diff --git a/.github/workflows/gnu.yml b/.github/workflows/gnu.yml index af3c5555f..df920ec4f 100644 --- a/.github/workflows/gnu.yml +++ b/.github/workflows/gnu.yml @@ -25,7 +25,7 @@ jobs: - name: checkout-ww3 if: steps.cache-env.outputs.cache-hit != 'true' uses: actions/checkout@v2 - with: + with: path: ww3 # Cache spack, OASIS, and compiler # No way to flush Action cache, so key may have # appended diff --git a/.github/workflows/intel.yml b/.github/workflows/intel.yml index 4c43c3053..eec7697ae 100644 --- a/.github/workflows/intel.yml +++ b/.github/workflows/intel.yml @@ -34,7 +34,7 @@ jobs: - name: checkout-ww3 if: steps.cache-env.outputs.cache-hit != 'true' uses: actions/checkout@v2 - with: + with: path: ww3 # Cache spack, OASIS, and compiler diff --git a/cmake/FindMETIS.cmake b/cmake/FindMETIS.cmake index c4f854db7..03fcb28b5 100644 --- a/cmake/FindMETIS.cmake +++ b/cmake/FindMETIS.cmake @@ -14,5 +14,5 @@ find_package_handle_standard_args( ${CMAKE_FIND_PACKAGE_NAME} REQUIRED_VARS metis_lib metis_inc) - + message(STATUS "Found METIS: ${metis_lib}") diff --git a/model/bin/ad3.tmpl b/model/bin/ad3.tmpl index 713f5359f..e8fc59617 100755 --- a/model/bin/ad3.tmpl +++ b/model/bin/ad3.tmpl @@ -89,7 +89,7 @@ compress=0 # source code compression par in w3adc # if not 0, documentaion removed from .f90 file -# 1.d Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - +# 1.d Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv main_dir=$WWATCH3_DIR @@ -201,14 +201,14 @@ if [ "$w3adc" = 'yes' ] then -# 2.b Run CPP preprocessor - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# 2.b Run CPP preprocessor - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #Generate list of CPP Flags based on switches: CPPFLAGS=() - for sw in $sw_str - do + for sw in $sw_str + do CPPFLAGS+=("-DW3_$sw") - done + done CPPFLAGS+=("-D__WW3_SWITCHES__='$sw_str'") @@ -259,14 +259,14 @@ # rm -f *.mod ## too indiscriminate ## Using find -iname most succinct, but maybe not all version of find have - ## the -iname option? + ## the -iname option? # find . -iname "${name}.mod" -delete # not all versions of find have -iname? - # Fall back on grep -i + # Fall back on grep -i mods=`ls *.mod 2> /dev/null | grep -i "${name}.mod"` if [ -n ${mods} ]; then rm -f ${mods} - fi + fi # --------------------------------------------------------------------------- # # 3. Compile source code f / f90 # @@ -346,13 +346,13 @@ then ## ChrisB: Don't move all module files...could break parallel make. ## Just target specific module file (could be mixed case filename ## depending on compiler - use case insensitive find): -# mods=`ls *.mod 2> /dev/null` +# mods=`ls *.mod 2> /dev/null` ## Using find -iname most succinct, but maybe not all version of find have - ## the -iname option? + ## the -iname option? # mods=`find . -iname "${name}.mod"` # not all versions of find have -iname? - # Fall back on grep -i + # Fall back on grep -i mods=`ls *.mod 2> /dev/null | grep -i "${name}.mod"` if [ -n "$mods" ] then diff --git a/model/bin/all_switches b/model/bin/all_switches index d02d5eb6b..72e645e92 100755 --- a/model/bin/all_switches +++ b/model/bin/all_switches @@ -26,7 +26,7 @@ echo 'Find all switches in WAVEWATCH III' echo '----------------------------------' -# 1.b Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - +# 1.b Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv main_dir=$WWATCH3_DIR diff --git a/model/bin/cmplr.env b/model/bin/cmplr.env index 75674b094..217e6be3a 100644 --- a/model/bin/cmplr.env +++ b/model/bin/cmplr.env @@ -21,7 +21,7 @@ # remarks : # # # # - template files comp.tmpl and link.tmpl will be used to create the # -# comp and link file based on the following environment variables : # +# comp and link file based on the following environment variables : # # $optc, $optl, $comp_seq, $comp_mpi, $optomp, $err_pattern, $warn_pattern # # # # # @@ -61,8 +61,8 @@ if [ "$cmplr" == "mpt" ] || [ "$cmplr" == "mpt_debug" ] || [ "$cmplr" == "mpt_pr comp_seq='ftn' comp_mpi='ftn' fi - - + + # OPTIONS - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # common options @@ -104,7 +104,7 @@ if [ "$cmplr" == "mpt" ] || [ "$cmplr" == "mpt_debug" ] || [ "$cmplr" == "mpt_pr optl="$optl -xhost" fi - #Flags for CPP: + #Flags for CPP: cppad3procflag='-E' cppad3flag2=' ' cppad3flag3='-o' @@ -140,7 +140,7 @@ if [ "$cmplr" == "intel" ] || [ "$cmplr" == "intel_debug" ] || [ "$c comp_seq='ftn' comp_mpi='ftn' fi - + if [ ! -z "$(echo $cmplr | grep cheyenne)" ] ; then comp_seq='ifort' comp_mpi='mpif90' @@ -162,7 +162,7 @@ if [ "$cmplr" == "intel" ] || [ "$cmplr" == "intel_debug" ] || [ "$c if [ ! -z "$(echo $cmplr | grep datarmor)" ] || [ "$cmplr" == "hera.intel" ] || [ "$cmplr" == "orion.intel" ] || \ [ "$cmplr" == "wcoss_cray" ] || [ "$cmplr" == "wcoss_dell_p3" ] || [ "$cmplr" == "cheyenne.intel" ] || \ [ "$cmplr" == "gaea.intel" ] || [ "$cmplr" == "jet.intel" ] || [ "$cmplr" == "wcoss2" ] || \ - [ "$cmplr" == "stampede.intel" ] || [ "$cmplr" == "s4.intel" ] || [ "$cmplr" == "expanse.intel" ] ; then + [ "$cmplr" == "stampede.intel" ] || [ "$cmplr" == "s4.intel" ] || [ "$cmplr" == "expanse.intel" ] ; then optomp="-qopenmp" else optomp="-openmp" @@ -219,7 +219,7 @@ if [ "$cmplr" == "intel" ] || [ "$cmplr" == "intel_debug" ] || [ "$c fi - #Flags for CPP: + #Flags for CPP: cppad3procflag='-E' cppad3flag2=' ' cppad3flag3='>' @@ -301,7 +301,7 @@ if [ "$cmplr" == "gnu" ] || [ "$cmplr" == "gnu_debug" ] || [ "$cmplr" == "gnu_pr optc="$optc -fPIC" fi - #Flags for CPP: + #Flags for CPP: cppad3procflag='-E' cppad3flag2=' ' cppad3flag3='-o' @@ -361,7 +361,7 @@ if [ "$cmplr" == "pgi" ] || [ "$cmplr" == "pgi_debug" ] || [ "$cmplr" == "pgi_pr optl="$optl" fi - #Flags for CPP: + #Flags for CPP: cppad3procflag='-E' cppad3flag2=' ' cppad3flag3='>' @@ -419,7 +419,7 @@ if [ "$cmplr" == "ukmo_cray" ] || [ "$cmplr" == "ukmo_cray_debug" ] || \ # system-dependant options # N/A - #Flags for CPP: + #Flags for CPP: cppad3procflag='-eP' cppad3flag2=' ' cppad3flag3='#' diff --git a/model/bin/comp.tmpl b/model/bin/comp.tmpl index 6a39bc778..3dc544c56 100755 --- a/model/bin/comp.tmpl +++ b/model/bin/comp.tmpl @@ -46,7 +46,7 @@ name="$1" echo " Compiling $name" -# 1.b Initial clean-up - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# 1.b Initial clean-up - - - - - - - - - - - - - - - - - - - - - - - - - - - - rm -f $name.l rm -f $name.o @@ -120,7 +120,7 @@ fi fi -# 3.b Make file comp.stat - - - - - - - - - - - - - - - - - - - - - - - - - - +# 3.b Make file comp.stat - - - - - - - - - - - - - - - - - - - - - - - - - - echo "ERROR $nr_err" > comp.stat.$name echo "WARNING $nr_war" >> comp.stat.$name @@ -131,12 +131,12 @@ # comment lines are to be numbered. # listing done by the compiler - if [ -s $name.lst ] + if [ -s $name.lst ] then mv $name.lst $name.l fi # add comp options, warnings and error to listing - if [ -s $name.l ] + if [ -s $name.l ] then echo '------------' >> $name.l echo "$comp $opt" >> $name.l diff --git a/model/bin/find_switch b/model/bin/find_switch index 3ed3a7a04..ae4cca2dc 100755 --- a/model/bin/find_switch +++ b/model/bin/find_switch @@ -26,7 +26,7 @@ echo 'Find switches in WAVEWATCH III' echo '------------------------------' -# 1.b Process/save input - - - - - - - - - - - - - - - - - - - - - - - - - - - +# 1.b Process/save input - - - - - - - - - - - - - - - - - - - - - - - - - - - if test "$#" != '0' then @@ -38,7 +38,7 @@ echo ' ' ; echo "Files including $switch :" ; echo ' ' -# 1.c Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - +# 1.c Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv main_dir=$WWATCH3_DIR @@ -46,13 +46,13 @@ source=$WWATCH3_SOURCE list=$WWATCH3_LIST -# 1.d Raw data file - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# 1.d Raw data file - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -### TO DO: This needs to be improved for CPP transition +### TO DO: This needs to be improved for CPP transition cd $main_dir/src grep "$switch" * | sed 's/\:/ /' | awk '{ print $1}' > ../.switch.files -# 1.e Output - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# 1.e Output - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - last=$NULL for file in `cat ../.switch.files` diff --git a/model/bin/link.tmpl b/model/bin/link.tmpl index 016ca6870..55c33103c 100755 --- a/model/bin/link.tmpl +++ b/model/bin/link.tmpl @@ -33,7 +33,7 @@ echo " Linking $prog" input="$*" -# 1.b Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - +# 1.b Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv main_dir=$WWATCH3_DIR @@ -42,7 +42,7 @@ list=$WWATCH3_LIST -# 1.c Initial clean-up - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# 1.c Initial clean-up - - - - - - - - - - - - - - - - - - - - - - - - - - - - rm -f $main_dir/exe/$prog @@ -117,7 +117,7 @@ libs="$libs `$NETCDF_CONFIG --flibs` `$NETCDF_CONFIG --libs`" fi - # parmetis library + # parmetis library if [ "$prog" = 'ww3_shel' ] || [ "$prog" = 'ww3_multi' ] || [ "$prog" = 'ww3_sbs1' ] ; then if [ "$pdlib_mod" = 'yes' ] ; then if [ -z "$(env | grep METIS_PATH)" ] ; then @@ -125,7 +125,7 @@ echo "[ERROR] METIS_PATH is not defined" exit 1 fi - echo "link with parmetis" + echo "link with parmetis" libs="$libs $METIS_PATH/lib/libparmetis.a $METIS_PATH/lib/libmetis.a" fi fi diff --git a/model/bin/make_makefile.sh b/model/bin/make_makefile.sh index a114f9d3a..9a94b9e9f 100755 --- a/model/bin/make_makefile.sh +++ b/model/bin/make_makefile.sh @@ -126,7 +126,7 @@ # Get file - the list of files to be compiled # and filel - list of files for linking a particular prog create_file_list - + case $prog in ww3_grid) IDstring='Grid preprocessor' ;; ww3_strt) IDstring='Initial conditions program' ;; diff --git a/model/bin/sort_all_switches b/model/bin/sort_all_switches index 957488159..ade2142f7 100755 --- a/model/bin/sort_all_switches +++ b/model/bin/sort_all_switches @@ -45,7 +45,7 @@ Options: otherwise this gives an error exit EOF } - + # 1.a.3 Process input (part 1) args=`getopt $optstr $*` @@ -75,7 +75,7 @@ EOF exit 1 fi -# 1.a.4 Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - +# 1.a.4 Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv main_dir=$WWATCH3_DIR diff --git a/model/bin/sort_switch b/model/bin/sort_switch index ce6f8ed2b..5167fbba2 100755 --- a/model/bin/sort_switch +++ b/model/bin/sort_switch @@ -60,7 +60,7 @@ Options: -v : verbose, show program output EOF } - + # 1.a.3 Process input (part 1) args=`getopt $optstr $*` @@ -112,14 +112,14 @@ EOF exit 2 fi -# 1.a.4 Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - +# 1.a.4 Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv main_dir=$WWATCH3_DIR temp_dir=$WWATCH3_TMP source=$WWATCH3_SOURCE list=$WWATCH3_LIST - + # 1.a.5 Process input (part 2) bin_dir="$main_dir/exe" @@ -133,7 +133,7 @@ EOF if [ ! -f $script ] ; then echo " *** cannot find $script ***" ; exit 5 ; fi - + # 1.a.6 Additional setups outs="O0 O1 O2 O2a O2b O2c O3 O4 O5 O6 O7 O7a O7b O8 O9 O10 O11 O12 O13 O14 O15 O16" @@ -162,7 +162,7 @@ EOF echo ' ' fi -# 1.d Set up work space - - - - - - - - - - - - - - - - - - - - - - - - - - - +# 1.d Set up work space - - - - - - - - - - - - - - - - - - - - - - - - - - - cd $temp_dir @@ -300,7 +300,7 @@ EOF fi fi done - + done if [ "$verbose" ] @@ -433,7 +433,7 @@ EOF # --------------------------------------------------------------------------- # # 4. Dealing with left over switches # # --------------------------------------------------------------------------- # -# 4.a Loop over additional types +# 4.a Loop over additional types for type in out strace test do @@ -457,7 +457,7 @@ EOF # 4.c Loop over switchs - for sw in $switches + for sw in $switches do i_fnd='0' found= diff --git a/model/bin/w3_make b/model/bin/w3_make index b2369df09..308cad9a3 100755 --- a/model/bin/w3_make +++ b/model/bin/w3_make @@ -53,7 +53,7 @@ fi -# 1.c Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - +# 1.c Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv main_dir=$WWATCH3_DIR @@ -142,7 +142,7 @@ reg_programs="$reg_programs ww3_gint" reg_programs="$reg_programs gx_outf" reg_programs="$reg_programs gx_outp" - reg_programs="$reg_programs ww3_uprstr" + reg_programs="$reg_programs ww3_uprstr" # PRNC OUNF OUNP BOUNC TRNC cdf_programs="ww3_prnc" @@ -197,7 +197,7 @@ reg_programs="$reg_programs ww3_prep" fi - #SHEL + #SHEL if [ -n "`grep OASIS $switch_file`" ] || [ -n "`grep PDLIB $switch_file`" ] then cdf_programs="$cdf_programs ww3_shel" @@ -237,9 +237,9 @@ pres_type='SEQ' flag_OMP=`grep OMP $switch_file | wc -l | awk '{ print $1}'` if [ "$flag_OMP" -gt '0' ] - then + then pres_type='OMP' - fi + fi else if [ "$flag_OMPH" -gt '0' ] then @@ -265,7 +265,7 @@ -# 1.g Setup for NetCDF compile - - - - - - - - - - - - - - - - - - - - - - - - +# 1.g Setup for NetCDF compile - - - - - - - - - - - - - - - - - - - - - - - - # 1.g.1 NetCDF compile message function @@ -285,10 +285,10 @@ is required: The nc-config utility (part of the NetCDF-4 install) is used to determine the appropriate compile and link flags. -For NetCDF routines to compile, WAVEWATCH III requires -NetCDF version 4.1.1 or higher. Use "nc-config --version" to check -the version of the installed NetCDF. It is also required for NetCDF -to be compiled with the NetCDF-4 API enabled. Use "nc-config --has-nc4" +For NetCDF routines to compile, WAVEWATCH III requires +NetCDF version 4.1.1 or higher. Use "nc-config --version" to check +the version of the installed NetCDF. It is also required for NetCDF +to be compiled with the NetCDF-4 API enabled. Use "nc-config --has-nc4" to check if the installed NetCDF has the NetCDF-4 API enabled. *********************************************************************** @@ -340,7 +340,7 @@ EOF echo "will not be compiled unless NetCDF compile environment is properly set."; echo ' ' echo "Continuing with compile of non-NetCDF programs ..."; echo ' ' all_programs="$reg_programs" - else + else all_programs="$reg_programs $cdf_programs" fi else @@ -370,10 +370,10 @@ EOF # 1.h set progs list - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # no filtering is done to distinguish sequential to parallel programs + # no filtering is done to distinguish sequential to parallel programs progs=$all_programs -# 1.i Prepare scratch directory - - - - - - - - - - - - - - - - - - - - - - - +# 1.i Prepare scratch directory - - - - - - - - - - - - - - - - - - - - - - - if test ! -d $temp_dir then @@ -418,7 +418,7 @@ EOF then cp $switch_file ${switch_file_old}_OMP cp $makefile ${makefile}_OMP - else + else cp $switch_file ${switch_file_old}_SEQ cp $makefile ${makefile}_SEQ fi @@ -438,7 +438,7 @@ EOF fi echo ' ' -# 1.k Export paths - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# 1.k Export paths - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - aPb="$main_dir/bin" # path containing shell scripts aPo="$main_dir/obj" # path containing .o files @@ -457,7 +457,7 @@ EOF echo "Processing $prog" echo "---------------------" -# 2.b Check input - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# 2.b Check input - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - OK='n' for check in $all_programs @@ -473,7 +473,7 @@ EOF echo ' ' exit 1 -# 2.c Run make - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# 2.c Run make - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else @@ -499,14 +499,14 @@ EOF export omp_mod oasis_mod=no - if [ -n "`grep OASIS $switch_file`" ] + if [ -n "`grep OASIS $switch_file`" ] then export oasis_mod='yes' fi export oasis_mod pdlib_mod=no - esmfpdlib='' + esmfpdlib='' if [ -n "`grep PDLIB $switch_file`" ] then export pdlib_mod='yes' @@ -516,14 +516,14 @@ EOF # NCEP GRIB export ncep_grib_compile="no" - #check for switch file: + #check for switch file: if [ -n "`grep NCEP $switch_file`" ] then - #only set to yes if compiling ww3_grib: + #only set to yes if compiling ww3_grib: if [ -n "`echo $prog | grep ww3_grib`" ] then export ncep_grib_compile="yes" - fi + fi fi # if esmf is included in program name, then the compile @@ -531,7 +531,7 @@ EOF # processed to get required ESMF compile options if [ -n "`echo $prog | grep esmf 2>/dev/null`" ] then - if [ -z "`grep DIST $switch_file`" ] + if [ -z "`grep DIST $switch_file`" ] then echo ' ' echo "*** DIST switch must be set when compiling with ESMF ***" @@ -610,10 +610,10 @@ EOF then mod_dir=$main_dir/mod_HYB obj_dir=$main_dir/obj_HYB - else + else mod_dir=$main_dir/mod_MPI obj_dir=$main_dir/obj_MPI - fi + fi rm -f $mkfile touch $mkfile echo "#-----------------------------------------------" >> $mkfile @@ -634,11 +634,11 @@ EOF done -# 2.d copy comp and link +# 2.d copy comp and link cp $main_dir/bin/comp $main_dir/exe/ cp $main_dir/bin/link $main_dir/exe/ - + # --------------------------------------------------------------------------- # # 3. End of program ID. # # --------------------------------------------------------------------------- # diff --git a/model/esmf/README b/model/esmf/README index 68a826326..4102026a5 100644 --- a/model/esmf/README +++ b/model/esmf/README @@ -20,7 +20,7 @@ concomp.F90: coupled application connector component mdl.F90: coupled application model components (ATM, OCN, or ICE) dum.F90: dummy model component utl.F90: utilities module -Makefile: the +Makefile: the The WAV model component is Wavewatch (wmesmfmd.ftn). diff --git a/model/esmf/concomp.F90 b/model/esmf/concomp.F90 index 8dbc693de..9ee7d61e1 100644 --- a/model/esmf/concomp.F90 +++ b/model/esmf/concomp.F90 @@ -288,7 +288,7 @@ subroutine ComputeRH(ccomp, rc) if (verbose) & call ESMF_LogWrite(trim(cname)//': leaving ComputeRH', ESMF_LOGMSG_INFO) - + end subroutine !----------------------------------------------------------------------------- @@ -345,7 +345,7 @@ subroutine ExecuteRH(ccomp, rc) if (verbose) & call ESMF_LogWrite(trim(cname)//': leaving ExecuteRH', ESMF_LOGMSG_INFO) - + end subroutine !----------------------------------------------------------------------------- diff --git a/model/esmf/esmApp.F90 b/model/esmf/esmApp.F90 index 3aa7a369f..3610dc982 100644 --- a/model/esmf/esmApp.F90 +++ b/model/esmf/esmApp.F90 @@ -22,7 +22,7 @@ program esmApp integer :: argCount type(ESMF_Config) :: config character(ESMF_MAXSTR) :: configFile - + ! Initialize ESMF call ESMF_Initialize(logkindflag=ESMF_LOGKIND_MULTI, & defaultCalkind=ESMF_CALKIND_GREGORIAN, rc=rc) @@ -53,31 +53,31 @@ program esmApp if (ESMF_LogFoundError(rc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_GridCompSet(gcomp, config=config, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + ! SetServices for the driver Component call ESMF_GridCompSetServices(gcomp, drmSS, userRc=urc, rc=rc) if (ESMF_LogFoundError( rc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) if (ESMF_LogFoundError(urc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + ! Call Initialize for the driver Component call ESMF_GridCompInitialize(gcomp, userRc=urc, rc=rc) if (ESMF_LogFoundError( rc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) if (ESMF_LogFoundError(urc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + ! Call Run for the driver Component call ESMF_GridCompRun(gcomp, userRc=urc, rc=rc) if (ESMF_LogFoundError( rc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) if (ESMF_LogFoundError(urc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + ! Call Finalize for the driver Component call ESMF_GridCompFinalize(gcomp, userRc=urc, rc=rc) if (ESMF_LogFoundError( rc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) if (ESMF_LogFoundError(urc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + ! Destroy the driver Component call ESMF_GridCompDestroy(gcomp, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + ! Finalize ESMF call ESMF_Finalize() @@ -95,4 +95,4 @@ subroutine DummyRoutine(rc) end subroutine -end program +end program diff --git a/model/inp/gx_outp.inp b/model/inp/gx_outp.inp index 5cea65265..95f70950e 100644 --- a/model/inp/gx_outp.inp +++ b/model/inp/gx_outp.inp @@ -1,13 +1,13 @@ $ -------------------------------------------------------------------- $ $ WAVEWATCH III Point output post-processing ( GrADS ) $ $--------------------------------------------------------------------- $ -$ First output time (yyyymmdd hhmmss), increment of output (s), +$ First output time (yyyymmdd hhmmss), increment of output (s), $ and number of output times. $ 19680606 000000 3600. 7 $ $ Points requested --------------------------------------------------- $ -$ Define points for which output is to be generated. +$ Define points for which output is to be generated. $ $ 1 $ 2 @@ -19,7 +19,7 @@ $ $ -------------------------------------------------------------------- $ $ Flags for plotting F, Sin, Snl, Sds, Sbt, Sice, Stot $ - T T T T T T T + T T T T T T T $ $ NOTE : In the Cartesian grid version of the code, X and Y are $ converted to km. Use source_xy.gs instead of source.gs diff --git a/model/inp/ww3_bounc.inp b/model/inp/ww3_bounc.inp index 672a0dc34..df312407e 100644 --- a/model/inp/ww3_bounc.inp +++ b/model/inp/ww3_bounc.inp @@ -4,16 +4,16 @@ $--------------------------------------------------------------------- $ $ $ Boundary option: READ or WRITE $ - WRITE + WRITE $ $ Interpolation method: 1: nearest $ 2: linear interpolation - 2 + 2 $ Verbose (0, 1, 2) 1 $ $ List of spectra files. These NetCDF files use the WAVEWATCH III -$ format as described in the ww3_ounp.inp file. The files are +$ format as described in the ww3_ounp.inp file. The files are $ defined relative to the directory in which the program is run. $ $ Note: When using a rotated pole WW3 grid, these input spectra are diff --git a/model/inp/ww3_bound.inp b/model/inp/ww3_bound.inp index 05976bd41..79d52b3be 100644 --- a/model/inp/ww3_bound.inp +++ b/model/inp/ww3_bound.inp @@ -4,21 +4,21 @@ $--------------------------------------------------------------------- $ $ $ Boundary option: READ or WRITE $ - WRITE + WRITE $ $ Interpolation method: 1: nearest $ 2: linear interpolation - 2 + 2 $ $ Verbose mode [0-1] $ 0 $ $ List of spectra files. These ASCII files use the WAVEWATCH III -$ format as described in the ww3_outp.inp file. The files are +$ format as described in the ww3_outp.inp file. The files are $ defined relative to the directory in which the program is run. $ -$ Examples of such files can be found at (for example): +$ Examples of such files can be found at (for example): $ ftp://polar.ncep.noaa.gov/pub/waves/develop/glw.latest_run/ $ (the *.spec.gz files) $ http://tinyurl.com/iowagaftp/HINDCAST/GLOBAL/2009_ECMWF/SPEC @@ -29,7 +29,7 @@ $ $ Note: When using a rotated pole WW3 grid, these input spectra are $ always assumed to be formulated on a standard pole. $ -$ In the case of NetCDF files see ww3_bounc.inp +$ In the case of NetCDF files see ww3_bounc.inp $ SPECTRI/mww3.W004N476.spec SPECTRI/mww3.W0042N476.spec @@ -46,7 +46,7 @@ SPECTRI/mww3.W006N482.spec SPECTRI/mww3.W006N486.spec SPECTRI/mww3.W006N489.spec 'STOPSTRING' -$ +$ $ -------------------------------------------------------------------- $ $ End of input file $ $ -------------------------------------------------------------------- $ diff --git a/model/inp/ww3_gint.inp b/model/inp/ww3_gint.inp index b141c1c89..82a01ed55 100644 --- a/model/inp/ww3_gint.inp +++ b/model/inp/ww3_gint.inp @@ -5,10 +5,10 @@ $ Time, time increment and number of outputs $ 19680606 060000 10800. 1 $ -$ Total number of grids (NGR). The code assumes that the first NGR-1 -$ grids are the input grids and the last grid is the target grid in +$ Total number of grids (NGR). The code assumes that the first NGR-1 +$ grids are the input grids and the last grid is the target grid in $ which the output fields are to be interpolated. It also assumes -$ that all the grids have the same output fields switched on +$ that all the grids have the same output fields switched on $ $ NGR $ @@ -36,4 +36,4 @@ $ 2: Nearest (curvilinear and rectangular) $ $ -------------------------------------------------------------------- $ $ End of input file $ -$ -------------------------------------------------------------------- $ +$ -------------------------------------------------------------------- $ diff --git a/model/inp/ww3_grib.inp b/model/inp/ww3_grib.inp index 8519842ac..bf8b76e84 100644 --- a/model/inp/ww3_grib.inp +++ b/model/inp/ww3_grib.inp @@ -5,11 +5,11 @@ $ Time, time increment and number of outputs. $ 19680606 000000 3600. 3 $ -$ Time, time increment and number of outputs. Option to encode grib2 +$ Time, time increment and number of outputs. Option to encode grib2 $ from ensemble runs (replace line above with commented line below). -$ Usage: include additional (optional) 5th parameter -$ 0 - deterministic (default) -$ 1 - ensemble run +$ Usage: include additional (optional) 5th parameter +$ 0 - deterministic (default) +$ 1 - ensemble run $ 19680606 000000 3600. 3 1 $ $ Output request flags identifying fields as in ww3_shel.inp. See that @@ -22,15 +22,15 @@ $ $ Additional info needed for grib file $ Forecast time, center ID, generating process ID, grid definition, $ GDS/BMS flag and grid definition template number GDTN (0 = regular; -$ 30 = Lambert Conformal, only these two types available now) +$ 30 = Lambert Conformal, only these two types available now) $ 19680606 010000 7 10 255 192 0 $ -$ if GDTN is 30 (lambert conformal) read next line with proj parms -$ LATAN1, LONV, DSX, DSY, SCNMOD, LATIN1, LATIN2, LATSP, LONSP -$ Example for the GLW grid at NCEP -$ 25 265 2.539703 2.539703 64 25 25 -90 0 -$ Other curvilinear grids not yet implemented +$ if GDTN is 30 (lambert conformal) read next line with proj parms +$ LATAN1, LONV, DSX, DSY, SCNMOD, LATIN1, LATIN2, LATSP, LONSP +$ Example for the GLW grid at NCEP +$ 25 265 2.539703 2.539703 64 25 25 -90 0 +$ Other curvilinear grids not yet implemented $ $ -------------------------------------------------------------------- $ $ End of input file $ diff --git a/model/inp/ww3_grid.inp b/model/inp/ww3_grid.inp index 084e0abd8..61f9e0e01 100644 --- a/model/inp/ww3_grid.inp +++ b/model/inp/ww3_grid.inp @@ -78,14 +78,14 @@ $ BETAMAX : maximum value of wind-wave coupling $ SINTHP : power of cosine in wind input $ ZALP : wave age shift to account for gustiness $ TAUWSHELTER : sheltering of short waves to reduce u_star -$ SWELLFPAR : choice of swell attenuation formulation +$ SWELLFPAR : choice of swell attenuation formulation $ (1: TC 1996, 3: ACC 2008) $ SWELLF : swell attenuation factor -$ Extra parameters for SWELLFPAR=3 only -$ SWELLF2, SWELLF3 : swell attenuation factors +$ Extra parameters for SWELLFPAR=3 only +$ SWELLF2, SWELLF3 : swell attenuation factors $ SWELLF4 : Threshold Reynolds number for ACC2008 $ SWELLF5 : Relative viscous decay below threshold -$ Z0RAT : roughness for oscil. flow / mean flow +$ Z0RAT : roughness for oscil. flow / mean flow $ BYDRZ input : Namelist SIN6 $ SINA0 : factor for negative input $ SINWS : wind speed scaling option @@ -169,17 +169,17 @@ $ $ WAM4 and variants : Namelist SDS3 $ SDSC1 : WAM4 Cds coeffient $ MNMEANP, WNMEANPTAIL : power of wavenumber -$ for mean definitions in Sds and tail -$ SDSDELTA1, SDSDELTA2 : relative weights +$ for mean definitions in Sds and tail +$ SDSDELTA1, SDSDELTA2 : relative weights $ of k and k^2 parts of WAM4 dissipation -$ SDSLF, SDSHF : coefficient for activation of -$ WAM4 dissipation for unsaturated (SDSLF) and +$ SDSLF, SDSHF : coefficient for activation of +$ WAM4 dissipation for unsaturated (SDSLF) and $ saturated (SDSHF) parts of the spectrum $ SDSC2 : Saturation dissipation coefficient $ SDSC4 : Value of B0=B/Br for wich Sds is zero $ SDSBR : Threshold Br for saturation $ SDSP : power of (B/Br-B0) in Sds -$ SDSBR2 : Threshold Br2 for the separation of +$ SDSBR2 : Threshold Br2 for the separation of $ WAM4 dissipation in saturated and non-saturated $ SDSC5 : coefficient for turbulence dissipation $ SDSC6 : Weight for the istropic part of Sds_SAT @@ -204,27 +204,27 @@ $ BJGAM : Breaking threshold (default = 0.73) $ BJFLAG : TRUE - Use Hmax/d ratio only (default) $ FALSE - Use Hmax/d in Miche formulation $ -$ Dissipation in the ice - - - - - - - - - - - - - - - - - - - - - - +$ Dissipation in the ice - - - - - - - - - - - - - - - - - - - - - - $ Generalization of Liu et al. : Namelist SIC2 $ IC2DISPER : If true uses Liu formulation with eddy viscosity -$ If false, uses the generalization with turbulent -$ to laminar transition +$ If false, uses the generalization with turbulent +$ to laminar transition $ IC2TURB : empirical factor for the turbulent part -$ IC2ROUGH : under-ice roughness length -$ IC2REYNOLDS: Re number for laminar to turbulent transition +$ IC2ROUGH : under-ice roughness length +$ IC2REYNOLDS: Re number for laminar to turbulent transition $ IC2SMOOTH : smoothing of transition reprensenting random waves -$ IC2VISC : empirical factor for viscous part +$ IC2VISC : empirical factor for viscous part $ $ -$ Scattering in the ice & creep dissipations- - - - - - - - - - - - - +$ Scattering in the ice & creep dissipations- - - - - - - - - - - - - $ Generalization of Wiliams et al. : Namelist SIS2 $ ISC1 : scattering coefficient (default = 1) $ IS2BACKSCAT : fraction of energy back-scattered (default = 1 ) $ IS2BREAK : TRUE - changes floe max diameter $ : FALSE - does not change floe max diameter -$ IS2C1 : scattering in pack ice -$ IS2C2 : frequency dependance of scattering in pack ice -$ IS2C3 : frequency dependance of scattering in pack ice +$ IS2C1 : scattering in pack ice +$ IS2C2 : frequency dependance of scattering in pack ice +$ IS2C3 : frequency dependance of scattering in pack ice $ ISBACKSCAT : fraction of scattered energy actualy redistributed $ IS2DISP : use of ice-specific dispersion relation (T/F) $ FRAGILITY : parameter between 0 and 1 that gives the shape of FSD @@ -246,31 +246,31 @@ $ $ Triad nonlinear interactions - - - - - - - - - - - - - - - - - - - - $ Lumped Triad Interaction (LTA) : Namelist STR1 (To be implemented) $ PTRIAD1 : Proportionality coefficient (default 0.05) -$ PTRIAD2 : Multiple of Tm01 up to which interaction +$ PTRIAD2 : Multiple of Tm01 up to which interaction $ is computed (2.5) $ PTRIAD3 : Ursell upper limit for computing $ interactions (not used, default 10.) $ PTRIAD4 : Shape parameter for biphase $ computation (0.2) -$ PTRIAD5 : Ursell number treshold for computing +$ PTRIAD5 : Ursell number treshold for computing $ interactions (0.01) $ -$ Shoreline reflections - - - - - - - - - - - - - - - - - - - - - - - - -$ ref. parameters : Namelist REF1 +$ Shoreline reflections - - - - - - - - - - - - - - - - - - - - - - - - +$ ref. parameters : Namelist REF1 $ REFCOAST : Reflection coefficient at shoreline -$ REFFREQ : Activation of freq-dependent ref. +$ REFFREQ : Activation of freq-dependent ref. $ REFMAP : Scale factor for bottom slope map -$ REFRMAX : maximum ref. coeffient (default 0.8) -$ REFFREQPOW: power of frequency +$ REFRMAX : maximum ref. coeffient (default 0.8) +$ REFFREQPOW: power of frequency $ REFICEBERG: Reflection coefficient for icebergs $ REFSUBGRID: Reflection coefficient for islands -$ REFCOSP_STRAIGHT: power of cosine used for +$ REFCOSP_STRAIGHT: power of cosine used for $ straight shoreline $ -$ Bound 2nd order spectrum and free IG - - - - - - - - - - - - - - - - - +$ Bound 2nd order spectrum and free IG - - - - - - - - - - - - - - - - - $ IG1 parameters : Namelist SIG1 $ IGMETHOD : 1: Hasselmann, 2: Krasitskii-Janssen -$ IGADDOUTP : activation of bound wave correction +$ IGADDOUTP : activation of bound wave correction $ in ww3_outp / ww3_ounp $ IGSOURCE : 1: uses bound waves, 2: empirical $ IGSTERMS : > 0 : no source term in IG band @@ -304,7 +304,7 @@ $ All tuneable parameters are associated with the refraction $ limitation and the GSE alleviation. $ $ Unstructured grids ------------------------------------------------ $ -$ UNST parameters : Namelist UNST +$ UNST parameters : Namelist UNST $ UGOBCAUTO : TRUE: OBC points are taken from type 15 elements $ FALSE: OBC points must be listed in ww3_grid.inp $ UGOBCDEPTH: Threshold ( < 0) depth for OBC points if UGOBCAUTO is TRUE @@ -323,7 +323,7 @@ $ JGS_TERMINATE_NORM : terminate based on the norm of $ JGS_USE_JACOBI : Use Jacobi solver for imptotal $ JGS_BLOCK_GAUSS_SEIDEL : Use Block Gauss Seidel method for imptotal $ JGS_MAXITER : max. Number of solver iterations -$ JGS_PMIN : % of grid points that do not need to converge during solver iteration. +$ JGS_PMIN : % of grid points that do not need to converge during solver iteration. $ JGS_DIFF_THR : implicit solver threshold for JGS_TERMINATE_DIFFERENCE $ JGS_NORM_THR : terminate based on the norm of the solution $ SETUP_APPLY_WLV : Compute wave setup (experimental) @@ -334,10 +334,10 @@ $ SMC grid propagation : Namelist PSMC and default values $ CFLSM : Maximum CFL no. for propagation, 0.7 $ DTIMS : Swell age for diffusion term (s), 360.0 $ RFMAXD : Maximum refraction turning (deg), 36.0 -$ LvSMC : No. of refinement level, default 1 -$ ISHFT : Shift number of i-index, default 0 -$ JEQT : Shift number of j-index, default 0 -$ NBISMC : No. of input boundary points, 0 +$ LvSMC : No. of refinement level, default 1 +$ ISHFT : Shift number of i-index, default 0 +$ JEQT : Shift number of j-index, default 0 +$ NBISMC : No. of input boundary points, 0 $ AVERG : Add extra spatial averaging, .TRUE. $ UNO3 : Use 3rd order advection scheme, .FALSE. $ SEAWND : Use sea-point only wind input. .FALSE. @@ -354,7 +354,7 @@ $ $ Compile switch /RTD required. $ $ These will be used to derive rotation angle corrections in the -$ model. The corrections are used for rotation of boundary spectra +$ model. The corrections are used for rotation of boundary spectra $ and for restoring conventional lat/lon orientation of the $ output spectra, mean direction or any related variables. $ The PLAT/LON example below is a standard setting for Met @@ -385,22 +385,22 @@ $ $ &ROTB BPLAT(1)=90., BPLON(1)=-180., BPLAT(2)=90. / $ (etc.) $ $ Output of 3D arrays------------------------------------------------- $ -$ In order to limit the use of memory, arrays for 3D output fiels (i.e. -$ variables that are a function of both space and frequency, are not +$ In order to limit the use of memory, arrays for 3D output fiels (i.e. +$ variables that are a function of both space and frequency, are not $ declared, and thus cannot be used, unless specified by namelists. -$ NB: Output of 'first 5' moments E, th1m, sth1m, th2, sth2m allows to estimate the full -$ directional spectrum using, e.g. MEM (Lygre&Krogstad 1986). +$ NB: Output of 'first 5' moments E, th1m, sth1m, th2, sth2m allows to estimate the full +$ directional spectrum using, e.g. MEM (Lygre&Krogstad 1986). $ $ Parameters (integers) : Namelist OUTS -$ For the frequency spectrum E(f) +$ For the frequency spectrum E(f) $ E3D : <=0: not declared, > 0: declared $ I1E3D : First frequency index of output (default is 1) $ I2E3D : Last frequency index of output (default is NK) -$ For the mean direction th1m(f), and spread sth1m(f) +$ For the mean direction th1m(f), and spread sth1m(f) $ TH1MF, STH1MF : <=0: not declared, > 0: declared $ I1TH1MF, I1STH1MF: First frequency index of output (default is 1) $ I2TH1MF, I2STH1MF: First frequency index of output (default is 1) -$ For the mean direction th2m(f), and spread sth2m(f) +$ For the mean direction th2m(f), and spread sth2m(f) $ TH2MF, STH2MF : <=0: not declared, > 0: declared $ I1TH2MF, I1STH2MF: First frequency index of output (default is 1) $ I2TH2MF, I2STH2MF: First frequency index of output (default is 1) @@ -417,7 +417,7 @@ $ STK_WN : List of wavenumbers (size of IUSSP) $ e.g.: USSP = 1, IUSSP=3, STK_WN = 0.04, 0.11, 0.33 $ provides 3 partitions of both x & y component, $ with a reasonable accuracy for using in -$ a climate model. +$ a climate model. $ $ Miscellaneous ------------------------------------------------------ $ $ Misc. parameters : Namelist MISC @@ -476,7 +476,7 @@ $ 0: Constant value (prescribed) $ 1: Wind speed dependent $ (Based on GFDL Hurricane $ Model Z0 relationship) -$ TAILLEV : Level of high frequency tail +$ TAILLEV : Level of high frequency tail $ (if TAILTYPE==0) $ Valid choices: $ Capped min: 0.001, max: 0.02 @@ -515,7 +515,7 @@ $ 1 Type of grid, coordinate system and type of closure: GSTRG, FLAGLL, $ CSTRG. Grid closure can only be applied in spherical coordinates. $ GSTRG : String indicating type of grid : $ 'RECT' : rectilinear -$ 'CURV' : curvilinear +$ 'CURV' : curvilinear $ 'UNST' : unstructured (triangle-based) $ 'SMCG' : Spherical Multiple-Cell grid. $ FLAGLL : Flag to indicate coordinate system : @@ -587,7 +587,7 @@ $ file. The y-coord must follow the above record. No comment lines are $ allowed within the y-coord input. $ $ ELSE IF ( UNSTRUCTURED GRID ) THEN -$ Nothing to declare: all the data will be read from the GMESH file +$ Nothing to declare: all the data will be read from the GMESH file $ END IF ( CURVILINEAR GRID ) $ $ 5 Limiting bottom depth (m) to discriminate between land and sea @@ -609,7 +609,7 @@ $ 'NAME' : open file by name and assign to unit. $ $ If the above unit number equals 10, then the bottom depths are read from $ this file. The depths must follow the above record. No comment lines are -$ allowed within the depth input. In the case of unstructured grids, the file +$ allowed within the depth input. In the case of unstructured grids, the file $ is expected to be a GMESH grid file containing node and element lists. $ $ ------------------------------------------------------------------------ @@ -689,15 +689,15 @@ $ 6 6 6 6 6 6 6 6 6 6 6 6 $ 6 6 6 6 6 6 6 6 6 6 6 6 $ $ ------------------------------------------------------------- -$ SMC grid use the same spherical lat-lon grid parameters +$ SMC grid use the same spherical lat-lon grid parameters $ 'SMCG' T 'SMPL' $ 1024 704 -$ SMC grid base level resolution dlon dlat and start lon lat +$ SMC grid base level resolution dlon dlat and start lon lat $ 0.35156250 0.23437500 1. $ 0.17578125 -78.6328125 1. $ $ Normal depth input line is used to passing the minimum depth -$ though the depth file is not read for SMC grid. +$ though the depth file is not read for SMC grid. $ -0.1 10.0 30 -1. 1 1 '(....)' 'NAME' 'SMC25Depth.dat' $ SMC cell and face arrays and obstruction ratio: $ 32 1 1 '(....)' 'S6125MCels.dat' @@ -706,14 +706,14 @@ $ 34 1 1 '(....)' 'S6125JSide.dat' $ 31 1.0 1 1 '(...)' 'NAME' 'SMC25Subtr.dat' $ The input boundary cell file is only needed when NBISMC > 0. $ 35 1 1 '(....)' 'S6125Bundy.dat' -$ Extra cell and face arrays for Arctic part if Arctic=.TRUE. is selected. +$ Extra cell and face arrays for Arctic part if Arctic=.TRUE. is selected. $ 36 1 1 '(....)' 'S6125MBArc.dat' $ 37 1 1 '(....)' 'S6125AISid.dat' $ 38 1 1 '(....)' 'S6125AJSid.dat' $ Normal land-sea mask file input line is kept but file is not used. $ 39 1 1 '(....)' 'NAME' 'S6125Masks.dat' -$ Boundary cell id list file (unit 35) is only required if boundary -$ cell number entered above is non-zero. The cell id number should be +$ Boundary cell id list file (unit 35) is only required if boundary +$ cell number entered above is non-zero. The cell id number should be $ the sequential number in the cell array (unit 32) S625MCels.dat. $ $ If sub-grid information is available as indicated by FLAGTR above, diff --git a/model/inp/ww3_gspl.inp b/model/inp/ww3_gspl.inp index c6375bd04..e28660a9e 100644 --- a/model/inp/ww3_gspl.inp +++ b/model/inp/ww3_gspl.inp @@ -9,7 +9,7 @@ $ Number of sub-grids to be created, maximum number of iterations, $ target grid point count std in percent. user defined halo extension $ (default should be 2, used because of inconsistencies between halo $ computation in this code and in the main wave model code). Increase -$ the latter number if ww3_multi fails on halo overlaps between +$ the latter number if ww3_multi fails on halo overlaps between $ equally ranked grids. $ 12 250 0.75 2 diff --git a/model/inp/ww3_multi.inp b/model/inp/ww3_multi.inp index fad6efc4d..740654efa 100644 --- a/model/inp/ww3_multi.inp +++ b/model/inp/ww3_multi.inp @@ -36,7 +36,7 @@ $ and the file wind.input to provide the corresponding wind data. $ $ -------------------------------------------------------------------- $ $ If all point output is gathered in a unified point output file -$ ( UNIPTS = .TRUE. ), then the output spectral grid needs to be +$ ( UNIPTS = .TRUE. ), then the output spectral grid needs to be $ defined. This information is taken from a wave model grid, and only $ the spectral definitions from this grid are relevant. Define the $ name of this grid here @@ -52,22 +52,22 @@ $ Now each actual wave model grid is defined using 13 parameters to be $ read from a single line in the file. Each line contains the following $ parameters $ 1) Define the grid with the extension of the mod_def file. -$ 2-10) Define the inputs used by the grids with 10 keywords +$ 2-10) Define the inputs used by the grids with 10 keywords $ corresponding to the 10 flags defining the input in the $ input files. Valid keywords are: $ 'no' : This input is not used. $ 'native' : This grid has its own input files, e.g. grid $ grdX (mod_def.grdX) uses ice.grdX. -$ 'MODID' : Take input from the grid identified by +$ 'MODID' : Take input from the grid identified by $ MODID. In the example below, all grids get $ their wind from wind.input (mod_def.input). $ 11) Rank number of grid (internally sorted and reassigned). $ 12) Group number (internally reassigned so that different $ ranks result in different group numbers. $ 13-14) Define fraction of communicator (processes) used for this -$ grid. '0.00 1.00' is appropriate in many cases. Partial -$ fractions, i.e. settings other than '0.00 1.00', are -$ intended for equal rank grids, to improve scaling. The +$ grid. '0.00 1.00' is appropriate in many cases. Partial +$ fractions, i.e. settings other than '0.00 1.00', are +$ intended for equal rank grids, to improve scaling. The $ commented example provided here (partial fractions with $ non-equal rank) is not generally recommended. $ 15) Flag identifying dumping of boundary data used by this @@ -89,7 +89,7 @@ $ $ Limitations relevant to irregular (curvilinear) grids: $ 1) Equal rank is not supported when one or more is an irregular $ grid. Use non-equal rank instead. (see wmgridmd.ftn) -$ 2) Non-native input grids: feature is not supported when either +$ 2) Non-native input grids: feature is not supported when either $ an input grid or computational grids is irregular. $ (see wmupdtmd.ftn) $ 3) Irregular grids with unified point output: This is supported @@ -103,7 +103,7 @@ $ $ $ -------------------------------------------------------------------- $ $ Specific multi-scale model settings (single line). -$ Flag for masking computation in two-way nesting (except at +$ Flag for masking computation in two-way nesting (except at $ output times). $ Flag for masking at printout time. $ @@ -165,7 +165,7 @@ $ 0.E3 0.E3 'STOPSTRING' $ $ Four additional output types: see ww3_shel.inp for documentation. -$ +$ $ track output 19680606 000000 0 19680608 000000 $ @@ -183,15 +183,15 @@ $ Output requests per grid and type to overwrite general setup $ as defined above. First record per set is the grid name MODID $ and the output type number. Then follows the standard time string, $ and conventional data as per output type. In mww3_test_05 this is -$ not used. Below, one example generating partitioning output for +$ not used. Below, one example generating partitioning output for $ the inner grid is included but commented out. $ $ 'grd3' 6 $ 19680606 000000 900 19680608 000000 -$ 0 999 1 0 999 1 T +$ 0 999 1 0 999 1 T $ $ -------------------------------------------------------------------- $ -$ Mandatory end of output requests per grid, identified by output +$ Mandatory end of output requests per grid, identified by output $ type set to 0. $ 'the_end' 0 diff --git a/model/inp/ww3_ounf.inp b/model/inp/ww3_ounf.inp index 5c645d123..7bde30754 100644 --- a/model/inp/ww3_ounf.inp +++ b/model/inp/ww3_ounf.inp @@ -1,7 +1,7 @@ $ -------------------------------------------------------------------- $ $ WAVEWATCH III Grid output post-processing $ $--------------------------------------------------------------------- $ -$ First output time (yyyymmdd hhmmss), increment of output (s), +$ First output time (yyyymmdd hhmmss), increment of output (s), $ and number of output times. $ 19850101 000000 3600. 1000 @@ -16,7 +16,7 @@ $ DPT CUR WND AST WLV ICE IBG TAU RHO D50 IC1 IC5 HS LM T02 T0M1 T01 FP $ DIR SPR DP HIG EF TH1M STH1M TH2M STH2M WN PHS PTP PLP PDIR PSPR PWS PDP $ PQP PPE PGW PSW PTM10 PT01 PT02 PEP TWS PNR UST CHA CGE FAW TAW TWA WCC $ WCF WCH WCM SXY TWO BHD FOC TUS USS P2S USF P2L TWI FIC ABR UBR BED -$ FBB TBB MSS MSC DTD FC CFX CFD CFK U1 U2 WNM TOC +$ FBB TBB MSS MSC DTD FC CFX CFD CFK U1 U2 WNM TOC $ N DPT HS FP T01 @@ -25,7 +25,7 @@ $--------------------------------------------------------------------- $ $ netCDF version [3,4] $ and variable type 4 [2 = SHORT, 3 = it depends , 4 = REAL] $ swell partitions [0 1 2 3 4 5] -$ variables in same file [T] or not [F] +$ variables in same file [T] or not [F] $ 3 4 0 1 2 @@ -36,7 +36,7 @@ $ File prefix $ number of characters in date [0(nodate),4(yearly),6(monthly),8(daily),10(hourly)] $ IX and IY ranges [regular:IX NX IY NY, unstructured:IP NP 1 1] $ - ww3. + ww3. 6 $ $ ----------------- FOR SMC GRID ONLY ---------------------------------$ @@ -50,7 +50,7 @@ $ For SMC output, the IX/IY range line is replaced with a domain $ lat/lon range and `cellfac` parameter for SMC type 2 output. $ First/Last lat/lon can be set to -999.9 to use edge of SMC grid. $ -$ For SMC type 1 output, only those points within the specified +$ For SMC type 1 output, only those points within the specified $ lat/lon ranges will be extracted: $ $ first_lon, first_lat, last_lon, last_lat @@ -58,18 +58,18 @@ $ $ For type 2 output, the range is used in conjunction with a fifth $ integer `cellfac` parameter to specify the regular output grid $ to area average the SMC grid to. In this case, the output grid will -$ be aligned to nearest largest SMC grid points within the selected -$ region. Therefore, the output grid start and end lat/lons may differ +$ be aligned to nearest largest SMC grid points within the selected +$ region. Therefore, the output grid start and end lat/lons may differ $ slightly from what is requested. In order to obtain a fully populated $ regular grid the extents specified should encompass the SW corner of $ the bottom left cell, and NE corner of the top right cell required. $ `cellfac` is an integer value that selects the target grid cell size $ as multiple of the smallest SMC grid cell. It must be a power of 2. -$ e.g. 1 = highest resolution, 2 = half resolution of smallest cell, +$ e.g. 1 = highest resolution, 2 = half resolution of smallest cell, $ 4 = 1/4 res of smallest cell, etc. $ $ first_lon, first_lat, last_lon, last_lat, cellfac -$ +$ $ Example: Extract high resolution data for U.K.: $ $ -13.50 46.85 5.50 61.0 1 @@ -77,7 +77,7 @@ $ $ $ ---------------- FOR NON-SMC GRIDS --------------------------------- $ $ IX, IY range: -$ 1 1000000 1 1000000 +$ 1 1000000 1 1000000 $ $ For each field and time a new file is generated with the file name $ ww3.date_xxx.nc , where date is a conventional time indicator with S3 diff --git a/model/inp/ww3_ounp.inp b/model/inp/ww3_ounp.inp index c25027145..4fbab57b8 100644 --- a/model/inp/ww3_ounp.inp +++ b/model/inp/ww3_ounp.inp @@ -1,14 +1,14 @@ $ -------------------------------------------------------------------- $ $ WAVEWATCH III NETCDF Point output post-processing $ $--------------------------------------------------------------------- $ -$ First output time (yyyymmdd hhmmss), increment of output (s), +$ First output time (yyyymmdd hhmmss), increment of output (s), $ and number of output times. $ 19850101 000000 3600. 1000 $ $ Points requested --------------------------------------------------- $ $ -$ Define points index for which output is to be generated. +$ Define points index for which output is to be generated. $ If no one defined, all points are selected $ One index number per line, negative number identifies end of list. $ 1 @@ -20,7 +20,7 @@ $--------------------------------------------------------------------- $ $ file prefix $ number of characters in date [0(nodate),4(yearly),6(monthly),8(daily),10(hourly)] $ netCDF version [3,4] -$ points in same file [T] or not [F] +$ points in same file [T] or not [F] $ and max number of points to be processed in one pass $ output type ITYPE [0,1,2,3] $ flag for global attributes WW3 [0] or variable version [1-2-3-4] @@ -29,7 +29,7 @@ $ ww3. 6 4 - T 150 + T 150 1 0 T @@ -71,7 +71,7 @@ $ 2 : Mean wave pars. $ 3 : Nondimensional pars. (U*) $ 4 : Nondimensional pars. (U10) $ 5 : 'Validation table' -$ 6 : WMO standard output +$ 6 : WMO standard output $ 4 $ $ -------------------------------------------------------------------- $ diff --git a/model/inp/ww3_outf.inp b/model/inp/ww3_outf.inp index 97de435c9..b2a02c5ba 100644 --- a/model/inp/ww3_outf.inp +++ b/model/inp/ww3_outf.inp @@ -35,7 +35,7 @@ $ $ -------------------------------------------------------------------- $ $ ITYPE = 3, transfer files. $ IX, IY range, IDLA and IDFM as in ww3_grid.inp. -$ The additional option IDLA=5 gives longitude, latitude +$ The additional option IDLA=5 gives longitude, latitude $ and parameter value(s) per record (defined points only), $ $ 2 11 2 11 1 2 diff --git a/model/inp/ww3_outp.inp b/model/inp/ww3_outp.inp index fa133a326..7c30a9659 100644 --- a/model/inp/ww3_outp.inp +++ b/model/inp/ww3_outp.inp @@ -1,13 +1,13 @@ $ -------------------------------------------------------------------- $ $ WAVEWATCH III Point output post-processing $ $--------------------------------------------------------------------- $ -$ First output time (yyyymmdd hhmmss), increment of output (s), +$ First output time (yyyymmdd hhmmss), increment of output (s), $ and number of output times. $ 19680606 060000 3600. 7 $ $ Points requested --------------------------------------------------- $ -$ Define points for which output is to be generated. +$ Define points for which output is to be generated. $ $ 1 $ 2 @@ -62,7 +62,7 @@ $ 2 : Mean wave pars. $ 3 : Nondimensional pars. (U*) $ 4 : Nondimensional pars. (U10) $ 5 : 'Validation table' -$ 6 : WMO standard output +$ 6 : WMO standard output $ - Unit number for file, also used in file name. $ $ 6 66 @@ -120,9 +120,9 @@ $ 3 : Bulletins CSV format $ 4 : Bulletins ASCII and CSV formats $ - Unit number for transfer file, also used in table file $ name. -$ - Reference date/time in YYYYMMDD HHMMSS format, used for +$ - Reference date/time in YYYYMMDD HHMMSS format, used for $ including in bulletin legend, and computing forecast time -$ in CSV type output (if the first field is negative, the +$ in CSV type output (if the first field is negative, the $ reference time becomes the first simulation time slice) $ - Three-character code indicating time zone (UTC, EST etc) $ @@ -141,7 +141,7 @@ $ - Point name (C*40), lat, lon, d, U10 and | loop | over $ direction, current speed and direction | over | $ - E(f,theta) | points | times $ -+ -+ -$ +$ $ -------------------------------------------------------------------- $ $ End of input file $ $ -------------------------------------------------------------------- $ diff --git a/model/inp/ww3_prep.inp b/model/inp/ww3_prep.inp index f21394f53..cfe2d12b9 100644 --- a/model/inp/ww3_prep.inp +++ b/model/inp/ww3_prep.inp @@ -52,10 +52,10 @@ $ input for grid preprocessor), and a format $ 3) Unit number and (dummy) name of first file. $ 4) Unit number and (dummy) name of second file (F2 only). $ -$ 15 3 +$ 15 3 $ 'UNIT' 3 1 '(.L.L.)' $ 10 'll_file.1' -$ 10 'll_file.2' +$ 10 'll_file.2' $ $ Additional input for data ------------------------------------------ $ $ Dimension of data (0,1,2 for mean pars, 1D or 2D spectra), "record @@ -67,7 +67,7 @@ $ Define data files -------------------------------------------------- $ $ The first input line identifies the file format with FROM, IDLA and $ IDFM, the second (third) lines give the file unit number and name. $ - 'UNIT' 3 1 '(..T..)' '(..F..)' + 'UNIT' 3 1 '(..T..)' '(..F..)' 10 'data_file.1' $ 10 'data_file.2' $ diff --git a/model/inp/ww3_prnc.inp b/model/inp/ww3_prnc.inp index 1cb95ac05..1d0982f11 100644 --- a/model/inp/ww3_prnc.inp +++ b/model/inp/ww3_prnc.inp @@ -17,7 +17,7 @@ $ $ Format types : AI Transfer field 'as is'. (ITYPE 1) $ LL Field defined on regular longitude-latitude $ or Cartesian grid. (ITYPE 2) -$ Format types : AT Transfer field 'as is', performs tidal +$ Format types : AT Transfer field 'as is', performs tidal $ analysis on the time series (ITYPE 6) $ When using AT, another line should be added $ with the choice of tidal constituents: @@ -33,7 +33,7 @@ $ 'WND' 'LL' T T $ $ Name of spatial dimensions------------------------------------------ $ -$ NB: time dimension is expected to be called 'time' and must respect +$ NB: time dimension is expected to be called 'time' and must respect $ Julian or Gregorian calendar with leap day. $ longitude latitude diff --git a/model/inp/ww3_prtide.inp b/model/inp/ww3_prtide.inp index 7cbb1b576..609bda335 100644 --- a/model/inp/ww3_prtide.inp +++ b/model/inp/ww3_prtide.inp @@ -8,21 +8,21 @@ $ CUR Currents. $ $ List of tidal constituents------------------------------------------ $ $ - Z0 M2 + Z0 M2 $ $ Maximum allowed values ------------------------------------------ $ $ First line: name of tidal constituents for which the max. are defined -$ these should be chosen among the ones avaialable in the -$ tidal analysis. -$ If analysis was performed with ww3_prnc, the default list -$ is Z0 SSA MSM MSF MF 2N2 MU2 N2 NU2 M2 S2 K2 MSN2 MN4 M4 -$ MS4 S4 M6 2MS6 M8 -$ Second line: values of maximum magnitude of the amplitude -$ at points where not values are defined or where these maxima are -$ exceeded, the constituents are extrapolated from neighbors -$ (e.g. tidal flats ...) - Z0 SSA MSF - 1.0 0.5 0.5 +$ these should be chosen among the ones avaialable in the +$ tidal analysis. +$ If analysis was performed with ww3_prnc, the default list +$ is Z0 SSA MSM MSF MF 2N2 MU2 N2 NU2 M2 S2 K2 MSN2 MN4 M4 +$ MS4 S4 M6 2MS6 M8 +$ Second line: values of maximum magnitude of the amplitude +$ at points where not values are defined or where these maxima are +$ exceeded, the constituents are extrapolated from neighbors +$ (e.g. tidal flats ...) + Z0 SSA MSF + 1.0 0.5 0.5 $ $ Start time step end time 19680606 000000 1800 19680607 120000 diff --git a/model/inp/ww3_shel.inp b/model/inp/ww3_shel.inp index d10e3df65..8eca9b58a 100644 --- a/model/inp/ww3_shel.inp +++ b/model/inp/ww3_shel.inp @@ -40,7 +40,7 @@ $ parallel file system like GPFS. $ $ IOSTYP = 0 : No data server processes, direct access output from $ each process (requires true parallel file system). -$ 1 : No data server process. All output for each type +$ 1 : No data server process. All output for each type $ performed by process that performs computations too. $ 2 : Last process is reserved for all output, and does no $ computing. @@ -50,7 +50,7 @@ $ $ $ Five output types are available (see below). All output types share $ a similar format for the first input line: -$ - first time in yyyymmdd hhmmss format, output interval (s), and +$ - first time in yyyymmdd hhmmss format, output interval (s), and $ last time in yyyymmdd hhmmss format (all integers). $ Output is disabled by setting the output interval to 0. $ @@ -62,25 +62,25 @@ $ fields as defined in section 2.4 of the manual. The logical $ flags are not supplied if no output is requested. The logical $ flags can be placed on multiple consecutive lines. However, $ the total number and order of the logical flags is fixed. -$ The raw data file is out_grd.ww3, +$ The raw data file is out_grd.ww3, $ see w3iogo.ftn for additional doc. $ 19680606 000000 3600 19680608 000000 $---------------------------------------------------------------- $ Output request flags identifying fields. -$ +$ $ The table below provides a full definition of field output parameters -$ as well as flags indicating if they are available in different field -$ output output file types (ASCII, grib, NetCDF). -$ Further definitions are found in section 2.4 of the manual. +$ as well as flags indicating if they are available in different field +$ output output file types (ASCII, grib, NetCDF). +$ Further definitions are found in section 2.4 of the manual. $ -$ Selection of field outputs may be made in two ways: +$ Selection of field outputs may be made in two ways: $ F/T flags: first flag is set to F, requests made per group (1st line) $ followed by parameter flags (total of 10 groups). -$ Namelists: first line is set to N, next line contains parameter +$ Namelists: first line is set to N, next line contains parameter $ symbol as per table below. -$ -$ Example of F/T flag use is given in this sample ww3_shel.inp, below. +$ +$ Example of F/T flag use is given in this sample ww3_shel.inp, below. $ For namelist usage, see the sample ww3_ounf.inp for an example. $ $ ---------------------------------------- @@ -88,7 +88,7 @@ $ Output field parameter definitions table $ ---------------------------------------- $ $ All parameters listed below are available in output file of the types -$ ASCII and NetCDF. If selected output file types are grads or grib, +$ ASCII and NetCDF. If selected output file types are grads or grib, $ some parameters may not be available. The first two columns in the $ table below identify such cases by flags, cols 1 (GRB) and 2 (GXO) $ refer to grib (ww3_grib) and grads (gx_outf), respectively. @@ -96,13 +96,13 @@ $ $ Columns 3 and 4 provide group and parameter numbers per group. $ Columns 5, 6 and 7 provide: $ 5 - code name (internal) -$ 6 - output tags (names used is ASCII file extensions, NetCDF +$ 6 - output tags (names used is ASCII file extensions, NetCDF $ variable names and namelist-based selection (see ww3_ounf.inp) $ 7 - Long parameter name/definition $ $ G G $ R X Grp Param Code Output Parameter/Group -$ B O Numb Numbr Name Tag Definition +$ B O Numb Numbr Name Tag Definition $ -------------------------------------------------- $ 1 Forcing Fields $ ------------------------------------------------- @@ -113,11 +113,11 @@ $ T T 1 4 AS AST Air-sea temperature difference. $ T T 1 5 WLV WLV Water levels. $ T T 1 6 ICE ICE Ice concentration. $ T T 1 7 IBG IBG Iceberg-induced damping. -$ T T 1 8 TAUA TAU Atm. momentum. -$ T T 1 9 RHOAIR RHO Air density. +$ T T 1 8 TAUA TAU Atm. momentum. +$ T T 1 9 RHOAIR RHO Air density. $ T T 1 10 D50 D50 Median sediment grain size. $ T T 1 11 IC1 IC1 Ice thickness. -$ T T 1 12 IC5 IC5 Ice flow diameter. +$ T T 1 12 IC5 IC5 Ice flow diameter. $ ------------------------------------------------- $ 2 Standard mean wave Parameters $ ------------------------------------------------- @@ -138,7 +138,7 @@ $ T T 2 14 HCMAXE MXHC Max wave height from crest (STE) $ T T 2 15 HMAXD SDMH St Dev of MXC (STE) $ T T 2 16 HCMAXD SDMHC St Dev of MXHC (STE) $ F T 2 17 WBT WBT Dominant wave breaking probability bT -$ F F 2 18 FP0 TP Peak period (from peak freq) +$ F F 2 18 FP0 TP Peak period (from peak freq) $ ------------------------------------------------- $ 3 Spectral Parameters (first 5) $ ------------------------------------------------- @@ -149,7 +149,7 @@ $ F F 3 4 TH2M TH2M Mean wave direction from a2,b2 $ F F 3 5 STH2M STH2M Directional spreading from a2,b2 $ F F 3 6 WN WN Wavenumber array $ ------------------------------------------------- -$ 4 Spectral Partition Parameters +$ 4 Spectral Partition Parameters $ ------------------------------------------------- $ T T 4 1 PHS PHS Partitioned wave heights. $ T T 4 2 PTP PTP Partitioned peak period. @@ -183,15 +183,15 @@ $ F F 5 9 WHITECAP WCH Mean breaking height $ F F 5 10 WHITECAP WCM Whitecap moment $ F F 5 11 FWS FWS Wind sea mean period $ ------------------------------------------------- -$ 6 Wave-ocean layer +$ 6 Wave-ocean layer $ ------------------------------------------------- $ F F 6 1 S[XX,YY,XY] SXY Radiation stresses. $ F F 6 2 TAUO[X,Y] TWO Wave to ocean momentum flux -$ F F 6 3 BHD BHD Bernoulli head (J term) +$ F F 6 3 BHD BHD Bernoulli head (J term) $ F F 6 4 PHIOC FOC Wave to ocean energy flux $ F F 6 5 TUS[X,Y] TUS Stokes transport $ F F 6 6 USS[X,Y] USS Surface Stokes drift -$ F F 6 7 [PR,TP]MS P2S Second-order sum pressure +$ F F 6 7 [PR,TP]MS P2S Second-order sum pressure $ F F 6 8 US3D USF Spectrum of surface Stokes drift $ F F 6 9 P2SMS P2L Micro seism source term $ F F 6 10 TAUICE TWI Wave to sea ice stress @@ -199,12 +199,12 @@ $ F F 6 11 PHICE FIC Wave to sea ice energy flux $ F F 6 12 USSP USP Partitioned surface Stokes drift $ F F 6 13 TAUOC[X,Y] TOC Total momentum to the ocean $ ------------------------------------------------- -$ 7 Wave-bottom layer +$ 7 Wave-bottom layer $ ------------------------------------------------- $ F F 7 1 ABA ABR Near bottom rms amplitides. $ F F 7 2 UBA UBR Near bottom rms velocities. $ F F 7 3 BEDFORMS BED Bedforms -$ F F 7 4 PHIBBL FBB Energy flux due to bottom friction +$ F F 7 4 PHIBBL FBB Energy flux due to bottom friction $ F F 7 5 TAUBBL TBB Momentum flux due to bottom friction $ ------------------------------------------------- $ 8 Spectrum parameters @@ -216,15 +216,15 @@ $ F F 8 4 ALPXT AXT Correl sea surface gradients (x,t) $ F F 8 5 ALPYT AYT Correl sea surface gradients (y,t) $ F F 8 6 ALPXY AXY Correl sea surface gradients (x,y) $ ------------------------------------------------- -$ 9 Numerical diagnostics +$ 9 Numerical diagnostics $ ------------------------------------------------- $ T T 9 1 DTDYN DTD Average time step in integration. $ T T 9 2 FCUT FC Cut-off frequency. -$ T T 9 3 CFLXYMAX CFX Max. CFL number for spatial advection. -$ T T 9 4 CFLTHMAX CFD Max. CFL number for theta-advection. -$ F F 9 5 CFLKMAX CFK Max. CFL number for k-advection. +$ T T 9 3 CFLXYMAX CFX Max. CFL number for spatial advection. +$ T T 9 4 CFLTHMAX CFD Max. CFL number for theta-advection. +$ F F 9 5 CFLKMAX CFK Max. CFL number for k-advection. $ ------------------------------------------------- -$ 10 User defined +$ 10 User defined $ ------------------------------------------------- $ F F 10 1 U1 User defined #1. (requires coding ...) $ F F 10 2 U2 User defined #1. (requires coding ...) @@ -249,7 +249,7 @@ $ EF TH1M STH1M TH2M STH2M WN T T T F F F $ (4) Spectral Partition Parameters T -$ PHS PTP PLP PDIR PSPR PNR PDP PQP PPE PGW PSW PTM10 PT01 PT02 PEP PWS TWS +$ PHS PTP PLP PDIR PSPR PNR PDP PQP PPE PGW PSW PTM10 PT01 PT02 PEP PWS TWS T T T T T T T T T T T T T T T T T $ (5) Atmosphere-waves layer T @@ -279,17 +279,17 @@ $ $---------------------------------------------------------------- $ $ Type 2 : Point output -$ Standard line and a number of lines identifying the +$ Standard line and a number of lines identifying the $ longitude, latitude and name (C*40) of output points. $ The list is closed by defining a point with the name $ 'STOPSTRING'. No point info read if no point output is $ requested (i.e., no 'STOPSTRING' needed). $ Example for spherical grid. -$ The raw data file is out_pnt.ww3, +$ The raw data file is out_pnt.ww3, $ see w3iogo.ftn for additional doc. $ $ NOTE : Spaces may be included in the name, but this is not -$ advised, because it will break the GrADS utility to +$ advised, because it will break the GrADS utility to $ plots spectra and source terms, and will make it more $ difficult to use point names in data files. $ diff --git a/model/inp/ww3_systrk.inp b/model/inp/ww3_systrk.inp index aade81c95..a92be5f51 100644 --- a/model/inp/ww3_systrk.inp +++ b/model/inp/ww3_systrk.inp @@ -5,14 +5,14 @@ $ File name for raw partition data $ 'partition.ww3' $ -$ First time level (yyyymmdd hhmmss), time increment and number of +$ First time level (yyyymmdd hhmmss), time increment and number of $ time levels to process. $ 20091122 000000 3600 4 $ $ Output type [1,3,4] [text file, netCDF version 3, netCDF version 4] -$ Note for NetCDF version 3 or version 4 compresssion, -$ the TRKNC switch is needed. +$ Note for NetCDF version 3 or version 4 compresssion, +$ the TRKNC switch is needed. 1 $ $ Wave tracking domain. First line: longitude limits, longitude intervals @@ -22,7 +22,7 @@ $ 0. 55. 55 $ $ Parameters of tracking algorithm ----------------------------------- $ -$ - dirKnob (deg), perKnob (s), hsKnob (m), wetPts (frac), +$ - dirKnob (deg), perKnob (s), hsKnob (m), wetPts (frac), $ dirTimeKnob (deg), tpTimeKnob (s) $ - seedLat, seedLon $ @@ -33,15 +33,14 @@ $ Output points ------------------------------------------------------ $ $ Longitude, latitude. End with 0. 0. string on last line. $ 222.54 40.75 - 199.42 19.02 - 205.94 23.55 - 290.35 31.98 - 347.60 48.70 + 199.42 19.02 + 205.94 23.55 + 290.35 31.98 + 347.60 48.70 337.00 21.00 197.94 24.32 - 206.10 23.56 + 206.10 23.56 0. 0. $ -------------------------------------------------------------------- $ $ End of input file $ $ -------------------------------------------------------------------- $ - diff --git a/model/inp/ww3_trnc.inp b/model/inp/ww3_trnc.inp index df60800b8..ec9a64c30 100644 --- a/model/inp/ww3_trnc.inp +++ b/model/inp/ww3_trnc.inp @@ -13,7 +13,7 @@ $ number of characters in date [4(yearly),6(monthly),8(daily),10(hourly)] $ 3 ww3. - 6 + 6 $ $ -------------------------------------------------------------------- $ $ End of input file $ diff --git a/model/inp/ww3_uprstr.inp b/model/inp/ww3_uprstr.inp index f0ee6faf9..a4b92e88c 100644 --- a/model/inp/ww3_uprstr.inp +++ b/model/inp/ww3_uprstr.inp @@ -47,7 +47,7 @@ $ for the last gross check. $ $ UPD4 :: [NOT INCLUDED in this Version, Just keeping the spot] $ $ Option 4 The generalization of the UPD3. The update $ $ factor is the sum of surfaces which are applied on the $ -$ background spectrum. $ +$ background spectrum. $ $ The algorithm requires the mapping of each partition on the $ $ individual spectra; the map is used to determine the $ $ weighting surfaces. $ diff --git a/model/nml/namelists.nml b/model/nml/namelists.nml index 8ce245d25..d376a045a 100644 --- a/model/nml/namelists.nml +++ b/model/nml/namelists.nml @@ -57,14 +57,14 @@ $ BETAMAX : maximum value of wind-wave coupling $ SINTHP : power of cosine in wind input $ ZALP : wave age shift to account for gustiness $ TAUWSHELTER : sheltering of short waves to reduce u_star -$ SWELLFPAR : choice of swell attenuation formulation +$ SWELLFPAR : choice of swell attenuation formulation $ (1: TC 1996, 3: ACC 2008) $ SWELLF : swell attenuation factor -$ Extra parameters for SWELLFPAR=3 only -$ SWELLF2, SWELLF3 : swell attenuation factors +$ Extra parameters for SWELLFPAR=3 only +$ SWELLF2, SWELLF3 : swell attenuation factors $ SWELLF4 : Threshold Reynolds number for ACC2008 $ SWELLF5 : Relative viscous decay below threshold -$ Z0RAT : roughness for oscil. flow / mean flow +$ Z0RAT : roughness for oscil. flow / mean flow $ BYDRZ input : Namelist SIN6 $ SINA0 : factor for negative input $ SINWS : wind speed scaling option @@ -148,17 +148,17 @@ $ $ WAM4 and variants : Namelist SDS3 $ SDSC1 : WAM4 Cds coeffient $ MNMEANP, WNMEANPTAIL : power of wavenumber -$ for mean definitions in Sds and tail -$ SDSDELTA1, SDSDELTA2 : relative weights +$ for mean definitions in Sds and tail +$ SDSDELTA1, SDSDELTA2 : relative weights $ of k and k^2 parts of WAM4 dissipation -$ SDSLF, SDSHF : coefficient for activation of -$ WAM4 dissipation for unsaturated (SDSLF) and +$ SDSLF, SDSHF : coefficient for activation of +$ WAM4 dissipation for unsaturated (SDSLF) and $ saturated (SDSHF) parts of the spectrum $ SDSC2 : Saturation dissipation coefficient $ SDSC4 : Value of B0=B/Br for wich Sds is zero $ SDSBR : Threshold Br for saturation $ SDSP : power of (B/Br-B0) in Sds -$ SDSBR2 : Threshold Br2 for the separation of +$ SDSBR2 : Threshold Br2 for the separation of $ WAM4 dissipation in saturated and non-saturated $ SDSC5 : coefficient for turbulence dissipation $ SDSC6 : Weight for the istropic part of Sds_SAT @@ -183,27 +183,27 @@ $ BJGAM : Breaking threshold (default = 0.73) $ BJFLAG : TRUE - Use Hmax/d ratio only (default) $ FALSE - Use Hmax/d in Miche formulation $ -$ Dissipation in the ice - - - - - - - - - - - - - - - - - - - - - - +$ Dissipation in the ice - - - - - - - - - - - - - - - - - - - - - - $ Generalization of Liu et al. : Namelist SIC2 $ IC2DISPER : If true uses Liu formulation with eddy viscosity -$ If false, uses the generalization with turbulent -$ to laminar transition +$ If false, uses the generalization with turbulent +$ to laminar transition $ IC2TURB : empirical factor for the turbulent part -$ IC2ROUGH : under-ice roughness length -$ IC2REYNOLDS: Re number for laminar to turbulent transition +$ IC2ROUGH : under-ice roughness length +$ IC2REYNOLDS: Re number for laminar to turbulent transition $ IC2SMOOTH : smoothing of transition reprensenting random waves -$ IC2VISC : empirical factor for viscous part +$ IC2VISC : empirical factor for viscous part $ $ -$ Scattering in the ice & creep dissipations- - - - - - - - - - - - - +$ Scattering in the ice & creep dissipations- - - - - - - - - - - - - $ Generalization of Wiliams et al. : Namelist SIS2 $ ISC1 : scattering coefficient (default = 1) $ IS2BACKSCAT : fraction of energy back-scattered (default = 1 ) $ IS2BREAK : TRUE - changes floe max diameter $ : FALSE - does not change floe max diameter -$ IS2C1 : scattering in pack ice -$ IS2C2 : frequency dependance of scattering in pack ice -$ IS2C3 : frequency dependance of scattering in pack ice +$ IS2C1 : scattering in pack ice +$ IS2C2 : frequency dependance of scattering in pack ice +$ IS2C3 : frequency dependance of scattering in pack ice $ ISBACKSCAT : fraction of scattered energy actualy redistributed $ IS2DISP : use of ice-specific dispersion relation (T/F) $ FRAGILITY : parameter between 0 and 1 that gives the shape of FSD @@ -225,31 +225,31 @@ $ $ Triad nonlinear interactions - - - - - - - - - - - - - - - - - - - - $ Lumped Triad Interaction (LTA) : Namelist STR1 (To be implemented) $ PTRIAD1 : Proportionality coefficient (default 0.05) -$ PTRIAD2 : Multiple of Tm01 up to which interaction +$ PTRIAD2 : Multiple of Tm01 up to which interaction $ is computed (2.5) $ PTRIAD3 : Ursell upper limit for computing $ interactions (not used, default 10.) $ PTRIAD4 : Shape parameter for biphase $ computation (0.2) -$ PTRIAD5 : Ursell number treshold for computing +$ PTRIAD5 : Ursell number treshold for computing $ interactions (0.01) $ -$ Shoreline reflections - - - - - - - - - - - - - - - - - - - - - - - - -$ ref. parameters : Namelist REF1 +$ Shoreline reflections - - - - - - - - - - - - - - - - - - - - - - - - +$ ref. parameters : Namelist REF1 $ REFCOAST : Reflection coefficient at shoreline -$ REFFREQ : Activation of freq-dependent ref. +$ REFFREQ : Activation of freq-dependent ref. $ REFMAP : Scale factor for bottom slope map -$ REFRMAX : maximum ref. coeffient (default 0.8) -$ REFFREQPOW: power of frequency +$ REFRMAX : maximum ref. coeffient (default 0.8) +$ REFFREQPOW: power of frequency $ REFICEBERG: Reflection coefficient for icebergs $ REFSUBGRID: Reflection coefficient for islands -$ REFCOSP_STRAIGHT: power of cosine used for +$ REFCOSP_STRAIGHT: power of cosine used for $ straight shoreline $ -$ Bound 2nd order spectrum and free IG - - - - - - - - - - - - - - - - - +$ Bound 2nd order spectrum and free IG - - - - - - - - - - - - - - - - - $ IG1 parameters : Namelist SIG1 $ IGMETHOD : 1: Hasselmann, 2: Krasitskii-Janssen -$ IGADDOUTP : activation of bound wave correction +$ IGADDOUTP : activation of bound wave correction $ in ww3_outp / ww3_ounp $ IGSOURCE : 1: uses bound waves, 2: empirical $ IGSTERMS : > 0 : no source term in IG band @@ -283,7 +283,7 @@ $ All tuneable parameters are associated with the refraction $ limitation and the GSE alleviation. $ $ Unstructured grids ------------------------------------------------ $ -$ UNST parameters : Namelist UNST +$ UNST parameters : Namelist UNST $ UGOBCAUTO : TRUE: OBC points are taken from type 15 elements $ FALSE: OBC points must be listed in ww3_grid.inp $ UGOBCDEPTH: Threshold ( < 0) depth for OBC points if UGOBCAUTO is TRUE @@ -302,7 +302,7 @@ $ JGS_TERMINATE_NORM : terminate based on the norm of $ JGS_USE_JACOBI : Use Jacobi solver for imptotal $ JGS_BLOCK_GAUSS_SEIDEL : Use Block Gauss Seidel method for imptotal $ JGS_MAXITER : max. Number of solver iterations -$ JGS_PMIN : % of grid points that do not need to converge during solver iteration. +$ JGS_PMIN : % of grid points that do not need to converge during solver iteration. $ JGS_DIFF_THR : implicit solver threshold for JGS_TERMINATE_DIFFERENCE $ JGS_NORM_THR : terminate based on the norm of the solution $ SETUP_APPLY_WLV : Compute wave setup (experimental) @@ -312,12 +312,12 @@ $ $ SMC grid propagation : Namelist PSMC and default values $ CFLTM : Maximum CFL no. for propagation, 0.7 $ DTIME : Swell age for diffusion term (s), 0.0 -$ LATMIN : Maximum latitude (deg) for GCT, 86.0 +$ LATMIN : Maximum latitude (deg) for GCT, 86.0 $ RFMAXD : Maximum refraction turning (deg), 80.0 -$ LvSMC : No. of refinement level, default 1 -$ ISHFT : Shift number of i-index, default 0 -$ JEQT : Shift number of j-index, default 0 -$ NBISMC : No. of input boundary points, 0 +$ LvSMC : No. of refinement level, default 1 +$ ISHFT : Shift number of i-index, default 0 +$ JEQT : Shift number of j-index, default 0 +$ NBISMC : No. of input boundary points, 0 $ UNO3 : Use 3rd order advection scheme, .FALSE. $ AVERG : Add extra spatial averaging, .FALSE. $ SEAWND : Use sea-point only wind input. .FALSE. @@ -333,7 +333,7 @@ $ $ Compile switch /RTD required. $ $ These will be used to derive rotation angle corrections in the -$ model. The corrections are used for rotation of boundary spectra +$ model. The corrections are used for rotation of boundary spectra $ and for restoring conventional lat/lon orientation of the $ output spectra, mean direction or any related variables. $ The PLAT/LON example below is a standard setting for Met @@ -365,22 +365,22 @@ $ $ &ROTB BPLAT(1)=90., BPLON(1)=-180., BPLAT(2)=90. / $ (etc.) $ $ Output of 3D arrays------------------------------------------------- $ -$ In order to limit the use of memory, arrays for 3D output fiels (i.e. -$ variables that are a function of both space and frequency, are not +$ In order to limit the use of memory, arrays for 3D output fiels (i.e. +$ variables that are a function of both space and frequency, are not $ declared, and thus cannot be used, unless specified by namelists. -$ NB: Output of 'first 5' moments E, th1m, sth1m, th2, sth2m allows to estimate the full -$ directional spectrum using, e.g. MEM (Lygre&Krogstad 1986). +$ NB: Output of 'first 5' moments E, th1m, sth1m, th2, sth2m allows to estimate the full +$ directional spectrum using, e.g. MEM (Lygre&Krogstad 1986). $ $ Parameters (integers) : Namelist OUTS -$ For the frequency spectrum E(f) +$ For the frequency spectrum E(f) $ E3D : <=0: not declared, > 0: declared $ I1E3D : First frequency index of output (default is 1) $ I2E3D : Last frequency index of output (default is NK) -$ For the mean direction th1m(f), and spread sth1m(f) +$ For the mean direction th1m(f), and spread sth1m(f) $ TH1MF, STH1MF : <=0: not declared, > 0: declared $ I1TH1MF, I1STH1MF: First frequency index of output (default is 1) $ I2TH1MF, I2STH1MF: First frequency index of output (default is 1) -$ For the mean direction th2m(f), and spread sth2m(f) +$ For the mean direction th2m(f), and spread sth2m(f) $ TH2MF, STH2MF : <=0: not declared, > 0: declared $ I1TH2MF, I1STH2MF: First frequency index of output (default is 1) $ I2TH2MF, I2STH2MF: First frequency index of output (default is 1) @@ -397,7 +397,7 @@ $ STK_WN : List of wavenumbers (size of IUSSP) $ e.g.: USSP = 1, IUSSP=3, STK_WN = 0.04, 0.11, 0.33 $ provides 3 partitions of both x & y component, $ with a reasonable accuracy for using in -$ a climate model. +$ a climate model. $ $ Miscellaneous ------------------------------------------------------ $ $ Misc. parameters : Namelist MISC @@ -456,7 +456,7 @@ $ 0: Constant value (prescribed) $ 1: Wind speed dependent $ (Based on GFDL Hurricane $ Model Z0 relationship) -$ TAILLEV : Level of high frequency tail +$ TAILLEV : Level of high frequency tail $ (if TAILTYPE==0) $ Valid choices: $ Capped min: 0.001, max: 0.02 diff --git a/model/nml/ww3_grid.nml b/model/nml/ww3_grid.nml index 3996b2b4d..e9a7bfdc1 100644 --- a/model/nml/ww3_grid.nml +++ b/model/nml/ww3_grid.nml @@ -45,8 +45,8 @@ ! -------------------------------------------------------------------- ! ! Define the timesteps parameterization via TIMESTEPS_NML namelist ! -! * It is highly recommended to set up time steps which are multiple -! between them. +! * It is highly recommended to set up time steps which are multiple +! between them. ! ! * The first time step to calculate is the maximum CFL time step ! which depend on the lowest frequency FREQ1 previously set up and the @@ -84,26 +84,26 @@ ! -------------------------------------------------------------------- ! ! Define the grid to preprocess via GRID_NML namelist ! -! * the tunable parameters for source terms, propagation schemes, and -! numerics are read using namelists. +! * the tunable parameters for source terms, propagation schemes, and +! numerics are read using namelists. ! * Any namelist found in the folowing sections is temporarily written -! to param.scratch, and read from there if necessary. +! to param.scratch, and read from there if necessary. ! * The order of the namelists is immaterial. ! * Namelists not needed for the given switch settings will be skipped ! automatically ! -! * grid type can be : +! * grid type can be : ! 'RECT' : rectilinear ! 'CURV' : curvilinear ! 'UNST' : unstructured (triangle-based) ! -! * coordinate system can be : +! * coordinate system can be : ! 'SPHE' : Spherical (degrees) ! 'CART' : Cartesian (meters) ! ! * grid closure can only be applied in spherical coordinates ! -! * grid closure can be : +! * grid closure can be : ! 'NONE' : No closure is applied ! 'SMPL' : Simple grid closure. Grid is periodic in the ! : i-index and wraps at i=NX+1. In other words, @@ -116,7 +116,7 @@ ! : grid closure requires that NX be even. A grid ! : with tripole closure must be curvilinear. ! -! * The coastline limit depth is the value which distinguish the sea +! * The coastline limit depth is the value which distinguish the sea ! points to the land points. All the points with depth values (ZBIN) ! greater than this limit (ZLIM) will be considered as excluded points ! and will never be wet points, even if the water level grows over. @@ -124,7 +124,7 @@ ! The value must have a negative value under the mean sea level ! ! * The minimum water depth allowed to compute the model is the absolute -! depth value (DMIN) used in the model if the input depth is lower to +! depth value (DMIN) used in the model if the input depth is lower to ! avoid the model to blow up. ! ! * namelist must be terminated with / @@ -216,7 +216,7 @@ ! CURV%NX = 0 ! number of points along x-axis ! CURV%NY = 0 ! number of points along y-axis ! -! CURV%XCOORD%SF = 1. ! x-coord scale factor +! CURV%XCOORD%SF = 1. ! x-coord scale factor ! CURV%XCOORD%OFF = 0. ! x-coord add offset ! CURV%XCOORD%FILENAME = 'unset' ! x-coord filename ! CURV%XCOORD%IDF = 21 ! x-coord file unit number @@ -224,7 +224,7 @@ ! CURV%XCOORD%IDFM = 1 ! x-coord format indicator ! CURV%XCOORD%FORMAT = '(....)' ! x-coord formatted read format ! -! CURV%YCOORD%SF = 1. ! y-coord scale factor +! CURV%YCOORD%SF = 1. ! y-coord scale factor ! CURV%YCOORD%OFF = 0. ! y-coord add offset ! CURV%YCOORD%FILENAME = 'unset' ! y-coord filename ! CURV%YCOORD%IDF = 22 ! y-coord file unit number @@ -319,11 +319,11 @@ ! and obstruction ratio 'SUBTR'. ! ! * The input boundary cell file 'BUNDY' is only needed when NBISMC > 0. -! Boundary cell id list file (unit 35) is only required if boundary -! cell number entered above is non-zero. The cell id number should be +! Boundary cell id list file (unit 35) is only required if boundary +! cell number entered above is non-zero. The cell id number should be ! the sequential number in the cell array (unit 31) S625MCels.dat. ! -! * Extra cell and face arrays for Arctic part if switch ARC is selected. +! * Extra cell and face arrays for Arctic part if switch ARC is selected. ! ! * Example : ! IDF IDLA IDFM FORMAT FILENAME @@ -653,7 +653,7 @@ ! * Included point : ! grid points from segment data ! Defines as lines identifying points at which -! input boundary conditions are to be defined. +! input boundary conditions are to be defined. ! ! * namelist must be terminated with / ! * definitions & defaults: @@ -677,7 +677,7 @@ ! -------------------------------------------------------------------- ! -! Define the excluded points and bodies via EXCL_COUNT_NML, EXCL_POINT_NML +! Define the excluded points and bodies via EXCL_COUNT_NML, EXCL_POINT_NML ! and EXCL_BODY_NML namelist ! - only for RECT and CURV grids - ! @@ -693,12 +693,12 @@ ! point are on a grid line or diagonal, all intermediate points ! are also defined as boundary points. ! -! * Excluded point : +! * Excluded point : ! grid points from segment data ! Defined as lines identifying points at which ! input boundary conditions are to be excluded. ! -! * Excluded body: +! * Excluded body: ! Define a point in a closed body of sea points to remove the ! entire body of sea points. ! diff --git a/model/nml/ww3_multi.nml b/model/nml/ww3_multi.nml index 1e851efe1..6719a3510 100644 --- a/model/nml/ww3_multi.nml +++ b/model/nml/ww3_multi.nml @@ -9,7 +9,7 @@ ! * IOSTYP defines the output server mode for parallel implementation. ! 0 : No data server processes, direct access output from ! each process (requires true parallel file system). -! 1 : No data server process. All output for each type +! 1 : No data server process. All output for each type ! performed by process that performs computations too. ! 2 : Last process is reserved for all output, and does no ! computing. @@ -25,7 +25,7 @@ ! DOMAIN%PSHARE = F ! Flag for grids sharing dedicated output processes. ! DOMAIN%FLGHG1 = F ! Flag for masking computation in two-way nesting ! DOMAIN%FLGHG2 = F ! Flag for masking at printout time -! DOMAIN%START = '19680606 000000' ! Start date for the entire model +! DOMAIN%START = '19680606 000000' ! Start date for the entire model ! DOMAIN%STOP = '19680607 000000' ! Stop date for the entire model ! -------------------------------------------------------------------- ! &DOMAIN_NML @@ -90,7 +90,7 @@ ! ! * index I must match indexes from 1 to DOMAIN%NRGRD ! * MODEL(I)%NAME must be set for each active model grid I -! * FORCING can be set as : +! * FORCING can be set as : ! - 'no' : This input is not used. ! - 'native' : This grid has its own input files, e.g. grid ! grdX (mod_def.grdX) uses ice.grdX. @@ -203,7 +203,7 @@ ! ABR UBR BED FBB TBB ! MSS MSC WL02 AXT AYT AXY ! DTD FC CFX CFD CFK -! U1 U2 +! U1 U2 ! ! * output track file formatted (T) or unformated (F) ! @@ -263,10 +263,10 @@ ! ALLDATE%PARTITION%START = '19680606 000000' ! ALLDATE%PARTITION%STRIDE = '0' ! ALLDATE%PARTITION%STOP = '19680607 000000' -! +! ! ALLDATE%RESTART = '19680606 000000' '0' '19680607 000000' ! -! IDATE(3)%PARTITION%START = '19680606 000000' +! IDATE(3)%PARTITION%START = '19680606 000000' ! -------------------------------------------------------------------- ! &OUTPUT_DATE_NML ALLDATE%FIELD%START = '20100101 000000' @@ -278,9 +278,9 @@ ALLDATE%RESTART = '20101231 000000' '43200' '20501231 000000' - IDATE(5)%PARTITION%START = '20100601 000000' - IDATE(5)%PARTITION%STRIDE = '3600' - IDATE(5)%PARTITION%START = '20101201 000000' + IDATE(5)%PARTITION%START = '20100601 000000' + IDATE(5)%PARTITION%STRIDE = '3600' + IDATE(5)%PARTITION%START = '20101201 000000' / diff --git a/model/nml/ww3_ounf.nml b/model/nml/ww3_ounf.nml index f777d345c..9b1ffe136 100644 --- a/model/nml/ww3_ounf.nml +++ b/model/nml/ww3_ounf.nml @@ -42,7 +42,7 @@ ! ! Note: If FCVARS = T, the following auxiliary variables will be generated ! (see the manual entry for ww3_ounf for more information): -! +! ! - forecast_reference_time: The time associated with the "analysis" of ! the current forecast. Defaults to TIMESTART if TIMEREF not set. ! @@ -107,4 +107,3 @@ ! -------------------------------------------------------------------- ! ! WAVEWATCH III - end of namelist ! ! -------------------------------------------------------------------- ! - diff --git a/model/nml/ww3_ounp.nml b/model/nml/ww3_ounp.nml index b76d1050a..a0f44ceb1 100644 --- a/model/nml/ww3_ounp.nml +++ b/model/nml/ww3_ounp.nml @@ -51,14 +51,14 @@ ! -------------------------------------------------------------------- ! ! Define the type 1, spectra via SPECTRA_NML namelist ! -! Table of 1-D spectra content : +! Table of 1-D spectra content : ! - time, station id, station name, longitude, latitude ! - frequency : unit Hz, center band frequency - linear log scale (XFR factor) ! - ffp, f, th1m, sth1m, alpha : 1D spectral parameters ! - dpt, ust, wnd, wnddir : mean parameters ! ! Transfert file content : -! - time, station id, station name, longitude, latitude +! - time, station id, station name, longitude, latitude ! - frequency : unit Hz, center band frequency - linear log scale (XFR factor) ! - frequency1 : unit Hz, lower band frequency ! - frequency2 : unit Hz, upper band frequency @@ -66,7 +66,7 @@ ! - efth(time,station,frequency,direction) : 2D spectral density ! - dpt, wnd, wnddir, cur, curdir : mean parameters ! -! Spectral partitioning content : +! Spectral partitioning content : ! - time, station id, station name, longitude, latitude ! - npart : number of partitions ! - hs, tp, lm, th1m, sth1m, ws, tm10, t01, t02 : partitioned parameters @@ -92,19 +92,19 @@ ! -------------------------------------------------------------------- ! ! Define the type 2, mean parameter via PARAM_NML namelist ! -! Forcing parameters content : +! Forcing parameters content : ! - dpt, wnd, wnddir, cur, curdir ! -! Mean wave parameters content : +! Mean wave parameters content : ! - hs, lm, tr, th1p, sth1p, fp, th1m, sth1m ! ! Nondimensional parameters (U*) content : ! - ust, efst, fpst, cd, alpha ! -! Nondimensional parameters (U10) content : +! Nondimensional parameters (U10) content : ! - wnd, efst, fpst, cd, alpha ! -! Validation table content : +! Validation table content : ! - wnd, wnddir, hs, hsst, cpu, cmu, ast ! ! WMO stantdard output content : @@ -126,7 +126,7 @@ ! -------------------------------------------------------------------- ! ! Define the type 3, source terms via SOURCE_NML namelist ! -! Table of 1-D S(f) content : +! Table of 1-D S(f) content : ! - time, station id, station name, longitude, latitude ! - frequency : unit Hz, center band frequency ! - ef(frequency) : 1D spectral density @@ -138,7 +138,7 @@ ! - Stot(frequency) : total source term ! - dpt, ust, wnd : mean parameters ! -! Table of 1-D inverse time scales (1/T = S/F) content : +! Table of 1-D inverse time scales (1/T = S/F) content : ! - time, station id, station name, longitude, latitude ! - frequency : unit Hz, center band frequency ! - ef(frequency) : 1D spectral density @@ -151,7 +151,7 @@ ! - dpt, ust, wnd : mean parameters ! ! Transfert file content : -! - time, station id, station name, longitude, latitude +! - time, station id, station name, longitude, latitude ! - frequency : unit Hz, center band frequency - linear log scale (XFR factor) ! - frequency1 : unit Hz, lower band frequency ! - frequency2 : unit Hz, upper band frequency @@ -174,7 +174,7 @@ ! ! 4: Transfer file ! SOURCE%SCALE_FAC = 0 ! Scale factor (-1=disabled) ! SOURCE%OUTPUT_FAC = 0 ! Output factor (0=normalized) -! SOURCE%TABLE_FAC = 0 ! Table factor +! SOURCE%TABLE_FAC = 0 ! Table factor ! 0 : Dimensional. ! 1 : Nondimensional in terms of U10 ! 2 : Nondimensional in terms of U* diff --git a/model/nml/ww3_prnc.nml b/model/nml/ww3_prnc.nml index 38d69c32d..0795a45fa 100644 --- a/model/nml/ww3_prnc.nml +++ b/model/nml/ww3_prnc.nml @@ -82,4 +82,3 @@ ! -------------------------------------------------------------------- ! ! WAVEWATCH III - end of namelist ! ! -------------------------------------------------------------------- ! - diff --git a/model/nml/ww3_shel.nml b/model/nml/ww3_shel.nml index 7989eda08..528b35c56 100644 --- a/model/nml/ww3_shel.nml +++ b/model/nml/ww3_shel.nml @@ -9,7 +9,7 @@ ! * IOSTYP defines the output server mode for parallel implementation. ! 0 : No data server processes, direct access output from ! each process (requires true parallel file system). -! 1 : No data server process. All output for each type +! 1 : No data server process. All output for each type ! performed by process that performs computations too. ! 2 : Last process is reserved for all output, and does no ! computing. @@ -18,7 +18,7 @@ ! * namelist must be terminated with / ! * definitions & defaults: ! DOMAIN%IOSTYP = 1 ! Output server type -! DOMAIN%START = '19680606 000000' ! Start date for the entire model +! DOMAIN%START = '19680606 000000' ! Start date for the entire model ! DOMAIN%STOP = '19680607 000000' ! Stop date for the entire model ! -------------------------------------------------------------------- ! &DOMAIN_NML @@ -76,9 +76,9 @@ ! * the point file is a space separated values per line : ! longitude latitude 'name' (C*40) ! -! * the full list of field names is : +! * the full list of field names is : ! All parameters listed below are available in output file of the types -! ASCII and NetCDF. If selected output file types are grads or grib, +! ASCII and NetCDF. If selected output file types are grads or grib, ! some parameters may not be available. The first two columns in the ! table below identify such cases by flags, cols 1 (GRB) and 2 (GXO) ! refer to grib (ww3_grib) and grads (gx_outf), respectively. @@ -86,13 +86,13 @@ ! Columns 3 and 4 provide group and parameter numbers per group. ! Columns 5, 6 and 7 provide: ! 5 - code name (internal) -! 6 - output tags (names used is ASCII file extensions, NetCDF +! 6 - output tags (names used is ASCII file extensions, NetCDF ! variable names and namelist-based selection ! 7 - Long parameter name/definition ! ! G G ! R X Grp Param Code Output Parameter/Group -! B O Numb Numbr Name Tag Definition +! B O Numb Numbr Name Tag Definition ! -------------------------------------------------- ! 1 Forcing Fields ! ------------------------------------------------- @@ -139,7 +139,7 @@ ! F F 3 5 STH2M STH2M Directional spreading from a2,b2 ! F F 3 6 WN WN Wavenumber array ! ------------------------------------------------- -! 4 Spectral Partition Parameters +! 4 Spectral Partition Parameters ! ------------------------------------------------- ! T T 4 1 PHS PHS Partitioned wave heights. ! T T 4 2 PTP PTP Partitioned peak period. @@ -173,15 +173,15 @@ ! F F 5 10 WHITECAP WCM Whitecap moment ! F F 5 11 FWS FWS Wind sea mean period ! ------------------------------------------------- -! 6 Wave-ocean layer +! 6 Wave-ocean layer ! ------------------------------------------------- ! F F 6 1 S[XX,YY,XY] SXY Radiation stresses. ! F F 6 2 TAUO[X,Y] TWO Wave to ocean momentum flux -! F F 6 3 BHD BHD Bernoulli head (J term) +! F F 6 3 BHD BHD Bernoulli head (J term) ! F F 6 4 PHIOC FOC Wave to ocean energy flux ! F F 6 5 TUS[X,Y] TUS Stokes transport ! F F 6 6 USS[X,Y] USS Surface Stokes drift -! F F 6 7 [PR,TP]MS P2S Second-order sum pressure +! F F 6 7 [PR,TP]MS P2S Second-order sum pressure ! F F 6 8 US3D USF Spectrum of surface Stokes drift ! F F 6 9 P2SMS P2L Micro seism source term ! F F 6 10 TAUICE TWI Wave to sea ice stress @@ -189,12 +189,12 @@ ! F F 6 12 USSP USP Partitioned surface Stokes drift ! F F 6 13 TAUOC[X,Y] TOC Total momentum to the ocean ! ------------------------------------------------- -! 7 Wave-bottom layer +! 7 Wave-bottom layer ! ------------------------------------------------- ! F F 7 1 ABA ABR Near bottom rms amplitides. ! F F 7 2 UBA UBR Near bottom rms velocities. ! F F 7 3 BEDFORMS BED Bedforms -! F F 7 4 PHIBBL FBB Energy flux due to bottom friction +! F F 7 4 PHIBBL FBB Energy flux due to bottom friction ! F F 7 5 TAUBBL TBB Momentum flux due to bottom friction ! ------------------------------------------------- ! 8 Spectrum parameters @@ -206,15 +206,15 @@ ! F F 8 5 ALPYT AYT Correl sea surface gradients (y,t) ! F F 8 6 ALPXY AXY Correl sea surface gradients (x,y) ! ------------------------------------------------- -! 9 Numerical diagnostics +! 9 Numerical diagnostics ! ------------------------------------------------- ! T T 9 1 DTDYN DTD Average time step in integration. ! T T 9 2 FCUT FC Cut-off frequency. -! T T 9 3 CFLXYMAX CFX Max. CFL number for spatial advection. -! T T 9 4 CFLTHMAX CFD Max. CFL number for theta-advection. -! F F 9 5 CFLKMAX CFK Max. CFL number for k-advection. +! T T 9 3 CFLXYMAX CFX Max. CFL number for spatial advection. +! T T 9 4 CFLTHMAX CFD Max. CFL number for theta-advection. +! F F 9 5 CFLKMAX CFK Max. CFL number for k-advection. ! ------------------------------------------------- -! 10 User defined +! 10 User defined ! ------------------------------------------------- ! F F 10 1 U1 User defined #1. (requires coding ...) ! F F 10 2 U2 User defined #1. (requires coding ...) @@ -386,9 +386,3 @@ ! -------------------------------------------------------------------- ! ! WAVEWATCH III - end of namelist ! ! -------------------------------------------------------------------- ! - - - - - - diff --git a/model/nml/ww3_uprstr.nml b/model/nml/ww3_uprstr.nml index 947e024b8..939cf3332 100644 --- a/model/nml/ww3_uprstr.nml +++ b/model/nml/ww3_uprstr.nml @@ -4,7 +4,7 @@ ! -------------------------------------------------------------------- ! -! Define the assimilation time for initialising the wave model. This +! Define the assimilation time for initialising the wave model. This ! has to be the same as the time of the restart.ww3 ! ! * namelist must be terminated with / @@ -22,7 +22,7 @@ ! set. Setting non-relevant variables should not affect the way the ! code works ! -! A number of different update approaches are available. UPDN is used +! A number of different update approaches are available. UPDN is used ! for the Nth approach ! ! The UPDN*, with N<2 the same correction factor is applied at all @@ -40,12 +40,12 @@ ! the maximum SWH correction factor applied to all the ! gridpoints, as both a multiple or divisor (e.g. cap at 5.0 ! means SWHANL/SWHBKG<=5.0 and SWHANL/SWHBKG>=0.2). The value -! given should not be less than 1.0 +! given should not be less than 1.0 ! Name of the file with the SWH analysis from the DA system ! suffix .grbtxt for text out of grib2 file. ! UPD2 :: Option 2 The fac(x,y,frq,theta), is calculated at each -! grid point according to HsBckg and HsAnl -! Expected input the Analysis field, grbtxt format +! grid point according to HsBckg and HsAnl +! Expected input the Analysis field, grbtxt format ! UPD3 :: Option 3 The update factor is a surface with the shape ! of the background spectrum. ! Expected input: the Analysis field, grbtxt format and cap @@ -57,9 +57,9 @@ ! The algorithm requires the mapping of each partition on the ! individual spectra; the map is used to determine the ! weighting surfaces. -! Expected input: the Analysis field, grbtxt format and the +! Expected input: the Analysis field, grbtxt format and the ! functions(frq,theta) of the update to be applied. -! +! ! UPDN, with N>=5 each gridpoint has its own update factor and uses ! wind field data to evaluate wind-sea and swell fields. Also ! uses: @@ -110,4 +110,3 @@ ! -------------------------------------------------------------------- ! ! WAVEWATCH III - end of namelist ! ! -------------------------------------------------------------------- ! - diff --git a/model/src/PDLIB/yowdatapool.F90 b/model/src/PDLIB/yowdatapool.F90 index 101b4c036..24ae18162 100644 --- a/model/src/PDLIB/yowdatapool.F90 +++ b/model/src/PDLIB/yowdatapool.F90 @@ -39,13 +39,13 @@ module yowDatapool use MPI, only: MPI_COMM_WORLD, MPI_INTEGER, MPI_REAL4, MPI_REAL8, MPI_STATUS_SIZE implicit none -!#ifdef USE_SINGLE -! !> single precision. Enable with compiler flag -DUSE_SINGLE -! integer,parameter :: rkind = 4 -!#else + !#ifdef USE_SINGLE + ! !> single precision. Enable with compiler flag -DUSE_SINGLE + ! integer,parameter :: rkind = 4 + !#else !> double precision. Default real datatype - integer,parameter :: rkind = 4 -!#endif + integer,parameter :: rkind = 4 + !#endif logical, parameter :: debugPrePartition = .false. logical, parameter :: debugPostPartition = .false. logical, parameter :: debugParmetis = .false. @@ -72,10 +72,10 @@ module yowDatapool !> MPI Real Type !> Shpuld be MPI_REAL8 integer :: istatus(MPI_STATUS_SIZE) -!#ifdef USE_SINGLE + !#ifdef USE_SINGLE integer, save :: rtype = MPI_REAL4 -!#else -! integer, save :: rtype = MPI_REAL8 -!#endif + !#else + ! integer, save :: rtype = MPI_REAL8 + !#endif end module yowDatapool diff --git a/model/src/PDLIB/yowelementpool.F90 b/model/src/PDLIB/yowelementpool.F90 index 8bf802491..f1f06b293 100644 --- a/model/src/PDLIB/yowelementpool.F90 +++ b/model/src/PDLIB/yowelementpool.F90 @@ -47,7 +47,7 @@ module yowElementpool !> number of local elements integer, public :: ne = 0 - !> number of elements of the augmented domain + !> number of elements of the augmented domain !> local element array. it stores the local node IDs !> first index from 1 to 3. @@ -64,7 +64,7 @@ module yowElementpool !> ne long. give the global element id integer, public, target, allocatable :: ielg(:) - contains +contains !> Returns true if the element belongs to rank. diff --git a/model/src/PDLIB/yowerr.F90 b/model/src/PDLIB/yowerr.F90 index b99c37a9c..57e5c0675 100644 --- a/model/src/PDLIB/yowerr.F90 +++ b/model/src/PDLIB/yowerr.F90 @@ -38,7 +38,7 @@ !> Has some subroutine to make a nice error message module yowerr implicit none - contains +contains subroutine parallel_abort(string, error) use yowDatapool, only: comm use MPI @@ -73,148 +73,148 @@ subroutine parallel_abort(string, error) if(lopen) write(11,'(i4,2a)') myrank,': MPI ERROR: ', errorstring endif do i=1,200; inquire(i,opened=lopen); if(lopen) close(i); enddo; - call mpi_abort(comm, error,ierr) - if(ierr/=MPI_SUCCESS) write(*,*) "parallel_abort: ierr=", ierr - else - do i=1,200; inquire(i,opened=lopen); if(lopen) close(i); enddo; - call mpi_abort(comm, 0,ierr) - if(ierr/=MPI_SUCCESS) write(*,*) "parallel_abort: ierr=", ierr - endif - end subroutine parallel_abort - - - !> print various error strings and exit. - !> Call this to print an error string and optional line number, file and MPI error string - !> \param[in] string Errorstring - !> \param[in] line Line number - !> \param[in] file Filename - !> \param[in] errno The MPI error number which is translated into an error string - subroutine abort(string, line, file, errno) - use yowDatapool, only: comm - use MPI - implicit none - ! Errorstring to print - character(*), optional, intent(in) :: string - ! Linenumber to print - integer, optional, intent(in) :: line - ! Filename to print - character(*), optional, intent(in) :: file - ! MPI error number to translate - integer, optional, intent(in) :: errno - ! Linenumber as string - character(50) :: lineNumber - ! MPI_MAX_ERROR_STRING = 1024 - ! MPI Errorstring - character(MPI_MAX_ERROR_STRING) :: errorstring - ! The rank of this thread - integer :: myrank - ! real MPI errorsting lengt - integer :: stringLengh - ! - integer :: ierr - - ! Get rank - call mpi_comm_rank(comm, myrank,ierr) -! if(ierr/=MPI_SUCCESS) write(*,*) "parallel_abort: ierr=", ierr - - ! Always print rank - write(*, '(i2,a)', advance='no') myrank, " " - - ! Print a simple "ERROR" when no MPI error number was given because the MPI error string contain an "ERROR" allready - if(.not. present(errno)) then - write(*,'(a)', advance='no' ) " ERROR " - endif - - ! print file and linenumber - if(present(file)) then - write(*,'(a)',advance='no' ) file - - if(present(line)) then - Write(lineNumber, '(i10)') line - write(*, '(2a)', advance='no') ":", trim(adjustl(lineNumber)) - endif - - write(*, '(a)', advance='no') " " - endif - - ! if only linenumber is present, add an "Line:" string - if(.not. present(file) .and. present(line)) then - Write(lineNumber, '(i10)') line - write(*, '(2a)', advance='no') "Line:", trim(adjustl(lineNumber)) - write(*, '(a)', advance='no') " " - endif - - ! print the errror string - if(present(string)) then - write(*,'(a)', advance='no') string - endif - - ! translate and print the MPI error string - if(present(errno) .and. errno /= MPI_SUCCESS) then - call mpi_error_string(errno, errorstring, stringLengh, ierr) - write(*,'(2a)', advance='no') 'MPI ERROR: ', errorstring(1:stringLengh) - endif - - write(*,*) - stop - - end subroutine abort - - !> print warning - !> Call this to print an warning string and optional line number, and file - !> \param[in] string warnstring - !> \param[in] line Line number - !> \param[in] file Filename - subroutine warn(string, line, file) - use yowDatapool, only: comm - use MPI - implicit none - ! Errorstring to print - character(*), optional, intent(in) :: string - ! Linenumber to print - integer, optional, intent(in) :: line - ! Filename to print - character(*), optional, intent(in) :: file - ! Linenumber as string - character(50) :: lineNumber - ! The rank of this thread - integer :: myrank - ! - integer :: ierr - - ! Get rank - call mpi_comm_rank(comm, myrank,ierr) -! if(ierr/=MPI_SUCCESS) write(*,*) "parallel_abort: ierr=", ierr - - ! Always print rank - write(*, '(i2,a)', advance='no') myrank, " " - - write(*,'(a)', advance='no' ) " WARN " - - ! print file and linenumber - if(present(file)) then - write(*,'(a)',advance='no' ) file - - if(present(line)) then - Write(lineNumber, '(i10)') line - write(*, '(2a)', advance='no') ":", trim(adjustl(lineNumber)) - endif - - write(*, '(a)', advance='no') " " - endif - - ! if only linenumber is present, add an "Line:" string - if(.not. present(file) .and. present(line)) then - Write(lineNumber, '(i10)') line - write(*, '(2a)', advance='no') "Line:", trim(adjustl(lineNumber)) - write(*, '(a)', advance='no') " " - endif - - ! print the errror string - if(present(string)) then - write(*,'(a)', advance='no') string - endif - - write(*,*) - end subroutine warn -end module yowerr + call mpi_abort(comm, error,ierr) + if(ierr/=MPI_SUCCESS) write(*,*) "parallel_abort: ierr=", ierr + else + do i=1,200; inquire(i,opened=lopen); if(lopen) close(i); enddo; + call mpi_abort(comm, 0,ierr) + if(ierr/=MPI_SUCCESS) write(*,*) "parallel_abort: ierr=", ierr + endif + end subroutine parallel_abort + + + !> print various error strings and exit. + !> Call this to print an error string and optional line number, file and MPI error string + !> \param[in] string Errorstring + !> \param[in] line Line number + !> \param[in] file Filename + !> \param[in] errno The MPI error number which is translated into an error string + subroutine abort(string, line, file, errno) + use yowDatapool, only: comm + use MPI + implicit none + ! Errorstring to print + character(*), optional, intent(in) :: string + ! Linenumber to print + integer, optional, intent(in) :: line + ! Filename to print + character(*), optional, intent(in) :: file + ! MPI error number to translate + integer, optional, intent(in) :: errno + ! Linenumber as string + character(50) :: lineNumber + ! MPI_MAX_ERROR_STRING = 1024 + ! MPI Errorstring + character(MPI_MAX_ERROR_STRING) :: errorstring + ! The rank of this thread + integer :: myrank + ! real MPI errorsting lengt + integer :: stringLengh + ! + integer :: ierr + + ! Get rank + call mpi_comm_rank(comm, myrank,ierr) + ! if(ierr/=MPI_SUCCESS) write(*,*) "parallel_abort: ierr=", ierr + + ! Always print rank + write(*, '(i2,a)', advance='no') myrank, " " + + ! Print a simple "ERROR" when no MPI error number was given because the MPI error string contain an "ERROR" allready + if(.not. present(errno)) then + write(*,'(a)', advance='no' ) " ERROR " + endif + + ! print file and linenumber + if(present(file)) then + write(*,'(a)',advance='no' ) file + + if(present(line)) then + Write(lineNumber, '(i10)') line + write(*, '(2a)', advance='no') ":", trim(adjustl(lineNumber)) + endif + + write(*, '(a)', advance='no') " " + endif + + ! if only linenumber is present, add an "Line:" string + if(.not. present(file) .and. present(line)) then + Write(lineNumber, '(i10)') line + write(*, '(2a)', advance='no') "Line:", trim(adjustl(lineNumber)) + write(*, '(a)', advance='no') " " + endif + + ! print the errror string + if(present(string)) then + write(*,'(a)', advance='no') string + endif + + ! translate and print the MPI error string + if(present(errno) .and. errno /= MPI_SUCCESS) then + call mpi_error_string(errno, errorstring, stringLengh, ierr) + write(*,'(2a)', advance='no') 'MPI ERROR: ', errorstring(1:stringLengh) + endif + + write(*,*) + stop + + end subroutine abort + + !> print warning + !> Call this to print an warning string and optional line number, and file + !> \param[in] string warnstring + !> \param[in] line Line number + !> \param[in] file Filename + subroutine warn(string, line, file) + use yowDatapool, only: comm + use MPI + implicit none + ! Errorstring to print + character(*), optional, intent(in) :: string + ! Linenumber to print + integer, optional, intent(in) :: line + ! Filename to print + character(*), optional, intent(in) :: file + ! Linenumber as string + character(50) :: lineNumber + ! The rank of this thread + integer :: myrank + ! + integer :: ierr + + ! Get rank + call mpi_comm_rank(comm, myrank,ierr) + ! if(ierr/=MPI_SUCCESS) write(*,*) "parallel_abort: ierr=", ierr + + ! Always print rank + write(*, '(i2,a)', advance='no') myrank, " " + + write(*,'(a)', advance='no' ) " WARN " + + ! print file and linenumber + if(present(file)) then + write(*,'(a)',advance='no' ) file + + if(present(line)) then + Write(lineNumber, '(i10)') line + write(*, '(2a)', advance='no') ":", trim(adjustl(lineNumber)) + endif + + write(*, '(a)', advance='no') " " + endif + + ! if only linenumber is present, add an "Line:" string + if(.not. present(file) .and. present(line)) then + Write(lineNumber, '(i10)') line + write(*, '(2a)', advance='no') "Line:", trim(adjustl(lineNumber)) + write(*, '(a)', advance='no') " " + endif + + ! print the errror string + if(present(string)) then + write(*,'(a)', advance='no') string + endif + + write(*,*) + end subroutine warn + end module yowerr diff --git a/model/src/PDLIB/yowexchangeModule.F90 b/model/src/PDLIB/yowexchangeModule.F90 index c732497cd..c6d620ba3 100644 --- a/model/src/PDLIB/yowexchangeModule.F90 +++ b/model/src/PDLIB/yowexchangeModule.F90 @@ -47,7 +47,7 @@ module yowExchangeModule !> Holds some data belong to a neighbor Domain type, public :: t_neighborDomain - + !> the domain ID !> The domain ID of the neighbor domain. Starts by 1 integer :: domainID = 0 @@ -70,7 +70,7 @@ module yowExchangeModule integer, allocatable :: nodesToSend(:) ! MPI datatypes for size(U) == npa+1 U(0:npa) - + !> MPI datatypes for 1D exchange integer :: p1DRsendType_zero = MPI_DATATYPE_NULL integer :: p1DRrecvType_zero = MPI_DATATYPE_NULL @@ -78,7 +78,7 @@ module yowExchangeModule !> MPI datatypes for 2D exchange integer :: p2DRsendType_zero = MPI_DATATYPE_NULL integer :: p2DRrecvType_zero = MPI_DATATYPE_NULL - + ! MPI datatypes for size(U) == npa U(1:npa) !> MPI datatypes for 1D exchange integer :: p1DRsendType = MPI_DATATYPE_NULL @@ -89,9 +89,9 @@ module yowExchangeModule integer :: p2DRsendType2 = MPI_DATATYPE_NULL integer :: p2DRrecvType2 = MPI_DATATYPE_NULL - contains -! procedure :: exchangeGhostIds -! final :: finalizeNeighborDomain + contains + ! procedure :: exchangeGhostIds + ! final :: finalizeNeighborDomain procedure :: finalize procedure :: createMPIType @@ -108,7 +108,7 @@ module yowExchangeModule integer, public :: n2ndDim = 1 - contains +contains subroutine finalize(this) @@ -266,8 +266,8 @@ subroutine PDLIB_exchange1Dreal(U) do i=1, nConnDomains tag = 10000 + myrank call MPI_IRecv(U, 1, neighborDomains(i)%p1DRrecvType, & - neighborDomains(i)%domainID-1, tag, comm, & - recvRqst(i), ierr) + neighborDomains(i)%domainID-1, tag, comm, & + recvRqst(i), ierr) if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_IRecv", ierr) endif @@ -277,8 +277,8 @@ subroutine PDLIB_exchange1Dreal(U) do i=1, nConnDomains tag = 10000 + (neighborDomains(i)%domainID-1) call MPI_ISend(U, 1, neighborDomains(i)%p1DRsendType, & - neighborDomains(i)%domainID-1, tag, comm, & - sendRqst(i), ierr); + neighborDomains(i)%domainID-1, tag, comm, & + sendRqst(i), ierr); if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_ISend", ierr) endif @@ -293,7 +293,7 @@ end subroutine PDLIB_exchange1Dreal !> \overload PDLIB_exchange1Dreal - !> + !> !> \note MPI recv tag: 30000 + MPI rank !> \note MPI send tag: 30000 + neighbor MPI rank subroutine PDLIB_exchange2Dreal(U) @@ -311,56 +311,56 @@ subroutine PDLIB_exchange2Dreal(U) #ifdef W3_DEBUGEXCH - WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 3' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 3' + FLUSH(740+IAPROC) #endif ! post receives #ifdef W3_DEBUGEXCH - WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 4' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 4' + FLUSH(740+IAPROC) #endif do i=1, nConnDomains tag = 30000 + myrank call MPI_IRecv(U, 1, neighborDomains(i)%p2DRrecvType1, & - neighborDomains(i)%domainID-1, tag, comm, & - recvRqst(i), ierr) + neighborDomains(i)%domainID-1, tag, comm, & + recvRqst(i), ierr) if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_IRecv", ierr) endif enddo #ifdef W3_DEBUGEXCH - WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 5' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 5' + FLUSH(740+IAPROC) #endif ! post sends do i=1, nConnDomains tag = 30000 + (neighborDomains(i)%domainID-1) call MPI_ISend(U, 1, neighborDomains(i)%p2DRsendType1, & - neighborDomains(i)%domainID-1, tag, comm, & - sendRqst(i), ierr) + neighborDomains(i)%domainID-1, tag, comm, & + sendRqst(i), ierr) if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_ISend", ierr) endif end do #ifdef W3_DEBUGEXCH - WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 6' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 6' + FLUSH(740+IAPROC) #endif ! Wait for completion call mpi_waitall(nConnDomains, recvRqst, recvStat,ierr) if(ierr/=MPI_SUCCESS) CALL PARALLEL_ABORT("waitall", ierr) #ifdef W3_DEBUGEXCH - WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 11' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 11' + FLUSH(740+IAPROC) #endif call mpi_waitall(nConnDomains, sendRqst, sendStat,ierr) if(ierr/=MPI_SUCCESS) CALL PARALLEL_ABORT("waitall", ierr) #ifdef W3_DEBUGEXCH - WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 12' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 12' + FLUSH(740+IAPROC) #endif end subroutine PDLIB_exchange2Dreal @@ -385,7 +385,7 @@ subroutine finalizeExchangeModule() deallocate(neighborDomains) endif end subroutine finalizeExchangeModule -!> exchange values in U. + !> exchange values in U. !> \param[inout] U array with values to exchange. np+ng+1 long. !> U[0:npa] Send values from U(1:np) to other threads. !> Receive values from other threads and updates U(np+1:np+ng) @@ -406,32 +406,32 @@ subroutine PDLIB_exchange1Dreal_zero(U) ! It is impossible to add these range checks because assumed shape array start vom 1:npa+1 even if you allocate it from 0:npa -! if(size(U) /= npa+1) then -! write(errstr, *) "size(U) /= npa+1", size(U), "should be", npa+1 -! ABORT(errstr) -! endif -! -! if(ubound(U,1) /= npa) then -! write(errstr, *) "ubound(U) /= npa", ubound(U), "should be", npa -! ABORT(errstr) -! endif -! -! if(lbound(U,1) /= 0) then -! write(errstr, *) "lbound(U) /= 0", lbound(U), "should be 0" -! ABORT(errstr) -! endif + ! if(size(U) /= npa+1) then + ! write(errstr, *) "size(U) /= npa+1", size(U), "should be", npa+1 + ! ABORT(errstr) + ! endif + ! + ! if(ubound(U,1) /= npa) then + ! write(errstr, *) "ubound(U) /= npa", ubound(U), "should be", npa + ! ABORT(errstr) + ! endif + ! + ! if(lbound(U,1) /= 0) then + ! write(errstr, *) "lbound(U) /= 0", lbound(U), "should be 0" + ! ABORT(errstr) + ! endif ! post receives do i=1, nConnDomains tag = 10001 + myrank call MPI_IRecv(U, & - 1, & - neighborDomains(i)%p1DRrecvType_zero, & - neighborDomains(i)%domainID-1, & - tag, & - comm, & - recvRqst(i), & - ierr) + 1, & + neighborDomains(i)%p1DRrecvType_zero, & + neighborDomains(i)%domainID-1, & + tag, & + comm, & + recvRqst(i), & + ierr) if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_IRecv", ierr) endif @@ -441,16 +441,16 @@ subroutine PDLIB_exchange1Dreal_zero(U) do i=1, nConnDomains tag = 10001 + (neighborDomains(i)%domainID-1) call MPI_ISend(U, & - 1, & - neighborDomains(i)%p1DRsendType_zero, & - neighborDomains(i)%domainID-1, & - tag, & - comm, & - sendRqst(i), & - ierr); - if(ierr/=MPI_SUCCESS) then - CALL PARALLEL_ABORT("MPI_ISend", ierr) - endif + 1, & + neighborDomains(i)%p1DRsendType_zero, & + neighborDomains(i)%domainID-1, & + tag, & + comm, & + sendRqst(i), & + ierr); + if(ierr/=MPI_SUCCESS) then + CALL PARALLEL_ABORT("MPI_ISend", ierr) + endif end do ! Wait for completion @@ -474,38 +474,38 @@ subroutine PDLIB_exchange2Dreal_zero(U) integer :: recvStat(MPI_STATUS_SIZE, nConnDomains), sendStat(MPI_STATUS_SIZE, nConnDomains) character(len=200) errstr -! It is impossible to add these range checks because assumed shape array start vom 1:npa+1 even if you allocate it from 0:npa -! if(size(U,2) /= npa+1) then -! write(errstr, *) "size(U,2) /= npa+1", size(U,2), "should be", npa+1 -! ABORT(errstr) -! endif -! -! if(ubound(U,2) /= npa) then -! write(errstr, *) "ubound(U,2) /= npa", ubound(U,2), "should be", npa -! ABORT(errstr) -! endif -! -! if(lbound(U,2) /= 0) then -! write(errstr, *) "lbound(U,2) /= 0", lbound(U,2), "should be 0" -! ABORT(errstr) -! endif - -! if((size(U,1) /= n2ndDim) ) then -! write(errstr, *) "size(U,1) /= n2ndDim size(U,1)=", size(U,1), " n2ndDim=", n2ndDim -! ABORT(errstr) -! endif + ! It is impossible to add these range checks because assumed shape array start vom 1:npa+1 even if you allocate it from 0:npa + ! if(size(U,2) /= npa+1) then + ! write(errstr, *) "size(U,2) /= npa+1", size(U,2), "should be", npa+1 + ! ABORT(errstr) + ! endif + ! + ! if(ubound(U,2) /= npa) then + ! write(errstr, *) "ubound(U,2) /= npa", ubound(U,2), "should be", npa + ! ABORT(errstr) + ! endif + ! + ! if(lbound(U,2) /= 0) then + ! write(errstr, *) "lbound(U,2) /= 0", lbound(U,2), "should be 0" + ! ABORT(errstr) + ! endif + + ! if((size(U,1) /= n2ndDim) ) then + ! write(errstr, *) "size(U,1) /= n2ndDim size(U,1)=", size(U,1), " n2ndDim=", n2ndDim + ! ABORT(errstr) + ! endif ! post receives do i=1, nConnDomains tag = 30001 + myrank call MPI_IRecv(U, & - 1, & - neighborDomains(i)%p2DRrecvType_zero, & - neighborDomains(i)%domainID-1, & - tag, & - comm, & - recvRqst(i), & - ierr) + 1, & + neighborDomains(i)%p2DRrecvType_zero, & + neighborDomains(i)%domainID-1, & + tag, & + comm, & + recvRqst(i), & + ierr) if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_IRecv", ierr) endif @@ -515,18 +515,18 @@ subroutine PDLIB_exchange2Dreal_zero(U) do i=1, nConnDomains tag = 30001 + (neighborDomains(i)%domainID-1) call MPI_ISend(U, & - 1, & - neighborDomains(i)%p2DRsendType_zero, & - neighborDomains(i)%domainID-1, & - tag, & - comm, & - sendRqst(i), & - ierr); - if(ierr/=MPI_SUCCESS) then - CALL PARALLEL_ABORT("MPI_ISend", ierr) - endif + 1, & + neighborDomains(i)%p2DRsendType_zero, & + neighborDomains(i)%domainID-1, & + tag, & + comm, & + sendRqst(i), & + ierr); + if(ierr/=MPI_SUCCESS) then + CALL PARALLEL_ABORT("MPI_ISend", ierr) + endif end do - + ! Wait for completion call mpi_waitall(nConnDomains, recvRqst, recvStat,ierr) diff --git a/model/src/PDLIB/yowfunction.F90 b/model/src/PDLIB/yowfunction.F90 index 5edaa8168..46971c555 100644 --- a/model/src/PDLIB/yowfunction.F90 +++ b/model/src/PDLIB/yowfunction.F90 @@ -40,19 +40,19 @@ !> \author Thomas Huxhorn !> \date 2011-2012 module yowfunction - CONTAINS -!********************************************************************** -!* * -!********************************************************************** - SUBROUTINE PDLIB_ABORT(istat) - IMPLICIT NONE - integer, intent(in) :: istat - Print *, 'Error with istat=', istat - CALL ABORT +CONTAINS + !********************************************************************** + !* * + !********************************************************************** + SUBROUTINE PDLIB_ABORT(istat) + IMPLICIT NONE + integer, intent(in) :: istat + Print *, 'Error with istat=', istat + CALL ABORT END SUBROUTINE PDLIB_ABORT -!********************************************************************** -!* * -!********************************************************************** + !********************************************************************** + !* * + !********************************************************************** SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel USE W3ODATMD, only : IAPROC, NAPROC, NTPROC USE W3ADATMD, ONLY: MPI_COMM_WCMP @@ -67,18 +67,18 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel ! Computing ListNP and ListNPA ! #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 1' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 1' + FLUSH(740+IAPROC) #endif allocate(ListNP(NAPROC), ListNPA(NAPROC), iVect(2), stat=istat) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 2' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 2' + FLUSH(740+IAPROC) #endif IF (istat /= 0) CALL PDLIB_ABORT(1) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 3' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 3' + FLUSH(740+IAPROC) #endif IF (IAPROC .eq. 1) THEN ListNP(1)=np @@ -101,32 +101,32 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel END IF deallocate(iVect) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 4' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 4' + FLUSH(740+IAPROC) #endif ! ! ListIPLG ! sumNP=sum(ListNPA) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 5, sumNP=', sumNP - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 5, sumNP=', sumNP + FLUSH(740+IAPROC) #endif allocate(ListIPLG(sumNP), stat=istat) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 6' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 6' + FLUSH(740+IAPROC) #endif IF (istat /= 0) CALL PDLIB_ABORT(2) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 7' - WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, NAPROC=', NAPROC, ' NTPROC=', NTPROC - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 7' + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, NAPROC=', NAPROC, ' NTPROC=', NTPROC + FLUSH(740+IAPROC) #endif IF (IAPROC .eq. 1) THEN #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Main node 1' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Main node 1' + FLUSH(740+IAPROC) #endif idx=0 DO IP=1,NPA @@ -134,8 +134,8 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel ListIPLG(IP)=iplg(IP) END DO #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Main node 2' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Main node 2' + FLUSH(740+IAPROC) #endif DO IPROC=2,NAPROC len=ListNPA(IPROC) @@ -149,49 +149,49 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel deallocate(iVect) END DO #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Main node 3' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Main node 3' + FLUSH(740+IAPROC) #endif DO IPROC=2,NAPROC #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before mpi_send IPROC=', IPROC - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Before mpi_send IPROC=', IPROC + FLUSH(740+IAPROC) #endif CALL MPI_SEND(ListIPLG, sumNP,MPI_INTEGER, iProc-1, 271, MPI_COMM_WCMP, ierr) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'After mpi_send IPROC=', IPROC - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'After mpi_send IPROC=', IPROC + FLUSH(740+IAPROC) #endif END DO #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Main node 4' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Main node 4' + FLUSH(740+IAPROC) #endif ELSE #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Peripheral node 1' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Peripheral node 1' + FLUSH(740+IAPROC) #endif CALL MPI_SEND(iplg, npa,MPI_INTEGER, 0, 269, MPI_COMM_WCMP, ierr) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Peripheral node 2' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Peripheral node 2' + FLUSH(740+IAPROC) #endif CALL MPI_RECV(ListIPLG,sumNP,MPI_INTEGER, 0, 271, MPI_COMM_WCMP, istatus, ierr) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Peripheral node 3' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Peripheral node 3' + FLUSH(740+IAPROC) #endif END IF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 8' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 8' + FLUSH(740+IAPROC) #endif END SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel -!********************************************************************** -!* * -!********************************************************************** - SUBROUTINE ComputeListNP_ListNPA_ListIPLG + !********************************************************************** + !* * + !********************************************************************** + SUBROUTINE ComputeListNP_ListNPA_ListIPLG USE W3ODATMD, only : IAPROC, NAPROC, NTPROC USE W3ADATMD, ONLY: MPI_COMM_WAVE USE yowDatapool, only: rtype, istatus @@ -201,84 +201,84 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG INCLUDE "mpif.h" INTEGER sumNP, iProc, ierr, istat #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before ComputeListNP_ListNPA_Kernel' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Before ComputeListNP_ListNPA_Kernel' + FLUSH(740+IAPROC) #endif IF (IAPROC .le. NAPROC) THEN - CALL ComputeListNP_ListNPA_ListIPLG_Kernel + CALL ComputeListNP_ListNPA_ListIPLG_Kernel END IF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) ' After ComputeListNP_ListNPA_Kernel' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) ' After ComputeListNP_ListNPA_Kernel' + FLUSH(740+IAPROC) #endif IF (IAPROC .eq. 1) THEN #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Doing the send' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Doing the send' + FLUSH(740+IAPROC) #endif sumNP=sum(ListNPA) DO iProc=NAPROC+1,NTPROC #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Loop state 1, iProc=', iProc - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Loop state 1, iProc=', iProc + FLUSH(740+IAPROC) #endif CALL MPI_SEND(ListNP, NAPROC,MPI_INTEGER, iProc-1, 20, MPI_COMM_WAVE, ierr) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Loop state 2, iProc=', iProc - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Loop state 2, iProc=', iProc + FLUSH(740+IAPROC) #endif CALL MPI_SEND(ListNPA,NAPROC,MPI_INTEGER, iProc-1, 21, MPI_COMM_WAVE, ierr) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Loop state 3, iProc=', iProc - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Loop state 3, iProc=', iProc + FLUSH(740+IAPROC) #endif CALL MPI_SEND(ListIPLG, sumNP,MPI_INTEGER, iProc-1, 271, MPI_COMM_WAVE, ierr) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Loop state 4, iProc=', iProc - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Loop state 4, iProc=', iProc + FLUSH(740+IAPROC) #endif END DO END IF IF (IAPROC .gt. NAPROC) THEN #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before allocation' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Before allocation' + FLUSH(740+IAPROC) #endif allocate(ListNP(NAPROC), ListNPA(NAPROC), stat=istat) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before receiving of data 1' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Before receiving of data 1' + FLUSH(740+IAPROC) #endif CALL MPI_RECV(ListNP ,NAPROC,MPI_INTEGER, 0, 20, MPI_COMM_WAVE, istatus, ierr) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before receiving of data 2' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Before receiving of data 2' + FLUSH(740+IAPROC) #endif CALL MPI_RECV(ListNPA,NAPROC,MPI_INTEGER, 0, 21, MPI_COMM_WAVE, istatus, ierr) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before computing sumNP' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Before computing sumNP' + FLUSH(740+IAPROC) #endif sumNP=sum(ListNPA) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before allocating ListIPLG' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Before allocating ListIPLG' + FLUSH(740+IAPROC) #endif allocate(ListIPLG(sumNP), stat=istat) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before receiving ListIPLG' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Before receiving ListIPLG' + FLUSH(740+IAPROC) #endif CALL MPI_RECV(ListIPLG,sumNP,MPI_INTEGER, 0, 271, MPI_COMM_WAVE, istatus, ierr) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'After receiving ListIPLG' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'After receiving ListIPLG' + FLUSH(740+IAPROC) #endif END IF END SUBROUTINE ComputeListNP_ListNPA_ListIPLG -!********************************************************************** -!* * -!********************************************************************** + !********************************************************************** + !* * + !********************************************************************** SUBROUTINE ComputeBoundaryInformation use yowNodepool, only: ListNP, ListNPA, ListIPLG USE W3GDATMD, ONLY: IOBP diff --git a/model/src/PDLIB/yownodepool.F90 b/model/src/PDLIB/yownodepool.F90 index 3af3d31de..8e98c3fc5 100644 --- a/model/src/PDLIB/yownodepool.F90 +++ b/model/src/PDLIB/yownodepool.F90 @@ -62,17 +62,17 @@ module yowNodepool !> The first domain starts by 1. Fortran Stye integer :: domainID = 0 - contains - !> Insert a node to the connected Nodes array. See Node_insertConnNode() - !> Just a helper subroutine to make nicer code - procedure :: insertConnNode + contains + !> Insert a node to the connected Nodes array. See Node_insertConnNode() + !> Just a helper subroutine to make nicer code + procedure :: insertConnNode - !> return a pointer to the i-th node number conntected to this node - !> Just a helper function to make nicer code - procedure :: connNodes + !> return a pointer to the i-th node number conntected to this node + !> Just a helper function to make nicer code + procedure :: connNodes - !> returns true if this node is a ghost node - procedure :: isGhost + !> returns true if this node is a ghost node + procedure :: isGhost end type t_Node !> coordinates of the local + ghost nodes. range [1:npa] @@ -138,7 +138,7 @@ module yowNodepool integer, public, allocatable :: np_perProcSum(:) - contains +contains !> return a pointer to the i-th node number conntected to this node. !> \param i @@ -195,9 +195,9 @@ subroutine insertConnNode(this, ind) end do this%nConnNodes = this%nConnNodes +1 -! connNode => this%connNodes(this%nConnNodes) + ! connNode => this%connNodes(this%nConnNodes) connNodes_data(this%id_global, this%nConnNodes) = ind -! connNode = index + ! connNode = index else this%nConnNodes = this%nConnNodes +1 end if diff --git a/model/src/PDLIB/yowpdlibmain.F90 b/model/src/PDLIB/yowpdlibmain.F90 index 0646f95d5..94f689714 100644 --- a/model/src/PDLIB/yowpdlibmain.F90 +++ b/model/src/PDLIB/yowpdlibmain.F90 @@ -43,15 +43,15 @@ module yowpdlibMain use yowerr use yowDatapool, only: rkind #ifdef W3_MEMCHECK - USE MallocInfo_m - USE W3ADATMD, ONLY: MALLINFOS + USE MallocInfo_m + USE W3ADATMD, ONLY: MALLINFOS #endif implicit none private public :: initFromGridDim, finalizePD - contains - +contains + !> @param[in] MNP number of nodes global !> @param[in] XP node X value !> @param[in] XY node Y value @@ -70,8 +70,8 @@ subroutine initFromGridDim(MNP, MNE, INE_global, secDim, MPIcomm) use yowExchangeModule, only: nConnDomains, setDimSize use yowRankModule, only: initRankModule, ipgl_npa #ifdef W3_MEMCHECK - USE MallocInfo_m - USE W3ADATMD, ONLY: MALLINFOS + USE MallocInfo_m + USE W3ADATMD, ONLY: MALLINFOS #endif implicit none @@ -83,45 +83,45 @@ subroutine initFromGridDim(MNP, MNE, INE_global, secDim, MPIcomm) call setDimSize(secDim) #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 1' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif #ifdef W3_DEBUGINIT Print *, '1: MPIcomm=', MPIcomm #endif call initMPI(MPIcomm) #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 2' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 2' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif #ifdef W3_DEBUGINIT Print *, '2: After initMPI' #endif call assignMesh(MNP, MNE) #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 3' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 3' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif #ifdef W3_DEBUGINIT Print *, '3: After assignMesh' #endif call prePartition() #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 4' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 4' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif #ifdef W3_DEBUGINIT Print *, '3: After prePartition' #endif call findConnNodes(INE_global) #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 5' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif #ifdef W3_DEBUGINIT Print *, '4: After findConnNodes' @@ -138,71 +138,71 @@ subroutine initFromGridDim(MNP, MNE, INE_global, secDim, MPIcomm) write(*,*) "Thread", myrank, "# local sides" , ns endif - ! call writeMesh() + ! call writeMesh() #ifdef W3_DEBUGINIT Print *, '4.1: After findConnNodes' #endif -! CALL REAL_MPI_BARRIER_PDLIB(MPIcomm, "Before call to runParmetis") + ! CALL REAL_MPI_BARRIER_PDLIB(MPIcomm, "Before call to runParmetis") call runParmetis(MNP) #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 6' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 6' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif -! CALL REAL_MPI_BARRIER_PDLIB(MPIcomm, "After call to runParmetis") + ! CALL REAL_MPI_BARRIER_PDLIB(MPIcomm, "After call to runParmetis") #ifdef W3_DEBUGINIT Print *, '5: After runParmetis' #endif call postPartition #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 7' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 7' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif #ifdef W3_DEBUGINIT Print *, 'Before findGhostNodes' #endif call findGhostNodes #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 8' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 8' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif call findConnDomains #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 9' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 9' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif call exchangeGhostIds #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 10' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 10' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif call postPartition2(INE_global) #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 11' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 11' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif call initRankModule #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 12' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 12' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif call ComputeTRIA_IEN_SI_CCON #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 13' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 13' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif call ComputeIA_JA_POSI_NNZ #ifdef W3_MEMCHECK - WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 14' - call getMallocInfo(mallinfos) - call printMallInfo(70000+myrank,mallInfos) + WRITE(70000+myrank,*) 'memcheck_____:', 'WW3_PDLIB SECTION 14' + call getMallocInfo(mallinfos) + call printMallInfo(70000+myrank,mallInfos) #endif if(debugPostPartition) then if(myrank == 0) then @@ -222,33 +222,33 @@ end subroutine initFromGridDim - SUBROUTINE REAL_MPI_BARRIER_PDLIB(TheComm, string) - IMPLICIT NONE - INCLUDE "mpif.h" - integer, intent(in) :: TheComm - character(*), intent(in) :: string - integer NbProc, eRank - integer :: istatus(MPI_STATUS_SIZE) - integer ierr, iField(1), iProc -! Print *, 'Start of REAL_MPI_BARRIER_PDLIB' - CALL MPI_COMM_RANK(TheComm, eRank, ierr) - CALL MPI_COMM_SIZE(TheComm, NbProc, ierr) -! Print *, ' eRank=', eRank, ' NbProc=', NbProc - iField(1)=1 - IF (eRank .eq. 0) THEN - DO iProc=2,NbProc -! Print *, ' Before MPI_RECV 1 iProc=', iProc - CALL MPI_RECV(iField, 1, MPI_INTEGER, iProc-1, 711, TheComm, istatus, ierr) -! Print *, ' Before MPI_SEND 1' - CALL MPI_SEND(iField, 1, MPI_INTEGER, iProc-1, 712, TheComm, ierr) - END DO - ELSE -! Print *, ' Before MPI_SEND 2 eRank=', eRank - CALL MPI_SEND(iField, 1, MPI_INTEGER, 0, 711, TheComm, ierr) -! Print *, ' Before MPI_RECV 2 eRank=', eRank - CALL MPI_RECV(iField, 1, MPI_INTEGER, 0, 712, TheComm, istatus, ierr) - END IF -! Print *, 'Passing barrier string=', string + SUBROUTINE REAL_MPI_BARRIER_PDLIB(TheComm, string) + IMPLICIT NONE + INCLUDE "mpif.h" + integer, intent(in) :: TheComm + character(*), intent(in) :: string + integer NbProc, eRank + integer :: istatus(MPI_STATUS_SIZE) + integer ierr, iField(1), iProc + ! Print *, 'Start of REAL_MPI_BARRIER_PDLIB' + CALL MPI_COMM_RANK(TheComm, eRank, ierr) + CALL MPI_COMM_SIZE(TheComm, NbProc, ierr) + ! Print *, ' eRank=', eRank, ' NbProc=', NbProc + iField(1)=1 + IF (eRank .eq. 0) THEN + DO iProc=2,NbProc + ! Print *, ' Before MPI_RECV 1 iProc=', iProc + CALL MPI_RECV(iField, 1, MPI_INTEGER, iProc-1, 711, TheComm, istatus, ierr) + ! Print *, ' Before MPI_SEND 1' + CALL MPI_SEND(iField, 1, MPI_INTEGER, iProc-1, 712, TheComm, ierr) + END DO + ELSE + ! Print *, ' Before MPI_SEND 2 eRank=', eRank + CALL MPI_SEND(iField, 1, MPI_INTEGER, 0, 711, TheComm, ierr) + ! Print *, ' Before MPI_RECV 2 eRank=', eRank + CALL MPI_RECV(iField, 1, MPI_INTEGER, 0, 712, TheComm, istatus, ierr) + END IF + ! Print *, 'Passing barrier string=', string END SUBROUTINE REAL_MPI_BARRIER_PDLIB !-------------------------------------------------------------------------- ! Init MPI @@ -394,7 +394,7 @@ subroutine findConnNodes(INE_global) use yowSidepool, only: ns, ns_global implicit none - integer, intent(in) :: INE_global(3,ne_global) + integer, intent(in) :: INE_global(3,ne_global) integer :: i, j, stat type(t_Node), pointer :: node integer JPREV, JNEXT @@ -486,7 +486,7 @@ subroutine runParmetis(MNP) ! parmetis need single precision real(4), allocatable :: xyz(:), tpwgts(:), ubvec(:) integer :: IP_glob, itmp - logical :: lexist = .false. + logical :: lexist = .false. ! Node to domain mapping. ! np_global long. give the domain number for die global node number @@ -496,7 +496,7 @@ subroutine runParmetis(MNP) integer :: i, j, stat, ierr type(t_Node), pointer :: node, nodeNeighbor -! CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 1") + ! CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 1") ! Create xadj and adjncy arrays. They holds the nodes neighbors in CSR Format ! Here, the adjacency structure of a graph is represented by two arrays, ! xadj[n+1] and adjncy[m]; n vertices and m edges. Every edge is listen twice @@ -504,7 +504,7 @@ subroutine runParmetis(MNP) if(stat/=0) call parallel_abort('adjncy allocation failure') allocate(xadj(np+1), stat=stat) if(stat/=0) call parallel_abort('xadj allocation failure') -! CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 2") + ! CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 2") xadj = 0 xadj(1) = 1 @@ -522,7 +522,7 @@ subroutine runParmetis(MNP) if(debugParmetis) write(710+myrank,*) i, j, j + xadj(i) - 1, adjncy(j + xadj(i) - 1), nodeNeighbor%id_global end do end do -! CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 3") + ! CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 3") ! Option for Parmetis allocate(options(3)) @@ -552,11 +552,11 @@ subroutine runParmetis(MNP) allocate(iweights(np_global)); iweights = 0 do i = 1, np_global read(100001,*) iweights(i) - enddo + enddo CLOSE(100001) ELSE wgtflag = 0 - ENDIF + ENDIF #else wgtflag = 0 #endif @@ -573,7 +573,7 @@ subroutine runParmetis(MNP) !vwgt(i) = max(1,iweights(iplg(i))) !vwgt(i) = max(1,itmp) vwgt(i) = itmp - enddo + enddo vwgt = 1 deallocate(iweights) else @@ -606,11 +606,11 @@ subroutine runParmetis(MNP) if(debugParmetis) write(710+myrank,*) np_global, ne_global, np, npa, ne do i = 1, np IP_glob = iplg(i) -!AR: this is questionable ... + !AR: this is questionable ... xyz(2*(i-1)+1) = REAL(xgrd(1,IP_glob)) xyz(2*(i-1)+2) = REAL(ygrd(1,IP_glob)) if(debugParmetis) then - write(710+myrank,*) i, np, xyz(2*(i-1)+1), xyz(2*(i-1)+2) + write(710+myrank,*) i, np, xyz(2*(i-1)+1), xyz(2*(i-1)+2) call flush(710+myrank) endif end do @@ -627,7 +627,7 @@ subroutine runParmetis(MNP) call mpi_allgather(np_perProcSum(myrank)+1, 1, itype, vtxdist, 1, itype, comm, ierr) if(ierr/=MPI_SUCCESS) call parallel_abort('partition: mpi_allgather',ierr) vtxdist(nTasks+1)=np_global+1 -! CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 7") + ! CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 7") ! check vtxdist ! myrank stats from 0 @@ -639,101 +639,101 @@ subroutine runParmetis(MNP) - ! My notes from manual: - ! p: # of processors; - ! n: total # of vertices (local) in graph sense; - ! m: total # of neighboring vertices ("edges"); double counted between neighboring vertice u and v. - ! ncon: # of weights for each vertex; - ! int(in) vtxdist(p+1): Processor j stores vertices vtxdist(j):vtxdist(j+1)-1 - ! int (in) xadj(n+1), adjncy(m): - ! locally, vertex j's neighboring vertices are adjncy(xadj(j):xadj(j+1)-1). adjncy points to global index; - ! int(in) vwgt(ncon*n), adjwgt(m): weights at vertices and "edges". Format of adjwgt follows adjncy; - ! int(in) wgtflag: 0: none (vwgt and adjwgt are NULL); - ! 1: edges (vwgt is NULL); 2: vertices (adjwgt is NULL); 3: both vertices & edges; - ! int(in) numflag: 0: C-style numbering from 0; 1: FORTRAN style from 1; - ! int(in) ndims: 2 or 3 (D); - ! float(in) xyz(ndims*n): coordinate for vertex j is xyz(j*ndims:(j+1)*ndims-1); - ! int(in) nparts: # of desired sub-domains (usually nTasks); - ! float(in) tpwgts(ncon*nparts): =1/nparts if sub-domains are to be of same size for each vertex weight; - ! float(in) ubvec(ncon): imbalance tolerance for each weight; - ! int(in) options: additonal parameters for the routine (see above); - ! int(out) edgecut: # of edges that are cut by the partitioning; - ! int(out) part(): array size = # of local vertices. It stores indices of local vertices. - - ! write(1112+myrank,*) "Thread",myrank,"sum;vtxdist", sum(vtxdist), vtxdist - ! write(1112+myrank,*) "Thread",myrank,"sum;xadj", sum(xadj), xadj - ! write(1112+myrank,*) "Thread",myrank,"sum;adjncy", sum(adjncy), adjncy + ! My notes from manual: + ! p: # of processors; + ! n: total # of vertices (local) in graph sense; + ! m: total # of neighboring vertices ("edges"); double counted between neighboring vertice u and v. + ! ncon: # of weights for each vertex; + ! int(in) vtxdist(p+1): Processor j stores vertices vtxdist(j):vtxdist(j+1)-1 + ! int (in) xadj(n+1), adjncy(m): + ! locally, vertex j's neighboring vertices are adjncy(xadj(j):xadj(j+1)-1). adjncy points to global index; + ! int(in) vwgt(ncon*n), adjwgt(m): weights at vertices and "edges". Format of adjwgt follows adjncy; + ! int(in) wgtflag: 0: none (vwgt and adjwgt are NULL); + ! 1: edges (vwgt is NULL); 2: vertices (adjwgt is NULL); 3: both vertices & edges; + ! int(in) numflag: 0: C-style numbering from 0; 1: FORTRAN style from 1; + ! int(in) ndims: 2 or 3 (D); + ! float(in) xyz(ndims*n): coordinate for vertex j is xyz(j*ndims:(j+1)*ndims-1); + ! int(in) nparts: # of desired sub-domains (usually nTasks); + ! float(in) tpwgts(ncon*nparts): =1/nparts if sub-domains are to be of same size for each vertex weight; + ! float(in) ubvec(ncon): imbalance tolerance for each weight; + ! int(in) options: additonal parameters for the routine (see above); + ! int(out) edgecut: # of edges that are cut by the partitioning; + ! int(out) part(): array size = # of local vertices. It stores indices of local vertices. + + ! write(1112+myrank,*) "Thread",myrank,"sum;vtxdist", sum(vtxdist), vtxdist + ! write(1112+myrank,*) "Thread",myrank,"sum;xadj", sum(xadj), xadj + ! write(1112+myrank,*) "Thread",myrank,"sum;adjncy", sum(adjncy), adjncy CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 8") if(debugParmetis) then write(710+myrank,*) vtxdist, xadj, adjncy, & - vwgt, & !vwgt - ignore weights - adjwgt, & ! adjwgt - ignore weights - wgtflag, & - numflag,ndims,ncon,nparts,tpwgts,ubvec,options, & - edgecut,part,comm + vwgt, & !vwgt - ignore weights + adjwgt, & ! adjwgt - ignore weights + wgtflag, & + numflag,ndims,ncon,nparts,tpwgts,ubvec,options, & + edgecut,part,comm call flush(710+myrank) endif !if(debugParmetis) write(710+myrank,*) "Run ParMETIS now..." call ParMETIS_V3_PartGeomKway(vtxdist, xadj, adjncy, & - vwgt, & !vwgt - ignore weights - adjwgt, & ! adjwgt - ignore weights - wgtflag, & - numflag,ndims,xyz,ncon,nparts,tpwgts,ubvec,options, & - edgecut,part, comm) + vwgt, & !vwgt - ignore weights + adjwgt, & ! adjwgt - ignore weights + wgtflag, & + numflag,ndims,xyz,ncon,nparts,tpwgts,ubvec,options, & + edgecut,part, comm) CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 9") if(nTasks == 1) then -! write(*,*) myrank, "minval part", minval(part) + ! write(*,*) myrank, "minval part", minval(part) if(minval(part) == 0) then part(:) = part(:) + 1 endif endif - ! write(*,*) myrank, "edge cuted", edgecut + ! write(*,*) myrank, "edge cuted", edgecut ! Collect the parmetis data from all threads ! and create a global node to domain number mapping allocate(node2domain(np_global),stat=stat) if(stat/=0) call parallel_abort(' node2domain allocation failure') - ! + ! call mpi_allgatherv(part, np, itype, node2domain, np_perProc, np_perProcSum, itype, comm, ierr) if(ierr/=MPI_SUCCESS) call parallel_abort('mpi_allgatherv ',ierr) - ! + ! do i = 1, np_global - node => nodes_global(i) - node%domainID = node2domain(node%id_global) + node => nodes_global(i) + node%domainID = node2domain(node%id_global) end do -! CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 10") + ! CALL REAL_MPI_BARRIER_PDLIB(comm, "runParmetis, step 10") ! write out partition info for katerfempresenter if(debugPartition) write(600,*) node2domain -! Print *, 'runparmetis step 1' + ! Print *, 'runparmetis step 1' if(allocated(xadj)) deallocate(xadj) -! Print *, 'runparmetis step 2' + ! Print *, 'runparmetis step 2' if(allocated(adjncy)) deallocate(adjncy) -! Print *, 'runparmetis step 3' + ! Print *, 'runparmetis step 3' if(allocated(part)) deallocate(part) -! Print *, 'runparmetis step 4' + ! Print *, 'runparmetis step 4' if(allocated(vwgt)) deallocate(vwgt) -! Print *, 'runparmetis step 5' + ! Print *, 'runparmetis step 5' if(allocated(adjwgt)) deallocate(adjwgt) -! Print *, 'runparmetis step 6' + ! Print *, 'runparmetis step 6' if(allocated(xyz)) deallocate(xyz) -! Print *, 'runparmetis step 7' + ! Print *, 'runparmetis step 7' if(allocated(tpwgts)) deallocate(tpwgts) -! Print *, 'runparmetis step 8' + ! Print *, 'runparmetis step 8' if(allocated(ubvec)) deallocate(ubvec) -! Print *, 'runparmetis step 9' + ! Print *, 'runparmetis step 9' if(allocated(vtxdist)) deallocate(vtxdist) -! Print *, 'runparmetis step 10' + ! Print *, 'runparmetis step 10' if(allocated(node2domain)) deallocate(node2domain) -! Print *, 'runparmetis step 11' + ! Print *, 'runparmetis step 11' end subroutine runParmetis !------------------------------------------------------------------------ @@ -745,30 +745,30 @@ end subroutine runParmetis ! rebuild NCONE, CONE, NCONN, CONN ! alter nd, nde !subroutine dummyNodes - ! use yowExchangeModule - ! use yowNodepool, only: npa, nb, nd, PDLIB_NCONN, PDLIB_CONN, boundaryNodes, nodes, x, y, z, outwardNormal, XY, dummy2boundary, BNDprevnext - ! use yowElementpool, only: ne, nde, INE, NCONE, CONE - ! implicit none - ! integer :: i, IP, IPprev, IPnext, newIP, newIE - ! integer, allocatable :: INEnew(:,:) - ! real(rkind) :: vec(2), newPoint(2), newLength - ! real(rkind), allocatable :: xNew(:), yNew(:), zNew(:) - ! - ! nd = nb - ! - ! allocate(dummy2boundary(nd)) - ! - ! nde = 2*nd - ! allocate(INEnew(3,ne+nde)) - ! INEnew(:,1:ne) = INE(:,1:ne) - ! - ! allocate(xNew(npa+nd), yNew(npa+nd), zNew(npa+nd)) - ! xNew(1:npa) = x(1:npa) - ! yNew(1:npa) = y(1:npa) - ! zNew(1:npa) = z(1:npa) - ! - ! nd = 0 - ! nde = 0 + ! use yowExchangeModule + ! use yowNodepool, only: npa, nb, nd, PDLIB_NCONN, PDLIB_CONN, boundaryNodes, nodes, x, y, z, outwardNormal, XY, dummy2boundary, BNDprevnext + ! use yowElementpool, only: ne, nde, INE, NCONE, CONE + ! implicit none + ! integer :: i, IP, IPprev, IPnext, newIP, newIE + ! integer, allocatable :: INEnew(:,:) + ! real(rkind) :: vec(2), newPoint(2), newLength + ! real(rkind), allocatable :: xNew(:), yNew(:), zNew(:) + ! + ! nd = nb + ! + ! allocate(dummy2boundary(nd)) + ! + ! nde = 2*nd + ! allocate(INEnew(3,ne+nde)) + ! INEnew(:,1:ne) = INE(:,1:ne) + ! + ! allocate(xNew(npa+nd), yNew(npa+nd), zNew(npa+nd)) + ! xNew(1:npa) = x(1:npa) + ! yNew(1:npa) = y(1:npa) + ! zNew(1:npa) = z(1:npa) + ! + ! nd = 0 + ! nde = 0 ! do i=1, nb ! nd = nd + 1 ! IP = boundaryNodes(i) @@ -777,14 +777,14 @@ end subroutine runParmetis ! call BNDprevnext(IP, IPprev, IPnext) ! newLength = max(distanceTo(XY(IP), XY(IPprev)), distanceTo(XY(IP), XY(IPnext))) ! newPoint = XY(IP) + outwardNormal(:,i) * newLength - ! newIP = npa+i - ! xNew(newIP) = newPoint(1) - ! yNew(newIP) = newPoint(2) - ! zNew(newIP) = z(IP) - ! NCONN(IP) = NCONN(IP) + 1 - ! CONN(NCONN(IP),IP) = newIP - ! - ! nde = nde +1 + ! newIP = npa+i + ! xNew(newIP) = newPoint(1) + ! yNew(newIP) = newPoint(2) + ! zNew(newIP) = z(IP) + ! NCONN(IP) = NCONN(IP) + 1 + ! CONN(NCONN(IP),IP) = newIP + ! + ! nde = nde +1 ! newIE = ne+nde ! INEnew(1,newIE) = IP ! INEnew(2,newIE) = IPprev @@ -1112,49 +1112,49 @@ subroutine exchangeGhostIds ! send to all domain neighbors how many ghosts nodes we want from him and which ones do i=1, nConnDomains - ! create a uniq tag for this domain - tag = neighborDomains(i)%domainID*10 + 1 - ! send to the neighbor how many ghost nodes we want from him - call MPI_Isend(neighborDomains(i)%numNodesToReceive, & - 1, & - MPI_INT, & - neighborDomains(i)%domainID-1, & - tag, & - comm, & - sendRequest(i), & - ierr); - if(ierr/=MPI_SUCCESS) then - write(*,*) "mpi send failure" - endif + ! create a uniq tag for this domain + tag = neighborDomains(i)%domainID*10 + 1 + ! send to the neighbor how many ghost nodes we want from him + call MPI_Isend(neighborDomains(i)%numNodesToReceive, & + 1, & + MPI_INT, & + neighborDomains(i)%domainID-1, & + tag, & + comm, & + sendRequest(i), & + ierr); + if(ierr/=MPI_SUCCESS) then + write(*,*) "mpi send failure" + endif - tag = neighborDomains(i)%domainID*10 + 2 - ! send to the neighbor which ghost nodes we want from him - call MPI_Isend(neighborDomains(i)%nodesToReceive, & - neighborDomains(i)%numNodesToReceive, & - MPI_INT, & - neighborDomains(i)%domainID-1, & - tag, & - comm, & -!> todo use a second sendRequest array here - sendRequest(i), & - ierr); - if(ierr/=MPI_SUCCESS) then - write(*,*) "mpi send failure" - endif + tag = neighborDomains(i)%domainID*10 + 2 + ! send to the neighbor which ghost nodes we want from him + call MPI_Isend(neighborDomains(i)%nodesToReceive, & + neighborDomains(i)%numNodesToReceive, & + MPI_INT, & + neighborDomains(i)%domainID-1, & + tag, & + comm, & + !> todo use a second sendRequest array here + sendRequest(i), & + ierr); + if(ierr/=MPI_SUCCESS) then + write(*,*) "mpi send failure" + endif - ! receive from neighbor how many ghost nodes we have to send him - tag = (myrank+1)*10 + 1 - call MPI_Irecv(neighborDomains(i)%numNodesToSend, & - 1, & - MPI_INT, & - neighborDomains(i)%domainID-1, & - tag, & - comm, & - recvRequest(i), & - ierr) - if(ierr/=MPI_SUCCESS) then - write(*,*) "mpi recv failure" - endif + ! receive from neighbor how many ghost nodes we have to send him + tag = (myrank+1)*10 + 1 + call MPI_Irecv(neighborDomains(i)%numNodesToSend, & + 1, & + MPI_INT, & + neighborDomains(i)%domainID-1, & + tag, & + comm, & + recvRequest(i), & + ierr) + if(ierr/=MPI_SUCCESS) then + write(*,*) "mpi recv failure" + endif end do ! wait for communication end @@ -1162,39 +1162,39 @@ subroutine exchangeGhostIds ! test for all neighbor domains do i=1, nConnDomains - ! test if the neighbor wants more ghost nodes than we have - if(neighborDomains(i)%numNodesToSend > np) then - write(*,'(i5, a, i5, a, i5,a, i5, a, /)', advance='no') myrank, " ERROR neighbordomain ", neighborDomains(i)%domainID, & - " wants ", neighborDomains(i)%numNodesToSend, & - " nodes, but we have only ", np, " nodes" - CALL ABORT("") - end if + ! test if the neighbor wants more ghost nodes than we have + if(neighborDomains(i)%numNodesToSend > np) then + write(*,'(i5, a, i5, a, i5,a, i5, a, /)', advance='no') myrank, " ERROR neighbordomain ", neighborDomains(i)%domainID, & + " wants ", neighborDomains(i)%numNodesToSend, & + " nodes, but we have only ", np, " nodes" + CALL ABORT("") + end if end do ! receive from all neighbor domains which nodes we must send him do i=1, nConnDomains - allocate(neighborDomains(i)%nodesToSend(neighborDomains(i)%numNodesToSend)) - neighborDomains(i)%nodesToSend = 0 - - ! receive from neighbor which nodes we must send - tag = (myrank+1)*10 + 2 - call MPI_Irecv(neighborDomains(i)%nodesToSend, & - neighborDomains(i)%numNodesToSend, & - MPI_INT, & - neighborDomains(i)%domainID-1, & - tag, & - comm, & - recvRequest(i), & - ierr) - if(ierr/=MPI_SUCCESS) then - CALL PARALLEL_ABORT("mpi recv failure", ierr) - endif + allocate(neighborDomains(i)%nodesToSend(neighborDomains(i)%numNodesToSend)) + neighborDomains(i)%nodesToSend = 0 + + ! receive from neighbor which nodes we must send + tag = (myrank+1)*10 + 2 + call MPI_Irecv(neighborDomains(i)%nodesToSend, & + neighborDomains(i)%numNodesToSend, & + MPI_INT, & + neighborDomains(i)%domainID-1, & + tag, & + comm, & + recvRequest(i), & + ierr) + if(ierr/=MPI_SUCCESS) then + CALL PARALLEL_ABORT("mpi recv failure", ierr) + endif end do ! wait for communication end call MPI_Waitall(nConnDomains, recvRequest, status, ierr) - ! test for all neighbor domains + ! test for all neighbor domains do i=1, nConnDomains ! test if the neighbor wants nodes that we don't own outerloop: do j=1, neighborDomains(i)%numNodesToSend @@ -1206,8 +1206,8 @@ subroutine exchangeGhostIds end if end do write(*,*) myrank, "Neighbordomain", neighborDomains(i)%domainID, & - " want Node", neighborDomains(i)%nodesToSend(j), & - " but we don't own this node" + " want Node", neighborDomains(i)%nodesToSend(j), & + " but we don't own this node" stop end do outerloop end do @@ -1223,7 +1223,7 @@ subroutine postPartition2(INE_global) use yowDatapool, only: myrank use yowNodepool, only: np_global, np, nodes_global, iplg, t_Node, ghostlg, ng, npa use yowNodepool, only: x, y, z - use w3gdatmd, only: xgrd, ygrd, zb + use w3gdatmd, only: xgrd, ygrd, zb implicit none integer, intent(in) :: INE_global(3,ne_global) @@ -1266,12 +1266,12 @@ subroutine postPartition2(INE_global) if(node%id_global == ghostlg(k)) then ! conversion: the ghost nodes are stored behind the local nodes. if(INE(j,ne) /= 0) then - write(*,*) "will write to INE(j, ne) but there is allready a value", j, ne, INE(j, ne) + write(*,*) "will write to INE(j, ne) but there is allready a value", j, ne, INE(j, ne) endif INE(j, ne) = np + k node%id = np+k assigned = .true. -! write(*,*) myrank, "node to ele", node%id_global-1, i-1, np+k + ! write(*,*) myrank, "node to ele", node%id_global-1, i-1, np+k exit endif end do @@ -1335,11 +1335,11 @@ subroutine postPartition2(INE_global) y(np+i) = ygrd(1,IP_glob) z(np+i) = zb(IP_glob) end do - + end subroutine postPartition2 -!********************************************************************** -!* * -!********************************************************************** + !********************************************************************** + !* * + !********************************************************************** subroutine ComputeTRIA_IEN_SI_CCON use yowElementpool, only: ne, ne_global, INE, ielg use yowExchangeModule, only : PDLIB_exchange1Dreal @@ -1386,7 +1386,7 @@ subroutine ComputeTRIA_IEN_SI_CCON PDLIB_TRIA(IE) = DBLTMP IF (PDLIB_TRIA(IE) .lt. TINY(1.)) THEN WRITE(*,*) PDLIB_IEN(:,IE) - WRITE(*,*) + WRITE(*,*) WRITE(*,*) 'AREA SMALLER ZERO IN PDLIB', IE, NE, PDLIB_TRIA(IE) STOP ENDIF @@ -1402,13 +1402,13 @@ subroutine ComputeTRIA_IEN_SI_CCON ENDDO CALL PDLIB_exchange1Dreal(PDLIB_SI) end subroutine ComputeTRIA_IEN_SI_CCON -!********************************************************************** -!* * -!********************************************************************** + !********************************************************************** + !* * + !********************************************************************** subroutine ELEMENT_CROSSES_DATELINE(RX1, RX2, RX3, CROSSES_DATELINE) -! Purpose: understanding if an element crosses the dateline. -! An element crossing the dateline has, e.g. a node with lon < 180 -! and another 2 with lon > -180 + ! Purpose: understanding if an element crosses the dateline. + ! An element crossing the dateline has, e.g. a node with lon < 180 + ! and another 2 with lon > -180 IMPLICIT NONE REAL(rkind), INTENT(IN) :: RX1, RX2, RX3 LOGICAL, INTENT(OUT) :: CROSSES_DATELINE @@ -1416,18 +1416,18 @@ subroutine ELEMENT_CROSSES_DATELINE(RX1, RX2, RX3, CROSSES_DATELINE) R1GT180 = MERGE(1, 0, ABS(RX1).GT.180) R2GT180 = MERGE(1, 0, ABS(RX2).GT.180) R3GT180 = MERGE(1, 0, ABS(RX3).GT.180) -! if R1GT180+R2GT180+R3GT180 .eq. 0 the element does not cross the dateline -! if R1GT180+R2GT180+R3GT180 .eq. 1 the element contains the pole -! if R1GT180+R2GT180+R3GT180 .eq. 2 the element crosses the dateline + ! if R1GT180+R2GT180+R3GT180 .eq. 0 the element does not cross the dateline + ! if R1GT180+R2GT180+R3GT180 .eq. 1 the element contains the pole + ! if R1GT180+R2GT180+R3GT180 .eq. 2 the element crosses the dateline CROSSES_DATELINE = R1GT180+R2GT180+R3GT180 .EQ. 2 end subroutine ELEMENT_CROSSES_DATELINE -!********************************************************************** -!* * -!********************************************************************** + !********************************************************************** + !* * + !********************************************************************** subroutine CORRECT_DX_GT180(DXP) -! Purpose: the absolute zonal distance between 2 points is always <= 180 -! This subroutine corrects the zonal distance to satifsy -! this requirement + ! Purpose: the absolute zonal distance between 2 points is always <= 180 + ! This subroutine corrects the zonal distance to satifsy + ! this requirement IMPLICIT NONE REAL(rkind), INTENT(INOUT) :: DXP IF (DXP .le. -180) THEN @@ -1437,9 +1437,9 @@ subroutine CORRECT_DX_GT180(DXP) DXP=DXP - 360 END IF end subroutine CORRECT_DX_GT180 -!********************************************************************** -!* * -!********************************************************************** + !********************************************************************** + !* * + !********************************************************************** subroutine ComputeIA_JA_POSI_NNZ use yowElementpool, only: ne, ne_global, INE, ielg use yowerr, only: parallel_abort @@ -1460,7 +1460,7 @@ subroutine ComputeIA_JA_POSI_NNZ MAXMNECON = MAXVAL(PDLIB_CCON) ALLOCATE(CELLVERTEX(npa,MAXMNECON,2), stat=istat) IF (istat/=0) CALL PARALLEL_ABORT('ComputeIA_JA_POSI_NNZ, allocate error 4') -! + ! CELLVERTEX(:,:,:) = 0 CHILF = 0 DO IE = 1, ne @@ -1471,9 +1471,9 @@ subroutine ComputeIA_JA_POSI_NNZ CELLVERTEX(I,CHILF(I),2) = J END DO ENDDO -! -! Emulates loop structure and counts max. entries in the different pointers that have to be designed -! + ! + ! Emulates loop structure and counts max. entries in the different pointers that have to be designed + ! J = 0 DO IP = 1, npa DO I = 1, PDLIB_CCON(IP) @@ -1485,11 +1485,11 @@ subroutine ComputeIA_JA_POSI_NNZ IF (istat/=0) CALL PARALLEL_ABORT('wwm_fluctsplit, allocate error 5a') ALLOCATE (PDLIB_IE_CELL2(MAXMNECON,NPA), PDLIB_POS_CELL2(MAXMNECON, NPA), stat=istat) IF (istat/=0) CALL PARALLEL_ABORT('wwm_fluctsplit, allocate error 5b') -! Just a remapping from CELLVERTEX ... Element number in the -! order of the occurence in the loop during runtime + ! Just a remapping from CELLVERTEX ... Element number in the + ! order of the occurence in the loop during runtime PDLIB_IE_CELL = 0 -! Just a remapping from CELLVERTEX ... Position of the node -! in the Element index -"- + ! Just a remapping from CELLVERTEX ... Position of the node + ! in the Element index -"- PDLIB_POS_CELL = 0 J = 0 DO IP = 1, npa @@ -1540,11 +1540,11 @@ subroutine ComputeIA_JA_POSI_NNZ PTABLE(J,7) = IE ! Element numbers same as PDLIB_IE_CELL END DO END DO -! -! Count number of nonzero entries in the matrix ... -! Basically, each connected element may have two off-diagonal -! contribution and one diagonal related to the connected vertex itself ... -! + ! + ! Count number of nonzero entries in the matrix ... + ! Basically, each connected element may have two off-diagonal + ! contribution and one diagonal related to the connected vertex itself ... + ! J = 0 PDLIB_NNZ = 0 ITMP = 0 @@ -1560,11 +1560,11 @@ subroutine ComputeIA_JA_POSI_NNZ END DO PDLIB_NNZ = PDLIB_NNZ + SUM(ITMP) END DO -! -! Allocate sparse matrix pointers using the Compressed Sparse Row Format CSR ... this is now done only of npa nodes -! The next step is to do it for the whole Matrix npa * MSC * MDC -! see ...:x -! + ! + ! Allocate sparse matrix pointers using the Compressed Sparse Row Format CSR ... this is now done only of npa nodes + ! The next step is to do it for the whole Matrix npa * MSC * MDC + ! see ...:x + ! ALLOCATE (PDLIB_JA(PDLIB_NNZ), PDLIB_IA(npa+1), PDLIB_JA_P(PDLIB_NNZ), stat=istat) IF (istat/=0) CALL PARALLEL_ABORT('wwm_fluctsplit, allocate error 6a') ALLOCATE (PDLIB_IA_P(npa+1), PDLIB_POSI(3,COUNT_MAX), PDLIB_I_DIAG(npa), stat=istat) @@ -1574,8 +1574,8 @@ subroutine ComputeIA_JA_POSI_NNZ PDLIB_JA_P = 0 PDLIB_IA_P = 0 PDLIB_POSI = 0 -! Points to the position of the matrix entry in the mass matrix -! according to the CSR matrix format see p. 124 + ! Points to the position of the matrix entry in the mass matrix + ! according to the CSR matrix format see p. 124 J = 0 K = 0 PDLIB_IA (1) = 1 @@ -1629,11 +1629,11 @@ subroutine ComputeIA_JA_POSI_NNZ PDLIB_JA_IE(POS,3,IE) = I3 END DO END DO - deallocate(PTABLE) + deallocate(PTABLE) end subroutine ComputeIA_JA_POSI_NNZ -!********************************************************************** -!* * -!********************************************************************** + !********************************************************************** + !* * + !********************************************************************** subroutine finalizePD() use yowExchangeModule, only: finalizeExchangeModule use yowNodepool, only: finalizeNodepool diff --git a/model/src/PDLIB/yowrankModule.F90 b/model/src/PDLIB/yowrankModule.F90 index 98377ebac..62c2341f5 100644 --- a/model/src/PDLIB/yowrankModule.F90 +++ b/model/src/PDLIB/yowrankModule.F90 @@ -69,7 +69,7 @@ module yowRankModule integer, public, allocatable :: IPGL_TO_PROC(:), ipgl_tot(:) integer, public, allocatable :: ipgl_npa(:) - contains +contains !> allocate and exchange subroutine initRankModule() @@ -107,7 +107,7 @@ subroutine exchangeIPLG() do i=1, nTasks if(i /= myrank+1) then call MPI_IRecv(rank(i)%np, 1, itype, i-1, & - 42, comm, recvRqst(i), ierr) + 42, comm, recvRqst(i), ierr) if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_IRecv", ierr) endif @@ -120,7 +120,7 @@ subroutine exchangeIPLG() do i=1, nTasks if(i /= myrank+1) then call MPI_ISend(np, 1, itype, i-1, & - 42, comm, sendRqst(i), ierr) + 42, comm, sendRqst(i), ierr) if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_ISend", ierr) endif @@ -155,7 +155,7 @@ subroutine exchangeIPLG() do i=1, nTasks if(i /= myrank+1) then call MPI_ISend(npa, 1, itype, i-1, & - 42, comm, sendRqst(i), ierr) + 42, comm, sendRqst(i), ierr) if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_ISend", ierr) endif @@ -185,7 +185,7 @@ subroutine exchangeIPLG() do i=1, nTasks if(i /= myrank+1) then call MPI_IRecv(rank(i)%iplg, rank(i)%npa, itype, i-1, & - 42, comm, recvRqst(i), ierr) + 42, comm, recvRqst(i), ierr) if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_IRecv", ierr) endif @@ -198,7 +198,7 @@ subroutine exchangeIPLG() do i=1, nTasks if(i /= myrank+1) then call MPI_ISend(iplg, npa, itype, i-1, & - 42, comm, sendRqst(i), ierr) + 42, comm, sendRqst(i), ierr) if(ierr/=MPI_SUCCESS) then CALL PARALLEL_ABORT("MPI_ISend", ierr) endif @@ -248,7 +248,7 @@ end subroutine calcISTART subroutine finalizeRankModule() implicit none integer :: i - + if(allocated(rank)) then do i=1, size(rank) if(allocated(rank(i)%iplg)) deallocate(rank(i)%iplg) diff --git a/model/src/SCRIP/SCRIP.mk b/model/src/SCRIP/SCRIP.mk index 61e3841b1..9932807d1 100644 --- a/model/src/SCRIP/SCRIP.mk +++ b/model/src/SCRIP/SCRIP.mk @@ -26,7 +26,7 @@ $(aPo)/scrip_remap_vars.o: SCRIP/scrip_remap_vars.f \ $(aPo)/scrip_constants.o \ $(aPo)/scrip_grids.o \ $(aPo)/scrip_errormod.o \ - $(aPo)/scrip_iounitsmod.o + $(aPo)/scrip_iounitsmod.o @$(aPb)/ad3 scrip_remap_vars $(aPo)/scrip_remap_conservative.o: SCRIP/scrip_remap_conservative.f \ @@ -36,7 +36,7 @@ $(aPo)/scrip_remap_conservative.o: SCRIP/scrip_remap_conservative.f \ $(aPo)/scrip_remap_vars.o \ $(aPo)/scrip_grids.o \ $(aPo)/scrip_errormod.o \ - $(aPo)/scrip_iounitsmod.o + $(aPo)/scrip_iounitsmod.o @$(aPb)/ad3 scrip_remap_conservative $(aPo)/scrip_timers.o: SCRIP/scrip_timers.f \ @@ -51,6 +51,5 @@ $(aPo)/scrip_interface.o: SCRIP/scrip_interface.F90 \ $(aPo)/scrip_grids.o \ $(aPo)/scrip_remap_conservative.o \ $(aPo)/scrip_iounitsmod.o \ - $(aPo)/scrip_errormod.o + $(aPo)/scrip_errormod.o @$(aPb)/ad3 scrip_interface - diff --git a/model/src/SCRIP/SCRIP_NC.mk b/model/src/SCRIP/SCRIP_NC.mk index 33fb6faf7..700dafe36 100644 --- a/model/src/SCRIP/SCRIP_NC.mk +++ b/model/src/SCRIP/SCRIP_NC.mk @@ -33,7 +33,7 @@ $(aPo)/scrip_remap_vars.o: SCRIP/scrip_remap_vars.f \ $(aPo)/scrip_grids.o \ $(aPo)/scrip_errormod.o \ $(aPo)/scrip_netcdfmod.o \ - $(aPo)/scrip_iounitsmod.o + $(aPo)/scrip_iounitsmod.o @$(aPb)/ad3 scrip_remap_vars $(aPo)/scrip_remap_conservative.o: SCRIP/scrip_remap_conservative.f \ @@ -44,7 +44,7 @@ $(aPo)/scrip_remap_conservative.o: SCRIP/scrip_remap_conservative.f \ $(aPo)/scrip_grids.o \ $(aPo)/scrip_errormod.o \ $(aPo)/scrip_netcdfmod.o \ - $(aPo)/scrip_iounitsmod.o + $(aPo)/scrip_iounitsmod.o @$(aPb)/ad3 scrip_remap_conservative $(aPo)/scrip_timers.o: SCRIP/scrip_timers.f \ @@ -82,6 +82,5 @@ $(aPo)/scrip_interface.o: SCRIP/scrip_interface.F90 \ $(aPo)/scrip_remap_write.o \ $(aPo)/scrip_remap_read.o \ $(aPo)/scrip_iounitsmod.o \ - $(aPo)/scrip_errormod.o + $(aPo)/scrip_errormod.o @$(aPb)/ad3 scrip_interface - diff --git a/model/src/SCRIP/scrip_constants.f b/model/src/SCRIP/scrip_constants.f index afe004ef2..7ddf34fee 100644 --- a/model/src/SCRIP/scrip_constants.f +++ b/model/src/SCRIP/scrip_constants.f @@ -6,12 +6,12 @@ ! ! CVS:$Id: constants.f,v 1.2 2000/04/19 21:56:25 pwjones Exp $ ! -! Copyright (c) 1997, 1998 the Regents of the University of +! Copyright (c) 1997, 1998 the Regents of the University of ! California. ! -! This software and ancillary information (herein called software) -! called SCRIP is made available under the terms described here. -! The software has been approved for release with associated +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated ! LA-CC Number 98-45. ! ! Unless otherwise indicated, this software has been authored @@ -26,44 +26,44 @@ ! any liability or responsibility for the use of this software. ! ! If software is modified to produce derivative works, such modified -! software should be clearly marked, so as not to confuse it with +! software should be clearly marked, so as not to confuse it with ! the version available from Los Alamos National Laboratory. ! -! This code has been modified from the version available from +! This code has been modified from the version available from ! Los Alamos National Laboratory, for the purpose of running it ! within WW3. ! !*********************************************************************** - module SCRIP_constants + module SCRIP_constants !----------------------------------------------------------------------- - use SCRIP_KindsMod ! defines common data types + use SCRIP_KindsMod ! defines common data types - implicit none + implicit none - save + save !----------------------------------------------------------------------- - real (kind = SCRIP_r8), parameter :: - & zero = 0.0_SCRIP_r8, - & one = 1.0_SCRIP_r8, - & two = 2.0_SCRIP_r8, - & three = 3.0_SCRIP_r8, - & four = 4.0_SCRIP_r8, - & five = 5.0_SCRIP_r8, - & half = 0.5_SCRIP_r8, - & quart = 0.25_SCRIP_r8, - & bignum = 1.e+20_SCRIP_r8, - & tiny = 1.e-14_SCRIP_r8, - & pi = 3.14159265359_SCRIP_r8, - & pi2 = two*pi, - & pih = half*pi + real (kind = SCRIP_r8), parameter :: + & zero = 0.0_SCRIP_r8, + & one = 1.0_SCRIP_r8, + & two = 2.0_SCRIP_r8, + & three = 3.0_SCRIP_r8, + & four = 4.0_SCRIP_r8, + & five = 5.0_SCRIP_r8, + & half = 0.5_SCRIP_r8, + & quart = 0.25_SCRIP_r8, + & bignum = 1.e+20_SCRIP_r8, + & tiny = 1.e-14_SCRIP_r8, + & pi = 3.14159265359_SCRIP_r8, + & pi2 = two*pi, + & pih = half*pi !----------------------------------------------------------------------- - end module SCRIP_constants + end module SCRIP_constants !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/model/src/SCRIP/scrip_errormod.f90 b/model/src/SCRIP/scrip_errormod.f90 index 4e84550a4..d4035a7c6 100644 --- a/model/src/SCRIP/scrip_errormod.f90 +++ b/model/src/SCRIP/scrip_errormod.f90 @@ -1,298 +1,298 @@ -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| - - module SCRIP_ErrorMod - -!BOP -! !MODULE: SCRIP_ErrorMod -! !DESCRIPTION: -! This module contains SCRIP error flags and facilities for logging and -! printing error messages. Note that error flags are local to a -! process and there is no synchronization of error flags across -! processes. As routines trap error flags, they may add a message -! to the error log to aid in tracking the call sequence. -! -! Users should not need to change any values in this module. -! -! All routines in SCRIP which encounter an error should return to -! the calling routine with the SCRIP\_Fail error code set and a message -! added to the error log using the SCRIP\_ErrorCheck or -! SCRIP\_ErrorSet function. Routines in SCRIP should also check -! error codes returned by called routines and add a message to the -! error log to help users track the calling sequence that generated -! the error. This process enables the error code to be propagated -! to the highest level or calling routine to enable a graceful -! exit. At that level, the SCRIP_ErrorPrint call can be used to -! print the entire error trace or error log. -! -! !REVISION HISTORY: -! SVN:$Id: SCRIP_ErrorMod.F90 14 2006-08-17 17:07:05Z $ -! -! !USES: - - use SCRIP_KindsMod - !use SCRIP_CommMod - use SCRIP_IOUnitsMod - - implicit none - private - save - -! !DEFINED PARAMETERS: - - integer (SCRIP_i4), parameter, public :: & - SCRIP_Success = 0, & ! standard SCRIP error flags - SCRIP_Fail = -1 - -! !PUBLIC MEMBER FUNCTIONS: - - public :: SCRIP_ErrorSet, & - SCRIP_ErrorCheck, & - SCRIP_ErrorPrint - -!EOP -!BOC -!----------------------------------------------------------------------- -! -! module variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), parameter :: & - SCRIP_errorLogDepth = 20 ! Max depth of call tree to properly - ! size the error log array - - integer (SCRIP_i4) :: & - SCRIP_errorMsgCount = 0 ! tracks current number of log messages - - character (SCRIP_CharLength), dimension(SCRIP_ErrorLogDepth) :: & - SCRIP_errorLog ! list of error messages to be output - -!EOC -!*********************************************************************** - - contains - -!*********************************************************************** -!BOP -! !IROUTINE: SCRIP_ErrorSet -- sets error code and logs error message -! !INTERFACE: - - subroutine SCRIP_ErrorSet(errorCode, rtnName, errorMsg) - -! !DESCRIPTION: -! This routine sets an error code to SCRIP\_Fail and adds a message to -! the error log for later printing. -! -! !REVISION HISTORY: -! same as module - -! !OUTPUT PARAMETERS: - - integer (SCRIP_i4), intent(out) :: & - errorCode ! Error code to set to fail - -! !INPUT PARAMETERS: - - character (*), intent(in) :: & - rtnName, &! name of calling routine - errorMsg ! message to add to error log for printing - -!EOP -!BOC -!----------------------------------------------------------------------- -! -! Local variables -! -!----------------------------------------------------------------------- - - character(SCRIP_charLength) :: & - logErrorMsg ! constructed error message with routine name - -!----------------------------------------------------------------------- -! -! Set error code to fail -! -!----------------------------------------------------------------------- - - errorCode = SCRIP_Fail - -!----------------------------------------------------------------------- -! -! Add error message to error log -! -!----------------------------------------------------------------------- +!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + +module SCRIP_ErrorMod + + !BOP + ! !MODULE: SCRIP_ErrorMod + ! !DESCRIPTION: + ! This module contains SCRIP error flags and facilities for logging and + ! printing error messages. Note that error flags are local to a + ! process and there is no synchronization of error flags across + ! processes. As routines trap error flags, they may add a message + ! to the error log to aid in tracking the call sequence. + ! + ! Users should not need to change any values in this module. + ! + ! All routines in SCRIP which encounter an error should return to + ! the calling routine with the SCRIP\_Fail error code set and a message + ! added to the error log using the SCRIP\_ErrorCheck or + ! SCRIP\_ErrorSet function. Routines in SCRIP should also check + ! error codes returned by called routines and add a message to the + ! error log to help users track the calling sequence that generated + ! the error. This process enables the error code to be propagated + ! to the highest level or calling routine to enable a graceful + ! exit. At that level, the SCRIP_ErrorPrint call can be used to + ! print the entire error trace or error log. + ! + ! !REVISION HISTORY: + ! SVN:$Id: SCRIP_ErrorMod.F90 14 2006-08-17 17:07:05Z $ + ! + ! !USES: + + use SCRIP_KindsMod + !use SCRIP_CommMod + use SCRIP_IOUnitsMod + + implicit none + private + save + + ! !DEFINED PARAMETERS: + + integer (SCRIP_i4), parameter, public :: & + SCRIP_Success = 0, & ! standard SCRIP error flags + SCRIP_Fail = -1 + + ! !PUBLIC MEMBER FUNCTIONS: + + public :: SCRIP_ErrorSet, & + SCRIP_ErrorCheck, & + SCRIP_ErrorPrint + + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! module variables + ! + !----------------------------------------------------------------------- + + integer (SCRIP_i4), parameter :: & + SCRIP_errorLogDepth = 20 ! Max depth of call tree to properly + ! size the error log array + + integer (SCRIP_i4) :: & + SCRIP_errorMsgCount = 0 ! tracks current number of log messages + + character (SCRIP_CharLength), dimension(SCRIP_ErrorLogDepth) :: & + SCRIP_errorLog ! list of error messages to be output + + !EOC + !*********************************************************************** + +contains + + !*********************************************************************** + !BOP + ! !IROUTINE: SCRIP_ErrorSet -- sets error code and logs error message + ! !INTERFACE: + + subroutine SCRIP_ErrorSet(errorCode, rtnName, errorMsg) + + ! !DESCRIPTION: + ! This routine sets an error code to SCRIP\_Fail and adds a message to + ! the error log for later printing. + ! + ! !REVISION HISTORY: + ! same as module + + ! !OUTPUT PARAMETERS: + + integer (SCRIP_i4), intent(out) :: & + errorCode ! Error code to set to fail + + ! !INPUT PARAMETERS: + + character (*), intent(in) :: & + rtnName, &! name of calling routine + errorMsg ! message to add to error log for printing + + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! Local variables + ! + !----------------------------------------------------------------------- + + character(SCRIP_charLength) :: & + logErrorMsg ! constructed error message with routine name + + !----------------------------------------------------------------------- + ! + ! Set error code to fail + ! + !----------------------------------------------------------------------- + + errorCode = SCRIP_Fail + + !----------------------------------------------------------------------- + ! + ! Add error message to error log + ! + !----------------------------------------------------------------------- - SCRIP_errorMsgCount = SCRIP_errorMsgCount + 1 + SCRIP_errorMsgCount = SCRIP_errorMsgCount + 1 - if (SCRIP_errorMsgCount <= SCRIP_errorLogDepth) then + if (SCRIP_errorMsgCount <= SCRIP_errorLogDepth) then write(logErrorMsg,'(a,a2,a)') rtnName,': ',errorMsg SCRIP_errorLog(SCRIP_errorMsgCount) = logErrorMsg - endif - -!----------------------------------------------------------------------- -!EOC - - end subroutine SCRIP_ErrorSet - -!*********************************************************************** -!BOP -! !IROUTINE: SCRIP_ErrorCheck -- checks error code and logs error message -! !INTERFACE: - - function SCRIP_ErrorCheck(errorCode, rtnName, errorMsg) - -! !DESCRIPTION: -! This function checks an error code and adds a message to the error -! log for later printing. It is a more compact form of the ErrorSet -! routine that is especially useful for checking an error code after -! returning from a routine or function. If the errorCode is the -! failure code SCRIP\_Fail, it returns a logical true value so that -! it can be used in a typical call like: -! \begin{verbatim} -! if (SCRIP_ErrorCheck(errorCode, rtnName, errorMsg)) return -! \end{verbatim} -! -! !REVISION HISTORY: -! same as module - -! !OUTPUT PARAMETERS: - - logical (SCRIP_logical) :: & - SCRIP_ErrorCheck - -! !INPUT PARAMETERS: - - integer (SCRIP_i4), intent(in) :: & - errorCode ! Error code to check - - character (*), intent(in) :: & - rtnName, &! name of calling routine - errorMsg ! message to add to error log for printing - -!EOP -!BOC -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - character (SCRIP_charLength) :: & - logErrorMsg ! constructed error message with routine name - -!----------------------------------------------------------------------- -! -! If the error code is success, set the return value to false. -! -!----------------------------------------------------------------------- - - if (errorCode == SCRIP_Success) then + endif + + !----------------------------------------------------------------------- + !EOC + + end subroutine SCRIP_ErrorSet + + !*********************************************************************** + !BOP + ! !IROUTINE: SCRIP_ErrorCheck -- checks error code and logs error message + ! !INTERFACE: + + function SCRIP_ErrorCheck(errorCode, rtnName, errorMsg) + + ! !DESCRIPTION: + ! This function checks an error code and adds a message to the error + ! log for later printing. It is a more compact form of the ErrorSet + ! routine that is especially useful for checking an error code after + ! returning from a routine or function. If the errorCode is the + ! failure code SCRIP\_Fail, it returns a logical true value so that + ! it can be used in a typical call like: + ! \begin{verbatim} + ! if (SCRIP_ErrorCheck(errorCode, rtnName, errorMsg)) return + ! \end{verbatim} + ! + ! !REVISION HISTORY: + ! same as module + + ! !OUTPUT PARAMETERS: + + logical (SCRIP_logical) :: & + SCRIP_ErrorCheck + + ! !INPUT PARAMETERS: + + integer (SCRIP_i4), intent(in) :: & + errorCode ! Error code to check + + character (*), intent(in) :: & + rtnName, &! name of calling routine + errorMsg ! message to add to error log for printing + + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------------- + + character (SCRIP_charLength) :: & + logErrorMsg ! constructed error message with routine name + + !----------------------------------------------------------------------- + ! + ! If the error code is success, set the return value to false. + ! + !----------------------------------------------------------------------- + + if (errorCode == SCRIP_Success) then SCRIP_ErrorCheck = .false. -!----------------------------------------------------------------------- -! -! If the error code is a fail, set the return value to true and -! add the error message to the log. -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! If the error code is a fail, set the return value to true and + ! add the error message to the log. + ! + !----------------------------------------------------------------------- - else + else SCRIP_ErrorCheck = .true. SCRIP_errorMsgCount = SCRIP_errorMsgCount + 1 if (SCRIP_errorMsgCount <= SCRIP_errorLogDepth) then - write(logErrorMsg,'(a,a2,a)') rtnName,': ',errorMsg - SCRIP_errorLog(SCRIP_errorMsgCount) = logErrorMsg + write(logErrorMsg,'(a,a2,a)') rtnName,': ',errorMsg + SCRIP_errorLog(SCRIP_errorMsgCount) = logErrorMsg endif - endif + endif -!----------------------------------------------------------------------- -!EOC + !----------------------------------------------------------------------- + !EOC - end function SCRIP_ErrorCheck + end function SCRIP_ErrorCheck -!*********************************************************************** -!BOP -! !IROUTINE: SCRIP_ErrorPrint -- prints the error log -! !INTERFACE: + !*********************************************************************** + !BOP + ! !IROUTINE: SCRIP_ErrorPrint -- prints the error log + ! !INTERFACE: - subroutine SCRIP_ErrorPrint(printTask) + subroutine SCRIP_ErrorPrint(printTask) -! !DESCRIPTION: -! This routine prints all messages in the error log. If a printTask -! is specified, only the message log on that task will be printed. -! -! !REVISION HISTORY: -! same as module + ! !DESCRIPTION: + ! This routine prints all messages in the error log. If a printTask + ! is specified, only the message log on that task will be printed. + ! + ! !REVISION HISTORY: + ! same as module -! !INPUT PARAMETERS: + ! !INPUT PARAMETERS: -! integer (SCRIP_i4), intent(in) :: & -! errorCode ! input error code to check success/fail + ! integer (SCRIP_i4), intent(in) :: & + ! errorCode ! input error code to check success/fail - !*** currently this has no meaning, but will be used in parallel - !*** SCRIP version - integer (SCRIP_i4), intent(in), optional :: & - printTask ! Task from which to print error log + !*** currently this has no meaning, but will be used in parallel + !*** SCRIP version + integer (SCRIP_i4), intent(in), optional :: & + printTask ! Task from which to print error log -!EOP -!BOC -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------------- - integer (SCRIP_i4) :: n + integer (SCRIP_i4) :: n -!----------------------------------------------------------------------- -! -! Print all error messages to stdout -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! Print all error messages to stdout + ! + !----------------------------------------------------------------------- - if (present(printTask)) then + if (present(printTask)) then !*** parallel SCRIP not yet supported !if (SCRIP_myTask == printTask) then - write(SCRIP_stdout,SCRIP_blankFormat) - write(SCRIP_stdout,SCRIP_delimFormat) - write(SCRIP_stdout,SCRIP_blankFormat) + write(SCRIP_stdout,SCRIP_blankFormat) + write(SCRIP_stdout,SCRIP_delimFormat) + write(SCRIP_stdout,SCRIP_blankFormat) - if (SCRIP_errorMsgCount == 0) then ! no errors + if (SCRIP_errorMsgCount == 0) then ! no errors - write(SCRIP_stdout,'(a34)') & - 'Successful completion of SCRIP model' + write(SCRIP_stdout,'(a34)') & + 'Successful completion of SCRIP model' - else + else - write(SCRIP_stdout,'(a14)') 'SCRIP Exiting...' + write(SCRIP_stdout,'(a14)') 'SCRIP Exiting...' - do n=1,min(SCRIP_errorMsgCount,SCRIP_errorLogDepth) - write(SCRIP_stderr,'(a)') trim(SCRIP_errorLog(n)) - if (SCRIP_stdout /= SCRIP_stderr) then - write(SCRIP_stdout,'(a)') trim(SCRIP_errorLog(n)) - endif - end do + do n=1,min(SCRIP_errorMsgCount,SCRIP_errorLogDepth) + write(SCRIP_stderr,'(a)') trim(SCRIP_errorLog(n)) + if (SCRIP_stdout /= SCRIP_stderr) then + write(SCRIP_stdout,'(a)') trim(SCRIP_errorLog(n)) + endif + end do - if (SCRIP_errorMsgCount > SCRIP_errorLogDepth) then - write(SCRIP_stderr,'(a23)') 'Too many error messages' - if (SCRIP_stdout /= SCRIP_stderr) then - write(SCRIP_stdout,'(a23)') 'Too many error messages' - endif - endif + if (SCRIP_errorMsgCount > SCRIP_errorLogDepth) then + write(SCRIP_stderr,'(a23)') 'Too many error messages' + if (SCRIP_stdout /= SCRIP_stderr) then + write(SCRIP_stdout,'(a23)') 'Too many error messages' + endif + endif - endif + endif - write(SCRIP_stdout,SCRIP_blankFormat) - write(SCRIP_stdout,SCRIP_delimFormat) - write(SCRIP_stdout,SCRIP_blankFormat) + write(SCRIP_stdout,SCRIP_blankFormat) + write(SCRIP_stdout,SCRIP_delimFormat) + write(SCRIP_stdout,SCRIP_blankFormat) !endif - else + else write(SCRIP_stdout,SCRIP_blankFormat) write(SCRIP_stdout,SCRIP_delimFormat) @@ -300,25 +300,25 @@ subroutine SCRIP_ErrorPrint(printTask) if (SCRIP_errorMsgCount == 0) then ! no errors - write(SCRIP_stdout,'(a34)') 'Successful completion of SCRIP' + write(SCRIP_stdout,'(a34)') 'Successful completion of SCRIP' else - write(SCRIP_stdout,'(a14)') 'SCRIP Exiting...' + write(SCRIP_stdout,'(a14)') 'SCRIP Exiting...' - do n=1,min(SCRIP_errorMsgCount,SCRIP_errorLogDepth) - write(SCRIP_stderr,'(a)') trim(SCRIP_errorLog(n)) - if (SCRIP_stdout /= SCRIP_stderr) then - write(SCRIP_stdout,'(a)') trim(SCRIP_errorLog(n)) - endif - end do + do n=1,min(SCRIP_errorMsgCount,SCRIP_errorLogDepth) + write(SCRIP_stderr,'(a)') trim(SCRIP_errorLog(n)) + if (SCRIP_stdout /= SCRIP_stderr) then + write(SCRIP_stdout,'(a)') trim(SCRIP_errorLog(n)) + endif + end do - if (SCRIP_errorMsgCount > SCRIP_errorLogDepth) then - write(SCRIP_stderr,'(a23)') 'Too many error messages' - if (SCRIP_stdout /= SCRIP_stderr) then - write(SCRIP_stdout,'(a23)') 'Too many error messages' - endif - endif + if (SCRIP_errorMsgCount > SCRIP_errorLogDepth) then + write(SCRIP_stderr,'(a23)') 'Too many error messages' + if (SCRIP_stdout /= SCRIP_stderr) then + write(SCRIP_stdout,'(a23)') 'Too many error messages' + endif + endif endif @@ -326,15 +326,15 @@ subroutine SCRIP_ErrorPrint(printTask) write(SCRIP_stdout,SCRIP_delimFormat) write(SCRIP_stdout,SCRIP_blankFormat) - endif + endif -!----------------------------------------------------------------------- -!EOC + !----------------------------------------------------------------------- + !EOC - end subroutine SCRIP_ErrorPrint + end subroutine SCRIP_ErrorPrint -!*********************************************************************** + !*********************************************************************** - end module SCRIP_ErrorMod +end module SCRIP_ErrorMod !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/model/src/SCRIP/scrip_grids.f b/model/src/SCRIP/scrip_grids.f index 193d00cb7..bf5d28490 100644 --- a/model/src/SCRIP/scrip_grids.f +++ b/model/src/SCRIP/scrip_grids.f @@ -9,12 +9,12 @@ ! ! CVS:$Id: grids.f,v 1.6 2001/08/21 21:06:41 pwjones Exp $ ! -! Copyright (c) 1997, 1998 the Regents of the University of +! Copyright (c) 1997, 1998 the Regents of the University of ! California. ! -! This software and ancillary information (herein called software) -! called SCRIP is made available under the terms described here. -! The software has been approved for release with associated +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated ! LA-CC Number 98-45. ! ! Unless otherwise indicated, this software has been authored @@ -29,10 +29,10 @@ ! any liability or responsibility for the use of this software. ! ! If software is modified to produce derivative works, such modified -! software should be clearly marked, so as not to confuse it with +! software should be clearly marked, so as not to confuse it with ! the version available from Los Alamos National Laboratory. ! -! this grids.f has been modified from the version available from +! this grids.f has been modified from the version available from ! Los Alamos National Laboratory. ! modifications are marked with "NRL" ! list of modifications: @@ -40,8 +40,8 @@ ! (major change) ! - print statements added ! - allocations removed (moved to scrip_wrapper subroutine) -! - imask removed (this was an intermediate step from ncdf to -! the logicals grid1_mask grid2_mask; creation of these +! - imask removed (this was an intermediate step from ncdf to +! the logicals grid1_mask grid2_mask; creation of these ! logicals is now handled by scrip_wrapper) ! !*********************************************************************** @@ -74,10 +74,10 @@ module scrip_grids integer (SCRIP_i4), dimension(:), allocatable, save :: & grid1_dims, grid2_dims ! size of each grid dimension - character(SCRIP_charLength), save :: + character(SCRIP_charLength), save :: & grid1_name, grid2_name ! name for each grid - character (SCRIP_charLength), save :: + character (SCRIP_charLength), save :: & grid1_units, ! units for grid coords (degs/radians) & grid2_units ! units for grid coords @@ -103,7 +103,7 @@ module scrip_grids real (SCRIP_r8), dimension(:), allocatable, target, save :: & grid1_center_lat, ! lat/lon coordinates for & grid1_center_lon, ! each grid center in radians - & grid2_center_lat, + & grid2_center_lat, & grid2_center_lon, & grid1_area, ! tot area of each grid1 cell & grid2_area, ! tot area of each grid2 cell @@ -120,7 +120,7 @@ module scrip_grids real (SCRIP_r8), dimension(:,:), allocatable, target, save :: & grid1_corner_lat, ! lat/lon coordinates for & grid1_corner_lon, ! each grid corner in radians - & grid2_corner_lat, + & grid2_corner_lat, & grid2_corner_lon logical (SCRIP_logical), save :: @@ -132,13 +132,13 @@ module scrip_grids & grid1_bound_box, ! lat/lon bounding box for use & grid2_bound_box ! in restricting grid searches - integer (SCRIP_i4), save :: ! Cells overlapping the poles + integer (SCRIP_i4), save :: ! Cells overlapping the poles ! (may be 0) - & grid1_npole_cell, - & grid1_spole_cell, + & grid1_npole_cell, + & grid1_spole_cell, & grid2_npole_cell, & grid2_spole_cell - + !----------------------------------------------------------------------- ! @@ -166,7 +166,7 @@ module scrip_grids ! !----------------------------------------------------------------------- - real (SCRIP_r8), save :: + real (SCRIP_r8), save :: & north_thresh, ! threshold for coord transf. & south_thresh ! threshold for coord transf. @@ -176,7 +176,7 @@ module scrip_grids !*** degeneracies in intersection integer (SCRIP_i4), save :: - & npseg + & npseg !*********************************************************************** @@ -219,7 +219,7 @@ subroutine grid_init(errorCode,l_master,l_test) ! !----------------------------------------------------------------------- - integer (SCRIP_i4) :: + integer (SCRIP_i4) :: & n, ! loop counter & nele, ! element loop counter & i,j, @@ -231,17 +231,17 @@ subroutine grid_init(errorCode,l_master,l_test) & zero_crossing, pi_crossing, & grid1_add, grid2_add, & corner, next_corn - + real (SCRIP_r8) :: & beglon, beglat, endlon, endlat logical (SCRIP_logical) :: & found -!NRL integer (SCRIP_i4), dimension(:), allocatable :: +!NRL integer (SCRIP_i4), dimension(:), allocatable :: !NRL & imask ! integer mask read from file - real (SCRIP_r8) :: + real (SCRIP_r8) :: & dlat,dlon ! lat/lon intervals for search bins real (SCRIP_r8), dimension(4) :: @@ -262,14 +262,14 @@ subroutine grid_init(errorCode,l_master,l_test) ! !----------------------------------------------------------------------- - allocate( + allocate( !NRL & grid1_mask (grid1_size), !NRL & grid2_mask (grid2_size), & special_polar_cell1(grid1_size), & special_polar_cell2(grid2_size), -!NRL & grid1_center_lat(grid1_size), +!NRL & grid1_center_lat(grid1_size), !NRL & grid1_center_lon(grid1_size), -!NRL & grid2_center_lat(grid2_size), +!NRL & grid2_center_lat(grid2_size), !NRL & grid2_center_lon(grid2_size), & grid1_area (grid1_size), & grid1_area_in (grid1_size), @@ -433,7 +433,7 @@ subroutine grid_init(errorCode,l_master,l_test) !----------------------------------------------------------------------- ! ! make sure input latitude range is within the machine values -! for +/- pi/2 +! for +/- pi/2 ! !----------------------------------------------------------------------- @@ -457,7 +457,7 @@ subroutine grid_init(errorCode,l_master,l_test) ! problems ! !----------------------------------------------------------------------- - + where (abs(grid1_corner_lat-pih) < 1.e-03) grid1_corner_lat = pih where (abs(grid1_corner_lat+pih) < 1.e-03) grid1_corner_lat = -pih where (abs(grid2_corner_lat-pih) < 1.e-03) grid2_corner_lat = pih @@ -500,7 +500,7 @@ subroutine grid_init(errorCode,l_master,l_test) ip1 = 1 !*** but if it is not, correct e_add = (j - 1)*nx + ip1 - if (abs(grid1_center_lat(e_add) - + if (abs(grid1_center_lat(e_add) - & grid1_center_lat(n )) > pih) then ip1 = i endif @@ -513,7 +513,7 @@ subroutine grid_init(errorCode,l_master,l_test) jp1 = 1 !*** but if it is not, correct n_add = (jp1 - 1)*nx + i - if (abs(grid1_center_lat(n_add) - + if (abs(grid1_center_lat(n_add) - & grid1_center_lat(n )) > pih) then jp1 = j endif @@ -558,7 +558,7 @@ subroutine grid_init(errorCode,l_master,l_test) ip1 = 1 !*** but if it is not, correct e_add = (j - 1)*nx + ip1 - if (abs(grid2_center_lat(e_add) - + if (abs(grid2_center_lat(e_add) - & grid2_center_lat(n )) > pih) then ip1 = i endif @@ -571,7 +571,7 @@ subroutine grid_init(errorCode,l_master,l_test) jp1 = 1 !*** but if it is not, correct n_add = (jp1 - 1)*nx + i - if (abs(grid2_center_lat(n_add) - + if (abs(grid2_center_lat(n_add) - & grid2_center_lat(n )) > pih) then jp1 = j endif @@ -631,14 +631,14 @@ subroutine grid_init(errorCode,l_master,l_test) grid1_npole_cell = 0 grid1_spole_cell = 0 - + do grid1_add = 1, grid1_size found = .false. do corner = 1, grid1_corners endlat = grid1_corner_lat(corner,grid1_add) if (abs(abs(endlat)-pih) .lt. 1e-5) then - found = .true. ! cell has polar pnt; so pole is + found = .true. ! cell has polar pnt; so pole is ! not in the interior of the cell exit endif @@ -666,7 +666,7 @@ subroutine grid_init(errorCode,l_master,l_test) beglon = endlon enddo - + if (zero_crossing .eq. 1 .and. pi_crossing .eq. 1) then !*** @@ -699,7 +699,7 @@ subroutine grid_init(errorCode,l_master,l_test) do corner = 1, grid2_corners endlat = grid2_corner_lat(corner,grid2_add) if (abs(abs(endlat)-pih) .lt. 1e-5) then - found = .true. ! cell has polar pnt; so pole is + found = .true. ! cell has polar pnt; so pole is ! not in the interior of the cell exit endif @@ -714,7 +714,7 @@ subroutine grid_init(errorCode,l_master,l_test) do corner = 1, grid2_corners next_corn = mod(corner,grid2_corners) + 1 endlon = grid2_corner_lon(next_corn,grid2_add) - + if (abs(beglon-endlon) > pi) then zero_crossing = 1 else @@ -726,7 +726,7 @@ subroutine grid_init(errorCode,l_master,l_test) beglon = endlon enddo - + if (zero_crossing .eq. 1 .and. pi_crossing .eq. 1) then !*** @@ -755,13 +755,13 @@ subroutine grid_init(errorCode,l_master,l_test) ncorners_at_pole = 0 do i = 1, grid1_corners beglat = grid1_corner_lat(i,grid1_add) - if (abs(abs(beglat)-pih) .le. 1.e-5) + if (abs(abs(beglat)-pih) .le. 1.e-5) & ncorners_at_pole = ncorners_at_pole + 1 enddo - if (ncorners_at_pole .eq. 1) + if (ncorners_at_pole .eq. 1) & special_polar_cell1(grid1_add) = .true. - + enddo special_polar_cell2 = .false. @@ -770,13 +770,13 @@ subroutine grid_init(errorCode,l_master,l_test) ncorners_at_pole = 0 do i = 1, grid2_corners beglat = grid2_corner_lat(i,grid2_add) - if (abs(abs(beglat)-pih) .le. 1.e-5) + if (abs(abs(beglat)-pih) .le. 1.e-5) & ncorners_at_pole = ncorners_at_pole + 1 enddo - if (ncorners_at_pole .eq. 1) + if (ncorners_at_pole .eq. 1) & special_polar_cell2(grid2_add) = .true. - + enddo if(l_master)print *, ' ' @@ -794,21 +794,21 @@ subroutine grid_init(errorCode,l_master,l_test) ! if(l_master)print *, 'grid1_spole_cell',grid1_spole_cell if (grid1_spole_cell .gt. 0) then do i = 1, grid1_corners - print *, grid1_corner_lat(i,grid1_spole_cell), + print *, grid1_corner_lat(i,grid1_spole_cell), & grid1_corner_lon(i,grid1_spole_cell) enddo endif ! if(l_master)print *, 'grid2_npole_cell',grid2_npole_cell if (grid2_npole_cell .gt. 0) then do i = 1, grid2_corners - print *, grid2_corner_lat(i,grid2_npole_cell), + print *, grid2_corner_lat(i,grid2_npole_cell), & grid2_corner_lon(i,grid2_npole_cell) enddo endif ! if(l_master)print *, 'grid2_spole_cell',grid2_spole_cell if (grid2_spole_cell .gt. 0) then do i = 1, grid2_corners - print *, grid2_corner_lat(i,grid2_spole_cell), + print *, grid2_corner_lat(i,grid2_spole_cell), & grid2_corner_lon(i,grid2_spole_cell) enddo endif @@ -817,7 +817,7 @@ subroutine grid_init(errorCode,l_master,l_test) !----------------------------------------------------------------------- ! -! set up and assign address ranges to search bins in order to +! set up and assign address ranges to search bins in order to ! further restrict later searches ! !----------------------------------------------------------------------- @@ -934,7 +934,7 @@ subroutine grid_init(errorCode,l_master,l_test) call SCRIP_GridComputeArea(grid1_area_in, grid1_corner_lat, & grid1_corner_lon, errorCode) - if (SCRIP_ErrorCheck(errorCode, rtnName, + if (SCRIP_ErrorCheck(errorCode, rtnName, & 'error computing grid1 area')) return endif @@ -942,7 +942,7 @@ subroutine grid_init(errorCode,l_master,l_test) call SCRIP_GridComputeArea(grid2_area_in, grid2_corner_lat, & grid2_corner_lon, errorCode) - if (SCRIP_ErrorCheck(errorCode, rtnName, + if (SCRIP_ErrorCheck(errorCode, rtnName, & 'error computing grid2 area')) return endif @@ -997,7 +997,7 @@ subroutine SCRIP_GridComputeArea(area, cornerLat, cornerLon, real (SCRIP_r8) :: & dphi ! delta(longitude) for this segment - + !----------------------------------------------------------------------- ! ! determine size of grid and initialize @@ -1023,7 +1023,7 @@ subroutine SCRIP_GridComputeArea(area, cornerLat, cornerLon, nextCorner = mod(nCorner,numCorners) + 1 !*** trapezoid rule - delta(Lon) is -0.5*dx - dphi = CornerLon( nCorner,nCell) - + dphi = CornerLon( nCorner,nCell) - & CornerLon(nextCorner,nCell) if (dphi > pi) then dphi = dphi - pi2 @@ -1032,7 +1032,7 @@ subroutine SCRIP_GridComputeArea(area, cornerLat, cornerLon, endif dphi = 0.5_SCRIP_r8*dphi - Area(nCell) = Area(nCell) + + Area(nCell) = Area(nCell) + & dphi*(sin(CornerLat( nCorner,nCell)) + & sin(CornerLat(nextCorner,nCell))) end do @@ -1049,4 +1049,3 @@ end subroutine SCRIP_GridComputeArea end module scrip_grids !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - diff --git a/model/src/SCRIP/scrip_interface.F90 b/model/src/SCRIP/scrip_interface.F90 index 0e51775c0..0635fe061 100644 --- a/model/src/SCRIP/scrip_interface.F90 +++ b/model/src/SCRIP/scrip_interface.F90 @@ -1,895 +1,893 @@ !/ ------------------------------------------------------------------- / - module scrip_interface - -! 1. Original author : -! -! Erick Rogers, NRL -! -! 2. Last update : -! -! See revisions. -! -! 3. Revisions : -! -! 29-Apr-2011 : Origination ( version 4.01 ) -! -! 4. Copyright : -! -! 5. Purpose : -! -! Routines to provide interface between WMGHGH and SCRIP -! -! 6. Variables and types : -! -! 7. Subroutines and functions : -! -! 8. Subroutines and functions used : -! -! 9. Remarks : -! On parallelization: -! When WW3 is working on WMGHGH, each MPI task performs identical computations -! and therefore creates its own copy of the an identical solution. Thus there -! is no MPI parallelization of WMGHGH. Presumably, this was designed with the -! expectation that WMGHGH computations are fairly quick. Unfortunately, SCRIP -! can be slow for large grids, making WMGHGH slow. It is possible to run SCRIP -! with OpenMP (with pgf90, it simply requires that we compile with the -mp flag). -! Unfortunately, this doesn't change the situation whereby each MPI task calls -! SCRIP and creates its own copy of an identical solution. Thus, if we want -! to use OpenMP to speed up SCRIP, it means that we have to leave some cores idle -! during the actual WW3 compuation. Example: using pgf90, we execute ww3_multi -! with mpirun -n 4. Thus, four MPI tasks are created. And say we compiled SCRIP -! using -mp and have nthreads=2 specified in scrip_interface.f. When multi gets -! to SCRIP, each MPI task will create 2 OpenMP threads, which means that we'd -! better have 8 threads available to do this, and also note that 4 threads will -! be idle after SCRIP is finished. This isn't an ideal solution. A better -! prior to the SCRIP call, is instructed to only compute using one MPI thread. -! Then, SCRIP does its thing using OpenMPI and returns to WMGHGH. Then, WMGHGH -! shares all the information with all the nodes and continues. -! On connection to WW3: -! This is handled by "scrip_wrapper" routines. These routines formerly resided -! in this file (scrip_interface.f*) but are now in wmscrpmd.ftn -! -! 10. Switches : -! -! 11. Source code : - - use SCRIP_KindsMod ! defines data types - -!.....notes: since the calling subroutine (wmghgh) does not know a priori the size -!............of the weights arrays, we manage the communication via this module. - implicit none - - type weight_data - integer (SCRIP_i4) :: n ! number of weights for dst cell - ! n is equivalent to NR1 and NLOC in original WMGHGH - ! NR1 is the counter of |MAPSTA|=1 (indicates sea point) - integer (SCRIP_i4) :: NR0 ! counter of MAPSTA=0 (indicates excluded point) - integer (SCRIP_i4) :: NR2 ! counter of |MAPSTA|=2 (indicates boundary point) - integer (SCRIP_i4) :: NRL ! counter of MAPSTA=0 (indicates excluded point) and MAPST2=0 (indicates land) - real (SCRIP_r8), allocatable :: w(:) ! weights, sized by n, formerly wxwy(:,:) - integer (SCRIP_i4), allocatable :: k(:) ! source grid cells, sized by n, formerly ksrc(:,:) - end type weight_data - - type(weight_data), allocatable :: wgtdata(:) - - contains -!/ ------------------------------------------------------------------- / - - - -!####################################################################### - subroutine scrip_clear -!####################################################################### - -! 1. Original author : -! -! Erick Rogers, NRL -! -! 2. Last update : -! -! See revisions. -! -! 3. Revisions : -! -! 5-May-2011 : Origination ( version 4.01 ) -! -! 4. Copyright : -! -! 5. Purpose : -! -! "Clear" all variables declared at module level of SCRIP routines -! (clear "common block" equivalent) -! -! 6. Method : -! -! rules: -! - if not an array (scalar), set to zero or other start value -! - if dimensioned array, set to zero -! - if allocatable array, deallocate -! - private variables: ignore, since we would need to -! make them public in order to clear them, which may do more -! harm than good. -! -! 7. Parameters, Variables and types : -! -! 8. Called by : -! -! Subroutine SCRIP_interface -! -! 9. Subroutines and functions used : -! -! None -! -! 10. Error messages: -! -! 11. Remarks : -! -! We "clear" all variables with "save" attribute, -! both "module variables" and "subroutine variables" -! including all variables that are initialized with a value -! in the type declaration, e.g. "real :: x=5.0" -! -! 12. Structure : -! -! 13. Switches : -! -! 14. Source code : - - use SCRIP_KindsMod - use scrip_timers - use scrip_remap_vars - use scrip_remap_conservative - use scrip_iounitsmod - use scrip_grids - - implicit none - - call timers_init ! takes care of all variables in timers.f - -!.....scrip_remap_vars.f : - max_links_map1=0 - num_links_map1=0 - max_links_map2=0 - num_links_map2=0 - num_maps=0 - num_wts=0 - map_type=0 - norm_opt=0 - resize_increment=0 - if(allocated(grid1_add_map1))deallocate(grid1_add_map1) - if(allocated(grid2_add_map1))deallocate(grid2_add_map1) - if(allocated(grid1_add_map2))deallocate(grid1_add_map2) - if(allocated(grid2_add_map2))deallocate(grid2_add_map2) - if(allocated(wts_map1))deallocate(wts_map1) - if(allocated(wts_map2))deallocate(wts_map2) - -!.....remap_conserv.f : -!.....scalars: - first_call_store_link_cnsrv = .true. - first_call_locate_segstart= .true. - first_call_locate_point= .true. - first_call_get_srch_cells=.true. - first_call_find_adj_cell=.true. - avoid_pole_count = 0 - avoid_pole_offset = tiny - last_cell_locate_segstart=0 - last_cell_grid_num_locate_segstart=0 - last_srch_grid_num_locate_segstart=0 - num_srch_cells_locate_segstart=0 - last_cell_locate_point=0 - last_cell_grid_num_locate_point=0 - last_srch_grid_num_locate_point=0 - num_srch_cell_locate_points=0 - srch_corners_locate_point=0 - srch_corners_find_adj_cell=0 - srch_corners_locate_segstart=0 - srch_corners_loc_get_srch_cells=0 - num_srch_cells_loc_get_srch_cells=0 - num_srch_cells_find_adj_cell=0 - last_cell_add_get_srch_cells=0 - last_cell_grid_num_get_srch_cells=0 - last_srch_grid_num_get_srch_cells=0 - last_cell_find_adj_cell=0 - last_cell_grid_num_find_adj_cell=0 -!.....arrays : - if(allocated(link_add1))deallocate(link_add1) - if(allocated(link_add2))deallocate(link_add2) - - if(allocated(srch_add_loc_get_srch_cells))deallocate(srch_add_loc_get_srch_cells) - if(allocated(srch_corner_lat_loc_get_srch_cells))deallocate(srch_corner_lat_loc_get_srch_cells) - if(allocated(srch_corner_lon_loc_get_srch_cells))deallocate(srch_corner_lon_loc_get_srch_cells) - if(allocated(srch_center_lat_loc_get_srch_cells))deallocate(srch_center_lat_loc_get_srch_cells) - if(allocated(srch_center_lon_loc_get_srch_cells))deallocate(srch_center_lon_loc_get_srch_cells) - - if(allocated(srch_add_find_adj_cell))deallocate(srch_add_find_adj_cell) - if(allocated(srch_corner_lat_find_adj_cell))deallocate(srch_corner_lat_find_adj_cell) - if(allocated(srch_corner_lon_find_adj_cell))deallocate(srch_corner_lon_find_adj_cell) - if(allocated(srch_center_lat_find_adj_cell))deallocate(srch_center_lat_find_adj_cell) - if(allocated(srch_center_lon_find_adj_cell))deallocate(srch_center_lon_find_adj_cell) - - if(allocated(srch_add_locate_segstart))deallocate(srch_add_locate_segstart) - if(allocated(srch_corner_lat_locate_segstart))deallocate(srch_corner_lat_locate_segstart) - if(allocated(srch_corner_lon_locate_segstart))deallocate(srch_corner_lon_locate_segstart) - if(allocated(srch_center_lat_locate_segstart))deallocate(srch_center_lat_locate_segstart) - if(allocated(srch_center_lon_locate_segstart))deallocate(srch_center_lon_locate_segstart) - - if(allocated(srch_add_locate_point))deallocate(srch_add_locate_point) - if(allocated(srch_corner_lat_locate_point))deallocate(srch_corner_lat_locate_point) - if(allocated(srch_corner_lon_locate_point))deallocate(srch_corner_lon_locate_point) - if(allocated(srch_center_lat_locate_point))deallocate(srch_center_lat_locate_point) - if(allocated(srch_center_lon_locate_point))deallocate(srch_center_lon_locate_point) - -!.....scrip_grids.f : - grid1_size=0 - grid2_size=0 - grid1_rank=0 - grid2_rank=0 - grid1_corners=0 - grid2_corners=0 - grid1_name='' - grid2_name='' - grid1_units='' - grid2_units='' - luse_grid_centers=.false. - luse_grid1_area=.false. - luse_grid2_area=.false. - restrict_type='' - num_srch_bins=0 - if(allocated(bin_addr1))deallocate(bin_addr1) - if(allocated(bin_addr2))deallocate(bin_addr2) - if(allocated(bin_lats))deallocate(bin_lats) - if(allocated(bin_lons))deallocate(bin_lons) - if(allocated(grid1_dims))deallocate(grid1_dims) - if(allocated(grid2_dims))deallocate(grid2_dims) - if(allocated(grid1_mask))deallocate(grid1_mask) - if(allocated(grid2_mask))deallocate(grid2_mask) - if(allocated(grid1_center_lat))deallocate(grid1_center_lat) - if(allocated(grid1_center_lon))deallocate(grid1_center_lon) - if(allocated(grid2_center_lat))deallocate(grid2_center_lat) - if(allocated(grid2_center_lon))deallocate(grid2_center_lon) - if(allocated(grid1_area))deallocate(grid1_area) - if(allocated(grid2_area))deallocate(grid2_area) - if(allocated(grid1_area_in))deallocate(grid1_area_in) - if(allocated(grid2_area_in))deallocate(grid2_area_in) - if(allocated(grid1_frac))deallocate(grid1_frac) - if(allocated(grid2_frac))deallocate(grid2_frac) - if(allocated(grid1_corner_lat))deallocate(grid1_corner_lat) - if(allocated(grid1_corner_lon))deallocate(grid1_corner_lon) - if(allocated(grid2_corner_lat))deallocate(grid2_corner_lat) - if(allocated(grid2_corner_lon))deallocate(grid2_corner_lon) - if(allocated(grid1_bound_box))deallocate(grid1_bound_box) - if(allocated(grid2_bound_box))deallocate(grid2_bound_box) - if(allocated(special_polar_cell1))deallocate(special_polar_cell1) - if(allocated(special_polar_cell2))deallocate(special_polar_cell2) - if(allocated(grid1_centroid_lat))deallocate(grid1_centroid_lat) - if(allocated(grid1_centroid_lon))deallocate(grid1_centroid_lon) - if(allocated(grid2_centroid_lat))deallocate(grid2_centroid_lat) - if(allocated(grid2_centroid_lon))deallocate(grid2_centroid_lon) - -!####################################################################### - end subroutine scrip_clear -!####################################################################### +module scrip_interface + + ! 1. Original author : + ! + ! Erick Rogers, NRL + ! + ! 2. Last update : + ! + ! See revisions. + ! + ! 3. Revisions : + ! + ! 29-Apr-2011 : Origination ( version 4.01 ) + ! + ! 4. Copyright : + ! + ! 5. Purpose : + ! + ! Routines to provide interface between WMGHGH and SCRIP + ! + ! 6. Variables and types : + ! + ! 7. Subroutines and functions : + ! + ! 8. Subroutines and functions used : + ! + ! 9. Remarks : + ! On parallelization: + ! When WW3 is working on WMGHGH, each MPI task performs identical computations + ! and therefore creates its own copy of the an identical solution. Thus there + ! is no MPI parallelization of WMGHGH. Presumably, this was designed with the + ! expectation that WMGHGH computations are fairly quick. Unfortunately, SCRIP + ! can be slow for large grids, making WMGHGH slow. It is possible to run SCRIP + ! with OpenMP (with pgf90, it simply requires that we compile with the -mp flag). + ! Unfortunately, this doesn't change the situation whereby each MPI task calls + ! SCRIP and creates its own copy of an identical solution. Thus, if we want + ! to use OpenMP to speed up SCRIP, it means that we have to leave some cores idle + ! during the actual WW3 compuation. Example: using pgf90, we execute ww3_multi + ! with mpirun -n 4. Thus, four MPI tasks are created. And say we compiled SCRIP + ! using -mp and have nthreads=2 specified in scrip_interface.f. When multi gets + ! to SCRIP, each MPI task will create 2 OpenMP threads, which means that we'd + ! better have 8 threads available to do this, and also note that 4 threads will + ! be idle after SCRIP is finished. This isn't an ideal solution. A better + ! prior to the SCRIP call, is instructed to only compute using one MPI thread. + ! Then, SCRIP does its thing using OpenMPI and returns to WMGHGH. Then, WMGHGH + ! shares all the information with all the nodes and continues. + ! On connection to WW3: + ! This is handled by "scrip_wrapper" routines. These routines formerly resided + ! in this file (scrip_interface.f*) but are now in wmscrpmd.ftn + ! + ! 10. Switches : + ! + ! 11. Source code : + + use SCRIP_KindsMod ! defines data types + + !.....notes: since the calling subroutine (wmghgh) does not know a priori the size + !............of the weights arrays, we manage the communication via this module. + implicit none + + type weight_data + integer (SCRIP_i4) :: n ! number of weights for dst cell + ! n is equivalent to NR1 and NLOC in original WMGHGH + ! NR1 is the counter of |MAPSTA|=1 (indicates sea point) + integer (SCRIP_i4) :: NR0 ! counter of MAPSTA=0 (indicates excluded point) + integer (SCRIP_i4) :: NR2 ! counter of |MAPSTA|=2 (indicates boundary point) + integer (SCRIP_i4) :: NRL ! counter of MAPSTA=0 (indicates excluded point) and MAPST2=0 (indicates land) + real (SCRIP_r8), allocatable :: w(:) ! weights, sized by n, formerly wxwy(:,:) + integer (SCRIP_i4), allocatable :: k(:) ! source grid cells, sized by n, formerly ksrc(:,:) + end type weight_data + + type(weight_data), allocatable :: wgtdata(:) + +contains + !/ ------------------------------------------------------------------- / + + + + !####################################################################### + subroutine scrip_clear + !####################################################################### + + ! 1. Original author : + ! + ! Erick Rogers, NRL + ! + ! 2. Last update : + ! + ! See revisions. + ! + ! 3. Revisions : + ! + ! 5-May-2011 : Origination ( version 4.01 ) + ! + ! 4. Copyright : + ! + ! 5. Purpose : + ! + ! "Clear" all variables declared at module level of SCRIP routines + ! (clear "common block" equivalent) + ! + ! 6. Method : + ! + ! rules: + ! - if not an array (scalar), set to zero or other start value + ! - if dimensioned array, set to zero + ! - if allocatable array, deallocate + ! - private variables: ignore, since we would need to + ! make them public in order to clear them, which may do more + ! harm than good. + ! + ! 7. Parameters, Variables and types : + ! + ! 8. Called by : + ! + ! Subroutine SCRIP_interface + ! + ! 9. Subroutines and functions used : + ! + ! None + ! + ! 10. Error messages: + ! + ! 11. Remarks : + ! + ! We "clear" all variables with "save" attribute, + ! both "module variables" and "subroutine variables" + ! including all variables that are initialized with a value + ! in the type declaration, e.g. "real :: x=5.0" + ! + ! 12. Structure : + ! + ! 13. Switches : + ! + ! 14. Source code : + + use SCRIP_KindsMod + use scrip_timers + use scrip_remap_vars + use scrip_remap_conservative + use scrip_iounitsmod + use scrip_grids + + implicit none + + call timers_init ! takes care of all variables in timers.f + + !.....scrip_remap_vars.f : + max_links_map1=0 + num_links_map1=0 + max_links_map2=0 + num_links_map2=0 + num_maps=0 + num_wts=0 + map_type=0 + norm_opt=0 + resize_increment=0 + if(allocated(grid1_add_map1))deallocate(grid1_add_map1) + if(allocated(grid2_add_map1))deallocate(grid2_add_map1) + if(allocated(grid1_add_map2))deallocate(grid1_add_map2) + if(allocated(grid2_add_map2))deallocate(grid2_add_map2) + if(allocated(wts_map1))deallocate(wts_map1) + if(allocated(wts_map2))deallocate(wts_map2) + + !.....remap_conserv.f : + !.....scalars: + first_call_store_link_cnsrv = .true. + first_call_locate_segstart= .true. + first_call_locate_point= .true. + first_call_get_srch_cells=.true. + first_call_find_adj_cell=.true. + avoid_pole_count = 0 + avoid_pole_offset = tiny + last_cell_locate_segstart=0 + last_cell_grid_num_locate_segstart=0 + last_srch_grid_num_locate_segstart=0 + num_srch_cells_locate_segstart=0 + last_cell_locate_point=0 + last_cell_grid_num_locate_point=0 + last_srch_grid_num_locate_point=0 + num_srch_cell_locate_points=0 + srch_corners_locate_point=0 + srch_corners_find_adj_cell=0 + srch_corners_locate_segstart=0 + srch_corners_loc_get_srch_cells=0 + num_srch_cells_loc_get_srch_cells=0 + num_srch_cells_find_adj_cell=0 + last_cell_add_get_srch_cells=0 + last_cell_grid_num_get_srch_cells=0 + last_srch_grid_num_get_srch_cells=0 + last_cell_find_adj_cell=0 + last_cell_grid_num_find_adj_cell=0 + !.....arrays : + if(allocated(link_add1))deallocate(link_add1) + if(allocated(link_add2))deallocate(link_add2) + + if(allocated(srch_add_loc_get_srch_cells))deallocate(srch_add_loc_get_srch_cells) + if(allocated(srch_corner_lat_loc_get_srch_cells))deallocate(srch_corner_lat_loc_get_srch_cells) + if(allocated(srch_corner_lon_loc_get_srch_cells))deallocate(srch_corner_lon_loc_get_srch_cells) + if(allocated(srch_center_lat_loc_get_srch_cells))deallocate(srch_center_lat_loc_get_srch_cells) + if(allocated(srch_center_lon_loc_get_srch_cells))deallocate(srch_center_lon_loc_get_srch_cells) + + if(allocated(srch_add_find_adj_cell))deallocate(srch_add_find_adj_cell) + if(allocated(srch_corner_lat_find_adj_cell))deallocate(srch_corner_lat_find_adj_cell) + if(allocated(srch_corner_lon_find_adj_cell))deallocate(srch_corner_lon_find_adj_cell) + if(allocated(srch_center_lat_find_adj_cell))deallocate(srch_center_lat_find_adj_cell) + if(allocated(srch_center_lon_find_adj_cell))deallocate(srch_center_lon_find_adj_cell) + + if(allocated(srch_add_locate_segstart))deallocate(srch_add_locate_segstart) + if(allocated(srch_corner_lat_locate_segstart))deallocate(srch_corner_lat_locate_segstart) + if(allocated(srch_corner_lon_locate_segstart))deallocate(srch_corner_lon_locate_segstart) + if(allocated(srch_center_lat_locate_segstart))deallocate(srch_center_lat_locate_segstart) + if(allocated(srch_center_lon_locate_segstart))deallocate(srch_center_lon_locate_segstart) + + if(allocated(srch_add_locate_point))deallocate(srch_add_locate_point) + if(allocated(srch_corner_lat_locate_point))deallocate(srch_corner_lat_locate_point) + if(allocated(srch_corner_lon_locate_point))deallocate(srch_corner_lon_locate_point) + if(allocated(srch_center_lat_locate_point))deallocate(srch_center_lat_locate_point) + if(allocated(srch_center_lon_locate_point))deallocate(srch_center_lon_locate_point) + + !.....scrip_grids.f : + grid1_size=0 + grid2_size=0 + grid1_rank=0 + grid2_rank=0 + grid1_corners=0 + grid2_corners=0 + grid1_name='' + grid2_name='' + grid1_units='' + grid2_units='' + luse_grid_centers=.false. + luse_grid1_area=.false. + luse_grid2_area=.false. + restrict_type='' + num_srch_bins=0 + if(allocated(bin_addr1))deallocate(bin_addr1) + if(allocated(bin_addr2))deallocate(bin_addr2) + if(allocated(bin_lats))deallocate(bin_lats) + if(allocated(bin_lons))deallocate(bin_lons) + if(allocated(grid1_dims))deallocate(grid1_dims) + if(allocated(grid2_dims))deallocate(grid2_dims) + if(allocated(grid1_mask))deallocate(grid1_mask) + if(allocated(grid2_mask))deallocate(grid2_mask) + if(allocated(grid1_center_lat))deallocate(grid1_center_lat) + if(allocated(grid1_center_lon))deallocate(grid1_center_lon) + if(allocated(grid2_center_lat))deallocate(grid2_center_lat) + if(allocated(grid2_center_lon))deallocate(grid2_center_lon) + if(allocated(grid1_area))deallocate(grid1_area) + if(allocated(grid2_area))deallocate(grid2_area) + if(allocated(grid1_area_in))deallocate(grid1_area_in) + if(allocated(grid2_area_in))deallocate(grid2_area_in) + if(allocated(grid1_frac))deallocate(grid1_frac) + if(allocated(grid2_frac))deallocate(grid2_frac) + if(allocated(grid1_corner_lat))deallocate(grid1_corner_lat) + if(allocated(grid1_corner_lon))deallocate(grid1_corner_lon) + if(allocated(grid2_corner_lat))deallocate(grid2_corner_lat) + if(allocated(grid2_corner_lon))deallocate(grid2_corner_lon) + if(allocated(grid1_bound_box))deallocate(grid1_bound_box) + if(allocated(grid2_bound_box))deallocate(grid2_bound_box) + if(allocated(special_polar_cell1))deallocate(special_polar_cell1) + if(allocated(special_polar_cell2))deallocate(special_polar_cell2) + if(allocated(grid1_centroid_lat))deallocate(grid1_centroid_lat) + if(allocated(grid1_centroid_lon))deallocate(grid1_centroid_lon) + if(allocated(grid2_centroid_lat))deallocate(grid2_centroid_lat) + if(allocated(grid2_centroid_lon))deallocate(grid2_centroid_lon) + + !####################################################################### + end subroutine scrip_clear + !####################################################################### !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! subroutine scrip: -! This routine is the driver for computing the addresses and weights -! for interpolating between two grids on a sphere. -! -!----------------------------------------------------------------------- -! -! CVS:$Id: scrip.f,v 1.6 2001/08/21 21:06:44 pwjones Exp $ -! -! Copyright (c) 1997, 1998 the Regents of the University of -! California. -! -! This software and ancillary information (herein called software) -! called SCRIP is made available under the terms described here. -! The software has been approved for release with associated -! LA-CC Number 98-45. -! -! Unless otherwise indicated, this software has been authored -! by an employee or employees of the University of California, -! operator of the Los Alamos National Laboratory under Contract -! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. -! Government has rights to use, reproduce, and distribute this -! software. The public may copy and use this software without -! charge, provided that this Notice and any statement of authorship -! are reproduced on all copies. Neither the Government nor the -! University makes any warranty, express or implied, or assumes -! any liability or responsibility for the use of this software. -! -! If software is modified to produce derivative works, such modified -! software should be clearly marked, so as not to confuse it with -! the version available from Los Alamos National Laboratory. -! -! This code has been modified from the version available from -! Los Alamos National Laboratory, for the purpose of running it -! within WW3. Here is a list of modifications: -! - changed from standalone program to a subroutine, to be called -! by scrip_wrapper -! - all modules are now prepended with "scrip_" to make them easier -! to distinguish from WW3 code. -! - code changed to free format style (e.g. continuation characters) -! - print statements added -! - initial values for settings are changed -! - initial value for "map_method" added (is set to "conservative") -! - read of settings from "scrip_in" is removed, and file "scrip_in" -! is thus no longer used -! - in context of scrip_wrapper, these initial values for the settings -! are never changed. Thus, these settings are basically hardwired -! in here. -! - lines associated with remap_distance_weight, remap_bilinear, -! remap_bicubic are removed. Motivation: we do not need these -! routines, so we opt to exclude them in our compile -! (fewer .f files, fewer compiles). -! -!*********************************************************************** - - subroutine scrip(src_num, dst_num, l_master, l_read, l_test) - -!----------------------------------------------------------------------- - - use SCRIP_KindsMod ! module defining data types - use scrip_constants ! module for common constants - use scrip_iounitsmod ! I/O unit manager - use scrip_timers ! CPU timers - use scrip_grids ! module with grid information - use scrip_remap_vars ! common remapping variables - use scrip_remap_conservative ! routines for conservative remap + ! + ! subroutine scrip: + ! This routine is the driver for computing the addresses and weights + ! for interpolating between two grids on a sphere. + ! + !----------------------------------------------------------------------- + ! + ! CVS:$Id: scrip.f,v 1.6 2001/08/21 21:06:44 pwjones Exp $ + ! + ! Copyright (c) 1997, 1998 the Regents of the University of + ! California. + ! + ! This software and ancillary information (herein called software) + ! called SCRIP is made available under the terms described here. + ! The software has been approved for release with associated + ! LA-CC Number 98-45. + ! + ! Unless otherwise indicated, this software has been authored + ! by an employee or employees of the University of California, + ! operator of the Los Alamos National Laboratory under Contract + ! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. + ! Government has rights to use, reproduce, and distribute this + ! software. The public may copy and use this software without + ! charge, provided that this Notice and any statement of authorship + ! are reproduced on all copies. Neither the Government nor the + ! University makes any warranty, express or implied, or assumes + ! any liability or responsibility for the use of this software. + ! + ! If software is modified to produce derivative works, such modified + ! software should be clearly marked, so as not to confuse it with + ! the version available from Los Alamos National Laboratory. + ! + ! This code has been modified from the version available from + ! Los Alamos National Laboratory, for the purpose of running it + ! within WW3. Here is a list of modifications: + ! - changed from standalone program to a subroutine, to be called + ! by scrip_wrapper + ! - all modules are now prepended with "scrip_" to make them easier + ! to distinguish from WW3 code. + ! - code changed to free format style (e.g. continuation characters) + ! - print statements added + ! - initial values for settings are changed + ! - initial value for "map_method" added (is set to "conservative") + ! - read of settings from "scrip_in" is removed, and file "scrip_in" + ! is thus no longer used + ! - in context of scrip_wrapper, these initial values for the settings + ! are never changed. Thus, these settings are basically hardwired + ! in here. + ! - lines associated with remap_distance_weight, remap_bilinear, + ! remap_bicubic are removed. Motivation: we do not need these + ! routines, so we opt to exclude them in our compile + ! (fewer .f files, fewer compiles). + ! + !*********************************************************************** + + subroutine scrip(src_num, dst_num, l_master, l_read, l_test) + + !----------------------------------------------------------------------- + + use SCRIP_KindsMod ! module defining data types + use scrip_constants ! module for common constants + use scrip_iounitsmod ! I/O unit manager + use scrip_timers ! CPU timers + use scrip_grids ! module with grid information + use scrip_remap_vars ! common remapping variables + use scrip_remap_conservative ! routines for conservative remap #ifdef W3_SCRIPNC - use scrip_remap_write ! routines for remap output - use scrip_remap_read ! routines for remap input + use scrip_remap_write ! routines for remap output + use scrip_remap_read ! routines for remap input #endif - use scrip_errormod + use scrip_errormod - implicit none + implicit none -!----------------------------------------------------------------------- -! -! input variables formerly part of namelist -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! input variables formerly part of namelist + ! + !----------------------------------------------------------------------- - character (SCRIP_charLength) :: & - interp_file1,& ! filename for output remap data (map1) - interp_file2,& ! filename for output remap data (map2) - map1_name, & ! name for mapping from grid1 to grid2 - map2_name, & ! name for mapping from grid2 to grid1 - map_method, & ! choice for mapping method - normalize_opt,&! option for normalizing weights - output_opt ! option for output conventions + character (SCRIP_charLength) :: & + interp_file1,& ! filename for output remap data (map1) + interp_file2,& ! filename for output remap data (map2) + map1_name, & ! name for mapping from grid1 to grid2 + map2_name, & ! name for mapping from grid2 to grid1 + map_method, & ! choice for mapping method + normalize_opt,&! option for normalizing weights + output_opt ! option for output conventions - integer (SCRIP_i4) :: & - nmap ! number of mappings to compute (1 or 2) + integer (SCRIP_i4) :: & + nmap ! number of mappings to compute (1 or 2) -!----------------------------------------------------------------------- -! -! input variables not part of namelist -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! input variables not part of namelist + ! + !----------------------------------------------------------------------- - integer (SCRIP_i4), intent(in) :: dst_num ! number of destination grid GDST - integer (SCRIP_i4), intent(in) :: src_num ! number of source grid GSRC - logical (SCRIP_Logical), intent(in) :: l_master ! Am I the master processor (do I/O)? - logical( SCRIP_Logical), intent(in) :: l_read ! Do I read the remap file? - logical(SCRIP_Logical), intent(in) :: l_test ! Whether to include test output - ! in subroutines + integer (SCRIP_i4), intent(in) :: dst_num ! number of destination grid GDST + integer (SCRIP_i4), intent(in) :: src_num ! number of source grid GSRC + logical (SCRIP_Logical), intent(in) :: l_master ! Am I the master processor (do I/O)? + logical( SCRIP_Logical), intent(in) :: l_read ! Do I read the remap file? + logical(SCRIP_Logical), intent(in) :: l_test ! Whether to include test output + ! in subroutines -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------------- - integer (SCRIP_i4) :: n, & ! dummy counter - iunit ! unit number for namelist file + integer (SCRIP_i4) :: n, & ! dummy counter + iunit ! unit number for namelist file - integer (SCRIP_i4) :: & - errorCode ! error flag + integer (SCRIP_i4) :: & + errorCode ! error flag - character (12), parameter :: & - rtnName = 'SCRIP_driver' + character (12), parameter :: & + rtnName = 'SCRIP_driver' #ifdef W3_SCRIPNC - character (LEN=3) :: cdst ! 3 character number of destination map - character (LEN=3) :: csrc ! 3 character number of source map + character (LEN=3) :: cdst ! 3 character number of destination map + character (LEN=3) :: csrc ! 3 character number of source map #endif #ifdef W3_T38 - CHARACTER (LEN=10) :: CDATE_TIME(3) - INTEGER :: DATE_TIME(8) - INTEGER :: ELAPSED_TIME, BEG_TIME, END_TIME + CHARACTER (LEN=10) :: CDATE_TIME(3) + INTEGER :: DATE_TIME(8) + INTEGER :: ELAPSED_TIME, BEG_TIME, END_TIME #endif -!----------------------------------------------------------------------- -! -! initialize timers and errorcode -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! initialize timers and errorcode + ! + !----------------------------------------------------------------------- #ifdef W3_T38 - if(l_master)write(SCRIP_stdout,*)'subroutine scrip' + if(l_master)write(SCRIP_stdout,*)'subroutine scrip' #endif - call timers_init - do n=1,max_timers - call timer_clear(n) - end do + call timers_init + do n=1,max_timers + call timer_clear(n) + end do - errorCode = SCRIP_Success + errorCode = SCRIP_Success -!----------------------------------------------------------------------- -! -! set variables that were previously read in as a namelist -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! set variables that were previously read in as a namelist + ! + !----------------------------------------------------------------------- - num_maps = 1 + num_maps = 1 #ifdef W3_SCRIPNC -! Note: Only master does I/O, but all processors need to know about -! file existence - interp_file1 = "rmp_src_to_dst_conserv_XXX_XXX.nc" - interp_file2 = 'not_used.nc' - map1_name = 'source to destination Conservative Mapping' - map2_name = 'map not used' - write(cdst, "(i3.3)") dst_num - write(csrc, "(i3.3)") src_num - interp_file1(24:26) = csrc - interp_file1(28:30) = cdst + ! Note: Only master does I/O, but all processors need to know about + ! file existence + interp_file1 = "rmp_src_to_dst_conserv_XXX_XXX.nc" + interp_file2 = 'not_used.nc' + map1_name = 'source to destination Conservative Mapping' + map2_name = 'map not used' + write(cdst, "(i3.3)") dst_num + write(csrc, "(i3.3)") src_num + interp_file1(24:26) = csrc + interp_file1(28:30) = cdst #endif - map_method = 'conservative' - normalize_opt = 'fracarea' - output_opt = 'scrip' - restrict_type = 'latitude' - num_srch_bins = 90 - luse_grid1_area = .false. - luse_grid2_area = .false. - npseg=11 ! or num_polar_segs - north_thresh=1.5_SCRIP_r8 ! or npole_threshold - south_thresh=-1.5_SCRIP_r8 ! or spole_threshold - nthreads=2 ! or num_threads - - select case(map_method) - case ('conservative') - map_type = map_type_conserv - luse_grid_centers = .false. - case ('bilinear') - map_type = map_type_bilinear - luse_grid_centers = .true. - case ('bicubic') - map_type = map_type_bicubic - luse_grid_centers = .true. - case ('distwgt') - map_type = map_type_distwgt - luse_grid_centers = .true. - case ('particle') - map_type = map_type_particle - luse_grid_centers = .false. - case default - call SCRIP_ErrorSet(errorCode, rtnName, 'unknown mapping method') - call SCRIP_driverExit(errorCode, 'unknown mapping method') - end select - - select case(normalize_opt(1:4)) - case ('none') - norm_opt = norm_opt_none - case ('frac') - norm_opt = norm_opt_frcarea - case ('dest') - norm_opt = norm_opt_dstarea - case default - call SCRIP_ErrorSet(errorCode, rtnName, 'unknown normalization option') - call SCRIP_driverExit(errorCode, 'unknown normalization option') - end select - -!----------------------------------------------------------------------- -! -! initialize grid information for both grids -! -!----------------------------------------------------------------------- + map_method = 'conservative' + normalize_opt = 'fracarea' + output_opt = 'scrip' + restrict_type = 'latitude' + num_srch_bins = 90 + luse_grid1_area = .false. + luse_grid2_area = .false. + npseg=11 ! or num_polar_segs + north_thresh=1.5_SCRIP_r8 ! or npole_threshold + south_thresh=-1.5_SCRIP_r8 ! or spole_threshold + nthreads=2 ! or num_threads + + select case(map_method) + case ('conservative') + map_type = map_type_conserv + luse_grid_centers = .false. + case ('bilinear') + map_type = map_type_bilinear + luse_grid_centers = .true. + case ('bicubic') + map_type = map_type_bicubic + luse_grid_centers = .true. + case ('distwgt') + map_type = map_type_distwgt + luse_grid_centers = .true. + case ('particle') + map_type = map_type_particle + luse_grid_centers = .false. + case default + call SCRIP_ErrorSet(errorCode, rtnName, 'unknown mapping method') + call SCRIP_driverExit(errorCode, 'unknown mapping method') + end select + + select case(normalize_opt(1:4)) + case ('none') + norm_opt = norm_opt_none + case ('frac') + norm_opt = norm_opt_frcarea + case ('dest') + norm_opt = norm_opt_dstarea + case default + call SCRIP_ErrorSet(errorCode, rtnName, 'unknown normalization option') + call SCRIP_driverExit(errorCode, 'unknown normalization option') + end select + + !----------------------------------------------------------------------- + ! + ! initialize grid information for both grids + ! + !----------------------------------------------------------------------- #ifdef W3_T38 - if(l_master)write(SCRIP_stdout,*)'calling grid_init' + if(l_master)write(SCRIP_stdout,*)'calling grid_init' #endif - call grid_init( errorCode,l_master,l_test) + call grid_init( errorCode,l_master,l_test) #ifdef W3_T38 - if(l_master)write(SCRIP_stdout, *) 'Computing remappings between: ',grid1_name - if(l_master)write(SCRIP_stdout, *) ' and ',grid2_name + if(l_master)write(SCRIP_stdout, *) 'Computing remappings between: ',grid1_name + if(l_master)write(SCRIP_stdout, *) ' and ',grid2_name #endif -!----------------------------------------------------------------------- -! -! initialize some remapping variables. -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! initialize some remapping variables. + ! + !----------------------------------------------------------------------- - call init_remap_vars + call init_remap_vars -!----------------------------------------------------------------------- -! -! call appropriate interpolation setup routine based on type of -! remapping requested. or read in remapping data. + !----------------------------------------------------------------------- + ! + ! call appropriate interpolation setup routine based on type of + ! remapping requested. or read in remapping data. #ifdef W3_SCRIPNC -!or, read in remapping data. + !or, read in remapping data. #endif -! -!----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- #ifdef W3_T38 - call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) #endif - + #ifdef W3_SCRIPNC - if (l_read) then - if(l_master)write(SCRIP_stdout, *) 'Reading remapping data from ', interp_file1 - call read_remap_ww3(map1_name, interp_file1, errorCode) + if (l_read) then + if(l_master)write(SCRIP_stdout, *) 'Reading remapping data from ', interp_file1 + call read_remap_ww3(map1_name, interp_file1, errorCode) #endif #ifdef W3_T38 - call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) - elapsed_time = end_time - beg_time - write(0,*) "SCRIP: READING ", elapsed_time, " MSEC" + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + elapsed_time = end_time - beg_time + write(0,*) "SCRIP: READING ", elapsed_time, " MSEC" #endif #ifdef W3_SCRIPNC - else + else #endif - select case(map_type) - case(map_type_conserv) + select case(map_type) + case(map_type_conserv) #ifdef W3_T38 - if(l_master)write(SCRIP_stdout,*)'calling remap_conserv' + if(l_master)write(SCRIP_stdout,*)'calling remap_conserv' #endif - call remap_conserv(l_master,l_test) + call remap_conserv(l_master,l_test) #ifdef W3_T38 - if(l_master)write(SCRIP_stdout,*)'back from remap_conserv' - call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) - elapsed_time = end_time - beg_time - write(0,*) "SCRIP: CALCULATING ", elapsed_time, " MSEC" + if(l_master)write(SCRIP_stdout,*)'back from remap_conserv' + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + elapsed_time = end_time - beg_time + write(0,*) "SCRIP: CALCULATING ", elapsed_time, " MSEC" #endif - case default - call SCRIP_ErrorSet(errorCode, rtnName, 'Invalid Map Type') - call SCRIP_driverExit(errorCode, 'Invalid Map Type') - end select - -!----------------------------------------------------------------------- -! -! reduce size of remapping arrays -! -!----------------------------------------------------------------------- - + case default + call SCRIP_ErrorSet(errorCode, rtnName, 'Invalid Map Type') + call SCRIP_driverExit(errorCode, 'Invalid Map Type') + end select + + !----------------------------------------------------------------------- + ! + ! reduce size of remapping arrays + ! + !----------------------------------------------------------------------- + #ifdef W3_T38 - call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) #endif - if (num_links_map1 /= max_links_map1) then - call resize_remap_vars(1, num_links_map1-max_links_map1) - endif - if ((num_maps > 1) .and. (num_links_map2 /= max_links_map2)) then - call resize_remap_vars(2, num_links_map2-max_links_map2) - endif + if (num_links_map1 /= max_links_map1) then + call resize_remap_vars(1, num_links_map1-max_links_map1) + endif + if ((num_maps > 1) .and. (num_links_map2 /= max_links_map2)) then + call resize_remap_vars(2, num_links_map2-max_links_map2) + endif - call sort_add_v2(grid2_add_map1, grid1_add_map1, wts_map1) + call sort_add_v2(grid2_add_map1, grid1_add_map1, wts_map1) -!----------------------------------------------------------------------- -! + !----------------------------------------------------------------------- + ! #ifdef W3_SCRIPNC -! write remapping info to a file. + ! write remapping info to a file. #endif -! -!----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- #ifdef W3_SCRIPNC - if (l_master) then - write(SCRIP_stdout, *) 'Writing remapping data to ', interp_file1 - endif + if (l_master) then + write(SCRIP_stdout, *) 'Writing remapping data to ', interp_file1 + endif #endif #ifdef W3_T38 - call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) - elapsed_time = end_time - beg_time - write(0,*) "SCRIP: RESIZING ", elapsed_time, " MSEC" - call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + elapsed_time = end_time - beg_time + write(0,*) "SCRIP: RESIZING ", elapsed_time, " MSEC" + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) #endif -! Use write_remap if you want the extra variables in the .nc files for diagnostics -! Use write_remap_ww3 if you don't want any extra variables in the .nc files + ! Use write_remap if you want the extra variables in the .nc files for diagnostics + ! Use write_remap_ww3 if you don't want any extra variables in the .nc files #ifdef W3_SCRIPNC - if(l_test)then - call write_remap(map1_name, map2_name, interp_file1, interp_file2, & - output_opt, l_master, errorCode) - else - call write_remap_ww3(map1_name, interp_file1, output_opt, & - l_master, errorCode) - endif + if(l_test)then + call write_remap(map1_name, map2_name, interp_file1, interp_file2, & + output_opt, l_master, errorCode) + else + call write_remap_ww3(map1_name, interp_file1, output_opt, & + l_master, errorCode) + endif #endif #ifdef W3_SCRIPNC - end if + end if #endif -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- - end subroutine scrip + end subroutine scrip !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine SCRIP_driverExit(errorCode,errormsg) - -! !DESCRIPTION: -! This routine exits the SCRIP driver program. It first calls the -! SCRIP error print function to print any errors encountered and then -! exits the message environment before stopping. -! -! !USES: - - use SCRIP_KindsMod - -! !INPUT PARAMETERS: - - integer (SCRIP_i4), intent(in) :: & - errorCode ! error flag to detect any errors encountered - - CHARACTER*(*), INTENT(IN) :: errormsg -!----------------------------------------------------------------------- -! -! call SCRIP error print function to output any logged errors that -! were encountered during execution. Then stop. -! -!----------------------------------------------------------------------- - - write(*,*)'error encountered : ',errorcode - write(*,*)errormsg - - stop - -!----------------------------------------------------------------------- - - end subroutine SCRIP_driverExit - -!####################################################################### - subroutine sort_add_v2(add1, add2, weights) -!####################################################################### - -!----------------------------------------------------------------------- -! -! this routine sorts address and weight arrays based on the -! destination address with the source address as a secondary -! sorting criterion. the method is a standard heap sort. -! -! sort_add_v2 is identical to subroutine sort_add, but is moved into -! scrip_interface.ftn and converted to f90 format (line continuations) -! -!----------------------------------------------------------------------- - - implicit none - -!----------------------------------------------------------------------- -! -! Input and Output arrays -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), intent(inout), dimension(:) :: & - add1, & ! destination address array (num_links) - add2 ! source address array - - real (SCRIP_r8), intent(inout), dimension(:,:) :: & - weights ! remapping weights (num_wts, num_links) - -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4) :: & - num_links, & ! num of links for this mapping - num_wts, & ! num of weights for this mapping - add1_tmp, add2_tmp,& ! temp for addresses during swap - lvl, final_lvl, & ! level indexes for heap sort levels - chk_lvl1, chk_lvl2, max_lvl - - real (SCRIP_r8), dimension(SIZE(weights,DIM=1)) :: & - wgttmp ! temp for holding wts during swap - -!----------------------------------------------------------------------- -! -! determine total number of links to sort and number of weights -! -!----------------------------------------------------------------------- - - num_links = SIZE(add1) - num_wts = SIZE(weights, DIM=1) - -!----------------------------------------------------------------------- -! -! start at the lowest level (N/2) of the tree and sift lower -! values to the bottom of the tree, promoting the larger numbers -! -!----------------------------------------------------------------------- - - do lvl=num_links/2,1,-1 - - final_lvl = lvl - add1_tmp = add1(lvl) - add2_tmp = add2(lvl) - wgttmp(:) = weights(:,lvl) + subroutine SCRIP_driverExit(errorCode,errormsg) + + ! !DESCRIPTION: + ! This routine exits the SCRIP driver program. It first calls the + ! SCRIP error print function to print any errors encountered and then + ! exits the message environment before stopping. + ! + ! !USES: + + use SCRIP_KindsMod + + ! !INPUT PARAMETERS: + + integer (SCRIP_i4), intent(in) :: & + errorCode ! error flag to detect any errors encountered + + CHARACTER*(*), INTENT(IN) :: errormsg + !----------------------------------------------------------------------- + ! + ! call SCRIP error print function to output any logged errors that + ! were encountered during execution. Then stop. + ! + !----------------------------------------------------------------------- + + write(*,*)'error encountered : ',errorcode + write(*,*)errormsg + + stop + + !----------------------------------------------------------------------- + + end subroutine SCRIP_driverExit + + !####################################################################### + subroutine sort_add_v2(add1, add2, weights) + !####################################################################### + + !----------------------------------------------------------------------- + ! + ! this routine sorts address and weight arrays based on the + ! destination address with the source address as a secondary + ! sorting criterion. the method is a standard heap sort. + ! + ! sort_add_v2 is identical to subroutine sort_add, but is moved into + ! scrip_interface.ftn and converted to f90 format (line continuations) + ! + !----------------------------------------------------------------------- + + implicit none + + !----------------------------------------------------------------------- + ! + ! Input and Output arrays + ! + !----------------------------------------------------------------------- + + integer (SCRIP_i4), intent(inout), dimension(:) :: & + add1, & ! destination address array (num_links) + add2 ! source address array + + real (SCRIP_r8), intent(inout), dimension(:,:) :: & + weights ! remapping weights (num_wts, num_links) + + !----------------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------------- + + integer (SCRIP_i4) :: & + num_links, & ! num of links for this mapping + num_wts, & ! num of weights for this mapping + add1_tmp, add2_tmp,& ! temp for addresses during swap + lvl, final_lvl, & ! level indexes for heap sort levels + chk_lvl1, chk_lvl2, max_lvl + + real (SCRIP_r8), dimension(SIZE(weights,DIM=1)) :: & + wgttmp ! temp for holding wts during swap + + !----------------------------------------------------------------------- + ! + ! determine total number of links to sort and number of weights + ! + !----------------------------------------------------------------------- + + num_links = SIZE(add1) + num_wts = SIZE(weights, DIM=1) + + !----------------------------------------------------------------------- + ! + ! start at the lowest level (N/2) of the tree and sift lower + ! values to the bottom of the tree, promoting the larger numbers + ! + !----------------------------------------------------------------------- + + do lvl=num_links/2,1,-1 + + final_lvl = lvl + add1_tmp = add1(lvl) + add2_tmp = add2(lvl) + wgttmp(:) = weights(:,lvl) + + !*** + !*** loop until proper level is found for this link, or reach + !*** bottom + !*** + + sift_loop1: do !*** - !*** loop until proper level is found for this link, or reach - !*** bottom + !*** find the largest of the two daughters !*** - sift_loop1: do - - !*** - !*** find the largest of the two daughters - !*** - - chk_lvl1 = 2*final_lvl - chk_lvl2 = 2*final_lvl+1 - if (chk_lvl1 .EQ. num_links) chk_lvl2 = chk_lvl1 - - if ((add1(chk_lvl1) > add1(chk_lvl2)) .OR. & - ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. & - (add2(chk_lvl1) > add2(chk_lvl2)))) then - max_lvl = chk_lvl1 - else - max_lvl = chk_lvl2 - endif - - !*** - !*** if the parent is greater than both daughters, - !*** the correct level has been found - !*** - - if ((add1_tmp .GT. add1(max_lvl)) .OR. & - ((add1_tmp .EQ. add1(max_lvl)) .AND. & - (add2_tmp .GT. add2(max_lvl)))) then - add1(final_lvl) = add1_tmp - add2(final_lvl) = add2_tmp - weights(:,final_lvl) = wgttmp(:) - exit sift_loop1 - - !*** - !*** otherwise, promote the largest daughter and push - !*** down one level in the tree. if haven't reached - !*** the end of the tree, repeat the process. otherwise - !*** store last values and exit the loop - !*** - - else - add1(final_lvl) = add1(max_lvl) - add2(final_lvl) = add2(max_lvl) - weights(:,final_lvl) = weights(:,max_lvl) - - final_lvl = max_lvl - if (2*final_lvl > num_links) then - add1(final_lvl) = add1_tmp - add2(final_lvl) = add2_tmp - weights(:,final_lvl) = wgttmp(:) - exit sift_loop1 - endif - endif - end do sift_loop1 - end do - -!----------------------------------------------------------------------- -! -! now that the heap has been sorted, strip off the top (largest) -! value and promote the values below -! -!----------------------------------------------------------------------- - - do lvl=num_links,3,-1 + chk_lvl1 = 2*final_lvl + chk_lvl2 = 2*final_lvl+1 + if (chk_lvl1 .EQ. num_links) chk_lvl2 = chk_lvl1 + + if ((add1(chk_lvl1) > add1(chk_lvl2)) .OR. & + ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. & + (add2(chk_lvl1) > add2(chk_lvl2)))) then + max_lvl = chk_lvl1 + else + max_lvl = chk_lvl2 + endif !*** - !*** move the top value and insert it into the correct place + !*** if the parent is greater than both daughters, + !*** the correct level has been found !*** - add1_tmp = add1(lvl) - add1(lvl) = add1(1) + if ((add1_tmp .GT. add1(max_lvl)) .OR. & + ((add1_tmp .EQ. add1(max_lvl)) .AND. & + (add2_tmp .GT. add2(max_lvl)))) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop1 + + !*** + !*** otherwise, promote the largest daughter and push + !*** down one level in the tree. if haven't reached + !*** the end of the tree, repeat the process. otherwise + !*** store last values and exit the loop + !*** + + else + add1(final_lvl) = add1(max_lvl) + add2(final_lvl) = add2(max_lvl) + weights(:,final_lvl) = weights(:,max_lvl) + + final_lvl = max_lvl + if (2*final_lvl > num_links) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop1 + endif + endif + end do sift_loop1 + end do + + !----------------------------------------------------------------------- + ! + ! now that the heap has been sorted, strip off the top (largest) + ! value and promote the values below + ! + !----------------------------------------------------------------------- + + do lvl=num_links,3,-1 + + !*** + !*** move the top value and insert it into the correct place + !*** + + add1_tmp = add1(lvl) + add1(lvl) = add1(1) + + add2_tmp = add2(lvl) + add2(lvl) = add2(1) + + wgttmp(:) = weights(:,lvl) + weights(:,lvl) = weights(:,1) + + !*** + !*** as above this loop sifts the tmp values down until proper + !*** level is reached + !*** + + final_lvl = 1 + + sift_loop2: do - add2_tmp = add2(lvl) - add2(lvl) = add2(1) + !*** + !*** find the largest of the two daughters + !*** + + chk_lvl1 = 2*final_lvl + chk_lvl2 = 2*final_lvl+1 + if (chk_lvl2 >= lvl) chk_lvl2 = chk_lvl1 - wgttmp(:) = weights(:,lvl) - weights(:,lvl) = weights(:,1) + if ((add1(chk_lvl1) > add1(chk_lvl2)) .OR. & + ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. & + (add2(chk_lvl1) > add2(chk_lvl2)))) then + max_lvl = chk_lvl1 + else + max_lvl = chk_lvl2 + endif !*** - !*** as above this loop sifts the tmp values down until proper - !*** level is reached + !*** if the parent is greater than both daughters, + !*** the correct level has been found !*** - final_lvl = 1 - - sift_loop2: do - - !*** - !*** find the largest of the two daughters - !*** - - chk_lvl1 = 2*final_lvl - chk_lvl2 = 2*final_lvl+1 - if (chk_lvl2 >= lvl) chk_lvl2 = chk_lvl1 - - if ((add1(chk_lvl1) > add1(chk_lvl2)) .OR. & - ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. & - (add2(chk_lvl1) > add2(chk_lvl2)))) then - max_lvl = chk_lvl1 - else - max_lvl = chk_lvl2 - endif - - !*** - !*** if the parent is greater than both daughters, - !*** the correct level has been found - !*** - - if ((add1_tmp > add1(max_lvl)) .OR. & - ((add1_tmp == add1(max_lvl)) .AND. & - (add2_tmp > add2(max_lvl)))) then - add1(final_lvl) = add1_tmp - add2(final_lvl) = add2_tmp - weights(:,final_lvl) = wgttmp(:) - exit sift_loop2 - - !*** - !*** otherwise, promote the largest daughter and push - !*** down one level in the tree. if haven't reached - !*** the end of the tree, repeat the process. otherwise - !*** store last values and exit the loop - !*** - - else - add1(final_lvl) = add1(max_lvl) - add2(final_lvl) = add2(max_lvl) - weights(:,final_lvl) = weights(:,max_lvl) - - final_lvl = max_lvl - if (2*final_lvl >= lvl) then - add1(final_lvl) = add1_tmp - add2(final_lvl) = add2_tmp - weights(:,final_lvl) = wgttmp(:) - exit sift_loop2 - endif - endif - end do sift_loop2 - end do - - !*** - !*** swap the last two entries - !*** - - - add1_tmp = add1(2) - add1(2) = add1(1) - add1(1) = add1_tmp - - add2_tmp = add2(2) - add2(2) = add2(1) - add2(1) = add2_tmp - - wgttmp (:) = weights(:,2) - weights(:,2) = weights(:,1) - weights(:,1) = wgttmp (:) - -!####################################################################### + if ((add1_tmp > add1(max_lvl)) .OR. & + ((add1_tmp == add1(max_lvl)) .AND. & + (add2_tmp > add2(max_lvl)))) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop2 + + !*** + !*** otherwise, promote the largest daughter and push + !*** down one level in the tree. if haven't reached + !*** the end of the tree, repeat the process. otherwise + !*** store last values and exit the loop + !*** + + else + add1(final_lvl) = add1(max_lvl) + add2(final_lvl) = add2(max_lvl) + weights(:,final_lvl) = weights(:,max_lvl) + + final_lvl = max_lvl + if (2*final_lvl >= lvl) then + add1(final_lvl) = add1_tmp + add2(final_lvl) = add2_tmp + weights(:,final_lvl) = wgttmp(:) + exit sift_loop2 + endif + endif + end do sift_loop2 + end do + + !*** + !*** swap the last two entries + !*** + + + add1_tmp = add1(2) + add1(2) = add1(1) + add1(1) = add1_tmp + + add2_tmp = add2(2) + add2(2) = add2(1) + add2(1) = add2_tmp + + wgttmp (:) = weights(:,2) + weights(:,2) = weights(:,1) + weights(:,1) = wgttmp (:) + + !####################################################################### end subroutine sort_add_v2 -!####################################################################### - -!/ -!/ End of module SCRIP_INTERFACE -------------------------------------------- / -!/ - END MODULE SCRIP_INTERFACE - + !####################################################################### + !/ + !/ End of module SCRIP_INTERFACE -------------------------------------------- / + !/ +END MODULE SCRIP_INTERFACE diff --git a/model/src/SCRIP/scrip_iounitsmod.f90 b/model/src/SCRIP/scrip_iounitsmod.f90 index 1a4f3a345..9664fd622 100644 --- a/model/src/SCRIP/scrip_iounitsmod.f90 +++ b/model/src/SCRIP/scrip_iounitsmod.f90 @@ -1,384 +1,384 @@ !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| - module SCRIP_IOUnitsMod - -!BOP -! -! !MODULE: SCRIP_IOUnitsMod -! -! !DESCRIPTION: -! This module contains an I/O unit manager for tracking, assigning -! and reserving I/O unit numbers. -! -! There are three reserved I/O units set as parameters in this -! module. The default units for standard input (stdin), standard -! output (stdout) and standard error (stderr). These are currently -! set as units 5,6,6, respectively as that is the most commonly -! used among vendors. However, the user may change these if those -! default units are conflicting with other models or if the -! vendor is using different values. -! -! The maximum number of I/O units per node is currently set by -! the parameter SCRIP\_IOMaxUnits. -! -! !REFDOC: -! -! !REVISION HISTORY: -! SVN:$Id: SCRIP_IOUnitsMod.F90 83 2008-02-22 17:26:54Z pwjones $ - -! !USES: - - use SCRIP_KindsMod - - implicit none - private - save - -! !PUBLIC MEMBER FUNCTIONS: - - public :: SCRIP_IOUnitsGet, & - SCRIP_IOUnitsRelease, & - SCRIP_IOUnitsReserve, & - SCRIP_IOUnitsRedirect, & - SCRIP_IOUnitsFlush - -! !PUBLIC DATA MEMBERS: - - integer (SCRIP_i4), parameter, public :: & - SCRIP_stdin = 5, &! reserved unit for standard input - SCRIP_stdout = 6, &! reserved unit for standard output - SCRIP_stderr = 6 ! reserved unit for standard error - - ! common formats for writing to stdout, stderr - - character (9), parameter, public :: & - SCRIP_delimFormat = "(72('-'))" - - character (5), parameter, public :: & - SCRIP_blankFormat = "(' ')" - -!EOP -!BOC -!----------------------------------------------------------------------- -! -! private io unit manager variables -! -!----------------------------------------------------------------------- - - integer (SCRIP_i4), parameter :: & - SCRIP_IOUnitsMinUnits = 11, & ! do not use unit numbers below this - SCRIP_IOUnitsMaxUnits = 99 ! maximum number of open units - - logical (SCRIP_Logical) :: & - SCRIP_IOUnitsInitialized = .false. - - logical (SCRIP_Logical), dimension(SCRIP_IOUnitsMaxUnits) :: & - SCRIP_IOUnitsInUse ! flag=.true. if unit currently open - -!EOC -!*********************************************************************** +module SCRIP_IOUnitsMod + + !BOP + ! + ! !MODULE: SCRIP_IOUnitsMod + ! + ! !DESCRIPTION: + ! This module contains an I/O unit manager for tracking, assigning + ! and reserving I/O unit numbers. + ! + ! There are three reserved I/O units set as parameters in this + ! module. The default units for standard input (stdin), standard + ! output (stdout) and standard error (stderr). These are currently + ! set as units 5,6,6, respectively as that is the most commonly + ! used among vendors. However, the user may change these if those + ! default units are conflicting with other models or if the + ! vendor is using different values. + ! + ! The maximum number of I/O units per node is currently set by + ! the parameter SCRIP\_IOMaxUnits. + ! + ! !REFDOC: + ! + ! !REVISION HISTORY: + ! SVN:$Id: SCRIP_IOUnitsMod.F90 83 2008-02-22 17:26:54Z pwjones $ + + ! !USES: + + use SCRIP_KindsMod + + implicit none + private + save + + ! !PUBLIC MEMBER FUNCTIONS: + + public :: SCRIP_IOUnitsGet, & + SCRIP_IOUnitsRelease, & + SCRIP_IOUnitsReserve, & + SCRIP_IOUnitsRedirect, & + SCRIP_IOUnitsFlush + + ! !PUBLIC DATA MEMBERS: + + integer (SCRIP_i4), parameter, public :: & + SCRIP_stdin = 5, &! reserved unit for standard input + SCRIP_stdout = 6, &! reserved unit for standard output + SCRIP_stderr = 6 ! reserved unit for standard error + + ! common formats for writing to stdout, stderr + + character (9), parameter, public :: & + SCRIP_delimFormat = "(72('-'))" + + character (5), parameter, public :: & + SCRIP_blankFormat = "(' ')" + + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! private io unit manager variables + ! + !----------------------------------------------------------------------- + + integer (SCRIP_i4), parameter :: & + SCRIP_IOUnitsMinUnits = 11, & ! do not use unit numbers below this + SCRIP_IOUnitsMaxUnits = 99 ! maximum number of open units + + logical (SCRIP_Logical) :: & + SCRIP_IOUnitsInitialized = .false. + + logical (SCRIP_Logical), dimension(SCRIP_IOUnitsMaxUnits) :: & + SCRIP_IOUnitsInUse ! flag=.true. if unit currently open + + !EOC + !*********************************************************************** contains -!*********************************************************************** -!BOP -! !IROUTINE: SCRIP_IOUnitsGet -! !INTERFACE: + !*********************************************************************** + !BOP + ! !IROUTINE: SCRIP_IOUnitsGet + ! !INTERFACE: - subroutine SCRIP_IOUnitsGet(iunit) + subroutine SCRIP_IOUnitsGet(iunit) -! !DESCRIPTION: -! This routine returns the next available i/o unit and marks it as -! in use to prevent any later use. -! Note that {\em all} processors must call this routine even if only -! the master task is doing the i/o. This is necessary insure that -! the units remain synchronized for other parallel I/O functions. -! -! !REVISION HISTORY: -! same as module + ! !DESCRIPTION: + ! This routine returns the next available i/o unit and marks it as + ! in use to prevent any later use. + ! Note that {\em all} processors must call this routine even if only + ! the master task is doing the i/o. This is necessary insure that + ! the units remain synchronized for other parallel I/O functions. + ! + ! !REVISION HISTORY: + ! same as module -! !OUTPUT PARAMETERS: + ! !OUTPUT PARAMETERS: - integer (SCRIP_i4), intent(out) :: & - iunit ! next free i/o unit + integer (SCRIP_i4), intent(out) :: & + iunit ! next free i/o unit -!EOP -!BOC -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------------- - integer (SCRIP_i4) :: n ! dummy loop index + integer (SCRIP_i4) :: n ! dummy loop index - logical (SCRIP_Logical) :: alreadyInUse + logical (SCRIP_Logical) :: alreadyInUse -!----------------------------------------------------------------------- -! -! check to see if units initialized and initialize if necessary -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! check to see if units initialized and initialize if necessary + ! + !----------------------------------------------------------------------- - if (.not. SCRIP_IOUnitsInitialized) then + if (.not. SCRIP_IOUnitsInitialized) then SCRIP_IOUnitsInUse = .false. SCRIP_IOUnitsInUse(SCRIP_stdin) = .true. SCRIP_IOUnitsInUse(SCRIP_stdout) = .true. SCRIP_IOUnitsInUse(SCRIP_stderr) = .true. SCRIP_IOUnitsInitialized = .true. - endif + endif -!----------------------------------------------------------------------- -! -! find next free unit -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! find next free unit + ! + !----------------------------------------------------------------------- - srch_units: do n=SCRIP_IOUnitsMinUnits, SCRIP_IOUnitsMaxUnits + srch_units: do n=SCRIP_IOUnitsMinUnits, SCRIP_IOUnitsMaxUnits if (.not. SCRIP_IOUnitsInUse(n)) then ! I found one, I found one - !*** make sure not in use by library or calling routines - INQUIRE (unit=n,OPENED=alreadyInUse) - - if (.not. alreadyInUse) then - iunit = n ! return the free unit number - SCRIP_IOUnitsInUse(iunit) = .true. ! mark iunit as being in use - exit srch_units - else - !*** if inquire shows this unit in use, mark it as - !*** in use to prevent further queries - SCRIP_IOUnitsInUse(n) = .true. - endif + !*** make sure not in use by library or calling routines + INQUIRE (unit=n,OPENED=alreadyInUse) + + if (.not. alreadyInUse) then + iunit = n ! return the free unit number + SCRIP_IOUnitsInUse(iunit) = .true. ! mark iunit as being in use + exit srch_units + else + !*** if inquire shows this unit in use, mark it as + !*** in use to prevent further queries + SCRIP_IOUnitsInUse(n) = .true. + endif endif - end do srch_units + end do srch_units - if (iunit > SCRIP_IOUnitsMaxUnits) & - stop 'SCRIP_IOUnitsGet: No free units' + if (iunit > SCRIP_IOUnitsMaxUnits) & + stop 'SCRIP_IOUnitsGet: No free units' -!----------------------------------------------------------------------- -!EOC + !----------------------------------------------------------------------- + !EOC - end subroutine SCRIP_IOUnitsGet + end subroutine SCRIP_IOUnitsGet -!*********************************************************************** -!BOP -! !IROUTINE: SCRIP_IOUnitsRelease -! !INTERFACE: + !*********************************************************************** + !BOP + ! !IROUTINE: SCRIP_IOUnitsRelease + ! !INTERFACE: - subroutine SCRIP_IOUnitsRelease(iunit) + subroutine SCRIP_IOUnitsRelease(iunit) -! !DESCRIPTION: -! This routine releases an i/o unit (marks it as available). -! Note that {\em all} processors must call this routine even if only -! the master task is doing the i/o. This is necessary insure that -! the units remain synchronized for other parallel I/O functions. -! -! !REVISION HISTORY: -! same as module + ! !DESCRIPTION: + ! This routine releases an i/o unit (marks it as available). + ! Note that {\em all} processors must call this routine even if only + ! the master task is doing the i/o. This is necessary insure that + ! the units remain synchronized for other parallel I/O functions. + ! + ! !REVISION HISTORY: + ! same as module -! !INPUT PARAMETER: + ! !INPUT PARAMETER: - integer (SCRIP_i4), intent(in) :: & - iunit ! i/o unit to be released + integer (SCRIP_i4), intent(in) :: & + iunit ! i/o unit to be released -!EOP -!BOC -!----------------------------------------------------------------------- -! -! check for proper unit number -! -!----------------------------------------------------------------------- + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! check for proper unit number + ! + !----------------------------------------------------------------------- - if (iunit < 1 .or. iunit > SCRIP_IOUnitsMaxUnits) then + if (iunit < 1 .or. iunit > SCRIP_IOUnitsMaxUnits) then stop 'SCRIP_IOUnitsRelease: bad unit' - endif - -!----------------------------------------------------------------------- -! -! mark the unit as not in use -! -!----------------------------------------------------------------------- - - SCRIP_IOUnitsInUse(iunit) = .false. ! that was easy... - -!----------------------------------------------------------------------- -!EOC - - end subroutine SCRIP_IOUnitsRelease - -!*********************************************************************** -!BOP -! !IROUTINE: SCRIP_IOUnitsReserve -! !INTERFACE: - - subroutine SCRIP_IOUnitsReserve(iunit) - -! !DESCRIPTION: -! This routine marks an IO unit as in use to reserve its use -! for purposes outside of SCRIP IO. This is necessary for -! cases where you might be importing code developed elsewhere -! that performs its own I/O and open/closes units. -! Note that {\em all} processors must call this routine even if only -! the master task is doing the i/o. This is necessary insure that -! the units remains synchronized for other parallel I/O functions. -! -! !REVISION HISTORY: -! same as module - -! !INPUT PARAMETER: - - integer (SCRIP_i4), intent(in) :: & - iunit ! i/o unit to be reserved - -!EOP -!BOC -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - logical (SCRIP_Logical) :: alreadyInUse - -!----------------------------------------------------------------------- -! -! check for proper unit number -! -!----------------------------------------------------------------------- - - if (iunit < SCRIP_IOUnitsMinUnits .or. & - iunit > SCRIP_IOUnitsMaxUnits) then + endif + + !----------------------------------------------------------------------- + ! + ! mark the unit as not in use + ! + !----------------------------------------------------------------------- + + SCRIP_IOUnitsInUse(iunit) = .false. ! that was easy... + + !----------------------------------------------------------------------- + !EOC + + end subroutine SCRIP_IOUnitsRelease + + !*********************************************************************** + !BOP + ! !IROUTINE: SCRIP_IOUnitsReserve + ! !INTERFACE: + + subroutine SCRIP_IOUnitsReserve(iunit) + + ! !DESCRIPTION: + ! This routine marks an IO unit as in use to reserve its use + ! for purposes outside of SCRIP IO. This is necessary for + ! cases where you might be importing code developed elsewhere + ! that performs its own I/O and open/closes units. + ! Note that {\em all} processors must call this routine even if only + ! the master task is doing the i/o. This is necessary insure that + ! the units remains synchronized for other parallel I/O functions. + ! + ! !REVISION HISTORY: + ! same as module + + ! !INPUT PARAMETER: + + integer (SCRIP_i4), intent(in) :: & + iunit ! i/o unit to be reserved + + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------------- + + logical (SCRIP_Logical) :: alreadyInUse + + !----------------------------------------------------------------------- + ! + ! check for proper unit number + ! + !----------------------------------------------------------------------- + + if (iunit < SCRIP_IOUnitsMinUnits .or. & + iunit > SCRIP_IOUnitsMaxUnits) then stop 'SCRIP_IOUnitsReserve: invalid unit' - endif + endif -!----------------------------------------------------------------------- -! -! check to see if SCRIP already using this unit -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! check to see if SCRIP already using this unit + ! + !----------------------------------------------------------------------- - if (SCRIP_IOUnitsInUse(iunit)) then + if (SCRIP_IOUnitsInUse(iunit)) then stop 'SCRIP_IOUnitsReserve: unit already in use by SCRIP' - endif + endif -!----------------------------------------------------------------------- -! -! check to see if others already using this unit -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! check to see if others already using this unit + ! + !----------------------------------------------------------------------- - INQUIRE (unit=iunit, OPENED=alreadyInUse) - if (alreadyInUse) then + INQUIRE (unit=iunit, OPENED=alreadyInUse) + if (alreadyInUse) then stop 'SCRIP_IOUnitsReserve: unit already in use by others' - endif - -!----------------------------------------------------------------------- -! -! mark the unit as in use -! -!----------------------------------------------------------------------- - - SCRIP_IOUnitsInUse(iunit) = .true. - -!----------------------------------------------------------------------- -!EOC - - end subroutine SCRIP_IOUnitsReserve - -!*********************************************************************** -!BOP -! !IROUTINE: SCRIP_IOUnitsRedirect -! !INTERFACE: - - subroutine SCRIP_IOUnitsRedirect(iunit, filename) - -! !DESCRIPTION: -! This routine enables a user to redirect stdin, stdout, stderr to -! a file instead of to the terminal. It is only permitted for these -! special units. The SCRIP IO file operators should be used for -! normal I/O. -! Note that {\em all} processors must call this routine even if only -! the master task is doing the i/o. This is necessary insure that -! the units remains synchronized for other parallel I/O functions. -! -! !REVISION HISTORY: -! same as module - -! !INPUT PARAMETER: - - integer (SCRIP_i4), intent(in) :: & - iunit ! i/o unit to be redirected to file - - character (*), intent(in) :: & - filename ! filename, including path, to which - ! i/o should be directed - -!EOP -!BOC -!----------------------------------------------------------------------- -! -! check for proper unit number and open file -! -!----------------------------------------------------------------------- - - if (iunit == SCRIP_stdin) then ! open input file for stdin + endif + + !----------------------------------------------------------------------- + ! + ! mark the unit as in use + ! + !----------------------------------------------------------------------- + + SCRIP_IOUnitsInUse(iunit) = .true. + + !----------------------------------------------------------------------- + !EOC + + end subroutine SCRIP_IOUnitsReserve + + !*********************************************************************** + !BOP + ! !IROUTINE: SCRIP_IOUnitsRedirect + ! !INTERFACE: + + subroutine SCRIP_IOUnitsRedirect(iunit, filename) + + ! !DESCRIPTION: + ! This routine enables a user to redirect stdin, stdout, stderr to + ! a file instead of to the terminal. It is only permitted for these + ! special units. The SCRIP IO file operators should be used for + ! normal I/O. + ! Note that {\em all} processors must call this routine even if only + ! the master task is doing the i/o. This is necessary insure that + ! the units remains synchronized for other parallel I/O functions. + ! + ! !REVISION HISTORY: + ! same as module + + ! !INPUT PARAMETER: + + integer (SCRIP_i4), intent(in) :: & + iunit ! i/o unit to be redirected to file + + character (*), intent(in) :: & + filename ! filename, including path, to which + ! i/o should be directed + + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! check for proper unit number and open file + ! + !----------------------------------------------------------------------- + + if (iunit == SCRIP_stdin) then ! open input file for stdin open(unit=iunit, file=filename, status='old', form='formatted') - else if (iunit == SCRIP_stdout) then ! open output file for stdout + else if (iunit == SCRIP_stdout) then ! open output file for stdout open(unit=iunit, file=filename, status='unknown', form='formatted') - else if (iunit == SCRIP_stderr .and. SCRIP_stderr /= SCRIP_stdout) then + else if (iunit == SCRIP_stderr .and. SCRIP_stderr /= SCRIP_stdout) then ! open output file for stderr open(unit=iunit, file=filename, status='unknown', form='formatted') - else + else stop 'SCRIP_IOUnitsRedirect: invalid unit' - endif + endif -!----------------------------------------------------------------------- -!EOC + !----------------------------------------------------------------------- + !EOC - end subroutine SCRIP_IOUnitsRedirect + end subroutine SCRIP_IOUnitsRedirect -!*********************************************************************** -!BOP -! !IROUTINE: SCRIP_IOUnitsFlush -! !INTERFACE: + !*********************************************************************** + !BOP + ! !IROUTINE: SCRIP_IOUnitsFlush + ! !INTERFACE: - subroutine SCRIP_IOUnitsFlush(iunit) + subroutine SCRIP_IOUnitsFlush(iunit) -! !DESCRIPTION: -! This routine enables a user to flush the output from an IO unit -! (typically stdout) to force output when the system is buffering -! such output. Because this system function is system dependent, -! we only support this wrapper and users are welcome to insert the -! code relevant to their local machine. -! -! !REVISION HISTORY: -! same as module + ! !DESCRIPTION: + ! This routine enables a user to flush the output from an IO unit + ! (typically stdout) to force output when the system is buffering + ! such output. Because this system function is system dependent, + ! we only support this wrapper and users are welcome to insert the + ! code relevant to their local machine. + ! + ! !REVISION HISTORY: + ! same as module -! !INPUT PARAMETER: + ! !INPUT PARAMETER: - integer (SCRIP_i4), intent(in) :: & - iunit ! i/o unit to be flushed + integer (SCRIP_i4), intent(in) :: & + iunit ! i/o unit to be flushed -!EOP -!BOC -!----------------------------------------------------------------------- -! -! insert your system code here -! -!----------------------------------------------------------------------- + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! insert your system code here + ! + !----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!EOC + !----------------------------------------------------------------------- + !EOC - end subroutine SCRIP_IOUnitsFlush + end subroutine SCRIP_IOUnitsFlush -!*********************************************************************** + !*********************************************************************** - end module SCRIP_IOUnitsMod +end module SCRIP_IOUnitsMod !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/model/src/SCRIP/scrip_kindsmod.f90 b/model/src/SCRIP/scrip_kindsmod.f90 index 7144f0d43..8e143097d 100644 --- a/model/src/SCRIP/scrip_kindsmod.f90 +++ b/model/src/SCRIP/scrip_kindsmod.f90 @@ -1,54 +1,54 @@ !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| - module SCRIP_KindsMod - -!BOP -! !MODULE: SCRIP_KindsMod -! -! !DESCRIPTION: -! This module defines default numerical data types for all common data -! types like integer, character, logical, real4 and real8. -! -! !USERDOC: -! Users should not need to adjust anything in this module. If various -! character strings like long paths to files exceed the default -! character length, the default value may be increased. -! -! !REFDOC: -! This module is supplied to provide consistent data representation -! across machine architectures. It is meant to replace the old -! Fortran double precision and real *X declarations that were -! implementation-specific. -! Users should not need to adjust anything in this module. If various -! character strings like long paths to files exceed the default -! character length, the default value may be increased. -! -! !REVISION HISTORY: -! SVN:$Id: SCRIP_KindsMod.F90 82 2008-02-14 19:36:07Z pwjones $ - -! !USES: -! uses no other modules - - implicit none - private - save - -! !DEFINED PARAMETERS: - - integer, parameter, public :: & - SCRIP_CharLength = 100 ,& - SCRIP_Logical = kind(.true.) ,& - SCRIP_i4 = selected_int_kind(6) ,& - SCRIP_i8 = selected_int_kind(13) ,& - SCRIP_r4 = selected_real_kind(6) ,& - SCRIP_r8 = selected_real_kind(13) ,& - SCRIP_r16 = selected_real_kind(26) - -!EOP -!BOC -!EOC -!*********************************************************************** - - end module SCRIP_KindsMod +module SCRIP_KindsMod + + !BOP + ! !MODULE: SCRIP_KindsMod + ! + ! !DESCRIPTION: + ! This module defines default numerical data types for all common data + ! types like integer, character, logical, real4 and real8. + ! + ! !USERDOC: + ! Users should not need to adjust anything in this module. If various + ! character strings like long paths to files exceed the default + ! character length, the default value may be increased. + ! + ! !REFDOC: + ! This module is supplied to provide consistent data representation + ! across machine architectures. It is meant to replace the old + ! Fortran double precision and real *X declarations that were + ! implementation-specific. + ! Users should not need to adjust anything in this module. If various + ! character strings like long paths to files exceed the default + ! character length, the default value may be increased. + ! + ! !REVISION HISTORY: + ! SVN:$Id: SCRIP_KindsMod.F90 82 2008-02-14 19:36:07Z pwjones $ + + ! !USES: + ! uses no other modules + + implicit none + private + save + + ! !DEFINED PARAMETERS: + + integer, parameter, public :: & + SCRIP_CharLength = 100 ,& + SCRIP_Logical = kind(.true.) ,& + SCRIP_i4 = selected_int_kind(6) ,& + SCRIP_i8 = selected_int_kind(13) ,& + SCRIP_r4 = selected_real_kind(6) ,& + SCRIP_r8 = selected_real_kind(13) ,& + SCRIP_r16 = selected_real_kind(26) + + !EOP + !BOC + !EOC + !*********************************************************************** + +end module SCRIP_KindsMod !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/model/src/SCRIP/scrip_netcdfmod.f90 b/model/src/SCRIP/scrip_netcdfmod.f90 index f70719c65..036b6a3ec 100644 --- a/model/src/SCRIP/scrip_netcdfmod.f90 +++ b/model/src/SCRIP/scrip_netcdfmod.f90 @@ -1,120 +1,120 @@ !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| - module SCRIP_NetCDFMod - -!BOP -! !MODULE: SCRIP_NetCDFMod -! -! !DESCRIPTION: -! This module contains netCDF error handling functions and the -! use of the netCDF module for all netCDF functions. -! -! !REVISION HISTORY: -! SVN:$Id: $ -! -! !USES: - - use SCRIP_KindsMod - use SCRIP_ErrorMod - use netcdf - - implicit none - private - save - -! !DEFINED PARAMETERS: - -! !PUBLIC MEMBER FUNCTIONS: - - public :: SCRIP_NetcdfErrorCheck - -!EOP -!BOC -!EOC -!*********************************************************************** - - contains - -!*********************************************************************** -!BOP -! !IROUTINE: SCRIP_NetcdfErrorCheck -! !INTERFACE: - - function SCRIP_NetcdfErrorCheck(netcdfStat, errorCode, rtnName, & - errorMsg) - -! !DESCRIPTION: -! This routine checks netCDF status flags from netCDF routines. -! On error, it adds an error message to the error log and returns -! both a true value to the calling routines as well as setting the -! error code to fail. It is used in the same manner is the -! SCRIP\_ErrorCheck function. -! -! !REVISION HISTORY: -! same as module - -! !OUTPUT PARAMETERS: - - logical (SCRIP_logical) :: & - SCRIP_NetcdfErrorCheck - - integer (SCRIP_i4), intent(out) :: & - errorCode ! returned SCRIP error flag - -! !INPUT PARAMETERS: - - integer (SCRIP_i4), intent(in) :: & - netcdfStat ! status flag from netCDF call - - character (*), intent(in) :: & - rtnName, &! name of calling routine - errorMsg ! error message for logging - -!EOP -!BOC -!----------------------------------------------------------------------- -! -! local variables -! -!----------------------------------------------------------------------- - - character (SCRIP_charLength) :: & - ncErrMsg ! netCDF error message - -!----------------------------------------------------------------------- -! -! if no error, return false and a successful errorCode -! -!----------------------------------------------------------------------- - - if (netcdfStat == NF90_NOERR) then +module SCRIP_NetCDFMod + + !BOP + ! !MODULE: SCRIP_NetCDFMod + ! + ! !DESCRIPTION: + ! This module contains netCDF error handling functions and the + ! use of the netCDF module for all netCDF functions. + ! + ! !REVISION HISTORY: + ! SVN:$Id: $ + ! + ! !USES: + + use SCRIP_KindsMod + use SCRIP_ErrorMod + use netcdf + + implicit none + private + save + + ! !DEFINED PARAMETERS: + + ! !PUBLIC MEMBER FUNCTIONS: + + public :: SCRIP_NetcdfErrorCheck + + !EOP + !BOC + !EOC + !*********************************************************************** + +contains + + !*********************************************************************** + !BOP + ! !IROUTINE: SCRIP_NetcdfErrorCheck + ! !INTERFACE: + + function SCRIP_NetcdfErrorCheck(netcdfStat, errorCode, rtnName, & + errorMsg) + + ! !DESCRIPTION: + ! This routine checks netCDF status flags from netCDF routines. + ! On error, it adds an error message to the error log and returns + ! both a true value to the calling routines as well as setting the + ! error code to fail. It is used in the same manner is the + ! SCRIP\_ErrorCheck function. + ! + ! !REVISION HISTORY: + ! same as module + + ! !OUTPUT PARAMETERS: + + logical (SCRIP_logical) :: & + SCRIP_NetcdfErrorCheck + + integer (SCRIP_i4), intent(out) :: & + errorCode ! returned SCRIP error flag + + ! !INPUT PARAMETERS: + + integer (SCRIP_i4), intent(in) :: & + netcdfStat ! status flag from netCDF call + + character (*), intent(in) :: & + rtnName, &! name of calling routine + errorMsg ! error message for logging + + !EOP + !BOC + !----------------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------------- + + character (SCRIP_charLength) :: & + ncErrMsg ! netCDF error message + + !----------------------------------------------------------------------- + ! + ! if no error, return false and a successful errorCode + ! + !----------------------------------------------------------------------- + + if (netcdfStat == NF90_NOERR) then errorCode = SCRIP_Success SCRIP_NetcdfErrorCheck = .false. -!----------------------------------------------------------------------- -! -! if an error is detected, return a true value and call the SCRIP -! error handlers to log the error. Log both the netCDF error msg -! as well as the error passed by the calling routine. -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! if an error is detected, return a true value and call the SCRIP + ! error handlers to log the error. Log both the netCDF error msg + ! as well as the error passed by the calling routine. + ! + !----------------------------------------------------------------------- - else + else SCRIP_NetcdfErrorCheck = .true. ncErrMsg = nf90_strerror(netcdfStat) call SCRIP_ErrorSet(errorCode, rtnName, ncErrMsg) call SCRIP_ErrorSet(errorCode, rtnName, errorMsg) - endif + endif -!----------------------------------------------------------------------- -!EOC + !----------------------------------------------------------------------- + !EOC - end function SCRIP_NetcdfErrorCheck + end function SCRIP_NetcdfErrorCheck -!*********************************************************************** + !*********************************************************************** - end module SCRIP_NetCDFMod +end module SCRIP_NetCDFMod !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/model/src/SCRIP/scrip_remap_conservative.f b/model/src/SCRIP/scrip_remap_conservative.f index 0b330b0b9..4bbc748c8 100644 --- a/model/src/SCRIP/scrip_remap_conservative.f +++ b/model/src/SCRIP/scrip_remap_conservative.f @@ -1,9 +1,9 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! this module contains necessary routines for computing addresses -! and weights for a conservative interpolation between any two -! grids on a sphere. the weights are computed by performing line -! integrals around all overlap regions of the two grids. see +! and weights for a conservative interpolation between any two +! grids on a sphere. the weights are computed by performing line +! integrals around all overlap regions of the two grids. see ! Dukowicz and Kodis, SIAM J. Sci. Stat. Comput. 8, 305 (1987) and ! Jones, P.W. Monthly Weather Review (submitted). ! @@ -11,12 +11,12 @@ ! ! CVS:$Id: remap_conserv.f,v 1.10 2001/08/21 21:05:13 pwjones Exp $ ! -! Copyright (c) 1997, 1998 the Regents of the University of +! Copyright (c) 1997, 1998 the Regents of the University of ! California. ! -! This software and ancillary information (herein called software) -! called SCRIP is made available under the terms described here. -! The software has been approved for release with associated +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated ! LA-CC Number 98-45. ! ! Unless otherwise indicated, this software has been authored @@ -31,10 +31,10 @@ ! any liability or responsibility for the use of this software. ! ! If software is modified to produce derivative works, such modified -! software should be clearly marked, so as not to confuse it with +! software should be clearly marked, so as not to confuse it with ! the version available from Los Alamos National Laboratory. ! -! This code has been modified from the version available from +! This code has been modified from the version available from ! Los Alamos National Laboratory, for the purpose of running it ! within WW3. Primary modifications: ! - renamed many variables to be unique across the code @@ -44,15 +44,15 @@ ! - phi_or_theta = 2 instead of phi_or_theta = 1 (important!) ! !*********************************************************************** -! Modifications introduced by M. Dutour (MD) for +! Modifications introduced by M. Dutour (MD) for ! running with WAVEWATCH III ... see below ! -! +! ! BE CAREFUL ABOUT EXPLICIT INITIALIZATION OF VARIABLES IN ! MULTI-THREADED VERSION OF THE CODE - INLINE INITIALIZATION OF ! A VARIABLE IN FORTRAN 90/95 MAKES THE VARIABLE IMPLICITLY STATIC. ! OPENMP FORCES _ALL_ FORTRAN IMPLEMENTATIONS TO MAKE THE VARIABLE -! STATIC (OR OF THE TYPE SAVE) IF IT IS INITIALIZED IN THE +! STATIC (OR OF THE TYPE SAVE) IF IT IS INITIALIZED IN THE ! DECLARATION LINE ! ! @@ -77,23 +77,23 @@ module scrip_remap_conservative !............These are all local variables that had the "save" attribute !............in the standard version of SCRIP - integer (SCRIP_i4), save :: + integer (SCRIP_i4), save :: & avoid_pole_count = 0 ! count attempts to avoid pole - real (SCRIP_r8), save :: + real (SCRIP_r8), save :: & avoid_pole_offset = tiny ! endpoint offset to avoid pole integer (SCRIP_i4), dimension(:,:), allocatable, save :: & link_add1, ! min,max link add to restrict search & link_add2 ! min,max link add to restrict search - logical (SCRIP_logical), save :: + logical (SCRIP_logical), save :: & first_call_store_link_cnsrv = .true. logical (SCRIP_logical), save :: & first_call_locate_segstart= .true. - integer (SCRIP_i4), save :: + integer (SCRIP_i4), save :: & last_cell_locate_segstart=0, ! save the search parameters & last_cell_grid_num_locate_segstart=0, ! if unchanged, reuse ! search lists @@ -101,10 +101,10 @@ module scrip_remap_conservative integer (SCRIP_i4), save :: & num_srch_cells_locate_segstart=0, - & srch_corners_locate_segstart ! number of corners for + & srch_corners_locate_segstart ! number of corners for ! each cell - integer (SCRIP_i4), dimension(:), allocatable, save :: + integer (SCRIP_i4), dimension(:), allocatable, save :: & srch_add_locate_segstart ! global address of cells ! in srch arrays @@ -117,11 +117,11 @@ module scrip_remap_conservative real(SCRIP_r8), dimension(:), allocatable, save :: & srch_center_lat_locate_segstart,! lat of center of srch cells & srch_center_lon_locate_segstart ! lon of center of srch cells - + logical (SCRIP_logical), save :: & first_call_locate_point= .true. - integer (SCRIP_i4), save :: + integer (SCRIP_i4), save :: & last_cell_locate_point=0, ! save the search parameters & last_cell_grid_num_locate_point=0, ! if unchanged, reuse ! search lists @@ -131,7 +131,7 @@ module scrip_remap_conservative & num_srch_cell_locate_points=0, & srch_corners_locate_point ! number of corners for each cell - integer (SCRIP_i4), dimension(:), allocatable, save :: + integer (SCRIP_i4), dimension(:), allocatable, save :: & srch_add_locate_point ! global address of cells in ! srch arrays @@ -156,16 +156,16 @@ module scrip_remap_conservative ! search cells real (SCRIP_r8), dimension(:,:), allocatable, save :: - & srch_corner_lat_loc_get_srch_cells, + & srch_corner_lat_loc_get_srch_cells, & srch_corner_lon_loc_get_srch_cells - + real (SCRIP_r8), dimension(:), allocatable, save :: & srch_center_lat_loc_get_srch_cells, & srch_center_lon_loc_get_srch_cells integer (SCRIP_i4), save :: - & last_cell_add_get_srch_cells, - & last_cell_grid_num_get_srch_cells, + & last_cell_add_get_srch_cells, + & last_cell_grid_num_get_srch_cells, & last_srch_grid_num_get_srch_cells logical (SCRIP_logical), save :: @@ -177,13 +177,13 @@ module scrip_remap_conservative logical (SCRIP_logical), private :: is_master ! module's equivalent of "l_master" - integer (SCRIP_i4), save :: + integer (SCRIP_i4), save :: & last_cell_find_adj_cell, & last_cell_grid_num_find_adj_cell, - & num_srch_cells_find_adj_cell, + & num_srch_cells_find_adj_cell, & srch_corners_find_adj_cell - integer (SCRIP_i4), dimension(:), allocatable, save :: + integer (SCRIP_i4), dimension(:), allocatable, save :: & srch_add_find_adj_cell real (SCRIP_r8), dimension(:,:), allocatable, save :: & srch_corner_lat_find_adj_cell, srch_corner_lon_find_adj_cell @@ -201,7 +201,7 @@ module scrip_remap_conservative C$OMP& srch_corner_lat_loc_get_srch_cells, C$OMP& srch_corner_lon_loc_get_srch_cells, C$OMP& srch_center_lat_loc_get_srch_cells, -C$OMP& srch_center_lon_loc_get_srch_cells) +C$OMP& srch_center_lon_loc_get_srch_cells) C$OMP THREADPRIVATE(first_call_locate_segstart, C$OMP& last_cell_locate_segstart, @@ -254,7 +254,7 @@ subroutine remap_conserv(l_master, l_test) logical(SCRIP_Logical), intent(in) :: l_master ! Am I the master ! processor (do I/O)? - logical(SCRIP_Logical), intent(in) :: l_test ! Whether to + logical(SCRIP_Logical), intent(in) :: l_test ! Whether to !include test output !----------------------------------------------------------------------- @@ -263,13 +263,13 @@ subroutine remap_conserv(l_master, l_test) ! !----------------------------------------------------------------------- - integer (SCRIP_i4), parameter :: + integer (SCRIP_i4), parameter :: & phi_or_theta = 2 ! integrate w.r.t. phi (1) or theta (2) - - integer (SCRIP_i4) :: + + integer (SCRIP_i4) :: & i, inext, ! - & n, nwgt, + & n, nwgt, & grid1_add, ! Current linear address for grid1 cell & grid2_add, ! Current linear address for grid2 cell & grid_num, ! Index (1,2) of grid that we are @@ -284,7 +284,7 @@ subroutine remap_conserv(l_master, l_test) real (SCRIP_r8) :: & norm_factor ! factor for normalizing wts - real (SCRIP_r8), dimension(6) :: + real (SCRIP_r8), dimension(6) :: & weights ! Weights array real (SCRIP_r8) :: @@ -299,7 +299,7 @@ subroutine remap_conserv(l_master, l_test) real (SCRIP_r8), dimension(:), allocatable :: & reldiff, ! Relative difference in computed ! and true area - & ref_area ! Area of cell as computed by direct + & ref_area ! Area of cell as computed by direct ! integration around its boundaries ! call OMP_SET_DYNAMIC(.FALSE.) @@ -311,7 +311,7 @@ subroutine remap_conserv(l_master, l_test) !----------------------------------------------------------------------- is_master=l_master ! set module variable using subroutine input - ! argument variable. + ! argument variable. ! Use the former subsequently. if(is_master)print *,'grid1 sweep' @@ -321,9 +321,9 @@ subroutine remap_conserv(l_master, l_test) if (grid2_size > 500000) then progint = 1000 elseif (grid2_size > 250000) then - progint = 2000 + progint = 2000 elseif (grid2_size > 100000) then - progint = 5000 + progint = 5000 else progint = 10000 endif @@ -335,7 +335,7 @@ subroutine remap_conserv(l_master, l_test) C$OMP PARALLEL DEFAULT(SHARED) PRIVATE(grid1_add) NUM_THREADS(nthreads) -C$OMP DO SCHEDULE(DYNAMIC) +C$OMP DO SCHEDULE(DYNAMIC) do grid1_add = 1,grid1_size @@ -364,9 +364,9 @@ subroutine remap_conserv(l_master, l_test) if (grid1_size > 500000) then progint = 1000 elseif (grid1_size > 250000) then - progint = 2000 + progint = 2000 elseif (grid1_size > 100000) then - progint = 5000 + progint = 5000 else progint = 10000 endif @@ -400,7 +400,7 @@ subroutine remap_conserv(l_master, l_test) ! ! correct for situations where N/S pole not explicitly included in ! grid (i.e. as a grid corner point). if pole is missing from only -! one grid, need to correct only the area and centroid of that +! one grid, need to correct only the area and centroid of that ! grid. if missing from both, do complete weight calculation. ! This is necessary only when integrating w.r.t. phi (longitude) ! @@ -415,38 +415,38 @@ subroutine remap_conserv(l_master, l_test) weights(4) = pi2 weights(5) = pi*pi weights(6) = zero - + if (grid1_npole_cell /=0) then - grid1_area(grid1_npole_cell) = grid1_area(grid1_npole_cell) + grid1_area(grid1_npole_cell) = grid1_area(grid1_npole_cell) & + weights(1) - grid1_centroid_lat(grid1_npole_cell) = + grid1_centroid_lat(grid1_npole_cell) = & grid1_centroid_lat(grid1_npole_cell) + weights(2) grid1_centroid_lon(grid1_npole_cell) = & grid1_centroid_lon(grid1_npole_cell) + weights(3) endif - + if (grid2_npole_cell /=0) then - grid2_area(grid2_npole_cell) = grid2_area(grid2_npole_cell) + grid2_area(grid2_npole_cell) = grid2_area(grid2_npole_cell) & + weights(num_wts+1) - grid2_centroid_lat(grid2_npole_cell) = - & grid2_centroid_lat(grid2_npole_cell) + + grid2_centroid_lat(grid2_npole_cell) = + & grid2_centroid_lat(grid2_npole_cell) + & weights(num_wts+2) grid2_centroid_lon(grid2_npole_cell) = - & grid2_centroid_lon(grid2_npole_cell) + + & grid2_centroid_lon(grid2_npole_cell) + & weights(num_wts+3) endif - + if (grid1_npole_cell /= 0 .and. grid2_npole_cell /=0) then - call store_link_cnsrv(grid1_npole_cell, + call store_link_cnsrv(grid1_npole_cell, & grid2_npole_cell, weights) - - grid1_frac(grid1_npole_cell) = grid1_frac(grid1_npole_cell) + + grid1_frac(grid1_npole_cell) = grid1_frac(grid1_npole_cell) & + weights(1) - grid2_frac(grid2_npole_cell) = grid2_frac(grid2_npole_cell) + grid2_frac(grid2_npole_cell) = grid2_frac(grid2_npole_cell) & + weights(num_wts+1) endif - + !*** South Pole weights(1) = pi2 weights(2) = -pi*pi @@ -454,42 +454,42 @@ subroutine remap_conserv(l_master, l_test) weights(4) = pi2 weights(5) = -pi*pi weights(6) = zero - + if (grid1_spole_cell /=0) then - grid1_area(grid1_spole_cell) = grid1_area(grid1_spole_cell) + grid1_area(grid1_spole_cell) = grid1_area(grid1_spole_cell) & + weights(1) - grid1_centroid_lat(grid1_spole_cell) = + grid1_centroid_lat(grid1_spole_cell) = & grid1_centroid_lat(grid1_spole_cell) + weights(2) grid1_centroid_lon(grid1_spole_cell) = & grid1_centroid_lon(grid1_spole_cell) + weights(3) endif - + if (grid2_spole_cell /=0) then - grid2_area(grid2_spole_cell) = grid2_area(grid2_spole_cell) + grid2_area(grid2_spole_cell) = grid2_area(grid2_spole_cell) & + weights(num_wts+1) - grid2_centroid_lat(grid2_spole_cell) = - & grid2_centroid_lat(grid2_spole_cell) + + grid2_centroid_lat(grid2_spole_cell) = + & grid2_centroid_lat(grid2_spole_cell) + & weights(num_wts+2) grid2_centroid_lon(grid2_spole_cell) = - & grid2_centroid_lon(grid2_spole_cell) + + & grid2_centroid_lon(grid2_spole_cell) + & weights(num_wts+3) endif if (grid1_spole_cell /= 0 .and. grid2_spole_cell /=0) then - call store_link_cnsrv(grid1_spole_cell, + call store_link_cnsrv(grid1_spole_cell, & grid2_spole_cell, weights) - - grid1_frac(grid1_spole_cell) = grid1_frac(grid1_spole_cell) + + grid1_frac(grid1_spole_cell) = grid1_frac(grid1_spole_cell) & + weights(1) - grid2_frac(grid2_spole_cell) = grid2_frac(grid2_spole_cell) + grid2_frac(grid2_spole_cell) = grid2_frac(grid2_spole_cell) & + weights(num_wts+1) endif endif - + if(is_master)print *, 'Grid sweeps completed' - + !----------------------------------------------------------------------- ! @@ -663,8 +663,8 @@ subroutine remap_conserv(l_master, l_test) if ((phi_or_theta .eq. 1 .and. beglon .eq. endlon) .or. & (phi_or_theta .eq. 2 .and. beglat .eq. endlat)) cycle - call line_integral(phi_or_theta, weights, num_wts, beglon, - & endlon, beglat, endlat, grid1_center_lat(n), + call line_integral(phi_or_theta, weights, num_wts, beglon, + & endlon, beglat, endlat, grid1_center_lat(n), & grid1_center_lon(n), grid1_center_lat(n), & grid1_center_lon(n)) @@ -683,18 +683,18 @@ subroutine remap_conserv(l_master, l_test) weights(1) = pi2 if (grid1_npole_cell /=0) then - ref_area(grid1_npole_cell) = ref_area(grid1_npole_cell) + ref_area(grid1_npole_cell) = ref_area(grid1_npole_cell) & + weights(1) endif - + !*** South Pole weights(1) = pi2 - + if (grid1_spole_cell /=0) then - ref_area(grid1_spole_cell) = ref_area(grid1_spole_cell) + ref_area(grid1_spole_cell) = ref_area(grid1_spole_cell) & + weights(1) endif - + endif @@ -713,7 +713,7 @@ subroutine remap_conserv(l_master, l_test) maxrd_true = ref_area(n) endif end do - + ave_reldiff = ave_reldiff/grid1_size if(is_master.and.l_test)then @@ -727,7 +727,7 @@ subroutine remap_conserv(l_master, l_test) & max_reldiff print *, 'Max rel. diff. is in cell ',maxrd_cell print *, 'Computed Area: ', maxrd_area - print *, 'Reference Area: ',maxrd_true + print *, 'Reference Area: ',maxrd_true print * endif @@ -738,7 +738,7 @@ subroutine remap_conserv(l_master, l_test) allocate(ref_area(grid2_size)) allocate(reldiff(grid2_size)) -C$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads) +C$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads) C$OMP& PRIVATE(n, i, inext, beglat, beglon, endlat, endlon, weights) C$OMP DO SCHEDULE(DYNAMIC) @@ -763,8 +763,8 @@ subroutine remap_conserv(l_master, l_test) if ((phi_or_theta .eq. 1 .and. beglon .eq. endlon) .or. & (phi_or_theta .eq. 2 .and. beglat .eq. endlat)) cycle - call line_integral(phi_or_theta, weights, num_wts, beglon, - & endlon, beglat, endlat, grid2_center_lat(n), + call line_integral(phi_or_theta, weights, num_wts, beglon, + & endlon, beglat, endlat, grid2_center_lat(n), & grid2_center_lon(n), grid2_center_lat(n), & grid2_center_lon(n)) @@ -781,20 +781,20 @@ subroutine remap_conserv(l_master, l_test) !*** North Pole weights(1) = pi2 - + if (grid2_npole_cell /=0) then - ref_area(grid2_npole_cell) = ref_area(grid2_npole_cell) + ref_area(grid2_npole_cell) = ref_area(grid2_npole_cell) & + weights(1) endif - + !*** South Pole weights(1) = pi2 - + if (grid2_spole_cell /=0) then - ref_area(grid2_spole_cell) = ref_area(grid2_spole_cell) + ref_area(grid2_spole_cell) = ref_area(grid2_spole_cell) & + weights(1) endif - + endif @@ -824,7 +824,7 @@ subroutine remap_conserv(l_master, l_test) & max_reldiff print *, 'Max rel. diff. is in cell ',maxrd_cell print *, 'Computed Area: ', maxrd_area - print *, 'Reference Area: ',maxrd_true + print *, 'Reference Area: ',maxrd_true print * endif @@ -838,8 +838,8 @@ subroutine remap_conserv(l_master, l_test) endif !*** - !*** In the following code, gridN_centroid_lat is being used to - !*** store running tallies of the cell areas - so it is a + !*** In the following code, gridN_centroid_lat is being used to + !*** store running tallies of the cell areas - so it is a !*** misnomer used to avoid allocation of a new variable !*** @@ -863,20 +863,20 @@ subroutine remap_conserv(l_master, l_test) end do ! count warnings about weights that will be excluded - if (grid2_frac(grid2_add).gt.frac_lowest .and. + if (grid2_frac(grid2_add).gt.frac_lowest .and. & grid2_frac(grid2_add).lt.frac_highest .and. is_master) then if ( (wts_map1(1,n) < wt_lowest) )then icount=icount+1 ! print statements that were here have been moved to another routine... endif - if (norm_opt /= norm_opt_none .and. wts_map1(1,n) > + if (norm_opt /= norm_opt_none .and. wts_map1(1,n) > & wt_highest)then icount=icount+1 ! print statements that were here have been moved to another routine... endif endif C$OMP CRITICAL - grid2_centroid_lat(grid2_add) = + grid2_centroid_lat(grid2_add) = & grid2_centroid_lat(grid2_add) + wts_map1(1,n) C$OMP END CRITICAL @@ -891,7 +891,7 @@ subroutine remap_conserv(l_master, l_test) & wts_map2(1,n) endif C$OMP CRITICAL - grid1_centroid_lat(grid1_add) = + grid1_centroid_lat(grid1_add) = & grid1_centroid_lat(grid1_add) + wts_map2(1,n) C$OMP END CRITICAL endif @@ -911,7 +911,7 @@ subroutine remap_conserv(l_master, l_test) !*** the following code will generate errors even though nothing !*** is wrong (grid1_centroid_lat or grid2_centroid_lat are never !*** updated in the above loop) - !*** + !*** do n=1,grid2_size select case(norm_opt) @@ -926,7 +926,7 @@ subroutine remap_conserv(l_master, l_test) norm_factor = grid2_area(n) endif end select -! if (abs(grid2_centroid_lat(n)-norm_factor) > .01 +! if (abs(grid2_centroid_lat(n)-norm_factor) > .01 ! & .and. is_master) then ! print *,'Warning: sum of wts for map1 ',n, ! & grid2_centroid_lat(n),norm_factor @@ -977,14 +977,14 @@ end subroutine remap_conserv !*********************************************************************** - subroutine cellblock_integrate(ibegin, iend, grid_num, - & phi_or_theta) + subroutine cellblock_integrate(ibegin, iend, grid_num, + & phi_or_theta) integer (SCRIP_i4) :: ibegin, iend, grid_num, phi_or_theta integer (SCRIP_i4) :: cell_add - + do cell_add = ibegin, iend call cell_integrate(cell_add, grid_num, phi_or_theta) @@ -1016,7 +1016,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) ! Input variables ! !----------------------------------------------------------------------- - + integer (SCRIP_i4) :: & cell_add, ! cell to be processed & grid_num, ! grid that the cell belongs to @@ -1035,22 +1035,22 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) ! to prevent infinite loop - integer (SCRIP_i4) :: + integer (SCRIP_i4) :: & i, inext, ! & j, jnext, ! generic counters & ic, k, ns, ! & n, next_n, ! & nwgt, it, ! - & oppcell_add, ! Cell from opposite grid we are + & oppcell_add, ! Cell from opposite grid we are ! intersecting & opp_grid_num, ! Index of opposite grid (2,1) & min_add, ! addresses for restricting search of & max_add, ! destination grid - & corner, ! corner of cell that segment starts + & corner, ! corner of cell that segment starts ! from & next_corn, ! corner of cell that segment ends on & nseg, ! number of segments to use to represent - ! edges near the pole + ! edges near the pole & num_subseg, ! number of subsegments & bedgeid1, ! & bedgeid2, ! ID of edge that a point is on @@ -1058,21 +1058,21 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) & intedge, ! ID of intersected edge & last_add, ! Address of last cell we were in & next_add, ! Address of next cell we will go into - & adj_add ! Address of cell adjacent to current + & adj_add ! Address of cell adjacent to current ! one - logical (SCRIP_logical) :: + logical (SCRIP_logical) :: & lcoinc, ! Are segments coincident? & lrevers, ! Are we integrating segment in reverse? - & lboundary1, + & lboundary1, & lboundary2, ! Is point is on cell boundary? - & lboundary3, + & lboundary3, & last_lboundary, ! Is last point is on cell bdry? & loutside, ! Is point outside the grid? & lthresh, ! Has segment crossed threshold? - & srch_success, ! Was search for segment start + & srch_success, ! Was search for segment start ! successful? - & intrsct_success, ! Was intersection of segment with + & intrsct_success, ! Was intersection of segment with ! opposite grid successful? & inpoly, ! Is point is in polygon & last_endpt_inpoly, ! Was end point of last segment in cell @@ -1081,27 +1081,27 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) & lstuck, ! Is the walk stuck inside a cell & seg_outside, ! Is segment completely outside the grid & bndedge, ! Is segment on the boundary of the grid - & search, ! Do we have to search to locate point + & search, ! Do we have to search to locate point ! in grid & inpolar, ! Are we in the polar region? - & special_cell, ! Is this a special cell + & special_cell, ! Is this a special cell ! (only 1 vtx at pole) - & L_exit_do ! Do we need to escape from infinite + & L_exit_do ! Do we need to escape from infinite ! loop? (NRL) real (SCRIP_r8) :: & intrsct_lat, ! lat of next intersection point & intrsct_lon, ! lon of next intersection point & beglat, beglon, ! start point of current sub seg - & endlat, endlon, ! endpoint of current seg + & endlat, endlon, ! endpoint of current seg ! (chg to endseg?) & endlat1, endlon1, ! endpoint of current subseg & norm_factor ! factor for normalizing wts - real (SCRIP_r8), dimension(2) :: + real (SCRIP_r8), dimension(2) :: & begseg ! begin lat/lon for full segment - real (SCRIP_r8), dimension(6) :: + real (SCRIP_r8), dimension(6) :: & weights, ! local wgt array & rev_weights ! Weights for grid1 and grid2 flipped @@ -1112,9 +1112,9 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) & midlat, midlon, ! Midpoint of segment & tmplat, tmplon, & srchpt_lat, ! Search point (offset from seg. start) - & srchpt_lon, + & srchpt_lon, & offset, delta, ! Offset and offset increase for search - & sinang2, ! Square of sine of angle b/w two + & sinang2, ! Square of sine of angle b/w two ! segments & dist2, ! Square of distance b/w two points & fullseg_len2, ! Square of full segment length @@ -1193,7 +1193,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) !*** ncorners = grid2_corners - nalloc = min(ncorners + 2, + nalloc = min(ncorners + 2, & size(grid2_corner_lat(:,1))) allocate (cell_corner_lat(nalloc), & cell_corner_lon(nalloc)) @@ -1265,7 +1265,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) lrevers = .false. !*** - !*** if this is a constant-longitude segment, skip the rest + !*** if this is a constant-longitude segment, skip the rest !*** since the line integral contribution will be zero. !*** @@ -1274,7 +1274,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) !*** !*** to ensure exact path taken during both - !*** sweeps, always integrate segments in the same + !*** sweeps, always integrate segments in the same !*** direction (SW to NE). !*** @@ -1293,7 +1293,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) !*** we want to start from that (makes some logic easier) if ((beglat < north_thresh .and. endlat > north_thresh) .or. - & (beglat > south_thresh .and. endlat < south_thresh)) + & (beglat > south_thresh .and. endlat < south_thresh)) & then tmplat = beglat beglat = endlat @@ -1311,17 +1311,17 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) fullseg_dlon = endlon-beglon if (fullseg_dlon > pi) fullseg_dlon = fullseg_dlon - pi2 if (fullseg_dlon < -pi) fullseg_dlon = fullseg_dlon + pi2 - fullseg_len2 = fullseg_dlat*fullseg_dlat + + fullseg_len2 = fullseg_dlat*fullseg_dlat + & fullseg_dlon*fullseg_dlon - + partseg_len2 = 0.0 !*** - !*** Is this an edge on the boundary of the grid or + !*** Is this an edge on the boundary of the grid or !*** on the boundary of the active cells - !*** + !*** -! Commented out by MD +! Commented out by MD ! call find_adj_cell(cell_add, corner, grid_num, adj_add) ! if (grid_num .eq. 1) then ! if (adj_add .eq. 0 .or. .not. grid1_mask(adj_add)) then @@ -1358,7 +1358,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) endif !*** - !*** integrate along this segment, detecting intersections + !*** integrate along this segment, detecting intersections !*** and computing the line integral for each sub-segment !*** @@ -1383,7 +1383,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) ! outer "do while" do while (beglat /= endlat .or. beglon /= endlon) - + L_exit_do=.false. !NRL if ((ns .eq. nseg) .or. (inpolar .eqv. .false.)) then @@ -1397,15 +1397,15 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) endlat1 = begseg(1) + ns*(fullseg_dlat)/nseg endlon1 = begseg(2) + ns*(fullseg_dlon)/nseg endif - + num_subseg = 0 ! inner "do while" do while (beglat /= endlat1 .or. beglon /= endlon1) - - !*** - !*** If we integrated to the end or just past it (due to + + !*** + !*** If we integrated to the end or just past it (due to !*** numerical errors), we are done with this segment !*** @@ -1426,7 +1426,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) !*** segment is starting in and where it is exiting this !*** cell !****************************************************** - + vec1_lat = endlat1-beglat vec1_lon = endlon1-beglon if (vec1_lon > pi) vec1_lon = vec1_lon - pi2 @@ -1434,7 +1434,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) vec1_len = sqrt(vec1_lat*vec1_lat+vec1_lon*vec1_lon) vec1_lat = vec1_lat/vec1_len vec1_lon = vec1_lon/vec1_len - + offset = 100.0*tiny oppcell_add = 0 delta = 10*tiny @@ -1444,8 +1444,8 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) lboundary1 = .false. lboundary2 = .false. lboundary3 = .false. - - do while (.not. intrsct_success) + + do while (.not. intrsct_success) !************************************************* !*** Find out which cell the segment starts in @@ -1455,50 +1455,50 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) if (search) then !*** - !*** Offset the start point in ever increasing - !*** amounts until we are able to reliably locate + !*** Offset the start point in ever increasing + !*** amounts until we are able to reliably locate !*** the point in a cell of grid2. Inability to locate !*** the point causes the offset amount to increase it = 0 - do while (.not. srch_success) - + do while (.not. srch_success) + srchpt_lat = beglat + offset*vec1_lat srchpt_lon = beglon + offset*vec1_lon - + call locate_point(srchpt_lat, srchpt_lon, - & cell_add, grid_num, opp_grid_num, + & cell_add, grid_num, opp_grid_num, & oppcell_add, lboundary1, bedgeid1) - + if (oppcell_add .eq. 0) then loutside = .true. ! lcoinc added by MD lcoinc = .false. exit ! exit the search loop else - if (oppcell_add .ne. last_add .or. lthresh) + if (oppcell_add .ne. last_add .or. lthresh) & then srch_success = .true. else offset = offset + delta if (offset .ge. vec1_len) then exit - endif + endif if (it .gt. 3) then delta = 2.0*delta it = 0 endif - endif + endif endif - - it = it + 1 + + it = it + 1 enddo ! do while (.not. srch_success) - + else if (last_endpt_inpoly) then - !*** We know the grid cell the end of the last - !*** segment (which is the beginning of this + !*** We know the grid cell the end of the last + !*** segment (which is the beginning of this !*** segment) oppcell_add = last_add @@ -1512,18 +1512,18 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) oppcell_add = next_add lboundary1 = .true. - + endif - + srch_success = .true. - + endif - + !***************************************************** !*** Find where the segment exits this cell, if at all !***************************************************** - if (srch_success) then + if (srch_success) then !*** !*** First setup local copy of oppcell with room for @@ -1533,28 +1533,28 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) if (grid_num .eq. 1) then ncorners_opp = grid2_corners do i = 1, ncorners_opp - oppcell_corner_lat(i) = + oppcell_corner_lat(i) = & grid2_corner_lat(i,oppcell_add) - oppcell_corner_lon(i) = + oppcell_corner_lon(i) = & grid2_corner_lon(i,oppcell_add) enddo - oppcell_center_lat = + oppcell_center_lat = & grid2_center_lat(oppcell_add) - oppcell_center_lon = + oppcell_center_lon = & grid2_center_lon(oppcell_add) special_cell = special_polar_cell2(oppcell_add) else ncorners_opp = grid1_corners do i = 1, ncorners_opp - oppcell_corner_lat(i) = + oppcell_corner_lat(i) = & grid1_corner_lat(i,oppcell_add) oppcell_corner_lon(i) = & grid1_corner_lon(i,oppcell_add) enddo - oppcell_center_lat = + oppcell_center_lat = & grid1_center_lat(oppcell_add) - oppcell_center_lon = + oppcell_center_lon = & grid1_center_lon(oppcell_add) special_cell = special_polar_cell1(oppcell_add) @@ -1564,35 +1564,35 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) call modify_polar_cell(ncorners_opp, nalloc_opp, & oppcell_corner_lat, oppcell_corner_lon) endif - + !*** - !*** First see if the segment end is + !*** First see if the segment end is !*** in the same cell !*** - call ptincell(endlat1,endlon1, oppcell_add, + call ptincell(endlat1,endlon1, oppcell_add, & ncorners_opp, & oppcell_corner_lat,oppcell_corner_lon, & oppcell_center_lat,oppcell_center_lon, & opp_grid_num,inpoly, - & lboundary2,bedgeid2) - + & lboundary2,bedgeid2) + if (inpoly) then intrsct_lat = endlat1 intrsct_lon = endlon1 - intrsct_success = .true. + intrsct_success = .true. search = .false. next_add = 0 last_add = oppcell_add ! for next subseg last_lboundary = lboundary2 last_endpt_inpoly = .true. - + if (lboundary1 .and. lboundary2) then - - !*** This is a edge on the boundary of the - !*** active mesh and both of its endpoints - !*** are on the boundary of the containing - !*** cell. Check if the the segment is also + + !*** This is a edge on the boundary of the + !*** active mesh and both of its endpoints + !*** are on the boundary of the containing + !*** cell. Check if the the segment is also !*** on the boundary midlat = (beglat+endlat1)/2.0 @@ -1600,33 +1600,33 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) midlon = (beglon+endlon1)/2.0 - pi else midlon = (beglon+endlon1)/2.0 - endif - - call ptincell(midlat,midlon, oppcell_add, + endif + + call ptincell(midlat,midlon, oppcell_add, & ncorners_opp, & oppcell_corner_lat, oppcell_corner_lon, & oppcell_center_lat, oppcell_center_lon, & opp_grid_num, inpoly, lboundary3, - & bedgeid3) - + & bedgeid3) + if (inpoly .and. lboundary3) then lcoinc = .true. intedge = bedgeid3 endif - + else lcoinc = .false. endif - + else - + !*** - !*** Do an intersection to find out where the + !*** Do an intersection to find out where the !*** segment exits the cell !*** call intersection(cell_add,grid_num, - & beglat, beglon, endlat1, endlon1, + & beglat, beglon, endlat1, endlon1, & begseg, & bedgeid1, & oppcell_add, ncorners_opp, @@ -1634,7 +1634,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) & opp_grid_num, & intrsct_lat, intrsct_lon, intedge, & sinang2, lcoinc, lthresh) - + if (intedge /= 0) then intrsct_success = .true. last_add = oppcell_add ! for next subseg @@ -1654,11 +1654,11 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) search = .true. endif endif - + endif - + if (.not. intrsct_success) then - + !*** Offset point and try again search = .true. @@ -1672,7 +1672,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) intrsct_lon = endlon1 last_add = 0 last_lboundary = .false. - exit + exit endif endif @@ -1685,7 +1685,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) !*** !*** Segment is coincident with edge of other grid !*** which means it could belong to one of 2 cells - !*** Choose the cell such that edge that is + !*** Choose the cell such that edge that is !*** coincident with the segment is in the same !*** dir as the segment @@ -1693,23 +1693,23 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) inext = mod(i,ncorners_opp)+1 vec2_lat = oppcell_corner_lat(inext) - & oppcell_corner_lat(i) - vec2_lon = oppcell_corner_lon(inext) - + vec2_lon = oppcell_corner_lon(inext) - & oppcell_corner_lon(i) if (vec2_lon > pi) vec2_lon = vec2_lon - pi2 if (vec2_lon < -pi) vec2_lon = vec2_lon + pi2 - + dp = vec1_lat*vec2_lat + vec1_lon*vec2_lon - + if ((.not. lrevers .and. dp .lt. 0) .or. & (lrevers .and. dp .gt. 0)) then - + !*** Integrals from this segment must be !*** assigned to the adjacent cell of !*** opcell_add but only if such an adjacent !*** cell exists - call find_adj_cell(oppcell_add, intedge, + call find_adj_cell(oppcell_add, intedge, & opp_grid_num, adj_add) if (adj_add .gt. 0) then @@ -1718,47 +1718,47 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) if (grid_num .eq. 1) then ncorners_opp = grid2_corners do i = 1, ncorners_opp - oppcell_corner_lat(i) = + oppcell_corner_lat(i) = & grid2_corner_lat(i,oppcell_add) - oppcell_corner_lon(i) = + oppcell_corner_lon(i) = & grid2_corner_lon(i,oppcell_add) enddo - oppcell_center_lat = + oppcell_center_lat = & grid2_center_lat(oppcell_add) - oppcell_center_lon = + oppcell_center_lon = & grid2_center_lon(oppcell_add) - - special_cell = + + special_cell = & special_polar_cell2(oppcell_add) else ncorners_opp = grid1_corners do i = 1, ncorners_opp - oppcell_corner_lat(i) = + oppcell_corner_lat(i) = & grid1_corner_lat(i,oppcell_add) oppcell_corner_lon(i) = & grid1_corner_lon(i,oppcell_add) enddo - oppcell_center_lat = + oppcell_center_lat = & grid1_center_lat(oppcell_add) - oppcell_center_lon = + oppcell_center_lon = & grid1_center_lon(oppcell_add) - special_cell = + special_cell = & special_polar_cell1(oppcell_add) endif - + if (special_cell) then - call modify_polar_cell(ncorners_opp, - & nalloc_opp, oppcell_corner_lat, + call modify_polar_cell(ncorners_opp, + & nalloc_opp, oppcell_corner_lat, & oppcell_corner_lon) endif endif endif - + endif - + else !*** @@ -1766,11 +1766,11 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) !*** start !*** - if (oppcell_add .eq. 0) then + if (oppcell_add .eq. 0) then loutside = .true. ! lcoinc added by MD lcoinc = .false. - + !*** !*** Take baby steps to see if any part of the !*** segment is inside a cell of the other grid @@ -1780,48 +1780,48 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) delta = vec1_len/100.00 offset = delta do while (.not. srch_success) - + srchpt_lat = beglat + offset*vec1_lat srchpt_lon = beglon + offset*vec1_lon - - call locate_point(srchpt_lat, srchpt_lon, - & cell_add, grid_num, opp_grid_num, + + call locate_point(srchpt_lat, srchpt_lon, + & cell_add, grid_num, opp_grid_num, & oppcell_add, lboundary1, bedgeid1) - + if (oppcell_add /= 0) then srch_success = .true. !*** !*** Found a point of the segment in the !*** cell. Do a bisection method to find - !*** the starting point of the segment + !*** the starting point of the segment !*** in the cell - !*** + !*** - call converge_to_bdry(oppcell_add, - & opp_grid_num, ncorners_opp, - & oppcell_corner_lat, + call converge_to_bdry(oppcell_add, + & opp_grid_num, ncorners_opp, + & oppcell_corner_lat, & oppcell_corner_lon, & oppcell_center_lat, & oppcell_center_lon, & srchpt_lat, srchpt_lon, & beglat, beglon, - & intrsct_lat, intrsct_lon, + & intrsct_lat, intrsct_lon, & bedgeid1) search = .false. last_endpt_onedge = .true. next_add = oppcell_add last_lboundary = .true. - - oppcell_add = 0 + + oppcell_add = 0 else offset = offset + delta - + if (offset .ge. vec1_len) then -! print *, +! print *, ! & 'Segment fully outside grid2' ! print *, 'Segment of grid1_add', ! & grid1_add @@ -1831,8 +1831,8 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) seg_outside = .true. intrsct_lat = endlat1 - intrsct_lon = endlon1 - + intrsct_lon = endlon1 + search = .true. last_add = 0 last_lboundary = .false. @@ -1840,34 +1840,34 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) exit ! leave search loop endif endif - + enddo ! int. loop - if (srch_success .or. seg_outside) exit - + if (srch_success .or. seg_outside) exit + else - + if(is_master)then print *, 'Unable to move out of last cell' print *, 'Segment of edge ',corner, & ' of grid cell ',cell_add print *, 'Stuck in opposite grid cell ', & oppcell_add - dist2 = + dist2 = & (endlat1-begseg(1))*(endlat1-begseg(1)) + & (endlon1-begseg(2))*(endlon1-begseg(2)) print *, 'Fraction of segment left ', & vec1_len/sqrt(dist2) endif lstuck = .true. - + !*** - !*** Punt - just assign the rest of the segment + !*** Punt - just assign the rest of the segment !*** to the current cell it is stuck in by - !*** tagging the segment endpoint as the + !*** tagging the segment endpoint as the !*** intersection point - !*** + !*** intrsct_lat = endlat1 intrsct_lon = endlon1 @@ -1875,11 +1875,11 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) search = .true. last_add = 0 last_lboundary = .false. - + endif exit ! exit the intersection loop - + endif ! if (srch_success) then ... else .... end do ! do while (.not. intrsct_success) @@ -1887,7 +1887,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) !******************************************************** !*** Compute the line integrals for this subsegment !******************************************************** - + if (oppcell_add /= 0) then call line_integral(phi_or_theta, weights, num_wts, & beglon, intrsct_lon, beglat, intrsct_lat, @@ -1899,7 +1899,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) & cell_center_lat, cell_center_lon, & cell_center_lat, cell_center_lon) endif - + !*** !*** if integrating in reverse order, change !*** sign of weights @@ -1910,7 +1910,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) endif !*** - !*** store the appropriate addresses and weights. + !*** store the appropriate addresses and weights. !*** also add contributions to cell areas and centroids. !*** @@ -1918,7 +1918,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) if (oppcell_add /= 0) then if (grid1_mask(cell_add)) then - call store_link_cnsrv(cell_add, oppcell_add, + call store_link_cnsrv(cell_add, oppcell_add, & weights) C$OMP CRITICAL(block1) @@ -1927,22 +1927,22 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) ! cell address and oppcell_add in which case it will try to write ! into this address - we have to block that until we are finished ! - grid1_frac(cell_add) = + grid1_frac(cell_add) = & grid1_frac(cell_add) + weights(1) - grid2_frac(oppcell_add) = + grid2_frac(oppcell_add) = & grid2_frac(oppcell_add) + weights(num_wts+1) C$OMP END CRITICAL(block1) endif - + endif -C$OMP CRITICAL(block2) - grid1_area(cell_add) = grid1_area(cell_add) + +C$OMP CRITICAL(block2) + grid1_area(cell_add) = grid1_area(cell_add) + & weights(1) - grid1_centroid_lat(cell_add) = + grid1_centroid_lat(cell_add) = & grid1_centroid_lat(cell_add) + weights(2) - grid1_centroid_lon(cell_add) = + grid1_centroid_lon(cell_add) = & grid1_centroid_lon(cell_add) + weights(3) C$OMP END CRITICAL(block2) @@ -1952,14 +1952,14 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) !*** we are always sending in grid1 weights first !*** and then grid2 weights - do i = 1, num_wts + do i = 1, num_wts rev_weights(num_wts+i) = weights(i) rev_weights(i) = weights(num_wts+i) enddo if (.not. lcoinc .and. oppcell_add /= 0) then if (grid1_mask(oppcell_add)) then - call store_link_cnsrv(oppcell_add, cell_add, + call store_link_cnsrv(oppcell_add, cell_add, & rev_weights) C$OMP CRITICAL(block3) @@ -1968,23 +1968,23 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) ! cell address and oppcell_add in which case it will try to write ! into this address - we have to block that until we are finished ! - grid2_frac(cell_add) = + grid2_frac(cell_add) = & grid2_frac(cell_add) + weights(1) - grid1_frac(oppcell_add) = + grid1_frac(oppcell_add) = & grid1_frac(oppcell_add) + weights(num_wts+1) C$OMP END CRITICAL(block3) endif - + endif - + C$OMP CRITICAL(block4) - grid2_area(cell_add) = grid2_area(cell_add) + + grid2_area(cell_add) = grid2_area(cell_add) + & weights(1) - grid2_centroid_lat(cell_add) = + grid2_centroid_lat(cell_add) = & grid2_centroid_lat(cell_add) + weights(2) - grid2_centroid_lon(cell_add) = + grid2_centroid_lon(cell_add) = & grid2_centroid_lon(cell_add) + weights(3) C$OMP END CRITICAL(block4) endif @@ -1999,12 +1999,12 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) !*** !*** How far have we come from the start of the segment !*** - + vec2_lat = intrsct_lat-begseg(1) vec2_lon = intrsct_lon-begseg(2) if (vec2_lon > pi) vec2_lon = vec2_lon - pi2 if (vec2_lon < -pi) vec2_lon = vec2_lon + pi2 - + partseg_len2 = vec2_lat*vec2_lat + vec2_lon*vec2_lon !*** @@ -2014,7 +2014,7 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) num_subseg = num_subseg + 1 if (num_subseg > max_subseg) then - print *, + print *, & 'integration stalled: num_subseg exceeded limit' print *, 'Cell ',cell_add print *, 'Edge ',corner @@ -2031,11 +2031,11 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) end do ! do while (beglat /= endlat1 ... !NRL We add an exit to outer do similar to exit of inner do: -!NRL This was an apparent bug: exit statement would escape -!NRL inner do but then computation could not get out of +!NRL This was an apparent bug: exit statement would escape +!NRL inner do but then computation could not get out of !NRL outer do since beglat, beglon controlling outer do !NRL never changed b/c it never gets to the part of the -!NRL code that changes beglat, beglon, b/c it keeps +!NRL code that changes beglat, beglon, b/c it keeps !NRL exiting inner do. !NRL This should happen very rarely, so we have a print @@ -2049,8 +2049,8 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) endif ! NRL ns = ns + 1 - if ((beglat > 0 .and. beglat < north_thresh) .or. - & (beglat < 0 .and. beglat > south_thresh)) + if ((beglat > 0 .and. beglat < north_thresh) .or. + & (beglat < 0 .and. beglat > south_thresh)) & then inpolar = .false. endif @@ -2060,9 +2060,9 @@ subroutine cell_integrate(cell_add, grid_num, phi_or_theta) call line_integral(phi_or_theta, weights, num_wts, & begseg(2), endlon, begseg(1), endlat, - & cell_center_lat, + & cell_center_lat, & cell_center_lon, - & cell_center_lat, + & cell_center_lat, & cell_center_lon) !*** @@ -2077,7 +2077,7 @@ end subroutine cell_integrate !*********************************************************************** - subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, + subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, & cell_corner_lon) !*** Input variables @@ -2085,7 +2085,7 @@ subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, integer (SCRIP_i4), intent(in) :: & nalloc - !*** In/Out Variables + !*** In/Out Variables integer (SCRIP_i4), intent(inout) :: & ncorners @@ -2097,7 +2097,7 @@ subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, integer (SCRIP_i4) :: & npcorners, ! Number of polar corners - & pcorner, ! Index of the polar corner + & pcorner, ! Index of the polar corner ! (if only 1 is found) & corner, ! Corner iterator variable & previdx, ! Index of previous corner to polar corner @@ -2108,7 +2108,7 @@ subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, & prevlon, ! Latitude of previous corner to polar corner & nextlon ! Latitude of next corner to polar corner - + !*** !*** Modify special cell with only one corner at the pole. Such !*** cells can have an artificially extreme distortion of the @@ -2129,9 +2129,9 @@ subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, !*** lat_p+ lat_p- lat_p+ lat_p- !*** - + !*** - !*** MAJOR ASSUMPTION HERE IS THAT CELL_CORNER_LAT AND + !*** MAJOR ASSUMPTION HERE IS THAT CELL_CORNER_LAT AND !*** CELL_CORNER_LON HAVE ROOM TO GROW !*** if (ncorners .ge. nalloc) return ! ** * No room to grow @@ -2148,13 +2148,13 @@ subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, if (npcorners .ne. 1) return !*** Not the kind of cell we want - + previdx = mod((pcorner-1)-1+ncorners,ncorners) + 1 prevlon = cell_corner_lon(previdx) - + nextidx = mod(pcorner,ncorners) + 1 nextlon = cell_corner_lon(nextidx) - + !*** Move entries from pcorner+1 on back by one do corner = ncorners, pcorner+1, -1 @@ -2166,7 +2166,7 @@ subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, cell_corner_lat(pcorner+1) = pole_lat cell_corner_lon(pcorner+1) = nextlon - + ncorners = ncorners+1 !*** Move entries from pcorner on back by one @@ -2182,7 +2182,7 @@ subroutine modify_polar_cell(ncorners, nalloc, cell_corner_lat, cell_corner_lon(pcorner) = prevlon ncorners = ncorners+1 - + end subroutine modify_polar_cell @@ -2196,16 +2196,16 @@ subroutine intersection(seg_cell_id, seg_grid_id, !----------------------------------------------------------------------- ! -! this routine finds the intersection of a line segment given by +! this routine finds the intersection of a line segment given by ! beglon, endlon, etc. with a cell from another grid -! A coincidence flag is returned if the segment is entirely -! coincident with an edge of the opposite. +! A coincidence flag is returned if the segment is entirely +! coincident with an edge of the opposite. ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! -! intent(in): +! intent(in): ! !----------------------------------------------------------------------- @@ -2215,11 +2215,11 @@ subroutine intersection(seg_cell_id, seg_grid_id, integer (SCRIP_i4), intent(in) :: & seg_grid_id ! ID of grid that intersecting segment is from - real (SCRIP_r8), intent(in) :: + real (SCRIP_r8), intent(in) :: & beglat, beglon,! beginning lat/lon endpoints for segment & endlat, endlon ! ending lat/lon endpoints for segment - real (SCRIP_r8), dimension(2), intent(inout) :: + real (SCRIP_r8), dimension(2), intent(inout) :: & begseg ! begin lat/lon of full segment integer (SCRIP_i4), intent(in) :: @@ -2227,7 +2227,7 @@ subroutine intersection(seg_cell_id, seg_grid_id, integer (SCRIP_i4), intent(in) :: & cell_id ! cell to intersect with - + integer (SCRIP_i4), intent(in) :: & ncorners ! number of corners of cell @@ -2241,12 +2241,12 @@ subroutine intersection(seg_cell_id, seg_grid_id, !----------------------------------------------------------------------- ! -! intent(out): +! intent(out): ! !----------------------------------------------------------------------- real (SCRIP_r8), intent(out) :: - & intrsct_lat, + & intrsct_lat, & intrsct_lon ! lat/lon coords of intersection real (SCRIP_r8), intent(out) :: @@ -2257,7 +2257,7 @@ subroutine intersection(seg_cell_id, seg_grid_id, & intedge ! edge that is intersected logical (SCRIP_logical), intent(out) :: - & lcoinc ! True if segment is coincident with + & lcoinc ! True if segment is coincident with ! a cell edge logical (SCRIP_logical), intent(out) :: @@ -2269,7 +2269,7 @@ subroutine intersection(seg_cell_id, seg_grid_id, ! !----------------------------------------------------------------------- - integer (SCRIP_i4) :: + integer (SCRIP_i4) :: & n, next_n logical (SCRIP_logical) :: @@ -2280,22 +2280,22 @@ subroutine intersection(seg_cell_id, seg_grid_id, & lat1, lat2, ! local latitude variables for segment & grdlon1, grdlon2, ! local longitude variables for grid cell & grdlat1, grdlat2, ! local latitude variables for grid cell - & vec1_lat, vec1_lon, + & vec1_lat, vec1_lon, & vec2_lat, vec2_lon, ! & vec3_lat, vec3_lon, ! vectors and vector products used & cross_product, ! during grid search & dot_product, ! & lensqr1, lensqr2, ! & lensqr3, ! - & s1, s2, determ, + & s1, s2, determ, & mat1, mat2, ! variables used for linear solve to & mat3, mat4, ! find intersection & rhs1, rhs2, ! - & denom, + & denom, & begsegloc(2), ! local copy of full segment start - & dist2, ! distance from start pt to intersection + & dist2, ! distance from start pt to intersection ! pt - & maxdist2, ! max dist from start pt to any + & maxdist2, ! max dist from start pt to any ! intersection pt & max_intrsct_lat, ! latitude of farthest intersection point & max_intrsct_lon, ! longitude of farthest intersection @@ -2341,12 +2341,12 @@ subroutine intersection(seg_cell_id, seg_grid_id, if (beglat > north_thresh .or. beglat < south_thresh) then !*** Special intersection routine for cells near the pole - !*** Intersection is done in a transformed space using + !*** Intersection is done in a transformed space using !*** multi-segmented representation of the cell call pole_intersection(cell_id,ncorners, & cell_corner_lat,cell_corner_lon,cell_grid_id, - & beglat, beglon, endlat, + & beglat, beglon, endlat, & endlon, begseg, begedge, & intedge,intrsct_lat,intrsct_lon, & sinang2,lcoinc,lthresh) @@ -2356,7 +2356,7 @@ subroutine intersection(seg_cell_id, seg_grid_id, endif - maxdist2 = -9999999.0 + maxdist2 = -9999999.0 begsegloc(1) = begseg(1) begsegloc(2) = begseg(2) @@ -2364,7 +2364,7 @@ subroutine intersection(seg_cell_id, seg_grid_id, lthresh = .false. intrsct_loop: do n=1,ncorners next_n = mod(n,ncorners) + 1 - + grdlat1 = cell_corner_lat(n) grdlon1 = cell_corner_lon(n) grdlat2 = cell_corner_lat(next_n) @@ -2383,7 +2383,7 @@ subroutine intersection(seg_cell_id, seg_grid_id, grdlon1 = grdlon1 - pi2 endif - ! Also the two intersecting segments together + ! Also the two intersecting segments together ! cannot span more than 2*pi radians minlon = min(lon1,lon2) @@ -2398,8 +2398,8 @@ subroutine intersection(seg_cell_id, seg_grid_id, grdlon1 = grdlon1 + pi2 grdlon2 = grdlon2 + pi2 endif - endif - + endif + !*** !*** set up linear system to solve for intersection @@ -2415,14 +2415,14 @@ subroutine intersection(seg_cell_id, seg_grid_id, determ = mat1*mat4 - mat2*mat3 !*** - !*** if the determinant is zero, the segments are either - !*** parallel or coincident. coincidences were detected + !*** if the determinant is zero, the segments are either + !*** parallel or coincident. coincidences were detected !*** above so do nothing. if (abs(determ) > tiny*tiny) then - !*** if the determinant is non-zero, solve for the linear - !*** parameters s for the intersection point on each line + !*** if the determinant is non-zero, solve for the linear + !*** parameters s for the intersection point on each line !*** segment. !*** if 0 pi) then @@ -2532,8 +2532,8 @@ subroutine intersection(seg_cell_id, seg_grid_id, max_intrsct_lat = intrsct_lat max_intrsct_lon = intrsct_lon maxdist2 = dist2 - - denom = + + denom = & (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) sinang2 = determ*determ/denom intedge = n @@ -2545,14 +2545,14 @@ subroutine intersection(seg_cell_id, seg_grid_id, print *, 'DEBUG: zero determ' stop endif - + endif else !*** !*** Coincident lines or parallel lines - !*** + !*** cross_product = mat2*rhs2 - mat4*rhs1 @@ -2566,7 +2566,7 @@ subroutine intersection(seg_cell_id, seg_grid_id, dot_product = mat1*(-mat2) + mat3*(-mat4) - lensqr1 = mat1*mat1 + mat3*mat3 ! length sqrd of input + lensqr1 = mat1*mat1 + mat3*mat3 ! length sqrd of input ! segment if (dot_product < zero) then @@ -2574,7 +2574,7 @@ subroutine intersection(seg_cell_id, seg_grid_id, !*** !*** Segments oriented in the same direction !*** - + tmplat = grdlat2 tmplon = grdlon2 @@ -2600,14 +2600,14 @@ subroutine intersection(seg_cell_id, seg_grid_id, vec3_lat = grdlat2 - lat1 vec3_lon = grdlon2 - lon1 if (vec3_lon > pi) vec3_lon = vec3_lon - pi2 - if (vec3_lon < -pi) vec3_lon = vec3_lon + pi2 + if (vec3_lon < -pi) vec3_lon = vec3_lon + pi2 lensqr3 = (vec3_lat*vec3_lat+vec3_lon*vec3_lon) if (vec3_lat*mat1 + vec3_lon*mat3 < 0) then lensqr3 = -lensqr3 endif - + found = .false. if (lensqr2 > 0) then @@ -2646,13 +2646,13 @@ subroutine intersection(seg_cell_id, seg_grid_id, exit intrsct_loop endif - + endif endif !*** restore lon1 and lon2 in case it got modified - + lon1 = beglon lon2 = endlon begsegloc(2) = begseg(2) @@ -2728,20 +2728,20 @@ subroutine pole_intersection(location,ncorners, !----------------------------------------------------------------------- ! -! Special intersection routine for line segment in cell close to +! Special intersection routine for line segment in cell close to ! poles ! A coordinate transformation (using a Lambert azimuthal ! equivalent projection) is performed to perform the intersection ! Also, since a straight line in lat-lon space is a curve in this -! transformed space, we represent each edge of the cell as having -! 'npseg' segments whose endpoints are mapped using the Lambert +! transformed space, we represent each edge of the cell as having +! 'npseg' segments whose endpoints are mapped using the Lambert ! projection ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! -! intent(in): +! intent(in): ! !----------------------------------------------------------------------- @@ -2758,20 +2758,20 @@ subroutine pole_intersection(location,ncorners, integer (SCRIP_i4), intent(in) :: & cell_grid_id ! which grid is the cell from? - real (SCRIP_r8), intent(in) :: + real (SCRIP_r8), intent(in) :: & beglat, beglon, ! beginning lat/lon coords for segment & endlat, endlon ! ending lat/lon coords for segment - real (SCRIP_r8), dimension(2), intent(inout) :: + real (SCRIP_r8), dimension(2), intent(inout) :: & begseg ! begin lat/lon of full segment integer (SCRIP_i4), intent(in) :: - & begedge ! edge on which segment start is on + & begedge ! edge on which segment start is on ! (can be 0) !----------------------------------------------------------------------- ! -! intent(out): +! intent(out): ! !----------------------------------------------------------------------- @@ -2780,18 +2780,18 @@ subroutine pole_intersection(location,ncorners, real (SCRIP_r8), intent(out) :: & intrsct_lat, ! lat/lon coords of intersection - & intrsct_lon + & intrsct_lon real (SCRIP_r8), intent(out) :: & sinang2 ! square of sine of angle between ! intersecting line segments logical (SCRIP_logical), intent(out) :: - & lcoinc ! True if segment is coincident with + & lcoinc ! True if segment is coincident with ! a cell edge logical (SCRIP_logical), intent(inout) :: - & lthresh ! True if segment crosses threshold + & lthresh ! True if segment crosses threshold !----------------------------------------------------------------------- @@ -2800,17 +2800,17 @@ subroutine pole_intersection(location,ncorners, ! !----------------------------------------------------------------------- - integer (SCRIP_i4) :: + integer (SCRIP_i4) :: & n, n1, next_n, prev_n, - & it, i, j, - & ncorners2, + & it, i, j, + & ncorners2, & intedge1 - logical (SCRIP_logical) :: - & first, + logical (SCRIP_logical) :: + & first, & found - real (SCRIP_r8) :: + real (SCRIP_r8) :: & pi4, rns, ! north/south conversion & x1, x2, ! local x variables for segment & y1, y2, ! local y variables for segment @@ -2820,7 +2820,7 @@ subroutine pole_intersection(location,ncorners, & grdlon1, grdlon2, ! longitude vars for grid cell & vec1_y, vec1_x, ! & vec2_y, vec2_x, ! vectors and cross products used - & vec3_y, vec3_x, ! + & vec3_y, vec3_x, ! & vec1_lat, vec1_lon, ! & vec2_lat, vec2_lon, ! & vec3_lon, ! @@ -2831,7 +2831,7 @@ subroutine pole_intersection(location,ncorners, & mat3, mat4, ! find intersection & rhs1, rhs2, ! & denom, ! - & intrsct_x, intrsct_y, ! intersection coordinates in + & intrsct_x, intrsct_y, ! intersection coordinates in ! transformed space & max_intrsct_lat, ! intersection point at max distance & max_intrsct_lon, ! from the start point @@ -2840,8 +2840,8 @@ subroutine pole_intersection(location,ncorners, & maxdist2, ! max dist of intersection point from ! start pnt & lensqr1, lensqr2, ! various segment lengths - & lensqr3, - & tmpx, tmpy, + & lensqr3, + & tmpx, tmpy, & tmplat, tmplon, & ldummy @@ -2851,9 +2851,9 @@ subroutine pole_intersection(location,ncorners, real (SCRIP_r8), dimension(npseg*ncorners) :: & cell_corners_lat_loc,! Lat/Lon coordinates of multi-segmented - & cell_corners_lon_loc ! version of cell + & cell_corners_lon_loc ! version of cell + - !----------------------------------------------------------------------- ! @@ -2902,13 +2902,13 @@ subroutine pole_intersection(location,ncorners, !----------------------------------------------------------------------- - if (abs(x1) .le. tiny .and. abs(y1) .le. tiny .and. + if (abs(x1) .le. tiny .and. abs(y1) .le. tiny .and. & abs(x2) .le. tiny .and. abs(y2) .le. tiny) then !*** !*** The segment is a polar segment which is degenerate !*** in the transformed Lambert space. Find out which - !*** cell edge it is coincident with and find the + !*** cell edge it is coincident with and find the !*** point where the segment exits this cell (if at all) !*** NOTE 1: THIS MUST BE DONE IN LAT-LON SPACE !*** NOTE 2: CODE RELEVANT ONLY FOR INTEGRATION W.R.T. phi @@ -2916,7 +2916,7 @@ subroutine pole_intersection(location,ncorners, intrsct_loop1: do n = 1, ncorners next_n = mod(n,ncorners) + 1 - + grdlat1 = cell_corners_lat(n) grdlon1 = cell_corners_lon(n) grdlat2 = cell_corners_lat(next_n) @@ -2925,10 +2925,10 @@ subroutine pole_intersection(location,ncorners, grdy1 = two*sin(pi4 - half*grdlat1)*sin(grdlon1) grdx2 = rns*two*sin(pi4 - half*grdlat2)*cos(grdlon2) grdy2 = two*sin(pi4 - half*grdlat2)*sin(grdlon2) - + if (abs(grdx1) .le. tiny .and. abs(grdy1) .le. tiny .and. & abs(grdx2) .le. tiny .and. abs(grdy2) .le. tiny) then - + !*** !*** Found polar segment in cell !*** @@ -2950,7 +2950,7 @@ subroutine pole_intersection(location,ncorners, grdlat2 = grdlat1 grdlon2 = grdlon1 grdlat1 = tmplat - grdlon1 = tmplon + grdlon1 = tmplon endif vec2_lon = grdlon1 - beglon @@ -2988,15 +2988,15 @@ subroutine pole_intersection(location,ncorners, intedge = n exit intrsct_loop1 endif - + endif - + end do intrsct_loop1 return endif - + !**** @@ -3012,7 +3012,7 @@ subroutine pole_intersection(location,ncorners, i = 0 do n = ncorners, 1, -1 i = i+1 - n1 = mod(n,ncorners)+1 + n1 = mod(n,ncorners)+1 cell_corners_lat_loc(i) = cell_corners_lat(n1) cell_corners_lon_loc(i) = cell_corners_lon(n1) @@ -3029,8 +3029,8 @@ subroutine pole_intersection(location,ncorners, endif do j = 1, npseg-1 - i = i+1 - cell_corners_lat_loc(i) = + i = i+1 + cell_corners_lat_loc(i) = & cell_corners_lat(n1) + j*vec1_lat/npseg cell_corners_lon_loc(i) = & cell_corners_lon(n1) + j*vec1_lon/npseg @@ -3077,11 +3077,11 @@ subroutine pole_intersection(location,ncorners, determ = mat1*mat4 - mat2*mat3 !*** - !*** if the determinant is zero, the segments are either - !*** parallel or coincident or one segment has zero length. + !*** if the determinant is zero, the segments are either + !*** parallel or coincident or one segment has zero length. - !*** if the determinant is non-zero, solve for the linear - !*** parameters s for the intersection point on each line + !*** if the determinant is non-zero, solve for the linear + !*** parameters s for the intersection point on each line !*** segment. !*** if 0= zero .and. s2 <= one .and. & s1 > tiny .and. s1 <= one) then intrsct_x = x1 + s1*mat1 intrsct_y = y1 + s1*mat3 - + !*** !*** convert back to lat/lon coordinates !*** @@ -3112,10 +3112,10 @@ subroutine pole_intersection(location,ncorners, !*** Degenerate case - we don't have a good way of !*** finding out what the longitude corresponding - !*** to a (0,0) intersection is. So we take the + !*** to a (0,0) intersection is. So we take the !*** the intersection as one of the two endpoints of !*** the grid segment - + if (abs(abs(grdlat1)-pih) .lt. 1e-5 .and. & abs(abs(grdlat2)-pih) .lt. 1e-5) then @@ -3138,7 +3138,7 @@ subroutine pole_intersection(location,ncorners, else if (vec2_lon < -pi) then vec2_lon = vec2_lon + pi2 endif - + !*** pick the endpoint of the grid segment that is !*** farthest from the beg point of the segment @@ -3180,16 +3180,16 @@ subroutine pole_intersection(location,ncorners, endif - if (intrsct_lon < zero) + if (intrsct_lon < zero) & intrsct_lon = intrsct_lon + pi2 - + if (abs(intrsct_x) > 1.d-10) then - intrsct_lat = (pi4 - + intrsct_lat = (pi4 - & asin(rns*half*intrsct_x/cos(intrsct_lon)))*two ldummy = two*(pi4 - & asin(sqrt(intrsct_x*intrsct_x+intrsct_y*intrsct_y)/2.)) else if (abs(intrsct_y) > 1.d-10) then - intrsct_lat = (pi4 - + intrsct_lat = (pi4 - & asin(half*intrsct_y/sin(intrsct_lon)))*two ldummy = two*(pi4 - & asin(sqrt(intrsct_x*intrsct_x+intrsct_y*intrsct_y)/2.)) @@ -3201,10 +3201,10 @@ subroutine pole_intersection(location,ncorners, !*** !*** If there are multiple intersection points, accept the !*** one that is not on the edge we started from but is - !*** closest to the start point - need this for + !*** closest to the start point - need this for !*** intersection to work for non-convex edges !*** - + if (first) then intedge1 = (n-1)/npseg + 1 @@ -3214,7 +3214,7 @@ subroutine pole_intersection(location,ncorners, max_intrsct_lat = intrsct_lat max_intrsct_lon = intrsct_lon - + vec1_lat = intrsct_lat-beglat vec1_lon = intrsct_lon-beglon if (vec1_lon > pi) then @@ -3224,11 +3224,11 @@ subroutine pole_intersection(location,ncorners, endif maxdist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon dist2 = maxdist2 - + denom = (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) sinang2 = determ*determ/denom intedge = intedge1 - + first = .false. endif @@ -3241,44 +3241,44 @@ subroutine pole_intersection(location,ncorners, vec1_lon = vec1_lon + pi2 endif dist2 = vec1_lat*vec1_lat + vec1_lon*vec1_lon - + !*** if the first intersection was on the same edge - !*** as the starting edge or - !*** the current intersection point is not on the - !*** starting edge and the distance to the beginning - !*** point is less than that of the previous + !*** as the starting edge or + !*** the current intersection point is not on the + !*** starting edge and the distance to the beginning + !*** point is less than that of the previous !*** intersection accept this intersection intedge1 = (n-1)/npseg + 1 intedge1 = ncorners - intedge1 + 1 ! dir of edges was - ! reversed + ! reversed if (dist2 > maxdist2) then if (begedge == 0 .or. intedge1 .ne. begedge) then max_intrsct_lat = intrsct_lat max_intrsct_lon = intrsct_lon maxdist2 = dist2 - - denom = + + denom = & (mat1*mat1+mat2*mat2)*(mat3*mat3+mat4*mat4) sinang2 = determ*determ/denom intedge = intedge1 endif endif endif - endif + endif else !*** !*** Coincident lines or parallel lines - !*** + !*** cross_product = mat2*rhs2 - mat4*rhs1 - + if (abs(cross_product) < tiny) then - + dot_product = mat1*(-mat2) + mat3*(-mat4) - + !*** !*** If area of triangle formed by x2,y2 and the gridline !*** is negligible then the lines are coincident @@ -3286,7 +3286,7 @@ subroutine pole_intersection(location,ncorners, lensqr1 = mat1*mat1 + mat3*mat3 ! length sqrd of input ! segment - + if (dot_product < zero) then tmpx = grdx2 tmpy = grdy2 @@ -3302,17 +3302,17 @@ subroutine pole_intersection(location,ncorners, grdlon1 = tmplon endif - + vec2_x = grdx1 - x1 vec2_y = grdy1 - y1 lensqr2 = vec2_x*vec2_x + vec2_y*vec2_y if (vec2_x*mat1+vec2_y*mat3 < 0) then lensqr2 = -lensqr2 endif - + vec3_x = grdx2 - x1 - vec3_y = grdy2 - y1 + vec3_y = grdy2 - y1 lensqr3 = (vec3_x*vec3_x+vec3_y*vec3_y) if (vec3_x*mat1+vec3_y*mat3 < 0) then lensqr3 = -lensqr3 @@ -3345,15 +3345,15 @@ subroutine pole_intersection(location,ncorners, endif endif endif - + if (found) then dist2 = (intrsct_lat-beglat)*(intrsct_lat-beglat)+ & (intrsct_lon-beglon)*(intrsct_lon-beglon) - + if (dist2 > tiny*tiny) then - + !*** Coincidence intersection always wins - + max_intrsct_lat = intrsct_lat max_intrsct_lon = intrsct_lon maxdist2 = dist2 @@ -3361,14 +3361,14 @@ subroutine pole_intersection(location,ncorners, intedge = (n-1)/npseg + 1 intedge = ncorners - intedge + 1 lcoinc = .true. - + exit intrsct_loop2 endif endif endif ! if (abs(cross_product) < tiny) - + endif ! if (abs(determ) > 1.e-30) .. else .. endif end do intrsct_loop2 @@ -3383,7 +3383,7 @@ subroutine pole_intersection(location,ncorners, !----------------------------------------------------------------------- ! -! if segment manages to cross over pole, shift the beginning +! if segment manages to cross over pole, shift the beginning ! endpoint in order to avoid hitting pole directly ! (it is ok for endpoint to be pole point) ! @@ -3454,31 +3454,31 @@ end subroutine pole_intersection - subroutine line_integral(phi_or_theta, weights, num_wts, + subroutine line_integral(phi_or_theta, weights, num_wts, & in_phi1, in_phi2, theta1, theta2, & grid1_lat, grid1_lon, grid2_lat, grid2_lon) !----------------------------------------------------------------------- ! -! this routine computes the line integral of the flux function +! this routine computes the line integral of the flux function ! that results in the interpolation weights. the line is defined ! by the input lat/lon of the endpoints. ! !----------------------------------------------------------------------- - + !----------------------------------------------------------------------- ! ! intent(in): ! !----------------------------------------------------------------------- - integer (SCRIP_i4), intent(in) :: + integer (SCRIP_i4), intent(in) :: & phi_or_theta ! Integration variable (lat or lon) integer (SCRIP_i4), intent(in) :: & num_wts ! number of weights to compute - real (SCRIP_r8), intent(in) :: + real (SCRIP_r8), intent(in) :: & in_phi1, in_phi2, ! longitude endpoints for the segment & theta1, theta2, ! latitude endpoints for the segment & grid1_lat, grid1_lon, ! reference coordinates for each @@ -3497,11 +3497,11 @@ subroutine line_integral(phi_or_theta, weights, num_wts, ! write(*,*)'subroutine line_integral' if (phi_or_theta .eq. 1) then call line_integral_phi(weights, num_wts, in_phi1, in_phi2, - & theta1, theta2, grid1_lat, grid1_lon, + & theta1, theta2, grid1_lat, grid1_lon, & grid2_lat, grid2_lon) else call line_integral_theta(weights, num_wts,in_phi1,in_phi2, - & theta1, theta2, grid1_lat, grid1_lon, + & theta1, theta2, grid1_lat, grid1_lon, & grid2_lat, grid2_lon) endif @@ -3516,13 +3516,13 @@ end subroutine line_integral - subroutine line_integral_phi(weights, num_wts, + subroutine line_integral_phi(weights, num_wts, & in_phi1, in_phi2, theta1, theta2, & grid1_lat, grid1_lon, grid2_lat, grid2_lon) !----------------------------------------------------------------------- ! -! this routine computes the line integral of the flux function +! this routine computes the line integral of the flux function ! that results in the interpolation weights. the line is defined ! by the input lat/lon of the endpoints. Integration is w.r.t. lon ! @@ -3537,7 +3537,7 @@ subroutine line_integral_phi(weights, num_wts, integer (SCRIP_i4), intent(in) :: & num_wts ! number of weights to compute - real (SCRIP_r8), intent(in) :: + real (SCRIP_r8), intent(in) :: & in_phi1, in_phi2, ! longitude endpoints for the segment & theta1, theta2, ! latitude endpoints for the segment & grid1_lat, grid1_lon, ! reference coordinates for each @@ -3676,13 +3676,13 @@ end subroutine line_integral_phi !*********************************************************************** - subroutine line_integral_theta(weights, num_wts, + subroutine line_integral_theta(weights, num_wts, & in_phi1, in_phi2, theta1, theta2, & grid1_lat, grid1_lon, grid2_lat, grid2_lon) !----------------------------------------------------------------------- ! -! this routine computes the line integral of the flux function +! this routine computes the line integral of the flux function ! that results in the interpolation weights. the line is defined ! by the input lat/lon of the endpoints. Integration is w.r.t. lat ! @@ -3698,7 +3698,7 @@ subroutine line_integral_theta(weights, num_wts, integer (SCRIP_i4), intent(in) :: & num_wts ! number of weights to compute - real (SCRIP_r8), intent(in) :: + real (SCRIP_r8), intent(in) :: & in_phi1, in_phi2, ! longitude endpoints for the segment & theta1, theta2, ! latitude endpoints for the segment & grid1_lat, grid1_lon, ! reference coordinates for each @@ -3720,7 +3720,7 @@ subroutine line_integral_theta(weights, num_wts, !----------------------------------------------------------------------- real (SCRIP_r8) :: dtheta, dtheta2, costh1, costh2, costhpi, - & phi1, phi2, theta_pi, f1, f2, fpi, + & phi1, phi2, theta_pi, f1, f2, fpi, & fm, costhm, part1, part2 !----------------------------------------------------------------------- @@ -3805,36 +3805,36 @@ subroutine line_integral_theta(weights, num_wts, ! print *, 'phi1',phi1,' phi2',phi2 ! print *, 'theta1',theta1,' theta2',theta2 ! print *, 'theta_pi',theta_pi - + costhpi = COS(theta_pi) fpi = pi*costhpi - fm = half*(phi1+pi)*cos(half*(theta1+theta_pi)) + fm = half*(phi1+pi)*cos(half*(theta1+theta_pi)) part1 = (theta_pi - theta1)*(f1 + 4*fm + fpi)/6.0 fm = half*(phi2-pi)*cos(half*(theta1+theta_pi)) part2 = 0.5*(theta2 - theta_pi)*(-fpi + 4*fm + f2)/6.0 - weights(1) = part1 + part2 + weights(1) = part1 + part2 ! write(401,*)weights(1),' % B' - + part1 = 0.5*(theta_pi - theta1)*(theta1*f1 + theta_pi*fpi) part2 = 0.5*(theta2 - theta_pi)*(-theta_pi*fpi + theta2*f2) - weights(2) = part1 + part2 - - + weights(2) = part1 + part2 + + else ! Means phi2-phi1 > pi - + ! theta at phi = -pi theta_pi = theta1 + (-pi - phi1)*dtheta/(phi2 - pi2 - phi1) ! print *, '' ! print *, 'phi1',phi1,' phi2',phi2 ! print *, 'theta1',theta1,' theta2',theta2 ! print *, 'theta_pi',theta_pi - + costhpi = COS(theta_pi) fpi = pi*costhpi - + fm = half*(phi1-pi)*cos(half*(theta1+theta_pi)) part1 = 0.5*(theta_pi - theta1)*(f1 + 4*fm - fpi)/6.0 @@ -3842,58 +3842,58 @@ subroutine line_integral_theta(weights, num_wts, part2 = 0.5*(theta2 - theta_pi)*(fpi + 4*fm + f2)/6.0 weights(1) = part1 + part2 ! write(401,*)weights(1),' % C' - + part1 = 0.5*(theta_pi - theta1)*(theta1*f1 - theta_pi*fpi) part2 = 0.5*(theta2 - theta_pi)*(theta_pi*fpi + theta2*f2) weights(2) = part1 + part2 - - + + endif - + part1 = 0.25*(theta_pi - theta1)*(f1*f1 + fpi*fpi) part2 = 0.25*(theta2 - theta_pi)*(fpi*fpi + f2*f2) weights(3) = part1 + part2 - + endif - - + + phi1 = in_phi1 - grid2_lon if (phi1 > pi) then phi1 = phi1 - pi2 else if (phi1 < -pi) then phi1 = phi1 + pi2 endif - + phi2 = in_phi2 - grid2_lon if (phi2 > pi) then phi2 = phi2 - pi2 else if (phi2 < -pi) then phi2 = phi2 + pi2 endif - - + + f1 = phi1*costh1 f2 = phi2*costh2 - + if ((phi2-phi1) < pi .and. (phi2-phi1) > -pi) then fm = half*(phi1+phi2)*costhm weights(num_wts+1) = dtheta2*(f1 + f2) - + weights(num_wts+2) = dtheta2*(theta1*f1 + theta2*f2) - + weights(num_wts+3) = half*dtheta2*(f1*f1 + f2*f2) - + else if (phi1 > zero) then - + theta_pi = theta1 + (pi - phi1)*dtheta/(phi2 + pi2 - phi1) ! print *, '' ! print *, 'phi1',phi1,' phi2',phi2 ! print *, 'theta1',theta1,' theta2',theta2 ! print *, 'theta_pi',theta_pi - + costhpi = COS(theta_pi) fpi = pi*costhpi @@ -3903,40 +3903,40 @@ subroutine line_integral_theta(weights, num_wts, fm = half*(-pi+phi2)*cos(half*(theta2+theta_pi)) part2 = (theta2 - theta_pi)*(-fpi + 4*fm + f2)/6.0 weights(num_wts+1) = part1 + part2 - + part1 = 0.5*(theta_pi - theta1)*(theta1*f1 + theta_pi*fpi) part2 = 0.5*(theta2 - theta_pi)*(-theta_pi*fpi + theta2*f2) weights(num_wts+2) = part1 + part2 - - + + else - + theta_pi = theta1 + (-pi - phi1)*dtheta/(phi2 - pi2 - phi1) ! print *, '' ! print *, 'phi1',phi1,' phi2',phi2 ! print *, 'theta1',theta1,' theta2',theta2 ! print *, 'theta_pi',theta_pi - + costhpi = COS(theta_pi) fpi = pi*costhpi - + fm = half*(phi1-pi)*cos(half*(theta1+theta_pi)) part1 = (theta_pi - theta1)*(f1 +4*fm - fpi)/6.0 fm = half*(phi2+pi)*cos(half*(theta2+theta_pi)) part2 = 0.5*(theta2 - theta_pi)*(fpi + 4*fm + f2)/6.0 weights(num_wts+1) = part1 + part2 - + part1 = 0.5*(theta_pi - theta1)*(theta1*f1 - theta_pi*fpi) part2 = 0.5*(theta2 - theta_pi)*(theta_pi*fpi + theta2*f2) weights(num_wts+2) = part1 + part2 - + endif - + part1 = 0.25*(theta_pi - theta1)*(f1*f1 + fpi*fpi) part2 = 0.25*(theta2 - theta_pi)*(fpi*fpi + f2*f2) weights(num_wts+3) = part1 + part2 - + endif !----------------------------------------------------------------------- @@ -3996,7 +3996,7 @@ subroutine store_link_cnsrv(add1, add2, weights) !----------------------------------------------------------------------- C$OMP CRITICAL(block5) -! first_call should be within critical block or else multiple +! first_call should be within critical block or else multiple ! threads will see it as true the first time around if (first_call_store_link_cnsrv) then @@ -4032,7 +4032,7 @@ subroutine store_link_cnsrv(add1, add2, weights) C$OMP CRITICAL(block3a) wts_map1(:,nlink) = wts_map1(:,nlink) + weights(1:num_wts) if (num_maps == 2) then - wts_map2(:,nlink) = wts_map2(:,nlink) + + wts_map2(:,nlink) = wts_map2(:,nlink) + & weights(num_wts+1:2*num_wts) endif C$OMP END CRITICAL(block3a) @@ -4048,8 +4048,8 @@ subroutine store_link_cnsrv(add1, add2, weights) !----------------------------------------------------------------------- ! -! if the link does not yet exist, increment number of links and -! check to see if remap arrays need to be increased to accomodate +! if the link does not yet exist, increment number of links and +! check to see if remap arrays need to be increased to accomodate ! the new link. then store the link. ! !----------------------------------------------------------------------- @@ -4057,7 +4057,7 @@ subroutine store_link_cnsrv(add1, add2, weights) C$OMP CRITICAL(block6) num_links_map1 = num_links_map1 + 1 - if (num_links_map1 > max_links_map1) + if (num_links_map1 > max_links_map1) & call resize_remap_vars(1,resize_increment) grid1_add_map1(num_links_map1) = add1 @@ -4066,7 +4066,7 @@ subroutine store_link_cnsrv(add1, add2, weights) if (num_maps > 1) then num_links_map2 = num_links_map2 + 1 - if (num_links_map2 > max_links_map2) + if (num_links_map2 > max_links_map2) & call resize_remap_vars(2,resize_increment) grid1_add_map2(num_links_map2) = add1 @@ -4104,11 +4104,11 @@ subroutine locate_segstart(cell_grid_num, cell, !----------------------------------------------------------------------- ! -! intent(in): +! intent(in): ! !----------------------------------------------------------------------- - real (SCRIP_r8), intent(in) :: + real (SCRIP_r8), intent(in) :: & beglat, beglon, ! beginning and end points of segment & endlat, endlon ! on which the point to be located lies @@ -4121,14 +4121,14 @@ subroutine locate_segstart(cell_grid_num, cell, & cell_grid_num ! Index of grid to which cell belongs integer (SCRIP_i4), intent(in) :: - & srch_grid_num ! num indicating if we are locating a + & srch_grid_num ! num indicating if we are locating a ! grid1 point in a cell of grid2 (num=2) - ! or a grid2 point in a cell of grid1 + ! or a grid2 point in a cell of grid1 ! (num=1) !----------------------------------------------------------------------- ! -! intent(out): +! intent(out): ! !----------------------------------------------------------------------- @@ -4136,7 +4136,7 @@ subroutine locate_segstart(cell_grid_num, cell, & cont_cell ! grid cell containing this point logical (SCRIP_logical), intent(out) :: - & lboundary ! flag points that lie on the boundary + & lboundary ! flag points that lie on the boundary ! of the cell integer (SCRIP_i4), intent(out) :: @@ -4156,7 +4156,7 @@ subroutine locate_segstart(cell_grid_num, cell, real (SCRIP_r8), dimension(:), allocatable :: & cell_corner_x, cell_corner_y - logical (SCRIP_logical) :: inpoly, latlon + logical (SCRIP_logical) :: inpoly, latlon real (SCRIP_r8) :: & vec1_x, vec1_y, vec1_lenx, vec1_lat, vec1_lon, vec1_len, @@ -4172,10 +4172,10 @@ subroutine locate_segstart(cell_grid_num, cell, lboundary = .false. edgeid = 0 cont_cell = 0 - - if (cell /= last_cell_locate_segstart .or. - & cell_grid_num /= last_cell_grid_num_locate_segstart + + if (cell /= last_cell_locate_segstart .or. + & cell_grid_num /= last_cell_grid_num_locate_segstart & .or. srch_grid_num /= last_srch_grid_num_locate_segstart) & then @@ -4194,17 +4194,17 @@ subroutine locate_segstart(cell_grid_num, cell, deallocate(srch_add_locate_segstart, & srch_corner_lat_locate_segstart, & srch_corner_lon_locate_segstart, - & srch_center_lat_locate_segstart, + & srch_center_lat_locate_segstart, & srch_center_lon_locate_segstart) endif endif - call get_srch_cells(cell, cell_grid_num, srch_grid_num, - & num_srch_cells_locate_segstart, srch_add_locate_segstart, - & srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart, + call get_srch_cells(cell, cell_grid_num, srch_grid_num, + & num_srch_cells_locate_segstart, srch_add_locate_segstart, + & srch_corners_locate_segstart, + & srch_corner_lat_locate_segstart, & srch_corner_lon_locate_segstart, - & srch_center_lat_locate_segstart, + & srch_center_lat_locate_segstart, & srch_center_lon_locate_segstart) endif @@ -4213,13 +4213,13 @@ subroutine locate_segstart(cell_grid_num, cell, do ic=1,num_srch_cells_locate_segstart - + srch_cell_add = srch_add_locate_segstart(ic) - - !**** CAN WE ACCOMPLISH THE FOLLOWING THROUGH A SUBROUTINE - !**** CALLED SEGSTART_INCELL ?? + + !**** CAN WE ACCOMPLISH THE FOLLOWING THROUGH A SUBROUTINE + !**** CALLED SEGSTART_INCELL ?? !*** IF POINT IS IN POLAR REGION, CHECK IN A TRANSFORMED SPACE @@ -4241,13 +4241,13 @@ subroutine locate_segstart(cell_grid_num, cell, vec1_len = sqrt(vec1_lat*vec1_lat+vec1_lon*vec1_lon) vec1_lat = vec1_lat/vec1_len vec1_lon = vec1_lon/vec1_len - + ptlat = beglat + offset*vec1_lat ptlon = beglon + offset*vec1_lon - - if ((ptlat .gt. north_thresh .and. abs(ptlat-pih) .ge. 0.001) - & .or. + + if ((ptlat .gt. north_thresh .and. abs(ptlat-pih) .ge. 0.001) + & .or. & (ptlat .lt. south_thresh .and. abs(ptlat+pih) .ge. 0.001)) & then @@ -4259,12 +4259,12 @@ subroutine locate_segstart(cell_grid_num, cell, rns = -one endif - + begx = rns*two*sin(pi4 - half*beglat)*cos(beglon) begy = two*sin(pi4 - half*beglat)*sin(beglon) endx = rns*two*sin(pi4 - half*endlat)*cos(endlon) endy = two*sin(pi4 - half*endlat)*sin(endlon) - + vec1_x = endx-begx vec1_y = endy-begy @@ -4273,7 +4273,7 @@ subroutine locate_segstart(cell_grid_num, cell, vec1_y = vec1_y/vec1_lenx - !*** Must calculate ptx and pty as an offset on straight + !*** Must calculate ptx and pty as an offset on straight !*** line in polar space rather than calculating it on a !*** straight line in latlon space an offset point in latlon !*** space will be off the straight line in polar space @@ -4283,9 +4283,9 @@ subroutine locate_segstart(cell_grid_num, cell, latlon = .false. - ! Since we want greater fidelity for locating the points + ! Since we want greater fidelity for locating the points ! we send in the mid-points of the polygon edges too - ! BUT THAT MAKES THE POLYGON NON-CONVEX SOMETIMES AND + ! BUT THAT MAKES THE POLYGON NON-CONVEX SOMETIMES AND ! THE CROSS-PRODUCT CHECK FAILS. SO USE CODE TO CHECK GENERAL ! POLYGONS @@ -4301,11 +4301,11 @@ subroutine locate_segstart(cell_grid_num, cell, lon = srch_corner_lon_locate_segstart(i,ic) cell_corner_x(k) = rns*two*sin(pi4-half*lat)*cos(lon) cell_corner_y(k) = two*sin(pi4-half*lat)*sin(lon) - + j = i-1 - if (j .eq. 0) j = srch_corners_locate_segstart ! how do + if (j .eq. 0) j = srch_corners_locate_segstart ! how do ! we do (j-1+n)%n in F90? - + vec1_lat = srch_corner_lat_locate_segstart(j,ic) & -srch_corner_lat_locate_segstart(i,ic) vec1_lon = srch_corner_lon_locate_segstart(j,ic) @@ -4332,7 +4332,7 @@ subroutine locate_segstart(cell_grid_num, cell, & cell_corner_y, latlon, inpoly, lboundary, edgeid) if (lboundary) then - edgeid = (edgeid-1)/npseg + 1 ! convert from index in + edgeid = (edgeid-1)/npseg + 1 ! convert from index in ! multi-segmented to regular cell endif @@ -4341,68 +4341,68 @@ subroutine locate_segstart(cell_grid_num, cell, else latlon = .true. - + whichpole = 0 - if (srch_grid_num .eq. 1 .and. + if (srch_grid_num .eq. 1 .and. & srch_cell_add .eq. grid1_spole_cell) then - + whichpole = -1 ! S pole - call ptinpolarpoly(ptlat, ptlon, + call ptinpolarpoly(ptlat, ptlon, & srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart(:,ic), + & srch_corner_lat_locate_segstart(:,ic), & srch_corner_lon_locate_segstart(:,ic), & latlon, whichpole, inpoly, lboundary, edgeid) - + else if (srch_grid_num .eq. 1 .and. & srch_cell_add .eq. grid1_npole_cell) then - + whichpole = 1 ! N pole - call ptinpolarpoly(ptlat, ptlon, + call ptinpolarpoly(ptlat, ptlon, & srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart(:,ic), + & srch_corner_lat_locate_segstart(:,ic), & srch_corner_lon_locate_segstart(:,ic), & latlon, whichpole, inpoly, lboundary, edgeid) - + else if (srch_grid_num .eq. 2 .and. & srch_cell_add .eq. grid2_spole_cell) then - + whichpole = -1 ! S pole - call ptinpolarpoly(ptlat, ptlon, + call ptinpolarpoly(ptlat, ptlon, & srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart(:,ic), + & srch_corner_lat_locate_segstart(:,ic), & srch_corner_lon_locate_segstart(:,ic), & latlon, whichpole, inpoly, lboundary, edgeid) - + else if (srch_grid_num .eq. 2 .and. & srch_cell_add .eq. grid2_npole_cell) then - + whichpole = 1 ! N pole - call ptinpolarpoly(ptlat, ptlon, + call ptinpolarpoly(ptlat, ptlon, & srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart(:,ic), + & srch_corner_lat_locate_segstart(:,ic), & srch_corner_lon_locate_segstart(:,ic), & latlon, whichpole, inpoly, lboundary, edgeid) - + else - + !*** !*** General cell !*** - + call ptinpoly(ptlat, ptlon, srch_corners_locate_segstart, - & srch_corner_lat_locate_segstart(:,ic), + & srch_corner_lat_locate_segstart(:,ic), & srch_corner_lon_locate_segstart(:,ic), & latlon, inpoly, lboundary, edgeid) - + endif - + endif if (inpoly) then cont_cell = srch_cell_add exit - endif - + endif + end do return @@ -4431,11 +4431,11 @@ subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, !----------------------------------------------------------------------- ! -! intent(in): +! intent(in): ! !----------------------------------------------------------------------- - real (SCRIP_r8), intent(in) :: + real (SCRIP_r8), intent(in) :: & ptlat, ptlon ! Point to locate integer (SCRIP_i4), intent(in) :: @@ -4444,14 +4444,14 @@ subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, & cell_grid_num ! Index of grid to which cell belongs integer (SCRIP_i4), intent(in) :: - & srch_grid_num ! num indicating if we are locating a + & srch_grid_num ! num indicating if we are locating a ! grid1 point in a cell of grid2 (num=2) ! or a grid2 point in a cell of grid1 ! (num=1) !----------------------------------------------------------------------- ! -! intent(out): +! intent(out): ! !----------------------------------------------------------------------- @@ -4459,7 +4459,7 @@ subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, & cont_cell ! grid cell containing this point logical (SCRIP_logical), intent(out) :: - & lboundary ! flag points that lie on the boundary + & lboundary ! flag points that lie on the boundary ! of the cell integer (SCRIP_i4), intent(out) :: @@ -4475,7 +4475,7 @@ subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, integer (SCRIP_i4) :: i, j, n, ic integer (SCRIP_i4) :: whichpole, srch_cell_add, & grid1_add, grid2_add, min_add, max_add, - & previdx, nextidx, pcorner, corner, + & previdx, nextidx, pcorner, corner, & ncorners, nalloc real (SCRIP_r8), dimension(:), allocatable :: @@ -4490,7 +4490,7 @@ subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, & cell_center_lon - logical (SCRIP_logical) :: inpoly, latlon + logical (SCRIP_logical) :: inpoly, latlon logical (SCRIP_logical) :: test !----------------------------------------------------------------------- @@ -4504,7 +4504,7 @@ subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, cont_cell = 0 if (cell /= last_cell_locate_point .or. cell_grid_num /= - & last_cell_grid_num_locate_point + & last_cell_grid_num_locate_point & .or. srch_grid_num /= last_srch_grid_num_locate_point) then last_cell_locate_point = cell @@ -4525,9 +4525,9 @@ subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, endif endif - call get_srch_cells(cell, cell_grid_num, srch_grid_num, + call get_srch_cells(cell, cell_grid_num, srch_grid_num, & num_srch_cell_locate_points, srch_add_locate_point, - & srch_corners_locate_point, + & srch_corners_locate_point, & srch_corner_lat_locate_point,srch_corner_lon_locate_point, & srch_center_lat_locate_point,srch_center_lon_locate_point) @@ -4543,18 +4543,18 @@ subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, do ic=1,num_srch_cell_locate_points - + srch_cell_add = srch_add_locate_point(ic) do i = 1, ncorners cell_corner_lat(i) = srch_corner_lat_locate_point(i,ic) cell_corner_lon(i) = srch_corner_lon_locate_point(i,ic) enddo - + cell_center_lat = srch_center_lat_locate_point(ic) cell_center_lon = srch_center_lon_locate_point(ic) -! if ((srch_grid_num .eq. 1 .and. +! if ((srch_grid_num .eq. 1 .and. ! & (special_polar_cell1(srch_cell_add))) .or. ! & (srch_grid_num .eq. 2 .and. ! & (special_polar_cell2(srch_cell_add)))) then @@ -4581,13 +4581,13 @@ subroutine locate_point(ptlat, ptlon, cell, cell_grid_num, & cell_center_lat, cell_center_lon, & srch_grid_num, inpoly, lboundary, edgeid) - + if (inpoly) then cont_cell = srch_cell_add exit - endif + endif - ncorners = srch_corners_locate_point ! reset it for other srch + ncorners = srch_corners_locate_point ! reset it for other srch !cells end do @@ -4601,7 +4601,7 @@ end subroutine locate_point !********************************************************************** - subroutine ptincell(ptlat, ptlon, cell_add, ncorners, + subroutine ptincell(ptlat, ptlon, cell_add, ncorners, & cell_corner_lat, cell_corner_lon, & cell_center_lat, cell_center_lon, & cell_grid_id, inpoly, lboundary, edgeid) @@ -4612,35 +4612,35 @@ subroutine ptincell(ptlat, ptlon, cell_add, ncorners, !----------------------------------------------------------------------- ! -! intent(in): +! intent(in): ! !----------------------------------------------------------------------- - real (SCRIP_r8), intent(in) :: + real (SCRIP_r8), intent(in) :: & ptlat, ptlon ! Point to locate integer (SCRIP_i4), intent(in) :: & cell_add ! ID of cell integer (SCRIP_i4), intent(in) :: - & ncorners + & ncorners real (SCRIP_r8), dimension(ncorners), intent(in) :: & cell_corner_lat, cell_corner_lon real (SCRIP_r8), intent(in) :: - & cell_center_lat, + & cell_center_lat, & cell_center_lon integer (SCRIP_i4), intent(in) :: & cell_grid_id ! num indicating if we are locating a grid1 - ! point in a cell of grid2 (num = 2) or + ! point in a cell of grid2 (num = 2) or ! a grid2 point in a cell of grid1 (num = 1) !----------------------------------------------------------------------- ! -! intent(out): +! intent(out): ! !----------------------------------------------------------------------- @@ -4648,7 +4648,7 @@ subroutine ptincell(ptlat, ptlon, cell_add, ncorners, & inpoly ! is point in polygon? logical (SCRIP_logical), intent(out) :: - & lboundary ! flag points that lie on the boundary + & lboundary ! flag points that lie on the boundary ! of the cell integer (SCRIP_i4), intent(out) :: @@ -4687,7 +4687,7 @@ subroutine ptincell(ptlat, ptlon, cell_add, ncorners, !*** if ((ptlat .gt. north_thresh .and. abs(ptlat-pih) .ge. 0.001) .or. - & (ptlat .lt. south_thresh .and. abs(ptlat+pih) .ge. 0.001)) + & (ptlat .lt. south_thresh .and. abs(ptlat+pih) .ge. 0.001)) & then if (ptlat > zero) then @@ -4700,12 +4700,12 @@ subroutine ptincell(ptlat, ptlon, cell_add, ncorners, ptx = rns*two*sin(pi4 - half*ptlat)*cos(ptlon) pty = two*sin(pi4 - half*ptlat)*sin(ptlon) - + latlon = .false. - ! Since we want greater fidelity for locating the points + ! Since we want greater fidelity for locating the points ! we send in the mid-points of the polygon edges too - ! BUT THAT MAKES THE POLYGON NON-CONVEX SOMETIMES AND + ! BUT THAT MAKES THE POLYGON NON-CONVEX SOMETIMES AND ! THE CROSS-PRODUCT CHECK FAILS. SO USE CODE TO CHECK GENERAL ! POLYGONS @@ -4717,7 +4717,7 @@ subroutine ptincell(ptlat, ptlon, cell_add, ncorners, lon = cell_corner_lon(i) cell_corner_x(k) = rns*two*sin(pi4-half*lat)*cos(lon) cell_corner_y(k) = two*sin(pi4-half*lat)*sin(lon) - + j = i-1 if (j .eq. 0) j = ncorners ! how do we do (j-1+n)%n in F90? @@ -4745,54 +4745,54 @@ subroutine ptincell(ptlat, ptlon, cell_add, ncorners, & cell_corner_y, latlon, inpoly, lboundary, edgeid) if (lboundary) then - edgeid = (edgeid-1)/npseg + 1 ! convert from index in - ! multi-segmented cell to + edgeid = (edgeid-1)/npseg + 1 ! convert from index in + ! multi-segmented cell to ! regular cell endif else latlon = .true. - + whichpole = 0 - if (cell_grid_id .eq. 1 .and. + if (cell_grid_id .eq. 1 .and. & cell_add .eq. grid1_spole_cell) then - + whichpole = -1 ! S pole call ptinpolarpoly(ptlat, ptlon, ncorners, & cell_corner_lat, cell_corner_lon, & latlon, whichpole, inpoly, lboundary, edgeid) - + else if (cell_grid_id .eq. 1 .and. & cell_add .eq. grid1_npole_cell) then - + whichpole = 1 ! N pole call ptinpolarpoly(ptlat, ptlon, ncorners, & cell_corner_lat, cell_corner_lon, & latlon, whichpole, inpoly, lboundary, edgeid) - + else if (cell_grid_id .eq. 2 .and. & cell_add .eq. grid2_spole_cell) then - + whichpole = -1 ! S pole call ptinpolarpoly(ptlat, ptlon, ncorners, & cell_corner_lat, cell_corner_lon, & latlon, whichpole, inpoly, lboundary, edgeid) - + else if (cell_grid_id .eq. 2 .and. & cell_add .eq. grid2_npole_cell) then - + whichpole = 1 ! N pole call ptinpolarpoly(ptlat, ptlon, ncorners, & cell_corner_lat, cell_corner_lon, & latlon, whichpole, inpoly, lboundary, edgeid) - + else - + !*** !*** General cell !*** - - call ptinpoly(ptlat, ptlon, ncorners, + + call ptinpoly(ptlat, ptlon, ncorners, & cell_corner_lat, cell_corner_lon, & latlon, inpoly, lboundary, edgeid) @@ -4815,7 +4815,7 @@ subroutine ptinpoly(ptx, pty, ncorners, cell_corner_x, !---------------------------------------------------------------------- ! -! Check if point is in (convex) polygonal cell +! Check if point is in (convex) polygonal cell ! !---------------------------------------------------------------------- @@ -4874,42 +4874,42 @@ subroutine ptinpoly(ptx, pty, ncorners, cell_corner_x, !*********************************************************** !*** We should just remove the latlon argument since that is !*** the only coordinate system we are using it for - !*********************************************************** - + !*********************************************************** + !*** - !*** here we take the cross product of the vector making + !*** here we take the cross product of the vector making !*** up each cell side with the vector formed by the vertex - !*** and search point. if all the cross products are + !*** and search point. if all the cross products are !*** positive, the point is contained in the cell. !*** inpoly = .false. lboundary = .false. edgeid = 0 - + if (.not. latlon) then - + do n = 1, ncorners next_n = MOD(n,ncorners) + 1 - + x1 = cell_corner_x(n) y1 = cell_corner_y(n) x2 = cell_corner_x(next_n) y2 = cell_corner_y(next_n) - + vec1_x = x2 - x1 vec1_y = y2 - y1 vec2_x = ptx - x1 vec2_y = pty - y1 - + cross_product = vec1_y*vec2_x - vec2_y*vec1_x - + !*** - !*** if the cross product for a side is zero, the point + !*** if the cross product for a side is zero, the point !*** lies exactly on the side or the side is degenerate - !*** (zero length). if degenerate, set the cross - !*** product to a positive number. + !*** (zero length). if degenerate, set the cross + !*** product to a positive number. !*** if (abs(cross_product) < tiny) then @@ -4933,7 +4933,7 @@ subroutine ptinpoly(ptx, pty, ncorners, cell_corner_x, return endif endif - + end do else @@ -4944,7 +4944,7 @@ subroutine ptinpoly(ptx, pty, ncorners, cell_corner_x, cell_corner_lat_loc = cell_corner_x cell_corner_lon_loc = cell_corner_y - + minlon = 9999.0 maxlon = -9999.0 do n = 1, ncorners @@ -4977,24 +4977,24 @@ subroutine ptinpoly(ptx, pty, ncorners, cell_corner_x, do n = 1, ncorners next_n = MOD(n,ncorners) + 1 - + x1 = cell_corner_lat_loc(n) y1 = cell_corner_lon_loc(n) x2 = cell_corner_lat_loc(next_n) y2 = cell_corner_lon_loc(next_n) - + vec1_x = x2 - x1 vec1_y = y2 - y1 vec2_x = ptx_loc - x1 vec2_y = pty_loc - y1 - + cross_product = vec1_y*vec2_x - vec2_y*vec1_x - + !*** - !*** if the cross product for a side is zero, the point + !*** if the cross product for a side is zero, the point !*** lies exactly on the side or the side is degenerate - !*** (zero length). if degenerate, set the cross - !*** product to a positive number. + !*** (zero length). if degenerate, set the cross + !*** product to a positive number. !*** if (abs(cross_product) < tiny) then @@ -5018,7 +5018,7 @@ subroutine ptinpoly(ptx, pty, ncorners, cell_corner_x, return endif endif - + end do endif @@ -5043,12 +5043,12 @@ subroutine ptinpolarpoly(ptx, pty, ncorners, cell_corner_x, !---------------------------------------------------------------------- ! ! Check if point is in polygonal cell overlapping the pole -! Cannot check the containment as is in latlon space - We have +! Cannot check the containment as is in latlon space - We have ! to check by connecting each edge of the polygon to the pole -! and check containment in the resulting quadrilateral in latlon +! and check containment in the resulting quadrilateral in latlon ! space ! The cell can be non-convex as long as the pole is 'visible' to -! all the edges of the polygon, i.e., we can connect the pole to +! all the edges of the polygon, i.e., we can connect the pole to ! each edge of the polygon and form a triangle with positive area ! !---------------------------------------------------------------------- @@ -5075,7 +5075,7 @@ subroutine ptinpolarpoly(ptx, pty, ncorners, cell_corner_x, & latlon ! Are coordinates in latlon space? integer (SCRIP_i4), intent(in) :: - & whichpole ! South or North pole + & whichpole ! South or North pole !---------------------------------------------------------------------- ! @@ -5103,7 +5103,7 @@ subroutine ptinpolarpoly(ptx, pty, ncorners, cell_corner_x, real (SCRIP_r8), dimension(4) :: & pquad_corner_x, ! Coordinates of polar quad - & pquad_corner_y + & pquad_corner_y real (SCRIP_r8) :: x1, y1, x2, y2, vec1_x, vec1_y, vec2_x, vec2_y, & cross_product, pole_lat @@ -5113,15 +5113,15 @@ subroutine ptinpolarpoly(ptx, pty, ncorners, cell_corner_x, !*** !*** This is a polygon that overlaps the pole !*** A normal point in polygon check could fail - !*** So, with each edge of the polygon form a quadrilateral + !*** So, with each edge of the polygon form a quadrilateral !*** in latlon space using the polar latitude and the longitude !*** values of the endpoints of the edge. Then check containment !*** of the point in this quadrilateral !*** - + inpoly = .false. lboundary = .false. - + do n = 1, ncorners next_n = MOD(n,ncorners) + 1 @@ -5134,8 +5134,8 @@ subroutine ptinpolarpoly(ptx, pty, ncorners, cell_corner_x, pquad_corner_x(4) = pole_lat pquad_corner_y(4) = cell_corner_y(n) - - call ptinpoly(ptx,pty,4,pquad_corner_x,pquad_corner_y, + + call ptinpoly(ptx,pty,4,pquad_corner_x,pquad_corner_y, & latlon,inpoly,lboundary, ledgeid) if (inpoly) then @@ -5144,8 +5144,8 @@ subroutine ptinpolarpoly(ptx, pty, ncorners, cell_corner_x, !*** !*** Check to see if the lboundary flag is being - !*** triggered by the outer edge of the polygon or - !*** by one of the artificial internal edges + !*** triggered by the outer edge of the polygon or + !*** by one of the artificial internal edges !*** vec1_x = pquad_corner_x(2) - pquad_corner_x(1) @@ -5164,7 +5164,7 @@ subroutine ptinpolarpoly(ptx, pty, ncorners, cell_corner_x, if (vec1_y < -pi) vec1_y = vec1_y + pi2 if (vec2_y > pi) vec2_y = vec2_y - pi2 if (vec2_y < -pi) vec2_y = vec2_y + pi2 - + endif cross_product = vec1_y*vec2_x - vec2_y*vec1_x @@ -5172,8 +5172,8 @@ subroutine ptinpolarpoly(ptx, pty, ncorners, cell_corner_x, !*** !*** if the cross product for a side is zero, the point !*** lies exactly on the side or the side is degenerate - !*** (zero length). if degenerate, set the cross - !*** product to a positive number. + !*** (zero length). if degenerate, set the cross + !*** product to a positive number. !*** if (abs(cross_product) < tiny) then @@ -5211,9 +5211,9 @@ subroutine ptinpolygen(ptx, pty, ncorners, cell_corner_x, !---------------------------------------------------------------------- ! -! Check if point is in general (convex or mildly non-convex) +! Check if point is in general (convex or mildly non-convex) ! polygonal cell by connecting each edge of the polygon to a -! a central point (average of vertices) and check containment in +! a central point (average of vertices) and check containment in ! the resulting triangle ! ! The cell can be non-convex as long as the 'center' is 'visible' to @@ -5273,7 +5273,7 @@ subroutine ptinpolygen(ptx, pty, ncorners, cell_corner_x, real (SCRIP_r8), dimension(3) :: & tri_corner_x, ! Coordinates of triangle - & tri_corner_y + & tri_corner_y real (SCRIP_r8) :: x1, y1, x2, y2, vec1_x, vec1_y, vec2_x, vec2_y, & cross_product @@ -5281,13 +5281,13 @@ subroutine ptinpolygen(ptx, pty, ncorners, cell_corner_x, !*** !*** So, with each edge of the polygon form a triangle - !*** by connecting a 'central' point to the endpoints of + !*** by connecting a 'central' point to the endpoints of !*** the edge. Then check containment of the point in this tri !*** - + inpoly = .false. lboundary = .false. - + do n = 1, ncorners next_n = MOD(n,ncorners) + 1 @@ -5304,8 +5304,8 @@ subroutine ptinpolygen(ptx, pty, ncorners, cell_corner_x, !*** Skip triangles arising from degenerate edges if (vec1_x*vec1_x+vec1_y*vec1_y .le. tiny*tiny) cycle - - call ptinpoly(ptx,pty,3,tri_corner_x,tri_corner_y, + + call ptinpoly(ptx,pty,3,tri_corner_x,tri_corner_y, & latlon,inpoly,lboundary, ledgeid) if (inpoly) then @@ -5314,8 +5314,8 @@ subroutine ptinpolygen(ptx, pty, ncorners, cell_corner_x, !*** !*** Check to see if the lboundary flag is being - !*** triggered by the outer edge of the polygon or - !*** by one of the artificial internal edges + !*** triggered by the outer edge of the polygon or + !*** by one of the artificial internal edges !*** vec2_x = ptx - tri_corner_x(1) @@ -5332,7 +5332,7 @@ subroutine ptinpolygen(ptx, pty, ncorners, cell_corner_x, if (vec1_y < -pi) vec1_y = vec1_y + pi2 if (vec2_y > pi) vec2_y = vec2_y - pi2 if (vec2_y < -pi) vec2_y = vec2_y + pi2 - + endif cross_product = vec1_y*vec2_x - vec2_y*vec1_x @@ -5340,8 +5340,8 @@ subroutine ptinpolygen(ptx, pty, ncorners, cell_corner_x, !*** !*** if the cross product for a side is zero, the point !*** lies exactly on the side or the side is degenerate - !*** (zero length). if degenerate, set the cross - !*** product to a positive number. + !*** (zero length). if degenerate, set the cross + !*** product to a positive number. !*** if (abs(cross_product) < tiny) then @@ -5378,13 +5378,13 @@ subroutine ptinpolygen2(ptx, pty, ncorners, cell_corner_x, !---------------------------------------------------------------------- ! -! Check if point is in general (convex or mildly non-convex) +! Check if point is in general (convex or mildly non-convex) ! polygonal cell by connecting each edge of the polygon to a -! a central point (average of vertices) and check containment in +! a central point (average of vertices) and check containment in ! the resulting triangle ! ! The cell can be non-convex as long as the 'center' is 'visible' to -! all the edges of the polygon, i.e., we can connect the 'center' to +! all the edges of the polygon, i.e., we can connect the 'center' to ! each edge of the polygon and form a triangle with positive area ! !---------------------------------------------------------------------- @@ -5441,13 +5441,13 @@ subroutine ptinpolygen2(ptx, pty, ncorners, cell_corner_x, !*** !*** So, with each edge of the polygon form a triangle - !*** by connecting a 'central' point to the endpoints of + !*** by connecting a 'central' point to the endpoints of !*** the edge. Then check containment of the point in this tri !*** - + inpoly = .false. lboundary = .false. - + c = 0 do n = 1, ncorners next_n = MOD(n,ncorners) + 1 @@ -5462,12 +5462,12 @@ subroutine ptinpolygen2(ptx, pty, ncorners, cell_corner_x, & (ptx <= (x1 + (pty-y1)*(x2-x1)/(y2-y1)))) then c = 1 - c - + endif enddo if (c .eq. 1) inpoly = .true. - + !*** Check if the point is on the boundary of the polygon @@ -5495,7 +5495,7 @@ subroutine ptinpolygen2(ptx, pty, ncorners, cell_corner_x, cross_product = cross_product/vec2_len endif - if (abs(cross_product) < 1e5*tiny .and. + if (abs(cross_product) < 1e5*tiny .and. & abs(cross_product) > 10*tiny) then !*** Sometimes when the point is too close to a vertex @@ -5510,7 +5510,7 @@ subroutine ptinpolygen2(ptx, pty, ncorners, cell_corner_x, cross_product = -vec1_x*vec3_y + vec1_y*vec3_x if (abs(cross_product) > tiny .and. vec3_len > tiny) then !*** - !*** Normalize only if we won't be dividing two small + !*** Normalize only if we won't be dividing two small !*** numbers cross_product = cross_product/vec3_len endif @@ -5533,8 +5533,8 @@ subroutine ptinpolygen2(ptx, pty, ncorners, cell_corner_x, endif enddo - - return + + return !---------------------------------------------------------------------- @@ -5550,8 +5550,8 @@ end subroutine ptinpolygen2 ! !---------------------------------------------------------------------- - subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, - & num_srch_cells, srch_add, srch_corners, + subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, + & num_srch_cells, srch_add, srch_corners, & srch_corner_lat, srch_corner_lon, & srch_center_lat, srch_center_lon) @@ -5562,10 +5562,10 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, !---------------------------------------------------------------------- integer (SCRIP_i4), intent(in) :: - & cell_add, ! cell in whose nbrhood we must find other - & cell_grid_num, ! cells grid number from which 'cell_add' + & cell_add, ! cell in whose nbrhood we must find other + & cell_grid_num, ! cells grid number from which 'cell_add' & srch_grid_num ! is grid number in which we must find - ! search cells + ! search cells !---------------------------------------------------------------------- ! @@ -5602,12 +5602,12 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, !----------------------------------------------------------------------- num_srch_cells = 0 - + !*** !*** restrict searches first using search bins !*** - if (last_cell_add_get_srch_cells /= cell_add .or. + if (last_cell_add_get_srch_cells /= cell_add .or. & last_cell_grid_num_get_srch_cells /= cell_grid_num .or. & last_srch_grid_num_get_srch_cells /= srch_grid_num) then @@ -5659,17 +5659,17 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, num_srch_cells_loc_get_srch_cells = 0 do grid1_add = min_add,max_add - srch_mask(grid1_add) = - & (grid1_bound_box(1,grid1_add) <= + srch_mask(grid1_add) = + & (grid1_bound_box(1,grid1_add) <= & grid1_bound_box(2,cell_add)) .and. - & (grid1_bound_box(2,grid1_add) >= + & (grid1_bound_box(2,grid1_add) >= & grid1_bound_box(1,cell_add)) .and. - & (grid1_bound_box(3,grid1_add) <= + & (grid1_bound_box(3,grid1_add) <= & grid1_bound_box(4,cell_add)) .and. - & (grid1_bound_box(4,grid1_add) >= + & (grid1_bound_box(4,grid1_add) >= & grid1_bound_box(3,cell_add)) - - if (srch_mask(grid1_add)) + + if (srch_mask(grid1_add)) & num_srch_cells_loc_get_srch_cells = & num_srch_cells_loc_get_srch_cells+1 end do @@ -5696,13 +5696,13 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, if (srch_mask(grid1_add)) then n = n+1 srch_add_loc_get_srch_cells(n) = grid1_add - srch_corner_lat_loc_get_srch_cells(:,n) = + srch_corner_lat_loc_get_srch_cells(:,n) = & grid1_corner_lat(:,grid1_add) - srch_corner_lon_loc_get_srch_cells(:,n) = + srch_corner_lon_loc_get_srch_cells(:,n) = & grid1_corner_lon(:,grid1_add) - srch_center_lat_loc_get_srch_cells(n) = + srch_center_lat_loc_get_srch_cells(n) = & grid1_center_lat(grid1_add) - srch_center_lon_loc_get_srch_cells(n) = + srch_center_lon_loc_get_srch_cells(n) = & grid1_center_lon(grid1_add) endif end do @@ -5713,7 +5713,7 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, deallocate(srch_mask) else - + !*** Grid 2 neighbors of grid 1 cell allocate(srch_mask(grid2_size)) @@ -5734,20 +5734,20 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, num_srch_cells_loc_get_srch_cells = 0 do grid2_add = min_add,max_add - srch_mask(grid2_add) = - & (grid2_bound_box(1,grid2_add) <= + srch_mask(grid2_add) = + & (grid2_bound_box(1,grid2_add) <= & grid1_bound_box(2,cell_add)) .and. - & (grid2_bound_box(2,grid2_add) >= + & (grid2_bound_box(2,grid2_add) >= & grid1_bound_box(1,cell_add)) .and. - & (grid2_bound_box(3,grid2_add) <= + & (grid2_bound_box(3,grid2_add) <= & grid1_bound_box(4,cell_add)) .and. - & (grid2_bound_box(4,grid2_add) >= + & (grid2_bound_box(4,grid2_add) >= & grid1_bound_box(3,cell_add)) - - if (srch_mask(grid2_add)) - & num_srch_cells_loc_get_srch_cells = + + if (srch_mask(grid2_add)) + & num_srch_cells_loc_get_srch_cells = & num_srch_cells_loc_get_srch_cells+1 end do @@ -5774,17 +5774,17 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, if (srch_mask(grid2_add)) then n = n+1 srch_add_loc_get_srch_cells(n) = grid2_add - srch_corner_lat_loc_get_srch_cells(:,n) = + srch_corner_lat_loc_get_srch_cells(:,n) = & grid2_corner_lat(:,grid2_add) - srch_corner_lon_loc_get_srch_cells(:,n) = + srch_corner_lon_loc_get_srch_cells(:,n) = & grid2_corner_lon(:,grid2_add) - srch_center_lat_loc_get_srch_cells(n) = + srch_center_lat_loc_get_srch_cells(n) = & grid2_center_lat(grid2_add) - srch_center_lon_loc_get_srch_cells(n) = + srch_center_lon_loc_get_srch_cells(n) = & grid2_center_lon(grid2_add) endif end do - + srch_corners_loc_get_srch_cells = grid2_corners endif @@ -5815,18 +5815,18 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, num_srch_cells_loc_get_srch_cells = 0 do grid1_add = min_add,max_add - srch_mask(grid1_add) = - & (grid1_bound_box(1,grid1_add) <= + srch_mask(grid1_add) = + & (grid1_bound_box(1,grid1_add) <= & grid2_bound_box(2,cell_add)) .and. - & (grid1_bound_box(2,grid1_add) >= + & (grid1_bound_box(2,grid1_add) >= & grid2_bound_box(1,cell_add)) .and. - & (grid1_bound_box(3,grid1_add) <= + & (grid1_bound_box(3,grid1_add) <= & grid2_bound_box(4,cell_add)) .and. - & (grid1_bound_box(4,grid1_add) >= + & (grid1_bound_box(4,grid1_add) >= & grid2_bound_box(3,cell_add)) - if (srch_mask(grid1_add)) - & num_srch_cells_loc_get_srch_cells = + if (srch_mask(grid1_add)) + & num_srch_cells_loc_get_srch_cells = & num_srch_cells_loc_get_srch_cells+1 end do @@ -5853,13 +5853,13 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, if (srch_mask(grid1_add)) then n = n+1 srch_add_loc_get_srch_cells(n) = grid1_add - srch_corner_lat_loc_get_srch_cells(:,n) = + srch_corner_lat_loc_get_srch_cells(:,n) = & grid1_corner_lat(:,grid1_add) - srch_corner_lon_loc_get_srch_cells(:,n) = + srch_corner_lon_loc_get_srch_cells(:,n) = & grid1_corner_lon(:,grid1_add) - srch_center_lat_loc_get_srch_cells(n) = + srch_center_lat_loc_get_srch_cells(n) = & grid1_center_lat(grid1_add) - srch_center_lon_loc_get_srch_cells(n) = + srch_center_lon_loc_get_srch_cells(n) = & grid1_center_lon(grid1_add) endif end do @@ -5891,21 +5891,21 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, num_srch_cells_loc_get_srch_cells = 0 do grid2_add = min_add,max_add - srch_mask(grid2_add) = - & (grid2_bound_box(1,grid2_add) <= + srch_mask(grid2_add) = + & (grid2_bound_box(1,grid2_add) <= & grid2_bound_box(2,cell_add)) .and. - & (grid2_bound_box(2,grid2_add) >= + & (grid2_bound_box(2,grid2_add) >= & grid2_bound_box(1,cell_add)) .and. - & (grid2_bound_box(3,grid2_add) <= + & (grid2_bound_box(3,grid2_add) <= & grid2_bound_box(4,cell_add)) .and. - & (grid2_bound_box(4,grid2_add) >= + & (grid2_bound_box(4,grid2_add) >= & grid2_bound_box(3,cell_add)) - if (srch_mask(grid2_add)) - & num_srch_cells_loc_get_srch_cells = + if (srch_mask(grid2_add)) + & num_srch_cells_loc_get_srch_cells = & num_srch_cells_loc_get_srch_cells+1 end do - + if (num_srch_cells_loc_get_srch_cells /= 0) then @@ -5929,17 +5929,17 @@ subroutine get_srch_cells(cell_add, cell_grid_num, srch_grid_num, if (srch_mask(grid2_add)) then n = n+1 srch_add_loc_get_srch_cells(n) = grid2_add - srch_corner_lat_loc_get_srch_cells(:,n) = + srch_corner_lat_loc_get_srch_cells(:,n) = & grid2_corner_lat(:,grid2_add) - srch_corner_lon_loc_get_srch_cells(:,n) = + srch_corner_lon_loc_get_srch_cells(:,n) = & grid2_corner_lon(:,grid2_add) - srch_center_lat_loc_get_srch_cells(n) = + srch_center_lat_loc_get_srch_cells(n) = & grid2_center_lat(grid2_add) - srch_center_lon_loc_get_srch_cells(n) = + srch_center_lon_loc_get_srch_cells(n) = & grid2_center_lon(grid2_add) endif end do - + srch_corners_loc_get_srch_cells = grid2_corners endif @@ -5982,8 +5982,8 @@ end subroutine get_srch_cells ! !---------------------------------------------------------------------- - subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, - & adj_add) + subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, + & adj_add) !---------------------------------------------------------------------- ! @@ -6027,7 +6027,7 @@ subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, lon2 = grid1_corner_lon(inx,cell_add) !*** - !*** Often the cell with the next or previous index is + !*** Often the cell with the next or previous index is !*** the adjacent cell. Check that first !*** @@ -6037,45 +6037,45 @@ subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, do i = 1, grid1_corners inx = mod(i,grid1_corners)+1 - if (abs(grid1_corner_lat(inx,global_add)-lat1) .le. tiny + if (abs(grid1_corner_lat(inx,global_add)-lat1) .le. tiny & .and. - & abs(grid1_corner_lat(i,global_add)-lat2) .le. tiny + & abs(grid1_corner_lat(i,global_add)-lat2) .le. tiny & .and. & abs(grid1_corner_lon(inx,global_add)-lon1) .le. tiny & .and. - & abs(grid1_corner_lon(i,global_add)-lon2) .le. tiny) + & abs(grid1_corner_lon(i,global_add)-lon2) .le. tiny) & then - + adj_add = global_add return endif enddo endif - + if (cell_add .gt. 1) then - + global_add = cell_add - 1 do i = 1, grid1_corners inx = mod(i,grid1_corners)+1 - if (abs(grid1_corner_lat(inx,global_add)-lat1) .le. tiny + if (abs(grid1_corner_lat(inx,global_add)-lat1) .le. tiny & .and. - & abs(grid1_corner_lat(i,global_add)-lat2) .le. tiny + & abs(grid1_corner_lat(i,global_add)-lat2) .le. tiny & .and. & abs(grid1_corner_lon(inx,global_add)-lon1) .le. tiny & .and. - & abs(grid1_corner_lon(i,global_add)-lon2) .le. tiny) + & abs(grid1_corner_lon(i,global_add)-lon2) .le. tiny) & then - + adj_add = global_add return endif enddo endif - - + + else @@ -6089,7 +6089,7 @@ subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, !*** - !*** Often the cell with the next or previous index is + !*** Often the cell with the next or previous index is !*** the adjacent cell. Check that first !*** @@ -6099,49 +6099,49 @@ subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, do i = 1, grid2_corners inx = mod(i,grid2_corners)+1 - if (abs(grid2_corner_lat(inx,global_add)-lat1) .le. tiny + if (abs(grid2_corner_lat(inx,global_add)-lat1) .le. tiny & .and. - & abs(grid2_corner_lat(i,global_add)-lat2) .le. tiny + & abs(grid2_corner_lat(i,global_add)-lat2) .le. tiny & .and. & abs(grid2_corner_lon(inx,global_add)-lon1) .le. tiny & .and. - & abs(grid2_corner_lon(i,global_add)-lon2) .le. tiny) + & abs(grid2_corner_lon(i,global_add)-lon2) .le. tiny) & then - + adj_add = global_add return endif enddo endif - + if (cell_add .gt. 1) then - + global_add = cell_add - 1 do i = 1, grid2_corners inx = mod(i,grid2_corners)+1 - if (abs(grid2_corner_lat(inx,global_add)-lat1) .le. tiny + if (abs(grid2_corner_lat(inx,global_add)-lat1) .le. tiny & .and. - & abs(grid2_corner_lat(i,global_add)-lat2) .le. tiny + & abs(grid2_corner_lat(i,global_add)-lat2) .le. tiny & .and. & abs(grid2_corner_lon(inx,global_add)-lon1) .le. tiny & .and. - & abs(grid2_corner_lon(i,global_add)-lon2) .le. tiny) + & abs(grid2_corner_lon(i,global_add)-lon2) .le. tiny) & then - + adj_add = global_add return endif enddo endif - + endif - if (cell_add /= last_cell_find_adj_cell .or. + if (cell_add /= last_cell_find_adj_cell .or. & cell_grid_num /= last_cell_grid_num_find_adj_cell) then last_cell_find_adj_cell = cell_add @@ -6153,19 +6153,19 @@ subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, last_cell_grid_num_find_adj_cell = 0 else if (num_srch_cells_find_adj_cell .gt. 0) then - deallocate(srch_add_find_adj_cell, - & srch_corner_lat_find_adj_cell, + deallocate(srch_add_find_adj_cell, + & srch_corner_lat_find_adj_cell, & srch_corner_lon_find_adj_cell, - & srch_center_lat_find_adj_cell, + & srch_center_lat_find_adj_cell, & srch_center_lon_find_adj_cell) endif endif call get_srch_cells(cell_add, cell_grid_num, cell_grid_num, - & num_srch_cells_find_adj_cell, srch_add_find_adj_cell, + & num_srch_cells_find_adj_cell, srch_add_find_adj_cell, & srch_corners_find_adj_cell, srch_corner_lat_find_adj_cell, - & srch_corner_lon_find_adj_cell, - & srch_center_lat_find_adj_cell, + & srch_corner_lon_find_adj_cell, + & srch_center_lat_find_adj_cell, & srch_center_lon_find_adj_cell) endif @@ -6173,14 +6173,14 @@ subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, found = .false. do n = 1, num_srch_cells_find_adj_cell - + global_add = srch_add_find_adj_cell(n) do i = 1, srch_corners_find_adj_cell inx = mod(i,srch_corners_find_adj_cell)+1 if (abs(srch_corner_lat_find_adj_cell(inx,n)-lat1) .le. tiny & .and. - & abs(srch_corner_lat_find_adj_cell(i,n)-lat2) .le. tiny + & abs(srch_corner_lat_find_adj_cell(i,n)-lat2) .le. tiny & .and. & abs(srch_corner_lon_find_adj_cell(inx,n)-lon1) .le.tiny & .and. @@ -6195,7 +6195,7 @@ subroutine find_adj_cell(cell_add, edge_id, cell_grid_num, enddo if (found) exit - + enddo return @@ -6211,7 +6211,7 @@ end subroutine find_adj_cell subroutine converge_to_bdry(cell_add, cell_grid_num, & ncorners, cell_corner_lat, - & cell_corner_lon, cell_center_lat, cell_center_lon, + & cell_corner_lon, cell_center_lat, cell_center_lon, & inpt_lat, inpt_lon, outpt_lat, outpt_lon, & bpt_lat, bpt_lon, bedgeid) @@ -6259,7 +6259,7 @@ subroutine converge_to_bdry(cell_add, cell_grid_num, !---------------------------------------------------------------------- logical (SCRIP_logical) :: - & converged, + & converged, & lboundary, & inpoly @@ -6276,28 +6276,28 @@ subroutine converge_to_bdry(cell_add, cell_grid_num, lat1 = inpt_lat lon1 = inpt_lon lat2 = outpt_lat - lon2 = outpt_lon + lon2 = outpt_lon converged = .false. it = 0 - do while (.not. converged) - + do while (.not. converged) + midlat = (lat1+lat2)/2.0 - if (abs(lon1-lon2) < pi) then + if (abs(lon1-lon2) < pi) then midlon = (lon1+lon2)/2.0 else midlon = (lon1+lon2)/2.0 - pi2 endif - - - call ptincell(midlat, midlon, - & cell_add, ncorners, + + + call ptincell(midlat, midlon, + & cell_add, ncorners, & cell_corner_lat, cell_corner_lon, & cell_center_lat, cell_center_lon, & cell_grid_num, - & inpoly, lboundary, bedgeid) - + & inpoly, lboundary, bedgeid) + if (inpoly) then lat1 = midlat lon1 = midlon @@ -6305,16 +6305,16 @@ subroutine converge_to_bdry(cell_add, cell_grid_num, lat2 = midlat lon2 = midlon endif - + if (abs(lat1-lat2) < tiny .and. & abs(lon1-lon2) < tiny .and. lboundary) then converged = .true. - endif - + endif + if (it > 100) then exit endif - + it = it + 1 enddo ! do while (not converged) diff --git a/model/src/SCRIP/scrip_remap_read.f b/model/src/SCRIP/scrip_remap_read.f index 5ab3459e5..b0caa89a7 100644 --- a/model/src/SCRIP/scrip_remap_read.f +++ b/model/src/SCRIP/scrip_remap_read.f @@ -8,12 +8,12 @@ ! ! CVS:$Id: remap_read.f,v 1.6 2000/04/19 21:56:26 pwjones Exp $ ! -! Copyright (c) 1997, 1998 the Regents of the University of +! Copyright (c) 1997, 1998 the Regents of the University of ! California. ! -! This software and ancillary information (herein called software) -! called SCRIP is made available under the terms described here. -! The software has been approved for release with associated +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated ! LA-CC Number 98-45. ! ! Unless otherwise indicated, this software has been authored @@ -28,16 +28,16 @@ ! any liability or responsibility for the use of this software. ! ! If software is modified to produce derivative works, such modified -! software should be clearly marked, so as not to confuse it with +! software should be clearly marked, so as not to confuse it with ! the version available from Los Alamos National Laboratory. ! -! This code has been modified from the version available from +! This code has been modified from the version available from ! Los Alamos National Laboratory, for the purpose of running it ! within WW3. ! !*********************************************************************** - module scrip_remap_read + module scrip_remap_read !----------------------------------------------------------------------- ! @@ -63,7 +63,7 @@ module scrip_remap_read !----------------------------------------------------------------------- - character(SCRIP_charLength), private :: + character(SCRIP_charLength), private :: & map_method ! character string for map_type &, normalize_opt ! character string for normalization option &, convention ! character string for output convention @@ -144,10 +144,10 @@ subroutine read_remap_ww3(map_name, interp_file, errorCode) ! !----------------------------------------------------------------------- - integer (SCRIP_i4) :: + integer (SCRIP_i4) :: & errorCode ! error code for SCRIP routine - character (14), parameter :: + character (14), parameter :: & rtnName = 'read_remap_ww3' !----------------------------------------------------------------------- @@ -267,7 +267,7 @@ subroutine read_remap_scrip_ww3 & grid1_name ! grid name for source grid &, grid2_name ! grid name for dest grid - integer (SCRIP_i4) :: + integer (SCRIP_i4) :: & n ! dummy index &, errorCode ! error code for SCRIP routine @@ -275,7 +275,7 @@ subroutine read_remap_scrip_ww3 & grid1_mask_int, ! integer masks to determine & grid2_mask_int ! cells that participate in map - character (20), parameter :: + character (20), parameter :: & rtnName = 'read_remap_scrip_ww3' !----------------------------------------------------------------------- @@ -293,7 +293,7 @@ subroutine read_remap_scrip_ww3 errorCode = SCRIP_Success ncstat = nf90_get_att (nc_file_id, NF90_GLOBAL, 'source_grid', & grid1_name) - if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error + if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading source grid name')) return ncstat = nf90_get_att (nc_file_id, NF90_GLOBAL, 'dest_grid', @@ -313,34 +313,34 @@ subroutine read_remap_scrip_ww3 ! !----------------------------------------------------------------------- - ncstat = nf90_inq_dimid(nc_file_id, 'dst_grid_size', + ncstat = nf90_inq_dimid(nc_file_id, 'dst_grid_size', & nc_dstgrdsize_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading destination grid id')) return ! ncstat = nf90_inq_dimlen(nc_file_id, nc_dstgrdsize_id, grid2_size) - ncstat = nf90_inquire_dimension(nc_file_id, nc_dstgrdsize_id, + ncstat = nf90_inquire_dimension(nc_file_id, nc_dstgrdsize_id, & len = grid2_size) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading destination grid size')) return - ncstat = nf90_inq_dimid(nc_file_id, 'num_links', + ncstat = nf90_inq_dimid(nc_file_id, 'num_links', & nc_numlinks_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading number of links id')) return -! ncstat = nf90_inq_dimlen(nc_file_id, nc_numlinks_id, +! ncstat = nf90_inq_dimlen(nc_file_id, nc_numlinks_id, ! & num_links_map1) - ncstat = nf90_inquire_dimension(nc_file_id, nc_numlinks_id, + ncstat = nf90_inquire_dimension(nc_file_id, nc_numlinks_id, & len = num_links_map1) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading number of links')) return max_links_map1 = num_links_map1 - ncstat = nf90_inq_dimid(nc_file_id, 'num_wgts', + ncstat = nf90_inq_dimid(nc_file_id, 'num_wgts', & nc_numwgts_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading number of weights id')) return ! ncstat = nf90_inq_dimlen(nc_file_id, nc_numwgts_id, num_wts) - ncstat = nf90_inquire_dimension(nc_file_id, nc_numwgts_id, + ncstat = nf90_inquire_dimension(nc_file_id, nc_numwgts_id, & len = num_wts) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading number of weights')) return @@ -369,22 +369,22 @@ subroutine read_remap_scrip_ww3 ! !----------------------------------------------------------------------- - ncstat = nf90_inq_varid(nc_file_id, 'dst_grid_frac', + ncstat = nf90_inq_varid(nc_file_id, 'dst_grid_frac', & nc_dstgrdfrac_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading destination grid fraction id')) return - ncstat = nf90_inq_varid(nc_file_id, 'src_address', + ncstat = nf90_inq_varid(nc_file_id, 'src_address', & nc_srcgrdadd_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading source grid address id')) return - ncstat = nf90_inq_varid(nc_file_id, 'dst_address', + ncstat = nf90_inq_varid(nc_file_id, 'dst_address', & nc_dstgrdadd_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading destination grid address id')) return - ncstat = nf90_inq_varid(nc_file_id, 'remap_matrix', + ncstat = nf90_inq_varid(nc_file_id, 'remap_matrix', & nc_rmpmatrix_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading remap matrix id')) return @@ -395,22 +395,22 @@ subroutine read_remap_scrip_ww3 ! !----------------------------------------------------------------------- - ncstat = nf90_get_var(nc_file_id, nc_dstgrdfrac_id, + ncstat = nf90_get_var(nc_file_id, nc_dstgrdfrac_id, & grid2_frac) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading destination grid fraction')) return - ncstat = nf90_get_var(nc_file_id, nc_srcgrdadd_id, + ncstat = nf90_get_var(nc_file_id, nc_srcgrdadd_id, & grid1_add_map1) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading source grid address')) return - ncstat = nf90_get_var(nc_file_id, nc_dstgrdadd_id, + ncstat = nf90_get_var(nc_file_id, nc_dstgrdadd_id, & grid2_add_map1) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading destination grid address')) return - ncstat = nf90_get_var(nc_file_id, nc_rmpmatrix_id, + ncstat = nf90_get_var(nc_file_id, nc_rmpmatrix_id, & wts_map1) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, 'error & reading remap weights')) return diff --git a/model/src/SCRIP/scrip_remap_vars.f b/model/src/SCRIP/scrip_remap_vars.f index 1bc074200..1d3bf2ee2 100644 --- a/model/src/SCRIP/scrip_remap_vars.f +++ b/model/src/SCRIP/scrip_remap_vars.f @@ -8,12 +8,12 @@ ! ! CVS:$Id: remap_vars.f,v 1.5 2000/04/19 21:56:26 pwjones Exp $ ! -! Copyright (c) 1997, 1998 the Regents of the University of +! Copyright (c) 1997, 1998 the Regents of the University of ! California. ! -! This software and ancillary information (herein called software) -! called SCRIP is made available under the terms described here. -! The software has been approved for release with associated +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated ! LA-CC Number 98-45. ! ! Unless otherwise indicated, this software has been authored @@ -28,10 +28,10 @@ ! any liability or responsibility for the use of this software. ! ! If software is modified to produce derivative works, such modified -! software should be clearly marked, so as not to confuse it with +! software should be clearly marked, so as not to confuse it with ! the version available from Los Alamos National Laboratory. ! -! This code has been modified from the version available from +! This code has been modified from the version available from ! Los Alamos National Laboratory, for the purpose of running it ! within WW3. ! @@ -63,7 +63,7 @@ module scrip_remap_vars &, map_type_distwgt = 4 &, map_type_particle = 5 - integer (SCRIP_i4), save :: + integer (SCRIP_i4), save :: & max_links_map1 ! current size of link arrays &, num_links_map1 ! actual number of links for remapping &, max_links_map2 ! current size of link arrays @@ -98,7 +98,7 @@ subroutine init_remap_vars !----------------------------------------------------------------------- ! ! this routine initializes some variables and provides an initial -! allocation of arrays (fairly large so frequent resizing +! allocation of arrays (fairly large so frequent resizing ! unnecessary). ! !----------------------------------------------------------------------- @@ -124,11 +124,11 @@ subroutine init_remap_vars !----------------------------------------------------------------------- ! -! initialize num_links and set max_links to four times the largest +! initialize num_links and set max_links to four times the largest ! of the destination grid sizes initially (can be changed later). ! set a default resize increment to increase the size of link ! arrays if the number of links exceeds the initial size -! +! !----------------------------------------------------------------------- num_links_map1 = 0 @@ -144,7 +144,7 @@ subroutine init_remap_vars !----------------------------------------------------------------------- ! ! allocate address and weight arrays for mapping 1 -! +! !----------------------------------------------------------------------- allocate (grid1_add_map1(max_links_map1), @@ -153,8 +153,8 @@ subroutine init_remap_vars !----------------------------------------------------------------------- ! -! allocate address and weight arrays for mapping 2 if necessary -! +! allocate address and weight arrays for mapping 2 if necessary +! !----------------------------------------------------------------------- if (num_maps > 1) then @@ -219,13 +219,13 @@ subroutine resize_remap_vars(nmap, increment) !*** mxlinks = size(grid1_add_map1) - allocate (add1_tmp(mxlinks), add2_tmp(mxlinks), + allocate (add1_tmp(mxlinks), add2_tmp(mxlinks), & wts_tmp(num_wts,mxlinks)) add1_tmp = grid1_add_map1 add2_tmp = grid2_add_map1 wts_tmp = wts_map1 - + !*** !*** deallocate originals and increment max_links then !*** reallocate arrays at new size @@ -261,7 +261,7 @@ subroutine resize_remap_vars(nmap, increment) !*** mxlinks = size(grid1_add_map2) - allocate (add1_tmp(mxlinks), add2_tmp(mxlinks), + allocate (add1_tmp(mxlinks), add2_tmp(mxlinks), & wts_tmp(num_wts,mxlinks),stat=ierr) if (ierr .ne. 0) then print *,'error allocating temps in resize: ',ierr @@ -271,7 +271,7 @@ subroutine resize_remap_vars(nmap, increment) add1_tmp = grid1_add_map2 add2_tmp = grid2_add_map2 wts_tmp = wts_map2 - + !*** !*** deallocate originals and increment max_links then !*** reallocate arrays at new size diff --git a/model/src/SCRIP/scrip_remap_write.f b/model/src/SCRIP/scrip_remap_write.f index df9c9ea7d..f3a67cd8d 100644 --- a/model/src/SCRIP/scrip_remap_write.f +++ b/model/src/SCRIP/scrip_remap_write.f @@ -1,19 +1,19 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! -! This module contains routines for writing the remapping data to -! a file. Before writing the data for each mapping, the links are +! This module contains routines for writing the remapping data to +! a file. Before writing the data for each mapping, the links are ! sorted by destination grid address. ! !----------------------------------------------------------------------- ! ! CVS:$Id: remap_write.f,v 1.7 2001/08/21 21:06:42 pwjones Exp $ ! -! Copyright (c) 1997, 1998 the Regents of the University of +! Copyright (c) 1997, 1998 the Regents of the University of ! California. ! -! This software and ancillary information (herein called software) -! called SCRIP is made available under the terms described here. -! The software has been approved for release with associated +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated ! LA-CC Number 98-45. ! ! Unless otherwise indicated, this software has been authored @@ -28,10 +28,10 @@ ! any liability or responsibility for the use of this software. ! ! If software is modified to produce derivative works, such modified -! software should be clearly marked, so as not to confuse it with +! software should be clearly marked, so as not to confuse it with ! the version available from Los Alamos National Laboratory. ! -! This code has been modified from the version available from +! This code has been modified from the version available from ! Los Alamos National Laboratory, for the purpose of running it ! within WW3. ! @@ -58,13 +58,13 @@ module scrip_remap_write ! !----------------------------------------------------------------------- - character(SCRIP_charLength), private :: + character(SCRIP_charLength), private :: & map_method ! character string for map_type &, normalize_opt ! character string for normalization option &, history ! character string for history information &, convention ! character string for output convention - character(8), private :: + character(8), private :: & cdate ! character date string integer (SCRIP_i4), dimension(:), allocatable, private :: @@ -78,7 +78,7 @@ module scrip_remap_write !----------------------------------------------------------------------- integer (SCRIP_i4), private :: - & ncstat ! error flag for netCDF calls + & ncstat ! error flag for netCDF calls &, nc_file_id ! id for netCDF file &, nc_srcgrdsize_id ! id for source grid size &, nc_dstgrdsize_id ! id for destination grid size @@ -117,7 +117,7 @@ module scrip_remap_write !*********************************************************************** - subroutine write_remap(map1_name, map2_name, interp_file1, + subroutine write_remap(map1_name, map2_name, interp_file1, & interp_file2, output_opt, l_master, errorCode) !----------------------------------------------------------------------- @@ -188,8 +188,8 @@ subroutine write_remap(map1_name, map2_name, interp_file1, case(map_type_particle) map_method = 'Particle remapping' case default - call SCRIP_ErrorSet(errorCode, rtnName, 'Invalid Map Type') - return + call SCRIP_ErrorSet(errorCode, rtnName, 'Invalid Map Type') + return end select call date_and_time(date=cdate) @@ -207,7 +207,7 @@ subroutine write_remap(map1_name, map2_name, interp_file1, ! call sort_add(grid2_add_map1, grid1_add_map1, wts_map1) if (num_maps > 1) then - call sort_add(grid1_add_map2, grid2_add_map2, wts_map2) + call sort_add(grid1_add_map2, grid2_add_map2, wts_map2) endif !----------------------------------------------------------------------- @@ -218,18 +218,18 @@ subroutine write_remap(map1_name, map2_name, interp_file1, select case(output_opt) case ('scrip') - if (l_master) - & call write_remap_scrip(map1_name, interp_file1, 1, errorCode) - if (SCRIP_ErrorCheck(errorCode, rtnName, - & 'error in write_remap_scrip')) return + if (l_master) + & call write_remap_scrip(map1_name, interp_file1, 1, errorCode) + if (SCRIP_ErrorCheck(errorCode, rtnName, + & 'error in write_remap_scrip')) return case ('ncar-csm') - call write_remap_csm (map1_name, interp_file1, 1, errorCode) - if (SCRIP_ErrorCheck(errorCode, rtnName, - & 'error in write_remap_csm')) return + call write_remap_csm (map1_name, interp_file1, 1, errorCode) + if (SCRIP_ErrorCheck(errorCode, rtnName, + & 'error in write_remap_csm')) return case default - call SCRIP_ErrorSet(errorCode, rtnName, - & 'unknown output file convention') - return + call SCRIP_ErrorSet(errorCode, rtnName, + & 'unknown output file convention') + return end select !----------------------------------------------------------------------- @@ -241,7 +241,7 @@ subroutine write_remap(map1_name, map2_name, interp_file1, if (num_maps > 1) then select case(output_opt) case ('scrip') - if (l_master) + if (l_master) & call write_remap_scrip(map2_name, interp_file2, 2, errorCode) if (SCRIP_ErrorCheck(errorCode, rtnName, & 'error in write_remap_scrip')) return @@ -278,7 +278,7 @@ subroutine write_remap_scrip(map_name, interp_file, direction, !----------------------------------------------------------------------- character(SCRIP_charLength), intent(in) :: - & map_name ! name for mapping + & map_name ! name for mapping &, interp_file ! filename for remap data integer (SCRIP_i4), intent(in) :: @@ -404,12 +404,12 @@ subroutine write_remap_scrip(map_name, interp_file, direction, itmp2 = grid1_size endif - ncstat = nf90_def_dim(nc_file_id, 'src_grid_size', itmp1, + ncstat = nf90_def_dim(nc_file_id, 'src_grid_size', itmp1, & nc_srcgrdsize_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid size')) return - ncstat = nf90_def_dim(nc_file_id, 'dst_grid_size', itmp2, + ncstat = nf90_def_dim(nc_file_id, 'dst_grid_size', itmp2, & nc_dstgrdsize_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid size')) return @@ -426,12 +426,12 @@ subroutine write_remap_scrip(map_name, interp_file, direction, itmp2 = grid1_corners endif - ncstat = nf90_def_dim(nc_file_id, 'src_grid_corners', + ncstat = nf90_def_dim(nc_file_id, 'src_grid_corners', & itmp1, nc_srcgrdcorn_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining num corners on source grid')) return - ncstat = nf90_def_dim(nc_file_id, 'dst_grid_corners', + ncstat = nf90_def_dim(nc_file_id, 'dst_grid_corners', & itmp2, nc_dstgrdcorn_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining num corners on destination grid')) return @@ -448,12 +448,12 @@ subroutine write_remap_scrip(map_name, interp_file, direction, itmp2 = grid1_rank endif - ncstat = nf90_def_dim(nc_file_id, 'src_grid_rank', + ncstat = nf90_def_dim(nc_file_id, 'src_grid_rank', & itmp1, nc_srcgrdrank_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid rank')) return - ncstat = nf90_def_dim(nc_file_id, 'dst_grid_rank', + ncstat = nf90_def_dim(nc_file_id, 'dst_grid_rank', & itmp2, nc_dstgrdrank_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid rank')) return @@ -468,12 +468,12 @@ subroutine write_remap_scrip(map_name, interp_file, direction, itmp1 = num_links_map2 endif - ncstat = nf90_def_dim(nc_file_id, 'num_links', + ncstat = nf90_def_dim(nc_file_id, 'num_links', & itmp1, nc_numlinks_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining remap size')) return - ncstat = nf90_def_dim(nc_file_id, 'num_wgts', + ncstat = nf90_def_dim(nc_file_id, 'num_wgts', & num_wts, nc_numwgts_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining number of weights')) return @@ -502,14 +502,14 @@ subroutine write_remap_scrip(map_name, interp_file, direction, !*** define grid center latitude array !*** - ncstat = nf90_def_var(nc_file_id, 'src_grid_center_lat', - & NF90_DOUBLE, nc_srcgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'src_grid_center_lat', + & NF90_DOUBLE, nc_srcgrdsize_id, & nc_srcgrdcntrlat_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid center lat')) return - ncstat = nf90_def_var(nc_file_id, 'dst_grid_center_lat', - & NF90_DOUBLE, nc_dstgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'dst_grid_center_lat', + & NF90_DOUBLE, nc_dstgrdsize_id, & nc_dstgrdcntrlat_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid center lat')) return @@ -518,14 +518,14 @@ subroutine write_remap_scrip(map_name, interp_file, direction, !*** define grid center longitude array !*** - ncstat = nf90_def_var(nc_file_id, 'src_grid_center_lon', - & NF90_DOUBLE, nc_srcgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'src_grid_center_lon', + & NF90_DOUBLE, nc_srcgrdsize_id, & nc_srcgrdcntrlon_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid center lon')) return - ncstat = nf90_def_var(nc_file_id, 'dst_grid_center_lon', - & NF90_DOUBLE, nc_dstgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'dst_grid_center_lon', + & NF90_DOUBLE, nc_dstgrdsize_id, & nc_dstgrdcntrlon_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid center lon')) return @@ -537,14 +537,14 @@ subroutine write_remap_scrip(map_name, interp_file, direction, nc_dims2_id(1) = nc_srcgrdcorn_id nc_dims2_id(2) = nc_srcgrdsize_id - ncstat = nf90_def_var(nc_file_id, 'src_grid_corner_lat', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'src_grid_corner_lat', + & NF90_DOUBLE, nc_dims2_id, & nc_srcgrdcrnrlat_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid corner lats')) return - ncstat = nf90_def_var(nc_file_id, 'src_grid_corner_lon', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'src_grid_corner_lon', + & NF90_DOUBLE, nc_dims2_id, & nc_srcgrdcrnrlon_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid corner lons')) return @@ -552,14 +552,14 @@ subroutine write_remap_scrip(map_name, interp_file, direction, nc_dims2_id(1) = nc_dstgrdcorn_id nc_dims2_id(2) = nc_dstgrdsize_id - ncstat = nf90_def_var(nc_file_id, 'dst_grid_corner_lat', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'dst_grid_corner_lat', + & NF90_DOUBLE, nc_dims2_id, & nc_dstgrdcrnrlat_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid corner lats')) return - ncstat = nf90_def_var(nc_file_id, 'dst_grid_corner_lon', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'dst_grid_corner_lon', + & NF90_DOUBLE, nc_dims2_id, & nc_dstgrdcrnrlon_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid corner lons')) return @@ -576,42 +576,42 @@ subroutine write_remap_scrip(map_name, interp_file, direction, grid2_ctmp = grid1_units endif - ncstat = nf90_put_att(nc_file_id, nc_srcgrdcntrlat_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdcntrlat_id, & 'units', grid1_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdcntrlat_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdcntrlat_id, & 'units', grid2_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdcntrlon_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdcntrlon_id, & 'units', grid1_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdcntrlon_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdcntrlon_id, & 'units', grid2_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdcrnrlat_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdcrnrlat_id, & 'units', grid1_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdcrnrlon_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdcrnrlon_id, & 'units', grid1_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdcrnrlat_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdcrnrlat_id, & 'units', grid2_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdcrnrlon_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdcrnrlon_id, & 'units', grid2_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination grid units')) return @@ -625,7 +625,7 @@ subroutine write_remap_scrip(map_name, interp_file, direction, if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid mask')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdimask_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdimask_id, & 'units', 'unitless') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source grid mask units')) return @@ -635,7 +635,7 @@ subroutine write_remap_scrip(map_name, interp_file, direction, if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid mask')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdimask_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdimask_id, & 'units', 'unitless') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination grid mask units')) return @@ -644,24 +644,24 @@ subroutine write_remap_scrip(map_name, interp_file, direction, !*** define grid area arrays !*** - ncstat = nf90_def_var(nc_file_id, 'src_grid_area', - & NF90_DOUBLE, nc_srcgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'src_grid_area', + & NF90_DOUBLE, nc_srcgrdsize_id, & nc_srcgrdarea_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid area')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdarea_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdarea_id, & 'units', 'square radians') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source area units')) return - ncstat = nf90_def_var(nc_file_id, 'dst_grid_area', - & NF90_DOUBLE, nc_dstgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'dst_grid_area', + & NF90_DOUBLE, nc_dstgrdsize_id, & nc_dstgrdarea_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid area')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdarea_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdarea_id, & 'units', 'square radians') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination area units')) return @@ -670,24 +670,24 @@ subroutine write_remap_scrip(map_name, interp_file, direction, !*** define grid fraction arrays !*** - ncstat = nf90_def_var(nc_file_id, 'src_grid_frac', - & NF90_DOUBLE, nc_srcgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'src_grid_frac', + & NF90_DOUBLE, nc_srcgrdsize_id, & nc_srcgrdfrac_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid fraction')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdfrac_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdfrac_id, & 'units', 'unitless') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source fraction units')) return - ncstat = nf90_def_var(nc_file_id, 'dst_grid_frac', - & NF90_DOUBLE, nc_dstgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'dst_grid_frac', + & NF90_DOUBLE, nc_dstgrdsize_id, & nc_dstgrdfrac_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination fraction')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdfrac_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdfrac_id, & 'units', 'unitless') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination frac units')) return @@ -696,14 +696,14 @@ subroutine write_remap_scrip(map_name, interp_file, direction, !*** define mapping arrays !*** - ncstat = nf90_def_var(nc_file_id, 'src_address', - & NF90_INT, nc_numlinks_id, + ncstat = nf90_def_var(nc_file_id, 'src_address', + & NF90_INT, nc_numlinks_id, & nc_srcadd_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source addresses')) return - ncstat = nf90_def_var(nc_file_id, 'dst_address', - & NF90_INT, nc_numlinks_id, + ncstat = nf90_def_var(nc_file_id, 'dst_address', + & NF90_INT, nc_numlinks_id, & nc_dstadd_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination addresses')) return @@ -711,8 +711,8 @@ subroutine write_remap_scrip(map_name, interp_file, direction, nc_dims2_id(1) = nc_numwgts_id nc_dims2_id(2) = nc_numlinks_id - ncstat = nf90_def_var(nc_file_id, 'remap_matrix', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'remap_matrix', + & NF90_DOUBLE, nc_dims2_id, & nc_rmpmatrix_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining remapping weights')) return @@ -909,12 +909,12 @@ subroutine write_remap_scrip(map_name, interp_file, direction, & 'error writing grid2 frac')) return if (direction == 1) then - ncstat = nf90_put_var(nc_file_id, nc_srcadd_id, + ncstat = nf90_put_var(nc_file_id, nc_srcadd_id, & grid1_add_map1) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source addresses')) return - ncstat = nf90_put_var(nc_file_id, nc_dstadd_id, + ncstat = nf90_put_var(nc_file_id, nc_dstadd_id, & grid2_add_map1) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination addresses')) return @@ -923,12 +923,12 @@ subroutine write_remap_scrip(map_name, interp_file, direction, if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing weights')) return else - ncstat = nf90_put_var(nc_file_id, nc_srcadd_id, + ncstat = nf90_put_var(nc_file_id, nc_srcadd_id, & grid2_add_map2) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source addresses')) return - ncstat = nf90_put_var(nc_file_id, nc_dstadd_id, + ncstat = nf90_put_var(nc_file_id, nc_dstadd_id, & grid1_add_map2) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination addresses')) return @@ -948,7 +948,7 @@ end subroutine write_remap_scrip !*********************************************************************** - subroutine write_remap_ww3(map1_name, interp_file1, + subroutine write_remap_ww3(map1_name, interp_file1, & output_opt, l_master, errorCode) !----------------------------------------------------------------------- @@ -1052,13 +1052,13 @@ subroutine write_remap_ww3(map1_name, interp_file1, select case(output_opt) case ('scrip') if (l_master) then - call write_remap_scrip_ww3(map1_name_pass, + call write_remap_scrip_ww3(map1_name_pass, & interp_file1_pass, errorCode) endif if (SCRIP_ErrorCheck(errorCode, rtnName, & 'error in write_remap_scrip')) return case default - call SCRIP_ErrorSet(errorCode, rtnName, + call SCRIP_ErrorSet(errorCode, rtnName, & 'unknown output file convention') return end select @@ -1085,7 +1085,7 @@ subroutine write_remap_scrip_ww3(map_name, interp_file, errorCode) !----------------------------------------------------------------------- character(SCRIP_charLength), intent(in) :: - & map_name ! name for mapping + & map_name ! name for mapping &, interp_file ! filename for remap data !----------------------------------------------------------------------- @@ -1106,7 +1106,7 @@ subroutine write_remap_scrip_ww3(map_name, interp_file, errorCode) character(SCRIP_charLength) :: & grid1_ctmp ! character temp for grid1 names &, grid2_ctmp ! character temp for grid2 names - &, map_name_ctmp ! character temp for name for mapping + &, map_name_ctmp ! character temp for name for mapping &, interp_file_ctmp ! character temp filename for remap data integer (SCRIP_i4) :: @@ -1203,7 +1203,7 @@ subroutine write_remap_scrip_ww3(map_name, interp_file, errorCode) itmp2 = grid2_size - ncstat = nf90_def_dim(nc_file_id, 'dst_grid_size', itmp2, + ncstat = nf90_def_dim(nc_file_id, 'dst_grid_size', itmp2, & nc_dstgrdsize_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid size')) return @@ -1214,12 +1214,12 @@ subroutine write_remap_scrip_ww3(map_name, interp_file, errorCode) itmp1 = num_links_map1 - ncstat = nf90_def_dim(nc_file_id, 'num_links', + ncstat = nf90_def_dim(nc_file_id, 'num_links', & itmp1, nc_numlinks_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining remap size')) return - ncstat = nf90_def_dim(nc_file_id, 'num_wgts', + ncstat = nf90_def_dim(nc_file_id, 'num_wgts', & num_wts, nc_numwgts_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining number of weights')) return @@ -1236,13 +1236,13 @@ subroutine write_remap_scrip_ww3(map_name, interp_file, errorCode) !*** - ncstat = nf90_def_var(nc_file_id, 'dst_grid_frac', - & NF90_DOUBLE, nc_dstgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'dst_grid_frac', + & NF90_DOUBLE, nc_dstgrdsize_id, & nc_dstgrdfrac_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination fraction')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdfrac_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdfrac_id, & 'units', 'unitless') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination frac units')) return @@ -1251,14 +1251,14 @@ subroutine write_remap_scrip_ww3(map_name, interp_file, errorCode) !*** define mapping arrays !*** - ncstat = nf90_def_var(nc_file_id, 'src_address', - & NF90_INT, nc_numlinks_id, + ncstat = nf90_def_var(nc_file_id, 'src_address', + & NF90_INT, nc_numlinks_id, & nc_srcadd_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source addresses')) return - ncstat = nf90_def_var(nc_file_id, 'dst_address', - & NF90_INT, nc_numlinks_id, + ncstat = nf90_def_var(nc_file_id, 'dst_address', + & NF90_INT, nc_numlinks_id, & nc_dstadd_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination addresses')) return @@ -1266,8 +1266,8 @@ subroutine write_remap_scrip_ww3(map_name, interp_file, errorCode) nc_dims2_id(1) = nc_numwgts_id nc_dims2_id(2) = nc_numlinks_id - ncstat = nf90_def_var(nc_file_id, 'remap_matrix', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'remap_matrix', + & NF90_DOUBLE, nc_dims2_id, & nc_rmpmatrix_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining remapping weights')) return @@ -1291,12 +1291,12 @@ subroutine write_remap_scrip_ww3(map_name, interp_file, errorCode) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing grid2 frac')) return - ncstat = nf90_put_var(nc_file_id, nc_srcadd_id, + ncstat = nf90_put_var(nc_file_id, nc_srcadd_id, & grid1_add_map1) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source addresses')) return - ncstat = nf90_put_var(nc_file_id, nc_dstadd_id, + ncstat = nf90_put_var(nc_file_id, nc_dstadd_id, & grid2_add_map1) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination addresses')) return @@ -1333,7 +1333,7 @@ subroutine write_remap_csm(map_name, interp_file, direction, !----------------------------------------------------------------------- character(SCRIP_charLength), intent(in) :: - & map_name ! name for mapping + & map_name ! name for mapping &, interp_file ! filename for remap data integer (SCRIP_i4), intent(in) :: @@ -1511,12 +1511,12 @@ subroutine write_remap_csm(map_name, interp_file, direction, itmp2 = grid1_rank endif - ncstat = nf90_def_dim(nc_file_id, 'src_grid_rank', + ncstat = nf90_def_dim(nc_file_id, 'src_grid_rank', & itmp1, nc_srcgrdrank_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid rank')) return - ncstat = nf90_def_dim(nc_file_id, 'dst_grid_rank', + ncstat = nf90_def_dim(nc_file_id, 'dst_grid_rank', & itmp2, nc_dstgrdrank_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid rank')) return @@ -1583,13 +1583,13 @@ subroutine write_remap_csm(map_name, interp_file, direction, if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining remap size')) return - ncstat = nf90_def_dim(nc_file_id, 'num_wgts', + ncstat = nf90_def_dim(nc_file_id, 'num_wgts', & num_wts, nc_numwgts_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining number of weights')) return if (num_wts > 1) then - ncstat = nf90_def_dim(nc_file_id, 'num_wgts1', + ncstat = nf90_def_dim(nc_file_id, 'num_wgts1', & num_wts-1, nc_numwgts1_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining number of weights1')) return @@ -1620,13 +1620,13 @@ subroutine write_remap_csm(map_name, interp_file, direction, !*** ncstat = nf90_def_var(nc_file_id, 'yc_a', - & NF90_DOUBLE, nc_srcgrdsize_id, + & NF90_DOUBLE, nc_srcgrdsize_id, & nc_srcgrdcntrlat_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid center lats')) return - ncstat = nf90_def_var(nc_file_id, 'yc_b', - & NF90_DOUBLE, nc_dstgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'yc_b', + & NF90_DOUBLE, nc_dstgrdsize_id, & nc_dstgrdcntrlat_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid center lats')) return @@ -1635,14 +1635,14 @@ subroutine write_remap_csm(map_name, interp_file, direction, !*** define grid center longitude array !*** - ncstat = nf90_def_var(nc_file_id, 'xc_a', - & NF90_DOUBLE, nc_srcgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'xc_a', + & NF90_DOUBLE, nc_srcgrdsize_id, & nc_srcgrdcntrlon_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid center lons')) return - ncstat = nf90_def_var(nc_file_id, 'xc_b', - & NF90_DOUBLE, nc_dstgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'xc_b', + & NF90_DOUBLE, nc_dstgrdsize_id, & nc_dstgrdcntrlon_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid center lons')) return @@ -1654,14 +1654,14 @@ subroutine write_remap_csm(map_name, interp_file, direction, nc_dims2_id(1) = nc_srcgrdcorn_id nc_dims2_id(2) = nc_srcgrdsize_id - ncstat = nf90_def_var(nc_file_id, 'yv_a', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'yv_a', + & NF90_DOUBLE, nc_dims2_id, & nc_srcgrdcrnrlat_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid corner lats')) return - ncstat = nf90_def_var(nc_file_id, 'xv_a', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'xv_a', + & NF90_DOUBLE, nc_dims2_id, & nc_srcgrdcrnrlon_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid corner lons')) return @@ -1669,14 +1669,14 @@ subroutine write_remap_csm(map_name, interp_file, direction, nc_dims2_id(1) = nc_dstgrdcorn_id nc_dims2_id(2) = nc_dstgrdsize_id - ncstat = nf90_def_var(nc_file_id, 'yv_b', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'yv_b', + & NF90_DOUBLE, nc_dims2_id, & nc_dstgrdcrnrlat_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid corner lats')) return - ncstat = nf90_def_var(nc_file_id, 'xv_b', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'xv_b', + & NF90_DOUBLE, nc_dims2_id, & nc_dstgrdcrnrlon_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid corner lons')) return @@ -1696,42 +1696,42 @@ subroutine write_remap_csm(map_name, interp_file, direction, grid2_ctmp = grid1_units endif - ncstat = nf90_put_att(nc_file_id, nc_srcgrdcntrlat_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdcntrlat_id, & 'units', grid1_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdcntrlat_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdcntrlat_id, & 'units', grid2_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdcntrlon_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdcntrlon_id, & 'units', grid1_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdcntrlon_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdcntrlon_id, & 'units', grid2_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdcrnrlat_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdcrnrlat_id, & 'units', grid1_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdcrnrlon_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdcrnrlon_id, & 'units', grid1_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdcrnrlat_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdcrnrlat_id, & 'units', grid2_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing grid units')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdcrnrlon_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdcrnrlon_id, & 'units', grid2_ctmp) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing grid units')) return @@ -1745,7 +1745,7 @@ subroutine write_remap_csm(map_name, interp_file, direction, if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid mask')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdimask_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdimask_id, & 'units', 'unitless') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source mask units')) return @@ -1755,7 +1755,7 @@ subroutine write_remap_csm(map_name, interp_file, direction, if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid mask')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdimask_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdimask_id, & 'units', 'unitless') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination mask units')) return @@ -1764,24 +1764,24 @@ subroutine write_remap_csm(map_name, interp_file, direction, !*** define grid area arrays !*** - ncstat = nf90_def_var(nc_file_id, 'area_a', - & NF90_DOUBLE, nc_srcgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'area_a', + & NF90_DOUBLE, nc_srcgrdsize_id, & nc_srcgrdarea_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid area')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdarea_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdarea_id, & 'units', 'square radians') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source area units')) return - ncstat = nf90_def_var(nc_file_id, 'area_b', - & NF90_DOUBLE, nc_dstgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'area_b', + & NF90_DOUBLE, nc_dstgrdsize_id, & nc_dstgrdarea_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid area')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdarea_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdarea_id, & 'units', 'square radians') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination area units')) return @@ -1790,24 +1790,24 @@ subroutine write_remap_csm(map_name, interp_file, direction, !*** define grid fraction arrays !*** - ncstat = nf90_def_var(nc_file_id, 'frac_a', - & NF90_DOUBLE, nc_srcgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'frac_a', + & NF90_DOUBLE, nc_srcgrdsize_id, & nc_srcgrdfrac_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source grid frac')) return - ncstat = nf90_put_att(nc_file_id, nc_srcgrdfrac_id, + ncstat = nf90_put_att(nc_file_id, nc_srcgrdfrac_id, & 'units', 'unitless') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source frac units')) return - ncstat = nf90_def_var(nc_file_id, 'frac_b', - & NF90_DOUBLE, nc_dstgrdsize_id, + ncstat = nf90_def_var(nc_file_id, 'frac_b', + & NF90_DOUBLE, nc_dstgrdsize_id, & nc_dstgrdfrac_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination grid frac')) return - ncstat = nf90_put_att(nc_file_id, nc_dstgrdfrac_id, + ncstat = nf90_put_att(nc_file_id, nc_dstgrdfrac_id, & 'units', 'unitless') if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination frac units')) return @@ -1816,20 +1816,20 @@ subroutine write_remap_csm(map_name, interp_file, direction, !*** define mapping arrays !*** - ncstat = nf90_def_var(nc_file_id, 'col', - & NF90_INT, nc_numlinks_id, + ncstat = nf90_def_var(nc_file_id, 'col', + & NF90_INT, nc_numlinks_id, & nc_srcadd_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining source addresses')) return - ncstat = nf90_def_var(nc_file_id, 'row', - & NF90_INT, nc_numlinks_id, + ncstat = nf90_def_var(nc_file_id, 'row', + & NF90_INT, nc_numlinks_id, & nc_dstadd_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining destination addresses')) return - ncstat = nf90_def_var(nc_file_id, 'S', - & NF90_DOUBLE, nc_numlinks_id, + ncstat = nf90_def_var(nc_file_id, 'S', + & NF90_DOUBLE, nc_numlinks_id, & nc_rmpmatrix_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining weights')) return @@ -1838,8 +1838,8 @@ subroutine write_remap_csm(map_name, interp_file, direction, nc_dims2_id(1) = nc_numwgts1_id nc_dims2_id(2) = nc_numlinks_id - ncstat = nf90_def_var(nc_file_id, 'S2', - & NF90_DOUBLE, nc_dims2_id, + ncstat = nf90_def_var(nc_file_id, 'S2', + & NF90_DOUBLE, nc_dims2_id, & nc_rmpmatrix2_id) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error defining weights2')) return @@ -1935,7 +1935,7 @@ subroutine write_remap_csm(map_name, interp_file, direction, if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing grid2 dims')) return - ncstat = nf90_put_var(nc_file_id, nc_srcgrdimask_id, + ncstat = nf90_put_var(nc_file_id, nc_srcgrdimask_id, & src_mask_int) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source grid mask')) return @@ -2040,18 +2040,18 @@ subroutine write_remap_csm(map_name, interp_file, direction, & 'error writing grid2 frac')) return if (direction == 1) then - ncstat = nf90_put_var(nc_file_id, nc_srcadd_id, + ncstat = nf90_put_var(nc_file_id, nc_srcadd_id, & grid1_add_map1) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source addresses')) return - ncstat = nf90_put_var(nc_file_id, nc_dstadd_id, + ncstat = nf90_put_var(nc_file_id, nc_dstadd_id, & grid2_add_map1) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination addresses')) return if (num_wts == 1) then - ncstat = nf90_put_var(nc_file_id, nc_rmpmatrix_id, + ncstat = nf90_put_var(nc_file_id, nc_rmpmatrix_id, & wts_map1(1,:)) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing weights')) return @@ -2070,18 +2070,18 @@ subroutine write_remap_csm(map_name, interp_file, direction, deallocate(wts1,wts2) endif else - ncstat = nf90_put_var(nc_file_id, nc_srcadd_id, + ncstat = nf90_put_var(nc_file_id, nc_srcadd_id, & grid2_add_map2) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing source addresses')) return - ncstat = nf90_put_var(nc_file_id, nc_dstadd_id, + ncstat = nf90_put_var(nc_file_id, nc_dstadd_id, & grid1_add_map2) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing destination addresses')) return if (num_wts == 1) then - ncstat = nf90_put_var(nc_file_id, nc_rmpmatrix_id, + ncstat = nf90_put_var(nc_file_id, nc_rmpmatrix_id, & wts_map2(1,:)) if (SCRIP_NetcdfErrorCheck(ncstat, errorCode, rtnName, & 'error writing weights')) return @@ -2163,7 +2163,7 @@ subroutine sort_add(add1, add2, weights) !----------------------------------------------------------------------- ! -! start at the lowest level (N/2) of the tree and sift lower +! start at the lowest level (N/2) of the tree and sift lower ! values to the bottom of the tree, promoting the larger numbers ! !----------------------------------------------------------------------- @@ -2194,7 +2194,7 @@ subroutine sort_add(add1, add2, weights) & ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. & (add2(chk_lvl1) > add2(chk_lvl2)))) then max_lvl = chk_lvl1 - else + else max_lvl = chk_lvl2 endif @@ -2218,7 +2218,7 @@ subroutine sort_add(add1, add2, weights) !*** store last values and exit the loop !*** - else + else add1(final_lvl) = add1(max_lvl) add2(final_lvl) = add2(max_lvl) weights(:,final_lvl) = weights(:,max_lvl) @@ -2257,7 +2257,7 @@ subroutine sort_add(add1, add2, weights) weights(:,lvl) = weights(:,1) !*** - !*** as above this loop sifts the tmp values down until proper + !*** as above this loop sifts the tmp values down until proper !*** level is reached !*** @@ -2277,7 +2277,7 @@ subroutine sort_add(add1, add2, weights) & ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. & (add2(chk_lvl1) > add2(chk_lvl2)))) then max_lvl = chk_lvl1 - else + else max_lvl = chk_lvl2 endif @@ -2301,7 +2301,7 @@ subroutine sort_add(add1, add2, weights) !*** store last values and exit the loop !*** - else + else add1(final_lvl) = add1(max_lvl) add2(final_lvl) = add2(max_lvl) weights(:,final_lvl) = weights(:,max_lvl) diff --git a/model/src/SCRIP/scrip_timers.f b/model/src/SCRIP/scrip_timers.f index cca0ab280..99fc34343 100644 --- a/model/src/SCRIP/scrip_timers.f +++ b/model/src/SCRIP/scrip_timers.f @@ -7,12 +7,12 @@ ! ! CVS:$Id: timers.f,v 1.2 2000/04/19 21:56:26 pwjones Exp $ ! -! Copyright (c) 1997, 1998 the Regents of the University of +! Copyright (c) 1997, 1998 the Regents of the University of ! California. ! -! This software and ancillary information (herein called software) -! called SCRIP is made available under the terms described here. -! The software has been approved for release with associated +! This software and ancillary information (herein called software) +! called SCRIP is made available under the terms described here. +! The software has been approved for release with associated ! LA-CC Number 98-45. ! ! Unless otherwise indicated, this software has been authored @@ -27,10 +27,10 @@ ! any liability or responsibility for the use of this software. ! ! If software is modified to produce derivative works, such modified -! software should be clearly marked, so as not to confuse it with +! software should be clearly marked, so as not to confuse it with ! the version available from Los Alamos National Laboratory. ! -! This code has been modified from the version available from +! This code has been modified from the version available from ! Los Alamos National Laboratory, for the purpose of running it ! within WW3. ! @@ -44,23 +44,23 @@ module scrip_timers implicit none - integer (SCRIP_i4), parameter :: + integer (SCRIP_i4), parameter :: & max_timers = 99 ! max number of timers allowed - integer (SCRIP_i4), save :: + integer (SCRIP_i4), save :: & cycles_max ! max value of clock allowed by system - integer (SCRIP_i4), dimension(max_timers), save :: + integer (SCRIP_i4), dimension(max_timers), save :: & cycles1, ! cycle number at start for each timer & cycles2 ! cycle number at stop for each timer - real (SCRIP_r4), save :: + real (SCRIP_r4), save :: & clock_rate ! clock_rate in seconds for each cycle - real (SCRIP_r4), dimension(max_timers), save :: + real (SCRIP_r4), dimension(max_timers), save :: & cputime ! accumulated cpu time in each timer - character (len=8), dimension(max_timers), save :: + character (len=8), dimension(max_timers), save :: & status ! timer status string !*********************************************************************** @@ -85,7 +85,7 @@ subroutine timer_check(timer) ! !----------------------------------------------------------------------- - integer (SCRIP_i4), intent(in) :: + integer (SCRIP_i4), intent(in) :: & timer ! timer number !----------------------------------------------------------------------- @@ -115,7 +115,7 @@ subroutine timer_clear(timer) ! !----------------------------------------------------------------------- - integer (SCRIP_i4), intent(in) :: + integer (SCRIP_i4), intent(in) :: & timer ! timer number !----------------------------------------------------------------------- @@ -133,7 +133,7 @@ function timer_get(timer) !----------------------------------------------------------------------- ! ! This routine returns the result of a given timer. This can be -! called instead of timer_print so that the calling routine can +! called instead of timer_print so that the calling routine can ! print it in desired format. ! !----------------------------------------------------------------------- @@ -144,7 +144,7 @@ function timer_get(timer) ! !----------------------------------------------------------------------- - integer (SCRIP_i4), intent(in) :: + integer (SCRIP_i4), intent(in) :: & timer ! timer number !----------------------------------------------------------------------- @@ -153,7 +153,7 @@ function timer_get(timer) ! !----------------------------------------------------------------------- - real (SCRIP_r4) :: + real (SCRIP_r4) :: & timer_get ! accumulated cputime in given timer !----------------------------------------------------------------------- @@ -186,22 +186,22 @@ subroutine timer_print(timer) ! !----------------------------------------------------------------------- - integer (SCRIP_i4), intent(in) :: + integer (SCRIP_i4), intent(in) :: & timer ! timer number !----------------------------------------------------------------------- - !--- - !--- print the cputime accumulated for timer + !--- + !--- print the cputime accumulated for timer !--- make sure timer is stopped !--- if (status(timer) .eq. 'stopped') then - write(*,"(' CPU time for timer',i3,':',1p,e16.8)") + write(*,"(' CPU time for timer',i3,':',1p,e16.8)") & timer,cputime(timer) else call timer_stop(timer) - write(*,"(' CPU time for timer',i3,':',1p,e16.8)") + write(*,"(' CPU time for timer',i3,':',1p,e16.8)") & timer,cputime(timer) call timer_start(timer) endif @@ -226,7 +226,7 @@ subroutine timer_start(timer) ! !----------------------------------------------------------------------- - integer (SCRIP_i4), intent(in) :: + integer (SCRIP_i4), intent(in) :: & timer ! timer number !----------------------------------------------------------------------- @@ -260,7 +260,7 @@ subroutine timer_stop(timer) ! !----------------------------------------------------------------------- - integer (SCRIP_i4), intent(in) :: + integer (SCRIP_i4), intent(in) :: & timer ! timer number !----------------------------------------------------------------------- @@ -278,10 +278,10 @@ subroutine timer_stop(timer) !--- if (cycles2(timer) .ge. cycles1(timer)) then - cputime(timer) = cputime(timer) + clock_rate* + cputime(timer) = cputime(timer) + clock_rate* & (cycles2(timer) - cycles1(timer)) else - cputime(timer) = cputime(timer) + clock_rate* + cputime(timer) = cputime(timer) + clock_rate* & (cycles2(timer) - cycles1(timer) + cycles_max) endif diff --git a/model/src/cmake/switches.json b/model/src/cmake/switches.json index 8bf45060b..004145909 100644 --- a/model/src/cmake/switches.json +++ b/model/src/cmake/switches.json @@ -209,7 +209,7 @@ { "name": "LN1", "build_files": ["w3sln1md.F90"] - } + } ] }, { @@ -260,7 +260,7 @@ { "name": "STAB2", "requires": ["ST2"] - + }, { "name": "STAB3", @@ -357,7 +357,7 @@ "valid-options": [ { "name": "MLIM" - } + } ] }, { @@ -385,7 +385,7 @@ { "name": "BS1", "build_files": ["w3sbs1md.F90"] - } + } ] }, { @@ -561,7 +561,7 @@ "valid-options": [ { "name": "MGP" - } + } ] }, { diff --git a/model/src/constants.F90 b/model/src/constants.F90 index b071b1705..c4f67b371 100644 --- a/model/src/constants.F90 +++ b/model/src/constants.F90 @@ -8,7 +8,7 @@ !> !> @brief Define some much-used constants for global use (all defined !> as PARAMETER). -!> +!> !> @author H. L. Tolman @date 05-Jun-2018 !> ! @@ -17,428 +17,428 @@ #endif ! !/ ------------------------------------------------------------------- / - MODULE CONSTANTS -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 05-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 11-Nov-1999 : Fortran 90 version. ( version 2.00 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 25-Jun-2011 : Adding Kelvin functions. ( version 4.05 ) -!/ 03-Sep-2012 : Adding TSTOUT flag. ( version 4.10 ) -!/ 28-Feb-2013 : Adding cap at 0.5 in FWTABLE ( version 4.08 ) -!/ 20-Jan-2017 : Add parameters for ESMF ( version 6.02 ) -!/ 01-Mar-2018 : Add UNDEF parameter ( version 6.02 ) -!/ 05-Jun-2018 : Add PDLIB parameters ( version 6.04 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Define some much-used constants for global use (all defined -! as PARAMETER). -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! UNDEF Real Global Value for undefined variable in output -! ---------------------------------------------------------------- -!/ ------------------------------------------------------------------- / -!/ - LOGICAL, PARAMETER :: TSTOUT = .FALSE. !< TSTOUT Flag for generation of test files. -! The flag for generating test output files is included here as -! it is needed in both ww3_shel and ww3_multi at the same time. -! Make sure that this flag is true if you want to write to the -! test output file ! - REAL, PARAMETER :: GRAV = 9.806 !< GRAV Acc. of gravity (m/s2). - REAL, PARAMETER :: DWAT = 1000. !< DWAT Density of water (kg/m3). - REAL, PARAMETER :: DAIR = 1.225 !< DAIR Density of air (kg/m3). - REAL, PARAMETER :: NU_AIR = 1.4E-5 !< NU_AIR Kinematic viscosity of air (m2/s). -!mdo *** Changing nu_water to be consistent with DWAT=1000 (assumes 10degC) -!mdo WAS: 3.E-6 - REAL, PARAMETER :: NU_WATER = 1.31E-6 !< NU_WATER Kinematic viscosity of water (m2/s). - REAL, PARAMETER :: SED_SG = 2.65 !< SED_SG Specific gravity of sediments (N.D.). - REAL, PARAMETER :: KAPPA = 0.40 !< KAPPA von Karman's constant (N.D.). -! - REAL, PARAMETER :: PI = 3.141592653589793 !< PI Value of Pi. - REAL, PARAMETER :: TPI = 2.0 * PI !< TPI 2*Pi. - REAL, PARAMETER :: HPI = 0.5 * PI !< HPI 1/2*Pi. - REAL, PARAMETER :: TPIINV = 1. / TPI !< TPIINV Inverse of 2*Pi. - REAL, PARAMETER :: HPIINV = 1. / HPI !< HPIINV Inverse of 1/2*Pi. - REAL, PARAMETER :: RADE = 180. / PI !< RADE Conversion factor from radians to degrees. - REAL, PARAMETER :: DERA = PI / 180. !< DERA Conversion factor from degrees to radians. -! - REAL, PARAMETER :: RADIUS = 4.E7 * TPIINV !< RADIUS Radius of the earth (m). -! - REAL, PARAMETER :: G2PI3I = 1. / ( GRAV**2 * TPI**3 ) !< G2PI3I Inverse of gravity^2 * (2*Pi)^3. - REAL, PARAMETER :: G1PI1I = 1. / ( GRAV * TPI ) !< G1PI1I Inverse of gravity * 2 * Pi. -! - REAL :: UNDEF = -999.9 !< UNDEF Value for undefined variable in output. +MODULE CONSTANTS + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 05-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 11-Nov-1999 : Fortran 90 version. ( version 2.00 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 25-Jun-2011 : Adding Kelvin functions. ( version 4.05 ) + !/ 03-Sep-2012 : Adding TSTOUT flag. ( version 4.10 ) + !/ 28-Feb-2013 : Adding cap at 0.5 in FWTABLE ( version 4.08 ) + !/ 20-Jan-2017 : Add parameters for ESMF ( version 6.02 ) + !/ 01-Mar-2018 : Add UNDEF parameter ( version 6.02 ) + !/ 05-Jun-2018 : Add PDLIB parameters ( version 6.04 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Define some much-used constants for global use (all defined + ! as PARAMETER). + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! UNDEF Real Global Value for undefined variable in output + ! ---------------------------------------------------------------- + !/ ------------------------------------------------------------------- / + !/ + LOGICAL, PARAMETER :: TSTOUT = .FALSE. !< TSTOUT Flag for generation of test files. + ! The flag for generating test output files is included here as + ! it is needed in both ww3_shel and ww3_multi at the same time. + ! Make sure that this flag is true if you want to write to the + ! test output file ! + REAL, PARAMETER :: GRAV = 9.806 !< GRAV Acc. of gravity (m/s2). + REAL, PARAMETER :: DWAT = 1000. !< DWAT Density of water (kg/m3). + REAL, PARAMETER :: DAIR = 1.225 !< DAIR Density of air (kg/m3). + REAL, PARAMETER :: NU_AIR = 1.4E-5 !< NU_AIR Kinematic viscosity of air (m2/s). + !mdo *** Changing nu_water to be consistent with DWAT=1000 (assumes 10degC) + !mdo WAS: 3.E-6 + REAL, PARAMETER :: NU_WATER = 1.31E-6 !< NU_WATER Kinematic viscosity of water (m2/s). + REAL, PARAMETER :: SED_SG = 2.65 !< SED_SG Specific gravity of sediments (N.D.). + REAL, PARAMETER :: KAPPA = 0.40 !< KAPPA von Karman's constant (N.D.). + ! + REAL, PARAMETER :: PI = 3.141592653589793 !< PI Value of Pi. + REAL, PARAMETER :: TPI = 2.0 * PI !< TPI 2*Pi. + REAL, PARAMETER :: HPI = 0.5 * PI !< HPI 1/2*Pi. + REAL, PARAMETER :: TPIINV = 1. / TPI !< TPIINV Inverse of 2*Pi. + REAL, PARAMETER :: HPIINV = 1. / HPI !< HPIINV Inverse of 1/2*Pi. + REAL, PARAMETER :: RADE = 180. / PI !< RADE Conversion factor from radians to degrees. + REAL, PARAMETER :: DERA = PI / 180. !< DERA Conversion factor from degrees to radians. + ! + REAL, PARAMETER :: RADIUS = 4.E7 * TPIINV !< RADIUS Radius of the earth (m). + ! + REAL, PARAMETER :: G2PI3I = 1. / ( GRAV**2 * TPI**3 ) !< G2PI3I Inverse of gravity^2 * (2*Pi)^3. + REAL, PARAMETER :: G1PI1I = 1. / ( GRAV * TPI ) !< G1PI1I Inverse of gravity * 2 * Pi. + ! + REAL :: UNDEF = -999.9 !< UNDEF Value for undefined variable in output. - CHARACTER(*), PARAMETER :: FILE_ENDIAN = ENDIANNESS !< FILE_ENDIAN Filled by preprocessor with 'big_endian', - !< 'little_endian', or 'native'. -! -! Parameters for friction factor table -! - INTEGER, PARAMETER :: SIZEFWTABLE=300 !< SIZEFWTABLE - REAL :: FWTABLE(0:SIZEFWTABLE) !< FWTABLE - REAL :: DELAB !< DELAB - REAL, PARAMETER :: ABMIN = -1. !< ABMIN - REAL, PRIVATE, PARAMETER :: ABMAX = 8. !< ABMAX - INTEGER, PARAMETER :: srce_direct = 0 !< srce_direct - INTEGER, PARAMETER :: srce_imp_post = 1 !< srce_imp_post - INTEGER, PARAMETER :: srce_imp_pre = 2 !< srce_imp_pre - INTEGER, PARAMETER :: DEBUG_NODE = 1014 !< DEBUG_NODE Node number used for debugging. - INTEGER, PARAMETER :: DEBUG_ELEMENT = 50 !< DEBUG_ELEMENT Element number used for debug. - LOGICAL :: LPDLIB = .FALSE. !< LPDLIB Logical for using the PDLIB library. - LOGICAL :: LSETUP = .FALSE. !< LSETUP Logical LSETUP is not used. -! -! Parameters in support of running as ESMF component -! -! --- Flag indicating whether or not the model has been invoked as an -! ESMF Component. This flag is set to true in the WMESMFMD ESMF -! module during initialization. - LOGICAL :: IS_ESMF_COMPONENT = .FALSE. !< IS_ESMF_COMPONENT Flag for model invoked via ESMF. -! - CONTAINS -! ---------------------------------------------------------------------- -!> -!> @brief Estimate friction coefficients in oscillatory boundary layers -!> using tabulation on Kelvin functions. -!> -!> @author F. Ardhuin @date 28-Feb-2013 -!> - SUBROUTINE TABU_FW -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 28-Feb-2013 | -!/ +-----------------------------------+ -!/ -!/ 19-Oct-2007 : Origination. ( version 3.13 ) -!/ 28-Feb-2013 : Caps the friction factor to 0.5 ( version 4.08 ) -!/ -! 1. Purpose : -! TO estimate friction coefficients in oscillatory boundary layers -! METHOD. -! tabulation on Kelvin functions -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_GRID Prog. WW3_GRID Model grid initialization -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - INTEGER, PARAMETER :: NITER=100 - REAL , PARAMETER :: XM=0.50 - REAL , PARAMETER :: EPS1=0.00001 -! ---------------------------------------------------------------------- - INTEGER I,ITER - REAL KER, KEI - REAL ABR,ABRLOG,L10,FACT,FSUBW,FSUBWMEMO,dzeta0,dzeta0memo -! - DELAB = (ABMAX-ABMIN)/REAL(SIZEFWTABLE) - L10=ALOG(10.) - DO I=0,SIZEFWTABLE -! -! index I in this table corresponds to a normalized roughness z0/ABR = 10^ABMIN+REAL(I)*DELAB -! - ABRLOG=ABMIN+REAL(I)*DELAB - ABR=EXP(ABRLOG*L10) - FACT=1/ABR/(21.2*KAPPA) - FSUBW=0.05 - dzeta0=0. - DO ITER=1,NITER - fsubwmemo=fsubw - dzeta0memo=dzeta0 - dzeta0=fact*fsubw**(-.5) - CALL KERKEI(2.*SQRT(dzeta0),ker,kei) - fsubw=.08/(ker**2+kei**2) - fsubw=.5*(fsubwmemo+fsubw) - dzeta0=.5*(dzeta0memo+dzeta0) - END DO -! -! Maximum value of 0.5 for fe is based on field -! and lab experiment by Lowe et al. JGR 2005, 2007 -! - FWTABLE(I) = MIN(fsubw,0.5) -! WRITE(994,*) 'Friction factor:',I,ABR,FWTABLE(I) - END DO - RETURN - END SUBROUTINE TABU_FW + CHARACTER(*), PARAMETER :: FILE_ENDIAN = ENDIANNESS !< FILE_ENDIAN Filled by preprocessor with 'big_endian', + !< 'little_endian', or 'native'. + ! + ! Parameters for friction factor table + ! + INTEGER, PARAMETER :: SIZEFWTABLE=300 !< SIZEFWTABLE + REAL :: FWTABLE(0:SIZEFWTABLE) !< FWTABLE + REAL :: DELAB !< DELAB + REAL, PARAMETER :: ABMIN = -1. !< ABMIN + REAL, PRIVATE, PARAMETER :: ABMAX = 8. !< ABMAX + INTEGER, PARAMETER :: srce_direct = 0 !< srce_direct + INTEGER, PARAMETER :: srce_imp_post = 1 !< srce_imp_post + INTEGER, PARAMETER :: srce_imp_pre = 2 !< srce_imp_pre + INTEGER, PARAMETER :: DEBUG_NODE = 1014 !< DEBUG_NODE Node number used for debugging. + INTEGER, PARAMETER :: DEBUG_ELEMENT = 50 !< DEBUG_ELEMENT Element number used for debug. + LOGICAL :: LPDLIB = .FALSE. !< LPDLIB Logical for using the PDLIB library. + LOGICAL :: LSETUP = .FALSE. !< LSETUP Logical LSETUP is not used. + ! + ! Parameters in support of running as ESMF component + ! + ! --- Flag indicating whether or not the model has been invoked as an + ! ESMF Component. This flag is set to true in the WMESMFMD ESMF + ! module during initialization. + LOGICAL :: IS_ESMF_COMPONENT = .FALSE. !< IS_ESMF_COMPONENT Flag for model invoked via ESMF. + ! +CONTAINS + ! ---------------------------------------------------------------------- + !> + !> @brief Estimate friction coefficients in oscillatory boundary layers + !> using tabulation on Kelvin functions. + !> + !> @author F. Ardhuin @date 28-Feb-2013 + !> + SUBROUTINE TABU_FW + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 28-Feb-2013 | + !/ +-----------------------------------+ + !/ + !/ 19-Oct-2007 : Origination. ( version 3.13 ) + !/ 28-Feb-2013 : Caps the friction factor to 0.5 ( version 4.08 ) + !/ + ! 1. Purpose : + ! TO estimate friction coefficients in oscillatory boundary layers + ! METHOD. + ! tabulation on Kelvin functions + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_GRID Prog. WW3_GRID Model grid initialization + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + INTEGER, PARAMETER :: NITER=100 + REAL , PARAMETER :: XM=0.50 + REAL , PARAMETER :: EPS1=0.00001 + ! ---------------------------------------------------------------------- + INTEGER I,ITER + REAL KER, KEI + REAL ABR,ABRLOG,L10,FACT,FSUBW,FSUBWMEMO,dzeta0,dzeta0memo + ! + DELAB = (ABMAX-ABMIN)/REAL(SIZEFWTABLE) + L10=ALOG(10.) + DO I=0,SIZEFWTABLE + ! + ! index I in this table corresponds to a normalized roughness z0/ABR = 10^ABMIN+REAL(I)*DELAB + ! + ABRLOG=ABMIN+REAL(I)*DELAB + ABR=EXP(ABRLOG*L10) + FACT=1/ABR/(21.2*KAPPA) + FSUBW=0.05 + dzeta0=0. + DO ITER=1,NITER + fsubwmemo=fsubw + dzeta0memo=dzeta0 + dzeta0=fact*fsubw**(-.5) + CALL KERKEI(2.*SQRT(dzeta0),ker,kei) + fsubw=.08/(ker**2+kei**2) + fsubw=.5*(fsubwmemo+fsubw) + dzeta0=.5*(dzeta0memo+dzeta0) + END DO + ! + ! Maximum value of 0.5 for fe is based on field + ! and lab experiment by Lowe et al. JGR 2005, 2007 + ! + FWTABLE(I) = MIN(fsubw,0.5) + ! WRITE(994,*) 'Friction factor:',I,ABR,FWTABLE(I) + END DO + RETURN + END SUBROUTINE TABU_FW -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!> -!> @brief June 1999 adaptation to CRESTb, all tests on range of (x,y) -!> have been bypassed, we implicitly expect X to be positive or |x,y| -!> non zero. -!> -!> @details The variables X and Y are the real and imaginary parts of -!> the argument of the first two modified bessel functions -!> of the second kind,k0 and k1. Re0,im0,re1 and im1 give -!> the real and imaginary parts of exp(x)*k0 and exp(x)*k1, -!> respectively. Although the real notation used in this -!> subroutine may seem inelegant when compared with the -!> complex notation that fortran allows, this version runs -!> about 30 percent faster than one written using complex -!> variables. -!> -!> @copyright This subroutine is copyright by ACM, see -!> http://www.acm.org/pubs/copyright_policy/softwareCRnotice.html. -!> ACM declines any responsibility of any kind. -!> -!> @param X Real part of argument to modified Bessel functions. -!> @param Y Imaginary part of argument to modified Bessel functions. -!> @param RE0 Real part of exp(x)*k0. -!> @param IM0 Imaginary part of exp(x)*k0. -!> @param RE1 Real part of exp(x)*k1. -!> @param IM1 Imaginary part of exp(x)*k1. -!> -!> @author N/A @date N/A -!> - SUBROUTINE KZEONE(X, Y, RE0, IM0, RE1, IM1) -! June 1999 adaptation to CRESTb, all tests on range of (x,y) have been -! bypassed, we implicitly expect X to be positive or |x,y| non zero -! -! This subroutine is copyright by ACM -! see http://www.acm.org/pubs/copyright_policy/softwareCRnotice.html -! ACM declines any responsibility of any kind -! -! THE VARIABLES X AND Y ARE THE REAL AND IMAGINARY PARTS OF -! THE ARGUMENT OF THE FIRST TWO MODIFIED BESSEL FUNCTIONS -! OF THE SECOND KIND,K0 AND K1. RE0,IM0,RE1 AND IM1 GIVE -! THE REAL AND IMAGINARY PARTS OF EXP(X)*K0 AND EXP(X)*K1, -! RESPECTIVELY. ALTHOUGH THE REAL NOTATION USED IN THIS -! SUBROUTINE MAY SEEM INELEGANT WHEN COMPARED WITH THE -! COMPLEX NOTATION THAT FORTRAN ALLOWS, THIS VERSION RUNS -! ABOUT 30 PERCENT FASTER THAN ONE WRITTEN USING COMPLEX -! VARIABLES. -! ACM Libraries -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - IMPLICIT NONE - DOUBLE PRECISION X, Y, X2, Y2, RE0, IM0, RE1, IM1, & - R1, R2, T1, T2, P1, P2, RTERM, ITERM, L - DOUBLE PRECISION , PARAMETER, DIMENSION(8) :: EXSQ = & + ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !> + !> @brief June 1999 adaptation to CRESTb, all tests on range of (x,y) + !> have been bypassed, we implicitly expect X to be positive or |x,y| + !> non zero. + !> + !> @details The variables X and Y are the real and imaginary parts of + !> the argument of the first two modified bessel functions + !> of the second kind,k0 and k1. Re0,im0,re1 and im1 give + !> the real and imaginary parts of exp(x)*k0 and exp(x)*k1, + !> respectively. Although the real notation used in this + !> subroutine may seem inelegant when compared with the + !> complex notation that fortran allows, this version runs + !> about 30 percent faster than one written using complex + !> variables. + !> + !> @copyright This subroutine is copyright by ACM, see + !> http://www.acm.org/pubs/copyright_policy/softwareCRnotice.html. + !> ACM declines any responsibility of any kind. + !> + !> @param X Real part of argument to modified Bessel functions. + !> @param Y Imaginary part of argument to modified Bessel functions. + !> @param RE0 Real part of exp(x)*k0. + !> @param IM0 Imaginary part of exp(x)*k0. + !> @param RE1 Real part of exp(x)*k1. + !> @param IM1 Imaginary part of exp(x)*k1. + !> + !> @author N/A @date N/A + !> + SUBROUTINE KZEONE(X, Y, RE0, IM0, RE1, IM1) + ! June 1999 adaptation to CRESTb, all tests on range of (x,y) have been + ! bypassed, we implicitly expect X to be positive or |x,y| non zero + ! + ! This subroutine is copyright by ACM + ! see http://www.acm.org/pubs/copyright_policy/softwareCRnotice.html + ! ACM declines any responsibility of any kind + ! + ! THE VARIABLES X AND Y ARE THE REAL AND IMAGINARY PARTS OF + ! THE ARGUMENT OF THE FIRST TWO MODIFIED BESSEL FUNCTIONS + ! OF THE SECOND KIND,K0 AND K1. RE0,IM0,RE1 AND IM1 GIVE + ! THE REAL AND IMAGINARY PARTS OF EXP(X)*K0 AND EXP(X)*K1, + ! RESPECTIVELY. ALTHOUGH THE REAL NOTATION USED IN THIS + ! SUBROUTINE MAY SEEM INELEGANT WHEN COMPARED WITH THE + ! COMPLEX NOTATION THAT FORTRAN ALLOWS, THIS VERSION RUNS + ! ABOUT 30 PERCENT FASTER THAN ONE WRITTEN USING COMPLEX + ! VARIABLES. + ! ACM Libraries + ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + IMPLICIT NONE + DOUBLE PRECISION X, Y, X2, Y2, RE0, IM0, RE1, IM1, & + R1, R2, T1, T2, P1, P2, RTERM, ITERM, L + DOUBLE PRECISION , PARAMETER, DIMENSION(8) :: EXSQ = & (/ 0.5641003087264D0,0.4120286874989D0,0.1584889157959D0, & - 0.3078003387255D-1,0.2778068842913D-2,0.1000044412325D-3, & - 0.1059115547711D-5,0.1522475804254D-8 /) - DOUBLE PRECISION , PARAMETER, DIMENSION(8) :: TSQ = & + 0.3078003387255D-1,0.2778068842913D-2,0.1000044412325D-3, & + 0.1059115547711D-5,0.1522475804254D-8 /) + DOUBLE PRECISION , PARAMETER, DIMENSION(8) :: TSQ = & (/ 0.0D0,3.19303633920635D-1,1.29075862295915D0, & - 2.95837445869665D0,5.40903159724444D0,8.80407957805676D0, & - 1.34685357432515D1,2.02499163658709D1 /) - INTEGER N,M,K -! THE ARRAYS TSQ AND EXSQ CONTAIN THE SQUARE OF THE -! ABSCISSAS AND THE WEIGHT FACTORS USED IN THE GAUSS- -! HERMITE QUADRATURE. - R2 = X*X + Y*Y - IF (R2.GE.1.96D2) GO TO 50 - IF (R2.GE.1.849D1) GO TO 30 -! THIS SECTION CALCULATES THE FUNCTIONS USING THE SERIES -! EXPANSIONS - X2 = X/2.0D0 - Y2 = Y/2.0D0 - P1 = X2*X2 - P2 = Y2*Y2 - T1 = -(DLOG(P1+P2)/2.0D0+0.5772156649015329D0) -! THE CONSTANT IN THE PRECEDING STATEMENT IS EULER*S -! CONSTANT - T2 = -DATAN2(Y,X) - X2 = P1 - P2 - Y2 = X*Y2 - RTERM = 1.0D0 - ITERM = 0.0D0 - RE0 = T1 - IM0 = T2 - T1 = T1 + 0.5D0 - RE1 = T1 - IM1 = T2 - P2 = DSQRT(R2) - L = 2.106D0*P2 + 4.4D0 - IF (P2.LT.8.0D-1) L = 2.129D0*P2 + 4.0D0 - DO N=1,INT(L) - P1 = N - P2 = N*N - R1 = RTERM - RTERM = (R1*X2-ITERM*Y2)/P2 - ITERM = (R1*Y2+ITERM*X2)/P2 - T1 = T1 + 0.5D0/P1 - RE0 = RE0 + T1*RTERM - T2*ITERM - IM0 = IM0 + T1*ITERM + T2*RTERM - P1 = P1 + 1.0D0 - T1 = T1 + 0.5D0/P1 - RE1 = RE1 + (T1*RTERM-T2*ITERM)/P1 - IM1 = IM1 + (T1*ITERM+T2*RTERM)/P1 - END DO - R1 = X/R2 - 0.5D0*(X*RE1-Y*IM1) - R2 = -Y/R2 - 0.5D0*(X*IM1+Y*RE1) - P1 = DEXP(X) - RE0 = P1*RE0 - IM0 = P1*IM0 - RE1 = P1*R1 - IM1 = P1*R2 - RETURN -! THIS SECTION CALCULATES THE FUNCTIONS USING THE INTEGRAL -! REPRESENTATION, EQN 3, EVALUATED WITH 15 POINT GAUSS- -! HERMITE QUADRATURE - 30 X2 = 2.0D0*X - Y2 = 2.0D0*Y - R1 = Y2*Y2 - P1 = DSQRT(X2*X2+R1) - P2 = DSQRT(P1+X2) - T1 = EXSQ(1)/(2.0D0*P1) - RE0 = T1*P2 - IM0 = T1/P2 - RE1 = 0.0D0 - IM1 = 0.0D0 - DO N=2,8 - T2 = X2 + TSQ(N) - P1 = DSQRT(T2*T2+R1) - P2 = DSQRT(P1+T2) - T1 = EXSQ(N)/P1 - RE0 = RE0 + T1*P2 - IM0 = IM0 + T1/P2 - T1 = EXSQ(N)*TSQ(N) - RE1 = RE1 + T1*P2 - IM1 = IM1 + T1/P2 - END DO - T2 = -Y2*IM0 - RE1 = RE1/R2 - R2 = Y2*IM1/R2 - RTERM = 1.41421356237309D0*DCOS(Y) - ITERM = -1.41421356237309D0*DSIN(Y) -! THE CONSTANT IN THE PREVIOUS STATEMENTS IS,OF COURSE, -! SQRT(2.0). - IM0 = RE0*ITERM + T2*RTERM - RE0 = RE0*RTERM - T2*ITERM - T1 = RE1*RTERM - R2*ITERM - T2 = RE1*ITERM + R2*RTERM - RE1 = T1*X + T2*Y - IM1 = -T1*Y + T2*X - RETURN -! THIS SECTION CALCULATES THE FUNCTIONS USING THE -! ASYMPTOTIC EXPANSIONS - 50 RTERM = 1.0D0 - ITERM = 0.0D0 - RE0 = 1.0D0 - IM0 = 0.0D0 - RE1 = 1.0D0 - IM1 = 0.0D0 - P1 = 8.0D0*R2 - P2 = DSQRT(R2) - L = 3.91D0+8.12D1/P2 - R1 = 1.0D0 - R2 = 1.0D0 - M = -8 - K = 3 - DO N=1,INT(L) - M = M + 8 - K = K - M - R1 = FLOAT(K-4)*R1 - R2 = FLOAT(K)*R2 - T1 = FLOAT(N)*P1 - T2 = RTERM - RTERM = (T2*X+ITERM*Y)/T1 - ITERM = (-T2*Y+ITERM*X)/T1 - RE0 = RE0 + R1*RTERM - IM0 = IM0 + R1*ITERM - RE1 = RE1 + R2*RTERM - IM1 = IM1 + R2*ITERM - END DO - T1 = DSQRT(P2+X) - T2 = -Y/T1 - P1 = 8.86226925452758D-1/P2 -! THIS CONSTANT IS SQRT(PI)/2.0, WITH PI=3.14159... - RTERM = P1*DCOS(Y) - ITERM = -P1*DSIN(Y) - R1 = RE0*RTERM - IM0*ITERM - R2 = RE0*ITERM + IM0*RTERM - RE0 = T1*R1 - T2*R2 - IM0 = T1*R2 + T2*R1 - R1 = RE1*RTERM - IM1*ITERM - R2 = RE1*ITERM + IM1*RTERM - RE1 = T1*R1 - T2*R2 - IM1 = T1*R2 + T2*R1 - RETURN - END SUBROUTINE KZEONE + 2.95837445869665D0,5.40903159724444D0,8.80407957805676D0, & + 1.34685357432515D1,2.02499163658709D1 /) + INTEGER N,M,K + ! THE ARRAYS TSQ AND EXSQ CONTAIN THE SQUARE OF THE + ! ABSCISSAS AND THE WEIGHT FACTORS USED IN THE GAUSS- + ! HERMITE QUADRATURE. + R2 = X*X + Y*Y + IF (R2.GE.1.96D2) GO TO 50 + IF (R2.GE.1.849D1) GO TO 30 + ! THIS SECTION CALCULATES THE FUNCTIONS USING THE SERIES + ! EXPANSIONS + X2 = X/2.0D0 + Y2 = Y/2.0D0 + P1 = X2*X2 + P2 = Y2*Y2 + T1 = -(DLOG(P1+P2)/2.0D0+0.5772156649015329D0) + ! THE CONSTANT IN THE PRECEDING STATEMENT IS EULER*S + ! CONSTANT + T2 = -DATAN2(Y,X) + X2 = P1 - P2 + Y2 = X*Y2 + RTERM = 1.0D0 + ITERM = 0.0D0 + RE0 = T1 + IM0 = T2 + T1 = T1 + 0.5D0 + RE1 = T1 + IM1 = T2 + P2 = DSQRT(R2) + L = 2.106D0*P2 + 4.4D0 + IF (P2.LT.8.0D-1) L = 2.129D0*P2 + 4.0D0 + DO N=1,INT(L) + P1 = N + P2 = N*N + R1 = RTERM + RTERM = (R1*X2-ITERM*Y2)/P2 + ITERM = (R1*Y2+ITERM*X2)/P2 + T1 = T1 + 0.5D0/P1 + RE0 = RE0 + T1*RTERM - T2*ITERM + IM0 = IM0 + T1*ITERM + T2*RTERM + P1 = P1 + 1.0D0 + T1 = T1 + 0.5D0/P1 + RE1 = RE1 + (T1*RTERM-T2*ITERM)/P1 + IM1 = IM1 + (T1*ITERM+T2*RTERM)/P1 + END DO + R1 = X/R2 - 0.5D0*(X*RE1-Y*IM1) + R2 = -Y/R2 - 0.5D0*(X*IM1+Y*RE1) + P1 = DEXP(X) + RE0 = P1*RE0 + IM0 = P1*IM0 + RE1 = P1*R1 + IM1 = P1*R2 + RETURN + ! THIS SECTION CALCULATES THE FUNCTIONS USING THE INTEGRAL + ! REPRESENTATION, EQN 3, EVALUATED WITH 15 POINT GAUSS- + ! HERMITE QUADRATURE +30 X2 = 2.0D0*X + Y2 = 2.0D0*Y + R1 = Y2*Y2 + P1 = DSQRT(X2*X2+R1) + P2 = DSQRT(P1+X2) + T1 = EXSQ(1)/(2.0D0*P1) + RE0 = T1*P2 + IM0 = T1/P2 + RE1 = 0.0D0 + IM1 = 0.0D0 + DO N=2,8 + T2 = X2 + TSQ(N) + P1 = DSQRT(T2*T2+R1) + P2 = DSQRT(P1+T2) + T1 = EXSQ(N)/P1 + RE0 = RE0 + T1*P2 + IM0 = IM0 + T1/P2 + T1 = EXSQ(N)*TSQ(N) + RE1 = RE1 + T1*P2 + IM1 = IM1 + T1/P2 + END DO + T2 = -Y2*IM0 + RE1 = RE1/R2 + R2 = Y2*IM1/R2 + RTERM = 1.41421356237309D0*DCOS(Y) + ITERM = -1.41421356237309D0*DSIN(Y) + ! THE CONSTANT IN THE PREVIOUS STATEMENTS IS,OF COURSE, + ! SQRT(2.0). + IM0 = RE0*ITERM + T2*RTERM + RE0 = RE0*RTERM - T2*ITERM + T1 = RE1*RTERM - R2*ITERM + T2 = RE1*ITERM + R2*RTERM + RE1 = T1*X + T2*Y + IM1 = -T1*Y + T2*X + RETURN + ! THIS SECTION CALCULATES THE FUNCTIONS USING THE + ! ASYMPTOTIC EXPANSIONS +50 RTERM = 1.0D0 + ITERM = 0.0D0 + RE0 = 1.0D0 + IM0 = 0.0D0 + RE1 = 1.0D0 + IM1 = 0.0D0 + P1 = 8.0D0*R2 + P2 = DSQRT(R2) + L = 3.91D0+8.12D1/P2 + R1 = 1.0D0 + R2 = 1.0D0 + M = -8 + K = 3 + DO N=1,INT(L) + M = M + 8 + K = K - M + R1 = FLOAT(K-4)*R1 + R2 = FLOAT(K)*R2 + T1 = FLOAT(N)*P1 + T2 = RTERM + RTERM = (T2*X+ITERM*Y)/T1 + ITERM = (-T2*Y+ITERM*X)/T1 + RE0 = RE0 + R1*RTERM + IM0 = IM0 + R1*ITERM + RE1 = RE1 + R2*RTERM + IM1 = IM1 + R2*ITERM + END DO + T1 = DSQRT(P2+X) + T2 = -Y/T1 + P1 = 8.86226925452758D-1/P2 + ! THIS CONSTANT IS SQRT(PI)/2.0, WITH PI=3.14159... + RTERM = P1*DCOS(Y) + ITERM = -P1*DSIN(Y) + R1 = RE0*RTERM - IM0*ITERM + R2 = RE0*ITERM + IM0*RTERM + RE0 = T1*R1 - T2*R2 + IM0 = T1*R2 + T2*R1 + R1 = RE1*RTERM - IM1*ITERM + R2 = RE1*ITERM + IM1*RTERM + RE1 = T1*R1 - T2*R2 + IM1 = T1*R2 + T2*R1 + RETURN + END SUBROUTINE KZEONE -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!> -!> @brief Computes the values of the zeroth order Kelvin function -!> Ker and Kei. -!> -!> @details These functions are used to determine the friction factor -!> fw as a function of the bottom roughness length assuming a linear -!> profile of eddy viscosity (See Grant and Madsen, 1979). -!> -!> @param X -!> @param KER -!> @param KEI -!> -!> @author N/A @date N/A -!> - SUBROUTINE KERKEI(X,KER,KEI) -!********************************************************************** -! Computes the values of the zeroth order Kelvin function Ker and Kei -! These functions are used to determine the friction factor fw as a -! function of the bottom roughness length assuming a linear profile -! of eddy viscosity (See Grant and Madsen, 1979) -!********************************************************************** - IMPLICIT NONE + ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !> + !> @brief Computes the values of the zeroth order Kelvin function + !> Ker and Kei. + !> + !> @details These functions are used to determine the friction factor + !> fw as a function of the bottom roughness length assuming a linear + !> profile of eddy viscosity (See Grant and Madsen, 1979). + !> + !> @param X + !> @param KER + !> @param KEI + !> + !> @author N/A @date N/A + !> + SUBROUTINE KERKEI(X,KER,KEI) + !********************************************************************** + ! Computes the values of the zeroth order Kelvin function Ker and Kei + ! These functions are used to determine the friction factor fw as a + ! function of the bottom roughness length assuming a linear profile + ! of eddy viscosity (See Grant and Madsen, 1979) + !********************************************************************** + IMPLICIT NONE - DOUBLE PRECISION ZR,ZI,CYR,CYI,CYR1,CYI1 - REAL X,KER,KEI + DOUBLE PRECISION ZR,ZI,CYR,CYI,CYR1,CYI1 + REAL X,KER,KEI - ZR=X*.50D0*SQRT(2.0D0) - ZI=ZR - CALL KZEONE(ZR, ZI, CYR, CYI,CYR1,CYI1) - KER=CYR/EXP(ZR) - KEI=CYI/EXP(ZR) -END SUBROUTINE KERKEI -!/ -!/ End of module CONSTANTS ------------------------------------------- / -!/ - END MODULE CONSTANTS + ZR=X*.50D0*SQRT(2.0D0) + ZI=ZR + CALL KZEONE(ZR, ZI, CYR, CYI,CYR1,CYI1) + KER=CYR/EXP(ZR) + KEI=CYI/EXP(ZR) + END SUBROUTINE KERKEI + !/ + !/ End of module CONSTANTS ------------------------------------------- / + !/ +END MODULE CONSTANTS diff --git a/model/src/ctest.F90 b/model/src/ctest.F90 index 567121bae..d9149c3a0 100644 --- a/model/src/ctest.F90 +++ b/model/src/ctest.F90 @@ -1,45 +1,45 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - SUBROUTINE CTEST -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! This subroutine provides no other purpose than to provide a test -! routine to set up error capturing in the 'comp' script. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -! - INTEGER IENT0, IENT1 -! -! The next line MIGHT generate a warning, depending on the compiler -! - IENT1 = IENT0 -! -! Activate this line to generate an error or warning -! -! IENT = 0 -! -! Activate this line to generate an error -! -! IENT == 0 -! - RETURN -!/ -!/ End of CTEST ----------------------------------------------------- / -!/ +SUBROUTINE CTEST + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! This subroutine provides no other purpose than to provide a test + ! routine to set up error capturing in the 'comp' script. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + ! + INTEGER IENT0, IENT1 + ! + ! The next line MIGHT generate a warning, depending on the compiler + ! + IENT1 = IENT0 + ! + ! Activate this line to generate an error or warning + ! + ! IENT = 0 + ! + ! Activate this line to generate an error + ! + ! IENT == 0 + ! + RETURN + !/ + !/ End of CTEST ----------------------------------------------------- / + !/ END SUBROUTINE CTEST diff --git a/model/src/gx_outf.F90 b/model/src/gx_outf.F90 index 61ec0464a..4c25b4425 100644 --- a/model/src/gx_outf.F90 +++ b/model/src/gx_outf.F90 @@ -1,1432 +1,1429 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - PROGRAM GXOUTF -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | A. Chawla | -!/ | J.H.G.M. Alves | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 30-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 25-Jan-2001 : Cartesian grid version ( version 2.06 ) -!/ 29-Jan-2001 : Add output fields 17-18 ( version 2.20 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 27-Jun-2005 : Adding MAPST2. ( version 3.07 ) -!/ 21-Jul-2005 : Add output fields 19-21. ( version 3.07 ) -!/ 15-Dec-2005 : Updating MAPST2 for 2-way nest. ( version 3.08 ) -!/ 13-Mar-2006 : MSOUT and MBOUT added. ( version 3.09 ) -!/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 18-Jan-2007 : Update MSOUT/MBOUT treatment. ( version 3.10 ) -!/ 28-Mar-2007 : Adding partitioned output. ( version 3.11 ) -!/ Adding user slots for outputs. -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 05-Oct-2011 : Updating to the 53 output parameter ( version 4.05 ) -!/ (J-H Alves) -!/ 25-Feb-2013 : Adding double-index output fields ( version 4.11 ) -!/ 27-Aug-2015 : ICEH and ICEF added as output ( version 5.10 ) -!/ 25-Aug-2018 : Add WBT parameter ( version 6.06 ) -!/ 22-Mar-2021 : RHOA and TAUA added as output ( version 7.13 ) -!/ -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Generate GrADS input files from raw WAVEWATCH data file. -! -! 2. Method : -! -! Data is read from the grid output file out_grd.ww3 (raw data) -! and from the file gx_outf.inp ( NDSI, output requests ). -! Model definition and raw data files are read using WAVEWATCH III -! subroutines. -! -! Output files are ww3.ctl and ww3.grads. the output files -! contains a land-sea map, followed by requested fields. See the -! control file for the names of the fields. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W3NAUX Subr. W3ADATMD Set number of model for aux data. -! W3SETA Subr. Id. Point to selected model for aux data. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! STME21 Subr. W3TIMEMD Convert time to string. -! TICK21 Subr. Id. Advance time. -! DSEC21 Func. Id. Difference between times. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. -! W3READFLGRD Subr. W3IOGOMD Reading output fields flags. -! W3EXGO Subr. Internal Execute grid output. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! Checks on input, checks in W3IOxx. -! Check on grid type. -! -! 7. Remarks : -! -! - For the Cartesian grid version the X and Y increment are -! artificially converted to long-lat by assuming the 1 degree -! equals 100 km. -! - Curvilinear grids currently not supported. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ -! USE W3GDATMD, ONLY: W3NMOD, W3SETG - USE W3WDATMD, ONLY: W3NDAT, W3SETW - USE W3ADATMD, ONLY: W3NAUX, W3SETA - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3IOGRMD, ONLY: W3IOGR - USE W3IOGOMD, ONLY: W3READFLGRD, W3IOGO - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE +PROGRAM GXOUTF + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | A. Chawla | + !/ | J.H.G.M. Alves | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 30-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 25-Jan-2001 : Cartesian grid version ( version 2.06 ) + !/ 29-Jan-2001 : Add output fields 17-18 ( version 2.20 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 27-Jun-2005 : Adding MAPST2. ( version 3.07 ) + !/ 21-Jul-2005 : Add output fields 19-21. ( version 3.07 ) + !/ 15-Dec-2005 : Updating MAPST2 for 2-way nest. ( version 3.08 ) + !/ 13-Mar-2006 : MSOUT and MBOUT added. ( version 3.09 ) + !/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 18-Jan-2007 : Update MSOUT/MBOUT treatment. ( version 3.10 ) + !/ 28-Mar-2007 : Adding partitioned output. ( version 3.11 ) + !/ Adding user slots for outputs. + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 05-Oct-2011 : Updating to the 53 output parameter ( version 4.05 ) + !/ (J-H Alves) + !/ 25-Feb-2013 : Adding double-index output fields ( version 4.11 ) + !/ 27-Aug-2015 : ICEH and ICEF added as output ( version 5.10 ) + !/ 25-Aug-2018 : Add WBT parameter ( version 6.06 ) + !/ 22-Mar-2021 : RHOA and TAUA added as output ( version 7.13 ) + !/ + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Generate GrADS input files from raw WAVEWATCH data file. + ! + ! 2. Method : + ! + ! Data is read from the grid output file out_grd.ww3 (raw data) + ! and from the file gx_outf.inp ( NDSI, output requests ). + ! Model definition and raw data files are read using WAVEWATCH III + ! subroutines. + ! + ! Output files are ww3.ctl and ww3.grads. the output files + ! contains a land-sea map, followed by requested fields. See the + ! control file for the names of the fields. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W3NAUX Subr. W3ADATMD Set number of model for aux data. + ! W3SETA Subr. Id. Point to selected model for aux data. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! TICK21 Subr. Id. Advance time. + ! DSEC21 Func. Id. Difference between times. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. + ! W3READFLGRD Subr. W3IOGOMD Reading output fields flags. + ! W3EXGO Subr. Internal Execute grid output. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! Checks on input, checks in W3IOxx. + ! Check on grid type. + ! + ! 7. Remarks : + ! + ! - For the Cartesian grid version the X and Y increment are + ! artificially converted to long-lat by assuming the 1 degree + ! equals 100 km. + ! - Curvilinear grids currently not supported. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG + USE W3WDATMD, ONLY: W3NDAT, W3SETW + USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3IOGRMD, ONLY: W3IOGR + USE W3IOGOMD, ONLY: W3READFLGRD, W3IOGO + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif - USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 -!/ - USE W3GDATMD - USE W3WDATMD, ONLY: TIME, WLV, ICE, ICEH, ICEF, BERG, & - UST, USTDIR, RHOAIR - USE W3ADATMD, ONLY: CFLXYMAX, CFLTHMAX, AS, CX, CY, UA, UD, WN, & - DW, HS, WLM, T01, T0M1, T02, THM, THS, FP0, & - THP0, ABA, ABD, UBA, UBD, FCUT, & - SXX, SYY, SXY, PHS, PTP, PLP, PDIR, PSI, PWS,& - PTM1, PT1, PT2, PEP, TAUA, TAUADIR, & - PTHP0, PQP, PSW, PPE, PGW, QP, & - PWST, PNR, USERO, TAUOX, TAUOY, TAUWIX, & - TAUWIY, PHIAW, PHIOC, TUSX, TUSY, PRMS, TPMS,& - USSX, USSY, MSSX, MSSY, MSCX, MSCY, CHARN, & - TAUWNX, TAUWNY, BHD, P2SMS, DTDYN, & - CGE, T02, BEDFORMS, WHITECAP, TAUBBL, PHIBBL,& - CFLXYMAX, CFLTHMAX, CFLKMAX, US3D, STMAXE, & - STMAXD, HMAXE, HCMAXE, HMAXD, HCMAXD, WBT - USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOGRP, NGRPP, IDOUT, UNDEF,& - FLOGRD, FNMPRE, NOSWLL, NOGE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NDSI, NDSM, NDSOG, NDSDAT, NDSCTL, & - NDSTRC, NTRACE, IERR, I,J,K, IFI,IFJ,& - TOUT(2), NOUT, TDUM(2), NVAR, IOUT, & - IX0, IXN, IY0, IYN, TIME0(2), IH0, & - IM0, ID0, IID, IJ0, IOTEST, IINC, IU,& - TIMEN(2), JLEN + USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 + !/ + USE W3GDATMD + USE W3WDATMD, ONLY: TIME, WLV, ICE, ICEH, ICEF, BERG, & + UST, USTDIR, RHOAIR + USE W3ADATMD, ONLY: CFLXYMAX, CFLTHMAX, AS, CX, CY, UA, UD, WN, & + DW, HS, WLM, T01, T0M1, T02, THM, THS, FP0, & + THP0, ABA, ABD, UBA, UBD, FCUT, & + SXX, SYY, SXY, PHS, PTP, PLP, PDIR, PSI, PWS,& + PTM1, PT1, PT2, PEP, TAUA, TAUADIR, & + PTHP0, PQP, PSW, PPE, PGW, QP, & + PWST, PNR, USERO, TAUOX, TAUOY, TAUWIX, & + TAUWIY, PHIAW, PHIOC, TUSX, TUSY, PRMS, TPMS,& + USSX, USSY, MSSX, MSSY, MSCX, MSCY, CHARN, & + TAUWNX, TAUWNY, BHD, P2SMS, DTDYN, & + CGE, T02, BEDFORMS, WHITECAP, TAUBBL, PHIBBL,& + CFLXYMAX, CFLTHMAX, CFLKMAX, US3D, STMAXE, & + STMAXD, HMAXE, HCMAXE, HMAXD, HCMAXD, WBT + USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOGRP, NGRPP, IDOUT, UNDEF,& + FLOGRD, FNMPRE, NOSWLL, NOGE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NDSI, NDSM, NDSOG, NDSDAT, NDSCTL, & + NDSTRC, NTRACE, IERR, I,J,K, IFI,IFJ,& + TOUT(2), NOUT, TDUM(2), NVAR, IOUT, & + IX0, IXN, IY0, IYN, TIME0(2), IH0, & + IM0, ID0, IID, IJ0, IOTEST, IINC, IU,& + TIMEN(2), JLEN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: DTREQ, DTEST - REAL :: FAC, XYMAX - CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & - CINC*2 - CHARACTER*3 :: MNTH(12) - CHARACTER*5 :: PARID - LOGICAL :: FLONE, FLTWO, FLDIR, FLTRI, FLPRT - LOGICAL :: FLREQ(NOGRP,NGRPP), FLOG(NOGRP), & - MSOUT, MBOUT, LTEMP(NGRPP) -!/ -!/ ------------------------------------------------------------------- / -!/ - DATA TIME0 / -1, 0 / - DATA MNTH / 'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN', & - 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC' / -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. IO set-up. -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! - NDSI = 10 - NDSM = 20 - NDSOG = 20 - NDSDAT = 50 - NDSCTL = 51 -! - NDSTRC = 6 - NTRACE = 10 -! - WRITE (NDSO,900) -! - CALL ITRACE ( NDSTRC, NTRACE ) + REAL :: DTREQ, DTEST + REAL :: FAC, XYMAX + CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & + CINC*2 + CHARACTER*3 :: MNTH(12) + CHARACTER*5 :: PARID + LOGICAL :: FLONE, FLTWO, FLDIR, FLTRI, FLPRT + LOGICAL :: FLREQ(NOGRP,NGRPP), FLOG(NOGRP), & + MSOUT, MBOUT, LTEMP(NGRPP) + !/ + !/ ------------------------------------------------------------------- / + !/ + DATA TIME0 / -1, 0 / + DATA MNTH / 'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN', & + 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC' / + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1. IO set-up. + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + NDSI = 10 + NDSM = 20 + NDSOG = 20 + NDSDAT = 50 + NDSCTL = 51 + ! + NDSTRC = 6 + NTRACE = 10 + ! + WRITE (NDSO,900) + ! + CALL ITRACE ( NDSTRC, NTRACE ) #ifdef W3_S - CALL STRACE (IENT, 'GXOUTF') + CALL STRACE (IENT, 'GXOUTF') #endif -! - JLEN = LEN_TRIM(FNMPRE) - OPEN (NDSI,FILE=FNMPRE(:JLEN)//'gx_outf.inp',STATUS='OLD', & - ERR=800,IOSTAT=IERR) - READ (NDSI,'(A)',END=801,ERR=802) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - WRITE (NDSO,920) GNAME - IF ( GTYPE .EQ. CLGTYPE ) THEN - WRITE(NDSE,*)'PROGRAM GXOUTF: '// & + ! + JLEN = LEN_TRIM(FNMPRE) + OPEN (NDSI,FILE=FNMPRE(:JLEN)//'gx_outf.inp',STATUS='OLD', & + ERR=800,IOSTAT=IERR) + READ (NDSI,'(A)',END=801,ERR=802) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + WRITE (NDSO,920) GNAME + IF ( GTYPE .EQ. CLGTYPE ) THEN + WRITE(NDSE,*)'PROGRAM GXOUTF: '// & 'GRADS OUTPUT NOT IMPLEMENTED FOR CURVILINEAR GRIDS. '// & 'NOW STOPPING.' - CALL EXTCDE ( 1 ) - END IF - IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN - WRITE(NDSE,*)'PROGRAM GXOUTF: '// & + CALL EXTCDE ( 1 ) + END IF + IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN + WRITE(NDSE,*)'PROGRAM GXOUTF: '// & 'GRADS OUTPUT NOT IMPLEMENTED FOR TRIPOLE GRIDS. '// & 'NOW STOPPING.' - CALL EXTCDE ( 1 ) + CALL EXTCDE ( 1 ) + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read general data and first fields from file + ! + CALL W3IOGO ( 'READ', NDSOG, IOTEST ) + ! + WRITE (NDSO,930) + DO I=1, NOGRP + DO J=1, NGRPP + IF ( FLOGRD(I,J) ) WRITE (NDSO,931) IDOUT(I,J) + END DO + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Read requests from input file. + ! Output times + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT + DTREQ = MAX ( 0. , DTREQ ) + IF ( DTREQ.EQ.0 ) NOUT = 1 + NOUT = MAX ( 1 , NOUT ) + ! + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,940) IDTIME + ! + TDUM = 0 + CALL TICK21 ( TDUM , DTREQ ) + CALL STME21 ( TDUM , IDTIME ) + IF ( DTREQ .GE. 86400. ) THEN + WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) + ELSE + IDDDAY = ' ' + END IF + IDTIME(1:11) = IDDDAY + IDTIME(21:23) = ' ' + WRITE (NDSO,941) IDTIME, NOUT + ! + IF ( MOD(NINT(DTREQ),60) .NE. 0 ) GOTO 810 + ! + ! ... Output fields + ! + FLREQ(:,:)=.FALSE. ! Initialize FLGRD + CALL W3READFLGRD ( NDSI, NDSO, 9, NDSE, COMSTR, FLOG, & + FLREQ, 1, 1, IERR ) + ! + ! + ! Reset flags for variables not yet implemented in grads output interface + ! + ! This needs to be reviewed whenever new parameters are added to the + ! grads ctl and data files + ! + IFI = 3 + DO IFJ = 1,NOGE(IFI) + IF ( FLREQ(IFI,IFJ) ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ), & + '*** NOT YET CODED INTO GXOUTF ***' + FLREQ(IFI,IFJ) = .FALSE. + END IF + END DO + IFI = 5 + DO IFJ = 7,10 + IF ( FLREQ(IFI,IFJ) ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ), & + '*** NOT YET CODED INTO GXOUTF ***' + FLREQ(IFI,IFJ) = .FALSE. + END IF + END DO + DO IFI = 6,8 + DO IFJ = 1,NOGE(IFI) + IF ( FLREQ(IFI,IFJ) ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ), & + '*** NOT YET CODED INTO GXOUTF ***' + FLREQ(IFI,IFJ) = .FALSE. END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read general data and first fields from file -! - CALL W3IOGO ( 'READ', NDSOG, IOTEST ) -! - WRITE (NDSO,930) - DO I=1, NOGRP - DO J=1, NGRPP - IF ( FLOGRD(I,J) ) WRITE (NDSO,931) IDOUT(I,J) - END DO - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Read requests from input file. -! Output times -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT - DTREQ = MAX ( 0. , DTREQ ) - IF ( DTREQ.EQ.0 ) NOUT = 1 - NOUT = MAX ( 1 , NOUT ) -! - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,940) IDTIME -! - TDUM = 0 - CALL TICK21 ( TDUM , DTREQ ) - CALL STME21 ( TDUM , IDTIME ) - IF ( DTREQ .GE. 86400. ) THEN - WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) + END DO + END DO + IFI = 10 + DO IFJ = 1,NOGE(IFI) + IF ( FLREQ(IFI,IFJ) ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ), & + '*** NOT YET CODED INTO GXOUTF ***' + FLREQ(IFI,IFJ) = .FALSE. + END IF + END DO + IF ( FLREQ(9,5) ) THEN + WRITE (NDSO,946) IDOUT(9,5),'*** NOT YET CODED INTO GXOUTF ***' + FLREQ(9,5) = .FALSE. + END IF + + WRITE (NDSO,945) + ! + NVAR = 1 + DO IFI=1, NOGRP + DO IFJ=1, NGRPP + IF ( FLREQ(IFI,IFJ) ) THEN + IF ( .NOT. FLOGRD(IFI,IFJ) ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ),'*** DATA NOT AVAILABLE ***' ELSE - IDDDAY = ' ' - END IF - IDTIME(1:11) = IDDDAY - IDTIME(21:23) = ' ' - WRITE (NDSO,941) IDTIME, NOUT -! - IF ( MOD(NINT(DTREQ),60) .NE. 0 ) GOTO 810 -! -! ... Output fields -! - FLREQ(:,:)=.FALSE. ! Initialize FLGRD - CALL W3READFLGRD ( NDSI, NDSO, 9, NDSE, COMSTR, FLOG, & - FLREQ, 1, 1, IERR ) -! -! -! Reset flags for variables not yet implemented in grads output interface -! -! This needs to be reviewed whenever new parameters are added to the -! grads ctl and data files -! - IFI = 3 - DO IFJ = 1,NOGE(IFI) - IF ( FLREQ(IFI,IFJ) ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ), & - '*** NOT YET CODED INTO GXOUTF ***' - FLREQ(IFI,IFJ) = .FALSE. - END IF - END DO - IFI = 5 - DO IFJ = 7,10 - IF ( FLREQ(IFI,IFJ) ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ), & - '*** NOT YET CODED INTO GXOUTF ***' - FLREQ(IFI,IFJ) = .FALSE. - END IF - END DO - DO IFI = 6,8 - DO IFJ = 1,NOGE(IFI) - IF ( FLREQ(IFI,IFJ) ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ), & - '*** NOT YET CODED INTO GXOUTF ***' - FLREQ(IFI,IFJ) = .FALSE. - END IF - END DO - END DO - IFI = 10 - DO IFJ = 1,NOGE(IFI) - IF ( FLREQ(IFI,IFJ) ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ), & - '*** NOT YET CODED INTO GXOUTF ***' - FLREQ(IFI,IFJ) = .FALSE. + WRITE (NDSO,946) IDOUT(IFI,IFJ), ' ' END IF - END DO - IF ( FLREQ(9,5) ) THEN - WRITE (NDSO,946) IDOUT(9,5),'*** NOT YET CODED INTO GXOUTF ***' - FLREQ(9,5) = .FALSE. END IF - - WRITE (NDSO,945) -! - NVAR = 1 - DO IFI=1, NOGRP - DO IFJ=1, NGRPP - IF ( FLREQ(IFI,IFJ) ) THEN - IF ( .NOT. FLOGRD(IFI,IFJ) ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ),'*** DATA NOT AVAILABLE ***' - ELSE - WRITE (NDSO,946) IDOUT(IFI,IFJ), ' ' - END IF - END IF - FLREQ(IFI,IFJ) = FLREQ(IFI,IFJ) .AND. FLOGRD(IFI,IFJ) -! -! Note: Whenever number of output parameters change, this needs updating -! -! The grads output type code does NOT cover all the output parameter space!! -! - IF ( IFI.EQ.6 .AND. IFJ.EQ.1 ) THEN ! Radiation stresses needs 3D variable setting - IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 3 - ELSE IF ( IFI.EQ.4 .AND. IFJ.LE.NOGE(4) ) THEN - IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + NOSWLL + 1 ! Partitioned parameters - ELSE IF ( IFI.EQ.1 .AND. IFJ .EQ. 2 ) THEN - IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! Current vector - ELSE IF ( IFI.EQ.1 .AND. IFJ.EQ.3 ) THEN - IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! Wind vector - ELSE IF ( IFI.EQ.5 .AND. IFJ.EQ.1 ) THEN - IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! USTAR vector - ELSE IF ( IFI.EQ.5 .AND. IFJ.EQ.5 ) THEN - IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! TAUWI vector - ELSE IF ( IFI.EQ.5 .AND. IFJ.EQ.6 ) THEN - IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! TAUWN vector -! ELSE IF ( IFI.EQ.9 .AND. IFJ.EQ.5 ) THEN -! IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! Max angular CFL vector - ELSE - IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 1 ! scalars - END IF - END DO - END DO -! -! ... Grid range -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) IX0, IXN, IY0, IYN, MSOUT, MBOUT -! - WRITE (NDSO,947) -! - IX0 = MAX ( 1, IX0 ) - IY0 = MAX ( 1, IY0 ) - IXN = MIN ( NX, IXN ) - IYN = MIN ( NY, IYN ) -! - WRITE (NDSO,948) IX0, IXN, IY0, IYN -! - IF ( MSOUT ) THEN - WRITE (NDSO,950) 'YES/--' - ELSE - WRITE (NDSO,950) '---/NO' - END IF -! - IF ( .NOT. MSOUT ) MBOUT = .FALSE. - IF ( MBOUT ) THEN - WRITE (NDSO,951) 'YES/--' - ELSE - WRITE (NDSO,951) '---/NO' - END IF -! - MSOUT = .NOT. MSOUT - MBOUT = .NOT. MBOUT -! - OPEN (NDSDAT,FILE=FNMPRE(:JLEN)//'ww3.grads',form='UNFORMATTED', convert=file_endian, & - ERR=811,IOSTAT=IERR) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Time management. -! - IOUT = 0 - WRITE (NDSO,970) -! - DO - DTEST = DSEC21 ( TIME , TOUT ) - IF ( DTEST .GT. 0. ) THEN - CALL W3IOGO ( 'READ', NDSOG, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - WRITE (NDSO,942) - GOTO 600 - END IF - CYCLE - END IF - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF -! - IOUT = IOUT + 1 - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,971) IDTIME -! - CALL GXEXGO ( NX, NY, NSEA ) - TIMEN = TOUT -! - IF ( TIME0(1) .EQ. -1 ) TIME0 = TIME -! - CALL TICK21 ( TOUT , DTREQ ) - IF ( IOUT .GE. NOUT ) EXIT - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6. Close data file and write control file -! - 600 CONTINUE - WRITE (NDSO,980) -! - WRITE (NDSO,981) - CLOSE (NDSDAT) - WRITE (NDSO,982) - OPEN (NDSCTL,FILE=FNMPRE(:JLEN)//'ww3.ctl',ERR=812,IOSTAT=IERR) -! - IH0 = TIME0(2)/10000 - IM0 = MOD(TIME0(2)/100,100) - ID0 = MOD(TIME0(1),100) - IID = MOD(TIME0(1)/100,100) - IJ0 = TIME0(1)/10000 -! - IF ( IOUT .GT. 1 ) DTREQ = DSEC21 ( TIME0, TIMEN ) / REAL(IOUT-1) - IF ( IOUT .EQ. 1 ) DTREQ = 3600. - IF ( DTREQ .GT. 3599. ) THEN - CINC = 'HR' - IINC = NINT(DTREQ/3600.) - IF ( MOD(NINT(DTREQ),3600) .NE. 0 ) GOTO 820 - ELSE - CINC = 'MN' - IINC = NINT(DTREQ/60.) - END IF -! - WRITE (NDSO,983) IOUT, IH0, IM0, ID0, MNTH(IID), IJ0, IINC, CINC -! - IF ( FLAGLL ) THEN - FAC = 1. - ELSE - XYMAX = MAX ( ABS(X0+REAL(IX0-1)*SX), & - ABS(X0+REAL(IXN-1)*SX), & - ABS(Y0+REAL(IY0-1)*SY), & - ABS(Y0+REAL(IYN-1)*SY) ) - IF ( XYMAX .LT. 1.E3 ) THEN - FAC = 1.E-1 - ELSE IF ( XYMAX .LT. 1.E4 ) THEN - FAC = 1.E-2 - ELSE IF ( XYMAX .LT. 1.E5 ) THEN - FAC = 1.E-3 - ELSE IF ( XYMAX .LT. 1.E6 ) THEN - FAC = 1.E-4 - ELSE - FAC = 1.E-5 - END IF - END IF !FLAGLL -! - WRITE (NDSCTL,990) UNDEF, & - (1+IXN-IX0), FAC*(X0+REAL(IX0-1)*SX), FAC*SX,& - (1+IYN-IY0), FAC*(Y0+REAL(IY0-1)*SY), FAC*SY,& - 1, 1000., 1., & - IOUT, IH0, IM0, ID0, MNTH(IID), IJ0, & - IINC, CINC, NVAR -! - IU = 99 - WRITE (NDSCTL,991) 'MAP ', 0, IU, 'grid use map ' -! - IF ( FLREQ(01,01) ) & - WRITE (NDSCTL,991) 'dpt ', 0, IU, 'Water depth ' - IF ( FLREQ(01,02) ) & - WRITE (NDSCTL,991) 'ucur ', 0, IU, 'Current U (m/s)' - IF ( FLREQ(01,02) ) & - WRITE (NDSCTL,991) 'vcur ', 0, IU, 'Current V (m/s)' - IF ( FLREQ(01,03) ) & - WRITE (NDSCTL,991) 'uwnd ', 0, IU, 'Wind U (m/s) ' - IF ( FLREQ(01,03) ) & - WRITE (NDSCTL,991) 'vwnd ', 0, IU, 'Wind V (m/s) ' - IF ( FLREQ(01,04) ) & - WRITE (NDSCTL,991) 'ast ', 0, IU, 'AT-SST (degr) ' - IF ( FLREQ(01,05) ) & - WRITE (NDSCTL,991) 'wlv ', 0, IU, 'Water Level (m)' - IF ( FLREQ(01,06) ) & - WRITE (NDSCTL,991) 'ice ', 0, IU, 'Ice Conc. (-) ' + FLREQ(IFI,IFJ) = FLREQ(IFI,IFJ) .AND. FLOGRD(IFI,IFJ) + ! + ! Note: Whenever number of output parameters change, this needs updating + ! + ! The grads output type code does NOT cover all the output parameter space!! + ! + IF ( IFI.EQ.6 .AND. IFJ.EQ.1 ) THEN ! Radiation stresses needs 3D variable setting + IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 3 + ELSE IF ( IFI.EQ.4 .AND. IFJ.LE.NOGE(4) ) THEN + IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + NOSWLL + 1 ! Partitioned parameters + ELSE IF ( IFI.EQ.1 .AND. IFJ .EQ. 2 ) THEN + IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! Current vector + ELSE IF ( IFI.EQ.1 .AND. IFJ.EQ.3 ) THEN + IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! Wind vector + ELSE IF ( IFI.EQ.5 .AND. IFJ.EQ.1 ) THEN + IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! USTAR vector + ELSE IF ( IFI.EQ.5 .AND. IFJ.EQ.5 ) THEN + IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! TAUWI vector + ELSE IF ( IFI.EQ.5 .AND. IFJ.EQ.6 ) THEN + IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! TAUWN vector + ! ELSE IF ( IFI.EQ.9 .AND. IFJ.EQ.5 ) THEN + ! IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 2 ! Max angular CFL vector + ELSE + IF ( FLREQ(IFI,IFJ) ) NVAR = NVAR + 1 ! scalars + END IF + END DO + END DO + ! + ! ... Grid range + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) IX0, IXN, IY0, IYN, MSOUT, MBOUT + ! + WRITE (NDSO,947) + ! + IX0 = MAX ( 1, IX0 ) + IY0 = MAX ( 1, IY0 ) + IXN = MIN ( NX, IXN ) + IYN = MIN ( NY, IYN ) + ! + WRITE (NDSO,948) IX0, IXN, IY0, IYN + ! + IF ( MSOUT ) THEN + WRITE (NDSO,950) 'YES/--' + ELSE + WRITE (NDSO,950) '---/NO' + END IF + ! + IF ( .NOT. MSOUT ) MBOUT = .FALSE. + IF ( MBOUT ) THEN + WRITE (NDSO,951) 'YES/--' + ELSE + WRITE (NDSO,951) '---/NO' + END IF + ! + MSOUT = .NOT. MSOUT + MBOUT = .NOT. MBOUT + ! + OPEN (NDSDAT,FILE=FNMPRE(:JLEN)//'ww3.grads',form='UNFORMATTED', convert=file_endian, & + ERR=811,IOSTAT=IERR) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Time management. + ! + IOUT = 0 + WRITE (NDSO,970) + ! + DO + DTEST = DSEC21 ( TIME , TOUT ) + IF ( DTEST .GT. 0. ) THEN + CALL W3IOGO ( 'READ', NDSOG, IOTEST ) + IF ( IOTEST .EQ. -1 ) THEN + WRITE (NDSO,942) + GOTO 600 + END IF + CYCLE + END IF + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF + ! + IOUT = IOUT + 1 + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,971) IDTIME + ! + CALL GXEXGO ( NX, NY, NSEA ) + TIMEN = TOUT + ! + IF ( TIME0(1) .EQ. -1 ) TIME0 = TIME + ! + CALL TICK21 ( TOUT , DTREQ ) + IF ( IOUT .GE. NOUT ) EXIT + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6. Close data file and write control file + ! +600 CONTINUE + WRITE (NDSO,980) + ! + WRITE (NDSO,981) + CLOSE (NDSDAT) + WRITE (NDSO,982) + OPEN (NDSCTL,FILE=FNMPRE(:JLEN)//'ww3.ctl',ERR=812,IOSTAT=IERR) + ! + IH0 = TIME0(2)/10000 + IM0 = MOD(TIME0(2)/100,100) + ID0 = MOD(TIME0(1),100) + IID = MOD(TIME0(1)/100,100) + IJ0 = TIME0(1)/10000 + ! + IF ( IOUT .GT. 1 ) DTREQ = DSEC21 ( TIME0, TIMEN ) / REAL(IOUT-1) + IF ( IOUT .EQ. 1 ) DTREQ = 3600. + IF ( DTREQ .GT. 3599. ) THEN + CINC = 'HR' + IINC = NINT(DTREQ/3600.) + IF ( MOD(NINT(DTREQ),3600) .NE. 0 ) GOTO 820 + ELSE + CINC = 'MN' + IINC = NINT(DTREQ/60.) + END IF + ! + WRITE (NDSO,983) IOUT, IH0, IM0, ID0, MNTH(IID), IJ0, IINC, CINC + ! + IF ( FLAGLL ) THEN + FAC = 1. + ELSE + XYMAX = MAX ( ABS(X0+REAL(IX0-1)*SX), & + ABS(X0+REAL(IXN-1)*SX), & + ABS(Y0+REAL(IY0-1)*SY), & + ABS(Y0+REAL(IYN-1)*SY) ) + IF ( XYMAX .LT. 1.E3 ) THEN + FAC = 1.E-1 + ELSE IF ( XYMAX .LT. 1.E4 ) THEN + FAC = 1.E-2 + ELSE IF ( XYMAX .LT. 1.E5 ) THEN + FAC = 1.E-3 + ELSE IF ( XYMAX .LT. 1.E6 ) THEN + FAC = 1.E-4 + ELSE + FAC = 1.E-5 + END IF + END IF !FLAGLL + ! + WRITE (NDSCTL,990) UNDEF, & + (1+IXN-IX0), FAC*(X0+REAL(IX0-1)*SX), FAC*SX,& + (1+IYN-IY0), FAC*(Y0+REAL(IY0-1)*SY), FAC*SY,& + 1, 1000., 1., & + IOUT, IH0, IM0, ID0, MNTH(IID), IJ0, & + IINC, CINC, NVAR + ! + IU = 99 + WRITE (NDSCTL,991) 'MAP ', 0, IU, 'grid use map ' + ! + IF ( FLREQ(01,01) ) & + WRITE (NDSCTL,991) 'dpt ', 0, IU, 'Water depth ' + IF ( FLREQ(01,02) ) & + WRITE (NDSCTL,991) 'ucur ', 0, IU, 'Current U (m/s)' + IF ( FLREQ(01,02) ) & + WRITE (NDSCTL,991) 'vcur ', 0, IU, 'Current V (m/s)' + IF ( FLREQ(01,03) ) & + WRITE (NDSCTL,991) 'uwnd ', 0, IU, 'Wind U (m/s) ' + IF ( FLREQ(01,03) ) & + WRITE (NDSCTL,991) 'vwnd ', 0, IU, 'Wind V (m/s) ' + IF ( FLREQ(01,04) ) & + WRITE (NDSCTL,991) 'ast ', 0, IU, 'AT-SST (degr) ' + IF ( FLREQ(01,05) ) & + WRITE (NDSCTL,991) 'wlv ', 0, IU, 'Water Level (m)' + IF ( FLREQ(01,06) ) & + WRITE (NDSCTL,991) 'ice ', 0, IU, 'Ice Conc. (-) ' #ifdef W3_IS2 IF (FLREQ(01,09) ) & - WRITE (NDSCTL,991) 'ic1 ', 0, IU, 'Ice thick. (m) ' + WRITE (NDSCTL,991) 'ic1 ', 0, IU, 'Ice thick. (m) ' IF (FLREQ(01,10) ) & - WRITE (NDSCTL,991) 'ic5 ', 0, IU, 'Floe diam. (m) ' + WRITE (NDSCTL,991) 'ic5 ', 0, IU, 'Floe diam. (m) ' #endif - IF ( FLREQ(02,01) ) & - WRITE (NDSCTL,991) 'hs ', 0, IU, 'Wave height (m)' - IF ( FLREQ(02,02) ) & - WRITE (NDSCTL,991) 'lm ', 0, IU, 'Mean L (m) ' - IF ( FLREQ(02,03) ) & - WRITE (NDSCTL,991) 't02 ', 0, IU, 'Mean Per Tz (s)' - IF ( FLREQ(02,04) ) & - WRITE (NDSCTL,991) 't01 ', 0, IU, 'Mean Per Tm (s) ' - IF ( FLREQ(02,05) ) & - WRITE (NDSCTL,991) 't0m1', 0, IU, 'Mean Per Te (s) ' - IF ( FLREQ(02,06) ) & - WRITE (NDSCTL,991) 'fp ', 0, IU, 'Peak Freq. (Hz)' - IF ( FLREQ(02,07) ) & - WRITE (NDSCTL,991) 'dir ', 0, IU, 'Mean Dir. (rad)' - IF ( FLREQ(02,08) ) & - WRITE (NDSCTL,991) 'spr ', 0, IU, 'Dir. spread ' - IF ( FLREQ(02,09) ) & - WRITE (NDSCTL,991) 'dp ', 0, IU, 'Peak Dir. (rad)' - IF ( FLREQ(04,01) ) THEN - PARID = 'phs ' - DO I=0, NOSWLL - WRITE (PARID(4:5),'(I2.2)') I - WRITE (NDSCTL,991) PARID , 0, IU, 'Part. Hs (m) ' - END DO - END IF - IF ( FLREQ(04,02) ) THEN - PARID = 'ptp ' - DO I=0, NOSWLL - WRITE (PARID(4:5),'(I2.2)') I - WRITE (NDSCTL,991) PARID , 0, IU, 'Part. Tp (s) ' - END DO - END IF - IF ( FLREQ(04,03) ) THEN - PARID = 'plp ' - DO I=0, NOSWLL - WRITE (PARID(4:5),'(I2.2)') I - WRITE (NDSCTL,991) PARID , 0, IU, 'Part. L (m) ' - END DO - END IF - IF ( FLREQ(04,04) ) THEN - PARID = 'pdir ' - DO I=0, NOSWLL - WRITE (PARID(4:5),'(I2.2)') I - WRITE (NDSCTL,991) PARID , 0, IU, 'Part. Th (deg.)' - END DO - END IF - IF ( FLREQ(04,05) ) THEN - PARID = 'pspr ' - DO I=0, NOSWLL - WRITE (PARID(4:5),'(I2.2)') I - WRITE (NDSCTL,991) PARID , 0, IU, 'Part. si (deg.)' - END DO - END IF - IF ( FLREQ(04,06) ) THEN - PARID = 'pws ' - DO I=0, NOSWLL - WRITE (PARID(4:5),'(I2.2)') I - WRITE (NDSCTL,991) PARID , 0, IU, 'Part. ws frac. ' - END DO - END IF - IF ( FLREQ(04,07) ) & - WRITE (NDSCTL,991) 'tws ', 0, IU, 'Total ws frac. ' - IF ( FLREQ(04,08) ) & - WRITE (NDSCTL,991) 'pnr ', 0, IU, 'Number of part.' - IF ( FLREQ(05,01) ) & - WRITE (NDSCTL,991) 'uust ', 0, IU, 'Fr.Vel. U(m/s) ' - IF ( FLREQ(05,01) ) & - WRITE (NDSCTL,991) 'vust ', 0, IU, 'Fr.Vel. V(m/s) ' - IF ( FLREQ(05,02) ) & - WRITE (NDSCTL,991) 'cha ', 0, IU, 'Charnock parameter' - IF ( FLREQ(05,03) ) & - WRITE (NDSCTL,991) 'cge ', 0, IU, 'Energy Flux (W/m)' - IF ( FLREQ(05,04) ) & - WRITE (NDSCTL,991) 'faw ', 0, IU, 'Air-sea energy flux' - IF ( FLREQ(05,05) ) & - WRITE (NDSCTL,991) 'utaw ', 0, IU, 'Net wave supp str' - IF ( FLREQ(05,05) ) & - WRITE (NDSCTL,991) 'vtaw ', 0, IU, 'Net wave supp str' - IF ( FLREQ(05,06) ) & - WRITE (NDSCTL,991) 'utwa ', 0, IU, 'Neg wave supp str' - IF ( FLREQ(05,06) ) & - WRITE (NDSCTL,991) 'vtwa ', 0, IU, 'Neg wave supp str' - IF ( FLREQ(09,01) ) & - WRITE (NDSCTL,991) 'dtd ', 0, IU, 'DTAVG ST (min) ' - IF ( FLREQ(09,02) ) & - WRITE (NDSCTL,991) 'fc ', 0, IU, 'fcut (Hz) ' - IF ( FLREQ(09,03) ) & - WRITE (NDSCTL,991) 'cfx ', 0, IU, 'Max CFL XY Prop' - IF ( FLREQ(09,04) ) & - WRITE (NDSCTL,991) 'cfd ', 0, IU, 'Max CFL TH Prop' -! - WRITE (NDSCTL,992) -! - GOTO 888 -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 1 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 2 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 3 ) -! - 810 CONTINUE - WRITE (NDSE,1010) - CALL EXTCDE ( 10 ) -! - 811 CONTINUE - WRITE (NDSE,1011) - CALL EXTCDE ( 11 ) -! - 812 CONTINUE - WRITE (NDSE,1012) - CALL EXTCDE ( 12 ) -! - 820 CONTINUE - WRITE (NDSE,1020) DTREQ - CALL EXTCDE ( 20 ) -! - 821 CONTINUE - WRITE (NDSE,1021) - CALL EXTCDE ( 21 ) -! - 888 CONTINUE - WRITE (NDSO,999) -! -! Formats -! - 900 FORMAT (/12X,' *** WAVEWATCH III GrADS field output postp. *** '/ & - 12X,'====================================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) -! - 920 FORMAT ( ' Grid name : ',A/) -! - 930 FORMAT ( ' Fields in file : '/ & - ' --------------------------') - 931 FORMAT ( ' ',A) -! - 940 FORMAT (/' Output time data : '/ & - ' -----------------------------------------------------'/ & - ' First time : ',A) - 941 FORMAT ( ' Interval : ',A/ & - ' Number of requests : ',I4) - 942 FORMAT (/' End of file reached '/) -! - 945 FORMAT (/' Requested output fields : '/ & - ' -----------------------------------------------------') - 946 FORMAT ( ' ',A,1X,A) -! - 947 FORMAT (/' Requested discrete grid ranges : '/ & - ' -----------------------------------------------------') - 948 FORMAT ( ' Longitudes : ',2I6/ & - ' lattidutes : ',2I6/ & - ' Opening file ww3.grads') - 949 FORMAT ( ' Alternative definition is used ') - 950 FORMAT ( ' Sea points in mask : ',A) - 951 FORMAT ( ' Bound. pts. in mask: ',A) -! - 970 FORMAT (//' Generating file '/ & - ' -----------------------------------------------------') - 971 FORMAT ( ' Data for ',A) -! - 980 FORMAT (//' Final file management '/ & - ' -----------------------------------------------------') - 981 FORMAT ( ' Closing file ww3.grads') - 982 FORMAT ( ' Opening file ww3.ctl') - 983 FORMAT ( ' Number of times : ',I6/ & - ' Initial time ID : ',I2.2,':',I2.2,'Z',I2.2,A3,I4/ & - ' Time step ID : ',I2,A2) -! - 990 FORMAT ('DSET ww3.grads'/ & - 'TITLE WAVEWATCH III gridded data'/ & - 'OPTIONS sequential'/ & - 'OPTIONS big_endian'/ & - 'UNDEF ',F8.1/ & - 'XDEF ',I4,' LINEAR ',2F12.5/ & - 'YDEF ',I4,' LINEAR ',2F12.5/ & - 'ZDEF ',I4,' LINEAR ',2F12.5/ & - 'TDEF ',I4,' LINEAR ',I6.2,':',I2.2,'Z',I2.2,A3,I4, & - 2x,I2,A2/ & - 'VARS ',I4) - 991 FORMAT (A6,2I4,2X,A15) - 992 FORMAT ('ENDVARS') -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III GrADS field output '/) -! + IF ( FLREQ(02,01) ) & + WRITE (NDSCTL,991) 'hs ', 0, IU, 'Wave height (m)' + IF ( FLREQ(02,02) ) & + WRITE (NDSCTL,991) 'lm ', 0, IU, 'Mean L (m) ' + IF ( FLREQ(02,03) ) & + WRITE (NDSCTL,991) 't02 ', 0, IU, 'Mean Per Tz (s)' + IF ( FLREQ(02,04) ) & + WRITE (NDSCTL,991) 't01 ', 0, IU, 'Mean Per Tm (s) ' + IF ( FLREQ(02,05) ) & + WRITE (NDSCTL,991) 't0m1', 0, IU, 'Mean Per Te (s) ' + IF ( FLREQ(02,06) ) & + WRITE (NDSCTL,991) 'fp ', 0, IU, 'Peak Freq. (Hz)' + IF ( FLREQ(02,07) ) & + WRITE (NDSCTL,991) 'dir ', 0, IU, 'Mean Dir. (rad)' + IF ( FLREQ(02,08) ) & + WRITE (NDSCTL,991) 'spr ', 0, IU, 'Dir. spread ' + IF ( FLREQ(02,09) ) & + WRITE (NDSCTL,991) 'dp ', 0, IU, 'Peak Dir. (rad)' + IF ( FLREQ(04,01) ) THEN + PARID = 'phs ' + DO I=0, NOSWLL + WRITE (PARID(4:5),'(I2.2)') I + WRITE (NDSCTL,991) PARID , 0, IU, 'Part. Hs (m) ' + END DO + END IF + IF ( FLREQ(04,02) ) THEN + PARID = 'ptp ' + DO I=0, NOSWLL + WRITE (PARID(4:5),'(I2.2)') I + WRITE (NDSCTL,991) PARID , 0, IU, 'Part. Tp (s) ' + END DO + END IF + IF ( FLREQ(04,03) ) THEN + PARID = 'plp ' + DO I=0, NOSWLL + WRITE (PARID(4:5),'(I2.2)') I + WRITE (NDSCTL,991) PARID , 0, IU, 'Part. L (m) ' + END DO + END IF + IF ( FLREQ(04,04) ) THEN + PARID = 'pdir ' + DO I=0, NOSWLL + WRITE (PARID(4:5),'(I2.2)') I + WRITE (NDSCTL,991) PARID , 0, IU, 'Part. Th (deg.)' + END DO + END IF + IF ( FLREQ(04,05) ) THEN + PARID = 'pspr ' + DO I=0, NOSWLL + WRITE (PARID(4:5),'(I2.2)') I + WRITE (NDSCTL,991) PARID , 0, IU, 'Part. si (deg.)' + END DO + END IF + IF ( FLREQ(04,06) ) THEN + PARID = 'pws ' + DO I=0, NOSWLL + WRITE (PARID(4:5),'(I2.2)') I + WRITE (NDSCTL,991) PARID , 0, IU, 'Part. ws frac. ' + END DO + END IF + IF ( FLREQ(04,07) ) & + WRITE (NDSCTL,991) 'tws ', 0, IU, 'Total ws frac. ' + IF ( FLREQ(04,08) ) & + WRITE (NDSCTL,991) 'pnr ', 0, IU, 'Number of part.' + IF ( FLREQ(05,01) ) & + WRITE (NDSCTL,991) 'uust ', 0, IU, 'Fr.Vel. U(m/s) ' + IF ( FLREQ(05,01) ) & + WRITE (NDSCTL,991) 'vust ', 0, IU, 'Fr.Vel. V(m/s) ' + IF ( FLREQ(05,02) ) & + WRITE (NDSCTL,991) 'cha ', 0, IU, 'Charnock parameter' + IF ( FLREQ(05,03) ) & + WRITE (NDSCTL,991) 'cge ', 0, IU, 'Energy Flux (W/m)' + IF ( FLREQ(05,04) ) & + WRITE (NDSCTL,991) 'faw ', 0, IU, 'Air-sea energy flux' + IF ( FLREQ(05,05) ) & + WRITE (NDSCTL,991) 'utaw ', 0, IU, 'Net wave supp str' + IF ( FLREQ(05,05) ) & + WRITE (NDSCTL,991) 'vtaw ', 0, IU, 'Net wave supp str' + IF ( FLREQ(05,06) ) & + WRITE (NDSCTL,991) 'utwa ', 0, IU, 'Neg wave supp str' + IF ( FLREQ(05,06) ) & + WRITE (NDSCTL,991) 'vtwa ', 0, IU, 'Neg wave supp str' + IF ( FLREQ(09,01) ) & + WRITE (NDSCTL,991) 'dtd ', 0, IU, 'DTAVG ST (min) ' + IF ( FLREQ(09,02) ) & + WRITE (NDSCTL,991) 'fc ', 0, IU, 'fcut (Hz) ' + IF ( FLREQ(09,03) ) & + WRITE (NDSCTL,991) 'cfx ', 0, IU, 'Max CFL XY Prop' + IF ( FLREQ(09,04) ) & + WRITE (NDSCTL,991) 'cfd ', 0, IU, 'Max CFL TH Prop' + ! + WRITE (NDSCTL,992) + ! + GOTO 888 + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 1 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 2 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 3 ) + ! +810 CONTINUE + WRITE (NDSE,1010) + CALL EXTCDE ( 10 ) + ! +811 CONTINUE + WRITE (NDSE,1011) + CALL EXTCDE ( 11 ) + ! +812 CONTINUE + WRITE (NDSE,1012) + CALL EXTCDE ( 12 ) + ! +820 CONTINUE + WRITE (NDSE,1020) DTREQ + CALL EXTCDE ( 20 ) + ! +821 CONTINUE + WRITE (NDSE,1021) + CALL EXTCDE ( 21 ) + ! +888 CONTINUE + WRITE (NDSO,999) + ! + ! Formats + ! +900 FORMAT (/12X,' *** WAVEWATCH III GrADS field output postp. *** '/ & + 12X,'====================================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) + ! +920 FORMAT ( ' Grid name : ',A/) + ! +930 FORMAT ( ' Fields in file : '/ & + ' --------------------------') +931 FORMAT ( ' ',A) + ! +940 FORMAT (/' Output time data : '/ & + ' -----------------------------------------------------'/ & + ' First time : ',A) +941 FORMAT ( ' Interval : ',A/ & + ' Number of requests : ',I4) +942 FORMAT (/' End of file reached '/) + ! +945 FORMAT (/' Requested output fields : '/ & + ' -----------------------------------------------------') +946 FORMAT ( ' ',A,1X,A) + ! +947 FORMAT (/' Requested discrete grid ranges : '/ & + ' -----------------------------------------------------') +948 FORMAT ( ' Longitudes : ',2I6/ & + ' lattidutes : ',2I6/ & + ' Opening file ww3.grads') +949 FORMAT ( ' Alternative definition is used ') +950 FORMAT ( ' Sea points in mask : ',A) +951 FORMAT ( ' Bound. pts. in mask: ',A) + ! +970 FORMAT (//' Generating file '/ & + ' -----------------------------------------------------') +971 FORMAT ( ' Data for ',A) + ! +980 FORMAT (//' Final file management '/ & + ' -----------------------------------------------------') +981 FORMAT ( ' Closing file ww3.grads') +982 FORMAT ( ' Opening file ww3.ctl') +983 FORMAT ( ' Number of times : ',I6/ & + ' Initial time ID : ',I2.2,':',I2.2,'Z',I2.2,A3,I4/ & + ' Time step ID : ',I2,A2) + ! +990 FORMAT ('DSET ww3.grads'/ & + 'TITLE WAVEWATCH III gridded data'/ & + 'OPTIONS sequential'/ & + 'OPTIONS big_endian'/ & + 'UNDEF ',F8.1/ & + 'XDEF ',I4,' LINEAR ',2F12.5/ & + 'YDEF ',I4,' LINEAR ',2F12.5/ & + 'ZDEF ',I4,' LINEAR ',2F12.5/ & + 'TDEF ',I4,' LINEAR ',I6.2,':',I2.2,'Z',I2.2,A3,I4, & + 2x,I2,A2/ & + 'VARS ',I4) +991 FORMAT (A6,2I4,2X,A15) +992 FORMAT ('ENDVARS') + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III GrADS field output '/) + ! #ifdef W3_T - 9050 FORMAT ( ' TEST GXOUTF : KPDS : ',13I4/ & - ' ',12I4) - 9051 FORMAT ( ' TEST GXOUTF : KGDS : ',8I6/ & - ' ',8I6/ & - ' ',6I6) +9050 FORMAT ( ' TEST GXOUTF : KPDS : ',13I4/ & + ' ',12I4) +9051 FORMAT ( ' TEST GXOUTF : KGDS : ',8I6/ & + ' ',8I6/ & + ' ',6I6) #endif -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & - ' SMALLEST OUTPUT INCREMENT IS 60 SEC.'/) -! - 1011 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & - ' ERROR IN OPENING OUTPUT FILE ww3.grads'/ & - ' IOSTAT =',I5/) -! - 1012 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & - ' ERROR IN OPENING OUTPUT FILE ww3.ctl'/ & - ' IOSTAT =',I5/) -! - 1020 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & - ' FIELD INCREMENT > 1HR BUT NOT MULTIPLE',F10.0/) -! - 1021 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & - ' UPDATE PARS IN LOOP 610 !!!'/) -!/ -!/ Internal subroutine GXEXGO ---------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE GXEXGO ( NX, NY, NSEA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 30-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Massive changes to logistics. -!/ 29-Jan-2001 : Add output fields 17-18 ( version 2.20 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 27-Jun-2005 : Adding MAPST2. ( version 3.07 ) -!/ 21-Jul-2005 : Add output fields 19-21. ( version 3.07 ) -!/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 18-Jan-2007 : Update MSOUT/MBOUT treatment. ( version 3.10 ) -!/ 28-Mar-2007 : Adding partitioned output. ( version 3.11 ) -!/ Adding user slots for outputs. -!/ 22-Mar-2021 : Add output fields RHOA and TAUA ( version 7.13 ) -!/ -! 1. Purpose : -! -! Perform actual output for GrADS postprocessing. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NX/Y Int. I Grid dimensions. -! NSEA Int. I Number of sea points. -! ---------------------------------------------------------------- -! -! Internal parameters -! ---------------------------------------------------------------- -! X1, X2, XX -! R.A. Output fields -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Abort program as graceful as possible. -! W3S2XY Subr. Id. Convert from storage to spatial grid. -! --------------------------------------------------------------- -! -! 5. Called by : -! -! Main program in which it is contained. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Note that arrays CX and CY of the main program now contain -! the absolute current speed and direction respectively. -! - VALLND added to assure that map with only land plots in -! GrADS. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: W3S2XY -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NX, NY, NSEA -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IX, IY, J, ISEA, IXL, IXR - INTEGER :: MAPXCL(NY,NX), MAPDRY(NY,NX), & - MAPICE(NY,NX), MAPLND(NY,NX), & - MAPMSK(NY,NX) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & + ' SMALLEST OUTPUT INCREMENT IS 60 SEC.'/) + ! +1011 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & + ' ERROR IN OPENING OUTPUT FILE ww3.grads'/ & + ' IOSTAT =',I5/) + ! +1012 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & + ' ERROR IN OPENING OUTPUT FILE ww3.ctl'/ & + ' IOSTAT =',I5/) + ! +1020 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & + ' FIELD INCREMENT > 1HR BUT NOT MULTIPLE',F10.0/) + ! +1021 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & + ' UPDATE PARS IN LOOP 610 !!!'/) + !/ + !/ Internal subroutine GXEXGO ---------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE GXEXGO ( NX, NY, NSEA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 30-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Massive changes to logistics. + !/ 29-Jan-2001 : Add output fields 17-18 ( version 2.20 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 27-Jun-2005 : Adding MAPST2. ( version 3.07 ) + !/ 21-Jul-2005 : Add output fields 19-21. ( version 3.07 ) + !/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 18-Jan-2007 : Update MSOUT/MBOUT treatment. ( version 3.10 ) + !/ 28-Mar-2007 : Adding partitioned output. ( version 3.11 ) + !/ Adding user slots for outputs. + !/ 22-Mar-2021 : Add output fields RHOA and TAUA ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Perform actual output for GrADS postprocessing. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NX/Y Int. I Grid dimensions. + ! NSEA Int. I Number of sea points. + ! ---------------------------------------------------------------- + ! + ! Internal parameters + ! ---------------------------------------------------------------- + ! X1, X2, XX + ! R.A. Output fields + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! W3S2XY Subr. Id. Convert from storage to spatial grid. + ! --------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Main program in which it is contained. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Note that arrays CX and CY of the main program now contain + ! the absolute current speed and direction respectively. + ! - VALLND added to assure that map with only land plots in + ! GrADS. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: W3S2XY + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NX, NY, NSEA + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IX, IY, J, ISEA, IXL, IXR + INTEGER :: MAPXCL(NY,NX), MAPDRY(NY,NX), & + MAPICE(NY,NX), MAPLND(NY,NX), & + MAPMSK(NY,NX) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: X1(NX,NY), XX(NX,NY), XY(NX,NY), & - XA(NX,NY,0:NOSWLL) - REAL :: VALLND = 0.001 -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: X1(NX,NY), XX(NX,NY), XY(NX,NY), & + XA(NX,NY,0:NOSWLL) + REAL :: VALLND = 0.001 + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GXEXGO') + CALL STRACE (IENT, 'GXEXGO') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) ((FLREQ(J,K),J=1,NOGRP), K=1,NGRPP) + WRITE (NDST,9000) ((FLREQ(J,K),J=1,NOGRP), K=1,NGRPP) #endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. Preparations -! 1.a Write map to file -! - MAPXCL = MOD(MAPST2,2) - MAPICE = MOD(MAPST2,2) - MAPDRY = MOD(MAPST2/2,2) - MAPLND = MOD(MAPST2/4,2) - MAPMSK = MOD(MAPST2/8,2) -! - DO IY=1, NY - DO IX=1, NX - IF ( MAPSTA(IY,IX).EQ.0 ) THEN - IF ( MAPXCL(IY,IX).EQ.1 ) THEN - X1(IX,IY) = UNDEF - ELSE - X1(IX,IY) = VALLND - END IF - ELSE IF ( MAPSTA(IY,IX).LT.0 ) THEN - IF ( MAPMSK(IY,IX).EQ.1 ) THEN - X1(IX,IY) = -4. - ELSE IF ( MAPLND(IY,IX).EQ.1 ) THEN - X1(IX,IY) = VALLND - ELSE IF ( MAPICE(IY,IX).EQ.1 .AND. & - MAPDRY(IY,IX).EQ.1 ) THEN - X1(IX,IY) = -3. - ELSE IF ( MAPDRY(IY,IX).EQ.1 ) THEN - X1(IX,IY) = -2. - ELSE IF ( MAPICE(IY,IX).EQ.1 ) THEN - X1(IX,IY) = -1. - ELSE - X1(IX,IY) = -5. - END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1. Preparations + ! 1.a Write map to file + ! + MAPXCL = MOD(MAPST2,2) + MAPICE = MOD(MAPST2,2) + MAPDRY = MOD(MAPST2/2,2) + MAPLND = MOD(MAPST2/4,2) + MAPMSK = MOD(MAPST2/8,2) + ! + DO IY=1, NY + DO IX=1, NX + IF ( MAPSTA(IY,IX).EQ.0 ) THEN + IF ( MAPXCL(IY,IX).EQ.1 ) THEN + X1(IX,IY) = UNDEF + ELSE + X1(IX,IY) = VALLND + END IF + ELSE IF ( MAPSTA(IY,IX).LT.0 ) THEN + IF ( MAPMSK(IY,IX).EQ.1 ) THEN + X1(IX,IY) = -4. + ELSE IF ( MAPLND(IY,IX).EQ.1 ) THEN + X1(IX,IY) = VALLND + ELSE IF ( MAPICE(IY,IX).EQ.1 .AND. & + MAPDRY(IY,IX).EQ.1 ) THEN + X1(IX,IY) = -3. + ELSE IF ( MAPDRY(IY,IX).EQ.1 ) THEN + X1(IX,IY) = -2. + ELSE IF ( MAPICE(IY,IX).EQ.1 ) THEN + X1(IX,IY) = -1. + ELSE + X1(IX,IY) = -5. + END IF + ELSE + X1(IX,IY) = REAL(MAPSTA(IY,IX)) + IF ( MSOUT ) THEN + IF ( MAPSTA(IY,IX) .GT. 0 ) X1(IX,IY) = UNDEF + ELSE IF ( MBOUT ) THEN + IF ( MAPSTA(IY,IX).EQ.2 .OR. & + IY.EQ.1 .OR. IY.EQ.NY .OR. & + ( ICLOSE.NE.ICLO_NONE .AND. & + (IX.EQ.1 .OR. IX.EQ.NX) ) ) THEN + X1(IX,IY) = UNDEF ELSE - X1(IX,IY) = REAL(MAPSTA(IY,IX)) - IF ( MSOUT ) THEN - IF ( MAPSTA(IY,IX) .GT. 0 ) X1(IX,IY) = UNDEF - ELSE IF ( MBOUT ) THEN - IF ( MAPSTA(IY,IX).EQ.2 .OR. & - IY.EQ.1 .OR. IY.EQ.NY .OR. & - ( ICLOSE.NE.ICLO_NONE .AND. & - (IX.EQ.1 .OR. IX.EQ.NX) ) ) THEN - X1(IX,IY) = UNDEF - ELSE - IXl = 1 + MOD(IX+NX-2,NX) - IXR = 1 + MOD(IX,NX) - IF ( MAPSTA(IY+1,IXL).EQ.0 .AND. & - MAPXCL(IY+1,IXL).EQ.1 ) X1(IX,IY) = UNDEF - IF ( MAPSTA(IY+1,IX ).EQ.0 .AND. & - MAPXCL(IY+1,IX ).EQ.1 ) X1(IX,IY) = UNDEF - IF ( MAPSTA(IY+1,IXR).EQ.0 .AND. & - MAPXCL(IY+1,IXR).EQ.1 ) X1(IX,IY) = UNDEF - IF ( MAPSTA( IY ,IXR).EQ.0 .AND. & - MAPXCL( IY ,IXR).EQ.1 ) X1(IX,IY) = UNDEF - IF ( MAPSTA(IY-1,IXR).EQ.0 .AND. & - MAPXCL(IY-1,IXR).EQ.1 ) X1(IX,IY) = UNDEF - IF ( MAPSTA(IY-1,IX ).EQ.0 .AND. & - MAPXCL(IY-1,IX ).EQ.1 ) X1(IX,IY) = UNDEF - IF ( MAPSTA(IY-1,IXL).EQ.0 .AND. & - MAPXCL(IY-1,IXL).EQ.1 ) X1(IX,IY) = UNDEF - IF ( MAPSTA( IY ,IXL).EQ.0 .AND. & - MAPXCL( IY ,IXL).EQ.1 ) X1(IX,IY) = UNDEF - END IF - END IF - IF ( MSOUT .AND. MAPSTA(IY,IX).EQ.1 ) X1(IX,IY) = UNDEF - IF ( MBOUT .AND. MAPSTA(IY,IX).EQ.2 ) X1(IX,IY) = UNDEF + IXl = 1 + MOD(IX+NX-2,NX) + IXR = 1 + MOD(IX,NX) + IF ( MAPSTA(IY+1,IXL).EQ.0 .AND. & + MAPXCL(IY+1,IXL).EQ.1 ) X1(IX,IY) = UNDEF + IF ( MAPSTA(IY+1,IX ).EQ.0 .AND. & + MAPXCL(IY+1,IX ).EQ.1 ) X1(IX,IY) = UNDEF + IF ( MAPSTA(IY+1,IXR).EQ.0 .AND. & + MAPXCL(IY+1,IXR).EQ.1 ) X1(IX,IY) = UNDEF + IF ( MAPSTA( IY ,IXR).EQ.0 .AND. & + MAPXCL( IY ,IXR).EQ.1 ) X1(IX,IY) = UNDEF + IF ( MAPSTA(IY-1,IXR).EQ.0 .AND. & + MAPXCL(IY-1,IXR).EQ.1 ) X1(IX,IY) = UNDEF + IF ( MAPSTA(IY-1,IX ).EQ.0 .AND. & + MAPXCL(IY-1,IX ).EQ.1 ) X1(IX,IY) = UNDEF + IF ( MAPSTA(IY-1,IXL).EQ.0 .AND. & + MAPXCL(IY-1,IXL).EQ.1 ) X1(IX,IY) = UNDEF + IF ( MAPSTA( IY ,IXL).EQ.0 .AND. & + MAPXCL( IY ,IXL).EQ.1 ) X1(IX,IY) = UNDEF END IF - VALLND = - VALLND - END DO - END DO -! - WRITE (NDSDAT) ((X1(IX,IY),IX=IX0,IXN),IY=IY0,IYN) -! -! 1.b Initialize arrays -! - X1 = UNDEF - XX = UNDEF - XY = UNDEF - XA = UNDEF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Loop over output fields. -! - DO J=1, NOGRP - DO K=1, NGRPP -! WRITE(*,*)J,K,FLREQ(J,K) + END IF + IF ( MSOUT .AND. MAPSTA(IY,IX).EQ.1 ) X1(IX,IY) = UNDEF + IF ( MBOUT .AND. MAPSTA(IY,IX).EQ.2 ) X1(IX,IY) = UNDEF + END IF + VALLND = - VALLND + END DO + END DO + ! + WRITE (NDSDAT) ((X1(IX,IY),IX=IX0,IXN),IY=IY0,IYN) + ! + ! 1.b Initialize arrays + ! + X1 = UNDEF + XX = UNDEF + XY = UNDEF + XA = UNDEF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Loop over output fields. + ! + DO J=1, NOGRP + DO K=1, NGRPP + ! WRITE(*,*)J,K,FLREQ(J,K) IF ( FLREQ(J,K) ) THEN -! -! Set array dimension flags - FLONE = .FALSE. - FLTWO = .FALSE. - FLDIR = .FALSE. - FLTRI = .FALSE. - FLPRT = .FALSE. -! + ! + ! Set array dimension flags + FLONE = .FALSE. + FLTWO = .FALSE. + FLDIR = .FALSE. + FLTRI = .FALSE. + FLPRT = .FALSE. + ! #ifdef W3_T - WRITE (NDST,9020) IDOUT(J,K) + WRITE (NDST,9020) IDOUT(J,K) #endif -! -! 2.a Set output arrays and parameters -! -! Water depth -! - IF ( J.EQ.1 .AND. K.EQ.1 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, DW(1:NSEA) & - , MAPSF, X1 ) -! -! Current -! - ELSE IF ( J.EQ.1 .AND. K.EQ.2 ) THEN - FLTWO = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, CX(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, CY(1:NSEA) & - , MAPSF, XY ) -! -! Wind speed -! - ELSE IF ( J.EQ.1 .AND. K.EQ.3 ) THEN - FLTWO = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, UA(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, UD(1:NSEA) & - , MAPSF, XY ) -! -! Air-sea temp. dif. -! - ELSE IF ( J.EQ.1 .AND. K.EQ.4 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, AS(1:NSEA) & - , MAPSF, X1 ) -! -! Water level -! - ELSE IF ( J.EQ.1 .AND. K.EQ.5 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, WLV , MAPSF, X1 ) -! -! Ice concentration -! - ELSE IF ( J.EQ.1 .AND. K.EQ.6 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, ICE , MAPSF, X1 ) -! -! Atmospheric momentum -! - ELSE IF ( J.EQ.1 .AND. K.EQ.8 ) THEN - FLTWO = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUA(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUADIR(1:NSEA) & - , MAPSF, XY ) -! -! Air density -! - ELSE IF ( J.EQ.1 .AND. K.EQ.9 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, RHOAIR, MAPSF, X1 ) -! -! Ice thickness -! + ! + ! 2.a Set output arrays and parameters + ! + ! Water depth + ! + IF ( J.EQ.1 .AND. K.EQ.1 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, DW(1:NSEA) & + , MAPSF, X1 ) + ! + ! Current + ! + ELSE IF ( J.EQ.1 .AND. K.EQ.2 ) THEN + FLTWO = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, CX(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, CY(1:NSEA) & + , MAPSF, XY ) + ! + ! Wind speed + ! + ELSE IF ( J.EQ.1 .AND. K.EQ.3 ) THEN + FLTWO = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, UA(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, UD(1:NSEA) & + , MAPSF, XY ) + ! + ! Air-sea temp. dif. + ! + ELSE IF ( J.EQ.1 .AND. K.EQ.4 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, AS(1:NSEA) & + , MAPSF, X1 ) + ! + ! Water level + ! + ELSE IF ( J.EQ.1 .AND. K.EQ.5 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, WLV , MAPSF, X1 ) + ! + ! Ice concentration + ! + ELSE IF ( J.EQ.1 .AND. K.EQ.6 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, ICE , MAPSF, X1 ) + ! + ! Atmospheric momentum + ! + ELSE IF ( J.EQ.1 .AND. K.EQ.8 ) THEN + FLTWO = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUA(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUADIR(1:NSEA) & + , MAPSF, XY ) + ! + ! Air density + ! + ELSE IF ( J.EQ.1 .AND. K.EQ.9 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, RHOAIR, MAPSF, X1 ) + ! + ! Ice thickness + ! #ifdef W3_IS2 - ELSE IF ( J.EQ.1 .AND. K.EQ.11 ) THEN - FLONE = .TRUE. - CALL W3S2XY (NSEA, NSEA, NX, NY, ICEH , MAPSF, X1 ) + ELSE IF ( J.EQ.1 .AND. K.EQ.11 ) THEN + FLONE = .TRUE. + CALL W3S2XY (NSEA, NSEA, NX, NY, ICEH , MAPSF, X1 ) #endif -! -! Average sea ice floe diameter -! + ! + ! Average sea ice floe diameter + ! #ifdef W3_IS2 - ELSE IF ( J.EQ.1 .AND. K.EQ.12) THEN - FLONE = .TRUE. - CALL W3S2XY (NSEA, NSEA, NX, NY, ICEF , MAPSF, X1 ) + ELSE IF ( J.EQ.1 .AND. K.EQ.12) THEN + FLONE = .TRUE. + CALL W3S2XY (NSEA, NSEA, NX, NY, ICEF , MAPSF, X1 ) #endif -! -! -! Significant wave height -! - ELSE IF ( J.EQ.2 .AND. K.EQ.1 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, HS , MAPSF, X1 ) -! -! Mean wave length -! - ELSE IF ( J.EQ.2 .AND. K.EQ.2 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, WLM , MAPSF, X1 ) -! -! Mean zero-crossing wave period T02 -! - ELSE IF ( J.EQ.2 .AND. K.EQ.3 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, T02 , MAPSF, X1 ) -! -! Mean wave period Tm -! - ELSE IF ( J.EQ.2 .AND. K.EQ.4 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, T0M1 , MAPSF, X1 ) -! -! Mean energy wave period Te -! - ELSE IF ( J.EQ.2 .AND. K.EQ.5 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, T01 , MAPSF, X1 ) -! -! Peak period -! - ELSE IF ( J.EQ.2 .AND. K.EQ.6 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, FP0 , MAPSF, X1 ) -! -! Mean wave direction -! - ELSE IF ( J.EQ.2 .AND. K.EQ.7 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, THM , MAPSF, X1 ) -! -! Directional spread -! - ELSE IF ( J.EQ.2 .AND. K.EQ.8 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, THS , MAPSF, X1 ) -! -! Peak direction -! - ELSE IF ( J.EQ.2 .AND. K.EQ.9 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, THP0 , MAPSF, X1 ) -! -! Dominant wave breaking probability -! - ELSE IF ( J.EQ.2 .AND. K.EQ.17 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, WBT , MAPSF, X1 ) -! -! Partitioned wave heights -! - ELSE IF ( J.EQ.4 .AND. K.EQ.1 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PHS(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! Partitioned peak period -! - ELSE IF ( J.EQ.4 .AND. K.EQ.2 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PTP(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! Partitioned wave leangths (peak) -! - ELSE IF ( J.EQ.4 .AND. K.EQ.3 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PLP(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! Partitioned directions -! - ELSE IF ( J.EQ.4 .AND. K.EQ.4 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PDIR(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! Partitioned direstional spread -! - ELSE IF ( J.EQ.4 .AND. K.EQ.5 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PSI(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! Partitioned wind sea fraction -! - ELSE IF ( J.EQ.4 .AND. K.EQ.6 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PWS(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! Partitioned peak direction -! - ELSE IF ( J.EQ.4 .AND. K.EQ.7 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PTHP0(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! Partitioned peakedness -! - ELSE IF ( J.EQ.4 .AND. K.EQ.8 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PQP(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! -! Partitioned peak enhancement factor -! - ELSE IF ( J.EQ.4 .AND. K.EQ.9 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PPE(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! -! Partitioned gaussian frequency spread -! - ELSE IF ( J.EQ.4 .AND. K.EQ.10 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PGW(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! -! Partitioned spectral width -! - ELSE IF ( J.EQ.4 .AND. K.EQ.11 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PSW(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! -! Partitioned mean energy period (-1) -! - ELSE IF ( J.EQ.4 .AND. K.EQ.12 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PTM1(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! -! Partitioned mean wave period (+1) -! - ELSE IF ( J.EQ.4 .AND. K.EQ.13 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PT1(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! -! Partitioned mean wave period (+2) -! - ELSE IF ( J.EQ.4 .AND. K.EQ.14 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PT2(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! -! Partitioned peak density -! - ELSE IF ( J.EQ.4 .AND. K.EQ.15 ) THEN - FLPRT = .TRUE. - DO I=0, NOSWLL - CALL W3S2XY ( NSEA, NSEA, NX, NY, PEP(:,I), & - MAPSF, XA(:,:,I) ) - END DO -! -! Total wind sea fraction -! - ELSE IF ( J.EQ.4 .AND. K.EQ.16 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, PWST ,MAPSF, X1 ) -! -! Number of partitions -! - ELSE IF ( J.EQ.4 .AND. K.EQ.17 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, PNR , MAPSF, X1 ) -! -! Friction velocity -! - ELSE IF ( J.EQ.5 .AND. K.EQ.1 ) THEN - FLTWO = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, UST (1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, USTDIR(1:NSEA) & - , MAPSF, XY ) -! -! Charnock parameter -! - ELSE IF ( J.EQ.5 .AND. K.EQ.2 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, CHARN , MAPSF, X1 ) -! -! Mean energy flux -! - ELSE IF ( J.EQ.5 .AND. K.EQ.3 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, CGE , MAPSF, X1 ) -! -! Air-sea energy flux -! - ELSE IF ( J.EQ.5 .AND. K.EQ.4 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, PHIAW , MAPSF, X1 ) -! -! Net supported wave stress -! - ELSE IF ( J.EQ.5 .AND. K.EQ.5 ) THEN - FLTWO = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUWIX, MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUWIY, MAPSF, XY ) -! -! Net supported wave stress -! - ELSE IF ( J.EQ.5 .AND. K.EQ.6 ) THEN - FLTWO = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUWNX, MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUWNY, MAPSF, XY ) -! -! Peakedness -! - ELSE IF ( J.EQ.8 .AND. K.EQ.5 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, QP , MAPSF, X1 ) -! -! Average source term time step -! - ELSE IF ( J.EQ.9 .AND. K.EQ.1 ) THEN - FLONE = .TRUE. - DO ISEA=1, NSEA - IF ( DTDYN(ISEA) .NE. UNDEF ) & - DTDYN(ISEA) = DTDYN(ISEA) / 60. - END DO - CALL W3S2XY ( NSEA, NSEA, NX, NY, DTDYN , MAPSF, X1 ) -! -! Cut-off frequency -! - ELSE IF ( J.EQ.9 .AND. K.EQ.2 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, FCUT , MAPSF, X1 ) -! -! Max CFL step for XY propagation -! - ELSE IF ( J.EQ.9 .AND. K.EQ.3 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLXYMAX , MAPSF, X1 ) -! -! Max CFL step for directional propagation -! - ELSE IF ( J.EQ.9 .AND. K.EQ.4 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLTHMAX , MAPSF, X1 ) -!! -!! Not yet coded onto control file list (section 6 above) -! -! Near-bottom amplitude -! - ELSE IF ( J.EQ.7 .AND. K.EQ.1 ) THEN - FLTWO = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, ABA , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, ABD , MAPSF, XY ) -! -! Near-bottom velocity -! - ELSE IF ( J.EQ.7 .AND. K.EQ.2 ) THEN - FLTWO = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, UBA , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, UBD , MAPSF, XY ) -! -! Radiation stresses -! - ELSE IF ( J.EQ.6 .AND. K.EQ.1 ) THEN - FLTWO = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, SXX , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, SYY , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, SXY , MAPSF, XY ) -! -! User defined #1 -! - ELSE IF ( J.EQ.10 .AND. K.EQ.1 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, USERO(:,1) & - , MAPSF, X1 ) -! -! User defined #2 -! - ELSE IF ( J.EQ.10 .AND. K.EQ.2 ) THEN - FLONE = .TRUE. - CALL W3S2XY ( NSEA, NSEA, NX, NY, USERO(:,2) & - , MAPSF, X1 ) -! - ELSE - WRITE (NDSE,990) J, K - WRITE (NDSE,999) - CALL EXTCDE ( 1 ) -! - END IF -! -! 3 Perform output -! -! 3D array fields -! - IF ( FLTRI ) THEN - WRITE (NDSDAT) & - ((X1(IX,IY),IX=IX0,IXN),IY=IY0,IYN) - WRITE (NDSDAT) & - ((XX(IX,IY),IX=IX0,IXN),IY=IY0,IYN) - WRITE (NDSDAT) & - ((XY(IX,IY),IX=IX0,IXN),IY=IY0,IYN) -! -! Partitions parameters -! - ELSE IF ( FLPRT ) THEN - DO I=0, NOSWLL - WRITE (NDSDAT) & - ((XA(IX,IY,I),IX=IX0,IXN),IY=IY0,IYN) - END DO -! -! 2D array fields -! - ELSE IF ( FLTWO ) THEN - WRITE (NDSDAT) & - ((XX(IX,IY),IX=IX0,IXN),IY=IY0,IYN) - WRITE (NDSDAT) & - ((XY(IX,IY),IX=IX0,IXN),IY=IY0,IYN) -! -! Scalars -! - ELSE IF ( FLONE ) THEN - WRITE (NDSDAT) & - ((X1(IX,IY),IX=IX0,IXN),IY=IY0,IYN) - END IF -! -! ... End of fields loop -! + ! + ! + ! Significant wave height + ! + ELSE IF ( J.EQ.2 .AND. K.EQ.1 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, HS , MAPSF, X1 ) + ! + ! Mean wave length + ! + ELSE IF ( J.EQ.2 .AND. K.EQ.2 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, WLM , MAPSF, X1 ) + ! + ! Mean zero-crossing wave period T02 + ! + ELSE IF ( J.EQ.2 .AND. K.EQ.3 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, T02 , MAPSF, X1 ) + ! + ! Mean wave period Tm + ! + ELSE IF ( J.EQ.2 .AND. K.EQ.4 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, T0M1 , MAPSF, X1 ) + ! + ! Mean energy wave period Te + ! + ELSE IF ( J.EQ.2 .AND. K.EQ.5 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, T01 , MAPSF, X1 ) + ! + ! Peak period + ! + ELSE IF ( J.EQ.2 .AND. K.EQ.6 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, FP0 , MAPSF, X1 ) + ! + ! Mean wave direction + ! + ELSE IF ( J.EQ.2 .AND. K.EQ.7 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, THM , MAPSF, X1 ) + ! + ! Directional spread + ! + ELSE IF ( J.EQ.2 .AND. K.EQ.8 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, THS , MAPSF, X1 ) + ! + ! Peak direction + ! + ELSE IF ( J.EQ.2 .AND. K.EQ.9 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, THP0 , MAPSF, X1 ) + ! + ! Dominant wave breaking probability + ! + ELSE IF ( J.EQ.2 .AND. K.EQ.17 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, WBT , MAPSF, X1 ) + ! + ! Partitioned wave heights + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.1 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PHS(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! Partitioned peak period + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.2 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PTP(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! Partitioned wave leangths (peak) + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.3 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PLP(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! Partitioned directions + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.4 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PDIR(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! Partitioned direstional spread + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.5 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PSI(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! Partitioned wind sea fraction + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.6 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PWS(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! Partitioned peak direction + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.7 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PTHP0(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! Partitioned peakedness + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.8 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PQP(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! + ! Partitioned peak enhancement factor + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.9 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PPE(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! + ! Partitioned gaussian frequency spread + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.10 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PGW(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! + ! Partitioned spectral width + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.11 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PSW(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! + ! Partitioned mean energy period (-1) + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.12 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PTM1(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! + ! Partitioned mean wave period (+1) + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.13 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PT1(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! + ! Partitioned mean wave period (+2) + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.14 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PT2(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! + ! Partitioned peak density + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.15 ) THEN + FLPRT = .TRUE. + DO I=0, NOSWLL + CALL W3S2XY ( NSEA, NSEA, NX, NY, PEP(:,I), & + MAPSF, XA(:,:,I) ) + END DO + ! + ! Total wind sea fraction + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.16 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, PWST ,MAPSF, X1 ) + ! + ! Number of partitions + ! + ELSE IF ( J.EQ.4 .AND. K.EQ.17 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, PNR , MAPSF, X1 ) + ! + ! Friction velocity + ! + ELSE IF ( J.EQ.5 .AND. K.EQ.1 ) THEN + FLTWO = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, UST (1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, USTDIR(1:NSEA) & + , MAPSF, XY ) + ! + ! Charnock parameter + ! + ELSE IF ( J.EQ.5 .AND. K.EQ.2 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, CHARN , MAPSF, X1 ) + ! + ! Mean energy flux + ! + ELSE IF ( J.EQ.5 .AND. K.EQ.3 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, CGE , MAPSF, X1 ) + ! + ! Air-sea energy flux + ! + ELSE IF ( J.EQ.5 .AND. K.EQ.4 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, PHIAW , MAPSF, X1 ) + ! + ! Net supported wave stress + ! + ELSE IF ( J.EQ.5 .AND. K.EQ.5 ) THEN + FLTWO = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUWIX, MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUWIY, MAPSF, XY ) + ! + ! Net supported wave stress + ! + ELSE IF ( J.EQ.5 .AND. K.EQ.6 ) THEN + FLTWO = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUWNX, MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUWNY, MAPSF, XY ) + ! + ! Peakedness + ! + ELSE IF ( J.EQ.8 .AND. K.EQ.5 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, QP , MAPSF, X1 ) + ! + ! Average source term time step + ! + ELSE IF ( J.EQ.9 .AND. K.EQ.1 ) THEN + FLONE = .TRUE. + DO ISEA=1, NSEA + IF ( DTDYN(ISEA) .NE. UNDEF ) & + DTDYN(ISEA) = DTDYN(ISEA) / 60. + END DO + CALL W3S2XY ( NSEA, NSEA, NX, NY, DTDYN , MAPSF, X1 ) + ! + ! Cut-off frequency + ! + ELSE IF ( J.EQ.9 .AND. K.EQ.2 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, FCUT , MAPSF, X1 ) + ! + ! Max CFL step for XY propagation + ! + ELSE IF ( J.EQ.9 .AND. K.EQ.3 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLXYMAX , MAPSF, X1 ) + ! + ! Max CFL step for directional propagation + ! + ELSE IF ( J.EQ.9 .AND. K.EQ.4 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLTHMAX , MAPSF, X1 ) + !! + !! Not yet coded onto control file list (section 6 above) + ! + ! Near-bottom amplitude + ! + ELSE IF ( J.EQ.7 .AND. K.EQ.1 ) THEN + FLTWO = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, ABA , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, ABD , MAPSF, XY ) + ! + ! Near-bottom velocity + ! + ELSE IF ( J.EQ.7 .AND. K.EQ.2 ) THEN + FLTWO = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, UBA , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, UBD , MAPSF, XY ) + ! + ! Radiation stresses + ! + ELSE IF ( J.EQ.6 .AND. K.EQ.1 ) THEN + FLTWO = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, SXX , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, SYY , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, SXY , MAPSF, XY ) + ! + ! User defined #1 + ! + ELSE IF ( J.EQ.10 .AND. K.EQ.1 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, USERO(:,1) & + , MAPSF, X1 ) + ! + ! User defined #2 + ! + ELSE IF ( J.EQ.10 .AND. K.EQ.2 ) THEN + FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, USERO(:,2) & + , MAPSF, X1 ) + ! + ELSE + WRITE (NDSE,990) J, K + WRITE (NDSE,999) + CALL EXTCDE ( 1 ) + ! END IF - END DO - END DO -! - RETURN -! -! Error escape locations -! -! Formats -! - 940 FORMAT (1X,I8,3I3.2,2X,4E12.4) - 950 FORMAT (1X,A13,I9.8,I7.6,2(2F8.2,I4), & - 1X,A4,F8.4,1X,A10,2I2,1X,A11,I4) - 951 FORMAT (1X,2F10.5,2I8) -! - 990 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGO :'/ & - ' GROUP',I2,' PARAMETER',I3,' NOT LISTED ' ) - 999 FORMAT (/' *** WAVEWATCH III ERROR IN GXEXGO :'/ & - ' PLEASE UPDATE FIELDS !!! '/) -! -#ifdef W3_T - 9000 FORMAT (' TEST GXEXGO : FLAGS :',40L2) -#endif -! + ! + ! 3 Perform output + ! + ! 3D array fields + ! + IF ( FLTRI ) THEN + WRITE (NDSDAT) & + ((X1(IX,IY),IX=IX0,IXN),IY=IY0,IYN) + WRITE (NDSDAT) & + ((XX(IX,IY),IX=IX0,IXN),IY=IY0,IYN) + WRITE (NDSDAT) & + ((XY(IX,IY),IX=IX0,IXN),IY=IY0,IYN) + ! + ! Partitions parameters + ! + ELSE IF ( FLPRT ) THEN + DO I=0, NOSWLL + WRITE (NDSDAT) & + ((XA(IX,IY,I),IX=IX0,IXN),IY=IY0,IYN) + END DO + ! + ! 2D array fields + ! + ELSE IF ( FLTWO ) THEN + WRITE (NDSDAT) & + ((XX(IX,IY),IX=IX0,IXN),IY=IY0,IYN) + WRITE (NDSDAT) & + ((XY(IX,IY),IX=IX0,IXN),IY=IY0,IYN) + ! + ! Scalars + ! + ELSE IF ( FLONE ) THEN + WRITE (NDSDAT) & + ((X1(IX,IY),IX=IX0,IXN),IY=IY0,IYN) + END IF + ! + ! ... End of fields loop + ! + END IF + END DO + END DO + ! + RETURN + ! + ! Error escape locations + ! + ! Formats + ! +940 FORMAT (1X,I8,3I3.2,2X,4E12.4) +950 FORMAT (1X,A13,I9.8,I7.6,2(2F8.2,I4), & + 1X,A4,F8.4,1X,A10,2I2,1X,A11,I4) +951 FORMAT (1X,2F10.5,2I8) + ! +990 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGO :'/ & + ' GROUP',I2,' PARAMETER',I3,' NOT LISTED ' ) +999 FORMAT (/' *** WAVEWATCH III ERROR IN GXEXGO :'/ & + ' PLEASE UPDATE FIELDS !!! '/) + ! #ifdef W3_T - 9020 FORMAT (' TEST GXEXGO : OUTPUT FIELD : ',A) +9000 FORMAT (' TEST GXEXGO : FLAGS :',40L2) +9020 FORMAT (' TEST GXEXGO : OUTPUT FIELD : ',A) #endif -!/ -!/ End of GXEXGO ----------------------------------------------------- / -!/ - END SUBROUTINE GXEXGO -!/ -!/ End of GXOUTF ----------------------------------------------------- / -!/ - END PROGRAM GXOUTF + !/ + !/ End of GXEXGO ----------------------------------------------------- / + !/ + END SUBROUTINE GXEXGO + !/ + !/ End of GXOUTF ----------------------------------------------------- / + !/ +END PROGRAM GXOUTF diff --git a/model/src/gx_outp.F90 b/model/src/gx_outp.F90 index 1f3809cda..63b525485 100644 --- a/model/src/gx_outp.F90 +++ b/model/src/gx_outp.F90 @@ -1,1347 +1,1347 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - PROGRAM GXOUTP -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | J.H. Alves | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 27-Aug-2015 | -!/ +-----------------------------------+ -!/ -!/ 30-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 14-Feb-2000 : Exact nonlinear interactions ( version 2.01 ) -!/ 25-Jan-2001 : Cartesian grid version ( version 2.06 ) -!/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 27-Nov-2002 : First version of VDIA and MDIA. ( version 3.01 ) -!/ 01-Aug-2003 : Fix format for SH output points. ( version 3.03 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 23-Jun-2006 : Linear input added. ( version 3.09 ) -!/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 03-Jul-2006 : Separate flux modules. ( version 3.09 ) -!/ 25-Jul-2006 : Grid ID for each point. ( version 3.10 ) -!/ 25-Apr-2007 : EMEAN in W3SPR2 par list. ( version 3.11 ) -!/ 09-Oct-2007 : WAM 4+ Sin and Sds added. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 09-Oct-2007 : Experimental Sbs (BS1) added. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Aug-2010 : Adding ST4 ( version 3.14 ) -!/ 20-Apr-2010 : Fix initialization of USTAR. ( version 3.14.1 ) -!/ 23-Aug-2012 : Adding movable bed friction BT4 ( version 4.07 ) -!/ 16-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) -!/ from 3.15 (HLT). ( version 4.08 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ 27-Aug-2015 : Sice add as additional output ( version 5.10 ) -!/ (in source terms) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Post-processing of point output for GrADS post-processing. -! -! 2. Method : -! -! In order to be able to plot spectra and source terms as -! fields, spectral data is written as if it is fields data. -! The spectral direction becomes the longitude, 90.-FREQ -! become the latitude. This way, polar plots can be made -! using the GrADS 'NPS' map option. The level or z coordinate -! is used to store spectra and source terms for separate -! output points. The name of the output point is stored in -! the control file as the 'description' of the field. -! Also written is a separate file with mean input and wave -! parameters. This file contains per level and per time a -! single line containing : -! -! Station ID, Longitude, Latitude, Depth, , Wind speed. -! U and V components, Air-Sea Temperature difference, -! Current velocity, U and V components, Significant -! wave height. -! -! The files generated are : -! -! ww3.spec.ctl GrADS control file. -! ww3.spec.grads GrADS data file. -! ww3.mean.grads File with additional input and wave -! parameters. -! -! The first direction set to 90 degr. Grads NPS plot should -! therefore have 'set lon -180 180' for oceanographic directional -! convention. -! -! Examples of using the three files can be found in spec.gs and -! source.gs. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W3NAUX Subr. W3ADATMD Set number of model for aux data. -! W3SETA Subr. Id. Point to selected model for aux data. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! STME21 Subr. W3TIMEMD Convert time to string. -! TICK21 Subr. Id. Advance time. -! DSEC21 Func. Id. Difference between times. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3IOPO Subr. W3IOPOMD Reading/writing raw point output file. -! GXEXPO Subr. Internal Execute point output. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! Checks on input, checks in W3IOxx. -! Check on grid type. -! -! 7. Remarks : -! -! - Curvilinear grids currently not supported. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ -! USE W3GDATMD, ONLY: W3NMOD, W3SETG - USE W3WDATMD, ONLY: W3SETW, W3NDAT +PROGRAM GXOUTP + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | J.H. Alves | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 27-Aug-2015 | + !/ +-----------------------------------+ + !/ + !/ 30-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 14-Feb-2000 : Exact nonlinear interactions ( version 2.01 ) + !/ 25-Jan-2001 : Cartesian grid version ( version 2.06 ) + !/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 27-Nov-2002 : First version of VDIA and MDIA. ( version 3.01 ) + !/ 01-Aug-2003 : Fix format for SH output points. ( version 3.03 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 23-Jun-2006 : Linear input added. ( version 3.09 ) + !/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 03-Jul-2006 : Separate flux modules. ( version 3.09 ) + !/ 25-Jul-2006 : Grid ID for each point. ( version 3.10 ) + !/ 25-Apr-2007 : EMEAN in W3SPR2 par list. ( version 3.11 ) + !/ 09-Oct-2007 : WAM 4+ Sin and Sds added. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 09-Oct-2007 : Experimental Sbs (BS1) added. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Aug-2010 : Adding ST4 ( version 3.14 ) + !/ 20-Apr-2010 : Fix initialization of USTAR. ( version 3.14.1 ) + !/ 23-Aug-2012 : Adding movable bed friction BT4 ( version 4.07 ) + !/ 16-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) + !/ from 3.15 (HLT). ( version 4.08 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ 27-Aug-2015 : Sice add as additional output ( version 5.10 ) + !/ (in source terms) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Post-processing of point output for GrADS post-processing. + ! + ! 2. Method : + ! + ! In order to be able to plot spectra and source terms as + ! fields, spectral data is written as if it is fields data. + ! The spectral direction becomes the longitude, 90.-FREQ + ! become the latitude. This way, polar plots can be made + ! using the GrADS 'NPS' map option. The level or z coordinate + ! is used to store spectra and source terms for separate + ! output points. The name of the output point is stored in + ! the control file as the 'description' of the field. + ! Also written is a separate file with mean input and wave + ! parameters. This file contains per level and per time a + ! single line containing : + ! + ! Station ID, Longitude, Latitude, Depth, , Wind speed. + ! U and V components, Air-Sea Temperature difference, + ! Current velocity, U and V components, Significant + ! wave height. + ! + ! The files generated are : + ! + ! ww3.spec.ctl GrADS control file. + ! ww3.spec.grads GrADS data file. + ! ww3.mean.grads File with additional input and wave + ! parameters. + ! + ! The first direction set to 90 degr. Grads NPS plot should + ! therefore have 'set lon -180 180' for oceanographic directional + ! convention. + ! + ! Examples of using the three files can be found in spec.gs and + ! source.gs. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W3NAUX Subr. W3ADATMD Set number of model for aux data. + ! W3SETA Subr. Id. Point to selected model for aux data. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! W3SETO Subr. Id. Point to selected model for output. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! TICK21 Subr. Id. Advance time. + ! DSEC21 Func. Id. Difference between times. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3IOPO Subr. W3IOPOMD Reading/writing raw point output file. + ! GXEXPO Subr. Internal Execute point output. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! Checks on input, checks in W3IOxx. + ! Check on grid type. + ! + ! 7. Remarks : + ! + ! - Curvilinear grids currently not supported. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG + USE W3WDATMD, ONLY: W3SETW, W3NDAT #ifdef W3_NL1 - USE W3ADATMD, ONLY: W3SETA, W3NAUX + USE W3ADATMD, ONLY: W3SETA, W3NAUX #endif - USE W3ODATMD, ONLY: W3SETO, W3NOUT - USE W3IOGRMD, ONLY: W3IOGR - USE W3IOPOMD, ONLY: W3IOPO - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE + USE W3ODATMD, ONLY: W3SETO, W3NOUT + USE W3IOGRMD, ONLY: W3IOGR + USE W3IOPOMD, ONLY: W3IOPO + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY : STRACE -#endif - USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 -!/ - USE W3GDATMD - USE W3WDATMD, ONLY: TIME - USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOPTS, PTLOC, PTNME, & - DPO, WAO, WDO, ASO, CAO, CDO, SPCO, FNMPRE, & - GRDID, ICEO, ICEHO, ICEFO + USE W3SERVMD, ONLY : STRACE +#endif + USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 + !/ + USE W3GDATMD + USE W3WDATMD, ONLY: TIME + USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOPTS, PTLOC, PTNME, & + DPO, WAO, WDO, ASO, CAO, CDO, SPCO, FNMPRE, & + GRDID, ICEO, ICEHO, ICEFO #ifdef W3_FLX5 - USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NDSI, NDSM, NDSOP, NDSGRD, NDSPNT, & - NDSCGR, NDSTRC, NTRACE, IERR, & - IOTEST, I, TOUT(2), NOUT, TDUM(2), & - NREQ, IPOINT, NLEV, IOUT, TIME0(2), & - IH0, IM0, ID0, IID, IJ0, IINC, IK, & - IREQ, TIMEN(2), J + USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NDSI, NDSM, NDSOP, NDSGRD, NDSPNT, & + NDSCGR, NDSTRC, NTRACE, IERR, & + IOTEST, I, TOUT(2), NOUT, TDUM(2), & + NREQ, IPOINT, NLEV, IOUT, TIME0(2), & + IH0, IM0, ID0, IID, IJ0, IINC, IK, & + IREQ, TIMEN(2), J #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: DTREQ, DTEST - REAL :: UNDEFP = -99.E20 - REAL :: FACT - LOGICAL :: FLSRCE(7) - LOGICAL, ALLOCATABLE :: FLREQ(:) - CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & - CINC*2 - CHARACTER(LEN=3) :: MNTH(12) - CHARACTER(LEN=25) :: IDSRCE(7) -!/ -!/ ------------------------------------------------------------------- / -!/ - DATA IDSRCE / 'Spectrum ' , & - 'Wind-wave interactions ' , & - 'Nonlinear interactions ' , & - 'Dissipation ' , & - 'Wave-bottom interactions ' , & - 'Wave-ice interactions ' , & - 'Sum of selected sources ' / - DATA FLSRCE / .FALSE. , .FALSE. , .FALSE. , & - .FALSE. , .FALSE. , .FALSE., .FALSE. / - DATA TIME0 / -1, 0 / - DATA MNTH / 'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN', & - 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC' / -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. IO set-up. -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: DTREQ, DTEST + REAL :: UNDEFP = -99.E20 + REAL :: FACT + LOGICAL :: FLSRCE(7) + LOGICAL, ALLOCATABLE :: FLREQ(:) + CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & + CINC*2 + CHARACTER(LEN=3) :: MNTH(12) + CHARACTER(LEN=25) :: IDSRCE(7) + !/ + !/ ------------------------------------------------------------------- / + !/ + DATA IDSRCE / 'Spectrum ' , & + 'Wind-wave interactions ' , & + 'Nonlinear interactions ' , & + 'Dissipation ' , & + 'Wave-bottom interactions ' , & + 'Wave-ice interactions ' , & + 'Sum of selected sources ' / + DATA FLSRCE / .FALSE. , .FALSE. , .FALSE. , & + .FALSE. , .FALSE. , .FALSE., .FALSE. / + DATA TIME0 / -1, 0 / + DATA MNTH / 'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN', & + 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC' / + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1. IO set-up. + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) #ifdef W3_NL1 - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) -#endif - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! - NDSI = 10 - NDSM = 20 - NDSOP = 20 - NDSGRD = 30 - NDSPNT = 31 - NDSCGR = 32 -! - NDSTRC = 6 - NTRACE = 0 -! - WRITE (NDSO,900) -! - CALL ITRACE ( NDSTRC, NTRACE ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + NDSI = 10 + NDSM = 20 + NDSOP = 20 + NDSGRD = 30 + NDSPNT = 31 + NDSCGR = 32 + ! + NDSTRC = 6 + NTRACE = 0 + ! + WRITE (NDSO,900) + ! + CALL ITRACE ( NDSTRC, NTRACE ) #ifdef W3_S - CALL STRACE (IENT, 'GXOUTP') -#endif -! - J = LEN_TRIM(FNMPRE) - OPEN (NDSI,FILE=FNMPRE(:J)//'gx_outp.inp',STATUS='OLD', & - ERR=800,IOSTAT=IERR) - READ (NDSI,'(A)',END=801,ERR=802) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR -! - OPEN (NDSGRD,FILE=FNMPRE(:J)//'ww3.spec.grads', & - form='UNFORMATTED', convert=file_endian) - OPEN (NDSPNT,FILE=FNMPRE(:J)//'ww3.mean.grads',FORM='FORMATTED') - OPEN (NDSCGR,FILE=FNMPRE(:J)//'ww3.spec.ctl',FORM='FORMATTED') -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - WRITE (NDSO,920) GNAME + CALL STRACE (IENT, 'GXOUTP') +#endif + ! + J = LEN_TRIM(FNMPRE) + OPEN (NDSI,FILE=FNMPRE(:J)//'gx_outp.inp',STATUS='OLD', & + ERR=800,IOSTAT=IERR) + READ (NDSI,'(A)',END=801,ERR=802) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + ! + OPEN (NDSGRD,FILE=FNMPRE(:J)//'ww3.spec.grads', & + form='UNFORMATTED', convert=file_endian) + OPEN (NDSPNT,FILE=FNMPRE(:J)//'ww3.mean.grads',FORM='FORMATTED') + OPEN (NDSCGR,FILE=FNMPRE(:J)//'ww3.spec.ctl',FORM='FORMATTED') + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + WRITE (NDSO,920) GNAME + IF ( FLAGLL ) THEN + FACT = 1. + ELSE + FACT = 1.E-3 + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read general data and first fields from file + ! + CALL W3IOPO ( 'READ', NDSOP, IOTEST ) + ALLOCATE ( FLREQ(NOPTS) ) + ! + WRITE (NDSO,930) + DO I=1, NOPTS + IF ( FLAGLL ) THEN + WRITE (NDSO,931) PTNME(I), FACT*PTLOC(1,I), FACT*PTLOC(2,I) + ELSE + WRITE (NDSO,932) PTNME(I), FACT*PTLOC(1,I), FACT*PTLOC(2,I) + END IF + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Read requests from input file. + ! Output times + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT + DTREQ = MAX ( 0. , DTREQ ) + IF ( DTREQ.EQ.0 ) NOUT = 1 + NOUT = MAX ( 1 , NOUT ) + ! + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,940) IDTIME + ! + TDUM = 0 + CALL TICK21 ( TDUM , DTREQ ) + CALL STME21 ( TDUM , IDTIME ) + IF ( DTREQ .GE. 86400. ) THEN + WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) + ELSE + IDDDAY = ' ' + END IF + IDTIME(1:11) = IDDDAY + IDTIME(21:23) = ' ' + WRITE (NDSO,941) IDTIME, NOUT + ! + ! ... Output points + ! + FLREQ = .FALSE. + NREQ = 0 + ! + DO + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) IPOINT + IF ( IPOINT .GT. 0 ) THEN + IF ( IPOINT .LE. NOPTS ) THEN + IF ( .NOT. FLREQ(IPOINT) ) NREQ = NREQ + 1 + FLREQ(IPOINT) = .TRUE. + END IF + ELSE + EXIT + END IF + END DO + ! + ! ... Output of output points + ! + WRITE (NDSO,950) NREQ + DO I=1, NOPTS + IF (FLREQ(I)) THEN IF ( FLAGLL ) THEN - FACT = 1. - ELSE - FACT = 1.E-3 - END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read general data and first fields from file -! + WRITE (NDSO,951) PTNME(I), FACT*PTLOC(1,I), & + FACT*PTLOC(2,I) + ELSE + WRITE (NDSO,956) PTNME(I), FACT*PTLOC(1,I), & + FACT*PTLOC(2,I) + END IF + END IF + END DO + ! + ! ... Output of output points + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) FLSRCE + WRITE (NDSO,952) + NLEV = 0 + DO I=1, 7 + IF ( FLSRCE(I) ) THEN + WRITE (NDST,953) IDSRCE(I) + NLEV = NLEV + 1 + END IF + END DO + ! + WRITE (NDSO,955) + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Time management. + ! + IOUT = 0 + ! + DO + DTEST = DSEC21 ( TIME , TOUT ) + IF ( DTEST .GT. 0. ) THEN CALL W3IOPO ( 'READ', NDSOP, IOTEST ) - ALLOCATE ( FLREQ(NOPTS) ) -! - WRITE (NDSO,930) - DO I=1, NOPTS - IF ( FLAGLL ) THEN - WRITE (NDSO,931) PTNME(I), FACT*PTLOC(1,I), FACT*PTLOC(2,I) - ELSE - WRITE (NDSO,932) PTNME(I), FACT*PTLOC(1,I), FACT*PTLOC(2,I) - END IF - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Read requests from input file. -! Output times -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT - DTREQ = MAX ( 0. , DTREQ ) - IF ( DTREQ.EQ.0 ) NOUT = 1 - NOUT = MAX ( 1 , NOUT ) -! - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,940) IDTIME -! - TDUM = 0 - CALL TICK21 ( TDUM , DTREQ ) - CALL STME21 ( TDUM , IDTIME ) - IF ( DTREQ .GE. 86400. ) THEN - WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) - ELSE - IDDDAY = ' ' - END IF - IDTIME(1:11) = IDDDAY - IDTIME(21:23) = ' ' - WRITE (NDSO,941) IDTIME, NOUT -! -! ... Output points -! - FLREQ = .FALSE. - NREQ = 0 -! - DO - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) IPOINT - IF ( IPOINT .GT. 0 ) THEN - IF ( IPOINT .LE. NOPTS ) THEN - IF ( .NOT. FLREQ(IPOINT) ) NREQ = NREQ + 1 - FLREQ(IPOINT) = .TRUE. - END IF - ELSE - EXIT - END IF - END DO -! -! ... Output of output points -! - WRITE (NDSO,950) NREQ - DO I=1, NOPTS - IF (FLREQ(I)) THEN - IF ( FLAGLL ) THEN - WRITE (NDSO,951) PTNME(I), FACT*PTLOC(1,I), & - FACT*PTLOC(2,I) - ELSE - WRITE (NDSO,956) PTNME(I), FACT*PTLOC(1,I), & - FACT*PTLOC(2,I) - END IF - END IF - END DO -! -! ... Output of output points -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) FLSRCE - WRITE (NDSO,952) - NLEV = 0 - DO I=1, 7 - IF ( FLSRCE(I) ) THEN - WRITE (NDST,953) IDSRCE(I) - NLEV = NLEV + 1 - END IF - END DO -! - WRITE (NDSO,955) -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Time management. -! - IOUT = 0 -! - DO - DTEST = DSEC21 ( TIME , TOUT ) - IF ( DTEST .GT. 0. ) THEN - CALL W3IOPO ( 'READ', NDSOP, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - WRITE (NDSO,998) - EXIT - END IF - CYCLE - END IF - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF -! - IOUT = IOUT + 1 - CALL STME21 ( TOUT , IDTIME ) -! - CALL GXEXPO - TIMEN = TOUT -! - IF ( TIME0(1) .EQ. -1 ) TIME0 = TIME -! - CALL TICK21 ( TOUT , DTREQ ) - IF ( IOUT .GE. NOUT ) EXIT - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6. Close data file and write control file -! 6.a Close data sets -! - WRITE (NDSO,960) -! - WRITE (NDSO,961) - CLOSE (NDSGRD) - CLOSE (NDSPNT) -! - WRITE (NDSO,962) -! -! 6.b Set up timing info -! - IH0 = TIME0(2)/10000 - IM0 = MOD(TIME0(2)/100,100) - ID0 = MOD(TIME0(1),100) - IID = MOD(TIME0(1)/100,100) - IJ0 = TIME0(1)/10000 -! - IF ( IOUT .GT. 1 ) DTREQ = DSEC21 ( TIME0, TIMEN ) / REAL(IOUT-1) - IF ( IOUT .EQ. 1 ) DTREQ = 3600. - IF ( DTREQ .GT. 3599. ) THEN - CINC = 'HR' - IINC = NINT(DTREQ/3600.) - IF ( MOD(NINT(DTREQ),3600) .NE. 0 ) GOTO 820 - ELSE - CINC = 'MN' - IINC = NINT(DTREQ/60.) - END IF -! - WRITE (NDSO,963) IOUT, IH0, IM0, ID0, MNTH(IID), IJ0, IINC, CINC -! -! 6.c Write control file for spectral data -! - WRITE (NDSO,964) -! - WRITE (NDSCGR,970) UNDEFP, NTH, 90.+TH(1)*RADE, DTH*RADE, & - NK, (90.-TPIINV*SIG(IK),IK=NK,MAX(1,NK-4),-1) - WRITE (NDSCGR,971) (90.-TPIINV*SIG(IK),IK=NK-5,1,-1) - WRITE (NDSCGR,972) NLEV, 1., 1., & - IOUT, IH0, IM0, ID0, MNTH(IID), IJ0, & - IINC, CINC, NREQ -! - IREQ = 0 - DO I=1, NOPTS - IF ( FLREQ(I) ) THEN - IREQ = IREQ + 1 - WRITE (NDSCGR,973) IREQ, NLEV, 99, PTNME(I) - END IF - END DO -! - WRITE (NDSCGR,974) -! - GOTO 888 -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 10 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 11 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 12 ) -! - 820 CONTINUE - WRITE (NDSE,1020) DTREQ - CALL EXTCDE ( 20 ) -! - 821 CONTINUE - WRITE (NDSE,1021) - CALL EXTCDE ( 21 ) -! - 888 CONTINUE -! - WRITE (NDSO,999) -! -! Formats -! - 900 FORMAT (/12X,' *** WAVEWATCH III GrADS point output post.*** '/ & - 12X,'====================================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) -! - 920 FORMAT ( ' Grid name : ',A/) -! - 930 FORMAT ( ' Points in file : '/ & - ' ------------------------------------') + IF ( IOTEST .EQ. -1 ) THEN + WRITE (NDSO,998) + EXIT + END IF + CYCLE + END IF + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF + ! + IOUT = IOUT + 1 + CALL STME21 ( TOUT , IDTIME ) + ! + CALL GXEXPO + TIMEN = TOUT + ! + IF ( TIME0(1) .EQ. -1 ) TIME0 = TIME + ! + CALL TICK21 ( TOUT , DTREQ ) + IF ( IOUT .GE. NOUT ) EXIT + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6. Close data file and write control file + ! 6.a Close data sets + ! + WRITE (NDSO,960) + ! + WRITE (NDSO,961) + CLOSE (NDSGRD) + CLOSE (NDSPNT) + ! + WRITE (NDSO,962) + ! + ! 6.b Set up timing info + ! + IH0 = TIME0(2)/10000 + IM0 = MOD(TIME0(2)/100,100) + ID0 = MOD(TIME0(1),100) + IID = MOD(TIME0(1)/100,100) + IJ0 = TIME0(1)/10000 + ! + IF ( IOUT .GT. 1 ) DTREQ = DSEC21 ( TIME0, TIMEN ) / REAL(IOUT-1) + IF ( IOUT .EQ. 1 ) DTREQ = 3600. + IF ( DTREQ .GT. 3599. ) THEN + CINC = 'HR' + IINC = NINT(DTREQ/3600.) + IF ( MOD(NINT(DTREQ),3600) .NE. 0 ) GOTO 820 + ELSE + CINC = 'MN' + IINC = NINT(DTREQ/60.) + END IF + ! + WRITE (NDSO,963) IOUT, IH0, IM0, ID0, MNTH(IID), IJ0, IINC, CINC + ! + ! 6.c Write control file for spectral data + ! + WRITE (NDSO,964) + ! + WRITE (NDSCGR,970) UNDEFP, NTH, 90.+TH(1)*RADE, DTH*RADE, & + NK, (90.-TPIINV*SIG(IK),IK=NK,MAX(1,NK-4),-1) + WRITE (NDSCGR,971) (90.-TPIINV*SIG(IK),IK=NK-5,1,-1) + WRITE (NDSCGR,972) NLEV, 1., 1., & + IOUT, IH0, IM0, ID0, MNTH(IID), IJ0, & + IINC, CINC, NREQ + ! + IREQ = 0 + DO I=1, NOPTS + IF ( FLREQ(I) ) THEN + IREQ = IREQ + 1 + WRITE (NDSCGR,973) IREQ, NLEV, 99, PTNME(I) + END IF + END DO + ! + WRITE (NDSCGR,974) + ! + GOTO 888 + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 10 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 11 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 12 ) + ! +820 CONTINUE + WRITE (NDSE,1020) DTREQ + CALL EXTCDE ( 20 ) + ! +821 CONTINUE + WRITE (NDSE,1021) + CALL EXTCDE ( 21 ) + ! +888 CONTINUE + ! + WRITE (NDSO,999) + ! + ! Formats + ! +900 FORMAT (/12X,' *** WAVEWATCH III GrADS point output post.*** '/ & + 12X,'====================================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) + ! +920 FORMAT ( ' Grid name : ',A/) + ! +930 FORMAT ( ' Points in file : '/ & + ' ------------------------------------') - 931 FORMAT ( ' ',A,2F10.2) +931 FORMAT ( ' ',A,2F10.2) - 932 FORMAT ( ' ',A,2(F8.1,'E3')) -! - 940 FORMAT (/' Output time data : '/ & - ' --------------------------------------------------'/ & - ' First time : ',A) - 941 FORMAT ( ' Interval : ',A/ & - ' Number of requests : ',I4) -! - 950 FORMAT (/' Requested output for',I3,' points : '/ & - ' --------------------------------------------------') +932 FORMAT ( ' ',A,2(F8.1,'E3')) + ! +940 FORMAT (/' Output time data : '/ & + ' --------------------------------------------------'/ & + ' First time : ',A) +941 FORMAT ( ' Interval : ',A/ & + ' Number of requests : ',I4) + ! +950 FORMAT (/' Requested output for',I3,' points : '/ & + ' --------------------------------------------------') - 951 FORMAT ( ' ',A,2F10.2) +951 FORMAT ( ' ',A,2F10.2) - 956 FORMAT ( ' ',A,2(F8.1,'E3')) +956 FORMAT ( ' ',A,2(F8.1,'E3')) - 952 FORMAT (/' Requested output fields :'/ & - ' --------------------------------------------------') - 953 FORMAT ( ' ',A) - 955 FORMAT (/' Output times :'/ & - ' --------------------------------------------------') -! - 960 FORMAT (//' Final file management '/ & - ' -----------------------------------------------------') - 961 FORMAT ( ' Closing file ww3.spec.grads'/ & - ' Closing file ww3.mean.grads') - 962 FORMAT ( ' Preparing control files :') - 963 FORMAT ( ' Number of times : ',I6/ & - ' Initial time ID : ',I2.2,':',I2.2,'Z',I2.2,A3,I4/ & - ' Time step ID : ',I2,A2) - 964 FORMAT ( ' Writing ww3.spec.ctl'/) -! - 970 FORMAT ('DSET ww3.spec.grads'/ & - 'TITLE WAVEWATCH III spectra and source terms'/ & - 'OPTIONS sequential'/ & - 'OPTIONS big_endian'/ & - 'UNDEF ',E10.2/ & - 'XDEF ',I4,' LINEAR ',2F8.2/ & - 'YDEF ',I4,' LEVELS ',5F8.4) - 971 FORMAT (22X,5F8.4) - 972 FORMAT ('ZDEF ',I4,' LINEAR ',2F8.2/ & - 'TDEF ',I4,' LINEAR ',I6.2,':',I2.2,'Z',I2.2,A3,I4, & - 2x,I2,A2/ & - 'VARS ',I4) - 973 FORMAT ('LOC',I3.3,2I4,2X,A) - 974 FORMAT ('ENDVARS') -! - 998 FORMAT (/' End of file reached '/) -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III GrADS point output '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTP : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTP : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTP : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1020 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & - ' FIELD INCREMENT > 1HR BUT NOT MULTIPLE',F10.0/) -! - 1021 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & - ' UPDATE PARS IN LOOP 610 !!!'/) -!/ -!/ Internal subroutine GXEXPO ---------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE GXEXPO -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 16-Jul-2012 | -!/ +-----------------------------------+ -!/ -!/ 30-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Massive changes to logistics -!/ 25-Jan-2001 : Cartesian grid version ( version 2.06 ) -!/ 02-Feb-2001 : Xnl version 5 ( version 2.07 ) -!/ 01-Aug-2003 : Fix format for SH output points. ( version 3.03 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 23-Jun-2006 : Linear input added. ( version 3.09 ) -!/ 03-Jul-2006 : Separate flux modules. ( version 3.09 ) -!/ 25-Jul-2006 : Grid ID for each point. ( version 3.10 ) -!/ 25-Apr-2007 : EMEAN in W3SPR2 par list. ( version 3.11 ) -!/ 09-Oct-2007 : WAM 4+ Sin and Sds added. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 09-Oct-2007 : Experimental Sbs (BS1) added. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 16-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) -!/ from 3.15 (HLT). ( version 4.08 ) -!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) -!/ -! 1. Purpose : -! -! Perform actual point output. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SPRn Subr. W3SRCnMD Mean wave parameters for use in -! source terms. -! W3FLXn Subr. W3FLXnMD Flux/stress computation. -! W3SLNn Subr. W3SLNnMD Linear input. -! W3SINn Subr. W3SRCnMD Input source term. -! W3SDSn Subr. W3SRCnMD Whitecapping source term -! W3SNLn Subr. W3SNLnMD Nonlinear interactions. -! W3SBTn Subr. W3SBTnMD Bottom friction source term. -! W3SDBn Subr. W3SBTnMD Depth induced breaking source term. -! W3STRn Subr. W3STRnMD Triad interaction source term. -! W3SBSn Subr. W3SBSnMD Bottom scattering source term. -! W3SXXn Subr. W3SXXnMD Unclassified source term. -! STRACE Subr. W3SERVMD Subroutine tracing. -! STME21 Subr. W3TIMEMD Convert time to string. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Program in which it is contained. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Spectra are relative frequency energy spectra. -! - Note that arrays CX and CY of the main program now contain -! the absolute current speed and direction respectively. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! !/FLXx Flux/stress computation. -! !/LNx Linear input package -! !/STx Source term package -! !/NLx Nonlinear interaction package -! !/BTx Bottom friction package -! !/ICx Ice source term package -! !/DBx Depth-induced breaking package -! !/TRx Triad interaction package -! !/BSx Bottom scattering package -! -! !/STAB2 Stability correction for !/ST2 -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +952 FORMAT (/' Requested output fields :'/ & + ' --------------------------------------------------') +953 FORMAT ( ' ',A) +955 FORMAT (/' Output times :'/ & + ' --------------------------------------------------') + ! +960 FORMAT (//' Final file management '/ & + ' -----------------------------------------------------') +961 FORMAT ( ' Closing file ww3.spec.grads'/ & + ' Closing file ww3.mean.grads') +962 FORMAT ( ' Preparing control files :') +963 FORMAT ( ' Number of times : ',I6/ & + ' Initial time ID : ',I2.2,':',I2.2,'Z',I2.2,A3,I4/ & + ' Time step ID : ',I2,A2) +964 FORMAT ( ' Writing ww3.spec.ctl'/) + ! +970 FORMAT ('DSET ww3.spec.grads'/ & + 'TITLE WAVEWATCH III spectra and source terms'/ & + 'OPTIONS sequential'/ & + 'OPTIONS big_endian'/ & + 'UNDEF ',E10.2/ & + 'XDEF ',I4,' LINEAR ',2F8.2/ & + 'YDEF ',I4,' LEVELS ',5F8.4) +971 FORMAT (22X,5F8.4) +972 FORMAT ('ZDEF ',I4,' LINEAR ',2F8.2/ & + 'TDEF ',I4,' LINEAR ',I6.2,':',I2.2,'Z',I2.2,A3,I4, & + 2x,I2,A2/ & + 'VARS ',I4) +973 FORMAT ('LOC',I3.3,2I4,2X,A) +974 FORMAT ('ENDVARS') + ! +998 FORMAT (/' End of file reached '/) + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III GrADS point output '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTP : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTP : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTP : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1020 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & + ' FIELD INCREMENT > 1HR BUT NOT MULTIPLE',F10.0/) + ! +1021 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & + ' UPDATE PARS IN LOOP 610 !!!'/) + !/ + !/ Internal subroutine GXEXPO ---------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE GXEXPO + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 16-Jul-2012 | + !/ +-----------------------------------+ + !/ + !/ 30-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Massive changes to logistics + !/ 25-Jan-2001 : Cartesian grid version ( version 2.06 ) + !/ 02-Feb-2001 : Xnl version 5 ( version 2.07 ) + !/ 01-Aug-2003 : Fix format for SH output points. ( version 3.03 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 23-Jun-2006 : Linear input added. ( version 3.09 ) + !/ 03-Jul-2006 : Separate flux modules. ( version 3.09 ) + !/ 25-Jul-2006 : Grid ID for each point. ( version 3.10 ) + !/ 25-Apr-2007 : EMEAN in W3SPR2 par list. ( version 3.11 ) + !/ 09-Oct-2007 : WAM 4+ Sin and Sds added. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 09-Oct-2007 : Experimental Sbs (BS1) added. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 16-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) + !/ from 3.15 (HLT). ( version 4.08 ) + !/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) + !/ + ! 1. Purpose : + ! + ! Perform actual point output. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SPRn Subr. W3SRCnMD Mean wave parameters for use in + ! source terms. + ! W3FLXn Subr. W3FLXnMD Flux/stress computation. + ! W3SLNn Subr. W3SLNnMD Linear input. + ! W3SINn Subr. W3SRCnMD Input source term. + ! W3SDSn Subr. W3SRCnMD Whitecapping source term + ! W3SNLn Subr. W3SNLnMD Nonlinear interactions. + ! W3SBTn Subr. W3SBTnMD Bottom friction source term. + ! W3SDBn Subr. W3SBTnMD Depth induced breaking source term. + ! W3STRn Subr. W3STRnMD Triad interaction source term. + ! W3SBSn Subr. W3SBSnMD Bottom scattering source term. + ! W3SXXn Subr. W3SXXnMD Unclassified source term. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Program in which it is contained. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Spectra are relative frequency energy spectra. + ! - Note that arrays CX and CY of the main program now contain + ! the absolute current speed and direction respectively. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! !/FLXx Flux/stress computation. + ! !/LNx Linear input package + ! !/STx Source term package + ! !/NLx Nonlinear interaction package + ! !/BTx Bottom friction package + ! !/ICx Ice source term package + ! !/DBx Depth-induced breaking package + ! !/TRx Triad interaction package + ! !/BSx Bottom scattering package + ! + ! !/STAB2 Stability correction for !/ST2 + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_FLX1 - USE W3FLX1MD + USE W3FLX1MD #endif #ifdef W3_FLX2 - USE W3FLX2MD + USE W3FLX2MD #endif #ifdef W3_FLX3 - USE W3FLX3MD + USE W3FLX3MD #endif #ifdef W3_FLX4 - USE W3FLX4MD + USE W3FLX4MD #endif #ifdef W3_FLX5 - USE W3FLX5MD + USE W3FLX5MD #endif #ifdef W3_LN1 - USE W3SLN1MD + USE W3SLN1MD #endif #ifdef W3_ST1 - USE W3SRC1MD + USE W3SRC1MD #endif #ifdef W3_ST2 - USE W3SRC2MD + USE W3SRC2MD #endif #ifdef W3_ST3 - USE W3SRC3MD + USE W3SRC3MD #endif #ifdef W3_ST4 - USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 + USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 #endif #ifdef W3_ST6 - USE W3SRC6MD - USE W3SWLDMD, ONLY : W3SWL6 - USE W3GDATMD, ONLY : SWL6S6 + USE W3SRC6MD + USE W3SWLDMD, ONLY : W3SWL6 + USE W3GDATMD, ONLY : SWL6S6 #endif #ifdef W3_NL1 - USE W3SNL1MD + USE W3SNL1MD #endif #ifdef W3_NL2 - USE W3SNL2MD + USE W3SNL2MD #endif #ifdef W3_NL3 - USE W3SNL3MD + USE W3SNL3MD #endif #ifdef W3_NL4 - USE W3SNL4MD + USE W3SNL4MD #endif #ifdef W3_NLS - USE W3SNLSMD + USE W3SNLSMD #endif #ifdef W3_BT1 - USE W3SBT1MD + USE W3SBT1MD #endif #ifdef W3_BT4 - USE W3SBT4MD + USE W3SBT4MD #endif #ifdef W3_BT8 - USE W3SBT8MD + USE W3SBT8MD #endif #ifdef W3_IC1 - USE W3SIC1MD + USE W3SIC1MD #endif #ifdef W3_IC2 - USE W3SIC2MD + USE W3SIC2MD #endif #ifdef W3_IC3 - USE W3SIC3MD + USE W3SIC3MD #endif #ifdef W3_IC4 - USE W3SIC4MD + USE W3SIC4MD #endif #ifdef W3_IC5 - USE W3SIC5MD + USE W3SIC5MD #endif #ifdef W3_DB1 - USE W3SDB1MD + USE W3SDB1MD #endif #ifdef W3_BS1 - USE W3SBS1MD + USE W3SBS1MD #endif #ifdef W3_IS2 - USE W3SIS2MD -#endif -!/ - USE W3DISPMD, ONLY: LIU_FORWARD_DISPERSION, NAR1D, DFAC, N1MAX, & - ECG1, EWN1, DSIE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, I1, I2, IK, ITH, ISPEC, IKM, IKL, & - IKH, ITT, IX, IY, ISEA + USE W3SIS2MD +#endif + !/ + USE W3DISPMD, ONLY: LIU_FORWARD_DISPERSION, NAR1D, DFAC, N1MAX, & + ECG1, EWN1, DSIE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, I1, I2, IK, ITH, ISPEC, IKM, IKL, & + IKH, ITT, IX, IY, ISEA #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: XL, XH, XL2, XH2, DEPTH, SQRTH, UDIR,& - UDIRR, UABS, CDIR, SIX, R1, R2, ET, & - EWN, ETR, ETX, ETY, EBND, EBX, EBY, & - HSIG, WLEN, TMEAN, THMEAN, THSPRD, & - EMAX, EL, EH, DENOM, FP, THP, SPP, & - FACTOR, CD, USTAR, FHIGH, ZWND, ICE, & - USTD, Z0, CHARN, EMEAN, FMEAN, WNMEAN,& - ICETHICK, ICECON, ICEF + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: XL, XH, XL2, XH2, DEPTH, SQRTH, UDIR,& + UDIRR, UABS, CDIR, SIX, R1, R2, ET, & + EWN, ETR, ETX, ETY, EBND, EBX, EBY, & + HSIG, WLEN, TMEAN, THMEAN, THSPRD, & + EMAX, EL, EH, DENOM, FP, THP, SPP, & + FACTOR, CD, USTAR, FHIGH, ZWND, ICE, & + USTD, Z0, CHARN, EMEAN, FMEAN, WNMEAN,& + ICETHICK, ICECON, ICEF #ifdef W3_FLX5 - REAL ::TAUA, TAUADIR, RHOAIR + REAL ::TAUA, TAUADIR, RHOAIR #endif #ifdef W3_IS2 - REAL :: ICEDMAX + REAL :: ICEDMAX #endif #ifdef W3_ST1 - REAL :: AMAX, FH1, FH2 + REAL :: AMAX, FH1, FH2 #endif #ifdef W3_ST2 - REAL :: AMAX, ALPHA(NK), FPI + REAL :: AMAX, ALPHA(NK), FPI #endif #ifdef W3_ST3 - REAL :: FMEANS, FMEANWS, TAUWX, TAUWY, AMAX, & - TAUWNX, TAUWNY + REAL :: FMEANS, FMEANWS, TAUWX, TAUWY, AMAX, & + TAUWNX, TAUWNY #endif #ifdef W3_ST4 - REAL :: FMEANWS, TAUWX, TAUWY, AMAX, & - TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4), DLWMEAN + REAL :: FMEANWS, TAUWX, TAUWY, AMAX, & + TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4), DLWMEAN #endif #ifdef W3_ST6 - REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY + REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY #endif #ifdef W3_BS1 - REAL :: TAUSCX, TAUSCY + REAL :: TAUSCX, TAUSCY #endif #ifdef W3_BT3 - REAL :: D50 + REAL :: D50 #endif #ifdef W3_BT4 - REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) + REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) #endif #ifdef W3_STAB2 - REAL :: STAB0, STAB, THARG1, THARG2, COR1, & - COR2, ASFAC -#endif - REAL :: HSMIN = 0.05 - REAL :: WN(NK), CG(NK), E(NK,NTH), E1(NK), & - APM(NK), THBND(NK), SPBND(NK), & - A(NTH,NK), WN2(NTH,NK),WN_R(NK), & - ALPHA_LIU(NK), CG_ICE(NK), R(NK) - REAL :: DIA(NTH,NK), SWI(NK,NTH), SNL(NK,NTH),& - SDS(NK,NTH), SBT(NK,NTH), SIS(NK,NTH),& - STT(NK,NTH), DIA2(NK,NTH) - REAL :: XLN(NTH,NK), XWI(NTH,NK), XNL(NTH,NK),& - XTR(NTH,NK), XDS(NTH,NK), XDB(NTH,NK),& - XBT(NTH,NK), XBS(NTH,NK), XXX(NTH,NK),& - XWL(NTH,NK), XIS(NTH,NK) - LOGICAL :: LBREAK + REAL :: STAB0, STAB, THARG1, THARG2, COR1, & + COR2, ASFAC +#endif + REAL :: HSMIN = 0.05 + REAL :: WN(NK), CG(NK), E(NK,NTH), E1(NK), & + APM(NK), THBND(NK), SPBND(NK), & + A(NTH,NK), WN2(NTH,NK),WN_R(NK), & + ALPHA_LIU(NK), CG_ICE(NK), R(NK) + REAL :: DIA(NTH,NK), SWI(NK,NTH), SNL(NK,NTH),& + SDS(NK,NTH), SBT(NK,NTH), SIS(NK,NTH),& + STT(NK,NTH), DIA2(NK,NTH) + REAL :: XLN(NTH,NK), XWI(NTH,NK), XNL(NTH,NK),& + XTR(NTH,NK), XDS(NTH,NK), XDB(NTH,NK),& + XBT(NTH,NK), XBS(NTH,NK), XXX(NTH,NK),& + XWL(NTH,NK), XIS(NTH,NK) + LOGICAL :: LBREAK #ifdef W3_ST3 - LOGICAL :: LLWS(NTH,NK) + LOGICAL :: LLWS(NTH,NK) #endif #ifdef W3_ST4 - LOGICAL :: LLWS(NTH,NK) - REAL :: LAMBDA(NSPEC) + LOGICAL :: LLWS(NTH,NK) + REAL :: LAMBDA(NSPEC) #endif - CHARACTER :: DTME21*23 -!/ -!/ ------------------------------------------------------------------- / -!/ + CHARACTER :: DTME21*23 + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GXEXPO') -#endif -! - XL = 1./XFR - 1. - XH = XFR - 1. - XL2 = XL**2 - XH2 = XH**2 - ICE = 0. -! - XLN = 0. - XWI = 0. - XNL = 0. - XTR = 0. - XDS = 0. - XDB = 0. - XBT = 0. - XBS = 0. - XWL = 0. - XIS = 0. - XXX = 0. -! + CALL STRACE (IENT, 'GXEXPO') +#endif + ! + XL = 1./XFR - 1. + XH = XFR - 1. + XL2 = XL**2 + XH2 = XH**2 + ICE = 0. + ! + XLN = 0. + XWI = 0. + XNL = 0. + XTR = 0. + XDS = 0. + XDB = 0. + XBT = 0. + XBS = 0. + XWL = 0. + XIS = 0. + XXX = 0. + ! #ifdef W3_T - WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) - WRITE (NDST,9001) FLSRCE -#endif -! -! Output of time -! - CALL STME21 ( TIME , DTME21 ) - WRITE (NDSO,905) DTME21 -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Loop over output points. -! - DO J=1, NOPTS - IF ( FLREQ(J) ) THEN -! + WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) + WRITE (NDST,9001) FLSRCE +#endif + ! + ! Output of time + ! + CALL STME21 ( TIME , DTME21 ) + WRITE (NDSO,905) DTME21 + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! Loop over output points. + ! + DO J=1, NOPTS + IF ( FLREQ(J) ) THEN + ! #ifdef W3_T - WRITE (NDST,9002) PTNME(J) -#endif -! -! 2. Calculate grid parameters using and inlined version of WAVNU1. -! - DEPTH = MAX ( DMIN, DPO(J) ) - SQRTH = SQRT ( DEPTH ) - UDIR = MOD ( 270. - WDO(J)*RADE , 360. ) - UDIRR = WDO(J) - UABS = MAX ( 0.001 , WAO(J) ) + WRITE (NDST,9002) PTNME(J) +#endif + ! + ! 2. Calculate grid parameters using and inlined version of WAVNU1. + ! + DEPTH = MAX ( DMIN, DPO(J) ) + SQRTH = SQRT ( DEPTH ) + UDIR = MOD ( 270. - WDO(J)*RADE , 360. ) + UDIRR = WDO(J) + UABS = MAX ( 0.001 , WAO(J) ) #ifdef W3_FLX5 - TAUA = MAX ( 0.001 , TAUAO(J)) - TAUADIR = MOD ( 270. - TAUDO(J)*RADE , 360. ) - RHOAIR = MAX ( 0. , DAIRO(J)) + TAUA = MAX ( 0.001 , TAUAO(J)) + TAUADIR = MOD ( 270. - TAUDO(J)*RADE , 360. ) + RHOAIR = MAX ( 0. , DAIRO(J)) #endif - CDIR = MOD ( 270. - CDO(J)*RADE , 360. ) + CDIR = MOD ( 270. - CDO(J)*RADE , 360. ) #ifdef W3_IS2 - ICEDMAX = MAX ( 0., ICEFO(J)) + ICEDMAX = MAX ( 0., ICEFO(J)) #endif #ifdef W3_IC2 - ICEF = 0. + ICEF = 0. #endif #ifdef W3_IS2 - ICEF = ICEDMAX + ICEF = ICEDMAX #endif - ICETHICK = MAX (0., ICEHO(J)) - ICECON = MAX (0., ICEO(J)) -! + ICETHICK = MAX (0., ICEHO(J)) + ICECON = MAX (0., ICEO(J)) + ! #ifdef W3_STAB2 - STAB0 = ZWIND * GRAV / 273. - STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 - STAB = MAX ( -1. , MIN ( 1. , STAB ) ) - THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) - THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) - COR1 = CCNG * TANH(THARG1) - COR2 = CCPS * TANH(THARG2) - ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) -#endif -! + STAB0 = ZWIND * GRAV / 273. + STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 + STAB = MAX ( -1. , MIN ( 1. , STAB ) ) + THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) + THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) + COR1 = CCNG * TANH(THARG1) + COR2 = CCPS * TANH(THARG2) + ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) +#endif + ! #ifdef W3_T - WRITE (NDST,9010) DEPTH -#endif - DO IK=1, NK - SIX = SIG(IK) * SQRTH - I1 = INT(SIX/DSIE) - IF (I1.LE.N1MAX) THEN - I2 = I1 + 1 - R1 = SIX/DSIE - REAL(I1) - R2 = 1. - R1 - WN(IK) = ( R2*EWN1(I1) + R1*EWN1(I2) ) / DEPTH - CG(IK) = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH - ELSE - WN(IK) = SIG(IK)*SIG(IK)/GRAV - CG(IK) = 0.5 * GRAV / SIG(IK) - END IF + WRITE (NDST,9010) DEPTH +#endif + DO IK=1, NK + SIX = SIG(IK) * SQRTH + I1 = INT(SIX/DSIE) + IF (I1.LE.N1MAX) THEN + I2 = I1 + 1 + R1 = SIX/DSIE - REAL(I1) + R2 = 1. - R1 + WN(IK) = ( R2*EWN1(I1) + R1*EWN1(I2) ) / DEPTH + CG(IK) = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH + ELSE + WN(IK) = SIG(IK)*SIG(IK)/GRAV + CG(IK) = 0.5 * GRAV / SIG(IK) + END IF #ifdef W3_T - WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) + WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) #endif -! - END DO + ! + END DO - IF (IICEDISP) THEN - CALL LIU_FORWARD_DISPERSION (ICETHICK,0.,DEPTH, & - SIG,WN_R,CG_ICE,ALPHA_LIU) - ELSE - WN_R=WN - CG_ICE=CG - END IF - R(:)=1 ! In case IC2 is defined but not IS2 + IF (IICEDISP) THEN + CALL LIU_FORWARD_DISPERSION (ICETHICK,0.,DEPTH, & + SIG,WN_R,CG_ICE,ALPHA_LIU) + ELSE + WN_R=WN + CG_ICE=CG + END IF + R(:)=1 ! In case IC2 is defined but not IS2 -! -! 3. Prepare spectra etc. -! 3.a Mean wave parameters. -! - ET = 0. - EWN = 0. - ETR = 0. - ETX = 0. - ETY = 0. - DO IK=1, NK - EBND = 0. - EBX = 0. - EBY = 0. - DO ITH=1, NTH - ISPEC = ITH + (IK-1)*NTH - E(IK,ITH) = SPCO(ISPEC,J) - EBND = EBND + SPCO(ISPEC,J) - EBX = EBX + SPCO(ISPEC,J)*ECOS(ITH) - EBY = EBY + SPCO(ISPEC,J)*ESIN(ITH) - END DO - E1(IK) = EBND * DTH - APM(IK)= E1(IK) / ( TPI * GRAV**2 / SIG(IK)**5 ) - IF ( E1(IK) .GT. 1.E-5) THEN - THBND(IK) = MOD(630.- RADE*ATAN2(EBY,EBX),360.) - SPBND(IK) = RADE * SQRT ( MAX ( 0. , 2.*( 1. - & - SQRT( MAX(0.,(EBX**2+EBY**2)/EBND**2) ) ) ) ) - ELSE - THBND(IK) = -999.9 - SPBND(IK) = -999.9 - END IF - EBND = E1(IK) * DSII(IK) * TPIINV - ET = ET + EBND - EWN = EWN + EBND / WN(IK) - ETR = ETR + EBND / SIG(IK) - ETX = ETX + EBX * DSII(IK) - ETY = ETY + EBY * DSII(IK) - END DO -! -! tail factors for radian action etc ...! -! - EBND = E1(NK) * TPIINV / ( SIG(NK) * DTH ) - ET = ET + FTE *EBND - EWN = EWN + FTWL*EBND - ETR = ETR + FTTR*EBND - ETX = DTH*ETX*TPIINV + FTE*EBX*TPIINV/SIG(NK) - ETY = DTH*ETY*TPIINV + FTE*EBY*TPIINV/SIG(NK) -! - HSIG = 4. * SQRT ( ET ) - IF ( HSIG .GT. HSMIN ) THEN - WLEN = EWN / ET * TPI - TMEAN = ETR / ET * TPI - THMEAN = MOD ( 630. - RADE*ATAN2(ETY,ETX) , 360. ) - THSPRD = RADE * SQRT ( MAX ( 0. , 2.*( 1. - SQRT( & - MAX(0.,(ETX**2+ETY**2)/ET**2) ) ) ) ) - ELSE - WLEN = 0. - TMEAN = 0. - THMEAN = 0. - THSPRD = 0. - DO IK=1, NK - E1(IK) = 0. - DO ITH=1, NTH - E(IK,ITH) = 0. - END DO - END DO - END IF -! -! peak frequency -! - EMAX = E1(NK) - IKM = NK -! - DO IK=NK-1, 1, -1 - IF ( E1(IK) .GT. EMAX ) THEN - EMAX = E1(IK) - IKM = IK - END IF - END DO -! - IKL = MAX ( 1 , IKM-1 ) - IKH = MIN ( NK , IKM+1 ) - EL = E1(IKL) - E1(IKM) - EH = E1(IKH) - E1(IKM) - DENOM = XL*EH - XH*EL -! - IF ( HSIG .GE. HSMIN ) THEN - FP = SIG(IKM) * ( 1. + 0.5 * ( XL2*EH - XH2*EL ) & - / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) - THP = THBND(IKM) - SPP = SPBND(IKM) - ELSE - FP = 0. - THP = 0. - SPP = 0. - END IF -! -! 3.4 source terms -! - DO IK=1, NK - FACTOR = TPIINV * CG(IK) / SIG(IK) - DO ITH=1, NTH - ISPEC = ITH + (IK-1)*NTH - A(ITH,IK) = FACTOR * SPCO(ISPEC,J) - WN2(ITH,IK) = WN(IK) - END DO - END DO -! + ! + ! 3. Prepare spectra etc. + ! 3.a Mean wave parameters. + ! + ET = 0. + EWN = 0. + ETR = 0. + ETX = 0. + ETY = 0. + DO IK=1, NK + EBND = 0. + EBX = 0. + EBY = 0. + DO ITH=1, NTH + ISPEC = ITH + (IK-1)*NTH + E(IK,ITH) = SPCO(ISPEC,J) + EBND = EBND + SPCO(ISPEC,J) + EBX = EBX + SPCO(ISPEC,J)*ECOS(ITH) + EBY = EBY + SPCO(ISPEC,J)*ESIN(ITH) + END DO + E1(IK) = EBND * DTH + APM(IK)= E1(IK) / ( TPI * GRAV**2 / SIG(IK)**5 ) + IF ( E1(IK) .GT. 1.E-5) THEN + THBND(IK) = MOD(630.- RADE*ATAN2(EBY,EBX),360.) + SPBND(IK) = RADE * SQRT ( MAX ( 0. , 2.*( 1. - & + SQRT( MAX(0.,(EBX**2+EBY**2)/EBND**2) ) ) ) ) + ELSE + THBND(IK) = -999.9 + SPBND(IK) = -999.9 + END IF + EBND = E1(IK) * DSII(IK) * TPIINV + ET = ET + EBND + EWN = EWN + EBND / WN(IK) + ETR = ETR + EBND / SIG(IK) + ETX = ETX + EBX * DSII(IK) + ETY = ETY + EBY * DSII(IK) + END DO + ! + ! tail factors for radian action etc ...! + ! + EBND = E1(NK) * TPIINV / ( SIG(NK) * DTH ) + ET = ET + FTE *EBND + EWN = EWN + FTWL*EBND + ETR = ETR + FTTR*EBND + ETX = DTH*ETX*TPIINV + FTE*EBX*TPIINV/SIG(NK) + ETY = DTH*ETY*TPIINV + FTE*EBY*TPIINV/SIG(NK) + ! + HSIG = 4. * SQRT ( ET ) + IF ( HSIG .GT. HSMIN ) THEN + WLEN = EWN / ET * TPI + TMEAN = ETR / ET * TPI + THMEAN = MOD ( 630. - RADE*ATAN2(ETY,ETX) , 360. ) + THSPRD = RADE * SQRT ( MAX ( 0. , 2.*( 1. - SQRT( & + MAX(0.,(ETX**2+ETY**2)/ET**2) ) ) ) ) + ELSE + WLEN = 0. + TMEAN = 0. + THMEAN = 0. + THSPRD = 0. + DO IK=1, NK + E1(IK) = 0. + DO ITH=1, NTH + E(IK,ITH) = 0. + END DO + END DO + END IF + ! + ! peak frequency + ! + EMAX = E1(NK) + IKM = NK + ! + DO IK=NK-1, 1, -1 + IF ( E1(IK) .GT. EMAX ) THEN + EMAX = E1(IK) + IKM = IK + END IF + END DO + ! + IKL = MAX ( 1 , IKM-1 ) + IKH = MIN ( NK , IKM+1 ) + EL = E1(IKL) - E1(IKM) + EH = E1(IKH) - E1(IKM) + DENOM = XL*EH - XH*EL + ! + IF ( HSIG .GE. HSMIN ) THEN + FP = SIG(IKM) * ( 1. + 0.5 * ( XL2*EH - XH2*EL ) & + / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) + THP = THBND(IKM) + SPP = SPBND(IKM) + ELSE + FP = 0. + THP = 0. + SPP = 0. + END IF + ! + ! 3.4 source terms + ! + DO IK=1, NK + FACTOR = TPIINV * CG(IK) / SIG(IK) + DO ITH=1, NTH + ISPEC = ITH + (IK-1)*NTH + A(ITH,IK) = FACTOR * SPCO(ISPEC,J) + WN2(ITH,IK) = WN(IK) + END DO + END DO + ! #ifdef W3_STAB2 - UABS = UABS / ASFAC + UABS = UABS / ASFAC #endif -! + ! #ifdef W3_ST0 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST1 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST2 - ZWND = ZWIND + ZWND = ZWIND #endif #ifdef W3_ST3 - ZWND = ZZWND - TAUWX = 0. - TAUWY = 0. - LLWS(:,:) = .TRUE. + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. + LLWS(:,:) = .TRUE. #endif - USTAR = 1. + USTAR = 1. #ifdef W3_ST4 - ZWND = ZZWND - TAUWX = 0. - TAUWY = 0. + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. #endif #ifdef W3_ST6 - ZWND = 10. + ZWND = 10. #endif -! + ! #ifdef W3_ST0 - FHIGH = SIG(NK) + FHIGH = SIG(NK) #endif #ifdef W3_ST1 - CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) - FP = 0.85 * FMEAN - FH1 = FXFM * FMEAN - FH2 = FXPM / USTAR - FHIGH = MAX ( FH1 , FH2 ) + CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN + FH1 = FXFM * FMEAN + FH2 = FXPM / USTAR + FHIGH = MAX ( FH1 , FH2 ) #endif #ifdef W3_ST2 - CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD, & - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) #endif #ifdef W3_ST4 - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) #endif #ifdef W3_ST6 - CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) + CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) #endif -! + ! #ifdef W3_FLX1 - CALL W3FLX1 ( ZWND, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX1 ( ZWND, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX4 - CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) + CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX5 - CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & - RHOAIR, USTAR, USTD, Z0, CD, CHARN ) + CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & + RHOAIR, USTAR, USTD, Z0, CD, CHARN ) #endif -! - DO ITT=1, 3 + ! + DO ITT=1, 3 #ifdef W3_ST2 - CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & - FPI, XWI, DIA ) - CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XWI, DIA ) + CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - CALL W3SIN3 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & - ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, & - TAUWNX, TAUWNY, & - ICE, XWI, DIA, LLWS, IX, IY ) - CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD, & - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) + CALL W3SIN3 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, & + TAUWNX, TAUWNY, & + ICE, XWI, DIA, LLWS, IX, IY ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) #endif #ifdef W3_ST4 - CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & - ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, & - TAUWNX, TAUWNY, XWI, DIA, LLWS, IX, IY, LAMBDA ) - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, & + TAUWNX, TAUWNY, XWI, DIA, LLWS, IX, IY, LAMBDA ) + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif - END DO -! + END DO + ! #ifdef W3_ST2 - FHIGH = XFC * FPI + FHIGH = XFC * FPI #endif -! - IF ( FLSRCE(2) ) THEN + ! + IF ( FLSRCE(2) ) THEN #ifdef W3_LN1 - CALL W3SLN1 ( WN, FHIGH, USTAR, UDIRR, XLN ) + CALL W3SLN1 ( WN, FHIGH, USTAR, UDIRR, XLN ) #endif -! + ! #ifdef W3_ST1 - CALL W3SIN1 (A, WN2, USTAR, UDIRR, XWI, DIA ) + CALL W3SIN1 (A, WN2, USTAR, UDIRR, XWI, DIA ) #endif #ifdef W3_ST2 - CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & - FPI, XWI, DIA ) + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XWI, DIA ) #endif #ifdef W3_ST3 - CALL W3SIN3 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & - ASO(J), UDIRR, Z0, CD, & - TAUWX, TAUWY, TAUWNX, TAUWNY, & - ICE, XWI, DIA, LLWS, IX, IY ) + CALL W3SIN3 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, & + TAUWX, TAUWY, TAUWNX, TAUWNY, & + ICE, XWI, DIA, LLWS, IX, IY ) #endif #ifdef W3_ST4 - CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & - ASO(J), UDIRR, Z0, CD, & - TAUWX, TAUWY, TAUWNX, TAUWNY, & - XWI, DIA, LLWS, IX, IY, LAMBDA ) + CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, & + TAUWX, TAUWY, TAUWNX, TAUWNY, & + XWI, DIA, LLWS, IX, IY, LAMBDA ) #endif #ifdef W3_ST6 - CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, & - DAIR, TAUWX, TAUWY, TAUWNX, TAUWNY, XWI, DIA ) + CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, & + DAIR, TAUWX, TAUWY, TAUWNX, TAUWNY, XWI, DIA ) #endif - END IF - IF ( FLSRCE(3) ) THEN + END IF + IF ( FLSRCE(3) ) THEN #ifdef W3_NL1 - CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) + CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) #endif #ifdef W3_NL2 - CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) + CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) #endif #ifdef W3_NL3 - CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) + CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) #endif #ifdef W3_NL4 - CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) + CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) #endif - END IF - IF ( FLSRCE(4) ) THEN + END IF + IF ( FLSRCE(4) ) THEN #ifdef W3_ST1 - CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, XDS, DIA ) + CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, XDS, DIA ) #endif #ifdef W3_ST2 - CALL W3SDS2 ( A, CG, WN, FPI, USTAR, ALPHA, XDS, DIA ) + CALL W3SDS2 ( A, CG, WN, FPI, USTAR, ALPHA, XDS, DIA ) #endif #ifdef W3_ST3 - CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & - USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) + CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & + USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) #endif #ifdef W3_ST4 - CALL W3SDS4 ( A, WN, CG, & - USTAR, USTD, DEPTH, DAIR, XDS, DIA, IX, IY, LAMBDA, WHITECAP , DLWMEAN) + CALL W3SDS4 ( A, WN, CG, & + USTAR, USTD, DEPTH, DAIR, XDS, DIA, IX, IY, LAMBDA, WHITECAP , DLWMEAN) #endif #ifdef W3_ST6 - CALL W3SDS6 ( A, CG, WN, XDS, DIA ) - IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) + CALL W3SDS6 ( A, CG, WN, XDS, DIA ) + IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) #endif -! + ! #ifdef W3_DB1 - CALL W3SDB1 ( J, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, & - LBREAK, XDB, DIA ) + CALL W3SDB1 ( J, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, & + LBREAK, XDB, DIA ) #endif -! - END IF - IF ( FLSRCE(5) ) THEN + ! + END IF + IF ( FLSRCE(5) ) THEN #ifdef W3_BT1 - CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) + CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) #endif #ifdef W3_IC1 - CALL W3SIC1 ( A, DEPTH, CG, IX, IY, XBT, DIA ) + CALL W3SIC1 ( A, DEPTH, CG, IX, IY, XBT, DIA ) #endif #ifdef W3_IC2 - CALL W3SIC2 ( A, DEPTH, ICETHICK, ICEF ,CG, WN, IX, IY, XBT, DIA, WN_R, & - CG_ICE, ALPHA_LIU, R ) + CALL W3SIC2 ( A, DEPTH, ICETHICK, ICEF ,CG, WN, IX, IY, XBT, DIA, WN_R, & + CG_ICE, ALPHA_LIU, R ) #endif #ifdef W3_IC3 - CALL W3SIC3 ( A, DEPTH, CG, WN, IX, IY, XBT, DIA ) + CALL W3SIC3 ( A, DEPTH, CG, WN, IX, IY, XBT, DIA ) #endif #ifdef W3_IC4 - CALL W3SIC4 ( A, DEPTH, CG, IX, IY, XBT, DIA ) + CALL W3SIC4 ( A, DEPTH, CG, IX, IY, XBT, DIA ) #endif #ifdef W3_IC5 - CALL W3SIC5 ( A, DEPTH, CG, WN, IX, IY, XBT, DIA ) + CALL W3SIC5 ( A, DEPTH, CG, WN, IX, IY, XBT, DIA ) #endif #ifdef W3_BT4 - IX=1 ! to be fixed later - IY=1 ! to be fixed later - ISEA=1 ! to be fixed later - D50 = SED_D50(ISEA) - PSIC= SED_PSIC(ISEA) + IX=1 ! to be fixed later + IY=1 ! to be fixed later + ISEA=1 ! to be fixed later + D50 = SED_D50(ISEA) + PSIC= SED_PSIC(ISEA) #endif #ifdef W3_BT4 - CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & - BEDFORM, XBT, DIA, IX, IY ) + CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & + BEDFORM, XBT, DIA, IX, IY ) #endif -! + ! #ifdef W3_BT8 - CALL W3SBT8 ( A, DEPTH, XBT, DIA, IX, IY ) + CALL W3SBT8 ( A, DEPTH, XBT, DIA, IX, IY ) #endif #ifdef W3_BS1 - CALL W3SBS1 ( A, CG, WN, DEPTH, CAO(J)*COS(CDO(J)), & - CAO(J)*SIN(CDO(J)), & - TAUSCX, TAUSCY, XBS, DIA ) + CALL W3SBS1 ( A, CG, WN, DEPTH, CAO(J)*COS(CDO(J)), & + CAO(J)*SIN(CDO(J)), & + TAUSCX, TAUSCY, XBS, DIA ) #endif - END IF + END IF - IF ( FLSRCE(6) ) THEN + IF ( FLSRCE(6) ) THEN #ifdef W3_IS2 - CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, IX, IY, & - XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) + CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, IX, IY, & + XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) #endif - END IF -! + END IF + ! #ifdef W3_STAB2 - UABS = UABS * ASFAC -#endif -! - DO IK=1, NK - FACTOR = TPI / CG(IK) * SIG(IK) - DO ITH=1, NTH - ISPEC = ITH + (IK-1)*NTH - E (IK,ITH) = SPCO(ISPEC,J) - SWI(IK,ITH) = ( XWI(ITH,IK) + XLN(ITH,IK) ) * FACTOR - SNL(IK,ITH) = ( XNL(ITH,IK) + XTR(ITH,IK) ) * FACTOR - SDS(IK,ITH) = ( XDS(ITH,IK) + XDB(ITH,IK) ) * FACTOR + UABS = UABS * ASFAC +#endif + ! + DO IK=1, NK + FACTOR = TPI / CG(IK) * SIG(IK) + DO ITH=1, NTH + ISPEC = ITH + (IK-1)*NTH + E (IK,ITH) = SPCO(ISPEC,J) + SWI(IK,ITH) = ( XWI(ITH,IK) + XLN(ITH,IK) ) * FACTOR + SNL(IK,ITH) = ( XNL(ITH,IK) + XTR(ITH,IK) ) * FACTOR + SDS(IK,ITH) = ( XDS(ITH,IK) + XDB(ITH,IK) ) * FACTOR #ifdef W3_ST6 - SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) -#endif - SBT(IK,ITH) = ( XBT(ITH,IK) + XBS(ITH,IK) ) * FACTOR - SIS(IK,ITH) = XIS(ITH,IK) * FACTOR - STT(IK,ITH) = XXX(ITH,IK) * FACTOR - END DO - END DO - STT = STT + SWI + SNL + SDS + SBT + SIS - -! -! 4.a Perform output -! - IF ( FLSRCE(1) ) WRITE (NDSGRD) & - ((E (IK,ITH),ITH=1,NTH),IK=NK,1,-1) - IF ( FLSRCE(2) ) WRITE (NDSGRD) & - ((SWI(IK,ITH),ITH=1,NTH),IK=NK,1,-1) - IF ( FLSRCE(3) ) WRITE (NDSGRD) & - ((SNL(IK,ITH),ITH=1,NTH),IK=NK,1,-1) - IF ( FLSRCE(4) ) WRITE (NDSGRD) & - ((SDS(IK,ITH),ITH=1,NTH),IK=NK,1,-1) - IF ( FLSRCE(5) ) WRITE (NDSGRD) & - ((SBT(IK,ITH),ITH=1,NTH),IK=NK,1,-1) - IF ( FLSRCE(6) ) WRITE (NDSGRD) & - ((SIS(IK,ITH),ITH=1,NTH),IK=NK,1,-1) - IF ( FLSRCE(7) ) WRITE (NDSGRD) & - ((STT(IK,ITH),ITH=1,NTH),IK=NK,1,-1) -! - IF ( FLAGLL ) THEN - WRITE (NDSPNT,940) PTNME(J), & - FACT*PTLOC(1,J), FACT*PTLOC(2,J), DPO(J), WAO(J), & - WAO(J)*COS(WDO(J)), WAO(J)*SIN(WDO(J)), ASO(J), & - CAO(J), CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & - HSIG, GRDID(J) - ELSE - WRITE (NDSPNT,941) PTNME(J), & - FACT*PTLOC(1,J), FACT*PTLOC(2,J), DPO(J), WAO(J), & - WAO(J)*COS(WDO(J)), WAO(J)*SIN(WDO(J)), ASO(J), & - CAO(J), CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & - HSIG, GRDID(J) - END IF -! -! ... End of points loop -! - END IF + SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) +#endif + SBT(IK,ITH) = ( XBT(ITH,IK) + XBS(ITH,IK) ) * FACTOR + SIS(IK,ITH) = XIS(ITH,IK) * FACTOR + STT(IK,ITH) = XXX(ITH,IK) * FACTOR + END DO END DO -! - RETURN -! -! Formats -! - 905 FORMAT (9X,A) + STT = STT + SWI + SNL + SDS + SBT + SIS + + ! + ! 4.a Perform output + ! + IF ( FLSRCE(1) ) WRITE (NDSGRD) & + ((E (IK,ITH),ITH=1,NTH),IK=NK,1,-1) + IF ( FLSRCE(2) ) WRITE (NDSGRD) & + ((SWI(IK,ITH),ITH=1,NTH),IK=NK,1,-1) + IF ( FLSRCE(3) ) WRITE (NDSGRD) & + ((SNL(IK,ITH),ITH=1,NTH),IK=NK,1,-1) + IF ( FLSRCE(4) ) WRITE (NDSGRD) & + ((SDS(IK,ITH),ITH=1,NTH),IK=NK,1,-1) + IF ( FLSRCE(5) ) WRITE (NDSGRD) & + ((SBT(IK,ITH),ITH=1,NTH),IK=NK,1,-1) + IF ( FLSRCE(6) ) WRITE (NDSGRD) & + ((SIS(IK,ITH),ITH=1,NTH),IK=NK,1,-1) + IF ( FLSRCE(7) ) WRITE (NDSGRD) & + ((STT(IK,ITH),ITH=1,NTH),IK=NK,1,-1) + ! + IF ( FLAGLL ) THEN + WRITE (NDSPNT,940) PTNME(J), & + FACT*PTLOC(1,J), FACT*PTLOC(2,J), DPO(J), WAO(J), & + WAO(J)*COS(WDO(J)), WAO(J)*SIN(WDO(J)), ASO(J), & + CAO(J), CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & + HSIG, GRDID(J) + ELSE + WRITE (NDSPNT,941) PTNME(J), & + FACT*PTLOC(1,J), FACT*PTLOC(2,J), DPO(J), WAO(J), & + WAO(J)*COS(WDO(J)), WAO(J)*SIN(WDO(J)), ASO(J), & + CAO(J), CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & + HSIG, GRDID(J) + END IF + ! + ! ... End of points loop + ! + END IF + END DO + ! + RETURN + ! + ! Formats + ! +905 FORMAT (9X,A) - 940 FORMAT (A10,1X,2F6.1,f7.1,3F7.1,F8.2,3F7.2,F6.2,2X,A) +940 FORMAT (A10,1X,2F6.1,f7.1,3F7.1,F8.2,3F7.2,F6.2,2X,A) - 941 FORMAT (A10,1X,2F8.1,f7.1,3F7.1,F8.2,3F7.2,F6.2,2X,A) +941 FORMAT (A10,1X,2F8.1,f7.1,3F7.1,F8.2,3F7.2,F6.2,2X,A) -! + ! #ifdef W3_T - 9000 FORMAT (' TEST GXEXPO : FLAGS :',40L2) - 9001 FORMAT (' TEST GXEXPO : FLSRCE :',6L2) - 9002 FORMAT (' TEST GXEXPO : OUTPUT POINT : ',A) - 9010 FORMAT (' TEST GXEXPO : DEPTH =',F7.1,' IK, T, K, CG :') - 9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) -#endif -!/ -!/ End of GXEXPO ----------------------------------------------------- / -!/ - END SUBROUTINE GXEXPO -!/ -!/ End of GXOUTP ----------------------------------------------------- / -!/ - END PROGRAM GXOUTP +9000 FORMAT (' TEST GXEXPO : FLAGS :',40L2) +9001 FORMAT (' TEST GXEXPO : FLSRCE :',6L2) +9002 FORMAT (' TEST GXEXPO : OUTPUT POINT : ',A) +9010 FORMAT (' TEST GXEXPO : DEPTH =',F7.1,' IK, T, K, CG :') +9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#endif + !/ + !/ End of GXEXPO ----------------------------------------------------- / + !/ + END SUBROUTINE GXEXPO + !/ + !/ End of GXOUTP ----------------------------------------------------- / + !/ +END PROGRAM GXOUTP diff --git a/model/src/pdlib_field_vec.F90 b/model/src/pdlib_field_vec.F90 index 7365e5593..95c817d97 100644 --- a/model/src/pdlib_field_vec.F90 +++ b/model/src/pdlib_field_vec.F90 @@ -1,1735 +1,1734 @@ MODULE PDLIB_FIELD_VEC -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 01-Jan-2010 : Origination. ( version 6.04 ) -!/ 22-Mar-2021 : Add WNMEAN, TAUOC output ( version 7.13 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : Provides parallel I/O in context of PDLIB -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3XXXX Subr. Public ........ -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -! - SUBROUTINE GET_ARRAY_SIZE(TheSize) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Estimate arrays size for communication -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 01-Jan-2010 : Origination. ( version 6.04 ) + !/ 22-Mar-2021 : Add WNMEAN, TAUOC output ( version 7.13 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : Provides parallel I/O in context of PDLIB + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3XXXX Subr. Public ........ + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + ! + SUBROUTINE GET_ARRAY_SIZE(TheSize) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Estimate arrays size for communication + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE W3ODATMD, ONLY: FLOGRD, FLOGR2, NOSWLL, NOEXTR, & - NOGRP, NGRPP - USE W3GDATMD, ONLY: E3DF, P2MSF, NK - IMPLICIT NONE - INTEGER, INTENT(OUT) :: TheSize - LOGICAL :: FLGRDALL(NOGRP,NGRPP) - INTEGER IH, I, J, K, IK -!/ -!/ ------------------------------------------------------------------- / -!/ - DO J=1, NOGRP - DO K=1, NGRPP - FLGRDALL (J,K) = (FLOGRD(J,K) .OR. FLOGR2(J,K)) - END DO + ! + USE W3ODATMD, ONLY: FLOGRD, FLOGR2, NOSWLL, NOEXTR, & + NOGRP, NGRPP + USE W3GDATMD, ONLY: E3DF, P2MSF, NK + IMPLICIT NONE + INTEGER, INTENT(OUT) :: TheSize + LOGICAL :: FLGRDALL(NOGRP,NGRPP) + INTEGER IH, I, J, K, IK + !/ + !/ ------------------------------------------------------------------- / + !/ + DO J=1, NOGRP + DO K=1, NGRPP + FLGRDALL (J,K) = (FLOGRD(J,K) .OR. FLOGR2(J,K)) END DO - IH = 0 - IF ( FLGRDALL( 2, 1) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 2) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 3) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 4) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 5) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 6) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 7) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 8) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 9) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 10) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 11) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 12) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 13) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 14) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 15) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 16) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 17) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 2, 19) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 3, 1) ) THEN - DO IK=E3DF(2,1),E3DF(3,1) - IH = IH + 1 - END DO - END IF - IF ( FLGRDALL( 3, 2) ) THEN - DO IK=E3DF(2,2),E3DF(3,2) - IH = IH + 1 - END DO - END IF - IF ( FLGRDALL( 3, 3) ) THEN - DO IK=E3DF(2,3),E3DF(3,3) - IH = IH + 1 - END DO - END IF - IF ( FLGRDALL( 3, 4) ) THEN - DO IK=E3DF(2,4),E3DF(3,4) - IH = IH + 1 - END DO - END IF - IF ( FLGRDALL( 3, 5) ) THEN - DO IK=E3DF(2,5),E3DF(3,5) - IH = IH + 1 - END DO - END IF - IF ( FLGRDALL( 4, 1) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4, 2) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4, 3) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4, 4) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4, 5) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4, 6) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4, 7) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4, 8) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4, 9) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4,10) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4,11) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4,12) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4,13) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4,14) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4,15) ) THEN - IH = IH + NOSWLL + 1 - END IF - IF ( FLGRDALL( 4,16) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 4,17) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 5, 1) ) THEN - IH = IH + 1 - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 5, 2) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 5, 3) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 5, 4) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 5, 5) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 5, 6) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 5, 7) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 5, 8) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 5, 9) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 5,10) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 6, 1) ) THEN - IH = IH + 1 - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 6, 2) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 6, 3) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 6, 4) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 6, 5) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 6, 6) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 6, 7) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 6, 8) ) THEN - DO IK=1,2*NK - IH = IH + 1 - END DO - END IF - IF ( FLGRDALL( 6, 9) ) THEN - DO K=P2MSF(2),P2MSF(3) - IH = IH + 1 - END DO - END IF - IF ( FLGRDALL( 6, 10) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 6, 11) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 6, 13) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 7, 1) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 7, 2) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 7, 3) ) THEN - IH = IH + 1 - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 7, 4) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 7, 5) ) THEN - IH = IH + 1 + END DO + IH = 0 + IF ( FLGRDALL( 2, 1) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 2) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 3) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 4) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 5) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 6) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 7) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 8) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 9) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 10) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 11) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 12) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 13) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 14) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 15) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 16) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 17) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 2, 19) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 3, 1) ) THEN + DO IK=E3DF(2,1),E3DF(3,1) IH = IH + 1 - END IF - IF ( FLGRDALL( 8, 1) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 8, 2) ) THEN - IH = IH + 1 - IH = IH + 1 - END IF - IF ( FLGRDALL( 8, 3) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 8, 4) ) THEN - IH = IH + 1 - END IF - IF ( FLGRDALL( 8, 5) ) THEN + END DO + END IF + IF ( FLGRDALL( 3, 2) ) THEN + DO IK=E3DF(2,2),E3DF(3,2) IH = IH + 1 - END IF - IF ( FLGRDALL( 9, 1) ) THEN + END DO + END IF + IF ( FLGRDALL( 3, 3) ) THEN + DO IK=E3DF(2,3),E3DF(3,3) IH = IH + 1 - END IF - IF ( FLGRDALL( 9, 2) ) THEN + END DO + END IF + IF ( FLGRDALL( 3, 4) ) THEN + DO IK=E3DF(2,4),E3DF(3,4) IH = IH + 1 - END IF - IF ( FLGRDALL( 9, 3) ) THEN + END DO + END IF + IF ( FLGRDALL( 3, 5) ) THEN + DO IK=E3DF(2,5),E3DF(3,5) IH = IH + 1 - END IF - IF ( FLGRDALL( 9, 4) ) THEN + END DO + END IF + IF ( FLGRDALL( 4, 1) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4, 2) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4, 3) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4, 4) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4, 5) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4, 6) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4, 7) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4, 8) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4, 9) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4,10) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4,11) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4,12) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4,13) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4,14) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4,15) ) THEN + IH = IH + NOSWLL + 1 + END IF + IF ( FLGRDALL( 4,16) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 4,17) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 5, 1) ) THEN + IH = IH + 1 + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 5, 2) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 5, 3) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 5, 4) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 5, 5) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 5, 6) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 5, 7) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 5, 8) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 5, 9) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 5,10) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 6, 1) ) THEN + IH = IH + 1 + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 6, 2) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 6, 3) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 6, 4) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 6, 5) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 6, 6) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 6, 7) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 6, 8) ) THEN + DO IK=1,2*NK IH = IH + 1 - END IF - IF ( FLGRDALL( 9, 5) ) THEN + END DO + END IF + IF ( FLGRDALL( 6, 9) ) THEN + DO K=P2MSF(2),P2MSF(3) IH = IH + 1 - END IF - DO I=1, NOEXTR - IF ( FLGRDALL(10, I) ) THEN - IH = IH + 1 - END IF END DO - TheSize=IH + END IF + IF ( FLGRDALL( 6, 10) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 6, 11) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 6, 13) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 7, 1) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 7, 2) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 7, 3) ) THEN + IH = IH + 1 + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 7, 4) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 7, 5) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 8, 1) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 8, 2) ) THEN + IH = IH + 1 + IH = IH + 1 + END IF + IF ( FLGRDALL( 8, 3) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 8, 4) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 8, 5) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 9, 1) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 9, 2) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 9, 3) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 9, 4) ) THEN + IH = IH + 1 + END IF + IF ( FLGRDALL( 9, 5) ) THEN + IH = IH + 1 + END IF + DO I=1, NOEXTR + IF ( FLGRDALL(10, I) ) THEN + IH = IH + 1 + END IF + END DO + TheSize=IH END SUBROUTINE GET_ARRAY_SIZE -!/ ------------------------------------------------------------------- / - SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : PDLIB read from file -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : PDLIB read from file + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! - use yowDatapool, only: istatus - USE W3GDATMD, only : NSEA, NSPEC - USE W3ODATMD, only : NAPROC, NTPROC, IAPROC - USE W3ADATMD, only : MPI_COMM_WAVE - USE W3PARALL, only : GET_JSEA_IBELONG - USE W3WDATMD, ONLY : VA - USE W3GDATMD, ONLY: NSEAL - USE W3ADATMD, ONLY: NSEALM - USE W3SERVMD, ONLY : EXTCDE + use yowDatapool, only: istatus + USE W3GDATMD, only : NSEA, NSPEC + USE W3ODATMD, only : NAPROC, NTPROC, IAPROC + USE W3ADATMD, only : MPI_COMM_WAVE + USE W3PARALL, only : GET_JSEA_IBELONG + USE W3WDATMD, ONLY : VA + USE W3GDATMD, ONLY: NSEAL + USE W3ADATMD, ONLY: NSEALM + USE W3SERVMD, ONLY : EXTCDE #ifdef W3_TIMINGS - USE W3PARALL, ONLY: PRINT_MY_TIME + USE W3PARALL, ONLY: PRINT_MY_TIME #endif - use yowNodepool, only: ListNP, ListNPA, ListIPLG - IMPLICIT NONE - INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + use yowNodepool, only: ListNP, ListNPA, ListIPLG + IMPLICIT NONE + INCLUDE "mpif.h" + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -! - INTEGER, intent(in) :: NDREAD - INTEGER iBlock, iFirst, iEnd, len, i, IB, iProc - INTEGER NREC, ISEA, JSEA, ierr - INTEGER nbBlock, IBELONG - INTEGER :: BlockSize - REAL, allocatable :: ArrSend(:,:) - REAL, allocatable :: DataRead(:,:) - integer(KIND=8) RPOS - integer LRECL - INTEGER, PARAMETER :: LRB = 4 - INTEGER NBLKRSloc, RSBLKSloc - integer eArr(1) - integer IERR_MPI, istat - integer IPloc, IPglob, pos - integer NbMatch, idx - integer ListFirst(NAPROC) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + INTEGER, intent(in) :: NDREAD + INTEGER iBlock, iFirst, iEnd, len, i, IB, iProc + INTEGER NREC, ISEA, JSEA, ierr + INTEGER nbBlock, IBELONG + INTEGER :: BlockSize + REAL, allocatable :: ArrSend(:,:) + REAL, allocatable :: DataRead(:,:) + integer(KIND=8) RPOS + integer LRECL + INTEGER, PARAMETER :: LRB = 4 + INTEGER NBLKRSloc, RSBLKSloc + integer eArr(1) + integer IERR_MPI, istat + integer IPloc, IPglob, pos + integer NbMatch, idx + integer ListFirst(NAPROC) #ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') + CALL STRACE (IENT, 'VA_SETUP_IOBPD') #endif - ! - LRECL = MAX ( LRB*NSPEC , & - LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) - IF (IAPROC .gt. NAPROC) THEN - RETURN - END IF - ListFirst(1)=0 - DO iProc=2,NAPROC - ListFirst(iProc) = ListFirst(iProc-1) + ListNPA(iProc-1) - END DO - NBLKRSloc = 10 - RSBLKSloc = MAX ( 5 , NSEALM/NBLKRSloc ) - IF ( NBLKRSloc*RSBLKSloc .LT. NSEALM ) RSBLKSloc = RSBLKSloc + 1 - NBLKRSloc = 1 + (NSEALM-1)/RSBLKSloc - BLOCKSIZE = INT(REAL(NSEA)/REAL(NBLKRSloc)) - ! - nbBlock=NSEA / BlockSize - IF (nbBlock * BlockSize .lt. NSEA) THEN - nbBlock=nbBlock+1 - END IF - IF (IAPROC .eq. 1) THEN - allocate(DATAread(NSPEC,BlockSize)) - DATAread = 0. - END IF - DO iBlock=1,nbBlock - iFirst = 1 + (iBlock - 1)*BlockSize - iEnd = MIN(iBlock * BlockSize, NSEA) + ! + LRECL = MAX ( LRB*NSPEC , & + LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) + IF (IAPROC .gt. NAPROC) THEN + RETURN + END IF + ListFirst(1)=0 + DO iProc=2,NAPROC + ListFirst(iProc) = ListFirst(iProc-1) + ListNPA(iProc-1) + END DO + NBLKRSloc = 10 + RSBLKSloc = MAX ( 5 , NSEALM/NBLKRSloc ) + IF ( NBLKRSloc*RSBLKSloc .LT. NSEALM ) RSBLKSloc = RSBLKSloc + 1 + NBLKRSloc = 1 + (NSEALM-1)/RSBLKSloc + BLOCKSIZE = INT(REAL(NSEA)/REAL(NBLKRSloc)) + ! + nbBlock=NSEA / BlockSize + IF (nbBlock * BlockSize .lt. NSEA) THEN + nbBlock=nbBlock+1 + END IF + IF (IAPROC .eq. 1) THEN + allocate(DATAread(NSPEC,BlockSize)) + DATAread = 0. + END IF + DO iBlock=1,nbBlock + iFirst = 1 + (iBlock - 1)*BlockSize + iEnd = MIN(iBlock * BlockSize, NSEA) #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Beginning of iBlock value treatment") + CALL PRINT_MY_TIME("Beginning of iBlock value treatment") #endif -! Let's try to get the indexes right. -! We have 1 <= IB <= len = iEnd + 1 - iFirst -! We have iFirst - 1 = (iBlock - 1)*BlockSize -! and so iFirst <= IB + (iBlock - 1)*BlockSize <= iEnd -! and thus iFirst <= ISEA <= iEnd - len=iEnd + 1 - iFirst - IF (IAPROC .eq. 1) THEN -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before data reading") -#endif - DO IB=1,len - ISEA = (iBlock - 1)*BlockSize + IB - NREC = ISEA + 2 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDREAD, POS=RPOS, IOSTAT=IERR) (DATAread(I,IB), I=1,NSPEC) - END DO + ! Let's try to get the indexes right. + ! We have 1 <= IB <= len = iEnd + 1 - iFirst + ! We have iFirst - 1 = (iBlock - 1)*BlockSize + ! and so iFirst <= IB + (iBlock - 1)*BlockSize <= iEnd + ! and thus iFirst <= ISEA <= iEnd + len=iEnd + 1 - iFirst + IF (IAPROC .eq. 1) THEN #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After data reading") + CALL PRINT_MY_TIME("Before data reading") #endif - DO iProc=2,NAPROC - NbMatch=0 - DO IPloc=1,ListNPA(iProc) - IPglob = ListIPLG(ListFirst(iProc) + IPloc) - IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN - NbMatch = NbMatch+1 - END IF - END DO - IF (NbMatch .gt. 0) THEN - allocate(ArrSend(NSPEC,NbMatch), stat=istat) - ArrSend = 0. - idx=0 - DO IPloc=1,ListNPA(iProc) - IPglob = ListIPLG(ListFirst(iProc) + IPloc) - IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN - pos = IPglob - iFirst + 1 - idx = idx + 1 - ArrSend(:,idx) = DATAread(:,pos) - END IF - END DO - CALL MPI_SEND(ArrSend,NSPEC*NbMatch,MPI_REAL, iProc-1, 37, MPI_COMM_WAVE, ierr) - deallocate(ArrSend) - END IF - END DO - DO IPloc=1,ListNPA(1) - IPglob = ListIPLG(IPloc) - IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN - pos = IPglob - iFirst + 1 - VA(:,IPloc) = DATAread(:,pos) - END IF - END DO + DO IB=1,len + ISEA = (iBlock - 1)*BlockSize + IB + NREC = ISEA + 2 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDREAD, POS=RPOS, IOSTAT=IERR) (DATAread(I,IB), I=1,NSPEC) + END DO #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After the sending") + CALL PRINT_MY_TIME("After data reading") #endif - ELSE + DO iProc=2,NAPROC NbMatch=0 - DO IPloc=1,ListNPA(IAPROC) - IPglob = ListIPLG(ListFirst(IAPROC) + IPloc) + DO IPloc=1,ListNPA(iProc) + IPglob = ListIPLG(ListFirst(iProc) + IPloc) IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN NbMatch = NbMatch+1 END IF END DO IF (NbMatch .gt. 0) THEN allocate(ArrSend(NSPEC,NbMatch), stat=istat) - CALL MPI_RECV(ArrSend,NSPEC*NbMatch,MPI_REAL, 0, 37, MPI_COMM_WAVE, istatus, ierr) + ArrSend = 0. idx=0 - DO IPloc=1,ListNPA(IAPROC) - IPglob = ListIPLG(ListFirst(IAPROC) + IPloc) + DO IPloc=1,ListNPA(iProc) + IPglob = ListIPLG(ListFirst(iProc) + IPloc) IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN + pos = IPglob - iFirst + 1 idx = idx + 1 - VA(:,IPloc) = ArrSend(:,idx) + ArrSend(:,idx) = DATAread(:,pos) END IF END DO + CALL MPI_SEND(ArrSend,NSPEC*NbMatch,MPI_REAL, iProc-1, 37, MPI_COMM_WAVE, ierr) deallocate(ArrSend) END IF - END IF + END DO + DO IPloc=1,ListNPA(1) + IPglob = ListIPLG(IPloc) + IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN + pos = IPglob - iFirst + 1 + VA(:,IPloc) = DATAread(:,pos) + END IF + END DO #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Beginning of iBlock value treatment") + CALL PRINT_MY_TIME("After the sending") #endif - END DO - IF (IAPROC .eq. 1) THEN - deallocate(DATAread) + ELSE + NbMatch=0 + DO IPloc=1,ListNPA(IAPROC) + IPglob = ListIPLG(ListFirst(IAPROC) + IPloc) + IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN + NbMatch = NbMatch+1 + END IF + END DO + IF (NbMatch .gt. 0) THEN + allocate(ArrSend(NSPEC,NbMatch), stat=istat) + CALL MPI_RECV(ArrSend,NSPEC*NbMatch,MPI_REAL, 0, 37, MPI_COMM_WAVE, istatus, ierr) + idx=0 + DO IPloc=1,ListNPA(IAPROC) + IPglob = ListIPLG(ListFirst(IAPROC) + IPloc) + IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN + idx = idx + 1 + VA(:,IPloc) = ArrSend(:,idx) + END IF + END DO + deallocate(ArrSend) + END IF END IF +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Beginning of iBlock value treatment") +#endif + END DO + IF (IAPROC .eq. 1) THEN + deallocate(DATAread) + END IF END SUBROUTINE UNST_PDLIB_READ_FROM_FILE -!/ ------------------------------------------------------------------- / - SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : PDLIB write to file -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : PDLIB write to file + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - use yowDatapool, only: istatus - USE yowNodepool, only: ListNP, ListNPA, ListIPLG - USE W3PARALL, ONLY: INIT_GET_ISEA - USE W3GDATMD, only : NSEA, NSPEC - USE W3ODATMD, only : NAPROC, NTPROC, NAPRST, IAPROC - USE W3ADATMD, only : MPI_COMM_WAVE - USE W3PARALL, only : GET_JSEA_IBELONG - USE W3WDATMD, ONLY : VA - USE W3GDATMD, ONLY: NSEAL, NX, NY - IMPLICIT NONE - INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + ! + use yowDatapool, only: istatus + USE yowNodepool, only: ListNP, ListNPA, ListIPLG + USE W3PARALL, ONLY: INIT_GET_ISEA + USE W3GDATMD, only : NSEA, NSPEC + USE W3ODATMD, only : NAPROC, NTPROC, NAPRST, IAPROC + USE W3ADATMD, only : MPI_COMM_WAVE + USE W3PARALL, only : GET_JSEA_IBELONG + USE W3WDATMD, ONLY : VA + USE W3GDATMD, ONLY: NSEAL, NX, NY + IMPLICIT NONE + INCLUDE "mpif.h" + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -! - INTEGER, intent(in) :: NDWRITE - INTEGER, PARAMETER :: BlockSize = 100000 - REAL :: DATAwrite(NSPEC,BlockSize) - REAL, allocatable :: DATArecv(:,:) - integer ListFirst(NAPROC) - integer idx, idxB - integer len, i, IS - integer iBlock, iFirst, iEnd - integer IPglob, IPloc, pos, ISEA, nbBlock, NPAloc - integer ierr, istat, JSEA, NREC, iProc - integer NbMatch - INTEGER, PARAMETER :: LRB = 4 - INTEGER(KIND=8) RPOS - INTEGER LRECL - INTEGER IERR_MPI - REAL(KIND=LRB) WRITEBUFF(NSPEC) - REAL, allocatable :: DATAsend(:,:) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + INTEGER, intent(in) :: NDWRITE + INTEGER, PARAMETER :: BlockSize = 100000 + REAL :: DATAwrite(NSPEC,BlockSize) + REAL, allocatable :: DATArecv(:,:) + integer ListFirst(NAPROC) + integer idx, idxB + integer len, i, IS + integer iBlock, iFirst, iEnd + integer IPglob, IPloc, pos, ISEA, nbBlock, NPAloc + integer ierr, istat, JSEA, NREC, iProc + integer NbMatch + INTEGER, PARAMETER :: LRB = 4 + INTEGER(KIND=8) RPOS + INTEGER LRECL + INTEGER IERR_MPI + REAL(KIND=LRB) WRITEBUFF(NSPEC) + REAL, allocatable :: DATAsend(:,:) #ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') + CALL STRACE (IENT, 'VA_SETUP_IOBPD') #endif - ListFirst(1) = 0 - DO IPROC=2,NAPROC - ListFirst(iProc)=ListFirst(iProc-1) + ListNPA(iProc-1) - END DO - ! - LRECL = MAX ( LRB*NSPEC , & - LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) - nbBlock=NSEA / BlockSize + 1 - DO iBlock=1,nbBlock - iFirst= 1 + (iBlock - 1)*BlockSize - iEnd= MIN(iBlock * BlockSize, NSEA) - len=iEnd + 1 - iFirst - IF (IAPROC .eq. NAPRST) THEN - IF (IAPROC .le. NAPROC) THEN - DO JSEA=1,NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IF ((iFirst .le. ISEA).and.(ISEA .le. iEnd)) THEN - idx = ISEA - iFirst + 1 - DATAwrite(:, idx) = VA(:, JSEA) - END IF - END DO - END IF - DO iProc=1,NAPROC - IF (iProc .ne. IAPROC) THEN - NPAloc=ListNPA(iProc) - NbMatch=0 - DO IPloc=1,NPAloc - IPglob = ListIPLG(ListFirst(iProc) + IPloc) - IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN - NbMatch=NbMatch+1 - END IF - END DO - IF (NbMatch .gt. 0) THEN - allocate(DATArecv(NSPEC, NbMatch), stat=istat) - CALL MPI_RECV(DATArecv,NSPEC*NbMatch,MPI_REAL, iProc-1, 101, MPI_COMM_WAVE, istatus, ierr) - idx=0 - DO IPloc=1,NPAloc - IPglob = ListIPLG(IPloc + ListFirst(iProc)) - ISEA = IPglob ! Great ansatz here. False in general - IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN - idx=idx+1 - pos = IPglob - iFirst + 1 - DATAwrite(:, pos) = DATArecv(:, idx) - END IF - END DO - deallocate(DATArecv, stat=istat) - END IF + ListFirst(1) = 0 + DO IPROC=2,NAPROC + ListFirst(iProc)=ListFirst(iProc-1) + ListNPA(iProc-1) + END DO + ! + LRECL = MAX ( LRB*NSPEC , & + LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) + nbBlock=NSEA / BlockSize + 1 + DO iBlock=1,nbBlock + iFirst= 1 + (iBlock - 1)*BlockSize + iEnd= MIN(iBlock * BlockSize, NSEA) + len=iEnd + 1 - iFirst + IF (IAPROC .eq. NAPRST) THEN + IF (IAPROC .le. NAPROC) THEN + DO JSEA=1,NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IF ((iFirst .le. ISEA).and.(ISEA .le. iEnd)) THEN + idx = ISEA - iFirst + 1 + DATAwrite(:, idx) = VA(:, JSEA) END IF END DO - DO ISEA=iFirst,iEnd - idx = ISEA - iFirst + 1 - NREC = ISEA + 2 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITEBUFF(:) = 0 - WRITEBUFF(1:NSPEC) = DATAwrite(1:NSPEC, idx) - WRITE(NDWRITE, POS=RPOS) WRITEBUFF - END DO - ELSE - IF (IAPROC .le. NAPROC) THEN + END IF + DO iProc=1,NAPROC + IF (iProc .ne. IAPROC) THEN + NPAloc=ListNPA(iProc) NbMatch=0 - DO IPloc=1,ListNPA(IAPROC) - IPglob = ListIPLG(ListFirst(IAPROC) + IPloc) + DO IPloc=1,NPAloc + IPglob = ListIPLG(ListFirst(iProc) + IPloc) IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN NbMatch=NbMatch+1 END IF END DO IF (NbMatch .gt. 0) THEN - allocate(DATAsend(NSPEC,NbMatch), stat=istat) + allocate(DATArecv(NSPEC, NbMatch), stat=istat) + CALL MPI_RECV(DATArecv,NSPEC*NbMatch,MPI_REAL, iProc-1, 101, MPI_COMM_WAVE, istatus, ierr) idx=0 - DO IPloc=1,ListNPA(IAPROC) - IPglob = ListIPLG(ListFirst(IAPROC) + IPloc) + DO IPloc=1,NPAloc + IPglob = ListIPLG(IPloc + ListFirst(iProc)) + ISEA = IPglob ! Great ansatz here. False in general IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN - idx=idx + 1 - DATAsend(:,idx)=VA(:,IPloc) + idx=idx+1 + pos = IPglob - iFirst + 1 + DATAwrite(:, pos) = DATArecv(:, idx) END IF END DO - CALL MPI_SEND(DATAsend,NSPEC*NbMatch,MPI_REAL, NAPRST-1, 101, MPI_COMM_WAVE, ierr) - deallocate(DATAsend, stat=istat) + deallocate(DATArecv, stat=istat) + END IF + END IF + END DO + DO ISEA=iFirst,iEnd + idx = ISEA - iFirst + 1 + NREC = ISEA + 2 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITEBUFF(:) = 0 + WRITEBUFF(1:NSPEC) = DATAwrite(1:NSPEC, idx) + WRITE(NDWRITE, POS=RPOS) WRITEBUFF + END DO + ELSE + IF (IAPROC .le. NAPROC) THEN + NbMatch=0 + DO IPloc=1,ListNPA(IAPROC) + IPglob = ListIPLG(ListFirst(IAPROC) + IPloc) + IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN + NbMatch=NbMatch+1 END IF + END DO + IF (NbMatch .gt. 0) THEN + allocate(DATAsend(NSPEC,NbMatch), stat=istat) + idx=0 + DO IPloc=1,ListNPA(IAPROC) + IPglob = ListIPLG(ListFirst(IAPROC) + IPloc) + IF ((iFirst .le. IPglob).and.(IPglob .le. iEnd)) THEN + idx=idx + 1 + DATAsend(:,idx)=VA(:,IPloc) + END IF + END DO + CALL MPI_SEND(DATAsend,NSPEC*NbMatch,MPI_REAL, NAPRST-1, 101, MPI_COMM_WAVE, ierr) + deallocate(DATAsend, stat=istat) END IF END IF - END DO + END IF + END DO END SUBROUTINE UNST_PDLIB_WRITE_TO_FILE -!/ ------------------------------------------------------------------- / - SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ 22-Mar-2021 : Add WNMEAN, TAUOC output ( version 7.13 ) -!/ -! 1. Purpose : Do communication for PDLIB output -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! - USE W3ADATMD, ONLY: W3XDMA, W3SETA, W3XETA - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY: NSEA - USE W3GDATMD, ONLY: NX, NSPEC, MAPFS, E3DF, P2MSF, US3DF - USE W3WDATMD, ONLY: VA, UST, USTDIR, ASF, FPIS - USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC - USE W3ADATMD, ONLY: HS, WLM, T02 - USE W3ADATMD, ONLY: T0M1, THM, THS, FP0, THP0, & - DTDYN, FCUT, SPPNT, ABA, ABD, UBA, UBD,& - SXX, SYY, SXY, USERO, PHS, PTP, PLP, & - PDIR, PSI, PWS, PWST, PNR, PHIAW, & - PHIOC, TAUOCX, TAUOCY, WNMEAN, & - TUSX, TUSY, TAUWIX, TAUWIY, TAUOX, & - TAUOY, USSX, USSY, MSSX, MSSY, & - MSCX, MSCY, PRMS, TPMS, CHARN, & - TAUWNX, TAUWNY, BHD, CGE, & - CFLXYMAX, CFLTHMAX, CFLKMAX, WHITECAP, & - BEDFORMS, PHIBBL, TAUBBL, T01, & - P2SMS, US3D, EF, TH1M, STH1M, TH2M, & - STH2M, HSIG, TAUICE, PHICE, PTHP0, PQP,& - PPE, PGW, PSW, PTM1, PT1, PT2, PEP, & - QP, MSSD, MSCD, STMAXE, STMAXD, HMAXE, & - HCMAXE, HMAXD, HCMAXD, WBT - USE W3GDATMD, ONLY: NK, NSEAL - USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NTPROC, FLOUT, & - NAPFLD, NAPPNT, NAPRST, NAPBPT, NAPTRK,& - NOGRP, NGRPP - USE W3ODATMD, ONLY: OUTPTS, NRQGO, NRQGO2, IRQGO, IRQGO2, & - FLOGRD, NRQPO, NRQPO2, IRQPO1, IRQPO2, & - NOPTS, IPTINT, NRQRS, IRQRS, NBLKRS, & - RSBLKS, IRQRSS, VAAUX, NRQBP, NRQBP2, & - IRQBP1, IRQBP2, NFBPO, NBO2, ISBPO, & - ABPOS, NRQTR, IRQTR, IT0PNT, IT0TRK, & - IT0PRT, NOSWLL, NOEXTR, NDSE, IOSTYP, & - FLOGR2 - USE W3ADATMD, ONLY: MPI_COMM_WCMP - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC - USE W3PARALL, ONLY: INIT_GET_ISEA - use yowDatapool, only: istatus -!/ - IMPLICIT NONE -! - INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IK, IFJ - INTEGER :: IH, IT0, IROOT, IT, IERR, I0, & - IFROM, IX(4), IY(4), IS(4), & - IP(4), I, J, JSEA, ITARG, IB, & - JSEA0, JSEAN, NSEAB, IBOFF, & - ISEA, ISPROC, K, NRQMAX + !/ ------------------------------------------------------------------- / + SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ 22-Mar-2021 : Add WNMEAN, TAUOC output ( version 7.13 ) + !/ + ! 1. Purpose : Do communication for PDLIB output + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + USE W3ADATMD, ONLY: W3XDMA, W3SETA, W3XETA + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY: NSEA + USE W3GDATMD, ONLY: NX, NSPEC, MAPFS, E3DF, P2MSF, US3DF + USE W3WDATMD, ONLY: VA, UST, USTDIR, ASF, FPIS + USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC + USE W3ADATMD, ONLY: HS, WLM, T02 + USE W3ADATMD, ONLY: T0M1, THM, THS, FP0, THP0, & + DTDYN, FCUT, SPPNT, ABA, ABD, UBA, UBD,& + SXX, SYY, SXY, USERO, PHS, PTP, PLP, & + PDIR, PSI, PWS, PWST, PNR, PHIAW, & + PHIOC, TAUOCX, TAUOCY, WNMEAN, & + TUSX, TUSY, TAUWIX, TAUWIY, TAUOX, & + TAUOY, USSX, USSY, MSSX, MSSY, & + MSCX, MSCY, PRMS, TPMS, CHARN, & + TAUWNX, TAUWNY, BHD, CGE, & + CFLXYMAX, CFLTHMAX, CFLKMAX, WHITECAP, & + BEDFORMS, PHIBBL, TAUBBL, T01, & + P2SMS, US3D, EF, TH1M, STH1M, TH2M, & + STH2M, HSIG, TAUICE, PHICE, PTHP0, PQP,& + PPE, PGW, PSW, PTM1, PT1, PT2, PEP, & + QP, MSSD, MSCD, STMAXE, STMAXD, HMAXE, & + HCMAXE, HMAXD, HCMAXD, WBT + USE W3GDATMD, ONLY: NK, NSEAL + USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NTPROC, FLOUT, & + NAPFLD, NAPPNT, NAPRST, NAPBPT, NAPTRK,& + NOGRP, NGRPP + USE W3ODATMD, ONLY: OUTPTS, NRQGO, NRQGO2, IRQGO, IRQGO2, & + FLOGRD, NRQPO, NRQPO2, IRQPO1, IRQPO2, & + NOPTS, IPTINT, NRQRS, IRQRS, NBLKRS, & + RSBLKS, IRQRSS, VAAUX, NRQBP, NRQBP2, & + IRQBP1, IRQBP2, NFBPO, NBO2, ISBPO, & + ABPOS, NRQTR, IRQTR, IT0PNT, IT0TRK, & + IT0PRT, NOSWLL, NOEXTR, NDSE, IOSTYP, & + FLOGR2 + USE W3ADATMD, ONLY: MPI_COMM_WCMP + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC + USE W3PARALL, ONLY: INIT_GET_ISEA + use yowDatapool, only: istatus + !/ + IMPLICIT NONE + ! + INCLUDE "mpif.h" + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IK, IFJ + INTEGER :: IH, IT0, IROOT, IT, IERR, I0, & + IFROM, IX(4), IY(4), IS(4), & + IP(4), I, J, JSEA, ITARG, IB, & + JSEA0, JSEAN, NSEAB, IBOFF, & + ISEA, ISPROC, K, NRQMAX #ifdef W3_S - INTEGER, SAVE :: IENT + INTEGER, SAVE :: IENT #endif - LOGICAL :: FLGRDALL(NOGRP,NGRPP) - REAL, allocatable :: ARRexch(:,:), ARRexch_loc(:,:) - REAL, allocatable :: ARRtotal(:,:) - INTEGER, allocatable :: ARRpos(:), ARRpos_loc(:) - INTEGER :: eEnt(1), IPROC - INTEGER :: TheSize, NSEAL_loc - INTEGER, SAVE :: indexOutput -!/ -!/ ------------------------------------------------------------------- / -!/ - DO J=1, NOGRP - DO K=1, NGRPP - FLGRDALL (J,K) = (FLOGRD(J,K) .OR. FLOGR2(J,K)) - END DO + LOGICAL :: FLGRDALL(NOGRP,NGRPP) + REAL, allocatable :: ARRexch(:,:), ARRexch_loc(:,:) + REAL, allocatable :: ARRtotal(:,:) + INTEGER, allocatable :: ARRpos(:), ARRpos_loc(:) + INTEGER :: eEnt(1), IPROC + INTEGER :: TheSize, NSEAL_loc + INTEGER, SAVE :: indexOutput + !/ + !/ ------------------------------------------------------------------- / + !/ + DO J=1, NOGRP + DO K=1, NGRPP + FLGRDALL (J,K) = (FLOGRD(J,K) .OR. FLOGR2(J,K)) END DO - NRQGO = 0 - NRQGO2 = 0 - IT0 = NSPEC - IROOT = NAPFLD - 1 - IF ( FLOUT(1) .OR. FLOUT(7) ) THEN - CALL GET_ARRAY_SIZE(TheSize) - IF ( IAPROC .LE. NAPROC ) THEN - allocate(ARRexch(TheSize, NSEAL), ARRpos(NSEAL)) - DO JSEA=1,NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - ARRpos(JSEA)=ISEA - IH = 0 - IF ( FLGRDALL( 2, 1) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=HS(JSEA) - END IF - IF ( FLGRDALL( 2, 2) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=WLM(JSEA) - END IF - IF ( FLGRDALL( 2, 3) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=T02(JSEA) - END IF - IF ( FLGRDALL( 2, 4) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=T0M1(JSEA) - END IF - IF ( FLGRDALL( 2, 5) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=T01(JSEA) - END IF - IF ( FLGRDALL( 2, 6) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=FP0(JSEA) - END IF - IF ( FLGRDALL( 2, 7) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=THM(JSEA) - END IF - IF ( FLGRDALL( 2, 8) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=THS(JSEA) - END IF - IF ( FLGRDALL( 2, 9) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=THP0(JSEA) - END IF - IF ( FLGRDALL( 2, 10) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=HSIG(JSEA) - END IF - IF ( FLGRDALL( 2, 11) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=STMAXE(JSEA) - END IF - IF ( FLGRDALL( 2, 12) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=STMAXD(JSEA) - END IF - IF ( FLGRDALL( 2, 13) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=HMAXE(JSEA) - END IF - IF ( FLGRDALL( 2, 14) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=HCMAXE(JSEA) - END IF - IF ( FLGRDALL( 2, 15) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=HMAXD(JSEA) - END IF - IF ( FLGRDALL( 2, 16) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=HCMAXD(JSEA) - END IF - IF ( FLGRDALL( 2, 17) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=WBT(JSEA) - END IF - IF ( FLGRDALL( 2, 19) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=WNMEAN(JSEA) - END IF - IF ( FLGRDALL( 3, 1) ) THEN - DO IK=E3DF(2,1),E3DF(3,1) - IH = IH + 1 - Arrexch(IH,JSEA)=EF(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 3, 2) ) THEN - DO IK=E3DF(2,2),E3DF(3,2) - IH = IH + 1 - Arrexch(IH,JSEA)=TH1M(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 3, 3) ) THEN - DO IK=E3DF(2,3),E3DF(3,3) - IH = IH + 1 - Arrexch(IH,JSEA)=STH1M(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 3, 4) ) THEN - DO IK=E3DF(2,4),E3DF(3,4) - IH = IH + 1 - Arrexch(IH,JSEA)=TH2M(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 3, 5) ) THEN - DO IK=E3DF(2,5),E3DF(3,5) - IH = IH + 1 - Arrexch(IH,JSEA)=STH2M(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4, 1) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PHS(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4, 2) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PTP(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4, 3) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PLP(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4, 4) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PDIR(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4, 5) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PSI(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4, 6) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PWS(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4, 7) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PTHP0(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4, 8) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PQP(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4, 9) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PPE(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4,10) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PGW(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4,11) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PSW(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4,12) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PTM1(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4,13) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PT1(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4,14) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PT2(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4,15) ) THEN - DO IK=0, NOSWLL - IH = IH + 1 - Arrexch(IH,JSEA)=PEP(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 4,16) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=PWST(JSEA) - END IF - IF ( FLGRDALL( 4,17) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=PNR(JSEA) - END IF - IF ( FLGRDALL( 5, 1) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=UST(JSEA) - IH = IH + 1 - Arrexch(IH,JSEA)=USTDIR(JSEA) - IH = IH + 1 - Arrexch(IH,JSEA)=ASF(JSEA) - END IF - IF ( FLGRDALL( 5, 2) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=CHARN(JSEA) - END IF - IF ( FLGRDALL( 5, 3) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=CGE(JSEA) - END IF - IF ( FLGRDALL( 5, 4) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=PHIAW(JSEA) - END IF - IF ( FLGRDALL( 5, 5) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=TAUWIX(JSEA) - IH = IH + 1 - Arrexch(IH,JSEA)=TAUWIY(JSEA) - END IF - IF ( FLGRDALL( 5, 6) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=TAUWNX(JSEA) - IH = IH + 1 - Arrexch(IH,JSEA)=TAUWNY(JSEA) - END IF - IF ( FLGRDALL( 5, 7) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=WHITECAP(JSEA,1) - END IF - IF ( FLGRDALL( 5, 8) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=WHITECAP(JSEA,2) - END IF - IF ( FLGRDALL( 5, 9) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=WHITECAP(JSEA,3) - END IF - IF ( FLGRDALL( 5,10) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=WHITECAP(JSEA,4) - END IF - IF ( FLGRDALL( 6, 1) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=SXX(JSEA) - IH = IH + 1 - Arrexch(IH,JSEA)=SYY(JSEA) - IH = IH + 1 - Arrexch(IH,JSEA)=SXY(JSEA) - END IF - IF ( FLGRDALL( 6, 2) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=TAUOX(JSEA) - IH = IH + 1 - Arrexch(IH,JSEA)=TAUOY(JSEA) - END IF - IF ( FLGRDALL( 6, 3) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=BHD(JSEA) - END IF - IF ( FLGRDALL( 6, 4) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=PHIOC(JSEA) - END IF - IF ( FLGRDALL( 6, 5) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=TUSX(JSEA) - IH = IH + 1 - Arrexch(IH,JSEA)=TUSY(JSEA) - END IF - IF ( FLGRDALL( 6, 6) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=USSX(JSEA) - IH = IH + 1 - Arrexch(IH,JSEA)=USSY(JSEA) - END IF - IF ( FLGRDALL( 6, 7) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=PRMS(JSEA) - IH = IH + 1 - Arrexch(IH,JSEA)=TPMS(JSEA) - END IF - IF ( FLGRDALL( 6, 8) ) THEN - DO IK=1,2*NK - IH = IH + 1 - Arrexch(IH,JSEA)=US3D(JSEA,IK) - END DO - END IF - IF ( FLGRDALL( 6, 9) ) THEN - DO K=P2MSF(2),P2MSF(3) - IH = IH + 1 - Arrexch(IH,JSEA)=P2SMS(JSEA,K) - END DO - END IF - IF ( FLGRDALL( 6, 10) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=TAUICE(JSEA,1) - IH = IH + 1 - Arrexch(IH,JSEA)=TAUICE(JSEA,2) - END IF - IF ( FLGRDALL( 6, 11) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=PHICE(JSEA) - END IF - IF ( FLGRDALL( 6, 13) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=TAUOCX(JSEA) + END DO + NRQGO = 0 + NRQGO2 = 0 + IT0 = NSPEC + IROOT = NAPFLD - 1 + IF ( FLOUT(1) .OR. FLOUT(7) ) THEN + CALL GET_ARRAY_SIZE(TheSize) + IF ( IAPROC .LE. NAPROC ) THEN + allocate(ARRexch(TheSize, NSEAL), ARRpos(NSEAL)) + DO JSEA=1,NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + ARRpos(JSEA)=ISEA + IH = 0 + IF ( FLGRDALL( 2, 1) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=HS(JSEA) + END IF + IF ( FLGRDALL( 2, 2) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=WLM(JSEA) + END IF + IF ( FLGRDALL( 2, 3) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=T02(JSEA) + END IF + IF ( FLGRDALL( 2, 4) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=T0M1(JSEA) + END IF + IF ( FLGRDALL( 2, 5) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=T01(JSEA) + END IF + IF ( FLGRDALL( 2, 6) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=FP0(JSEA) + END IF + IF ( FLGRDALL( 2, 7) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=THM(JSEA) + END IF + IF ( FLGRDALL( 2, 8) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=THS(JSEA) + END IF + IF ( FLGRDALL( 2, 9) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=THP0(JSEA) + END IF + IF ( FLGRDALL( 2, 10) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=HSIG(JSEA) + END IF + IF ( FLGRDALL( 2, 11) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=STMAXE(JSEA) + END IF + IF ( FLGRDALL( 2, 12) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=STMAXD(JSEA) + END IF + IF ( FLGRDALL( 2, 13) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=HMAXE(JSEA) + END IF + IF ( FLGRDALL( 2, 14) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=HCMAXE(JSEA) + END IF + IF ( FLGRDALL( 2, 15) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=HMAXD(JSEA) + END IF + IF ( FLGRDALL( 2, 16) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=HCMAXD(JSEA) + END IF + IF ( FLGRDALL( 2, 17) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=WBT(JSEA) + END IF + IF ( FLGRDALL( 2, 19) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=WNMEAN(JSEA) + END IF + IF ( FLGRDALL( 3, 1) ) THEN + DO IK=E3DF(2,1),E3DF(3,1) IH = IH + 1 - Arrexch(IH,JSEA)=TAUOCY(JSEA) - END IF - IF ( FLGRDALL( 7, 1) ) THEN + Arrexch(IH,JSEA)=EF(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 3, 2) ) THEN + DO IK=E3DF(2,2),E3DF(3,2) IH = IH + 1 - Arrexch(IH,JSEA)=ABA(JSEA) + Arrexch(IH,JSEA)=TH1M(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 3, 3) ) THEN + DO IK=E3DF(2,3),E3DF(3,3) IH = IH + 1 - Arrexch(IH,JSEA)=ABD(JSEA) - END IF - IF ( FLGRDALL( 7, 2) ) THEN + Arrexch(IH,JSEA)=STH1M(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 3, 4) ) THEN + DO IK=E3DF(2,4),E3DF(3,4) IH = IH + 1 - Arrexch(IH,JSEA)=UBA(JSEA) + Arrexch(IH,JSEA)=TH2M(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 3, 5) ) THEN + DO IK=E3DF(2,5),E3DF(3,5) IH = IH + 1 - Arrexch(IH,JSEA)=UBD(JSEA) - END IF - IF ( FLGRDALL( 7, 3) ) THEN + Arrexch(IH,JSEA)=STH2M(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4, 1) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=BEDFORMS(JSEA,1) + Arrexch(IH,JSEA)=PHS(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4, 2) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=BEDFORMS(JSEA,2) + Arrexch(IH,JSEA)=PTP(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4, 3) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=BEDFORMS(JSEA,3) - END IF - IF ( FLGRDALL( 7, 4) ) THEN + Arrexch(IH,JSEA)=PLP(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4, 4) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=PHIBBL(JSEA) - END IF - IF ( FLGRDALL( 7, 5) ) THEN + Arrexch(IH,JSEA)=PDIR(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4, 5) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=TAUBBL(JSEA,1) + Arrexch(IH,JSEA)=PSI(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4, 6) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=TAUBBL(JSEA,2) - END IF - IF ( FLGRDALL( 8, 1) ) THEN + Arrexch(IH,JSEA)=PWS(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4, 7) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=MSSX(JSEA) + Arrexch(IH,JSEA)=PTHP0(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4, 8) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=MSSY(JSEA) - END IF - IF ( FLGRDALL( 8, 2) ) THEN + Arrexch(IH,JSEA)=PQP(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4, 9) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=MSCX(JSEA) + Arrexch(IH,JSEA)=PPE(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4,10) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=MSCY(JSEA) - END IF - IF ( FLGRDALL( 8, 3) ) THEN + Arrexch(IH,JSEA)=PGW(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4,11) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=MSSD(JSEA) - END IF - IF ( FLGRDALL( 8, 4) ) THEN + Arrexch(IH,JSEA)=PSW(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4,12) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=MSCD(JSEA) - END IF - IF ( FLGRDALL( 8, 5) ) THEN + Arrexch(IH,JSEA)=PTM1(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4,13) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=QP(JSEA) - END IF - IF ( FLGRDALL( 9, 1) ) THEN + Arrexch(IH,JSEA)=PT1(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4,14) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=DTDYN(JSEA) - END IF - IF ( FLGRDALL( 9, 2) ) THEN + Arrexch(IH,JSEA)=PT2(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4,15) ) THEN + DO IK=0, NOSWLL IH = IH + 1 - Arrexch(IH,JSEA)=FCUT(JSEA) - END IF - IF ( FLGRDALL( 9, 3) ) THEN + Arrexch(IH,JSEA)=PEP(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 4,16) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=PWST(JSEA) + END IF + IF ( FLGRDALL( 4,17) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=PNR(JSEA) + END IF + IF ( FLGRDALL( 5, 1) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=UST(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=USTDIR(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=ASF(JSEA) + END IF + IF ( FLGRDALL( 5, 2) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=CHARN(JSEA) + END IF + IF ( FLGRDALL( 5, 3) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=CGE(JSEA) + END IF + IF ( FLGRDALL( 5, 4) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=PHIAW(JSEA) + END IF + IF ( FLGRDALL( 5, 5) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=TAUWIX(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=TAUWIY(JSEA) + END IF + IF ( FLGRDALL( 5, 6) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=TAUWNX(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=TAUWNY(JSEA) + END IF + IF ( FLGRDALL( 5, 7) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=WHITECAP(JSEA,1) + END IF + IF ( FLGRDALL( 5, 8) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=WHITECAP(JSEA,2) + END IF + IF ( FLGRDALL( 5, 9) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=WHITECAP(JSEA,3) + END IF + IF ( FLGRDALL( 5,10) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=WHITECAP(JSEA,4) + END IF + IF ( FLGRDALL( 6, 1) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=SXX(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=SYY(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=SXY(JSEA) + END IF + IF ( FLGRDALL( 6, 2) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=TAUOX(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=TAUOY(JSEA) + END IF + IF ( FLGRDALL( 6, 3) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=BHD(JSEA) + END IF + IF ( FLGRDALL( 6, 4) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=PHIOC(JSEA) + END IF + IF ( FLGRDALL( 6, 5) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=TUSX(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=TUSY(JSEA) + END IF + IF ( FLGRDALL( 6, 6) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=USSX(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=USSY(JSEA) + END IF + IF ( FLGRDALL( 6, 7) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=PRMS(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=TPMS(JSEA) + END IF + IF ( FLGRDALL( 6, 8) ) THEN + DO IK=1,2*NK IH = IH + 1 - Arrexch(IH,JSEA)=CFLXYMAX(JSEA) - END IF - IF ( FLGRDALL( 9, 4) ) THEN + Arrexch(IH,JSEA)=US3D(JSEA,IK) + END DO + END IF + IF ( FLGRDALL( 6, 9) ) THEN + DO K=P2MSF(2),P2MSF(3) IH = IH + 1 - Arrexch(IH,JSEA)=CFLTHMAX(JSEA) - END IF - IF ( FLGRDALL( 9, 5) ) THEN + Arrexch(IH,JSEA)=P2SMS(JSEA,K) + END DO + END IF + IF ( FLGRDALL( 6, 10) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=TAUICE(JSEA,1) + IH = IH + 1 + Arrexch(IH,JSEA)=TAUICE(JSEA,2) + END IF + IF ( FLGRDALL( 6, 11) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=PHICE(JSEA) + END IF + IF ( FLGRDALL( 6, 13) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=TAUOCX(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=TAUOCY(JSEA) + END IF + IF ( FLGRDALL( 7, 1) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=ABA(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=ABD(JSEA) + END IF + IF ( FLGRDALL( 7, 2) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=UBA(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=UBD(JSEA) + END IF + IF ( FLGRDALL( 7, 3) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=BEDFORMS(JSEA,1) + IH = IH + 1 + Arrexch(IH,JSEA)=BEDFORMS(JSEA,2) + IH = IH + 1 + Arrexch(IH,JSEA)=BEDFORMS(JSEA,3) + END IF + IF ( FLGRDALL( 7, 4) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=PHIBBL(JSEA) + END IF + IF ( FLGRDALL( 7, 5) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=TAUBBL(JSEA,1) + IH = IH + 1 + Arrexch(IH,JSEA)=TAUBBL(JSEA,2) + END IF + IF ( FLGRDALL( 8, 1) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=MSSX(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=MSSY(JSEA) + END IF + IF ( FLGRDALL( 8, 2) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=MSCX(JSEA) + IH = IH + 1 + Arrexch(IH,JSEA)=MSCY(JSEA) + END IF + IF ( FLGRDALL( 8, 3) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=MSSD(JSEA) + END IF + IF ( FLGRDALL( 8, 4) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=MSCD(JSEA) + END IF + IF ( FLGRDALL( 8, 5) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=QP(JSEA) + END IF + IF ( FLGRDALL( 9, 1) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=DTDYN(JSEA) + END IF + IF ( FLGRDALL( 9, 2) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=FCUT(JSEA) + END IF + IF ( FLGRDALL( 9, 3) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=CFLXYMAX(JSEA) + END IF + IF ( FLGRDALL( 9, 4) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=CFLTHMAX(JSEA) + END IF + IF ( FLGRDALL( 9, 5) ) THEN + IH = IH + 1 + Arrexch(IH,JSEA)=CFLKMAX(JSEA) + END IF + DO I=1, NOEXTR + IF ( FLGRDALL(10, I) ) THEN IH = IH + 1 - Arrexch(IH,JSEA)=CFLKMAX(JSEA) + Arrexch(IH,JSEA)=USERO(JSEA,I) END IF - DO I=1, NOEXTR - IF ( FLGRDALL(10, I) ) THEN - IH = IH + 1 - Arrexch(IH,JSEA)=USERO(JSEA,I) - END IF - END DO + END DO + END DO + END IF + ! + ! Now synchronizing the data + ! It must be possible to ensure that the output + ! node is also a computational node. + ! + IF (IAPROC .eq. NAPFLD) THEN + allocate(ARRtotal(TheSize, NSEA)) + IF (IAPROC .le. NAPROC) THEN + DO I=1,NSEAL + ARRtotal(:,ARRpos(I)) = ARRexch(:,I) END DO END IF -! -! Now synchronizing the data -! It must be possible to ensure that the output -! node is also a computational node. -! - IF (IAPROC .eq. NAPFLD) THEN - allocate(ARRtotal(TheSize, NSEA)) - IF (IAPROC .le. NAPROC) THEN - DO I=1,NSEAL - ARRtotal(:,ARRpos(I)) = ARRexch(:,I) + END IF + IF ((IAPROC .le. NAPROC).and.(IAPROC.ne.NAPFLD)) THEN + eEnt(1)=NSEAL + CALL MPI_SEND(eEnt,1,MPI_INTEGER, NAPFLD-1, 23, MPI_COMM_WAVE, ierr) + CALL MPI_SEND(ARRpos,NSEAL,MPI_INTEGER, NAPFLD-1, 29, MPI_COMM_WAVE, ierr) + CALL MPI_SEND(ARRexch,NSEAL*TheSize,MPI_REAL, NAPFLD-1, 37, MPI_COMM_WAVE, ierr) + deallocate(ARRpos, ARRexch) + END IF + IF (IAPROC .eq. NAPFLD) THEN + DO IPROC=1,NAPROC + IF (IPROC .ne. IAPROC) THEN + CALL MPI_RECV(eEnt,1,MPI_INTEGER, IPROC-1, 23, MPI_COMM_WAVE, istatus, ierr) + NSEAL_loc=eEnt(1) + allocate(ARRpos_loc(NSEAL_loc), ARRexch_loc(TheSize, NSEAL_loc)) + CALL MPI_RECV(ARRpos_loc,NSEAL_loc,MPI_INTEGER, IPROC-1, 29, MPI_COMM_WAVE, istatus, ierr) + CALL MPI_RECV(ARRexch_loc,NSEAL_loc*TheSize,MPI_INTEGER, IPROC-1, 37, MPI_COMM_WAVE, istatus, ierr) + DO I=1,NSEAL_loc + ARRtotal(:,ARRpos_loc(I)) = ARRexch_loc(:,I) END DO + deallocate(ARRexch_loc, ARRpos_loc) END IF + END DO + END IF + IF ( IAPROC .EQ. NAPFLD ) THEN + ! CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDALL ) + CALL W3XETA ( IMOD, NDSE, NDST ) + IH = 0 + IF ( FLGRDALL( 2, 1) ) THEN + IH = IH + 1 + HS(1:NSEA) = ARRtotal(IH,:) END IF - IF ((IAPROC .le. NAPROC).and.(IAPROC.ne.NAPFLD)) THEN - eEnt(1)=NSEAL - CALL MPI_SEND(eEnt,1,MPI_INTEGER, NAPFLD-1, 23, MPI_COMM_WAVE, ierr) - CALL MPI_SEND(ARRpos,NSEAL,MPI_INTEGER, NAPFLD-1, 29, MPI_COMM_WAVE, ierr) - CALL MPI_SEND(ARRexch,NSEAL*TheSize,MPI_REAL, NAPFLD-1, 37, MPI_COMM_WAVE, ierr) - deallocate(ARRpos, ARRexch) - END IF - IF (IAPROC .eq. NAPFLD) THEN - DO IPROC=1,NAPROC - IF (IPROC .ne. IAPROC) THEN - CALL MPI_RECV(eEnt,1,MPI_INTEGER, IPROC-1, 23, MPI_COMM_WAVE, istatus, ierr) - NSEAL_loc=eEnt(1) - allocate(ARRpos_loc(NSEAL_loc), ARRexch_loc(TheSize, NSEAL_loc)) - CALL MPI_RECV(ARRpos_loc,NSEAL_loc,MPI_INTEGER, IPROC-1, 29, MPI_COMM_WAVE, istatus, ierr) - CALL MPI_RECV(ARRexch_loc,NSEAL_loc*TheSize,MPI_INTEGER, IPROC-1, 37, MPI_COMM_WAVE, istatus, ierr) - DO I=1,NSEAL_loc - ARRtotal(:,ARRpos_loc(I)) = ARRexch_loc(:,I) - END DO - deallocate(ARRexch_loc, ARRpos_loc) - END IF - END DO + IF ( FLGRDALL( 2, 2) ) THEN + IH = IH + 1 + WLM(1:NSEA) = ARRtotal(IH,:) END IF - IF ( IAPROC .EQ. NAPFLD ) THEN -! CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDALL ) - CALL W3XETA ( IMOD, NDSE, NDST ) - IH = 0 - IF ( FLGRDALL( 2, 1) ) THEN - IH = IH + 1 - HS(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 2) ) THEN - IH = IH + 1 - WLM(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 3) ) THEN - IH = IH + 1 - T02(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 4) ) THEN - IH = IH + 1 - T0M1(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 5) ) THEN - IH = IH + 1 - T01(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 6) ) THEN - IH = IH + 1 - FP0(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 7) ) THEN - IH = IH + 1 - THM(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 8) ) THEN - IH = IH + 1 - THS(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 9) ) THEN - IH = IH + 1 - THP0(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 10) ) THEN - IH = IH + 1 - HSIG(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 11) ) THEN - IH = IH + 1 - STMAXE(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 12) ) THEN - IH = IH + 1 - STMAXD(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 13) ) THEN - IH = IH + 1 - HMAXE(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 14) ) THEN - IH = IH + 1 - HCMAXE(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 15) ) THEN - IH = IH + 1 - HMAXD(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 16) ) THEN - IH = IH + 1 - HCMAXD(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 17) ) THEN - IH = IH + 1 - WBT(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 2, 19) ) THEN - IH = IH + 1 - WNMEAN(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 3, 1) ) THEN - DO IK=E3DF(2,1),E3DF(3,1) - IH = IH + 1 - EF(1:NSEA,IK) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 3, 2) ) THEN - DO IK=E3DF(2,2),E3DF(3,2) - IH = IH + 1 - TH1M(1:NSEA,IK) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 3, 3) ) THEN - DO IK=E3DF(2,3),E3DF(3,3) - IH = IH + 1 - STH1M(1:NSEA,IK) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 3, 4) ) THEN - DO IK=E3DF(2,4),E3DF(3,4) - IH = IH + 1 - TH2M(1:NSEA,IK) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 3, 5) ) THEN - DO IK=E3DF(2,5),E3DF(3,5) - IH = IH + 1 - STH2M(1:NSEA,IK) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4, 1) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PHS(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4, 2) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PTP(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4, 3) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PLP(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4, 4) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PDIR(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4, 5) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PSI(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4, 6) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PWS(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4, 7) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PTHP0(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4, 8) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PQP(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4, 9) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PPE(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4,10) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PGW(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4,11) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PSW(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4,12) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PTM1(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4,13) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PT1(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4,14) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PT2(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4,15) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - PEP(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 4,16) ) THEN - IH = IH + 1 - PWST(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 4,17) ) THEN - IH = IH + 1 - PNR(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 5, 1) ) THEN - IH = IH + 1 - UST(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - USTDIR(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - ASF(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 5, 2) ) THEN - IH = IH + 1 - CHARN(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 5, 3) ) THEN - IH = IH + 1 - CGE(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 5, 4) ) THEN - IH = IH + 1 - PHIAW(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 5, 5) ) THEN - IH = IH + 1 - TAUWIX(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - TAUWIY(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 5, 6) ) THEN - IH = IH + 1 - TAUWNX(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - TAUWNY(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 5, 7) ) THEN - IH = IH + 1 - WHITECAP(1:NSEA,1) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 5, 8) ) THEN - IH = IH + 1 - WHITECAP(1:NSEA,2) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 5, 9) ) THEN - IH = IH + 1 - WHITECAP(1:NSEA,3) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 5,10) ) THEN - IH = IH + 1 - WHITECAP(1:NSEA,4) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 6, 1) ) THEN - IH = IH + 1 - SXX(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - SYY(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - SXY(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 6, 2) ) THEN - IH = IH + 1 - TAUOX(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - TAUOY(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 6, 3) ) THEN - IH = IH + 1 - BHD(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 6, 4) ) THEN - IH = IH + 1 - PHIOC(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 6, 5) ) THEN - IH = IH + 1 - TUSX(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - TUSY(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 6, 6) ) THEN - IH = IH + 1 - USSX(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - USSY(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 6, 7) ) THEN - IH = IH + 1 - PRMS(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - TPMS(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 6, 8) ) THEN - DO IK=1,2*NK - IH = IH + 1 - US3D(1:NSEA,IK) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 6, 9) ) THEN - DO K=P2MSF(2),P2MSF(3) - IH = IH + 1 - P2SMS(1:NSEA,K) = ARRtotal(IH,:) - END DO - END IF - IF ( FLGRDALL( 6, 10) ) THEN - IH = IH + 1 - TAUICE(1:NSEA,1) = ARRtotal(IH,:) - IH = IH + 1 - TAUICE(1:NSEA,2) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 6, 11) ) THEN - IH = IH + 1 - PHICE(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 6, 13) ) THEN - IH = IH + 1 - TAUOCX(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - TAUOCY(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 7, 1) ) THEN - IH = IH + 1 - ABA(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - ABD(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 7, 2) ) THEN - IH = IH + 1 - UBA(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - UBD(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 7, 3) ) THEN - IH = IH + 1 - BEDFORMS(1:NSEA,1) = ARRtotal(IH,:) - IH = IH + 1 - BEDFORMS(1:NSEA,2) = ARRtotal(IH,:) - IH = IH + 1 - BEDFORMS(1:NSEA,3) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 7, 4) ) THEN - IH = IH + 1 - PHIBBL(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 7, 5) ) THEN - IH = IH + 1 - TAUBBL(1:NSEA,1) = ARRtotal(IH,:) - IH = IH + 1 - TAUBBL(1:NSEA,2) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 8, 1) ) THEN - IH = IH + 1 - MSSX(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - MSSY(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 8, 2) ) THEN - IH = IH + 1 - MSCX(1:NSEA) = ARRtotal(IH,:) - IH = IH + 1 - MSCY(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 8, 3) ) THEN - IH = IH + 1 - MSSD(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 8, 4) ) THEN - IH = IH + 1 - MSCD(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 8, 5) ) THEN - IH = IH + 1 - QP(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 9, 1) ) THEN - IH = IH + 1 - DTDYN(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 9, 2) ) THEN - IH = IH + 1 - FCUT(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 9, 3) ) THEN - IH = IH + 1 - CFLXYMAX(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 9, 4) ) THEN - IH = IH + 1 - CFLTHMAX(1:NSEA) = ARRtotal(IH,:) - END IF - IF ( FLGRDALL( 9, 5) ) THEN - IH = IH + 1 - CFLKMAX(1:NSEA) = ARRtotal(IH,:) - END IF - DO I=1, NOEXTR - IF ( FLGRDALL(10, I) ) THEN - IH = IH + 1 - USERO(1:NSEA,I) = ARRtotal(IH,:) - END IF - END DO - CALL W3SETA ( IMOD, NDSE, NDST ) + IF ( FLGRDALL( 2, 3) ) THEN + IH = IH + 1 + T02(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 4) ) THEN + IH = IH + 1 + T0M1(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 5) ) THEN + IH = IH + 1 + T01(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 6) ) THEN + IH = IH + 1 + FP0(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 7) ) THEN + IH = IH + 1 + THM(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 8) ) THEN + IH = IH + 1 + THS(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 9) ) THEN + IH = IH + 1 + THP0(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 10) ) THEN + IH = IH + 1 + HSIG(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 11) ) THEN + IH = IH + 1 + STMAXE(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 12) ) THEN + IH = IH + 1 + STMAXD(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 13) ) THEN + IH = IH + 1 + HMAXE(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 14) ) THEN + IH = IH + 1 + HCMAXE(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 15) ) THEN + IH = IH + 1 + HMAXD(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 16) ) THEN + IH = IH + 1 + HCMAXD(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 17) ) THEN + IH = IH + 1 + WBT(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 2, 19) ) THEN + IH = IH + 1 + WNMEAN(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 3, 1) ) THEN + DO IK=E3DF(2,1),E3DF(3,1) + IH = IH + 1 + EF(1:NSEA,IK) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 3, 2) ) THEN + DO IK=E3DF(2,2),E3DF(3,2) + IH = IH + 1 + TH1M(1:NSEA,IK) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 3, 3) ) THEN + DO IK=E3DF(2,3),E3DF(3,3) + IH = IH + 1 + STH1M(1:NSEA,IK) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 3, 4) ) THEN + DO IK=E3DF(2,4),E3DF(3,4) + IH = IH + 1 + TH2M(1:NSEA,IK) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 3, 5) ) THEN + DO IK=E3DF(2,5),E3DF(3,5) + IH = IH + 1 + STH2M(1:NSEA,IK) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4, 1) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PHS(1:NSEA,K) = ARRtotal(IH,:) + END DO END IF + IF ( FLGRDALL( 4, 2) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PTP(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4, 3) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PLP(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4, 4) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PDIR(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4, 5) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PSI(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4, 6) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PWS(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4, 7) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PTHP0(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4, 8) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PQP(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4, 9) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PPE(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4,10) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PGW(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4,11) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PSW(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4,12) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PTM1(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4,13) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PT1(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4,14) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PT2(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4,15) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + PEP(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 4,16) ) THEN + IH = IH + 1 + PWST(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 4,17) ) THEN + IH = IH + 1 + PNR(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 5, 1) ) THEN + IH = IH + 1 + UST(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + USTDIR(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + ASF(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 5, 2) ) THEN + IH = IH + 1 + CHARN(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 5, 3) ) THEN + IH = IH + 1 + CGE(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 5, 4) ) THEN + IH = IH + 1 + PHIAW(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 5, 5) ) THEN + IH = IH + 1 + TAUWIX(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + TAUWIY(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 5, 6) ) THEN + IH = IH + 1 + TAUWNX(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + TAUWNY(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 5, 7) ) THEN + IH = IH + 1 + WHITECAP(1:NSEA,1) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 5, 8) ) THEN + IH = IH + 1 + WHITECAP(1:NSEA,2) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 5, 9) ) THEN + IH = IH + 1 + WHITECAP(1:NSEA,3) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 5,10) ) THEN + IH = IH + 1 + WHITECAP(1:NSEA,4) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 6, 1) ) THEN + IH = IH + 1 + SXX(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + SYY(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + SXY(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 6, 2) ) THEN + IH = IH + 1 + TAUOX(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + TAUOY(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 6, 3) ) THEN + IH = IH + 1 + BHD(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 6, 4) ) THEN + IH = IH + 1 + PHIOC(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 6, 5) ) THEN + IH = IH + 1 + TUSX(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + TUSY(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 6, 6) ) THEN + IH = IH + 1 + USSX(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + USSY(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 6, 7) ) THEN + IH = IH + 1 + PRMS(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + TPMS(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 6, 8) ) THEN + DO IK=1,2*NK + IH = IH + 1 + US3D(1:NSEA,IK) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 6, 9) ) THEN + DO K=P2MSF(2),P2MSF(3) + IH = IH + 1 + P2SMS(1:NSEA,K) = ARRtotal(IH,:) + END DO + END IF + IF ( FLGRDALL( 6, 10) ) THEN + IH = IH + 1 + TAUICE(1:NSEA,1) = ARRtotal(IH,:) + IH = IH + 1 + TAUICE(1:NSEA,2) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 6, 11) ) THEN + IH = IH + 1 + PHICE(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 6, 13) ) THEN + IH = IH + 1 + TAUOCX(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + TAUOCY(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 7, 1) ) THEN + IH = IH + 1 + ABA(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + ABD(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 7, 2) ) THEN + IH = IH + 1 + UBA(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + UBD(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 7, 3) ) THEN + IH = IH + 1 + BEDFORMS(1:NSEA,1) = ARRtotal(IH,:) + IH = IH + 1 + BEDFORMS(1:NSEA,2) = ARRtotal(IH,:) + IH = IH + 1 + BEDFORMS(1:NSEA,3) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 7, 4) ) THEN + IH = IH + 1 + PHIBBL(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 7, 5) ) THEN + IH = IH + 1 + TAUBBL(1:NSEA,1) = ARRtotal(IH,:) + IH = IH + 1 + TAUBBL(1:NSEA,2) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 8, 1) ) THEN + IH = IH + 1 + MSSX(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + MSSY(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 8, 2) ) THEN + IH = IH + 1 + MSCX(1:NSEA) = ARRtotal(IH,:) + IH = IH + 1 + MSCY(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 8, 3) ) THEN + IH = IH + 1 + MSSD(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 8, 4) ) THEN + IH = IH + 1 + MSCD(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 8, 5) ) THEN + IH = IH + 1 + QP(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 9, 1) ) THEN + IH = IH + 1 + DTDYN(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 9, 2) ) THEN + IH = IH + 1 + FCUT(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 9, 3) ) THEN + IH = IH + 1 + CFLXYMAX(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 9, 4) ) THEN + IH = IH + 1 + CFLTHMAX(1:NSEA) = ARRtotal(IH,:) + END IF + IF ( FLGRDALL( 9, 5) ) THEN + IH = IH + 1 + CFLKMAX(1:NSEA) = ARRtotal(IH,:) + END IF + DO I=1, NOEXTR + IF ( FLGRDALL(10, I) ) THEN + IH = IH + 1 + USERO(1:NSEA,I) = ARRtotal(IH,:) + END IF + END DO + CALL W3SETA ( IMOD, NDSE, NDST ) END IF - indexOutput=indexOutput+1 - END SUBROUTINE DO_OUTPUT_EXCHANGES -!/ ------------------------------------------------------------------- / + END IF + indexOutput=indexOutput+1 + END SUBROUTINE DO_OUTPUT_EXCHANGES + !/ ------------------------------------------------------------------- / END MODULE PDLIB_FIELD_VEC !/ ------------------------------------------------------------------- / - diff --git a/model/src/w3adatmd.F90 b/model/src/w3adatmd.F90 index 5377a4dec..d9cbc8208 100644 --- a/model/src/w3adatmd.F90 +++ b/model/src/w3adatmd.F90 @@ -1,7 +1,7 @@ -!> @file +!> @file !> @brief Define data structures to set up wave model auxiliary data !> for several models simultaneously. -!> +!> !> @author H. L. Tolman !> @date 22-Mar-2021 !> @@ -11,7 +11,7 @@ !> !> @brief Define data structures to set up wave model auxiliary data !> for several models simultaneously. -!> +!> !> @details The number of grids is taken from W3GDATMD, and needs to be !> set first with W3DIMG. !> @@ -23,3398 +23,3374 @@ !> reserved. WAVEWATCH III is a trademark of the NWS. !> No unauthorized use without permission. !> - MODULE W3ADATMD +MODULE W3ADATMD #ifdef W3_MEMCHECK - USE MallocInfo_m -#endif -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2004 : Origination. ( version 3.06 ) -!/ 04-May-2005 : Adding MPI_COMM_WAVE. ( version 3.07 ) -!/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) -!/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) -!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 28_Mar-2007 : Add partitioned data arrays. ( version 3.11 ) -!/ Add aditional undefined arrays. -!/ 22-Feb-2008 ; Modify MAPTH2 declaration. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 29-Oct-2010 : Adding unstructured grid data. ( version 3.14 ) -!/ (A. Roland and F. Ardhuin) -!/ 31-Oct-2010 : Adding output parameters ( version 3.14 ) -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) -!/ 26-Dec-2012 : Memory reduction for outputs. ( version 4.11 ) -!/ Add W3XETA. -!/ 28-Jun-2013 : Bug fix initialization P2SMS. ( version 4.11 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 14-Nov-2013 : Move orphaned arrays as scalar to W3SRCE. -!/ Here update of documentation only. -!/ (Z0S, CDS, EMN, FMN, WNM, AMX) ( version 4.13 ) -!/ 30-Apr-2014 : Memory reduction for group3. ( version 5.00 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 01-May-2017 : Adds directional MSS parameters ( version 6.02 ) -!/ 30-Jul-2017 : Adds TWS parameter ( version 6.02 ) -!/ 05-Jun-2018 : Adds PDLIB and MEMCHECK ( version 6.04 ) -!/ 21-Aug-2018 : Add WBT parameter ( version 6.06 ) -!/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) -!/ 06-May-2021 : SMC shares variables with PR2/3. ( version 7.13 ) -! -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Define data structures to set up wave model auxiliary data for -! several models simultaneously. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NADATA Int. Public Number of models in array dim. -! IADATA Int. Public Selected model for output, init. at -1. -! MPIBUF I.P. Public Number of buffer arrays for 'hidden' -! MPI communications (no hiding for -! MPIBUF = 1). -! WADAT TYPE Public Basic data structure. -! WADATS WADAT Public Array of data structures. -! ---------------------------------------------------------------- -! -! All elements of WADAT are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! Internal model definition: -! -! CG R.A. Public Group velocities for all wave model -! sea points and frequencies. -! WN R.A. Public Idem, wavenumbers. -! -! Aux. arrays for model input: -! -! CA0-I R.A. Public Absolute current velocity (initial -! and inc.) in W3UCUR. -! CD0-I R.A. Public Current direction (initial and -! increment) in W3UCUR. -! UA0-I R.A. Public Absolute wind speeds (initial and -! incr.) in W3UWND (m/s) -! UD0-I R.A. Public Wind direction (initial and incr.) -! in W3UWND (rad) -! AS0-I R.A. Public Stability par. (initial and incr.) -! in W3UWND (degr) -! MA0-I R.A. Public Absolute atmospheric momentum (initial -! and inc.) in W3UTAU. -! RA0-I R.A. Public Absolute air density (initial and inc.) -! in W3URHO. -! MD0-I R.A. Public Atmospheric momentum direction (initial and -! increment) in W3UTAU. -! ATRNX/Y R.A. Public Actual transparency info. -! -! Fields of mean wave parameters: -! -! DW R.A. Public Water depths. -! UA R.A. Public Absolute wind speeds. -! UD R.A. Public Absolute wind direction. -! U10 R.A. Public Wind speed used. -! U10D R.A. Public Wind direction used. -! AS R.A. Public Stability parameter. -! CX/Y R.A. Public Current components. -! TAUA R.A. Public Absolute atmospheric momentum. -! TAUADIR R.A. Public Absolute atmospheric momentum direction. -! -! HS R.A. Public Wave Height. -! WLM R.A. Public Mean wave length. -! T02 R.A. Public Mean wave period (m0,2). -! T0M1 R.A. Public Mean wave period (m0,-1). -! T01 R.A. Public Mean wave period (m0,1). -! FP0 R.A. Public Peak frequency. -! THM R.A. Public Mean wave direction. -! THS R.A. Public Mean directional spread. -! THP0 R.A. Public Peak direction. -! HSIG R.A. Public Height of infragravity waves -! STMAXE R.A. Public Expected maximum surface elevation (crest) -! STMAXD R.A. Public STD of maximum surface elevation -! HMAXE R.A. Public Expected maximum wave height (from covariance) -! HMAXD R.A. Public Std of HMAXE -! HCMAXE R.A. Public Expected maximum wave height (from crest) -! HCMAXD R.A. Public STD of HCMAXE -! WBT R.A. Public Dominant wave breaking probability -! (b_T in Babanin et al. (2001, JGR)) -! WNMEAN R.A. Public Mean wave number -! -! CHARN R.A. Public Charnock parameter for air-sea friction. -! TWS R.A. Public Wind sea period (used for flux parameterizations) -! CGE R.A. Public Energy flux. -! PHIAW R.A. Public Wind to wave energy flux. -! TAUWIX/Y R.A. Public Wind to wave energy flux. -! TAUWNX/Y R.A. Public Wind to wave energy flux. -! WHITECAP R.A. Public 1 : Whitecap coverage -! 2 : Whitecap thickness -! 3 : Mean breaking height -! 4 : Mean breaking height -! -! Sxx R.A. Public Radiation stresses. -! TAUOX/Y R.A. Public Wave-ocean momentum flux. -! BHD R.A. Public Wave-induced pressure (J term, Smith JPO 2006) -! PHIOC R.A. Public Waves to ocean energy flux. -! TUSX/Y R.A. Public Volume transport associated to Stokes drift. -! USSX/Y R.A. Public Surface Stokes drift. -! TAUOCX/Y R.A. Public Total ocean momentum flux -! TAUICE R.A. Public Wave-ice momentum flux. -! PHICE R.A. Public Waves to ice energy flux. -! -! US3D R.A. Public 3D Stokes drift. -! USSP R.A. Public Partitioned Surface Stokes drift -! -! ABA R.A. Public Near-bottom rms wave ex. amplitude. -! ABD R.A. Public Corresponding direction. -! UBA R.A. Public Near-bottom rms wave velocity. -! UBD R.A. Public Corresponding direction. -! BEDFORMS R.A. Public Bed for parameters -! PHIBBL R.A. Public Energy loss in WBBL. -! TAUBBL R.A. Public Momentum loss in WBBL. -! -! MSSX/Y R.A. Public Surface mean square slopes in X and Y direction. -! MSCX/Y R.A. Public Phillips constant. -! MSSD R.A. Public Direction of MSSX -! MSCD R.A. Public Direction of MSCX -! QP R.A. Public Goda peakedness parameter. -! -! DTDYN R.A. Public Mean dynamic time step (raw). -! FCUT R.A. Public Cut-off frequency for tail. -! CFLXYMAX R.A. Public Max. CFL number for spatial advection. -! CFLTHMAX R.A. Public Max. CFL number for refraction. -! CFLKMAX R.A. Public Max. CFL number for wavenumber shift. -! -! Orphans, commented out here, now automatic arrays in W3WAVE, .... -! -! DRAT R.A. Public Density ration air/water. Was -! placeholder only. Now scalar in W3SRCE, -! TAUWX/Y R.A. Public Stresses. -! -! Derivatives in space .... -! -! DDDx R.A. Public Spatial derivatives of the depth. -! DCxDx R.A. Public Spatial dirivatives of the current. -! -! Mean parameters from partitiones spectra, 2D array with el. -! 0 holding wind sea data, and 1:NOSWLL holding swell fields. -! Last two arrays are regular single-entry arrays. -! -! PHS R.A. Public Wave height of partition. -! PTP R.A. Public Peak period of partition. -! PLP R.A. Public Peak wave leingth of partition. -! PDIR R.A. Public Mean direction of partition. -! PSI R.A. Public Mean spread of partition. -! PWS R.A. Public Wind sea fraction of partition. -! -! PWST R.A. Public Total wind sea fraction. -! PNR R.A. Public Number of partitions found. -! -! PTHP0 R.A. Public Peak wave direction of partition. -! PQP R.A. Public Goda peakdedness parameter of partition. -! PPE R.A. Public JONSWAP peak enhancement factor of partition. -! PGW R.A. Public Gaussian frequency width of partition. -! PSW R.A. Public Spectral width of partition. -! PTM1 R.A. Public Mean wave period (m-1,0) of partition. -! PT1 R.A. Public Mean wave period (m0,1) of partition. -! PT2 R.A. Public Mean wave period (m0,2) of partition. -! PEP R.A. Public Peak spectral density of partition. -! -! Empty dummy fields (NOEXTR) -! -! USERO R.A. Public Empty output arrays than can be -! used by users as a simple means to -! add output. -! -! Map data for propagation schemes (1Up). -! -! IS0/2 I.A. Public Spectral propagation maps. -! FACVX/Y R.A. Public Spatial propagation factor map. -! -! Map data for propagation schemes (UQ). -! -! NMXn Int. Public Counters for MAPX2, see W3MAP3. -! NMYn Int. Public -! NMXY Int. Public Dimension of MAPXY. -! NACTn Int. Public Dimension of MAPAXY. -! NCENT Int. Public Dimension of MAPAXY. -! MAPX2 I.A. Public Map for prop. in 'x' (longitude) dir. -! MAPY2 I.A. Public Idem in y' (latitude) direction. -! MAPXY I.A. Public -! MAPAXY I.A. Public List of active points used in W3QCK1. -! MAPCXY I.A. Public List of central points used in avg. -! MAPTH2 I.A. Public Like MAPX2 for refraction (rotated -! and shifted, see W3KTP3). Like MAPAXY. -! MAPWN2 I.A. Public Like MAPX2 for wavenumber shift. -! MAPTRN L.A. Public Map to block out GSE mitigation in -! proper grid points. -! -! Nonlinear interactions ( !/NL1 ) : -! -! NFR Int. Public Nuber of frequencies ( NFR = NK ) -! NFRHGH Int. Public Auxiliary frequency counter. -! NFRCHG Int. Public Id. -! NSPECX-Y Int. Public Auxiliary spectral counter. -! IPnn I.A. Public Spectral address for Snl. -! IMnn I.A. Public Id. -! ICnn I.A. Public Id. -! DALn Real Public Lambda dependend weight factors. -! AWGn Real Public Interpolation weights for Snl. -! SWGn Real Public Interpolation weights for diag. term. -! AF11 R.A. Public Scaling array (f**11) -! NLINIT Log. Public Flag for initialization. -! -! MPP / MPI variables : -! -! IAPPRO I.A. Public Processor numbers for propagation calc. -! for each spectral component. -! MPI_COMM_WAVE -! Int. Public Communicator used in the wave model. -! MPI_COMM_WCMP -! Int. Public Idem, computational proc. only. -! WW3_FIELD_VEC, WW3_SPEC_VEC -! Int. Public MPI derived vecor types. -! NRQSG1 Int. Public Number of handles in IRQSG1. -! NRQSG2 Int. Public Number of handles in IRQSG2. -! IBFLOC Int. Public Present active buffer number. -! ISPLOC Int. Public Corresponding local spectral bin number -! (1,NSPLOC,1). -! NSPLOC Int. Public Total number of spectral bins for which -! prop. is performed on present CPU. -! BSTAT I.A. Public Status of buffer (size MPIBUF): -! 0: Inactive. -! 1: A --> STORE (active or finished). -! 2: STORE --> A (active or finished). -! BISPL I.A. Public Local spectral bin number for buffer -! (size MPIBUF). -! IRQSG1 I.A. Public MPI request handles for scatters and -! gathers to A() (persistent). -! IRQSG2 I.A. Public MPI request handles for gathers and -! scatters to STORE (persistent). -! G/SSTORE R.A. Public Communication buffer (NSEA,MPIBUF). -! SPPNT R.A. Public Point output buffer. -! -! Other: -! -! ITIME Int. Public Discrete time step counter. -! IPASS Int. Public Pass counter for log file. -! IDLAST Int. Public Last day ID for log file. -! NSEALM Int. Public Maximum number of local sea points. -! ALPHA R.A. Public Phillips' alpha. -! FLCOLD Log. Public Flag for 'cold start' of model. -! FLIWND Log. Public Flag for initialization of model -! based on wind. -! AINIT(2) Log. Public Flag for array initialization. -! FL_ALL Log. Public Flag for all/partial initialization. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3NAUX Subr. Public Set number of grids/models. -! W3DIMA Subr. Public Set dimensions of arrays. -! W3DMNL Subr. Public Set dimensions of arrays. ( !/NL1 ) -! W3SETA Subr. Public Point to selected grid / model. -! W3XETA Subr. Public Like W3SETA for expanded output arrays. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to proper model grid. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - The number of grids is taken from W3GDATMD, and needs to be -! set first with W3DIMG. -! -! 6. Switches : -! -! !/SHRD, !/DIST, !/MPI -! Shared / distributed memory model -! -! !/PRn Propagation scheme selection. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Module private variable for checking error returns -!/ - INTEGER, PRIVATE :: ISTAT -!/ -!/ Conventional declarations -!/ - INTEGER :: NADATA = -1, IADATA = -1 + USE MallocInfo_m +#endif + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 28-Dec-2004 : Origination. ( version 3.06 ) + !/ 04-May-2005 : Adding MPI_COMM_WAVE. ( version 3.07 ) + !/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) + !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) + !/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 28_Mar-2007 : Add partitioned data arrays. ( version 3.11 ) + !/ Add aditional undefined arrays. + !/ 22-Feb-2008 ; Modify MAPTH2 declaration. ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 29-Oct-2010 : Adding unstructured grid data. ( version 3.14 ) + !/ (A. Roland and F. Ardhuin) + !/ 31-Oct-2010 : Adding output parameters ( version 3.14 ) + !/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) + !/ 26-Dec-2012 : Memory reduction for outputs. ( version 4.11 ) + !/ Add W3XETA. + !/ 28-Jun-2013 : Bug fix initialization P2SMS. ( version 4.11 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 14-Nov-2013 : Move orphaned arrays as scalar to W3SRCE. + !/ Here update of documentation only. + !/ (Z0S, CDS, EMN, FMN, WNM, AMX) ( version 4.13 ) + !/ 30-Apr-2014 : Memory reduction for group3. ( version 5.00 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 01-May-2017 : Adds directional MSS parameters ( version 6.02 ) + !/ 30-Jul-2017 : Adds TWS parameter ( version 6.02 ) + !/ 05-Jun-2018 : Adds PDLIB and MEMCHECK ( version 6.04 ) + !/ 21-Aug-2018 : Add WBT parameter ( version 6.06 ) + !/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) + !/ 06-May-2021 : SMC shares variables with PR2/3. ( version 7.13 ) + ! + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Define data structures to set up wave model auxiliary data for + ! several models simultaneously. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NADATA Int. Public Number of models in array dim. + ! IADATA Int. Public Selected model for output, init. at -1. + ! MPIBUF I.P. Public Number of buffer arrays for 'hidden' + ! MPI communications (no hiding for + ! MPIBUF = 1). + ! WADAT TYPE Public Basic data structure. + ! WADATS WADAT Public Array of data structures. + ! ---------------------------------------------------------------- + ! + ! All elements of WADAT are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! Internal model definition: + ! + ! CG R.A. Public Group velocities for all wave model + ! sea points and frequencies. + ! WN R.A. Public Idem, wavenumbers. + ! + ! Aux. arrays for model input: + ! + ! CA0-I R.A. Public Absolute current velocity (initial + ! and inc.) in W3UCUR. + ! CD0-I R.A. Public Current direction (initial and + ! increment) in W3UCUR. + ! UA0-I R.A. Public Absolute wind speeds (initial and + ! incr.) in W3UWND (m/s) + ! UD0-I R.A. Public Wind direction (initial and incr.) + ! in W3UWND (rad) + ! AS0-I R.A. Public Stability par. (initial and incr.) + ! in W3UWND (degr) + ! MA0-I R.A. Public Absolute atmospheric momentum (initial + ! and inc.) in W3UTAU. + ! RA0-I R.A. Public Absolute air density (initial and inc.) + ! in W3URHO. + ! MD0-I R.A. Public Atmospheric momentum direction (initial and + ! increment) in W3UTAU. + ! ATRNX/Y R.A. Public Actual transparency info. + ! + ! Fields of mean wave parameters: + ! + ! DW R.A. Public Water depths. + ! UA R.A. Public Absolute wind speeds. + ! UD R.A. Public Absolute wind direction. + ! U10 R.A. Public Wind speed used. + ! U10D R.A. Public Wind direction used. + ! AS R.A. Public Stability parameter. + ! CX/Y R.A. Public Current components. + ! TAUA R.A. Public Absolute atmospheric momentum. + ! TAUADIR R.A. Public Absolute atmospheric momentum direction. + ! + ! HS R.A. Public Wave Height. + ! WLM R.A. Public Mean wave length. + ! T02 R.A. Public Mean wave period (m0,2). + ! T0M1 R.A. Public Mean wave period (m0,-1). + ! T01 R.A. Public Mean wave period (m0,1). + ! FP0 R.A. Public Peak frequency. + ! THM R.A. Public Mean wave direction. + ! THS R.A. Public Mean directional spread. + ! THP0 R.A. Public Peak direction. + ! HSIG R.A. Public Height of infragravity waves + ! STMAXE R.A. Public Expected maximum surface elevation (crest) + ! STMAXD R.A. Public STD of maximum surface elevation + ! HMAXE R.A. Public Expected maximum wave height (from covariance) + ! HMAXD R.A. Public Std of HMAXE + ! HCMAXE R.A. Public Expected maximum wave height (from crest) + ! HCMAXD R.A. Public STD of HCMAXE + ! WBT R.A. Public Dominant wave breaking probability + ! (b_T in Babanin et al. (2001, JGR)) + ! WNMEAN R.A. Public Mean wave number + ! + ! CHARN R.A. Public Charnock parameter for air-sea friction. + ! TWS R.A. Public Wind sea period (used for flux parameterizations) + ! CGE R.A. Public Energy flux. + ! PHIAW R.A. Public Wind to wave energy flux. + ! TAUWIX/Y R.A. Public Wind to wave energy flux. + ! TAUWNX/Y R.A. Public Wind to wave energy flux. + ! WHITECAP R.A. Public 1 : Whitecap coverage + ! 2 : Whitecap thickness + ! 3 : Mean breaking height + ! 4 : Mean breaking height + ! + ! Sxx R.A. Public Radiation stresses. + ! TAUOX/Y R.A. Public Wave-ocean momentum flux. + ! BHD R.A. Public Wave-induced pressure (J term, Smith JPO 2006) + ! PHIOC R.A. Public Waves to ocean energy flux. + ! TUSX/Y R.A. Public Volume transport associated to Stokes drift. + ! USSX/Y R.A. Public Surface Stokes drift. + ! TAUOCX/Y R.A. Public Total ocean momentum flux + ! TAUICE R.A. Public Wave-ice momentum flux. + ! PHICE R.A. Public Waves to ice energy flux. + ! + ! US3D R.A. Public 3D Stokes drift. + ! USSP R.A. Public Partitioned Surface Stokes drift + ! + ! ABA R.A. Public Near-bottom rms wave ex. amplitude. + ! ABD R.A. Public Corresponding direction. + ! UBA R.A. Public Near-bottom rms wave velocity. + ! UBD R.A. Public Corresponding direction. + ! BEDFORMS R.A. Public Bed for parameters + ! PHIBBL R.A. Public Energy loss in WBBL. + ! TAUBBL R.A. Public Momentum loss in WBBL. + ! + ! MSSX/Y R.A. Public Surface mean square slopes in X and Y direction. + ! MSCX/Y R.A. Public Phillips constant. + ! MSSD R.A. Public Direction of MSSX + ! MSCD R.A. Public Direction of MSCX + ! QP R.A. Public Goda peakedness parameter. + ! + ! DTDYN R.A. Public Mean dynamic time step (raw). + ! FCUT R.A. Public Cut-off frequency for tail. + ! CFLXYMAX R.A. Public Max. CFL number for spatial advection. + ! CFLTHMAX R.A. Public Max. CFL number for refraction. + ! CFLKMAX R.A. Public Max. CFL number for wavenumber shift. + ! + ! Orphans, commented out here, now automatic arrays in W3WAVE, .... + ! + ! DRAT R.A. Public Density ration air/water. Was + ! placeholder only. Now scalar in W3SRCE, + ! TAUWX/Y R.A. Public Stresses. + ! + ! Derivatives in space .... + ! + ! DDDx R.A. Public Spatial derivatives of the depth. + ! DCxDx R.A. Public Spatial dirivatives of the current. + ! + ! Mean parameters from partitiones spectra, 2D array with el. + ! 0 holding wind sea data, and 1:NOSWLL holding swell fields. + ! Last two arrays are regular single-entry arrays. + ! + ! PHS R.A. Public Wave height of partition. + ! PTP R.A. Public Peak period of partition. + ! PLP R.A. Public Peak wave leingth of partition. + ! PDIR R.A. Public Mean direction of partition. + ! PSI R.A. Public Mean spread of partition. + ! PWS R.A. Public Wind sea fraction of partition. + ! + ! PWST R.A. Public Total wind sea fraction. + ! PNR R.A. Public Number of partitions found. + ! + ! PTHP0 R.A. Public Peak wave direction of partition. + ! PQP R.A. Public Goda peakdedness parameter of partition. + ! PPE R.A. Public JONSWAP peak enhancement factor of partition. + ! PGW R.A. Public Gaussian frequency width of partition. + ! PSW R.A. Public Spectral width of partition. + ! PTM1 R.A. Public Mean wave period (m-1,0) of partition. + ! PT1 R.A. Public Mean wave period (m0,1) of partition. + ! PT2 R.A. Public Mean wave period (m0,2) of partition. + ! PEP R.A. Public Peak spectral density of partition. + ! + ! Empty dummy fields (NOEXTR) + ! + ! USERO R.A. Public Empty output arrays than can be + ! used by users as a simple means to + ! add output. + ! + ! Map data for propagation schemes (1Up). + ! + ! IS0/2 I.A. Public Spectral propagation maps. + ! FACVX/Y R.A. Public Spatial propagation factor map. + ! + ! Map data for propagation schemes (UQ). + ! + ! NMXn Int. Public Counters for MAPX2, see W3MAP3. + ! NMYn Int. Public + ! NMXY Int. Public Dimension of MAPXY. + ! NACTn Int. Public Dimension of MAPAXY. + ! NCENT Int. Public Dimension of MAPAXY. + ! MAPX2 I.A. Public Map for prop. in 'x' (longitude) dir. + ! MAPY2 I.A. Public Idem in y' (latitude) direction. + ! MAPXY I.A. Public + ! MAPAXY I.A. Public List of active points used in W3QCK1. + ! MAPCXY I.A. Public List of central points used in avg. + ! MAPTH2 I.A. Public Like MAPX2 for refraction (rotated + ! and shifted, see W3KTP3). Like MAPAXY. + ! MAPWN2 I.A. Public Like MAPX2 for wavenumber shift. + ! MAPTRN L.A. Public Map to block out GSE mitigation in + ! proper grid points. + ! + ! Nonlinear interactions ( !/NL1 ) : + ! + ! NFR Int. Public Nuber of frequencies ( NFR = NK ) + ! NFRHGH Int. Public Auxiliary frequency counter. + ! NFRCHG Int. Public Id. + ! NSPECX-Y Int. Public Auxiliary spectral counter. + ! IPnn I.A. Public Spectral address for Snl. + ! IMnn I.A. Public Id. + ! ICnn I.A. Public Id. + ! DALn Real Public Lambda dependend weight factors. + ! AWGn Real Public Interpolation weights for Snl. + ! SWGn Real Public Interpolation weights for diag. term. + ! AF11 R.A. Public Scaling array (f**11) + ! NLINIT Log. Public Flag for initialization. + ! + ! MPP / MPI variables : + ! + ! IAPPRO I.A. Public Processor numbers for propagation calc. + ! for each spectral component. + ! MPI_COMM_WAVE + ! Int. Public Communicator used in the wave model. + ! MPI_COMM_WCMP + ! Int. Public Idem, computational proc. only. + ! WW3_FIELD_VEC, WW3_SPEC_VEC + ! Int. Public MPI derived vecor types. + ! NRQSG1 Int. Public Number of handles in IRQSG1. + ! NRQSG2 Int. Public Number of handles in IRQSG2. + ! IBFLOC Int. Public Present active buffer number. + ! ISPLOC Int. Public Corresponding local spectral bin number + ! (1,NSPLOC,1). + ! NSPLOC Int. Public Total number of spectral bins for which + ! prop. is performed on present CPU. + ! BSTAT I.A. Public Status of buffer (size MPIBUF): + ! 0: Inactive. + ! 1: A --> STORE (active or finished). + ! 2: STORE --> A (active or finished). + ! BISPL I.A. Public Local spectral bin number for buffer + ! (size MPIBUF). + ! IRQSG1 I.A. Public MPI request handles for scatters and + ! gathers to A() (persistent). + ! IRQSG2 I.A. Public MPI request handles for gathers and + ! scatters to STORE (persistent). + ! G/SSTORE R.A. Public Communication buffer (NSEA,MPIBUF). + ! SPPNT R.A. Public Point output buffer. + ! + ! Other: + ! + ! ITIME Int. Public Discrete time step counter. + ! IPASS Int. Public Pass counter for log file. + ! IDLAST Int. Public Last day ID for log file. + ! NSEALM Int. Public Maximum number of local sea points. + ! ALPHA R.A. Public Phillips' alpha. + ! FLCOLD Log. Public Flag for 'cold start' of model. + ! FLIWND Log. Public Flag for initialization of model + ! based on wind. + ! AINIT(2) Log. Public Flag for array initialization. + ! FL_ALL Log. Public Flag for all/partial initialization. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3NAUX Subr. Public Set number of grids/models. + ! W3DIMA Subr. Public Set dimensions of arrays. + ! W3DMNL Subr. Public Set dimensions of arrays. ( !/NL1 ) + ! W3SETA Subr. Public Point to selected grid / model. + ! W3XETA Subr. Public Like W3SETA for expanded output arrays. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to proper model grid. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - The number of grids is taken from W3GDATMD, and needs to be + ! set first with W3DIMG. + ! + ! 6. Switches : + ! + ! !/SHRD, !/DIST, !/MPI + ! Shared / distributed memory model + ! + ! !/PRn Propagation scheme selection. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + !/ Module private variable for checking error returns + !/ + INTEGER, PRIVATE :: ISTAT + !/ + !/ Conventional declarations + !/ + INTEGER :: NADATA = -1, IADATA = -1 #ifdef W3_MPI - INTEGER, PARAMETER :: MPIBUF = 6 -#endif -!/ -!/ Data structure WADAT -!/ - TYPE WADAT -! -! The grid -! - REAL, POINTER :: CG(:,:), WN(:,:) + INTEGER, PARAMETER :: MPIBUF = 6 +#endif + !/ + !/ Data structure WADAT + !/ + TYPE WADAT + ! + ! The grid + ! + REAL, POINTER :: CG(:,:), WN(:,:) #ifdef W3_IC3 - REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) -#endif -! -! Arrays for processing model input -! - REAL, POINTER :: CA0(:), CAI(:), CD0(:), CDI(:), & - UA0(:), UAI(:), UD0(:), UDI(:), & - MA0(:), MAI(:), RA0(:), RAI(:), & - MD0(:), MDI(:), AS0(:), ASI(:), & - ATRNX(:,:), ATRNY(:,:) -! -! Output fields group 1) -! - REAL, POINTER :: DW(:), UA(:), UD(:), U10(:), U10D(:),& - AS(:), CX(:), CY(:), TAUA(:), TAUADIR(:) -! -! Output fields group 2) -! - REAL, POINTER :: HS(:), WLM(:), T02(:), T0M1(:), & - T01 (:), FP0(:), THM(:), & - THS(:), THP0(:), & - HSIG(:), STMAXE(:), STMAXD(:), & - HMAXE(:), HCMAXE(:), HMAXD(:), & - HCMAXD(:), QP(:), WBT(:), WNMEAN(:) - REAL, POINTER :: XHS(:), XWLM(:), XT02(:), XT0M1(:), & - XT01 (:), XFP0(:), XTHM(:), & - XTHS(:), XTHP0(:), & - XHSIG(:), XSTMAXE(:), XSTMAXD(:), & - XHMAXE(:), XHCMAXE(:), XHMAXD(:), & - XHCMAXD(:), XQP(:), XWBT(:), & - XWNMEAN(:) -! -! Output fields group 3) -! - REAL, POINTER :: EF(:,:), TH1M(:,:), STH1M(:,:), & - TH2M(:,:), STH2M(:,:) !, WN(:,:) - REAL, POINTER :: XEF(:,:), XTH1M(:,:), XSTH1M(:,:),& - XTH2M(:,:), XSTH2M(:,:) !, XWN(:,:) -! -! Output fields group 4) -! - REAL, POINTER :: PHS(:,:), PTP(:,:), PLP(:,:), & - PDIR(:,:), PSI(:,:), PWS(:,:), & - PWST(:), PNR(:), PGW(:,:), & - PTHP0(:,:), PQP(:,:), PPE(:,:), & - PSW(:,:), PTM1(:,:), PT1(:,:), & - PT2(:,:), PEP(:,:) - REAL, POINTER :: XPHS(:,:), XPTP(:,:), XPLP(:,:), & - XPDIR(:,:), XPSI(:,:), XPWS(:,:), & - XPWST(:), XPNR(:), XPGW(:,:), & - XPTHP0(:,:), XPQP(:,:), XPPE(:,:), & - XPSW(:,:), XPTM1(:,:), XPT1(:,:), & - XPT2(:,:), XPEP(:,:) -! -! Output fields group 5) -! - REAL, POINTER :: CHARN(:), CGE(:), PHIAW(:), & - TAUWIX(:), TAUWIY(:), TAUWNX(:), & - TAUWNY(:), WHITECAP(:,:), TWS(:) - REAL, POINTER :: XCHARN(:), XCGE(:), XPHIAW(:), & - XTAUWIX(:), XTAUWIY(:), XTAUWNX(:), & - XTAUWNY(:), XWHITECAP(:,:), XTWS(:) -! -! Output fields group 6) -! - REAL, POINTER :: SXX(:), SYY(:), SXY(:), TAUOX(:),& - TAUOY(:), BHD(:), PHIOC(:), & - TUSX(:), TUSY(:), USSX(:), & - USSY(:), TAUOCX(:), TAUOCY(:), & - PRMS(:), TPMS(:), PHICE(:), & - TAUICE(:,:) - REAL, POINTER :: P2SMS(:,:), US3D(:,:), USSP(:,:) - REAL, POINTER :: XSXX(:), XSYY(:), XSXY(:), XTAUOX(:),& - XTAUOY(:), XBHD(:), XPHIOC(:), & - XTUSX(:), XTUSY(:), XUSSX(:), & - XUSSY(:), XTAUOCX(:), XTAUOCY(:), & - XPRMS(:), XTPMS(:), XPHICE(:), & - XTAUICE(:,:) - REAL, POINTER :: XP2SMS(:,:), XUS3D(:,:), XUSSP(:,:) + REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) +#endif + ! + ! Arrays for processing model input + ! + REAL, POINTER :: CA0(:), CAI(:), CD0(:), CDI(:), & + UA0(:), UAI(:), UD0(:), UDI(:), & + MA0(:), MAI(:), RA0(:), RAI(:), & + MD0(:), MDI(:), AS0(:), ASI(:), & + ATRNX(:,:), ATRNY(:,:) + ! + ! Output fields group 1) + ! + REAL, POINTER :: DW(:), UA(:), UD(:), U10(:), U10D(:),& + AS(:), CX(:), CY(:), TAUA(:), TAUADIR(:) + ! + ! Output fields group 2) + ! + REAL, POINTER :: HS(:), WLM(:), T02(:), T0M1(:), & + T01 (:), FP0(:), THM(:), & + THS(:), THP0(:), & + HSIG(:), STMAXE(:), STMAXD(:), & + HMAXE(:), HCMAXE(:), HMAXD(:), & + HCMAXD(:), QP(:), WBT(:), WNMEAN(:) + REAL, POINTER :: XHS(:), XWLM(:), XT02(:), XT0M1(:), & + XT01 (:), XFP0(:), XTHM(:), & + XTHS(:), XTHP0(:), & + XHSIG(:), XSTMAXE(:), XSTMAXD(:), & + XHMAXE(:), XHCMAXE(:), XHMAXD(:), & + XHCMAXD(:), XQP(:), XWBT(:), & + XWNMEAN(:) + ! + ! Output fields group 3) + ! + REAL, POINTER :: EF(:,:), TH1M(:,:), STH1M(:,:), & + TH2M(:,:), STH2M(:,:) !, WN(:,:) + REAL, POINTER :: XEF(:,:), XTH1M(:,:), XSTH1M(:,:),& + XTH2M(:,:), XSTH2M(:,:) !, XWN(:,:) + ! + ! Output fields group 4) + ! + REAL, POINTER :: PHS(:,:), PTP(:,:), PLP(:,:), & + PDIR(:,:), PSI(:,:), PWS(:,:), & + PWST(:), PNR(:), PGW(:,:), & + PTHP0(:,:), PQP(:,:), PPE(:,:), & + PSW(:,:), PTM1(:,:), PT1(:,:), & + PT2(:,:), PEP(:,:) + REAL, POINTER :: XPHS(:,:), XPTP(:,:), XPLP(:,:), & + XPDIR(:,:), XPSI(:,:), XPWS(:,:), & + XPWST(:), XPNR(:), XPGW(:,:), & + XPTHP0(:,:), XPQP(:,:), XPPE(:,:), & + XPSW(:,:), XPTM1(:,:), XPT1(:,:), & + XPT2(:,:), XPEP(:,:) + ! + ! Output fields group 5) + ! + REAL, POINTER :: CHARN(:), CGE(:), PHIAW(:), & + TAUWIX(:), TAUWIY(:), TAUWNX(:), & + TAUWNY(:), WHITECAP(:,:), TWS(:) + REAL, POINTER :: XCHARN(:), XCGE(:), XPHIAW(:), & + XTAUWIX(:), XTAUWIY(:), XTAUWNX(:), & + XTAUWNY(:), XWHITECAP(:,:), XTWS(:) + ! + ! Output fields group 6) + ! + REAL, POINTER :: SXX(:), SYY(:), SXY(:), TAUOX(:),& + TAUOY(:), BHD(:), PHIOC(:), & + TUSX(:), TUSY(:), USSX(:), & + USSY(:), TAUOCX(:), TAUOCY(:), & + PRMS(:), TPMS(:), PHICE(:), & + TAUICE(:,:) + REAL, POINTER :: P2SMS(:,:), US3D(:,:), USSP(:,:) + REAL, POINTER :: XSXX(:), XSYY(:), XSXY(:), XTAUOX(:),& + XTAUOY(:), XBHD(:), XPHIOC(:), & + XTUSX(:), XTUSY(:), XUSSX(:), & + XUSSY(:), XTAUOCX(:), XTAUOCY(:), & + XPRMS(:), XTPMS(:), XPHICE(:), & + XTAUICE(:,:) + REAL, POINTER :: XP2SMS(:,:), XUS3D(:,:), XUSSP(:,:) #ifdef W3_CESMCOUPLED - REAL, POINTER :: XLANGMT(:) -#endif -! -! Output fields group 7) -! - REAL, POINTER :: ABA(:), ABD(:), UBA(:), UBD(:), & - BEDFORMS(:,:), PHIBBL(:), & - TAUBBL(:,:) - REAL, POINTER :: XABA(:), XABD(:), XUBA(:), XUBD(:), & - XBEDFORMS(:,:), XPHIBBL(:), & - XTAUBBL(:,:) -! -! Output fields group 8) -! - REAL, POINTER :: MSSX(:), MSSY(:), MSSD(:), & - MSCX(:), MSCY(:), MSCD(:) - REAL, POINTER :: XMSSX(:), XMSSY(:), XMSSD(:), & - XMSCX(:), XMSCY(:), XMSCD(:) -! -! Output fields group 9) -! - REAL, POINTER :: DTDYN(:), FCUT(:), CFLXYMAX(:), & - CFLTHMAX(:), CFLKMAX(:) - REAL, POINTER :: XDTDYN(:), XFCUT(:), XCFLXYMAX(:), & - XCFLTHMAX(:), XCFLKMAX(:) -! -! Output fields group 10) -! - REAL, POINTER :: USERO(:,:) - REAL, POINTER :: XUSERO(:,:) + REAL, POINTER :: XLANGMT(:) +#endif + ! + ! Output fields group 7) + ! + REAL, POINTER :: ABA(:), ABD(:), UBA(:), UBD(:), & + BEDFORMS(:,:), PHIBBL(:), & + TAUBBL(:,:) + REAL, POINTER :: XABA(:), XABD(:), XUBA(:), XUBD(:), & + XBEDFORMS(:,:), XPHIBBL(:), & + XTAUBBL(:,:) + ! + ! Output fields group 8) + ! + REAL, POINTER :: MSSX(:), MSSY(:), MSSD(:), & + MSCX(:), MSCY(:), MSCD(:) + REAL, POINTER :: XMSSX(:), XMSSY(:), XMSSD(:), & + XMSCX(:), XMSCY(:), XMSCD(:) + ! + ! Output fields group 9) + ! + REAL, POINTER :: DTDYN(:), FCUT(:), CFLXYMAX(:), & + CFLTHMAX(:), CFLKMAX(:) + REAL, POINTER :: XDTDYN(:), XFCUT(:), XCFLXYMAX(:), & + XCFLTHMAX(:), XCFLKMAX(:) + ! + ! Output fields group 10) + ! + REAL, POINTER :: USERO(:,:) + REAL, POINTER :: XUSERO(:,:) #ifdef W3_CESMCOUPLED - ! Output fileds for Langmuir mixing in group - REAL, POINTER :: LANGMT(:), LAPROJ(:), LASL(:), & - LASLPJ(:), LAMULT(:), ALPHAL(:), & - ALPHALS(:), USSXH(:), USSYH(:) -#endif -! -! Spatial derivatives -! - REAL, POINTER :: DDDX(:,:), DDDY(:,:), DCXDX(:,:), & - DCYDX(:,:), DCXDY(:,:), DCYDY(:,:) - REAL, POINTER :: DCDX(:,:,:), DCDY(:,:,:) + ! Output fileds for Langmuir mixing in group + REAL, POINTER :: LANGMT(:), LAPROJ(:), LASL(:), & + LASLPJ(:), LAMULT(:), ALPHAL(:), & + ALPHALS(:), USSXH(:), USSYH(:) +#endif + ! + ! Spatial derivatives + ! + REAL, POINTER :: DDDX(:,:), DDDY(:,:), DCXDX(:,:), & + DCYDX(:,:), DCXDY(:,:), DCYDY(:,:) + REAL, POINTER :: DCDX(:,:,:), DCDY(:,:,:) #ifdef W3_SMC - REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) + REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) #endif -! + ! #ifdef W3_PR1 - INTEGER, POINTER :: IS0(:), IS2(:) - REAL, POINTER :: FACVX(:), FACVY(:) + INTEGER, POINTER :: IS0(:), IS2(:) + REAL, POINTER :: FACVX(:), FACVY(:) #endif -! + ! #ifdef W3_PR2 - INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & - NACT, NMXY - INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & - MAPXY(:), MAPTH2(:), MAPWN2(:) + INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & + NACT, NMXY + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & + MAPXY(:), MAPTH2(:), MAPWN2(:) #endif -! + ! #ifdef W3_PR3 - INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & - NACT, NCENT - INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & - MAPCXY(:), MAPTH2(:), MAPWN2(:) - LOGICAL, POINTER :: MAPTRN(:) -#endif -! -! Warning Defined but not set if UGTYPE .EQ. .T. - INTEGER, POINTER :: ITER(:,:) -! + INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & + NACT, NCENT + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & + MAPCXY(:), MAPTH2(:), MAPWN2(:) + LOGICAL, POINTER :: MAPTRN(:) +#endif + ! + ! Warning Defined but not set if UGTYPE .EQ. .T. + INTEGER, POINTER :: ITER(:,:) + ! #ifdef W3_NL1 - INTEGER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY - INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:), & - IM11(:), IM12(:), IM13(:), IM14(:), & - IP21(:), IP22(:), IP23(:), IP24(:), & - IM21(:), IM22(:), IM23(:), IM24(:), & - IC11(:), IC12(:), IC21(:), IC22(:), & - IC31(:), IC32(:), IC41(:), IC42(:), & - IC51(:), IC52(:), IC61(:), IC62(:), & - IC71(:), IC72(:), IC81(:), IC82(:) - REAL :: DAL1, DAL2, DAL3, & - AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, & - AWG7, AWG8, SWG1, SWG2, SWG3, SWG4, & - SWG5, SWG6, SWG7, SWG8 - REAL, POINTER :: AF11(:) - LOGICAL :: NLINIT -#endif -! - INTEGER, POINTER :: IAPPRO(:) + INTEGER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY + INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:), & + IM11(:), IM12(:), IM13(:), IM14(:), & + IP21(:), IP22(:), IP23(:), IP24(:), & + IM21(:), IM22(:), IM23(:), IM24(:), & + IC11(:), IC12(:), IC21(:), IC22(:), & + IC31(:), IC32(:), IC41(:), IC42(:), & + IC51(:), IC52(:), IC61(:), IC62(:), & + IC71(:), IC72(:), IC81(:), IC82(:) + REAL :: DAL1, DAL2, DAL3, & + AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, & + AWG7, AWG8, SWG1, SWG2, SWG3, SWG4, & + SWG5, SWG6, SWG7, SWG8 + REAL, POINTER :: AF11(:) + LOGICAL :: NLINIT +#endif + ! + INTEGER, POINTER :: IAPPRO(:) #ifdef W3_MPI - INTEGER :: MPI_COMM_WAVE, MPI_COMM_WCMP, & - WW3_FIELD_VEC, WW3_SPEC_VEC, & - NRQSG1 = 0, NRQSG2, IBFLOC, ISPLOC, & - NSPLOC + INTEGER :: MPI_COMM_WAVE, MPI_COMM_WCMP, & + WW3_FIELD_VEC, WW3_SPEC_VEC, & + NRQSG1 = 0, NRQSG2, IBFLOC, ISPLOC, & + NSPLOC #endif #ifdef W3_PDLIB - INTEGER :: NBFIELD, PDLIB_MPI_TYPE + INTEGER :: NBFIELD, PDLIB_MPI_TYPE #endif #ifdef W3_MPI - INTEGER :: BSTAT(MPIBUF), BISPL(MPIBUF) - INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) - REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) -#endif - REAL, POINTER :: SPPNT(:,:,:) -! - INTEGER :: ITIME, IPASS, IDLAST, NSEALM - REAL, POINTER :: ALPHA(:,:) - LOGICAL :: AINIT, AINIT2, FL_ALL, FLCOLD, FLIWND -! - END TYPE WADAT -!/ -!/ Data storage -!/ - TYPE(WADAT), TARGET, ALLOCATABLE :: WADATS(:) -!/ -!/ Data aliases for structure WADAT(S) -!/ + INTEGER :: BSTAT(MPIBUF), BISPL(MPIBUF) + INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) + REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) +#endif + REAL, POINTER :: SPPNT(:,:,:) + ! + INTEGER :: ITIME, IPASS, IDLAST, NSEALM + REAL, POINTER :: ALPHA(:,:) + LOGICAL :: AINIT, AINIT2, FL_ALL, FLCOLD, FLIWND + ! + END TYPE WADAT + !/ + !/ Data storage + !/ + TYPE(WADAT), TARGET, ALLOCATABLE :: WADATS(:) + !/ + !/ Data aliases for structure WADAT(S) + !/ #ifdef W3_CESMCOUPLED - REAL, POINTER :: LANGMT(:), LAPROJ(:), ALPHAL(:), & - ALPHALS(:), LAMULT(:), LASL(:), & - LASLPJ(:), USSXH(:), USSYH(:) -#endif - REAL, POINTER :: CG(:,:), WN(:,:) - REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) -! - REAL, POINTER :: CA0(:), CAI(:), CD0(:), CDI(:), & - UA0(:), UAI(:), UD0(:), UDI(:), & - MA0(:), MAI(:), RA0(:), RAI(:), & - MD0(:), MDI(:), AS0(:), ASI(:), & - ATRNX(:,:), ATRNY(:,:) -! - REAL, POINTER :: DW(:), UA(:), UD(:), U10(:), U10D(:),& - AS(:), CX(:), CY(:), TAUA(:), TAUADIR(:) -! - REAL, POINTER :: HS(:), WLM(:), T02(:), T0M1(:), & - T01 (:), FP0(:), THM(:), THS(:), & - THP0(:), HSIG(:), & - STMAXE(:), STMAXD(:), HMAXE(:), & - HCMAXE(:), HMAXD(:), HCMAXD(:), & - QP(:), WBT(:), WNMEAN(:) -! - REAL, POINTER :: EF(:,:), TH1M(:,:), STH1M(:,:), & - TH2M(:,:), STH2M(:,:) -! - REAL, POINTER :: PHS(:,:), PTP(:,:), PLP(:,:), & - PDIR(:,:), PSI(:,:), PWS(:,:), & - PWST(:), PNR(:), PGW(:,:), PSW(:,:), & - PTHP0(:,:), PQP(:,:), PPE(:,:), & - PTM1(:,:), PT1(:,:), PT2(:,:),PEP(:,:) -! - REAL, POINTER :: CHARN(:), CGE(:), PHIAW(:), & - TAUWIX(:), TAUWIY(:), TAUWNX(:), & - TAUWNY(:), WHITECAP(:,:), TWS(:) -! - REAL, POINTER :: SXX(:), SYY(:), SXY(:), TAUOX(:), & - TAUOY(:), BHD(:), PHIOC(:), & - TUSX(:), TUSY(:), USSX(:), USSY(:), & - TAUOCX(:), TAUOCY(:), PRMS(:), & - TPMS(:), PHICE(:), TAUICE(:,:) - REAL, POINTER :: P2SMS(:,:), US3D(:,:), USSP(:,:) -! - REAL, POINTER :: ABA(:), ABD(:), UBA(:), UBD(:), & - BEDFORMS(:,:), PHIBBL(:), TAUBBL(:,:) -! - REAL, POINTER :: MSSX(:), MSSY(:), MSSD(:), & - MSCX(:), MSCY(:), MSCD(:) -! - REAL, POINTER :: DTDYN(:), FCUT(:), CFLXYMAX(:), & - CFLTHMAX(:), CFLKMAX(:) -! - REAL, POINTER :: USERO(:,:) -! -! REAL, POINTER :: TAUWX(:), TAUWY(:) -! - REAL, POINTER :: DDDX(:,:), DDDY(:,:), DCXDX(:,:), & - DCYDX(:,:), DCXDY(:,:), DCYDY(:,:) - REAL, POINTER :: DCDX(:,:,:), DCDY(:,:,:) + REAL, POINTER :: LANGMT(:), LAPROJ(:), ALPHAL(:), & + ALPHALS(:), LAMULT(:), LASL(:), & + LASLPJ(:), USSXH(:), USSYH(:) +#endif + REAL, POINTER :: CG(:,:), WN(:,:) + REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) + ! + REAL, POINTER :: CA0(:), CAI(:), CD0(:), CDI(:), & + UA0(:), UAI(:), UD0(:), UDI(:), & + MA0(:), MAI(:), RA0(:), RAI(:), & + MD0(:), MDI(:), AS0(:), ASI(:), & + ATRNX(:,:), ATRNY(:,:) + ! + REAL, POINTER :: DW(:), UA(:), UD(:), U10(:), U10D(:),& + AS(:), CX(:), CY(:), TAUA(:), TAUADIR(:) + ! + REAL, POINTER :: HS(:), WLM(:), T02(:), T0M1(:), & + T01 (:), FP0(:), THM(:), THS(:), & + THP0(:), HSIG(:), & + STMAXE(:), STMAXD(:), HMAXE(:), & + HCMAXE(:), HMAXD(:), HCMAXD(:), & + QP(:), WBT(:), WNMEAN(:) + ! + REAL, POINTER :: EF(:,:), TH1M(:,:), STH1M(:,:), & + TH2M(:,:), STH2M(:,:) + ! + REAL, POINTER :: PHS(:,:), PTP(:,:), PLP(:,:), & + PDIR(:,:), PSI(:,:), PWS(:,:), & + PWST(:), PNR(:), PGW(:,:), PSW(:,:), & + PTHP0(:,:), PQP(:,:), PPE(:,:), & + PTM1(:,:), PT1(:,:), PT2(:,:),PEP(:,:) + ! + REAL, POINTER :: CHARN(:), CGE(:), PHIAW(:), & + TAUWIX(:), TAUWIY(:), TAUWNX(:), & + TAUWNY(:), WHITECAP(:,:), TWS(:) + ! + REAL, POINTER :: SXX(:), SYY(:), SXY(:), TAUOX(:), & + TAUOY(:), BHD(:), PHIOC(:), & + TUSX(:), TUSY(:), USSX(:), USSY(:), & + TAUOCX(:), TAUOCY(:), PRMS(:), & + TPMS(:), PHICE(:), TAUICE(:,:) + REAL, POINTER :: P2SMS(:,:), US3D(:,:), USSP(:,:) + ! + REAL, POINTER :: ABA(:), ABD(:), UBA(:), UBD(:), & + BEDFORMS(:,:), PHIBBL(:), TAUBBL(:,:) + ! + REAL, POINTER :: MSSX(:), MSSY(:), MSSD(:), & + MSCX(:), MSCY(:), MSCD(:) + ! + REAL, POINTER :: DTDYN(:), FCUT(:), CFLXYMAX(:), & + CFLTHMAX(:), CFLKMAX(:) + ! + REAL, POINTER :: USERO(:,:) + ! + ! REAL, POINTER :: TAUWX(:), TAUWY(:) + ! + REAL, POINTER :: DDDX(:,:), DDDY(:,:), DCXDX(:,:), & + DCYDX(:,:), DCXDY(:,:), DCYDY(:,:) + REAL, POINTER :: DCDX(:,:,:), DCDY(:,:,:) #ifdef W3_SMC - REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) + REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) #endif -! + ! #ifdef W3_PR1 - INTEGER, POINTER :: IS0(:), IS2(:) - REAL, POINTER :: FACVX(:), FACVY(:) + INTEGER, POINTER :: IS0(:), IS2(:) + REAL, POINTER :: FACVX(:), FACVY(:) #endif -! + ! #ifdef W3_PR2 - INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & - NACT, NMXY - INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & - MAPXY(:), MAPTH2(:), MAPWN2(:) + INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & + NACT, NMXY + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & + MAPXY(:), MAPTH2(:), MAPWN2(:) #endif -! + ! #ifdef W3_PR3 - INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & - NACT, NCENT - INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & - MAPCXY(:), MAPTH2(:), MAPWN2(:) - LOGICAL, POINTER :: MAPTRN(:) -#endif -! - INTEGER, POINTER :: ITER(:,:) -! + INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & + NACT, NCENT + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & + MAPCXY(:), MAPTH2(:), MAPWN2(:) + LOGICAL, POINTER :: MAPTRN(:) +#endif + ! + INTEGER, POINTER :: ITER(:,:) + ! #ifdef W3_NL1 - INTEGER, POINTER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY - INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:), & - IM11(:), IM12(:), IM13(:), IM14(:), & - IP21(:), IP22(:), IP23(:), IP24(:), & - IM21(:), IM22(:), IM23(:), IM24(:), & - IC11(:), IC12(:), IC21(:), IC22(:), & - IC31(:), IC32(:), IC41(:), IC42(:), & - IC51(:), IC52(:), IC61(:), IC62(:), & - IC71(:), IC72(:), IC81(:), IC82(:) - REAL, POINTER :: DAL1, DAL2, DAL3, & - AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, & - AWG7, AWG8, SWG1, SWG2, SWG3, SWG4, & - SWG5, SWG6, SWG7, SWG8 - REAL, POINTER :: AF11(:) - LOGICAL, POINTER :: NLINIT -#endif -! - INTEGER, POINTER :: IAPPRO(:) + INTEGER, POINTER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY + INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:), & + IM11(:), IM12(:), IM13(:), IM14(:), & + IP21(:), IP22(:), IP23(:), IP24(:), & + IM21(:), IM22(:), IM23(:), IM24(:), & + IC11(:), IC12(:), IC21(:), IC22(:), & + IC31(:), IC32(:), IC41(:), IC42(:), & + IC51(:), IC52(:), IC61(:), IC62(:), & + IC71(:), IC72(:), IC81(:), IC82(:) + REAL, POINTER :: DAL1, DAL2, DAL3, & + AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, & + AWG7, AWG8, SWG1, SWG2, SWG3, SWG4, & + SWG5, SWG6, SWG7, SWG8 + REAL, POINTER :: AF11(:) + LOGICAL, POINTER :: NLINIT +#endif + ! + INTEGER, POINTER :: IAPPRO(:) #ifdef W3_MPI - INTEGER, POINTER :: MPI_COMM_WAVE, MPI_COMM_WCMP, & - WW3_FIELD_VEC, WW3_SPEC_VEC, & - NRQSG1, NRQSG2, IBFLOC, ISPLOC, & - NSPLOC - INTEGER, POINTER :: BSTAT(:), BISPL(:) - INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) - REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) -#endif - REAL, POINTER :: SPPNT(:,:,:) -! - INTEGER, POINTER :: ITIME, IPASS, IDLAST, NSEALM - REAL, POINTER :: ALPHA(:,:) - LOGICAL, POINTER :: AINIT, AINIT2, FL_ALL, FLCOLD, FLIWND + INTEGER, POINTER :: MPI_COMM_WAVE, MPI_COMM_WCMP, & + WW3_FIELD_VEC, WW3_SPEC_VEC, & + NRQSG1, NRQSG2, IBFLOC, ISPLOC, & + NSPLOC + INTEGER, POINTER :: BSTAT(:), BISPL(:) + INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) + REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) +#endif + REAL, POINTER :: SPPNT(:,:,:) + ! + INTEGER, POINTER :: ITIME, IPASS, IDLAST, NSEALM + REAL, POINTER :: ALPHA(:,:) + LOGICAL, POINTER :: AINIT, AINIT2, FL_ALL, FLCOLD, FLIWND #ifdef W3_MEMCHECK - type(MallInfo_t) :: mallinfos + type(MallInfo_t) :: mallinfos #endif -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Set up the number of grids to be used. -!> -!> @details Use data stored in NGRIDS in W3GDATMD. -!> -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author H. L. Tolman -!> @date 10-Dec-2014 -!> - SUBROUTINE W3NAUX ( NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 14-Dec-2004 : Origination. ( version 3.06 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Set up the number of grids to be used. -! -! 2. Method : -! -! Use data stored in NGRIDS in W3GDATMD. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program that uses this grid structure. -! -! 6. Error messages : -! -! - Error checks on previous setting of variable NGRIDS. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: IAPROC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Set up the number of grids to be used. + !> + !> @details Use data stored in NGRIDS in W3GDATMD. + !> + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author H. L. Tolman + !> @date 10-Dec-2014 + !> + SUBROUTINE W3NAUX ( NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 14-Dec-2004 : Origination. ( version 3.06 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Set up the number of grids to be used. + ! + ! 2. Method : + ! + ! Use data stored in NGRIDS in W3GDATMD. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program that uses this grid structure. + ! + ! 6. Error messages : + ! + ! - Error checks on previous setting of variable NGRIDS. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: IAPROC #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3NAUX') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) NGRIDS - CALL EXTCDE (1) - END IF -! -! -------------------------------------------------------------------- / -! 2. Set variable and allocate arrays -! - ALLOCATE ( WADATS(NGRIDS), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - NADATA = NGRIDS -! -! -------------------------------------------------------------------- / -! 3. Initialize parameters -! - DO I=1, NGRIDS - WADATS(I)%ITIME = 0 - WADATS(I)%IPASS = 0 - WADATS(I)%IDLAST = 0 - WADATS(I)%NSEALM = 0 - WADATS(I)%FLCOLD = .FALSE. - WADATS(I)%FLIWND = .FALSE. - WADATS(I)%AINIT = .FALSE. - WADATS(I)%AINIT2 = .FALSE. - WADATS(I)%FL_ALL = .FALSE. + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3NAUX') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) NGRIDS + CALL EXTCDE (1) + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Set variable and allocate arrays + ! + ALLOCATE ( WADATS(NGRIDS), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + NADATA = NGRIDS + ! + ! -------------------------------------------------------------------- / + ! 3. Initialize parameters + ! + DO I=1, NGRIDS + WADATS(I)%ITIME = 0 + WADATS(I)%IPASS = 0 + WADATS(I)%IDLAST = 0 + WADATS(I)%NSEALM = 0 + WADATS(I)%FLCOLD = .FALSE. + WADATS(I)%FLIWND = .FALSE. + WADATS(I)%AINIT = .FALSE. + WADATS(I)%AINIT2 = .FALSE. + WADATS(I)%FL_ALL = .FALSE. #ifdef W3_NL1 - WADATS(I)%NLINIT = .FALSE. + WADATS(I)%NLINIT = .FALSE. #endif - END DO -! + END DO + ! #ifdef W3_T - WRITE (NDST,9000) NGRIDS -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3NAUX : NGRIDS NOT YET SET *** '/ & - ' NGRIDS = ',I10/ & - ' RUN W3NMOD FIRST'/) -! + WRITE (NDST,9000) NGRIDS +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3NAUX : NGRIDS NOT YET SET *** '/ & + ' NGRIDS = ',I10/ & + ' RUN W3NMOD FIRST'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3NAUX : SETTING UP FOR ',I4,' GRIDS') -#endif -!/ -!/ End of W3NAUX ----------------------------------------------------- / -!/ - END SUBROUTINE W3NAUX -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize an individual data grid at the proper dimensions. -!> -!> @details Allocate directly into the structure array. Note that -!> this cannot be done through the pointer alias! -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> @param[in] D_ONLY Flag for initializing data arrays only. -!> -!> @author H. L. Tolman -!> @date 22-Mar-2021 -!> - SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2004 : Origination. ( version 3.06 ) -!/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 28-Mar-2007 : Add partitioned data arrays. ( version 3.11 ) -!/ Add additional undefined arrays. -!/ 22-Feb-2008 ; Modify MAPTH2 declaration. ( version 3.14 ) -!/ 31-Oct-2010 : Added initialization of CX,CY,DW ( version 3.14 ) -!/ 25-Dec-2012 : Memory reduction for outputs. ( version 4.11 ) -!/ 28-Jul-2013 : Bug fix initialization P2SMS. ( version 4.11 ) -!/ 30-Apr-2014 : Memory reduction for group3. ( version 5.00 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) -!/ -! 1. Purpose : -! -! Initialize an individual data grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! D_ONLY L.O. I FLag for initializing data arrays only. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGO Subr. W3IOGOMD Grid output IO routine. -! WW3_SHEL Prog. N/A Wave model driver. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - W3SETA needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD, !/DIST -! Shared / distributed memory model -! -! !/PRn Propagation scheme selection. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG, NK, NX, NY, NSEA, & - NSEAL, NSPEC, NTH, E3DF, P2MSF, US3DF, & - USSPF, GTYPE, UNGTYPE - USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC, NAPFLD, & - NOSWLL, NOEXTR, UNDEF, FLOGRD, FLOGR2 - USE W3IDATMD, ONLY: FLCUR, FLWIND, FLTAUA, FLRHOA - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT (' TEST W3NAUX : SETTING UP FOR ',I4,' GRIDS') +#endif + !/ + !/ End of W3NAUX ----------------------------------------------------- / + !/ + END SUBROUTINE W3NAUX + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize an individual data grid at the proper dimensions. + !> + !> @details Allocate directly into the structure array. Note that + !> this cannot be done through the pointer alias! + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> @param[in] D_ONLY Flag for initializing data arrays only. + !> + !> @author H. L. Tolman + !> @date 22-Mar-2021 + !> + SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 28-Dec-2004 : Origination. ( version 3.06 ) + !/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 28-Mar-2007 : Add partitioned data arrays. ( version 3.11 ) + !/ Add additional undefined arrays. + !/ 22-Feb-2008 ; Modify MAPTH2 declaration. ( version 3.14 ) + !/ 31-Oct-2010 : Added initialization of CX,CY,DW ( version 3.14 ) + !/ 25-Dec-2012 : Memory reduction for outputs. ( version 4.11 ) + !/ 28-Jul-2013 : Bug fix initialization P2SMS. ( version 4.11 ) + !/ 30-Apr-2014 : Memory reduction for group3. ( version 5.00 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! D_ONLY L.O. I FLag for initializing data arrays only. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGO Subr. W3IOGOMD Grid output IO routine. + ! WW3_SHEL Prog. N/A Wave model driver. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - W3SETA needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD, !/DIST + ! Shared / distributed memory model + ! + ! !/PRn Propagation scheme selection. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY : LPDLIB + USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG, NK, NX, NY, NSEA, & + NSEAL, NSPEC, NTH, E3DF, P2MSF, US3DF, & + USSPF, GTYPE, UNGTYPE + USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC, NAPFLD, & + NOSWLL, NOEXTR, UNDEF, FLOGRD, FLOGR2 + USE W3IDATMD, ONLY: FLCUR, FLWIND, FLTAUA, FLRHOA + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST - LOGICAL, INTENT(IN), OPTIONAL :: D_ONLY -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID, NXXX, NSEAL_tmp + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + LOGICAL, INTENT(IN), OPTIONAL :: D_ONLY + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID, NXXX, NSEAL_tmp #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIMA') #endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3DIMA') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 0' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 0' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) #endif - IF ( PRESENT(D_ONLY) ) THEN - FL_ALL = .NOT. D_ONLY - ELSE - FL_ALL = .TRUE. - END IF -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN - WRITE (NDSE,1002) IMOD, NADATA - CALL EXTCDE (2) - END IF -! - IF ( WADATS(IMOD)%AINIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -! + IF ( PRESENT(D_ONLY) ) THEN + FL_ALL = .NOT. D_ONLY + ELSE + FL_ALL = .TRUE. + END IF + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN + WRITE (NDSE,1002) IMOD, NADATA + CALL EXTCDE (2) + END IF + ! + IF ( WADATS(IMOD)%AINIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD + WRITE (NDST,9000) IMOD #endif -! - JGRID = IGRID - IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + ! + JGRID = IGRID + IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 1' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! Call W3SETA to assure of pointes FLCUR, FLWND, and FLTAUA -! - CALL W3SETA ( IMOD, NDSE, NDST ) + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 1' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! Call W3SETA to assure of pointes FLCUR, FLWND, and FLTAUA + ! + CALL W3SETA ( IMOD, NDSE, NDST ) -! -!AR: Check this below more ... - NXXX = NSEALM * NAPROC -! -! Output and input parameteres by output type -! -! 1) Forcing fields (these arrays are always needed) -! - ALLOCATE ( WADATS(IMOD)%DW(0:NSEA) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%DW(:)=0. -! - ALLOCATE ( WADATS(IMOD)%CX(0:NSEA) , WADATS(IMOD)%CY(0:NSEA) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%CX(:)=0. - WADATS(IMOD)%CY(:)=0. -! - ALLOCATE ( WADATS(IMOD)%UA(0:NSEA) , WADATS(IMOD)%UD(0:NSEA) , & - WADATS(IMOD)%U10(NSEA) , WADATS(IMOD)%U10D(NSEA) , & - WADATS(IMOD)%AS(0:NSEA) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - ALLOCATE ( WADATS(IMOD)%TAUA(0:NSEA) , & - WADATS(IMOD)%TAUADIR(0:NSEA), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%TAUA(:) =0. - WADATS(IMOD)%TAUADIR(:)=0. + ! + !AR: Check this below more ... + NXXX = NSEALM * NAPROC + ! + ! Output and input parameteres by output type + ! + ! 1) Forcing fields (these arrays are always needed) + ! + ALLOCATE ( WADATS(IMOD)%DW(0:NSEA) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%DW(:)=0. + ! + ALLOCATE ( WADATS(IMOD)%CX(0:NSEA) , WADATS(IMOD)%CY(0:NSEA) , & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%CX(:)=0. + WADATS(IMOD)%CY(:)=0. + ! + ALLOCATE ( WADATS(IMOD)%UA(0:NSEA) , WADATS(IMOD)%UD(0:NSEA) , & + WADATS(IMOD)%U10(NSEA) , WADATS(IMOD)%U10D(NSEA) , & + WADATS(IMOD)%AS(0:NSEA) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + ALLOCATE ( WADATS(IMOD)%TAUA(0:NSEA) , & + WADATS(IMOD)%TAUADIR(0:NSEA), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%TAUA(:) =0. + WADATS(IMOD)%TAUADIR(:)=0. #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 2' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! Water level WLV stored in W3WDATMD -! Ice concentration ICE stored in W3WDATMD -! Ice floe sizes ICEF and ICEDMAX stored in W3WDATMD -! Iceberg damping BERG stored in W3WDATMD -! -! 2) Standard mean wave parameters -! Here, all short arrays are always allocated to reduce logical -! checks in all computations. The coresponding full size arrays -! are allocated in W3MPIO only as needed to keep the memory -! footprint down. -! - IF (NSEALM .eq. 0) THEN - NSEALM=NSEA - END IF - ALLOCATE ( WADATS(IMOD)%HS (NSEALM), WADATS(IMOD)%WLM (NSEALM), & - WADATS(IMOD)%T02 (NSEALM), WADATS(IMOD)%T0M1(NSEALM), & - WADATS(IMOD)%T01 (NSEALM), WADATS(IMOD)%FP0 (NSEALM), & - WADATS(IMOD)%THM (NSEALM), WADATS(IMOD)%THS (NSEALM), & - WADATS(IMOD)%THP0 (NSEALM), WADATS(IMOD)%HSIG(NSEALM), & - WADATS(IMOD)%STMAXE (NSEALM), & - WADATS(IMOD)%STMAXD(NSEALM), & - WADATS(IMOD)%HMAXE(NSEALM), WADATS(IMOD)%HMAXD(NSEALM),& - WADATS(IMOD)%HCMAXE(NSEALM), & - WADATS(IMOD)%HCMAXD(NSEALM), WADATS(IMOD)%QP(NSEALM), & - WADATS(IMOD)%WBT(NSEALM), & - WADATS(IMOD)%WNMEAN(NSEALM), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 2' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) +#endif + ! + ! Water level WLV stored in W3WDATMD + ! Ice concentration ICE stored in W3WDATMD + ! Ice floe sizes ICEF and ICEDMAX stored in W3WDATMD + ! Iceberg damping BERG stored in W3WDATMD + ! + ! 2) Standard mean wave parameters + ! Here, all short arrays are always allocated to reduce logical + ! checks in all computations. The coresponding full size arrays + ! are allocated in W3MPIO only as needed to keep the memory + ! footprint down. + ! + IF (NSEALM .eq. 0) THEN + NSEALM=NSEA + END IF + ALLOCATE ( WADATS(IMOD)%HS (NSEALM), WADATS(IMOD)%WLM (NSEALM), & + WADATS(IMOD)%T02 (NSEALM), WADATS(IMOD)%T0M1(NSEALM), & + WADATS(IMOD)%T01 (NSEALM), WADATS(IMOD)%FP0 (NSEALM), & + WADATS(IMOD)%THM (NSEALM), WADATS(IMOD)%THS (NSEALM), & + WADATS(IMOD)%THP0 (NSEALM), WADATS(IMOD)%HSIG(NSEALM), & + WADATS(IMOD)%STMAXE (NSEALM), & + WADATS(IMOD)%STMAXD(NSEALM), & + WADATS(IMOD)%HMAXE(NSEALM), WADATS(IMOD)%HMAXD(NSEALM),& + WADATS(IMOD)%HCMAXE(NSEALM), & + WADATS(IMOD)%HCMAXD(NSEALM), WADATS(IMOD)%QP(NSEALM), & + WADATS(IMOD)%WBT(NSEALM), & + WADATS(IMOD)%WNMEAN(NSEALM), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_CESMCOUPLED - ALLOCATE ( WADATS(IMOD)%USSXH(NSEALM) , & - WADATS(IMOD)%USSYH(NSEALM) , & - WADATS(IMOD)%LANGMT(NSEALM) , & - WADATS(IMOD)%LAPROJ(NSEALM) , & - WADATS(IMOD)%LASL(NSEALM) , & - WADATS(IMOD)%LASLPJ(NSEALM) , & - WADATS(IMOD)%ALPHAL(NSEALM) , & - WADATS(IMOD)%ALPHALS(NSEALM) , & - WADATS(IMOD)%LAMULT(NSEALM) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! - WADATS(IMOD)%HS = UNDEF - WADATS(IMOD)%WLM = UNDEF - WADATS(IMOD)%T02 = UNDEF - WADATS(IMOD)%T0M1 = UNDEF - WADATS(IMOD)%T01 = UNDEF - WADATS(IMOD)%FP0 = UNDEF - WADATS(IMOD)%THM = UNDEF - WADATS(IMOD)%THS = UNDEF - WADATS(IMOD)%THP0 = UNDEF - WADATS(IMOD)%HSIG = UNDEF - WADATS(IMOD)%STMAXE = UNDEF - WADATS(IMOD)%STMAXD = UNDEF - WADATS(IMOD)%HMAXE = UNDEF - WADATS(IMOD)%HMAXD = UNDEF - WADATS(IMOD)%HCMAXE = UNDEF - WADATS(IMOD)%HCMAXD = UNDEF - WADATS(IMOD)%QP = UNDEF - WADATS(IMOD)%WBT = UNDEF - WADATS(IMOD)%WNMEAN = UNDEF + ALLOCATE ( WADATS(IMOD)%USSXH(NSEALM) , & + WADATS(IMOD)%USSYH(NSEALM) , & + WADATS(IMOD)%LANGMT(NSEALM) , & + WADATS(IMOD)%LAPROJ(NSEALM) , & + WADATS(IMOD)%LASL(NSEALM) , & + WADATS(IMOD)%LASLPJ(NSEALM) , & + WADATS(IMOD)%ALPHAL(NSEALM) , & + WADATS(IMOD)%ALPHALS(NSEALM) , & + WADATS(IMOD)%LAMULT(NSEALM) , & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! + WADATS(IMOD)%HS = UNDEF + WADATS(IMOD)%WLM = UNDEF + WADATS(IMOD)%T02 = UNDEF + WADATS(IMOD)%T0M1 = UNDEF + WADATS(IMOD)%T01 = UNDEF + WADATS(IMOD)%FP0 = UNDEF + WADATS(IMOD)%THM = UNDEF + WADATS(IMOD)%THS = UNDEF + WADATS(IMOD)%THP0 = UNDEF + WADATS(IMOD)%HSIG = UNDEF + WADATS(IMOD)%STMAXE = UNDEF + WADATS(IMOD)%STMAXD = UNDEF + WADATS(IMOD)%HMAXE = UNDEF + WADATS(IMOD)%HMAXD = UNDEF + WADATS(IMOD)%HCMAXE = UNDEF + WADATS(IMOD)%HCMAXD = UNDEF + WADATS(IMOD)%QP = UNDEF + WADATS(IMOD)%WBT = UNDEF + WADATS(IMOD)%WNMEAN = UNDEF #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 3' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! 3) Frequency-dependent standard parameters -! -! For the 3D arrays: the allocation is performed only if these arrays are allowed -! by specific variables defined through the mod_def file -! and read by w3iogr, which is called before W3DIMA. - IF ( E3DF(1,1).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%EF(NSEALM,E3DF(2,1):E3DF(3,1)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( E3DF(1,2).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%TH1M(NSEALM,E3DF(2,2):E3DF(3,2)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( E3DF(1,3).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%STH1M(NSEALM,E3DF(2,3):E3DF(3,3)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( E3DF(1,4).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%TH2M(NSEALM,E3DF(2,4):E3DF(3,4)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( E3DF(1,5).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%STH2M(NSEALM,E3DF(2,5):E3DF(3,5)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( E3DF(1,1).GT.0 ) WADATS(IMOD)%EF = UNDEF - IF ( E3DF(1,2).GT.0 ) WADATS(IMOD)%TH1M = UNDEF - IF ( E3DF(1,3).GT.0 ) WADATS(IMOD)%STH1M = UNDEF - IF ( E3DF(1,4).GT.0 ) WADATS(IMOD)%TH2M = UNDEF - IF ( E3DF(1,5).GT.0 ) WADATS(IMOD)%STH2M = UNDEF + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 3' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) +#endif + ! + ! 3) Frequency-dependent standard parameters + ! + ! For the 3D arrays: the allocation is performed only if these arrays are allowed + ! by specific variables defined through the mod_def file + ! and read by w3iogr, which is called before W3DIMA. + IF ( E3DF(1,1).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%EF(NSEALM,E3DF(2,1):E3DF(3,1)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( E3DF(1,2).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%TH1M(NSEALM,E3DF(2,2):E3DF(3,2)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( E3DF(1,3).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%STH1M(NSEALM,E3DF(2,3):E3DF(3,3)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( E3DF(1,4).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%TH2M(NSEALM,E3DF(2,4):E3DF(3,4)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( E3DF(1,5).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%STH2M(NSEALM,E3DF(2,5):E3DF(3,5)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( E3DF(1,1).GT.0 ) WADATS(IMOD)%EF = UNDEF + IF ( E3DF(1,2).GT.0 ) WADATS(IMOD)%TH1M = UNDEF + IF ( E3DF(1,3).GT.0 ) WADATS(IMOD)%STH1M = UNDEF + IF ( E3DF(1,4).GT.0 ) WADATS(IMOD)%TH2M = UNDEF + IF ( E3DF(1,5).GT.0 ) WADATS(IMOD)%STH2M = UNDEF #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 4' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 4' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) #endif -! -! 4) Spectral Partitions parameters -! - ALLOCATE ( WADATS(IMOD)%PHS(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PTP(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PLP(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PDIR(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PSI(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PWS(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PWST(NSEALM), & - WADATS(IMOD)%PNR(NSEALM), & - WADATS(IMOD)%PTHP0(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PQP(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PPE(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PGW(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PSW(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PTM1(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PT1(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PT2(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PEP(NSEALM,0:NOSWLL), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%PHS = UNDEF - WADATS(IMOD)%PTP = UNDEF - WADATS(IMOD)%PLP = UNDEF - WADATS(IMOD)%PDIR = UNDEF - WADATS(IMOD)%PSI = UNDEF - WADATS(IMOD)%PWS = UNDEF - WADATS(IMOD)%PWST = UNDEF - WADATS(IMOD)%PNR = UNDEF - WADATS(IMOD)%PTHP0 = UNDEF - WADATS(IMOD)%PQP = UNDEF - WADATS(IMOD)%PPE = UNDEF - WADATS(IMOD)%PGW = UNDEF - WADATS(IMOD)%PSW = UNDEF - WADATS(IMOD)%PTM1 = UNDEF - WADATS(IMOD)%PT1 = UNDEF - WADATS(IMOD)%PT2 = UNDEF - WADATS(IMOD)%PEP = UNDEF -! -! 5) Atmosphere-waves layer -! -! Friction velocity UST and USTDIR in W3WDATMD -! - ALLOCATE ( WADATS(IMOD)%CHARN (NSEALM), & - WADATS(IMOD)%TWS (NSEALM), & - WADATS(IMOD)%CGE (NSEALM), & - WADATS(IMOD)%PHIAW (NSEALM), & - WADATS(IMOD)%TAUWIX (NSEALM), & - WADATS(IMOD)%TAUWIY (NSEALM), & - WADATS(IMOD)%TAUWNX (NSEALM), & - WADATS(IMOD)%TAUWNY (NSEALM), & - WADATS(IMOD)%WHITECAP(NSEALM,4), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%CHARN = UNDEF - WADATS(IMOD)%TWS = UNDEF - WADATS(IMOD)%CGE = UNDEF - WADATS(IMOD)%PHIAW = UNDEF - WADATS(IMOD)%TAUWIX = UNDEF - WADATS(IMOD)%TAUWIY = UNDEF - WADATS(IMOD)%TAUWNX = UNDEF - WADATS(IMOD)%TAUWNY = UNDEF - WADATS(IMOD)%WHITECAP = UNDEF + ! + ! 4) Spectral Partitions parameters + ! + ALLOCATE ( WADATS(IMOD)%PHS(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PTP(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PLP(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PDIR(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PSI(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PWS(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PWST(NSEALM), & + WADATS(IMOD)%PNR(NSEALM), & + WADATS(IMOD)%PTHP0(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PQP(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PPE(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PGW(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PSW(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PTM1(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PT1(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PT2(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PEP(NSEALM,0:NOSWLL), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%PHS = UNDEF + WADATS(IMOD)%PTP = UNDEF + WADATS(IMOD)%PLP = UNDEF + WADATS(IMOD)%PDIR = UNDEF + WADATS(IMOD)%PSI = UNDEF + WADATS(IMOD)%PWS = UNDEF + WADATS(IMOD)%PWST = UNDEF + WADATS(IMOD)%PNR = UNDEF + WADATS(IMOD)%PTHP0 = UNDEF + WADATS(IMOD)%PQP = UNDEF + WADATS(IMOD)%PPE = UNDEF + WADATS(IMOD)%PGW = UNDEF + WADATS(IMOD)%PSW = UNDEF + WADATS(IMOD)%PTM1 = UNDEF + WADATS(IMOD)%PT1 = UNDEF + WADATS(IMOD)%PT2 = UNDEF + WADATS(IMOD)%PEP = UNDEF + ! + ! 5) Atmosphere-waves layer + ! + ! Friction velocity UST and USTDIR in W3WDATMD + ! + ALLOCATE ( WADATS(IMOD)%CHARN (NSEALM), & + WADATS(IMOD)%TWS (NSEALM), & + WADATS(IMOD)%CGE (NSEALM), & + WADATS(IMOD)%PHIAW (NSEALM), & + WADATS(IMOD)%TAUWIX (NSEALM), & + WADATS(IMOD)%TAUWIY (NSEALM), & + WADATS(IMOD)%TAUWNX (NSEALM), & + WADATS(IMOD)%TAUWNY (NSEALM), & + WADATS(IMOD)%WHITECAP(NSEALM,4), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%CHARN = UNDEF + WADATS(IMOD)%TWS = UNDEF + WADATS(IMOD)%CGE = UNDEF + WADATS(IMOD)%PHIAW = UNDEF + WADATS(IMOD)%TAUWIX = UNDEF + WADATS(IMOD)%TAUWIY = UNDEF + WADATS(IMOD)%TAUWNX = UNDEF + WADATS(IMOD)%TAUWNY = UNDEF + WADATS(IMOD)%WHITECAP = UNDEF #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 5' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 5' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) #endif -! -! 6) Wave-ocean layer -! - ALLOCATE ( WADATS(IMOD)%SXX (NSEALM) , & - WADATS(IMOD)%SYY (NSEALM) , & - WADATS(IMOD)%SXY (NSEALM) , & - WADATS(IMOD)%TAUOX (NSEALM) , & - WADATS(IMOD)%TAUOY (NSEALM) , & - WADATS(IMOD)%BHD (NSEALM) , & - WADATS(IMOD)%PHIOC (NSEALM) , & - WADATS(IMOD)%TUSX (NSEALM) , & - WADATS(IMOD)%TUSY (NSEALM) , & - WADATS(IMOD)%USSX (NSEALM) , & - WADATS(IMOD)%USSY (NSEALM) , & - WADATS(IMOD)%TAUOCX(NSEALM) , & - WADATS(IMOD)%TAUOCY(NSEALM) , & - WADATS(IMOD)%PRMS (NSEALM) , & - WADATS(IMOD)%TPMS (NSEALM) , & - WADATS(IMOD)%PHICE (NSEALM) , & - WADATS(IMOD)%TAUICE(NSEALM,2), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! -! For the 3D arrays: the allocation is performed only if these arrays are allowed -! by specific variables defined through the mod_def file -! and read by w3iogr, which is called before W3DIMA. - IF ( P2MSF(1).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%P2SMS(NSEALM,P2MSF(2):P2MSF(3)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( US3DF(1).GT.0 ) THEN ! maybe use US3DF(2:3) - ALLOCATE(WADATS(IMOD)%US3D(NSEALM,NK*2), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( USSPF(1).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%USSP(NSEALM,NK*2), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%SXX = UNDEF - WADATS(IMOD)%SYY = UNDEF - WADATS(IMOD)%SXY = UNDEF - WADATS(IMOD)%TAUOX = UNDEF - WADATS(IMOD)%TAUOY = UNDEF - WADATS(IMOD)%BHD = UNDEF - WADATS(IMOD)%PHIOC = UNDEF - WADATS(IMOD)%TUSX = UNDEF - WADATS(IMOD)%TUSY = UNDEF - WADATS(IMOD)%USSX = UNDEF - WADATS(IMOD)%USSY = UNDEF - WADATS(IMOD)%TAUOCX = UNDEF - WADATS(IMOD)%TAUOCY = UNDEF - WADATS(IMOD)%PRMS = UNDEF - WADATS(IMOD)%TPMS = UNDEF - WADATS(IMOD)%PHICE = UNDEF - WADATS(IMOD)%TAUICE = UNDEF + ! + ! 6) Wave-ocean layer + ! + ALLOCATE ( WADATS(IMOD)%SXX (NSEALM) , & + WADATS(IMOD)%SYY (NSEALM) , & + WADATS(IMOD)%SXY (NSEALM) , & + WADATS(IMOD)%TAUOX (NSEALM) , & + WADATS(IMOD)%TAUOY (NSEALM) , & + WADATS(IMOD)%BHD (NSEALM) , & + WADATS(IMOD)%PHIOC (NSEALM) , & + WADATS(IMOD)%TUSX (NSEALM) , & + WADATS(IMOD)%TUSY (NSEALM) , & + WADATS(IMOD)%USSX (NSEALM) , & + WADATS(IMOD)%USSY (NSEALM) , & + WADATS(IMOD)%TAUOCX(NSEALM) , & + WADATS(IMOD)%TAUOCY(NSEALM) , & + WADATS(IMOD)%PRMS (NSEALM) , & + WADATS(IMOD)%TPMS (NSEALM) , & + WADATS(IMOD)%PHICE (NSEALM) , & + WADATS(IMOD)%TAUICE(NSEALM,2), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + ! For the 3D arrays: the allocation is performed only if these arrays are allowed + ! by specific variables defined through the mod_def file + ! and read by w3iogr, which is called before W3DIMA. + IF ( P2MSF(1).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%P2SMS(NSEALM,P2MSF(2):P2MSF(3)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( US3DF(1).GT.0 ) THEN ! maybe use US3DF(2:3) + ALLOCATE(WADATS(IMOD)%US3D(NSEALM,NK*2), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( USSPF(1).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%USSP(NSEALM,NK*2), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%SXX = UNDEF + WADATS(IMOD)%SYY = UNDEF + WADATS(IMOD)%SXY = UNDEF + WADATS(IMOD)%TAUOX = UNDEF + WADATS(IMOD)%TAUOY = UNDEF + WADATS(IMOD)%BHD = UNDEF + WADATS(IMOD)%PHIOC = UNDEF + WADATS(IMOD)%TUSX = UNDEF + WADATS(IMOD)%TUSY = UNDEF + WADATS(IMOD)%USSX = UNDEF + WADATS(IMOD)%USSY = UNDEF + WADATS(IMOD)%TAUOCX = UNDEF + WADATS(IMOD)%TAUOCY = UNDEF + WADATS(IMOD)%PRMS = UNDEF + WADATS(IMOD)%TPMS = UNDEF + WADATS(IMOD)%PHICE = UNDEF + WADATS(IMOD)%TAUICE = UNDEF #ifdef W3_CESMCOUPLED - WADATS(IMOD)%LANGMT = UNDEF + WADATS(IMOD)%LANGMT = UNDEF #endif - IF ( P2MSF(1).GT.0 ) WADATS(IMOD)%P2SMS = UNDEF - IF ( US3DF(1).GT.0 ) WADATS(IMOD)%US3D = UNDEF - IF ( USSPF(1).GT.0 ) WADATS(IMOD)%USSP = UNDEF + IF ( P2MSF(1).GT.0 ) WADATS(IMOD)%P2SMS = UNDEF + IF ( US3DF(1).GT.0 ) WADATS(IMOD)%US3D = UNDEF + IF ( USSPF(1).GT.0 ) WADATS(IMOD)%USSP = UNDEF #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 6' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! 7) Wave-bottom layer -! - ALLOCATE ( WADATS(IMOD)%ABA(NSEALM) , WADATS(IMOD)%ABD(NSEALM) , & - WADATS(IMOD)%UBA(NSEALM) , WADATS(IMOD)%UBD(NSEALM) , & - WADATS(IMOD)%BEDFORMS(NSEALM,3), & - WADATS(IMOD)%PHIBBL (NSEALM) , & - WADATS(IMOD)%TAUBBL (NSEALM,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%ABA = UNDEF - WADATS(IMOD)%ABD = UNDEF - WADATS(IMOD)%UBA = UNDEF - WADATS(IMOD)%UBD = UNDEF - WADATS(IMOD)%BEDFORMS = UNDEF - WADATS(IMOD)%PHIBBL = UNDEF - WADATS(IMOD)%TAUBBL = UNDEF + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 6' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) +#endif + ! + ! 7) Wave-bottom layer + ! + ALLOCATE ( WADATS(IMOD)%ABA(NSEALM) , WADATS(IMOD)%ABD(NSEALM) , & + WADATS(IMOD)%UBA(NSEALM) , WADATS(IMOD)%UBD(NSEALM) , & + WADATS(IMOD)%BEDFORMS(NSEALM,3), & + WADATS(IMOD)%PHIBBL (NSEALM) , & + WADATS(IMOD)%TAUBBL (NSEALM,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%ABA = UNDEF + WADATS(IMOD)%ABD = UNDEF + WADATS(IMOD)%UBA = UNDEF + WADATS(IMOD)%UBD = UNDEF + WADATS(IMOD)%BEDFORMS = UNDEF + WADATS(IMOD)%PHIBBL = UNDEF + WADATS(IMOD)%TAUBBL = UNDEF #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 7' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! 8) Spectrum parameters -! - ALLOCATE ( WADATS(IMOD)%MSSX(NSEALM), WADATS(IMOD)%MSSY(NSEALM), & - WADATS(IMOD)%MSCX(NSEALM), WADATS(IMOD)%MSCY(NSEALM), & - WADATS(IMOD)%MSSD(NSEALM), WADATS(IMOD)%MSCD(NSEALM), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%MSSX = UNDEF - WADATS(IMOD)%MSSY = UNDEF - WADATS(IMOD)%MSSD = UNDEF - WADATS(IMOD)%MSCX = UNDEF - WADATS(IMOD)%MSCY = UNDEF - WADATS(IMOD)%MSCD = UNDEF + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 7' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) +#endif + ! + ! 8) Spectrum parameters + ! + ALLOCATE ( WADATS(IMOD)%MSSX(NSEALM), WADATS(IMOD)%MSSY(NSEALM), & + WADATS(IMOD)%MSCX(NSEALM), WADATS(IMOD)%MSCY(NSEALM), & + WADATS(IMOD)%MSSD(NSEALM), WADATS(IMOD)%MSCD(NSEALM), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%MSSX = UNDEF + WADATS(IMOD)%MSSY = UNDEF + WADATS(IMOD)%MSSD = UNDEF + WADATS(IMOD)%MSCX = UNDEF + WADATS(IMOD)%MSCY = UNDEF + WADATS(IMOD)%MSCD = UNDEF #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 8' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! 9) Numerical diagnostics -! -! - ALLOCATE ( WADATS(IMOD)%DTDYN (NSEALM) , & - WADATS(IMOD)%FCUT (NSEALM) , & - WADATS(IMOD)%CFLXYMAX(NSEALM) , & - WADATS(IMOD)%CFLTHMAX(NSEALM) , & - WADATS(IMOD)%CFLKMAX (NSEALM) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%DTDYN = UNDEF - WADATS(IMOD)%FCUT = UNDEF - WADATS(IMOD)%CFLXYMAX = UNDEF - WADATS(IMOD)%CFLTHMAX = UNDEF - WADATS(IMOD)%CFLKMAX = UNDEF + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 8' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) +#endif + ! + ! 9) Numerical diagnostics + ! + ! + ALLOCATE ( WADATS(IMOD)%DTDYN (NSEALM) , & + WADATS(IMOD)%FCUT (NSEALM) , & + WADATS(IMOD)%CFLXYMAX(NSEALM) , & + WADATS(IMOD)%CFLTHMAX(NSEALM) , & + WADATS(IMOD)%CFLKMAX (NSEALM) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%DTDYN = UNDEF + WADATS(IMOD)%FCUT = UNDEF + WADATS(IMOD)%CFLXYMAX = UNDEF + WADATS(IMOD)%CFLTHMAX = UNDEF + WADATS(IMOD)%CFLKMAX = UNDEF #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 9' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! 10) User defined -! - ALLOCATE ( WADATS(IMOD)%USERO(NSEALM,NOEXTR), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%USERO = UNDEF -! - ALLOCATE ( WADATS(IMOD)%WN(0:NK+1,0:NSEA), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 9' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) +#endif + ! + ! 10) User defined + ! + ALLOCATE ( WADATS(IMOD)%USERO(NSEALM,NOEXTR), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%USERO = UNDEF + ! + ALLOCATE ( WADATS(IMOD)%WN(0:NK+1,0:NSEA), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_IC3 - ALLOCATE (WADATS(IMOD)%IC3WN_R(0:NK+1,0:300), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE (WADATS(IMOD)%IC3WN_I(0:NK+1,0:300), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE (WADATS(IMOD)%IC3WN_R(0:NK+1,0:300), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE (WADATS(IMOD)%IC3WN_I(0:NK+1,0:300), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 10' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! - IF ( FL_ALL ) THEN -! - ALLOCATE ( WADATS(IMOD)%CG(0:NK+1,0:NSEA), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 10' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) +#endif + ! + IF ( FL_ALL ) THEN + ! + ALLOCATE ( WADATS(IMOD)%CG(0:NK+1,0:NSEA), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_IC3 - ALLOCATE (WADATS(IMOD)%IC3CG(0:NK+1,0:300), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE (WADATS(IMOD)%IC3CG(0:NK+1,0:300), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -! - IF ( FLCUR ) THEN - ALLOCATE ( WADATS(IMOD)%CA0(NSEA) , & - WADATS(IMOD)%CAI(NSEA) , & - WADATS(IMOD)%CD0(NSEA) , & - WADATS(IMOD)%CDI(NSEA) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLWIND ) THEN - ALLOCATE ( WADATS(IMOD)%UA0(NSEA) , & - WADATS(IMOD)%UAI(NSEA) , & - WADATS(IMOD)%UD0(NSEA) , & - WADATS(IMOD)%UDI(NSEA) , & - WADATS(IMOD)%AS0(NSEA) , & - WADATS(IMOD)%ASI(NSEA) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLTAUA ) THEN - ALLOCATE ( WADATS(IMOD)%MA0(NSEA) , & - WADATS(IMOD)%MAI(NSEA) , & - WADATS(IMOD)%MD0(NSEA) , & - WADATS(IMOD)%MDI(NSEA) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLRHOA ) THEN - ALLOCATE ( WADATS(IMOD)%RA0(NSEA) , & - WADATS(IMOD)%RAI(NSEA) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - ALLOCATE ( WADATS(IMOD)%ATRNX(NY*NX,-1:1) , & - WADATS(IMOD)%ATRNY(NY*NX,-1:1) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - IF (.NOT. LPDLIB) THEN - ALLOCATE ( WADATS(IMOD)%DDDX(NY,NX) , & - WADATS(IMOD)%DDDY(NY,NX) , & - WADATS(IMOD)%DCDX(0:NK+1,NY,NX) , & - WADATS(IMOD)%DCDY(0:NK+1,NY,NX) , & - WADATS(IMOD)%DCXDX(NY,NX) , & - WADATS(IMOD)%DCYDX(NY,NX) , & - WADATS(IMOD)%DCXDY(NY,NX) , & - WADATS(IMOD)%DCYDY(NY,NX) , STAT=ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%DDDX(1,NSEAL) , & - WADATS(IMOD)%DDDY(1,NSEAL) , & - WADATS(IMOD)%DCDX(0:NK+1,1,NSEAL) , & - WADATS(IMOD)%DCDY(0:NK+1,1,NSEAL) , & - WADATS(IMOD)%DCXDX(1,NSEAL) , & - WADATS(IMOD)%DCYDX(1,NSEAL) , & - WADATS(IMOD)%DCXDY(1,NSEAL) , & - WADATS(IMOD)%DCYDY(1,NSEAL) , & - STAT=ISTAT ) - ENDIF - CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%DDDX = 0. - WADATS(IMOD)%DDDY = 0. - WADATS(IMOD)%DCDX = 0. - WADATS(IMOD)%DCDY = 0. - WADATS(IMOD)%DCXDX = 0. - WADATS(IMOD)%DCYDX = 0. - WADATS(IMOD)%DCXDY = 0. - WADATS(IMOD)%DCYDY = 0. -! + ! + IF ( FLCUR ) THEN + ALLOCATE ( WADATS(IMOD)%CA0(NSEA) , & + WADATS(IMOD)%CAI(NSEA) , & + WADATS(IMOD)%CD0(NSEA) , & + WADATS(IMOD)%CDI(NSEA) , & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( FLWIND ) THEN + ALLOCATE ( WADATS(IMOD)%UA0(NSEA) , & + WADATS(IMOD)%UAI(NSEA) , & + WADATS(IMOD)%UD0(NSEA) , & + WADATS(IMOD)%UDI(NSEA) , & + WADATS(IMOD)%AS0(NSEA) , & + WADATS(IMOD)%ASI(NSEA) , & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( FLTAUA ) THEN + ALLOCATE ( WADATS(IMOD)%MA0(NSEA) , & + WADATS(IMOD)%MAI(NSEA) , & + WADATS(IMOD)%MD0(NSEA) , & + WADATS(IMOD)%MDI(NSEA) , & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( FLRHOA ) THEN + ALLOCATE ( WADATS(IMOD)%RA0(NSEA) , & + WADATS(IMOD)%RAI(NSEA) , & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + ALLOCATE ( WADATS(IMOD)%ATRNX(NY*NX,-1:1) , & + WADATS(IMOD)%ATRNY(NY*NX,-1:1) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + IF (.NOT. LPDLIB) THEN + ALLOCATE ( WADATS(IMOD)%DDDX(NY,NX) , & + WADATS(IMOD)%DDDY(NY,NX) , & + WADATS(IMOD)%DCDX(0:NK+1,NY,NX) , & + WADATS(IMOD)%DCDY(0:NK+1,NY,NX) , & + WADATS(IMOD)%DCXDX(NY,NX) , & + WADATS(IMOD)%DCYDX(NY,NX) , & + WADATS(IMOD)%DCXDY(NY,NX) , & + WADATS(IMOD)%DCYDY(NY,NX) , STAT=ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%DDDX(1,NSEAL) , & + WADATS(IMOD)%DDDY(1,NSEAL) , & + WADATS(IMOD)%DCDX(0:NK+1,1,NSEAL) , & + WADATS(IMOD)%DCDY(0:NK+1,1,NSEAL) , & + WADATS(IMOD)%DCXDX(1,NSEAL) , & + WADATS(IMOD)%DCYDX(1,NSEAL) , & + WADATS(IMOD)%DCXDY(1,NSEAL) , & + WADATS(IMOD)%DCYDY(1,NSEAL) , & + STAT=ISTAT ) + ENDIF + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%DDDX = 0. + WADATS(IMOD)%DDDY = 0. + WADATS(IMOD)%DCDX = 0. + WADATS(IMOD)%DCDY = 0. + WADATS(IMOD)%DCXDX = 0. + WADATS(IMOD)%DCYDX = 0. + WADATS(IMOD)%DCXDY = 0. + WADATS(IMOD)%DCYDY = 0. + ! #ifdef W3_SMC - ALLOCATE ( WADATS(IMOD)%DHDX(NSEA) , & - WADATS(IMOD)%DHDY(NSEA) , & - WADATS(IMOD)%DHLMT(NTH,NSEA) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! - ALLOCATE ( WADATS(IMOD)%ALPHA(NK,NSEAL) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! + ALLOCATE ( WADATS(IMOD)%DHDX(NSEA) , & + WADATS(IMOD)%DHDY(NSEA) , & + WADATS(IMOD)%DHLMT(NTH,NSEA) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! + ALLOCATE ( WADATS(IMOD)%ALPHA(NK,NSEAL) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! #ifdef W3_PR1 - ALLOCATE ( WADATS(IMOD)%IS0(NSPEC) , & - WADATS(IMOD)%IS2(NSPEC) , & - WADATS(IMOD)%FACVX(NY*NX) , & - WADATS(IMOD)%FACVY(NY*NX) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%IS0(NSPEC) , & + WADATS(IMOD)%IS2(NSPEC) , & + WADATS(IMOD)%FACVX(NY*NX) , & + WADATS(IMOD)%FACVY(NY*NX) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -! + ! #ifdef W3_PR2 - ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & - WADATS(IMOD)%MAPY2(NY*NX) , & - WADATS(IMOD)%MAPAXY(NY*NX) , & - WADATS(IMOD)%MAPXY(NSEA) , & - WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & - WADATS(IMOD)%MAPWN2(NSPEC+NTH) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%MAPTH2 = 0 -#endif -! - IF (GTYPE .EQ. UNGTYPE) THEN - ALLOCATE( WADATS(IMOD)%ITER(NK,NTH), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! + ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & + WADATS(IMOD)%MAPY2(NY*NX) , & + WADATS(IMOD)%MAPAXY(NY*NX) , & + WADATS(IMOD)%MAPXY(NSEA) , & + WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & + WADATS(IMOD)%MAPWN2(NSPEC+NTH) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%MAPTH2 = 0 +#endif + ! + IF (GTYPE .EQ. UNGTYPE) THEN + ALLOCATE( WADATS(IMOD)%ITER(NK,NTH), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! #ifdef W3_PR3 - ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & - WADATS(IMOD)%MAPY2(NY*NX) , & - WADATS(IMOD)%MAPAXY(NY*NX) , & - WADATS(IMOD)%MAPCXY(NSEA) , & - WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & - WADATS(IMOD)%MAPWN2(NSPEC+NTH) , & - WADATS(IMOD)%MAPTRN(NY*NX) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%MAPTH2 = 0 -#endif -! - ALLOCATE ( WADATS(IMOD)%IAPPRO(NSPEC) , & - WADATS(IMOD)%SPPNT(NTH,NK,4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - END IF -! - WADATS(IMOD)%AINIT = .TRUE. + ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & + WADATS(IMOD)%MAPY2(NY*NX) , & + WADATS(IMOD)%MAPAXY(NY*NX) , & + WADATS(IMOD)%MAPCXY(NSEA) , & + WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & + WADATS(IMOD)%MAPWN2(NSPEC+NTH) , & + WADATS(IMOD)%MAPTRN(NY*NX) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%MAPTH2 = 0 +#endif + ! + ALLOCATE ( WADATS(IMOD)%IAPPRO(NSPEC) , & + WADATS(IMOD)%SPPNT(NTH,NK,4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + END IF + ! + WADATS(IMOD)%AINIT = .TRUE. #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 11' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 11' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) #endif -! + ! #ifdef W3_T - WRITE (NDST,9001) + WRITE (NDST,9001) #endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETA ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETA ( IMOD, NDSE, NDST ) #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 12' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 12' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) #endif -! + ! #ifdef W3_T - WRITE (NDST,9002) + WRITE (NDST,9002) #endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! #ifdef W3_T - WRITE (NDST,9003) -#endif -! -! -------------------------------------------------------------------- / -! 5. Restore previous grid setting if necessary -! - IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) - + WRITE (NDST,9003) +#endif + ! + ! -------------------------------------------------------------------- / + ! 5. Restore previous grid setting if necessary + ! + IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) + #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA END' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DIMA : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DIMA : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NADATA = ',I10/) - 1003 FORMAT (/' *** ERROR W3DIMA : ARRAY(S) ALREADY ALLOCATED *** ') -! + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA END' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DIMA : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DIMA : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NADATA = ',I10/) +1003 FORMAT (/' *** ERROR W3DIMA : ARRAY(S) ALREADY ALLOCATED *** ') + ! #ifdef W3_T - 9000 FORMAT (' TEST W3DIMA : MODEL ',I4) - 9001 FORMAT (' TEST W3DIMA : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DIMA : POINTERS RESET') - 9003 FORMAT (' TEST W3DIMA : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DIMA ----------------------------------------------------- / -!/ - END SUBROUTINE W3DIMA -!/ ------------------------------------------------------------------- / -!> -!> @brief Version of W3DIMX for extended ouput arrays only. -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> @param[in] OUTFLAGS -!> -!> @author H. L. Tolman -!> @date 22-Mar-2021 -!> - SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 26-Dec-2012 : Origination. ( version 3.06 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 22-Mar-2021 : Adds WNMEAN, TAUOC parameters ( version 7.13 ) -!/ -! 1. Purpose : -! -! Version of W3DIMX for extended ouput arrays only. -! -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG, NK, NX, NY, NSEA, & - NSEAL, NSPEC, NTH, E3DF, P2MSF, US3DF, & - USSPF, GTYPE, UNGTYPE - USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC, NAPFLD, & - NOSWLL, NOEXTR, UNDEF, FLOGRD, FLOGR2, & - NOGRP, NGRPP - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT (' TEST W3DIMA : MODEL ',I4) +9001 FORMAT (' TEST W3DIMA : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DIMA : POINTERS RESET') +9003 FORMAT (' TEST W3DIMA : DIMENSIONS STORED') +#endif + !/ + !/ End of W3DIMA ----------------------------------------------------- / + !/ + END SUBROUTINE W3DIMA + !/ ------------------------------------------------------------------- / + !> + !> @brief Version of W3DIMX for extended ouput arrays only. + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> @param[in] OUTFLAGS + !> + !> @author H. L. Tolman + !> @date 22-Mar-2021 + !> + SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 26-Dec-2012 : Origination. ( version 3.06 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 22-Mar-2021 : Adds WNMEAN, TAUOC parameters ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Version of W3DIMX for extended ouput arrays only. + ! + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG, NK, NX, NY, NSEA, & + NSEAL, NSPEC, NTH, E3DF, P2MSF, US3DF, & + USSPF, GTYPE, UNGTYPE + USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC, NAPFLD, & + NOSWLL, NOEXTR, UNDEF, FLOGRD, FLOGR2, & + NOGRP, NGRPP + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST - LOGICAL, INTENT(IN) :: OUTFLAGS(NOGRP,NGRPP) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID, NXXX, I + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + LOGICAL, INTENT(IN) :: OUTFLAGS(NOGRP,NGRPP) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID, NXXX, I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3XDMA') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN - WRITE (NDSE,1002) IMOD, NADATA - CALL EXTCDE (2) - END IF -! - IF ( WADATS(IMOD)%AINIT2 ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -! + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3XDMA') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN + WRITE (NDSE,1002) IMOD, NADATA + CALL EXTCDE (2) + END IF + ! + IF ( WADATS(IMOD)%AINIT2 ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! - JGRID = IGRID - IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! - NXXX = NSEALM * NAPROC -! - IF ( OUTFLAGS( 2, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XHS(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XWLM(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XWLM(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XT02(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XT02(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XT0M1(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XT0M1(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XT01 (NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XT01 (1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 6) .OR. OUTFLAGS( 2,18) ) THEN - ! TP output shares FP0 internal field with FP - ALLOCATE ( WADATS(IMOD)%XFP0(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XFP0(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 7) ) THEN - ALLOCATE ( WADATS(IMOD)%XTHM(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTHM(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 8) ) THEN - ALLOCATE ( WADATS(IMOD)%XTHS(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTHS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 9) ) THEN - ALLOCATE ( WADATS(IMOD)%XTHP0(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTHP0(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 10) ) THEN - ALLOCATE ( WADATS(IMOD)%XHSIG(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHSIG(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 11) ) THEN - ALLOCATE ( WADATS(IMOD)%XSTMAXE(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XSTMAXE(1) ) - END IF -! - IF ( OUTFLAGS( 2, 12) ) THEN - ALLOCATE ( WADATS(IMOD)%XSTMAXD(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XSTMAXD(1) ) - END IF -! - IF ( OUTFLAGS( 2, 13) ) THEN - ALLOCATE ( WADATS(IMOD)%XHMAXE(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHMAXE(1) ) - END IF -! - IF ( OUTFLAGS( 2, 14) ) THEN - ALLOCATE ( WADATS(IMOD)%XHCMAXE(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHCMAXE(1) ) - END IF -! -! - IF ( OUTFLAGS( 2, 15) ) THEN - ALLOCATE ( WADATS(IMOD)%XHMAXD(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHMAXD(1) ) - END IF -! - IF ( OUTFLAGS( 2, 16) ) THEN - ALLOCATE ( WADATS(IMOD)%XHCMAXD(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHCMAXD(1) ) - END IF -! - IF ( OUTFLAGS( 2, 17) ) THEN - ALLOCATE ( WADATS(IMOD)%XWBT (NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XWBT (1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 19) ) THEN - ALLOCATE ( WADATS(IMOD)%XWNMEAN(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XWNMEAN(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XHS = UNDEF - WADATS(IMOD)%XWLM = UNDEF - WADATS(IMOD)%XT02 = UNDEF - WADATS(IMOD)%XT0M1 = UNDEF - WADATS(IMOD)%XT01 = UNDEF - WADATS(IMOD)%XFP0 = UNDEF - WADATS(IMOD)%XTHM = UNDEF - WADATS(IMOD)%XTHS = UNDEF - WADATS(IMOD)%XTHP0 = UNDEF - WADATS(IMOD)%XHSIG = UNDEF - WADATS(IMOD)%XSTMAXE= UNDEF - WADATS(IMOD)%XSTMAXD= UNDEF - WADATS(IMOD)%XHMAXE = UNDEF - WADATS(IMOD)%XHMAXD = UNDEF - WADATS(IMOD)%XHCMAXE= UNDEF - WADATS(IMOD)%XHCMAXD= UNDEF - WADATS(IMOD)%XWBT = UNDEF - WADATS(IMOD)%XWNMEAN= UNDEF -! - IF ( OUTFLAGS( 3, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XEF(NXXX,E3DF(2,1):E3DF(3,1)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XEF(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF + WRITE (NDST,9000) IMOD +#endif + ! + JGRID = IGRID + IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + NXXX = NSEALM * NAPROC + ! + IF ( OUTFLAGS( 2, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XHS(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XWLM(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XWLM(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XT02(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XT02(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XT0M1(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XT0M1(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XT01 (NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XT01 (1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 6) .OR. OUTFLAGS( 2,18) ) THEN + ! TP output shares FP0 internal field with FP + ALLOCATE ( WADATS(IMOD)%XFP0(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XFP0(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 7) ) THEN + ALLOCATE ( WADATS(IMOD)%XTHM(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTHM(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 8) ) THEN + ALLOCATE ( WADATS(IMOD)%XTHS(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTHS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 9) ) THEN + ALLOCATE ( WADATS(IMOD)%XTHP0(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTHP0(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 10) ) THEN + ALLOCATE ( WADATS(IMOD)%XHSIG(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHSIG(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 11) ) THEN + ALLOCATE ( WADATS(IMOD)%XSTMAXE(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XSTMAXE(1) ) + END IF + ! + IF ( OUTFLAGS( 2, 12) ) THEN + ALLOCATE ( WADATS(IMOD)%XSTMAXD(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XSTMAXD(1) ) + END IF + ! + IF ( OUTFLAGS( 2, 13) ) THEN + ALLOCATE ( WADATS(IMOD)%XHMAXE(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHMAXE(1) ) + END IF + ! + IF ( OUTFLAGS( 2, 14) ) THEN + ALLOCATE ( WADATS(IMOD)%XHCMAXE(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHCMAXE(1) ) + END IF + ! + ! + IF ( OUTFLAGS( 2, 15) ) THEN + ALLOCATE ( WADATS(IMOD)%XHMAXD(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHMAXD(1) ) + END IF + ! + IF ( OUTFLAGS( 2, 16) ) THEN + ALLOCATE ( WADATS(IMOD)%XHCMAXD(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHCMAXD(1) ) + END IF + ! + IF ( OUTFLAGS( 2, 17) ) THEN + ALLOCATE ( WADATS(IMOD)%XWBT (NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XWBT (1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 19) ) THEN + ALLOCATE ( WADATS(IMOD)%XWNMEAN(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XWNMEAN(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XHS = UNDEF + WADATS(IMOD)%XWLM = UNDEF + WADATS(IMOD)%XT02 = UNDEF + WADATS(IMOD)%XT0M1 = UNDEF + WADATS(IMOD)%XT01 = UNDEF + WADATS(IMOD)%XFP0 = UNDEF + WADATS(IMOD)%XTHM = UNDEF + WADATS(IMOD)%XTHS = UNDEF + WADATS(IMOD)%XTHP0 = UNDEF + WADATS(IMOD)%XHSIG = UNDEF + WADATS(IMOD)%XSTMAXE= UNDEF + WADATS(IMOD)%XSTMAXD= UNDEF + WADATS(IMOD)%XHMAXE = UNDEF + WADATS(IMOD)%XHMAXD = UNDEF + WADATS(IMOD)%XHCMAXE= UNDEF + WADATS(IMOD)%XHCMAXD= UNDEF + WADATS(IMOD)%XWBT = UNDEF + WADATS(IMOD)%XWNMEAN= UNDEF + ! + IF ( OUTFLAGS( 3, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XEF(NXXX,E3DF(2,1):E3DF(3,1)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XEF(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF - IF ( OUTFLAGS( 3, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XTH1M(NXXX,E3DF(2,2):E3DF(3,2)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTH1M(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF + IF ( OUTFLAGS( 3, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XTH1M(NXXX,E3DF(2,2):E3DF(3,2)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTH1M(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF - IF ( OUTFLAGS( 3, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XSTH1M(NXXX,E3DF(2,3):E3DF(3,3)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XSTH1M(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF + IF ( OUTFLAGS( 3, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XSTH1M(NXXX,E3DF(2,3):E3DF(3,3)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XSTH1M(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF - IF ( OUTFLAGS( 3, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XTH2M(NXXX,E3DF(2,4):E3DF(3,4)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTH2M(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 3, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XSTH2M(NXXX,E3DF(2,5):E3DF(3,5)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XSTH2M(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XEF = UNDEF - WADATS(IMOD)%XTH1M = UNDEF - WADATS(IMOD)%XSTH1M = UNDEF - WADATS(IMOD)%XTH2M = UNDEF - WADATS(IMOD)%XSTH2M = UNDEF -! - IF ( OUTFLAGS( 4, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XPHS(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPHS(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XPTP(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPTP(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XPLP(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPLP(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XPDIR(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPDIR(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XPSI(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPSI(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 6) ) THEN - ALLOCATE ( WADATS(IMOD)%XPWS(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPWS(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 7) ) THEN - ALLOCATE ( WADATS(IMOD)%XPTHP0(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPTHP0(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 8) ) THEN - ALLOCATE ( WADATS(IMOD)%XPQP(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPQP(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 9) ) THEN - ALLOCATE ( WADATS(IMOD)%XPPE(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPPE(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,10) ) THEN - ALLOCATE ( WADATS(IMOD)%XPGW(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPGW(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,11) ) THEN - ALLOCATE ( WADATS(IMOD)%XPSW(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPSW(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,12) ) THEN - ALLOCATE ( WADATS(IMOD)%XPTM1(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPTM1(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,13) ) THEN - ALLOCATE ( WADATS(IMOD)%XPT1(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPT1(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,14) ) THEN - ALLOCATE ( WADATS(IMOD)%XPT2(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPT2(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,15) ) THEN - ALLOCATE ( WADATS(IMOD)%XPEP(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPEP(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,16) ) THEN - ALLOCATE ( WADATS(IMOD)%XPWST(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPWST(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,17) ) THEN - ALLOCATE ( WADATS(IMOD)%XPNR(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPNR(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XPHS = UNDEF - WADATS(IMOD)%XPTP = UNDEF - WADATS(IMOD)%XPLP = UNDEF - WADATS(IMOD)%XPDIR = UNDEF - WADATS(IMOD)%XPSI = UNDEF - WADATS(IMOD)%XPWS = UNDEF - WADATS(IMOD)%XPWST = UNDEF - WADATS(IMOD)%XPNR = UNDEF - WADATS(IMOD)%XPTHP0 = UNDEF - WADATS(IMOD)%XPQP = UNDEF - WADATS(IMOD)%XPPE = UNDEF - WADATS(IMOD)%XPGW = UNDEF - WADATS(IMOD)%XPSW = UNDEF - WADATS(IMOD)%XPTM1 = UNDEF - WADATS(IMOD)%XPT1 = UNDEF - WADATS(IMOD)%XPT2 = UNDEF - WADATS(IMOD)%XPEP = UNDEF -! - IF ( OUTFLAGS( 5, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XCHARN(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XCHARN(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XCGE(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XCGE(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XPHIAW(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPHIAW(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUWIX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUWIY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUWIX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUWIY(1) ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 6) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUWNX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUWNY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUWNX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUWNY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 7) .OR. OUTFLAGS( 5, 8) .OR. & - OUTFLAGS( 5, 9) .OR. OUTFLAGS( 5,10)) THEN - ALLOCATE ( WADATS(IMOD)%XWHITECAP(NXXX,4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XWHITECAP(1,4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 11) ) THEN - ALLOCATE ( WADATS(IMOD)%XTWS(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTWS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XCHARN = UNDEF - WADATS(IMOD)%XTWS = UNDEF - WADATS(IMOD)%XCGE = UNDEF - WADATS(IMOD)%XPHIAW = UNDEF - WADATS(IMOD)%XTAUWIX = UNDEF - WADATS(IMOD)%XTAUWIY = UNDEF - WADATS(IMOD)%XTAUWNX = UNDEF - WADATS(IMOD)%XTAUWNY = UNDEF - WADATS(IMOD)%XWHITECAP = UNDEF -! - IF ( OUTFLAGS( 6, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XSXX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XSYY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XSXY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XSXX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XSYY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XSXY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUOX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUOY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUOX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUOY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XBHD(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XBHD(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XPHIOC(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPHIOC(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XTUSX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTUSY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTUSX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTUSY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 6) ) THEN - ALLOCATE ( WADATS(IMOD)%XUSSX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XUSSY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XUSSX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XUSSY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 7) ) THEN - ALLOCATE ( WADATS(IMOD)%XPRMS(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTPMS(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPRMS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTPMS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 8) ) THEN - ALLOCATE ( WADATS(IMOD)%XUS3D(NXXX,2*NK), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XUS3D(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 9) ) THEN - ALLOCATE ( WADATS(IMOD)%XP2SMS(NXXX,P2MSF(2):P2MSF(3)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XP2SMS(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6,10) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUICE(NXXX,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUICE(1,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6,11) ) THEN - ALLOCATE ( WADATS(IMOD)%XPHICE(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPHICE(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 12) ) THEN - ALLOCATE ( WADATS(IMOD)%XUSSP(NXXX,2*NK), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XUSSP(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 13) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUOCX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUOCY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUOCX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUOCY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! + IF ( OUTFLAGS( 3, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XTH2M(NXXX,E3DF(2,4):E3DF(3,4)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTH2M(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 3, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XSTH2M(NXXX,E3DF(2,5):E3DF(3,5)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XSTH2M(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XEF = UNDEF + WADATS(IMOD)%XTH1M = UNDEF + WADATS(IMOD)%XSTH1M = UNDEF + WADATS(IMOD)%XTH2M = UNDEF + WADATS(IMOD)%XSTH2M = UNDEF + ! + IF ( OUTFLAGS( 4, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XPHS(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPHS(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XPTP(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPTP(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XPLP(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPLP(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XPDIR(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPDIR(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XPSI(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPSI(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 6) ) THEN + ALLOCATE ( WADATS(IMOD)%XPWS(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPWS(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 7) ) THEN + ALLOCATE ( WADATS(IMOD)%XPTHP0(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPTHP0(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 8) ) THEN + ALLOCATE ( WADATS(IMOD)%XPQP(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPQP(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 9) ) THEN + ALLOCATE ( WADATS(IMOD)%XPPE(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPPE(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,10) ) THEN + ALLOCATE ( WADATS(IMOD)%XPGW(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPGW(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,11) ) THEN + ALLOCATE ( WADATS(IMOD)%XPSW(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPSW(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,12) ) THEN + ALLOCATE ( WADATS(IMOD)%XPTM1(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPTM1(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,13) ) THEN + ALLOCATE ( WADATS(IMOD)%XPT1(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPT1(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,14) ) THEN + ALLOCATE ( WADATS(IMOD)%XPT2(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPT2(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,15) ) THEN + ALLOCATE ( WADATS(IMOD)%XPEP(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPEP(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,16) ) THEN + ALLOCATE ( WADATS(IMOD)%XPWST(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPWST(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,17) ) THEN + ALLOCATE ( WADATS(IMOD)%XPNR(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPNR(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XPHS = UNDEF + WADATS(IMOD)%XPTP = UNDEF + WADATS(IMOD)%XPLP = UNDEF + WADATS(IMOD)%XPDIR = UNDEF + WADATS(IMOD)%XPSI = UNDEF + WADATS(IMOD)%XPWS = UNDEF + WADATS(IMOD)%XPWST = UNDEF + WADATS(IMOD)%XPNR = UNDEF + WADATS(IMOD)%XPTHP0 = UNDEF + WADATS(IMOD)%XPQP = UNDEF + WADATS(IMOD)%XPPE = UNDEF + WADATS(IMOD)%XPGW = UNDEF + WADATS(IMOD)%XPSW = UNDEF + WADATS(IMOD)%XPTM1 = UNDEF + WADATS(IMOD)%XPT1 = UNDEF + WADATS(IMOD)%XPT2 = UNDEF + WADATS(IMOD)%XPEP = UNDEF + ! + IF ( OUTFLAGS( 5, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XCHARN(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XCHARN(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XCGE(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XCGE(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XPHIAW(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPHIAW(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUWIX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUWIY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUWIX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUWIY(1) ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 6) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUWNX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUWNY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUWNX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUWNY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 7) .OR. OUTFLAGS( 5, 8) .OR. & + OUTFLAGS( 5, 9) .OR. OUTFLAGS( 5,10)) THEN + ALLOCATE ( WADATS(IMOD)%XWHITECAP(NXXX,4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XWHITECAP(1,4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 11) ) THEN + ALLOCATE ( WADATS(IMOD)%XTWS(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTWS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XCHARN = UNDEF + WADATS(IMOD)%XTWS = UNDEF + WADATS(IMOD)%XCGE = UNDEF + WADATS(IMOD)%XPHIAW = UNDEF + WADATS(IMOD)%XTAUWIX = UNDEF + WADATS(IMOD)%XTAUWIY = UNDEF + WADATS(IMOD)%XTAUWNX = UNDEF + WADATS(IMOD)%XTAUWNY = UNDEF + WADATS(IMOD)%XWHITECAP = UNDEF + ! + IF ( OUTFLAGS( 6, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XSXX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XSYY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XSXY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XSXX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XSYY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XSXY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUOX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUOY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUOX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUOY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XBHD(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XBHD(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XPHIOC(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPHIOC(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XTUSX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTUSY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTUSX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTUSY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 6) ) THEN + ALLOCATE ( WADATS(IMOD)%XUSSX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XUSSY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XUSSX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XUSSY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 7) ) THEN + ALLOCATE ( WADATS(IMOD)%XPRMS(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTPMS(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPRMS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTPMS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 8) ) THEN + ALLOCATE ( WADATS(IMOD)%XUS3D(NXXX,2*NK), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XUS3D(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 9) ) THEN + ALLOCATE ( WADATS(IMOD)%XP2SMS(NXXX,P2MSF(2):P2MSF(3)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XP2SMS(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6,10) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUICE(NXXX,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUICE(1,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6,11) ) THEN + ALLOCATE ( WADATS(IMOD)%XPHICE(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPHICE(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 12) ) THEN + ALLOCATE ( WADATS(IMOD)%XUSSP(NXXX,2*NK), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XUSSP(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 13) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUOCX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUOCY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUOCX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUOCY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! #ifdef W3_CESMCOUPLED - IF ( OUTFLAGS( 6, 14) ) THEN - ALLOCATE ( WADATS(IMOD)%XLANGMT(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XLANGMT(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -#endif -! - WADATS(IMOD)%XSXX = UNDEF - WADATS(IMOD)%XSYY = UNDEF - WADATS(IMOD)%XSXY = UNDEF - WADATS(IMOD)%XTAUOX = UNDEF - WADATS(IMOD)%XTAUOY = UNDEF - WADATS(IMOD)%XBHD = UNDEF - WADATS(IMOD)%XPHIOC = UNDEF - WADATS(IMOD)%XTUSX = UNDEF - WADATS(IMOD)%XTUSY = UNDEF - WADATS(IMOD)%XUSSX = UNDEF - WADATS(IMOD)%XUSSY = UNDEF - WADATS(IMOD)%XPRMS = UNDEF - WADATS(IMOD)%XTPMS = UNDEF - WADATS(IMOD)%XUS3D = UNDEF - WADATS(IMOD)%XP2SMS = UNDEF - WADATS(IMOD)%XPHICE = UNDEF - WADATS(IMOD)%XTAUICE = UNDEF - WADATS(IMOD)%XUSSP = UNDEF - WADATS(IMOD)%XTAUOCX = UNDEF - WADATS(IMOD)%XTAUOCY = UNDEF + IF ( OUTFLAGS( 6, 14) ) THEN + ALLOCATE ( WADATS(IMOD)%XLANGMT(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XLANGMT(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF +#endif + ! + WADATS(IMOD)%XSXX = UNDEF + WADATS(IMOD)%XSYY = UNDEF + WADATS(IMOD)%XSXY = UNDEF + WADATS(IMOD)%XTAUOX = UNDEF + WADATS(IMOD)%XTAUOY = UNDEF + WADATS(IMOD)%XBHD = UNDEF + WADATS(IMOD)%XPHIOC = UNDEF + WADATS(IMOD)%XTUSX = UNDEF + WADATS(IMOD)%XTUSY = UNDEF + WADATS(IMOD)%XUSSX = UNDEF + WADATS(IMOD)%XUSSY = UNDEF + WADATS(IMOD)%XPRMS = UNDEF + WADATS(IMOD)%XTPMS = UNDEF + WADATS(IMOD)%XUS3D = UNDEF + WADATS(IMOD)%XP2SMS = UNDEF + WADATS(IMOD)%XPHICE = UNDEF + WADATS(IMOD)%XTAUICE = UNDEF + WADATS(IMOD)%XUSSP = UNDEF + WADATS(IMOD)%XTAUOCX = UNDEF + WADATS(IMOD)%XTAUOCY = UNDEF #ifdef W3_CESMCOUPLED - WADATS(IMOD)%XLANGMT = UNDEF -#endif -! - IF ( OUTFLAGS( 7, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XABA(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XABD(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XABA(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XABD(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 7, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XUBA(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XUBD(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XUBA(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XUBD(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 7, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XBEDFORMS(NXXX,3), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XBEDFORMS(1,3), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 7, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XPHIBBL(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPHIBBL(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 7, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUBBL(NXXX,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUBBL(1,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XABA = UNDEF - WADATS(IMOD)%XABD = UNDEF - WADATS(IMOD)%XUBA = UNDEF - WADATS(IMOD)%XUBD = UNDEF - WADATS(IMOD)%XBEDFORMS = UNDEF - WADATS(IMOD)%XPHIBBL = UNDEF - WADATS(IMOD)%XTAUBBL = UNDEF -! - IF ( OUTFLAGS( 8, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XMSSX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XMSSY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XMSSX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XMSSY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 8, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XMSCX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XMSCY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XMSCX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XMSCY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 8, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XMSSD(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XMSSD(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 8, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XMSCD(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XMSCD(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 8, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XQP(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XQP(1) ) - END IF -! - WADATS(IMOD)%XMSSX = UNDEF - WADATS(IMOD)%XMSSY = UNDEF - WADATS(IMOD)%XMSSD = UNDEF - WADATS(IMOD)%XMSCX = UNDEF - WADATS(IMOD)%XMSCY = UNDEF - WADATS(IMOD)%XMSCD = UNDEF - WADATS(IMOD)%XQP(1) = UNDEF -! - IF ( OUTFLAGS( 9, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XDTDYN(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XDTDYN(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 9, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XFCUT(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XFCUT(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 9, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XCFLXYMAX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XCFLXYMAX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 9, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XCFLTHMAX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XCFLTHMAX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 9, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XCFLKMAX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XCFLKMAX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XDTDYN = UNDEF - WADATS(IMOD)%XFCUT = UNDEF - WADATS(IMOD)%XCFLXYMAX = UNDEF - WADATS(IMOD)%XCFLTHMAX = UNDEF - WADATS(IMOD)%XCFLKMAX = UNDEF -! - DO I=1, NOEXTR - IF ( OUTFLAGS(10, i) ) THEN - ALLOCATE ( WADATS(IMOD)%XUSERO(NXXX,I), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XUSERO(1,I), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - END DO -! - WADATS(IMOD)%XUSERO = UNDEF -! - WADATS(IMOD)%AINIT2 = .TRUE. -! + WADATS(IMOD)%XLANGMT = UNDEF +#endif + ! + IF ( OUTFLAGS( 7, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XABA(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XABD(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XABA(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XABD(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 7, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XUBA(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XUBD(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XUBA(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XUBD(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 7, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XBEDFORMS(NXXX,3), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XBEDFORMS(1,3), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 7, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XPHIBBL(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPHIBBL(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 7, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUBBL(NXXX,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUBBL(1,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XABA = UNDEF + WADATS(IMOD)%XABD = UNDEF + WADATS(IMOD)%XUBA = UNDEF + WADATS(IMOD)%XUBD = UNDEF + WADATS(IMOD)%XBEDFORMS = UNDEF + WADATS(IMOD)%XPHIBBL = UNDEF + WADATS(IMOD)%XTAUBBL = UNDEF + ! + IF ( OUTFLAGS( 8, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XMSSX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XMSSY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XMSSX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XMSSY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 8, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XMSCX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XMSCY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XMSCX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XMSCY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 8, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XMSSD(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XMSSD(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 8, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XMSCD(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XMSCD(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 8, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XQP(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XQP(1) ) + END IF + ! + WADATS(IMOD)%XMSSX = UNDEF + WADATS(IMOD)%XMSSY = UNDEF + WADATS(IMOD)%XMSSD = UNDEF + WADATS(IMOD)%XMSCX = UNDEF + WADATS(IMOD)%XMSCY = UNDEF + WADATS(IMOD)%XMSCD = UNDEF + WADATS(IMOD)%XQP(1) = UNDEF + ! + IF ( OUTFLAGS( 9, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XDTDYN(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XDTDYN(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 9, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XFCUT(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XFCUT(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 9, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XCFLXYMAX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XCFLXYMAX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 9, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XCFLTHMAX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XCFLTHMAX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 9, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XCFLKMAX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XCFLKMAX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XDTDYN = UNDEF + WADATS(IMOD)%XFCUT = UNDEF + WADATS(IMOD)%XCFLXYMAX = UNDEF + WADATS(IMOD)%XCFLTHMAX = UNDEF + WADATS(IMOD)%XCFLKMAX = UNDEF + ! + DO I=1, NOEXTR + IF ( OUTFLAGS(10, i) ) THEN + ALLOCATE ( WADATS(IMOD)%XUSERO(NXXX,I), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XUSERO(1,I), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + END DO + ! + WADATS(IMOD)%XUSERO = UNDEF + ! + WADATS(IMOD)%AINIT2 = .TRUE. + ! #ifdef W3_T - WRITE (NDST,9001) - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! 5. Restore previous grid setting if necessary -! - IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) + WRITE (NDST,9001) + WRITE (NDST,9001) +#endif + ! + ! -------------------------------------------------------------------- / + ! 5. Restore previous grid setting if necessary + ! + IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) #ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3XDMA' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3XDMA : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3XDMA : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NADATA = ',I10/) - 1003 FORMAT (/' *** ERROR W3XDMA : ARRAY(S) ALREADY ALLOCATED *** ') -! + WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3XDMA' + call getMallocInfo(mallinfos) + call printMallInfo(30000+IAPROC,mallInfos) +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3XDMA : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3XDMA : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NADATA = ',I10/) +1003 FORMAT (/' *** ERROR W3XDMA : ARRAY(S) ALREADY ALLOCATED *** ') + ! #ifdef W3_T - 9000 FORMAT (' TEST W3XDMA : MODEL ',I4) - 9001 FORMAT (' TEST W3XDMA : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3XDMA : POINTERS RESET') - 9003 FORMAT (' TEST W3XDMA : DIMENSIONS STORED') -#endif -!/ -!/ End of W3XDMA ----------------------------------------------------- / -!/ - END SUBROUTINE W3XDMA -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize an individual data grid at the proper dimensions (DIA). -!> -!> @details Allocate directly into the structure array. Note that -!> this cannot be done through the pointer alias! -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> @param[in] NSP Array dimensions. -!> @param[in] NSPX Array dimensions. -!> -!> @author H. L. Tolman -!> @date 10-Dec-2014 -!> - SUBROUTINE W3DMNL ( IMOD, NDSE, NDST, NSP, NSPX ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 | -!/ +-----------------------------------+ -!/ -!/ 24-Dec-2004 : Origination. ( version 3.06 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Initialize an individual data grid at the proper dimensions (DIA). -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! NSP(X) Int. I Array dimensions. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! INSNL1 Subr. W3SNL1MD Traditional DIA approach to Snl. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - W3SETA needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS, IGRID, NK, NX, NY, NSEA, NSEAL, & - NSPEC, NTH, GTYPE, UNGTYPE - USE W3ODATMD, ONLY: NAPROC - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT (' TEST W3XDMA : MODEL ',I4) +9001 FORMAT (' TEST W3XDMA : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3XDMA : POINTERS RESET') +9003 FORMAT (' TEST W3XDMA : DIMENSIONS STORED') +#endif + !/ + !/ End of W3XDMA ----------------------------------------------------- / + !/ + END SUBROUTINE W3XDMA + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize an individual data grid at the proper dimensions (DIA). + !> + !> @details Allocate directly into the structure array. Note that + !> this cannot be done through the pointer alias! + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> @param[in] NSP Array dimensions. + !> @param[in] NSPX Array dimensions. + !> + !> @author H. L. Tolman + !> @date 10-Dec-2014 + !> + SUBROUTINE W3DMNL ( IMOD, NDSE, NDST, NSP, NSPX ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 | + !/ +-----------------------------------+ + !/ + !/ 24-Dec-2004 : Origination. ( version 3.06 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data grid at the proper dimensions (DIA). + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! NSP(X) Int. I Array dimensions. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! INSNL1 Subr. W3SNL1MD Traditional DIA approach to Snl. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - W3SETA needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS, IGRID, NK, NX, NY, NSEA, NSEAL, & + NSPEC, NTH, GTYPE, UNGTYPE + USE W3ODATMD, ONLY: NAPROC + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST, NSP, NSPX -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST, NSP, NSPX + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3DMNL') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN - WRITE (NDSE,1002) IMOD, NADATA - CALL EXTCDE (2) - END IF -! + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DMNL') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN + WRITE (NDSE,1002) IMOD, NADATA + CALL EXTCDE (2) + END IF + ! #ifdef W3_NL1 - IF ( WADATS(IMOD)%NLINIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF + IF ( WADATS(IMOD)%NLINIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) IMOD + WRITE (NDST,9000) IMOD #endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! -#ifdef W3_NL1 - ALLOCATE ( WADATS(IMOD)%IP11(NSPX), & - WADATS(IMOD)%IP12(NSPX), & - WADATS(IMOD)%IP13(NSPX), & - WADATS(IMOD)%IP14(NSPX), & - WADATS(IMOD)%IM11(NSPX), & - WADATS(IMOD)%IM12(NSPX), & - WADATS(IMOD)%IM13(NSPX), & - WADATS(IMOD)%IM14(NSPX), & - WADATS(IMOD)%IP21(NSPX), & - WADATS(IMOD)%IP22(NSPX), & - WADATS(IMOD)%IP23(NSPX), & - WADATS(IMOD)%IP24(NSPX), & - WADATS(IMOD)%IM21(NSPX), & - WADATS(IMOD)%IM22(NSPX), & - WADATS(IMOD)%IM23(NSPX), & - WADATS(IMOD)%IM24(NSPX), & - WADATS(IMOD)%IC11(NSP) , & - WADATS(IMOD)%IC12(NSP) , & - WADATS(IMOD)%IC21(NSP) , & - WADATS(IMOD)%IC22(NSP) , & - WADATS(IMOD)%IC31(NSP) , & - WADATS(IMOD)%IC32(NSP) , & - WADATS(IMOD)%IC41(NSP) , & - WADATS(IMOD)%IC42(NSP) , & - WADATS(IMOD)%IC51(NSP) , & - WADATS(IMOD)%IC52(NSP) , & - WADATS(IMOD)%IC61(NSP) , & - WADATS(IMOD)%IC62(NSP) , & - WADATS(IMOD)%IC71(NSP) , & - WADATS(IMOD)%IC72(NSP) , & - WADATS(IMOD)%IC81(NSP) , & - WADATS(IMOD)%IC82(NSP) , & - WADATS(IMOD)%AF11(NSPX), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! #ifdef W3_NL1 - WADATS(IMOD)%NLINIT = .TRUE. -#endif -! + ALLOCATE ( WADATS(IMOD)%IP11(NSPX), & + WADATS(IMOD)%IP12(NSPX), & + WADATS(IMOD)%IP13(NSPX), & + WADATS(IMOD)%IP14(NSPX), & + WADATS(IMOD)%IM11(NSPX), & + WADATS(IMOD)%IM12(NSPX), & + WADATS(IMOD)%IM13(NSPX), & + WADATS(IMOD)%IM14(NSPX), & + WADATS(IMOD)%IP21(NSPX), & + WADATS(IMOD)%IP22(NSPX), & + WADATS(IMOD)%IP23(NSPX), & + WADATS(IMOD)%IP24(NSPX), & + WADATS(IMOD)%IM21(NSPX), & + WADATS(IMOD)%IM22(NSPX), & + WADATS(IMOD)%IM23(NSPX), & + WADATS(IMOD)%IM24(NSPX), & + WADATS(IMOD)%IC11(NSP) , & + WADATS(IMOD)%IC12(NSP) , & + WADATS(IMOD)%IC21(NSP) , & + WADATS(IMOD)%IC22(NSP) , & + WADATS(IMOD)%IC31(NSP) , & + WADATS(IMOD)%IC32(NSP) , & + WADATS(IMOD)%IC41(NSP) , & + WADATS(IMOD)%IC42(NSP) , & + WADATS(IMOD)%IC51(NSP) , & + WADATS(IMOD)%IC52(NSP) , & + WADATS(IMOD)%IC61(NSP) , & + WADATS(IMOD)%IC62(NSP) , & + WADATS(IMOD)%IC71(NSP) , & + WADATS(IMOD)%IC72(NSP) , & + WADATS(IMOD)%IC81(NSP) , & + WADATS(IMOD)%IC82(NSP) , & + WADATS(IMOD)%AF11(NSPX), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%NLINIT = .TRUE. +#endif + ! #ifdef W3_T - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETA ( IMOD, NDSE, NDST ) -! + WRITE (NDST,9001) +#endif + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETA ( IMOD, NDSE, NDST ) + ! #ifdef W3_T - WRITE (NDST,9002) + WRITE (NDST,9002) #endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! #ifdef W3_NL1 - NSPECX = NSPX + NSPECX = NSPX #endif -! + ! #ifdef W3_T - WRITE (NDST,9003) -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DMNL : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DMNL : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NADATA = ',I10/) + WRITE (NDST,9003) +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DMNL : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DMNL : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NADATA = ',I10/) #ifdef W3_NL1 - 1003 FORMAT (/' *** ERROR W3DMNL : ARRAY(S) ALREADY ALLOCATED *** ') +1003 FORMAT (/' *** ERROR W3DMNL : ARRAY(S) ALREADY ALLOCATED *** ') #endif -! + ! #ifdef W3_T - 9000 FORMAT (' TEST W3DMNL : MODEL ',I4) - 9001 FORMAT (' TEST W3DMNL : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DMNL : POINTERS RESET') - 9003 FORMAT (' TEST W3DMNL : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DMNL ----------------------------------------------------- / -!/ - END SUBROUTINE W3DMNL -!/ ------------------------------------------------------------------- / -!> -!> @brief Select one of the WAVEWATCH III grids / models. -!> -!> @details Point pointers to the proper variables in the proper element -!> of the GRIDS array. -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author H. L. Tolman -!> @date 22-Mar-2021 -!> - SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2004 : Origination. ( version 3.06 ) -!/ 04-May-2005 : Adding MPI_COMM_WAVE. ( version 3.07 ) -!/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) -!/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) -!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 28_Mar-2007 : Add partitioned data arrays. ( version 3.11 ) -!/ Add aditional undefined arrays. -!/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) -!/ -! 1. Purpose : -! -! Select one of the WAVEWATCH III grids / models. -! -! 2. Method : -! -! Point pointers to the proper variables in the proper element of -! the GRIDS array. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation below. -! -! 5. Called by : -! -! Many subroutines in the WAVEWATCH system. -! -! 6. Error messages : -! -! Checks on parameter list IMOD. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/MPI Paralllel model environment. -! -! !/PRn Propagation scheme selection. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3IDATMD, ONLY: INPUTS - USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF, GTYPE, UNGTYPE -! - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT (' TEST W3DMNL : MODEL ',I4) +9001 FORMAT (' TEST W3DMNL : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DMNL : POINTERS RESET') +9003 FORMAT (' TEST W3DMNL : DIMENSIONS STORED') +#endif + !/ + !/ End of W3DMNL ----------------------------------------------------- / + !/ + END SUBROUTINE W3DMNL + !/ ------------------------------------------------------------------- / + !> + !> @brief Select one of the WAVEWATCH III grids / models. + !> + !> @details Point pointers to the proper variables in the proper element + !> of the GRIDS array. + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author H. L. Tolman + !> @date 22-Mar-2021 + !> + SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 28-Dec-2004 : Origination. ( version 3.06 ) + !/ 04-May-2005 : Adding MPI_COMM_WAVE. ( version 3.07 ) + !/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) + !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) + !/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 28_Mar-2007 : Add partitioned data arrays. ( version 3.11 ) + !/ Add aditional undefined arrays. + !/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Select one of the WAVEWATCH III grids / models. + ! + ! 2. Method : + ! + ! Point pointers to the proper variables in the proper element of + ! the GRIDS array. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation below. + ! + ! 5. Called by : + ! + ! Many subroutines in the WAVEWATCH system. + ! + ! 6. Error messages : + ! + ! Checks on parameter list IMOD. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/MPI Paralllel model environment. + ! + ! !/PRn Propagation scheme selection. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3IDATMD, ONLY: INPUTS + USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF, GTYPE, UNGTYPE + ! + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3SETA') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NADATA .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN - WRITE (NDSE,1002) IMOD, NADATA - CALL EXTCDE (2) - END IF -! + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SETA') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NADATA .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN + WRITE (NDSE,1002) IMOD, NADATA + CALL EXTCDE (2) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Set model numbers -! - IADATA = IMOD -! -! -------------------------------------------------------------------- / -! 3. Set pointers -! - ITIME => WADATS(IMOD)%ITIME - IPASS => WADATS(IMOD)%IPASS - IDLAST => WADATS(IMOD)%IDLAST - NSEALM => WADATS(IMOD)%NSEALM - FLCOLD => WADATS(IMOD)%FLCOLD - FLIWND => WADATS(IMOD)%FLIWND - AINIT => WADATS(IMOD)%AINIT - AINIT2 => WADATS(IMOD)%AINIT2 - FL_ALL => WADATS(IMOD)%FL_ALL -! + WRITE (NDST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Set model numbers + ! + IADATA = IMOD + ! + ! -------------------------------------------------------------------- / + ! 3. Set pointers + ! + ITIME => WADATS(IMOD)%ITIME + IPASS => WADATS(IMOD)%IPASS + IDLAST => WADATS(IMOD)%IDLAST + NSEALM => WADATS(IMOD)%NSEALM + FLCOLD => WADATS(IMOD)%FLCOLD + FLIWND => WADATS(IMOD)%FLIWND + AINIT => WADATS(IMOD)%AINIT + AINIT2 => WADATS(IMOD)%AINIT2 + FL_ALL => WADATS(IMOD)%FL_ALL + ! #ifdef W3_PR2 - NMX0 => WADATS(IMOD)%NMX0 - NMX1 => WADATS(IMOD)%NMX1 - NMX2 => WADATS(IMOD)%NMX2 - NMY0 => WADATS(IMOD)%NMY0 - NMY1 => WADATS(IMOD)%NMY1 - NMY2 => WADATS(IMOD)%NMY2 - NACT => WADATS(IMOD)%NACT - NMXY => WADATS(IMOD)%NMXY -#endif -! + NMX0 => WADATS(IMOD)%NMX0 + NMX1 => WADATS(IMOD)%NMX1 + NMX2 => WADATS(IMOD)%NMX2 + NMY0 => WADATS(IMOD)%NMY0 + NMY1 => WADATS(IMOD)%NMY1 + NMY2 => WADATS(IMOD)%NMY2 + NACT => WADATS(IMOD)%NACT + NMXY => WADATS(IMOD)%NMXY +#endif + ! #ifdef W3_PR3 - NMX0 => WADATS(IMOD)%NMX0 - NMX1 => WADATS(IMOD)%NMX1 - NMX2 => WADATS(IMOD)%NMX2 - NMY0 => WADATS(IMOD)%NMY0 - NMY1 => WADATS(IMOD)%NMY1 - NMY2 => WADATS(IMOD)%NMY2 - NACT => WADATS(IMOD)%NACT - NCENT => WADATS(IMOD)%NCENT -#endif -! + NMX0 => WADATS(IMOD)%NMX0 + NMX1 => WADATS(IMOD)%NMX1 + NMX2 => WADATS(IMOD)%NMX2 + NMY0 => WADATS(IMOD)%NMY0 + NMY1 => WADATS(IMOD)%NMY1 + NMY2 => WADATS(IMOD)%NMY2 + NACT => WADATS(IMOD)%NACT + NCENT => WADATS(IMOD)%NCENT +#endif + ! #ifdef W3_NL1 - NFR => WADATS(IMOD)%NFR - NFRHGH => WADATS(IMOD)%NFRHGH - NFRCHG => WADATS(IMOD)%NFRCHG - NSPECX => WADATS(IMOD)%NSPECX - NSPECY => WADATS(IMOD)%NSPECY - DAL1 => WADATS(IMOD)%DAL1 - DAL2 => WADATS(IMOD)%DAL2 - DAL3 => WADATS(IMOD)%DAL3 - AWG1 => WADATS(IMOD)%AWG1 - AWG2 => WADATS(IMOD)%AWG2 - AWG3 => WADATS(IMOD)%AWG3 - AWG4 => WADATS(IMOD)%AWG4 - AWG5 => WADATS(IMOD)%AWG5 - AWG6 => WADATS(IMOD)%AWG6 - AWG7 => WADATS(IMOD)%AWG7 - AWG8 => WADATS(IMOD)%AWG8 - SWG1 => WADATS(IMOD)%SWG1 - SWG2 => WADATS(IMOD)%SWG2 - SWG3 => WADATS(IMOD)%SWG3 - SWG4 => WADATS(IMOD)%SWG4 - SWG5 => WADATS(IMOD)%SWG5 - SWG6 => WADATS(IMOD)%SWG6 - SWG7 => WADATS(IMOD)%SWG7 - SWG8 => WADATS(IMOD)%SWG8 - NLINIT => WADATS(IMOD)%NLINIT -#endif -! + NFR => WADATS(IMOD)%NFR + NFRHGH => WADATS(IMOD)%NFRHGH + NFRCHG => WADATS(IMOD)%NFRCHG + NSPECX => WADATS(IMOD)%NSPECX + NSPECY => WADATS(IMOD)%NSPECY + DAL1 => WADATS(IMOD)%DAL1 + DAL2 => WADATS(IMOD)%DAL2 + DAL3 => WADATS(IMOD)%DAL3 + AWG1 => WADATS(IMOD)%AWG1 + AWG2 => WADATS(IMOD)%AWG2 + AWG3 => WADATS(IMOD)%AWG3 + AWG4 => WADATS(IMOD)%AWG4 + AWG5 => WADATS(IMOD)%AWG5 + AWG6 => WADATS(IMOD)%AWG6 + AWG7 => WADATS(IMOD)%AWG7 + AWG8 => WADATS(IMOD)%AWG8 + SWG1 => WADATS(IMOD)%SWG1 + SWG2 => WADATS(IMOD)%SWG2 + SWG3 => WADATS(IMOD)%SWG3 + SWG4 => WADATS(IMOD)%SWG4 + SWG5 => WADATS(IMOD)%SWG5 + SWG6 => WADATS(IMOD)%SWG6 + SWG7 => WADATS(IMOD)%SWG7 + SWG8 => WADATS(IMOD)%SWG8 + NLINIT => WADATS(IMOD)%NLINIT +#endif + ! #ifdef W3_MPI - MPI_COMM_WAVE => WADATS(IMOD)%MPI_COMM_WAVE - MPI_COMM_WCMP => WADATS(IMOD)%MPI_COMM_WCMP - WW3_FIELD_VEC => WADATS(IMOD)%WW3_FIELD_VEC - WW3_SPEC_VEC => WADATS(IMOD)%WW3_SPEC_VEC - NRQSG1 => WADATS(IMOD)%NRQSG1 - NRQSG2 => WADATS(IMOD)%NRQSG2 - IBFLOC => WADATS(IMOD)%IBFLOC - ISPLOC => WADATS(IMOD)%ISPLOC - NSPLOC => WADATS(IMOD)%NSPLOC - BSTAT => WADATS(IMOD)%BSTAT - BISPL => WADATS(IMOD)%BISPL -#endif -! - IF ( AINIT ) THEN -! - DW => WADATS(IMOD)%DW - UA => WADATS(IMOD)%UA - UD => WADATS(IMOD)%UD - U10 => WADATS(IMOD)%U10 - U10D => WADATS(IMOD)%U10D - AS => WADATS(IMOD)%AS - CX => WADATS(IMOD)%CX - CY => WADATS(IMOD)%CY - TAUA => WADATS(IMOD)%TAUA - TAUADIR=> WADATS(IMOD)%TAUADIR -! - HS => WADATS(IMOD)%HS - WLM => WADATS(IMOD)%WLM - T02 => WADATS(IMOD)%T02 - T0M1 => WADATS(IMOD)%T0M1 - T01 => WADATS(IMOD)%T01 - FP0 => WADATS(IMOD)%FP0 - THM => WADATS(IMOD)%THM - THS => WADATS(IMOD)%THS - THP0 => WADATS(IMOD)%THP0 - HSIG => WADATS(IMOD)%HSIG - STMAXE => WADATS(IMOD)%STMAXE - STMAXD => WADATS(IMOD)%STMAXD - HMAXE => WADATS(IMOD)%HMAXE - HMAXD => WADATS(IMOD)%HMAXD - HCMAXE => WADATS(IMOD)%HCMAXE - HCMAXD => WADATS(IMOD)%HCMAXD - QP => WADATS(IMOD)%QP - WBT => WADATS(IMOD)%WBT - WNMEAN => WADATS(IMOD)%WNMEAN -! - EF => WADATS(IMOD)%EF - TH1M => WADATS(IMOD)%TH1M - STH1M => WADATS(IMOD)%STH1M - TH2M => WADATS(IMOD)%TH2M - STH2M => WADATS(IMOD)%STH2M -! - PHS => WADATS(IMOD)%PHS - PTP => WADATS(IMOD)%PTP - PLP => WADATS(IMOD)%PLP - PDIR => WADATS(IMOD)%PDIR - PSI => WADATS(IMOD)%PSI - PWS => WADATS(IMOD)%PWS - PWST => WADATS(IMOD)%PWST - PNR => WADATS(IMOD)%PNR - PTHP0 => WADATS(IMOD)%PTHP0 - PQP => WADATS(IMOD)%PQP - PPE => WADATS(IMOD)%PPE - PGW => WADATS(IMOD)%PGW - PSW => WADATS(IMOD)%PSW - PTM1 => WADATS(IMOD)%PTM1 - PT1 => WADATS(IMOD)%PT1 - PT2 => WADATS(IMOD)%PT2 - PEP => WADATS(IMOD)%PEP -! - CHARN => WADATS(IMOD)%CHARN - TWS => WADATS(IMOD)%TWS - CGE => WADATS(IMOD)%CGE - PHIAW => WADATS(IMOD)%PHIAW - TAUWIX => WADATS(IMOD)%TAUWIX - TAUWIY => WADATS(IMOD)%TAUWIY - TAUWNX => WADATS(IMOD)%TAUWNX - TAUWNY => WADATS(IMOD)%TAUWNY - WHITECAP => WADATS(IMOD)%WHITECAP -! - SXX => WADATS(IMOD)%SXX - SYY => WADATS(IMOD)%SYY - SXY => WADATS(IMOD)%SXY - TAUOX => WADATS(IMOD)%TAUOX - TAUOY => WADATS(IMOD)%TAUOY - BHD => WADATS(IMOD)%BHD - PHIOC => WADATS(IMOD)%PHIOC - TUSX => WADATS(IMOD)%TUSX - TUSY => WADATS(IMOD)%TUSY - USSX => WADATS(IMOD)%USSX - USSY => WADATS(IMOD)%USSY - PRMS => WADATS(IMOD)%PRMS - TPMS => WADATS(IMOD)%TPMS - P2SMS => WADATS(IMOD)%P2SMS - US3D => WADATS(IMOD)%US3D - PHICE => WADATS(IMOD)%PHICE - TAUICE => WADATS(IMOD)%TAUICE - USSP => WADATS(IMOD)%USSP - TAUOCX => WADATS(IMOD)%TAUOCX - TAUOCY => WADATS(IMOD)%TAUOCY -! - ABA => WADATS(IMOD)%ABA - ABD => WADATS(IMOD)%ABD - UBA => WADATS(IMOD)%UBA - UBD => WADATS(IMOD)%UBD - BEDFORMS=> WADATS(IMOD)%BEDFORMS - PHIBBL => WADATS(IMOD)%PHIBBL - TAUBBL => WADATS(IMOD)%TAUBBL -! - MSSX => WADATS(IMOD)%MSSX - MSSY => WADATS(IMOD)%MSSY - MSSD => WADATS(IMOD)%MSSD - MSCX => WADATS(IMOD)%MSCX - MSCY => WADATS(IMOD)%MSCY - MSCD => WADATS(IMOD)%MSCD -! - DTDYN => WADATS(IMOD)%DTDYN - FCUT => WADATS(IMOD)%FCUT - CFLXYMAX => WADATS(IMOD)%CFLXYMAX - CFLTHMAX => WADATS(IMOD)%CFLTHMAX - CFLKMAX => WADATS(IMOD)%CFLKMAX -! - USERO => WADATS(IMOD)%USERO -! - WN => WADATS(IMOD)%WN + MPI_COMM_WAVE => WADATS(IMOD)%MPI_COMM_WAVE + MPI_COMM_WCMP => WADATS(IMOD)%MPI_COMM_WCMP + WW3_FIELD_VEC => WADATS(IMOD)%WW3_FIELD_VEC + WW3_SPEC_VEC => WADATS(IMOD)%WW3_SPEC_VEC + NRQSG1 => WADATS(IMOD)%NRQSG1 + NRQSG2 => WADATS(IMOD)%NRQSG2 + IBFLOC => WADATS(IMOD)%IBFLOC + ISPLOC => WADATS(IMOD)%ISPLOC + NSPLOC => WADATS(IMOD)%NSPLOC + BSTAT => WADATS(IMOD)%BSTAT + BISPL => WADATS(IMOD)%BISPL +#endif + ! + IF ( AINIT ) THEN + ! + DW => WADATS(IMOD)%DW + UA => WADATS(IMOD)%UA + UD => WADATS(IMOD)%UD + U10 => WADATS(IMOD)%U10 + U10D => WADATS(IMOD)%U10D + AS => WADATS(IMOD)%AS + CX => WADATS(IMOD)%CX + CY => WADATS(IMOD)%CY + TAUA => WADATS(IMOD)%TAUA + TAUADIR=> WADATS(IMOD)%TAUADIR + ! + HS => WADATS(IMOD)%HS + WLM => WADATS(IMOD)%WLM + T02 => WADATS(IMOD)%T02 + T0M1 => WADATS(IMOD)%T0M1 + T01 => WADATS(IMOD)%T01 + FP0 => WADATS(IMOD)%FP0 + THM => WADATS(IMOD)%THM + THS => WADATS(IMOD)%THS + THP0 => WADATS(IMOD)%THP0 + HSIG => WADATS(IMOD)%HSIG + STMAXE => WADATS(IMOD)%STMAXE + STMAXD => WADATS(IMOD)%STMAXD + HMAXE => WADATS(IMOD)%HMAXE + HMAXD => WADATS(IMOD)%HMAXD + HCMAXE => WADATS(IMOD)%HCMAXE + HCMAXD => WADATS(IMOD)%HCMAXD + QP => WADATS(IMOD)%QP + WBT => WADATS(IMOD)%WBT + WNMEAN => WADATS(IMOD)%WNMEAN + ! + EF => WADATS(IMOD)%EF + TH1M => WADATS(IMOD)%TH1M + STH1M => WADATS(IMOD)%STH1M + TH2M => WADATS(IMOD)%TH2M + STH2M => WADATS(IMOD)%STH2M + ! + PHS => WADATS(IMOD)%PHS + PTP => WADATS(IMOD)%PTP + PLP => WADATS(IMOD)%PLP + PDIR => WADATS(IMOD)%PDIR + PSI => WADATS(IMOD)%PSI + PWS => WADATS(IMOD)%PWS + PWST => WADATS(IMOD)%PWST + PNR => WADATS(IMOD)%PNR + PTHP0 => WADATS(IMOD)%PTHP0 + PQP => WADATS(IMOD)%PQP + PPE => WADATS(IMOD)%PPE + PGW => WADATS(IMOD)%PGW + PSW => WADATS(IMOD)%PSW + PTM1 => WADATS(IMOD)%PTM1 + PT1 => WADATS(IMOD)%PT1 + PT2 => WADATS(IMOD)%PT2 + PEP => WADATS(IMOD)%PEP + ! + CHARN => WADATS(IMOD)%CHARN + TWS => WADATS(IMOD)%TWS + CGE => WADATS(IMOD)%CGE + PHIAW => WADATS(IMOD)%PHIAW + TAUWIX => WADATS(IMOD)%TAUWIX + TAUWIY => WADATS(IMOD)%TAUWIY + TAUWNX => WADATS(IMOD)%TAUWNX + TAUWNY => WADATS(IMOD)%TAUWNY + WHITECAP => WADATS(IMOD)%WHITECAP + ! + SXX => WADATS(IMOD)%SXX + SYY => WADATS(IMOD)%SYY + SXY => WADATS(IMOD)%SXY + TAUOX => WADATS(IMOD)%TAUOX + TAUOY => WADATS(IMOD)%TAUOY + BHD => WADATS(IMOD)%BHD + PHIOC => WADATS(IMOD)%PHIOC + TUSX => WADATS(IMOD)%TUSX + TUSY => WADATS(IMOD)%TUSY + USSX => WADATS(IMOD)%USSX + USSY => WADATS(IMOD)%USSY + PRMS => WADATS(IMOD)%PRMS + TPMS => WADATS(IMOD)%TPMS + P2SMS => WADATS(IMOD)%P2SMS + US3D => WADATS(IMOD)%US3D + PHICE => WADATS(IMOD)%PHICE + TAUICE => WADATS(IMOD)%TAUICE + USSP => WADATS(IMOD)%USSP + TAUOCX => WADATS(IMOD)%TAUOCX + TAUOCY => WADATS(IMOD)%TAUOCY + ! + ABA => WADATS(IMOD)%ABA + ABD => WADATS(IMOD)%ABD + UBA => WADATS(IMOD)%UBA + UBD => WADATS(IMOD)%UBD + BEDFORMS=> WADATS(IMOD)%BEDFORMS + PHIBBL => WADATS(IMOD)%PHIBBL + TAUBBL => WADATS(IMOD)%TAUBBL + ! + MSSX => WADATS(IMOD)%MSSX + MSSY => WADATS(IMOD)%MSSY + MSSD => WADATS(IMOD)%MSSD + MSCX => WADATS(IMOD)%MSCX + MSCY => WADATS(IMOD)%MSCY + MSCD => WADATS(IMOD)%MSCD + ! + DTDYN => WADATS(IMOD)%DTDYN + FCUT => WADATS(IMOD)%FCUT + CFLXYMAX => WADATS(IMOD)%CFLXYMAX + CFLTHMAX => WADATS(IMOD)%CFLTHMAX + CFLKMAX => WADATS(IMOD)%CFLKMAX + ! + USERO => WADATS(IMOD)%USERO + ! + WN => WADATS(IMOD)%WN #ifdef W3_CESMCOUPLED - ! USSX and USSY are already set - LANGMT => WADATS(IMOD)%LANGMT - LAPROJ => WADATS(IMOD)%LAPROJ - LASL => WADATS(IMOD)%LASL - LASLPJ => WADATS(IMOD)%LASLPJ - ALPHAL => WADATS(IMOD)%ALPHAL - ALPHALS=> WADATS(IMOD)%ALPHALS - USSXH => WADATS(IMOD)%USSXH - USSYH => WADATS(IMOD)%USSYH - LAMULT => WADATS(IMOD)%LAMULT + ! USSX and USSY are already set + LANGMT => WADATS(IMOD)%LANGMT + LAPROJ => WADATS(IMOD)%LAPROJ + LASL => WADATS(IMOD)%LASL + LASLPJ => WADATS(IMOD)%LASLPJ + ALPHAL => WADATS(IMOD)%ALPHAL + ALPHALS=> WADATS(IMOD)%ALPHALS + USSXH => WADATS(IMOD)%USSXH + USSYH => WADATS(IMOD)%USSYH + LAMULT => WADATS(IMOD)%LAMULT #endif #ifdef W3_IC3 - IC3WN_R=> WADATS(IMOD)%IC3WN_R - IC3WN_I=> WADATS(IMOD)%IC3WN_I + IC3WN_R=> WADATS(IMOD)%IC3WN_R + IC3WN_I=> WADATS(IMOD)%IC3WN_I #endif -! - IF ( FL_ALL ) THEN -! - CG => WADATS(IMOD)%CG + ! + IF ( FL_ALL ) THEN + ! + CG => WADATS(IMOD)%CG #ifdef W3_IC3 - IC3CG => WADATS(IMOD)%IC3CG -#endif -! - ATRNX => WADATS(IMOD)%ATRNX - ATRNY => WADATS(IMOD)%ATRNY -! - DDDX => WADATS(IMOD)%DDDX - DDDY => WADATS(IMOD)%DDDY - DCDX => WADATS(IMOD)%DCDX - DCDY => WADATS(IMOD)%DCDY - DCXDX => WADATS(IMOD)%DCXDX - DCYDX => WADATS(IMOD)%DCYDX - DCXDY => WADATS(IMOD)%DCXDY - DCYDY => WADATS(IMOD)%DCYDY -! + IC3CG => WADATS(IMOD)%IC3CG +#endif + ! + ATRNX => WADATS(IMOD)%ATRNX + ATRNY => WADATS(IMOD)%ATRNY + ! + DDDX => WADATS(IMOD)%DDDX + DDDY => WADATS(IMOD)%DDDY + DCDX => WADATS(IMOD)%DCDX + DCDY => WADATS(IMOD)%DCDY + DCXDX => WADATS(IMOD)%DCXDX + DCYDX => WADATS(IMOD)%DCYDX + DCXDY => WADATS(IMOD)%DCXDY + DCYDY => WADATS(IMOD)%DCYDY + ! #ifdef W3_SMC - DHDX => WADATS(IMOD)%DHDX - DHDY => WADATS(IMOD)%DHDY - DHLMT => WADATS(IMOD)%DHLMT -#endif -! - ALPHA => WADATS(IMOD)%ALPHA -! - IF ( INPUTS(IMOD)%INFLAGS1(2) ) THEN - CA0 => WADATS(IMOD)%CA0 - CAI => WADATS(IMOD)%CAI - CD0 => WADATS(IMOD)%CD0 - CDI => WADATS(IMOD)%CDI - END IF -! - IF ( INPUTS(IMOD)%INFLAGS1(3) ) THEN - UA0 => WADATS(IMOD)%UA0 - UAI => WADATS(IMOD)%UAI - UD0 => WADATS(IMOD)%UD0 - UDI => WADATS(IMOD)%UDI - AS0 => WADATS(IMOD)%AS0 - ASI => WADATS(IMOD)%ASI - END IF -! - IF ( INPUTS(IMOD)%INFLAGS1(5) ) THEN - MA0 => WADATS(IMOD)%MA0 - MAI => WADATS(IMOD)%MAI - MD0 => WADATS(IMOD)%MD0 - MDI => WADATS(IMOD)%MDI - END IF -! - IF ( INPUTS(IMOD)%INFLAGS1(6) ) THEN - RA0 => WADATS(IMOD)%RA0 - RAI => WADATS(IMOD)%RAI - END IF -! + DHDX => WADATS(IMOD)%DHDX + DHDY => WADATS(IMOD)%DHDY + DHLMT => WADATS(IMOD)%DHLMT +#endif + ! + ALPHA => WADATS(IMOD)%ALPHA + ! + IF ( INPUTS(IMOD)%INFLAGS1(2) ) THEN + CA0 => WADATS(IMOD)%CA0 + CAI => WADATS(IMOD)%CAI + CD0 => WADATS(IMOD)%CD0 + CDI => WADATS(IMOD)%CDI + END IF + ! + IF ( INPUTS(IMOD)%INFLAGS1(3) ) THEN + UA0 => WADATS(IMOD)%UA0 + UAI => WADATS(IMOD)%UAI + UD0 => WADATS(IMOD)%UD0 + UDI => WADATS(IMOD)%UDI + AS0 => WADATS(IMOD)%AS0 + ASI => WADATS(IMOD)%ASI + END IF + ! + IF ( INPUTS(IMOD)%INFLAGS1(5) ) THEN + MA0 => WADATS(IMOD)%MA0 + MAI => WADATS(IMOD)%MAI + MD0 => WADATS(IMOD)%MD0 + MDI => WADATS(IMOD)%MDI + END IF + ! + IF ( INPUTS(IMOD)%INFLAGS1(6) ) THEN + RA0 => WADATS(IMOD)%RA0 + RAI => WADATS(IMOD)%RAI + END IF + ! #ifdef W3_PR1 - IS0 => WADATS(IMOD)%IS0 - IS2 => WADATS(IMOD)%IS2 - FACVX => WADATS(IMOD)%FACVX - FACVY => WADATS(IMOD)%FACVY + IS0 => WADATS(IMOD)%IS0 + IS2 => WADATS(IMOD)%IS2 + FACVX => WADATS(IMOD)%FACVX + FACVY => WADATS(IMOD)%FACVY #endif -! + ! #ifdef W3_PR2 - MAPX2 => WADATS(IMOD)%MAPX2 - MAPY2 => WADATS(IMOD)%MAPY2 - MAPAXY => WADATS(IMOD)%MAPAXY - MAPXY => WADATS(IMOD)%MAPXY - MAPTH2 => WADATS(IMOD)%MAPTH2 - MAPWN2 => WADATS(IMOD)%MAPWN2 -#endif -! + MAPX2 => WADATS(IMOD)%MAPX2 + MAPY2 => WADATS(IMOD)%MAPY2 + MAPAXY => WADATS(IMOD)%MAPAXY + MAPXY => WADATS(IMOD)%MAPXY + MAPTH2 => WADATS(IMOD)%MAPTH2 + MAPWN2 => WADATS(IMOD)%MAPWN2 +#endif + ! #ifdef W3_PR3 - MAPX2 => WADATS(IMOD)%MAPX2 - MAPY2 => WADATS(IMOD)%MAPY2 - MAPAXY => WADATS(IMOD)%MAPAXY - MAPCXY => WADATS(IMOD)%MAPCXY - MAPTH2 => WADATS(IMOD)%MAPTH2 - MAPWN2 => WADATS(IMOD)%MAPWN2 - MAPTRN => WADATS(IMOD)%MAPTRN -#endif -! - IF (GTYPE .EQ. UNGTYPE) ITER => WADATS(IMOD)%ITER -! - IAPPRO => WADATS(IMOD)%IAPPRO - SPPNT => WADATS(IMOD)%SPPNT -! - END IF -! - END IF -! + MAPX2 => WADATS(IMOD)%MAPX2 + MAPY2 => WADATS(IMOD)%MAPY2 + MAPAXY => WADATS(IMOD)%MAPAXY + MAPCXY => WADATS(IMOD)%MAPCXY + MAPTH2 => WADATS(IMOD)%MAPTH2 + MAPWN2 => WADATS(IMOD)%MAPWN2 + MAPTRN => WADATS(IMOD)%MAPTRN +#endif + ! + IF (GTYPE .EQ. UNGTYPE) ITER => WADATS(IMOD)%ITER + ! + IAPPRO => WADATS(IMOD)%IAPPRO + SPPNT => WADATS(IMOD)%SPPNT + ! + END IF + ! + END IF + ! #ifdef W3_NL1 - IF ( NLINIT ) THEN - IP11 => WADATS(IMOD)%IP11 - IP12 => WADATS(IMOD)%IP12 - IP13 => WADATS(IMOD)%IP13 - IP14 => WADATS(IMOD)%IP14 - IM11 => WADATS(IMOD)%IM11 - IM12 => WADATS(IMOD)%IM12 - IM13 => WADATS(IMOD)%IM13 - IM14 => WADATS(IMOD)%IM14 - IP21 => WADATS(IMOD)%IP21 - IP22 => WADATS(IMOD)%IP22 - IP23 => WADATS(IMOD)%IP23 - IP24 => WADATS(IMOD)%IP24 - IM21 => WADATS(IMOD)%IM21 - IM22 => WADATS(IMOD)%IM22 - IM23 => WADATS(IMOD)%IM23 - IM24 => WADATS(IMOD)%IM24 - IC11 => WADATS(IMOD)%IC11 - IC12 => WADATS(IMOD)%IC12 - IC21 => WADATS(IMOD)%IC21 - IC22 => WADATS(IMOD)%IC22 - IC31 => WADATS(IMOD)%IC31 - IC32 => WADATS(IMOD)%IC32 - IC41 => WADATS(IMOD)%IC41 - IC42 => WADATS(IMOD)%IC42 - IC51 => WADATS(IMOD)%IC51 - IC52 => WADATS(IMOD)%IC52 - IC61 => WADATS(IMOD)%IC61 - IC62 => WADATS(IMOD)%IC62 - IC71 => WADATS(IMOD)%IC71 - IC72 => WADATS(IMOD)%IC72 - IC81 => WADATS(IMOD)%IC81 - IC82 => WADATS(IMOD)%IC82 - AF11 => WADATS(IMOD)%AF11 - END IF + IF ( NLINIT ) THEN + IP11 => WADATS(IMOD)%IP11 + IP12 => WADATS(IMOD)%IP12 + IP13 => WADATS(IMOD)%IP13 + IP14 => WADATS(IMOD)%IP14 + IM11 => WADATS(IMOD)%IM11 + IM12 => WADATS(IMOD)%IM12 + IM13 => WADATS(IMOD)%IM13 + IM14 => WADATS(IMOD)%IM14 + IP21 => WADATS(IMOD)%IP21 + IP22 => WADATS(IMOD)%IP22 + IP23 => WADATS(IMOD)%IP23 + IP24 => WADATS(IMOD)%IP24 + IM21 => WADATS(IMOD)%IM21 + IM22 => WADATS(IMOD)%IM22 + IM23 => WADATS(IMOD)%IM23 + IM24 => WADATS(IMOD)%IM24 + IC11 => WADATS(IMOD)%IC11 + IC12 => WADATS(IMOD)%IC12 + IC21 => WADATS(IMOD)%IC21 + IC22 => WADATS(IMOD)%IC22 + IC31 => WADATS(IMOD)%IC31 + IC32 => WADATS(IMOD)%IC32 + IC41 => WADATS(IMOD)%IC41 + IC42 => WADATS(IMOD)%IC42 + IC51 => WADATS(IMOD)%IC51 + IC52 => WADATS(IMOD)%IC52 + IC61 => WADATS(IMOD)%IC61 + IC62 => WADATS(IMOD)%IC62 + IC71 => WADATS(IMOD)%IC71 + IC72 => WADATS(IMOD)%IC72 + IC81 => WADATS(IMOD)%IC81 + IC82 => WADATS(IMOD)%IC82 + AF11 => WADATS(IMOD)%AF11 + END IF #endif #ifdef W3_MPI - IF ( NRQSG1 .NE. 0 ) THEN - IRQSG1 => WADATS(IMOD)%IRQSG1 - IRQSG2 => WADATS(IMOD)%IRQSG2 - END IF -#endif -! -#ifdef W3_MPI - GSTORE => WADATS(IMOD)%GSTORE - SSTORE => WADATS(IMOD)%SSTORE -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3SETA : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3SETA : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NADATA = ',I10/) -! + IF ( NRQSG1 .NE. 0 ) THEN + IRQSG1 => WADATS(IMOD)%IRQSG1 + IRQSG2 => WADATS(IMOD)%IRQSG2 + END IF + GSTORE => WADATS(IMOD)%GSTORE + SSTORE => WADATS(IMOD)%SSTORE +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3SETA : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3SETA : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NADATA = ',I10/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SETA : MODEL ',I4,' SELECTED') -#endif -!/ -!/ End of W3SETA ----------------------------------------------------- / -!/ - END SUBROUTINE W3SETA -!/ ------------------------------------------------------------------- / -!> -!> @brief Reduced version of W3SETA to point to expended output arrays. -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author H. L. Tolman -!> @date 22-Mar-2021 -!> - SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 25-Dec-2012 : Origination. ( version 4.11 ) -!/ 30-Apr-2014 : Add s/th1-2m ( version 5.01 ) -!/ 22-Mar-2021 : Adds WNMEAN, TAUOC parameters ( version 7.13 ) -!/ -! 1. Purpose : -! -! Reduced version of W3SETA to point t expended output arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3IDATMD, ONLY: INPUTS - USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF, GTYPE, UNGTYPE -! - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ +9000 FORMAT (' TEST W3SETA : MODEL ',I4,' SELECTED') +#endif + !/ + !/ End of W3SETA ----------------------------------------------------- / + !/ + END SUBROUTINE W3SETA + !/ ------------------------------------------------------------------- / + !> + !> @brief Reduced version of W3SETA to point to expended output arrays. + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author H. L. Tolman + !> @date 22-Mar-2021 + !> + SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 25-Dec-2012 : Origination. ( version 4.11 ) + !/ 30-Apr-2014 : Add s/th1-2m ( version 5.01 ) + !/ 22-Mar-2021 : Adds WNMEAN, TAUOC parameters ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Reduced version of W3SETA to point t expended output arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3IDATMD, ONLY: INPUTS + USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF, GTYPE, UNGTYPE + ! + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3XETA') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NADATA .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN - WRITE (NDSE,1002) IMOD, NADATA - CALL EXTCDE (2) - END IF -! + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3XETA') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NADATA .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN + WRITE (NDSE,1002) IMOD, NADATA + CALL EXTCDE (2) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Set model numbers -! - IADATA = IMOD -! -! -------------------------------------------------------------------- / -! 3. Set pointers -! - IF ( AINIT2 ) THEN -! - HS => WADATS(IMOD)%XHS - WLM => WADATS(IMOD)%XWLM - T02 => WADATS(IMOD)%XT02 - T0M1 => WADATS(IMOD)%XT0M1 - T01 => WADATS(IMOD)%XT01 - FP0 => WADATS(IMOD)%XFP0 - THM => WADATS(IMOD)%XTHM - THS => WADATS(IMOD)%XTHS - THP0 => WADATS(IMOD)%XTHP0 - HSIG => WADATS(IMOD)%XHSIG - STMAXE => WADATS(IMOD)%XSTMAXE - STMAXD => WADATS(IMOD)%XSTMAXD - HMAXE => WADATS(IMOD)%XHMAXE - HMAXD => WADATS(IMOD)%XHMAXD - HCMAXE => WADATS(IMOD)%XHCMAXE - HCMAXD => WADATS(IMOD)%XHCMAXD - QP => WADATS(IMOD)%XQP - WBT => WADATS(IMOD)%XWBT - WNMEAN => WADATS(IMOD)%XWNMEAN -! - EF => WADATS(IMOD)%XEF - TH1M => WADATS(IMOD)%XTH1M - STH1M => WADATS(IMOD)%XSTH1M - TH2M => WADATS(IMOD)%XTH2M - STH2M => WADATS(IMOD)%XSTH2M -! - PHS => WADATS(IMOD)%XPHS - PTP => WADATS(IMOD)%XPTP - PLP => WADATS(IMOD)%XPLP - PDIR => WADATS(IMOD)%XPDIR - PSI => WADATS(IMOD)%XPSI - PWS => WADATS(IMOD)%XPWS - PWST => WADATS(IMOD)%XPWST - PNR => WADATS(IMOD)%XPNR - PTHP0 => WADATS(IMOD)%XPTHP0 - PQP => WADATS(IMOD)%XPQP - PPE => WADATS(IMOD)%XPPE - PGW => WADATS(IMOD)%XPGW - PSW => WADATS(IMOD)%XPSW - PTM1 => WADATS(IMOD)%XPTM1 - PT1 => WADATS(IMOD)%XPT1 - PT2 => WADATS(IMOD)%XPT2 - PEP => WADATS(IMOD)%XPEP -! - CHARN => WADATS(IMOD)%XCHARN - TWS => WADATS(IMOD)%XTWS - CGE => WADATS(IMOD)%XCGE - PHIAW => WADATS(IMOD)%XPHIAW - TAUWIX => WADATS(IMOD)%XTAUWIX - TAUWIY => WADATS(IMOD)%XTAUWIY - TAUWNX => WADATS(IMOD)%XTAUWNX - TAUWNY => WADATS(IMOD)%XTAUWNY - WHITECAP => WADATS(IMOD)%XWHITECAP -! - SXX => WADATS(IMOD)%XSXX - SYY => WADATS(IMOD)%XSYY - SXY => WADATS(IMOD)%XSXY - TAUOX => WADATS(IMOD)%XTAUOX - TAUOY => WADATS(IMOD)%XTAUOY - BHD => WADATS(IMOD)%XBHD - PHIOC => WADATS(IMOD)%XPHIOC - TUSX => WADATS(IMOD)%XTUSX - TUSY => WADATS(IMOD)%XTUSY - USSX => WADATS(IMOD)%XUSSX - USSY => WADATS(IMOD)%XUSSY - PRMS => WADATS(IMOD)%XPRMS - TPMS => WADATS(IMOD)%XTPMS - P2SMS => WADATS(IMOD)%XP2SMS - US3D => WADATS(IMOD)%XUS3D - PHICE => WADATS(IMOD)%XPHICE - TAUICE => WADATS(IMOD)%XTAUICE - USSP => WADATS(IMOD)%XUSSP - TAUOCX => WADATS(IMOD)%XTAUOCX - TAUOCY => WADATS(IMOD)%XTAUOCY - ABA => WADATS(IMOD)%XABA - ABD => WADATS(IMOD)%XABD - UBA => WADATS(IMOD)%XUBA - UBD => WADATS(IMOD)%XUBD - BEDFORMS=> WADATS(IMOD)%XBEDFORMS - PHIBBL => WADATS(IMOD)%XPHIBBL - TAUBBL => WADATS(IMOD)%XTAUBBL + WRITE (NDST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Set model numbers + ! + IADATA = IMOD + ! + ! -------------------------------------------------------------------- / + ! 3. Set pointers + ! + IF ( AINIT2 ) THEN + ! + HS => WADATS(IMOD)%XHS + WLM => WADATS(IMOD)%XWLM + T02 => WADATS(IMOD)%XT02 + T0M1 => WADATS(IMOD)%XT0M1 + T01 => WADATS(IMOD)%XT01 + FP0 => WADATS(IMOD)%XFP0 + THM => WADATS(IMOD)%XTHM + THS => WADATS(IMOD)%XTHS + THP0 => WADATS(IMOD)%XTHP0 + HSIG => WADATS(IMOD)%XHSIG + STMAXE => WADATS(IMOD)%XSTMAXE + STMAXD => WADATS(IMOD)%XSTMAXD + HMAXE => WADATS(IMOD)%XHMAXE + HMAXD => WADATS(IMOD)%XHMAXD + HCMAXE => WADATS(IMOD)%XHCMAXE + HCMAXD => WADATS(IMOD)%XHCMAXD + QP => WADATS(IMOD)%XQP + WBT => WADATS(IMOD)%XWBT + WNMEAN => WADATS(IMOD)%XWNMEAN + ! + EF => WADATS(IMOD)%XEF + TH1M => WADATS(IMOD)%XTH1M + STH1M => WADATS(IMOD)%XSTH1M + TH2M => WADATS(IMOD)%XTH2M + STH2M => WADATS(IMOD)%XSTH2M + ! + PHS => WADATS(IMOD)%XPHS + PTP => WADATS(IMOD)%XPTP + PLP => WADATS(IMOD)%XPLP + PDIR => WADATS(IMOD)%XPDIR + PSI => WADATS(IMOD)%XPSI + PWS => WADATS(IMOD)%XPWS + PWST => WADATS(IMOD)%XPWST + PNR => WADATS(IMOD)%XPNR + PTHP0 => WADATS(IMOD)%XPTHP0 + PQP => WADATS(IMOD)%XPQP + PPE => WADATS(IMOD)%XPPE + PGW => WADATS(IMOD)%XPGW + PSW => WADATS(IMOD)%XPSW + PTM1 => WADATS(IMOD)%XPTM1 + PT1 => WADATS(IMOD)%XPT1 + PT2 => WADATS(IMOD)%XPT2 + PEP => WADATS(IMOD)%XPEP + ! + CHARN => WADATS(IMOD)%XCHARN + TWS => WADATS(IMOD)%XTWS + CGE => WADATS(IMOD)%XCGE + PHIAW => WADATS(IMOD)%XPHIAW + TAUWIX => WADATS(IMOD)%XTAUWIX + TAUWIY => WADATS(IMOD)%XTAUWIY + TAUWNX => WADATS(IMOD)%XTAUWNX + TAUWNY => WADATS(IMOD)%XTAUWNY + WHITECAP => WADATS(IMOD)%XWHITECAP + ! + SXX => WADATS(IMOD)%XSXX + SYY => WADATS(IMOD)%XSYY + SXY => WADATS(IMOD)%XSXY + TAUOX => WADATS(IMOD)%XTAUOX + TAUOY => WADATS(IMOD)%XTAUOY + BHD => WADATS(IMOD)%XBHD + PHIOC => WADATS(IMOD)%XPHIOC + TUSX => WADATS(IMOD)%XTUSX + TUSY => WADATS(IMOD)%XTUSY + USSX => WADATS(IMOD)%XUSSX + USSY => WADATS(IMOD)%XUSSY + PRMS => WADATS(IMOD)%XPRMS + TPMS => WADATS(IMOD)%XTPMS + P2SMS => WADATS(IMOD)%XP2SMS + US3D => WADATS(IMOD)%XUS3D + PHICE => WADATS(IMOD)%XPHICE + TAUICE => WADATS(IMOD)%XTAUICE + USSP => WADATS(IMOD)%XUSSP + TAUOCX => WADATS(IMOD)%XTAUOCX + TAUOCY => WADATS(IMOD)%XTAUOCY + ABA => WADATS(IMOD)%XABA + ABD => WADATS(IMOD)%XABD + UBA => WADATS(IMOD)%XUBA + UBD => WADATS(IMOD)%XUBD + BEDFORMS=> WADATS(IMOD)%XBEDFORMS + PHIBBL => WADATS(IMOD)%XPHIBBL + TAUBBL => WADATS(IMOD)%XTAUBBL #ifdef W3_CESMCOUPLED - LANGMT => WADATS(IMOD)%XLANGMT -#endif -! - MSSX => WADATS(IMOD)%XMSSX - MSSY => WADATS(IMOD)%XMSSY - MSSD => WADATS(IMOD)%XMSSD - MSCX => WADATS(IMOD)%XMSCX - MSCY => WADATS(IMOD)%XMSCY - MSCD => WADATS(IMOD)%XMSCD -! - DTDYN => WADATS(IMOD)%XDTDYN - FCUT => WADATS(IMOD)%XFCUT - CFLXYMAX => WADATS(IMOD)%XCFLXYMAX - CFLTHMAX => WADATS(IMOD)%XCFLTHMAX - CFLKMAX => WADATS(IMOD)%XCFLKMAX -! - USERO => WADATS(IMOD)%XUSERO -! - END IF -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3XETA : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3XETA : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NADATA = ',I10/) -! + LANGMT => WADATS(IMOD)%XLANGMT +#endif + ! + MSSX => WADATS(IMOD)%XMSSX + MSSY => WADATS(IMOD)%XMSSY + MSSD => WADATS(IMOD)%XMSSD + MSCX => WADATS(IMOD)%XMSCX + MSCY => WADATS(IMOD)%XMSCY + MSCD => WADATS(IMOD)%XMSCD + ! + DTDYN => WADATS(IMOD)%XDTDYN + FCUT => WADATS(IMOD)%XFCUT + CFLXYMAX => WADATS(IMOD)%XCFLXYMAX + CFLTHMAX => WADATS(IMOD)%XCFLTHMAX + CFLKMAX => WADATS(IMOD)%XCFLKMAX + ! + USERO => WADATS(IMOD)%XUSERO + ! + END IF + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3XETA : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3XETA : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NADATA = ',I10/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3XETA : MODEL ',I4,' SELECTED') -#endif -!/ -!/ End of W3XETA ----------------------------------------------------- / -!/ - END SUBROUTINE W3XETA -!/ -!/ End of module W3ADATMD -------------------------------------------- / -!/ - END MODULE W3ADATMD +9000 FORMAT (' TEST W3XETA : MODEL ',I4,' SELECTED') +#endif + !/ + !/ End of W3XETA ----------------------------------------------------- / + !/ + END SUBROUTINE W3XETA + !/ + !/ End of module W3ADATMD -------------------------------------------- / + !/ +END MODULE W3ADATMD diff --git a/model/src/w3agcmmd.F90 b/model/src/w3agcmmd.F90 index 61d9768bc..dbe7741ea 100644 --- a/model/src/w3agcmmd.F90 +++ b/model/src/w3agcmmd.F90 @@ -1,7 +1,7 @@ -!> @file +!> @file !> @brief Contains module used for coupling applications between atmospheric model !> and WW3 with OASIS3-MCT. -!> +!> !> @author J. Pianezze !> @date Mar-2021 !> @@ -11,7 +11,7 @@ !> !> @brief Module used for coupling applications between atmospheric model !> and WW3 with OASIS3-MCT. -!> +!> !> @author J. Pianezze !> @date Mar-2021 !> @@ -20,444 +20,443 @@ !> reserved. WAVEWATCH III is a trademark of the NWS. !> No unauthorized use without permission. !> - MODULE W3AGCMMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | J. Pianezze | -!/ | FORTRAN 90 | -!/ | Last update : Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ Mar-2014 : Origination. ( version 4.18 ) -!/ For upgrades see subroutines. -!/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ Mar-2021 : Add TAUA and RHOA coupling ( version 7.13 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Module used for coupling applications between atmospheric model and WW3 with OASIS3-MCT -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! SND_FIELDS_TO_ATMOS Subr. Public Send fields to atmos model -! RCV_FIELDS_FROM_ATMOS Subr. Public Receive fields from atmos model -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! CPL_OASIS_SEND Subr. W3OACPMD Send fields -! CPL_OASIS_RECV Subr. W3OACPMD Receive fields -! ---------------------------------------------------------------- -! -! 5. Remarks -! 6. Switches : -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -! - IMPLICIT NONE -! - INCLUDE "mpif.h" -! - PRIVATE -! -! * Accessibility - PUBLIC SND_FIELDS_TO_ATMOS - PUBLIC RCV_FIELDS_FROM_ATMOS -! - CONTAINS -!/ ------------------------------------------------------------------- / +MODULE W3AGCMMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | J. Pianezze | + !/ | FORTRAN 90 | + !/ | Last update : Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ Mar-2014 : Origination. ( version 4.18 ) + !/ For upgrades see subroutines. + !/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ Mar-2021 : Add TAUA and RHOA coupling ( version 7.13 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Module used for coupling applications between atmospheric model and WW3 with OASIS3-MCT + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! SND_FIELDS_TO_ATMOS Subr. Public Send fields to atmos model + ! RCV_FIELDS_FROM_ATMOS Subr. Public Receive fields from atmos model + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! CPL_OASIS_SEND Subr. W3OACPMD Send fields + ! CPL_OASIS_RECV Subr. W3OACPMD Receive fields + ! ---------------------------------------------------------------- + ! + ! 5. Remarks + ! 6. Switches : + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + IMPLICIT NONE + ! + INCLUDE "mpif.h" + ! + PRIVATE + ! + ! * Accessibility + PUBLIC SND_FIELDS_TO_ATMOS + PUBLIC RCV_FIELDS_FROM_ATMOS + ! +CONTAINS + !/ ------------------------------------------------------------------- / -!> -!> @brief Send coupling fields to atmospheric model. -!> -!> @author J. Pianezze -!> @date Apr-2016 -!> - SUBROUTINE SND_FIELDS_TO_ATMOS() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | J. Pianezze | -!/ | FORTRAN 90 | -!/ | Last update : Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ Mar-2014 : Origination. ( version 4.18 ) -!/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ -! 1. Purpose : -! -! Send coupling fields to atmospheric model -! -! 2. Method : -! 3. Parameters : -! 4. Subroutines used : -! -! Name Type Module Description -! ------------------------------------------------------------------- -! CPL_OASIS_SND Subr. W3OACPMD Send field to atmos/ocean model -! ------------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ------------------------------------------------------------------ -! W3WAVE Subr. W3WAVEMD Wave model -! ------------------------------------------------------------------ -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_SND, SND_FLD, CPL_OASIS_SND - USE W3GDATMD, ONLY: NSEAL, NSEA - USE W3ADATMD, ONLY: CX, CY, CHARN, HS, FP0, TWS - USE W3ODATMD, ONLY: UNDEF, NAPROC, IAPROC -! -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_SND - INTEGER :: IB_DO - LOGICAL :: LL_ACTION - REAL(kind=8), DIMENSION(NSEAL) :: TMP - INTEGER :: JSEA, ISEA -! -!---------------------------------------------------------------------- -! * Executable part -! - DO IB_DO = 1, IL_NB_SND - ! - ! Ocean sea surface current (m.s-1) (u-component) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_WSSU') THEN - TMP(1:NSEAL) = 0.0 - DO JSEA=1, NSEAL - ISEA=IAPROC+(JSEA-1)*NAPROC - IF(CX(ISEA) /= UNDEF) TMP(JSEA)=CX(ISEA) - END DO - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Ocean sea surface current (m.s-1) (v-component) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_WSSV') THEN - TMP(1:NSEAL) = 0.0 - DO JSEA=1, NSEAL - ISEA=IAPROC+(JSEA-1)*NAPROC - IF(CY(ISEA) /= UNDEF) TMP(JSEA)=CY(ISEA) - END DO - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Charnock Coefficient (-) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_ACHA') THEN - TMP(1:NSEAL) = 0.0 - WHERE(CHARN(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=CHARN(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Significant wave height (m) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__AHS') THEN - TMP(1:NSEAL) = 0.0 - WHERE(HS(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=HS(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Peak frequency (s-1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3___FP') THEN - TMP(1:NSEAL) = 0.0 - WHERE(FP0(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=FP0(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Peak period (s) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3___TP') THEN - TMP(1:NSEAL) = 0.0 - WHERE(FP0(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=1./FP0(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Wind sea Mean period (s) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__FWS') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TWS(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TWS(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! + !> + !> @brief Send coupling fields to atmospheric model. + !> + !> @author J. Pianezze + !> @date Apr-2016 + !> + SUBROUTINE SND_FIELDS_TO_ATMOS() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | J. Pianezze | + !/ | FORTRAN 90 | + !/ | Last update : Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ Mar-2014 : Origination. ( version 4.18 ) + !/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ + ! 1. Purpose : + ! + ! Send coupling fields to atmospheric model + ! + ! 2. Method : + ! 3. Parameters : + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------- + ! CPL_OASIS_SND Subr. W3OACPMD Send field to atmos/ocean model + ! ------------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------ + ! W3WAVE Subr. W3WAVEMD Wave model + ! ------------------------------------------------------------------ + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_SND, SND_FLD, CPL_OASIS_SND + USE W3GDATMD, ONLY: NSEAL, NSEA + USE W3ADATMD, ONLY: CX, CY, CHARN, HS, FP0, TWS + USE W3ODATMD, ONLY: UNDEF, NAPROC, IAPROC + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_SND + INTEGER :: IB_DO + LOGICAL :: LL_ACTION + REAL(kind=8), DIMENSION(NSEAL) :: TMP + INTEGER :: JSEA, ISEA + ! + !---------------------------------------------------------------------- + ! * Executable part + ! + DO IB_DO = 1, IL_NB_SND + ! + ! Ocean sea surface current (m.s-1) (u-component) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_WSSU') THEN + TMP(1:NSEAL) = 0.0 + DO JSEA=1, NSEAL + ISEA=IAPROC+(JSEA-1)*NAPROC + IF(CX(ISEA) /= UNDEF) TMP(JSEA)=CX(ISEA) + END DO + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Ocean sea surface current (m.s-1) (v-component) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_WSSV') THEN + TMP(1:NSEAL) = 0.0 + DO JSEA=1, NSEAL + ISEA=IAPROC+(JSEA-1)*NAPROC + IF(CY(ISEA) /= UNDEF) TMP(JSEA)=CY(ISEA) + END DO + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Charnock Coefficient (-) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_ACHA') THEN + TMP(1:NSEAL) = 0.0 + WHERE(CHARN(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=CHARN(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Significant wave height (m) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__AHS') THEN + TMP(1:NSEAL) = 0.0 + WHERE(HS(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=HS(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Peak frequency (s-1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3___FP') THEN + TMP(1:NSEAL) = 0.0 + WHERE(FP0(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=FP0(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Peak period (s) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3___TP') THEN + TMP(1:NSEAL) = 0.0 + WHERE(FP0(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=1./FP0(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Wind sea Mean period (s) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__FWS') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TWS(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TWS(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! - ENDDO -! -!/ ------------------------------------------------------------------- / - END SUBROUTINE SND_FIELDS_TO_ATMOS + ENDDO + ! + !/ ------------------------------------------------------------------- / + END SUBROUTINE SND_FIELDS_TO_ATMOS -!> -!> @brief Receive coupling fields from atmospheric model. -!> -!> @param[in] ID_LCOMM MPI communicator. -!> @param[in] IDFLD Name of the exchange fields. -!> @param[inout] FXN First exchange field. -!> @param[inout] FYN Second exchange field. -!> @param[inout] FAN Third exchange field. -!> -!> @author J. Pianezze -!> @date Mar-2021 -!> -!/ ------------------------------------------------------------------- / - SUBROUTINE RCV_FIELDS_FROM_ATMOS(ID_LCOMM, IDFLD, FXN, FYN, FAN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | J. Pianezze | -!/ | FORTRAN 90 | -!/ | Last update : Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ Mar-2014 : Origination. ( version 4.18 ) -!/ Apr-2015 : Modification (M. Accensi) ( version 5.07 ) -!/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ Mar-2021 : Add TAUA and RHOA coupling ( version 7.13 ) -!/ -! 1. Purpose : -! -! Receive coupling fields from atmospheric model -! -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ID_LCOMM Char. I MPI communicator -! IDFLD Int. I Name of the exchange fields -! FXN Int. I/O First exchange field -! FYN Int. I/O Second exchange field -! FAN Int. I/O Third exchange field -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ------------------------------------------------------------------- -! CPL_OASIS_RCV Subr. W3OACPMD Receive fields from atmos/ocean model -! W3S2XY Subr. W3SERVMD Convert from storage (NSEA) to spatial grid (NX, NY) -! ------------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ------------------------------------------------------------------ -! W3FLDG Subr. W3FLDSMD Manage input fields of depth, -! current, wind and ice concentration -! ------------------------------------------------------------------ -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_RCV, RCV_FLD, CPL_OASIS_RCV - USE W3GDATMD, ONLY: NX, NY, NSEAL, NSEA, MAPSF - USE W3ODATMD, ONLY: NAPROC, IAPROC - USE W3SERVMD, ONLY: W3S2XY -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ID_LCOMM - CHARACTER(LEN=3), INTENT(IN) :: IDFLD - REAL, INTENT(INOUT) :: FXN(:,:), FYN(:,:), FAN(:,:) -! -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - LOGICAL :: LL_ACTION - INTEGER :: IB_DO, IB_I, IB_J, IL_ERR - REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_RCV - REAL(kind=8), DIMENSION(NSEAL) :: TMP - REAL, DIMENSION(1:NSEA) :: SND_BUFF,RCV_BUFF -! -!---------------------------------------------------------------------- -! * Executable part -! - RLA_OASIS_RCV(:,:) = 0.0 -! - DO IB_DO = 1, IL_NB_RCV - IF (IDFLD == 'WND') THEN + !> + !> @brief Receive coupling fields from atmospheric model. + !> + !> @param[in] ID_LCOMM MPI communicator. + !> @param[in] IDFLD Name of the exchange fields. + !> @param[inout] FXN First exchange field. + !> @param[inout] FYN Second exchange field. + !> @param[inout] FAN Third exchange field. + !> + !> @author J. Pianezze + !> @date Mar-2021 + !> + !/ ------------------------------------------------------------------- / + SUBROUTINE RCV_FIELDS_FROM_ATMOS(ID_LCOMM, IDFLD, FXN, FYN, FAN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | J. Pianezze | + !/ | FORTRAN 90 | + !/ | Last update : Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ Mar-2014 : Origination. ( version 4.18 ) + !/ Apr-2015 : Modification (M. Accensi) ( version 5.07 ) + !/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ Mar-2021 : Add TAUA and RHOA coupling ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Receive coupling fields from atmospheric model + ! + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ID_LCOMM Char. I MPI communicator + ! IDFLD Int. I Name of the exchange fields + ! FXN Int. I/O First exchange field + ! FYN Int. I/O Second exchange field + ! FAN Int. I/O Third exchange field + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------- + ! CPL_OASIS_RCV Subr. W3OACPMD Receive fields from atmos/ocean model + ! W3S2XY Subr. W3SERVMD Convert from storage (NSEA) to spatial grid (NX, NY) + ! ------------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------ + ! W3FLDG Subr. W3FLDSMD Manage input fields of depth, + ! current, wind and ice concentration + ! ------------------------------------------------------------------ + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_RCV, RCV_FLD, CPL_OASIS_RCV + USE W3GDATMD, ONLY: NX, NY, NSEAL, NSEA, MAPSF + USE W3ODATMD, ONLY: NAPROC, IAPROC + USE W3SERVMD, ONLY: W3S2XY + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ID_LCOMM + CHARACTER(LEN=3), INTENT(IN) :: IDFLD + REAL, INTENT(INOUT) :: FXN(:,:), FYN(:,:), FAN(:,:) + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + LOGICAL :: LL_ACTION + INTEGER :: IB_DO, IB_I, IB_J, IL_ERR + REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_RCV + REAL(kind=8), DIMENSION(NSEAL) :: TMP + REAL, DIMENSION(1:NSEA) :: SND_BUFF,RCV_BUFF + ! + !---------------------------------------------------------------------- + ! * Executable part + ! + RLA_OASIS_RCV(:,:) = 0.0 + ! + DO IB_DO = 1, IL_NB_RCV + IF (IDFLD == 'WND') THEN + ! + ! Wind speed at 10m (m.s-1) (u-component) + ! ---------------------------------------------------------------------- + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__U10') THEN + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + ENDDO ! - ! Wind speed at 10m (m.s-1) (u-component) - ! ---------------------------------------------------------------------- - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__U10') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - ENDDO - ! - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FXN) - ! - ENDIF - ENDIF + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) ! - ! Wind speed at 10m (m.s-1) (v-component) - ! ---------------------------------------------------------------------- - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__V10') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - END DO - ! - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FYN) - ! - ENDIF - ENDIF + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FXN) ! - ENDIF - IF (IDFLD == 'TAU') THEN + ENDIF + ENDIF + ! + ! Wind speed at 10m (m.s-1) (v-component) + ! ---------------------------------------------------------------------- + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__V10') THEN + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + END DO ! - ! Atmospheric momentum (Pa) (u-component) - ! ---------------------------------------------------------------------- - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_UTAU') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - ENDDO - ! - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FXN) - ! - ENDIF - ENDIF + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) ! - ! Atmospheric momentum (Pa) (v-component) - ! ---------------------------------------------------------------------- - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_VTAU') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - END DO - ! - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FYN) - ! - ENDIF - ENDIF + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FYN) ! - ENDIF - IF (IDFLD == 'RHO') THEN + ENDIF + ENDIF + ! + ENDIF + IF (IDFLD == 'TAU') THEN + ! + ! Atmospheric momentum (Pa) (u-component) + ! ---------------------------------------------------------------------- + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_UTAU') THEN + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + ENDDO ! - ! Air density (kg.m-3) - ! ---------------------------------------------------------------------- - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_RHOA') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - ENDDO - ! - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FAN) - ! - ENDIF - ENDIF - ENDIF - ENDDO -!/ ------------------------------------------------------------------- / - END SUBROUTINE RCV_FIELDS_FROM_ATMOS -!/ ------------------------------------------------------------------- / -!/ - END MODULE W3AGCMMD + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) + ! + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FXN) + ! + ENDIF + ENDIF + ! + ! Atmospheric momentum (Pa) (v-component) + ! ---------------------------------------------------------------------- + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_VTAU') THEN + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + END DO + ! + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) + ! + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FYN) + ! + ENDIF + ENDIF + ! + ENDIF + IF (IDFLD == 'RHO') THEN + ! + ! Air density (kg.m-3) + ! ---------------------------------------------------------------------- + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_RHOA') THEN + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + ENDDO + ! + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) + ! + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FAN) + ! + ENDIF + ENDIF + ENDIF + ENDDO + !/ ------------------------------------------------------------------- / + END SUBROUTINE RCV_FIELDS_FROM_ATMOS + !/ ------------------------------------------------------------------- / + !/ +END MODULE W3AGCMMD !/ !/ ------------------------------------------------------------------- / - diff --git a/model/src/w3arrymd.F90 b/model/src/w3arrymd.F90 index de3cbe5ec..600e6f014 100644 --- a/model/src/w3arrymd.F90 +++ b/model/src/w3arrymd.F90 @@ -1,2383 +1,2383 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3ARRYMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! In this module all service routines for in and output (binary -! and test) of arrays are gathered. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ICOL Int. Private Number of collums four array output -! (if not 80, 132 assumed). -! NFRMAX Int. Private Max number of frequencies in 1D -! print plots of spectra. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! INA2R Subr. Public Read 2D real array. -! INA2I Subr. Public Read 2D integer array. -! OUTA2R Subr. Public Write 2D real array. -! OUTA2I Subr. Public Write 2D integer array. -! OUTREA Subr. Public Print out 1D real array. -! OUTINT Subr. Public Print out 1D integer array. -! OUTMAT Subr. Public Print out 2D real array. -! PRTBLK Subr. Public Print a block-type table of a 2D -! real array. -! PRT1DS Subr. Public Print plot of 1D spectrum. -! PRT1DM Subr. Public Print plot of 1D spectra. -! PRT2DS Subr. Public Print plot of 2D spectrum. -! ANGSTR Subr. PRT2DS Convert direction to string. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing troughout module. -! !/T Switch on test output for INA2R/I and OUTA2R/I. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -! - INTEGER, PARAMETER, PRIVATE :: ICOL = 80 - INTEGER, PARAMETER, PRIVATE :: NFRMAX = 50 - INTEGER, PARAMETER, PRIVATE :: NFM2 = NFRMAX+1 -! - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE INA2R (ARRAY, MX, MY, LX, HX, LY, HY, & - NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ Based on INAR2D by N.Booij, DUT. -!/ -!/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Reads 2-D array of pre-described layout and format. -! -! 3. Parameter list -! ---------------------------------------------------------------- -! ARRAY R.A. O Array to be read. -! MX,MY Int. I Declared size of array. -! LX,HX Int. I Range of x-counters to be read. -! LY,HY Int. I Range of y-counters to be read. -! NDS Int. I Unit number for dataset with array. -! NDST Int. I Unit number for test output. -! NDSE Int. I Unit number for error messages. -! IDFM Int. I Format indicator. -! IDFM = 1 : Free format. -! IDFM = 2 : Fixed format RFORM. -! IDFM = 3 : Unformatted. -! RFORM C*(*) I Format, if IDFM = 2 -! IDLA Int. I Lay out indicator. -! IDLA = 1 : Read for IY=LY-HY, IX=LX-HX, -! IX line by IX line. -! IDLA = 2 : Idem, one read statement. -! IDLA = 3 : Read for IY=HY-LY, IX=LX,HX, -! IX line by IX line. -! IDLA = 4 : Idem, one read statement. -! VSC Real I Scaling factor (multiplication). -! VOF Real I Add offset. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See mudule documentation. -! -! 5. Called by : -! -! Any. -! -! 6. Error messages : -! -! See error escape locations at end of routine. -! -! 8. Structure : -! -! See comments in code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Dump of input parameters in parameter list. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ +MODULE W3ARRYMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! In this module all service routines for in and output (binary + ! and test) of arrays are gathered. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ICOL Int. Private Number of collums four array output + ! (if not 80, 132 assumed). + ! NFRMAX Int. Private Max number of frequencies in 1D + ! print plots of spectra. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! INA2R Subr. Public Read 2D real array. + ! INA2I Subr. Public Read 2D integer array. + ! OUTA2R Subr. Public Write 2D real array. + ! OUTA2I Subr. Public Write 2D integer array. + ! OUTREA Subr. Public Print out 1D real array. + ! OUTINT Subr. Public Print out 1D integer array. + ! OUTMAT Subr. Public Print out 2D real array. + ! PRTBLK Subr. Public Print a block-type table of a 2D + ! real array. + ! PRT1DS Subr. Public Print plot of 1D spectrum. + ! PRT1DM Subr. Public Print plot of 1D spectra. + ! PRT2DS Subr. Public Print plot of 2D spectrum. + ! ANGSTR Subr. PRT2DS Convert direction to string. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing troughout module. + ! !/T Switch on test output for INA2R/I and OUTA2R/I. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + ! + INTEGER, PARAMETER, PRIVATE :: ICOL = 80 + INTEGER, PARAMETER, PRIVATE :: NFRMAX = 50 + INTEGER, PARAMETER, PRIVATE :: NFM2 = NFRMAX+1 + ! +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE INA2R (ARRAY, MX, MY, LX, HX, LY, HY, & + NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ Based on INAR2D by N.Booij, DUT. + !/ + !/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Reads 2-D array of pre-described layout and format. + ! + ! 3. Parameter list + ! ---------------------------------------------------------------- + ! ARRAY R.A. O Array to be read. + ! MX,MY Int. I Declared size of array. + ! LX,HX Int. I Range of x-counters to be read. + ! LY,HY Int. I Range of y-counters to be read. + ! NDS Int. I Unit number for dataset with array. + ! NDST Int. I Unit number for test output. + ! NDSE Int. I Unit number for error messages. + ! IDFM Int. I Format indicator. + ! IDFM = 1 : Free format. + ! IDFM = 2 : Fixed format RFORM. + ! IDFM = 3 : Unformatted. + ! RFORM C*(*) I Format, if IDFM = 2 + ! IDLA Int. I Lay out indicator. + ! IDLA = 1 : Read for IY=LY-HY, IX=LX-HX, + ! IX line by IX line. + ! IDLA = 2 : Idem, one read statement. + ! IDLA = 3 : Read for IY=HY-LY, IX=LX,HX, + ! IX line by IX line. + ! IDLA = 4 : Idem, one read statement. + ! VSC Real I Scaling factor (multiplication). + ! VOF Real I Add offset. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See mudule documentation. + ! + ! 5. Called by : + ! + ! Any. + ! + ! 6. Error messages : + ! + ! See error escape locations at end of routine. + ! + ! 8. Structure : + ! + ! See comments in code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Dump of input parameters in parameter list. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3SERVMD, ONLY: EXTCDE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, & - NDSE, IDFM, IDLA - REAL, INTENT(IN) :: VSC, VOF - CHARACTER, INTENT(IN) :: RFORM*(*) - REAL, INTENT(OUT) :: ARRAY(MX,MY) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT + USE W3SERVMD, ONLY: EXTCDE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, & + NDSE, IDFM, IDLA + REAL, INTENT(IN) :: VSC, VOF + CHARACTER, INTENT(IN) :: RFORM*(*) + REAL, INTENT(OUT) :: ARRAY(MX,MY) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INA2R') + CALL STRACE (IENT, 'INA2R') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, VOF + WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF #endif -! - IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN - IIDFM = 1 - ELSE - IIDFM = IDFM - END IF - IF (IDLA.LT.1 .OR. IDLA.GT.4) THEN - IIDLA = 1 - ELSE - IIDLA = IDLA - END IF -! -! Free format read : -! - IF (IIDFM.EQ.1) THEN - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE - READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) - END IF -! -! Fixed format read : -! - ELSE IF (IIDFM.EQ.2) THEN - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE - READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) - END IF -! -! Unformat read : -! - ELSE - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE - READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) - END IF - END IF -! -! Scaling : -! - DO IX=LX, HX + ! + IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN + IIDFM = 1 + ELSE + IIDFM = IDFM + END IF + IF (IDLA.LT.1 .OR. IDLA.GT.4) THEN + IIDLA = 1 + ELSE + IIDLA = IDLA + END IF + ! + ! Free format read : + ! + IF (IIDFM.EQ.1) THEN + IF (IIDLA.EQ.1) THEN DO IY=LY, HY - ARRAY(IX,IY) = VSC * ARRAY(IX,IY) + VOF - END DO + READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) END DO -! - RETURN -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,900) - CALL EXTCDE ( ISTAT ) -! - 801 CONTINUE - WRITE (NDSE,901) ISTAT - CALL EXTCDE ( ISTAT ) -! -! Formats -! - 900 FORMAT (/' *** ERROR INA2R : '/ & - ' PREMATURE END OF FILE'/) - 901 FORMAT (/' *** ERROR INA2R : '/ & - ' ERROR IN READING FROM FILE'/ & - ' IOSTAT =',I5/) -! + ELSE IF (IIDLA.EQ.2) THEN + READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) + END DO + ELSE + READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) + END IF + ! + ! Fixed format read : + ! + ELSE IF (IIDFM.EQ.2) THEN + IF (IIDLA.EQ.1) THEN + DO IY=LY, HY + READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) + END DO + ELSE IF (IIDLA.EQ.2) THEN + READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) + END DO + ELSE + READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) + END IF + ! + ! Unformat read : + ! + ELSE + IF (IIDLA.EQ.1) THEN + DO IY=LY, HY + READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) + END DO + ELSE IF (IIDLA.EQ.2) THEN + READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) + END DO + ELSE + READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) + END IF + END IF + ! + ! Scaling : + ! + DO IX=LX, HX + DO IY=LY, HY + ARRAY(IX,IY) = VSC * ARRAY(IX,IY) + VOF + END DO + END DO + ! + RETURN + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,900) + CALL EXTCDE ( ISTAT ) + ! +801 CONTINUE + WRITE (NDSE,901) ISTAT + CALL EXTCDE ( ISTAT ) + ! + ! Formats + ! +900 FORMAT (/' *** ERROR INA2R : '/ & + ' PREMATURE END OF FILE'/) +901 FORMAT (/' *** ERROR INA2R : '/ & + ' ERROR IN READING FROM FILE'/ & + ' IOSTAT =',I5/) + ! #ifdef W3_T - 9000 FORMAT (' TEST INA2R : INPUT :'/6X,8I4,2I3,1X,A,I3,2E12.4) +9000 FORMAT (' TEST INA2R : INPUT :'/6X,8I4,2I3,1X,A,I3,2E12.4) #endif -!/ -!/ End of INA2R ----------------------------------------------------- / -!/ - END SUBROUTINE INA2R -!/ ------------------------------------------------------------------- / - SUBROUTINE INA2I (ARRAY, MX, MY, LX, HX, LY, HY, & - NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ Based on INAR2D by N.Booij, DUT. -!/ -!/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Like INA2R , integer ARRAY, VSC and VOF, see INA2R . -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ End of INA2R ----------------------------------------------------- / + !/ + END SUBROUTINE INA2R + !/ ------------------------------------------------------------------- / + SUBROUTINE INA2I (ARRAY, MX, MY, LX, HX, LY, HY, & + NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ Based on INAR2D by N.Booij, DUT. + !/ + !/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Like INA2R , integer ARRAY, VSC and VOF, see INA2R . + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3SERVMD, ONLY: EXTCDE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, & - NDSE, IDFM, IDLA, VSC, VOF - INTEGER, INTENT(OUT) :: ARRAY(MX,MY) - CHARACTER, INTENT(IN) :: RFORM*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT + USE W3SERVMD, ONLY: EXTCDE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, & + NDSE, IDFM, IDLA, VSC, VOF + INTEGER, INTENT(OUT) :: ARRAY(MX,MY) + CHARACTER, INTENT(IN) :: RFORM*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INA2I') + CALL STRACE (IENT, 'INA2I') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, VOF + WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF #endif -! - IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN - IIDFM = 1 - ELSE - IIDFM = IDFM - END IF - IF (IDLA.LT.1 .OR. IDLA.GT.4)THEN - IIDLA = 1 - ELSE - IIDLA = IDLA - END IF -! -! Free format read : -! - IF (IIDFM.EQ.1) THEN - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE - READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) - END IF -! -! Fixed format read : -! - ELSE IF (IIDFM.EQ.2) THEN - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE - READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) - END IF -! -! Unformat read : -! - ELSE - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & - (ARRAY(IX,IY),IX=LX,HX) - END DO - ELSE - READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & - ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) - END IF - END IF -! -! Scaling : -! - DO IX=LX, HX + ! + IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN + IIDFM = 1 + ELSE + IIDFM = IDFM + END IF + IF (IDLA.LT.1 .OR. IDLA.GT.4)THEN + IIDLA = 1 + ELSE + IIDLA = IDLA + END IF + ! + ! Free format read : + ! + IF (IIDFM.EQ.1) THEN + IF (IIDLA.EQ.1) THEN DO IY=LY, HY - ARRAY(IX,IY) = VSC * ARRAY(IX,IY) + VOF - END DO + READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) END DO -! - RETURN -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,900) - CALL EXTCDE ( ISTAT ) -! - 801 CONTINUE - WRITE (NDSE,901) ISTAT - CALL EXTCDE ( ISTAT ) -! -! Formats -! - 900 FORMAT (/' *** ERROR INA2I : '/ & - ' PREMATURE END OF FILE'/) - 901 FORMAT (/' *** ERROR INA2I : '/ & - ' ERROR IN READING FROM FILE'/ & - ' IOSTAT =',I5/) -! + ELSE IF (IIDLA.EQ.2) THEN + READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) + END DO + ELSE + READ (NDS,*,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) + END IF + ! + ! Fixed format read : + ! + ELSE IF (IIDFM.EQ.2) THEN + IF (IIDLA.EQ.1) THEN + DO IY=LY, HY + READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) + END DO + ELSE IF (IIDLA.EQ.2) THEN + READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) + END DO + ELSE + READ (NDS,RFORM,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) + END IF + ! + ! Unformat read : + ! + ELSE + IF (IIDLA.EQ.1) THEN + DO IY=LY, HY + READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) + END DO + ELSE IF (IIDLA.EQ.2) THEN + READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & + (ARRAY(IX,IY),IX=LX,HX) + END DO + ELSE + READ (NDS,END=800,ERR=801,IOSTAT=ISTAT) & + ((ARRAY(IX,IY),IX=LX,HX),IY=HY,LY,-1) + END IF + END IF + ! + ! Scaling : + ! + DO IX=LX, HX + DO IY=LY, HY + ARRAY(IX,IY) = VSC * ARRAY(IX,IY) + VOF + END DO + END DO + ! + RETURN + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,900) + CALL EXTCDE ( ISTAT ) + ! +801 CONTINUE + WRITE (NDSE,901) ISTAT + CALL EXTCDE ( ISTAT ) + ! + ! Formats + ! +900 FORMAT (/' *** ERROR INA2I : '/ & + ' PREMATURE END OF FILE'/) +901 FORMAT (/' *** ERROR INA2I : '/ & + ' ERROR IN READING FROM FILE'/ & + ' IOSTAT =',I5/) + ! #ifdef W3_T - 9000 FORMAT (' TEST INA2I : INPUT :'/6X,8I4,2I3,1X,A,I3,2I5) +9000 FORMAT (' TEST INA2I : INPUT :'/6X,8I4,2I3,1X,A,I3,2I5) #endif -!/ -!/ End of INA2I ----------------------------------------------------- / -!/ - END SUBROUTINE INA2I -!/ ------------------------------------------------------------------- / - SUBROUTINE OUTA2R (ARRAY, MX, MY, LX, HX, LY, HY, & - NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 21-Feb-2008 ; Bug fix IDFM=1, IDLA=2 writing ( version 3.13 ) -!/ 30-Oct-2009 ; Fix non-integer loop bound. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Writes 2-D array of pre-described layout and format. "Inverse" -! version of INA2R . For documentation see INA2R . -! -! N.B. - ARRAY_OUT <= ( ARRAY_IN - VOF ) / VSC -! - No error trapping on write. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ End of INA2I ----------------------------------------------------- / + !/ + END SUBROUTINE INA2I + !/ ------------------------------------------------------------------- / + SUBROUTINE OUTA2R (ARRAY, MX, MY, LX, HX, LY, HY, & + NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ + !/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 21-Feb-2008 ; Bug fix IDFM=1, IDLA=2 writing ( version 3.13 ) + !/ 30-Oct-2009 ; Fix non-integer loop bound. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Writes 2-D array of pre-described layout and format. "Inverse" + ! version of INA2R . For documentation see INA2R . + ! + ! N.B. - ARRAY_OUT <= ( ARRAY_IN - VOF ) / VSC + ! - No error trapping on write. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3SERVMD, ONLY: EXTCDE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, & - NDSE, IDFM, IDLA - REAL, INTENT(IN) :: VSC, VOF, ARRAY(MX,MY) - CHARACTER, INTENT(IN) :: RFORM*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT + USE W3SERVMD, ONLY: EXTCDE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, & + NDSE, IDFM, IDLA + REAL, INTENT(IN) :: VSC, VOF, ARRAY(MX,MY) + CHARACTER, INTENT(IN) :: RFORM*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'OUTA2R') + CALL STRACE (IENT, 'OUTA2R') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, VOF + WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF #endif -! - IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN - IIDFM = 1 - ELSE - IIDFM = IDFM - END IF - IF (IDLA.LT.1 .OR. IDLA.GT.4) THEN - IIDLA = 1 - ELSE - IIDLA = IDLA - END IF -! -! Free format write : -! - IF (IIDFM.EQ.1) THEN - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,INT(HX/VSC)),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE - WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) - END IF -! -! Fixed format write : -! - ELSE IF (IIDFM.EQ.2) THEN - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE - WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) - END IF -! -! Unformat write : -! - ELSE - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - WRITE (NDS,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - WRITE (NDS,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - WRITE (NDS,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE - WRITE (NDS,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) - END IF - END IF -! - RETURN -! -! Escape locations write errors : -! - 800 CONTINUE - WRITE (NDSE,900) ISTAT - CALL EXTCDE ( ISTAT ) -! -! Formats -! - 900 FORMAT (/' *** ERROR OUTA2R : '/ & - ' ERROR IN WRITING TO FILE'/ & - ' IOSTAT =',I5/) -! + ! + IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN + IIDFM = 1 + ELSE + IIDFM = IDFM + END IF + IF (IDLA.LT.1 .OR. IDLA.GT.4) THEN + IIDLA = 1 + ELSE + IIDLA = IDLA + END IF + ! + ! Free format write : + ! + IF (IIDFM.EQ.1) THEN + IF (IIDLA.EQ.1) THEN + DO IY=LY, HY + WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE IF (IIDLA.EQ.2) THEN + WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,INT(HX/VSC)),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE + WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) + END IF + ! + ! Fixed format write : + ! + ELSE IF (IIDFM.EQ.2) THEN + IF (IIDLA.EQ.1) THEN + DO IY=LY, HY + WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE IF (IIDLA.EQ.2) THEN + WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE + WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) + END IF + ! + ! Unformat write : + ! + ELSE + IF (IIDLA.EQ.1) THEN + DO IY=LY, HY + WRITE (NDS,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE IF (IIDLA.EQ.2) THEN + WRITE (NDS,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + WRITE (NDS,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE + WRITE (NDS,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) + END IF + END IF + ! + RETURN + ! + ! Escape locations write errors : + ! +800 CONTINUE + WRITE (NDSE,900) ISTAT + CALL EXTCDE ( ISTAT ) + ! + ! Formats + ! +900 FORMAT (/' *** ERROR OUTA2R : '/ & + ' ERROR IN WRITING TO FILE'/ & + ' IOSTAT =',I5/) + ! #ifdef W3_T - 9000 FORMAT (' TEST OUTA2R : INPUT :'/6X,8I4,2I3,1X,A,I3,2E12.4) +9000 FORMAT (' TEST OUTA2R : INPUT :'/6X,8I4,2I3,1X,A,I3,2E12.4) #endif -!/ -!/ End of OUTA2R ----------------------------------------------------- / -!/ - END SUBROUTINE OUTA2R -!/ ------------------------------------------------------------------- / - SUBROUTINE OUTA2I (ARRAY, MX, MY, LX, HX, LY, HY, & - NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Like OUTA2R, integer ARRAY, VSC and VOF, see OUTA2R. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ End of OUTA2R ----------------------------------------------------- / + !/ + END SUBROUTINE OUTA2R + !/ ------------------------------------------------------------------- / + SUBROUTINE OUTA2I (ARRAY, MX, MY, LX, HX, LY, HY, & + NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ + !/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Like OUTA2R, integer ARRAY, VSC and VOF, see OUTA2R. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3SERVMD, ONLY: EXTCDE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, & - NDSE, IDFM, IDLA, ARRAY(MX,MY) - INTEGER, INTENT(IN) :: VSC, VOF - CHARACTER, INTENT(IN) :: RFORM*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT + USE W3SERVMD, ONLY: EXTCDE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, & + NDSE, IDFM, IDLA, ARRAY(MX,MY) + INTEGER, INTENT(IN) :: VSC, VOF + CHARACTER, INTENT(IN) :: RFORM*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'OUTA2I') + CALL STRACE (IENT, 'OUTA2I') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, VOF + WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF #endif -! - IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN - IIDFM = 1 - ELSE - IIDFM = IDFM - END IF - IF (IDLA.LT.1 .OR. IDLA.GT.4) THEN - IIDLA = 1 - ELSE - IIDLA = IDLA - END IF -! -! Free format write : -! - IF (IIDFM.EQ.1) THEN - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE - WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) - END IF -! -! Fixed format write : -! - ELSE IF (IIDFM.EQ.2) THEN - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE - WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) - END IF -! -! Unformat write : -! - ELSE - IF (IIDLA.EQ.1) THEN - DO IY=LY, HY - WRITE (NDS,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE IF (IIDLA.EQ.2) THEN - WRITE (NDS,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=LY,HY) - ELSE IF (IIDLA.EQ.3) THEN - DO IY=HY, LY, -1 - WRITE (NDS,ERR=800,IOSTAT=ISTAT) & - ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) - END DO - ELSE - WRITE (NDS,ERR=800,IOSTAT=ISTAT) & - (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) - END IF - END IF -! - RETURN -! -! Escape locations write errors : -! - 800 CONTINUE - WRITE (NDSE,900) ISTAT - CALL EXTCDE ( ISTAT ) -! -! Formats -! - 900 FORMAT (/' *** ERROR OUTA2I : '/ & - ' ERROR IN WRITING TO FILE'/ & - ' IOSTAT =',I5/) -! + ! + IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN + IIDFM = 1 + ELSE + IIDFM = IDFM + END IF + IF (IDLA.LT.1 .OR. IDLA.GT.4) THEN + IIDLA = 1 + ELSE + IIDLA = IDLA + END IF + ! + ! Free format write : + ! + IF (IIDFM.EQ.1) THEN + IF (IIDLA.EQ.1) THEN + DO IY=LY, HY + WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE IF (IIDLA.EQ.2) THEN + WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE + WRITE (NDS,*,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) + END IF + ! + ! Fixed format write : + ! + ELSE IF (IIDFM.EQ.2) THEN + IF (IIDLA.EQ.1) THEN + DO IY=LY, HY + WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE IF (IIDLA.EQ.2) THEN + WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE + WRITE (NDS,RFORM,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) + END IF + ! + ! Unformat write : + ! + ELSE + IF (IIDLA.EQ.1) THEN + DO IY=LY, HY + WRITE (NDS,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE IF (IIDLA.EQ.2) THEN + WRITE (NDS,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=LY,HY) + ELSE IF (IIDLA.EQ.3) THEN + DO IY=HY, LY, -1 + WRITE (NDS,ERR=800,IOSTAT=ISTAT) & + ((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX) + END DO + ELSE + WRITE (NDS,ERR=800,IOSTAT=ISTAT) & + (((ARRAY(IX,IY)-VOF)/VSC,IX=LX,HX),IY=HY,LY,-1) + END IF + END IF + ! + RETURN + ! + ! Escape locations write errors : + ! +800 CONTINUE + WRITE (NDSE,900) ISTAT + CALL EXTCDE ( ISTAT ) + ! + ! Formats + ! +900 FORMAT (/' *** ERROR OUTA2I : '/ & + ' ERROR IN WRITING TO FILE'/ & + ' IOSTAT =',I5/) + ! #ifdef W3_T - 9000 FORMAT (' TEST OUTA2I : INPUT :'/6X,8I4,2I3,1X,A,I3,2I5) +9000 FORMAT (' TEST OUTA2I : INPUT :'/6X,8I4,2I3,1X,A,I3,2I5) #endif -!/ -!/ End of OUTA2I ----------------------------------------------------- / -!/ - END SUBROUTINE OUTA2I -!/ ------------------------------------------------------------------- / - SUBROUTINE OUTREA (NDS,ARRAY,DIM,ANAME) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Nov-1999 | -!/ +-----------------------------------+ -!/ Original versions G. Ph. van Vledder -!/ P. H. Willems -!/ -!/ 29-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Print contents of a 1-D real array, see OUTINT. -! -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ End of OUTA2I ----------------------------------------------------- / + !/ + END SUBROUTINE OUTA2I + !/ ------------------------------------------------------------------- / + SUBROUTINE OUTREA (NDS,ARRAY,DIM,ANAME) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Nov-1999 | + !/ +-----------------------------------+ + !/ Original versions G. Ph. van Vledder + !/ P. H. Willems + !/ + !/ 29-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Print contents of a 1-D real array, see OUTINT. + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, DIM - REAL, INTENT(IN) :: ARRAY(DIM) - CHARACTER, INTENT(IN) :: ANAME*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, K + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, DIM + REAL, INTENT(IN) :: ARRAY(DIM) + CHARACTER, INTENT(IN) :: ANAME*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, K #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'OUTREA') + CALL STRACE (IENT, 'OUTREA') #endif -! - WRITE (NDS,8000) ANAME -! - IF (ICOL.EQ.80) THEN -! - WRITE (NDS,8005) (I, I=1, 5) - WRITE (NDS,8010) - DO K=0, DIM, 5 - IF (DIM-K.GE.5) THEN - WRITE (NDS,'(1X,I4,A,5E12.4,A)') & - K,' |',(ARRAY(I),I= K+1, K+5),' |' - ELSE - WRITE (NDS,'(1X,T71,''|'',T2,I4,A,5E12.4)') & - K,' |',(ARRAY(I),I= K+1, DIM) - END IF - END DO - WRITE (NDS,8010) -! + ! + WRITE (NDS,8000) ANAME + ! + IF (ICOL.EQ.80) THEN + ! + WRITE (NDS,8005) (I, I=1, 5) + WRITE (NDS,8010) + DO K=0, DIM, 5 + IF (DIM-K.GE.5) THEN + WRITE (NDS,'(1X,I4,A,5E12.4,A)') & + K,' |',(ARRAY(I),I= K+1, K+5),' |' ELSE -! - WRITE (NDS,9005) (I, I=1, 10) - WRITE (NDS,9010) - DO K=0, DIM, 10 - IF (DIM-K.GE.10) THEN - WRITE (NDS,'(1X,I4,A,10E12.4,A)') & - K,' |',(ARRAY(I),I= K+1, K+10),' |' - ELSE - WRITE (NDS,'(1X,T131,''|'',T2,I4,A,10E12.4)') & - K,' |',(ARRAY(I),I= K+1, DIM) - END IF - END DO - WRITE (NDS,9010) - END IF -! - RETURN -! - 8000 FORMAT (/,1X,'A R R A Y D U M P (REAL) / NAME: ',A) - 8005 FORMAT (8X,5I12) - 8010 FORMAT (7X,'+',62('-'),'+') - 9005 FORMAT (8X,10I12) - 9010 FORMAT (7X,'+',122('-'),'+') -!/ -!/ End of OUTREA ----------------------------------------------------- / -!/ - END SUBROUTINE OUTREA -!/ ------------------------------------------------------------------- / - SUBROUTINE OUTINT ( NDS, IARRAY, DIM, ANAME ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Mar-1993 | -!/ +-----------------------------------+ -!/ Original versions G. Ph. van Vledder -!/ P. H. Willems -!/ -!/ 29-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Print contents of a 1-D integer array. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Output unit number. -! IARRAY I.A. I Array to be printed. -! DIM Int. I Number of elements to be printed. -! ANAME C*(*) I Name of array. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See mudule documentation. -! -! 5. Called by : -! -! Anny routine or program. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + WRITE (NDS,'(1X,T71,''|'',T2,I4,A,5E12.4)') & + K,' |',(ARRAY(I),I= K+1, DIM) + END IF + END DO + WRITE (NDS,8010) + ! + ELSE + ! + WRITE (NDS,9005) (I, I=1, 10) + WRITE (NDS,9010) + DO K=0, DIM, 10 + IF (DIM-K.GE.10) THEN + WRITE (NDS,'(1X,I4,A,10E12.4,A)') & + K,' |',(ARRAY(I),I= K+1, K+10),' |' + ELSE + WRITE (NDS,'(1X,T131,''|'',T2,I4,A,10E12.4)') & + K,' |',(ARRAY(I),I= K+1, DIM) + END IF + END DO + WRITE (NDS,9010) + END IF + ! + RETURN + ! +8000 FORMAT (/,1X,'A R R A Y D U M P (REAL) / NAME: ',A) +8005 FORMAT (8X,5I12) +8010 FORMAT (7X,'+',62('-'),'+') +9005 FORMAT (8X,10I12) +9010 FORMAT (7X,'+',122('-'),'+') + !/ + !/ End of OUTREA ----------------------------------------------------- / + !/ + END SUBROUTINE OUTREA + !/ ------------------------------------------------------------------- / + SUBROUTINE OUTINT ( NDS, IARRAY, DIM, ANAME ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Mar-1993 | + !/ +-----------------------------------+ + !/ Original versions G. Ph. van Vledder + !/ P. H. Willems + !/ + !/ 29-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Print contents of a 1-D integer array. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Output unit number. + ! IARRAY I.A. I Array to be printed. + ! DIM Int. I Number of elements to be printed. + ! ANAME C*(*) I Name of array. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See mudule documentation. + ! + ! 5. Called by : + ! + ! Anny routine or program. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, DIM, IARRAY(DIM) - CHARACTER, INTENT(IN) :: ANAME*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, K + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, DIM, IARRAY(DIM) + CHARACTER, INTENT(IN) :: ANAME*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, K #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'OUTINT') + CALL STRACE (IENT, 'OUTINT') #endif -! - WRITE (NDS,8000) ANAME -! -! ------- 80 COLUMNS ----- -! - IF (ICOL.EQ.80) THEN - WRITE (NDS,8005) (I, I=1, 5) - WRITE (NDS,8010) - DO K=0, DIM, 5 - IF (DIM-K.GE.5) THEN - WRITE (NDS,'(1X,I4,A,5I12,A)') & - K,' |',(IARRAY(I),I= K+1, K+5),' |' - ELSE - WRITE (NDS,'(1X,T71,''|'',T2,I4,A,5I12)') & - K,' |',(IARRAY(I),I= K+1, DIM) - END IF - END DO - WRITE (NDS,8010) - ELSE -! -! ---- 132 COLUMNS ---- -! - WRITE (NDS,9005) (I, I=1, 10) - WRITE (NDS,9010) - DO K=0, DIM, 10 - IF (DIM-K.GE.10) THEN - WRITE (NDS,'(1X,I4,A,10I12,A)') & - K,' |',(IARRAY(I),I= K+1, K+10),' |' - ELSE - WRITE (NDS,'(1X,T131,''|'',T2,I4,A,10I12)') & - K,' |',(IARRAY(I),I= K+1, DIM) - END IF - END DO - WRITE (NDS,9010) - END IF -! - RETURN -! - 8000 FORMAT (/,1X,'A R R A Y D U M P (INTEGER) / NAME: ',A) - 8005 FORMAT (8X,5I12) - 8010 FORMAT (7X,'+',62('-'),'+') - 9005 FORMAT (8X,10I12) - 9010 FORMAT (7X,'+',122('-'),'+') -!/ -!/ End of OUTINT ----------------------------------------------------- / -!/ - END SUBROUTINE OUTINT -!/ ------------------------------------------------------------------- / - SUBROUTINE OUTMAT (NDS,A,MX,NX,NY,MNAME) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Nov-1999 | -!/ +-----------------------------------+ -!/ Original versions G. Ph. van Vledder -!/ -!/ 29-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Print contents of a 2-D real array. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Output unit number. -! A R.A. I Matrix to be printed. -! MX Int. I Dimension of first index. -! NX Int. I Number of points for first index. -! NY Int. I Number of points for scond index. -! MNAME C*(*) I Name of matrix. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See mudule documentation. -! -! 5. Called by : -! -! Anny routine or program. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + ! + WRITE (NDS,8000) ANAME + ! + ! ------- 80 COLUMNS ----- + ! + IF (ICOL.EQ.80) THEN + WRITE (NDS,8005) (I, I=1, 5) + WRITE (NDS,8010) + DO K=0, DIM, 5 + IF (DIM-K.GE.5) THEN + WRITE (NDS,'(1X,I4,A,5I12,A)') & + K,' |',(IARRAY(I),I= K+1, K+5),' |' + ELSE + WRITE (NDS,'(1X,T71,''|'',T2,I4,A,5I12)') & + K,' |',(IARRAY(I),I= K+1, DIM) + END IF + END DO + WRITE (NDS,8010) + ELSE + ! + ! ---- 132 COLUMNS ---- + ! + WRITE (NDS,9005) (I, I=1, 10) + WRITE (NDS,9010) + DO K=0, DIM, 10 + IF (DIM-K.GE.10) THEN + WRITE (NDS,'(1X,I4,A,10I12,A)') & + K,' |',(IARRAY(I),I= K+1, K+10),' |' + ELSE + WRITE (NDS,'(1X,T131,''|'',T2,I4,A,10I12)') & + K,' |',(IARRAY(I),I= K+1, DIM) + END IF + END DO + WRITE (NDS,9010) + END IF + ! + RETURN + ! +8000 FORMAT (/,1X,'A R R A Y D U M P (INTEGER) / NAME: ',A) +8005 FORMAT (8X,5I12) +8010 FORMAT (7X,'+',62('-'),'+') +9005 FORMAT (8X,10I12) +9010 FORMAT (7X,'+',122('-'),'+') + !/ + !/ End of OUTINT ----------------------------------------------------- / + !/ + END SUBROUTINE OUTINT + !/ ------------------------------------------------------------------- / + SUBROUTINE OUTMAT (NDS,A,MX,NX,NY,MNAME) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Nov-1999 | + !/ +-----------------------------------+ + !/ Original versions G. Ph. van Vledder + !/ + !/ 29-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Print contents of a 2-D real array. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Output unit number. + ! A R.A. I Matrix to be printed. + ! MX Int. I Dimension of first index. + ! NX Int. I Number of points for first index. + ! NY Int. I Number of points for scond index. + ! MNAME C*(*) I Name of matrix. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See mudule documentation. + ! + ! 5. Called by : + ! + ! Anny routine or program. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, MX, NX, NY - REAL, INTENT(IN) :: A(MX,NY) - CHARACTER, INTENT(IN) :: MNAME*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: LBLOK, NBLOK, IBLOK, IX, IX1, IX2, IY + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, MX, NX, NY + REAL, INTENT(IN) :: A(MX,NY) + CHARACTER, INTENT(IN) :: MNAME*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: LBLOK, NBLOK, IBLOK, IX, IX1, IX2, IY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'OUTMAT') + CALL STRACE (IENT, 'OUTMAT') #endif -! - WRITE(NDS,8000) MNAME -! -! ------ 80 COLUMNS ----- -! - IF(ICOL.EQ.80) THEN - LBLOK = 6 - NBLOK = (NX-1)/LBLOK + 1 - DO IBLOK = 1,NBLOK - IX1 = (IBLOK-1)*LBLOK + 1 - IX2 = IX1 + LBLOK - 1 - IF(IX2.GT.NX) IX2 = NX - WRITE(NDS,8001) (IX,IX = IX1,IX2) - WRITE(NDS,8002) - DO IY = 1,NY - WRITE(NDS,8003) IY,(A(IX,IY),IX = IX1,IX2) - END DO - WRITE(NDS,8002) - END DO - ELSE -! -! ---- 132 COLUMNS ---- -! - LBLOK = 12 - NBLOK = (NX-1)/LBLOK + 1 - DO IBLOK = 1,NBLOK - IX1 = (IBLOK-1)*LBLOK + 1 - IX2 = IX1 + LBLOK - 1 - IF(IX2.GT.NX) IX2 = NX - WRITE(NDS,9001) (IX,IX = IX1,IX2) - WRITE(NDS,9002) - DO IY = 1,NY - WRITE(NDS,9003) IY,(A(IX,IY),IX = IX1,IX2) - END DO - WRITE(NDS,9002) - END DO - END IF -! - RETURN -! -! Formats -! - 8000 FORMAT(/,1X,' M A T R I X D U M P (REAL) / NAME: ',A) - 8001 FORMAT(9X,6I10) - 8002 FORMAT(1X,6X,'+',62('-'),'+') - 8003 FORMAT(1X,T71,'|',T2,I5,' | ',12E10.3) - 9001 FORMAT(9X,12I10) - 9002 FORMAT(1X,6X,'+',122('-'),'+') - 9003 FORMAT(1X,T131,'|',T2,I5,' | ',12E10.3) -!/ -!/ End of OUTMAT ----------------------------------------------------- / -!/ - END SUBROUTINE OUTMAT -!/ ------------------------------------------------------------------- / - SUBROUTINE PRTBLK (NDS, NX, NY, MX, F, MAP, MAP0, FSC, & - IX1, IX2, IX3, IY1, IY2, IY3, PRVAR, PRUNIT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 04-Jun-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Print a block-type table of a two-dimensional field using a -! land-sea array. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I File unit number. -! NX, NY Int. I X and Y range of arrays. -! MY Int. I Actual X size of arrays. -! F R.A. I Array to pr presented. -! MAP I.A. I Map array for land points. -! MAP0 Int. I Map value for land points in MAP. -! FSC Real I Scaling factor. -! IX1-3 Int. I Firts, last, increment grid points in X -! direction. -! IY1-3 Int. I Id. Y direction. -! PRVAR C*(*) I Name of variable. -! PRUNIT C*(*) I Units of spectrum. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See mudule documentation. -! -! 5. Called by : -! -! Any program. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! ------------------------------------------------ -! Check if automatic scaling -! If automatic scaling : get extermata -! Print heading -! Print table -! Print ending -! ------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + ! + WRITE(NDS,8000) MNAME + ! + ! ------ 80 COLUMNS ----- + ! + IF(ICOL.EQ.80) THEN + LBLOK = 6 + NBLOK = (NX-1)/LBLOK + 1 + DO IBLOK = 1,NBLOK + IX1 = (IBLOK-1)*LBLOK + 1 + IX2 = IX1 + LBLOK - 1 + IF(IX2.GT.NX) IX2 = NX + WRITE(NDS,8001) (IX,IX = IX1,IX2) + WRITE(NDS,8002) + DO IY = 1,NY + WRITE(NDS,8003) IY,(A(IX,IY),IX = IX1,IX2) + END DO + WRITE(NDS,8002) + END DO + ELSE + ! + ! ---- 132 COLUMNS ---- + ! + LBLOK = 12 + NBLOK = (NX-1)/LBLOK + 1 + DO IBLOK = 1,NBLOK + IX1 = (IBLOK-1)*LBLOK + 1 + IX2 = IX1 + LBLOK - 1 + IF(IX2.GT.NX) IX2 = NX + WRITE(NDS,9001) (IX,IX = IX1,IX2) + WRITE(NDS,9002) + DO IY = 1,NY + WRITE(NDS,9003) IY,(A(IX,IY),IX = IX1,IX2) + END DO + WRITE(NDS,9002) + END DO + END IF + ! + RETURN + ! + ! Formats + ! +8000 FORMAT(/,1X,' M A T R I X D U M P (REAL) / NAME: ',A) +8001 FORMAT(9X,6I10) +8002 FORMAT(1X,6X,'+',62('-'),'+') +8003 FORMAT(1X,T71,'|',T2,I5,' | ',12E10.3) +9001 FORMAT(9X,12I10) +9002 FORMAT(1X,6X,'+',122('-'),'+') +9003 FORMAT(1X,T131,'|',T2,I5,' | ',12E10.3) + !/ + !/ End of OUTMAT ----------------------------------------------------- / + !/ + END SUBROUTINE OUTMAT + !/ ------------------------------------------------------------------- / + SUBROUTINE PRTBLK (NDS, NX, NY, MX, F, MAP, MAP0, FSC, & + IX1, IX2, IX3, IY1, IY2, IY3, PRVAR, PRUNIT) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 04-Jun-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Print a block-type table of a two-dimensional field using a + ! land-sea array. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I File unit number. + ! NX, NY Int. I X and Y range of arrays. + ! MY Int. I Actual X size of arrays. + ! F R.A. I Array to pr presented. + ! MAP I.A. I Map array for land points. + ! MAP0 Int. I Map value for land points in MAP. + ! FSC Real I Scaling factor. + ! IX1-3 Int. I Firts, last, increment grid points in X + ! direction. + ! IY1-3 Int. I Id. Y direction. + ! PRVAR C*(*) I Name of variable. + ! PRUNIT C*(*) I Units of spectrum. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See mudule documentation. + ! + ! 5. Called by : + ! + ! Any program. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! ------------------------------------------------ + ! Check if automatic scaling + ! If automatic scaling : get extermata + ! Print heading + ! Print table + ! Print ending + ! ------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NX, NY, MX, MAP(MX,NY), MAP0, & - IX1, IX2, IX3, IY1, IY2, IY3 - REAL, INTENT(IN) :: F(MX,NY), FSC - CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IX, IY, JJ, JM, K1, LX, I + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NX, NY, MX, MAP(MX,NY), MAP0, & + IX1, IX2, IX3, IY1, IY2, IY3 + REAL, INTENT(IN) :: F(MX,NY), FSC + CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IX, IY, JJ, JM, K1, LX, I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: FMAX, RR - LOGICAL :: FLSCLE - CHARACTER :: PNUM*5, STRA*5, PNUM2*2, STRA3*3 - DIMENSION :: PNUM(25), PNUM2(61) -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: FMAX, RR + LOGICAL :: FLSCLE + CHARACTER :: PNUM*5, STRA*5, PNUM2*2, STRA3*3 + DIMENSION :: PNUM(25), PNUM2(61) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'PRTBLK') + CALL STRACE (IENT, 'PRTBLK') #endif -! -! Check scaling -! - FLSCLE = (FSC.LE.0.) -! -! Extremata -! - IF (FLSCLE) THEN - FMAX = 1.E-15 - DO IX=1, NX - DO IY=1, NY - IF ( MAP(IX,IY) .NE. MAP0 ) & - FMAX = MAX ( FMAX , ABS(F(IX,IY)) ) - END DO - END DO - END IF -! -! Normalized print plot ----------------------------------------------- -! - IF (FLSCLE) THEN -! -! Heading -! - WRITE (NDS,901) PRVAR, FMAX, PRUNIT -! - STRA = ' ' - JJ = 0 - DO IX = IX1, IX2, IX3 - JJ = JJ + 1 - END DO - LX = JJ - WRITE (NDS,911) - WRITE (NDS,912) (IX,IX=IX1,IX2,2*IX3) - PNUM2(1) = '--' - WRITE (NDS,910) STRA, ' +', (PNUM2(1), I=1, LX), '-+' -! -! Write table -! - JM = 0 - DO IY = IY2, IY1, IY3*(-1) -! - JJ = 0 - DO IX = IX1, IX2, IX3 - JJ = JJ + 1 - IF (MAP(IX,IY).EQ.MAP0) THEN - PNUM2(JJ) = ' ' - ELSE - RR = 10.*F(IX,IY)/FMAX - WRITE (STRA, FMT='(I2,3X)') INT(RR*1.000001) - PNUM2(JJ) = STRA(1:2) - IF (PNUM2(JJ).EQ.'10' .OR. PNUM2(JJ).EQ.'**' .OR. & - F(IX,IY).EQ.FMAX) THEN - IF ( RR .LT. 0. ) THEN - PNUM2(JJ) = '-*' - ELSE - PNUM2(JJ) = ' *' - END IF - END IF - END IF - END DO -! - IF (JM.EQ.0) THEN - WRITE (STRA, FMT='(I5)') IY - JM = 2 + ! + ! Check scaling + ! + FLSCLE = (FSC.LE.0.) + ! + ! Extremata + ! + IF (FLSCLE) THEN + FMAX = 1.E-15 + DO IX=1, NX + DO IY=1, NY + IF ( MAP(IX,IY) .NE. MAP0 ) & + FMAX = MAX ( FMAX , ABS(F(IX,IY)) ) + END DO + END DO + END IF + ! + ! Normalized print plot ----------------------------------------------- + ! + IF (FLSCLE) THEN + ! + ! Heading + ! + WRITE (NDS,901) PRVAR, FMAX, PRUNIT + ! + STRA = ' ' + JJ = 0 + DO IX = IX1, IX2, IX3 + JJ = JJ + 1 + END DO + LX = JJ + WRITE (NDS,911) + WRITE (NDS,912) (IX,IX=IX1,IX2,2*IX3) + PNUM2(1) = '--' + WRITE (NDS,910) STRA, ' +', (PNUM2(1), I=1, LX), '-+' + ! + ! Write table + ! + JM = 0 + DO IY = IY2, IY1, IY3*(-1) + ! + JJ = 0 + DO IX = IX1, IX2, IX3 + JJ = JJ + 1 + IF (MAP(IX,IY).EQ.MAP0) THEN + PNUM2(JJ) = ' ' + ELSE + RR = 10.*F(IX,IY)/FMAX + WRITE (STRA, FMT='(I2,3X)') INT(RR*1.000001) + PNUM2(JJ) = STRA(1:2) + IF (PNUM2(JJ).EQ.'10' .OR. PNUM2(JJ).EQ.'**' .OR. & + F(IX,IY).EQ.FMAX) THEN + IF ( RR .LT. 0. ) THEN + PNUM2(JJ) = '-*' ELSE - STRA = ' ' - JM = JM-1 + PNUM2(JJ) = ' *' END IF -! - LX = JJ - WRITE (NDS,910) STRA, ' |', (PNUM2(I), I=1, LX), ' |' - END DO -! - STRA = ' ' - PNUM2(1) = '--' - WRITE (NDS,910) STRA, ' +', (PNUM2(1), I=1, LX), '-+' - WRITE (NDS,912) (IX,IX=IX1,IX2,2*IX3) - WRITE (NDS,911) -! -! Non-normalized print plot ------------------------------------------- -! + END IF + END IF + END DO + ! + IF (JM.EQ.0) THEN + WRITE (STRA, FMT='(I5)') IY + JM = 2 ELSE -! -! Heading -! - WRITE (NDS,900) PRVAR, FSC, PRUNIT -! - JJ = 0 - PNUM(1) = ' ' - DO IX = IX1, IX2, IX3 - JJ = JJ + 1 - END DO - LX = JJ - WRITE (NDS,921) - WRITE (NDS,922) (IX,IX=IX1,IX2,IX3) - STRA3 = ' ' - PNUM(1) = '-----' - WRITE (NDS,920) STRA3, ' +', (PNUM(1), I=1, LX), '-+ ' -! -! Write table -! - JM = 0 - DO IY = IY2, IY1, IY3*(-1) - IF (JM.EQ.0) THEN - WRITE (STRA3, FMT='(I3)') IY - JM = 2 - ELSE - STRA3 = ' ' - JM = JM-1 - END IF -! - JJ = 0 - DO IX = IX1, IX2, IX3 - JJ = JJ + 1 - IF (MAP(IX,IY).EQ.MAP0) THEN - PNUM(JJ) = ' ' - ELSE - RR = F(IX,IY) - K1 = NINT (RR / FSC) - WRITE (STRA, FMT='(I5)') K1 - PNUM(JJ) = STRA - END IF - END DO -! - LX = JJ - WRITE (NDS,920) STRA3, ' |', (PNUM(I), I=1, LX), ' | ' - END DO -! - STRA3 = ' ' - PNUM(1) = '-----' - WRITE (NDS,920) STRA3, ' +', (PNUM(1), I=1, LX), '-+ ' - WRITE (NDS,922) (IX,IX=IX1,IX2,IX3) - WRITE (NDS,921) -! + STRA = ' ' + JM = JM-1 END IF -! - RETURN -! -! Formats -! - 900 FORMAT (/, ' Variable: ',A,' Units: ',E10.3,1X,A) - 901 FORMAT (/, ' Variable: ',A,' Max.: ',E10.3,1X,A) -! - 910 FORMAT (1X,A5,63A2) - 911 FORMAT (' ') - 912 FORMAT (6X,32I8) -! - 920 FORMAT (1X,A3,A2,25A5) - 921 FORMAT (' ') - 922 FORMAT (6X,25I5) -!/ -!/ End of PRTBLK ----------------------------------------------------- / -!/ - END SUBROUTINE PRTBLK -!/ ------------------------------------------------------------------- / - SUBROUTINE PRT1DS (NDS, NFR, E, FR, UFR, NLINES, FTOPI, & - PRVAR, PRUNIT, PNTNME) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 10-Mar-1992 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Produces a print plot of a 1-D spectrum. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I File unit number. -! NFR Int. I Number of frequencies. -! E R.A. I Spectral densities. -! FR R.A. I Frequencies. -! UFR C*(*) I If 'HZ', frequencies in Hz, otherwise in -! rad/s (N.B., does not re-scale spectrum). -! NLINES Int. I Hight of plot in lines. -! FTOPI Real I Highest value of density in plot, -! if FTOPI.LE.0., automatic scaling. -! PRVAR C*(*) I Name of variable. -! PRUNIT C*(*) I Units of spectrum. -! PNTNME C*(*) I Name of location. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See mudule documentation. -! -! 5. Called by : -! -! Any routine. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Paperwidth is "set" by NFRMAX. -! -! 8. Structure : -! -! ------------------------------------------------ -! Initializations and preparations. -! Determine maximum of spectra. -! Scaling / normalization. -! Printing of spectrum -! ---------------------------------------------- -! Print ID -! Print heading -! Print table -! Print ending -! ------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + ! + LX = JJ + WRITE (NDS,910) STRA, ' |', (PNUM2(I), I=1, LX), ' |' + END DO + ! + STRA = ' ' + PNUM2(1) = '--' + WRITE (NDS,910) STRA, ' +', (PNUM2(1), I=1, LX), '-+' + WRITE (NDS,912) (IX,IX=IX1,IX2,2*IX3) + WRITE (NDS,911) + ! + ! Non-normalized print plot ------------------------------------------- + ! + ELSE + ! + ! Heading + ! + WRITE (NDS,900) PRVAR, FSC, PRUNIT + ! + JJ = 0 + PNUM(1) = ' ' + DO IX = IX1, IX2, IX3 + JJ = JJ + 1 + END DO + LX = JJ + WRITE (NDS,921) + WRITE (NDS,922) (IX,IX=IX1,IX2,IX3) + STRA3 = ' ' + PNUM(1) = '-----' + WRITE (NDS,920) STRA3, ' +', (PNUM(1), I=1, LX), '-+ ' + ! + ! Write table + ! + JM = 0 + DO IY = IY2, IY1, IY3*(-1) + IF (JM.EQ.0) THEN + WRITE (STRA3, FMT='(I3)') IY + JM = 2 + ELSE + STRA3 = ' ' + JM = JM-1 + END IF + ! + JJ = 0 + DO IX = IX1, IX2, IX3 + JJ = JJ + 1 + IF (MAP(IX,IY).EQ.MAP0) THEN + PNUM(JJ) = ' ' + ELSE + RR = F(IX,IY) + K1 = NINT (RR / FSC) + WRITE (STRA, FMT='(I5)') K1 + PNUM(JJ) = STRA + END IF + END DO + ! + LX = JJ + WRITE (NDS,920) STRA3, ' |', (PNUM(I), I=1, LX), ' | ' + END DO + ! + STRA3 = ' ' + PNUM(1) = '-----' + WRITE (NDS,920) STRA3, ' +', (PNUM(1), I=1, LX), '-+ ' + WRITE (NDS,922) (IX,IX=IX1,IX2,IX3) + WRITE (NDS,921) + ! + END IF + ! + RETURN + ! + ! Formats + ! +900 FORMAT (/, ' Variable: ',A,' Units: ',E10.3,1X,A) +901 FORMAT (/, ' Variable: ',A,' Max.: ',E10.3,1X,A) + ! +910 FORMAT (1X,A5,63A2) +911 FORMAT (' ') +912 FORMAT (6X,32I8) + ! +920 FORMAT (1X,A3,A2,25A5) +921 FORMAT (' ') +922 FORMAT (6X,25I5) + !/ + !/ End of PRTBLK ----------------------------------------------------- / + !/ + END SUBROUTINE PRTBLK + !/ ------------------------------------------------------------------- / + SUBROUTINE PRT1DS (NDS, NFR, E, FR, UFR, NLINES, FTOPI, & + PRVAR, PRUNIT, PNTNME) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 10-Mar-1992 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Produces a print plot of a 1-D spectrum. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I File unit number. + ! NFR Int. I Number of frequencies. + ! E R.A. I Spectral densities. + ! FR R.A. I Frequencies. + ! UFR C*(*) I If 'HZ', frequencies in Hz, otherwise in + ! rad/s (N.B., does not re-scale spectrum). + ! NLINES Int. I Hight of plot in lines. + ! FTOPI Real I Highest value of density in plot, + ! if FTOPI.LE.0., automatic scaling. + ! PRVAR C*(*) I Name of variable. + ! PRUNIT C*(*) I Units of spectrum. + ! PNTNME C*(*) I Name of location. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See mudule documentation. + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Paperwidth is "set" by NFRMAX. + ! + ! 8. Structure : + ! + ! ------------------------------------------------ + ! Initializations and preparations. + ! Determine maximum of spectra. + ! Scaling / normalization. + ! Printing of spectrum + ! ---------------------------------------------- + ! Print ID + ! Print heading + ! Print table + ! Print ending + ! ------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NFR, NLINES - REAL, INTENT(IN) :: FTOPI, E(NFR), FR(NFR) - CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*), PNTNME*(*), & - UFR*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NFRB, IFR, IL, IL0 + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NFR, NLINES + REAL, INTENT(IN) :: FTOPI, E(NFR), FR(NFR) + CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*), PNTNME*(*), & + UFR*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NFRB, IFR, IL, IL0 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL, SAVE :: TOPFAC = 1.1 - REAL :: FTOP, RLINES, FACFR, FSC, FLINE, & - EMAX, EMIN, EXTR, FLOC - LOGICAL :: FLSCLE - CHARACTER :: STRA*10, STRA2*2, PNUM2*2 - DIMENSION :: PNUM2(NFM2) -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL, SAVE :: TOPFAC = 1.1 + REAL :: FTOP, RLINES, FACFR, FSC, FLINE, & + EMAX, EMIN, EXTR, FLOC + LOGICAL :: FLSCLE + CHARACTER :: STRA*10, STRA2*2, PNUM2*2 + DIMENSION :: PNUM2(NFM2) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'PRT1DS') + CALL STRACE (IENT, 'PRT1DS') #endif -! - FTOP = FTOPI -! - NFRB = MIN (NFR,50) - RLINES = REAL(NLINES) - FLSCLE = FTOP.LE.0. -! - IF (UFR.EQ.'HZ') THEN - FACFR = 1. - ELSE - FACFR = 0.159155 - END IF -! -! Maximum of 1-D spectrum -! - EMAX = 0. - EMIN = 0. -! - DO IFR=1, NFR - EMAX = MAX ( EMAX , E(IFR) ) - EMIN = MIN ( EMIN , E(IFR) ) - END DO -! - IF (EMAX.EQ.0. .AND. EMIN.EQ.0.) THEN - EMAX = 1.E-20 - EMIN = -1.E-20 - END IF -! + ! + FTOP = FTOPI + ! + NFRB = MIN (NFR,50) + RLINES = REAL(NLINES) + FLSCLE = FTOP.LE.0. + ! + IF (UFR.EQ.'HZ') THEN + FACFR = 1. + ELSE + FACFR = 0.159155 + END IF + ! + ! Maximum of 1-D spectrum + ! + EMAX = 0. + EMIN = 0. + ! + DO IFR=1, NFR + EMAX = MAX ( EMAX , E(IFR) ) + EMIN = MIN ( EMIN , E(IFR) ) + END DO + ! + IF (EMAX.EQ.0. .AND. EMIN.EQ.0.) THEN + EMAX = 1.E-20 + EMIN = -1.E-20 + END IF + ! + IF (EMAX.GT.ABS(EMIN)) THEN + EXTR = EMAX + ELSE + EXTR = EMIN + END IF + ! + ! Scaling / Normalization + ! + IF (FLSCLE) THEN IF (EMAX.GT.ABS(EMIN)) THEN - EXTR = EMAX - ELSE - EXTR = EMIN - END IF -! -! Scaling / Normalization -! - IF (FLSCLE) THEN - IF (EMAX.GT.ABS(EMIN)) THEN - FLOC = EMAX * TOPFAC - FSC = FLOC / REAL(NINT(EMAX/(EMAX-EMIN)*RLINES)) - ELSE - FLOC = EMIN * TOPFAC - FSC = FLOC / REAL(NINT(EMIN/(EMAX-EMIN)*RLINES)) - FLOC = FTOP + RLINES*FSC - IF (EMAX.LT.0.01*FSC) FTOP = 0. - END IF - ELSE - FLOC = FTOP - FSC = FLOC / RLINES - IF (EMAX*EMIN.LT.0) FSC = 2.*FSC - IF (EMAX.LT.0.01*FSC) FLOC = 0. - END IF -! - IL0 = MOD ( NINT(FLOC/FSC) , 2 ) + 1 -! -! Print ID -! - WRITE (NDS,900) PNTNME, PRVAR, EXTR, PRUNIT -! -! Print heading -! - FLINE = FLOC - IF (MOD(NLINES+IL0,2).EQ.0) THEN - WRITE (STRA, FMT='(E10.3)') FLINE - ELSE - STRA= ' ' - END IF -! - DO IFR=1, NFRB - IF ( NINT( (E(IFR)-FLINE)/FSC ) .EQ.0) THEN - PNUM2(IFR) = '-*' - ELSE - PNUM2(IFR) = '--' - END IF - END DO -! - PNUM2(NFRB+1) = '-+' - STRA2 = ' +' - WRITE (NDS,910) STRA, STRA2, (PNUM2(IFR),IFR=1, NFRB+1) -! -! Print table -! - DO IL = 1, NLINES-1 - FLINE = FLOC - FSC * REAL(IL) - IF (ABS(FLINE).LT.0.01*FSC) FLINE = 0. - IF (MOD(NLINES+IL0-IL,2).EQ.0) THEN - WRITE (STRA, FMT='(E10.3)') FLINE - STRA2 = ' +' - ELSE - STRA = ' ' - STRA2 = ' |' - END IF - DO IFR=1, NFRB - IF (ABS(FLINE).LT.0.1*FSC) THEN - PNUM2(NFRB+1) = '-|' - IF ( NINT( (E(IFR)-FLINE)/FSC ) .EQ.0) THEN - PNUM2(IFR) = '-*' - ELSE - PNUM2(IFR) = '--' - END IF - ELSE - PNUM2(NFRB+1) = ' |' - IF ( NINT( (E(IFR)-FLINE)/FSC ) .EQ.0) THEN - PNUM2(IFR) = ' *' - ELSE - PNUM2(IFR) = ' ' - END IF - END IF - END DO - WRITE (NDS,910) STRA, STRA2, (PNUM2(IFR),IFR=1, NFRB+1) - END DO -! -! write ending -! + FLOC = EMAX * TOPFAC + FSC = FLOC / REAL(NINT(EMAX/(EMAX-EMIN)*RLINES)) + ELSE + FLOC = EMIN * TOPFAC + FSC = FLOC / REAL(NINT(EMIN/(EMAX-EMIN)*RLINES)) + FLOC = FTOP + RLINES*FSC + IF (EMAX.LT.0.01*FSC) FTOP = 0. + END IF + ELSE + FLOC = FTOP + FSC = FLOC / RLINES + IF (EMAX*EMIN.LT.0) FSC = 2.*FSC + IF (EMAX.LT.0.01*FSC) FLOC = 0. + END IF + ! + IL0 = MOD ( NINT(FLOC/FSC) , 2 ) + 1 + ! + ! Print ID + ! + WRITE (NDS,900) PNTNME, PRVAR, EXTR, PRUNIT + ! + ! Print heading + ! + FLINE = FLOC + IF (MOD(NLINES+IL0,2).EQ.0) THEN + WRITE (STRA, FMT='(E10.3)') FLINE + ELSE + STRA= ' ' + END IF + ! + DO IFR=1, NFRB + IF ( NINT( (E(IFR)-FLINE)/FSC ) .EQ.0) THEN + PNUM2(IFR) = '-*' + ELSE + PNUM2(IFR) = '--' + END IF + END DO + ! + PNUM2(NFRB+1) = '-+' + STRA2 = ' +' + WRITE (NDS,910) STRA, STRA2, (PNUM2(IFR),IFR=1, NFRB+1) + ! + ! Print table + ! + DO IL = 1, NLINES-1 FLINE = FLOC - FSC * REAL(IL) IF (ABS(FLINE).LT.0.01*FSC) FLINE = 0. - WRITE (STRA, FMT='(E10.3)') FLINE - IF (MOD(IL0,2).EQ.0) THEN - WRITE (STRA, FMT='(E10.3)') FLINE - ELSE - STRA = ' ' - END IF - STRA2 = ' +' - PNUM2(NFRB+1) = '-+' -! + IF (MOD(NLINES+IL0-IL,2).EQ.0) THEN + WRITE (STRA, FMT='(E10.3)') FLINE + STRA2 = ' +' + ELSE + STRA = ' ' + STRA2 = ' |' + END IF DO IFR=1, NFRB - IF ( NINT( (E(IFR)-FLINE)/FSC ) .EQ.0) THEN + IF (ABS(FLINE).LT.0.1*FSC) THEN + PNUM2(NFRB+1) = '-|' + IF ( NINT( (E(IFR)-FLINE)/FSC ) .EQ.0) THEN PNUM2(IFR) = '-*' - ELSE IF ( MOD (IFR-2,4) .EQ. 0 ) THEN - PNUM2(IFR) = '-|' ELSE PNUM2(IFR) = '--' END IF - END DO -! + ELSE + PNUM2(NFRB+1) = ' |' + IF ( NINT( (E(IFR)-FLINE)/FSC ) .EQ.0) THEN + PNUM2(IFR) = ' *' + ELSE + PNUM2(IFR) = ' ' + END IF + END IF + END DO WRITE (NDS,910) STRA, STRA2, (PNUM2(IFR),IFR=1, NFRB+1) - WRITE (NDS,911) (FR(IFR)*FACFR,IFR=2,NFRB,4) - WRITE (NDS,920) -! - RETURN -! -! Formats -! - 900 FORMAT (/' Location : ',A & - /' Spectrum : ',A,' Extreme value : ',E10.3,1X,A/) -! - 910 FORMAT (A10,A2,60A2) - 911 FORMAT (10X,15F8.3) -! - 920 FORMAT (' ') -!/ -!/ End of PRT1DS ----------------------------------------------------- / -!/ - END SUBROUTINE PRT1DS -!/ ------------------------------------------------------------------- / - SUBROUTINE PRT1DM (NDS, NFR, NE, E, FR, UFR, NLINES, FTOPI, & - PRVAR, PRUNIT, PNTNME) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 17-Apr-1992 | -!/ +-----------------------------------+ -!/ -!/ 17-Apr-1992 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Produces a print plot of several 1-D spectra. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I File unit number. -! NFR Int. I Number of frequencies. -! NE Int. I Number of spectra. -! E R.A. I Spectral densities. -! FR R.A. I Frequencies. -! UFR C* I If 'HZ', frequencies in Hz, otherwise in -! rad/s -! NLINES Int. I Hight of plot in lines. -! FTOPI Real I Highest value of density in plot, -! if FTOP.LE.0., automatic scaling. -! PRVAR C*(*) I Name of variable. -! PRUNIT C*(*) I Units of spectrum. -! PNTNME C*(*) I Name of location. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See mudule documentation. -! -! 5. Called by : -! -! Any routine. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Paperwidth is "set" by NFRMAX. -! -! 8. Structure : -! -! ------------------------------------------------ -! Initializations and preparations. -! Determine maximum of spectrum. -! Scaling / normalization. -! Printing of spectrum -! ---------------------------------------------- -! Print ID -! Print heading -! Print table -! Print ending -! ------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + END DO + ! + ! write ending + ! + FLINE = FLOC - FSC * REAL(IL) + IF (ABS(FLINE).LT.0.01*FSC) FLINE = 0. + WRITE (STRA, FMT='(E10.3)') FLINE + IF (MOD(IL0,2).EQ.0) THEN + WRITE (STRA, FMT='(E10.3)') FLINE + ELSE + STRA = ' ' + END IF + STRA2 = ' +' + PNUM2(NFRB+1) = '-+' + ! + DO IFR=1, NFRB + IF ( NINT( (E(IFR)-FLINE)/FSC ) .EQ.0) THEN + PNUM2(IFR) = '-*' + ELSE IF ( MOD (IFR-2,4) .EQ. 0 ) THEN + PNUM2(IFR) = '-|' + ELSE + PNUM2(IFR) = '--' + END IF + END DO + ! + WRITE (NDS,910) STRA, STRA2, (PNUM2(IFR),IFR=1, NFRB+1) + WRITE (NDS,911) (FR(IFR)*FACFR,IFR=2,NFRB,4) + WRITE (NDS,920) + ! + RETURN + ! + ! Formats + ! +900 FORMAT (/' Location : ',A & + /' Spectrum : ',A,' Extreme value : ',E10.3,1X,A/) + ! +910 FORMAT (A10,A2,60A2) +911 FORMAT (10X,15F8.3) + ! +920 FORMAT (' ') + !/ + !/ End of PRT1DS ----------------------------------------------------- / + !/ + END SUBROUTINE PRT1DS + !/ ------------------------------------------------------------------- / + SUBROUTINE PRT1DM (NDS, NFR, NE, E, FR, UFR, NLINES, FTOPI, & + PRVAR, PRUNIT, PNTNME) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 17-Apr-1992 | + !/ +-----------------------------------+ + !/ + !/ 17-Apr-1992 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Produces a print plot of several 1-D spectra. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I File unit number. + ! NFR Int. I Number of frequencies. + ! NE Int. I Number of spectra. + ! E R.A. I Spectral densities. + ! FR R.A. I Frequencies. + ! UFR C* I If 'HZ', frequencies in Hz, otherwise in + ! rad/s + ! NLINES Int. I Hight of plot in lines. + ! FTOPI Real I Highest value of density in plot, + ! if FTOP.LE.0., automatic scaling. + ! PRVAR C*(*) I Name of variable. + ! PRUNIT C*(*) I Units of spectrum. + ! PNTNME C*(*) I Name of location. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See mudule documentation. + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Paperwidth is "set" by NFRMAX. + ! + ! 8. Structure : + ! + ! ------------------------------------------------ + ! Initializations and preparations. + ! Determine maximum of spectrum. + ! Scaling / normalization. + ! Printing of spectrum + ! ---------------------------------------------- + ! Print ID + ! Print heading + ! Print table + ! Print ending + ! ------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NFR, NE, NLINES - REAL, INTENT(IN) :: FTOPI, E(NFR,NE), FR(NFR) - CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*), PNTNME*(*), & - UFR*(*) - DIMENSION :: PRVAR(NE) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, PARAMETER :: NFRMAX = 100 - INTEGER, PARAMETER :: NFM2 = NFRMAX+1 - INTEGER :: NFRB, IFR, IE, IL + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NFR, NE, NLINES + REAL, INTENT(IN) :: FTOPI, E(NFR,NE), FR(NFR) + CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*), PNTNME*(*), & + UFR*(*) + DIMENSION :: PRVAR(NE) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, PARAMETER :: NFRMAX = 100 + INTEGER, PARAMETER :: NFM2 = NFRMAX+1 + INTEGER :: NFRB, IFR, IE, IL #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL, SAVE :: TOPFAC = 1.1 - REAL :: FTOP, RLINES, FACFR, FSC, FLINE, & - EMAX, EMIN, EXTR, FLOC - LOGICAL :: FLSCLE - CHARACTER :: STRA*10, STRA2*2, STRAX*2, PNUM2*2 - DIMENSION :: PNUM2(NFM2) -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL, SAVE :: TOPFAC = 1.1 + REAL :: FTOP, RLINES, FACFR, FSC, FLINE, & + EMAX, EMIN, EXTR, FLOC + LOGICAL :: FLSCLE + CHARACTER :: STRA*10, STRA2*2, STRAX*2, PNUM2*2 + DIMENSION :: PNUM2(NFM2) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'PRT1DM') + CALL STRACE (IENT, 'PRT1DM') #endif -! -! Test output, echo input -! + ! + ! Test output, echo input + ! #ifdef W3_T - WRITE (*,*) - WRITE (*,*) 'TEST OUTPUT PRT1DM, ECHO OF INPUT' - WRITE (*,*) '=======================================', & - '=======================================' - WRITE (*,*) 'File unit number : ', NDS - WRITE (*,*) 'Number of frequencies : ', NFR - WRITE (*,*) 'Number of spectra : ', NE - DO IE=1, NE - WRITE (*,*) 'Spectral densities spectrum ', IE - WRITE (*,'(6X,8E9.2)') (E(IFR,IE),IFR=1,NFR) - END DO - WRITE (*,*) 'Frequencies' - WRITE (*,'(6X,8E9.2)') (FR(IFR),IFR=1,NFR) - WRITE (*,*) 'Frequency type : ', UFR - WRITE (*,*) 'NLINES : ', NLINES - WRITE (*,*) 'FTOPI : ', FTOPI - WRITE (*,*) 'Names of spectra : ', PRVAR(1) - DO IE=2, NE - WRITE (*,*) ' ', PRVAR(IE) - END DO - WRITE (*,*) 'Units of spectra : ', PRUNIT - WRITE (*,*) 'Name of location : ', PNTNME - WRITE (*,*) '=======================================', & - '=======================================' - WRITE (*,*) + WRITE (*,*) + WRITE (*,*) 'TEST OUTPUT PRT1DM, ECHO OF INPUT' + WRITE (*,*) '=======================================', & + '=======================================' + WRITE (*,*) 'File unit number : ', NDS + WRITE (*,*) 'Number of frequencies : ', NFR + WRITE (*,*) 'Number of spectra : ', NE + DO IE=1, NE + WRITE (*,*) 'Spectral densities spectrum ', IE + WRITE (*,'(6X,8E9.2)') (E(IFR,IE),IFR=1,NFR) + END DO + WRITE (*,*) 'Frequencies' + WRITE (*,'(6X,8E9.2)') (FR(IFR),IFR=1,NFR) + WRITE (*,*) 'Frequency type : ', UFR + WRITE (*,*) 'NLINES : ', NLINES + WRITE (*,*) 'FTOPI : ', FTOPI + WRITE (*,*) 'Names of spectra : ', PRVAR(1) + DO IE=2, NE + WRITE (*,*) ' ', PRVAR(IE) + END DO + WRITE (*,*) 'Units of spectra : ', PRUNIT + WRITE (*,*) 'Name of location : ', PNTNME + WRITE (*,*) '=======================================', & + '=======================================' + WRITE (*,*) #endif -! - FTOP = FTOPI - NFRB = MIN (NFR,50) - RLINES = REAL(NLINES) - FLSCLE = FTOP.LE.0. -! - IF (UFR.EQ.'HZ') THEN - FACFR = 1. - ELSE - FACFR = 0.159155 - END IF -! -! Maximum of 1-D spectrum -! - EMAX = 0. - EMIN = 0. -! - DO IE=1, NE - DO IFR=1, NFR - EMAX = MAX ( EMAX , E(IFR,IE) ) - EMIN = MIN ( EMIN , E(IFR,IE) ) - END DO - END DO -! - IF (EMAX.EQ.0. .AND. EMIN.EQ.0.) THEN - EMAX = 1.E-20 - EMIN = -1.E-20 - END IF -! + ! + FTOP = FTOPI + NFRB = MIN (NFR,50) + RLINES = REAL(NLINES) + FLSCLE = FTOP.LE.0. + ! + IF (UFR.EQ.'HZ') THEN + FACFR = 1. + ELSE + FACFR = 0.159155 + END IF + ! + ! Maximum of 1-D spectrum + ! + EMAX = 0. + EMIN = 0. + ! + DO IE=1, NE + DO IFR=1, NFR + EMAX = MAX ( EMAX , E(IFR,IE) ) + EMIN = MIN ( EMIN , E(IFR,IE) ) + END DO + END DO + ! + IF (EMAX.EQ.0. .AND. EMIN.EQ.0.) THEN + EMAX = 1.E-20 + EMIN = -1.E-20 + END IF + ! + IF (EMAX.GT.ABS(EMIN)) THEN + EXTR = EMAX + ELSE + EXTR = EMIN + END IF + ! + ! Scaling / Normalization + ! + IF (FLSCLE) THEN IF (EMAX.GT.ABS(EMIN)) THEN - EXTR = EMAX - ELSE - EXTR = EMIN - END IF -! -! Scaling / Normalization -! - IF (FLSCLE) THEN - IF (EMAX.GT.ABS(EMIN)) THEN - FTOP = EMAX * TOPFAC - FSC = FTOP / REAL(NINT(EMAX/(EMAX-EMIN)*RLINES)) - ELSE - FTOP = EMIN * TOPFAC - FSC = FTOP / REAL(NINT(EMIN/(EMAX-EMIN)*RLINES)) - FTOP = FTOP + RLINES*FSC - IF (ABS(FTOP).LT.0.01*FSC) FTOP = 0. - END IF - ELSE - FSC = FTOP / RLINES - IF (EMAX*EMIN.LT.0) FSC = 2.*FSC - IF (EMAX.EQ.0.) FTOP = 0. - END IF -! -! Print ID -! - WRITE (NDS,900) PNTNME, EXTR, PRUNIT -! -! Print heading -! - FLINE = FTOP - IF (MOD(NLINES,2).EQ.0) THEN - WRITE (STRA, FMT='(E10.3)') FLINE - ELSE - STRA= ' ' - END IF -! - DO IFR=1, NFRB - PNUM2(IFR) = '--' - DO IE=1, NE - IF ( NINT( (E(IFR,IE)-FLINE)/FSC ) .EQ.0) THEN - IF (IE.LT.10) THEN - WRITE (STRAX,'(A1,I1)') '-', IE - ELSE - WRITE (STRAX,'(I2)') IE - END IF - PNUM2(IFR) = STRAX - END IF - END DO - END DO -! - PNUM2(NFRB+1) = '-+' - STRA2 = ' +' - WRITE (NDS,910) STRA, STRA2, (PNUM2(IFR),IFR=1, NFRB+1) -! -! Print table -! - PNUM2(NFRB+1) = ' |' -! - DO IL = 1, NLINES-1 - FLINE = FTOP - FSC * REAL(IL) - IF (ABS(FLINE).LT.0.01*FSC) FLINE = 0. - IF (MOD(NLINES-IL,2).EQ.0) THEN - WRITE (STRA, FMT='(E10.3)') FLINE - STRA2 = ' +' + FTOP = EMAX * TOPFAC + FSC = FTOP / REAL(NINT(EMAX/(EMAX-EMIN)*RLINES)) + ELSE + FTOP = EMIN * TOPFAC + FSC = FTOP / REAL(NINT(EMIN/(EMAX-EMIN)*RLINES)) + FTOP = FTOP + RLINES*FSC + IF (ABS(FTOP).LT.0.01*FSC) FTOP = 0. + END IF + ELSE + FSC = FTOP / RLINES + IF (EMAX*EMIN.LT.0) FSC = 2.*FSC + IF (EMAX.EQ.0.) FTOP = 0. + END IF + ! + ! Print ID + ! + WRITE (NDS,900) PNTNME, EXTR, PRUNIT + ! + ! Print heading + ! + FLINE = FTOP + IF (MOD(NLINES,2).EQ.0) THEN + WRITE (STRA, FMT='(E10.3)') FLINE + ELSE + STRA= ' ' + END IF + ! + DO IFR=1, NFRB + PNUM2(IFR) = '--' + DO IE=1, NE + IF ( NINT( (E(IFR,IE)-FLINE)/FSC ) .EQ.0) THEN + IF (IE.LT.10) THEN + WRITE (STRAX,'(A1,I1)') '-', IE ELSE - STRA = ' ' - STRA2 = ' |' + WRITE (STRAX,'(I2)') IE END IF - DO IFR=1, NFRB - PNUM2(NFRB+1) = ' |' - IF (ABS(FLINE).LT.0.1*FSC) THEN - PNUM2(IFR) = '--' - PNUM2(NFRB+1) = '-+' - DO IE=1, NE - IF ( NINT( (E(IFR,IE)-FLINE)/FSC ) .EQ.0) THEN - IF (IE.LT.10) THEN - WRITE (STRAX,'(A1,I1)') '-', IE - ELSE - WRITE (STRAX,'(I2)') IE - END IF - PNUM2(IFR) = STRAX - END IF - END DO - ELSE - PNUM2(IFR) = ' ' - DO IE=1, NE - IF ( NINT( (E(IFR,IE)-FLINE)/FSC ) .EQ.0) THEN - WRITE (STRAX,'(I2)') IE - PNUM2(IFR) = STRAX - END IF - END DO - END IF - END DO - WRITE (NDS,910) STRA, STRA2, (PNUM2(IFR),IFR=1, NFRB+1) - END DO -! -! write ending -! + PNUM2(IFR) = STRAX + END IF + END DO + END DO + ! + PNUM2(NFRB+1) = '-+' + STRA2 = ' +' + WRITE (NDS,910) STRA, STRA2, (PNUM2(IFR),IFR=1, NFRB+1) + ! + ! Print table + ! + PNUM2(NFRB+1) = ' |' + ! + DO IL = 1, NLINES-1 FLINE = FTOP - FSC * REAL(IL) IF (ABS(FLINE).LT.0.01*FSC) FLINE = 0. - WRITE (STRA, FMT='(E10.3)') FLINE - STRA2 = ' +' - PNUM2(NFRB+1) = '-+' -! + IF (MOD(NLINES-IL,2).EQ.0) THEN + WRITE (STRA, FMT='(E10.3)') FLINE + STRA2 = ' +' + ELSE + STRA = ' ' + STRA2 = ' |' + END IF DO IFR=1, NFRB - IF ( MOD (IFR-2,4) .EQ. 0 ) THEN - PNUM2(IFR) = '-|' - ELSE - PNUM2(IFR) = '--' - END IF - DO IE=1, NE - IF ( NINT( (E(IFR,IE)-FLINE)/FSC ) .EQ.0) THEN + PNUM2(NFRB+1) = ' |' + IF (ABS(FLINE).LT.0.1*FSC) THEN + PNUM2(IFR) = '--' + PNUM2(NFRB+1) = '-+' + DO IE=1, NE + IF ( NINT( (E(IFR,IE)-FLINE)/FSC ) .EQ.0) THEN IF (IE.LT.10) THEN - WRITE (STRAX,'(A1,I1)') '-', IE - ELSE - WRITE (STRAX,'(I2)') IE - END IF + WRITE (STRAX,'(A1,I1)') '-', IE + ELSE + WRITE (STRAX,'(I2)') IE + END IF PNUM2(IFR) = STRAX END IF END DO - END DO -! + ELSE + PNUM2(IFR) = ' ' + DO IE=1, NE + IF ( NINT( (E(IFR,IE)-FLINE)/FSC ) .EQ.0) THEN + WRITE (STRAX,'(I2)') IE + PNUM2(IFR) = STRAX + END IF + END DO + END IF + END DO WRITE (NDS,910) STRA, STRA2, (PNUM2(IFR),IFR=1, NFRB+1) - WRITE (NDS,911) (FR(IFR)*FACFR,IFR=2,NFRB,4) - WRITE (NDS,920) - WRITE (NDS,921) (PRVAR(IE),IE=1,NE) - WRITE (NDS,920) - IF (FLSCLE) FTOP = 0. -! - RETURN -! -! Formats -! - 900 FORMAT (/' Location : ',A & - /' Extreme value : ',E10.3,1X,A/) -! - 910 FORMAT (A10,A2,60A2) - 911 FORMAT (10X,15F8.3) -! - 920 FORMAT (' ') - 921 FORMAT (10X,'spectra : ',10(A,' ')/) -!/ -!/ End of PRT1DM ----------------------------------------------------- / -!/ - END SUBROUTINE PRT1DM -!/ ------------------------------------------------------------------- / - SUBROUTINE PRT2DS (NDS, NFR0, NFR, NTH, E, FR, UFR, FACSP, FSC, & - RRCUT, PRVAR, PRUNIT, PNTNME) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 07-Jun-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Prints a block type table of a 2-D spectrum. Input considers -! cartesian directions, output according to meteorological -! conventions (compass direction where waves come from). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I File unit number. -! NFR0 Int. I Array size for freq. -! NFR Int. I Number of frequencies. -! NTH Int. I Number of frequencies. -! E R.A. I Spectral densities. -! FR R.A. I Frequencies. -! UFR C*(*) I If 'HZ', frequencies in Hz, otherwise in -! rad/s -! FACSP Real I Conversion factor to obtain (Hz,degr) -! spectrum from E -! FSC Real I Scale factor, if FSC.eq.0. automatic -! scaling for "compressed" block. -! RRCUT Real I Relative cut-off for printing. -! PRVAR C*(*) I Name of variable. -! PRUNIT C*(*) I Units of spectrum. -! PNTNME C*(*) I Name of location. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ANGSTR (Internal) -! -! 5. Called by : -! -! Any program. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! PNUM2: dimensioning changed from 51 to 71 due to "subscript out -! of range" fault (Sep 28 2012) -! -! 8. Structure : -! -! ------------------------------------------------ -! Initializations and preparations. -! Determine maximum of spectrum. -! Scaling / normalization. -! Do for normalized or non-norm. spectrum -! ---------------------------------------------- -! Print ID -! Print heading -! Print table -! Print ending -! ------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! !/T Diagnostic test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + END DO + ! + ! write ending + ! + FLINE = FTOP - FSC * REAL(IL) + IF (ABS(FLINE).LT.0.01*FSC) FLINE = 0. + WRITE (STRA, FMT='(E10.3)') FLINE + STRA2 = ' +' + PNUM2(NFRB+1) = '-+' + ! + DO IFR=1, NFRB + IF ( MOD (IFR-2,4) .EQ. 0 ) THEN + PNUM2(IFR) = '-|' + ELSE + PNUM2(IFR) = '--' + END IF + DO IE=1, NE + IF ( NINT( (E(IFR,IE)-FLINE)/FSC ) .EQ.0) THEN + IF (IE.LT.10) THEN + WRITE (STRAX,'(A1,I1)') '-', IE + ELSE + WRITE (STRAX,'(I2)') IE + END IF + PNUM2(IFR) = STRAX + END IF + END DO + END DO + ! + WRITE (NDS,910) STRA, STRA2, (PNUM2(IFR),IFR=1, NFRB+1) + WRITE (NDS,911) (FR(IFR)*FACFR,IFR=2,NFRB,4) + WRITE (NDS,920) + WRITE (NDS,921) (PRVAR(IE),IE=1,NE) + WRITE (NDS,920) + IF (FLSCLE) FTOP = 0. + ! + RETURN + ! + ! Formats + ! +900 FORMAT (/' Location : ',A & + /' Extreme value : ',E10.3,1X,A/) + ! +910 FORMAT (A10,A2,60A2) +911 FORMAT (10X,15F8.3) + ! +920 FORMAT (' ') +921 FORMAT (10X,'spectra : ',10(A,' ')/) + !/ + !/ End of PRT1DM ----------------------------------------------------- / + !/ + END SUBROUTINE PRT1DM + !/ ------------------------------------------------------------------- / + SUBROUTINE PRT2DS (NDS, NFR0, NFR, NTH, E, FR, UFR, FACSP, FSC, & + RRCUT, PRVAR, PRUNIT, PNTNME) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 07-Jun-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Prints a block type table of a 2-D spectrum. Input considers + ! cartesian directions, output according to meteorological + ! conventions (compass direction where waves come from). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I File unit number. + ! NFR0 Int. I Array size for freq. + ! NFR Int. I Number of frequencies. + ! NTH Int. I Number of frequencies. + ! E R.A. I Spectral densities. + ! FR R.A. I Frequencies. + ! UFR C*(*) I If 'HZ', frequencies in Hz, otherwise in + ! rad/s + ! FACSP Real I Conversion factor to obtain (Hz,degr) + ! spectrum from E + ! FSC Real I Scale factor, if FSC.eq.0. automatic + ! scaling for "compressed" block. + ! RRCUT Real I Relative cut-off for printing. + ! PRVAR C*(*) I Name of variable. + ! PRUNIT C*(*) I Units of spectrum. + ! PNTNME C*(*) I Name of location. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ANGSTR (Internal) + ! + ! 5. Called by : + ! + ! Any program. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! PNUM2: dimensioning changed from 51 to 71 due to "subscript out + ! of range" fault (Sep 28 2012) + ! + ! 8. Structure : + ! + ! ------------------------------------------------ + ! Initializations and preparations. + ! Determine maximum of spectrum. + ! Scaling / normalization. + ! Do for normalized or non-norm. spectrum + ! ---------------------------------------------- + ! Print ID + ! Print heading + ! Print table + ! Print ending + ! ------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! !/T Diagnostic test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NFR0, NFR, NTH - REAL, INTENT(IN) :: E(NFR0,*), FR(*), FACSP, FSC, RRCUT - CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*), PNTNME*(*), & - UFR*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IFR, ITH, NFRB, INTANG, ITHSEC + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NFR0, NFR, NTH + REAL, INTENT(IN) :: E(NFR0,*), FR(*), FACSP, FSC, RRCUT + CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*), PNTNME*(*), & + UFR*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IFR, ITH, NFRB, INTANG, ITHSEC #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - LOGICAL :: FLSCLE - REAL :: FACFR, EMAX, EMIN, DTHDEG, RR, RRC - CHARACTER :: PNUM*5, STRA*5, STRANG*5, PNUM2*2, & - STRA2*2 - DIMENSION :: PNUM(25), PNUM2(101) -!/ -!/ ------------------------------------------------------------------- / -!/ + LOGICAL :: FLSCLE + REAL :: FACFR, EMAX, EMIN, DTHDEG, RR, RRC + CHARACTER :: PNUM*5, STRA*5, STRANG*5, PNUM2*2, & + STRA2*2 + DIMENSION :: PNUM(25), PNUM2(101) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'PRT2DS') + CALL STRACE (IENT, 'PRT2DS') #endif -! + ! #ifdef W3_T - WRITE (NDS,9000) NDS, NFR0, NFR, NTH, UFR, FACSP, FSC, & - RRCUT, PRVAR, PRUNIT, PNTNME + WRITE (NDS,9000) NDS, NFR0, NFR, NTH, UFR, FACSP, FSC, & + RRCUT, PRVAR, PRUNIT, PNTNME #endif -! -! initialisations -! - FLSCLE = .FALSE. - IF (FSC.EQ.0.) THEN - FLSCLE = .TRUE. - RRC = RRCUT * 10. - END IF -! - IF (UFR.EQ.'HZ') THEN - FACFR = 1. - ELSE - FACFR = 0.159155 - END IF -! -! Maximum of spectrum -! - EMAX = 1.E-20 - EMIN = 0. -! + ! + ! initialisations + ! + FLSCLE = .FALSE. + IF (FSC.EQ.0.) THEN + FLSCLE = .TRUE. + RRC = RRCUT * 10. + END IF + ! + IF (UFR.EQ.'HZ') THEN + FACFR = 1. + ELSE + FACFR = 0.159155 + END IF + ! + ! Maximum of spectrum + ! + EMAX = 1.E-20 + EMIN = 0. + ! + DO IFR=1, NFR + DO ITH=1, NTH + EMAX = MAX ( EMAX , E(IFR,ITH) ) + EMIN = MIN ( EMIN , E(IFR,ITH) ) + END DO + END DO + ! + EMAX = MAX (EMAX, ABS(EMIN) ) + ! + DTHDEG = 360. / REAL(NTH) + ! + ! Normalized spectra : = = = = = = = = = = = = = = = = = = = = = = + ! + IF (FLSCLE) THEN + ! + ! Write ID + ! + WRITE (NDS,900) PNTNME, PRVAR, EMAX*FACSP, PRUNIT + ! + ! Write Head + ! + NFRB = MIN (NFR,50) + WRITE (NDS,910) (FR(IFR)*FACFR,IFR=2,NFRB,4) + ! DO IFR=1, NFR - DO ITH=1, NTH - EMAX = MAX ( EMAX , E(IFR,ITH) ) - EMIN = MIN ( EMIN , E(IFR,ITH) ) - END DO - END DO -! - EMAX = MAX (EMAX, ABS(EMIN) ) -! - DTHDEG = 360. / REAL(NTH) -! -! Normalized spectra : = = = = = = = = = = = = = = = = = = = = = = -! - IF (FLSCLE) THEN -! -! Write ID -! - WRITE (NDS,900) PNTNME, PRVAR, EMAX*FACSP, PRUNIT -! -! Write Head -! - NFRB = MIN (NFR,50) - WRITE (NDS,910) (FR(IFR)*FACFR,IFR=2,NFRB,4) -! - DO IFR=1, NFR - IF ( MOD((IFR-2),4) .EQ. 0) THEN - PNUM2(IFR) = '-|' - ELSE - PNUM2(IFR) = '--' - END IF - END DO -! - PNUM2(NFRB+1) = '-+' - WRITE (NDS,920) (PNUM2(IFR),IFR=1, NFRB+1) -! -! Write table -! - ITHSEC = NTH + 1 -! - DO ITH= NTH, 1, -1 - INTANG = 270 - NINT (DTHDEG*REAL(ITH-1)) - IF (INTANG.LT.0) THEN - ITHSEC = ITH - CYCLE - END IF - CALL ANGSTR (INTANG, STRANG, 4, 2) - DO IFR=1, NFRB - RR = E(IFR,ITH)/EMAX - IF (E(IFR,ITH).EQ.EMAX .OR. RR.GE.1.) THEN - PNUM2(IFR) = ' *' - ELSE IF (-E(IFR,ITH).EQ.EMAX .OR. RR.LE.-1.) THEN - PNUM2(IFR) = ' #' - ELSE IF (ABS(RR).LT.RRC) THEN - PNUM2(IFR) = ' ' - ELSE IF ((RR*10.).LT.0. .AND. (RR*10.).GT.-1.) THEN - PNUM2(IFR) = '-0' - ELSE - WRITE (STRA2, FMT='(I2)') INT (RR*10.) - PNUM2(IFR) = STRA2 - END IF - END DO - PNUM2(NFRB+1) = ' |' - WRITE (NDS,930) STRANG, (PNUM2(IFR),IFR=1, NFRB+1) - END DO -! - DO ITH= NTH, ITHSEC, -1 - INTANG = 630 - NINT (DTHDEG*REAL(ITH-1)) - CALL ANGSTR (INTANG, STRANG, 4, 2) - DO IFR=1, NFRB - RR = E(IFR,ITH)/EMAX - IF (E(IFR,ITH).EQ.EMAX .OR. RR.GE.1.) THEN - PNUM2(IFR) = ' *' - ELSE IF (-E(IFR,ITH).EQ.EMAX .OR. RR.LE.-1.) THEN - PNUM2(IFR) = ' #' - ELSE IF (ABS(RR).LT.RRC) THEN - PNUM2(IFR) = ' ' - ELSE IF ((RR*10.).LT.0. .AND. (RR*10.).GT.-1.) THEN - PNUM2(IFR) = '-0' - ELSE - WRITE (STRA2, FMT='(I2)') INT (RR*10.) - PNUM2(IFR) = STRA2 - END IF - END DO - PNUM2(NFRB+1) = ' |' - WRITE (NDS,930) STRANG, (PNUM2(IFR),IFR=1, NFRB+1) - END DO -! -! Write ending: -! - PNUM2(1) = '--' - PNUM2(2) = '-+' - WRITE (NDS,920) (PNUM2(1),IFR=1, NFRB), PNUM2(2) - WRITE (NDS,950) -! -! Scaled spectra : = = = = = = = = = = = = = = = = = = = = = = = = -! + IF ( MOD((IFR-2),4) .EQ. 0) THEN + PNUM2(IFR) = '-|' ELSE -! -! Write ID -! - WRITE (NDS,901) PNTNME, PRVAR, FSC, PRUNIT, & - EMAX*FACSP, PRUNIT -! -! Write heading -! - NFRB = MIN (NFR,25) -! - WRITE (NDS,911) (FR(IFR)*FACFR,IFR=2,NFRB,2) - PNUM(1) = '-----' - PNUM(2) = '-- ' -! - IF (NFRB.LT.25) THEN - WRITE (NDS,921) (PNUM(1),IFR=1, NFRB), PNUM(2) - ELSE - WRITE (NDS,921) (PNUM(1),IFR=1, NFRB) - END IF -! -! write table : -! - ITHSEC = NTH + 1 -! - DO ITH= NTH, 1, -1 - INTANG = 270 - NINT (DTHDEG*REAL(ITH-1)) - IF (INTANG.LT.0) THEN - ITHSEC = ITH - CYCLE - END IF - CALL ANGSTR (INTANG, STRANG, 4, 2) - DO IFR=1, NFRB - RR = E(IFR,ITH) - IF (ABS(RR/EMAX).LT.RRCUT) THEN - PNUM(IFR) = ' ' - ELSE - WRITE (STRA, FMT='(I5)') NINT (RR*FACSP/FSC) - PNUM(IFR) = STRA - END IF - END DO - WRITE (NDS,931) STRANG, (PNUM(IFR),IFR=1, NFRB) - END DO -! - DO ITH= NTH, ITHSEC, -1 - INTANG = 630 - NINT (DTHDEG*REAL(ITH-1)) - CALL ANGSTR (INTANG, STRANG, 4, 2) - DO IFR=1, NFRB - RR = E(IFR,ITH) - IF (ABS(RR/EMAX).LT.RRCUT) THEN - PNUM(IFR) = ' ' - ELSE - WRITE (STRA, FMT='(I5)') NINT (RR*FACSP/FSC) - PNUM(IFR) = STRA - END IF - END DO - WRITE (NDS,931) STRANG, (PNUM(IFR),IFR=1, NFRB) - END DO -! -! write ending : -! - PNUM(1) = '-----' - PNUM(2) = '-- ' - IF (NFRB.LT.25) THEN - WRITE (NDS,921) (PNUM(1),IFR=1, NFRB), PNUM(2) - ELSE - WRITE (NDS,921) (PNUM(1),IFR=1, NFRB) - END IF - WRITE (NDS,950) -! + PNUM2(IFR) = '--' END IF -! - RETURN -! -! Formats -! - 900 FORMAT (/' Location : ',A/ & - ' Spectrum : ',A,' (Normalized) ', & - ' Maximum value : ',E8.3,1X,A/) - 901 FORMAT (/' Location : ',A/ & - ' Spectrum : ',A,' Units : ',E8.3,1X,A, & - ' Maximum value : ',E8.3,1X,A/) -! - 910 FORMAT (5X,' ang.| frequencies (Hz) '/ & - 5X,' deg.|',F6.3,15F8.3) - 920 FORMAT (5X,' ----+',60A2) - 930 FORMAT (5X,' ',A4,' |',60A2) -! - 911 FORMAT (' ang.| frequencies (Hz) '/ & - ' deg.|',12F10.3) - 921 FORMAT (' ----|',25A5) - 931 FORMAT (' ',A4,' |',25A5) -! - 950 FORMAT (' ') -! + END DO + ! + PNUM2(NFRB+1) = '-+' + WRITE (NDS,920) (PNUM2(IFR),IFR=1, NFRB+1) + ! + ! Write table + ! + ITHSEC = NTH + 1 + ! + DO ITH= NTH, 1, -1 + INTANG = 270 - NINT (DTHDEG*REAL(ITH-1)) + IF (INTANG.LT.0) THEN + ITHSEC = ITH + CYCLE + END IF + CALL ANGSTR (INTANG, STRANG, 4, 2) + DO IFR=1, NFRB + RR = E(IFR,ITH)/EMAX + IF (E(IFR,ITH).EQ.EMAX .OR. RR.GE.1.) THEN + PNUM2(IFR) = ' *' + ELSE IF (-E(IFR,ITH).EQ.EMAX .OR. RR.LE.-1.) THEN + PNUM2(IFR) = ' #' + ELSE IF (ABS(RR).LT.RRC) THEN + PNUM2(IFR) = ' ' + ELSE IF ((RR*10.).LT.0. .AND. (RR*10.).GT.-1.) THEN + PNUM2(IFR) = '-0' + ELSE + WRITE (STRA2, FMT='(I2)') INT (RR*10.) + PNUM2(IFR) = STRA2 + END IF + END DO + PNUM2(NFRB+1) = ' |' + WRITE (NDS,930) STRANG, (PNUM2(IFR),IFR=1, NFRB+1) + END DO + ! + DO ITH= NTH, ITHSEC, -1 + INTANG = 630 - NINT (DTHDEG*REAL(ITH-1)) + CALL ANGSTR (INTANG, STRANG, 4, 2) + DO IFR=1, NFRB + RR = E(IFR,ITH)/EMAX + IF (E(IFR,ITH).EQ.EMAX .OR. RR.GE.1.) THEN + PNUM2(IFR) = ' *' + ELSE IF (-E(IFR,ITH).EQ.EMAX .OR. RR.LE.-1.) THEN + PNUM2(IFR) = ' #' + ELSE IF (ABS(RR).LT.RRC) THEN + PNUM2(IFR) = ' ' + ELSE IF ((RR*10.).LT.0. .AND. (RR*10.).GT.-1.) THEN + PNUM2(IFR) = '-0' + ELSE + WRITE (STRA2, FMT='(I2)') INT (RR*10.) + PNUM2(IFR) = STRA2 + END IF + END DO + PNUM2(NFRB+1) = ' |' + WRITE (NDS,930) STRANG, (PNUM2(IFR),IFR=1, NFRB+1) + END DO + ! + ! Write ending: + ! + PNUM2(1) = '--' + PNUM2(2) = '-+' + WRITE (NDS,920) (PNUM2(1),IFR=1, NFRB), PNUM2(2) + WRITE (NDS,950) + ! + ! Scaled spectra : = = = = = = = = = = = = = = = = = = = = = = = = + ! + ELSE + ! + ! Write ID + ! + WRITE (NDS,901) PNTNME, PRVAR, FSC, PRUNIT, & + EMAX*FACSP, PRUNIT + ! + ! Write heading + ! + NFRB = MIN (NFR,25) + ! + WRITE (NDS,911) (FR(IFR)*FACFR,IFR=2,NFRB,2) + PNUM(1) = '-----' + PNUM(2) = '-- ' + ! + IF (NFRB.LT.25) THEN + WRITE (NDS,921) (PNUM(1),IFR=1, NFRB), PNUM(2) + ELSE + WRITE (NDS,921) (PNUM(1),IFR=1, NFRB) + END IF + ! + ! write table : + ! + ITHSEC = NTH + 1 + ! + DO ITH= NTH, 1, -1 + INTANG = 270 - NINT (DTHDEG*REAL(ITH-1)) + IF (INTANG.LT.0) THEN + ITHSEC = ITH + CYCLE + END IF + CALL ANGSTR (INTANG, STRANG, 4, 2) + DO IFR=1, NFRB + RR = E(IFR,ITH) + IF (ABS(RR/EMAX).LT.RRCUT) THEN + PNUM(IFR) = ' ' + ELSE + WRITE (STRA, FMT='(I5)') NINT (RR*FACSP/FSC) + PNUM(IFR) = STRA + END IF + END DO + WRITE (NDS,931) STRANG, (PNUM(IFR),IFR=1, NFRB) + END DO + ! + DO ITH= NTH, ITHSEC, -1 + INTANG = 630 - NINT (DTHDEG*REAL(ITH-1)) + CALL ANGSTR (INTANG, STRANG, 4, 2) + DO IFR=1, NFRB + RR = E(IFR,ITH) + IF (ABS(RR/EMAX).LT.RRCUT) THEN + PNUM(IFR) = ' ' + ELSE + WRITE (STRA, FMT='(I5)') NINT (RR*FACSP/FSC) + PNUM(IFR) = STRA + END IF + END DO + WRITE (NDS,931) STRANG, (PNUM(IFR),IFR=1, NFRB) + END DO + ! + ! write ending : + ! + PNUM(1) = '-----' + PNUM(2) = '-- ' + IF (NFRB.LT.25) THEN + WRITE (NDS,921) (PNUM(1),IFR=1, NFRB), PNUM(2) + ELSE + WRITE (NDS,921) (PNUM(1),IFR=1, NFRB) + END IF + WRITE (NDS,950) + ! + END IF + ! + RETURN + ! + ! Formats + ! +900 FORMAT (/' Location : ',A/ & + ' Spectrum : ',A,' (Normalized) ', & + ' Maximum value : ',E8.3,1X,A/) +901 FORMAT (/' Location : ',A/ & + ' Spectrum : ',A,' Units : ',E8.3,1X,A, & + ' Maximum value : ',E8.3,1X,A/) + ! +910 FORMAT (5X,' ang.| frequencies (Hz) '/ & + 5X,' deg.|',F6.3,15F8.3) +920 FORMAT (5X,' ----+',60A2) +930 FORMAT (5X,' ',A4,' |',60A2) + ! +911 FORMAT (' ang.| frequencies (Hz) '/ & + ' deg.|',12F10.3) +921 FORMAT (' ----|',25A5) +931 FORMAT (' ',A4,' |',25A5) + ! +950 FORMAT (' ') + ! #ifdef W3_T - 9000 FORMAT ( ' TEST PRT2DS : ECHO OF INPUT PARAMETERS'/ & - ' NDS :',I6/ & - ' NFR0, NFR :',2I6/ & - ' NTH :',I6/ & - ' UFR : ',A/ & - ' FACSP :',E10.3/ & - ' FSC :',E10.3/ & - ' RRCUT :',E10.3/ & - ' PRVAR : ',A/ & - ' PRUNIT : ',A/ & - ' PNTNME : ',A) +9000 FORMAT ( ' TEST PRT2DS : ECHO OF INPUT PARAMETERS'/ & + ' NDS :',I6/ & + ' NFR0, NFR :',2I6/ & + ' NTH :',I6/ & + ' UFR : ',A/ & + ' FACSP :',E10.3/ & + ' FSC :',E10.3/ & + ' RRCUT :',E10.3/ & + ' PRVAR : ',A/ & + ' PRUNIT : ',A/ & + ' PNTNME : ',A) #endif -!/ -!/ Internal subroutine ANGSTR ---------------------------------------- / -!/ - CONTAINS -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE ANGSTR (IANG, SANG, ILEN, INUM) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 10-Mar-1992 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -! -! INPUT : IANG --> INTEGER ANGLE (DEGREES) -! ILEN --> STRING LENGTH -! INUM --> <1 : ONLY FOUR MAIN DIRECTIONS -! 1 : N,E,S,W AND NUMERICAL OUTPUT -! 2 : EIGHT MAIN DIRECTIONS -! >2 : EIGHT DIRECTIONS + NUMERICAL OUTPUT -! OUTPUT : SANG --> STRING -! -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ Internal subroutine ANGSTR ---------------------------------------- / + !/ + CONTAINS + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE ANGSTR (IANG, SANG, ILEN, INUM) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 10-Mar-1992 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + ! + ! INPUT : IANG --> INTEGER ANGLE (DEGREES) + ! ILEN --> STRING LENGTH + ! INUM --> <1 : ONLY FOUR MAIN DIRECTIONS + ! 1 : N,E,S,W AND NUMERICAL OUTPUT + ! 2 : EIGHT MAIN DIRECTIONS + ! >2 : EIGHT DIRECTIONS + NUMERICAL OUTPUT + ! OUTPUT : SANG --> STRING + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S USE W3SERVMD, ONLY: STRACE #endif -! + ! IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ INTEGER, INTENT(IN) :: IANG, ILEN, INUM CHARACTER, INTENT(OUT) :: SANG*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ INTEGER :: I, J CHARACTER :: SAUX*4 -!/ -!/ ------------------------------------------------------------------- / -!/ -! numerical : -! + !/ + !/ ------------------------------------------------------------------- / + !/ + ! numerical : + ! IF (INUM.EQ.1 .OR. INUM.GE.3) THEN - WRITE (SAUX, FMT='(I4)') IANG - ELSE - SAUX = ' ' - END IF -! -! string : -! + WRITE (SAUX, FMT='(I4)') IANG + ELSE + SAUX = ' ' + END IF + ! + ! string : + ! IF (IANG.EQ.0) THEN - SAUX = ' N' - ELSE IF (IANG.EQ.90) THEN - SAUX = ' E' - ELSE IF (IANG.EQ.180) THEN - SAUX = ' S' - ELSE IF (IANG.EQ.270) THEN - SAUX = ' W' - ELSE IF (INUM.GE.2) THEN - IF (IANG.EQ.45) THEN - SAUX = ' NE' - ELSE IF (IANG.EQ.135) THEN - SAUX = ' SE' - ELSE IF (IANG.EQ.225) THEN - SAUX = ' SW' - ELSE IF (IANG.EQ.315) THEN - SAUX = ' NW' - END IF + SAUX = ' N' + ELSE IF (IANG.EQ.90) THEN + SAUX = ' E' + ELSE IF (IANG.EQ.180) THEN + SAUX = ' S' + ELSE IF (IANG.EQ.270) THEN + SAUX = ' W' + ELSE IF (INUM.GE.2) THEN + IF (IANG.EQ.45) THEN + SAUX = ' NE' + ELSE IF (IANG.EQ.135) THEN + SAUX = ' SE' + ELSE IF (IANG.EQ.225) THEN + SAUX = ' SW' + ELSE IF (IANG.EQ.315) THEN + SAUX = ' NW' END IF -! -! Auxilary string to output : -! + END IF + ! + ! Auxilary string to output : + ! DO I=1, ILEN-4 SANG = ' ' - END DO + END DO J = 0 DO I=ILEN-3, ILEN J = J + 1 SANG(I:I) = SAUX(J:J) - END DO + END DO RETURN -!/ -!/ End of ANGSTR ----------------------------------------------------- / -!/ - END SUBROUTINE ANGSTR -!/ -!/ End of PRT2DS ----------------------------------------------------- / -!/ - END SUBROUTINE PRT2DS -!/ -!/ End of module W3ARRYMD -------------------------------------------- / -!/ - END MODULE W3ARRYMD + !/ + !/ End of ANGSTR ----------------------------------------------------- / + !/ + END SUBROUTINE ANGSTR + !/ + !/ End of PRT2DS ----------------------------------------------------- / + !/ + END SUBROUTINE PRT2DS + !/ + !/ End of module W3ARRYMD -------------------------------------------- / + !/ +END MODULE W3ARRYMD diff --git a/model/src/w3bullmd.F90 b/model/src/w3bullmd.F90 index 2d5b0352b..10301e8ca 100644 --- a/model/src/w3bullmd.F90 +++ b/model/src/w3bullmd.F90 @@ -1,6 +1,6 @@ -!> @file +!> @file !> @brief Contains module W3BULLMD. -!> +!> !> @author J. H. Alves !> @author H. L. Tolman !> @date 26-Dec-2012 @@ -10,7 +10,7 @@ !/ ------------------------------------------------------------------- / !> !> @brief Module W3BULLMD. -!> +!> !> @author J. H. Alves !> @author H. L. Tolman !> @date 26-Dec-2012 @@ -20,469 +20,468 @@ !> reserved. WAVEWATCH III is a trademark of the NWS. !> No unauthorized use without permission. !> - MODULE W3BULLMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | J. H. Alves | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2012 | -!/ +-----------------------------------+ -!/ -!/ 01-APR-2010 : Origination. ( version 3.14 ) -!/ 25-Jun-2011 : Temporary change of HSMIN ( version 4.05 ) -!/ 15-Aug-2011 : Changing HSMIN to BHSMIN bugfix ( version 4.05 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: GNAME, NK, NTH, NSPEC, FLAGLL - USE W3ODATMD, ONLY: NOPTS, PTLOC, PTNME, DIMP - USE CONSTANTS, ONLY: PI, TPI - USE W3WDATMD, ONLY: TIME - USE W3TIMEMD, ONLY: DSEC21 - PUBLIC - INTEGER, PARAMETER :: NPTAB = 6, NFLD = 50, NPMAX = 80 -! - REAL, PARAMETER :: BHSMIN = 0.15, BHSDROP = 0.05 - REAL :: HST(NPTAB,2), TPT(NPTAB,2), & - DMT(NPTAB,2) - CHARACTER(LEN=129) :: ASCBLINE - CHARACTER(LEN=664) :: CSVBLINE +MODULE W3BULLMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | J. H. Alves | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Dec-2012 | + !/ +-----------------------------------+ + !/ + !/ 01-APR-2010 : Origination. ( version 3.14 ) + !/ 25-Jun-2011 : Temporary change of HSMIN ( version 4.05 ) + !/ 15-Aug-2011 : Changing HSMIN to BHSMIN bugfix ( version 4.05 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: GNAME, NK, NTH, NSPEC, FLAGLL + USE W3ODATMD, ONLY: NOPTS, PTLOC, PTNME, DIMP + USE CONSTANTS, ONLY: PI, TPI + USE W3WDATMD, ONLY: TIME + USE W3TIMEMD, ONLY: DSEC21 + PUBLIC + INTEGER, PARAMETER :: NPTAB = 6, NFLD = 50, NPMAX = 80 + ! + REAL, PARAMETER :: BHSMIN = 0.15, BHSDROP = 0.05 + REAL :: HST(NPTAB,2), TPT(NPTAB,2), & + DMT(NPTAB,2) + CHARACTER(LEN=129) :: ASCBLINE + CHARACTER(LEN=664) :: CSVBLINE #ifdef W3_NCO - CHARACTER(LEN=67) :: CASCBLINE + CHARACTER(LEN=67) :: CASCBLINE #endif - LOGICAL :: IYY(NPMAX) -!/ -!/ Conventional declarations -!/ -!/ -!/ Private parameter statements (ID strings) -!/ -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Read a WAVEWATCH-III version 1.17 point output data file and -!> produces a table of mean parameters for all individual wave -!> systems. -!> -!> @details Partitioning is made using the built-in module w3partmd. -!> Partitions are ranked and organized into coherent sequences that -!> are then written as tables to output files. Input options for generating -!> tables are defined in ww3_outp.inp. This module sorts the table -!> data, output to file is controlled by WW3_OUTP. -!> -!> @param[in] NPART -!> @param[in] XPART -!> @param[in] DIMXP -!> @param[in] UABS -!> @param[in] UD -!> @param IPNT -!> @param[in] IOUT -!> @param[inout] TIMEV -!> -!> @author J. H. Alves -!> @author H. L. Tolman -!> @date 11-Mar-2013 -!> - SUBROUTINE W3BULL & - ( NPART, XPART, DIMXP, UABS, UD, IPNT, IOUT, TIMEV ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | J. H. Alves | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 11-Mar-2013 ! -!/ +-----------------------------------+ -!/ -!/ 01-Apr-2010 : Origination. ( version 3.14 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ 15-Aug-2011 : Adjustments to version 4.05 ( version 4.05 ) -!/ 11-Mar-2013 : Minor cleanup ( version 4.09 ) -!/ -! 1. Purpose : -! -! Read a WAVEWATCH-III version 1.17 point output data file and -! produces a table of mean parameters for all individual wave -! systems. -! -! 2. Method : -! -! Partitioning is made using the built-in module w3partmd. Partitions -! are ranked and organized into coherent sequences that are then -! written as tables to output files. Input options for generating -! tables are defined in ww3_outp.inp. This module sorts the table -! data, output to file is controlled by WW3_OUTP. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! DHSMAX Real Max. change in Hs for system to be considered -! related to previous time. -! DTPMAX Real Id. Tp. -! DDMMAX Real Id. Dm. -! DDWMAX Real Maximum differences in wind and wave direction -! for marking of system as under the influence -! of the local wind, -! AGEMIN Real Id. wave age. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! WW3_OUTP -! -! 6. Error messages : -! -! Error control made in WW3_OUTP. -! -! 7. Remarks : -! -! Current version does not allow generating tables for multiple -! points. -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! USE CONSTANTS + LOGICAL :: IYY(NPMAX) + !/ + !/ Conventional declarations + !/ + !/ + !/ Private parameter statements (ID strings) + !/ + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Read a WAVEWATCH-III version 1.17 point output data file and + !> produces a table of mean parameters for all individual wave + !> systems. + !> + !> @details Partitioning is made using the built-in module w3partmd. + !> Partitions are ranked and organized into coherent sequences that + !> are then written as tables to output files. Input options for generating + !> tables are defined in ww3_outp.inp. This module sorts the table + !> data, output to file is controlled by WW3_OUTP. + !> + !> @param[in] NPART + !> @param[in] XPART + !> @param[in] DIMXP + !> @param[in] UABS + !> @param[in] UD + !> @param IPNT + !> @param[in] IOUT + !> @param[inout] TIMEV + !> + !> @author J. H. Alves + !> @author H. L. Tolman + !> @date 11-Mar-2013 + !> + SUBROUTINE W3BULL & + ( NPART, XPART, DIMXP, UABS, UD, IPNT, IOUT, TIMEV ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | J. H. Alves | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 11-Mar-2013 ! + !/ +-----------------------------------+ + !/ + !/ 01-Apr-2010 : Origination. ( version 3.14 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ 15-Aug-2011 : Adjustments to version 4.05 ( version 4.05 ) + !/ 11-Mar-2013 : Minor cleanup ( version 4.09 ) + !/ + ! 1. Purpose : + ! + ! Read a WAVEWATCH-III version 1.17 point output data file and + ! produces a table of mean parameters for all individual wave + ! systems. + ! + ! 2. Method : + ! + ! Partitioning is made using the built-in module w3partmd. Partitions + ! are ranked and organized into coherent sequences that are then + ! written as tables to output files. Input options for generating + ! tables are defined in ww3_outp.inp. This module sorts the table + ! data, output to file is controlled by WW3_OUTP. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! DHSMAX Real Max. change in Hs for system to be considered + ! related to previous time. + ! DTPMAX Real Id. Tp. + ! DDMMAX Real Id. Dm. + ! DDWMAX Real Maximum differences in wind and wave direction + ! for marking of system as under the influence + ! of the local wind, + ! AGEMIN Real Id. wave age. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! WW3_OUTP + ! + ! 6. Error messages : + ! + ! Error control made in WW3_OUTP. + ! + ! 7. Remarks : + ! + ! Current version does not allow generating tables for multiple + ! points. + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! USE CONSTANTS #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -!/ -! -! -------------------------------------------------------------------- / -! 1. Initializations -! + ! + IMPLICIT NONE + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + !/ + ! + ! -------------------------------------------------------------------- / + ! 1. Initializations + ! #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: DHSMAX, DTPMAX, & - DDMMAX, DDWMAX, AGEMIN - PARAMETER ( DHSMAX = 1.50 ) - PARAMETER ( DTPMAX = 1.50 ) - PARAMETER ( DDMMAX = 15. ) - PARAMETER ( DDWMAX = 30. ) - PARAMETER ( AGEMIN = 0.8 ) - INTEGER, INTENT(IN) :: NPART, DIMXP, IOUT - INTEGER, INTENT(INOUT) :: TIMEV(2) - REAL, INTENT(IN) :: UABS, & - UD, XPART(DIMP,0:DIMXP) - INTEGER :: IPG1,IPI(NPMAX), ILEN(NPMAX), IP, & - IPNOW, IFLD, INOTAB, IPNT, ITAB, & - DOUTP, FCSTI, NZERO - REAL :: AFR, AGE, DDMMAXR, DELDM, DELDMR, & - DELDW, DELHS, DELTP, DHSMAXR, & - DTPMAXR, HMAX, HSTOT, TP, UDIR, FACT - REAL :: HSP(NPMAX), TPP(NPMAX), & - DMP(NPMAX), WNP(NPMAX), HSD(NPMAX), & - TPD(NPMAX), WDD(NPMAX) - LOGICAL :: FLAG(NPMAX) - CHARACTER(LEN=129) :: BLANK, TAIL !, ASCBLINE + REAL :: DHSMAX, DTPMAX, & + DDMMAX, DDWMAX, AGEMIN + PARAMETER ( DHSMAX = 1.50 ) + PARAMETER ( DTPMAX = 1.50 ) + PARAMETER ( DDMMAX = 15. ) + PARAMETER ( DDWMAX = 30. ) + PARAMETER ( AGEMIN = 0.8 ) + INTEGER, INTENT(IN) :: NPART, DIMXP, IOUT + INTEGER, INTENT(INOUT) :: TIMEV(2) + REAL, INTENT(IN) :: UABS, & + UD, XPART(DIMP,0:DIMXP) + INTEGER :: IPG1,IPI(NPMAX), ILEN(NPMAX), IP, & + IPNOW, IFLD, INOTAB, IPNT, ITAB, & + DOUTP, FCSTI, NZERO + REAL :: AFR, AGE, DDMMAXR, DELDM, DELDMR, & + DELDW, DELHS, DELTP, DHSMAXR, & + DTPMAXR, HMAX, HSTOT, TP, UDIR, FACT + REAL :: HSP(NPMAX), TPP(NPMAX), & + DMP(NPMAX), WNP(NPMAX), HSD(NPMAX), & + TPD(NPMAX), WDD(NPMAX) + LOGICAL :: FLAG(NPMAX) + CHARACTER(LEN=129) :: BLANK, TAIL !, ASCBLINE #ifdef W3_NCO - CHARACTER(LEN=67) :: CBLANK, CTAIL !, CASCBLINE + CHARACTER(LEN=67) :: CBLANK, CTAIL !, CASCBLINE #endif - CHARACTER(LEN=15) :: PART + CHARACTER(LEN=15) :: PART #ifdef W3_NCO - CHARACTER(LEN=9) :: CPART + CHARACTER(LEN=9) :: CPART #endif - CHARACTER(LEN=664) :: BLANK2 !,CSVBLINE - CHARACTER :: STIME*8,FORM*20,FORM1*2 - CHARACTER(LEN=16) :: PART2 -!/ -!/ ------------------------------------------------------------------- / -! + CHARACTER(LEN=664) :: BLANK2 !,CSVBLINE + CHARACTER :: STIME*8,FORM*20,FORM1*2 + CHARACTER(LEN=16) :: PART2 + !/ + !/ ------------------------------------------------------------------- / + ! #ifdef W3_S - CALL STRACE (IENT, 'XXXXXX') + CALL STRACE (IENT, 'XXXXXX') #endif -! -! 1.a Constants etc. -! -! Set FACT to proper scaling according to spherical or cartesian - IF ( FLAGLL ) THEN - FACT = 1. - ELSE - FACT = 1.E-3 - ENDIF -! -! Convert wind direction to azimuthal reference - UDIR = MOD( UD+180., 360. ) -! - TAIL ( 1: 40) = '+-------+-----------+-----------------+-' - TAIL ( 41: 80) = '----------------+-----------------+-----' - TAIL ( 81:120) = '------------+-----------------+---------' - TAIL (120:129) = '---------+' - BLANK( 1: 40) = '| nn nn | nn | | ' - BLANK( 41: 80) = ' | | ' - BLANK( 81:120) = ' | | ' - BLANK(120:129) = ' |' - ASCBLINE = BLANK + ! + ! 1.a Constants etc. + ! + ! Set FACT to proper scaling according to spherical or cartesian + IF ( FLAGLL ) THEN + FACT = 1. + ELSE + FACT = 1.E-3 + ENDIF + ! + ! Convert wind direction to azimuthal reference + UDIR = MOD( UD+180., 360. ) + ! + TAIL ( 1: 40) = '+-------+-----------+-----------------+-' + TAIL ( 41: 80) = '----------------+-----------------+-----' + TAIL ( 81:120) = '------------+-----------------+---------' + TAIL (120:129) = '---------+' + BLANK( 1: 40) = '| nn nn | nn | | ' + BLANK( 41: 80) = ' | | ' + BLANK( 81:120) = ' | | ' + BLANK(120:129) = ' |' + ASCBLINE = BLANK #ifdef W3_NCO - CTAIL( 1:40) = '----------------------------------------' - CTAIL(41:67) = '---------------------------' - CBLANK( 1:40) = ' ' - CBLANK(41:67) = ' ' - CASCBLINE = CBLANK + CTAIL( 1:40) = '----------------------------------------' + CTAIL(41:67) = '---------------------------' + CBLANK( 1:40) = ' ' + CBLANK(41:67) = ' ' + CASCBLINE = CBLANK #endif -! - BLANK2( 1: 40)=' , , , , , , , , ' - BLANK2( 41: 88)=', , , , , , , , , ' - BLANK2( 89:136)=', , , , , , , , , ' - BLANK2(137:184)=', , , , , , , , , ' - BLANK2(185:232)=', , , , , , , , , ' - BLANK2(233:280)=', , , , , , , , , ' - BLANK2(281:328)=', , , , , , , , , ' - BLANK2(329:376)=', , , , , , , , , ' - BLANK2(377:424)=', , , , , , , , , ' - BLANK2(425:472)=', , , , , , , , , ' - BLANK2(473:520)=', , , , , , , , , ' - BLANK2(521:568)=', , , , , , , , , ' - BLANK2(569:616)=', , , , , , , , , ' - BLANK2(617:664)=', , , , , , , , , ' -! - CSVBLINE = BLANK2 -! - IF (IOUT .EQ. 1) THEN - IPG1 = 0 - DO IP=1, NPTAB - HST(IP,1) = -99.9 - TPT(IP,1) = -99.9 - DMT(IP,1) = -99.9 - ENDDO - DO IP=1, NPMAX - IYY(IP) = .FALSE. - IPI(IP)=1 - ILEN(IP)=0 - ENDDO - ENDIF -! -! 3. Get overall wave height ---------------------------------------- * -! - HSTOT = XPART(1,0) - TP = XPART(2,0) - HSP = XPART(1,1:NPART) - TPP = XPART(2,1:NPART) - WNP = TPI / XPART(3,1:NPART) - DMP = MOD( XPART(4,1:NPART) + 180., 360.) - - NZERO = 0 - NZERO = COUNT( HSP <= BHSMIN .AND. HSP /= 0. ) -! -! 4. Process all partial fields ------------------------------------- * -! - DO IP=NPART+1, NPMAX - HSP(IP) = 0.00 - TPP(IP) = -999.99 - DMP(IP) = -999.99 - ENDDO - + ! + BLANK2( 1: 40)=' , , , , , , , , ' + BLANK2( 41: 88)=', , , , , , , , , ' + BLANK2( 89:136)=', , , , , , , , , ' + BLANK2(137:184)=', , , , , , , , , ' + BLANK2(185:232)=', , , , , , , , , ' + BLANK2(233:280)=', , , , , , , , , ' + BLANK2(281:328)=', , , , , , , , , ' + BLANK2(329:376)=', , , , , , , , , ' + BLANK2(377:424)=', , , , , , , , , ' + BLANK2(425:472)=', , , , , , , , , ' + BLANK2(473:520)=', , , , , , , , , ' + BLANK2(521:568)=', , , , , , , , , ' + BLANK2(569:616)=', , , , , , , , , ' + BLANK2(617:664)=', , , , , , , , , ' + ! + CSVBLINE = BLANK2 + ! + IF (IOUT .EQ. 1) THEN + IPG1 = 0 DO IP=1, NPTAB - HST(IP,2) = HST(IP,1) - TPT(IP,2) = TPT(IP,1) - DMT(IP,2) = DMT(IP,1) - HST(IP,1) = -1. - TPT(IP,1) = -1. - DMT(IP,1) = -1. + HST(IP,1) = -99.9 + TPT(IP,1) = -99.9 + DMT(IP,1) = -99.9 ENDDO -! -! 5. Generate output table ------------------------------------------ * -! 5.a Time and overall wave height to string -! - ASCBLINE = BLANK - CSVBLINE = BLANK2 + DO IP=1, NPMAX + IYY(IP) = .FALSE. + IPI(IP)=1 + ILEN(IP)=0 + ENDDO + ENDIF + ! + ! 3. Get overall wave height ---------------------------------------- * + ! + HSTOT = XPART(1,0) + TP = XPART(2,0) + HSP = XPART(1,1:NPART) + TPP = XPART(2,1:NPART) + WNP = TPI / XPART(3,1:NPART) + DMP = MOD( XPART(4,1:NPART) + 180., 360.) + + NZERO = 0 + NZERO = COUNT( HSP <= BHSMIN .AND. HSP /= 0. ) + ! + ! 4. Process all partial fields ------------------------------------- * + ! + DO IP=NPART+1, NPMAX + HSP(IP) = 0.00 + TPP(IP) = -999.99 + DMP(IP) = -999.99 + ENDDO + + DO IP=1, NPTAB + HST(IP,2) = HST(IP,1) + TPT(IP,2) = TPT(IP,1) + DMT(IP,2) = DMT(IP,1) + HST(IP,1) = -1. + TPT(IP,1) = -1. + DMT(IP,1) = -1. + ENDDO + ! + ! 5. Generate output table ------------------------------------------ * + ! 5.a Time and overall wave height to string + ! + ASCBLINE = BLANK + CSVBLINE = BLANK2 #ifdef W3_NCO - CASCBLINE = CBLANK + CASCBLINE = CBLANK #endif -! -! Fill the variable forecast time with hrs relative to reference time - IF ( TIMEV(1) .LE. 0 ) TIMEV = TIME - FCSTI = DSEC21 (TIMEV, TIME) / 3600 - WRITE(CSVBLINE(1:4),'(I4)')FCSTI -! - DO IFLD=1,NPTAB - IYY(IFLD)=.FALSE. - ENDDO -! -! ... write the time labels for current table line - WRITE (CSVBLINE(6:9),'(I4)') INT(TIME(1)/10000) - WRITE (CSVBLINE(11:12),'(I2)') & - INT(TIME(1)/100)-100*INT(TIME(1)/10000) - WRITE (CSVBLINE(14:15),'(I2)') MOD(TIME(1),100) - WRITE (CSVBLINE(17:18),'(I2)') TIME(2)/10000 - WRITE (CSVBLINE(20:24),'(F5.2)') UABS - WRITE (CSVBLINE(26:28),'(I3)') INT(UDIR) - IF ( HSTOT .GT. 0. ) WRITE (CSVBLINE(30:34),'(F5.2)') HSTOT - IF ( HSTOT .GT. 0. ) WRITE (CSVBLINE(36:40),'(F5.2)') TP -! - WRITE (ASCBLINE(3:4),'(I2)') MOD(TIME(1),100) - WRITE (ASCBLINE(6:7),'(I2)') TIME(2)/10000 -! - IF ( HSTOT .GT. 0. ) WRITE (ASCBLINE(10:14),'(F5.2)') HSTOT - WRITE (ASCBLINE(16:17),'(I2)') NPART - NZERO -! + ! + ! Fill the variable forecast time with hrs relative to reference time + IF ( TIMEV(1) .LE. 0 ) TIMEV = TIME + FCSTI = DSEC21 (TIMEV, TIME) / 3600 + WRITE(CSVBLINE(1:4),'(I4)')FCSTI + ! + DO IFLD=1,NPTAB + IYY(IFLD)=.FALSE. + ENDDO + ! + ! ... write the time labels for current table line + WRITE (CSVBLINE(6:9),'(I4)') INT(TIME(1)/10000) + WRITE (CSVBLINE(11:12),'(I2)') & + INT(TIME(1)/100)-100*INT(TIME(1)/10000) + WRITE (CSVBLINE(14:15),'(I2)') MOD(TIME(1),100) + WRITE (CSVBLINE(17:18),'(I2)') TIME(2)/10000 + WRITE (CSVBLINE(20:24),'(F5.2)') UABS + WRITE (CSVBLINE(26:28),'(I3)') INT(UDIR) + IF ( HSTOT .GT. 0. ) WRITE (CSVBLINE(30:34),'(F5.2)') HSTOT + IF ( HSTOT .GT. 0. ) WRITE (CSVBLINE(36:40),'(F5.2)') TP + ! + WRITE (ASCBLINE(3:4),'(I2)') MOD(TIME(1),100) + WRITE (ASCBLINE(6:7),'(I2)') TIME(2)/10000 + ! + IF ( HSTOT .GT. 0. ) WRITE (ASCBLINE(10:14),'(F5.2)') HSTOT + WRITE (ASCBLINE(16:17),'(I2)') NPART - NZERO + ! #ifdef W3_NCO - WRITE (CASCBLINE(1:2),'(I2.2)') MOD(TIME(1),100) - WRITE (CASCBLINE(3:4),'(I2.2)') TIME(2)/10000 - IF ( HSTOT .GT. 0. ) WRITE (CASCBLINE(6:7),'(I2)') NINT(HSTOT/0.3048) + WRITE (CASCBLINE(1:2),'(I2.2)') MOD(TIME(1),100) + WRITE (CASCBLINE(3:4),'(I2.2)') TIME(2)/10000 + IF ( HSTOT .GT. 0. ) WRITE (CASCBLINE(6:7),'(I2)') NINT(HSTOT/0.3048) #endif -! - IF ( NPART.EQ.0 .OR. HSTOT.LT.0.1 ) GOTO 699 -! -! 5.b Switch off peak with too low wave height -! - DO IP=1, NPART - FLAG(IP) = HSP(IP) .GT. BHSMIN - ENDDO -! -! 5.c Find next highest wave height -! - INOTAB = 0 -! - 601 CONTINUE -! - HMAX = 0. - IPNOW = 0 - DO IP=1, NPART - IF ( HSP(IP).GT.HMAX .AND. FLAG(IP) ) THEN - IPNOW = IP - HMAX = HSP(IP) - ENDIF - ENDDO -! -! 5.d No more peaks, skip to output -! - IF ( IPNOW .EQ. 0 ) GOTO 699 -! -! 5.e Find matching field -! - ITAB = 0 -! - DO IP=1, NPTAB - IF ( TPT(IP,2) .GT. 0. ) THEN -! - DELHS = ABS ( HST(IP,2) - HSP(IPNOW) ) - DELTP = ABS ( TPT(IP,2) - TPP(IPNOW) ) - DELDM = ABS ( DMT(IP,2) - DMP(IPNOW) ) - IF ( DELDM .GT. 180. ) DELDM = 360. - DELDM - IF ( DELHS.LT.DHSMAX .AND. & - DELTP.LT.DTPMAX .AND. & - DELDM.LT.DDMMAX ) ITAB = IP -! - ENDIF + ! + IF ( NPART.EQ.0 .OR. HSTOT.LT.0.1 ) GOTO 699 + ! + ! 5.b Switch off peak with too low wave height + ! + DO IP=1, NPART + FLAG(IP) = HSP(IP) .GT. BHSMIN + ENDDO + ! + ! 5.c Find next highest wave height + ! + INOTAB = 0 + ! +601 CONTINUE + ! + HMAX = 0. + IPNOW = 0 + DO IP=1, NPART + IF ( HSP(IP).GT.HMAX .AND. FLAG(IP) ) THEN + IPNOW = IP + HMAX = HSP(IP) + ENDIF + ENDDO + ! + ! 5.d No more peaks, skip to output + ! + IF ( IPNOW .EQ. 0 ) GOTO 699 + ! + ! 5.e Find matching field + ! + ITAB = 0 + ! + DO IP=1, NPTAB + IF ( TPT(IP,2) .GT. 0. ) THEN + ! + DELHS = ABS ( HST(IP,2) - HSP(IPNOW) ) + DELTP = ABS ( TPT(IP,2) - TPP(IPNOW) ) + DELDM = ABS ( DMT(IP,2) - DMP(IPNOW) ) + IF ( DELDM .GT. 180. ) DELDM = 360. - DELDM + IF ( DELHS.LT.DHSMAX .AND. & + DELTP.LT.DTPMAX .AND. & + DELDM.LT.DDMMAX ) ITAB = IP + ! + ENDIF + ENDDO + ! + ! 5.f No matching field, find empty fields + ! + IF ( ITAB .EQ. 0 ) THEN + DO IP=NPTAB, 1, -1 + IF ( TPT(IP,1).LT.0. .AND. TPT(IP,2).LT.0. ) & + ITAB = IP ENDDO -! -! 5.f No matching field, find empty fields -! - IF ( ITAB .EQ. 0 ) THEN - DO IP=NPTAB, 1, -1 - IF ( TPT(IP,1).LT.0. .AND. TPT(IP,2).LT.0. ) & - ITAB = IP - ENDDO - ENDIF -! -! 5.g Slot in table found, write -! -! Remove clear windseas -! - IF ( ITAB .NE. 0 ) THEN -! - WRITE (PART,'(1X,F5.2,F5.1,I4)') & - HSP(IPNOW), TPP(IPNOW), NINT(DMP(IPNOW)) + ENDIF + ! + ! 5.g Slot in table found, write + ! + ! Remove clear windseas + ! + IF ( ITAB .NE. 0 ) THEN + ! + WRITE (PART,'(1X,F5.2,F5.1,I4)') & + HSP(IPNOW), TPP(IPNOW), NINT(DMP(IPNOW)) #ifdef W3_NCO - WRITE (CPART,'(I2,1X,I2.2,1X,I3.3)') & - NINT(HSP(IPNOW)/0.3048), & - NINT(TPP(IPNOW)), & - NINT(MOD(DMP(IPNOW)+180.,360.)) + WRITE (CPART,'(I2,1X,I2.2,1X,I3.3)') & + NINT(HSP(IPNOW)/0.3048), & + NINT(TPP(IPNOW)), & + NINT(MOD(DMP(IPNOW)+180.,360.)) #endif - DELDW = MOD ( ABS ( UDIR - DMP(IPNOW) ) , 360. ) - IF ( DELDW .GT. 180. ) DELDW = 360. - DELDW - AFR = 2.*PI/TPP(IPNOW) - AGE = UABS * WNP(IPNOW) / AFR - IF ( DELDW.LT.DDWMAX .AND. AGE.GT.AGEMIN ) PART(1:1) = '*' -! - ASCBLINE(5+ITAB*18:19+ITAB*18) = PART + DELDW = MOD ( ABS ( UDIR - DMP(IPNOW) ) , 360. ) + IF ( DELDW .GT. 180. ) DELDW = 360. - DELDW + AFR = 2.*PI/TPP(IPNOW) + AGE = UABS * WNP(IPNOW) / AFR + IF ( DELDW.LT.DDWMAX .AND. AGE.GT.AGEMIN ) PART(1:1) = '*' + ! + ASCBLINE(5+ITAB*18:19+ITAB*18) = PART #ifdef W3_NCO - CASCBLINE(ITAB*10-1:ITAB*10+7) = CPART + CASCBLINE(ITAB*10-1:ITAB*10+7) = CPART #endif -! - DO IFLD=1,NPTAB - IF(ITAB.EQ.IFLD)THEN - IYY(IFLD)=.TRUE. - HSD(IFLD)=HSP(IPNOW) - TPD(IFLD)=TPP(IPNOW) - WDD(IFLD)=NINT(DMP(IPNOW)) - ENDIF - ENDDO -! - HST(ITAB,1) = HSP(IPNOW) - TPT(ITAB,1) = TPP(IPNOW) - DMT(ITAB,1) = DMP(IPNOW) - -! -! 5.h No slot in table found, write -! - ELSE -! - INOTAB = INOTAB + 1 - WRITE (ASCBLINE(19:19),'(I1)') INOTAB -! - ENDIF -! - FLAG(IPNOW) = .FALSE. - GOTO 601 -! -! 5.i End of processing, write line in table -! - 699 CONTINUE -! + ! DO IFLD=1,NPTAB - IF(IYY(IFLD))THEN - ILEN(IFLD)=ILEN(IFLD)+1 - IF (ILEN(IFLD).EQ.1)THEN - IPI(IFLD)=IPG1+1 - IPG1=IPG1+1 - ENDIF - WRITE (PART2,'(",",F5.2,",",F5.2,",",I3)') & - HSD(IFLD), TPD(IFLD), NINT(WDD(IFLD)) - CSVBLINE(25+IPI(IFLD)*16:40+IPI(IFLD)*16) = PART2 - ELSE - ILEN(IFLD)=0 - ENDIF + IF(ITAB.EQ.IFLD)THEN + IYY(IFLD)=.TRUE. + HSD(IFLD)=HSP(IPNOW) + TPD(IFLD)=TPP(IPNOW) + WDD(IFLD)=NINT(DMP(IPNOW)) + ENDIF ENDDO -! - RETURN -!/ -!/ End of W3BULL ----------------------------------------------------- / -!/ - END SUBROUTINE W3BULL -!/ -!/ End of module W3BULLMD -------------------------------------------- / -!/ - END MODULE W3BULLMD + ! + HST(ITAB,1) = HSP(IPNOW) + TPT(ITAB,1) = TPP(IPNOW) + DMT(ITAB,1) = DMP(IPNOW) + ! + ! 5.h No slot in table found, write + ! + ELSE + ! + INOTAB = INOTAB + 1 + WRITE (ASCBLINE(19:19),'(I1)') INOTAB + ! + ENDIF + ! + FLAG(IPNOW) = .FALSE. + GOTO 601 + ! + ! 5.i End of processing, write line in table + ! +699 CONTINUE + ! + DO IFLD=1,NPTAB + IF(IYY(IFLD))THEN + ILEN(IFLD)=ILEN(IFLD)+1 + IF (ILEN(IFLD).EQ.1)THEN + IPI(IFLD)=IPG1+1 + IPG1=IPG1+1 + ENDIF + WRITE (PART2,'(",",F5.2,",",F5.2,",",I3)') & + HSD(IFLD), TPD(IFLD), NINT(WDD(IFLD)) + CSVBLINE(25+IPI(IFLD)*16:40+IPI(IFLD)*16) = PART2 + ELSE + ILEN(IFLD)=0 + ENDIF + ENDDO + ! + RETURN + !/ + !/ End of W3BULL ----------------------------------------------------- / + !/ + END SUBROUTINE W3BULL + !/ + !/ End of module W3BULLMD -------------------------------------------- / + !/ +END MODULE W3BULLMD diff --git a/model/src/w3canomd.F90 b/model/src/w3canomd.F90 index c7594b655..de287eb85 100644 --- a/model/src/w3canomd.F90 +++ b/model/src/w3canomd.F90 @@ -1,2484 +1,2484 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3CANOMD -!/ -!/ +-----------------------------------+ -!/ | | -!/ | P.A.E.M. Janssen | -!/ | FORTRAN 90 | -!/ | Last update : 21-Aug-2014 | -!/ +-----------------------------------+ -!/ -!/ XX-Jul-2010 : Origination by PAEM JANSSEN -!/ 18-Oct-2012 : Adapted to WAVEWATCH III: F. Ardhuin( version 4.07 ) -!/ 21-Aug-2014 : Bug corrected: only first call wasOK( version 5.01 ) -!/ -! 0. Note by F. Ardhuin: -! In adapting the orginal program to be a WAVEWATCH module, I -! have so far strived to keep the original code. As a result -! some routines are unnecessarily duplicated (e.g. the calculation of -! the group velocity ...). But this can improve the traceability of -! the code. -! The first spectrum (JONSWAP) has been removed from the code -! -! 1. Purpose : -! -! -! CALCULATION OF THE SECOND ORDER CORRECTION TO THE SURFACE GRAVITY -! WAVE SPECTRUM -! -! DOCUMENTATION. -! ------------- -! -! PRESENTLY, THE SOFTWARE IS SET UP TO DO FOR A GIVING FIRST-ORDER -! SPECTRUM AT A GIVEN DEPTH THE DETERMINATION OF THE SECOND ORDER -! CORRECTION (INCLUDING SECOND-HARMONICS, WAVE SET DOWN AND DOPPLER SHIFT -! OWING TO THE STOKES FREQUENCY CORRECTION. -! -! EVALUATION OF THE INTERACTION COEFFICIENTS FOR ARBRITRARY DEPTH WOULD -! BE VERY TIME CONSUMING. THEREFORE, THE APPROACH IN THE WAM MODEL IS -! FOLLOWED, WHERE TABLES ARE GENERATED FOR A LOGARITHMIC DEPTH TABLE -! -! D(JD) = DEPTHA*DEPTHD**(JD-1) -! -! WITH JD AN INTEGER. IN THE PRESENT OPERATIONAL VERSION OF ECWAM JD -! RANGES FROM 1 TO NDEPTH = 74, WHILE DEPTHA = 1. AND DEPTHD = 1.1 -! -! FINALLY, THIS IS A VERY TIME-CONSUMING CALCULATION, AT LEAST FOR AN -! OPERATIONAL MODEL. i HAVE THEREFORE INTRODUCED THE OPTION THAT THE SECOND-ORDER -! SPECTRUM IS CALCULATED ON A LOWER RESOLUTION GRID (TYPICALLY HALF THE -! RESOLUTION) WHILE THE INFORMATION CONTAINED IN THE FIRST-ORDER SPECTRUM -! IS KEPT ON THE ORIGINAL SPECTRAL GRID. -! -! ---------------------------------------------------------------------- -! -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SREF Subr. Public Reflection of waves (shorline, islands...) -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! -!/ -!/ Public variables -!/ - - REAL :: G, PI, ZPI, RAD, DEG - INTEGER :: NDEPTH - REAL :: DEPTHA ! first depth in table - REAL, SAVE , PRIVATE, ALLOCATABLE :: OMEGA(:) +MODULE W3CANOMD + !/ + !/ +-----------------------------------+ + !/ | | + !/ | P.A.E.M. Janssen | + !/ | FORTRAN 90 | + !/ | Last update : 21-Aug-2014 | + !/ +-----------------------------------+ + !/ + !/ XX-Jul-2010 : Origination by PAEM JANSSEN + !/ 18-Oct-2012 : Adapted to WAVEWATCH III: F. Ardhuin( version 4.07 ) + !/ 21-Aug-2014 : Bug corrected: only first call wasOK( version 5.01 ) + !/ + ! 0. Note by F. Ardhuin: + ! In adapting the orginal program to be a WAVEWATCH module, I + ! have so far strived to keep the original code. As a result + ! some routines are unnecessarily duplicated (e.g. the calculation of + ! the group velocity ...). But this can improve the traceability of + ! the code. + ! The first spectrum (JONSWAP) has been removed from the code + ! + ! 1. Purpose : + ! + ! + ! CALCULATION OF THE SECOND ORDER CORRECTION TO THE SURFACE GRAVITY + ! WAVE SPECTRUM + ! + ! DOCUMENTATION. + ! ------------- + ! + ! PRESENTLY, THE SOFTWARE IS SET UP TO DO FOR A GIVING FIRST-ORDER + ! SPECTRUM AT A GIVEN DEPTH THE DETERMINATION OF THE SECOND ORDER + ! CORRECTION (INCLUDING SECOND-HARMONICS, WAVE SET DOWN AND DOPPLER SHIFT + ! OWING TO THE STOKES FREQUENCY CORRECTION. + ! + ! EVALUATION OF THE INTERACTION COEFFICIENTS FOR ARBRITRARY DEPTH WOULD + ! BE VERY TIME CONSUMING. THEREFORE, THE APPROACH IN THE WAM MODEL IS + ! FOLLOWED, WHERE TABLES ARE GENERATED FOR A LOGARITHMIC DEPTH TABLE + ! + ! D(JD) = DEPTHA*DEPTHD**(JD-1) + ! + ! WITH JD AN INTEGER. IN THE PRESENT OPERATIONAL VERSION OF ECWAM JD + ! RANGES FROM 1 TO NDEPTH = 74, WHILE DEPTHA = 1. AND DEPTHD = 1.1 + ! + ! FINALLY, THIS IS A VERY TIME-CONSUMING CALCULATION, AT LEAST FOR AN + ! OPERATIONAL MODEL. i HAVE THEREFORE INTRODUCED THE OPTION THAT THE SECOND-ORDER + ! SPECTRUM IS CALCULATED ON A LOWER RESOLUTION GRID (TYPICALLY HALF THE + ! RESOLUTION) WHILE THE INFORMATION CONTAINED IN THE FIRST-ORDER SPECTRUM + ! IS KEPT ON THE ORIGINAL SPECTRAL GRID. + ! + ! ---------------------------------------------------------------------- + ! + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SREF Subr. Public Reflection of waves (shorline, islands...) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + !/ + !/ Public variables + !/ + + REAL :: G, PI, ZPI, RAD, DEG + INTEGER :: NDEPTH + REAL :: DEPTHA ! first depth in table + REAL, SAVE , PRIVATE, ALLOCATABLE :: OMEGA(:) #ifdef W3_OMPG -!$omp threadprivate( OMEGA ) + !$omp threadprivate( OMEGA ) #endif - INTEGER, SAVE , PRIVATE :: COUNTER = 0 + INTEGER, SAVE , PRIVATE :: COUNTER = 0 #ifdef W3_OMPG -!$omp threadprivate( COUNTER ) + !$omp threadprivate( COUNTER ) #endif -! Tables for non-linear coefficients ... - REAL, SAVE , PRIVATE, ALLOCATABLE :: TA(:,:,:,:),TB(:,:,:,:),TC_QL(:,:,:,:),& - TT_4M(:,:,:,:),TT_4P(:,:,:,:),TFAKH(:,:), & - TFAK(:,:) + ! Tables for non-linear coefficients ... + REAL, SAVE , PRIVATE, ALLOCATABLE :: TA(:,:,:,:),TB(:,:,:,:),TC_QL(:,:,:,:),& + TT_4M(:,:,:,:),TT_4P(:,:,:,:),TFAKH(:,:), & + TFAK(:,:) #ifdef W3_OMPG -!$omp threadprivate( TA, TB, TC_QL, TT_4M, TT_4P, TFAKH, TFAK ) + !$omp threadprivate( TA, TB, TC_QL, TT_4M, TT_4P, TFAKH, TFAK ) #endif - INTEGER, SAVE, PRIVATE, ALLOCATABLE :: IM_P(:,:),IM_M(:,:) + INTEGER, SAVE, PRIVATE, ALLOCATABLE :: IM_P(:,:),IM_M(:,:) #ifdef W3_OMPG -!$omp threadprivate( IM_P, IM_M ) + !$omp threadprivate( IM_P, IM_M ) #endif -! -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3ADD2NDORDER(E,DEPTH,WN,CG,IACTION) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 19-Oct-2012 | -!/ +-----------------------------------+ -!/ -!/ 19-Oct-2012 : Origination ( version 4.08 ) -!/ -! 1. Purpose : -! -! Adds second order spectrum on top of first order spectrum -! -! 2. Method : -! -! Uses P. Janssen's code for the inverse canonical transform -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! DEPTH Real I Mean water depth. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! E R.A. I/O Energy density spectrum (1-D), f-theta -! DEPTH Real I Water depth -! WN R.A. wavenumbers -! CG R.A. group velocities -! IACTION Int I Switch to specify if the input spectrum -! is E(f,theta) or A(k,theta) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SREF Subr. W3REF1MD Shoreline reflection source term -! W3EXPO Subr. N/A Point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV - USE W3DISPMD - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, DTH, IGPARS + ! + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3ADD2NDORDER(E,DEPTH,WN,CG,IACTION) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 19-Oct-2012 | + !/ +-----------------------------------+ + !/ + !/ 19-Oct-2012 : Origination ( version 4.08 ) + !/ + ! 1. Purpose : + ! + ! Adds second order spectrum on top of first order spectrum + ! + ! 2. Method : + ! + ! Uses P. Janssen's code for the inverse canonical transform + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! DEPTH Real I Mean water depth. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! E R.A. I/O Energy density spectrum (1-D), f-theta + ! DEPTH Real I Water depth + ! WN R.A. wavenumbers + ! CG R.A. group velocities + ! IACTION Int I Switch to specify if the input spectrum + ! is E(f,theta) or A(k,theta) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SREF Subr. W3REF1MD Shoreline reflection source term + ! W3EXPO Subr. N/A Point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV + USE W3DISPMD + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, DTH, IGPARS #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(INOUT) :: E(NSPEC) - REAL, INTENT(IN) :: DEPTH - REAL, INTENT(IN) :: WN(NK) - REAL, INTENT(IN) :: CG(NK) - INTEGER, INTENT(IN) :: IACTION -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISPEC, IK, ITH, M - REAL :: CO1, ATOE, DPTH + !/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(INOUT) :: E(NSPEC) + REAL, INTENT(IN) :: DEPTH + REAL, INTENT(IN) :: WN(NK) + REAL, INTENT(IN) :: CG(NK) + INTEGER, INTENT(IN) :: IACTION + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISPEC, IK, ITH, M + REAL :: CO1, ATOE, DPTH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: FIRST = .TRUE. #ifdef W3_OMPG -!$omp threadprivate( FIRST ) + !$omp threadprivate( FIRST ) #endif - REAL, ALLOCATABLE, SAVE :: FR(:), DFIM(:) - REAL, ALLOCATABLE, SAVE :: F1(:,:), F3(:,:) + REAL, ALLOCATABLE, SAVE :: FR(:), DFIM(:) + REAL, ALLOCATABLE, SAVE :: F1(:,:), F3(:,:) #ifdef W3_OMPG -!$omp threadprivate( FR, DFIM, F1, F3 ) + !$omp threadprivate( FR, DFIM, F1, F3 ) #endif - INTEGER, SAVE :: NFRE, NANG - INTEGER, SAVE :: NFREH, NANGH + INTEGER, SAVE :: NFRE, NANG + INTEGER, SAVE :: NFREH, NANGH #ifdef W3_OMPG -!$omp threadprivate( NFRE, NANG, NFREH, NANGH ) + !$omp threadprivate( NFRE, NANG, NFREH, NANGH ) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3ADD2NDORDER') + CALL STRACE (IENT, 'W3ADD2NDORDER') #endif -! -! 0. Initializations ------------------------------------------------ * -! - IF (FIRST) THEN - FIRST=.FALSE. - NFRE=NK - NANG=NTH - NFREH=NK - NANGH=NTH - G=GRAV - PI = 4.*ATAN(1.) - ZPI=2*PI - RAD = PI/180. - DEG = 180./PI - ALLOCATE(FR(NFRE), DFIM(NFRE)) - FR(1:NFRE)=SIG(1:NK)/ZPI -! The following can be replaced using DSIP from WWATCH - CO1 = 0.5*DTH - DFIM(1)= CO1*(FR(2)-FR(1)) - DO M=2,NFRE-1 - DFIM(M)=CO1*(FR(M+1)-FR(M-1)) - ENDDO - DFIM(NFRE)=CO1*(FR(NFRE)-FR(NFRE-1)) -! - ALLOCATE(F1(NANG,NFRE), F3(NANG,NFRE)) - NDEPTH=IGPARS(6) - DEPTHA=IGPARS(7) + ! + ! 0. Initializations ------------------------------------------------ * + ! + IF (FIRST) THEN + FIRST=.FALSE. + NFRE=NK + NANG=NTH + NFREH=NK + NANGH=NTH + G=GRAV + PI = 4.*ATAN(1.) + ZPI=2*PI + RAD = PI/180. + DEG = 180./PI + ALLOCATE(FR(NFRE), DFIM(NFRE)) + FR(1:NFRE)=SIG(1:NK)/ZPI + ! The following can be replaced using DSIP from WWATCH + CO1 = 0.5*DTH + DFIM(1)= CO1*(FR(2)-FR(1)) + DO M=2,NFRE-1 + DFIM(M)=CO1*(FR(M+1)-FR(M-1)) + ENDDO + DFIM(NFRE)=CO1*(FR(NFRE)-FR(NFRE-1)) + ! + ALLOCATE(F1(NANG,NFRE), F3(NANG,NFRE)) + NDEPTH=IGPARS(6) + DEPTHA=IGPARS(7) + END IF + DPTH = DEPTH + + DO IK=1,NK + IF (IACTION.EQ.0) THEN + ATOE=1 + ELSE + ATOE=SIG(IK)*ZPI / CG(IK) + END IF + DO ITH=1,NTH + ISPEC=ITH+(IK-1)*NTH + F1(ITH,IK)=E(ISPEC)*ATOE + END DO + !WRITE(100,'(100G16.8)') SIG(IK)*ZPI,(F1(ITH,IK),ITH=1,NTH) + + END DO + ! + ! 1. DETERMINE SECOND-ORDER SPECTRUM. + ! + + CALL CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH, & + DTH,DPTH,+1., NFREH, NANGH) + + ! + ! 2. Adds 2nd order spectrum to 1st order + ! + DO IK=1,NK + IF (IACTION.EQ.0) THEN + ATOE=1 + ELSE + ATOE=SIG(IK)*ZPI / CG(IK) END IF - DPTH = DEPTH - - DO IK=1,NK - IF (IACTION.EQ.0) THEN - ATOE=1 - ELSE - ATOE=SIG(IK)*ZPI / CG(IK) - END IF - DO ITH=1,NTH - ISPEC=ITH+(IK-1)*NTH - F1(ITH,IK)=E(ISPEC)*ATOE - END DO - !WRITE(100,'(100G16.8)') SIG(IK)*ZPI,(F1(ITH,IK),ITH=1,NTH) - - END DO -! -! 1. DETERMINE SECOND-ORDER SPECTRUM. -! - - CALL CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH, & - DTH,DPTH,+1., NFREH, NANGH) - -! -! 2. Adds 2nd order spectrum to 1st order -! - DO IK=1,NK - IF (IACTION.EQ.0) THEN - ATOE=1 - ELSE - ATOE=SIG(IK)*ZPI / CG(IK) - END IF - DO ITH=1,NTH - ISPEC=ITH+(IK-1)*NTH - E(ISPEC)=F3(ITH,IK)/ATOE - END DO - !WRITE(101,'(I3,100G16.8)') SIG(IK)*ZPI,(F3(ITH,IK),ITH=1,NTH) - END DO - + DO ITH=1,NTH + ISPEC=ITH+(IK-1)*NTH + E(ISPEC)=F3(ITH,IK)/ATOE + END DO + !WRITE(101,'(I3,100G16.8)') SIG(IK)*ZPI,(F3(ITH,IK),ITH=1,NTH) + END DO + #ifdef W3_T - PRINT*,' END CAL_SEC_ORDER_SPEC' + PRINT*,' END CAL_SEC_ORDER_SPEC' #endif - RETURN - - END SUBROUTINE W3ADD2NDORDER -!/ ------------------------------------------------------------------- / - -!----------------------------------------------------------------------- -! - SUBROUTINE CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH,DELTH, & - DPTH,SIGM, NFREH, NANGH) -! -!*** *CAL_SEC_ORDER_SPEC* DETERMINES SECOND_ORDER SPECTRUM -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! DETERMINATION OF SECOND-ORDER SPECTRUM -! -! INTERFACE. -! ---------- -! *CALL* *CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR, -! DFIM,TH,DELTH,DPTH,SIGM)* -! -! INPUT: -! *F1* - 2-D FREE WAVE SPECTRUM -! *NFRE* - NUMBER OF FREQUENCIES -! *NANG* - NUMBER OF DIRECTIONS -! *FR* - FREQUENCIES -! *DFIM* - FREQUENCY INCREMENT -! *TH* - DIRECTIONAL ARRAY -! *DELTH* - DIRECTIONAL INCREMENT -! *DPTH* - DEPTH ARRAY -! *SIGM* - FOR SIGM = 1 FORWARD MAPPING -! WHILE FOR SIGM = -1 INVERSE -! MAPPING. -! -! OUTPUT: -! *F3* - 2-D SPECTRUM INCLUDING SECOND-ORDER -! CORRECTION -! -! METHOD. -! ------- -! IS DESCRIBED IN JANSSEN (2009), JFM, 637, 1-44. -! -! EXTERNALS. -! ---------- -! NONE -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - - REAL, INTENT(IN) :: F1(NANG,NFRE) - REAL, INTENT(OUT) :: F3(NANG,NFRE) - - INTEGER, INTENT(IN) :: NFRE,NANG,NFREH, NANGH - - REAL, INTENT(IN) :: DFIM(NFRE),FR(NFRE), TH(NANG), DELTH - REAL, INTENT(IN) :: DPTH, SIGM - - LOGICAL FRSTIME,DOUBLEP - - INTEGER MDW,M,K, K0,M0,MP,KP,MM,KM,KL,KLL,ML,JD - INTEGER, SAVE :: MR, MA,NMAX + RETURN + + END SUBROUTINE W3ADD2NDORDER + !/ ------------------------------------------------------------------- / + + !----------------------------------------------------------------------- + ! + SUBROUTINE CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH,DELTH, & + DPTH,SIGM, NFREH, NANGH) + ! + !*** *CAL_SEC_ORDER_SPEC* DETERMINES SECOND_ORDER SPECTRUM + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! DETERMINATION OF SECOND-ORDER SPECTRUM + ! + ! INTERFACE. + ! ---------- + ! *CALL* *CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR, + ! DFIM,TH,DELTH,DPTH,SIGM)* + ! + ! INPUT: + ! *F1* - 2-D FREE WAVE SPECTRUM + ! *NFRE* - NUMBER OF FREQUENCIES + ! *NANG* - NUMBER OF DIRECTIONS + ! *FR* - FREQUENCIES + ! *DFIM* - FREQUENCY INCREMENT + ! *TH* - DIRECTIONAL ARRAY + ! *DELTH* - DIRECTIONAL INCREMENT + ! *DPTH* - DEPTH ARRAY + ! *SIGM* - FOR SIGM = 1 FORWARD MAPPING + ! WHILE FOR SIGM = -1 INVERSE + ! MAPPING. + ! + ! OUTPUT: + ! *F3* - 2-D SPECTRUM INCLUDING SECOND-ORDER + ! CORRECTION + ! + ! METHOD. + ! ------- + ! IS DESCRIBED IN JANSSEN (2009), JFM, 637, 1-44. + ! + ! EXTERNALS. + ! ---------- + ! NONE + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + + REAL, INTENT(IN) :: F1(NANG,NFRE) + REAL, INTENT(OUT) :: F3(NANG,NFRE) + + INTEGER, INTENT(IN) :: NFRE,NANG,NFREH, NANGH + + REAL, INTENT(IN) :: DFIM(NFRE),FR(NFRE), TH(NANG), DELTH + REAL, INTENT(IN) :: DPTH, SIGM + + LOGICAL FRSTIME,DOUBLEP + + INTEGER MDW,M,K, K0,M0,MP,KP,MM,KM,KL,KLL,ML,JD + INTEGER, SAVE :: MR, MA,NMAX #ifdef W3_OMPG -!$omp threadprivate( MR, MA, NMAX ) + !$omp threadprivate( MR, MA, NMAX ) #endif -! PARAMETER (NFREH=32,NANGH=36) + ! PARAMETER (NFREH=32,NANGH=36) - INTEGER, SAVE :: INDEP + INTEGER, SAVE :: INDEP #ifdef W3_OMPG -!$omp threadprivate( INDEP ) + !$omp threadprivate( INDEP ) #endif - REAL,ALLOCATABLE :: PF1(:,:),PF3(:,:) + REAL,ALLOCATABLE :: PF1(:,:),PF3(:,:) - REAL DEPTH,ALPHA,GAM_J,DEPTHD - REAL OM0,AA1,BB1,& - F,EPSMIN,DELFF,SPEC1,SQRTK - REAL FRAC,DEL,DELF,D1,D2,D3,D4,C1,& - C2,XM,XK - REAL, SAVE :: OMSTART - REAL, SAVE :: XMR,XMA, DELTHH, CO1 + REAL DEPTH,ALPHA,GAM_J,DEPTHD + REAL OM0,AA1,BB1,& + F,EPSMIN,DELFF,SPEC1,SQRTK + REAL FRAC,DEL,DELF,D1,D2,D3,D4,C1,& + C2,XM,XK + REAL, SAVE :: OMSTART + REAL, SAVE :: XMR,XMA, DELTHH, CO1 #ifdef W3_OMPG -!$omp threadprivate( OMSTART, XMR,XMA, DELTHH, CO1 ) + !$omp threadprivate( OMSTART, XMR,XMA, DELTHH, CO1 ) #endif - REAL :: F13(NFREH,NANGH) - REAL :: SUM0,AKMEAN - REAL :: DELOM(NFREH),THH(NANGH),DFDTH(NFREH) - - DATA FRSTIME/.TRUE./ + REAL :: F13(NFREH,NANGH) + REAL :: SUM0,AKMEAN + REAL :: DELOM(NFREH),THH(NANGH),DFDTH(NFREH) + + DATA FRSTIME/.TRUE./ - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - COMMON/PRECIS/DOUBLEP + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + COMMON/PRECIS/DOUBLEP -! -!*** 2. DETERMINE SECOND ORDER CORRECTION TO THE SPECTRUM -! ---------------------------------------------------- + ! + !*** 2. DETERMINE SECOND ORDER CORRECTION TO THE SPECTRUM + ! ---------------------------------------------------- -! + ! #ifdef W3_T - PRINT*,' START SECOND-ORDER CALC.' + PRINT*,' START SECOND-ORDER CALC.' #endif - DOUBLEP = .TRUE. -! -!*** 2.1 SET UP OF LOW-RESOLUTION CALCULATION GRID. -! --------------------------------------------- -! - EPSMIN = 1.0E-4 - FRAC = 0.1 - OMSTART = ZPI*FR(1) - MR = MAX(1,NFRE/NFREH) - XMR = 1./FLOAT(MR) - MA = NANG/NANGH - XMA = 1./FLOAT(MA) - DELTHH = FLOAT(MA)*DELTH - - IF (FRSTIME) THEN - ! IF (COUNTER.GT.0) THEN - ! DEALLOCATE(OMEGA,TFAK,TA,TB,TC_QL,TT_4M,TT_4P,IM_P,IM_M,TFAKH) - ! ENDIF - ALLOCATE(OMEGA(NFREH)) - ALLOCATE(TFAK(NFRE,NDEPTH)) - ALLOCATE(TA(NANGH,NFREH,NFREH,NDEPTH)) - ALLOCATE(TB(NANGH,NFREH,NFREH,NDEPTH)) - ALLOCATE(TC_QL(NANGH,NFREH,NFREH,NDEPTH)) - ALLOCATE(TT_4M(NANGH,NFREH,NFREH,NDEPTH)) - ALLOCATE(TT_4P(NANGH,NFREH,NFREH,NDEPTH)) - ALLOCATE(IM_P(NFREH,NFREH)) - ALLOCATE(IM_M(NFREH,NFREH)) - ALLOCATE(TFAKH(NFREH,NDEPTH)) - - DO M=1,NFREH - OMEGA(M) = ZPI*FR(MR*M) - ENDDO + DOUBLEP = .TRUE. + ! + !*** 2.1 SET UP OF LOW-RESOLUTION CALCULATION GRID. + ! --------------------------------------------- + ! + EPSMIN = 1.0E-4 + FRAC = 0.1 + OMSTART = ZPI*FR(1) + MR = MAX(1,NFRE/NFREH) + XMR = 1./FLOAT(MR) + MA = NANG/NANGH + XMA = 1./FLOAT(MA) + DELTHH = FLOAT(MA)*DELTH + + IF (FRSTIME) THEN + ! IF (COUNTER.GT.0) THEN + ! DEALLOCATE(OMEGA,TFAK,TA,TB,TC_QL,TT_4M,TT_4P,IM_P,IM_M,TFAKH) + ! ENDIF + ALLOCATE(OMEGA(NFREH)) + ALLOCATE(TFAK(NFRE,NDEPTH)) + ALLOCATE(TA(NANGH,NFREH,NFREH,NDEPTH)) + ALLOCATE(TB(NANGH,NFREH,NFREH,NDEPTH)) + ALLOCATE(TC_QL(NANGH,NFREH,NFREH,NDEPTH)) + ALLOCATE(TT_4M(NANGH,NFREH,NFREH,NDEPTH)) + ALLOCATE(TT_4P(NANGH,NFREH,NFREH,NDEPTH)) + ALLOCATE(IM_P(NFREH,NFREH)) + ALLOCATE(IM_M(NFREH,NFREH)) + ALLOCATE(TFAKH(NFREH,NDEPTH)) + + DO M=1,NFREH + OMEGA(M) = ZPI*FR(MR*M) + ENDDO - DO K=1,NANGH - K0 = MA*K+1 - IF (K0.GT.NANG) K0 = K0-NANG - THH(K) = TH(K0) - ENDDO + DO K=1,NANGH + K0 = MA*K+1 + IF (K0.GT.NANG) K0 = K0-NANG + THH(K) = TH(K0) + ENDDO - CO1 = 1./2.*DELTHH - DELOM(1) = CO1*(OMEGA(2)-OMEGA(1)) - DO M=2,NFREH-1 - DELOM(M)=CO1*(OMEGA(M+1)-OMEGA(M-1)) - ENDDO - DELOM(NFREH)=CO1*(OMEGA(NFREH)-OMEGA(NFREH-1)) -! - DFDTH = DELOM/ZPI -! -!*** 2.2 INITIALISE TABLES -! --------------------- -! - NMAX = XMR*(1+NINT(LOG(2.*OMEGA(NFREH)/OMSTART)/LOG(1.+FRAC))) - NMAX = NMAX+1 + CO1 = 1./2.*DELTHH + DELOM(1) = CO1*(OMEGA(2)-OMEGA(1)) + DO M=2,NFREH-1 + DELOM(M)=CO1*(OMEGA(M+1)-OMEGA(M-1)) + ENDDO + DELOM(NFREH)=CO1*(OMEGA(NFREH)-OMEGA(NFREH-1)) + ! + DFDTH = DELOM/ZPI + ! + !*** 2.2 INITIALISE TABLES + ! --------------------- + ! + NMAX = XMR*(1+NINT(LOG(2.*OMEGA(NFREH)/OMSTART)/LOG(1.+FRAC))) + NMAX = NMAX+1 #ifdef W3_T PRINT*,' NMAX = ',NMAX #endif - DEPTHD = 1.1 - - DO JD=1,NDEPTH - DEPTH = DEPTHA*DEPTHD**(JD-1) - DO M=1,NFRE - OM0 = ZPI*FR(M) - TFAK(M,JD) = AKI(OM0,DEPTH) - ENDDO + DEPTHD = 1.1 + + DO JD=1,NDEPTH + DEPTH = DEPTHA*DEPTHD**(JD-1) + DO M=1,NFRE + OM0 = ZPI*FR(M) + TFAK(M,JD) = AKI(OM0,DEPTH) ENDDO + ENDDO + + INDEP = 1+NINT(LOG(DPTH/DEPTHA)/LOG(DEPTHD)) + INDEP = MIN(NDEPTH,INDEP) + INDEP = MAX(1,INDEP) + + CALL TABLES_2ND(NFREH,NANGH,NDEPTH,DEPTHA,OMSTART,FRAC,XMR,& + DFDTH,OMEGA,THH) + PRINT*, '2ND ORDER TABLES GENERATED:',NDEPTH,DEPTHA, DELTHH + + FRSTIME = .FALSE. + ENDIF ! end of test on FRSTIME + ! + COUNTER=COUNTER+1 + ! + !*** DETERMINE SOME MOMENTS. + ! ---------------------- + ! + SUM0 = 0. + AKMEAN = 0. + DO M=1,NFRE + DO K=1,NANG + SQRTK=SQRT(TFAK(M,INDEP)) + SUM0 = SUM0+F1(K,M)*DFIM(M) + AKMEAN = AKMEAN+F1(K,M)*DFIM(M)/SQRTK + ENDDO + ENDDO + ! + ! NB: AKMEAN is the mean wavenumber corresponding to Tm0,-1 in deep water + ! + AKMEAN = (SUM0/AKMEAN)**2 + + ! + !*** 2.2 INTERPOLATION OR NOT. + ! ------------------------ + ! + IF (MR.EQ.1 .AND. MA.EQ.1) THEN + ! + !*** 2.21 NO INTERPOLATION. + ! ---------------------- + ! +#ifdef W3_T + PRINT*,' NO THINNING AND INTERPOLATION' + PRINT*,'nanG:',NANG,NMAX,NFRE,NDEPTH,DEPTHA,DEPTHD,DPTH,'##',DELTH,DELTHH +#endif - INDEP = 1+NINT(LOG(DPTH/DEPTHA)/LOG(DEPTHD)) - INDEP = MIN(NDEPTH,INDEP) - INDEP = MAX(1,INDEP) - - CALL TABLES_2ND(NFREH,NANGH,NDEPTH,DEPTHA,OMSTART,FRAC,XMR,& - DFDTH,OMEGA,THH) - PRINT*, '2ND ORDER TABLES GENERATED:',NDEPTH,DEPTHA, DELTHH - - FRSTIME = .FALSE. - ENDIF ! end of test on FRSTIME -! - COUNTER=COUNTER+1 -! -!*** DETERMINE SOME MOMENTS. -! ---------------------- -! - SUM0 = 0. - AKMEAN = 0. + CALL SECSPOM(F1,F3,NFRE,NANG,NMAX,NDEPTH,& + DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,& + DPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P,& + IM_P,IM_M,COUNTER) DO M=1,NFRE DO K=1,NANG - SQRTK=SQRT(TFAK(M,INDEP)) - SUM0 = SUM0+F1(K,M)*DFIM(M) - AKMEAN = AKMEAN+F1(K,M)*DFIM(M)/SQRTK + DELF = F3(K,M) + F3(K,M)=MAX(0.00000001,F1(K,M)+SIGM*DELF) ENDDO ENDDO -! -! NB: AKMEAN is the mean wavenumber corresponding to Tm0,-1 in deep water -! - AKMEAN = (SUM0/AKMEAN)**2 - -! -!*** 2.2 INTERPOLATION OR NOT. -! ------------------------ -! - IF (MR.EQ.1 .AND. MA.EQ.1) THEN -! -!*** 2.21 NO INTERPOLATION. -! ---------------------- -! -#ifdef W3_T - PRINT*,' NO THINNING AND INTERPOLATION' - PRINT*,'nanG:',NANG,NMAX,NFRE,NDEPTH,DEPTHA,DEPTHD,DPTH,'##',DELTH,DELTHH -#endif - CALL SECSPOM(F1,F3,NFRE,NANG,NMAX,NDEPTH,& - DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,& - DPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P,& - IM_P,IM_M,COUNTER) - DO M=1,NFRE - DO K=1,NANG - DELF = F3(K,M) - F3(K,M)=MAX(0.00000001,F1(K,M)+SIGM*DELF) - ENDDO - ENDDO + ELSE - ELSE + ! + !*** 2.22 ENERGY CONSERVING INTERPOLATION SCHEME + ! ------------------------------------------- + ! + PRINT*,' !THINNING AND INTERPOLATION!' + ALLOCATE(PF1(NANGH,NFREH)) + ALLOCATE(PF3(NANGH,NFREH)) -! -!*** 2.22 ENERGY CONSERVING INTERPOLATION SCHEME -! ------------------------------------------- -! - PRINT*,' !THINNING AND INTERPOLATION!' - ALLOCATE(PF1(NANGH,NFREH)) - ALLOCATE(PF3(NANGH,NFREH)) - - PF1 = 0. - DO M=1,NFREH - DO K=1,NANGH - M0 = MR*M - MP = M0+1 - MP = MIN(NFRE,MP) - MM = M0-1 - - K0 = MA*K+1 - KP = K0+1 - KM = K0-1 - DELFF = 0. - DO KL = KM,KP - KLL = KL - IF (KLL.GT.NANG) KLL = KLL-NANG - IF (KLL.LT.1) KLL = KLL+NANG - DO ML = MM,MP - DEL = DFIM(ML) - DELFF = DELFF+DEL - SPEC1 = F1(KLL,ML) - PF1(K,M)=PF1(K,M)+SPEC1*DEL - ENDDO - ENDDO - PF1(K,M) =PF1(K,M)/DELFF - ENDDO - ENDDO -! -!*** 2.23 DETERMINE SECOND-ORDER SPEC -! -------------------------------- -! - CALL SECSPOM(PF1,PF3,NFREH,NANGH,NMAX,NDEPTH,& - DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,& - DPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P,& - IM_P,IM_M,COUNTER) -! -!*** 2.24 INTERPOLATE TOWARDS HIGH-RES GRID -! -------------------------------------- -! - DO M=1,NFRE - DO K=1,NANG - XM = REAL(M/MR) - XK = REAL((K-1)/MA) - - M0 = MAX(1,INT(XM)) - K0 = INT(XK) - - D1 = REAL(M)/REAL(MR)-XM - D2 = 1.-D1 - D3 = REAL(K-1)/REAL(MA)-XK - D4 = 1.-D3 - - IF (K0.LT.1) K0 = K0+NANGH - MP = MIN(NFREH,M0+1) - KP = K0+1 - IF (KP.GT.NANGH) KP = KP-NANGH - - C1 = PF3(K0,M0)*D4+PF3(KP,M0)*D3 - C2 = PF3(KP,MP)*D3+PF3(K0,MP)*D4 - - DELF = C1*D2+C2*D1 - F3(K,M)=MAX(0.00000001,F1(K,M)+SIGM*DELF) - ENDDO - ENDDO - - ENDIF - - - IF (MR.GT.1 .OR. MA.GT.1 ) THEN - DO M=1,NFREH - AA1 = 0. - DO K=1,NANGH - AA1 = AA1+PF1(K,M)*DELTHH - ENDDO - AA1 = MAX(AA1,EPSMIN) + PF1 = 0. + DO M=1,NFREH + DO K=1,NANGH + M0 = MR*M + MP = M0+1 + MP = MIN(NFRE,MP) + MM = M0-1 - BB1 = 0. - DO K=1,NANGH - BB1 = BB1+(PF1(K,M)+PF3(K,M))*DELTHH + K0 = MA*K+1 + KP = K0+1 + KM = K0-1 + DELFF = 0. + DO KL = KM,KP + KLL = KL + IF (KLL.GT.NANG) KLL = KLL-NANG + IF (KLL.LT.1) KLL = KLL+NANG + DO ML = MM,MP + DEL = DFIM(ML) + DELFF = DELFF+DEL + SPEC1 = F1(KLL,ML) + PF1(K,M)=PF1(K,M)+SPEC1*DEL ENDDO - BB1 = MAX(BB1,EPSMIN) - F = OMEGA(M)/ZPI - -#ifdef W3_T - WRITE(6,62) M,F,AA1,BB1,DELTHH - WRITE(80,62) M,F,AA1,BB1,DELTHH -#endif - ENDDO + ENDDO + PF1(K,M) =PF1(K,M)/DELFF + ENDDO + ENDDO + ! + !*** 2.23 DETERMINE SECOND-ORDER SPEC + ! -------------------------------- + ! + CALL SECSPOM(PF1,PF3,NFREH,NANGH,NMAX,NDEPTH,& + DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,& + DPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P,& + IM_P,IM_M,COUNTER) + ! + !*** 2.24 INTERPOLATE TOWARDS HIGH-RES GRID + ! -------------------------------------- + ! + DO M=1,NFRE + DO K=1,NANG + XM = REAL(M/MR) + XK = REAL((K-1)/MA) - DO M=1,NFREH - DO K=1,NANGH - F13(M,K)=PF1(K,M)+PF3(K,M) - ENDDO - ENDDO - ENDIF + M0 = MAX(1,INT(XM)) + K0 = INT(XK) -! -#ifdef W3_T - 62 FORMAT(I4,9F16.9) -#endif -! - RETURN - END SUBROUTINE CAL_SEC_ORDER_SPEC -! -!-------------------------------------------------------------------- -! - SUBROUTINE TABLES_2ND(NFRE,NANG,NDEPTH,DEPTHA,OMSTART,FRAC,XMR,& - DFDTH,OMEGA,TH) -! -!-------------------------------------------------------------------- -! -!*****TABLES** COMPUTES TABLES FOR SECOND ORDER SPECTRUM IN FREQUENCY SPACE. -! -! P.JANSSEN DECEMBER 2008 -! -! PURPOSE -! ------- -! DETERMINES TABLES, BASED ON JANSSEN (2008) -! THERE ARE THREE CORRECTIONS: -! 1) GENERATION OF SECOND-HARMONICS -! 2) QUASI-LINEAR EFFECT -! 3) SHIFT OF SPECTRUM BECAUSE OF STOKES FREQUENCY -! CORRECTION. -! -! INTERFACE -! --------- -! *CALL* *TABLES(NFRE,NANG,NDEPTH,OMSTART,FRAC,XMR, -! OMEGA,TA,TB,TC_QL,TT_4M,TT_4P,IM_P,IM_M, -! TFAK)* -! -! -! PARAMETER TYPE PURPOSE. -! --------- ---- ------- -! -! NFRE INTEGER NUMBER OF FREQUENCIES -! NANG INTEGER NUMBER OF DIRECTIONS -! NDEPTH INTEGER NUMBER OF ENTRIES IN THE DEPTH TABLE -! OMSTART REAL START FREQUENCY -! FRAC REAL FRACTIONAL INCREASE IN FREQUENCY SPACE -! XMR REAL INVERSE OF THINNING FACTOR IN FREQUENCY SPACE -! OMEGA REAL ANGULAR FREQUENCY ARRAY -! DFDTH REAL PRODUCT OF INCREMENT IN FREQUENCY AND DIRECTION -! TH REAL DIRECTION ARRAY -! TA REAL TABLE FOR MINUS INTERACTIONS -! TB REAL TABLE FOR PLUS INTERACTIONS -! TC_QL REAL TABLE FOR QUASI-LINEAR INTERACTIONS -! TT_4M REAL TABLE FOR STOKES FREQUENCY CORRECTION -! TT_4P REAL TABLE FOR STOKES FREQUENCY CORRECTION -! IM_P INTEGER TABLE FOR WAVENUMBER M2 PLUS -! IM_M INTEGER TABLE FOR WAVENUMBER M2 MIN -! TFAK REAL WAVENUMBER TABLE -! -! -! METHOD -! ------ -! -! EXTERNALS -! --------- -! NONE -! -! REFERENCES -! ---------- -! V.E. ZAKHAROV, HAMILTONIAN APPROACH (1968) -! M.A. SROKOSZ, J.G.R.,91,995-1006 (1986) -! P.A.E.M. JANSSEN, ECMWF TECH MEMO (2008),JFM PAPER (2009) -! -! -!-------------------------------------------------------------------- -! -! -! - IMPLICIT NONE - - INTEGER NFRE,NANG,NDEPTH,MDW,JD,M,K,M1,K1,MP,MM,L - - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL OM0,TH0,XK0,OM1,TH1,XK1,OM2,XK2,OM0P,XK0P,OM0M,XK0M,OMSTART,& - FRAC,XMR,XM2,FAC - REAL OMEGA(NFRE),TH(NANG),DFDTH(NFRE) - - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD -! -! 1. COMPUTATION OF WAVENUMBER ARRAY TFAK -! --------------------------------------- -! -! - DO JD=1,NDEPTH - DEPTH = DEPTHA*DEPTHD**(JD-1) - DO M=1,NFRE - OM0 = OMEGA(M) - TFAK(M,JD) = AKI(OM0,DEPTH) - ENDDO - WRITE(6,*) 'GENERATING TABLES FOR DEPTH:',JD,DEPTH,DEPTHA,NDEPTH -! -! 2. COMPUTATION OF THE 2nd ORDER COEFFICIENTS. -! --------------------------------------------- -! -! - K1 = 0 - TH1 = TH(NANG) - DO M=1,NFRE - OM0 = OMEGA(M) - XK0 = TFAK(M,JD) - - MP = MIN(M+1,NFRE) - OM0P = OMEGA(MP) - XK0P = TFAK(MP,JD) - - MM = MAX(M-1,1) - OM0M = OMEGA(MM) - XK0M = TFAK(MM,JD) - - DO M1=1,NFRE - - OM1 = OMEGA(M1) - - DO L=1,NANG -! -! XK0-XK1 CASE -! - K = K1+L - TH0 = TH(K) - OM2 = OM0-OM1 - - - IF (ABS(OM1).LT.OM0/2.) THEN - XM2 = LOG(OM2/OMSTART)/LOG(1.+FRAC) - IM_M(M1,M) = NINT(XMR*(XM2+1.)) - XK1 = TFAK(M1,JD) - XK2 = AKI(OM2,DEPTH) - - TA(L,M1,M,JD) = DFDTH(M1)*A(XK1,XK2,TH1,TH0)**2 - ELSE - TA(L,M1,M,JD) = 0. - IM_M(M1,M) = 1 - ENDIF -! -! XK1+XK0 CASE -! - OM2 = OM1+OM0 - XM2 = LOG(OM2/OMSTART)/LOG(1.+FRAC) - IM_P(M1,M) = NINT(XMR*(XM2+1.)) - XK1 = TFAK(M1,JD) - XK2 = AKI(OM2,DEPTH) - - TB(L,M1,M,JD) = DFDTH(M1)*B(XK1,XK2,TH1,TH0)**2 -! -! QUASI-LINEAR EFFECT -! -! - TC_QL(L,M1,M,JD) = DFDTH(M1)*C_QL(XK0,XK1,TH0,TH1) -! -! STOKES-FREQUENCY CORRECTION -! -! - FAC = 2.*G/OM1*DFDTH(M1) - TT_4M(L,M1,M,JD) = & - FAC*(W2(XK0M,XK1,XK1,XK0M,TH0,TH1,TH1,TH0)+& - V2(XK0M,XK1,XK1,XK0M,TH0,TH1,TH1,TH0)) - TT_4P(L,M1,M,JD) = & - FAC*(W2(XK0P,XK1,XK1,XK0P,TH0,TH1,TH1,TH0)+& - V2(XK0P,XK1,XK1,XK0P,TH0,TH1,TH1,TH0)) -! Table identical to Janssen: verified. -! IF (JD.EQ.1) WRITE(998,'(F4.1,3I3,5G11.3)') DEPTH,M,M1,L, TB(L,M1,M,JD), & -! TC_QL(L,M1,M,JD) , FAC, TT_4M(L,M1,M,JD), TT_4P(L,M1,M,JD) - ENDDO - ENDDO - ENDDO - ENDDO -! -! -!-------------------------------------------------------------------- -! - RETURN - END SUBROUTINE TABLES_2ND -! -!-------------------------------------------------------------------- -! - SUBROUTINE SECSPOM(F1,F3,NFRE,NANG,NMAX,NDEPTH,& - DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,& - DEPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P,& - IM_P,IM_M,COUNTER) -! -!-------------------------------------------------------------------- -! -!*****SECSPOM** COMPUTES SECOND ORDER SPECTRUM IN FREQUENCY SPACE. -! -! P.JANSSEN JULY 2008 -! -! PURPOSE -! ------- -! DETERMINES SECOND-ORDER SPECTRUM, BASED ON JANSSEN (2008) -! THERE ARE THREE CORRECTIONS: -! 1) GENERATION OF SECOND-HARMONICS -! 2) QUASI-LINEAR EFFECT -! 3) SHIFT OF SPECTRUM BECAUSE OF STOKES FREQUENCY -! CORRECTION. -! -! INTERFACE -! --------- -! *CALL* *SECSPOM(F1,F3,NFRE,NANG,NMAX,NDEPTH, -! DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA, -! DEPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P, -! IM_P,IM_M)* -! -! -! PARAMETER TYPE PURPOSE. -! --------- ---- ------- -! -! F1 REAL 2D FREE WAVE SPECTRUM (INPUT) -! F3 REAL BOUND WAVES SPECTRUM (OUTPUT) -! NFRE INTEGER NUMBER OF FREQUENCIES -! NANG INTEGER NUMBER OF DIRECTIONS -! NMAX INTEGER MAXIMUM INDEX CORRESPONDS TO TWICE THE CUT-OFF -! FREQUENCY -! NDEPTH INTEGER NUMBER OF ENTRIES IN DEPTH TABLE -! DEPTHA REAL START VALUE DEPTH ARRAY -! DEPTHD REAL INCREMENT DEPTH ARRAY -! OMSTART REAL START VALUE ANG. FREQUENCY ARRAY -! FRAC REAL FRACTIONAL INCREASE IN FREQUENCY SPACE -! MR INTEGER THINNING FACTOR IN FREQUENCY SPACE -! OMEGA REAL ANGULAR FREQUENCY ARRAY -! DEPTH REAL DEPTH ARRAY -! AKMEAN REAL MEAN WAVENUMBER ARRAY -! TA REAL TABLE FOR MINUS INTERACTIONS -! TB REAL TABLE FOR PLUS INTERACTIONS -! TC_QL REAL TABLE FOR QUASI-LINEAR INTERACTIONS -! TT_4M REAL TABLE FOR STOKES FREQUENCY CORRECTION -! TT_4P REAL TABLE FOR STOKES FREQUENCY CORRECTION -! IM_P INTEGER TABLE FOR WAVENUMBER M2 PLUS -! IM_M INTEGER TABLE FOR WAVENUMBER M2 MIN -! -! -! -! METHOD -! ------ -! EVALUATE SECOND ORDER SPECTRUM IN FREQUENCY BASED ON -! KRASITSKII'S CANONICAL TRANSFORMATION. -! -! EXTERNALS -! --------- -! NONE -! -! REFERENCES -! ---------- -! V.E. ZAKHAROV, HAMILTONIAN APPROACH (1968) -! M.A. SROKOSZ, J.G.R.,91,995-1006 (1986) -! P.A.E.M. JANSSEN, JFM (2009) -! -! -!-------------------------------------------------------------------- -! -! -! - USE W3GDATMD, ONLY: IGPARS - IMPLICIT NONE - - INTEGER NFRE,NANG,NDEPTH,M,K,M1,K1,M2_M,M2_P,K2,MP,& - MM,L,MR,NMAX,JD,COUNTER - INTEGER IM_P(NFRE,NFRE),IM_M(NFRE,NFRE),IL(NANG,NANG) - - REAL OM0,OM0H,OM1,OM0P,OM0M,& - OMSTART,FRAC,XINCR1,XINCR2,XINCR3,XINCR4,FAC1,FAC2,& - FAC3,T_4M,T_4P,F2K,F2KP,F2KM,F2K1,F2K2,DELM1,DEPTHA,DEPTHD,& - XD,X_MIN - REAL OMEGA(NFRE), DFDTH(NFRE), OMEGAHF(NFRE+1:NMAX) - REAL TA(NANG,NFRE,NFRE,NDEPTH),TB(NANG,NFRE,NFRE,NDEPTH),& - TC_QL(NANG,NFRE,NFRE,NDEPTH),TT_4M(NANG,NFRE,NFRE,NDEPTH),& - TT_4P(NANG,NFRE,NFRE,NDEPTH) - REAL F1(NANG,NFRE),F3(NANG,NFRE),DEPTH - REAL AKMEAN - REAL G1(NANG,NMAX),G3(NANG,NFRE) - - LOGICAL :: LL2H - -! -!*** 1. COMPUTATION OF TAIL OF THE SPECTRUM AND INDEX JD -! --------------------------------------------------- -! -! - X_MIN = IGPARS(9) ! this was 1.1 in Janssen's original code - - DO M=NFRE+1,NMAX - OMEGAHF(M) = OMSTART*(1.+FRAC)**(MR*M-1) - ENDDO + D1 = REAL(M)/REAL(MR)-XM + D2 = 1.-D1 + D3 = REAL(K-1)/REAL(MA)-XK + D4 = 1.-D3 - DO K=1,NANG - DO K1=1,NANG - L = K-K1 - IF (L.GT.NANG) L=L-NANG - IF (L.LT.1) L=L+NANG - IL(K,K1) = L - ENDDO + IF (K0.LT.1) K0 = K0+NANGH + MP = MIN(NFREH,M0+1) + KP = K0+1 + IF (KP.GT.NANGH) KP = KP-NANGH + + C1 = PF3(K0,M0)*D4+PF3(KP,M0)*D3 + C2 = PF3(KP,MP)*D3+PF3(K0,MP)*D4 + + DELF = C1*D2+C2*D1 + F3(K,M)=MAX(0.00000001,F1(K,M)+SIGM*DELF) + ENDDO ENDDO + ENDIF -! This was Janssen's version ... limited to kD > X_MIN ... (here set to 1.1) - XD = MAX(X_MIN/AKMEAN,DEPTH) ! note by FA: why do we have X_MIN/AKMEAN??! - XD = DEPTH - XD = LOG(XD/DEPTHA)/LOG(DEPTHD)+1. - JD = NINT(XD) - JD = MAX(JD,1) - JD = MIN(JD,NDEPTH) - DO M=1,NFRE - DO K=1,NANG - G1(K,M) = F1(K,M) - G3(K,M) = 0. + IF (MR.GT.1 .OR. MA.GT.1 ) THEN + DO M=1,NFREH + AA1 = 0. + DO K=1,NANGH + AA1 = AA1+PF1(K,M)*DELTHH + ENDDO + AA1 = MAX(AA1,EPSMIN) + + BB1 = 0. + DO K=1,NANGH + BB1 = BB1+(PF1(K,M)+PF3(K,M))*DELTHH ENDDO + BB1 = MAX(BB1,EPSMIN) + F = OMEGA(M)/ZPI + +#ifdef W3_T + WRITE(6,62) M,F,AA1,BB1,DELTHH + WRITE(80,62) M,F,AA1,BB1,DELTHH +#endif ENDDO - DO M=NFRE+1,NMAX - DO K=1,NANG - G1(K,M) = OMEGA(NFRE)**5*G1(K,NFRE)/OMEGAHF(M)**5 + DO M=1,NFREH + DO K=1,NANGH + F13(M,K)=PF1(K,M)+PF3(K,M) ENDDO ENDDO -! -! -! -! -!*** 2. COMPUTATION OF THE 2nd ORDER FREQUENCY SPECTRUM. -! --------------------------------------------------- -! -! + ENDIF + + ! +#ifdef W3_T +62 FORMAT(I4,9F16.9) +#endif + ! + RETURN + END SUBROUTINE CAL_SEC_ORDER_SPEC + ! + !-------------------------------------------------------------------- + ! + SUBROUTINE TABLES_2ND(NFRE,NANG,NDEPTH,DEPTHA,OMSTART,FRAC,XMR,& + DFDTH,OMEGA,TH) + ! + !-------------------------------------------------------------------- + ! + !*****TABLES** COMPUTES TABLES FOR SECOND ORDER SPECTRUM IN FREQUENCY SPACE. + ! + ! P.JANSSEN DECEMBER 2008 + ! + ! PURPOSE + ! ------- + ! DETERMINES TABLES, BASED ON JANSSEN (2008) + ! THERE ARE THREE CORRECTIONS: + ! 1) GENERATION OF SECOND-HARMONICS + ! 2) QUASI-LINEAR EFFECT + ! 3) SHIFT OF SPECTRUM BECAUSE OF STOKES FREQUENCY + ! CORRECTION. + ! + ! INTERFACE + ! --------- + ! *CALL* *TABLES(NFRE,NANG,NDEPTH,OMSTART,FRAC,XMR, + ! OMEGA,TA,TB,TC_QL,TT_4M,TT_4P,IM_P,IM_M, + ! TFAK)* + ! + ! + ! PARAMETER TYPE PURPOSE. + ! --------- ---- ------- + ! + ! NFRE INTEGER NUMBER OF FREQUENCIES + ! NANG INTEGER NUMBER OF DIRECTIONS + ! NDEPTH INTEGER NUMBER OF ENTRIES IN THE DEPTH TABLE + ! OMSTART REAL START FREQUENCY + ! FRAC REAL FRACTIONAL INCREASE IN FREQUENCY SPACE + ! XMR REAL INVERSE OF THINNING FACTOR IN FREQUENCY SPACE + ! OMEGA REAL ANGULAR FREQUENCY ARRAY + ! DFDTH REAL PRODUCT OF INCREMENT IN FREQUENCY AND DIRECTION + ! TH REAL DIRECTION ARRAY + ! TA REAL TABLE FOR MINUS INTERACTIONS + ! TB REAL TABLE FOR PLUS INTERACTIONS + ! TC_QL REAL TABLE FOR QUASI-LINEAR INTERACTIONS + ! TT_4M REAL TABLE FOR STOKES FREQUENCY CORRECTION + ! TT_4P REAL TABLE FOR STOKES FREQUENCY CORRECTION + ! IM_P INTEGER TABLE FOR WAVENUMBER M2 PLUS + ! IM_M INTEGER TABLE FOR WAVENUMBER M2 MIN + ! TFAK REAL WAVENUMBER TABLE + ! + ! + ! METHOD + ! ------ + ! + ! EXTERNALS + ! --------- + ! NONE + ! + ! REFERENCES + ! ---------- + ! V.E. ZAKHAROV, HAMILTONIAN APPROACH (1968) + ! M.A. SROKOSZ, J.G.R.,91,995-1006 (1986) + ! P.A.E.M. JANSSEN, ECMWF TECH MEMO (2008),JFM PAPER (2009) + ! + ! + !-------------------------------------------------------------------- + ! + ! + ! + IMPLICIT NONE + + INTEGER NFRE,NANG,NDEPTH,MDW,JD,M,K,M1,K1,MP,MM,L + + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL OM0,TH0,XK0,OM1,TH1,XK1,OM2,XK2,OM0P,XK0P,OM0M,XK0M,OMSTART,& + FRAC,XMR,XM2,FAC + REAL OMEGA(NFRE),TH(NANG),DFDTH(NFRE) + + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + ! + ! 1. COMPUTATION OF WAVENUMBER ARRAY TFAK + ! --------------------------------------- + ! + ! + DO JD=1,NDEPTH + DEPTH = DEPTHA*DEPTHD**(JD-1) + DO M=1,NFRE + OM0 = OMEGA(M) + TFAK(M,JD) = AKI(OM0,DEPTH) + ENDDO + WRITE(6,*) 'GENERATING TABLES FOR DEPTH:',JD,DEPTH,DEPTHA,NDEPTH + ! + ! 2. COMPUTATION OF THE 2nd ORDER COEFFICIENTS. + ! --------------------------------------------- + ! + ! + K1 = 0 + TH1 = TH(NANG) DO M=1,NFRE OM0 = OMEGA(M) - OM0H = OM0/2. + XK0 = TFAK(M,JD) + MP = MIN(M+1,NFRE) - OM0P = OMEGA(MP) - MM = MAX(M-1,1) - OM0M = OMEGA(MM) - DELM1 = 1./(OM0P-OM0M) - DO K=1,NANG - K2 = K - F2K = G1(K,M) - F2KP = G1(K,MP) - F2KM = G1(K,MM) - DO M1=1,NFRE - OM1 = OMEGA(M1) - LL2H = (ABS(OM1).LT.OM0H) - M2_M = IM_M(M1,M) - M2_P = IM_P(M1,M) - DO K1=1,NANG - F2K1 = G1(K1,M1) - L = IL(K,K1) -! -! 2.1 OM0-OM1 CASE: SECOND HARMONICS -! OM2 = OM0-OM1 -! - IF (LL2H) THEN - F2K2 = G1(K2,M2_M) - FAC1 = TA(L,M1,M,JD) - FAC2 = F2K1*F2K2+G1(K2,M1)*G1(K1,M2_M) - - XINCR1 = FAC1*FAC2 - G3(K,M) = G3(K,M)+XINCR1 - ENDIF -! -! 2.2 OM1+OM0 CASE: INFRA-GRAVITY WAVES -! OM2 = OM1+OM0 -! - F2K2 = G1(K2,M2_P) - FAC3 = 2.*TB(L,M1,M,JD) - XINCR2 = FAC3*F2K2 -! -! 2.3 QUASI-LINEAR EFFECT -! - XINCR3 = TC_QL(L,M1,M,JD)*F2K -! -! 2.4 STOKES-FREQUENCY CORRECTION -! - T_4M = TT_4M(L,M1,M,JD) - T_4P = TT_4P(L,M1,M,JD) - XINCR4 = -(F2KP*T_4P-F2KM*T_4M)*DELM1 - - G3(K,M) = G3(K,M)+F2K1*(XINCR2+XINCR3+XINCR4) + OM0P = OMEGA(MP) + XK0P = TFAK(MP,JD) - ENDDO + MM = MAX(M-1,1) + OM0M = OMEGA(MM) + XK0M = TFAK(MM,JD) + + DO M1=1,NFRE + + OM1 = OMEGA(M1) + + DO L=1,NANG + ! + ! XK0-XK1 CASE + ! + K = K1+L + TH0 = TH(K) + OM2 = OM0-OM1 + + + IF (ABS(OM1).LT.OM0/2.) THEN + XM2 = LOG(OM2/OMSTART)/LOG(1.+FRAC) + IM_M(M1,M) = NINT(XMR*(XM2+1.)) + XK1 = TFAK(M1,JD) + XK2 = AKI(OM2,DEPTH) + + TA(L,M1,M,JD) = DFDTH(M1)*A(XK1,XK2,TH1,TH0)**2 + ELSE + TA(L,M1,M,JD) = 0. + IM_M(M1,M) = 1 + ENDIF + ! + ! XK1+XK0 CASE + ! + OM2 = OM1+OM0 + XM2 = LOG(OM2/OMSTART)/LOG(1.+FRAC) + IM_P(M1,M) = NINT(XMR*(XM2+1.)) + XK1 = TFAK(M1,JD) + XK2 = AKI(OM2,DEPTH) + + TB(L,M1,M,JD) = DFDTH(M1)*B(XK1,XK2,TH1,TH0)**2 + ! + ! QUASI-LINEAR EFFECT + ! + ! + TC_QL(L,M1,M,JD) = DFDTH(M1)*C_QL(XK0,XK1,TH0,TH1) + ! + ! STOKES-FREQUENCY CORRECTION + ! + ! + FAC = 2.*G/OM1*DFDTH(M1) + TT_4M(L,M1,M,JD) = & + FAC*(W2(XK0M,XK1,XK1,XK0M,TH0,TH1,TH1,TH0)+& + V2(XK0M,XK1,XK1,XK0M,TH0,TH1,TH1,TH0)) + TT_4P(L,M1,M,JD) = & + FAC*(W2(XK0P,XK1,XK1,XK0P,TH0,TH1,TH1,TH0)+& + V2(XK0P,XK1,XK1,XK0P,TH0,TH1,TH1,TH0)) + ! Table identical to Janssen: verified. + ! IF (JD.EQ.1) WRITE(998,'(F4.1,3I3,5G11.3)') DEPTH,M,M1,L, TB(L,M1,M,JD), & + ! TC_QL(L,M1,M,JD) , FAC, TT_4M(L,M1,M,JD), TT_4P(L,M1,M,JD) ENDDO ENDDO ENDDO -! - DO M=1,NFRE - DO K=1,NANG - F3(K,M) = G3(K,M) + ENDDO + ! + ! + !-------------------------------------------------------------------- + ! + RETURN + END SUBROUTINE TABLES_2ND + ! + !-------------------------------------------------------------------- + ! + SUBROUTINE SECSPOM(F1,F3,NFRE,NANG,NMAX,NDEPTH,& + DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,& + DEPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P,& + IM_P,IM_M,COUNTER) + ! + !-------------------------------------------------------------------- + ! + !*****SECSPOM** COMPUTES SECOND ORDER SPECTRUM IN FREQUENCY SPACE. + ! + ! P.JANSSEN JULY 2008 + ! + ! PURPOSE + ! ------- + ! DETERMINES SECOND-ORDER SPECTRUM, BASED ON JANSSEN (2008) + ! THERE ARE THREE CORRECTIONS: + ! 1) GENERATION OF SECOND-HARMONICS + ! 2) QUASI-LINEAR EFFECT + ! 3) SHIFT OF SPECTRUM BECAUSE OF STOKES FREQUENCY + ! CORRECTION. + ! + ! INTERFACE + ! --------- + ! *CALL* *SECSPOM(F1,F3,NFRE,NANG,NMAX,NDEPTH, + ! DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA, + ! DEPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P, + ! IM_P,IM_M)* + ! + ! + ! PARAMETER TYPE PURPOSE. + ! --------- ---- ------- + ! + ! F1 REAL 2D FREE WAVE SPECTRUM (INPUT) + ! F3 REAL BOUND WAVES SPECTRUM (OUTPUT) + ! NFRE INTEGER NUMBER OF FREQUENCIES + ! NANG INTEGER NUMBER OF DIRECTIONS + ! NMAX INTEGER MAXIMUM INDEX CORRESPONDS TO TWICE THE CUT-OFF + ! FREQUENCY + ! NDEPTH INTEGER NUMBER OF ENTRIES IN DEPTH TABLE + ! DEPTHA REAL START VALUE DEPTH ARRAY + ! DEPTHD REAL INCREMENT DEPTH ARRAY + ! OMSTART REAL START VALUE ANG. FREQUENCY ARRAY + ! FRAC REAL FRACTIONAL INCREASE IN FREQUENCY SPACE + ! MR INTEGER THINNING FACTOR IN FREQUENCY SPACE + ! OMEGA REAL ANGULAR FREQUENCY ARRAY + ! DEPTH REAL DEPTH ARRAY + ! AKMEAN REAL MEAN WAVENUMBER ARRAY + ! TA REAL TABLE FOR MINUS INTERACTIONS + ! TB REAL TABLE FOR PLUS INTERACTIONS + ! TC_QL REAL TABLE FOR QUASI-LINEAR INTERACTIONS + ! TT_4M REAL TABLE FOR STOKES FREQUENCY CORRECTION + ! TT_4P REAL TABLE FOR STOKES FREQUENCY CORRECTION + ! IM_P INTEGER TABLE FOR WAVENUMBER M2 PLUS + ! IM_M INTEGER TABLE FOR WAVENUMBER M2 MIN + ! + ! + ! + ! METHOD + ! ------ + ! EVALUATE SECOND ORDER SPECTRUM IN FREQUENCY BASED ON + ! KRASITSKII'S CANONICAL TRANSFORMATION. + ! + ! EXTERNALS + ! --------- + ! NONE + ! + ! REFERENCES + ! ---------- + ! V.E. ZAKHAROV, HAMILTONIAN APPROACH (1968) + ! M.A. SROKOSZ, J.G.R.,91,995-1006 (1986) + ! P.A.E.M. JANSSEN, JFM (2009) + ! + ! + !-------------------------------------------------------------------- + ! + ! + ! + USE W3GDATMD, ONLY: IGPARS + IMPLICIT NONE + + INTEGER NFRE,NANG,NDEPTH,M,K,M1,K1,M2_M,M2_P,K2,MP,& + MM,L,MR,NMAX,JD,COUNTER + INTEGER IM_P(NFRE,NFRE),IM_M(NFRE,NFRE),IL(NANG,NANG) + + REAL OM0,OM0H,OM1,OM0P,OM0M,& + OMSTART,FRAC,XINCR1,XINCR2,XINCR3,XINCR4,FAC1,FAC2,& + FAC3,T_4M,T_4P,F2K,F2KP,F2KM,F2K1,F2K2,DELM1,DEPTHA,DEPTHD,& + XD,X_MIN + REAL OMEGA(NFRE), DFDTH(NFRE), OMEGAHF(NFRE+1:NMAX) + REAL TA(NANG,NFRE,NFRE,NDEPTH),TB(NANG,NFRE,NFRE,NDEPTH),& + TC_QL(NANG,NFRE,NFRE,NDEPTH),TT_4M(NANG,NFRE,NFRE,NDEPTH),& + TT_4P(NANG,NFRE,NFRE,NDEPTH) + REAL F1(NANG,NFRE),F3(NANG,NFRE),DEPTH + REAL AKMEAN + REAL G1(NANG,NMAX),G3(NANG,NFRE) + + LOGICAL :: LL2H + + ! + !*** 1. COMPUTATION OF TAIL OF THE SPECTRUM AND INDEX JD + ! --------------------------------------------------- + ! + ! + X_MIN = IGPARS(9) ! this was 1.1 in Janssen's original code + + DO M=NFRE+1,NMAX + OMEGAHF(M) = OMSTART*(1.+FRAC)**(MR*M-1) + ENDDO + + DO K=1,NANG + DO K1=1,NANG + L = K-K1 + IF (L.GT.NANG) L=L-NANG + IF (L.LT.1) L=L+NANG + IL(K,K1) = L + ENDDO + ENDDO + + + ! This was Janssen's version ... limited to kD > X_MIN ... (here set to 1.1) + XD = MAX(X_MIN/AKMEAN,DEPTH) ! note by FA: why do we have X_MIN/AKMEAN??! + XD = DEPTH + XD = LOG(XD/DEPTHA)/LOG(DEPTHD)+1. + JD = NINT(XD) + JD = MAX(JD,1) + JD = MIN(JD,NDEPTH) + + DO M=1,NFRE + DO K=1,NANG + G1(K,M) = F1(K,M) + G3(K,M) = 0. + ENDDO + ENDDO + + DO M=NFRE+1,NMAX + DO K=1,NANG + G1(K,M) = OMEGA(NFRE)**5*G1(K,NFRE)/OMEGAHF(M)**5 + ENDDO + ENDDO + ! + ! + ! + ! + !*** 2. COMPUTATION OF THE 2nd ORDER FREQUENCY SPECTRUM. + ! --------------------------------------------------- + ! + ! + DO M=1,NFRE + OM0 = OMEGA(M) + OM0H = OM0/2. + MP = MIN(M+1,NFRE) + OM0P = OMEGA(MP) + MM = MAX(M-1,1) + OM0M = OMEGA(MM) + DELM1 = 1./(OM0P-OM0M) + DO K=1,NANG + K2 = K + F2K = G1(K,M) + F2KP = G1(K,MP) + F2KM = G1(K,MM) + DO M1=1,NFRE + OM1 = OMEGA(M1) + LL2H = (ABS(OM1).LT.OM0H) + M2_M = IM_M(M1,M) + M2_P = IM_P(M1,M) + DO K1=1,NANG + F2K1 = G1(K1,M1) + L = IL(K,K1) + ! + ! 2.1 OM0-OM1 CASE: SECOND HARMONICS + ! OM2 = OM0-OM1 + ! + IF (LL2H) THEN + F2K2 = G1(K2,M2_M) + FAC1 = TA(L,M1,M,JD) + FAC2 = F2K1*F2K2+G1(K2,M1)*G1(K1,M2_M) + + XINCR1 = FAC1*FAC2 + G3(K,M) = G3(K,M)+XINCR1 + ENDIF + ! + ! 2.2 OM1+OM0 CASE: INFRA-GRAVITY WAVES + ! OM2 = OM1+OM0 + ! + F2K2 = G1(K2,M2_P) + FAC3 = 2.*TB(L,M1,M,JD) + XINCR2 = FAC3*F2K2 + ! + ! 2.3 QUASI-LINEAR EFFECT + ! + XINCR3 = TC_QL(L,M1,M,JD)*F2K + ! + ! 2.4 STOKES-FREQUENCY CORRECTION + ! + T_4M = TT_4M(L,M1,M,JD) + T_4P = TT_4P(L,M1,M,JD) + XINCR4 = -(F2KP*T_4P-F2KM*T_4M)*DELM1 + + G3(K,M) = G3(K,M)+F2K1*(XINCR2+XINCR3+XINCR4) + + ENDDO ENDDO ENDDO -! -!-------------------------------------------------------------------- -! - RETURN - END SUBROUTINE SECSPOM -! -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *A(XI,XJ,THI,THJ) -! -!----------------------------------------------------------------------- - REAL FUNCTION A(XI,XJ,THI,THJ) -! -!*** *A* DETERMINES THE MINUS INTERACTIONS. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE -! WAVE INTERACTIONS OF GRAVITY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) -! -! INTERFACE. -! ---------- -! *A(XI,XJ)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL RI,RJ,RK,XI,XJ,THI,THJ,THK,OI,OJ,OK,FI,FJ,FK -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - - RI = XI - RJ = XJ - RK = VABS(RI,RJ,THI,THJ) - THK = VDIR(RI,RJ,THI,THJ) - - OI=OMEG(RI) - OJ=OMEG(RJ) - OK=OMEG(RK) - - FI = SQRT(OI/(2.*G)) - FJ = SQRT(OJ/(2.*G)) - FK = SQRT(OK/(2.*G)) - - - A = FK/(FI*FJ)*(A1(RK,RI,RJ,THK,THI,THJ)+& - A3(RK,RI,RJ,THK-PI,THI,THJ)) - - RETURN - END FUNCTION A -! -!*** *REAL FUNCTION* *B(XI,XJ,THI,THJ) -! -!----------------------------------------------------------------------- - REAL FUNCTION B(XI,XJ,THI,THJ) -! -!*** *B* DETERMINES THE PLUS INTERACTION COEFFICIENTS. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE -! WAVE INTERACTIONS OF GRAVITY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) -! -! INTERFACE. -! ---------- -! *B(XI,XJ)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL DEL,RI,RJ,RK,XI,XJ,THI,THJ,THK,OI,OJ,OK,FI,FJ,FK -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - DEL = 0. - RI = XI - RJ = XJ - RK = VABS(RJ,RI,THJ,THI-PI) - THK = VDIR(RJ,RI,THJ,THI-PI) - - OI=OMEG(RI)+DEL - OJ=OMEG(RJ)+DEL - OK=OMEG(RK)+DEL - - FI = SQRT(OI/(2.*G)) - FJ = SQRT(OJ/(2.*G)) - FK = SQRT(OK/(2.*G)) - - B = 0.5*FK/(FI*FJ)*(A2(RK,RI,RJ,THK,THI,THJ)+& - A2(RK,RJ,RI,THK-PI,THJ,THI)) - - RETURN - END FUNCTION B -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *C_QL(XK0,XK1,TH0,TH1) -! -!----------------------------------------------------------------------- - REAL FUNCTION C_QL(XK0,XK1,TH0,TH1) -! -!*** *A* DETERMINES THE QUASI-LINEAR TERM. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! DETERMINE CONTRIBUTION BY QUASI-LINEAR TERMS -! -! INTERFACE. -! ---------- -! *C_QL(XK0,XK1)* -! *XK0* - WAVE NUMBER -! *XK1* - WAVE NUMBER -! METHOD. -! ------- - -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL XK0,XK1,TH0,TH1,OM1,F1 -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - OM1 = OMEG(XK1) - F1 = SQRT(OM1/(2.*G)) - - C_QL = 2./F1**2*(B2(XK0,XK1,XK1,XK0,TH0,TH1,TH1,TH0)+& - B3(XK0,XK0,XK1,XK1,TH0-PI,TH0,TH1,TH1)) - - RETURN - END FUNCTION C_QL - -! -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *VPLUS(XI,XJ,XK,THI,THJ,THK) -! -!----------------------------------------------------------------------- - REAL FUNCTION VPLUS(XI,XJ,XK,THI,THJ,THK) -! -!*** *VPLUS* DETERMINES THE SECOND-ORDER TRANSFER COEFFICIENT -! FOR THREE WAVE INTERACTIONS OF GRAVITY WAVES. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE -! WAVE INTERACTIONS OF GRAVITY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) -! -! INTERFACE. -! ---------- -! *VPLUS(XI,XJ,XK)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *THI* - WAVE DIRECTION -! *THJ* - WAVE DIRECTION -! *THK* - WAVE DIRECTION -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL DEL1,RI,RJ,RK,XI,XJ,XK,THI,THJ,THK,OI,OJ,OK,QI,QJ,QK,& - RIJ,RIK,RJK,SQIJK,SQIKJ,SQJKI,ZCONST -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - DEL1 = 10.**(-12) - ZCONST=1./(4*SQRT(2.)) - - RI = XI - RJ = XJ - RK = XK - - OI=OMEG(RI)+DEL1 - OJ=OMEG(RJ)+DEL1 - OK=OMEG(RK)+DEL1 - - QI=OI**2/G - QJ=OJ**2/G - QK=OK**2/G - - RIJ = RI*RJ*COS(THJ-THI) - RIK = RI*RK*COS(THK-THI) - RJK = RJ*RK*COS(THK-THJ) - - SQIJK=SQRT(G*OK/(OI*OJ)) - SQIKJ=SQRT(G*OJ/(OI*OK)) - SQJKI=SQRT(G*OI/(OJ*OK)) - - VPLUS=ZCONST*( (RIJ+QI*QJ)*SQIJK + (RIK+QI*QK)*SQIKJ& - + (RJK+QJ*QK)*SQJKI ) - RETURN - END FUNCTION VPLUS -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *VMIN(XI,XJ,XK,THI,THJ,THK) -! -!----------------------------------------------------------------------- - REAL FUNCTION VMIN(XI,XJ,XK,THI,THJ,THK) -! -!*** *VMIN* DETERMINES THE SECOND-ORDER TRANSFER COEFFICIENT FOR -! THREE WAVE INTERACTIONS OF GRAVITY WAVES. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE -! WAVE INTERACTIONS OF GRAVITY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) -! -! INTERFACE. -! ---------- -! *VMIN(XI,XJ,XK)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *THI* - WAVE DIRECTION -! *THJ* - WAVE DIRECTION -! *THK* - WAVE DIRECTION -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL DEL1,RI,RJ,RK,XI,XJ,XK,THI,THJ,THK,OI,OJ,OK,QI,QJ,QK,& - RIJ,RIK,RJK,SQIJK,SQIKJ,SQJKI,ZCONST -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - DEL1 = 10.**(-12) - ZCONST=1./(4*SQRT(2.)) - - RI = XI - RJ = XJ - RK = XK - - OI=OMEG(RI)+DEL1 - OJ=OMEG(RJ)+DEL1 - OK=OMEG(RK)+DEL1 - - QI=OI**2/G - QJ=OJ**2/G - QK=OK**2/G - - RIJ = RI*RJ*COS(THJ-THI) - RIK = RI*RK*COS(THK-THI) - RJK = RJ*RK*COS(THK-THJ) - - SQIJK=SQRT(G*OK/(OI*OJ)) - SQIKJ=SQRT(G*OJ/(OI*OK)) - SQJKI=SQRT(G*OI/(OJ*OK)) - - VMIN=ZCONST*( (RIJ-QI*QJ)*SQIJK + (RIK-QI*QK)*SQIKJ& - + (RJK+QJ*QK)*SQJKI ) - RETURN - END FUNCTION VMIN -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *U(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!----------------------------------------------------------------------- - REAL FUNCTION U(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!*** *U* DETERMINES THE THIRD-ORDER TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY WAVES. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) -! -! INTERFACE. -! ---------- -! *U(XI,XJ,XK,XL)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *XL* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,XIK,XJK,XIL,XJL,& - OIK,OJK,OIL,OJL,QI,QJ,QIK,QJK,QIL,QJL,SQIJKL,ZCONST -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - ZCONST=1./(16.) - - OI=OMEG(XI) - OJ=OMEG(XJ) - OK=OMEG(XK) - OL=OMEG(XL) - - XIK = VABS(XI,XK,THI,THK) - XJK = VABS(XJ,XK,THJ,THK) - XIL = VABS(XI,XL,THI,THL) - XJL = VABS(XJ,XL,THJ,THL) - OIK=OMEG(XIK) - OJK=OMEG(XJK) - OIL=OMEG(XIL) - OJL=OMEG(XJL) - - QI=OI**2/G - QJ=OJ**2/G - QIK=OIK**2/G - QJK=OJK**2/G - QIL=OIL**2/G - QJL=OJL**2/G - SQIJKL=SQRT(OK*OL/(OI*OJ)) - U = ZCONST*SQIJKL*( 2.*(XI**2*QJ+XJ**2*QI)-QI*QJ*(& - QIK+QJK+QIL+QJL) ) - RETURN - END FUNCTION U -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *W2(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!----------------------------------------------------------------------- - REAL FUNCTION W2(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!*** *W2* DETERMINES THE CONTRIBUTION OF THE DIRECT FOUR-WAVE -! INTERACTIONS OF GRAVITY WAVES OF THE TYPE -! A_2^*A_3A_4. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) -! -! INTERFACE. -! ---------- -! *W(XI,XJ,XK,XL)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *XL* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - REAL XI,XJ,XK,XL,THI,THJ,THK,THL -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - W2= U(XI,XJ,XK,XL,THI-PI,THJ-PI,THK,THL)+& - U(XK,XL,XI,XJ,THK,THL,THI-PI,THJ-PI)-& - U(XK,XJ,XI,XL,THK,THJ-PI,THI-PI,THL)-& - U(XI,XK,XJ,XL,THI-PI,THK,THJ-PI,THL)-& - U(XI,XL,XK,XJ,THI-PI,THL,THK,THJ-PI)-& - U(XL,XJ,XK,XI,THL,THJ-PI,THK,THI-PI) - RETURN - END FUNCTION W2 -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *V2(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!----------------------------------------------------------------------- - REAL FUNCTION V2(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!*** *V2* DETERMINES THE CONTRIBUTION OF THE VIRTUAL -! FOUR-WAVE INTERACTIONS OF GRAVITY WAVES. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND -! CRAWFORD ET AL) -! -! INTERFACE. -! ---------- -! *V2(XI,XJ,XK,XL)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *XL* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - COMMON/PRECIS/DOUBLEP - LOGICAL DOUBLEP - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,& - RIJ,RIK,RLI,RJL,RJK,RKL,THIJ,THIK,THLI,THJL,THJK,THKL,OIJ,& - OIK,OJL,OJK,OLI,OKL,XNIK,XNJL,XNJK,XNIL,YNIL,YNJK,YNJL,YNIK,& - ZNIJ,ZNKL,ZPIJ,ZPKL,THLJ,THIL,THKJ,THKI,THJI,THLK -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - IF (DOUBLEP) THEN - DEL1=10.**(-5) - ELSE - DEL1=10.**(-2) - ENDIF - - - RI=XI+DEL1 - RJ=XJ+DEL1/2. - RK=XK+DEL1/3. - RL=XL+DEL1*(1.+1./2.-1./3.) - - OI=OMEG(RI) - OJ=OMEG(RJ) - OK=OMEG(RK) - OL=OMEG(RL) - - RIJ = VABS(RI,RJ,THI,THJ) - THIJ = VDIR(RI,RJ,THI,THJ) - - RIK = VABS(RI,RK,THI,THK-PI) - THIK = VDIR(RI,RK,THI,THK-PI) - - RLI = VABS(RL,RI,THL,THI-PI) - THLI = VDIR(XL,XI,THL,THI-PI) - - RJL = VABS(RJ,RL,THJ,THL-PI) - THJL = VDIR(RJ,RL,THJ,THL-PI) - - RJK = VABS(RJ,RK,THJ,THK-PI) - THJK = VDIR(RJ,RK,THJ,THK-PI) - - RKL = VABS(RK,RL,THK,THL) - THKL = VDIR(RK,RL,THK,THL) - - OIJ=OMEG(RIJ) - OIK=OMEG(RIK) - OJL=OMEG(RJL) - OJK=OMEG(RJK) - OLI=OMEG(RLI) - OKL=OMEG(RKL) - - XNIK = OK+OIK-OI - XNJL = OJ+OJL-OL - XNJK = OK+OJK-OJ - XNIL = OI+OLI-OL - - YNIL = OL+OLI-OI - YNJK = OJ+OJK-OK - YNJL = OL+OJL-OJ - YNIK = OI+OIK-OK - - ZNIJ = OIJ-OI-OJ - ZNKL = OKL-OK-OL - ZPIJ = OIJ+OI+OJ - ZPKL = OKL+OK+OL - - THLJ = THJL-PI - THIL = THLI-PI - THKJ = THJK-PI - THKI = THIK-PI - THJI = THIJ-PI - THLK = THKL-PI - - V2= VMIN(RI,RK,RIK,THI,THK,THIK)*VMIN(RL,RJ,RJL,THL,THJ,THLJ)*& - (1./XNIK+1./XNJL)& - +VMIN(RJ,RK,RJK,THJ,THK,THJK)*VMIN(RL,RI,RLI,THL,THI,THLI)*& - (1./XNJK+1./XNIL)& - +VMIN(RI,RL,RLI,THI,THL,THIL)*VMIN(RK,RJ,RJK,THK,THJ,THKJ)*& - (1./YNIL+1./YNJK)& - +VMIN(RJ,RL,RJL,THJ,THL,THJL)*VMIN(RK,RI,RIK,THK,THI,THKI)*& - (1./YNJL+1./YNIK)& - +VMIN(RIJ,RI,RJ,THIJ,THI,THJ)*VMIN(RKL,RK,RL,THKL,THK,THL)*& - (1./ZNIJ+1./ZNKL)& - +VPLUS(RIJ,RI,RJ,THJI,THI,THJ)*VPLUS(RKL,RK,RL,THLK,THK,THL)*& - (1./ZPIJ+1./ZPKL) - - V2 = -V2 - - RETURN - END FUNCTION V2 -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *W1(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!----------------------------------------------------------------------- - REAL FUNCTION W1(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!*** *W1* DETERMINES THE NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY WAVES OF THE TYPE -! A_2A_3A_4. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) -! -! INTERFACE. -! ---------- -! *W1(XI,XJ,XK,XL)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *XL* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL XI,XJ,XK,XL,THI,THJ,THK,THL -! -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - W1= -U(XI,XJ,XK,XL,THI-PI,THJ,THK,THL)-& - U(XI,XK,XJ,XL,THI-PI,THK,THJ,THL)-& - U(XI,XL,XJ,XK,THI-PI,THL,THJ,THK)+& - U(XJ,XK,XI,XL,THJ,THK,THI-PI,THL)+& - U(XJ,XL,XI,XK,THJ,THL,THI-PI,THK)+& - U(XK,XL,XI,XJ,THK,THL,THI-PI,THJ) - - W1=W1/3. - - RETURN - END FUNCTION W1 -! -!*** *REAL FUNCTION* *W4(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!----------------------------------------------------------------------- - REAL FUNCTION W4(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!*** *W4* DETERMINES THE NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY WAVES of the type -! A_^*A_3^*A_4^*. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) -! -! INTERFACE. -! ---------- -! *W4(XI,XJ,XK,XL)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *XL* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL XI,XJ,XK,XL,THI,THJ,THK,THL -! -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - - W4= U(XI,XJ,XK,XL,THI,THJ,THK,THL)+& - U(XI,XK,XJ,XL,THI,THK,THJ,THL)+& - U(XI,XL,XJ,XK,THI,THL,THJ,THK)+& - U(XJ,XK,XI,XL,THJ,THK,THI,THL)+& - U(XJ,XL,XI,XK,THJ,THL,THI,THK)+& - U(XK,XL,XI,XJ,THK,THL,THI,THJ) - - - W4=W4/3. - - RETURN - END FUNCTION W4 -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *B3(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!----------------------------------------------------------------------- - REAL FUNCTION B3(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!*** *B3* WEIGHTS OF THE A_2^*A_3^*A_4 PART OF THE -! CANONICAL TRANSFORMATION. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) -! -! INTERFACE. -! ---------- -! *B3(XI,XJ,XK,XL)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *XL* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - COMMON/PRECIS/DOUBLEP - LOGICAL DOUBLEP - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,& - RIJ,RJI,RIK,RKI,RLJ,RJL,RJK,RKJ,RLI,RIL,RLK,RKL,THIJ,THJI,& - THIK,THKI,THLJ,THJL,THJK,THKJ,THLI,THIL,THLK,THKL,ZIJKL -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - IF (DOUBLEP) THEN - DEL1=10.**(-5) - ELSE - DEL1=0.01 - ENDIF - - RI=XI - RJ=XJ - RK=XK - RL=XL - - OI=OMEG(RI)+DEL1 - OJ=OMEG(RJ)+DEL1 - OK=OMEG(RK)+DEL1 - OL=OMEG(RL)+DEL1 - - RIJ = VABS(RI,RJ,THI,THJ) - THIJ = VDIR(RI,RJ,THI,THJ) - - RJI = VABS(RJ,RI,THJ,THI) - THJI = VDIR(RJ,RI,THJ,THI) - - RIK = VABS(RI,RK,THI,THK) - THIK = VDIR(RI,RK,THI,THK) - - RKI = VABS(RK,RI,THK,THI) - THKI = VDIR(RK,RI,THK,THI) - - RLJ = VABS(RL,RJ,THL,THJ-PI) - THLJ = VDIR(RL,RJ,THL,THJ-PI) - - RJL = VABS(RJ,RL,THJ,THL-PI) - THJL = VDIR(RJ,RL,THJ,THL-PI) - - RJK = VABS(RJ,RK,THJ,THK) - THJK = VDIR(RJ,RK,THJ,THK) - - RKJ = VABS(RK,RJ,THK,THJ) - THKJ = VDIR(RK,RJ,THK,THJ) - - RLI = VABS(RL,RI,THL,THI-PI) - THLI = VDIR(RL,RI,THL,THI-PI) - - RIL = VABS(RI,RL,THI,THL-PI) - THIL = VDIR(RI,RL,THI,THL-PI) - - RLK = VABS(RL,RK,THL,THK-PI) - THLK = VDIR(RL,RK,THL,THK-PI) - - RKL = VABS(RK,RL,THK,THL-PI) - THKL = VDIR(RK,RL,THK,THL-PI) - - ZIJKL = OI+OJ+OK-OL - - B3= -1./ZIJKL*(2.*( & - VMIN(RL,RI,RLI,THL,THI,THLI)*A1(RJK,RJ,RK,THJK,THJ,THK)& - -VMIN(RIJ,RI,RJ,THIJ,THI,THJ)*A1(RL,RK,RLK,THL,THK,THLK)& - -VMIN(RIK,RI,RK,THIK,THI,THK)*A1(RL,RJ,RLJ,THL,THJ,THLJ)& - -VPLUS(RJ,RI,RJI,THJ,THI,THJI-PI)*A1(RK,RL,RKL,THK,THL,THKL)& - -VPLUS(RK,RI,RKI,THK,THI,THKI-PI)*A1(RJ,RL,RJL,THJ,THL,THJL)& - +VMIN(RI,RL,RIL,THI,THL,THIL)*A3(RJ,RK,RJK,THJ,THK,THJK-PI))& - +3.*W1(RL,RK,RJ,RI,THL,THK,THJ,THI) ) - - RETURN - END FUNCTION B3 -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *B4(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!----------------------------------------------------------------------- - REAL FUNCTION B4(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!*** *B4* WEIGHTS OF THE A_2^*A_3^*A_4^* PART OF THE CANONICAL -! TRANSFORMATION. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) -! -! INTERFACE. -! ---------- -! *B4(XI,XJ,XK,XL)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *XL* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - COMMON/PRECIS/DOUBLEP - LOGICAL DOUBLEP - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,& - RIJ,RIK,RIL,RJL,RJK,RKL,THIJ,THIK,THIL,THJL,THJK,THLK,THKL,& - ZIJKL -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - - - RI=XI - RJ=XJ - RK=XK - RL=XL - - OI=OMEG(RI) - OJ=OMEG(RJ) - OK=OMEG(RK) - OL=OMEG(RL) - - - RIJ = VABS(RI,RJ,THI,THJ) - THIJ = VDIR(RI,RJ,THI,THJ) - - RIK = VABS(RI,RK,THI,THK) - THIK = VDIR(RI,RK,THI,THK) - - RIL = VABS(RI,RL,THI,THL) - THIL = VDIR(RI,RL,THI,THL) - - RJL = VABS(RJ,RL,THJ,THL) - THJL = VDIR(RJ,RL,THJ,THL) - - RJK = VABS(RJ,RK,THJ,THK) - THJK = VDIR(RJ,RK,THJ,THK) - - RKL = VABS(RK,RL,THK,THL) - THKL = VDIR(RK,RL,THK,THL) - - - ZIJKL = OI+OJ+OK+OL - - B4= -1./ZIJKL*(2./3.*( & - VPLUS(RIJ,RI,RJ,THIJ-PI,THI,THJ)*A1(RKL,RK,RL,THKL,THK,THL)& - +VPLUS(RIK,RI,RK,THIK-PI,THI,THK)*A1(RJL,RJ,RL,THJL,THJ,THL)& - +VPLUS(RIL,RI,RL,THIL-PI,THI,THL)*A1(RJK,RJ,RK,THJK,THJ,THK)& - +VMIN(RIK,RI,RK,THIK,THI,THK)*A3(RJL,RJ,RL,THJL-PI,THJ,THL)& - +VMIN(RIL,RI,RL,THIL,THI,THL)*A3(RJK,RJ,RK,THJK-PI,THJ,THK)& - +VMIN(RIJ,RI,RJ,THIJ,THI,THJ)*A3(RKL,RK,RL,THKL-PI,THK,THL) )& - +W4(RI,RJ,RK,RL,THI,THJ,THK,THL) ) - - RETURN - END FUNCTION B4 -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *B1(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!----------------------------------------------------------------------- - REAL FUNCTION B1(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!*** *B1* WEIGHTS OF THE A_2A_3A_4 PART OF THE CANONICAL -! TRANSFORMATION. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) -! -! INTERFACE. -! ---------- -! *B1(XI,XJ,XK,XL)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *XL* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - COMMON/PRECIS/DOUBLEP - LOGICAL DOUBLEP - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,& - RIJ,RJI,RIK,RKI,RJL,RJK,RLI,RIL,RKL,THIJ,THJI,& - THIK,THKI,THJL,THJK,THLI,THIL,THKL,ZIJKL -! -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - - RI=XI - RJ=XJ - RK=XK - RL=XL - - OI=OMEG(RI) - OJ=OMEG(RJ) - OK=OMEG(RK) - OL=OMEG(RL) - - RIJ = VABS(RI,RJ,THI,THJ-PI) - THIJ = VDIR(RI,RJ,THI,THJ-PI) - - RJI = VABS(RJ,RI,THJ,THI-PI) - THJI = VDIR(RJ,RI,THJ,THI-PI) - - RIK = VABS(RI,RK,THI,THK-PI) - THIK = VDIR(RI,RK,THI,THK-PI) - - RKI = VABS(RK,RI,THK,THI-PI) - THKI = VDIR(RK,RI,THK,THI-PI) - - RIL = VABS(RI,RL,THI,THL-PI) - THIL = VDIR(RI,RL,THI,THL-PI) - - RLI = VABS(RL,RI,THL,THI-PI) - THLI = VDIR(RL,RI,THL,THI-PI) - - RJL = VABS(RJ,RL,THJ,THL) - THJL = VDIR(RJ,RL,THJ,THL) - - RJK = VABS(RJ,RK,THJ,THK) - THJK = VDIR(RJ,RK,THJ,THK) - - RKL = VABS(RK,RL,THK,THL) - THKL = VDIR(RK,RL,THK,THL) - - ZIJKL = OI-OJ-OK-OL - - B1= -1./ZIJKL*(2./3.*( & - MIN(RI,RJ,RIJ,THI,THJ,THIJ)*A1(RKL,RK,RL,THKL,THK,THL)& - +VMIN(RI,RK,RIK,THI,THK,THIK)*A1(RJL,RJ,RL,THJL,THJ,THL)& - +VMIN(RI,RL,RIL,THI,THL,THIL)*A1(RJK,RJ,RK,THJK,THJ,THK)& - +VMIN(RK,RI,RKI,THK,THI,THKI)*A3(RJL,RJ,RL,THJL-PI,THJ,THL)& - +VMIN(RL,RI,RLI,THL,THI,THLI)*A3(RJK,RJ,RK,THJK-PI,THJ,THK)& - +VMIN(RJ,RI,RJI,THJ,THI,THJI)*A3(RKL,RK,RL,THKL-PI,THK,THL) & - ) +W1(RI,RJ,RK,RL,THI,THJ,THK,THL) ) - RETURN - END FUNCTION B1 - -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *B2(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -!----------------------------------------------------------------------- - REAL FUNCTION B2(XI,XJ,XK,XL,THI,THJ,THK,THL) -! -! -!*** *B2* WEIGHTS OF THE A_2^*A_3A_4 PART OF THE CANONICAL -! TRANSFORMATION. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR -! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) -! -! INTERFACE. -! ---------- -! *B2(XI,XJ,XK,XL)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! *XL* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - COMMON/PRECIS/DOUBLEP - LOGICAL DOUBLEP - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,& - RIJ,RIK,RKI,RJL,RLJ,RJK,RKJ,RLI,RIL,RKL,THIJ,& - THIK,THKI,THJL,THLJ,THJK,THKJ,THLI,THIL,THKL,ZIJKL -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - - RI=XI - RJ=XJ - RK=XK - RL=XL - - RIJ = VABS(RI,RJ,THI,THJ) - THIJ = VDIR(RI,RJ,THI,THJ) - - RIK = VABS(RI,RK,THI,THK-PI) - THIK = VDIR(RI,RK,THI,THK-PI) - - RKI = VABS(RK,RI,THK,THI-PI) - THKI = VDIR(RK,RI,THK,THI-PI) - - RIL = VABS(RI,RL,THI,THL-PI) - THIL = VDIR(RI,RL,THI,THL-PI) - - RLI = VABS(RL,RI,THL,THI-PI) - THLI = VDIR(RL,RI,THL,THI-PI) - - RJL = VABS(RJ,RL,THJ,THL-PI) - THJL = VDIR(RJ,RL,THJ,THL-PI) - - RLJ = VABS(RL,RJ,THL,THJ-PI) - THLJ = VDIR(RL,RJ,THL,THJ-PI) - - RJK = VABS(RJ,RK,THJ,THK-PI) - THJK = VDIR(RJ,RK,THJ,THK-PI) - - RKJ = VABS(RK,RJ,THK,THJ-PI) - THKJ = VDIR(RK,RJ,THK,THJ-PI) - - RKL = VABS(RK,RL,THK,THL) - THKL = VDIR(RK,RL,THK,THL) - - B2= A3(RI,RJ,RIJ,THI,THJ,THIJ-PI)*A3(RK,RL,RKL,THK,THL,THKL-PI)& - +A1(RJ,RK,RJK,THJ,THK,THJK)*A1(RL,RI,RLI,THL,THI,THLI)& - +A1(RJ,RL,RJL,THJ,THL,THJL)*A1(RK,RI,RKI,THK,THI,THKI)& - -A1(RIJ,RI,RJ,THIJ,THI,THJ)*A1(RKL,RK,RL,THKL,THK,THL)& - -A1(RI,RK,RIK,THI,THK,THIK)*A1(RL,RJ,RLJ,THL,THJ,THLJ)& - -A1(RI,RL,RIL,THI,THL,THIL)*A1(RK,RJ,RKJ,THK,THJ,THKJ) - - - RETURN - END FUNCTION B2 -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *A1(XI,XJ,XK,THI,THJ,THK) -! -!----------------------------------------------------------------------- - REAL FUNCTION A1(XI,XJ,XK,THI,THJ,THK) -! -!*** *A1* AUXILIARY SECOND-ORDER COEFFICIENT. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE -! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) -! -! INTERFACE. -! ---------- -! *VMIN(XI,XJ,XK)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - COMMON/PRECIS/DOUBLEP - LOGICAL DOUBLEP - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD - REAL DEL1,XI,XJ,XK,THI,THJ,THK,OI,OJ,OK -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - IF (DOUBLEP) THEN - DEL1 = 10.**(-8) - ELSE - DEL1 = 10.**(-4) - ENDIF - - OI=OMEG(XI)+DEL1 - OJ=OMEG(XJ)+DEL1 - OK=OMEG(XK)+DEL1 - - A1 = -VMIN(XI,XJ,XK,THI,THJ,THK)/(OI-OJ-OK) - - RETURN - END FUNCTION A1 -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *A2(XI,XJ,XK,THI,THJ,THK) -! -!----------------------------------------------------------------------- - REAL FUNCTION A2(XI,XJ,XK,THI,THJ,THK) -! -!*** *A2* AUXILIARY SECOND-ORDER FUNCTION. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE -! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) -! -! INTERFACE. -! ---------- -! *VMIN(XI,XJ,XK)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - REAL DEL1,XI,XJ,XK,THI,THJ,THK -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - A2 = -2.*A1(XK,XJ,XI,THK,THJ,THI) - RETURN - END FUNCTION A2 -! -!----------------------------------------------------------------------- -! -!*** *REAL FUNCTION* *A3(XI,XJ,XK,THI,THJ,THK) -! -!----------------------------------------------------------------------- - REAL FUNCTION A3(XI,XJ,XK,THI,THJ,THK) -! -!*** *A3* AUXILIARY SECOND-ORDER FUNCTION. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE -! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE -! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) -! -! INTERFACE. -! ---------- -! *VMIN(XI,XJ,XK)* -! *XI* - WAVE NUMBER -! *XJ* - WAVE NUMBER -! *XK* - WAVE NUMBER -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/PRECIS/DOUBLEP - LOGICAL DOUBLEP - REAL DEL1,OI,OJ,OK,XI,XJ,XK,THI,THJ,THK -! -!*** 1. DETERMINE NONLINEAR TRANSFER. -! -------------------------------- -! - IF (DOUBLEP) THEN - DEL1 = 10.**(-8) - ELSE - DEL1 = 10.**(-4) - ENDIF - - - OI=OMEG(XI)+DEL1 - OJ=OMEG(XJ)+DEL1 - OK=OMEG(XK)+DEL1 - - A3 = -VPLUS(XI,XJ,XK,THI,THJ,THK)/(OI+OJ+OK) - RETURN - END FUNCTION A3 - -! -!----------------------------------------------------------------------- -! -! -!*** *REAL FUNCTION* *OMEG(X)* -! -!----------------------------------------------------------------------- -! - REAL FUNCTION OMEG(X) -! -!*** *OMEG* DETERMINES THE DISPERSION RELATION FOR GRAVITY -! WAVES. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES DISPERSION RELATION FOR GRAVITY- -! WAVES IN THE IDEAL CASE OF NO CURRENT. -! -! INTERFACE. -! ---------- -! *OMEG(X)* -! *X* - WAVE NUMBER -! -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHD - REAL D,XK,X,T - - D = DEPTH - XK = ABS(X) - T = TANH(XK*D) - OMEG=SQRT(G*XK*T) - - RETURN - END FUNCTION OMEG -! -! -!----------------------------------------------------------------------- -! -! -!*** *REAL FUNCTION* *VG(X)* -! -!----------------------------------------------------------------------- -! - REAL FUNCTION VG(X) -! -!*** *VG* DETERMINES THE GROUP VELOCITY FOR GRAVITY- WAVES. -! -! PETER JANSSEN -! -! PURPOSE. -! -------- -! -! GIVES GROUP VELOCITY FOR GRAVITY- -! WAVES IN THE IDEAL CASE OF NO CURRENT. -! -! INTERFACE. -! ---------- -! *VG(X)* -! *X* - WAVE NUMBER -! -! METHOD. -! ------- -! NONE -! -! EXTERNALS. -! ---------- -! NONE. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD - INTEGER MDW - REAL DEPTH,ALPHA,GAM_J,DEPTHD - REAL D,XK,X,XD - - D = DEPTH - XK = ABS(X) - XD = XK*DEPTH - - VG = 0.5*SQRT(G*TANH(XD)/XK)*(1.+2.*XD/SINH(2.*XD)) - - RETURN - END FUNCTION VG -!--------------------------------------------------------------------- - REAL FUNCTION AKI(OM,BETA) -! This function gives the wavenumber ... -!--------------------------------------------------------------------- -! - IMPLICIT NONE - REAL OM,BETA,G,EBS,AKM1,AKM2,AO,AKP,BO,TH,STH - - G =9.806 - EBS=0.0001 - AKM1=OM**2/(4.*G ) - AKM2=OM/(2.*SQRT(G*BETA)) - AO=MAX(AKM1,AKM2) - 10 CONTINUE - AKP=AO - BO=BETA*AO -! IF (BO.GT.10) GO TO 20 - IF (BO.GT.20.) GO TO 20 - TH=G*AO*TANH(BO) - STH=SQRT(TH) - AO=AO+(OM-STH)*STH*2./(TH/AO+G*BO/COSH(BO)**2) - IF (ABS(AKP-AO).GT.EBS*AO) GO TO 10 - AKI=AO - RETURN - 20 CONTINUE - AKI=OM**2/G - RETURN - END FUNCTION AKI -! - REAL FUNCTION VABS(XI,XJ,THI,THJ) -! -!--------------------------------------------------------------------- -! - IMPLICIT NONE - REAL XI,XJ,THI,THJ,ARG - - ARG = XI**2+XJ**2+2.*XI*XJ*COS(THI-THJ) - - IF (ARG.LE.0.) THEN - VABS = 0. - ELSE - VABS = SQRT(ARG) - ENDIF - - RETURN - END FUNCTION VABS -! - REAL FUNCTION VDIR(XI,XJ,THI,THJ) -! -!--------------------------------------------------------------------- -! - IMPLICIT NONE - REAL XI,XJ,THI,THJ,EPS,Y,X - - EPS = 0. - - Y = XJ*SIN(THJ-THI) - X = XI+XJ*COS(THJ-THI)+EPS - VDIR = ATAN2(Y,X)+THI - IF (X.EQ.0.) VDIR = 0. - - RETURN - END FUNCTION VDIR -!/ -!/ End of module W3CANOMD -------------------------------------------- / -!/ - END MODULE W3CANOMD + ENDDO + ! + DO M=1,NFRE + DO K=1,NANG + F3(K,M) = G3(K,M) + ENDDO + ENDDO + ! + !-------------------------------------------------------------------- + ! + RETURN + END SUBROUTINE SECSPOM + ! + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *A(XI,XJ,THI,THJ) + ! + !----------------------------------------------------------------------- + REAL FUNCTION A(XI,XJ,THI,THJ) + ! + !*** *A* DETERMINES THE MINUS INTERACTIONS. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE + ! WAVE INTERACTIONS OF GRAVITY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) + ! + ! INTERFACE. + ! ---------- + ! *A(XI,XJ)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL RI,RJ,RK,XI,XJ,THI,THJ,THK,OI,OJ,OK,FI,FJ,FK + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + + RI = XI + RJ = XJ + RK = VABS(RI,RJ,THI,THJ) + THK = VDIR(RI,RJ,THI,THJ) + + OI=OMEG(RI) + OJ=OMEG(RJ) + OK=OMEG(RK) + + FI = SQRT(OI/(2.*G)) + FJ = SQRT(OJ/(2.*G)) + FK = SQRT(OK/(2.*G)) + + + A = FK/(FI*FJ)*(A1(RK,RI,RJ,THK,THI,THJ)+& + A3(RK,RI,RJ,THK-PI,THI,THJ)) + + RETURN + END FUNCTION A + ! + !*** *REAL FUNCTION* *B(XI,XJ,THI,THJ) + ! + !----------------------------------------------------------------------- + REAL FUNCTION B(XI,XJ,THI,THJ) + ! + !*** *B* DETERMINES THE PLUS INTERACTION COEFFICIENTS. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE + ! WAVE INTERACTIONS OF GRAVITY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) + ! + ! INTERFACE. + ! ---------- + ! *B(XI,XJ)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL DEL,RI,RJ,RK,XI,XJ,THI,THJ,THK,OI,OJ,OK,FI,FJ,FK + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + DEL = 0. + RI = XI + RJ = XJ + RK = VABS(RJ,RI,THJ,THI-PI) + THK = VDIR(RJ,RI,THJ,THI-PI) + + OI=OMEG(RI)+DEL + OJ=OMEG(RJ)+DEL + OK=OMEG(RK)+DEL + + FI = SQRT(OI/(2.*G)) + FJ = SQRT(OJ/(2.*G)) + FK = SQRT(OK/(2.*G)) + + B = 0.5*FK/(FI*FJ)*(A2(RK,RI,RJ,THK,THI,THJ)+& + A2(RK,RJ,RI,THK-PI,THJ,THI)) + + RETURN + END FUNCTION B + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *C_QL(XK0,XK1,TH0,TH1) + ! + !----------------------------------------------------------------------- + REAL FUNCTION C_QL(XK0,XK1,TH0,TH1) + ! + !*** *A* DETERMINES THE QUASI-LINEAR TERM. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! DETERMINE CONTRIBUTION BY QUASI-LINEAR TERMS + ! + ! INTERFACE. + ! ---------- + ! *C_QL(XK0,XK1)* + ! *XK0* - WAVE NUMBER + ! *XK1* - WAVE NUMBER + ! METHOD. + ! ------- + + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL XK0,XK1,TH0,TH1,OM1,F1 + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + OM1 = OMEG(XK1) + F1 = SQRT(OM1/(2.*G)) + + C_QL = 2./F1**2*(B2(XK0,XK1,XK1,XK0,TH0,TH1,TH1,TH0)+& + B3(XK0,XK0,XK1,XK1,TH0-PI,TH0,TH1,TH1)) + + RETURN + END FUNCTION C_QL + + ! + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *VPLUS(XI,XJ,XK,THI,THJ,THK) + ! + !----------------------------------------------------------------------- + REAL FUNCTION VPLUS(XI,XJ,XK,THI,THJ,THK) + ! + !*** *VPLUS* DETERMINES THE SECOND-ORDER TRANSFER COEFFICIENT + ! FOR THREE WAVE INTERACTIONS OF GRAVITY WAVES. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE + ! WAVE INTERACTIONS OF GRAVITY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) + ! + ! INTERFACE. + ! ---------- + ! *VPLUS(XI,XJ,XK)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *THI* - WAVE DIRECTION + ! *THJ* - WAVE DIRECTION + ! *THK* - WAVE DIRECTION + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL DEL1,RI,RJ,RK,XI,XJ,XK,THI,THJ,THK,OI,OJ,OK,QI,QJ,QK,& + RIJ,RIK,RJK,SQIJK,SQIKJ,SQJKI,ZCONST + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + DEL1 = 10.**(-12) + ZCONST=1./(4*SQRT(2.)) + + RI = XI + RJ = XJ + RK = XK + + OI=OMEG(RI)+DEL1 + OJ=OMEG(RJ)+DEL1 + OK=OMEG(RK)+DEL1 + + QI=OI**2/G + QJ=OJ**2/G + QK=OK**2/G + + RIJ = RI*RJ*COS(THJ-THI) + RIK = RI*RK*COS(THK-THI) + RJK = RJ*RK*COS(THK-THJ) + + SQIJK=SQRT(G*OK/(OI*OJ)) + SQIKJ=SQRT(G*OJ/(OI*OK)) + SQJKI=SQRT(G*OI/(OJ*OK)) + + VPLUS=ZCONST*( (RIJ+QI*QJ)*SQIJK + (RIK+QI*QK)*SQIKJ& + + (RJK+QJ*QK)*SQJKI ) + RETURN + END FUNCTION VPLUS + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *VMIN(XI,XJ,XK,THI,THJ,THK) + ! + !----------------------------------------------------------------------- + REAL FUNCTION VMIN(XI,XJ,XK,THI,THJ,THK) + ! + !*** *VMIN* DETERMINES THE SECOND-ORDER TRANSFER COEFFICIENT FOR + ! THREE WAVE INTERACTIONS OF GRAVITY WAVES. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE + ! WAVE INTERACTIONS OF GRAVITY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) + ! + ! INTERFACE. + ! ---------- + ! *VMIN(XI,XJ,XK)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *THI* - WAVE DIRECTION + ! *THJ* - WAVE DIRECTION + ! *THK* - WAVE DIRECTION + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL DEL1,RI,RJ,RK,XI,XJ,XK,THI,THJ,THK,OI,OJ,OK,QI,QJ,QK,& + RIJ,RIK,RJK,SQIJK,SQIKJ,SQJKI,ZCONST + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + DEL1 = 10.**(-12) + ZCONST=1./(4*SQRT(2.)) + + RI = XI + RJ = XJ + RK = XK + + OI=OMEG(RI)+DEL1 + OJ=OMEG(RJ)+DEL1 + OK=OMEG(RK)+DEL1 + + QI=OI**2/G + QJ=OJ**2/G + QK=OK**2/G + + RIJ = RI*RJ*COS(THJ-THI) + RIK = RI*RK*COS(THK-THI) + RJK = RJ*RK*COS(THK-THJ) + + SQIJK=SQRT(G*OK/(OI*OJ)) + SQIKJ=SQRT(G*OJ/(OI*OK)) + SQJKI=SQRT(G*OI/(OJ*OK)) + + VMIN=ZCONST*( (RIJ-QI*QJ)*SQIJK + (RIK-QI*QK)*SQIKJ& + + (RJK+QJ*QK)*SQJKI ) + RETURN + END FUNCTION VMIN + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *U(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !----------------------------------------------------------------------- + REAL FUNCTION U(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !*** *U* DETERMINES THE THIRD-ORDER TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY WAVES. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) + ! + ! INTERFACE. + ! ---------- + ! *U(XI,XJ,XK,XL)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *XL* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,XIK,XJK,XIL,XJL,& + OIK,OJK,OIL,OJL,QI,QJ,QIK,QJK,QIL,QJL,SQIJKL,ZCONST + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + ZCONST=1./(16.) + + OI=OMEG(XI) + OJ=OMEG(XJ) + OK=OMEG(XK) + OL=OMEG(XL) + + XIK = VABS(XI,XK,THI,THK) + XJK = VABS(XJ,XK,THJ,THK) + XIL = VABS(XI,XL,THI,THL) + XJL = VABS(XJ,XL,THJ,THL) + OIK=OMEG(XIK) + OJK=OMEG(XJK) + OIL=OMEG(XIL) + OJL=OMEG(XJL) + + QI=OI**2/G + QJ=OJ**2/G + QIK=OIK**2/G + QJK=OJK**2/G + QIL=OIL**2/G + QJL=OJL**2/G + SQIJKL=SQRT(OK*OL/(OI*OJ)) + U = ZCONST*SQIJKL*( 2.*(XI**2*QJ+XJ**2*QI)-QI*QJ*(& + QIK+QJK+QIL+QJL) ) + RETURN + END FUNCTION U + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *W2(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !----------------------------------------------------------------------- + REAL FUNCTION W2(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !*** *W2* DETERMINES THE CONTRIBUTION OF THE DIRECT FOUR-WAVE + ! INTERACTIONS OF GRAVITY WAVES OF THE TYPE + ! A_2^*A_3A_4. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) + ! + ! INTERFACE. + ! ---------- + ! *W(XI,XJ,XK,XL)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *XL* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + REAL XI,XJ,XK,XL,THI,THJ,THK,THL + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + W2= U(XI,XJ,XK,XL,THI-PI,THJ-PI,THK,THL)+& + U(XK,XL,XI,XJ,THK,THL,THI-PI,THJ-PI)-& + U(XK,XJ,XI,XL,THK,THJ-PI,THI-PI,THL)-& + U(XI,XK,XJ,XL,THI-PI,THK,THJ-PI,THL)-& + U(XI,XL,XK,XJ,THI-PI,THL,THK,THJ-PI)-& + U(XL,XJ,XK,XI,THL,THJ-PI,THK,THI-PI) + RETURN + END FUNCTION W2 + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *V2(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !----------------------------------------------------------------------- + REAL FUNCTION V2(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !*** *V2* DETERMINES THE CONTRIBUTION OF THE VIRTUAL + ! FOUR-WAVE INTERACTIONS OF GRAVITY WAVES. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND + ! CRAWFORD ET AL) + ! + ! INTERFACE. + ! ---------- + ! *V2(XI,XJ,XK,XL)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *XL* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + COMMON/PRECIS/DOUBLEP + LOGICAL DOUBLEP + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,& + RIJ,RIK,RLI,RJL,RJK,RKL,THIJ,THIK,THLI,THJL,THJK,THKL,OIJ,& + OIK,OJL,OJK,OLI,OKL,XNIK,XNJL,XNJK,XNIL,YNIL,YNJK,YNJL,YNIK,& + ZNIJ,ZNKL,ZPIJ,ZPKL,THLJ,THIL,THKJ,THKI,THJI,THLK + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + IF (DOUBLEP) THEN + DEL1=10.**(-5) + ELSE + DEL1=10.**(-2) + ENDIF + + + RI=XI+DEL1 + RJ=XJ+DEL1/2. + RK=XK+DEL1/3. + RL=XL+DEL1*(1.+1./2.-1./3.) + + OI=OMEG(RI) + OJ=OMEG(RJ) + OK=OMEG(RK) + OL=OMEG(RL) + + RIJ = VABS(RI,RJ,THI,THJ) + THIJ = VDIR(RI,RJ,THI,THJ) + + RIK = VABS(RI,RK,THI,THK-PI) + THIK = VDIR(RI,RK,THI,THK-PI) + + RLI = VABS(RL,RI,THL,THI-PI) + THLI = VDIR(XL,XI,THL,THI-PI) + + RJL = VABS(RJ,RL,THJ,THL-PI) + THJL = VDIR(RJ,RL,THJ,THL-PI) + + RJK = VABS(RJ,RK,THJ,THK-PI) + THJK = VDIR(RJ,RK,THJ,THK-PI) + + RKL = VABS(RK,RL,THK,THL) + THKL = VDIR(RK,RL,THK,THL) + + OIJ=OMEG(RIJ) + OIK=OMEG(RIK) + OJL=OMEG(RJL) + OJK=OMEG(RJK) + OLI=OMEG(RLI) + OKL=OMEG(RKL) + + XNIK = OK+OIK-OI + XNJL = OJ+OJL-OL + XNJK = OK+OJK-OJ + XNIL = OI+OLI-OL + + YNIL = OL+OLI-OI + YNJK = OJ+OJK-OK + YNJL = OL+OJL-OJ + YNIK = OI+OIK-OK + + ZNIJ = OIJ-OI-OJ + ZNKL = OKL-OK-OL + ZPIJ = OIJ+OI+OJ + ZPKL = OKL+OK+OL + + THLJ = THJL-PI + THIL = THLI-PI + THKJ = THJK-PI + THKI = THIK-PI + THJI = THIJ-PI + THLK = THKL-PI + + V2= VMIN(RI,RK,RIK,THI,THK,THIK)*VMIN(RL,RJ,RJL,THL,THJ,THLJ)*& + (1./XNIK+1./XNJL)& + +VMIN(RJ,RK,RJK,THJ,THK,THJK)*VMIN(RL,RI,RLI,THL,THI,THLI)*& + (1./XNJK+1./XNIL)& + +VMIN(RI,RL,RLI,THI,THL,THIL)*VMIN(RK,RJ,RJK,THK,THJ,THKJ)*& + (1./YNIL+1./YNJK)& + +VMIN(RJ,RL,RJL,THJ,THL,THJL)*VMIN(RK,RI,RIK,THK,THI,THKI)*& + (1./YNJL+1./YNIK)& + +VMIN(RIJ,RI,RJ,THIJ,THI,THJ)*VMIN(RKL,RK,RL,THKL,THK,THL)*& + (1./ZNIJ+1./ZNKL)& + +VPLUS(RIJ,RI,RJ,THJI,THI,THJ)*VPLUS(RKL,RK,RL,THLK,THK,THL)*& + (1./ZPIJ+1./ZPKL) + + V2 = -V2 + + RETURN + END FUNCTION V2 + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *W1(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !----------------------------------------------------------------------- + REAL FUNCTION W1(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !*** *W1* DETERMINES THE NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY WAVES OF THE TYPE + ! A_2A_3A_4. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) + ! + ! INTERFACE. + ! ---------- + ! *W1(XI,XJ,XK,XL)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *XL* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL XI,XJ,XK,XL,THI,THJ,THK,THL + ! + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + W1= -U(XI,XJ,XK,XL,THI-PI,THJ,THK,THL)-& + U(XI,XK,XJ,XL,THI-PI,THK,THJ,THL)-& + U(XI,XL,XJ,XK,THI-PI,THL,THJ,THK)+& + U(XJ,XK,XI,XL,THJ,THK,THI-PI,THL)+& + U(XJ,XL,XI,XK,THJ,THL,THI-PI,THK)+& + U(XK,XL,XI,XJ,THK,THL,THI-PI,THJ) + + W1=W1/3. + + RETURN + END FUNCTION W1 + ! + !*** *REAL FUNCTION* *W4(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !----------------------------------------------------------------------- + REAL FUNCTION W4(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !*** *W4* DETERMINES THE NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY WAVES of the type + ! A_^*A_3^*A_4^*. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) + ! + ! INTERFACE. + ! ---------- + ! *W4(XI,XJ,XK,XL)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *XL* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL XI,XJ,XK,XL,THI,THJ,THK,THL + ! + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + + W4= U(XI,XJ,XK,XL,THI,THJ,THK,THL)+& + U(XI,XK,XJ,XL,THI,THK,THJ,THL)+& + U(XI,XL,XJ,XK,THI,THL,THJ,THK)+& + U(XJ,XK,XI,XL,THJ,THK,THI,THL)+& + U(XJ,XL,XI,XK,THJ,THL,THI,THK)+& + U(XK,XL,XI,XJ,THK,THL,THI,THJ) + + + W4=W4/3. + + RETURN + END FUNCTION W4 + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *B3(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !----------------------------------------------------------------------- + REAL FUNCTION B3(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !*** *B3* WEIGHTS OF THE A_2^*A_3^*A_4 PART OF THE + ! CANONICAL TRANSFORMATION. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) + ! + ! INTERFACE. + ! ---------- + ! *B3(XI,XJ,XK,XL)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *XL* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + COMMON/PRECIS/DOUBLEP + LOGICAL DOUBLEP + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,& + RIJ,RJI,RIK,RKI,RLJ,RJL,RJK,RKJ,RLI,RIL,RLK,RKL,THIJ,THJI,& + THIK,THKI,THLJ,THJL,THJK,THKJ,THLI,THIL,THLK,THKL,ZIJKL + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + IF (DOUBLEP) THEN + DEL1=10.**(-5) + ELSE + DEL1=0.01 + ENDIF + + RI=XI + RJ=XJ + RK=XK + RL=XL + + OI=OMEG(RI)+DEL1 + OJ=OMEG(RJ)+DEL1 + OK=OMEG(RK)+DEL1 + OL=OMEG(RL)+DEL1 + + RIJ = VABS(RI,RJ,THI,THJ) + THIJ = VDIR(RI,RJ,THI,THJ) + + RJI = VABS(RJ,RI,THJ,THI) + THJI = VDIR(RJ,RI,THJ,THI) + + RIK = VABS(RI,RK,THI,THK) + THIK = VDIR(RI,RK,THI,THK) + + RKI = VABS(RK,RI,THK,THI) + THKI = VDIR(RK,RI,THK,THI) + + RLJ = VABS(RL,RJ,THL,THJ-PI) + THLJ = VDIR(RL,RJ,THL,THJ-PI) + + RJL = VABS(RJ,RL,THJ,THL-PI) + THJL = VDIR(RJ,RL,THJ,THL-PI) + + RJK = VABS(RJ,RK,THJ,THK) + THJK = VDIR(RJ,RK,THJ,THK) + + RKJ = VABS(RK,RJ,THK,THJ) + THKJ = VDIR(RK,RJ,THK,THJ) + + RLI = VABS(RL,RI,THL,THI-PI) + THLI = VDIR(RL,RI,THL,THI-PI) + + RIL = VABS(RI,RL,THI,THL-PI) + THIL = VDIR(RI,RL,THI,THL-PI) + + RLK = VABS(RL,RK,THL,THK-PI) + THLK = VDIR(RL,RK,THL,THK-PI) + + RKL = VABS(RK,RL,THK,THL-PI) + THKL = VDIR(RK,RL,THK,THL-PI) + + ZIJKL = OI+OJ+OK-OL + + B3= -1./ZIJKL*(2.*( & + VMIN(RL,RI,RLI,THL,THI,THLI)*A1(RJK,RJ,RK,THJK,THJ,THK)& + -VMIN(RIJ,RI,RJ,THIJ,THI,THJ)*A1(RL,RK,RLK,THL,THK,THLK)& + -VMIN(RIK,RI,RK,THIK,THI,THK)*A1(RL,RJ,RLJ,THL,THJ,THLJ)& + -VPLUS(RJ,RI,RJI,THJ,THI,THJI-PI)*A1(RK,RL,RKL,THK,THL,THKL)& + -VPLUS(RK,RI,RKI,THK,THI,THKI-PI)*A1(RJ,RL,RJL,THJ,THL,THJL)& + +VMIN(RI,RL,RIL,THI,THL,THIL)*A3(RJ,RK,RJK,THJ,THK,THJK-PI))& + +3.*W1(RL,RK,RJ,RI,THL,THK,THJ,THI) ) + + RETURN + END FUNCTION B3 + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *B4(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !----------------------------------------------------------------------- + REAL FUNCTION B4(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !*** *B4* WEIGHTS OF THE A_2^*A_3^*A_4^* PART OF THE CANONICAL + ! TRANSFORMATION. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) + ! + ! INTERFACE. + ! ---------- + ! *B4(XI,XJ,XK,XL)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *XL* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + COMMON/PRECIS/DOUBLEP + LOGICAL DOUBLEP + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,& + RIJ,RIK,RIL,RJL,RJK,RKL,THIJ,THIK,THIL,THJL,THJK,THLK,THKL,& + ZIJKL + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + + + RI=XI + RJ=XJ + RK=XK + RL=XL + + OI=OMEG(RI) + OJ=OMEG(RJ) + OK=OMEG(RK) + OL=OMEG(RL) + + + RIJ = VABS(RI,RJ,THI,THJ) + THIJ = VDIR(RI,RJ,THI,THJ) + + RIK = VABS(RI,RK,THI,THK) + THIK = VDIR(RI,RK,THI,THK) + + RIL = VABS(RI,RL,THI,THL) + THIL = VDIR(RI,RL,THI,THL) + + RJL = VABS(RJ,RL,THJ,THL) + THJL = VDIR(RJ,RL,THJ,THL) + + RJK = VABS(RJ,RK,THJ,THK) + THJK = VDIR(RJ,RK,THJ,THK) + + RKL = VABS(RK,RL,THK,THL) + THKL = VDIR(RK,RL,THK,THL) + + + ZIJKL = OI+OJ+OK+OL + + B4= -1./ZIJKL*(2./3.*( & + VPLUS(RIJ,RI,RJ,THIJ-PI,THI,THJ)*A1(RKL,RK,RL,THKL,THK,THL)& + +VPLUS(RIK,RI,RK,THIK-PI,THI,THK)*A1(RJL,RJ,RL,THJL,THJ,THL)& + +VPLUS(RIL,RI,RL,THIL-PI,THI,THL)*A1(RJK,RJ,RK,THJK,THJ,THK)& + +VMIN(RIK,RI,RK,THIK,THI,THK)*A3(RJL,RJ,RL,THJL-PI,THJ,THL)& + +VMIN(RIL,RI,RL,THIL,THI,THL)*A3(RJK,RJ,RK,THJK-PI,THJ,THK)& + +VMIN(RIJ,RI,RJ,THIJ,THI,THJ)*A3(RKL,RK,RL,THKL-PI,THK,THL) )& + +W4(RI,RJ,RK,RL,THI,THJ,THK,THL) ) + + RETURN + END FUNCTION B4 + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *B1(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !----------------------------------------------------------------------- + REAL FUNCTION B1(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !*** *B1* WEIGHTS OF THE A_2A_3A_4 PART OF THE CANONICAL + ! TRANSFORMATION. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) + ! + ! INTERFACE. + ! ---------- + ! *B1(XI,XJ,XK,XL)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *XL* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + COMMON/PRECIS/DOUBLEP + LOGICAL DOUBLEP + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,& + RIJ,RJI,RIK,RKI,RJL,RJK,RLI,RIL,RKL,THIJ,THJI,& + THIK,THKI,THJL,THJK,THLI,THIL,THKL,ZIJKL + ! + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + + RI=XI + RJ=XJ + RK=XK + RL=XL + + OI=OMEG(RI) + OJ=OMEG(RJ) + OK=OMEG(RK) + OL=OMEG(RL) + + RIJ = VABS(RI,RJ,THI,THJ-PI) + THIJ = VDIR(RI,RJ,THI,THJ-PI) + + RJI = VABS(RJ,RI,THJ,THI-PI) + THJI = VDIR(RJ,RI,THJ,THI-PI) + + RIK = VABS(RI,RK,THI,THK-PI) + THIK = VDIR(RI,RK,THI,THK-PI) + + RKI = VABS(RK,RI,THK,THI-PI) + THKI = VDIR(RK,RI,THK,THI-PI) + + RIL = VABS(RI,RL,THI,THL-PI) + THIL = VDIR(RI,RL,THI,THL-PI) + + RLI = VABS(RL,RI,THL,THI-PI) + THLI = VDIR(RL,RI,THL,THI-PI) + + RJL = VABS(RJ,RL,THJ,THL) + THJL = VDIR(RJ,RL,THJ,THL) + + RJK = VABS(RJ,RK,THJ,THK) + THJK = VDIR(RJ,RK,THJ,THK) + + RKL = VABS(RK,RL,THK,THL) + THKL = VDIR(RK,RL,THK,THL) + + ZIJKL = OI-OJ-OK-OL + + B1= -1./ZIJKL*(2./3.*( & + MIN(RI,RJ,RIJ,THI,THJ,THIJ)*A1(RKL,RK,RL,THKL,THK,THL)& + +VMIN(RI,RK,RIK,THI,THK,THIK)*A1(RJL,RJ,RL,THJL,THJ,THL)& + +VMIN(RI,RL,RIL,THI,THL,THIL)*A1(RJK,RJ,RK,THJK,THJ,THK)& + +VMIN(RK,RI,RKI,THK,THI,THKI)*A3(RJL,RJ,RL,THJL-PI,THJ,THL)& + +VMIN(RL,RI,RLI,THL,THI,THLI)*A3(RJK,RJ,RK,THJK-PI,THJ,THK)& + +VMIN(RJ,RI,RJI,THJ,THI,THJI)*A3(RKL,RK,RL,THKL-PI,THK,THL) & + ) +W1(RI,RJ,RK,RL,THI,THJ,THK,THL) ) + RETURN + END FUNCTION B1 + + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *B2(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + !----------------------------------------------------------------------- + REAL FUNCTION B2(XI,XJ,XK,XL,THI,THJ,THK,THL) + ! + ! + !*** *B2* WEIGHTS OF THE A_2^*A_3A_4 PART OF THE CANONICAL + ! TRANSFORMATION. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR + ! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL) + ! + ! INTERFACE. + ! ---------- + ! *B2(XI,XJ,XK,XL)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! *XL* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + COMMON/PRECIS/DOUBLEP + LOGICAL DOUBLEP + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,& + RIJ,RIK,RKI,RJL,RLJ,RJK,RKJ,RLI,RIL,RKL,THIJ,& + THIK,THKI,THJL,THLJ,THJK,THKJ,THLI,THIL,THKL,ZIJKL + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + + RI=XI + RJ=XJ + RK=XK + RL=XL + + RIJ = VABS(RI,RJ,THI,THJ) + THIJ = VDIR(RI,RJ,THI,THJ) + + RIK = VABS(RI,RK,THI,THK-PI) + THIK = VDIR(RI,RK,THI,THK-PI) + + RKI = VABS(RK,RI,THK,THI-PI) + THKI = VDIR(RK,RI,THK,THI-PI) + + RIL = VABS(RI,RL,THI,THL-PI) + THIL = VDIR(RI,RL,THI,THL-PI) + + RLI = VABS(RL,RI,THL,THI-PI) + THLI = VDIR(RL,RI,THL,THI-PI) + + RJL = VABS(RJ,RL,THJ,THL-PI) + THJL = VDIR(RJ,RL,THJ,THL-PI) + + RLJ = VABS(RL,RJ,THL,THJ-PI) + THLJ = VDIR(RL,RJ,THL,THJ-PI) + + RJK = VABS(RJ,RK,THJ,THK-PI) + THJK = VDIR(RJ,RK,THJ,THK-PI) + + RKJ = VABS(RK,RJ,THK,THJ-PI) + THKJ = VDIR(RK,RJ,THK,THJ-PI) + + RKL = VABS(RK,RL,THK,THL) + THKL = VDIR(RK,RL,THK,THL) + + B2= A3(RI,RJ,RIJ,THI,THJ,THIJ-PI)*A3(RK,RL,RKL,THK,THL,THKL-PI)& + +A1(RJ,RK,RJK,THJ,THK,THJK)*A1(RL,RI,RLI,THL,THI,THLI)& + +A1(RJ,RL,RJL,THJ,THL,THJL)*A1(RK,RI,RKI,THK,THI,THKI)& + -A1(RIJ,RI,RJ,THIJ,THI,THJ)*A1(RKL,RK,RL,THKL,THK,THL)& + -A1(RI,RK,RIK,THI,THK,THIK)*A1(RL,RJ,RLJ,THL,THJ,THLJ)& + -A1(RI,RL,RIL,THI,THL,THIL)*A1(RK,RJ,RKJ,THK,THJ,THKJ) + + + RETURN + END FUNCTION B2 + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *A1(XI,XJ,XK,THI,THJ,THK) + ! + !----------------------------------------------------------------------- + REAL FUNCTION A1(XI,XJ,XK,THI,THJ,THK) + ! + !*** *A1* AUXILIARY SECOND-ORDER COEFFICIENT. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE + ! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) + ! + ! INTERFACE. + ! ---------- + ! *VMIN(XI,XJ,XK)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + COMMON/PRECIS/DOUBLEP + LOGICAL DOUBLEP + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD + REAL DEL1,XI,XJ,XK,THI,THJ,THK,OI,OJ,OK + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + IF (DOUBLEP) THEN + DEL1 = 10.**(-8) + ELSE + DEL1 = 10.**(-4) + ENDIF + + OI=OMEG(XI)+DEL1 + OJ=OMEG(XJ)+DEL1 + OK=OMEG(XK)+DEL1 + + A1 = -VMIN(XI,XJ,XK,THI,THJ,THK)/(OI-OJ-OK) + + RETURN + END FUNCTION A1 + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *A2(XI,XJ,XK,THI,THJ,THK) + ! + !----------------------------------------------------------------------- + REAL FUNCTION A2(XI,XJ,XK,THI,THJ,THK) + ! + !*** *A2* AUXILIARY SECOND-ORDER FUNCTION. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE + ! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) + ! + ! INTERFACE. + ! ---------- + ! *VMIN(XI,XJ,XK)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + REAL DEL1,XI,XJ,XK,THI,THJ,THK + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + A2 = -2.*A1(XK,XJ,XI,THK,THJ,THI) + RETURN + END FUNCTION A2 + ! + !----------------------------------------------------------------------- + ! + !*** *REAL FUNCTION* *A3(XI,XJ,XK,THI,THJ,THK) + ! + !----------------------------------------------------------------------- + REAL FUNCTION A3(XI,XJ,XK,THI,THJ,THK) + ! + !*** *A3* AUXILIARY SECOND-ORDER FUNCTION. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE + ! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE + ! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV) + ! + ! INTERFACE. + ! ---------- + ! *VMIN(XI,XJ,XK)* + ! *XI* - WAVE NUMBER + ! *XJ* - WAVE NUMBER + ! *XK* - WAVE NUMBER + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/PRECIS/DOUBLEP + LOGICAL DOUBLEP + REAL DEL1,OI,OJ,OK,XI,XJ,XK,THI,THJ,THK + ! + !*** 1. DETERMINE NONLINEAR TRANSFER. + ! -------------------------------- + ! + IF (DOUBLEP) THEN + DEL1 = 10.**(-8) + ELSE + DEL1 = 10.**(-4) + ENDIF + + + OI=OMEG(XI)+DEL1 + OJ=OMEG(XJ)+DEL1 + OK=OMEG(XK)+DEL1 + + A3 = -VPLUS(XI,XJ,XK,THI,THJ,THK)/(OI+OJ+OK) + RETURN + END FUNCTION A3 + + ! + !----------------------------------------------------------------------- + ! + ! + !*** *REAL FUNCTION* *OMEG(X)* + ! + !----------------------------------------------------------------------- + ! + REAL FUNCTION OMEG(X) + ! + !*** *OMEG* DETERMINES THE DISPERSION RELATION FOR GRAVITY + ! WAVES. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES DISPERSION RELATION FOR GRAVITY- + ! WAVES IN THE IDEAL CASE OF NO CURRENT. + ! + ! INTERFACE. + ! ---------- + ! *OMEG(X)* + ! *X* - WAVE NUMBER + ! + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHD + REAL D,XK,X,T + + D = DEPTH + XK = ABS(X) + T = TANH(XK*D) + OMEG=SQRT(G*XK*T) + + RETURN + END FUNCTION OMEG + ! + ! + !----------------------------------------------------------------------- + ! + ! + !*** *REAL FUNCTION* *VG(X)* + ! + !----------------------------------------------------------------------- + ! + REAL FUNCTION VG(X) + ! + !*** *VG* DETERMINES THE GROUP VELOCITY FOR GRAVITY- WAVES. + ! + ! PETER JANSSEN + ! + ! PURPOSE. + ! -------- + ! + ! GIVES GROUP VELOCITY FOR GRAVITY- + ! WAVES IN THE IDEAL CASE OF NO CURRENT. + ! + ! INTERFACE. + ! ---------- + ! *VG(X)* + ! *X* - WAVE NUMBER + ! + ! METHOD. + ! ------- + ! NONE + ! + ! EXTERNALS. + ! ---------- + ! NONE. + ! + !----------------------------------------------------------------------- + ! + IMPLICIT NONE + COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD + INTEGER MDW + REAL DEPTH,ALPHA,GAM_J,DEPTHD + REAL D,XK,X,XD + + D = DEPTH + XK = ABS(X) + XD = XK*DEPTH + + VG = 0.5*SQRT(G*TANH(XD)/XK)*(1.+2.*XD/SINH(2.*XD)) + + RETURN + END FUNCTION VG + !--------------------------------------------------------------------- + REAL FUNCTION AKI(OM,BETA) + ! This function gives the wavenumber ... + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + REAL OM,BETA,G,EBS,AKM1,AKM2,AO,AKP,BO,TH,STH + + G =9.806 + EBS=0.0001 + AKM1=OM**2/(4.*G ) + AKM2=OM/(2.*SQRT(G*BETA)) + AO=MAX(AKM1,AKM2) +10 CONTINUE + AKP=AO + BO=BETA*AO + ! IF (BO.GT.10) GO TO 20 + IF (BO.GT.20.) GO TO 20 + TH=G*AO*TANH(BO) + STH=SQRT(TH) + AO=AO+(OM-STH)*STH*2./(TH/AO+G*BO/COSH(BO)**2) + IF (ABS(AKP-AO).GT.EBS*AO) GO TO 10 + AKI=AO + RETURN +20 CONTINUE + AKI=OM**2/G + RETURN + END FUNCTION AKI + ! + REAL FUNCTION VABS(XI,XJ,THI,THJ) + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + REAL XI,XJ,THI,THJ,ARG + + ARG = XI**2+XJ**2+2.*XI*XJ*COS(THI-THJ) + + IF (ARG.LE.0.) THEN + VABS = 0. + ELSE + VABS = SQRT(ARG) + ENDIF + + RETURN + END FUNCTION VABS + ! + REAL FUNCTION VDIR(XI,XJ,THI,THJ) + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + REAL XI,XJ,THI,THJ,EPS,Y,X + + EPS = 0. + + Y = XJ*SIN(THJ-THI) + X = XI+XJ*COS(THJ-THI)+EPS + VDIR = ATAN2(Y,X)+THI + IF (X.EQ.0.) VDIR = 0. + + RETURN + END FUNCTION VDIR + !/ + !/ End of module W3CANOMD -------------------------------------------- / + !/ +END MODULE W3CANOMD diff --git a/model/src/w3cspcmd.F90 b/model/src/w3cspcmd.F90 index c4bbfc78a..a8129242f 100644 --- a/model/src/w3cspcmd.F90 +++ b/model/src/w3cspcmd.F90 @@ -1,6 +1,6 @@ -!> @file +!> @file !> @brief Convert spectra to new discrete spectral grid. -!> +!> !> @author H. L. Tolman !> @date 01-Nov-2012 !> @@ -9,7 +9,7 @@ !/ ------------------------------------------------------------------- / !> !> @brief Convert spectra to new discrete spectral grid. -!> +!> !> @author H. L. Tolman !> @date 01-Nov-2012 !> @@ -18,591 +18,591 @@ !> reserved. WAVEWATCH III is a trademark of the NWS. !> No unauthorized use without permission. !> - MODULE W3CSPCMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Nov-2012 | -!/ +-----------------------------------+ -!/ -!/ 19-Sep-2005 : Origination. ( version 3.08 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 01-Nov-2012 : Minor code clean-up (tabs & coments)( version 4.08 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Convert spectra to new discrete spectral grid. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NCASES Int. Private Number of cases for which interpol. -! data is stored. -! IDATA CASE Private Interpolation data. -! ---------------------------------------------------------------- -! -! Elements of the data structure CASE are given below. The middle -! block pf parameters has pointer aliasses with the same name in -! the subroutine. -! -! Name Type Description -! ---------------------------------------------------------------- -! ICASE Int. Number of case. -! NFR1, NTH1, NFR2, NTH2, XF1, FR1, TH1, XF2, FR2, TH2 -! Same as in parameter list of routine. -! -! DTH1 Real Directional increment. -! DTH2 Real Directional increment. -! IDTH I.A. Index information for redistribution of -! energy in direction space. -! RDTH R.A. Factors corresponding to IDTH. -! FRQ1 R.A. Frequencies. -! FRQ2 R.A. Frequencies. -! XDF1 Real Factor for increments. -! XDF2 Real Factor for increments. -! NFR2T Int. Frequency to start the tail. -! IDFR I.A. Idem for frequencies. -! RDFR R.A. Factors corresponding to IDFR. -! -! NEXT CASE Pointer to next data set stored. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3CSPC Subr. Public Perform conversion for vector of -! spectra. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine W3CSPC. -! -! 5. Remarks : -! -! - Conversion data are sored in an endless linked chain, which -! is tested at the beginning of the routine. -! -! 6. Switches : -! -! See subroutine. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - TYPE CASE - INTEGER :: ICASE, NFR1, NTH1, NFR2, NTH2, NFR2T - REAL :: XF1, FR1, TH1, XF2, FR2, TH2, & - DTH1, DTH2, XDF1, XDF2 - INTEGER, POINTER :: IDTH(:,:), IDFR(:,:) - REAL, POINTER :: RDTH(:,:), FRQ1(:), FRQ2(:), RDFR(:,:) - TYPE(CASE), POINTER :: NEXT - END TYPE CASE -!/ - INTEGER, PRIVATE :: NCASES = 0 - TYPE(CASE), PRIVATE, POINTER :: IDATA -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Convert a set of spectra to a new spectral grid. -!> -!> @details Conservative distribution of input energies over new grid. -!> -!> @param[in] SP1 Input spectra. -!> @param[in] NFR1 Input number of frequencies. -!> @param[in] NTH1 Input number of directions. -!> @param[in] XF1 Input frequency increment factor. -!> @param[in] FR1 First input frequency. -!> @param[in] TH1 First input direction. -!> @param[out] SP2 Output spectra. -!> @param[in] NFR2 Output number of frequencies. -!> @param[in] NTH2 Output number of directions. -!> @param[in] XF2 Output frequency increment factor. -!> @param[in] FR2 First output frequency. -!> @param[in] TH2 First output direction. -!> @param[in] NSP Number of spectra. -!> @param[in] NDST Unit number for test output. -!> @param[in] NDSE Unit number for error output. -!> @param[in] FTL Factor for tail description = XF2**N. -!> -!> @author H. L. Tolman -!> @date 01-Nov-2012 -!> - SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & - SP2, NFR2, NTH2, XF2, FR2, TH2, & - NSP, NDST, NDSE, FTL ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Nov-2012 ! -!/ +-----------------------------------+ -!/ -!/ 19-Sep-2005 : Origination. ( version 3.08 ) -!/ 01-Nov-2012 : code clean up (tab spaces, comments)( version 4.08 ) -!/ -! 1. Purpose : -! -! Convert a set of spectra to a new spectral grid. -! -! 2. Method : -! -! Conservative distribution of input energies over new grid. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! SP1 R.A. I Input spectra. -! NFR1 Int. I Input number of frequencies. -! NTH1 Int. I Input number of directions. -! XFR Real I Input frequency increment factor. -! FR1 Real I First input frequency. -! TH1 Real I First input direction. -! SP2 R.A. O Output spectra. -! NFR2, NTH2, XF2, FR2, TH2 -! ! Specral description for output spectra. -! NSP Int. I Number of spectra. -! NDST int. I Unit number for test output. -! NDSE int. I Unit number for error output. -! FTAIL Real I Factor for tail description = XF2**N -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! EXTCDE Sur. Id program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOBC Subr. W3IOBCMD Updating boundary conditions. -! Subr Multi scale model bound. data input. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! -! 7. Remarks : -! -! - The inner loop of the actual redistribution is over the -! individual spectra, optimizing this routine for large numbers -! of conversions in a single call. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! !/T Enable test output. -! !/T1 Test output for searching in stored data. -! !/T2 Test output for redistribution data. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -! - USE W3SERVMD, ONLY: EXTCDE +MODULE W3CSPCMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Nov-2012 | + !/ +-----------------------------------+ + !/ + !/ 19-Sep-2005 : Origination. ( version 3.08 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 01-Nov-2012 : Minor code clean-up (tabs & coments)( version 4.08 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Convert spectra to new discrete spectral grid. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NCASES Int. Private Number of cases for which interpol. + ! data is stored. + ! IDATA CASE Private Interpolation data. + ! ---------------------------------------------------------------- + ! + ! Elements of the data structure CASE are given below. The middle + ! block pf parameters has pointer aliasses with the same name in + ! the subroutine. + ! + ! Name Type Description + ! ---------------------------------------------------------------- + ! ICASE Int. Number of case. + ! NFR1, NTH1, NFR2, NTH2, XF1, FR1, TH1, XF2, FR2, TH2 + ! Same as in parameter list of routine. + ! + ! DTH1 Real Directional increment. + ! DTH2 Real Directional increment. + ! IDTH I.A. Index information for redistribution of + ! energy in direction space. + ! RDTH R.A. Factors corresponding to IDTH. + ! FRQ1 R.A. Frequencies. + ! FRQ2 R.A. Frequencies. + ! XDF1 Real Factor for increments. + ! XDF2 Real Factor for increments. + ! NFR2T Int. Frequency to start the tail. + ! IDFR I.A. Idem for frequencies. + ! RDFR R.A. Factors corresponding to IDFR. + ! + ! NEXT CASE Pointer to next data set stored. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3CSPC Subr. Public Perform conversion for vector of + ! spectra. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine W3CSPC. + ! + ! 5. Remarks : + ! + ! - Conversion data are sored in an endless linked chain, which + ! is tested at the beginning of the routine. + ! + ! 6. Switches : + ! + ! See subroutine. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + TYPE CASE + INTEGER :: ICASE, NFR1, NTH1, NFR2, NTH2, NFR2T + REAL :: XF1, FR1, TH1, XF2, FR2, TH2, & + DTH1, DTH2, XDF1, XDF2 + INTEGER, POINTER :: IDTH(:,:), IDFR(:,:) + REAL, POINTER :: RDTH(:,:), FRQ1(:), FRQ2(:), RDFR(:,:) + TYPE(CASE), POINTER :: NEXT + END TYPE CASE + !/ + INTEGER, PRIVATE :: NCASES = 0 + TYPE(CASE), PRIVATE, POINTER :: IDATA + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Convert a set of spectra to a new spectral grid. + !> + !> @details Conservative distribution of input energies over new grid. + !> + !> @param[in] SP1 Input spectra. + !> @param[in] NFR1 Input number of frequencies. + !> @param[in] NTH1 Input number of directions. + !> @param[in] XF1 Input frequency increment factor. + !> @param[in] FR1 First input frequency. + !> @param[in] TH1 First input direction. + !> @param[out] SP2 Output spectra. + !> @param[in] NFR2 Output number of frequencies. + !> @param[in] NTH2 Output number of directions. + !> @param[in] XF2 Output frequency increment factor. + !> @param[in] FR2 First output frequency. + !> @param[in] TH2 First output direction. + !> @param[in] NSP Number of spectra. + !> @param[in] NDST Unit number for test output. + !> @param[in] NDSE Unit number for error output. + !> @param[in] FTL Factor for tail description = XF2**N. + !> + !> @author H. L. Tolman + !> @date 01-Nov-2012 + !> + SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & + SP2, NFR2, NTH2, XF2, FR2, TH2, & + NSP, NDST, NDSE, FTL ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Nov-2012 ! + !/ +-----------------------------------+ + !/ + !/ 19-Sep-2005 : Origination. ( version 3.08 ) + !/ 01-Nov-2012 : code clean up (tab spaces, comments)( version 4.08 ) + !/ + ! 1. Purpose : + ! + ! Convert a set of spectra to a new spectral grid. + ! + ! 2. Method : + ! + ! Conservative distribution of input energies over new grid. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! SP1 R.A. I Input spectra. + ! NFR1 Int. I Input number of frequencies. + ! NTH1 Int. I Input number of directions. + ! XFR Real I Input frequency increment factor. + ! FR1 Real I First input frequency. + ! TH1 Real I First input direction. + ! SP2 R.A. O Output spectra. + ! NFR2, NTH2, XF2, FR2, TH2 + ! ! Specral description for output spectra. + ! NSP Int. I Number of spectra. + ! NDST int. I Unit number for test output. + ! NDSE int. I Unit number for error output. + ! FTAIL Real I Factor for tail description = XF2**N + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! EXTCDE Sur. Id program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOBC Subr. W3IOBCMD Updating boundary conditions. + ! Subr Multi scale model bound. data input. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! + ! 7. Remarks : + ! + ! - The inner loop of the actual redistribution is over the + ! individual spectra, optimizing this routine for large numbers + ! of conversions in a single call. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! !/T Enable test output. + ! !/T1 Test output for searching in stored data. + ! !/T2 Test output for redistribution data. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + ! + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NSP, NFR1, NTH1, NFR2, NTH2, NDST, NDSE - REAL, INTENT(IN) :: SP1(NTH1,NFR1,NSP), XF1, FR1, TH1, & - XF2, FR2, TH2, FTL - REAL, INTENT(OUT) :: SP2(NTH2,NFR2,NSP) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, NRMAX, J, I1, L1, J1, I2, L2, J2, & - ISP + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NSP, NFR1, NTH1, NFR2, NTH2, NDST, NDSE + REAL, INTENT(IN) :: SP1(NTH1,NFR1,NSP), XF1, FR1, TH1, & + XF2, FR2, TH2, FTL + REAL, INTENT(OUT) :: SP2(NTH2,NFR2,NSP) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, NRMAX, J, I1, L1, J1, I2, L2, J2, & + ISP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: LOW, HGH, RLOW, RHGH, BLOW, BHGH, & - FRAC, AUX1, AUX2, R1, R2, FACT - LOGICAL :: FOUND - TYPE(CASE), POINTER :: CURRENT -!/ -!/ ------------------------------------------------------------------- / -!/ Pointers for aliases -!/ - INTEGER, POINTER :: IDTH(:,:), IDFR(:,:), NFR2T - REAL, POINTER :: DTH1, DTH2, RDTH(:,:), FRQ1(:), & - FRQ2(:), XDF1, XDF2, RDFR(:,:) -!/ + REAL :: LOW, HGH, RLOW, RHGH, BLOW, BHGH, & + FRAC, AUX1, AUX2, R1, R2, FACT + LOGICAL :: FOUND + TYPE(CASE), POINTER :: CURRENT + !/ + !/ ------------------------------------------------------------------- / + !/ Pointers for aliases + !/ + INTEGER, POINTER :: IDTH(:,:), IDFR(:,:), NFR2T + REAL, POINTER :: DTH1, DTH2, RDTH(:,:), FRQ1(:), & + FRQ2(:), XDF1, XDF2, RDFR(:,:) + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3CSPC') + CALL STRACE (IENT, 'W3CSPC') #endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! 0.a Check input -! - IF ( NFR1.LT.3 .OR. NTH1.LT.4 .OR. XF1.LE.1. .OR. FR1.LE.0. .OR.& - NFR2.LT.3 .OR. NTH2.LT.4 .OR. XF2.LE.1. .OR. FR2.LE.0. ) THEN - WRITE (NDSE,900) NFR1, NTH1, XF1, FR1, NFR2, NTH2, XF2, FR2 - CALL EXTCDE ( 1 ) - END IF -! - IF ( NSP .LT. 0 ) THEN - WRITE (NDSE,901) - CALL EXTCDE ( 2 ) - END IF -! - IF ( NSP .EQ. 0 ) THEN - WRITE (NDSE,902) - RETURN - END IF -! -! 0.b Test output -! + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! 0.a Check input + ! + IF ( NFR1.LT.3 .OR. NTH1.LT.4 .OR. XF1.LE.1. .OR. FR1.LE.0. .OR.& + NFR2.LT.3 .OR. NTH2.LT.4 .OR. XF2.LE.1. .OR. FR2.LE.0. ) THEN + WRITE (NDSE,900) NFR1, NTH1, XF1, FR1, NFR2, NTH2, XF2, FR2 + CALL EXTCDE ( 1 ) + END IF + ! + IF ( NSP .LT. 0 ) THEN + WRITE (NDSE,901) + CALL EXTCDE ( 2 ) + END IF + ! + IF ( NSP .EQ. 0 ) THEN + WRITE (NDSE,902) + RETURN + END IF + ! + ! 0.b Test output + ! #ifdef W3_T - WRITE (NDST,9000) NSP, NFR1, NTH1, XF1, FR1, TH1*RADE, & - NFR2, NTH2, XF2, FR2, TH2*RADE, FTL + WRITE (NDST,9000) NSP, NFR1, NTH1, XF1, FR1, TH1*RADE, & + NFR2, NTH2, XF2, FR2, TH2*RADE, FTL #endif -! -! -------------------------------------------------------------------- / -! 1. Search stored interpolation data for match -! - FOUND = .FALSE. -! - DO I=1, NCASES -! - IF ( I .EQ. 1 ) THEN - CURRENT => IDATA - ELSE - CURRENT => CURRENT%NEXT - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 1. Search stored interpolation data for match + ! + FOUND = .FALSE. + ! + DO I=1, NCASES + ! + IF ( I .EQ. 1 ) THEN + CURRENT => IDATA + ELSE + CURRENT => CURRENT%NEXT + END IF + ! #ifdef W3_T1 - WRITE (NDST,9010) I, CURRENT%NFR1, CURRENT%NTH1, & - CURRENT%XF1, CURRENT%FR1, CURRENT%TH1*RADE, & - CURRENT%NFR2, CURRENT%NTH2, & - CURRENT%XF2, CURRENT%FR2, CURRENT%TH2*RADE + WRITE (NDST,9010) I, CURRENT%NFR1, CURRENT%NTH1, & + CURRENT%XF1, CURRENT%FR1, CURRENT%TH1*RADE, & + CURRENT%NFR2, CURRENT%NTH2, & + CURRENT%XF2, CURRENT%FR2, CURRENT%TH2*RADE #endif -! - FOUND = CURRENT%NFR1.EQ.NFR1 .AND. CURRENT%NFR2.EQ.NFR2 .AND. & - CURRENT%NTH1.EQ.NTH1 .AND. CURRENT%NTH2.EQ.NTH2 .AND. & - CURRENT%XF1 .EQ.XF1 .AND. CURRENT%XF2 .EQ.XF2 .AND. & - CURRENT%FR1 .EQ.FR1 .AND. CURRENT%FR2 .EQ.FR2 .AND. & - CURRENT%TH1 .EQ.TH1 .AND. CURRENT%TH2 .EQ.TH2 - IF ( FOUND ) EXIT -! - END DO -! -! -------------------------------------------------------------------- / -! 2. Link or compute interpolation data -! 2.a Link -! - IF ( FOUND ) THEN -! + ! + FOUND = CURRENT%NFR1.EQ.NFR1 .AND. CURRENT%NFR2.EQ.NFR2 .AND. & + CURRENT%NTH1.EQ.NTH1 .AND. CURRENT%NTH2.EQ.NTH2 .AND. & + CURRENT%XF1 .EQ.XF1 .AND. CURRENT%XF2 .EQ.XF2 .AND. & + CURRENT%FR1 .EQ.FR1 .AND. CURRENT%FR2 .EQ.FR2 .AND. & + CURRENT%TH1 .EQ.TH1 .AND. CURRENT%TH2 .EQ.TH2 + IF ( FOUND ) EXIT + ! + END DO + ! + ! -------------------------------------------------------------------- / + ! 2. Link or compute interpolation data + ! 2.a Link + ! + IF ( FOUND ) THEN + ! #ifdef W3_T - WRITE (NDST,9020) I + WRITE (NDST,9020) I #endif -! - DTH1 => CURRENT%DTH1 - DTH2 => CURRENT%DTH2 - IDTH => CURRENT%IDTH - RDTH => CURRENT%RDTH -! - FRQ1 => CURRENT%FRQ1 - FRQ2 => CURRENT%FRQ2 - XDF1 => CURRENT%XDF1 - XDF2 => CURRENT%XDF2 - NFR2T => CURRENT%NFR2T - IDFR => CURRENT%IDFR - RDFR => CURRENT%RDFR -! -! 2.b Compute -! - ELSE -! - NCASES = NCASES + 1 + ! + DTH1 => CURRENT%DTH1 + DTH2 => CURRENT%DTH2 + IDTH => CURRENT%IDTH + RDTH => CURRENT%RDTH + ! + FRQ1 => CURRENT%FRQ1 + FRQ2 => CURRENT%FRQ2 + XDF1 => CURRENT%XDF1 + XDF2 => CURRENT%XDF2 + NFR2T => CURRENT%NFR2T + IDFR => CURRENT%IDFR + RDFR => CURRENT%RDFR + ! + ! 2.b Compute + ! + ELSE + ! + NCASES = NCASES + 1 #ifdef W3_T - WRITE (NDST,9021) NCASES + WRITE (NDST,9021) NCASES #endif -! -! 2.b.1 Point and allocate as necessary -! - IF ( NCASES .EQ. 1 ) THEN - ALLOCATE ( IDATA ) - CURRENT => IDATA - ELSE - ALLOCATE ( CURRENT%NEXT ) - CURRENT => CURRENT%NEXT - END IF -! -! 2.b.2 Store test data -! - CURRENT%ICASE = NCASES - CURRENT%NFR1 = NFR1 - CURRENT%NTH1 = NTH1 - CURRENT%XF1 = XF1 - CURRENT%FR1 = FR1 - CURRENT%TH1 = TH1 - CURRENT%NFR2 = NFR2 - CURRENT%NTH2 = NTH2 - CURRENT%XF2 = XF2 - CURRENT%FR2 = FR2 - CURRENT%TH2 = TH2 -! -! 2.b.3 Directional redistribution data -! - DTH1 => CURRENT%DTH1 - DTH1 = TPI / REAL(NTH1) - DTH2 => CURRENT%DTH2 - DTH2 = TPI / REAL(NTH2) -! - IF ( DTH1 .LE. DTH2 ) THEN - NRMAX = 2 - ELSE - NRMAX = 2 + INT(DTH1/DTH2) + ! + ! 2.b.1 Point and allocate as necessary + ! + IF ( NCASES .EQ. 1 ) THEN + ALLOCATE ( IDATA ) + CURRENT => IDATA + ELSE + ALLOCATE ( CURRENT%NEXT ) + CURRENT => CURRENT%NEXT + END IF + ! + ! 2.b.2 Store test data + ! + CURRENT%ICASE = NCASES + CURRENT%NFR1 = NFR1 + CURRENT%NTH1 = NTH1 + CURRENT%XF1 = XF1 + CURRENT%FR1 = FR1 + CURRENT%TH1 = TH1 + CURRENT%NFR2 = NFR2 + CURRENT%NTH2 = NTH2 + CURRENT%XF2 = XF2 + CURRENT%FR2 = FR2 + CURRENT%TH2 = TH2 + ! + ! 2.b.3 Directional redistribution data + ! + DTH1 => CURRENT%DTH1 + DTH1 = TPI / REAL(NTH1) + DTH2 => CURRENT%DTH2 + DTH2 = TPI / REAL(NTH2) + ! + IF ( DTH1 .LE. DTH2 ) THEN + NRMAX = 2 + ELSE + NRMAX = 2 + INT(DTH1/DTH2) + END IF + ! + ALLOCATE (CURRENT%IDTH(0:NRMAX,NTH1),CURRENT%RDTH(NRMAX,NTH1)) + IDTH => CURRENT%IDTH + RDTH => CURRENT%RDTH + IDTH = 0 + RDTH = 0. + ! + DO I=1, NTH1 + LOW = TH1 + REAL(I-1)*DTH1 - 0.5*DTH1 + HGH = LOW + DTH1 + RLOW = 1. + (LOW-TH2)/DTH2 + RHGH = 1. + (HGH-TH2)/DTH2 + DO J=NINT(RLOW), NINT(RLOW)+NRMAX-1 + BLOW = TH2 + REAL(J-1)*DTH2 - 0.5*DTH2 + BHGH = BLOW + DTH2 + FRAC = (MIN(BHGH,HGH)-MAX(BLOW,LOW)) / (HGH-LOW) + IF ( FRAC .GT. 1.E-5 ) THEN + IDTH(0,I) = IDTH(0,I) + 1 + IDTH(IDTH(0,I),I) = 1 + MOD(J-1+NTH2,NTH2) + RDTH(IDTH(0,I),I) = FRAC END IF -! - ALLOCATE (CURRENT%IDTH(0:NRMAX,NTH1),CURRENT%RDTH(NRMAX,NTH1)) - IDTH => CURRENT%IDTH - RDTH => CURRENT%RDTH - IDTH = 0 - RDTH = 0. -! - DO I=1, NTH1 - LOW = TH1 + REAL(I-1)*DTH1 - 0.5*DTH1 - HGH = LOW + DTH1 - RLOW = 1. + (LOW-TH2)/DTH2 - RHGH = 1. + (HGH-TH2)/DTH2 - DO J=NINT(RLOW), NINT(RLOW)+NRMAX-1 - BLOW = TH2 + REAL(J-1)*DTH2 - 0.5*DTH2 - BHGH = BLOW + DTH2 - FRAC = (MIN(BHGH,HGH)-MAX(BLOW,LOW)) / (HGH-LOW) - IF ( FRAC .GT. 1.E-5 ) THEN - IDTH(0,I) = IDTH(0,I) + 1 - IDTH(IDTH(0,I),I) = 1 + MOD(J-1+NTH2,NTH2) - RDTH(IDTH(0,I),I) = FRAC - END IF - END DO - END DO -! -! 2.b.4 Frequency redistribution data -! - ALLOCATE ( CURRENT%FRQ1(NFR1), CURRENT%FRQ2(NFR2) ) - FRQ1 => CURRENT%FRQ1 - FRQ2 => CURRENT%FRQ2 -! - FRQ1(1) = FR1 - DO I=2, NFR1 - FRQ1(I) = XF1 * FRQ1(I-1) - END DO -! - FRQ2(1) = FR2 - DO I=2, NFR2 - FRQ2(I) = XF2 * FRQ2(I-1) - END DO -! - XDF1 => CURRENT%XDF1 - XDF1 = 0.5 * ( XF1 - 1./XF1 ) - XDF2 => CURRENT%XDF2 - XDF2 = 0.5 * ( XF2 - 1./XF2 ) -! - IF ( XDF1 .LE. XDF2 ) THEN - NRMAX = 2 + END DO + END DO + ! + ! 2.b.4 Frequency redistribution data + ! + ALLOCATE ( CURRENT%FRQ1(NFR1), CURRENT%FRQ2(NFR2) ) + FRQ1 => CURRENT%FRQ1 + FRQ2 => CURRENT%FRQ2 + ! + FRQ1(1) = FR1 + DO I=2, NFR1 + FRQ1(I) = XF1 * FRQ1(I-1) + END DO + ! + FRQ2(1) = FR2 + DO I=2, NFR2 + FRQ2(I) = XF2 * FRQ2(I-1) + END DO + ! + XDF1 => CURRENT%XDF1 + XDF1 = 0.5 * ( XF1 - 1./XF1 ) + XDF2 => CURRENT%XDF2 + XDF2 = 0.5 * ( XF2 - 1./XF2 ) + ! + IF ( XDF1 .LE. XDF2 ) THEN + NRMAX = 2 + ELSE + NRMAX = 1 + AUX1 = XDF1 + AUX2 = XDF2 + DO + NRMAX = NRMAX + 1 + AUX1 = AUX1 - AUX2 + AUX2 = AUX2 / XF2 + IF ( AUX1 .LT. 0. ) EXIT + END DO + END IF + ! + ALLOCATE (CURRENT%IDFR(0:NRMAX,NFR1),CURRENT%RDFR(NRMAX,NFR1)) + IDFR => CURRENT%IDFR + RDFR => CURRENT%RDFR + IDFR = 0 + RDFR = 0. + ! + DO I=1, NFR1 + IF ( I .EQ. 1 ) THEN + HGH = 0.5 * ( FRQ1(I) + FRQ1(I+1) ) + LOW = HGH - XDF1*FRQ1(I) ELSE - NRMAX = 1 - AUX1 = XDF1 - AUX2 = XDF2 - DO - NRMAX = NRMAX + 1 - AUX1 = AUX1 - AUX2 - AUX2 = AUX2 / XF2 - IF ( AUX1 .LT. 0. ) EXIT - END DO - END IF -! - ALLOCATE (CURRENT%IDFR(0:NRMAX,NFR1),CURRENT%RDFR(NRMAX,NFR1)) - IDFR => CURRENT%IDFR - RDFR => CURRENT%RDFR - IDFR = 0 - RDFR = 0. -! - DO I=1, NFR1 - IF ( I .EQ. 1 ) THEN - HGH = 0.5 * ( FRQ1(I) + FRQ1(I+1) ) - LOW = HGH - XDF1*FRQ1(I) - ELSE - LOW = 0.5 * ( FRQ1(I) + FRQ1(I-1) ) - HGH = LOW + XDF1*FRQ1(I) - END IF - DO J=1, NFR2 - IF ( J .EQ. 1 ) THEN - BHGH = 0.5 * ( FRQ2(J) + FRQ2(J+1) ) - BLOW = BHGH - XDF2*FRQ2(J) - ELSE - BLOW = 0.5 * ( FRQ2(J) + FRQ2(J-1) ) - BHGH = BLOW + XDF2*FRQ2(J) - END IF - IF ( BHGH .LE. LOW ) CYCLE - IF ( BLOW .GE. HGH ) EXIT - FRAC = (MIN(BHGH,HGH)-MAX(BLOW,LOW)) / (HGH-LOW) - IF ( FRAC .LT. 1.E-5 ) CYCLE - IDFR(0,I) = IDFR(0,I) + 1 - IDFR(IDFR(0,I),I) = J - RDFR(IDFR(0,I),I) = FRAC - END DO - END DO -! - NFR2T => CURRENT%NFR2T - NFR2T = NFR2 + 1 - DO J=NFR2, 1, -1 + LOW = 0.5 * ( FRQ1(I) + FRQ1(I-1) ) + HGH = LOW + XDF1*FRQ1(I) + END IF + DO J=1, NFR2 IF ( J .EQ. 1 ) THEN BHGH = 0.5 * ( FRQ2(J) + FRQ2(J+1) ) + BLOW = BHGH - XDF2*FRQ2(J) ELSE BLOW = 0.5 * ( FRQ2(J) + FRQ2(J-1) ) BHGH = BLOW + XDF2*FRQ2(J) - END IF - IF ( BHGH .GT. HGH ) THEN - NFR2T = J - ELSE - EXIT - END IF - END DO -! + END IF + IF ( BHGH .LE. LOW ) CYCLE + IF ( BLOW .GE. HGH ) EXIT + FRAC = (MIN(BHGH,HGH)-MAX(BLOW,LOW)) / (HGH-LOW) + IF ( FRAC .LT. 1.E-5 ) CYCLE + IDFR(0,I) = IDFR(0,I) + 1 + IDFR(IDFR(0,I),I) = J + RDFR(IDFR(0,I),I) = FRAC + END DO + END DO + ! + NFR2T => CURRENT%NFR2T + NFR2T = NFR2 + 1 + DO J=NFR2, 1, -1 + IF ( J .EQ. 1 ) THEN + BHGH = 0.5 * ( FRQ2(J) + FRQ2(J+1) ) + ELSE + BLOW = 0.5 * ( FRQ2(J) + FRQ2(J-1) ) + BHGH = BLOW + XDF2*FRQ2(J) END IF -! -! 2.c Test output -! + IF ( BHGH .GT. HGH ) THEN + NFR2T = J + ELSE + EXIT + END IF + END DO + ! + END IF + ! + ! 2.c Test output + ! #ifdef W3_T2 - WRITE (NDST,9022) - DO I=1, NTH1 - WRITE (NDST,9024) I, IDTH(0,I), & - (IDTH(J,I),RDTH(J,I),J=1,IDTH(0,I)) - END DO - WRITE (NDST,9023) NFR2T - DO I=1, NFR1 - WRITE (NDST,9024) I, IDFR(0,I), & - (IDFR(J,I),RDFR(J,I),J=1,IDFR(0,I)) - END DO + WRITE (NDST,9022) + DO I=1, NTH1 + WRITE (NDST,9024) I, IDTH(0,I), & + (IDTH(J,I),RDTH(J,I),J=1,IDTH(0,I)) + END DO + WRITE (NDST,9023) NFR2T + DO I=1, NFR1 + WRITE (NDST,9024) I, IDFR(0,I), & + (IDFR(J,I),RDFR(J,I),J=1,IDFR(0,I)) + END DO #endif -! -! -------------------------------------------------------------------- / -! 3. Convert -! 3.a Discrete energies -! + ! + ! -------------------------------------------------------------------- / + ! 3. Convert + ! 3.a Discrete energies + ! #ifdef W3_T - WRITE (NDST,9030) + WRITE (NDST,9030) #endif -! - SP2 = 0. -! - DO I2=1, NFR1 + ! + SP2 = 0. + ! + DO I2=1, NFR1 DO L2=1, IDFR(0,I2) J2 = IDFR(L2,I2) - R2 = RDFR(L2,I2) - DO I1=1,NTH1 - DO L1=1, IDTH( 0,I1) - J1 = IDTH(L1,I1) - R1 = RDTH(L1,I1) - FRAC = R2 * FRQ1(I2) * XDF1 * R1 * DTH1 - SP2(J1,J2,:) = SP2(J1,J2,:) + FRAC * SP1(I1,I2,:) - END DO - END DO + R2 = RDFR(L2,I2) + DO I1=1,NTH1 + DO L1=1, IDTH( 0,I1) + J1 = IDTH(L1,I1) + R1 = RDTH(L1,I1) + FRAC = R2 * FRQ1(I2) * XDF1 * R1 * DTH1 + SP2(J1,J2,:) = SP2(J1,J2,:) + FRAC * SP1(I1,I2,:) END DO END DO -! -! 3.b Energy densities -! + END DO + END DO + ! + ! 3.b Energy densities + ! #ifdef W3_T - WRITE (NDST,9031) + WRITE (NDST,9031) #endif -! - DO J2=1, NFR2 - DO J1=1, NTH2 - FACT = 1. / ( FRQ2(J2) * XDF2 * DTH2 ) - SP2(J1,J2,:) = FACT * SP2(J1,J2,:) - END DO - END DO -! -! 3.c Add the tail -! + ! + DO J2=1, NFR2 + DO J1=1, NTH2 + FACT = 1. / ( FRQ2(J2) * XDF2 * DTH2 ) + SP2(J1,J2,:) = FACT * SP2(J1,J2,:) + END DO + END DO + ! + ! 3.c Add the tail + ! #ifdef W3_T - WRITE (NDST,9032) + WRITE (NDST,9032) #endif -! - DO J2=NFR2T, NFR2 - SP2(:,J2,:) = FTL * SP2(:,J2-1,:) - END DO -! - RETURN -! -! Formats -! - 900 FORMAT (/' *** ERROR W3CSPC: ILLEGAL INPUT PARAMETERS ***'/ & - ' INPUT : ',2I8,2F10.4/ & - ' OUTPUT : ',2I8,2F10.4) - 901 FORMAT (/' *** ERROR W3CSPC: NEGATIVE NUMBER OF SPECTRA ***'/) - 902 FORMAT (/' *** WARNING W3CSPC: NO SPECTRA ***'/) -! + ! + DO J2=NFR2T, NFR2 + SP2(:,J2,:) = FTL * SP2(:,J2-1,:) + END DO + ! + RETURN + ! + ! Formats + ! +900 FORMAT (/' *** ERROR W3CSPC: ILLEGAL INPUT PARAMETERS ***'/ & + ' INPUT : ',2I8,2F10.4/ & + ' OUTPUT : ',2I8,2F10.4) +901 FORMAT (/' *** ERROR W3CSPC: NEGATIVE NUMBER OF SPECTRA ***'/) +902 FORMAT (/' *** WARNING W3CSPC: NO SPECTRA ***'/) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3CSPC : NR. OF SPECTRA : ',I8/ & - ' INPUT SPECTRA : ',2I4,2F8.4,F6.1/ & - ' OUTPUT SPECTRA : ',2I4,2F8.4,F6.1/ & - ' TAIL FACTOR : ',F8.5) +9000 FORMAT ( ' TEST W3CSPC : NR. OF SPECTRA : ',I8/ & + ' INPUT SPECTRA : ',2I4,2F8.4,F6.1/ & + ' OUTPUT SPECTRA : ',2I4,2F8.4,F6.1/ & + ' TAIL FACTOR : ',F8.5) #endif -! + ! #ifdef W3_T1 - 9010 FORMAT ( ' TEST W3CSPC : TEST INFO CASE : ',I8/ & - ' INPUT SPECTRA : ',2I4,2F8.4,F6.1/ & - ' OUTPUT SPECTRA : ',2I4,2F8.4,F6.1) +9010 FORMAT ( ' TEST W3CSPC : TEST INFO CASE : ',I8/ & + ' INPUT SPECTRA : ',2I4,2F8.4,F6.1/ & + ' OUTPUT SPECTRA : ',2I4,2F8.4,F6.1) #endif -! + ! #ifdef W3_T - 9020 FORMAT ( ' TEST W3CSPC : USING STORED DATA FOR CASE',I4) - 9021 FORMAT ( ' TEST W3CSPC : COMPUTING DATA FOR CASE',I4) +9020 FORMAT ( ' TEST W3CSPC : USING STORED DATA FOR CASE',I4) +9021 FORMAT ( ' TEST W3CSPC : COMPUTING DATA FOR CASE',I4) #endif #ifdef W3_T2 - 9022 FORMAT ( ' TEST W3CSPC : DIRECTIONAL DISTRIBUTION DATA') - 9023 FORMAT ( ' TEST W3CSPC : FREQUENCY DISTRIBUTION DATA, ', & - 'TAIL AT',I4) - 9024 FORMAT ( ' ',I4,I4,' :',10(I4,F5.2) ) +9022 FORMAT ( ' TEST W3CSPC : DIRECTIONAL DISTRIBUTION DATA') +9023 FORMAT ( ' TEST W3CSPC : FREQUENCY DISTRIBUTION DATA, ', & + 'TAIL AT',I4) +9024 FORMAT ( ' ',I4,I4,' :',10(I4,F5.2) ) #endif -! + ! #ifdef W3_T - 9030 FORMAT ( ' TEST W3CSPC : STARTING CONVERSION') - 9031 FORMAT ( ' TEST W3CSPC : ENERGIES TO DENSITIES') - 9032 FORMAT ( ' TEST W3CSPC : ADD TAIL') +9030 FORMAT ( ' TEST W3CSPC : STARTING CONVERSION') +9031 FORMAT ( ' TEST W3CSPC : ENERGIES TO DENSITIES') +9032 FORMAT ( ' TEST W3CSPC : ADD TAIL') #endif -!/ -!/ End of W3CSPC ----------------------------------------------------- / -!/ - END SUBROUTINE W3CSPC -!/ -!/ End of module W3CSPCMD -------------------------------------------- / -!/ - END MODULE W3CSPCMD + !/ + !/ End of W3CSPC ----------------------------------------------------- / + !/ + END SUBROUTINE W3CSPC + !/ + !/ End of module W3CSPCMD -------------------------------------------- / + !/ +END MODULE W3CSPCMD diff --git a/model/src/w3dispmd.F90 b/model/src/w3dispmd.F90 index 70d4f4946..f925174bf 100644 --- a/model/src/w3dispmd.F90 +++ b/model/src/w3dispmd.F90 @@ -1,1143 +1,1137 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3DISPMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 30-Nov-1999 : Fortran 90 version. ( version 2.00 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 10-Mar-2016 : Added Liu & Mollo-Christensen -!/ dispersion with ice (E. Rogers) ( version 5.10 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! A set of routines for solving the dispersion relation. -! -! 2. Variables and types : -! -! All variables are retated to the interpolation tables. See -! DISTAB for a more comprehensive description. -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NAR1D I.P. Public Nmmer of elements in interpolation -! array. -! DFAC R.P. Public Value of KH at deep boundary. -! EWN1 R.A. Public Wavenumber array. -! ECG1 R.A. Public Group velocity array. -! N1MAX Int. Public Actual maximum position in array. -! DSIE Real Public SI step. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WAVNU1 Subr. Public Solve dispersion using lookup table. -! WAVNU2 Subr. Public Solve dispersion relation itteratively. -! DISTAB Subr. Public Fill interpolation tables. -! LIU_FORWARD_DISPERSION Subr. Public Dispersion with ice -! LIU_REVERSE_DISPERSION Subr. Public Dispersion with ice -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing ( !/S ) -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ -!/ Set up of public interpolation table ------------------------------ / -!/ - INTEGER, PARAMETER :: NAR1D = 121 - REAL, PARAMETER :: DFAC = 6. -!/ - INTEGER :: N1MAX - REAL :: ECG1(0:NAR1D), EWN1(0:NAR1D), DSIE -!/ -!/ Set up of public subroutines -------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE WAVNU1 (SI,H,K,CG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 04-Nov-1990 : Final FORTRAN 77 ( version 1.18 ) -!/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Calculate wavenumber and group velocity from the interpolation -! array filled by DISTAB from a given intrinsic frequency and the -! waterdepth. -! -! 2. Method : -! -! Linear interpolation from one-dimensional array. -! -! 3. Parameters used : -! -! Parameter list -! ---------------------------------------------------------------- -! SI Real I Intrinsic frequency (moving frame) (rad/s) -! H Real I Waterdepth (m) -! K Real O Wavenumber (rad/m) -! CG Real O Group velocity (m/s) -! ---------------------------------------------------------------- -! -! 4. Error messages : -! -! - None. -! -! 5. Called by : -! -! - Any main program -! -! 6. Subroutines used : -! -! - None -! -! 7. Remarks : -! -! - Calculated si* is always made positive without checks : check in -! main program assumed ! -! - Depth is unlimited. -! -! 8. Structure : -! -! +---------------------------------------------+ -! | calculate non-dimensional frequency | -! |---------------------------------------------| -! | T si* in range ? F | -! |----------------------|----------------------| -! | calculate k* and cg* | deep water approx. | -! | calculate output | | -! | parameters | | -! +---------------------------------------------+ -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS, ONLY : GRAV +MODULE W3DISPMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 30-Nov-1999 : Fortran 90 version. ( version 2.00 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 10-Mar-2016 : Added Liu & Mollo-Christensen + !/ dispersion with ice (E. Rogers) ( version 5.10 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! A set of routines for solving the dispersion relation. + ! + ! 2. Variables and types : + ! + ! All variables are retated to the interpolation tables. See + ! DISTAB for a more comprehensive description. + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NAR1D I.P. Public Nmmer of elements in interpolation + ! array. + ! DFAC R.P. Public Value of KH at deep boundary. + ! EWN1 R.A. Public Wavenumber array. + ! ECG1 R.A. Public Group velocity array. + ! N1MAX Int. Public Actual maximum position in array. + ! DSIE Real Public SI step. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WAVNU1 Subr. Public Solve dispersion using lookup table. + ! WAVNU2 Subr. Public Solve dispersion relation itteratively. + ! DISTAB Subr. Public Fill interpolation tables. + ! LIU_FORWARD_DISPERSION Subr. Public Dispersion with ice + ! LIU_REVERSE_DISPERSION Subr. Public Dispersion with ice + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing ( !/S ) + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ + !/ Set up of public interpolation table ------------------------------ / + !/ + INTEGER, PARAMETER :: NAR1D = 121 + REAL, PARAMETER :: DFAC = 6. + !/ + INTEGER :: N1MAX + REAL :: ECG1(0:NAR1D), EWN1(0:NAR1D), DSIE + !/ + !/ Set up of public subroutines -------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE WAVNU1 (SI,H,K,CG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 04-Nov-1990 : Final FORTRAN 77 ( version 1.18 ) + !/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Calculate wavenumber and group velocity from the interpolation + ! array filled by DISTAB from a given intrinsic frequency and the + ! waterdepth. + ! + ! 2. Method : + ! + ! Linear interpolation from one-dimensional array. + ! + ! 3. Parameters used : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! SI Real I Intrinsic frequency (moving frame) (rad/s) + ! H Real I Waterdepth (m) + ! K Real O Wavenumber (rad/m) + ! CG Real O Group velocity (m/s) + ! ---------------------------------------------------------------- + ! + ! 4. Error messages : + ! + ! - None. + ! + ! 5. Called by : + ! + ! - Any main program + ! + ! 6. Subroutines used : + ! + ! - None + ! + ! 7. Remarks : + ! + ! - Calculated si* is always made positive without checks : check in + ! main program assumed ! + ! - Depth is unlimited. + ! + ! 8. Structure : + ! + ! +---------------------------------------------+ + ! | calculate non-dimensional frequency | + ! |---------------------------------------------| + ! | T si* in range ? F | + ! |----------------------|----------------------| + ! | calculate k* and cg* | deep water approx. | + ! | calculate output | | + ! | parameters | | + ! +---------------------------------------------+ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS, ONLY : GRAV #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: SI, H - REAL, INTENT(OUT) :: K, CG -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I1, I2 + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: SI, H + REAL, INTENT(OUT) :: K, CG + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I1, I2 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: SQRTH, SIX, R1, R2 -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: SQRTH, SIX, R1, R2 + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'WAVNU1') + CALL STRACE (IENT, 'WAVNU1') #endif -! - SQRTH = SQRT(H) - SIX = SI * SQRTH - I1 = INT(SIX/DSIE) -! - IF (I1.LE.N1MAX.AND.I1.GE.1) THEN - I2 = I1 + 1 - R1 = SIX/DSIE - REAL(I1) - R2 = 1. - R1 - K = ( R2*EWN1(I1) + R1*EWN1(I2) ) / H - CG = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH - ELSE - K = SI*SI/GRAV - CG = 0.5 * GRAV / SI - END IF -! - RETURN -!/ -!/ End of WAVNU1 ----------------------------------------------------- / -!/ - END SUBROUTINE WAVNU1 -!/ ------------------------------------------------------------------- / - SUBROUTINE WAVNU2 (W,H,K,CG,EPS,NMAX,ICON) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 17-Jul-1990 : Final FORTRAN 77 ( version 1.18 ) -!/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Calculation of wavenumber K from a given angular -! frequency W and waterdepth H. -! -! 2. Method : -! -! Used equation : -! 2 -! W = G*K*TANH(K*H) -! -! Because of the nature of the equation, K is calculated -! with an itterative procedure. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! W Real I Angular frequency -! H Real I Waterdepth -! K Real O Wavenumber ( same sign as W ) -! CG Real O Group velocity (same sign as W) -! EPS Real I Wanted max. difference between K and Kold -! NMAX Int. I Max number of repetitions in calculation -! ICON Int. O Contol counter ( See error messages ) -! ---------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS, ONLY : GRAV + ! + SQRTH = SQRT(H) + SIX = SI * SQRTH + I1 = INT(SIX/DSIE) + ! + IF (I1.LE.N1MAX.AND.I1.GE.1) THEN + I2 = I1 + 1 + R1 = SIX/DSIE - REAL(I1) + R2 = 1. - R1 + K = ( R2*EWN1(I1) + R1*EWN1(I2) ) / H + CG = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH + ELSE + K = SI*SI/GRAV + CG = 0.5 * GRAV / SI + END IF + ! + RETURN + !/ + !/ End of WAVNU1 ----------------------------------------------------- / + !/ + END SUBROUTINE WAVNU1 + !/ ------------------------------------------------------------------- / + SUBROUTINE WAVNU2 (W,H,K,CG,EPS,NMAX,ICON) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 17-Jul-1990 : Final FORTRAN 77 ( version 1.18 ) + !/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Calculation of wavenumber K from a given angular + ! frequency W and waterdepth H. + ! + ! 2. Method : + ! + ! Used equation : + ! 2 + ! W = G*K*TANH(K*H) + ! + ! Because of the nature of the equation, K is calculated + ! with an itterative procedure. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! W Real I Angular frequency + ! H Real I Waterdepth + ! K Real O Wavenumber ( same sign as W ) + ! CG Real O Group velocity (same sign as W) + ! EPS Real I Wanted max. difference between K and Kold + ! NMAX Int. I Max number of repetitions in calculation + ! ICON Int. O Contol counter ( See error messages ) + ! ---------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS, ONLY : GRAV #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NMAX - INTEGER, INTENT(OUT) :: ICON - REAL, INTENT(IN) :: W, H, EPS - REAL, INTENT(OUT) :: CG, K -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NMAX + INTEGER, INTENT(OUT) :: ICON + REAL, INTENT(IN) :: W, H, EPS + REAL, INTENT(OUT) :: CG, K + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: F, W0, FD, DIF, RDIF, KOLD - !REAL :: KTEST1, CGTEST1, KTEST2, CGTEST2 -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: F, W0, FD, DIF, RDIF, KOLD + !REAL :: KTEST1, CGTEST1, KTEST2, CGTEST2 + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'WAVNU2') + CALL STRACE (IENT, 'WAVNU2') #endif -! -! Initialisations : -! - !CALL WAVNU1(ABS(W),H,KTEST1,CGTEST1) - !CALL WAVNU3(ABS(W),H,KTEST2,CGTEST2) - - CG = 0 - KOLD = 0 - ICON = 0 - W0 = ABS(W) + ! + ! Initialisations : + ! + !CALL WAVNU1(ABS(W),H,KTEST1,CGTEST1) + !CALL WAVNU3(ABS(W),H,KTEST2,CGTEST2) -! -! 1st approach : -! - IF (W0.LT.SQRT(GRAV/H)) THEN - K = W0/SQRT(GRAV*H) - ELSE - K = W0*W0/GRAV - END IF -! -! Refinement : -! - DO I=1, NMAX - DIF = ABS(K-KOLD) - IF (K.NE.0) THEN - RDIF = DIF/K - ELSE - RDIF = 0 - END IF - IF (DIF .LT. EPS .AND. RDIF .LT. EPS) THEN - ICON = 1 - GOTO 100 - ELSE - KOLD = K - F = GRAV*KOLD*TANH(KOLD*H)-W0**2 - IF (KOLD*H.GT.25) THEN - FD = GRAV*TANH(KOLD*H) - ELSE - FD = GRAV*TANH(KOLD*H) + GRAV*KOLD*H/((COSH(KOLD*H))**2) - END IF - K = KOLD - F/FD - END IF - END DO -! - DIF = ABS(K-KOLD) - RDIF = DIF/K - IF (DIF .LT. EPS .AND. RDIF .LT. EPS) ICON = 1 - 100 CONTINUE - IF (2*K*H.GT.25) THEN - CG = W0/K * 0.5 + CG = 0 + KOLD = 0 + ICON = 0 + W0 = ABS(W) + + ! + ! 1st approach : + ! + IF (W0.LT.SQRT(GRAV/H)) THEN + K = W0/SQRT(GRAV*H) + ELSE + K = W0*W0/GRAV + END IF + ! + ! Refinement : + ! + DO I=1, NMAX + DIF = ABS(K-KOLD) + IF (K.NE.0) THEN + RDIF = DIF/K + ELSE + RDIF = 0 + END IF + IF (DIF .LT. EPS .AND. RDIF .LT. EPS) THEN + ICON = 1 + GOTO 100 + ELSE + KOLD = K + F = GRAV*KOLD*TANH(KOLD*H)-W0**2 + IF (KOLD*H.GT.25) THEN + FD = GRAV*TANH(KOLD*H) ELSE - CG = W0/K * 0.5*(1+(2*K*H/SINH(2*K*H))) - END IF - IF (W.LT.0.0) THEN - K = (-1)*K - CG = CG*(-1) + FD = GRAV*TANH(KOLD*H) + GRAV*KOLD*H/((COSH(KOLD*H))**2) END IF + K = KOLD - F/FD + END IF + END DO + ! + DIF = ABS(K-KOLD) + RDIF = DIF/K + IF (DIF .LT. EPS .AND. RDIF .LT. EPS) ICON = 1 +100 CONTINUE + IF (2*K*H.GT.25) THEN + CG = W0/K * 0.5 + ELSE + CG = W0/K * 0.5*(1+(2*K*H/SINH(2*K*H))) + END IF + IF (W.LT.0.0) THEN + K = (-1)*K + CG = CG*(-1) + END IF - !WRITE(*,'(20F20.10)') W, H, (K-KTEST2)/K*100., (CG-CGTEST2)/CG*100. -! - RETURN -!/ -!/ End of WAVNU2 ----------------------------------------------------- / -!/ - END SUBROUTINE WAVNU2 -!/ - PURE SUBROUTINE WAVNU3 (SI,H,K,CG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Aron Roland | -!/ | FORTRAN 90 | -!/ | Last update : 20-05-17 | -!/ +-----------------------------------+ -!/ -!/ 20.05.17 : Initial Version, Aron Roland based on WAVNU1 -!/ -! 1. Purpose : -! -! Calculate wavenumber and group velocity from the improved -! Eckard's formula by Beji (2003) -! -! 2. Method : -! -! Direct computation by approximation -! -! 3. Parameters used : -! -! Parameter list -! ---------------------------------------------------------------- -! SI Real I Intrinsic frequency (moving frame) (rad/s) -! H Real I Waterdepth (m) -! K Real O Wavenumber (rad/m) -! CG Real O Group velocity (m/s) -! ---------------------------------------------------------------- -! -! 4. Error messages : -! -! - None. -! -! 5. Called by : -! -! - Any main program -! -! 6. Subroutines used : -! -! - None -! -! 7. Remarks : -! -! - Calculated si* is always made positive without checks : check in -! main program assumed ! -! - Depth is unlimited. -! -! 8. Structure : -! -! +---------------------------------------------+ -! | calculate non-dimensional frequency | -! |---------------------------------------------| -! | T si* in range ? F | -! |----------------------|----------------------| -! | calculate k* and cg* | deep water approx. | -! | calculate output | | -! | parameters | | -! +---------------------------------------------+ -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS, ONLY : GRAV, PI -!!/S USE W3SERVMD, ONLY: STRACE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: SI, H - REAL, INTENT(OUT) :: K, CG -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I1, I2 -!!/S INTEGER, SAVE :: IENT = 0 - REAL :: KH0, KH, TMP, TP, CP, L - REAL, PARAMETER :: BETA1 = 1.55 - REAL, PARAMETER :: BETA2 = 1.3 - REAL, PARAMETER :: BETA3 = 0.216 - REAL, PARAMETER :: ZPI = 2 * PI - REAL, PARAMETER :: KDMAX = 20. -!/ -!/ ------------------------------------------------------------------- / -!/ -! IENT does not work with PURE subroutines -!!/S CALL STRACE (IENT, 'WAVNU1') -! - TP = SI/ZPI - KH0 = ZPI*ZPI*H/GRAV*TP*TP - TMP = 1.55 + 1.3*KH0 + 0.216*KH0*KH0 - KH = KH0 * (1 + KH0**1.09 * 1./EXP(MIN(KDMAX,TMP))) / SQRT(TANH(MIN(KDMAX,KH0))) - K = KH/H - CG = 0.5*(1+(2*KH/SINH(MIN(KDMAX,2*KH))))*SI/K -! - RETURN -!/ -!/ End of WAVNU3 ----------------------------------------------------- / -!/ - END SUBROUTINE WAVNU3 + !WRITE(*,'(20F20.10)') W, H, (K-KTEST2)/K*100., (CG-CGTEST2)/CG*100. + ! + RETURN + !/ + !/ End of WAVNU2 ----------------------------------------------------- / + !/ + END SUBROUTINE WAVNU2 + !/ + PURE SUBROUTINE WAVNU3 (SI,H,K,CG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Aron Roland | + !/ | FORTRAN 90 | + !/ | Last update : 20-05-17 | + !/ +-----------------------------------+ + !/ + !/ 20.05.17 : Initial Version, Aron Roland based on WAVNU1 + !/ + ! 1. Purpose : + ! + ! Calculate wavenumber and group velocity from the improved + ! Eckard's formula by Beji (2003) + ! + ! 2. Method : + ! + ! Direct computation by approximation + ! + ! 3. Parameters used : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! SI Real I Intrinsic frequency (moving frame) (rad/s) + ! H Real I Waterdepth (m) + ! K Real O Wavenumber (rad/m) + ! CG Real O Group velocity (m/s) + ! ---------------------------------------------------------------- + ! + ! 4. Error messages : + ! + ! - None. + ! + ! 5. Called by : + ! + ! - Any main program + ! + ! 6. Subroutines used : + ! + ! - None + ! + ! 7. Remarks : + ! + ! - Calculated si* is always made positive without checks : check in + ! main program assumed ! + ! - Depth is unlimited. + ! + ! 8. Structure : + ! + ! +---------------------------------------------+ + ! | calculate non-dimensional frequency | + ! |---------------------------------------------| + ! | T si* in range ? F | + ! |----------------------|----------------------| + ! | calculate k* and cg* | deep water approx. | + ! | calculate output | | + ! | parameters | | + ! +---------------------------------------------+ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS, ONLY : GRAV, PI + !!/S USE W3SERVMD, ONLY: STRACE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: SI, H + REAL, INTENT(OUT) :: K, CG + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I1, I2 + !!/S INTEGER, SAVE :: IENT = 0 + REAL :: KH0, KH, TMP, TP, CP, L + REAL, PARAMETER :: BETA1 = 1.55 + REAL, PARAMETER :: BETA2 = 1.3 + REAL, PARAMETER :: BETA3 = 0.216 + REAL, PARAMETER :: ZPI = 2 * PI + REAL, PARAMETER :: KDMAX = 20. + !/ + !/ ------------------------------------------------------------------- / + !/ + ! IENT does not work with PURE subroutines + !!/S CALL STRACE (IENT, 'WAVNU1') + ! + TP = SI/ZPI + KH0 = ZPI*ZPI*H/GRAV*TP*TP + TMP = 1.55 + 1.3*KH0 + 0.216*KH0*KH0 + KH = KH0 * (1 + KH0**1.09 * 1./EXP(MIN(KDMAX,TMP))) / SQRT(TANH(MIN(KDMAX,KH0))) + K = KH/H + CG = 0.5*(1+(2*KH/SINH(MIN(KDMAX,2*KH))))*SI/K + ! + RETURN + !/ + !/ End of WAVNU3 ----------------------------------------------------- / + !/ + END SUBROUTINE WAVNU3 - PURE SUBROUTINE WAVNU_LOCAL (SIG,DW,WNL,CGL) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Aron Roland | -!/ | FORTRAN 90 | -!/ | Last update : 20-05-17 | -!/ +-----------------------------------+ -!/ -!/ 20.05.17 : Initial Version, Aron Roland based on WAVNU1 -!/ -! 1. Purpose : -! -! Calculate wavenumber and group velocity from the improved -! Eckard's formula by Beji (2003) -! -! 2. Method : -! -! Linear interpolation from one-dimensional array. -! -! 3. Parameters used : -! -! Parameter list -! ---------------------------------------------------------------- -! SI Real I Intrinsic frequency (moving frame) (rad/s) -! H Real I Waterdepth (m) -! K Real O Wavenumber (rad/m) -! CG Real O Group velocity (m/s) -! ---------------------------------------------------------------- -! -! 4. Error messages : -! -! - None. -! -! 5. Called by : -! -! - Any main program -! -! 6. Subroutines used : -! -! - None -! -! 7. Remarks : -! -! - Calculated si* is always made positive without checks : check in -! main program assumed ! -! - Depth is unlimited. -! -! 8. Structure : -! -! +---------------------------------------------+ -! | calculate non-dimensional frequency | -! |---------------------------------------------| -! | T si* in range ? F | -! |----------------------|----------------------| -! | calculate k* and cg* | deep water approx. | -! | calculate output | | -! | parameters | | -! +---------------------------------------------+ -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : + PURE SUBROUTINE WAVNU_LOCAL (SIG,DW,WNL,CGL) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Aron Roland | + !/ | FORTRAN 90 | + !/ | Last update : 20-05-17 | + !/ +-----------------------------------+ + !/ + !/ 20.05.17 : Initial Version, Aron Roland based on WAVNU1 + !/ + ! 1. Purpose : + ! + ! Calculate wavenumber and group velocity from the improved + ! Eckard's formula by Beji (2003) + ! + ! 2. Method : + ! + ! Linear interpolation from one-dimensional array. + ! + ! 3. Parameters used : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! SI Real I Intrinsic frequency (moving frame) (rad/s) + ! H Real I Waterdepth (m) + ! K Real O Wavenumber (rad/m) + ! CG Real O Group velocity (m/s) + ! ---------------------------------------------------------------- + ! + ! 4. Error messages : + ! + ! - None. + ! + ! 5. Called by : + ! + ! - Any main program + ! + ! 6. Subroutines used : + ! + ! - None + ! + ! 7. Remarks : + ! + ! - Calculated si* is always made positive without checks : check in + ! main program assumed ! + ! - Depth is unlimited. + ! + ! 8. Structure : + ! + ! +---------------------------------------------+ + ! | calculate non-dimensional frequency | + ! |---------------------------------------------| + ! | T si* in range ? F | + ! |----------------------|----------------------| + ! | calculate k* and cg* | deep water approx. | + ! | calculate output | | + ! | parameters | | + ! +---------------------------------------------+ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : - USE W3GDATMD, ONLY: DMIN -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE + USE W3GDATMD, ONLY: DMIN + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: SIG, DW - REAL, INTENT(OUT) :: WNL, CGL -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters - REAL :: DEPTH -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'WAVNU2') -#endif -! -!/ -!/ End of WAVNU_LOCAL------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: SIG, DW + REAL, INTENT(OUT) :: WNL, CGL + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + REAL :: DEPTH + ! + !/ + !/ End of WAVNU_LOCAL------------------------------------------------- / + !/ - DEPTH = MAX ( DMIN , DW) -! - CALL WAVNU3(SIG,DEPTH,WNL,CGL) + DEPTH = MAX ( DMIN , DW) + ! + CALL WAVNU3(SIG,DEPTH,WNL,CGL) - END SUBROUTINE WAVNU_LOCAL -!/ -!/ ------------------------------------------------------------------- / + END SUBROUTINE WAVNU_LOCAL + !/ + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / - SUBROUTINE DISTAB -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Nov-1990 | -!/ +-----------------------------------+ -!/ -!/ 04-Nov-1990 : Final FORTRAN 77 ( version 1.18 ) -!/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Fill interpolation arrays for the calculation of wave parameters -! according to the linear (Airy) wave theory given the intrinsic -! frequency. -! -! 2. Method : -! -! For a given set of non-dimensional frequencies the interpolation -! arrays with non-dimensional depths and group velocity are filled. -! The following non-dimensional parameters are used : -! -! frequency f*SQRT(h/g) = f* -! depth kh = k* -! group vel. c/SQRT(gh) = c* -! -! Where k is the wavenumber, h the depth f the intrinsic frequency, -! g the acceleration of gravity and c the group velocity. -! -! 3. Parameters : -! -! See module documentation. -! -! 4. Error messages : -! -! - None. -! -! 5. Called by : -! -! - W3GRID -! - Any main program. -! -! 6. Subroutines used : -! -! - WAVNU2 (solve dispersion relation) -! -! 7. Remarks : -! -! - In the filling of the arrays H = 1. is assumed and the factor -! SQRT (g) is moved from the interpolation to the filling -! procedure thus : -! -! k* = k -! -! c* = cg/SQRT(g) -! -! 8. Structure -! -! ----------------------------------- -! include common block -! calculate parameters -! fill zero-th position of arrays -! fill middle positions of arrays -! fill last positions of arrays -! ----------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS, ONLY : GRAV + !/ ------------------------------------------------------------------- / + SUBROUTINE DISTAB + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Nov-1990 | + !/ +-----------------------------------+ + !/ + !/ 04-Nov-1990 : Final FORTRAN 77 ( version 1.18 ) + !/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Fill interpolation arrays for the calculation of wave parameters + ! according to the linear (Airy) wave theory given the intrinsic + ! frequency. + ! + ! 2. Method : + ! + ! For a given set of non-dimensional frequencies the interpolation + ! arrays with non-dimensional depths and group velocity are filled. + ! The following non-dimensional parameters are used : + ! + ! frequency f*SQRT(h/g) = f* + ! depth kh = k* + ! group vel. c/SQRT(gh) = c* + ! + ! Where k is the wavenumber, h the depth f the intrinsic frequency, + ! g the acceleration of gravity and c the group velocity. + ! + ! 3. Parameters : + ! + ! See module documentation. + ! + ! 4. Error messages : + ! + ! - None. + ! + ! 5. Called by : + ! + ! - W3GRID + ! - Any main program. + ! + ! 6. Subroutines used : + ! + ! - WAVNU2 (solve dispersion relation) + ! + ! 7. Remarks : + ! + ! - In the filling of the arrays H = 1. is assumed and the factor + ! SQRT (g) is moved from the interpolation to the filling + ! procedure thus : + ! + ! k* = k + ! + ! c* = cg/SQRT(g) + ! + ! 8. Structure + ! + ! ----------------------------------- + ! include common block + ! calculate parameters + ! fill zero-th position of arrays + ! fill middle positions of arrays + ! fill last positions of arrays + ! ----------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS, ONLY : GRAV #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, ICON + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, ICON #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: DEPTH, CG, SIMAX, SI, K -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: DEPTH, CG, SIMAX, SI, K + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'DISTAB') + CALL STRACE (IENT, 'DISTAB') #endif -! -! Calculate parameters ----------------------------------------------- * -! - N1MAX = NAR1D - 1 - DEPTH = 1. - SIMAX = SQRT (GRAV * DFAC) - DSIE = SIMAX / REAL(N1MAX) -! -! Fill zero-th position of arrays ------------------------------------ * -! - EWN1(0) = 0. - ECG1(0) = SQRT(GRAV) -! -! Fill middle positions of arrays ------------------------------------ * -! - DO I=1, N1MAX - SI = REAL(I)*DSIE - CALL WAVNU2 (SI,DEPTH,K,CG,1E-7,15,ICON) - EWN1(I) = K - ECG1(I) = CG - END DO -! -! Fill last positions of arrays -------------------------------------- * -! - I = N1MAX+1 - SI = REAL(I)*DSIE + ! + ! Calculate parameters ----------------------------------------------- * + ! + N1MAX = NAR1D - 1 + DEPTH = 1. + SIMAX = SQRT (GRAV * DFAC) + DSIE = SIMAX / REAL(N1MAX) + ! + ! Fill zero-th position of arrays ------------------------------------ * + ! + EWN1(0) = 0. + ECG1(0) = SQRT(GRAV) + ! + ! Fill middle positions of arrays ------------------------------------ * + ! + DO I=1, N1MAX + SI = REAL(I)*DSIE CALL WAVNU2 (SI,DEPTH,K,CG,1E-7,15,ICON) EWN1(I) = K ECG1(I) = CG -! - RETURN -!/ -!/ End of DISTAB ----------------------------------------------------- / -!/ - END SUBROUTINE DISTAB + END DO + ! + ! Fill last positions of arrays -------------------------------------- * + ! + I = N1MAX+1 + SI = REAL(I)*DSIE + CALL WAVNU2 (SI,DEPTH,K,CG,1E-7,15,ICON) + EWN1(I) = K + ECG1(I) = CG + ! + RETURN + !/ + !/ End of DISTAB ----------------------------------------------------- / + !/ + END SUBROUTINE DISTAB -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE LIU_FORWARD_DISPERSION (H_ICE,VISC,H_WDEPTH,SIGMA & - ,K_SOLUTION,CG,ALPHA) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | W. E. Rogers (NRL-SSC) | -!/ | FORTRAN 90 | -!/ | Last update : 11-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 16-Oct-2012 : Origination. ( version 4.04 ) -!/ (E. Rogers) -!/ -! 1. Purpose : -! -! Dispersion relation calculation: given frequency, find k -! This is for dispersion in ice, so it requires the ice thickness -! and viscosity also. (the latter is the "eddy viscosity in the -! turbulent boundary layer beneath the ice."). -! Please note that this is for a continuous ice cover (not broken in floes) -! -! This subroutine also calculates Cg and alpha. -! alpha is the exponential decay rate of *energy* (not to be -! confused with k_i which is the exponential decay rate of -! amplitude) -! -! Both alpha and k_i are for spatial decay rate, units (1/m) -! Neither is for temporal decay rate. -! -! References: -! N/A here, but see subroutine "Liu_reverse_dispersion" -! -! 2. Method : -! -! Newton-Raphson. -! For actual dispersion relation, see documentation of subroutine -! "Liu_reverse_dispersion" -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! H_ICE Real I Ice thickness -! VISC Real I Eddy viscosity (m2/sec) -! H_WDEPTH Real I Water depth -! SIGMA R.A. I Radian Wave frequency -! K_SOLUTION R.A. O Wave number -! CG R.A. O Group velocity -! ALPHA R.A. O Exponential decay rate of energy -! NK Int. I Number of frequencies -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name | Type | Module | Description -! ---------------------------------------------------------------- -! Liu_reverse_dispersion | Subr.| W3SIC2MD| As name implies. -! STRACE | Subr.| W3SERVMD| Subroutine tracing. -! WAVNU1 | Subr.| W3DISPMD| Wavenumber for waves -! in open water. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name | Type | Module | Description -! ---------------------------------------------------------------- -! W3SIC2 | Subr.| W3SIC2MD| S_ice source term -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! Fails if solution is not found in a given number of iterations -! -! 7. Remarks : -! -! Eventually, k and Cg should be used for propagation. This is not -! implemented yet. For now, it is only used to calculate the source -! term. -! -! For discussion of the eddy viscosity term, see documentation of -! subroutine "Liu_reverse_dispersion" -! -! This subroutine expects eddy viscosity in units of m2/sec even -! though values are given in units of cm2/sec in the Liu paper. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPI - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY: NK, IICEHDISP, IICEDDISP, IICEFDISP, IICEHMIN - ! USE W3DISPMD, ONLY: WAVNU1 + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE LIU_FORWARD_DISPERSION (H_ICE,VISC,H_WDEPTH,SIGMA & + ,K_SOLUTION,CG,ALPHA) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | W. E. Rogers (NRL-SSC) | + !/ | FORTRAN 90 | + !/ | Last update : 11-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 16-Oct-2012 : Origination. ( version 4.04 ) + !/ (E. Rogers) + !/ + ! 1. Purpose : + ! + ! Dispersion relation calculation: given frequency, find k + ! This is for dispersion in ice, so it requires the ice thickness + ! and viscosity also. (the latter is the "eddy viscosity in the + ! turbulent boundary layer beneath the ice."). + ! Please note that this is for a continuous ice cover (not broken in floes) + ! + ! This subroutine also calculates Cg and alpha. + ! alpha is the exponential decay rate of *energy* (not to be + ! confused with k_i which is the exponential decay rate of + ! amplitude) + ! + ! Both alpha and k_i are for spatial decay rate, units (1/m) + ! Neither is for temporal decay rate. + ! + ! References: + ! N/A here, but see subroutine "Liu_reverse_dispersion" + ! + ! 2. Method : + ! + ! Newton-Raphson. + ! For actual dispersion relation, see documentation of subroutine + ! "Liu_reverse_dispersion" + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! H_ICE Real I Ice thickness + ! VISC Real I Eddy viscosity (m2/sec) + ! H_WDEPTH Real I Water depth + ! SIGMA R.A. I Radian Wave frequency + ! K_SOLUTION R.A. O Wave number + ! CG R.A. O Group velocity + ! ALPHA R.A. O Exponential decay rate of energy + ! NK Int. I Number of frequencies + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name | Type | Module | Description + ! ---------------------------------------------------------------- + ! Liu_reverse_dispersion | Subr.| W3SIC2MD| As name implies. + ! STRACE | Subr.| W3SERVMD| Subroutine tracing. + ! WAVNU1 | Subr.| W3DISPMD| Wavenumber for waves + ! in open water. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name | Type | Module | Description + ! ---------------------------------------------------------------- + ! W3SIC2 | Subr.| W3SIC2MD| S_ice source term + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! Fails if solution is not found in a given number of iterations + ! + ! 7. Remarks : + ! + ! Eventually, k and Cg should be used for propagation. This is not + ! implemented yet. For now, it is only used to calculate the source + ! term. + ! + ! For discussion of the eddy viscosity term, see documentation of + ! subroutine "Liu_reverse_dispersion" + ! + ! This subroutine expects eddy viscosity in units of m2/sec even + ! though values are given in units of cm2/sec in the Liu paper. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPI + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY: NK, IICEHDISP, IICEDDISP, IICEFDISP, IICEHMIN + ! USE W3DISPMD, ONLY: WAVNU1 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - - REAL , INTENT(IN) :: H_ICE, H_WDEPTH, SIGMA(NK) - REAL , INTENT(IN) :: VISC ! in m2/sec - REAL , INTENT(OUT) :: K_SOLUTION(NK) ,CG(NK) ,ALPHA(NK) - -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + + REAL , INTENT(IN) :: H_ICE, H_WDEPTH, SIGMA(NK) + REAL , INTENT(IN) :: VISC ! in m2/sec + REAL , INTENT(OUT) :: K_SOLUTION(NK) ,CG(NK) ,ALPHA(NK) + + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IK - REAL, PARAMETER :: FERRORMAX=1.0E-5 ! maximum acceptable error - INTEGER, PARAMETER :: N_ITER=20 ! number of iterations prior to - ! failure - LOGICAL :: GET_CG ! indicates whether to get Cg - ! and alpha - ! from "Liu_reverse_dispersion" - REAL :: FREQ(20) ! wave frequency at current - ! iteration - REAL :: KWN(20) ! wavenumber at current - ! iteration - INTEGER :: ITER ! iteration number - REAL :: DK,DF,DFDK ! as name implies - REAL :: FDUMMY ! as name implies - !REAL :: SIGMA ! 2*pi/T - REAL :: K_OPEN ! open-water value of k - REAL :: CG_OPEN ! open-water value of Cg - REAL :: FWANTED ! Freq. corresponding to sigma - REAL :: FERROR ! Max acceptable error after test to avoid crash + INTEGER :: IK + REAL, PARAMETER :: FERRORMAX=1.0E-5 ! maximum acceptable error + INTEGER, PARAMETER :: N_ITER=20 ! number of iterations prior to + ! failure + LOGICAL :: GET_CG ! indicates whether to get Cg + ! and alpha + ! from "Liu_reverse_dispersion" + REAL :: FREQ(20) ! wave frequency at current + ! iteration + REAL :: KWN(20) ! wavenumber at current + ! iteration + INTEGER :: ITER ! iteration number + REAL :: DK,DF,DFDK ! as name implies + REAL :: FDUMMY ! as name implies + !REAL :: SIGMA ! 2*pi/T + REAL :: K_OPEN ! open-water value of k + REAL :: CG_OPEN ! open-water value of Cg + REAL :: FWANTED ! Freq. corresponding to sigma + REAL :: FERROR ! Max acceptable error after test to avoid crash -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'LIU_FORWARD_DISPERSION') + CALL STRACE (IENT, 'LIU_FORWARD_DISPERSION') #endif -! -!/ 0) --- Initialize/allocate variables ------------------------------ / - - - + ! + !/ 0) --- Initialize/allocate variables ------------------------------ / - DO IK = 1, NK - GET_CG = .FALSE. - !/T38 WRITE(*,*)'FORWARD IN: H_ICE,VISC,H_WDEPTH,FWANTED = ', & - !/T38 H_ICE,VISC,H_WDEPTH,FWANTED - FWANTED=SIGMA(IK)/TPI - ! First guess for k : - - CALL WAVNU1(SIGMA(IK),H_WDEPTH,K_OPEN,CG_OPEN) - ! KWN(1) = 0.2 ! (old method) - KWN(1) =K_OPEN ! new method, Mar 10 2014 - ! - !/ 1) ----- Iteration loop to find k --------------------------------- / - ITER = 0 - DF = 999. - IF ( (H_ICE.LT.IICEHDISP).OR.(H_WDEPTH.LT.IICEDDISP) ) THEN - FERROR=IICEFDISP*FERRORMAX - ELSE - FERROR=FERRORMAX - ENDIF - DO WHILE ( ABS(DF).GE.FERROR .AND. ITER.LE.N_ITER ) - ITER = ITER + 1 - ! compute freq for this iteration - CALL LIU_REVERSE_DISPERSION(H_ICE,VISC,H_WDEPTH,KWN(ITER), & - GET_CG,FREQ(ITER),CG(IK),ALPHA(IK)) + DO IK = 1, NK - ! calculate dk - IF (ITER == 1)THEN - ! We do not have slope yet, so pick a number... - DK = 0.01 - ELSEIF (ITER.EQ.N_ITER+1) THEN - WRITE(NDSE,800) N_ITER - CALL EXTCDE(2) - ELSE - ! use slope - DFDK = (FREQ(ITER)-FREQ(ITER-1)) / (KWN(ITER)-KWN(ITER-1)) - DF = FWANTED - FREQ(ITER) - !/T38 WRITE(*,*)'ITER = ',ITER,' ; K = ',KWN(ITER),' ; F = ', & - !/T38 FREQ(ITER),' ; DF = ',DF - DK = DF / DFDK - ENDIF + GET_CG = .FALSE. + !/T38 WRITE(*,*)'FORWARD IN: H_ICE,VISC,H_WDEPTH,FWANTED = ', & + !/T38 H_ICE,VISC,H_WDEPTH,FWANTED + FWANTED=SIGMA(IK)/TPI + ! First guess for k : - ! Decide on next k to try - KWN(ITER+1) = KWN(ITER) + DK - ! If we end up with a negative k for the next iteration, don't - ! allow this. - IF(KWN(ITER+1) < 0.0)THEN - KWN(ITER+1) = TPI / 1000.0 - ENDIF + CALL WAVNU1(SIGMA(IK),H_WDEPTH,K_OPEN,CG_OPEN) + ! KWN(1) = 0.2 ! (old method) + KWN(1) =K_OPEN ! new method, Mar 10 2014 + ! + !/ 1) ----- Iteration loop to find k --------------------------------- / + ITER = 0 + DF = 999. - END DO + IF ( (H_ICE.LT.IICEHDISP).OR.(H_WDEPTH.LT.IICEDDISP) ) THEN + FERROR=IICEFDISP*FERRORMAX + ELSE + FERROR=FERRORMAX + ENDIF - !/ 2) -------- Finish up. -------------------------------------------- / - ! Success, so return K_SOLUTION, and call LIU_REVERSE_DISPERSION one - ! last time, to get CG and ALPHA + DO WHILE ( ABS(DF).GE.FERROR .AND. ITER.LE.N_ITER ) + ITER = ITER + 1 + ! compute freq for this iteration + CALL LIU_REVERSE_DISPERSION(H_ICE,VISC,H_WDEPTH,KWN(ITER), & + GET_CG,FREQ(ITER),CG(IK),ALPHA(IK)) - K_SOLUTION(IK) = KWN(ITER) + ! calculate dk + IF (ITER == 1)THEN + ! We do not have slope yet, so pick a number... + DK = 0.01 + ELSEIF (ITER.EQ.N_ITER+1) THEN + WRITE(NDSE,800) N_ITER + CALL EXTCDE(2) + ELSE + ! use slope + DFDK = (FREQ(ITER)-FREQ(ITER-1)) / (KWN(ITER)-KWN(ITER-1)) + DF = FWANTED - FREQ(ITER) + !/T38 WRITE(*,*)'ITER = ',ITER,' ; K = ',KWN(ITER),' ; F = ', & + !/T38 FREQ(ITER),' ; DF = ',DF + DK = DF / DFDK + ENDIF - GET_CG = .TRUE. + ! Decide on next k to try + KWN(ITER+1) = KWN(ITER) + DK + ! If we end up with a negative k for the next iteration, don't + ! allow this. + IF(KWN(ITER+1) < 0.0)THEN + KWN(ITER+1) = TPI / 1000.0 + ENDIF + + END DO + + !/ 2) -------- Finish up. -------------------------------------------- / + ! Success, so return K_SOLUTION, and call LIU_REVERSE_DISPERSION one + ! last time, to get CG and ALPHA + + K_SOLUTION(IK) = KWN(ITER) + + GET_CG = .TRUE. CALL LIU_REVERSE_DISPERSION(H_ICE,VISC,H_WDEPTH,K_SOLUTION(IK), & GET_CG,FDUMMY,CG(IK),ALPHA(IK)) - END DO -! + END DO + ! #ifdef W3_T38 - WRITE(*,*)'FORWARD OUT: K_SOLUTION,CG,ALPHA = ', & - K_SOLUTION,CG,ALPHA - IF (H_ICE==1.0)THEN - WRITE(*,*)FWANTED,ALPHA - ENDIF + WRITE(*,*)'FORWARD OUT: K_SOLUTION,CG,ALPHA = ', & + K_SOLUTION,CG,ALPHA + IF (H_ICE==1.0)THEN + WRITE(*,*)FWANTED,ALPHA + ENDIF #endif -! - 800 FORMAT (/' *** WAVEWATCH III ERROR IN ' & - 'W3SIC2_LIU_FORWARD_DISPERSION : ' / & - ' NO SOLUTION FOUND AFTER ',I4,' ITERATIONS.') -!/ -!/ End of LIU_FORWARD_DISPERSION ------------------------------------- / -!/ - END SUBROUTINE LIU_FORWARD_DISPERSION -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE LIU_REVERSE_DISPERSION (H_ICE,VISC,H_WDEPTH,KWN & - ,GET_CG,FREQ,CG,ALPHA) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | W. E. Rogers (NRL-SSC) | -!/ | FORTRAN 90 | -!/ | Last update : 11-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 12-Oct-2012 : Origination. ( version 4.04 ) -!/ (E. Rogers) -!/ -! 1. Purpose : -! -! Dispersion relation calculation: given k, find frequency. -! This is for dispersion in ice, so it requires the ice thickness -! and viscosity also. (the latter is the "eddy viscosity in the -! turbulent boundary layer beneath the ice."). -! -! This subroutine also (optionally) calculates Cg and alpha. -! alpha is the exponential decay rate of *energy* (not to be -! confused with k_i which is the exponential decay rate of -! amplitude) -! -! Both alpha and k_i are for spatial decay rate, units (1/m) -! Neither is for temporal decay rate. + ! +800 FORMAT (/' *** WAVEWATCH III ERROR IN ' & + 'W3SIC2_LIU_FORWARD_DISPERSION : ' / & + ' NO SOLUTION FOUND AFTER ',I4,' ITERATIONS.') + !/ + !/ End of LIU_FORWARD_DISPERSION ------------------------------------- / + !/ + END SUBROUTINE LIU_FORWARD_DISPERSION + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE LIU_REVERSE_DISPERSION (H_ICE,VISC,H_WDEPTH,KWN & + ,GET_CG,FREQ,CG,ALPHA) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | W. E. Rogers (NRL-SSC) | + !/ | FORTRAN 90 | + !/ | Last update : 11-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 12-Oct-2012 : Origination. ( version 4.04 ) + !/ (E. Rogers) + !/ + ! 1. Purpose : + ! + ! Dispersion relation calculation: given k, find frequency. + ! This is for dispersion in ice, so it requires the ice thickness + ! and viscosity also. (the latter is the "eddy viscosity in the + ! turbulent boundary layer beneath the ice."). + ! + ! This subroutine also (optionally) calculates Cg and alpha. + ! alpha is the exponential decay rate of *energy* (not to be + ! confused with k_i which is the exponential decay rate of + ! amplitude) + ! + ! Both alpha and k_i are for spatial decay rate, units (1/m) + ! Neither is for temporal decay rate. -! This calculation is optional for reasons of computational -! efficiency (don't calculate if it will not be used). Note that -! if Cg and alpha are not calculated, the value of input viscosity -! is irrelevant. -! -! References: -! Liu et al. 1991: JGR 96 (C3), 4605-4621 -! Liu and Mollo 1988: JPO 18 1720-1712 -! -! 2. Method : -! -! In 1991 paper, see equations on page 4606. The key equations are: -! sigma2=(grav*k+B*k^5)/((coth(k*H_wdepth))+k*M); -! Cg=(grav+(5+4*k*M)*(B*k^4))/((2*sigma)*((1+k*M)^2)); -! alpha=(sqrt(visc)*k*sqrt(sigma))/(Cg*sqrt(2)*(1+k*M)); -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! H_ICE REAL I Ice thickness -! VISC REAL I Eddy viscosity (if GET_CG) (m2/sec) -! H_WDEPTH REAL I Water depth -! KWN REAL I Wavenumber -! GET_CG LOGICAL I Indicates whether to calculate Cg and alpha -! FREQ REAL O Frequency -! CG REAL O Group velocity (if GET_CG) -! ALPHA REAL O Exponential decay rate of energy (if GET_CG) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name | Type | Module | Description -! ---------------------------------------------------------------- -! Liu_forward_dispersion| Subr.| W3SIC2MD| As name implies. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! Eventually, k and Cg should be used for propagation. This is not -! implemented yet. For now, it is only used to calculate the source -! term. -! -! The eddy viscosity term given by Liu is unfortunately highly -! variable, and "not a physical parameter", which suggests that it -! is difficult to specify in practice. In this paper, we see values -! of: -! nu= 160.0e-4 m2/sec (Brennecke (1921) -! nu= 24.0e-4 m2/sec (Hunkins 1966) -! nu=3450.0e-4 m2/sec (Fig 11) -! nu= 4.0e-4 m2/sec (Fig 12) -! nu= 150.0e-4 m2/sec (Fig 13) -! nu= 54.0e-4 m2/sec (Fig 14) -! nu= 384.0e-4 m2/sec (Fig 15) -! nu=1536.0e-4 m2/sec (Fig 16) -! -! The paper states: "The only tuning parameter is the turbulent eddy -! viscosity, and it is a function of the flow conditions in the -! turbulent boundary layer which are determined by the ice -! thickness, floe sizes, ice concentration, and wavelength." -! -! Another criticism of this source term is that it does not use the -! ice concentration in actual calculations. The method appears to -! simply rely on concentration being high, "When the ice is highly -! compact with high concentration, the flexural waves obey the -! dispersion relation (1) as similar waves in a continuous ice -! sheet." Later, "Five of these cases with high ice conentration -! (larger than 60%) in the MIZ have been selected" -! -! This subroutine expects eddy viscosity in units of m2/sec even -! though values are given in units of cm2/sec in the Liu paper. -! -! Cg used here is correct only for deep water. It is taken from -! Liu et al. (1991) equation 2. If we want to calculate for finite -! depths accurately, we need to use d_sigma/d_k. However, be warned -! that this calculation is sensitive to numerical error and so the -! (potentially too coarse) computational grid for sigma and k should -! *not* be used. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: DWAT, TPI, GRAV - USE W3GDATMD, ONLY: NK + ! This calculation is optional for reasons of computational + ! efficiency (don't calculate if it will not be used). Note that + ! if Cg and alpha are not calculated, the value of input viscosity + ! is irrelevant. + ! + ! References: + ! Liu et al. 1991: JGR 96 (C3), 4605-4621 + ! Liu and Mollo 1988: JPO 18 1720-1712 + ! + ! 2. Method : + ! + ! In 1991 paper, see equations on page 4606. The key equations are: + ! sigma2=(grav*k+B*k^5)/((coth(k*H_wdepth))+k*M); + ! Cg=(grav+(5+4*k*M)*(B*k^4))/((2*sigma)*((1+k*M)^2)); + ! alpha=(sqrt(visc)*k*sqrt(sigma))/(Cg*sqrt(2)*(1+k*M)); + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! H_ICE REAL I Ice thickness + ! VISC REAL I Eddy viscosity (if GET_CG) (m2/sec) + ! H_WDEPTH REAL I Water depth + ! KWN REAL I Wavenumber + ! GET_CG LOGICAL I Indicates whether to calculate Cg and alpha + ! FREQ REAL O Frequency + ! CG REAL O Group velocity (if GET_CG) + ! ALPHA REAL O Exponential decay rate of energy (if GET_CG) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name | Type | Module | Description + ! ---------------------------------------------------------------- + ! Liu_forward_dispersion| Subr.| W3SIC2MD| As name implies. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! Eventually, k and Cg should be used for propagation. This is not + ! implemented yet. For now, it is only used to calculate the source + ! term. + ! + ! The eddy viscosity term given by Liu is unfortunately highly + ! variable, and "not a physical parameter", which suggests that it + ! is difficult to specify in practice. In this paper, we see values + ! of: + ! nu= 160.0e-4 m2/sec (Brennecke (1921) + ! nu= 24.0e-4 m2/sec (Hunkins 1966) + ! nu=3450.0e-4 m2/sec (Fig 11) + ! nu= 4.0e-4 m2/sec (Fig 12) + ! nu= 150.0e-4 m2/sec (Fig 13) + ! nu= 54.0e-4 m2/sec (Fig 14) + ! nu= 384.0e-4 m2/sec (Fig 15) + ! nu=1536.0e-4 m2/sec (Fig 16) + ! + ! The paper states: "The only tuning parameter is the turbulent eddy + ! viscosity, and it is a function of the flow conditions in the + ! turbulent boundary layer which are determined by the ice + ! thickness, floe sizes, ice concentration, and wavelength." + ! + ! Another criticism of this source term is that it does not use the + ! ice concentration in actual calculations. The method appears to + ! simply rely on concentration being high, "When the ice is highly + ! compact with high concentration, the flexural waves obey the + ! dispersion relation (1) as similar waves in a continuous ice + ! sheet." Later, "Five of these cases with high ice conentration + ! (larger than 60%) in the MIZ have been selected" + ! + ! This subroutine expects eddy viscosity in units of m2/sec even + ! though values are given in units of cm2/sec in the Liu paper. + ! + ! Cg used here is correct only for deep water. It is taken from + ! Liu et al. (1991) equation 2. If we want to calculate for finite + ! depths accurately, we need to use d_sigma/d_k. However, be warned + ! that this calculation is sensitive to numerical error and so the + ! (potentially too coarse) computational grid for sigma and k should + ! *not* be used. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: DWAT, TPI, GRAV + USE W3GDATMD, ONLY: NK #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL , INTENT(IN) :: H_ICE,H_WDEPTH,KWN - REAL , INTENT(IN) :: VISC ! in m2/sec - LOGICAL, INTENT(IN) :: GET_CG - REAL , INTENT(OUT) :: FREQ,CG,ALPHA -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL , INTENT(IN) :: H_ICE,H_WDEPTH,KWN + REAL , INTENT(IN) :: VISC ! in m2/sec + LOGICAL, INTENT(IN) :: GET_CG + REAL , INTENT(OUT) :: FREQ,CG,ALPHA + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL, PARAMETER :: E = 6.0E+9 ! Young's modulus of elasticity - REAL, PARAMETER :: S = 0.3 ! "s", Poisson's ratio - REAL :: DICE ! "dice", density of ice - REAL :: B ! quantifies effect of bending - ! of ice - REAL :: M ! quantifies effect of inertia - ! of ice - REAL :: COTHTERM ! temporary variable - REAL :: SIGMA ! 2*pi/T - REAL :: KH ! k*h -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL, PARAMETER :: E = 6.0E+9 ! Young's modulus of elasticity + REAL, PARAMETER :: S = 0.3 ! "s", Poisson's ratio + REAL :: DICE ! "dice", density of ice + REAL :: B ! quantifies effect of bending + ! of ice + REAL :: M ! quantifies effect of inertia + ! of ice + REAL :: COTHTERM ! temporary variable + REAL :: SIGMA ! 2*pi/T + REAL :: KH ! k*h + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'LIU_REVERSE_DISPERSION') + CALL STRACE (IENT, 'LIU_REVERSE_DISPERSION') #endif -! -!/ 0) --- Initialize essential parameters ---------------------------- / - CG = 0. - ALPHA = 0. - FREQ = 0. - DICE = DWAT * 0.9 ! from Liu 1991 pg 4606 + ! + !/ 0) --- Initialize essential parameters ---------------------------- / + CG = 0. + ALPHA = 0. + FREQ = 0. + DICE = DWAT * 0.9 ! from Liu 1991 pg 4606 #ifdef W3_T38 - WRITE(*,*)'REVERSE IN: H_ICE,VISC,H_WDEPTH,KWN,GET_CG = ', & - H_ICE,VISC,H_WDEPTH,KWN,GET_CG + WRITE(*,*)'REVERSE IN: H_ICE,VISC,H_WDEPTH,KWN,GET_CG = ', & + H_ICE,VISC,H_WDEPTH,KWN,GET_CG #endif -! -!/ 1) --- Calculate frequency ---------------------------------------- / + ! + !/ 1) --- Calculate frequency ---------------------------------------- / -! Note: Liu et al 1991 have "kwn*h_ice" in COTH(_) but I believe they -! meant to write "kwn*H_wdepth" + ! Note: Liu et al 1991 have "kwn*h_ice" in COTH(_) but I believe they + ! meant to write "kwn*H_wdepth" - B = (E * H_ICE**3) / (12. * (1. - S**2) * DWAT) - M = DICE * H_ICE / DWAT - KH = KWN * H_WDEPTH - IF ( KH>5.0 ) THEN - COTHTERM = 1.0 - ELSEIF ( KH<1.0E-4 ) THEN - COTHTERM = 1.0 / KH - ELSE - COTHTERM = COSH(KH) / SINH(KH) - ENDIF - SIGMA = SQRT((GRAV * KWN + B * KWN**5) / (COTHTERM + KWN * M)) - FREQ = SIGMA/(TPI) + B = (E * H_ICE**3) / (12. * (1. - S**2) * DWAT) + M = DICE * H_ICE / DWAT + KH = KWN * H_WDEPTH + IF ( KH>5.0 ) THEN + COTHTERM = 1.0 + ELSEIF ( KH<1.0E-4 ) THEN + COTHTERM = 1.0 / KH + ELSE + COTHTERM = COSH(KH) / SINH(KH) + ENDIF + SIGMA = SQRT((GRAV * KWN + B * KWN**5) / (COTHTERM + KWN * M)) + FREQ = SIGMA/(TPI) -!/ 2) --- Calculate Cg and alpha if requested ------------------------ / -! Note: Cg is correct only for deep water - IF (GET_CG) THEN - CG = (GRAV + (5.0+4.0 * KWN * M) * (B * KWN**4)) & - / (2.0 * SIGMA * ((1.0 + KWN * M)**2)) - ALPHA = (SQRT(VISC) * KWN * SQRT(SIGMA)) & - / (CG * SQRT(2.0) * (1 + KWN * M)) - ENDIF + !/ 2) --- Calculate Cg and alpha if requested ------------------------ / + ! Note: Cg is correct only for deep water + IF (GET_CG) THEN + CG = (GRAV + (5.0+4.0 * KWN * M) * (B * KWN**4)) & + / (2.0 * SIGMA * ((1.0 + KWN * M)**2)) + ALPHA = (SQRT(VISC) * KWN * SQRT(SIGMA)) & + / (CG * SQRT(2.0) * (1 + KWN * M)) + ENDIF #ifdef W3_T38 - WRITE(*,*)'REVERSE OUT: FREQ,CG,ALPHA = ',FREQ,CG,ALPHA + WRITE(*,*)'REVERSE OUT: FREQ,CG,ALPHA = ',FREQ,CG,ALPHA #endif -!/ -!/ End of LIU_REVERSE_DISPERSION ------------------------------------- / -!/ - END SUBROUTINE LIU_REVERSE_DISPERSION -!/ ------------------------------------------------------------------- / -!/ -!/ End of module W3DISPMD -------------------------------------------- / -!/ - END MODULE W3DISPMD + !/ + !/ End of LIU_REVERSE_DISPERSION ------------------------------------- / + !/ + END SUBROUTINE LIU_REVERSE_DISPERSION + !/ ------------------------------------------------------------------- / + !/ + !/ End of module W3DISPMD -------------------------------------------- / + !/ +END MODULE W3DISPMD diff --git a/model/src/w3fld1md.F90 b/model/src/w3fld1md.F90 index 970e20706..960fd185a 100644 --- a/model/src/w3fld1md.F90 +++ b/model/src/w3fld1md.F90 @@ -1,1473 +1,1470 @@ !/ ------------------------------------------------------------------- / - Module W3FLD1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP/NOPP | -!/ | B. G. Reichl | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 01-Jul-2013 : Origination. ( version 4.xx ) -!/ 18-Mar-2015 : Clean-up/prepare for distribution ( version 5.12 ) -!/ 15-Jan-2016 : Updates ( version 5.12 ) -!/ ( B. G. Reichl ) -!/ 27-Jul-2016 : Added Charnock output (J.Meixner) ( version 5.12 ) -!/ 22-Jun-2018 : updated SIG2WN subroutine (X.Chen) ( version 6.06 ) -!/ modified the range of wind profile computation; -!/ corrected direction of the shortest waves -!/ 22-Mar-2021 : Consider DAIR a variable ( version 7.13 ) -!/ -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! This Module contains routines to compute the wind stress vector -! from the wave spectrum, the wind vector, and the lower atmospheric -! stability (the form included here is for neutral conditions, but -! the structure needed to include stability is included in comments). -! The stress calculated via this subroutine is -! intended for coupling to serve as the boundary condition -! between the ocean and atmosphere, and (for now) -! and has no impact on the wave spectrum calculated. -! The calculation in w3fld1 is based on the method -! presented in Reichl, Hara, and Ginis (2014), "Sea State Dependence -! of the Wind Stress under Hurricane Winds." -! -! 2. Variables and types : -! -! Not applicable. -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3FLD1 Subr. Public Reichl et al. 2014 stress calculation -! INFLD1 Subr. Public Corresponding initialization routine. -! APPENDTAIL Subr. Public Modification of tail for calculation -! SIG2WN Subr. Public Depth-dependent dispersion relation -! WND2Z0M Subr. Public Wind to roughness length -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/ -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! - PUBLIC - ! Tail_Choice: Chose the method to determine the level of the tail - INTEGER, SAVE :: Tail_Choice +Module W3FLD1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP/NOPP | + !/ | B. G. Reichl | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 01-Jul-2013 : Origination. ( version 4.xx ) + !/ 18-Mar-2015 : Clean-up/prepare for distribution ( version 5.12 ) + !/ 15-Jan-2016 : Updates ( version 5.12 ) + !/ ( B. G. Reichl ) + !/ 27-Jul-2016 : Added Charnock output (J.Meixner) ( version 5.12 ) + !/ 22-Jun-2018 : updated SIG2WN subroutine (X.Chen) ( version 6.06 ) + !/ modified the range of wind profile computation; + !/ corrected direction of the shortest waves + !/ 22-Mar-2021 : Consider DAIR a variable ( version 7.13 ) + !/ + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! This Module contains routines to compute the wind stress vector + ! from the wave spectrum, the wind vector, and the lower atmospheric + ! stability (the form included here is for neutral conditions, but + ! the structure needed to include stability is included in comments). + ! The stress calculated via this subroutine is + ! intended for coupling to serve as the boundary condition + ! between the ocean and atmosphere, and (for now) + ! and has no impact on the wave spectrum calculated. + ! The calculation in w3fld1 is based on the method + ! presented in Reichl, Hara, and Ginis (2014), "Sea State Dependence + ! of the Wind Stress under Hurricane Winds." + ! + ! 2. Variables and types : + ! + ! Not applicable. + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3FLD1 Subr. Public Reichl et al. 2014 stress calculation + ! INFLD1 Subr. Public Corresponding initialization routine. + ! APPENDTAIL Subr. Public Modification of tail for calculation + ! SIG2WN Subr. Public Depth-dependent dispersion relation + ! WND2Z0M Subr. Public Wind to roughness length + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/ + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + PUBLIC + ! Tail_Choice: Chose the method to determine the level of the tail + INTEGER, SAVE :: Tail_Choice #ifdef W3_OMPG -!$omp threadprivate(Tail_Choice) + !$omp threadprivate(Tail_Choice) #endif - REAL, SAVE :: Tail_Level !if Tail_Choice=0, tail is constant - REAL, SAVE :: Tail_transition_ratio1! freq/fpi where tail - ! adjustment begins - REAL, SAVE :: Tail_transition_ratio2! freq/fpi where tail - ! adjustment ends + REAL, SAVE :: Tail_Level !if Tail_Choice=0, tail is constant + REAL, SAVE :: Tail_transition_ratio1! freq/fpi where tail + ! adjustment begins + REAL, SAVE :: Tail_transition_ratio2! freq/fpi where tail + ! adjustment ends #ifdef W3_OMPG -!$omp threadprivate(Tail_Level) -!$omp threadprivate(Tail_transition_ratio1,Tail_transition_ratio2) + !$omp threadprivate(Tail_Level) + !$omp threadprivate(Tail_transition_ratio1,Tail_transition_ratio2) #endif -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3FLD1( ASPC, FPI, WNDX,WNDY, ZWND, & - DEPTH, RIB, DAIR, UST, USTD, Z0, & - TAUNUX, TAUNUY, CHARN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP/NOPP | -!/ | B. G. Reichl | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 01-Jul-2013 : Origination. ( version 4.xx ) -!/ 18-Mar-2015 : Prepare for submission ( version 5.12 ) -!/ 22-Mar-2021 : Consider DAIR a variable ( version 7.13 ) -!/ -! 1. Purpose : -! -! Diagnostic stress vector calculation from wave spectrum, lower -! atmosphere stability, and wind vector (at some given height). -! The height of wind vector is assumed to be within the constant -! stress layer. These parameterizations are meant to be performed -! at wind speeds > 10 m/s, and may not converge for extremely young -! seas (i.e. starting from flat sea conditions). -! -! 2. Method : -! See Reichl et al. (2014). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ASPC Real I 1-D Wave action spectrum. -! FPI Real I Peak input frequency. -! WNDX Real I X-dir wind (assumed referenced to current) -! WNDY Real I Y-dir wind (assumed referenced to current) -! ZWND Real I Wind height. -! DEPTH Real I Water depth. -! RIB REAL I Bulk Richardson in lower atmosphere -! (for determining stability in ABL to get -! 10 m neutral wind) -! DAIR REAL I Air density -! TAUNUX Real 0 X-dir viscous stress (guessed from prev.) -! TAUNUY Real 0 Y-dir viscous stress (guessed from prev.) -! UST Real O Friction velocity. -! USTD Real O Direction of friction velocity. -! Z0 Real O Surface roughness length -! CHARN Real O,optional Charnock parameter -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3ASIM Subr. W3ASIMMD Air-sea interface module. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, DWAT, TPI, PI, KAPPA - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, XFR, TH - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3FLD1( ASPC, FPI, WNDX,WNDY, ZWND, & + DEPTH, RIB, DAIR, UST, USTD, Z0, & + TAUNUX, TAUNUY, CHARN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP/NOPP | + !/ | B. G. Reichl | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 01-Jul-2013 : Origination. ( version 4.xx ) + !/ 18-Mar-2015 : Prepare for submission ( version 5.12 ) + !/ 22-Mar-2021 : Consider DAIR a variable ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Diagnostic stress vector calculation from wave spectrum, lower + ! atmosphere stability, and wind vector (at some given height). + ! The height of wind vector is assumed to be within the constant + ! stress layer. These parameterizations are meant to be performed + ! at wind speeds > 10 m/s, and may not converge for extremely young + ! seas (i.e. starting from flat sea conditions). + ! + ! 2. Method : + ! See Reichl et al. (2014). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ASPC Real I 1-D Wave action spectrum. + ! FPI Real I Peak input frequency. + ! WNDX Real I X-dir wind (assumed referenced to current) + ! WNDY Real I Y-dir wind (assumed referenced to current) + ! ZWND Real I Wind height. + ! DEPTH Real I Water depth. + ! RIB REAL I Bulk Richardson in lower atmosphere + ! (for determining stability in ABL to get + ! 10 m neutral wind) + ! DAIR REAL I Air density + ! TAUNUX Real 0 X-dir viscous stress (guessed from prev.) + ! TAUNUY Real 0 Y-dir viscous stress (guessed from prev.) + ! UST Real O Friction velocity. + ! USTD Real O Direction of friction velocity. + ! Z0 Real O Surface roughness length + ! CHARN Real O,optional Charnock parameter + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3ASIM Subr. W3ASIMMD Air-sea interface module. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, DWAT, TPI, PI, KAPPA + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, XFR, TH + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: ASPC(NSPEC), WNDX, WNDY, & - ZWND, DEPTH, RIB, DAIR, FPI - REAL, INTENT(OUT) :: UST, USTD, Z0 - REAL, INTENT(OUT), OPTIONAL :: CHARN - REAL, INTENT(INOUT) :: TAUNUX, TAUNUY -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - REAL, PARAMETER :: NU=0.105/10000.0 - REAL, PARAMETER :: DELTA=0.03 - ! Commonly used parameters - REAL :: wnd_in_mag, wnd_in_dir - !For Calculating Tail - REAL :: KMAX, KTAILA, KTAILB, KTAILC - REAL :: SAT, z01, z02, u10 - LOGICAL :: ITERFLAG - INTEGER :: COUNT - !For Iterations - REAL :: DTX, DTY, iter_thresh, & - USTSM, Z0SM, Z1 - !For stress calculation - REAL :: WAGE, CBETA, BP, CD, & - USTRB, ANGDIF, USTAR, ZNU, & - TAUT, TAUX, TAUY, BETAG, TAUDIR, & - TAUDIRB - !For wind profile calculation - REAL :: UPROFV, VPROFV - !For wind profile iteration - REAL :: WND_1X, WND_1Y, & - WND_2X, WND_2Y, & - WND_3X, WND_3Y, & - DIFU10XX, DIFU10YX, DIFU10XY, DIFU10YY, & - FD_A, FD_B, FD_C, FD_D, & - DWNDX, DWNDY, & - APAR, CH,UITV, VITV,USTL,& - CK - !For adding stability to wind profile - REAL :: WND_TOP, ANG_TOP, WND_PA, WND_PE, & - WND_PEx, WND_PEy, WND_PAx, WND_PAy, & - CDM - INTEGER :: NKT, K, T, Z2, ITER, ZI, ZII, & - I, CTR, ITERATION, KA1, KA2, & - KA3, KB - ! For defining extended spectrum with appended tail. - REAL, ALLOCATABLE, DIMENSION(:) :: WN, DWN, CP,SIG2 - REAL, ALLOCATABLE, DIMENSION(:,:) :: SPC2 - REAL, ALLOCATABLE, DIMENSION(:) :: TLTN, TLTE, TAUD, & - TLTND, & - TLTED, ZOFK, UPROF, VPROF, & - FTILDE, UP1, VP1, UP, VP, & - TLTNA, TLTEA + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: ASPC(NSPEC), WNDX, WNDY, & + ZWND, DEPTH, RIB, DAIR, FPI + REAL, INTENT(OUT) :: UST, USTD, Z0 + REAL, INTENT(OUT), OPTIONAL :: CHARN + REAL, INTENT(INOUT) :: TAUNUX, TAUNUY + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL, PARAMETER :: NU=0.105/10000.0 + REAL, PARAMETER :: DELTA=0.03 + ! Commonly used parameters + REAL :: wnd_in_mag, wnd_in_dir + !For Calculating Tail + REAL :: KMAX, KTAILA, KTAILB, KTAILC + REAL :: SAT, z01, z02, u10 + LOGICAL :: ITERFLAG + INTEGER :: COUNT + !For Iterations + REAL :: DTX, DTY, iter_thresh, & + USTSM, Z0SM, Z1 + !For stress calculation + REAL :: WAGE, CBETA, BP, CD, & + USTRB, ANGDIF, USTAR, ZNU, & + TAUT, TAUX, TAUY, BETAG, TAUDIR, & + TAUDIRB + !For wind profile calculation + REAL :: UPROFV, VPROFV + !For wind profile iteration + REAL :: WND_1X, WND_1Y, & + WND_2X, WND_2Y, & + WND_3X, WND_3Y, & + DIFU10XX, DIFU10YX, DIFU10XY, DIFU10YY, & + FD_A, FD_B, FD_C, FD_D, & + DWNDX, DWNDY, & + APAR, CH,UITV, VITV,USTL,& + CK + !For adding stability to wind profile + REAL :: WND_TOP, ANG_TOP, WND_PA, WND_PE, & + WND_PEx, WND_PEy, WND_PAx, WND_PAy, & + CDM + INTEGER :: NKT, K, T, Z2, ITER, ZI, ZII, & + I, CTR, ITERATION, KA1, KA2, & + KA3, KB + ! For defining extended spectrum with appended tail. + REAL, ALLOCATABLE, DIMENSION(:) :: WN, DWN, CP,SIG2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: SPC2 + REAL, ALLOCATABLE, DIMENSION(:) :: TLTN, TLTE, TAUD, & + TLTND, & + TLTED, ZOFK, UPROF, VPROF, & + FTILDE, UP1, VP1, UP, VP, & + TLTNA, TLTEA #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - LOGICAL :: FSFL1,FSFL2, CRIT1, CRIT2 - LOGICAL :: IT_FLAG1, IT_FLAG2 - LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: FSFL1,FSFL2, CRIT1, CRIT2 + LOGICAL :: IT_FLAG1, IT_FLAG2 + LOGICAL, SAVE :: FIRST = .TRUE. #ifdef W3_OMPG -!$omp threadprivate( FIRST) + !$omp threadprivate( FIRST) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLD1') + CALL STRACE (IENT, 'W3FLD1') #endif -! -! 0. Initializations ------------------------------------------------ * -! -! ********************************************************** -! *** The initialization routine should include all *** -! *** initialization, including reading data from files. *** -! ********************************************************** -! - IF ( FIRST ) THEN - CALL INFLD - FIRST = .FALSE. - END IF - wnd_in_mag = sqrt( wndx**2 + wndy**2 ) - wnd_in_dir = atan2(wndy, wndx) - !----------------------------------------------------------+ - ! Assume wind input is neutral 10 m wind. If wind input + - ! is not 10 m, tail level will need to be calculated based + - ! on esimation of 10 m wind. + - !----------------------------------------------------------+ - u10 = wnd_in_mag - ! - Get tail level - if (Tail_Choice.eq.0) then - SAT=Tail_Level - elseif (Tail_Choice.eq.1) then - CALL WND2SAT(U10,SAT) - endif -! -! 1. Attach Tail ---------------------------------------------------- * -! -! If the depth remains constant, the allocation could be limited to the -! first time step. Since this code is designed for coupled -! implementation where the water level can change, I keep it the -! allocation on every time step. When computational efficiency is -! important, this process may be rethought. -! - ! i. Find maximum wavenumber of input spectrum - call sig2wn(sig(nk),depth,kmax) - NKT = NK - ! ii. Find additional wavenumber bins to extended to cm scale waves - DO WHILE ( KMAX .LT. 366.0 ) - NKT = NKT + 1 - KMAX = ( KMAX * XFR**2 ) - ENDDO!K<366 - ! iii. Allocate new "extended" spectrum - ALLOCATE( WN(NKT), DWN(NKT), CP(NKT), SIG2(NKT),SPC2(NKT,NTH), & - TLTN(NKT), TLTE(NKT), TAUD(NKT), & - TLTND(NKT), TLTED(NKT), ZOFK(NKT), UPROF(NKT+1),& - VPROF(NKT+1), FTILDE(NKT), UP1(NKT+1),VP1(NKT+1), & - UP(NKT+1), VP(NKT+1), TLTNA(NKT),TLTEA(NKT)) -! -! 1a. Build Discrete Wavenumbers for defining extended spectrum on---- * -! - !i. Copy existing sig to extended sig2, calculate phase speed. - DO K = 1, NK !existing spectrum - call sig2wn(sig(k),depth,wn(k)) - CP(K) = ( SIG(K) / WN(K) ) - sig2(k) = sig(k) - ENDDO!K - !ii. Calculate extended sig2 and phase speed. - DO K = ( NK + 1 ), ( NKT) !extension - sig2(k) = sig2(k-1) *XFR - call sig2wn(sig2(k),depth,wn(k)) - CP(K) = SIG2(K) / WN(K) - ENDDO!K - !iii. Calculate dk's for integrations. - DO K = 1, NKT-1 - DWN(K) = WN(K+1) - WN(K) - ENDDO - DWN(NKT) = WN(NKT)*XFR**2 - WN(NKT) -! -! 1b. Attach initial tail--------------------------------------------- * -! - !i. Convert action spectrum to variance spectrum - ! SPC(k,theta) = A(k,theta) * sig(k) - ! This could be redone for computational efficiency - I=0 - DO K=1, NK - DO T=1, NTH - I = I + 1 - SPC2(K,T) = ASPC(I) * SIG(K) - ENDDO!T - ENDDO!K - !ii. Extend k^-3 tail to extended spectrum - DO K=NK+1, NKT - DO T=1, NTH - SPC2(K,T)=SPC2(NK,T)*WN(NK)**3.0/WN(K)**(3.0) - ENDDO!T - ENDDO!K -! -! 1c. Calculate transitions for new (constant saturation ) tail ------ * -! -! - !i. Find wavenumber for beginning spc level transition to tail - call sig2wn (FPI*TPI*tail_transition_ratio1,depth,ktaila ) - !ii. Find wavenumber for ending spc level transition to tail - call sig2wn (FPI*TPI*tail_transition_ratio2,depth,ktailb ) - !iii. Find wavenumber for ending spc direction transition to tail - KTAILC= KTAILB * 2.0 - !iv. Find corresponding indices of wavenumber transitions - KA1 = 2 ! Do not modify 1st wavenumber bin - DO WHILE ( ( KTAILA .GE. WN(KA1) ) .AND. (KA1 .LT. NKT-6) ) - KA1 = KA1 + 1 - ENDDO - KA2 = KA1+2 - DO WHILE ( ( KTAILB .GE. WN(KA2) ) .AND. (KA2 .LT. NKT-4) ) - KA2 = KA2 + 1 - ENDDO - KA3 = KA2+2 - DO WHILE ( ( KTAILC .GE. WN(KA3)) .AND. (KA3 .LT. NKT-2) ) - KA3 = KA3 + 1 - ENDDO - !v. Call subroutine to perform actually tail truncation - ! only if there is some energy in spectrum - CALL APPENDTAIL(SPC2, WN, NKT, KA1, KA2, KA3,& - wnd_in_dir, SAT) - ! Spectrum is now set for stress integration -! -! 2. Prepare for iterative calculation of wave-form stress----------- * -! - DTX = 0.00005 - DTY = 0.00005 - iter_thresh = 0.001 -! -! 2a. Calculate initial guess for viscous stress from smooth-law------ * -! (Would be preferable to use prev. step) -! - Z0SM = 0.001 !Guess - IT_FLAG1 = .true. - ITERATION = 0 - DO WHILE( IT_FLAG1 ) - ITERATION = ITERATION + 1 - Z1 = Z0SM - USTSM = KAPPA * wnd_in_mag / ( LOG( ZWND / Z1 ) ) - Z0SM = 0.132 * NU / USTSM - IF ( (ABS( Z0SM - Z1 ) .LT. 10.0**(-6)) .OR.& - ( ITERATION .GT. 5 )) THEN - IT_FLAG1 = .false. - ENDIF - ENDDO + ! + ! 0. Initializations ------------------------------------------------ * + ! + ! ********************************************************** + ! *** The initialization routine should include all *** + ! *** initialization, including reading data from files. *** + ! ********************************************************** + ! + IF ( FIRST ) THEN + CALL INFLD + FIRST = .FALSE. + END IF + wnd_in_mag = sqrt( wndx**2 + wndy**2 ) + wnd_in_dir = atan2(wndy, wndx) + !----------------------------------------------------------+ + ! Assume wind input is neutral 10 m wind. If wind input + + ! is not 10 m, tail level will need to be calculated based + + ! on esimation of 10 m wind. + + !----------------------------------------------------------+ + u10 = wnd_in_mag + ! - Get tail level + if (Tail_Choice.eq.0) then + SAT=Tail_Level + elseif (Tail_Choice.eq.1) then + CALL WND2SAT(U10,SAT) + endif + ! + ! 1. Attach Tail ---------------------------------------------------- * + ! + ! If the depth remains constant, the allocation could be limited to the + ! first time step. Since this code is designed for coupled + ! implementation where the water level can change, I keep it the + ! allocation on every time step. When computational efficiency is + ! important, this process may be rethought. + ! + ! i. Find maximum wavenumber of input spectrum + call sig2wn(sig(nk),depth,kmax) + NKT = NK + ! ii. Find additional wavenumber bins to extended to cm scale waves + DO WHILE ( KMAX .LT. 366.0 ) + NKT = NKT + 1 + KMAX = ( KMAX * XFR**2 ) + ENDDO!K<366 + ! iii. Allocate new "extended" spectrum + ALLOCATE( WN(NKT), DWN(NKT), CP(NKT), SIG2(NKT),SPC2(NKT,NTH), & + TLTN(NKT), TLTE(NKT), TAUD(NKT), & + TLTND(NKT), TLTED(NKT), ZOFK(NKT), UPROF(NKT+1),& + VPROF(NKT+1), FTILDE(NKT), UP1(NKT+1),VP1(NKT+1), & + UP(NKT+1), VP(NKT+1), TLTNA(NKT),TLTEA(NKT)) + ! + ! 1a. Build Discrete Wavenumbers for defining extended spectrum on---- * + ! + !i. Copy existing sig to extended sig2, calculate phase speed. + DO K = 1, NK !existing spectrum + call sig2wn(sig(k),depth,wn(k)) + CP(K) = ( SIG(K) / WN(K) ) + sig2(k) = sig(k) + ENDDO!K + !ii. Calculate extended sig2 and phase speed. + DO K = ( NK + 1 ), ( NKT) !extension + sig2(k) = sig2(k-1) *XFR + call sig2wn(sig2(k),depth,wn(k)) + CP(K) = SIG2(K) / WN(K) + ENDDO!K + !iii. Calculate dk's for integrations. + DO K = 1, NKT-1 + DWN(K) = WN(K+1) - WN(K) + ENDDO + DWN(NKT) = WN(NKT)*XFR**2 - WN(NKT) + ! + ! 1b. Attach initial tail--------------------------------------------- * + ! + !i. Convert action spectrum to variance spectrum + ! SPC(k,theta) = A(k,theta) * sig(k) + ! This could be redone for computational efficiency + I=0 + DO K=1, NK + DO T=1, NTH + I = I + 1 + SPC2(K,T) = ASPC(I) * SIG(K) + ENDDO!T + ENDDO!K + !ii. Extend k^-3 tail to extended spectrum + DO K=NK+1, NKT + DO T=1, NTH + SPC2(K,T)=SPC2(NK,T)*WN(NK)**3.0/WN(K)**(3.0) + ENDDO!T + ENDDO!K + ! + ! 1c. Calculate transitions for new (constant saturation ) tail ------ * + ! + ! + !i. Find wavenumber for beginning spc level transition to tail + call sig2wn (FPI*TPI*tail_transition_ratio1,depth,ktaila ) + !ii. Find wavenumber for ending spc level transition to tail + call sig2wn (FPI*TPI*tail_transition_ratio2,depth,ktailb ) + !iii. Find wavenumber for ending spc direction transition to tail + KTAILC= KTAILB * 2.0 + !iv. Find corresponding indices of wavenumber transitions + KA1 = 2 ! Do not modify 1st wavenumber bin + DO WHILE ( ( KTAILA .GE. WN(KA1) ) .AND. (KA1 .LT. NKT-6) ) + KA1 = KA1 + 1 + ENDDO + KA2 = KA1+2 + DO WHILE ( ( KTAILB .GE. WN(KA2) ) .AND. (KA2 .LT. NKT-4) ) + KA2 = KA2 + 1 + ENDDO + KA3 = KA2+2 + DO WHILE ( ( KTAILC .GE. WN(KA3)) .AND. (KA3 .LT. NKT-2) ) + KA3 = KA3 + 1 + ENDDO + !v. Call subroutine to perform actually tail truncation + ! only if there is some energy in spectrum + CALL APPENDTAIL(SPC2, WN, NKT, KA1, KA2, KA3,& + wnd_in_dir, SAT) + ! Spectrum is now set for stress integration + ! + ! 2. Prepare for iterative calculation of wave-form stress----------- * + ! + DTX = 0.00005 + DTY = 0.00005 + iter_thresh = 0.001 + ! + ! 2a. Calculate initial guess for viscous stress from smooth-law------ * + ! (Would be preferable to use prev. step) + ! + Z0SM = 0.001 !Guess + IT_FLAG1 = .true. + ITERATION = 0 + DO WHILE( IT_FLAG1 ) + ITERATION = ITERATION + 1 + Z1 = Z0SM + USTSM = KAPPA * wnd_in_mag / ( LOG( ZWND / Z1 ) ) + Z0SM = 0.132 * NU / USTSM + IF ( (ABS( Z0SM - Z1 ) .LT. 10.0**(-6)) .OR.& + ( ITERATION .GT. 5 )) THEN + IT_FLAG1 = .false. + ENDIF + ENDDO - ITERATION = 1 - ! Guessed values of viscous stress - TAUNUX = USTSM**2 * DAIR * wndx / wnd_in_mag - TAUNUY = USTSM**2 * DAIR * wndy / wnd_in_mag -! -! 3. Enter iterative calculation of wave form/skin stress---------- * -! - IT_FLAG1 = .true. - DO WHILE (IT_FLAG1) - DO ITER=1, 3 !3 loops for TAUNU iteration - Z2 = NKT - ! First : TAUNUX + DX - IF (ITER .EQ. 1) THEN - TAUNUX = TAUNUX + DTX + ITERATION = 1 + ! Guessed values of viscous stress + TAUNUX = USTSM**2 * DAIR * wndx / wnd_in_mag + TAUNUY = USTSM**2 * DAIR * wndy / wnd_in_mag + ! + ! 3. Enter iterative calculation of wave form/skin stress---------- * + ! + IT_FLAG1 = .true. + DO WHILE (IT_FLAG1) + DO ITER=1, 3 !3 loops for TAUNU iteration + Z2 = NKT + ! First : TAUNUX + DX + IF (ITER .EQ. 1) THEN + TAUNUX = TAUNUX + DTX ! Second : TAUNUY + DY - ELSEIF (ITER .EQ. 2) THEN - TAUNUX = TAUNUX - DTX - TAUNUY = TAUNUY + DTY + ELSEIF (ITER .EQ. 2) THEN + TAUNUX = TAUNUX - DTX + TAUNUY = TAUNUY + DTY ! Third : unmodified - ELSEIF (ITER .EQ. 3) THEN - TAUNUY = TAUNUY - DTY - ENDIF - ! Near surface turbulent stress = taunu - TLTN(1) = TAUNUY - TLTE(1) = TAUNUX + ELSEIF (ITER .EQ. 3) THEN + TAUNUY = TAUNUY - DTY + ENDIF + ! Near surface turbulent stress = taunu + TLTN(1) = TAUNUY + TLTE(1) = TAUNUX CALL APPENDTAIL(SPC2, WN, NKT, KA1, KA2, KA3,& - atan2(TAUNUY,TAUNUX), SAT) -!|---------------------------------------------------------------------| -!|-----Calculate first guess at growth rate and local turbulent stress-| -!|-----for integration as a function of wavedirection------------------| -!|---------------------------------------------------------------------| - DO ZI = 2, NKT + atan2(TAUNUY,TAUNUX), SAT) + !|---------------------------------------------------------------------| + !|-----Calculate first guess at growth rate and local turbulent stress-| + !|-----for integration as a function of wavedirection------------------| + !|---------------------------------------------------------------------| + DO ZI = 2, NKT + USTL=0.0 + TLTND(zi)=0.0 + TLTED(zi)=0.0 + Z2 = Z2 - 1 + ! Use value of prev. wavenumber/height + TAUD(ZI) = ATAN2( TLTN(ZI-1), TLTE(ZI-1)) + USTL = SQRT( SQRT( TLTN(ZI-1)**2 + TLTE(ZI-1)**2 )/ DAIR ) + DO T = 1, NTH + ANGDIF=TAUD(ZI)-TH(T) !stress/wave angle + IF ( COS( ANGDIF ) .GE. 0.0 ) THEN !Waves aligned + WAGE = CP(Z2) / (USTL) + ! First, waves much slower than wind. + IF ( WAGE .LT. 10. ) THEN + CBETA = 25.0 + ! Transition from waves slower than wind to faster + ELSEIF ( ( WAGE .GE. 10.0 ) .AND. & + ( WAGE .LE. 25.0 ) ) THEN + CBETA = 10.0 + 15.0 * COS( PI * ( WAGE - 10.0 ) & + / 15.0 ) + ! Waves faster than wind + ELSEIF ( WAGE .GT. 25.0 ) THEN + CBETA = -5.0 + ENDIF + ! Waves opposing wind + ELSE + CBETA = -25.0 + ENDIF + !Integrate turbulent stress + TLTND(ZI) =TLTND(ZI)+( SIN( TH(T) ) * COS( ANGDIF )**2)& + * CBETA * SPC2(Z2,T) * & + SQRT( TLTE(ZI-1)**2 + TLTN(ZI-1)**2.0 ) & + * ( WN(Z2)**2.0 )*DTH + TLTED(ZI) = TLTED(ZI)+(COS( TH(T) ) * COS( ANGDIF )**2)& + * CBETA * SPC2(Z2,T) * & + SQRT( TLTE(ZI-1)**2 + TLTN(ZI-1)**2.0 ) & + * ( WN(Z2)**2.0 )*DTH + ENDDO + !|---------------------------------------------------------------------| + !|-----Complete the integrations---------------------------------------| + !|---------------------------------------------------------------------| + IF (ZI .EQ. 2) THEN + !First turbulent stress bin above taunu + TLTNA(ZI) = TLTND(ZI) * DWN(Z2) * 0.5 + TLTEA(ZI) = TLTED(ZI) * DWN(Z2) * 0.5 + ELSE + TLTNA(ZI)=(TLTND(ZI)+TLTND(ZI-1))*0.5*DWN(Z2) + TLTEA(ZI)=(TLTED(ZI)+TLTED(ZI-1))*0.5*DWN(Z2) + ENDIF + TLTN(ZI)=TLTN(ZI-1)+TLTNA(ZI) + TLTE(ZI)=TLTE(ZI-1)+TLTEA(ZI) + ENDDO + TAUY=TLTN(NKT) + TAUX=TLTE(NKT) + ! This is the first guess at the stress. + !|---------------------------------------------------------------------| + !|----Iterate til convergence------------------------------------------| + !|---------------------------------------------------------------------| + USTRB=SQRT(SQRT(TAUY**2.0+TAUX**2.0)/DAIR) + TAUDIRB=atan2(TAUY,TAUX) + IT_FLAG2 = .TRUE. + CTR=1 + DO WHILE ( (IT_FLAG2) .AND. ( CTR .LT. 10 ) ) + Z2=NKT+1 + DO ZI=1, NKT + Z2=Z2-1 USTL=0.0 - TLTND(zi)=0.0 TLTED(zi)=0.0 - Z2 = Z2 - 1 - ! Use value of prev. wavenumber/height - TAUD(ZI) = ATAN2( TLTN(ZI-1), TLTE(ZI-1)) - USTL = SQRT( SQRT( TLTN(ZI-1)**2 + TLTE(ZI-1)**2 )/ DAIR ) - DO T = 1, NTH - ANGDIF=TAUD(ZI)-TH(T) !stress/wave angle - IF ( COS( ANGDIF ) .GE. 0.0 ) THEN !Waves aligned - WAGE = CP(Z2) / (USTL) - ! First, waves much slower than wind. - IF ( WAGE .LT. 10. ) THEN + TLTND(zi)=0.0 + FTILDE(z2)=0.0 + TAUD(ZI) = ATAN2(TLTN(ZI),TLTE(ZI)) + USTL = SQRT(SQRT(TLTN(ZI)**2+TLTE(ZI)**2)/DAIR) + DO T=1, NTH + BETAG=0.0 + ANGDIF = TAUD(ZI)-TH(T) + IF ( COS( ANGDIF ) .GE. 0.0 ) THEN + WAGE = CP(Z2) / (USTL) + IF ( WAGE .LT. 10 ) THEN CBETA = 25.0 - ! Transition from waves slower than wind to faster ELSEIF ( ( WAGE .GE. 10.0 ) .AND. & - ( WAGE .LE. 25.0 ) ) THEN + ( WAGE .LE. 25.0 ) ) THEN CBETA = 10.0 + 15.0 * COS( PI * ( WAGE - 10.0 ) & - / 15.0 ) - ! Waves faster than wind + / 15.0 ) ELSEIF ( WAGE .GT. 25.0 ) THEN CBETA = -5.0 ENDIF - ! Waves opposing wind ELSE CBETA = -25.0 ENDIF - !Integrate turbulent stress - TLTND(ZI) =TLTND(ZI)+( SIN( TH(T) ) * COS( ANGDIF )**2)& - * CBETA * SPC2(Z2,T) * & - SQRT( TLTE(ZI-1)**2 + TLTN(ZI-1)**2.0 ) & - * ( WN(Z2)**2.0 )*DTH - TLTED(ZI) = TLTED(ZI)+(COS( TH(T) ) * COS( ANGDIF )**2)& - * CBETA * SPC2(Z2,T) * & - SQRT( TLTE(ZI-1)**2 + TLTN(ZI-1)**2.0 ) & - * ( WN(Z2)**2.0 )*DTH - ENDDO -!|---------------------------------------------------------------------| -!|-----Complete the integrations---------------------------------------| -!|---------------------------------------------------------------------| - IF (ZI .EQ. 2) THEN - !First turbulent stress bin above taunu - TLTNA(ZI) = TLTND(ZI) * DWN(Z2) * 0.5 - TLTEA(ZI) = TLTED(ZI) * DWN(Z2) * 0.5 + BP = SQRT( (COS( TH(T) ) * COS( ANGDIF )**2.0)**2.0 & + + (SIN( TH(T) ) * COS( ANGDIF )**2.0)**2.0 ) + BETAG=BP*CBETA*SQRT(TLTE(ZI)**2.0+TLTN(ZI)**2.0) & + /(DWAT)*SIG2(Z2)/CP(Z2)**2 + FTILDE(Z2) = FTILDE(Z2) + BETAG * DWAT * GRAV & + * SPC2(Z2,T) * DTH + TLTND(zi) =tltnd(zi)+ (SIN( TH(T) ) * COS( ANGDIF )**2.0)& + * CBETA * SPC2(Z2,T) * SQRT( & + TLTE(ZI)**2.0 + TLTN(ZI)**2.0 ) * & + ( WN(Z2)**2.0 )*dth + TLTED(zi) = tlted(zi)+(COS( TH(T) ) * COS( ANGDIF )**2.0)& + * CBETA * SPC2(Z2,T) * SQRT( & + TLTE(ZI)**2.0 + TLTN(ZI)**2.0 ) * & + ( WN(Z2)**2.0 )*dth + ENDDO + IF (ZI .EQ. 1) THEN + TLTNA(ZI)=TLTND(ZI)*DWN(Z2)*0.5 + TLTEA(ZI)=TLTED(ZI)*DWN(Z2)*0.5 ELSE TLTNA(ZI)=(TLTND(ZI)+TLTND(ZI-1))*0.5*DWN(Z2) TLTEA(ZI)=(TLTED(ZI)+TLTED(ZI-1))*0.5*DWN(Z2) ENDIF - TLTN(ZI)=TLTN(ZI-1)+TLTNA(ZI) - TLTE(ZI)=TLTE(ZI-1)+TLTEA(ZI) - ENDDO - TAUY=TLTN(NKT) - TAUX=TLTE(NKT) - ! This is the first guess at the stress. -!|---------------------------------------------------------------------| -!|----Iterate til convergence------------------------------------------| -!|---------------------------------------------------------------------| - USTRB=SQRT(SQRT(TAUY**2.0+TAUX**2.0)/DAIR) - TAUDIRB=atan2(TAUY,TAUX) - IT_FLAG2 = .TRUE. - CTR=1 - DO WHILE ( (IT_FLAG2) .AND. ( CTR .LT. 10 ) ) - Z2=NKT+1 - DO ZI=1, NKT - Z2=Z2-1 - USTL=0.0 - TLTED(zi)=0.0 - TLTND(zi)=0.0 - FTILDE(z2)=0.0 - TAUD(ZI) = ATAN2(TLTN(ZI),TLTE(ZI)) - USTL = SQRT(SQRT(TLTN(ZI)**2+TLTE(ZI)**2)/DAIR) - DO T=1, NTH - BETAG=0.0 - ANGDIF = TAUD(ZI)-TH(T) - IF ( COS( ANGDIF ) .GE. 0.0 ) THEN - WAGE = CP(Z2) / (USTL) - IF ( WAGE .LT. 10 ) THEN - CBETA = 25.0 - ELSEIF ( ( WAGE .GE. 10.0 ) .AND. & - ( WAGE .LE. 25.0 ) ) THEN - CBETA = 10.0 + 15.0 * COS( PI * ( WAGE - 10.0 ) & - / 15.0 ) - ELSEIF ( WAGE .GT. 25.0 ) THEN - CBETA = -5.0 - ENDIF - ELSE - CBETA = -25.0 - ENDIF - BP = SQRT( (COS( TH(T) ) * COS( ANGDIF )**2.0)**2.0 & - + (SIN( TH(T) ) * COS( ANGDIF )**2.0)**2.0 ) - BETAG=BP*CBETA*SQRT(TLTE(ZI)**2.0+TLTN(ZI)**2.0) & - /(DWAT)*SIG2(Z2)/CP(Z2)**2 - FTILDE(Z2) = FTILDE(Z2) + BETAG * DWAT * GRAV & - * SPC2(Z2,T) * DTH - TLTND(zi) =tltnd(zi)+ (SIN( TH(T) ) * COS( ANGDIF )**2.0)& - * CBETA * SPC2(Z2,T) * SQRT( & - TLTE(ZI)**2.0 + TLTN(ZI)**2.0 ) * & - ( WN(Z2)**2.0 )*dth - TLTED(zi) = tlted(zi)+(COS( TH(T) ) * COS( ANGDIF )**2.0)& - * CBETA * SPC2(Z2,T) * SQRT( & - TLTE(ZI)**2.0 + TLTN(ZI)**2.0 ) * & - ( WN(Z2)**2.0 )*dth - ENDDO - IF (ZI .EQ. 1) THEN - TLTNA(ZI)=TLTND(ZI)*DWN(Z2)*0.5 - TLTEA(ZI)=TLTED(ZI)*DWN(Z2)*0.5 - ELSE - TLTNA(ZI)=(TLTND(ZI)+TLTND(ZI-1))*0.5*DWN(Z2) - TLTEA(ZI)=(TLTED(ZI)+TLTED(ZI-1))*0.5*DWN(Z2) - ENDIF - IF (ZI.GT.1) then - TLTN(ZI)=TLTN(ZI-1)+TLTNA(ZI) - TLTE(ZI)=TLTE(ZI-1)+TLTEA(ZI) - else - TLTN(ZI)=TAUNUY+TLTNA(ZI) - TLTE(ZI)=TAUNUX+TLTEA(ZI) - endif - ENDDO - TAUY=TLTN(NKT) !by NKT full stress is entirely - TAUX=TLTE(NKT) !from turbulent stress - TAUT=SQRT(TAUY**2.0+TAUX**2.0) - USTAR=SQRT(SQRT(TAUY**2.0+TAUX**2.0)/DAIR) - TAUDIR=atan2(TAUY, TAUX) -! Note: add another criterion (stress direction) for iteration. - CRIT1=(ABS(USTAR-USTRB)*100.0)/((USTAR+USTRB)*0.5) .GT. 0.1 - CRIT2=(ABS(TAUDIR-TAUDIRB)*100.0/(TAUDIR+TAUDIRB)*0.5) .GT. 0.1 - IF (CRIT1 .OR. CRIT2) THEN -! IF ((ABS(USTAR-USTRB)*100.0)/((USTAR+USTRB)*0.5) .GT. 0.1) THEN - USTRB=USTAR - TAUDIRB=TAUDIR - CTR=CTR+1 - ELSE - IT_FLAG2 = .FALSE. - ENDIF + IF (ZI.GT.1) then + TLTN(ZI)=TLTN(ZI-1)+TLTNA(ZI) + TLTE(ZI)=TLTE(ZI-1)+TLTEA(ZI) + else + TLTN(ZI)=TAUNUY+TLTNA(ZI) + TLTE(ZI)=TAUNUX+TLTEA(ZI) + endif ENDDO -! Note: search for the top of WBL from top to bottom (avoid problems -! caused by for very long swell) - KB=NKT - DO WHILE(((TLTN(KB)**2+TLTE(KB)**2)/(TAUX**2+TAUY**2)).GT. & + TAUY=TLTN(NKT) !by NKT full stress is entirely + TAUX=TLTE(NKT) !from turbulent stress + TAUT=SQRT(TAUY**2.0+TAUX**2.0) + USTAR=SQRT(SQRT(TAUY**2.0+TAUX**2.0)/DAIR) + TAUDIR=atan2(TAUY, TAUX) + ! Note: add another criterion (stress direction) for iteration. + CRIT1=(ABS(USTAR-USTRB)*100.0)/((USTAR+USTRB)*0.5) .GT. 0.1 + CRIT2=(ABS(TAUDIR-TAUDIRB)*100.0/(TAUDIR+TAUDIRB)*0.5) .GT. 0.1 + IF (CRIT1 .OR. CRIT2) THEN + ! IF ((ABS(USTAR-USTRB)*100.0)/((USTAR+USTRB)*0.5) .GT. 0.1) THEN + USTRB=USTAR + TAUDIRB=TAUDIR + CTR=CTR+1 + ELSE + IT_FLAG2 = .FALSE. + ENDIF + ENDDO + ! Note: search for the top of WBL from top to bottom (avoid problems + ! caused by for very long swell) + KB=NKT + DO WHILE(((TLTN(KB)**2+TLTE(KB)**2)/(TAUX**2+TAUY**2)).GT. & .99) - KB=KB-1 - ENDDO - KB=KB+1 -!|---------------------------------------------------------------------| -!|----Now begin work on wind profile-----------------------------------| -!|---------------------------------------------------------------------| - DO I=1,NKT - ZOFK(I)=DELTA/WN(I) - ENDDO - ZNU=0.1 * 1.45E-5 / SQRT(SQRT(TAUNUX**2.0+TAUNUY**2.0)/DAIR) - UPROF(1:NKT+1)=0.0 - VPROF(1:NKT+1)=0.0 - UPROFV=0.0 - VPROFV=0.0 - ZI=1 - Z2=NKT - UP1(ZI) = ( ( ( WN(Z2)**2 / DELTA ) * FTILDE(z2) ) + & - ( DAIR / ( ZOFK(Z2) * KAPPA ) ) * ( SQRT( & - TLTN(ZI)**2 + TLTE(ZI)**2 ) / DAIR )**(3/2) ) & - * ( TLTE(ZI) ) / ( TLTE(ZI) * TAUX & - + TLTN(ZI) * TAUY ) - VP1(ZI) = ( ( ( WN(Z2)**2 / DELTA ) * FTILDE(z2) ) + & - ( DAIR / ( ZOFK(Z2) * KAPPA ) ) * ( SQRT ( & - TLTN(ZI)**2 + TLTE(ZI)**2 ) / DAIR )**(3/2) ) & - * ( TLTN(ZI) ) / ( TLTE(ZI) * TAUX & - + TLTN(ZI) * TAUY ) - UP(ZI) = UP1(ZI) - VP(ZI) = VP1(ZI) - UPROF(ZI) = DAIR / KAPPA * ( SQRT( TAUNUX**2.0 + TAUNUY**2.0 ) & - / DAIR )**(1.5) * ( TAUNUX / ( TAUX * & - TAUNUX + TAUY * TAUNUY ) ) * LOG( & - ZOFK(Z2) / ZNU ) - VPROF(ZI) = DAIR / KAPPA * ( SQRT( TAUNUX**2.0 + TAUNUY**2.0 ) & - / DAIR )**(1.5) * ( TAUNUY / ( TAUX * & - TAUNUX + TAUY * TAUNUY ) ) * LOG( & - ZOFK(Z2) / ZNU ) -!Noted: wind profile computed till the inner layer height of the longest -!wave, not just to the top of wave boundary layer (previous) - DO ZI=2, NKT - Z2 = Z2 - 1 - UP1(ZI) = ( ( ( WN(Z2)**2.0 / DELTA ) * FTILDE(Z2) ) + & - ( DAIR / ( ZOFK(Z2) * KAPPA ) ) * ( SQRT( & - TLTN(ZI)**2.0 + TLTE(ZI)**2.0 ) / DAIR )**(1.5) ) & - * ( TLTE(ZI) ) / ( TLTE(ZI) * TAUX + & - TLTN(ZI) * TAUY ) - VP1(ZI) = ( ( ( WN(Z2)**2.0 / DELTA ) * FTILDE(Z2) ) + & - ( DAIR / ( ZOFK(Z2) * KAPPA ) ) * ( SQRT( & - TLTN(ZI)**2.0 + TLTE(ZI)**2.0 ) / DAIR )**(1.5) ) & - * ( TLTN(ZI) ) / ( TLTE(ZI) * TAUX + & - TLTN(ZI) * TAUY ) - UP(ZI) = UP1(ZI) * 0.5 + UP1(ZI-1) * 0.5 - VP(ZI) = VP1(ZI) * 0.5 + VP1(ZI-1) * 0.5 - UPROF(ZI) = UPROF(ZI-1) + UP(ZI) * ( ZOFK(Z2) - ZOFK(Z2+1) ) - VPROF(ZI) = VPROF(ZI-1) + VP(ZI) * ( ZOFK(Z2) - ZOFK(Z2+1) ) - ENDDO -!|---------------------------------------------------------------------| -!|----Iteration completion/checks--------------------------------------| -!|---------------------------------------------------------------------| - !ZI = ( KB + 1 ) - ! Now solving for 'ZWND' height wind - UPROF(NKT+1) = UPROF(NKT) + ( SQRT( SQRT( TAUY**2.0 + & - TAUX**2.0 ) / DAIR ) ) / KAPPA * TAUX & - / SQRT( TAUY**2.0 +TAUX**2.0 ) * LOG( ZWND & - / ZOFK(Z2) ) - VPROF(NKT+1) = VPROF(NKT) + ( SQRT( SQRT( TAUY**2.0 + & - TAUX**2.0 ) / DAIR ) ) / KAPPA * TAUY & - / SQRT( TAUY**2.0 +TAUX**2.0 ) * LOG( ZWND & - / ZOFK(Z2) ) - IF (ITER .EQ. 3) THEN - WND_1X = UPROF(NKT+1) - WND_1Y = VPROF(NKT+1) - ELSEIF (ITER .EQ. 2) THEN - WND_2X = UPROF(NKT+1) - WND_2Y = VPROF(NKT+1) - ELSEIF (ITER .EQ. 1) THEN - WND_3X = UPROF(NKT+1) - WND_3Y = VPROF(NKT+1) - ENDIF - - - !-------------------------------------+ - ! Guide for adding stability effects + - !-------------------------------------+ - !Get Wind at top of wave boundary layer - ! WND_TOP=SQRT(UPROF(KB)**2+VPROF(KB)**2) - ! Get Wind Angle at top of wave boundary layer - ! ANG_TOP=ATAN2(VPROF(KB),UPROF(KB)) - ! Stress and direction - ! USTD = ATAN2(TAUY,TAUX) - ! UST = SQRT( SQRT( TAUX**2 + TAUY**2 ) / DAIR) - ! Calclate along (PA) and across (PE) wind components - ! WND_PA=WND_TOP*COS(ANG_TOP-USTD) - ! WND_PE=WND_TOP*SIN(ANG_TOP-USTD) - ! Calculate cartesian aligned wind - ! WND_PAx=WND_PA*cos(ustd) - ! WND_PAy=WND_PA*sin(USTd) - !Calculate cartesion across wind - ! WND_PEx=WND_PE*cos(ustd+pi/2.) - ! WND_PEy=WND_PE*sin(ustd+pi/2.) - !----------------------------------------------------+ - ! If a non-neutral profile is used the effective z0 + - ! should be computed. This z0 can then be used + - ! with stability information to derive a Cd, which + - ! can be used to project the along-stress wind to + - ! the given height. + - ! i.e.: Assume neutral inside WBL calculate Z0 + - ! Z0=ZOFK(Z2)*EXP(-WND_PA*kappa/UST) + - ! WND_PA=UST/SQRT(CDM) + - !----------------------------------------------------+ - ! WND_PAx=WND_PA*cos(ustd) - ! WND_PAy=WND_PA*sin(USTd) - ! IF (ITER .EQ. 3) THEN - ! WND_1X = WND_PAx+WND_PEx - ! WND_1Y = WND_PAy+WND_PEy - ! ELSEIF (ITER .EQ. 2) THEN - ! WND_2X = WND_PAx+WND_PEx - ! WND_2Y = WND_PAy+WND_PEy - ! ELSEIF (ITER .EQ. 1) THEN - ! WND_3X = WND_PAx+WND_PEx - ! WND_3Y = WND_PAy+WND_PEy - ! ENDIF + KB=KB-1 ENDDO - ITERATION = ITERATION + 1 - DIFU10XX = WND_3X - WND_1X - DIFU10YX = WND_3Y - WND_1Y - DIFU10XY = WND_2X - WND_1X - DIFU10YY = WND_2Y - WND_1Y - FD_A = DIFU10XX / DTX - FD_B = DIFU10XY / DTY - FD_C = DIFU10YX / DTX - FD_D = DIFU10YY / DTY - DWNDX = - WNDX + WND_1X - DWNDY = - WNDY + WND_1Y - UITV = ABS( DWNDX ) - VITV = ABS( DWNDY ) - CH = SQRT( UITV**2.0 + VITV**2.0 ) - IF (CH .GT. 15.) THEN - APAR = 0.5 / ( FD_A * FD_D - FD_B * FD_C ) - ELSE - APAR = 1.0 / ( FD_A * FD_D - FD_B * FD_C ) - ENDIF - CK=4. - IF (((VITV/MAX(ABS(WNDY),CK) .GT. iter_thresh) .OR. & - (UITV/MAX(ABS(WNDX),CK) .GT. iter_thresh)) .AND. & - (ITERATION .LT. 2)) THEN - TAUNUX = TAUNUX - APAR * ( FD_D * DWNDX - FD_B * DWNDY ) - TAUNUY = TAUNUY - APAR * ( -FD_C * DWNDX +FD_A * DWNDY ) - ELSEIF (((VITV/MAX(ABS(WNDY),CK) .GT. iter_thresh) .OR. & - (UITV/MAX(ABS(WNDX),CK) .GT. iter_thresh)) .AND. & - (ITERATION .LT. 24)) THEN - iter_thresh = 0.001 - TAUNUX = TAUNUX - APAR * ( FD_D * DWNDX - FD_B * DWNDY ) - TAUNUY = TAUNUY - APAR * ( -FD_C * DWNDX +FD_A * DWNDY ) - ELSEIF (((VITV/MAX(ABS(WNDY),CK) .GT. iter_thresh) .OR. & - (UITV/MAX(ABS(WNDX),CK) .GT. iter_thresh)) .AND. & - (ITERATION .LT. 26)) THEN - iter_thresh = 0.01 - TAUNUX = TAUNUX - APAR * ( FD_D * DWNDX - FD_B * DWNDY ) - TAUNUY = TAUNUY - APAR * ( -FD_C * DWNDX +FD_A * DWNDY ) - ELSEIF (((VITV/MAX(ABS(WNDY),CK) .GT. iter_thresh) .OR. & - (UITV/MAX(ABS(WNDX),CK) .GT. iter_thresh)) .AND. & - (ITERATION .LT. 30)) THEN - iter_thresh = 0.05 - TAUNUX = TAUNUX - APAR * ( FD_D * DWNDX - FD_B * DWNDY ) - TAUNUY = TAUNUY - APAR * ( -FD_C * DWNDX +FD_A * DWNDY ) - ELSEIF (ITERATION .GE. 30) THEN - write(*,*)'Attn: W3FLD1 not converged.' - write(*,*)' Wind (X/Y): ',WNDX,WNDY - IT_FLAG1 = .FALSE. - UST=-999 - TAUNUX=0. - TAUNUY=0. - ELSEIF (((VITV/MAX(ABS(WNDY),CK) .LT. iter_thresh) .AND.& - (UITV/MAX(ABS(WNDX),CK) .LT. iter_thresh)) .AND. & - (ITERATION .GE. 2)) THEN - IT_FLAG1 = .FALSE. + KB=KB+1 + !|---------------------------------------------------------------------| + !|----Now begin work on wind profile-----------------------------------| + !|---------------------------------------------------------------------| + DO I=1,NKT + ZOFK(I)=DELTA/WN(I) + ENDDO + ZNU=0.1 * 1.45E-5 / SQRT(SQRT(TAUNUX**2.0+TAUNUY**2.0)/DAIR) + UPROF(1:NKT+1)=0.0 + VPROF(1:NKT+1)=0.0 + UPROFV=0.0 + VPROFV=0.0 + ZI=1 + Z2=NKT + UP1(ZI) = ( ( ( WN(Z2)**2 / DELTA ) * FTILDE(z2) ) + & + ( DAIR / ( ZOFK(Z2) * KAPPA ) ) * ( SQRT( & + TLTN(ZI)**2 + TLTE(ZI)**2 ) / DAIR )**(3/2) ) & + * ( TLTE(ZI) ) / ( TLTE(ZI) * TAUX & + + TLTN(ZI) * TAUY ) + VP1(ZI) = ( ( ( WN(Z2)**2 / DELTA ) * FTILDE(z2) ) + & + ( DAIR / ( ZOFK(Z2) * KAPPA ) ) * ( SQRT ( & + TLTN(ZI)**2 + TLTE(ZI)**2 ) / DAIR )**(3/2) ) & + * ( TLTN(ZI) ) / ( TLTE(ZI) * TAUX & + + TLTN(ZI) * TAUY ) + UP(ZI) = UP1(ZI) + VP(ZI) = VP1(ZI) + UPROF(ZI) = DAIR / KAPPA * ( SQRT( TAUNUX**2.0 + TAUNUY**2.0 ) & + / DAIR )**(1.5) * ( TAUNUX / ( TAUX * & + TAUNUX + TAUY * TAUNUY ) ) * LOG( & + ZOFK(Z2) / ZNU ) + VPROF(ZI) = DAIR / KAPPA * ( SQRT( TAUNUX**2.0 + TAUNUY**2.0 ) & + / DAIR )**(1.5) * ( TAUNUY / ( TAUX * & + TAUNUX + TAUY * TAUNUY ) ) * LOG( & + ZOFK(Z2) / ZNU ) + !Noted: wind profile computed till the inner layer height of the longest + !wave, not just to the top of wave boundary layer (previous) + DO ZI=2, NKT + Z2 = Z2 - 1 + UP1(ZI) = ( ( ( WN(Z2)**2.0 / DELTA ) * FTILDE(Z2) ) + & + ( DAIR / ( ZOFK(Z2) * KAPPA ) ) * ( SQRT( & + TLTN(ZI)**2.0 + TLTE(ZI)**2.0 ) / DAIR )**(1.5) ) & + * ( TLTE(ZI) ) / ( TLTE(ZI) * TAUX + & + TLTN(ZI) * TAUY ) + VP1(ZI) = ( ( ( WN(Z2)**2.0 / DELTA ) * FTILDE(Z2) ) + & + ( DAIR / ( ZOFK(Z2) * KAPPA ) ) * ( SQRT( & + TLTN(ZI)**2.0 + TLTE(ZI)**2.0 ) / DAIR )**(1.5) ) & + * ( TLTN(ZI) ) / ( TLTE(ZI) * TAUX + & + TLTN(ZI) * TAUY ) + UP(ZI) = UP1(ZI) * 0.5 + UP1(ZI-1) * 0.5 + VP(ZI) = VP1(ZI) * 0.5 + VP1(ZI-1) * 0.5 + UPROF(ZI) = UPROF(ZI-1) + UP(ZI) * ( ZOFK(Z2) - ZOFK(Z2+1) ) + VPROF(ZI) = VPROF(ZI-1) + VP(ZI) * ( ZOFK(Z2) - ZOFK(Z2+1) ) + ENDDO + !|---------------------------------------------------------------------| + !|----Iteration completion/checks--------------------------------------| + !|---------------------------------------------------------------------| + !ZI = ( KB + 1 ) + ! Now solving for 'ZWND' height wind + UPROF(NKT+1) = UPROF(NKT) + ( SQRT( SQRT( TAUY**2.0 + & + TAUX**2.0 ) / DAIR ) ) / KAPPA * TAUX & + / SQRT( TAUY**2.0 +TAUX**2.0 ) * LOG( ZWND & + / ZOFK(Z2) ) + VPROF(NKT+1) = VPROF(NKT) + ( SQRT( SQRT( TAUY**2.0 + & + TAUX**2.0 ) / DAIR ) ) / KAPPA * TAUY & + / SQRT( TAUY**2.0 +TAUX**2.0 ) * LOG( ZWND & + / ZOFK(Z2) ) + IF (ITER .EQ. 3) THEN + WND_1X = UPROF(NKT+1) + WND_1Y = VPROF(NKT+1) + ELSEIF (ITER .EQ. 2) THEN + WND_2X = UPROF(NKT+1) + WND_2Y = VPROF(NKT+1) + ELSEIF (ITER .EQ. 1) THEN + WND_3X = UPROF(NKT+1) + WND_3Y = VPROF(NKT+1) ENDIF - ! if taunu iteration is unstable try to reset with new guess... - if (.not.(cos(wnd_in_dir-atan2(taunuy,taunux)).ge.0.0)) then - TAUNUX = USTSM**2 * DAIR * wndx / wnd_in_mag*.95 - TAUNUY = USTSM**2 * DAIR * wndy / wnd_in_mag*.95 - endif - ENDDO -!|---------------------------------------------------------------------| -!|----Finish-----------------------------------------------------------| -!|---------------------------------------------------------------------| - USTD = ATAN2(TAUY,TAUX) - UST = SQRT( SQRT( TAUX**2 + TAUY**2 ) / DAIR) - ! Get Z0 from aligned wind - WND_PA=wnd_in_mag*COS(wnd_in_dir-USTD) - Z0 = ZWND/exp(wnd_pa*kappa/ust) - CD = UST**2 / wnd_in_mag**2 - IF (PRESENT(CHARN)) THEN - CHARN = 0.01/SQRT(SQRT( TAUNUX**2 + TAUNUY**2 )/(UST**2)) + + + !-------------------------------------+ + ! Guide for adding stability effects + + !-------------------------------------+ + !Get Wind at top of wave boundary layer + ! WND_TOP=SQRT(UPROF(KB)**2+VPROF(KB)**2) + ! Get Wind Angle at top of wave boundary layer + ! ANG_TOP=ATAN2(VPROF(KB),UPROF(KB)) + ! Stress and direction + ! USTD = ATAN2(TAUY,TAUX) + ! UST = SQRT( SQRT( TAUX**2 + TAUY**2 ) / DAIR) + ! Calclate along (PA) and across (PE) wind components + ! WND_PA=WND_TOP*COS(ANG_TOP-USTD) + ! WND_PE=WND_TOP*SIN(ANG_TOP-USTD) + ! Calculate cartesian aligned wind + ! WND_PAx=WND_PA*cos(ustd) + ! WND_PAy=WND_PA*sin(USTd) + !Calculate cartesion across wind + ! WND_PEx=WND_PE*cos(ustd+pi/2.) + ! WND_PEy=WND_PE*sin(ustd+pi/2.) + !----------------------------------------------------+ + ! If a non-neutral profile is used the effective z0 + + ! should be computed. This z0 can then be used + + ! with stability information to derive a Cd, which + + ! can be used to project the along-stress wind to + + ! the given height. + + ! i.e.: Assume neutral inside WBL calculate Z0 + + ! Z0=ZOFK(Z2)*EXP(-WND_PA*kappa/UST) + + ! WND_PA=UST/SQRT(CDM) + + !----------------------------------------------------+ + ! WND_PAx=WND_PA*cos(ustd) + ! WND_PAy=WND_PA*sin(USTd) + ! IF (ITER .EQ. 3) THEN + ! WND_1X = WND_PAx+WND_PEx + ! WND_1Y = WND_PAy+WND_PEy + ! ELSEIF (ITER .EQ. 2) THEN + ! WND_2X = WND_PAx+WND_PEx + ! WND_2Y = WND_PAy+WND_PEy + ! ELSEIF (ITER .EQ. 1) THEN + ! WND_3X = WND_PAx+WND_PEx + ! WND_3Y = WND_PAy+WND_PEy + ! ENDIF + ENDDO + ITERATION = ITERATION + 1 + DIFU10XX = WND_3X - WND_1X + DIFU10YX = WND_3Y - WND_1Y + DIFU10XY = WND_2X - WND_1X + DIFU10YY = WND_2Y - WND_1Y + FD_A = DIFU10XX / DTX + FD_B = DIFU10XY / DTY + FD_C = DIFU10YX / DTX + FD_D = DIFU10YY / DTY + DWNDX = - WNDX + WND_1X + DWNDY = - WNDY + WND_1Y + UITV = ABS( DWNDX ) + VITV = ABS( DWNDY ) + CH = SQRT( UITV**2.0 + VITV**2.0 ) + IF (CH .GT. 15.) THEN + APAR = 0.5 / ( FD_A * FD_D - FD_B * FD_C ) + ELSE + APAR = 1.0 / ( FD_A * FD_D - FD_B * FD_C ) ENDIF - FSFL1=.not.((CD .LT. 0.01).AND.(CD .GT. 0.0001)) - FSFL2=.not.(cos(wnd_in_dir-ustd).GT.0.9) - IF (FSFL1 .or. FSFL2) THEN - !Fail safe to bulk - write(*,*)'Attn: W3FLD1 failed, will output bulk...' - CALL wnd2z0m(wnd_in_mag,z0) - UST = wnd_in_mag*kappa/log(zwnd/z0) - USTD = wnd_in_dir - CD = UST**2 / wnd_in_mag**2 + CK=4. + IF (((VITV/MAX(ABS(WNDY),CK) .GT. iter_thresh) .OR. & + (UITV/MAX(ABS(WNDX),CK) .GT. iter_thresh)) .AND. & + (ITERATION .LT. 2)) THEN + TAUNUX = TAUNUX - APAR * ( FD_D * DWNDX - FD_B * DWNDY ) + TAUNUY = TAUNUY - APAR * ( -FD_C * DWNDX +FD_A * DWNDY ) + ELSEIF (((VITV/MAX(ABS(WNDY),CK) .GT. iter_thresh) .OR. & + (UITV/MAX(ABS(WNDX),CK) .GT. iter_thresh)) .AND. & + (ITERATION .LT. 24)) THEN + iter_thresh = 0.001 + TAUNUX = TAUNUX - APAR * ( FD_D * DWNDX - FD_B * DWNDY ) + TAUNUY = TAUNUY - APAR * ( -FD_C * DWNDX +FD_A * DWNDY ) + ELSEIF (((VITV/MAX(ABS(WNDY),CK) .GT. iter_thresh) .OR. & + (UITV/MAX(ABS(WNDX),CK) .GT. iter_thresh)) .AND. & + (ITERATION .LT. 26)) THEN + iter_thresh = 0.01 + TAUNUX = TAUNUX - APAR * ( FD_D * DWNDX - FD_B * DWNDY ) + TAUNUY = TAUNUY - APAR * ( -FD_C * DWNDX +FD_A * DWNDY ) + ELSEIF (((VITV/MAX(ABS(WNDY),CK) .GT. iter_thresh) .OR. & + (UITV/MAX(ABS(WNDX),CK) .GT. iter_thresh)) .AND. & + (ITERATION .LT. 30)) THEN + iter_thresh = 0.05 + TAUNUX = TAUNUX - APAR * ( FD_D * DWNDX - FD_B * DWNDY ) + TAUNUY = TAUNUY - APAR * ( -FD_C * DWNDX +FD_A * DWNDY ) + ELSEIF (ITERATION .GE. 30) THEN + write(*,*)'Attn: W3FLD1 not converged.' + write(*,*)' Wind (X/Y): ',WNDX,WNDY + IT_FLAG1 = .FALSE. + UST=-999 + TAUNUX=0. + TAUNUY=0. + ELSEIF (((VITV/MAX(ABS(WNDY),CK) .LT. iter_thresh) .AND.& + (UITV/MAX(ABS(WNDX),CK) .LT. iter_thresh)) .AND. & + (ITERATION .GE. 2)) THEN + IT_FLAG1 = .FALSE. ENDIF - DEALLOCATE(WN, DWN, CP,SIG2, SPC2, TLTN, TLTE, TAUD, & - TLTND, TLTED, ZOFK, UPROF, & - VPROF, FTILDE, UP1, VP1, UP, VP, TLTNA, TLTEA) -!/ End of W3FLD1 ----------------------------------------------------- / -!/ - RETURN -! - END SUBROUTINE W3FLD1 -!/ ------------------------------------------------------------------- / - SUBROUTINE INFLD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | B. G. Reichl | -!/ | FORTRAN 90 | -!/ | Last update : 15-Jan-2016 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-2016 : Origination. ( version 5.12 ) -!/ -! 1. Purpose : -! -! Initialization for w3fld1 (also used by w3fld2) -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3FLDX Subr. W3FLDXMD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: NDSE - USE W3GDATMD, ONLY: TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 - USE W3SERVMD, ONLY: EXTCDE + ! if taunu iteration is unstable try to reset with new guess... + if (.not.(cos(wnd_in_dir-atan2(taunuy,taunux)).ge.0.0)) then + TAUNUX = USTSM**2 * DAIR * wndx / wnd_in_mag*.95 + TAUNUY = USTSM**2 * DAIR * wndy / wnd_in_mag*.95 + endif + ENDDO + !|---------------------------------------------------------------------| + !|----Finish-----------------------------------------------------------| + !|---------------------------------------------------------------------| + USTD = ATAN2(TAUY,TAUX) + UST = SQRT( SQRT( TAUX**2 + TAUY**2 ) / DAIR) + ! Get Z0 from aligned wind + WND_PA=wnd_in_mag*COS(wnd_in_dir-USTD) + Z0 = ZWND/exp(wnd_pa*kappa/ust) + CD = UST**2 / wnd_in_mag**2 + IF (PRESENT(CHARN)) THEN + CHARN = 0.01/SQRT(SQRT( TAUNUX**2 + TAUNUY**2 )/(UST**2)) + ENDIF + FSFL1=.not.((CD .LT. 0.01).AND.(CD .GT. 0.0001)) + FSFL2=.not.(cos(wnd_in_dir-ustd).GT.0.9) + IF (FSFL1 .or. FSFL2) THEN + !Fail safe to bulk + write(*,*)'Attn: W3FLD1 failed, will output bulk...' + CALL wnd2z0m(wnd_in_mag,z0) + UST = wnd_in_mag*kappa/log(zwnd/z0) + USTD = wnd_in_dir + CD = UST**2 / wnd_in_mag**2 + ENDIF + DEALLOCATE(WN, DWN, CP,SIG2, SPC2, TLTN, TLTE, TAUD, & + TLTND, TLTED, ZOFK, UPROF, & + VPROF, FTILDE, UP1, VP1, UP, VP, TLTNA, TLTEA) + !/ End of W3FLD1 ----------------------------------------------------- / + !/ + RETURN + ! + END SUBROUTINE W3FLD1 + !/ ------------------------------------------------------------------- / + SUBROUTINE INFLD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | B. G. Reichl | + !/ | FORTRAN 90 | + !/ | Last update : 15-Jan-2016 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-2016 : Origination. ( version 5.12 ) + !/ + ! 1. Purpose : + ! + ! Initialization for w3fld1 (also used by w3fld2) + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3FLDX Subr. W3FLDXMD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: NDSE + USE W3GDATMD, ONLY: TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INFLD') + CALL STRACE (IENT, 'INFLD') #endif -! -! 1. .... ----------------------------------------------------------- * -! - Tail_Choice=Tail_ID - Tail_Level=TAIL_Lev - Tail_transition_ratio1 = TAIL_TRAN1 - Tail_transition_ratio2 = TAIL_TRAN2 - -! - RETURN -! -! Formats -! + ! + ! 1. .... ----------------------------------------------------------- * + ! + Tail_Choice=Tail_ID + Tail_Level=TAIL_Lev + Tail_transition_ratio1 = TAIL_TRAN1 + Tail_transition_ratio2 = TAIL_TRAN2 -!/ -!/ End of INFLD1 ----------------------------------------------------- / -!/ - END SUBROUTINE INFLD -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE APPENDTAIL(INSPC, WN2, NKT, KA1, KA2, KA3, WNDDIR,SAT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | B. G. Reichl | -!/ | FORTRAN 90 | -!/ | Last update : 15-Jan-2016 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-2016 : Origination. ( version 5.12 ) -!/ -! 1. Purpose : -! -! Set tail for stress calculation. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3FLD1 Subr. W3FLD1MD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPI, PI - USE W3GDATMD, ONLY: NTH, TH, DTH - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE + ! + RETURN + ! + ! Formats + ! + + !/ + !/ End of INFLD1 ----------------------------------------------------- / + !/ + END SUBROUTINE INFLD + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE APPENDTAIL(INSPC, WN2, NKT, KA1, KA2, KA3, WNDDIR,SAT) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | B. G. Reichl | + !/ | FORTRAN 90 | + !/ | Last update : 15-Jan-2016 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-2016 : Origination. ( version 5.12 ) + !/ + ! 1. Purpose : + ! + ! Set tail for stress calculation. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3FLD1 Subr. W3FLD1MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPI, PI + USE W3GDATMD, ONLY: NTH, TH, DTH + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NKT, KA1, KA2, KA3 - REAL, INTENT(IN) :: WN2(NKT), WNDDIR,SAT - REAL, INTENT(INOUT) :: INSPC(NKT,NTH) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NKT, KA1, KA2, KA3 + REAL, INTENT(IN) :: WN2(NKT), WNDDIR,SAT + REAL, INTENT(INOUT) :: INSPC(NKT,NTH) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: BT(NKT), IC, ANGLE2, ANG(NKT),& - NORMSPC(NTH), AVG, ANGDIF, M, MAXANG, & - MAXAN, MINAN - INTEGER :: MAI, I, K, T - REAL, ALLOCATABLE, DIMENSION(:) :: ANGLE1 -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: BT(NKT), IC, ANGLE2, ANG(NKT),& + NORMSPC(NTH), AVG, ANGDIF, M, MAXANG, & + MAXAN, MINAN + INTEGER :: MAI, I, K, T + REAL, ALLOCATABLE, DIMENSION(:) :: ANGLE1 + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'APPENDTAIL') + CALL STRACE (IENT, 'APPENDTAIL') #endif -! -! 1. .... ----------------------------------------------------------- * -! - !|###############################################################| - !|##1. Get the level of the saturation spectrum in transition - !|## region A - !|###############################################################| - !------------------------------------------- - ! 1a, get saturation level at KA1 (1.25xFPI) - !------------------------------------------- - BT(KA1) = 0 - ANG = 0.0 - DO T=1, NTH - BT(KA1)=BT(KA1)+INSPC(KA1,T)*WN2(KA1)**3.0*DTH - ENDDO - !----------------------------------------------- - ! 1b, Set saturation level at KA2 (3xFPI) to SAT - !----------------------------------------------- - BT(KA2) = SAT - !------------------------------------------------------------- - ! 1c, Find slope of saturation spectrum in transition region A - !------------------------------------------------------------- - M = ( BT(KA2) - BT(KA1) ) / ( WN2(KA2) - WN2(KA1) ) - !---------------------------------------------------------------- - ! 1d, Find intercept of saturation spectrum in transition region - ! A - !---------------------------------------------------------------- - IC = BT(KA1) - M * WN2(KA1) - !------------------------------------------------------ - ! 1e, Calculate saturation level for all wavenumbers in - ! transition region A - !------------------------------------------------------ - DO K=KA1,KA2 - BT(K)=M*WN2(K)+IC + ! + ! 1. .... ----------------------------------------------------------- * + ! + !|###############################################################| + !|##1. Get the level of the saturation spectrum in transition + !|## region A + !|###############################################################| + !------------------------------------------- + ! 1a, get saturation level at KA1 (1.25xFPI) + !------------------------------------------- + BT(KA1) = 0 + ANG = 0.0 + DO T=1, NTH + BT(KA1)=BT(KA1)+INSPC(KA1,T)*WN2(KA1)**3.0*DTH + ENDDO + !----------------------------------------------- + ! 1b, Set saturation level at KA2 (3xFPI) to SAT + !----------------------------------------------- + BT(KA2) = SAT + !------------------------------------------------------------- + ! 1c, Find slope of saturation spectrum in transition region A + !------------------------------------------------------------- + M = ( BT(KA2) - BT(KA1) ) / ( WN2(KA2) - WN2(KA1) ) + !---------------------------------------------------------------- + ! 1d, Find intercept of saturation spectrum in transition region + ! A + !---------------------------------------------------------------- + IC = BT(KA1) - M * WN2(KA1) + !------------------------------------------------------ + ! 1e, Calculate saturation level for all wavenumbers in + ! transition region A + !------------------------------------------------------ + DO K=KA1,KA2 + BT(K)=M*WN2(K)+IC + ENDDO + !|###############################################################| + !|##2. Determine the directionality at each wavenumber in + !|## transition region B + !|###############################################################| + !----------------------------------------------- + ! 2a, Find angle of spectral peak at KA2 (3xFPI) + !----------------------------------------------- + MAXANG = 0.0 + DO T=1, NTH + IF (INSPC(KA2,T) .GT. MAXANG) THEN + MAXANG=INSPC(KA2,T) + ENDIF + ENDDO + !------------------------------- + ! 2b, Check if peak spans 2 bins + !------------------------------- + !MAI = total number of angles of peak (if it spans more than 1) + MAI = 0 + DO T=1, NTH + IF (MAXANG .EQ. INSPC(KA2,T)) THEN + MAI = MAI+1 + ENDIF + ENDDO + !ANGLE1 = angles that correspond to peak (array) + MAI = MAX(1,MAI) + ALLOCATE(ANGLE1(MAI)) + !----------------------------------------------------- + ! 2c, If peak spans 2 or more bins it must be averaged + !----------------------------------------------------- + K=1 + DO T=1, NTH + IF (MAXANG .EQ. INSPC(KA2,T)) THEN + ANGLE1(K) = TH(T) + K=K+1 + ENDIF + ENDDO + DO K=1, MAI + DO WHILE (ANGLE1(K) .LT. 0.0) + ANGLE1(K) = ANGLE1(K) + TPI ENDDO - !|###############################################################| - !|##2. Determine the directionality at each wavenumber in - !|## transition region B - !|###############################################################| - !----------------------------------------------- - ! 2a, Find angle of spectral peak at KA2 (3xFPI) - !----------------------------------------------- - MAXANG = 0.0 - DO T=1, NTH - IF (INSPC(KA2,T) .GT. MAXANG) THEN - MAXANG=INSPC(KA2,T) - ENDIF + DO WHILE (ANGLE1(K) .GE. TPI) + ANGLE1(K) = ANGLE1(K) - TPI ENDDO - !------------------------------- - ! 2b, Check if peak spans 2 bins - !------------------------------- - !MAI = total number of angles of peak (if it spans more than 1) - MAI = 0 - DO T=1, NTH - IF (MAXANG .EQ. INSPC(KA2,T)) THEN - MAI = MAI+1 + ENDDO + IF (MAI .GT. 1) THEN + MAXAN = ANGLE1(1) + MINAN = ANGLE1(1) + DO I=2, MAI + IF (MAXAN .LT. ANGLE1(I) )THEN + MAXAN = ANGLE1(I) ENDIF - ENDDO - !ANGLE1 = angles that correspond to peak (array) - MAI = MAX(1,MAI) - ALLOCATE(ANGLE1(MAI)) - !----------------------------------------------------- - ! 2c, If peak spans 2 or more bins it must be averaged - !----------------------------------------------------- - K=1 - DO T=1, NTH - IF (MAXANG .EQ. INSPC(KA2,T)) THEN - ANGLE1(K) = TH(T) - K=K+1 + IF (MINAN .GT. ANGLE1(I) )THEN + MINAN = ANGLE1(I) ENDIF ENDDO - DO K=1, MAI - DO WHILE (ANGLE1(K) .LT. 0.0) - ANGLE1(K) = ANGLE1(K) + TPI - ENDDO - DO WHILE (ANGLE1(K) .GE. TPI) - ANGLE1(K) = ANGLE1(K) - TPI - ENDDO - ENDDO - IF (MAI .GT. 1) THEN - MAXAN = ANGLE1(1) - MINAN = ANGLE1(1) - DO I=2, MAI - IF (MAXAN .LT. ANGLE1(I) )THEN - MAXAN = ANGLE1(I) - ENDIF - IF (MINAN .GT. ANGLE1(I) )THEN - MINAN = ANGLE1(I) - ENDIF - ENDDO !------------------------------------------------------ ! Need to distinguish if mean cross the origin (0/2pi) !------------------------------------------------------ - IF (MAXAN-MINAN .GT. PI) THEN - DO I=1, MAI - IF (MAXAN - ANGLE1(I) .GT. PI) THEN - ANGLE1(I) = ANGLE1(I) + TPI - ENDIF - ENDDO - ANGLE2=SUM(ANGLE1)/MAX(REAL(MAI),1.) - ELSE - ANGLE2=SUM(ANGLE1)/MAX(REAL(MAI),1.) - ENDIF + IF (MAXAN-MINAN .GT. PI) THEN + DO I=1, MAI + IF (MAXAN - ANGLE1(I) .GT. PI) THEN + ANGLE1(I) = ANGLE1(I) + TPI + ENDIF + ENDDO + ANGLE2=SUM(ANGLE1)/MAX(REAL(MAI),1.) ELSE - ANGLE2=ANGLE1(1) + ANGLE2=SUM(ANGLE1)/MAX(REAL(MAI),1.) ENDIF - DO WHILE (ANGLE2 .LT. 0.0) - ANGLE2 = ANGLE2 + TPI - ENDDO - DO WHILE (ANGLE2 .GE. TPI) - ANGLE2 = ANGLE2 - TPI - ENDDO - ! - !--------------------------------------------------- - ! This deals with angles that are less than 90 - !--------------------------------------------------- - if (cos(angle2-wnddir) .ge. 0.) then !Less than 90 - m=asin(sin(wnddir-angle2))/(wn2(ka3)-wn2(ka2)) + ELSE + ANGLE2=ANGLE1(1) + ENDIF + DO WHILE (ANGLE2 .LT. 0.0) + ANGLE2 = ANGLE2 + TPI + ENDDO + DO WHILE (ANGLE2 .GE. TPI) + ANGLE2 = ANGLE2 - TPI + ENDDO + ! + !--------------------------------------------------- + ! This deals with angles that are less than 90 + !--------------------------------------------------- + if (cos(angle2-wnddir) .ge. 0.) then !Less than 90 + m=asin(sin(wnddir-angle2))/(wn2(ka3)-wn2(ka2)) + ic=angle2 + do k=ka2, ka3 + ang(k)=ic +m*(wn2(k)-wn2(ka2)) + enddo + else + !---------------------------------------------------- + ! This deals with angels that turn clockwise + !---------------------------------------------------- + if (sin(wnddir-angle2).GE.0) then + m=acos(cos(wnddir-angle2))/(wn2(ka3)-wn2(ka2)) ic=angle2 do k=ka2, ka3 - ang(k)=ic +m*(wn2(k)-wn2(ka2)) + ang(k)=ic+m*(wn2(k)-wn2(ka2)) enddo else - !---------------------------------------------------- - ! This deals with angels that turn clockwise - !---------------------------------------------------- - if (sin(wnddir-angle2).GE.0) then - m=acos(cos(wnddir-angle2))/(wn2(ka3)-wn2(ka2)) - ic=angle2 - do k=ka2, ka3 - ang(k)=ic+m*(wn2(k)-wn2(ka2)) - enddo - else - !----------------------------------------------------- - ! This deals with angels that cross counter-clockwise - !----------------------------------------------------- - m=acos(cos(wnddir-angle2))/(wn2(ka3)-wn2(ka2)) - ic=angle2 - do k=ka2, ka3 - ang(k)=ic-m*(wn2(k)-wn2(ka2)) - enddo - endif + !----------------------------------------------------- + ! This deals with angels that cross counter-clockwise + !----------------------------------------------------- + m=acos(cos(wnddir-angle2))/(wn2(ka3)-wn2(ka2)) + ic=angle2 + do k=ka2, ka3 + ang(k)=ic-m*(wn2(k)-wn2(ka2)) + enddo endif - !---------------------------------------------- - ! Region A, Saturation level decreased linearly - ! while direction is maintained - !---------------------------------------------- - DO K=KA1, KA2-1 - AVG=SUM(INSPC(K,:))/MAX(REAL(NTH),1.) - DO T=1,NTH - INSPC(K,T)=BT(K)*INSPC(K,T)/TPI/(WN2(K)**3.0)/AVG - ENDDO - ENDDO - !----------------------------------------------------------- - ! Region B, Saturation level left flat while spectrum turned - ! to direction of wind - !----------------------------------------------------------- - DO K = KA2, KA3 - DO T=1, NTH - angdif=th(t)-ang(k) - IF (COS(ANGDIF) .GT. 0.0) THEN - NORMSPC(T) = COS(ANGDIF)**2.0 - ELSE - NORMSPC(T)=0.0 - ENDIF - ENDDO - AVG=SUM(NORMSPC)/MAX(REAL(NTH),1.) - DO T=1, NTH - INSPC(K,T) = SAT * NORMSPC(T)/TPI/(WN2(K)**3.0)/AVG - ENDDO + endif + !---------------------------------------------- + ! Region A, Saturation level decreased linearly + ! while direction is maintained + !---------------------------------------------- + DO K=KA1, KA2-1 + AVG=SUM(INSPC(K,:))/MAX(REAL(NTH),1.) + DO T=1,NTH + INSPC(K,T)=BT(K)*INSPC(K,T)/TPI/(WN2(K)**3.0)/AVG ENDDO + ENDDO + !----------------------------------------------------------- + ! Region B, Saturation level left flat while spectrum turned + ! to direction of wind + !----------------------------------------------------------- + DO K = KA2, KA3 DO T=1, NTH - angdif=th(t)-wnddir + angdif=th(t)-ang(k) IF (COS(ANGDIF) .GT. 0.0) THEN NORMSPC(T) = COS(ANGDIF)**2.0 ELSE - NORMSPC(T) = 0.0 + NORMSPC(T)=0.0 ENDIF ENDDO - AVG=SUM(NORMSPC)/MAX(REAL(NTH),1.)!1./4. - DO K=KA3+1, NKT - DO T=1, NTH - INSPC(K,T)=NORMSPC(T)*(SAT)/TPI/(WN2(K)**3.0)/AVG - ENDDO + AVG=SUM(NORMSPC)/MAX(REAL(NTH),1.) + DO T=1, NTH + INSPC(K,T) = SAT * NORMSPC(T)/TPI/(WN2(K)**3.0)/AVG ENDDO - DEALLOCATE(ANGLE1) -! -! Formats -! -!/ -!/ End of APPENDTAIL ----------------------------------------------------- / -!/ - RETURN -! - END SUBROUTINE APPENDTAIL -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE SIG2WN(SIG,DEPTH,WN) -!/ ------------------------------------------------------------------- / -!Author: Brandon Reichl (GSO/URI) -!Origination : 2013 -!Update : March - 18 - 2015 -! : June -22 -2018 (XYC) -!Puropse : Convert from angular frequency to wavenumber -! using full gravity wave dispersion relation -! if tanh(kh)<0.99, otherwise uses deep-water -! approximation. -!NOTE: May be a better version internal to WW3 that can replace this. -! Improved by using newton's method for iteration.(2018) -!/ ------------------------------------------------------------------- / -!/ - use constants, only: GRAV -!/ - implicit none -!/ - REAL,INTENT(IN) :: SIG,DEPTH - REAL,INTENT(OUT) :: WN -!/ - real :: wn1,wn2 !,sig1,sig2,dsigdk - real :: fk, fk_slp - integer :: i - logical :: SWITCH -!/ ------------------------------------------------------------------- / - wn1=sig**2/GRAV - SWITCH=.true. -!/ Updated code with Newton's method by XYC: - if (tanh(wn1*depth) .LT. 0.99) then - do while (SWITCH) - fk=grav*wn1*tanh(wn1*depth) - sig**2 - fk_slp = grav*tanh(wn1*depth) + grav*wn1*depth/(cosh(wn1*depth))**2 + ENDDO + DO T=1, NTH + angdif=th(t)-wnddir + IF (COS(ANGDIF) .GT. 0.0) THEN + NORMSPC(T) = COS(ANGDIF)**2.0 + ELSE + NORMSPC(T) = 0.0 + ENDIF + ENDDO + AVG=SUM(NORMSPC)/MAX(REAL(NTH),1.)!1./4. + DO K=KA3+1, NKT + DO T=1, NTH + INSPC(K,T)=NORMSPC(T)*(SAT)/TPI/(WN2(K)**3.0)/AVG + ENDDO + ENDDO + DEALLOCATE(ANGLE1) + ! + ! Formats + ! + !/ + !/ End of APPENDTAIL ----------------------------------------------------- / + !/ + RETURN + ! + END SUBROUTINE APPENDTAIL + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE SIG2WN(SIG,DEPTH,WN) + !/ ------------------------------------------------------------------- / + !Author: Brandon Reichl (GSO/URI) + !Origination : 2013 + !Update : March - 18 - 2015 + ! : June -22 -2018 (XYC) + !Puropse : Convert from angular frequency to wavenumber + ! using full gravity wave dispersion relation + ! if tanh(kh)<0.99, otherwise uses deep-water + ! approximation. + !NOTE: May be a better version internal to WW3 that can replace this. + ! Improved by using newton's method for iteration.(2018) + !/ ------------------------------------------------------------------- / + !/ + use constants, only: GRAV + !/ + implicit none + !/ + REAL,INTENT(IN) :: SIG,DEPTH + REAL,INTENT(OUT) :: WN + !/ + real :: wn1,wn2 !,sig1,sig2,dsigdk + real :: fk, fk_slp + integer :: i + logical :: SWITCH + !/ ------------------------------------------------------------------- / + wn1=sig**2/GRAV + SWITCH=.true. + !/ Updated code with Newton's method by XYC: + if (tanh(wn1*depth) .LT. 0.99) then + do while (SWITCH) + fk=grav*wn1*tanh(wn1*depth) - sig**2 + fk_slp = grav*tanh(wn1*depth) + grav*wn1*depth/(cosh(wn1*depth))**2 - wn2=wn1 - fk/fk_slp - - if (abs(wn2-wn1)/wn1 .LT. 0.0001 ) then - SWITCH = .FALSE. - else - wn1=wn2 - endif - enddo - else - wn2=wn1 - endif - WN=WN2 -!/ END of update -!/ -!/ Previous code by BR: -!/ ------------------------------------------------------------------- / -! wn1=sig**2/GRAV -! wn2=wn1+0.00001 -! SWITCH=.true. -!/ ------------------------------------------------------------------- / -! if (tanh(wn1*depth).LT.0.99) then -! do i=1,5 -! if (SWITCH) then -! sig1=sqrt(GRAV*wn1*tanh(wn1*depth)) -! sig2=sqrt(GRAV*wn2*tanh(wn2*depth)) -! if (sig1.lt.sig*.99999.or.sig1.gt.sig*1.00001) then -! dsigdk=(sig2-sig1)/(wn2-wn1) -! WN1=WN1+(SIG2-SIG1)/dsigdk -! wn2=wn1+wn1*0.00001 -! else -! SWITCH = .FALSE. -! endif -! endif -! enddo -! endif -!/ -! WN=WN1 -!/ - RETURN - END SUBROUTINE SIG2WN -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE WND2Z0M( W10M , ZNOTM ) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | B. G. Reichl | -!/ | FORTRAN 90 | -!/ | Last update : 04-Aug-2016 | -!/ +-----------------------------------+ -!/ -!/ 09-Apr-2014 : Last Update. ( version 5.12 ) -!/ 15-Aug-2016 : Updated for 2016 HWRF z0 ( J. Meixner ) -!/ -! 1. Purpose : -! -! Get bulk momentum z0 from 10-m wind. -! Bulk stress corresponds to 2015 GFDL Hurricane model -! Not published yet, but contact Brandon Reichl or -! Isaac Ginis (Univ. of Rhode Island) for further info -! -! 2. Method : -! This has now been updated for 2016 HWRF z0 using routines -! from HWRF znot_m_v1, Biju Thomas, 02/07/2014 -! and znot_wind10m Weiguo Wang, 02/24/2016 -! -! 3. Parameters : -! Name Unit Type Description -! ---------------------------------------------------------------- -! W10M m/s input 10 m neutral wind [m/s] -! ZNOTM m output Roughness scale for momentum -! ---------------------------------------------------------------- -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3FLD1 Subr. W3FLD1MD Corresponding source term. -! W3FLD2 Subr. W3FLD2MD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + wn2=wn1 - fk/fk_slp + + if (abs(wn2-wn1)/wn1 .LT. 0.0001 ) then + SWITCH = .FALSE. + else + wn1=wn2 + endif + enddo + else + wn2=wn1 + endif + WN=WN2 + !/ END of update + !/ + !/ Previous code by BR: + !/ ------------------------------------------------------------------- / + ! wn1=sig**2/GRAV + ! wn2=wn1+0.00001 + ! SWITCH=.true. + !/ ------------------------------------------------------------------- / + ! if (tanh(wn1*depth).LT.0.99) then + ! do i=1,5 + ! if (SWITCH) then + ! sig1=sqrt(GRAV*wn1*tanh(wn1*depth)) + ! sig2=sqrt(GRAV*wn2*tanh(wn2*depth)) + ! if (sig1.lt.sig*.99999.or.sig1.gt.sig*1.00001) then + ! dsigdk=(sig2-sig1)/(wn2-wn1) + ! WN1=WN1+(SIG2-SIG1)/dsigdk + ! wn2=wn1+wn1*0.00001 + ! else + ! SWITCH = .FALSE. + ! endif + ! endif + ! enddo + ! endif + !/ + ! WN=WN1 + !/ + RETURN + END SUBROUTINE SIG2WN + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE WND2Z0M( W10M , ZNOTM ) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | B. G. Reichl | + !/ | FORTRAN 90 | + !/ | Last update : 04-Aug-2016 | + !/ +-----------------------------------+ + !/ + !/ 09-Apr-2014 : Last Update. ( version 5.12 ) + !/ 15-Aug-2016 : Updated for 2016 HWRF z0 ( J. Meixner ) + !/ + ! 1. Purpose : + ! + ! Get bulk momentum z0 from 10-m wind. + ! Bulk stress corresponds to 2015 GFDL Hurricane model + ! Not published yet, but contact Brandon Reichl or + ! Isaac Ginis (Univ. of Rhode Island) for further info + ! + ! 2. Method : + ! This has now been updated for 2016 HWRF z0 using routines + ! from HWRF znot_m_v1, Biju Thomas, 02/07/2014 + ! and znot_wind10m Weiguo Wang, 02/24/2016 + ! + ! 3. Parameters : + ! Name Unit Type Description + ! ---------------------------------------------------------------- + ! W10M m/s input 10 m neutral wind [m/s] + ! ZNOTM m output Roughness scale for momentum + ! ---------------------------------------------------------------- + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3FLD1 Subr. W3FLD1MD Corresponding source term. + ! W3FLD2 Subr. W3FLD2MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE - REAL, INTENT(IN) :: W10M - REAL, INTENT(OUT):: ZNOTM + !/ + IMPLICIT NONE + REAL, INTENT(IN) :: W10M + REAL, INTENT(OUT):: ZNOTM - !Parameters from znot_m_v1 - REAL, PARAMETER :: bs0 = -8.367276172397277e-12 - REAL, PARAMETER :: bs1 = 1.7398510865876079e-09 - REAL, PARAMETER :: bs2 = -1.331896578363359e-07 - REAL, PARAMETER :: bs3 = 4.507055294438727e-06 - REAL, PARAMETER :: bs4 = -6.508676881906914e-05 - REAL, PARAMETER :: bs5 = 0.00044745137674732834 - REAL, PARAMETER :: bs6 = -0.0010745704660847233 + !Parameters from znot_m_v1 + REAL, PARAMETER :: bs0 = -8.367276172397277e-12 + REAL, PARAMETER :: bs1 = 1.7398510865876079e-09 + REAL, PARAMETER :: bs2 = -1.331896578363359e-07 + REAL, PARAMETER :: bs3 = 4.507055294438727e-06 + REAL, PARAMETER :: bs4 = -6.508676881906914e-05 + REAL, PARAMETER :: bs5 = 0.00044745137674732834 + REAL, PARAMETER :: bs6 = -0.0010745704660847233 - REAL, PARAMETER :: cf0 = 2.1151080765239772e-13 - REAL, PARAMETER :: cf1 = -3.2260663894433345e-11 - REAL, PARAMETER :: cf2 = -3.329705958751961e-10 - REAL, PARAMETER :: cf3 = 1.7648562021709124e-07 - REAL, PARAMETER :: cf4 = 7.107636825694182e-06 - REAL, PARAMETER :: cf5 = -0.0013914681964973246 - REAL, PARAMETER :: cf6 = 0.0406766967657759 + REAL, PARAMETER :: cf0 = 2.1151080765239772e-13 + REAL, PARAMETER :: cf1 = -3.2260663894433345e-11 + REAL, PARAMETER :: cf2 = -3.329705958751961e-10 + REAL, PARAMETER :: cf3 = 1.7648562021709124e-07 + REAL, PARAMETER :: cf4 = 7.107636825694182e-06 + REAL, PARAMETER :: cf5 = -0.0013914681964973246 + REAL, PARAMETER :: cf6 = 0.0406766967657759 - !Variables from znot_wind10m - REAL :: Z10, U10,AAA,TMP + !Variables from znot_wind10m + REAL :: Z10, U10,AAA,TMP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'WND2Z0M') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'WND2Z0M') #endif - !Values as set in znot_wind10m - Z10=10.0 - U10=W10M - if (U10 > 85.0) U10=85.0 + !Values as set in znot_wind10m + Z10=10.0 + U10=W10M + if (U10 > 85.0) U10=85.0 - !Calculation of z0 as in znot_m_v1 - IF ( U10 .LE. 5.0 ) THEN - ZNOTM = (0.0185 / 9.8*(7.59e-4*U10**2+2.46e-2*U10)**2) - ELSEIF (U10 .GT. 5.0 .AND. U10 .LT. 10.0) THEN - ZNOTM =.00000235*(U10**2 - 25 ) + 3.805129199617346e-05 - ELSEIF ( U10 .GE. 10.0 .AND. U10 .LT. 60.0) THEN - ZNOTM = bs6 + bs5*U10 + bs4*U10**2 + bs3*U10**3 + bs2*U10**4 +& - bs1*U10**5 + bs0*U10**6 - ELSE - ZNOTM = cf6 + cf5*U10 + cf4*U10**2 + cf3*U10**3 + cf2*U10**4 +& - cf1*U10**5 + cf0*U10**6 - END IF + !Calculation of z0 as in znot_m_v1 + IF ( U10 .LE. 5.0 ) THEN + ZNOTM = (0.0185 / 9.8*(7.59e-4*U10**2+2.46e-2*U10)**2) + ELSEIF (U10 .GT. 5.0 .AND. U10 .LT. 10.0) THEN + ZNOTM =.00000235*(U10**2 - 25 ) + 3.805129199617346e-05 + ELSEIF ( U10 .GE. 10.0 .AND. U10 .LT. 60.0) THEN + ZNOTM = bs6 + bs5*U10 + bs4*U10**2 + bs3*U10**3 + bs2*U10**4 +& + bs1*U10**5 + bs0*U10**6 + ELSE + ZNOTM = cf6 + cf5*U10 + cf4*U10**2 + cf3*U10**3 + cf2*U10**4 +& + cf1*U10**5 + cf0*U10**6 + END IF - !Modifications as in znot_wind10m for icoef_sf=4 + !Modifications as in znot_wind10m for icoef_sf=4 - !for wind<20, cd similar to icoef=2 at 10m, then reduced - TMP=0.4*0.4/(ALOG(10.0/ZNOTM))**2 ! cd at zlev - AAA=0.75 - IF (U10 < 20) THEN - AAA=0.99 - ELSEIF(U10 < 45.0) THEN - AAA=0.99+(U10-20)*(0.75-0.99)/(45.0-20.0) - END IF - ZNOTM=Z10/EXP( SQRT(0.4*0.4/(TMP*AAA)) ) + !for wind<20, cd similar to icoef=2 at 10m, then reduced + TMP=0.4*0.4/(ALOG(10.0/ZNOTM))**2 ! cd at zlev + AAA=0.75 + IF (U10 < 20) THEN + AAA=0.99 + ELSEIF(U10 < 45.0) THEN + AAA=0.99+(U10-20)*(0.75-0.99)/(45.0-20.0) + END IF + ZNOTM=Z10/EXP( SQRT(0.4*0.4/(TMP*AAA)) ) - END SUBROUTINE WND2Z0M -!/ ------------------------------------------------------------------- / - SUBROUTINE WND2SAT(WND10,SAT) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | B. G. Reichl | -!/ | FORTRAN 90 | -!/ | Last update : 04-Aug-2016 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-2016 : Origination. ( version 5.12 ) -!/ 04-Aug-2016 : Updated for 2016 HWRF CD/U10 curve ( J. Meixner ) -!/ -! 1. Purpose : -! -! Gives level of saturation spectrum to produce -! equivalent Cd as in wnd2z0m (for neutral 10m wind) -! tuned for method of Reichl et al. 2014 -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- - !Input: WND10 - 10 m neutral wind [m/s] - !Output: SAT - Level 1-d saturation spectrum in tail [non-dim] -! ---------------------------------------------------------------- -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3FLD1 Subr. W3FLD1MD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END SUBROUTINE WND2Z0M + !/ ------------------------------------------------------------------- / + SUBROUTINE WND2SAT(WND10,SAT) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | B. G. Reichl | + !/ | FORTRAN 90 | + !/ | Last update : 04-Aug-2016 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-2016 : Origination. ( version 5.12 ) + !/ 04-Aug-2016 : Updated for 2016 HWRF CD/U10 curve ( J. Meixner ) + !/ + ! 1. Purpose : + ! + ! Gives level of saturation spectrum to produce + ! equivalent Cd as in wnd2z0m (for neutral 10m wind) + ! tuned for method of Reichl et al. 2014 + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + !Input: WND10 - 10 m neutral wind [m/s] + !Output: SAT - Level 1-d saturation spectrum in tail [non-dim] + ! ---------------------------------------------------------------- + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3FLD1 Subr. W3FLD1MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ - REAL, INTENT(IN) :: WND10 - REAL, INTENT(OUT) :: SAT + !/ + IMPLICIT NONE + !/ + REAL, INTENT(IN) :: WND10 + REAL, INTENT(OUT) :: SAT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'WND2SAT') #endif -! -#ifdef W3_S - CALL STRACE (IENT, 'WND2SAT') -#endif -!/ Old HWRF 2015 and ST2 -! SAT =0.000000000001237 * WND10**6 +& -! -0.000000000364155 * WND10**5 +& -! 0.000000037435015 * WND10**4 +& -! -0.000001424719473 * WND10**3 +& -! 0.000000471570975 * WND10**2 +& -! 0.000778467452178 * WND10**1 +& -! 0.002962335390055 -! -! SAT values based on -! HWRF 2016 CD curve, created with fetch limited cases ST4 physics - IF (WND10<20.0) THEN - SAT = -0.000018541921682*WND10**2 & - +0.000751515452434*WND10 & - +0.002466529381004 - ELSEIF (WND10<45) THEN - SAT = -0.000000009060349*WND10**4 & - +0.000001276678367*WND10**3 & - -0.000068274393789*WND10**2 & - +0.001418180888868*WND10 & - +0.000262277682984 - ELSE - SAT = -0.000155976275073*WND10 & - +0.012027763023184 - ENDIF + !/ Old HWRF 2015 and ST2 + ! SAT =0.000000000001237 * WND10**6 +& + ! -0.000000000364155 * WND10**5 +& + ! 0.000000037435015 * WND10**4 +& + ! -0.000001424719473 * WND10**3 +& + ! 0.000000471570975 * WND10**2 +& + ! 0.000778467452178 * WND10**1 +& + ! 0.002962335390055 + ! + ! SAT values based on + ! HWRF 2016 CD curve, created with fetch limited cases ST4 physics + IF (WND10<20.0) THEN + SAT = -0.000018541921682*WND10**2 & + +0.000751515452434*WND10 & + +0.002466529381004 + ELSEIF (WND10<45) THEN + SAT = -0.000000009060349*WND10**4 & + +0.000001276678367*WND10**3 & + -0.000068274393789*WND10**2 & + +0.001418180888868*WND10 & + +0.000262277682984 + ELSE + SAT = -0.000155976275073*WND10 & + +0.012027763023184 + ENDIF - SAT = min(max(SAT,0.002),0.014) - END SUBROUTINE WND2SAT -! -!/ End of module W3FLD1MD -------------------------------------------- / -!/ - END MODULE W3FLD1MD + SAT = min(max(SAT,0.002),0.014) + END SUBROUTINE WND2SAT + ! + !/ End of module W3FLD1MD -------------------------------------------- / + !/ +END MODULE W3FLD1MD diff --git a/model/src/w3fld2md.F90 b/model/src/w3fld2md.F90 index 30d247cee..83e44c021 100644 --- a/model/src/w3fld2md.F90 +++ b/model/src/w3fld2md.F90 @@ -1,700 +1,697 @@ !/ ------------------------------------------------------------------- / - Module W3FLD2MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP/NOPP | -!/ | B. G. Reichl | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 01-Jul-2013 : Origination (version 3.14) -!/ 16-May-2014 : Finalizing (version 4.18) -!/ 19-Mar-2015 : Extending for non-10 m winds (version 5.12) -!/ 27-Jul-2016 : Added Charnock output (J.Meixner) (version 5.12) -!/ 22-Jun-2018 : Minor modification for application in shallow water. -!/ (X.Chen) (version 6.06) -!/ 22-Mar-2021 : Consider DAIR a variable ( version 7.13 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! This section of code has been designed to compute the wind -! stress vector from the wave spectrum, the wind speed -! vector, and the lower atmosphere stability. -! This code is based on the 2012 JGR paper, "Modeling Waves -! and Wind Stress" by Donelan, Curcic, Chen, and Magnusson. -! -! 2. Variables and types : -! -! Not applicable -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3FLD2 Subr. Public Donelan et al. 2012 stress calculation -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3FLD2( ASPC,FPI, WNDX,WNDY, ZWND, & - DEPTH, RIB, DAIR, UST, USTD, Z0, TAUNUX,TAUNUY,CHARN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP/NOPP | -!/ | B. G. Reichl | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 01-Jul-2013 : Origination (version 3.14) -!/ 19-Mar-2015 : Clean-up for submission (version 5.12) -!/ 22-Mar-2021 : Consider DAIR a variable ( version 7.13 ) -!/ -! 1. Purpose : -! -! Wind stress vector calculation from wave spectrum and -! n-meter wind speed vector. -! -! 2. Method : -! See Donelan et al. (2012). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ASPC Real I 1-D Wave action spectrum. -! FPI Real I Peak input frequency. -! WNDX Real I X-dir wind (assumed referenced to current) -! WNDY Real I Y-dir wind (assumed referenced to current) -! ZWND Real I Wind height. -! DEPTH Real I Water depth. -! RIB Real I Bulk Richardson number in lower atm -! DAIR Real I Air density -! TAUNUX Real 0 X-dir viscous stress (guessed from prev.) -! TAUNUY Real 0 Y-dir viscous stress (guessed from prev.) -! UST Real O Friction velocity. -! USTD Real O Direction of friction velocity. -! Z0 Real O Surface roughness length -! CHARN Real O,optional Charnock parameter -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! APPENDTAIL Subr. W3FLD1MD Modification of tail for calculation -! SIG2WN Subr. W3FLD1MD Depth-dependent dispersion relation -! MFLUX Subr. W3FLD1MD MO stability correction -! WND2Z0M Subr. W3FLD1MD Bulk Z0 from wind -! CALC_FPI Subr. W3FLD1MD Calculate peak frequency -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3ASIM Subr. W3ASIMMD Air-sea interface module. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: DWAT, GRAV, TPI, PI, KAPPA - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, XFR, TH - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE W3FLD1MD, ONLY: APPENDTAIL,sig2wn,wnd2z0m,infld,tail_choice,& - tail_level, tail_transition_ratio1, & - tail_transition_ratio2 +Module W3FLD2MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP/NOPP | + !/ | B. G. Reichl | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 01-Jul-2013 : Origination (version 3.14) + !/ 16-May-2014 : Finalizing (version 4.18) + !/ 19-Mar-2015 : Extending for non-10 m winds (version 5.12) + !/ 27-Jul-2016 : Added Charnock output (J.Meixner) (version 5.12) + !/ 22-Jun-2018 : Minor modification for application in shallow water. + !/ (X.Chen) (version 6.06) + !/ 22-Mar-2021 : Consider DAIR a variable ( version 7.13 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! This section of code has been designed to compute the wind + ! stress vector from the wave spectrum, the wind speed + ! vector, and the lower atmosphere stability. + ! This code is based on the 2012 JGR paper, "Modeling Waves + ! and Wind Stress" by Donelan, Curcic, Chen, and Magnusson. + ! + ! 2. Variables and types : + ! + ! Not applicable + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3FLD2 Subr. Public Donelan et al. 2012 stress calculation + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3FLD2( ASPC,FPI, WNDX,WNDY, ZWND, & + DEPTH, RIB, DAIR, UST, USTD, Z0, TAUNUX,TAUNUY,CHARN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP/NOPP | + !/ | B. G. Reichl | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 01-Jul-2013 : Origination (version 3.14) + !/ 19-Mar-2015 : Clean-up for submission (version 5.12) + !/ 22-Mar-2021 : Consider DAIR a variable ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Wind stress vector calculation from wave spectrum and + ! n-meter wind speed vector. + ! + ! 2. Method : + ! See Donelan et al. (2012). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ASPC Real I 1-D Wave action spectrum. + ! FPI Real I Peak input frequency. + ! WNDX Real I X-dir wind (assumed referenced to current) + ! WNDY Real I Y-dir wind (assumed referenced to current) + ! ZWND Real I Wind height. + ! DEPTH Real I Water depth. + ! RIB Real I Bulk Richardson number in lower atm + ! DAIR Real I Air density + ! TAUNUX Real 0 X-dir viscous stress (guessed from prev.) + ! TAUNUY Real 0 Y-dir viscous stress (guessed from prev.) + ! UST Real O Friction velocity. + ! USTD Real O Direction of friction velocity. + ! Z0 Real O Surface roughness length + ! CHARN Real O,optional Charnock parameter + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! APPENDTAIL Subr. W3FLD1MD Modification of tail for calculation + ! SIG2WN Subr. W3FLD1MD Depth-dependent dispersion relation + ! MFLUX Subr. W3FLD1MD MO stability correction + ! WND2Z0M Subr. W3FLD1MD Bulk Z0 from wind + ! CALC_FPI Subr. W3FLD1MD Calculate peak frequency + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3ASIM Subr. W3ASIMMD Air-sea interface module. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: DWAT, GRAV, TPI, PI, KAPPA + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, XFR, TH + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE W3FLD1MD, ONLY: APPENDTAIL,sig2wn,wnd2z0m,infld,tail_choice,& + tail_level, tail_transition_ratio1, & + tail_transition_ratio2 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: ASPC(NSPEC), WNDX, WNDY, & - ZWND, DEPTH, RIB, DAIR, FPI - REAL, INTENT(OUT) :: UST, USTD, Z0 - REAL, INTENT(OUT),OPTIONAL :: CHARN - REAL, INTENT(INOUT) :: TAUNUX, TAUNUY -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - !-Parameters - REAL, PARAMETER :: NU=0.105/10000.0 - !-Commonly used values - REAL :: UREF, UREFD - !-Tail - REAL :: SAT - REAL :: KMAX, KTAILA, KTAILB, KTAILC - INTEGER :: KA1, KA2, KA3, NKT - !-Extended spectrum - REAL, ALLOCATABLE, DIMENSION(:) :: WN, DWN, CP, sig2,TAUINTX, TAUINTY - REAL, ALLOCATABLE, DIMENSION(:,:) :: SPC2 - !-Stress Calculation - INTEGER :: K, T, ITS - REAL :: TAUXW, TAUYW, TAUX, TAUY - REAL :: USTRA, USTRB, USTSM - REAL :: A1, SCIN - REAL :: CD, CDF, CDS - real :: wnd_z, wnd_z_mag, wnd_z_proj, wnd_effect - ! Stress iteration - REAL :: B1, B2 - REAL :: USTRI1, USTRF1, USTRI2, USTRF2 - REAL :: USTGRA, SLO - LOGICAL :: UST_IT_FLG(2) - !-Z0 iteration - REAL :: z01,z02 - !-Wind iteration - real :: wnd_10_x, wnd_10_y, wnd_10_mag, wnd_10_dir - real :: u35_1, v35_1, u35_2, v35_2, u35_3, v35_3 - REAL :: DIFU10xx, DIFU10yx, DIFU10xy, DIFU10yy - REAL :: fd_a, fd_b, fd_c, fd_d - REAL :: DU, DV, UITV, VITV, CH - REAL :: APAR, DTX(3), DTY(3), DT - LOGICAL :: WIFLG, WND_IT_FLG - !-MO stability correction - LOGICAL :: HEIGHTFLG - integer :: wi_count, wi - real :: wnd_ref_al,wnd_ref_ax - real :: wndpa, wndpax, wndpay, wndpe,wndpex, wndpey - LOGICAL :: NO_ERR - LOGICAL :: ITERFLAG - INTEGER :: ITTOT - INTEGER :: COUNT + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: ASPC(NSPEC), WNDX, WNDY, & + ZWND, DEPTH, RIB, DAIR, FPI + REAL, INTENT(OUT) :: UST, USTD, Z0 + REAL, INTENT(OUT),OPTIONAL :: CHARN + REAL, INTENT(INOUT) :: TAUNUX, TAUNUY + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + !-Parameters + REAL, PARAMETER :: NU=0.105/10000.0 + !-Commonly used values + REAL :: UREF, UREFD + !-Tail + REAL :: SAT + REAL :: KMAX, KTAILA, KTAILB, KTAILC + INTEGER :: KA1, KA2, KA3, NKT + !-Extended spectrum + REAL, ALLOCATABLE, DIMENSION(:) :: WN, DWN, CP, sig2,TAUINTX, TAUINTY + REAL, ALLOCATABLE, DIMENSION(:,:) :: SPC2 + !-Stress Calculation + INTEGER :: K, T, ITS + REAL :: TAUXW, TAUYW, TAUX, TAUY + REAL :: USTRA, USTRB, USTSM + REAL :: A1, SCIN + REAL :: CD, CDF, CDS + real :: wnd_z, wnd_z_mag, wnd_z_proj, wnd_effect + ! Stress iteration + REAL :: B1, B2 + REAL :: USTRI1, USTRF1, USTRI2, USTRF2 + REAL :: USTGRA, SLO + LOGICAL :: UST_IT_FLG(2) + !-Z0 iteration + REAL :: z01,z02 + !-Wind iteration + real :: wnd_10_x, wnd_10_y, wnd_10_mag, wnd_10_dir + real :: u35_1, v35_1, u35_2, v35_2, u35_3, v35_3 + REAL :: DIFU10xx, DIFU10yx, DIFU10xy, DIFU10yy + REAL :: fd_a, fd_b, fd_c, fd_d + REAL :: DU, DV, UITV, VITV, CH + REAL :: APAR, DTX(3), DTY(3), DT + LOGICAL :: WIFLG, WND_IT_FLG + !-MO stability correction + LOGICAL :: HEIGHTFLG + integer :: wi_count, wi + real :: wnd_ref_al,wnd_ref_ax + real :: wndpa, wndpax, wndpay, wndpe,wndpex, wndpey + LOGICAL :: NO_ERR + LOGICAL :: ITERFLAG + INTEGER :: ITTOT + INTEGER :: COUNT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: FIRST = .TRUE. #ifdef W3_OMPG -!$omp threadprivate( FIRST ) + !$omp threadprivate( FIRST ) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'C3FLD2') + CALL STRACE (IENT, 'C3FLD2') #endif -! -! 0. Initializations ------------------------------------------------ * -! -! ********************************************************** -! *** The initialization routine should include all *** -! *** initialization, including reading data from files. *** -! ********************************************************** -! - IF ( FIRST ) THEN - CALL INFLD - FIRST = .FALSE. - END IF - !----------------------------| - ! Calculate Reference height | - ! wind magnitude | - !----------------------------| - UREF=SQRT(WNDX**2+WNDY**2) - UREFD=ATAN2(WNDY,WNDX) - !----------------------------------------------| - ! Check if wind height not equal to 10 m | - !----------------------------------------------| - !HeightFLG = (abs(zwnd-10.).GT.0.1) ! True if not 10m - !----------------------------------------------| - ! Assume bulk and calculate 10 m wind guess for| - ! defining tail level | - !----------------------------------------------| - CALL wnd2z0m(uref,z01) ! first guess at z0 - wnd_10_mag=uref - ittot=1 - ! If input wind is not 10m, solve for approx 10 m - !-------------------------------------------------| - ! If height != 10 m, then iterate to get 10 m wind| - ! (assuming neutral -- this is just a guess) | - !-------------------------------------------------| - !IF (HeightFLG) THEN - ! IterFLAG=.true. - ! COUNT = 1 !COUNT is now counting iteration over z0 - ! do while(IterFLAG) - ! wnd_10_mag=UREF*log(10./z01)/log(zwnd/z01) - ! CALL wnd2z0m(wnd_10_mag,z02) - ! if ( (abs(z01/z02-1.).GT.0.001) .AND. & - ! (COUNT.LT.10))THEN - ! z01 = z02 - ! else - ! IterFLAG = .false. - ! endif - ! COUNT = COUNT + 1 - ! enddo - ! ITTOT = 3 !extra iterations for 10m wind - !ELSE - ! wnd_10_mag = uref - ! ITTOT = 1 !no iteration needed - !ENDIF - if (Tail_Choice.eq.0) then - SAT=Tail_Level - elseif (Tail_Choice.eq.1) then - CALL WND2SAT(wnd_10_mag,SAT) - endif - ! now you have the guess at 10 m wind mag. and z01 -!/ - !--------------------------| - ! Get first guess at ustar | - !--------------------------| - USTRA = UREF*kappa/log(zwnd/z01) - USTD = UREFD - wnd_10_dir = urefd - wnd_10_x=wnd_10_mag*cos(wnd_10_dir) - wnd_10_y=wnd_10_mag*sin(wnd_10_dir) -! -! 1. Attach Tail ---------------------------------------------------- * -! - call sig2wn ( sig(nk),depth,kmax) - NKT = NK - DO WHILE ( KMAX .LT. 366. ) - NKT = NKT + 1 - KMAX = ( KMAX * XFR**2 ) - ENDDO - ALLOCATE( WN(NKT), DWN(NKT), CP(NKT),sig2(nkt), SPC2(NKT,NTH), & - TAUINTX(NKT),TAUINTY(NKT)) -!|--------------------------------------------------------------------| -!|----Build Discrete Wavenumbers for defining spectrum on-------------| -!|--------------------------------------------------------------------| - DO K = 1, NK - call sig2wn(sig(k),depth,wn(k)) - CP(K) = sig(k) / WN(K) - sig2(k) = sig(k) + ! + ! 0. Initializations ------------------------------------------------ * + ! + ! ********************************************************** + ! *** The initialization routine should include all *** + ! *** initialization, including reading data from files. *** + ! ********************************************************** + ! + IF ( FIRST ) THEN + CALL INFLD + FIRST = .FALSE. + END IF + !----------------------------| + ! Calculate Reference height | + ! wind magnitude | + !----------------------------| + UREF=SQRT(WNDX**2+WNDY**2) + UREFD=ATAN2(WNDY,WNDX) + !----------------------------------------------| + ! Check if wind height not equal to 10 m | + !----------------------------------------------| + !HeightFLG = (abs(zwnd-10.).GT.0.1) ! True if not 10m + !----------------------------------------------| + ! Assume bulk and calculate 10 m wind guess for| + ! defining tail level | + !----------------------------------------------| + CALL wnd2z0m(uref,z01) ! first guess at z0 + wnd_10_mag=uref + ittot=1 + ! If input wind is not 10m, solve for approx 10 m + !-------------------------------------------------| + ! If height != 10 m, then iterate to get 10 m wind| + ! (assuming neutral -- this is just a guess) | + !-------------------------------------------------| + !IF (HeightFLG) THEN + ! IterFLAG=.true. + ! COUNT = 1 !COUNT is now counting iteration over z0 + ! do while(IterFLAG) + ! wnd_10_mag=UREF*log(10./z01)/log(zwnd/z01) + ! CALL wnd2z0m(wnd_10_mag,z02) + ! if ( (abs(z01/z02-1.).GT.0.001) .AND. & + ! (COUNT.LT.10))THEN + ! z01 = z02 + ! else + ! IterFLAG = .false. + ! endif + ! COUNT = COUNT + 1 + ! enddo + ! ITTOT = 3 !extra iterations for 10m wind + !ELSE + ! wnd_10_mag = uref + ! ITTOT = 1 !no iteration needed + !ENDIF + if (Tail_Choice.eq.0) then + SAT=Tail_Level + elseif (Tail_Choice.eq.1) then + CALL WND2SAT(wnd_10_mag,SAT) + endif + ! now you have the guess at 10 m wind mag. and z01 + !/ + !--------------------------| + ! Get first guess at ustar | + !--------------------------| + USTRA = UREF*kappa/log(zwnd/z01) + USTD = UREFD + wnd_10_dir = urefd + wnd_10_x=wnd_10_mag*cos(wnd_10_dir) + wnd_10_y=wnd_10_mag*sin(wnd_10_dir) + ! + ! 1. Attach Tail ---------------------------------------------------- * + ! + call sig2wn ( sig(nk),depth,kmax) + NKT = NK + DO WHILE ( KMAX .LT. 366. ) + NKT = NKT + 1 + KMAX = ( KMAX * XFR**2 ) + ENDDO + ALLOCATE( WN(NKT), DWN(NKT), CP(NKT),sig2(nkt), SPC2(NKT,NTH), & + TAUINTX(NKT),TAUINTY(NKT)) + !|--------------------------------------------------------------------| + !|----Build Discrete Wavenumbers for defining spectrum on-------------| + !|--------------------------------------------------------------------| + DO K = 1, NK + call sig2wn(sig(k),depth,wn(k)) + CP(K) = sig(k) / WN(K) + sig2(k) = sig(k) + ENDDO + DO K = ( NK + 1 ), ( NKT) + sig2(k)=sig2(k-1)*XFR + call sig2wn(sig2(k),depth,wn(k)) + cp(k)=sig2(k)/wn(k) + ENDDO + DO K = 2, NKT-1 + DWN(K) = (WN(K+1) - WN(K-1)) / 2.0 + ENDDO + DWN(1) = ( WN(2)- ( WN(1) / (XFR **2.0) ) ) / 2.0 + DWN(NKT) = ( WN(NKT)*(XFR**2.0) - WN(NKT-1)) / 2.0 + !|---------------------------------------------------------------------| + !|---Attach initial tail-----------------------------------------------| + !|---------------------------------------------------------------------| + COUNT=0 !Count is now counting step through 1-d spectrum + DO K=1, NK + DO T=1, NTH + COUNT = COUNT + 1 + SPC2(K,T) = ASPC(COUNT) * SIG(K) ENDDO - DO K = ( NK + 1 ), ( NKT) - sig2(k)=sig2(k-1)*XFR - call sig2wn(sig2(k),depth,wn(k)) - cp(k)=sig2(k)/wn(k) + ENDDO + DO K=NK+1, NKT + DO T=1, NTH + SPC2(K,T)=SPC2(NK,T)*WN(NK)**3.0/WN(K)**(3.0) ENDDO - DO K = 2, NKT-1 - DWN(K) = (WN(K+1) - WN(K-1)) / 2.0 - ENDDO - DWN(1) = ( WN(2)- ( WN(1) / (XFR **2.0) ) ) / 2.0 - DWN(NKT) = ( WN(NKT)*(XFR**2.0) - WN(NKT-1)) / 2.0 -!|---------------------------------------------------------------------| -!|---Attach initial tail-----------------------------------------------| -!|---------------------------------------------------------------------| - COUNT=0 !Count is now counting step through 1-d spectrum - DO K=1, NK - DO T=1, NTH + ENDDO + ! + ! 1c. Calculate transitions for new (constant saturation ) tail ------ * + ! + !-----Wavenumber for beginning of (spectrum level) transition to tail- * + call sig2wn (FPI*TPI*tail_transition_ratio1,depth,ktaila ) + !-----Wavenumber for end of (spectrum level) transition to tail------- * + call sig2wn (FPI*TPI*tail_transition_ratio2,depth,ktailb ) + !-----Wavenumber for end of (spectrum direction) transition to tail--- * + KTAILC= KTAILB * 2.0 + KA1 = 2 ! Do not modify 1st wavenumber bin + DO WHILE ( ( KTAILA .GE. WN(KA1) ) .AND. (KA1 .LT. NKT-6) ) + KA1 = KA1 + 1 + ENDDO + KA2 = KA1+2 + DO WHILE ( ( KTAILB .GE. WN(KA2) ) .AND. (KA2 .LT. NKT-4) ) + KA2 = KA2 + 1 + ENDDO + KA3 = KA2+2 + DO WHILE ( ( KTAILC .GE. WN(KA3)) .AND. (KA3 .LT. NKT-2) ) + KA3 = KA3 + 1 + ENDDO + CALL APPENDTAIL(SPC2,WN,NKT,KA1,KA2,KA3,atan2(WNDY,WNDX),SAT) + ! Now the spectrum is set w/ tail level SAT + ! + ! 2. Enter iteration ------------------------------------------------- * + ! + ! Add new iteration for wind + ! + ! Wind perturbations for iteration + !DT = 1.E-04 + !DTX = (/ 1. , -1. , 0. /) + !DTY = (/ 0. , 1. , -1. /) + !/ + HEIGHTFLG=.false.!Not set-up for non-10 m winds + WIFLG = .TRUE. !This kicks out when wind iteration complete + NO_ERR = .TRUE. !This kicks out when there is an error + WI_COUNT = 1 !Count is now counting wind iterations + ! - start of wind iteration (if applicable) + DO WHILE ( WIFLG .AND. NO_ERR ) !Wind iteration + !/ + DO WI = 1, ITTOT !Newton-Raphson solve for derivatives if zwnd not 10 m. + ! If iterating over 10 m wind need to adjust guesses to get slopes + IF (HeightFLG) THEN + WND_10_X = WND_10_X + DTX(WI)*DT + WND_10_Y = WND_10_Y + DTY(WI)*DT + wnd_10_mag = sqrt(wnd_10_x**2+wnd_10_y**2) + wnd_10_dir = atan2(wnd_10_y,wnd_10_x) + ENDIF + ! + ! Stress iteration (inside wind iteration solve for stress) + ITS = 1 !ITS is counting stress iteration + UST_IT_FLG(1)=.TRUE. + UST_IT_FLG(2)=.TRUE. + DO WHILE ((UST_IT_FLG(1) .AND. UST_IT_FLG(2)) .AND. NO_ERR) + !Get z0 from (guessed) stress and wind magnitude + z0 = 10. / ( EXP( KAPPA * wnd_10_mag / USTRA ) ) + TAUINTX(1:NKT) = 0.0 + TAUINTY(1:NKT) = 0.0 + DO K = 1, NKT + !Waves 'feel' wind at height related to wavelength + wnd_z = MIN( PI / WN(K), 20.0 ) + wnd_z_mag = ( USTRA / KAPPA ) * (LOG(wnd_z/Z0)) + DO T = 1, NTH + !projected component of wind in wave direction + wnd_z_proj = wnd_z_mag * COS( wnd_10_dir-TH(T) ) + IF (wnd_z_proj .GT. CP(K)) THEN + !Waves slower than wind + A1 = 0.11 + ELSEIF (( wnd_z_proj .GE. 0 ) .AND. ( wnd_z_proj .LE. CP(K) )) THEN + !Wave faster than wind + A1 = 0.01 + ELSEIF (wnd_z_proj .LT. 0) THEN + !Waves opposed to wind + A1 = 0.1 + ENDIF + wnd_effect = wnd_z_proj - CP(K) + SCIN = A1 * wnd_effect * ABS( wnd_effect ) * DAIR / DWAT * & + WN(K) / CP(K) + ! -- Original version assumed g/Cp = sig,(a.k.a in deep water.) + ! TAUINTX(K) = TAUINTX(K) + SPC2(K,T) * SCIN & + ! * COS( TH(T) ) / CP(K) * DTH + ! TAUINTY(K) = TAUINTY(K) + SPC2(K,T) * SCIN & + ! * SIN( TH(T) ) / CP(K) * DTH + + TAUINTX(K) = TAUINTX(K) + SPC2(K,T) * SCIN & + * COS( TH(T) ) *SIG2(K) * DTH + TAUINTY(K) = TAUINTY(K) + SPC2(K,T) * SCIN & + * SIN( TH(T) ) *SIG2(K) * DTH + ENDDO + ENDDO + TAUYW = 0.0 + TAUXW = 0.0 + DO K = 1, NKT + ! TAUXW = TAUXW + DWAT * GRAV * DWN(K) * TAUINTX(K) + ! TAUYW = TAUYW + DWAT * GRAV * DWN(K) * TAUINTY(K) + TAUXW = TAUXW + DWAT * DWN(K) * TAUINTX(K) + TAUYW = TAUYW + DWAT * DWN(K) * TAUINTY(K) + ENDDO + CDF = ( SQRT(TAUXW**2.0+TAUYW**2.0) / DAIR ) / wnd_10_mag**2.0 + !|---------------------------------------------------------------------| + !|----Solve for the smooth drag coefficient to use as initial guess----| + !|----for the viscous stress-------------------------------------------| + !|---------------------------------------------------------------------| + IF (UREF .LT. 0.01) THEN + USTSM = 0.0 + IterFLAG = .false. + ELSE + Z02 = 0.001 + IterFLAG = .true. + ENDIF + COUNT = 1 + ! Finding smooth z0 to get smooth drag + DO WHILE( (IterFLAG ) .AND. (COUNT .LT. 10) ) + Z01 = Z02 + USTSM = KAPPA * wnd_10_mag / ( LOG( 10. / Z01 ) ) + Z02 = 0.132 * NU / USTSM + IF (ABS( Z02/Z01-1.0) .LT. 10.0**(-4)) THEN + IterFLAG = .false. + ELSE + IterFLAG = .true. + ENDIF COUNT = COUNT + 1 - SPC2(K,T) = ASPC(COUNT) * SIG(K) - ENDDO + ENDDO + CDS = USTSM**2.0 / wnd_10_mag**2.0 + ! smooth drag adjustment based on full drag + CDS = CDS / 3.0 * ( 1.0 + 2.0 * CDS / ( CDS + CDF ) ) + !-----Solve for viscous stress from smooth Cd + TAUNUX = DAIR * CDS * wnd_10_mag**2.0 * COS( wnd_10_dir ) + TAUNUY = DAIR * CDS * wnd_10_mag**2.0 * SIN( wnd_10_dir ) + !-----Sum drag components + TAUX = TAUNUX + TAUXW + TAUY = TAUNUY + TAUYW + !-----Calculate USTAR + USTRB = SQRT( SQRT( TAUY**2.0 + TAUX**2.0) / DAIR ) + !-----Calculate stress direction + ustd = atan2(tauy,taux) + !Checking ustar. ustra=guess. ustrb=found. + B1 = ( USTRA - USTRB ) + B2 = ( USTRA + USTRB ) / 2.0 + ITS = ITS + 1 + !Check for convergence + UST_IT_FLG(1)=( ABS(B1*100.0/B2) .GE. 0.01) + !If not converged after 20 iterations, quit. + UST_IT_FLG(2)=( ITS .LT. 20 ) + IF ( UST_IT_FLG(1) .AND. UST_IT_FLG(2)) THEN + ! Toyed with methods for improving iteration. + ! ultimately this was sufficient. + ! May be imporved upon in future... + USTRA = USTRB*.5 + USTRB*.5 + ELSEIF (ABS(B1*100.0/B2) .GE. 5.) THEN + !After 20 iterations, >5% from converged + UST_IT_FLG(1) = .FALSE. + UST_IT_FLG(2) = .FALSE. + print*,'Attn: Stress not converged for windspeed: ',UREF + UST = -999. + NO_ERR = .false. + ENDIF + ENDDO + !IF (HeightFLG) THEN + ! ! Get along stress wind at top wave boundary layer (10m) + ! WNDPA=WND_10_mag*COS(WND_10_dir-USTD) + ! WNDPE=WND_10_mag*SIN(WND_10_dir-USTD) + ! ! Calculate Cartesian of across wind + ! WNDPEx=WNDPE*cos(ustd+pi/2.)! add pi/2 since referenced + ! WNDPEy=WNDPE*sin(ustd+pi/2.)! to right of stress angle + ! !Approx as neutral inside 10 m (WBL) calculate z0 + ! wnd_ref_al=uref*cos(urefd-ustd) + ! z0=10. / exp( wnd_10_mag * KAPPA / ustra ) + ! ! Use that z0 to calculate stability + ! ! Cd to ref height (based on input wind) + ! Below is subroutine for computing stability effects + ! call mflux(wnd_ref_al,zwnd,z0,rib,cd) + ! 2. Get CD with stability + ! 3. Get New 35-m wind based on calculated stress Cd from MO + ! WNDPA=ustra/sqrt(cd) + ! WNDPAX=WNDPA*cos(ustd) + ! WNDPAY=WNDPA*sin(ustd) + ! if (wi.eq.3) then + ! u35_1=WNDPAX+WNDPEX + ! v35_1=WNDPAY+WNDPEY + ! elseif (wi.eq.2) then + ! u35_2=WNDPAX+WNDPEX + ! v35_2=WNDPAY+WNDPEY + ! elseif (wi.eq.1) then + ! u35_3=WNDPAX+WNDPEX + ! v35_3=WNDPAY+WNDPEY + ! endif + !ENDIF ENDDO - DO K=NK+1, NKT - DO T=1, NTH - SPC2(K,T)=SPC2(NK,T)*WN(NK)**3.0/WN(K)**(3.0) - ENDDO - ENDDO -! -! 1c. Calculate transitions for new (constant saturation ) tail ------ * -! -!-----Wavenumber for beginning of (spectrum level) transition to tail- * - call sig2wn (FPI*TPI*tail_transition_ratio1,depth,ktaila ) -!-----Wavenumber for end of (spectrum level) transition to tail------- * - call sig2wn (FPI*TPI*tail_transition_ratio2,depth,ktailb ) -!-----Wavenumber for end of (spectrum direction) transition to tail--- * - KTAILC= KTAILB * 2.0 - KA1 = 2 ! Do not modify 1st wavenumber bin - DO WHILE ( ( KTAILA .GE. WN(KA1) ) .AND. (KA1 .LT. NKT-6) ) - KA1 = KA1 + 1 - ENDDO - KA2 = KA1+2 - DO WHILE ( ( KTAILB .GE. WN(KA2) ) .AND. (KA2 .LT. NKT-4) ) - KA2 = KA2 + 1 - ENDDO - KA3 = KA2+2 - DO WHILE ( ( KTAILC .GE. WN(KA3)) .AND. (KA3 .LT. NKT-2) ) - KA3 = KA3 + 1 - ENDDO - CALL APPENDTAIL(SPC2,WN,NKT,KA1,KA2,KA3,atan2(WNDY,WNDX),SAT) - ! Now the spectrum is set w/ tail level SAT -! -! 2. Enter iteration ------------------------------------------------- * -! -! Add new iteration for wind -! - ! Wind perturbations for iteration - !DT = 1.E-04 - !DTX = (/ 1. , -1. , 0. /) - !DTY = (/ 0. , 1. , -1. /) -!/ - HEIGHTFLG=.false.!Not set-up for non-10 m winds - WIFLG = .TRUE. !This kicks out when wind iteration complete - NO_ERR = .TRUE. !This kicks out when there is an error - WI_COUNT = 1 !Count is now counting wind iterations - ! - start of wind iteration (if applicable) - DO WHILE ( WIFLG .AND. NO_ERR ) !Wind iteration - !/ - DO WI = 1, ITTOT !Newton-Raphson solve for derivatives if zwnd not 10 m. - ! If iterating over 10 m wind need to adjust guesses to get slopes - IF (HeightFLG) THEN - WND_10_X = WND_10_X + DTX(WI)*DT - WND_10_Y = WND_10_Y + DTY(WI)*DT - wnd_10_mag = sqrt(wnd_10_x**2+wnd_10_y**2) - wnd_10_dir = atan2(wnd_10_y,wnd_10_x) - ENDIF - ! - ! Stress iteration (inside wind iteration solve for stress) - ITS = 1 !ITS is counting stress iteration - UST_IT_FLG(1)=.TRUE. - UST_IT_FLG(2)=.TRUE. - DO WHILE ((UST_IT_FLG(1) .AND. UST_IT_FLG(2)) .AND. NO_ERR) - !Get z0 from (guessed) stress and wind magnitude - z0 = 10. / ( EXP( KAPPA * wnd_10_mag / USTRA ) ) - TAUINTX(1:NKT) = 0.0 - TAUINTY(1:NKT) = 0.0 - DO K = 1, NKT - !Waves 'feel' wind at height related to wavelength - wnd_z = MIN( PI / WN(K), 20.0 ) - wnd_z_mag = ( USTRA / KAPPA ) * (LOG(wnd_z/Z0)) - DO T = 1, NTH - !projected component of wind in wave direction - wnd_z_proj = wnd_z_mag * COS( wnd_10_dir-TH(T) ) - IF (wnd_z_proj .GT. CP(K)) THEN - !Waves slower than wind - A1 = 0.11 - ELSEIF (( wnd_z_proj .GE. 0 ) .AND. ( wnd_z_proj .LE. CP(K) )) THEN - !Wave faster than wind - A1 = 0.01 - ELSEIF (wnd_z_proj .LT. 0) THEN - !Waves opposed to wind - A1 = 0.1 - ENDIF - wnd_effect = wnd_z_proj - CP(K) - SCIN = A1 * wnd_effect * ABS( wnd_effect ) * DAIR / DWAT * & - WN(K) / CP(K) - ! -- Original version assumed g/Cp = sig,(a.k.a in deep water.) - ! TAUINTX(K) = TAUINTX(K) + SPC2(K,T) * SCIN & - ! * COS( TH(T) ) / CP(K) * DTH - ! TAUINTY(K) = TAUINTY(K) + SPC2(K,T) * SCIN & - ! * SIN( TH(T) ) / CP(K) * DTH - - TAUINTX(K) = TAUINTX(K) + SPC2(K,T) * SCIN & - * COS( TH(T) ) *SIG2(K) * DTH - TAUINTY(K) = TAUINTY(K) + SPC2(K,T) * SCIN & - * SIN( TH(T) ) *SIG2(K) * DTH - ENDDO - ENDDO - TAUYW = 0.0 - TAUXW = 0.0 - DO K = 1, NKT - ! TAUXW = TAUXW + DWAT * GRAV * DWN(K) * TAUINTX(K) - ! TAUYW = TAUYW + DWAT * GRAV * DWN(K) * TAUINTY(K) - TAUXW = TAUXW + DWAT * DWN(K) * TAUINTX(K) - TAUYW = TAUYW + DWAT * DWN(K) * TAUINTY(K) - ENDDO - CDF = ( SQRT(TAUXW**2.0+TAUYW**2.0) / DAIR ) / wnd_10_mag**2.0 - !|---------------------------------------------------------------------| - !|----Solve for the smooth drag coefficient to use as initial guess----| - !|----for the viscous stress-------------------------------------------| - !|---------------------------------------------------------------------| - IF (UREF .LT. 0.01) THEN - USTSM = 0.0 - IterFLAG = .false. - ELSE - Z02 = 0.001 - IterFLAG = .true. - ENDIF - COUNT = 1 - ! Finding smooth z0 to get smooth drag - DO WHILE( (IterFLAG ) .AND. (COUNT .LT. 10) ) - Z01 = Z02 - USTSM = KAPPA * wnd_10_mag / ( LOG( 10. / Z01 ) ) - Z02 = 0.132 * NU / USTSM - IF (ABS( Z02/Z01-1.0) .LT. 10.0**(-4)) THEN - IterFLAG = .false. - ELSE - IterFLAG = .true. - ENDIF - COUNT = COUNT + 1 - ENDDO - CDS = USTSM**2.0 / wnd_10_mag**2.0 - ! smooth drag adjustment based on full drag - CDS = CDS / 3.0 * ( 1.0 + 2.0 * CDS / ( CDS + CDF ) ) - !-----Solve for viscous stress from smooth Cd - TAUNUX = DAIR * CDS * wnd_10_mag**2.0 * COS( wnd_10_dir ) - TAUNUY = DAIR * CDS * wnd_10_mag**2.0 * SIN( wnd_10_dir ) - !-----Sum drag components - TAUX = TAUNUX + TAUXW - TAUY = TAUNUY + TAUYW - !-----Calculate USTAR - USTRB = SQRT( SQRT( TAUY**2.0 + TAUX**2.0) / DAIR ) - !-----Calculate stress direction - ustd = atan2(tauy,taux) - !Checking ustar. ustra=guess. ustrb=found. - B1 = ( USTRA - USTRB ) - B2 = ( USTRA + USTRB ) / 2.0 - ITS = ITS + 1 - !Check for convergence - UST_IT_FLG(1)=( ABS(B1*100.0/B2) .GE. 0.01) - !If not converged after 20 iterations, quit. - UST_IT_FLG(2)=( ITS .LT. 20 ) - IF ( UST_IT_FLG(1) .AND. UST_IT_FLG(2)) THEN - ! Toyed with methods for improving iteration. - ! ultimately this was sufficient. - ! May be imporved upon in future... - USTRA = USTRB*.5 + USTRB*.5 - ELSEIF (ABS(B1*100.0/B2) .GE. 5.) THEN - !After 20 iterations, >5% from converged - UST_IT_FLG(1) = .FALSE. - UST_IT_FLG(2) = .FALSE. - print*,'Attn: Stress not converged for windspeed: ',UREF - UST = -999. - NO_ERR = .false. - ENDIF - ENDDO - !IF (HeightFLG) THEN - ! ! Get along stress wind at top wave boundary layer (10m) - ! WNDPA=WND_10_mag*COS(WND_10_dir-USTD) - ! WNDPE=WND_10_mag*SIN(WND_10_dir-USTD) - ! ! Calculate Cartesian of across wind - ! WNDPEx=WNDPE*cos(ustd+pi/2.)! add pi/2 since referenced - ! WNDPEy=WNDPE*sin(ustd+pi/2.)! to right of stress angle - ! !Approx as neutral inside 10 m (WBL) calculate z0 - ! wnd_ref_al=uref*cos(urefd-ustd) - ! z0=10. / exp( wnd_10_mag * KAPPA / ustra ) - ! ! Use that z0 to calculate stability - ! ! Cd to ref height (based on input wind) - ! Below is subroutine for computing stability effects - ! call mflux(wnd_ref_al,zwnd,z0,rib,cd) - ! 2. Get CD with stability - ! 3. Get New 35-m wind based on calculated stress Cd from MO - ! WNDPA=ustra/sqrt(cd) - ! WNDPAX=WNDPA*cos(ustd) - ! WNDPAY=WNDPA*sin(ustd) - ! if (wi.eq.3) then - ! u35_1=WNDPAX+WNDPEX - ! v35_1=WNDPAY+WNDPEY - ! elseif (wi.eq.2) then - ! u35_2=WNDPAX+WNDPEX - ! v35_2=WNDPAY+WNDPEY - ! elseif (wi.eq.1) then - ! u35_3=WNDPAX+WNDPEX - ! v35_3=WNDPAY+WNDPEY - ! endif - !ENDIF - ENDDO - !IF (HeightFLG) THEN - ! DIFU10xx= u35_3-u35_1 - ! DIFU10yx= v35_3-v35_1 - ! DIFU10xy= u35_2-u35_1 - ! DIFU10yy= v35_2-v35_1 - ! fd_a = difu10xx / DT - ! fd_b = difu10xy / DT - ! fd_c = difu10yx / DT - ! fd_d = difu10yy / DT - ! du = -wndx+u35_1 - ! dv = -wndy+v35_1 - ! uitv= abs(du) - ! vitv=abs(dv) - ! ch=sqrt(uitv*uitv+vitv*vitv) - ! if (ch.gt.10) then - ! apar=0.5/(fd_a*fd_d-fd_b*fd_c) - ! else - ! apar=1.0/(fd_a*fd_d-fd_b*fd_c) - ! endif + !IF (HeightFLG) THEN + ! DIFU10xx= u35_3-u35_1 + ! DIFU10yx= v35_3-v35_1 + ! DIFU10xy= u35_2-u35_1 + ! DIFU10yy= v35_2-v35_1 + ! fd_a = difu10xx / DT + ! fd_b = difu10xy / DT + ! fd_c = difu10yx / DT + ! fd_d = difu10yy / DT + ! du = -wndx+u35_1 + ! dv = -wndy+v35_1 + ! uitv= abs(du) + ! vitv=abs(dv) + ! ch=sqrt(uitv*uitv+vitv*vitv) + ! if (ch.gt.10) then + ! apar=0.5/(fd_a*fd_d-fd_b*fd_c) + ! else + ! apar=1.0/(fd_a*fd_d-fd_b*fd_c) + ! endif - ! Check for wind convergence - ! WND_IT_FLG = (((du**2+dv**2)/(wndx**2+wndy**2)).GT.0.001) - ! - ! IF ( WND_IT_FLG .AND. WI_COUNT.LT.10 ) THEN - ! ! New guesses - ! wnd_10_x=wnd_10_x-apar*( FD_D * DU - FD_B * DV ) - ! wnd_10_y=wnd_10_y-apar*( -FD_C * DU +FD_A * DV ) - ! ELSE - ! wiflg = .FALSE. - ! IF (WI_COUNT .gt. 10 .AND. & - ! ((du**2+dv**2)/(wndx**2+wndy**2)).GT.0.05 ) then - ! print*,'Attn: W3FLD2 Wind error gt 5%' - ! !print*,' Wind y/error: ',wndy,dv - ! !print*,' Wind x/error: ',wndx,du - ! NO_ERR = .false. - ! endif - ! ENDIF - ! WI_COUNT = WI_COUNT + 1 - !ELSE - wiflg=.false. ! If already 10 m wind then complete. - !ENDIF - enddo + ! Check for wind convergence + ! WND_IT_FLG = (((du**2+dv**2)/(wndx**2+wndy**2)).GT.0.001) + ! + ! IF ( WND_IT_FLG .AND. WI_COUNT.LT.10 ) THEN + ! ! New guesses + ! wnd_10_x=wnd_10_x-apar*( FD_D * DU - FD_B * DV ) + ! wnd_10_y=wnd_10_y-apar*( -FD_C * DU +FD_A * DV ) + ! ELSE + ! wiflg = .FALSE. + ! IF (WI_COUNT .gt. 10 .AND. & + ! ((du**2+dv**2)/(wndx**2+wndy**2)).GT.0.05 ) then + ! print*,'Attn: W3FLD2 Wind error gt 5%' + ! !print*,' Wind y/error: ',wndy,dv + ! !print*,' Wind x/error: ',wndx,du + ! NO_ERR = .false. + ! endif + ! ENDIF + ! WI_COUNT = WI_COUNT + 1 + !ELSE + wiflg=.false. ! If already 10 m wind then complete. + !ENDIF + enddo - UST = USTRB - USTD = ATAN2(TAUY, TAUX) - CD = UST**2 / UREF**2 - IF (PRESENT(CHARN)) THEN - CHARN = 0.01/SQRT(SQRT( TAUNUX**2 + TAUNUY**2 )/(UST**2)) - ENDIF - IF (.not.((CD .LT. 0.01).AND.(CD .GT. 0.0005)).or. .not.(NO_ERR)) THEN - !Fail safe to bulk - print*,'Attn: W3FLD2 failed, using bulk stress' - print*,'Calculated Wind/Cd: ',UREF,CD,UST - call wnd2z0m(UREF,Z0) - UST = UREF * kappa / log(zwnd/z0) - CD = UST**2/UREF**2 - USTD = UREFD - ENDIF - DEALLOCATE( TAUINTY , TAUINTX , & - SPC2, sig2, CP , DWN , WN ) - !STOP + UST = USTRB + USTD = ATAN2(TAUY, TAUX) + CD = UST**2 / UREF**2 + IF (PRESENT(CHARN)) THEN + CHARN = 0.01/SQRT(SQRT( TAUNUX**2 + TAUNUY**2 )/(UST**2)) + ENDIF + IF (.not.((CD .LT. 0.01).AND.(CD .GT. 0.0005)).or. .not.(NO_ERR)) THEN + !Fail safe to bulk + print*,'Attn: W3FLD2 failed, using bulk stress' + print*,'Calculated Wind/Cd: ',UREF,CD,UST + call wnd2z0m(UREF,Z0) + UST = UREF * kappa / log(zwnd/z0) + CD = UST**2/UREF**2 + USTD = UREFD + ENDIF + DEALLOCATE( TAUINTY , TAUINTX , & + SPC2, sig2, CP , DWN , WN ) + !STOP -!/ End of W3FLD2 ----------------------------------------------------- / -!/ - RETURN -! - END SUBROUTINE W3FLD2 + !/ End of W3FLD2 ----------------------------------------------------- / + !/ + RETURN + ! + END SUBROUTINE W3FLD2 - SUBROUTINE WND2SAT(WND10,SAT) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | B. G. Reichl | -!/ | FORTRAN 90 | -!/ | Last update : 04-Aug-2016 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-2016 : Origination. ( version 5.12 ) -!/ 05-Aug-2016 : Updated for 2016 HWRF CD/U10 curve ( J. Meixner ) -!/ -! 1. Purpose : -! -! Gives level of saturation spectrum to produce -! equivalent Cd as in wnd2z0m (for neutral 10m wind) -! tuned for method of Donelan et al. 2012 -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- - !Input: WND10 - 10 m neutral wind [m/s] - !Output: SAT - Level 1-d saturation spectrum in tail [non-dim] -! ---------------------------------------------------------------- -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3FLD2 Subr. W3FLD2MD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + SUBROUTINE WND2SAT(WND10,SAT) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | B. G. Reichl | + !/ | FORTRAN 90 | + !/ | Last update : 04-Aug-2016 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-2016 : Origination. ( version 5.12 ) + !/ 05-Aug-2016 : Updated for 2016 HWRF CD/U10 curve ( J. Meixner ) + !/ + ! 1. Purpose : + ! + ! Gives level of saturation spectrum to produce + ! equivalent Cd as in wnd2z0m (for neutral 10m wind) + ! tuned for method of Donelan et al. 2012 + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + !Input: WND10 - 10 m neutral wind [m/s] + !Output: SAT - Level 1-d saturation spectrum in tail [non-dim] + ! ---------------------------------------------------------------- + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3FLD2 Subr. W3FLD2MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE - REAL, INTENT(IN) :: WND10 - REAL, INTENT(OUT) :: SAT + ! + IMPLICIT NONE + REAL, INTENT(IN) :: WND10 + REAL, INTENT(OUT) :: SAT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'WND2SAT') #endif -! -#ifdef W3_S - CALL STRACE (IENT, 'WND2SAT') -#endif -! -! ST2, previous HWRF relationship: -! SAT =0.000000000000349* WND10**6 +& -! -0.000000000250547* WND10**5 +& -! 0.000000039543565* WND10**4 +& -! -0.000002229206185* WND10**3 +& -! 0.000034922624204* WND10**2 +& -! 0.000339117617027* WND10**1 +& -! 0.003521314236550 -! SAT values based on -! HWRF 2016 CD curve, created with fetch limited cases ST4 physics - IF (WND10<20) THEN - SAT = -0.022919753482426e-3* WND10**2 & - +0.960758623686446e-3* WND10 & - -0.084461041915030e-3 - ELSEIF (WND10<45) THEN - SAT = -0.000000006585745* WND10**4 & - +0.000001058147954* WND10**3 & - -0.000065829151883* WND10**2 & - +0.001587028483595* WND10 & - -0.002857112191889 - ELSE - SAT = -0.000178498197241* WND10 & - +0.012706067280674 - ENDIF - SAT = min(max(SAT,0.002),0.014) + ! + ! ST2, previous HWRF relationship: + ! SAT =0.000000000000349* WND10**6 +& + ! -0.000000000250547* WND10**5 +& + ! 0.000000039543565* WND10**4 +& + ! -0.000002229206185* WND10**3 +& + ! 0.000034922624204* WND10**2 +& + ! 0.000339117617027* WND10**1 +& + ! 0.003521314236550 + ! SAT values based on + ! HWRF 2016 CD curve, created with fetch limited cases ST4 physics + IF (WND10<20) THEN + SAT = -0.022919753482426e-3* WND10**2 & + +0.960758623686446e-3* WND10 & + -0.084461041915030e-3 + ELSEIF (WND10<45) THEN + SAT = -0.000000006585745* WND10**4 & + +0.000001058147954* WND10**3 & + -0.000065829151883* WND10**2 & + +0.001587028483595* WND10 & + -0.002857112191889 + ELSE + SAT = -0.000178498197241* WND10 & + +0.012706067280674 + ENDIF + SAT = min(max(SAT,0.002),0.014) - END SUBROUTINE WND2SAT -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / + END SUBROUTINE WND2SAT + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / -!/ -!/ End of module C3FLD2MD -------------------------------------------- / -!/ - END MODULE W3FLD2MD + !/ + !/ End of module C3FLD2MD -------------------------------------------- / + !/ +END MODULE W3FLD2MD diff --git a/model/src/w3fldsmd.F90 b/model/src/w3fldsmd.F90 index 5e14589bd..dbd0dae53 100644 --- a/model/src/w3fldsmd.F90 +++ b/model/src/w3fldsmd.F90 @@ -1,2760 +1,2730 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3FLDSMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | A. Chawla | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 25-Jan-2002 : Data assimilation set up. ( version 2.17 ) -!/ 26-Dec-2002 : Continuously moving grid. ( version 3.02 ) -!/ 04-Sep-2003 : Bug fix W3FLHD. ( version 3.04 ) -!/ 27-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 05-Jul-2005 : Correct first level/ice. ( version 3.07 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 09-Oct-2007 : Make file header optional. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 04-Apr-2010 : Adding icebergs with ISI. ( version 3.14 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLO (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 30-Oct-2012 : Implement tidal analysis ( version 4.08 ) -!/ (F. Ardhuin) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.OF ) -!/ 5-Mar-2012 : Cleanup of tidal analysis ( version 4.09 ) -!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) -!/ (M. Accensi & F. Ardhuin, IFREMER) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ 05-Jun-2018 : adds DEBUGFLS ( version 6.04 ) -!/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Gathers a set of routines to manage input fields of depth, -! current, wind, ice concentration, atmospheric momentum, and -! air density -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3FLDO Subr. Public Open data file. -! W3FLDG Subr. Public. Read/write data file (fields). -! W3FLDD Subr. Public. Read/write data file (data). -! W3FLDP Subr. Public. Generic field interpolation. -! W3FLDH Subr. Public. Process homogeneous fields. -! W3FLDM Subr. Public. Process moving grid data. -! W3FLDTIDE Subr. Public. Read/write tidal constituents -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) -! TICK21 Subr. W3TIMEMD Increment the clock. -! DSEC21 R.F. W3TIMEMD Calculate time differnces. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - By design, these routines do not use the WAVEWATCH III data -! structure. With this approach, they can be used in a straight- -! forward way in other programs to generate WAVEWATCH III input -! data sets directly from such programs. -! -! 6. Switches : -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3FLDO ( INXOUT, IDFLD, NDS, NDST, NDSE, NX, NY, & - GTYPE, IERR, FEXT, FPRE, FHDR, TIDEFLAGIN ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | A. Chawla | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 24-Jan-2001 : Flat grid version (formats only) ( version 2.06 ) -!/ 24-Jan-2002 : Assimilation data added. ( version 2.17 ) -!/ 27-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 09-Oct-2007 : Make file header optional. ( version 3.13 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 04-Apr-2010 : Adding iceberg field. ( version 3.14 ) -!/ 09-Sep-2012 : Implement tidal cons. (F. Ardhuin ) ( version 4.09 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Open and prepare WAVEWATCH III field files as used by the -! generic shell and the field preprocessor. -! -! 2. Method : -! -! The file header contains a general WAVEWATCH III ID string, -! a field ID string and the dimensions of the grid. If a file -! is opened to be read, these parameters are all checked. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ' and 'WRITE'. -! IDFLD C*3 I/O ID string for field type, valid are: 'IC1', -! 'IC2', 'IC3', 'IC4', 'IC5', 'MDN', 'MTH', -! 'MVS', 'LEV', 'CUR', 'WND', 'WNS', 'ICE', -! 'TAU', 'RHO', 'ISI', and 'DTn'. -! NDS Int. I Dataset number for fields file. -! NDST Int. I Dataset number for test output. -! NDSE Int. I Dataset number for error output. -! (No output if NDSE < 0). -! NX, NY Int. I Discrete grid dimensions. \ -! GTYPE Int. I Integer flag indicating type of grid. /a -! NX Int. I/O Record length. \ -! GTYPE Int. I Undefined value. /b -! IERR Int. O Error indicator. -! 0 : No errors. -! 1 : Illegal INXOUT. -! 2 : Illegal ID. -! 3 : Error in opening file. -! 4 : Write error in file. -! 5 : Read error in file. -! 6 : Premature EOF in read. -! 7 : Unexpected file identifier read. -! 8 : Unexpected field identifier read. -! 9 : Unexpected grid dimensions read. -! 10 : Unexpected data info. -! ---------------------------------------------------------------- -! a) for output fields. -! b) for input data. -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_PREP Prog. N/A Input data preprocessor. -! WW3_SHEL Prog. N/A Basic wave model driver. -! ...... Prog. N/A Any other program that reads or -! writes WAVEWATCH III data files. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See end of subroutine. -! -! 7. Remarks : -! -! - On read, the ID 'WND' may be changed to 'WNS' (including -! stability data). -! - On read, the ID 'ICE' may be changed to 'ISI' (including -! iceberg data). -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ +MODULE W3FLDSMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | A. Chawla | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 25-Jan-2002 : Data assimilation set up. ( version 2.17 ) + !/ 26-Dec-2002 : Continuously moving grid. ( version 3.02 ) + !/ 04-Sep-2003 : Bug fix W3FLHD. ( version 3.04 ) + !/ 27-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 05-Jul-2005 : Correct first level/ice. ( version 3.07 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 09-Oct-2007 : Make file header optional. ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 04-Apr-2010 : Adding icebergs with ISI. ( version 3.14 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLO (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 30-Oct-2012 : Implement tidal analysis ( version 4.08 ) + !/ (F. Ardhuin) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.OF ) + !/ 5-Mar-2012 : Cleanup of tidal analysis ( version 4.09 ) + !/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) + !/ (M. Accensi & F. Ardhuin, IFREMER) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ 05-Jun-2018 : adds DEBUGFLS ( version 6.04 ) + !/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Gathers a set of routines to manage input fields of depth, + ! current, wind, ice concentration, atmospheric momentum, and + ! air density + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3FLDO Subr. Public Open data file. + ! W3FLDG Subr. Public. Read/write data file (fields). + ! W3FLDD Subr. Public. Read/write data file (data). + ! W3FLDP Subr. Public. Generic field interpolation. + ! W3FLDH Subr. Public. Process homogeneous fields. + ! W3FLDM Subr. Public. Process moving grid data. + ! W3FLDTIDE Subr. Public. Read/write tidal constituents + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) + ! TICK21 Subr. W3TIMEMD Increment the clock. + ! DSEC21 R.F. W3TIMEMD Calculate time differnces. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - By design, these routines do not use the WAVEWATCH III data + ! structure. With this approach, they can be used in a straight- + ! forward way in other programs to generate WAVEWATCH III input + ! data sets directly from such programs. + ! + ! 6. Switches : + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3FLDO ( INXOUT, IDFLD, NDS, NDST, NDSE, NX, NY, & + GTYPE, IERR, FEXT, FPRE, FHDR, TIDEFLAGIN ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | A. Chawla | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 24-Jan-2001 : Flat grid version (formats only) ( version 2.06 ) + !/ 24-Jan-2002 : Assimilation data added. ( version 2.17 ) + !/ 27-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 09-Oct-2007 : Make file header optional. ( version 3.13 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 04-Apr-2010 : Adding iceberg field. ( version 3.14 ) + !/ 09-Sep-2012 : Implement tidal cons. (F. Ardhuin ) ( version 4.09 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Open and prepare WAVEWATCH III field files as used by the + ! generic shell and the field preprocessor. + ! + ! 2. Method : + ! + ! The file header contains a general WAVEWATCH III ID string, + ! a field ID string and the dimensions of the grid. If a file + ! is opened to be read, these parameters are all checked. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'READ' and 'WRITE'. + ! IDFLD C*3 I/O ID string for field type, valid are: 'IC1', + ! 'IC2', 'IC3', 'IC4', 'IC5', 'MDN', 'MTH', + ! 'MVS', 'LEV', 'CUR', 'WND', 'WNS', 'ICE', + ! 'TAU', 'RHO', 'ISI', and 'DTn'. + ! NDS Int. I Dataset number for fields file. + ! NDST Int. I Dataset number for test output. + ! NDSE Int. I Dataset number for error output. + ! (No output if NDSE < 0). + ! NX, NY Int. I Discrete grid dimensions. \ + ! GTYPE Int. I Integer flag indicating type of grid. /a + ! NX Int. I/O Record length. \ + ! GTYPE Int. I Undefined value. /b + ! IERR Int. O Error indicator. + ! 0 : No errors. + ! 1 : Illegal INXOUT. + ! 2 : Illegal ID. + ! 3 : Error in opening file. + ! 4 : Write error in file. + ! 5 : Read error in file. + ! 6 : Premature EOF in read. + ! 7 : Unexpected file identifier read. + ! 8 : Unexpected field identifier read. + ! 9 : Unexpected grid dimensions read. + ! 10 : Unexpected data info. + ! ---------------------------------------------------------------- + ! a) for output fields. + ! b) for input data. + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_PREP Prog. N/A Input data preprocessor. + ! WW3_SHEL Prog. N/A Basic wave model driver. + ! ...... Prog. N/A Any other program that reads or + ! writes WAVEWATCH III data files. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See end of subroutine. + ! + ! 7. Remarks : + ! + ! - On read, the ID 'WND' may be changed to 'WNS' (including + ! stability data). + ! - On read, the ID 'ICE' may be changed to 'ISI' (including + ! iceberg data). + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE W3ODATMD, only : IAPROC - USE CONSTANTS, ONLY: file_endian + ! + USE W3ODATMD, only : IAPROC + USE CONSTANTS, ONLY: file_endian - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NDST, NDSE, NY - INTEGER, INTENT(INOUT) :: NX - INTEGER, INTENT(OUT) :: IERR - INTEGER, INTENT(INOUT) :: GTYPE - CHARACTER(LEN=3), INTENT(INOUT) :: IDFLD - CHARACTER, INTENT(IN) :: INXOUT*(*) - CHARACTER, INTENT(IN), OPTIONAL :: FEXT*(*), FPRE*(*) - LOGICAL, INTENT(IN), OPTIONAL :: FHDR - INTEGER, INTENT(INOUT), OPTIONAL :: TIDEFLAGIN -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NXT, NYT, GTYPET, I - INTEGER :: FILLER(3) + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NDST, NDSE, NY + INTEGER, INTENT(INOUT) :: NX + INTEGER, INTENT(OUT) :: IERR + INTEGER, INTENT(INOUT) :: GTYPE + CHARACTER(LEN=3), INTENT(INOUT) :: IDFLD + CHARACTER, INTENT(IN) :: INXOUT*(*) + CHARACTER, INTENT(IN), OPTIONAL :: FEXT*(*), FPRE*(*) + LOGICAL, INTENT(IN), OPTIONAL :: FHDR + INTEGER, INTENT(INOUT), OPTIONAL :: TIDEFLAGIN + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NXT, NYT, GTYPET, I + INTEGER :: FILLER(3) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - LOGICAL :: WRITE - CHARACTER(LEN=3) :: TSFLD - CHARACTER(LEN=11) :: FORM = 'UNFORMATTED' - CHARACTER(LEN=13) :: TSSTR, IDSTR = 'WAVEWATCH III' - CHARACTER(LEN=20) :: TEMPXT - CHARACTER(LEN=30) :: FNAME - LOGICAL :: FDHDR = .TRUE. - INTEGER :: TIDEFLAG = 0 - LOGICAL :: TIDEOK = .FALSE. -! -! 'FORM' is used for initial testing of new files only. -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + LOGICAL :: WRITE + CHARACTER(LEN=3) :: TSFLD + CHARACTER(LEN=11) :: FORM = 'UNFORMATTED' + CHARACTER(LEN=13) :: TSSTR, IDSTR = 'WAVEWATCH III' + CHARACTER(LEN=20) :: TEMPXT + CHARACTER(LEN=30) :: FNAME + LOGICAL :: FDHDR = .TRUE. + INTEGER :: TIDEFLAG = 0 + LOGICAL :: TIDEOK = .FALSE. + ! + ! 'FORM' is used for initial testing of new files only. + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLDO') + CALL STRACE (IENT, 'W3FLDO') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, & - NX, NY, GTYPE, IERR + WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, & + NX, NY, GTYPE, IERR #endif -! -! test input parameters ---------------------------------------------- * -! + ! + ! test input parameters ---------------------------------------------- * + ! #ifdef W3_TIDE - TIDEOK = .TRUE. -#endif - FILLER(:)=0 - IF ( PRESENT(TIDEFLAGIN) ) THEN - TIDEFLAG = TIDEFLAGIN - ELSE - TIDEFLAG = 0 - END IF + TIDEOK = .TRUE. +#endif + FILLER(:)=0 + IF ( PRESENT(TIDEFLAGIN) ) THEN + TIDEFLAG = TIDEFLAGIN + ELSE + TIDEFLAG = 0 + END IF - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE') GOTO 801 - IF ( IDFLD.NE.'IC1' .AND. IDFLD.NE.'IC2' .AND. & - IDFLD.NE.'IC3' .AND. IDFLD.NE.'IC4' .AND. & - IDFLD.NE.'IC5' .AND. IDFLD.NE.'MDN' .AND. & - IDFLD.NE.'MTH' .AND. IDFLD.NE.'MVS' .AND. & - IDFLD.NE.'LEV' .AND. IDFLD.NE.'CUR' .AND. & - IDFLD.NE.'WND' .AND. IDFLD.NE.'WNS' .AND. & - IDFLD.NE.'ICE' .AND. IDFLD.NE.'TAU' .AND. & - IDFLD.NE.'RHO' .AND. IDFLD.NE.'DT0' .AND. & - IDFLD.NE.'DT1' .AND. IDFLD.NE.'DT2' .AND. & - IDFLD.NE.'ISI' ) GOTO 802 -! - IF ( PRESENT(FEXT) ) THEN - TEMPXT = FEXT - I = LEN_TRIM(FEXT) - ELSE - TEMPXT = 'ww3' - I = 3 - END IF -! - IF ( PRESENT(FHDR) ) THEN - FDHDR = FHDR - END IF -! -! Set internal variables --------------------------------------------- * -! - IF ( IDFLD.EQ.'LEV' ) THEN - FNAME = 'level.' // TEMPXT(:I) - I = I + 6 - ELSE IF ( IDFLD.EQ.'CUR' ) THEN - FNAME = 'current.' // TEMPXT(:I) - I = I + 8 - ELSE IF ( IDFLD.EQ.'WND' .OR. IDFLD.EQ.'WNS' ) THEN - FNAME = 'wind.' // TEMPXT(:I) - I = I + 5 - ELSE IF ( IDFLD.EQ.'ICE' .OR. IDFLD.EQ.'ISI' ) THEN - FNAME = 'ice.' // TEMPXT(:I) - I = I + 4 - ELSE IF ( IDFLD.EQ.'TAU' ) THEN - FNAME = 'momentum.' // TEMPXT(:I) - I = I + 9 - ELSE IF ( IDFLD.EQ.'RHO' ) THEN - FNAME = 'density.' // TEMPXT(:I) - I = I + 8 - ELSE IF ( IDFLD.EQ.'DT0' ) THEN - FNAME = 'data0.' // TEMPXT(:I) - I = I + 6 - ELSE IF ( IDFLD.EQ.'DT1' ) THEN - FNAME = 'data1.' // TEMPXT(:I) - I = I + 6 - ELSE IF ( IDFLD.EQ.'DT2' ) THEN - FNAME = 'data2.' // TEMPXT(:I) - I = I + 6 - ELSE IF ( IDFLD.EQ.'MDN' ) THEN - FNAME = 'muddens.' // TEMPXT(:I) - I = I + 8 - ELSE IF ( IDFLD.EQ.'MTH' ) THEN - FNAME = 'mudthk.' // TEMPXT(:I) - I = I + 7 - ELSE IF ( IDFLD.EQ.'MVS' ) THEN - FNAME = 'mudvisc.' // TEMPXT(:I) - I = I + 8 - ELSE IF ( IDFLD.EQ.'IC1' ) THEN - FNAME = 'ice1.' // TEMPXT(:I) - I = I + 5 - ELSE IF ( IDFLD.EQ.'IC2' ) THEN - FNAME = 'ice2.' // TEMPXT(:I) - I = I + 5 - ELSE IF ( IDFLD.EQ.'IC3' ) THEN - FNAME = 'ice3.' // TEMPXT(:I) - I = I + 5 - ELSE IF ( IDFLD.EQ.'IC4' ) THEN - FNAME = 'ice4.' // TEMPXT(:I) - I = I + 5 - ELSE IF ( IDFLD.EQ.'IC5' ) THEN - FNAME = 'ice5.' // TEMPXT(:I) - I = I + 5 - END IF -! - WRITE = INXOUT .EQ. 'WRITE' -! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE') GOTO 801 + IF ( IDFLD.NE.'IC1' .AND. IDFLD.NE.'IC2' .AND. & + IDFLD.NE.'IC3' .AND. IDFLD.NE.'IC4' .AND. & + IDFLD.NE.'IC5' .AND. IDFLD.NE.'MDN' .AND. & + IDFLD.NE.'MTH' .AND. IDFLD.NE.'MVS' .AND. & + IDFLD.NE.'LEV' .AND. IDFLD.NE.'CUR' .AND. & + IDFLD.NE.'WND' .AND. IDFLD.NE.'WNS' .AND. & + IDFLD.NE.'ICE' .AND. IDFLD.NE.'TAU' .AND. & + IDFLD.NE.'RHO' .AND. IDFLD.NE.'DT0' .AND. & + IDFLD.NE.'DT1' .AND. IDFLD.NE.'DT2' .AND. & + IDFLD.NE.'ISI' ) GOTO 802 + ! + IF ( PRESENT(FEXT) ) THEN + TEMPXT = FEXT + I = LEN_TRIM(FEXT) + ELSE + TEMPXT = 'ww3' + I = 3 + END IF + ! + IF ( PRESENT(FHDR) ) THEN + FDHDR = FHDR + END IF + ! + ! Set internal variables --------------------------------------------- * + ! + IF ( IDFLD.EQ.'LEV' ) THEN + FNAME = 'level.' // TEMPXT(:I) + I = I + 6 + ELSE IF ( IDFLD.EQ.'CUR' ) THEN + FNAME = 'current.' // TEMPXT(:I) + I = I + 8 + ELSE IF ( IDFLD.EQ.'WND' .OR. IDFLD.EQ.'WNS' ) THEN + FNAME = 'wind.' // TEMPXT(:I) + I = I + 5 + ELSE IF ( IDFLD.EQ.'ICE' .OR. IDFLD.EQ.'ISI' ) THEN + FNAME = 'ice.' // TEMPXT(:I) + I = I + 4 + ELSE IF ( IDFLD.EQ.'TAU' ) THEN + FNAME = 'momentum.' // TEMPXT(:I) + I = I + 9 + ELSE IF ( IDFLD.EQ.'RHO' ) THEN + FNAME = 'density.' // TEMPXT(:I) + I = I + 8 + ELSE IF ( IDFLD.EQ.'DT0' ) THEN + FNAME = 'data0.' // TEMPXT(:I) + I = I + 6 + ELSE IF ( IDFLD.EQ.'DT1' ) THEN + FNAME = 'data1.' // TEMPXT(:I) + I = I + 6 + ELSE IF ( IDFLD.EQ.'DT2' ) THEN + FNAME = 'data2.' // TEMPXT(:I) + I = I + 6 + ELSE IF ( IDFLD.EQ.'MDN' ) THEN + FNAME = 'muddens.' // TEMPXT(:I) + I = I + 8 + ELSE IF ( IDFLD.EQ.'MTH' ) THEN + FNAME = 'mudthk.' // TEMPXT(:I) + I = I + 7 + ELSE IF ( IDFLD.EQ.'MVS' ) THEN + FNAME = 'mudvisc.' // TEMPXT(:I) + I = I + 8 + ELSE IF ( IDFLD.EQ.'IC1' ) THEN + FNAME = 'ice1.' // TEMPXT(:I) + I = I + 5 + ELSE IF ( IDFLD.EQ.'IC2' ) THEN + FNAME = 'ice2.' // TEMPXT(:I) + I = I + 5 + ELSE IF ( IDFLD.EQ.'IC3' ) THEN + FNAME = 'ice3.' // TEMPXT(:I) + I = I + 5 + ELSE IF ( IDFLD.EQ.'IC4' ) THEN + FNAME = 'ice4.' // TEMPXT(:I) + I = I + 5 + ELSE IF ( IDFLD.EQ.'IC5' ) THEN + FNAME = 'ice5.' // TEMPXT(:I) + I = I + 5 + END IF + ! + WRITE = INXOUT .EQ. 'WRITE' + ! #ifdef W3_T - WRITE (NDST,9001) WRITE, FNAME(:I) -#endif -! -! Open file ---------------------------------------------------------- * -! - IF ( WRITE ) THEN - IF ( PRESENT(FPRE) ) THEN - OPEN (NDS,FILE=FPRE//FNAME(:I),FORM=FORM, convert=file_endian, & - ERR=803, IOSTAT=IERR) - ELSE - OPEN (NDS,FILE=FNAME(:I),FORM=FORM,convert=file_endian, & - ERR=803,IOSTAT=IERR) - END IF + WRITE (NDST,9001) WRITE, FNAME(:I) +#endif + ! + ! Open file ---------------------------------------------------------- * + ! + IF ( WRITE ) THEN + IF ( PRESENT(FPRE) ) THEN + OPEN (NDS,FILE=FPRE//FNAME(:I),FORM=FORM, convert=file_endian, & + ERR=803, IOSTAT=IERR) ELSE - IF ( PRESENT(FPRE) ) THEN - OPEN (NDS,FILE=FPRE//FNAME(:I),FORM=FORM,convert=file_endian, & - STATUS='OLD',ERR=803,IOSTAT=IERR) + OPEN (NDS,FILE=FNAME(:I),FORM=FORM,convert=file_endian, & + ERR=803,IOSTAT=IERR) + END IF + ELSE + IF ( PRESENT(FPRE) ) THEN + OPEN (NDS,FILE=FPRE//FNAME(:I),FORM=FORM,convert=file_endian, & + STATUS='OLD',ERR=803,IOSTAT=IERR) + ELSE + OPEN (NDS,FILE=FNAME(:I),FORM=FORM,convert=file_endian, & + STATUS='OLD',ERR=803,IOSTAT=IERR) + END IF + END IF + ! + ! Process test data -------------------------------------------------- * + ! + IF ( WRITE ) THEN + IF ( FDHDR ) THEN + IF ( FORM .EQ. 'UNFORMATTED' ) THEN + ! + ! The "filler" was added for compatibility with old binary forcing files + ! It is now also used for tidal info ... + ! + WRITE (NDS,ERR=804,IOSTAT=IERR) & + IDSTR, IDFLD, NX, NY, GTYPE, FILLER(1:2), TIDEFLAG ELSE - OPEN (NDS,FILE=FNAME(:I),FORM=FORM,convert=file_endian, & - STATUS='OLD',ERR=803,IOSTAT=IERR) + WRITE (NDS,900,ERR=804,IOSTAT=IERR) & + IDSTR, IDFLD, NX, NY, GTYPE, FILLER(1:2), TIDEFLAG END IF END IF -! -! Process test data -------------------------------------------------- * -! - IF ( WRITE ) THEN - IF ( FDHDR ) THEN - IF ( FORM .EQ. 'UNFORMATTED' ) THEN -! -! The "filler" was added for compatibility with old binary forcing files -! It is now also used for tidal info ... -! - WRITE (NDS,ERR=804,IOSTAT=IERR) & - IDSTR, IDFLD, NX, NY, GTYPE, FILLER(1:2), TIDEFLAG - ELSE - WRITE (NDS,900,ERR=804,IOSTAT=IERR) & - IDSTR, IDFLD, NX, NY, GTYPE, FILLER(1:2), TIDEFLAG - END IF - END IF - ELSE - IF ( FORM .EQ. 'UNFORMATTED' ) THEN - READ (NDS,END=806,ERR=805,IOSTAT=IERR) & - TSSTR, TSFLD, NXT, NYT, GTYPET, FILLER(1:2), TIDEFLAG - ELSE - READ (NDS,900,END=806,ERR=805,IOSTAT=IERR) & - TSSTR, TSFLD, NXT, NYT, GTYPET, FILLER(1:2), TIDEFLAG - END IF - IF ((FILLER(1).NE.0.OR.FILLER(2).NE.0).AND.TIDEFLAG.GE.0) TIDEFLAG=0 - IF (TIDEFLAG.NE.0.AND.(.NOT.TIDEOK)) THEN - GOTO 810 - END IF -! - IF ( IDSTR .NE. TSSTR ) GOTO 807 - IF (( IDFLD.EQ.'WND' .AND. TSFLD.EQ.'WNS') .OR. & - ( IDFLD.EQ.'ICE' .AND. TSFLD.EQ.'ISI') ) THEN - IDFLD = TSFLD + ELSE + IF ( FORM .EQ. 'UNFORMATTED' ) THEN + READ (NDS,END=806,ERR=805,IOSTAT=IERR) & + TSSTR, TSFLD, NXT, NYT, GTYPET, FILLER(1:2), TIDEFLAG + ELSE + READ (NDS,900,END=806,ERR=805,IOSTAT=IERR) & + TSSTR, TSFLD, NXT, NYT, GTYPET, FILLER(1:2), TIDEFLAG + END IF + IF ((FILLER(1).NE.0.OR.FILLER(2).NE.0).AND.TIDEFLAG.GE.0) TIDEFLAG=0 + IF (TIDEFLAG.NE.0.AND.(.NOT.TIDEOK)) THEN + GOTO 810 + END IF + ! + IF ( IDSTR .NE. TSSTR ) GOTO 807 + IF (( IDFLD.EQ.'WND' .AND. TSFLD.EQ.'WNS') .OR. & + ( IDFLD.EQ.'ICE' .AND. TSFLD.EQ.'ISI') ) THEN + IDFLD = TSFLD #ifdef W3_T - WRITE (NDST,9002) IDFLD + WRITE (NDST,9002) IDFLD #endif - END IF - IF ( IDFLD .NE. TSFLD ) GOTO 808 - IF ( IDFLD(1:2) .NE. 'DT' ) THEN - IF ( NX.NE.NXT .OR. NY.NE.NYT ) THEN - GOTO 809 - ELSE - NX = NXT - IF (GTYPE.LE.4) GTYPE = GTYPET - END IF - END IF - END IF -! -! File OK ------------------------------------------------------------ * -! - IERR = 0 - IF ( PRESENT(TIDEFLAGIN) ) THEN - TIDEFLAGIN = TIDEFLAG + END IF + IF ( IDFLD .NE. TSFLD ) GOTO 808 + IF ( IDFLD(1:2) .NE. 'DT' ) THEN + IF ( NX.NE.NXT .OR. NY.NE.NYT ) THEN + GOTO 809 + ELSE + NX = NXT + IF (GTYPE.LE.4) GTYPE = GTYPET END IF + END IF + END IF + ! + ! File OK ------------------------------------------------------------ * + ! + IERR = 0 + IF ( PRESENT(TIDEFLAGIN) ) THEN + TIDEFLAGIN = TIDEFLAG + END IF - RETURN -! -! Error escape locations -! - 801 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) INXOUT - IERR = 1 - RETURN -! - 802 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1002) IDFLD - IERR = 2 - RETURN -! - 803 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1003) IDFLD, IERR - IERR = 3 - RETURN -! - 804 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1004) IDFLD, IERR - IERR = 4 - RETURN -! - 805 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1005) IDFLD, IERR - IERR = 5 - RETURN -! - 806 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1006) IDFLD - IERR = 6 - RETURN -! - 807 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1007) TSSTR, IDSTR - IERR = 7 - RETURN -! - 808 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1008) TSFLD, IDFLD - IERR = 8 - RETURN -! - 809 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1009) & - NXT, NYT, GTYPET, & - NX , NY , GTYPE - IERR = 9 - RETURN -! - 810 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1010) & - FILLER(1:2),TIDEFLAG - IERR = 10 - RETURN -! -! Formats -! - 900 FORMAT (1X,A13,1X,A3,6I12) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & - ' ILLEGAL INXOUT STRING : ',A/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & - ' ILLEGAL FIELD ID STRING : ',A/) - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & - ' ERROR IN OPENING ',A,' FILE, IOSTAT =',I6/) - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & - ' ERROR IN WRITING TO ',A,' FILE, IOSTAT =',I6/) - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & - ' ERROR IN READING ',A,' FILE, IOSTAT =',I6/) + RETURN + ! + ! Error escape locations + ! +801 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) INXOUT + IERR = 1 + RETURN + ! +802 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1002) IDFLD + IERR = 2 + RETURN + ! +803 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1003) IDFLD, IERR + IERR = 3 + RETURN + ! +804 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1004) IDFLD, IERR + IERR = 4 + RETURN + ! +805 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1005) IDFLD, IERR + IERR = 5 + RETURN + ! +806 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1006) IDFLD + IERR = 6 + RETURN + ! +807 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1007) TSSTR, IDSTR + IERR = 7 + RETURN + ! +808 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1008) TSFLD, IDFLD + IERR = 8 + RETURN + ! +809 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1009) & + NXT, NYT, GTYPET, & + NX , NY , GTYPE + IERR = 9 + RETURN + ! +810 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1010) & + FILLER(1:2),TIDEFLAG + IERR = 10 + RETURN + ! + ! Formats + ! +900 FORMAT (1X,A13,1X,A3,6I12) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & + ' ILLEGAL INXOUT STRING : ',A/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & + ' ILLEGAL FIELD ID STRING : ',A/) +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & + ' ERROR IN OPENING ',A,' FILE, IOSTAT =',I6/) +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & + ' ERROR IN WRITING TO ',A,' FILE, IOSTAT =',I6/) +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & + ' ERROR IN READING ',A,' FILE, IOSTAT =',I6/) - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & - ' PREMATURE END OF ',A,' FILE'/) - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & - ' ILLEGAL FILE ID STRING >',A,'<'/ & - ' SHOULD BE >',A,'<'/) - 1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & - ' ILLEGAL FIELD ID STRING >',A,'<'/ & - ' SHOULD BE >',A,'<'/) - 1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & + ' PREMATURE END OF ',A,' FILE'/) +1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & + ' ILLEGAL FILE ID STRING >',A,'<'/ & + ' SHOULD BE >',A,'<'/) +1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & + ' ILLEGAL FIELD ID STRING >',A,'<'/ & + ' SHOULD BE >',A,'<'/) +1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & ' INCOMPATIBLE GRID DATA : ',3(1X,I10)/ & - ' SHOULD BE : ',3(1X,I10)/) - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & + ' SHOULD BE : ',3(1X,I10)/) +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDO : '/ & ' FILLER indicates use of tidal constituents',3I4, /& ' For this the code should be compiled with TIDE switch'/) -! + ! #ifdef W3_T - 9000 FORMAT (' TEST W3FLDO : INXOUT : ',A/ & - ' IDFLD : ',A/ & - ' NDS : ',I2/ & - ' NDST : ',I2/ & - ' NDSE : ',I2/ & - ' NX, NY : ',I9,3X,I9/ & - ' GTYPE : ',I2/ & - ' IERR : ',I2) - 9001 FORMAT (' WRITE : ',L2/ & - ' FNAME : [',A,']') - 9002 FORMAT (' NEW IDFLD : ',A) -#endif -!/ -!/ End of W3FLDO ---------------------------------------------------- / -!/ - END SUBROUTINE W3FLDO +9000 FORMAT (' TEST W3FLDO : INXOUT : ',A/ & + ' IDFLD : ',A/ & + ' NDS : ',I2/ & + ' NDST : ',I2/ & + ' NDSE : ',I2/ & + ' NX, NY : ',I9,3X,I9/ & + ' GTYPE : ',I2/ & + ' IERR : ',I2) +9001 FORMAT (' WRITE : ',L2/ & + ' FNAME : [',A,']') +9002 FORMAT (' NEW IDFLD : ',A) +#endif + !/ + !/ End of W3FLDO ---------------------------------------------------- / + !/ + END SUBROUTINE W3FLDO -!/ ------------------------------------------------------------------- / - SUBROUTINE W3FLDTIDE1 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IERR ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 24-Sep-2012 : Creation ( version 4.09 ) -!/ 30-Jun-2013 : Split in 2 subroutines ( version 4.11 ) -!/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Reads and writes tidal consituents -! -! 2. Method : -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ' and 'WRITE'. -! IDFLD C*3 I/O ID string for field type, valid are: -! 'LEV', 'CUR', 'WND', 'WNS', 'ICE', 'ISI', -! 'TAU', 'RHO', and 'DTn'. -! NDS Int. I Dataset number for fields file. -! NDST Int. I Dataset number for test output. -! NDSE Int. I Dataset number for error output. -! (No output if NDSE < 0). -! NX, NY Int. I Discrete grid dimensions. \ -! IERR Int. O Error indicator. -! 0 : No errors. -! 1 : Illegal INXOUT. -! ---------------------------------------------------------------- -! a) for output fields. -! b) for input data. -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_PREP Prog. N/A Input data preprocessor. -! WW3_PRNC Prog. N/A NetCDF input data preprocessor. -! WW3_SHEL Prog. N/A Basic wave model driver. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See end of subroutine. -! -! 7. Remarks : -! -! - On read, the ID 'WND' may be changed to 'WNS' (including -! stability data). -! - On read, the ID 'ICE' may be changed to 'ISI' (including -! iceberg data). -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + !/ ------------------------------------------------------------------- / + SUBROUTINE W3FLDTIDE1 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IERR ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 24-Sep-2012 : Creation ( version 4.09 ) + !/ 30-Jun-2013 : Split in 2 subroutines ( version 4.11 ) + !/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Reads and writes tidal consituents + ! + ! 2. Method : + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'READ' and 'WRITE'. + ! IDFLD C*3 I/O ID string for field type, valid are: + ! 'LEV', 'CUR', 'WND', 'WNS', 'ICE', 'ISI', + ! 'TAU', 'RHO', and 'DTn'. + ! NDS Int. I Dataset number for fields file. + ! NDST Int. I Dataset number for test output. + ! NDSE Int. I Dataset number for error output. + ! (No output if NDSE < 0). + ! NX, NY Int. I Discrete grid dimensions. \ + ! IERR Int. O Error indicator. + ! 0 : No errors. + ! 1 : Illegal INXOUT. + ! ---------------------------------------------------------------- + ! a) for output fields. + ! b) for input data. + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_PREP Prog. N/A Input data preprocessor. + ! WW3_PRNC Prog. N/A NetCDF input data preprocessor. + ! WW3_SHEL Prog. N/A Basic wave model driver. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See end of subroutine. + ! + ! 7. Remarks : + ! + ! - On read, the ID 'WND' may be changed to 'WNS' (including + ! stability data). + ! - On read, the ID 'ICE' may be changed to 'ISI' (including + ! iceberg data). + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! #ifdef W3_TIDE - USE W3TIDEMD -#endif - USE W3IDATMD - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NDST, NDSE, NX, NY - CHARACTER(LEN=3), INTENT(INOUT) :: IDFLD - CHARACTER*(*), INTENT(IN) :: INXOUT - INTEGER, INTENT(OUT) :: IERR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3TIDEMD +#endif + USE W3IDATMD + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NDST, NDSE, NX, NY + CHARACTER(LEN=3), INTENT(INOUT) :: IDFLD + CHARACTER*(*), INTENT(IN) :: INXOUT + INTEGER, INTENT(OUT) :: IERR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - LOGICAL :: WRITE - INTEGER :: I, IX -! -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + LOGICAL :: WRITE + INTEGER :: I, IX + ! + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLDTIDE1') -#endif -! -! test input parameters ---------------------------------------------- * -! - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE') GOTO 801 - IF ( IDFLD.NE.'LEV' .AND. IDFLD.NE.'CUR' .AND. & - IDFLD.NE.'WND' .AND. IDFLD.NE.'WNS' .AND. & - IDFLD.NE.'ICE' .AND. IDFLD.NE.'TAU' .AND. & - IDFLD.NE.'RHO' .AND. IDFLD.NE.'DT0' .AND. & - IDFLD.NE.'DT1' .AND. IDFLD.NE.'DT2' .AND. & - IDFLD.NE.'ISI' ) GOTO 802 - WRITE = INXOUT .EQ. 'WRITE' + CALL STRACE (IENT, 'W3FLDTIDE1') +#endif + ! + ! test input parameters ---------------------------------------------- * + ! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE') GOTO 801 + IF ( IDFLD.NE.'LEV' .AND. IDFLD.NE.'CUR' .AND. & + IDFLD.NE.'WND' .AND. IDFLD.NE.'WNS' .AND. & + IDFLD.NE.'ICE' .AND. IDFLD.NE.'TAU' .AND. & + IDFLD.NE.'RHO' .AND. IDFLD.NE.'DT0' .AND. & + IDFLD.NE.'DT1' .AND. IDFLD.NE.'DT2' .AND. & + IDFLD.NE.'ISI' ) GOTO 802 + WRITE = INXOUT .EQ. 'WRITE' #ifdef W3_TIDE - IF ( WRITE ) THEN - WRITE (NDS,ERR=804,IOSTAT=IERR) & - TIDE_MF - ELSE - READ (NDS,END=806,ERR=805,IOSTAT=IERR) & - TIDE_MF - NTIDE = TIDE_MF - END IF -#endif -! -! -! File OK ------------------------------------------------------------ * -! - IERR = 0 - RETURN -! -! Error escape locations -! - 801 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) INXOUT - IERR = 1 - RETURN -! - 802 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1002) IDFLD - IERR = 2 - RETURN -! - 804 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1004) IDFLD, IERR - IERR = 4 - RETURN -! - 805 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1005) IDFLD, IERR - IERR = 5 - RETURN -! - 806 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1006) IDFLD - IERR = 6 - RETURN -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE1 : '/ & - ' ILLEGAL INXOUT STRING : ',A/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE1 : '/ & - ' ILLEGAL FIELD ID STRING : ',A/) - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE1 : '/ & - ' ERROR IN WRITING TO ',A,' FILE, IOSTAT =',I6/) - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE1 : '/ & - ' ERROR IN READING ',A,' FILE, IOSTAT =',I6/) + IF ( WRITE ) THEN + WRITE (NDS,ERR=804,IOSTAT=IERR) & + TIDE_MF + ELSE + READ (NDS,END=806,ERR=805,IOSTAT=IERR) & + TIDE_MF + NTIDE = TIDE_MF + END IF +#endif + ! + ! + ! File OK ------------------------------------------------------------ * + ! + IERR = 0 + RETURN + ! + ! Error escape locations + ! +801 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) INXOUT + IERR = 1 + RETURN + ! +802 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1002) IDFLD + IERR = 2 + RETURN + ! +804 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1004) IDFLD, IERR + IERR = 4 + RETURN + ! +805 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1005) IDFLD, IERR + IERR = 5 + RETURN + ! +806 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1006) IDFLD + IERR = 6 + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE1 : '/ & + ' ILLEGAL INXOUT STRING : ',A/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE1 : '/ & + ' ILLEGAL FIELD ID STRING : ',A/) +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE1 : '/ & + ' ERROR IN WRITING TO ',A,' FILE, IOSTAT =',I6/) +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE1 : '/ & + ' ERROR IN READING ',A,' FILE, IOSTAT =',I6/) - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE1 : '/ & - ' PREMATURE END OF ',A,' FILE'/) -!/ -!/ End of W3FLDO ---------------------------------------------------- / -!/ - END SUBROUTINE W3FLDTIDE1 +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE1 : '/ & + ' PREMATURE END OF ',A,' FILE'/) + !/ + !/ End of W3FLDO ---------------------------------------------------- / + !/ + END SUBROUTINE W3FLDTIDE1 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3FLDTIDE2 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IDAT, IERR ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 24-Sep-2012 : Creation ( version 4.09 ) -!/ 30-Jun-2013 : Split in 2 subroutines ( version 4.11 ) -!/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Reads and writes tidal constituents -! -! 2. Method : -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ' and 'WRITE'. -! IDFLD C*3 I/O ID string for field type, valid are: -! 'LEV', 'CUR', 'WND', 'WNS', 'ICE', 'ISI', -! 'TAU', 'RHO', and 'DTn'. -! NDS Int. I Dataset number for fields file. -! NDST Int. I Dataset number for test output. -! NDSE Int. I Dataset number for error output. -! (No output if NDSE < 0). -! NX, NY Int. I Discrete grid dimensions. \ -! IDAT Int. I Equal to 1 if W3IDATMD arrays are to be filled -! IERR Int. O Error indicator. -! 0 : No errors. -! 1 : Illegal INXOUT. -! ---------------------------------------------------------------- -! a) for output fields. -! b) for input data. -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_PREP Prog. N/A Input data preprocessor. -! WW3_PRNC Prog. N/A NetCDF input data preprocessor. -! WW3_SHEL Prog. N/A Basic wave model driver. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See end of subroutine. -! -! 7. Remarks : -! -! - On read, the ID 'WND' may be changed to 'WNS' (including -! stability data). -! - On read, the ID 'ICE' may be changed to 'ISI' (including -! iceberg data). -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + !/ ------------------------------------------------------------------- / + SUBROUTINE W3FLDTIDE2 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IDAT, IERR ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 24-Sep-2012 : Creation ( version 4.09 ) + !/ 30-Jun-2013 : Split in 2 subroutines ( version 4.11 ) + !/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Reads and writes tidal constituents + ! + ! 2. Method : + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'READ' and 'WRITE'. + ! IDFLD C*3 I/O ID string for field type, valid are: + ! 'LEV', 'CUR', 'WND', 'WNS', 'ICE', 'ISI', + ! 'TAU', 'RHO', and 'DTn'. + ! NDS Int. I Dataset number for fields file. + ! NDST Int. I Dataset number for test output. + ! NDSE Int. I Dataset number for error output. + ! (No output if NDSE < 0). + ! NX, NY Int. I Discrete grid dimensions. \ + ! IDAT Int. I Equal to 1 if W3IDATMD arrays are to be filled + ! IERR Int. O Error indicator. + ! 0 : No errors. + ! 1 : Illegal INXOUT. + ! ---------------------------------------------------------------- + ! a) for output fields. + ! b) for input data. + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_PREP Prog. N/A Input data preprocessor. + ! WW3_PRNC Prog. N/A NetCDF input data preprocessor. + ! WW3_SHEL Prog. N/A Basic wave model driver. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See end of subroutine. + ! + ! 7. Remarks : + ! + ! - On read, the ID 'WND' may be changed to 'WNS' (including + ! stability data). + ! - On read, the ID 'ICE' may be changed to 'ISI' (including + ! iceberg data). + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! #ifdef W3_TIDE - USE W3TIDEMD -#endif - USE W3IDATMD - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NDST, NDSE, NX, NY, IDAT - CHARACTER(LEN=3), INTENT(INOUT) :: IDFLD - CHARACTER*(*), INTENT(IN) :: INXOUT - INTEGER, INTENT(OUT) :: IERR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3TIDEMD +#endif + USE W3IDATMD + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NDST, NDSE, NX, NY, IDAT + CHARACTER(LEN=3), INTENT(INOUT) :: IDFLD + CHARACTER*(*), INTENT(IN) :: INXOUT + INTEGER, INTENT(OUT) :: IERR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - LOGICAL :: WRITE - INTEGER :: I, IX, TIDE_MF1 - CHARACTER(LEN=100) :: LIST(70) -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + LOGICAL :: WRITE + INTEGER :: I, IX, TIDE_MF1 + CHARACTER(LEN=100) :: LIST(70) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLDTIDE2') -#endif -! -! test input parameters ---------------------------------------------- * -! - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE') GOTO 801 - IF ( IDFLD.NE.'LEV' .AND. IDFLD.NE.'CUR' .AND. & - IDFLD.NE.'WND' .AND. IDFLD.NE.'WNS' .AND. & - IDFLD.NE.'ICE' .AND. IDFLD.NE.'TAU' .AND. & - IDFLD.NE.'RHO' .AND. IDFLD.NE.'DT0' .AND. & - IDFLD.NE.'DT1' .AND. IDFLD.NE.'DT2' .AND. & - IDFLD.NE.'ISI' ) GOTO 802 - WRITE = INXOUT .EQ. 'WRITE' + CALL STRACE (IENT, 'W3FLDTIDE2') +#endif + ! + ! test input parameters ---------------------------------------------- * + ! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE') GOTO 801 + IF ( IDFLD.NE.'LEV' .AND. IDFLD.NE.'CUR' .AND. & + IDFLD.NE.'WND' .AND. IDFLD.NE.'WNS' .AND. & + IDFLD.NE.'ICE' .AND. IDFLD.NE.'TAU' .AND. & + IDFLD.NE.'RHO' .AND. IDFLD.NE.'DT0' .AND. & + IDFLD.NE.'DT1' .AND. IDFLD.NE.'DT2' .AND. & + IDFLD.NE.'ISI' ) GOTO 802 + WRITE = INXOUT .EQ. 'WRITE' #ifdef W3_TIDE - IF ( WRITE ) THEN - WRITE (NDS,ERR=804,IOSTAT=IERR) & - TIDE_FREQC(:),TIDECON_NAME(:),TIDAL_CONST(:,:,:,:,:) - ELSE - IF (.NOT. ALLOCATED(TIDAL_CONST)) ALLOCATE(TIDAL_CONST(NX,NY,TIDE_MF,2,2)) - IF (.NOT. ALLOCATED(TIDE_FREQC)) ALLOCATE(TIDE_FREQC(TIDE_MF)) - IF (.NOT. ALLOCATED(TIDECON_NAMEI)) ALLOCATE(TIDECON_NAMEI(TIDE_MF)) - READ (NDS,END=806,ERR=805,IOSTAT=IERR) & - TIDE_FREQC,TIDECON_NAMEI(:),TIDAL_CONST(:,:,:,:,:) - LIST(:)='' - TIDE_MF1=TIDE_MF - DO I=1,TIDE_MF - LIST(I)=TIDECON_NAMEI(I) - END DO - CALL TIDE_FIND_INDICES_ANALYSIS(LIST) - IF (TIDE_MF1.NE.TIDE_MF) GOTO 807 - CALL TIDE_SET_INDICES - IF(IDFLD.EQ.'LEV') THEN - IF (IDAT.EQ.1) WLTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,1,:) - ELSE - IF (IDAT.EQ.1) CXTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,1,:) - IF (IDAT.EQ.1) CYTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,2,:) - END IF - END IF + IF ( WRITE ) THEN + WRITE (NDS,ERR=804,IOSTAT=IERR) & + TIDE_FREQC(:),TIDECON_NAME(:),TIDAL_CONST(:,:,:,:,:) + ELSE + IF (.NOT. ALLOCATED(TIDAL_CONST)) ALLOCATE(TIDAL_CONST(NX,NY,TIDE_MF,2,2)) + IF (.NOT. ALLOCATED(TIDE_FREQC)) ALLOCATE(TIDE_FREQC(TIDE_MF)) + IF (.NOT. ALLOCATED(TIDECON_NAMEI)) ALLOCATE(TIDECON_NAMEI(TIDE_MF)) + READ (NDS,END=806,ERR=805,IOSTAT=IERR) & + TIDE_FREQC,TIDECON_NAMEI(:),TIDAL_CONST(:,:,:,:,:) + LIST(:)='' + TIDE_MF1=TIDE_MF + DO I=1,TIDE_MF + LIST(I)=TIDECON_NAMEI(I) + END DO + CALL TIDE_FIND_INDICES_ANALYSIS(LIST) + IF (TIDE_MF1.NE.TIDE_MF) GOTO 807 + CALL TIDE_SET_INDICES + IF(IDFLD.EQ.'LEV') THEN + IF (IDAT.EQ.1) WLTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,1,:) + ELSE + IF (IDAT.EQ.1) CXTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,1,:) + IF (IDAT.EQ.1) CYTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,2,:) + END IF + END IF #endif #ifdef W3_TIDET - DO I=1,NTIDE - WRITE(NDST,*) 'Tidal constituents for IX = 1:', IDFLD,' ',TIDECON_NAME(I),TIDAL_CONST(1,1,I,1,1),TIDAL_CONST(1,1,I,1,2), & - '##',TIDAL_CONST(1,1,I,2,1),TIDAL_CONST(1,1,I,2,2) - END DO - DO I=1,NTIDE - WRITE(NDST,*) 'Tidal constituents for IX = 2:', IDFLD,' ',TIDECON_NAME(I),TIDAL_CONST(2,1,I,1,1),TIDAL_CONST(2,1,I,1,2), & - '##',TIDAL_CONST(2,1,I,2,1),TIDAL_CONST(2,1,I,2,2) - END DO - DO IX=1,NX - IF (IDFLD.EQ.'CUR') WRITE (989,'(I10,X,176F10.3)') IX,CXTIDE(IX,1,:,1),CYTIDE(IX,1,:,1), & - CXTIDE(IX,1,:,2),CYTIDE(IX,1,:,2) - END DO - IF (IDFLD.EQ.'CUR') WRITE(988,'(F10.3,/)') CXTIDE(:,1,15,1) - IF (IDFLD.EQ.'CUR') WRITE(988,'(F10.3,/)') CXTIDE(:,1,15,2) -#endif -! -! -! File OK ------------------------------------------------------------ * -! - IERR = 0 - RETURN -! -! Error escape locations -! - 801 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) INXOUT - IERR = 1 - RETURN -! - 802 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1002) IDFLD - IERR = 2 - RETURN -! - 804 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1004) IDFLD, IERR - IERR = 4 - RETURN -! - 805 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1005) IDFLD, IERR - IERR = 5 - RETURN -! - 806 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1006) IDFLD - IERR = 6 - RETURN -! - 807 CONTINUE + DO I=1,NTIDE + WRITE(NDST,*) 'Tidal constituents for IX = 1:', IDFLD,' ',TIDECON_NAME(I),TIDAL_CONST(1,1,I,1,1),TIDAL_CONST(1,1,I,1,2), & + '##',TIDAL_CONST(1,1,I,2,1),TIDAL_CONST(1,1,I,2,2) + END DO + DO I=1,NTIDE + WRITE(NDST,*) 'Tidal constituents for IX = 2:', IDFLD,' ',TIDECON_NAME(I),TIDAL_CONST(2,1,I,1,1),TIDAL_CONST(2,1,I,1,2), & + '##',TIDAL_CONST(2,1,I,2,1),TIDAL_CONST(2,1,I,2,2) + END DO + DO IX=1,NX + IF (IDFLD.EQ.'CUR') WRITE (989,'(I10,X,176F10.3)') IX,CXTIDE(IX,1,:,1),CYTIDE(IX,1,:,1), & + CXTIDE(IX,1,:,2),CYTIDE(IX,1,:,2) + END DO + IF (IDFLD.EQ.'CUR') WRITE(988,'(F10.3,/)') CXTIDE(:,1,15,1) + IF (IDFLD.EQ.'CUR') WRITE(988,'(F10.3,/)') CXTIDE(:,1,15,2) +#endif + ! + ! + ! File OK ------------------------------------------------------------ * + ! + IERR = 0 + RETURN + ! + ! Error escape locations + ! +801 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) INXOUT + IERR = 1 + RETURN + ! +802 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1002) IDFLD + IERR = 2 + RETURN + ! +804 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1004) IDFLD, IERR + IERR = 4 + RETURN + ! +805 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1005) IDFLD, IERR + IERR = 5 + RETURN + ! +806 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1006) IDFLD + IERR = 6 + RETURN + ! +807 CONTINUE #ifdef W3_TIDE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1007) TIDECON_NAMEI(:) -#endif - IERR = 7 - RETURN -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & - ' ILLEGAL INXOUT STRING : ',A/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & - ' ILLEGAL FIELD ID STRING : ',A/) - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & - ' ERROR IN WRITING TO ',A,' FILE, IOSTAT =',I6/) - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & - ' ERROR IN READING ',A,' FILE, IOSTAT =',I6/) - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & - ' PREMATURE END OF ',A,' FILE'/) + IF ( NDSE .GE. 0 ) WRITE (NDSE,1007) TIDECON_NAMEI(:) +#endif + IERR = 7 + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & + ' ILLEGAL INXOUT STRING : ',A/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & + ' ILLEGAL FIELD ID STRING : ',A/) +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & + ' ERROR IN WRITING TO ',A,' FILE, IOSTAT =',I6/) +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & + ' ERROR IN READING ',A,' FILE, IOSTAT =',I6/) +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & + ' PREMATURE END OF ',A,' FILE'/) #ifdef W3_TIDE - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & - ' TIDAL CONSTITUENTS NOT RECOGNIZED ',A /) +1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & + ' TIDAL CONSTITUENTS NOT RECOGNIZED ',A /) #endif -!/ -!/ End of W3FLDO ---------------------------------------------------- / -!/ - END SUBROUTINE W3FLDTIDE2 + !/ + !/ End of W3FLDO ---------------------------------------------------- / + !/ + END SUBROUTINE W3FLDTIDE2 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & - NX, NY, T0, TN, TF0, FX0, FY0, FA0, & - TFN, FXN, FYN, FAN, IERR, FLAGSC & + !/ ------------------------------------------------------------------- / + SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & + NX, NY, T0, TN, TF0, FX0, FY0, FA0, & + TFN, FXN, FYN, FAN, IERR, FLAGSC & #ifdef W3_OASIS - , COUPL_COMM & -#endif - ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Aug-2021 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 05-Jul-2005 : Correct first level/ice. ( version 3.07 ) -!/ 04-Apr-2010 : Adding icebergs in ISI ( version 3.14 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) -!/ (M. Accensi & F. Ardhuin, IFREMER) -!/ 25-Sep-2020 : Receive coupled fields at T+0 ( version 7.10 ) -!/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) -!/ 13-Aug-2021 : Allow scalar fields to be time ( version 7.14 ) -!/ interpolated -!/ -! 1. Purpose : -! -! Update input fields in the WAVEWATCH III generic shell from a -! WAVEWATCH III shell data file or write from preprocessor. -! -! 2. Method : -! -! Read from file opened by W3FLDO. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ' and 'WRITE'. -! IDFLD C*3 I ID string for field type, valid are: 'IC1', -! 'IC2', 'IC3', 'IC4', 'IC5', 'MDN', 'MTH', 'MVS', -! 'LEV', 'CUR', 'WND', 'WNS', 'ICE', 'ISI', -! 'TAU', and 'RHO'. -! NDS Int. I Dataset number for fields file. -! NDST Int. I Dataset number for test output. -! NDSE Int. I Dataset number for error output. -! (No error output if NDSE < 0 ). -! MX,MY Int. I Array dimensions output fields. -! NX,NY Int. I Discrete grid dimensions. -! T0-N I.A. I Time interval considered (dummy for write). -! TF0-N I.A. I/O Field times (TFN dummy for write). -! Fxx R.A. I/O Input fields (FxN dummy for write). -! subtypes: FX0, FY0, FA0, FXN, FYN, FAN -! (meaning is inferred from context as follows) -! "0" denotes "prior time level" -! "N" denotes "next time level" -! "X" denotes x in a vector -! "Y" denotes y in a vector -! "A" denotes scalar -! IERR Int. O Error indicator, -! -1 Past last data -! 0 OK, -! 1 : Illegal INXOUT. -! 2 : Illegal IDFLD. -! 3 : Error in writing time. -! 4 : Error in writing field. -! 5 : Error in reading time. -! 6 : Premature EOF reading field. -! 7 : Error reading field. -! FLAGSC Log. I/O Flag for coupling field -! COUPL_COMM Int. I MPI communicator for coupling -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. Id. Subroutine tracing. -! TICK21 Subr. W3TIMEMD Advance time. -! DSEC21 Func. Id. Difference between times. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_PREP Prog. N/A Input data preprocessor. -! WW3_SHEL Prog. N/A Basic wave model driver. -! ...... Prog. N/A Any other program that reads or -! writes WAVEWATCH III data files. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See end of subroutine. -! -! 7. Remarks : -! -! - Saving of previous fields needed only for reading of 2-D fields. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + , COUPL_COMM & +#endif + ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Aug-2021 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 05-Jul-2005 : Correct first level/ice. ( version 3.07 ) + !/ 04-Apr-2010 : Adding icebergs in ISI ( version 3.14 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) + !/ (M. Accensi & F. Ardhuin, IFREMER) + !/ 25-Sep-2020 : Receive coupled fields at T+0 ( version 7.10 ) + !/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) + !/ 13-Aug-2021 : Allow scalar fields to be time ( version 7.14 ) + !/ interpolated + !/ + ! 1. Purpose : + ! + ! Update input fields in the WAVEWATCH III generic shell from a + ! WAVEWATCH III shell data file or write from preprocessor. + ! + ! 2. Method : + ! + ! Read from file opened by W3FLDO. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'READ' and 'WRITE'. + ! IDFLD C*3 I ID string for field type, valid are: 'IC1', + ! 'IC2', 'IC3', 'IC4', 'IC5', 'MDN', 'MTH', 'MVS', + ! 'LEV', 'CUR', 'WND', 'WNS', 'ICE', 'ISI', + ! 'TAU', and 'RHO'. + ! NDS Int. I Dataset number for fields file. + ! NDST Int. I Dataset number for test output. + ! NDSE Int. I Dataset number for error output. + ! (No error output if NDSE < 0 ). + ! MX,MY Int. I Array dimensions output fields. + ! NX,NY Int. I Discrete grid dimensions. + ! T0-N I.A. I Time interval considered (dummy for write). + ! TF0-N I.A. I/O Field times (TFN dummy for write). + ! Fxx R.A. I/O Input fields (FxN dummy for write). + ! subtypes: FX0, FY0, FA0, FXN, FYN, FAN + ! (meaning is inferred from context as follows) + ! "0" denotes "prior time level" + ! "N" denotes "next time level" + ! "X" denotes x in a vector + ! "Y" denotes y in a vector + ! "A" denotes scalar + ! IERR Int. O Error indicator, + ! -1 Past last data + ! 0 OK, + ! 1 : Illegal INXOUT. + ! 2 : Illegal IDFLD. + ! 3 : Error in writing time. + ! 4 : Error in writing field. + ! 5 : Error in reading time. + ! 6 : Premature EOF reading field. + ! 7 : Error reading field. + ! FLAGSC Log. I/O Flag for coupling field + ! COUPL_COMM Int. I MPI communicator for coupling + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. Id. Subroutine tracing. + ! TICK21 Subr. W3TIMEMD Advance time. + ! DSEC21 Func. Id. Difference between times. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_PREP Prog. N/A Input data preprocessor. + ! WW3_SHEL Prog. N/A Basic wave model driver. + ! ...... Prog. N/A Any other program that reads or + ! writes WAVEWATCH III data files. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See end of subroutine. + ! + ! 7. Remarks : + ! + ! - Saving of previous fields needed only for reading of 2-D fields. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3TIMEMD + USE W3TIMEMD #ifdef W3_OASIS - USE W3OACPMD, ONLY: ID_OASIS_TIME, CPLT0 + USE W3OACPMD, ONLY: ID_OASIS_TIME, CPLT0 #endif #ifdef W3_OASACM - USE W3AGCMMD, ONLY: RCV_FIELDS_FROM_ATMOS + USE W3AGCMMD, ONLY: RCV_FIELDS_FROM_ATMOS #endif #ifdef W3_OASOCM - USE W3OGCMMD, ONLY: RCV_FIELDS_FROM_OCEAN + USE W3OGCMMD, ONLY: RCV_FIELDS_FROM_OCEAN #endif #ifdef W3_OASICM - USE W3IGCMMD, ONLY: RCV_FIELDS_FROM_ICE + USE W3IGCMMD, ONLY: RCV_FIELDS_FROM_ICE #endif #ifdef W3_OASIS - USE W3ODATMD, ONLY: DTOUT -#endif - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NDST, NDSE, MX, MY, & - NX, NY, T0(2), TN(2) - INTEGER, INTENT(INOUT) :: TF0(2), TFN(2) - INTEGER, INTENT(OUT) :: IERR - REAL, INTENT(INOUT) :: FX0(MX,MY), FY0(MX,MY), & - FXN(MX,MY), FYN(MX,MY), & - FA0(MX,MY), FAN(MX,MY) - CHARACTER, INTENT(IN) :: INXOUT*(*) - CHARACTER(LEN=3), INTENT(IN) :: IDFLD - LOGICAL, INTENT(INOUT), OPTIONAL :: FLAGSC + USE W3ODATMD, ONLY: DTOUT +#endif + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NDST, NDSE, MX, MY, & + NX, NY, T0(2), TN(2) + INTEGER, INTENT(INOUT) :: TF0(2), TFN(2) + INTEGER, INTENT(OUT) :: IERR + REAL, INTENT(INOUT) :: FX0(MX,MY), FY0(MX,MY), & + FXN(MX,MY), FYN(MX,MY), & + FA0(MX,MY), FAN(MX,MY) + CHARACTER, INTENT(IN) :: INXOUT*(*) + CHARACTER(LEN=3), INTENT(IN) :: IDFLD + LOGICAL, INTENT(INOUT), OPTIONAL :: FLAGSC #ifdef W3_OASIS - INTEGER, INTENT(IN), OPTIONAL :: COUPL_COMM + INTEGER, INTENT(IN), OPTIONAL :: COUPL_COMM #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IX, IY, J, ISTAT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IX, IY, J, ISTAT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: DTTST - LOGICAL :: WRITE, FL2D, FLFRST, FLBE, FLST, & - FLINTERP, FLCOUPL - LOGICAL, PARAMETER :: FLAGSC_DEFAULT = .FALSE. -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: DTTST + LOGICAL :: WRITE, FL2D, FLFRST, FLBE, FLST, & + FLINTERP, FLCOUPL + LOGICAL, PARAMETER :: FLAGSC_DEFAULT = .FALSE. + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLDG') + CALL STRACE (IENT, 'W3FLDG') #endif -!/ - IERR = 0 -! + !/ + IERR = 0 + ! #ifdef W3_T - WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & - NX, NY, TF0, TFN, IERR -#endif -! -! test input parameters ---------------------------------------------- * -! - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE') GOTO 801 - IF ( IDFLD.NE.'IC1' .AND. IDFLD.NE.'IC2' .AND. & - IDFLD.NE.'IC3' .AND. IDFLD.NE.'IC4' .AND. & - IDFLD.NE.'IC5' .AND. IDFLD.NE.'MDN' .AND. & - IDFLD.NE.'MTH' .AND. IDFLD.NE.'MVS' .AND. & - IDFLD.NE.'LEV' .AND. IDFLD.NE.'CUR' .AND. & - IDFLD.NE.'WND' .AND. IDFLD.NE.'WNS' .AND. & - IDFLD.NE.'ICE' .AND. IDFLD.NE.'ISI' .AND. & - IDFLD.NE.'TAU' .AND. IDFLD.NE.'RHO' ) GOTO 802 -! -! Set internal variables --------------------------------------------- * -! - WRITE = INXOUT .EQ. 'WRITE' - FL2D = IDFLD.EQ.'CUR' .OR. IDFLD.EQ.'WND' .OR. IDFLD.EQ.'WNS' & - .OR. IDFLD.EQ.'ISI' .OR. IDFLD.EQ.'TAU' - FLBE = IDFLD.EQ.'ISI' - FLST = IDFLD.EQ.'WNS' + WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & + NX, NY, TF0, TFN, IERR +#endif + ! + ! test input parameters ---------------------------------------------- * + ! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE') GOTO 801 + IF ( IDFLD.NE.'IC1' .AND. IDFLD.NE.'IC2' .AND. & + IDFLD.NE.'IC3' .AND. IDFLD.NE.'IC4' .AND. & + IDFLD.NE.'IC5' .AND. IDFLD.NE.'MDN' .AND. & + IDFLD.NE.'MTH' .AND. IDFLD.NE.'MVS' .AND. & + IDFLD.NE.'LEV' .AND. IDFLD.NE.'CUR' .AND. & + IDFLD.NE.'WND' .AND. IDFLD.NE.'WNS' .AND. & + IDFLD.NE.'ICE' .AND. IDFLD.NE.'ISI' .AND. & + IDFLD.NE.'TAU' .AND. IDFLD.NE.'RHO' ) GOTO 802 + ! + ! Set internal variables --------------------------------------------- * + ! + WRITE = INXOUT .EQ. 'WRITE' + FL2D = IDFLD.EQ.'CUR' .OR. IDFLD.EQ.'WND' .OR. IDFLD.EQ.'WNS' & + .OR. IDFLD.EQ.'ISI' .OR. IDFLD.EQ.'TAU' + FLBE = IDFLD.EQ.'ISI' + FLST = IDFLD.EQ.'WNS' - IF ( .NOT. PRESENT(FLAGSC) ) THEN - FLCOUPL=FLAGSC_DEFAULT - ELSE - FLCOUPL=FLAGSC - END IF + IF ( .NOT. PRESENT(FLAGSC) ) THEN + FLCOUPL=FLAGSC_DEFAULT + ELSE + FLCOUPL=FLAGSC + END IF -! this flag is necessary to define the field at the start and end time -! of integration for the first time step which is integrated on 0 -! to be able to output integrated variables like cha, ust, taw + ! this flag is necessary to define the field at the start and end time + ! of integration for the first time step which is integrated on 0 + ! to be able to output integrated variables like cha, ust, taw - FLINTERP = IDFLD.EQ.'CUR' .OR. IDFLD.EQ.'WND' .OR. IDFLD.EQ.'WNS' & - .OR. IDFLD.EQ.'TAU' .OR. IDFLD.EQ.'RHO' -! if the model is coupled, no interpolation in time must be done + FLINTERP = IDFLD.EQ.'CUR' .OR. IDFLD.EQ.'WND' .OR. IDFLD.EQ.'WNS' & + .OR. IDFLD.EQ.'TAU' .OR. IDFLD.EQ.'RHO' + ! if the model is coupled, no interpolation in time must be done - IF (FLCOUPL) FLINTERP = .FALSE. + IF (FLCOUPL) FLINTERP = .FALSE. - FLFRST = TFN(1) .EQ. -1 -! + FLFRST = TFN(1) .EQ. -1 + ! #ifdef W3_T - WRITE (NDST,9001) WRITE, FL2D, FLBE, FLST, FLFRST -#endif -! -! Loop over times / fields ========================================== * -! - DO -! -! Shift fields (interpolated fields only) -! - IF ( (.NOT.WRITE) .AND. FLINTERP ) THEN -! - TF0(1) = TFN(1) - TF0(2) = TFN(2) + WRITE (NDST,9001) WRITE, FL2D, FLBE, FLST, FLFRST +#endif + ! + ! Loop over times / fields ========================================== * + ! + DO + ! + ! Shift fields (interpolated fields only) + ! + IF ( (.NOT.WRITE) .AND. FLINTERP ) THEN + ! + TF0(1) = TFN(1) + TF0(2) = TFN(2) #ifdef W3_T - WRITE (NDST,9020) -#endif -! unless TFN has been changed in the do loop, the following line is essentally -! "if not.flfrst" - IF ( TFN(1) .NE. -1 ) THEN - DO IX=1, NX - DO IY=1, NY - FX0(IX,IY) = FXN(IX,IY) - IF (FL2D) FY0(IX,IY) = FYN(IX,IY) - END DO - IF( FLST .OR. .NOT.FL2D ) THEN - DO IY=1, NY - FA0(IX,IY) = FAN(IX,IY) - END DO - END IF - END DO + WRITE (NDST,9020) +#endif + ! unless TFN has been changed in the do loop, the following line is essentally + ! "if not.flfrst" + IF ( TFN(1) .NE. -1 ) THEN + DO IX=1, NX + DO IY=1, NY + FX0(IX,IY) = FXN(IX,IY) + IF (FL2D) FY0(IX,IY) = FYN(IX,IY) + END DO + IF( FLST .OR. .NOT.FL2D ) THEN + DO IY=1, NY + FA0(IX,IY) = FAN(IX,IY) + END DO + END IF + END DO #ifdef W3_T - ELSE - WRITE (NDST,9021) + ELSE + WRITE (NDST,9021) #endif - END IF -! - END IF + END IF + ! + END IF -! -! Process fields, write --------------------------------------------- * -! - IF ( WRITE ) THEN -! + ! + ! Process fields, write --------------------------------------------- * + ! + IF ( WRITE ) THEN + ! #ifdef W3_T - WRITE (NDST,9030) TF0 + WRITE (NDST,9030) TF0 #endif - WRITE (NDS,ERR=803,IOSTAT=ISTAT) TF0 - IF ( .NOT. FL2D ) THEN - J = 1 - WRITE (NDS,ERR=804,IOSTAT=ISTAT) & - ((FA0(IX,IY),IX=1,NX),IY=1,NY) - ELSE - J = 1 - WRITE (NDS,ERR=804,IOSTAT=ISTAT) & - ((FX0(IX,IY),IX=1,NX),IY=1,NY) - J = 2 - WRITE (NDS,ERR=804,IOSTAT=ISTAT) & - ((FY0(IX,IY),IX=1,NX),IY=1,NY) - J = 3 - IF ( FLST ) WRITE (NDS,ERR=804,IOSTAT=ISTAT) & - ((FA0(IX,IY),IX=1,NX),IY=1,NY) - END IF -! - EXIT -! -! Process fields, read ---------------------------------------------- * -! - ELSE -! + WRITE (NDS,ERR=803,IOSTAT=ISTAT) TF0 + IF ( .NOT. FL2D ) THEN + J = 1 + WRITE (NDS,ERR=804,IOSTAT=ISTAT) & + ((FA0(IX,IY),IX=1,NX),IY=1,NY) + ELSE + J = 1 + WRITE (NDS,ERR=804,IOSTAT=ISTAT) & + ((FX0(IX,IY),IX=1,NX),IY=1,NY) + J = 2 + WRITE (NDS,ERR=804,IOSTAT=ISTAT) & + ((FY0(IX,IY),IX=1,NX),IY=1,NY) + J = 3 + IF ( FLST ) WRITE (NDS,ERR=804,IOSTAT=ISTAT) & + ((FA0(IX,IY),IX=1,NX),IY=1,NY) + END IF + ! + EXIT + ! + ! Process fields, read ---------------------------------------------- * + ! + ELSE + ! #ifdef W3_OASIS - IF (FLCOUPL) THEN - ! Do not receive coupling fields at the end of the first integration time in case of - ! forcing with a non interpolated field (like lev, ice, ...) - IF ( (ID_OASIS_TIME.EQ.0 .AND. ( FLFRST .OR. CPLT0 )) .OR. & - (ID_OASIS_TIME.GT.0)) THEN + IF (FLCOUPL) THEN + ! Do not receive coupling fields at the end of the first integration time in case of + ! forcing with a non interpolated field (like lev, ice, ...) + IF ( (ID_OASIS_TIME.EQ.0 .AND. ( FLFRST .OR. CPLT0 )) .OR. & + (ID_OASIS_TIME.GT.0)) THEN #endif -! + ! #ifdef W3_OASACM - ! Getting U10 (FXN) and V10 (FYN) from atmospheric model - CALL RCV_FIELDS_FROM_ATMOS(COUPL_COMM, & - IDFLD, FXN, FYN, FAN) + ! Getting U10 (FXN) and V10 (FYN) from atmospheric model + CALL RCV_FIELDS_FROM_ATMOS(COUPL_COMM, & + IDFLD, FXN, FYN, FAN) #endif #ifdef W3_OASOCM - ! Getting UCUR (CX), VCUR (CY), WLV from ocean model - CALL RCV_FIELDS_FROM_OCEAN(COUPL_COMM, & - IDFLD, FXN, FYN, FAN) + ! Getting UCUR (CX), VCUR (CY), WLV from ocean model + CALL RCV_FIELDS_FROM_OCEAN(COUPL_COMM, & + IDFLD, FXN, FYN, FAN) #endif #ifdef W3_OASICM - ! Getting ICEF from ice model - CALL RCV_FIELDS_FROM_ICE(COUPL_COMM, & - IDFLD, FXN, FYN, FAN) + ! Getting ICEF from ice model + CALL RCV_FIELDS_FROM_ICE(COUPL_COMM, & + IDFLD, FXN, FYN, FAN) #endif #ifdef W3_OASIS - ! Increment the time field TFN to the next coupling time - TFN(1)=T0(1) - TFN(2)=T0(2) - CALL TICK21(TFN,DTOUT(7)) - END IF - ELSE -#endif - READ (NDS,END=800,ERR=805,IOSTAT=ISTAT) TFN + ! Increment the time field TFN to the next coupling time + TFN(1)=T0(1) + TFN(2)=T0(2) + CALL TICK21(TFN,DTOUT(7)) + END IF + ELSE +#endif + READ (NDS,END=800,ERR=805,IOSTAT=ISTAT) TFN #ifdef W3_T - WRITE (NDST,9031) TFN -#endif - IF ( .NOT. FL2D ) THEN -! note: "J" here does *not* refer to data type, wlev etc. -! It refers to the dimension. - J = 1 - READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) & - ((FAN(IX,IY),IX=1,NX),IY=1,NY) - ELSE - J = 1 - READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) & - ((FXN(IX,IY),IX=1,NX),IY=1,NY) - J = 2 - READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) & - ((FYN(IX,IY),IX=1,NX),IY=1,NY) + WRITE (NDST,9031) TFN +#endif + IF ( .NOT. FL2D ) THEN + ! note: "J" here does *not* refer to data type, wlev etc. + ! It refers to the dimension. + J = 1 + READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) & + ((FAN(IX,IY),IX=1,NX),IY=1,NY) + ELSE + J = 1 + READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) & + ((FXN(IX,IY),IX=1,NX),IY=1,NY) + J = 2 + READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) & + ((FYN(IX,IY),IX=1,NX),IY=1,NY) -! this was added for ISI files to store ICE in FAN and BERG in FYN + ! this was added for ISI files to store ICE in FAN and BERG in FYN - IF (FLBE) FAN(:,:) = FXN(:,:) + IF (FLBE) FAN(:,:) = FXN(:,:) -! this was added for WNS files to store WND in FXN & FYN and AST in FAN + ! this was added for WNS files to store WND in FXN & FYN and AST in FAN - J = 3 - IF ( FLST ) READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) & - ((FAN(IX,IY),IX=1,NX),IY=1,NY) - END IF + J = 3 + IF ( FLST ) READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) & + ((FAN(IX,IY),IX=1,NX),IY=1,NY) + END IF #ifdef W3_OASIS - END IF + END IF #endif -! -! Check time, branch back if necessary -! - DTTST = DSEC21 ( T0 , TFN ) + ! + ! Check time, branch back if necessary + ! + DTTST = DSEC21 ( T0 , TFN ) -! Exit if the time is the first time and the field is not interpolated in time + ! Exit if the time is the first time and the field is not interpolated in time - IF ( .NOT.FLINTERP .AND. FLFRST .AND. DTTST .EQ. 0. ) EXIT + IF ( .NOT.FLINTERP .AND. FLFRST .AND. DTTST .EQ. 0. ) EXIT -! Exit if the time of the input field is larger than the current time + ! Exit if the time of the input field is larger than the current time - IF ( DTTST .GT. 0. ) EXIT -! - END IF -! - END DO -! -! Branch point for EOF and interpolated fields (forcing current, wind or winds) -! - 300 CONTINUE + IF ( DTTST .GT. 0. ) EXIT + ! + END IF + ! + END DO + ! + ! Branch point for EOF and interpolated fields (forcing current, wind or winds) + ! +300 CONTINUE -! If the field is interpolated in time and the start time of interpolation is not set -! save the time and field values at the start time and field of interpolation + ! If the field is interpolated in time and the start time of interpolation is not set + ! save the time and field values at the start time and field of interpolation - IF ( .NOT.WRITE .AND. FLINTERP .AND. TF0(1) .EQ. -1 ) THEN -! -#ifdef W3_T - WRITE (NDST,9040) -#endif - TF0(1) = T0(1) - TF0(2) = T0(2) -! - DO IX=1, NX - DO IY=1, NY - FX0(IX,IY) = FXN(IX,IY) - IF (FL2D) FY0(IX,IY) = FYN(IX,IY) - END DO - IF( FLST .OR. .NOT.FL2D ) THEN - DO IY=1, NY - FA0(IX,IY) = FAN(IX,IY) - END DO - END IF - END DO -! - END IF -! -! Branch point for EOF and not interpolated fields (coupled fields, ice, lev, ...) -! - 500 CONTINUE -! + IF ( .NOT.WRITE .AND. FLINTERP .AND. TF0(1) .EQ. -1 ) THEN + ! #ifdef W3_T - IF ( FLINTERP ) THEN - WRITE (NDST,9041) TF0, TFN - ELSE - WRITE (NDST,9042) TFN - END IF -#endif -! -! Process fields, end ----------------------------------------------- * -! - RETURN -! -! EOF escape location (have read to end of file) -! - 800 CONTINUE - IERR = -1 -! - IF ( FLINTERP ) THEN - TFN(1) = TN(1) - TFN(2) = TN(2) - CALL TICK21 ( TFN , 1. ) - END IF -#ifdef W3_T - WRITE (NDST,9032) TFN, IERR -#endif -! - IF ( FLINTERP ) THEN - GOTO 300 - ELSE - GOTO 500 + WRITE (NDST,9040) +#endif + TF0(1) = T0(1) + TF0(2) = T0(2) + ! + DO IX=1, NX + DO IY=1, NY + FX0(IX,IY) = FXN(IX,IY) + IF (FL2D) FY0(IX,IY) = FYN(IX,IY) + END DO + IF( FLST .OR. .NOT.FL2D ) THEN + DO IY=1, NY + FA0(IX,IY) = FAN(IX,IY) + END DO END IF -! -! -! Error escape locations -! - 801 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) INXOUT - IERR = 1 - RETURN -! - 802 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1002) IDFLD - IERR = 2 - RETURN -! - 803 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1003) ISTAT - IERR = 3 - RETURN -! - 804 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1004) J, ISTAT - IERR = 4 - RETURN -! - 805 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1005) ISTAT - IERR = 5 - RETURN -! - 806 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1006) J, ISTAT - IERR = 6 - RETURN -! - 807 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1007) J, ISTAT - IERR = 7 - RETURN -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & - ' ILLEGAL INXOUT STRING : ',A/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & - ' ILLEGAL FIELD ID STRING : ',A/) - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & - ' ERROR IN WRITING TIME, IOSTAT =',I6/) - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & - ' ERROR IN WRITING FIELD ',I1,', IOSTAT =',I6/) - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & - ' ERROR IN READING TIME, IOSTAT =',I6/) - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & - ' PRMATURE EOF READING FIELD ',I1,', IOSTAT =',I6/) - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & - ' ERROR IN READING FIELD ',I1,', IOSTAT =',I6/) -! + END DO + ! + END IF + ! + ! Branch point for EOF and not interpolated fields (coupled fields, ice, lev, ...) + ! +500 CONTINUE + ! #ifdef W3_T - 9000 FORMAT (' TEST W3FLDG : INXOUT : ',A/ & - ' IDFLD : ',A/ & - ' NDS(T/E) :',3I4/ & - ' MX, MY :',2I8/ & - ' NX, NY :',2I8/ & - ' TF0 :',I9.8,I7.6/ & - ' TFN :',I9.8,I7.6/ & - ' IERR :',I4) - 9001 FORMAT (' TEST W3FLDG : WRITE :',L4/ & - ' FL2D :',L4/ & - ' FLBE :',L4/ & - ' FLST :',L4/ & - ' FIRST :',L4) -#endif -! + IF ( FLINTERP ) THEN + WRITE (NDST,9041) TF0, TFN + ELSE + WRITE (NDST,9042) TFN + END IF +#endif + ! + ! Process fields, end ----------------------------------------------- * + ! + RETURN + ! + ! EOF escape location (have read to end of file) + ! +800 CONTINUE + IERR = -1 + ! + IF ( FLINTERP ) THEN + TFN(1) = TN(1) + TFN(2) = TN(2) + CALL TICK21 ( TFN , 1. ) + END IF #ifdef W3_T - 9020 FORMAT (' TEST W3FLDG : FIELD SHIFTED') - 9021 FORMAT (' NO FIELD TO SHIFT') -#endif -! + WRITE (NDST,9032) TFN, IERR +#endif + ! + IF ( FLINTERP ) THEN + GOTO 300 + ELSE + GOTO 500 + END IF + ! + ! + ! Error escape locations + ! +801 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) INXOUT + IERR = 1 + RETURN + ! +802 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1002) IDFLD + IERR = 2 + RETURN + ! +803 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1003) ISTAT + IERR = 3 + RETURN + ! +804 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1004) J, ISTAT + IERR = 4 + RETURN + ! +805 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1005) ISTAT + IERR = 5 + RETURN + ! +806 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1006) J, ISTAT + IERR = 6 + RETURN + ! +807 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1007) J, ISTAT + IERR = 7 + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & + ' ILLEGAL INXOUT STRING : ',A/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & + ' ILLEGAL FIELD ID STRING : ',A/) +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & + ' ERROR IN WRITING TIME, IOSTAT =',I6/) +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & + ' ERROR IN WRITING FIELD ',I1,', IOSTAT =',I6/) +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & + ' ERROR IN READING TIME, IOSTAT =',I6/) +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & + ' PRMATURE EOF READING FIELD ',I1,', IOSTAT =',I6/) +1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & + ' ERROR IN READING FIELD ',I1,', IOSTAT =',I6/) + ! #ifdef W3_T - 9030 FORMAT (' TEST W3FLDG : WRITE TIME : ',I8,I7.6) - 9031 FORMAT (' TEST W3FLDG : NEW TIME : ',I8,I7.6) - 9032 FORMAT (' TEST W3FLDG : NEW TIME : ',I8,I7.6, & - ' EOF (IERR =',I3,')') -#endif -! -#ifdef W3_T - 9040 FORMAT (' TEST W3FLDG : FILLING IN FIRST FIELD') - 9041 FORMAT (' TEST W3FLDG : FINAL TIMES: ',I8,I7.6/ & - ' ',I8,I7.6) - 9042 FORMAT (' TEST W3FLDG : FINAL TIME : ',I8,I7.6) -#endif -!/ -!/ End of W3FLDG ----------------------------------------------------- / -!/ - END SUBROUTINE W3FLDG -!/ ------------------------------------------------------------------- / - SUBROUTINE W3FLDD (INXOUT, IDFLD, NDS, NDST, NDSE, TIME, TD, & - NR, ND, NDOUT, DATA, IERR ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2012 | -!/ +-----------------------------------+ -!/ -!/ 24-Jan-2002 : Origination. ( version 2.17 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ -! 1. Purpose : -! -! Update assimilation data in the WAVEWATCH III generic shell from -! a WAVEWATCH III shell data file or write from preprocessor. -! -! 2. Method : -! -! Read from file opened by W3FLDO. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'WRITE' Write a data field to file. -! 'SIZE' Get the number of records of -! next data set. -! 'READ' Read the data set found by -! 'SIZE' after allocating proper -! data array. -! IDFLD C*3 I ID string for field type, valid are: -! 'DT0', 'DT1', and 'DT2'. -! NDS Int. I Dataset number for fields file. -! NDST Int. I Dataset number for test output. -! NDSE Int. I Dataset number for error output. -! (No error output if NDSE < 0 ). -! TIME I.A. I Minimum time for data. -! TD I.A. I/O Data time. -! NR,ND Int. I Array dimensions. -! NDOUT Int. O Number of data to be read next. -! DATA R.A. I/O Data array. -! IERR Int. O Error indicator, -! -1 Past last data -! 0 OK, -! 1 : Illegal INXOUT. -! 2 : Illegal IDFLD. -! 3 : Error in writing time. -! 4 : Error in writing data. -! 5 : Error in reading time. -! 6 : Premature EOF reading data. -! 7 : Error reading data. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. Id. Subroutine tracing. -! TICK21 Subr. W3TIMEMD Advance time. -! DSEC21 Func. Id. Difference between times. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_PREP Prog. N/A Input data preprocessor. -! WW3_SHEL Prog. N/A Basic wave model driver. -! ...... Prog. N/A Any other program that reads or -! writes WAVEWATCH III data files. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See end of subroutine. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ +9000 FORMAT (' TEST W3FLDG : INXOUT : ',A/ & + ' IDFLD : ',A/ & + ' NDS(T/E) :',3I4/ & + ' MX, MY :',2I8/ & + ' NX, NY :',2I8/ & + ' TF0 :',I9.8,I7.6/ & + ' TFN :',I9.8,I7.6/ & + ' IERR :',I4) +9001 FORMAT (' TEST W3FLDG : WRITE :',L4/ & + ' FL2D :',L4/ & + ' FLBE :',L4/ & + ' FLST :',L4/ & + ' FIRST :',L4) +9020 FORMAT (' TEST W3FLDG : FIELD SHIFTED') +9021 FORMAT (' NO FIELD TO SHIFT') +9030 FORMAT (' TEST W3FLDG : WRITE TIME : ',I8,I7.6) +9031 FORMAT (' TEST W3FLDG : NEW TIME : ',I8,I7.6) +9032 FORMAT (' TEST W3FLDG : NEW TIME : ',I8,I7.6, & + ' EOF (IERR =',I3,')') +9040 FORMAT (' TEST W3FLDG : FILLING IN FIRST FIELD') +9041 FORMAT (' TEST W3FLDG : FINAL TIMES: ',I8,I7.6/ & + ' ',I8,I7.6) +9042 FORMAT (' TEST W3FLDG : FINAL TIME : ',I8,I7.6) +#endif + !/ + !/ End of W3FLDG ----------------------------------------------------- / + !/ + END SUBROUTINE W3FLDG + !/ ------------------------------------------------------------------- / + SUBROUTINE W3FLDD (INXOUT, IDFLD, NDS, NDST, NDSE, TIME, TD, & + NR, ND, NDOUT, DATA, IERR ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Dec-2012 | + !/ +-----------------------------------+ + !/ + !/ 24-Jan-2002 : Origination. ( version 2.17 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ + ! 1. Purpose : + ! + ! Update assimilation data in the WAVEWATCH III generic shell from + ! a WAVEWATCH III shell data file or write from preprocessor. + ! + ! 2. Method : + ! + ! Read from file opened by W3FLDO. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'WRITE' Write a data field to file. + ! 'SIZE' Get the number of records of + ! next data set. + ! 'READ' Read the data set found by + ! 'SIZE' after allocating proper + ! data array. + ! IDFLD C*3 I ID string for field type, valid are: + ! 'DT0', 'DT1', and 'DT2'. + ! NDS Int. I Dataset number for fields file. + ! NDST Int. I Dataset number for test output. + ! NDSE Int. I Dataset number for error output. + ! (No error output if NDSE < 0 ). + ! TIME I.A. I Minimum time for data. + ! TD I.A. I/O Data time. + ! NR,ND Int. I Array dimensions. + ! NDOUT Int. O Number of data to be read next. + ! DATA R.A. I/O Data array. + ! IERR Int. O Error indicator, + ! -1 Past last data + ! 0 OK, + ! 1 : Illegal INXOUT. + ! 2 : Illegal IDFLD. + ! 3 : Error in writing time. + ! 4 : Error in writing data. + ! 5 : Error in reading time. + ! 6 : Premature EOF reading data. + ! 7 : Error reading data. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. Id. Subroutine tracing. + ! TICK21 Subr. W3TIMEMD Advance time. + ! DSEC21 Func. Id. Difference between times. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_PREP Prog. N/A Input data preprocessor. + ! WW3_SHEL Prog. N/A Basic wave model driver. + ! ...... Prog. N/A Any other program that reads or + ! writes WAVEWATCH III data files. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See end of subroutine. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3TIMEMD -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NDST, NDSE, TIME(2), NR, ND - INTEGER, INTENT(INOUT) :: TD(2), NDOUT - INTEGER, INTENT(OUT) :: IERR - REAL, INTENT(INOUT) :: DATA(NR,ND) - CHARACTER, INTENT(IN) :: INXOUT*(*) - CHARACTER(LEN=3), INTENT(IN) :: IDFLD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISTAT, NRT + USE W3SERVMD, ONLY: STRACE +#endif + USE W3TIMEMD + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NDST, NDSE, TIME(2), NR, ND + INTEGER, INTENT(INOUT) :: TD(2), NDOUT + INTEGER, INTENT(OUT) :: IERR + REAL, INTENT(INOUT) :: DATA(NR,ND) + CHARACTER, INTENT(IN) :: INXOUT*(*) + CHARACTER(LEN=3), INTENT(IN) :: IDFLD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISTAT, NRT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: DTTST - LOGICAL :: WRITE, SIZE -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: DTTST + LOGICAL :: WRITE, SIZE + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLDD') + CALL STRACE (IENT, 'W3FLDD') #endif -!/ - IERR = 0 -! + !/ + IERR = 0 + ! #ifdef W3_T - WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, NR, ND, & - TIME, TD, IERR -#endif -! -! test input parameters ---------------------------------------------- * -! - IF ( INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' .AND. & - INXOUT.NE.'SIZE' ) GOTO 801 - IF ( IDFLD.NE.'DT0' .AND. IDFLD.NE.'DT1' .AND. & - IDFLD.NE.'DT2' ) GOTO 802 -! -! Set internal variables --------------------------------------------- * -! - WRITE = INXOUT .EQ. 'WRITE' - SIZE = INXOUT .EQ. 'SIZE' -! + WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, NR, ND, & + TIME, TD, IERR +#endif + ! + ! test input parameters ---------------------------------------------- * + ! + IF ( INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' .AND. & + INXOUT.NE.'SIZE' ) GOTO 801 + IF ( IDFLD.NE.'DT0' .AND. IDFLD.NE.'DT1' .AND. & + IDFLD.NE.'DT2' ) GOTO 802 + ! + ! Set internal variables --------------------------------------------- * + ! + WRITE = INXOUT .EQ. 'WRITE' + SIZE = INXOUT .EQ. 'SIZE' + ! #ifdef W3_T - WRITE (NDST,9001) WRITE, SIZE + WRITE (NDST,9001) WRITE, SIZE #endif -! -! Process fields, write --------------------------------------------- * -! - IF ( WRITE ) THEN -! -#ifdef W3_T - WRITE (NDST,9020) TD, ND -#endif - WRITE (NDS,ERR=803,IOSTAT=ISTAT) TD, ND - WRITE (NDS,ERR=804,IOSTAT=ISTAT) DATA -! -! Process fields, read size ----------------------------------------- * -! - ELSE IF ( SIZE ) THEN -! - 100 CONTINUE - READ (NDS,END=800,ERR=805,IOSTAT=ISTAT) TD, NDOUT -#ifdef W3_T - WRITE (NDST,9021) TD, NDOUT -#endif -! -! Check time, read and branch back if necessary -! - DTTST = DSEC21 ( TIME , TD ) - IF ( DTTST.LT.0. .OR. NDOUT.EQ.0 ) THEN - IF (NDOUT.GT.0) READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) - GOTO 100 - END IF -! -! Process fields, read data ----------------------------------------- * -! - ELSE -! - READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) DATA + ! + ! Process fields, write --------------------------------------------- * + ! + IF ( WRITE ) THEN + ! #ifdef W3_T - WRITE (NDST,9030) TD -#endif - END IF -! -! Process fields, end ----------------------------------------------- * -! - RETURN -! -! EOF escape location -! - 800 CONTINUE - IERR = -1 - RETURN -! -! Error escape locations -! - 801 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) INXOUT - IERR = 1 - RETURN -! - 802 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1002) IDFLD - IERR = 2 - RETURN -! - 803 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1003) ISTAT - IERR = 3 - RETURN -! - 804 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1004) ISTAT - IERR = 4 - RETURN -! - 805 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1005) ISTAT - IERR = 5 - RETURN -! - 806 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1006) ISTAT - IERR = 6 - RETURN -! - 807 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1007) ISTAT - IERR = 7 - RETURN -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & - ' ILLEGAL INXOUT STRING : ',A/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & - ' ILLEGAL FIELD ID STRING : ',A/) - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & - ' ERROR IN WRITING TIME, IOSTAT =',I6/) - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & - ' ERROR IN WRITING DATA, IOSTAT =',I6/) - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & - ' ERROR IN READING TIME, IOSTAT =',I6/) - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & - ' PRMATURE EOF READING DATA, IOSTAT =',I6/) - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & - ' ERROR IN READING DATA, IOSTAT =',I6/) -! + WRITE (NDST,9020) TD, ND +#endif + WRITE (NDS,ERR=803,IOSTAT=ISTAT) TD, ND + WRITE (NDS,ERR=804,IOSTAT=ISTAT) DATA + ! + ! Process fields, read size ----------------------------------------- * + ! + ELSE IF ( SIZE ) THEN + ! +100 CONTINUE + READ (NDS,END=800,ERR=805,IOSTAT=ISTAT) TD, NDOUT #ifdef W3_T - 9000 FORMAT (' TEST W3FLDD : INXOUT : ',A/ & - ' IDFLD : ',A/ & - ' NDS(T/E) :',3I4/ & - ' NR, ND :',2I4/ & - ' TIME :',I8,I7.6/ & - ' TD :',I8,I7.6/ & - ' IERR :',I4) - 9001 FORMAT (' TEST W3FLDD : WRITE :',L4/ & - ' SIZE :',L4) -#endif -! + WRITE (NDST,9021) TD, NDOUT +#endif + ! + ! Check time, read and branch back if necessary + ! + DTTST = DSEC21 ( TIME , TD ) + IF ( DTTST.LT.0. .OR. NDOUT.EQ.0 ) THEN + IF (NDOUT.GT.0) READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) + GOTO 100 + END IF + ! + ! Process fields, read data ----------------------------------------- * + ! + ELSE + ! + READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) DATA #ifdef W3_T - 9020 FORMAT (' TEST W3FLDD : WRITE TIME : ',I8,I7.6/ & - ' RECORDS : ',I6) - 9021 FORMAT (' TEST W3FLDD : NEW TIME : ',I8,I7.6/ & - ' RECORDS : ',I6) -#endif -! + WRITE (NDST,9030) TD +#endif + END IF + ! + ! Process fields, end ----------------------------------------------- * + ! + RETURN + ! + ! EOF escape location + ! +800 CONTINUE + IERR = -1 + RETURN + ! + ! Error escape locations + ! +801 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) INXOUT + IERR = 1 + RETURN + ! +802 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1002) IDFLD + IERR = 2 + RETURN + ! +803 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1003) ISTAT + IERR = 3 + RETURN + ! +804 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1004) ISTAT + IERR = 4 + RETURN + ! +805 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1005) ISTAT + IERR = 5 + RETURN + ! +806 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1006) ISTAT + IERR = 6 + RETURN + ! +807 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1007) ISTAT + IERR = 7 + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & + ' ILLEGAL INXOUT STRING : ',A/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & + ' ILLEGAL FIELD ID STRING : ',A/) +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & + ' ERROR IN WRITING TIME, IOSTAT =',I6/) +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & + ' ERROR IN WRITING DATA, IOSTAT =',I6/) +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & + ' ERROR IN READING TIME, IOSTAT =',I6/) +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & + ' PRMATURE EOF READING DATA, IOSTAT =',I6/) +1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & + ' ERROR IN READING DATA, IOSTAT =',I6/) + ! #ifdef W3_T - 9030 FORMAT (' TEST W3FLDD : FINAL TIME : ',I8,I7.6) -#endif -!/ -!/ End of W3FLDD ----------------------------------------------------- / -!/ - END SUBROUTINE W3FLDD -!/ ------------------------------------------------------------------- / - SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & - MX, MY, NX, NY, & - TLAT, TLON, MAPOVR, ILAND, MXI, MYI, & - NXI, NYI, CLOSED, ALAT, ALON, MASK, & - RD11, RD21, RD12, RD22, IX1, IX2, IY1, IY2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ 08-Feb-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ -! 1. Purpose : -! -! General purpose routine for interpolating data of an irregular -! grid given by ALAT and ALON to a target grid given by TLAT and TLON. -! -! 2. Method : -! -! Use the grid search and remapping utilities (W3GSRUMD). -! Bi-linear interpolation. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSM Int. I Unit number message output (disabled if 0). -! NDST Int. I Unit number test output. -! NDSE Int. I Unit number error output. -! IERR Int. O Error indicator (number of lost points due -! to ap conflicts). -! FLAGLL Log. I Coordinate system flag (T=Lat/Lon, F=Cartesian) -! MX,MY Int. I Array dimensions for output type arrays. -! NX,NY Int. I Id. actual field syze. -! TLAT R.A. I Y-coordinates of output grid. -! TLON R.A. I X-coordinates of output grid. -! MAPOVR I.A. I/O Overlay map, the value of a grid point is -! incremeted by 1 of the corresponding grid -! point of the output grid is covered by the -! input grid. Land points are masked out by -! setting them to ILAND. -! ILAND Int. I Value for land points in MAPOVR (typically<0) -! MXI,MYI Int. I Array dimensions for input fields. -! NXI,NYI Int. I Id. actual field sizes. -! CLOSED Log. I Flag for closed longitude range in input. -! ALAT R.A. I Y-coordinates of input grid. -! ALON R.A. I/O X-coordinates of input grid. -! (will be modified if CLOSED) -! MASK I.A. I Land-sea mask for input field (0=land). -! RDnn R.A. O Interpolation factors (see below). -! IXn,IYn I.A. O Interpolation addresses (see below). -! ---------------------------------------------------------------- -! -! RD12| |RD22 -! IY2 --+----------+-- -! | | -! | | -! | | -! | | -! IY1 --+----------+-- -! RD11| |RD21 -! -! IX1 IX2 -! -! -! Internal parameters -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. Id. Subroutine tracing. -! TICK21 Subr. W3TIMEMD Advance time. -! DSEC21 Func. Id. Difference between times. -! W3GSUC Func. W3GSRUMD Create grid-search-utility object -! W3GSUD Subr. W3GSRUMD Destroy grid-search-utility object -! W3GRMP Func. W3GSRUMD Compute interpolation weights -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_PREP Prog. N/A Input data preprocessor. -! ...... Prog. N/A Any other program that reads or -! writes WAVEWATCH III data files. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Land points in the input grid are taken out of the interp. -! algorithm. If this results in zero weight factors through the -! interpolation box in the input grid, the closest 2 sea point -! for an extended 4x4 grid are used for interpolation, weighted -! by the inverse distance. -! - The "CLOSED" variable comes from ww3_prep.inp and is associated -! with the input grid (e.g. grid that winds are provided on). -! It is a logical, not an integer, so it only allows two cases: -! no closure, or simple closure. "ww3_prep" only supports these -! two (not tripole). -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Initializations. -! a Initialize counters and factors. -! b Setup logical mask -! c Create grid-search-utility object -! 2. Loop over output grid -! a Check if sea point -! b Find enclosing cell and compute interpolation weights using -! W3GRMP -! c Non-masked or partially masked cell -! d Fully masked cell -! e Update overlay map -! 2. Finalizations. -! a Final output -! b Destroy grid-search-utility object -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! !/T Enable limited test output. -! !/T1 Enable full debugging in W3GRMP -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3GSRUMD +9000 FORMAT (' TEST W3FLDD : INXOUT : ',A/ & + ' IDFLD : ',A/ & + ' NDS(T/E) :',3I4/ & + ' NR, ND :',2I4/ & + ' TIME :',I8,I7.6/ & + ' TD :',I8,I7.6/ & + ' IERR :',I4) +9001 FORMAT (' TEST W3FLDD : WRITE :',L4/ & + ' SIZE :',L4) +9020 FORMAT (' TEST W3FLDD : WRITE TIME : ',I8,I7.6/ & + ' RECORDS : ',I6) +9021 FORMAT (' TEST W3FLDD : NEW TIME : ',I8,I7.6/ & + ' RECORDS : ',I6) +9030 FORMAT (' TEST W3FLDD : FINAL TIME : ',I8,I7.6) +#endif + !/ + !/ End of W3FLDD ----------------------------------------------------- / + !/ + END SUBROUTINE W3FLDD + !/ ------------------------------------------------------------------- / + SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & + MX, MY, NX, NY, & + TLAT, TLON, MAPOVR, ILAND, MXI, MYI, & + NXI, NYI, CLOSED, ALAT, ALON, MASK, & + RD11, RD21, RD12, RD22, IX1, IX2, IY1, IY2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ + !/ 08-Feb-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! General purpose routine for interpolating data of an irregular + ! grid given by ALAT and ALON to a target grid given by TLAT and TLON. + ! + ! 2. Method : + ! + ! Use the grid search and remapping utilities (W3GSRUMD). + ! Bi-linear interpolation. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSM Int. I Unit number message output (disabled if 0). + ! NDST Int. I Unit number test output. + ! NDSE Int. I Unit number error output. + ! IERR Int. O Error indicator (number of lost points due + ! to ap conflicts). + ! FLAGLL Log. I Coordinate system flag (T=Lat/Lon, F=Cartesian) + ! MX,MY Int. I Array dimensions for output type arrays. + ! NX,NY Int. I Id. actual field syze. + ! TLAT R.A. I Y-coordinates of output grid. + ! TLON R.A. I X-coordinates of output grid. + ! MAPOVR I.A. I/O Overlay map, the value of a grid point is + ! incremeted by 1 of the corresponding grid + ! point of the output grid is covered by the + ! input grid. Land points are masked out by + ! setting them to ILAND. + ! ILAND Int. I Value for land points in MAPOVR (typically<0) + ! MXI,MYI Int. I Array dimensions for input fields. + ! NXI,NYI Int. I Id. actual field sizes. + ! CLOSED Log. I Flag for closed longitude range in input. + ! ALAT R.A. I Y-coordinates of input grid. + ! ALON R.A. I/O X-coordinates of input grid. + ! (will be modified if CLOSED) + ! MASK I.A. I Land-sea mask for input field (0=land). + ! RDnn R.A. O Interpolation factors (see below). + ! IXn,IYn I.A. O Interpolation addresses (see below). + ! ---------------------------------------------------------------- + ! + ! RD12| |RD22 + ! IY2 --+----------+-- + ! | | + ! | | + ! | | + ! | | + ! IY1 --+----------+-- + ! RD11| |RD21 + ! + ! IX1 IX2 + ! + ! + ! Internal parameters + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. Id. Subroutine tracing. + ! TICK21 Subr. W3TIMEMD Advance time. + ! DSEC21 Func. Id. Difference between times. + ! W3GSUC Func. W3GSRUMD Create grid-search-utility object + ! W3GSUD Subr. W3GSRUMD Destroy grid-search-utility object + ! W3GRMP Func. W3GSRUMD Compute interpolation weights + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_PREP Prog. N/A Input data preprocessor. + ! ...... Prog. N/A Any other program that reads or + ! writes WAVEWATCH III data files. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Land points in the input grid are taken out of the interp. + ! algorithm. If this results in zero weight factors through the + ! interpolation box in the input grid, the closest 2 sea point + ! for an extended 4x4 grid are used for interpolation, weighted + ! by the inverse distance. + ! - The "CLOSED" variable comes from ww3_prep.inp and is associated + ! with the input grid (e.g. grid that winds are provided on). + ! It is a logical, not an integer, so it only allows two cases: + ! no closure, or simple closure. "ww3_prep" only supports these + ! two (not tripole). + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Initializations. + ! a Initialize counters and factors. + ! b Setup logical mask + ! c Create grid-search-utility object + ! 2. Loop over output grid + ! a Check if sea point + ! b Find enclosing cell and compute interpolation weights using + ! W3GRMP + ! c Non-masked or partially masked cell + ! d Fully masked cell + ! e Update overlay map + ! 2. Finalizations. + ! a Final output + ! b Destroy grid-search-utility object + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! !/T Enable limited test output. + ! !/T1 Enable full debugging in W3GRMP + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3GSRUMD #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSM, NDST, NDSE, MX, MY, NX, NY, & - MXI, MYI, NXI, NYI, MASK(MXI,MYI) - INTEGER, INTENT(INOUT) :: MAPOVR(MX,MY), ILAND - INTEGER, INTENT(OUT) :: IERR, IX1(MX,MY), IX2(MX,MY), & - IY1(MX,MY), IY2(MX,MY) - REAL, INTENT(IN) :: TLAT(MY,MX), TLON(MY,MX) - REAL, INTENT(IN) ,TARGET :: ALAT(MXI,MYI) - REAL, INTENT(INOUT),TARGET :: ALON(MXI,MYI) - REAL, INTENT(OUT) :: RD11(MX,MY), RD12(MX,MY), & - RD21(MX,MY), RD22(MX,MY) - LOGICAL, INTENT(IN) :: FLAGLL, CLOSED -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSM, NDST, NDSE, MX, MY, NX, NY, & + MXI, MYI, NXI, NYI, MASK(MXI,MYI) + INTEGER, INTENT(INOUT) :: MAPOVR(MX,MY), ILAND + INTEGER, INTENT(OUT) :: IERR, IX1(MX,MY), IX2(MX,MY), & + IY1(MX,MY), IY2(MX,MY) + REAL, INTENT(IN) :: TLAT(MY,MX), TLON(MY,MX) + REAL, INTENT(IN) ,TARGET :: ALAT(MXI,MYI) + REAL, INTENT(INOUT),TARGET :: ALON(MXI,MYI) + REAL, INTENT(OUT) :: RD11(MX,MY), RD12(MX,MY), & + RD21(MX,MY), RD22(MX,MY) + LOGICAL, INTENT(IN) :: FLAGLL, CLOSED + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - TYPE(T_GSU) :: GSU - INTEGER :: IX, IY, I, J, NNBR, II(4), JJ(4), & - MSKC, IFOUND, IMASK, ICOR1 - REAL :: RR(4), X, Y - REAL, POINTER :: PLAT(:,:), PLON(:,:) - LOGICAL :: INGRID, LMSK(MXI,MYI) - LOGICAL :: LDBG = .FALSE. - INTEGER, PARAMETER :: NNBR_MAX = 2 - INTEGER :: ICLO -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + TYPE(T_GSU) :: GSU + INTEGER :: IX, IY, I, J, NNBR, II(4), JJ(4), & + MSKC, IFOUND, IMASK, ICOR1 + REAL :: RR(4), X, Y + REAL, POINTER :: PLAT(:,:), PLON(:,:) + LOGICAL :: INGRID, LMSK(MXI,MYI) + LOGICAL :: LDBG = .FALSE. + INTEGER, PARAMETER :: NNBR_MAX = 2 + INTEGER :: ICLO + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLDP') + CALL STRACE (IENT, 'W3FLDP') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) NDSM, NDST, NDSE, MX, MY, NX, NY, ILAND, & - MXI, MYI, NXI, NYI, CLOSED + WRITE (NDST,9000) NDSM, NDST, NDSE, MX, MY, NX, NY, ILAND, & + MXI, MYI, NXI, NYI, CLOSED #endif -! -! 1. Initializations ------------------------------------------------ * -! 1.a Initialize counters and factors -! + ! + ! 1. Initializations ------------------------------------------------ * + ! 1.a Initialize counters and factors + ! #ifdef W3_T8 - LDBG = .TRUE. -#endif - IERR = 0 - IFOUND = 0 - IMASK = 0 - ICOR1 = 0 - ICLO = ICLO_NONE - IF ( FLAGLL .AND. CLOSED ) ICLO = ICLO_SMPL -! - DO IX=1, NX - DO IY=1, NY - RD11(IX,IY) = 0. - RD12(IX,IY) = 0. - RD21(IX,IY) = 0. - RD22(IX,IY) = 0. - IX1(IX,IY) = 1 - IX2(IX,IY) = 1 - IY1(IX,IY) = 1 - IY2(IX,IY) = 1 - END DO + LDBG = .TRUE. +#endif + IERR = 0 + IFOUND = 0 + IMASK = 0 + ICOR1 = 0 + ICLO = ICLO_NONE + IF ( FLAGLL .AND. CLOSED ) ICLO = ICLO_SMPL + ! + DO IX=1, NX + DO IY=1, NY + RD11(IX,IY) = 0. + RD12(IX,IY) = 0. + RD21(IX,IY) = 0. + RD22(IX,IY) = 0. + IX1(IX,IY) = 1 + IX2(IX,IY) = 1 + IY1(IX,IY) = 1 + IY2(IX,IY) = 1 END DO -! -! 1.b Setup logical mask -! - LMSK = MASK .EQ. 0 -! -! 1.c Create grid-search-utility object for input grid -! - PLAT => ALAT - PLON => ALON - GSU = W3GSUC( .TRUE., FLAGLL, ICLO, PLON, PLAT ) -! + END DO + ! + ! 1.b Setup logical mask + ! + LMSK = MASK .EQ. 0 + ! + ! 1.c Create grid-search-utility object for input grid + ! + PLAT => ALAT + PLON => ALON + GSU = W3GSUC( .TRUE., FLAGLL, ICLO, PLON, PLAT ) + ! #ifdef W3_T - WRITE (NDST,9001) - CALL W3GSUP( GSU, NDST ) -#endif -! -! 2. Loop over output grid ------------------------------------------ * -! - DO IY=1, NY - DO IX=1, NX -! - X = TLON(IY,IX) - Y = TLAT(IY,IX) + WRITE (NDST,9001) + CALL W3GSUP( GSU, NDST ) +#endif + ! + ! 2. Loop over output grid ------------------------------------------ * + ! + DO IY=1, NY + DO IX=1, NX + ! + X = TLON(IY,IX) + Y = TLAT(IY,IX) #ifdef W3_T1 - WRITE (NDST,9010) IX, IY, X, Y -#endif -! -! 2.a Check if sea point -! - IF ( MAPOVR(IX,IY) .NE. ILAND ) THEN -! -! 2.b Find enclosing cell and compute interpolation weights -! - NNBR = NNBR_MAX - INGRID = W3GRMP( GSU, X, Y, II, JJ, RR, & - MASK=LMSK, MSKC=MSKC, NNBR=NNBR, DEBUG=LDBG ) -! - IF ( INGRID ) THEN -! -! 2.c Non-masked or partially masked cell: simply store the weights -! - IF ( MSKC.EQ.MSKC_NONE .OR. MSKC.EQ.MSKC_PART ) THEN -! - IF ( MSKC.EQ.MSKC_PART ) IMASK = IMASK + 1 -! -! ..... Here we switch from counter-clockwise order to column-major - IX1 (IX,IY) = II(1) - IX2 (IX,IY) = II(2) - IY1 (IX,IY) = JJ(1) - IY2 (IX,IY) = JJ(4) - RD11(IX,IY) = RR(1) - RD21(IX,IY) = RR(2) - RD12(IX,IY) = RR(4) - RD22(IX,IY) = RR(3) -! -! 2.d Fully masked cell -! - ELSE !MSKC.EQ.MSKC_FULL -! - IMASK = IMASK + 1 -! - IF ( NNBR .GT. 0 ) THEN - ICOR1 = ICOR1 + 1 - IX1 (IX,IY) = II(1) - IY1 (IX,IY) = JJ(1) - RD11(IX,IY) = RR(1) - IF ( NNBR .GT. 1 ) THEN - IX1 (IX,IY) = II(2) - IY1 (IX,IY) = JJ(2) - RD22(IX,IY) = RR(2) - END IF + WRITE (NDST,9010) IX, IY, X, Y +#endif + ! + ! 2.a Check if sea point + ! + IF ( MAPOVR(IX,IY) .NE. ILAND ) THEN + ! + ! 2.b Find enclosing cell and compute interpolation weights + ! + NNBR = NNBR_MAX + INGRID = W3GRMP( GSU, X, Y, II, JJ, RR, & + MASK=LMSK, MSKC=MSKC, NNBR=NNBR, DEBUG=LDBG ) + ! + IF ( INGRID ) THEN + ! + ! 2.c Non-masked or partially masked cell: simply store the weights + ! + IF ( MSKC.EQ.MSKC_NONE .OR. MSKC.EQ.MSKC_PART ) THEN + ! + IF ( MSKC.EQ.MSKC_PART ) IMASK = IMASK + 1 + ! + ! ..... Here we switch from counter-clockwise order to column-major + IX1 (IX,IY) = II(1) + IX2 (IX,IY) = II(2) + IY1 (IX,IY) = JJ(1) + IY2 (IX,IY) = JJ(4) + RD11(IX,IY) = RR(1) + RD21(IX,IY) = RR(2) + RD12(IX,IY) = RR(4) + RD22(IX,IY) = RR(3) + ! + ! 2.d Fully masked cell + ! + ELSE !MSKC.EQ.MSKC_FULL + ! + IMASK = IMASK + 1 + ! + IF ( NNBR .GT. 0 ) THEN + ICOR1 = ICOR1 + 1 + IX1 (IX,IY) = II(1) + IY1 (IX,IY) = JJ(1) + RD11(IX,IY) = RR(1) + IF ( NNBR .GT. 1 ) THEN + IX1 (IX,IY) = II(2) + IY1 (IX,IY) = JJ(2) + RD22(IX,IY) = RR(2) + END IF #ifdef W3_T - IF ( NNBR .EQ. 1 ) THEN - WRITE (NDST,9043) & - IX1(IX,IY), IY1(IX,IY), RD11(IX,IY) - ELSE - WRITE (NDST,9044) & - IX1(IX,IY), IY1(IX,IY), RD11(IX,IY), & - IX2(IX,IY), IY2(IX,IY), RD22(IX,IY) - END IF -#endif - ELSE - IERR = IERR + 1 - WRITE (NDSE,910) IX, IY, X, Y, & - II(1), II(2), JJ(1), JJ(2) - END IF ! NNBR -! - END IF ! MSKC -! + IF ( NNBR .EQ. 1 ) THEN + WRITE (NDST,9043) & + IX1(IX,IY), IY1(IX,IY), RD11(IX,IY) + ELSE + WRITE (NDST,9044) & + IX1(IX,IY), IY1(IX,IY), RD11(IX,IY), & + IX2(IX,IY), IY2(IX,IY), RD22(IX,IY) + END IF +#endif + ELSE + IERR = IERR + 1 + WRITE (NDSE,910) IX, IY, X, Y, & + II(1), II(2), JJ(1), JJ(2) + END IF ! NNBR + ! + END IF ! MSKC + ! #ifdef W3_T - WRITE (NDST,9031) & - IX1(IX,IY), IY1(IX,IY), RD11(IX,IY), & - IX2(IX,IY), IY1(IX,IY), RD21(IX,IY), & - IX1(IX,IY), IY2(IX,IY), RD12(IX,IY), & - IX2(IX,IY), IY2(IX,IY), RD22(IX,IY) -#endif -! -! 2.e Update overlay map -! - MAPOVR(IX,IY) = MAPOVR(IX,IY) + 1 - IFOUND = IFOUND + 1 -! + WRITE (NDST,9031) & + IX1(IX,IY), IY1(IX,IY), RD11(IX,IY), & + IX2(IX,IY), IY1(IX,IY), RD21(IX,IY), & + IX1(IX,IY), IY2(IX,IY), RD12(IX,IY), & + IX2(IX,IY), IY2(IX,IY), RD22(IX,IY) +#endif + ! + ! 2.e Update overlay map + ! + MAPOVR(IX,IY) = MAPOVR(IX,IY) + 1 + IFOUND = IFOUND + 1 + ! #ifdef W3_T1 - ELSE ! .NOT.INGRID - WRITE (NDST,9021) + ELSE ! .NOT.INGRID + WRITE (NDST,9021) #endif - END IF ! INGRID + END IF ! INGRID #ifdef W3_T1 - ELSE ! land-point - WRITE (NDST,9020) IX, IY, X, Y, 'LAND' + ELSE ! land-point + WRITE (NDST,9020) IX, IY, X, Y, 'LAND' #endif - ENDIF ! sea-point -! -! ... End loop over output grid -------------------------------------- * -! - END DO + ENDIF ! sea-point + ! + ! ... End loop over output grid -------------------------------------- * + ! END DO -! -! 3. Finalizations -------------------------------------------------- * -! 3.a Final output -! - IF (NDSM.NE.0) WRITE (NDSM,900) IFOUND, IMASK, ICOR1, IERR -! -! 3.b Destroy grid-search-utility object -! - CALL W3GSUD(GSU) -! - RETURN -! -! Formats -! - 900 FORMAT (/' *** MESSAGE W3FLDP: FINAL SEA POINT COUNT :',I8/ & - ' INTERPOLATION ACROSS SHORE:',I8/ & - ' CORRECTED COASTAL POINTS :',I8/ & - ' UNCORRECTABLE C. POINTS :',I8/) -! - 910 FORMAT ( ' *** WARNING W3FLDP : SEA POINT ON LAND MASK ', & - '(COULD NOT BE CORRECTED)'/ & - ' COORDINATES IN OUTPUT GRID :',2I4,2F8.2/ & - ' X-COUNTERS IN INPUT GRID :',2I4/ & - ' Y-COUNTERS IN INPUT GRID :',2I4) -! + END DO + ! + ! 3. Finalizations -------------------------------------------------- * + ! 3.a Final output + ! + IF (NDSM.NE.0) WRITE (NDSM,900) IFOUND, IMASK, ICOR1, IERR + ! + ! 3.b Destroy grid-search-utility object + ! + CALL W3GSUD(GSU) + ! + RETURN + ! + ! Formats + ! +900 FORMAT (/' *** MESSAGE W3FLDP: FINAL SEA POINT COUNT :',I8/ & + ' INTERPOLATION ACROSS SHORE:',I8/ & + ' CORRECTED COASTAL POINTS :',I8/ & + ' UNCORRECTABLE C. POINTS :',I8/) + ! +910 FORMAT ( ' *** WARNING W3FLDP : SEA POINT ON LAND MASK ', & + '(COULD NOT BE CORRECTED)'/ & + ' COORDINATES IN OUTPUT GRID :',2I4,2F8.2/ & + ' X-COUNTERS IN INPUT GRID :',2I4/ & + ' Y-COUNTERS IN INPUT GRID :',2I4) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3FLDP : NDSM/T/E : ',3I8/ & - ' MX, MY : ',2I8/ & - ' NX, NY : ',2I8/ & - ' ILAND : ',I8/ & - ' MXI, MYI : ',2I8/ & - ' NXI, NYI : ',2I8/ & - ' CLOSED : ',L8) - 9001 FORMAT ( ' TEST W3FLDP : GRID SEARCH INFO -- OUTPUT FROM W3GSUP') -#endif -! -#ifdef W3_T1 - 9010 FORMAT ( ' TEST W3FLDP : IX =',I4,' IY =',I4, & - ' LONGITUDE =',F8.2, ' LATITUDE =',F8.2, & - ' ================================') -#endif -! +9000 FORMAT ( ' TEST W3FLDP : NDSM/T/E : ',3I8/ & + ' MX, MY : ',2I8/ & + ' NX, NY : ',2I8/ & + ' ILAND : ',I8/ & + ' MXI, MYI : ',2I8/ & + ' NXI, NYI : ',2I8/ & + ' CLOSED : ',L8) +9001 FORMAT ( ' TEST W3FLDP : GRID SEARCH INFO -- OUTPUT FROM W3GSUP') +#endif + ! #ifdef W3_T1 - 9020 FORMAT ( ' TEST W3FLDP : IX =',I4,' IY =',I4, & - ' LONGITUDE =',F8.2, ' LATITUDE =',F8.2, & - ' (',A,')') - 9021 FORMAT ( ' ***** OUT OF RANGE *****') -#endif -! +9010 FORMAT ( ' TEST W3FLDP : IX =',I4,' IY =',I4, & + ' LONGITUDE =',F8.2, ' LATITUDE =',F8.2, & + ' ================================') +9020 FORMAT ( ' TEST W3FLDP : IX =',I4,' IY =',I4, & + ' LONGITUDE =',F8.2, ' LATITUDE =',F8.2, & + ' (',A,')') +9021 FORMAT ( ' ***** OUT OF RANGE *****') +#endif + ! #ifdef W3_T - 9031 FORMAT ( ' TEST W3FLDP : FINAL INTERPOLATION DATA (IX,IY,R)', & - 4(/' ',2I4,f7.3)) - 9043 FORMAT ( ' TEST W3FLDP : CORRECTED INTERPOLATION '/ & - ' POINT 1 : ',2I4,F6.2) - 9044 FORMAT ( ' TEST W3FLDP : CORRECTED INTERPOLATION '/ & - ' POINT 1 : ',2I4,F6.2/ & - ' POINT 2 : ',2I4,F6.2) -#endif -!/ -!/ End of W3FLDP ----------------------------------------------------- / -!/ - END SUBROUTINE W3FLDP -!/ ------------------------------------------------------------------- / - SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & - NH, NHM, THO, HA, HD, HS, TF0, FX0, FY0, FS0,& - TFN, FXN, FYN, FSN, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 04-Sep-2003 : Bug fix par. list declaration. ( version 3.04 ) -!/ 05-Jul-2005 : Correct first level/ice. ( version 3.07 ) -!/ 15-May-2018 : Allow homog ice. ( version 6.05 ) -!/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Update homogeneous input fields for the WAVEWATCH III generic -! shell. -! -! 2. Method : -! -! Variables defining the homogeneous fields are transfered through -! the parameter list (see section 3). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! J Int I Field number of input field as in shell. -! -7 : ice parameter 1 -! -6 : ice parameter 2 -! -5 : ice parameter 3 -! -4 : ice parameter 4 -! -3 : ice parameter 5 -! -2 : mud parameter 1 -! -1 : mud parameter 2 -! 0 : mud parameter 3 -! 1 : water levels -! 2 : currents -! 3 : winds -! 4 : ice -! 5 : atmospheric momentum -! 6 : air density -! 10 : moving grid -! NDST Int. I Unit number test output. -! NDSE Int. I Unit number error messages. -! (No output if NDSE < 0). -! MX,MY Int. I Array dimensions output fields. -! NX,NY Int. I Field dimensions output fields. -! T0-N I.A. I Time interval considered. -! NH Int. I/O Number of homogeneous fields J. -! NHM Int. I Array dimension corresponding to NH. -! THO I.A. I/O Times for all homogeneous fields left. -! HA R.A. I/O Id. amplitude. -! HD R.A. I/O Id. direction (degr., Naut.). -! HS R.A. I/O Id. air-sea temperature difference (degr.). -! TF0-N I.A. I/O Times of input fields -! Fxx R.A. I/O Input fields (X, Y, Scalar) -! IERR Int. O Error indicator, -! 0 OK, -! 1 Illegal field number -! -1 Past last data -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. Id. Subroutine tracing. -! TICK21 Subr. W3TIMEMD Advance time. -! DSEC21 Func. Id. Difference between times. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_SHEL Prog. N/A Basic wave model driver. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - See end of subroutine. -! - Array dimensions not checked. -! -! 7. Remarks : -! -! - No homogeneous ice fields available. -! - Previous fields needed only for 2-D fields. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ +9031 FORMAT ( ' TEST W3FLDP : FINAL INTERPOLATION DATA (IX,IY,R)', & + 4(/' ',2I4,f7.3)) +9043 FORMAT ( ' TEST W3FLDP : CORRECTED INTERPOLATION '/ & + ' POINT 1 : ',2I4,F6.2) +9044 FORMAT ( ' TEST W3FLDP : CORRECTED INTERPOLATION '/ & + ' POINT 1 : ',2I4,F6.2/ & + ' POINT 2 : ',2I4,F6.2) +#endif + !/ + !/ End of W3FLDP ----------------------------------------------------- / + !/ + END SUBROUTINE W3FLDP + !/ ------------------------------------------------------------------- / + SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & + NH, NHM, THO, HA, HD, HS, TF0, FX0, FY0, FS0,& + TFN, FXN, FYN, FSN, IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 30-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 04-Sep-2003 : Bug fix par. list declaration. ( version 3.04 ) + !/ 05-Jul-2005 : Correct first level/ice. ( version 3.07 ) + !/ 15-May-2018 : Allow homog ice. ( version 6.05 ) + !/ 22-Mar-2021 : adds momentum and density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Update homogeneous input fields for the WAVEWATCH III generic + ! shell. + ! + ! 2. Method : + ! + ! Variables defining the homogeneous fields are transfered through + ! the parameter list (see section 3). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! J Int I Field number of input field as in shell. + ! -7 : ice parameter 1 + ! -6 : ice parameter 2 + ! -5 : ice parameter 3 + ! -4 : ice parameter 4 + ! -3 : ice parameter 5 + ! -2 : mud parameter 1 + ! -1 : mud parameter 2 + ! 0 : mud parameter 3 + ! 1 : water levels + ! 2 : currents + ! 3 : winds + ! 4 : ice + ! 5 : atmospheric momentum + ! 6 : air density + ! 10 : moving grid + ! NDST Int. I Unit number test output. + ! NDSE Int. I Unit number error messages. + ! (No output if NDSE < 0). + ! MX,MY Int. I Array dimensions output fields. + ! NX,NY Int. I Field dimensions output fields. + ! T0-N I.A. I Time interval considered. + ! NH Int. I/O Number of homogeneous fields J. + ! NHM Int. I Array dimension corresponding to NH. + ! THO I.A. I/O Times for all homogeneous fields left. + ! HA R.A. I/O Id. amplitude. + ! HD R.A. I/O Id. direction (degr., Naut.). + ! HS R.A. I/O Id. air-sea temperature difference (degr.). + ! TF0-N I.A. I/O Times of input fields + ! Fxx R.A. I/O Input fields (X, Y, Scalar) + ! IERR Int. O Error indicator, + ! 0 OK, + ! 1 Illegal field number + ! -1 Past last data + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. Id. Subroutine tracing. + ! TICK21 Subr. W3TIMEMD Advance time. + ! DSEC21 Func. Id. Difference between times. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_SHEL Prog. N/A Basic wave model driver. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - See end of subroutine. + ! - Array dimensions not checked. + ! + ! 7. Remarks : + ! + ! - No homogeneous ice fields available. + ! - Previous fields needed only for 2-D fields. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3TIMEMD -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: J, NDST, NDSE, MX, MY, NX, NY, & - T0(2), TN(2), NHM - INTEGER, INTENT(INOUT) :: NH, THO(2,-7:10,NHM), TF0(2), TFN(2) - INTEGER, INTENT(OUT) :: IERR - REAL, INTENT(INOUT) :: HA(NHM,-7:10), HD(NHM,-7:10), HS(NHM,-7:10), & - FX0(MX,MY), FY0(MX,MY), FS0(MX,MY), & - FXN(MX,MY), FYN(MX,MY), FSN(MX,MY) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IX, IY, I + USE W3SERVMD, ONLY: STRACE +#endif + USE W3TIMEMD + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: J, NDST, NDSE, MX, MY, NX, NY, & + T0(2), TN(2), NHM + INTEGER, INTENT(INOUT) :: NH, THO(2,-7:10,NHM), TF0(2), TFN(2) + INTEGER, INTENT(OUT) :: IERR + REAL, INTENT(INOUT) :: HA(NHM,-7:10), HD(NHM,-7:10), HS(NHM,-7:10), & + FX0(MX,MY), FY0(MX,MY), FS0(MX,MY), & + FXN(MX,MY), FYN(MX,MY), FSN(MX,MY) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IX, IY, I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: X, Y, DIR, DTTST, DERA - LOGICAL :: FLFRST -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: X, Y, DIR, DTTST, DERA + LOGICAL :: FLFRST + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLDH') + CALL STRACE (IENT, 'W3FLDH') #endif -! - IERR = 0 - DERA = ATAN(1.)/45. + ! + IERR = 0 + DERA = ATAN(1.)/45. -! + ! #ifdef W3_T - WRITE (NDST,9000) J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & - NH, NHM, TF0, TFN, IERR -#endif -! -! Test field ID number for validity -! - IF ( J.LT.-7 .OR. J .GT.10 ) GOTO 801 - FLFRST = TFN(1) .EQ. -1 -! + WRITE (NDST,9000) J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & + NH, NHM, TF0, TFN, IERR +#endif + ! + ! Test field ID number for validity + ! + IF ( J.LT.-7 .OR. J .GT.10 ) GOTO 801 + FLFRST = TFN(1) .EQ. -1 + ! #ifdef W3_T - WRITE (NDST,9001) FLFRST -#endif -! -! Loop over times / fields ========================================== * -! - DO -! -! Shift fields -! - TF0(1) = TFN(1) - TF0(2) = TFN(2) - IF ( TFN(1) .NE. -1 ) THEN - IF ( (J .EQ. 2) .OR. (J .EQ. 5) ) THEN - DO IX=1, NX - DO IY=1, NY - FX0(IX,IY) = FXN(IX,IY) - FY0(IX,IY) = FYN(IX,IY) - END DO - END DO -#ifdef W3_T - WRITE (NDST,9020) -#endif - ELSE IF ( J .EQ. 3 ) THEN - DO IX=1, NX - DO IY=1, NY - FX0(IX,IY) = FXN(IX,IY) - FY0(IX,IY) = FYN(IX,IY) - FS0(IX,IY) = FSN(IX,IY) - END DO - END DO + WRITE (NDST,9001) FLFRST +#endif + ! + ! Loop over times / fields ========================================== * + ! + DO + ! + ! Shift fields + ! + TF0(1) = TFN(1) + TF0(2) = TFN(2) + IF ( TFN(1) .NE. -1 ) THEN + IF ( (J .EQ. 2) .OR. (J .EQ. 5) ) THEN + DO IX=1, NX + DO IY=1, NY + FX0(IX,IY) = FXN(IX,IY) + FY0(IX,IY) = FYN(IX,IY) + END DO + END DO #ifdef W3_T - WRITE (NDST,9020) + WRITE (NDST,9020) #endif - END IF + ELSE IF ( J .EQ. 3 ) THEN + DO IX=1, NX + DO IY=1, NY + FX0(IX,IY) = FXN(IX,IY) + FY0(IX,IY) = FYN(IX,IY) + FS0(IX,IY) = FSN(IX,IY) + END DO + END DO #ifdef W3_T - ELSE - IF ( J .NE. 1 ) WRITE (NDST,9021) + WRITE (NDST,9020) #endif - END IF -! -! New field -! - IF ( NH .NE. 0. ) THEN - TFN(1) = THO(1,J,1) - TFN(2) = THO(2,J,1) -! ic* md* lev ice - IF ( (J.LE.1) .OR. (J.EQ.4) .OR. (J.EQ.6) ) THEN - DO IX=1, NX - DO IY=1, NY - FSN(IX,IY) = HA(1,J) - END DO - END DO -#ifdef W3_T - WRITE (NDST,9050) HA(1,J) -#endif - END IF -! cur - IF ( (J .EQ. 2) .OR. (J .EQ. 5) ) THEN - DIR = ( 270. - HD(1,J) ) * DERA - X = HA(1,J) * COS(DIR) - Y = HA(1,J) * SIN(DIR) - DO IX=1, NX - DO IY=1, NY - FXN(IX,IY) = X - FYN(IX,IY) = Y - END DO - END DO -#ifdef W3_T - WRITE (NDST,9050) X, Y -#endif - END IF -! wnd - IF ( J .EQ. 3 ) THEN - DIR = ( 270. - HD(1,J) ) * DERA - X = HA(1,J) * COS(DIR) - Y = HA(1,J) * SIN(DIR) - DO IX=1, NX - DO IY=1, NY - FXN(IX,IY) = X - FYN(IX,IY) = Y - FSN(IX,IY) = HS(1,J) - END DO - END DO -#ifdef W3_T - WRITE (NDST,9050) X, Y, HS(1,J) -#endif - END IF -! -! Shift data arrays -! - DO I=1, NH-1 - THO(1,J,I) = THO(1,J,I+1) - THO(2,J,I) = THO(2,J,I+1) - HA(I,J) = HA(I+1,J) - HD(I,J) = HD(I+1,J) - HS(I,J) = HS(I+1,J) - END DO - NH = NH - 1 + END IF #ifdef W3_T - WRITE (NDST,9051) TFN + ELSE + IF ( J .NE. 1 ) WRITE (NDST,9021) #endif -! - ELSE -! - TFN(1) = TN(1) - TFN(2) = TN(2) - CALL TICK21 ( TFN , 1. ) - IERR = -1 + END IF + ! + ! New field + ! + IF ( NH .NE. 0. ) THEN + TFN(1) = THO(1,J,1) + TFN(2) = THO(2,J,1) + ! ic* md* lev ice + IF ( (J.LE.1) .OR. (J.EQ.4) .OR. (J.EQ.6) ) THEN + DO IX=1, NX + DO IY=1, NY + FSN(IX,IY) = HA(1,J) + END DO + END DO #ifdef W3_T - WRITE (NDST,9052) TFN, IERR + WRITE (NDST,9050) HA(1,J) #endif -! - END IF -! -! Check time -! - - DTTST = DSEC21 ( T0 , TFN ) - - ! exit if field time is later than run time - IF ( DTTST .GT. 0. ) EXIT - ! exit if field is ic* or md* or lev or ice - ! and first forcing field has been stored - ! at start run time - IF ( J.LE.(1).OR.(J.EQ.4).OR.(J.EQ.6) ) THEN - IF (FLFRST .AND. DTTST.EQ.0. ) EXIT - END IF - END DO -! -! Check if first field -! - IF ( J.NE.1 .AND. TFN(1) .EQ. -1 ) THEN + END IF + ! cur + IF ( (J .EQ. 2) .OR. (J .EQ. 5) ) THEN + DIR = ( 270. - HD(1,J) ) * DERA + X = HA(1,J) * COS(DIR) + Y = HA(1,J) * SIN(DIR) + DO IX=1, NX + DO IY=1, NY + FXN(IX,IY) = X + FYN(IX,IY) = Y + END DO + END DO #ifdef W3_T - WRITE (NDST,9060) + WRITE (NDST,9050) X, Y #endif - TF0(1) = T0(1) - TF0(2) = T0(2) -! + END IF + ! wnd + IF ( J .EQ. 3 ) THEN + DIR = ( 270. - HD(1,J) ) * DERA + X = HA(1,J) * COS(DIR) + Y = HA(1,J) * SIN(DIR) DO IX=1, NX DO IY=1, NY - FX0(IX,IY) = FXN(IX,IY) - FY0(IX,IY) = FYN(IX,IY) - FS0(IX,IY) = FSN(IX,IY) - END DO + FXN(IX,IY) = X + FYN(IX,IY) = Y + FSN(IX,IY) = HS(1,J) END DO - END IF -! + END DO #ifdef W3_T - IF ( J .GT. 1 ) THEN - WRITE (NDST,9061) TF0, TFN - ELSE - WRITE (NDST,9062) TFN - END IF + WRITE (NDST,9050) X, Y, HS(1,J) #endif -! - RETURN -! -! Error escape locations -! - 801 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) J - IERR = 1 - RETURN -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDH : '/ & - ' ILLEGAL FIELD ID NR : ',I4/) -! + END IF + ! + ! Shift data arrays + ! + DO I=1, NH-1 + THO(1,J,I) = THO(1,J,I+1) + THO(2,J,I) = THO(2,J,I+1) + HA(I,J) = HA(I+1,J) + HD(I,J) = HD(I+1,J) + HS(I,J) = HS(I+1,J) + END DO + NH = NH - 1 #ifdef W3_T - 9000 FORMAT (' TEST W3FLDH : J, NDST/E : ',3I4/ & - ' DIMENSIONS : ',4I4/ & - ' T0 : ',I8,I7.6/ & - ' TN : ',I8,I7.6/ & - ' NH(M) : ',2I4/ & - ' TF0 : ',I8,I7.6/ & - ' TFN, IERR : ',I8,I7.6,I4) - 9001 FORMAT (' TEST W3FLDH : FIRST FIELD : ',L2) -#endif -! + WRITE (NDST,9051) TFN +#endif + ! + ELSE + ! + TFN(1) = TN(1) + TFN(2) = TN(2) + CALL TICK21 ( TFN , 1. ) + IERR = -1 #ifdef W3_T - 9020 FORMAT (' TEST W3FLDH : FIELD SHIFTED') - 9021 FORMAT (' NO FIELD TO SHIFT') + WRITE (NDST,9052) TFN, IERR #endif -! + ! + END IF + ! + ! Check time + ! + + DTTST = DSEC21 ( T0 , TFN ) + + ! exit if field time is later than run time + IF ( DTTST .GT. 0. ) EXIT + ! exit if field is ic* or md* or lev or ice + ! and first forcing field has been stored + ! at start run time + IF ( J.LE.(1).OR.(J.EQ.4).OR.(J.EQ.6) ) THEN + IF (FLFRST .AND. DTTST.EQ.0. ) EXIT + END IF + END DO + ! + ! Check if first field + ! + IF ( J.NE.1 .AND. TFN(1) .EQ. -1 ) THEN #ifdef W3_T - 9050 FORMAT (' TEST W3FLDH : NEW VALUE(S) : ',3F8.2) - 9051 FORMAT (' TEST W3FLDH : NEW TIME : ',I8,I7.6) - 9052 FORMAT (' TEST W3FLDH : NEW TIME : ',I8,I7.6, & - ' LAST FIELD (IERR =',I3,')') - 9060 FORMAT (' TEST W3FLDH : FILLING IN FIRST FIELD') - 9061 FORMAT (' TEST W3FLDH : FINAL TIMES : ',I8,I7.6/ & - ' ',I8,I7.6) - 9062 FORMAT (' TEST W3FLDH : FINAL TIME : ',I8,I7.6) -#endif -!/ -!/ End of W3FLDH ----------------------------------------------------- / -!/ - END SUBROUTINE W3FLDH -!/ ------------------------------------------------------------------- / - SUBROUTINE W3FLDM (J, NDST, NDSE, T0, TN, NH, NHM, THO, HA, HD, & - TF0, A0, D0, TFN, AN, DN, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2002 | -!/ +-----------------------------------+ -!/ -!/ 26-Dec-2002 : Origination. ( version 3.02 ) -!/ -! 1. Purpose : -! -! Update moving grid info for the WAVEWATCH III generic -! shell. -! -! 2. Method : -! -! Variables defining the homogeneous fields are transfered through -! the parameter list (see section 3). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! J Int I Field number, should be 4. -! NDST Int. I Unit number test output. -! NDSE Int. I Unit number error messages. -! (No output if NDSE < 0). -! T0-N I.A. I Time interval considered. -! NH Int. I/O Number of homogeneous fields J. -! NHM Int. I Array dimension corresponding to NH. -! THO I.A. I/O Times for all homogeneous fields left. -! HA R.A. I/O Id. amplitude. -! HD R.A. I/O Id. direction (degr., Naut.). -! TF0-N I.A. I/O Times of input fields -! A/D0/N R.A. I/O Input data. -! IERR Int. O Error indicator, -! 0 OK, -! 1 Illegal field number -! -1 Past last data -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. Id. Subroutine tracing. -! TICK21 Subr. W3TIMEMD Advance time. -! DSEC21 Func. Id. Difference between times. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_SHEL Prog. N/A Basic wave model driver. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - See end of subroutine. -! - Array dimensions not checked. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + WRITE (NDST,9060) +#endif + TF0(1) = T0(1) + TF0(2) = T0(2) + ! + DO IX=1, NX + DO IY=1, NY + FX0(IX,IY) = FXN(IX,IY) + FY0(IX,IY) = FYN(IX,IY) + FS0(IX,IY) = FSN(IX,IY) + END DO + END DO + END IF + ! +#ifdef W3_T + IF ( J .GT. 1 ) THEN + WRITE (NDST,9061) TF0, TFN + ELSE + WRITE (NDST,9062) TFN + END IF +#endif + ! + RETURN + ! + ! Error escape locations + ! +801 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) J + IERR = 1 + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDH : '/ & + ' ILLEGAL FIELD ID NR : ',I4/) + ! +#ifdef W3_T +9000 FORMAT (' TEST W3FLDH : J, NDST/E : ',3I4/ & + ' DIMENSIONS : ',4I4/ & + ' T0 : ',I8,I7.6/ & + ' TN : ',I8,I7.6/ & + ' NH(M) : ',2I4/ & + ' TF0 : ',I8,I7.6/ & + ' TFN, IERR : ',I8,I7.6,I4) +9001 FORMAT (' TEST W3FLDH : FIRST FIELD : ',L2) +9020 FORMAT (' TEST W3FLDH : FIELD SHIFTED') +9021 FORMAT (' NO FIELD TO SHIFT') +9050 FORMAT (' TEST W3FLDH : NEW VALUE(S) : ',3F8.2) +9051 FORMAT (' TEST W3FLDH : NEW TIME : ',I8,I7.6) +9052 FORMAT (' TEST W3FLDH : NEW TIME : ',I8,I7.6, & + ' LAST FIELD (IERR =',I3,')') +9060 FORMAT (' TEST W3FLDH : FILLING IN FIRST FIELD') +9061 FORMAT (' TEST W3FLDH : FINAL TIMES : ',I8,I7.6/ & + ' ',I8,I7.6) +9062 FORMAT (' TEST W3FLDH : FINAL TIME : ',I8,I7.6) +#endif + !/ + !/ End of W3FLDH ----------------------------------------------------- / + !/ + END SUBROUTINE W3FLDH + !/ ------------------------------------------------------------------- / + SUBROUTINE W3FLDM (J, NDST, NDSE, T0, TN, NH, NHM, THO, HA, HD, & + TF0, A0, D0, TFN, AN, DN, IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Dec-2002 | + !/ +-----------------------------------+ + !/ + !/ 26-Dec-2002 : Origination. ( version 3.02 ) + !/ + ! 1. Purpose : + ! + ! Update moving grid info for the WAVEWATCH III generic + ! shell. + ! + ! 2. Method : + ! + ! Variables defining the homogeneous fields are transfered through + ! the parameter list (see section 3). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! J Int I Field number, should be 4. + ! NDST Int. I Unit number test output. + ! NDSE Int. I Unit number error messages. + ! (No output if NDSE < 0). + ! T0-N I.A. I Time interval considered. + ! NH Int. I/O Number of homogeneous fields J. + ! NHM Int. I Array dimension corresponding to NH. + ! THO I.A. I/O Times for all homogeneous fields left. + ! HA R.A. I/O Id. amplitude. + ! HD R.A. I/O Id. direction (degr., Naut.). + ! TF0-N I.A. I/O Times of input fields + ! A/D0/N R.A. I/O Input data. + ! IERR Int. O Error indicator, + ! 0 OK, + ! 1 Illegal field number + ! -1 Past last data + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. Id. Subroutine tracing. + ! TICK21 Subr. W3TIMEMD Advance time. + ! DSEC21 Func. Id. Difference between times. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_SHEL Prog. N/A Basic wave model driver. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - See end of subroutine. + ! - Array dimensions not checked. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3TIMEMD -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: J, NDST, NDSE, T0(2), TN(2), NHM - INTEGER, INTENT(INOUT) :: NH, THO(2,-7:10,NHM), TF0(2), TFN(2) - INTEGER, INTENT(OUT) :: IERR - REAL, INTENT(INOUT) :: HA(NHM,-7:10), HD(NHM,-7:10), A0, AN, D0, DN -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I + USE W3SERVMD, ONLY: STRACE +#endif + USE W3TIMEMD + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: J, NDST, NDSE, T0(2), TN(2), NHM + INTEGER, INTENT(INOUT) :: NH, THO(2,-7:10,NHM), TF0(2), TFN(2) + INTEGER, INTENT(OUT) :: IERR + REAL, INTENT(INOUT) :: HA(NHM,-7:10), HD(NHM,-7:10), A0, AN, D0, DN + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: DTTST, DERA - LOGICAL :: FLFRST -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: DTTST, DERA + LOGICAL :: FLFRST + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLDM') + CALL STRACE (IENT, 'W3FLDM') #endif -! - IERR = 0 - DERA = ATAN(1.)/45. -! + ! + IERR = 0 + DERA = ATAN(1.)/45. + ! #ifdef W3_T - WRITE (NDST,9000) J, NDST, NDSE, T0, TN, NH, NHM, TF0, TFN, IERR -#endif -! -! Test field ID number for validity -! - IF ( J .NE. 4 ) GOTO 801 - FLFRST = TFN(1) .EQ. -1 -! + WRITE (NDST,9000) J, NDST, NDSE, T0, TN, NH, NHM, TF0, TFN, IERR +#endif + ! + ! Test field ID number for validity + ! + IF ( J .NE. 4 ) GOTO 801 + FLFRST = TFN(1) .EQ. -1 + ! #ifdef W3_T - WRITE (NDST,9001) FLFRST -#endif -! -! Backward branch point ============================================= * -! - 100 CONTINUE -! -! Shift data -! - TF0(1) = TFN(1) - TF0(2) = TFN(2) - IF ( TFN(1) .NE. -1 ) THEN - A0 = AN - D0 = DN + WRITE (NDST,9001) FLFRST +#endif + ! + ! Backward branch point ============================================= * + ! +100 CONTINUE + ! + ! Shift data + ! + TF0(1) = TFN(1) + TF0(2) = TFN(2) + IF ( TFN(1) .NE. -1 ) THEN + A0 = AN + D0 = DN #ifdef W3_T - WRITE (NDST,9020) - ELSE - WRITE (NDST,9021) -#endif - END IF -! -! New field -! - IF ( NH .NE. 0. ) THEN - TFN(1) = THO(1,J,1) - TFN(2) = THO(2,J,1) - AN = HA(1,J) - DN = ( 90. - HD(1,J) ) * DERA + WRITE (NDST,9020) + ELSE + WRITE (NDST,9021) +#endif + END IF + ! + ! New field + ! + IF ( NH .NE. 0. ) THEN + TFN(1) = THO(1,J,1) + TFN(2) = THO(2,J,1) + AN = HA(1,J) + DN = ( 90. - HD(1,J) ) * DERA #ifdef W3_T - WRITE (NDST,9050) AN, DN -#endif -! -! Shift data arrays -! - DO I=1, NH-1 - THO(1,J,I) = THO(1,J,I+1) - THO(2,J,I) = THO(2,J,I+1) - HA(I,J) = HA(I+1,J) - HD(I,J) = HD(I+1,J) - END DO - NH = NH - 1 -#ifdef W3_T - WRITE (NDST,9051) TFN -#endif -! - ELSE -! - TFN(1) = TN(1) - TFN(2) = TN(2) - CALL TICK21 ( TFN , 1. ) - IERR = -1 -#ifdef W3_T - WRITE (NDST,9052) TFN, IERR -#endif -! - END IF -! -! Check time -! - DTTST = DSEC21 ( T0 , TFN ) - IF ( DTTST .LE. 0. ) GOTO 100 -! -! Check if first field -! - IF ( TF0(1).EQ.-1 ) THEN + WRITE (NDST,9050) AN, DN +#endif + ! + ! Shift data arrays + ! + DO I=1, NH-1 + THO(1,J,I) = THO(1,J,I+1) + THO(2,J,I) = THO(2,J,I+1) + HA(I,J) = HA(I+1,J) + HD(I,J) = HD(I+1,J) + END DO + NH = NH - 1 #ifdef W3_T - WRITE (NDST,9060) -#endif - TF0(1) = T0(1) - TF0(2) = T0(2) - A0 = AN - D0 = DN - END IF -! + WRITE (NDST,9051) TFN +#endif + ! + ELSE + ! + TFN(1) = TN(1) + TFN(2) = TN(2) + CALL TICK21 ( TFN , 1. ) + IERR = -1 #ifdef W3_T - WRITE (NDST,9061) TF0, TFN -#endif -! - RETURN -! -! Error escape locations -! - 801 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) J - IERR = 1 - RETURN -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDM : '/ & - ' ILLEGAL FIELD ID NR : ',I4/) -! + WRITE (NDST,9052) TFN, IERR +#endif + ! + END IF + ! + ! Check time + ! + DTTST = DSEC21 ( T0 , TFN ) + IF ( DTTST .LE. 0. ) GOTO 100 + ! + ! Check if first field + ! + IF ( TF0(1).EQ.-1 ) THEN #ifdef W3_T - 9000 FORMAT (' TEST W3FLDM : J, NDST/E : ',3I4/ & - ' T0 : ',I8,I7.6/ & - ' TN : ',I8,I7.6/ & - ' NH(M) : ',2I4/ & - ' TF0 : ',I8,I7.6/ & - ' TFN, IERR : ',I8,I7.6,I4) - 9001 FORMAT (' TEST W3FLDM : FIRST FIELD : ',L2) -#endif -! + WRITE (NDST,9060) +#endif + TF0(1) = T0(1) + TF0(2) = T0(2) + A0 = AN + D0 = DN + END IF + ! #ifdef W3_T - 9020 FORMAT (' TEST W3FLDM : FIELD SHIFTED') - 9021 FORMAT (' NO FIELD TO SHIFT') -#endif -! + WRITE (NDST,9061) TF0, TFN +#endif + ! + RETURN + ! + ! Error escape locations + ! +801 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1001) J + IERR = 1 + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDM : '/ & + ' ILLEGAL FIELD ID NR : ',I4/) + ! #ifdef W3_T - 9050 FORMAT (' TEST W3FLDM : NEW VALUE(S) : ',2F8.2) - 9051 FORMAT (' TEST W3FLDM : NEW TIME : ',I8,I7.6) - 9052 FORMAT (' TEST W3FLDM : NEW TIME : ',I8,I7.6, & - ' LAST FIELD (IERR =',I3,')') - 9060 FORMAT (' TEST W3FLDM : FILLING IN FIRST FIELD') - 9061 FORMAT (' TEST W3FLDM : FINAL TIMES : ',I8,I7.6/ & - ' ',I8,I7.6) -#endif -!/ -!/ End of W3FLDM ----------------------------------------------------- / -!/ - END SUBROUTINE W3FLDM -!/ -!/ End of module W3FLDSMD -------------------------------------------- / -!/ - END MODULE W3FLDSMD +9000 FORMAT (' TEST W3FLDM : J, NDST/E : ',3I4/ & + ' T0 : ',I8,I7.6/ & + ' TN : ',I8,I7.6/ & + ' NH(M) : ',2I4/ & + ' TF0 : ',I8,I7.6/ & + ' TFN, IERR : ',I8,I7.6,I4) +9001 FORMAT (' TEST W3FLDM : FIRST FIELD : ',L2) +9020 FORMAT (' TEST W3FLDM : FIELD SHIFTED') +9021 FORMAT (' NO FIELD TO SHIFT') +9050 FORMAT (' TEST W3FLDM : NEW VALUE(S) : ',2F8.2) +9051 FORMAT (' TEST W3FLDM : NEW TIME : ',I8,I7.6) +9052 FORMAT (' TEST W3FLDM : NEW TIME : ',I8,I7.6, & + ' LAST FIELD (IERR =',I3,')') +9060 FORMAT (' TEST W3FLDM : FILLING IN FIRST FIELD') +9061 FORMAT (' TEST W3FLDM : FINAL TIMES : ',I8,I7.6/ & + ' ',I8,I7.6) +#endif + !/ + !/ End of W3FLDM ----------------------------------------------------- / + !/ + END SUBROUTINE W3FLDM + !/ + !/ End of module W3FLDSMD -------------------------------------------- / + !/ +END MODULE W3FLDSMD diff --git a/model/src/w3flx1md.F90 b/model/src/w3flx1md.F90 index 33502cf6c..ba61d9e15 100644 --- a/model/src/w3flx1md.F90 +++ b/model/src/w3flx1md.F90 @@ -1,15 +1,15 @@ -!> @file +!> @file !> @brief Flux/stress computations according to Wu (1980). -!> +!> !> @author H. L. Tolman !> @date 29-May-2009 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / !> !> @brief Flux/stress computations according to Wu (1980). -!> +!> !> @author H. L. Tolman !> @date 29-May-2009 !> @@ -18,187 +18,187 @@ !> reserved. WAVEWATCH III is a trademark of the NWS. !> No unauthorized use without permission. !> - MODULE W3FLX1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 03-Jul-2006 : Origination. ( version 3.09 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Flux/stress computations according to Wu (1980) -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3FLX1 Subr. Public Stresses according to Wu (1980). -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - Originally used with source term !/ST1. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief FLux/stress computations according to Wu (1980). -!> -!> @param[inout] ZWND Wind height. -!> @param[inout] U10 Wind speed. -!> @param[inout] U10D Wind direction. -!> @param[inout] UST Friction velocity. -!> @param[inout] USTD Direction of friction velocity. -!> @param[inout] Z0 Z0 in profile law. -!> @param[inout] CD Drag coefficient. -!> -!> @author H. L. Tolman -!> @date 03-Jul-2006 -!> - SUBROUTINE W3FLX1 ( ZWND, U10, U10D, UST, USTD, Z0, CD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 03-Jul-2006 | -!/ +-----------------------------------+ -!/ -!/ 03-Jul-2006 : Origination. ( version 3.09 ) -!/ -! 1. Purpose : -! -! FLux/stress computations according to Wu (1980) -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ZWND Real I Wind height. -! U10 Real I Wind speed. -! U10D Real I Wind direction. -! UST Real O Friction velocity. -! USTD Real 0 Direction of friction velocity. -! Z0 Real O z0 in profile law. -! CD Real O Drag coefficient. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE +MODULE W3FLX1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 03-Jul-2006 : Origination. ( version 3.09 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Flux/stress computations according to Wu (1980) + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3FLX1 Subr. Public Stresses according to Wu (1980). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - Originally used with source term !/ST1. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief FLux/stress computations according to Wu (1980). + !> + !> @param[inout] ZWND Wind height. + !> @param[inout] U10 Wind speed. + !> @param[inout] U10D Wind direction. + !> @param[inout] UST Friction velocity. + !> @param[inout] USTD Direction of friction velocity. + !> @param[inout] Z0 Z0 in profile law. + !> @param[inout] CD Drag coefficient. + !> + !> @author H. L. Tolman + !> @date 03-Jul-2006 + !> + SUBROUTINE W3FLX1 ( ZWND, U10, U10D, UST, USTD, Z0, CD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 03-Jul-2006 | + !/ +-----------------------------------+ + !/ + !/ 03-Jul-2006 : Origination. ( version 3.09 ) + !/ + ! 1. Purpose : + ! + ! FLux/stress computations according to Wu (1980) + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ZWND Real I Wind height. + ! U10 Real I Wind speed. + ! U10D Real I Wind direction. + ! UST Real O Friction velocity. + ! USTD Real 0 Direction of friction velocity. + ! Z0 Real O z0 in profile law. + ! CD Real O Drag coefficient. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: ZWND, U10, U10D - REAL, INTENT(OUT) :: UST, USTD, Z0, CD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: ZWND, U10, U10D + REAL, INTENT(OUT) :: UST, USTD, Z0, CD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLX1') + CALL STRACE (IENT, 'W3FLX1') #endif -! -! 1. Tests ---------------------------------------------------------- * -! - IF ( ABS(ZWND-10.) .GT. 0.01 ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) ZWND - CALL EXTCDE (1) - END IF -! -! 2. Computation ---------------------------------------------------- * -! - CD = 0.001 * (0.8+0.065*U10) - Z0 = ZWND * EXP ( -0.4 / SQRT(CD) ) - UST = U10 * SQRT(CD) - USTD = U10D -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3STR1 : '/ & - ' HIGHT OF WIND SHOULD BE 10m IN THIS APPRACH '/ & - ' ZWND =',F8.2,'m'/) -!/ -!/ End of W3FLX1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3FLX1 -!/ -!/ End of module INFLX1MD -------------------------------------------- / -!/ - END MODULE W3FLX1MD + ! + ! 1. Tests ---------------------------------------------------------- * + ! + IF ( ABS(ZWND-10.) .GT. 0.01 ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) ZWND + CALL EXTCDE (1) + END IF + ! + ! 2. Computation ---------------------------------------------------- * + ! + CD = 0.001 * (0.8+0.065*U10) + Z0 = ZWND * EXP ( -0.4 / SQRT(CD) ) + UST = U10 * SQRT(CD) + USTD = U10D + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3STR1 : '/ & + ' HIGHT OF WIND SHOULD BE 10m IN THIS APPRACH '/ & + ' ZWND =',F8.2,'m'/) + !/ + !/ End of W3FLX1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3FLX1 + !/ + !/ End of module INFLX1MD -------------------------------------------- / + !/ +END MODULE W3FLX1MD diff --git a/model/src/w3flx2md.F90 b/model/src/w3flx2md.F90 index 4faf495b1..38f4bcc94 100644 --- a/model/src/w3flx2md.F90 +++ b/model/src/w3flx2md.F90 @@ -1,6 +1,6 @@ -!> @file +!> @file !> @brief FLux/stress computations according Tolman and Chalikov (1996). -!> +!> !> @author H. L. Tolman !> @date 20-Apr-2010 !> @@ -9,7 +9,7 @@ !/ ------------------------------------------------------------------- / !> !> @brief FLux/stress computations according Tolman and Chalikov (1996). -!> +!> !> @author H. L. Tolman !> @date 20-Apr-2020 !> @@ -18,218 +18,218 @@ !> reserved. WAVEWATCH III is a trademark of the NWS. !> No unauthorized use without permission. !> - MODULE W3FLX2MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 20-Apr-2010 | -!/ +-----------------------------------+ -!/ -!/ 03-Jul-2006 : Origination. ( version 3.09 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 20-Apr-2010 : Fix INTENT of UST. ( version 3.14.1 ) -!/ -!/ Copyright 2009-2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! FLux/stress computations according Tolman and Chalikov (1996). -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3FLX2 Subr. Public Stresses according to TC (1996). -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - Originally used with source term !/ST2. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief FLux/stress computations according Tolman and Chalikov (1996). -!> -!> @param[in] ZWIND Height of wind. -!> @param[in] DEPTH Depth. -!> @param[in] FP Peak frequency. -!> @param[in] U Wind speed. -!> @param[in] UDIR Wind direction. -!> @param[inout] UST Friction velocity. -!> @param[out] USTD Direction of friction velocity. -!> @param[out] Z0 Z0 in profile law. -!> @param[out] CD Drag coefficient. -!> -!> @author H. L. Tolman -!> @date 10-Jan-2014 -!> - SUBROUTINE W3FLX2 ( ZWIND, DEPTH, FP, U, UDIR, UST, USTD, Z0, CD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Jan-2014 | -!/ +-----------------------------------+ -!/ -!/ 03-Jul-2006 : Origination. ( version 3.09 ) -!/ 20-Apr-2010 : Fix INTENT of UST. ( version 3.14.1 ) -!/ 16-Sep-2011 : Add max on division by UST ( version 4.05 ) -!/ 10-Jan-2014 : Add a min value for FP ( version 4.18 ) -!/ -! 1. Purpose : -! -! FLux/stress computations according Tolman and Chalikov (1996). -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ZWIND Real I Hight of wind. -! DEPTH Real I Depth. -! FP Real I Peak frequency. -! U Real I Wind speed. -! UDIR Real I Wind direction. -! UST Real O Friction velocity. -! USTD Real 0 Direction of friction velocity. -! Z0 Real O z0 in profile law. -! CD Real O Drag coefficient. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NITTIN, CINXSI - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE +MODULE W3FLX2MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 20-Apr-2010 | + !/ +-----------------------------------+ + !/ + !/ 03-Jul-2006 : Origination. ( version 3.09 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 20-Apr-2010 : Fix INTENT of UST. ( version 3.14.1 ) + !/ + !/ Copyright 2009-2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! FLux/stress computations according Tolman and Chalikov (1996). + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3FLX2 Subr. Public Stresses according to TC (1996). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - Originally used with source term !/ST2. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief FLux/stress computations according Tolman and Chalikov (1996). + !> + !> @param[in] ZWIND Height of wind. + !> @param[in] DEPTH Depth. + !> @param[in] FP Peak frequency. + !> @param[in] U Wind speed. + !> @param[in] UDIR Wind direction. + !> @param[inout] UST Friction velocity. + !> @param[out] USTD Direction of friction velocity. + !> @param[out] Z0 Z0 in profile law. + !> @param[out] CD Drag coefficient. + !> + !> @author H. L. Tolman + !> @date 10-Jan-2014 + !> + SUBROUTINE W3FLX2 ( ZWIND, DEPTH, FP, U, UDIR, UST, USTD, Z0, CD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Jan-2014 | + !/ +-----------------------------------+ + !/ + !/ 03-Jul-2006 : Origination. ( version 3.09 ) + !/ 20-Apr-2010 : Fix INTENT of UST. ( version 3.14.1 ) + !/ 16-Sep-2011 : Add max on division by UST ( version 4.05 ) + !/ 10-Jan-2014 : Add a min value for FP ( version 4.18 ) + !/ + ! 1. Purpose : + ! + ! FLux/stress computations according Tolman and Chalikov (1996). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ZWIND Real I Hight of wind. + ! DEPTH Real I Depth. + ! FP Real I Peak frequency. + ! U Real I Wind speed. + ! UDIR Real I Wind direction. + ! UST Real O Friction velocity. + ! USTD Real 0 Direction of friction velocity. + ! Z0 Real O z0 in profile law. + ! CD Real O Drag coefficient. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NITTIN, CINXSI + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3DISPMD, ONLY: DSIE, N1MAX, EWN1 -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: ZWIND, DEPTH, FP, U, UDIR - REAL, INTENT(INOUT) :: UST - REAL, INTENT(OUT) :: USTD, Z0, CD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I1, ITT + USE W3DISPMD, ONLY: DSIE, N1MAX, EWN1 + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: ZWIND, DEPTH, FP, U, UDIR + REAL, INTENT(INOUT) :: UST + REAL, INTENT(OUT) :: USTD, Z0, CD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I1, ITT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: SQRTH, SIX, R1, WNP, CP, UNZ, ALPHA, & - RDCH, AFP -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: SQRTH, SIX, R1, WNP, CP, UNZ, ALPHA, & + RDCH, AFP + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLX2') + CALL STRACE (IENT, 'W3FLX2') #endif -! -! 1. Peak phase velocity -------------------------------------------- * -! -! ----- start of inlined and reduced WAVNU1 ----- -! - AFP = TPI * MAX ( FP, 0.001) -! - SQRTH = SQRT ( DEPTH ) - SIX = AFP * SQRTH - I1 = INT ( SIX / DSIE ) - IF (I1.LE.N1MAX) THEN - R1 = SIX/DSIE - REAL(I1) - WNP = ( (1.-R1)*EWN1(I1) + R1*EWN1(I1+1) ) / DEPTH - ELSE - WNP = AFP * AFP / GRAV - END IF -! -! ----- end of inlined and reduced WAVNU1 ----- -! - CP = AFP / WNP -! -! 2. Itterative stress computation ---------------------------------- * -! - UNZ = MAX ( 0.01 , U ) - USTD = UDIR -! - DO ITT=1, NITTIN - ALPHA = 0.57 / ( CP / MAX (UST,0.0001) )**(1.5) - RDCH = MAX ( 0. , & - LOG ( ( ZWIND * GRAV) / ( CINXSI * SQRT(ALPHA) * UNZ**2) ) ) - CD = 0.001 * ( 0.021 + 10.4 / (RDCH**1.23+1.85) ) - UST = SQRT(CD) * UNZ - Z0 = ZWIND * EXP ( -0.4 / SQRT(CD) ) - END DO -! - RETURN -! -! Formats -! -!/ -!/ End of W3FLX2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3FLX2 -!/ -!/ End of module INFLX1MD -------------------------------------------- / -!/ - END MODULE W3FLX2MD + ! + ! 1. Peak phase velocity -------------------------------------------- * + ! + ! ----- start of inlined and reduced WAVNU1 ----- + ! + AFP = TPI * MAX ( FP, 0.001) + ! + SQRTH = SQRT ( DEPTH ) + SIX = AFP * SQRTH + I1 = INT ( SIX / DSIE ) + IF (I1.LE.N1MAX) THEN + R1 = SIX/DSIE - REAL(I1) + WNP = ( (1.-R1)*EWN1(I1) + R1*EWN1(I1+1) ) / DEPTH + ELSE + WNP = AFP * AFP / GRAV + END IF + ! + ! ----- end of inlined and reduced WAVNU1 ----- + ! + CP = AFP / WNP + ! + ! 2. Itterative stress computation ---------------------------------- * + ! + UNZ = MAX ( 0.01 , U ) + USTD = UDIR + ! + DO ITT=1, NITTIN + ALPHA = 0.57 / ( CP / MAX (UST,0.0001) )**(1.5) + RDCH = MAX ( 0. , & + LOG ( ( ZWIND * GRAV) / ( CINXSI * SQRT(ALPHA) * UNZ**2) ) ) + CD = 0.001 * ( 0.021 + 10.4 / (RDCH**1.23+1.85) ) + UST = SQRT(CD) * UNZ + Z0 = ZWIND * EXP ( -0.4 / SQRT(CD) ) + END DO + ! + RETURN + ! + ! Formats + ! + !/ + !/ End of W3FLX2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3FLX2 + !/ + !/ End of module INFLX1MD -------------------------------------------- / + !/ +END MODULE W3FLX2MD diff --git a/model/src/w3flx3md.F90 b/model/src/w3flx3md.F90 index 61036ebde..529002128 100644 --- a/model/src/w3flx3md.F90 +++ b/model/src/w3flx3md.F90 @@ -1,6 +1,6 @@ -!> @file +!> @file !> @brief FLux/stress computations according Tolman and Chalikov (1996). -!> +!> !> @author H. L. Tolman !> @date 20-Apr-2010 !> @@ -9,7 +9,7 @@ !/ ------------------------------------------------------------------- / !> !> @brief FLux/stress computations according Tolman and Chalikov (1996). -!> +!> !> @details Cap on flux added compared to W3FLX2. !> !> @author H. L. Tolman @@ -20,234 +20,234 @@ !> reserved. WAVEWATCH III is a trademark of the NWS. !> No unauthorized use without permission. !> - MODULE W3FLX3MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 20-Apr-2010 | -!/ +-----------------------------------+ -!/ -!/ 05-Jul-2006 : Origination. ( version 3.09 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 20-Apr-2010 : Fix INTENT of UST. ( version 3.14.1 ) -!/ -!/ Copyright 2009-2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! FLux/stress computations according Tolman and Chalikov (1996). -! Cap on flux added compared to W3FLX2. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3FLX3 Subr. Public Stresses according to TC (1996). -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - Originally used with source term !/ST2. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief FLux/stress computations according Tolman and Chalikov (1996). -!> -!> @details Cap on flux added compared to W3FLX2. -!> -!> @param[in] ZWIND Height of wind. -!> @param[in] DEPTH Depth. -!> @param[in] FP Peak frequency. -!> @param[in] U Wind speed. -!> @param[in] UDIR Wind direction. -!> @param[inout] UST Friction velocity. -!> @param[out] USTD Direction of friction velocity. -!> @param[out] Z0 Z0 in profile law. -!> @param[out] CD Drag coefficient. -!> -!> @author H. L. Tolman -!> @date 10-Jan-2014 -!> - SUBROUTINE W3FLX3 ( ZWIND, DEPTH, FP, U, UDIR, UST, USTD, Z0, CD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Jan-2014 | -!/ +-----------------------------------+ -!/ -!/ 05-Jul-2006 : Origination. ( version 3.09 ) -!/ 20-Apr-2010 : Fix INTENT of UST. ( version 3.14.1 ) -!/ 10-Jan-2014 : Add max on division by UST ( version 4.18 ) -!/ (This was already done for W3FLX2 on 16 Sep 2011) -!/ 10-Jan-2014 : Add a min value for FP ( version 4.18 ) -!/ -! 1. Purpose : -! -! FLux/stress computations according Tolman and Chalikov (1996). -! Cap on flux added compared to W3FLX2. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ZWIND Real I Hight of wind. -! DEPTH Real I Depth. -! FP Real I Peak frequency. -! U Real I Wind speed. -! UDIR Real I Wind direction. -! UST Real O Friction velocity. -! USTD Real 0 Direction of friction velocity. -! Z0 Real O z0 in profile law. -! CD Real O Drag coefficient. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NITTIN, CINXSI, CD_MAX, CAP_ID - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE +MODULE W3FLX3MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 20-Apr-2010 | + !/ +-----------------------------------+ + !/ + !/ 05-Jul-2006 : Origination. ( version 3.09 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 20-Apr-2010 : Fix INTENT of UST. ( version 3.14.1 ) + !/ + !/ Copyright 2009-2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! FLux/stress computations according Tolman and Chalikov (1996). + ! Cap on flux added compared to W3FLX2. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3FLX3 Subr. Public Stresses according to TC (1996). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - Originally used with source term !/ST2. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief FLux/stress computations according Tolman and Chalikov (1996). + !> + !> @details Cap on flux added compared to W3FLX2. + !> + !> @param[in] ZWIND Height of wind. + !> @param[in] DEPTH Depth. + !> @param[in] FP Peak frequency. + !> @param[in] U Wind speed. + !> @param[in] UDIR Wind direction. + !> @param[inout] UST Friction velocity. + !> @param[out] USTD Direction of friction velocity. + !> @param[out] Z0 Z0 in profile law. + !> @param[out] CD Drag coefficient. + !> + !> @author H. L. Tolman + !> @date 10-Jan-2014 + !> + SUBROUTINE W3FLX3 ( ZWIND, DEPTH, FP, U, UDIR, UST, USTD, Z0, CD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Jan-2014 | + !/ +-----------------------------------+ + !/ + !/ 05-Jul-2006 : Origination. ( version 3.09 ) + !/ 20-Apr-2010 : Fix INTENT of UST. ( version 3.14.1 ) + !/ 10-Jan-2014 : Add max on division by UST ( version 4.18 ) + !/ (This was already done for W3FLX2 on 16 Sep 2011) + !/ 10-Jan-2014 : Add a min value for FP ( version 4.18 ) + !/ + ! 1. Purpose : + ! + ! FLux/stress computations according Tolman and Chalikov (1996). + ! Cap on flux added compared to W3FLX2. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ZWIND Real I Hight of wind. + ! DEPTH Real I Depth. + ! FP Real I Peak frequency. + ! U Real I Wind speed. + ! UDIR Real I Wind direction. + ! UST Real O Friction velocity. + ! USTD Real 0 Direction of friction velocity. + ! Z0 Real O z0 in profile law. + ! CD Real O Drag coefficient. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NITTIN, CINXSI, CD_MAX, CAP_ID + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3DISPMD, ONLY: DSIE, N1MAX, EWN1 -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: ZWIND, DEPTH, FP, U, UDIR - REAL, INTENT(INOUT) :: UST - REAL, INTENT(OUT) :: USTD, Z0, CD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I1, ITT + USE W3DISPMD, ONLY: DSIE, N1MAX, EWN1 + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: ZWIND, DEPTH, FP, U, UDIR + REAL, INTENT(INOUT) :: UST + REAL, INTENT(OUT) :: USTD, Z0, CD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I1, ITT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: SQRTH, SIX, R1, WNP, CP, UNZ, ALPHA, & - RDCH, AFP -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: SQRTH, SIX, R1, WNP, CP, UNZ, ALPHA, & + RDCH, AFP + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLX3') + CALL STRACE (IENT, 'W3FLX3') #endif -! -! 1. Peak phase velocity -------------------------------------------- * -! -! ----- start of inlined and reduced WAVNU1 ----- -! - AFP = TPI * MAX ( FP, 0.001) -! - SQRTH = SQRT ( DEPTH ) - SIX = AFP * SQRTH - I1 = INT ( SIX / DSIE ) - IF (I1.LE.N1MAX) THEN - R1 = SIX/DSIE - REAL(I1) - WNP = ( (1.-R1)*EWN1(I1) + R1*EWN1(I1+1) ) / DEPTH - ELSE - WNP = AFP * AFP / GRAV - END IF -! -! ----- end of inlined and reduced WAVNU1 ----- -! - CP = AFP / WNP -! -! 2. Itterative stress computation ---------------------------------- * -! - UNZ = MAX ( 0.01 , U ) - USTD = UDIR -! - DO ITT=1, NITTIN - ALPHA = 0.57 / ( CP / MAX (UST,0.0001) )**(1.5) - RDCH = MAX ( 0. , & - LOG ( ( ZWIND * GRAV) / ( CINXSI * SQRT(ALPHA) * UNZ**2) ) ) - CD = 0.001 * ( 0.021 + 10.4 / (RDCH**1.23+1.85) ) - UST = SQRT(CD) * UNZ - Z0 = ZWIND * EXP ( -0.4 / SQRT(CD) ) - END DO -! -! 3. Apply limit to drag coefficient -------------------------------- * -! - IF ( CAP_ID .EQ. 0 ) THEN - CD = MIN ( CD_MAX, CD ) - ELSE - CD = CD_MAX * TANH ( CD / CD_MAX ) - END IF -! + ! + ! 1. Peak phase velocity -------------------------------------------- * + ! + ! ----- start of inlined and reduced WAVNU1 ----- + ! + AFP = TPI * MAX ( FP, 0.001) + ! + SQRTH = SQRT ( DEPTH ) + SIX = AFP * SQRTH + I1 = INT ( SIX / DSIE ) + IF (I1.LE.N1MAX) THEN + R1 = SIX/DSIE - REAL(I1) + WNP = ( (1.-R1)*EWN1(I1) + R1*EWN1(I1+1) ) / DEPTH + ELSE + WNP = AFP * AFP / GRAV + END IF + ! + ! ----- end of inlined and reduced WAVNU1 ----- + ! + CP = AFP / WNP + ! + ! 2. Itterative stress computation ---------------------------------- * + ! + UNZ = MAX ( 0.01 , U ) + USTD = UDIR + ! + DO ITT=1, NITTIN + ALPHA = 0.57 / ( CP / MAX (UST,0.0001) )**(1.5) + RDCH = MAX ( 0. , & + LOG ( ( ZWIND * GRAV) / ( CINXSI * SQRT(ALPHA) * UNZ**2) ) ) + CD = 0.001 * ( 0.021 + 10.4 / (RDCH**1.23+1.85) ) UST = SQRT(CD) * UNZ - Z0 = ZWIND * EXP ( -0.4 / SQRT(CD) ) -! - RETURN -! -! Formats -! -!/ -!/ End of W3FLX3 ----------------------------------------------------- / -!/ - END SUBROUTINE W3FLX3 -!/ -!/ End of module W3FLX3MD -------------------------------------------- / -!/ - END MODULE W3FLX3MD + Z0 = ZWIND * EXP ( -0.4 / SQRT(CD) ) + END DO + ! + ! 3. Apply limit to drag coefficient -------------------------------- * + ! + IF ( CAP_ID .EQ. 0 ) THEN + CD = MIN ( CD_MAX, CD ) + ELSE + CD = CD_MAX * TANH ( CD / CD_MAX ) + END IF + ! + UST = SQRT(CD) * UNZ + Z0 = ZWIND * EXP ( -0.4 / SQRT(CD) ) + ! + RETURN + ! + ! Formats + ! + !/ + !/ End of W3FLX3 ----------------------------------------------------- / + !/ + END SUBROUTINE W3FLX3 + !/ + !/ End of module W3FLX3MD -------------------------------------------- / + !/ +END MODULE W3FLX3MD diff --git a/model/src/w3flx4md.F90 b/model/src/w3flx4md.F90 index 9b2afb234..45d203967 100644 --- a/model/src/w3flx4md.F90 +++ b/model/src/w3flx4md.F90 @@ -1,6 +1,6 @@ -!> @file +!> @file !> @brief Flux/stress computations according to Hwang (2011). -!> +!> !> @author H. L. Tolman !> @author S. Zieger !> @author Q. Liu @@ -11,7 +11,7 @@ !/ ------------------------------------------------------------------- / !> !> @brief Flux/stress computations according to Hwang ( 2011). -!> +!> !> @details Hwang 2011: J Atmos Ocean Tech 28(3) 436-443. !> !> @author H. L. Tolman @@ -24,212 +24,212 @@ !> reserved. WAVEWATCH III is a trademark of the NWS. !> No unauthorized use without permission. !> - MODULE W3FLX4MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | S. Zieger | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 24-Nov-2017 | -!/ +-----------------------------------+ -!/ -!/ 03-Jul-2006 : Origination. ( version 3.09 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 15-Mar-2011 : Implementation of Hwang (2011) -!/ parameterization. -!/ 24-Nov_2017 : Modifying CDFAC ( Q. Liu) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Flux/stress computations according to Hwang ( 2011). -! -! References: -! Hwang 2011: J Atmos Ocean Tech 28(3) 436-443 -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3FLX4 Subr. Public Stresses according to Hwang (JTech, 2011) -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Flux/stress computations according to Hwang (JTECH, 2011). -!> -!> @verbatim -!> CD = 1E-4 ( -0.016 U10**2 + 0.967U10 + 8.058) -!> USTAR = U10 * SQRT( U10 ) -!> @endverbatim -!> -!> @param[in] ZWND Wind height. -!> @param[in] U10 Wind speed. -!> @param[in] U10D Wind direction. -!> @param[out] UST Friction velocity. -!> @param[out] USTD Direction of friction velocity. -!> @param[out] Z0 Z0 in profile law. -!> @param[out] CD Drag coefficient. -!> -!> @author H. L. Tolman -!> @date 03-Jul-2006 -!> - SUBROUTINE W3FLX4 ( ZWND, U10, U10D, UST, USTD, Z0, CD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 03-Jul-2006 | -!/ +-----------------------------------+ -!/ -!/ 03-Jul-2006 : Origination. ( version 3.09 ) -!/ -! 1. Purpose : -! -! Flux/stress computations according to Hwang (JTECH, 2011) -! -! 2. Method : -! -! CD = 1E-4 ( -0.016 U10**2 + 0.967U10 + 8.058) -! USTAR = U10 * SQRT( U10 ) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ZWND Real I Wind height. -! U10 Real I Wind speed. -! U10D Real I Wind direction. -! UST Real O Friction velocity. -! USTD Real 0 Direction of friction velocity. -! Z0 Real O z0 in profile law. -! CD Real O Drag coefficient. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR - USE W3GDATMD, ONLY: FLX4A0 - USE W3SERVMD, ONLY: EXTCDE +MODULE W3FLX4MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | S. Zieger | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 24-Nov-2017 | + !/ +-----------------------------------+ + !/ + !/ 03-Jul-2006 : Origination. ( version 3.09 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 15-Mar-2011 : Implementation of Hwang (2011) + !/ parameterization. + !/ 24-Nov_2017 : Modifying CDFAC ( Q. Liu) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Flux/stress computations according to Hwang ( 2011). + ! + ! References: + ! Hwang 2011: J Atmos Ocean Tech 28(3) 436-443 + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3FLX4 Subr. Public Stresses according to Hwang (JTech, 2011) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Flux/stress computations according to Hwang (JTECH, 2011). + !> + !> @verbatim + !> CD = 1E-4 ( -0.016 U10**2 + 0.967U10 + 8.058) + !> USTAR = U10 * SQRT( U10 ) + !> @endverbatim + !> + !> @param[in] ZWND Wind height. + !> @param[in] U10 Wind speed. + !> @param[in] U10D Wind direction. + !> @param[out] UST Friction velocity. + !> @param[out] USTD Direction of friction velocity. + !> @param[out] Z0 Z0 in profile law. + !> @param[out] CD Drag coefficient. + !> + !> @author H. L. Tolman + !> @date 03-Jul-2006 + !> + SUBROUTINE W3FLX4 ( ZWND, U10, U10D, UST, USTD, Z0, CD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 03-Jul-2006 | + !/ +-----------------------------------+ + !/ + !/ 03-Jul-2006 : Origination. ( version 3.09 ) + !/ + ! 1. Purpose : + ! + ! Flux/stress computations according to Hwang (JTECH, 2011) + ! + ! 2. Method : + ! + ! CD = 1E-4 ( -0.016 U10**2 + 0.967U10 + 8.058) + ! USTAR = U10 * SQRT( U10 ) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ZWND Real I Wind height. + ! U10 Real I Wind speed. + ! U10D Real I Wind direction. + ! UST Real O Friction velocity. + ! USTD Real 0 Direction of friction velocity. + ! Z0 Real O z0 in profile law. + ! CD Real O Drag coefficient. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR + USE W3GDATMD, ONLY: FLX4A0 + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: ZWND, U10, U10D - REAL, INTENT(OUT) :: UST, USTD, Z0, CD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: ZWND, U10, U10D + REAL, INTENT(OUT) :: UST, USTD, Z0, CD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLX4') + CALL STRACE (IENT, 'W3FLX4') #endif -! -! 1. Tests ---------------------------------------------------------- * -! - IF ( ABS(ZWND-10.) .GT. 0.01 ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) ZWND - CALL EXTCDE (1) - END IF -! -! 2. Computation ---------------------------------------------------- * -! -! To prevent the drag coefficient from dropping to zero at extreme -! wind speeds, we use a simple modification UST = 2.026 m/s for -! U10 greater than 50.33 m/s. -! - IF (U10 .GE. 50.33) THEN - UST = 2.026 * SQRT(FLX4A0) - CD = (UST/U10)**2 - ELSE - CD = FLX4A0 * ( 8.058 + 0.967*U10 - 0.016*U10**2 ) * 1E-4 - UST = U10 * SQRT(CD) - END IF -! - Z0 = ZWND * EXP ( -0.4 / SQRT(CD) ) - USTD = U10D -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLX4 : '/ & - ' HIGHT OF WIND SHOULD BE 10m IN THIS APPRACH '/ & - ' ZWND =',F8.2,'m'/) -!/ -!/ End of W3FLX4 ----------------------------------------------------- / -!/ - END SUBROUTINE W3FLX4 -!/ -!/ End of module W3FLX4MD -------------------------------------------- / -!/ - END MODULE W3FLX4MD + ! + ! 1. Tests ---------------------------------------------------------- * + ! + IF ( ABS(ZWND-10.) .GT. 0.01 ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) ZWND + CALL EXTCDE (1) + END IF + ! + ! 2. Computation ---------------------------------------------------- * + ! + ! To prevent the drag coefficient from dropping to zero at extreme + ! wind speeds, we use a simple modification UST = 2.026 m/s for + ! U10 greater than 50.33 m/s. + ! + IF (U10 .GE. 50.33) THEN + UST = 2.026 * SQRT(FLX4A0) + CD = (UST/U10)**2 + ELSE + CD = FLX4A0 * ( 8.058 + 0.967*U10 - 0.016*U10**2 ) * 1E-4 + UST = U10 * SQRT(CD) + END IF + ! + Z0 = ZWND * EXP ( -0.4 / SQRT(CD) ) + USTD = U10D + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLX4 : '/ & + ' HIGHT OF WIND SHOULD BE 10m IN THIS APPRACH '/ & + ' ZWND =',F8.2,'m'/) + !/ + !/ End of W3FLX4 ----------------------------------------------------- / + !/ + END SUBROUTINE W3FLX4 + !/ + !/ End of module W3FLX4MD -------------------------------------------- / + !/ +END MODULE W3FLX4MD diff --git a/model/src/w3flx5md.F90 b/model/src/w3flx5md.F90 index f1082a81d..d4935dd0a 100644 --- a/model/src/w3flx5md.F90 +++ b/model/src/w3flx5md.F90 @@ -1,7 +1,7 @@ -!> @file +!> @file !> @brief Unified process to obtain friction velocity and drag when stresses !> are an input (from atmospheric model). -!> +!> !> @author N.G. Valiente !> @author J. Edward !> @author A. Saulter @@ -14,7 +14,7 @@ !> !> @brief Unified process to obtain friction velocity and drag when stresses !> are an input (from atmospheric model). -!> +!> !> @author N.G. Valiente !> @author J. Edward !> @author A. Saulter @@ -25,240 +25,240 @@ !> reserved. WAVEWATCH III is a trademark of the NWS. !> No unauthorized use without permission. !> - MODULE W3FLX5MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | N.G. Valiente | -!/ | J. Edward | -!/ | A. Saulter | -!/ | FORTRAN 90 | -!/ | Last update : 01-Jul-2021 | -!/ +-----------------------------------+ -!/ -!/ 22-Mar-2021 : Origination. ( version 7.14 ) -!/ 22-Mar-2021 : Enable direct use of atmospheric model wind stress -!/ by source terms ST6 -!/ 01-Jul-2021 : Enable direct use of atmospheric model wind stress -!/ by source terms ST4 -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Unified process to obtain friction velocity and drag when stresses are an -! input (from atmospheric model). -! -! References: -! XX -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3FLX5 Subr. Public Stresses closure -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Unified process to obtain friction velocity and drag when -!> stresses are an input (from atmospheric model). -!> -!> @verbatim -!> UST = SQRT(TAUA / RHOAIR) -!> USTD = TAUADIR -!> CD = (UST/U10)**2 -!> SQRTCDM1 = MIN(U10/UST,100.0) -!> Z0 = ZWND*EXP(-KAPPA*SQRTCDM1) -!> @endverbatim -!> -!> @param[in] ZWND Wind height. -!> @param[in] U10 Wind speed. -!> @param[in] U10D Wind direction. -!> @param[in] TAUA Atmosphere total stress. -!> @param[in] TAUADIR Atmosphere total stress directions. -!> @param[in] RHOAIR Air density. -!> @param[out] UST Friction velocity. -!> @param[out] USTD Direction of friction velocity. -!> @param[out] Z0 Z0 in profile law. -!> @param[out] CD Drag coefficient. -!> @param[out] CHARN Charnock coefficient. -!> -!> @author N.G. Valiente -!> @author J. Edward -!> @author A. Saulter -!> @date 01-Jul-2021 -!> - SUBROUTINE W3FLX5 ( ZWND, U10, U10D, TAUA, TAUADIR, RHOAIR, UST, USTD, Z0, CD, CHARN ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | N.G. Valiente | -!/ | J. Edward | -!/ | A. Saulter | -!/ | FORTRAN 90 | -!/ | Last update : 01-Jul-2021 | -!/ +-----------------------------------+ -!/ -!/ 22-Mar-2021 : Origination. ( version 7.14 ) -!/ 22-Mar-2021 : Enable direct use of atmospheric model wind stress -!/ by source terms ST6 -!/ 01-Jul-2021 : Enable direct use of atmospheric model wind stress -!/ by source terms ST4 -!/ -! 1. Purpose : -! -! Unified process to obtain friction velocity and drag when stresses are an -! input (from atmospheric model). -! -! 2. Method : -! -! UST = SQRT(TAUA / RHOAIR) -! USTD = TAUADIR -! CD = (UST/U10)**2 -! SQRTCDM1 = MIN(U10/UST,100.0) -! Z0 = ZWND*EXP(-KAPPA*SQRTCDM1) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ZWND Real I Wind height. -! U10 Real I Wind speed. -! U10D Real I Wind direction. -! TAUA Real I Atm. total stress. -! TAUADIR Real I Atm. total stress direction. -! RHOAIR Real I Air density. -! UST Real O Friction velocity. -! USTD Real 0 Direction of friction velocity. -! Z0 Real O z0 in profile law. -! CD Real O Drag coefficient. -! CHARN Real O Charnock coefficient -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: KAPPA, GRAV, nu_air - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE +MODULE W3FLX5MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | N.G. Valiente | + !/ | J. Edward | + !/ | A. Saulter | + !/ | FORTRAN 90 | + !/ | Last update : 01-Jul-2021 | + !/ +-----------------------------------+ + !/ + !/ 22-Mar-2021 : Origination. ( version 7.14 ) + !/ 22-Mar-2021 : Enable direct use of atmospheric model wind stress + !/ by source terms ST6 + !/ 01-Jul-2021 : Enable direct use of atmospheric model wind stress + !/ by source terms ST4 + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Unified process to obtain friction velocity and drag when stresses are an + ! input (from atmospheric model). + ! + ! References: + ! XX + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3FLX5 Subr. Public Stresses closure + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Unified process to obtain friction velocity and drag when + !> stresses are an input (from atmospheric model). + !> + !> @verbatim + !> UST = SQRT(TAUA / RHOAIR) + !> USTD = TAUADIR + !> CD = (UST/U10)**2 + !> SQRTCDM1 = MIN(U10/UST,100.0) + !> Z0 = ZWND*EXP(-KAPPA*SQRTCDM1) + !> @endverbatim + !> + !> @param[in] ZWND Wind height. + !> @param[in] U10 Wind speed. + !> @param[in] U10D Wind direction. + !> @param[in] TAUA Atmosphere total stress. + !> @param[in] TAUADIR Atmosphere total stress directions. + !> @param[in] RHOAIR Air density. + !> @param[out] UST Friction velocity. + !> @param[out] USTD Direction of friction velocity. + !> @param[out] Z0 Z0 in profile law. + !> @param[out] CD Drag coefficient. + !> @param[out] CHARN Charnock coefficient. + !> + !> @author N.G. Valiente + !> @author J. Edward + !> @author A. Saulter + !> @date 01-Jul-2021 + !> + SUBROUTINE W3FLX5 ( ZWND, U10, U10D, TAUA, TAUADIR, RHOAIR, UST, USTD, Z0, CD, CHARN ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | N.G. Valiente | + !/ | J. Edward | + !/ | A. Saulter | + !/ | FORTRAN 90 | + !/ | Last update : 01-Jul-2021 | + !/ +-----------------------------------+ + !/ + !/ 22-Mar-2021 : Origination. ( version 7.14 ) + !/ 22-Mar-2021 : Enable direct use of atmospheric model wind stress + !/ by source terms ST6 + !/ 01-Jul-2021 : Enable direct use of atmospheric model wind stress + !/ by source terms ST4 + !/ + ! 1. Purpose : + ! + ! Unified process to obtain friction velocity and drag when stresses are an + ! input (from atmospheric model). + ! + ! 2. Method : + ! + ! UST = SQRT(TAUA / RHOAIR) + ! USTD = TAUADIR + ! CD = (UST/U10)**2 + ! SQRTCDM1 = MIN(U10/UST,100.0) + ! Z0 = ZWND*EXP(-KAPPA*SQRTCDM1) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ZWND Real I Wind height. + ! U10 Real I Wind speed. + ! U10D Real I Wind direction. + ! TAUA Real I Atm. total stress. + ! TAUADIR Real I Atm. total stress direction. + ! RHOAIR Real I Air density. + ! UST Real O Friction velocity. + ! USTD Real 0 Direction of friction velocity. + ! Z0 Real O z0 in profile law. + ! CD Real O Drag coefficient. + ! CHARN Real O Charnock coefficient + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: KAPPA, GRAV, nu_air + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: ZWND, U10, U10D, TAUA, TAUADIR, RHOAIR - REAL, INTENT(OUT) :: UST, USTD, Z0, CD, CHARN - REAL :: UNZ, SQRTCDM1 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: ZWND, U10, U10D, TAUA, TAUADIR, RHOAIR + REAL, INTENT(OUT) :: UST, USTD, Z0, CD, CHARN + REAL :: UNZ, SQRTCDM1 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLX5') + CALL STRACE (IENT, 'W3FLX5') #endif -! -! 1. Tests ---------------------------------------------------------- * -! - IF ( ABS(ZWND-10.) .GT. 0.01 ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) ZWND - CALL EXTCDE (1) - END IF -! -! 2. Computation ---------------------------------------------------- * -! -! - UST = MAX ( 1E-4, SQRT(TAUA/RHOAIR) ) - UNZ = MAX ( 0.01 , U10 ) - CD = (UST/UNZ)**2 - USTD = TAUADIR - SQRTCDM1 = MIN(UNZ/UST,100.0) - Z0 = ZWND*EXP(-KAPPA*SQRTCDM1) - IF (UNZ.GT.2.5) THEN - CHARN = (Z0 - 0.11 * NU_AIR / UST) * GRAV / UST**2 - CHARN = MAX( CHARN , 0.0095 ) - CHARN = MIN( 0.035 , CHARN ) - ELSE - CHARN = 0.0095 - END IF -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLX5 : '/ & - ' HEIGHT OF WIND SHOULD BE 10m IN THIS APPROACH '/ & - ' ZWND =',F8.2,'m'/) -!/ -!/ End of W3FLX5 ----------------------------------------------------- / -!/ - END SUBROUTINE W3FLX5 -!/ -!/ End of module W3FLX5MD -------------------------------------------- / -!/ - END MODULE W3FLX5MD + ! + ! 1. Tests ---------------------------------------------------------- * + ! + IF ( ABS(ZWND-10.) .GT. 0.01 ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) ZWND + CALL EXTCDE (1) + END IF + ! + ! 2. Computation ---------------------------------------------------- * + ! + ! + UST = MAX ( 1E-4, SQRT(TAUA/RHOAIR) ) + UNZ = MAX ( 0.01 , U10 ) + CD = (UST/UNZ)**2 + USTD = TAUADIR + SQRTCDM1 = MIN(UNZ/UST,100.0) + Z0 = ZWND*EXP(-KAPPA*SQRTCDM1) + IF (UNZ.GT.2.5) THEN + CHARN = (Z0 - 0.11 * NU_AIR / UST) * GRAV / UST**2 + CHARN = MAX( CHARN , 0.0095 ) + CHARN = MIN( 0.035 , CHARN ) + ELSE + CHARN = 0.0095 + END IF + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLX5 : '/ & + ' HEIGHT OF WIND SHOULD BE 10m IN THIS APPROACH '/ & + ' ZWND =',F8.2,'m'/) + !/ + !/ End of W3FLX5 ----------------------------------------------------- / + !/ + END SUBROUTINE W3FLX5 + !/ + !/ End of module W3FLX5MD -------------------------------------------- / + !/ +END MODULE W3FLX5MD diff --git a/model/src/w3gdatmd.F90 b/model/src/w3gdatmd.F90 index cd587ea04..5fdbbe9aa 100644 --- a/model/src/w3gdatmd.F90 +++ b/model/src/w3gdatmd.F90 @@ -13,3539 +13,3489 @@ #define TEST_W3GDATMD_W3SETREF___disabled !/ !/ ------------------------------------------------------------------- / - MODULE W3GDATMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ ! J. H. Alves ! -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-Apr-2020 | -!/ +-----------------------------------+ -!/ -!/ 24-Jun-2005 : Origination. ( version 3.07 ) -!/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) -!/ 23-Jun-2006 : Add data for W3SLN1. ( version 3.09 ) -!/ 18-Jul-2006 : Add input grids. ( version 3.10 ) -!/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) -!/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 06-Aug-2007 : Fixing SLNP !/SEED bug. ( version 3.13 ) -!/ 18-Sep-2007 : Adding WAM4 source terms. ( version 3.13 ) -!/ ( F. Ardhuin ) -!/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) -!/ 27-Jun-2008 : Expand WAM4 variants namelist ( version 3.14 ) -!/ ( F. Ardhuin ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.1 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) -!/ factor with DXDP and DXDQ terms. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 05-Apr-2011 : Implement interations for DTMAX < 1s( version 3.14.1 ) -!/ (F. Ardhuin) -!/ 01-Jul-2011 : Movable bed bottom friction BT4 ( version 4.01 ) -!/ 03-Nov-2011 : Bug fix: GUGINIT initialization ( version 4.04 ) -!/ 29-Nov-2011 : Adding ST6 source term option. ( version 4.04 ) -!/ (S. Zieger) -!/ 14-Mar-2012 : Add PSIC for BT4 ( version 4.04 ) -!/ 12-Jun-2012 : Add /RTD option or rotated grid variables. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear -!/ filter (SNLS) from 3.15 (HLT). ( version 4.08 ) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.09 ) -!/ 16-Sep-2013 : Add Arctic part SMC grid. ( version 4.11 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 16-Nov-2013 : Allows reflection on curvi grids ( version 4.14 ) -!/ 26-Jul-2013 : Adding IG waves ( version 4.16 ) -!/ 18-Dec-2013 : Moving FLAGLL into GRID TYPE ( version 4.16 ) -!/ 11-Jun-2014 : Changed reflection for subgrid ( version 5.01 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 21-Aug-2015 : Add SMC FUNO3, FVERG options. JGLi ( version 5.09 ) -!/ 04-May-2016 : Add IICEDISP GB&FA ( version 5.10 ) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ 20-Jan-2017 : Change to preprocessor macros to enable test output. -!/ (T.J. Campbell, NRL) ( version 6.02 ) -!/ 20-Jan-2017 : Change calculation of curvilinear grid metric and -!/ derivatives calculations to use W3GSRUMD:W3CGDM. -!/ (T.J. Campbell, NRL) ( version 6.02 ) -!/ 07-Jan-2018 : Generalizes ICE100WIND to ICESCALES ( version 6.04 ) -!/ 26-Mar-2018 : Add FSWND optional variable. JGLi ( version 6.02 ) -!/ 05-Jun-2018 : Add PDLIB/DEBUGINIT and implcit scheme parameters -!/ for unstructured grids ( version 6.04 ) -!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) -!/ 20-Aug-2018: Extra namelist variables for ST6 ( version 6.06) -!/ (Q. Liu, UoM) -!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) -!/ 27-Aug-2018 : Add BTBETA parameter ( version 6.06 ) -!/ 22-Feb-2020 : Add AIRGB and AIRCMIN ( version 7.06 ) -!/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) -!/ 06-May-2021 : Add SMCTYPE, ARCTC options. JGLi ( version 7.12 ) -!/ 07-Jun-2021 : the GKE module (NL5, Q. Liu) ( version 7.12 ) -!/ -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Define data structures to set up wave model grids and aliases -! to use individual grids transparently. Also includes subroutines -! to manage data structure and pointing to individual models. -! Definition of grids and model set up. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NGRIDS Int. Public Number of grids, initialized at -1 -! to check proper model initialization. -! NAUXGR Int. Public Auxiliary grids. -! IGRID Int. Public Selected spatial grid, init. at -1. -! ISGRD Int. Public Selected spectral grid, init. at -1. -! IPARS Int. Public Selected num. and ph. pars, init. at -1. -! RLGTYPE I.P. Public Named constant for rectilinear grid type -! CLGTYPE I.P. Public Named constant for curvilinear grid type -! UNGTYPE I.P. Public Named constant for Unstructured triangular grid -! SMCTYPE I.P. Public Named constant for unstructured SMC grid type -! FLAGLL Log. Public Flag to indicate coordinate system for all grids -! .TRUE.: Spherical (lon/lat in degrees) -! .FALSE.: Cartesian (meters) -! GRID TYPE Public Data structure defining grid. -! GRIDS GRID Public Array of grids. -! SGRD TYPE Public Data structure defining spectral grid. -! SGRDS GRID Public Array of spectral grids. -! MPAR TYPE Public Data structure with all other model -! parameters. -! MPARS GRID Public Array of MPAR. -! ---------------------------------------------------------------- -! -! All elements of GRID are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! GTYPE Int. Public Flag for type of grid -! RLGTYPE: Rectilinear grid -! CLGTYPE: Curvilinear grid -! UNGTYPE: Unstructured triangular grid -! SMCTYPE: Unstructured SMC grid -! RSTYPE Int. Public Integer identifyng restart type -! ICLOSE Int. Public Parameter indicating type of index closure of grid. -! ICLOSE_NONE: No grid closure -! ICLOSE_SMPL: Simple grid closure -! Grid is periodic in the i-index and wraps at -! I=NX+1. In other words, (NX+1,J) => (1,J). -! ICLOSE_TRPL: Tripole grid closure -! Grid is periodic in the i-index and and wraps at -! I=NX+1 and has closure at J=NY+1. In other words, -! (NX+1,J<=NY) => (1,J) and -! (I,NY+1) => (MOD(NX-I+1,NX)+1,NY). The tripole -! closure requires that NX be even. -! NX, NY Int. Public Discrete dimensions of spatial grid. -! NSEA(L) Int. Public Number of sea points (local for MPP). -! NU/VFc Int. Public Number of U/V faces for SMC grid. -! NRLv Int. Public Number of refined levels for SMC grid. -! NGLO Int. Public Number of cells in global part for SMC grid. -! NARC Int. Public Number of cells in Arctic part for SMC grid. -! NBAC Int. Public Number of boundary cells in Arctic part. -! NBGL Int. Public Number of boundary cells in global part. -! NBSMC Int. Public Number of boundary cells for regional SMC grid. -! TRFLAG Int. Public Flag for use of transparencies -! 0: No sub-grid obstacles. -! 1: Obstructions at cell boundaries. -! 2: Obstructions at cell centers. -! 3: Like 1 with continuous ice. -! 4: Like 2 with continuous ice. -! MAPSTA I.A. Public Grid status map. -! MAPST2 I.A. Public Second grid status map. -! MAPxx I.A. Public Storage grid maps. -! IJKCel I.A. Public Cell info array for SMC grid. -! IJKU/VFc I.A. Public U/V-Face arrays for SMC grid. -! NLv* I.A. Public Cell, U/V-Face numbers of refine levels. -! ICLBAC I.A. Public Mapping index for Arctic boundary cells. -! ISMCBP I.A. Public List of SMC grid input boundary cell indexes. -! SX,SY Real Public Spatial (rectilinear) grid increments. -! X0,Y0 Real Public Lower left corner of spatial (rectilinear) grid. -! DTCFL Real Public Maximum CFL time step X-Y propagation. -! DTCFLI Real Public Id. intra-spectral. -! DTMAX Real Public Maximum overall time step. -! DTMIN Real Public Minimum dynamic time step for source -! NITERSEC1 Real Public Number of interations when DTMAX < 1s -! DMIN Real Public Minimum water depth. -! CTMAX Real Public Maximum CFL number for depth refr. -! FICE0/N Real Public Cut-off ice conc. for ice coverage. -! FICEL Real Public Length scale for sea ice damping -! IICEHMIN Real Public Minimum thickness of sea ice -! IICEHDISP Real Public Minimum thickness of sea ice in the dispersion relation before relaxing the conv. criterion -! IICEHFAC Real Public Scale factor for sea ice thickness -! IICEHINIT Real Public Initial value of ice thickness -! ICESCALES R.A. Publ. Scaling coefficient for source terms in the presence of ice -! Default is 1.0, meaning that 100% ice -! concentration result in zero source term -! If set to 0.0, then ice has no direct impact on Sln / Sin / Snl / Sds -! IC3PARS R.A. Public various parameters for use in IC4, handled as -! an array for simplicity -! IC4_KI R.A. Public KI (dissipation rate) values for use in IC4 -! IC4_FC R.A. Public FC (frequency bin separators) for use in IC4 -! PFMOVE Real Public Tunable parameter in GSE correction -! for moving grids. -! GRIDSHIFT Real Public Grid offset for multi-grid w/SCRIP -! CMPRTRCK Log. Public True for traditional compression of track output -! PoLat/Lon R.A. Public Rotated N-Pole standard latitude/longitude. -! AnglD R.A. Public Rotation angle in degree to turn rotated grid -! back to standard grid. JGLi12Jun2012 -! FLAGUNR Log. Public True if rotating directions back to true north -! STEXU Real Public Length-scale (X) for space-time extreme averaging -! STEYU Real Public Length-scale (Y) for space-time extreme averaging -! STEDU Real Public Time-scale for space-time extreme averaging -! ZB R.A. Public Bottom levels on storage grid. -! CLATS(I) R.A. Public (Inverse) cosine of latitude at sea points. -! CTHG0S R.A. Public Constant in great-circle refr. term at sea points. -! TRNX/Y R.A. Public Transparencies in X/Y for sub-grid -! CTRNX/Y R.A. Public Sub-grid transparencies for SMC grid. -! ANGARC R.A. Public Rotation angle in degree for Arctic cells. -! SPCBAC R.A. Public Full 2-D spectra for Arctic boundary cells. -! X/YGRD R.A. Public Spatial grid coordinate arrays. -! SX/SYGRD R.A. Public Spatial grid increment arrays. -! GINIT Log. Public Flag identifying grid initialization. -! FLDRY Log. Public Flag for 'dry' run (IO and data -! processing only). -! FLCx Log. Public Flags for prop. is different spaces. -! FLSOU Log. Public Flag for source term calculation. -! FUNO3 Log. Public Flag for 3rd order UNO3 scheme on SMC grid. -! FVERG Log. Public Flag for 1-2-1 averaging smoothing on SMC grid. -! FSWND Log. Public Flag for sea-point only wind input on SMC grid. -! ARCTC Log. Public Flag to include Arctic polar part on SMC grid. -! FLAGST L.A. Public Flag for source term computations -! for individual grid points. -! IICEDISP Log. Public Flag for use of the ice covered dispertion relation. -! IICESMOOTH Log. Public Flag to smooth the ice covered dispertion relation in broken ice. -! -! -! GNAME C*30 Public Grid name. -! FILEXT C*13 Public Extension of WAVEWATCH III file names -! default in 'ww3'. -! BTBETA Real Public The constant used for separating wind sea -! and swell when we estimate WBT -! ---------------------------------------------------------------- -! -! All elements of SGRD are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NK Int. Public Number of discrete wavenumbers. -! NK2 Int. Public Extended wavenumber range. -! NTH Int. Public Number of discrete directions. -! NSPEC Int. Public Number of discrete spectral bins. -! MAPxx I.A. Public Spectral maps. -! DTH Real Public Directional increments (radians). -! XFR Real Public Frequency multiplication factor. -! FR1 Real Public Lowest frequency (Hz) -! FTE Real Public Factor in tail integration energy. -! FTF Real Public Id. frequency. -! FTWN Real Public Id. wavenumber. -! FTTR Real Public Id. wave period. -! FTWL Real Public Id. wave length. -! FACTIn Real Public Factors for obtaining integer cut-off -! frequency. -! FACHFx Real Public Factor for tail. -! TH R.A Public Directions (radians). -! ESIN R.A Public Sine of discrete directions. -! ECOS R.A Public Cosine of discrete directions. -! ES2, ESC, EC2 -! R.A Public Sine and cosine products -! SIG R.A Public Relative frequencies (invariant -! in grid). (rad) -! SIG2 R.A Public Id. for full 2-D spectrum. -! DSIP R.A Public Frequency bandwidths (prop.) (rad) -! DSII R.A Public Frequency bandwidths (int.) (rad) -! DDEN R.A Public DSII * DTH * SIG (for integration -! based on energy) -! DDEN2 R.A Public Idem, full spectrum. -! SINIT Log. Public Flag identifying grid initialization. -! ---------------------------------------------------------------- -! -! The structure MPAR contains all other model parameters for -! numerical methods and physical parameterizations. It contains -! itself several structures as outlined below. -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! PINIT Log. Public Flag identifying initialization. -! NPARS NPAR Public Numerical parameters, -! PROPS PROP Public Parameters propagatrion schemes. -! SFLPS SFLP Public Parameters for flux computation. -! SLNPS SLNP Public Parameters Sln. -! SRCPS SRCP Public Parameters Sin and Sds. -! SNLPS SNLP Public Parameters Snl. -! SBTPS SBTP Public Parameters Sbt. -! SDBPS SDBP Public Parameters Sdb. -! STRPS STRP Public Parameters Str. -! SBSPS SBSP Public Parameters Sbs. -! ---------------------------------------------------------------- -! -! The structure NPAR contains numerical parameters and is aliased -! as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! FACP Real Public Constant in maximum par. change in -! dynamic integration scheme (depends -! upon Xp). -! XREL Real Public Id. relative change. -! XFLT Real Public Id. filter level. -! FXFM Real Public Constant for mean frequency in -! cut-off. (!/ST1) -! FXPM Real Public Id. PM. -! XFT Real Public Constant for cut-off freq. (!/ST2) -! XFC Real Public Id. -! FACSD Real Public Constant in seeding algorithm. -! FHMAX Real Public Hs/depth ratio in limiter (!/MLIM) -! RWINDC Real Public Coefficient for current in relative -! wind (!/RWND) -! WWCOR R.A. Public Wind correction factors (!/WCOR) -! ---------------------------------------------------------------- -! -! The structure PROP contains parameters for the propagation -! schemes and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! DTME Real Public Swell age in disp. corr. (!/PR2) -! CLATMN Real Public Id. minimum cosine of lat. (!/PR2) -! DTMS Real Public Swell age in disp. corr. (!/SMC) -! -! WDCG Real Public Factors in width of av. Cg. (!/PR3) -! WDTH Real Public Factors in width of av. Th. (!/PR3) -! ---------------------------------------------------------------- -! -! The structure SFLP contains parameters for the fluxes -! and is aliased as above: -! ---------------------------------------------------------------- -! (!/FLX2) -! NITTIN Int. Public Number of itterations for drag calc. -! CINXSI Real Public Constant in parametric description -! (!/FLX3) -! NITTIN Int. Public Number of itterations for drag calc. -! CAP_ID Int Public Type of cap used. -! CINXSI Real Public Constant in parametric description -! CD_MAX Real Public Cap on Cd. -! (!/FLX4) -! FLX4A0 Real Public Scaling value in parametric description -! ---------------------------------------------------------------- -! -! The structure SLNP contains parameters for the linear input -! source terms and is aliased as above: -! -! ---------------------------------------------------------------- -! (!/LN1) -! SLNC1 Real Public Proportionality and other constants in -! input source term. -! FSPM Real Public Factor for fPM in filter. -! FSHF Real Public Factor for fh in filter. -! ---------------------------------------------------------------- -! -! The structure SRCP contains parameters for the input and dis, -! source terms and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WWNMEANPTAIL R Public Power of tail for WNMEAN calculation -! SSTXFTFTAIL R Public Tail factor for WNMEAN calculation -! (!/ST1) -! SINC1 Real Public Proportionality and other constants in -! input source term. -! SDSC1 Real Public Combined constant in dissipation -! source term. -! (!/ST2) -! ZWIND Real Public Height at which the wind is defined -! of drag. -! FSWELL Real Public Reduction factor of negative input -! for swell. -! SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS -! Real Public Factors in effective wind speed. -! CDSAn Real Public Constants in high-freq. dis. -! SDSALN Real Public Factor for nondimensional 1-D spectrum. -! CDSBn Real Public Constants in parameterization of PHI. -! XFH Real Public Constant for turbulent length scale. -! XFn Real Public Constants in combining low and high -! frequency dissipation. -! (!/ST3) -! ZZWND Real Public Height at which the wind is defined -! AALPHA Real Public Minimum value of charnock parameter -! BBETA Real Public Wind-wave coupling coefficient -! ZZALP Real Public Wave age tuning coefficient in Sin -! TTAUWSHELTER Real Public Sheltering coefficient for short waves -! ZZ0MAX Real Public Maximum value of air-side roughness -! ZZ0RAT Real Public ratio of roughness for mean and -! oscillatory flows -! SSINTHP Real Public Power in cosine of wind input -! SSWELLF R.A. Public Swell damping coefficients -! SSDSCn Real Public Dissipation parameters -! SSDSBR Real Public Threshold in saturation spectrum for Sds -! SSDSP Real Public Power of B(k) in Sds -! WWNMEANP Real Public Power that defines the mean wavenumber -! in Sds -! SSTXFTF, SSTXFTWN Real Public Tail constants -! SSDSC4, Real Public Threshold shift in saturation diss. -! SSDSC5, Real Public Wave-turbulence dissipation factor -! SSDSC6, Real Public dissipation parameter -! DDELTA1 Real Public Low-frequency dissipation coefficient -! in WAM4 -! DDELTA2 Real Public High-frequency dissipation coefficient -! in WAM4 -! SSDSDTH Real Public Maximum angular sector for saturation -! spectrum -! SSDSCOS Real Public Power of cosine in saturation integral -! SSDSISO Int. Public Choice of definition of the isotropic -! saturation -! ---------------------------------------------------------------- -! -! The structure SNLP contains parameters for the nonl. inter. -! source term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! (!/NL1) -! SNLC1 Real Public Scaled proportionality constant. -! LAM Real Public Factor defining quadruplet. -! KDCON Real Public Conversion factor for relative depth. -! KDMN Real Public Minimum relative depth. -! SNLSn Real Public Constants in shallow water factor. -! (!/NL2) -! IQTPE Int. Public Type of depth treatment -! 1 : Deep water -! 2 : Deep water / WAM scaling -! 3 : Finite water depth -! NDPTHS Int. Public Number of depth for which integration -! space needs to be computed. -! NLTAIL Real Public Tail factor for parametric tail. -! DPTHNL R.A. Public Depths corresponding to NDPTHS. -! *** NOTE: This array is not allocated -! in the W3DIMP routine *** -! (!/NL3) -! NFR Int. Public Number of frequencies or wavenumbers -! in discrete spectral space (NFR=>NK). -! NFRMIN Int. Public Minimum discrete frequency in the -! expanded frequency space. -! NFRMAX Int. Public Idem maximum for first part. -! NFRCUT Int. Public Idem maximum for second part. -! NTHMAX Int. Public Extension of directional space. -! NTHEXP Int Public Number of bins in extended dir. space. -! NSPMIN, NSPMAX, NSPMX2 -! Int. Public 1D spectral space range. -! FRQ R.A. Public Expanded frequency range (Hz). -! XSI R.A. Public Expanded frequency range (rad/s). -! NQA Int. Public Number of actual quadruplets. -! QST1 I.A. Public Spectral offsets for compuation of -! quadruplet spectral desnities. -! QST2 R.A. Public Idem weights. -! QST3 R.A. Public Proportionality constants and k factors -! in diagonal strength. -! QST4 I.A. Public Spectral offsets for combining of -! interactions and diagonal. -! QST5 R.A. Public Idem weights for interactions. -! QST6 R.A. Public Idem weights for diagonal. -! SNLNQ Int. Public Number of quadruplet definitions. -! SNLMSC Real Public Tuning power 'deep' scaling. -! SNLNSC Real Public Tuning power 'shallow' scaling. -! SNLSFD Real Public 'Deep' nondimensional filer freq. -! SNLSFS Real Public 'Shallow' nondimensional filer freq. -! SNLL R.A. Public Array with lambda for quadruplet. -! SNLM R.A. Public Array with mu for quadruplet. -! SNLT R.A. Public Array with Dtheta for quadruplet. -! SNLCD R.A. Public Array with Cd for quadruplet. -! SNLCS R.A. Public Array with Cs for quadruplet. -! (!/NL4) -! ITSA Int. Public Integer indicating TSA (1) or FBI (0) -! IALT Int. Public Integer determining alternating looping -! (!/NL5) -! QR5DPT Real Public Water depth for the GKE module -! QR5OML Real Public λ cut off value for quasi-resonant quartets -! QI5DIS Int. Public Method to discretize continuous spectrum -! QI5KEV Int. Public GKE (GS13 or J03) -! QI5NNZ Int. Public # of interactive quadruplets -! QI5IPL Int. Public Interp. method to get C₄ -! QI5PMX Int. Public Phase mixing related parameter -! (!/NLS) -! NTHX Int. Public Expanded discrete direction range. -! NFRX Int. Public Expanded discrete frequency range. -! NSPL-H Int. Public Range of 1D spectrum. -! SNSST R.A. Public Array with interpolation weights. -! CNLSA Real Public a34 in quadruplet definition. -! CNLSC Real Public C in Snl definition. -! CNLSFM Real Public Maximum relative spectral change. -! CNLSC1/3 Real Public Constant in frequency filter. -! ---------------------------------------------------------------- -! -! The structure SBTP contains parameters for the bottom friction -! source term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! SBTC1 Real Public Proportionality constant. (!/BT1) -! SBTCX R.A. Public Parameters for bottom fric. (!/BT4) -! ---------------------------------------------------------------- -! -! The structure SDBP contains parameters for the depth incduced -! breaking source term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! SDBC1 Real Public Proportionality constant. (!/DB1) -! SDBC2 Real Public Hmax/d ratio. (!/DB1) -! FDONLY Log. Public Flag for checking depth only (!/DB1) -! otherwise Miche criterion. -! ---------------------------------------------------------------- -! -! The structure STRP contains parameters for the triad interaction -! source term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! The structure SBSP contains parameters for the bottom scattering -! source term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! The structure SICP contains parameters for arbitrary source -! term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! IS1C1 Real Public Scale factor for icecon. (!/ISx) -! IS1C2 Real Public Offset for ice concentration (!/ISx) -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3NMOD Subr. Public Set number of grids. -! W3DIMX Subr. Public Set dimensions of spatial grid. -! W3DIMS Subr. Public Set dimensions of spectral grid. -! W3SETG Subr. Public Point to selected grid / model. -! W3GNTX Subr. Public Construct grid arrays -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - In model versions before 3.06 the parameters in the grid -! structure were stored in the module W3IOGR. -! - No subroutine DIMP is provided, instead, arrays are set -! one-by-one in W3IOGR. -! -! 6. Switches : -! -! See subroutine documentation. -! -! !/PRn Select propagation scheme -! !/SMC UNO2 propagation on SMC grid. -! -! !/LNn Select source terms -! !/STn -! !/NLn -! !/BTn -! !/DBn -! !/TRn -! !/BSn -! !/XXn -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ Required modules -!/ - USE W3GSRUMD -!/ -!/ Specify default accessibility -!/ - PUBLIC -!/ -!/ Module private variable for checking error returns -!/ - INTEGER, PRIVATE :: ISTAT -!/ -!/ Conventional declarations -!/ - INTEGER :: NGRIDS = -1, IGRID = -1, ISGRD = -1, & - IPARS = -1, NAUXGR -! +MODULE W3GDATMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ ! J. H. Alves ! + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-Apr-2020 | + !/ +-----------------------------------+ + !/ + !/ 24-Jun-2005 : Origination. ( version 3.07 ) + !/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) + !/ 23-Jun-2006 : Add data for W3SLN1. ( version 3.09 ) + !/ 18-Jul-2006 : Add input grids. ( version 3.10 ) + !/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) + !/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) + !/ ( J. H. Alves ) + !/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) + !/ ( J. H. Alves ) + !/ 06-Aug-2007 : Fixing SLNP !/SEED bug. ( version 3.13 ) + !/ 18-Sep-2007 : Adding WAM4 source terms. ( version 3.13 ) + !/ ( F. Ardhuin ) + !/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) + !/ 27-Jun-2008 : Expand WAM4 variants namelist ( version 3.14 ) + !/ ( F. Ardhuin ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.1 ) + !/ (A. Roland and F. Ardhuin) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) + !/ factor with DXDP and DXDQ terms. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 05-Apr-2011 : Implement interations for DTMAX < 1s( version 3.14.1 ) + !/ (F. Ardhuin) + !/ 01-Jul-2011 : Movable bed bottom friction BT4 ( version 4.01 ) + !/ 03-Nov-2011 : Bug fix: GUGINIT initialization ( version 4.04 ) + !/ 29-Nov-2011 : Adding ST6 source term option. ( version 4.04 ) + !/ (S. Zieger) + !/ 14-Mar-2012 : Add PSIC for BT4 ( version 4.04 ) + !/ 12-Jun-2012 : Add /RTD option or rotated grid variables. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear + !/ filter (SNLS) from 3.15 (HLT). ( version 4.08 ) + !/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) + !/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.09 ) + !/ 16-Sep-2013 : Add Arctic part SMC grid. ( version 4.11 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 16-Nov-2013 : Allows reflection on curvi grids ( version 4.14 ) + !/ 26-Jul-2013 : Adding IG waves ( version 4.16 ) + !/ 18-Dec-2013 : Moving FLAGLL into GRID TYPE ( version 4.16 ) + !/ 11-Jun-2014 : Changed reflection for subgrid ( version 5.01 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 21-Aug-2015 : Add SMC FUNO3, FVERG options. JGLi ( version 5.09 ) + !/ 04-May-2016 : Add IICEDISP GB&FA ( version 5.10 ) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ 20-Jan-2017 : Change to preprocessor macros to enable test output. + !/ (T.J. Campbell, NRL) ( version 6.02 ) + !/ 20-Jan-2017 : Change calculation of curvilinear grid metric and + !/ derivatives calculations to use W3GSRUMD:W3CGDM. + !/ (T.J. Campbell, NRL) ( version 6.02 ) + !/ 07-Jan-2018 : Generalizes ICE100WIND to ICESCALES ( version 6.04 ) + !/ 26-Mar-2018 : Add FSWND optional variable. JGLi ( version 6.02 ) + !/ 05-Jun-2018 : Add PDLIB/DEBUGINIT and implcit scheme parameters + !/ for unstructured grids ( version 6.04 ) + !/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) + !/ 20-Aug-2018: Extra namelist variables for ST6 ( version 6.06) + !/ (Q. Liu, UoM) + !/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) + !/ 27-Aug-2018 : Add BTBETA parameter ( version 6.06 ) + !/ 22-Feb-2020 : Add AIRGB and AIRCMIN ( version 7.06 ) + !/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) + !/ 06-May-2021 : Add SMCTYPE, ARCTC options. JGLi ( version 7.12 ) + !/ 07-Jun-2021 : the GKE module (NL5, Q. Liu) ( version 7.12 ) + !/ + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Define data structures to set up wave model grids and aliases + ! to use individual grids transparently. Also includes subroutines + ! to manage data structure and pointing to individual models. + ! Definition of grids and model set up. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NGRIDS Int. Public Number of grids, initialized at -1 + ! to check proper model initialization. + ! NAUXGR Int. Public Auxiliary grids. + ! IGRID Int. Public Selected spatial grid, init. at -1. + ! ISGRD Int. Public Selected spectral grid, init. at -1. + ! IPARS Int. Public Selected num. and ph. pars, init. at -1. + ! RLGTYPE I.P. Public Named constant for rectilinear grid type + ! CLGTYPE I.P. Public Named constant for curvilinear grid type + ! UNGTYPE I.P. Public Named constant for Unstructured triangular grid + ! SMCTYPE I.P. Public Named constant for unstructured SMC grid type + ! FLAGLL Log. Public Flag to indicate coordinate system for all grids + ! .TRUE.: Spherical (lon/lat in degrees) + ! .FALSE.: Cartesian (meters) + ! GRID TYPE Public Data structure defining grid. + ! GRIDS GRID Public Array of grids. + ! SGRD TYPE Public Data structure defining spectral grid. + ! SGRDS GRID Public Array of spectral grids. + ! MPAR TYPE Public Data structure with all other model + ! parameters. + ! MPARS GRID Public Array of MPAR. + ! ---------------------------------------------------------------- + ! + ! All elements of GRID are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! GTYPE Int. Public Flag for type of grid + ! RLGTYPE: Rectilinear grid + ! CLGTYPE: Curvilinear grid + ! UNGTYPE: Unstructured triangular grid + ! SMCTYPE: Unstructured SMC grid + ! RSTYPE Int. Public Integer identifyng restart type + ! ICLOSE Int. Public Parameter indicating type of index closure of grid. + ! ICLOSE_NONE: No grid closure + ! ICLOSE_SMPL: Simple grid closure + ! Grid is periodic in the i-index and wraps at + ! I=NX+1. In other words, (NX+1,J) => (1,J). + ! ICLOSE_TRPL: Tripole grid closure + ! Grid is periodic in the i-index and and wraps at + ! I=NX+1 and has closure at J=NY+1. In other words, + ! (NX+1,J<=NY) => (1,J) and + ! (I,NY+1) => (MOD(NX-I+1,NX)+1,NY). The tripole + ! closure requires that NX be even. + ! NX, NY Int. Public Discrete dimensions of spatial grid. + ! NSEA(L) Int. Public Number of sea points (local for MPP). + ! NU/VFc Int. Public Number of U/V faces for SMC grid. + ! NRLv Int. Public Number of refined levels for SMC grid. + ! NGLO Int. Public Number of cells in global part for SMC grid. + ! NARC Int. Public Number of cells in Arctic part for SMC grid. + ! NBAC Int. Public Number of boundary cells in Arctic part. + ! NBGL Int. Public Number of boundary cells in global part. + ! NBSMC Int. Public Number of boundary cells for regional SMC grid. + ! TRFLAG Int. Public Flag for use of transparencies + ! 0: No sub-grid obstacles. + ! 1: Obstructions at cell boundaries. + ! 2: Obstructions at cell centers. + ! 3: Like 1 with continuous ice. + ! 4: Like 2 with continuous ice. + ! MAPSTA I.A. Public Grid status map. + ! MAPST2 I.A. Public Second grid status map. + ! MAPxx I.A. Public Storage grid maps. + ! IJKCel I.A. Public Cell info array for SMC grid. + ! IJKU/VFc I.A. Public U/V-Face arrays for SMC grid. + ! NLv* I.A. Public Cell, U/V-Face numbers of refine levels. + ! ICLBAC I.A. Public Mapping index for Arctic boundary cells. + ! ISMCBP I.A. Public List of SMC grid input boundary cell indexes. + ! SX,SY Real Public Spatial (rectilinear) grid increments. + ! X0,Y0 Real Public Lower left corner of spatial (rectilinear) grid. + ! DTCFL Real Public Maximum CFL time step X-Y propagation. + ! DTCFLI Real Public Id. intra-spectral. + ! DTMAX Real Public Maximum overall time step. + ! DTMIN Real Public Minimum dynamic time step for source + ! NITERSEC1 Real Public Number of interations when DTMAX < 1s + ! DMIN Real Public Minimum water depth. + ! CTMAX Real Public Maximum CFL number for depth refr. + ! FICE0/N Real Public Cut-off ice conc. for ice coverage. + ! FICEL Real Public Length scale for sea ice damping + ! IICEHMIN Real Public Minimum thickness of sea ice + ! IICEHDISP Real Public Minimum thickness of sea ice in the dispersion relation before relaxing the conv. criterion + ! IICEHFAC Real Public Scale factor for sea ice thickness + ! IICEHINIT Real Public Initial value of ice thickness + ! ICESCALES R.A. Publ. Scaling coefficient for source terms in the presence of ice + ! Default is 1.0, meaning that 100% ice + ! concentration result in zero source term + ! If set to 0.0, then ice has no direct impact on Sln / Sin / Snl / Sds + ! IC3PARS R.A. Public various parameters for use in IC4, handled as + ! an array for simplicity + ! IC4_KI R.A. Public KI (dissipation rate) values for use in IC4 + ! IC4_FC R.A. Public FC (frequency bin separators) for use in IC4 + ! PFMOVE Real Public Tunable parameter in GSE correction + ! for moving grids. + ! GRIDSHIFT Real Public Grid offset for multi-grid w/SCRIP + ! CMPRTRCK Log. Public True for traditional compression of track output + ! PoLat/Lon R.A. Public Rotated N-Pole standard latitude/longitude. + ! AnglD R.A. Public Rotation angle in degree to turn rotated grid + ! back to standard grid. JGLi12Jun2012 + ! FLAGUNR Log. Public True if rotating directions back to true north + ! STEXU Real Public Length-scale (X) for space-time extreme averaging + ! STEYU Real Public Length-scale (Y) for space-time extreme averaging + ! STEDU Real Public Time-scale for space-time extreme averaging + ! ZB R.A. Public Bottom levels on storage grid. + ! CLATS(I) R.A. Public (Inverse) cosine of latitude at sea points. + ! CTHG0S R.A. Public Constant in great-circle refr. term at sea points. + ! TRNX/Y R.A. Public Transparencies in X/Y for sub-grid + ! CTRNX/Y R.A. Public Sub-grid transparencies for SMC grid. + ! ANGARC R.A. Public Rotation angle in degree for Arctic cells. + ! SPCBAC R.A. Public Full 2-D spectra for Arctic boundary cells. + ! X/YGRD R.A. Public Spatial grid coordinate arrays. + ! SX/SYGRD R.A. Public Spatial grid increment arrays. + ! GINIT Log. Public Flag identifying grid initialization. + ! FLDRY Log. Public Flag for 'dry' run (IO and data + ! processing only). + ! FLCx Log. Public Flags for prop. is different spaces. + ! FLSOU Log. Public Flag for source term calculation. + ! FUNO3 Log. Public Flag for 3rd order UNO3 scheme on SMC grid. + ! FVERG Log. Public Flag for 1-2-1 averaging smoothing on SMC grid. + ! FSWND Log. Public Flag for sea-point only wind input on SMC grid. + ! ARCTC Log. Public Flag to include Arctic polar part on SMC grid. + ! FLAGST L.A. Public Flag for source term computations + ! for individual grid points. + ! IICEDISP Log. Public Flag for use of the ice covered dispertion relation. + ! IICESMOOTH Log. Public Flag to smooth the ice covered dispertion relation in broken ice. + ! + ! + ! GNAME C*30 Public Grid name. + ! FILEXT C*13 Public Extension of WAVEWATCH III file names + ! default in 'ww3'. + ! BTBETA Real Public The constant used for separating wind sea + ! and swell when we estimate WBT + ! ---------------------------------------------------------------- + ! + ! All elements of SGRD are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NK Int. Public Number of discrete wavenumbers. + ! NK2 Int. Public Extended wavenumber range. + ! NTH Int. Public Number of discrete directions. + ! NSPEC Int. Public Number of discrete spectral bins. + ! MAPxx I.A. Public Spectral maps. + ! DTH Real Public Directional increments (radians). + ! XFR Real Public Frequency multiplication factor. + ! FR1 Real Public Lowest frequency (Hz) + ! FTE Real Public Factor in tail integration energy. + ! FTF Real Public Id. frequency. + ! FTWN Real Public Id. wavenumber. + ! FTTR Real Public Id. wave period. + ! FTWL Real Public Id. wave length. + ! FACTIn Real Public Factors for obtaining integer cut-off + ! frequency. + ! FACHFx Real Public Factor for tail. + ! TH R.A Public Directions (radians). + ! ESIN R.A Public Sine of discrete directions. + ! ECOS R.A Public Cosine of discrete directions. + ! ES2, ESC, EC2 + ! R.A Public Sine and cosine products + ! SIG R.A Public Relative frequencies (invariant + ! in grid). (rad) + ! SIG2 R.A Public Id. for full 2-D spectrum. + ! DSIP R.A Public Frequency bandwidths (prop.) (rad) + ! DSII R.A Public Frequency bandwidths (int.) (rad) + ! DDEN R.A Public DSII * DTH * SIG (for integration + ! based on energy) + ! DDEN2 R.A Public Idem, full spectrum. + ! SINIT Log. Public Flag identifying grid initialization. + ! ---------------------------------------------------------------- + ! + ! The structure MPAR contains all other model parameters for + ! numerical methods and physical parameterizations. It contains + ! itself several structures as outlined below. + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! PINIT Log. Public Flag identifying initialization. + ! NPARS NPAR Public Numerical parameters, + ! PROPS PROP Public Parameters propagatrion schemes. + ! SFLPS SFLP Public Parameters for flux computation. + ! SLNPS SLNP Public Parameters Sln. + ! SRCPS SRCP Public Parameters Sin and Sds. + ! SNLPS SNLP Public Parameters Snl. + ! SBTPS SBTP Public Parameters Sbt. + ! SDBPS SDBP Public Parameters Sdb. + ! STRPS STRP Public Parameters Str. + ! SBSPS SBSP Public Parameters Sbs. + ! ---------------------------------------------------------------- + ! + ! The structure NPAR contains numerical parameters and is aliased + ! as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! FACP Real Public Constant in maximum par. change in + ! dynamic integration scheme (depends + ! upon Xp). + ! XREL Real Public Id. relative change. + ! XFLT Real Public Id. filter level. + ! FXFM Real Public Constant for mean frequency in + ! cut-off. (!/ST1) + ! FXPM Real Public Id. PM. + ! XFT Real Public Constant for cut-off freq. (!/ST2) + ! XFC Real Public Id. + ! FACSD Real Public Constant in seeding algorithm. + ! FHMAX Real Public Hs/depth ratio in limiter (!/MLIM) + ! RWINDC Real Public Coefficient for current in relative + ! wind (!/RWND) + ! WWCOR R.A. Public Wind correction factors (!/WCOR) + ! ---------------------------------------------------------------- + ! + ! The structure PROP contains parameters for the propagation + ! schemes and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! DTME Real Public Swell age in disp. corr. (!/PR2) + ! CLATMN Real Public Id. minimum cosine of lat. (!/PR2) + ! DTMS Real Public Swell age in disp. corr. (!/SMC) + ! + ! WDCG Real Public Factors in width of av. Cg. (!/PR3) + ! WDTH Real Public Factors in width of av. Th. (!/PR3) + ! ---------------------------------------------------------------- + ! + ! The structure SFLP contains parameters for the fluxes + ! and is aliased as above: + ! ---------------------------------------------------------------- + ! (!/FLX2) + ! NITTIN Int. Public Number of itterations for drag calc. + ! CINXSI Real Public Constant in parametric description + ! (!/FLX3) + ! NITTIN Int. Public Number of itterations for drag calc. + ! CAP_ID Int Public Type of cap used. + ! CINXSI Real Public Constant in parametric description + ! CD_MAX Real Public Cap on Cd. + ! (!/FLX4) + ! FLX4A0 Real Public Scaling value in parametric description + ! ---------------------------------------------------------------- + ! + ! The structure SLNP contains parameters for the linear input + ! source terms and is aliased as above: + ! + ! ---------------------------------------------------------------- + ! (!/LN1) + ! SLNC1 Real Public Proportionality and other constants in + ! input source term. + ! FSPM Real Public Factor for fPM in filter. + ! FSHF Real Public Factor for fh in filter. + ! ---------------------------------------------------------------- + ! + ! The structure SRCP contains parameters for the input and dis, + ! source terms and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WWNMEANPTAIL R Public Power of tail for WNMEAN calculation + ! SSTXFTFTAIL R Public Tail factor for WNMEAN calculation + ! (!/ST1) + ! SINC1 Real Public Proportionality and other constants in + ! input source term. + ! SDSC1 Real Public Combined constant in dissipation + ! source term. + ! (!/ST2) + ! ZWIND Real Public Height at which the wind is defined + ! of drag. + ! FSWELL Real Public Reduction factor of negative input + ! for swell. + ! SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS + ! Real Public Factors in effective wind speed. + ! CDSAn Real Public Constants in high-freq. dis. + ! SDSALN Real Public Factor for nondimensional 1-D spectrum. + ! CDSBn Real Public Constants in parameterization of PHI. + ! XFH Real Public Constant for turbulent length scale. + ! XFn Real Public Constants in combining low and high + ! frequency dissipation. + ! (!/ST3) + ! ZZWND Real Public Height at which the wind is defined + ! AALPHA Real Public Minimum value of charnock parameter + ! BBETA Real Public Wind-wave coupling coefficient + ! ZZALP Real Public Wave age tuning coefficient in Sin + ! TTAUWSHELTER Real Public Sheltering coefficient for short waves + ! ZZ0MAX Real Public Maximum value of air-side roughness + ! ZZ0RAT Real Public ratio of roughness for mean and + ! oscillatory flows + ! SSINTHP Real Public Power in cosine of wind input + ! SSWELLF R.A. Public Swell damping coefficients + ! SSDSCn Real Public Dissipation parameters + ! SSDSBR Real Public Threshold in saturation spectrum for Sds + ! SSDSP Real Public Power of B(k) in Sds + ! WWNMEANP Real Public Power that defines the mean wavenumber + ! in Sds + ! SSTXFTF, SSTXFTWN Real Public Tail constants + ! SSDSC4, Real Public Threshold shift in saturation diss. + ! SSDSC5, Real Public Wave-turbulence dissipation factor + ! SSDSC6, Real Public dissipation parameter + ! DDELTA1 Real Public Low-frequency dissipation coefficient + ! in WAM4 + ! DDELTA2 Real Public High-frequency dissipation coefficient + ! in WAM4 + ! SSDSDTH Real Public Maximum angular sector for saturation + ! spectrum + ! SSDSCOS Real Public Power of cosine in saturation integral + ! SSDSISO Int. Public Choice of definition of the isotropic + ! saturation + ! ---------------------------------------------------------------- + ! + ! The structure SNLP contains parameters for the nonl. inter. + ! source term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! (!/NL1) + ! SNLC1 Real Public Scaled proportionality constant. + ! LAM Real Public Factor defining quadruplet. + ! KDCON Real Public Conversion factor for relative depth. + ! KDMN Real Public Minimum relative depth. + ! SNLSn Real Public Constants in shallow water factor. + ! (!/NL2) + ! IQTPE Int. Public Type of depth treatment + ! 1 : Deep water + ! 2 : Deep water / WAM scaling + ! 3 : Finite water depth + ! NDPTHS Int. Public Number of depth for which integration + ! space needs to be computed. + ! NLTAIL Real Public Tail factor for parametric tail. + ! DPTHNL R.A. Public Depths corresponding to NDPTHS. + ! *** NOTE: This array is not allocated + ! in the W3DIMP routine *** + ! (!/NL3) + ! NFR Int. Public Number of frequencies or wavenumbers + ! in discrete spectral space (NFR=>NK). + ! NFRMIN Int. Public Minimum discrete frequency in the + ! expanded frequency space. + ! NFRMAX Int. Public Idem maximum for first part. + ! NFRCUT Int. Public Idem maximum for second part. + ! NTHMAX Int. Public Extension of directional space. + ! NTHEXP Int Public Number of bins in extended dir. space. + ! NSPMIN, NSPMAX, NSPMX2 + ! Int. Public 1D spectral space range. + ! FRQ R.A. Public Expanded frequency range (Hz). + ! XSI R.A. Public Expanded frequency range (rad/s). + ! NQA Int. Public Number of actual quadruplets. + ! QST1 I.A. Public Spectral offsets for compuation of + ! quadruplet spectral desnities. + ! QST2 R.A. Public Idem weights. + ! QST3 R.A. Public Proportionality constants and k factors + ! in diagonal strength. + ! QST4 I.A. Public Spectral offsets for combining of + ! interactions and diagonal. + ! QST5 R.A. Public Idem weights for interactions. + ! QST6 R.A. Public Idem weights for diagonal. + ! SNLNQ Int. Public Number of quadruplet definitions. + ! SNLMSC Real Public Tuning power 'deep' scaling. + ! SNLNSC Real Public Tuning power 'shallow' scaling. + ! SNLSFD Real Public 'Deep' nondimensional filer freq. + ! SNLSFS Real Public 'Shallow' nondimensional filer freq. + ! SNLL R.A. Public Array with lambda for quadruplet. + ! SNLM R.A. Public Array with mu for quadruplet. + ! SNLT R.A. Public Array with Dtheta for quadruplet. + ! SNLCD R.A. Public Array with Cd for quadruplet. + ! SNLCS R.A. Public Array with Cs for quadruplet. + ! (!/NL4) + ! ITSA Int. Public Integer indicating TSA (1) or FBI (0) + ! IALT Int. Public Integer determining alternating looping + ! (!/NL5) + ! QR5DPT Real Public Water depth for the GKE module + ! QR5OML Real Public λ cut off value for quasi-resonant quartets + ! QI5DIS Int. Public Method to discretize continuous spectrum + ! QI5KEV Int. Public GKE (GS13 or J03) + ! QI5NNZ Int. Public # of interactive quadruplets + ! QI5IPL Int. Public Interp. method to get C₄ + ! QI5PMX Int. Public Phase mixing related parameter + ! (!/NLS) + ! NTHX Int. Public Expanded discrete direction range. + ! NFRX Int. Public Expanded discrete frequency range. + ! NSPL-H Int. Public Range of 1D spectrum. + ! SNSST R.A. Public Array with interpolation weights. + ! CNLSA Real Public a34 in quadruplet definition. + ! CNLSC Real Public C in Snl definition. + ! CNLSFM Real Public Maximum relative spectral change. + ! CNLSC1/3 Real Public Constant in frequency filter. + ! ---------------------------------------------------------------- + ! + ! The structure SBTP contains parameters for the bottom friction + ! source term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! SBTC1 Real Public Proportionality constant. (!/BT1) + ! SBTCX R.A. Public Parameters for bottom fric. (!/BT4) + ! ---------------------------------------------------------------- + ! + ! The structure SDBP contains parameters for the depth incduced + ! breaking source term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! SDBC1 Real Public Proportionality constant. (!/DB1) + ! SDBC2 Real Public Hmax/d ratio. (!/DB1) + ! FDONLY Log. Public Flag for checking depth only (!/DB1) + ! otherwise Miche criterion. + ! ---------------------------------------------------------------- + ! + ! The structure STRP contains parameters for the triad interaction + ! source term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! The structure SBSP contains parameters for the bottom scattering + ! source term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! The structure SICP contains parameters for arbitrary source + ! term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! IS1C1 Real Public Scale factor for icecon. (!/ISx) + ! IS1C2 Real Public Offset for ice concentration (!/ISx) + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. Public Set number of grids. + ! W3DIMX Subr. Public Set dimensions of spatial grid. + ! W3DIMS Subr. Public Set dimensions of spectral grid. + ! W3SETG Subr. Public Point to selected grid / model. + ! W3GNTX Subr. Public Construct grid arrays + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - In model versions before 3.06 the parameters in the grid + ! structure were stored in the module W3IOGR. + ! - No subroutine DIMP is provided, instead, arrays are set + ! one-by-one in W3IOGR. + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! !/PRn Select propagation scheme + ! !/SMC UNO2 propagation on SMC grid. + ! + ! !/LNn Select source terms + ! !/STn + ! !/NLn + ! !/BTn + ! !/DBn + ! !/TRn + ! !/BSn + ! !/XXn + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ Required modules + !/ + USE W3GSRUMD + !/ + !/ Specify default accessibility + !/ + PUBLIC + !/ + !/ Module private variable for checking error returns + !/ + INTEGER, PRIVATE :: ISTAT + !/ + !/ Conventional declarations + !/ + INTEGER :: NGRIDS = -1, IGRID = -1, ISGRD = -1, & + IPARS = -1, NAUXGR + ! #ifdef W3_IC4 - INTEGER, PARAMETER :: NIC4=10 + INTEGER, PARAMETER :: NIC4=10 #endif - INTEGER, PARAMETER :: RLGTYPE = 1 - INTEGER, PARAMETER :: CLGTYPE = 2 - INTEGER, PARAMETER :: UNGTYPE = 3 - INTEGER, PARAMETER :: SMCTYPE = 4 + INTEGER, PARAMETER :: RLGTYPE = 1 + INTEGER, PARAMETER :: CLGTYPE = 2 + INTEGER, PARAMETER :: UNGTYPE = 3 + INTEGER, PARAMETER :: SMCTYPE = 4 - INTEGER, PARAMETER :: ICLOSE_NONE = ICLO_NONE - INTEGER, PARAMETER :: ICLOSE_SMPL = ICLO_SMPL - INTEGER, PARAMETER :: ICLOSE_TRPL = ICLO_TRPL -! -! Dimensions of tables for pre-computing of dissipation -! + INTEGER, PARAMETER :: ICLOSE_NONE = ICLO_NONE + INTEGER, PARAMETER :: ICLOSE_SMPL = ICLO_SMPL + INTEGER, PARAMETER :: ICLOSE_TRPL = ICLO_TRPL + ! + ! Dimensions of tables for pre-computing of dissipation + ! #ifdef W3_ST4 - INTEGER, PARAMETER :: NKHS=2000, NKD=1300 - INTEGER, PARAMETER :: NDTAB=2000 -#endif -!/ -!/ Data structures -!/ -!/ Grid type - TYPE GRID ! this is the geographical grid with all associated parameters - INTEGER :: GTYPE - INTEGER :: RSTYPE = -1 - INTEGER :: ICLOSE - INTEGER :: NX, NY, NSEA, NSEAL, TRFLAG + INTEGER, PARAMETER :: NKHS=2000, NKD=1300 + INTEGER, PARAMETER :: NDTAB=2000 +#endif + !/ + !/ Data structures + !/ + !/ Grid type + TYPE GRID ! this is the geographical grid with all associated parameters + INTEGER :: GTYPE + INTEGER :: RSTYPE = -1 + INTEGER :: ICLOSE + INTEGER :: NX, NY, NSEA, NSEAL, TRFLAG #ifdef W3_SEC1 - INTEGER :: NITERSEC1 + INTEGER :: NITERSEC1 #endif - INTEGER, POINTER :: MAPSTA(:,:), MAPST2(:,:), & - MAPFS(:,:), MAPSF(:,:) -! + INTEGER, POINTER :: MAPSTA(:,:), MAPST2(:,:), & + MAPFS(:,:), MAPSF(:,:) + ! #ifdef W3_SMC - !!Li Cell and face arrays for SMC grid. - INTEGER :: NCel, NUFc, NVFc, NRLv, MRFct - INTEGER :: NGLO, NARC, NBGL, NBAC, NBSMC - INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) - INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) - INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) + !!Li Cell and face arrays for SMC grid. + INTEGER :: NCel, NUFc, NVFc, NRLv, MRFct + INTEGER :: NGLO, NARC, NBGL, NBAC, NBSMC + INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) + INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) + INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) -!/ Data duplicated for better performance - INTEGER, POINTER :: IJKCel3(:), IJKCel4(:), & - IJKVFc5(:), IJKVFc6(:), & - IJKUFc5(:), IJKUFc6(:) -#endif -! - REAL :: SX, SY, X0, Y0, DTCFL, DTCFLI, DTMAX, & - DTMIN, DMIN, CTMAX, FICE0, FICEN, FICEL, & - PFMOVE, STEXU, STEYU, STEDU, IICEHMIN, & - IICEHINIT, ICESCALES(4), IICEHFAC, IICEHDISP, & - IICEDDISP, IICEFDISP, BTBETA, AAIRCMIN, AAIRGB + !/ Data duplicated for better performance + INTEGER, POINTER :: IJKCel3(:), IJKCel4(:), & + IJKVFc5(:), IJKVFc6(:), & + IJKUFc5(:), IJKUFc6(:) +#endif + ! + REAL :: SX, SY, X0, Y0, DTCFL, DTCFLI, DTMAX, & + DTMIN, DMIN, CTMAX, FICE0, FICEN, FICEL, & + PFMOVE, STEXU, STEYU, STEDU, IICEHMIN, & + IICEHINIT, ICESCALES(4), IICEHFAC, IICEHDISP, & + IICEDDISP, IICEFDISP, BTBETA, AAIRCMIN, AAIRGB - REAL(8) :: GRIDSHIFT ! see notes in WMGHGH + REAL(8) :: GRIDSHIFT ! see notes in WMGHGH #ifdef W3_RTD - REAL :: PoLat, PoLon ! Rotated N-Pole lat/lon - REAL, POINTER :: AnglD(:) ! Angle in degree - LOGICAL :: FLAGUNR + REAL :: PoLat, PoLon ! Rotated N-Pole lat/lon + REAL, POINTER :: AnglD(:) ! Angle in degree + LOGICAL :: FLAGUNR #endif - REAL , POINTER :: ZB(:) ! BOTTOM GRID, DEFINED ON ISEA - REAL , POINTER :: CLATS(:) ! COS(LAT), DEFINED ON SEA POINTS - REAL , POINTER :: CLATIS(:) ! INVERSE OF COS(LAT) DEFINED ON ISEA - REAL , POINTER :: CTHG0S(:) ! TAN(Y)/R, DEFINED ON ISEA + REAL , POINTER :: ZB(:) ! BOTTOM GRID, DEFINED ON ISEA + REAL , POINTER :: CLATS(:) ! COS(LAT), DEFINED ON SEA POINTS + REAL , POINTER :: CLATIS(:) ! INVERSE OF COS(LAT) DEFINED ON ISEA + REAL , POINTER :: CTHG0S(:) ! TAN(Y)/R, DEFINED ON ISEA - REAL , POINTER :: TRNX(:,:), TRNY(:,:) ! TRANSPARENCY INFORMATION ON IX,IY + REAL , POINTER :: TRNX(:,:), TRNY(:,:) ! TRANSPARENCY INFORMATION ON IX,IY #ifdef W3_SMC - REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) -#endif - REAL , POINTER :: SPCBAC(:,:), ANGARC(:) - DOUBLE PRECISION, POINTER :: XGRD(:,:), YGRD(:,:) ! X AND Y DEFINED ON IX,IY - REAL , POINTER :: DXDP(:,:), DXDQ(:,:) ! DX/DP & DX/DQ DEFINED ON IX,IY - REAL , POINTER :: DYDP(:,:), DYDQ(:,:) ! DY/DP & DY/DQ DEFINED ON IX,IY - REAL , POINTER :: DPDX(:,:), DPDY(:,:) ! DP/DX & DP/DY DEFINED ON IX,IY - REAL , POINTER :: DQDX(:,:), DQDY(:,:) ! DQ/DX & DQ/DY DEFINED ON IX,IY - REAL , POINTER :: GSQRT(:,:) ! SQRT(G) DEFINED ON IX,IY - REAL , POINTER :: HPFAC(:,:) ! H_P = SQRT(G_PP) DEFINED ON IX,IY - REAL , POINTER :: HQFAC(:,:) ! H_Q = SQRT(G_QQ) DEFINED ON IX,IY + REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) +#endif + REAL , POINTER :: SPCBAC(:,:), ANGARC(:) + DOUBLE PRECISION, POINTER :: XGRD(:,:), YGRD(:,:) ! X AND Y DEFINED ON IX,IY + REAL , POINTER :: DXDP(:,:), DXDQ(:,:) ! DX/DP & DX/DQ DEFINED ON IX,IY + REAL , POINTER :: DYDP(:,:), DYDQ(:,:) ! DY/DP & DY/DQ DEFINED ON IX,IY + REAL , POINTER :: DPDX(:,:), DPDY(:,:) ! DP/DX & DP/DY DEFINED ON IX,IY + REAL , POINTER :: DQDX(:,:), DQDY(:,:) ! DQ/DX & DQ/DY DEFINED ON IX,IY + REAL , POINTER :: GSQRT(:,:) ! SQRT(G) DEFINED ON IX,IY + REAL , POINTER :: HPFAC(:,:) ! H_P = SQRT(G_PP) DEFINED ON IX,IY + REAL , POINTER :: HQFAC(:,:) ! H_Q = SQRT(G_QQ) DEFINED ON IX,IY - LOGICAL :: GINIT, FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU, IICEDISP,& - IICESMOOTH - LOGICAL :: FLAGLL - LOGICAL :: CMPRTRCK - LOGICAL, POINTER :: FLAGST(:) - CHARACTER(LEN=30):: GNAME - CHARACTER(LEN=13):: FILEXT - LOGICAL :: GUGINIT + LOGICAL :: GINIT, FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU, IICEDISP,& + IICESMOOTH + LOGICAL :: FLAGLL + LOGICAL :: CMPRTRCK + LOGICAL, POINTER :: FLAGST(:) + CHARACTER(LEN=30):: GNAME + CHARACTER(LEN=13):: FILEXT + LOGICAL :: GUGINIT #ifdef W3_REF1 - REAL, POINTER :: REFLC(:,:) ! reflection coefficient - INTEGER, POINTER :: REFLD(:,:) ! reflection direction -#endif - INTEGER :: E3DF(3,5), P2MSF(3), US3DF(3), USSPF(2) ! freq. indices for 3D output - REAL :: USSP_WN(25) !Max set to 25 decay scales. -! - TYPE(T_GSU) :: GSU ! Grid search utility object -! - REAL :: FFACBERG ! mutiplicative factor for iceberg mask + REAL, POINTER :: REFLC(:,:) ! reflection coefficient + INTEGER, POINTER :: REFLD(:,:) ! reflection direction +#endif + INTEGER :: E3DF(3,5), P2MSF(3), US3DF(3), USSPF(2) ! freq. indices for 3D output + REAL :: USSP_WN(25) !Max set to 25 decay scales. + ! + TYPE(T_GSU) :: GSU ! Grid search utility object + ! + REAL :: FFACBERG ! mutiplicative factor for iceberg mask #ifdef W3_BT4 - REAL, POINTER :: SED_D50(:), SED_PSIC(:) + REAL, POINTER :: SED_D50(:), SED_PSIC(:) #endif #ifdef W3_REF1 - LOGICAL, POINTER :: RREF(:) - REAL, POINTER :: REFPARS(:) + LOGICAL, POINTER :: RREF(:) + REAL, POINTER :: REFPARS(:) #endif #ifdef W3_IG1 - REAL, POINTER :: IGPARS(:) + REAL, POINTER :: IGPARS(:) #endif #ifdef W3_IC2 - REAL, POINTER :: IC2PARS(:) + REAL, POINTER :: IC2PARS(:) #endif #ifdef W3_IC3 - REAL, POINTER :: IC3PARS(:) + REAL, POINTER :: IC3PARS(:) #endif #ifdef W3_IC4 - INTEGER, POINTER :: IC4PARS(:) - REAL, POINTER :: IC4_KI(:) - REAL, POINTER :: IC4_FC(:) + INTEGER, POINTER :: IC4PARS(:) + REAL, POINTER :: IC4_KI(:) + REAL, POINTER :: IC4_FC(:) #endif #ifdef W3_IC5 - REAL, POINTER :: IC5PARS(:) + REAL, POINTER :: IC5PARS(:) #endif #ifdef W3_IS2 - REAL, POINTER :: IS2PARS(:) + REAL, POINTER :: IS2PARS(:) #endif -! -! unstructured data -! - INTEGER :: NTRI - INTEGER, POINTER :: TRIGP(:,:) + ! + ! unstructured data + ! + INTEGER :: NTRI + INTEGER, POINTER :: TRIGP(:,:) #ifdef W3_PDLIB - INTEGER :: NBND_MAP - INTEGER, POINTER :: INDEX_MAP(:) - INTEGER, POINTER :: MAPSTA_LOC(:) - INTEGER*1, POINTER :: IOBPD_LOC(:,:) - INTEGER*2, POINTER :: IOBP_LOC(:) - INTEGER*1, POINTER :: IOBDP_LOC(:) - INTEGER*1, POINTER :: IOBPA_LOC(:) + INTEGER :: NBND_MAP + INTEGER, POINTER :: INDEX_MAP(:) + INTEGER, POINTER :: MAPSTA_LOC(:) + INTEGER*1, POINTER :: IOBPD_LOC(:,:) + INTEGER*2, POINTER :: IOBP_LOC(:) + INTEGER*1, POINTER :: IOBDP_LOC(:) + INTEGER*1, POINTER :: IOBPA_LOC(:) #endif - REAL(8), POINTER :: LEN(:,:),SI(:), IEN(:,:) + REAL(8), POINTER :: LEN(:,:),SI(:), IEN(:,:) - REAL :: MAXX, MAXY, DXYMAX - REAL, POINTER :: ANGLE(:,:),ANGLE0(:,:) - INTEGER :: COUNTRI,COUNTOT,NNZ, NBEDGE - INTEGER, POINTER :: CCON(:), COUNTCON(:), IE_CELL(:), & - POS_CELL(:), & - IAA(:), JAA(:), POSI(:,:), INDEX_CELL(:), & - I_DIAG(:), JA_IE(:,:,:) - INTEGER*2, POINTER :: IOBP(:) - INTEGER*1, POINTER :: IOBPD(:,:), IOBDP(:), IOBPA(:) - INTEGER, POINTER :: EDGES(:,:), NEIGH(:,:) - REAL(8), POINTER :: TRIA(:) - REAL, POINTER :: CROSSDIFF(:,:) + REAL :: MAXX, MAXY, DXYMAX + REAL, POINTER :: ANGLE(:,:),ANGLE0(:,:) + INTEGER :: COUNTRI,COUNTOT,NNZ, NBEDGE + INTEGER, POINTER :: CCON(:), COUNTCON(:), IE_CELL(:), & + POS_CELL(:), & + IAA(:), JAA(:), POSI(:,:), INDEX_CELL(:), & + I_DIAG(:), JA_IE(:,:,:) + INTEGER*2, POINTER :: IOBP(:) + INTEGER*1, POINTER :: IOBPD(:,:), IOBDP(:), IOBPA(:) + INTEGER, POINTER :: EDGES(:,:), NEIGH(:,:) + REAL(8), POINTER :: TRIA(:) + REAL, POINTER :: CROSSDIFF(:,:) #ifdef W3_UOST - CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW - LOGICAL, ALLOCATABLE :: UOST_LCL_OBSTRUCTED(:,:), UOST_SHD_OBSTRUCTED(:,:) - INTEGER*1, ALLOCATABLE :: UOSTLOCALALPHA(:,:,:,:), UOSTLOCALBETA(:,:,:,:) - INTEGER*1, ALLOCATABLE :: UOSTSHADOWALPHA(:,:,:,:), UOSTSHADOWBETA(:,:,:,:) - REAL*4, ALLOCATABLE :: UOSTCELLSIZE(:,:,:) - REAL :: UOSTABMULTFACTOR = 100 - REAL :: UOSTCELLSIZEFACTOR = 1000 - REAL :: UOSTLOCALFACTOR = 1 - REAL :: UOSTSHADOWFACTOR = 1 - LOGICAL :: UOSTENABLED = .true. + CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW + LOGICAL, ALLOCATABLE :: UOST_LCL_OBSTRUCTED(:,:), UOST_SHD_OBSTRUCTED(:,:) + INTEGER*1, ALLOCATABLE :: UOSTLOCALALPHA(:,:,:,:), UOSTLOCALBETA(:,:,:,:) + INTEGER*1, ALLOCATABLE :: UOSTSHADOWALPHA(:,:,:,:), UOSTSHADOWBETA(:,:,:,:) + REAL*4, ALLOCATABLE :: UOSTCELLSIZE(:,:,:) + REAL :: UOSTABMULTFACTOR = 100 + REAL :: UOSTCELLSIZEFACTOR = 1000 + REAL :: UOSTLOCALFACTOR = 1 + REAL :: UOSTSHADOWFACTOR = 1 + LOGICAL :: UOSTENABLED = .true. #endif - END TYPE GRID -! - TYPE SGRD ! this is the spectral grid with all parameters that vary with freq. and direction - INTEGER :: NK=0, NK2=0, NTH=0, NSPEC=0 - INTEGER, POINTER :: MAPWN(:), MAPTH(:) - REAL :: DTH=0., XFR=0., FR1=0., FTE=0., FTF=0., FTWN=0., FTTR=0., & - FTWL=0., FACTI1=0., FACTI2=0., FACHFA=0., FACHFE=0. - REAL, POINTER :: TH(:), ESIN(:), ECOS(:), ES2(:), & - ESC(:), EC2(:), SIG(:), SIG2(:), & - DSIP(:), DSII(:), DDEN(:), DDEN2(:) - LOGICAL :: SINIT=.FALSE. - END TYPE SGRD -! - TYPE NPAR - REAL :: FACP, XREL, XFLT, FXFM, FXPM, & - XFT, XFC, FACSD, FHMAX + END TYPE GRID + ! + TYPE SGRD ! this is the spectral grid with all parameters that vary with freq. and direction + INTEGER :: NK=0, NK2=0, NTH=0, NSPEC=0 + INTEGER, POINTER :: MAPWN(:), MAPTH(:) + REAL :: DTH=0., XFR=0., FR1=0., FTE=0., FTF=0., FTWN=0., FTTR=0., & + FTWL=0., FACTI1=0., FACTI2=0., FACHFA=0., FACHFE=0. + REAL, POINTER :: TH(:), ESIN(:), ECOS(:), ES2(:), & + ESC(:), EC2(:), SIG(:), SIG2(:), & + DSIP(:), DSII(:), DDEN(:), DDEN2(:) + LOGICAL :: SINIT=.FALSE. + END TYPE SGRD + ! + TYPE NPAR + REAL :: FACP, XREL, XFLT, FXFM, FXPM, & + XFT, XFC, FACSD, FHMAX #ifdef W3_RWND - REAL :: RWINDC + REAL :: RWINDC #endif #ifdef W3_WCOR - REAL :: WWCOR(2) + REAL :: WWCOR(2) #endif - END TYPE NPAR -! - TYPE PROP + END TYPE NPAR + ! + TYPE PROP #ifdef W3_PR0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_PR1 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_PR2 - REAL :: DTME, CLATMN + REAL :: DTME, CLATMN #endif #ifdef W3_PR3 - REAL :: WDCG, WDTH + REAL :: WDCG, WDTH #endif #ifdef W3_SMC - REAL :: DTMS, Refran - LOGICAL :: FUNO3, FVERG, FSWND, ARCTC + REAL :: DTMS, Refran + LOGICAL :: FUNO3, FVERG, FSWND, ARCTC #endif - END TYPE PROP -! - TYPE FLDP - REAL :: DUMMY + END TYPE PROP + ! + TYPE FLDP + REAL :: DUMMY #ifdef W3_FLD1 - INTEGER :: Tail_ID - REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 + INTEGER :: Tail_ID + REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 #endif #ifdef W3_FLD2 - INTEGER :: Tail_ID - REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 + INTEGER :: Tail_ID + REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 #endif - END TYPE FLDP - TYPE SFLP + END TYPE FLDP + TYPE SFLP #ifdef W3_FLX0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_FLX1 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_FLX2 - INTEGER :: NITTIN - REAL :: CINXSI + INTEGER :: NITTIN + REAL :: CINXSI #endif #ifdef W3_FLX3 - INTEGER :: NITTIN, CAP_ID - REAL :: CINXSI, CD_MAX + INTEGER :: NITTIN, CAP_ID + REAL :: CINXSI, CD_MAX #endif #ifdef W3_FLX4 - REAL :: FLX4A0 + REAL :: FLX4A0 #endif - END TYPE SFLP -! - TYPE SLNP + END TYPE SFLP + ! + TYPE SLNP #ifdef W3_SEED - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_LN0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_LN1 - REAL :: SLNC1, FSPM, FSHF + REAL :: SLNC1, FSPM, FSHF #endif - END TYPE SLNP -! - TYPE SRCP - REAL :: WWNMEANPTAIL, SSTXFTFTAIL + END TYPE SLNP + ! + TYPE SRCP + REAL :: WWNMEANPTAIL, SSTXFTFTAIL #ifdef W3_ST1 - REAL :: SINC1, SDSC1 + REAL :: SINC1, SDSC1 #endif #ifdef W3_ST2 - REAL :: ZWIND, FSWELL, SHSTAB, & - OFSTAB, CCNG, CCPS, FFNG, FFPS, & - CDSA0, CDSA1, CDSA2, SDSALN, & - CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, & - XFH, XF1, XF2 + REAL :: ZWIND, FSWELL, SHSTAB, & + OFSTAB, CCNG, CCPS, FFNG, FFPS, & + CDSA0, CDSA1, CDSA2, SDSALN, & + CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, & + XFH, XF1, XF2 #endif #ifdef W3_ST3 - INTEGER :: SSDSISO, SSDSBRFDF - REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP,& - SSINTHP, TTAUWSHELTER, SSWELLF(1:6), & - SSDSC1, SSDSC2, SSDSC3, SSDSBR, & - SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & - FFXPM, FFXFM, & - SSDSC4, SSDSC5, SSDSC6, DDELTA1, & - DDELTA2, ZZWND -#endif -! + INTEGER :: SSDSISO, SSDSBRFDF + REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP,& + SSINTHP, TTAUWSHELTER, SSWELLF(1:6), & + SSDSC1, SSDSC2, SSDSC3, SSDSBR, & + SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & + FFXPM, FFXFM, & + SSDSC4, SSDSC5, SSDSC6, DDELTA1, & + DDELTA2, ZZWND +#endif + ! #ifdef W3_ST4 - INTEGER :: SSWELLFPAR, SSDSISO, SSDSBRFDF - INTEGER, POINTER :: IKTAB(:,:), SATINDICES(:,:) - REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) - REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP,& - SSINTHP, TTAUWSHELTER, SSWELLF(1:7), & - SSDSC(1:21), SSDSBR, & - SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & - FFXPM, FFXFM, FFXFA, & - SSDSBRF1, SSDSBRF2, SSDSBINT,SSDSBCK,& - SSDSHCK, SSDSABK, SSDSPBK, SSINBR - REAL :: ZZWND - REAL :: SSDSCOS, SSDSDTH, SSDSBT, SSDSBM(0:4) -#endif -! + INTEGER :: SSWELLFPAR, SSDSISO, SSDSBRFDF + INTEGER, POINTER :: IKTAB(:,:), SATINDICES(:,:) + REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) + REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP,& + SSINTHP, TTAUWSHELTER, SSWELLF(1:7), & + SSDSC(1:21), SSDSBR, & + SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & + FFXPM, FFXFM, FFXFA, & + SSDSBRF1, SSDSBRF2, SSDSBINT,SSDSBCK,& + SSDSHCK, SSDSABK, SSDSPBK, SSINBR + REAL :: ZZWND + REAL :: SSDSCOS, SSDSDTH, SSDSBT, SSDSBM(0:4) +#endif + ! #ifdef W3_ST6 - REAL :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, & - SIN6WS, SIN6FC - INTEGER :: SDS6P1, SDS6P2 - LOGICAL :: SDS6ET, SWL6S6, SWL6CSTB1 -#endif - END TYPE SRCP -! - TYPE SNLP + REAL :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, & + SIN6WS, SIN6FC + INTEGER :: SDS6P1, SDS6P2 + LOGICAL :: SDS6ET, SWL6S6, SWL6CSTB1 +#endif + END TYPE SRCP + ! + TYPE SNLP #ifdef W3_NL0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_NL1 - REAL :: SNLC1, LAM, KDCON, KDMN, & - SNLS1, SNLS2, SNLS3 + REAL :: SNLC1, LAM, KDCON, KDMN, & + SNLS1, SNLS2, SNLS3 #endif #ifdef W3_NL2 - INTEGER :: IQTPE, NDPTHS - REAL :: NLTAIL - REAL, POINTER :: DPTHNL(:) + INTEGER :: IQTPE, NDPTHS + REAL :: NLTAIL + REAL, POINTER :: DPTHNL(:) #endif #ifdef W3_NL3 - INTEGER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, & - NTHEXP, NSPMIN, NSPMAX, NSPMX2, & - NQA, SNLNQ - INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) - REAL :: SNLMSC, SNLNSC, SNLSFD, SNLSFS - REAL, POINTER :: FRQ(:), XSI(:), & - QST2(:,:,:), QST3(:,:,:), & - QST5(:,:,:), QST6(:,:,:), & - SNLL(:), SNLM(:), SNLT(:), & - SNLCD(:), SNLCS(:) + INTEGER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, & + NTHEXP, NSPMIN, NSPMAX, NSPMX2, & + NQA, SNLNQ + INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) + REAL :: SNLMSC, SNLNSC, SNLSFD, SNLSFS + REAL, POINTER :: FRQ(:), XSI(:), & + QST2(:,:,:), QST3(:,:,:), & + QST5(:,:,:), QST6(:,:,:), & + SNLL(:), SNLM(:), SNLT(:), & + SNLCD(:), SNLCS(:) #endif #ifdef W3_NL4 - INTEGER :: ITSA, IALT + INTEGER :: ITSA, IALT #endif #ifdef W3_NL5 - REAL :: QR5DPT, QR5OML - INTEGER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX - INTEGER(KIND=8) :: QI5NNZ + REAL :: QR5DPT, QR5OML + INTEGER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX + INTEGER(KIND=8) :: QI5NNZ #endif #ifdef W3_NLS - INTEGER :: NTHX, NFRX, NSPL, NSPH - REAL :: CNLSA, CNLSC, CNLSFM, & - CNLSC1, CNLSC2, CNLSC3 - REAL, POINTER :: SNSST(:,:) + INTEGER :: NTHX, NFRX, NSPL, NSPH + REAL :: CNLSA, CNLSC, CNLSFM, & + CNLSC1, CNLSC2, CNLSC3 + REAL, POINTER :: SNSST(:,:) #endif - END TYPE SNLP -! - TYPE SBTP + END TYPE SNLP + ! + TYPE SBTP #ifdef W3_BT0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_BT1 - REAL :: SBTC1 + REAL :: SBTC1 #endif #ifdef W3_BT4 - REAL :: SBTCX(10) + REAL :: SBTCX(10) #endif #ifdef W3_BT8 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_BT9 - REAL :: DUMMY + REAL :: DUMMY #endif - END TYPE SBTP -! - TYPE SDBP + END TYPE SBTP + ! + TYPE SDBP #ifdef W3_DB0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_DB1 - REAL :: SDBC1, SDBC2 - LOGICAL :: FDONLY - REAL :: SDBSC + REAL :: SDBC1, SDBC2 + LOGICAL :: FDONLY + REAL :: SDBSC #endif - END TYPE SDBP + END TYPE SDBP #ifdef W3_UOST - TYPE UOSTP - CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW - REAL :: UOSTFACTORLOCAL, UOSTFACTORSHADOW - END TYPE UOSTP + TYPE UOSTP + CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW + REAL :: UOSTFACTORLOCAL, UOSTFACTORSHADOW + END TYPE UOSTP #endif -! - TYPE STRP + ! + TYPE STRP #ifdef W3_TR0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_TR1 - REAL :: DUMMY + REAL :: DUMMY #endif - END TYPE STRP -! - TYPE SBSP + END TYPE STRP + ! + TYPE SBSP #ifdef W3_BS0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_BS1 - REAL :: DUMMY + REAL :: DUMMY #endif - END TYPE SBSP -! - TYPE SICP + END TYPE SBSP + ! + TYPE SICP #ifdef W3_IS0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_IS1 - REAL :: IS1C1, IS1C2 + REAL :: IS1C1, IS1C2 #endif #ifdef W3_IS2 - REAL :: IS2C1, IS2C2 -#endif - END TYPE SICP - -! specific type for unstructured scheme - TYPE SCHM - LOGICAL :: FSN = .FALSE. - LOGICAL :: FSPSI = .FALSE. - LOGICAL :: FSFCT = .FALSE. - LOGICAL :: FSNIMP = .FALSE. - LOGICAL :: FSTOTALIMP = .FALSE. - LOGICAL :: FSTOTALEXP = .FALSE. - LOGICAL :: FSREFRACTION = .FALSE. - LOGICAL :: FSFREQSHIFT = .FALSE. - LOGICAL :: FSSOURCE = .FALSE. - LOGICAL :: FSBCCFL = .FALSE. - LOGICAL :: DO_CHANGE_WLV - REAL(8) :: SOLVERTHR_STP - REAL(8) :: CRIT_DEP_STP - LOGICAL :: B_JGS_TERMINATE_MAXITER - LOGICAL :: B_JGS_TERMINATE_DIFFERENCE - LOGICAL :: B_JGS_TERMINATE_NORM - LOGICAL :: B_JGS_LIMITER - LOGICAL :: B_JGS_USE_JACOBI - LOGICAL :: B_JGS_BLOCK_GAUSS_SEIDEL - INTEGER :: B_JGS_MAXITER - REAL*8 :: B_JGS_PMIN - REAL*8 :: B_JGS_DIFF_THR - REAL*8 :: B_JGS_NORM_THR - INTEGER :: B_JGS_NLEVEL - LOGICAL :: B_JGS_SOURCE_NONLINEAR - END TYPE SCHM -! -! - TYPE MPAR - LOGICAL :: PINIT - TYPE(NPAR) :: NPARS - TYPE(PROP) :: PROPS - TYPE(FLDP) :: FLDPS - TYPE(SFLP) :: SFLPS - TYPE(SLNP) :: SLNPS - TYPE(SRCP) :: SRCPS - TYPE(SNLP) :: SNLPS - TYPE(SBTP) :: SBTPS - TYPE(SDBP) :: SDBPS -#ifdef W3_UOST - TYPE(UOSTP) :: UOSTPS + REAL :: IS2C1, IS2C2 #endif - TYPE(STRP) :: STRPS - TYPE(SBSP) :: SBSPS - TYPE(SICP) :: SICPS - TYPE(SCHM) :: SCHMS - END TYPE MPAR -!/ -!/ Data storage -!/ - TYPE(GRID), TARGET, ALLOCATABLE :: GRIDS(:) - TYPE(SGRD), TARGET, ALLOCATABLE :: SGRDS(:) - TYPE(MPAR), TARGET, ALLOCATABLE :: MPARS(:) -!/ -!/ Data aliases for structure GRID(S) -!/ - INTEGER, POINTER :: GTYPE - INTEGER, POINTER :: RSTYPE - INTEGER, POINTER :: ICLOSE - INTEGER, POINTER :: NX, NY, NSEA, NSEAL, TRFLAG - INTEGER, POINTER :: E3DF(:,:), P2MSF(:), US3DF(:), USSPF(:) - REAL, POINTER :: USSP_WN(:) + END TYPE SICP + + ! specific type for unstructured scheme + TYPE SCHM + LOGICAL :: FSN = .FALSE. + LOGICAL :: FSPSI = .FALSE. + LOGICAL :: FSFCT = .FALSE. + LOGICAL :: FSNIMP = .FALSE. + LOGICAL :: FSTOTALIMP = .FALSE. + LOGICAL :: FSTOTALEXP = .FALSE. + LOGICAL :: FSREFRACTION = .FALSE. + LOGICAL :: FSFREQSHIFT = .FALSE. + LOGICAL :: FSSOURCE = .FALSE. + LOGICAL :: FSBCCFL = .FALSE. + LOGICAL :: DO_CHANGE_WLV + REAL(8) :: SOLVERTHR_STP + REAL(8) :: CRIT_DEP_STP + LOGICAL :: B_JGS_TERMINATE_MAXITER + LOGICAL :: B_JGS_TERMINATE_DIFFERENCE + LOGICAL :: B_JGS_TERMINATE_NORM + LOGICAL :: B_JGS_LIMITER + LOGICAL :: B_JGS_USE_JACOBI + LOGICAL :: B_JGS_BLOCK_GAUSS_SEIDEL + INTEGER :: B_JGS_MAXITER + REAL*8 :: B_JGS_PMIN + REAL*8 :: B_JGS_DIFF_THR + REAL*8 :: B_JGS_NORM_THR + INTEGER :: B_JGS_NLEVEL + LOGICAL :: B_JGS_SOURCE_NONLINEAR + END TYPE SCHM + ! + ! + TYPE MPAR + LOGICAL :: PINIT + TYPE(NPAR) :: NPARS + TYPE(PROP) :: PROPS + TYPE(FLDP) :: FLDPS + TYPE(SFLP) :: SFLPS + TYPE(SLNP) :: SLNPS + TYPE(SRCP) :: SRCPS + TYPE(SNLP) :: SNLPS + TYPE(SBTP) :: SBTPS + TYPE(SDBP) :: SDBPS +#ifdef W3_UOST + TYPE(UOSTP) :: UOSTPS +#endif + TYPE(STRP) :: STRPS + TYPE(SBSP) :: SBSPS + TYPE(SICP) :: SICPS + TYPE(SCHM) :: SCHMS + END TYPE MPAR + !/ + !/ Data storage + !/ + TYPE(GRID), TARGET, ALLOCATABLE :: GRIDS(:) + TYPE(SGRD), TARGET, ALLOCATABLE :: SGRDS(:) + TYPE(MPAR), TARGET, ALLOCATABLE :: MPARS(:) + !/ + !/ Data aliases for structure GRID(S) + !/ + INTEGER, POINTER :: GTYPE + INTEGER, POINTER :: RSTYPE + INTEGER, POINTER :: ICLOSE + INTEGER, POINTER :: NX, NY, NSEA, NSEAL, TRFLAG + INTEGER, POINTER :: E3DF(:,:), P2MSF(:), US3DF(:), USSPF(:) + REAL, POINTER :: USSP_WN(:) #ifdef W3_REF1 - REAL, POINTER :: REFLC(:,:) - INTEGER, POINTER :: REFLD(:,:) -#endif - INTEGER, POINTER :: NBEDGE - INTEGER, POINTER :: EDGES(:,:), NEIGH(:,:) -! -! Variables for unstructured grids -! - INTEGER, POINTER :: NTRI,COUNTRI,COUNTOT,NNZ - INTEGER :: optionCall = 3 ! take care all other options are basically wrong - INTEGER, POINTER :: TRIGP(:,:) + REAL, POINTER :: REFLC(:,:) + INTEGER, POINTER :: REFLD(:,:) +#endif + INTEGER, POINTER :: NBEDGE + INTEGER, POINTER :: EDGES(:,:), NEIGH(:,:) + ! + ! Variables for unstructured grids + ! + INTEGER, POINTER :: NTRI,COUNTRI,COUNTOT,NNZ + INTEGER :: optionCall = 3 ! take care all other options are basically wrong + INTEGER, POINTER :: TRIGP(:,:) #ifdef W3_PDLIB - INTEGER, POINTER :: NBND_MAP - INTEGER, POINTER :: INDEX_MAP(:) - INTEGER, POINTER :: MAPSTA_LOC(:) - INTEGER*1, POINTER :: IOBPD_LOC(:,:) - INTEGER*2, POINTER :: IOBP_LOC(:) - INTEGER*1, POINTER :: IOBDP_LOC(:) - INTEGER*1, POINTER :: IOBPA_LOC(:) + INTEGER, POINTER :: NBND_MAP + INTEGER, POINTER :: INDEX_MAP(:) + INTEGER, POINTER :: MAPSTA_LOC(:) + INTEGER*1, POINTER :: IOBPD_LOC(:,:) + INTEGER*2, POINTER :: IOBP_LOC(:) + INTEGER*1, POINTER :: IOBDP_LOC(:) + INTEGER*1, POINTER :: IOBPA_LOC(:) #endif - REAL(8), POINTER :: IEN(:,:), LEN(:,:), SI(:) - REAL, POINTER :: ANGLE(:,:),ANGLE0(:,:) - INTEGER, POINTER :: CCON(:), COUNTCON(:), IE_CELL(:), & - POS_CELL(:), & - IAA(:), JAA(:), POSI(:,:), & - I_DIAG(:), JA_IE(:,:,:), & - INDEX_CELL(:) - INTEGER*2, POINTER :: IOBP(:) - INTEGER*1, POINTER :: IOBPD(:,:), IOBDP(:), IOBPA(:) - REAL(8), POINTER :: TRIA(:) - REAL, POINTER :: CROSSDIFF(:,:) - REAL,POINTER :: MAXX, MAXY, DXYMAX - LOGICAL, POINTER :: GUGINIT -! - REAL, POINTER :: FFACBERG + REAL(8), POINTER :: IEN(:,:), LEN(:,:), SI(:) + REAL, POINTER :: ANGLE(:,:),ANGLE0(:,:) + INTEGER, POINTER :: CCON(:), COUNTCON(:), IE_CELL(:), & + POS_CELL(:), & + IAA(:), JAA(:), POSI(:,:), & + I_DIAG(:), JA_IE(:,:,:), & + INDEX_CELL(:) + INTEGER*2, POINTER :: IOBP(:) + INTEGER*1, POINTER :: IOBPD(:,:), IOBDP(:), IOBPA(:) + REAL(8), POINTER :: TRIA(:) + REAL, POINTER :: CROSSDIFF(:,:) + REAL,POINTER :: MAXX, MAXY, DXYMAX + LOGICAL, POINTER :: GUGINIT + ! + REAL, POINTER :: FFACBERG #ifdef W3_REF1 - LOGICAL, POINTER :: RREF(:) - REAL, POINTER :: REFPARS(:) + LOGICAL, POINTER :: RREF(:) + REAL, POINTER :: REFPARS(:) #endif #ifdef W3_IG1 - REAL, POINTER :: IGPARS(:) + REAL, POINTER :: IGPARS(:) #endif #ifdef W3_IC2 - REAL, POINTER :: IC2PARS(:) + REAL, POINTER :: IC2PARS(:) #endif #ifdef W3_IC3 - REAL, POINTER :: IC3PARS(:) + REAL, POINTER :: IC3PARS(:) #endif #ifdef W3_IC4 - INTEGER, POINTER :: IC4PARS(:) - REAL, POINTER :: IC4_KI(:) - REAL, POINTER :: IC4_FC(:) + INTEGER, POINTER :: IC4PARS(:) + REAL, POINTER :: IC4_KI(:) + REAL, POINTER :: IC4_FC(:) #endif #ifdef W3_IC5 - REAL, POINTER :: IC5PARS(:) + REAL, POINTER :: IC5PARS(:) #endif #ifdef W3_IS2 - REAL, POINTER :: IS2PARS(:) + REAL, POINTER :: IS2PARS(:) #endif - INTEGER, POINTER :: MAPSTA(:,:), MAPST2(:,:), & - MAPFS(:,:), MAPSF(:,:) -! + INTEGER, POINTER :: MAPSTA(:,:), MAPST2(:,:), & + MAPFS(:,:), MAPSF(:,:) + ! #ifdef W3_SMC - INTEGER, POINTER :: NCel, NUFc, NVFc, NRLv, MRFct - INTEGER, POINTER :: NGLO, NARC, NBGL, NBAC, NBSMC - INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) - INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) - INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) + INTEGER, POINTER :: NCel, NUFc, NVFc, NRLv, MRFct + INTEGER, POINTER :: NGLO, NARC, NBGL, NBAC, NBSMC + INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) + INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) + INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) -!/ Data duplicated for better performance - INTEGER, POINTER :: IJKCel3(:), IJKCel4(:), & - IJKVFc5(:), IJKVFc6(:), & - IJKUFc5(:), IJKUFc6(:) -!/ + !/ Data duplicated for better performance + INTEGER, POINTER :: IJKCel3(:), IJKCel4(:), & + IJKVFc5(:), IJKVFc6(:), & + IJKUFc5(:), IJKUFc6(:) + !/ #endif -! + ! #ifdef W3_SEC1 - INTEGER, POINTER :: NITERSEC1 -#endif - REAL, POINTER :: SX, SY, X0, Y0, DTCFL, DTCFLI, DTMAX, & - DTMIN, DMIN, CTMAX, FICE0, FICEN, & - FICEL, PFMOVE, STEXU, STEYU, STEDU, & - IICEHMIN, IICEHINIT, ICESCALES(:), & - IICEHFAC, IICEHDISP, IICEDDISP, IICEFDISP, & - BTBETA, AAIRCMIN, AAIRGB - REAL(8),POINTER :: GRIDSHIFT ! see notes in WMGHGH + INTEGER, POINTER :: NITERSEC1 +#endif + REAL, POINTER :: SX, SY, X0, Y0, DTCFL, DTCFLI, DTMAX, & + DTMIN, DMIN, CTMAX, FICE0, FICEN, & + FICEL, PFMOVE, STEXU, STEYU, STEDU, & + IICEHMIN, IICEHINIT, ICESCALES(:), & + IICEHFAC, IICEHDISP, IICEDDISP, IICEFDISP, & + BTBETA, AAIRCMIN, AAIRGB + REAL(8),POINTER :: GRIDSHIFT ! see notes in WMGHGH #ifdef W3_RTD - REAL, POINTER :: PoLat, PoLon - REAL, POINTER :: AnglD(:) - LOGICAL, POINTER :: FLAGUNR -#endif - REAL , POINTER :: ZB(:) - REAL , POINTER :: CLATS(:) - REAL , POINTER :: CLATIS(:) ! INVERSE OF COS(LAT) DEFINED ON ISEA - REAL , POINTER :: CTHG0S(:) ! TAN(Y)/R, DEFINED ON ISEA + REAL, POINTER :: PoLat, PoLon + REAL, POINTER :: AnglD(:) + LOGICAL, POINTER :: FLAGUNR +#endif + REAL , POINTER :: ZB(:) + REAL , POINTER :: CLATS(:) + REAL , POINTER :: CLATIS(:) ! INVERSE OF COS(LAT) DEFINED ON ISEA + REAL , POINTER :: CTHG0S(:) ! TAN(Y)/R, DEFINED ON ISEA - REAL , POINTER :: TRNX(:,:), TRNY(:,:) ! TRANSPARENCY INFORMATION ON IX,IY + REAL , POINTER :: TRNX(:,:), TRNY(:,:) ! TRANSPARENCY INFORMATION ON IX,IY #ifdef W3_SMC - REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) -#endif - REAL , POINTER :: SPCBAC(:,:), ANGARC(:) - DOUBLE PRECISION, POINTER :: XGRD(:,:), YGRD(:,:) ! X AND Y DEFINED ON IX,IY - REAL , POINTER :: DXDP(:,:), DXDQ(:,:) ! DX/DP & DX/DQ DEFINED ON IX,IY - REAL , POINTER :: DYDP(:,:), DYDQ(:,:) ! DY/DP & DY/DQ DEFINED ON IX,IY - REAL , POINTER :: DPDX(:,:), DPDY(:,:) ! DP/DX & DP/DY DEFINED ON IX,IY - REAL , POINTER :: DQDX(:,:), DQDY(:,:) ! DQ/DX & DQ/DY DEFINED ON IX,IY - REAL , POINTER :: GSQRT(:,:) ! SQRT(G) DEFINED ON IX,IY - REAL , POINTER :: HPFAC(:,:) ! H_P = SQRT(G_PP) DEFINED ON IX,IY - REAL , POINTER :: HQFAC(:,:) ! H_Q = SQRT(G_QQ) DEFINED ON IX,IY + REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) +#endif + REAL , POINTER :: SPCBAC(:,:), ANGARC(:) + DOUBLE PRECISION, POINTER :: XGRD(:,:), YGRD(:,:) ! X AND Y DEFINED ON IX,IY + REAL , POINTER :: DXDP(:,:), DXDQ(:,:) ! DX/DP & DX/DQ DEFINED ON IX,IY + REAL , POINTER :: DYDP(:,:), DYDQ(:,:) ! DY/DP & DY/DQ DEFINED ON IX,IY + REAL , POINTER :: DPDX(:,:), DPDY(:,:) ! DP/DX & DP/DY DEFINED ON IX,IY + REAL , POINTER :: DQDX(:,:), DQDY(:,:) ! DQ/DX & DQ/DY DEFINED ON IX,IY + REAL , POINTER :: GSQRT(:,:) ! SQRT(G) DEFINED ON IX,IY + REAL , POINTER :: HPFAC(:,:) ! H_P = SQRT(G_PP) DEFINED ON IX,IY + REAL , POINTER :: HQFAC(:,:) ! H_Q = SQRT(G_QQ) DEFINED ON IX,IY #ifdef W3_BT4 - REAL, POINTER :: SED_D50(:), SED_PSIC(:) + REAL, POINTER :: SED_D50(:), SED_PSIC(:) #endif - LOGICAL, POINTER :: GINIT, FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU, IICEDISP,& - IICESMOOTH - LOGICAL, POINTER :: FLAGLL - LOGICAL, POINTER :: CMPRTRCK - LOGICAL, POINTER :: FLAGST(:) + LOGICAL, POINTER :: GINIT, FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU, IICEDISP,& + IICESMOOTH + LOGICAL, POINTER :: FLAGLL + LOGICAL, POINTER :: CMPRTRCK + LOGICAL, POINTER :: FLAGST(:) - CHARACTER(LEN=30), POINTER :: GNAME - CHARACTER(LEN=13), POINTER :: FILEXT + CHARACTER(LEN=30), POINTER :: GNAME + CHARACTER(LEN=13), POINTER :: FILEXT - TYPE(T_GSU), POINTER :: GSU ! Grid search utility object -!/ -!/ Data aliasses for structure SGRD(S) -!/ - INTEGER, POINTER :: NK, NK2, NTH, NSPEC - INTEGER, POINTER :: MAPWN(:), MAPTH(:) - REAL, POINTER :: DTH, XFR, FR1, FTE, FTF, FTWN, FTTR, & - FTWL, FACTI1, FACTI2, FACHFA, FACHFE - REAL, POINTER :: TH(:), ESIN(:), ECOS(:), ES2(:), & - ESC(:), EC2(:), SIG(:), SIG2(:), & - DSIP(:), DSII(:), DDEN(:), DDEN2(:) - LOGICAL, POINTER :: SINIT -!/ -!/ Data aliasses for structure MPAR(S) -!/ - LOGICAL, POINTER :: PINIT -!/ -!/ Data aliasses for structure NPAR(S) -!/ - REAL, POINTER :: FACP, XREL, XFLT, FXFM, FXPM, & - XFT, XFC, FACSD, FHMAX + TYPE(T_GSU), POINTER :: GSU ! Grid search utility object + !/ + !/ Data aliasses for structure SGRD(S) + !/ + INTEGER, POINTER :: NK, NK2, NTH, NSPEC + INTEGER, POINTER :: MAPWN(:), MAPTH(:) + REAL, POINTER :: DTH, XFR, FR1, FTE, FTF, FTWN, FTTR, & + FTWL, FACTI1, FACTI2, FACHFA, FACHFE + REAL, POINTER :: TH(:), ESIN(:), ECOS(:), ES2(:), & + ESC(:), EC2(:), SIG(:), SIG2(:), & + DSIP(:), DSII(:), DDEN(:), DDEN2(:) + LOGICAL, POINTER :: SINIT + !/ + !/ Data aliasses for structure MPAR(S) + !/ + LOGICAL, POINTER :: PINIT + !/ + !/ Data aliasses for structure NPAR(S) + !/ + REAL, POINTER :: FACP, XREL, XFLT, FXFM, FXPM, & + XFT, XFC, FACSD, FHMAX #ifdef W3_RWND - REAL, POINTER :: RWINDC + REAL, POINTER :: RWINDC #endif #ifdef W3_WCOR - REAL, POINTER :: WWCOR(:) + REAL, POINTER :: WWCOR(:) #endif -!/ -!/ Data aliasses for structure PROP(S) -!/ + !/ + !/ Data aliasses for structure PROP(S) + !/ #ifdef W3_PR2 - REAL, POINTER :: DTME, CLATMN + REAL, POINTER :: DTME, CLATMN #endif #ifdef W3_PR3 - REAL, POINTER :: WDCG, WDTH + REAL, POINTER :: WDCG, WDTH #endif #ifdef W3_SMC - REAL, POINTER :: DTMS, Refran - LOGICAL, POINTER :: FUNO3, FVERG, FSWND, ARCTC + REAL, POINTER :: DTMS, Refran + LOGICAL, POINTER :: FUNO3, FVERG, FSWND, ARCTC #endif -!/ -!/ Data aliasses for structure FLDP(S) -!/ + !/ + !/ Data aliasses for structure FLDP(S) + !/ #ifdef W3_FLD1 - INTEGER, POINTER :: TAIL_ID - REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + INTEGER, POINTER :: TAIL_ID + REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 #endif #ifdef W3_FLD2 - INTEGER, POINTER :: TAIL_ID - REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + INTEGER, POINTER :: TAIL_ID + REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 #endif -!/ -!/ Data aliasses for structure SFLP(S) -!/ + !/ + !/ Data aliasses for structure SFLP(S) + !/ #ifdef W3_FLX2 - INTEGER, POINTER :: NITTIN - REAL, POINTER :: CINXSI + INTEGER, POINTER :: NITTIN + REAL, POINTER :: CINXSI #endif #ifdef W3_FLX3 - INTEGER, POINTER :: NITTIN, CAP_ID - REAL, POINTER :: CINXSI, CD_MAX + INTEGER, POINTER :: NITTIN, CAP_ID + REAL, POINTER :: CINXSI, CD_MAX #endif #ifdef W3_FLX4 - REAL, POINTER :: FLX4A0 + REAL, POINTER :: FLX4A0 #endif -!/ -!/ Data aliasses for structure SLNP(S) -!/ + !/ + !/ Data aliasses for structure SLNP(S) + !/ #ifdef W3_LN1 - REAL, POINTER :: SLNC1, FSPM, FSHF + REAL, POINTER :: SLNC1, FSPM, FSHF #endif -!/ -!/ Data aliasses for structure SRCP(S) -!/ + !/ + !/ Data aliasses for structure SRCP(S) + !/ #ifdef W3_ST1 - REAL, POINTER :: SINC1, SDSC1 + REAL, POINTER :: SINC1, SDSC1 #endif #ifdef W3_ST2 - REAL, POINTER :: ZWIND, FSWELL, SHSTAB, & - OFSTAB, CCNG, CCPS, FFNG, FFPS, & - CDSA0, CDSA1, CDSA2, SDSALN, & - CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, & - XFH, XF1, XF2 + REAL, POINTER :: ZWIND, FSWELL, SHSTAB, & + OFSTAB, CCNG, CCPS, FFNG, FFPS, & + CDSA0, CDSA1, CDSA2, SDSALN, & + CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, & + XFH, XF1, XF2 #endif #ifdef W3_ST3 - REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT,& - ZZALP, FFXFM, FFXPM, & - SSINTHP, TTAUWSHELTER, SSWELLF(:), & - SSDSC1, SSDSC2, SSDSC3, SSDSBR, & - SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & - SSDSC4, SSDSC5, SSDSC6, SSDSBT, & - DDELTA1, DDELTA2, & - SSDSCOS, SSDSDTH, SSDSBM(:) + REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT,& + ZZALP, FFXFM, FFXPM, & + SSINTHP, TTAUWSHELTER, SSWELLF(:), & + SSDSC1, SSDSC2, SSDSC3, SSDSBR, & + SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & + SSDSC4, SSDSC5, SSDSC6, SSDSBT, & + DDELTA1, DDELTA2, & + SSDSCOS, SSDSDTH, SSDSBM(:) #endif #ifdef W3_ST4 - INTEGER, POINTER :: SSWELLFPAR, SSDSISO,SSDSBRFDF, & - IKTAB(:,:), SATINDICES(:,:),SSDSDIK - REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) - REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT,& - ZZALP, FFXFA, & - FFXFM, FFXPM, SSDSBRF1, SSDSBRF2, & - SSDSBINT, SSDSBCK, SSDSHCK, SSDSABK, & - SSDSPBK, SSINBR,SSINTHP,TTAUWSHELTER,& - SSWELLF(:), SSDSC(:), SSDSBR, & - SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & - SSDSBT, SSDSCOS, SSDSDTH, SSDSBM(:) + INTEGER, POINTER :: SSWELLFPAR, SSDSISO,SSDSBRFDF, & + IKTAB(:,:), SATINDICES(:,:),SSDSDIK + REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) + REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT,& + ZZALP, FFXFA, & + FFXFM, FFXPM, SSDSBRF1, SSDSBRF2, & + SSDSBINT, SSDSBCK, SSDSHCK, SSDSABK, & + SSDSPBK, SSINBR,SSINTHP,TTAUWSHELTER,& + SSWELLF(:), SSDSC(:), SSDSBR, & + SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & + SSDSBT, SSDSCOS, SSDSDTH, SSDSBM(:) #endif #ifdef W3_ST6 - REAL, POINTER :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, & - SIN6WS, SIN6FC - INTEGER, POINTER :: SDS6P1, SDS6P2 - LOGICAL, POINTER :: SDS6ET, SWL6S6, SWL6CSTB1 -#endif - REAL, POINTER :: WWNMEANPTAIL, SSTXFTFTAIL -!/ -!/ Data aliasses for structure SNLP(S) -!/ + REAL, POINTER :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, & + SIN6WS, SIN6FC + INTEGER, POINTER :: SDS6P1, SDS6P2 + LOGICAL, POINTER :: SDS6ET, SWL6S6, SWL6CSTB1 +#endif + REAL, POINTER :: WWNMEANPTAIL, SSTXFTFTAIL + !/ + !/ Data aliasses for structure SNLP(S) + !/ #ifdef W3_NL1 - REAL, POINTER :: SNLC1, LAM, KDCON, KDMN, & - SNLS1, SNLS2, SNLS3 + REAL, POINTER :: SNLC1, LAM, KDCON, KDMN, & + SNLS1, SNLS2, SNLS3 #endif #ifdef W3_NL2 - INTEGER, POINTER :: IQTPE, NDPTHS - REAL, POINTER :: NLTAIL - REAL, POINTER :: DPTHNL(:) + INTEGER, POINTER :: IQTPE, NDPTHS + REAL, POINTER :: NLTAIL + REAL, POINTER :: DPTHNL(:) #endif #ifdef W3_NL3 - INTEGER, POINTER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, & - NTHEXP, NSPMIN, NSPMAX, NSPMX2, & - NQA, SNLNQ - INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) - REAL, POINTER :: SNLMSC, SNLNSC, SNLSFD, SNLSFS - REAL, POINTER :: FRQ(:), XSI(:), & - QST2(:,:,:), QST3(:,:,:), & - QST5(:,:,:), QST6(:,:,:), & - SNLL(:), SNLM(:), SNLT(:), & - SNLCD(:), SNLCS(:) + INTEGER, POINTER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, & + NTHEXP, NSPMIN, NSPMAX, NSPMX2, & + NQA, SNLNQ + INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) + REAL, POINTER :: SNLMSC, SNLNSC, SNLSFD, SNLSFS + REAL, POINTER :: FRQ(:), XSI(:), & + QST2(:,:,:), QST3(:,:,:), & + QST5(:,:,:), QST6(:,:,:), & + SNLL(:), SNLM(:), SNLT(:), & + SNLCD(:), SNLCS(:) #endif #ifdef W3_NL4 - INTEGER, POINTER :: ITSA, IALT + INTEGER, POINTER :: ITSA, IALT #endif #ifdef W3_NL5 - REAL, POINTER :: QR5DPT, QR5OML - INTEGER, POINTER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX - INTEGER(KIND=8), POINTER:: QI5NNZ + REAL, POINTER :: QR5DPT, QR5OML + INTEGER, POINTER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX + INTEGER(KIND=8), POINTER:: QI5NNZ #endif #ifdef W3_NLS - INTEGER, POINTER :: NTHX, NFRX, NSPL, NSPH - REAL, POINTER :: CNLSA, CNLSC, CNLSFM, & - CNLSC1, CNLSC2, CNLSC3, SNSST(:,:) + INTEGER, POINTER :: NTHX, NFRX, NSPL, NSPH + REAL, POINTER :: CNLSA, CNLSC, CNLSFM, & + CNLSC1, CNLSC2, CNLSC3, SNSST(:,:) #endif -!/ -!/ Data aliasses for structure SBTP(S) -!/ + !/ + !/ Data aliasses for structure SBTP(S) + !/ #ifdef W3_BT1 - REAL, POINTER :: SBTC1 + REAL, POINTER :: SBTC1 #endif #ifdef W3_BT4 - REAL, POINTER :: SBTCX(:) + REAL, POINTER :: SBTCX(:) #endif -!/ -!/ Data aliasses for structure SDBP(S) -!/ + !/ + !/ Data aliasses for structure SDBP(S) + !/ #ifdef W3_DB1 - REAL, POINTER :: SDBC1, SDBC2 - LOGICAL, POINTER :: FDONLY - REAL, POINTER :: SDBSC + REAL, POINTER :: SDBC1, SDBC2 + LOGICAL, POINTER :: FDONLY + REAL, POINTER :: SDBSC #endif -!/ + !/ #ifdef W3_UOST -!/ Data aliases for structure UOSTP(S) - CHARACTER(LEN=:), POINTER :: UOSTFILELOCAL, UOSTFILESHADOW - REAL, POINTER :: UOSTFACTORLOCAL, UOSTFACTORSHADOW -#endif -!/ -!/ Data aliasing for structure SCHM(S) - LOGICAL, POINTER :: FSN,FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP - LOGICAL, POINTER :: FSREFRACTION, FSFREQSHIFT, FSSOURCE, FSBCCFL - LOGICAL, POINTER :: DO_CHANGE_WLV - REAL(8), POINTER :: SOLVERTHR_STP - REAL(8), POINTER :: CRIT_DEP_STP - LOGICAL, POINTER :: B_JGS_TERMINATE_MAXITER - LOGICAL, POINTER :: B_JGS_TERMINATE_DIFFERENCE - LOGICAL, POINTER :: B_JGS_TERMINATE_NORM - LOGICAL, POINTER :: B_JGS_LIMITER - LOGICAL, POINTER :: B_JGS_USE_JACOBI - LOGICAL, POINTER :: B_JGS_BLOCK_GAUSS_SEIDEL - INTEGER, POINTER :: B_JGS_MAXITER - REAL(8), POINTER :: B_JGS_PMIN - REAL(8), POINTER :: B_JGS_DIFF_THR - REAL(8), POINTER :: B_JGS_NORM_THR - INTEGER, POINTER :: B_JGS_NLEVEL - LOGICAL, POINTER :: B_JGS_SOURCE_NONLINEAR -!/ -!/ Data aliasing for structure SICP(S) + !/ Data aliases for structure UOSTP(S) + CHARACTER(LEN=:), POINTER :: UOSTFILELOCAL, UOSTFILESHADOW + REAL, POINTER :: UOSTFACTORLOCAL, UOSTFACTORSHADOW +#endif + !/ + !/ Data aliasing for structure SCHM(S) + LOGICAL, POINTER :: FSN,FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP + LOGICAL, POINTER :: FSREFRACTION, FSFREQSHIFT, FSSOURCE, FSBCCFL + LOGICAL, POINTER :: DO_CHANGE_WLV + REAL(8), POINTER :: SOLVERTHR_STP + REAL(8), POINTER :: CRIT_DEP_STP + LOGICAL, POINTER :: B_JGS_TERMINATE_MAXITER + LOGICAL, POINTER :: B_JGS_TERMINATE_DIFFERENCE + LOGICAL, POINTER :: B_JGS_TERMINATE_NORM + LOGICAL, POINTER :: B_JGS_LIMITER + LOGICAL, POINTER :: B_JGS_USE_JACOBI + LOGICAL, POINTER :: B_JGS_BLOCK_GAUSS_SEIDEL + INTEGER, POINTER :: B_JGS_MAXITER + REAL(8), POINTER :: B_JGS_PMIN + REAL(8), POINTER :: B_JGS_DIFF_THR + REAL(8), POINTER :: B_JGS_NORM_THR + INTEGER, POINTER :: B_JGS_NLEVEL + LOGICAL, POINTER :: B_JGS_SOURCE_NONLINEAR + !/ + !/ Data aliasing for structure SICP(S) #ifdef W3_IS1 - REAL, POINTER :: IS1C1, IS1C2 + REAL, POINTER :: IS1C1, IS1C2 #endif -!/ + !/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3NMOD ( NUMBER, NDSE, NDST, NAUX ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 24-Feb-2004 : Origination. ( version 3.06 ) -!/ 18-Jul-2006 : Add input grids. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Set up the number of grids to be used. -! -! 2. Method : -! -! Store in NGRIDS and allocate GRIDS. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NUMBER Int. I Number of grids to be used. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! NAUX Int. I Number of auxiliary grids to be used. -! Grids -NAUX:NUBMER are defined, optional -! parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program that uses this grid structure. -! -! 6. Error messages : -! -! - Error checks on previous setting of variable. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3NMOD ( NUMBER, NDSE, NDST, NAUX ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 24-Feb-2004 : Origination. ( version 3.06 ) + !/ 18-Jul-2006 : Add input grids. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Set up the number of grids to be used. + ! + ! 2. Method : + ! + ! Store in NGRIDS and allocate GRIDS. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NUMBER Int. I Number of grids to be used. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! NAUX Int. I Number of auxiliary grids to be used. + ! Grids -NAUX:NUBMER are defined, optional + ! parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program that uses this grid structure. + ! + ! 6. Error messages : + ! + ! - Error checks on previous setting of variable. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NUMBER, NDSE, NDST - INTEGER, INTENT(IN), OPTIONAL :: NAUX -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, NLOW + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NUMBER, NDSE, NDST + INTEGER, INTENT(IN), OPTIONAL :: NAUX + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, NLOW #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3NMOD') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .NE. -1 ) THEN - WRITE (NDSE,1001) NGRIDS - CALL EXTCDE (1) - END IF -! - IF ( NUMBER .LT. 1 ) THEN - WRITE (NDSE,1002) NUMBER - CALL EXTCDE (2) - END IF -! - IF ( PRESENT(NAUX) ) THEN - NLOW = -NAUX - ELSE - NLOW = 1 - END IF -! - IF ( NLOW .GT. 1 ) THEN - WRITE (NDSE,1003) -NLOW - CALL EXTCDE (3) - END IF -! -! -------------------------------------------------------------------- / -! 1. Set variable and allocate arrays -! - NGRIDS = NUMBER - NAUXGR = - NLOW - ALLOCATE ( GRIDS(NLOW:NUMBER), & - SGRDS(NLOW:NUMBER), & - MPARS(NLOW:NUMBER), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! -! -------------------------------------------------------------------- / -! 2. Initialize GINIT and SINIT -! - DO I=NLOW, NUMBER - GRIDS(I)%GINIT = .FALSE. - GRIDS(I)%GUGINIT = .FALSE. - SGRDS(I)%SINIT = .FALSE. - MPARS(I)%PINIT = .FALSE. + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3NMOD') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .NE. -1 ) THEN + WRITE (NDSE,1001) NGRIDS + CALL EXTCDE (1) + END IF + ! + IF ( NUMBER .LT. 1 ) THEN + WRITE (NDSE,1002) NUMBER + CALL EXTCDE (2) + END IF + ! + IF ( PRESENT(NAUX) ) THEN + NLOW = -NAUX + ELSE + NLOW = 1 + END IF + ! + IF ( NLOW .GT. 1 ) THEN + WRITE (NDSE,1003) -NLOW + CALL EXTCDE (3) + END IF + ! + ! -------------------------------------------------------------------- / + ! 1. Set variable and allocate arrays + ! + NGRIDS = NUMBER + NAUXGR = - NLOW + ALLOCATE ( GRIDS(NLOW:NUMBER), & + SGRDS(NLOW:NUMBER), & + MPARS(NLOW:NUMBER), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + ! -------------------------------------------------------------------- / + ! 2. Initialize GINIT and SINIT + ! + DO I=NLOW, NUMBER + GRIDS(I)%GINIT = .FALSE. + GRIDS(I)%GUGINIT = .FALSE. + SGRDS(I)%SINIT = .FALSE. + MPARS(I)%PINIT = .FALSE. #ifdef W3_NL2 - MPARS(I)%SNLPS%NDPTHS = 0 + MPARS(I)%SNLPS%NDPTHS = 0 #endif - END DO + END DO #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3NMOD) - WRITE (NDST,9000) NLOW, NGRIDS -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3NMOD : GRIDS ALREADY INITIALIZED *** '/ & - ' NGRIDS = ',I10/) - 1002 FORMAT (/' *** ERROR W3NMOD : ILLEGAL NUMBER OF GRIDS *** '/ & - ' NUMBER = ',I10/) - 1003 FORMAT (/' *** ERROR W3NMOD : ILLEGAL NUMBER OF AUX GRIDS *** '/& - ' NUMBER = ',I10/) + WRITE (NDST,9000) NLOW, NGRIDS +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3NMOD : GRIDS ALREADY INITIALIZED *** '/ & + ' NGRIDS = ',I10/) +1002 FORMAT (/' *** ERROR W3NMOD : ILLEGAL NUMBER OF GRIDS *** '/ & + ' NUMBER = ',I10/) +1003 FORMAT (/' *** ERROR W3NMOD : ILLEGAL NUMBER OF AUX GRIDS *** '/& + ' NUMBER = ',I10/) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3NMOD) - 9000 FORMAT (' TEST W3NMOD : SETTING UP FOR GRIDS ',I3, & - ' THROUGH ',I3) -#endif -!/ -!/ End of W3NMOD ----------------------------------------------------- / -!/ - END SUBROUTINE W3NMOD -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DIMX ( IMOD, MX, MY, MSEA, NDSE, NDST & +9000 FORMAT (' TEST W3NMOD : SETTING UP FOR GRIDS ',I3, & + ' THROUGH ',I3) +#endif + !/ + !/ End of W3NMOD ----------------------------------------------------- / + !/ + END SUBROUTINE W3NMOD + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DIMX ( IMOD, MX, MY, MSEA, NDSE, NDST & #ifdef W3_SMC - , MCel, MUFc, MVFc, MRLv, MBSMC & - , MARC, MBAC, MSPEC & -#endif - ) -#ifdef W3_SMC - !!Li A few dimensional numbers for SMC grid. -#endif -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 | -!/ +-----------------------------------+ -!/ -!/ 24-Jun-2005 : Origination. ( version 3.07 ) -!/ 18-Jul-2006 : Add input grids. ( version 3.10 ) -!/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement unstructured grids ( version 3.14.1) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Initialize an individual spatial grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array GRIDS. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! MX, MY, MSEA Like NX, NY, NSEA in data structure. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Model definition file IO program. -! WW3_GRID Prog. N/A Model set up program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - Grid dimensions apre passed through parameter list and then -! locally stored to assure consistency between allocation and -! data in structure. -! - W3SETG needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE + , MCel, MUFc, MVFc, MRLv, MBSMC & + , MARC, MBAC, MSPEC & +#endif + ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 | + !/ +-----------------------------------+ + !/ + !/ 24-Jun-2005 : Origination. ( version 3.07 ) + !/ 18-Jul-2006 : Add input grids. ( version 3.10 ) + !/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement unstructured grids ( version 3.14.1) + !/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual spatial grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array GRIDS. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! MX, MY, MSEA Like NX, NY, NSEA in data structure. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Model definition file IO program. + ! WW3_GRID Prog. N/A Model set up program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - Grid dimensions apre passed through parameter list and then + ! locally stored to assure consistency between allocation and + ! data in structure. + ! - W3SETG needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, MX, MY, MSEA, NDSE, NDST + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, MX, MY, MSEA, NDSE, NDST #ifdef W3_SMC - INTEGER, INTENT(IN) :: MCel, MUFc, MVFc, MRLv, MBSMC - INTEGER, INTENT(IN) :: MARC, MBAC, MSPEC + INTEGER, INTENT(IN) :: MCel, MUFc, MVFc, MRLv, MBSMC + INTEGER, INTENT(IN) :: MARC, MBAC, MSPEC #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_SMC - INTEGER :: IARC, IBAC, IBSMC -#endif -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER :: IARC, IBAC, IBSMC #endif -!/ #ifdef W3_S - CALL STRACE (IENT, 'W3DIMX') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN - WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS - CALL EXTCDE (2) - END IF -! - IF ( MX.LT.3 .OR. (MY.LT.3.AND.GTYPE.NE.UNGTYPE) .OR. MSEA.LT.1 ) THEN - WRITE (NDSE,1003) MX, MY, MSEA, GTYPE - CALL EXTCDE (3) - END IF -! - IF ( GRIDS(IMOD)%GINIT ) THEN - WRITE (NDSE,1004) - CALL EXTCDE (4) - END IF + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIMX') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN + WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS + CALL EXTCDE (2) + END IF + ! + IF ( MX.LT.3 .OR. (MY.LT.3.AND.GTYPE.NE.UNGTYPE) .OR. MSEA.LT.1 ) THEN + WRITE (NDSE,1003) MX, MY, MSEA, GTYPE + CALL EXTCDE (3) + END IF + ! + IF ( GRIDS(IMOD)%GINIT ) THEN + WRITE (NDSE,1004) + CALL EXTCDE (4) + END IF #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) - WRITE (NDST,9000) IMOD, MX, MY, MSEA -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! -! NB: Some array start at 0 because MAPFS(IY,IX)=0 for missing points -! - IF (GTYPE .NE. UNGTYPE) THEN - ALLOCATE ( GRIDS(IMOD)%ZB(MSEA), & - GRIDS(IMOD)%XGRD(MY,MX), & - GRIDS(IMOD)%YGRD(MY,MX), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ENDIF + WRITE (NDST,9000) IMOD, MX, MY, MSEA +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + ! NB: Some array start at 0 because MAPFS(IY,IX)=0 for missing points + ! + IF (GTYPE .NE. UNGTYPE) THEN + ALLOCATE ( GRIDS(IMOD)%ZB(MSEA), & + GRIDS(IMOD)%XGRD(MY,MX), & + GRIDS(IMOD)%YGRD(MY,MX), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ENDIF - ALLOCATE ( GRIDS(IMOD)%MAPSTA(MY,MX), & - GRIDS(IMOD)%MAPST2(MY,MX), & - GRIDS(IMOD)%MAPFS(MY,MX), & - GRIDS(IMOD)%MAPSF(MSEA,3), & - GRIDS(IMOD)%FLAGST(MSEA), & + ALLOCATE ( GRIDS(IMOD)%MAPSTA(MY,MX), & + GRIDS(IMOD)%MAPST2(MY,MX), & + GRIDS(IMOD)%MAPFS(MY,MX), & + GRIDS(IMOD)%MAPSF(MSEA,3), & + GRIDS(IMOD)%FLAGST(MSEA), & #ifdef W3_RTD - GRIDS(IMOD)%AnglD(MSEA), & -#endif - GRIDS(IMOD)%CLATS(0:MSEA), & - GRIDS(IMOD)%CLATIS(0:MSEA), & - GRIDS(IMOD)%CTHG0S(0:MSEA), & - GRIDS(IMOD)%TRNX(MY,MX), & - GRIDS(IMOD)%TRNY(MY,MX), & - GRIDS(IMOD)%DXDP(MY,MX), & - GRIDS(IMOD)%DXDQ(MY,MX), & - GRIDS(IMOD)%DYDP(MY,MX), & - GRIDS(IMOD)%DYDQ(MY,MX), & - GRIDS(IMOD)%DPDX(MY,MX), & - GRIDS(IMOD)%DPDY(MY,MX), & - GRIDS(IMOD)%DQDX(MY,MX), & - GRIDS(IMOD)%DQDY(MY,MX), & - GRIDS(IMOD)%GSQRT(MY,MX), & - GRIDS(IMOD)%HPFAC(MY,MX), & - GRIDS(IMOD)%HQFAC(MY,MX), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + GRIDS(IMOD)%AnglD(MSEA), & +#endif + GRIDS(IMOD)%CLATS(0:MSEA), & + GRIDS(IMOD)%CLATIS(0:MSEA), & + GRIDS(IMOD)%CTHG0S(0:MSEA), & + GRIDS(IMOD)%TRNX(MY,MX), & + GRIDS(IMOD)%TRNY(MY,MX), & + GRIDS(IMOD)%DXDP(MY,MX), & + GRIDS(IMOD)%DXDQ(MY,MX), & + GRIDS(IMOD)%DYDP(MY,MX), & + GRIDS(IMOD)%DYDQ(MY,MX), & + GRIDS(IMOD)%DPDX(MY,MX), & + GRIDS(IMOD)%DPDY(MY,MX), & + GRIDS(IMOD)%DQDX(MY,MX), & + GRIDS(IMOD)%DQDY(MY,MX), & + GRIDS(IMOD)%GSQRT(MY,MX), & + GRIDS(IMOD)%HPFAC(MY,MX), & + GRIDS(IMOD)%HQFAC(MY,MX), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_BT4 ALLOCATE ( GRIDS(IMOD)%SED_D50(0:MSEA), & - GRIDS(IMOD)%SED_PSIC(0:MSEA),& - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + GRIDS(IMOD)%SED_PSIC(0:MSEA),& + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -! + ! #ifdef W3_SMC - ALLOCATE ( GRIDS(IMOD)%NLvCel(0:MRLv), & - GRIDS(IMOD)%NLvUFc(0:MRLv), & - GRIDS(IMOD)%NLvVFc(0:MRLv), & - GRIDS(IMOD)%IJKCel(4, -9:MCel), & - GRIDS(IMOD)%IJKUFc(7,MUFc), & - GRIDS(IMOD)%IJKVFc(7,MVFc), & - GRIDS(IMOD)%CTRNX(-9:MCel), & - GRIDS(IMOD)%CTRNY(-9:MCel), & - GRIDS(IMOD)%CLATF(MVFc), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%NLvCel(0:MRLv), & + GRIDS(IMOD)%NLvUFc(0:MRLv), & + GRIDS(IMOD)%NLvVFc(0:MRLv), & + GRIDS(IMOD)%IJKCel(4, -9:MCel), & + GRIDS(IMOD)%IJKUFc(7,MUFc), & + GRIDS(IMOD)%IJKVFc(7,MVFc), & + GRIDS(IMOD)%CTRNX(-9:MCel), & + GRIDS(IMOD)%CTRNY(-9:MCel), & + GRIDS(IMOD)%CLATF(MVFc), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( GRIDS(IMOD)%IJKCel3(-9:MCel), & - GRIDS(IMOD)%IJKCel4(-9:MCel), & - GRIDS(IMOD)%IJKVFc5(MVFc), & - GRIDS(IMOD)%IJKVFc6(MVFc), & - GRIDS(IMOD)%IJKUFc5(MUFc), & - GRIDS(IMOD)%IJKUFc6(MUFc), & - STAT=ISTAT) -#endif -! -#ifdef W3_SMC - !! Arctic part related variables, declare minimum 1 element. - IARC = MARC - IF( MARC .LE. 1 ) IARC = 1 - IBAC = MBAC - IF( MBAC .LE. 1 ) IBAC = 1 - IBSMC = MBSMC - IF( MBSMC .LE. 1 ) IBSMC = 1 - ALLOCATE ( GRIDS(IMOD)%ICLBAC(IBAC), & - GRIDS(IMOD)%ANGARC(IARC), & - GRIDS(IMOD)%SPCBAC(MSPEC,IBAC), & - GRIDS(IMOD)%ISMCBP(IBSMC), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! -#ifdef W3_SMC - !! All SMC grid related varialbes are initialised in case SMC - !! switch is selected but SMCTYPE is not used. JGLi08Mar2021 - GRIDS(IMOD)%NLvCel(:) = 0 - GRIDS(IMOD)%NLvUFc(:) = 0 - GRIDS(IMOD)%NLvVFc(:) = 0 - GRIDS(IMOD)%ISMCBP(:) = 0 - GRIDS(IMOD)%ICLBAC(:) = 0 - GRIDS(IMOD)%IJKCel(:,:) = 0 - GRIDS(IMOD)%IJKUFc(:,:) = 0 - GRIDS(IMOD)%IJKVFc(:,:) = 0 - GRIDS(IMOD)%CTRNX(:) = 0.0 - GRIDS(IMOD)%CTRNY(:) = 0.0 - GRIDS(IMOD)%CLATF(:) = 0.0 - GRIDS(IMOD)%ANGARC(:) = 0.0 -#endif -! - GRIDS(IMOD)%FLAGST = .TRUE. - GRIDS(IMOD)%GINIT = .TRUE. - GRIDS(IMOD)%MAPSF(:,3)=0. - GRIDS(IMOD)%CLATS(0)=1. - GRIDS(IMOD)%CLATIS(0)=1. - GRIDS(IMOD)%CTHG0S(0)=1. -! -#ifdef W3_REF1 - ALLOCATE ( GRIDS(IMOD)%RREF(4), & - GRIDS(IMOD)%REFPARS(10), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! + ALLOCATE ( GRIDS(IMOD)%IJKCel3(-9:MCel), & + GRIDS(IMOD)%IJKCel4(-9:MCel), & + GRIDS(IMOD)%IJKVFc5(MVFc), & + GRIDS(IMOD)%IJKVFc6(MVFc), & + GRIDS(IMOD)%IJKUFc5(MUFc), & + GRIDS(IMOD)%IJKUFc6(MUFc), & + STAT=ISTAT) + !! Arctic part related variables, declare minimum 1 element. + IARC = MARC + IF( MARC .LE. 1 ) IARC = 1 + IBAC = MBAC + IF( MBAC .LE. 1 ) IBAC = 1 + IBSMC = MBSMC + IF( MBSMC .LE. 1 ) IBSMC = 1 + ALLOCATE ( GRIDS(IMOD)%ICLBAC(IBAC), & + GRIDS(IMOD)%ANGARC(IARC), & + GRIDS(IMOD)%SPCBAC(MSPEC,IBAC), & + GRIDS(IMOD)%ISMCBP(IBSMC), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + !! All SMC grid related varialbes are initialised in case SMC + !! switch is selected but SMCTYPE is not used. JGLi08Mar2021 + GRIDS(IMOD)%NLvCel(:) = 0 + GRIDS(IMOD)%NLvUFc(:) = 0 + GRIDS(IMOD)%NLvVFc(:) = 0 + GRIDS(IMOD)%ISMCBP(:) = 0 + GRIDS(IMOD)%ICLBAC(:) = 0 + GRIDS(IMOD)%IJKCel(:,:) = 0 + GRIDS(IMOD)%IJKUFc(:,:) = 0 + GRIDS(IMOD)%IJKVFc(:,:) = 0 + GRIDS(IMOD)%CTRNX(:) = 0.0 + GRIDS(IMOD)%CTRNY(:) = 0.0 + GRIDS(IMOD)%CLATF(:) = 0.0 + GRIDS(IMOD)%ANGARC(:) = 0.0 +#endif + ! + GRIDS(IMOD)%FLAGST = .TRUE. + GRIDS(IMOD)%GINIT = .TRUE. + GRIDS(IMOD)%MAPSF(:,3)=0. + GRIDS(IMOD)%CLATS(0)=1. + GRIDS(IMOD)%CLATIS(0)=1. + GRIDS(IMOD)%CTHG0S(0)=1. + ! #ifdef W3_REF1 - GRIDS(IMOD)%RREF(:)=.FALSE. - GRIDS(IMOD)%REFPARS(:)=0. -#endif -! -#ifdef W3_REF1 -! Memory footprint can be reduced by defining REFLC and REFLD only over nodes -! where reflection can occur. - ALLOCATE ( GRIDS(IMOD)%REFLC(4,0:NSEA), & - GRIDS(IMOD)%REFLD(6,0:NSEA), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%RREF(4), & + GRIDS(IMOD)%REFPARS(10), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + GRIDS(IMOD)%RREF(:)=.FALSE. + GRIDS(IMOD)%REFPARS(:)=0. + ! + ! Memory footprint can be reduced by defining REFLC and REFLD only over nodes + ! where reflection can occur. + ALLOCATE ( GRIDS(IMOD)%REFLC(4,0:NSEA), & + GRIDS(IMOD)%REFLD(6,0:NSEA), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IG1 - ALLOCATE ( GRIDS(IMOD)%IGPARS(12), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IGPARS(12), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IC2 - ALLOCATE ( GRIDS(IMOD)%IC2PARS(9), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC2PARS(9), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IC3 - ALLOCATE ( GRIDS(IMOD)%IC3PARS(16), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC3PARS(16), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IC4 - ALLOCATE ( GRIDS(IMOD)%IC4PARS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( GRIDS(IMOD)%IC4_KI(NIC4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( GRIDS(IMOD)%IC4_FC(NIC4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC4PARS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC4_KI(NIC4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC4_FC(NIC4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IC5 - ALLOCATE ( GRIDS(IMOD)%IC5PARS(9), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC5PARS(9), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IS2 - ALLOCATE ( GRIDS(IMOD)%IS2PARS(24), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IS2PARS(24), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) - WRITE (NDST,9001) + WRITE (NDST,9001) #endif -! + ! #ifdef W3_REF1 - GRIDS(IMOD)%REFLC(1:4,0:NSEA)=0. - GRIDS(IMOD)%REFLD(:,:)=0 + GRIDS(IMOD)%REFLC(1:4,0:NSEA)=0. + GRIDS(IMOD)%REFLD(:,:)=0 #endif #ifdef W3_IG1 - GRIDS(IMOD)%IGPARS(:)=0. + GRIDS(IMOD)%IGPARS(:)=0. #endif #ifdef W3_IC2 - GRIDS(IMOD)%IC2PARS(:)=0. + GRIDS(IMOD)%IC2PARS(:)=0. #endif #ifdef W3_IS2 - GRIDS(IMOD)%IS2PARS(:)=0. -#endif -! -! -------------------------------------------------------------------- / -! 2. Update counters in grid -! - GRIDS(IMOD)%NX = MX - GRIDS(IMOD)%NY = MY - GRIDS(IMOD)%NSEA = MSEA + GRIDS(IMOD)%IS2PARS(:)=0. +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Update counters in grid + ! + GRIDS(IMOD)%NX = MX + GRIDS(IMOD)%NY = MY + GRIDS(IMOD)%NSEA = MSEA #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) - WRITE (NDST,9002) + WRITE (NDST,9002) #endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETG ( IMOD, NDSE, NDST ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) - WRITE (NDST,9003) -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DIMX : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DIMX : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NAUXGR = ',I10/ & - ' NGRIDS = ',I10/) - 1003 FORMAT (/' *** ERROR W3DIMX : ILLEGAL GRID DIMENSION(S) *** '/ & - ' INPUT = ',4I10 /) - 1004 FORMAT (/' *** ERROR W3DIMX : ARRAY(S) ALREADY ALLOCATED *** ') + WRITE (NDST,9003) +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DIMX : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DIMX : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NAUXGR = ',I10/ & + ' NGRIDS = ',I10/) +1003 FORMAT (/' *** ERROR W3DIMX : ILLEGAL GRID DIMENSION(S) *** '/ & + ' INPUT = ',4I10 /) +1004 FORMAT (/' *** ERROR W3DIMX : ARRAY(S) ALREADY ALLOCATED *** ') #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) - 9000 FORMAT (' TEST W3DIMX : MODEL ',I4,' DIM. AT ',2I5,I7) - 9001 FORMAT (' TEST W3DIMX : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DIMX : DIMENSIONS STORED') - 9003 FORMAT (' TEST W3DIMX : POINTERS RESET') -#endif -!/ -!/ End of W3DIMX ----------------------------------------------------- / -!/ - END SUBROUTINE W3DIMX -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DIMS ( IMOD, MK, MTH, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 19-Feb-2004 : Origination. ( version 3.06 ) -!/ 18-Jul-2006 : Add input grids. ( version 3.10 ) -!/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Initialize an individual spatial grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array GRIDS. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! MK,MTH Int. I Spectral dimensions. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Model definition file IO program. -! WW3_GRID Prog. N/A Model set up program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - Grid dimensions apre passed through parameter list and then -! locally stored to assure consistency between allocation and -! data in structure. -! - W3SETG needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT (' TEST W3DIMX : MODEL ',I4,' DIM. AT ',2I5,I7) +9001 FORMAT (' TEST W3DIMX : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DIMX : DIMENSIONS STORED') +9003 FORMAT (' TEST W3DIMX : POINTERS RESET') +#endif + !/ + !/ End of W3DIMX ----------------------------------------------------- / + !/ + END SUBROUTINE W3DIMX + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DIMS ( IMOD, MK, MTH, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 19-Feb-2004 : Origination. ( version 3.06 ) + !/ 18-Jul-2006 : Add input grids. ( version 3.10 ) + !/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual spatial grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array GRIDS. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! MK,MTH Int. I Spectral dimensions. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Model definition file IO program. + ! WW3_GRID Prog. N/A Model set up program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - Grid dimensions apre passed through parameter list and then + ! locally stored to assure consistency between allocation and + ! data in structure. + ! - W3SETG needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_ST4 - USE CONSTANTS, ONLY: RADE + USE CONSTANTS, ONLY: RADE #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, MK, MTH, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, SAVE :: MK2, MSPEC + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, MK, MTH, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: MK2, MSPEC #ifdef W3_ST4 - INTEGER :: SDSNTH + INTEGER :: SDSNTH #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3DIMS') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN - WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS - CALL EXTCDE (2) - END IF -! - IF ( MK.LT.3 .OR. MTH.LT.4 ) THEN - WRITE (NDSE,1003) MK, MTH - CALL EXTCDE (3) - END IF -! - IF ( SGRDS(IMOD)%SINIT ) THEN - WRITE (NDSE,1004) - CALL EXTCDE (4) - END IF -! - MK2 = MK + 2 - MSPEC = MK * MTH + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIMS') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN + WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS + CALL EXTCDE (2) + END IF + ! + IF ( MK.LT.3 .OR. MTH.LT.4 ) THEN + WRITE (NDSE,1003) MK, MTH + CALL EXTCDE (3) + END IF + ! + IF ( SGRDS(IMOD)%SINIT ) THEN + WRITE (NDSE,1004) + CALL EXTCDE (4) + END IF + ! + MK2 = MK + 2 + MSPEC = MK * MTH #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) - WRITE (NDST,9000) IMOD, MTH, MK, MK2, MSPEC -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! - ALLOCATE ( SGRDS(IMOD)%MAPWN(MSPEC+MTH), & - SGRDS(IMOD)%MAPTH(MSPEC+MTH), & - SGRDS(IMOD)%TH(MTH), & - SGRDS(IMOD)%ESIN(MSPEC+MTH), & - SGRDS(IMOD)%ECOS(MSPEC+MTH), & - SGRDS(IMOD)%ES2(MSPEC+MTH), & - SGRDS(IMOD)%ESC(MSPEC+MTH), & - SGRDS(IMOD)%EC2(MSPEC+MTH), & - SGRDS(IMOD)%SIG(0:MK+1), & - SGRDS(IMOD)%SIG2(MSPEC), & - SGRDS(IMOD)%DSIP(0:MK+1), & - SGRDS(IMOD)%DSII(MK), & - SGRDS(IMOD)%DDEN(MK), & - SGRDS(IMOD)%DDEN2(MSPEC), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - SGRDS(IMOD)%MAPWN(:)=0. - SGRDS(IMOD)%MAPTH(:)=0. - SGRDS(IMOD)%TH(:)=0. - SGRDS(IMOD)%ESIN(:)=0. - SGRDS(IMOD)%ECOS(:)=0. - SGRDS(IMOD)%ES2(:)=0. - SGRDS(IMOD)%ESC(:)=0. - SGRDS(IMOD)%EC2(:)=0. - SGRDS(IMOD)%SIG(:)=0. - SGRDS(IMOD)%SIG2(:)=0. - SGRDS(IMOD)%DSIP(:)=0. - SGRDS(IMOD)%DSII(:)=0. - SGRDS(IMOD)%DDEN(:)=0. - SGRDS(IMOD)%DDEN2(:)=0. + WRITE (NDST,9000) IMOD, MTH, MK, MK2, MSPEC +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + ALLOCATE ( SGRDS(IMOD)%MAPWN(MSPEC+MTH), & + SGRDS(IMOD)%MAPTH(MSPEC+MTH), & + SGRDS(IMOD)%TH(MTH), & + SGRDS(IMOD)%ESIN(MSPEC+MTH), & + SGRDS(IMOD)%ECOS(MSPEC+MTH), & + SGRDS(IMOD)%ES2(MSPEC+MTH), & + SGRDS(IMOD)%ESC(MSPEC+MTH), & + SGRDS(IMOD)%EC2(MSPEC+MTH), & + SGRDS(IMOD)%SIG(0:MK+1), & + SGRDS(IMOD)%SIG2(MSPEC), & + SGRDS(IMOD)%DSIP(0:MK+1), & + SGRDS(IMOD)%DSII(MK), & + SGRDS(IMOD)%DDEN(MK), & + SGRDS(IMOD)%DDEN2(MSPEC), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + SGRDS(IMOD)%MAPWN(:)=0. + SGRDS(IMOD)%MAPTH(:)=0. + SGRDS(IMOD)%TH(:)=0. + SGRDS(IMOD)%ESIN(:)=0. + SGRDS(IMOD)%ECOS(:)=0. + SGRDS(IMOD)%ES2(:)=0. + SGRDS(IMOD)%ESC(:)=0. + SGRDS(IMOD)%EC2(:)=0. + SGRDS(IMOD)%SIG(:)=0. + SGRDS(IMOD)%SIG2(:)=0. + SGRDS(IMOD)%DSIP(:)=0. + SGRDS(IMOD)%DSII(:)=0. + SGRDS(IMOD)%DDEN(:)=0. + SGRDS(IMOD)%DDEN2(:)=0. #ifdef W3_ST4 - ALLOCATE ( MPARS(IMOD)%SRCPS%IKTAB(MK,NDTAB), & - MPARS(IMOD)%SRCPS%DCKI(NKHS,NKD), & - MPARS(IMOD)%SRCPS%QBI(NKHS,NKD), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - SDSNTH = MTH/2-1 !MIN(NINT(SSDSDTH/(DTH*RADE)),MTH/2-1) - ALLOCATE( MPARS(IMOD)%SRCPS%SATINDICES(2*SDSNTH+1,MTH), & - MPARS(IMOD)%SRCPS%SATWEIGHTS(2*SDSNTH+1,MTH), & - MPARS(IMOD)%SRCPS%CUMULW(MSPEC,MSPEC), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! - SGRDS(IMOD)%SINIT = .TRUE. + ALLOCATE ( MPARS(IMOD)%SRCPS%IKTAB(MK,NDTAB), & + MPARS(IMOD)%SRCPS%DCKI(NKHS,NKD), & + MPARS(IMOD)%SRCPS%QBI(NKHS,NKD), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + SDSNTH = MTH/2-1 !MIN(NINT(SSDSDTH/(DTH*RADE)),MTH/2-1) + ALLOCATE( MPARS(IMOD)%SRCPS%SATINDICES(2*SDSNTH+1,MTH), & + MPARS(IMOD)%SRCPS%SATWEIGHTS(2*SDSNTH+1,MTH), & + MPARS(IMOD)%SRCPS%CUMULW(MSPEC,MSPEC), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! + SGRDS(IMOD)%SINIT = .TRUE. #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) - WRITE (NDST,9001) + WRITE (NDST,9001) #endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETG ( IMOD, NDSE, NDST ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) - WRITE (NDST,9002) -#endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! - NK = MK - NK2 = MK + 2 - NTH = MTH - NSPEC = MK * MTH + WRITE (NDST,9002) +#endif + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! + NK = MK + NK2 = MK + 2 + NTH = MTH + NSPEC = MK * MTH #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) - WRITE (NDST,9003) -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DIMS : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DIMS : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NAUXGR = ',I10/ & - ' NGRIDS = ',I10/) - 1003 FORMAT (/' *** ERROR W3DIMS : ILLEGAL GRID DIMENSION(S) *** '/ & - ' INPUT = ',4I10/) - 1004 FORMAT (/' *** ERROR W3DIMS : ARRAY(S) ALREADY ALLOCATED *** ') + WRITE (NDST,9003) +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DIMS : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DIMS : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NAUXGR = ',I10/ & + ' NGRIDS = ',I10/) +1003 FORMAT (/' *** ERROR W3DIMS : ILLEGAL GRID DIMENSION(S) *** '/ & + ' INPUT = ',4I10/) +1004 FORMAT (/' *** ERROR W3DIMS : ARRAY(S) ALREADY ALLOCATED *** ') #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) - 9000 FORMAT (' TEST W3DIMS : MODEL ',I4,' DIM. AT ',3I5,I7) - 9001 FORMAT (' TEST W3DIMS : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DIMS : POINTERS RESET') - 9003 FORMAT (' TEST W3DIMS : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DIMS ----------------------------------------------------- / -!/ - END SUBROUTINE W3DIMS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ ! J. H. Alves ! -!/ | FORTRAN 90 | -!/ | Last update : 03-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 24-Jun-2005 : Origination. ( version 3.07 ) -!/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) -!/ 23-Jun-2006 : Add data for W3SLN1. ( version 3.09 ) -!/ 18-Jul-2006 : Add input grids. ( version 3.10 ) -!/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) -!/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 18-Sep-2007 : Adding WAM4 source terms. ( version 3.13 ) -!/ ( F. Ardhuin ) -!/ 27-Jun-2008 : Expand WAM4 variants namelist ( version 3.14 ) -!/ ( F. Ardhuin ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear -!/ filter (SNLS) from 3.15 (HLT). ( version 4.08 ) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ -! 1. Purpose : -! -! Select one of the WAVEWATCH III grids / models. -! -! 2. Method : -! -! Point pointers to the proper variables in the proper element of -! the GRIDS array. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Many subroutines in eth WAVEWATCH system. -! -! 6. Error messages : -! -! Checks on parameter list IMOD. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/PRn Select propagation scheme -! -! !/STn Select source terms -! !/NLn -! !/BTn -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ +9000 FORMAT (' TEST W3DIMS : MODEL ',I4,' DIM. AT ',3I5,I7) +9001 FORMAT (' TEST W3DIMS : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DIMS : POINTERS RESET') +9003 FORMAT (' TEST W3DIMS : DIMENSIONS STORED') +#endif + !/ + !/ End of W3DIMS ----------------------------------------------------- / + !/ + END SUBROUTINE W3DIMS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ ! J. H. Alves ! + !/ | FORTRAN 90 | + !/ | Last update : 03-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 24-Jun-2005 : Origination. ( version 3.07 ) + !/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) + !/ 23-Jun-2006 : Add data for W3SLN1. ( version 3.09 ) + !/ 18-Jul-2006 : Add input grids. ( version 3.10 ) + !/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) + !/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) + !/ ( J. H. Alves ) + !/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) + !/ ( J. H. Alves ) + !/ 18-Sep-2007 : Adding WAM4 source terms. ( version 3.13 ) + !/ ( F. Ardhuin ) + !/ 27-Jun-2008 : Expand WAM4 variants namelist ( version 3.14 ) + !/ ( F. Ardhuin ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear + !/ filter (SNLS) from 3.15 (HLT). ( version 4.08 ) + !/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) + !/ + ! 1. Purpose : + ! + ! Select one of the WAVEWATCH III grids / models. + ! + ! 2. Method : + ! + ! Point pointers to the proper variables in the proper element of + ! the GRIDS array. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Many subroutines in eth WAVEWATCH system. + ! + ! 6. Error messages : + ! + ! Checks on parameter list IMOD. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/PRn Select propagation scheme + ! + ! !/STn Select source terms + ! !/NLn + ! !/BTn + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SETG') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN - WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS - CALL EXTCDE (2) - END IF + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SETG') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN + WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS + CALL EXTCDE (2) + END IF #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3SETG) - WRITE (NDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Set model numbers -! - IGRID = IMOD - ISGRD = IMOD - IPARS = IMOD -! -! -------------------------------------------------------------------- / -! 3. Set pointers in structure GRID -! - GTYPE => GRIDS(IMOD)%GTYPE - RSTYPE => GRIDS(IMOD)%RSTYPE - ICLOSE => GRIDS(IMOD)%ICLOSE -! - NX => GRIDS(IMOD)%NX - NY => GRIDS(IMOD)%NY - NSEA => GRIDS(IMOD)%NSEA - NSEAL => GRIDS(IMOD)%NSEAL - TRFLAG => GRIDS(IMOD)%TRFLAG - FLAGLL => GRIDS(IMOD)%FLAGLL -! -#ifdef W3_SMC - NCel => GRIDS(IMOD)%NCel - NUFc => GRIDS(IMOD)%NUFc - NVFc => GRIDS(IMOD)%NVFc - NRLv => GRIDS(IMOD)%NRLv - MRFct => GRIDS(IMOD)%MRFct -#endif -! + WRITE (NDST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Set model numbers + ! + IGRID = IMOD + ISGRD = IMOD + IPARS = IMOD + ! + ! -------------------------------------------------------------------- / + ! 3. Set pointers in structure GRID + ! + GTYPE => GRIDS(IMOD)%GTYPE + RSTYPE => GRIDS(IMOD)%RSTYPE + ICLOSE => GRIDS(IMOD)%ICLOSE + ! + NX => GRIDS(IMOD)%NX + NY => GRIDS(IMOD)%NY + NSEA => GRIDS(IMOD)%NSEA + NSEAL => GRIDS(IMOD)%NSEAL + TRFLAG => GRIDS(IMOD)%TRFLAG + FLAGLL => GRIDS(IMOD)%FLAGLL + ! #ifdef W3_SMC - NGLO => GRIDS(IMOD)%NGLO - NARC => GRIDS(IMOD)%NARC - NBGL => GRIDS(IMOD)%NBGL - NBAC => GRIDS(IMOD)%NBAC - NBSMC => GRIDS(IMOD)%NBSMC -#endif -! - E3DF => GRIDS(IMOD)%E3DF - P2MSF => GRIDS(IMOD)%P2MSF - US3DF => GRIDS(IMOD)%US3DF - USSPF => GRIDS(IMOD)%USSPF - USSP_WN => GRIDS(IMOD)%USSP_WN -#ifdef W3_REF1 - REFLC => GRIDS(IMOD)%REFLC - REFLD => GRIDS(IMOD)%REFLD -#endif - FFACBERG => GRIDS(IMOD)%FFACBERG + NCel => GRIDS(IMOD)%NCel + NUFc => GRIDS(IMOD)%NUFc + NVFc => GRIDS(IMOD)%NVFc + NRLv => GRIDS(IMOD)%NRLv + MRFct => GRIDS(IMOD)%MRFct + NGLO => GRIDS(IMOD)%NGLO + NARC => GRIDS(IMOD)%NARC + NBGL => GRIDS(IMOD)%NBGL + NBAC => GRIDS(IMOD)%NBAC + NBSMC => GRIDS(IMOD)%NBSMC +#endif + ! + E3DF => GRIDS(IMOD)%E3DF + P2MSF => GRIDS(IMOD)%P2MSF + US3DF => GRIDS(IMOD)%US3DF + USSPF => GRIDS(IMOD)%USSPF + USSP_WN => GRIDS(IMOD)%USSP_WN + FFACBERG => GRIDS(IMOD)%FFACBERG #ifdef W3_REF1 - RREF => GRIDS(IMOD)%RREF - REFPARS=> GRIDS(IMOD)%REFPARS + REFLC => GRIDS(IMOD)%REFLC + REFLD => GRIDS(IMOD)%REFLD + RREF => GRIDS(IMOD)%RREF + REFPARS=> GRIDS(IMOD)%REFPARS #endif #ifdef W3_IG1 - IGPARS => GRIDS(IMOD)%IGPARS + IGPARS => GRIDS(IMOD)%IGPARS #endif #ifdef W3_IC2 - IC2PARS => GRIDS(IMOD)%IC2PARS + IC2PARS => GRIDS(IMOD)%IC2PARS #endif #ifdef W3_IC3 - IC3PARS => GRIDS(IMOD)%IC3PARS + IC3PARS => GRIDS(IMOD)%IC3PARS #endif #ifdef W3_IC4 - IC4PARS => GRIDS(IMOD)%IC4PARS - IC4_KI => GRIDS(IMOD)%IC4_KI - IC4_FC => GRIDS(IMOD)%IC4_FC + IC4PARS => GRIDS(IMOD)%IC4PARS + IC4_KI => GRIDS(IMOD)%IC4_KI + IC4_FC => GRIDS(IMOD)%IC4_FC #endif #ifdef W3_IC5 - IC5PARS => GRIDS(IMOD)%IC5PARS + IC5PARS => GRIDS(IMOD)%IC5PARS #endif #ifdef W3_IS2 - IS2PARS => GRIDS(IMOD)%IS2PARS -#endif - SX => GRIDS(IMOD)%SX - SY => GRIDS(IMOD)%SY - X0 => GRIDS(IMOD)%X0 - Y0 => GRIDS(IMOD)%Y0 -! - DTCFL => GRIDS(IMOD)%DTCFL - DTCFLI => GRIDS(IMOD)%DTCFLI - DTMAX => GRIDS(IMOD)%DTMAX - DTMIN => GRIDS(IMOD)%DTMIN - DMIN => GRIDS(IMOD)%DMIN + IS2PARS => GRIDS(IMOD)%IS2PARS +#endif + SX => GRIDS(IMOD)%SX + SY => GRIDS(IMOD)%SY + X0 => GRIDS(IMOD)%X0 + Y0 => GRIDS(IMOD)%Y0 + ! + DTCFL => GRIDS(IMOD)%DTCFL + DTCFLI => GRIDS(IMOD)%DTCFLI + DTMAX => GRIDS(IMOD)%DTMAX + DTMIN => GRIDS(IMOD)%DTMIN + DMIN => GRIDS(IMOD)%DMIN #ifdef W3_SEC1 - NITERSEC1 => GRIDS(IMOD)%NITERSEC1 + NITERSEC1 => GRIDS(IMOD)%NITERSEC1 #endif - CTMAX => GRIDS(IMOD)%CTMAX - FICE0 => GRIDS(IMOD)%FICE0 - GRIDSHIFT => GRIDS(IMOD)%GRIDSHIFT - CMPRTRCK => GRIDS(IMOD)%CMPRTRCK + CTMAX => GRIDS(IMOD)%CTMAX + FICE0 => GRIDS(IMOD)%FICE0 + GRIDSHIFT => GRIDS(IMOD)%GRIDSHIFT + CMPRTRCK => GRIDS(IMOD)%CMPRTRCK #ifdef W3_RTD - PoLat => GRIDS(IMOD)%PoLat - PoLon => GRIDS(IMOD)%PoLon - FLAGUNR => GRIDS(IMOD)%FLAGUNR -#endif - FICEN => GRIDS(IMOD)%FICEN - FICEL => GRIDS(IMOD)%FICEL - IICEHMIN => GRIDS(IMOD)%IICEHMIN - IICEHDISP => GRIDS(IMOD)%IICEHDISP - IICEFDISP => GRIDS(IMOD)%IICEFDISP - IICEDDISP => GRIDS(IMOD)%IICEDDISP - IICEHFAC => GRIDS(IMOD)%IICEHFAC - IICEHINIT => GRIDS(IMOD)%IICEHINIT - ICESCALES => GRIDS(IMOD)%ICESCALES - PFMOVE => GRIDS(IMOD)%PFMOVE - STEXU => GRIDS(IMOD)%STEXU - STEYU => GRIDS(IMOD)%STEYU - STEDU => GRIDS(IMOD)%STEDU - BTBETA => GRIDS(IMOD)%BTBETA - AAIRGB => GRIDS(IMOD)%AAIRGB - AAIRCMIN => GRIDS(IMOD)%AAIRCMIN -! - GINIT => GRIDS(IMOD)%GINIT - GUGINIT => GRIDS(IMOD)%GUGINIT - FLDRY => GRIDS(IMOD)%FLDRY - FLCX => GRIDS(IMOD)%FLCX - FLCY => GRIDS(IMOD)%FLCY - FLCTH => GRIDS(IMOD)%FLCTH - FLCK => GRIDS(IMOD)%FLCK - FLSOU => GRIDS(IMOD)%FLSOU - IICEDISP => GRIDS(IMOD)%IICEDISP - IICESMOOTH => GRIDS(IMOD)%IICESMOOTH -! - GNAME => GRIDS(IMOD)%GNAME - FILEXT => GRIDS(IMOD)%FILEXT - TRIGP => GRIDS(IMOD)%TRIGP - NTRI => GRIDS(IMOD)%NTRI - COUNTRI => GRIDS(IMOD)%COUNTRI - SI => GRIDS(IMOD)%SI - COUNTOT => GRIDS(IMOD)%COUNTOT - IEN => GRIDS(IMOD)%IEN - LEN => GRIDS(IMOD)%LEN - ANGLE => GRIDS(IMOD)%ANGLE - ANGLE0 => GRIDS(IMOD)%ANGLE0 - CCON => GRIDS(IMOD)%CCON - COUNTCON => GRIDS(IMOD)%COUNTCON - INDEX_CELL => GRIDS(IMOD)%INDEX_CELL - IE_CELL => GRIDS(IMOD)%IE_CELL - POS_CELL => GRIDS(IMOD)%POS_CELL - IOBP => GRIDS(IMOD)%IOBP - IAA => GRIDS(IMOD)%IAA - JAA => GRIDS(IMOD)%JAA - POSI => GRIDS(IMOD)%POSI - I_DIAG => GRIDS(IMOD)%I_DIAG - JA_IE => GRIDS(IMOD)%JA_IE - NBEDGE => GRIDS(IMOD)%NBEDGE - EDGES => GRIDS(IMOD)%EDGES - NEIGH => GRIDS(IMOD)%NEIGH - NNZ => GRIDS(IMOD)%NNZ - IOBPD => GRIDS(IMOD)%IOBPD - IOBDP => GRIDS(IMOD)%IOBDP - IOBPA => GRIDS(IMOD)%IOBPA - TRIA => GRIDS(IMOD)%TRIA - CROSSDIFF => GRIDS(IMOD)%CROSSDIFF - MAXX => GRIDS(IMOD)%MAXX - MAXY => GRIDS(IMOD)%MAXY - DXYMAX => GRIDS(IMOD)%DXYMAX - XGRD => GRIDS(IMOD)%XGRD - YGRD => GRIDS(IMOD)%YGRD - ZB => GRIDS(IMOD)%ZB -! - IF ( GINIT ) THEN -! - MAPSTA => GRIDS(IMOD)%MAPSTA - MAPST2 => GRIDS(IMOD)%MAPST2 - MAPFS => GRIDS(IMOD)%MAPFS - MAPSF => GRIDS(IMOD)%MAPSF - FLAGST => GRIDS(IMOD)%FLAGST -! + PoLat => GRIDS(IMOD)%PoLat + PoLon => GRIDS(IMOD)%PoLon + FLAGUNR => GRIDS(IMOD)%FLAGUNR +#endif + FICEN => GRIDS(IMOD)%FICEN + FICEL => GRIDS(IMOD)%FICEL + IICEHMIN => GRIDS(IMOD)%IICEHMIN + IICEHDISP => GRIDS(IMOD)%IICEHDISP + IICEFDISP => GRIDS(IMOD)%IICEFDISP + IICEDDISP => GRIDS(IMOD)%IICEDDISP + IICEHFAC => GRIDS(IMOD)%IICEHFAC + IICEHINIT => GRIDS(IMOD)%IICEHINIT + ICESCALES => GRIDS(IMOD)%ICESCALES + PFMOVE => GRIDS(IMOD)%PFMOVE + STEXU => GRIDS(IMOD)%STEXU + STEYU => GRIDS(IMOD)%STEYU + STEDU => GRIDS(IMOD)%STEDU + BTBETA => GRIDS(IMOD)%BTBETA + AAIRGB => GRIDS(IMOD)%AAIRGB + AAIRCMIN => GRIDS(IMOD)%AAIRCMIN + ! + GINIT => GRIDS(IMOD)%GINIT + GUGINIT => GRIDS(IMOD)%GUGINIT + FLDRY => GRIDS(IMOD)%FLDRY + FLCX => GRIDS(IMOD)%FLCX + FLCY => GRIDS(IMOD)%FLCY + FLCTH => GRIDS(IMOD)%FLCTH + FLCK => GRIDS(IMOD)%FLCK + FLSOU => GRIDS(IMOD)%FLSOU + IICEDISP => GRIDS(IMOD)%IICEDISP + IICESMOOTH => GRIDS(IMOD)%IICESMOOTH + ! + GNAME => GRIDS(IMOD)%GNAME + FILEXT => GRIDS(IMOD)%FILEXT + TRIGP => GRIDS(IMOD)%TRIGP + NTRI => GRIDS(IMOD)%NTRI + COUNTRI => GRIDS(IMOD)%COUNTRI + SI => GRIDS(IMOD)%SI + COUNTOT => GRIDS(IMOD)%COUNTOT + IEN => GRIDS(IMOD)%IEN + LEN => GRIDS(IMOD)%LEN + ANGLE => GRIDS(IMOD)%ANGLE + ANGLE0 => GRIDS(IMOD)%ANGLE0 + CCON => GRIDS(IMOD)%CCON + COUNTCON => GRIDS(IMOD)%COUNTCON + INDEX_CELL => GRIDS(IMOD)%INDEX_CELL + IE_CELL => GRIDS(IMOD)%IE_CELL + POS_CELL => GRIDS(IMOD)%POS_CELL + IOBP => GRIDS(IMOD)%IOBP + IAA => GRIDS(IMOD)%IAA + JAA => GRIDS(IMOD)%JAA + POSI => GRIDS(IMOD)%POSI + I_DIAG => GRIDS(IMOD)%I_DIAG + JA_IE => GRIDS(IMOD)%JA_IE + NBEDGE => GRIDS(IMOD)%NBEDGE + EDGES => GRIDS(IMOD)%EDGES + NEIGH => GRIDS(IMOD)%NEIGH + NNZ => GRIDS(IMOD)%NNZ + IOBPD => GRIDS(IMOD)%IOBPD + IOBDP => GRIDS(IMOD)%IOBDP + IOBPA => GRIDS(IMOD)%IOBPA + TRIA => GRIDS(IMOD)%TRIA + CROSSDIFF => GRIDS(IMOD)%CROSSDIFF + MAXX => GRIDS(IMOD)%MAXX + MAXY => GRIDS(IMOD)%MAXY + DXYMAX => GRIDS(IMOD)%DXYMAX + XGRD => GRIDS(IMOD)%XGRD + YGRD => GRIDS(IMOD)%YGRD + ZB => GRIDS(IMOD)%ZB + ! + IF ( GINIT ) THEN + ! + MAPSTA => GRIDS(IMOD)%MAPSTA + MAPST2 => GRIDS(IMOD)%MAPST2 + MAPFS => GRIDS(IMOD)%MAPFS + MAPSF => GRIDS(IMOD)%MAPSF + FLAGST => GRIDS(IMOD)%FLAGST + ! #ifdef W3_RTD - AnglD => GRIDS(IMOD)%AnglD -#endif - CLATS => GRIDS(IMOD)%CLATS - CLATIS => GRIDS(IMOD)%CLATIS - CTHG0S => GRIDS(IMOD)%CTHG0S - TRNX => GRIDS(IMOD)%TRNX - TRNY => GRIDS(IMOD)%TRNY -! - DXDP => GRIDS(IMOD)%DXDP - DXDQ => GRIDS(IMOD)%DXDQ - DYDP => GRIDS(IMOD)%DYDP - DYDQ => GRIDS(IMOD)%DYDQ - DPDX => GRIDS(IMOD)%DPDX - DPDY => GRIDS(IMOD)%DPDY - DQDX => GRIDS(IMOD)%DQDX - DQDY => GRIDS(IMOD)%DQDY - GSQRT => GRIDS(IMOD)%GSQRT - HPFAC => GRIDS(IMOD)%HPFAC - HQFAC => GRIDS(IMOD)%HQFAC -! + AnglD => GRIDS(IMOD)%AnglD +#endif + CLATS => GRIDS(IMOD)%CLATS + CLATIS => GRIDS(IMOD)%CLATIS + CTHG0S => GRIDS(IMOD)%CTHG0S + TRNX => GRIDS(IMOD)%TRNX + TRNY => GRIDS(IMOD)%TRNY + ! + DXDP => GRIDS(IMOD)%DXDP + DXDQ => GRIDS(IMOD)%DXDQ + DYDP => GRIDS(IMOD)%DYDP + DYDQ => GRIDS(IMOD)%DYDQ + DPDX => GRIDS(IMOD)%DPDX + DPDY => GRIDS(IMOD)%DPDY + DQDX => GRIDS(IMOD)%DQDX + DQDY => GRIDS(IMOD)%DQDY + GSQRT => GRIDS(IMOD)%GSQRT + HPFAC => GRIDS(IMOD)%HPFAC + HQFAC => GRIDS(IMOD)%HQFAC + ! #ifdef W3_BT4 - SED_D50 => GRIDS(IMOD)%SED_D50 - SED_PSIC => GRIDS(IMOD)%SED_PSIC + SED_D50 => GRIDS(IMOD)%SED_D50 + SED_PSIC => GRIDS(IMOD)%SED_PSIC #endif -! + ! #ifdef W3_SMC - NLvCel => GRIDS(IMOD)%NLvCel - NLvUFc => GRIDS(IMOD)%NLvUFc - NLvVFc => GRIDS(IMOD)%NLvVFc - IJKCel => GRIDS(IMOD)%IJKCel - IJKUFc => GRIDS(IMOD)%IJKUFc - IJKVFc => GRIDS(IMOD)%IJKVFc - ISMCBP => GRIDS(IMOD)%ISMCBP - CTRNX => GRIDS(IMOD)%CTRNX - CTRNY => GRIDS(IMOD)%CTRNY - CLATF => GRIDS(IMOD)%CLATF - - IJKCel3 => GRIDS(IMOD)%IJKCel3 - IJKCel4 => GRIDS(IMOD)%IJKCel4 - IJKVFc5 => GRIDS(IMOD)%IJKVFc5 - IJKVFc6 => GRIDS(IMOD)%IJKVFc6 - IJKUFc5 => GRIDS(IMOD)%IJKUFc5 - IJKUFc6 => GRIDS(IMOD)%IJKUFc6 + NLvCel => GRIDS(IMOD)%NLvCel + NLvUFc => GRIDS(IMOD)%NLvUFc + NLvVFc => GRIDS(IMOD)%NLvVFc + IJKCel => GRIDS(IMOD)%IJKCel + IJKUFc => GRIDS(IMOD)%IJKUFc + IJKVFc => GRIDS(IMOD)%IJKVFc + ISMCBP => GRIDS(IMOD)%ISMCBP + CTRNX => GRIDS(IMOD)%CTRNX + CTRNY => GRIDS(IMOD)%CTRNY + CLATF => GRIDS(IMOD)%CLATF -#endif -! -#ifdef W3_SMC - ICLBAC => GRIDS(IMOD)%ICLBAC - ANGARC => GRIDS(IMOD)%ANGARC - SPCBAC => GRIDS(IMOD)%SPCBAC -#endif -! - GSU => GRIDS(IMOD)%GSU -! - END IF -! -! -------------------------------------------------------------------- / -! 4. Set pointers in structure SGRD -! - NK => SGRDS(IMOD)%NK - NK2 => SGRDS(IMOD)%NK2 - NTH => SGRDS(IMOD)%NTH - NSPEC => SGRDS(IMOD)%NSPEC -! - DTH => SGRDS(IMOD)%DTH - XFR => SGRDS(IMOD)%XFR - FR1 => SGRDS(IMOD)%FR1 - FTE => SGRDS(IMOD)%FTE - FTF => SGRDS(IMOD)%FTF - FTWN => SGRDS(IMOD)%FTWN - FTTR => SGRDS(IMOD)%FTTR - FTWL => SGRDS(IMOD)%FTWL - FACTI1 => SGRDS(IMOD)%FACTI1 - FACTI2 => SGRDS(IMOD)%FACTI2 - FACHFA => SGRDS(IMOD)%FACHFA - FACHFE => SGRDS(IMOD)%FACHFE -! - SINIT => SGRDS(IMOD)%SINIT -! - IF ( SINIT ) THEN -! - MAPWN => SGRDS(IMOD)%MAPWN - MAPTH => SGRDS(IMOD)%MAPTH -! - TH => SGRDS(IMOD)%TH - ESIN => SGRDS(IMOD)%ESIN - ECOS => SGRDS(IMOD)%ECOS - ES2 => SGRDS(IMOD)%ES2 - ESC => SGRDS(IMOD)%ESC - EC2 => SGRDS(IMOD)%EC2 - SIG => SGRDS(IMOD)%SIG - SIG2 => SGRDS(IMOD)%SIG2 - DSIP => SGRDS(IMOD)%DSIP - DSII => SGRDS(IMOD)%DSII - DDEN => SGRDS(IMOD)%DDEN - DDEN2 => SGRDS(IMOD)%DDEN2 -! - END IF -! -! -------------------------------------------------------------------- / -! 5. Set pointers in structure MPAR -! - PINIT => MPARS(IMOD)%PINIT -! -! Structure NPARS -! - FACP => MPARS(IMOD)%NPARS%FACP - XREL => MPARS(IMOD)%NPARS%XREL - XFLT => MPARS(IMOD)%NPARS%XFLT - FXFM => MPARS(IMOD)%NPARS%FXFM - FXPM => MPARS(IMOD)%NPARS%FXPM - XFT => MPARS(IMOD)%NPARS%XFT - XFC => MPARS(IMOD)%NPARS%XFC - FACSD => MPARS(IMOD)%NPARS%FACSD - FHMAX => MPARS(IMOD)%NPARS%FHMAX + IJKCel3 => GRIDS(IMOD)%IJKCel3 + IJKCel4 => GRIDS(IMOD)%IJKCel4 + IJKVFc5 => GRIDS(IMOD)%IJKVFc5 + IJKVFc6 => GRIDS(IMOD)%IJKVFc6 + IJKUFc5 => GRIDS(IMOD)%IJKUFc5 + IJKUFc6 => GRIDS(IMOD)%IJKUFc6 + ICLBAC => GRIDS(IMOD)%ICLBAC + ANGARC => GRIDS(IMOD)%ANGARC + SPCBAC => GRIDS(IMOD)%SPCBAC +#endif + ! + GSU => GRIDS(IMOD)%GSU + ! + END IF + ! + ! -------------------------------------------------------------------- / + ! 4. Set pointers in structure SGRD + ! + NK => SGRDS(IMOD)%NK + NK2 => SGRDS(IMOD)%NK2 + NTH => SGRDS(IMOD)%NTH + NSPEC => SGRDS(IMOD)%NSPEC + ! + DTH => SGRDS(IMOD)%DTH + XFR => SGRDS(IMOD)%XFR + FR1 => SGRDS(IMOD)%FR1 + FTE => SGRDS(IMOD)%FTE + FTF => SGRDS(IMOD)%FTF + FTWN => SGRDS(IMOD)%FTWN + FTTR => SGRDS(IMOD)%FTTR + FTWL => SGRDS(IMOD)%FTWL + FACTI1 => SGRDS(IMOD)%FACTI1 + FACTI2 => SGRDS(IMOD)%FACTI2 + FACHFA => SGRDS(IMOD)%FACHFA + FACHFE => SGRDS(IMOD)%FACHFE + ! + SINIT => SGRDS(IMOD)%SINIT + ! + IF ( SINIT ) THEN + ! + MAPWN => SGRDS(IMOD)%MAPWN + MAPTH => SGRDS(IMOD)%MAPTH + ! + TH => SGRDS(IMOD)%TH + ESIN => SGRDS(IMOD)%ESIN + ECOS => SGRDS(IMOD)%ECOS + ES2 => SGRDS(IMOD)%ES2 + ESC => SGRDS(IMOD)%ESC + EC2 => SGRDS(IMOD)%EC2 + SIG => SGRDS(IMOD)%SIG + SIG2 => SGRDS(IMOD)%SIG2 + DSIP => SGRDS(IMOD)%DSIP + DSII => SGRDS(IMOD)%DSII + DDEN => SGRDS(IMOD)%DDEN + DDEN2 => SGRDS(IMOD)%DDEN2 + ! + END IF + ! + ! -------------------------------------------------------------------- / + ! 5. Set pointers in structure MPAR + ! + PINIT => MPARS(IMOD)%PINIT + ! + ! Structure NPARS + ! + FACP => MPARS(IMOD)%NPARS%FACP + XREL => MPARS(IMOD)%NPARS%XREL + XFLT => MPARS(IMOD)%NPARS%XFLT + FXFM => MPARS(IMOD)%NPARS%FXFM + FXPM => MPARS(IMOD)%NPARS%FXPM + XFT => MPARS(IMOD)%NPARS%XFT + XFC => MPARS(IMOD)%NPARS%XFC + FACSD => MPARS(IMOD)%NPARS%FACSD + FHMAX => MPARS(IMOD)%NPARS%FHMAX #ifdef W3_RWND RWINDC => MPARS(IMOD)%NPARS%RWINDC #endif #ifdef W3_WCOR WWCOR => MPARS(IMOD)%NPARS%WWCOR #endif -! -! Structure PROPS -! + ! + ! Structure PROPS + ! #ifdef W3_PR2 - DTME => MPARS(IMOD)%PROPS%DTME - CLATMN => MPARS(IMOD)%PROPS%CLATMN + DTME => MPARS(IMOD)%PROPS%DTME + CLATMN => MPARS(IMOD)%PROPS%CLATMN #endif #ifdef W3_PR3 - WDCG => MPARS(IMOD)%PROPS%WDCG - WDTH => MPARS(IMOD)%PROPS%WDTH + WDCG => MPARS(IMOD)%PROPS%WDCG + WDTH => MPARS(IMOD)%PROPS%WDTH #endif #ifdef W3_SMC - DTMS => MPARS(IMOD)%PROPS%DTMS - Refran => MPARS(IMOD)%PROPS%Refran - FUNO3 => MPARS(IMOD)%PROPS%FUNO3 - FVERG => MPARS(IMOD)%PROPS%FVERG - FSWND => MPARS(IMOD)%PROPS%FSWND - ARCTC => MPARS(IMOD)%PROPS%ARCTC -#endif -! -! Structure FLDP -! + DTMS => MPARS(IMOD)%PROPS%DTMS + Refran => MPARS(IMOD)%PROPS%Refran + FUNO3 => MPARS(IMOD)%PROPS%FUNO3 + FVERG => MPARS(IMOD)%PROPS%FVERG + FSWND => MPARS(IMOD)%PROPS%FSWND + ARCTC => MPARS(IMOD)%PROPS%ARCTC +#endif + ! + ! Structure FLDP + ! #ifdef W3_FLD1 - TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID - TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV - TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 - TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 + TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID + TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV + TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 + TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 #endif #ifdef W3_FLD2 - TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID - TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV - TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 - TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 -#endif -! -! Structure SFLPS -! + TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID + TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV + TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 + TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 +#endif + ! + ! Structure SFLPS + ! #ifdef W3_FLX2 - NITTIN => MPARS(IMOD)%SFLPS%NITTIN - CINXSI => MPARS(IMOD)%SFLPS%CINXSI + NITTIN => MPARS(IMOD)%SFLPS%NITTIN + CINXSI => MPARS(IMOD)%SFLPS%CINXSI #endif #ifdef W3_FLX3 - NITTIN => MPARS(IMOD)%SFLPS%NITTIN - CAP_ID => MPARS(IMOD)%SFLPS%CAP_ID - CINXSI => MPARS(IMOD)%SFLPS%CINXSI - CD_MAX => MPARS(IMOD)%SFLPS%CD_MAX + NITTIN => MPARS(IMOD)%SFLPS%NITTIN + CAP_ID => MPARS(IMOD)%SFLPS%CAP_ID + CINXSI => MPARS(IMOD)%SFLPS%CINXSI + CD_MAX => MPARS(IMOD)%SFLPS%CD_MAX #endif #ifdef W3_FLX4 - FLX4A0 => MPARS(IMOD)%SFLPS%FLX4A0 + FLX4A0 => MPARS(IMOD)%SFLPS%FLX4A0 #endif -! -! Structure SLNPS -! + ! + ! Structure SLNPS + ! #ifdef W3_LN1 - SLNC1 => MPARS(IMOD)%SLNPS%SLNC1 - FSPM => MPARS(IMOD)%SLNPS%FSPM - FSHF => MPARS(IMOD)%SLNPS%FSHF -#endif -! -! Structure SRCPS -! - WWNMEANPTAIL=> MPARS(IMOD)%SRCPS%WWNMEANPTAIL - SSTXFTFTAIL => MPARS(IMOD)%SRCPS%SSTXFTFTAIL + SLNC1 => MPARS(IMOD)%SLNPS%SLNC1 + FSPM => MPARS(IMOD)%SLNPS%FSPM + FSHF => MPARS(IMOD)%SLNPS%FSHF +#endif + ! + ! Structure SRCPS + ! + WWNMEANPTAIL=> MPARS(IMOD)%SRCPS%WWNMEANPTAIL + SSTXFTFTAIL => MPARS(IMOD)%SRCPS%SSTXFTFTAIL #ifdef W3_ST1 - SINC1 => MPARS(IMOD)%SRCPS%SINC1 - SDSC1 => MPARS(IMOD)%SRCPS%SDSC1 + SINC1 => MPARS(IMOD)%SRCPS%SINC1 + SDSC1 => MPARS(IMOD)%SRCPS%SDSC1 #endif #ifdef W3_ST2 - ZWIND => MPARS(IMOD)%SRCPS%ZWIND - FSWELL => MPARS(IMOD)%SRCPS%FSWELL - SHSTAB => MPARS(IMOD)%SRCPS%SHSTAB - OFSTAB => MPARS(IMOD)%SRCPS%OFSTAB - CCNG => MPARS(IMOD)%SRCPS%CCNG - CCPS => MPARS(IMOD)%SRCPS%CCPS - FFNG => MPARS(IMOD)%SRCPS%FFNG - FFPS => MPARS(IMOD)%SRCPS%FFPS - CDSA0 => MPARS(IMOD)%SRCPS%CDSA0 - CDSA1 => MPARS(IMOD)%SRCPS%CDSA1 - CDSA2 => MPARS(IMOD)%SRCPS%CDSA2 - SDSALN => MPARS(IMOD)%SRCPS%SDSALN - CDSB0 => MPARS(IMOD)%SRCPS%CDSB0 - CDSB1 => MPARS(IMOD)%SRCPS%CDSB1 - CDSB2 => MPARS(IMOD)%SRCPS%CDSB2 - CDSB3 => MPARS(IMOD)%SRCPS%CDSB3 - FPIMIN => MPARS(IMOD)%SRCPS%FPIMIN - XFH => MPARS(IMOD)%SRCPS%XFH - XF1 => MPARS(IMOD)%SRCPS%XF1 - XF2 => MPARS(IMOD)%SRCPS%XF2 -#endif -! + ZWIND => MPARS(IMOD)%SRCPS%ZWIND + FSWELL => MPARS(IMOD)%SRCPS%FSWELL + SHSTAB => MPARS(IMOD)%SRCPS%SHSTAB + OFSTAB => MPARS(IMOD)%SRCPS%OFSTAB + CCNG => MPARS(IMOD)%SRCPS%CCNG + CCPS => MPARS(IMOD)%SRCPS%CCPS + FFNG => MPARS(IMOD)%SRCPS%FFNG + FFPS => MPARS(IMOD)%SRCPS%FFPS + CDSA0 => MPARS(IMOD)%SRCPS%CDSA0 + CDSA1 => MPARS(IMOD)%SRCPS%CDSA1 + CDSA2 => MPARS(IMOD)%SRCPS%CDSA2 + SDSALN => MPARS(IMOD)%SRCPS%SDSALN + CDSB0 => MPARS(IMOD)%SRCPS%CDSB0 + CDSB1 => MPARS(IMOD)%SRCPS%CDSB1 + CDSB2 => MPARS(IMOD)%SRCPS%CDSB2 + CDSB3 => MPARS(IMOD)%SRCPS%CDSB3 + FPIMIN => MPARS(IMOD)%SRCPS%FPIMIN + XFH => MPARS(IMOD)%SRCPS%XFH + XF1 => MPARS(IMOD)%SRCPS%XF1 + XF2 => MPARS(IMOD)%SRCPS%XF2 +#endif + ! #ifdef W3_ST3 - ZZWND => MPARS(IMOD)%SRCPS%ZZWND - AALPHA => MPARS(IMOD)%SRCPS%AALPHA - BBETA => MPARS(IMOD)%SRCPS%BBETA - SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP - ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX - ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT - ZZALP => MPARS(IMOD)%SRCPS%ZZALP - TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER - SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF - SSDSC1 => MPARS(IMOD)%SRCPS%SSDSC1 - WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP - FFXFM => MPARS(IMOD)%SRCPS%FFXFM - FFXPM => MPARS(IMOD)%SRCPS%FFXPM - DDELTA1 => MPARS(IMOD)%SRCPS%DDELTA1 - DDELTA2 => MPARS(IMOD)%SRCPS%DDELTA2 - SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF - SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN -#endif -! + ZZWND => MPARS(IMOD)%SRCPS%ZZWND + AALPHA => MPARS(IMOD)%SRCPS%AALPHA + BBETA => MPARS(IMOD)%SRCPS%BBETA + SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP + ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX + ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT + ZZALP => MPARS(IMOD)%SRCPS%ZZALP + TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER + SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF + SSDSC1 => MPARS(IMOD)%SRCPS%SSDSC1 + WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP + FFXFM => MPARS(IMOD)%SRCPS%FFXFM + FFXPM => MPARS(IMOD)%SRCPS%FFXPM + DDELTA1 => MPARS(IMOD)%SRCPS%DDELTA1 + DDELTA2 => MPARS(IMOD)%SRCPS%DDELTA2 + SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF + SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN +#endif + ! #ifdef W3_ST4 - ZZWND => MPARS(IMOD)%SRCPS%ZZWND - AALPHA => MPARS(IMOD)%SRCPS%AALPHA - BBETA => MPARS(IMOD)%SRCPS%BBETA - SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP - ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX - ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT - ZZALP => MPARS(IMOD)%SRCPS%ZZALP - TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER - SSWELLFPAR => MPARS(IMOD)%SRCPS%SSWELLFPAR - SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF - SSDSC => MPARS(IMOD)%SRCPS%SSDSC - SSDSBR => MPARS(IMOD)%SRCPS%SSDSBR - SSDSBT => MPARS(IMOD)%SRCPS%SSDSBT - SSDSBRF1 => MPARS(IMOD)%SRCPS%SSDSBRF1 - SSDSBRF2 => MPARS(IMOD)%SRCPS%SSDSBRF2 - SSDSBRFDF => MPARS(IMOD)%SRCPS%SSDSBRFDF - SSDSBM => MPARS(IMOD)%SRCPS%SSDSBM - SSDSBCK => MPARS(IMOD)%SRCPS%SSDSBCK - SSDSABK => MPARS(IMOD)%SRCPS%SSDSABK - SSDSPBK => MPARS(IMOD)%SRCPS%SSDSPBK - SSDSHCK => MPARS(IMOD)%SRCPS%SSDSHCK - SSDSBINT => MPARS(IMOD)%SRCPS%SSDSBINT - SSDSP => MPARS(IMOD)%SRCPS%SSDSP - WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP - FFXFM => MPARS(IMOD)%SRCPS%FFXFM - FFXFA => MPARS(IMOD)%SRCPS%FFXFA - FFXPM => MPARS(IMOD)%SRCPS%FFXPM - SSDSDTH => MPARS(IMOD)%SRCPS%SSDSDTH - SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF - SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN - SSDSCOS => MPARS(IMOD)%SRCPS%SSDSCOS - SSDSISO => MPARS(IMOD)%SRCPS%SSDSISO - IKTAB => MPARS(IMOD)%SRCPS%IKTAB - DCKI => MPARS(IMOD)%SRCPS%DCKI - QBI => MPARS(IMOD)%SRCPS%QBI - CUMULW => MPARS(IMOD)%SRCPS%CUMULW - SATINDICES => MPARS(IMOD)%SRCPS%SATINDICES - SATWEIGHTS => MPARS(IMOD)%SRCPS%SATWEIGHTS - SSINBR => MPARS(IMOD)%SRCPS%SSINBR -#endif -! + ZZWND => MPARS(IMOD)%SRCPS%ZZWND + AALPHA => MPARS(IMOD)%SRCPS%AALPHA + BBETA => MPARS(IMOD)%SRCPS%BBETA + SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP + ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX + ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT + ZZALP => MPARS(IMOD)%SRCPS%ZZALP + TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER + SSWELLFPAR => MPARS(IMOD)%SRCPS%SSWELLFPAR + SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF + SSDSC => MPARS(IMOD)%SRCPS%SSDSC + SSDSBR => MPARS(IMOD)%SRCPS%SSDSBR + SSDSBT => MPARS(IMOD)%SRCPS%SSDSBT + SSDSBRF1 => MPARS(IMOD)%SRCPS%SSDSBRF1 + SSDSBRF2 => MPARS(IMOD)%SRCPS%SSDSBRF2 + SSDSBRFDF => MPARS(IMOD)%SRCPS%SSDSBRFDF + SSDSBM => MPARS(IMOD)%SRCPS%SSDSBM + SSDSBCK => MPARS(IMOD)%SRCPS%SSDSBCK + SSDSABK => MPARS(IMOD)%SRCPS%SSDSABK + SSDSPBK => MPARS(IMOD)%SRCPS%SSDSPBK + SSDSHCK => MPARS(IMOD)%SRCPS%SSDSHCK + SSDSBINT => MPARS(IMOD)%SRCPS%SSDSBINT + SSDSP => MPARS(IMOD)%SRCPS%SSDSP + WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP + FFXFM => MPARS(IMOD)%SRCPS%FFXFM + FFXFA => MPARS(IMOD)%SRCPS%FFXFA + FFXPM => MPARS(IMOD)%SRCPS%FFXPM + SSDSDTH => MPARS(IMOD)%SRCPS%SSDSDTH + SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF + SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN + SSDSCOS => MPARS(IMOD)%SRCPS%SSDSCOS + SSDSISO => MPARS(IMOD)%SRCPS%SSDSISO + IKTAB => MPARS(IMOD)%SRCPS%IKTAB + DCKI => MPARS(IMOD)%SRCPS%DCKI + QBI => MPARS(IMOD)%SRCPS%QBI + CUMULW => MPARS(IMOD)%SRCPS%CUMULW + SATINDICES => MPARS(IMOD)%SRCPS%SATINDICES + SATWEIGHTS => MPARS(IMOD)%SRCPS%SATWEIGHTS + SSINBR => MPARS(IMOD)%SRCPS%SSINBR +#endif + ! #ifdef W3_ST6 - SIN6A0 => MPARS(IMOD)%SRCPS%SIN6A0 - SIN6WS => MPARS(IMOD)%SRCPS%SIN6WS - SIN6FC => MPARS(IMOD)%SRCPS%SIN6FC - SDS6ET => MPARS(IMOD)%SRCPS%SDS6ET - SDS6A1 => MPARS(IMOD)%SRCPS%SDS6A1 - SDS6P1 => MPARS(IMOD)%SRCPS%SDS6P1 - SDS6A2 => MPARS(IMOD)%SRCPS%SDS6A2 - SDS6P2 => MPARS(IMOD)%SRCPS%SDS6P2 - SWL6S6 => MPARS(IMOD)%SRCPS%SWL6S6 - SWL6B1 => MPARS(IMOD)%SRCPS%SWL6B1 - SWL6CSTB1 => MPARS(IMOD)%SRCPS%SWL6CSTB1 -#endif -! -! Structure SRNLS -! + SIN6A0 => MPARS(IMOD)%SRCPS%SIN6A0 + SIN6WS => MPARS(IMOD)%SRCPS%SIN6WS + SIN6FC => MPARS(IMOD)%SRCPS%SIN6FC + SDS6ET => MPARS(IMOD)%SRCPS%SDS6ET + SDS6A1 => MPARS(IMOD)%SRCPS%SDS6A1 + SDS6P1 => MPARS(IMOD)%SRCPS%SDS6P1 + SDS6A2 => MPARS(IMOD)%SRCPS%SDS6A2 + SDS6P2 => MPARS(IMOD)%SRCPS%SDS6P2 + SWL6S6 => MPARS(IMOD)%SRCPS%SWL6S6 + SWL6B1 => MPARS(IMOD)%SRCPS%SWL6B1 + SWL6CSTB1 => MPARS(IMOD)%SRCPS%SWL6CSTB1 +#endif + ! + ! Structure SRNLS + ! #ifdef W3_NL1 - SNLC1 => MPARS(IMOD)%SNLPS%SNLC1 - LAM => MPARS(IMOD)%SNLPS%LAM - KDCON => MPARS(IMOD)%SNLPS%KDCON - KDMN => MPARS(IMOD)%SNLPS%KDMN - SNLS1 => MPARS(IMOD)%SNLPS%SNLS1 - SNLS2 => MPARS(IMOD)%SNLPS%SNLS2 - SNLS3 => MPARS(IMOD)%SNLPS%SNLS3 + SNLC1 => MPARS(IMOD)%SNLPS%SNLC1 + LAM => MPARS(IMOD)%SNLPS%LAM + KDCON => MPARS(IMOD)%SNLPS%KDCON + KDMN => MPARS(IMOD)%SNLPS%KDMN + SNLS1 => MPARS(IMOD)%SNLPS%SNLS1 + SNLS2 => MPARS(IMOD)%SNLPS%SNLS2 + SNLS3 => MPARS(IMOD)%SNLPS%SNLS3 #endif #ifdef W3_NL2 - IQTPE => MPARS(IMOD)%SNLPS%IQTPE - NDPTHS => MPARS(IMOD)%SNLPS%NDPTHS - NLTAIL => MPARS(IMOD)%SNLPS%NLTAIL - IF ( NDPTHS .NE. 0 ) DPTHNL => MPARS(IMOD)%SNLPS%DPTHNL + IQTPE => MPARS(IMOD)%SNLPS%IQTPE + NDPTHS => MPARS(IMOD)%SNLPS%NDPTHS + NLTAIL => MPARS(IMOD)%SNLPS%NLTAIL + IF ( NDPTHS .NE. 0 ) DPTHNL => MPARS(IMOD)%SNLPS%DPTHNL #endif #ifdef W3_NL3 - NFRMIN => MPARS(IMOD)%SNLPS%NFRMIN - NFRMAX => MPARS(IMOD)%SNLPS%NFRMAX - NFRCUT => MPARS(IMOD)%SNLPS%NFRCUT - NTHMAX => MPARS(IMOD)%SNLPS%NTHMAX - NTHEXP => MPARS(IMOD)%SNLPS%NTHEXP - NSPMIN => MPARS(IMOD)%SNLPS%NSPMIN - NSPMAX => MPARS(IMOD)%SNLPS%NSPMAX - NSPMX2 => MPARS(IMOD)%SNLPS%NSPMX2 - FRQ => MPARS(IMOD)%SNLPS%FRQ - XSI => MPARS(IMOD)%SNLPS%XSI - NQA => MPARS(IMOD)%SNLPS%NQA - QST1 => MPARS(IMOD)%SNLPS%QST1 - QST2 => MPARS(IMOD)%SNLPS%QST2 - QST3 => MPARS(IMOD)%SNLPS%QST3 - QST4 => MPARS(IMOD)%SNLPS%QST4 - QST5 => MPARS(IMOD)%SNLPS%QST5 - QST6 => MPARS(IMOD)%SNLPS%QST6 - SNLNQ => MPARS(IMOD)%SNLPS%SNLNQ - SNLMSC => MPARS(IMOD)%SNLPS%SNLMSC - SNLNSC => MPARS(IMOD)%SNLPS%SNLNSC - SNLSFD => MPARS(IMOD)%SNLPS%SNLSFD - SNLSFS => MPARS(IMOD)%SNLPS%SNLSFS - SNLL => MPARS(IMOD)%SNLPS%SNLL - SNLM => MPARS(IMOD)%SNLPS%SNLM - SNLT => MPARS(IMOD)%SNLPS%SNLT - SNLCD => MPARS(IMOD)%SNLPS%SNLCD - SNLCS => MPARS(IMOD)%SNLPS%SNLCS + NFRMIN => MPARS(IMOD)%SNLPS%NFRMIN + NFRMAX => MPARS(IMOD)%SNLPS%NFRMAX + NFRCUT => MPARS(IMOD)%SNLPS%NFRCUT + NTHMAX => MPARS(IMOD)%SNLPS%NTHMAX + NTHEXP => MPARS(IMOD)%SNLPS%NTHEXP + NSPMIN => MPARS(IMOD)%SNLPS%NSPMIN + NSPMAX => MPARS(IMOD)%SNLPS%NSPMAX + NSPMX2 => MPARS(IMOD)%SNLPS%NSPMX2 + FRQ => MPARS(IMOD)%SNLPS%FRQ + XSI => MPARS(IMOD)%SNLPS%XSI + NQA => MPARS(IMOD)%SNLPS%NQA + QST1 => MPARS(IMOD)%SNLPS%QST1 + QST2 => MPARS(IMOD)%SNLPS%QST2 + QST3 => MPARS(IMOD)%SNLPS%QST3 + QST4 => MPARS(IMOD)%SNLPS%QST4 + QST5 => MPARS(IMOD)%SNLPS%QST5 + QST6 => MPARS(IMOD)%SNLPS%QST6 + SNLNQ => MPARS(IMOD)%SNLPS%SNLNQ + SNLMSC => MPARS(IMOD)%SNLPS%SNLMSC + SNLNSC => MPARS(IMOD)%SNLPS%SNLNSC + SNLSFD => MPARS(IMOD)%SNLPS%SNLSFD + SNLSFS => MPARS(IMOD)%SNLPS%SNLSFS + SNLL => MPARS(IMOD)%SNLPS%SNLL + SNLM => MPARS(IMOD)%SNLPS%SNLM + SNLT => MPARS(IMOD)%SNLPS%SNLT + SNLCD => MPARS(IMOD)%SNLPS%SNLCD + SNLCS => MPARS(IMOD)%SNLPS%SNLCS #endif #ifdef W3_NL4 - ITSA => MPARS(IMOD)%SNLPS%ITSA - IALT => MPARS(IMOD)%SNLPS%IALT + ITSA => MPARS(IMOD)%SNLPS%ITSA + IALT => MPARS(IMOD)%SNLPS%IALT #endif #ifdef W3_NL5 - QR5DPT => MPARS(IMOD)%SNLPS%QR5DPT - QR5OML => MPARS(IMOD)%SNLPS%QR5OML - QI5DIS => MPARS(IMOD)%SNLPS%QI5DIS - QI5KEV => MPARS(IMOD)%SNLPS%QI5KEV - QI5NNZ => MPARS(IMOD)%SNLPS%QI5NNZ - QI5IPL => MPARS(IMOD)%SNLPS%QI5IPL - QI5PMX => MPARS(IMOD)%SNLPS%QI5PMX + QR5DPT => MPARS(IMOD)%SNLPS%QR5DPT + QR5OML => MPARS(IMOD)%SNLPS%QR5OML + QI5DIS => MPARS(IMOD)%SNLPS%QI5DIS + QI5KEV => MPARS(IMOD)%SNLPS%QI5KEV + QI5NNZ => MPARS(IMOD)%SNLPS%QI5NNZ + QI5IPL => MPARS(IMOD)%SNLPS%QI5IPL + QI5PMX => MPARS(IMOD)%SNLPS%QI5PMX #endif #ifdef W3_NLS - NTHX => MPARS(IMOD)%SNLPS%NTHX - NFRX => MPARS(IMOD)%SNLPS%NFRX - NSPL => MPARS(IMOD)%SNLPS%NSPL - NSPH => MPARS(IMOD)%SNLPS%NSPH - SNSST => MPARS(IMOD)%SNLPS%SNSST - CNLSA => MPARS(IMOD)%SNLPS%CNLSA - CNLSC => MPARS(IMOD)%SNLPS%CNLSC - CNLSFM => MPARS(IMOD)%SNLPS%CNLSFM - CNLSC1 => MPARS(IMOD)%SNLPS%CNLSC1 - CNLSC2 => MPARS(IMOD)%SNLPS%CNLSC2 - CNLSC3 => MPARS(IMOD)%SNLPS%CNLSC3 -#endif -! -! Structure SBTPS -! + NTHX => MPARS(IMOD)%SNLPS%NTHX + NFRX => MPARS(IMOD)%SNLPS%NFRX + NSPL => MPARS(IMOD)%SNLPS%NSPL + NSPH => MPARS(IMOD)%SNLPS%NSPH + SNSST => MPARS(IMOD)%SNLPS%SNSST + CNLSA => MPARS(IMOD)%SNLPS%CNLSA + CNLSC => MPARS(IMOD)%SNLPS%CNLSC + CNLSFM => MPARS(IMOD)%SNLPS%CNLSFM + CNLSC1 => MPARS(IMOD)%SNLPS%CNLSC1 + CNLSC2 => MPARS(IMOD)%SNLPS%CNLSC2 + CNLSC3 => MPARS(IMOD)%SNLPS%CNLSC3 +#endif + ! + ! Structure SBTPS + ! #ifdef W3_BT1 - SBTC1 => MPARS(IMOD)%SBTPS%SBTC1 + SBTC1 => MPARS(IMOD)%SBTPS%SBTC1 #endif #ifdef W3_BT4 - SBTCX => MPARS(IMOD)%SBTPS%SBTCX + SBTCX => MPARS(IMOD)%SBTPS%SBTCX #endif -! -! Structure SDBPS -! + ! + ! Structure SDBPS + ! #ifdef W3_DB1 - SDBC1 => MPARS(IMOD)%SDBPS%SDBC1 - SDBC2 => MPARS(IMOD)%SDBPS%SDBC2 - FDONLY => MPARS(IMOD)%SDBPS%FDONLY - SDBSC => MPARS(IMOD)%SDBPS%SDBSC + SDBC1 => MPARS(IMOD)%SDBPS%SDBC1 + SDBC2 => MPARS(IMOD)%SDBPS%SDBC2 + FDONLY => MPARS(IMOD)%SDBPS%FDONLY + SDBSC => MPARS(IMOD)%SDBPS%SDBSC #endif -! -! + ! + ! #ifdef W3_UOST - UOSTFILELOCAL => MPARS(IMOD)%UOSTPS%UOSTFILELOCAL - UOSTFILESHADOW => MPARS(IMOD)%UOSTPS%UOSTFILESHADOW - UOSTFACTORLOCAL => MPARS(IMOD)%UOSTPS%UOSTFACTORLOCAL - UOSTFACTORSHADOW => MPARS(IMOD)%UOSTPS%UOSTFACTORSHADOW -#endif -! -! Structure SICPS -! + UOSTFILELOCAL => MPARS(IMOD)%UOSTPS%UOSTFILELOCAL + UOSTFILESHADOW => MPARS(IMOD)%UOSTPS%UOSTFILESHADOW + UOSTFACTORLOCAL => MPARS(IMOD)%UOSTPS%UOSTFACTORLOCAL + UOSTFACTORSHADOW => MPARS(IMOD)%UOSTPS%UOSTFACTORSHADOW +#endif + ! + ! Structure SICPS + ! #ifdef W3_IS1 - IS1C1 => MPARS(IMOD)%SICPS%IS1C1 - IS1C2 => MPARS(IMOD)%SICPS%IS1C2 -#endif -! -! Structure SCHM - FSBCCFL => MPARS(IMOD)%SCHMS%FSBCCFL - FSN => MPARS(IMOD)%SCHMS%FSN - FSPSI => MPARS(IMOD)%SCHMS%FSPSI - FSFCT => MPARS(IMOD)%SCHMS%FSFCT - FSNIMP => MPARS(IMOD)%SCHMS%FSNIMP - FSTOTALIMP => MPARS(IMOD)%SCHMS%FSTOTALIMP - FSTOTALEXP => MPARS(IMOD)%SCHMS%FSTOTALEXP - FSREFRACTION => MPARS(IMOD)%SCHMS%FSREFRACTION - FSFREQSHIFT => MPARS(IMOD)%SCHMS%FSFREQSHIFT - FSSOURCE => MPARS(IMOD)%SCHMS%FSSOURCE - DO_CHANGE_WLV => MPARS(IMOD)%SCHMS%DO_CHANGE_WLV - SOLVERTHR_STP => MPARS(IMOD)%SCHMS%SOLVERTHR_STP - CRIT_DEP_STP => MPARS(IMOD)%SCHMS%CRIT_DEP_STP - B_JGS_TERMINATE_MAXITER => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_MAXITER - B_JGS_TERMINATE_DIFFERENCE => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_DIFFERENCE - B_JGS_TERMINATE_NORM => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_NORM - B_JGS_LIMITER => MPARS(IMOD)%SCHMS%B_JGS_LIMITER - B_JGS_USE_JACOBI => MPARS(IMOD)%SCHMS%B_JGS_USE_JACOBI - B_JGS_BLOCK_GAUSS_SEIDEL => MPARS(IMOD)%SCHMS%B_JGS_BLOCK_GAUSS_SEIDEL - B_JGS_MAXITER => MPARS(IMOD)%SCHMS%B_JGS_MAXITER - B_JGS_PMIN => MPARS(IMOD)%SCHMS%B_JGS_PMIN - B_JGS_DIFF_THR => MPARS(IMOD)%SCHMS%B_JGS_DIFF_THR - B_JGS_NORM_THR => MPARS(IMOD)%SCHMS%B_JGS_NORM_THR - B_JGS_NLEVEL => MPARS(IMOD)%SCHMS%B_JGS_NLEVEL - B_JGS_SOURCE_NONLINEAR => MPARS(IMOD)%SCHMS%B_JGS_SOURCE_NONLINEAR - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3SETG : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3SETG : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NAUXGR = ',I10/ & - ' NGRIDS = ',I10/) + IS1C1 => MPARS(IMOD)%SICPS%IS1C1 + IS1C2 => MPARS(IMOD)%SICPS%IS1C2 +#endif + ! + ! Structure SCHM + FSBCCFL => MPARS(IMOD)%SCHMS%FSBCCFL + FSN => MPARS(IMOD)%SCHMS%FSN + FSPSI => MPARS(IMOD)%SCHMS%FSPSI + FSFCT => MPARS(IMOD)%SCHMS%FSFCT + FSNIMP => MPARS(IMOD)%SCHMS%FSNIMP + FSTOTALIMP => MPARS(IMOD)%SCHMS%FSTOTALIMP + FSTOTALEXP => MPARS(IMOD)%SCHMS%FSTOTALEXP + FSREFRACTION => MPARS(IMOD)%SCHMS%FSREFRACTION + FSFREQSHIFT => MPARS(IMOD)%SCHMS%FSFREQSHIFT + FSSOURCE => MPARS(IMOD)%SCHMS%FSSOURCE + DO_CHANGE_WLV => MPARS(IMOD)%SCHMS%DO_CHANGE_WLV + SOLVERTHR_STP => MPARS(IMOD)%SCHMS%SOLVERTHR_STP + CRIT_DEP_STP => MPARS(IMOD)%SCHMS%CRIT_DEP_STP + B_JGS_TERMINATE_MAXITER => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_MAXITER + B_JGS_TERMINATE_DIFFERENCE => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_DIFFERENCE + B_JGS_TERMINATE_NORM => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_NORM + B_JGS_LIMITER => MPARS(IMOD)%SCHMS%B_JGS_LIMITER + B_JGS_USE_JACOBI => MPARS(IMOD)%SCHMS%B_JGS_USE_JACOBI + B_JGS_BLOCK_GAUSS_SEIDEL => MPARS(IMOD)%SCHMS%B_JGS_BLOCK_GAUSS_SEIDEL + B_JGS_MAXITER => MPARS(IMOD)%SCHMS%B_JGS_MAXITER + B_JGS_PMIN => MPARS(IMOD)%SCHMS%B_JGS_PMIN + B_JGS_DIFF_THR => MPARS(IMOD)%SCHMS%B_JGS_DIFF_THR + B_JGS_NORM_THR => MPARS(IMOD)%SCHMS%B_JGS_NORM_THR + B_JGS_NLEVEL => MPARS(IMOD)%SCHMS%B_JGS_NLEVEL + B_JGS_SOURCE_NONLINEAR => MPARS(IMOD)%SCHMS%B_JGS_SOURCE_NONLINEAR + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3SETG : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3SETG : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NAUXGR = ',I10/ & + ' NGRIDS = ',I10/) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3SETG) - 9000 FORMAT (' TEST W3SETG : GRID/MODEL ',I4,' SELECTED') -#endif -!/ -!/ End of W3SETG ----------------------------------------------------- / -!/ - END SUBROUTINE W3SETG -!/ ------------------------------------------------------------------- / - SUBROUTINE W3GNTX ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | T. J. Campbell | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jul-2011 | -!/ +-----------------------------------+ -!/ -!/ 30-Oct-2009 : Origination. ( version 3.13 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) -!/ factor with DXDP and DXDQ terms. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 20-Jul-2011 : HPFAC and HQFAC are now calculated using W3DIST. -!/ Result should be very similar except near pole. -!/ Due to precision issues, HPFAC and HQFAC revert -!/ to SX and SY in case of regular grids. -!/ (W. E. Rogers, NRL) ( version 3.14 ) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ 20-Jan-2017 : Change calculation of curvilinear grid metric and -!/ derivatives calculations to use W3GSRUMD:W3CGDM. -!/ (T.J. Campbell, NRL) ( version 6.02 ) -!/ -! 1. Purpose : -! -! Construct required spatial grid quantities for curvilinear grids. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program that uses this grid structure. -! -! 6. Error messages : -! -! - Check on previous initialization of grids. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, PARAMETER :: NFD = 4 - LOGICAL, PARAMETER :: PTILED = .FALSE. - LOGICAL, PARAMETER :: QTILED = .FALSE. - LOGICAL, PARAMETER :: IJG = .FALSE. - LOGICAL, PARAMETER :: SPHERE = .FALSE. - INTEGER :: PRANGE(2), QRANGE(2) - INTEGER :: LBI(2), UBI(2), LBO(2), UBO(2), ISTAT - REAL , ALLOCATABLE :: COSA(:,:) +9000 FORMAT (' TEST W3SETG : GRID/MODEL ',I4,' SELECTED') +#endif + !/ + !/ End of W3SETG ----------------------------------------------------- / + !/ + END SUBROUTINE W3SETG + !/ ------------------------------------------------------------------- / + SUBROUTINE W3GNTX ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | T. J. Campbell | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jul-2011 | + !/ +-----------------------------------+ + !/ + !/ 30-Oct-2009 : Origination. ( version 3.13 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) + !/ factor with DXDP and DXDQ terms. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 20-Jul-2011 : HPFAC and HQFAC are now calculated using W3DIST. + !/ Result should be very similar except near pole. + !/ Due to precision issues, HPFAC and HQFAC revert + !/ to SX and SY in case of regular grids. + !/ (W. E. Rogers, NRL) ( version 3.14 ) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ 20-Jan-2017 : Change calculation of curvilinear grid metric and + !/ derivatives calculations to use W3GSRUMD:W3CGDM. + !/ (T.J. Campbell, NRL) ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Construct required spatial grid quantities for curvilinear grids. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program that uses this grid structure. + ! + ! 6. Error messages : + ! + ! - Check on previous initialization of grids. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, PARAMETER :: NFD = 4 + LOGICAL, PARAMETER :: PTILED = .FALSE. + LOGICAL, PARAMETER :: QTILED = .FALSE. + LOGICAL, PARAMETER :: IJG = .FALSE. + LOGICAL, PARAMETER :: SPHERE = .FALSE. + INTEGER :: PRANGE(2), QRANGE(2) + INTEGER :: LBI(2), UBI(2), LBO(2), UBO(2), ISTAT + REAL , ALLOCATABLE :: COSA(:,:) #ifdef W3_S - CALL STRACE (IENT, 'W3GNTX') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN - WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS - CALL EXTCDE (2) - END IF -! - SELECT CASE ( GRIDS(IMOD)%GTYPE ) - CASE ( RLGTYPE ) - CASE ( CLGTYPE ) - CASE ( SMCTYPE ) - CASE DEFAULT - WRITE (NDSE,1003) GRIDS(IMOD)%GTYPE - CALL EXTCDE (3) - END SELECT + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GNTX') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN + WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS + CALL EXTCDE (2) + END IF + ! + SELECT CASE ( GRIDS(IMOD)%GTYPE ) + CASE ( RLGTYPE ) + CASE ( CLGTYPE ) + CASE ( SMCTYPE ) + CASE DEFAULT + WRITE (NDSE,1003) GRIDS(IMOD)%GTYPE + CALL EXTCDE (3) + END SELECT #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - WRITE (NDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Create grid search utility object -! - GRIDS(IMOD)%GSU = W3GSUC( IJG, FLAGLL, GRIDS(IMOD)%ICLOSE, & - GRIDS(IMOD)%XGRD, GRIDS(IMOD)%YGRD ) + WRITE (NDST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Create grid search utility object + ! + GRIDS(IMOD)%GSU = W3GSUC( IJG, FLAGLL, GRIDS(IMOD)%ICLOSE, & + GRIDS(IMOD)%XGRD, GRIDS(IMOD)%YGRD ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - CALL W3GSUP(GRIDS(IMOD)%GSU, NDST) - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! 3. Reset grid pointers -! - CALL W3SETG ( IMOD, NDSE, NDST ) + CALL W3GSUP(GRIDS(IMOD)%GSU, NDST) + WRITE (NDST,9001) +#endif + ! + ! -------------------------------------------------------------------- / + ! 3. Reset grid pointers + ! + CALL W3SETG ( IMOD, NDSE, NDST ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - WRITE (NDST,9002) -#endif -! -! -------------------------------------------------------------------- / -! 4. Construct curvilinear grid derivatives and metric -! Note that in the case of lon/lat grids, these quantities do not -! include the spherical coordinate metric (SPHERE=.FALSE.). -! + WRITE (NDST,9002) +#endif + ! + ! -------------------------------------------------------------------- / + ! 4. Construct curvilinear grid derivatives and metric + ! Note that in the case of lon/lat grids, these quantities do not + ! include the spherical coordinate metric (SPHERE=.FALSE.). + ! #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - ALLOCATE ( COSA(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif - PRANGE = (/ 1,NX/) - QRANGE = (/ 1,NY/) - LBI = (/ 1, 1/) - UBI = (/NY,NX/) - LBO = (/ 1, 1/) - UBO = (/NY,NX/) - SELECT CASE ( GTYPE ) -!!Li SMC grid shares the settings with rectilinear grid. JGLi12Oct2020 - CASE ( RLGTYPE, SMCTYPE ) - CALL W3CGDM( IJG, FLAGLL, ICLOSE, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, REAL(XGRD), REAL(YGRD), & - NFD=NFD, SPHERE=SPHERE, DX=SX, DY=SY, & - DXDP=DXDP, DYDP=DYDP, DXDQ=DXDQ, DYDQ=DYDQ, & - DPDX=DPDX, DPDY=DPDY, DQDX=DQDX, DQDY=DQDY, & - HPFC=HPFAC, HQFC=HQFAC, GSQR=GSQRT, & + ALLOCATE ( COSA(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + PRANGE = (/ 1,NX/) + QRANGE = (/ 1,NY/) + LBI = (/ 1, 1/) + UBI = (/NY,NX/) + LBO = (/ 1, 1/) + UBO = (/NY,NX/) + SELECT CASE ( GTYPE ) + !!Li SMC grid shares the settings with rectilinear grid. JGLi12Oct2020 + CASE ( RLGTYPE, SMCTYPE ) + CALL W3CGDM( IJG, FLAGLL, ICLOSE, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, REAL(XGRD), REAL(YGRD), & + NFD=NFD, SPHERE=SPHERE, DX=SX, DY=SY, & + DXDP=DXDP, DYDP=DYDP, DXDQ=DXDQ, DYDQ=DYDQ, & + DPDX=DPDX, DPDY=DPDY, DQDX=DQDX, DQDY=DQDY, & + HPFC=HPFAC, HQFC=HQFAC, GSQR=GSQRT, & #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - COSA=COSA, & + COSA=COSA, & #endif - RC=ISTAT ) - IF ( ISTAT.NE.0 ) THEN - WRITE (NDSE,1004) GTYPE - CALL EXTCDE (4) - END IF - CASE ( CLGTYPE ) - CALL W3CGDM( IJG, FLAGLL, ICLOSE, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, REAL(XGRD), REAL(YGRD), & - NFD=NFD, SPHERE=SPHERE, & - DXDP=DXDP, DYDP=DYDP, DXDQ=DXDQ, DYDQ=DYDQ, & - DPDX=DPDX, DPDY=DPDY, DQDX=DQDX, DQDY=DQDY, & - HPFC=HPFAC, HQFC=HQFAC, GSQR=GSQRT, & + RC=ISTAT ) + IF ( ISTAT.NE.0 ) THEN + WRITE (NDSE,1004) GTYPE + CALL EXTCDE (4) + END IF + CASE ( CLGTYPE ) + CALL W3CGDM( IJG, FLAGLL, ICLOSE, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, REAL(XGRD), REAL(YGRD), & + NFD=NFD, SPHERE=SPHERE, & + DXDP=DXDP, DYDP=DYDP, DXDQ=DXDQ, DYDQ=DYDQ, & + DPDX=DPDX, DPDY=DPDY, DQDX=DQDX, DQDY=DQDY, & + HPFC=HPFAC, HQFC=HQFAC, GSQR=GSQRT, & #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - COSA=COSA, & + COSA=COSA, & #endif - RC=ISTAT ) - IF ( ISTAT.NE.0 ) THEN - WRITE (NDSE,1004) GTYPE - CALL EXTCDE (4) - END IF - END SELECT -! + RC=ISTAT ) + IF ( ISTAT.NE.0 ) THEN + WRITE (NDSE,1004) GTYPE + CALL EXTCDE (4) + END IF + END SELECT + ! #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - WRITE(NDST,'(A,2E14.6)')'HPFAC MIN/MAX:',MINVAL(HPFAC),MAXVAL(HPFAC) - WRITE(NDST,'(A,2E14.6)')'HQFAC MIN/MAX:',MINVAL(HQFAC),MAXVAL(HQFAC) - WRITE(NDST,'(A,2E14.6)')'GSQRT MIN/MAX:',MINVAL(GSQRT),MAXVAL(GSQRT) - WRITE(NDST,'(A,2E14.6)')'DXDP MIN/MAX:',MINVAL(DXDP),MAXVAL(DXDP) - WRITE(NDST,'(A,2E14.6)')'DYDP MIN/MAX:',MINVAL(DYDP),MAXVAL(DYDP) - WRITE(NDST,'(A,2E14.6)')'DXDQ MIN/MAX:',MINVAL(DXDQ),MAXVAL(DXDQ) - WRITE(NDST,'(A,2E14.6)')'DYDQ MIN/MAX:',MINVAL(DYDQ),MAXVAL(DYDQ) - WRITE(NDST,'(A,2E14.6)')'DPDX MIN/MAX:',MINVAL(DPDX),MAXVAL(DPDX) - WRITE(NDST,'(A,2E14.6)')'DPDY MIN/MAX:',MINVAL(DPDY),MAXVAL(DPDY) - WRITE(NDST,'(A,2E14.6)')'DQDX MIN/MAX:',MINVAL(DQDX),MAXVAL(DQDX) - WRITE(NDST,'(A,2E14.6)')'DQDY MIN/MAX:',MINVAL(DQDY),MAXVAL(DQDY) - WRITE(NDST,'(A,2E14.6)')'COSA MIN/MAX:',MINVAL(COSA),MAXVAL(COSA) - WRITE (NDST,9003) - DEALLOCATE ( COSA, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) -#endif -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3GNTX : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3GNTX : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NAUXGR = ',I10/ & - ' NGRIDS = ',I10/) - 1003 FORMAT (/' *** ERROR W3GNTX : UNSUPPORTED TYPE OF GRID *** '/ & - ' GTYPE = ',I10/) - 1004 FORMAT (/' *** ERROR W3GNTX : ERROR OCCURED IN W3CGDM *** '/ & - ' GTYPE = ',I10/) -! + WRITE(NDST,'(A,2E14.6)')'HPFAC MIN/MAX:',MINVAL(HPFAC),MAXVAL(HPFAC) + WRITE(NDST,'(A,2E14.6)')'HQFAC MIN/MAX:',MINVAL(HQFAC),MAXVAL(HQFAC) + WRITE(NDST,'(A,2E14.6)')'GSQRT MIN/MAX:',MINVAL(GSQRT),MAXVAL(GSQRT) + WRITE(NDST,'(A,2E14.6)')'DXDP MIN/MAX:',MINVAL(DXDP),MAXVAL(DXDP) + WRITE(NDST,'(A,2E14.6)')'DYDP MIN/MAX:',MINVAL(DYDP),MAXVAL(DYDP) + WRITE(NDST,'(A,2E14.6)')'DXDQ MIN/MAX:',MINVAL(DXDQ),MAXVAL(DXDQ) + WRITE(NDST,'(A,2E14.6)')'DYDQ MIN/MAX:',MINVAL(DYDQ),MAXVAL(DYDQ) + WRITE(NDST,'(A,2E14.6)')'DPDX MIN/MAX:',MINVAL(DPDX),MAXVAL(DPDX) + WRITE(NDST,'(A,2E14.6)')'DPDY MIN/MAX:',MINVAL(DPDY),MAXVAL(DPDY) + WRITE(NDST,'(A,2E14.6)')'DQDX MIN/MAX:',MINVAL(DQDX),MAXVAL(DQDX) + WRITE(NDST,'(A,2E14.6)')'DQDY MIN/MAX:',MINVAL(DQDY),MAXVAL(DQDY) + WRITE(NDST,'(A,2E14.6)')'COSA MIN/MAX:',MINVAL(COSA),MAXVAL(COSA) + WRITE (NDST,9003) + DEALLOCATE ( COSA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) +#endif + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3GNTX : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3GNTX : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NAUXGR = ',I10/ & + ' NGRIDS = ',I10/) +1003 FORMAT (/' *** ERROR W3GNTX : UNSUPPORTED TYPE OF GRID *** '/ & + ' GTYPE = ',I10/) +1004 FORMAT (/' *** ERROR W3GNTX : ERROR OCCURED IN W3CGDM *** '/ & + ' GTYPE = ',I10/) + ! #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - 9000 FORMAT (' TEST W3GNTX : MODEL ',I4) - 9001 FORMAT (' TEST W3GNTX : SEARCH OBJECT CREATED') - 9002 FORMAT (' TEST W3GNTX : POINTERS RESET') - 9003 FORMAT (' TEST W3GNTX : GRID ARRAYS CONSTRUCTED') -#endif -!/ -!/ End of W3GNTX ----------------------------------------------------- / -!/ - END SUBROUTINE W3GNTX -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DIMUG ( IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | F.ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-Mar-2007 ! -!/ +-----------------------------------+ -!/ -!/ 15-Mar-2007 : Origination. ( version 3.14 ) -!/ 11-May-2015 : Updates to 2-ways nestings for UG ( version 5.08 ) -!/ -! 1. Purpose : -! -! Initialize an individual spatial grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array GRIDS. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! MX, MTRI, MSEA Like NX, NTRI, NSEA in data structure. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Model definition file IO program. -! WW3_GRID Prog. N/A Model set up program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - Grid dimensions apre passed through parameter list and then -! locally stored to assure consistency between allocation and -! data in structure. -! - W3SETG needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT (' TEST W3GNTX : MODEL ',I4) +9001 FORMAT (' TEST W3GNTX : SEARCH OBJECT CREATED') +9002 FORMAT (' TEST W3GNTX : POINTERS RESET') +9003 FORMAT (' TEST W3GNTX : GRID ARRAYS CONSTRUCTED') +#endif + !/ + !/ End of W3GNTX ----------------------------------------------------- / + !/ + END SUBROUTINE W3GNTX + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DIMUG ( IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | F.ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-Mar-2007 ! + !/ +-----------------------------------+ + !/ + !/ 15-Mar-2007 : Origination. ( version 3.14 ) + !/ 11-May-2015 : Updates to 2-ways nestings for UG ( version 5.08 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual spatial grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array GRIDS. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! MX, MTRI, MSEA Like NX, NTRI, NSEA in data structure. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Model definition file IO program. + ! WW3_GRID Prog. N/A Model set up program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - Grid dimensions apre passed through parameter list and then + ! locally stored to assure consistency between allocation and + ! data in structure. + ! - W3SETG needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_MEMCHECK - USE MallocInfo_m + USE MallocInfo_m #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST #ifdef W3_MEMCHECK - type(MallInfo_t) :: mallinfos -#endif - INTEGER :: IAPROC = 1 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + type(MallInfo_t) :: mallinfos #endif -!/ + INTEGER :: IAPROC = 1 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3DIMUG') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN - WRITE (NDSE,1002) IMOD, NGRIDS - CALL EXTCDE (2) - END IF - IF ( GRIDS(IMOD)%GUGINIT ) THEN - WRITE (NDSE,1004) - CALL EXTCDE (4) - END IF -! + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIMUG') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN + WRITE (NDSE,1002) IMOD, NGRIDS + CALL EXTCDE (2) + END IF + IF ( GRIDS(IMOD)%GUGINIT ) THEN + WRITE (NDSE,1004) + CALL EXTCDE (4) + END IF + ! #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) - WRITE (NDST,9000) IMOD, MX, MTRI -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! - ALLOCATE ( GRIDS(IMOD)%TRIGP(3,MTRI), & - GRIDS(IMOD)%SI(MX), & - GRIDS(IMOD)%XGRD(1,MX), & - GRIDS(IMOD)%YGRD(1,MX), & - GRIDS(IMOD)%ZB(MX), & - GRIDS(IMOD)%TRIA(MTRI), & - GRIDS(IMOD)%CROSSDIFF(6,MTRI), & - GRIDS(IMOD)%IEN(MTRI,6), & - GRIDS(IMOD)%LEN(MTRI,3), & - GRIDS(IMOD)%ANGLE(MTRI,3), & - GRIDS(IMOD)%ANGLE0(MTRI,3), & - GRIDS(IMOD)%CCON(MX), & - GRIDS(IMOD)%COUNTCON(MX), & - GRIDS(IMOD)%INDEX_CELL(MX+1), & - GRIDS(IMOD)%IE_CELL(COUNTOTA), & - GRIDS(IMOD)%POS_CELL(COUNTOTA), & - GRIDS(IMOD)%IAA(NX+1), & - GRIDS(IMOD)%JAA(NNZ), & - GRIDS(IMOD)%POSI(3,COUNTOTA), & - GRIDS(IMOD)%I_DIAG(NX), & - GRIDS(IMOD)%JA_IE(3,3,MTRI), & - GRIDS(IMOD)%IOBP(MX), & - GRIDS(IMOD)%IOBPD(NTH,MX), & - GRIDS(IMOD)%IOBDP(MX), & - GRIDS(IMOD)%IOBPA(MX), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - GRIDS(IMOD)%IOBP(:)=1 + WRITE (NDST,9000) IMOD, MX, MTRI +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + ALLOCATE ( GRIDS(IMOD)%TRIGP(3,MTRI), & + GRIDS(IMOD)%SI(MX), & + GRIDS(IMOD)%XGRD(1,MX), & + GRIDS(IMOD)%YGRD(1,MX), & + GRIDS(IMOD)%ZB(MX), & + GRIDS(IMOD)%TRIA(MTRI), & + GRIDS(IMOD)%CROSSDIFF(6,MTRI), & + GRIDS(IMOD)%IEN(MTRI,6), & + GRIDS(IMOD)%LEN(MTRI,3), & + GRIDS(IMOD)%ANGLE(MTRI,3), & + GRIDS(IMOD)%ANGLE0(MTRI,3), & + GRIDS(IMOD)%CCON(MX), & + GRIDS(IMOD)%COUNTCON(MX), & + GRIDS(IMOD)%INDEX_CELL(MX+1), & + GRIDS(IMOD)%IE_CELL(COUNTOTA), & + GRIDS(IMOD)%POS_CELL(COUNTOTA), & + GRIDS(IMOD)%IAA(NX+1), & + GRIDS(IMOD)%JAA(NNZ), & + GRIDS(IMOD)%POSI(3,COUNTOTA), & + GRIDS(IMOD)%I_DIAG(NX), & + GRIDS(IMOD)%JA_IE(3,3,MTRI), & + GRIDS(IMOD)%IOBP(MX), & + GRIDS(IMOD)%IOBPD(NTH,MX), & + GRIDS(IMOD)%IOBDP(MX), & + GRIDS(IMOD)%IOBPA(MX), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + GRIDS(IMOD)%IOBP(:)=1 #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) - WRITE (NDST,9001) -#endif -! -!some segmentation troubles can appear, they are related with the allocation of -!normal(1st dimension) and the nesting of the triangulated grid. -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETG ( IMOD, NDSE, NDST ) + WRITE (NDST,9001) +#endif + ! + !some segmentation troubles can appear, they are related with the allocation of + !normal(1st dimension) and the nesting of the triangulated grid. + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETG ( IMOD, NDSE, NDST ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) - WRITE (NDST,9002) -#endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! Note that in the case of lon/lat grids, these quantities do not -! include the spherical coordinate metric (SPHERE=.FALSE.). -! - NTRI = MTRI - COUNTOT=COUNTOTA - GRIDS(IMOD)%GUGINIT = .TRUE. + WRITE (NDST,9002) +#endif + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! Note that in the case of lon/lat grids, these quantities do not + ! include the spherical coordinate metric (SPHERE=.FALSE.). + ! + NTRI = MTRI + COUNTOT=COUNTOTA + GRIDS(IMOD)%GUGINIT = .TRUE. #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) - WRITE (NDST,9003) -#endif - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DIMUG : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DIMUG : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NGRIDS = ',I10/) - 1004 FORMAT (/' *** ERROR W3DIMUG : ARRAY(S) ALREADY ALLOCATED *** ') + WRITE (NDST,9003) +#endif + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DIMUG : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DIMUG : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NGRIDS = ',I10/) +1004 FORMAT (/' *** ERROR W3DIMUG : ARRAY(S) ALREADY ALLOCATED *** ') #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) - 9000 FORMAT (' TEST W3DIMUG: MODEL ',I4,' DIM. AT ',2I5,I7) - 9001 FORMAT (' TEST W3DIMUG : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DIMUG : POINTERS RESET') - 9003 FORMAT (' TEST W3DIMUG : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DIMUG ----------------------------------------------------- / -!/ - END SUBROUTINE W3DIMUG -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SETREF -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 13-Nov-2013 | -!/ +-----------------------------------+ -!/ -!/ 13-Nov-2013 : Origination. ( version 4.13 ) -!/ -! 1. Purpose : -! -! Update reflection directions at shoreline. -! -! 2. Method : -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! None -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_GRID Prog. WW3_GRID Grid preprocessor -! W3ULEV Subr. W3UPDTMD Water level update -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS +9000 FORMAT (' TEST W3DIMUG: MODEL ',I4,' DIM. AT ',2I5,I7) +9001 FORMAT (' TEST W3DIMUG : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DIMUG : POINTERS RESET') +9003 FORMAT (' TEST W3DIMUG : DIMENSIONS STORED') +#endif + !/ + !/ End of W3DIMUG ----------------------------------------------------- / + !/ + END SUBROUTINE W3DIMUG + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SETREF + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 13-Nov-2013 | + !/ +-----------------------------------+ + !/ + !/ 13-Nov-2013 : Origination. ( version 4.13 ) + !/ + ! 1. Purpose : + ! + ! Update reflection directions at shoreline. + ! + ! 2. Method : + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! None + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_GRID Prog. WW3_GRID Grid preprocessor + ! W3ULEV Subr. W3UPDTMD Water level update + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS #ifdef W3_S - USE W3SERVMD, ONLY : STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: ISEA, IX, IY, IXY, IXN, IXP, IYN, IYP - INTEGER :: J, K, NEIGH1(0:7) - INTEGER :: ILEV, NLEV + USE W3SERVMD, ONLY : STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: ISEA, IX, IY, IXY, IXN, IXP, IYN, IYP + INTEGER :: J, K, NEIGH1(0:7) + INTEGER :: ILEV, NLEV #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: TRIX(NY*NX), TRIY(NY*NX), DX, DY, & - COSAVG, SINAVG, THAVG, ANGLES(0:7), CLAT -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: TRIX(NY*NX), TRIY(NY*NX), DX, DY, & + COSAVG, SINAVG, THAVG, ANGLES(0:7), CLAT + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SETREF') -#endif -! -! 1. Preparations --------------------------------------------------- * -! -#ifdef W3_REF1 - IF (REFPARS(2).GT.0) RREF(2)=.TRUE. - IF (REFPARS(3).GT.0) RREF(3)=.TRUE. - IF (REFPARS(4).GT.0) RREF(4)=.TRUE. + CALL STRACE (IENT, 'W3SETREF') #endif -! + ! + ! 1. Preparations --------------------------------------------------- * + ! #ifdef W3_REF1 - DO IY=2, NY-1 - DO IX=2, NX-1 - IF (REFPARS(1).GT.0) RREF(1)=.TRUE. -!No reflection from artificial island on pole. - IF (FLAGLL.AND.(YGRD(IY,IX).GT.85)) RREF(1)=.FALSE. - IF (MAPSTA(IY,IX).GT.0) THEN -! -! Prepares for reflection from subgrid islands -! - IF (RREF(2)) & - REFLC(2,MAPFS(IY,IX))= MAX((1. - TRNX(IY,IX)),(1.-TRNY(IY,IX))) -! -! Prepares for iceberg reflections -! - IF (RREF(4)) & - REFLC(4,MAPFS(IY,IX))= 1. -! -! resolved shoreline reflection -! - IF (RREF(1)) THEN - REFLC(1, MAPFS(IY,IX)) = 0. - REFLD(1:6,MAPFS(IY,IX)) = 0 -! -! Search for neighboring coastline. 3 2 1 -! around X. These are the neighbors of X: 4 X 0 -! 5 6 7 -! -! - NEIGH1(0)=8*MAPST2(IY,IX+1)+MAPSTA(IY,IX+1) - NEIGH1(1:3)=8*MAPST2(IY+1,IX+1:IX-1:-1)+MAPSTA(IY+1,IX+1:IX-1:-1) - NEIGH1(4)=8*MAPST2(IY,IX-1)+MAPSTA(IY,IX-1) - NEIGH1(5:7)=8*MAPST2(IY-1,IX-1:IX+1)+MAPSTA(IY-1,IX-1:IX+1) -! -! if one of the surrounding points is land: determines directions ... -! - IF (MINVAL(ABS(NEIGH1)).EQ.0) THEN - IF ( FLAGLL ) THEN - CLAT = COS(YGRD(IY,IX)*DERA) - ELSE - CLAT = 1. - END IF - ANGLES(0)= ATAN2(DYDP(IY,IX),DXDP(IY,IX)*CLAT) - ANGLES(1)= ATAN2(DYDP(IY,IX)+DYDQ(IY,IX),(DXDP(IY,IX)+DXDQ(IY,IX))*CLAT) - ANGLES(2)= ATAN2(DYDQ(IY,IX),DXDQ(IY,IX)*CLAT) - ANGLES(3)= ATAN2(DYDQ(IY,IX)-DYDP(IY,IX),(DXDQ(IY,IX)-DXDP(IY,IX))*CLAT) - ANGLES(4:7)= ANGLES(0:3)+PI - IF ((NEIGH1(0).GE.1).AND.(NEIGH1(4).GE.1)) THEN - REFLD(3,MAPFS(IY,IX))=0 - ELSE - IF ((NEIGH1(0).GE.1).OR.(NEIGH1(4).GE.1)) REFLD(3,MAPFS(IY,IX))=1 - END IF - IF ((NEIGH1(2).EQ.1).AND.(NEIGH1(6).GE.1)) THEN - REFLD(4,MAPFS(IY,IX))=0 - ELSE - IF ((NEIGH1(2).GE.1).OR.(NEIGH1(6).GE.1)) REFLD(4,MAPFS(IY,IX))=1 - END IF -! -! Looks for a locally straight coast in all 8 orientations -! - J=0 - REFLD(1,MAPFS(IY,IX))=0 - COSAVG=0 - SINAVG=0 -! Shore angle is corrected for grid rotation in w3ref1md.ftn with REFLD(5:6,MAPFS(IY,IX)) - REFLD(5,MAPFS(IY,IX))= MOD(NTH+NINT(ANGLES(0)/TPI*NTH),NTH) - REFLD(6,MAPFS(IY,IX))= MOD(NTH+NINT((ANGLES(2)/TPI-0.25)*NTH),NTH) + IF (REFPARS(2).GT.0) RREF(2)=.TRUE. + IF (REFPARS(3).GT.0) RREF(3)=.TRUE. + IF (REFPARS(4).GT.0) RREF(4)=.TRUE. + ! + DO IY=2, NY-1 + DO IX=2, NX-1 + IF (REFPARS(1).GT.0) RREF(1)=.TRUE. + !No reflection from artificial island on pole. + IF (FLAGLL.AND.(YGRD(IY,IX).GT.85)) RREF(1)=.FALSE. + IF (MAPSTA(IY,IX).GT.0) THEN + ! + ! Prepares for reflection from subgrid islands + ! + IF (RREF(2)) & + REFLC(2,MAPFS(IY,IX))= MAX((1. - TRNX(IY,IX)),(1.-TRNY(IY,IX))) + ! + ! Prepares for iceberg reflections + ! + IF (RREF(4)) & + REFLC(4,MAPFS(IY,IX))= 1. + ! + ! resolved shoreline reflection + ! + IF (RREF(1)) THEN + REFLC(1, MAPFS(IY,IX)) = 0. + REFLD(1:6,MAPFS(IY,IX)) = 0 + ! + ! Search for neighboring coastline. 3 2 1 + ! around X. These are the neighbors of X: 4 X 0 + ! 5 6 7 + ! + ! + NEIGH1(0)=8*MAPST2(IY,IX+1)+MAPSTA(IY,IX+1) + NEIGH1(1:3)=8*MAPST2(IY+1,IX+1:IX-1:-1)+MAPSTA(IY+1,IX+1:IX-1:-1) + NEIGH1(4)=8*MAPST2(IY,IX-1)+MAPSTA(IY,IX-1) + NEIGH1(5:7)=8*MAPST2(IY-1,IX-1:IX+1)+MAPSTA(IY-1,IX-1:IX+1) + ! + ! if one of the surrounding points is land: determines directions ... + ! + IF (MINVAL(ABS(NEIGH1)).EQ.0) THEN + IF ( FLAGLL ) THEN + CLAT = COS(YGRD(IY,IX)*DERA) + ELSE + CLAT = 1. + END IF + ANGLES(0)= ATAN2(DYDP(IY,IX),DXDP(IY,IX)*CLAT) + ANGLES(1)= ATAN2(DYDP(IY,IX)+DYDQ(IY,IX),(DXDP(IY,IX)+DXDQ(IY,IX))*CLAT) + ANGLES(2)= ATAN2(DYDQ(IY,IX),DXDQ(IY,IX)*CLAT) + ANGLES(3)= ATAN2(DYDQ(IY,IX)-DYDP(IY,IX),(DXDQ(IY,IX)-DXDP(IY,IX))*CLAT) + ANGLES(4:7)= ANGLES(0:3)+PI + IF ((NEIGH1(0).GE.1).AND.(NEIGH1(4).GE.1)) THEN + REFLD(3,MAPFS(IY,IX))=0 + ELSE + IF ((NEIGH1(0).GE.1).OR.(NEIGH1(4).GE.1)) REFLD(3,MAPFS(IY,IX))=1 + END IF + IF ((NEIGH1(2).EQ.1).AND.(NEIGH1(6).GE.1)) THEN + REFLD(4,MAPFS(IY,IX))=0 + ELSE + IF ((NEIGH1(2).GE.1).OR.(NEIGH1(6).GE.1)) REFLD(4,MAPFS(IY,IX))=1 + END IF + ! + ! Looks for a locally straight coast in all 8 orientations + ! + J=0 + REFLD(1,MAPFS(IY,IX))=0 + COSAVG=0 + SINAVG=0 + ! Shore angle is corrected for grid rotation in w3ref1md.ftn with REFLD(5:6,MAPFS(IY,IX)) + REFLD(5,MAPFS(IY,IX))= MOD(NTH+NINT(ANGLES(0)/TPI*NTH),NTH) + REFLD(6,MAPFS(IY,IX))= MOD(NTH+NINT((ANGLES(2)/TPI-0.25)*NTH),NTH) #endif #ifdef W3_REFT - IF (IY.EQ.4) THEN - WRITE(6,*) 'POINT (IX,IY):',IX,IY - WRITE(6,*) 'REFT:',NEIGH1(3),NEIGH1(2), NEIGH1(1) - WRITE(6,*) 'REFT:',NEIGH1(4),1, NEIGH1(0) - WRITE(6,*) 'REFT:',NEIGH1(5:7) - WRITE(6,*) 'ANG:',ANGLES(3)*RADE,ANGLES(2)*RADE, ANGLES(1)*RADE - WRITE(6,*) 'ANG:',ANGLES(4)*RADE,1, ANGLES(0) *RADE - WRITE(6,*) 'ANG:',ANGLES(5:7)*RADE - WRITE(6,*) 'REFT:',XGRD(IY+1,IX-1:IX+1), YGRD(IY+1,IX-1:IX+1) - WRITE(6,*) 'REFT:',XGRD(IY,IX-1:IX+1) , YGRD(IY,IX-1:IX+1) - WRITE(6,*) 'REFT:',XGRD(IY-1,IX-1:IX+1), YGRD(IY-1,IX-1:IX+1) - WRITE(6,*) 'REFLD:',REFLD(3:6,MAPFS(IY,IX)) - ENDIF + IF (IY.EQ.4) THEN + WRITE(6,*) 'POINT (IX,IY):',IX,IY + WRITE(6,*) 'REFT:',NEIGH1(3),NEIGH1(2), NEIGH1(1) + WRITE(6,*) 'REFT:',NEIGH1(4),1, NEIGH1(0) + WRITE(6,*) 'REFT:',NEIGH1(5:7) + WRITE(6,*) 'ANG:',ANGLES(3)*RADE,ANGLES(2)*RADE, ANGLES(1)*RADE + WRITE(6,*) 'ANG:',ANGLES(4)*RADE,1, ANGLES(0) *RADE + WRITE(6,*) 'ANG:',ANGLES(5:7)*RADE + WRITE(6,*) 'REFT:',XGRD(IY+1,IX-1:IX+1), YGRD(IY+1,IX-1:IX+1) + WRITE(6,*) 'REFT:',XGRD(IY,IX-1:IX+1) , YGRD(IY,IX-1:IX+1) + WRITE(6,*) 'REFT:',XGRD(IY-1,IX-1:IX+1), YGRD(IY-1,IX-1:IX+1) + WRITE(6,*) 'REFLD:',REFLD(3:6,MAPFS(IY,IX)) + ENDIF #endif #ifdef W3_REF1 + DO K=0,7 + IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+7,8)).EQ.0 & + .AND.NEIGH1(MOD(K+1,8)).EQ.0 & + .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN + REFLC(1,MAPFS(IY,IX))= REFPARS(1) + ! + ! Defines direction index for specular reflection (normal to coast) + ! + ! for example, if we have this layout 1 1 0 + ! (NB: 1 is sea, 0 is land) 1 X 0 + ! 1 1 0 + ! + ! then there is only a coastline detection for K=0, giving J=1 + ! and the final result will be REFLD(1,MAPFS(IY,IX))=1 + ! Namely, the direction TH(REFLD) is the direction pointing INTO the coast + ! + REFLD(2,MAPFS(IY,IX))= 2 + COSAVG=COSAVG+COS(ANGLES(K)) !ECOS(1+(K*NTH)/8) + SINAVG=SINAVG+SIN(ANGLES(K)) !ESIN(1+(K*NTH)/8) + J=J+1 + ENDIF + END DO + IF (J.GT.0) THEN + IF (J.GT.1) REFLD(2,MAPFS(IY,IX))= 1 + THAVG=ATAN2(SINAVG,COSAVG) + REFLD(1,MAPFS(IY,IX))=1+MOD(NTH+NINT(THAVG/TPI*NTH),NTH) + ELSE + + ! 1 1 1 + ! Looks for mild corners like 1 1 1 + ! 1 0 0 DO K=0,7 - IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+7,8)).EQ.0 & - .AND.NEIGH1(MOD(K+1,8)).EQ.0 & - .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN + IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+1,8)).EQ.0 & + .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN REFLC(1,MAPFS(IY,IX))= REFPARS(1) -! -! Defines direction index for specular reflection (normal to coast) -! -! for example, if we have this layout 1 1 0 -! (NB: 1 is sea, 0 is land) 1 X 0 -! 1 1 0 -! -! then there is only a coastline detection for K=0, giving J=1 -! and the final result will be REFLD(1,MAPFS(IY,IX))=1 -! Namely, the direction TH(REFLD) is the direction pointing INTO the coast -! - REFLD(2,MAPFS(IY,IX))= 2 - COSAVG=COSAVG+COS(ANGLES(K)) !ECOS(1+(K*NTH)/8) - SINAVG=SINAVG+SIN(ANGLES(K)) !ESIN(1+(K*NTH)/8) - J=J+1 - ENDIF - END DO - IF (J.GT.0) THEN - IF (J.GT.1) REFLD(2,MAPFS(IY,IX))= 1 - THAVG=ATAN2(SINAVG,COSAVG) -#endif -#if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3SETREF) -#ifdef W3_REF1 - !WRITE (6,*) 'COASTAL REFLECTION:',IX,IY, & - !SINAVG,COSAVG,THAVG/TPI,NINT(THAVG/TPI*NTH),MOD(NTH+NINT(THAVG/TPI*NTH),NTH) -#endif -#endif -#ifdef W3_REF1 - REFLD(1,MAPFS(IY,IX))=1+MOD(NTH+NINT(THAVG/TPI*NTH),NTH) - ELSE - -! 1 1 1 -! Looks for mild corners like 1 1 1 -! 1 0 0 - DO K=0,7 - IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+1,8)).EQ.0 & - .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN + REFLD(1,MAPFS(IY,IX))= 1+MOD((K*NTH+(K+1)*NTH)/16,NTH) + REFLD(2,MAPFS(IY,IX))= 1 + ENDIF + END DO + ! 1 1 1 1 1 1 + ! Looks for sharp corners like 1 1 1 but not diagonals like 1 1 1 + ! 1 0 1 1 1 0 + IF (REFLC(1,MAPFS(IY,IX)).LE.0) THEN + DO K=0,7,2 + IF ( NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+4,8)).NE.0) THEN REFLC(1,MAPFS(IY,IX))= REFPARS(1) - REFLD(1,MAPFS(IY,IX))= 1+MOD((K*NTH+(K+1)*NTH)/16,NTH) - REFLD(2,MAPFS(IY,IX))= 1 - ENDIF - END DO -! 1 1 1 1 1 1 -! Looks for sharp corners like 1 1 1 but not diagonals like 1 1 1 -! 1 0 1 1 1 0 - IF (REFLC(1,MAPFS(IY,IX)).LE.0) THEN - DO K=0,7,2 - IF ( NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+4,8)).NE.0) THEN - REFLC(1,MAPFS(IY,IX))= REFPARS(1) - REFLD(1,MAPFS(IY,IX))= 1+(K*NTH)/8 - REFLD(2,MAPFS(IY,IX))= 0 - !WRITE(6,*) 'NEIGH3:',IX,IY,K,NEIGH1,K*(NTH/8) - END IF - END DO + REFLD(1,MAPFS(IY,IX))= 1+(K*NTH)/8 + REFLD(2,MAPFS(IY,IX))= 0 + !WRITE(6,*) 'NEIGH3:',IX,IY,K,NEIGH1,K*(NTH/8) END IF - END IF -! End of test if surrounding point is land + END DO END IF + END IF + ! End of test if surrounding point is land + END IF #endif #ifdef W3_REFT - IF (REFLC(1,MAPFS(IY,IX)).GT.0) THEN - WRITE (6,*) 'COAST DIRECTION AT POINT:',IX,IY,' IS ', & - REFLD(:,MAPFS(IY,IX)),TH(REFLD(1,MAPFS(IY,IX)))*360/TPI - ENDIF + IF (REFLC(1,MAPFS(IY,IX)).GT.0) THEN + WRITE (6,*) 'COAST DIRECTION AT POINT:',IX,IY,' IS ', & + REFLD(:,MAPFS(IY,IX)),TH(REFLD(1,MAPFS(IY,IX)))*360/TPI + ENDIF #endif #ifdef W3_REF1 -! End of test if local point is sea - END IF - END IF - END DO - END DO -#endif -! - RETURN -! -! Formats -! -!/ -!/ End of W3SETREF ----------------------------------------------------- / -!/ - END SUBROUTINE W3SETREF - -!/ -!/ End of module W3GDATMD -------------------------------------------- / -!/ - END MODULE W3GDATMD + ! End of test if local point is sea + END IF + END IF + END DO + END DO +#endif + ! + RETURN + ! + ! Formats + ! + !/ + !/ End of W3SETREF ----------------------------------------------------- / + !/ + END SUBROUTINE W3SETREF + + !/ + !/ End of module W3GDATMD -------------------------------------------- / + !/ +END MODULE W3GDATMD diff --git a/model/src/w3gig1md.F90 b/model/src/w3gig1md.F90 index f85738d9e..a3d225ff6 100644 --- a/model/src/w3gig1md.F90 +++ b/model/src/w3gig1md.F90 @@ -1,299 +1,299 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3GIG1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III | -!/ | A. Rawat and F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 05-Jul-2012 | -!/ +-----------------------------------+ -!/ -!/ 31-Mar-2010 : Origination. ( version 4.07 ) -!/ -! 1. Purpose : -! -! This module computes : -! - the second order spectrum, in particular for infragravity waves -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SREF Subr. Public Reflection of waves (shorline, islands...) -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! - PUBLIC -!/ -!/ Public variables -!/ -! -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - - FUNCTION Df1f2theta(s1,s2,WN1,WN2,theta,DEPTH) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Nov-1999 | -!/ +-----------------------------------+ -!/ Based on INCYMD of the GLA GCM. -!/ -!/ 18-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Computes the coupling coefficient between waves of frequencies f1 and f2 -! and an angle theta. -! This is for the surface elevation variance -! See Okihiro et al. 1992 -! Code adapted from Matlab by Arshad Rawat, 2012. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NYMD Int. I Old date in YYMMDD format. -! M Int. I +/- 1 (Day adjustment) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any subroutine. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS - - IMPLICIT NONE - - REAL, INTENT(IN) :: s1,s2,theta,DEPTH - REAL :: Df1f2theta,WN1,WN2 - REAL :: k1,k2,co,cok1,cok2,k3,C1,C2,C3,C4 - REAL :: C1b,s3,sk2,g2,g - - k1=WN1 - k2=WN2 - co=cos(theta) - g2=GRAV**2 - s3=s1+s2 - k3=SQRT(k1**2+k2**2+2*k1*k2*co) - g=GRAV - sk2=g*k3*tanh(k3*DEPTH) - - C1=-(k1*k2*co)/(s1*s2) - C1b=(s3**2-s1*s2)/g2 - C2=s3 - C3=(s3**2-sk2)*s1*s2 - -! C4 is Hasselmann's D times i - - C4=s3*(k1*k2*co-((s1*s2)**2)/g2)+0.5*(s1*k2**2+s2*k1**2-s1*s2*(s2**3+s1**3)/g2) - - Df1f2theta=g*(0.5*(C1+C1b)+(C2*C4/C3)); - - RETURN -END FUNCTION Df1f2theta - - -!/ ------------------------------------------------------------------- / - SUBROUTINE W3ADDIG(E,DEPTH,WN,CG,IACTION) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III | -!/ | A. Rawat and F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 05-Jul-2012 | -!/ +-----------------------------------+ -!/ -!/ 31-Mar-2010 : Origination. ( version 4.07 ) -!/ -! 1. Purpose : -! -! This subroutine computes : -! - the second order spectrum, in particular for infragravity waves -! 2. Method : -! Uses 2nd order coupling coefficient (Biesel 1952, Hasselmann 1962) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! E R.A. I/O Energy density spectrum (1-D), f-theta -! DEPTH Real I Water depth -! WN R.A. wavenumbers -! CG R.A. group velocities -! IACTION Int I Switch to specify if the input spectrum -! is E(f,theta) or A(k,theta) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SREF Subr. W3REF1MD Shoreline reflection source term -! W3EXPO Subr. N/A Point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3DISPMD - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, DTH, DDEN, & - ECOS, ESIN, EC2, MAPTH, MAPWN, & - DSIP, IOBPD, GTYPE, UNGTYPE, IGPARS +MODULE W3GIG1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III | + !/ | A. Rawat and F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 05-Jul-2012 | + !/ +-----------------------------------+ + !/ + !/ 31-Mar-2010 : Origination. ( version 4.07 ) + !/ + ! 1. Purpose : + ! + ! This module computes : + ! - the second order spectrum, in particular for infragravity waves + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SREF Subr. Public Reflection of waves (shorline, islands...) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + PUBLIC + !/ + !/ Public variables + !/ + ! + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + + FUNCTION Df1f2theta(s1,s2,WN1,WN2,theta,DEPTH) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Nov-1999 | + !/ +-----------------------------------+ + !/ Based on INCYMD of the GLA GCM. + !/ + !/ 18-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Computes the coupling coefficient between waves of frequencies f1 and f2 + ! and an angle theta. + ! This is for the surface elevation variance + ! See Okihiro et al. 1992 + ! Code adapted from Matlab by Arshad Rawat, 2012. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NYMD Int. I Old date in YYMMDD format. + ! M Int. I +/- 1 (Day adjustment) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any subroutine. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS + + IMPLICIT NONE + + REAL, INTENT(IN) :: s1,s2,theta,DEPTH + REAL :: Df1f2theta,WN1,WN2 + REAL :: k1,k2,co,cok1,cok2,k3,C1,C2,C3,C4 + REAL :: C1b,s3,sk2,g2,g + + k1=WN1 + k2=WN2 + co=cos(theta) + g2=GRAV**2 + s3=s1+s2 + k3=SQRT(k1**2+k2**2+2*k1*k2*co) + g=GRAV + sk2=g*k3*tanh(k3*DEPTH) + + C1=-(k1*k2*co)/(s1*s2) + C1b=(s3**2-s1*s2)/g2 + C2=s3 + C3=(s3**2-sk2)*s1*s2 + + ! C4 is Hasselmann's D times i + + C4=s3*(k1*k2*co-((s1*s2)**2)/g2)+0.5*(s1*k2**2+s2*k1**2-s1*s2*(s2**3+s1**3)/g2) + + Df1f2theta=g*(0.5*(C1+C1b)+(C2*C4/C3)); + + RETURN + END FUNCTION Df1f2theta + + + !/ ------------------------------------------------------------------- / + SUBROUTINE W3ADDIG(E,DEPTH,WN,CG,IACTION) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III | + !/ | A. Rawat and F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 05-Jul-2012 | + !/ +-----------------------------------+ + !/ + !/ 31-Mar-2010 : Origination. ( version 4.07 ) + !/ + ! 1. Purpose : + ! + ! This subroutine computes : + ! - the second order spectrum, in particular for infragravity waves + ! 2. Method : + ! Uses 2nd order coupling coefficient (Biesel 1952, Hasselmann 1962) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! E R.A. I/O Energy density spectrum (1-D), f-theta + ! DEPTH Real I Water depth + ! WN R.A. wavenumbers + ! CG R.A. group velocities + ! IACTION Int I Switch to specify if the input spectrum + ! is E(f,theta) or A(k,theta) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SREF Subr. W3REF1MD Shoreline reflection source term + ! W3EXPO Subr. N/A Point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3DISPMD + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, DTH, DDEN, & + ECOS, ESIN, EC2, MAPTH, MAPWN, & + DSIP, IOBPD, GTYPE, UNGTYPE, IGPARS #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(INOUT) :: E(NSPEC) - REAL, INTENT(IN) :: DEPTH - REAL, INTENT(IN) :: WN(NK) - REAL, INTENT(IN) :: CG(NK) - INTEGER, INTENT(IN) :: IACTION - -!***************************************************************************** -! Computes the "second order spectrum" (only difference interaction, not sum) -!***************************************************************************** -! Reads in the wave frequency-directional spectrum -! - - - INTEGER :: NKIG,iloc,NSPECIG - INTEGER :: i,iIG,IFR,IK,ith,ith1,ith2,itime,I2, ISP1, ISP2, ISP3 - INTEGER , DIMENSION(:,:), ALLOCATABLE :: ifr2c - - REAL :: d,deltaf,dfIG,CG2 - REAL :: WN1,K1,K2,Dkx,Dky,Eadd,thetaIG,memo - - REAL , DIMENSION(:), ALLOCATABLE :: df,fIG,II,Efmall - REAL , DIMENSION(:,:), ALLOCATABLE :: wfr1,Efth - REAL , DIMENSION(:), ALLOCATABLE :: EfthIG - REAL , DIMENSION(:,:,:,:), ALLOCATABLE :: DD - REAL , DIMENSION(NSPEC) :: ESPEC - CHARACTER(120) ::path,filename,filename2 - - -! Defines the spectral domain for the IG computation - NKIG=IGPARS(5) - NSPECIG=NKIG*NTH - - ALLOCATE(DD(NKIG,nk,nth,nth)) - ALLOCATE(wfr1(NKIG,nk)) - ALLOCATE(ifr2c(NKIG,nk)) - ALLOCATE(EfthIG(NSPECIG)) - EfthIG(:)=0. - -! WRITE(*,*) 'Computing coupling coefficient for SURFACE ELEVATION' - - IF (IACTION.EQ.0) THEN - ESPEC=E - ELSE - DO IK = 1,NK - DO ITH = 1, NTH - ISP1=ITH+(IK-1)*NTH - ESPEC(ISP1)=E(ISP1)*SIG(IK)*TPI / CG(IK) - END DO + !/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(INOUT) :: E(NSPEC) + REAL, INTENT(IN) :: DEPTH + REAL, INTENT(IN) :: WN(NK) + REAL, INTENT(IN) :: CG(NK) + INTEGER, INTENT(IN) :: IACTION + + !***************************************************************************** + ! Computes the "second order spectrum" (only difference interaction, not sum) + !***************************************************************************** + ! Reads in the wave frequency-directional spectrum + ! + + + INTEGER :: NKIG,iloc,NSPECIG + INTEGER :: i,iIG,IFR,IK,ith,ith1,ith2,itime,I2, ISP1, ISP2, ISP3 + INTEGER , DIMENSION(:,:), ALLOCATABLE :: ifr2c + + REAL :: d,deltaf,dfIG,CG2 + REAL :: WN1,K1,K2,Dkx,Dky,Eadd,thetaIG,memo + + REAL , DIMENSION(:), ALLOCATABLE :: df,fIG,II,Efmall + REAL , DIMENSION(:,:), ALLOCATABLE :: wfr1,Efth + REAL , DIMENSION(:), ALLOCATABLE :: EfthIG + REAL , DIMENSION(:,:,:,:), ALLOCATABLE :: DD + REAL , DIMENSION(NSPEC) :: ESPEC + CHARACTER(120) ::path,filename,filename2 + + + ! Defines the spectral domain for the IG computation + NKIG=IGPARS(5) + NSPECIG=NKIG*NTH + + ALLOCATE(DD(NKIG,nk,nth,nth)) + ALLOCATE(wfr1(NKIG,nk)) + ALLOCATE(ifr2c(NKIG,nk)) + ALLOCATE(EfthIG(NSPECIG)) + EfthIG(:)=0. + + ! WRITE(*,*) 'Computing coupling coefficient for SURFACE ELEVATION' + + IF (IACTION.EQ.0) THEN + ESPEC=E + ELSE + DO IK = 1,NK + DO ITH = 1, NTH + ISP1=ITH+(IK-1)*NTH + ESPEC(ISP1)=E(ISP1)*SIG(IK)*TPI / CG(IK) + END DO + END DO + END IF + ! + DO iIG=1,NKIG + DO ifr=1,nk + CALL WAVNU1 (SIG(ifr)+SIG(iIG),DEPTH,WN1,CG2) + DO ith1=1,nth + DO ith2=1,nth + ! + ! This is the coupling coefficient for the SURFACE ELEVATION. See .e.g. forristall (JPO 2000) + ! + DD(iIG,ifr,ith1,ith2)=(Df1f2theta(SIG(ifr)+SIG(iIG),-SIG(ifr), WN1,WN(IFR), & + (abs(TH(ith1)-TH(ith2))+pi),DEPTH))**2 + END DO - END IF -! - DO iIG=1,NKIG - DO ifr=1,nk - CALL WAVNU1 (SIG(ifr)+SIG(iIG),DEPTH,WN1,CG2) - DO ith1=1,nth - DO ith2=1,nth -! -! This is the coupling coefficient for the SURFACE ELEVATION. See .e.g. forristall (JPO 2000) -! - DD(iIG,ifr,ith1,ith2)=(Df1f2theta(SIG(ifr)+SIG(iIG),-SIG(ifr), WN1,WN(IFR), & - (abs(TH(ith1)-TH(ith2))+pi),DEPTH))**2 - - END DO - END DO + END DO + ! + ! weights + ! + wfr1(iIG,ifr)=dble(DSIP(ifr))*dth ! -! weights -! - wfr1(iIG,ifr)=dble(DSIP(ifr))*dth -! -! Computes indices for a proper integration over the spectral domain using Rectangle's rule -! since we integrate E(f)*E(f+fIG)*df for a fixed fIG + ! Computes indices for a proper integration over the spectral domain using Rectangle's rule + ! since we integrate E(f)*E(f+fIG)*df for a fixed fIG - iloc=1 + iloc=1 if (SIG(iIG) < 0.5*DSIP(ifr))THEN ifr2c(iIG,ifr)=ifr @@ -303,81 +303,79 @@ SUBROUTINE W3ADDIG(E,DEPTH,WN,CG,IACTION) if (iloc /= 0) THEN ifr2c(iIG,ifr)=iloc ! index of frequency f+fIG else - ifr2c(iIG,ifr)=nk - end if - - !wfr1(iIG,ifr)=0.0 + ifr2c(iIG,ifr)=nk end if - end do + + !wfr1(iIG,ifr)=0.0 + end if end do + end do - DO iIG=1,NKIG - DO IFR = 1,NK-1 - -! AR calculating k1 and k2 before loops on th1 and th2 - - k1=WN(ifr) - k2=WN(ifr2c(iIG,ifr)) - - DO ith1 = 1,NTH - DO ith2 = 1,NTH - -! Adds the effect of interaction of frequency f(ifr), theta(ith1) with f(ifr)+fIG(:), theta(ith2) - ISP1 = ITH1 + (ifr2c(iIG,ifr)-1)*NTH - ISP2 = ITH2 + (ifr-1)*NTH - - Eadd=DD(iIG,ifr,ith1,ith2)*wfr1(iIG,ifr) & - *ESPEC(ISP1)*ESPEC(ISP2) ! Rectangle rule by AR - Dkx=k2*cos(dble(dth*ith2))- k1*cos(dble(dth*ith1)) - Dky=k2*sin(dble(dth*ith2))- k1*sin(dble(dth*ith1)) - - thetaIG=atan2(Dky,Dkx) - - if (thetaIG.LT.0) thetaIG=2*pi+thetaIG -! Finding corresponding index of theta IG in theta array - !I=INT((thetaIG/(2*pi))*nth) - - I=minloc(abs(thetaIG-TH), 1)-1 - if (I==0) I=nth - ISP3 = I + (iIG-1)*NTH -! memo=EfthIG(ISP3) - EfthIG(ISP3)= EfthIG(ISP3)+Eadd; -! IF (EfthIG(ISP3).NE.EfthIG(ISP3).AND.Eadd.NE.0) WRITE(6,*) 'EfthIG:',IIG, IFR, ITH1,ITH2,ISP3, & -! EfthIG(ISP3),Eadd,memo - END DO - END DO - end do - end do - -! ESPEC(1:NSPECIG)=ESPEC(1:NSPECIG)+EfthIG(:) - ESPEC(1:NSPECIG)=EfthIG(:) - - IF (IACTION.EQ.0) THEN - DO ISP1=1,NSPECIG - E(ISP1)=ESPEC(ISP1) - END DO - ELSE - DO IK = 1,NKIG - DO ITH = 1, NTH - ISP1=ITH+(IK-1)*NTH - E(ISP1)=ESPEC(ISP1)*CG(IK)/(SIG(IK)*TPI) - END DO - END DO - END IF + DO iIG=1,NKIG + DO IFR = 1,NK-1 -! OPEN(5555,FILE='testos.dat',status='unknown') -! WRITE(5555,*) E,EfthIG !f,fIG,tet!ifr2c !Efth, !!, Efth, + ! AR calculating k1 and k2 before loops on th1 and th2 -!/ -!/ End of W3ADDIG ----------------------------------------------------- / -!/ - END SUBROUTINE W3ADDIG -!/ ------------------------------------------------------------------- / + k1=WN(ifr) + k2=WN(ifr2c(iIG,ifr)) + + DO ith1 = 1,NTH + DO ith2 = 1,NTH + + ! Adds the effect of interaction of frequency f(ifr), theta(ith1) with f(ifr)+fIG(:), theta(ith2) + ISP1 = ITH1 + (ifr2c(iIG,ifr)-1)*NTH + ISP2 = ITH2 + (ifr-1)*NTH -!/ -!/ End of module W3GIG1MD -------------------------------------------- / -!/ - END MODULE W3GIG1MD + Eadd=DD(iIG,ifr,ith1,ith2)*wfr1(iIG,ifr) & + *ESPEC(ISP1)*ESPEC(ISP2) ! Rectangle rule by AR + Dkx=k2*cos(dble(dth*ith2))- k1*cos(dble(dth*ith1)) + Dky=k2*sin(dble(dth*ith2))- k1*sin(dble(dth*ith1)) + thetaIG=atan2(Dky,Dkx) + if (thetaIG.LT.0) thetaIG=2*pi+thetaIG + ! Finding corresponding index of theta IG in theta array + !I=INT((thetaIG/(2*pi))*nth) + + I=minloc(abs(thetaIG-TH), 1)-1 + if (I==0) I=nth + ISP3 = I + (iIG-1)*NTH + ! memo=EfthIG(ISP3) + EfthIG(ISP3)= EfthIG(ISP3)+Eadd; + ! IF (EfthIG(ISP3).NE.EfthIG(ISP3).AND.Eadd.NE.0) WRITE(6,*) 'EfthIG:',IIG, IFR, ITH1,ITH2,ISP3, & + ! EfthIG(ISP3),Eadd,memo + END DO + END DO + end do + end do + + ! ESPEC(1:NSPECIG)=ESPEC(1:NSPECIG)+EfthIG(:) + ESPEC(1:NSPECIG)=EfthIG(:) + + IF (IACTION.EQ.0) THEN + DO ISP1=1,NSPECIG + E(ISP1)=ESPEC(ISP1) + END DO + ELSE + DO IK = 1,NKIG + DO ITH = 1, NTH + ISP1=ITH+(IK-1)*NTH + E(ISP1)=ESPEC(ISP1)*CG(IK)/(SIG(IK)*TPI) + END DO + END DO + END IF + + ! OPEN(5555,FILE='testos.dat',status='unknown') + ! WRITE(5555,*) E,EfthIG !f,fIG,tet!ifr2c !Efth, !!, Efth, + + !/ + !/ End of W3ADDIG ----------------------------------------------------- / + !/ + END SUBROUTINE W3ADDIG + !/ ------------------------------------------------------------------- / + + !/ + !/ End of module W3GIG1MD -------------------------------------------- / + !/ +END MODULE W3GIG1MD diff --git a/model/src/w3gkemd.F90 b/model/src/w3gkemd.F90 index 16dd09039..15f5b6acc 100644 --- a/model/src/w3gkemd.F90 +++ b/model/src/w3gkemd.F90 @@ -1,1738 +1,1738 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / module w3gkemd -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Odin Gramstad | -!/ | Qingxiang Liu | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 03-Jun-2021 | -!/ +-----------------------------------+ -!/ -!/ 26-May-2014 : Origination. ( version 3.14 ) -!/ Intially Dr. O. Gramstad implemented his GKE method -!/ in WW3 v3.14 which worked well for the single-grid -!/ point duration-limited test. -!/ -!/ 09-Nov-2018 : Fully implemented in WW3 ( version 7.13 ) -!/ ( Q. Liu ) -!/ 16-Apr-2019 : Add save attribute explicitly ( version 7.13 ) -!/ ( Q. Liu ) -!/ 18-Apr-2019 : Add the bilinear interp. option ( version 7.13 ) -!/ ( Q. Liu ) -!/ 08-Jul-2019 : Use kind=8 for qi_nnz ( Q. Liu ) -!/ 01-Apr-2020 : Boundary conditions ( Q. Liu ) -!/ 03-Jun-2021 : Merge into the WW3 Github ( version 7.12 ) -!/ ( Q. Liu ) -!/ -! 1. Purpose: -! Calculate the (resonant & quasi/near-resonant) four-wave nonlinear -! interaction term S_{nl} according to the generalized kinetic -! equation (GKE) developed in Gramstad and Stiassnie (2013). -! -! References: -! Gramstad and Stiassnie (2013), JFM, 818, 280-303 (hereafter GS13) -! Gramstad and Babanin (2016), OD, 66, 509-526 (hereafter GB16) -! Liu et al. (2021), JFM, 910, A50 (hereafter LGB21) -! & -! Annenkov and Shrira (2006), JFM, 561, 181-207 (*) -! Annenkov and Shrira (2015), JPO, 45, 807-812 -! Annenkov and Shrira (2018), JFM, 844, 766-795 (*) -! & -! Shrira and Annenkov (2013), Book Ch., 239-281 -! Annenkov and Shrira (2016), Book Ch., 159-178 -! -! (*) Note that equations therein contain typos. -! -! 2. Subroutines and functions : -! -! [Part 1]: Kernel Function -! -! Calculate the kernel function T_{0, 1, 2, 3} for the Zakharov -! Equation. -! -! References: -! Krasitskii (1994), JFM, 272, 1 - 20 (hereafter K94) -! Janssen (2009), JFM, 637, 1 - 44 (hereafter J09) -! Mei et al. (2005), ch. 14, 882 - 884 -! -! Based on my own observation, Odin has closely followed the -! equations presented in the appendix (A.1/2) of J09. -! -! ---------------------------------------------------------------- -! Name Type Scope Description -! ---------------------------------------------------------------- -! QFunc Func. Private q = ω^2 / g -! VpFunc Func. Private V^{(+)}_{1, 2, 3} -! VmFunc Func. Private V^{(-)}_{1, 2, 3} -! UFunc Func. Private U_{1, 2, 3, 4} -! TFunc Func. Public T_{1, 2, 3, 4} -! ---------------------------------------------------------------- -! -! [Part 2]: Find Quartets (total number & configurations) -! -! References: -! Annenkov and Shrira (2015), JPO, 45, 807-812 -! Hasselmann and Hasselmann (1981), Exact-NL/DIA report -! Hasselmann and Hasselmann (1985), JPO, 15, 1369-1377 -! -! ---------------------------------------------------------------- -! Name Type Scope Description -! ---------------------------------------------------------------- -! FindQuartetNumber Subr. Private Total No. of Quartets -! FindQuartetConfig Subr. Private Config. of Quartets -! -! [Part 3]: Sparse matrix (storage, operation) -! -! References: -! Saad (1994) SPARSKIT: a basic tool kit for sparse matrix -! compuation (version 2) -! -! ---------------------------------------------------------------- -! Name Type Scope Description -! ---------------------------------------------------------------- -! CooCsrInd Subr. Private COO to CSR format -! ASymSmatTimVec Subr. Private (A±A^T)∙X, where (A±A^T) is an -! (anti)symmetric sparse matrix -! -! [Part 4]: GKE Integral (main subrs.) -! -! References: -! Gramstad and Stiassnie (2013), JFM, 818, 280-303 (hereafter GS13) -! Gramstad and Babanin (2016), OD, 66, 509-526 (hereafter GB16) -! Liu et al. (2021), JFM, 910, A50 (hereafter LGB21) -! Janssen (2003), JPO, 33, 863-884 (hereafter J03) -! Janssen (2009), JFM, 637, 1- 44 (hereafter J09) -! Annenkov and Shrira (2013), JFM, 726, 517-546 -! -! Hasselmann and Hasselmann (1981), Exact-NL/DIA report -! Hasselmann and Hasselmann (1985), JPO, 15, 1369-1377 -! van Vledder (2006), CE, 53, 223-242 -! Tolman (2013), OM, 70, 11- 24 -! -! ---------------------------------------------------------------- -! Name Type Scope Description -! ---------------------------------------------------------------- -! PrepKGrid Subr. Private (σ, θ) to (kx, ky) -! PrepKernelIO Subr. Private Read/Write Quartet Cfg file -! BiInterpWT Subr. Private Calc. interp. weights -! CalcQRSNL Subr. Public GKE Transfer Integral -! -! 3. Future work (TODO) -! * The current version only works for a constant-depth application ( -! either deep or finite deep). Extension of this module to be -! applicable to varying-depth cases may be pursued in the future. -! -! * Dnl -- diagonal term -! * βnpqr -- nonlinear stokes correction -!/ -!/ ------------------------------------------------------------------- / -! -! Public parameters -! -! * `qi_` denotes the variable is integer number -! * `qr_` ... real ... -! * `qs_` ... string -! * `ql_` ... logical -! * `qc_` ... complex -!/ - implicit none -!/ ------------------------------------------------------------------- / - public :: PrepKernelIO, CalcQRSNL -! - public :: qr_depth, qr_oml, qi_disc, qi_kev, qi_nnz, qi_interp + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Odin Gramstad | + !/ | Qingxiang Liu | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 03-Jun-2021 | + !/ +-----------------------------------+ + !/ + !/ 26-May-2014 : Origination. ( version 3.14 ) + !/ Intially Dr. O. Gramstad implemented his GKE method + !/ in WW3 v3.14 which worked well for the single-grid + !/ point duration-limited test. + !/ + !/ 09-Nov-2018 : Fully implemented in WW3 ( version 7.13 ) + !/ ( Q. Liu ) + !/ 16-Apr-2019 : Add save attribute explicitly ( version 7.13 ) + !/ ( Q. Liu ) + !/ 18-Apr-2019 : Add the bilinear interp. option ( version 7.13 ) + !/ ( Q. Liu ) + !/ 08-Jul-2019 : Use kind=8 for qi_nnz ( Q. Liu ) + !/ 01-Apr-2020 : Boundary conditions ( Q. Liu ) + !/ 03-Jun-2021 : Merge into the WW3 Github ( version 7.12 ) + !/ ( Q. Liu ) + !/ + ! 1. Purpose: + ! Calculate the (resonant & quasi/near-resonant) four-wave nonlinear + ! interaction term S_{nl} according to the generalized kinetic + ! equation (GKE) developed in Gramstad and Stiassnie (2013). + ! + ! References: + ! Gramstad and Stiassnie (2013), JFM, 818, 280-303 (hereafter GS13) + ! Gramstad and Babanin (2016), OD, 66, 509-526 (hereafter GB16) + ! Liu et al. (2021), JFM, 910, A50 (hereafter LGB21) + ! & + ! Annenkov and Shrira (2006), JFM, 561, 181-207 (*) + ! Annenkov and Shrira (2015), JPO, 45, 807-812 + ! Annenkov and Shrira (2018), JFM, 844, 766-795 (*) + ! & + ! Shrira and Annenkov (2013), Book Ch., 239-281 + ! Annenkov and Shrira (2016), Book Ch., 159-178 + ! + ! (*) Note that equations therein contain typos. + ! + ! 2. Subroutines and functions : + ! + ! [Part 1]: Kernel Function + ! + ! Calculate the kernel function T_{0, 1, 2, 3} for the Zakharov + ! Equation. + ! + ! References: + ! Krasitskii (1994), JFM, 272, 1 - 20 (hereafter K94) + ! Janssen (2009), JFM, 637, 1 - 44 (hereafter J09) + ! Mei et al. (2005), ch. 14, 882 - 884 + ! + ! Based on my own observation, Odin has closely followed the + ! equations presented in the appendix (A.1/2) of J09. + ! + ! ---------------------------------------------------------------- + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! QFunc Func. Private q = ω^2 / g + ! VpFunc Func. Private V^{(+)}_{1, 2, 3} + ! VmFunc Func. Private V^{(-)}_{1, 2, 3} + ! UFunc Func. Private U_{1, 2, 3, 4} + ! TFunc Func. Public T_{1, 2, 3, 4} + ! ---------------------------------------------------------------- + ! + ! [Part 2]: Find Quartets (total number & configurations) + ! + ! References: + ! Annenkov and Shrira (2015), JPO, 45, 807-812 + ! Hasselmann and Hasselmann (1981), Exact-NL/DIA report + ! Hasselmann and Hasselmann (1985), JPO, 15, 1369-1377 + ! + ! ---------------------------------------------------------------- + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! FindQuartetNumber Subr. Private Total No. of Quartets + ! FindQuartetConfig Subr. Private Config. of Quartets + ! + ! [Part 3]: Sparse matrix (storage, operation) + ! + ! References: + ! Saad (1994) SPARSKIT: a basic tool kit for sparse matrix + ! compuation (version 2) + ! + ! ---------------------------------------------------------------- + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! CooCsrInd Subr. Private COO to CSR format + ! ASymSmatTimVec Subr. Private (A±A^T)∙X, where (A±A^T) is an + ! (anti)symmetric sparse matrix + ! + ! [Part 4]: GKE Integral (main subrs.) + ! + ! References: + ! Gramstad and Stiassnie (2013), JFM, 818, 280-303 (hereafter GS13) + ! Gramstad and Babanin (2016), OD, 66, 509-526 (hereafter GB16) + ! Liu et al. (2021), JFM, 910, A50 (hereafter LGB21) + ! Janssen (2003), JPO, 33, 863-884 (hereafter J03) + ! Janssen (2009), JFM, 637, 1- 44 (hereafter J09) + ! Annenkov and Shrira (2013), JFM, 726, 517-546 + ! + ! Hasselmann and Hasselmann (1981), Exact-NL/DIA report + ! Hasselmann and Hasselmann (1985), JPO, 15, 1369-1377 + ! van Vledder (2006), CE, 53, 223-242 + ! Tolman (2013), OM, 70, 11- 24 + ! + ! ---------------------------------------------------------------- + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! PrepKGrid Subr. Private (σ, θ) to (kx, ky) + ! PrepKernelIO Subr. Private Read/Write Quartet Cfg file + ! BiInterpWT Subr. Private Calc. interp. weights + ! CalcQRSNL Subr. Public GKE Transfer Integral + ! + ! 3. Future work (TODO) + ! * The current version only works for a constant-depth application ( + ! either deep or finite deep). Extension of this module to be + ! applicable to varying-depth cases may be pursued in the future. + ! + ! * Dnl -- diagonal term + ! * βnpqr -- nonlinear stokes correction + !/ + !/ ------------------------------------------------------------------- / + ! + ! Public parameters + ! + ! * `qi_` denotes the variable is integer number + ! * `qr_` ... real ... + ! * `qs_` ... string + ! * `ql_` ... logical + ! * `qc_` ... complex + !/ + implicit none + !/ ------------------------------------------------------------------- / + public :: PrepKernelIO, CalcQRSNL + ! + public :: qr_depth, qr_oml, qi_disc, qi_kev, qi_nnz, qi_interp - private :: QFunc, VpFunc, VmFunc, UFunc, TFunc, & - FindQuartetNumber, FindQuartetConfig, & - CooCsrInd, ASymSmatTimVec, & - PrepKGrid, BiInterpWT -! - private :: qs_ver, qi_lrb, qr_eps, qr_grav, & - qr_pi, qr_tpi, qr_dmax, qc_iu, qs_cfg, & - qr_kx, qr_ky, qr_dk, qr_om, qi_nrsm, & - qi_NN, qi_PP, qi_QQ, qi_RR, & - qr_k4x, qr_k4y, qr_om4, qr_dom, & - qr_TKern, qr_TKurt, & - qi_icCos, qi_irCsr, qr_sumQR, qr_sumNP, & - qi_bind, qr_bwgh, qr_wn1 -! - private :: qi_bound, qr_fpow, qr_bdry -! -!/ ------------------------------------------------------------------- / - real :: qr_depth ! Real water depth d (m) + private :: QFunc, VpFunc, VmFunc, UFunc, TFunc, & + FindQuartetNumber, FindQuartetConfig, & + CooCsrInd, ASymSmatTimVec, & + PrepKGrid, BiInterpWT + ! + private :: qs_ver, qi_lrb, qr_eps, qr_grav, & + qr_pi, qr_tpi, qr_dmax, qc_iu, qs_cfg, & + qr_kx, qr_ky, qr_dk, qr_om, qi_nrsm, & + qi_NN, qi_PP, qi_QQ, qi_RR, & + qr_k4x, qr_k4y, qr_om4, qr_dom, & + qr_TKern, qr_TKurt, & + qi_icCos, qi_irCsr, qr_sumQR, qr_sumNP, & + qi_bind, qr_bwgh, qr_wn1 + ! + private :: qi_bound, qr_fpow, qr_bdry + ! + !/ ------------------------------------------------------------------- / + real :: qr_depth ! Real water depth d (m) - real :: qr_oml ! λ cut off factor - ! λ ≤ 0 → quartets far - ! from resonance will not - ! be excluded. + real :: qr_oml ! λ cut off factor + ! λ ≤ 0 → quartets far + ! from resonance will not + ! be excluded. - integer :: qi_disc ! Discretization of GKE - ! 0: continuous (like Exact-NL, WRT) - ! 1: discrete (see GS13) + integer :: qi_disc ! Discretization of GKE + ! 0: continuous (like Exact-NL, WRT) + ! 1: discrete (see GS13) - integer :: qi_kev ! Version of KE - ! 0: GKE - ! 1: KE from J03 + integer :: qi_kev ! Version of KE + ! 0: GKE + ! 1: KE from J03 - integer :: qi_interp ! Interp. option - ! 0: Nearest bin - ! 1: Bilinear Interp + integer :: qi_interp ! Interp. option + ! 0: Nearest bin + ! 1: Bilinear Interp - integer, parameter :: qi_bound= 1 ! Boundary conditions - ! 0: no bound - ! 1: tail extension + integer, parameter :: qi_bound= 1 ! Boundary conditions + ! 0: no bound + ! 1: tail extension - real, parameter :: qr_fpow= -5. ! E(f) tail power law -! - character(len=50), parameter & - :: qs_ver = 'gkev0' ! version number/str - integer, parameter :: qi_lrb = 4 ! 4 bytes - real, parameter :: qr_eps = epsilon(100.0) ! Smallest positive - ! value supported by the - ! compiler (e.g., gfortran - ! → 1.19E-7) + real, parameter :: qr_fpow= -5. ! E(f) tail power law + ! + character(len=50), parameter & + :: qs_ver = 'gkev0' ! version number/str + integer, parameter :: qi_lrb = 4 ! 4 bytes + real, parameter :: qr_eps = epsilon(100.0) ! Smallest positive + ! value supported by the + ! compiler (e.g., gfortran + ! → 1.19E-7) - real, parameter :: qr_grav = 9.806 ! Gravational acc (m/s^2) - real, parameter :: qr_pi = 3.141592653589793 ! π - real, parameter :: qr_tpi = 2 * qr_pi ! π * 2 - real, parameter :: qr_dmax = 3000.0 ! Maximum allowed water - complex, parameter :: qc_iu = (0.0, 1.0) ! complex unit `i` -! - character(len=100) :: qs_cfg ! File name for quartet/kernel -! - real, allocatable, save :: qr_kx(:), qr_ky(:), & ! kx, ky (2D grid → 1D vector) - qr_dk(:), qr_om(:) ! Δ\vec{k}, ω, -! - integer(kind=8) :: qi_nnz ! # of quartets - integer :: qi_nrsm ! # of rows of SMat - integer, allocatable, save :: qi_NN(:), qi_PP(:), & ! Index for Quartets - qi_QQ(:), qi_RR(:) - real, allocatable, save :: qr_k4x(:), qr_k4y(:), & ! kx, ky, ω for 4th wave - qr_om4(:) - real, allocatable, save :: qr_dom(:), & ! Δω - qr_TKern(:), & ! Kernel `T` - qr_TKurt(:) ! Kurtosis `T` - integer, allocatable, save :: qi_icCos(:), & ! col index of CooCsr - qi_irCsr(:) ! row begining index of - ! Csr sparse matrix - real, allocatable, save :: qr_sumQR(:), & ! Σ over Q, R - qr_sumNP(:, :) ! Σ over P -! - integer, allocatable, save :: qi_bind(:, :) ! Bilinear interp. (index and - real, allocatable, save :: qr_bwgh(:, :) ! weight) - real, allocatable, save :: qr_bdry(:) ! Boundary weight - real, allocatable, save :: qr_wn1(:) ! wavenumber k(nk) -!/ -!/ ------------------------------------------------------------------- / - contains -!/ ------------------------------------------------------------------- / -!/ [Part 1] -!/ - function QFunc(kx, ky) -!/ -!/ 19-Dec-2011 : Origination. ( O. Gramstad ) -!/ -!/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) -!/ -! 1. Purpose: Define q = ω^2 / g (i.e., q in K94 & J09) -! -! 2. Method: -! For wind-generated ocean surface waves, the dispersion relation -! reads -! ω^2 = g k tanh(kd), -! where g is the gravtional acceleration, ω is the radian frequency, -! d is the water depth. Hence, -! -! / k = √(k_x**2. + k_y**2.) for deep-water -! q = | -! \ k tanh(kd) for finite-deep water (e.g., -! d < 2500.) -! -!/ - implicit none -! - real, intent(in) :: kx, ky ! x, y components of wavenumber - ! vector (kx, ky) - real :: QFunc ! Returned function -!/ - QFunc = sqrt(kx*kx + ky*ky) ! deep-water case (q = k) -! -! Odin used qr_dmax = 2500. -! - if (qr_depth > qr_eps .and. qr_depth < qr_dmax) then - QFunc = QFunc * tanh(QFunc * qr_depth) ! finite-deep - end if -! - return -!/ - end function QFunc -!/ -!/ ------------------------------------------------------------------- / -!/ - function VpFunc(k0x, k0y, k1x, k1y, k2x, k2y) -!/ -!/ 19-Dec-2011: Origination. ( O. Gramstad ) -!/ -!/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) -!/ -!/ -! 1. Purpose: -! Calculate the second-order coefficient V^{(+)}_{1, 2, 3} of J09, -! which corresponds to U^{(3)}_{0, 1, 2} of K94. -! -! ◆ V^{(+)}_{1, 2, 3} differs from U^{(3)}_{0, 1, 2} by a factor -! of 1/2π --- this is because the wave spectrum F(k) used in K94 -! and J09 differ by a fator of (1/2π)^2. -! -!/ - implicit none -! - real, intent(in) :: k0x, k0y, k1x, k1y, k2x, k2y ! 3 waves - real :: VpFunc ! V^{(+)}_{1, 2, 3} -! - real :: q0, q1, q2 ! q for 3 waves -!/ -! Call Q function here - q0 = QFunc(k0x, k0y) - q1 = QFunc(k1x, k1y) - q2 = QFunc(k2x, k2y) -! -! Odin has ignored √g here because it will be absorbed/vanish when we -! calculate the kernel function T. I, however, included √g here for -! clarity. -! V^{(+)}_{1, 2, 3} -! - VpFunc = sqrt(1.0/32.0) * ( & - (k0x*k1x + k0y*k1y + q0*q1) * sqrt(sqrt(qr_grav*q2 / (q0*q1)))& - + (k0x*k2x + k0y*k2y + q0*q2) * sqrt(sqrt(qr_grav*q1 / (q0*q2)))& - + (k1x*k2x + k1y*k2y + q1*q2) * sqrt(sqrt(qr_grav*q0 / (q1*q2)))) -! - return -!/ - end function VpFunc -!/ -!/ ------------------------------------------------------------------- / -!/ - function VmFunc(k0x, k0y, k1x, k1y, k2x, k2y) -!/ -!/ 19-Dec-2011 : Origination. ( O. Gramstad ) -!/ -!/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) -!/ -! 1. Purpose: -! Calculate the second-order coefficient V^{(-)}_{1, 2, 3} of J09, -! which corresponds to U^{(1)}_{0, 1, 2} of K94. -! -! ◆ V^{(-)}_{1, 2, 3} differs from U^{(1)}_{0, 1, 2} by a factor -! of 1/2π -! -!/ - implicit none -! - real, intent(in) :: k0x, k0y, k1x, k1y, k2x, k2y ! 3 waves - real :: VmFunc ! V^{(-)}_{1, 2, 3} -! - real :: q0, q1, q2 ! q for 3 waves -!/ -! Call Q function here - q0 = QFunc(k0x, k0y) - q1 = QFunc(k1x, k1y) - q2 = QFunc(k2x, k2y) -! -! V^{(-)}_{1, 2, 3} -! - VmFunc = sqrt(1.0/32.0) * ( & - (k0x*k1x + k0y*k1y - q0*q1) * sqrt(sqrt(qr_grav*q2 / (q0*q1)))& - + (k0x*k2x + k0y*k2y - q0*q2) * sqrt(sqrt(qr_grav*q1 / (q0*q2)))& - + (k1x*k2x + k1y*k2y + q1*q2) * sqrt(sqrt(qr_grav*q0 / (q1*q2)))) -! - return -!/ - end function VmFunc -!/ -!/ ------------------------------------------------------------------- / -!/ - function UFunc(k0x, k0y, k1x, k1y, k2x, k2y, k3x, k3y) -!/ -!/ 19-Dec-2011 : Origination. ( O. Gramstad ) -!/ -!/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) -!/ -! 1. Purpose: -! Calculate the intermediate quantity (i.e., U_{1, 2, 3, 4} in J09, -! V_{0, 1, 2, 3} in K94) for the third-order coefficient (i.e., -! W^{(2)}_{1, 2, 3, 4} in J09, V^{(2)}_{0, 1, 2, 3} in K94). -! -! ◆ U_{1, 2, 3, 4} differs from V_{0, 1, 2, 3} by a factor of -! (1/2π)^2. -! -!/ - implicit none -! - real, intent(in) :: k0x, k0y, k1x, k1y, & - k2x, k2y, k3x, k3y ! 4 waves - real :: UFunc ! U_{1, 2, 3, 4} -! - real :: q0, q1, q2, q3 ! q for 4 waves -!/ -! Call Q function here - q0 = QFunc(k0x, k0y) - q1 = QFunc(k1x, k1y) - q2 = QFunc(k2x, k2y) - q3 = QFunc(k3x, k3y) -! -! U_{1, 2, 3, 4} -! - UFunc = (1.0/16.0) * sqrt(sqrt(q2*q3 / (q0*q1))) * & - (2.0*((k0x*k0x + k0y*k0y) * q1 + (k1x*k1x + k1y*k1y) * q0)-& - q0*q1*( QFunc(k0x+k2x, k0y+k2y) + QFunc(k1x+k2x, k1y+k2y)+& - QFunc(k0x+k3x, k0y+k3y) + QFunc(k1x+k3x, k1y+k3y) )) -! - return -!/ - end function UFunc -!/ -!/ ------------------------------------------------------------------- / -!/ - function TFunc(k0x, k0y, k1x, k1y, k2x, k2y, k3x, k3y) -!/ -!/ 19-Dec-2011 : Origination. ( O. Gramstad ) -!/ -!/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) -!/ -! 1. Purpose: -! Calculate the Kernel function for the four-wave interaction, i.e., -! (T_{1, 2, 3, 4}, \widetilde{V}^{(2)}_{0, 1, 2, 3} in K94). -! ◆ T from J09 and K94 differ by a factor of (1/2π)^2. -! -! Odin's comment: -! Kernel function for all combination that are not Stokes correction. -! I.e. n0 != n2 and n0 != n3 -!/ - implicit none -! - real, intent(in) :: k0x, k0y, k1x, k1y, & - k2x, k2y, k3x, k3y ! 4 waves - real :: TFunc ! T_{1, 2, 3, 4} -! -! Virtual-state interaction: two free waves generate a virtual state -! consisting of bound waves, which then decays into a different set of -! free waves (see J09) -! - real :: om0, om1, om2, om3, & ! ω for 4 waves - om02, & ! ω_{0-2} - om13, & ! ω_{1-3} - om12, & ! ω_{1-2} - om03, & ! ω_{0-3} - om0p1, & ! ω_{0+1} - om2p3 ! ω_{2+3} -! - real :: L14, L23, L56, & - W ! W^{(2)}_{1, 2, 3, 4} in J09 - ! or - ! V^{(2)}_{0, 1, 2, 3} in K94 -!/ -! Initilization - om0p1 = 0. - om2p3 = 0. - W = 0. - L14 = 0. - L23 = 0. - L56 = 0. -! -! Get ω from q: q = ω^2 / g → ω = √(qg) -! Odin has ignored √g here because it will be absorbed/vanish when we -! calculate the kernel function T (V / ω). I, however, included √g here for -! clarity. -! -! ω for four free waves - om0 = sqrt(qr_grav * QFunc(k0x, k0y)) - om1 = sqrt(qr_grav * QFunc(k1x, k1y)) - om2 = sqrt(qr_grav * QFunc(k2x, k2y)) - om3 = sqrt(qr_grav * QFunc(k3x, k3y)) -! -! ω for other combined waves -! - om02 = sqrt(qr_grav * QFunc(k0x-k2x, k0y-k2y)) - om13 = sqrt(qr_grav * QFunc(k1x-k3x, k1y-k3y)) - om12 = sqrt(qr_grav * QFunc(k1x-k2x, k1y-k2y)) - om03 = sqrt(qr_grav * QFunc(k0x-k3x, k0y-k3y)) -! - if (abs(k0x+k1x) > qr_eps .or. abs(k0y+k1y) > qr_eps) then -! k₀ + k₁ = k₂ + k₃ = 0., ω_{0+1} = 0., -! V^{(-)}_{0+1, 0, 1} ~ 1/ω_{0+1} = NaN, L56 = NaN - om0p1 = sqrt(qr_grav * QFunc(k0x+k1x, k0y+k1y)) - om2p3 = sqrt(qr_grav * QFunc(k2x+k3x, k2y+k3y)) - end if -! -! W^{(2)}_{1, 2, 3, 4} [Call U function here] for direct interaction -! - W = UFunc(-k0x, -k0y, -k1x, -k1y, k2x, k2y, k3x, k3y) + & - UFunc( k2x, k2y, k3x, k3y, -k0x, -k0y, -k1x, -k1y) - & - UFunc( k2x, k2y, -k1x, -k1y, -k0x, -k0y, k3x, k3y) - & - UFunc(-k0x, -k0y, k2x, k2y, -k1x, -k1y, k3x, k3y) - & - UFunc(-k0x, -k0y, k3x, k3y, k2x, k2y, -k1x, -k1y) - & - UFunc( k3x, k3y, -k1x, -k1y, k2x, k2y, -k0x, -k0y) -! -! First & Fourth lines for virtual-state interaction in J09 -! - L14 = VmFunc(k0x, k0y, k2x, k2y, k0x-k2x, k0y-k2y) * & - VmFunc(k3x, k3y, k1x, k1y, k3x-k1x, k3y-k1y) * & - (1.0/(om2 + om02 - om0) + 1.0/(om1 + om13 - om3)) + & - VmFunc(k1x, k1y, k3x, k3y, k1x-k3x, k1y-k3y) * & - VmFunc(k2x, k2y, k0x, k0y, k2x-k0x, k2y-k0y) * & - (1.0/(om3 + om13 - om1) + 1.0/(om0 + om02 - om2)) -! -! Second & Third lines for virtual-state interaction in J09 -! - L23 = VmFunc(k1x, k1y, k2x, k2y, k1x-k2x, k1y-k2y) * & - VmFunc(k3x, k3y, k0x, k0y, k3x-k0x, k3y-k0y) * & - (1.0/(om2 + om12 - om1) + 1.0/(om0 + om03 - om3)) + & - VmFunc(k0x, k0y, k3x, k3y, k0x-k3x, k0y-k3y) * & - VmFunc(k2x, k2y, k1x, k1y, k2x-k1x, k2y-k1y) * & - (1.0/(om3 + om03 - om0) + 1.0/(om1 + om12 - om2)) -! -! Fifth & Sixth lines for virtual-state interaction in J09 -! - if (abs(k0x+k1x) > qr_eps .or. abs(k0y+k1y) > qr_eps) then -! k₁ + k₂ = k₃ + k₄ = 0., ω_{1+2} = 0., -! V^{(-)}_{1+2, 1, 2} ~ 1/ω_{1+2} = NaN, L56 = NaN - L56 = VmFunc(k0x+k1x, k0y+k1y, k0x, k0y, k1x, k1y) * & - VmFunc(k2x+k3x, k2y+k3y, k2x, k2y, k3x, k3y) * & - (1.0/(om0p1 - om0 - om1) + 1.0/(om2p3 - om2 - om3)) + & - VpFunc(-k0x-k1x, -k0y-k1y, k0x, k0y, k1x, k1y) * & - VpFunc(-k2x-k3x, -k2y-k3y, k2x, k2y, k3x, k3y) * & - (1.0/(om0p1 + om0 + om1) + 1.0/(om2p3 + om2 + om3)) - end if -! -! T_{1, 2, 3, 4} -! - TFunc = W - L14 - L23 - L56 -! - return -!/ - end function TFunc -!/ -!/ ------------------------------------------------------------------- / -!/ [Part 2] -!/ - subroutine FindQuartetNumber(ns, kx, ky, om, oml, nnz) -!/ -!/ 19-Dec-2011 : Origination. ( O. Gramstad ) -!/ -!/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) -!/ 02-Apr-2020 : Boundary conditions (< kmin, > kmax)( Q. Liu ) -!/ -! 1. Purpose: -! Find the total number of quartets (resonant and quasi/near-resonant -! four waves) satisfying the criteria below: -! -! 1) \vec{k₁} + \vec{k₂} = \vec{k₃} + \vec{k₄} -! -! 2) Δω = |ω₁ + ω₂ - ω₃ - ω₄| <= λc \min(ω₁, ω₂, ω₃, ω₄) -! - that is, quartets far from the resonance is excluded for -! saving the computational cost. -! -! 3) For a given 2D frequency-direction grid (k_i, θ_j, i = 1, ..., -! NK, j = 1, ..., NTH) consisting of NS points (NS = NK * NTH), -! we will first reshape the 2D spectral grid (k_i, θ_j) -! into a 1D wavenumber vector (k_{xl}, k_{yl}, l = 1, ..., NS). -! Afterwards, we should have -! 3.a) l₂ >= l₁ -! 3.b) l₃ ≠ l₁, l₃ ≠ l₂ (otherwise the third and fourth wave -! components will be the same as the -! first and second) -! 3.c) l₄ >= l₃ -! 3.d) l₄ ≠ l₁, l₄ ≠ l₂ -! 3.e) k₄ >= k_{min}, k₄ <= k_{max} -! -! Note that `l` here only denotes the index of a specific wave -! component inside the 1D wavenumber vector array. For k₄, its -! index l₄ is not exact, and is just approximated by the index -! of its closest wave component. -! -! 4) If we store the located quartets in a 2D large sparse matrix, -! which can be organized as -! |K K K | -! |∩ ∩ ∩ | -! |3 q l₃| 1 2 . . . N 1 2 . . . N . . . . . . 1 2 . . . N -! |4 r l₄| 1 1 1 1 1 1 2 2 2 2 2 2 . . . . . . N N N N N N -! |∪ ∪ ∪ | -! ------- -! K {1 2} -! K {n p} -! K {l₁l₂} -! ------- -! 1 1 -! 2 1 (2,1,N,3) ✗⁴ ✗²(2,1,3,N) -! . 1 col > row → ▲ -! . 1 -! . 1 -! N 1 -! 1 2 (1,2,N,3) ✗³ [★ (1,2,3,N)] -! 2 2 -! . 2 -! . 2 ⊚ ← row = l₁ + (l₂ - 1) * NS -! . 2 ↑ -! N 2 col = l₃ + (l₄ - 1) * NS -! . . -! . . -! . . -! . . -! . . -! . . (N,3,2,1) ✓⁴ ✓³(N,3,1,2) -! 1 N ▼ ← col < row -! 2 N -! . N (3,N,2,1) ✓² ☆ (3,N,1,2) -! . N -! . N -! N N -! -! where `N` shown above denotes `NS`, not `NK`, therefore the shape -! of this large sparse matrix is (NS*NS, NS*NS). -! -! Only quartets with col > row (highlighted by ▲ , i.e., -! --------- -! elements in the upper trianglar matrix) are selected because, -! for example, ★ (1, 2, 3, NS) & ☆ (3, NS, 1, 2) essentially -! refer to the same quartet. -! -! To sum up, criteria 1) and 2) are kinetic, whereas 3) and 4) are -! enforced to avoid duplicating quartets since -! ★ (k₁, k₂, k₃, k₄) -! -! & [symmetric] -! ✗² (k₂, k₁, k₃, k₄) ← filterd by 3.a) -! ✗³ (k₁, k₂, k₄, k₃) ← filterd by 3.c) -! ✗⁴ (k₂, k₁, k₄, k₃) ← filterd by 3.a) and 3.c) -! -! & [antisymmetric] -! ☆ (k₃, k₄, k₁, k₂) ← filterd by 4) -! ✓² (k₃, k₄, k₂, k₁) -! ✓³ (k₄, k₃, k₁, k₂) -! ✓⁴ (k₄, k₃, k₂, k₁) -! -! are essentially the same. -! -! ◆ criteria 3.b) and 3.d) exclude two quartets: -! / k₁ = k₃, k₂ = k₄ (k₁, k₂, k₁, k₂) -! \ k₁ = k₄, k₂ = k₃ (k₁, k₂, k₂, k₁) -! → singular points for the nonlinear transfer integral as -! T_{1, 2, 1, 2} or T_{1, 2, 2, 1} ~ 1 / 0 = NaN -! -! van Vledder (2006, p. 231) argued that the first quadruplet had -! negligible contribution to the total transfer rate. Similarly, -! for the symmetric reason, the contribution from the second -! quadruplet is also very limited. -! -! ◆ We should keep in mind that the Snl term for wave component -! 3 in ★ (i.e., k₃) and in ☆ (i.e., k₁) are the same. -! -! ◆ Although the other 7 quartets are not counted here, their -! contributions to the nonlinear transfer rates should not be -! ignored as the interval of the 6D integration starts from -! -∞ and ends at +∞ ! -! -! More details can be found in Appendix of LGB21. -! -! See also references: -! Hasselmann and Hasselmann (1981) Exact-NL/DIA report -! Hasselmann and Hasselmann (1985), JPO, 15, 1369 - 1377. -! Annenkov and Shrira (2015), JPO, 45, 807-812 -! -!/ - implicit none -! - integer, intent(in) :: ns ! length of 1D wavenumber - ! vector, ns = nk * nth - real, intent(in) :: kx(ns), & - ky(ns), & ! (kx, ky) components - om(ns) ! ω or σ - real, intent(in) :: oml ! cut-off value λc for the - ! quasi-resonant criterion 2) -! - integer(kind=8), intent(out) & - :: nnz ! total number of quartets - ! i.e., nonzero values - ! in the large-sparse matrix - ! illustrated above -! -! Local parameters - real :: k(ns) ! scalar/mag k - integer :: i1, i2, i3, i4, row, col - real :: k4x, k4y, k4, om4, kmin, kmax, dom -!/ -! Scalar wavenumber (i.e., magnitude) - k = sqrt(kx*kx + ky*ky) - kmin = minval(k) - kmax = maxval(k) -! -! Boundary conditions: include k4 beyond kmin & kmax - if (qi_interp .eq. 1 .and. qi_bound .eq. 1) then - kmin = kmin / 9. ! 1/3 fmax - kmax = kmax * 9. ! 3 fmax - end if -! -! Start to find the quartets: \vec{k_j}, j = 1, 2, 3 are chosen at the -! grid points, and \vec_{k_4} is found by -! \vec{k_4} = \vec{k_1} + \vec{k_2} - \vec{k_3} -! - nnz = 0 -! - do i1 = 1, ns -! criterion 3.a) ← starting from i1 - do i2 = i1, ns - do i3 = 1, ns -! criterion 3.b) - if (i3 .ne. i1 .and. i3 .ne. i2) then -! criterion 1) - k4x = kx(i1) + kx(i2) - kx(i3) - k4y = ky(i1) + ky(i2) - ky(i3) - k4 = sqrt(k4x*k4x + k4y*k4y) -! -! wavenumber k4 falls outside the grid (criterion 3.e) - if (k4 >= kmin .and. k4 <= kmax) then -! ω = √(qg) & Δω - om4 = sqrt(qr_grav * QFunc(k4x, k4y)) - dom = abs(om(i1) + om(i2) - om(i3) - om4) / & - min(om(i1), om(i2), om(i3), om4) -! criterion 2) - if (oml <= qr_eps .or. dom <= oml) then - i4 = minloc((kx - k4x)*(kx - k4x) + & - (ky - k4y)*(ky - k4y), 1) -! criterion 3.d) - if (i4 .ne. i1 .and. i4 .ne. i2) then -! criterion 3.c) - if (i4 >= i3) then - row = i1 + ns * (i2-1) - col = i3 + ns * (i4-1) -! criterion 4) - if (col > row) then - nnz = nnz + 1 - end if - end if - end if - end if - end if + real, parameter :: qr_grav = 9.806 ! Gravational acc (m/s^2) + real, parameter :: qr_pi = 3.141592653589793 ! π + real, parameter :: qr_tpi = 2 * qr_pi ! π * 2 + real, parameter :: qr_dmax = 3000.0 ! Maximum allowed water + complex, parameter :: qc_iu = (0.0, 1.0) ! complex unit `i` + ! + character(len=100) :: qs_cfg ! File name for quartet/kernel + ! + real, allocatable, save :: qr_kx(:), qr_ky(:), & ! kx, ky (2D grid → 1D vector) + qr_dk(:), qr_om(:) ! Δ\vec{k}, ω, + ! + integer(kind=8) :: qi_nnz ! # of quartets + integer :: qi_nrsm ! # of rows of SMat + integer, allocatable, save :: qi_NN(:), qi_PP(:), & ! Index for Quartets + qi_QQ(:), qi_RR(:) + real, allocatable, save :: qr_k4x(:), qr_k4y(:), & ! kx, ky, ω for 4th wave + qr_om4(:) + real, allocatable, save :: qr_dom(:), & ! Δω + qr_TKern(:), & ! Kernel `T` + qr_TKurt(:) ! Kurtosis `T` + integer, allocatable, save :: qi_icCos(:), & ! col index of CooCsr + qi_irCsr(:) ! row begining index of + ! Csr sparse matrix + real, allocatable, save :: qr_sumQR(:), & ! Σ over Q, R + qr_sumNP(:, :) ! Σ over P + ! + integer, allocatable, save :: qi_bind(:, :) ! Bilinear interp. (index and + real, allocatable, save :: qr_bwgh(:, :) ! weight) + real, allocatable, save :: qr_bdry(:) ! Boundary weight + real, allocatable, save :: qr_wn1(:) ! wavenumber k(nk) + !/ + !/ ------------------------------------------------------------------- / +contains + !/ ------------------------------------------------------------------- / + !/ [Part 1] + !/ + function QFunc(kx, ky) + !/ + !/ 19-Dec-2011 : Origination. ( O. Gramstad ) + !/ + !/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) + !/ + ! 1. Purpose: Define q = ω^2 / g (i.e., q in K94 & J09) + ! + ! 2. Method: + ! For wind-generated ocean surface waves, the dispersion relation + ! reads + ! ω^2 = g k tanh(kd), + ! where g is the gravtional acceleration, ω is the radian frequency, + ! d is the water depth. Hence, + ! + ! / k = √(k_x**2. + k_y**2.) for deep-water + ! q = | + ! \ k tanh(kd) for finite-deep water (e.g., + ! d < 2500.) + ! + !/ + implicit none + ! + real, intent(in) :: kx, ky ! x, y components of wavenumber + ! vector (kx, ky) + real :: QFunc ! Returned function + !/ + QFunc = sqrt(kx*kx + ky*ky) ! deep-water case (q = k) + ! + ! Odin used qr_dmax = 2500. + ! + if (qr_depth > qr_eps .and. qr_depth < qr_dmax) then + QFunc = QFunc * tanh(QFunc * qr_depth) ! finite-deep + end if + ! + return + !/ + end function QFunc + !/ + !/ ------------------------------------------------------------------- / + !/ + function VpFunc(k0x, k0y, k1x, k1y, k2x, k2y) + !/ + !/ 19-Dec-2011: Origination. ( O. Gramstad ) + !/ + !/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) + !/ + !/ + ! 1. Purpose: + ! Calculate the second-order coefficient V^{(+)}_{1, 2, 3} of J09, + ! which corresponds to U^{(3)}_{0, 1, 2} of K94. + ! + ! ◆ V^{(+)}_{1, 2, 3} differs from U^{(3)}_{0, 1, 2} by a factor + ! of 1/2π --- this is because the wave spectrum F(k) used in K94 + ! and J09 differ by a fator of (1/2π)^2. + ! + !/ + implicit none + ! + real, intent(in) :: k0x, k0y, k1x, k1y, k2x, k2y ! 3 waves + real :: VpFunc ! V^{(+)}_{1, 2, 3} + ! + real :: q0, q1, q2 ! q for 3 waves + !/ + ! Call Q function here + q0 = QFunc(k0x, k0y) + q1 = QFunc(k1x, k1y) + q2 = QFunc(k2x, k2y) + ! + ! Odin has ignored √g here because it will be absorbed/vanish when we + ! calculate the kernel function T. I, however, included √g here for + ! clarity. + ! V^{(+)}_{1, 2, 3} + ! + VpFunc = sqrt(1.0/32.0) * ( & + (k0x*k1x + k0y*k1y + q0*q1) * sqrt(sqrt(qr_grav*q2 / (q0*q1)))& + + (k0x*k2x + k0y*k2y + q0*q2) * sqrt(sqrt(qr_grav*q1 / (q0*q2)))& + + (k1x*k2x + k1y*k2y + q1*q2) * sqrt(sqrt(qr_grav*q0 / (q1*q2)))) + ! + return + !/ + end function VpFunc + !/ + !/ ------------------------------------------------------------------- / + !/ + function VmFunc(k0x, k0y, k1x, k1y, k2x, k2y) + !/ + !/ 19-Dec-2011 : Origination. ( O. Gramstad ) + !/ + !/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) + !/ + ! 1. Purpose: + ! Calculate the second-order coefficient V^{(-)}_{1, 2, 3} of J09, + ! which corresponds to U^{(1)}_{0, 1, 2} of K94. + ! + ! ◆ V^{(-)}_{1, 2, 3} differs from U^{(1)}_{0, 1, 2} by a factor + ! of 1/2π + ! + !/ + implicit none + ! + real, intent(in) :: k0x, k0y, k1x, k1y, k2x, k2y ! 3 waves + real :: VmFunc ! V^{(-)}_{1, 2, 3} + ! + real :: q0, q1, q2 ! q for 3 waves + !/ + ! Call Q function here + q0 = QFunc(k0x, k0y) + q1 = QFunc(k1x, k1y) + q2 = QFunc(k2x, k2y) + ! + ! V^{(-)}_{1, 2, 3} + ! + VmFunc = sqrt(1.0/32.0) * ( & + (k0x*k1x + k0y*k1y - q0*q1) * sqrt(sqrt(qr_grav*q2 / (q0*q1)))& + + (k0x*k2x + k0y*k2y - q0*q2) * sqrt(sqrt(qr_grav*q1 / (q0*q2)))& + + (k1x*k2x + k1y*k2y + q1*q2) * sqrt(sqrt(qr_grav*q0 / (q1*q2)))) + ! + return + !/ + end function VmFunc + !/ + !/ ------------------------------------------------------------------- / + !/ + function UFunc(k0x, k0y, k1x, k1y, k2x, k2y, k3x, k3y) + !/ + !/ 19-Dec-2011 : Origination. ( O. Gramstad ) + !/ + !/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) + !/ + ! 1. Purpose: + ! Calculate the intermediate quantity (i.e., U_{1, 2, 3, 4} in J09, + ! V_{0, 1, 2, 3} in K94) for the third-order coefficient (i.e., + ! W^{(2)}_{1, 2, 3, 4} in J09, V^{(2)}_{0, 1, 2, 3} in K94). + ! + ! ◆ U_{1, 2, 3, 4} differs from V_{0, 1, 2, 3} by a factor of + ! (1/2π)^2. + ! + !/ + implicit none + ! + real, intent(in) :: k0x, k0y, k1x, k1y, & + k2x, k2y, k3x, k3y ! 4 waves + real :: UFunc ! U_{1, 2, 3, 4} + ! + real :: q0, q1, q2, q3 ! q for 4 waves + !/ + ! Call Q function here + q0 = QFunc(k0x, k0y) + q1 = QFunc(k1x, k1y) + q2 = QFunc(k2x, k2y) + q3 = QFunc(k3x, k3y) + ! + ! U_{1, 2, 3, 4} + ! + UFunc = (1.0/16.0) * sqrt(sqrt(q2*q3 / (q0*q1))) * & + (2.0*((k0x*k0x + k0y*k0y) * q1 + (k1x*k1x + k1y*k1y) * q0)-& + q0*q1*( QFunc(k0x+k2x, k0y+k2y) + QFunc(k1x+k2x, k1y+k2y)+& + QFunc(k0x+k3x, k0y+k3y) + QFunc(k1x+k3x, k1y+k3y) )) + ! + return + !/ + end function UFunc + !/ + !/ ------------------------------------------------------------------- / + !/ + function TFunc(k0x, k0y, k1x, k1y, k2x, k2y, k3x, k3y) + !/ + !/ 19-Dec-2011 : Origination. ( O. Gramstad ) + !/ + !/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) + !/ + ! 1. Purpose: + ! Calculate the Kernel function for the four-wave interaction, i.e., + ! (T_{1, 2, 3, 4}, \widetilde{V}^{(2)}_{0, 1, 2, 3} in K94). + ! ◆ T from J09 and K94 differ by a factor of (1/2π)^2. + ! + ! Odin's comment: + ! Kernel function for all combination that are not Stokes correction. + ! I.e. n0 != n2 and n0 != n3 + !/ + implicit none + ! + real, intent(in) :: k0x, k0y, k1x, k1y, & + k2x, k2y, k3x, k3y ! 4 waves + real :: TFunc ! T_{1, 2, 3, 4} + ! + ! Virtual-state interaction: two free waves generate a virtual state + ! consisting of bound waves, which then decays into a different set of + ! free waves (see J09) + ! + real :: om0, om1, om2, om3, & ! ω for 4 waves + om02, & ! ω_{0-2} + om13, & ! ω_{1-3} + om12, & ! ω_{1-2} + om03, & ! ω_{0-3} + om0p1, & ! ω_{0+1} + om2p3 ! ω_{2+3} + ! + real :: L14, L23, L56, & + W ! W^{(2)}_{1, 2, 3, 4} in J09 + ! or + ! V^{(2)}_{0, 1, 2, 3} in K94 + !/ + ! Initilization + om0p1 = 0. + om2p3 = 0. + W = 0. + L14 = 0. + L23 = 0. + L56 = 0. + ! + ! Get ω from q: q = ω^2 / g → ω = √(qg) + ! Odin has ignored √g here because it will be absorbed/vanish when we + ! calculate the kernel function T (V / ω). I, however, included √g here for + ! clarity. + ! + ! ω for four free waves + om0 = sqrt(qr_grav * QFunc(k0x, k0y)) + om1 = sqrt(qr_grav * QFunc(k1x, k1y)) + om2 = sqrt(qr_grav * QFunc(k2x, k2y)) + om3 = sqrt(qr_grav * QFunc(k3x, k3y)) + ! + ! ω for other combined waves + ! + om02 = sqrt(qr_grav * QFunc(k0x-k2x, k0y-k2y)) + om13 = sqrt(qr_grav * QFunc(k1x-k3x, k1y-k3y)) + om12 = sqrt(qr_grav * QFunc(k1x-k2x, k1y-k2y)) + om03 = sqrt(qr_grav * QFunc(k0x-k3x, k0y-k3y)) + ! + if (abs(k0x+k1x) > qr_eps .or. abs(k0y+k1y) > qr_eps) then + ! k₀ + k₁ = k₂ + k₃ = 0., ω_{0+1} = 0., + ! V^{(-)}_{0+1, 0, 1} ~ 1/ω_{0+1} = NaN, L56 = NaN + om0p1 = sqrt(qr_grav * QFunc(k0x+k1x, k0y+k1y)) + om2p3 = sqrt(qr_grav * QFunc(k2x+k3x, k2y+k3y)) + end if + ! + ! W^{(2)}_{1, 2, 3, 4} [Call U function here] for direct interaction + ! + W = UFunc(-k0x, -k0y, -k1x, -k1y, k2x, k2y, k3x, k3y) + & + UFunc( k2x, k2y, k3x, k3y, -k0x, -k0y, -k1x, -k1y) - & + UFunc( k2x, k2y, -k1x, -k1y, -k0x, -k0y, k3x, k3y) - & + UFunc(-k0x, -k0y, k2x, k2y, -k1x, -k1y, k3x, k3y) - & + UFunc(-k0x, -k0y, k3x, k3y, k2x, k2y, -k1x, -k1y) - & + UFunc( k3x, k3y, -k1x, -k1y, k2x, k2y, -k0x, -k0y) + ! + ! First & Fourth lines for virtual-state interaction in J09 + ! + L14 = VmFunc(k0x, k0y, k2x, k2y, k0x-k2x, k0y-k2y) * & + VmFunc(k3x, k3y, k1x, k1y, k3x-k1x, k3y-k1y) * & + (1.0/(om2 + om02 - om0) + 1.0/(om1 + om13 - om3)) + & + VmFunc(k1x, k1y, k3x, k3y, k1x-k3x, k1y-k3y) * & + VmFunc(k2x, k2y, k0x, k0y, k2x-k0x, k2y-k0y) * & + (1.0/(om3 + om13 - om1) + 1.0/(om0 + om02 - om2)) + ! + ! Second & Third lines for virtual-state interaction in J09 + ! + L23 = VmFunc(k1x, k1y, k2x, k2y, k1x-k2x, k1y-k2y) * & + VmFunc(k3x, k3y, k0x, k0y, k3x-k0x, k3y-k0y) * & + (1.0/(om2 + om12 - om1) + 1.0/(om0 + om03 - om3)) + & + VmFunc(k0x, k0y, k3x, k3y, k0x-k3x, k0y-k3y) * & + VmFunc(k2x, k2y, k1x, k1y, k2x-k1x, k2y-k1y) * & + (1.0/(om3 + om03 - om0) + 1.0/(om1 + om12 - om2)) + ! + ! Fifth & Sixth lines for virtual-state interaction in J09 + ! + if (abs(k0x+k1x) > qr_eps .or. abs(k0y+k1y) > qr_eps) then + ! k₁ + k₂ = k₃ + k₄ = 0., ω_{1+2} = 0., + ! V^{(-)}_{1+2, 1, 2} ~ 1/ω_{1+2} = NaN, L56 = NaN + L56 = VmFunc(k0x+k1x, k0y+k1y, k0x, k0y, k1x, k1y) * & + VmFunc(k2x+k3x, k2y+k3y, k2x, k2y, k3x, k3y) * & + (1.0/(om0p1 - om0 - om1) + 1.0/(om2p3 - om2 - om3)) + & + VpFunc(-k0x-k1x, -k0y-k1y, k0x, k0y, k1x, k1y) * & + VpFunc(-k2x-k3x, -k2y-k3y, k2x, k2y, k3x, k3y) * & + (1.0/(om0p1 + om0 + om1) + 1.0/(om2p3 + om2 + om3)) + end if + ! + ! T_{1, 2, 3, 4} + ! + TFunc = W - L14 - L23 - L56 + ! + return + !/ + end function TFunc + !/ + !/ ------------------------------------------------------------------- / + !/ [Part 2] + !/ + subroutine FindQuartetNumber(ns, kx, ky, om, oml, nnz) + !/ + !/ 19-Dec-2011 : Origination. ( O. Gramstad ) + !/ + !/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) + !/ 02-Apr-2020 : Boundary conditions (< kmin, > kmax)( Q. Liu ) + !/ + ! 1. Purpose: + ! Find the total number of quartets (resonant and quasi/near-resonant + ! four waves) satisfying the criteria below: + ! + ! 1) \vec{k₁} + \vec{k₂} = \vec{k₃} + \vec{k₄} + ! + ! 2) Δω = |ω₁ + ω₂ - ω₃ - ω₄| <= λc \min(ω₁, ω₂, ω₃, ω₄) + ! - that is, quartets far from the resonance is excluded for + ! saving the computational cost. + ! + ! 3) For a given 2D frequency-direction grid (k_i, θ_j, i = 1, ..., + ! NK, j = 1, ..., NTH) consisting of NS points (NS = NK * NTH), + ! we will first reshape the 2D spectral grid (k_i, θ_j) + ! into a 1D wavenumber vector (k_{xl}, k_{yl}, l = 1, ..., NS). + ! Afterwards, we should have + ! 3.a) l₂ >= l₁ + ! 3.b) l₃ ≠ l₁, l₃ ≠ l₂ (otherwise the third and fourth wave + ! components will be the same as the + ! first and second) + ! 3.c) l₄ >= l₃ + ! 3.d) l₄ ≠ l₁, l₄ ≠ l₂ + ! 3.e) k₄ >= k_{min}, k₄ <= k_{max} + ! + ! Note that `l` here only denotes the index of a specific wave + ! component inside the 1D wavenumber vector array. For k₄, its + ! index l₄ is not exact, and is just approximated by the index + ! of its closest wave component. + ! + ! 4) If we store the located quartets in a 2D large sparse matrix, + ! which can be organized as + ! |K K K | + ! |∩ ∩ ∩ | + ! |3 q l₃| 1 2 . . . N 1 2 . . . N . . . . . . 1 2 . . . N + ! |4 r l₄| 1 1 1 1 1 1 2 2 2 2 2 2 . . . . . . N N N N N N + ! |∪ ∪ ∪ | + ! ------- + ! K {1 2} + ! K {n p} + ! K {l₁l₂} + ! ------- + ! 1 1 + ! 2 1 (2,1,N,3) ✗⁴ ✗²(2,1,3,N) + ! . 1 col > row → ▲ + ! . 1 + ! . 1 + ! N 1 + ! 1 2 (1,2,N,3) ✗³ [★ (1,2,3,N)] + ! 2 2 + ! . 2 + ! . 2 ⊚ ← row = l₁ + (l₂ - 1) * NS + ! . 2 ↑ + ! N 2 col = l₃ + (l₄ - 1) * NS + ! . . + ! . . + ! . . + ! . . + ! . . + ! . . (N,3,2,1) ✓⁴ ✓³(N,3,1,2) + ! 1 N ▼ ← col < row + ! 2 N + ! . N (3,N,2,1) ✓² ☆ (3,N,1,2) + ! . N + ! . N + ! N N + ! + ! where `N` shown above denotes `NS`, not `NK`, therefore the shape + ! of this large sparse matrix is (NS*NS, NS*NS). + ! + ! Only quartets with col > row (highlighted by ▲ , i.e., + ! --------- + ! elements in the upper trianglar matrix) are selected because, + ! for example, ★ (1, 2, 3, NS) & ☆ (3, NS, 1, 2) essentially + ! refer to the same quartet. + ! + ! To sum up, criteria 1) and 2) are kinetic, whereas 3) and 4) are + ! enforced to avoid duplicating quartets since + ! ★ (k₁, k₂, k₃, k₄) + ! + ! & [symmetric] + ! ✗² (k₂, k₁, k₃, k₄) ← filterd by 3.a) + ! ✗³ (k₁, k₂, k₄, k₃) ← filterd by 3.c) + ! ✗⁴ (k₂, k₁, k₄, k₃) ← filterd by 3.a) and 3.c) + ! + ! & [antisymmetric] + ! ☆ (k₃, k₄, k₁, k₂) ← filterd by 4) + ! ✓² (k₃, k₄, k₂, k₁) + ! ✓³ (k₄, k₃, k₁, k₂) + ! ✓⁴ (k₄, k₃, k₂, k₁) + ! + ! are essentially the same. + ! + ! ◆ criteria 3.b) and 3.d) exclude two quartets: + ! / k₁ = k₃, k₂ = k₄ (k₁, k₂, k₁, k₂) + ! \ k₁ = k₄, k₂ = k₃ (k₁, k₂, k₂, k₁) + ! → singular points for the nonlinear transfer integral as + ! T_{1, 2, 1, 2} or T_{1, 2, 2, 1} ~ 1 / 0 = NaN + ! + ! van Vledder (2006, p. 231) argued that the first quadruplet had + ! negligible contribution to the total transfer rate. Similarly, + ! for the symmetric reason, the contribution from the second + ! quadruplet is also very limited. + ! + ! ◆ We should keep in mind that the Snl term for wave component + ! 3 in ★ (i.e., k₃) and in ☆ (i.e., k₁) are the same. + ! + ! ◆ Although the other 7 quartets are not counted here, their + ! contributions to the nonlinear transfer rates should not be + ! ignored as the interval of the 6D integration starts from + ! -∞ and ends at +∞ ! + ! + ! More details can be found in Appendix of LGB21. + ! + ! See also references: + ! Hasselmann and Hasselmann (1981) Exact-NL/DIA report + ! Hasselmann and Hasselmann (1985), JPO, 15, 1369 - 1377. + ! Annenkov and Shrira (2015), JPO, 45, 807-812 + ! + !/ + implicit none + ! + integer, intent(in) :: ns ! length of 1D wavenumber + ! vector, ns = nk * nth + real, intent(in) :: kx(ns), & + ky(ns), & ! (kx, ky) components + om(ns) ! ω or σ + real, intent(in) :: oml ! cut-off value λc for the + ! quasi-resonant criterion 2) + ! + integer(kind=8), intent(out) & + :: nnz ! total number of quartets + ! i.e., nonzero values + ! in the large-sparse matrix + ! illustrated above + ! + ! Local parameters + real :: k(ns) ! scalar/mag k + integer :: i1, i2, i3, i4, row, col + real :: k4x, k4y, k4, om4, kmin, kmax, dom + !/ + ! Scalar wavenumber (i.e., magnitude) + k = sqrt(kx*kx + ky*ky) + kmin = minval(k) + kmax = maxval(k) + ! + ! Boundary conditions: include k4 beyond kmin & kmax + if (qi_interp .eq. 1 .and. qi_bound .eq. 1) then + kmin = kmin / 9. ! 1/3 fmax + kmax = kmax * 9. ! 3 fmax + end if + ! + ! Start to find the quartets: \vec{k_j}, j = 1, 2, 3 are chosen at the + ! grid points, and \vec_{k_4} is found by + ! \vec{k_4} = \vec{k_1} + \vec{k_2} - \vec{k_3} + ! + nnz = 0 + ! + do i1 = 1, ns + ! criterion 3.a) ← starting from i1 + do i2 = i1, ns + do i3 = 1, ns + ! criterion 3.b) + if (i3 .ne. i1 .and. i3 .ne. i2) then + ! criterion 1) + k4x = kx(i1) + kx(i2) - kx(i3) + k4y = ky(i1) + ky(i2) - ky(i3) + k4 = sqrt(k4x*k4x + k4y*k4y) + ! + ! wavenumber k4 falls outside the grid (criterion 3.e) + if (k4 >= kmin .and. k4 <= kmax) then + ! ω = √(qg) & Δω + om4 = sqrt(qr_grav * QFunc(k4x, k4y)) + dom = abs(om(i1) + om(i2) - om(i3) - om4) / & + min(om(i1), om(i2), om(i3), om4) + ! criterion 2) + if (oml <= qr_eps .or. dom <= oml) then + i4 = minloc((kx - k4x)*(kx - k4x) + & + (ky - k4y)*(ky - k4y), 1) + ! criterion 3.d) + if (i4 .ne. i1 .and. i4 .ne. i2) then + ! criterion 3.c) + if (i4 >= i3) then + row = i1 + ns * (i2-1) + col = i3 + ns * (i4-1) + ! criterion 4) + if (col > row) then + nnz = nnz + 1 end if - end do - end do + end if + end if + end if + end if + end if + end do + end do #ifdef W3_TS - write(*, *) '→ nnz = ', nnz + write(*, *) '→ nnz = ', nnz #endif - end do -!/ - end subroutine FindQuartetNumber -!/ -!/ ------------------------------------------------------------------- / -!/ - subroutine FindQuartetConfig(ns, kx, ky, om, oml, nnz, & - NN, PP, QQ, RR, & - k4x, k4y, om4) -!/ -!/ 19-Dec-2011 : Origination. ( O. Gramstad ) -!/ -!/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) -!/ 02-Apr-2020 : Boundary conditions (< kmin, > kmax)( Q. Liu ) -!/ -! 1. Purpose: -! Find all the quartets that we are interested in. Initially I thought -! we may merge this subroutine and the subroutine above (i.e., -! FindQuartetNumber) in such a way that we first initialize a large -! array like Quartet(HNum), where HNum is a huge integer (something -! like 0.5*NS**4). But it quickly turned out this was a very naive -! idea because for the wavenumber grid (k, θ) used by 3G spectral -! wave models, in general NS~O(10^2-3), then NS^4~O(10^8-12). Thus, -! HNum becomes really very very very huge, and then we may have -! the integer/memory overflow problem. -! -! Based on the above-mentioned, we must split the whole process: -! 1) find the total number of quartets with FindQuartetNumber, `nnz` -! 2) allocate arrays with the known `nnz`, and store the wavenumber -! and ω for k₄ -! -! For more details, see the header of the subr. FindQuartetNumber. -! -!/ - implicit none -! - integer, intent(in) :: ns ! length of 1D wavenumber - ! vector, ns = nk * nth - real, intent(in) :: kx(ns), & - ky(ns), & ! (kx, ky) components - om(ns) ! ω or σ - real, intent(in) :: oml ! cut-off value λc for the - ! quasi-resonant criterion 2) - integer(kind=8), intent(in) & - :: nnz ! total number of quartets - ! returned from the subr. - ! FindQuartetNumber -! - integer, intent(out) :: NN(nnz), & ! index of k₁ - PP(nnz), & ! k₂ - QQ(nnz), & ! k₃ - RR(nnz) ! k₄ in the 1D - ! wavenumber vector [1 - NS] - real, intent(out) :: k4x(nnz), & - k4y(nnz), & ! x, y comp. of k₄ - om4(nnz) ! ω₄ -! -! Local parameters - real :: k(ns) ! scalar/mag k - integer :: i1, i2, i3, i4, row, col, s - real :: k4xT, k4yT, k4T, om4T, kmin, kmax, dom -!/ -! Scalar wavenumber (i.e., magnitude) - k = sqrt(kx*kx + ky*ky) - kmin = minval(k) - kmax = maxval(k) -! -! Boundary conditions: include k4 beyond kmin & kmax - if (qi_interp .eq. 1 .and. qi_bound .eq. 1) then - kmin = kmin / 9. ! 1/3 fmax - kmax = kmax * 9. ! 3 fmax - end if -! -! Start to find the quartets: \vec{k_j}, j = 1, 2, 3 are chosen at the -! grid points, and \vec_{k_4} is found by -! \vec{k_4} = \vec{k_1} + \vec{k_2} - \vec{k_3} -! -! s: count of quartets. This time the total number of quartets `nnz` is -! already known from `FindQuartetNumber`. -! nnz = 0 - s = 0 -! - do i1 = 1, ns -! criterion 3.a) ← starting from i1 - do i2 = i1, ns - do i3 = 1, ns -! criterion 3.b) - if (i3 .ne. i1 .and. i3 .ne. i2) then -! criterion 1) - k4xT = kx(i1) + kx(i2) - kx(i3) - k4yT = ky(i1) + ky(i2) - ky(i3) - k4T = sqrt(k4xT*k4xT + k4yT*k4yT) -! -! wavenumber k4 falls outside the grid (criterion 3.e) - if (k4T >= kmin .and. k4T <= kmax) then -! ω = √qg & Δω - om4T = sqrt(qr_grav * QFunc(k4xT, k4yT)) - dom = abs(om(i1) + om(i2) - om(i3) - om4T)/& - min(om(i1), om(i2), om(i3), om4T) -! criterion 2) - if (oml <= qr_eps .or. dom <= oml) then - i4 = minloc((kx - k4xT)*(kx - k4xT) + & - (ky - k4yT)*(ky - k4yT), 1) -! criterion 3.d) - if (i4 .ne. i1 .and. i4 .ne. i2) then -! criterion 3.c) - if (i4 >= i3) then - row = i1 + ns * (i2-1) - col = i3 + ns * (i4-1) -! criterion 4) - if (col > row) then -! nnz = nnz + 1 - s = s + 1 ! Find 1 quartet -! - NN(s) = i1 ! Store index - PP(s) = i2 - QQ(s) = i3 - RR(s) = i4 -! - k4x(s) = k4xT ! k₄, ω₄ - k4y(s) = k4yT - om4(s) = om4T -! - end if - end if - end if - end if - end if + end do + !/ + end subroutine FindQuartetNumber + !/ + !/ ------------------------------------------------------------------- / + !/ + subroutine FindQuartetConfig(ns, kx, ky, om, oml, nnz, & + NN, PP, QQ, RR, & + k4x, k4y, om4) + !/ + !/ 19-Dec-2011 : Origination. ( O. Gramstad ) + !/ + !/ 09-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) + !/ 02-Apr-2020 : Boundary conditions (< kmin, > kmax)( Q. Liu ) + !/ + ! 1. Purpose: + ! Find all the quartets that we are interested in. Initially I thought + ! we may merge this subroutine and the subroutine above (i.e., + ! FindQuartetNumber) in such a way that we first initialize a large + ! array like Quartet(HNum), where HNum is a huge integer (something + ! like 0.5*NS**4). But it quickly turned out this was a very naive + ! idea because for the wavenumber grid (k, θ) used by 3G spectral + ! wave models, in general NS~O(10^2-3), then NS^4~O(10^8-12). Thus, + ! HNum becomes really very very very huge, and then we may have + ! the integer/memory overflow problem. + ! + ! Based on the above-mentioned, we must split the whole process: + ! 1) find the total number of quartets with FindQuartetNumber, `nnz` + ! 2) allocate arrays with the known `nnz`, and store the wavenumber + ! and ω for k₄ + ! + ! For more details, see the header of the subr. FindQuartetNumber. + ! + !/ + implicit none + ! + integer, intent(in) :: ns ! length of 1D wavenumber + ! vector, ns = nk * nth + real, intent(in) :: kx(ns), & + ky(ns), & ! (kx, ky) components + om(ns) ! ω or σ + real, intent(in) :: oml ! cut-off value λc for the + ! quasi-resonant criterion 2) + integer(kind=8), intent(in) & + :: nnz ! total number of quartets + ! returned from the subr. + ! FindQuartetNumber + ! + integer, intent(out) :: NN(nnz), & ! index of k₁ + PP(nnz), & ! k₂ + QQ(nnz), & ! k₃ + RR(nnz) ! k₄ in the 1D + ! wavenumber vector [1 - NS] + real, intent(out) :: k4x(nnz), & + k4y(nnz), & ! x, y comp. of k₄ + om4(nnz) ! ω₄ + ! + ! Local parameters + real :: k(ns) ! scalar/mag k + integer :: i1, i2, i3, i4, row, col, s + real :: k4xT, k4yT, k4T, om4T, kmin, kmax, dom + !/ + ! Scalar wavenumber (i.e., magnitude) + k = sqrt(kx*kx + ky*ky) + kmin = minval(k) + kmax = maxval(k) + ! + ! Boundary conditions: include k4 beyond kmin & kmax + if (qi_interp .eq. 1 .and. qi_bound .eq. 1) then + kmin = kmin / 9. ! 1/3 fmax + kmax = kmax * 9. ! 3 fmax + end if + ! + ! Start to find the quartets: \vec{k_j}, j = 1, 2, 3 are chosen at the + ! grid points, and \vec_{k_4} is found by + ! \vec{k_4} = \vec{k_1} + \vec{k_2} - \vec{k_3} + ! + ! s: count of quartets. This time the total number of quartets `nnz` is + ! already known from `FindQuartetNumber`. + ! nnz = 0 + s = 0 + ! + do i1 = 1, ns + ! criterion 3.a) ← starting from i1 + do i2 = i1, ns + do i3 = 1, ns + ! criterion 3.b) + if (i3 .ne. i1 .and. i3 .ne. i2) then + ! criterion 1) + k4xT = kx(i1) + kx(i2) - kx(i3) + k4yT = ky(i1) + ky(i2) - ky(i3) + k4T = sqrt(k4xT*k4xT + k4yT*k4yT) + ! + ! wavenumber k4 falls outside the grid (criterion 3.e) + if (k4T >= kmin .and. k4T <= kmax) then + ! ω = √qg & Δω + om4T = sqrt(qr_grav * QFunc(k4xT, k4yT)) + dom = abs(om(i1) + om(i2) - om(i3) - om4T)/& + min(om(i1), om(i2), om(i3), om4T) + ! criterion 2) + if (oml <= qr_eps .or. dom <= oml) then + i4 = minloc((kx - k4xT)*(kx - k4xT) + & + (ky - k4yT)*(ky - k4yT), 1) + ! criterion 3.d) + if (i4 .ne. i1 .and. i4 .ne. i2) then + ! criterion 3.c) + if (i4 >= i3) then + row = i1 + ns * (i2-1) + col = i3 + ns * (i4-1) + ! criterion 4) + if (col > row) then + ! nnz = nnz + 1 + s = s + 1 ! Find 1 quartet + ! + NN(s) = i1 ! Store index + PP(s) = i2 + QQ(s) = i3 + RR(s) = i4 + ! + k4x(s) = k4xT ! k₄, ω₄ + k4y(s) = k4yT + om4(s) = om4T + ! end if - end do - end do - end do -! -! Check consistency of s and nnz - if (s .ne. nnz) then - write(*, 1001) 'FindQuartetConfig' - call exit(1) - end if -! -! Formats - 1001 FORMAT(/' *** GKE ERROR IN gkeModule : '/ & - ' Subr. ', A, ': The number of Quartet Configs. does not match NNZ!'/) -!/ - end subroutine FindQuartetConfig -!/ -!/ ------------------------------------------------------------------- / -!/ [Part 3] -!/ - subroutine CooCsrInd (nrow, nnz, ir, jc, ind_translate, iao) -!/ -!/ 12-Sep-2012 : Origination. ( version 3.14 ) -!/ Based on coocsr of SPARKIT ( O. Gramstad ) -!/ -!/ 16-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) -!/ -! 1. Purpose: -! It becomes clear from subr. FindQuartetNumber & FindQuartetConfig -! that we are faced with a problem of large sparse matrice when we -! manipulate the huge set of quartets. By sparse matrix we mean -! only a `relatively small number` of its matrix elements are nonzero. -! -! For saving time or memory space, a sparse matrix is usually stored -! in some compressed formats in the computer memory. Two among those -! formats, COO & CSR are relevant here in our application: -! 1) The coordinate format (COO) --- the simplest storage scheme -! For a given sparse matrix `A` (N, N) with NNZ nonzero elements, -! the COO format consists of 3 arrays: -! * a (nnz): real nonzero values of A in `any order` -! * ir(nnz): row indices of these nonzero values -! * jc(nnz): column indices -! -! 2) The Compressed Sparse Row format (CSR) -! The CSR format is the basic format used in SPARSKIT, consisting -! of three arrays as well -! * a (nnz): real nonzero values of A stored row by row from row -! 1 to row N -! * jc(nnz): column indices in `any order` -! * ia(N+1): the index of the first nonzero element at this -! corresponding row in the array a and jc, that is -! ia(i) provides the position in a & jc where the i-th -! row starts. -! -! This subroutine converts the sparse matrix (nrow, nrow) in the COO -! format, as represented by (ir, jc) to the CSR format, as represented -! by (ind_translate, iao). -! -! N.B.: -! This subr. neither needs the real value array in the COO format, -! nor returns the real value array in the CSR format. Alternatively, -! it returns the tranformed index (ind_translate) from COO to CSR. -! With such indices, we have -! *) a_csr = a_coo(ind_translate) -! *) jc_csr = jc_coo(ind_translate) -! -! References: -! Youcef Saad, 1994, SPARSKIT: a basic tool kit for sparse matrix -! compuation (version 2, `coocsr` therein) -! See also Numerical Recipe in Fortran (ch. 2.7, p. 71) -!/ - implicit none -! - integer, intent(in) :: nrow ! # of rows of sparse matrix - integer(kind=8), intent(in) & - :: nnz ! # of nonzero elements - integer, intent(in) :: ir(nnz) ! COO row - integer, intent(in) :: jc(nnz) ! COO col - integer, intent(out) :: ind_translate(nnz) ! indices from COO to CSR - integer, intent(out) :: iao(nrow+1) ! CSR iao -! -! Local parameters - integer :: i, j, k, k0, iad -!/ -! Determine the number of non-zeros in each row (iao(i), i = 1, ..., nrow, -! will be the # of nonzero elements at the i-th row), whereas -! iao(nrow+1) = 0 - iao(1:nrow+1) = 0 - do k = 1, nnz - iao(ir(k)) = iao(ir(k)) + 1 ! row by row - end do -! -! Find the positions that correspond to the first value in each row. -! Now iao(i) is the position where the i-th row starts, and -! iao(nrow+1) = 1 + nnz - k = 1 - do j = 1, nrow+1 - k0 = iao(j) ! num_i, # of nonzero in this row - iao(j) = k ! starting pos - k = k + k0 ! k = Σnum_i, where i <= j - end do -! -! Go through the structure once more. Fill in ind_translate - do k = 1, nnz - i = ir(k) ! coo row - j = jc(k) ! coo col -! -! When i-th row is encountered by the first time, iad = iao(i) denotes -! the starting position for this row. Afterwards, iao(i) is added by 1 -! when i-th row arrives every time. In the end, iao(i) records the -! starting position for the (i+1)-th row. However, the last element of -! iao remains unchanged, i.e., iao(nrow+1) = iao(nrow) = 1 + nnz - iad = iao(i) - ind_translate(iad) = k - iao(i) = iad + 1 - end do -! -! Shift back IAO. - do j = nrow, 1, -1 - iao(j+1) = iao(j) - end do - iao(1) = 1 -! - return -!/ - end subroutine CooCsrInd -!/ -!/ ------------------------------------------------------------------- / -!/ - subroutine ASymSmatTimVec (n, a, ja, ia, x, y, Symb) -!/ -!/ 07-Sep-2012 : Origination. ( version 3.14 ) -!/ Based on amux & atmux of SPARKIT ( O. Gramstad ) -!/ -!/ 16-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) -!/ 19-Feb-2018 : Add `Symb` keyword ( Q. Liu ) -!/ -! 1. Purpose: -! --------> Symb = -1 (antisymmetric) -! Calculate the dot product of an antisymmetric CSR sparse matrix -! and a vector X. -! -! An antisymmetric (skew-symmetric) matrix is a square matrix `B` -! whose transpose equals to its negative, i.e., -! B^T = -B -! -! ◆ Do not be confused by the name of this subr. The coming-in CSR -! sparse matrix `a` is not symmetric or antisymmetric. In our case, -! `a` is a upper triangular sparse matrix, and we are acturally -! calculating the dot product of `a - a^T` and `x`, where -! 'a - a^T' is an antisymmetric matrix due to the symmetry of -! four-wave nonlinear interactions (dN₁/dt = -dN₃/dt). -! -! This operation is in essence the dot product of two common dense -! matrix/vector, such as -! M(n, 1) = A(n, n) * X(n, 1) -! or -! M_{i, 1} = Σa(i, j) * x(j, 1) -! -! For the transposed array A^T, -! N_{i, 1} = Σat(i, j) * x(j, 1) -! = Σ a(j, i) * x(j, 1) -! Alternatively, we can exchange the index of i, j for easy -! understanding: -! N_{j, 1} = Σat(j, i) * x(i, 1) -! = Σ a(i, j) * x(i, 1) -! -! Finally, Y = M - N = A * X - A^T * X -! -! --------> Symb = 1 (Symmetric) -! Same as above but for Y = M + N = A * X + A^T * X -!/ - implicit none -! - integer, intent(in) :: n ! # of rows/cols -! - real, intent(in) :: a(:) ! CSR a (nnz) - integer, intent(in) :: ja(:) ! CSR ja(nnz) - integer, intent(in) :: ia(n+1) ! CSR ia(n+1) -! - real, intent(in) :: x(n) ! vector of the same length - real, intent(out) :: y(n) ! return product y = B * x - real, intent(in) :: Symb ! -1 for minus, 1 for plus -! -! Local parameters - integer :: i, k - real :: t -!/ -! Initilization - y(1:n) = 0.0 -! - do i = 1, n - t = 0.0 - do k = ia(i), ia(i+1)-1 -! -! M_{i, 1} = Σa(i, j) * x(j, 1) - t = t + a(k) * x(ja(k)) -! -!±N_{j, 1} = ±Σa(i, j) * x(i, 1) - y(ja(k)) = y(ja(k)) + Symb * a(k)*x(i) - end do - y(i) = y(i) + t - end do -! The final Y = M ± N = A * x ± A^T * x -! - return -!/ - end subroutine ASymSmatTimVec -!/ -!/ ------------------------------------------------------------------- / -!/ Part 4 -!/ - subroutine PrepKGrid(nk, nth, dpt, sig, th) -!/ -!/ 04-Dec-2018 : Origination. ( Q. Liu ) -!/ 04-Dec-2018 : Based on `z_cmpcg` & `z_wnumb` of serv_xnl4v5.f90 -!/ ( Q. Liu ) -!/ 01-Apr-2019 : Add the option using WAVNU1 ( Q. Liu ) -!/ -! 1. Purpose: -! Compute wave number k for a given discrete frequency grid and water -! depth based on the dispersion relation for the linear wave theory -! ω^2 = gk tanh(kd) -! -! ◆ In WW3, the radian frequency grid ω is invariant. -! -! ◆ It is desired that the GKE module should be independent from WW3 -! as much as possible. So I decided not to directly obtain -! `NK, NTH, SIG, WN, CG, DSII` from WW3 -! -! 2. Method -! ✓ dispopt = 0 -! Finite depth linear dispersion relation, using a Pade approximation -! (Hunt, 1988) [see WRT serv_xnl4v5.f90] -! -! ✓ dispopt = 1 for WAVNU1 -!/ - USE W3DISPMD, ONLY: WAVNU1 -! - implicit none -! - integer, intent(in) :: nk ! # of frequencies - integer, intent(in) :: nth ! # of directions - real, intent(in) :: dpt ! water depth (m) - real, intent(in) :: sig(nk) ! radian frequency σ - real, intent(in) :: th(nth) ! θ (rad) [equally spaced, - ! but may start from non-zero - ! value] -! - integer, parameter :: dispopt = 1 ! dispersion relation -! - integer :: ik, ith, jkth, ns - real :: x, xx, y, omega - real :: k, cg, dsii, angR, dth - real :: esin(nth), ecos(nth) -!/ -! Initialization - ns = nk * nth -! Allocation of qr_kx/ky/dk/om/wn1 was done in PrepKernelIO) - qr_kx = 0. ! ns - qr_ky = 0. - qr_dk = 0. - qr_om = 0. - qr_wn1 = 0. ! nk -! -! Calc Δθ, cosθ, sinθ [θ is equally spaced] - dth = qr_tpi / real(nth) -! - do ith = 1, nth - angR = th(ith) - esin(ith) = sin(angR) - ecos(ith) = cos(angR) -! - if (abs(esin(ith)) .lt. 1.E-5) then - esin(ith) = 0. - if (ecos(ith) .gt. 0.5) then - ecos(ith) = 1. ! θ = 0. - else - ecos(ith) = -1. ! θ = π - end if - end if -! - if (abs(ecos(ith)) .lt. 1.E-5) then - ecos(ith) = 0. - if (esin(ith) .gt. 0.5) then - esin(ith) = 1. ! θ = π/2 - else - esin(ith) = -1. ! θ = π * 3/2 + end if end if + end if end if + end if end do -! - do ik = 1, nk - if (dispopt .eq. 0) then -! Calc k & Cg (`z_cmpcg` & `z_wnumb` of serv_xnl4v5.f90) - omega = sig(ik)**2.0/qr_grav - y = omega*dpt - xx = y*(y+1.0/(1.0+y*(0.66667+y*(0.35550+y*(0.16084+y*(0.06320+y* & - (0.02174+y*(0.00654+y*(0.00171+y*(0.00039+y*0.00011)))))))))) - x = sqrt(xx) - k = x/dpt -! - if(dpt*k > 30.0) then - cg = qr_grav/(2.0*sig(ik)) - else - cg = sig(ik)/k*(0.5+dpt*k/sinh(2.0*dpt*k)) - end if -! - else if (dispopt .eq. 1) then -! Calc k & cg (WAVNU1 from WW3) - call WAVNU1(sig(ik), dpt, k, cg) - end if - qr_wn1(ik) = k ! Store k in qr_wn1 ('ll used for interp.) + end do + end do + ! + ! Check consistency of s and nnz + if (s .ne. nnz) then + write(*, 1001) 'FindQuartetConfig' + call exit(1) + end if + ! + ! Formats +1001 FORMAT(/' *** GKE ERROR IN gkeModule : '/ & + ' Subr. ', A, ': The number of Quartet Configs. does not match NNZ!'/) + !/ + end subroutine FindQuartetConfig + !/ + !/ ------------------------------------------------------------------- / + !/ [Part 3] + !/ + subroutine CooCsrInd (nrow, nnz, ir, jc, ind_translate, iao) + !/ + !/ 12-Sep-2012 : Origination. ( version 3.14 ) + !/ Based on coocsr of SPARKIT ( O. Gramstad ) + !/ + !/ 16-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) + !/ + ! 1. Purpose: + ! It becomes clear from subr. FindQuartetNumber & FindQuartetConfig + ! that we are faced with a problem of large sparse matrice when we + ! manipulate the huge set of quartets. By sparse matrix we mean + ! only a `relatively small number` of its matrix elements are nonzero. + ! + ! For saving time or memory space, a sparse matrix is usually stored + ! in some compressed formats in the computer memory. Two among those + ! formats, COO & CSR are relevant here in our application: + ! 1) The coordinate format (COO) --- the simplest storage scheme + ! For a given sparse matrix `A` (N, N) with NNZ nonzero elements, + ! the COO format consists of 3 arrays: + ! * a (nnz): real nonzero values of A in `any order` + ! * ir(nnz): row indices of these nonzero values + ! * jc(nnz): column indices + ! + ! 2) The Compressed Sparse Row format (CSR) + ! The CSR format is the basic format used in SPARSKIT, consisting + ! of three arrays as well + ! * a (nnz): real nonzero values of A stored row by row from row + ! 1 to row N + ! * jc(nnz): column indices in `any order` + ! * ia(N+1): the index of the first nonzero element at this + ! corresponding row in the array a and jc, that is + ! ia(i) provides the position in a & jc where the i-th + ! row starts. + ! + ! This subroutine converts the sparse matrix (nrow, nrow) in the COO + ! format, as represented by (ir, jc) to the CSR format, as represented + ! by (ind_translate, iao). + ! + ! N.B.: + ! This subr. neither needs the real value array in the COO format, + ! nor returns the real value array in the CSR format. Alternatively, + ! it returns the tranformed index (ind_translate) from COO to CSR. + ! With such indices, we have + ! *) a_csr = a_coo(ind_translate) + ! *) jc_csr = jc_coo(ind_translate) + ! + ! References: + ! Youcef Saad, 1994, SPARSKIT: a basic tool kit for sparse matrix + ! compuation (version 2, `coocsr` therein) + ! See also Numerical Recipe in Fortran (ch. 2.7, p. 71) + !/ + implicit none + ! + integer, intent(in) :: nrow ! # of rows of sparse matrix + integer(kind=8), intent(in) & + :: nnz ! # of nonzero elements + integer, intent(in) :: ir(nnz) ! COO row + integer, intent(in) :: jc(nnz) ! COO col + integer, intent(out) :: ind_translate(nnz) ! indices from COO to CSR + integer, intent(out) :: iao(nrow+1) ! CSR iao + ! + ! Local parameters + integer :: i, j, k, k0, iad + !/ + ! Determine the number of non-zeros in each row (iao(i), i = 1, ..., nrow, + ! will be the # of nonzero elements at the i-th row), whereas + ! iao(nrow+1) = 0 + iao(1:nrow+1) = 0 + do k = 1, nnz + iao(ir(k)) = iao(ir(k)) + 1 ! row by row + end do + ! + ! Find the positions that correspond to the first value in each row. + ! Now iao(i) is the position where the i-th row starts, and + ! iao(nrow+1) = 1 + nnz + k = 1 + do j = 1, nrow+1 + k0 = iao(j) ! num_i, # of nonzero in this row + iao(j) = k ! starting pos + k = k + k0 ! k = Σnum_i, where i <= j + end do + ! + ! Go through the structure once more. Fill in ind_translate + do k = 1, nnz + i = ir(k) ! coo row + j = jc(k) ! coo col + ! + ! When i-th row is encountered by the first time, iad = iao(i) denotes + ! the starting position for this row. Afterwards, iao(i) is added by 1 + ! when i-th row arrives every time. In the end, iao(i) records the + ! starting position for the (i+1)-th row. However, the last element of + ! iao remains unchanged, i.e., iao(nrow+1) = iao(nrow) = 1 + nnz + iad = iao(i) + ind_translate(iad) = k + iao(i) = iad + 1 + end do + ! + ! Shift back IAO. + do j = nrow, 1, -1 + iao(j+1) = iao(j) + end do + iao(1) = 1 + ! + return + !/ + end subroutine CooCsrInd + !/ + !/ ------------------------------------------------------------------- / + !/ + subroutine ASymSmatTimVec (n, a, ja, ia, x, y, Symb) + !/ + !/ 07-Sep-2012 : Origination. ( version 3.14 ) + !/ Based on amux & atmux of SPARKIT ( O. Gramstad ) + !/ + !/ 16-Nov-2018 : Prepare WW3 distribution ( Q. Liu ) + !/ 19-Feb-2018 : Add `Symb` keyword ( Q. Liu ) + !/ + ! 1. Purpose: + ! --------> Symb = -1 (antisymmetric) + ! Calculate the dot product of an antisymmetric CSR sparse matrix + ! and a vector X. + ! + ! An antisymmetric (skew-symmetric) matrix is a square matrix `B` + ! whose transpose equals to its negative, i.e., + ! B^T = -B + ! + ! ◆ Do not be confused by the name of this subr. The coming-in CSR + ! sparse matrix `a` is not symmetric or antisymmetric. In our case, + ! `a` is a upper triangular sparse matrix, and we are acturally + ! calculating the dot product of `a - a^T` and `x`, where + ! 'a - a^T' is an antisymmetric matrix due to the symmetry of + ! four-wave nonlinear interactions (dN₁/dt = -dN₃/dt). + ! + ! This operation is in essence the dot product of two common dense + ! matrix/vector, such as + ! M(n, 1) = A(n, n) * X(n, 1) + ! or + ! M_{i, 1} = Σa(i, j) * x(j, 1) + ! + ! For the transposed array A^T, + ! N_{i, 1} = Σat(i, j) * x(j, 1) + ! = Σ a(j, i) * x(j, 1) + ! Alternatively, we can exchange the index of i, j for easy + ! understanding: + ! N_{j, 1} = Σat(j, i) * x(i, 1) + ! = Σ a(i, j) * x(i, 1) + ! + ! Finally, Y = M - N = A * X - A^T * X + ! + ! --------> Symb = 1 (Symmetric) + ! Same as above but for Y = M + N = A * X + A^T * X + !/ + implicit none + ! + integer, intent(in) :: n ! # of rows/cols + ! + real, intent(in) :: a(:) ! CSR a (nnz) + integer, intent(in) :: ja(:) ! CSR ja(nnz) + integer, intent(in) :: ia(n+1) ! CSR ia(n+1) + ! + real, intent(in) :: x(n) ! vector of the same length + real, intent(out) :: y(n) ! return product y = B * x + real, intent(in) :: Symb ! -1 for minus, 1 for plus + ! + ! Local parameters + integer :: i, k + real :: t + !/ + ! Initilization + y(1:n) = 0.0 + ! + do i = 1, n + t = 0.0 + do k = ia(i), ia(i+1)-1 + ! + ! M_{i, 1} = Σa(i, j) * x(j, 1) + t = t + a(k) * x(ja(k)) + ! + !±N_{j, 1} = ±Σa(i, j) * x(i, 1) + y(ja(k)) = y(ja(k)) + Symb * a(k)*x(i) + end do + y(i) = y(i) + t + end do + ! The final Y = M ± N = A * x ± A^T * x + ! + return + !/ + end subroutine ASymSmatTimVec + !/ + !/ ------------------------------------------------------------------- / + !/ Part 4 + !/ + subroutine PrepKGrid(nk, nth, dpt, sig, th) + !/ + !/ 04-Dec-2018 : Origination. ( Q. Liu ) + !/ 04-Dec-2018 : Based on `z_cmpcg` & `z_wnumb` of serv_xnl4v5.f90 + !/ ( Q. Liu ) + !/ 01-Apr-2019 : Add the option using WAVNU1 ( Q. Liu ) + !/ + ! 1. Purpose: + ! Compute wave number k for a given discrete frequency grid and water + ! depth based on the dispersion relation for the linear wave theory + ! ω^2 = gk tanh(kd) + ! + ! ◆ In WW3, the radian frequency grid ω is invariant. + ! + ! ◆ It is desired that the GKE module should be independent from WW3 + ! as much as possible. So I decided not to directly obtain + ! `NK, NTH, SIG, WN, CG, DSII` from WW3 + ! + ! 2. Method + ! ✓ dispopt = 0 + ! Finite depth linear dispersion relation, using a Pade approximation + ! (Hunt, 1988) [see WRT serv_xnl4v5.f90] + ! + ! ✓ dispopt = 1 for WAVNU1 + !/ + USE W3DISPMD, ONLY: WAVNU1 + ! + implicit none + ! + integer, intent(in) :: nk ! # of frequencies + integer, intent(in) :: nth ! # of directions + real, intent(in) :: dpt ! water depth (m) + real, intent(in) :: sig(nk) ! radian frequency σ + real, intent(in) :: th(nth) ! θ (rad) [equally spaced, + ! but may start from non-zero + ! value] + ! + integer, parameter :: dispopt = 1 ! dispersion relation + ! + integer :: ik, ith, jkth, ns + real :: x, xx, y, omega + real :: k, cg, dsii, angR, dth + real :: esin(nth), ecos(nth) + !/ + ! Initialization + ns = nk * nth + ! Allocation of qr_kx/ky/dk/om/wn1 was done in PrepKernelIO) + qr_kx = 0. ! ns + qr_ky = 0. + qr_dk = 0. + qr_om = 0. + qr_wn1 = 0. ! nk + ! + ! Calc Δθ, cosθ, sinθ [θ is equally spaced] + dth = qr_tpi / real(nth) + ! + do ith = 1, nth + angR = th(ith) + esin(ith) = sin(angR) + ecos(ith) = cos(angR) + ! + if (abs(esin(ith)) .lt. 1.E-5) then + esin(ith) = 0. + if (ecos(ith) .gt. 0.5) then + ecos(ith) = 1. ! θ = 0. + else + ecos(ith) = -1. ! θ = π + end if + end if + ! + if (abs(ecos(ith)) .lt. 1.E-5) then + ecos(ith) = 0. + if (esin(ith) .gt. 0.5) then + esin(ith) = 1. ! θ = π/2 + else + esin(ith) = -1. ! θ = π * 3/2 + end if + end if + end do + ! + do ik = 1, nk + if (dispopt .eq. 0) then + ! Calc k & Cg (`z_cmpcg` & `z_wnumb` of serv_xnl4v5.f90) + omega = sig(ik)**2.0/qr_grav + y = omega*dpt + xx = y*(y+1.0/(1.0+y*(0.66667+y*(0.35550+y*(0.16084+y*(0.06320+y* & + (0.02174+y*(0.00654+y*(0.00171+y*(0.00039+y*0.00011)))))))))) + x = sqrt(xx) + k = x/dpt + ! + if(dpt*k > 30.0) then + cg = qr_grav/(2.0*sig(ik)) + else + cg = sig(ik)/k*(0.5+dpt*k/sinh(2.0*dpt*k)) + end if + ! + else if (dispopt .eq. 1) then + ! Calc k & cg (WAVNU1 from WW3) + call WAVNU1(sig(ik), dpt, k, cg) + end if + qr_wn1(ik) = k ! Store k in qr_wn1 ('ll used for interp.) #ifdef W3_TS - write(*, *) 'σ, k, cg: ', sig(ik), k, cg + write(*, *) 'σ, k, cg: ', sig(ik), k, cg #endif -! Calc Δσ - if (ik .eq. 1) then - dsii = 0.5 * (sig(2) - sig(1)) ! first bin - else if (ik .eq. nk) then - dsii = 0.5 * (sig(nk) - sig(nk-1)) ! last bin - else - dsii = 0.5 * (sig(ik+1) - sig(ik-1)) ! interm. bin - end if -! Calc Kx, Ky - do ith = 1, nth - jkth = ith + (ik - 1) * nth - qr_kx(jkth) = k * ecos(ith) - qr_ky(jkth) = k * esin(ith) -! Calc Δ\vec{k} = k Δk Δθ = k Δσ/cg Δθ - qr_dk(jkth) = k * dsii / cg * dth - qr_om(jkth) = sig(ik) - end do - end do + ! Calc Δσ + if (ik .eq. 1) then + dsii = 0.5 * (sig(2) - sig(1)) ! first bin + else if (ik .eq. nk) then + dsii = 0.5 * (sig(nk) - sig(nk-1)) ! last bin + else + dsii = 0.5 * (sig(ik+1) - sig(ik-1)) ! interm. bin + end if + ! Calc Kx, Ky + do ith = 1, nth + jkth = ith + (ik - 1) * nth + qr_kx(jkth) = k * ecos(ith) + qr_ky(jkth) = k * esin(ith) + ! Calc Δ\vec{k} = k Δk Δθ = k Δσ/cg Δθ + qr_dk(jkth) = k * dsii / cg * dth + qr_om(jkth) = sig(ik) + end do + end do #ifdef W3_TS write(*, *) 'qr_kx: ', qr_kx write(*, *) 'qr_ky: ', qr_ky write(*, *) 'qr_dk: ', qr_dk write(*, *) 'qr_om: ', qr_om #endif -! - return -!/ - end subroutine PrepKGrid -!/ -!/ ------------------------------------------------------------------- / -!/ - subroutine PrepKernelIO(nk, nth, sig, th, act) -!/ -!/ 04-Dec-2018 : Origination ( Q. Liu ) -!/ 04-Dec-2018 : Extracted from Odin's subr. `calcQRSNL` -!/ ( Q. Liu ) -!/ -! 1. Purpose: -! Read & Write the pre-computed kernel coefficients `T` for a given -! discrete wavenumber grid and water depth. -! -! For a typical 2D finite-depth wave model application, the wavenumber -! grid varies according to water depth. Consequently, the quartet -! configuration and interactive kernel coefficients will change as -! well. -! -! Therefore, it seems extremely difficult to handle a 2D varied-depth -! application as the total number of quartets (qi_nnz) and thus the -! array size of `Inpqr0` vary [see CalcQRSNL]. Initializing a 2D -! array `Inpqr0` with a fixed size of (qi_nnz, nsea) becomes impossible. -! -! So currently we are limiting ourself to deep-water or constant -! finite-deep cases. -! -!/ - USE CONSTANTS, ONLY: file_endian + ! + return + !/ + end subroutine PrepKGrid + !/ + !/ ------------------------------------------------------------------- / + !/ + subroutine PrepKernelIO(nk, nth, sig, th, act) + !/ + !/ 04-Dec-2018 : Origination ( Q. Liu ) + !/ 04-Dec-2018 : Extracted from Odin's subr. `calcQRSNL` + !/ ( Q. Liu ) + !/ + ! 1. Purpose: + ! Read & Write the pre-computed kernel coefficients `T` for a given + ! discrete wavenumber grid and water depth. + ! + ! For a typical 2D finite-depth wave model application, the wavenumber + ! grid varies according to water depth. Consequently, the quartet + ! configuration and interactive kernel coefficients will change as + ! well. + ! + ! Therefore, it seems extremely difficult to handle a 2D varied-depth + ! application as the total number of quartets (qi_nnz) and thus the + ! array size of `Inpqr0` vary [see CalcQRSNL]. Initializing a 2D + ! array `Inpqr0` with a fixed size of (qi_nnz, nsea) becomes impossible. + ! + ! So currently we are limiting ourself to deep-water or constant + ! finite-deep cases. + ! + !/ + USE CONSTANTS, ONLY: file_endian - implicit none -! - integer, intent(in) :: nk ! # of frequencies - integer, intent(in) :: nth ! # of directions - real, intent(in) :: sig(nk) ! radian frequency (rad) - real, intent(in) :: th(nth) ! θ (rad) [equally spaced, - ! but may start from non-zero - ! value] - character(len=*), intent(in) :: act ! 'read' or 'write' -! -! Local parameters - integer :: ns, iq, i1, i3, icol - integer(kind=8) :: rpos ! reading position - integer, allocatable :: irow_coo(:), & ! row of coo mat - icooTcsr(:) ! index for coo → csr -!/ -! Initilization - ns = nk * nth - qi_nrsm = ns * ns -! → Be very careful that the size of `qi_irCsr` is not qi_nnz ! - if (allocated(qi_irCsr)) deallocate(qi_irCsr); allocate(qi_irCsr(qi_nrsm+1)) - if (allocated(qr_sumQR)) deallocate(qr_sumQR); allocate(qr_sumQR(qi_nrsm)) - if (allocated(qr_sumNP)) deallocate(qr_sumNP); allocate(qr_sumNP(ns, ns)) -! qr_dk/om - if (allocated(qr_dk)) deallocate(qr_dk); allocate(qr_dk(ns)) - if (allocated(qr_om)) deallocate(qr_om); allocate(qr_om(ns)) -! -! Determine water depth for the whole module, which will be used by -! `T` & `Q` func. - qr_depth = max(0., min(qr_depth, qr_dmax)) - qi_disc = max(0, min(qi_disc, 1)) - qi_kev = max(0, min(qi_kev, 1)) - qi_interp = max(0, min(qi_interp, 1)) - if (qi_disc .eq. 1) qi_interp = 0 -! -! Determine the name for the binary file which stores the quartet -! configuration and the corresponding kernel coefficient ['gkev?_d????.cfg] -! constant-depth or deep water - write(qs_cfg, "(A, '_d', I4.4, '.cfg')") trim(qs_ver), int(qr_depth) -! - if (trim(act) == 'WRITE') then -! Calc KGrid → [qr_kx/ky/dk/om/wn] - if (allocated(qr_kx)) deallocate(qr_kx); allocate(qr_kx(ns)) - if (allocated(qr_ky)) deallocate(qr_ky); allocate(qr_ky(ns)) - if (allocated(qr_wn1)) deallocate(qr_wn1); allocate(qr_wn1(nk)) - call PrepKGrid(nk, nth, qr_depth, sig, th) -! Find total # of quartets → [qi_nnz] - call FindQuartetNumber(ns, qr_kx, qr_ky, qr_om, qr_oml, qi_nnz) -! Find Quartet Config. → [qi_NN/PP/QQ/RR & qr_k4x/k4y/om4] - if (allocated(qi_NN)) deallocate(qi_NN); allocate(qi_NN(qi_nnz)) - if (allocated(qi_PP)) deallocate(qi_PP); allocate(qi_PP(qi_nnz)) - if (allocated(qi_QQ)) deallocate(qi_QQ); allocate(qi_QQ(qi_nnz)) - if (allocated(qi_RR)) deallocate(qi_RR); allocate(qi_RR(qi_nnz)) -! - if (allocated(qr_k4x)) deallocate(qr_k4x); allocate(qr_k4x(qi_nnz)) - if (allocated(qr_k4y)) deallocate(qr_k4y); allocate(qr_k4y(qi_nnz)) - if (allocated(qr_om4)) deallocate(qr_om4); allocate(qr_om4(qi_nnz)) -! - call FindQuartetConfig(ns, qr_kx, qr_ky, qr_om, qr_oml, qi_nnz, & - qi_NN, qi_PP, qi_QQ, qi_RR, & - qr_k4x, qr_k4y, qr_om4) -! -! Calc Kernel `T` - if (allocated(qr_TKern)) deallocate(qr_TKern); allocate(qr_TKern(qi_nnz)) - if (allocated(qr_TKurt)) deallocate(qr_TKurt); allocate(qr_TKurt(qi_nnz)) - if (allocated(qr_dom)) deallocate(qr_dom); allocate(qr_dom(qi_nnz)) -! - do iq = 1, qi_nnz - qr_TKern(iq) = TFunc(qr_kx(qi_NN(iq)), qr_ky(qi_NN(iq)),& - qr_kx(qi_PP(iq)), qr_ky(qi_PP(iq)),& - qr_kx(qi_QQ(iq)), qr_ky(qi_QQ(iq)),& - qr_k4x(iq) , qr_k4y(iq) ) - end do -! Calc Kernel coeff. for Kurtosis - qr_TKurt = qr_TKern * sqrt(qr_om(qi_NN) * qr_om(qi_PP) * qr_om(qi_QQ) * qr_om4) -! Calc Δω (Remove very small Δω; Δω=0 → resonant quartets) - qr_dom = qr_om(qi_NN) + qr_om(qi_PP) - qr_om(qi_QQ) - qr_om4 -! TODO: should we use double precision for qr_dom -! Note for GNU compiler, qr_eps~1.2E-7 (single prec.) & ~2.2E-16 (double). -! The values above are also true for the intel compiler. -! sin(Δωt) / Δω is very different for Δω = 0 and Δw~1E-7 when t is large. - where(abs(qr_dom) < qr_eps) qr_dom = 0.0 -! -! Calc interp. weight if necessary - if (qi_interp .eq. 1) then - if (allocated(qi_bind)) deallocate(qi_bind); allocate(qi_bind(4, qi_nnz)) - if (allocated(qr_bwgh)) deallocate(qr_bwgh); allocate(qr_bwgh(4, qi_nnz)) - if (qi_bound .eq. 1 ) then - if (allocated(qr_bdry)) deallocate(qr_bdry); allocate(qr_bdry(qi_nnz)) - end if - call BiInterpWT(nk, nth, qr_wn1, th) - end if -! - deallocate(qr_kx, qr_ky) - deallocate(qr_k4x, qr_k4y, qr_om4) - if (qi_interp .eq. 1) deallocate(qr_wn1) -! -! Sparse matrix index conversion [icCos shared by two formats: COO & CSR] - if (allocated(qi_icCos)) deallocate(qi_icCos); allocate(qi_icCos(qi_nnz)) - if (allocated(irow_coo)) deallocate(irow_coo); allocate(irow_coo(qi_nnz)) - if (allocated(icooTcsr)) deallocate(icooTcsr); allocate(icooTcsr(qi_nnz)) -! - irow_coo = qi_NN + (qi_PP - 1) * ns - qi_icCos = qi_QQ + (qi_RR - 1) * ns -! -! FindQuartetConfig stores the quartet row by row in a discontinuous order, -! so we need keep icooTcsr & qi_irCsr - call CooCsrInd(qi_nrsm, qi_nnz, irow_coo, qi_icCos, icooTcsr, qi_irCsr) -! -! Reorder index & arrays [coo → crs] - qi_NN = qi_NN(icooTcsr) ! used for calc. action prod. - qi_PP = qi_PP(icooTcsr) - qi_QQ = qi_QQ(icooTcsr) - qi_RR = qi_RR(icooTcsr) - qr_TKern = qr_TKern(icooTcsr) - qr_TKurt = qr_TKurt(icooTcsr) - qr_dom = qr_dom(icooTcsr) ! Δω -! - if (qi_interp .eq. 1) then ! bilinear interp. weight - qi_bind = qi_bind(:, icooTcsr) - qr_bwgh = qr_bwgh(:, icooTcsr) - if (qi_bound .eq. 1) qr_bdry = qr_bdry(icooTcsr) - end if -! - qi_icCos = qi_icCos(icooTcsr) - deallocate(irow_coo, icooTcsr) -! -! Construct the sum vectors [used for 6D integration] -! Σ over Q, R [qr_sumQR] - qr_sumQR = 2.0 - do i3 = 1, ns -! i3 == i4 - icol = i3 + (i3 - 1) * ns - qr_sumQR(icol) = 1.0 - end do -! Σ over P [qr_sumNP] - qr_sumNP = 1.0 - do i1 = 1, ns -! i1 == i2 - qr_sumNP(i1, i1) = 0.5 - end do -! -! WRITE KGrid & Kernel into qs_cfg - write(*, *) '[W] Writing |', trim(qs_cfg), '| ...' - open(51, file=trim(qs_cfg), form='unformatted', convert=file_endian, & - access='stream', status='replace') -! -! It is not necessary to store `ns` since `ns = nk * nth` - write(51) nk, nth, sig, th ! (f, θ) grid - write(51) qr_depth, qr_oml, qi_disc, & - qi_kev, qi_interp ! parameters - write(51) qr_om, qr_dk - write(51) qi_nnz - write(51) qi_NN, qi_PP, qi_QQ, qi_RR - write(51) qr_TKern, qr_TKurt, qr_dom - write(51) qi_icCos, qi_irCsr - write(51) qr_sumQR, qr_sumNP -! - if (qi_interp .eq. 1) write(51) qi_bind, qr_bwgh - if ( (qi_interp .eq. 1) .and. (qi_bound .eq. 1) ) & - write(51) qr_bdry - close(51) -! Screen Test + implicit none + ! + integer, intent(in) :: nk ! # of frequencies + integer, intent(in) :: nth ! # of directions + real, intent(in) :: sig(nk) ! radian frequency (rad) + real, intent(in) :: th(nth) ! θ (rad) [equally spaced, + ! but may start from non-zero + ! value] + character(len=*), intent(in) :: act ! 'read' or 'write' + ! + ! Local parameters + integer :: ns, iq, i1, i3, icol + integer(kind=8) :: rpos ! reading position + integer, allocatable :: irow_coo(:), & ! row of coo mat + icooTcsr(:) ! index for coo → csr + !/ + ! Initilization + ns = nk * nth + qi_nrsm = ns * ns + ! → Be very careful that the size of `qi_irCsr` is not qi_nnz ! + if (allocated(qi_irCsr)) deallocate(qi_irCsr); allocate(qi_irCsr(qi_nrsm+1)) + if (allocated(qr_sumQR)) deallocate(qr_sumQR); allocate(qr_sumQR(qi_nrsm)) + if (allocated(qr_sumNP)) deallocate(qr_sumNP); allocate(qr_sumNP(ns, ns)) + ! qr_dk/om + if (allocated(qr_dk)) deallocate(qr_dk); allocate(qr_dk(ns)) + if (allocated(qr_om)) deallocate(qr_om); allocate(qr_om(ns)) + ! + ! Determine water depth for the whole module, which will be used by + ! `T` & `Q` func. + qr_depth = max(0., min(qr_depth, qr_dmax)) + qi_disc = max(0, min(qi_disc, 1)) + qi_kev = max(0, min(qi_kev, 1)) + qi_interp = max(0, min(qi_interp, 1)) + if (qi_disc .eq. 1) qi_interp = 0 + ! + ! Determine the name for the binary file which stores the quartet + ! configuration and the corresponding kernel coefficient ['gkev?_d????.cfg] + ! constant-depth or deep water + write(qs_cfg, "(A, '_d', I4.4, '.cfg')") trim(qs_ver), int(qr_depth) + ! + if (trim(act) == 'WRITE') then + ! Calc KGrid → [qr_kx/ky/dk/om/wn] + if (allocated(qr_kx)) deallocate(qr_kx); allocate(qr_kx(ns)) + if (allocated(qr_ky)) deallocate(qr_ky); allocate(qr_ky(ns)) + if (allocated(qr_wn1)) deallocate(qr_wn1); allocate(qr_wn1(nk)) + call PrepKGrid(nk, nth, qr_depth, sig, th) + ! Find total # of quartets → [qi_nnz] + call FindQuartetNumber(ns, qr_kx, qr_ky, qr_om, qr_oml, qi_nnz) + ! Find Quartet Config. → [qi_NN/PP/QQ/RR & qr_k4x/k4y/om4] + if (allocated(qi_NN)) deallocate(qi_NN); allocate(qi_NN(qi_nnz)) + if (allocated(qi_PP)) deallocate(qi_PP); allocate(qi_PP(qi_nnz)) + if (allocated(qi_QQ)) deallocate(qi_QQ); allocate(qi_QQ(qi_nnz)) + if (allocated(qi_RR)) deallocate(qi_RR); allocate(qi_RR(qi_nnz)) + ! + if (allocated(qr_k4x)) deallocate(qr_k4x); allocate(qr_k4x(qi_nnz)) + if (allocated(qr_k4y)) deallocate(qr_k4y); allocate(qr_k4y(qi_nnz)) + if (allocated(qr_om4)) deallocate(qr_om4); allocate(qr_om4(qi_nnz)) + ! + call FindQuartetConfig(ns, qr_kx, qr_ky, qr_om, qr_oml, qi_nnz, & + qi_NN, qi_PP, qi_QQ, qi_RR, & + qr_k4x, qr_k4y, qr_om4) + ! + ! Calc Kernel `T` + if (allocated(qr_TKern)) deallocate(qr_TKern); allocate(qr_TKern(qi_nnz)) + if (allocated(qr_TKurt)) deallocate(qr_TKurt); allocate(qr_TKurt(qi_nnz)) + if (allocated(qr_dom)) deallocate(qr_dom); allocate(qr_dom(qi_nnz)) + ! + do iq = 1, qi_nnz + qr_TKern(iq) = TFunc(qr_kx(qi_NN(iq)), qr_ky(qi_NN(iq)),& + qr_kx(qi_PP(iq)), qr_ky(qi_PP(iq)),& + qr_kx(qi_QQ(iq)), qr_ky(qi_QQ(iq)),& + qr_k4x(iq) , qr_k4y(iq) ) + end do + ! Calc Kernel coeff. for Kurtosis + qr_TKurt = qr_TKern * sqrt(qr_om(qi_NN) * qr_om(qi_PP) * qr_om(qi_QQ) * qr_om4) + ! Calc Δω (Remove very small Δω; Δω=0 → resonant quartets) + qr_dom = qr_om(qi_NN) + qr_om(qi_PP) - qr_om(qi_QQ) - qr_om4 + ! TODO: should we use double precision for qr_dom + ! Note for GNU compiler, qr_eps~1.2E-7 (single prec.) & ~2.2E-16 (double). + ! The values above are also true for the intel compiler. + ! sin(Δωt) / Δω is very different for Δω = 0 and Δw~1E-7 when t is large. + where(abs(qr_dom) < qr_eps) qr_dom = 0.0 + ! + ! Calc interp. weight if necessary + if (qi_interp .eq. 1) then + if (allocated(qi_bind)) deallocate(qi_bind); allocate(qi_bind(4, qi_nnz)) + if (allocated(qr_bwgh)) deallocate(qr_bwgh); allocate(qr_bwgh(4, qi_nnz)) + if (qi_bound .eq. 1 ) then + if (allocated(qr_bdry)) deallocate(qr_bdry); allocate(qr_bdry(qi_nnz)) + end if + call BiInterpWT(nk, nth, qr_wn1, th) + end if + ! + deallocate(qr_kx, qr_ky) + deallocate(qr_k4x, qr_k4y, qr_om4) + if (qi_interp .eq. 1) deallocate(qr_wn1) + ! + ! Sparse matrix index conversion [icCos shared by two formats: COO & CSR] + if (allocated(qi_icCos)) deallocate(qi_icCos); allocate(qi_icCos(qi_nnz)) + if (allocated(irow_coo)) deallocate(irow_coo); allocate(irow_coo(qi_nnz)) + if (allocated(icooTcsr)) deallocate(icooTcsr); allocate(icooTcsr(qi_nnz)) + ! + irow_coo = qi_NN + (qi_PP - 1) * ns + qi_icCos = qi_QQ + (qi_RR - 1) * ns + ! + ! FindQuartetConfig stores the quartet row by row in a discontinuous order, + ! so we need keep icooTcsr & qi_irCsr + call CooCsrInd(qi_nrsm, qi_nnz, irow_coo, qi_icCos, icooTcsr, qi_irCsr) + ! + ! Reorder index & arrays [coo → crs] + qi_NN = qi_NN(icooTcsr) ! used for calc. action prod. + qi_PP = qi_PP(icooTcsr) + qi_QQ = qi_QQ(icooTcsr) + qi_RR = qi_RR(icooTcsr) + qr_TKern = qr_TKern(icooTcsr) + qr_TKurt = qr_TKurt(icooTcsr) + qr_dom = qr_dom(icooTcsr) ! Δω + ! + if (qi_interp .eq. 1) then ! bilinear interp. weight + qi_bind = qi_bind(:, icooTcsr) + qr_bwgh = qr_bwgh(:, icooTcsr) + if (qi_bound .eq. 1) qr_bdry = qr_bdry(icooTcsr) + end if + ! + qi_icCos = qi_icCos(icooTcsr) + deallocate(irow_coo, icooTcsr) + ! + ! Construct the sum vectors [used for 6D integration] + ! Σ over Q, R [qr_sumQR] + qr_sumQR = 2.0 + do i3 = 1, ns + ! i3 == i4 + icol = i3 + (i3 - 1) * ns + qr_sumQR(icol) = 1.0 + end do + ! Σ over P [qr_sumNP] + qr_sumNP = 1.0 + do i1 = 1, ns + ! i1 == i2 + qr_sumNP(i1, i1) = 0.5 + end do + ! + ! WRITE KGrid & Kernel into qs_cfg + write(*, *) '[W] Writing |', trim(qs_cfg), '| ...' + open(51, file=trim(qs_cfg), form='unformatted', convert=file_endian, & + access='stream', status='replace') + ! + ! It is not necessary to store `ns` since `ns = nk * nth` + write(51) nk, nth, sig, th ! (f, θ) grid + write(51) qr_depth, qr_oml, qi_disc, & + qi_kev, qi_interp ! parameters + write(51) qr_om, qr_dk + write(51) qi_nnz + write(51) qi_NN, qi_PP, qi_QQ, qi_RR + write(51) qr_TKern, qr_TKurt, qr_dom + write(51) qi_icCos, qi_irCsr + write(51) qr_sumQR, qr_sumNP + ! + if (qi_interp .eq. 1) write(51) qi_bind, qr_bwgh + if ( (qi_interp .eq. 1) .and. (qi_bound .eq. 1) ) & + write(51) qr_bdry + close(51) + ! Screen Test #ifdef W3_TS - write(*, *) "[W] qr_depth: ", qr_depth - write(*, *) "[W] qr_oml : ", qr_oml - write(*, *) "[W] qi_disc : ", qi_disc - write(*, *) "[W] qi_kev : ", qi_kev - write(*, *) "[W] qr_om : ", qr_om - write(*, *) "[W] qr_dk : ", qr_dk - write(*, *) "[W] The total number of quartets is ", qi_nnz - write(*, *) '[W] qi_NN : ', qi_NN - write(*, *) '[W] qi_PP : ', qi_PP - write(*, *) '[W] qi_QQ : ', qi_QQ - write(*, *) '[W] qi_RR : ', qi_RR - write(*, *) '[W] qr_TKern: ', qr_TKern - write(*, *) '[W] qr_TKurt: ', qr_TKurt - write(*, *) '[W] qr_dom : ', qr_dom - write(*, *) '[W] qi_icCos: ', qi_icCos - write(*, *) '[W] qi_irCsr: ', qi_irCsr - write(*, *) '[W] Σ_QR : ', qr_sumQR(1: qi_nrsm: ns+1) - write(*, *) '[W] Σ_P : ', (qr_sumNP(iq, iq), iq = 1, ns) + write(*, *) "[W] qr_depth: ", qr_depth + write(*, *) "[W] qr_oml : ", qr_oml + write(*, *) "[W] qi_disc : ", qi_disc + write(*, *) "[W] qi_kev : ", qi_kev + write(*, *) "[W] qr_om : ", qr_om + write(*, *) "[W] qr_dk : ", qr_dk + write(*, *) "[W] The total number of quartets is ", qi_nnz + write(*, *) '[W] qi_NN : ', qi_NN + write(*, *) '[W] qi_PP : ', qi_PP + write(*, *) '[W] qi_QQ : ', qi_QQ + write(*, *) '[W] qi_RR : ', qi_RR + write(*, *) '[W] qr_TKern: ', qr_TKern + write(*, *) '[W] qr_TKurt: ', qr_TKurt + write(*, *) '[W] qr_dom : ', qr_dom + write(*, *) '[W] qi_icCos: ', qi_icCos + write(*, *) '[W] qi_irCsr: ', qi_irCsr + write(*, *) '[W] Σ_QR : ', qr_sumQR(1: qi_nrsm: ns+1) + write(*, *) '[W] Σ_P : ', (qr_sumNP(iq, iq), iq = 1, ns) #endif -! - else if (trim(act) == 'READ') then - write(*, *) '⊚ → [R] Reading |', trim(qs_cfg), '| ...' - open(51, file=trim(qs_cfg), form='unformatted', convert=file_endian, & - access='stream', status='old') -! nk, nth, sig, th can be skipped by using pos - rpos = 1_8 + qi_lrb * (2_8 + nk + nth) - read(51, pos=rpos) qr_depth, qr_oml, qi_disc, & - qi_kev, qi_interp -! -! read ω & Δ\vec{k} - read(51) qr_om, qr_dk -! read total # of quartets - read(51) qi_nnz - write(*, *) "⊚ → [R] The total number of quartets is ", qi_nnz - write(*, *) -! allocate arrays - if (allocated(qi_NN)) deallocate(qi_NN); allocate(qi_NN(qi_nnz)) - if (allocated(qi_PP)) deallocate(qi_PP); allocate(qi_PP(qi_nnz)) - if (allocated(qi_QQ)) deallocate(qi_QQ); allocate(qi_QQ(qi_nnz)) - if (allocated(qi_RR)) deallocate(qi_RR); allocate(qi_RR(qi_nnz)) -! - if (allocated(qr_TKern)) deallocate(qr_TKern); allocate(qr_TKern(qi_nnz)) - if (allocated(qr_TKurt)) deallocate(qr_TKurt); allocate(qr_TKurt(qi_nnz)) - if (allocated(qr_dom)) deallocate(qr_dom); allocate(qr_dom(qi_nnz)) -! - if (allocated(qi_icCos)) deallocate(qi_icCos); allocate(qi_icCos(qi_nnz)) -! - read(51) qi_NN, qi_PP, qi_QQ, qi_RR - read(51) qr_TKern, qr_TKurt, qr_dom - read(51) qi_icCos, qi_irCsr - read(51) qr_sumQR, qr_sumNP -! - if (qi_interp .eq. 1) then - if (allocated(qi_bind)) deallocate(qi_bind); allocate(qi_bind(4, qi_nnz)) - if (allocated(qr_bwgh)) deallocate(qr_bwgh); allocate(qr_bwgh(4, qi_nnz)) - read(51) qi_bind, qr_bwgh -! - if (qi_bound .eq. 1) then - if (allocated(qr_bdry)) deallocate(qr_bdry); allocate(qr_bdry(qi_nnz)) - read(51) qr_bdry - end if -! - end if -! - close(51) -! Screen Test + ! + else if (trim(act) == 'READ') then + write(*, *) '⊚ → [R] Reading |', trim(qs_cfg), '| ...' + open(51, file=trim(qs_cfg), form='unformatted', convert=file_endian, & + access='stream', status='old') + ! nk, nth, sig, th can be skipped by using pos + rpos = 1_8 + qi_lrb * (2_8 + nk + nth) + read(51, pos=rpos) qr_depth, qr_oml, qi_disc, & + qi_kev, qi_interp + ! + ! read ω & Δ\vec{k} + read(51) qr_om, qr_dk + ! read total # of quartets + read(51) qi_nnz + write(*, *) "⊚ → [R] The total number of quartets is ", qi_nnz + write(*, *) + ! allocate arrays + if (allocated(qi_NN)) deallocate(qi_NN); allocate(qi_NN(qi_nnz)) + if (allocated(qi_PP)) deallocate(qi_PP); allocate(qi_PP(qi_nnz)) + if (allocated(qi_QQ)) deallocate(qi_QQ); allocate(qi_QQ(qi_nnz)) + if (allocated(qi_RR)) deallocate(qi_RR); allocate(qi_RR(qi_nnz)) + ! + if (allocated(qr_TKern)) deallocate(qr_TKern); allocate(qr_TKern(qi_nnz)) + if (allocated(qr_TKurt)) deallocate(qr_TKurt); allocate(qr_TKurt(qi_nnz)) + if (allocated(qr_dom)) deallocate(qr_dom); allocate(qr_dom(qi_nnz)) + ! + if (allocated(qi_icCos)) deallocate(qi_icCos); allocate(qi_icCos(qi_nnz)) + ! + read(51) qi_NN, qi_PP, qi_QQ, qi_RR + read(51) qr_TKern, qr_TKurt, qr_dom + read(51) qi_icCos, qi_irCsr + read(51) qr_sumQR, qr_sumNP + ! + if (qi_interp .eq. 1) then + if (allocated(qi_bind)) deallocate(qi_bind); allocate(qi_bind(4, qi_nnz)) + if (allocated(qr_bwgh)) deallocate(qr_bwgh); allocate(qr_bwgh(4, qi_nnz)) + read(51) qi_bind, qr_bwgh + ! + if (qi_bound .eq. 1) then + if (allocated(qr_bdry)) deallocate(qr_bdry); allocate(qr_bdry(qi_nnz)) + read(51) qr_bdry + end if + ! + end if + ! + close(51) + ! Screen Test #ifdef W3_TS - write(*, *) "[R] qr_depth: ", qr_depth - write(*, *) "[R] qr_oml : ", qr_oml - write(*, *) "[R] qi_disc : ", qi_disc - write(*, *) "[R] qi_kev : ", qi_kev - write(*, *) "[R] qr_om : ", qr_om - write(*, *) "[R] qr_dk : ", qr_dk - write(*, *) "[R] The total number of quartets is ", qi_nnz - write(*, *) '[R] qi_NN : ', qi_NN - write(*, *) '[R] qi_PP : ', qi_PP - write(*, *) '[R] qi_QQ : ', qi_QQ - write(*, *) '[R] qi_RR : ', qi_RR - write(*, *) '[R] qr_TKern: ', qr_TKern - write(*, *) '[R] qr_TKurt: ', qr_TKurt - write(*, *) '[R] qr_dom : ', qr_dom - write(*, *) '[R] qi_icCos: ', qi_icCos - write(*, *) '[R] qi_irCsr: ', qi_irCsr - write(*, *) '[R] Σ_QR : ', qr_sumQR(1: qi_nrsm: ns+1) - write(*, *) '[R] Σ_P : ', (qr_sumNP(iq, iq), iq = 1, ns) + write(*, *) "[R] qr_depth: ", qr_depth + write(*, *) "[R] qr_oml : ", qr_oml + write(*, *) "[R] qi_disc : ", qi_disc + write(*, *) "[R] qi_kev : ", qi_kev + write(*, *) "[R] qr_om : ", qr_om + write(*, *) "[R] qr_dk : ", qr_dk + write(*, *) "[R] The total number of quartets is ", qi_nnz + write(*, *) '[R] qi_NN : ', qi_NN + write(*, *) '[R] qi_PP : ', qi_PP + write(*, *) '[R] qi_QQ : ', qi_QQ + write(*, *) '[R] qi_RR : ', qi_RR + write(*, *) '[R] qr_TKern: ', qr_TKern + write(*, *) '[R] qr_TKurt: ', qr_TKurt + write(*, *) '[R] qr_dom : ', qr_dom + write(*, *) '[R] qi_icCos: ', qi_icCos + write(*, *) '[R] qi_irCsr: ', qi_irCsr + write(*, *) '[R] Σ_QR : ', qr_sumQR(1: qi_nrsm: ns+1) + write(*, *) '[R] Σ_P : ', (qr_sumNP(iq, iq), iq = 1, ns) #endif - end if -!/ - end subroutine PrepKernelIO -!/ -!/ ------------------------------------------------------------------- / -!/ - subroutine BiInterpWT(nk, nth, wn, th) -!/ -!/ 19-Apr-2019 : Origination ( Q. Liu ) -!/ 19-Apr-2019 : Extracted from a few subrs. of mod_xnl4v5.f90 -!/ ( Q. Liu ) -!/ 01-Apr-2020 : Boundary conditions ( Q. Liu ) -!/ -! 1. Purpose: -! Calculate weights for the bilinear interpolation. -! -! 2. Method: -! See also Fig. 9 of van Vledder (2006, CE) and mod_xnl4v5.f90 (WRT). -! [q_t13v4, q_weight, q_makegrid -!/ - implicit none -! - integer, intent(in) :: nk - integer, intent(in) :: nth - real, intent(in) :: wn(nk) ! k - real, intent(in) :: th(nth) ! θ -! - integer :: iq, jkU, jk4, jk4p, jth4T, jth4, jth4p - real :: dth, aRef, k4T, angR, & - r_jk, r_jth, delK, w_k4, w_th4 - real :: kmin, kmax, k4R - real :: qr_kpow -! -! Initialization - qi_bind = 0 - qr_bwgh = 0. - if (qi_bound .eq. 1) qr_bdry = 1. -! -! Get power law for F(k) from qi_fpow for E(f) -! E(f) df = F(k) dk → F(k) ~ f^n * cg = k^{(n-1)/2} -! N(k) = F(k) / ω ~ k^{n/2-1} -! C(k) = N(k) / k ~ k^{n/2-1 -1} - qr_kpow = qr_fpow / 2. - 2. + end if + !/ + end subroutine PrepKernelIO + !/ + !/ ------------------------------------------------------------------- / + !/ + subroutine BiInterpWT(nk, nth, wn, th) + !/ + !/ 19-Apr-2019 : Origination ( Q. Liu ) + !/ 19-Apr-2019 : Extracted from a few subrs. of mod_xnl4v5.f90 + !/ ( Q. Liu ) + !/ 01-Apr-2020 : Boundary conditions ( Q. Liu ) + !/ + ! 1. Purpose: + ! Calculate weights for the bilinear interpolation. + ! + ! 2. Method: + ! See also Fig. 9 of van Vledder (2006, CE) and mod_xnl4v5.f90 (WRT). + ! [q_t13v4, q_weight, q_makegrid + !/ + implicit none + ! + integer, intent(in) :: nk + integer, intent(in) :: nth + real, intent(in) :: wn(nk) ! k + real, intent(in) :: th(nth) ! θ + ! + integer :: iq, jkU, jk4, jk4p, jth4T, jth4, jth4p + real :: dth, aRef, k4T, angR, & + r_jk, r_jth, delK, w_k4, w_th4 + real :: kmin, kmax, k4R + real :: qr_kpow + ! + ! Initialization + qi_bind = 0 + qr_bwgh = 0. + if (qi_bound .eq. 1) qr_bdry = 1. + ! + ! Get power law for F(k) from qi_fpow for E(f) + ! E(f) df = F(k) dk → F(k) ~ f^n * cg = k^{(n-1)/2} + ! N(k) = F(k) / ω ~ k^{n/2-1} + ! C(k) = N(k) / k ~ k^{n/2-1 -1} + qr_kpow = qr_fpow / 2. - 2. -! Kmin & Kmax - kmin = minval(wn) - kmax = maxval(wn) -! -! In general, th(nth) in [0, 2π). Note however, it is not the case when -! the first directional bin defined in ww3_grid.inp (RTH0) is not zero. - dth = qr_tpi / real(nth) - aRef = th(1) -! -! qr_k4x(nnz), qr_k4y(nnz), wn(nk) are already available for use - do iq = 1, qi_nnz - k4R = sqrt(qr_k4x(iq)**2. + qr_k4y(iq)**2.) ! k₄ - angR= atan2(qr_k4y(iq), qr_k4x(iq)) ! θ₄ [-π, π] -! Boundary - if (qi_bound .eq. 1) then - k4T = max(kmin, min(k4R, kmax)) - else - k4T = k4R ! already bounded in [kmin, kmax] - end if -! -! Layout of surrouding four (f, θ) grid points -! -! (θ)↑ -! ↑ ₄ ₃ -! jth4+1 ▪ ----------- ▪ -! | | -! | r_jth) | -! w- |---✗ (r_jk, | -! t| | | | -! h| |₁ | |₂ -! 4- jth4 ▪ ----------- ▪ → → (k) -! jk4 jk4+1 -! |---| -! wk4 -! -! i) θ index (counted counterclockwisely) - r_jth = (angR - aRef) / dth + 1. - jth4T = floor(r_jth) ! 'll be revised later - w_th4 = r_jth - real(jth4T) ! dirc. weight -! - jth4 = mod(jth4T-1+nth, nth) + 1 ! wrap around 2π - jth4p = mod(jth4T+nth, nth) + 1 -! -! ii) k index (counted in an ascending order). Note, as required in -! FindQuartetConfig, k4T >= kmin & k4T <= kmax are already satisfied. -! Thus, the resulted jkU will be in [1, nk]. -! Two special cases: -! / 1, k4T = kmin -! jkU = | -! \ NK, k4T = kmax or k4T in (wn(nk-1), kmax) -! - jkU = 1 - do while (k4T > wn(jkU)) - jkU = jkU + 1 - if (jkU > nk) exit ! impossible in our case - end do -! - if (jkU .eq. 1) then ! k4T = kmin - r_jk = 1. - else ! k4T in (kmin, kmax] - delK = wn(jkU) - wn(jkU-1) ! Δk - r_jk = real(jkU - 1.) + (k4T - wn(jkU-1)) / delK - end if -! Parse r_jk - jk4 = floor(r_jk) ! in [1, nk] - w_k4 = r_jk - real(jk4) - jk4p = min(jk4+1, nk) ! k4T = kmax ← min func. -! -! Store indices (in 1D vector; jkth = ith + (ik-1) * nth) - qi_bind(1, iq) = jth4 + (jk4 - 1) * nth - qi_bind(2, iq) = jth4 + (jk4p - 1) * nth - qi_bind(3, iq) = jth4p + (jk4p - 1) * nth - qi_bind(4, iq) = jth4p + (jk4 - 1) * nth -! -! Store weights - qr_bwgh(1, iq) = (1. - w_k4) * (1. - w_th4) - qr_bwgh(2, iq) = w_k4 * (1. - w_th4) - qr_bwgh(3, iq) = w_k4 * w_th4 - qr_bwgh(4, iq) = (1. - w_k4) * w_th4 -! -! Note that the qi_bind & qr_bwgh do not make full sense when -! k4 < kmin (k indices are not correct at all) or k4 > kmax (k index = NK) -! because we have capped k4T in between kmin and kmax. -! But no need to worry about this because -! 1) C(k) = 0. when k < kmin -! 2) C(k) = C(NK) * power decay when k > kmax -! - if (qi_bound .eq. 1) then - if (k4R < kmin) then - qr_bdry(iq) = 0. - else if (k4R > kmax) then - qr_bdry(iq) = (k4R/kmax)**qr_kpow - end if - end if -! - end do -!/ - end subroutine BiInterpWT -!/ -!/ ------------------------------------------------------------------- / -!/ - subroutine CalcQRSNL(nk, nth, sig, th, & - t0, t1, Cvk0, Cvk1, & - Inpqr0, Snl, Dnl, Kurt) -!/ -!/ 09-Dec-2018 : Origination ( Q. Liu ) -!/ 09-Dec-2018 : Extracted from Odin's subr. `calcQRSNL` -!/ ( Q. Liu ) -!/ 10-Jun-2019 : Include Janssen's KE properly ( Q. Liu ) -!/ 07-Jun-2021 : Switch off the cal. of kurtosis (!|KT|) -!/ ( Q. Liu ) -!/ -! 1. Purpose: -! Calculate the nonlinear transfer rates for a given frequency -! grid and given action density spectrum C(\vec{k}). -! -! According to J09 and GS13, C(\vec{k}) is given by -! / -! m0 = | F(\vec{k}) d \vec{k} -! / -! -! F(\vec{k}) = ω C(\vec{k}) / g, -! -! whereas the wave action density spectrum used in WW3 is given by -! F(\vec{k}) d \vec{k} = F(k, θ) dk dθ -! = N(k, θ) ω dk dθ -! -! Thus, we have -! C(\vec{k}) = N * g / k. -! -! 2. Method -! See GS13 & GB16 for all the details. -! -! ◆ t0, t1 here are time `relative` to the begining time of the -! simulaiton, rather than the `absolute` time -! -! ◆ Cvk0, Cvk1, Snl, Dnl shoud be organized/stored in the same way as -! qr_kx, qr_ky, qr_dk, qr_om -!/ - implicit none -! - integer, intent(in) :: nk ! # of frequencies - integer, intent(in) :: nth ! # of directions - real, intent(in) :: sig(nk) ! radian frequency (rad) - real, intent(in) :: th(nth) ! θ (rad) [equally spaced, - ! but may start from non-zero -! - real, intent(inout) :: t0 ! previous time step - real, intent(inout) :: Cvk0(nk*nth) ! Action density @ t0 - complex, intent(inout) :: Inpqr0(:) ! I(t) @ t0 -! - real, intent(in) :: t1 ! current time step - real, intent(in) :: Cvk1(nk*nth) ! Action density @ t1 - ! ... C(\vec{k}) -! - real, intent(out) :: Snl(nk*nth) ! Snl = dC/dt - real, intent(out) :: Dnl(nk*nth) ! Dnl - real, intent(out) :: Kurt ! Kurtosis -! -! Local parameters -! - real :: DelT ! Δt - logical, save :: FlRead = .true. - integer :: num_I, ns - real :: Dvk0(nk*nth),& ! Odin's discrete Cvk @ t0 - Dvk1(nk*nth) ! ... @ t1 - real, allocatable, save :: Cvk0_R(:), & ! C₄ @ t0 - Cvk1_R(:) ! @ t1 - real, allocatable, save :: Fnpqr0(:), & ! C prod. @ t0 - Fnpqr1(:), & ! C prod. @ t1 - Mnpqr (:) ! δC_1/δt * δk_1 - complex, allocatable, save :: Inpqr1(:), & ! I(t) @ t1 - ETau(:), & ! exp(iΔωt) - EDelT(:) ! exp(iΔωΔt) -! - real, allocatable, save :: Mnp1D(:), Mnp2D(:, :) - real :: SecM2 ! Second-order moment² -!/ -! -! Initilization - ns = nk * nth - qi_nrsm = ns * ns -! -! Only constant depth is allowed now. Accordingly, we only need a single -! binary config file which provides the wavenumber grid and kernel -! coefficients. -! -! Read quartets & kernel coefficients in - if (FlRead) then -! Only read data once - call PrepKernelIO(nk, nth, sig, th, 'READ') - FlRead = .false. -! write(*, *) "⊚ → [R] FLag for Reading Kernels becomes |", FlRead, "|" -! Allocate arrays -! ✓ A variable with the SAVE attribute retains its value and definition, -! association, and `allocation` status on exit from a procedure -! - if (allocated(Fnpqr0)) deallocate(Fnpqr0); allocate(Fnpqr0(qi_nnz)) - if (allocated(Fnpqr1)) deallocate(Fnpqr1); allocate(Fnpqr1(qi_nnz)) - if (allocated(ETau )) deallocate(ETau ); allocate(ETau (qi_nnz)) - if (allocated(EDelT )) deallocate(EDelT ); allocate(EDelT (qi_nnz)) - if (allocated(Mnpqr )) deallocate(Mnpqr ); allocate(Mnpqr (qi_nnz)) - if (allocated(Inpqr1)) deallocate(Inpqr1); allocate(Inpqr1(qi_nnz)) -! - if (allocated(Mnp1D)) deallocate(Mnp1D); allocate(Mnp1D(qi_nrsm)) - if (allocated(Mnp2D)) deallocate(Mnp2D); allocate(Mnp2D(ns, ns)) -! - if (qi_disc .eq. 0) then - if (allocated(Cvk0_R)) deallocate(Cvk0_R); allocate(Cvk0_R(qi_nnz)) - if (allocated(Cvk1_R)) deallocate(Cvk1_R); allocate(Cvk1_R(qi_nnz)) - end if -! + ! Kmin & Kmax + kmin = minval(wn) + kmax = maxval(wn) + ! + ! In general, th(nth) in [0, 2π). Note however, it is not the case when + ! the first directional bin defined in ww3_grid.inp (RTH0) is not zero. + dth = qr_tpi / real(nth) + aRef = th(1) + ! + ! qr_k4x(nnz), qr_k4y(nnz), wn(nk) are already available for use + do iq = 1, qi_nnz + k4R = sqrt(qr_k4x(iq)**2. + qr_k4y(iq)**2.) ! k₄ + angR= atan2(qr_k4y(iq), qr_k4x(iq)) ! θ₄ [-π, π] + ! Boundary + if (qi_bound .eq. 1) then + k4T = max(kmin, min(k4R, kmax)) + else + k4T = k4R ! already bounded in [kmin, kmax] + end if + ! + ! Layout of surrouding four (f, θ) grid points + ! + ! (θ)↑ + ! ↑ ₄ ₃ + ! jth4+1 ▪ ----------- ▪ + ! | | + ! | r_jth) | + ! w- |---✗ (r_jk, | + ! t| | | | + ! h| |₁ | |₂ + ! 4- jth4 ▪ ----------- ▪ → → (k) + ! jk4 jk4+1 + ! |---| + ! wk4 + ! + ! i) θ index (counted counterclockwisely) + r_jth = (angR - aRef) / dth + 1. + jth4T = floor(r_jth) ! 'll be revised later + w_th4 = r_jth - real(jth4T) ! dirc. weight + ! + jth4 = mod(jth4T-1+nth, nth) + 1 ! wrap around 2π + jth4p = mod(jth4T+nth, nth) + 1 + ! + ! ii) k index (counted in an ascending order). Note, as required in + ! FindQuartetConfig, k4T >= kmin & k4T <= kmax are already satisfied. + ! Thus, the resulted jkU will be in [1, nk]. + ! Two special cases: + ! / 1, k4T = kmin + ! jkU = | + ! \ NK, k4T = kmax or k4T in (wn(nk-1), kmax) + ! + jkU = 1 + do while (k4T > wn(jkU)) + jkU = jkU + 1 + if (jkU > nk) exit ! impossible in our case + end do + ! + if (jkU .eq. 1) then ! k4T = kmin + r_jk = 1. + else ! k4T in (kmin, kmax] + delK = wn(jkU) - wn(jkU-1) ! Δk + r_jk = real(jkU - 1.) + (k4T - wn(jkU-1)) / delK + end if + ! Parse r_jk + jk4 = floor(r_jk) ! in [1, nk] + w_k4 = r_jk - real(jk4) + jk4p = min(jk4+1, nk) ! k4T = kmax ← min func. + ! + ! Store indices (in 1D vector; jkth = ith + (ik-1) * nth) + qi_bind(1, iq) = jth4 + (jk4 - 1) * nth + qi_bind(2, iq) = jth4 + (jk4p - 1) * nth + qi_bind(3, iq) = jth4p + (jk4p - 1) * nth + qi_bind(4, iq) = jth4p + (jk4 - 1) * nth + ! + ! Store weights + qr_bwgh(1, iq) = (1. - w_k4) * (1. - w_th4) + qr_bwgh(2, iq) = w_k4 * (1. - w_th4) + qr_bwgh(3, iq) = w_k4 * w_th4 + qr_bwgh(4, iq) = (1. - w_k4) * w_th4 + ! + ! Note that the qi_bind & qr_bwgh do not make full sense when + ! k4 < kmin (k indices are not correct at all) or k4 > kmax (k index = NK) + ! because we have capped k4T in between kmin and kmax. + ! But no need to worry about this because + ! 1) C(k) = 0. when k < kmin + ! 2) C(k) = C(NK) * power decay when k > kmax + ! + if (qi_bound .eq. 1) then + if (k4R < kmin) then + qr_bdry(iq) = 0. + else if (k4R > kmax) then + qr_bdry(iq) = (k4R/kmax)**qr_kpow end if -! -! Screen output (check whether the kernel data are stored in memory) + end if + ! + end do + !/ + end subroutine BiInterpWT + !/ + !/ ------------------------------------------------------------------- / + !/ + subroutine CalcQRSNL(nk, nth, sig, th, & + t0, t1, Cvk0, Cvk1, & + Inpqr0, Snl, Dnl, Kurt) + !/ + !/ 09-Dec-2018 : Origination ( Q. Liu ) + !/ 09-Dec-2018 : Extracted from Odin's subr. `calcQRSNL` + !/ ( Q. Liu ) + !/ 10-Jun-2019 : Include Janssen's KE properly ( Q. Liu ) + !/ 07-Jun-2021 : Switch off the cal. of kurtosis (!|KT|) + !/ ( Q. Liu ) + !/ + ! 1. Purpose: + ! Calculate the nonlinear transfer rates for a given frequency + ! grid and given action density spectrum C(\vec{k}). + ! + ! According to J09 and GS13, C(\vec{k}) is given by + ! / + ! m0 = | F(\vec{k}) d \vec{k} + ! / + ! + ! F(\vec{k}) = ω C(\vec{k}) / g, + ! + ! whereas the wave action density spectrum used in WW3 is given by + ! F(\vec{k}) d \vec{k} = F(k, θ) dk dθ + ! = N(k, θ) ω dk dθ + ! + ! Thus, we have + ! C(\vec{k}) = N * g / k. + ! + ! 2. Method + ! See GS13 & GB16 for all the details. + ! + ! ◆ t0, t1 here are time `relative` to the begining time of the + ! simulaiton, rather than the `absolute` time + ! + ! ◆ Cvk0, Cvk1, Snl, Dnl shoud be organized/stored in the same way as + ! qr_kx, qr_ky, qr_dk, qr_om + !/ + implicit none + ! + integer, intent(in) :: nk ! # of frequencies + integer, intent(in) :: nth ! # of directions + real, intent(in) :: sig(nk) ! radian frequency (rad) + real, intent(in) :: th(nth) ! θ (rad) [equally spaced, + ! but may start from non-zero + ! + real, intent(inout) :: t0 ! previous time step + real, intent(inout) :: Cvk0(nk*nth) ! Action density @ t0 + complex, intent(inout) :: Inpqr0(:) ! I(t) @ t0 + ! + real, intent(in) :: t1 ! current time step + real, intent(in) :: Cvk1(nk*nth) ! Action density @ t1 + ! ... C(\vec{k}) + ! + real, intent(out) :: Snl(nk*nth) ! Snl = dC/dt + real, intent(out) :: Dnl(nk*nth) ! Dnl + real, intent(out) :: Kurt ! Kurtosis + ! + ! Local parameters + ! + real :: DelT ! Δt + logical, save :: FlRead = .true. + integer :: num_I, ns + real :: Dvk0(nk*nth),& ! Odin's discrete Cvk @ t0 + Dvk1(nk*nth) ! ... @ t1 + real, allocatable, save :: Cvk0_R(:), & ! C₄ @ t0 + Cvk1_R(:) ! @ t1 + real, allocatable, save :: Fnpqr0(:), & ! C prod. @ t0 + Fnpqr1(:), & ! C prod. @ t1 + Mnpqr (:) ! δC_1/δt * δk_1 + complex, allocatable, save :: Inpqr1(:), & ! I(t) @ t1 + ETau(:), & ! exp(iΔωt) + EDelT(:) ! exp(iΔωΔt) + ! + real, allocatable, save :: Mnp1D(:), Mnp2D(:, :) + real :: SecM2 ! Second-order moment² + !/ + ! + ! Initilization + ns = nk * nth + qi_nrsm = ns * ns + ! + ! Only constant depth is allowed now. Accordingly, we only need a single + ! binary config file which provides the wavenumber grid and kernel + ! coefficients. + ! + ! Read quartets & kernel coefficients in + if (FlRead) then + ! Only read data once + call PrepKernelIO(nk, nth, sig, th, 'READ') + FlRead = .false. + ! write(*, *) "⊚ → [R] FLag for Reading Kernels becomes |", FlRead, "|" + ! Allocate arrays + ! ✓ A variable with the SAVE attribute retains its value and definition, + ! association, and `allocation` status on exit from a procedure + ! + if (allocated(Fnpqr0)) deallocate(Fnpqr0); allocate(Fnpqr0(qi_nnz)) + if (allocated(Fnpqr1)) deallocate(Fnpqr1); allocate(Fnpqr1(qi_nnz)) + if (allocated(ETau )) deallocate(ETau ); allocate(ETau (qi_nnz)) + if (allocated(EDelT )) deallocate(EDelT ); allocate(EDelT (qi_nnz)) + if (allocated(Mnpqr )) deallocate(Mnpqr ); allocate(Mnpqr (qi_nnz)) + if (allocated(Inpqr1)) deallocate(Inpqr1); allocate(Inpqr1(qi_nnz)) + ! + if (allocated(Mnp1D)) deallocate(Mnp1D); allocate(Mnp1D(qi_nrsm)) + if (allocated(Mnp2D)) deallocate(Mnp2D); allocate(Mnp2D(ns, ns)) + ! + if (qi_disc .eq. 0) then + if (allocated(Cvk0_R)) deallocate(Cvk0_R); allocate(Cvk0_R(qi_nnz)) + if (allocated(Cvk1_R)) deallocate(Cvk1_R); allocate(Cvk1_R(qi_nnz)) + end if + ! + end if + ! + ! Screen output (check whether the kernel data are stored in memory) #ifdef W3_TS write(*, *) "◆ qr_depth :", qr_depth write(*, *) "◆ qr_oml :", qr_oml @@ -1744,181 +1744,181 @@ subroutine CalcQRSNL(nk, nth, sig, th, & write(*, *) "◆ qr_TKurt(:10) :", qr_TKurt(:10) write(*, *) "◆ qr_sumQR(:10) :", qr_sumQR(:10) #endif -! - num_I = size(Inpqr0) - if (num_I .ne. qi_nnz) then - write(*, 1001) 'CalcQRSNL' - call exit(1) + ! + num_I = size(Inpqr0) + if (num_I .ne. qi_nnz) then + write(*, 1001) 'CalcQRSNL' + call exit(1) + end if + ! + ! Start to calc. Snl term + if (qi_disc == 0) then + ! Define ΔC = dC/dt * Δk Δt, we have ΔC₁ = ΔC₂ = -ΔC₃ = -ΔC₄ (Δt can be + ! removed by taking the unit time) + ! + ! Cvk0/1_R (bilinear interp. or nearest bin) + if (qi_interp .eq. 0) then + Cvk0_R = Cvk0(qi_RR) + Cvk1_R = Cvk1(qi_RR) + ! + else if (qi_interp .eq. 1) then + Cvk0_R = qr_bwgh(1, :) * Cvk0(qi_bind(1, :)) + & + qr_bwgh(2, :) * Cvk0(qi_bind(2, :)) + & + qr_bwgh(3, :) * Cvk0(qi_bind(3, :)) + & + qr_bwgh(4, :) * Cvk0(qi_bind(4, :)) + ! + Cvk1_R = qr_bwgh(1, :) * Cvk1(qi_bind(1, :)) + & + qr_bwgh(2, :) * Cvk1(qi_bind(2, :)) + & + qr_bwgh(3, :) * Cvk1(qi_bind(3, :)) + & + qr_bwgh(4, :) * Cvk1(qi_bind(4, :)) + ! + if (qi_bound .eq. 1) then + Cvk0_R = Cvk0_R * qr_bdry + Cvk1_R = Cvk1_R * qr_bdry end if -! -! Start to calc. Snl term - if (qi_disc == 0) then -! Define ΔC = dC/dt * Δk Δt, we have ΔC₁ = ΔC₂ = -ΔC₃ = -ΔC₄ (Δt can be -! removed by taking the unit time) -! -! Cvk0/1_R (bilinear interp. or nearest bin) - if (qi_interp .eq. 0) then - Cvk0_R = Cvk0(qi_RR) - Cvk1_R = Cvk1(qi_RR) -! - else if (qi_interp .eq. 1) then - Cvk0_R = qr_bwgh(1, :) * Cvk0(qi_bind(1, :)) + & - qr_bwgh(2, :) * Cvk0(qi_bind(2, :)) + & - qr_bwgh(3, :) * Cvk0(qi_bind(3, :)) + & - qr_bwgh(4, :) * Cvk0(qi_bind(4, :)) -! - Cvk1_R = qr_bwgh(1, :) * Cvk1(qi_bind(1, :)) + & - qr_bwgh(2, :) * Cvk1(qi_bind(2, :)) + & - qr_bwgh(3, :) * Cvk1(qi_bind(3, :)) + & - qr_bwgh(4, :) * Cvk1(qi_bind(4, :)) -! - if (qi_bound .eq. 1) then - Cvk0_R = Cvk0_R * qr_bdry - Cvk1_R = Cvk1_R * qr_bdry - end if -! - end if -! -! F = [C₃ C₄ (C₁ + C₂) - C₁ C₂ (C₃ + C₄)] dk₂ dk₃ dk₄ ∙ dk₁ -! dk₄ vanishes with the δ function - Fnpqr0 = (Cvk0(qi_QQ) * Cvk0_R * ( & - Cvk0(qi_NN) + Cvk0(qi_PP) ) - & - Cvk0(qi_NN) * Cvk0(qi_PP) * ( & - Cvk0(qi_QQ) + Cvk0_R )) * & - qr_dk(qi_NN) * qr_dk(qi_PP) * qr_dk(qi_QQ) -! - Fnpqr1 = (Cvk1(qi_QQ) * Cvk1_R * ( & - Cvk1(qi_NN) + Cvk1(qi_PP) ) - & - Cvk1(qi_NN) * Cvk1(qi_PP) * ( & - Cvk1(qi_QQ) + Cvk1_R )) * & - qr_dk(qi_NN) * qr_dk(qi_PP) * qr_dk(qi_QQ) -! - else if (qi_disc == 1) then -! Used in GS13 & GB16 -! F = [C₃dk₃ C₄dk₄ (C₁dk₁ + C₂dk₂) - C₁dk₁ C₂dk₂ (C₃dk₃ + C₄dk₄)] -! It seems the bilinear interpolation for this discretization approach -! is not very meaningful. - Dvk0 = Cvk0 * qr_dk - Fnpqr0 = Dvk0(qi_QQ) * Dvk0(qi_RR) * ( & - Dvk0(qi_NN) + Dvk0(qi_PP) ) - & - Dvk0(qi_NN) * Dvk0(qi_PP) * ( & - Dvk0(qi_QQ) + Dvk0(qi_RR) ) -! - Dvk1 = Cvk1 * qr_dk - Fnpqr1 = Dvk1(qi_QQ) * Dvk1(qi_RR) * ( & - Dvk1(qi_NN) + Dvk1(qi_PP) ) - & - Dvk1(qi_NN) * Dvk1(qi_PP) * ( & - Dvk1(qi_QQ) + Dvk1(qi_RR) ) -! - end if -!|KT|! Calc m2 for Kurtosis estimation ((2.6) of Annekov & Shrira (2013)) -!|KT| SecM2 = sum(Cvk1 * qr_om * qr_dk) ** 2. -! -! write(*, *) '.... Input args: t0, t1 :', t0, t1 - if (abs(t1) < qr_eps) then -! t1 = 0.0 [essentially I₁ = 0 → I₀ = 0] - t0 = 0.0 - Cvk0 = Cvk1 - Inpqr0 = (0.0, 0.0) ! \int_{0}^{0} dt = 0 - Snl = 0.0 - Dnl = 0.0 - Kurt = 0.0 - else -! t1 ≠ 0.0 - DelT = t1 - t0 - if (DelT < 0.0) then - write(*, 1002) 'CalcQRSNL' - call exit(2) - end if - ETau = exp(qc_iu * cmplx(qr_dom * t1)) ! exp(iΔωt) - EDelT = exp(qc_iu * cmplx(qr_dom * DelT)) ! exp(iΔωΔt) -! -! ◆ Calc. I₁: note here I₁ = I(t₁) dk₁ dk₂ dk₃ for both qi_disc = 0/1 - if (qi_kev .eq. 0) then -! GKE from GS13, GB16 - Inpqr1 = Inpqr0 + cmplx(0.5 * DelT) * & - conjg(ETau) * & ! exp(-iΔωt) - (cmplx(Fnpqr0) * EDelT + cmplx(Fnpqr1)) - else if (qi_kev .eq. 1) then -! KE from J03 (Fnpqr1 is taken outside the time integral; Fnpqr0 is not -! used in this case; and the real part of Inpqr1 is sin(Δωt)/Δω, and -! the imaginary part is [1 - cos(Δωt)] / Δω -! Approximation used before -! Inpqr1 = Inpqr0 + cmplx(0.5 * DelT) * & -! conjg(ETau) * (EDelT + 1) -! - where (abs(qr_dom) < qr_eps) -! Δω = 0., sin(Δωt)/Δω ~ t, [1 - cos(Δωt)] / Δω ~ 0 - Inpqr1 = cmplx(t1, 0.) - elsewhere -! Δω ≠ 0., cacl. sin(Δωt)/Δω & [1 - cos(Δωt)] / Δω directly -! TODO: the sign of cos is not clear yet. - Inpqr1 = cmplx(sin(qr_dom * t1) / qr_dom, & - (1 - cos(qr_dom * t1)) / qr_dom) - end where - end if -! ◆ Snl [Tranfer Integal] - if (qi_kev .eq. 0) then -! GKE from GS13, GB16 - Mnpqr = 4.0 * (qr_TKern ** 2.) * real(ETau * Inpqr1) - else if (qi_kev .eq. 1) then -! KE from J03 -! Mnpqr = 4.0 * (qr_TKern ** 2.) * Fnpqr1 * real(ETau * Inpqr1) - Mnpqr = 4.0 * (qr_TKern ** 2.) * Fnpqr1 * real(Inpqr1) - end if -! Calc. Σ over Q, R [Mnpqr is a upper triangular sparse matrix] -! dN₁/dt = - dN₃/dt → anti-symmetric array operation -! Mnp1D = (Mnpqr - Mnpqr^{T}) × S_{qr} - call ASymSmatTimVec(qi_nrsm, Mnpqr, qi_icCos, qi_irCsr, qr_sumQR, Mnp1D, -1.0) -! Calc. Σ over P [Mnp2D is a upper triangular matrix] -! dN₁/dt = dN₂/dt → symmetric array operation -! Snl = {Σ (Mnp + Mnp^{T}) ⊙ S_{p}} / d\vec{k₁} - Mnp2D = reshape(Mnp1D, (/ns, ns/)) - Snl = sum((Mnp2D + transpose(Mnp2D)) * qr_sumNP, 2) / qr_dk -! ◆ Conservation Check + ! + end if + ! + ! F = [C₃ C₄ (C₁ + C₂) - C₁ C₂ (C₃ + C₄)] dk₂ dk₃ dk₄ ∙ dk₁ + ! dk₄ vanishes with the δ function + Fnpqr0 = (Cvk0(qi_QQ) * Cvk0_R * ( & + Cvk0(qi_NN) + Cvk0(qi_PP) ) - & + Cvk0(qi_NN) * Cvk0(qi_PP) * ( & + Cvk0(qi_QQ) + Cvk0_R )) * & + qr_dk(qi_NN) * qr_dk(qi_PP) * qr_dk(qi_QQ) + ! + Fnpqr1 = (Cvk1(qi_QQ) * Cvk1_R * ( & + Cvk1(qi_NN) + Cvk1(qi_PP) ) - & + Cvk1(qi_NN) * Cvk1(qi_PP) * ( & + Cvk1(qi_QQ) + Cvk1_R )) * & + qr_dk(qi_NN) * qr_dk(qi_PP) * qr_dk(qi_QQ) + ! + else if (qi_disc == 1) then + ! Used in GS13 & GB16 + ! F = [C₃dk₃ C₄dk₄ (C₁dk₁ + C₂dk₂) - C₁dk₁ C₂dk₂ (C₃dk₃ + C₄dk₄)] + ! It seems the bilinear interpolation for this discretization approach + ! is not very meaningful. + Dvk0 = Cvk0 * qr_dk + Fnpqr0 = Dvk0(qi_QQ) * Dvk0(qi_RR) * ( & + Dvk0(qi_NN) + Dvk0(qi_PP) ) - & + Dvk0(qi_NN) * Dvk0(qi_PP) * ( & + Dvk0(qi_QQ) + Dvk0(qi_RR) ) + ! + Dvk1 = Cvk1 * qr_dk + Fnpqr1 = Dvk1(qi_QQ) * Dvk1(qi_RR) * ( & + Dvk1(qi_NN) + Dvk1(qi_PP) ) - & + Dvk1(qi_NN) * Dvk1(qi_PP) * ( & + Dvk1(qi_QQ) + Dvk1(qi_RR) ) + ! + end if + !|KT|! Calc m2 for Kurtosis estimation ((2.6) of Annekov & Shrira (2013)) + !|KT| SecM2 = sum(Cvk1 * qr_om * qr_dk) ** 2. + ! + ! write(*, *) '.... Input args: t0, t1 :', t0, t1 + if (abs(t1) < qr_eps) then + ! t1 = 0.0 [essentially I₁ = 0 → I₀ = 0] + t0 = 0.0 + Cvk0 = Cvk1 + Inpqr0 = (0.0, 0.0) ! \int_{0}^{0} dt = 0 + Snl = 0.0 + Dnl = 0.0 + Kurt = 0.0 + else + ! t1 ≠ 0.0 + DelT = t1 - t0 + if (DelT < 0.0) then + write(*, 1002) 'CalcQRSNL' + call exit(2) + end if + ETau = exp(qc_iu * cmplx(qr_dom * t1)) ! exp(iΔωt) + EDelT = exp(qc_iu * cmplx(qr_dom * DelT)) ! exp(iΔωΔt) + ! + ! ◆ Calc. I₁: note here I₁ = I(t₁) dk₁ dk₂ dk₃ for both qi_disc = 0/1 + if (qi_kev .eq. 0) then + ! GKE from GS13, GB16 + Inpqr1 = Inpqr0 + cmplx(0.5 * DelT) * & + conjg(ETau) * & ! exp(-iΔωt) + (cmplx(Fnpqr0) * EDelT + cmplx(Fnpqr1)) + else if (qi_kev .eq. 1) then + ! KE from J03 (Fnpqr1 is taken outside the time integral; Fnpqr0 is not + ! used in this case; and the real part of Inpqr1 is sin(Δωt)/Δω, and + ! the imaginary part is [1 - cos(Δωt)] / Δω + ! Approximation used before + ! Inpqr1 = Inpqr0 + cmplx(0.5 * DelT) * & + ! conjg(ETau) * (EDelT + 1) + ! + where (abs(qr_dom) < qr_eps) + ! Δω = 0., sin(Δωt)/Δω ~ t, [1 - cos(Δωt)] / Δω ~ 0 + Inpqr1 = cmplx(t1, 0.) + elsewhere + ! Δω ≠ 0., cacl. sin(Δωt)/Δω & [1 - cos(Δωt)] / Δω directly + ! TODO: the sign of cos is not clear yet. + Inpqr1 = cmplx(sin(qr_dom * t1) / qr_dom, & + (1 - cos(qr_dom * t1)) / qr_dom) + end where + end if + ! ◆ Snl [Tranfer Integal] + if (qi_kev .eq. 0) then + ! GKE from GS13, GB16 + Mnpqr = 4.0 * (qr_TKern ** 2.) * real(ETau * Inpqr1) + else if (qi_kev .eq. 1) then + ! KE from J03 + ! Mnpqr = 4.0 * (qr_TKern ** 2.) * Fnpqr1 * real(ETau * Inpqr1) + Mnpqr = 4.0 * (qr_TKern ** 2.) * Fnpqr1 * real(Inpqr1) + end if + ! Calc. Σ over Q, R [Mnpqr is a upper triangular sparse matrix] + ! dN₁/dt = - dN₃/dt → anti-symmetric array operation + ! Mnp1D = (Mnpqr - Mnpqr^{T}) × S_{qr} + call ASymSmatTimVec(qi_nrsm, Mnpqr, qi_icCos, qi_irCsr, qr_sumQR, Mnp1D, -1.0) + ! Calc. Σ over P [Mnp2D is a upper triangular matrix] + ! dN₁/dt = dN₂/dt → symmetric array operation + ! Snl = {Σ (Mnp + Mnp^{T}) ⊙ S_{p}} / d\vec{k₁} + Mnp2D = reshape(Mnp1D, (/ns, ns/)) + Snl = sum((Mnp2D + transpose(Mnp2D)) * qr_sumNP, 2) / qr_dk + ! ◆ Conservation Check #ifdef W3_TS - write(*, '(A, E15.3)') ' ← {WW3 GKE } ΣSnl(k) * dk: ', sum(Snl * qr_dk) + write(*, '(A, E15.3)') ' ← {WW3 GKE } ΣSnl(k) * dk: ', sum(Snl * qr_dk) #endif -! -! ◆ Dnl [Diagonal term] -! i) it is easy to calculate Dnl for Janssen's KE (but we may -! have to abandon the sparse array approach) -! ii) it is challenging to get Dnl for GKE. - Dnl = 0.0 - Kurt = 0.0 -! -!|KT|! ◆ Kurtosis -!|KT| if (qi_kev .eq. 0) then -!|KT|! GKE from GS13, GB16 -!|KT| Mnpqr = -3.0 / SecM2 * qr_TKurt * aimag(ETau * Inpqr1) -!|KT| else if (qi_kev .eq. 1) then -!|KT|! KE from J03 (here the imaginary part becomes [1 - cos(Δωt)] / Δω -!|KT|! Mnpqr = -3.0 / SecM2 * qr_TKurt * Fnpqr1 * aimag(ETau * Inpqr1) -!|KT| Mnpqr = -3.0 / SecM2 * qr_TKurt * Fnpqr1 * aimag(Inpqr1) -!|KT| end if -!|KT|! Calc. Σ over Q, R [Mnpqr is a upper triangular sparse matrix] -!|KT|! symmetric array operation Mnp1D = (Mnpqr - Mnpqr^{T}) × S_{qr} -!|KT| call ASymSmatTimVec(qi_nrsm, Mnpqr, qi_icCos, qi_irCsr, qr_sumQR, Mnp1D, 1.0) -!|KT| Mnp2D = reshape(Mnp1D, (/ns, ns/)) -!|KT| Kurt = sum((Mnp2D + transpose(Mnp2D)) * qr_sumNP) -! -! I₁ → I₀ for next computation (time step) - t0 = t1 - Cvk0 = Cvk1 - Inpqr0 = Inpqr1 - end if -! -! write(*, *) '.... Output args: t0, t1 :', t0, t1 -! -! Formats - 1001 FORMAT(/' *** GKE ERROR IN gkeModule : '/ & - ' Subr. ', A, ': the stored total number of quartets & - & and the size of Inpqr0 do not match !'/) - 1002 FORMAT(/' *** GKE ERROR IN gkeModule : '/ & - ' Subr. ', A, ': t0 ≤ t1 is not satisfied !'/) -!/ - end subroutine CalcQRSNL -!/ -!/ ------------------------------------------------------------------- / + ! + ! ◆ Dnl [Diagonal term] + ! i) it is easy to calculate Dnl for Janssen's KE (but we may + ! have to abandon the sparse array approach) + ! ii) it is challenging to get Dnl for GKE. + Dnl = 0.0 + Kurt = 0.0 + ! + !|KT|! ◆ Kurtosis + !|KT| if (qi_kev .eq. 0) then + !|KT|! GKE from GS13, GB16 + !|KT| Mnpqr = -3.0 / SecM2 * qr_TKurt * aimag(ETau * Inpqr1) + !|KT| else if (qi_kev .eq. 1) then + !|KT|! KE from J03 (here the imaginary part becomes [1 - cos(Δωt)] / Δω + !|KT|! Mnpqr = -3.0 / SecM2 * qr_TKurt * Fnpqr1 * aimag(ETau * Inpqr1) + !|KT| Mnpqr = -3.0 / SecM2 * qr_TKurt * Fnpqr1 * aimag(Inpqr1) + !|KT| end if + !|KT|! Calc. Σ over Q, R [Mnpqr is a upper triangular sparse matrix] + !|KT|! symmetric array operation Mnp1D = (Mnpqr - Mnpqr^{T}) × S_{qr} + !|KT| call ASymSmatTimVec(qi_nrsm, Mnpqr, qi_icCos, qi_irCsr, qr_sumQR, Mnp1D, 1.0) + !|KT| Mnp2D = reshape(Mnp1D, (/ns, ns/)) + !|KT| Kurt = sum((Mnp2D + transpose(Mnp2D)) * qr_sumNP) + ! + ! I₁ → I₀ for next computation (time step) + t0 = t1 + Cvk0 = Cvk1 + Inpqr0 = Inpqr1 + end if + ! + ! write(*, *) '.... Output args: t0, t1 :', t0, t1 + ! + ! Formats +1001 FORMAT(/' *** GKE ERROR IN gkeModule : '/ & + ' Subr. ', A, ': the stored total number of quartets & + & and the size of Inpqr0 do not match !'/) +1002 FORMAT(/' *** GKE ERROR IN gkeModule : '/ & + ' Subr. ', A, ': t0 ≤ t1 is not satisfied !'/) + !/ + end subroutine CalcQRSNL + !/ + !/ ------------------------------------------------------------------- / end module w3gkemd !/ ------------------------------------------------------------------- / diff --git a/model/src/w3gridmd.F90 b/model/src/w3gridmd.F90 index e33a5c119..ec6ebbde2 100644 --- a/model/src/w3gridmd.F90 +++ b/model/src/w3gridmd.F90 @@ -1,760 +1,760 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3GRIDMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | J. H. Alves | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2021 | -!/ +-----------------------------------+ -!/ -!/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 27-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Add UNFORMATTED bath file option. -!/ Read options with namelists. -!/ 14-Feb-2000 : Adding exact Snl ( version 2.01 ) -!/ 04-May-2000 : Non central source term int. ( version 2.03 ) -!/ 24-Jan-2001 : Flat grid option. ( version 2.06 ) -!/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) -!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) -!/ 27-Feb-2001 : O0 output switch added. ( version 2.08 ) -!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) -!/ 29-Mar-2001 : Sub-grid island treatment. ( version 2.10 ) -!/ 20-Jul-2001 : Clean up. ( version 2.11 ) -!/ 12-Sep-2001 : Clean up. ( version 2.13 ) -!/ 09-Nov-2001 : Clean up. ( version 2.14 ) -!/ 11-Jan-2002 : Sub-grid ice treatment. ( version 2.15 ) -!/ 17-Jan-2002 : DSII bug fix. ( version 2.16 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 26-Nov-2002 : Adding first version of NL-3/4. ( version 3.01 ) -!/ Removed before distribution in 3.12. -!/ 26-Dec-2002 : Relaxing CFL time step. ( version 3.02 ) -!/ 01-Aug-2003 : Modify GSE correction for moving gr.( version 3.03 ) -!/ Add offset option for first direction. -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 04-May-2005 : Allow active points at edge. ( version 3.07 ) -!/ 07-Jul-2005 : Add MAPST2 and map processing. ( version 3.07 ) -!/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) -!/ 23-Jun-2006 : Adding alternative source terms. ( version 3.09 ) -!/ Module W3SLN1MD, dummy for others. -!/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 28-Oct-2006 : Spectral partitioning. ( version 3.09 ) -!/ 09-Jan-2007 : Correct edges of read mask. ( version 3.10 ) -!/ 26-Mar-2007 : Add to spectral partitioning. ( version 3.11 ) -!/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 18-Sep-2007 : Adding WAM4 physics option. ( version 3.13 ) -!/ ( F. Ardhuin ) -!/ 09-Oct-2007 : Adding bottom scattering SBS1. ( version 3.13 ) -!/ ( F. Ardhuin ) -!/ 22-Feb-2008 : Initialize TRNX-Y properly. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 23-Jul-2009 : Modification of ST3 namelist . ( version 3.14-SHOM ) -!/ 31-Mar-2010 : Addition of shoreline reflection ( version 3.14-IFREMER ) -!/ 29-Jun-2010 : Adding Stokes drift profile output ( version 3.14-IFREMER ) -!/ 30-Aug-2010 : Adding ST4 option ( version 3.14-IFREMER ) - -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Oct-2010 : Clean up of unstructured grids ( version 3.14.4 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. Change GLOBAL -!/ input in ww3_grid.inp to CSTRG. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 25-Jun-2011 : Adding movable bed friction ( version 4.01 ) -!/ 16-Sep-2011 : Clean up. ( version 4.05 ) -!/ 01-Dec-2011 : New namelist for reflection ( version 4.05 ) -!/ 01-Mar-2012 : Bug correction for NLPROP in ST2 ( version 4.05 ) -!/ 12-Jun-2012 : Add /RTD rotated grid option. JGLi ( version 4.06 ) -!/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear -!/ filter (SNLS) from 3.15 (HLT). ( version 4.07 ) -!/ 02-Sep-2012 : Clean up of reflection and UG grids ( version 4.08 ) -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) -!/ 19-Dec-2012 : Add NOSWLL as namelist variable. ( version 4.OF ) -!/ 05-Mar-2013 : Adjusted default roughness for rocks( version 4.09 ) -!/ 01-Jun-2013 : Adding namelist for spectral output ( version 4.10 ) -!/ 12-Sep-2013 : Adding Arctic part for SMC grid. ( version 4.11 ) -!/ 01-Nov-2013 : Changed UG list name to UNST ( version 4.12 ) -!/ 11-Nov-2013 : Make SMC and RTD option compatible. ( version 4.13 ) -!/ 13-Nov-2013 : Moved out reflection to W3UPDTMD ( version 4.12 ) -!/ 27-Jul-2013 : Adding free infragravity waves ( version 4.15 ) -!/ 02-Dec-2013 : Update of ST4 ( version 4.16 ) -!/ 16-Feb-2014 : Adds wind bias correction: WCOR ( version 5.00 ) -!/ 10-Mar-2014 : Adding namelist for IC2 ( version 5.01 ) -!/ 29-May-2014 : Adding namelist for IC3 ( version 5.01 ) -!/ 15 Oct-2015 : Change SMC grid input files. JGLi ( version 5.09 ) -!/ 10-Jan-2017 : Changes for US3D and USSP ( version 6.01 ) -!/ 20-Jan-2017 : Bug fix for mask input from file. ( version 6.02 ) -!/ 01-Mar-2018 : RTD poles info read from namelist ( version 6.02 ) -!/ 14-Mar-2018 : Option to read UNST boundary file ( version 6.02 ) -!/ 26-Mar-2018 : Sea-point only Wnd/Cur input. JGLi ( version 6.02 ) -!/ 15-May-2018 : Dry sea points over zlim ( version 6.04 ) -!/ 06-Jun-2018 : add Implicit grid parameters for unstructured grids -!/ add DEBUGGRID/DEBUGSTP ( version 6.04 ) -!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) -!/ 20-Jun-2018 : Update of ST6 (Q. Liu) ( version 6.06 ) -!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) -!/ 27-Aug-2018 : Add WBT parameter ( version 6.06 ) -!/ 22-Jan-2020 : Update default values for IS2 ( version 7.05 ) -!/ 20-Feb-2020 : Include Romero's dissipation in ST4 ( version 7.06 ) -!/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) -!/ 18-Jun-2020 : Adds 360-day calendar option ( version 7.08 ) -!/ 24-Jun-2020 : RTD output b. c. to rotated grid. ( version 7.11 ) -!/ 05-Jan-2021 : Update SMC grid for multi-grid. JGLi( version 7.13 ) -!/ 27-May-2021 : Updates for IC5 (Q. Liu) ( version 7.12 ) -!/ 27-May-2021 : Moved to a subroutine ( version 7.13 ) -!/ 07-Jun-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.13 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! "Grid" preprocessing subroutine, which writes a model definition -! file containing the model parameter settigs and grid data. -! -! 2. Method : -! -! Information is read from the file ww3_grid.inp (NDSI), or -! preset in this subroutine. A model definition file mod_def.ww3 is -! then produced by W3IOGR. Note that the name of the model -! definition file is set in W3IOGR. -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! NDSI Int. Input unit number ("ww3_grid.inp"). -! NDSS Int. Scratch file. -! NDSG Int. Grid unit ( may be NDSI ) -! NDSTR Int. Sub-grid unit ( may be NDSI or NDSG ) -! VSC Real Scale factor. -! VOF Real Add offset. -! ZLIM Real Limiting bottom depth, used to define land. -! IDLA Int. Layout indicator used by INA2R. -! IDFM Int. Id. FORMAT indicator. -! RFORM C*16 Id. FORMAT. -! FNAME C*60 File name with bottom level data. -! FROM C*4 Test string for open, 'UNIT' or 'FILE' -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3DIMS Subr. Id. Set array dims for a spectral grid. -! W3DIMX Subr. Id. Set array dims for a spatial grid. -! W3GRMP Subr. W3GSRUMD Compute bilinear interpolation for point -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! W3DMO5 Subr. Id. Set array dims for output type 5. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input file -! EXTCDE Subr. Id. Abort program as graceful as possible. -! DISTAB Subr. W3DISPMD Make tables for solution of the -! dispersion relation. -! READNL Subr. Internal Read namelist. -! INAR2R Subr. W3ARRYMD Read in an REAL array. -! PRTBLK Subr. Id. Print plot of array. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! ww3_grid program -! -! 6. Error messages : -! -! 7. Remarks : -! -! Physical grid : -! ----------------- -! -! The physical grid is defined by a grid counter IX defining the -! discrete longitude and IY defining the discrete latitude as shown -! below. For mathemathical convenience, these grid axes will -! generally be denoted as the X and Y axes. Two-dimensional arrays -! describing parameters on this grid are given as A(IY,IX). -! -! IY=NY -! ^ | | | | | | ^ N -! | |------|------|------|------|------|---- | -! | | :: | 25 | 26 | 27 | 28 | --|-- -! |------|------|------|------|------|---- | -! IY=3 | :: | :: | 9 | 10 | 11 | | -! |------|------|------|------|------|---- -! IY=2 | :: | 1 | 2 | :: | 3 | -! |------|------|------|------|------|---- -! IY=1 | :: | :: | :: | :: | :: | -! +------+------+------+------+------+---- -! IX=1 IX=2 IX=3 IX=4 IX=5 ---> IX=NX -! -! :: is a land point. -! -! To reduce memory usage of the model, spectra are stored for sea -! points only, in a one-dimensional grid with the length NSEA. This -! grid is called the storage grid. The definition of the counter -! in the storage grid is graphically depicted above. To transfer -! data between the two grids, the maps MAPFS and MAPSF are -! determined. MAPFS gives the counter of the storage grid ISEA -! for every physical grid point (IY,IX), such that -! -! MAPFS(IY,IX) = ISEA -! -! ISEA = 0 corresponds to land points. The map MAPSF gives the grid -! counters (IY,IX) for a given storage point ISEA. -! -! MAPSF(ISEA,1) = IX -! MAPSF(ISEA,2) = IY -! MAPSF(ISEA,3) = IY+(IX-1)*NY ( filled during reading ) -! -! Finally, a status maps MAPSTA and MAPST2 are determined, where -! the status indicator ISTAT = MAPSTA(IY,IX) determines the type -! of the grid point. -! -! ISTAT Means -! --------------------------------------------------- -! 0 Point excluded from grid. -! (-)1 Sea point -! (-)2 "Active" boundary point (data prescribed) -! -! For ISTAT=0, the secondary status counter ISTA2 is defined as -! -! ISTA2 Means -! --------------------------------------------------- -! 0 Land point. -! 1 Point excluded from grid. -! -! Negative values of ISTAT identify points that are temporarily -! taken out of the computation. For these points ISTA2 are -! defined per bit -! -! BIT Means -! --------------------------------------------------- -! 1 Ice flag (1 = ice coverage) -! 2 Dry flag (1 = dry point with depth 0) -! 3 Inferred land in multi-grid model. -! 4 Masking in multi-grid model. -! 5 land point flag for relocatable grid. -! -! Thus ISTA2=0 for ISTAT<0 is in error, ISTA2=1 means ice cover, -! ISTA2=3 means ice on dry point, etc. -! -! Spectral grid : -! ----------------- -! -! In the spectral grid (and in physical space in general), -! the cartesian convention for directions is used, i.e., the -! direction 0 corresponds to waves propagating in the positive -! X-direction and 90 degr. corresponds to waves propagating in -! the positive Y-direction. Similar definitions are used for the -! internal description of winds and currents. Output can obviously -! be transformed according to any preferred convention. -! -! ITH=NTH -! ^ | | | | | -! | |------|------|------|------|---- -! | | | | | | TH(3) = DTH*2. -! |------|------|------|------|---- -! ITH=2 | | | | | TH(2) = DTH -! |------|------|------|------|---- -! ITH=1 | | | | | TH(1) = 0. -! +------+------+------+------+---- -! IK=1 IK=2 IK=3 IK=4 ---> IK=NK -! -! The spectral grid consists of NK wavenumbers. The first -! wavenumber IK=1 corresponds to the longest wave. The wavenumber -! grid varies in space, as given by an invariant relative freq. -! grid and the local depth. The spectral grid furthermore contains -! NTH directions, equally spaced over a full circle. the first -! direction corresponds to the direction 0, etc. -! -! (Begin SMC description) -! -! Spherical Multiple-Cell (SMC) grid -! ----------------------------------- -! -! SMC grid is a multi-resolution grid using cells of multiple times -! of each other. It is similar to the lat-lon grid using rectangular -! cells but only cells at sea points are retained. All land points -! have been removed from the model. At high latitudes, cells are -! merged longitudinally to relax the CFL resctiction on time steps. -! Near coastlines, cells are divided into quarters in a few steps so -! that high resolution is achieved to refine coastlines and resolve -! small islands. At present, three tiers of quarter cells are used. -! For locating purpose, a usual x-y counter is setup by the smallest -! cell size and starting from the south-west corner of the usual -! rectuangular domain. Each sea cell is then given a pair of x-y -! index, plus a pair of increments. These four index are stored in -! the cell array IJKCel(4, NCel), each row holds i, j, di, dj, and -! IJKDep holds ndps, where ndps is an integer depth in metre. If -! precision higher than a metre is required, it may use other unit -! (cm for instance) with a conversion factor. -! -! For transport calculation, two face arrays, IJKUFc(7, NUFc) and -! IJKVFc(7, NVFc), are also created to store the neighbouring cell -! sequential numbers and the face location and size. The 3 arrays -! are calculated outside the wave model and input from text files. -! -! Boundary condition is added for SMC grid so that it can be used for -! regional model as well. Most of the original boundary settings -! are reclaimed as long as the boundary condition file is provided -! by a lat-lon grid WW3 model, which will set the interpolation -! parameters in the boundary condition file. The NBI number is -! reset with an input value because the NX-Y double loop overcount -! the boundary cells for merged cells in the SMC grid. ISBPI -! boundary cell mapping array is fine as MAPFS uses duplicated cell -! number in any merged cell. From there, all original NBI loops are -! reusable. -! -! The whole Arctic can be included in the SMC grid if ARCTC variable -! is set to be .TRUE. within the SMC option. The ARCTC option appends -! the polar Arctic part above 86N to the existing SMC grid and uses -! a map-east reference direction for this extra polar region. -! Because the map-east direction changes with latitude and longitude -! the wave spectra defined to the map-east direction could not be -! mixed up with the conventional spectra defined to the local east -! direction. A rotation sub is provided for convertion from one to -! another. Propagation part will be calculated together, including -! the boundary cells. The boundary cells are then updated by -! assigning the corresponding inner cells to them after conversion. -! Boundary cells are duplicated northmost 4 rows of the global part -! and they can be excluded for source term and output if required. -! For convenience, Arctic cellls are all base level cells and are -! appended to the end of the global cells. If refined cells were -! used in the Arctic part, it would not be kept all together, making -! the sub-loops much more complicated. If refined resolution cells -! are required for a Arctic regional model, users may consider use -! the rotated SMC grid options (RTD and SMC). -! -! For more information about the SMC grid, please refer to -! Li, J.G. (2012) Propagation of Ocean Surface Waves on a Spherical -! Multiple-Cell Grid. J. Comput. Phys., 231, 8262-8277. online at -! http://dx.doi.org/10.1016/j.jcp.2012.08.007 -! -! (End SMC description) -! -! ICEWIND is the scale factor for reduction of wind input by ice -! concentration. Value specified corresponds to the fractional -! input for 100% ice concentration. Default is 1.0, meaning that -! 100% ice concentration result in zero wind input. -! Sin_in_ice=Sin_in_open_water * (1-ICE*ICEWIND) - -! -----------------------------------------------------------------* -! 8. Structure : -! -! ---------------------------------------------------------------- -! 1. Set up grid storage structure. -! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) -! 2.a I-O setup. -! b Print heading(s). -! 3. Prepare int. table for dispersion relation ( DISTAB ) -! 4. Read and process input file up to spectrum. -! a Get comment character -! b Name of grid -! c Define spectrum ( W3DIMS ) -! 5. Set-up discrete spectrum. -! a Directions. -! b Frequency for spectrum. -! 6. Read and process input file up to numerical parameters -! a Set model flags and time steps -! b Set / select source term package -! c Pre-process namelists. -! d Wind input source term. -! e Nonlinear interactions. -! f Whitecapping term. -! g Bottom friction source term. -! h Depth indiced breaking source term. -! i Triad interaction source term. -! j Bottom scattering source term. -! k Undefined source term. -! l Set / select propagaton scheme -! m Parameters for propagation scheme. -! n Set misc. parameters (ice, seeding, ...) -! o End of namelist processing -! p Set various other variables -! 7. Read and prepare grid. -! a Layout of grid -! b Storage of grid of grid -! c Read bottom depths -! d Set up temp map -! e Subgrid information -! 1 Info from input file -! 2 Open file and check if necessary -! 3 Read the data -! 4 Limit -! 8 Finalize status maps -! a Determine where to get the data -! Get data in parts from input file -! ---------------------------------------------------- -! b Read and update TMPSTA with bound. and excl. points. -! c Finalize excluded points -! ---------------------------------------------------- -! Read data from file -! ---------------------------------------------------- -! d Read data from file -! ---------------------------------------------------- -! e Get NSEA and other counters -! f Set up all maps ( W3DIMX ) -! 9. Prepare output boundary points. -! a Read -! b Update -! 10. Write model definition file. ( W3IOGR ) -! ---------------------------------------------------------------- -! -! 9. Switches : -! -! !/FLX1 Stresses according to Wu (1980). -! !/FLX2 Stresses according to T&C (1996). -! !/FLX3 Stresses according to T&C (1996) with cap on Cd. -! !/FLX4 Stresses according to Hwang (2011). -! !/FLX5 Direct use of stress from atmospheric model/input file. -! -! !/LN0 No linear input source term. -! !/SEED 'Seeding' of lowest frequency for sufficiently strong -! winds. Proxi for linear input. -! !/LN1 Cavaleri and Melanotte-Rizzoli with Tolman filter. -! -! !/ST0 No source terms included (input/dissipation) -! !/ST1 WAM-3 physics package. -! !/ST2 Tolman and Chalikov (1996) physics package. -! !/ST3 WAM 4+ source terms from P.A.E.M. Janssen and J-R. Bidlot -! !/ST4 Input and dissipation using saturation following Ardhuin et al. (2009,2010) -! Filipot & Ardhuin (2010) or Romero (2019) -! !/ST6 BYDRZ source term package featuring Donelan et al. -! (2006) input and Babanin et al. (2001,2010) dissipation. -! -! !/NL0 No nonlinear interactions. -! !/NL1 Discrete interaction approximation (DIA). -! !/NL2 Exact interactions (WRT). -! !/NL3 Generalized Multiple DIA (GMD). -! !/NL4 Two Scale Approximation -! !/NL5 Generalized Kinetic Equation (GKE) -! !/NLS Snl based HF filter. -! -! !/BT0 No bottom friction included. -! !/BT1 JONSWAP bottom friction package. -! !/BT4 SHOWEX bottom friction using movable bed roughness -! (Tolman 1994, Ardhuin & al. 2003) -! -! !/IC1 Sink term for interaction with ice (uniform k_i) -! !/IC2 Sink term for under-ice boundary layer friction -! (Liu et al. 1991: JGR 96 (C3), 4605-4621) -! (Liu and Mollo 1988: JPO 18 1720-1712) -! !/IC3 Sink term for interaction with ice (Wang and Shen method) -! (Wang and Shen JGR 2010) -! !/IC4 Sink term for empirical, frequency-dependent attenuation -! in ice (Wadhams et al. 1988: JGR 93 (C6) 6799-6818) -! !/IC5 Sink term for interaction with ice (effective medium mod.) -! (Mosig et al. 2015, Meylan et al. 2018, Liu et al. -! 2020) -! -! !/UOST Unresolved Obstacles Source Term (UOST), Mentaschi et al. 2015 -! -! !/DB0 No depth-induced breaking included. -! !/DB1 Battjes-Janssen depth-limited breaking. -! !/MLIM Mich-style limiter. -! -! !/TR0 No triad interactions included. -! -! !/BS0 No bottom scattering included. -! !/BS1 Routines from F. Ardhuin. -! -! !/PR1 First order propagation scheme. -! !/PR2 QUICKEST scheme with ULTIMATE limite and diffusion -! correction for swell dispersion. -! !/PR3 Averaging ULTIMATE QUICKEST scheme. -! -! !/RTD Rotated regular lat-lon grid. Special case is standard Polat=90. -! !/SMC Spherical Multiple-Cell grid, may includes the whole Arctic. -! -! !/MGG GSE correction for moving grid. -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T0 Enable test output tables for boundary output. -! -! !/O0 Print equivalent namelist setting to std out. -! !/O1 Print tables with boundary points as part of output. -! !/O2 Print MAPSTA as part of output. -! !/O2a Print land-sea mask in mask.ww3. -! !/O2b Print obstruction data. -! !/O2c Print extended status map. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ - USE W3TRIAMD - USE W3GSRUMD, ONLY: W3GRMP - USE W3ODATMD, ONLY: W3NOUT, W3SETO, W3DMO5 - USE W3IOGRMD, ONLY: W3IOGR - USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE +MODULE W3GRIDMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | J. H. Alves | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2021 | + !/ +-----------------------------------+ + !/ + !/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 27-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Add UNFORMATTED bath file option. + !/ Read options with namelists. + !/ 14-Feb-2000 : Adding exact Snl ( version 2.01 ) + !/ 04-May-2000 : Non central source term int. ( version 2.03 ) + !/ 24-Jan-2001 : Flat grid option. ( version 2.06 ) + !/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) + !/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) + !/ 27-Feb-2001 : O0 output switch added. ( version 2.08 ) + !/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) + !/ 29-Mar-2001 : Sub-grid island treatment. ( version 2.10 ) + !/ 20-Jul-2001 : Clean up. ( version 2.11 ) + !/ 12-Sep-2001 : Clean up. ( version 2.13 ) + !/ 09-Nov-2001 : Clean up. ( version 2.14 ) + !/ 11-Jan-2002 : Sub-grid ice treatment. ( version 2.15 ) + !/ 17-Jan-2002 : DSII bug fix. ( version 2.16 ) + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 26-Nov-2002 : Adding first version of NL-3/4. ( version 3.01 ) + !/ Removed before distribution in 3.12. + !/ 26-Dec-2002 : Relaxing CFL time step. ( version 3.02 ) + !/ 01-Aug-2003 : Modify GSE correction for moving gr.( version 3.03 ) + !/ Add offset option for first direction. + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 04-May-2005 : Allow active points at edge. ( version 3.07 ) + !/ 07-Jul-2005 : Add MAPST2 and map processing. ( version 3.07 ) + !/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) + !/ 23-Jun-2006 : Adding alternative source terms. ( version 3.09 ) + !/ Module W3SLN1MD, dummy for others. + !/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 28-Oct-2006 : Spectral partitioning. ( version 3.09 ) + !/ 09-Jan-2007 : Correct edges of read mask. ( version 3.10 ) + !/ 26-Mar-2007 : Add to spectral partitioning. ( version 3.11 ) + !/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) + !/ ( J. H. Alves ) + !/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) + !/ ( J. H. Alves ) + !/ 18-Sep-2007 : Adding WAM4 physics option. ( version 3.13 ) + !/ ( F. Ardhuin ) + !/ 09-Oct-2007 : Adding bottom scattering SBS1. ( version 3.13 ) + !/ ( F. Ardhuin ) + !/ 22-Feb-2008 : Initialize TRNX-Y properly. ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 23-Jul-2009 : Modification of ST3 namelist . ( version 3.14-SHOM ) + !/ 31-Mar-2010 : Addition of shoreline reflection ( version 3.14-IFREMER ) + !/ 29-Jun-2010 : Adding Stokes drift profile output ( version 3.14-IFREMER ) + !/ 30-Aug-2010 : Adding ST4 option ( version 3.14-IFREMER ) + + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 29-Oct-2010 : Clean up of unstructured grids ( version 3.14.4 ) + !/ (A. Roland and F. Ardhuin) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. Change GLOBAL + !/ input in ww3_grid.inp to CSTRG. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 25-Jun-2011 : Adding movable bed friction ( version 4.01 ) + !/ 16-Sep-2011 : Clean up. ( version 4.05 ) + !/ 01-Dec-2011 : New namelist for reflection ( version 4.05 ) + !/ 01-Mar-2012 : Bug correction for NLPROP in ST2 ( version 4.05 ) + !/ 12-Jun-2012 : Add /RTD rotated grid option. JGLi ( version 4.06 ) + !/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear + !/ filter (SNLS) from 3.15 (HLT). ( version 4.07 ) + !/ 02-Sep-2012 : Clean up of reflection and UG grids ( version 4.08 ) + !/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) + !/ 19-Dec-2012 : Add NOSWLL as namelist variable. ( version 4.OF ) + !/ 05-Mar-2013 : Adjusted default roughness for rocks( version 4.09 ) + !/ 01-Jun-2013 : Adding namelist for spectral output ( version 4.10 ) + !/ 12-Sep-2013 : Adding Arctic part for SMC grid. ( version 4.11 ) + !/ 01-Nov-2013 : Changed UG list name to UNST ( version 4.12 ) + !/ 11-Nov-2013 : Make SMC and RTD option compatible. ( version 4.13 ) + !/ 13-Nov-2013 : Moved out reflection to W3UPDTMD ( version 4.12 ) + !/ 27-Jul-2013 : Adding free infragravity waves ( version 4.15 ) + !/ 02-Dec-2013 : Update of ST4 ( version 4.16 ) + !/ 16-Feb-2014 : Adds wind bias correction: WCOR ( version 5.00 ) + !/ 10-Mar-2014 : Adding namelist for IC2 ( version 5.01 ) + !/ 29-May-2014 : Adding namelist for IC3 ( version 5.01 ) + !/ 15 Oct-2015 : Change SMC grid input files. JGLi ( version 5.09 ) + !/ 10-Jan-2017 : Changes for US3D and USSP ( version 6.01 ) + !/ 20-Jan-2017 : Bug fix for mask input from file. ( version 6.02 ) + !/ 01-Mar-2018 : RTD poles info read from namelist ( version 6.02 ) + !/ 14-Mar-2018 : Option to read UNST boundary file ( version 6.02 ) + !/ 26-Mar-2018 : Sea-point only Wnd/Cur input. JGLi ( version 6.02 ) + !/ 15-May-2018 : Dry sea points over zlim ( version 6.04 ) + !/ 06-Jun-2018 : add Implicit grid parameters for unstructured grids + !/ add DEBUGGRID/DEBUGSTP ( version 6.04 ) + !/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) + !/ 20-Jun-2018 : Update of ST6 (Q. Liu) ( version 6.06 ) + !/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) + !/ 27-Aug-2018 : Add WBT parameter ( version 6.06 ) + !/ 22-Jan-2020 : Update default values for IS2 ( version 7.05 ) + !/ 20-Feb-2020 : Include Romero's dissipation in ST4 ( version 7.06 ) + !/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) + !/ 18-Jun-2020 : Adds 360-day calendar option ( version 7.08 ) + !/ 24-Jun-2020 : RTD output b. c. to rotated grid. ( version 7.11 ) + !/ 05-Jan-2021 : Update SMC grid for multi-grid. JGLi( version 7.13 ) + !/ 27-May-2021 : Updates for IC5 (Q. Liu) ( version 7.12 ) + !/ 27-May-2021 : Moved to a subroutine ( version 7.13 ) + !/ 07-Jun-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.13 ) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! "Grid" preprocessing subroutine, which writes a model definition + ! file containing the model parameter settigs and grid data. + ! + ! 2. Method : + ! + ! Information is read from the file ww3_grid.inp (NDSI), or + ! preset in this subroutine. A model definition file mod_def.ww3 is + ! then produced by W3IOGR. Note that the name of the model + ! definition file is set in W3IOGR. + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! NDSI Int. Input unit number ("ww3_grid.inp"). + ! NDSS Int. Scratch file. + ! NDSG Int. Grid unit ( may be NDSI ) + ! NDSTR Int. Sub-grid unit ( may be NDSI or NDSG ) + ! VSC Real Scale factor. + ! VOF Real Add offset. + ! ZLIM Real Limiting bottom depth, used to define land. + ! IDLA Int. Layout indicator used by INA2R. + ! IDFM Int. Id. FORMAT indicator. + ! RFORM C*16 Id. FORMAT. + ! FNAME C*60 File name with bottom level data. + ! FROM C*4 Test string for open, 'UNIT' or 'FILE' + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3DIMS Subr. Id. Set array dims for a spectral grid. + ! W3DIMX Subr. Id. Set array dims for a spatial grid. + ! W3GRMP Subr. W3GSRUMD Compute bilinear interpolation for point + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! W3SETO Subr. Id. Point to selected model for output. + ! W3DMO5 Subr. Id. Set array dims for output type 5. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input file + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! DISTAB Subr. W3DISPMD Make tables for solution of the + ! dispersion relation. + ! READNL Subr. Internal Read namelist. + ! INAR2R Subr. W3ARRYMD Read in an REAL array. + ! PRTBLK Subr. Id. Print plot of array. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! ww3_grid program + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Physical grid : + ! ----------------- + ! + ! The physical grid is defined by a grid counter IX defining the + ! discrete longitude and IY defining the discrete latitude as shown + ! below. For mathemathical convenience, these grid axes will + ! generally be denoted as the X and Y axes. Two-dimensional arrays + ! describing parameters on this grid are given as A(IY,IX). + ! + ! IY=NY + ! ^ | | | | | | ^ N + ! | |------|------|------|------|------|---- | + ! | | :: | 25 | 26 | 27 | 28 | --|-- + ! |------|------|------|------|------|---- | + ! IY=3 | :: | :: | 9 | 10 | 11 | | + ! |------|------|------|------|------|---- + ! IY=2 | :: | 1 | 2 | :: | 3 | + ! |------|------|------|------|------|---- + ! IY=1 | :: | :: | :: | :: | :: | + ! +------+------+------+------+------+---- + ! IX=1 IX=2 IX=3 IX=4 IX=5 ---> IX=NX + ! + ! :: is a land point. + ! + ! To reduce memory usage of the model, spectra are stored for sea + ! points only, in a one-dimensional grid with the length NSEA. This + ! grid is called the storage grid. The definition of the counter + ! in the storage grid is graphically depicted above. To transfer + ! data between the two grids, the maps MAPFS and MAPSF are + ! determined. MAPFS gives the counter of the storage grid ISEA + ! for every physical grid point (IY,IX), such that + ! + ! MAPFS(IY,IX) = ISEA + ! + ! ISEA = 0 corresponds to land points. The map MAPSF gives the grid + ! counters (IY,IX) for a given storage point ISEA. + ! + ! MAPSF(ISEA,1) = IX + ! MAPSF(ISEA,2) = IY + ! MAPSF(ISEA,3) = IY+(IX-1)*NY ( filled during reading ) + ! + ! Finally, a status maps MAPSTA and MAPST2 are determined, where + ! the status indicator ISTAT = MAPSTA(IY,IX) determines the type + ! of the grid point. + ! + ! ISTAT Means + ! --------------------------------------------------- + ! 0 Point excluded from grid. + ! (-)1 Sea point + ! (-)2 "Active" boundary point (data prescribed) + ! + ! For ISTAT=0, the secondary status counter ISTA2 is defined as + ! + ! ISTA2 Means + ! --------------------------------------------------- + ! 0 Land point. + ! 1 Point excluded from grid. + ! + ! Negative values of ISTAT identify points that are temporarily + ! taken out of the computation. For these points ISTA2 are + ! defined per bit + ! + ! BIT Means + ! --------------------------------------------------- + ! 1 Ice flag (1 = ice coverage) + ! 2 Dry flag (1 = dry point with depth 0) + ! 3 Inferred land in multi-grid model. + ! 4 Masking in multi-grid model. + ! 5 land point flag for relocatable grid. + ! + ! Thus ISTA2=0 for ISTAT<0 is in error, ISTA2=1 means ice cover, + ! ISTA2=3 means ice on dry point, etc. + ! + ! Spectral grid : + ! ----------------- + ! + ! In the spectral grid (and in physical space in general), + ! the cartesian convention for directions is used, i.e., the + ! direction 0 corresponds to waves propagating in the positive + ! X-direction and 90 degr. corresponds to waves propagating in + ! the positive Y-direction. Similar definitions are used for the + ! internal description of winds and currents. Output can obviously + ! be transformed according to any preferred convention. + ! + ! ITH=NTH + ! ^ | | | | | + ! | |------|------|------|------|---- + ! | | | | | | TH(3) = DTH*2. + ! |------|------|------|------|---- + ! ITH=2 | | | | | TH(2) = DTH + ! |------|------|------|------|---- + ! ITH=1 | | | | | TH(1) = 0. + ! +------+------+------+------+---- + ! IK=1 IK=2 IK=3 IK=4 ---> IK=NK + ! + ! The spectral grid consists of NK wavenumbers. The first + ! wavenumber IK=1 corresponds to the longest wave. The wavenumber + ! grid varies in space, as given by an invariant relative freq. + ! grid and the local depth. The spectral grid furthermore contains + ! NTH directions, equally spaced over a full circle. the first + ! direction corresponds to the direction 0, etc. + ! + ! (Begin SMC description) + ! + ! Spherical Multiple-Cell (SMC) grid + ! ----------------------------------- + ! + ! SMC grid is a multi-resolution grid using cells of multiple times + ! of each other. It is similar to the lat-lon grid using rectangular + ! cells but only cells at sea points are retained. All land points + ! have been removed from the model. At high latitudes, cells are + ! merged longitudinally to relax the CFL resctiction on time steps. + ! Near coastlines, cells are divided into quarters in a few steps so + ! that high resolution is achieved to refine coastlines and resolve + ! small islands. At present, three tiers of quarter cells are used. + ! For locating purpose, a usual x-y counter is setup by the smallest + ! cell size and starting from the south-west corner of the usual + ! rectuangular domain. Each sea cell is then given a pair of x-y + ! index, plus a pair of increments. These four index are stored in + ! the cell array IJKCel(4, NCel), each row holds i, j, di, dj, and + ! IJKDep holds ndps, where ndps is an integer depth in metre. If + ! precision higher than a metre is required, it may use other unit + ! (cm for instance) with a conversion factor. + ! + ! For transport calculation, two face arrays, IJKUFc(7, NUFc) and + ! IJKVFc(7, NVFc), are also created to store the neighbouring cell + ! sequential numbers and the face location and size. The 3 arrays + ! are calculated outside the wave model and input from text files. + ! + ! Boundary condition is added for SMC grid so that it can be used for + ! regional model as well. Most of the original boundary settings + ! are reclaimed as long as the boundary condition file is provided + ! by a lat-lon grid WW3 model, which will set the interpolation + ! parameters in the boundary condition file. The NBI number is + ! reset with an input value because the NX-Y double loop overcount + ! the boundary cells for merged cells in the SMC grid. ISBPI + ! boundary cell mapping array is fine as MAPFS uses duplicated cell + ! number in any merged cell. From there, all original NBI loops are + ! reusable. + ! + ! The whole Arctic can be included in the SMC grid if ARCTC variable + ! is set to be .TRUE. within the SMC option. The ARCTC option appends + ! the polar Arctic part above 86N to the existing SMC grid and uses + ! a map-east reference direction for this extra polar region. + ! Because the map-east direction changes with latitude and longitude + ! the wave spectra defined to the map-east direction could not be + ! mixed up with the conventional spectra defined to the local east + ! direction. A rotation sub is provided for convertion from one to + ! another. Propagation part will be calculated together, including + ! the boundary cells. The boundary cells are then updated by + ! assigning the corresponding inner cells to them after conversion. + ! Boundary cells are duplicated northmost 4 rows of the global part + ! and they can be excluded for source term and output if required. + ! For convenience, Arctic cellls are all base level cells and are + ! appended to the end of the global cells. If refined cells were + ! used in the Arctic part, it would not be kept all together, making + ! the sub-loops much more complicated. If refined resolution cells + ! are required for a Arctic regional model, users may consider use + ! the rotated SMC grid options (RTD and SMC). + ! + ! For more information about the SMC grid, please refer to + ! Li, J.G. (2012) Propagation of Ocean Surface Waves on a Spherical + ! Multiple-Cell Grid. J. Comput. Phys., 231, 8262-8277. online at + ! http://dx.doi.org/10.1016/j.jcp.2012.08.007 + ! + ! (End SMC description) + ! + ! ICEWIND is the scale factor for reduction of wind input by ice + ! concentration. Value specified corresponds to the fractional + ! input for 100% ice concentration. Default is 1.0, meaning that + ! 100% ice concentration result in zero wind input. + ! Sin_in_ice=Sin_in_open_water * (1-ICE*ICEWIND) + + ! -----------------------------------------------------------------* + ! 8. Structure : + ! + ! ---------------------------------------------------------------- + ! 1. Set up grid storage structure. + ! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) + ! 2.a I-O setup. + ! b Print heading(s). + ! 3. Prepare int. table for dispersion relation ( DISTAB ) + ! 4. Read and process input file up to spectrum. + ! a Get comment character + ! b Name of grid + ! c Define spectrum ( W3DIMS ) + ! 5. Set-up discrete spectrum. + ! a Directions. + ! b Frequency for spectrum. + ! 6. Read and process input file up to numerical parameters + ! a Set model flags and time steps + ! b Set / select source term package + ! c Pre-process namelists. + ! d Wind input source term. + ! e Nonlinear interactions. + ! f Whitecapping term. + ! g Bottom friction source term. + ! h Depth indiced breaking source term. + ! i Triad interaction source term. + ! j Bottom scattering source term. + ! k Undefined source term. + ! l Set / select propagaton scheme + ! m Parameters for propagation scheme. + ! n Set misc. parameters (ice, seeding, ...) + ! o End of namelist processing + ! p Set various other variables + ! 7. Read and prepare grid. + ! a Layout of grid + ! b Storage of grid of grid + ! c Read bottom depths + ! d Set up temp map + ! e Subgrid information + ! 1 Info from input file + ! 2 Open file and check if necessary + ! 3 Read the data + ! 4 Limit + ! 8 Finalize status maps + ! a Determine where to get the data + ! Get data in parts from input file + ! ---------------------------------------------------- + ! b Read and update TMPSTA with bound. and excl. points. + ! c Finalize excluded points + ! ---------------------------------------------------- + ! Read data from file + ! ---------------------------------------------------- + ! d Read data from file + ! ---------------------------------------------------- + ! e Get NSEA and other counters + ! f Set up all maps ( W3DIMX ) + ! 9. Prepare output boundary points. + ! a Read + ! b Update + ! 10. Write model definition file. ( W3IOGR ) + ! ---------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/FLX1 Stresses according to Wu (1980). + ! !/FLX2 Stresses according to T&C (1996). + ! !/FLX3 Stresses according to T&C (1996) with cap on Cd. + ! !/FLX4 Stresses according to Hwang (2011). + ! !/FLX5 Direct use of stress from atmospheric model/input file. + ! + ! !/LN0 No linear input source term. + ! !/SEED 'Seeding' of lowest frequency for sufficiently strong + ! winds. Proxi for linear input. + ! !/LN1 Cavaleri and Melanotte-Rizzoli with Tolman filter. + ! + ! !/ST0 No source terms included (input/dissipation) + ! !/ST1 WAM-3 physics package. + ! !/ST2 Tolman and Chalikov (1996) physics package. + ! !/ST3 WAM 4+ source terms from P.A.E.M. Janssen and J-R. Bidlot + ! !/ST4 Input and dissipation using saturation following Ardhuin et al. (2009,2010) + ! Filipot & Ardhuin (2010) or Romero (2019) + ! !/ST6 BYDRZ source term package featuring Donelan et al. + ! (2006) input and Babanin et al. (2001,2010) dissipation. + ! + ! !/NL0 No nonlinear interactions. + ! !/NL1 Discrete interaction approximation (DIA). + ! !/NL2 Exact interactions (WRT). + ! !/NL3 Generalized Multiple DIA (GMD). + ! !/NL4 Two Scale Approximation + ! !/NL5 Generalized Kinetic Equation (GKE) + ! !/NLS Snl based HF filter. + ! + ! !/BT0 No bottom friction included. + ! !/BT1 JONSWAP bottom friction package. + ! !/BT4 SHOWEX bottom friction using movable bed roughness + ! (Tolman 1994, Ardhuin & al. 2003) + ! + ! !/IC1 Sink term for interaction with ice (uniform k_i) + ! !/IC2 Sink term for under-ice boundary layer friction + ! (Liu et al. 1991: JGR 96 (C3), 4605-4621) + ! (Liu and Mollo 1988: JPO 18 1720-1712) + ! !/IC3 Sink term for interaction with ice (Wang and Shen method) + ! (Wang and Shen JGR 2010) + ! !/IC4 Sink term for empirical, frequency-dependent attenuation + ! in ice (Wadhams et al. 1988: JGR 93 (C6) 6799-6818) + ! !/IC5 Sink term for interaction with ice (effective medium mod.) + ! (Mosig et al. 2015, Meylan et al. 2018, Liu et al. + ! 2020) + ! + ! !/UOST Unresolved Obstacles Source Term (UOST), Mentaschi et al. 2015 + ! + ! !/DB0 No depth-induced breaking included. + ! !/DB1 Battjes-Janssen depth-limited breaking. + ! !/MLIM Mich-style limiter. + ! + ! !/TR0 No triad interactions included. + ! + ! !/BS0 No bottom scattering included. + ! !/BS1 Routines from F. Ardhuin. + ! + ! !/PR1 First order propagation scheme. + ! !/PR2 QUICKEST scheme with ULTIMATE limite and diffusion + ! correction for swell dispersion. + ! !/PR3 Averaging ULTIMATE QUICKEST scheme. + ! + ! !/RTD Rotated regular lat-lon grid. Special case is standard Polat=90. + ! !/SMC Spherical Multiple-Cell grid, may includes the whole Arctic. + ! + ! !/MGG GSE correction for moving grid. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T0 Enable test output tables for boundary output. + ! + ! !/O0 Print equivalent namelist setting to std out. + ! !/O1 Print tables with boundary points as part of output. + ! !/O2 Print MAPSTA as part of output. + ! !/O2a Print land-sea mask in mask.ww3. + ! !/O2b Print obstruction data. + ! !/O2c Print extended status map. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + USE W3TRIAMD + USE W3GSRUMD, ONLY: W3GRMP + USE W3ODATMD, ONLY: W3NOUT, W3SETO, W3DMO5 + USE W3IOGRMD, ONLY: W3IOGR + USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE #ifdef W3_RTD - USE W3SERVMD, ONLY: W3EQTOLL, W3LLTOEQ + USE W3SERVMD, ONLY: W3EQTOLL, W3LLTOEQ #endif #ifdef W3_SMC - USE W3SERVMD, ONLY: W3LLTOEQ + USE W3SERVMD, ONLY: W3LLTOEQ #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3ARRYMD, ONLY: INA2R, INA2I + USE W3ARRYMD, ONLY: INA2R, INA2I #ifdef W3_T - USE W3ARRYMD, ONLY: PRTBLK -#endif - USE W3DISPMD, ONLY: DISTAB -!/ - USE W3GDATMD - USE W3ODATMD, ONLY: NDSE, NDST, NDSO - USE W3ODATMD, ONLY: NBI, NBI2, NFBPO, NBO, NBO2, FLBPI, FLBPO, & - IPBPO, ISBPO, XBPO, YBPO, RDBPO, FNMPRE, & - IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, & - NOSWLL, PTMETH, PTFCUT - USE W3TIMEMD, ONLY: CALTYPE - USE W3NMLGRIDMD + USE W3ARRYMD, ONLY: PRTBLK +#endif + USE W3DISPMD, ONLY: DISTAB + !/ + USE W3GDATMD + USE W3ODATMD, ONLY: NDSE, NDST, NDSO + USE W3ODATMD, ONLY: NBI, NBI2, NFBPO, NBO, NBO2, FLBPI, FLBPO, & + IPBPO, ISBPO, XBPO, YBPO, RDBPO, FNMPRE, & + IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, & + NOSWLL, PTMETH, PTFCUT + USE W3TIMEMD, ONLY: CALTYPE + USE W3NMLGRIDMD #ifdef W3_SCRIP - USE SCRIP_GRIDS, ONLY: GRID1_UNITS, GRID1_NAME, & - GRID1_CENTER_LON, GRID1_CENTER_LAT, & - GRID1_CORNER_LON, GRID1_CORNER_LAT, & - GRID1_MASK, GRID1_SIZE, GRID1_RANK, & - GRID1_IMASK, & - GRID1_CORNERS, GRID1_DIMS - USE SCRIP_KINDSMOD - USE WMSCRPMD + USE SCRIP_GRIDS, ONLY: GRID1_UNITS, GRID1_NAME, & + GRID1_CENTER_LON, GRID1_CENTER_LAT, & + GRID1_CORNER_LON, GRID1_CORNER_LAT, & + GRID1_MASK, GRID1_SIZE, GRID1_RANK, & + GRID1_IMASK, & + GRID1_CORNERS, GRID1_DIMS + USE SCRIP_KINDSMOD + USE WMSCRPMD #endif #ifdef W3_SCRIPNC - USE NETCDF + USE NETCDF #endif -! + ! #ifdef W3_NL3 - USE W3SNL3MD, ONLY: LAMMAX, DELTHM + USE W3SNL3MD, ONLY: LAMMAX, DELTHM #endif #ifdef W3_NLS - USE W3SNLSMD, ONLY: ABMAX -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(NML_SPECTRUM_T) :: NML_SPECTRUM - TYPE(NML_RUN_T) :: NML_RUN - TYPE(NML_TIMESTEPS_T) :: NML_TIMESTEPS - TYPE(NML_GRID_T) :: NML_GRID - TYPE(NML_RECT_T) :: NML_RECT - TYPE(NML_CURV_T) :: NML_CURV - TYPE(NML_UNST_T) :: NML_UNST - TYPE(NML_SMC_T) :: NML_SMC - TYPE(NML_DEPTH_T) :: NML_DEPTH - TYPE(NML_MASK_T) :: NML_MASK - TYPE(NML_OBST_T) :: NML_OBST - TYPE(NML_SLOPE_T) :: NML_SLOPE - TYPE(NML_SED_T) :: NML_SED - TYPE(NML_INBND_COUNT_T) :: NML_INBND_COUNT - TYPE(NML_INBND_POINT_T), ALLOCATABLE :: NML_INBND_POINT(:) - TYPE(NML_EXCL_COUNT_T) :: NML_EXCL_COUNT - TYPE(NML_EXCL_POINT_T), ALLOCATABLE :: NML_EXCL_POINT(:) - TYPE(NML_EXCL_BODY_T), ALLOCATABLE :: NML_EXCL_BODY(:) - TYPE(NML_OUTBND_COUNT_T) :: NML_OUTBND_COUNT - TYPE(NML_OUTBND_LINE_T), ALLOCATABLE :: NML_OUTBND_LINE(:) -! - INTEGER, PARAMETER :: NFL = 6 - INTEGER :: NDSI, NDSI2, NDSS, NDSM, NDSG, NDSTR,& - IERR, NDSTRC, NTRACE, ITH, IK, ITH0, & - ISP, IYN(NFL), NRLIN, NRSRCE, NRNL, & - NRBT, NRDB, NRTR, NRBS, NRPROP, & - IDLA, IDFM, IX0, IXN, IX, IY, ISEA, & - IDX, IXO, IDY, IYO, IBA, NBA, ILOOP, & - IFL, NBOTOT, NPO, IP, IX1, IX2, IY1, & - IY2, J, JJ, IXR(4), IYR(4), ISEAI(4),& - IST, NKI, NTHI, NRIC, NRIS, I, IDFT, & - NSTAT, NBT, NLAND, NOSW, NMAPB, IMAPB + USE W3SNLSMD, ONLY: ABMAX +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(NML_SPECTRUM_T) :: NML_SPECTRUM + TYPE(NML_RUN_T) :: NML_RUN + TYPE(NML_TIMESTEPS_T) :: NML_TIMESTEPS + TYPE(NML_GRID_T) :: NML_GRID + TYPE(NML_RECT_T) :: NML_RECT + TYPE(NML_CURV_T) :: NML_CURV + TYPE(NML_UNST_T) :: NML_UNST + TYPE(NML_SMC_T) :: NML_SMC + TYPE(NML_DEPTH_T) :: NML_DEPTH + TYPE(NML_MASK_T) :: NML_MASK + TYPE(NML_OBST_T) :: NML_OBST + TYPE(NML_SLOPE_T) :: NML_SLOPE + TYPE(NML_SED_T) :: NML_SED + TYPE(NML_INBND_COUNT_T) :: NML_INBND_COUNT + TYPE(NML_INBND_POINT_T), ALLOCATABLE :: NML_INBND_POINT(:) + TYPE(NML_EXCL_COUNT_T) :: NML_EXCL_COUNT + TYPE(NML_EXCL_POINT_T), ALLOCATABLE :: NML_EXCL_POINT(:) + TYPE(NML_EXCL_BODY_T), ALLOCATABLE :: NML_EXCL_BODY(:) + TYPE(NML_OUTBND_COUNT_T) :: NML_OUTBND_COUNT + TYPE(NML_OUTBND_LINE_T), ALLOCATABLE :: NML_OUTBND_LINE(:) + ! + INTEGER, PARAMETER :: NFL = 6 + INTEGER :: NDSI, NDSI2, NDSS, NDSM, NDSG, NDSTR,& + IERR, NDSTRC, NTRACE, ITH, IK, ITH0, & + ISP, IYN(NFL), NRLIN, NRSRCE, NRNL, & + NRBT, NRDB, NRTR, NRBS, NRPROP, & + IDLA, IDFM, IX0, IXN, IX, IY, ISEA, & + IDX, IXO, IDY, IYO, IBA, NBA, ILOOP, & + IFL, NBOTOT, NPO, IP, IX1, IX2, IY1, & + IY2, J, JJ, IXR(4), IYR(4), ISEAI(4),& + IST, NKI, NTHI, NRIC, NRIS, I, IDFT, & + NSTAT, NBT, NLAND, NOSW, NMAPB, IMAPB #ifdef W3_NL2 - INTEGER :: IDEPTH + INTEGER :: IDEPTH #endif #ifdef W3_O1 - INTEGER :: IBI, IP0, IPN, IPH, IPI + INTEGER :: IBI, IP0, IPN, IPH, IPI #endif - INTEGER :: NCOL = 78 + INTEGER :: NCOL = 78 #ifdef W3_SMC - !!Li Offset to change Equator index = 0 to regular index JEQT - !!Li LvSMC levels of refinded resolutions for SMC grid. - !!Li NBISMC number of boundary point for regional SMC grid. - !!Li ISHFT for SMC i-index from smc origin to regular grid west edge. - !!Li SMC cell only subgrid obstruction array dimensions NCObst, JObs. - INTEGER :: JEQT, LvSMC, NBISMC, JS, NCObst, JObs, ISHFT - INTEGER :: NGUI, NGVJ, NAUI, NAVJ -#endif -! + !!Li Offset to change Equator index = 0 to regular index JEQT + !!Li LvSMC levels of refinded resolutions for SMC grid. + !!Li NBISMC number of boundary point for regional SMC grid. + !!Li ISHFT for SMC i-index from smc origin to regular grid west edge. + !!Li SMC cell only subgrid obstruction array dimensions NCObst, JObs. + INTEGER :: JEQT, LvSMC, NBISMC, JS, NCObst, JObs, ISHFT + INTEGER :: NGUI, NGVJ, NAUI, NAVJ +#endif + ! #ifdef W3_O2 - INTEGER :: NMAP, IMAP + INTEGER :: NMAP, IMAP #endif #ifdef W3_T - INTEGER :: IX3, IY3 + INTEGER :: IX3, IY3 #endif #ifdef W3_T0 - INTEGER :: IFILE + INTEGER :: IFILE #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! - INTEGER, ALLOCATABLE :: TMPSTA(:,:), TMPMAP(:,:), READMP(:,:) + ! + INTEGER, ALLOCATABLE :: TMPSTA(:,:), TMPMAP(:,:), READMP(:,:) #ifdef W3_T - INTEGER, ALLOCATABLE :: MAPOUT(:,:) -#endif -! - REAL :: RXFR, RFR1, SIGMA, SXFR, FACHF, & - VSC, VSC0, VOF, & - ZLIM, X, Y, XP, XO0, YO0, DXO, DYO, & - XO, YO, RD(4), RDTOT, & - FACTOR, RTH0, FMICHE, RWNDC, & - WCOR1, WCOR2 -! - CHARACTER(LEN=4) :: GSTRG, CSTRG -! -! Variables used to allow spectral output on full grid -! - INTEGER :: P2SF,I1P2SF,I2P2SF - INTEGER :: E3D,I1E3D,I2E3D - INTEGER :: US3D,I1US3D,I2US3D, & - USSP, IUSSP, & - TH1MF, I1TH1M, I2TH1M, & - STH1MF, I1STH1M, I2STH1M, & - TH2MF, I1TH2M, I2TH2M, & - STH2MF, I1STH2M, I2STH2M - ! STK_WN are the decays for Stokes drift partitions - REAL :: STK_WN(25) - -! + INTEGER, ALLOCATABLE :: MAPOUT(:,:) +#endif + ! + REAL :: RXFR, RFR1, SIGMA, SXFR, FACHF, & + VSC, VSC0, VOF, & + ZLIM, X, Y, XP, XO0, YO0, DXO, DYO, & + XO, YO, RD(4), RDTOT, & + FACTOR, RTH0, FMICHE, RWNDC, & + WCOR1, WCOR2 + ! + CHARACTER(LEN=4) :: GSTRG, CSTRG + ! + ! Variables used to allow spectral output on full grid + ! + INTEGER :: P2SF,I1P2SF,I2P2SF + INTEGER :: E3D,I1E3D,I2E3D + INTEGER :: US3D,I1US3D,I2US3D, & + USSP, IUSSP, & + TH1MF, I1TH1M, I2TH1M, & + STH1MF, I1STH1M, I2STH1M, & + TH2MF, I1TH2M, I2TH2M, & + STH2MF, I1STH2M, I2STH2M + ! STK_WN are the decays for Stokes drift partitions + REAL :: STK_WN(25) + + ! #ifdef W3_LN1 - REAL :: CLIN, RFPM, RFHF + REAL :: CLIN, RFPM, RFHF #endif #ifdef W3_ST1 - REAL :: CINP, CDIS, APM + REAL :: CINP, CDIS, APM #endif #ifdef W3_ST2 - REAL :: PHIMIN, FPIA, FPIB, DPHID + REAL :: PHIMIN, FPIA, FPIB, DPHID #endif #ifdef W3_NL1 - REAL :: NLPROP + REAL :: NLPROP #endif #ifdef W3_NL2 - REAL :: DPTFAC, DEPTHS(100) + REAL :: DPTFAC, DEPTHS(100) #endif #ifdef W3_NL3 - REAL :: QPARMS(500) + REAL :: QPARMS(500) #endif #ifdef W3_NLS - REAL :: A34, FHFC, DNM, FC1, FC2, FC3 + REAL :: A34, FHFC, DNM, FC1, FC2, FC3 #endif #ifdef W3_BT1 - REAL :: GAMMA + REAL :: GAMMA #endif #ifdef W3_PR2 - REAL :: LATMIN + REAL :: LATMIN #endif -! + ! #ifdef W3_SMC - REAL :: TRNMX, TRNMY - INTEGER, ALLOCATABLE :: NLvCelsk(:), NLvUFcsk(:), NLvVFcsk(:) - INTEGER, ALLOCATABLE :: IJKCelin(:,:),IJKUFcin(:,:),IJKVFcin(:,:) - INTEGER, ALLOCATABLE :: NBICelin(:), IJKObstr(:,:) - REAL :: PoLonAC, PoLatAC - INTEGER, ALLOCATABLE :: IJKCelAC(:,:),IJKUFcAC(:,:),IJKVFcAC(:,:) - INTEGER, ALLOCATABLE :: IJKDep(:), IJKVFc8(:) - REAL, ALLOCATABLE :: XLONAC(:),YLATAC(:),ELONAC(:),ELATAC(:) -#endif -! + REAL :: TRNMX, TRNMY + INTEGER, ALLOCATABLE :: NLvCelsk(:), NLvUFcsk(:), NLvVFcsk(:) + INTEGER, ALLOCATABLE :: IJKCelin(:,:),IJKUFcin(:,:),IJKVFcin(:,:) + INTEGER, ALLOCATABLE :: NBICelin(:), IJKObstr(:,:) + REAL :: PoLonAC, PoLatAC + INTEGER, ALLOCATABLE :: IJKCelAC(:,:),IJKUFcAC(:,:),IJKVFcAC(:,:) + INTEGER, ALLOCATABLE :: IJKDep(:), IJKVFc8(:) + REAL, ALLOCATABLE :: XLONAC(:),YLATAC(:),ELONAC(:),ELATAC(:) +#endif + ! #ifdef W3_RTD - REAL, ALLOCATABLE :: AnglDin(:,:),StdLon(:,:),StdLat(:,:) - ! 1-dim boundary sectors - REAL, ALLOCATABLE :: BDYLON(:), BDYLAT(:), & - ELatbdy(:), ELonbdy(:), Anglbdy(:) - ! If the destination grid for an output b.c. is rotated, its pole is: - REAL :: bPolat, bPolon -! -#endif - REAL, ALLOCATABLE :: XGRDIN(:,:), YGRDIN(:,:) - REAL, ALLOCATABLE :: ZBIN(:,:), OBSX(:,:), OBSY(:,:) - REAL, ALLOCATABLE :: REFD(:,:), REFD2(:,:), REFS(:,:) + REAL, ALLOCATABLE :: AnglDin(:,:),StdLon(:,:),StdLat(:,:) + ! 1-dim boundary sectors + REAL, ALLOCATABLE :: BDYLON(:), BDYLAT(:), & + ELatbdy(:), ELonbdy(:), Anglbdy(:) + ! If the destination grid for an output b.c. is rotated, its pole is: + REAL :: bPolat, bPolon + ! +#endif + REAL, ALLOCATABLE :: XGRDIN(:,:), YGRDIN(:,:) + REAL, ALLOCATABLE :: ZBIN(:,:), OBSX(:,:), OBSY(:,:) + REAL, ALLOCATABLE :: REFD(:,:), REFD2(:,:), REFS(:,:) #ifdef W3_BT4 - REAL, ALLOCATABLE :: SED_D50FILE(:,:), SED_POROFILE(:,:) - LOGICAL :: SEDMAPD50 - REAL :: SED_D50_UNIFORM, SED_DSTAR, RIPFAC1, & - RIPFAC2, RIPFAC3, RIPFAC4, SIGDEPTH, & - BOTROUGHMIN, BOTROUGHFAC -#endif -! - LOGICAL :: FLLIN, FLINDS, FLNL, FLBT, FLDB, & - FLTR, FLBS, FLPROP, FLREF, & - FIRST, CONNCT, FLNEW, INGRID,FLIC, & - FLIS, FLGNML - LOGICAL :: FLTC96 = .FALSE. - LOGICAL :: FLNMLO = .FALSE. - LOGICAL :: FLSTB2 = .FALSE. - LOGICAL :: FLST4 = .FALSE. - LOGICAL :: FLST6 = .FALSE. - - REAL :: FACBERG, REFSLOPE + REAL, ALLOCATABLE :: SED_D50FILE(:,:), SED_POROFILE(:,:) + LOGICAL :: SEDMAPD50 + REAL :: SED_D50_UNIFORM, SED_DSTAR, RIPFAC1, & + RIPFAC2, RIPFAC3, RIPFAC4, SIGDEPTH, & + BOTROUGHMIN, BOTROUGHFAC +#endif + ! + LOGICAL :: FLLIN, FLINDS, FLNL, FLBT, FLDB, & + FLTR, FLBS, FLPROP, FLREF, & + FIRST, CONNCT, FLNEW, INGRID,FLIC, & + FLIS, FLGNML + LOGICAL :: FLTC96 = .FALSE. + LOGICAL :: FLNMLO = .FALSE. + LOGICAL :: FLSTB2 = .FALSE. + LOGICAL :: FLST4 = .FALSE. + LOGICAL :: FLST6 = .FALSE. + + REAL :: FACBERG, REFSLOPE #ifdef W3_IS1 - REAL :: ISC1, ISC2 + REAL :: ISC1, ISC2 #endif #ifdef W3_IS2 - REAL :: ISC1, IS2BACKSCAT, IS2C2, IS2C3,& - IS2FRAGILITY, IS2DMIN, IS2DAMP, & - IS2CONC, IS2CREEPB, IS2CREEPC, & - IS2CREEPD, IS2CREEPN, IS2BREAKE,& - IS2WIM1, IS2BREAKF, IS2FLEXSTR, & - IS2ANDISN, IS2ANDISE, IS2ANDISD - LOGICAL :: IS2BREAK, IS2DISP, IS2DUPDATE, & - IS2ISOSCAT, IS2ANDISB -#endif -! + REAL :: ISC1, IS2BACKSCAT, IS2C2, IS2C3,& + IS2FRAGILITY, IS2DMIN, IS2DAMP, & + IS2CONC, IS2CREEPB, IS2CREEPC, & + IS2CREEPD, IS2CREEPN, IS2BREAKE,& + IS2WIM1, IS2BREAKF, IS2FLEXSTR, & + IS2ANDISN, IS2ANDISE, IS2ANDISD + LOGICAL :: IS2BREAK, IS2DISP, IS2DUPDATE, & + IS2ISOSCAT, IS2ANDISB +#endif + ! #ifdef W3_REF1 - REAL :: REFCOAST, REFFREQ, REFMAP, & - REFSUBGRID, REFRMAX, REFMAPD, & - REFICEBERG, REFCOSP_STRAIGHT, & - REFFREQPOW, REFUNSTSOURCE + REAL :: REFCOAST, REFFREQ, REFMAP, & + REFSUBGRID, REFRMAX, REFMAPD, & + REFICEBERG, REFCOSP_STRAIGHT, & + REFFREQPOW, REFUNSTSOURCE #endif -! + ! #ifdef W3_IG1 LOGICAL :: IGSWELLMAX, IGBCOVERWRITE INTEGER :: IGMETHOD, IGADDOUTP, IGSOURCE, & - IGSOURCEATBP, IGSTERMS + IGSOURCEATBP, IGSTERMS REAL :: IGMAXFREQ, IGMINDEP, IGMAXDEP, & - IGKDMIN, IGFIXEDDEPTH, IGEMPIRICAL + IGKDMIN, IGFIXEDDEPTH, IGEMPIRICAL #endif -! + ! #ifdef W3_IC2 LOGICAL :: IC2DISPER REAL :: IC2TURB, IC2ROUGH, IC2REYNOLDS, & - IC2SMOOTH, IC2VISC, IC2TURBS, IC2DMAX + IC2SMOOTH, IC2VISC, IC2TURBS, IC2DMAX #endif #ifdef W3_IC3 REAL :: IC2TURB, IC2ROUGH, IC2REYNOLDS, & - IC2SMOOTH, IC2VISC, IC2TURBS, & - IC3MAXTHK, IC3MAXCNC, & - IC3HILIM, IC3KILIM, & - IC3VISC, IC3ELAS, IC3DENS, IC3HICE + IC2SMOOTH, IC2VISC, IC2TURBS, & + IC3MAXTHK, IC3MAXCNC, & + IC3HILIM, IC3KILIM, & + IC3VISC, IC3ELAS, IC3DENS, IC3HICE LOGICAL :: IC3CHENG,USECGICE #endif @@ -762,3246 +762,3213 @@ MODULE W3GRIDMD INTEGER :: IC4METHOD REAL :: IC4KI(NIC4), IC4FC(NIC4) #endif -! + ! #ifdef W3_IC5 REAL :: IC5MINIG, IC5MINWT, & - IC5MAXKRATIO, IC5MAXKI, IC5MINHW, & - IC5MAXITER, IC5RKICK, IC5KFILTER, & - IC5VEMOD + IC5MAXKRATIO, IC5MAXKI, IC5MINHW, & + IC5MAXITER, IC5RKICK, IC5KFILTER, & + IC5VEMOD CHARACTER(LEN=4) :: IC5MSTR(3) = (/' EFS', ' RP ', ' M2 '/) #endif - CHARACTER :: COMSTR*1, PNAME*30, RFORM*16, & - FROM*4, FNAME*60, TNAME*60, LINE*80, & - STATUS*20,FNAME2*60, PNAME2*40 - CHARACTER(LEN=6) :: YESXNO(2) + CHARACTER :: COMSTR*1, PNAME*30, RFORM*16, & + FROM*4, FNAME*60, TNAME*60, LINE*80, & + STATUS*20,FNAME2*60, PNAME2*40 + CHARACTER(LEN=6) :: YESXNO(2) #ifdef W3_FLX3 - CHARACTER(LEN=18) :: TYPEID + CHARACTER(LEN=18) :: TYPEID #endif #ifdef W3_SCRIP - INTEGER :: NCID - INTEGER :: grid_size_dimid, grid_rank_dimid, grid_corners_dimid - INTEGER :: grid_center_lat_varid, grid_center_lon_varid - INTEGER :: grid_corner_lat_varid, grid_corner_lon_varid - INTEGER :: grid_area_varid, grid_imask_varid - INTEGER :: grid_dims_varid - REAL (SCRIP_R8) :: CONV_DX,CONV_DY,OFFSET + INTEGER :: NCID + INTEGER :: grid_size_dimid, grid_rank_dimid, grid_corners_dimid + INTEGER :: grid_center_lat_varid, grid_center_lon_varid + INTEGER :: grid_corner_lat_varid, grid_corner_lon_varid + INTEGER :: grid_area_varid, grid_imask_varid + INTEGER :: grid_dims_varid + REAL (SCRIP_R8) :: CONV_DX,CONV_DY,OFFSET #endif -!/ ------------------------------------------------------------------- / -!/ Namelists -!/ - INTEGER :: FLAGTR, IHM - REAL :: CFLTM, CICE0, CICEN, PMOVE, XFILT, & - LICE, XSEED, XR, HSPM, WSM, WSC, STDX,& - STDY, STDT, ICEHMIN, ICEHFAC, ICEHINIT, & - ICESLN, ICEWIND, ICESNL, ICESDS, & - ICEHDISP, ICEFDISP, ICEDDISP, BTBET -! - REAL(8) :: GSHIFT ! see notes in WMGHGH - LOGICAL :: FLC, ICEDISP, TRCKCMPR - INTEGER :: PTM ! Partitioning method - REAL :: PTFC ! Part. cut off freq (for method 5) - REAL :: AIRCMIN, AIRGB - CHARACTER :: PMNAME*45, PMNAM2*45 ! Part. method desc. + !/ ------------------------------------------------------------------- / + !/ Namelists + !/ + INTEGER :: FLAGTR, IHM + REAL :: CFLTM, CICE0, CICEN, PMOVE, XFILT, & + LICE, XSEED, XR, HSPM, WSM, WSC, STDX,& + STDY, STDT, ICEHMIN, ICEHFAC, ICEHINIT, & + ICESLN, ICEWIND, ICESNL, ICESDS, & + ICEHDISP, ICEFDISP, ICEDDISP, BTBET + ! + REAL(8) :: GSHIFT ! see notes in WMGHGH + LOGICAL :: FLC, ICEDISP, TRCKCMPR + INTEGER :: PTM ! Partitioning method + REAL :: PTFC ! Part. cut off freq (for method 5) + REAL :: AIRCMIN, AIRGB + CHARACTER :: PMNAME*45, PMNAM2*45 ! Part. method desc. #ifdef W3_FLD1 - INTEGER :: TAILTYPE - REAL :: TAILLEV, TAILT1, TAILT2 + INTEGER :: TAILTYPE + REAL :: TAILLEV, TAILT1, TAILT2 #endif #ifdef W3_FLD2 - INTEGER :: TAILTYPE - REAL :: TAILLEV, TAILT1, TAILT2 + INTEGER :: TAILTYPE + REAL :: TAILLEV, TAILT1, TAILT2 #endif #ifdef W3_FLX3 - INTEGER :: CTYPE - REAL :: CDMAX + INTEGER :: CTYPE + REAL :: CDMAX #endif #ifdef W3_FLX4 - REAL :: CDFAC + REAL :: CDFAC #endif #ifdef W3_ST2 - REAL :: ZWND, SWELLF, STABSH, STABOF, & - CNEG, CPOS, FNEG, FPOS - REAL :: SDSA0, SDSA1, SDSA2, & - SDSB0, SDSB1, SDSB2, SDSB3 + REAL :: ZWND, SWELLF, STABSH, STABOF, & + CNEG, CPOS, FNEG, FPOS + REAL :: SDSA0, SDSA1, SDSA2, & + SDSB0, SDSB1, SDSB2, SDSB3 #endif #ifdef W3_ST3 - REAL :: ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP,& - ZALP, SWELLF, FXPM3, FXFM3, & - WNMEANPTAIL, WNMEANP, STXFTF, STXFTWN - REAL :: STXFTFTAIL, SDSC1, & - SDSDELTA1, SDSDELTA2 + REAL :: ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP,& + ZALP, SWELLF, FXPM3, FXFM3, & + WNMEANPTAIL, WNMEANP, STXFTF, STXFTWN + REAL :: STXFTFTAIL, SDSC1, & + SDSDELTA1, SDSDELTA2 #endif -! + ! #ifdef W3_ST4 - INTEGER :: SWELLFPAR, SDSISO, SDSBRFDF - REAL :: SDSBCHOICE - REAL :: ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP,& - ZALP, Z0RAT, TAUWSHELTER, SWELLF, & - SWELLF2,SWELLF3,SWELLF4, SWELLF5, & - SWELLF6, SWELLF7, FXPM3, FXFM3, & - WNMEANPTAIL, WNMEANP, STXFTF, STXFTFTAIL, & - STXFTWN, SINBR, FXFMAGE, & - SDSC2, SDSCUM, SDSC4, SDSC5, SDSC6, WHITECAPWIDTH, WHITECAPDUR, & - SDSSTRAIN, SDSSTRAINA, SDSSTRAIN2, & - SDSBR, SDSP, SDSBT, SDS4A, SDKOF, & - SDSCOS, SDSDTH, SDSBCK, SDSABK, & - SDSPBK, SDSBINT, SDSHCK, & - SDSBRF1, & - SDSBM0, SDSBM1, SDSBM2, SDSBM3, & - SDSBM4, SDSFACMTF, SDSCUMP, SDSNUW, & - SDSL, SDSMWD, SDSMWPOW, SPMSS, SDSNMTF -#endif -! + INTEGER :: SWELLFPAR, SDSISO, SDSBRFDF + REAL :: SDSBCHOICE + REAL :: ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP,& + ZALP, Z0RAT, TAUWSHELTER, SWELLF, & + SWELLF2,SWELLF3,SWELLF4, SWELLF5, & + SWELLF6, SWELLF7, FXPM3, FXFM3, & + WNMEANPTAIL, WNMEANP, STXFTF, STXFTFTAIL, & + STXFTWN, SINBR, FXFMAGE, & + SDSC2, SDSCUM, SDSC4, SDSC5, SDSC6, WHITECAPWIDTH, WHITECAPDUR, & + SDSSTRAIN, SDSSTRAINA, SDSSTRAIN2, & + SDSBR, SDSP, SDSBT, SDS4A, SDKOF, & + SDSCOS, SDSDTH, SDSBCK, SDSABK, & + SDSPBK, SDSBINT, SDSHCK, & + SDSBRF1, & + SDSBM0, SDSBM1, SDSBM2, SDSBM3, & + SDSBM4, SDSFACMTF, SDSCUMP, SDSNUW, & + SDSL, SDSMWD, SDSMWPOW, SPMSS, SDSNMTF +#endif + ! #ifdef W3_ST6 - REAL :: SINA0, SINWS, SINFC, & - SDSA1, SDSA2, SWLB1 - INTEGER :: SDSP1, SDSP2 - LOGICAL :: SDSET, CSTB1 + REAL :: SINA0, SINWS, SINFC, & + SDSA1, SDSA2, SWLB1 + INTEGER :: SDSP1, SDSP2 + LOGICAL :: SDSET, CSTB1 #endif -! + ! #ifdef W3_NL1 - REAL :: LAMBDA, KDCONV, KDMIN, & - SNLCS1, SNLCS2, SNLCS3 + REAL :: LAMBDA, KDCONV, KDMIN, & + SNLCS1, SNLCS2, SNLCS3 #endif #ifdef W3_NL2 - INTEGER :: IQTYPE, NDEPTH - REAL :: TAILNL + INTEGER :: IQTYPE, NDEPTH + REAL :: TAILNL #endif #ifdef W3_NL3 - INTEGER :: NQDEF - REAL :: MSC, NSC, KDFD, KDFS + INTEGER :: NQDEF + REAL :: MSC, NSC, KDFD, KDFS #endif #ifdef W3_NL4 - INTEGER :: INDTSA, ALTLP + INTEGER :: INDTSA, ALTLP #endif #ifdef W3_NL5 - REAL :: NL5DPT, NL5OML - INTEGER :: NL5DIS, NL5KEV, NL5IPL, NL5PMX + REAL :: NL5DPT, NL5OML + INTEGER :: NL5DIS, NL5KEV, NL5IPL, NL5PMX #endif #ifdef W3_DB1 - REAL :: BJALFA, BJGAM - LOGICAL :: BJFLAG + REAL :: BJALFA, BJGAM + LOGICAL :: BJFLAG #endif #ifdef W3_PR2 - REAL :: DTIME + REAL :: DTIME #endif -! + ! #ifdef W3_SMC - REAL :: DTIMS, CFLSM, RFMAXD, SYMR, YJ0R - LOGICAL :: UNO3, AVERG, SEAWND, Arctic - CHARACTER :: PNSMC*30 + REAL :: DTIMS, CFLSM, RFMAXD, SYMR, YJ0R + LOGICAL :: UNO3, AVERG, SEAWND, Arctic + CHARACTER :: PNSMC*30 #endif -! + ! #ifdef W3_PR3 - REAL :: WDTHCG, WDTHTH -#endif - LOGICAL :: JGS_TERMINATE_MAXITER = .TRUE. - LOGICAL :: JGS_TERMINATE_DIFFERENCE = .TRUE. - LOGICAL :: JGS_TERMINATE_NORM = .TRUE. - LOGICAL :: JGS_LIMITER = .FALSE. - LOGICAL :: JGS_BLOCK_GAUSS_SEIDEL = .TRUE. - LOGICAL :: JGS_USE_JACOBI = .TRUE. - LOGICAL :: JGS_SOURCE_NONLINEAR = .FALSE. - LOGICAL :: UGOBCAUTO = .FALSE. - LOGICAL :: UGBCCFL = .FALSE. - LOGICAL :: EXPFSN = .TRUE. - LOGICAL :: EXPFSPSI = .FALSE. - LOGICAL :: EXPFSFCT = .FALSE. - LOGICAL :: IMPFSN = .FALSE. - LOGICAL :: EXPTOTAL = .FALSE. - LOGICAL :: IMPTOTAL = .FALSE. - LOGICAL :: IMPREFRACTION = .FALSE. - LOGICAL :: IMPFREQSHIFT = .FALSE. - LOGICAL :: IMPSOURCE = .FALSE. - LOGICAL :: SETUP_APPLY_WLV = .FALSE. - INTEGER :: JGS_MAXITER=100 - INTEGER :: nbSel - INTEGER :: UNSTSCHEMES(6) - INTEGER :: UNSTSCHEME - INTEGER :: JGS_NLEVEL = 0 - REAL*8 :: JGS_PMIN = 0. - REAL*8 :: JGS_DIFF_THR = 1.E-10 - REAL*8 :: JGS_NORM_THR = 1.E-20 - REAL*8 :: SOLVERTHR_SETUP = 1.E-20 - REAL*8 :: CRIT_DEP_SETUP = 0. -! - CHARACTER :: UGOBCFILE*60 - REAL :: UGOBCDEPTH - LOGICAL :: UGOBCOK + REAL :: WDTHCG, WDTHTH +#endif + LOGICAL :: JGS_TERMINATE_MAXITER = .TRUE. + LOGICAL :: JGS_TERMINATE_DIFFERENCE = .TRUE. + LOGICAL :: JGS_TERMINATE_NORM = .TRUE. + LOGICAL :: JGS_LIMITER = .FALSE. + LOGICAL :: JGS_BLOCK_GAUSS_SEIDEL = .TRUE. + LOGICAL :: JGS_USE_JACOBI = .TRUE. + LOGICAL :: JGS_SOURCE_NONLINEAR = .FALSE. + LOGICAL :: UGOBCAUTO = .FALSE. + LOGICAL :: UGBCCFL = .FALSE. + LOGICAL :: EXPFSN = .TRUE. + LOGICAL :: EXPFSPSI = .FALSE. + LOGICAL :: EXPFSFCT = .FALSE. + LOGICAL :: IMPFSN = .FALSE. + LOGICAL :: EXPTOTAL = .FALSE. + LOGICAL :: IMPTOTAL = .FALSE. + LOGICAL :: IMPREFRACTION = .FALSE. + LOGICAL :: IMPFREQSHIFT = .FALSE. + LOGICAL :: IMPSOURCE = .FALSE. + LOGICAL :: SETUP_APPLY_WLV = .FALSE. + INTEGER :: JGS_MAXITER=100 + INTEGER :: nbSel + INTEGER :: UNSTSCHEMES(6) + INTEGER :: UNSTSCHEME + INTEGER :: JGS_NLEVEL = 0 + REAL*8 :: JGS_PMIN = 0. + REAL*8 :: JGS_DIFF_THR = 1.E-10 + REAL*8 :: JGS_NORM_THR = 1.E-20 + REAL*8 :: SOLVERTHR_SETUP = 1.E-20 + REAL*8 :: CRIT_DEP_SETUP = 0. + ! + CHARACTER :: UGOBCFILE*60 + REAL :: UGOBCDEPTH + LOGICAL :: UGOBCOK #ifdef W3_RTD - REAL :: PLAT, PLON - LOGICAL :: UNROT - ! Poles of the output nested grids. May be a mix of rotated and standard - REAL, DIMENSION(9) :: BPLAT, BPLON + REAL :: PLAT, PLON + LOGICAL :: UNROT + ! Poles of the output nested grids. May be a mix of rotated and standard + REAL, DIMENSION(9) :: BPLAT, BPLON #endif -! + ! #ifdef W3_FLD1 - NAMELIST /FLD1/ TAILTYPE, TAILLEV, TAILT1, TAILT2 + NAMELIST /FLD1/ TAILTYPE, TAILLEV, TAILT1, TAILT2 #endif #ifdef W3_FLD2 - NAMELIST /FLD2/ TAILTYPE, TAILLEV, TAILT1, TAILT2 + NAMELIST /FLD2/ TAILTYPE, TAILLEV, TAILT1, TAILT2 #endif #ifdef W3_FLX3 - NAMELIST /FLX3/ CDMAX, CTYPE + NAMELIST /FLX3/ CDMAX, CTYPE #endif #ifdef W3_FLX4 - NAMELIST /FLX4/ CDFAC + NAMELIST /FLX4/ CDFAC #endif #ifdef W3_IC2 - NAMELIST /SIC2/ IC2DISPER, IC2TURB, IC2ROUGH, IC2REYNOLDS, & - IC2SMOOTH, IC2VISC, IC2TURBS, IC2DMAX + NAMELIST /SIC2/ IC2DISPER, IC2TURB, IC2ROUGH, IC2REYNOLDS, & + IC2SMOOTH, IC2VISC, IC2TURBS, IC2DMAX #endif #ifdef W3_IC3 - NAMELIST /SIC3/ IC3MAXTHK, IC2TURB, IC2ROUGH, IC2REYNOLDS, & - IC2SMOOTH, IC2VISC, IC2TURBS, IC3MAXCNC, & - IC3CHENG, USECGICE, IC3HILIM, IC3KILIM, & - IC3VISC, IC3ELAS, IC3DENS, IC3HICE + NAMELIST /SIC3/ IC3MAXTHK, IC2TURB, IC2ROUGH, IC2REYNOLDS, & + IC2SMOOTH, IC2VISC, IC2TURBS, IC3MAXCNC, & + IC3CHENG, USECGICE, IC3HILIM, IC3KILIM, & + IC3VISC, IC3ELAS, IC3DENS, IC3HICE #endif #ifdef W3_IC4 - NAMELIST /SIC4/ IC4METHOD, IC4KI, IC4FC + NAMELIST /SIC4/ IC4METHOD, IC4KI, IC4FC #endif #ifdef W3_IC5 - NAMELIST /SIC5/ IC5MINIG, IC5MINWT, IC5MAXKRATIO, & - IC5MAXKI, IC5MINHW, IC5MAXITER, IC5RKICK,& - IC5KFILTER, IC5VEMOD + NAMELIST /SIC5/ IC5MINIG, IC5MINWT, IC5MAXKRATIO, & + IC5MAXKI, IC5MINHW, IC5MAXITER, IC5RKICK,& + IC5KFILTER, IC5VEMOD #endif #ifdef W3_IG1 - NAMELIST /SIG1/ IGMETHOD, IGADDOUTP, IGSOURCE, IGBCOVERWRITE, & - IGMAXFREQ, IGSTERMS, IGSWELLMAX, & - IGSOURCEATBP, IGKDMIN, IGFIXEDDEPTH, IGEMPIRICAL + NAMELIST /SIG1/ IGMETHOD, IGADDOUTP, IGSOURCE, IGBCOVERWRITE, & + IGMAXFREQ, IGSTERMS, IGSWELLMAX, & + IGSOURCEATBP, IGKDMIN, IGFIXEDDEPTH, IGEMPIRICAL #endif #ifdef W3_LN1 - NAMELIST /SLN1/ CLIN, RFPM, RFHF + NAMELIST /SLN1/ CLIN, RFPM, RFHF #endif #ifdef W3_ST1 - NAMELIST /SIN1/ CINP + NAMELIST /SIN1/ CINP #endif #ifdef W3_ST2 - NAMELIST /SIN2/ ZWND, SWELLF, STABSH, STABOF, CNEG, CPOS, FNEG + NAMELIST /SIN2/ ZWND, SWELLF, STABSH, STABOF, CNEG, CPOS, FNEG #endif #ifdef W3_ST3 - NAMELIST /SIN3/ ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & - SWELLF + NAMELIST /SIN3/ ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & + SWELLF #endif #ifdef W3_ST4 - NAMELIST /SIN4/ ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & - TAUWSHELTER, SWELLFPAR, SWELLF, & - SWELLF2, SWELLF3, SWELLF4, SWELLF5, SWELLF6, & - SWELLF7, Z0RAT, SINBR + NAMELIST /SIN4/ ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & + TAUWSHELTER, SWELLFPAR, SWELLF, & + SWELLF2, SWELLF3, SWELLF4, SWELLF5, SWELLF6, & + SWELLF7, Z0RAT, SINBR #endif #ifdef W3_NL1 - NAMELIST /SNL1/ LAMBDA, NLPROP, KDCONV, KDMIN, & - SNLCS1, SNLCS2, SNLCS3 + NAMELIST /SNL1/ LAMBDA, NLPROP, KDCONV, KDMIN, & + SNLCS1, SNLCS2, SNLCS3 #endif #ifdef W3_NL2 - NAMELIST /SNL2/ IQTYPE, TAILNL, NDEPTH - NAMELIST /ANL2/ DEPTHS + NAMELIST /SNL2/ IQTYPE, TAILNL, NDEPTH + NAMELIST /ANL2/ DEPTHS #endif #ifdef W3_NL3 - NAMELIST /SNL3/ NQDEF, MSC, NSC, KDFD, KDFS - NAMELIST /ANL3/ QPARMS + NAMELIST /SNL3/ NQDEF, MSC, NSC, KDFD, KDFS + NAMELIST /ANL3/ QPARMS #endif #ifdef W3_NL4 - NAMELIST /SNL4/ INDTSA, ALTLP + NAMELIST /SNL4/ INDTSA, ALTLP #endif #ifdef W3_NL5 - NAMELIST /SNL5/ NL5DPT, NL5OML, NL5DIS, NL5KEV, NL5IPL, NL5PMX + NAMELIST /SNL5/ NL5DPT, NL5OML, NL5DIS, NL5KEV, NL5IPL, NL5PMX #endif #ifdef W3_NLS - NAMELIST /SNLS/ A34, FHFC, DNM, FC1, FC2, FC3 + NAMELIST /SNLS/ A34, FHFC, DNM, FC1, FC2, FC3 #endif #ifdef W3_ST1 - NAMELIST /SDS1/ CDIS, APM + NAMELIST /SDS1/ CDIS, APM #endif #ifdef W3_ST2 - NAMELIST /SDS2/ SDSA0, SDSA1, SDSA2, SDSB0, SDSB1, PHIMIN + NAMELIST /SDS2/ SDSA0, SDSA1, SDSA2, SDSB0, SDSB1, PHIMIN #endif #ifdef W3_ST3 - NAMELIST /SDS3/ SDSC1, WNMEANP, FXPM3, FXFM3, SDSDELTA1, & - SDSDELTA2 + NAMELIST /SDS3/ SDSC1, WNMEANP, FXPM3, FXFM3, SDSDELTA1, & + SDSDELTA2 #endif #ifdef W3_ST4 - NAMELIST /SDS4/ SDSBCHOICE, WNMEANP, WNMEANPTAIL, FXPM3, FXFM3, & - FXFMAGE, SDSC2, SDSCUM, SDSSTRAIN, SDSSTRAINA, & - SDSSTRAIN2, SDSC4, SDSFACMTF, SDSNMTF,SDSCUMP, & - SDSC5, SDSC6, SDSBR, SDSBT, SDSP, SDSISO, & - SDSBCK, SDSABK, SDSPBK, SDSBINT, SDSHCK, & - SDSDTH, SDSCOS, SDSBRF1, SDSBRFDF, SDSNUW, & - SDSBM0, SDSBM1, SDSBM2, SDSBM3, SDSBM4, & - WHITECAPWIDTH, WHITECAPDUR, SDSMWD, SDSMWPOW, SDKOF + NAMELIST /SDS4/ SDSBCHOICE, WNMEANP, WNMEANPTAIL, FXPM3, FXFM3, & + FXFMAGE, SDSC2, SDSCUM, SDSSTRAIN, SDSSTRAINA, & + SDSSTRAIN2, SDSC4, SDSFACMTF, SDSNMTF,SDSCUMP, & + SDSC5, SDSC6, SDSBR, SDSBT, SDSP, SDSISO, & + SDSBCK, SDSABK, SDSPBK, SDSBINT, SDSHCK, & + SDSDTH, SDSCOS, SDSBRF1, SDSBRFDF, SDSNUW, & + SDSBM0, SDSBM1, SDSBM2, SDSBM3, SDSBM4, & + WHITECAPWIDTH, WHITECAPDUR, SDSMWD, SDSMWPOW, SDKOF #endif #ifdef W3_ST6 - NAMELIST /SIN6/ SINA0, SINWS, SINFC - NAMELIST /SDS6/ SDSET, SDSA1, SDSA2, SDSP1, SDSP2 - NAMELIST /SWL6/ SWLB1, CSTB1 + NAMELIST /SIN6/ SINA0, SINWS, SINFC + NAMELIST /SDS6/ SDSET, SDSA1, SDSA2, SDSP1, SDSP2 + NAMELIST /SWL6/ SWLB1, CSTB1 #endif #ifdef W3_BT1 - NAMELIST /SBT1/ GAMMA + NAMELIST /SBT1/ GAMMA #endif #ifdef W3_BT4 - NAMELIST /SBT4/ SEDMAPD50, SED_D50_UNIFORM, RIPFAC1, & - RIPFAC2, RIPFAC3, RIPFAC4, SIGDEPTH, & - BOTROUGHMIN, BOTROUGHFAC + NAMELIST /SBT4/ SEDMAPD50, SED_D50_UNIFORM, RIPFAC1, & + RIPFAC2, RIPFAC3, RIPFAC4, SIGDEPTH, & + BOTROUGHMIN, BOTROUGHFAC #endif #ifdef W3_DB1 - NAMELIST /SDB1/ BJALFA, BJGAM, BJFLAG + NAMELIST /SDB1/ BJALFA, BJGAM, BJFLAG #endif #ifdef W3_UOST - NAMELIST /UOST/ UOSTFILELOCAL, UOSTFILESHADOW, & - UOSTFACTORLOCAL, UOSTFACTORSHADOW + NAMELIST /UOST/ UOSTFILELOCAL, UOSTFILESHADOW, & + UOSTFACTORLOCAL, UOSTFACTORSHADOW #endif -! + ! #ifdef W3_PR1 - NAMELIST /PRO1/ CFLTM + NAMELIST /PRO1/ CFLTM #endif #ifdef W3_PR2 - NAMELIST /PRO2/ CFLTM, DTIME, LATMIN + NAMELIST /PRO2/ CFLTM, DTIME, LATMIN #endif #ifdef W3_SMC - NAMELIST /PSMC/ CFLSM, DTIMS, RFMAXD, Arctic, AVERG, UNO3, & - LvSMC, ISHFT, JEQT, NBISMC, SEAWND + NAMELIST /PSMC/ CFLSM, DTIMS, RFMAXD, Arctic, AVERG, UNO3, & + LvSMC, ISHFT, JEQT, NBISMC, SEAWND #endif -! + ! #ifdef W3_PR3 - NAMELIST /PRO3/ CFLTM, WDTHCG, WDTHTH -#endif - NAMELIST /UNST/ UGOBCAUTO, UGOBCDEPTH, UGOBCFILE, & - UGBCCFL, EXPFSN, EXPFSPSI, EXPFSFCT, & - IMPFSN, IMPTOTAL, EXPTOTAL, & - IMPREFRACTION, IMPFREQSHIFT, & - IMPSOURCE, & - JGS_TERMINATE_MAXITER, & - JGS_TERMINATE_DIFFERENCE, & - JGS_TERMINATE_NORM, & - JGS_LIMITER, & - JGS_USE_JACOBI, & - JGS_BLOCK_GAUSS_SEIDEL, & - JGS_MAXITER, & - JGS_PMIN, & - JGS_DIFF_THR, & - JGS_NORM_THR, & - JGS_NLEVEL, & - JGS_SOURCE_NONLINEAR, & - SETUP_APPLY_WLV, SOLVERTHR_SETUP, & - CRIT_DEP_SETUP - NAMELIST /MISC/ CICE0, CICEN, LICE, XSEED, FLAGTR, XP, XR, & - XFILT, PMOVE, IHM, HSPM, WSM, WSC, FLC, FMICHE, & - RWNDC, FACBERG, NOSW, GSHIFT, WCOR1, WCOR2, & - STDX, STDY, STDT, ICEHMIN, ICEHINIT, ICEDISP, & - ICESLN, ICEWIND, ICESNL, ICESDS, ICEHFAC, & - ICEHDISP, ICEDDISP, ICEFDISP, CALTYPE, & - TRCKCMPR, PTM, PTFC, BTBET - NAMELIST /OUTS/ P2SF, I1P2SF, I2P2SF, & - US3D, I1US3D, I2US3D, & - USSP, IUSSP, STK_WN, & - E3D, I1E3D, I2E3D, & - TH1MF, I1TH1M, I2TH1M, & - STH1MF, I1STH1M, I2STH1M, & - TH2MF, I1TH2M, I2TH2M, & - STH2MF, I1STH2M, I2STH2M + NAMELIST /PRO3/ CFLTM, WDTHCG, WDTHTH +#endif + NAMELIST /UNST/ UGOBCAUTO, UGOBCDEPTH, UGOBCFILE, & + UGBCCFL, EXPFSN, EXPFSPSI, EXPFSFCT, & + IMPFSN, IMPTOTAL, EXPTOTAL, & + IMPREFRACTION, IMPFREQSHIFT, & + IMPSOURCE, & + JGS_TERMINATE_MAXITER, & + JGS_TERMINATE_DIFFERENCE, & + JGS_TERMINATE_NORM, & + JGS_LIMITER, & + JGS_USE_JACOBI, & + JGS_BLOCK_GAUSS_SEIDEL, & + JGS_MAXITER, & + JGS_PMIN, & + JGS_DIFF_THR, & + JGS_NORM_THR, & + JGS_NLEVEL, & + JGS_SOURCE_NONLINEAR, & + SETUP_APPLY_WLV, SOLVERTHR_SETUP, & + CRIT_DEP_SETUP + NAMELIST /MISC/ CICE0, CICEN, LICE, XSEED, FLAGTR, XP, XR, & + XFILT, PMOVE, IHM, HSPM, WSM, WSC, FLC, FMICHE, & + RWNDC, FACBERG, NOSW, GSHIFT, WCOR1, WCOR2, & + STDX, STDY, STDT, ICEHMIN, ICEHINIT, ICEDISP, & + ICESLN, ICEWIND, ICESNL, ICESDS, ICEHFAC, & + ICEHDISP, ICEDDISP, ICEFDISP, CALTYPE, & + TRCKCMPR, PTM, PTFC, BTBET + NAMELIST /OUTS/ P2SF, I1P2SF, I2P2SF, & + US3D, I1US3D, I2US3D, & + USSP, IUSSP, STK_WN, & + E3D, I1E3D, I2E3D, & + TH1MF, I1TH1M, I2TH1M, & + STH1MF, I1STH1M, I2STH1M, & + TH2MF, I1TH2M, I2TH2M, & + STH2MF, I1STH2M, I2STH2M #ifdef W3_IS1 - NAMELIST /SIS1/ ISC1, ISC2 + NAMELIST /SIS1/ ISC1, ISC2 #endif #ifdef W3_IS2 - NAMELIST /SIS2/ ISC1, IS2C2, IS2C3, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, & - IS2DISP, IS2FRAGILITY, IS2CONC, IS2DMIN, & - IS2DAMP, IS2DUPDATE, IS2CREEPB, IS2CREEPC, & - IS2CREEPD, IS2CREEPN, IS2BREAKE, IS2BREAKF, & - IS2WIM1, IS2FLEXSTR, IS2ANDISB, IS2ANDISE, IS2ANDISD, & - IS2ANDISN + NAMELIST /SIS2/ ISC1, IS2C2, IS2C3, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, & + IS2DISP, IS2FRAGILITY, IS2CONC, IS2DMIN, & + IS2DAMP, IS2DUPDATE, IS2CREEPB, IS2CREEPC, & + IS2CREEPD, IS2CREEPN, IS2BREAKE, IS2BREAKF, & + IS2WIM1, IS2FLEXSTR, IS2ANDISB, IS2ANDISE, IS2ANDISD, & + IS2ANDISN #endif #ifdef W3_REF1 - NAMELIST /REF1/ REFCOAST, REFFREQ, REFMAP, REFMAPD, & - REFSUBGRID, REFICEBERG, & - REFCOSP_STRAIGHT, REFSLOPE, REFRMAX, & - REFFREQPOW, REFUNSTSOURCE + NAMELIST /REF1/ REFCOAST, REFFREQ, REFMAP, REFMAPD, & + REFSUBGRID, REFICEBERG, & + REFCOSP_STRAIGHT, REFSLOPE, REFRMAX, & + REFFREQPOW, REFUNSTSOURCE #endif -!/ + !/ #ifdef W3_RTD - NAMELIST /ROTD/ PLAT, PLON, UNROT -! Poles of destination grids for boundary conditions output - NAMELIST /ROTB/ BPLAT, BPLON -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ - DATA YESXNO / 'YES/--' , '---/NO' / + NAMELIST /ROTD/ PLAT, PLON, UNROT + ! Poles of destination grids for boundary conditions output + NAMELIST /ROTB/ BPLAT, BPLON +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + DATA YESXNO / 'YES/--' , '---/NO' / - CONTAINS +CONTAINS - SUBROUTINE W3GRID() + SUBROUTINE W3GRID() #ifdef W3_O0 - FLNMLO = .TRUE. + FLNMLO = .TRUE. #endif #ifdef W3_STAB2 - FLSTB2 = .TRUE. -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. Set up grid storage structure -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. IO set-up. -! - NDSI = 10 - NDSS = 99 - NDSM = 20 -! - INQUIRE(FILE=TRIM(FNMPRE)//"ww3_grid.nml", EXIST=FLGNML) - IF (FLGNML) THEN - ! Read namelist - CALL W3NMLGRID (NDSI, TRIM(FNMPRE)//'ww3_grid.nml', NML_SPECTRUM, NML_RUN, & - NML_TIMESTEPS, NML_GRID, NML_RECT, NML_CURV, & - NML_UNST, NML_SMC, NML_DEPTH, NML_MASK, & - NML_OBST, NML_SLOPE, NML_SED, NML_INBND_COUNT, & - NML_INBND_POINT, NML_EXCL_COUNT, & - NML_EXCL_POINT, NML_EXCL_BODY, & - NML_OUTBND_COUNT, NML_OUTBND_LINE, IERR) - ELSE - OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_grid.inp',STATUS='OLD', & - ERR=2000,IOSTAT=IERR) - END IF -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + FLSTB2 = .TRUE. +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1. Set up grid storage structure + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. IO set-up. + ! + NDSI = 10 + NDSS = 99 + NDSM = 20 + ! + INQUIRE(FILE=TRIM(FNMPRE)//"ww3_grid.nml", EXIST=FLGNML) + IF (FLGNML) THEN + ! Read namelist + CALL W3NMLGRID (NDSI, TRIM(FNMPRE)//'ww3_grid.nml', NML_SPECTRUM, NML_RUN, & + NML_TIMESTEPS, NML_GRID, NML_RECT, NML_CURV, & + NML_UNST, NML_SMC, NML_DEPTH, NML_MASK, & + NML_OBST, NML_SLOPE, NML_SED, NML_INBND_COUNT, & + NML_INBND_POINT, NML_EXCL_COUNT, & + NML_EXCL_POINT, NML_EXCL_BODY, & + NML_OUTBND_COUNT, NML_OUTBND_LINE, IERR) + ELSE + OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_grid.inp',STATUS='OLD', & + ERR=2000,IOSTAT=IERR) + END IF + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_S - CALL STRACE (IENT, 'W3GRID') -#endif - WRITE (NDSO,900) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3.a Interpolation table for dispersion relation. -! - CALL DISTAB -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3.b Table for friction factors -! - CALL TABU_FW -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4 Read and process input file up to spectrum -! + CALL STRACE (IENT, 'W3GRID') +#endif + WRITE (NDSO,900) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3.a Interpolation table for dispersion relation. + ! + CALL DISTAB + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3.b Table for friction factors + ! + CALL TABU_FW + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4 Read and process input file up to spectrum + ! - IF (FLGNML) THEN - ! grid name - GNAME=TRIM(NML_GRID%NAME) - WRITE (NDSO,902) GNAME + IF (FLGNML) THEN + ! grid name + GNAME=TRIM(NML_GRID%NAME) + WRITE (NDSO,902) GNAME - ! spectrum parameters - RXFR=NML_SPECTRUM%XFR - RFR1=NML_SPECTRUM%FREQ1 - NKI=NML_SPECTRUM%NK - NTHI=NML_SPECTRUM%NTH - RTH0=NML_SPECTRUM%THOFF + ! spectrum parameters + RXFR=NML_SPECTRUM%XFR + RFR1=NML_SPECTRUM%FREQ1 + NKI=NML_SPECTRUM%NK + NTHI=NML_SPECTRUM%NTH + RTH0=NML_SPECTRUM%THOFF - ELSE + ELSE - READ (NDSI,'(A)',END=2001,ERR=2002,IOSTAT=IERR) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR - CALL NEXTLN ( COMSTR , NDSI , NDSE ) -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) GNAME - WRITE (NDSO,902) GNAME -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) RXFR, RFR1, NKI, NTHI, RTH0 - END IF + READ (NDSI,'(A)',END=2001,ERR=2002,IOSTAT=IERR) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) GNAME + WRITE (NDSO,902) GNAME + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) RXFR, RFR1, NKI, NTHI, RTH0 + END IF - NK = NKI - NK2 = NKI + 2 - NTH = NTHI - NSPEC = NK * NTH - XFR = MAX ( RXFR , 1.00001 ) - FR1 = MAX ( RFR1 , 1.E-6 ) - DTH = TPI / REAL(NTH) - RTH0 = MAX ( -0.5 , MIN ( 0.5 , RTH0 ) ) - WRITE (NDSO,903) NTH, DTH*RADE - WRITE (NDSO,904) 360./REAL(NTH)*RTH0 - WRITE (NDSO,905) NK, FR1, FR1*XFR**(NK-1), XFR -! - CALL W3DIMS ( 1, NK, NTH, NDSE, NDST ) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Initialize spectral parameters. -! 5.a Directions : -! - DO ITH=1, NTH - TH (ITH) = DTH * ( RTH0 + REAL(ITH-1) ) - ESIN(ITH) = SIN ( TH(ITH) ) - ECOS(ITH) = COS ( TH(ITH) ) - IF ( ABS(ESIN(ITH)) .LT. 1.E-5 ) THEN - ESIN(ITH) = 0. - IF ( ECOS(ITH) .GT. 0.5 ) THEN - ECOS(ITH) = 1. - ELSE - ECOS(ITH) = -1. - END IF - END IF - IF ( ABS(ECOS(ITH)) .LT. 1.E-5 ) THEN - ECOS(ITH) = 0. - IF ( ESIN(ITH) .GT. 0.5 ) THEN - ESIN(ITH) = 1. - ELSE - ESIN(ITH) = -1. - END IF - END IF - ES2 (ITH) = ESIN(ITH)**2 - EC2 (ITH) = ECOS(ITH)**2 - ESC (ITH) = ESIN(ITH)*ECOS(ITH) - END DO -! - DO IK=2, NK+1 - ITH0 = (IK-1)*NTH - DO ITH=1, NTH - ESIN(ITH0+ITH) = ESIN(ITH) - ECOS(ITH0+ITH) = ECOS(ITH) - ES2 (ITH0+ITH) = ES2 (ITH) - EC2 (ITH0+ITH) = EC2 (ITH) - ESC (ITH0+ITH) = ESC (ITH) - END DO - END DO -! -! b Frequencies : -! - SIGMA = FR1 * TPI / XFR**2 - SXFR = 0.5 * (XFR-1./XFR) -! - DO IK=0, NK+1 - SIGMA = SIGMA * XFR - SIG (IK) = SIGMA - DSIP(IK) = SIGMA * SXFR - END DO -! - DSII( 1) = 0.5 * SIG( 1) * (XFR-1.) - DO IK=2, NK-1 - DSII(IK) = DSIP(IK) - END DO - DSII(NK) = 0.5 * SIG(NK) * (XFR-1.) / XFR -! - DO IK=1, NK - DDEN(IK) = DTH * DSII(IK) * SIG(IK) - END DO -! - DO ISP=1, NSPEC - IK = 1 + (ISP-1)/NTH - SIG2 (ISP) = SIG (IK) - DDEN2(ISP) = DDEN(IK) - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6 Read and process input file up to numerical parameters -! 6.a Set model flags and time steps -! - WRITE (NDSO,910) - IF (FLGNML) THEN - FLDRY=NML_RUN%FLDRY - FLCX=NML_RUN%FLCX - FLCY=NML_RUN%FLCY - FLCTH=NML_RUN%FLCTH - FLCK=NML_RUN%FLCK - FLSOU=NML_RUN%FLSOU - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) & - FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU + NK = NKI + NK2 = NKI + 2 + NTH = NTHI + NSPEC = NK * NTH + XFR = MAX ( RXFR , 1.00001 ) + FR1 = MAX ( RFR1 , 1.E-6 ) + DTH = TPI / REAL(NTH) + RTH0 = MAX ( -0.5 , MIN ( 0.5 , RTH0 ) ) + WRITE (NDSO,903) NTH, DTH*RADE + WRITE (NDSO,904) 360./REAL(NTH)*RTH0 + WRITE (NDSO,905) NK, FR1, FR1*XFR**(NK-1), XFR + ! + CALL W3DIMS ( 1, NK, NTH, NDSE, NDST ) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Initialize spectral parameters. + ! 5.a Directions : + ! + DO ITH=1, NTH + TH (ITH) = DTH * ( RTH0 + REAL(ITH-1) ) + ESIN(ITH) = SIN ( TH(ITH) ) + ECOS(ITH) = COS ( TH(ITH) ) + IF ( ABS(ESIN(ITH)) .LT. 1.E-5 ) THEN + ESIN(ITH) = 0. + IF ( ECOS(ITH) .GT. 0.5 ) THEN + ECOS(ITH) = 1. + ELSE + ECOS(ITH) = -1. + END IF END IF -! - IYN = 2 - IF ( FLDRY ) IYN(1) = 1 - IF ( FLCX ) IYN(2) = 1 - IF ( FLCY ) IYN(3) = 1 - IF ( FLCTH ) IYN(4) = 1 - IF ( FLCK ) IYN(5) = 1 - IF ( FLSOU ) IYN(6) = 1 -! - WRITE (NDSO,911) (YESXNO(IYN(IFL)),IFL=1,NFL) -! - IF ( .NOT. (FLDRY.OR.FLCX.OR.FLCY.OR.FLCK.OR.FLCTH.OR.FLSOU) ) THEN - WRITE (NDSE,1010) - CALL EXTCDE ( 2 ) + IF ( ABS(ECOS(ITH)) .LT. 1.E-5 ) THEN + ECOS(ITH) = 0. + IF ( ESIN(ITH) .GT. 0.5 ) THEN + ESIN(ITH) = 1. + ELSE + ESIN(ITH) = -1. END IF -! - IF (FLGNML) THEN - DTMAX=NML_TIMESTEPS%DTMAX - DTCFL=NML_TIMESTEPS%DTXY - DTCFLI=NML_TIMESTEPS%DTKTH - DTMIN=NML_TIMESTEPS%DTMIN - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) DTMAX, DTCFL, DTCFLI, DTMIN END IF + ES2 (ITH) = ESIN(ITH)**2 + EC2 (ITH) = ECOS(ITH)**2 + ESC (ITH) = ESIN(ITH)*ECOS(ITH) + END DO + ! + DO IK=2, NK+1 + ITH0 = (IK-1)*NTH + DO ITH=1, NTH + ESIN(ITH0+ITH) = ESIN(ITH) + ECOS(ITH0+ITH) = ECOS(ITH) + ES2 (ITH0+ITH) = ES2 (ITH) + EC2 (ITH0+ITH) = EC2 (ITH) + ESC (ITH0+ITH) = ESC (ITH) + END DO + END DO + ! + ! b Frequencies : + ! + SIGMA = FR1 * TPI / XFR**2 + SXFR = 0.5 * (XFR-1./XFR) + ! + DO IK=0, NK+1 + SIGMA = SIGMA * XFR + SIG (IK) = SIGMA + DSIP(IK) = SIGMA * SXFR + END DO + ! + DSII( 1) = 0.5 * SIG( 1) * (XFR-1.) + DO IK=2, NK-1 + DSII(IK) = DSIP(IK) + END DO + DSII(NK) = 0.5 * SIG(NK) * (XFR-1.) / XFR + ! + DO IK=1, NK + DDEN(IK) = DTH * DSII(IK) * SIG(IK) + END DO + ! + DO ISP=1, NSPEC + IK = 1 + (ISP-1)/NTH + SIG2 (ISP) = SIG (IK) + DDEN2(ISP) = DDEN(IK) + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6 Read and process input file up to numerical parameters + ! 6.a Set model flags and time steps + ! + WRITE (NDSO,910) + IF (FLGNML) THEN + FLDRY=NML_RUN%FLDRY + FLCX=NML_RUN%FLCX + FLCY=NML_RUN%FLCY + FLCTH=NML_RUN%FLCTH + FLCK=NML_RUN%FLCK + FLSOU=NML_RUN%FLSOU + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) & + FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU + END IF + ! + IYN = 2 + IF ( FLDRY ) IYN(1) = 1 + IF ( FLCX ) IYN(2) = 1 + IF ( FLCY ) IYN(3) = 1 + IF ( FLCTH ) IYN(4) = 1 + IF ( FLCK ) IYN(5) = 1 + IF ( FLSOU ) IYN(6) = 1 + ! + WRITE (NDSO,911) (YESXNO(IYN(IFL)),IFL=1,NFL) + ! + IF ( .NOT. (FLDRY.OR.FLCX.OR.FLCY.OR.FLCK.OR.FLCTH.OR.FLSOU) ) THEN + WRITE (NDSE,1010) + CALL EXTCDE ( 2 ) + END IF + ! + IF (FLGNML) THEN + DTMAX=NML_TIMESTEPS%DTMAX + DTCFL=NML_TIMESTEPS%DTXY + DTCFLI=NML_TIMESTEPS%DTKTH + DTMIN=NML_TIMESTEPS%DTMIN + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) DTMAX, DTCFL, DTCFLI, DTMIN + END IF #ifdef W3_SEC1 - IF (DTMAX.LT.1.) THEN - NITERSEC1=CEILING(1./DTMAX) - WRITE (NDSO,913) NITERSEC1 - ELSE - NITERSEC1=1 - END IF + IF (DTMAX.LT.1.) THEN + NITERSEC1=CEILING(1./DTMAX) + WRITE (NDSO,913) NITERSEC1 + ELSE + NITERSEC1=1 + END IF #endif - DTMAX = MAX ( 1. , DTMAX ) -! -! Commented to allow very high resolution zooms -! -! DTCFL = MAX ( 1. , DTCFL ) -! DTCFLI = MIN ( DTMAX , MAX ( 1. , DTCFLI ) ) - DTMIN = MIN ( DTMAX , MAX ( 0. , DTMIN ) ) - WRITE (NDSO,912) DTMAX, DTCFL, DTCFLI, DTMIN -! -! 6.b Set / select source term package -! - NRLIN = 0 - NRSRCE = 0 - NRNL = 0 - NRBT = 0 - NRIC = 0 - NRIS = 0 - NRDB = 0 - NRTR = 0 - NRBS = 0 -! - FLLIN = .TRUE. - FLINDS = .TRUE. - FLNL = .TRUE. - FLBT = .TRUE. - FLIC = .FALSE. - FLIS = .FALSE. - FLDB = .TRUE. - FLTR = .TRUE. - FLBS = .TRUE. - FLREF = .FALSE. -! + DTMAX = MAX ( 1. , DTMAX ) + ! + ! Commented to allow very high resolution zooms + ! + ! DTCFL = MAX ( 1. , DTCFL ) + ! DTCFLI = MIN ( DTMAX , MAX ( 1. , DTCFLI ) ) + DTMIN = MIN ( DTMAX , MAX ( 0. , DTMIN ) ) + WRITE (NDSO,912) DTMAX, DTCFL, DTCFLI, DTMIN + ! + ! 6.b Set / select source term package + ! + NRLIN = 0 + NRSRCE = 0 + NRNL = 0 + NRBT = 0 + NRIC = 0 + NRIS = 0 + NRDB = 0 + NRTR = 0 + NRBS = 0 + ! + FLLIN = .TRUE. + FLINDS = .TRUE. + FLNL = .TRUE. + FLBT = .TRUE. + FLIC = .FALSE. + FLIS = .FALSE. + FLDB = .TRUE. + FLTR = .TRUE. + FLBS = .TRUE. + FLREF = .FALSE. + ! #ifdef W3_LN0 - NRLIN = NRLIN + 1 - FLLIN = .FALSE. + NRLIN = NRLIN + 1 + FLLIN = .FALSE. #endif #ifdef W3_SEED - NRLIN = NRLIN + 1 + NRLIN = NRLIN + 1 #endif #ifdef W3_LN1 - NRLIN = NRLIN + 1 + NRLIN = NRLIN + 1 #endif -! + ! #ifdef W3_ST0 - NRSRCE = NRSRCE + 1 - FLINDS = .FALSE. + NRSRCE = NRSRCE + 1 + FLINDS = .FALSE. #endif #ifdef W3_ST1 - NRSRCE = NRSRCE + 1 + NRSRCE = NRSRCE + 1 #endif #ifdef W3_ST2 - NRSRCE = NRSRCE + 1 - FLTC96 = .TRUE. + NRSRCE = NRSRCE + 1 + FLTC96 = .TRUE. #endif #ifdef W3_ST3 - NRSRCE = NRSRCE + 1 + NRSRCE = NRSRCE + 1 #endif #ifdef W3_ST4 - NRSRCE = NRSRCE + 1 - FLST4 = .TRUE. + NRSRCE = NRSRCE + 1 + FLST4 = .TRUE. #endif #ifdef W3_ST6 - NRSRCE = NRSRCE + 1 - FLST6 = .TRUE. + NRSRCE = NRSRCE + 1 + FLST6 = .TRUE. #endif -! + ! #ifdef W3_NL0 - NRNL = NRNL + 1 - FLNL = .FALSE. + NRNL = NRNL + 1 + FLNL = .FALSE. #endif #ifdef W3_NL1 - NRNL = NRNL + 1 + NRNL = NRNL + 1 #endif #ifdef W3_NL2 - NRNL = NRNL + 1 + NRNL = NRNL + 1 #endif #ifdef W3_NL3 - NRNL = NRNL + 1 + NRNL = NRNL + 1 #endif #ifdef W3_NL4 - NRNL = NRNL + 1 + NRNL = NRNL + 1 #endif #ifdef W3_NL5 - NRNL = NRNL + 1 + NRNL = NRNL + 1 #endif -! + ! #ifdef W3_BT0 - NRBT = NRBT + 1 - FLBT = .FALSE. + NRBT = NRBT + 1 + FLBT = .FALSE. #endif #ifdef W3_BT1 - NRBT = NRBT + 1 + NRBT = NRBT + 1 #endif #ifdef W3_BT4 - NRBT = NRBT + 1 + NRBT = NRBT + 1 #endif #ifdef W3_BT8 - NRBT = NRBT + 1 + NRBT = NRBT + 1 #endif #ifdef W3_BT9 - NRBT = NRBT + 1 + NRBT = NRBT + 1 #endif -! + ! #ifdef W3_IC1 - NRIC = NRIC + 1 - FLIC = .TRUE. + NRIC = NRIC + 1 + FLIC = .TRUE. #endif #ifdef W3_IC2 - NRIC = NRIC + 1 - FLIC = .TRUE. + NRIC = NRIC + 1 + FLIC = .TRUE. #endif #ifdef W3_IC3 - NRIC = NRIC + 1 - FLIC = .TRUE. + NRIC = NRIC + 1 + FLIC = .TRUE. #endif #ifdef W3_IC4 - NRIC = NRIC + 1 - FLIC = .TRUE. + NRIC = NRIC + 1 + FLIC = .TRUE. #endif #ifdef W3_IC5 - NRIC = NRIC + 1 - FLIC = .TRUE. + NRIC = NRIC + 1 + FLIC = .TRUE. #endif -! + ! #ifdef W3_IS1 - NRIS = NRIS + 1 - FLIS = .TRUE. + NRIS = NRIS + 1 + FLIS = .TRUE. #endif #ifdef W3_IS2 - NRIS = NRIS + 1 - FLIS = .TRUE. + NRIS = NRIS + 1 + FLIS = .TRUE. #endif -! + ! #ifdef W3_DB0 - NRDB = NRDB + 1 - FLDB = .FALSE. + NRDB = NRDB + 1 + FLDB = .FALSE. #endif #ifdef W3_DB1 - NRDB = NRDB + 1 + NRDB = NRDB + 1 #endif -! + ! #ifdef W3_TR0 - NRTR = NRTR + 1 - FLTR = .FALSE. + NRTR = NRTR + 1 + FLTR = .FALSE. #endif #ifdef W3_TR1 - NRTR = NRTR + 1 + NRTR = NRTR + 1 #endif -! + ! #ifdef W3_BS0 - NRBS = NRBS + 1 - FLBS = .FALSE. + NRBS = NRBS + 1 + FLBS = .FALSE. #endif #ifdef W3_BS1 - NRBS = NRBS + 1 + NRBS = NRBS + 1 #endif -! + ! #ifdef W3_REF1 - FLREF = .TRUE. -#endif -! - IF ( .NOT.FLLIN .AND. .NOT.FLINDS .AND. .NOT.FLNL .AND. & - .NOT.FLBT .AND. .NOT.FLIC .AND. .NOT.FLIS .AND. & - .NOT.FLDB .AND. .NOT.FLTR .AND. .NOT.FLBS .AND. & - .NOT.FLREF .AND. FLSOU ) THEN - WRITE (NDSE,1020) - CALL EXTCDE ( 10 ) - END IF -! - IF ( ( FLLIN .OR. FLINDS .OR. FLNL .OR. FLBT .OR. FLDB .OR. & - FLTR .OR. FLBS .OR. FLREF .OR. FLIC ) & - .AND. .NOT.FLSOU ) THEN - WRITE (NDSE,1021) - END IF -! - IF ( NRLIN .NE. 1 ) THEN - WRITE (NDSE,1022) NRLIN - CALL EXTCDE ( 11 ) - END IF -! - IF ( NRSRCE .NE. 1 ) THEN - WRITE (NDSE,1023) NRSRCE - CALL EXTCDE ( 12 ) - END IF -! - IF ( NRNL .NE. 1 ) THEN - WRITE (NDSE,1024) NRNL - CALL EXTCDE ( 13 ) - END IF -! - IF ( NRBT .NE. 1 ) THEN - WRITE (NDSE,1025) NRBT - CALL EXTCDE ( 14 ) - END IF -! - IF ( NRDB .NE. 1 ) THEN - WRITE (NDSE,1026) NRDB - CALL EXTCDE ( 15 ) - END IF -! - IF ( NRTR .NE. 1 ) THEN - WRITE (NDSE,1027) NRTR - CALL EXTCDE ( 16 ) - END IF -! - IF ( NRBS .NE. 1 ) THEN - WRITE (NDSE,1028) NRBS - CALL EXTCDE ( 17 ) - END IF -! - IF ( NRIC .GT. 1 ) THEN - WRITE (NDSE,1034) NRIC - CALL EXTCDE ( 19 ) - END IF -! - IF ( NRIS .GT. 1 ) THEN - WRITE (NDSE,1036) NRIS - CALL EXTCDE ( 26 ) - END IF + FLREF = .TRUE. +#endif + ! + IF ( .NOT.FLLIN .AND. .NOT.FLINDS .AND. .NOT.FLNL .AND. & + .NOT.FLBT .AND. .NOT.FLIC .AND. .NOT.FLIS .AND. & + .NOT.FLDB .AND. .NOT.FLTR .AND. .NOT.FLBS .AND. & + .NOT.FLREF .AND. FLSOU ) THEN + WRITE (NDSE,1020) + CALL EXTCDE ( 10 ) + END IF + ! + IF ( ( FLLIN .OR. FLINDS .OR. FLNL .OR. FLBT .OR. FLDB .OR. & + FLTR .OR. FLBS .OR. FLREF .OR. FLIC ) & + .AND. .NOT.FLSOU ) THEN + WRITE (NDSE,1021) + END IF + ! + IF ( NRLIN .NE. 1 ) THEN + WRITE (NDSE,1022) NRLIN + CALL EXTCDE ( 11 ) + END IF + ! + IF ( NRSRCE .NE. 1 ) THEN + WRITE (NDSE,1023) NRSRCE + CALL EXTCDE ( 12 ) + END IF + ! + IF ( NRNL .NE. 1 ) THEN + WRITE (NDSE,1024) NRNL + CALL EXTCDE ( 13 ) + END IF + ! + IF ( NRBT .NE. 1 ) THEN + WRITE (NDSE,1025) NRBT + CALL EXTCDE ( 14 ) + END IF + ! + IF ( NRDB .NE. 1 ) THEN + WRITE (NDSE,1026) NRDB + CALL EXTCDE ( 15 ) + END IF + ! + IF ( NRTR .NE. 1 ) THEN + WRITE (NDSE,1027) NRTR + CALL EXTCDE ( 16 ) + END IF + ! + IF ( NRBS .NE. 1 ) THEN + WRITE (NDSE,1028) NRBS + CALL EXTCDE ( 17 ) + END IF + ! + IF ( NRIC .GT. 1 ) THEN + WRITE (NDSE,1034) NRIC + CALL EXTCDE ( 19 ) + END IF + ! + IF ( NRIS .GT. 1 ) THEN + WRITE (NDSE,1036) NRIS + CALL EXTCDE ( 26 ) + END IF -! -! 6.c Read namelist file or Pre-process namelists into scratch file -! - WRITE (NDSO,915) - IF (FLGNML) THEN - OPEN (NDSS,FILE=TRIM(FNMPRE)//TRIM(NML_GRID%NML),STATUS='OLD',FORM='FORMATTED') - ELSE - OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_grid.scratch',FORM='FORMATTED') - DO - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,'(A)',END=2001,ERR=2002) LINE - IF ( LINE(1:16) .EQ. 'END OF NAMELISTS' ) THEN - EXIT - ELSE - WRITE (NDSS,'(A)') LINE - ENDIF - END DO - END IF - WRITE (NDSO,916) -! -! 6.d Define Sin. -! 6.d.1 Stresses -! + ! + ! 6.c Read namelist file or Pre-process namelists into scratch file + ! + WRITE (NDSO,915) + IF (FLGNML) THEN + OPEN (NDSS,FILE=TRIM(FNMPRE)//TRIM(NML_GRID%NML),STATUS='OLD',FORM='FORMATTED') + ELSE + OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_grid.scratch',FORM='FORMATTED') + DO + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,'(A)',END=2001,ERR=2002) LINE + IF ( LINE(1:16) .EQ. 'END OF NAMELISTS' ) THEN + EXIT + ELSE + WRITE (NDSS,'(A)') LINE + ENDIF + END DO + END IF + WRITE (NDSO,916) + ! + ! 6.d Define Sin. + ! 6.d.1 Stresses + ! #ifdef W3_FLX1 - WRITE (NDSO,810) -#endif -#ifdef W3_FLX2 - WRITE (NDSO,810) + WRITE (NDSO,810) #endif -! #ifdef W3_FLX2 - CINXSI = 0.20 - NITTIN = 3 -#endif -#ifdef W3_FLX3 - CINXSI = 0.20 - NITTIN = 3 - CDMAX = 2.5E-3 - CTYPE = 0 + WRITE (NDSO,810) + CINXSI = 0.20 + NITTIN = 3 #endif -! #ifdef W3_FLX3 - CALL READNL ( NDSS, 'FLX3', STATUS ) - WRITE (NDSO,810) STATUS - CDMAX = MAX ( 0. , CDMAX ) - IF ( CTYPE .EQ. 1 ) THEN - TYPEID = 'hyperbolic tangent' - ELSE - CTYPE = 0 - TYPEID = 'discontinuous ' - END IF - WRITE (NDSO,811) CDMAX*1.E3, TYPEID - CD_MAX = CDMAX - CAP_ID = CTYPE -#endif -! + CINXSI = 0.20 + NITTIN = 3 + CDMAX = 2.5E-3 + CTYPE = 0 + CALL READNL ( NDSS, 'FLX3', STATUS ) + WRITE (NDSO,810) STATUS + CDMAX = MAX ( 0. , CDMAX ) + IF ( CTYPE .EQ. 1 ) THEN + TYPEID = 'hyperbolic tangent' + ELSE + CTYPE = 0 + TYPEID = 'discontinuous ' + END IF + WRITE (NDSO,811) CDMAX*1.E3, TYPEID + CD_MAX = CDMAX + CAP_ID = CTYPE +#endif + ! #ifdef W3_FLX4 - CDFAC = 1.0 - CALL READNL ( NDSS, 'FLX4', STATUS ) - WRITE (NDSO,810) STATUS - WRITE (NDSO,811) CDFAC - FLX4A0 = CDFAC + CDFAC = 1.0 + CALL READNL ( NDSS, 'FLX4', STATUS ) + WRITE (NDSO,810) STATUS + WRITE (NDSO,811) CDFAC + FLX4A0 = CDFAC #endif #ifdef W3_FLX5 - WRITE (NDSO,810) + WRITE (NDSO,810) #endif -! -! 6.d.2 Linear input -! + ! + ! 6.d.2 Linear input + ! #ifdef W3_LN0 - WRITE (NDSO,820) + WRITE (NDSO,820) #endif #ifdef W3_SEED - WRITE (NDSO,820) + WRITE (NDSO,820) #endif -! + ! #ifdef W3_LN1 - CLIN = 80. - RFPM = 1. - RFHF = 0.5 -#endif -! -#ifdef W3_LN1 - CALL READNL ( NDSS, 'SLN1', STATUS ) - WRITE (NDSO,820) STATUS - CLIN = MAX (0.,CLIN) - RFPM = MAX (0.,RFPM) - RFHF = MAX(0.,MIN (1.,RFHF)) - WRITE (NDSO,821) CLIN, RFPM, RFHF - SLNC1 = CLIN * (DAIR/DWAT)**2 / GRAV**2 - FSPM = RFPM - FSHF = RFHF -#endif -! -! 6.d.3 Exponential input -! + CLIN = 80. + RFPM = 1. + RFHF = 0.5 + CALL READNL ( NDSS, 'SLN1', STATUS ) + WRITE (NDSO,820) STATUS + CLIN = MAX (0.,CLIN) + RFPM = MAX (0.,RFPM) + RFHF = MAX(0.,MIN (1.,RFHF)) + WRITE (NDSO,821) CLIN, RFPM, RFHF + SLNC1 = CLIN * (DAIR/DWAT)**2 / GRAV**2 + FSPM = RFPM + FSHF = RFHF +#endif + ! + ! 6.d.3 Exponential input + ! #ifdef W3_ST0 - WRITE (NDSO,920) + WRITE (NDSO,920) #endif -! + ! #ifdef W3_ST1 - CINP = 0.25 + CINP = 0.25 #endif #ifdef W3_ST2 - ZWND = 10. - SWELLF = 0.100 - STABSH = 1.38 - STABOF = -0.01 - CNEG = -0.1 - CPOS = 0.1 - FNEG = 150. -#endif -! + ZWND = 10. + SWELLF = 0.100 + STABSH = 1.38 + STABOF = -0.01 + CNEG = -0.1 + CPOS = 0.1 + FNEG = 150. +#endif + ! #ifdef W3_ST3 - ZWND = 10. - ALPHA0 = 0.0095 - Z0MAX = 0.0 - BETAMAX = 1.2 ! default WAM4 / WAM4 + is 1.2 with rhow=1000 - SINTHP = 2. - SWELLF = 0. - ZALP = 0.0110 -#endif -! + ZWND = 10. + ALPHA0 = 0.0095 + Z0MAX = 0.0 + BETAMAX = 1.2 ! default WAM4 / WAM4 + is 1.2 with rhow=1000 + SINTHP = 2. + SWELLF = 0. + ZALP = 0.0110 +#endif + ! #ifdef W3_ST4 - ZWND = 10. - ALPHA0 = 0.0095 - Z0MAX = 0.0 - Z0RAT = 0.04 - BETAMAX = 1.43 - SINTHP = 2. - SWELLF = 0.66 - SWELLFPAR = 1 - SWELLF2 = -0.018 - SWELLF3 = 0.022 - SWELLF4 = 1.5E5 - SWELLF5 = 1.2 - SWELLF6 = 0. - SWELLF7 = 360000. - TAUWSHELTER = 0.3 - ZALP = 0.006 - SINBR = 0. -#endif -! + ZWND = 10. + ALPHA0 = 0.0095 + Z0MAX = 0.0 + Z0RAT = 0.04 + BETAMAX = 1.43 + SINTHP = 2. + SWELLF = 0.66 + SWELLFPAR = 1 + SWELLF2 = -0.018 + SWELLF3 = 0.022 + SWELLF4 = 1.5E5 + SWELLF5 = 1.2 + SWELLF6 = 0. + SWELLF7 = 360000. + TAUWSHELTER = 0.3 + ZALP = 0.006 + SINBR = 0. +#endif + ! #ifdef W3_ST6 - SINA0 = 0.09 - SINWS = 32.0 - SINFC = 6.0 + SINA0 = 0.09 + SINWS = 32.0 + SINFC = 6.0 #endif -! + ! #ifdef W3_ST1 - CALL READNL ( NDSS, 'SIN1', STATUS ) - WRITE (NDSO,920) STATUS - WRITE (NDSO,921) CINP - SINC1 = 28. * CINP * DAIR / DWAT + CALL READNL ( NDSS, 'SIN1', STATUS ) + WRITE (NDSO,920) STATUS + WRITE (NDSO,921) CINP + SINC1 = 28. * CINP * DAIR / DWAT #endif -! + ! #ifdef W3_ST2 - CALL READNL ( NDSS, 'SIN2', STATUS ) - WRITE (NDSO,920) STATUS - IF ( SWELLF.LT.0. .OR. SWELLF.GT.1. ) SWELLF = 1. - WRITE (NDSO,921) ZWND, SWELLF - IF ( STABSH .LT. 0.1 ) STABSH = 1. - IF ( CNEG*CPOS .EQ. 0. ) THEN - CNEG = 0. - CPOS = 0. - FNEG = 0. - FPOS = 0. - ELSE - CPOS = - ABS(CPOS) * ABS(CNEG)/CNEG - FNEG = - MAX(1.,ABS(FNEG)) - FPOS = FNEG * CNEG/CPOS - END IF + CALL READNL ( NDSS, 'SIN2', STATUS ) + WRITE (NDSO,920) STATUS + IF ( SWELLF.LT.0. .OR. SWELLF.GT.1. ) SWELLF = 1. + WRITE (NDSO,921) ZWND, SWELLF + IF ( STABSH .LT. 0.1 ) STABSH = 1. + IF ( CNEG*CPOS .EQ. 0. ) THEN + CNEG = 0. + CPOS = 0. + FNEG = 0. + FPOS = 0. + ELSE + CPOS = - ABS(CPOS) * ABS(CNEG)/CNEG + FNEG = - MAX(1.,ABS(FNEG)) + FPOS = FNEG * CNEG/CPOS + END IF #endif #ifdef W3_STAB2 - WRITE (NDSO,1921) STABSH, STABOF, CNEG, CPOS, FNEG, FPOS + WRITE (NDSO,1921) STABSH, STABOF, CNEG, CPOS, FNEG, FPOS #endif #ifdef W3_ST2 - ZWIND = ZWND - FSWELL = SWELLF - SHSTAB = STABSH - OFSTAB = STABOF - CCNG = CNEG - CCPS = CPOS - FFNG = FNEG - FFPS = FPOS -#endif -! + ZWIND = ZWND + FSWELL = SWELLF + SHSTAB = STABSH + OFSTAB = STABOF + CCNG = CNEG + CCPS = CPOS + FFNG = FNEG + FFPS = FPOS +#endif + ! #ifdef W3_ST3 - CALL READNL ( NDSS, 'SIN3', STATUS ) - WRITE (NDSO,920) STATUS - WRITE (NDSO,921) ALPHA0, BETAMAX, SINTHP, Z0MAX, ZALP, ZWND, & - SWELLF - ZZWND = ZWND - AALPHA = ALPHA0 - BBETA = BETAMAX - SSINTHP = SINTHP - ZZ0MAX = Z0MAX - ZZALP = ZALP - SSWELLF(1) = SWELLF -#endif -! + CALL READNL ( NDSS, 'SIN3', STATUS ) + WRITE (NDSO,920) STATUS + WRITE (NDSO,921) ALPHA0, BETAMAX, SINTHP, Z0MAX, ZALP, ZWND, & + SWELLF + ZZWND = ZWND + AALPHA = ALPHA0 + BBETA = BETAMAX + SSINTHP = SINTHP + ZZ0MAX = Z0MAX + ZZALP = ZALP + SSWELLF(1) = SWELLF +#endif + ! #ifdef W3_ST4 - CALL READNL ( NDSS, 'SIN4', STATUS ) - WRITE (NDSO,920) STATUS - WRITE (NDSO,921) ALPHA0, BETAMAX, SINTHP, Z0MAX, ZALP, ZWND, TAUWSHELTER, & - SWELLFPAR, SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, & - SWELLF6, SWELLF7, Z0RAT - ZZWND = ZWND - AALPHA = ALPHA0 - BBETA = BETAMAX - SSINBR = SINBR - SSINTHP = SINTHP - ZZ0MAX = Z0MAX - ZZ0RAT = Z0RAT - ZZALP = ZALP - TTAUWSHELTER = TAUWSHELTER - SSWELLF(1) = SWELLF - SSWELLF(2) = SWELLF2 - SSWELLF(3) = SWELLF3 - SSWELLF(4) = SWELLF4 - SSWELLF(5) = SWELLF5 - SSWELLF(6) = SWELLF6 - SSWELLF(7) = SWELLF7 - SSWELLFPAR = SWELLFPAR -#endif -! + CALL READNL ( NDSS, 'SIN4', STATUS ) + WRITE (NDSO,920) STATUS + WRITE (NDSO,921) ALPHA0, BETAMAX, SINTHP, Z0MAX, ZALP, ZWND, TAUWSHELTER, & + SWELLFPAR, SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, & + SWELLF6, SWELLF7, Z0RAT + ZZWND = ZWND + AALPHA = ALPHA0 + BBETA = BETAMAX + SSINBR = SINBR + SSINTHP = SINTHP + ZZ0MAX = Z0MAX + ZZ0RAT = Z0RAT + ZZALP = ZALP + TTAUWSHELTER = TAUWSHELTER + SSWELLF(1) = SWELLF + SSWELLF(2) = SWELLF2 + SSWELLF(3) = SWELLF3 + SSWELLF(4) = SWELLF4 + SSWELLF(5) = SWELLF5 + SSWELLF(6) = SWELLF6 + SSWELLF(7) = SWELLF7 + SSWELLFPAR = SWELLFPAR +#endif + ! #ifdef W3_ST6 - CALL READNL ( NDSS, 'SIN6', STATUS ) - WRITE (NDSO,920) STATUS - SIN6A0 = SINA0 - SIN6WS = SINWS - SIN6FC = SINFC - J = 1 - IF ( SIN6A0.LE.0. ) J = 2 - WRITE (NDSO,921) YESXNO(J), SIN6A0, SIN6WS, SIN6FC -#endif -! -! 6.e Define Snl. -! + CALL READNL ( NDSS, 'SIN6', STATUS ) + WRITE (NDSO,920) STATUS + SIN6A0 = SINA0 + SIN6WS = SINWS + SIN6FC = SINFC + J = 1 + IF ( SIN6A0.LE.0. ) J = 2 + WRITE (NDSO,921) YESXNO(J), SIN6A0, SIN6WS, SIN6FC +#endif + ! + ! 6.e Define Snl. + ! #ifdef W3_NL0 - WRITE (NDSO,922) -#endif -! -#ifdef W3_NL1 - LAMBDA = 0.25 - IF ( FLTC96 ) THEN - NLPROP = 1.00E7 - ELSE IF ( FLST4 ) THEN - NLPROP = 2.50E7 - ELSE IF ( FLST6 ) THEN - NLPROP = 3.00E7 - ELSE - NLPROP = 2.78E7 - END IF -#endif -! -#ifdef W3_NL1 - KDCONV = 0.75 - KDMIN = 0.50 - SNLCS1 = 5.5 - SNLCS2 = 0.833 - SNLCS3 = -1.25 + WRITE (NDSO,922) #endif -! + ! #ifdef W3_NL1 - CALL READNL ( NDSS, 'SNL1', STATUS ) - WRITE (NDSO,922) STATUS - WRITE (NDSO,923) LAMBDA, NLPROP, KDCONV, KDMIN, & - SNLCS1, SNLCS2, SNLCS3 - SNLC1 = NLPROP / GRAV**4 - LAM = LAMBDA - KDCON = KDCONV - KDMN = KDMIN - SNLS1 = SNLCS1 - SNLS2 = SNLCS2 - SNLS3 = SNLCS3 -#endif -! + LAMBDA = 0.25 + IF ( FLTC96 ) THEN + NLPROP = 1.00E7 + ELSE IF ( FLST4 ) THEN + NLPROP = 2.50E7 + ELSE IF ( FLST6 ) THEN + NLPROP = 3.00E7 + ELSE + NLPROP = 2.78E7 + END IF + KDCONV = 0.75 + KDMIN = 0.50 + SNLCS1 = 5.5 + SNLCS2 = 0.833 + SNLCS3 = -1.25 + CALL READNL ( NDSS, 'SNL1', STATUS ) + WRITE (NDSO,922) STATUS + WRITE (NDSO,923) LAMBDA, NLPROP, KDCONV, KDMIN, & + SNLCS1, SNLCS2, SNLCS3 + SNLC1 = NLPROP / GRAV**4 + LAM = LAMBDA + KDCON = KDCONV + KDMN = KDMIN + SNLS1 = SNLCS1 + SNLS2 = SNLCS2 + SNLS3 = SNLCS3 +#endif + ! #ifdef W3_ST0 - FACHF = 5. + FACHF = 5. #endif #ifdef W3_ST1 - FACHF = 4.5 + FACHF = 4.5 #endif #ifdef W3_ST2 - FACHF = 5. + FACHF = 5. #endif #ifdef W3_ST3 - FACHF = 5. + FACHF = 5. #endif #ifdef W3_ST4 - FACHF = 5. + FACHF = 5. #endif #ifdef W3_ST6 - FACHF = 5. + FACHF = 5. #endif #ifdef W3_NL2 - IQTYPE = 2 - TAILNL = -FACHF - NDEPTH = 0 + IQTYPE = 2 + TAILNL = -FACHF + NDEPTH = 0 #endif #ifdef W3_NL3 - NQDEF = 0 - MSC = 0. - NSC = -3.5 - KDFD = 0.20 - KDFS = 5.00 + NQDEF = 0 + MSC = 0. + NSC = -3.5 + KDFD = 0.20 + KDFS = 5.00 #endif #ifdef W3_NL4 - INDTSA = 1 - ALTLP = 2 + INDTSA = 1 + ALTLP = 2 #endif #ifdef W3_NL5 - NL5DPT = 3000. - NL5OML = 0.10 - NL5DIS = 0 - NL5KEV = 0 - NL5IPL = 1 - NL5PMX = 100 + NL5DPT = 3000. + NL5OML = 0.10 + NL5DIS = 0 + NL5KEV = 0 + NL5IPL = 1 + NL5PMX = 100 #endif #ifdef W3_NLS - A34 = 0.05 - FHFC = 1.E10 - DNM = 0.25 - FC1 = 1.25 - FC2 = 1.50 - FC3 = 6.00 -#endif -! + A34 = 0.05 + FHFC = 1.E10 + DNM = 0.25 + FC1 = 1.25 + FC2 = 1.50 + FC3 = 6.00 +#endif + ! #ifdef W3_NL2 - CALL READNL ( NDSS, 'SNL2', STATUS ) - WRITE (NDSO,922) STATUS - TAILNL = MIN ( MAX ( TAILNL, -5. ) , -4. ) - IF ( IQTYPE .EQ. 3 ) THEN - WRITE (NDSO,923) 'Shallow water', TAILNL - ELSE IF ( IQTYPE .EQ. 2 ) THEN - WRITE (NDSO,923) 'Deep water with scaling', TAILNL - ELSE - WRITE (NDSO,923) 'Deep water', TAILNL - IQTYPE = 1 - END IF -! - IF ( IQTYPE .NE. 3 ) THEN - NDEPTH = 1 - ALLOCATE ( MPARS(1)%SNLPS%DPTHNL(NDEPTH) ) - DPTHNL => MPARS(1)%SNLPS%DPTHNL - DPTHNL = 1000. - ELSE - IF ( NDEPTH .EQ. 0 ) NDEPTH = 7 - NDEPTH = MAX ( 1 , NDEPTH ) - ALLOCATE ( MPARS(1)%SNLPS%DPTHNL(NDEPTH) ) - DPTHNL => MPARS(1)%SNLPS%DPTHNL - DPTHNL(1) = 640. - DPTHNL(NDEPTH) = 10. - IF ( NDEPTH .GT. 1 ) THEN - DPTFAC = (DPTHNL(NDEPTH)/DPTHNL(1))**(1./(REAL(NDEPTH-1))) - DO IDEPTH=2, NDEPTH-1 - DPTHNL(IDEPTH) = DPTFAC*DPTHNL(IDEPTH-1) - END DO - END IF - CALL READNL ( NDSS, 'ANL2', STATUS ) - WRITE (NDSO,1923) NDEPTH, DPTHNL(1:MIN(5,NDEPTH)) - IF (NDEPTH .GT. 5 )WRITE (NDSO,2923) DPTHNL(6:NDEPTH) - END IF - WRITE (NDST,*) - IQTPE = IQTYPE - NDPTHS = NDEPTH - NLTAIL = TAILNL -#endif -! + CALL READNL ( NDSS, 'SNL2', STATUS ) + WRITE (NDSO,922) STATUS + TAILNL = MIN ( MAX ( TAILNL, -5. ) , -4. ) + IF ( IQTYPE .EQ. 3 ) THEN + WRITE (NDSO,923) 'Shallow water', TAILNL + ELSE IF ( IQTYPE .EQ. 2 ) THEN + WRITE (NDSO,923) 'Deep water with scaling', TAILNL + ELSE + WRITE (NDSO,923) 'Deep water', TAILNL + IQTYPE = 1 + END IF + ! + IF ( IQTYPE .NE. 3 ) THEN + NDEPTH = 1 + ALLOCATE ( MPARS(1)%SNLPS%DPTHNL(NDEPTH) ) + DPTHNL => MPARS(1)%SNLPS%DPTHNL + DPTHNL = 1000. + ELSE + IF ( NDEPTH .EQ. 0 ) NDEPTH = 7 + NDEPTH = MAX ( 1 , NDEPTH ) + ALLOCATE ( MPARS(1)%SNLPS%DPTHNL(NDEPTH) ) + DPTHNL => MPARS(1)%SNLPS%DPTHNL + DPTHNL(1) = 640. + DPTHNL(NDEPTH) = 10. + IF ( NDEPTH .GT. 1 ) THEN + DPTFAC = (DPTHNL(NDEPTH)/DPTHNL(1))**(1./(REAL(NDEPTH-1))) + DO IDEPTH=2, NDEPTH-1 + DPTHNL(IDEPTH) = DPTFAC*DPTHNL(IDEPTH-1) + END DO + END IF + CALL READNL ( NDSS, 'ANL2', STATUS ) + WRITE (NDSO,1923) NDEPTH, DPTHNL(1:MIN(5,NDEPTH)) + IF (NDEPTH .GT. 5 )WRITE (NDSO,2923) DPTHNL(6:NDEPTH) + END IF + WRITE (NDST,*) + IQTPE = IQTYPE + NDPTHS = NDEPTH + NLTAIL = TAILNL +#endif + ! #ifdef W3_NL3 - CALL READNL ( NDSS, 'SNL3', STATUS ) - WRITE (NDSO,922) STATUS - KDFD = MAX ( 0.001 , MIN ( 10. , KDFD ) ) - KDFS = MAX ( KDFD , MIN ( 10. , KDFS ) ) - WRITE (NDSO,923) MSC, NSC, KDFD, KDFS -! - NQDEF = MAX ( 0 , NQDEF ) - IF ( NQDEF .EQ. 0 ) THEN - NQDEF = 1 - QPARMS(1:5) = [ 0.25 , 0.00, -1., 1.E7, 0.00 ] - ELSE - DO J=1, NQDEF - QPARMS((J-1)*5+1:J*5) = [ 0.25, 0.00, -1., 1.E7, 1.E6 ] - END DO - CALL READNL ( NDSS, 'ANL3', STATUS ) - END IF + CALL READNL ( NDSS, 'SNL3', STATUS ) + WRITE (NDSO,922) STATUS + KDFD = MAX ( 0.001 , MIN ( 10. , KDFD ) ) + KDFS = MAX ( KDFD , MIN ( 10. , KDFS ) ) + WRITE (NDSO,923) MSC, NSC, KDFD, KDFS + ! + NQDEF = MAX ( 0 , NQDEF ) + IF ( NQDEF .EQ. 0 ) THEN + NQDEF = 1 + QPARMS(1:5) = [ 0.25 , 0.00, -1., 1.E7, 0.00 ] + ELSE DO J=1, NQDEF - QPARMS((J-1)*5+1) = MAX(0.,MIN (LAMMAX,QPARMS((J-1)*5+1))) - QPARMS((J-1)*5+2) = MAX(0.,MIN (QPARMS((J-1)*5+1), & - QPARMS((J-1)*5+2))) - QPARMS((J-1)*5+3) = MIN (DELTHM,QPARMS((J-1)*5+3)) - QPARMS((J-1)*5+4) = MAX (0.,QPARMS((J-1)*5+4)) - QPARMS((J-1)*5+5) = MAX (0.,QPARMS((J-1)*5+5)) - END DO - WRITE (NDSO,1923) NQDEF - WRITE (NDSO,2923) QPARMS(1:NQDEF*5) - WRITE (NDSO,*) - SNLNQ = NQDEF - SNLMSC = MSC - SNLNSC = NSC - SNLSFD = SQRT ( KDFD * TANH(KDFD) ) - SNLSFS = SQRT ( KDFS * TANH(KDFS) ) - ALLOCATE ( MPARS(1)%SNLPS%SNLL(NQDEF), & - MPARS(1)%SNLPS%SNLM(NQDEF), & - MPARS(1)%SNLPS%SNLT(NQDEF), & - MPARS(1)%SNLPS%SNLCD(NQDEF), & - MPARS(1)%SNLPS%SNLCS(NQDEF) ) - SNLL => MPARS(1)%SNLPS%SNLL - SNLL = QPARMS(1:NQDEF*5:5) - SNLM => MPARS(1)%SNLPS%SNLM - SNLM = QPARMS(2:NQDEF*5:5) - SNLT => MPARS(1)%SNLPS%SNLT - SNLT = QPARMS(3:NQDEF*5:5) - SNLCD => MPARS(1)%SNLPS%SNLCD - SNLCD = QPARMS(4:NQDEF*5:5) - SNLCS => MPARS(1)%SNLPS%SNLCS - SNLCS = QPARMS(5:NQDEF*5:5) -#endif -! + QPARMS((J-1)*5+1:J*5) = [ 0.25, 0.00, -1., 1.E7, 1.E6 ] + END DO + CALL READNL ( NDSS, 'ANL3', STATUS ) + END IF + DO J=1, NQDEF + QPARMS((J-1)*5+1) = MAX(0.,MIN (LAMMAX,QPARMS((J-1)*5+1))) + QPARMS((J-1)*5+2) = MAX(0.,MIN (QPARMS((J-1)*5+1), & + QPARMS((J-1)*5+2))) + QPARMS((J-1)*5+3) = MIN (DELTHM,QPARMS((J-1)*5+3)) + QPARMS((J-1)*5+4) = MAX (0.,QPARMS((J-1)*5+4)) + QPARMS((J-1)*5+5) = MAX (0.,QPARMS((J-1)*5+5)) + END DO + WRITE (NDSO,1923) NQDEF + WRITE (NDSO,2923) QPARMS(1:NQDEF*5) + WRITE (NDSO,*) + SNLNQ = NQDEF + SNLMSC = MSC + SNLNSC = NSC + SNLSFD = SQRT ( KDFD * TANH(KDFD) ) + SNLSFS = SQRT ( KDFS * TANH(KDFS) ) + ALLOCATE ( MPARS(1)%SNLPS%SNLL(NQDEF), & + MPARS(1)%SNLPS%SNLM(NQDEF), & + MPARS(1)%SNLPS%SNLT(NQDEF), & + MPARS(1)%SNLPS%SNLCD(NQDEF), & + MPARS(1)%SNLPS%SNLCS(NQDEF) ) + SNLL => MPARS(1)%SNLPS%SNLL + SNLL = QPARMS(1:NQDEF*5:5) + SNLM => MPARS(1)%SNLPS%SNLM + SNLM = QPARMS(2:NQDEF*5:5) + SNLT => MPARS(1)%SNLPS%SNLT + SNLT = QPARMS(3:NQDEF*5:5) + SNLCD => MPARS(1)%SNLPS%SNLCD + SNLCD = QPARMS(4:NQDEF*5:5) + SNLCS => MPARS(1)%SNLPS%SNLCS + SNLCS = QPARMS(5:NQDEF*5:5) +#endif + ! #ifdef W3_NL4 - CALL READNL ( NDSS, 'SNL4', STATUS ) - WRITE (NDSO,922) STATUS - WRITE (NDSO,923) INDTSA, ALTLP - ITSA = INDTSA - IALT = ALTLP + CALL READNL ( NDSS, 'SNL4', STATUS ) + WRITE (NDSO,922) STATUS + WRITE (NDSO,923) INDTSA, ALTLP + ITSA = INDTSA + IALT = ALTLP #endif -! + ! #ifdef W3_NL5 - CALL READNL ( NDSS, 'SNL5', STATUS ) - WRITE (NDSO,922) STATUS - NL5DPT = MAX(0., MIN(NL5DPT, 3000.)) - NL5DIS = MAX(0 , MIN(NL5DIS, 1)) - NL5KEV = MAX(0 , MIN(NL5KEV, 1)) - NL5IPL = MAX(0 , MIN(NL5IPL, 1)) - IF (NL5DIS .EQ. 1) NL5IPL = 0 - IF (NL5PMX .GT. 0) NL5PMX = MAX(10, NL5PMX) - WRITE (NDSO,923) NL5DPT, NL5OML, NL5DIS, NL5KEV, NL5IPL, NL5PMX - QR5DPT = NL5DPT - QR5OML = NL5OML - QI5DIS = NL5DIS - QI5KEV = NL5KEV - QI5IPL = NL5IPL - QI5PMX = NL5PMX -#endif -! + CALL READNL ( NDSS, 'SNL5', STATUS ) + WRITE (NDSO,922) STATUS + NL5DPT = MAX(0., MIN(NL5DPT, 3000.)) + NL5DIS = MAX(0 , MIN(NL5DIS, 1)) + NL5KEV = MAX(0 , MIN(NL5KEV, 1)) + NL5IPL = MAX(0 , MIN(NL5IPL, 1)) + IF (NL5DIS .EQ. 1) NL5IPL = 0 + IF (NL5PMX .GT. 0) NL5PMX = MAX(10, NL5PMX) + WRITE (NDSO,923) NL5DPT, NL5OML, NL5DIS, NL5KEV, NL5IPL, NL5PMX + QR5DPT = NL5DPT + QR5OML = NL5OML + QI5DIS = NL5DIS + QI5KEV = NL5KEV + QI5IPL = NL5IPL + QI5PMX = NL5PMX +#endif + ! #ifdef W3_NLS - CALL READNL ( NDSS, 'SNLS', STATUS ) - WRITE (NDSO,9922) STATUS - A34 = MAX ( 0. , MIN ( A34 , ABMAX ) ) - FHFC = MAX ( 0. , FHFC ) - DNM = MAX ( 0., DNM ) - WRITE (NDSO,9923) A34, (XFR-1.)*A34, FHFC, DNM, FC1, FC2, FC3 - CNLSA = A34 - CNLSC = FHFC - CNLSFM = DNM - CNLSC1 = FC1 - CNLSC2 = FC2 - CNLSC3 = FC3 -#endif -! -! 6.f Define Sds. -! + CALL READNL ( NDSS, 'SNLS', STATUS ) + WRITE (NDSO,9922) STATUS + A34 = MAX ( 0. , MIN ( A34 , ABMAX ) ) + FHFC = MAX ( 0. , FHFC ) + DNM = MAX ( 0., DNM ) + WRITE (NDSO,9923) A34, (XFR-1.)*A34, FHFC, DNM, FC1, FC2, FC3 + CNLSA = A34 + CNLSC = FHFC + CNLSFM = DNM + CNLSC1 = FC1 + CNLSC2 = FC2 + CNLSC3 = FC3 +#endif + ! + ! 6.f Define Sds. + ! #ifdef W3_ST0 - WRITE (NDSO,924) + WRITE (NDSO,924) #endif -! + ! #ifdef W3_ST1 - CDIS = -2.36E-5 - APM = 3.02E-3 + CDIS = -2.36E-5 + APM = 3.02E-3 #endif #ifdef W3_ST2 - SDSA0 = 4.8 - SDSA1 = 1.7e-4 - SDSA2 = 2.0 - SDSB0 = 0.3e-3 - SDSB1 = 0.47 - PHIMIN = 0.003 - SDSALN = 0.002 - FPIMIN = 0.009 + SDSA0 = 4.8 + SDSA1 = 1.7e-4 + SDSA2 = 2.0 + SDSB0 = 0.3e-3 + SDSB1 = 0.47 + PHIMIN = 0.003 + SDSALN = 0.002 + FPIMIN = 0.009 #endif #ifdef W3_ST3 - SDSC1 = -2.1 !! This is Bidlot et al. 2005, Otherwise WAM4 uses -4.5 - WNMEANP = 0.5 !! This is Bidlot et al. 2005, Otherwise WAM4 uses -0.5 - FXFM3 = 2.5 - FXPM3 = 4. - WNMEANPTAIL = 0.5 - SDSDELTA1 = 0.4 !! This is Bidlot et al. 2005, Otherwise WAM4 uses 0.5 - SDSDELTA2 = 0.6 !! This is Bidlot et al. 2005, Otherwise WAM4 uses 0.5 -#endif -! + SDSC1 = -2.1 !! This is Bidlot et al. 2005, Otherwise WAM4 uses -4.5 + WNMEANP = 0.5 !! This is Bidlot et al. 2005, Otherwise WAM4 uses -0.5 + FXFM3 = 2.5 + FXPM3 = 4. + WNMEANPTAIL = 0.5 + SDSDELTA1 = 0.4 !! This is Bidlot et al. 2005, Otherwise WAM4 uses 0.5 + SDSDELTA2 = 0.6 !! This is Bidlot et al. 2005, Otherwise WAM4 uses 0.5 +#endif + ! #ifdef W3_ST4 - WNMEANP = 0.5 ! taken from Bidlot et al. 2005 - FXFM3 = 2.5 - FXFMAGE = 0. - FXPM3 = 4. - WNMEANPTAIL = -0.5 - SDSBCHOICE =1 ! 1: Ardhuin et al., 2: Filipot & Ardhuin, 3: Romero - SDSC2 = -2.2E-5 ! -3.8 for Romero - SDSCUM = -0.40344 - SDSC4 = 1. - SDSC5 = 0. - SDSNUW = 0. - SDSC6 = 0.3 - SDSBR = 0.90E-3 ! 0.005 for Romero - SDSBRFDF = 0 - SDSBRF1 = 0.5 - SDSP = 2. ! this is now fixed in w3sds4, should be cleaned up - SDSDTH = 80. - SDSCOS = 2. - SDSISO = 2 - SDSBM0 = 1. - SDSBM1 = 0. - SDSBM2 = 0. - SDSBM3 = 0. - SDSBM4 = 0. - SDSBCK = 0. - SDSABK = 1.5 - SDSPBK = 4. - SDSBINT = 0.3 - SDSHCK = 1.5 - WHITECAPWIDTH = 0.3 - SDSSTRAIN = 0. - SDSFACMTF = 400 ! MTF factor for Lambda , Romero (2019) - SDSSTRAINA = 15. - SDSSTRAIN2 = 0. - WHITECAPDUR = 0.56 ! breaking duration factor -! b (strength of breaking) - SDSBT = 1.100E-3 ! B_T (sturation threshold for dissipation rate b) -! Lambda parameters - SDSL = 3.5000e-05 ! L scaling -! MTF - SPMSS = 0.5 ! cmss^SPMSS - SDSNMTF = 1.5 ! MTF power - SDSCUMP = 2. -! MW - SDSMWD = .9 ! new AFo - SDSMWPOW = 1. ! (k )^pow - SDKOF = 3. ! ko factor such that ko= g (SDKOF/(28 us))^2 -#endif -! + WNMEANP = 0.5 ! taken from Bidlot et al. 2005 + FXFM3 = 2.5 + FXFMAGE = 0. + FXPM3 = 4. + WNMEANPTAIL = -0.5 + SDSBCHOICE =1 ! 1: Ardhuin et al., 2: Filipot & Ardhuin, 3: Romero + SDSC2 = -2.2E-5 ! -3.8 for Romero + SDSCUM = -0.40344 + SDSC4 = 1. + SDSC5 = 0. + SDSNUW = 0. + SDSC6 = 0.3 + SDSBR = 0.90E-3 ! 0.005 for Romero + SDSBRFDF = 0 + SDSBRF1 = 0.5 + SDSP = 2. ! this is now fixed in w3sds4, should be cleaned up + SDSDTH = 80. + SDSCOS = 2. + SDSISO = 2 + SDSBM0 = 1. + SDSBM1 = 0. + SDSBM2 = 0. + SDSBM3 = 0. + SDSBM4 = 0. + SDSBCK = 0. + SDSABK = 1.5 + SDSPBK = 4. + SDSBINT = 0.3 + SDSHCK = 1.5 + WHITECAPWIDTH = 0.3 + SDSSTRAIN = 0. + SDSFACMTF = 400 ! MTF factor for Lambda , Romero (2019) + SDSSTRAINA = 15. + SDSSTRAIN2 = 0. + WHITECAPDUR = 0.56 ! breaking duration factor + ! b (strength of breaking) + SDSBT = 1.100E-3 ! B_T (sturation threshold for dissipation rate b) + ! Lambda parameters + SDSL = 3.5000e-05 ! L scaling + ! MTF + SPMSS = 0.5 ! cmss^SPMSS + SDSNMTF = 1.5 ! MTF power + SDSCUMP = 2. + ! MW + SDSMWD = .9 ! new AFo + SDSMWPOW = 1. ! (k )^pow + SDKOF = 3. ! ko factor such that ko= g (SDKOF/(28 us))^2 +#endif + ! #ifdef W3_ST6 - SDSET = .TRUE. - SDSA1 = 4.75E-06 - SDSP1 = 4 - SDSA2 = 7.00E-05 - SDSP2 = 4 - CSTB1 = .FALSE. - SWLB1 = 0.41E-02 -#endif -! + SDSET = .TRUE. + SDSA1 = 4.75E-06 + SDSP1 = 4 + SDSA2 = 7.00E-05 + SDSP2 = 4 + CSTB1 = .FALSE. + SWLB1 = 0.41E-02 +#endif + ! #ifdef W3_ST1 - CALL READNL ( NDSS, 'SDS1', STATUS ) - WRITE (NDSO,924) STATUS - WRITE (NDSO,925) CDIS, APM - SDSC1 = TPI * CDIS / APM**2 + CALL READNL ( NDSS, 'SDS1', STATUS ) + WRITE (NDSO,924) STATUS + WRITE (NDSO,925) CDIS, APM + SDSC1 = TPI * CDIS / APM**2 #endif -! + ! #ifdef W3_ST2 - CALL READNL ( NDSS, 'SDS2', STATUS ) - WRITE (NDSO,924) STATUS - IF ( PHIMIN .LE. 0. ) THEN - SDSB2 = 0. - SDSB3 = 0. - PHIMIN = SDSB0 + SDSB1*FPIMIN - ELSE - FPIA = ( PHIMIN - SDSB0 ) / SDSB1 - IF ( FPIA .LT. FPIMIN ) THEN - SDSB3 = 4. - SDSB2 = FPIMIN**SDSB3 * (PHIMIN-SDSB0-SDSB1*FPIMIN) - ELSE - FPIB = MAX ( FPIA-0.0025 , FPIMIN ) - DPHID = MAX ( PHIMIN - SDSB0 - SDSB1*FPIB , 1.E-15 ) - SDSB3 = MIN ( 10. , SDSB1*FPIB / DPHID ) - SDSB2 = FPIB**SDSB3 * DPHID - FPIMIN = FPIB - END IF - END IF - WRITE (NDSO,925) SDSA0, SDSA1, SDSA2, & - SDSB0, SDSB1, SDSB2, SDSB3, FPIMIN, PHIMIN - CDSA0 = SDSA0 - CDSA1 = SDSA1 - CDSA2 = SDSA2 - CDSB0 = SDSB0 - CDSB1 = SDSB1 - CDSB2 = SDSB2 - CDSB3 = SDSB3 -#endif -! + CALL READNL ( NDSS, 'SDS2', STATUS ) + WRITE (NDSO,924) STATUS + IF ( PHIMIN .LE. 0. ) THEN + SDSB2 = 0. + SDSB3 = 0. + PHIMIN = SDSB0 + SDSB1*FPIMIN + ELSE + FPIA = ( PHIMIN - SDSB0 ) / SDSB1 + IF ( FPIA .LT. FPIMIN ) THEN + SDSB3 = 4. + SDSB2 = FPIMIN**SDSB3 * (PHIMIN-SDSB0-SDSB1*FPIMIN) + ELSE + FPIB = MAX ( FPIA-0.0025 , FPIMIN ) + DPHID = MAX ( PHIMIN - SDSB0 - SDSB1*FPIB , 1.E-15 ) + SDSB3 = MIN ( 10. , SDSB1*FPIB / DPHID ) + SDSB2 = FPIB**SDSB3 * DPHID + FPIMIN = FPIB + END IF + END IF + WRITE (NDSO,925) SDSA0, SDSA1, SDSA2, & + SDSB0, SDSB1, SDSB2, SDSB3, FPIMIN, PHIMIN + CDSA0 = SDSA0 + CDSA1 = SDSA1 + CDSA2 = SDSA2 + CDSB0 = SDSB0 + CDSB1 = SDSB1 + CDSB2 = SDSB2 + CDSB3 = SDSB3 +#endif + ! #ifdef W3_ST3 - CALL READNL ( NDSS, 'SDS3', STATUS ) - WRITE (NDSO,924) STATUS - WRITE (NDSO,925) SDSC1, WNMEANP, SDSDELTA1, & - SDSDELTA2 - SSDSC1 = SDSC1 - WWNMEANP = WNMEANP - FFXFM = FXFM3 * TPI - FFXPM = FXPM3 * GRAV / 28. - WWNMEANPTAIL = WNMEANPTAIL - DDELTA1 = SDSDELTA1 - DDELTA2 = SDSDELTA2 -#endif -! + CALL READNL ( NDSS, 'SDS3', STATUS ) + WRITE (NDSO,924) STATUS + WRITE (NDSO,925) SDSC1, WNMEANP, SDSDELTA1, & + SDSDELTA2 + SSDSC1 = SDSC1 + WWNMEANP = WNMEANP + FFXFM = FXFM3 * TPI + FFXPM = FXPM3 * GRAV / 28. + WWNMEANPTAIL = WNMEANPTAIL + DDELTA1 = SDSDELTA1 + DDELTA2 = SDSDELTA2 +#endif + ! #ifdef W3_ST4 - CALL READNL ( NDSS, 'SDS4', STATUS ) - WRITE (NDSO,924) STATUS - WRITE (NDSO,925) SDSC2, SDSBCK, SDSCUM, WNMEANP - SSDSC(1) = REAL(SDSBCHOICE) - SSDSC(2) = SDSC2 - SSDSC(3) = SDSCUM - SSDSC(4) = SDSC4 - SSDSC(5) = SDSC5 - SSDSC(6) = SDSC6 - SSDSC(7) = WHITECAPWIDTH - SSDSC(8) = SDSSTRAIN ! Straining constant ... - SSDSC(9) = SDSL - SSDSC(10) = SDSSTRAINA*NTH/360. ! angle Aor enhanced straining - SSDSC(11) = SDSSTRAIN2 ! straining constant for directional part - SSDSC(12) = SDSBT - SSDSC(13) = SDSMWD - SSDSC(14) = SPMSS - SSDSC(15) = SDSMWPOW - SSDSC(16) = SDKOF - SSDSC(17) = WHITECAPDUR - SSDSC(18) = SDSFACMTF - SSDSC(19) = SDSNMTF - SSDSC(20) = SDSCUMP - SSDSC(21) = SDSNUW -#endif -! -#ifdef W3_ST4 - SSDSBR = SDSBR - SSDSBRF1 = SDSBRF1 - SSDSBRFDF= SDSBRFDF - SSDSBM(0) = SDSBM0 - SSDSBM(1) = SDSBM1 - SSDSBM(2) = SDSBM2 - SSDSBM(3) = SDSBM3 - SSDSBM(4) = SDSBM4 - SSDSBT = SDSBT - SSDSISO = SDSISO - SSDSCOS = SDSCOS - SSDSP = SDSP - SSDSDTH = SDSDTH - WWNMEANP = WNMEANP - FFXFM = FXFM3 * TPI - FFXFA = FXFMAGE * TPI - FFXPM = FXPM3 * GRAV / 28. - WWNMEANPTAIL = WNMEANPTAIL - SSDSBCK = SDSBCK - SSDSABK = SDSABK - SSDSPBK = SDSPBK - SSDSBINT = SDSBINT - SSDSHCK = SDSHCK -#endif -! + CALL READNL ( NDSS, 'SDS4', STATUS ) + WRITE (NDSO,924) STATUS + WRITE (NDSO,925) SDSC2, SDSBCK, SDSCUM, WNMEANP + SSDSC(1) = REAL(SDSBCHOICE) + SSDSC(2) = SDSC2 + SSDSC(3) = SDSCUM + SSDSC(4) = SDSC4 + SSDSC(5) = SDSC5 + SSDSC(6) = SDSC6 + SSDSC(7) = WHITECAPWIDTH + SSDSC(8) = SDSSTRAIN ! Straining constant ... + SSDSC(9) = SDSL + SSDSC(10) = SDSSTRAINA*NTH/360. ! angle Aor enhanced straining + SSDSC(11) = SDSSTRAIN2 ! straining constant for directional part + SSDSC(12) = SDSBT + SSDSC(13) = SDSMWD + SSDSC(14) = SPMSS + SSDSC(15) = SDSMWPOW + SSDSC(16) = SDKOF + SSDSC(17) = WHITECAPDUR + SSDSC(18) = SDSFACMTF + SSDSC(19) = SDSNMTF + SSDSC(20) = SDSCUMP + SSDSC(21) = SDSNUW + ! + SSDSBR = SDSBR + SSDSBRF1 = SDSBRF1 + SSDSBRFDF= SDSBRFDF + SSDSBM(0) = SDSBM0 + SSDSBM(1) = SDSBM1 + SSDSBM(2) = SDSBM2 + SSDSBM(3) = SDSBM3 + SSDSBM(4) = SDSBM4 + SSDSBT = SDSBT + SSDSISO = SDSISO + SSDSCOS = SDSCOS + SSDSP = SDSP + SSDSDTH = SDSDTH + WWNMEANP = WNMEANP + FFXFM = FXFM3 * TPI + FFXFA = FXFMAGE * TPI + FFXPM = FXPM3 * GRAV / 28. + WWNMEANPTAIL = WNMEANPTAIL + SSDSBCK = SDSBCK + SSDSABK = SDSABK + SSDSPBK = SDSPBK + SSDSBINT = SDSBINT + SSDSHCK = SDSHCK +#endif + ! #ifdef W3_ST6 - CALL READNL ( NDSS, 'SDS6', STATUS ) - WRITE (NDSO,924) STATUS - SDS6ET = SDSET - SDS6A1 = SDSA1 - SDS6P1 = SDSP1 - SDS6A2 = SDSA2 - SDS6P2 = SDSP2 - J = 2 - IF (SDSET) J = 1 - WRITE (NDSO,925) YESXNO(J), YESXNO(3-J), SDS6A1, SDS6P1, SDS6A2, SDS6P2 - - CALL READNL ( NDSS, 'SWL6', STATUS ) - WRITE (NDSO,937) STATUS - J = 1 - SWL6S6 = SWLB1.GT.0.0 - IF (.NOT.SWL6S6) J = 2 - SWL6B1 = SWLB1 - SWL6CSTB1 = CSTB1 - IF (CSTB1) THEN - WRITE (NDSO,940) YESXNO(J), '(constant) ' ,SWL6B1 - ELSE - WRITE (NDSO,940) YESXNO(J), '(steepness dependent)' ,SWL6B1 - END IF -#endif -! -! 6.g Define Sbt. -! + CALL READNL ( NDSS, 'SDS6', STATUS ) + WRITE (NDSO,924) STATUS + SDS6ET = SDSET + SDS6A1 = SDSA1 + SDS6P1 = SDSP1 + SDS6A2 = SDSA2 + SDS6P2 = SDSP2 + J = 2 + IF (SDSET) J = 1 + WRITE (NDSO,925) YESXNO(J), YESXNO(3-J), SDS6A1, SDS6P1, SDS6A2, SDS6P2 + + CALL READNL ( NDSS, 'SWL6', STATUS ) + WRITE (NDSO,937) STATUS + J = 1 + SWL6S6 = SWLB1.GT.0.0 + IF (.NOT.SWL6S6) J = 2 + SWL6B1 = SWLB1 + SWL6CSTB1 = CSTB1 + IF (CSTB1) THEN + WRITE (NDSO,940) YESXNO(J), '(constant) ' ,SWL6B1 + ELSE + WRITE (NDSO,940) YESXNO(J), '(steepness dependent)' ,SWL6B1 + END IF +#endif + ! + ! 6.g Define Sbt. + ! #ifdef W3_BT0 - WRITE (NDSO,926) + WRITE (NDSO,926) #endif #ifdef W3_BT4 - WRITE (NDSO,926) -#endif -! -#ifdef W3_BT1 - GAMMA = -0.067 + WRITE (NDSO,926) #endif -! + ! #ifdef W3_BT1 - CALL READNL ( NDSS, 'SBT1', STATUS ) - WRITE (NDSO,926) STATUS - WRITE (NDSO,927) GAMMA - SBTC1 = 2. * GAMMA / GRAV + GAMMA = -0.067 + CALL READNL ( NDSS, 'SBT1', STATUS ) + WRITE (NDSO,926) STATUS + WRITE (NDSO,927) GAMMA + SBTC1 = 2. * GAMMA / GRAV #endif -! + ! #ifdef W3_BT4 - SEDMAPD50=.FALSE. - SED_D50_UNIFORM=2.E-4 ! default grain size: medium sand 200 microns - RIPFAC1=0.4 ! A1 in Ardhuin et al. 2003 - RIPFAC2=-2.5 ! A2 in Ardhuin et al. 2003 - RIPFAC3=1.2 ! A3 in Ardhuin et al. 2003 - RIPFAC4=0.05 ! A4 in Ardhuin et al. 2003 - SIGDEPTH=0.05 - BOTROUGHMIN=0.01 - BOTROUGHFAC=1.00 - CALL READNL ( NDSS, 'SBT4', STATUS ) - WRITE (NDSO,926) STATUS - WRITE (NDSO,927) SEDMAPD50, SED_D50_UNIFORM, & - RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4,SIGDEPTH, & - BOTROUGHMIN, BOTROUGHFAC - SBTCX(1)=RIPFAC1 - SBTCX(2)=RIPFAC2 - SBTCX(3)=RIPFAC3 - SBTCX(4)=RIPFAC4 - SBTCX(5)=SIGDEPTH - SBTCX(6)=BOTROUGHMIN - SBTCX(7)=BOTROUGHFAC -#endif -! -! -! 6.h Define Sdb. -! + SEDMAPD50=.FALSE. + SED_D50_UNIFORM=2.E-4 ! default grain size: medium sand 200 microns + RIPFAC1=0.4 ! A1 in Ardhuin et al. 2003 + RIPFAC2=-2.5 ! A2 in Ardhuin et al. 2003 + RIPFAC3=1.2 ! A3 in Ardhuin et al. 2003 + RIPFAC4=0.05 ! A4 in Ardhuin et al. 2003 + SIGDEPTH=0.05 + BOTROUGHMIN=0.01 + BOTROUGHFAC=1.00 + CALL READNL ( NDSS, 'SBT4', STATUS ) + WRITE (NDSO,926) STATUS + WRITE (NDSO,927) SEDMAPD50, SED_D50_UNIFORM, & + RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4,SIGDEPTH, & + BOTROUGHMIN, BOTROUGHFAC + SBTCX(1)=RIPFAC1 + SBTCX(2)=RIPFAC2 + SBTCX(3)=RIPFAC3 + SBTCX(4)=RIPFAC4 + SBTCX(5)=SIGDEPTH + SBTCX(6)=BOTROUGHMIN + SBTCX(7)=BOTROUGHFAC +#endif + ! + ! + ! 6.h Define Sdb. + ! #ifdef W3_DB0 - WRITE (NDSO,928) -#endif -! -#ifdef W3_DB1 - BJALFA = 1. - BJGAM = 0.73 - BJFLAG = .TRUE. + WRITE (NDSO,928) #endif -! + ! #ifdef W3_DB1 - CALL READNL ( NDSS, 'SDB1', STATUS ) - WRITE (NDSO,928) STATUS - BJALFA = MAX ( 0. , BJALFA ) - BJGAM = MAX ( 0. , BJGAM ) - WRITE (NDSO,929) BJALFA, BJGAM - IF ( BJFLAG ) THEN - WRITE (NDSO,*) ' Using Hmax/d ratio only.' - ELSE - WRITE (NDSO,*) & - ' Using Hmax/d in Miche style formulation.' - END IF - WRITE (NDSO,*) - SDBC1 = BJALFA - SDBC2 = BJGAM - FDONLY = BJFLAG -#endif -! -! + BJALFA = 1. + BJGAM = 0.73 + BJFLAG = .TRUE. + CALL READNL ( NDSS, 'SDB1', STATUS ) + WRITE (NDSO,928) STATUS + BJALFA = MAX ( 0. , BJALFA ) + BJGAM = MAX ( 0. , BJGAM ) + WRITE (NDSO,929) BJALFA, BJGAM + IF ( BJFLAG ) THEN + WRITE (NDSO,*) ' Using Hmax/d ratio only.' + ELSE + WRITE (NDSO,*) & + ' Using Hmax/d in Miche style formulation.' + END IF + WRITE (NDSO,*) + SDBC1 = BJALFA + SDBC2 = BJGAM + FDONLY = BJFLAG +#endif + ! + ! #ifdef W3_UOST - UOSTFILELOCAL = 'obstructions_local.'//ADJUSTL(TRIM(GNAME))//'.in' - UOSTFILESHADOW = 'obstructions_shadow.'//ADJUSTL(TRIM(GNAME))//'.in' - UOSTFACTORLOCAL = 1 - UOSTFACTORSHADOW = 1 - CALL READNL ( NDSS, 'UOST', STATUS ) - WRITE (NDSO,4500) STATUS - WRITE (NDSO,4501) ADJUSTL(TRIM(UOSTFILELOCAL)), ADJUSTL(TRIM(UOSTFILESHADOW)), & - UOSTFACTORLOCAL, UOSTFACTORSHADOW -#endif -! -! 6.i Define Str. -! + UOSTFILELOCAL = 'obstructions_local.'//ADJUSTL(TRIM(GNAME))//'.in' + UOSTFILESHADOW = 'obstructions_shadow.'//ADJUSTL(TRIM(GNAME))//'.in' + UOSTFACTORLOCAL = 1 + UOSTFACTORSHADOW = 1 + CALL READNL ( NDSS, 'UOST', STATUS ) + WRITE (NDSO,4500) STATUS + WRITE (NDSO,4501) ADJUSTL(TRIM(UOSTFILELOCAL)), ADJUSTL(TRIM(UOSTFILESHADOW)), & + UOSTFACTORLOCAL, UOSTFACTORSHADOW +#endif + ! + ! 6.i Define Str. + ! #ifdef W3_TR0 - WRITE (NDSO,930) + WRITE (NDSO,930) #endif -! -! 6.j Define Sbs. -! + ! + ! 6.j Define Sbs. + ! #ifdef W3_BS0 - WRITE (NDSO,932) + WRITE (NDSO,932) #endif #ifdef W3_BS1 - WRITE (NDSO,932) + WRITE (NDSO,932) #endif -! -! 6.k Define Sxx and Sic. -! + ! + ! 6.k Define Sxx and Sic. + ! #ifdef W3_IC1 - WRITE (NDSO,935) - WRITE(NDSO,'(A/A)')' Sice will be calculated using ' & - //'user-specified ki values.',' Required ' & - //'field input: ice parameter 1.' + WRITE (NDSO,935) + WRITE(NDSO,'(A/A)')' Sice will be calculated using ' & + //'user-specified ki values.',' Required ' & + //'field input: ice parameter 1.' #endif -! + ! #ifdef W3_IC2 - WRITE (NDSO,935) - WRITE(NDSO,'(A/A)')' Sice will be calculated using ' & - //'under-ice boundary layer method.',' Required ' & - //'field input: ice parameters 1 and 2.' + WRITE (NDSO,935) + WRITE(NDSO,'(A/A)')' Sice will be calculated using ' & + //'under-ice boundary layer method.',' Required ' & + //'field input: ice parameters 1 and 2.' #endif -! + ! #ifdef W3_IC3 - WRITE (NDSO,935) - WRITE(NDSO,'(A/A)')' Sice will be calculated using '& - //'Wang and Shen method.',' '& - //'Required field input: ice parameters 1, 2, 3 and 4.' + WRITE (NDSO,935) + WRITE(NDSO,'(A/A)')' Sice will be calculated using '& + //'Wang and Shen method.',' '& + //'Required field input: ice parameters 1, 2, 3 and 4.' #endif -! + ! #ifdef W3_IC4 - WRITE (NDSO,935) - WRITE(NDSO,'(A/A)')' Sice will be calculated using '& - //'Empirical method.',' '& - //'Required field input: ice parameters (varies).' + WRITE (NDSO,935) + WRITE(NDSO,'(A/A)')' Sice will be calculated using '& + //'Empirical method.',' '& + //'Required field input: ice parameters (varies).' #endif -! + ! #ifdef W3_IC5 - WRITE (NDSO,935) - WRITE(NDSO,'(A/A/)')' Sice will be calculated using '& - //'effective medium models.',' '& - //'Required field input: ice parameters 1, 2, 3 and 4.' -#endif -! -! 6.l Read unstructured data -! initialisation of logical related to unstructured grid - UGOBCAUTO = .TRUE. - UGBCCFL = .TRUE. - UGOBCDEPTH= -10. - UGOBCOK = .FALSE. - UGOBCFILE = 'unset' - EXPFSN = .TRUE. - EXPFSPSI = .FALSE. - EXPFSFCT = .FALSE. - IMPFSN = .FALSE. - IMPTOTAL = .FALSE. - EXPTOTAL = .FALSE. - IMPREFRACTION = .FALSE. - IMPFREQSHIFT = .FALSE. - IMPSOURCE = .FALSE. - SETUP_APPLY_WLV = .FALSE. - SOLVERTHR_SETUP=1E-14 - CRIT_DEP_SETUP=0.1 - JGS_TERMINATE_MAXITER = .TRUE. - JGS_TERMINATE_DIFFERENCE = .TRUE. - JGS_TERMINATE_NORM = .FALSE. - JGS_LIMITER = .FALSE. - JGS_BLOCK_GAUSS_SEIDEL = .TRUE. - JGS_USE_JACOBI = .TRUE. - JGS_MAXITER=100 - JGS_PMIN = 1 - JGS_DIFF_THR = 1.E-10 - JGS_NORM_THR = 1.E-20 - JGS_NLEVEL = 0 - JGS_SOURCE_NONLINEAR = .FALSE. -! read data from the unstructured devoted namelist - CALL READNL ( NDSS, 'UNST', STATUS ) - - B_JGS_USE_JACOBI = JGS_USE_JACOBI - B_JGS_TERMINATE_MAXITER = JGS_TERMINATE_MAXITER - B_JGS_TERMINATE_DIFFERENCE = JGS_TERMINATE_DIFFERENCE - B_JGS_TERMINATE_NORM = JGS_TERMINATE_NORM - B_JGS_LIMITER = JGS_LIMITER - B_JGS_BLOCK_GAUSS_SEIDEL = JGS_BLOCK_GAUSS_SEIDEL - B_JGS_MAXITER = JGS_MAXITER - B_JGS_PMIN = JGS_PMIN - B_JGS_DIFF_THR = JGS_DIFF_THR - B_JGS_NORM_THR = JGS_NORM_THR - B_JGS_NLEVEL = JGS_NLEVEL - B_JGS_SOURCE_NONLINEAR = JGS_SOURCE_NONLINEAR - - nbSel=0 - - IF (EXPFSN) nbSel = nbSel+1 - IF (EXPFSPSI) nbSel = nbSel+1 - IF (EXPFSFCT) nbSel = nbSel+1 - IF (IMPFSN) nbSel = nbSel+1 - IF (IMPTOTAL) nbSel = nbSel+1 - IF (EXPTOTAL) nbSel = nbSel+1 - - IF (GTYPE .EQ. UNGTYPE) THEN - IF (nbSel .ne. 1) THEN - IF (nbSel .gt. 1) THEN - WRITE (NDSE,*) 'MORE THAN ONE UNSTRUCTURED SCHEME SELECTED' - CALL EXTCDE ( 19 ) - ELSE IF (nbSel .eq. 0) THEN - WRITE (NDSE,*) 'NOTHING SELECTED FROM THE UNSTRUCTURED PART' - CALL EXTCDE ( 19 ) - END IF - END IF - END IF -! -! 6.m Select propagation scheme -! - WRITE (NDSO,950) -! - NRPROP = 0 - FLPROP = .TRUE. - PNAME = ' ' + WRITE (NDSO,935) + WRITE(NDSO,'(A/A/)')' Sice will be calculated using '& + //'effective medium models.',' '& + //'Required field input: ice parameters 1, 2, 3 and 4.' +#endif + ! + ! 6.l Read unstructured data + ! initialisation of logical related to unstructured grid + UGOBCAUTO = .TRUE. + UGBCCFL = .TRUE. + UGOBCDEPTH= -10. + UGOBCOK = .FALSE. + UGOBCFILE = 'unset' + EXPFSN = .TRUE. + EXPFSPSI = .FALSE. + EXPFSFCT = .FALSE. + IMPFSN = .FALSE. + IMPTOTAL = .FALSE. + EXPTOTAL = .FALSE. + IMPREFRACTION = .FALSE. + IMPFREQSHIFT = .FALSE. + IMPSOURCE = .FALSE. + SETUP_APPLY_WLV = .FALSE. + SOLVERTHR_SETUP=1E-14 + CRIT_DEP_SETUP=0.1 + JGS_TERMINATE_MAXITER = .TRUE. + JGS_TERMINATE_DIFFERENCE = .TRUE. + JGS_TERMINATE_NORM = .FALSE. + JGS_LIMITER = .FALSE. + JGS_BLOCK_GAUSS_SEIDEL = .TRUE. + JGS_USE_JACOBI = .TRUE. + JGS_MAXITER=100 + JGS_PMIN = 1 + JGS_DIFF_THR = 1.E-10 + JGS_NORM_THR = 1.E-20 + JGS_NLEVEL = 0 + JGS_SOURCE_NONLINEAR = .FALSE. + ! read data from the unstructured devoted namelist + CALL READNL ( NDSS, 'UNST', STATUS ) + + B_JGS_USE_JACOBI = JGS_USE_JACOBI + B_JGS_TERMINATE_MAXITER = JGS_TERMINATE_MAXITER + B_JGS_TERMINATE_DIFFERENCE = JGS_TERMINATE_DIFFERENCE + B_JGS_TERMINATE_NORM = JGS_TERMINATE_NORM + B_JGS_LIMITER = JGS_LIMITER + B_JGS_BLOCK_GAUSS_SEIDEL = JGS_BLOCK_GAUSS_SEIDEL + B_JGS_MAXITER = JGS_MAXITER + B_JGS_PMIN = JGS_PMIN + B_JGS_DIFF_THR = JGS_DIFF_THR + B_JGS_NORM_THR = JGS_NORM_THR + B_JGS_NLEVEL = JGS_NLEVEL + B_JGS_SOURCE_NONLINEAR = JGS_SOURCE_NONLINEAR + + nbSel=0 + + IF (EXPFSN) nbSel = nbSel+1 + IF (EXPFSPSI) nbSel = nbSel+1 + IF (EXPFSFCT) nbSel = nbSel+1 + IF (IMPFSN) nbSel = nbSel+1 + IF (IMPTOTAL) nbSel = nbSel+1 + IF (EXPTOTAL) nbSel = nbSel+1 + + IF (GTYPE .EQ. UNGTYPE) THEN + IF (nbSel .ne. 1) THEN + IF (nbSel .gt. 1) THEN + WRITE (NDSE,*) 'MORE THAN ONE UNSTRUCTURED SCHEME SELECTED' + CALL EXTCDE ( 19 ) + ELSE IF (nbSel .eq. 0) THEN + WRITE (NDSE,*) 'NOTHING SELECTED FROM THE UNSTRUCTURED PART' + CALL EXTCDE ( 19 ) + END IF + END IF + END IF + ! + ! 6.m Select propagation scheme + ! + WRITE (NDSO,950) + ! + NRPROP = 0 + FLPROP = .TRUE. + PNAME = ' ' #ifdef W3_PR0 - PNAME = 'Not defined ' - NRPROP = NRPROP + 1 - FLPROP = .FALSE. + PNAME = 'Not defined ' + NRPROP = NRPROP + 1 + FLPROP = .FALSE. #endif #ifdef W3_PR1 - PNAME = 'First order upstream ' - NRPROP = NRPROP + 1 + PNAME = 'First order upstream ' + NRPROP = NRPROP + 1 #endif #ifdef W3_UQ - PNAME = '3rd order UQ' + PNAME = '3rd order UQ' #endif #ifdef W3_UNO - PNAME = '2nd order UNO' + PNAME = '2nd order UNO' #endif - J = LEN_TRIM(PNAME) + J = LEN_TRIM(PNAME) #ifdef W3_PR2 - PNAME = PNAME(1:J)//' + GSE diffusion ' - NRPROP = NRPROP + 1 + PNAME = PNAME(1:J)//' + GSE diffusion ' + NRPROP = NRPROP + 1 #endif #ifdef W3_PR3 - PNAME = PNAME(1:J)//' + GSE averaging ' - NRPROP = NRPROP + 1 + PNAME = PNAME(1:J)//' + GSE averaging ' + NRPROP = NRPROP + 1 #endif -! + ! #ifdef W3_SMC - PNAME = 'UNO2 on SMC grid + diffusion ' -#endif -! - IF ( (FLCX.OR.FLCY.OR.FLCTH.OR.FLCK) .AND. .NOT. FLPROP ) THEN - WRITE (NDSE,1030) - CALL EXTCDE ( 20 ) - END IF -! - IF ( .NOT.(FLCX.OR.FLCY.OR.FLCTH.OR.FLCK) .AND. FLPROP ) THEN - WRITE (NDSE,1031) - END IF -! - IF ( NRPROP.EQ.0 ) THEN - WRITE (NDSE,1032) - CALL EXTCDE ( 21 ) - END IF -! - IF ( NRPROP .GT. 1 ) THEN - WRITE (NDSE,1033) NRPROP - CALL EXTCDE ( 22 ) - END IF -! -! 6.m Parameters for propagation scheme -! - WRITE (NDSO,951) PNAME -! - CFLTM = 0.7 -! + PNAME = 'UNO2 on SMC grid + diffusion ' +#endif + ! + IF ( (FLCX.OR.FLCY.OR.FLCTH.OR.FLCK) .AND. .NOT. FLPROP ) THEN + WRITE (NDSE,1030) + CALL EXTCDE ( 20 ) + END IF + ! + IF ( .NOT.(FLCX.OR.FLCY.OR.FLCTH.OR.FLCK) .AND. FLPROP ) THEN + WRITE (NDSE,1031) + END IF + ! + IF ( NRPROP.EQ.0 ) THEN + WRITE (NDSE,1032) + CALL EXTCDE ( 21 ) + END IF + ! + IF ( NRPROP .GT. 1 ) THEN + WRITE (NDSE,1033) NRPROP + CALL EXTCDE ( 22 ) + END IF + ! + ! 6.m Parameters for propagation scheme + ! + WRITE (NDSO,951) PNAME + ! + CFLTM = 0.7 + ! #ifdef W3_PR2 - DTIME = 0. - LATMIN = 70. + DTIME = 0. + LATMIN = 70. #endif -! + ! #ifdef W3_SMC - !! Default values of SMC grid parameters. JGLi06Apr2021 - NCel = 1 - NUFc = 1 - NVFc = 1 - NGLO = 1 - NARC = 1 - NBGL = 1 - NBAC = 1 - LvSMC = 1 - MRFct = 1 - ISHFT = 0 - JEQT = 0 - NBISMC = 0 - CFLSM = 0.7 - DTIMS = 360.0 - RFMAXD = 36.0 - UNO3 = .FALSE. - AVERG = .TRUE. - SEAWND = .FALSE. - Arctic = .FALSE. -#endif -! + !! Default values of SMC grid parameters. JGLi06Apr2021 + NCel = 1 + NUFc = 1 + NVFc = 1 + NGLO = 1 + NARC = 1 + NBGL = 1 + NBAC = 1 + LvSMC = 1 + MRFct = 1 + ISHFT = 0 + JEQT = 0 + NBISMC = 0 + CFLSM = 0.7 + DTIMS = 360.0 + RFMAXD = 36.0 + UNO3 = .FALSE. + AVERG = .TRUE. + SEAWND = .FALSE. + Arctic = .FALSE. +#endif + ! #ifdef W3_PR3 - WDTHCG = 1.5 - WDTHTH = WDTHCG + WDTHCG = 1.5 + WDTHTH = WDTHCG #endif -! + ! #ifdef W3_PR1 - CALL READNL ( NDSS, 'PRO1', STATUS ) - IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' - WRITE (NDSO,952) STATUS(1:18) - CFLTM = MAX ( 0. , CFLTM ) - WRITE (NDSO,953) CFLTM + CALL READNL ( NDSS, 'PRO1', STATUS ) + IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' + WRITE (NDSO,952) STATUS(1:18) + CFLTM = MAX ( 0. , CFLTM ) + WRITE (NDSO,953) CFLTM #endif -! + ! #ifdef W3_PR2 - CALL READNL ( NDSS, 'PRO2', STATUS ) - IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' - WRITE (NDSO,952) STATUS(1:18) - CFLTM = MAX ( 0. , CFLTM ) - DTIME = MAX ( 0. , DTIME ) - LATMIN = MIN ( 89. , ABS(LATMIN) ) - CLATMN = COS ( LATMIN * DERA ) - IF ( DTIME .EQ. 0. ) THEN - WRITE (NDSO,953) CFLTM, LATMIN - ELSE - WRITE (NDSO,954) CFLTM, DTIME/3600., LATMIN - END IF - DTME = DTIME -#endif -! -#ifdef W3_SMC - CALL READNL ( NDSS, 'PSMC', STATUS ) - IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' - WRITE (NDSO,952) STATUS(1:18) - CFLSM = MAX ( 0. , CFLSM ) - DTIMS = MAX ( 0. , DTIMS ) - RFMAXD = MIN ( 80.0, ABS(RFMAXD) ) - Refran = RFMAXD * DERA - !! Printing out SMC grid parameters. - WRITE (NDSO,1950) - WRITE (NDSO,1951) PNSMC - WRITE (NDSO,1953) CFLSM, DTIMS/3600., RFMAXD -#endif -! + CALL READNL ( NDSS, 'PRO2', STATUS ) + IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' + WRITE (NDSO,952) STATUS(1:18) + CFLTM = MAX ( 0. , CFLTM ) + DTIME = MAX ( 0. , DTIME ) + LATMIN = MIN ( 89. , ABS(LATMIN) ) + CLATMN = COS ( LATMIN * DERA ) + IF ( DTIME .EQ. 0. ) THEN + WRITE (NDSO,953) CFLTM, LATMIN + ELSE + WRITE (NDSO,954) CFLTM, DTIME/3600., LATMIN + END IF + DTME = DTIME +#endif + ! #ifdef W3_SMC - FUNO3 = UNO3 - FVERG = AVERG - FSWND = SEAWND - ARCTC = Arctic - NBSMC = NBISMC - IF( FUNO3 ) WRITE (NDSO,*) & - " Advection use 3rd order UNO3 instead of UNO2 scheme." - IF( FVERG ) WRITE (NDSO,*) & - " Extra 1-2-1 average smoothing activated on SMC grid." - IF( FSWND ) WRITE (NDSO,*) & - " Sea-point only wind input is required for SMC grid. " - IF( ARCTC ) WRITE (NDSO,*) & - " Arctic polar part will be appended to this SMC grid." - NRLv = LvSMC - WRITE (NDSO,4001) NRLv - WRITE (NDSO,4002) JEQT - WRITE (NDSO,4302) ISHFT - WRITE (NDSO,4003) NBSMC -#endif -! + CALL READNL ( NDSS, 'PSMC', STATUS ) + IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' + WRITE (NDSO,952) STATUS(1:18) + CFLSM = MAX ( 0. , CFLSM ) + DTIMS = MAX ( 0. , DTIMS ) + RFMAXD = MIN ( 80.0, ABS(RFMAXD) ) + Refran = RFMAXD * DERA + !! Printing out SMC grid parameters. + WRITE (NDSO,1950) + WRITE (NDSO,1951) PNSMC + WRITE (NDSO,1953) CFLSM, DTIMS/3600., RFMAXD + FUNO3 = UNO3 + FVERG = AVERG + FSWND = SEAWND + ARCTC = Arctic + NBSMC = NBISMC + IF( FUNO3 ) WRITE (NDSO,*) & + " Advection use 3rd order UNO3 instead of UNO2 scheme." + IF( FVERG ) WRITE (NDSO,*) & + " Extra 1-2-1 average smoothing activated on SMC grid." + IF( FSWND ) WRITE (NDSO,*) & + " Sea-point only wind input is required for SMC grid. " + IF( ARCTC ) WRITE (NDSO,*) & + " Arctic polar part will be appended to this SMC grid." + NRLv = LvSMC + WRITE (NDSO,4001) NRLv + WRITE (NDSO,4002) JEQT + WRITE (NDSO,4302) ISHFT + WRITE (NDSO,4003) NBSMC +#endif + ! #ifdef W3_PR3 - CALL READNL ( NDSS, 'PRO3', STATUS ) - IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' + CALL READNL ( NDSS, 'PRO3', STATUS ) + IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' #endif - IF (GTYPE.NE.UNGTYPE) THEN + IF (GTYPE.NE.UNGTYPE) THEN #ifdef W3_PR3 - WRITE (NDSO,952) STATUS(1:18) + WRITE (NDSO,952) STATUS(1:18) CFLTM = MAX ( 0. , CFLTM ) - WRITE (NDSO,953) CFLTM, WDTHCG + WRITE (NDSO,953) CFLTM, WDTHCG IF ( WDTHCG*(XFR-1.) .GT. 1. ) WRITE (NDSO,955) 1./(XFR-1.) - WRITE (NDSO,954) WDTHTH + WRITE (NDSO,954) WDTHTH IF ( WDTHTH*DTH .GT. 1. ) WRITE (NDSO,955) 1./DTH - WRITE (NDSO,*) + WRITE (NDSO,*) #endif - ENDIF + ENDIF #ifdef W3_PR3 - WDCG = WDTHCG - WDTH = WDTHTH + WDCG = WDTHCG + WDTH = WDTHTH #endif -! - CTMAX = CFLTM -! + ! + CTMAX = CFLTM + ! #ifdef W3_RTD - ! Set/ read in rotation values - these will be written out - ! later with the rest of the grid info - ! Default is a non-rotated lat-lon grid - PLAT = 90. - PLON = -180. - UNROT = .FALSE. - CALL READNL ( NDSS, 'ROTD', STATUS ) - PLON = MOD( PLON + 180., 360. ) - 180. - ! Ensure that a grid with pole at the geographic North is standard lat-lon - IF ( PLAT == 90. .AND. ( PLON /= -180. .OR. UNROT ) ) THEN - WRITE( NDSE, 1052 ) - CALL EXTCDE ( 33 ) - ENDIF - ! Default poles of output b. c. are non-rotated: - BPLAT = 90. - BPLON = -180. - CALL READNL ( NDSS, 'ROTB', STATUS ) - ! A b. c. dest. grid with pole at the geographic North must be non-rotated - DO I=1,9 - IF ( BPLAT(I) == 90. ) THEN - ! Require BPLON(I) == -180., but don't blaim the user if BPLON(I) == 180. - IF ( BPLON(I) == 180. ) BPLON(I) = -180. - IF ( BPLON(I) == -180. ) CYCLE - END IF - IF ( BPLAT(I) < 90. ) CYCLE - WRITE( NDSE, 1053 ) - CALL EXTCDE ( 34 ) - END DO -#endif -! -! 6.n Set miscellaneous parameters (ice, seeding, numerics ... ) -! - CICE0 = 0.5 - CICEN = 0.5 - LICE = 0. - ICEHFAC= 1.0 - ICEHMIN= 0.2 ! the 0.2 value is arbitrary and needs to be tuned. - ICEHINIT= 0.5 - ICESLN = 1.0 - ICEWIND= 1.0 - ICESNL = 1.0 - ICESDS = 1.0 - ICEHDISP= 0.6 ! Prevent from convergence crash in w3dispmd in the presence of ice, should be tuned - ICEDDISP= 80 - ICEFDISP= 2 - GSHIFT = 0.0D0 - PMOVE = 0.5 - XSEED = 1. - FLAGTR = 0 - XP = 0.15 - XR = 0.10 - XFILT = 0.05 - IHM = 100 - HSPM = 0.05 - WSM = 1.7 - WSC = 0.333 - FLC = .TRUE. - TRCKCMPR = .TRUE. - NOSW = 5 -! -! Gas fluxes -! - AIRCMIN = 2.0 ! cmin for whitecap coverage and entrained air - AIRGB = 0.2 ! volume of entrained air constant (Deike et al. 2017) -! + ! Set/ read in rotation values - these will be written out + ! later with the rest of the grid info + ! Default is a non-rotated lat-lon grid + PLAT = 90. + PLON = -180. + UNROT = .FALSE. + CALL READNL ( NDSS, 'ROTD', STATUS ) + PLON = MOD( PLON + 180., 360. ) - 180. + ! Ensure that a grid with pole at the geographic North is standard lat-lon + IF ( PLAT == 90. .AND. ( PLON /= -180. .OR. UNROT ) ) THEN + WRITE( NDSE, 1052 ) + CALL EXTCDE ( 33 ) + ENDIF + ! Default poles of output b. c. are non-rotated: + BPLAT = 90. + BPLON = -180. + CALL READNL ( NDSS, 'ROTB', STATUS ) + ! A b. c. dest. grid with pole at the geographic North must be non-rotated + DO I=1,9 + IF ( BPLAT(I) == 90. ) THEN + ! Require BPLON(I) == -180., but don't blaim the user if BPLON(I) == 180. + IF ( BPLON(I) == 180. ) BPLON(I) = -180. + IF ( BPLON(I) == -180. ) CYCLE + END IF + IF ( BPLAT(I) < 90. ) CYCLE + WRITE( NDSE, 1053 ) + CALL EXTCDE ( 34 ) + END DO +#endif + ! + ! 6.n Set miscellaneous parameters (ice, seeding, numerics ... ) + ! + CICE0 = 0.5 + CICEN = 0.5 + LICE = 0. + ICEHFAC= 1.0 + ICEHMIN= 0.2 ! the 0.2 value is arbitrary and needs to be tuned. + ICEHINIT= 0.5 + ICESLN = 1.0 + ICEWIND= 1.0 + ICESNL = 1.0 + ICESDS = 1.0 + ICEHDISP= 0.6 ! Prevent from convergence crash in w3dispmd in the presence of ice, should be tuned + ICEDDISP= 80 + ICEFDISP= 2 + GSHIFT = 0.0D0 + PMOVE = 0.5 + XSEED = 1. + FLAGTR = 0 + XP = 0.15 + XR = 0.10 + XFILT = 0.05 + IHM = 100 + HSPM = 0.05 + WSM = 1.7 + WSC = 0.333 + FLC = .TRUE. + TRCKCMPR = .TRUE. + NOSW = 5 + ! + ! Gas fluxes + ! + AIRCMIN = 2.0 ! cmin for whitecap coverage and entrained air + AIRGB = 0.2 ! volume of entrained air constant (Deike et al. 2017) + ! #ifdef W3_NCO -! NCEP operations retains first three swell systems. - NOSW=3 -#endif - PTM = 1 ! Default to standard WW3 partitioning. C. Bunney - PTFC = 0.1 ! Part. method 5 cutoff freq default. C. Bunney - FMICHE = 1.6 - RWNDC = 1. - WCOR1 = 99. - WCOR2 = 0. - BTBET = 1.2 ! β for c / [U cos(θ - φ)] < β -! Variables for Space-Time Extremes -! Default negative values make w3iogomd switch off space-time extremes -! forces user to provide NAMELIST if wanting to compute STE parameters - STDX = -1. - STDY = -1. - STDT = -1. - ICEDISP = .FALSE. - CALTYPE = 'standard' -! Variables for 3D array output - E3D=0 - I1E3D=1 - I2E3D=NK - P2SF = 0 - I1P2SF = 1 - I2P2SF = 15 - US3D = 0 - I1US3D = 1 - I2US3D = NK - USSP=0 - IUSSP=1 - STK_WN(:)=0.0 - STK_WN(1)=TPI/100. !Set default decay of 100 m for Stokes drift - TH1MF=0 - I1TH1M=1 - I2TH1M=NK - STH1MF=0 - I1STH1M=1 - I2STH1M=NK - TH2MF=0 - I1TH2M=1 - I2TH2M=NK - STH2MF=0 - I1STH2M=1 - I2STH2M=NK -! - FACBERG=1. + ! NCEP operations retains first three swell systems. + NOSW=3 +#endif + PTM = 1 ! Default to standard WW3 partitioning. C. Bunney + PTFC = 0.1 ! Part. method 5 cutoff freq default. C. Bunney + FMICHE = 1.6 + RWNDC = 1. + WCOR1 = 99. + WCOR2 = 0. + BTBET = 1.2 ! β for c / [U cos(θ - φ)] < β + ! Variables for Space-Time Extremes + ! Default negative values make w3iogomd switch off space-time extremes + ! forces user to provide NAMELIST if wanting to compute STE parameters + STDX = -1. + STDY = -1. + STDT = -1. + ICEDISP = .FALSE. + CALTYPE = 'standard' + ! Variables for 3D array output + E3D=0 + I1E3D=1 + I2E3D=NK + P2SF = 0 + I1P2SF = 1 + I2P2SF = 15 + US3D = 0 + I1US3D = 1 + I2US3D = NK + USSP=0 + IUSSP=1 + STK_WN(:)=0.0 + STK_WN(1)=TPI/100. !Set default decay of 100 m for Stokes drift + TH1MF=0 + I1TH1M=1 + I2TH1M=NK + STH1MF=0 + I1STH1M=1 + I2STH1M=NK + TH2MF=0 + I1TH2M=1 + I2TH2M=NK + STH2MF=0 + I1STH2M=1 + I2STH2M=NK + ! + FACBERG=1. #ifdef W3_IS0 - WRITE (NDSO,944) + WRITE (NDSO,944) #endif #ifdef W3_IS1 - ISC1 = 1. - ISC2 = 0. - CALL READNL ( NDSS, 'SIS1', STATUS ) - WRITE (NDSO,945) STATUS - WRITE (NDSO,946) ISC1, ISC2 - IS1C1 = ISC1 - IS1C2 = ISC2 + ISC1 = 1. + ISC2 = 0. + CALL READNL ( NDSS, 'SIS1', STATUS ) + WRITE (NDSO,945) STATUS + WRITE (NDSO,946) ISC1, ISC2 + IS1C1 = ISC1 + IS1C2 = ISC2 #endif #ifdef W3_IS2 - ISC1 = 1. - IS2C2 = 0. ! 0.025 - IS2C3 = 0. ! 2.4253 - IS2CONC = 0. - IS2BACKSCAT = 1. - IS2BREAK = .FALSE. - IS2BREAKF = 3.6 - IS2FLEXSTR=6.00E+05 ! value used in Ardhuin et al. 2020 - IS2ISOSCAT=.TRUE. ! uses isotropic back-scatter - IS2DISP=.FALSE. !not dispersion only attenuation following Liu disp. eq. - IS2DUPDATE=.TRUE. - IS2FRAGILITY=0.9 - IS2DMIN=20 - IS2DAMP=0. - IS2CREEPB=0. - IS2CREEPC=0.4 ! This gives an impact of break-up over a wider freq. range -#endif -! ! compared to the 0.2 value in Boutin et al. 2018 -#ifdef W3_IS2 - IS2CREEPD=0.5 - IS2CREEPN=3.0 - IS2BREAKE=1. - IS2WIM1=1. - IS2ANDISB=.TRUE. !anelastic instead of inelastic dissipation if IS2CREEPB>0 - IS2ANDISE=0.55 !energy of activation - IS2ANDISD=2.0E-9 !see Ardhuin et al. 2020 - IS2ANDISN=1. !dependency on stress. Equal to 1 normally? - CALL READNL ( NDSS, 'SIS2', STATUS ) - WRITE (NDSO,947) STATUS - WRITE (NDSO,2948) ISC1, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, IS2DUPDATE, IS2FLEXSTR, IS2DISP, & - IS2DAMP, IS2FRAGILITY, IS2DMIN, IS2C2, IS2C3, IS2CONC, IS2CREEPB,& - IS2CREEPC, IS2CREEPD, IS2CREEPN, IS2BREAKE, IS2BREAKF, IS2WIM1, & - IS2ANDISB, IS2ANDISE, IS2ANDISD, IS2ANDISN -#endif -! -#ifdef W3_REF1 - REFCOAST=0. - REFMAP=0. - REFMAPD=0. - REFRMAX=1. - REFFREQPOW=2. - REFFREQ=0. - REFCOSP_STRAIGHT=4. - REFSLOPE=0.22 - REFSUBGRID=0. - REFICEBERG=0. - REFUNSTSOURCE=0. -#endif -! + ISC1 = 1. + IS2C2 = 0. ! 0.025 + IS2C3 = 0. ! 2.4253 + IS2CONC = 0. + IS2BACKSCAT = 1. + IS2BREAK = .FALSE. + IS2BREAKF = 3.6 + IS2FLEXSTR=6.00E+05 ! value used in Ardhuin et al. 2020 + IS2ISOSCAT=.TRUE. ! uses isotropic back-scatter + IS2DISP=.FALSE. !not dispersion only attenuation following Liu disp. eq. + IS2DUPDATE=.TRUE. + IS2FRAGILITY=0.9 + IS2DMIN=20 + IS2DAMP=0. + IS2CREEPB=0. + IS2CREEPC=0.4 ! This gives an impact of break-up over a wider freq. range + ! ! compared to the 0.2 value in Boutin et al. 2018 + IS2CREEPD=0.5 + IS2CREEPN=3.0 + IS2BREAKE=1. + IS2WIM1=1. + IS2ANDISB=.TRUE. !anelastic instead of inelastic dissipation if IS2CREEPB>0 + IS2ANDISE=0.55 !energy of activation + IS2ANDISD=2.0E-9 !see Ardhuin et al. 2020 + IS2ANDISN=1. !dependency on stress. Equal to 1 normally? + CALL READNL ( NDSS, 'SIS2', STATUS ) + WRITE (NDSO,947) STATUS + WRITE (NDSO,2948) ISC1, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, IS2DUPDATE, IS2FLEXSTR, IS2DISP, & + IS2DAMP, IS2FRAGILITY, IS2DMIN, IS2C2, IS2C3, IS2CONC, IS2CREEPB,& + IS2CREEPC, IS2CREEPD, IS2CREEPN, IS2BREAKE, IS2BREAKF, IS2WIM1, & + IS2ANDISB, IS2ANDISE, IS2ANDISD, IS2ANDISN +#endif + ! #ifdef W3_REF1 - CALL READNL ( NDSS, 'REF1', STATUS ) - WRITE (NDSO,969) STATUS -#endif -! -#ifdef W3_IG1 - IGMETHOD = 2 - IGADDOUTP= 0 - IGSOURCE = 2 - IGSTERMS = 0 - IGMAXFREQ=0.03 - IGSOURCEATBP = 0 - IGBCOVERWRITE = .TRUE. - IGSWELLMAX = .TRUE. - IGKDMIN = 1.1 - IGFIXEDDEPTH = 0. - IGEMPIRICAL = 0.00125 -#endif -! + REFCOAST=0. + REFMAP=0. + REFMAPD=0. + REFRMAX=1. + REFFREQPOW=2. + REFFREQ=0. + REFCOSP_STRAIGHT=4. + REFSLOPE=0.22 + REFSUBGRID=0. + REFICEBERG=0. + REFUNSTSOURCE=0. + ! + CALL READNL ( NDSS, 'REF1', STATUS ) + WRITE (NDSO,969) STATUS +#endif + ! #ifdef W3_IG1 - CALL READNL ( NDSS, 'SIG1 ', STATUS ) - WRITE (NDSO,970) STATUS -#endif -! + IGMETHOD = 2 + IGADDOUTP= 0 + IGSOURCE = 2 + IGSTERMS = 0 + IGMAXFREQ=0.03 + IGSOURCEATBP = 0 + IGBCOVERWRITE = .TRUE. + IGSWELLMAX = .TRUE. + IGKDMIN = 1.1 + IGFIXEDDEPTH = 0. + IGEMPIRICAL = 0.00125 + CALL READNL ( NDSS, 'SIG1 ', STATUS ) + WRITE (NDSO,970) STATUS +#endif + ! #ifdef W3_IC2 - IC2DISPER = .FALSE. - IC2TURB = 1. - IC2TURBS = 0. - IC2ROUGH = 0.01 - IC2REYNOLDS = 1.5E5 - IC2SMOOTH = 2E5 - IC2VISC = 1. - IC2DMAX = 0. -#endif -! + IC2DISPER = .FALSE. + IC2TURB = 1. + IC2TURBS = 0. + IC2ROUGH = 0.01 + IC2REYNOLDS = 1.5E5 + IC2SMOOTH = 2E5 + IC2VISC = 1. + IC2DMAX = 0. +#endif + ! #ifdef W3_IC3 - IC3MAXTHK = 100.0 - IC3MAXCNC = 100.0 - IC2TURB = 2.0 ! from run_test example by F.A. - IC2TURBS = 0. - IC2ROUGH = 0.02 ! from run_test example by F.A. (alt:0.1) - IC2REYNOLDS = 1.5E5 - IC2SMOOTH = 7.0E4 - IC2VISC = 2.0 - IC3CHENG = .TRUE. - USECGICE = .FALSE. - IC3HILIM = 100.0 - IC3KILIM = 100.0 - IC3HICE = -1.0 - IC3VISC = -2.0 - IC3DENS = -3.0 - IC3ELAS = -4.0 -#endif -!fixme: if USECGICE = .TRUE., don't allow use of IC3MAXTHK<100.0 + IC3MAXTHK = 100.0 + IC3MAXCNC = 100.0 + IC2TURB = 2.0 ! from run_test example by F.A. + IC2TURBS = 0. + IC2ROUGH = 0.02 ! from run_test example by F.A. (alt:0.1) + IC2REYNOLDS = 1.5E5 + IC2SMOOTH = 7.0E4 + IC2VISC = 2.0 + IC3CHENG = .TRUE. + USECGICE = .FALSE. + IC3HILIM = 100.0 + IC3KILIM = 100.0 + IC3HICE = -1.0 + IC3VISC = -2.0 + IC3DENS = -3.0 + IC3ELAS = -4.0 +#endif + !fixme: if USECGICE = .TRUE., don't allow use of IC3MAXTHK<100.0 #ifdef W3_IC4 - IC4METHOD = 1 !switch for methods within IC4 - IC4KI=0.0 - IC4FC=0.0 + IC4METHOD = 1 !switch for methods within IC4 + IC4KI=0.0 + IC4FC=0.0 #endif -! + ! #ifdef W3_IC5 - IC5MINIG = 1. - IC5MINWT = 0. - IC5MAXKRATIO = 1E9 - IC5MAXKI = 100. - IC5MINHW = 0. - IC5MAXITER = 100. - IC5RKICK = 0. - IC5KFILTER = 0.0025 - IC5VEMOD = 3. ! 1: EFS, 2: RP, 3: M2 (default) -#endif -! + IC5MINIG = 1. + IC5MINWT = 0. + IC5MAXKRATIO = 1E9 + IC5MAXKI = 100. + IC5MINHW = 0. + IC5MAXITER = 100. + IC5RKICK = 0. + IC5KFILTER = 0.0025 + IC5VEMOD = 3. ! 1: EFS, 2: RP, 3: M2 (default) +#endif + ! #ifdef W3_IC2 - CALL READNL ( NDSS, 'SIC2 ', STATUS ) - WRITE (NDSO,971) STATUS + CALL READNL ( NDSS, 'SIC2 ', STATUS ) + WRITE (NDSO,971) STATUS #endif -! + ! #ifdef W3_IC3 - CALL READNL ( NDSS, 'SIC3 ', STATUS ) - WRITE (NDSO,971) STATUS + CALL READNL ( NDSS, 'SIC3 ', STATUS ) + WRITE (NDSO,971) STATUS #endif -! + ! #ifdef W3_IC4 - CALL READNL ( NDSS, 'SIC4 ', STATUS ) - WRITE (NDSO,971) STATUS + CALL READNL ( NDSS, 'SIC4 ', STATUS ) + WRITE (NDSO,971) STATUS #endif -! + ! #ifdef W3_IC5 - CALL READNL ( NDSS, 'SIC5 ', STATUS ) - IC5VEMOD = MIN(MAX(1., IC5VEMOD), 3.) - WRITE (NDSO,971) STATUS - WRITE (NDSO,2971) IC5MINIG, IC5MINWT, IC5MAXKRATIO, & - IC5MAXKI, IC5MINHW, IC5MAXITER, IC5RKICK, & - IC5KFILTER, IC5MSTR(NINT(IC5VEMOD)) -#endif -! - CALL READNL ( NDSS, 'OUTS', STATUS ) - WRITE (NDSO,4970) STATUS -! -! -! output of frequency spectra, th1m ... -! - E3DF(1,1) = E3D - E3DF(2,1) = MIN(MAX(1,I1E3D),NK) - E3DF(3,1) = MIN(MAX(1,I2E3D),NK) - E3DF(1,2) = TH1MF - E3DF(2,2) = MIN(MAX(1,I1TH1M),NK) - E3DF(3,2) = MIN(MAX(1,I2TH1M),NK) - E3DF(1,3) = STH1MF - E3DF(2,3) = MIN(MAX(1,I1STH1M),NK) - E3DF(3,3) = MIN(MAX(1,I2STH1M),NK) - E3DF(1,4) = TH2MF - E3DF(2,4) = MIN(MAX(1,I1TH2M),NK) - E3DF(3,4) = MIN(MAX(1,I2TH2M),NK) - E3DF(1,5) = STH2MF - E3DF(2,5) = MIN(MAX(1,I1STH2M),NK) - E3DF(3,5) = MIN(MAX(1,I2STH2M),NK) -! -! output of microseismic source spectra -! - P2MSF(1) = P2SF - P2MSF(2) = MIN(MAX(1,I1P2SF),NK) - P2MSF(3) = MIN(MAX(1,I2P2SF),NK) -! -! output of Stokes drift profile -! - US3DF(1) = US3D - US3DF(2) = MAX( 1 , MIN( NK, I1US3D) ) - US3DF(3) = MAX( 1 , MIN( NK, I2US3D) ) -! -! output of Stokes drift partitions -! - USSPF(1) = USSP - USSPF(2) = MAX( 1 , MIN(25, IUSSP ) ) - IF (IUSSP.GT.25) THEN - WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN ww3_grid:' - WRITE(NDSE,*) " Stokes drift partition outputs not " - WRITE(NDSE,*) " intended for use with more than 25 " - WRITE(NDSE,*) " partitions. Please reduce IUSSP " - WRITE(NDSE,*) " specified in ww3_grid.inp to proceed " - CALL EXTCDE( 31) - ENDIF + CALL READNL ( NDSS, 'SIC5 ', STATUS ) + IC5VEMOD = MIN(MAX(1., IC5VEMOD), 3.) + WRITE (NDSO,971) STATUS + WRITE (NDSO,2971) IC5MINIG, IC5MINWT, IC5MAXKRATIO, & + IC5MAXKI, IC5MINHW, IC5MAXITER, IC5RKICK, & + IC5KFILTER, IC5MSTR(NINT(IC5VEMOD)) +#endif + ! + CALL READNL ( NDSS, 'OUTS', STATUS ) + WRITE (NDSO,4970) STATUS + ! + ! + ! output of frequency spectra, th1m ... + ! + E3DF(1,1) = E3D + E3DF(2,1) = MIN(MAX(1,I1E3D),NK) + E3DF(3,1) = MIN(MAX(1,I2E3D),NK) + E3DF(1,2) = TH1MF + E3DF(2,2) = MIN(MAX(1,I1TH1M),NK) + E3DF(3,2) = MIN(MAX(1,I2TH1M),NK) + E3DF(1,3) = STH1MF + E3DF(2,3) = MIN(MAX(1,I1STH1M),NK) + E3DF(3,3) = MIN(MAX(1,I2STH1M),NK) + E3DF(1,4) = TH2MF + E3DF(2,4) = MIN(MAX(1,I1TH2M),NK) + E3DF(3,4) = MIN(MAX(1,I2TH2M),NK) + E3DF(1,5) = STH2MF + E3DF(2,5) = MIN(MAX(1,I1STH2M),NK) + E3DF(3,5) = MIN(MAX(1,I2STH2M),NK) + ! + ! output of microseismic source spectra + ! + P2MSF(1) = P2SF + P2MSF(2) = MIN(MAX(1,I1P2SF),NK) + P2MSF(3) = MIN(MAX(1,I2P2SF),NK) + ! + ! output of Stokes drift profile + ! + US3DF(1) = US3D + US3DF(2) = MAX( 1 , MIN( NK, I1US3D) ) + US3DF(3) = MAX( 1 , MIN( NK, I2US3D) ) + ! + ! output of Stokes drift partitions + ! + USSPF(1) = USSP + USSPF(2) = MAX( 1 , MIN(25, IUSSP ) ) + IF (IUSSP.GT.25) THEN + WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN ww3_grid:' + WRITE(NDSE,*) " Stokes drift partition outputs not " + WRITE(NDSE,*) " intended for use with more than 25 " + WRITE(NDSE,*) " partitions. Please reduce IUSSP " + WRITE(NDSE,*) " specified in ww3_grid.inp to proceed " + CALL EXTCDE( 31) + ENDIF - DO J=1,USSPF(2) - USSP_WN(j) = STK_WN(J) - ENDDO - -! - WRITE (NDSO,4971) P2MSF(1:3) - WRITE (NDSO,4972) US3DF(1:3) - WRITE (NDSO,4973) E3DF(1:3,1) - WRITE (NDSO,4974) USSPF(1:2) - DO J=1,USSPF(2) - WRITE(NDSO,4975) J,USSP_WN(J) - ENDDO -! - CALL READNL ( NDSS, 'MISC', STATUS ) - WRITE (NDSO,960) STATUS -! - IF ( FLAGTR.LT.0 .OR. FLAGTR.GT.6 ) FLAGTR = 0 - CICEN = MIN ( 1. , MAX ( 0. , CICEN ) ) - ICESLN = MIN ( 1. , MAX ( 0. , ICESLN ) ) - ICEWIND = MIN ( 1. , MAX ( 0. , ICEWIND ) ) - ICESDS = MIN ( 1. , MAX ( 0. , ICESDS ) ) - ICESNL = MIN ( 1. , MAX ( 0. , ICESNL ) ) - FICEN = CICEN - GRIDSHIFT=GSHIFT - ICESCALES(1)=ICESLN - ICESCALES(2)=ICEWIND - ICESCALES(3)=ICESNL - ICESCALES(4)=ICESDS - CMPRTRCK=TRCKCMPR - CICE0 = MIN ( CICEN , MAX ( 0. , CICE0 ) ) - FICEL = LICE - IICEHMIN = ICEHMIN - IICEHFAC = ICEHFAC - IICEHINIT = ICEHINIT - IICEDISP= ICEDISP - IICEHDISP = ICEHDISP - IICEDDISP = ICEDDISP - IICEFDISP = ICEFDISP - PMOVE = MAX ( 0. , PMOVE ) - PFMOVE = PMOVE -! - BTBETA = MIN(MAX (1., BTBET), 2.) - AAIRCMIN = ALOG(GRAV/AIRCMIN/SIG(1))/ALOG(XFR)+1 ! goes from phase speed C=g/sig to index - AAIRGB = AIRGB -! -! Notes: Presently, if we select CICE0.ne.CICEN requires an obstruction -! grid, that is initialized with zeros as default. - IF ( FLAGTR .LT. 3 ) THEN - IF (CICE0.NE.CICEN) THEN - CICE0 = CICEN - IF (STATUS=='(user def. values) :') WRITE (NDSO,2961) - END IF - END IF -#ifdef W3_IC0 - IF ( CICE0.EQ.CICEN .AND. FLAGTR.GE.3 ) FLAGTR = FLAGTR - 2 -#endif - WRITE (NDSO,961) CICE0, CICEN - WRITE (NDSO,8972) ICEWIND - FICE0 = CICE0 -! Variables for Space-Time Extremes - STEXU = STDX - IF ( STDY .LE. 0. ) THEN - STDY = STDX - END IF - STEYU = STDY - STEDU = STDT - IF ( STDX .GT. 0 ) THEN - WRITE (NDSO,1040) STDX - WRITE (NDSO,1041) STDY - ELSE - WRITE (NDSO,1042) - END IF - IF ( STDT .GT. 0 ) THEN - WRITE (NDSO,1043) STDT - ELSE - WRITE (NDSO,1044) + DO J=1,USSPF(2) + USSP_WN(j) = STK_WN(J) + ENDDO + + ! + WRITE (NDSO,4971) P2MSF(1:3) + WRITE (NDSO,4972) US3DF(1:3) + WRITE (NDSO,4973) E3DF(1:3,1) + WRITE (NDSO,4974) USSPF(1:2) + DO J=1,USSPF(2) + WRITE(NDSO,4975) J,USSP_WN(J) + ENDDO + ! + CALL READNL ( NDSS, 'MISC', STATUS ) + WRITE (NDSO,960) STATUS + ! + IF ( FLAGTR.LT.0 .OR. FLAGTR.GT.6 ) FLAGTR = 0 + CICEN = MIN ( 1. , MAX ( 0. , CICEN ) ) + ICESLN = MIN ( 1. , MAX ( 0. , ICESLN ) ) + ICEWIND = MIN ( 1. , MAX ( 0. , ICEWIND ) ) + ICESDS = MIN ( 1. , MAX ( 0. , ICESDS ) ) + ICESNL = MIN ( 1. , MAX ( 0. , ICESNL ) ) + FICEN = CICEN + GRIDSHIFT=GSHIFT + ICESCALES(1)=ICESLN + ICESCALES(2)=ICEWIND + ICESCALES(3)=ICESNL + ICESCALES(4)=ICESDS + CMPRTRCK=TRCKCMPR + CICE0 = MIN ( CICEN , MAX ( 0. , CICE0 ) ) + FICEL = LICE + IICEHMIN = ICEHMIN + IICEHFAC = ICEHFAC + IICEHINIT = ICEHINIT + IICEDISP= ICEDISP + IICEHDISP = ICEHDISP + IICEDDISP = ICEDDISP + IICEFDISP = ICEFDISP + PMOVE = MAX ( 0. , PMOVE ) + PFMOVE = PMOVE + ! + BTBETA = MIN(MAX (1., BTBET), 2.) + AAIRCMIN = ALOG(GRAV/AIRCMIN/SIG(1))/ALOG(XFR)+1 ! goes from phase speed C=g/sig to index + AAIRGB = AIRGB + ! + ! Notes: Presently, if we select CICE0.ne.CICEN requires an obstruction + ! grid, that is initialized with zeros as default. + IF ( FLAGTR .LT. 3 ) THEN + IF (CICE0.NE.CICEN) THEN + CICE0 = CICEN + IF (STATUS=='(user def. values) :') WRITE (NDSO,2961) END IF + END IF +#ifdef W3_IC0 + IF ( CICE0.EQ.CICEN .AND. FLAGTR.GE.3 ) FLAGTR = FLAGTR - 2 +#endif + WRITE (NDSO,961) CICE0, CICEN + WRITE (NDSO,8972) ICEWIND + FICE0 = CICE0 + ! Variables for Space-Time Extremes + STEXU = STDX + IF ( STDY .LE. 0. ) THEN + STDY = STDX + END IF + STEYU = STDY + STEDU = STDT + IF ( STDX .GT. 0 ) THEN + WRITE (NDSO,1040) STDX + WRITE (NDSO,1041) STDY + ELSE + WRITE (NDSO,1042) + END IF + IF ( STDT .GT. 0 ) THEN + WRITE (NDSO,1043) STDT + ELSE + WRITE (NDSO,1044) + END IF #ifdef W3_MGG - WRITE (NDSO,962) PMOVE + WRITE (NDSO,962) PMOVE #endif -! + ! #ifdef W3_SEED - XSEED = MAX ( 1. , XSEED ) - WRITE (NDSO,964) XSEED + XSEED = MAX ( 1. , XSEED ) + WRITE (NDSO,964) XSEED #endif #ifdef W3_SCRIP - WRITE (NDSO,963) GSHIFT + WRITE (NDSO,963) GSHIFT #endif - WRITE (NDSO,1972) TRCKCMPR - FACSD = XSEED + WRITE (NDSO,1972) TRCKCMPR + FACSD = XSEED #ifdef W3_RWND - RWINDC = RWNDC + RWINDC = RWNDC #endif #ifdef W3_WCOR - WWCOR(1) = WCOR1 - WWCOR(2) = WCOR2 -#endif -! - XP = MAX ( 1.E-6 , XP ) - XR = MAX ( 1.E-6 , XR ) - XREL = XR - XFILT = MAX ( 0. , XFILT ) - XFLT = XFILT - WRITE (NDSO,965) XP, XR, XFILT - FACP = XP / PI * 0.62E-3 * TPI**4 / GRAV**2 -! - IHMAX = MAX ( 50, IHM ) - HSPMIN = MAX ( 0.0001 , HSPM ) - WSMULT = MAX ( 1. , WSM ) - WSCUT = MIN ( 1.0001 , MAX ( 0. , WSC ) ) - FLCOMB = FLC - NOSWLL = MAX ( 1 , NOSW ) - PTMETH = PTM ! Partitioning method. Chris Bunney (Jan 2016) - PTFCUT = PTFC ! Freq cutoff for partitiong method 5 - PMNAM2 = "" - IF( PTMETH .EQ. 1 ) THEN - PMNAME = "WW3 default" - ELSE IF( PTMETH .EQ. 2 ) THEN - PMNAME = "Watershedding plus wind cut-off" - ELSE IF( PTMETH .EQ. 3 ) THEN - PMNAME = "Watershedding only" - WSCUT = 0.0 ! We don't want to classify by ws frac - PMNAM2 = "WSC set to 0.0" - ELSE IF( PTMETH .EQ. 4 ) THEN - PMNAME = "Wind speed cut-off only" - PMNAM2 = "WSC set to 0.0, NOSW set to 1" - WSCUT = 0.0 ! We don't want to classify by ws frac - NOSWLL = 1 ! Only ever one swell - ELSE IF( PTMETH .EQ. 5 ) THEN - WRITE(PMNAME, '("2-Band hi/low cutoff at ", F4.2,"Hz")') PTFCUT - PMNAM2 = "WSC set to 0.0, NOSW set to 1" - WSCUT = 0.0 ! We don't want to classify by ws frac - NOSWLL = 1 ! Only ever one swell - ELSE - WRITE( NDSE, * ) & - "*** Error - unknown partitioing method (PTM)! ***" - CALL EXIT(1) - ENDIF + WWCOR(1) = WCOR1 + WWCOR(2) = WCOR2 +#endif + ! + XP = MAX ( 1.E-6 , XP ) + XR = MAX ( 1.E-6 , XR ) + XREL = XR + XFILT = MAX ( 0. , XFILT ) + XFLT = XFILT + WRITE (NDSO,965) XP, XR, XFILT + FACP = XP / PI * 0.62E-3 * TPI**4 / GRAV**2 + ! + IHMAX = MAX ( 50, IHM ) + HSPMIN = MAX ( 0.0001 , HSPM ) + WSMULT = MAX ( 1. , WSM ) + WSCUT = MIN ( 1.0001 , MAX ( 0. , WSC ) ) + FLCOMB = FLC + NOSWLL = MAX ( 1 , NOSW ) + PTMETH = PTM ! Partitioning method. Chris Bunney (Jan 2016) + PTFCUT = PTFC ! Freq cutoff for partitiong method 5 + PMNAM2 = "" + IF( PTMETH .EQ. 1 ) THEN + PMNAME = "WW3 default" + ELSE IF( PTMETH .EQ. 2 ) THEN + PMNAME = "Watershedding plus wind cut-off" + ELSE IF( PTMETH .EQ. 3 ) THEN + PMNAME = "Watershedding only" + WSCUT = 0.0 ! We don't want to classify by ws frac + PMNAM2 = "WSC set to 0.0" + ELSE IF( PTMETH .EQ. 4 ) THEN + PMNAME = "Wind speed cut-off only" + PMNAM2 = "WSC set to 0.0, NOSW set to 1" + WSCUT = 0.0 ! We don't want to classify by ws frac + NOSWLL = 1 ! Only ever one swell + ELSE IF( PTMETH .EQ. 5 ) THEN + WRITE(PMNAME, '("2-Band hi/low cutoff at ", F4.2,"Hz")') PTFCUT + PMNAM2 = "WSC set to 0.0, NOSW set to 1" + WSCUT = 0.0 ! We don't want to classify by ws frac + NOSWLL = 1 ! Only ever one swell + ELSE + WRITE( NDSE, * ) & + "*** Error - unknown partitioing method (PTM)! ***" + CALL EXIT(1) + ENDIF - IF ( FLCOMB ) THEN - J = 1 - ELSE - J = 2 - END IF - WRITE (NDSO,966) IHMAX, HSPMIN, WSMULT, WSCUT, YESXNO(J), NOSWLL - WRITE (NDSO,5971) PMNAME - IF( PMNAM2 .NE. "" ) WRITE (NDSO,5972) PMNAM2 -!! WRITE (NDSO,966) IHMAX, HSPMIN, WSMULT, WSCUT, YESXNO(J) -! - FHMAX = MAX ( 0.01 , FMICHE ) + IF ( FLCOMB ) THEN + J = 1 + ELSE J = 2 + END IF + WRITE (NDSO,966) IHMAX, HSPMIN, WSMULT, WSCUT, YESXNO(J), NOSWLL + WRITE (NDSO,5971) PMNAME + IF( PMNAM2 .NE. "" ) WRITE (NDSO,5972) PMNAM2 + !! WRITE (NDSO,966) IHMAX, HSPMIN, WSMULT, WSCUT, YESXNO(J) + ! + FHMAX = MAX ( 0.01 , FMICHE ) + J = 2 #ifdef W3_MLIM - J = 1 -#endif - WRITE (NDSO,967) FHMAX, FHMAX/SQRT(2.), YESXNO(J) - IF ( FHMAX.LT.0.50 .AND. J.EQ.1 ) WRITE (NDST,968) -! - IF (TRIM(CALTYPE) .NE. 'standard' .AND. & - TRIM(CALTYPE) .NE. '360_day' .AND. & - TRIM(CALTYPE) .NE. '365_day' ) GOTO 2003 - WRITE (NDST,1973) CALTYPE - WRITE (NDSO,*) -! -! 6.x Read values for FLD stress calculation -! + J = 1 +#endif + WRITE (NDSO,967) FHMAX, FHMAX/SQRT(2.), YESXNO(J) + IF ( FHMAX.LT.0.50 .AND. J.EQ.1 ) WRITE (NDST,968) + ! + IF (TRIM(CALTYPE) .NE. 'standard' .AND. & + TRIM(CALTYPE) .NE. '360_day' .AND. & + TRIM(CALTYPE) .NE. '365_day' ) GOTO 2003 + WRITE (NDST,1973) CALTYPE + WRITE (NDSO,*) + ! + ! 6.x Read values for FLD stress calculation + ! #ifdef W3_FLD1 - TAILTYPE = 0 - TAILLEV = 0.006 - TAILT1 = 1.25 - TAILT2 = 3.00 + TAILTYPE = 0 + TAILLEV = 0.006 + TAILT1 = 1.25 + TAILT2 = 3.00 #endif #ifdef W3_FLD2 - TAILTYPE = 0 - TAILLEV = 0.006 - TAILT1 = 1.25 - TAILT2 = 3.00 + TAILTYPE = 0 + TAILLEV = 0.006 + TAILT1 = 1.25 + TAILT2 = 3.00 #endif -! + ! #ifdef W3_FLD1 - CALL READNL ( NDSS, 'FLD1', STATUS ) - TAILLEV = MIN( MAX ( 0.0005 , TAILLEV ), 0.04) - TAIL_LEV = TAILLEV - TAIL_ID = TAILTYPE - TAIL_TRAN1 = TAILT1 - TAIL_TRAN2 = TAILT2 + CALL READNL ( NDSS, 'FLD1', STATUS ) + TAILLEV = MIN( MAX ( 0.0005 , TAILLEV ), 0.04) + TAIL_LEV = TAILLEV + TAIL_ID = TAILTYPE + TAIL_TRAN1 = TAILT1 + TAIL_TRAN2 = TAILT2 #endif #ifdef W3_FLD2 - CALL READNL ( NDSS, 'FLD2', STATUS ) - TAILLEV = MIN( MAX ( 0.0005 , TAILLEV ), 0.04) - TAIL_LEV = TAILLEV - TAIL_ID = TAILTYPE - TAIL_TRAN1 = TAILT1 - TAIL_TRAN2 = TAILT2 -#endif -! -! 6.o End of namelist processing -! - IF (FLGNML) THEN - CLOSE (NDSS) - ELSE - CLOSE (NDSS,STATUS='DELETE') - END IF -! - IF ( FLNMLO ) THEN - WRITE (NDSO,917) + CALL READNL ( NDSS, 'FLD2', STATUS ) + TAILLEV = MIN( MAX ( 0.0005 , TAILLEV ), 0.04) + TAIL_LEV = TAILLEV + TAIL_ID = TAILTYPE + TAIL_TRAN1 = TAILT1 + TAIL_TRAN2 = TAILT2 +#endif + ! + ! 6.o End of namelist processing + ! + IF (FLGNML) THEN + CLOSE (NDSS) + ELSE + CLOSE (NDSS,STATUS='DELETE') + END IF + ! + IF ( FLNMLO ) THEN + WRITE (NDSO,917) #ifdef W3_FLX3 - WRITE (NDSO,2810) CDMAX*1.E3, CTYPE + WRITE (NDSO,2810) CDMAX*1.E3, CTYPE #endif #ifdef W3_FLX4 - WRITE (NDSO,2810) CDFAC + WRITE (NDSO,2810) CDFAC #endif #ifdef W3_LN1 - WRITE (NDSO,2820) CLIN, RFPM, RFHF + WRITE (NDSO,2820) CLIN, RFPM, RFHF #endif #ifdef W3_ST1 - WRITE (NDSO,2920) CINP + WRITE (NDSO,2920) CINP #endif - IF ( .NOT. FLSTB2 ) THEN + IF ( .NOT. FLSTB2 ) THEN #ifdef W3_ST2 - WRITE (NDSO,2920) ZWND, SWELLF + WRITE (NDSO,2920) ZWND, SWELLF #endif - ELSE + ELSE #ifdef W3_STAB2 - WRITE (NDSO,2921) ZWND, SWELLF, STABSH, STABOF, & - CNEG, CPOS, FNEG + WRITE (NDSO,2921) ZWND, SWELLF, STABSH, STABOF, & + CNEG, CPOS, FNEG #endif - END IF -! + END IF + ! #ifdef W3_ST3 - WRITE (NDSO,2920) ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & - SWELLF + WRITE (NDSO,2920) ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & + SWELLF #endif #ifdef W3_ST4 - WRITE (NDSO,2920) ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & - TAUWSHELTER, SWELLFPAR, SWELLF, SWELLF2, SWELLF3, SWELLF4, & - SWELLF5, SWELLF6, SWELLF7, Z0RAT, SINBR + WRITE (NDSO,2920) ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & + TAUWSHELTER, SWELLFPAR, SWELLF, SWELLF2, SWELLF3, SWELLF4, & + SWELLF5, SWELLF6, SWELLF7, Z0RAT, SINBR #endif #ifdef W3_ST6 - WRITE (NDSO,2920) SINA0, SINWS, SINFC + WRITE (NDSO,2920) SINA0, SINWS, SINFC #endif #ifdef W3_NL1 - WRITE (NDSO,2922) LAMBDA, NLPROP, KDCONV, KDMIN, & - SNLCS1, SNLCS2, SNLCS3 + WRITE (NDSO,2922) LAMBDA, NLPROP, KDCONV, KDMIN, & + SNLCS1, SNLCS2, SNLCS3 #endif #ifdef W3_NL2 - WRITE (NDSO,2922) IQTYPE, TAILNL, NDEPTH - IF ( IQTYPE .EQ. 3 ) THEN - IF ( NDEPTH .EQ. 1 ) THEN - WRITE (NDSO,3923) DPTHNL(1) - ELSE - WRITE (NDSO,4923) DPTHNL(1) - END IF - WRITE (NDSO,5923) DPTHNL(2:NDEPTH-1) - WRITE (NDSO,6923) DPTHNL(NDEPTH) - END IF + WRITE (NDSO,2922) IQTYPE, TAILNL, NDEPTH + IF ( IQTYPE .EQ. 3 ) THEN + IF ( NDEPTH .EQ. 1 ) THEN + WRITE (NDSO,3923) DPTHNL(1) + ELSE + WRITE (NDSO,4923) DPTHNL(1) + END IF + WRITE (NDSO,5923) DPTHNL(2:NDEPTH-1) + WRITE (NDSO,6923) DPTHNL(NDEPTH) + END IF #endif #ifdef W3_NL3 - WRITE (NDSO,2922) NQDEF, MSC, NSC, KDFD, KDFS - IF ( NQDEF .EQ. 1 ) THEN - WRITE (NDSO,3923) QPARMS(1:5) - ELSE - WRITE (NDSO,4923) QPARMS(1:5) - DO J=2, NQDEF-1 - WRITE (NDSO,5923) QPARMS((J-1)*5+1:J*5) - END DO - WRITE (NDSO,6923) QPARMS((NQDEF-1)*5+1:NQDEF*5) - END IF + WRITE (NDSO,2922) NQDEF, MSC, NSC, KDFD, KDFS + IF ( NQDEF .EQ. 1 ) THEN + WRITE (NDSO,3923) QPARMS(1:5) + ELSE + WRITE (NDSO,4923) QPARMS(1:5) + DO J=2, NQDEF-1 + WRITE (NDSO,5923) QPARMS((J-1)*5+1:J*5) + END DO + WRITE (NDSO,6923) QPARMS((NQDEF-1)*5+1:NQDEF*5) + END IF #endif #ifdef W3_NL4 - WRITE (NDSO,2922) INDTSA, ALTLP + WRITE (NDSO,2922) INDTSA, ALTLP #endif #ifdef W3_NL5 - WRITE (NDSO,2922) QR5DPT, QR5OML, QI5DIS, QI5KEV, QI5IPL, QI5PMX + WRITE (NDSO,2922) QR5DPT, QR5OML, QI5DIS, QI5KEV, QI5IPL, QI5PMX #endif #ifdef W3_NLS - WRITE (NDSO,8922) A34, FHFC, DNM, FC1, FC2, FC3 + WRITE (NDSO,8922) A34, FHFC, DNM, FC1, FC2, FC3 #endif #ifdef W3_ST1 - WRITE (NDSO,2924) CDIS, APM + WRITE (NDSO,2924) CDIS, APM #endif #ifdef W3_ST2 - WRITE (NDSO,2924) SDSA0, SDSA1, SDSA2, SDSB0, SDSB1, PHIMIN + WRITE (NDSO,2924) SDSA0, SDSA1, SDSA2, SDSB0, SDSB1, PHIMIN #endif #ifdef W3_ST3 - WRITE (NDSO,2924) SDSC1, WNMEANP, FXPM3, FXFM3, SDSDELTA1, & - SDSDELTA2 + WRITE (NDSO,2924) SDSC1, WNMEANP, FXPM3, FXFM3, SDSDELTA1, & + SDSDELTA2 #endif #ifdef W3_ST4 - WRITE (NDSO,2924) SDSBCHOICE, SDSC2, SDSCUM, SDSC4, & - SDSC5, SDSC6, & - WNMEANP, FXPM3, FXFM3, FXFMAGE, & - SDSBINT, SDSBCK, SDSABK, SDSPBK, SDSHCK, & - SDSBR, SDSSTRAIN, SDSSTRAINA, SDSSTRAIN2, & - SDSBT, SDSP, SDSISO, SDSCOS, SDSDTH, SDSBRF1, & - SDSBRFDF, SDSBM0, SDSBM1, SDSBM2, SDSBM3, SDSBM4, & - SPMSS, SDKOF, SDSMWD, SDSFACMTF, SDSNMTF,SDSMWPOW,& - SDSCUMP, SDSNUW, WHITECAPWIDTH, WHITECAPDUR + WRITE (NDSO,2924) SDSBCHOICE, SDSC2, SDSCUM, SDSC4, & + SDSC5, SDSC6, & + WNMEANP, FXPM3, FXFM3, FXFMAGE, & + SDSBINT, SDSBCK, SDSABK, SDSPBK, SDSHCK, & + SDSBR, SDSSTRAIN, SDSSTRAINA, SDSSTRAIN2, & + SDSBT, SDSP, SDSISO, SDSCOS, SDSDTH, SDSBRF1, & + SDSBRFDF, SDSBM0, SDSBM1, SDSBM2, SDSBM3, SDSBM4, & + SPMSS, SDKOF, SDSMWD, SDSFACMTF, SDSNMTF,SDSMWPOW,& + SDSCUMP, SDSNUW, WHITECAPWIDTH, WHITECAPDUR #endif #ifdef W3_ST6 - WRITE (NDSO,2924) SDSET, SDSA1, SDSA2, SDSP1, SDSP2 - WRITE (NDSO,2937) SWLB1, CSTB1 + WRITE (NDSO,2924) SDSET, SDSA1, SDSA2, SDSP1, SDSP2 + WRITE (NDSO,2937) SWLB1, CSTB1 #endif #ifdef W3_BT1 - WRITE (NDSO,2926) GAMMA + WRITE (NDSO,2926) GAMMA #endif #ifdef W3_BT4 - WRITE (NDSO,2926) SEDMAPD50, SED_D50_UNIFORM, & - RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4, SIGDEPTH, & - BOTROUGHMIN, BOTROUGHFAC + WRITE (NDSO,2926) SEDMAPD50, SED_D50_UNIFORM, & + RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4, SIGDEPTH, & + BOTROUGHMIN, BOTROUGHFAC #endif #ifdef W3_DB1 - IF ( BJFLAG ) THEN - WRITE (NDSO,2928) BJALFA, BJGAM, '.TRUE.' - ELSE - WRITE (NDSO,2928) BJALFA, BJGAM, '.FALSE.' - END IF + IF ( BJFLAG ) THEN + WRITE (NDSO,2928) BJALFA, BJGAM, '.TRUE.' + ELSE + WRITE (NDSO,2928) BJALFA, BJGAM, '.FALSE.' + END IF #endif #ifdef W3_PR1 - WRITE (NDSO,2953) CFLTM + WRITE (NDSO,2953) CFLTM #endif #ifdef W3_PR2 - WRITE (NDSO,2953) CFLTM, DTIME, LATMIN + WRITE (NDSO,2953) CFLTM, DTIME, LATMIN #endif #ifdef W3_SMC - WRITE (NDSO,2954) CFLSM, DTIMS, Arctic, RFMAXD, UNO3, & - AVERG, LvSMC, NBISMC, ISHFT, JEQT, SEAWND + WRITE (NDSO,2954) CFLSM, DTIMS, Arctic, RFMAXD, UNO3, & + AVERG, LvSMC, NBISMC, ISHFT, JEQT, SEAWND #endif #ifdef W3_PR3 - WRITE (NDSO,2953) CFLTM, WDTHCG, WDTHTH -#endif -! - WRITE (NDSO,2956) UGBCCFL, UGOBCAUTO, UGOBCDEPTH,TRIM(UGOBCFILE), & - EXPFSN, EXPFSPSI, EXPFSFCT, IMPFSN, EXPTOTAL,& - IMPTOTAL, IMPREFRACTION, IMPFREQSHIFT, & - IMPSOURCE, SETUP_APPLY_WLV, & - JGS_TERMINATE_MAXITER, & - JGS_TERMINATE_DIFFERENCE, & - JGS_TERMINATE_NORM, & - JGS_LIMITER, & - JGS_USE_JACOBI, & - JGS_BLOCK_GAUSS_SEIDEL, & - JGS_MAXITER, & - JGS_PMIN, & - JGS_DIFF_THR, & - JGS_NORM_THR, & - JGS_NLEVEL, & - JGS_SOURCE_NONLINEAR -! - WRITE (NDSO,2976) P2SF, I1P2SF, I2P2SF, & - US3D, I1US3D, I2US3D, & - USSP, IUSSP, & - E3D, I1E3D, I2E3D, & - TH1MF, I1TH1M, I2TH1M, & - STH1MF, I1STH1M, I2STH1M, & - TH2MF, I1TH2M, I2TH2M, & - STH2MF, I1STH2M, I2STH2M -! + WRITE (NDSO,2953) CFLTM, WDTHCG, WDTHTH +#endif + ! + WRITE (NDSO,2956) UGBCCFL, UGOBCAUTO, UGOBCDEPTH,TRIM(UGOBCFILE), & + EXPFSN, EXPFSPSI, EXPFSFCT, IMPFSN, EXPTOTAL,& + IMPTOTAL, IMPREFRACTION, IMPFREQSHIFT, & + IMPSOURCE, SETUP_APPLY_WLV, & + JGS_TERMINATE_MAXITER, & + JGS_TERMINATE_DIFFERENCE, & + JGS_TERMINATE_NORM, & + JGS_LIMITER, & + JGS_USE_JACOBI, & + JGS_BLOCK_GAUSS_SEIDEL, & + JGS_MAXITER, & + JGS_PMIN, & + JGS_DIFF_THR, & + JGS_NORM_THR, & + JGS_NLEVEL, & + JGS_SOURCE_NONLINEAR + ! + WRITE (NDSO,2976) P2SF, I1P2SF, I2P2SF, & + US3D, I1US3D, I2US3D, & + USSP, IUSSP, & + E3D, I1E3D, I2E3D, & + TH1MF, I1TH1M, I2TH1M, & + STH1MF, I1STH1M, I2STH1M, & + TH2MF, I1TH2M, I2TH2M, & + STH2MF, I1STH2M, I2STH2M + ! #ifdef W3_REF1 - WRITE(NDSO,2986) REFCOAST, REFFREQ, REFSLOPE, REFMAP, & - REFMAPD, REFSUBGRID , REFRMAX, REFFREQPOW, & - REFICEBERG, REFCOSP_STRAIGHT, REFUNSTSOURCE + WRITE(NDSO,2986) REFCOAST, REFFREQ, REFSLOPE, REFMAP, & + REFMAPD, REFSUBGRID , REFRMAX, REFFREQPOW, & + REFICEBERG, REFCOSP_STRAIGHT, REFUNSTSOURCE #endif -! + ! #ifdef W3_IG1 - WRITE(NDSO,2977) IGMETHOD, IGADDOUTP, IGSOURCE, & - IGSTERMS, IGBCOVERWRITE, IGSWELLMAX, & - IGMAXFREQ, IGSOURCEATBP, IGKDMIN, & - IGFIXEDDEPTH, IGEMPIRICAL + WRITE(NDSO,2977) IGMETHOD, IGADDOUTP, IGSOURCE, & + IGSTERMS, IGBCOVERWRITE, IGSWELLMAX, & + IGMAXFREQ, IGSOURCEATBP, IGKDMIN, & + IGFIXEDDEPTH, IGEMPIRICAL #endif -! + ! #ifdef W3_IC2 - WRITE(NDSO,2978) IC2DISPER, IC2TURB, IC2ROUGH, & - IC2REYNOLDS, IC2SMOOTH, IC2VISC, IC2TURBS, & - IC2DMAX + WRITE(NDSO,2978) IC2DISPER, IC2TURB, IC2ROUGH, & + IC2REYNOLDS, IC2SMOOTH, IC2VISC, IC2TURBS, & + IC2DMAX #endif -! + ! #ifdef W3_IC3 - WRITE(NDSO,2979) IC3MAXTHK, IC3MAXCNC, IC2TURB, & - IC2ROUGH, IC2REYNOLDS, IC2SMOOTH, & - IC2VISC, IC2TURBS, IC3CHENG, & - USECGICE, IC3HILIM, IC3KILIM, & - IC3HICE, IC3VISC, IC3DENS, IC3ELAS + WRITE(NDSO,2979) IC3MAXTHK, IC3MAXCNC, IC2TURB, & + IC2ROUGH, IC2REYNOLDS, IC2SMOOTH, & + IC2VISC, IC2TURBS, IC3CHENG, & + USECGICE, IC3HILIM, IC3KILIM, & + IC3HICE, IC3VISC, IC3DENS, IC3ELAS #endif -! + ! #ifdef W3_IC4 - WRITE(NDSO,NML=SIC4) + WRITE(NDSO,NML=SIC4) #endif -! + ! #ifdef W3_IC5 - WRITE(NDSO,2981) IC5MINIG, IC5MINWT, IC5MAXKRATIO, & - IC5MAXKI, IC5MINHW, IC5MAXITER, & - IC5RKICK, IC5KFILTER, IC5VEMOD + WRITE(NDSO,2981) IC5MINIG, IC5MINWT, IC5MAXKRATIO, & + IC5MAXKI, IC5MINHW, IC5MAXITER, & + IC5RKICK, IC5KFILTER, IC5VEMOD #endif -! + ! #ifdef W3_IS1 - WRITE (NDSO,2946) IS1C1, IS1C2 + WRITE (NDSO,2946) IS1C1, IS1C2 #endif -! + ! #ifdef W3_IS2 - WRITE (NDSO,948) ISC1, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, & - IS2DUPDATE, IS2FLEXSTR, IS2DISP, IS2DAMP, IS2FRAGILITY, IS2DMIN, IS2C2, & - IS2C3, IS2CONC, IS2CREEPB, IS2CREEPC, IS2CREEPD, & - IS2CREEPN, IS2BREAKE, IS2BREAKF, IS2WIM1, IS2ANDISB, & - IS2ANDISE, IS2ANDISD, IS2ANDISN + WRITE (NDSO,948) ISC1, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, & + IS2DUPDATE, IS2FLEXSTR, IS2DISP, IS2DAMP, IS2FRAGILITY, IS2DMIN, IS2C2, & + IS2C3, IS2CONC, IS2CREEPB, IS2CREEPC, IS2CREEPD, & + IS2CREEPN, IS2BREAKE, IS2BREAKF, IS2WIM1, IS2ANDISB, & + IS2ANDISE, IS2ANDISD, IS2ANDISN #endif -! + ! #ifdef W3_UOST - WRITE (NDSO, 4502) ADJUSTL(TRIM(UOSTFILELOCAL)), ADJUSTL(TRIM(UOSTFILESHADOW)), & - UOSTFACTORLOCAL, UOSTFACTORSHADOW -#endif - -! - IF ( FLCOMB ) THEN - WRITE (NDSO,2966) CICE0, CICEN, LICE, PMOVE, XSEED, FLAGTR, & - XP, XR, XFILT, IHMAX, HSPMIN, WSMULT, & - WSCUT, '.TRUE.', NOSWLL, FHMAX, & - RWNDC, WCOR1, WCOR2, FACBERG, GSHIFT, & - STDX, STDY, STDT, ICEHMIN, ICEHFAC, & - ICEHINIT, ICEDISP, ICEHDISP, & - ICESLN, ICEWIND, ICESNL, ICESDS, & - ICEDDISP,ICEFDISP, CALTYPE, TRCKCMPR, & - BTBETA - ELSE - WRITE (NDSO,2966) CICE0, CICEN, LICE, PMOVE, XSEED, FLAGTR, & - XP, XR, XFILT, IHMAX, HSPMIN, WSMULT, & - WSCUT, '.FALSE.', NOSWLL, FHMAX, & - RWNDC, WCOR1, WCOR2, FACBERG, GSHIFT, & - STDX, STDY, STDT, ICEHMIN, ICEHFAC, & - ICEHINIT, ICEDISP, ICEHDISP, & - ICESLN, ICEWIND, ICESNL, ICESDS, & - ICEDDISP, ICEFDISP, CALTYPE, TRCKCMPR,& - BTBETA - END IF -! + WRITE (NDSO, 4502) ADJUSTL(TRIM(UOSTFILELOCAL)), ADJUSTL(TRIM(UOSTFILESHADOW)), & + UOSTFACTORLOCAL, UOSTFACTORSHADOW +#endif + + ! + IF ( FLCOMB ) THEN + WRITE (NDSO,2966) CICE0, CICEN, LICE, PMOVE, XSEED, FLAGTR, & + XP, XR, XFILT, IHMAX, HSPMIN, WSMULT, & + WSCUT, '.TRUE.', NOSWLL, FHMAX, & + RWNDC, WCOR1, WCOR2, FACBERG, GSHIFT, & + STDX, STDY, STDT, ICEHMIN, ICEHFAC, & + ICEHINIT, ICEDISP, ICEHDISP, & + ICESLN, ICEWIND, ICESNL, ICESDS, & + ICEDDISP,ICEFDISP, CALTYPE, TRCKCMPR, & + BTBETA + ELSE + WRITE (NDSO,2966) CICE0, CICEN, LICE, PMOVE, XSEED, FLAGTR, & + XP, XR, XFILT, IHMAX, HSPMIN, WSMULT, & + WSCUT, '.FALSE.', NOSWLL, FHMAX, & + RWNDC, WCOR1, WCOR2, FACBERG, GSHIFT, & + STDX, STDY, STDT, ICEHMIN, ICEHFAC, & + ICEHINIT, ICEDISP, ICEHDISP, & + ICESLN, ICEWIND, ICESNL, ICESDS, & + ICEDDISP, ICEFDISP, CALTYPE, TRCKCMPR,& + BTBETA + END IF + ! #ifdef W3_FLD1 - WRITE(NDSO,2987) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + WRITE(NDSO,2987) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 #endif #ifdef W3_FLD2 - WRITE(NDSO,2987) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + WRITE(NDSO,2987) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 #endif #ifdef W3_RTD - WRITE(NDSO,4991) PLAT, PLON, UNROT - WRITE(NDSO,4992) BPLAT, BPLON -#endif -! - WRITE (NDSO,918) - END IF -! -! 6.p Set various other values ... -! ... Tail in integration --> scale factor for A to E conv -! - FTE = 0.25 * SIG(NK) * DTH * SIG(NK) - FTF = 0.20 * DTH * SIG(NK) - FTWN = 0.20 * SQRT(GRAV) * DTH * SIG(NK) - FTTR = FTF - FTWL = GRAV / 6. / SIG(NK) * DTH * SIG(NK) + WRITE(NDSO,4991) PLAT, PLON, UNROT + WRITE(NDSO,4992) BPLAT, BPLON +#endif + ! + WRITE (NDSO,918) + END IF + ! + ! 6.p Set various other values ... + ! ... Tail in integration --> scale factor for A to E conv + ! + FTE = 0.25 * SIG(NK) * DTH * SIG(NK) + FTF = 0.20 * DTH * SIG(NK) + FTWN = 0.20 * SQRT(GRAV) * DTH * SIG(NK) + FTTR = FTF + FTWL = GRAV / 6. / SIG(NK) * DTH * SIG(NK) #ifdef W3_ST3 - STXFTF = 1/(FACHF-1.-WNMEANP*2) & - * SIG(NK)**(2+WNMEANP*2) * DTH - STXFTFTAIL = 1/(FACHF-1.-WNMEANPTAIL*2) & - * SIG(NK)**(2+WNMEANPTAIL*2) * DTH - STXFTWN = 1/(FACHF-1.-WNMEANP*2) * SIG(NK)**(2) & - * (SIG(NK)/SQRT(GRAV))**(WNMEANP*2) * DTH - SSTXFTF = STXFTF - SSTXFTFTAIL = STXFTFTAIL - SSTXFTWN = STXFTWN -#endif -! + STXFTF = 1/(FACHF-1.-WNMEANP*2) & + * SIG(NK)**(2+WNMEANP*2) * DTH + STXFTFTAIL = 1/(FACHF-1.-WNMEANPTAIL*2) & + * SIG(NK)**(2+WNMEANPTAIL*2) * DTH + STXFTWN = 1/(FACHF-1.-WNMEANP*2) * SIG(NK)**(2) & + * (SIG(NK)/SQRT(GRAV))**(WNMEANP*2) * DTH + SSTXFTF = STXFTF + SSTXFTFTAIL = STXFTFTAIL + SSTXFTWN = STXFTWN +#endif + ! #ifdef W3_ST4 - STXFTF = 1/(FACHF-1.-WNMEANP*2) & - * SIG(NK)**(2+WNMEANP*2) * DTH - STXFTFTAIL = 1/(FACHF-1.-WNMEANPTAIL*2) & - * SIG(NK)**(2+WNMEANPTAIL*2) * DTH - STXFTWN = 1/(FACHF-1.-WNMEANP*2) * SIG(NK)**(2) & - * (SIG(NK)/SQRT(GRAV))**(WNMEANP*2) * DTH - SSTXFTF = STXFTF - SSTXFTFTAIL = STXFTFTAIL - SSTXFTWN = STXFTWN -#endif -! -! ... High frequency cut-off -! - FXFM = 2.5 + STXFTF = 1/(FACHF-1.-WNMEANP*2) & + * SIG(NK)**(2+WNMEANP*2) * DTH + STXFTFTAIL = 1/(FACHF-1.-WNMEANPTAIL*2) & + * SIG(NK)**(2+WNMEANPTAIL*2) * DTH + STXFTWN = 1/(FACHF-1.-WNMEANP*2) * SIG(NK)**(2) & + * (SIG(NK)/SQRT(GRAV))**(WNMEANP*2) * DTH + SSTXFTF = STXFTF + SSTXFTFTAIL = STXFTFTAIL + SSTXFTWN = STXFTWN +#endif + ! + ! ... High frequency cut-off + ! + FXFM = 2.5 #ifdef W3_ST6 - FXFM = SIN6FC + FXFM = SIN6FC #endif - FXPM = 4.0 - FXPM = FXPM * GRAV / 28. - FXFM = FXFM * TPI - XFC = 3.0 + FXPM = 4.0 + FXPM = FXPM * GRAV / 28. + FXFM = FXFM * TPI + XFC = 3.0 #ifdef W3_ST2 - XFH = 2.0 - XF1 = 1.75 - XF2 = 2.5 - XFT = XF2 -#endif -! - FACTI1 = 1. / LOG(XFR) - FACTI2 = 1. - LOG(TPI*FR1) * FACTI1 -! -! Setting of FACHF moved to before !/NL2 set-up for consistency -! + XFH = 2.0 + XF1 = 1.75 + XF2 = 2.5 + XFT = XF2 +#endif + ! + FACTI1 = 1. / LOG(XFR) + FACTI2 = 1. - LOG(TPI*FR1) * FACTI1 + ! + ! Setting of FACHF moved to before !/NL2 set-up for consistency + ! #ifdef W3_NL2 - FACHF = -TAILNL -#endif - FACHFA = XFR**(-FACHF-2) - FACHFE = XFR**(-FACHF) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 7. Read and prepare the grid. -! 7.a Type of grid -! - IF (FLGNML) THEN - GSTRG=TRIM(NML_GRID%TYPE) - IF (TRIM(NML_GRID%COORD).EQ.'SPHE') FLAGLL=.TRUE. - IF (TRIM(NML_GRID%COORD).EQ.'CART') FLAGLL=.FALSE. - CSTRG=TRIM(NML_GRID%CLOS) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) GSTRG, FLAGLL, CSTRG - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF + FACHF = -TAILNL +#endif + FACHFA = XFR**(-FACHF-2) + FACHFE = XFR**(-FACHF) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 7. Read and prepare the grid. + ! 7.a Type of grid + ! + IF (FLGNML) THEN + GSTRG=TRIM(NML_GRID%TYPE) + IF (TRIM(NML_GRID%COORD).EQ.'SPHE') FLAGLL=.TRUE. + IF (TRIM(NML_GRID%COORD).EQ.'CART') FLAGLL=.FALSE. + CSTRG=TRIM(NML_GRID%CLOS) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) GSTRG, FLAGLL, CSTRG + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF - SELECT CASE (TRIM(GSTRG)) - CASE ('RECT') - GTYPE = RLGTYPE - WRITE (NDSO,3000) 'rectilinear' - CASE ('CURV') - GTYPE = CLGTYPE - WRITE (NDSO,3000) 'curvilinear' - CASE ('UNST') - GTYPE = UNGTYPE - WRITE (NDSO,3000) 'unstructured' -!!Li Add SMC grid type option. JGLi12Oct2020 - CASE ('SMCG') - GTYPE = SMCTYPE - WRITE (NDSO,3000) 'SMC Grid' - CASE DEFAULT - WRITE (NDSE,1007) TRIM(GSTRG) + SELECT CASE (TRIM(GSTRG)) + CASE ('RECT') + GTYPE = RLGTYPE + WRITE (NDSO,3000) 'rectilinear' + CASE ('CURV') + GTYPE = CLGTYPE + WRITE (NDSO,3000) 'curvilinear' + CASE ('UNST') + GTYPE = UNGTYPE + WRITE (NDSO,3000) 'unstructured' + !!Li Add SMC grid type option. JGLi12Oct2020 + CASE ('SMCG') + GTYPE = SMCTYPE + WRITE (NDSO,3000) 'SMC Grid' + CASE DEFAULT + WRITE (NDSE,1007) TRIM(GSTRG) + CALL EXTCDE ( 25 ) + END SELECT + ! + IF ( FLAGLL ) THEN + FACTOR = 1. + WRITE (NDSO,3001) 'spherical' + ELSE + FACTOR = 1.E-3 + WRITE (NDSO,3001) 'Cartesian' + END IF + ! + ! Only process grid closure string for logically rectangular grids. + ! Closure setting for unstructured grids is NONE. + ICLOSE = ICLOSE_NONE + IF ( GTYPE.NE.UNGTYPE ) THEN + SELECT CASE (TRIM(CSTRG)) + CASE ('NONE') + ICLOSE = ICLOSE_NONE + WRITE (NDSO,3002) 'none' + CASE ('SMPL') + ICLOSE = ICLOSE_SMPL + WRITE (NDSO,3002) 'simple' + CASE ('TRPL') + WRITE (NDSE,'(/2A)') ' *** WARNING WW3_GRID: TRIPOLE ', & + 'GRID CLOSURE IMPLEMENTATION IS INCOMPLETE ***' + ICLOSE = ICLOSE_TRPL + WRITE (NDSO,3002) 'tripole' + IF ( GTYPE.EQ.RLGTYPE ) THEN + WRITE (NDSE,1009) CALL EXTCDE ( 25 ) - END SELECT -! - IF ( FLAGLL ) THEN - FACTOR = 1. - WRITE (NDSO,3001) 'spherical' - ELSE - FACTOR = 1.E-3 - WRITE (NDSO,3001) 'Cartesian' END IF -! -! Only process grid closure string for logically rectangular grids. -! Closure setting for unstructured grids is NONE. - ICLOSE = ICLOSE_NONE - IF ( GTYPE.NE.UNGTYPE ) THEN - SELECT CASE (TRIM(CSTRG)) - CASE ('NONE') - ICLOSE = ICLOSE_NONE - WRITE (NDSO,3002) 'none' - CASE ('SMPL') - ICLOSE = ICLOSE_SMPL - WRITE (NDSO,3002) 'simple' - CASE ('TRPL') - WRITE (NDSE,'(/2A)') ' *** WARNING WW3_GRID: TRIPOLE ', & - 'GRID CLOSURE IMPLEMENTATION IS INCOMPLETE ***' - ICLOSE = ICLOSE_TRPL - WRITE (NDSO,3002) 'tripole' - IF ( GTYPE.EQ.RLGTYPE ) THEN - WRITE (NDSE,1009) - CALL EXTCDE ( 25 ) - END IF - CASE DEFAULT - ! Check for old style GLOBAL input - SELECT CASE (TRIM(CSTRG)) - CASE ('T','t','.TRU','.tru') - ICLOSE = ICLOSE_SMPL - WRITE (NDSO,3002) 'simple' - WRITE (NDSE,1013) - CASE ('F','f','.FAL','.fal') - ICLOSE = ICLOSE_NONE - WRITE (NDSO,3002) 'none' - WRITE (NDSE,1013) - CASE DEFAULT - WRITE (NDSE,1012) TRIM(CSTRG) - CALL EXTCDE ( 25 ) - END SELECT - END SELECT - IF ( ICLOSE.NE.ICLOSE_NONE .AND. .NOT.FLAGLL ) THEN - WRITE (NDSE,1008) - CALL EXTCDE ( 25 ) - END IF - END IF !GTYPE.NE.UNGTYPE -! -! 7.b Size of grid -! - IF (FLGNML) THEN - SELECT CASE ( GTYPE ) -!!Li SMCTYPE shares domain info with RLGTYPE. JGLi12Oct2020 - CASE ( RLGTYPE, SMCTYPE ) - NX = NML_RECT%NX - NY = NML_RECT%NY - NX = MAX ( 3 , NX ) - NY = MAX ( 3 , NY ) - WRITE (NDSO,3003) NX, NY - CASE ( CLGTYPE ) - NX = NML_CURV%NX - NY = NML_CURV%NY - NX = MAX ( 3 , NX ) - NY = MAX ( 3 , NY ) - WRITE (NDSO,3003) NX, NY - CASE ( UNGTYPE ) - NY=1 + CASE DEFAULT + ! Check for old style GLOBAL input + SELECT CASE (TRIM(CSTRG)) + CASE ('T','t','.TRU','.tru') + ICLOSE = ICLOSE_SMPL + WRITE (NDSO,3002) 'simple' + WRITE (NDSE,1013) + CASE ('F','f','.FAL','.fal') + ICLOSE = ICLOSE_NONE + WRITE (NDSO,3002) 'none' + WRITE (NDSE,1013) + CASE DEFAULT + WRITE (NDSE,1012) TRIM(CSTRG) + CALL EXTCDE ( 25 ) END SELECT + END SELECT + IF ( ICLOSE.NE.ICLOSE_NONE .AND. .NOT.FLAGLL ) THEN + WRITE (NDSE,1008) + CALL EXTCDE ( 25 ) + END IF + END IF !GTYPE.NE.UNGTYPE + ! + ! 7.b Size of grid + ! + IF (FLGNML) THEN + SELECT CASE ( GTYPE ) + !!Li SMCTYPE shares domain info with RLGTYPE. JGLi12Oct2020 + CASE ( RLGTYPE, SMCTYPE ) + NX = NML_RECT%NX + NY = NML_RECT%NY + NX = MAX ( 3 , NX ) + NY = MAX ( 3 , NY ) + WRITE (NDSO,3003) NX, NY + CASE ( CLGTYPE ) + NX = NML_CURV%NX + NY = NML_CURV%NY + NX = MAX ( 3 , NX ) + NY = MAX ( 3 , NY ) + WRITE (NDSO,3003) NX, NY + CASE ( UNGTYPE ) + NY=1 + END SELECT + ELSE + IF ( GTYPE.NE.UNGTYPE) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NX, NY + NX = MAX ( 3 , NX ) + NY = MAX ( 3 , NY ) + WRITE (NDSO,3003) NX, NY ELSE - IF ( GTYPE.NE.UNGTYPE) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NX, NY - NX = MAX ( 3 , NX ) - NY = MAX ( 3 , NY ) - WRITE (NDSO,3003) NX, NY - ELSE - NY =1 - END IF + NY =1 END IF -! -! Propagation specific to unstructured grids -! - DO_CHANGE_WLV=.FALSE. - IF ( GTYPE.EQ.UNGTYPE) THEN - UNSTSCHEMES = 0 - IF (EXPFSN) UNSTSCHEMES(1) = 1 - IF (EXPFSPSI) UNSTSCHEMES(2) = 1 - IF (EXPFSFCT) UNSTSCHEMES(3) = 1 - IF (IMPFSN) UNSTSCHEMES(4) = 1 - IF (IMPTOTAL) UNSTSCHEMES(5) = 1 - IF (EXPTOTAL) UNSTSCHEMES(6) = 1 - - IF (SUM(UNSTSCHEMES) .eq. 0) THEN - WRITE(NDSE,*) 'NO UNST SCHEME SELECTED' - CALL EXTCDE ( 19 ) - ELSE IF (SUM(UNSTSCHEMES) .gt. 1) THEN - WRITE(NDSE,*) 'MORE THAN ONE UNST SCHEME SELECTED' - CALL EXTCDE ( 19 ) - ENDIF - - UNSTSCHEME=-1 - DO IX=1,6 - IF (UNSTSCHEMES(IX).EQ.1) THEN - UNSTSCHEME=IX - EXIT - END IF - END DO - - FSBCCFL = UGBCCFL - SELECT CASE (UNSTSCHEME) - CASE (1) - FSN = EXPFSN - PNAME2 = 'N Explicit (Fluctuation Splitting) ' - CASE (2) - FSPSI = EXPFSPSI - PNAME2 = 'PSI Explicit (Fluctuation Splitting) ' - CASE (3) - FSFCT = EXPFSFCT - PNAME2 = ' Flux Corrected Transport Explicit' - CASE (4) - FSNIMP = IMPFSN - PNAME2 = 'N Implicit (Fluctuation Splitting) ' - CASE (5) - FSTOTALIMP = IMPTOTAL - PNAME2 = 'N Implicit (Fluctuation Splitting) for total implicit' - CASE (6) - FSTOTALEXP = EXPTOTAL - PNAME2 = 'N Explicit (Fluctuation Splitting) for one exchange explicit DC HPCF ' - END SELECT -! - IF (SUM(UNSTSCHEMES).GT.1) WRITE(NDSO,1035) - WRITE (NDSO,2951) PNAME2 + END IF + ! + ! Propagation specific to unstructured grids + ! + DO_CHANGE_WLV=.FALSE. + IF ( GTYPE.EQ.UNGTYPE) THEN + UNSTSCHEMES = 0 + IF (EXPFSN) UNSTSCHEMES(1) = 1 + IF (EXPFSPSI) UNSTSCHEMES(2) = 1 + IF (EXPFSFCT) UNSTSCHEMES(3) = 1 + IF (IMPFSN) UNSTSCHEMES(4) = 1 + IF (IMPTOTAL) UNSTSCHEMES(5) = 1 + IF (EXPTOTAL) UNSTSCHEMES(6) = 1 + IF (SUM(UNSTSCHEMES) .eq. 0) THEN + WRITE(NDSE,*) 'NO UNST SCHEME SELECTED' + CALL EXTCDE ( 19 ) + ELSE IF (SUM(UNSTSCHEMES) .gt. 1) THEN + WRITE(NDSE,*) 'MORE THAN ONE UNST SCHEME SELECTED' + CALL EXTCDE ( 19 ) + ENDIF - IF (IMPREFRACTION .and. IMPTOTAL .AND. FLCTH) THEN - FSREFRACTION = .TRUE. - PNAME2 = 'Refraction done implicitly' - WRITE (NDSO,2951) PNAME2 - ELSE - FSREFRACTION = .FALSE. - END IF - IF (IMPFREQSHIFT .and. IMPTOTAL .AND. FLCK) THEN - FSFREQSHIFT = .TRUE. - PNAME2 = 'Frequency shifting done implicitly' - WRITE (NDSO,2951) PNAME2 - ELSE - FSFREQSHIFT = .FALSE. - END IF - IF (IMPSOURCE .and. IMPTOTAL .AND. FLSOU) THEN - FSSOURCE = .TRUE. - PNAME2 = 'Source terms integrated implicitly' - WRITE (NDSO,2951) PNAME2 - ELSE - FSSOURCE = .FALSE. - END IF - IF (SETUP_APPLY_WLV) THEN - DO_CHANGE_WLV = SETUP_APPLY_WLV - PNAME2 = ' we change WLV' - WRITE (NDSO,2952) PNAME2 + UNSTSCHEME=-1 + DO IX=1,6 + IF (UNSTSCHEMES(IX).EQ.1) THEN + UNSTSCHEME=IX + EXIT END IF - SOLVERTHR_STP = SOLVERTHR_SETUP - CRIT_DEP_STP = CRIT_DEP_SETUP + END DO + + FSBCCFL = UGBCCFL + SELECT CASE (UNSTSCHEME) + CASE (1) + FSN = EXPFSN + PNAME2 = 'N Explicit (Fluctuation Splitting) ' + CASE (2) + FSPSI = EXPFSPSI + PNAME2 = 'PSI Explicit (Fluctuation Splitting) ' + CASE (3) + FSFCT = EXPFSFCT + PNAME2 = ' Flux Corrected Transport Explicit' + CASE (4) + FSNIMP = IMPFSN + PNAME2 = 'N Implicit (Fluctuation Splitting) ' + CASE (5) + FSTOTALIMP = IMPTOTAL + PNAME2 = 'N Implicit (Fluctuation Splitting) for total implicit' + CASE (6) + FSTOTALEXP = EXPTOTAL + PNAME2 = 'N Explicit (Fluctuation Splitting) for one exchange explicit DC HPCF ' + END SELECT + ! + IF (SUM(UNSTSCHEMES).GT.1) WRITE(NDSO,1035) + WRITE (NDSO,2951) PNAME2 + + + IF (IMPREFRACTION .and. IMPTOTAL .AND. FLCTH) THEN + FSREFRACTION = .TRUE. + PNAME2 = 'Refraction done implicitly' + WRITE (NDSO,2951) PNAME2 + ELSE + FSREFRACTION = .FALSE. + END IF + IF (IMPFREQSHIFT .and. IMPTOTAL .AND. FLCK) THEN + FSFREQSHIFT = .TRUE. + PNAME2 = 'Frequency shifting done implicitly' + WRITE (NDSO,2951) PNAME2 + ELSE + FSFREQSHIFT = .FALSE. END IF + IF (IMPSOURCE .and. IMPTOTAL .AND. FLSOU) THEN + FSSOURCE = .TRUE. + PNAME2 = 'Source terms integrated implicitly' + WRITE (NDSO,2951) PNAME2 + ELSE + FSSOURCE = .FALSE. + END IF + IF (SETUP_APPLY_WLV) THEN + DO_CHANGE_WLV = SETUP_APPLY_WLV + PNAME2 = ' we change WLV' + WRITE (NDSO,2952) PNAME2 + END IF + SOLVERTHR_STP = SOLVERTHR_SETUP + CRIT_DEP_STP = CRIT_DEP_SETUP + END IF -! -! 7.c Grid coordinates (branch here based on grid type) -! - IF ( GTYPE.NE.UNGTYPE) ALLOCATE ( XGRDIN(NX,NY), YGRDIN(NX,NY) ) - SELECT CASE ( GTYPE ) -! -! 7.c.1 Rectilinear grid -! -!!Li SMC grid shares domain info with RLGTYPE. JGLi12Oct2020 - CASE ( RLGTYPE, SMCTYPE ) -! - IF (FLGNML) THEN - SX = NML_RECT%SX - SY = NML_RECT%SY - VSC = NML_RECT%SF - X0 = NML_RECT%X0 - Y0 = NML_RECT%Y0 - VSC0 = NML_RECT%SF0 - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) SX, SY, VSC + ! + ! 7.c Grid coordinates (branch here based on grid type) + ! + IF ( GTYPE.NE.UNGTYPE) ALLOCATE ( XGRDIN(NX,NY), YGRDIN(NX,NY) ) + SELECT CASE ( GTYPE ) + ! + ! 7.c.1 Rectilinear grid + ! + !!Li SMC grid shares domain info with RLGTYPE. JGLi12Oct2020 + CASE ( RLGTYPE, SMCTYPE ) + ! + IF (FLGNML) THEN + SX = NML_RECT%SX + SY = NML_RECT%SY + VSC = NML_RECT%SF + X0 = NML_RECT%X0 + Y0 = NML_RECT%Y0 + VSC0 = NML_RECT%SF0 + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) SX, SY, VSC + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) X0, Y0, VSC0 + END IF + ! + VSC = MAX ( 1.E-7 , VSC ) + SX = SX / VSC + SY = SY / VSC + SX = MAX ( 1.E-7 , SX ) + SY = MAX ( 1.E-7 , SY ) + IF ( ICLOSE.EQ.ICLOSE_SMPL ) SX = 360. / REAL(NX) + ! + VSC0 = MAX ( 1.E-7 , VSC0 ) + X0 = X0 / VSC0 + Y0 = Y0 / VSC0 + ! + IF ( FLAGLL ) THEN + WRITE (NDSO,3004) FACTOR*SX, FACTOR*SY, & + FACTOR*X0, FACTOR*(X0+REAL(NX-1)*SX), & + FACTOR*Y0, FACTOR*(Y0+REAL(NY-1)*SY) + ELSE + WRITE (NDSO,3005) FACTOR*SX, FACTOR*SY, & + FACTOR*X0, FACTOR*(X0+REAL(NX-1)*SX), & + FACTOR*Y0, FACTOR*(Y0+REAL(NY-1)*SY) + END IF + ! + DO IY=1, NY + DO IX=1, NX + XGRDIN(IX,IY) = X0 + REAL(IX-1)*SX + YGRDIN(IX,IY) = Y0 + REAL(IY-1)*SY + END DO + END DO + ! + ! 7.c.2 Curvilinear grid + ! + CASE ( CLGTYPE ) + ! + ! 7.c.2.a Process x-coordinates + ! + IF (FLGNML) THEN + NDSG = NML_CURV%XCOORD%IDF + VSC = NML_CURV%XCOORD%SF + VOF = NML_CURV%XCOORD%OFF + IDLA = NML_CURV%XCOORD%IDLA + IDFM = NML_CURV%XCOORD%IDFM + RFORM = TRIM(NML_CURV%XCOORD%FORMAT) + FROM = TRIM(NML_CURV%XCOORD%FROM) + FNAME = TRIM(NML_CURV%XCOORD%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSG, VSC, VOF, & + IDLA, IDFM, RFORM, FROM, FNAME + END IF + ! + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 + ! + WRITE (NDSO,3006) NDSG, VSC, VOF, IDLA, IDFM + IF (IDFM.EQ.2) WRITE (NDSO,3008) TRIM(RFORM) + IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & + WRITE (NDSO,3009) TRIM(FNAME) + ! + IF ( NDSG .EQ. NDSI ) THEN + IF ( IDFM .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSG + CALL EXTCDE (23) + ELSE + IF (.NOT.FLGNML) THEN CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) X0, Y0, VSC0 END IF -! - VSC = MAX ( 1.E-7 , VSC ) - SX = SX / VSC - SY = SY / VSC - SX = MAX ( 1.E-7 , SX ) - SY = MAX ( 1.E-7 , SY ) - IF ( ICLOSE.EQ.ICLOSE_SMPL ) SX = 360. / REAL(NX) -! - VSC0 = MAX ( 1.E-7 , VSC0 ) - X0 = X0 / VSC0 - Y0 = Y0 / VSC0 -! - IF ( FLAGLL ) THEN - WRITE (NDSO,3004) FACTOR*SX, FACTOR*SY, & - FACTOR*X0, FACTOR*(X0+REAL(NX-1)*SX), & - FACTOR*Y0, FACTOR*(Y0+REAL(NY-1)*SY) - ELSE - WRITE (NDSO,3005) FACTOR*SX, FACTOR*SY, & - FACTOR*X0, FACTOR*(X0+REAL(NX-1)*SX), & - FACTOR*Y0, FACTOR*(Y0+REAL(NY-1)*SY) - END IF -! - DO IY=1, NY - DO IX=1, NX - XGRDIN(IX,IY) = X0 + REAL(IX-1)*SX - YGRDIN(IX,IY) = Y0 + REAL(IY-1)*SY - END DO - END DO -! -! 7.c.2 Curvilinear grid -! - CASE ( CLGTYPE ) -! -! 7.c.2.a Process x-coordinates -! - IF (FLGNML) THEN - NDSG = NML_CURV%XCOORD%IDF - VSC = NML_CURV%XCOORD%SF - VOF = NML_CURV%XCOORD%OFF - IDLA = NML_CURV%XCOORD%IDLA - IDFM = NML_CURV%XCOORD%IDFM - RFORM = TRIM(NML_CURV%XCOORD%FORMAT) - FROM = TRIM(NML_CURV%XCOORD%FROM) - FNAME = TRIM(NML_CURV%XCOORD%FILENAME) + END IF + ELSE + IF ( IDFM .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& + form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSG, VSC, VOF, & - IDLA, IDFM, RFORM, FROM, FNAME + OPEN (NDSG, & + form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) END IF -! - IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 - IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 -! - WRITE (NDSO,3006) NDSG, VSC, VOF, IDLA, IDFM - IF (IDFM.EQ.2) WRITE (NDSO,3008) TRIM(RFORM) - IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & - WRITE (NDSO,3009) TRIM(FNAME) -! - IF ( NDSG .EQ. NDSI ) THEN - IF ( IDFM .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSG - CALL EXTCDE (23) - ELSE - IF (.NOT.FLGNML) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - END IF - ELSE - IF ( IDFM .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& - form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, & - form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - END IF !IDFM - END IF !NDSG -! - CALL INA2R ( XGRDIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, VOF) -! -! 7.c.2.b Process y-coordinates -! - IF (FLGNML) THEN - NDSG = NML_CURV%YCOORD%IDF - VSC = NML_CURV%YCOORD%SF - VOF = NML_CURV%YCOORD%OFF - IDLA = NML_CURV%YCOORD%IDLA - IDFM = NML_CURV%YCOORD%IDFM - RFORM = TRIM(NML_CURV%YCOORD%FORMAT) - FROM = TRIM(NML_CURV%YCOORD%FROM) - FNAME = TRIM(NML_CURV%YCOORD%FILENAME) + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& + STATUS='OLD',ERR=2000,IOSTAT=IERR) ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSG, VSC, VOF, & - IDLA, IDFM, RFORM, FROM, FNAME + OPEN (NDSG, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) END IF -! - IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 - IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 -! - WRITE (NDSO,3007) NDSG, VSC, VOF, IDLA, IDFM - IF (IDFM.EQ.2) WRITE (NDSO,3008) TRIM(RFORM) - IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & - WRITE (NDSO,3009) TRIM(FNAME) -! - IF ( NDSG .EQ. NDSI ) THEN - IF ( IDFM .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSG - CALL EXTCDE (23) - ELSE - IF (.NOT.FLGNML) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - END IF - ELSE - IF ( IDFM .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& - form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, & - form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - END IF !IDFM - END IF !NDSG -! - CALL INA2R ( YGRDIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, VOF) -! -! 7.c.2.c Check for obvious errors in grid definition or input -! -! ....... Check for inverted grid (can result from wrong IDLA) - IF ( (XGRDIN(2,1)-XGRDIN(1,1))*(YGRDIN(1,2)-YGRDIN(1,1)) .LT. & - (YGRDIN(2,1)-YGRDIN(1,1))*(XGRDIN(1,2)-XGRDIN(1,1)) ) THEN - WRITE (NDSE,1011) IDLA -!.........Notes: here, we are checking to make sure that the j axis is ~90 degrees -!................counter-clockwise from the i axis (the standard cartesian setup). -!................So, it is a check on the handedness of the grid. -!................We have confirmed for one case that a left-handed grid produces -!................errors in SCRIP. We have not confirmed that left-handed grids necessarily -!................produce errors in single-grid simulations, or that they necessarily -!................produce errors in all multi-grid simulations. -!................Note that transposing or flipping a grid will generally change the handedness. - CALL EXTCDE (25) - END IF -! -! 7.c.3 Unstructured grid -! - CASE ( UNGTYPE ) -! - MAXX = 0. - MAXY = 0. - DXYMAX = 0. - WRITE (NDSO,1150) - - IF (FLGNML) THEN - ZLIM = NML_GRID%ZLIM - DMIN = NML_GRID%DMIN - NDSG = NML_UNST%IDF - VSC = NML_UNST%SF - IDLA = NML_UNST%IDLA - IDFM = NML_UNST%IDFM - RFORM = TRIM(NML_UNST%FORMAT) - FROM = 'NAME' - FNAME = TRIM(NML_UNST%FILENAME) - UGOBCFILE = TRIM(NML_UNST%UGOBCFILE) - END IF - END SELECT !GTYPE -! -! 7.d Depth information for grid -! + END IF !IDFM + END IF !NDSG + ! + CALL INA2R ( XGRDIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF) + ! + ! 7.c.2.b Process y-coordinates + ! IF (FLGNML) THEN - IF (GTYPE.NE.UNGTYPE) THEN - ZLIM = NML_GRID%ZLIM - DMIN = NML_GRID%DMIN - NDSG = NML_DEPTH%IDF - VSC = NML_DEPTH%SF - IDLA = NML_DEPTH%IDLA - IDFM = NML_DEPTH%IDFM - RFORM = TRIM(NML_DEPTH%FORMAT) - FROM = TRIM(NML_DEPTH%FROM) - FNAME = TRIM(NML_DEPTH%FILENAME) - END IF + NDSG = NML_CURV%YCOORD%IDF + VSC = NML_CURV%YCOORD%SF + VOF = NML_CURV%YCOORD%OFF + IDLA = NML_CURV%YCOORD%IDLA + IDFM = NML_CURV%YCOORD%IDFM + RFORM = TRIM(NML_CURV%YCOORD%FORMAT) + FROM = TRIM(NML_CURV%YCOORD%FROM) + FNAME = TRIM(NML_CURV%YCOORD%FILENAME) ELSE CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) ZLIM, DMIN, NDSG, VSC, IDLA, & - IDFM, RFORM, FROM, FNAME + READ (NDSI,*,END=2001,ERR=2002) NDSG, VSC, VOF, & + IDLA, IDFM, RFORM, FROM, FNAME END IF -! - DMIN = MAX ( 1.E-3 , DMIN ) - IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. + ! IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 -! - WRITE (NDSO,972) NDSG, ZLIM, DMIN, VSC, IDLA, IDFM - IF (IDFM.EQ.2) WRITE (NDSO,973) TRIM(RFORM) + ! + WRITE (NDSO,3007) NDSG, VSC, VOF, IDLA, IDFM + IF (IDFM.EQ.2) WRITE (NDSO,3008) TRIM(RFORM) IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & - WRITE (NDSO,974) TRIM(FNAME) -! -! 7.e Read bottom depths -! - IF ( GTYPE.NE.UNGTYPE ) THEN -! -! Reading depths on structured grid -! - ALLOCATE ( ZBIN(NX,NY), OBSX(NX,NY), OBSY(NX,NY) ) -! -! Initialize subgrid obstructions with zeros. - ZBIN(:,:)=0. - OBSX(:,:)=0. - OBSY(:,:)=0. - -!Li Suspended for SMC grid, which uses depth stored in its cell array. -!Li JGLi15Oct2014 - IF( GTYPE .NE. SMCTYPE ) THEN -! - IF ( NDSG .EQ. NDSI ) THEN - IF ( IDFM .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSG - CALL EXTCDE (23) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - ELSE ! NDSG.NE.NDSI - IF ( IDFM .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME), & - form='UNFORMATTED', convert=file_endian,& - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME), & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - END IF - END IF !( NDSG .EQ. NDSI ) -! - CALL INA2R ( ZBIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, 0.0) -! -!Li End of IF( GTYPE .NE. SMCTYPE ) block - ENDIF -! + WRITE (NDSO,3009) TRIM(FNAME) + ! + IF ( NDSG .EQ. NDSI ) THEN + IF ( IDFM .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSG + CALL EXTCDE (23) + ELSE + IF (.NOT.FLGNML) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + END IF ELSE -! -! Reading depths on unstructured grid (this also sets number of mesh points, NX) -! - CALL READMSH(NDSG,FNAME) - ALLOCATE(ZBIN(NX, NY),OBSX(NX,NY),OBSY(NX,NY)) - ZBIN(:,1) = VSC * ZB(:) -! -! subgrid obstructions are not yet handled in unstructured grids -! - OBSX(:,:)=0. - OBSY(:,:)=0. + IF ( IDFM .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& + form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSG, & + form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSG, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + END IF !IDFM + END IF !NDSG + ! + CALL INA2R ( YGRDIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF) + ! + ! 7.c.2.c Check for obvious errors in grid definition or input + ! + ! ....... Check for inverted grid (can result from wrong IDLA) + IF ( (XGRDIN(2,1)-XGRDIN(1,1))*(YGRDIN(1,2)-YGRDIN(1,1)) .LT. & + (YGRDIN(2,1)-YGRDIN(1,1))*(XGRDIN(1,2)-XGRDIN(1,1)) ) THEN + WRITE (NDSE,1011) IDLA + !.........Notes: here, we are checking to make sure that the j axis is ~90 degrees + !................counter-clockwise from the i axis (the standard cartesian setup). + !................So, it is a check on the handedness of the grid. + !................We have confirmed for one case that a left-handed grid produces + !................errors in SCRIP. We have not confirmed that left-handed grids necessarily + !................produce errors in single-grid simulations, or that they necessarily + !................produce errors in all multi-grid simulations. + !................Note that transposing or flipping a grid will generally change the handedness. + CALL EXTCDE (25) + END IF + ! + ! 7.c.3 Unstructured grid + ! + CASE ( UNGTYPE ) + ! + MAXX = 0. + MAXY = 0. + DXYMAX = 0. + WRITE (NDSO,1150) + IF (FLGNML) THEN + ZLIM = NML_GRID%ZLIM + DMIN = NML_GRID%DMIN + NDSG = NML_UNST%IDF + VSC = NML_UNST%SF + IDLA = NML_UNST%IDLA + IDFM = NML_UNST%IDFM + RFORM = TRIM(NML_UNST%FORMAT) + FROM = 'NAME' + FNAME = TRIM(NML_UNST%FILENAME) + UGOBCFILE = TRIM(NML_UNST%UGOBCFILE) END IF -! -! 7.f Set up temporary map -! - ALLOCATE ( TMPSTA(NY,NX), TMPMAP(NY,NX) ) - TMPSTA = 0 -! - IF (GTYPE .EQ. UNGTYPE) THEN - TMPSTA = 1 - ELSE - DO IY=1, NY - DO IX=1, NX - IF ( ZBIN(IX,IY) .LE. ZLIM ) TMPSTA(IY,IX) = 1 - END DO - END DO - ENDIF -! -!Li Suspended for SMC grid. JGLi15Oct2014 + END SELECT !GTYPE + ! + ! 7.d Depth information for grid + ! + IF (FLGNML) THEN + IF (GTYPE.NE.UNGTYPE) THEN + ZLIM = NML_GRID%ZLIM + DMIN = NML_GRID%DMIN + NDSG = NML_DEPTH%IDF + VSC = NML_DEPTH%SF + IDLA = NML_DEPTH%IDLA + IDFM = NML_DEPTH%IDFM + RFORM = TRIM(NML_DEPTH%FORMAT) + FROM = TRIM(NML_DEPTH%FROM) + FNAME = TRIM(NML_DEPTH%FILENAME) + END IF + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) ZLIM, DMIN, NDSG, VSC, IDLA, & + IDFM, RFORM, FROM, FNAME + END IF + ! + DMIN = MAX ( 1.E-3 , DMIN ) + IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 + ! + WRITE (NDSO,972) NDSG, ZLIM, DMIN, VSC, IDLA, IDFM + IF (IDFM.EQ.2) WRITE (NDSO,973) TRIM(RFORM) + IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & + WRITE (NDSO,974) TRIM(FNAME) + ! + ! 7.e Read bottom depths + ! + IF ( GTYPE.NE.UNGTYPE ) THEN + ! + ! Reading depths on structured grid + ! + ALLOCATE ( ZBIN(NX,NY), OBSX(NX,NY), OBSY(NX,NY) ) + ! + ! Initialize subgrid obstructions with zeros. + ZBIN(:,:)=0. + OBSX(:,:)=0. + OBSY(:,:)=0. + + !Li Suspended for SMC grid, which uses depth stored in its cell array. + !Li JGLi15Oct2014 IF( GTYPE .NE. SMCTYPE ) THEN -! -! 7.g Subgrid information -! + ! + IF ( NDSG .EQ. NDSI ) THEN + IF ( IDFM .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSG + CALL EXTCDE (23) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + ELSE ! NDSG.NE.NDSI + IF ( IDFM .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME), & + form='UNFORMATTED', convert=file_endian,& + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSG, form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME), & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSG, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + END IF + END IF !( NDSG .EQ. NDSI ) + ! + CALL INA2R ( ZBIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, 0.0) + ! + !Li End of IF( GTYPE .NE. SMCTYPE ) block + ENDIF + ! + ELSE + ! + ! Reading depths on unstructured grid (this also sets number of mesh points, NX) + ! + CALL READMSH(NDSG,FNAME) + ALLOCATE(ZBIN(NX, NY),OBSX(NX,NY),OBSY(NX,NY)) + ZBIN(:,1) = VSC * ZB(:) + ! + ! subgrid obstructions are not yet handled in unstructured grids + ! + OBSX(:,:)=0. + OBSY(:,:)=0. + + END IF + ! + ! 7.f Set up temporary map + ! + ALLOCATE ( TMPSTA(NY,NX), TMPMAP(NY,NX) ) + TMPSTA = 0 + ! + IF (GTYPE .EQ. UNGTYPE) THEN + TMPSTA = 1 + ELSE + DO IY=1, NY + DO IX=1, NX + IF ( ZBIN(IX,IY) .LE. ZLIM ) TMPSTA(IY,IX) = 1 + END DO + END DO + ENDIF + ! + !Li Suspended for SMC grid. JGLi15Oct2014 + IF( GTYPE .NE. SMCTYPE ) THEN + ! + ! 7.g Subgrid information + ! TRFLAG = FLAGTR IF ( TRFLAG.GT.6 .OR. TRFLAG.LT.0 ) TRFLAG = 0 -! + ! IF ( TRFLAG .EQ. 0 ) THEN WRITE (NDSO,976) 'Not available.' ELSE IF ( TRFLAG.EQ.1 .OR. TRFLAG.EQ.3 .OR. TRFLAG.EQ.5 ) THEN @@ -4009,11 +3976,11 @@ SUBROUTINE W3GRID() ELSE WRITE (NDSO,976) 'At grid points.' END IF -! + ! IF ( TRFLAG .NE. 0 ) THEN -! -! 7.g.1 Info from input file -! + ! + ! 7.g.1 Info from input file + ! IF (FLGNML) THEN NDSTR = NML_OBST%IDF VSC = NML_OBST%SF @@ -4025,19 +3992,19 @@ SUBROUTINE W3GRID() ELSE CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & - FROM, TNAME + FROM, TNAME END IF -! + ! IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 -! + ! WRITE (NDSO,977) NDSTR, VSC, IDLA, IDFT IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME -! -! 7.g.2 Open file and check if necessary -! + ! + ! 7.g.2 Open file and check if necessary + ! IF ( NDSTR .EQ. NDSI ) THEN IF ( IDFT .EQ. 3 ) THEN WRITE (NDSE,1004) NDSTR @@ -4055,976 +4022,966 @@ SUBROUTINE W3GRID() IF ( IDFT .EQ. 3 ) THEN IF (FROM.EQ.'NAME') THEN OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=2000, & - IOSTAT=IERR) + form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=2000, & + IOSTAT=IERR) ELSE OPEN (NDSTR, form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) + STATUS='OLD',ERR=2000,IOSTAT=IERR) END IF ELSE IF (FROM.EQ.'NAME') THEN OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) + STATUS='OLD',ERR=2000,IOSTAT=IERR) ELSE OPEN (NDSTR, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) + STATUS='OLD',ERR=2000,IOSTAT=IERR) END IF END IF END IF -! -! 7.g.3 Read the data -! + ! + ! 7.g.3 Read the data + ! CALL INA2R ( OBSX, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & - IDFT, RFORM, IDLA, VSC, 0.0) -! + IDFT, RFORM, IDLA, VSC, 0.0) + ! IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) -! + ! CALL INA2R ( OBSY, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & - IDFT, RFORM, IDLA, VSC, 0.0) -! -! 7.g.4 Limit -! + IDFT, RFORM, IDLA, VSC, 0.0) + ! + ! 7.g.4 Limit + ! DO IX=1, NX DO IY=1, NY OBSX(IX,IY) = MAX( 0. , MIN(1.,OBSX(IX,IY)) ) OBSY(IX,IY) = MAX( 0. , MIN(1.,OBSY(IX,IY)) ) END DO END DO -! + ! WRITE (NDSO,*) -! + ! END IF ! TRFLAG -! -!Li End of IF( GTYPE .NE. SMCTYPE ) block - END IF -! + ! + !Li End of IF( GTYPE .NE. SMCTYPE ) block + END IF + ! #ifdef W3_RTD - ! 7.h Calculate rotation angles for configs with rotated pole - PoLon = PLON - PoLat = PLAT - FLAGUNR = UNROT - ! Default values PLON=-180, PLAT=90, UNROT=.FALSE. for standard lat-lon - - ALLOCATE( AnglDin(NX,NY) ) - ! For standard lat-lon the rotation angles are zero - IF ( PoLat == 90. ) THEN - AnglDin = 0. - ELSE - ALLOCATE(StdLat(NX,NY), StdLon(NX,NY)) - - ! Calculate rotation angles; (StdLon/Lat are returned, but not used) - ! The regular grid X/YGRDIN are used as equatorial lon and lat - CALL W3EQTOLL( YGRDIN, XGRDIN, StdLat, StdLon, AnglDin, & - PoLat, PoLon, NX*NY ) - - ! Clean up - DEALLOCATE( StdLat, StdLon ) - END IF - ! Write out rotation information - WRITE (NDSO,4203) PoLat, PoLon - WRITE (NDSO,4200) - WRITE (NDSO,4201) ( IX, IX=1,NX,NX/3) - WRITE (NDSO,4202) 1,(AnglDin(IX, 1), IX=1,NX,NX/3) - WRITE (NDSO,4202) NY,(AnglDin(IX,NY), IX=1,NX,NX/3) - IF ( FLAGUNR ) WRITE (NDSO,4204) - WRITE (NDSO,*) ' ' - -#endif -! -#ifdef W3_SMC - !! 7.i Read SMC grid cell and face integer arrays. - IF( GTYPE .EQ. SMCTYPE ) THEN + ! 7.h Calculate rotation angles for configs with rotated pole + PoLon = PLON + PoLat = PLAT + FLAGUNR = UNROT + ! Default values PLON=-180, PLAT=90, UNROT=.FALSE. for standard lat-lon + + ALLOCATE( AnglDin(NX,NY) ) + ! For standard lat-lon the rotation angles are zero + IF ( PoLat == 90. ) THEN + AnglDin = 0. + ELSE + ALLOCATE(StdLat(NX,NY), StdLon(NX,NY)) + + ! Calculate rotation angles; (StdLon/Lat are returned, but not used) + ! The regular grid X/YGRDIN are used as equatorial lon and lat + CALL W3EQTOLL( YGRDIN, XGRDIN, StdLat, StdLon, AnglDin, & + PoLat, PoLon, NX*NY ) + + ! Clean up + DEALLOCATE( StdLat, StdLon ) + END IF + ! Write out rotation information + WRITE (NDSO,4203) PoLat, PoLon + WRITE (NDSO,4200) + WRITE (NDSO,4201) ( IX, IX=1,NX,NX/3) + WRITE (NDSO,4202) 1,(AnglDin(IX, 1), IX=1,NX,NX/3) + WRITE (NDSO,4202) NY,(AnglDin(IX,NY), IX=1,NX,NX/3) + IF ( FLAGUNR ) WRITE (NDSO,4204) + WRITE (NDSO,*) ' ' - !! Overwrite 2 parameters for SMC grid. JGLi03Mar2021 - DTMS = DTIMS - CTMAX = CFLSM #endif -! + ! #ifdef W3_SMC - IF (FLGNML) THEN - NDSTR = NML_SMC%MCELS%IDF - IDLA = NML_SMC%MCELS%IDLA - IDFM = NML_SMC%MCELS%IDFM - RFORM = TRIM(NML_SMC%MCELS%FORMAT) - TNAME = TRIM(NML_SMC%MCELS%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME - END IF - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - FORM='FORMATTED',STATUS='OLD',ERR=2000) - ALLOCATE ( NLvCelsk( 0:NRLv ) ) - READ (NDSTR,*) NLvCelsk - NCel=NLvCelsk(0) - NGLO=NCel - WRITE (NDSO,4004) NCel, NLvCelsk - - ALLOCATE ( IJKCelin( 5, NCel)) - CALL INA2I ( IJKCelin, 5, NCel, 1, 5, 1, NCel, NDSTR, NDST, NDSE, & - IDFM, RFORM, IDLA, 1, 0) - CLOSE(NDSTR) - !!Li Offset to change Equator index = 0 to regular grid index JEQT - IJKCelin( 2, :) = IJKCelin( 2, :) + JEQT - !!Li Offset to change i-index = 0 to regular grid index ISHFT - IJKCelin( 1, :) = IJKCelin( 1, :) + ISHFT - - WRITE (NDSO,4005) TNAME - WRITE (NDSO,4006) 1,(IJKCelin(ix, 1), ix=1,5) - WRITE (NDSO,4006) NCel,(IJKCelin(ix, NCel), ix=1,5) - WRITE (NDSO,*) ' ' - - IF (FLGNML) THEN - NDSTR = NML_SMC%ISIDE%IDF - IDLA = NML_SMC%ISIDE%IDLA - IDFM = NML_SMC%ISIDE%IDFM - RFORM = TRIM(NML_SMC%ISIDE%FORMAT) - TNAME = TRIM(NML_SMC%ISIDE%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME - END IF - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - FORM='FORMATTED',STATUS='OLD',ERR=2000) - ALLOCATE ( NLvUFcsk( 0:NRLv ) ) - READ (NDSTR,*) NLvUFcsk - NUFc = NLvUFcsk(0) - NGUI = NUFc - WRITE (NDSO,4007) NUFc, NLvUFcsk - - ALLOCATE ( IJKUFcin( 7, NUFc) ) - CALL INA2I ( IJKUFcin, 7, NUFc, 1, 7, 1, NUFc, NDSTR, NDST, NDSE, & - IDFM, RFORM, IDLA, 1, 0) - CLOSE(NDSTR) - !!Li Offset to change Equator index = 0 to regular grid index - IJKUFcin( 2, :) = IJKUFcin( 2, :) + JEQT - IJKUFcin( 1, :) = IJKUFcin( 1, :) + ISHFT - - WRITE (NDSO,4008) TNAME - WRITE (NDSO,4009) 1,(IJKUFcin(ix, 1), ix=1,7) - WRITE (NDSO,4009) NUFc,(IJKUFcin(ix, NUFc), ix=1,7) - WRITE (NDSO,*) ' ' - - IF (FLGNML) THEN - NDSTR = NML_SMC%JSIDE%IDF - IDLA = NML_SMC%JSIDE%IDLA - IDFM = NML_SMC%JSIDE%IDFM - RFORM = TRIM(NML_SMC%JSIDE%FORMAT) - TNAME = TRIM(NML_SMC%JSIDE%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME - END IF - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - FORM='FORMATTED',STATUS='OLD',ERR=2000) - ALLOCATE ( NLvVFcsk( 0:NRLv ) ) - READ (NDSTR,*) NLvVFcsk - NVFc= NLvVFcsk(0) - NGVJ= NVFc - WRITE (NDSO,4010) NVFc, NLvVFcsk - - ALLOCATE ( IJKVFcin( 8, NVFc) ) - CALL INA2I ( IJKVFcin, 8, NVFc, 1, 8, 1, NVFc, NDSTR, NDST, NDSE, & - IDFM, RFORM, IDLA, 1, 0) - CLOSE(NDSTR) - !!Li Offset to change Equator index = 0 to regular grid index - IJKVFcin( 2, :) = IJKVFcin( 2, :) + JEQT - IJKVFcin( 1, :) = IJKVFcin( 1, :) + ISHFT - - WRITE (NDSO,4011) TNAME - WRITE (NDSO,4012) 1,(IJKVFcin(ix, 1), ix=1,8) - WRITE (NDSO,4012) NVFc,(IJKVFcin(ix, NVFc), ix=1,8) - WRITE (NDSO,*) ' ' - - !!Li Subgrid obstruction for each SMCels. JGLi15Oct2014 - IF (FLGNML) THEN - NDSTR = NML_SMC%SUBTR%IDF - IDLA = NML_SMC%SUBTR%IDLA - IDFM = NML_SMC%SUBTR%IDFM - RFORM = TRIM(NML_SMC%SUBTR%FORMAT) - TNAME = TRIM(NML_SMC%SUBTR%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME - END IF - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - FORM='FORMATTED',STATUS='OLD',ERR=2000) - READ (NDSTR,*) NCObst, JObs - WRITE (NDSO,4110) NCObst, JObs - - ALLOCATE ( IJKObstr( JObs, NCObst) ) - CALL INA2I ( IJKObstr, JObs, NCObst, 1, JObs, 1, NCObst, NDSTR, NDST, & - NDSE, IDFM, RFORM, IDLA, 1, 0) - CLOSE(NDSTR) - - WRITE (NDSO,4111) TNAME - WRITE (NDSO,4012) 1, (IJKObstr(ix, 1), ix=1,JObs) - WRITE (NDSO,4012) NCObst, (IJKObstr(ix, NCObst), ix=1,JObs) - WRITE (NDSO,*) ' ' - - !!Li Bounary cell sequential numbers are read only if NBISMC>0 - IF( NBISMC .GT. 0 ) THEN - IF (FLGNML) THEN - NDSTR = NML_SMC%BUNDY%IDF - IDLA = NML_SMC%BUNDY%IDLA - IDFM = NML_SMC%BUNDY%IDFM - RFORM = TRIM(NML_SMC%BUNDY%FORMAT) - TNAME = TRIM(NML_SMC%BUNDY%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME - END IF - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - FORM='FORMATTED',STATUS='OLD',ERR=2000) - ALLOCATE ( NBICelin( NBISMC ) ) - CALL INA2I ( NBICelin, 1, NBISMC, 1, 1, 1, NBISMC, NDSTR, NDST, & - NDSE, IDFM, RFORM, IDLA, 1, 0) - CLOSE(NDSTR) - - WRITE (NDSO,4013) TNAME - WRITE (NDSO,4014) 1, NBICelin( 1) - WRITE (NDSO,4014) NBISMC, NBICelin(NBISMC) - WRITE (NDSO,*) ' ' - ENDIF - -#endif -! -#ifdef W3_SMC - !! 7.j Read Arctic grid cell and boundary cell integer arrays. - IF( ARCTC ) THEN - - IF (FLGNML) THEN - NDSTR = NML_SMC%MBARC%IDF - IDLA = NML_SMC%MBARC%IDLA - IDFM = NML_SMC%MBARC%IDFM - RFORM = TRIM(NML_SMC%MBARC%FORMAT) - TNAME = TRIM(NML_SMC%MBARC%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME - END IF - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - FORM='FORMATTED',STATUS='OLD',ERR=2000) - READ (NDSTR,*) NARC, NBGL, NBAC - WRITE (NDSO,4015) NARC, NBGL, NBAC - - ALLOCATE ( IJKCelAC( 5, NARC) ) - CALL INA2I ( IJKCelAC, 5, NARC, 1, 5, 1, NARC, NDSTR, NDST, NDSE, & - IDFM, RFORM, IDLA, 1, 0) - CLOSE(NDSTR) - !!Li Offset to change Equator index = 0 to regular grid index JEQT - IJKCelAC( 2, :) = IJKCelAC( 2, :) + JEQT - IJKCelAC( 1, :) = IJKCelAC( 1, :) + ISHFT - - WRITE (NDSO,4016) TNAME - WRITE (NDSO,4006) 1,(IJKCelAC(ix, 1), ix=1,5) - WRITE (NDSO,4006) NARC,(IJKCelAC(ix, NARC), ix=1,5) - WRITE (NDSO,*) ' ' - - IF (FLGNML) THEN - NDSTR = NML_SMC%AISID%IDF - IDLA = NML_SMC%AISID%IDLA - IDFM = NML_SMC%AISID%IDFM - RFORM = TRIM(NML_SMC%AISID%FORMAT) - TNAME = TRIM(NML_SMC%AISID%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME - END IF - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - FORM='FORMATTED',STATUS='OLD',ERR=2000) - READ (NDSTR,*) NAUI - WRITE (NDSO,4017) NAUI - - ALLOCATE ( IJKUFcAC( 7, NAUI) ) - CALL INA2I ( IJKUFcAC, 7, NAUI, 1, 7, 1, NAUI, NDSTR, NDST, NDSE, & - IDFM, RFORM, IDLA, 1, 0) - CLOSE(NDSTR) - !!Li Offset to change Equator index = 0 to regular grid index - IJKUFcAC( 2, :) = IJKUFcAC( 2, :) + JEQT - IJKUFcAC( 1, :) = IJKUFcAC( 1, :) + ISHFT - !!Li Offset Arctic cell sequential numbers by global cell number NGLO - DO IP=1, NAUI - DO IX=4,7 - IF( IJKUFcAC(IX,IP) > 0 ) IJKUFcAC(IX,IP) = IJKUFcAC(IX,IP) + NGLO - ENDDO - ENDDO - - WRITE (NDSO,4018) TNAME - WRITE (NDSO,4009) 1,(IJKUFcAC(ix, 1), ix=1,7) - WRITE (NDSO,4009) NAUI,(IJKUFcAC(ix, NAUI), ix=1,7) - WRITE (NDSO,*) ' ' - - IF (FLGNML) THEN - NDSTR = NML_SMC%AJSID%IDF - IDLA = NML_SMC%AJSID%IDLA - IDFM = NML_SMC%AJSID%IDFM - RFORM = TRIM(NML_SMC%AJSID%FORMAT) - TNAME = TRIM(NML_SMC%AJSID%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME - END IF - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - FORM='FORMATTED',STATUS='OLD',ERR=2000) - READ (NDSTR,*) NAVJ - WRITE (NDSO,4019) NAVJ - - ALLOCATE ( IJKVFcAC( 8, NAVJ) ) - CALL INA2I ( IJKVFcAC, 8, NAVJ, 1, 8, 1, NAVJ, NDSTR, NDST, NDSE, & - IDFM, RFORM, IDLA, 1, 0) - CLOSE(NDSTR) - !!Li Offset to change Equator index = 0 to regular grid index - IJKVFcAC( 2, :) = IJKVFcAC( 2, :) + JEQT - IJKVFcAC( 1, :) = IJKVFcAC( 1, :) + ISHFT - !!Li Offset Arctic cell sequential numbers by global cell number NGLO - DO IP=1, NAVJ - DO IY=4,7 - IF( IJKVFcAC(IY,IP) > 0 ) IJKVFcAC(IY,IP) = IJKVFcAC(IY,IP) + NGLO - ENDDO - ENDDO - - WRITE (NDSO,4020) TNAME - WRITE (NDSO,4012) 1,(IJKVFcAC(ix, 1), ix=1,8) - WRITE (NDSO,4012) NAVJ,(IJKVFcAC(ix, NAVJ), ix=1,8) - WRITE (NDSO,*) ' ' - - !!Li Reset total cell and face numbers - NCel = NGLO + NARC - NUFc = NGUI + NAUI - NVFc = NGVJ + NAVJ - !!Li Also append Arctic part into base level sub-loops - NLvCelsk(NRLv)=NLvCelsk(NRLv)+NARC - NLvUFcsk(NRLv)=NLvUFcsk(NRLv)+NAUI - NLvVFcsk(NRLv)=NLvVFcsk(NRLv)+NAVJ - !!Li Reset NBAC to total number of boundary cells. - NBAC = NBGL + NBAC - - ENDIF !! ARCTC section. - - ENDIF !! GTYPE .EQ. SMCTYPE -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 8. Finalize status maps -! 8.a Defines open boundary conditions for UNST grids -! - J = LEN_TRIM(UGOBCFILE) - IF (GTYPE.EQ.UNGTYPE.AND.UGOBCFILE(:J).NE.'unset') & - CALL READMSHOBC(NDSG,UGOBCFILE,TMPSTA,UGOBCOK) - IF ((GTYPE.EQ.UNGTYPE).AND.UGOBCAUTO.AND.(.NOT.UGOBCOK)) & - CALL UG_GETOPENBOUNDARY(TMPSTA,ZBIN,UGOBCDEPTH) -! -! 8.b Determine where to get the data -! + !! 7.i Read SMC grid cell and face integer arrays. + IF( GTYPE .EQ. SMCTYPE ) THEN + + !! Overwrite 2 parameters for SMC grid. JGLi03Mar2021 + DTMS = DTIMS + CTMAX = CFLSM + ! IF (FLGNML) THEN - NDSTR = NML_MASK%IDF - IDLA = NML_MASK%IDLA - IDFT = NML_MASK%IDFM - RFORM = TRIM(NML_MASK%FORMAT) - FROM = TRIM(NML_MASK%FROM) - TNAME = TRIM(NML_MASK%FILENAME) - IF (TNAME.EQ.'unset' .OR. TNAME.EQ.'UNSET') FROM='PART' - ELSE + NDSTR = NML_SMC%MCELS%IDF + IDLA = NML_SMC%MCELS%IDLA + IDFM = NML_SMC%MCELS%IDFM + RFORM = TRIM(NML_SMC%MCELS%FORMAT) + TNAME = TRIM(NML_SMC%MCELS%FILENAME) + ELSE CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFT, RFORM, & - FROM, TNAME + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME END IF -! -! ... Data to be read in parts -! - IF ( FROM .EQ. 'PART' ) THEN -! -! 8.b Update TMPSTA with input boundary data (ILOOP=1) -! and excluded points (ILOOP=2) -! - IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN - WRITE(NDSE,*)'PROGRAM W3GRID STATUS MAP CALCULATION IS '// & - 'NOT TESTED FOR TRIPOLE GRIDS FOR CASE WHERE USER OPTS '// & - 'TO READ DATA IN PARTS. STOPPING NOW (107).' - CALL EXTCDE ( 107 ) + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + ALLOCATE ( NLvCelsk( 0:NRLv ) ) + READ (NDSTR,*) NLvCelsk + NCel=NLvCelsk(0) + NGLO=NCel + WRITE (NDSO,4004) NCel, NLvCelsk + + ALLOCATE ( IJKCelin( 5, NCel)) + CALL INA2I ( IJKCelin, 5, NCel, 1, 5, 1, NCel, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index JEQT + IJKCelin( 2, :) = IJKCelin( 2, :) + JEQT + !!Li Offset to change i-index = 0 to regular grid index ISHFT + IJKCelin( 1, :) = IJKCelin( 1, :) + ISHFT + + WRITE (NDSO,4005) TNAME + WRITE (NDSO,4006) 1,(IJKCelin(ix, 1), ix=1,5) + WRITE (NDSO,4006) NCel,(IJKCelin(ix, NCel), ix=1,5) + WRITE (NDSO,*) ' ' + + IF (FLGNML) THEN + NDSTR = NML_SMC%ISIDE%IDF + IDLA = NML_SMC%ISIDE%IDLA + IDFM = NML_SMC%ISIDE%IDFM + RFORM = TRIM(NML_SMC%ISIDE%FORMAT) + TNAME = TRIM(NML_SMC%ISIDE%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + ALLOCATE ( NLvUFcsk( 0:NRLv ) ) + READ (NDSTR,*) NLvUFcsk + NUFc = NLvUFcsk(0) + NGUI = NUFc + WRITE (NDSO,4007) NUFc, NLvUFcsk + + ALLOCATE ( IJKUFcin( 7, NUFc) ) + CALL INA2I ( IJKUFcin, 7, NUFc, 1, 7, 1, NUFc, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index + IJKUFcin( 2, :) = IJKUFcin( 2, :) + JEQT + IJKUFcin( 1, :) = IJKUFcin( 1, :) + ISHFT + + WRITE (NDSO,4008) TNAME + WRITE (NDSO,4009) 1,(IJKUFcin(ix, 1), ix=1,7) + WRITE (NDSO,4009) NUFc,(IJKUFcin(ix, NUFc), ix=1,7) + WRITE (NDSO,*) ' ' + + IF (FLGNML) THEN + NDSTR = NML_SMC%JSIDE%IDF + IDLA = NML_SMC%JSIDE%IDLA + IDFM = NML_SMC%JSIDE%IDFM + RFORM = TRIM(NML_SMC%JSIDE%FORMAT) + TNAME = TRIM(NML_SMC%JSIDE%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + ALLOCATE ( NLvVFcsk( 0:NRLv ) ) + READ (NDSTR,*) NLvVFcsk + NVFc= NLvVFcsk(0) + NGVJ= NVFc + WRITE (NDSO,4010) NVFc, NLvVFcsk + + ALLOCATE ( IJKVFcin( 8, NVFc) ) + CALL INA2I ( IJKVFcin, 8, NVFc, 1, 8, 1, NVFc, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index + IJKVFcin( 2, :) = IJKVFcin( 2, :) + JEQT + IJKVFcin( 1, :) = IJKVFcin( 1, :) + ISHFT + + WRITE (NDSO,4011) TNAME + WRITE (NDSO,4012) 1,(IJKVFcin(ix, 1), ix=1,8) + WRITE (NDSO,4012) NVFc,(IJKVFcin(ix, NVFc), ix=1,8) + WRITE (NDSO,*) ' ' + + !!Li Subgrid obstruction for each SMCels. JGLi15Oct2014 + IF (FLGNML) THEN + NDSTR = NML_SMC%SUBTR%IDF + IDLA = NML_SMC%SUBTR%IDLA + IDFM = NML_SMC%SUBTR%IDFM + RFORM = TRIM(NML_SMC%SUBTR%FORMAT) + TNAME = TRIM(NML_SMC%SUBTR%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + READ (NDSTR,*) NCObst, JObs + WRITE (NDSO,4110) NCObst, JObs + + ALLOCATE ( IJKObstr( JObs, NCObst) ) + CALL INA2I ( IJKObstr, JObs, NCObst, 1, JObs, 1, NCObst, NDSTR, NDST, & + NDSE, IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + + WRITE (NDSO,4111) TNAME + WRITE (NDSO,4012) 1, (IJKObstr(ix, 1), ix=1,JObs) + WRITE (NDSO,4012) NCObst, (IJKObstr(ix, NCObst), ix=1,JObs) + WRITE (NDSO,*) ' ' + + !!Li Bounary cell sequential numbers are read only if NBISMC>0 + IF( NBISMC .GT. 0 ) THEN + IF (FLGNML) THEN + NDSTR = NML_SMC%BUNDY%IDF + IDLA = NML_SMC%BUNDY%IDLA + IDFM = NML_SMC%BUNDY%IDFM + RFORM = TRIM(NML_SMC%BUNDY%FORMAT) + TNAME = TRIM(NML_SMC%BUNDY%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME END IF - DO ILOOP=1, 2 -! - I = 1 - IF ( ILOOP .EQ. 1 ) THEN - WRITE (NDSO,979) 'boundary points' - NSTAT = 2 + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + ALLOCATE ( NBICelin( NBISMC ) ) + CALL INA2I ( NBICelin, 1, NBISMC, 1, 1, 1, NBISMC, NDSTR, NDST, & + NDSE, IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + + WRITE (NDSO,4013) TNAME + WRITE (NDSO,4014) 1, NBICelin( 1) + WRITE (NDSO,4014) NBISMC, NBICelin(NBISMC) + WRITE (NDSO,*) ' ' + ENDIF + ! + !! 7.j Read Arctic grid cell and boundary cell integer arrays. + IF( ARCTC ) THEN + + IF (FLGNML) THEN + NDSTR = NML_SMC%MBARC%IDF + IDLA = NML_SMC%MBARC%IDLA + IDFM = NML_SMC%MBARC%IDFM + RFORM = TRIM(NML_SMC%MBARC%FORMAT) + TNAME = TRIM(NML_SMC%MBARC%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + READ (NDSTR,*) NARC, NBGL, NBAC + WRITE (NDSO,4015) NARC, NBGL, NBAC + + ALLOCATE ( IJKCelAC( 5, NARC) ) + CALL INA2I ( IJKCelAC, 5, NARC, 1, 5, 1, NARC, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index JEQT + IJKCelAC( 2, :) = IJKCelAC( 2, :) + JEQT + IJKCelAC( 1, :) = IJKCelAC( 1, :) + ISHFT + + WRITE (NDSO,4016) TNAME + WRITE (NDSO,4006) 1,(IJKCelAC(ix, 1), ix=1,5) + WRITE (NDSO,4006) NARC,(IJKCelAC(ix, NARC), ix=1,5) + WRITE (NDSO,*) ' ' + + IF (FLGNML) THEN + NDSTR = NML_SMC%AISID%IDF + IDLA = NML_SMC%AISID%IDLA + IDFM = NML_SMC%AISID%IDFM + RFORM = TRIM(NML_SMC%AISID%FORMAT) + TNAME = TRIM(NML_SMC%AISID%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + READ (NDSTR,*) NAUI + WRITE (NDSO,4017) NAUI + + ALLOCATE ( IJKUFcAC( 7, NAUI) ) + CALL INA2I ( IJKUFcAC, 7, NAUI, 1, 7, 1, NAUI, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index + IJKUFcAC( 2, :) = IJKUFcAC( 2, :) + JEQT + IJKUFcAC( 1, :) = IJKUFcAC( 1, :) + ISHFT + !!Li Offset Arctic cell sequential numbers by global cell number NGLO + DO IP=1, NAUI + DO IX=4,7 + IF( IJKUFcAC(IX,IP) > 0 ) IJKUFcAC(IX,IP) = IJKUFcAC(IX,IP) + NGLO + ENDDO + ENDDO + + WRITE (NDSO,4018) TNAME + WRITE (NDSO,4009) 1,(IJKUFcAC(ix, 1), ix=1,7) + WRITE (NDSO,4009) NAUI,(IJKUFcAC(ix, NAUI), ix=1,7) + WRITE (NDSO,*) ' ' + + IF (FLGNML) THEN + NDSTR = NML_SMC%AJSID%IDF + IDLA = NML_SMC%AJSID%IDLA + IDFM = NML_SMC%AJSID%IDFM + RFORM = TRIM(NML_SMC%AJSID%FORMAT) + TNAME = TRIM(NML_SMC%AJSID%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + READ (NDSTR,*) NAVJ + WRITE (NDSO,4019) NAVJ + + ALLOCATE ( IJKVFcAC( 8, NAVJ) ) + CALL INA2I ( IJKVFcAC, 8, NAVJ, 1, 8, 1, NAVJ, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index + IJKVFcAC( 2, :) = IJKVFcAC( 2, :) + JEQT + IJKVFcAC( 1, :) = IJKVFcAC( 1, :) + ISHFT + !!Li Offset Arctic cell sequential numbers by global cell number NGLO + DO IP=1, NAVJ + DO IY=4,7 + IF( IJKVFcAC(IY,IP) > 0 ) IJKVFcAC(IY,IP) = IJKVFcAC(IY,IP) + NGLO + ENDDO + ENDDO + + WRITE (NDSO,4020) TNAME + WRITE (NDSO,4012) 1,(IJKVFcAC(ix, 1), ix=1,8) + WRITE (NDSO,4012) NAVJ,(IJKVFcAC(ix, NAVJ), ix=1,8) + WRITE (NDSO,*) ' ' + + !!Li Reset total cell and face numbers + NCel = NGLO + NARC + NUFc = NGUI + NAUI + NVFc = NGVJ + NAVJ + !!Li Also append Arctic part into base level sub-loops + NLvCelsk(NRLv)=NLvCelsk(NRLv)+NARC + NLvUFcsk(NRLv)=NLvUFcsk(NRLv)+NAUI + NLvVFcsk(NRLv)=NLvVFcsk(NRLv)+NAVJ + !!Li Reset NBAC to total number of boundary cells. + NBAC = NBGL + NBAC + + ENDIF !! ARCTC section. + + ENDIF !! GTYPE .EQ. SMCTYPE +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 8. Finalize status maps + ! 8.a Defines open boundary conditions for UNST grids + ! + J = LEN_TRIM(UGOBCFILE) + IF (GTYPE.EQ.UNGTYPE.AND.UGOBCFILE(:J).NE.'unset') & + CALL READMSHOBC(NDSG,UGOBCFILE,TMPSTA,UGOBCOK) + IF ((GTYPE.EQ.UNGTYPE).AND.UGOBCAUTO.AND.(.NOT.UGOBCOK)) & + CALL UG_GETOPENBOUNDARY(TMPSTA,ZBIN,UGOBCDEPTH) + ! + ! 8.b Determine where to get the data + ! + IF (FLGNML) THEN + NDSTR = NML_MASK%IDF + IDLA = NML_MASK%IDLA + IDFT = NML_MASK%IDFM + RFORM = TRIM(NML_MASK%FORMAT) + FROM = TRIM(NML_MASK%FROM) + TNAME = TRIM(NML_MASK%FILENAME) + IF (TNAME.EQ.'unset' .OR. TNAME.EQ.'UNSET') FROM='PART' + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFT, RFORM, & + FROM, TNAME + END IF + ! + ! ... Data to be read in parts + ! + IF ( FROM .EQ. 'PART' ) THEN + ! + ! 8.b Update TMPSTA with input boundary data (ILOOP=1) + ! and excluded points (ILOOP=2) + ! + IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN + WRITE(NDSE,*)'PROGRAM W3GRID STATUS MAP CALCULATION IS '// & + 'NOT TESTED FOR TRIPOLE GRIDS FOR CASE WHERE USER OPTS '// & + 'TO READ DATA IN PARTS. STOPPING NOW (107).' + CALL EXTCDE ( 107 ) + END IF + DO ILOOP=1, 2 + ! + I = 1 + IF ( ILOOP .EQ. 1 ) THEN + WRITE (NDSO,979) 'boundary points' + NSTAT = 2 + ELSE + WRITE (NDSO,979) 'excluded points' + NSTAT = -1 + END IF + FIRST = .TRUE. + ! + DO + IF (FLGNML) THEN + ! inbound points + IF (ILOOP.EQ.1) THEN + IF (NML_INBND_COUNT%N_POINT.GT.0 .AND. I.LE.NML_INBND_COUNT%N_POINT) THEN + IX = NML_INBND_POINT(I)%X_INDEX + IY = NML_INBND_POINT(I)%Y_INDEX + CONNCT = NML_INBND_POINT(I)%CONNECT + I=I+1 + ELSE + EXIT + END IF + ! excluded points + ELSE IF (ILOOP.EQ.2) THEN + IF (NML_EXCL_COUNT%N_POINT.GT.0 .AND. I.LE.NML_EXCL_COUNT%N_POINT) THEN + IX = NML_EXCL_POINT(I)%X_INDEX + IY = NML_EXCL_POINT(I)%Y_INDEX + CONNCT = NML_EXCL_POINT(I)%CONNECT + I=I+1 + ELSE + EXIT + END IF + END IF ELSE - WRITE (NDSO,979) 'excluded points' - NSTAT = -1 + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) IX, IY, CONNCT END IF - FIRST = .TRUE. -! - DO - IF (FLGNML) THEN - ! inbound points - IF (ILOOP.EQ.1) THEN - IF (NML_INBND_COUNT%N_POINT.GT.0 .AND. I.LE.NML_INBND_COUNT%N_POINT) THEN - IX = NML_INBND_POINT(I)%X_INDEX - IY = NML_INBND_POINT(I)%Y_INDEX - CONNCT = NML_INBND_POINT(I)%CONNECT - I=I+1 - ELSE - EXIT - END IF - ! excluded points - ELSE IF (ILOOP.EQ.2) THEN - IF (NML_EXCL_COUNT%N_POINT.GT.0 .AND. I.LE.NML_EXCL_COUNT%N_POINT) THEN - IX = NML_EXCL_POINT(I)%X_INDEX - IY = NML_EXCL_POINT(I)%Y_INDEX - CONNCT = NML_EXCL_POINT(I)%CONNECT - I=I+1 + ! + ! ... Check if last point reached. + ! + IF (IX.EQ.0 .AND. IY.EQ.0) EXIT + ! + ! ... Check if point in grid. + ! + IF (GTYPE.EQ.UNGTYPE.AND.(UGOBCAUTO.OR.UGOBCOK)) CYCLE + IF (IX.LT.1 .OR. IX.GT.NX .OR. IY.LT.1 .OR. IY.GT.NY) THEN + WRITE (NDSO,981) + WRITE (NDSO,*) ' ', IX, IY + CYCLE + END IF + ! + ! ... Check if intermediate points are to be added. + ! + IF ( CONNCT .AND. .NOT.FIRST ) THEN + IDX = IX - IXO + IDY = IY - IYO + IF ( IDX.EQ.0 .OR. IDY.EQ.0 .OR. & + ABS(IDX).EQ.ABS(IDY) ) THEN + NBA = MAX ( MAX(ABS(IDX),ABS(IDY))-1 , 0 ) + IF (IDX.NE.0) IDX = SIGN(1,IDX) + IF (IDY.NE.0) IDY = SIGN(1,IDY) + IX = IXO + IY = IYO + DO IBA=1, NBA + IX = IX + IDX + IY = IY + IDY + IF ( TMPSTA(IY,IX).EQ.1 .OR. J.EQ.2 ) THEN + TMPSTA(IY,IX) = NSTAT ELSE - EXIT + WRITE(NDSO,*) 'WARNING: POINT (',IX,',',IY, & + ') CANNOT BE GIVEN THE STATUS ',NSTAT END IF + END DO + IX = IX + IDX + IY = IY + IDY + ELSE + WRITE (NDSO,982) + WRITE (NDSO,*) ' ', IX , IY + WRITE (NDSO,*) ' ', IXO, IYO + END IF + END IF + ! + ! ... Check if point itself is to be added + ! + IF ( TMPSTA(IY,IX).EQ.1 .OR. J.EQ.2 ) THEN + TMPSTA(IY,IX) = NSTAT + END IF + ! + ! ... Save data of previous point + ! + IXO = IX + IYO = IY + FIRST = .FALSE. + ! + ! ... Branch back to read. + ! + END DO + ! + ! 8.c Final processing excluded points + ! + IF ( ILOOP .EQ. 2 ) THEN + ! + I = 1 + DO + IF (FLGNML) THEN + ! excluded bodies + IF (NML_EXCL_COUNT%N_BODY.GT.0 .AND. I.LE.NML_EXCL_COUNT%N_BODY) THEN + IX = NML_EXCL_BODY(I)%X_INDEX + IY = NML_EXCL_BODY(I)%Y_INDEX + I=I+1 + ELSE + EXIT END IF ELSE CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) IX, IY, CONNCT + READ (NDSI,*,END=2001,ERR=2002) IX, IY END IF -! -! ... Check if last point reached. -! + ! + ! ... Check if last point reached. + ! IF (IX.EQ.0 .AND. IY.EQ.0) EXIT -! -! ... Check if point in grid. -! - IF (GTYPE.EQ.UNGTYPE.AND.(UGOBCAUTO.OR.UGOBCOK)) CYCLE - IF (IX.LT.1 .OR. IX.GT.NX .OR. IY.LT.1 .OR. IY.GT.NY) THEN + ! + ! ... Check if point in grid. + ! + IF (IX.LT.1 .OR. IX.GT.NX .OR. IY.LT.1 .OR. IY.GT.NY) THEN WRITE (NDSO,981) WRITE (NDSO,*) ' ', IX, IY CYCLE END IF -! -! ... Check if intermediate points are to be added. -! - IF ( CONNCT .AND. .NOT.FIRST ) THEN - IDX = IX - IXO - IDY = IY - IYO - IF ( IDX.EQ.0 .OR. IDY.EQ.0 .OR. & - ABS(IDX).EQ.ABS(IDY) ) THEN - NBA = MAX ( MAX(ABS(IDX),ABS(IDY))-1 , 0 ) - IF (IDX.NE.0) IDX = SIGN(1,IDX) - IF (IDY.NE.0) IDY = SIGN(1,IDY) - IX = IXO - IY = IYO - DO IBA=1, NBA - IX = IX + IDX - IY = IY + IDY - IF ( TMPSTA(IY,IX).EQ.1 .OR. J.EQ.2 ) THEN - TMPSTA(IY,IX) = NSTAT - ELSE - WRITE(NDSO,*) 'WARNING: POINT (',IX,',',IY, & - ') CANNOT BE GIVEN THE STATUS ',NSTAT - END IF - END DO - IX = IX + IDX - IY = IY + IDY - ELSE - WRITE (NDSO,982) - WRITE (NDSO,*) ' ', IX , IY - WRITE (NDSO,*) ' ', IXO, IYO - END IF - END IF -! -! ... Check if point itself is to be added -! - IF ( TMPSTA(IY,IX).EQ.1 .OR. J.EQ.2 ) THEN - TMPSTA(IY,IX) = NSTAT + ! + ! ... Check if point already excluded + ! + IF ( TMPSTA(IY,IX) .EQ. NSTAT ) THEN + WRITE (NDSO,1981) + WRITE (NDSO,*) ' ', IX, IY + CYCLE END IF -! -! ... Save data of previous point -! - IXO = IX - IYO = IY - FIRST = .FALSE. -! -! ... Branch back to read. -! - END DO -! -! 8.c Final processing excluded points -! - IF ( ILOOP .EQ. 2 ) THEN -! - I = 1 + ! + ! ... Search for points to exclude + ! + TMPMAP = TMPSTA + J = 1 + IX1 = IX + IY1 = IY + ! + JJ = TMPSTA(IY,IX) + TMPSTA(IY,IX) = NSTAT DO - IF (FLGNML) THEN - ! excluded bodies - IF (NML_EXCL_COUNT%N_BODY.GT.0 .AND. I.LE.NML_EXCL_COUNT%N_BODY) THEN - IX = NML_EXCL_BODY(I)%X_INDEX - IY = NML_EXCL_BODY(I)%Y_INDEX - I=I+1 - ELSE - EXIT - END IF - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) IX, IY - END IF -! -! ... Check if last point reached. -! - IF (IX.EQ.0 .AND. IY.EQ.0) EXIT -! -! ... Check if point in grid. -! - IF (IX.LT.1 .OR. IX.GT.NX .OR. IY.LT.1 .OR. IY.GT.NY) THEN - WRITE (NDSO,981) - WRITE (NDSO,*) ' ', IX, IY - CYCLE - END IF -! -! ... Check if point already excluded -! - IF ( TMPSTA(IY,IX) .EQ. NSTAT ) THEN - WRITE (NDSO,1981) - WRITE (NDSO,*) ' ', IX, IY - CYCLE - END IF -! -! ... Search for points to exclude -! - TMPMAP = TMPSTA - J = 1 - IX1 = IX - IY1 = IY -! - JJ = TMPSTA(IY,IX) - TMPSTA(IY,IX) = NSTAT - DO - NBT = 0 - DO IX=MAX(1,IX1-J), MIN(IX1+J,NX) - DO IY=MAX(1,IY1-J), MIN(IY1+J,NY) - IF ( TMPSTA(IY,IX) .EQ. JJ ) THEN - IF (IX.GT.1) THEN - IF (TMPSTA(IY ,IX-1).EQ.NSTAT & - .AND. TMPMAP(IY ,IX-1).EQ.JJ ) THEN - TMPSTA(IY,IX) = NSTAT - END IF + NBT = 0 + DO IX=MAX(1,IX1-J), MIN(IX1+J,NX) + DO IY=MAX(1,IY1-J), MIN(IY1+J,NY) + IF ( TMPSTA(IY,IX) .EQ. JJ ) THEN + IF (IX.GT.1) THEN + IF (TMPSTA(IY ,IX-1).EQ.NSTAT & + .AND. TMPMAP(IY ,IX-1).EQ.JJ ) THEN + TMPSTA(IY,IX) = NSTAT END IF - IF (IX.LT.NX) THEN - IF (TMPSTA(IY ,IX+1).EQ.NSTAT & - .AND. TMPMAP(IY ,IX+1).EQ.JJ ) THEN - TMPSTA(IY,IX) = NSTAT - END IF + END IF + IF (IX.LT.NX) THEN + IF (TMPSTA(IY ,IX+1).EQ.NSTAT & + .AND. TMPMAP(IY ,IX+1).EQ.JJ ) THEN + TMPSTA(IY,IX) = NSTAT END IF - IF (IY.LT.NY) THEN - IF (TMPSTA(IY+1,IX ).EQ.NSTAT & - .AND. TMPMAP(IY+1,IX ).EQ.JJ ) THEN - TMPSTA(IY,IX) = NSTAT - END IF + END IF + IF (IY.LT.NY) THEN + IF (TMPSTA(IY+1,IX ).EQ.NSTAT & + .AND. TMPMAP(IY+1,IX ).EQ.JJ ) THEN + TMPSTA(IY,IX) = NSTAT END IF - IF (IY.GT.1) THEN - IF (TMPSTA(IY-1,IX ).EQ.NSTAT & + END IF + IF (IY.GT.1) THEN + IF (TMPSTA(IY-1,IX ).EQ.NSTAT & .AND. TMPMAP(IY-1,IX ).EQ.JJ ) THEN - TMPSTA(IY,IX) = NSTAT - END IF + TMPSTA(IY,IX) = NSTAT END IF - IF (TMPSTA(IY,IX).EQ.NSTAT) NBT = NBT + 1 END IF - END DO + IF (TMPSTA(IY,IX).EQ.NSTAT) NBT = NBT + 1 + END IF END DO -! - IF ( NBT .NE. 0 ) THEN - J = J + 1 - ELSE - EXIT - END IF END DO + ! + IF ( NBT .NE. 0 ) THEN + J = J + 1 + ELSE + EXIT + END IF + END DO + END DO + ! + ! ... Outer boundary excluded points + ! + IF ( GTYPE.NE.UNGTYPE ) THEN + + DO IX=1, NX + IF ( TMPSTA( 1,IX) .EQ. 1 ) TMPSTA( 1,IX) = NSTAT + IF ( TMPSTA(NY,IX) .EQ. 1 ) TMPSTA(NY,IX) = NSTAT END DO -! -! ... Outer boundary excluded points -! - IF ( GTYPE.NE.UNGTYPE ) THEN - - DO IX=1, NX - IF ( TMPSTA( 1,IX) .EQ. 1 ) TMPSTA( 1,IX) = NSTAT - IF ( TMPSTA(NY,IX) .EQ. 1 ) TMPSTA(NY,IX) = NSTAT + ! + IF ( ICLOSE.EQ.ICLOSE_NONE ) THEN + DO IY=2, NY-1 + IF ( TMPSTA(IY, 1) .EQ. 1 ) TMPSTA(IY, 1) = NSTAT + IF ( TMPSTA(IY,NX) .EQ. 1 ) TMPSTA(IY,NX) = NSTAT END DO -! - IF ( ICLOSE.EQ.ICLOSE_NONE ) THEN - DO IY=2, NY-1 - IF ( TMPSTA(IY, 1) .EQ. 1 ) TMPSTA(IY, 1) = NSTAT - IF ( TMPSTA(IY,NX) .EQ. 1 ) TMPSTA(IY,NX) = NSTAT - END DO - END IF + END IF - END IF ! GTYPE -! - END IF ! ILOOP .EQ. 2 -! -! ... Branch back input / excluded points ( ILOOP in 8.b ) -! - END DO -! - ELSE ! FROM .EQ. PART -! -! 8.d Read the map from file instead -! - NSTAT = -1 - IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 - IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 - -!!Li Suspended for SMC grid though the file input line in ww3_grid.inp -!!Li is kept to divert the program into this block. JGLi15Oct2014 -!!Li - IF( GTYPE .NE. SMCTYPE ) THEN -!!Li -! - WRITE (NDSO,978) NDSTR, IDLA, IDFT - IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM - IF (FROM.EQ.'NAME') WRITE (NDSO,974) TNAME -! - IF ( NDSTR .EQ. NDSI ) THEN - IF ( IDFT .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSTR - CALL EXTCDE (23) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF + END IF ! GTYPE + ! + END IF ! ILOOP .EQ. 2 + ! + ! ... Branch back input / excluded points ( ILOOP in 8.b ) + ! + END DO + ! + ELSE ! FROM .EQ. PART + ! + ! 8.d Read the map from file instead + ! + NSTAT = -1 + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 + + !!Li Suspended for SMC grid though the file input line in ww3_grid.inp + !!Li is kept to divert the program into this block. JGLi15Oct2014 + !!Li + IF( GTYPE .NE. SMCTYPE ) THEN + !!Li + ! + WRITE (NDSO,978) NDSTR, IDLA, IDFT + IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM + IF (FROM.EQ.'NAME') WRITE (NDSO,974) TNAME + ! + IF ( NDSTR .EQ. NDSI ) THEN + IF ( IDFT .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSTR + CALL EXTCDE (23) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + ELSE + IF ( IDFT .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=2000, & + IOSTAT=IERR) ELSE - IF ( IDFT .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=2000, & - IOSTAT=IERR) - ELSE - OPEN (NDSTR, form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSTR, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - END IF + OPEN (NDSTR, form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) END IF -! - ALLOCATE ( READMP(NX,NY) ) - CALL INA2I ( READMP, NX, NY, 1, NX, 1, NY, NDSTR, NDST, & - NDSE, IDFT, RFORM, IDLA, 1, 0 ) -! - IF ( ICLOSE.EQ.ICLOSE_NONE ) THEN - DO IY=2, NY-1 - IF ( READMP( 1,IY) .EQ. 1 ) READMP( 1,IY) = 3 - IF ( READMP(NX,IY) .EQ. 1 ) READMP(NX,IY) = 3 - END DO + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSTR, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) END IF -! - DO IX=1, NX - IF ( READMP(IX, 1) .EQ. 1 ) READMP(IX, 1) = 3 - IF ( READMP(IX,NY) .EQ. 1 .AND. ICLOSE .NE. ICLOSE_TRPL) & + END IF + END IF + ! + ALLOCATE ( READMP(NX,NY) ) + CALL INA2I ( READMP, NX, NY, 1, NX, 1, NY, NDSTR, NDST, & + NDSE, IDFT, RFORM, IDLA, 1, 0 ) + ! + IF ( ICLOSE.EQ.ICLOSE_NONE ) THEN + DO IY=2, NY-1 + IF ( READMP( 1,IY) .EQ. 1 ) READMP( 1,IY) = 3 + IF ( READMP(NX,IY) .EQ. 1 ) READMP(NX,IY) = 3 + END DO + END IF + ! + DO IX=1, NX + IF ( READMP(IX, 1) .EQ. 1 ) READMP(IX, 1) = 3 + IF ( READMP(IX,NY) .EQ. 1 .AND. ICLOSE .NE. ICLOSE_TRPL) & READMP(IX,NY) = 3 - END DO -! - DO IY=1, NY - DO IX=1, NX - IF ( READMP(IX,IY) .EQ. 3 ) THEN - TMPSTA(IY,IX) = NSTAT - ELSE - TMPSTA(IY,IX) = READMP(IX,IY) - ! force to dry the sea points over zlim - IF ( ZBIN(IX,IY) .GT. ZLIM ) TMPSTA(IY,IX) = 0 - END IF - END DO - END DO - DEALLOCATE ( READMP ) -!!Li - ENDIF !! GTYPE .NE. SMCTYPE -! - END IF !FROM .NE. 'PART' -! -! 8.e Get NSEA and other counters -! - NSEA = 0 - NLAND = 0 - NBI = 0 - NBT = 0 -! - DO IX=1, NX + END DO + ! DO IY=1, NY - IF ( TMPSTA(IY,IX) .GT. 0 ) NSEA = NSEA + 1 - IF ( TMPSTA(IY,IX) .EQ. 0 ) NLAND = NLAND + 1 - IF ( TMPSTA(IY,IX) .LT. 0 ) NBT = NBT + 1 - IF ( TMPSTA(IY,IX) .EQ. 2 ) NBI = NBI + 1 + DO IX=1, NX + IF ( READMP(IX,IY) .EQ. 3 ) THEN + TMPSTA(IY,IX) = NSTAT + ELSE + TMPSTA(IY,IX) = READMP(IX,IY) + ! force to dry the sea points over zlim + IF ( ZBIN(IX,IY) .GT. ZLIM ) TMPSTA(IY,IX) = 0 + END IF END DO END DO -! + DEALLOCATE ( READMP ) + !!Li + ENDIF !! GTYPE .NE. SMCTYPE + ! + END IF !FROM .NE. 'PART' + ! + ! 8.e Get NSEA and other counters + ! + NSEA = 0 + NLAND = 0 + NBI = 0 + NBT = 0 + ! + DO IX=1, NX + DO IY=1, NY + IF ( TMPSTA(IY,IX) .GT. 0 ) NSEA = NSEA + 1 + IF ( TMPSTA(IY,IX) .EQ. 0 ) NLAND = NLAND + 1 + IF ( TMPSTA(IY,IX) .LT. 0 ) NBT = NBT + 1 + IF ( TMPSTA(IY,IX) .EQ. 2 ) NBI = NBI + 1 + END DO + END DO + ! #ifdef W3_SMC - IF( GTYPE .EQ. SMCTYPE ) THEN - !Li Moved before FLBPI is defined with NBI value. JGLi05Jun2015 - !Li Overwrite NSEA with NCel for SMC grid. - NSEA = NCel - !Li Use input NBI number for SMC grid because merged - !Li cells are over-counted by model. - NBI = NBISMC - !Li No land points are used in SMC grid. JGLi26Feb2016 - NLAND = 0 - ENDIF !! GTYPE .EQ. SMCTYPE -#endif -! - WRITE (NDSO,980) - FLBPI = NBI .GT. 0 - IF ( .NOT. FLBPI ) THEN - WRITE (NDSO,985) - ELSE - WRITE (NDSO,986) NBI + IF( GTYPE .EQ. SMCTYPE ) THEN + !Li Moved before FLBPI is defined with NBI value. JGLi05Jun2015 + !Li Overwrite NSEA with NCel for SMC grid. + NSEA = NCel + !Li Use input NBI number for SMC grid because merged + !Li cells are over-counted by model. + NBI = NBISMC + !Li No land points are used in SMC grid. JGLi26Feb2016 + NLAND = 0 + ENDIF !! GTYPE .EQ. SMCTYPE +#endif + ! + WRITE (NDSO,980) + FLBPI = NBI .GT. 0 + IF ( .NOT. FLBPI ) THEN + WRITE (NDSO,985) + ELSE + WRITE (NDSO,986) NBI #ifdef W3_O1 - IF ( FLAGLL ) THEN - WRITE (NDSO, 987) + IF ( FLAGLL ) THEN + WRITE (NDSO, 987) + ELSE + WRITE (NDSO,1987) + END IF + IBI = 1 + DO IY=1, NY + DO IX=1, NX + IF (GTYPE.NE.UNGTYPE) THEN + X = FACTOR * ( XGRDIN(IX,IY) ) + Y = FACTOR * ( YGRDIN(IX,IY) ) + ELSE + X = FACTOR * XGRD(1,IX) + Y = FACTOR * YGRD(1,IX) + END IF + IF ( TMPSTA(IY,IX).EQ.2 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSO, 988) IBI, IX, IY, X, Y ELSE - WRITE (NDSO,1987) + WRITE (NDSO,1988) IBI, IX, IY, X, Y END IF - IBI = 1 - DO IY=1, NY - DO IX=1, NX - IF (GTYPE.NE.UNGTYPE) THEN - X = FACTOR * ( XGRDIN(IX,IY) ) - Y = FACTOR * ( YGRDIN(IX,IY) ) - ELSE - X = FACTOR * XGRD(1,IX) - Y = FACTOR * YGRD(1,IX) - END IF - IF ( TMPSTA(IY,IX).EQ.2 ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSO, 988) IBI, IX, IY, X, Y - ELSE - WRITE (NDSO,1988) IBI, IX, IY, X, Y - END IF - IBI = IBI + 1 - END IF - END DO - END DO -#endif - END IF -! - WRITE (NDSO,1980) - IF ( NBT .EQ. 0 ) THEN - WRITE (NDSO,1985) - ELSE - WRITE (NDSO,1986) NBT - END IF -! -! 8.f Set up all maps -! - CALL W3DIMX ( 1, NX, NY, NSEA, NDSE, NDST & + IBI = IBI + 1 + END IF + END DO + END DO +#endif + END IF + ! + WRITE (NDSO,1980) + IF ( NBT .EQ. 0 ) THEN + WRITE (NDSO,1985) + ELSE + WRITE (NDSO,1986) NBT + END IF + ! + ! 8.f Set up all maps + ! + CALL W3DIMX ( 1, NX, NY, NSEA, NDSE, NDST & #ifdef W3_SMC - , NCel, NUFc, NVFc, NRLv, NBSMC & - , NARC, NBAC, NSPEC & + , NCel, NUFc, NVFc, NRLv, NBSMC & + , NARC, NBAC, NSPEC & #endif - ) + ) #ifdef W3_SMC - WRITE (NDSO,4021) NCel + WRITE (NDSO,4021) NCel #endif -! -! 8.g Activation of reflections and scattering - FFACBERG=FACBERG + ! + ! 8.g Activation of reflections and scattering + FFACBERG=FACBERG #ifdef W3_REF1 - REFPARS(1)=REFCOAST - REFPARS(2)=REFSUBGRID - REFPARS(3)=REFUNSTSOURCE - REFPARS(4)=REFICEBERG - REFPARS(6)=REFFREQ - REFPARS(7)=REFSLOPE - REFPARS(8)=REFCOSP_STRAIGHT - REFPARS(9)=REFRMAX - REFPARS(10)=REFFREQPOW - IF (GTYPE.EQ.UNGTYPE) REFPARS(2:5)=0. - IF (REFMAP.EQ.0) THEN - REFLC(3,:)=REFPARS(7) - END IF + REFPARS(1)=REFCOAST + REFPARS(2)=REFSUBGRID + REFPARS(3)=REFUNSTSOURCE + REFPARS(4)=REFICEBERG + REFPARS(6)=REFFREQ + REFPARS(7)=REFSLOPE + REFPARS(8)=REFCOSP_STRAIGHT + REFPARS(9)=REFRMAX + REFPARS(10)=REFFREQPOW + IF (GTYPE.EQ.UNGTYPE) REFPARS(2:5)=0. + IF (REFMAP.EQ.0) THEN + REFLC(3,:)=REFPARS(7) + END IF #endif - IF (GTYPE.NE.UNGTYPE) THEN - DO IY=1, NY - DO IX=1, NX - XGRD(IY,IX) = XGRDIN(IX,IY) - YGRD(IY,IX) = YGRDIN(IX,IY) - END DO - END DO - DEALLOCATE ( XGRDIN, YGRDIN ) - CALL W3GNTX ( 1, 6, 6 ) - ELSE - END IF ! GTYPE -! + IF (GTYPE.NE.UNGTYPE) THEN + DO IY=1, NY + DO IX=1, NX + XGRD(IY,IX) = XGRDIN(IX,IY) + YGRD(IY,IX) = YGRDIN(IX,IY) + END DO + END DO + DEALLOCATE ( XGRDIN, YGRDIN ) + CALL W3GNTX ( 1, 6, 6 ) + ELSE + END IF ! GTYPE + ! #ifdef W3_SMC - !!Li Shelter MAPSTA LLG definition for SMC - IF( GTYPE .NE. SMCTYPE ) THEN + !!Li Shelter MAPSTA LLG definition for SMC + IF( GTYPE .NE. SMCTYPE ) THEN #endif -! + ! MAPSTA = TMPSTA MAPFS = 0 -! + ! #ifdef W3_T ALLOCATE ( MAPOUT(NX,NY) ) MAPOUT = 0 -#endif -! -#ifdef W3_T + ! IX3 = 1 + NX/60 IY3 = 1 + NY/60 CALL PRTBLK (NDST, NX, NY, NX, ZBIN, MAPOUT, 1, 0., & - 1, NX, IX3, 1, NY, IY3, 'Zb', 'm') + 1, NX, IX3, 1, NY, IY3, 'Zb', 'm') #endif -! + ! TRNX = 0. TRNY = 0. -! + ! ISEA = 0 DO IY=1, NY DO IX=1, NX IF ( TMPSTA(IY,IX) .EQ. NSTAT ) THEN - MAPSTA(IY,IX) = 0 - MAPST2(IY,IX) = 1 - TMPSTA(IY,IX) = 3 - ELSE - MAPSTA(IY,IX) = TMPSTA(IY,IX) - MAPST2(IY,IX) = 0 - END IF + MAPSTA(IY,IX) = 0 + MAPST2(IY,IX) = 1 + TMPSTA(IY,IX) = 3 + ELSE + MAPSTA(IY,IX) = TMPSTA(IY,IX) + MAPST2(IY,IX) = 0 + END IF IF ( MAPSTA(IY,IX) .NE. 0 ) THEN - ISEA = ISEA + 1 - MAPFS (IY,IX) = ISEA - ZB(ISEA) = ZBIN(IX,IY) + ISEA = ISEA + 1 + MAPFS (IY,IX) = ISEA + ZB(ISEA) = ZBIN(IX,IY) #ifdef W3_T - MAPOUT(IX,IY) = 1 -#endif - MAPSF(ISEA,1) = IX - MAPSF(ISEA,2) = IY - IF ( FLAGLL ) THEN - Y = YGRD(IY,IX) - CLATS(ISEA) = COS(Y*DERA) - CLATIS(ISEA) = 1. / CLATS(ISEA) - CTHG0S(ISEA) = - TAN(DERA*Y) / RADIUS - ELSE - CLATS(ISEA) = 1. - CLATIS(ISEA) = 1. - CTHG0S(ISEA) = 0. - END IF + MAPOUT(IX,IY) = 1 +#endif + MAPSF(ISEA,1) = IX + MAPSF(ISEA,2) = IY + IF ( FLAGLL ) THEN + Y = YGRD(IY,IX) + CLATS(ISEA) = COS(Y*DERA) + CLATIS(ISEA) = 1. / CLATS(ISEA) + CTHG0S(ISEA) = - TAN(DERA*Y) / RADIUS + ELSE + CLATS(ISEA) = 1. + CLATIS(ISEA) = 1. + CTHG0S(ISEA) = 0. END IF + END IF -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -! notes: Oct 22 2012: I moved the following "if-then" statement from -! inside the "IF ( MAPSTA(IY,IX) .NE. 0 )" statement to outside that -! statement. This is needed since later on, ATRNX is computed from -! TRNX(ix-1) , TRNX(ix) etc. which causes boundary effects if the -! MAPSTA=0 values are set to TRNX=0 + ! notes: Oct 22 2012: I moved the following "if-then" statement from + ! inside the "IF ( MAPSTA(IY,IX) .NE. 0 )" statement to outside that + ! statement. This is needed since later on, ATRNX is computed from + ! TRNX(ix-1) , TRNX(ix) etc. which causes boundary effects if the + ! MAPSTA=0 values are set to TRNX=0 - IF ( TRFLAG .NE. 0 ) THEN - TRNX(IY,IX) = 1. - OBSX(IX,IY) - TRNY(IY,IX) = 1. - OBSY(IX,IY) - END IF + IF ( TRFLAG .NE. 0 ) THEN + TRNX(IY,IX) = 1. - OBSX(IX,IY) + TRNY(IY,IX) = 1. - OBSY(IX,IY) + END IF - END DO END DO -! -#ifdef W3_SMC - !!Li SMC grid definition of mapping arrays. - ELSE -#endif -! + END DO + ! #ifdef W3_SMC - !!Li Pass refined level cell and face counts to NLv*(NRLv) - NLvCel(0)=0 - NLvUFc(0)=0 - NLvVFc(0)=0 - DO IP = 1, NRLv - NLvCel(IP)=NLvCelsk(IP) + NLvCel(IP-1) - NLvUFc(IP)=NLvUFcsk(IP) + NLvUFc(IP-1) - NLvVFc(IP)=NLvVFcsk(IP) + NLvVFc(IP-1) - ENDDO - WRITE (NDSO,4022) NLvCel - WRITE (NDSO,4023) NLvUFc - WRITE (NDSO,4024) NLvVFc - - !Li Redefine MAPSF MAPFS MAPSTA MAPST2 CLATS and ZB for SMC Grid, - !Li using SMC grid cell array and assuming NSEA=NCel. - MAPSTA = 0 - MAPST2 = 1 - MAPFS = 0 -!LS Allocation for read-in variables that remain local only. - ALLOCATE ( IJKVFc8(NVFc) ) - ALLOCATE ( IJKDep(-9:NCel) ) - - !Li Pass input SMC arrays to newly declared grid arrays. - WRITE (NDSO,4025) NCel - IJKCel(1:4, 1:NGLO)=IJKCelin(1:4, 1:NGLO) - IJKDep(1:NGLO)=IJKCelin(5, 1:NGLO) - IJKUFc(1:7, 1:NGUI)=IJKUFcin(1:7, 1:NGUI) - IJKVFc(1:7, 1:NGVJ)=IJKVFcin(1:7, 1:NGVJ) - IJKVFc8(1:NGVJ)=IJKVFcin(8, 1:NGVJ) - !Li Append Arctic part - IF( ARCTC ) THEN - IJKCel(1:4, NGLO+1:NCel)=IJKCelAC(1:4, 1:NARC) - IJKDep(NGLO+1:NCel)=IJKCelAC(5, 1:NARC) - IJKUFc(1:7, NGUI+1:NUFc)=IJKUFcAC(1:7, 1:NAUI) - IJKVFc(1:7, NGVJ+1:NVFc)=IJKVFcAC(1:7, 1:NAVJ) - IJKVFc8(NGVJ+1:NVFc)=IJKVFcAC(8, 1:NAVJ) - ENDIF !! ARCTC - - WRITE (NDSO,4026) - WRITE (NDSO,4006) 1,(IJKCel(ix, 1), ix=1,4), IJKDep(1) - JJ=NCel - WRITE (NDSO,4006) JJ,(IJKCel(ix, JJ), ix=1,4), IJKDep(JJ) - WRITE (NDSO,*) ' ' - WRITE (NDSO,4027) - WRITE (NDSO,4009) 1,(IJKUFc(ix, 1), ix=1,7) - JJ=NUFc - WRITE (NDSO,4009) JJ,(IJKUFc(ix, JJ), ix=1,7) - WRITE (NDSO,*) ' ' - WRITE (NDSO,4028) - WRITE (NDSO,4012) 1,(IJKVFc(ix, 1), ix=1,7), IJKVFc8(1) - JJ=NVFc - WRITE (NDSO,4012) JJ,(IJKVFc(ix, JJ), ix=1,7), IJKVFc8(JJ) - WRITE (NDSO,*) ' ' - - !Li Boundary -9 to 0 cells for cell x-size 2**n - !Li Note the position indice for bounary cell are not used. - IJKCel(1, -9:0)=0 - !Li Use Equator Y index for boundary cells. JGLi04Apr2011 - !Li IJKCel(2, -9:0)=0 - IJKCel(2, -9:0)=JEQT - IJKCel(3, 0)=1 - IJKCel(4, 0)=1 - !Li Use minimum 10 m depth for boundary cells. - !Li Y-size is restricted below base-cell value. - !Li For refined boundary cells, its y-size is replaced with - !Li the inner cell y-size for flux gradient. - IJKDep(0)=10 - DO ip=1,9 - IJKCel(3,-ip)=IJKCel(3,-ip+1)*2 - IK=MIN(ip, NRLv-1) - IJKCel(4,-ip)=2**IK - IJKDep(-ip)=10 - ENDDO - WRITE (NDSO,4029) - DO ip=0, -9, -1 - WRITE (NDSO,4030) IJKCel(:,ip), IJKDep(ip) - ENDDO - - WRITE (NDSO,4031) NCel - !Li Multi-resolution SMC grid requires rounding of x, y indices - !Li by a factor MRFct. - MRFct = 2**(NRLv - 1) - WRITE (NDSO,4032) MRFct - - !Li Cosine for SMC uses refined latitude increment. - SYMR = SY*DERA/FLOAT( MRFct ) - !Li Reference y point for adjusted cell j=0 in radian. JGLi16Feb2016 - YJ0R = ( Y0 - 0.5*SY )*DERA - - DO ISEA=1, NCel - !Li There is no polar cell row so it is mapped to last row. - IF( ARCTC .AND. (ISEA .EQ. NCel) ) THEN - IX=1 - IY=NY - IK=1 - JS=1 + !!Li SMC grid definition of mapping arrays. + ELSE + !!Li Pass refined level cell and face counts to NLv*(NRLv) + NLvCel(0)=0 + NLvUFc(0)=0 + NLvVFc(0)=0 + DO IP = 1, NRLv + NLvCel(IP)=NLvCelsk(IP) + NLvCel(IP-1) + NLvUFc(IP)=NLvUFcsk(IP) + NLvUFc(IP-1) + NLvVFc(IP)=NLvVFcsk(IP) + NLvVFc(IP-1) + ENDDO + WRITE (NDSO,4022) NLvCel + WRITE (NDSO,4023) NLvUFc + WRITE (NDSO,4024) NLvVFc + + !Li Redefine MAPSF MAPFS MAPSTA MAPST2 CLATS and ZB for SMC Grid, + !Li using SMC grid cell array and assuming NSEA=NCel. + MAPSTA = 0 + MAPST2 = 1 + MAPFS = 0 + !LS Allocation for read-in variables that remain local only. + ALLOCATE ( IJKVFc8(NVFc) ) + ALLOCATE ( IJKDep(-9:NCel) ) + + !Li Pass input SMC arrays to newly declared grid arrays. + WRITE (NDSO,4025) NCel + IJKCel(1:4, 1:NGLO)=IJKCelin(1:4, 1:NGLO) + IJKDep(1:NGLO)=IJKCelin(5, 1:NGLO) + IJKUFc(1:7, 1:NGUI)=IJKUFcin(1:7, 1:NGUI) + IJKVFc(1:7, 1:NGVJ)=IJKVFcin(1:7, 1:NGVJ) + IJKVFc8(1:NGVJ)=IJKVFcin(8, 1:NGVJ) + !Li Append Arctic part + IF( ARCTC ) THEN + IJKCel(1:4, NGLO+1:NCel)=IJKCelAC(1:4, 1:NARC) + IJKDep(NGLO+1:NCel)=IJKCelAC(5, 1:NARC) + IJKUFc(1:7, NGUI+1:NUFc)=IJKUFcAC(1:7, 1:NAUI) + IJKVFc(1:7, NGVJ+1:NVFc)=IJKVFcAC(1:7, 1:NAVJ) + IJKVFc8(NGVJ+1:NVFc)=IJKVFcAC(8, 1:NAVJ) + ENDIF !! ARCTC + + WRITE (NDSO,4026) + WRITE (NDSO,4006) 1,(IJKCel(ix, 1), ix=1,4), IJKDep(1) + JJ=NCel + WRITE (NDSO,4006) JJ,(IJKCel(ix, JJ), ix=1,4), IJKDep(JJ) + WRITE (NDSO,*) ' ' + WRITE (NDSO,4027) + WRITE (NDSO,4009) 1,(IJKUFc(ix, 1), ix=1,7) + JJ=NUFc + WRITE (NDSO,4009) JJ,(IJKUFc(ix, JJ), ix=1,7) + WRITE (NDSO,*) ' ' + WRITE (NDSO,4028) + WRITE (NDSO,4012) 1,(IJKVFc(ix, 1), ix=1,7), IJKVFc8(1) + JJ=NVFc + WRITE (NDSO,4012) JJ,(IJKVFc(ix, JJ), ix=1,7), IJKVFc8(JJ) + WRITE (NDSO,*) ' ' + + !Li Boundary -9 to 0 cells for cell x-size 2**n + !Li Note the position indice for bounary cell are not used. + IJKCel(1, -9:0)=0 + !Li Use Equator Y index for boundary cells. JGLi04Apr2011 + !Li IJKCel(2, -9:0)=0 + IJKCel(2, -9:0)=JEQT + IJKCel(3, 0)=1 + IJKCel(4, 0)=1 + !Li Use minimum 10 m depth for boundary cells. + !Li Y-size is restricted below base-cell value. + !Li For refined boundary cells, its y-size is replaced with + !Li the inner cell y-size for flux gradient. + IJKDep(0)=10 + DO ip=1,9 + IJKCel(3,-ip)=IJKCel(3,-ip+1)*2 + IK=MIN(ip, NRLv-1) + IJKCel(4,-ip)=2**IK + IJKDep(-ip)=10 + ENDDO + WRITE (NDSO,4029) + DO ip=0, -9, -1 + WRITE (NDSO,4030) IJKCel(:,ip), IJKDep(ip) + ENDDO + + WRITE (NDSO,4031) NCel + !Li Multi-resolution SMC grid requires rounding of x, y indices + !Li by a factor MRFct. + MRFct = 2**(NRLv - 1) + WRITE (NDSO,4032) MRFct + + !Li Cosine for SMC uses refined latitude increment. + SYMR = SY*DERA/FLOAT( MRFct ) + !Li Reference y point for adjusted cell j=0 in radian. JGLi16Feb2016 + YJ0R = ( Y0 - 0.5*SY )*DERA + + DO ISEA=1, NCel + !Li There is no polar cell row so it is mapped to last row. + IF( ARCTC .AND. (ISEA .EQ. NCel) ) THEN + IX=1 + IY=NY + IK=1 + JS=1 ELSE IX=IJKCel(1,ISEA)/MRFct + 1 IY=IJKCel(2,ISEA)/MRFct + 1 @@ -5032,68 +4989,68 @@ SUBROUTINE W3GRID() JS=MAX(1, IJKCel(4,ISEA)/MRFct) ENDIF - ! Check that IX, IY are in the bound of [1,NX] and [1,NY] respec. + ! Check that IX, IY are in the bound of [1,NX] and [1,NY] respec. IF ((IX+IK-1 .GT. NX) .OR. (IX .LE. 0)) THEN - WRITE (NDSE,1014) ISEA, IX, IX+IK-1, NX - CALL EXTCDE(65) + WRITE (NDSE,1014) ISEA, IX, IX+IK-1, NX + CALL EXTCDE(65) END IF - + IF ((IY+JS-1 .GT. NY) .OR. (IY .LE. 0)) THEN - WRITE (NDSE,1015) ISEA, IY, IY+JS-1, NY - CALL EXTCDE(65) + WRITE (NDSE,1015) ISEA, IY, IY+JS-1, NY + CALL EXTCDE(65) END IF - !Li Minimum DMIN depth is used as well for SMC. - ZB(ISEA)= - MAX( DMIN, FLOAT( IJKDep(ISEA) ) ) - MAPFS(IY:IY+JS-1,IX:IX+IK-1) = ISEA - MAPSTA(IY:IY+JS-1,IX:IX+IK-1) = 1 - MAPST2(IY:IY+JS-1,IX:IX+IK-1) = 0 - MAPSF(ISEA,1) = IX - MAPSF(ISEA,2) = IY - MAPSF(ISEA,3) = IY + (IX -1)*NY - - !Li New variable CLATS to hold cosine latitude at cell centre. - !Li Also added CLATIS and CTHG0S for version 4.08. - !Li Use adjusted j-index to calculate cell centre y from YJ0R. - Y = YJ0R + SYMR*( FLOAT(IJKCel(2,ISEA))+0.5*FLOAT(IJKCel(4,ISEA)) ) - !Li Arctic polar cell does not need COS(LAT), set 1 row down. - IF(Y .GE. HPI-0.1*SYMR) Y=HPI - SYMR*0.5*FLOAT( MRFct ) - - CLATS(ISEA) = COS( Y ) - CLATIS(ISEA)= 1. / CLATS(ISEA) - CTHG0S(ISEA)= - TAN( Y ) / RADIUS - !!Li Sub-grid obstruction is set zero beyond NCObst cells. - IF(ISEA .GT. NCObst) THEN - TRNMX=1.0 - TRNMY=1.0 - ELSE - !!Li Present obstruction is isotropic and in percentage. - TRNMX=1.0 - IJKObstr(1, ISEA)*0.01 - TRNMY=1.0 - IJKObstr(JObs, ISEA)*0.01 - ENDIF - CTRNX(ISEA) = MAX(0.11, TRNMX) - CTRNY(ISEA) = MAX(0.11, TRNMY) - END DO - !!Li Transparency for boundary cells are 1.0 JGLi16Jan2012 - CTRNX(-9:0) = 1.0 - CTRNY(-9:0) = 1.0 - !!Li Check range of MAPSF and MAPFS - WRITE (NDSO,4033) MINVAL( MAPSF(:,1) ), MAXVAL( MAPSF(:,1) ) - WRITE (NDSO,4034) MINVAL( MAPSF(:,2) ), MAXVAL( MAPSF(:,2) ) - WRITE (NDSO,4035) MINVAL( MAPSF(:,3) ), MAXVAL( MAPSF(:,3) ) - WRITE (NDSO,4036) MINVAL( MAPFS(:,:) ), MAXVAL( MAPFS(:,:) ) - - !Li New variable CLATF to hold cosine latitude at cell V face. - DO IP = 1, NVFC - ! CLATF(IP) = COS( SYMR*FLOAT(IJKVFc(2,IP) - JEQT) ) - !Li Use adjusted j-index to calculate cell face Y from YJ0R. - CLATF(IP) = COS( SYMR*FLOAT(IJKVFc(2,IP)) + YJ0R ) - ENDDO - IF(NBISMC .GT. 0) THEN - !Li Save input boundary SMC list to ISMCBP(NBSMC) - ISMCBP(1:NBISMC) = NBICelin(1:NBISMC) - !Li Reset MAPSTA for boundary cells if any. - DO IP=1, NBISMC + !Li Minimum DMIN depth is used as well for SMC. + ZB(ISEA)= - MAX( DMIN, FLOAT( IJKDep(ISEA) ) ) + MAPFS(IY:IY+JS-1,IX:IX+IK-1) = ISEA + MAPSTA(IY:IY+JS-1,IX:IX+IK-1) = 1 + MAPST2(IY:IY+JS-1,IX:IX+IK-1) = 0 + MAPSF(ISEA,1) = IX + MAPSF(ISEA,2) = IY + MAPSF(ISEA,3) = IY + (IX -1)*NY + + !Li New variable CLATS to hold cosine latitude at cell centre. + !Li Also added CLATIS and CTHG0S for version 4.08. + !Li Use adjusted j-index to calculate cell centre y from YJ0R. + Y = YJ0R + SYMR*( FLOAT(IJKCel(2,ISEA))+0.5*FLOAT(IJKCel(4,ISEA)) ) + !Li Arctic polar cell does not need COS(LAT), set 1 row down. + IF(Y .GE. HPI-0.1*SYMR) Y=HPI - SYMR*0.5*FLOAT( MRFct ) + + CLATS(ISEA) = COS( Y ) + CLATIS(ISEA)= 1. / CLATS(ISEA) + CTHG0S(ISEA)= - TAN( Y ) / RADIUS + !!Li Sub-grid obstruction is set zero beyond NCObst cells. + IF(ISEA .GT. NCObst) THEN + TRNMX=1.0 + TRNMY=1.0 + ELSE + !!Li Present obstruction is isotropic and in percentage. + TRNMX=1.0 - IJKObstr(1, ISEA)*0.01 + TRNMY=1.0 - IJKObstr(JObs, ISEA)*0.01 + ENDIF + CTRNX(ISEA) = MAX(0.11, TRNMX) + CTRNY(ISEA) = MAX(0.11, TRNMY) + END DO + !!Li Transparency for boundary cells are 1.0 JGLi16Jan2012 + CTRNX(-9:0) = 1.0 + CTRNY(-9:0) = 1.0 + !!Li Check range of MAPSF and MAPFS + WRITE (NDSO,4033) MINVAL( MAPSF(:,1) ), MAXVAL( MAPSF(:,1) ) + WRITE (NDSO,4034) MINVAL( MAPSF(:,2) ), MAXVAL( MAPSF(:,2) ) + WRITE (NDSO,4035) MINVAL( MAPSF(:,3) ), MAXVAL( MAPSF(:,3) ) + WRITE (NDSO,4036) MINVAL( MAPFS(:,:) ), MAXVAL( MAPFS(:,:) ) + + !Li New variable CLATF to hold cosine latitude at cell V face. + DO IP = 1, NVFC + ! CLATF(IP) = COS( SYMR*FLOAT(IJKVFc(2,IP) - JEQT) ) + !Li Use adjusted j-index to calculate cell face Y from YJ0R. + CLATF(IP) = COS( SYMR*FLOAT(IJKVFc(2,IP)) + YJ0R ) + ENDDO + IF(NBISMC .GT. 0) THEN + !Li Save input boundary SMC list to ISMCBP(NBSMC) + ISMCBP(1:NBISMC) = NBICelin(1:NBISMC) + !Li Reset MAPSTA for boundary cells if any. + DO IP=1, NBISMC ISEA = NBICelin(IP) IX=IJKCel(1,ISEA)/MRFct + 1 IY=IJKCel(2,ISEA)/MRFct + 1 @@ -5101,2373 +5058,2350 @@ SUBROUTINE W3GRID() JS=MAX(1, IJKCel(4,ISEA)/MRFct) MAPSTA(IY:IY+JS-1,IX:IX+IK-1) = 2 MAPST2(IY:IY+JS-1,IX:IX+IK-1) = 0 - ENDDO - ENDIF - -#endif -! -#ifdef W3_SMC - !Li Define rotation angle for Arctic cells. - IF( ARCTC ) THEN - - PoLonAC = 179.999 - PoLatAC = 0.001 - ALLOCATE( XLONAC(NARC),YLATAC(NARC),ELONAC(NARC),ELATAC(NARC) ) - DO ISEA=NGLO+1, NCel - !Li There is no polar cell row so it is mapped to last row. + ENDDO + ENDIF + !Li Define rotation angle for Arctic cells. + IF( ARCTC ) THEN + + PoLonAC = 179.999 + PoLatAC = 0.001 + ALLOCATE( XLONAC(NARC),YLATAC(NARC),ELONAC(NARC),ELATAC(NARC) ) + DO ISEA=NGLO+1, NCel + !Li There is no polar cell row so it is mapped to last row. IF(ISEA .EQ. NCel) THEN - IX=1 - IY=NY - IK=1 - JS=1 + IX=1 + IY=NY + IK=1 + JS=1 ELSE - IX=IJKCel(1,ISEA)/MRFct + 1 - IY=IJKCel(2,ISEA)/MRFct + 1 - IK=MAX(1, IJKCel(3,ISEA)/MRFct) - JS=MAX(1, IJKCel(4,ISEA)/MRFct) + IX=IJKCel(1,ISEA)/MRFct + 1 + IY=IJKCel(2,ISEA)/MRFct + 1 + IK=MAX(1, IJKCel(3,ISEA)/MRFct) + JS=MAX(1, IJKCel(4,ISEA)/MRFct) ENDIF XLONAC(ISEA-NGLO)= X0 + REAL(IX-1+IK/2)*SX YLATAC(ISEA-NGLO)= Y0 + REAL(IY-1+JS/2)*SY - ENDDO + ENDDO CALL W3LLTOEQ ( YLATAC, XLONAC, ELATAC, ELONAC, & - & ANGARC, PoLatAC, PoLonAC, NARC ) + & ANGARC, PoLatAC, PoLonAC, NARC ) - WRITE (NDSO,4037) NARC - WRITE (NDSO,4038) (ANGARC(ix), ix=1,NARC,NARC/8) + WRITE (NDSO,4037) NARC + WRITE (NDSO,4038) (ANGARC(ix), ix=1,NARC,NARC/8) -#endif -! -#ifdef W3_SMC - !Li Mapping Arctic boundary cells with inner model cells - DO IP=1, NBAC - IX=IJKCel(1,IP+NGLO) - IY=IJKCel(2,IP+NGLO) - DO ISEA=1, NGLO - IF( (IX .EQ. IJKCel(1,ISEA)) .AND. & - & (IY .EQ. IJKCel(2,ISEA)) ) THEN - ICLBAC(IP) = ISEA - ENDIF + !Li Mapping Arctic boundary cells with inner model cells + DO IP=1, NBAC + IX=IJKCel(1,IP+NGLO) + IY=IJKCel(2,IP+NGLO) + DO ISEA=1, NGLO + IF( (IX .EQ. IJKCel(1,ISEA)) .AND. & + & (IY .EQ. IJKCel(2,ISEA)) ) THEN + ICLBAC(IP) = ISEA + ENDIF ENDDO - ENDDO - WRITE (NDSO,4039) NBAC - WRITE (NDSO,4040) (ICLBAC(ix), ix=1,NBAC,NBAC/8) + ENDDO + WRITE (NDSO,4039) NBAC + WRITE (NDSO,4040) (ICLBAC(ix), ix=1,NBAC,NBAC/8) - !Li Redefine GCT term factor for Arctic part or the netative of - !Li tangient of rotated latitude divided by radius. JGLi14Sep2015 - DO ISEA=NGLO+1, NCel-1 + !Li Redefine GCT term factor for Arctic part or the netative of + !Li tangient of rotated latitude divided by radius. JGLi14Sep2015 + DO ISEA=NGLO+1, NCel-1 CTHG0S(ISEA)= - TAN( ELATAC(ISEA-NGLO)*DERA ) / RADIUS - ENDDO - CTHG0S(NCel)=0.0 - - ENDIF !! ARCTC section. -#endif -! -#ifdef W3_SMC - ENDIF !! (GTYPE .NE. SMCTYPE) ELSE SMCTYPE block. + ENDDO + CTHG0S(NCel)=0.0 + + ENDIF !! ARCTC section. + ENDIF !! (GTYPE .NE. SMCTYPE) ELSE SMCTYPE block. #endif -! + ! #ifdef W3_RTD - !Li Assign rotated grid angle for all sea points. JGLi01Feb2016 - DO ISEA=1,NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - AnglD(ISEA) = AnglDin(IX,IY) - END DO -#endif -! + !Li Assign rotated grid angle for all sea points. JGLi01Feb2016 + DO ISEA=1,NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + AnglD(ISEA) = AnglDin(IX,IY) + END DO +#endif + ! #ifdef W3_T - CALL PRTBLK (NDST, NX, NY, NX, ZBIN, MAPOUT, 0, 0., & - 1, NX, IX3, 1, NY, IY3, 'Sea points', 'm') - DEALLOCATE ( MAPOUT ) -#endif -! - DO ISP=1, NSPEC+NTH - MAPWN(ISP) = 1 + (ISP-1)/NTH - MAPTH(ISP) = 1 + MOD(ISP-1,NTH) - END DO -! + CALL PRTBLK (NDST, NX, NY, NX, ZBIN, MAPOUT, 0, 0., & + 1, NX, IX3, 1, NY, IY3, 'Sea points', 'm') + DEALLOCATE ( MAPOUT ) +#endif + ! + DO ISP=1, NSPEC+NTH + MAPWN(ISP) = 1 + (ISP-1)/NTH + MAPTH(ISP) = 1 + MOD(ISP-1,NTH) + END DO + ! #ifdef W3_O2 - NMAP = 1 + (NX-1)/NCOL - WRITE (NDSO,1100) NMAP - DO IMAP=1, NMAP - IX0 = 1 + (IMAP-1)*NCOL - IXN = MIN ( NX , IMAP*NCOL ) - DO IY=NY,1,-1 - WRITE (NDSO,1101) (TMPSTA(IY,IX),IX=IX0,IXN) - END DO - WRITE (NDSO,*) ' ' - END DO - WRITE (NDSO,1102) + NMAP = 1 + (NX-1)/NCOL + WRITE (NDSO,1100) NMAP + DO IMAP=1, NMAP + IX0 = 1 + (IMAP-1)*NCOL + IXN = MIN ( NX , IMAP*NCOL ) + DO IY=NY,1,-1 + WRITE (NDSO,1101) (TMPSTA(IY,IX),IX=IX0,IXN) + END DO + WRITE (NDSO,*) ' ' + END DO + WRITE (NDSO,1102) #endif #ifdef W3_O2a - OPEN (NDSM,FILE=TRIM(FNMPRE)//'mask.ww3') - DO IY=1, NY - WRITE (NDSM,998) MIN(1,MAPSTA(IY,:)) - END DO - CLOSE (NDSM) + OPEN (NDSM,FILE=TRIM(FNMPRE)//'mask.ww3') + DO IY=1, NY + WRITE (NDSM,998) MIN(1,MAPSTA(IY,:)) + END DO + CLOSE (NDSM) #endif -! + ! #ifdef W3_O2b - IF ( TRFLAG .GT. 0 ) THEN - NMAPB = 1 + (NX-1)/NCOL - WRITE (NDSO,1103) 'X', NMAPB - DO IMAPB=1, NMAPB - IX0 = 1 + (IMAPB-1)*NCOL - IXN = MIN ( NX , IMAPB*NCOL ) - DO IY=NY,1,-1 - WRITE (NDSO,1101) (NINT(10.*OBSX(IX,IY)),IX=IX0,IXN) - END DO - WRITE (NDSO,*) ' ' - END DO - WRITE (NDSO,1104) - WRITE (NDSO,1103) 'Y', NMAPB - DO IMAPB=1, NMAPB - IX0 = 1 + (IMAPB-1)*NCOL - IXN = MIN ( NX , IMAPB*NCOL ) - DO IY=NY,1,-1 - WRITE (NDSO,1101) (NINT(10.*OBSY(IX,IY)),IX=IX0,IXN) - END DO - WRITE (NDSO,*) ' ' - END DO - WRITE (NDSO,1104) - END IF + IF ( TRFLAG .GT. 0 ) THEN + NMAPB = 1 + (NX-1)/NCOL + WRITE (NDSO,1103) 'X', NMAPB + DO IMAPB=1, NMAPB + IX0 = 1 + (IMAPB-1)*NCOL + IXN = MIN ( NX , IMAPB*NCOL ) + DO IY=NY,1,-1 + WRITE (NDSO,1101) (NINT(10.*OBSX(IX,IY)),IX=IX0,IXN) + END DO + WRITE (NDSO,*) ' ' + END DO + WRITE (NDSO,1104) + WRITE (NDSO,1103) 'Y', NMAPB + DO IMAPB=1, NMAPB + IX0 = 1 + (IMAPB-1)*NCOL + IXN = MIN ( NX , IMAPB*NCOL ) + DO IY=NY,1,-1 + WRITE (NDSO,1101) (NINT(10.*OBSY(IX,IY)),IX=IX0,IXN) + END DO + WRITE (NDSO,*) ' ' + END DO + WRITE (NDSO,1104) + END IF #endif -! + ! #ifdef W3_O2c - OPEN (NDSM,FILE=TRIM(FNMPRE)//'mapsta.ww3', RECL=2*NX*NY*50+1) - DO IY=NY,1, -1 - DO IX=1,NX - DO I=1,50 - WRITE (NDSM,1998,ADVANCE='NO') (TMPSTA(IY,IX)) - END DO - END DO + OPEN (NDSM,FILE=TRIM(FNMPRE)//'mapsta.ww3', RECL=2*NX*NY*50+1) + DO IY=NY,1, -1 + DO IX=1,NX + DO I=1,50 + WRITE (NDSM,1998,ADVANCE='NO') (TMPSTA(IY,IX)) END DO - CLOSE (NDSM) + END DO + END DO + CLOSE (NDSM) #endif -! + ! #ifdef W3_IG1 - IGPARS(1)=IGMETHOD - IGPARS(2)=IGADDOUTP - IGPARS(3)=IGSOURCE - IGPARS(4)=0 - IF (IGBCOVERWRITE) IGPARS(4)=IGPARS(4)+1 - IF (IGSWELLMAX) IGPARS(4)=IGPARS(4)+2 - IGPARS(5)=1 - DO IK=1,NK - IF (SIG(IK)*TPIINV.LT.IGMAXFREQ) IGPARS(5)=IK - END DO - IGMINDEP=MINVAL(ZB*(-1.)-2) ! -2 / +2 is there for water level changes - IGMAXDEP=MAXVAL(ZB*(-1.)+2) - IF (IGSOURCEATBP.EQ.1) IGMINDEP=1. ! should use true minimum depth ... - IGPARS(6)=1+NINT(LOG(MAX(IGMAXDEP,1.0)/MAX(IGMINDEP,1.0))/LOG(1.1)) - IGPARS(7)=MAX(IGMINDEP,1.0) - IGPARS(8)=IGSOURCEATBP - IGPARS(9)=IGKDMIN - IGPARS(10)=IGFIXEDDEPTH - IGPARS(11)=IGEMPIRICAL**2 - IGPARS(12)=IGSTERMS -#endif -! + IGPARS(1)=IGMETHOD + IGPARS(2)=IGADDOUTP + IGPARS(3)=IGSOURCE + IGPARS(4)=0 + IF (IGBCOVERWRITE) IGPARS(4)=IGPARS(4)+1 + IF (IGSWELLMAX) IGPARS(4)=IGPARS(4)+2 + IGPARS(5)=1 + DO IK=1,NK + IF (SIG(IK)*TPIINV.LT.IGMAXFREQ) IGPARS(5)=IK + END DO + IGMINDEP=MINVAL(ZB*(-1.)-2) ! -2 / +2 is there for water level changes + IGMAXDEP=MAXVAL(ZB*(-1.)+2) + IF (IGSOURCEATBP.EQ.1) IGMINDEP=1. ! should use true minimum depth ... + IGPARS(6)=1+NINT(LOG(MAX(IGMAXDEP,1.0)/MAX(IGMINDEP,1.0))/LOG(1.1)) + IGPARS(7)=MAX(IGMINDEP,1.0) + IGPARS(8)=IGSOURCEATBP + IGPARS(9)=IGKDMIN + IGPARS(10)=IGFIXEDDEPTH + IGPARS(11)=IGEMPIRICAL**2 + IGPARS(12)=IGSTERMS +#endif + ! #ifdef W3_IC2 - IC2PARS(:)=0. - IF (IC2DISPER) IC2PARS(1)=1. - IC2PARS(2)=IC2TURB - IC2PARS(3)=IC2ROUGH - IC2PARS(4)=IC2REYNOLDS - IC2PARS(5)=IC2SMOOTH - IC2PARS(6)=IC2VISC - IC2PARS(7)=IC2TURBS - IC2PARS(8)=IC2DMAX -#endif -! + IC2PARS(:)=0. + IF (IC2DISPER) IC2PARS(1)=1. + IC2PARS(2)=IC2TURB + IC2PARS(3)=IC2ROUGH + IC2PARS(4)=IC2REYNOLDS + IC2PARS(5)=IC2SMOOTH + IC2PARS(6)=IC2VISC + IC2PARS(7)=IC2TURBS + IC2PARS(8)=IC2DMAX +#endif + ! #ifdef W3_IC3 - IC3PARS(:)=0. - IC3PARS(1)=IC3MAXTHK - IC3PARS(2)=IC2TURB - IC3PARS(3)=IC2ROUGH - IC3PARS(4)=IC2REYNOLDS - IC3PARS(5)=IC2SMOOTH - IC3PARS(6)=IC2VISC - IC3PARS(7)=IC2TURBS - IC3PARS(8)=IC3MAXCNC - IF (IC3CHENG) IC3PARS(9)=1.0 - IC3PARS(10)=IC3HILIM - IC3PARS(11)=IC3KILIM - IF (USECGICE) IC3PARS(12)=1.0 - IC3PARS(13)=IC3HICE - IC3PARS(14)=IC3VISC - IC3PARS(15)=IC3DENS - IC3PARS(16)=IC3ELAS -#endif -! + IC3PARS(:)=0. + IC3PARS(1)=IC3MAXTHK + IC3PARS(2)=IC2TURB + IC3PARS(3)=IC2ROUGH + IC3PARS(4)=IC2REYNOLDS + IC3PARS(5)=IC2SMOOTH + IC3PARS(6)=IC2VISC + IC3PARS(7)=IC2TURBS + IC3PARS(8)=IC3MAXCNC + IF (IC3CHENG) IC3PARS(9)=1.0 + IC3PARS(10)=IC3HILIM + IC3PARS(11)=IC3KILIM + IF (USECGICE) IC3PARS(12)=1.0 + IC3PARS(13)=IC3HICE + IC3PARS(14)=IC3VISC + IC3PARS(15)=IC3DENS + IC3PARS(16)=IC3ELAS +#endif + ! #ifdef W3_IC4 - IC4PARS(1)=IC4METHOD - IC4_KI=IC4KI - IC4_FC=IC4FC + IC4PARS(1)=IC4METHOD + IC4_KI=IC4KI + IC4_FC=IC4FC #endif -! + ! #ifdef W3_IC5 - IC5PARS(:)=0. - IC5PARS(1)=IC5MINIG - IC5PARS(2)=IC5MINWT - IC5PARS(3)=IC5MAXKRATIO - IC5PARS(4)=IC5MAXKI - IC5PARS(5)=IC5MINHW - IC5PARS(6)=IC5MAXITER - IC5PARS(7)=IC5RKICK - IC5PARS(8)=IC5KFILTER - IC5PARS(9)=IC5VEMOD -#endif -! + IC5PARS(:)=0. + IC5PARS(1)=IC5MINIG + IC5PARS(2)=IC5MINWT + IC5PARS(3)=IC5MAXKRATIO + IC5PARS(4)=IC5MAXKI + IC5PARS(5)=IC5MINHW + IC5PARS(6)=IC5MAXITER + IC5PARS(7)=IC5RKICK + IC5PARS(8)=IC5KFILTER + IC5PARS(9)=IC5VEMOD +#endif + ! #ifdef W3_IS2 - IS2PARS(1) = ISC1 - IS2PARS(2) = IS2BACKSCAT - IS2PARS(3)=0. - IF (IS2BREAK) IS2PARS(3)=1. - IS2PARS(4)=IS2C2 - IS2PARS(5)=IS2C3 - IS2PARS(6)=0. - IF (IS2DISP) IS2PARS(6)=1. - IS2PARS(7)=IS2DAMP - IS2PARS(8)=IS2FRAGILITY - IS2PARS(9)=IS2DMIN - IS2PARS(10)=0. - IF (IS2DUPDATE) IS2PARS(10)=1. - IS2PARS(11)=IS2CONC - IS2PARS(12)=ABS(IS2CREEPB) - IS2PARS(13)=IS2CREEPC - IS2PARS(14)=IS2CREEPD - IS2PARS(15)=IS2CREEPN - IS2PARS(16)=IS2BREAKE - IS2PARS(17)=IS2BREAKF - IS2PARS(18)=IS2WIM1 - IS2PARS(19)=IS2FLEXSTR - IS2PARS(20)=0. - IF (IS2ISOSCAT) IS2PARS(20)=1. - IS2PARS(21)=IS2ANDISD - IS2PARS(22)=IS2ANDISN - IS2PARS(23)=0. - IF (IS2ANDISB) IS2PARS(23)=1. - IS2PARS(24)=IS2ANDISE -#endif -! -! 9.d Estimates shoreline direction for reflection -! and shoreline treatment in general for UNST grids. -! NB: this is updated with moving water levels in W3ULEV -! AR: this is not anymore needed and will be deleted ... -! - IF (GTYPE.EQ.UNGTYPE) THEN - CALL SET_UG_IOBP + IS2PARS(1) = ISC1 + IS2PARS(2) = IS2BACKSCAT + IS2PARS(3)=0. + IF (IS2BREAK) IS2PARS(3)=1. + IS2PARS(4)=IS2C2 + IS2PARS(5)=IS2C3 + IS2PARS(6)=0. + IF (IS2DISP) IS2PARS(6)=1. + IS2PARS(7)=IS2DAMP + IS2PARS(8)=IS2FRAGILITY + IS2PARS(9)=IS2DMIN + IS2PARS(10)=0. + IF (IS2DUPDATE) IS2PARS(10)=1. + IS2PARS(11)=IS2CONC + IS2PARS(12)=ABS(IS2CREEPB) + IS2PARS(13)=IS2CREEPC + IS2PARS(14)=IS2CREEPD + IS2PARS(15)=IS2CREEPN + IS2PARS(16)=IS2BREAKE + IS2PARS(17)=IS2BREAKF + IS2PARS(18)=IS2WIM1 + IS2PARS(19)=IS2FLEXSTR + IS2PARS(20)=0. + IF (IS2ISOSCAT) IS2PARS(20)=1. + IS2PARS(21)=IS2ANDISD + IS2PARS(22)=IS2ANDISN + IS2PARS(23)=0. + IF (IS2ANDISB) IS2PARS(23)=1. + IS2PARS(24)=IS2ANDISE +#endif + ! + ! 9.d Estimates shoreline direction for reflection + ! and shoreline treatment in general for UNST grids. + ! NB: this is updated with moving water levels in W3ULEV + ! AR: this is not anymore needed and will be deleted ... + ! + IF (GTYPE.EQ.UNGTYPE) THEN + CALL SET_UG_IOBP #ifdef W3_REF1 - ELSE - CALL W3SETREF + ELSE + CALL W3SETREF #endif - END IF + END IF #ifdef W3_REF1 -! -! 9.a Reads shoreline slope (whith REF1 switch only) -! - ALLOCATE ( REFD(NX,NY), REFD2(NX,NY), REFS(NX,NY) ) - IF (REFMAP.EQ.0) THEN - REFS(:,:)=1. - ELSE -! -! 9.b Info from input file -! - IF (FLGNML) THEN - NDSTR = NML_SLOPE%IDF - VSC = NML_SLOPE%SF - IDLA = NML_SLOPE%IDLA - IDFT = NML_SLOPE%IDFM - RFORM = TRIM(NML_SLOPE%FORMAT) - FROM = TRIM(NML_SLOPE%FROM) - TNAME = TRIM(NML_SLOPE%FILENAME) + ! + ! 9.a Reads shoreline slope (whith REF1 switch only) + ! + ALLOCATE ( REFD(NX,NY), REFD2(NX,NY), REFS(NX,NY) ) + IF (REFMAP.EQ.0) THEN + REFS(:,:)=1. + ELSE + ! + ! 9.b Info from input file + ! + IF (FLGNML) THEN + NDSTR = NML_SLOPE%IDF + VSC = NML_SLOPE%SF + IDLA = NML_SLOPE%IDLA + IDFT = NML_SLOPE%IDFM + RFORM = TRIM(NML_SLOPE%FORMAT) + FROM = TRIM(NML_SLOPE%FROM) + TNAME = TRIM(NML_SLOPE%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & + FROM, TNAME + END IF + ! + IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 + ! + WRITE (NDSO,1977) NDSTR, VSC, IDLA, IDFT + IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM + IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME + ! + ! 9;c Open file and check if necessary + ! + IF ( NDSTR .EQ. NDSI ) THEN + IF ( IDFT .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSTR + CALL EXTCDE (23) ELSE CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & - FROM, TNAME END IF -! - IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. - IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 - IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 -! - WRITE (NDSO,1977) NDSTR, VSC, IDLA, IDFT - IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM - IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME -! -! 9;c Open file and check if necessary -! - IF ( NDSTR .EQ. NDSI ) THEN - IF ( IDFT .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSTR - CALL EXTCDE (23) + ELSE IF ( NDSTR .EQ. NDSG ) THEN + IF ( ( IDFM.EQ.3 .AND. IDFT.NE.3 ) .OR. & + ( IDFM.NE.3 .AND. IDFT.EQ.3 ) ) THEN + WRITE (NDSE,1005) IDFM, IDFT + CALL EXTCDE (24) + END IF + ELSE + IF ( IDFT .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=2000, & + IOSTAT=IERR) ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - ELSE IF ( NDSTR .EQ. NDSG ) THEN - IF ( ( IDFM.EQ.3 .AND. IDFT.NE.3 ) .OR. & - ( IDFM.NE.3 .AND. IDFT.EQ.3 ) ) THEN - WRITE (NDSE,1005) IDFM, IDFT - CALL EXTCDE (24) - END IF + OPEN (NDSTR, form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) ELSE - IF ( IDFT .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=2000, & - IOSTAT=IERR) - ELSE - OPEN (NDSTR, form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSTR, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF !end of (FROM.EQ.'NAME') - END IF !end of ( IDFT .EQ. 3 ) - END IF !end of ( NDSTR .EQ. NDSG ) -! -! 9.d Read the data -! -! CALL INA2R ( REFD, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & -! IDFM, RFORM, IDLA, VSC, 0.0) -! - IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) -! -! CALL INA2R ( REFD2, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & -! IDFM, RFORM, IDLA, VSC, 0.0) - CALL INA2R ( REFS, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, 0.0) - DO ISEA=1,NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - REFLC(3,ISEA) = REFS(IX,IY)*REFMAP - END DO -#endif -! -#ifdef W3_REF1 - NMAPB = 1 + (NX-1)/NCOL - WRITE (NDSO,1105) NMAPB -#endif -#ifdef W3_T + OPEN (NDSTR, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF !end of (FROM.EQ.'NAME') + END IF !end of ( IDFT .EQ. 3 ) + END IF !end of ( NDSTR .EQ. NDSG ) + ! + ! 9.d Read the data + ! + ! CALL INA2R ( REFD, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & + ! IDFM, RFORM, IDLA, VSC, 0.0) + ! + IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ! + ! CALL INA2R ( REFD2, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & + ! IDFM, RFORM, IDLA, VSC, 0.0) + CALL INA2R ( REFS, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, 0.0) + DO ISEA=1,NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + REFLC(3,ISEA) = REFS(IX,IY)*REFMAP + END DO + NMAPB = 1 + (NX-1)/NCOL + WRITE (NDSO,1105) NMAPB +#endif +#if defined W3_T && defined W3_REF1 + WRITE(NDSO,*) 'Maximum slope for reflection:',MAXVAL(REFS*REFMAP) +#endif + ! #ifdef W3_REF1 - WRITE(NDSO,*) 'Maximum slope for reflection:',MAXVAL(REFS*REFMAP) + DO IMAPB=1, NMAPB + IX0 = 1 + (IMAPB-1)*NCOL + IXN = MIN ( NX , IMAPB*NCOL ) #endif +#if defined W3_T && defined W3_REF1 + DO IY=NY,1,-1 + WRITE (NDSO,1101) (NINT(100.*REFS(IX,IY)*REFMAP),IX=IX0,IXN) + END DO #endif -! -#ifdef W3_REF1 - DO IMAPB=1, NMAPB - IX0 = 1 + (IMAPB-1)*NCOL - IXN = MIN ( NX , IMAPB*NCOL ) -#endif -#ifdef W3_T #ifdef W3_REF1 - DO IY=NY,1,-1 - WRITE (NDSO,1101) (NINT(100.*REFS(IX,IY)*REFMAP),IX=IX0,IXN) - END DO -#endif + WRITE (NDSO,*) ' ' + END DO + WRITE (NDSO,1106) + ! + WRITE (NDSO,*) + ! + END IF !end of (REFMAP.EQ.0) #endif -#ifdef W3_REF1 - WRITE (NDSO,*) ' ' - END DO - WRITE (NDSO,1106) -! - WRITE (NDSO,*) -! - END IF !end of (REFMAP.EQ.0) -#endif -! - DEALLOCATE ( ZBIN, TMPSTA, TMPMAP ) + ! + DEALLOCATE ( ZBIN, TMPSTA, TMPMAP ) #ifdef W3_RTD - DEALLOCATE ( AnglDin ) + DEALLOCATE ( AnglDin ) #endif -! -! 9.e Reads bottom information from file -! + ! + ! 9.e Reads bottom information from file + ! #ifdef W3_BT4 - ALLOCATE ( SED_D50FILE(NX,NY)) - IF ( SEDMAPD50 ) THEN + ALLOCATE ( SED_D50FILE(NX,NY)) + IF ( SEDMAPD50 ) THEN -! -! 9.e.1 Info from input file -! - IF (FLGNML) THEN - NDSTR = NML_SED%IDF - VSC = NML_SED%SF - IDLA = NML_SED%IDLA - IDFT = NML_SED%IDFM - RFORM = TRIM(NML_SED%FORMAT) - FROM = TRIM(NML_SED%FROM) - TNAME = TRIM(NML_SED%FILENAME) + ! + ! 9.e.1 Info from input file + ! + IF (FLGNML) THEN + NDSTR = NML_SED%IDF + VSC = NML_SED%SF + IDLA = NML_SED%IDLA + IDFT = NML_SED%IDFM + RFORM = TRIM(NML_SED%FORMAT) + FROM = TRIM(NML_SED%FROM) + TNAME = TRIM(NML_SED%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & + FROM, TNAME + END IF + ! + IF ( ABS(VSC) .LT. 1.E-7 ) THEN + VSC = 1. + ELSE + ! WARNING TO BE ADDED ... + END IF + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 + ! + WRITE (NDSO,1978) NDSTR, VSC, IDLA, IDFT + IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM + IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME + ! + ! 9.e.2 Open file and check if necessary + ! + IF ( NDSTR .EQ. NDSI ) THEN + IF ( IDFT .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSTR + CALL EXTCDE (23) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + ELSE IF ( NDSTR .EQ. NDSG ) THEN + IF ( ( IDFM.EQ.3 .AND. IDFT.NE.3 ) .OR. & + ( IDFM.NE.3 .AND. IDFT.EQ.3 ) ) THEN + WRITE (NDSE,1005) IDFM, IDFT + CALL EXTCDE (24) + END IF + ELSE + IF ( IDFT .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=2000, & + IOSTAT=IERR) ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & - FROM, TNAME + OPEN (NDSTR, form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) END IF -! - IF ( ABS(VSC) .LT. 1.E-7 ) THEN - VSC = 1. - ELSE -! WARNING TO BE ADDED ... + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSTR, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) END IF - IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 - IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 -! - WRITE (NDSO,1978) NDSTR, VSC, IDLA, IDFT - IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM - IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME -! -! 9.e.2 Open file and check if necessary -! - IF ( NDSTR .EQ. NDSI ) THEN - IF ( IDFT .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSTR - CALL EXTCDE (23) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - ELSE IF ( NDSTR .EQ. NDSG ) THEN - IF ( ( IDFM.EQ.3 .AND. IDFT.NE.3 ) .OR. & - ( IDFM.NE.3 .AND. IDFT.EQ.3 ) ) THEN - WRITE (NDSE,1005) IDFM, IDFT - CALL EXTCDE (24) - END IF - ELSE - IF ( IDFT .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=2000, & - IOSTAT=IERR) - ELSE - OPEN (NDSTR, form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSTR, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - END IF - END IF -! -! 9.e.3 Read the data -! - CALL INA2R ( SED_D50FILE, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, VOF) -! - IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) -! - WRITE (NDSO,*) 'Min and Max values of grain sizes:',MINVAL(SED_D50FILE), MAXVAL(SED_D50FILE) - WRITE (NDSO,*) -! - ELSE - SED_D50FILE(:,:)=SED_D50_UNIFORM END IF -! - DO IY=1, NY - DO IX=1, NX - ISEA = MAPFS (IY,IX) - SED_D50(ISEA) = SED_D50FILE(IX,IY) - SED_D50(ISEA) = MAX(SED_D50(ISEA),1E-5) - ! Critical Shields number, Soulsby, R.L. and R J S W Whitehouse - ! Threshold of sed. motion in coastal environments, Proc. Pacific Coasts and - ! ports, 1997 conference, Christchurch, p149-154, University of Cantebury, NZ - SED_DSTAR=(GRAV*(SED_SG-1)/nu_water**2)**(0.333333)*SED_D50(ISEA) - SED_PSIC(ISEA)=0.3/(1+1.2*SED_DSTAR)+0.55*(1-exp(-0.02*SED_DSTAR)) + END IF + ! + ! 9.e.3 Read the data + ! + CALL INA2R ( SED_D50FILE, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF) + ! + IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ! + WRITE (NDSO,*) 'Min and Max values of grain sizes:',MINVAL(SED_D50FILE), MAXVAL(SED_D50FILE) + WRITE (NDSO,*) + ! + ELSE + SED_D50FILE(:,:)=SED_D50_UNIFORM + END IF + ! + DO IY=1, NY + DO IX=1, NX + ISEA = MAPFS (IY,IX) + SED_D50(ISEA) = SED_D50FILE(IX,IY) + SED_D50(ISEA) = MAX(SED_D50(ISEA),1E-5) + ! Critical Shields number, Soulsby, R.L. and R J S W Whitehouse + ! Threshold of sed. motion in coastal environments, Proc. Pacific Coasts and + ! ports, 1997 conference, Christchurch, p149-154, University of Cantebury, NZ + SED_DSTAR=(GRAV*(SED_SG-1)/nu_water**2)**(0.333333)*SED_D50(ISEA) + SED_PSIC(ISEA)=0.3/(1+1.2*SED_DSTAR)+0.55*(1-exp(-0.02*SED_DSTAR)) #endif #ifdef W3_BT4 - END DO - END DO -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 10. Prepare output boundary points. -! ILOOP = 1 to count NFBPO and NBO -! ILOOP = 2 to fill data arrays -! - WRITE (NDSO,990) - IF ( .NOT. FLGNML ) & - OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_grid.scratch',FORM='FORMATTED') -! - DO ILOOP = 1, 2 -! - IF ( ILOOP.EQ.2 ) CALL W3DMO5 ( 1, NDST, NDSE, 2 ) -! - I = 1 - NBOTOT = 0 - NFBPO = 0 - NBO(0) = 0 - NBO2(0)= 0 - FIRST = .TRUE. - IF ( .NOT. FLGNML ) THEN - REWIND (NDSS) - IF ( ILOOP .EQ. 1 ) THEN - NDSI2 = NDSI - ELSE - NDSI2 = NDSS - END IF + END DO + END DO +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 10. Prepare output boundary points. + ! ILOOP = 1 to count NFBPO and NBO + ! ILOOP = 2 to fill data arrays + ! + WRITE (NDSO,990) + IF ( .NOT. FLGNML ) & + OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_grid.scratch',FORM='FORMATTED') + ! + DO ILOOP = 1, 2 + ! + IF ( ILOOP.EQ.2 ) CALL W3DMO5 ( 1, NDST, NDSE, 2 ) + ! + I = 1 + NBOTOT = 0 + NFBPO = 0 + NBO(0) = 0 + NBO2(0)= 0 + FIRST = .TRUE. + IF ( .NOT. FLGNML ) THEN + REWIND (NDSS) + IF ( ILOOP .EQ. 1 ) THEN + NDSI2 = NDSI + ELSE + NDSI2 = NDSS END IF -! - DO - IF (FLGNML) THEN - ! outbound lines - IF (NML_OUTBND_COUNT%N_LINE.GT.0 .AND. I.LE.NML_OUTBND_COUNT%N_LINE) THEN - XO0 = NML_OUTBND_LINE(I)%X0 - YO0 = NML_OUTBND_LINE(I)%Y0 - DXO = NML_OUTBND_LINE(I)%DX - DYO = NML_OUTBND_LINE(I)%DY - NPO = NML_OUTBND_LINE(I)%NP - I=I+1 - ELSE - NPO=0 - END IF + END IF + ! + DO + IF (FLGNML) THEN + ! outbound lines + IF (NML_OUTBND_COUNT%N_LINE.GT.0 .AND. I.LE.NML_OUTBND_COUNT%N_LINE) THEN + XO0 = NML_OUTBND_LINE(I)%X0 + YO0 = NML_OUTBND_LINE(I)%Y0 + DXO = NML_OUTBND_LINE(I)%DX + DYO = NML_OUTBND_LINE(I)%DY + NPO = NML_OUTBND_LINE(I)%NP + I=I+1 ELSE - CALL NEXTLN ( COMSTR , NDSI2 , NDSE ) - READ (NDSI2,*,END=2001,ERR=2002) XO0, YO0, DXO, DYO, NPO + NPO=0 END IF -! - IF ( .NOT. FLGNML .AND. ILOOP .EQ. 1 ) THEN - BACKSPACE (NDSI) - READ (NDSI,'(A)') LINE - WRITE (NDSS,'(A)') LINE - END IF -! -! ... Check if new file to be used -! - FIRST = FIRST .OR. NPO.LE.0 - NPO = ABS(NPO) -! -! ... Preparations for new output file including end check -! and output for last output file -! - IF ( FIRST ) THEN -! - FIRST = .FALSE. -! + ELSE + CALL NEXTLN ( COMSTR , NDSI2 , NDSE ) + READ (NDSI2,*,END=2001,ERR=2002) XO0, YO0, DXO, DYO, NPO + END IF + ! + IF ( .NOT. FLGNML .AND. ILOOP .EQ. 1 ) THEN + BACKSPACE (NDSI) + READ (NDSI,'(A)') LINE + WRITE (NDSS,'(A)') LINE + END IF + ! + ! ... Check if new file to be used + ! + FIRST = FIRST .OR. NPO.LE.0 + NPO = ABS(NPO) + ! + ! ... Preparations for new output file including end check + ! and output for last output file + ! + IF ( FIRST ) THEN + ! + FIRST = .FALSE. + ! #ifdef W3_RTD - IF ( NPO.NE.0 ) THEN - ! Destination pole lat, lon from namelist - bPolat = BPLAT(NFBPO+1) - bPolon = BPLON(NFBPO+1) - END IF - ! + IF ( NPO.NE.0 ) THEN + ! Destination pole lat, lon from namelist + bPolat = BPLAT(NFBPO+1) + bPolon = BPLON(NFBPO+1) + END IF + ! #endif - IF ( NFBPO.GE.1 .AND. ILOOP.EQ.2 ) THEN - WRITE (NDSO,991) NFBPO, NBO(NFBPO) - NBO(NFBPO-1), & - NBO2(NFBPO) - NBO2(NFBPO-1) + IF ( NFBPO.GE.1 .AND. ILOOP.EQ.2 ) THEN + WRITE (NDSO,991) NFBPO, NBO(NFBPO) - NBO(NFBPO-1), & + NBO2(NFBPO) - NBO2(NFBPO-1) #ifdef W3_RTD - ! Print dest. Pole lat/lon if either the dest or present grid is rotated - IF ( BPLAT(NFBPO) < 90. .OR. Polat < 90. ) & - WRITE (NDSO,1991) BPLAT(NFBPO), BPLON(NFBPO) - ! + ! Print dest. Pole lat/lon if either the dest or present grid is rotated + IF ( BPLAT(NFBPO) < 90. .OR. Polat < 90. ) & + WRITE (NDSO,1991) BPLAT(NFBPO), BPLON(NFBPO) + ! #endif #ifdef W3_O1 - IF ( NBO(NFBPO) - NBO(NFBPO-1) .EQ. 1 ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSO,992) - ELSE - WRITE (NDSO,2992) - END IF - ELSE - IF ( FLAGLL ) THEN - WRITE (NDSO,1992) - ELSE - WRITE (NDSO,3992) - END IF - END IF - IP0 = NBO(NFBPO-1)+1 - IPN = NBO(NFBPO) - IPH = IP0 + (IPN-IP0-1)/2 - IPI = IPH -IP0 + 1 + MOD(IPN-IP0+1,2) - DO IP=IP0, IPH - IF ( FLAGLL ) THEN - WRITE (NDSO,1993) IP-NBO(NFBPO-1), & - FACTOR*XBPO(IP), & - FACTOR*YBPO(IP), & - IP+IPI-NBO(NFBPO-1), & - FACTOR*XBPO(IP+IPI), & - FACTOR*YBPO(IP+IPI) - ELSE - WRITE (NDSO,3993) IP-NBO(NFBPO-1), & - FACTOR*XBPO(IP), & - FACTOR*YBPO(IP), & - IP+IPI-NBO(NFBPO-1), & - FACTOR*XBPO(IP+IPI), & - FACTOR*YBPO(IP+IPI) - END IF - END DO - IF ( MOD(IPN-IP0+1,2) .EQ. 1 ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSO, 993) IPH+1-NBO(NFBPO-1), & - FACTOR*XBPO(IPH+1), & - FACTOR*YBPO(IPH+1) - ELSE - WRITE (NDSO,2993) IPH+1-NBO(NFBPO-1), & - FACTOR*XBPO(IPH+1), & - FACTOR*YBPO(IPH+1) - END IF - END IF - WRITE (NDSO,*) -#endif - END IF -! - IF ( NPO .EQ. 0 ) EXIT -! - NFBPO = NFBPO + 1 - IF ( NFBPO .GT. 9 ) THEN - WRITE (NDSE,1006) - CALL EXTCDE ( 50 ) - END IF - NBO2(NFBPO) = NBO2(NFBPO-1) - NBO(NFBPO) = NBOTOT -! + IF ( NBO(NFBPO) - NBO(NFBPO-1) .EQ. 1 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSO,992) + ELSE + WRITE (NDSO,2992) + END IF + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSO,1992) + ELSE + WRITE (NDSO,3992) + END IF END IF -! -! ... Loop over line segment - - - - - - - - - - - - - - - - - - - - - -! -#ifdef W3_RTD - ! If either base or destination grid is rotated lat-lon - IF ( allocated(BDYLON) .eqv. .TRUE. ) THEN - deallocate( BDYLON, BDYLAT ) - IF ( bPolat < 90. .OR. Polat < 90. ) & - deallocate( ELatbdy, ELonbdy, Anglbdy ) + IP0 = NBO(NFBPO-1)+1 + IPN = NBO(NFBPO) + IPH = IP0 + (IPN-IP0-1)/2 + IPI = IPH -IP0 + 1 + MOD(IPN-IP0+1,2) + DO IP=IP0, IPH + IF ( FLAGLL ) THEN + WRITE (NDSO,1993) IP-NBO(NFBPO-1), & + FACTOR*XBPO(IP), & + FACTOR*YBPO(IP), & + IP+IPI-NBO(NFBPO-1), & + FACTOR*XBPO(IP+IPI), & + FACTOR*YBPO(IP+IPI) + ELSE + WRITE (NDSO,3993) IP-NBO(NFBPO-1), & + FACTOR*XBPO(IP), & + FACTOR*YBPO(IP), & + IP+IPI-NBO(NFBPO-1), & + FACTOR*XBPO(IP+IPI), & + FACTOR*YBPO(IP+IPI) + END IF + END DO + IF ( MOD(IPN-IP0+1,2) .EQ. 1 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSO, 993) IPH+1-NBO(NFBPO-1), & + FACTOR*XBPO(IPH+1), & + FACTOR*YBPO(IPH+1) + ELSE + WRITE (NDSO,2993) IPH+1-NBO(NFBPO-1), & + FACTOR*XBPO(IPH+1), & + FACTOR*YBPO(IPH+1) + END IF END IF - allocate( BDYLON(NPO), BDYLAT(NPO)) + WRITE (NDSO,*) +#endif + END IF + ! + IF ( NPO .EQ. 0 ) EXIT + ! + NFBPO = NFBPO + 1 + IF ( NFBPO .GT. 9 ) THEN + WRITE (NDSE,1006) + CALL EXTCDE ( 50 ) + END IF + NBO2(NFBPO) = NBO2(NFBPO-1) + NBO(NFBPO) = NBOTOT + ! + END IF + ! + ! ... Loop over line segment - - - - - - - - - - - - - - - - - - - - - + ! +#ifdef W3_RTD + ! If either base or destination grid is rotated lat-lon + IF ( allocated(BDYLON) .eqv. .TRUE. ) THEN + deallocate( BDYLON, BDYLAT ) IF ( bPolat < 90. .OR. Polat < 90. ) & - allocate( ELatbdy(NPO), ELonbdy(NPO), Anglbdy(NPO) ) - ! + deallocate( ELatbdy, ELonbdy, Anglbdy ) + END IF + allocate( BDYLON(NPO), BDYLAT(NPO)) + IF ( bPolat < 90. .OR. Polat < 90. ) & + allocate( ELatbdy(NPO), ELonbdy(NPO), Anglbdy(NPO) ) + ! #endif #ifdef W3_T - WRITE (NDST,9090) + WRITE (NDST,9090) #endif -! - DO IP=1, NPO -! - XO = XO0 + REAL(IP-1)*DXO - YO = YO0 + REAL(IP-1)*DYO + ! + DO IP=1, NPO + ! + XO = XO0 + REAL(IP-1)*DXO + YO = YO0 + REAL(IP-1)*DYO #ifdef W3_RTD - ! - ! Boundary points are specified in coordinates of the destination grid - ! - ! Collect the line segment points into arrays - BDYLON(IP) = XO - BDYLAT(IP) = YO - ! Close the loop before calculating rotated lat-lon coordinates. - END DO + ! + ! Boundary points are specified in coordinates of the destination grid + ! + ! Collect the line segment points into arrays + BDYLON(IP) = XO + BDYLAT(IP) = YO + ! Close the loop before calculating rotated lat-lon coordinates. + END DO - ! Create one or two sets of the segment points: - ! 1. (BDYLAT, BDYLON) in standard lat-lon coordinates, - ! 2. Also (ELatbdy, ELonbdy) in case the base grid is rotated - - IF ( bPolat < 90. ) THEN - ! The destination grid is rotated (std->rot or rot->rot) - ! Change BDYLAT, BDYLON to their standard lat-lon positions - ! Let ELatbdy,ELonbdy contain the rotated lat-lon coordinates - ELatbdy(:) = BDYLAT(:) - ELonbdy(:) = BDYLON(:) - CALL W3EQTOLL ( ELatbdy, ELonbdy, BDYLAT, BDYLON, & - & Anglbdy, bPolat, bPolon, NPO ) - ! Let the standard longitudes BDYLON be within the range [-180.,180.[ - ! or [0., 360.[ depending on the grid pole - IF ( Polon < -90. .OR. Polon > 90. ) THEN - BDYLON(:) = MOD( BDYLON(:) + 180., 360. ) - 180. - ELSE - BDYLON(:) = MOD( BDYLON(:) + 360., 360. ) - END IF - END IF ! bPolat < 90. - ! From now, BDYLAT, BDYLON are defined in standard lat-lon coordinates - ! - IF ( Polat < 90. ) THEN - ! The base grid is rotated (rot->std or rot->rot) - ! Find lat-lon in coordinates of the rotated base grid - CALL W3LLTOEQ ( BDYLAT, BDYLON, ELatbdy, ELonbdy, & - & Anglbdy, Polat, Polon, NPO ) - END IF - ! - ! Take up again the loop over the line segment points - DO IP=1, NPO - IF ( Polat < 90. ) THEN - ! The base grid is rotated (rot->std, rot->rot) - ! (The std. lat-lon values BDYLAT, BDYLON go to YBPO, XBPO) - XO = ELonbdy(IP) - YO = ELatbdy(IP) - ELSE - ! The base grid is standard geographic (std->rot or std->std) - XO = BDYLON(IP) - YO = BDYLAT(IP) - END IF + ! Create one or two sets of the segment points: + ! 1. (BDYLAT, BDYLON) in standard lat-lon coordinates, + ! 2. Also (ELatbdy, ELonbdy) in case the base grid is rotated + + IF ( bPolat < 90. ) THEN + ! The destination grid is rotated (std->rot or rot->rot) + ! Change BDYLAT, BDYLON to their standard lat-lon positions + ! Let ELatbdy,ELonbdy contain the rotated lat-lon coordinates + ELatbdy(:) = BDYLAT(:) + ELonbdy(:) = BDYLON(:) + CALL W3EQTOLL ( ELatbdy, ELonbdy, BDYLAT, BDYLON, & + & Anglbdy, bPolat, bPolon, NPO ) + ! Let the standard longitudes BDYLON be within the range [-180.,180.[ + ! or [0., 360.[ depending on the grid pole + IF ( Polon < -90. .OR. Polon > 90. ) THEN + BDYLON(:) = MOD( BDYLON(:) + 180., 360. ) - 180. + ELSE + BDYLON(:) = MOD( BDYLON(:) + 360., 360. ) + END IF + END IF ! bPolat < 90. + ! From now, BDYLAT, BDYLON are defined in standard lat-lon coordinates + ! + IF ( Polat < 90. ) THEN + ! The base grid is rotated (rot->std or rot->rot) + ! Find lat-lon in coordinates of the rotated base grid + CALL W3LLTOEQ ( BDYLAT, BDYLON, ELatbdy, ELonbdy, & + & Anglbdy, Polat, Polon, NPO ) + END IF + ! + ! Take up again the loop over the line segment points + DO IP=1, NPO + IF ( Polat < 90. ) THEN + ! The base grid is rotated (rot->std, rot->rot) + ! (The std. lat-lon values BDYLAT, BDYLON go to YBPO, XBPO) + XO = ELonbdy(IP) + YO = ELatbdy(IP) + ELSE + ! The base grid is standard geographic (std->rot or std->std) + XO = BDYLON(IP) + YO = BDYLAT(IP) + END IF #endif -! -! ... Compute bilinear remapping weights -! - INGRID = W3GRMP( GSU, XO, YO, IXR, IYR, RD ) -! -! Change cell-corners from counter-clockwise to column-major order - IX = IXR(3); IY = IYR(3); X = RD(3); - IXR(3) = IXR(4); IYR(3) = IYR(4); RD(3) = RD(4); - IXR(4) = IX ; IYR(4) = IY ; RD(4) = X ; -! + ! + ! ... Compute bilinear remapping weights + ! + INGRID = W3GRMP( GSU, XO, YO, IXR, IYR, RD ) + ! + ! Change cell-corners from counter-clockwise to column-major order + IX = IXR(3); IY = IYR(3); X = RD(3); + IXR(3) = IXR(4); IYR(3) = IYR(4); RD(3) = RD(4); + IXR(4) = IX ; IYR(4) = IY ; RD(4) = X ; + ! #ifdef W3_T - WRITE (NDST,9091) FACTOR*XO, FACTOR*YO, & - (IXR(J), IYR(J), RD(J), J=1,4) -#endif -! -! ... Check if point in grid -! - IF ( INGRID ) THEN -! -! ... Check if point not on land -! - IF ( ( MAPSTA(IYR(1),IXR(1)).GT.0 .AND. & - RD(1).GT.0.05 ) .OR. & - ( MAPSTA(IYR(2),IXR(2)).GT.0 .AND. & - RD(2).GT.0.05 ) .OR. & - ( MAPSTA(IYR(3),IXR(3)).GT.0 .AND. & - RD(3).GT.0.05 ) .OR. & - ( MAPSTA(IYR(4),IXR(4)).GT.0 .AND. & - RD(4).GT.0.05 ) ) THEN -! -! ... Check storage and store coordinates -! - NBOTOT = NBOTOT + 1 - IF ( ILOOP .EQ. 1 ) CYCLE -! + WRITE (NDST,9091) FACTOR*XO, FACTOR*YO, & + (IXR(J), IYR(J), RD(J), J=1,4) +#endif + ! + ! ... Check if point in grid + ! + IF ( INGRID ) THEN + ! + ! ... Check if point not on land + ! + IF ( ( MAPSTA(IYR(1),IXR(1)).GT.0 .AND. & + RD(1).GT.0.05 ) .OR. & + ( MAPSTA(IYR(2),IXR(2)).GT.0 .AND. & + RD(2).GT.0.05 ) .OR. & + ( MAPSTA(IYR(3),IXR(3)).GT.0 .AND. & + RD(3).GT.0.05 ) .OR. & + ( MAPSTA(IYR(4),IXR(4)).GT.0 .AND. & + RD(4).GT.0.05 ) ) THEN + ! + ! ... Check storage and store coordinates + ! + NBOTOT = NBOTOT + 1 + IF ( ILOOP .EQ. 1 ) CYCLE + ! #ifdef W3_RTD - ! BDYLAT, BDYLON contain Y0, X0, which are remapped to standard lat/lon. - ! BDYLAT, BDYLON are stored in the mod_def file. - IF ( Polat < 90. ) THEN - XO = BDYLON(IP) - YO = BDYLAT(IP) - END IF + ! BDYLAT, BDYLON contain Y0, X0, which are remapped to standard lat/lon. + ! BDYLAT, BDYLON are stored in the mod_def file. + IF ( Polat < 90. ) THEN + XO = BDYLON(IP) + YO = BDYLAT(IP) + END IF #endif - XBPO(NBOTOT) = XO - YBPO(NBOTOT) = YO -! -! ... Interpolation factors -! - RDTOT = 0. - DO J=1, 4 - IF ( MAPSTA(IYR(J),IXR(J)).GT.0 .AND. & - RD(J).GT.0.05 ) THEN - RDBPO(NBOTOT,J) = RD(J) - ELSE - RDBPO(NBOTOT,J) = 0. - END IF - RDTOT = RDTOT + RDBPO(NBOTOT,J) - END DO -! - DO J=1, 4 - RDBPO(NBOTOT,J) = RDBPO(NBOTOT,J) / RDTOT - END DO -! + XBPO(NBOTOT) = XO + YBPO(NBOTOT) = YO + ! + ! ... Interpolation factors + ! + RDTOT = 0. + DO J=1, 4 + IF ( MAPSTA(IYR(J),IXR(J)).GT.0 .AND. & + RD(J).GT.0.05 ) THEN + RDBPO(NBOTOT,J) = RD(J) + ELSE + RDBPO(NBOTOT,J) = 0. + END IF + RDTOT = RDTOT + RDBPO(NBOTOT,J) + END DO + ! + DO J=1, 4 + RDBPO(NBOTOT,J) = RDBPO(NBOTOT,J) / RDTOT + END DO + ! #ifdef W3_T WRITE (NDST,9092) RDTOT, (RDBPO(NBOTOT,J),J=1,4) #endif -! -! ... Determine sea and interpolation point counters -! - DO J=1, 4 - ISEAI(J) = MAPFS(IYR(J),IXR(J)) - END DO -! - DO J=1, 4 - IF ( ISEAI(J).EQ.0 .OR. RDBPO(NBOTOT,J).EQ. 0. ) THEN - IPBPO(NBOTOT,J) = 0 - ELSE - FLNEW = .TRUE. - DO IST=NBO2(NFBPO-1)+1, NBO2(NFBPO) - IF ( ISEAI(J) .EQ. ISBPO(IST) ) THEN - FLNEW = .FALSE. - IPBPO(NBOTOT,J) = IST - NBO2(NFBPO-1) - END IF - END DO - IF ( FLNEW ) THEN - NBO2(NFBPO) = NBO2(NFBPO) + 1 - IPBPO(NBOTOT,J) = NBO2(NFBPO) - NBO2(NFBPO-1) - ISBPO(NBO2(NFBPO)) = ISEAI(J) - END IF + ! + ! ... Determine sea and interpolation point counters + ! + DO J=1, 4 + ISEAI(J) = MAPFS(IYR(J),IXR(J)) + END DO + ! + DO J=1, 4 + IF ( ISEAI(J).EQ.0 .OR. RDBPO(NBOTOT,J).EQ. 0. ) THEN + IPBPO(NBOTOT,J) = 0 + ELSE + FLNEW = .TRUE. + DO IST=NBO2(NFBPO-1)+1, NBO2(NFBPO) + IF ( ISEAI(J) .EQ. ISBPO(IST) ) THEN + FLNEW = .FALSE. + IPBPO(NBOTOT,J) = IST - NBO2(NFBPO-1) END IF END DO -! + IF ( FLNEW ) THEN + NBO2(NFBPO) = NBO2(NFBPO) + 1 + IPBPO(NBOTOT,J) = NBO2(NFBPO) - NBO2(NFBPO-1) + ISBPO(NBO2(NFBPO)) = ISEAI(J) + END IF + END IF + END DO + ! #ifdef W3_T - WRITE (NDST,9093) ISEAI, (IPBPO(NBOTOT,J),J=1,4) + WRITE (NDST,9093) ISEAI, (IPBPO(NBOTOT,J),J=1,4) #endif -! -! ... Error output -! - ELSE - IF ( FLAGLL ) THEN - WRITE (NDSE,2995) FACTOR*XO, FACTOR*YO - ELSE - WRITE (NDSE,995) FACTOR*XO, FACTOR*YO - END IF - END IF + ! + ! ... Error output + ! + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSE,2995) FACTOR*XO, FACTOR*YO ELSE - IF ( FLAGLL ) THEN - WRITE (NDSE,2994) FACTOR*XO, FACTOR*YO - ELSE - WRITE (NDSE,994) FACTOR*XO, FACTOR*YO - END IF + WRITE (NDSE,995) FACTOR*XO, FACTOR*YO END IF -! - END DO -! - NBO(NFBPO) = NBOTOT -! -! ... Branch back to read. -! - END DO -! -! ... End of ILOOP loop -! - END DO -! - IF ( .NOT. FLGNML ) CLOSE ( NDSS, STATUS='DELETE' ) -! - FLBPO = NBOTOT .GT. 0 - IF ( .NOT. FLBPO ) THEN - WRITE (NDSO,996) - ELSE - WRITE (NDSO,997) NBOTOT, NBO2(NFBPO) - END IF -! -#ifdef W3_T0 - WRITE (NDST,9095) - DO IFILE=1, NFBPO - DO IP=NBO2(IFILE-1)+1, NBO2(IFILE) - WRITE (NDST,9096) IFILE, IP-NBO2(IFILE-1), ISBPO(IP) - END DO - END DO -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!10. Write model definition file. -! - WRITE (NDSO,999) - CALL W3IOGR ( 'WRITE', NDSM ) -! - CLOSE (NDSM) -! - GOTO 2222 -! -! Escape locations read errors : -! - 2000 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 60 ) -! - 2001 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 61 ) -! - 2002 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 62 ) -! - 2003 CONTINUE - WRITE (NDSE,1003) - CALL EXTCDE ( 64 ) -! - 2222 CONTINUE - IF ( GTYPE .NE. UNGTYPE) THEN - IF ( NX*NY .NE. NSEA ) THEN - WRITE (NDSO,9997) NX, NY, NX*NY, NSEA, & - 100.*REAL(NSEA)/REAL(NX*NY), NBI, NLAND, NBT - ELSE - WRITE (NDSO,9998) NX, NY, NX*NY, NSEA, NBI, NLAND, NBT END IF - ELSE IF ( GTYPE .EQ. UNGTYPE ) THEN - IF ( NX*NY .NE. NSEA ) THEN - WRITE (NDSO,9997) 0, 0, NX*NY, NSEA, & - 100.*REAL(NSEA)/REAL(NX*NY), NBI, NLAND, NBT + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSE,2994) FACTOR*XO, FACTOR*YO ELSE - WRITE (NDSO,9998) 0, 0, NX*NY, NSEA, NBI, NLAND, NBT + WRITE (NDSE,994) FACTOR*XO, FACTOR*YO END IF - ENDIF ! GTYPE .EQ. UNGTYPE - - WRITE (NDSO,9999) + END IF + ! + END DO + ! + NBO(NFBPO) = NBOTOT + ! + ! ... Branch back to read. + ! + END DO + ! + ! ... End of ILOOP loop + ! + END DO + ! + IF ( .NOT. FLGNML ) CLOSE ( NDSS, STATUS='DELETE' ) + ! + FLBPO = NBOTOT .GT. 0 + IF ( .NOT. FLBPO ) THEN + WRITE (NDSO,996) + ELSE + WRITE (NDSO,997) NBOTOT, NBO2(NFBPO) + END IF + ! +#ifdef W3_T0 + WRITE (NDST,9095) + DO IFILE=1, NFBPO + DO IP=NBO2(IFILE-1)+1, NBO2(IFILE) + WRITE (NDST,9096) IFILE, IP-NBO2(IFILE-1), ISBPO(IP) + END DO + END DO +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !10. Write model definition file. + ! + WRITE (NDSO,999) + CALL W3IOGR ( 'WRITE', NDSM ) + ! + CLOSE (NDSM) + ! + GOTO 2222 + ! + ! Escape locations read errors : + ! +2000 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 60 ) + ! +2001 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 61 ) + ! +2002 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 62 ) + ! +2003 CONTINUE + WRITE (NDSE,1003) + CALL EXTCDE ( 64 ) + ! +2222 CONTINUE + IF ( GTYPE .NE. UNGTYPE) THEN + IF ( NX*NY .NE. NSEA ) THEN + WRITE (NDSO,9997) NX, NY, NX*NY, NSEA, & + 100.*REAL(NSEA)/REAL(NX*NY), NBI, NLAND, NBT + ELSE + WRITE (NDSO,9998) NX, NY, NX*NY, NSEA, NBI, NLAND, NBT + END IF + ELSE IF ( GTYPE .EQ. UNGTYPE ) THEN + IF ( NX*NY .NE. NSEA ) THEN + WRITE (NDSO,9997) 0, 0, NX*NY, NSEA, & + 100.*REAL(NSEA)/REAL(NX*NY), NBI, NLAND, NBT + ELSE + WRITE (NDSO,9998) 0, 0, NX*NY, NSEA, NBI, NLAND, NBT + END IF + ENDIF ! GTYPE .EQ. UNGTYPE + + WRITE (NDSO,9999) #ifdef W3_SCRIP - GRID1_UNITS='degrees' ! the other option is radians...we don't use this - GRID1_NAME='src' ! this is not used, except for netcdf output - CALL GET_SCRIP_INFO(1, & - & GRID1_CENTER_LON, GRID1_CENTER_LAT, & - & GRID1_CORNER_LON, GRID1_CORNER_LAT, GRID1_MASK, & - & GRID1_DIMS, GRID1_SIZE, GRID1_CORNERS, GRID1_RANK) + GRID1_UNITS='degrees' ! the other option is radians...we don't use this + GRID1_NAME='src' ! this is not used, except for netcdf output + CALL GET_SCRIP_INFO(1, & + & GRID1_CENTER_LON, GRID1_CENTER_LAT, & + & GRID1_CORNER_LON, GRID1_CORNER_LAT, GRID1_MASK, & + & GRID1_DIMS, GRID1_SIZE, GRID1_CORNERS, GRID1_RANK) + - #endif #ifdef W3_SCRIP - IF (GTYPE .EQ. UNGTYPE) THEN - GRID1_RANK=1 - DEALLOCATE(GRID1_DIMS) - ALLOCATE(GRID1_DIMS(GRID1_RANK)) - GRID1_DIMS(1) = GRID1_SIZE - ENDIF + IF (GTYPE .EQ. UNGTYPE) THEN + GRID1_RANK=1 + DEALLOCATE(GRID1_DIMS) + ALLOCATE(GRID1_DIMS(GRID1_RANK)) + GRID1_DIMS(1) = GRID1_SIZE + ENDIF #endif #ifdef W3_SCRIP - DO I = 1,GRID1_SIZE - IF (GRID1_CENTER_LON(I) < 0.0) THEN - GRID1_CENTER_LON(I) = GRID1_CENTER_LON(I)+360.0 - ENDIF - DO J = 1,GRID1_CORNERS - IF (GRID1_CORNER_LON(J,I) < 0.0) THEN - GRID1_CORNER_LON(J,I) = GRID1_CORNER_LON(J,I)+360.0 - ENDIF - ENDDO - ENDDO + DO I = 1,GRID1_SIZE + IF (GRID1_CENTER_LON(I) < 0.0) THEN + GRID1_CENTER_LON(I) = GRID1_CENTER_LON(I)+360.0 + ENDIF + DO J = 1,GRID1_CORNERS + IF (GRID1_CORNER_LON(J,I) < 0.0) THEN + GRID1_CORNER_LON(J,I) = GRID1_CORNER_LON(J,I)+360.0 + ENDIF + ENDDO + ENDDO #endif #ifdef W3_SCRIPNC - IERR = NF90_CREATE(TRIM('scrip.nc'), NF90_NETCDF4, NCID) - IERR = NF90_DEF_DIM(NCID, 'grid_size', GRID1_SIZE, grid_size_dimid) - IERR = NF90_DEF_DIM(NCID, 'grid_corners', GRID1_CORNERS, grid_corners_dimid) - IERR = NF90_DEF_DIM(NCID, 'grid_rank', GRID1_RANK, grid_rank_dimid) + IERR = NF90_CREATE(TRIM('scrip.nc'), NF90_NETCDF4, NCID) + IERR = NF90_DEF_DIM(NCID, 'grid_size', GRID1_SIZE, grid_size_dimid) + IERR = NF90_DEF_DIM(NCID, 'grid_corners', GRID1_CORNERS, grid_corners_dimid) + IERR = NF90_DEF_DIM(NCID, 'grid_rank', GRID1_RANK, grid_rank_dimid) #endif #ifdef W3_SCRIPNC - IERR = NF90_DEF_VAR(NCID, 'grid_center_lat', NF90_DOUBLE, & - (/grid_size_dimid/),grid_center_lat_varid) - IERR = NF90_DEF_VAR(NCID, 'grid_center_lon', NF90_DOUBLE, & - (/grid_size_dimid/),grid_center_lon_varid) - IERR = NF90_DEF_VAR(NCID, 'grid_corner_lat', NF90_DOUBLE, & - (/grid_corners_dimid,grid_size_dimid/), & - grid_corner_lat_varid) - IERR = NF90_DEF_VAR(NCID, 'grid_corner_lon', NF90_DOUBLE, & - (/grid_corners_dimid,grid_size_dimid/), & - grid_corner_lon_varid) - IERR = NF90_DEF_VAR(NCID, 'grid_imask', NF90_INT, & - (/grid_size_dimid/),grid_imask_varid) - IERR = NF90_DEF_VAR(NCID, 'grid_dims', NF90_INT, & - (/grid_rank_dimid/),grid_dims_varid) - IERR = NF90_ENDDEF(NCID) + IERR = NF90_DEF_VAR(NCID, 'grid_center_lat', NF90_DOUBLE, & + (/grid_size_dimid/),grid_center_lat_varid) + IERR = NF90_DEF_VAR(NCID, 'grid_center_lon', NF90_DOUBLE, & + (/grid_size_dimid/),grid_center_lon_varid) + IERR = NF90_DEF_VAR(NCID, 'grid_corner_lat', NF90_DOUBLE, & + (/grid_corners_dimid,grid_size_dimid/), & + grid_corner_lat_varid) + IERR = NF90_DEF_VAR(NCID, 'grid_corner_lon', NF90_DOUBLE, & + (/grid_corners_dimid,grid_size_dimid/), & + grid_corner_lon_varid) + IERR = NF90_DEF_VAR(NCID, 'grid_imask', NF90_INT, & + (/grid_size_dimid/),grid_imask_varid) + IERR = NF90_DEF_VAR(NCID, 'grid_dims', NF90_INT, & + (/grid_rank_dimid/),grid_dims_varid) + IERR = NF90_ENDDEF(NCID) #endif #ifdef W3_SCRIP - ALLOCATE(GRID1_IMASK(GRID1_DIMS(1))) - GRID1_IMASK = 0 - DO I = 1,GRID1_DIMS(1) - IF (GRID1_MASK(I)) THEN - GRID1_IMASK(I) = 1 - ENDIF - ENDDO + ALLOCATE(GRID1_IMASK(GRID1_DIMS(1))) + GRID1_IMASK = 0 + DO I = 1,GRID1_DIMS(1) + IF (GRID1_MASK(I)) THEN + GRID1_IMASK(I) = 1 + ENDIF + ENDDO #endif #ifdef W3_SCRIPNC - IERR = NF90_PUT_ATT(NCID,grid_center_lat_varid,'units',GRID1_UNITS) - IERR = NF90_PUT_ATT(NCID,grid_center_lon_varid,'units',GRID1_UNITS) - IERR = NF90_PUT_ATT(NCID,grid_corner_lat_varid,'units',GRID1_UNITS) - IERR = NF90_PUT_ATT(NCID,grid_corner_lon_varid,'units',GRID1_UNITS) - IERR = NF90_PUT_ATT(NCID,grid_imask_varid,'units','unitless') + IERR = NF90_PUT_ATT(NCID,grid_center_lat_varid,'units',GRID1_UNITS) + IERR = NF90_PUT_ATT(NCID,grid_center_lon_varid,'units',GRID1_UNITS) + IERR = NF90_PUT_ATT(NCID,grid_corner_lat_varid,'units',GRID1_UNITS) + IERR = NF90_PUT_ATT(NCID,grid_corner_lon_varid,'units',GRID1_UNITS) + IERR = NF90_PUT_ATT(NCID,grid_imask_varid,'units','unitless') #endif #ifdef W3_SCRIPNC - IERR = NF90_PUT_VAR(NCID,grid_center_lat_varid,GRID1_CENTER_LAT) - IERR = NF90_PUT_VAR(NCID,grid_center_lon_varid,GRID1_CENTER_LON) - IERR = NF90_PUT_VAR(NCID,grid_corner_lat_varid,GRID1_CORNER_LAT) - IERR = NF90_PUT_VAR(NCID,grid_corner_lon_varid,GRID1_CORNER_LON) - IERR = NF90_PUT_VAR(NCID,grid_imask_varid,GRID1_IMASK) - IERR = NF90_PUT_VAR(NCID,grid_dims_varid,GRID1_DIMS) - IERR = NF90_CLOSE(NCID) -#endif - - -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Grid preprocessor *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) - 902 FORMAT ( ' Grid name : ',A/) - 903 FORMAT (/' Spectral discretization : '/ & - ' --------------------------------------------------'/ & - ' Number of directions :',I4/ & - ' Directional increment (deg.):',F6.1) - 904 FORMAT ( ' First direction (deg.):',F6.1) - 905 FORMAT ( ' Number of frequencies :',I4/ & - ' Frequency range (Hz) :',F9.4,'-',F6.4/ & - ' Increment factor :',F8.3/) -! - 910 FORMAT (/' Model definition :'/ & - ' --------------------------------------------------') - 911 FORMAT ( ' Dry run (no calculations) : ',A/ & - ' Propagation in X-direction : ',A/ & - ' Propagation in Y-direction : ',A/ & - ' Refraction : ',A/ & - ' Current-induced k-shift : ',A/ & - ' Source term calc. and int. : ',A/) - 912 FORMAT (/' Time steps : '/ & - ' --------------------------------------------------'/ & - ' Maximum global time step (s) :',F8.2/ & - ' Maximum CFL time step X-Y (s) :',F8.2/ & - ' Maximum CFL time step k-theta (s) :',F8.2/ & - ' Minimum source term time step (s) :',F8.2/) - 913 FORMAT (/ ' WARNING, TIME STEP LESS THAN 1 s, NITER:',I8 /) - 915 FORMAT ( ' Preprocessing namelists ...') - 916 FORMAT ( ' Preprocessing namelists finished.'/) - 917 FORMAT (/' Equivalent namelists ...'/) - 918 FORMAT (/' Equivalent namelists finished.'/) -! + IERR = NF90_PUT_VAR(NCID,grid_center_lat_varid,GRID1_CENTER_LAT) + IERR = NF90_PUT_VAR(NCID,grid_center_lon_varid,GRID1_CENTER_LON) + IERR = NF90_PUT_VAR(NCID,grid_corner_lat_varid,GRID1_CORNER_LAT) + IERR = NF90_PUT_VAR(NCID,grid_corner_lon_varid,GRID1_CORNER_LON) + IERR = NF90_PUT_VAR(NCID,grid_imask_varid,GRID1_IMASK) + IERR = NF90_PUT_VAR(NCID,grid_dims_varid,GRID1_DIMS) + IERR = NF90_CLOSE(NCID) +#endif + + + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Grid preprocessor *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) +902 FORMAT ( ' Grid name : ',A/) +903 FORMAT (/' Spectral discretization : '/ & + ' --------------------------------------------------'/ & + ' Number of directions :',I4/ & + ' Directional increment (deg.):',F6.1) +904 FORMAT ( ' First direction (deg.):',F6.1) +905 FORMAT ( ' Number of frequencies :',I4/ & + ' Frequency range (Hz) :',F9.4,'-',F6.4/ & + ' Increment factor :',F8.3/) + ! +910 FORMAT (/' Model definition :'/ & + ' --------------------------------------------------') +911 FORMAT ( ' Dry run (no calculations) : ',A/ & + ' Propagation in X-direction : ',A/ & + ' Propagation in Y-direction : ',A/ & + ' Refraction : ',A/ & + ' Current-induced k-shift : ',A/ & + ' Source term calc. and int. : ',A/) +912 FORMAT (/' Time steps : '/ & + ' --------------------------------------------------'/ & + ' Maximum global time step (s) :',F8.2/ & + ' Maximum CFL time step X-Y (s) :',F8.2/ & + ' Maximum CFL time step k-theta (s) :',F8.2/ & + ' Minimum source term time step (s) :',F8.2/) +913 FORMAT (/ ' WARNING, TIME STEP LESS THAN 1 s, NITER:',I8 /) +915 FORMAT ( ' Preprocessing namelists ...') +916 FORMAT ( ' Preprocessing namelists finished.'/) +917 FORMAT (/' Equivalent namelists ...'/) +918 FORMAT (/' Equivalent namelists finished.'/) + ! #ifdef W3_FLX1 - 810 FORMAT (/' Stresses (Wu 1980)'/ & - ' --------------------------------------------------'/) +810 FORMAT (/' Stresses (Wu 1980)'/ & + ' --------------------------------------------------'/) #endif #ifdef W3_FLX2 - 810 FORMAT (/' Stresses (T&C 96)'/ & - ' --------------------------------------------------'/) +810 FORMAT (/' Stresses (T&C 96)'/ & + ' --------------------------------------------------'/) #endif #ifdef W3_FLX3 - 810 FORMAT (/' Stresses (T&C 96 capped) ',A/ & - ' --------------------------------------------------') +810 FORMAT (/' Stresses (T&C 96 capped) ',A/ & + ' --------------------------------------------------') #endif #ifdef W3_FLX4 - 810 FORMAT (/' Stresses (Hwang 2011) ',A/ & - ' --------------------------------------------------') - 811 FORMAT ( ' drag coefficient scaling :',F8.2 /) - 2810 FORMAT ( ' &FLX4 CDFAC =',F6.3,' /') +810 FORMAT (/' Stresses (Hwang 2011) ',A/ & + ' --------------------------------------------------') +811 FORMAT ( ' drag coefficient scaling :',F8.2 /) +2810 FORMAT ( ' &FLX4 CDFAC =',F6.3,' /') #endif #ifdef W3_FLX5 - 810 FORMAT (/' Direct use of stress from input'/ & - ' --------------------------------------------------'/) +810 FORMAT (/' Direct use of stress from input'/ & + ' --------------------------------------------------'/) #endif #ifdef W3_FLX3 - 811 FORMAT ( ' Max Cd * 10^3 :',F8.2/ & - ' Cap type : ',A/) - 2810 FORMAT ( ' &FLX3 CDMAX =',F6.2,'E-3 , CTYPE = ',I1,' /') +811 FORMAT ( ' Max Cd * 10^3 :',F8.2/ & + ' Cap type : ',A/) +2810 FORMAT ( ' &FLX3 CDMAX =',F6.2,'E-3 , CTYPE = ',I1,' /') #endif -! + ! #ifdef W3_LN0 - 820 FORMAT (/' Linear input not defined.'/) +820 FORMAT (/' Linear input not defined.'/) #endif #ifdef W3_SEED - 820 FORMAT (/' Seeding as proxi for linear input.'/) +820 FORMAT (/' Seeding as proxi for linear input.'/) #endif -! + ! #ifdef W3_LN1 - 820 FORMAT (/' Linear input (C&M-R 82) ',A/ & - ' --------------------------------------------------') - 821 FORMAT ( ' CLIN :',f8.2/ & - ' Factor for fPM in filter :',F8.2/ & - ' Factor for fh in filter :',F8.2/) - 2820 FORMAT ( ' &SLN1 CLIN =',F6.1,', RFPM =',F6.2, & - ', RFHF =',F6.2,' /') -#endif -! +820 FORMAT (/' Linear input (C&M-R 82) ',A/ & + ' --------------------------------------------------') +821 FORMAT ( ' CLIN :',f8.2/ & + ' Factor for fPM in filter :',F8.2/ & + ' Factor for fh in filter :',F8.2/) +2820 FORMAT ( ' &SLN1 CLIN =',F6.1,', RFPM =',F6.2, & + ', RFHF =',F6.2,' /') +#endif + ! #ifdef W3_ST0 - 920 FORMAT (/' Wind input not defined.'/) +920 FORMAT (/' Wind input not defined.'/) #endif -! + ! #ifdef W3_ST1 - 920 FORMAT (/' Wind input (WAM-3) ',A/ & - ' --------------------------------------------------') - 921 FORMAT ( ' Cinp :',E10.3/) - 2920 FORMAT ( ' &SIN1 CINP =',F7.3,' /') +920 FORMAT (/' Wind input (WAM-3) ',A/ & + ' --------------------------------------------------') +921 FORMAT ( ' Cinp :',E10.3/) +2920 FORMAT ( ' &SIN1 CINP =',F7.3,' /') #endif -! + ! #ifdef W3_ST2 - 920 FORMAT (/' Wind input (T&C 1996) ',A/ & - ' --------------------------------------------------') - 921 FORMAT ( ' Height of input wind (m) :',F8.2/ & - ' Factor negative swell :',F9.3/) +920 FORMAT (/' Wind input (T&C 1996) ',A/ & + ' --------------------------------------------------') +921 FORMAT ( ' Height of input wind (m) :',F8.2/ & + ' Factor negative swell :',F9.3/) #endif #ifdef W3_STAB2 - 1921 FORMAT ( ' Effective wind mean factor :',F8.2/ & - ' Stability par. offset :',F9.3/ & - ' Stab. correction :',F9.3,F8.3/& - ' Stab. correction stab. fac. :',F7.1,F9.1/) +1921 FORMAT ( ' Effective wind mean factor :',F8.2/ & + ' Stability par. offset :',F9.3/ & + ' Stab. correction :',F9.3,F8.3/& + ' Stab. correction stab. fac. :',F7.1,F9.1/) #endif #ifdef W3_ST2 - 2920 FORMAT ( ' &SIN2 ZWND =',F5.1,', SWELLF =',F6.3,' /') +2920 FORMAT ( ' &SIN2 ZWND =',F5.1,', SWELLF =',F6.3,' /') #endif #ifdef W3_STAB2 - 2921 FORMAT ( ' &SIN2 ZWND =',F5.1,', SWELLF =',F6.3,', STABSH =', & - F6.3,', STABOF = ',E10.3,','/ & - ' CNEG =',F7.3,', CPOS =',F7.3,', FNEG =',F7.1,' /') +2921 FORMAT ( ' &SIN2 ZWND =',F5.1,', SWELLF =',F6.3,', STABSH =', & + F6.3,', STABOF = ',E10.3,','/ & + ' CNEG =',F7.3,', CPOS =',F7.3,', FNEG =',F7.1,' /') #endif -! + ! #ifdef W3_ST3 - 920 FORMAT (/' Wind input (WAM 4+) ',A/ & - ' --------------------------------------------------') - 921 FORMAT ( ' minimum Charnock coeff. :',F10.4/ & - ' betamax :',F9.3/ & - ' power of cos. in wind input :',F9.3/ & - ' z0max :',F9.3/ & - ' zalp :',F9.3/ & - ' Height of input wind (m) :',F8.2/ & - ' swell attenuation factor :',F9.3/ ) - 2920 FORMAT ( ' &SIN3 ZWND =',F5.1,', ALPHA0 =',F8.5,', Z0MAX =',F8.5,', BETAMAX =', & - F8.5,','/ & - ' SINTHP =',F8.5,', ZALP =',F8.5,','/ & - ' SWELLF =',F8.5,'R /'/) -#endif -! +920 FORMAT (/' Wind input (WAM 4+) ',A/ & + ' --------------------------------------------------') +921 FORMAT ( ' minimum Charnock coeff. :',F10.4/ & + ' betamax :',F9.3/ & + ' power of cos. in wind input :',F9.3/ & + ' z0max :',F9.3/ & + ' zalp :',F9.3/ & + ' Height of input wind (m) :',F8.2/ & + ' swell attenuation factor :',F9.3/ ) +2920 FORMAT ( ' &SIN3 ZWND =',F5.1,', ALPHA0 =',F8.5,', Z0MAX =',F8.5,', BETAMAX =', & + F8.5,','/ & + ' SINTHP =',F8.5,', ZALP =',F8.5,','/ & + ' SWELLF =',F8.5,'R /'/) +#endif + ! #ifdef W3_ST4 - 920 FORMAT (/' Wind input (WAM 4+) ',A/ & - ' --------------------------------------------------') - 921 FORMAT ( ' minimum Charnock coeff. :',F10.4/ & - ' betamax :',F9.3/ & - ' power of cos. in wind input :',F9.3/ & - ' z0max :',F9.3/ & - ' zalp :',F9.3/ & - ' Height of input wind (m) :',F8.2/ & - ' wind stress sheltering :',F9.3/ & - ' swell attenuation param. :',I5/ & - ' swell attenuation factor :',F9.3/ & - ' swell attenuation factor2 :',F9.3/ & - ' swell attenuation factor3 :',F9.3/ & - ' critical Reynolds number :',F9.1/ & - ' swell attenuation factor5 :',F9.3/ & - ' swell attenuation factor6 :',F9.3/ & - ' swell attenuation factor7 :',F14.3/ & - ' ratio of z0 for orb. & mean :',F9.3/) - 2920 FORMAT ( ' &SIN4 ZWND =',F5.1,', ALPHA0 =',F8.5,', Z0MAX =',F8.5,', BETAMAX =', & - F8.5,','/ & - ' SINTHP =',F8.5,', ZALP =',F8.5,', TAUWSHELTER =',F8.5, & - ', SWELLFPAR =',I2,','/ & - ' SWELLF =',F8.5,', SWELLF2 =',F8.5, & - ', SWELLF3 =',F8.5,', SWELLF4 =',F9.1,','/ & - ' SWELLF5 =',F8.5,', SWELLF6 =',F8.5, & - ', SWELLF7 =',F12.2,', Z0RAT =',F8.5,', SINBR =',F8.5,' /') -#endif -! +920 FORMAT (/' Wind input (WAM 4+) ',A/ & + ' --------------------------------------------------') +921 FORMAT ( ' minimum Charnock coeff. :',F10.4/ & + ' betamax :',F9.3/ & + ' power of cos. in wind input :',F9.3/ & + ' z0max :',F9.3/ & + ' zalp :',F9.3/ & + ' Height of input wind (m) :',F8.2/ & + ' wind stress sheltering :',F9.3/ & + ' swell attenuation param. :',I5/ & + ' swell attenuation factor :',F9.3/ & + ' swell attenuation factor2 :',F9.3/ & + ' swell attenuation factor3 :',F9.3/ & + ' critical Reynolds number :',F9.1/ & + ' swell attenuation factor5 :',F9.3/ & + ' swell attenuation factor6 :',F9.3/ & + ' swell attenuation factor7 :',F14.3/ & + ' ratio of z0 for orb. & mean :',F9.3/) +2920 FORMAT ( ' &SIN4 ZWND =',F5.1,', ALPHA0 =',F8.5,', Z0MAX =',F8.5,', BETAMAX =', & + F8.5,','/ & + ' SINTHP =',F8.5,', ZALP =',F8.5,', TAUWSHELTER =',F8.5, & + ', SWELLFPAR =',I2,','/ & + ' SWELLF =',F8.5,', SWELLF2 =',F8.5, & + ', SWELLF3 =',F8.5,', SWELLF4 =',F9.1,','/ & + ' SWELLF5 =',F8.5,', SWELLF6 =',F8.5, & + ', SWELLF7 =',F12.2,', Z0RAT =',F8.5,', SINBR =',F8.5,' /') +#endif + ! #ifdef W3_ST6 - 920 FORMAT (/' Wind input (Donelan et al, 2006) ',A/ & +920 FORMAT (/' Wind input (Donelan et al, 2006) ',A/ & ' --------------------------------------------------') - 921 FORMAT ( ' negative wind input active : ',A/ & - ' attenuation factor : ',F6.2/ & - ' wind speed scaling factor : ',F6.2/ & - ' frequency cut-off factor : ',F6.2/) - 2920 FORMAT ( ' &SIN6 SINA0 =', F6.3, ', SINWS =', F6.2, ', SINFC =', F6.2, ' /') +921 FORMAT ( ' negative wind input active : ',A/ & + ' attenuation factor : ',F6.2/ & + ' wind speed scaling factor : ',F6.2/ & + ' frequency cut-off factor : ',F6.2/) +2920 FORMAT ( ' &SIN6 SINA0 =', F6.3, ', SINWS =', F6.2, ', SINFC =', F6.2, ' /') #endif -! + ! #ifdef W3_NL0 - 922 FORMAT (/' Nonlinear interactions not defined.'/) +922 FORMAT (/' Nonlinear interactions not defined.'/) #endif -! + ! #ifdef W3_NL1 - 922 FORMAT (/' Nonlinear interactions (DIA) ',A/ & - ' --------------------------------------------------') - 923 FORMAT ( ' Lambda :',F8.2/ & - ' Prop. constant :',E10.3/ & - ' kd conversion factor :',F8.2/ & - ' minimum kd :',F8.2/ & - ' shallow water constants :',F8.2,2F6.2/) - 2922 FORMAT ( ' &SNL1 LAMBDA =',F7.3,', NLPROP =',E10.3, & - ', KDCONV =',F7.3,', KDMIN =',F7.3,','/ & - ' SNLCS1 =',F7.3,', SNLCS2 =',F7.3, & - ', SNLCS3 = ',F7.3,' /') -#endif -! +922 FORMAT (/' Nonlinear interactions (DIA) ',A/ & + ' --------------------------------------------------') +923 FORMAT ( ' Lambda :',F8.2/ & + ' Prop. constant :',E10.3/ & + ' kd conversion factor :',F8.2/ & + ' minimum kd :',F8.2/ & + ' shallow water constants :',F8.2,2F6.2/) +2922 FORMAT ( ' &SNL1 LAMBDA =',F7.3,', NLPROP =',E10.3, & + ', KDCONV =',F7.3,', KDMIN =',F7.3,','/ & + ' SNLCS1 =',F7.3,', SNLCS2 =',F7.3, & + ', SNLCS3 = ',F7.3,' /') +#endif + ! #ifdef W3_NL2 - 922 FORMAT (/' Nonlinear interactions (WRT) ',A/ & - ' --------------------------------------------------') - 923 FORMAT ( ' Deep/shallow options : ',A/ & - ' Power of h-f tail : ',F6.1) - 1923 FORMAT ( ' Number of depths used : ',I4/ & - ' Depths (m) :',5F7.1) - 2923 FORMAT ( ' ',5F7.1) - 2922 FORMAT ( ' &SNL2 IQTYPE =',I2,', TAILNL =',F5.1,',', & - ' NDEPTH =',I3,' /') - 3923 FORMAT ( ' &SNL2 DEPTHS =',F9.2,' /') - 4923 FORMAT ( ' &ANL2 DEPTHS =',F9.2,' ,') - 5923 FORMAT ( ' ',F9.2,' ,') - 6923 FORMAT ( ' ',F9.2,' /') -#endif -! +922 FORMAT (/' Nonlinear interactions (WRT) ',A/ & + ' --------------------------------------------------') +923 FORMAT ( ' Deep/shallow options : ',A/ & + ' Power of h-f tail : ',F6.1) +1923 FORMAT ( ' Number of depths used : ',I4/ & + ' Depths (m) :',5F7.1) +2923 FORMAT ( ' ',5F7.1) +2922 FORMAT ( ' &SNL2 IQTYPE =',I2,', TAILNL =',F5.1,',', & + ' NDEPTH =',I3,' /') +3923 FORMAT ( ' &SNL2 DEPTHS =',F9.2,' /') +4923 FORMAT ( ' &ANL2 DEPTHS =',F9.2,' ,') +5923 FORMAT ( ' ',F9.2,' ,') +6923 FORMAT ( ' ',F9.2,' /') +#endif + ! #ifdef W3_NL3 - 922 FORMAT (/' Nonlinear interactions (GMD) ',A/ & - ' --------------------------------------------------') - 923 FORMAT ( ' Powers in scaling functions : ',2F7.2/ & - ' Nondimension filter depths : ',2F7.2) - 1923 FORMAT ( ' Number of quad. definitions : ',I4) - 2923 FORMAT ( ' ',2F8.3,F6.1,2E12.4) - 2922 FORMAT ( ' &SNL3 NQDEF =',I3,', MSC =',F6.2,', NSC =', & - F6.2,', KDFD =',F6.2,', KDFS =',F6.2,' /') - 3923 FORMAT ( ' &ANL3 QPARMS = ',2(F5.3,', '),F5.1,', ',E10.4, & - ', ',E10.4,' /') - 4923 FORMAT ( ' &ANL3 QPARMS = ',2(F5.3,', '),F5.1,', ',E10.4, & - ', ',E10.4,' ,') - 5923 FORMAT ( ' ',2(F5.3,', '),F5.1,', ',E10.4, & - ', ',E10.4,' ,') - 6923 FORMAT ( ' ',2(F5.3,', '),F5.1,', ',E10.4, & - ', ',E10.4,' /') -#endif -! +922 FORMAT (/' Nonlinear interactions (GMD) ',A/ & + ' --------------------------------------------------') +923 FORMAT ( ' Powers in scaling functions : ',2F7.2/ & + ' Nondimension filter depths : ',2F7.2) +1923 FORMAT ( ' Number of quad. definitions : ',I4) +2923 FORMAT ( ' ',2F8.3,F6.1,2E12.4) +2922 FORMAT ( ' &SNL3 NQDEF =',I3,', MSC =',F6.2,', NSC =', & + F6.2,', KDFD =',F6.2,', KDFS =',F6.2,' /') +3923 FORMAT ( ' &ANL3 QPARMS = ',2(F5.3,', '),F5.1,', ',E10.4, & + ', ',E10.4,' /') +4923 FORMAT ( ' &ANL3 QPARMS = ',2(F5.3,', '),F5.1,', ',E10.4, & + ', ',E10.4,' ,') +5923 FORMAT ( ' ',2(F5.3,', '),F5.1,', ',E10.4, & + ', ',E10.4,' ,') +6923 FORMAT ( ' ',2(F5.3,', '),F5.1,', ',E10.4, & + ', ',E10.4,' /') +#endif + ! #ifdef W3_NL4 - 922 FORMAT (/' Nonlinear interactions (TSA) ',A/ & - ' --------------------------------------------------') - 923 FORMAT ( ' Source term computation (1=TSA,0=FBI) : ',I2/ & - ' Alternate loops (1=no,2=yes) : ',I2/ & - ' (To speed up computation) ') - 2922 FORMAT ( ' &SNL4 ITSA =',I2,', IALT =',I2 ) -#endif -! +922 FORMAT (/' Nonlinear interactions (TSA) ',A/ & + ' --------------------------------------------------') +923 FORMAT ( ' Source term computation (1=TSA,0=FBI) : ',I2/ & + ' Alternate loops (1=no,2=yes) : ',I2/ & + ' (To speed up computation) ') +2922 FORMAT ( ' &SNL4 ITSA =',I2,', IALT =',I2 ) +#endif + ! #ifdef W3_NL5 - 922 FORMAT(/' Nonlinear interactions (GKE) ',A/ & - ' --------------------------------------------------') - 923 FORMAT ( ' Constant water depth (in meter) : ', F7.1/ & - ' Quasi-resonant quartets cut-off : ', F8.2/ & - ' Discretiz. of GKE (0:Con., 1:GS): ', I5/ & - ' GKE (0: GS13-JFM, 1: J03-JPO) : ', I5/ & - ' Interp (0: nearest, 1: bilinear): ', I5/ & - ' Mixing (0: no, N: N Tm, -1: b_T): ', I5/) - 2922 FORMAT ( ' &SNL5 NL5DPT =', F7.1, ', NL5OML =', F5.2, & - ', NL5DIS =', I2.1, ', NL5KEV =', I2.1, & - ', NL5IPL =', I2.1, ', NL5PMX =', I5.1, ' /') -#endif -! +922 FORMAT(/' Nonlinear interactions (GKE) ',A/ & + ' --------------------------------------------------') +923 FORMAT ( ' Constant water depth (in meter) : ', F7.1/ & + ' Quasi-resonant quartets cut-off : ', F8.2/ & + ' Discretiz. of GKE (0:Con., 1:GS): ', I5/ & + ' GKE (0: GS13-JFM, 1: J03-JPO) : ', I5/ & + ' Interp (0: nearest, 1: bilinear): ', I5/ & + ' Mixing (0: no, N: N Tm, -1: b_T): ', I5/) +2922 FORMAT ( ' &SNL5 NL5DPT =', F7.1, ', NL5OML =', F5.2, & + ', NL5DIS =', I2.1, ', NL5KEV =', I2.1, & + ', NL5IPL =', I2.1, ', NL5PMX =', I5.1, ' /') +#endif + ! #ifdef W3_NLS - 9922 FORMAT (/' HF filter based on Snl ',A/ & - ' --------------------------------------------------') - 9923 FORMAT ( ' a34 (lambda) :',F9.3,F9.4/ & - ' Prop. constant :',E10.3/ & - ' maximum relative change :',F9.3/ & - ' filter constants :',F8.2,2F6.2/) - 8922 FORMAT ( ' &SNLS A34 =',F6.3,', FHFC =',E11.4, & - ', DNM =',F6.3,','/' FC1 =',F6.3, & - ', FC2 =',F6.3,', FC3 =',F6.3,' /') -#endif -! +9922 FORMAT (/' HF filter based on Snl ',A/ & + ' --------------------------------------------------') +9923 FORMAT ( ' a34 (lambda) :',F9.3,F9.4/ & + ' Prop. constant :',E10.3/ & + ' maximum relative change :',F9.3/ & + ' filter constants :',F8.2,2F6.2/) +8922 FORMAT ( ' &SNLS A34 =',F6.3,', FHFC =',E11.4, & + ', DNM =',F6.3,','/' FC1 =',F6.3, & + ', FC2 =',F6.3,', FC3 =',F6.3,' /') +#endif + ! #ifdef W3_ST0 - 924 FORMAT (/' Dissipation not defined.'/) +924 FORMAT (/' Dissipation not defined.'/) #endif -! + ! #ifdef W3_ST1 - 924 FORMAT (/' Dissipation (WAM-3) ',A/ & - ' --------------------------------------------------') - 925 FORMAT ( ' Cdis :',E10.3/ & - ' Apm :',E10.3/) - 2924 FORMAT ( ' &SDS1 CDIS =',E12.4,', APM =',E11.4,' /') +924 FORMAT (/' Dissipation (WAM-3) ',A/ & + ' --------------------------------------------------') +925 FORMAT ( ' Cdis :',E10.3/ & + ' Apm :',E10.3/) +2924 FORMAT ( ' &SDS1 CDIS =',E12.4,', APM =',E11.4,' /') #endif -! + ! #ifdef W3_ST2 - 924 FORMAT (/' Dissipation (T&C 1996) ',A/ & - ' --------------------------------------------------') - 925 FORMAT ( ' High-frequency constants :',F8.2,E11.3,F6.2/ & - ' Low-frequency constants :',E11.3,F6.2/& - ' ',E11.3,F6.2/& - ' Minimum input peak freq. (-):',F10.4/ & - ' Minimum PHI :',F10.4/) - 2924 FORMAT ( ' &SDS2 SDSA0 =',E10.3,', SDSA1 =',E10.3,', SDSA2 =', & - E10.3,', '/ & - ' SDSB0 =',E10.3,', SDSB1 =',E10.3,', ', & - 'PHIMIN =',E10.3,' /') -#endif -! +924 FORMAT (/' Dissipation (T&C 1996) ',A/ & + ' --------------------------------------------------') +925 FORMAT ( ' High-frequency constants :',F8.2,E11.3,F6.2/ & + ' Low-frequency constants :',E11.3,F6.2/& + ' ',E11.3,F6.2/& + ' Minimum input peak freq. (-):',F10.4/ & + ' Minimum PHI :',F10.4/) +2924 FORMAT ( ' &SDS2 SDSA0 =',E10.3,', SDSA1 =',E10.3,', SDSA2 =', & + E10.3,', '/ & + ' SDSB0 =',E10.3,', SDSB1 =',E10.3,', ', & + 'PHIMIN =',E10.3,' /') +#endif + ! #ifdef W3_ST3 - 924 FORMAT (/' Dissipation (WAM Cycle 4+) ',A/ & - ' --------------------------------------------------') - 925 FORMAT ( ' SDSC1 :',1E11.3/ & - ' Power of k in mean k :',F8.2/ & - ' weights of k and k^2 :',F9.3,F6.3/) - 2924 FORMAT ( ' &SDS3 SDSC1 =',E12.4,', WNMEANP =',F4.2, & - ', FXPM3 =', F4.2,',FXFM3 =',F4.2,', '/ & - ' SDSDELTA1 =', F5.2,', SDSDELTA2 =',F5.2, & - ' /') -#endif -! +924 FORMAT (/' Dissipation (WAM Cycle 4+) ',A/ & + ' --------------------------------------------------') +925 FORMAT ( ' SDSC1 :',1E11.3/ & + ' Power of k in mean k :',F8.2/ & + ' weights of k and k^2 :',F9.3,F6.3/) +2924 FORMAT ( ' &SDS3 SDSC1 =',E12.4,', WNMEANP =',F4.2, & + ', FXPM3 =', F4.2,',FXFM3 =',F4.2,', '/ & + ' SDSDELTA1 =', F5.2,', SDSDELTA2 =',F5.2, & + ' /') +#endif + ! #ifdef W3_ST4 - 924 FORMAT (/' Dissipation (Ardhuin / Filipot / Romero ) ',A/ & - ' --------------------------------------------------') - 925 FORMAT ( ' SDSC2, SDSBCK, SDSCUM :',3E11.3/ & - ' Power of k in mean k :',F8.2/) +924 FORMAT (/' Dissipation (Ardhuin / Filipot / Romero ) ',A/ & + ' --------------------------------------------------') +925 FORMAT ( ' SDSC2, SDSBCK, SDSCUM :',3E11.3/ & + ' Power of k in mean k :',F8.2/) #endif #ifdef W3_ST4 - 2924 FORMAT ( ' &SDS4 SDSBCHOICE = ',F3.1, & - ', SDSC2 =',E12.4,', SDSCUM =',F6.2,', '/ & - ' SDSC4 =',F6.2,', SDSC5 =',E12.4, & - ', SDSC6 =',E12.4,','/ & - ' WNMEANP =',F4.2,', FXPM3 =', F4.2, & - ', FXFM3 =',F4.1,', FXFMAGE =',F6.3, ', '/ & - ' SDSBINT =',E12.4,', SDSBCK =',E12.4, & - ', SDSABK =',F6.3,', SDSPBK =',F6.3,', '/ & - ' SDSHCK =',F5.2,', SDSBR = ',E12.4, & - ', SDSSTRAIN =',F5.1,', SDSSTRAINA =',F4.1, & - ', SDSSTRAIN2 =',F5.1,', '/ & - ' SDSBT =',F5.2,', SDSP =',F5.2, & - ', SDSISO =',I2, & - ', SDSCOS =',F3.1,', SDSDTH =',F5.1,', '/ & - ' SDSBRF1 = ',F5.2,', SDSBRFDF =',I2,', '/ & - ' SDSBM0 = ',F5.2, ', SDSBM1 =',F5.2, & - ', SDSBM2 =',F5.2,', SDSBM3 =',F5.2,', SDSBM4 =', & - F5.2,', '/, & - ' SPMSS = ',F5.2, ', SDKOF =',F5.2, & - ', SDSMWD =',F5.2,', SDSFACMTF =',F5.1,', '/ & - ' SDSMWPOW =',F3.1,', SDSNMTF =', F5.2, & - ', SDSCUMP =', F3.1,', SDSNUW =', E8.3,', '/, & - ' WHITECAPWIDTH =',F5.2, ' WHITECAPDUR =',F5.2,' /') -#endif -! +2924 FORMAT ( ' &SDS4 SDSBCHOICE = ',F3.1, & + ', SDSC2 =',E12.4,', SDSCUM =',F6.2,', '/ & + ' SDSC4 =',F6.2,', SDSC5 =',E12.4, & + ', SDSC6 =',E12.4,','/ & + ' WNMEANP =',F4.2,', FXPM3 =', F4.2, & + ', FXFM3 =',F4.1,', FXFMAGE =',F6.3, ', '/ & + ' SDSBINT =',E12.4,', SDSBCK =',E12.4, & + ', SDSABK =',F6.3,', SDSPBK =',F6.3,', '/ & + ' SDSHCK =',F5.2,', SDSBR = ',E12.4, & + ', SDSSTRAIN =',F5.1,', SDSSTRAINA =',F4.1, & + ', SDSSTRAIN2 =',F5.1,', '/ & + ' SDSBT =',F5.2,', SDSP =',F5.2, & + ', SDSISO =',I2, & + ', SDSCOS =',F3.1,', SDSDTH =',F5.1,', '/ & + ' SDSBRF1 = ',F5.2,', SDSBRFDF =',I2,', '/ & + ' SDSBM0 = ',F5.2, ', SDSBM1 =',F5.2, & + ', SDSBM2 =',F5.2,', SDSBM3 =',F5.2,', SDSBM4 =', & + F5.2,', '/, & + ' SPMSS = ',F5.2, ', SDKOF =',F5.2, & + ', SDSMWD =',F5.2,', SDSFACMTF =',F5.1,', '/ & + ' SDSMWPOW =',F3.1,', SDSNMTF =', F5.2, & + ', SDSCUMP =', F3.1,', SDSNUW =', E8.3,', '/, & + ' WHITECAPWIDTH =',F5.2, ' WHITECAPDUR =',F5.2,' /') +#endif + ! #ifdef W3_ST6 - 924 FORMAT (/' Dissipation (Rogers et al. 2012) ',A/ & - ' --------------------------------------------------') - 925 FORMAT ( ' normalise by threshold spectral density : ',A/& - ' normalise by spectral density : ',A/& - ' coefficient and exponent for '/ & - ' inherent breaking term a1, L as in (21) : ',E9.3,I3/ & - ' cumulative breaking term a2, M as in (22) : ',E9.3,I3/ & - ' ') - 2924 FORMAT ( ' &SDS6 SDSET = ',L,', SDSA1 = ',E9.3, & - ', SDSA2 = ',E9.3,', SDSP1 = ',I2,', SDSP1 = ', & - I2,' /' ) - - 937 FORMAT (/' Swell dissipation ',A/ & - ' --------------------------------------------------') - 940 FORMAT ( ' subroutine W3SWL6 activated : ',A/ & - ' coefficient b1 ',A, ' : ',E9.3/ ) - 2937 FORMAT ( ' &SWL6 SWLB1 = ',E9.3,', CSTB1 = ',L,' /') -#endif -! +924 FORMAT (/' Dissipation (Rogers et al. 2012) ',A/ & + ' --------------------------------------------------') +925 FORMAT ( ' normalise by threshold spectral density : ',A/& + ' normalise by spectral density : ',A/& + ' coefficient and exponent for '/ & + ' inherent breaking term a1, L as in (21) : ',E9.3,I3/ & + ' cumulative breaking term a2, M as in (22) : ',E9.3,I3/ & + ' ') +2924 FORMAT ( ' &SDS6 SDSET = ',L,', SDSA1 = ',E9.3, & + ', SDSA2 = ',E9.3,', SDSP1 = ',I2,', SDSP1 = ', & + I2,' /' ) + +937 FORMAT (/' Swell dissipation ',A/ & + ' --------------------------------------------------') +940 FORMAT ( ' subroutine W3SWL6 activated : ',A/ & + ' coefficient b1 ',A, ' : ',E9.3/ ) +2937 FORMAT ( ' &SWL6 SWLB1 = ',E9.3,', CSTB1 = ',L,' /') +#endif + ! #ifdef W3_BT0 - 926 FORMAT (/' Bottom friction not defined.'/) +926 FORMAT (/' Bottom friction not defined.'/) #endif -! + ! #ifdef W3_BT1 - 926 FORMAT (/' Bottom friction (JONSWAP) ',A/ & - ' --------------------------------------------------') - 927 FORMAT ( ' gamma :',F8.4/) - 2926 FORMAT ( ' &SBT1 GAMMA =',E12.4,' /') +926 FORMAT (/' Bottom friction (JONSWAP) ',A/ & + ' --------------------------------------------------') +927 FORMAT ( ' gamma :',F8.4/) +2926 FORMAT ( ' &SBT1 GAMMA =',E12.4,' /') #endif -! + ! #ifdef W3_BT4 - 926 FORMAT (/' Bottom friction (SHOWEX) ',A/ & - ' --------------------------------------------------') - 927 FORMAT ( ' SEDMAPD50, SED_D50_UNIFORM :',L3,1X,F8.6/ & - ' RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4 :',4F8.4/ & - ' SIGDEPTH, BOTROUGHMIN, BOTROUGHFAC:',3F8.4/) - 2926 FORMAT ( ' &SBT4 SEDMAPD50 =',L3,', SED_D50_UNIFORM =',F8.6,','/ & - ' RIPFAC1 =',F8.4,', RIPFAC2 =',F8.4, & - ', RIPFAC3 =',F8.4,', RIPFAC4 =',F8.4,','/ & - ' SIGDEPTH =',F8.4,', BOTROUGHMIN =',F8.4, & - ', BOTROUGHFAC =',F4.1,' /') -#endif -! +926 FORMAT (/' Bottom friction (SHOWEX) ',A/ & + ' --------------------------------------------------') +927 FORMAT ( ' SEDMAPD50, SED_D50_UNIFORM :',L3,1X,F8.6/ & + ' RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4 :',4F8.4/ & + ' SIGDEPTH, BOTROUGHMIN, BOTROUGHFAC:',3F8.4/) +2926 FORMAT ( ' &SBT4 SEDMAPD50 =',L3,', SED_D50_UNIFORM =',F8.6,','/ & + ' RIPFAC1 =',F8.4,', RIPFAC2 =',F8.4, & + ', RIPFAC3 =',F8.4,', RIPFAC4 =',F8.4,','/ & + ' SIGDEPTH =',F8.4,', BOTROUGHMIN =',F8.4, & + ', BOTROUGHFAC =',F4.1,' /') +#endif + ! #ifdef W3_DB0 - 928 FORMAT (/' Surf breaking not defined.'/) +928 FORMAT (/' Surf breaking not defined.'/) #endif -! + ! #ifdef W3_DB1 - 928 FORMAT (/' Surf breaking (B&J 1978) ',A/ & - ' --------------------------------------------------') - 929 FORMAT ( ' alpha :',F8.3/ & - ' gamma :',F8.3) - 2928 FORMAT ( ' &SDB1 BJALFA =',F7.3,', BJGAM =',F7.3, & - ', BJFLAG = ',A,' /') -#endif -! +928 FORMAT (/' Surf breaking (B&J 1978) ',A/ & + ' --------------------------------------------------') +929 FORMAT ( ' alpha :',F8.3/ & + ' gamma :',F8.3) +2928 FORMAT ( ' &SDB1 BJALFA =',F7.3,', BJGAM =',F7.3, & + ', BJFLAG = ',A,' /') +#endif + ! #ifdef W3_TR0 - 930 FORMAT (/' Triad interactions not defined.'/) +930 FORMAT (/' Triad interactions not defined.'/) #endif -! + ! #ifdef W3_BS0 - 932 FORMAT (/' Bottom scattering not defined.'/) +932 FORMAT (/' Bottom scattering not defined.'/) #endif #ifdef W3_BS1 - 932 FORMAT (/' Experimental bottom scattering (F. Ardhuin).'/) +932 FORMAT (/' Experimental bottom scattering (F. Ardhuin).'/) #endif -! + ! #ifdef W3_IC1 - 935 FORMAT (/' Dissipation via ice parameters (SIC1).'& - ,/' --------------------------------------------------') +935 FORMAT (/' Dissipation via ice parameters (SIC1).'& + ,/' --------------------------------------------------') #endif -! + ! #ifdef W3_IC2 - 935 FORMAT (/' Dissipation via ice parameters (SIC2).'& - ,/' --------------------------------------------------') +935 FORMAT (/' Dissipation via ice parameters (SIC2).'& + ,/' --------------------------------------------------') #endif -! + ! #ifdef W3_IC3 - 935 FORMAT (/' Dissipation via ice parameters (SIC3).'& - ,/' --------------------------------------------------') +935 FORMAT (/' Dissipation via ice parameters (SIC3).'& + ,/' --------------------------------------------------') #endif -! + ! #ifdef W3_IC4 - 935 FORMAT (/' Dissipation via ice parameters (SIC4).'& - ,/' --------------------------------------------------') +935 FORMAT (/' Dissipation via ice parameters (SIC4).'& + ,/' --------------------------------------------------') #endif -! + ! #ifdef W3_IC5 - 935 FORMAT (/' Dissipation via ice parameters (SIC5).'& - ,/' --------------------------------------------------') +935 FORMAT (/' Dissipation via ice parameters (SIC5).'& + ,/' --------------------------------------------------') #endif -! + ! #ifdef W3_IS0 - 944 FORMAT (/' Ice scattering not defined.'/) +944 FORMAT (/' Ice scattering not defined.'/) #endif #ifdef W3_IS1 - 945 FORMAT (/' Ice scattering ',A,/ & - ' --------------------------------------------------') - 946 FORMAT (' Isotropic (linear function of ice concentration)'/& - ' slope : ',E10.3/ & - ' offset : ',E10.3) - 2946 FORMAT ( ' &SIS1 ISC1 =',E9.3,', ISC2 =',E9.3) +945 FORMAT (/' Ice scattering ',A,/ & + ' --------------------------------------------------') +946 FORMAT (' Isotropic (linear function of ice concentration)'/& + ' slope : ',E10.3/ & + ' offset : ',E10.3) +2946 FORMAT ( ' &SIS1 ISC1 =',E9.3,', ISC2 =',E9.3) #endif #ifdef W3_IS2 - 947 FORMAT (/' Ice scattering ',A,/ & - ' --------------------------------------------------') - 948 FORMAT (' IS2 Scattering ... '/& - ' scattering coefficient : ',E9.3/ & - ' 0: no back-scattering : ',E9.3/ & - ' TRUE: istropic back-scattering : ',L3/ & - ' TRUE: update of ICEDMAX : ',L3/ & - ' TRUE: keeps updated ICEDMAX : ',L3/ & - ' flexural strength : ',E9.3/ & - ' TRUE: uses Robinson-Palmer disp.: ',L3/ & - ' attenuation : ',F5.2/ & - ' fragility : ',F5.2/ & - ' minimum floe size in meters : ',F5.2/ & - ' pack scattering coef 1 : ',F5.2/ & - ' pack scattering coef 2 : ',F5.2/ & - ' scaling by concentration : ',F5.2/ & - ' creep B coefficient : ',E9.3/ & - ' creep C coefficient : ',F5.2/ & - ' creep D coefficient : ',F5.2/ & - ' creep N power : ',F5.2/ & - ' elastic energy factor : ',F5.2/ & - ' factor for ice breakup : ',F5.2/ & - ' IS2WIM1 : ',F5.2/ & - ' anelastic dissipation : ',L3/ & - ' energy of activation : ',F5.2/ & - ' anelastic coefficient : ',E11.3/ & - ' anelastic exponent : ',F5.2) - 2948 FORMAT ( ' &SIS2 ISC1 =',E9.3,', IS2BACKSCAT =',E9.3, & - ', IS2ISOSCAT =',L3,', IS2BREAK =',L3, & - ', IS2DUPDATE =',L3,','/ & - ' IS2FLEXSTR =',E11.3,', IS2DISP =',L3, & - ', IS2DAMP =',F3.1, & - ', IS2FRAGILITY =',F4.2,', IS2DMIN =',F5.2,','/ & - ' IS2C2 =',F12.8,', IS2C3 =',F8.4, & - ', IS2CONC =',F5.1,', IS2CREEPB =',E11.3,','/ & - ' IS2CREEPC =',F5.2,', IS2CREEPD =',F5.2, & - ', IS2CREEPN =',F5.2,','/ & - ' IS2BREAKE =',F5.2, & - ', IS2BREAKF =',F5.2,', IS2WIM1 =',F5.2,','/ & - ', IS2ANDISB =',L3,', IS2ANDISE =',F5.2, & - ', IS2ANDISD =',E11.3,', IS2ANDISN=',F5.2, ' /') +947 FORMAT (/' Ice scattering ',A,/ & + ' --------------------------------------------------') +948 FORMAT (' IS2 Scattering ... '/& + ' scattering coefficient : ',E9.3/ & + ' 0: no back-scattering : ',E9.3/ & + ' TRUE: istropic back-scattering : ',L3/ & + ' TRUE: update of ICEDMAX : ',L3/ & + ' TRUE: keeps updated ICEDMAX : ',L3/ & + ' flexural strength : ',E9.3/ & + ' TRUE: uses Robinson-Palmer disp.: ',L3/ & + ' attenuation : ',F5.2/ & + ' fragility : ',F5.2/ & + ' minimum floe size in meters : ',F5.2/ & + ' pack scattering coef 1 : ',F5.2/ & + ' pack scattering coef 2 : ',F5.2/ & + ' scaling by concentration : ',F5.2/ & + ' creep B coefficient : ',E9.3/ & + ' creep C coefficient : ',F5.2/ & + ' creep D coefficient : ',F5.2/ & + ' creep N power : ',F5.2/ & + ' elastic energy factor : ',F5.2/ & + ' factor for ice breakup : ',F5.2/ & + ' IS2WIM1 : ',F5.2/ & + ' anelastic dissipation : ',L3/ & + ' energy of activation : ',F5.2/ & + ' anelastic coefficient : ',E11.3/ & + ' anelastic exponent : ',F5.2) +2948 FORMAT ( ' &SIS2 ISC1 =',E9.3,', IS2BACKSCAT =',E9.3, & + ', IS2ISOSCAT =',L3,', IS2BREAK =',L3, & + ', IS2DUPDATE =',L3,','/ & + ' IS2FLEXSTR =',E11.3,', IS2DISP =',L3, & + ', IS2DAMP =',F3.1, & + ', IS2FRAGILITY =',F4.2,', IS2DMIN =',F5.2,','/ & + ' IS2C2 =',F12.8,', IS2C3 =',F8.4, & + ', IS2CONC =',F5.1,', IS2CREEPB =',E11.3,','/ & + ' IS2CREEPC =',F5.2,', IS2CREEPD =',F5.2, & + ', IS2CREEPN =',F5.2,','/ & + ' IS2BREAKE =',F5.2, & + ', IS2BREAKF =',F5.2,', IS2WIM1 =',F5.2,','/ & + ', IS2ANDISB =',L3,', IS2ANDISE =',F5.2, & + ', IS2ANDISD =',E11.3,', IS2ANDISN=',F5.2, ' /') #endif #ifdef W3_UOST - 4500 FORMAT (/' Unresolved Obstacles Source Term (UOST) ',A,/ & - ' --------------------------------------------------') - 4501 FORMAT (' local alpha-beta file: ',A, & - ' shadow alpha-beta file: ',A,/ & - ' local calibration factor: ',F5.2, & - ' shadow calibration factor: ',F5.2) - 4502 FORMAT (' &UOST UOSTFILELOCAL = ',A,', UOSTFILESHADOW = ',A,/ & - ' UOSTFACTORLOCAL = ',F5.2', UOSTFACTORSHADOW = ',F5.2,' /') -#endif -! - 950 FORMAT (/' Propagation scheme : '/ & - ' --------------------------------------------------') - 951 FORMAT ( ' Type of scheme (structured) :',1X,A) - 2951 FORMAT ( ' Type of scheme(unstructured):',1X,A) - 2952 FORMAT ( ' wave setup computation:',1X,A) - 952 FORMAT ( ' ',1X,A) +4500 FORMAT (/' Unresolved Obstacles Source Term (UOST) ',A,/ & + ' --------------------------------------------------') +4501 FORMAT (' local alpha-beta file: ',A, & + ' shadow alpha-beta file: ',A,/ & + ' local calibration factor: ',F5.2, & + ' shadow calibration factor: ',F5.2) +4502 FORMAT (' &UOST UOSTFILELOCAL = ',A,', UOSTFILESHADOW = ',A,/ & + ' UOSTFACTORLOCAL = ',F5.2', UOSTFACTORSHADOW = ',F5.2,' /') +#endif + ! +950 FORMAT (/' Propagation scheme : '/ & + ' --------------------------------------------------') +951 FORMAT ( ' Type of scheme (structured) :',1X,A) +2951 FORMAT ( ' Type of scheme(unstructured):',1X,A) +2952 FORMAT ( ' wave setup computation:',1X,A) +952 FORMAT ( ' ',1X,A) #ifdef W3_PR1 - 953 FORMAT ( ' CFLmax depth refraction :',F9.3/) - 2953 FORMAT ( ' &PRO1 CFLTM =',F5.2,' /') +953 FORMAT ( ' CFLmax depth refraction :',F9.3/) +2953 FORMAT ( ' &PRO1 CFLTM =',F5.2,' /') #endif -! + ! #ifdef W3_PR2 - 953 FORMAT ( ' CFLmax depth refraction :',F9.3/ & - ' Effective swell age (h) : switched off'/ & - ' Cut-off latitude (degr.) :',F7.1/) - 954 FORMAT ( ' CFLmax depth refraction :',F9.3/ & - ' Effective swell age (h) :',F8.2/ & - ' Cut-off latitude (degr.) :',F7.1/) - 2953 FORMAT ( ' &PRO2 CFLTM =',F5.2,', DTIME =',F8.0, & - ', LATMIN =',F5.1,' /') -#endif -! +953 FORMAT ( ' CFLmax depth refraction :',F9.3/ & + ' Effective swell age (h) : switched off'/ & + ' Cut-off latitude (degr.) :',F7.1/) +954 FORMAT ( ' CFLmax depth refraction :',F9.3/ & + ' Effective swell age (h) :',F8.2/ & + ' Cut-off latitude (degr.) :',F7.1/) +2953 FORMAT ( ' &PRO2 CFLTM =',F5.2,', DTIME =',F8.0, & + ', LATMIN =',F5.1,' /') +#endif + ! #ifdef W3_SMC - 1950 FORMAT (/' SMC grid parameters : '/ & - ' --------------------------------------------------') - 1951 FORMAT ( ' Type of scheme (structured) :',1X,A) - 1953 FORMAT ( ' Max propagation CFL number :',F9.3/ & - ' Effective swell age (h) :',F8.2/ & - ' Maximum refraction (degr.) :',F8.2/) - 2954 FORMAT ( ' &PSMC CFLSM =',F5.2,', DTIMS =', F9.1/ & - ' Arctic =',L5, ', RFMAXD =', F9.2/ & - ' UNO3 =',L5, ', AVERG =',L5/ & - ' LvSMC =',i5, ', NBISMC =',i9/ & - ' ISHFT =',i5, ', JEQT =',i9/ & - ' SEAWND =',L5, '/') -#endif -! +1950 FORMAT (/' SMC grid parameters : '/ & + ' --------------------------------------------------') +1951 FORMAT ( ' Type of scheme (structured) :',1X,A) +1953 FORMAT ( ' Max propagation CFL number :',F9.3/ & + ' Effective swell age (h) :',F8.2/ & + ' Maximum refraction (degr.) :',F8.2/) +2954 FORMAT ( ' &PSMC CFLSM =',F5.2,', DTIMS =', F9.1/ & + ' Arctic =',L5, ', RFMAXD =', F9.2/ & + ' UNO3 =',L5, ', AVERG =',L5/ & + ' LvSMC =',i5, ', NBISMC =',i9/ & + ' ISHFT =',i5, ', JEQT =',i9/ & + ' SEAWND =',L5, '/') +#endif + ! #ifdef W3_PR3 - 953 FORMAT ( ' CFLmax depth refraction :',F9.3/ & - ' Averaging area factor Cg :',F8.2) - 954 FORMAT ( ' Averaging area factor theta :',F8.2) - 955 FORMAT ( ' **** Internal maximum .GE.',F6.2,' ****') - 2953 FORMAT ( ' &PRO3 CFLTM =',F5.2, & - ', WDTHCG = ',F4.2,', WDTHTH = ',F4.2,' /') -#endif -! - 2956 FORMAT ( ' &UNST UGBCCFL =',L3,', UGOBCAUTO =',L3, & - ', UGOBCDEPTH =', F8.3,', UGOBCFILE=',A,','/ & - ', EXPFSN =',L3,',EXPFSPSI =',L3, & - ', EXPFSFCT =', L3,',IMPFSN =',L3,',EXPTOTAL=',L3, & - ', IMPTOTAL=',L3,',IMPREFRACTION=', L3, & - ', IMPFREQSHIFT=', L3,', IMPSOURCE=', L3, & - ', SETUP_APPLY_WLV=', L3, & - ', JGS_TERMINATE_MAXITER=', L3, & - ', JGS_TERMINATE_DIFFERENCE=', L3, & - ', JGS_TERMINATE_NORM=', L3, & - ', JGS_LIMITER=', L3, & - ', JGS_USE_JACOBI=', L3, & - ', JGS_BLOCK_GAUSS_SEIDEL=', L3, & - ', JGS_MAXITER=', I5, & - ', JGS_PMIN=', F8.3, & - ', JGS_DIFF_THR=', F8.3, & - ', JGS_NORM_THR=', F8.3, & - ', JGS_NLEVEL=', I3, & - ', JGS_SOURCE_NONLINEAR=', L3 / ) -! - 960 FORMAT (/' Miscellaneous ',A/ & - ' --------------------------------------------------') - 2961 FORMAT ( ' *** WAVEWATCH-III WARNING IN W3GRID :'/ & - ' CICE0.NE.CICEN requires FLAGTR>2'/ & - ' Parameters corrected: CICE0 = CICEN'/) - 2962 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID : User requests', & +953 FORMAT ( ' CFLmax depth refraction :',F9.3/ & + ' Averaging area factor Cg :',F8.2) +954 FORMAT ( ' Averaging area factor theta :',F8.2) +955 FORMAT ( ' **** Internal maximum .GE.',F6.2,' ****') +2953 FORMAT ( ' &PRO3 CFLTM =',F5.2, & + ', WDTHCG = ',F4.2,', WDTHTH = ',F4.2,' /') +#endif + ! +2956 FORMAT ( ' &UNST UGBCCFL =',L3,', UGOBCAUTO =',L3, & + ', UGOBCDEPTH =', F8.3,', UGOBCFILE=',A,','/ & + ', EXPFSN =',L3,',EXPFSPSI =',L3, & + ', EXPFSFCT =', L3,',IMPFSN =',L3,',EXPTOTAL=',L3, & + ', IMPTOTAL=',L3,',IMPREFRACTION=', L3, & + ', IMPFREQSHIFT=', L3,', IMPSOURCE=', L3, & + ', SETUP_APPLY_WLV=', L3, & + ', JGS_TERMINATE_MAXITER=', L3, & + ', JGS_TERMINATE_DIFFERENCE=', L3, & + ', JGS_TERMINATE_NORM=', L3, & + ', JGS_LIMITER=', L3, & + ', JGS_USE_JACOBI=', L3, & + ', JGS_BLOCK_GAUSS_SEIDEL=', L3, & + ', JGS_MAXITER=', I5, & + ', JGS_PMIN=', F8.3, & + ', JGS_DIFF_THR=', F8.3, & + ', JGS_NORM_THR=', F8.3, & + ', JGS_NLEVEL=', I3, & + ', JGS_SOURCE_NONLINEAR=', L3 / ) + ! +960 FORMAT (/' Miscellaneous ',A/ & + ' --------------------------------------------------') +2961 FORMAT ( ' *** WAVEWATCH-III WARNING IN W3GRID :'/ & + ' CICE0.NE.CICEN requires FLAGTR>2'/ & + ' Parameters corrected: CICE0 = CICEN'/) +2962 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID : User requests', & 'CICE0=CICEN corresponding to discontinuous treatment of ', & 'ice, so we will change FLAGTR') - 2963 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & - ' Ice physics used, so we will change FLAGTR.') - 961 FORMAT ( ' Ice concentration cut-offs :',F8.2,F6.2) +2963 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & + ' Ice physics used, so we will change FLAGTR.') +961 FORMAT ( ' Ice concentration cut-offs :',F8.2,F6.2) #ifdef W3_MGG - 962 FORMAT ( ' Moving grid GSE cor. power :',F8.2) +962 FORMAT ( ' Moving grid GSE cor. power :',F8.2) #endif #ifdef W3_SCRIP - 963 FORMAT( ' Grid offset for multi-grid w/SCRIP : ',E11.3) +963 FORMAT( ' Grid offset for multi-grid w/SCRIP : ',E11.3) #endif - 1972 FORMAT ( ' Compression of track output : ',L3) +1972 FORMAT ( ' Compression of track output : ',L3) #ifdef W3_SEED - 964 FORMAT ( ' Xseed in seeding algorithm :',F8.2) -#endif - 965 FORMAT (/' Dynamic source term integration scheme :'/ & - ' Xp (-) :',F9.3/ & - ' Xr (-) :',F9.3/ & - ' Xfilt (-) :',F9.3) - 966 FORMAT (/' Wave field partitioning :'/ & - ' Levels (-) :',I5/ & - ' Minimum wave height (m) :',F9.3/ & - ' Wind area multiplier (-) :',F9.3/ & - ' Cut-off wind sea fract. (-) :',F9.3/ & - ' Combine wind seas : ',A/ & - ' Number of swells in fld out :',I5) - 967 FORMAT (/' Miche-style limiting wave height :'/ & - ' Hs,max/d factor (-) :',F9.3/ & - ' Hrms,max/d factor (-) :',F9.3/ & - ' Limiter activated : ',A) - 968 FORMAT ( ' *** FACTOR DANGEROUSLY LOW ***') - 1973 FORMAT (/' Calendar type : ',A) -! +964 FORMAT ( ' Xseed in seeding algorithm :',F8.2) +#endif +965 FORMAT (/' Dynamic source term integration scheme :'/ & + ' Xp (-) :',F9.3/ & + ' Xr (-) :',F9.3/ & + ' Xfilt (-) :',F9.3) +966 FORMAT (/' Wave field partitioning :'/ & + ' Levels (-) :',I5/ & + ' Minimum wave height (m) :',F9.3/ & + ' Wind area multiplier (-) :',F9.3/ & + ' Cut-off wind sea fract. (-) :',F9.3/ & + ' Combine wind seas : ',A/ & + ' Number of swells in fld out :',I5) +967 FORMAT (/' Miche-style limiting wave height :'/ & + ' Hs,max/d factor (-) :',F9.3/ & + ' Hrms,max/d factor (-) :',F9.3/ & + ' Limiter activated : ',A) +968 FORMAT ( ' *** FACTOR DANGEROUSLY LOW ***') +1973 FORMAT (/' Calendar type : ',A) + ! #ifdef W3_REF1 - 969 FORMAT (/' Shoreline reflection ',A/ & - ' --------------------------------------------------') +969 FORMAT (/' Shoreline reflection ',A/ & + ' --------------------------------------------------') #endif -! + ! #ifdef W3_IG1 - 970 FORMAT (/' Second order and infragravity waves ',A/ & - ' --------------------------------------------------') +970 FORMAT (/' Second order and infragravity waves ',A/ & + ' --------------------------------------------------') #endif -! - 5971 FORMAT (' Partitioning method : ',A) - 5972 FORMAT (' Namelist options overridden : ',A) -! + ! +5971 FORMAT (' Partitioning method : ',A) +5972 FORMAT (' Namelist options overridden : ',A) + ! #ifdef W3_IC2 - 971 FORMAT (/' Boundary layer below ice ',A/ & - ' --------------------------------------------------') +971 FORMAT (/' Boundary layer below ice ',A/ & + ' --------------------------------------------------') #endif #ifdef W3_IC3 - 971 FORMAT (/' Visco-elastic ice layer ',A/ & - ' --------------------------------------------------') +971 FORMAT (/' Visco-elastic ice layer ',A/ & + ' --------------------------------------------------') #endif #ifdef W3_IC4 - 971 FORMAT (/' Empirical wave-ice physics ',A/ & - ' --------------------------------------------------') +971 FORMAT (/' Empirical wave-ice physics ',A/ & + ' --------------------------------------------------') #endif #ifdef W3_IC5 - 971 FORMAT (/' Effective medium ice model (SIC5) ',A/ & - ' --------------------------------------------------') - 2971 FORMAT ( ' Min. Ice shear modulus G : ', E10.1/, & - ' Min. Wave period T : ', F7.2/, & - ' Max. Wavenumber Ratio (Ko/Kr): ', E10.1/, & - ' Max. Attenu. Rate (Ki) : ', E10.1/, & - ' Min. Water depth (d) : ', F5.0/, & - ' Max. # of Newton Iter. : ', F5.0/, & - ' Use Rand. Kick : ', F5.0/, & - ' Excluded Imag. Corridor : ', F9.4/, & - ' Selected ice model : ', A/) -#endif -! - 8972 FORMAT ( ' Wind input reduction factor in presence of ', & - /' ice :',F6.2, & - /' (0.0==> no reduction and 1.0==> no wind', & - /' input with 100% ice cover)') -! -! - 4970 FORMAT (/' Spectral output on full grid ',A/ & - ' --------------------------------------------------') - 4971 FORMAT ( ' Second order pressure at K=0:',3I4) - 4972 FORMAT ( ' Spectrum of Uss :',3I4) - 4973 FORMAT ( ' Frequency spectrum :',3I4) - 4974 FORMAT ( ' Partions of Uss :',2I4) - 4975 FORMAT ( ' Partition wavenumber #',I2,' : ',1F6.3) - -! - 4980 FORMAT (/' Coastal / iceberg reflection ',A/ & - ' --------------------------------------------------') - 4981 FORMAT ( ' Coefficient for shorelines :',F6.4) - 4989 FORMAT ( ' *** CURVLINEAR GRID: REFLECTION NOT IMPLEMENTED YET ***') - 2977 FORMAT ( ' &SIG1 IGMETHOD =',I2,', IGADDOUTP =',I2,', IGSOURCE =',I2, & - ', IGSTERMS = ',I2,', IGBCOVERWRITE =', L3,','/ & - ' IGSWELLMAX =', L3,', IGMAXFREQ =',F6.4, & - ', IGSOURCEATBP = ',I2,', IGKDMIN = ',F6.4,','/ & - ' IGFIXEDDEPTH = ',F6.2,', IGEMPIRICAL = ',F8.6,' /') -! - 2978 FORMAT ( ' &SIC2 IC2DISPER =',L3,', IC2TURB =',F6.2, & - ', IC2ROUGH =',F10.6,','/ & - ' IC2REYNOLDS = ',F10.1,', IC2SMOOTH = ',F10.1, & - ', IC2VISC =',F6.3,','/ & - ', IC2TURBS =',F8.2,', IC2DMAX =',F5.3,' /') -! - 2979 FORMAT ( ' &SIC3 IC3MAXTHK =',F6.2, ', IC3MAXCNC =',F6.2,','/ & - ' IC2TURB =',F8.2, & - ', IC2ROUGH =',F7.3,','/ & - ' IC2REYNOLDS = ',F10.1,', IC2SMOOTH = ',F10.1, & - ', IC2VISC =',F10.3,','/ & - ' IC2TURBS =',F8.2,', IC3CHENG =',L3, & - ', USECGICE =',L3,', IC3HILIM = ',F6.2,','/ & - ' IC3KILIM = ',E9.2,', IC3HICE = ',E9.2, & - ', IC3VISC = ',E9.2,','/ & - ' IC3DENS = ',E9.2,', IC3ELAS = ',E9.2,' /') -! - 2981 FORMAT ( ' &SIC5 IC5MINIG = ', E9.2, ', IC5MINWT = ', F5.2, & - ', IC5MAXKRATIO = ', E9.2, ','/ & - ' IC5MAXKI = ', E9.2, ', IC5MINHW = ', F4.0, & - ', IC5MAXITER = ', F4.0, ','/ & - ' IC5RKICK = ', F2.0, ', IC5KFILTER = ', F7.4, & - ', IC5VEMOD = ', F4.0, ' /') -! - 2966 FORMAT ( ' &MISC CICE0 =',F6.3,', CICEN =',F6.3, & - ', LICE = ',F8.1,', PMOVE =',F6.3,','/ & - ' XSEED =',F6.3,', FLAGTR = ', I1, & - ', XP =',F6.3,', XR =',F6.3,', XFILT =', F6.3 / & - ' IHM =',I5,', HSPM =',F6.3,', WSM =',F6.3, & - ', WSC =',F6.3,', FLC = ',A/ & - ' NOSW =',I3,', FMICHE =',F6.3,', RWNDC =' , & - F6.3,', WCOR1 =',F6.2,', WCOR2 =',F6.2,','/ & - ' FACBERG =',F4.1,', GSHIFT = ',E11.3, & - ', STDX = ' ,F7.2,', STDY =',F7.2,','/ & - ' STDT =', F8.2, & - ', ICEHMIN =',F5.2,', ICEHFAC =',F5.2,','/ & - ' ICEHINIT =',F5.2,', ICEDISP =',L3, & - ', ICEHDISP =',F5.2,','/ & - ' ICESLN = ',F6.2,', ICEWIND = ',F6.2, & - ', ICESNL = ',F6.2,', ICESDS = ',F5.2,','/ & - ' ICEDDISP = ',F5.2,', ICEFDISP = ',F5.2, & - ', CALTYPE = ',A8,' , TRCKCMPR = ', L3,','/ & - ' BTBET = ', F6.2, ' /') -! - 2976 FORMAT ( ' &OUTS P2SF =',I2,', I1P2SF =',I2,', I2P2SF =',I3,','/& - ' US3D =',I2,', I1US3D =',I3,', I2US3D =',I3,','/& - ' USSP =',I2,', IUSSP =',I3,','/& - ' E3D =',I2,', I1E3D =',I3,', I2E3D =',I3,','/& - ' TH1MF =',I2,', I1TH1M =',I3,', I2TH1M =',I3,','/& - ' STH1MF=',I2,', I1STH1M=',I3,', I2STH1M=',I3,','/& - ' TH2MF =',I2,', I1TH2M =',I3,', I2TH2M =',I3,','/& - ' STH2MF=',I2,', I1STH2M=',I3,', I2STH2M=',I3,' /') -! - 2986 FORMAT ( ' &REF1 REFCOAST =',F5.2,', REFFREQ =',F5.2,', REFSLOPE =',F5.3, & - ', REFMAP =',F4.1, ', REFMAPD =',F4.1, ', REFSUBGRID =',F5.2,','/ & - ' REFRMAX=',F5.2,', REFFREQPOW =',F5.2, & - ', REFICEBERG =',F5.2,', REFCOSP_STRAIGHT =',F4.1,' /') -! - 2987 FORMAT ( ' &FLD TAIL_ID =',I1,' TAIL_LEV =',F5.4,' TAILT1 =',F5.3,& - ' TAILT2 =',F5.3,' /') +971 FORMAT (/' Effective medium ice model (SIC5) ',A/ & + ' --------------------------------------------------') +2971 FORMAT ( ' Min. Ice shear modulus G : ', E10.1/, & + ' Min. Wave period T : ', F7.2/, & + ' Max. Wavenumber Ratio (Ko/Kr): ', E10.1/, & + ' Max. Attenu. Rate (Ki) : ', E10.1/, & + ' Min. Water depth (d) : ', F5.0/, & + ' Max. # of Newton Iter. : ', F5.0/, & + ' Use Rand. Kick : ', F5.0/, & + ' Excluded Imag. Corridor : ', F9.4/, & + ' Selected ice model : ', A/) +#endif + ! +8972 FORMAT ( ' Wind input reduction factor in presence of ', & + /' ice :',F6.2, & + /' (0.0==> no reduction and 1.0==> no wind', & + /' input with 100% ice cover)') + ! + ! +4970 FORMAT (/' Spectral output on full grid ',A/ & + ' --------------------------------------------------') +4971 FORMAT ( ' Second order pressure at K=0:',3I4) +4972 FORMAT ( ' Spectrum of Uss :',3I4) +4973 FORMAT ( ' Frequency spectrum :',3I4) +4974 FORMAT ( ' Partions of Uss :',2I4) +4975 FORMAT ( ' Partition wavenumber #',I2,' : ',1F6.3) + + ! +4980 FORMAT (/' Coastal / iceberg reflection ',A/ & + ' --------------------------------------------------') +4981 FORMAT ( ' Coefficient for shorelines :',F6.4) +4989 FORMAT ( ' *** CURVLINEAR GRID: REFLECTION NOT IMPLEMENTED YET ***') +2977 FORMAT ( ' &SIG1 IGMETHOD =',I2,', IGADDOUTP =',I2,', IGSOURCE =',I2, & + ', IGSTERMS = ',I2,', IGBCOVERWRITE =', L3,','/ & + ' IGSWELLMAX =', L3,', IGMAXFREQ =',F6.4, & + ', IGSOURCEATBP = ',I2,', IGKDMIN = ',F6.4,','/ & + ' IGFIXEDDEPTH = ',F6.2,', IGEMPIRICAL = ',F8.6,' /') + ! +2978 FORMAT ( ' &SIC2 IC2DISPER =',L3,', IC2TURB =',F6.2, & + ', IC2ROUGH =',F10.6,','/ & + ' IC2REYNOLDS = ',F10.1,', IC2SMOOTH = ',F10.1, & + ', IC2VISC =',F6.3,','/ & + ', IC2TURBS =',F8.2,', IC2DMAX =',F5.3,' /') + ! +2979 FORMAT ( ' &SIC3 IC3MAXTHK =',F6.2, ', IC3MAXCNC =',F6.2,','/ & + ' IC2TURB =',F8.2, & + ', IC2ROUGH =',F7.3,','/ & + ' IC2REYNOLDS = ',F10.1,', IC2SMOOTH = ',F10.1, & + ', IC2VISC =',F10.3,','/ & + ' IC2TURBS =',F8.2,', IC3CHENG =',L3, & + ', USECGICE =',L3,', IC3HILIM = ',F6.2,','/ & + ' IC3KILIM = ',E9.2,', IC3HICE = ',E9.2, & + ', IC3VISC = ',E9.2,','/ & + ' IC3DENS = ',E9.2,', IC3ELAS = ',E9.2,' /') + ! +2981 FORMAT ( ' &SIC5 IC5MINIG = ', E9.2, ', IC5MINWT = ', F5.2, & + ', IC5MAXKRATIO = ', E9.2, ','/ & + ' IC5MAXKI = ', E9.2, ', IC5MINHW = ', F4.0, & + ', IC5MAXITER = ', F4.0, ','/ & + ' IC5RKICK = ', F2.0, ', IC5KFILTER = ', F7.4, & + ', IC5VEMOD = ', F4.0, ' /') + ! +2966 FORMAT ( ' &MISC CICE0 =',F6.3,', CICEN =',F6.3, & + ', LICE = ',F8.1,', PMOVE =',F6.3,','/ & + ' XSEED =',F6.3,', FLAGTR = ', I1, & + ', XP =',F6.3,', XR =',F6.3,', XFILT =', F6.3 / & + ' IHM =',I5,', HSPM =',F6.3,', WSM =',F6.3, & + ', WSC =',F6.3,', FLC = ',A/ & + ' NOSW =',I3,', FMICHE =',F6.3,', RWNDC =' , & + F6.3,', WCOR1 =',F6.2,', WCOR2 =',F6.2,','/ & + ' FACBERG =',F4.1,', GSHIFT = ',E11.3, & + ', STDX = ' ,F7.2,', STDY =',F7.2,','/ & + ' STDT =', F8.2, & + ', ICEHMIN =',F5.2,', ICEHFAC =',F5.2,','/ & + ' ICEHINIT =',F5.2,', ICEDISP =',L3, & + ', ICEHDISP =',F5.2,','/ & + ' ICESLN = ',F6.2,', ICEWIND = ',F6.2, & + ', ICESNL = ',F6.2,', ICESDS = ',F5.2,','/ & + ' ICEDDISP = ',F5.2,', ICEFDISP = ',F5.2, & + ', CALTYPE = ',A8,' , TRCKCMPR = ', L3,','/ & + ' BTBET = ', F6.2, ' /') + ! +2976 FORMAT ( ' &OUTS P2SF =',I2,', I1P2SF =',I2,', I2P2SF =',I3,','/& + ' US3D =',I2,', I1US3D =',I3,', I2US3D =',I3,','/& + ' USSP =',I2,', IUSSP =',I3,','/& + ' E3D =',I2,', I1E3D =',I3,', I2E3D =',I3,','/& + ' TH1MF =',I2,', I1TH1M =',I3,', I2TH1M =',I3,','/& + ' STH1MF=',I2,', I1STH1M=',I3,', I2STH1M=',I3,','/& + ' TH2MF =',I2,', I1TH2M =',I3,', I2TH2M =',I3,','/& + ' STH2MF=',I2,', I1STH2M=',I3,', I2STH2M=',I3,' /') + ! +2986 FORMAT ( ' &REF1 REFCOAST =',F5.2,', REFFREQ =',F5.2,', REFSLOPE =',F5.3, & + ', REFMAP =',F4.1, ', REFMAPD =',F4.1, ', REFSUBGRID =',F5.2,','/ & + ' REFRMAX=',F5.2,', REFFREQPOW =',F5.2, & + ', REFICEBERG =',F5.2,', REFCOSP_STRAIGHT =',F4.1,' /') + ! +2987 FORMAT ( ' &FLD TAIL_ID =',I1,' TAIL_LEV =',F5.4,' TAILT1 =',F5.3,& + ' TAILT2 =',F5.3,' /') #ifdef W3_RTD - 4991 FORMAT ( ' &ROTD PLAT =', F6.2,', PLON =', F7.2,', UNROT =',L3,' /') - 4992 FORMAT ( ' &ROTB BPLAT =',9(F6.1,",")/ & - ' BPLON =',9(F6.1,","),' /') -#endif - - 3000 FORMAT (/' The spatial grid: '/ & - ' --------------------------------------------------'/ & - /' Grid type : ',A) - 3001 FORMAT ( ' Coordinate system : ',A) - 3002 FORMAT ( ' Index closure type : ',A) - 3003 FORMAT ( ' Dimensions : ',I6,I8) - 3004 FORMAT (/' Increments (deg.) :',2F10.4/ & - ' Longitude range (deg.) :',2F10.4/ & - ' Latitude range (deg.) :',2F10.4) - 3005 FORMAT ( ' Increments (km) :',2F8.2/ & - ' X range (km) :',2F8.2/ & - ' Y range (km) :',2F8.2) - 3006 FORMAT (/' X-coordinate unit :',I6/ & - ' Scale factor :',F10.4/ & - ' Add offset :',E12.4/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 3007 FORMAT (/' Y-coordinate unit :',I6/ & - ' Scale factor :',F10.4/ & - ' Add offset :',E12.4/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 3008 FORMAT ( ' Format : ',A) - 3009 FORMAT ( ' File name : ',A) +4991 FORMAT ( ' &ROTD PLAT =', F6.2,', PLON =', F7.2,', UNROT =',L3,' /') +4992 FORMAT ( ' &ROTB BPLAT =',9(F6.1,",")/ & + ' BPLON =',9(F6.1,","),' /') +#endif + +3000 FORMAT (/' The spatial grid: '/ & + ' --------------------------------------------------'/ & + /' Grid type : ',A) +3001 FORMAT ( ' Coordinate system : ',A) +3002 FORMAT ( ' Index closure type : ',A) +3003 FORMAT ( ' Dimensions : ',I6,I8) +3004 FORMAT (/' Increments (deg.) :',2F10.4/ & + ' Longitude range (deg.) :',2F10.4/ & + ' Latitude range (deg.) :',2F10.4) +3005 FORMAT ( ' Increments (km) :',2F8.2/ & + ' X range (km) :',2F8.2/ & + ' Y range (km) :',2F8.2) +3006 FORMAT (/' X-coordinate unit :',I6/ & + ' Scale factor :',F10.4/ & + ' Add offset :',E12.4/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) +3007 FORMAT (/' Y-coordinate unit :',I6/ & + ' Scale factor :',F10.4/ & + ' Add offset :',E12.4/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) +3008 FORMAT ( ' Format : ',A) +3009 FORMAT ( ' File name : ',A) #ifdef W3_SMC - 4001 FORMAT ( ' SMC refined levels NRLv = ',I8) - 4002 FORMAT ( ' SMC Equator j shift no. = ',I8) - 4302 FORMAT ( ' SMC I-index shift number = ',I8) - 4003 FORMAT ( ' SMC input boundary no. = ',I8) - 4004 FORMAT ( ' SMC NCel = ',6I9) - 4005 FORMAT ( ' IJKCel(5,NCel) read from ', A) - 4006 FORMAT (6I8) - 4007 FORMAT ( ' SMC NUFc = ',6I9) - 4008 FORMAT ( ' IJKUFc(7,NCel) read from ', A) - 4009 FORMAT (8I8) - 4010 FORMAT ( ' SMC NVFc = ',6I9) - 4011 FORMAT ( ' IJKVFc(8,NCel) read from ', A) - 4110 FORMAT ( ' SMC NCObsr = ',6I9) - 4111 FORMAT ( ' IJKObstr(1,NCel) read from ', A) - 4012 FORMAT (9I8) - 4013 FORMAT ( ' NBICelin(NBISMC) read from ', A) - 4014 FORMAT (2I8) - 4015 FORMAT ( ' ARC NARC = ',6I9) - 4016 FORMAT ( ' IJKCel(5,NARC) read from ', A) - 4017 FORMAT ( ' ARC NAUI = ',6I9) - 4018 FORMAT ( ' IJKUFc(7,NAUI) read from ', A) - 4019 FORMAT ( ' ARC NAVJ = ',6I9) - 4020 FORMAT ( ' IJKVFc(8,NAVJ) read from ', A) - 4021 FORMAT ( ' Varables by W3DIMX NCel = ',I9) - 4022 FORMAT ( ' Defined NLvCel ',6I9) - 4023 FORMAT ( ' Defined NLvUFc ',6I9) - 4024 FORMAT ( ' Defined NLvVFc ',6I9) - 4025 FORMAT ( ' Define IJKCel from -9 to ',I9) - 4026 FORMAT ( ' IJKCel(5,NCel) defined : ') - 4027 FORMAT ( ' IJKUFc(7,NUFc) defined : ') - 4028 FORMAT ( ' IJKVFc(8,NVFc) defined : ') - 4029 FORMAT ( ' Boundary cells IJKCel(:,-9:0) : ') - 4030 FORMAT (5I8) - 4031 FORMAT ( ' Define MAPSF ... 1 to ',I9) - 4032 FORMAT ( ' Multi-Resolution factor = ',I6) - 4033 FORMAT ( ' Range of MAPSF(:,1) : ',2I9) - 4034 FORMAT ( ' Range of MAPSF(:,2) : ',2I9) - 4035 FORMAT ( ' Range of MAPSF(:,3) : ',2I9) - 4036 FORMAT ( ' Range of MAPFS(:,:) : ',2I9) - 4037 FORMAT ( ' Arctic AngArc defined as ',I6) - 4038 FORMAT (9F8.2) - 4039 FORMAT ( ' Arctic ICLBAC defined as ',I6) - 4040 FORMAT (9I8) +4001 FORMAT ( ' SMC refined levels NRLv = ',I8) +4002 FORMAT ( ' SMC Equator j shift no. = ',I8) +4302 FORMAT ( ' SMC I-index shift number = ',I8) +4003 FORMAT ( ' SMC input boundary no. = ',I8) +4004 FORMAT ( ' SMC NCel = ',6I9) +4005 FORMAT ( ' IJKCel(5,NCel) read from ', A) +4006 FORMAT (6I8) +4007 FORMAT ( ' SMC NUFc = ',6I9) +4008 FORMAT ( ' IJKUFc(7,NCel) read from ', A) +4009 FORMAT (8I8) +4010 FORMAT ( ' SMC NVFc = ',6I9) +4011 FORMAT ( ' IJKVFc(8,NCel) read from ', A) +4110 FORMAT ( ' SMC NCObsr = ',6I9) +4111 FORMAT ( ' IJKObstr(1,NCel) read from ', A) +4012 FORMAT (9I8) +4013 FORMAT ( ' NBICelin(NBISMC) read from ', A) +4014 FORMAT (2I8) +4015 FORMAT ( ' ARC NARC = ',6I9) +4016 FORMAT ( ' IJKCel(5,NARC) read from ', A) +4017 FORMAT ( ' ARC NAUI = ',6I9) +4018 FORMAT ( ' IJKUFc(7,NAUI) read from ', A) +4019 FORMAT ( ' ARC NAVJ = ',6I9) +4020 FORMAT ( ' IJKVFc(8,NAVJ) read from ', A) +4021 FORMAT ( ' Varables by W3DIMX NCel = ',I9) +4022 FORMAT ( ' Defined NLvCel ',6I9) +4023 FORMAT ( ' Defined NLvUFc ',6I9) +4024 FORMAT ( ' Defined NLvVFc ',6I9) +4025 FORMAT ( ' Define IJKCel from -9 to ',I9) +4026 FORMAT ( ' IJKCel(5,NCel) defined : ') +4027 FORMAT ( ' IJKUFc(7,NUFc) defined : ') +4028 FORMAT ( ' IJKVFc(8,NVFc) defined : ') +4029 FORMAT ( ' Boundary cells IJKCel(:,-9:0) : ') +4030 FORMAT (5I8) +4031 FORMAT ( ' Define MAPSF ... 1 to ',I9) +4032 FORMAT ( ' Multi-Resolution factor = ',I6) +4033 FORMAT ( ' Range of MAPSF(:,1) : ',2I9) +4034 FORMAT ( ' Range of MAPSF(:,2) : ',2I9) +4035 FORMAT ( ' Range of MAPSF(:,3) : ',2I9) +4036 FORMAT ( ' Range of MAPFS(:,:) : ',2I9) +4037 FORMAT ( ' Arctic AngArc defined as ',I6) +4038 FORMAT (9F8.2) +4039 FORMAT ( ' Arctic ICLBAC defined as ',I6) +4040 FORMAT (9I8) #endif #ifdef W3_RTD - 4200 FORMAT ( ' AnglDin(NX,NY) defn checks : ') - 4201 FORMAT ( ' JY/IX',4I8) - 4202 FORMAT (I12,4F8.2) - 4203 FORMAT ( ' Rotated pole lat/lon (deg.) : ',2F9.3) - 4204 FORMAT ( ' Output dirns and x-y vectors will be set to True North') -#endif - 972 FORMAT (/' Bottom level unit :',I6/ & - ' Limiting depth (m) :',F8.2/ & - ' Minimum depth (m) :',F8.2/ & - ' Scale factor :',F8.2/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 973 FORMAT ( ' Format : ',A) - 974 FORMAT ( ' File name : ',A) - 976 FORMAT (/' Sub-grid information : ',A) - 977 FORMAT ( ' Obstructions unit :',I6/ & - ' Scale factor :',F10.4/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 978 FORMAT (/' Mask information : From file.'/ & - ' Mask unit :',I6/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 1977 FORMAT ( ' Shoreline slope :',I6/ & - ' Scale factor :',F10.4/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 1978 FORMAT ( ' Grain sizes :',I6/ & - ' Scale factor :',F10.4/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) -! - 979 FORMAT ( ' Processing ',A) - 980 FORMAT (/' Input boundary points : '/ & - ' --------------------------------------------------') - 1980 FORMAT (/' Excluded points : '/ & - ' --------------------------------------------------') - 981 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED), IX, IY =') - 1981 FORMAT ( ' *** POINT ALREADY EXCLUDED (SKIPPED), IX, IY =') - 982 FORMAT ( ' *** CANNOT CONNECT POINTS, IX, IY =') - 985 FORMAT ( ' No boundary points.'/) - 986 FORMAT ( ' Number of boundary points :',I6/) - 1985 FORMAT ( ' No excluded points.'/) - 1986 FORMAT ( ' Number of excluded points :',I6/) - 987 FORMAT ( ' Nr.| IX | IY | Long. | Lat. '/ & - ' -----|-------|-------|---------|---------') - 1987 FORMAT ( ' Nr.| IX | IY | X | Y '/ & - ' -----|-------|-------|-----------|-----------') - 988 FORMAT ( ' ',I4,2(' |',I6),2(' |',F8.2)) - 1988 FORMAT ( ' ',I4,2(' |',I6),2(' |',F8.1,'E3')) - 989 FORMAT ( ' ') -! - 990 FORMAT (/' Output boundary points : '/ & - ' --------------------------------------------------') - 991 FORMAT ( ' File nest',I1,'.ww3 Number of points :',I6/ & - ' Number of spectra :',I6) - 1991 FORMAT ( ' Dest. grid Polat:',F6.2,', Polon:',F8.2) - 992 FORMAT (/' Nr.| Long. | Lat. '/ & - ' -----|---------|---------') - 1992 FORMAT (/' Nr.| Long. | Lat. ', & - ' Nr.| Long. | Lat. '/ & - ' -----|---------|---------', & - ' -----|---------|---------') - 993 FORMAT ( ' ',I4,2(' |',F8.2)) - 1993 FORMAT ( ' ',I4,2(' |',F8.2), & - ' ',I4,2(' |',F8.2)) - 994 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED) : X,Y =',2F10.5) - 995 FORMAT ( ' *** POINT ON LAND (SKIPPED) : X,Y =',2F10.5) - 2992 FORMAT (/' Nr.| X | Y '/ & - ' -----|-----------|-----------') - 3992 FORMAT (/' Nr.| X | Y ', & - ' Nr.| X | Y '/ & - ' -----|-----------|-----------', & - ' -----|-----------|-----------') - 2993 FORMAT ( ' ',I4,2(' |',F8.1,'E3')) - 3993 FORMAT ( ' ',I4,2(' |',F8.1,'E3'), & - ' ',I4,2(' |',F8.1,'E3')) - 2994 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED) : X,Y =',2(F8.1,'E3')) - 2995 FORMAT ( ' *** POINT ON LAND (SKIPPED) : X,Y =',2(F8.1,'E3')) - 996 FORMAT ( ' No boundary points.'/) - 997 FORMAT ( ' Number of boundary points :',I6/ & - ' Number of spectra :',I6/) -! +4200 FORMAT ( ' AnglDin(NX,NY) defn checks : ') +4201 FORMAT ( ' JY/IX',4I8) +4202 FORMAT (I12,4F8.2) +4203 FORMAT ( ' Rotated pole lat/lon (deg.) : ',2F9.3) +4204 FORMAT ( ' Output dirns and x-y vectors will be set to True North') +#endif +972 FORMAT (/' Bottom level unit :',I6/ & + ' Limiting depth (m) :',F8.2/ & + ' Minimum depth (m) :',F8.2/ & + ' Scale factor :',F8.2/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) +973 FORMAT ( ' Format : ',A) +974 FORMAT ( ' File name : ',A) +976 FORMAT (/' Sub-grid information : ',A) +977 FORMAT ( ' Obstructions unit :',I6/ & + ' Scale factor :',F10.4/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) +978 FORMAT (/' Mask information : From file.'/ & + ' Mask unit :',I6/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) +1977 FORMAT ( ' Shoreline slope :',I6/ & + ' Scale factor :',F10.4/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) +1978 FORMAT ( ' Grain sizes :',I6/ & + ' Scale factor :',F10.4/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) + ! +979 FORMAT ( ' Processing ',A) +980 FORMAT (/' Input boundary points : '/ & + ' --------------------------------------------------') +1980 FORMAT (/' Excluded points : '/ & + ' --------------------------------------------------') +981 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED), IX, IY =') +1981 FORMAT ( ' *** POINT ALREADY EXCLUDED (SKIPPED), IX, IY =') +982 FORMAT ( ' *** CANNOT CONNECT POINTS, IX, IY =') +985 FORMAT ( ' No boundary points.'/) +986 FORMAT ( ' Number of boundary points :',I6/) +1985 FORMAT ( ' No excluded points.'/) +1986 FORMAT ( ' Number of excluded points :',I6/) +987 FORMAT ( ' Nr.| IX | IY | Long. | Lat. '/ & + ' -----|-------|-------|---------|---------') +1987 FORMAT ( ' Nr.| IX | IY | X | Y '/ & + ' -----|-------|-------|-----------|-----------') +988 FORMAT ( ' ',I4,2(' |',I6),2(' |',F8.2)) +1988 FORMAT ( ' ',I4,2(' |',I6),2(' |',F8.1,'E3')) +989 FORMAT ( ' ') + ! +990 FORMAT (/' Output boundary points : '/ & + ' --------------------------------------------------') +991 FORMAT ( ' File nest',I1,'.ww3 Number of points :',I6/ & + ' Number of spectra :',I6) +1991 FORMAT ( ' Dest. grid Polat:',F6.2,', Polon:',F8.2) +992 FORMAT (/' Nr.| Long. | Lat. '/ & + ' -----|---------|---------') +1992 FORMAT (/' Nr.| Long. | Lat. ', & + ' Nr.| Long. | Lat. '/ & + ' -----|---------|---------', & + ' -----|---------|---------') +993 FORMAT ( ' ',I4,2(' |',F8.2)) +1993 FORMAT ( ' ',I4,2(' |',F8.2), & + ' ',I4,2(' |',F8.2)) +994 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED) : X,Y =',2F10.5) +995 FORMAT ( ' *** POINT ON LAND (SKIPPED) : X,Y =',2F10.5) +2992 FORMAT (/' Nr.| X | Y '/ & + ' -----|-----------|-----------') +3992 FORMAT (/' Nr.| X | Y ', & + ' Nr.| X | Y '/ & + ' -----|-----------|-----------', & + ' -----|-----------|-----------') +2993 FORMAT ( ' ',I4,2(' |',F8.1,'E3')) +3993 FORMAT ( ' ',I4,2(' |',F8.1,'E3'), & + ' ',I4,2(' |',F8.1,'E3')) +2994 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED) : X,Y =',2(F8.1,'E3')) +2995 FORMAT ( ' *** POINT ON LAND (SKIPPED) : X,Y =',2(F8.1,'E3')) +996 FORMAT ( ' No boundary points.'/) +997 FORMAT ( ' Number of boundary points :',I6/ & + ' Number of spectra :',I6/) + ! #ifdef W3_O2a - 998 FORMAT (50I2) +998 FORMAT (50I2) #endif #ifdef W3_O2c - 1998 FORMAT (50I2) -#endif -! - 999 FORMAT (/' Writing model definition file ...'/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' INVALID CALENDAR TYPE: SELECT ONE OF:', & - ' standard, 360_day, or 365_day '/) -! - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' CANNOT READ UNFORMATTED (IDFM = 3) FROM UNIT', & - I4,' (ww3_grid.inp)'/) -! - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' BOTTOM AND OBSTRUCTION DATA FROM SAME FILE '/ & - ' BUT WITH INCOMPATIBLE FORMATS (',I1,',',I1,')'/) -! - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' TOO MANY NESTING OUTPUT FILES '/) -! - 1007 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' ILLEGAL GRID TYPE:',A4) -! - 1008 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' A CARTESIAN WITH CLOSURE IS NOT ALLOWED') -! - 1009 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' A RECTILINEAR TRIPOLE GRID IS NOT ALLOWED') -! - 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'// & - ' NO PROPAGATION + NO SOURCE TERMS = NO WAVE MODEL'// & - ' ( USE DRY RUN FLAG TO TEMPORARILY SWITCH OFF ', & - 'CALCULATIONS )'/) -! - 1011 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & - ' LEFT-HANDED GRID -- POSSIBLE CAUSE IS WRONG '/ & - ' IDLA:',I4,' . THIS MAY PRODUCE ERRORS '/ & - ' (COMMENT THIS EXTCDE AT YOUR OWN RISK).') -! - 1012 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' ILLEGAL GRID CLOSURE TYPE:',A4) -! - 1013 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & - ' THE GLOBAL (LOGICAL) INPUT FLAG IS DEPRECATED'/ & - ' AND REPLACED WITH A STRING INDICATING THE TYPE'/ & - ' OF GRID INDEX CLOSURE (NONE, SMPL or TRPL).'/ & - ' *** PLEASE UPDATE YOUR GRID INPUT FILE ACCORDINGLY ***'/) -! +1998 FORMAT (50I2) +#endif + ! +999 FORMAT (/' Writing model definition file ...'/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' INVALID CALENDAR TYPE: SELECT ONE OF:', & + ' standard, 360_day, or 365_day '/) + ! +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' CANNOT READ UNFORMATTED (IDFM = 3) FROM UNIT', & + I4,' (ww3_grid.inp)'/) + ! +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' BOTTOM AND OBSTRUCTION DATA FROM SAME FILE '/ & + ' BUT WITH INCOMPATIBLE FORMATS (',I1,',',I1,')'/) + ! +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' TOO MANY NESTING OUTPUT FILES '/) + ! +1007 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' ILLEGAL GRID TYPE:',A4) + ! +1008 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' A CARTESIAN WITH CLOSURE IS NOT ALLOWED') + ! +1009 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' A RECTILINEAR TRIPOLE GRID IS NOT ALLOWED') + ! +1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'// & + ' NO PROPAGATION + NO SOURCE TERMS = NO WAVE MODEL'// & + ' ( USE DRY RUN FLAG TO TEMPORARILY SWITCH OFF ', & + 'CALCULATIONS )'/) + ! +1011 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & + ' LEFT-HANDED GRID -- POSSIBLE CAUSE IS WRONG '/ & + ' IDLA:',I4,' . THIS MAY PRODUCE ERRORS '/ & + ' (COMMENT THIS EXTCDE AT YOUR OWN RISK).') + ! +1012 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' ILLEGAL GRID CLOSURE TYPE:',A4) + ! +1013 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & + ' THE GLOBAL (LOGICAL) INPUT FLAG IS DEPRECATED'/ & + ' AND REPLACED WITH A STRING INDICATING THE TYPE'/ & + ' OF GRID INDEX CLOSURE (NONE, SMPL or TRPL).'/ & + ' *** PLEASE UPDATE YOUR GRID INPUT FILE ACCORDINGLY ***'/) + ! #ifdef W3_SMC - 1014 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' SMC CELL LONGITUDE RANGE OUTSIDE BASE GRID RANGE:'/& - ' ISEA =', I6, '; IX =', I4, ':', I4,'; NX =', I4/) -#endif -! -#ifdef W3_SMC - 1015 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' SMC CELL LATITUDE RANGE OUTSIDE BASE GRID RANGE: '/& - ' ISEA =', I6, '; IY =', I4, ':', I4,'; NY =', I4/) -#endif -! - 1020 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' SOURCE TERMS REQUESTED BUT NOT SELECTED'/) - 1021 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & - ' SOURCE TERMS SELECTED BUT NOT REQUESTED'/) - 1022 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/LNn OR SEED SWITCHES :',I3) - 1023 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/STn SWITCHES :',I3) - 1024 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/NLn SWITCHES :',I3) - 1025 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/BTn SWITCHES :',I3) - 1026 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/DBn SWITCHES :',I3) - 1027 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/TRn SWITCHES :',I3) - 1028 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/BSn SWITCHES :',I3) -! - 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' PROPAGATION REQUESTED BUT NO SCHEME SELECTED '/) - 1031 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & - ' NO PROPAGATION REQUESTED BUT SCHEME SELECTED '/) - 1032 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' NO PROPAGATION SCHEME SELECTED ( use !/PR0 ) '/) - 1033 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' MULTIPLE PROPAGATION SCHEMES SELECTED :',I3/ & - ' CHECK !/PRn SWITCHES'/) - 1034 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/ICn SWITCHES :',I3) - 1035 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & - ' ONLY FIRST PROPAGATION SCHEME WILL BE USED: ') - 1036 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/ISn SWITCHES :',I3) -#ifdef W3_RTD - 1052 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' WITH NAMELIST VALUE PLAT == 90, PLON MUST BE -180'/ & - ' AND UNROT MUST BE .FALSE.' ) -#endif -! +1014 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' SMC CELL LONGITUDE RANGE OUTSIDE BASE GRID RANGE:'/& + ' ISEA =', I6, '; IX =', I4, ':', I4,'; NX =', I4/) +1015 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' SMC CELL LATITUDE RANGE OUTSIDE BASE GRID RANGE: '/& + ' ISEA =', I6, '; IY =', I4, ':', I4,'; NY =', I4/) +#endif + ! +1020 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' SOURCE TERMS REQUESTED BUT NOT SELECTED'/) +1021 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & + ' SOURCE TERMS SELECTED BUT NOT REQUESTED'/) +1022 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/LNn OR SEED SWITCHES :',I3) +1023 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/STn SWITCHES :',I3) +1024 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/NLn SWITCHES :',I3) +1025 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/BTn SWITCHES :',I3) +1026 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/DBn SWITCHES :',I3) +1027 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/TRn SWITCHES :',I3) +1028 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/BSn SWITCHES :',I3) + ! +1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' PROPAGATION REQUESTED BUT NO SCHEME SELECTED '/) +1031 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & + ' NO PROPAGATION REQUESTED BUT SCHEME SELECTED '/) +1032 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' NO PROPAGATION SCHEME SELECTED ( use !/PR0 ) '/) +1033 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' MULTIPLE PROPAGATION SCHEMES SELECTED :',I3/ & + ' CHECK !/PRn SWITCHES'/) +1034 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/ICn SWITCHES :',I3) +1035 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & + ' ONLY FIRST PROPAGATION SCHEME WILL BE USED: ') +1036 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/ISn SWITCHES :',I3) #ifdef W3_RTD - 1053 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' WITH NAMELIST VALUE BPLAT == 90, BPLON MUST BE -180') -#endif -! - 1040 FORMAT ( ' Space-time extremes DX :',F10.2) - 1041 FORMAT ( ' Space-time extremes DX :',F10.2) - 1042 FORMAT ( ' Space-time extremes DX-Y set to default 1000 m') - 1043 FORMAT ( ' Space-time extremes Dt :',F8.2) - 1044 FORMAT ( ' Space-time extremes Dt set to default 1200 s') -! - 1100 FORMAT (/' Status map, printed in',I6,' part(s) '/ & - ' -----------------------------------'/) - 1101 FORMAT (2X,180I2) - 1102 FORMAT ( ' Legend : '/ & - ' -----------------------------'/ & - ' 0 : Land point '/ & - ' 1 : Sea point '/ & - ' 2 : Active boundary point '/ & - ' 3 : Excluded point '/) - 1103 FORMAT (/' Obstruction map ',A1,', printed in',I6,' part(s) '/ & - ' ---------------------------------------------'/) - 1104 FORMAT ( ' Legend : '/ & - ' --------------------------------'/ & - ' fraction of obstruction * 10 '/) - - 1105 FORMAT (/' Shoreline slope, printed in',I6,' part(s) '/ & - ' ---------------------------------------------'/) - 1106 FORMAT ( ' Legend : '/ & - ' --------------------------------'/ & - ' Slope * 100'/) - - - 1150 FORMAT (/' Reading unstructured grid definition files ...'/) -! - 9997 FORMAT (/' Summary grid statistics : '/ & - ' --------------------------------------------------'/ & - ' Number of longitudes :',I10/ & - ' Number of latitudes :',I10/ & - ' Number of grid points :',I10/ & - ' Number of sea points :',I10,' (',F4.1,'%)'/& - ' Number of input b. points :',I10/ & - ' Number of land points :',I10/ & - ' Number of excluded points :',I10/) - 9998 FORMAT (/' Summary grid statistics : '/ & - ' --------------------------------------------------'/ & - ' Number of longitudes :',I10/ & - ' Number of latitudes :',I10/ & - ' Number of grid points :',I10/ & - ' Number of sea points :',I10,' (100%)'/ & - ' Number of input b. points :',I10/ & - ' Number of land points :',I10/ & - ' Number of excluded points :',I10/) - 9999 FORMAT (/' End of program '/ & - ' ========================================'/ & - ' WAVEWATCH III Grid preprocessor '/) -! +1052 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' WITH NAMELIST VALUE PLAT == 90, PLON MUST BE -180'/ & + ' AND UNROT MUST BE .FALSE.' ) +1053 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' WITH NAMELIST VALUE BPLAT == 90, BPLON MUST BE -180') +#endif + ! +1040 FORMAT ( ' Space-time extremes DX :',F10.2) +1041 FORMAT ( ' Space-time extremes DX :',F10.2) +1042 FORMAT ( ' Space-time extremes DX-Y set to default 1000 m') +1043 FORMAT ( ' Space-time extremes Dt :',F8.2) +1044 FORMAT ( ' Space-time extremes Dt set to default 1200 s') + ! +1100 FORMAT (/' Status map, printed in',I6,' part(s) '/ & + ' -----------------------------------'/) +1101 FORMAT (2X,180I2) +1102 FORMAT ( ' Legend : '/ & + ' -----------------------------'/ & + ' 0 : Land point '/ & + ' 1 : Sea point '/ & + ' 2 : Active boundary point '/ & + ' 3 : Excluded point '/) +1103 FORMAT (/' Obstruction map ',A1,', printed in',I6,' part(s) '/ & + ' ---------------------------------------------'/) +1104 FORMAT ( ' Legend : '/ & + ' --------------------------------'/ & + ' fraction of obstruction * 10 '/) + +1105 FORMAT (/' Shoreline slope, printed in',I6,' part(s) '/ & + ' ---------------------------------------------'/) +1106 FORMAT ( ' Legend : '/ & + ' --------------------------------'/ & + ' Slope * 100'/) + + +1150 FORMAT (/' Reading unstructured grid definition files ...'/) + ! +9997 FORMAT (/' Summary grid statistics : '/ & + ' --------------------------------------------------'/ & + ' Number of longitudes :',I10/ & + ' Number of latitudes :',I10/ & + ' Number of grid points :',I10/ & + ' Number of sea points :',I10,' (',F4.1,'%)'/& + ' Number of input b. points :',I10/ & + ' Number of land points :',I10/ & + ' Number of excluded points :',I10/) +9998 FORMAT (/' Summary grid statistics : '/ & + ' --------------------------------------------------'/ & + ' Number of longitudes :',I10/ & + ' Number of latitudes :',I10/ & + ' Number of grid points :',I10/ & + ' Number of sea points :',I10,' (100%)'/ & + ' Number of input b. points :',I10/ & + ' Number of land points :',I10/ & + ' Number of excluded points :',I10/) +9999 FORMAT (/' End of program '/ & + ' ========================================'/ & + ' WAVEWATCH III Grid preprocessor '/) + ! #ifdef W3_T - 9090 FORMAT ( ' TEST W3GRID : OUTPUT BOUND. POINT DATA LINE SEG.') - 9091 FORMAT ( ' ',2F8.2,4(2I4,F7.2)) - 9092 FORMAT ( ' ',F7.2,2X,4F7.2) - 9093 FORMAT ( ' ',4I7/ & - ' ',4I7) +9090 FORMAT ( ' TEST W3GRID : OUTPUT BOUND. POINT DATA LINE SEG.') +9091 FORMAT ( ' ',2F8.2,4(2I4,F7.2)) +9092 FORMAT ( ' ',F7.2,2X,4F7.2) +9093 FORMAT ( ' ',4I7/ & + ' ',4I7) #endif -! + ! #ifdef W3_T0 - 9095 FORMAT ( ' TEST W3GRID : OUTPUT BOUND. POINT SPEC DATA ') - 9096 FORMAT ( ' ',I3,2I8) +9095 FORMAT ( ' TEST W3GRID : OUTPUT BOUND. POINT SPEC DATA ') +9096 FORMAT ( ' ',I3,2I8) #endif END SUBROUTINE W3GRID -!/ -!/ Internal function READNL ------------------------------------------ / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE READNL ( NDS, NAME, STATUS ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Jun-2013 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! Read namelist info from file if namelist is found in file. -! -! 2. Method : -! -! Look for namelist with name NAME in unit NDS and read if found. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Data set number used for search. -! NAME C*4 I Name of namelist. -! STATUS C*20 O Status at end of routine, -! '(default values) ' if no namelist found. -! '(user def. values)' if namelist read. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! EXTCDE Subr. W3SERVMD Abort program as graceful as possible. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Program in which it is contained. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS - CHARACTER, INTENT(IN) :: NAME*4 - CHARACTER, INTENT(OUT) :: STATUS*20 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IERR, I, J - CHARACTER :: LINE*80 -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ Internal function READNL ------------------------------------------ / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE READNL ( NDS, NAME, STATUS ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Jun-2013 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! Read namelist info from file if namelist is found in file. + ! + ! 2. Method : + ! + ! Look for namelist with name NAME in unit NDS and read if found. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Data set number used for search. + ! NAME C*4 I Name of namelist. + ! STATUS C*20 O Status at end of routine, + ! '(default values) ' if no namelist found. + ! '(user def. values)' if namelist read. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! EXTCDE Subr. W3SERVMD Abort program as graceful as possible. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Program in which it is contained. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS + CHARACTER, INTENT(IN) :: NAME*4 + CHARACTER, INTENT(OUT) :: STATUS*20 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IERR, I, J + CHARACTER :: LINE*80 + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'READNL') -#endif -! - REWIND (NDS) - STATUS = '(default values) : ' -! - DO - READ (NDS,'(A)',END=800,ERR=800,IOSTAT=IERR) LINE - DO I=1, 70 - IF ( LINE(I:I) .NE. ' ' ) THEN - IF ( LINE(I:I) .EQ. '&' ) THEN - IF ( LINE(I+1:I+4) .EQ. NAME ) THEN - BACKSPACE (NDS) - SELECT CASE(NAME) + CALL STRACE (IENT, 'READNL') +#endif + ! + REWIND (NDS) + STATUS = '(default values) : ' + ! + DO + READ (NDS,'(A)',END=800,ERR=800,IOSTAT=IERR) LINE + DO I=1, 70 + IF ( LINE(I:I) .NE. ' ' ) THEN + IF ( LINE(I:I) .EQ. '&' ) THEN + IF ( LINE(I+1:I+4) .EQ. NAME ) THEN + BACKSPACE (NDS) + SELECT CASE(NAME) #ifdef W3_FLD1 - CASE('FLD1') - READ (NDS,NML=FLD1,END=801,ERR=802,IOSTAT=J) + CASE('FLD1') + READ (NDS,NML=FLD1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_FLD2 - CASE('FLD2') - READ (NDS,NML=FLD2,END=801,ERR=802,IOSTAT=J) + CASE('FLD2') + READ (NDS,NML=FLD2,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_FLX3 - CASE('FLX3') - READ (NDS,NML=FLX3,END=801,ERR=802,IOSTAT=J) + CASE('FLX3') + READ (NDS,NML=FLX3,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_FLX4 - CASE('FLX4') - READ (NDS,NML=FLX4,END=801,ERR=802,IOSTAT=J) + CASE('FLX4') + READ (NDS,NML=FLX4,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_LN1 - CASE('SLN1') - READ (NDS,NML=SLN1,END=801,ERR=802,IOSTAT=J) + CASE('SLN1') + READ (NDS,NML=SLN1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_ST1 - CASE('SIN1') - READ (NDS,NML=SIN1,END=801,ERR=802,IOSTAT=J) + CASE('SIN1') + READ (NDS,NML=SIN1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_ST2 - CASE('SIN2') - READ (NDS,NML=SIN2,END=801,ERR=802,IOSTAT=J) + CASE('SIN2') + READ (NDS,NML=SIN2,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_ST3 - CASE('SIN3') - READ (NDS,NML=SIN3,END=801,ERR=802,IOSTAT=J) + CASE('SIN3') + READ (NDS,NML=SIN3,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_ST4 - CASE('SIN4') - READ (NDS,NML=SIN4,END=801,ERR=802,IOSTAT=J) + CASE('SIN4') + READ (NDS,NML=SIN4,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_ST6 - CASE('SIN6') - READ (NDS,NML=SIN6,END=801,ERR=802,IOSTAT=J) + CASE('SIN6') + READ (NDS,NML=SIN6,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_NL1 - CASE('SNL1') - READ (NDS,NML=SNL1,END=801,ERR=802,IOSTAT=J) + CASE('SNL1') + READ (NDS,NML=SNL1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_NL2 - CASE('SNL2') - READ (NDS,NML=SNL2,END=801,ERR=802,IOSTAT=J) - CASE('ANL2') - IF ( NDEPTH .GT. 100 ) GOTO 804 - DEPTHS(1:NDEPTH) = DPTHNL - READ (NDS,NML=ANL2,END=801,ERR=802,IOSTAT=J) - DPTHNL = DEPTHS(1:NDEPTH) + CASE('SNL2') + READ (NDS,NML=SNL2,END=801,ERR=802,IOSTAT=J) + CASE('ANL2') + IF ( NDEPTH .GT. 100 ) GOTO 804 + DEPTHS(1:NDEPTH) = DPTHNL + READ (NDS,NML=ANL2,END=801,ERR=802,IOSTAT=J) + DPTHNL = DEPTHS(1:NDEPTH) #endif #ifdef W3_NL3 - CASE('SNL3') - READ (NDS,NML=SNL3,END=801,ERR=802,IOSTAT=J) - CASE('ANL3') - IF ( NQDEF .GT. 100 ) GOTO 804 - READ (NDS,NML=ANL3,END=801,ERR=802,IOSTAT=J) + CASE('SNL3') + READ (NDS,NML=SNL3,END=801,ERR=802,IOSTAT=J) + CASE('ANL3') + IF ( NQDEF .GT. 100 ) GOTO 804 + READ (NDS,NML=ANL3,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_NL4 - CASE('SNL4') - READ (NDS,NML=SNL4,END=801,ERR=802,IOSTAT=J) + CASE('SNL4') + READ (NDS,NML=SNL4,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_NL5 - CASE('SNL5') - READ (NDS,NML=SNL5,END=801,ERR=802,IOSTAT=J) + CASE('SNL5') + READ (NDS,NML=SNL5,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_NLS - CASE('SNLS') - READ (NDS,NML=SNLS,END=801,ERR=802,IOSTAT=J) + CASE('SNLS') + READ (NDS,NML=SNLS,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_ST1 - CASE('SDS1') - READ (NDS,NML=SDS1,END=801,ERR=802,IOSTAT=J) + CASE('SDS1') + READ (NDS,NML=SDS1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_ST2 - CASE('SDS2') - READ (NDS,NML=SDS2,END=801,ERR=802,IOSTAT=J) + CASE('SDS2') + READ (NDS,NML=SDS2,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_ST3 - CASE('SDS3') - READ (NDS,NML=SDS3,END=801,ERR=802,IOSTAT=J) + CASE('SDS3') + READ (NDS,NML=SDS3,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_ST4 - CASE('SDS4') - READ (NDS,NML=SDS4,END=801,ERR=802,IOSTAT=J) + CASE('SDS4') + READ (NDS,NML=SDS4,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_ST6 - CASE('SDS6') - READ (NDS,NML=SDS6,END=801,ERR=802,IOSTAT=J) - CASE('SWL6') - READ (NDS,NML=SWL6,END=801,ERR=802,IOSTAT=J) + CASE('SDS6') + READ (NDS,NML=SDS6,END=801,ERR=802,IOSTAT=J) + CASE('SWL6') + READ (NDS,NML=SWL6,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_BT1 - CASE('SBT1') - READ (NDS,NML=SBT1,END=801,ERR=802,IOSTAT=J) + CASE('SBT1') + READ (NDS,NML=SBT1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_BT4 - CASE('SBT4') - READ (NDS,NML=SBT4,END=801,ERR=802,IOSTAT=J) + CASE('SBT4') + READ (NDS,NML=SBT4,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_IS1 - CASE('SIS1') - READ (NDS,NML=SIS1,END=801,ERR=802,IOSTAT=J) + CASE('SIS1') + READ (NDS,NML=SIS1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_IS2 - CASE('SIS2') - READ (NDS,NML=SIS2,END=801,ERR=802,IOSTAT=J) + CASE('SIS2') + READ (NDS,NML=SIS2,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_DB1 - CASE('SDB1') - READ (NDS,NML=SDB1,END=801,ERR=802,IOSTAT=J) + CASE('SDB1') + READ (NDS,NML=SDB1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_UOST - CASE('UOST') - READ (NDS,NML=UOST,END=801,ERR=802,IOSTAT=J) + CASE('UOST') + READ (NDS,NML=UOST,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_PR1 - CASE('PRO1') - READ (NDS,NML=PRO1,END=801,ERR=802,IOSTAT=J) + CASE('PRO1') + READ (NDS,NML=PRO1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_PR2 - CASE('PRO2') - READ (NDS,NML=PRO2,END=801,ERR=802,IOSTAT=J) + CASE('PRO2') + READ (NDS,NML=PRO2,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_SMC - CASE('PSMC') - READ (NDS,NML=PSMC,END=801,ERR=802,IOSTAT=J) + CASE('PSMC') + READ (NDS,NML=PSMC,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_PR3 - CASE('PRO3') - READ (NDS,NML=PRO3,END=801,ERR=802,IOSTAT=J) + CASE('PRO3') + READ (NDS,NML=PRO3,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_RTD - CASE('ROTD') - READ (NDS,NML=ROTD,END=801,ERR=802,IOSTAT=J) - CASE('ROTB') - READ (NDS,NML=ROTB,END=801,ERR=802,IOSTAT=J) + CASE('ROTD') + READ (NDS,NML=ROTD,END=801,ERR=802,IOSTAT=J) + CASE('ROTB') + READ (NDS,NML=ROTB,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_REF1 - CASE('REF1') - READ (NDS,NML=REF1,END=801,ERR=802,IOSTAT=J) + CASE('REF1') + READ (NDS,NML=REF1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_IG1 - CASE('SIG1') - READ (NDS,NML=SIG1,END=801,ERR=802,IOSTAT=J) + CASE('SIG1') + READ (NDS,NML=SIG1,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_IC2 - CASE('SIC2') - READ (NDS,NML=SIC2,END=801,ERR=802,IOSTAT=J) + CASE('SIC2') + READ (NDS,NML=SIC2,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_IC3 - CASE('SIC3') - READ (NDS,NML=SIC3,END=801,ERR=802,IOSTAT=J) + CASE('SIC3') + READ (NDS,NML=SIC3,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_IC4 - CASE('SIC4 ') - READ (NDS,NML=SIC4,END=801,ERR=802,IOSTAT=J) + CASE('SIC4 ') + READ (NDS,NML=SIC4,END=801,ERR=802,IOSTAT=J) #endif #ifdef W3_IC5 - CASE('SIC5 ') - READ (NDS,NML=SIC5,END=801,ERR=802,IOSTAT=J) -#endif - CASE('UNST') - READ (NDS,NML=UNST,END=801,ERR=802,IOSTAT=J) - CASE('OUTS') - READ (NDS,NML=OUTS,END=801,ERR=802,IOSTAT=J) - CASE('MISC') - READ (NDS,NML=MISC,END=801,ERR=802,IOSTAT=J) - CASE DEFAULT - GOTO 803 - END SELECT - STATUS = '(user def. values) :' - RETURN - END IF - ELSE - EXIT - END IF - ENDIF - END DO - END DO -! - 800 CONTINUE - RETURN -! - 801 CONTINUE - WRITE (NDSE,1001) NAME - CALL EXTCDE(1) - RETURN -! - 802 CONTINUE - WRITE (NDSE,1002) NAME, J - CALL EXTCDE(2) - RETURN -! - 803 CONTINUE - WRITE (NDSE,1003) NAME - CALL EXTCDE(3) - RETURN -! + CASE('SIC5 ') + READ (NDS,NML=SIC5,END=801,ERR=802,IOSTAT=J) +#endif + CASE('UNST') + READ (NDS,NML=UNST,END=801,ERR=802,IOSTAT=J) + CASE('OUTS') + READ (NDS,NML=OUTS,END=801,ERR=802,IOSTAT=J) + CASE('MISC') + READ (NDS,NML=MISC,END=801,ERR=802,IOSTAT=J) + CASE DEFAULT + GOTO 803 + END SELECT + STATUS = '(user def. values) :' + RETURN + END IF + ELSE + EXIT + END IF + ENDIF + END DO + END DO + ! +800 CONTINUE + RETURN + ! +801 CONTINUE + WRITE (NDSE,1001) NAME + CALL EXTCDE(1) + RETURN + ! +802 CONTINUE + WRITE (NDSE,1002) NAME, J + CALL EXTCDE(2) + RETURN + ! +803 CONTINUE + WRITE (NDSE,1003) NAME + CALL EXTCDE(3) + RETURN + ! #ifdef W3_NL2 - 804 CONTINUE - WRITE (NDSE,1004) NDEPTH - CALL EXTCDE(4) - RETURN +804 CONTINUE + WRITE (NDSE,1004) NDEPTH + CALL EXTCDE(4) + RETURN #endif -! + ! #ifdef W3_NL3 - 804 CONTINUE - WRITE (NDSE,1004) NQDEF - CALL EXTCDE(4) - RETURN -#endif -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & - ' PREMATURE END OF FILE IN READING ',A/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & - ' ERROR IN READING ',A,' IOSTAT =',I8/) - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & - ' NAMELIST NAME ',A,' NOT RECOGNIZED'/) +804 CONTINUE + WRITE (NDSE,1004) NQDEF + CALL EXTCDE(4) + RETURN +#endif + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & + ' PREMATURE END OF FILE IN READING ',A/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & + ' ERROR IN READING ',A,' IOSTAT =',I8/) +1003 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & + ' NAMELIST NAME ',A,' NOT RECOGNIZED'/) #ifdef W3_NL2 - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & - ' TEMP DEPTH ARRAY TOO SMALL, .LE. ',I8/) +1004 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & + ' TEMP DEPTH ARRAY TOO SMALL, .LE. ',I8/) #endif #ifdef W3_NL3 - 1004 FORMAT (/' *** WAVEWATCH-III ERROR IN READNL : '/ & - ' TEMP QPARMS ARRAY TOO SMALL, .LE. ',I8/) +1004 FORMAT (/' *** WAVEWATCH-III ERROR IN READNL : '/ & + ' TEMP QPARMS ARRAY TOO SMALL, .LE. ',I8/) #endif -!/ -!/ End of READNL ----------------------------------------------------- / -!/ + !/ + !/ End of READNL ----------------------------------------------------- / + !/ END SUBROUTINE READNL -!/ -!/ End of W3GRID ----------------------------------------------------- / -!/ - END MODULE W3GRIDMD + !/ + !/ End of W3GRID ----------------------------------------------------- / + !/ +END MODULE W3GRIDMD diff --git a/model/src/w3gsrumd.F90 b/model/src/w3gsrumd.F90 index 3bc86215f..9cd4beaf5 100644 --- a/model/src/w3gsrumd.F90 +++ b/model/src/w3gsrumd.F90 @@ -14,9601 +14,9601 @@ #include "w3macros.h" #endif !/ =================================================================== / - MODULE W3GSRUMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 25-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 30-Oct-2009 : Origination. ( version 3.14 ) -!/ 14-Jun-2010 : Fix for ACOS argument > 1 in W3DIST ( version 3.14 ) -!/ 12-Nov-2010 : Change T_NNS, W3NN*, W3SORT, W3ISRT to public. -!/ Add W3GFIJ (public). Implement r4 & r8 interfaces. -!/ Add subcell check for grid cell that includes a pole. -!/ Change to number of search buckets based on -!/ dimensions of input grid. ( version 3.14 ) -!/ 01-Dec-2010 : Assign cells to buckets based on overlap. The -!/ nearest-neighbor bucket search is removed (no longer -!/ needed). Add support for tripole grids (JCLO). -!/ Add W3GFCD (public). Some cleanup. Add ouput of -!/ approximate memory usage. ( version 3.14 ) -!/ 01-Dec-2010 : Add check for target point coincident with a cell -!/ vertex in W3RMBL. Change to error exit when unable -!/ to determine local (i,j). ( version 3.14 ) -!/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO -!/ to integer and remove JCLO. Implement support for -!/ r4 and r8 source grids. ( version 3.14 ) -!/ 15-Jun-2012 : Fixed various format statements that gave compile -!/ warnings with Intel compiler on NCEP R&D machine -!/ zeus (H. L. Tolman) ( version 4.07 ) -!/ 20-Jan-2017 : Moved all record of changes from subroutines to -!/ the top of the module and consolidate source code -!/ for procedure interfaces ( version 6.02 ) -!/ 20-Jan-2017 : Generalize index bounds for source ( version 6.02 ) -!/ 20-Jan-2017 : Fix tripole grid index mapping and implement -!/ additional index closure types. ( version 6.02 ) -!/ 20-Jan-2017 : Add small non-zero tolerance to bounding box checks, -!/ point coincidence checks and checks for points that -!/ lie exactly on a cell side ( version 6.02 ) -!/ 20-Jan-2017 : Add option to W3GFCL, W3GRMP, W3GFPT, and W3GFIJ to -!/ allow target outside of source grid ( version 6.02 ) -!/ 20-Jan-2017 : Implement more accurate sin(d/2) equation in W3DIST -!/ for computing angular distance ( version 6.02 ) -!/ 20-Jan-2017 : Implement stereographic projection for remapping -!/ from cells near a pole ( version 6.02 ) -!/ 20-Jan-2017 : Add routine for computing metric and derivatives -!/ for a curvilinear grid and routines for computing -!/ gradient and divergence of fields defined on a -!/ curvilinear grid ( version 6.02 ) -!/ 20-Jan-2017 : Add routine for computing computing bounding box -!/ for a curvilinear grid ( version 6.02 ) -!/ 20-Jan-2017 : Add W3GRMC as generic routine for computing -!/ remapping coefficients ( version 6.02 ) -!/ 25-Jan-2017 : Fix index offsets for MASK in W3GRMP and W3GRMC. -!/ Change redist to nearpt in W3GRMC. ( version 6.03 ) -!/ 31-Oct-2017 : Add optional MASK input for W3CGDM. ( version 6.03 ) -!/ 18-Jul-2018 : Add fall back to NFD = 2 in W3CGDM for metric -!/ calculations where GSQRL < 0. ( version 6.05 ) -!/ -! 1. Purpose : -! -! Search, regrid, and miscellaneous utilities (data structures and -! associated methods) for logically rectangular grids. -! -! The grid-search-utility (GSU) object can be used for rapid searching -! of the associated grid to identify a grid cell that encloses a target -! point and to compute interpolation weights. The GSU object maintains -! internal pointers to the associated grid coordinate arrays. Rapid -! searching is done using a bucket search algorithm. The search buckets -! are based on the bounding box for the associated grid and an optional -! user defined approximate number of grid cells per search bucket. -! -! Grid cells are identified by the cell's lower-left corner grid point. -! The vertices (grid points) associated with a grid cell are assigned a -! sequential index in a counterclockwise order beginning with the cell's -! lower-left corner grid point. That is, when moving from vertex 1 to -! vertex 2 to vertex 3, etc., the grid cell interior is always to the left. -! Note that though cell will be counterclockwise w.r.t. indices, this does -! not necessarily mean that the cell will be counterclockwise geographically, -! specifically in situation of curvilinear grid. -! -! (x4,y4) (x3,y3) -! _____________________ -! / / -! / / -! / / -! / / -! /____________________/ -! (x1,y1) (x2,y2) -! -! -! A simple interpolation example: -! -! ----------------------------------------------------------- -! ! Define data -! TYPE(T_GSU) :: GSU -! LOGICAL :: IJG = .TRUE. -! LOGICAL :: LLG = .TRUE. -! LOGICAL :: ICLO = ICLO_NONE -! REAL, POINTER :: XS(:,:), YS(:,:) !source grid coordinates -! REAL :: FS(:,:) !source field -! INTEGER :: NT !number of target points -! REAL :: XT(NT), YT(NT), FT(NT) !target coordinates and field -! INTEGER :: IS(4), JS(4) !interpolation points -! REAL :: RW(4) !interpolation weights -! -! ! Setup source grid and field and target points -! < ... > -! -! ! Create grid-search-utility object for source grid -! GSU = W3GSUC( IJG, LLG, ICLO, XS, YS ) -! -! ! Interpolate source field to target points -! DO K=1,NT -! FT(K) = 0 -! IF ( W3GRMP( GSU, XT(K), YT(K), IS, JS, RW ) ) THEN -! DO L=1,4 -! FT(K) = FT(K) + RW(L)*FS(IS(L),JS(L)) -! END DO -! END IF -! END DO -! -! ! Destroy grid-search-utility object -! CALL W3GSUD( GSU ) -! ----------------------------------------------------------- -! -! 2. Variables and types : -! -! All module variables and types are scoped private by default. -! The private module variables and types are not listed in this section. -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! MSKC_NONE I.P. Public Named constant identifying a non-masked -! enclosing grid cell -! MSKC_PART I.P. Public Named constant identifying a partially -! masked enclosing grid cell -! MSKC_FULL I.P. Public Named constant identifying a fully -! masked enclosing grid cell -! ICLO_NONE I.P. Public Named constant identifying a grid with -! no closure in index space -! ICLO_SMPL I.P. Public Synonym for ICLO_GRDI -! ICLO_GRDI I.P. Public Named constant identifying a grid with -! closure in I-index: (UBX+1, j) => (LBX, j) -! ICLO_GRDJ I.P. Public Named constant identifying a grid with -! closure in J-index: (i, UBY+1) => (i, LBY) -! ICLO_TRDL I.P. Public Named constant identifying a grid with -! toroidal closure: (UBX+1, j) => (LBX, j) and -! (i, UBY+1) => (i, LBY) -! ICLO_TRPL I.P. Public Named constant identifying a grid with -! tripole closure: (UBX+1, LBY<=j<=UBY) => (LBX, j) -! and (LBX<=i<=UBX, UBY+1) => (UBX+LBX-i, UBY) -! T_GSU TYPE Public Grid-search-utility type (opaque) -! T_NNS TYPE Public Nearest-neighbor grid-point search type -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! All module subroutines and functions are scoped private by default. -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3GSUC Func. Public Create grid-search-utility object. -! W3GSUD Subr. Public Destroy grid-search-utility object. -! W3GSUP Subr. Public Print grid-search-utility object to stdout. -! W3BBOX Subr. Public Get bounding box associated with grid. -! W3GFCL Func. Public Find grid cell that encloses target point (bucket search). -! W3GFCD Func. Public Find grid cell that encloses target point (direct search). -! W3GFPT Func. Public Find grid point that is closest to target point. -! W3GFIJ Func. Public Compute coord of target point in source grid index space -! W3GRMP Func. Public Compute bilinear interpolation coeff. from grid. -! W3GRMC Func. Public Compute remapping coeff. from grid. -! W3CKCL Func. Public Check if point lies within grid cell. -! W3CGDM Func. Public Compute curvilinear grid derivatives and metric -! W3GRD0 Func. Public Compute gradient of scalar field -! W3DIV1 Func. Public Compute divergence of a vector field -! W3DIV2 Func. Public Compute divergence of a tensor field -! W3DIST Func. Public Compute distance between two points. -! W3SPLX Func. Public Compute Cartesian coord using stereographic projection -! W3SPXL Func. Public Compute (lon,lat) coord using stereographic projection -! W3TRLL Func. Public Compute (lon,lat) in rotated coordinate system -! W3LLAZ Func. Public Compute azimuth for pair of (lon,lat) points -! W3FDWT Func. Public Compute finite-difference weights. -! W3NNSC Func. Public Create nearest-neighbor-search object. -! W3NNSD Subr. Public Destroy nearest-neighbor-search object. -! W3NNSP Subr. Public Print nearest-neighbor-search object to stdout. -! W3SORT Subr. Public Sort input arrays in increasing order. -! W3ISRT Subr. Public Insert data into array. -! W3INAN Func. Public Check if input is infinite or NaN. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - The GSU object is an "opaque" object. This means that the -! internals of the object are not accessible outside this module. -! - The burden is upon the user to invoke the destroy method when -! finished with a GSU object. If created GSU objects are -! not properly destroyed, then memory leaks may be introduced. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -! -!/ =================================================================== / -!/ -!/ Use associated modules -!/ +MODULE W3GSRUMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 25-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 30-Oct-2009 : Origination. ( version 3.14 ) + !/ 14-Jun-2010 : Fix for ACOS argument > 1 in W3DIST ( version 3.14 ) + !/ 12-Nov-2010 : Change T_NNS, W3NN*, W3SORT, W3ISRT to public. + !/ Add W3GFIJ (public). Implement r4 & r8 interfaces. + !/ Add subcell check for grid cell that includes a pole. + !/ Change to number of search buckets based on + !/ dimensions of input grid. ( version 3.14 ) + !/ 01-Dec-2010 : Assign cells to buckets based on overlap. The + !/ nearest-neighbor bucket search is removed (no longer + !/ needed). Add support for tripole grids (JCLO). + !/ Add W3GFCD (public). Some cleanup. Add ouput of + !/ approximate memory usage. ( version 3.14 ) + !/ 01-Dec-2010 : Add check for target point coincident with a cell + !/ vertex in W3RMBL. Change to error exit when unable + !/ to determine local (i,j). ( version 3.14 ) + !/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO + !/ to integer and remove JCLO. Implement support for + !/ r4 and r8 source grids. ( version 3.14 ) + !/ 15-Jun-2012 : Fixed various format statements that gave compile + !/ warnings with Intel compiler on NCEP R&D machine + !/ zeus (H. L. Tolman) ( version 4.07 ) + !/ 20-Jan-2017 : Moved all record of changes from subroutines to + !/ the top of the module and consolidate source code + !/ for procedure interfaces ( version 6.02 ) + !/ 20-Jan-2017 : Generalize index bounds for source ( version 6.02 ) + !/ 20-Jan-2017 : Fix tripole grid index mapping and implement + !/ additional index closure types. ( version 6.02 ) + !/ 20-Jan-2017 : Add small non-zero tolerance to bounding box checks, + !/ point coincidence checks and checks for points that + !/ lie exactly on a cell side ( version 6.02 ) + !/ 20-Jan-2017 : Add option to W3GFCL, W3GRMP, W3GFPT, and W3GFIJ to + !/ allow target outside of source grid ( version 6.02 ) + !/ 20-Jan-2017 : Implement more accurate sin(d/2) equation in W3DIST + !/ for computing angular distance ( version 6.02 ) + !/ 20-Jan-2017 : Implement stereographic projection for remapping + !/ from cells near a pole ( version 6.02 ) + !/ 20-Jan-2017 : Add routine for computing metric and derivatives + !/ for a curvilinear grid and routines for computing + !/ gradient and divergence of fields defined on a + !/ curvilinear grid ( version 6.02 ) + !/ 20-Jan-2017 : Add routine for computing computing bounding box + !/ for a curvilinear grid ( version 6.02 ) + !/ 20-Jan-2017 : Add W3GRMC as generic routine for computing + !/ remapping coefficients ( version 6.02 ) + !/ 25-Jan-2017 : Fix index offsets for MASK in W3GRMP and W3GRMC. + !/ Change redist to nearpt in W3GRMC. ( version 6.03 ) + !/ 31-Oct-2017 : Add optional MASK input for W3CGDM. ( version 6.03 ) + !/ 18-Jul-2018 : Add fall back to NFD = 2 in W3CGDM for metric + !/ calculations where GSQRL < 0. ( version 6.05 ) + !/ + ! 1. Purpose : + ! + ! Search, regrid, and miscellaneous utilities (data structures and + ! associated methods) for logically rectangular grids. + ! + ! The grid-search-utility (GSU) object can be used for rapid searching + ! of the associated grid to identify a grid cell that encloses a target + ! point and to compute interpolation weights. The GSU object maintains + ! internal pointers to the associated grid coordinate arrays. Rapid + ! searching is done using a bucket search algorithm. The search buckets + ! are based on the bounding box for the associated grid and an optional + ! user defined approximate number of grid cells per search bucket. + ! + ! Grid cells are identified by the cell's lower-left corner grid point. + ! The vertices (grid points) associated with a grid cell are assigned a + ! sequential index in a counterclockwise order beginning with the cell's + ! lower-left corner grid point. That is, when moving from vertex 1 to + ! vertex 2 to vertex 3, etc., the grid cell interior is always to the left. + ! Note that though cell will be counterclockwise w.r.t. indices, this does + ! not necessarily mean that the cell will be counterclockwise geographically, + ! specifically in situation of curvilinear grid. + ! + ! (x4,y4) (x3,y3) + ! _____________________ + ! / / + ! / / + ! / / + ! / / + ! /____________________/ + ! (x1,y1) (x2,y2) + ! + ! + ! A simple interpolation example: + ! + ! ----------------------------------------------------------- + ! ! Define data + ! TYPE(T_GSU) :: GSU + ! LOGICAL :: IJG = .TRUE. + ! LOGICAL :: LLG = .TRUE. + ! LOGICAL :: ICLO = ICLO_NONE + ! REAL, POINTER :: XS(:,:), YS(:,:) !source grid coordinates + ! REAL :: FS(:,:) !source field + ! INTEGER :: NT !number of target points + ! REAL :: XT(NT), YT(NT), FT(NT) !target coordinates and field + ! INTEGER :: IS(4), JS(4) !interpolation points + ! REAL :: RW(4) !interpolation weights + ! + ! ! Setup source grid and field and target points + ! < ... > + ! + ! ! Create grid-search-utility object for source grid + ! GSU = W3GSUC( IJG, LLG, ICLO, XS, YS ) + ! + ! ! Interpolate source field to target points + ! DO K=1,NT + ! FT(K) = 0 + ! IF ( W3GRMP( GSU, XT(K), YT(K), IS, JS, RW ) ) THEN + ! DO L=1,4 + ! FT(K) = FT(K) + RW(L)*FS(IS(L),JS(L)) + ! END DO + ! END IF + ! END DO + ! + ! ! Destroy grid-search-utility object + ! CALL W3GSUD( GSU ) + ! ----------------------------------------------------------- + ! + ! 2. Variables and types : + ! + ! All module variables and types are scoped private by default. + ! The private module variables and types are not listed in this section. + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! MSKC_NONE I.P. Public Named constant identifying a non-masked + ! enclosing grid cell + ! MSKC_PART I.P. Public Named constant identifying a partially + ! masked enclosing grid cell + ! MSKC_FULL I.P. Public Named constant identifying a fully + ! masked enclosing grid cell + ! ICLO_NONE I.P. Public Named constant identifying a grid with + ! no closure in index space + ! ICLO_SMPL I.P. Public Synonym for ICLO_GRDI + ! ICLO_GRDI I.P. Public Named constant identifying a grid with + ! closure in I-index: (UBX+1, j) => (LBX, j) + ! ICLO_GRDJ I.P. Public Named constant identifying a grid with + ! closure in J-index: (i, UBY+1) => (i, LBY) + ! ICLO_TRDL I.P. Public Named constant identifying a grid with + ! toroidal closure: (UBX+1, j) => (LBX, j) and + ! (i, UBY+1) => (i, LBY) + ! ICLO_TRPL I.P. Public Named constant identifying a grid with + ! tripole closure: (UBX+1, LBY<=j<=UBY) => (LBX, j) + ! and (LBX<=i<=UBX, UBY+1) => (UBX+LBX-i, UBY) + ! T_GSU TYPE Public Grid-search-utility type (opaque) + ! T_NNS TYPE Public Nearest-neighbor grid-point search type + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! All module subroutines and functions are scoped private by default. + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3GSUC Func. Public Create grid-search-utility object. + ! W3GSUD Subr. Public Destroy grid-search-utility object. + ! W3GSUP Subr. Public Print grid-search-utility object to stdout. + ! W3BBOX Subr. Public Get bounding box associated with grid. + ! W3GFCL Func. Public Find grid cell that encloses target point (bucket search). + ! W3GFCD Func. Public Find grid cell that encloses target point (direct search). + ! W3GFPT Func. Public Find grid point that is closest to target point. + ! W3GFIJ Func. Public Compute coord of target point in source grid index space + ! W3GRMP Func. Public Compute bilinear interpolation coeff. from grid. + ! W3GRMC Func. Public Compute remapping coeff. from grid. + ! W3CKCL Func. Public Check if point lies within grid cell. + ! W3CGDM Func. Public Compute curvilinear grid derivatives and metric + ! W3GRD0 Func. Public Compute gradient of scalar field + ! W3DIV1 Func. Public Compute divergence of a vector field + ! W3DIV2 Func. Public Compute divergence of a tensor field + ! W3DIST Func. Public Compute distance between two points. + ! W3SPLX Func. Public Compute Cartesian coord using stereographic projection + ! W3SPXL Func. Public Compute (lon,lat) coord using stereographic projection + ! W3TRLL Func. Public Compute (lon,lat) in rotated coordinate system + ! W3LLAZ Func. Public Compute azimuth for pair of (lon,lat) points + ! W3FDWT Func. Public Compute finite-difference weights. + ! W3NNSC Func. Public Create nearest-neighbor-search object. + ! W3NNSD Subr. Public Destroy nearest-neighbor-search object. + ! W3NNSP Subr. Public Print nearest-neighbor-search object to stdout. + ! W3SORT Subr. Public Sort input arrays in increasing order. + ! W3ISRT Subr. Public Insert data into array. + ! W3INAN Func. Public Check if input is infinite or NaN. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - The GSU object is an "opaque" object. This means that the + ! internals of the object are not accessible outside this module. + ! - The burden is upon the user to invoke the destroy method when + ! finished with a GSU object. If created GSU objects are + ! not properly destroyed, then memory leaks may be introduced. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + ! + !/ =================================================================== / + !/ + !/ Use associated modules + !/ #ifdef ENABLE_WW3 - USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: EXTCDE #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ -!/ Specify default data typing -!/ - IMPLICIT NONE -!/ -!/ Specify default accessibility -!/ - PRIVATE -!/ -!/ Public module methods -!/ - PUBLIC W3GSUC - PUBLIC W3GSUD - PUBLIC W3GSUP - PUBLIC W3BBOX - PUBLIC W3GFCL - PUBLIC W3GFCD - PUBLIC W3GFPT - PUBLIC W3GFIJ - PUBLIC W3GRMP - PUBLIC W3GRMC - PUBLIC W3CKCL - PUBLIC W3CGDM - PUBLIC W3GRD0 - PUBLIC W3DIV1 - PUBLIC W3DIV2 - PUBLIC W3DIST - PUBLIC W3SPLX - PUBLIC W3SPXL - PUBLIC W3TRLL - PUBLIC W3LLAZ - PUBLIC W3FDWT - PUBLIC W3NNSC - PUBLIC W3NNSD - PUBLIC W3NNSP - PUBLIC W3SORT - PUBLIC W3ISRT - PUBLIC W3INAN -!/ -!/ Public return codes -!/ - INTEGER, PARAMETER, PUBLIC :: MSKC_NONE = 0 - INTEGER, PARAMETER, PUBLIC :: MSKC_PART = 1 - INTEGER, PARAMETER, PUBLIC :: MSKC_FULL = 2 -!/ -!/ Public index closure types (for lat/lon grids only) -!/ ICLO_NONE : no closure in index space -!/ ICLO_SMPL : synonym for ICLO_GRDI -!/ ICLO_GRDI : closure in i-index at i=UBX+1: (UBX+1, j) => (LBX, j) -!/ ICLO_GRDJ : closure in j-index at j=UBY+1: (i, UBY+1) => (i, LBY) -!/ ICLO_TRDL : toroidal grid closure: (UBX+1, j) => (LBX, j) and -!/ (i, UBY+1) => (i, LBY) -!/ ICLO_TRPL : tripole grid closure: (UBX+1, LBY<=j<=UBY) => (LBX, j) and -!/ (LBX<=i<=UBX, UBY+1) => (UBX+LBX-i, UBY) -!/ -!/ Note that simple i-index closure types are set to multiples of 2. -!/ Note that simple j-index closure types are set to multiples of 3. -!/ These settings are used in the GSU methods to simplify checking. -!/ -!/ Implementation notes on index closure: -!/ Simple closure in i-index means that a given integer i' is mapped to the -!/ range [LBX,UBX]. When i' >= LBX, the function i = LBX + MOD(i'-LBX,NX) -!/ maps i' to i in [LBX,UBX] (where, NX = UBX - LBX + 1). The function -!/ i = UBX + MOD(i'-LBX+1,NX) maps any integer i' to i in [LBX,INF). Hence, -!/ the following composition is used to map any integer i' to [LBX,UBX]. -!/ i = LBX + MOD(NX - 1 + MOD(i' - LBX + 1, NX), NX) -!/ Similarly, for simple closure in j-index, the following composition is used -!/ to map any integer j' to [LBY,UBY]. -!/ j = LBY + MOD(NY - 1 + MOD(j' - LBY + 1, NY), NY) -!/ For tripole type index closure, the simple closure in i-index is appied -!/ prior to computing the appropriate i and j-index mapping for closure across -!/ the seam at j = UBY. The j-index closure for i' in [LBX,UBX] and j' > UBY -!/ is computed as i = UBX + LBX - i' and j = 2*UBY - j' + 1. -!/ - INTEGER, PARAMETER, PUBLIC :: ICLO_NONE = -1 - INTEGER, PARAMETER, PUBLIC :: ICLO_SMPL = 2 - INTEGER, PARAMETER, PUBLIC :: ICLO_GRDI = ICLO_SMPL - INTEGER, PARAMETER, PUBLIC :: ICLO_GRDJ = 3 - INTEGER, PARAMETER, PUBLIC :: ICLO_TRDL = 6 - INTEGER, PARAMETER, PUBLIC :: ICLO_TRPL = 8 -!/ -!/ Public grid-search-utility type -!/ This is an opaque type -- that is, it's internals are private and only -!/ accessible to subroutines in this module where the type is declared. -!/ - TYPE, PUBLIC :: T_GSU - PRIVATE - TYPE(CLASS_GSU), POINTER :: PTR => NULL() - END TYPE T_GSU -!/ -!/ Private grid-search-utility class -!/ - TYPE :: CLASS_GSU - LOGICAL :: IJG ! grid array ordering flag: T = (NX,NY), F = (NY,NX) - LOGICAL :: LLG ! spherical coordinate flag of associated grid - INTEGER :: ICLO ! parameter indicating type of index space closure - ! this flag must be set by the user - LOGICAL :: LCLO ! flag indicating longitudinal periodicity - ! this flag is calculated internally - ! LLG & ICLO != ICLO_NONE => LCLO = T - LOGICAL :: L360 ! flag indicating longitude range: - ! T = [0:360], F = [-180:180] - INTEGER :: GKIND ! kind (precision: 4 or 8) of associated grid - INTEGER :: LBX, LBY ! lower-bounds of associated grid - INTEGER :: UBX, UBY ! upper-bounds of associated grid - INTEGER :: NX, NY ! dimensions of associated grid - REAL(4), POINTER :: XG4(:,:), YG4(:,:) ! coordinates of associated grid (r4) - REAL(8), POINTER :: XG8(:,:), YG8(:,:) ! coordinates of associated grid (r8) - TYPE(T_NNS), POINTER :: NNP ! nearest-neighbor point search indices object - INTEGER :: NBX, NBY ! number of buckets in each spatial direction - REAL(8) :: DXB, DYB ! spatial extent of each search bucket - REAL(8) :: XMIN, YMIN, XMAX, YMAX ! bounding box of search domain - TYPE(T_BKT), POINTER :: B(:,:) ! array of search buckets - TYPE(T_NNS), POINTER :: NNB ! nearest-neighbor bucket search indices object - END TYPE CLASS_GSU -!/ -!/ Private search bucket type -!/ - TYPE :: T_BKT - INTEGER :: N ! number of cells in bucket - INTEGER, POINTER :: I(:) ! i-index of cell c - INTEGER, POINTER :: J(:) ! j-index of cell c - END TYPE T_BKT -!/ -!/ Public nearest-neighbor grid-point search type -!/ - TYPE, PUBLIC :: T_NNS - INTEGER :: NLVL ! number of nnbr levels - INTEGER :: NNBR ! total number of nnbr's - INTEGER, POINTER :: N1(:) ! starting nearest-nbr loop index for level l - INTEGER, POINTER :: N2(:) ! ending nearest-nbr loop index for level l - INTEGER, POINTER :: DI(:) ! i-index delta for nearest-nbr n - INTEGER, POINTER :: DJ(:) ! j-index delta for nearest-nbr n - END TYPE T_NNS -!/ -!/ Private module parameters -!/ - REAL(8), PARAMETER :: PI = 3.14159265358979323846D0 - REAL(8), PARAMETER :: PI2 = 2D0*PI - REAL(8), PARAMETER :: PI3H = 3D0*PI/2D0 - REAL(8), PARAMETER :: PIO2 = PI/2D0 - REAL(8), PARAMETER :: PIO4 = PI/4D0 - REAL(8), PARAMETER :: D2R = PI/180D0 - REAL(8), PARAMETER :: R2D = 1D0/D2R - REAL(8), PARAMETER :: D360 = 360D0 - REAL(8), PARAMETER :: D270 = 270D0 - REAL(8), PARAMETER :: D180 = 180D0 - REAL(8), PARAMETER :: D90 = 90D0 - REAL(8), PARAMETER :: ZERO = 0.0D0 - REAL(8), PARAMETER :: HALF = 0.5D0 - REAL(8), PARAMETER :: ONE = 1.0D0 - REAL(8), PARAMETER :: TWO = 2.0D0 - REAL(8), PARAMETER :: FOUR = 4.0D0 + !/ + !/ Specify default data typing + !/ + IMPLICIT NONE + !/ + !/ Specify default accessibility + !/ + PRIVATE + !/ + !/ Public module methods + !/ + PUBLIC W3GSUC + PUBLIC W3GSUD + PUBLIC W3GSUP + PUBLIC W3BBOX + PUBLIC W3GFCL + PUBLIC W3GFCD + PUBLIC W3GFPT + PUBLIC W3GFIJ + PUBLIC W3GRMP + PUBLIC W3GRMC + PUBLIC W3CKCL + PUBLIC W3CGDM + PUBLIC W3GRD0 + PUBLIC W3DIV1 + PUBLIC W3DIV2 + PUBLIC W3DIST + PUBLIC W3SPLX + PUBLIC W3SPXL + PUBLIC W3TRLL + PUBLIC W3LLAZ + PUBLIC W3FDWT + PUBLIC W3NNSC + PUBLIC W3NNSD + PUBLIC W3NNSP + PUBLIC W3SORT + PUBLIC W3ISRT + PUBLIC W3INAN + !/ + !/ Public return codes + !/ + INTEGER, PARAMETER, PUBLIC :: MSKC_NONE = 0 + INTEGER, PARAMETER, PUBLIC :: MSKC_PART = 1 + INTEGER, PARAMETER, PUBLIC :: MSKC_FULL = 2 + !/ + !/ Public index closure types (for lat/lon grids only) + !/ ICLO_NONE : no closure in index space + !/ ICLO_SMPL : synonym for ICLO_GRDI + !/ ICLO_GRDI : closure in i-index at i=UBX+1: (UBX+1, j) => (LBX, j) + !/ ICLO_GRDJ : closure in j-index at j=UBY+1: (i, UBY+1) => (i, LBY) + !/ ICLO_TRDL : toroidal grid closure: (UBX+1, j) => (LBX, j) and + !/ (i, UBY+1) => (i, LBY) + !/ ICLO_TRPL : tripole grid closure: (UBX+1, LBY<=j<=UBY) => (LBX, j) and + !/ (LBX<=i<=UBX, UBY+1) => (UBX+LBX-i, UBY) + !/ + !/ Note that simple i-index closure types are set to multiples of 2. + !/ Note that simple j-index closure types are set to multiples of 3. + !/ These settings are used in the GSU methods to simplify checking. + !/ + !/ Implementation notes on index closure: + !/ Simple closure in i-index means that a given integer i' is mapped to the + !/ range [LBX,UBX]. When i' >= LBX, the function i = LBX + MOD(i'-LBX,NX) + !/ maps i' to i in [LBX,UBX] (where, NX = UBX - LBX + 1). The function + !/ i = UBX + MOD(i'-LBX+1,NX) maps any integer i' to i in [LBX,INF). Hence, + !/ the following composition is used to map any integer i' to [LBX,UBX]. + !/ i = LBX + MOD(NX - 1 + MOD(i' - LBX + 1, NX), NX) + !/ Similarly, for simple closure in j-index, the following composition is used + !/ to map any integer j' to [LBY,UBY]. + !/ j = LBY + MOD(NY - 1 + MOD(j' - LBY + 1, NY), NY) + !/ For tripole type index closure, the simple closure in i-index is appied + !/ prior to computing the appropriate i and j-index mapping for closure across + !/ the seam at j = UBY. The j-index closure for i' in [LBX,UBX] and j' > UBY + !/ is computed as i = UBX + LBX - i' and j = 2*UBY - j' + 1. + !/ + INTEGER, PARAMETER, PUBLIC :: ICLO_NONE = -1 + INTEGER, PARAMETER, PUBLIC :: ICLO_SMPL = 2 + INTEGER, PARAMETER, PUBLIC :: ICLO_GRDI = ICLO_SMPL + INTEGER, PARAMETER, PUBLIC :: ICLO_GRDJ = 3 + INTEGER, PARAMETER, PUBLIC :: ICLO_TRDL = 6 + INTEGER, PARAMETER, PUBLIC :: ICLO_TRPL = 8 + !/ + !/ Public grid-search-utility type + !/ This is an opaque type -- that is, it's internals are private and only + !/ accessible to subroutines in this module where the type is declared. + !/ + TYPE, PUBLIC :: T_GSU + PRIVATE + TYPE(CLASS_GSU), POINTER :: PTR => NULL() + END TYPE T_GSU + !/ + !/ Private grid-search-utility class + !/ + TYPE :: CLASS_GSU + LOGICAL :: IJG ! grid array ordering flag: T = (NX,NY), F = (NY,NX) + LOGICAL :: LLG ! spherical coordinate flag of associated grid + INTEGER :: ICLO ! parameter indicating type of index space closure + ! this flag must be set by the user + LOGICAL :: LCLO ! flag indicating longitudinal periodicity + ! this flag is calculated internally + ! LLG & ICLO != ICLO_NONE => LCLO = T + LOGICAL :: L360 ! flag indicating longitude range: + ! T = [0:360], F = [-180:180] + INTEGER :: GKIND ! kind (precision: 4 or 8) of associated grid + INTEGER :: LBX, LBY ! lower-bounds of associated grid + INTEGER :: UBX, UBY ! upper-bounds of associated grid + INTEGER :: NX, NY ! dimensions of associated grid + REAL(4), POINTER :: XG4(:,:), YG4(:,:) ! coordinates of associated grid (r4) + REAL(8), POINTER :: XG8(:,:), YG8(:,:) ! coordinates of associated grid (r8) + TYPE(T_NNS), POINTER :: NNP ! nearest-neighbor point search indices object + INTEGER :: NBX, NBY ! number of buckets in each spatial direction + REAL(8) :: DXB, DYB ! spatial extent of each search bucket + REAL(8) :: XMIN, YMIN, XMAX, YMAX ! bounding box of search domain + TYPE(T_BKT), POINTER :: B(:,:) ! array of search buckets + TYPE(T_NNS), POINTER :: NNB ! nearest-neighbor bucket search indices object + END TYPE CLASS_GSU + !/ + !/ Private search bucket type + !/ + TYPE :: T_BKT + INTEGER :: N ! number of cells in bucket + INTEGER, POINTER :: I(:) ! i-index of cell c + INTEGER, POINTER :: J(:) ! j-index of cell c + END TYPE T_BKT + !/ + !/ Public nearest-neighbor grid-point search type + !/ + TYPE, PUBLIC :: T_NNS + INTEGER :: NLVL ! number of nnbr levels + INTEGER :: NNBR ! total number of nnbr's + INTEGER, POINTER :: N1(:) ! starting nearest-nbr loop index for level l + INTEGER, POINTER :: N2(:) ! ending nearest-nbr loop index for level l + INTEGER, POINTER :: DI(:) ! i-index delta for nearest-nbr n + INTEGER, POINTER :: DJ(:) ! j-index delta for nearest-nbr n + END TYPE T_NNS + !/ + !/ Private module parameters + !/ + REAL(8), PARAMETER :: PI = 3.14159265358979323846D0 + REAL(8), PARAMETER :: PI2 = 2D0*PI + REAL(8), PARAMETER :: PI3H = 3D0*PI/2D0 + REAL(8), PARAMETER :: PIO2 = PI/2D0 + REAL(8), PARAMETER :: PIO4 = PI/4D0 + REAL(8), PARAMETER :: D2R = PI/180D0 + REAL(8), PARAMETER :: R2D = 1D0/D2R + REAL(8), PARAMETER :: D360 = 360D0 + REAL(8), PARAMETER :: D270 = 270D0 + REAL(8), PARAMETER :: D180 = 180D0 + REAL(8), PARAMETER :: D90 = 90D0 + REAL(8), PARAMETER :: ZERO = 0.0D0 + REAL(8), PARAMETER :: HALF = 0.5D0 + REAL(8), PARAMETER :: ONE = 1.0D0 + REAL(8), PARAMETER :: TWO = 2.0D0 + REAL(8), PARAMETER :: FOUR = 4.0D0 #if defined(COAMPS) - REAL(8), PARAMETER :: REARTH = 6371229.D0 + REAL(8), PARAMETER :: REARTH = 6371229.D0 #else - REAL(8), PARAMETER :: REARTH = 4.D7/PI2 !this gives D2M = 111111.111111 + REAL(8), PARAMETER :: REARTH = 4.D7/PI2 !this gives D2M = 111111.111111 #endif - REAL(8), PARAMETER :: D2M = REARTH*D2R - REAL(8), PARAMETER :: M2D = 1D0/D2M -! Default small non-zero tolerance used to check if -! target point is in domain and for point coincidence. - REAL(8), PARAMETER :: EPS_DEFAULT = 1.0D-6 -! Distance (deg) from pole to consider a cell "near the pole" - REAL(8), PARAMETER :: NEAR_POLE = 10.0D0 -! Default number of grid cells (in each direction) per search bucket. - INTEGER, PARAMETER :: NCB_DEFAULT = 10 -! Default maximum number of nearest-neighbor grid point search levels. - INTEGER, PARAMETER :: NNP_DEFAULT = 2 -! Max number of non-empty levels for bucket search when target point -! is outside source domain - INTEGER, PARAMETER :: MAX_FNCL_LEVEL = 3 -! Default finite-difference order - INTEGER, PARAMETER :: NFD_DEFAULT = 4 -!/ -!/ Module Interfaces -!/ - INTERFACE W3GSUC - MODULE PROCEDURE W3GSUC_PTR_R4 - MODULE PROCEDURE W3GSUC_PTR_R8 - MODULE PROCEDURE W3GSUC_TGT_R4 - MODULE PROCEDURE W3GSUC_TGT_R8 - END INTERFACE W3GSUC - INTERFACE W3BBOX - MODULE PROCEDURE W3BBOX_GSU - MODULE PROCEDURE W3BBOX_GRD_PTR_R4 - MODULE PROCEDURE W3BBOX_GRD_PTR_R8 - MODULE PROCEDURE W3BBOX_GRD_TGT_R4 - MODULE PROCEDURE W3BBOX_GRD_TGT_R8 - END INTERFACE W3BBOX - INTERFACE W3GFCL - MODULE PROCEDURE W3GFCL_R4 - MODULE PROCEDURE W3GFCL_R8 - END INTERFACE W3GFCL - INTERFACE W3GFCD - MODULE PROCEDURE W3GFCD_R4 - MODULE PROCEDURE W3GFCD_R8 - END INTERFACE W3GFCD - INTERFACE W3GFPT - MODULE PROCEDURE W3GFPT_R4 - MODULE PROCEDURE W3GFPT_R8 - END INTERFACE W3GFPT - INTERFACE W3GFIJ - MODULE PROCEDURE W3GFIJ_R4 - MODULE PROCEDURE W3GFIJ_R8 - END INTERFACE W3GFIJ - INTERFACE W3GRMP - MODULE PROCEDURE W3GRMP_R4 - MODULE PROCEDURE W3GRMP_R8 - END INTERFACE W3GRMP - INTERFACE W3GRMC - MODULE PROCEDURE W3GRMC_R4 - MODULE PROCEDURE W3GRMC_R8 - END INTERFACE W3GRMC - INTERFACE W3CGDM - MODULE PROCEDURE W3CGDM_R4 - MODULE PROCEDURE W3CGDM_R8 - END INTERFACE W3CGDM - INTERFACE W3GRD0 - MODULE PROCEDURE W3GRD0_R4 - MODULE PROCEDURE W3GRD0_R8 - END INTERFACE W3GRD0 - INTERFACE W3DIV1 - MODULE PROCEDURE W3DIV1_R4 - MODULE PROCEDURE W3DIV1_R8 - END INTERFACE W3DIV1 - INTERFACE W3DIV2 - MODULE PROCEDURE W3DIV2_R4 - MODULE PROCEDURE W3DIV2_R8 - END INTERFACE W3DIV2 - INTERFACE W3DIST - MODULE PROCEDURE W3DIST_R4 - MODULE PROCEDURE W3DIST_R8 - END INTERFACE W3DIST - INTERFACE W3SPLX - MODULE PROCEDURE W3SPLX_0D_R4 - MODULE PROCEDURE W3SPLX_0D_R8 - MODULE PROCEDURE W3SPLX_1D_R4 - MODULE PROCEDURE W3SPLX_1D_R8 - MODULE PROCEDURE W3SPLX_2D_R4 - MODULE PROCEDURE W3SPLX_2D_R8 - END INTERFACE W3SPLX - INTERFACE W3SPXL - MODULE PROCEDURE W3SPXL_0D_R4 - MODULE PROCEDURE W3SPXL_0D_R8 - MODULE PROCEDURE W3SPXL_1D_R4 - MODULE PROCEDURE W3SPXL_1D_R8 - MODULE PROCEDURE W3SPXL_2D_R4 - MODULE PROCEDURE W3SPXL_2D_R8 - END INTERFACE W3SPXL - INTERFACE W3TRLL - MODULE PROCEDURE W3TRLL_0D_R4 - MODULE PROCEDURE W3TRLL_0D_R8 - MODULE PROCEDURE W3TRLL_1D_R4 - MODULE PROCEDURE W3TRLL_1D_R8 - MODULE PROCEDURE W3TRLL_2D_R4 - MODULE PROCEDURE W3TRLL_2D_R8 - END INTERFACE W3TRLL - INTERFACE W3LLAZ - MODULE PROCEDURE W3LLAZ_R4 - MODULE PROCEDURE W3LLAZ_R8 - END INTERFACE W3LLAZ - INTERFACE W3FDWT - MODULE PROCEDURE W3FDWT_R4 - MODULE PROCEDURE W3FDWT_R8 - END INTERFACE W3FDWT - INTERFACE W3CKCL - MODULE PROCEDURE W3CKCL_R4 - MODULE PROCEDURE W3CKCL_R8 - END INTERFACE W3CKCL - INTERFACE W3SORT - MODULE PROCEDURE W3SORT_R4 - MODULE PROCEDURE W3SORT_R8 - END INTERFACE W3SORT - INTERFACE W3ISRT - MODULE PROCEDURE W3ISRT_R4 - MODULE PROCEDURE W3ISRT_R8 - END INTERFACE W3ISRT - INTERFACE W3INAN - MODULE PROCEDURE W3INAN_R4 - MODULE PROCEDURE W3INAN_R8 - END INTERFACE W3INAN - -!/ - CONTAINS -!/ -!/ =================================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3GSUC( IJG, LLG, ICLO, XG, YG, & -!/ NCB, NNP, DEBUG ) RESULT(GSU) -!/ OR -!/ FUNCTION W3GSUC( IJG, LLG, ICLO, LB, UB, XG, YG, & -!/ NCB, NNP, DEBUG ) RESULT(GSU) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Create grid-search-utility (GSU) object for a logically rectangular -! grid defined by the input coordinates. -! -! 2. Method : -! -! 3. Parameters : -! -! Return parameter -! ---------------------------------------------------------------- -! GSU Type O Created grid-search-utility object. -! ---------------------------------------------------------------- -! -! Parameter list -! ---------------------------------------------------------------- -! IJG Log. I Logical flag indicating ordering of input -! coord. arrays: T = (NX,NY) and F = (NY,NX). -! LLG Log. I Logical flag indicating the coordinate system: -! T = spherical lat/lon (degrees) and F = Cartesian. -! ICLO Int. I Parameter indicating type of index space closure -! -! Inputs (for W3GSUC_PTR): -! XG R.A. I Pointer to array of x-coordinates of input grid. -! YG R.A. I Pointer to array of y-coordinates of input grid. -! -! Inputs (for W3GSUC_TGT): -! LB I.A. I Lower bounds of XG and YG arrays -! UB I.A. I Upper bounds of XG and YG arrays -! XG R.A. I Array of x-coordinates of input grid. -! YG R.A. I Array of y-coordinates of input grid. -! -! NCB Int. I OPTIONAL (approximate) number of cells (in each -! direction) per search bucket. (default is NCB_DEFAULT) -! NCB >= 1 is required. NCB = 1 gives most efficient -! searching, but uses more memory. Increasing NCB leads -! to fewer buckets (less memory) but slower searching. -! NNP Int. I OPTIONAL maximum number of nearest-neighbor grid -! point search levels. (default is NNP_DEFAULT) -! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. -! Default is FALSE. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! - Check on correct coordinate system with global grid. -! - Check on association of input grid coordinate array pointers. -! -! 7. Remarks : -! -! - LCLO is calculated internally. -! - LLG & ICLO != ICLO_NONE => LCLO = T. -! - Periodic Cartesian grids are not allowed. -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Test input -! 2. Allocate object and set grid related data and pointers -! 3. Create nearest-neighbor point search object -! 4. Construct bucket search "object" -! 5. Set return parameter -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GSUC_PTR_R4( IJG, LLG, ICLO, XG, YG, & - NCB, NNP, DEBUG ) RESULT(GSU) -! Single precision pointer interface - TYPE(T_GSU) :: GSU - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - REAL(4), POINTER :: XG(:,:) - REAL(4), POINTER :: YG(:,:) - INTEGER, INTENT(IN), OPTIONAL :: NCB - INTEGER, INTENT(IN), OPTIONAL :: NNP - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - INTEGER :: LB(2), UB(2) + REAL(8), PARAMETER :: D2M = REARTH*D2R + REAL(8), PARAMETER :: M2D = 1D0/D2M + ! Default small non-zero tolerance used to check if + ! target point is in domain and for point coincidence. + REAL(8), PARAMETER :: EPS_DEFAULT = 1.0D-6 + ! Distance (deg) from pole to consider a cell "near the pole" + REAL(8), PARAMETER :: NEAR_POLE = 10.0D0 + ! Default number of grid cells (in each direction) per search bucket. + INTEGER, PARAMETER :: NCB_DEFAULT = 10 + ! Default maximum number of nearest-neighbor grid point search levels. + INTEGER, PARAMETER :: NNP_DEFAULT = 2 + ! Max number of non-empty levels for bucket search when target point + ! is outside source domain + INTEGER, PARAMETER :: MAX_FNCL_LEVEL = 3 + ! Default finite-difference order + INTEGER, PARAMETER :: NFD_DEFAULT = 4 + !/ + !/ Module Interfaces + !/ + INTERFACE W3GSUC + MODULE PROCEDURE W3GSUC_PTR_R4 + MODULE PROCEDURE W3GSUC_PTR_R8 + MODULE PROCEDURE W3GSUC_TGT_R4 + MODULE PROCEDURE W3GSUC_TGT_R8 + END INTERFACE W3GSUC + INTERFACE W3BBOX + MODULE PROCEDURE W3BBOX_GSU + MODULE PROCEDURE W3BBOX_GRD_PTR_R4 + MODULE PROCEDURE W3BBOX_GRD_PTR_R8 + MODULE PROCEDURE W3BBOX_GRD_TGT_R4 + MODULE PROCEDURE W3BBOX_GRD_TGT_R8 + END INTERFACE W3BBOX + INTERFACE W3GFCL + MODULE PROCEDURE W3GFCL_R4 + MODULE PROCEDURE W3GFCL_R8 + END INTERFACE W3GFCL + INTERFACE W3GFCD + MODULE PROCEDURE W3GFCD_R4 + MODULE PROCEDURE W3GFCD_R8 + END INTERFACE W3GFCD + INTERFACE W3GFPT + MODULE PROCEDURE W3GFPT_R4 + MODULE PROCEDURE W3GFPT_R8 + END INTERFACE W3GFPT + INTERFACE W3GFIJ + MODULE PROCEDURE W3GFIJ_R4 + MODULE PROCEDURE W3GFIJ_R8 + END INTERFACE W3GFIJ + INTERFACE W3GRMP + MODULE PROCEDURE W3GRMP_R4 + MODULE PROCEDURE W3GRMP_R8 + END INTERFACE W3GRMP + INTERFACE W3GRMC + MODULE PROCEDURE W3GRMC_R4 + MODULE PROCEDURE W3GRMC_R8 + END INTERFACE W3GRMC + INTERFACE W3CGDM + MODULE PROCEDURE W3CGDM_R4 + MODULE PROCEDURE W3CGDM_R8 + END INTERFACE W3CGDM + INTERFACE W3GRD0 + MODULE PROCEDURE W3GRD0_R4 + MODULE PROCEDURE W3GRD0_R8 + END INTERFACE W3GRD0 + INTERFACE W3DIV1 + MODULE PROCEDURE W3DIV1_R4 + MODULE PROCEDURE W3DIV1_R8 + END INTERFACE W3DIV1 + INTERFACE W3DIV2 + MODULE PROCEDURE W3DIV2_R4 + MODULE PROCEDURE W3DIV2_R8 + END INTERFACE W3DIV2 + INTERFACE W3DIST + MODULE PROCEDURE W3DIST_R4 + MODULE PROCEDURE W3DIST_R8 + END INTERFACE W3DIST + INTERFACE W3SPLX + MODULE PROCEDURE W3SPLX_0D_R4 + MODULE PROCEDURE W3SPLX_0D_R8 + MODULE PROCEDURE W3SPLX_1D_R4 + MODULE PROCEDURE W3SPLX_1D_R8 + MODULE PROCEDURE W3SPLX_2D_R4 + MODULE PROCEDURE W3SPLX_2D_R8 + END INTERFACE W3SPLX + INTERFACE W3SPXL + MODULE PROCEDURE W3SPXL_0D_R4 + MODULE PROCEDURE W3SPXL_0D_R8 + MODULE PROCEDURE W3SPXL_1D_R4 + MODULE PROCEDURE W3SPXL_1D_R8 + MODULE PROCEDURE W3SPXL_2D_R4 + MODULE PROCEDURE W3SPXL_2D_R8 + END INTERFACE W3SPXL + INTERFACE W3TRLL + MODULE PROCEDURE W3TRLL_0D_R4 + MODULE PROCEDURE W3TRLL_0D_R8 + MODULE PROCEDURE W3TRLL_1D_R4 + MODULE PROCEDURE W3TRLL_1D_R8 + MODULE PROCEDURE W3TRLL_2D_R4 + MODULE PROCEDURE W3TRLL_2D_R8 + END INTERFACE W3TRLL + INTERFACE W3LLAZ + MODULE PROCEDURE W3LLAZ_R4 + MODULE PROCEDURE W3LLAZ_R8 + END INTERFACE W3LLAZ + INTERFACE W3FDWT + MODULE PROCEDURE W3FDWT_R4 + MODULE PROCEDURE W3FDWT_R8 + END INTERFACE W3FDWT + INTERFACE W3CKCL + MODULE PROCEDURE W3CKCL_R4 + MODULE PROCEDURE W3CKCL_R8 + END INTERFACE W3CKCL + INTERFACE W3SORT + MODULE PROCEDURE W3SORT_R4 + MODULE PROCEDURE W3SORT_R8 + END INTERFACE W3SORT + INTERFACE W3ISRT + MODULE PROCEDURE W3ISRT_R4 + MODULE PROCEDURE W3ISRT_R8 + END INTERFACE W3ISRT + INTERFACE W3INAN + MODULE PROCEDURE W3INAN_R4 + MODULE PROCEDURE W3INAN_R8 + END INTERFACE W3INAN + + !/ +CONTAINS + !/ + !/ =================================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3GSUC( IJG, LLG, ICLO, XG, YG, & + !/ NCB, NNP, DEBUG ) RESULT(GSU) + !/ OR + !/ FUNCTION W3GSUC( IJG, LLG, ICLO, LB, UB, XG, YG, & + !/ NCB, NNP, DEBUG ) RESULT(GSU) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Create grid-search-utility (GSU) object for a logically rectangular + ! grid defined by the input coordinates. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Return parameter + ! ---------------------------------------------------------------- + ! GSU Type O Created grid-search-utility object. + ! ---------------------------------------------------------------- + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IJG Log. I Logical flag indicating ordering of input + ! coord. arrays: T = (NX,NY) and F = (NY,NX). + ! LLG Log. I Logical flag indicating the coordinate system: + ! T = spherical lat/lon (degrees) and F = Cartesian. + ! ICLO Int. I Parameter indicating type of index space closure + ! + ! Inputs (for W3GSUC_PTR): + ! XG R.A. I Pointer to array of x-coordinates of input grid. + ! YG R.A. I Pointer to array of y-coordinates of input grid. + ! + ! Inputs (for W3GSUC_TGT): + ! LB I.A. I Lower bounds of XG and YG arrays + ! UB I.A. I Upper bounds of XG and YG arrays + ! XG R.A. I Array of x-coordinates of input grid. + ! YG R.A. I Array of y-coordinates of input grid. + ! + ! NCB Int. I OPTIONAL (approximate) number of cells (in each + ! direction) per search bucket. (default is NCB_DEFAULT) + ! NCB >= 1 is required. NCB = 1 gives most efficient + ! searching, but uses more memory. Increasing NCB leads + ! to fewer buckets (less memory) but slower searching. + ! NNP Int. I OPTIONAL maximum number of nearest-neighbor grid + ! point search levels. (default is NNP_DEFAULT) + ! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. + ! Default is FALSE. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! - Check on correct coordinate system with global grid. + ! - Check on association of input grid coordinate array pointers. + ! + ! 7. Remarks : + ! + ! - LCLO is calculated internally. + ! - LLG & ICLO != ICLO_NONE => LCLO = T. + ! - Periodic Cartesian grids are not allowed. + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Test input + ! 2. Allocate object and set grid related data and pointers + ! 3. Create nearest-neighbor point search object + ! 4. Construct bucket search "object" + ! 5. Set return parameter + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GSUC_PTR_R4( IJG, LLG, ICLO, XG, YG, & + NCB, NNP, DEBUG ) RESULT(GSU) + ! Single precision pointer interface + TYPE(T_GSU) :: GSU + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + REAL(4), POINTER :: XG(:,:) + REAL(4), POINTER :: YG(:,:) + INTEGER, INTENT(IN), OPTIONAL :: NCB + INTEGER, INTENT(IN), OPTIONAL :: NNP + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + INTEGER :: LB(2), UB(2) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GSUC_PTR_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUC_PTR_R4') #endif -! - LB(1) = LBOUND(XG,1); LB(2) = LBOUND(XG,2) - UB(1) = UBOUND(XG,1); UB(2) = UBOUND(XG,2) - GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4=XG, YG4=YG, & - NCB=NCB, NNP=NNP, DEBUG=DEBUG) - - END FUNCTION W3GSUC_PTR_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GSUC_PTR_R8( IJG, LLG, ICLO, XG, YG, & - NCB, NNP, DEBUG ) RESULT(GSU) -! Double precision pointer interface - TYPE(T_GSU) :: GSU - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - REAL(8), POINTER :: XG(:,:) - REAL(8), POINTER :: YG(:,:) - INTEGER, INTENT(IN), OPTIONAL :: NCB - INTEGER, INTENT(IN), OPTIONAL :: NNP - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - INTEGER :: LB(2), UB(2) + ! + LB(1) = LBOUND(XG,1); LB(2) = LBOUND(XG,2) + UB(1) = UBOUND(XG,1); UB(2) = UBOUND(XG,2) + GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4=XG, YG4=YG, & + NCB=NCB, NNP=NNP, DEBUG=DEBUG) + + END FUNCTION W3GSUC_PTR_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GSUC_PTR_R8( IJG, LLG, ICLO, XG, YG, & + NCB, NNP, DEBUG ) RESULT(GSU) + ! Double precision pointer interface + TYPE(T_GSU) :: GSU + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + REAL(8), POINTER :: XG(:,:) + REAL(8), POINTER :: YG(:,:) + INTEGER, INTENT(IN), OPTIONAL :: NCB + INTEGER, INTENT(IN), OPTIONAL :: NNP + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + INTEGER :: LB(2), UB(2) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GSUC_PTR_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUC_PTR_R4') #endif -! - LB(1) = LBOUND(XG,1); LB(2) = LBOUND(XG,2) - UB(1) = UBOUND(XG,1); UB(2) = UBOUND(XG,2) - GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG8=XG, YG8=YG, & - NCB=NCB, NNP=NNP, DEBUG=DEBUG) - - END FUNCTION W3GSUC_PTR_R8 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GSUC_TGT_R4( IJG, LLG, ICLO, LB, UB, XG, YG, & - NCB, NNP, DEBUG ) RESULT(GSU) -! Single precision target interface - TYPE(T_GSU) :: GSU - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - INTEGER, INTENT(IN) :: LB(2) - INTEGER, INTENT(IN) :: UB(2) - REAL(4), TARGET :: XG(LB(1):UB(1),LB(2):UB(2)) - REAL(4), TARGET :: YG(LB(1):UB(1),LB(2):UB(2)) - INTEGER, INTENT(IN), OPTIONAL :: NCB - INTEGER, INTENT(IN), OPTIONAL :: NNP - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters + ! + LB(1) = LBOUND(XG,1); LB(2) = LBOUND(XG,2) + UB(1) = UBOUND(XG,1); UB(2) = UBOUND(XG,2) + GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG8=XG, YG8=YG, & + NCB=NCB, NNP=NNP, DEBUG=DEBUG) + + END FUNCTION W3GSUC_PTR_R8 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GSUC_TGT_R4( IJG, LLG, ICLO, LB, UB, XG, YG, & + NCB, NNP, DEBUG ) RESULT(GSU) + ! Single precision target interface + TYPE(T_GSU) :: GSU + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + INTEGER, INTENT(IN) :: LB(2) + INTEGER, INTENT(IN) :: UB(2) + REAL(4), TARGET :: XG(LB(1):UB(1),LB(2):UB(2)) + REAL(4), TARGET :: YG(LB(1):UB(1),LB(2):UB(2)) + INTEGER, INTENT(IN), OPTIONAL :: NCB + INTEGER, INTENT(IN), OPTIONAL :: NNP + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GSUC_TGT_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUC_TGT_R4') #endif -! - GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4=XG, YG4=YG, & - NCB=NCB, NNP=NNP, DEBUG=DEBUG) - - END FUNCTION W3GSUC_TGT_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GSUC_TGT_R8( IJG, LLG, ICLO, LB, UB, XG, YG, & - NCB, NNP, DEBUG ) RESULT(GSU) -! Double precision target interface - TYPE(T_GSU) :: GSU - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - INTEGER, INTENT(IN) :: LB(2) - INTEGER, INTENT(IN) :: UB(2) - REAL(8), TARGET :: XG(LB(1):UB(1),LB(2):UB(2)) - REAL(8), TARGET :: YG(LB(1):UB(1),LB(2):UB(2)) - INTEGER, INTENT(IN), OPTIONAL :: NCB - INTEGER, INTENT(IN), OPTIONAL :: NNP - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters + ! + GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4=XG, YG4=YG, & + NCB=NCB, NNP=NNP, DEBUG=DEBUG) + + END FUNCTION W3GSUC_TGT_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GSUC_TGT_R8( IJG, LLG, ICLO, LB, UB, XG, YG, & + NCB, NNP, DEBUG ) RESULT(GSU) + ! Double precision target interface + TYPE(T_GSU) :: GSU + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + INTEGER, INTENT(IN) :: LB(2) + INTEGER, INTENT(IN) :: UB(2) + REAL(8), TARGET :: XG(LB(1):UB(1),LB(2):UB(2)) + REAL(8), TARGET :: YG(LB(1):UB(1),LB(2):UB(2)) + INTEGER, INTENT(IN), OPTIONAL :: NCB + INTEGER, INTENT(IN), OPTIONAL :: NNP + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GSUC_TGT_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUC_TGT_R8') #endif -! - GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG8=XG, YG8=YG, & - NCB=NCB, NNP=NNP, DEBUG=DEBUG) - - END FUNCTION W3GSUC_TGT_R8 -!/ -!/ End of W3GSUC ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3GSUD( GSU ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Destroy grid search utility (GSU) object. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! GSU Type I Grid-search-utility object. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! - Check on previous creation of grid-search-utility object. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3GSUD( GSU ) - TYPE(T_GSU), INTENT(INOUT) :: GSU - -! Local parameters - INTEGER :: IB, JB + ! + GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG8=XG, YG8=YG, & + NCB=NCB, NNP=NNP, DEBUG=DEBUG) + + END FUNCTION W3GSUC_TGT_R8 + !/ + !/ End of W3GSUC ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3GSUD( GSU ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Destroy grid search utility (GSU) object. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! GSU Type I Grid-search-utility object. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! - Check on previous creation of grid-search-utility object. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3GSUD( GSU ) + TYPE(T_GSU), INTENT(INOUT) :: GSU + + ! Local parameters + INTEGER :: IB, JB #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GSUD') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUD') #endif -! - IF ( ASSOCIATED(GSU%PTR) ) THEN -! - CALL W3NNSD(GSU%PTR%NNP) -! - IF ( ASSOCIATED(GSU%PTR%B) ) THEN - DO IB=1,GSU%PTR%NBX - DO JB=1,GSU%PTR%NBY - IF ( GSU%PTR%B(JB,IB)%N .GT. 0 ) THEN - DEALLOCATE(GSU%PTR%B(JB,IB)%I) - NULLIFY(GSU%PTR%B(JB,IB)%I) - DEALLOCATE(GSU%PTR%B(JB,IB)%J) - NULLIFY(GSU%PTR%B(JB,IB)%J) - END IF - END DO - END DO - DEALLOCATE(GSU%PTR%B) - NULLIFY(GSU%PTR%B) + ! + IF ( ASSOCIATED(GSU%PTR) ) THEN + ! + CALL W3NNSD(GSU%PTR%NNP) + ! + IF ( ASSOCIATED(GSU%PTR%B) ) THEN + DO IB=1,GSU%PTR%NBX + DO JB=1,GSU%PTR%NBY + IF ( GSU%PTR%B(JB,IB)%N .GT. 0 ) THEN + DEALLOCATE(GSU%PTR%B(JB,IB)%I) + NULLIFY(GSU%PTR%B(JB,IB)%I) + DEALLOCATE(GSU%PTR%B(JB,IB)%J) + NULLIFY(GSU%PTR%B(JB,IB)%J) END IF -! - CALL W3NNSD(GSU%PTR%NNB) -! - DEALLOCATE(GSU%PTR) - NULLIFY(GSU%PTR) -! - END IF - - END SUBROUTINE W3GSUD -!/ -!/ End of W3GSUD ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3GSUP( GSU, IUNIT, LFULL ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Print grid-search-utility (GSU) object to IUNIT. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! GSU Type I Grid-search-utility object. -! IUNIT Int. I OPTIONAL unit for output. Default is stdout. -! LFULL Log. I OPTIONAL logical flag to turn on full-output -! mode. Default is FALSE. When full-output -! is enabled the search bucket cell lists and -! nearest-neighbor point search indices are output. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! - Check on previous creation of grid-search-utility object. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3GSUP( GSU, IUNIT, LFULL ) - TYPE(T_GSU), INTENT(IN) :: GSU - INTEGER, OPTIONAL, INTENT(IN) :: IUNIT - LOGICAL, OPTIONAL, INTENT(IN) :: LFULL - -! Local parameters - INTEGER, PARAMETER :: NBYTE_PTR=4 - INTEGER, PARAMETER :: NBYTE_INT=4 - TYPE(CLASS_GSU), POINTER :: PTR - INTEGER :: NDST, K, IB, JB, NBYTE + END DO + END DO + DEALLOCATE(GSU%PTR%B) + NULLIFY(GSU%PTR%B) + END IF + ! + CALL W3NNSD(GSU%PTR%NNB) + ! + DEALLOCATE(GSU%PTR) + NULLIFY(GSU%PTR) + ! + END IF + + END SUBROUTINE W3GSUD + !/ + !/ End of W3GSUD ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3GSUP( GSU, IUNIT, LFULL ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Print grid-search-utility (GSU) object to IUNIT. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! GSU Type I Grid-search-utility object. + ! IUNIT Int. I OPTIONAL unit for output. Default is stdout. + ! LFULL Log. I OPTIONAL logical flag to turn on full-output + ! mode. Default is FALSE. When full-output + ! is enabled the search bucket cell lists and + ! nearest-neighbor point search indices are output. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! - Check on previous creation of grid-search-utility object. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3GSUP( GSU, IUNIT, LFULL ) + TYPE(T_GSU), INTENT(IN) :: GSU + INTEGER, OPTIONAL, INTENT(IN) :: IUNIT + LOGICAL, OPTIONAL, INTENT(IN) :: LFULL + + ! Local parameters + INTEGER, PARAMETER :: NBYTE_PTR=4 + INTEGER, PARAMETER :: NBYTE_INT=4 + TYPE(CLASS_GSU), POINTER :: PTR + INTEGER :: NDST, K, IB, JB, NBYTE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GSUP') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUP') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input -! - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/1A,1A/)') 'W3GSUP ERROR -- ', & - 'grid search utility object not created' - CALL EXTCDE (1) - END IF - - IF ( PRESENT(IUNIT) ) THEN - NDST = IUNIT - ELSE - NDST = 6 - END IF - - PTR => GSU%PTR -! -! -------------------------------------------------------------------- / -! 2. Compute approximate memory usage -! - NBYTE = (NBYTE_INT+NBYTE_PTR*2)*SIZE(PTR%B) - DO IB=1,PTR%NBX + ! + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/1A,1A/)') 'W3GSUP ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + + IF ( PRESENT(IUNIT) ) THEN + NDST = IUNIT + ELSE + NDST = 6 + END IF + + PTR => GSU%PTR + ! + ! -------------------------------------------------------------------- / + ! 2. Compute approximate memory usage + ! + NBYTE = (NBYTE_INT+NBYTE_PTR*2)*SIZE(PTR%B) + DO IB=1,PTR%NBX DO JB=1,PTR%NBY - NBYTE = NBYTE + NBYTE_INT*2*PTR%B(JB,IB)%N + NBYTE = NBYTE + NBYTE_INT*2*PTR%B(JB,IB)%N + END DO + END DO + ! + ! -------------------------------------------------------------------- / + ! 3. Output + ! + WRITE(NDST,'(//80A)') ('-',K=1,80) + WRITE(NDST,'(A)') 'Report on grid search utility object' + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'(A,1L2)') 'Grid ijg:',PTR%IJG + WRITE(NDST,'(A,1L2)') 'Grid llg:',PTR%LLG + WRITE(NDST,'(A,1I2)') 'Grid iclo:',PTR%ICLO + WRITE(NDST,'(A,1L2)') 'Grid lclo:',PTR%LCLO + WRITE(NDST,'(A,1I2)') 'Grid precision:',PTR%GKIND + WRITE(NDST,'(A,2I6)') 'Grid lbx,lby:',PTR%LBX,PTR%LBY + WRITE(NDST,'(A,2I6)') 'Grid ubx,uby:',PTR%UBX,PTR%UBY + WRITE(NDST,'(A,2I6)') 'Grid nx, ny:',PTR%NX,PTR%NY + IF ( PRESENT(LFULL) ) THEN + IF ( LFULL ) THEN + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'(A)') 'Nearest-neighbor point search indices' + WRITE(NDST,'( 80A)') ('-',K=1,80) + CALL W3NNSP(PTR%NNP,NDST) + END IF + END IF + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'(A)') 'Bucket-search object' + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'(A,4E24.16)') 'Spatial grid search domain: ', & + PTR%XMIN,PTR%YMIN,PTR%XMAX,PTR%YMAX + WRITE(NDST,'(A,2I6)') 'nbx,nby:',PTR%NBX,PTR%NBY + WRITE(NDST,'(A,2E24.16)') 'dxb,dyb:',PTR%DXB,PTR%DYB + WRITE(NDST,'(A,1F10.1)') 'Approximate memory usage (MB):', & + REAL(NBYTE)/2**20 + IF ( PRESENT(LFULL) ) THEN + IF ( LFULL ) THEN + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'(A)') 'Search bucket bounds:' + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'(2A4,4A24)') 'IB','JB','X1','Y1','X2','Y2' + DO IB=1,PTR%NBX + DO JB=1,PTR%NBY + WRITE(NDST,'(2I4,4E24.16)') IB,JB, & + PTR%XMIN+(IB-1)*PTR%DXB,PTR%YMIN+(JB-1)*PTR%DYB, & + PTR%XMIN+(IB )*PTR%DXB,PTR%YMIN+(JB )*PTR%DYB + END DO END DO + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'(A)') 'Number of cells in each search bucket:' + WRITE(NDST,'( 80A)') ('-',K=1,80) + DO JB=PTR%NBY,1,-1 + WRITE(NDST,'(500I4)') (PTR%B(JB,IB)%N,IB=1,PTR%NBX) END DO -! -! -------------------------------------------------------------------- / -! 3. Output -! - WRITE(NDST,'(//80A)') ('-',K=1,80) - WRITE(NDST,'(A)') 'Report on grid search utility object' - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'(A,1L2)') 'Grid ijg:',PTR%IJG - WRITE(NDST,'(A,1L2)') 'Grid llg:',PTR%LLG - WRITE(NDST,'(A,1I2)') 'Grid iclo:',PTR%ICLO - WRITE(NDST,'(A,1L2)') 'Grid lclo:',PTR%LCLO - WRITE(NDST,'(A,1I2)') 'Grid precision:',PTR%GKIND - WRITE(NDST,'(A,2I6)') 'Grid lbx,lby:',PTR%LBX,PTR%LBY - WRITE(NDST,'(A,2I6)') 'Grid ubx,uby:',PTR%UBX,PTR%UBY - WRITE(NDST,'(A,2I6)') 'Grid nx, ny:',PTR%NX,PTR%NY - IF ( PRESENT(LFULL) ) THEN - IF ( LFULL ) THEN - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'(A)') 'Nearest-neighbor point search indices' - WRITE(NDST,'( 80A)') ('-',K=1,80) - CALL W3NNSP(PTR%NNP,NDST) - END IF - END IF - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'(A)') 'Bucket-search object' - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'(A,4E24.16)') 'Spatial grid search domain: ', & - PTR%XMIN,PTR%YMIN,PTR%XMAX,PTR%YMAX - WRITE(NDST,'(A,2I6)') 'nbx,nby:',PTR%NBX,PTR%NBY - WRITE(NDST,'(A,2E24.16)') 'dxb,dyb:',PTR%DXB,PTR%DYB - WRITE(NDST,'(A,1F10.1)') 'Approximate memory usage (MB):', & - REAL(NBYTE)/2**20 - IF ( PRESENT(LFULL) ) THEN - IF ( LFULL ) THEN - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'(A)') 'Search bucket bounds:' - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'(2A4,4A24)') 'IB','JB','X1','Y1','X2','Y2' - DO IB=1,PTR%NBX - DO JB=1,PTR%NBY - WRITE(NDST,'(2I4,4E24.16)') IB,JB, & - PTR%XMIN+(IB-1)*PTR%DXB,PTR%YMIN+(JB-1)*PTR%DYB, & - PTR%XMIN+(IB )*PTR%DXB,PTR%YMIN+(JB )*PTR%DYB - END DO - END DO - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'(A)') 'Number of cells in each search bucket:' - WRITE(NDST,'( 80A)') ('-',K=1,80) - DO JB=PTR%NBY,1,-1 - WRITE(NDST,'(500I4)') (PTR%B(JB,IB)%N,IB=1,PTR%NBX) - END DO - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'(A)') 'Search bucket cell lists:' - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'(3A4,A)') 'IB','JB','NC',': ( IC, JC), ...' - DO JB=1,PTR%NBY - DO IB=1,PTR%NBX - WRITE(NDST,'(3I4,A,500(A,I3,A,I3,A))') IB,JB, & - PTR%B(JB,IB)%N, ': ', & - ( '(',PTR%B(JB,IB)%I(K),',',PTR%B(JB,IB)%J(K),') ', & - K=1,PTR%B(JB,IB)%N ) - END DO - END DO - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'(A)') 'Nearest-neighbor bucket search indices' - WRITE(NDST,'( 80A)') ('-',K=1,80) - CALL W3NNSP(PTR%NNB,NDST) - END IF !LFULL - END IF !PRESENT(LFULL) - WRITE(NDST,'( 80A)') ('-',K=1,80) - WRITE(NDST,'( 80A)') ('-',K=1,80) - - END SUBROUTINE W3GSUP -!/ -!/ End of W3GSUP ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3BBOX( GSU, XMIN, YMIN, XMAX, YMAX ) -!/ OR -!/ SUBROUTINE W3BBOX( IJG, LLG, ICLO, XG, YG, XMIN, YMIN, XMAX, YMAX ) -!/ OR -!/ SUBROUTINE W3BBOX( IJG, LLG, ICLO, LB, UB, XG, YG, XMIN, YMIN, XMAX, YMAX ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Get bounding box associated with grid. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Inputs (for W3BBOX_GSU): -! GSU Type I Grid-search-utility object -! -! Inputs (for W3BBOX_GRD_PTR): -! IJG Log. I Logical flag indicating ordering of input -! coord. arrays: T = (NX,NY) and F = (NY,NX). -! LLG Log. I Logical flag indicating the coordinate system: -! T = spherical lat/lon (degrees) and F = Cartesian. -! ICLO Int. I Parameter indicating type of index space closure -! XG R.A. I Pointer to array of x-coordinates of input grid. -! YG R.A. I Pointer to array of y-coordinates of input grid. -! -! Inputs (for W3BBOX_GRD_TGT): -! IJG Log. I Logical flag indicating ordering of input -! coord. arrays: T = (NX,NY) and F = (NY,NX). -! LLG Log. I Logical flag indicating the coordinate system: -! T = spherical lat/lon (degrees) and F = Cartesian. -! ICLO Int. I Parameter indicating type of index space closure -! LB I.A. I Lower bounds of XG and YG arrays -! UB I.A. I Upper bounds of XG and YG arrays -! XG R.A. I Array of x-coordinates of input grid. -! YG R.A. I Array of y-coordinates of input grid. -! -! Outputs: -! XMIN Int. O Minimum X-coord of bounding box -! YMIN Int. O Minimum Y-coord of bounding box -! XMAX Int. O Maximum X-coord of bounding box -! YMAX Int. O Maximum Y-coord of bounding box -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! - Check on previous creation of grid-search-utility object. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3BBOX_GSU( GSU, XMIN, YMIN, XMAX, YMAX ) - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX - -! Local parameters + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'(A)') 'Search bucket cell lists:' + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'(3A4,A)') 'IB','JB','NC',': ( IC, JC), ...' + DO JB=1,PTR%NBY + DO IB=1,PTR%NBX + WRITE(NDST,'(3I4,A,500(A,I3,A,I3,A))') IB,JB, & + PTR%B(JB,IB)%N, ': ', & + ( '(',PTR%B(JB,IB)%I(K),',',PTR%B(JB,IB)%J(K),') ', & + K=1,PTR%B(JB,IB)%N ) + END DO + END DO + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'(A)') 'Nearest-neighbor bucket search indices' + WRITE(NDST,'( 80A)') ('-',K=1,80) + CALL W3NNSP(PTR%NNB,NDST) + END IF !LFULL + END IF !PRESENT(LFULL) + WRITE(NDST,'( 80A)') ('-',K=1,80) + WRITE(NDST,'( 80A)') ('-',K=1,80) + + END SUBROUTINE W3GSUP + !/ + !/ End of W3GSUP ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3BBOX( GSU, XMIN, YMIN, XMAX, YMAX ) + !/ OR + !/ SUBROUTINE W3BBOX( IJG, LLG, ICLO, XG, YG, XMIN, YMIN, XMAX, YMAX ) + !/ OR + !/ SUBROUTINE W3BBOX( IJG, LLG, ICLO, LB, UB, XG, YG, XMIN, YMIN, XMAX, YMAX ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Get bounding box associated with grid. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Inputs (for W3BBOX_GSU): + ! GSU Type I Grid-search-utility object + ! + ! Inputs (for W3BBOX_GRD_PTR): + ! IJG Log. I Logical flag indicating ordering of input + ! coord. arrays: T = (NX,NY) and F = (NY,NX). + ! LLG Log. I Logical flag indicating the coordinate system: + ! T = spherical lat/lon (degrees) and F = Cartesian. + ! ICLO Int. I Parameter indicating type of index space closure + ! XG R.A. I Pointer to array of x-coordinates of input grid. + ! YG R.A. I Pointer to array of y-coordinates of input grid. + ! + ! Inputs (for W3BBOX_GRD_TGT): + ! IJG Log. I Logical flag indicating ordering of input + ! coord. arrays: T = (NX,NY) and F = (NY,NX). + ! LLG Log. I Logical flag indicating the coordinate system: + ! T = spherical lat/lon (degrees) and F = Cartesian. + ! ICLO Int. I Parameter indicating type of index space closure + ! LB I.A. I Lower bounds of XG and YG arrays + ! UB I.A. I Upper bounds of XG and YG arrays + ! XG R.A. I Array of x-coordinates of input grid. + ! YG R.A. I Array of y-coordinates of input grid. + ! + ! Outputs: + ! XMIN Int. O Minimum X-coord of bounding box + ! YMIN Int. O Minimum Y-coord of bounding box + ! XMAX Int. O Maximum X-coord of bounding box + ! YMAX Int. O Maximum Y-coord of bounding box + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! - Check on previous creation of grid-search-utility object. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3BBOX_GSU( GSU, XMIN, YMIN, XMAX, YMAX ) + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX + + ! Local parameters #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3BBOX_GSU') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3BBOX_GSU') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input -! - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/1A,1A/)') 'W3BBOX_GSU ERROR -- ', & - 'grid search utility object not created' - CALL EXTCDE (1) - END IF -! -! -------------------------------------------------------------------- / -! 2. Set bounding box -! - XMIN = GSU%PTR%XMIN - YMIN = GSU%PTR%YMIN - XMAX = GSU%PTR%XMAX - YMAX = GSU%PTR%YMAX - - END SUBROUTINE W3BBOX_GSU -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3BBOX_GRD_PTR_R4( IJG, LLG, ICLO, XG, YG, & - XMIN, YMIN, XMAX, YMAX ) - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - REAL(4), POINTER :: XG(:,:) - REAL(4), POINTER :: YG(:,:) - REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX - -! Local parameters - TYPE(T_GSU) :: GSU - INTEGER :: LB(2), UB(2) + ! + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/1A,1A/)') 'W3BBOX_GSU ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Set bounding box + ! + XMIN = GSU%PTR%XMIN + YMIN = GSU%PTR%YMIN + XMAX = GSU%PTR%XMAX + YMAX = GSU%PTR%YMAX + + END SUBROUTINE W3BBOX_GSU + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3BBOX_GRD_PTR_R4( IJG, LLG, ICLO, XG, YG, & + XMIN, YMIN, XMAX, YMAX ) + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + REAL(4), POINTER :: XG(:,:) + REAL(4), POINTER :: YG(:,:) + REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX + + ! Local parameters + TYPE(T_GSU) :: GSU + INTEGER :: LB(2), UB(2) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3BBOX_GRD_PTR_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3BBOX_GRD_PTR_R4') #endif -! -! -------------------------------------------------------------------- / -! 1. Set bounding box -! - LB(1) = LBOUND(XG,1); LB(2) = LBOUND(XG,2) - UB(1) = UBOUND(XG,1); UB(2) = UBOUND(XG,2) - GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4=XG, YG4=YG, BBOX_ONLY=.TRUE. ) - XMIN = GSU%PTR%XMIN - YMIN = GSU%PTR%YMIN - XMAX = GSU%PTR%XMAX - YMAX = GSU%PTR%YMAX - CALL W3GSUD( GSU ) - - END SUBROUTINE W3BBOX_GRD_PTR_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3BBOX_GRD_PTR_R8( IJG, LLG, ICLO, XG, YG, & - XMIN, YMIN, XMAX, YMAX ) - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - REAL(8), POINTER :: XG(:,:) - REAL(8), POINTER :: YG(:,:) - REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX - -! Local parameters - TYPE(T_GSU) :: GSU - INTEGER :: LB(2), UB(2) + ! + ! -------------------------------------------------------------------- / + ! 1. Set bounding box + ! + LB(1) = LBOUND(XG,1); LB(2) = LBOUND(XG,2) + UB(1) = UBOUND(XG,1); UB(2) = UBOUND(XG,2) + GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4=XG, YG4=YG, BBOX_ONLY=.TRUE. ) + XMIN = GSU%PTR%XMIN + YMIN = GSU%PTR%YMIN + XMAX = GSU%PTR%XMAX + YMAX = GSU%PTR%YMAX + CALL W3GSUD( GSU ) + + END SUBROUTINE W3BBOX_GRD_PTR_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3BBOX_GRD_PTR_R8( IJG, LLG, ICLO, XG, YG, & + XMIN, YMIN, XMAX, YMAX ) + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + REAL(8), POINTER :: XG(:,:) + REAL(8), POINTER :: YG(:,:) + REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX + + ! Local parameters + TYPE(T_GSU) :: GSU + INTEGER :: LB(2), UB(2) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3BBOX_GRD_PTR_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3BBOX_GRD_PTR_R8') #endif -! -! -------------------------------------------------------------------- / -! 1. Set bounding box -! - LB(1) = LBOUND(XG,1); LB(2) = LBOUND(XG,2) - UB(1) = UBOUND(XG,1); UB(2) = UBOUND(XG,2) - GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG8=XG, YG8=YG, BBOX_ONLY=.TRUE. ) - XMIN = GSU%PTR%XMIN - YMIN = GSU%PTR%YMIN - XMAX = GSU%PTR%XMAX - YMAX = GSU%PTR%YMAX - CALL W3GSUD( GSU ) - - END SUBROUTINE W3BBOX_GRD_PTR_R8 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3BBOX_GRD_TGT_R4( IJG, LLG, ICLO, LB, UB, XG, YG, & - XMIN, YMIN, XMAX, YMAX ) - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - INTEGER, INTENT(IN) :: LB(2), UB(2) - REAL(4), TARGET :: XG(LB(1):UB(1),LB(2):UB(2)) - REAL(4), TARGET :: YG(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX - -! Local parameters - TYPE(T_GSU) :: GSU + ! + ! -------------------------------------------------------------------- / + ! 1. Set bounding box + ! + LB(1) = LBOUND(XG,1); LB(2) = LBOUND(XG,2) + UB(1) = UBOUND(XG,1); UB(2) = UBOUND(XG,2) + GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG8=XG, YG8=YG, BBOX_ONLY=.TRUE. ) + XMIN = GSU%PTR%XMIN + YMIN = GSU%PTR%YMIN + XMAX = GSU%PTR%XMAX + YMAX = GSU%PTR%YMAX + CALL W3GSUD( GSU ) + + END SUBROUTINE W3BBOX_GRD_PTR_R8 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3BBOX_GRD_TGT_R4( IJG, LLG, ICLO, LB, UB, XG, YG, & + XMIN, YMIN, XMAX, YMAX ) + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + INTEGER, INTENT(IN) :: LB(2), UB(2) + REAL(4), TARGET :: XG(LB(1):UB(1),LB(2):UB(2)) + REAL(4), TARGET :: YG(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX + + ! Local parameters + TYPE(T_GSU) :: GSU #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3BBOX_GRD_TGT_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3BBOX_GRD_TGT_R4') #endif -! -! -------------------------------------------------------------------- / -! 1. Set bounding box -! - GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4=XG, YG4=YG, BBOX_ONLY=.TRUE. ) - XMIN = GSU%PTR%XMIN - YMIN = GSU%PTR%YMIN - XMAX = GSU%PTR%XMAX - YMAX = GSU%PTR%YMAX - CALL W3GSUD( GSU ) - - END SUBROUTINE W3BBOX_GRD_TGT_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3BBOX_GRD_TGT_R8( IJG, LLG, ICLO, LB, UB, XG, YG, & - XMIN, YMIN, XMAX, YMAX ) - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - INTEGER, INTENT(IN) :: LB(2), UB(2) - REAL(8), TARGET :: XG(LB(1):UB(1),LB(2):UB(2)) - REAL(8), TARGET :: YG(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX - -! Local parameters - TYPE(T_GSU) :: GSU + ! + ! -------------------------------------------------------------------- / + ! 1. Set bounding box + ! + GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4=XG, YG4=YG, BBOX_ONLY=.TRUE. ) + XMIN = GSU%PTR%XMIN + YMIN = GSU%PTR%YMIN + XMAX = GSU%PTR%XMAX + YMAX = GSU%PTR%YMAX + CALL W3GSUD( GSU ) + + END SUBROUTINE W3BBOX_GRD_TGT_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3BBOX_GRD_TGT_R8( IJG, LLG, ICLO, LB, UB, XG, YG, & + XMIN, YMIN, XMAX, YMAX ) + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + INTEGER, INTENT(IN) :: LB(2), UB(2) + REAL(8), TARGET :: XG(LB(1):UB(1),LB(2):UB(2)) + REAL(8), TARGET :: YG(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX + + ! Local parameters + TYPE(T_GSU) :: GSU #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3BBOX_GRD_TGT_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3BBOX_GRD_TGT_R8') #endif -! -! -------------------------------------------------------------------- / -! 1. Set bounding box -! - GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG8=XG, YG8=YG, BBOX_ONLY=.TRUE. ) - XMIN = GSU%PTR%XMIN - YMIN = GSU%PTR%YMIN - XMAX = GSU%PTR%XMAX - YMAX = GSU%PTR%YMAX - CALL W3GSUD( GSU ) - - END SUBROUTINE W3BBOX_GRD_TGT_R8 -!/ -!/ End of W3BBOX ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3GFCL( GSU, XT, YT, IS, JS, XS, YS, & -!/ POLE, EPS, FNCL, DEBUG ) RESULT(INGRID) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Find cell in grid, associated with the input grid-search-utility -! object (GSU), that encloses the target point (xt,yt). -! -! 2. Method : -! -! 3. Parameters : -! -! Return parameter -! ---------------------------------------------------------------- -! INGRID Log. O Logical flag indicating if target point lies -! within the source grid domain. -! ---------------------------------------------------------------- -! -! Parameter list -! ---------------------------------------------------------------- -! GSU Type I Grid-search-utility object. -! XT Real I X-coordinate of target point. -! YT Real I Y-coordinate of target point. -! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. -! XS,YS R.A. O (X,Y) coord. of vertices of enclosing grid cell. -! POLE Log. O OPTIONAL logical flag to indicate whether or not -! the enclosing grid cell includes a pole. -! EPS Real I OPTIONAL small non-zero tolerance used to check if -! target point is in domain and for point coincidence. -! FNCL Log. I OPTIONAL logical flag to enable finding cell that -! is shortest distance from target point when the -! target point is not located in the source grid. -! Default is FALSE. -! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. -! Default is FALSE. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! - Check on previous creation of grid-search-utility object. -! -! 7. Remarks : -! -! - The target point coordinates may be modified by this routine. -! - The target point longitude will be shifted to the source grid -! longitudinal range. -! - If enclosing cell includes a branch cut, then the coordinates of -! of the cell vertices AND the target point will be adjusted so -! that the branch cut is shifted 180 degrees. -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Test input -! 2. Initialize search -! 3. Search for enclosing cell in central and nearest nbr buckets -! 4. If not in grid and find nearest cell is enabled, then -! identify cell closest to target point -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GFCL_R4( GSU, XT, YT, IS, JS, XS, YS, & - POLE, EPS, FNCL, DEBUG ) RESULT(INGRID) -! Single precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(4), INTENT(INOUT) :: XT - REAL(4), INTENT(INOUT) :: YT - INTEGER, INTENT(INOUT) :: IS(4), JS(4) - REAL(4), INTENT(INOUT) :: XS(4), YS(4) - LOGICAL, INTENT(OUT),OPTIONAL :: POLE - REAL(4), INTENT(IN), OPTIONAL :: EPS - LOGICAL, INTENT(IN), OPTIONAL :: FNCL - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: XT8, YT8, XS8(4), YS8(4), EPS8 + ! + ! -------------------------------------------------------------------- / + ! 1. Set bounding box + ! + GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG8=XG, YG8=YG, BBOX_ONLY=.TRUE. ) + XMIN = GSU%PTR%XMIN + YMIN = GSU%PTR%YMIN + XMAX = GSU%PTR%XMAX + YMAX = GSU%PTR%YMAX + CALL W3GSUD( GSU ) + + END SUBROUTINE W3BBOX_GRD_TGT_R8 + !/ + !/ End of W3BBOX ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3GFCL( GSU, XT, YT, IS, JS, XS, YS, & + !/ POLE, EPS, FNCL, DEBUG ) RESULT(INGRID) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Find cell in grid, associated with the input grid-search-utility + ! object (GSU), that encloses the target point (xt,yt). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Return parameter + ! ---------------------------------------------------------------- + ! INGRID Log. O Logical flag indicating if target point lies + ! within the source grid domain. + ! ---------------------------------------------------------------- + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! GSU Type I Grid-search-utility object. + ! XT Real I X-coordinate of target point. + ! YT Real I Y-coordinate of target point. + ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. + ! XS,YS R.A. O (X,Y) coord. of vertices of enclosing grid cell. + ! POLE Log. O OPTIONAL logical flag to indicate whether or not + ! the enclosing grid cell includes a pole. + ! EPS Real I OPTIONAL small non-zero tolerance used to check if + ! target point is in domain and for point coincidence. + ! FNCL Log. I OPTIONAL logical flag to enable finding cell that + ! is shortest distance from target point when the + ! target point is not located in the source grid. + ! Default is FALSE. + ! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. + ! Default is FALSE. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! - Check on previous creation of grid-search-utility object. + ! + ! 7. Remarks : + ! + ! - The target point coordinates may be modified by this routine. + ! - The target point longitude will be shifted to the source grid + ! longitudinal range. + ! - If enclosing cell includes a branch cut, then the coordinates of + ! of the cell vertices AND the target point will be adjusted so + ! that the branch cut is shifted 180 degrees. + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Test input + ! 2. Initialize search + ! 3. Search for enclosing cell in central and nearest nbr buckets + ! 4. If not in grid and find nearest cell is enabled, then + ! identify cell closest to target point + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GFCL_R4( GSU, XT, YT, IS, JS, XS, YS, & + POLE, EPS, FNCL, DEBUG ) RESULT(INGRID) + ! Single precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(4), INTENT(INOUT) :: XT + REAL(4), INTENT(INOUT) :: YT + INTEGER, INTENT(INOUT) :: IS(4), JS(4) + REAL(4), INTENT(INOUT) :: XS(4), YS(4) + LOGICAL, INTENT(OUT),OPTIONAL :: POLE + REAL(4), INTENT(IN), OPTIONAL :: EPS + LOGICAL, INTENT(IN), OPTIONAL :: FNCL + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: XT8, YT8, XS8(4), YS8(4), EPS8 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GFCL_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFCL_R4') #endif -! -!-----set inputs - XT8 = XT; YT8 = YT; - IF ( PRESENT(EPS) ) THEN - EPS8 = EPS - ELSE - EPS8 = EPS_DEFAULT - END IF -! -!-----call double precision method - INGRID = W3GFCL( GSU, XT8, YT8, IS, JS, XS8, YS8, POLE=POLE, & - EPS=EPS8, FNCL=FNCL, DEBUG=DEBUG ) -! -!-----set outputs - XT = XT8; YT = YT8; - XS = XS8; YS = YS8; - - END FUNCTION W3GFCL_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GFCL_R8( GSU, XT, YT, IS, JS, XS, YS, & - POLE, EPS, FNCL, DEBUG ) RESULT(INGRID) -! Double precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(8), INTENT(INOUT) :: XT - REAL(8), INTENT(INOUT) :: YT - INTEGER, INTENT(INOUT) :: IS(4), JS(4) - REAL(8), INTENT(INOUT) :: XS(4), YS(4) - LOGICAL, INTENT(OUT),OPTIONAL :: POLE - REAL(8), INTENT(IN), OPTIONAL :: EPS - LOGICAL, INTENT(IN), OPTIONAL :: FNCL - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: LEPS - LOGICAL :: LDBG, LPLC, LFNCL, INCELL - INTEGER :: I, J, K, L, N, IB, JB - LOGICAL :: IJG, LLG, LCLO, L360 - INTEGER :: ICLO, GKIND - INTEGER :: LBX, LBY, UBX, UBY, NX, NY - REAL(4), POINTER :: XG4(:,:), YG4(:,:) - REAL(8), POINTER :: XG8(:,:), YG8(:,:) - INTEGER :: NBX, NBY - REAL(8) :: DXB, DYB, XMIN, XMAX, YMIN, YMAX - TYPE(T_BKT), POINTER :: B(:,:) - TYPE(T_NNS), POINTER :: NNB - LOGICAL :: FOUND - INTEGER :: NLEVEL, LVL, LVL1, N1, IB0, JB0, IB1, JB1, K1 - INTEGER :: IS1(4), JS1(4) - REAL(8) :: XS1(4), YS1(4), XSM, YSM, DD, DD1 + ! + !-----set inputs + XT8 = XT; YT8 = YT; + IF ( PRESENT(EPS) ) THEN + EPS8 = EPS + ELSE + EPS8 = EPS_DEFAULT + END IF + ! + !-----call double precision method + INGRID = W3GFCL( GSU, XT8, YT8, IS, JS, XS8, YS8, POLE=POLE, & + EPS=EPS8, FNCL=FNCL, DEBUG=DEBUG ) + ! + !-----set outputs + XT = XT8; YT = YT8; + XS = XS8; YS = YS8; + + END FUNCTION W3GFCL_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GFCL_R8( GSU, XT, YT, IS, JS, XS, YS, & + POLE, EPS, FNCL, DEBUG ) RESULT(INGRID) + ! Double precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(8), INTENT(INOUT) :: XT + REAL(8), INTENT(INOUT) :: YT + INTEGER, INTENT(INOUT) :: IS(4), JS(4) + REAL(8), INTENT(INOUT) :: XS(4), YS(4) + LOGICAL, INTENT(OUT),OPTIONAL :: POLE + REAL(8), INTENT(IN), OPTIONAL :: EPS + LOGICAL, INTENT(IN), OPTIONAL :: FNCL + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: LEPS + LOGICAL :: LDBG, LPLC, LFNCL, INCELL + INTEGER :: I, J, K, L, N, IB, JB + LOGICAL :: IJG, LLG, LCLO, L360 + INTEGER :: ICLO, GKIND + INTEGER :: LBX, LBY, UBX, UBY, NX, NY + REAL(4), POINTER :: XG4(:,:), YG4(:,:) + REAL(8), POINTER :: XG8(:,:), YG8(:,:) + INTEGER :: NBX, NBY + REAL(8) :: DXB, DYB, XMIN, XMAX, YMIN, YMAX + TYPE(T_BKT), POINTER :: B(:,:) + TYPE(T_NNS), POINTER :: NNB + LOGICAL :: FOUND + INTEGER :: NLEVEL, LVL, LVL1, N1, IB0, JB0, IB1, JB1, K1 + INTEGER :: IS1(4), JS1(4) + REAL(8) :: XS1(4), YS1(4), XSM, YSM, DD, DD1 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GFCL_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFCL_R8') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input -! - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/2A/)') 'W3GFCL_R8 ERROR -- ', & - 'grid search utility object not created' - CALL EXTCDE (1) - END IF - IF ( PRESENT(EPS) ) THEN - IF ( EPS .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GFCL_R8 ERROR -- ', & - 'EPS parameter must be >= 0' - CALL EXTCDE (1) - END IF - LEPS = EPS - ELSE - LEPS = EPS_DEFAULT - END IF -! -! -------------------------------------------------------------------- / -! 2. Initialize search -! - IF ( PRESENT(FNCL) ) THEN - LFNCL = FNCL - ELSE - LFNCL = .FALSE. - END IF - IF ( PRESENT(DEBUG) ) THEN - LDBG = DEBUG - ELSE - LDBG = .FALSE. - END IF -! -! Local pointers to grid search utility object data - IJG = GSU%PTR%IJG - LLG = GSU%PTR%LLG - ICLO = GSU%PTR%ICLO - LCLO = GSU%PTR%LCLO - L360 = GSU%PTR%L360 - GKIND = GSU%PTR%GKIND - LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; - UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; - NX = GSU%PTR%NX; NY = GSU%PTR%NY; - IF ( GKIND.EQ.4 ) THEN - XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; + ! + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/2A/)') 'W3GFCL_R8 ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + IF ( PRESENT(EPS) ) THEN + IF ( EPS .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GFCL_R8 ERROR -- ', & + 'EPS parameter must be >= 0' + CALL EXTCDE (1) + END IF + LEPS = EPS + ELSE + LEPS = EPS_DEFAULT + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Initialize search + ! + IF ( PRESENT(FNCL) ) THEN + LFNCL = FNCL + ELSE + LFNCL = .FALSE. + END IF + IF ( PRESENT(DEBUG) ) THEN + LDBG = DEBUG + ELSE + LDBG = .FALSE. + END IF + ! + ! Local pointers to grid search utility object data + IJG = GSU%PTR%IJG + LLG = GSU%PTR%LLG + ICLO = GSU%PTR%ICLO + LCLO = GSU%PTR%LCLO + L360 = GSU%PTR%L360 + GKIND = GSU%PTR%GKIND + LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; + UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; + NX = GSU%PTR%NX; NY = GSU%PTR%NY; + IF ( GKIND.EQ.4 ) THEN + XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; + ELSE + XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; + END IF + NBX = GSU%PTR%NBX; NBY = GSU%PTR%NBY; + DXB = GSU%PTR%DXB; DYB = GSU%PTR%DYB; + XMIN = GSU%PTR%XMIN; YMIN = GSU%PTR%YMIN; + XMAX = GSU%PTR%XMAX; YMAX = GSU%PTR%YMAX; + B => GSU%PTR%B + NNB => GSU%PTR%NNB + ! + INGRID = .FALSE. + ! + ! Shift target to appropriate longitude range + IF ( LLG ) THEN + XT = MOD(XT,REAL(D360,8)) + IF ( LCLO .OR. L360 ) THEN + IF ( XT.LT.ZERO ) XT = XT + D360 + ELSE + IF ( XT.GT.D180 ) XT = XT - D360 + END IF + END IF + IF ( LDBG ) WRITE(*,'(/A,2E24.16)') 'W3GFCL_R8 - TARGET POINT:',XT,YT + ! + ! Target point must lie within search domain + IF ( .NOT.LFNCL ) THEN + IF ( XT.LT.XMIN-LEPS .OR. XT.GT.XMAX+LEPS .OR. & + YT.LT.YMIN-LEPS .OR. YT.GT.YMAX+LEPS ) THEN + IF ( LDBG ) WRITE(*,'(A)') & + 'W3GFCL_R8 - TARGET POINT OUTSIDE SEARCH DOMAIN' + RETURN + END IF + END IF + ! + ! Search bucket that contains the target point. + IB = MAX(INT((XT-XMIN)/DXB)+1,1); IF ( .NOT.LCLO ) IB = MIN(IB,NBX); + JB = MAX(INT((YT-YMIN)/DYB)+1,1); JB = MIN(JB,NBY); + ! + ! -------------------------------------------------------------------- / + ! 3. Search for enclosing cell in bucket + ! + IF ( LDBG ) & + WRITE(*,'(A,3I6,4E24.16)') & + 'W3GFCL_R8 - BUCKET SEARCH:',IB,JB,B(JB,IB)%N, & + XMIN+(IB-1)*DXB,YMIN+(JB-1)*DYB,XMIN+IB*DXB,YMIN+JB*DYB + CELL_LOOP: DO K=1,B(JB,IB)%N + !---------setup cell corner indices + IS(1) = B(JB,IB)%I(K) ; JS(1) = B(JB,IB)%J(K) ; + IS(2) = B(JB,IB)%I(K)+1; JS(2) = B(JB,IB)%J(K) ; + IS(3) = B(JB,IB)%I(K)+1; JS(3) = B(JB,IB)%J(K)+1; + IS(4) = B(JB,IB)%I(K) ; JS(4) = B(JB,IB)%J(K)+1; + !---------setup cell corner coordinates and adjust for periodicity + DO L=1,4 + !-------------apply index closure + IF ( MOD(ICLO,2).EQ.0 ) & + IS(L) = LBX + MOD(NX - 1 + MOD(IS(L) - LBX + 1, NX), NX) + IF ( MOD(ICLO,3).EQ.0 ) & + JS(L) = LBY + MOD(NY - 1 + MOD(JS(L) - LBY + 1, NY), NY) + IF ( ICLO.EQ.ICLO_TRPL .AND. JS(L).GT.UBY ) THEN + IS(L) = UBX + LBX - IS(L) + JS(L) = 2*UBY - JS(L) + 1 + END IF + !-------------copy cell vertex coordinates into local variables + IF ( IJG ) THEN + IF ( GKIND.EQ.4 ) THEN + XS(L) = XG4(IS(L),JS(L)); YS(L) = YG4(IS(L),JS(L)); + ELSE + XS(L) = XG8(IS(L),JS(L)); YS(L) = YG8(IS(L),JS(L)); + END IF ELSE - XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; + IF ( GKIND.EQ.4 ) THEN + XS(L) = XG4(JS(L),IS(L)); YS(L) = YG4(JS(L),IS(L)); + ELSE + XS(L) = XG8(JS(L),IS(L)); YS(L) = YG8(JS(L),IS(L)); + END IF END IF - NBX = GSU%PTR%NBX; NBY = GSU%PTR%NBY; - DXB = GSU%PTR%DXB; DYB = GSU%PTR%DYB; - XMIN = GSU%PTR%XMIN; YMIN = GSU%PTR%YMIN; - XMAX = GSU%PTR%XMAX; YMAX = GSU%PTR%YMAX; - B => GSU%PTR%B - NNB => GSU%PTR%NNB -! - INGRID = .FALSE. -! -! Shift target to appropriate longitude range - IF ( LLG ) THEN - XT = MOD(XT,REAL(D360,8)) + !-------------shift longitudes to same range + IF ( LLG ) THEN + XS(L) = MOD(XS(L),REAL(D360,8)) IF ( LCLO .OR. L360 ) THEN - IF ( XT.LT.ZERO ) XT = XT + D360 - ELSE - IF ( XT.GT.D180 ) XT = XT - D360 - END IF - END IF - IF ( LDBG ) WRITE(*,'(/A,2E24.16)') 'W3GFCL_R8 - TARGET POINT:',XT,YT -! -! Target point must lie within search domain - IF ( .NOT.LFNCL ) THEN - IF ( XT.LT.XMIN-LEPS .OR. XT.GT.XMAX+LEPS .OR. & - YT.LT.YMIN-LEPS .OR. YT.GT.YMAX+LEPS ) THEN - IF ( LDBG ) WRITE(*,'(A)') & - 'W3GFCL_R8 - TARGET POINT OUTSIDE SEARCH DOMAIN' - RETURN + IF ( XS(L).LT.ZERO ) XS(L) = XS(L) + D360 + ELSE + IF ( XS(L).GT.D180 ) XS(L) = XS(L) - D360 END IF END IF -! -! Search bucket that contains the target point. - IB = MAX(INT((XT-XMIN)/DXB)+1,1); IF ( .NOT.LCLO ) IB = MIN(IB,NBX); - JB = MAX(INT((YT-YMIN)/DYB)+1,1); JB = MIN(JB,NBY); -! -! -------------------------------------------------------------------- / -! 3. Search for enclosing cell in bucket -! + END DO !L IF ( LDBG ) & - WRITE(*,'(A,3I6,4E24.16)') & - 'W3GFCL_R8 - BUCKET SEARCH:',IB,JB,B(JB,IB)%N, & - XMIN+(IB-1)*DXB,YMIN+(JB-1)*DYB,XMIN+IB*DXB,YMIN+JB*DYB - CELL_LOOP: DO K=1,B(JB,IB)%N -!---------setup cell corner indices + WRITE(*,'(A,3I6,4(/A,1I1,A,2I6,2E24.16))') & + 'W3GFCL_R8 - CHECK CELL:',IB,JB,K, & + (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) + !---------check if point is enclosed in cell defined by xs(1:4) & ys(1:4) + INCELL = W3CKCL(LLG,XT,YT,4,XS,YS,LPLC,LEPS,LDBG) + IF ( LDBG ) WRITE(*,'(A,1L2)')'W3GFCL_R8 - INCELL:',INCELL + IF ( INCELL ) THEN + !-------------exit search + IF ( LDBG ) & + WRITE(*,'(A,3I6,4(2I6))') & + 'W3GFCL_R8 - ENCLOSING CELL:',IB,JB,K,(IS(L),JS(L),L=1,4) + IF ( PRESENT(POLE) ) POLE = LPLC + INGRID = .TRUE. + EXIT CELL_LOOP + END IF !point in cell + END DO CELL_LOOP + IF ( INGRID ) RETURN + IF ( .NOT.LFNCL ) RETURN + ! + ! -------------------------------------------------------------------- / + ! 4. If not in grid, then identify cell closest to target point + ! + !-----find closest cell by searching nearest-neighbor buckets + NLEVEL = 0 + DD1 = HUGE(XT) + IB0 = IB; JB0 = JB; + IB1 = IB; JB1 = JB; + NNB = W3NNSC(NINT(HALF*MAX(NBX,NBY))) + IF ( LDBG ) WRITE(*,'(A,3I6)') & + 'W3GFCL_R8 - CLOSEST CELL SEARCH:',IB0,JB0,NNB%NLVL + LEVEL_LOOP: DO LVL=0,NNB%NLVL + FOUND = .FALSE. + NNBR_LOOP: DO N=NNB%N1(LVL),NNB%N2(LVL) + IB = IB0 + NNB%DI(N); JB = JB0 + NNB%DJ(N); + IF ( IB.LT.1 .OR. IB.GT.NBX ) CYCLE NNBR_LOOP + IF ( JB.LT.1 .OR. JB.GT.NBY ) CYCLE NNBR_LOOP + IF ( LDBG ) WRITE(*,'(A,5I6)') & + 'W3GFCL_R8 - CHECK BUCKET:',LVL,N,IB,JB,B(JB,IB)%N + CELL_LOOP2: DO K=1,B(JB,IB)%N + !-----------------setup cell corner indices IS(1) = B(JB,IB)%I(K) ; JS(1) = B(JB,IB)%J(K) ; IS(2) = B(JB,IB)%I(K)+1; JS(2) = B(JB,IB)%J(K) ; IS(3) = B(JB,IB)%I(K)+1; JS(3) = B(JB,IB)%J(K)+1; IS(4) = B(JB,IB)%I(K) ; JS(4) = B(JB,IB)%J(K)+1; -!---------setup cell corner coordinates and adjust for periodicity + !-----------------setup cell corner coordinates and adjust for periodicity DO L=1,4 -!-------------apply index closure - IF ( MOD(ICLO,2).EQ.0 ) & - IS(L) = LBX + MOD(NX - 1 + MOD(IS(L) - LBX + 1, NX), NX) - IF ( MOD(ICLO,3).EQ.0 ) & - JS(L) = LBY + MOD(NY - 1 + MOD(JS(L) - LBY + 1, NY), NY) - IF ( ICLO.EQ.ICLO_TRPL .AND. JS(L).GT.UBY ) THEN - IS(L) = UBX + LBX - IS(L) - JS(L) = 2*UBY - JS(L) + 1 - END IF -!-------------copy cell vertex coordinates into local variables - IF ( IJG ) THEN - IF ( GKIND.EQ.4 ) THEN - XS(L) = XG4(IS(L),JS(L)); YS(L) = YG4(IS(L),JS(L)); - ELSE - XS(L) = XG8(IS(L),JS(L)); YS(L) = YG8(IS(L),JS(L)); - END IF - ELSE - IF ( GKIND.EQ.4 ) THEN - XS(L) = XG4(JS(L),IS(L)); YS(L) = YG4(JS(L),IS(L)); - ELSE - XS(L) = XG8(JS(L),IS(L)); YS(L) = YG8(JS(L),IS(L)); - END IF - END IF -!-------------shift longitudes to same range - IF ( LLG ) THEN - XS(L) = MOD(XS(L),REAL(D360,8)) - IF ( LCLO .OR. L360 ) THEN - IF ( XS(L).LT.ZERO ) XS(L) = XS(L) + D360 - ELSE - IF ( XS(L).GT.D180 ) XS(L) = XS(L) - D360 - END IF - END IF - END DO !L + !---------------------apply index closure + IF ( MOD(ICLO,2).EQ.0 ) & + IS(L) = LBX + MOD(NX - 1 + MOD(IS(L) - LBX + 1, NX), NX) + IF ( MOD(ICLO,3).EQ.0 ) & + JS(L) = LBY + MOD(NY - 1 + MOD(JS(L) - LBY + 1, NY), NY) + IF ( ICLO.EQ.ICLO_TRPL .AND. JS(L).GT.UBY ) THEN + IS(L) = UBX + LBX - IS(L) + JS(L) = 2*UBY - JS(L) + 1 + END IF + !---------------------copy cell vertex coordinates into local variables + IF ( IJG ) THEN + IF ( GKIND.EQ.4 ) THEN + XS(L) = XG4(IS(L),JS(L)); YS(L) = YG4(IS(L),JS(L)); + ELSE + XS(L) = XG8(IS(L),JS(L)); YS(L) = YG8(IS(L),JS(L)); + END IF + ELSE + IF ( GKIND.EQ.4 ) THEN + XS(L) = XG4(JS(L),IS(L)); YS(L) = YG4(JS(L),IS(L)); + ELSE + XS(L) = XG8(JS(L),IS(L)); YS(L) = YG8(JS(L),IS(L)); + END IF + END IF + !---------------------shift longitudes to same range + IF ( LLG ) THEN + XS(L) = MOD(XS(L),REAL(D360,8)) + IF ( LCLO .OR. L360 ) THEN + IF ( XS(L).LT.ZERO ) XS(L) = XS(L) + D360 + ELSE + IF ( XS(L).GT.D180 ) XS(L) = XS(L) - D360 + END IF + END IF + END DO !L + !-----------------check cell distance from target point + XSM = SUM(XS)/FOUR; YSM = SUM(YS)/FOUR; + DD = W3DIST(LLG,XT,YT,XSM,YSM) IF ( LDBG ) & - WRITE(*,'(A,3I6,4(/A,1I1,A,2I6,2E24.16))') & - 'W3GFCL_R8 - CHECK CELL:',IB,JB,K, & - (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) -!---------check if point is enclosed in cell defined by xs(1:4) & ys(1:4) - INCELL = W3CKCL(LLG,XT,YT,4,XS,YS,LPLC,LEPS,LDBG) - IF ( LDBG ) WRITE(*,'(A,1L2)')'W3GFCL_R8 - INCELL:',INCELL - IF ( INCELL ) THEN -!-------------exit search - IF ( LDBG ) & - WRITE(*,'(A,3I6,4(2I6))') & - 'W3GFCL_R8 - ENCLOSING CELL:',IB,JB,K,(IS(L),JS(L),L=1,4) - IF ( PRESENT(POLE) ) POLE = LPLC - INGRID = .TRUE. - EXIT CELL_LOOP - END IF !point in cell - END DO CELL_LOOP - IF ( INGRID ) RETURN - IF ( .NOT.LFNCL ) RETURN -! -! -------------------------------------------------------------------- / -! 4. If not in grid, then identify cell closest to target point -! -!-----find closest cell by searching nearest-neighbor buckets - NLEVEL = 0 - DD1 = HUGE(XT) - IB0 = IB; JB0 = JB; - IB1 = IB; JB1 = JB; - NNB = W3NNSC(NINT(HALF*MAX(NBX,NBY))) - IF ( LDBG ) WRITE(*,'(A,3I6)') & - 'W3GFCL_R8 - CLOSEST CELL SEARCH:',IB0,JB0,NNB%NLVL - LEVEL_LOOP: DO LVL=0,NNB%NLVL - FOUND = .FALSE. - NNBR_LOOP: DO N=NNB%N1(LVL),NNB%N2(LVL) - IB = IB0 + NNB%DI(N); JB = JB0 + NNB%DJ(N); - IF ( IB.LT.1 .OR. IB.GT.NBX ) CYCLE NNBR_LOOP - IF ( JB.LT.1 .OR. JB.GT.NBY ) CYCLE NNBR_LOOP - IF ( LDBG ) WRITE(*,'(A,5I6)') & - 'W3GFCL_R8 - CHECK BUCKET:',LVL,N,IB,JB,B(JB,IB)%N - CELL_LOOP2: DO K=1,B(JB,IB)%N -!-----------------setup cell corner indices - IS(1) = B(JB,IB)%I(K) ; JS(1) = B(JB,IB)%J(K) ; - IS(2) = B(JB,IB)%I(K)+1; JS(2) = B(JB,IB)%J(K) ; - IS(3) = B(JB,IB)%I(K)+1; JS(3) = B(JB,IB)%J(K)+1; - IS(4) = B(JB,IB)%I(K) ; JS(4) = B(JB,IB)%J(K)+1; -!-----------------setup cell corner coordinates and adjust for periodicity - DO L=1,4 -!---------------------apply index closure - IF ( MOD(ICLO,2).EQ.0 ) & - IS(L) = LBX + MOD(NX - 1 + MOD(IS(L) - LBX + 1, NX), NX) - IF ( MOD(ICLO,3).EQ.0 ) & - JS(L) = LBY + MOD(NY - 1 + MOD(JS(L) - LBY + 1, NY), NY) - IF ( ICLO.EQ.ICLO_TRPL .AND. JS(L).GT.UBY ) THEN - IS(L) = UBX + LBX - IS(L) - JS(L) = 2*UBY - JS(L) + 1 - END IF -!---------------------copy cell vertex coordinates into local variables - IF ( IJG ) THEN - IF ( GKIND.EQ.4 ) THEN - XS(L) = XG4(IS(L),JS(L)); YS(L) = YG4(IS(L),JS(L)); - ELSE - XS(L) = XG8(IS(L),JS(L)); YS(L) = YG8(IS(L),JS(L)); - END IF - ELSE - IF ( GKIND.EQ.4 ) THEN - XS(L) = XG4(JS(L),IS(L)); YS(L) = YG4(JS(L),IS(L)); - ELSE - XS(L) = XG8(JS(L),IS(L)); YS(L) = YG8(JS(L),IS(L)); - END IF - END IF -!---------------------shift longitudes to same range - IF ( LLG ) THEN - XS(L) = MOD(XS(L),REAL(D360,8)) - IF ( LCLO .OR. L360 ) THEN - IF ( XS(L).LT.ZERO ) XS(L) = XS(L) + D360 - ELSE - IF ( XS(L).GT.D180 ) XS(L) = XS(L) - D360 - END IF - END IF - END DO !L -!-----------------check cell distance from target point - XSM = SUM(XS)/FOUR; YSM = SUM(YS)/FOUR; - DD = W3DIST(LLG,XT,YT,XSM,YSM) - IF ( LDBG ) & - WRITE(*,'(A,5I6,3E24.16,4(/A,1I1,A,2I6,2E24.16))') & - 'W3GFCL_R8 - CHECK CELL:',LVL,N,IB,JB,K,XSM,YSM,DD, & - (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) - IF (DD.LT.DD1) THEN - LVL1 = LVL - N1 = N - IB1 = IB - JB1 = JB - K1 = K - DD1 = DD - IS1(:) = IS(:) - JS1(:) = JS(:) - XS1(:) = XS(:) - YS1(:) = YS(:) - ENDIF - FOUND = .TRUE. - END DO CELL_LOOP2 - END DO NNBR_LOOP - IF ( FOUND ) NLEVEL = NLEVEL + 1 - IF ( NLEVEL .GE. MAX_FNCL_LEVEL ) EXIT LEVEL_LOOP - END DO LEVEL_LOOP -! -!-----return cell that is shortest distance from target point - IS(:) = IS1(:) - JS(:) = JS1(:) - XS(:) = XS1(:) - YS(:) = YS1(:) - IF ( LDBG ) & - WRITE(*,'(A,5I6,1E24.16,4(/A,1I1,A,2I6,2E24.16))') & - 'W3GFCL_R8 - CLOSEST CELL:',LVL1,N1,IB1,JB1,K1,DD1, & - (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) -! -!-----check if cell includes a pole or branch cut - IF ( LLG ) THEN - N = 0 -!---------count longitudinal branch cut crossings - DO I=1,4 - J = MOD(I,4) + 1 - IF ( ABS(XS(J)-XS(I)) .GT. D180 ) N = N + 1 - END DO -!---------single longitudinal branch cut crossing -! or single vertex at 90 degrees => cell includes pole - LPLC = N.EQ.1 .OR. COUNT(ABS(YS).EQ.D90).EQ.1 - IF ( LPLC .AND. LDBG ) & - WRITE(*,'(A)') 'W3GFCL_R8 - CELL INCLUDES A POLE' - ELSE - LPLC = .FALSE. - END IF - IF ( PRESENT(POLE) ) POLE = LPLC - - END FUNCTION W3GFCL_R8 -!/ -!/ End of W3GFCL ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3GFCD_R4( GSU, XT, YT, IS, JS, XS, YS, POLE, EPS, DEBUG ) & -!/ RESULT(INGRID) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Find cell in grid, associated with the input grid-search-utility -! object (GSU), that encloses the target point (xt,yt), using direct -! grid search (i.e., no bucket search). -! -! 2. Method : -! -! 3. Parameters : -! -! Return parameter -! ---------------------------------------------------------------- -! INGRID Log. O Logical flag indicating if target point lies -! within the source grid domain. -! ---------------------------------------------------------------- -! -! Parameter list -! ---------------------------------------------------------------- -! GSU Type I Grid-search-utility object. -! XT Real I X-coordinate of target point. -! YT Real I Y-coordinate of target point. -! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. -! XS,YS R.A. O (X,Y) coord. of vertices of enclosing grid cell. -! POLE Log. O OPTIONAL logical flag to indicate whether or not -! the enclosing grid cell includes a pole. -! EPS Real I OPTIONAL small non-zero tolerance used to check if -! target point is in domain and for point coincidence. -! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. -! Default is FALSE. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! - Check on previous creation of grid-search-utility object. -! -! 7. Remarks : -! -! - The target point coordinates may be modified by this routine. -! - The target point longitude will be shifted to the source grid -! longitudinal range. -! - If enclosing cell includes a branch cut, then the coordinates of -! of the cell vertices AND the target point will be adjusted so -! that the branch cut is shifted 180 degrees. -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Test input -! 2. Initialize search -! 3. Search for enclosing cell -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GFCD_R4( GSU, XT, YT, IS, JS, XS, YS, & - POLE, EPS, DEBUG ) RESULT(INGRID) -! Single precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(4), INTENT(INOUT) :: XT - REAL(4), INTENT(INOUT) :: YT - INTEGER, INTENT(INOUT) :: IS(4), JS(4) - REAL(4), INTENT(INOUT) :: XS(4), YS(4) - LOGICAL, INTENT(OUT),OPTIONAL :: POLE - REAL(4), INTENT(IN), OPTIONAL :: EPS - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: XT8, YT8, XS8(4), YS8(4), EPS8 + WRITE(*,'(A,5I6,3E24.16,4(/A,1I1,A,2I6,2E24.16))') & + 'W3GFCL_R8 - CHECK CELL:',LVL,N,IB,JB,K,XSM,YSM,DD, & + (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) + IF (DD.LT.DD1) THEN + LVL1 = LVL + N1 = N + IB1 = IB + JB1 = JB + K1 = K + DD1 = DD + IS1(:) = IS(:) + JS1(:) = JS(:) + XS1(:) = XS(:) + YS1(:) = YS(:) + ENDIF + FOUND = .TRUE. + END DO CELL_LOOP2 + END DO NNBR_LOOP + IF ( FOUND ) NLEVEL = NLEVEL + 1 + IF ( NLEVEL .GE. MAX_FNCL_LEVEL ) EXIT LEVEL_LOOP + END DO LEVEL_LOOP + ! + !-----return cell that is shortest distance from target point + IS(:) = IS1(:) + JS(:) = JS1(:) + XS(:) = XS1(:) + YS(:) = YS1(:) + IF ( LDBG ) & + WRITE(*,'(A,5I6,1E24.16,4(/A,1I1,A,2I6,2E24.16))') & + 'W3GFCL_R8 - CLOSEST CELL:',LVL1,N1,IB1,JB1,K1,DD1, & + (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) + ! + !-----check if cell includes a pole or branch cut + IF ( LLG ) THEN + N = 0 + !---------count longitudinal branch cut crossings + DO I=1,4 + J = MOD(I,4) + 1 + IF ( ABS(XS(J)-XS(I)) .GT. D180 ) N = N + 1 + END DO + !---------single longitudinal branch cut crossing + ! or single vertex at 90 degrees => cell includes pole + LPLC = N.EQ.1 .OR. COUNT(ABS(YS).EQ.D90).EQ.1 + IF ( LPLC .AND. LDBG ) & + WRITE(*,'(A)') 'W3GFCL_R8 - CELL INCLUDES A POLE' + ELSE + LPLC = .FALSE. + END IF + IF ( PRESENT(POLE) ) POLE = LPLC + + END FUNCTION W3GFCL_R8 + !/ + !/ End of W3GFCL ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3GFCD_R4( GSU, XT, YT, IS, JS, XS, YS, POLE, EPS, DEBUG ) & + !/ RESULT(INGRID) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Find cell in grid, associated with the input grid-search-utility + ! object (GSU), that encloses the target point (xt,yt), using direct + ! grid search (i.e., no bucket search). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Return parameter + ! ---------------------------------------------------------------- + ! INGRID Log. O Logical flag indicating if target point lies + ! within the source grid domain. + ! ---------------------------------------------------------------- + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! GSU Type I Grid-search-utility object. + ! XT Real I X-coordinate of target point. + ! YT Real I Y-coordinate of target point. + ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. + ! XS,YS R.A. O (X,Y) coord. of vertices of enclosing grid cell. + ! POLE Log. O OPTIONAL logical flag to indicate whether or not + ! the enclosing grid cell includes a pole. + ! EPS Real I OPTIONAL small non-zero tolerance used to check if + ! target point is in domain and for point coincidence. + ! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. + ! Default is FALSE. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! - Check on previous creation of grid-search-utility object. + ! + ! 7. Remarks : + ! + ! - The target point coordinates may be modified by this routine. + ! - The target point longitude will be shifted to the source grid + ! longitudinal range. + ! - If enclosing cell includes a branch cut, then the coordinates of + ! of the cell vertices AND the target point will be adjusted so + ! that the branch cut is shifted 180 degrees. + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Test input + ! 2. Initialize search + ! 3. Search for enclosing cell + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GFCD_R4( GSU, XT, YT, IS, JS, XS, YS, & + POLE, EPS, DEBUG ) RESULT(INGRID) + ! Single precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(4), INTENT(INOUT) :: XT + REAL(4), INTENT(INOUT) :: YT + INTEGER, INTENT(INOUT) :: IS(4), JS(4) + REAL(4), INTENT(INOUT) :: XS(4), YS(4) + LOGICAL, INTENT(OUT),OPTIONAL :: POLE + REAL(4), INTENT(IN), OPTIONAL :: EPS + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: XT8, YT8, XS8(4), YS8(4), EPS8 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GFCD_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFCD_R4') #endif -! -!-----set inputs - XT8 = XT; YT8 = YT; - IF ( PRESENT(EPS) ) THEN - EPS8 = EPS - ELSE - EPS8 = EPS_DEFAULT - END IF -! -!-----call double precision method - INGRID = W3GFCD( GSU, XT8, YT8, IS, JS, XS8, YS8, POLE=POLE, & - EPS=EPS8, DEBUG=DEBUG ) -! -!-----set outputs - XT = XT8; YT = YT8; - XS = XS8; YS = YS8; - - END FUNCTION W3GFCD_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GFCD_R8( GSU, XT, YT, IS, JS, XS, YS, & - POLE, EPS, DEBUG ) RESULT(INGRID) -! Double precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(8), INTENT(INOUT) :: XT - REAL(8), INTENT(INOUT) :: YT - INTEGER, INTENT(INOUT) :: IS(4), JS(4) - REAL(8), INTENT(INOUT) :: XS(4), YS(4) - LOGICAL, INTENT(OUT),OPTIONAL :: POLE - REAL(8), INTENT(IN), OPTIONAL :: EPS - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: LEPS - LOGICAL :: LDBG, LPLC - INTEGER :: I, J, L - LOGICAL :: IJG, LLG, LCLO, L360 - INTEGER :: ICLO, GKIND - INTEGER :: LBX, LBY, UBX, UBY, NX, NY - INTEGER :: LXC, LYC, UXC, UYC - REAL(4), POINTER :: XG4(:,:), YG4(:,:) - REAL(8), POINTER :: XG8(:,:), YG8(:,:) + ! + !-----set inputs + XT8 = XT; YT8 = YT; + IF ( PRESENT(EPS) ) THEN + EPS8 = EPS + ELSE + EPS8 = EPS_DEFAULT + END IF + ! + !-----call double precision method + INGRID = W3GFCD( GSU, XT8, YT8, IS, JS, XS8, YS8, POLE=POLE, & + EPS=EPS8, DEBUG=DEBUG ) + ! + !-----set outputs + XT = XT8; YT = YT8; + XS = XS8; YS = YS8; + + END FUNCTION W3GFCD_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GFCD_R8( GSU, XT, YT, IS, JS, XS, YS, & + POLE, EPS, DEBUG ) RESULT(INGRID) + ! Double precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(8), INTENT(INOUT) :: XT + REAL(8), INTENT(INOUT) :: YT + INTEGER, INTENT(INOUT) :: IS(4), JS(4) + REAL(8), INTENT(INOUT) :: XS(4), YS(4) + LOGICAL, INTENT(OUT),OPTIONAL :: POLE + REAL(8), INTENT(IN), OPTIONAL :: EPS + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: LEPS + LOGICAL :: LDBG, LPLC + INTEGER :: I, J, L + LOGICAL :: IJG, LLG, LCLO, L360 + INTEGER :: ICLO, GKIND + INTEGER :: LBX, LBY, UBX, UBY, NX, NY + INTEGER :: LXC, LYC, UXC, UYC + REAL(4), POINTER :: XG4(:,:), YG4(:,:) + REAL(8), POINTER :: XG8(:,:), YG8(:,:) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GFCD_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFCD_R8') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input -! - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/2A/)') 'W3GFCD_R8 ERROR -- ', & - 'grid search utility object not created' - CALL EXTCDE (1) - END IF - IF ( PRESENT(EPS) ) THEN - IF ( EPS .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GFCD_R8 ERROR -- ', & - 'EPS parameter must be >= 0' - CALL EXTCDE (1) + ! + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/2A/)') 'W3GFCD_R8 ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + IF ( PRESENT(EPS) ) THEN + IF ( EPS .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GFCD_R8 ERROR -- ', & + 'EPS parameter must be >= 0' + CALL EXTCDE (1) + END IF + LEPS = EPS + ELSE + LEPS = EPS_DEFAULT + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Initialize search + ! + IF ( PRESENT(DEBUG) ) THEN + LDBG = DEBUG + ELSE + LDBG = .FALSE. + END IF + ! + ! Local pointers to grid search utility object data + IJG = GSU%PTR%IJG + LLG = GSU%PTR%LLG + ICLO = GSU%PTR%ICLO + LCLO = GSU%PTR%LCLO + L360 = GSU%PTR%L360 + GKIND = GSU%PTR%GKIND + LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; + UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; + NX = GSU%PTR%NX; NY = GSU%PTR%NY; + IF ( GKIND.EQ.4 ) THEN + XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; + ELSE + XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; + END IF + ! + INGRID = .FALSE. + ! + ! Shift target to appropriate longitude range + IF ( LLG ) THEN + XT = MOD(XT,REAL(D360,8)) + IF ( LCLO .OR. L360 ) THEN + IF ( XT.LT.ZERO ) XT = XT + D360 + ELSE + IF ( XT.GT.D180 ) XT = XT - D360 + END IF + END IF + IF ( LDBG ) & + WRITE(*,'(/A,2E24.16)') 'W3GFCD_R8 - TARGET POINT:',XT,YT + + !-----number of cells + LXC = LBX; LYC = LBY; + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE ) + UXC = UBX-1; UYC = UBY-1; + CASE ( ICLO_GRDI ) + UXC = UBX; UYC = UBY-1; + CASE ( ICLO_GRDJ ) + UXC = UBX-1; UYC = UBY; + CASE ( ICLO_TRDL ) + UXC = UBX; UYC = UBY; + CASE ( ICLO_TRPL ) + UXC = UBX; UYC = UBY; + END SELECT + ! + ! -------------------------------------------------------------------- / + ! 3. Search for enclosing cell + ! + CELL_LOOP: DO I=LXC,UXC + DO J=LYC,UYC + !-------------create list of cell vertices + IS(1) = I ; JS(1) = J ; + IS(2) = I+1; JS(2) = J ; + IS(3) = I+1; JS(3) = J+1; + IS(4) = I ; JS(4) = J+1; + !-------------setup cell corner coordinates and adjust for periodicity + DO L=1,4 + !-----------------apply index closure + IF ( MOD(ICLO,2).EQ.0 ) & + IS(L) = LBX + MOD(NX - 1 + MOD(IS(L) - LBX + 1, NX), NX) + IF ( MOD(ICLO,3).EQ.0 ) & + JS(L) = LBY + MOD(NY - 1 + MOD(JS(L) - LBY + 1, NY), NY) + IF ( ICLO.EQ.ICLO_TRPL .AND. JS(L).GT.UBY ) THEN + IS(L) = UBX + LBX - IS(L) + JS(L) = 2*UBY - JS(L) + 1 + END IF + !-----------------copy cell vertex coordinates into local variables + IF ( IJG ) THEN + IF ( GKIND.EQ.4 ) THEN + XS(L) = XG4(IS(L),JS(L)); YS(L) = YG4(IS(L),JS(L)); + ELSE + XS(L) = XG8(IS(L),JS(L)); YS(L) = YG8(IS(L),JS(L)); END IF - LEPS = EPS - ELSE - LEPS = EPS_DEFAULT - END IF -! -! -------------------------------------------------------------------- / -! 2. Initialize search -! - IF ( PRESENT(DEBUG) ) THEN - LDBG = DEBUG - ELSE - LDBG = .FALSE. - END IF -! -! Local pointers to grid search utility object data - IJG = GSU%PTR%IJG - LLG = GSU%PTR%LLG - ICLO = GSU%PTR%ICLO - LCLO = GSU%PTR%LCLO - L360 = GSU%PTR%L360 - GKIND = GSU%PTR%GKIND - LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; - UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; - NX = GSU%PTR%NX; NY = GSU%PTR%NY; - IF ( GKIND.EQ.4 ) THEN - XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; - ELSE - XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; - END IF -! - INGRID = .FALSE. -! -! Shift target to appropriate longitude range - IF ( LLG ) THEN - XT = MOD(XT,REAL(D360,8)) - IF ( LCLO .OR. L360 ) THEN - IF ( XT.LT.ZERO ) XT = XT + D360 + ELSE + IF ( GKIND.EQ.4 ) THEN + XS(L) = XG4(JS(L),IS(L)); YS(L) = YG4(JS(L),IS(L)); ELSE - IF ( XT.GT.D180 ) XT = XT - D360 + XS(L) = XG8(JS(L),IS(L)); YS(L) = YG8(JS(L),IS(L)); END IF - END IF - IF ( LDBG ) & - WRITE(*,'(/A,2E24.16)') 'W3GFCD_R8 - TARGET POINT:',XT,YT - -!-----number of cells - LXC = LBX; LYC = LBY; - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE ) - UXC = UBX-1; UYC = UBY-1; - CASE ( ICLO_GRDI ) - UXC = UBX; UYC = UBY-1; - CASE ( ICLO_GRDJ ) - UXC = UBX-1; UYC = UBY; - CASE ( ICLO_TRDL ) - UXC = UBX; UYC = UBY; - CASE ( ICLO_TRPL ) - UXC = UBX; UYC = UBY; - END SELECT -! -! -------------------------------------------------------------------- / -! 3. Search for enclosing cell -! - CELL_LOOP: DO I=LXC,UXC - DO J=LYC,UYC -!-------------create list of cell vertices - IS(1) = I ; JS(1) = J ; - IS(2) = I+1; JS(2) = J ; - IS(3) = I+1; JS(3) = J+1; - IS(4) = I ; JS(4) = J+1; -!-------------setup cell corner coordinates and adjust for periodicity - DO L=1,4 -!-----------------apply index closure - IF ( MOD(ICLO,2).EQ.0 ) & - IS(L) = LBX + MOD(NX - 1 + MOD(IS(L) - LBX + 1, NX), NX) - IF ( MOD(ICLO,3).EQ.0 ) & - JS(L) = LBY + MOD(NY - 1 + MOD(JS(L) - LBY + 1, NY), NY) - IF ( ICLO.EQ.ICLO_TRPL .AND. JS(L).GT.UBY ) THEN - IS(L) = UBX + LBX - IS(L) - JS(L) = 2*UBY - JS(L) + 1 - END IF -!-----------------copy cell vertex coordinates into local variables - IF ( IJG ) THEN - IF ( GKIND.EQ.4 ) THEN - XS(L) = XG4(IS(L),JS(L)); YS(L) = YG4(IS(L),JS(L)); - ELSE - XS(L) = XG8(IS(L),JS(L)); YS(L) = YG8(IS(L),JS(L)); - END IF - ELSE - IF ( GKIND.EQ.4 ) THEN - XS(L) = XG4(JS(L),IS(L)); YS(L) = YG4(JS(L),IS(L)); - ELSE - XS(L) = XG8(JS(L),IS(L)); YS(L) = YG8(JS(L),IS(L)); - END IF - END IF -!-----------------shift longitudes to same range - IF ( LLG ) THEN - XS(L) = MOD(XS(L),REAL(D360,8)) - IF ( LCLO .OR. L360 ) THEN - IF ( XS(L).LT.ZERO ) XS(L) = XS(L) + D360 - ELSE - IF ( XS(L).GT.D180 ) XS(L) = XS(L) - D360 - END IF - END IF - END DO !L - IF ( LDBG ) & - WRITE(*,'(A,4(/A,1I1,A,2I6,2E24.16))') & - 'W3GFCD_R8 - CHECK CELL:', & - (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) -!-------------check if point is enclosed in cell defined by xs(1:4) & ys(1:4) - INGRID = W3CKCL(LLG,XT,YT,4,XS,YS,LPLC,LEPS,LDBG) - IF ( LDBG ) WRITE(*,'(A,1L2)')'W3GFCD_R8 - INGRID:',INGRID - IF ( INGRID ) THEN -!-----------------exit search - IF ( LDBG ) & - WRITE(*,'(A,4(2I6))') & - 'W3GFCD_R8 - ENCLOSING CELL:',(IS(L),JS(L),L=1,4) - IF ( PRESENT(POLE) ) POLE = LPLC - EXIT CELL_LOOP - END IF !point in cell - END DO !J - END DO CELL_LOOP - - END FUNCTION W3GFCD_R8 -!/ -!/ End of W3GFCD ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3GFPT( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) & -!/ RESULT(INGRID) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Find point in grid, associated with the input grid-search-utility -! object (GSU), that is closest to the target point (xtin,ytin). -! -! 2. Method : -! -! 3. Parameters : -! -! Return parameter -! ---------------------------------------------------------------- -! INGRID Log. O Logical flag indicating if target point lies -! within the source grid domain. -! ---------------------------------------------------------------- -! -! Parameter list -! ---------------------------------------------------------------- -! GSU Type I Grid-search-utility object. -! XTIN Real I X-coordinate of target point. -! YTIN Real I Y-coordinate of target point. -! IX,JX I.A. O (I,J) indices of nearest grid point. -! EPS Real I OPTIONAL small non-zero tolerance used to check if -! target point is in domain and for point coincidence. -! DCIN Real I OPTIONAL distance outside of source grid in -! units of cell width to treat target point as -! inside the source grid. -! Default is 0. -! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. -! Default is FALSE. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! - Check on previous initialization of grid search utility object. -! -! 7. Remarks : -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Test input -! 2. Initialize search -! 3. Find enclosing cell and compute closest point -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GFPT_R4( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) & - RESULT(INGRID) -! Single precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(4), INTENT(IN) :: XTIN - REAL(4), INTENT(IN) :: YTIN - INTEGER, INTENT(OUT) :: IX, IY - REAL(4), INTENT(IN), OPTIONAL :: EPS - REAL(4), INTENT(IN), OPTIONAL :: DCIN - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: XT8, YT8, EPS8, DCIN8 + END IF + !-----------------shift longitudes to same range + IF ( LLG ) THEN + XS(L) = MOD(XS(L),REAL(D360,8)) + IF ( LCLO .OR. L360 ) THEN + IF ( XS(L).LT.ZERO ) XS(L) = XS(L) + D360 + ELSE + IF ( XS(L).GT.D180 ) XS(L) = XS(L) - D360 + END IF + END IF + END DO !L + IF ( LDBG ) & + WRITE(*,'(A,4(/A,1I1,A,2I6,2E24.16))') & + 'W3GFCD_R8 - CHECK CELL:', & + (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) + !-------------check if point is enclosed in cell defined by xs(1:4) & ys(1:4) + INGRID = W3CKCL(LLG,XT,YT,4,XS,YS,LPLC,LEPS,LDBG) + IF ( LDBG ) WRITE(*,'(A,1L2)')'W3GFCD_R8 - INGRID:',INGRID + IF ( INGRID ) THEN + !-----------------exit search + IF ( LDBG ) & + WRITE(*,'(A,4(2I6))') & + 'W3GFCD_R8 - ENCLOSING CELL:',(IS(L),JS(L),L=1,4) + IF ( PRESENT(POLE) ) POLE = LPLC + EXIT CELL_LOOP + END IF !point in cell + END DO !J + END DO CELL_LOOP + + END FUNCTION W3GFCD_R8 + !/ + !/ End of W3GFCD ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3GFPT( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) & + !/ RESULT(INGRID) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Find point in grid, associated with the input grid-search-utility + ! object (GSU), that is closest to the target point (xtin,ytin). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Return parameter + ! ---------------------------------------------------------------- + ! INGRID Log. O Logical flag indicating if target point lies + ! within the source grid domain. + ! ---------------------------------------------------------------- + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! GSU Type I Grid-search-utility object. + ! XTIN Real I X-coordinate of target point. + ! YTIN Real I Y-coordinate of target point. + ! IX,JX I.A. O (I,J) indices of nearest grid point. + ! EPS Real I OPTIONAL small non-zero tolerance used to check if + ! target point is in domain and for point coincidence. + ! DCIN Real I OPTIONAL distance outside of source grid in + ! units of cell width to treat target point as + ! inside the source grid. + ! Default is 0. + ! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. + ! Default is FALSE. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! - Check on previous initialization of grid search utility object. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Test input + ! 2. Initialize search + ! 3. Find enclosing cell and compute closest point + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GFPT_R4( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) & + RESULT(INGRID) + ! Single precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(4), INTENT(IN) :: XTIN + REAL(4), INTENT(IN) :: YTIN + INTEGER, INTENT(OUT) :: IX, IY + REAL(4), INTENT(IN), OPTIONAL :: EPS + REAL(4), INTENT(IN), OPTIONAL :: DCIN + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: XT8, YT8, EPS8, DCIN8 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GFPT_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFPT_R4') #endif -! -!-----set inputs - XT8 = XTIN; YT8 = YTIN; - IF ( PRESENT(EPS) ) THEN - EPS8 = EPS - ELSE - EPS8 = EPS_DEFAULT - END IF - IF ( PRESENT(DCIN) ) THEN - DCIN8 = DCIN - ELSE - DCIN8 = ZERO - END IF -! -!-----call double precision method - INGRID = W3GFPT( GSU, XT8, YT8, IX, IY, EPS=EPS8, DCIN=DCIN8, & - DEBUG=DEBUG ) - - END FUNCTION W3GFPT_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GFPT_R8( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) & - RESULT(INGRID) -! Single precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(8), INTENT(IN) :: XTIN - REAL(8), INTENT(IN) :: YTIN - INTEGER, INTENT(OUT) :: IX, IY - REAL(8), INTENT(IN), OPTIONAL :: EPS - REAL(8), INTENT(IN), OPTIONAL :: DCIN - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - REAL(8), PARAMETER :: BIG = 1D16 - REAL(8) :: LEPS, LDCIN - LOGICAL :: LDBG, FNCL - INTEGER :: I, L - INTEGER :: IS(4), JS(4) - REAL(8) :: XT, YT, XS(4), YS(4) - REAL(8) :: XTC, YTC, XSC(4), YSC(4) - REAL(8) :: IXR, JXR, DD, LON0, LAT0, DMIN - LOGICAL :: IJG, LLG + ! + !-----set inputs + XT8 = XTIN; YT8 = YTIN; + IF ( PRESENT(EPS) ) THEN + EPS8 = EPS + ELSE + EPS8 = EPS_DEFAULT + END IF + IF ( PRESENT(DCIN) ) THEN + DCIN8 = DCIN + ELSE + DCIN8 = ZERO + END IF + ! + !-----call double precision method + INGRID = W3GFPT( GSU, XT8, YT8, IX, IY, EPS=EPS8, DCIN=DCIN8, & + DEBUG=DEBUG ) + + END FUNCTION W3GFPT_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GFPT_R8( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) & + RESULT(INGRID) + ! Single precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(8), INTENT(IN) :: XTIN + REAL(8), INTENT(IN) :: YTIN + INTEGER, INTENT(OUT) :: IX, IY + REAL(8), INTENT(IN), OPTIONAL :: EPS + REAL(8), INTENT(IN), OPTIONAL :: DCIN + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + REAL(8), PARAMETER :: BIG = 1D16 + REAL(8) :: LEPS, LDCIN + LOGICAL :: LDBG, FNCL + INTEGER :: I, L + INTEGER :: IS(4), JS(4) + REAL(8) :: XT, YT, XS(4), YS(4) + REAL(8) :: XTC, YTC, XSC(4), YSC(4) + REAL(8) :: IXR, JXR, DD, LON0, LAT0, DMIN + LOGICAL :: IJG, LLG +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFPT_R8') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/2A/)') 'W3GFPT_R8 ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + IF ( PRESENT(EPS) ) THEN + IF ( EPS .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GFPT_R8 ERROR -- ', & + 'EPS parameter must be >= 0' + CALL EXTCDE (1) + END IF + LEPS = EPS + ELSE + LEPS = EPS_DEFAULT + END IF + IF ( PRESENT(DCIN) ) THEN + IF ( DCIN .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GFPT_R8 ERROR -- ', & + 'DCIN parameter must be >= 0' + CALL EXTCDE (1) + END IF + LDCIN = DCIN + ELSE + LDCIN = ZERO + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Initialize search + ! + IF ( PRESENT(DEBUG) ) THEN + LDBG = DEBUG + ELSE + LDBG = .FALSE. + END IF + ! + ! Local pointers to grid search utility object data + IJG = GSU%PTR%IJG + LLG = GSU%PTR%LLG + ! + INGRID = .FALSE. + IX = GSU%PTR%LBX-1 + IY = GSU%PTR%LBY-1 + ! + XT = XTIN; YT = YTIN; + IF ( LDBG ) & + WRITE(*,'(/A,2E24.16)') 'W3GFPT_R8 - TARGET POINT:',XT,YT + ! + ! -------------------------------------------------------------------- / + ! 3. Find enclosing cell and compute closest point + ! + FNCL = LDCIN .GT. ZERO + INGRID = W3GFCL( GSU, XT, YT, IS, JS, XS, YS, EPS=LEPS, FNCL=FNCL, DEBUG=LDBG ) + IF ( .NOT.INGRID .AND. .NOT.FNCL ) RETURN + ! + !-----Set in grid if point is within DCIN cell width distance of closest cell + IF ( .NOT.INGRID .AND. FNCL ) THEN + !-------Compute cell relative index space location + LON0 = SUM(XS)/FOUR; LAT0 = SUM(YS)/FOUR; + IF ( D90-ABS(LAT0).GT.NEAR_POLE ) THEN + !-----------non-pole cell: compute relative location using (lon,lat) + CALL GETPQR(XT,YT,XS,YS,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + ELSE + !-----------pole cell: compute relative location using stereographic projection + CALL W3SPLX(LON0,LAT0,ZERO,XT,YT,XTC,YTC) + DO I=1,4 + CALL W3SPLX(LON0,LAT0,ZERO,XS(I),YS(I),XSC(I),YSC(I)) + END DO + CALL GETPQR(XTC,YTC,XSC,YSC,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + ENDIF + DD = HALF + LDCIN + INGRID = ABS(IXR-HALF).LE.DD .AND. ABS(JXR-HALF).LE.DD + END IF + ! + !-----Compute indices of closest point in cell + IF ( INGRID ) THEN + DMIN = BIG + DO L=1,4 + DD = W3DIST( LLG, XT, YT, XS(L), YS(L) ) + IF ( DD .LT. DMIN ) THEN + DMIN = DD; IX = IS(L); IY = JS(L); + END IF + END DO !L + END IF + + END FUNCTION W3GFPT_R8 + !/ + !/ End of W3GFPT ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3GFIJ( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) & + !/ RESULT(INGRID) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute coordinates ( ix, jx ) of target point ( xtin, ytin ) in + ! source grid index space from source grid associated with the input + ! grid search utility object (GSU). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Return parameter + ! ---------------------------------------------------------------- + ! INGRID Log. O Logical flag indicating if target point lies + ! within the source grid domain. + ! ---------------------------------------------------------------- + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! GSU Type I Grid-search-utility object. + ! XTIN Real I X-coordinate of target point. + ! YTIN Real I Y-coordinate of target point. + ! IX Real O X-coordinate of target point in source grid + ! index space. + ! JX Real O Y-coordinate of target point in source grid + ! index space. + ! EPS Real I OPTIONAL small non-zero tolerance used to check if + ! target point is in domain and for point coincidence. + ! DCIN Real I OPTIONAL distance outside of source grid in + ! units of cell width to treat target point as + ! inside the source grid. + ! Default is 0. + ! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. + ! Default is FALSE. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! - Check on previous initialization of grid search utility object. + ! - Check on appropriate input of optional arguments. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Test input + ! 2. Initialize search + ! 3. Find enclosing cell and compute index coordinates + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GFIJ_R4( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) & + RESULT(INGRID) + ! Single precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(4), INTENT(IN) :: XTIN + REAL(4), INTENT(IN) :: YTIN + REAL(4), INTENT(OUT) :: IX + REAL(4), INTENT(OUT) :: JX + REAL(4), INTENT(IN), OPTIONAL :: EPS + REAL(4), INTENT(IN), OPTIONAL :: DCIN + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: XT8, YT8, IX8, JX8, EPS8, DCIN8 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFIJ_R4') +#endif + ! + !-----set inputs + XT8 = XTIN; YT8 = YTIN; + IF ( PRESENT(EPS) ) THEN + EPS8 = EPS + ELSE + EPS8 = EPS_DEFAULT + END IF + IF ( PRESENT(DCIN) ) THEN + DCIN8 = DCIN + ELSE + DCIN8 = ZERO + END IF + ! + !-----call double precision method + INGRID = W3GFIJ( GSU, XT8, YT8, IX8, JX8, EPS=EPS8, DCIN=DCIN8, & + DEBUG=DEBUG ) + ! + !-----set outputs + IX = IX8; JX = JX8; + + END FUNCTION W3GFIJ_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GFIJ_R8( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) & + RESULT(INGRID) + ! Double precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(8), INTENT(IN) :: XTIN + REAL(8), INTENT(IN) :: YTIN + REAL(8), INTENT(OUT) :: IX + REAL(8), INTENT(OUT) :: JX + REAL(8), INTENT(IN), OPTIONAL :: EPS + REAL(8), INTENT(IN), OPTIONAL :: DCIN + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: LEPS, LDCIN + INTEGER :: I + LOGICAL :: LDBG, FNCL, POLE + INTEGER :: IS(4), JS(4) + REAL(8) :: XT, YT, XS(4), YS(4) + REAL(8) :: XTC, YTC, XSC(4), YSC(4) + REAL(8) :: IXR, JXR, DD, LON0, LAT0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFIJ_R8') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/2A/)') 'W3GFIJ_R8 ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + IF ( PRESENT(EPS) ) THEN + IF ( EPS .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GFIJ_R8 ERROR -- ', & + 'EPS parameter must be >= 0' + CALL EXTCDE (1) + END IF + LEPS = EPS + ELSE + LEPS = EPS_DEFAULT + END IF + IF ( PRESENT(DCIN) ) THEN + IF ( DCIN .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GFIJ_R8 ERROR -- ', & + 'DCIN parameter must be >= 0' + CALL EXTCDE (1) + END IF + LDCIN = DCIN + ELSE + LDCIN = ZERO + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Initialize search + ! + IF ( PRESENT(DEBUG) ) THEN + LDBG = DEBUG + ELSE + LDBG = .FALSE. + END IF + ! + XT = XTIN; YT = YTIN; + IF ( LDBG ) WRITE(*,'(/A,2E24.16)') 'W3GFIJ_R8 - TARGET POINT:',XT,YT + ! + ! -------------------------------------------------------------------- / + ! 3. Find enclosing cell and compute point location + ! + FNCL = LDCIN .GT. ZERO + INGRID = W3GFCL(GSU,XT,YT,IS,JS,XS,YS,POLE=POLE,EPS=LEPS,FNCL=FNCL,DEBUG=LDBG) + IF ( .NOT.INGRID .AND. .NOT.FNCL ) RETURN + ! + !-----Compute cell relative index space location + LON0 = SUM(XS)/FOUR; LAT0 = SUM(YS)/FOUR; + IF ( D90-ABS(LAT0).GT.NEAR_POLE ) THEN + !---------non-pole cell: compute relative location using (lon,lat) + CALL GETPQR(XT,YT,XS,YS,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + ELSE + !---------pole cell: compute relative location using stereographic projection + CALL W3SPLX(LON0,LAT0,ZERO,XT,YT,XTC,YTC) + DO I=1,4 + CALL W3SPLX(LON0,LAT0,ZERO,XS(I),YS(I),XSC(I),YSC(I)) + END DO + CALL GETPQR(XTC,YTC,XSC,YSC,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + ENDIF + IF ( LDBG ) & + WRITE(*,'(A,2L2,2E24.16)') 'W3GFIJ_R8 - RELATIVE:',INGRID,FNCL,IXR,JXR + ! + !-----Set in grid if point is within DCIN cell width distance of closest cell + IF ( .NOT.INGRID .AND. FNCL ) THEN + DD = HALF + LDCIN + INGRID = ABS(IXR-HALF).LE.DD .AND. ABS(JXR-HALF).LE.DD + END IF + ! + !-----Compute absolute index space location + IX = IS(1)+IXR; JX = JS(1)+JXR; + IF ( LDBG ) & + WRITE(*,'(A,2L2,2E24.16)') 'W3GFIJ_R8 - ABSOLUTE:',INGRID,FNCL,IX,JX + + END FUNCTION W3GFIJ_R8 + !/ + !/ End of W3GFIJ ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3GRMP( GSU, XTIN, YTIN, IS, JS, RW, EPS, & + !/ DCIN, MASK, MSKC, NNBR, DEBUG ) RESULT(INGRID) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute bilinear remapping for target point (xtin,ytin) from source + ! grid associated with the input grid search utility object (GSU). + ! The indices of the source points used for remapping are returned in + ! is(1:4) and js(1:4). The remapping weights are returned in rw(1:4). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Return parameter + ! ---------------------------------------------------------------- + ! INGRID Log. O Logical flag indicating if target point lies + ! within the source grid domain. + ! ---------------------------------------------------------------- + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! GSU Type I Grid-search-utility object. + ! XTIN Real I X-coordinate of target point. + ! YTIN Real I Y-coordinate of target point. + ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. + ! RW R.A. O Array of interpolation weights. + ! EPS Real I OPTIONAL small non-zero tolerance used to check if + ! target point is in domain and for point coincidence. + ! DCIN Real I OPTIONAL distance outside of source grid in + ! units of cell width to treat target point as + ! inside the source grid. Default is 0. + ! MASK L.A. I OPTIONAL logical mask for source grid. + ! MSKC Int. O OPTIONAL output integer parameter indicating how + ! the enclosing cell is masked. Possible values + ! are MSKC_NONE, MSKC_PART and MSKC_FULL. + ! MSKC is required when MASK is specified. + ! NNBR Int. I/O OPTIONAL integer parameter indicating the number + ! of nearest-neighbor non-masked points used for + ! distance-weighted averaging. + ! Input: Requested number of nearest-neighbor + ! non-masked points (0 < NNBR <= 4). + ! Output: Actual number of nearest-neighbor + ! non-masked points used. + ! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. + ! Default is FALSE. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! - Check on previous initialization of grid search utility object. + ! - Check on appropriate input of optional arguments. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Test input + ! 2. Initialize search + ! 3. Find enclosing cell and compute remapping weights + ! - if enclosing cell does not includes a pole, then + ! compute bilinear remapping + ! - if enclosing cell includes a pole, then + ! compute distance weighted remapping + ! 4. Handle case of target point located within a partially masked cell. + ! 5. Handle case of target point located within a fully masked cell. + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GRMP_R4( GSU, XTIN, YTIN, IS, JS, RW, EPS, & + DCIN, MASK, MSKC, NNBR, DEBUG ) RESULT(INGRID) + ! Single precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(4), INTENT(IN) :: XTIN + REAL(4), INTENT(IN) :: YTIN + INTEGER, INTENT(OUT) :: IS(4) + INTEGER, INTENT(OUT) :: JS(4) + REAL(4), INTENT(OUT) :: RW(4) + REAL(4), INTENT(IN) , OPTIONAL :: EPS + REAL(4), INTENT(IN) , OPTIONAL :: DCIN + LOGICAL, INTENT(IN) , OPTIONAL :: MASK(:,:) + INTEGER, INTENT(OUT) , OPTIONAL :: MSKC + INTEGER, INTENT(INOUT), OPTIONAL :: NNBR + LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: XT8, YT8, RW8(4), EPS8, DCIN8 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRMP_R4') +#endif + ! + !-----set inputs + XT8 = XTIN; YT8 = YTIN; + IF ( PRESENT(EPS) ) THEN + EPS8 = EPS + ELSE + EPS8 = EPS_DEFAULT + END IF + IF ( PRESENT(DCIN) ) THEN + DCIN8 = DCIN + ELSE + DCIN8 = ZERO + END IF + ! + !-----call double precision method + INGRID = W3GRMP( GSU, XT8, YT8, IS, JS, RW8, & + EPS=EPS8, DCIN=DCIN8, & + MASK=MASK, MSKC=MSKC, NNBR=NNBR, DEBUG=DEBUG ) + ! + !-----set outputs + RW = RW8 + + END FUNCTION W3GRMP_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GRMP_R8( GSU, XTIN, YTIN, IS, JS, RW, EPS, & + DCIN, MASK, MSKC, NNBR, DEBUG ) RESULT(INGRID) + ! Double precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(8), INTENT(IN) :: XTIN + REAL(8), INTENT(IN) :: YTIN + INTEGER, INTENT(OUT) :: IS(4) + INTEGER, INTENT(OUT) :: JS(4) + REAL(8), INTENT(OUT) :: RW(4) + REAL(8), INTENT(IN) , OPTIONAL :: EPS + REAL(8), INTENT(IN) , OPTIONAL :: DCIN + LOGICAL, INTENT(IN) , OPTIONAL :: MASK(:,:) + INTEGER, INTENT(OUT) , OPTIONAL :: MSKC + INTEGER, INTENT(INOUT), OPTIONAL :: NNBR + LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG + + ! Local parameters + REAL(8), PARAMETER :: BIG = 1D16 + REAL(8), PARAMETER :: SMALL = 1D-6 + REAL(8) :: LEPS + LOGICAL :: LDBG, FNCL, POLE + INTEGER :: I, J, L + LOGICAL :: M, MSK(4) + INTEGER :: LVL, N, NS, ICC, JCC + REAL(8) :: XT, YT, XS(4), YS(4), DW(4) + REAL(8) :: XTC, YTC, XSC(4), YSC(4) + REAL(8) :: LDCIN, IXR, JXR, X, Y, D(4), DD, DMIN, DSUM, LON0, LAT0 + LOGICAL :: IJG, LLG, LCLO + INTEGER :: ICLO, GKIND + INTEGER :: LBX, LBY, UBX, UBY, NX, NY + REAL(4), POINTER :: XG4(:,:), YG4(:,:) + REAL(8), POINTER :: XG8(:,:), YG8(:,:) + TYPE(T_NNS), POINTER :: NNP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GFPT_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRMP_R8') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input -! - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/2A/)') 'W3GFPT_R8 ERROR -- ', & - 'grid search utility object not created' + ! + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + ! + IF ( PRESENT(EPS) ) THEN + IF ( EPS .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & + 'EPS parameter must be >= 0' + CALL EXTCDE (1) + END IF + LEPS = EPS + ELSE + LEPS = EPS_DEFAULT + END IF + ! + IF ( PRESENT(DCIN) ) THEN + IF ( DCIN .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GRMP_R4 ERROR -- ', & + 'DCIN parameter must be >= 0' + CALL EXTCDE (1) + END IF + LDCIN = DCIN + ELSE + LDCIN = ZERO + END IF + ! + IF ( PRESENT(MASK) ) THEN + IF ( .NOT.PRESENT(MSKC) ) THEN + WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & + 'MSKC must be specified with MASK' + CALL EXTCDE (1) + END IF + IF ( PRESENT(NNBR) ) THEN + IF ( .NOT.ASSOCIATED(GSU%PTR%NNP) ) THEN + WRITE(0,'(/3A/)') 'W3GRMP_R8 ERROR -- ', & + 'MASK and NNBR input specified, ', & + 'but grid point-search object not created' CALL EXTCDE (1) END IF - IF ( PRESENT(EPS) ) THEN - IF ( EPS .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GFPT_R8 ERROR -- ', & - 'EPS parameter must be >= 0' - CALL EXTCDE (1) - END IF - LEPS = EPS - ELSE - LEPS = EPS_DEFAULT + IF ( NNBR .LE. 0 .OR. NNBR .GT. 4 ) THEN + WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & + 'NNBR must be >= 1 AND <= 4' + CALL EXTCDE (1) END IF - IF ( PRESENT(DCIN) ) THEN - IF ( DCIN .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GFPT_R8 ERROR -- ', & - 'DCIN parameter must be >= 0' - CALL EXTCDE (1) - END IF - LDCIN = DCIN - ELSE - LDCIN = ZERO + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Initialize search + ! + IF ( PRESENT(DEBUG) ) THEN + LDBG = DEBUG + ELSE + LDBG = .FALSE. + END IF + ! + ! Local pointers to grid search utility object data + IJG = GSU%PTR%IJG + LLG = GSU%PTR%LLG + ICLO = GSU%PTR%ICLO + LCLO = GSU%PTR%LCLO + GKIND = GSU%PTR%GKIND + LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; + UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; + NX = GSU%PTR%NX; NY = GSU%PTR%NY; + IF ( GKIND.EQ.4 ) THEN + XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; + ELSE + XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; + END IF + NNP => GSU%PTR%NNP + ! + IF ( PRESENT(MASK) ) THEN + IF ( IJG ) THEN + IF ( .NOT.(UBOUND(MASK,1).EQ.NX.AND. & + UBOUND(MASK,2).EQ.NY) ) THEN + WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & + 'MASK array size does not agree with GSU index bounds' + CALL EXTCDE (1) END IF -! -! -------------------------------------------------------------------- / -! 2. Initialize search -! - IF ( PRESENT(DEBUG) ) THEN - LDBG = DEBUG - ELSE - LDBG = .FALSE. + ELSE + IF ( .NOT.(UBOUND(MASK,2).EQ.NX.AND. & + UBOUND(MASK,1).EQ.NY) ) THEN + WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & + 'MASK array size does not agree with GSU index bounds' + CALL EXTCDE (1) END IF -! -! Local pointers to grid search utility object data - IJG = GSU%PTR%IJG - LLG = GSU%PTR%LLG -! - INGRID = .FALSE. - IX = GSU%PTR%LBX-1 - IY = GSU%PTR%LBY-1 -! - XT = XTIN; YT = YTIN; + END IF + END IF + ! + RW = ZERO; + ! + XT = XTIN; YT = YTIN; + IF ( LDBG ) WRITE(*,'(/A,2E24.16)') 'W3GRMP_R8 - TARGET POINT:',XT,YT + ! + ! -------------------------------------------------------------------- / + ! 3. Find enclosing cell and compute remapping + ! + FNCL = LDCIN .GT. ZERO + INGRID = W3GFCL(GSU,XT,YT,IS,JS,XS,YS,POLE=POLE,EPS=LEPS,FNCL=FNCL,DEBUG=LDBG) + IF ( .NOT.INGRID .AND. .NOT.FNCL ) RETURN + ! + !-----Compute remapping + LON0 = SUM(XS)/FOUR; LAT0 = SUM(YS)/FOUR; + IF ( D90-ABS(LAT0).GT.NEAR_POLE ) THEN + !---------non-pole cell: compute remapping using (lon,lat) + CALL GETPQR(XT,YT,XS,YS,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + ELSE + !---------pole cell: compute remapping using stereographic projection + CALL W3SPLX(LON0,LAT0,ZERO,XT,YT,XTC,YTC) + DO I=1,4 + CALL W3SPLX(LON0,LAT0,ZERO,XS(I),YS(I),XSC(I),YSC(I)) + END DO + CALL GETPQR(XTC,YTC,XSC,YSC,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + ENDIF + DW(1) = (ONE-IXR)*(ONE-JXR) + DW(2) = IXR*(ONE-JXR) + DW(3) = IXR*JXR + DW(4) = (ONE-IXR)*JXR + RW = DW + IF ( LDBG ) THEN + WRITE(*,'(A,2E24.16)') 'W3GRMP_R8 - REMAP (TGT):',XT,YT + DO L=1,4 + WRITE(*,'(A,3I6,E24.16)') 'W3GRMP_R8 - REMAP (SRC):', & + L,IS(L),JS(L),DW(L) + END DO + END IF !LDBG + ! + !-----Set in grid if point is within DCIN cell width distance of closest cell + IF ( .NOT.INGRID .AND. FNCL ) THEN + DD = HALF + LDCIN + INGRID = ABS(IXR-HALF).LE.DD .AND. ABS(JXR-HALF).LE.DD + END IF + IF ( .NOT.INGRID ) RETURN + ! + IF ( .NOT.PRESENT(MASK) ) RETURN + ! + ! -------------------------------------------------------------------- / + ! 4. Handle case of target point located within a partially masked cell. + ! + !-----copy cell mask values according to array ordering + IF ( IJG ) THEN + DO L=1,4 + MSK(L) = MASK(IS(L)-LBX+1,JS(L)-LBY+1) + END DO + ELSE + DO L=1,4 + MSK(L) = MASK(JS(L)-LBY+1,IS(L)-LBX+1) + END DO + END IF + ! + !-----adjust weights for a partially masked cell + DSUM = ZERO + NS = 4 + DO L=1,4 + IF ( MSK(L) ) THEN + NS = NS - 1 + DW(L) = ZERO + END IF + DSUM = DSUM + DW(L) + END DO + IF ( NS .EQ. 4 ) THEN + MSKC = MSKC_NONE + RETURN + END IF + IF ( NS .GT. 0 .AND. DSUM .GT. SMALL ) THEN + DW = DW / DSUM + RW = DW IF ( LDBG ) & - WRITE(*,'(/A,2E24.16)') 'W3GFPT_R8 - TARGET POINT:',XT,YT -! -! -------------------------------------------------------------------- / -! 3. Find enclosing cell and compute closest point -! - FNCL = LDCIN .GT. ZERO - INGRID = W3GFCL( GSU, XT, YT, IS, JS, XS, YS, EPS=LEPS, FNCL=FNCL, DEBUG=LDBG ) - IF ( .NOT.INGRID .AND. .NOT.FNCL ) RETURN -! -!-----Set in grid if point is within DCIN cell width distance of closest cell - IF ( .NOT.INGRID .AND. FNCL ) THEN -!-------Compute cell relative index space location - LON0 = SUM(XS)/FOUR; LAT0 = SUM(YS)/FOUR; - IF ( D90-ABS(LAT0).GT.NEAR_POLE ) THEN -!-----------non-pole cell: compute relative location using (lon,lat) - CALL GETPQR(XT,YT,XS,YS,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + WRITE(*,'(A,2E24.16,4(2I6,E24.16))') & + 'W3GRMP_R8 - PARTIAL MASKED CELL:', & + XT,YT,(IS(L),JS(L),DW(L),L=1,4) + MSKC = MSKC_PART + RETURN + ELSE + MSKC = MSKC_FULL + IF ( .NOT.PRESENT(NNBR) ) RETURN + END IF + ! + ! -------------------------------------------------------------------- / + ! 5. Handle case of target point located within a fully masked cell. + ! + ! Choose closest point in enclosing land cell to be the central point + DMIN = BIG + DO L=1,4 + DD = W3DIST(LLG,XT,YT,XS(L),YS(L)) + IF ( DD .LT. DMIN ) THEN + DMIN = DD; ICC = IS(L); JCC = JS(L); + END IF + END DO !L + ! + ! Search nearest-neighbor source points for closest nnbr un-masked + ! points and compute distance-weighted average remapping. + IF ( LDBG ) & + WRITE(*,'(A,2I6)') & + 'W3GRMP_R8 - BEGIN POINT NNBR SEARCH:',ICC,JCC + NS = 0; D(:) = BIG; + LEVEL_LOOP: DO LVL=0,NNP%NLVL + NNBR_LOOP: DO N=NNP%N1(LVL),NNP%N2(LVL) + I = ICC + NNP%DI(N); J = JCC + NNP%DJ(N); + IF ( ICLO.EQ.ICLO_NONE ) THEN + IF ( I.LT.LBX .OR. I.GT.UBX ) CYCLE NNBR_LOOP + IF ( J.LT.LBY .OR. J.GT.UBY ) CYCLE NNBR_LOOP + END IF + !-------------apply index closure + IF ( MOD(ICLO,2).EQ.0 ) & + I = LBX + MOD(NX - 1 + MOD(I - LBX + 1, NX), NX) + IF ( MOD(ICLO,3).EQ.0 ) & + J = LBY + MOD(NY - 1 + MOD(J - LBY + 1, NY), NY) + IF ( ICLO.EQ.ICLO_TRPL .AND. J.GT.UBY ) THEN + I = UBX + LBX - I + J = 2*UBY - J + 1 + END IF + !-------------set mask + IF ( IJG ) THEN + M = MASK(I-LBX+1,J-LBY+1) + ELSE + M = MASK(J-LBY+1,I-LBX+1) + END IF + IF ( LDBG ) & + WRITE(*,'(A,4I6,1L6)') & + 'W3GRMP_R8 - POINT NNBR SEARCH:',LVL,N,I,J,M + !-------------if masked point, then skip + IF ( M ) CYCLE NNBR_LOOP + !-------------compute distance + IF ( IJG ) THEN + IF ( GKIND.EQ.4 ) THEN + X = XG4(I,J); Y = YG4(I,J); ELSE -!-----------pole cell: compute relative location using stereographic projection - CALL W3SPLX(LON0,LAT0,ZERO,XT,YT,XTC,YTC) - DO I=1,4 - CALL W3SPLX(LON0,LAT0,ZERO,XS(I),YS(I),XSC(I),YSC(I)) - END DO - CALL GETPQR(XTC,YTC,XSC,YSC,IXR,JXR,EPS=LEPS,DEBUG=LDBG) - ENDIF - DD = HALF + LDCIN - INGRID = ABS(IXR-HALF).LE.DD .AND. ABS(JXR-HALF).LE.DD - END IF -! -!-----Compute indices of closest point in cell - IF ( INGRID ) THEN - DMIN = BIG - DO L=1,4 - DD = W3DIST( LLG, XT, YT, XS(L), YS(L) ) - IF ( DD .LT. DMIN ) THEN - DMIN = DD; IX = IS(L); IY = JS(L); - END IF - END DO !L + X = XG8(I,J); Y = YG8(I,J); + END IF + ELSE + IF ( GKIND.EQ.4 ) THEN + X = XG4(J,I); Y = YG4(J,I); + ELSE + X = XG8(J,I); Y = YG8(J,I); + END IF END IF - - END FUNCTION W3GFPT_R8 -!/ -!/ End of W3GFPT ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3GFIJ( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) & -!/ RESULT(INGRID) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute coordinates ( ix, jx ) of target point ( xtin, ytin ) in -! source grid index space from source grid associated with the input -! grid search utility object (GSU). -! -! 2. Method : -! -! 3. Parameters : -! -! Return parameter -! ---------------------------------------------------------------- -! INGRID Log. O Logical flag indicating if target point lies -! within the source grid domain. -! ---------------------------------------------------------------- -! -! Parameter list -! ---------------------------------------------------------------- -! GSU Type I Grid-search-utility object. -! XTIN Real I X-coordinate of target point. -! YTIN Real I Y-coordinate of target point. -! IX Real O X-coordinate of target point in source grid -! index space. -! JX Real O Y-coordinate of target point in source grid -! index space. -! EPS Real I OPTIONAL small non-zero tolerance used to check if -! target point is in domain and for point coincidence. -! DCIN Real I OPTIONAL distance outside of source grid in -! units of cell width to treat target point as -! inside the source grid. -! Default is 0. -! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. -! Default is FALSE. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! - Check on previous initialization of grid search utility object. -! - Check on appropriate input of optional arguments. -! -! 7. Remarks : -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Test input -! 2. Initialize search -! 3. Find enclosing cell and compute index coordinates -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GFIJ_R4( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) & - RESULT(INGRID) -! Single precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(4), INTENT(IN) :: XTIN - REAL(4), INTENT(IN) :: YTIN - REAL(4), INTENT(OUT) :: IX - REAL(4), INTENT(OUT) :: JX - REAL(4), INTENT(IN), OPTIONAL :: EPS - REAL(4), INTENT(IN), OPTIONAL :: DCIN - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: XT8, YT8, IX8, JX8, EPS8, DCIN8 + DD = W3DIST(LLG,XT,YT,X,Y) + !-------------still need nnbr points + IF ( NS .LT. NNBR ) THEN + !-----------------add to list + NS = NS + 1 + IS(NS) = I; JS(NS) = J; D(NS) = DD; + !-----------------once list is full sort according to increasing distance + IF ( NS .EQ. NNBR ) CALL W3SORT(NS,IS,JS,D) + !---------------we have found nnbr points + ELSE !list is full + !-----------------insert into list if the newest point is closer + CALL W3ISRT(I,J,DD,NS,IS,JS,D) + END IF !list is full + IF ( LDBG ) & + WRITE(*,'(A,I2,I3,I6,4(2I6,E24.16))') & + 'W3GRMP_R8 - POINT NNBR LIST:', & + LVL,N,NS,(IS(L),JS(L),D(L),L=1,NS) + END DO NNBR_LOOP + !---------if we have found nnbr_rqd points, then exit the search + IF ( NS .EQ. NNBR ) EXIT LEVEL_LOOP + END DO LEVEL_LOOP + NNBR = NS + ! + ! If zero unmasked points found, then return nnbr=0 as error indicator + IF ( NNBR .EQ. 0 ) RETURN + ! + ! Compute distance-weighted remapping for nnbr points + DSUM = ZERO + DO L=1,NNBR + DSUM = DSUM + ONE/(D(L)+SMALL) + END DO + DW(1:NNBR) = ONE/(D(1:NNBR)+SMALL)/DSUM + RW = DW + IF ( LDBG ) THEN + WRITE(*,'(A,2E24.16,I6)') & + 'W3GRMP_R8 - FULLY MASKED CELL (TGT):',XT,YT,NNBR + DO L=1,NNBR + WRITE(*,'(A,3I6,E24.16)') & + 'W3GRMP_R8 - FULLY MASKED CELL (SRC):', & + L,IS(L),JS(L),DW(L) + END DO + END IF !LDBG + + END FUNCTION W3GRMP_R8 + !/ + !/ End of W3GRMP ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3GRMC( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, & + !/ DCIN, WDTH, MASK, NMSK, DEBUG ) RESULT(INGRID) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute remapping coefficients for target point (XTIN,YTIN) from + ! source grid associated with the input grid search utility object + ! (GSU). The type of remapping is specified by RTYP. The indices + ! of the source points used for remapping are returned in IS(1:NS) + ! and JS(1:NS). The remapping coefficients are returned in CS(1:NS). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Return parameter + ! ---------------------------------------------------------------- + ! INGRID Log. O Logical flag indicating if target point lies + ! within the source grid domain. + ! ---------------------------------------------------------------- + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! GSU Type I Grid-search-utility object. + ! XTIN Real I X-coordinate of target point. + ! YTIN Real I Y-coordinate of target point. + ! RTYP Str. I Remap type: 'nearpt', 'bilinr', 'bicubc', + ! 'filter' + ! NS Int. O Number of vertices for remapping + ! IS,JS I.A. O (I,J) indices of vertices for remapping + ! CS R.A. O Array of remapping coefficients + ! EPS Real I OPTIONAL small non-zero tolerance used to check if + ! target point is in domain and for point coincidence. + ! DCIN Real I OPTIONAL distance outside of source grid in + ! units of cell width to treat target point as + ! inside the source grid. Default is 0. + ! WDTH Real I OPTIONAL width for gaussian filter in units of + ! source grid cell width. Required if RTYP='filter'. + ! Actual width used is MIN(WDTH,1.5). + ! MASK L.A. I OPTIONAL logical mask for source grid. + ! (T = invalid, F = valid) + ! DIMENSION must be same as GSU coordinate arrays. + ! NMSK Int. I OPTIONAL maximum number of masked points for + ! treating an enclosing source grid cell as partially + ! masked. Must be >= 0 and < 4. Default is 2. + ! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. + ! Default is FALSE. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! - Check on previous initialization of grid search utility object. + ! - Check on appropriate input of optional arguments. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Test input + ! 2. Initialize search + ! 3. Find enclosing cell and compute relative index space location + ! 4. Compute source grid points and remapping coefficients + ! 5. Adjust for partially masked cell and enforce normalization + ! 6. Load into return arrays and release work arrays + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GRMC_R4( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, & + DCIN, WDTH, MASK, NMSK, DEBUG ) RESULT(INGRID) + ! Single precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(4), INTENT(IN) :: XTIN + REAL(4), INTENT(IN) :: YTIN + CHARACTER(6), INTENT(IN):: RTYP + INTEGER, INTENT(OUT) :: NS + INTEGER, INTENT(INOUT), POINTER :: IS(:) + INTEGER, INTENT(INOUT), POINTER :: JS(:) + REAL(4), INTENT(INOUT), POINTER :: CS(:) + REAL(4), INTENT(IN) , OPTIONAL :: EPS + REAL(4), INTENT(IN) , OPTIONAL :: DCIN + REAL(4), INTENT(IN) , OPTIONAL :: WDTH + LOGICAL, INTENT(IN) , OPTIONAL :: MASK(:,:) + INTEGER, INTENT(IN) , OPTIONAL :: NMSK + LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: LEPS, LDCIN, LWDTH=ZERO + REAL(8) :: XT, YT + REAL(8), POINTER :: CS8(:) => NULL() #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GFIJ_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRMC_R4') #endif -! -!-----set inputs - XT8 = XTIN; YT8 = YTIN; - IF ( PRESENT(EPS) ) THEN - EPS8 = EPS - ELSE - EPS8 = EPS_DEFAULT - END IF - IF ( PRESENT(DCIN) ) THEN - DCIN8 = DCIN - ELSE - DCIN8 = ZERO - END IF -! -!-----call double precision method - INGRID = W3GFIJ( GSU, XT8, YT8, IX8, JX8, EPS=EPS8, DCIN=DCIN8, & - DEBUG=DEBUG ) -! -!-----set outputs - IX = IX8; JX = JX8; - - END FUNCTION W3GFIJ_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GFIJ_R8( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) & - RESULT(INGRID) -! Double precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(8), INTENT(IN) :: XTIN - REAL(8), INTENT(IN) :: YTIN - REAL(8), INTENT(OUT) :: IX - REAL(8), INTENT(OUT) :: JX - REAL(8), INTENT(IN), OPTIONAL :: EPS - REAL(8), INTENT(IN), OPTIONAL :: DCIN - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: LEPS, LDCIN - INTEGER :: I - LOGICAL :: LDBG, FNCL, POLE - INTEGER :: IS(4), JS(4) - REAL(8) :: XT, YT, XS(4), YS(4) - REAL(8) :: XTC, YTC, XSC(4), YSC(4) - REAL(8) :: IXR, JXR, DD, LON0, LAT0 + ! + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + ! + SELECT CASE (RTYP) + CASE ('nearpt') + CASE ('bilinr') + CASE ('bicubc') + CASE ('filter') + IF ( .NOT.PRESENT(WDTH) ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', & + 'WDTH parameter is required with RTYP = filter' + CALL EXTCDE (1) + ELSE + LWDTH = WDTH + END IF + CASE DEFAULT + WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', & + 'RTYP = '//RTYP//' not supported' + CALL EXTCDE (1) + END SELECT + ! + IF ( PRESENT(EPS) ) THEN + IF ( EPS .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', & + 'EPS parameter must be >= 0' + CALL EXTCDE (1) + END IF + LEPS = EPS + ELSE + LEPS = EPS_DEFAULT + END IF + ! + IF ( PRESENT(DCIN) ) THEN + IF ( DCIN .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', & + 'DCIN parameter must be >= 0' + CALL EXTCDE (1) + END IF + LDCIN = DCIN + ELSE + LDCIN = ZERO + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Call into double precision method + ! + XT = XTIN; YT = YTIN; + INGRID = W3GRMC( GSU, XT, YT, RTYP, NS, IS, JS, CS8, & + EPS=LEPS, DCIN=LDCIN, WDTH=LWDTH, & + MASK=MASK, NMSK=NMSK, DEBUG=DEBUG ) + IF ( NS.GT.0 ) THEN + ALLOCATE( CS(NS) ) + CS(:) = CS8(:) + DEALLOCATE( CS8 ) + END IF + + END FUNCTION W3GRMC_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3GRMC_R8( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, & + DCIN, WDTH, MASK, NMSK, DEBUG ) RESULT(INGRID) + ! Double precision interface + LOGICAL :: INGRID + TYPE(T_GSU), INTENT(IN) :: GSU + REAL(8), INTENT(IN) :: XTIN + REAL(8), INTENT(IN) :: YTIN + CHARACTER(6), INTENT(IN):: RTYP + INTEGER, INTENT(OUT) :: NS + INTEGER, INTENT(INOUT), POINTER :: IS(:) + INTEGER, INTENT(INOUT), POINTER :: JS(:) + REAL(8), INTENT(INOUT), POINTER :: CS(:) + REAL(8), INTENT(IN) , OPTIONAL :: EPS + REAL(8), INTENT(IN) , OPTIONAL :: DCIN + REAL(8), INTENT(IN) , OPTIONAL :: WDTH + LOGICAL, INTENT(IN) , OPTIONAL :: MASK(:,:) + INTEGER, INTENT(IN) , OPTIONAL :: NMSK + LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG + + ! Local parameters + LOGICAL, PARAMETER :: LCMP = .TRUE. + INTEGER, PARAMETER :: NMSK_DEFAULT = 2 + REAL(8), PARAMETER :: BIG = 1D16 + REAL(8) :: LEPS, LWDTH=ZERO + LOGICAL :: LDBG, FNCL, POLE, DOBLC, LMSK + INTEGER :: I, II, JJ, K, KK, MCS, MCSMAX + INTEGER :: IC(4), JC(4) + REAL(8) :: XT, YT, XC(4), YC(4) + REAL(8) :: XTC, YTC, XSC(4), YSC(4) + REAL(8) :: LDCIN, IXR, JXR, DD, LON0, LAT0, DMIN + REAL(8) :: IX, JX, CZS + INTEGER :: NZ + LOGICAL, POINTER :: LZ(:)=>NULL() + INTEGER, POINTER :: IZ(:)=>NULL(), JZ(:)=>NULL() + REAL(8), POINTER :: CZ(:)=>NULL() + LOGICAL :: IJG, LLG, LCLO + INTEGER :: ICLO, GKIND + INTEGER :: LBX, LBY, UBX, UBY, NX, NY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GFIJ_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRMC_R8') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input -! - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/2A/)') 'W3GFIJ_R8 ERROR -- ', & - 'grid search utility object not created' + ! + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + ! + SELECT CASE (RTYP) + CASE ('nearpt') + CASE ('bilinr') + CASE ('bicubc') + CASE ('filter') + IF ( .NOT.PRESENT(WDTH) ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & + 'WDTH parameter is required with RTYP = filter' + CALL EXTCDE (1) + ELSE + LWDTH = WDTH + END IF + CASE DEFAULT + WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & + 'RTYP = '//RTYP//' not supported' + CALL EXTCDE (1) + END SELECT + ! + IF ( PRESENT(EPS) ) THEN + IF ( EPS .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & + 'EPS parameter must be >= 0' + CALL EXTCDE (1) + END IF + LEPS = EPS + ELSE + LEPS = EPS_DEFAULT + END IF + ! + IF ( PRESENT(DCIN) ) THEN + IF ( DCIN .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & + 'DCIN parameter must be >= 0' + CALL EXTCDE (1) + END IF + LDCIN = DCIN + ELSE + LDCIN = ZERO + END IF + ! + IF ( PRESENT(NMSK) ) THEN + IF ( NMSK .LT. ZERO .OR. NMSK .GE. 4 ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & + 'NMSK parameter must be >= 0 and < 4' + CALL EXTCDE (1) + END IF + MCSMAX = NMSK + ELSE + MCSMAX = NMSK_DEFAULT + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Initialize search + ! + IF ( PRESENT(DEBUG) ) THEN + LDBG = DEBUG + ELSE + LDBG = .FALSE. + END IF + ! + ! Local pointers to grid search utility object data + IJG = GSU%PTR%IJG + LLG = GSU%PTR%LLG + ICLO = GSU%PTR%ICLO + LCLO = GSU%PTR%LCLO + GKIND = GSU%PTR%GKIND + LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; + UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; + NX = GSU%PTR%NX; NY = GSU%PTR%NY; + ! + IF ( PRESENT(MASK) ) THEN + IF ( IJG ) THEN + IF ( .NOT.(UBOUND(MASK,1).EQ.NX.AND. & + UBOUND(MASK,2).EQ.NY) ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & + 'MASK array size does not agree with GSU index bounds' CALL EXTCDE (1) END IF - IF ( PRESENT(EPS) ) THEN - IF ( EPS .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GFIJ_R8 ERROR -- ', & - 'EPS parameter must be >= 0' - CALL EXTCDE (1) - END IF - LEPS = EPS - ELSE - LEPS = EPS_DEFAULT + ELSE + IF ( .NOT.(UBOUND(MASK,2).EQ.NX.AND. & + UBOUND(MASK,1).EQ.NY) ) THEN + WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & + 'MASK array size does not agree with GSU index bounds' + CALL EXTCDE (1) END IF - IF ( PRESENT(DCIN) ) THEN - IF ( DCIN .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GFIJ_R8 ERROR -- ', & - 'DCIN parameter must be >= 0' - CALL EXTCDE (1) - END IF - LDCIN = DCIN + END IF + END IF + ! + NS = 0 + IF ( ASSOCIATED(IS) ) THEN + DEALLOCATE( IS ) + NULLIFY( IS ) + END IF + IF ( ASSOCIATED(JS) ) THEN + DEALLOCATE( JS ) + NULLIFY( JS ) + END IF + IF ( ASSOCIATED(CS) ) THEN + DEALLOCATE( CS ) + NULLIFY( CS ) + END IF + ! + XT = XTIN; YT = YTIN; + IF ( LDBG ) WRITE(*,'(/A,2E24.16)') 'W3GRMC_R8 - TARGET POINT:',XT,YT + ! + ! -------------------------------------------------------------------- / + ! 3. Find enclosing cell and compute relative index space location + ! + FNCL = LDCIN .GT. ZERO + INGRID = W3GFCL(GSU,XT,YT,IC,JC,XC,YC,POLE=POLE,EPS=LEPS,FNCL=FNCL,DEBUG=LDBG) + IF ( .NOT.INGRID .AND. .NOT.FNCL ) RETURN + ! + !-----Compute cell relative index space location + LON0 = SUM(XC)/FOUR; LAT0 = SUM(YC)/FOUR; + IF ( D90-ABS(LAT0).GT.NEAR_POLE ) THEN + !---------non-pole cell: compute relative location using (lon,lat) + CALL GETPQR(XT,YT,XC,YC,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + ELSE + !---------pole cell: compute relative location using stereographic projection + CALL W3SPLX(LON0,LAT0,ZERO,XT,YT,XTC,YTC) + DO I=1,4 + CALL W3SPLX(LON0,LAT0,ZERO,XC(I),YC(I),XSC(I),YSC(I)) + END DO + CALL GETPQR(XTC,YTC,XSC,YSC,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + ENDIF + IF ( LDBG ) & + WRITE(*,'(A,2L2,2E24.16)') 'W3GRMC_R8 - RELATIVE:',INGRID,FNCL,IXR,JXR + ! + !-----Set in grid if point is within DCIN cell width distance of closest cell + IF ( .NOT.INGRID .AND. FNCL ) THEN + DD = HALF + LDCIN + INGRID = ABS(IXR-HALF).LE.DD .AND. ABS(JXR-HALF).LE.DD + END IF + IF ( .NOT.INGRID ) RETURN + ! + !-----Compute absolute index space location + IX = IC(1) + IXR; JX = JC(1) + JXR; + ! + !-----Determine if target point is coincident with an + ! unmasked source grid cell point (KK) + KK_LOOP: DO KK=1,4 + IF ( ABS(IC(KK)-IX).LE.LEPS .AND. & + ABS(JC(KK)-JX).LE.LEPS ) THEN + IF ( PRESENT(MASK) ) THEN + IF ( IJG ) THEN + IF ( .NOT.MASK(IC(KK)-LBX+1,JC(KK)-LBY+1) ) EXIT KK_LOOP + ELSE + IF ( .NOT.MASK(JC(KK)-LBY+1,IC(KK)-LBX+1) ) EXIT KK_LOOP + END IF + ELSE + EXIT KK_LOOP + END IF + END IF + END DO KK_LOOP + ! + !-----Count number of masked points in source cell + MCS = 0 + IF ( PRESENT(MASK) ) THEN + DO K=1,4 + IF ( IJG ) THEN + IF ( MASK(IC(K)-LBX+1,JC(K)-LBY+1) ) MCS = MCS+1 ELSE - LDCIN = ZERO + IF ( MASK(JC(K)-LBY+1,IC(K)-LBX+1) ) MCS = MCS+1 + END IF + END DO + END IF + ! + ! -------------------------------------------------------------------- / + ! 4. Compute source grid points and remapping coefficients + ! + SELECT CASE (RTYP) + CASE ('nearpt') + ! *** nearest point *** + DMIN = BIG + DO K=1,4 + DD = (IX - IC(K))**2 + (JX - JC(K))**2 + IF ( DD .LT. DMIN ) THEN + DMIN = DD; II = IC(K); JJ = JC(K); END IF -! -! -------------------------------------------------------------------- / -! 2. Initialize search -! - IF ( PRESENT(DEBUG) ) THEN - LDBG = DEBUG + END DO + NZ = 1 + IF ( PRESENT(MASK) ) THEN + IF ( IJG ) THEN + IF ( MASK(II-LBX+1,JJ-LBY+1) ) NZ = 0 + ELSE + IF ( MASK(JJ-LBY+1,II-LBX+1) ) NZ = 0 + END IF + END IF + IF ( NZ.EQ.1 ) THEN + ! nearest point is unmasked + ! set number of points to one and coefficient to one + ALLOCATE( LZ(NZ), IZ(NZ), JZ(NZ), CZ(NZ) ) + LZ(NZ) = .TRUE. + IZ(NZ) = II + JZ(NZ) = JJ + CZ(NZ) = ONE + ELSE + ! nearest point is masked + ! set number of points to zero and return + NS = 0 + RETURN + END IF + CASE ('bilinr') + ! *** bilinear interpolation *** + IF ( KK.LE.4 ) THEN + ! coincident with unmasked point kk + ! set number of points to one and coefficient to one + NZ = 1 + ALLOCATE( LZ(NZ), IZ(NZ), JZ(NZ), CZ(NZ) ) + LZ(NZ) = .TRUE. + IZ(NZ) = IC(KK) + JZ(NZ) = JC(KK) + CZ(NZ) = ONE + ELSE + ! no coincident points + IF ( MCS.LE.MCSMAX ) THEN + ! unmasked or partially masked cell + ! set bilinear interpolation + CALL GETBLC( GSU, IC(1), JC(1), IXR, JXR, & + LCMP, NZ, LZ, IZ, JZ, CZ ) ELSE - LDBG = .FALSE. + ! fully masked cell + ! set number of points to zero and return + NS = 0 + RETURN END IF -! - XT = XTIN; YT = YTIN; - IF ( LDBG ) WRITE(*,'(/A,2E24.16)') 'W3GFIJ_R8 - TARGET POINT:',XT,YT -! -! -------------------------------------------------------------------- / -! 3. Find enclosing cell and compute point location -! - FNCL = LDCIN .GT. ZERO - INGRID = W3GFCL(GSU,XT,YT,IS,JS,XS,YS,POLE=POLE,EPS=LEPS,FNCL=FNCL,DEBUG=LDBG) - IF ( .NOT.INGRID .AND. .NOT.FNCL ) RETURN -! -!-----Compute cell relative index space location - LON0 = SUM(XS)/FOUR; LAT0 = SUM(YS)/FOUR; - IF ( D90-ABS(LAT0).GT.NEAR_POLE ) THEN -!---------non-pole cell: compute relative location using (lon,lat) - CALL GETPQR(XT,YT,XS,YS,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + END IF + CASE ('bicubc') + ! *** bicubic interpolation *** + IF ( KK.LE.4 ) THEN + ! coincident with unmasked point kk + ! set number of points to one and coefficient to one + NZ = 1 + ALLOCATE( LZ(NZ), IZ(NZ), JZ(NZ), CZ(NZ) ) + LZ(NZ) = .TRUE. + IZ(NZ) = IC(KK) + JZ(NZ) = JC(KK) + CZ(NZ) = ONE + ELSE + ! no coincident points + IF ( MCS.EQ.0 ) THEN + ! unmasked cell + ! get bicubic interpolation + CALL GETBCC( GSU, IC(1), JC(1), IXR, JXR, & + LCMP, NZ, LZ, IZ, JZ, CZ ) + ! check for masked points in bicubic stencil + DOBLC = .FALSE. + IF ( PRESENT(MASK) ) THEN + CHECK: DO K=1,NZ + IF ( LZ(K) ) THEN + IF ( IJG ) THEN + LMSK = MASK(IZ(K)-LBX+1,JZ(K)-LBY+1) + ELSE + LMSK = MASK(JZ(K)-LBY+1,IZ(K)-LBX+1) + END IF + IF ( LMSK ) THEN + DOBLC = .TRUE. + EXIT CHECK + END IF + END IF + END DO CHECK + END IF + IF ( DOBLC ) THEN + ! masked points in bicubic stencil + ! set bilinear interpolation + CALL GETBLC( GSU, IC(1), JC(1), IXR, JXR, & + LCMP, NZ, LZ, IZ, JZ, CZ ) + END IF + ELSE IF ( MCS.LE.MCSMAX ) THEN + ! partially masked cell + ! set bilinear interpolation + CALL GETBLC( GSU, IC(1), JC(1), IXR, JXR, & + LCMP, NZ, LZ, IZ, JZ, CZ ) ELSE -!---------pole cell: compute relative location using stereographic projection - CALL W3SPLX(LON0,LAT0,ZERO,XT,YT,XTC,YTC) - DO I=1,4 - CALL W3SPLX(LON0,LAT0,ZERO,XS(I),YS(I),XSC(I),YSC(I)) - END DO - CALL GETPQR(XTC,YTC,XSC,YSC,IXR,JXR,EPS=LEPS,DEBUG=LDBG) - ENDIF - IF ( LDBG ) & - WRITE(*,'(A,2L2,2E24.16)') 'W3GFIJ_R8 - RELATIVE:',INGRID,FNCL,IXR,JXR -! -!-----Set in grid if point is within DCIN cell width distance of closest cell - IF ( .NOT.INGRID .AND. FNCL ) THEN - DD = HALF + LDCIN - INGRID = ABS(IXR-HALF).LE.DD .AND. ABS(JXR-HALF).LE.DD + ! fully masked cell + ! set number of points to zero and return + NS = 0 + RETURN END IF -! -!-----Compute absolute index space location - IX = IS(1)+IXR; JX = JS(1)+JXR; - IF ( LDBG ) & - WRITE(*,'(A,2L2,2E24.16)') 'W3GFIJ_R8 - ABSOLUTE:',INGRID,FNCL,IX,JX - - END FUNCTION W3GFIJ_R8 -!/ -!/ End of W3GFIJ ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3GRMP( GSU, XTIN, YTIN, IS, JS, RW, EPS, & -!/ DCIN, MASK, MSKC, NNBR, DEBUG ) RESULT(INGRID) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute bilinear remapping for target point (xtin,ytin) from source -! grid associated with the input grid search utility object (GSU). -! The indices of the source points used for remapping are returned in -! is(1:4) and js(1:4). The remapping weights are returned in rw(1:4). -! -! 2. Method : -! -! 3. Parameters : -! -! Return parameter -! ---------------------------------------------------------------- -! INGRID Log. O Logical flag indicating if target point lies -! within the source grid domain. -! ---------------------------------------------------------------- -! -! Parameter list -! ---------------------------------------------------------------- -! GSU Type I Grid-search-utility object. -! XTIN Real I X-coordinate of target point. -! YTIN Real I Y-coordinate of target point. -! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. -! RW R.A. O Array of interpolation weights. -! EPS Real I OPTIONAL small non-zero tolerance used to check if -! target point is in domain and for point coincidence. -! DCIN Real I OPTIONAL distance outside of source grid in -! units of cell width to treat target point as -! inside the source grid. Default is 0. -! MASK L.A. I OPTIONAL logical mask for source grid. -! MSKC Int. O OPTIONAL output integer parameter indicating how -! the enclosing cell is masked. Possible values -! are MSKC_NONE, MSKC_PART and MSKC_FULL. -! MSKC is required when MASK is specified. -! NNBR Int. I/O OPTIONAL integer parameter indicating the number -! of nearest-neighbor non-masked points used for -! distance-weighted averaging. -! Input: Requested number of nearest-neighbor -! non-masked points (0 < NNBR <= 4). -! Output: Actual number of nearest-neighbor -! non-masked points used. -! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. -! Default is FALSE. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! - Check on previous initialization of grid search utility object. -! - Check on appropriate input of optional arguments. -! -! 7. Remarks : -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Test input -! 2. Initialize search -! 3. Find enclosing cell and compute remapping weights -! - if enclosing cell does not includes a pole, then -! compute bilinear remapping -! - if enclosing cell includes a pole, then -! compute distance weighted remapping -! 4. Handle case of target point located within a partially masked cell. -! 5. Handle case of target point located within a fully masked cell. -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GRMP_R4( GSU, XTIN, YTIN, IS, JS, RW, EPS, & - DCIN, MASK, MSKC, NNBR, DEBUG ) RESULT(INGRID) -! Single precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(4), INTENT(IN) :: XTIN - REAL(4), INTENT(IN) :: YTIN - INTEGER, INTENT(OUT) :: IS(4) - INTEGER, INTENT(OUT) :: JS(4) - REAL(4), INTENT(OUT) :: RW(4) - REAL(4), INTENT(IN) , OPTIONAL :: EPS - REAL(4), INTENT(IN) , OPTIONAL :: DCIN - LOGICAL, INTENT(IN) , OPTIONAL :: MASK(:,:) - INTEGER, INTENT(OUT) , OPTIONAL :: MSKC - INTEGER, INTENT(INOUT), OPTIONAL :: NNBR - LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: XT8, YT8, RW8(4), EPS8, DCIN8 + END IF + case ('filter') + ! *** gaussian filter *** + IF ( MCS.LE.MCSMAX ) THEN + ! unmasked or partially masked cell + ! get gaussian filter + CALL GETGFC( GSU, IC(1), JC(1), IXR, JXR, & + LWDTH, LCMP, NZ, LZ, IZ, JZ, CZ ) + ELSE + ! fully masked cell + ! set number of points to zero and return + NS = 0 + RETURN + END IF + END SELECT + ! + ! -------------------------------------------------------------------- / + ! 5. Adjust for partially masked cell and enforce normalization + ! + IF ( NZ .GT. 1 ) THEN + CZS = ZERO + DO K=1,NZ + IF ( LZ(K) ) THEN + IF ( PRESENT(MASK) ) THEN + IF ( IJG ) THEN + LMSK = MASK(IZ(K)-LBX+1,JZ(K)-LBY+1) + ELSE + LMSK = MASK(JZ(K)-LBY+1,IZ(K)-LBX+1) + END IF + IF ( LMSK ) THEN + LZ(K) = .FALSE. + CZ(K) = ZERO + ELSE + CZS = CZS + CZ(K) + END IF + ELSE + CZS = CZS + CZ(K) + END IF + END IF + END DO + IF ( CZS .GT. ZERO ) THEN + DO K=1,NZ + IF ( LZ(K) ) CZ(K) = CZ(K)/CZS + ENDDO + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 6. Load into return arrays and release work arrays + ! + NS = 0 + DO K=1,NZ + IF ( LZ(K) ) NS = NS + 1 + END DO + IF ( NS.GT.0 ) THEN + ALLOCATE( IS(NS), JS(NS), CS(NS) ) + NS = 0 + DO K=1,NZ + IF ( LZ(K) ) THEN + NS = NS + 1 + IS(NS) = IZ(K) + JS(NS) = JZ(K) + CS(NS) = CZ(K) + END IF + END DO + END IF + + DEALLOCATE( LZ, IZ, JZ, CZ ) + + END FUNCTION W3GRMC_R8 + !/ + !/ End of W3GRMC ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3CKCL( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) & + !/ RESULT(INCELL) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Check if point lies within grid cell. + ! + ! 2. Method : + ! + ! Calculates cross products for vertex to vertex (i.e. cell side) + ! vs vertex to target. If all cross products have the same sign, + ! the point is considered to be within the cell. Since they can + ! be "all positive" *or* "all negative", there are no pre-conditions + ! that the order of specification of the vertices be clockwise vs. + ! counter-clockwise geographically. The logical variable POLE is + ! set to true if the grid cell includes a pole. + ! + ! 3. Parameters : + ! + ! Return parameter + ! ---------------------------------------------------------------- + ! INCELL Log. O Logical flag indicating point is in the cell + ! ---------------------------------------------------------------- + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! LLG Log. I Logical flag indicating the coordinate system: + ! T = spherical lat/lon (degrees) and F = Cartesian. + ! XT Real I X-coordinate of target point. + ! YT Real I Y-coordinate of target point. + ! XS R.A. I X-coordinates of source cell vertices. + ! YS R.A. I Y-coordinates of source cell vertices. + ! POLE Log. O OPTIONAL output logical flag to indicate + ! the source cell contains a pole. + ! EPS Real I OPTIONAL small non-zero tolerance used to check + ! for point coincidence. + ! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. + ! Default is FALSE. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - For LL grids, this method assumes that the longitudes of point + ! and grid cell vertices lie in the same range (i.e., both in [0:360] + ! or [-180:180]). If the longitudes are not in the same range, then + ! this method may result in a false positive. The burden is upon the + ! caller to ensure that the longitude range of the point is the same + ! as that of the grid cell vertices. + ! - If enclosing cell includes a branch cut, then the coordinates of + ! of the cell vertices AND the target point will be adjusted so + ! that the branch cut is shifted 180 degrees. + ! - If the enclosing cell includes a pole, then the cross-product check + ! is performed using coordinates in a stereographic projection. + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3CKCL_R4( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) & + RESULT(INCELL) + ! Single precision interface + LOGICAL :: INCELL + LOGICAL, INTENT(IN) :: LLG + REAL(4), INTENT(INOUT) :: XT, YT + INTEGER, INTENT(IN) :: NS + REAL(4), INTENT(INOUT) :: XS(NS), YS(NS) + LOGICAL, INTENT(OUT) :: POLE + REAL(4), INTENT(IN), OPTIONAL :: EPS + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: XT8, YT8, XS8(NS), YS8(NS), EPS8 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GRMP_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3CKCL_R4') #endif -! -!-----set inputs - XT8 = XTIN; YT8 = YTIN; - IF ( PRESENT(EPS) ) THEN - EPS8 = EPS - ELSE - EPS8 = EPS_DEFAULT + ! + !-----set inputs + XT8 = XT; XS8 = XS; + YT8 = YT; YS8 = YS; + IF ( PRESENT(EPS) ) THEN + EPS8 = EPS + ELSE + EPS8 = EPS_DEFAULT + END IF + ! + !-----call double precision method + INCELL = W3CKCL( LLG, XT8, YT8, NS, XS8, YS8, POLE, & + EPS=EPS8, DEBUG=DEBUG ) + ! + !-----return branch cut shifted coordinates + XT = XT8; XS = XS8; + + END FUNCTION W3CKCL_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3CKCL_R8( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) & + RESULT(INCELL) + ! Double precision interface + LOGICAL :: INCELL + LOGICAL, INTENT(IN) :: LLG + REAL(8), INTENT(INOUT) :: XT, YT + INTEGER, INTENT(IN) :: NS + REAL(8), INTENT(INOUT) :: XS(NS), YS(NS) + LOGICAL, INTENT(OUT) :: POLE + REAL(8), INTENT(IN), OPTIONAL :: EPS + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + REAL(8) :: LEPS + LOGICAL :: LDBG, LSBC, BCUT + INTEGER :: I, J, K, N + REAL(8) :: XXT, YYT, XXS(NS), YYS(NS) + REAL(8) :: XCT, YCT, XCS(NS), YCS(NS) + REAL(8) :: V1X, V1Y, V2X, V2Y, S90 + REAL(8) :: CROSS + REAL(8) :: SIGN1 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3CKCL_R8') +#endif + + INCELL = .TRUE. + ! + !-----must have >= 3 points to be a cell + IF ( NS .LT. 3 ) THEN + INCELL = .FALSE. + RETURN + END IF + ! + IF ( PRESENT(EPS) ) THEN + IF ( EPS .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'W3CKCL_R8 ERROR -- ', & + 'EPS parameter must be >= 0' + CALL EXTCDE (1) + END IF + LEPS = EPS + ELSE + LEPS = EPS_DEFAULT + END IF + IF ( PRESENT(DEBUG) ) THEN + LDBG = DEBUG + ELSE + LDBG = .FALSE. + END IF + ! + !-----set local copies + XXT = XT; XXS = XS; + YYT = YT; YYS = YS; + ! + !-----check if cell includes a pole or branch cut + IF ( LLG ) THEN + N = 0 + !---------count longitudinal branch cut crossings + DO I=1,NS + J = MOD(I,NS) + 1 + IF ( ABS(XXS(J)-XXS(I)) .GT. D180 ) N = N + 1 + END DO + !---------multiple longitudinal branch cut crossing => cell includes branch cut + BCUT = N.GT.1 + !---------single longitudinal branch cut crossing + ! or single vertex at 90 degrees => cell includes pole + POLE = N.EQ.1 .OR. COUNT(ABS(D90-ABS(YYS)).LE.LEPS).EQ.1 + ELSE + POLE = .FALSE. + BCUT = .FALSE. + END IF + ! + !-----shift branch cut if necessary + IF ( BCUT ) THEN + IF ( MINVAL(XXS) .GE. ZERO ) THEN + WHERE ( XXS .GT. D180 ) XXS = XXS - D360 + IF ( XXT .GT. D180 ) XXT = XXT - D360 + ELSE + WHERE ( XXS .LT. ZERO ) XXS = XXS + D360 + IF ( XXT .LT. ZERO ) XXT = XXT + D360 + END IF + IF ( LDBG ) THEN + WRITE(*,'(A)') 'W3CKCL_R8 - CELL INCLUDES A BRANCH CUT' + WRITE(*,'(A,2E24.16,4(/A,1I1,A,2E24.16))') & + 'W3CKCL_R8 - SHIFT BRANCH CUT:',XXT,YYT, & + (' CORNER(',K,'):',XXS(K),YYS(K),K=1,4) + END IF + END IF + ! + !-----check for coincidence with a cell vertex + DO I=1,NS + !---------if target point is coincident a cell vertex, then + ! flag as in cell and return + IF ( ABS(XXT-XXS(I)).LE.LEPS .AND. ABS(YYT-YYS(I)).LE.LEPS ) THEN + IF ( LDBG ) & + WRITE(*,'(A,I1,A,2E24.16)') & + 'W3CKCL_R8 - COINCIDENT WITH CORNER(',I,'): ', & + ABS(XXT-XXS(I)),ABS(YYT-YYS(I)) + !-------------return branch cut shifted coordinates + IF ( BCUT ) THEN + XT = XXT; XS = XXS; END IF - IF ( PRESENT(DCIN) ) THEN - DCIN8 = DCIN - ELSE - DCIN8 = ZERO + INCELL = .TRUE. + RETURN + END IF + END DO + ! + !-----handle cell that includes a pole + IF ( POLE ) THEN + !---------perform cross-product check for each subcell + IF ( LDBG ) & + WRITE(*,'(A)') 'W3CKCL_R8 - CELL INCLUDES A POLE' + S90 = D90; IF ( MAXVAL(YS).LT.ZERO ) S90 = -D90; + SUBCELL_LOOP: DO I=1,NS + LSBC = .TRUE. + J = MOD(I,NS) + 1 + SIGN1 = 0.0 + DO K=1,4 + SELECT CASE (K) + CASE (1) + !---------------------vector from (xi,yi) to (xj,yj) + V1X = XXS(J) - XXS(I) + V1Y = YYS(J) - YYS(I) + !---------------------vector from (xi,yi) to (xt,yt) + V2X = XXT - XXS(I) + V2Y = YYT - YYS(I) + CASE (2) + !---------------------vector from (xj,yj) to (xj,90) + V1X = XXS(J) - XXS(J) + V1Y = S90 - YYS(J) + !---------------------vector from (xj,yj) to (xt,yt) + V2X = XXT - XXS(J) + V2Y = YYT - YYS(J) + CASE (3) + !---------------------vector from (xj,90) to (xi,90) + V1X = XXS(I) - XXS(J) + V1Y = S90 - S90 + !---------------------vector from (xj,90) to (xt,yt) + V2X = XXT - XXS(J) + V2Y = YYT - S90 + CASE (4) + !---------------------vector from (xi,90) to (xi,yi) + V1X = XXS(I) - XXS(I) + V1Y = YYS(I) - S90 + !---------------------vector from (xi,90) to (xt,yt) + V2X = XXT - XXS(I) + V2Y = YYT - S90 + END SELECT + !-----------------check for longitudinal branch cut crossing + IF ( ABS(V1X) .GT. D180 ) THEN + V1X = V1X - SIGN(D360,V1X) + END IF + IF ( ABS(V2X) .GT. D180 ) THEN + V2X = V2X - SIGN(D360,V2X) + END IF + !-----------------cross product + CROSS = V1X*V2Y - V1Y*V2X + !-----------------handle point that lies exacly on side or zero length side + IF ( ABS(CROSS) .LT. LEPS ) CROSS = ZERO + IF ( LDBG ) & + WRITE(*,'(A,3(I1,A),5E24.16)') 'W3CKCL_R8 - CROSS(', & + I,',',J,',',K,'):',V1X,V1Y,V2X,V2Y,CROSS + !-----------------if sign of cross product is not "unanimous" among the + ! subcell sides, then target is outside the subcell + IF ( ABS(SIGN1) .LE. LEPS ) THEN + IF (ABS(CROSS) .GT. LEPS) SIGN1 = SIGN(ONE,CROSS) + ELSE + ! If point lies along a border, the cross product + ! is zero and its sign is not well defined + IF ( ABS(CROSS) .GT. LEPS ) THEN + IF ( SIGN(ONE,CROSS) .NE. SIGN1 ) THEN + LSBC = .FALSE. + CYCLE SUBCELL_LOOP + END IF + END IF + END IF + END DO !K + IF ( LSBC ) RETURN + END DO SUBCELL_LOOP + INCELL = .FALSE. + RETURN + ELSE + !---------use input coordinates + XCT = XXT; YCT = YYT; + XCS = XXS; YCS = YYS; + END IF !POLE + ! + !-----perform cross-product cell check + SIGN1 = 0.0 + DO I=1,NS + J = MOD(I,NS) + 1 + !---------vector from (xi,yi) to (xj,yj) + V1X = XCS(J) - XCS(I) + V1Y = YCS(J) - YCS(I) + !---------vector from (xi,yi) to (xt,yt) + V2X = XCT - XCS(I) + V2Y = YCT - YCS(I) + !---------cross product + CROSS = V1X*V2Y - V1Y*V2X + !---------handle point that lies exacly on side or zero length side + IF ( ABS(CROSS) .LT. LEPS ) CROSS = ZERO + IF ( LDBG ) & + WRITE(*,'(A,2(I1,A),5E24.16)') 'W3CKCL_R8 - CROSS(', & + I,',',J,'):',V1X,V1Y,V2X,V2Y,CROSS + !---------if sign of cross product is not "unanimous" among the cell sides, + ! then target is outside the cell + IF ( ABS(SIGN1) .LE. LEPS ) THEN + IF (ABS(CROSS) .GT. LEPS) SIGN1 = SIGN(ONE,CROSS) + ELSE + ! If point lies along a border, the cross product + ! is zero and its sign is not well defined + IF ( ABS(CROSS) .GT. LEPS ) THEN + IF ( SIGN(ONE,CROSS) .NE. SIGN1 ) THEN + INCELL = .FALSE. + RETURN + END IF END IF -! -!-----call double precision method - INGRID = W3GRMP( GSU, XT8, YT8, IS, JS, RW8, & - EPS=EPS8, DCIN=DCIN8, & - MASK=MASK, MSKC=MSKC, NNBR=NNBR, DEBUG=DEBUG ) -! -!-----set outputs - RW = RW8 - - END FUNCTION W3GRMP_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GRMP_R8( GSU, XTIN, YTIN, IS, JS, RW, EPS, & - DCIN, MASK, MSKC, NNBR, DEBUG ) RESULT(INGRID) -! Double precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(8), INTENT(IN) :: XTIN - REAL(8), INTENT(IN) :: YTIN - INTEGER, INTENT(OUT) :: IS(4) - INTEGER, INTENT(OUT) :: JS(4) - REAL(8), INTENT(OUT) :: RW(4) - REAL(8), INTENT(IN) , OPTIONAL :: EPS - REAL(8), INTENT(IN) , OPTIONAL :: DCIN - LOGICAL, INTENT(IN) , OPTIONAL :: MASK(:,:) - INTEGER, INTENT(OUT) , OPTIONAL :: MSKC - INTEGER, INTENT(INOUT), OPTIONAL :: NNBR - LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG - -! Local parameters - REAL(8), PARAMETER :: BIG = 1D16 - REAL(8), PARAMETER :: SMALL = 1D-6 - REAL(8) :: LEPS - LOGICAL :: LDBG, FNCL, POLE - INTEGER :: I, J, L - LOGICAL :: M, MSK(4) - INTEGER :: LVL, N, NS, ICC, JCC - REAL(8) :: XT, YT, XS(4), YS(4), DW(4) - REAL(8) :: XTC, YTC, XSC(4), YSC(4) - REAL(8) :: LDCIN, IXR, JXR, X, Y, D(4), DD, DMIN, DSUM, LON0, LAT0 - LOGICAL :: IJG, LLG, LCLO - INTEGER :: ICLO, GKIND - INTEGER :: LBX, LBY, UBX, UBY, NX, NY - REAL(4), POINTER :: XG4(:,:), YG4(:,:) - REAL(8), POINTER :: XG8(:,:), YG8(:,:) - TYPE(T_NNS), POINTER :: NNP + END IF + END DO + ! + !-----return branch cut shifted coordinates + IF ( BCUT ) THEN + XT = XXT; XS = XXS; + END IF + + END FUNCTION W3CKCL_R8 + !/ + !/ End of W3CKCL ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3CGDM( IJG, LLG, ICLO, PTILED, QTILED, & + !/ PRANGE, QRANGE, LBI, UBI, LBO, UBO, X, Y, & + !/ MASK, NFD, SPHERE, RADIUS, DX, DY, & + !/ GPPC, GQQC, GPQC, GSQR, & + !/ HPFC, HQFC, APPC, AQQC, APQC, & + !/ DXDP, DYDP, DXDQ, DYDQ, & + !/ DPDX, DPDY, DQDX, DQDY, & + !/ COSA, COSC, SINC, ANGL, RC ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute curvilinear grid derivatives and metric. + ! + ! 2. Method : + ! + ! Curvilinear grid is defined by the input coordinates as a function + ! of the (P,Q) index coordinates: + ! + ! x = x(p,q), y = y(p,q), dp = dq = 1. + ! + ! When using spherical coordinates (llg=T) x = longitude and + ! y = latitude in degrees. The optional sphere input (default is true) + ! controls whether or not the spherical coordinate metric is applied. + ! If sphere is true, then the spherical coordinate metric is applied + ! to the coordinate derivatives with respect to p & q. In other words, + ! + ! dx/dp <= d2r*radius*cos(y)*(dx/dp), + ! dx/dq <= d2r*radius*cos(y)*(dx/dq), + ! dy/dp <= d2r*radius*(dy/dp), and + ! dy/dq <= d2r*radius*(dy/dq). + ! + ! The default radius is Rearth. + ! + ! The covariant metric tensor components are + ! + ! g_pp = (dx/dp)*(dx/dp) + (dy/dp)*(dy/dp), + ! g_qq = (dx/dq)*(dx/dq) + (dy/dq)*(dy/dq), + ! g_pq = (dx/dp)*(dx/dq) + (dy/dp)*(dy/dq). + ! + ! The contravariant (associated) metric tensor components are + ! + ! g^pp = (dp/dx)*(dp/dx) + (dp/dy)*(dp/dy), + ! g^qq = (dq/dx)*(dq/dx) + (dq/dy)*(dq/dy), + ! g^pq = (dp/dx)*(dq/dx) + (dp/dy)*(dq/dy). + ! + ! The curvilinear scale factors are h_p = sqrt(g_pp) and h_q = sqrt(g_qq). + ! The square root of determinant of metric tensor is + ! + ! sqrt(|g|) = sqrt( g_pp*g_qq - g_pq^2 ) + ! = (dx/dp)(dy/dq) - (dx/dq)(dy/dp) + ! = h_p*h_q*sqrt(sin(alpha)) + ! = cell area. + ! + ! The curvilinear derivatives are computed as + ! + ! dp/dx = (1/sqrt(g))*(dy/dq), + ! dp/dy = -(1/sqrt(g))*(dx/dq), + ! dq/dx = -(1/sqrt(g))*(dy/dp), + ! dq/dy = (1/sqrt(g))*(dx/dp). + ! + ! Orthogonality of grid can be checked by computing angle between the + ! curvilinear coordinate unit vectors: + ! + ! cos(alpha) = g_pq/(h_p*h_q) = uvec_p \dot uvec_q, + ! + ! where + ! + ! uvec_p = (1/h_p)*(dx/dp)*uvec_x + (1/h_p)*(dy/dp)*uvec_y, + ! uvec_q = (1/h_q)*(dx/dq)*uvec_x + (1/h_q)*(dy/dq)*uvec_y. + ! + ! The local cell rotation angle is (assuming orthogonal): + ! + ! cos(theta) = (1/h_p)*dx/dp, + ! sin(theta) = (1/h_q)*dy/dp, + ! theta = atan2((1/h_q)*dy/dp,(1/h_p)*dx/dp). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IJG Log. I Logical flag indicating ordering of input + ! coord. arrays: T = (NP,NQ) and F = (NP,NQ) + ! LLG Log. I Spherical coordinate (lon,lat) flag + ! ICLO Int. I Parameter indicating type of index space closure + ! PTILED Log. I Logical flag indicating that input arrays are tiled + ! in P-axis with halos of width >= NFD/2 + ! QTILED Log. I Logical flag indicating that input arrays are tiled + ! in Q-axis with halos of width >= NFD/2 + ! PRANGE I.A. I Range of P index coordinate: P in [PRANGE(1),PRANGE(2)] + ! QRANGE I.A. I Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)] + ! LBI I.A. I Lower-bound of input arrays, DIMENSION(2) + ! UBI I.A. I Upper-bound of input arrays, DIMENSION(2) + ! LBO I.A. I Lower-bound of output arrays, DIMENSION(2) + ! UBO I.A. I Upper-bound of output arrays, DIMENSION(2) + ! X R.A. I Gridded X-coordinates, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! Y R.A. I Gridded Y-coordinates, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! MASK L.A. I OPTIONAL logical mask (T = invalid, F = valid) + ! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! NFD Int. I OPTIONAL finite-difference order (even), Default is NFD_DEFAULT. + ! SPHERE Log. I OPTIONAL apply spherical coord metric if LLG, Default is T + ! RADIUS Real I OPTIONAL radius for sphere. Default is REARTH + ! DX Real I OPTIONAL constant spacing in x-direction + ! DY Real I OPTIONAL constant spacing in y-direction + ! GPPC R.A. O OPTIONAL g_pp, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! GQQC R.A. O OPTIONAL g_qq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! GPQC R.A. O OPTIONAL g_pq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! GSQR R.A. O OPTIONAL sqrt(|g|), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! HPFC R.A. O OPTIONAL h_p, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! HQFC R.A. O OPTIONAL h_q, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! APPC R.A. O OPTIONAL g^pp, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! AQQC R.A. O OPTIONAL g^qq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! APQC R.A. O OPTIONAL g^pq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! DXDP R.A. O OPTIONAL dx/dp, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! DYDP R.A. O OPTIONAL dy/dp, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! DXDQ R.A. O OPTIONAL dx/dq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! DYDQ R.A. O OPTIONAL dy/dq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! DPDX R.A. O OPTIONAL dp/dx, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! DPDY R.A. O OPTIONAL dp/dy, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! DQDX R.A. O OPTIONAL dq/dx, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! DQDY R.A. O OPTIONAL dq/dy, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! COSA R.A. O OPTIONAL cos(alpha), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! COSC R.A. O OPTIONAL cos(theta), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! SINC R.A. O OPTIONAL sin(theta), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! ANGL R.A. O OPTIONAL theta, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! RC Int. O OPTIONAL return code (!= 0 if error occurs) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - The derivatives and metric will be computed using the constant + ! spacing DX and/or DY if they are specified. DX & DY are assumed + ! to be in degrees when LLG = T. + ! - The grid derivatives (dx/dp, dy/dp, dx/dq, dy/dq) are computed + ! using a finite difference method. + ! - When LLG = T, the finite differences are done in a polar + ! stereographic projection. + ! - If RC is not provided and an error occurs, then the routine will + ! report error to stderr and attempt to abort the calling program. + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3CGDM_R4( IJG, LLG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, X, Y, & + MASK, NFD, SPHERE, RADIUS, DX, DY, & + GPPC, GQQC, GPQC, GSQR, & + HPFC, HQFC, APPC, AQQC, APQC, & + DXDP, DYDP, DXDQ, DYDQ, & + DPDX, DPDY, DQDX, DQDY, & + COSA, COSC, SINC, ANGL, RC ) + ! Single precision interface + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LBI(2), UBI(2) + INTEGER, INTENT(IN) :: LBO(2), UBO(2) + REAL(4), INTENT(IN) :: X(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: Y(LBI(1):UBI(1),LBI(2):UBI(2)) + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) + INTEGER, INTENT(IN), OPTIONAL :: NFD + LOGICAL, INTENT(IN), OPTIONAL :: SPHERE + REAL(4), INTENT(IN), OPTIONAL :: RADIUS + REAL(4), INTENT(IN), OPTIONAL :: DX, DY + REAL(4), INTENT(OUT), OPTIONAL :: GPPC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: GQQC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: GPQC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: GSQR(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: HPFC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: HQFC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: APPC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: AQQC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: APQC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: DXDP(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: DYDP(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: DXDQ(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: DYDQ(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: DPDX(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: DPDY(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: DQDX(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: DQDY(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: COSA(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: COSC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: SINC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT), OPTIONAL :: ANGL(LBO(1):UBO(1),LBO(2):UBO(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + REAL(8), PARAMETER :: SMALL = 1D-15 + INTEGER :: ISTAT=0, N, NP, NQ, I1, I2, P, Q + LOGICAL :: SPHR + REAL(8) :: R, FACX, FACY + INTEGER, ALLOCATABLE :: K(:,:,:), K2(:,:,:) + REAL(8), ALLOCATABLE :: C(:,:,:), C2(:,:,:) + REAL(8) :: GPPCL, GQQCL, GPQCL + REAL(8) :: GSQRL, HPFCL, HQFCL + REAL(8) :: APPCL, AQQCL, APQCL + REAL(8) :: DXDPL, DYDPL, DXDQL, DYDQL + REAL(8) :: DPDXL, DPDYL, DQDXL, DQDYL + REAL(8) :: COSAL, SINAL, COSTP, SINTP, COSCL, SINCL, ANGLL #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GRMP_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3CGDM_R4') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input -! - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & - 'grid search utility object not created' - CALL EXTCDE (1) + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + IF ( PRESENT(NFD) ) THEN + N = NFD + ELSE + N = NFD_DEFAULT + END IF + IF ( N.LE.0 .OR. MOD(N,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & + 'NFD must be even and greater than zero' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) + CONTINUE + CASE DEFAULT + WRITE(0,'(/1A,1A,1I2/)') 'W3CGDM ERROR -- ', & + 'unsupported ICLO: ',ICLO + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END SELECT + + IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & + 'tripole grid closure requires NP even' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + IF ( PRESENT(SPHERE) ) THEN + SPHR = SPHERE + ELSE + SPHR = .TRUE. + END IF + + IF ( PRESENT(RADIUS) ) THEN + R = RADIUS + ELSE + R = REARTH + END IF + FACY = R*D2R + + IF ( PRESENT(DX) ) THEN + IF ( DX.LE.ZERO ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DX must be > 0' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) END IF -! - IF ( PRESENT(EPS) ) THEN - IF ( EPS .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & - 'EPS parameter must be >= 0' - CALL EXTCDE (1) - END IF - LEPS = EPS + END IF + END IF + + IF ( PRESENT(DY) ) THEN + IF ( DY.LE.ZERO ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DY must be > 0' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Setup finite difference coefficients + ! + ALLOCATE ( K(0:N,0:N,1:N), C(0:N,0:N,1:N), STAT=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & + 'finite difference coeff allocation failed' + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + CALL GET_FDW3 ( N, M, K, C ) + + ALLOCATE ( K2(0:2,0:2,1:2), C2(0:2,0:2,1:2), STAT=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & + 'finite difference coeff allocation for N=2 failed' + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + CALL GET_FDW3 ( 2, M, K2, C2 ) + ! + ! -------------------------------------------------------------------- / + ! 3. Compute optional return quantities + ! + DO I2 = LBO(2), UBO(2) + DO I1 = LBO(1), UBO(1) + IF ( IJG ) THEN + P = I1 + Q = I2 ELSE - LEPS = EPS_DEFAULT + P = I2 + Q = I1 END IF -! - IF ( PRESENT(DCIN) ) THEN - IF ( DCIN .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GRMP_R4 ERROR -- ', & - 'DCIN parameter must be >= 0' - CALL EXTCDE (1) + IF ( PRESENT(DX) ) THEN + DXDPL = DX + DYDPL = ZERO + ELSE + CALL DXYDP( N, K, C, IJG, LLG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, DXDPL, DYDPL, & + MASK=MASK, X4=X, Y4=Y, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) END IF - LDCIN = DCIN + END IF + END IF + IF ( PRESENT(DY) ) THEN + DXDQL = ZERO + DYDQL = DY ELSE - LDCIN = ZERO + CALL DXYDQ( N, K, C, IJG, LLG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, DXDQL, DYDQL, & + MASK=MASK, X4=X, Y4=Y, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF END IF -! - IF ( PRESENT(MASK) ) THEN - IF ( .NOT.PRESENT(MSKC) ) THEN - WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & - 'MSKC must be specified with MASK' - CALL EXTCDE (1) + IF ( LLG .AND. SPHR ) THEN + FACX = FACY*COS(REAL(Y(I1,I2),8)*D2R) + DXDPL = DXDPL*FACX + DYDPL = DYDPL*FACY + DXDQL = DXDQL*FACX + DYDQL = DYDQL*FACY + END IF + GSQRL = DXDPL*DYDQL - DXDQL*DYDPL + IF ( GSQRL .LT. ZERO .AND. N .GT. 2 ) THEN + ! WRITE(0,'(1A,1I0,1A,1I0,1A,1I0,2A)') & + ! 'W3CGDM WARNING -- NFD = ',N, & + ! ' yields GSQRL < 0 at (',P,',',Q,'):', & + ! ' computing metrics using NFD = 2' + IF ( PRESENT(DX) ) THEN + DXDPL = DX + DYDPL = ZERO + ELSE + CALL DXYDP( 2, K2, C2, IJG, LLG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, DXDPL, DYDPL, & + MASK=MASK, X4=X, Y4=Y, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF END IF - IF ( PRESENT(NNBR) ) THEN - IF ( .NOT.ASSOCIATED(GSU%PTR%NNP) ) THEN - WRITE(0,'(/3A/)') 'W3GRMP_R8 ERROR -- ', & - 'MASK and NNBR input specified, ', & - 'but grid point-search object not created' - CALL EXTCDE (1) - END IF - IF ( NNBR .LE. 0 .OR. NNBR .GT. 4 ) THEN - WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & - 'NNBR must be >= 1 AND <= 4' - CALL EXTCDE (1) - END IF + END IF + IF ( PRESENT(DY) ) THEN + DXDQL = ZERO + DYDQL = DY + ELSE + CALL DXYDQ( 2, K2, C2, IJG, LLG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, DXDQL, DYDQL, & + MASK=MASK, X4=X, Y4=Y, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF END IF + END IF + IF ( LLG .AND. SPHR ) THEN + FACX = FACY*COS(REAL(Y(I1,I2),8)*D2R) + DXDPL = DXDPL*FACX + DYDPL = DYDPL*FACY + DXDQL = DXDQL*FACX + DYDQL = DYDQL*FACY + END IF + GSQRL = DXDPL*DYDQL - DXDQL*DYDPL + END IF + IF ( GSQRL .LT. ZERO ) THEN + ISTAT = 1 + WRITE(0,'(/1A,1A)') 'W3CGDM ERROR -- ', & + 'input coordinates do not define a '// & + 'right-handed coordinate system' + WRITE(0,'(1A,2A6,5A16)') 'W3CGDM ERROR --', & + 'P','Q','GSQRL','DXDPL','DYDQL','DXDQL','DYDPL' + WRITE(0,'(1A,2I6,5E16.8/)') 'W3CGDM ERROR --', & + P,Q,GSQRL,DXDPL,DYDQL,DXDQL,DYDPL + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + GPPCL = DXDPL*DXDPL + DYDPL*DYDPL + GQQCL = DXDQL*DXDQL + DYDQL*DYDQL + GPQCL = DXDPL*DXDQL + DYDPL*DYDQL + GSQRL = MAX(GSQRL,SMALL) + GPPCL = MAX(GPPCL,SMALL) + GQQCL = MAX(GQQCL,SMALL) + DPDXL = DYDQL/GSQRL + DPDYL =-DXDQL/GSQRL + DQDXL =-DYDPL/GSQRL + DQDYL = DXDPL/GSQRL + APPCL = DPDXL*DPDXL + DPDYL*DPDYL + AQQCL = DQDXL*DQDXL + DQDYL*DQDYL + APQCL = DPDXL*DQDXL + DPDYL*DQDYL + HPFCL = SQRT(GPPCL) + HQFCL = SQRT(GQQCL) + COSAL = GPQCL/(HPFCL*HQFCL) + SINAL = GSQRL**2/(GPPCL*GQQCL) + COSTP = DXDPL/HPFCL + SINTP = DYDPL/HQFCL + COSCL = SINAL*COSTP + COSAL*SINTP + SINCL = SINAL*SINTP - COSAL*COSTP + ANGLL = ATAN2(SINCL,COSCL)*R2D + IF (PRESENT(GPPC)) GPPC(I1,I2) = GPPCL + IF (PRESENT(GQQC)) GQQC(I1,I2) = GQQCL + IF (PRESENT(GPQC)) GPQC(I1,I2) = GPQCL + IF (PRESENT(APPC)) APPC(I1,I2) = APPCL + IF (PRESENT(AQQC)) AQQC(I1,I2) = AQQCL + IF (PRESENT(APQC)) APQC(I1,I2) = APQCL + IF (PRESENT(GSQR)) GSQR(I1,I2) = GSQRL + IF (PRESENT(HPFC)) HPFC(I1,I2) = HPFCL + IF (PRESENT(HQFC)) HQFC(I1,I2) = HQFCL + IF (PRESENT(DXDP)) DXDP(I1,I2) = DXDPL + IF (PRESENT(DYDP)) DYDP(I1,I2) = DYDPL + IF (PRESENT(DXDQ)) DXDQ(I1,I2) = DXDQL + IF (PRESENT(DYDQ)) DYDQ(I1,I2) = DYDQL + IF (PRESENT(DPDX)) DPDX(I1,I2) = DPDXL + IF (PRESENT(DPDY)) DPDY(I1,I2) = DPDYL + IF (PRESENT(DQDX)) DQDX(I1,I2) = DQDXL + IF (PRESENT(DQDY)) DQDY(I1,I2) = DQDYL + IF (PRESENT(COSA)) COSA(I1,I2) = COSAL + IF (PRESENT(COSC)) COSC(I1,I2) = COSCL + IF (PRESENT(SINC)) SINC(I1,I2) = SINCL + IF (PRESENT(ANGL)) ANGL(I1,I2) = ANGLL + END DO !I1 + END DO !I2 + ! + ! -------------------------------------------------------------------- / + ! 4. Clean up + ! + DEALLOCATE ( K, C, K2, C2 ) + + END SUBROUTINE W3CGDM_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3CGDM_R8( IJG, LLG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, X, Y, & + MASK, NFD, SPHERE, RADIUS, DX, DY, & + GPPC, GQQC, GPQC, GSQR, & + HPFC, HQFC, APPC, AQQC, APQC, & + DXDP, DYDP, DXDQ, DYDQ, & + DPDX, DPDY, DQDX, DQDY, & + COSA, COSC, SINC, ANGL, RC ) + ! Double precision interface + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LBI(2), UBI(2) + INTEGER, INTENT(IN) :: LBO(2), UBO(2) + REAL(8), INTENT(IN) :: X(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: Y(LBI(1):UBI(1),LBI(2):UBI(2)) + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) + INTEGER, INTENT(IN), OPTIONAL :: NFD + LOGICAL, INTENT(IN), OPTIONAL :: SPHERE + REAL(8), INTENT(IN), OPTIONAL :: RADIUS + REAL(8), INTENT(IN), OPTIONAL :: DX, DY + REAL(8), INTENT(OUT), OPTIONAL :: GPPC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: GQQC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: GPQC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: GSQR(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: HPFC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: HQFC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: APPC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: AQQC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: APQC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DXDP(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DYDP(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DXDQ(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DYDQ(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DPDX(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DPDY(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DQDX(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DQDY(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: COSA(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: COSC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: SINC(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT), OPTIONAL :: ANGL(LBO(1):UBO(1),LBO(2):UBO(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + REAL(8), PARAMETER :: SMALL = 1D-15 + INTEGER :: ISTAT=0, N, NP, NQ, I1, I2, P, Q + LOGICAL :: SPHR + REAL(8) :: R, FACX, FACY + INTEGER, ALLOCATABLE :: K(:,:,:), K2(:,:,:) + REAL(8), ALLOCATABLE :: C(:,:,:), C2(:,:,:) + REAL(8) :: GPPCL, GQQCL, GPQCL + REAL(8) :: GSQRL, HPFCL, HQFCL + REAL(8) :: APPCL, AQQCL, APQCL + REAL(8) :: DXDPL, DYDPL, DXDQL, DYDQL + REAL(8) :: DPDXL, DPDYL, DQDXL, DQDYL + REAL(8) :: COSAL, SINAL, COSTP, SINTP, COSCL, SINCL, ANGLL +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3CGDM_R8') +#endif + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + IF ( PRESENT(NFD) ) THEN + N = NFD + ELSE + N = NFD_DEFAULT + END IF + IF ( N.LE.0 .OR. MOD(N,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & + 'NFD must be even and greater than zero' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) + CONTINUE + CASE DEFAULT + WRITE(0,'(/1A,1A,1I2/)') 'W3CGDM ERROR -- ', & + 'unsupported ICLO: ',ICLO + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END SELECT + + IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & + 'tripole grid closure requires NP even' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + IF ( PRESENT(SPHERE) ) THEN + SPHR = SPHERE + ELSE + SPHR = .TRUE. + END IF + + IF ( PRESENT(RADIUS) ) THEN + R = RADIUS + ELSE + R = REARTH + END IF + FACY = R*D2R + + IF ( PRESENT(DX) ) THEN + IF ( DX.LE.ZERO ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DX must be > 0' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) END IF -! -! -------------------------------------------------------------------- / -! 2. Initialize search -! - IF ( PRESENT(DEBUG) ) THEN - LDBG = DEBUG + END IF + END IF + + IF ( PRESENT(DY) ) THEN + IF ( DY.LE.ZERO ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DY must be > 0' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN ELSE - LDBG = .FALSE. + CALL EXTCDE (ISTAT) END IF -! -! Local pointers to grid search utility object data - IJG = GSU%PTR%IJG - LLG = GSU%PTR%LLG - ICLO = GSU%PTR%ICLO - LCLO = GSU%PTR%LCLO - GKIND = GSU%PTR%GKIND - LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; - UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; - NX = GSU%PTR%NX; NY = GSU%PTR%NY; - IF ( GKIND.EQ.4 ) THEN - XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Setup finite difference coefficients + ! + ALLOCATE ( K(0:N,0:N,1:N), C(0:N,0:N,1:N), STAT=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & + 'finite difference coeff allocation failed' + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + CALL GET_FDW3 ( N, M, K, C ) + + ALLOCATE ( K2(0:2,0:2,1:2), C2(0:2,0:2,1:2), STAT=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & + 'finite difference coeff allocation for N=2 failed' + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + CALL GET_FDW3 ( 2, M, K2, C2 ) + ! + ! -------------------------------------------------------------------- / + ! 3. Compute optional return quantities + ! + DO I2 = LBO(2), UBO(2) + DO I1 = LBO(1), UBO(1) + IF ( IJG ) THEN + P = I1 + Q = I2 ELSE - XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; + P = I2 + Q = I1 END IF - NNP => GSU%PTR%NNP -! - IF ( PRESENT(MASK) ) THEN - IF ( IJG ) THEN - IF ( .NOT.(UBOUND(MASK,1).EQ.NX.AND. & - UBOUND(MASK,2).EQ.NY) ) THEN - WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & - 'MASK array size does not agree with GSU index bounds' - CALL EXTCDE (1) - END IF + IF ( PRESENT(DX) ) THEN + DXDPL = DX + DYDPL = ZERO + ELSE + CALL DXYDP( N, K, C, IJG, LLG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, DXDPL, DYDPL, & + MASK=MASK, X8=X, Y8=Y, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN ELSE - IF ( .NOT.(UBOUND(MASK,2).EQ.NX.AND. & - UBOUND(MASK,1).EQ.NY) ) THEN - WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & - 'MASK array size does not agree with GSU index bounds' - CALL EXTCDE (1) - END IF + CALL EXTCDE (ISTAT) END IF + END IF END IF -! - RW = ZERO; -! - XT = XTIN; YT = YTIN; - IF ( LDBG ) WRITE(*,'(/A,2E24.16)') 'W3GRMP_R8 - TARGET POINT:',XT,YT -! -! -------------------------------------------------------------------- / -! 3. Find enclosing cell and compute remapping -! - FNCL = LDCIN .GT. ZERO - INGRID = W3GFCL(GSU,XT,YT,IS,JS,XS,YS,POLE=POLE,EPS=LEPS,FNCL=FNCL,DEBUG=LDBG) - IF ( .NOT.INGRID .AND. .NOT.FNCL ) RETURN -! -!-----Compute remapping - LON0 = SUM(XS)/FOUR; LAT0 = SUM(YS)/FOUR; - IF ( D90-ABS(LAT0).GT.NEAR_POLE ) THEN -!---------non-pole cell: compute remapping using (lon,lat) - CALL GETPQR(XT,YT,XS,YS,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + IF ( PRESENT(DY) ) THEN + DXDQL = ZERO + DYDQL = DY ELSE -!---------pole cell: compute remapping using stereographic projection - CALL W3SPLX(LON0,LAT0,ZERO,XT,YT,XTC,YTC) - DO I=1,4 - CALL W3SPLX(LON0,LAT0,ZERO,XS(I),YS(I),XSC(I),YSC(I)) - END DO - CALL GETPQR(XTC,YTC,XSC,YSC,IXR,JXR,EPS=LEPS,DEBUG=LDBG) - ENDIF - DW(1) = (ONE-IXR)*(ONE-JXR) - DW(2) = IXR*(ONE-JXR) - DW(3) = IXR*JXR - DW(4) = (ONE-IXR)*JXR - RW = DW - IF ( LDBG ) THEN - WRITE(*,'(A,2E24.16)') 'W3GRMP_R8 - REMAP (TGT):',XT,YT - DO L=1,4 - WRITE(*,'(A,3I6,E24.16)') 'W3GRMP_R8 - REMAP (SRC):', & - L,IS(L),JS(L),DW(L) - END DO - END IF !LDBG -! -!-----Set in grid if point is within DCIN cell width distance of closest cell - IF ( .NOT.INGRID .AND. FNCL ) THEN - DD = HALF + LDCIN - INGRID = ABS(IXR-HALF).LE.DD .AND. ABS(JXR-HALF).LE.DD - END IF - IF ( .NOT.INGRID ) RETURN -! - IF ( .NOT.PRESENT(MASK) ) RETURN -! -! -------------------------------------------------------------------- / -! 4. Handle case of target point located within a partially masked cell. -! -!-----copy cell mask values according to array ordering - IF ( IJG ) THEN - DO L=1,4 - MSK(L) = MASK(IS(L)-LBX+1,JS(L)-LBY+1) - END DO - ELSE - DO L=1,4 - MSK(L) = MASK(JS(L)-LBY+1,IS(L)-LBX+1) - END DO + CALL DXYDQ( N, K, C, IJG, LLG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, DXDQL, DYDQL, & + MASK=MASK, X8=X, Y8=Y, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF END IF -! -!-----adjust weights for a partially masked cell - DSUM = ZERO - NS = 4 - DO L=1,4 - IF ( MSK(L) ) THEN - NS = NS - 1 - DW(L) = ZERO + IF ( LLG .AND. SPHR ) THEN + FACX = FACY*COS(REAL(Y(I1,I2),8)*D2R) + DXDPL = DXDPL*FACX + DYDPL = DYDPL*FACY + DXDQL = DXDQL*FACX + DYDQL = DYDQL*FACY + END IF + GSQRL = DXDPL*DYDQL - DXDQL*DYDPL + IF ( GSQRL .LT. ZERO .AND. N .GT. 2 ) THEN + ! WRITE(0,'(1A,1I0,1A,1I0,1A,1I0,2A)') & + ! 'W3CGDM WARNING -- NFD = ',N, & + ! ' yields GSQRL < 0 at (',P,',',Q,'):', & + ! ' computing metrics using NFD = 2' + IF ( PRESENT(DX) ) THEN + DXDPL = DX + DYDPL = ZERO + ELSE + CALL DXYDP( 2, K2, C2, IJG, LLG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, DXDPL, DYDPL, & + MASK=MASK, X8=X, Y8=Y, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF END IF - DSUM = DSUM + DW(L) - END DO - IF ( NS .EQ. 4 ) THEN - MSKC = MSKC_NONE - RETURN + END IF + IF ( PRESENT(DY) ) THEN + DXDQL = ZERO + DYDQL = DY + ELSE + CALL DXYDQ( 2, K2, C2, IJG, LLG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, DXDQL, DYDQL, & + MASK=MASK, X8=X, Y8=Y, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + END IF + IF ( LLG .AND. SPHR ) THEN + FACX = FACY*COS(REAL(Y(I1,I2),8)*D2R) + DXDPL = DXDPL*FACX + DYDPL = DYDPL*FACY + DXDQL = DXDQL*FACX + DYDQL = DYDQL*FACY + END IF + GSQRL = DXDPL*DYDQL - DXDQL*DYDPL END IF - IF ( NS .GT. 0 .AND. DSUM .GT. SMALL ) THEN - DW = DW / DSUM - RW = DW - IF ( LDBG ) & - WRITE(*,'(A,2E24.16,4(2I6,E24.16))') & - 'W3GRMP_R8 - PARTIAL MASKED CELL:', & - XT,YT,(IS(L),JS(L),DW(L),L=1,4) - MSKC = MSKC_PART - RETURN - ELSE - MSKC = MSKC_FULL - IF ( .NOT.PRESENT(NNBR) ) RETURN + IF ( GSQRL .LT. ZERO ) THEN + ISTAT = 1 + WRITE(0,'(/1A,1A)') 'W3CGDM ERROR -- ', & + 'input coordinates do not define a '// & + 'right-handed coordinate system' + WRITE(0,'(1A,2A6,5A16)') 'W3CGDM ERROR --', & + 'P','Q','GSQRL','DXDPL','DYDQL','DXDQL','DYDPL' + WRITE(0,'(1A,2I6,5E16.8/)') 'W3CGDM ERROR --', & + P,Q,GSQRL,DXDPL,DYDQL,DXDQL,DYDPL + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF END IF -! -! -------------------------------------------------------------------- / -! 5. Handle case of target point located within a fully masked cell. -! -! Choose closest point in enclosing land cell to be the central point - DMIN = BIG - DO L=1,4 - DD = W3DIST(LLG,XT,YT,XS(L),YS(L)) - IF ( DD .LT. DMIN ) THEN - DMIN = DD; ICC = IS(L); JCC = JS(L); - END IF - END DO !L -! -! Search nearest-neighbor source points for closest nnbr un-masked -! points and compute distance-weighted average remapping. - IF ( LDBG ) & - WRITE(*,'(A,2I6)') & - 'W3GRMP_R8 - BEGIN POINT NNBR SEARCH:',ICC,JCC - NS = 0; D(:) = BIG; - LEVEL_LOOP: DO LVL=0,NNP%NLVL - NNBR_LOOP: DO N=NNP%N1(LVL),NNP%N2(LVL) - I = ICC + NNP%DI(N); J = JCC + NNP%DJ(N); - IF ( ICLO.EQ.ICLO_NONE ) THEN - IF ( I.LT.LBX .OR. I.GT.UBX ) CYCLE NNBR_LOOP - IF ( J.LT.LBY .OR. J.GT.UBY ) CYCLE NNBR_LOOP - END IF -!-------------apply index closure - IF ( MOD(ICLO,2).EQ.0 ) & - I = LBX + MOD(NX - 1 + MOD(I - LBX + 1, NX), NX) - IF ( MOD(ICLO,3).EQ.0 ) & - J = LBY + MOD(NY - 1 + MOD(J - LBY + 1, NY), NY) - IF ( ICLO.EQ.ICLO_TRPL .AND. J.GT.UBY ) THEN - I = UBX + LBX - I - J = 2*UBY - J + 1 - END IF -!-------------set mask - IF ( IJG ) THEN - M = MASK(I-LBX+1,J-LBY+1) - ELSE - M = MASK(J-LBY+1,I-LBX+1) - END IF - IF ( LDBG ) & - WRITE(*,'(A,4I6,1L6)') & - 'W3GRMP_R8 - POINT NNBR SEARCH:',LVL,N,I,J,M -!-------------if masked point, then skip - IF ( M ) CYCLE NNBR_LOOP -!-------------compute distance - IF ( IJG ) THEN - IF ( GKIND.EQ.4 ) THEN - X = XG4(I,J); Y = YG4(I,J); - ELSE - X = XG8(I,J); Y = YG8(I,J); - END IF - ELSE - IF ( GKIND.EQ.4 ) THEN - X = XG4(J,I); Y = YG4(J,I); - ELSE - X = XG8(J,I); Y = YG8(J,I); - END IF - END IF - DD = W3DIST(LLG,XT,YT,X,Y) -!-------------still need nnbr points - IF ( NS .LT. NNBR ) THEN -!-----------------add to list - NS = NS + 1 - IS(NS) = I; JS(NS) = J; D(NS) = DD; -!-----------------once list is full sort according to increasing distance - IF ( NS .EQ. NNBR ) CALL W3SORT(NS,IS,JS,D) -!---------------we have found nnbr points - ELSE !list is full -!-----------------insert into list if the newest point is closer - CALL W3ISRT(I,J,DD,NS,IS,JS,D) - END IF !list is full - IF ( LDBG ) & - WRITE(*,'(A,I2,I3,I6,4(2I6,E24.16))') & - 'W3GRMP_R8 - POINT NNBR LIST:', & - LVL,N,NS,(IS(L),JS(L),D(L),L=1,NS) - END DO NNBR_LOOP -!---------if we have found nnbr_rqd points, then exit the search - IF ( NS .EQ. NNBR ) EXIT LEVEL_LOOP - END DO LEVEL_LOOP - NNBR = NS -! -! If zero unmasked points found, then return nnbr=0 as error indicator - IF ( NNBR .EQ. 0 ) RETURN -! -! Compute distance-weighted remapping for nnbr points - DSUM = ZERO - DO L=1,NNBR - DSUM = DSUM + ONE/(D(L)+SMALL) - END DO - DW(1:NNBR) = ONE/(D(1:NNBR)+SMALL)/DSUM - RW = DW - IF ( LDBG ) THEN - WRITE(*,'(A,2E24.16,I6)') & - 'W3GRMP_R8 - FULLY MASKED CELL (TGT):',XT,YT,NNBR - DO L=1,NNBR - WRITE(*,'(A,3I6,E24.16)') & - 'W3GRMP_R8 - FULLY MASKED CELL (SRC):', & - L,IS(L),JS(L),DW(L) - END DO - END IF !LDBG - - END FUNCTION W3GRMP_R8 -!/ -!/ End of W3GRMP ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3GRMC( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, & -!/ DCIN, WDTH, MASK, NMSK, DEBUG ) RESULT(INGRID) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute remapping coefficients for target point (XTIN,YTIN) from -! source grid associated with the input grid search utility object -! (GSU). The type of remapping is specified by RTYP. The indices -! of the source points used for remapping are returned in IS(1:NS) -! and JS(1:NS). The remapping coefficients are returned in CS(1:NS). -! -! 2. Method : -! -! 3. Parameters : -! -! Return parameter -! ---------------------------------------------------------------- -! INGRID Log. O Logical flag indicating if target point lies -! within the source grid domain. -! ---------------------------------------------------------------- -! -! Parameter list -! ---------------------------------------------------------------- -! GSU Type I Grid-search-utility object. -! XTIN Real I X-coordinate of target point. -! YTIN Real I Y-coordinate of target point. -! RTYP Str. I Remap type: 'nearpt', 'bilinr', 'bicubc', -! 'filter' -! NS Int. O Number of vertices for remapping -! IS,JS I.A. O (I,J) indices of vertices for remapping -! CS R.A. O Array of remapping coefficients -! EPS Real I OPTIONAL small non-zero tolerance used to check if -! target point is in domain and for point coincidence. -! DCIN Real I OPTIONAL distance outside of source grid in -! units of cell width to treat target point as -! inside the source grid. Default is 0. -! WDTH Real I OPTIONAL width for gaussian filter in units of -! source grid cell width. Required if RTYP='filter'. -! Actual width used is MIN(WDTH,1.5). -! MASK L.A. I OPTIONAL logical mask for source grid. -! (T = invalid, F = valid) -! DIMENSION must be same as GSU coordinate arrays. -! NMSK Int. I OPTIONAL maximum number of masked points for -! treating an enclosing source grid cell as partially -! masked. Must be >= 0 and < 4. Default is 2. -! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. -! Default is FALSE. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! - Check on previous initialization of grid search utility object. -! - Check on appropriate input of optional arguments. -! -! 7. Remarks : -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Test input -! 2. Initialize search -! 3. Find enclosing cell and compute relative index space location -! 4. Compute source grid points and remapping coefficients -! 5. Adjust for partially masked cell and enforce normalization -! 6. Load into return arrays and release work arrays -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GRMC_R4( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, & - DCIN, WDTH, MASK, NMSK, DEBUG ) RESULT(INGRID) -! Single precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(4), INTENT(IN) :: XTIN - REAL(4), INTENT(IN) :: YTIN - CHARACTER(6), INTENT(IN):: RTYP - INTEGER, INTENT(OUT) :: NS - INTEGER, INTENT(INOUT), POINTER :: IS(:) - INTEGER, INTENT(INOUT), POINTER :: JS(:) - REAL(4), INTENT(INOUT), POINTER :: CS(:) - REAL(4), INTENT(IN) , OPTIONAL :: EPS - REAL(4), INTENT(IN) , OPTIONAL :: DCIN - REAL(4), INTENT(IN) , OPTIONAL :: WDTH - LOGICAL, INTENT(IN) , OPTIONAL :: MASK(:,:) - INTEGER, INTENT(IN) , OPTIONAL :: NMSK - LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: LEPS, LDCIN, LWDTH=ZERO - REAL(8) :: XT, YT - REAL(8), POINTER :: CS8(:) => NULL() + GPPCL = DXDPL*DXDPL + DYDPL*DYDPL + GQQCL = DXDQL*DXDQL + DYDQL*DYDQL + GPQCL = DXDPL*DXDQL + DYDPL*DYDQL + GSQRL = MAX(GSQRL,SMALL) + GPPCL = MAX(GPPCL,SMALL) + GQQCL = MAX(GQQCL,SMALL) + DPDXL = DYDQL/GSQRL + DPDYL =-DXDQL/GSQRL + DQDXL =-DYDPL/GSQRL + DQDYL = DXDPL/GSQRL + APPCL = DPDXL*DPDXL + DPDYL*DPDYL + AQQCL = DQDXL*DQDXL + DQDYL*DQDYL + APQCL = DPDXL*DQDXL + DPDYL*DQDYL + HPFCL = SQRT(GPPCL) + HQFCL = SQRT(GQQCL) + COSAL = GPQCL/(HPFCL*HQFCL) + SINAL = GSQRL**2/(GPPCL*GQQCL) + COSTP = DXDPL/HPFCL + SINTP = DYDPL/HQFCL + COSCL = SINAL*COSTP + COSAL*SINTP + SINCL = SINAL*SINTP - COSAL*COSTP + ANGLL = ATAN2(SINCL,COSCL)*R2D + IF (PRESENT(GPPC)) GPPC(I1,I2) = GPPCL + IF (PRESENT(GQQC)) GQQC(I1,I2) = GQQCL + IF (PRESENT(GPQC)) GPQC(I1,I2) = GPQCL + IF (PRESENT(APPC)) APPC(I1,I2) = APPCL + IF (PRESENT(AQQC)) AQQC(I1,I2) = AQQCL + IF (PRESENT(APQC)) APQC(I1,I2) = APQCL + IF (PRESENT(GSQR)) GSQR(I1,I2) = GSQRL + IF (PRESENT(HPFC)) HPFC(I1,I2) = HPFCL + IF (PRESENT(HQFC)) HQFC(I1,I2) = HQFCL + IF (PRESENT(DXDP)) DXDP(I1,I2) = DXDPL + IF (PRESENT(DYDP)) DYDP(I1,I2) = DYDPL + IF (PRESENT(DXDQ)) DXDQ(I1,I2) = DXDQL + IF (PRESENT(DYDQ)) DYDQ(I1,I2) = DYDQL + IF (PRESENT(DPDX)) DPDX(I1,I2) = DPDXL + IF (PRESENT(DPDY)) DPDY(I1,I2) = DPDYL + IF (PRESENT(DQDX)) DQDX(I1,I2) = DQDXL + IF (PRESENT(DQDY)) DQDY(I1,I2) = DQDYL + IF (PRESENT(COSA)) COSA(I1,I2) = COSAL + IF (PRESENT(COSC)) COSC(I1,I2) = COSCL + IF (PRESENT(SINC)) SINC(I1,I2) = SINCL + IF (PRESENT(ANGL)) ANGL(I1,I2) = ATAN2(SINCL,COSCL)*R2D + IF (PRESENT(ANGL)) ANGL(I1,I2) = ANGLL + END DO !I1 + END DO !I2 + ! + ! -------------------------------------------------------------------- / + ! 4. Clean up + ! + DEALLOCATE ( K, C, K2, C2 ) + + END SUBROUTINE W3CGDM_R8 + !/ + !/ End of W3CGDM ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3GRD0( NFD, IJG, ICLO, PTILED, QTILED, & + !/ PRANGE, QRANGE, LBI, UBI, LBO, UBO, & + !/ DPDX, DPDY, DQDX, DQDY, & + !/ F, DFDX, DFDY, MASK, RC ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute gradient of a scalar field F(x,y) defined on a + ! curvilinear coordinate grid (x(p,q),y(p,q)). + ! + ! 2. Method : + ! + ! Compute derivatives using finite-difference method. + ! Apply curvilinear grid metric. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NFD Int. I Finite-difference order (even) + ! IJG Log. I Logical flag indicating ordering of input + ! coord. arrays: T = (NP,NQ) and F = (NP,NQ) + ! ICLO Int. I Parameter indicating type of index space closure. + ! PTILED Log. I Logical flag indicating that input arrays are tiled + ! in P-axis with halos of width >= NFD/2 + ! QTILED Log. I Logical flag indicating that input arrays are tiled + ! in Q-axis with halos of width >= NFD/2 + ! PRANGE I.A. I Range of P index coordinate: P in [PRANGE(1),PRANGE(2)] + ! QRANGE I.A. I Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)] + ! LBI I.A. I Lower-bound of input arrays, DIMENSION(2) + ! UBI I.A. I Upper-bound of input arrays, DIMENSION(2) + ! LBO I.A. I Lower-bound of output arrays, DIMENSION(2) + ! UBO I.A. I Upper-bound of output arrays, DIMENSION(2) + ! DPDX R.A. I dp/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DPDY R.A. I dp/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DQDX R.A. I dq/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DQDY R.A. I dq/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! F R.A. I Scalar input field, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DFDX R.A. O df/dx, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! DFDY R.A. O df/dy, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! MASK L.A. I OPTIONAL logical mask (T = invalid, F = valid) + ! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! RC Int. O OPTIONAL return code (!= 0 if error occurs) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - If RC is not provided and an error occurs, then the routine will + ! report error to stderr and attempt to abort the calling program. + ! - When MASK is specified, points that are masked are excluded from + ! the finite-difference stencil. In order to avoid reaching across + ! masked regions, the stencil is modified to one-sided and/or the + ! finite-difference order is reduced. If the masking results in a + ! single point wide channel, then the derivative in the direction + ! across the channel is set to zero. + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3GRD0_R4( NFD, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, & + DPDX, DPDY, DQDX, DQDY, & + F, DFDX, DFDY, MASK, RC ) + ! Single precision interface + INTEGER, INTENT(IN) :: NFD + LOGICAL, INTENT(IN) :: IJG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LBI(2), UBI(2) + INTEGER, INTENT(IN) :: LBO(2), UBO(2) + REAL(4), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: F(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(OUT) :: DFDX(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT) :: DFDY(LBO(1):UBO(1),LBO(2):UBO(2)) + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + INTEGER :: NP, NQ, I1, I2, P, Q + INTEGER :: ISTAT=0 + INTEGER :: K(0:NFD,0:NFD,1:NFD) + REAL(8) :: C(0:NFD,0:NFD,1:NFD) + REAL(8) :: DFDP, DFDQ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GRMC_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRD0_R4') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input -! - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', & - 'grid search utility object not created' - CALL EXTCDE (1) - END IF -! - SELECT CASE (RTYP) - CASE ('nearpt') - CASE ('bilinr') - CASE ('bicubc') - CASE ('filter') - IF ( .NOT.PRESENT(WDTH) ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', & - 'WDTH parameter is required with RTYP = filter' - CALL EXTCDE (1) - ELSE - LWDTH = WDTH - END IF - CASE DEFAULT - WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', & - 'RTYP = '//RTYP//' not supported' - CALL EXTCDE (1) - END SELECT -! - IF ( PRESENT(EPS) ) THEN - IF ( EPS .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', & - 'EPS parameter must be >= 0' - CALL EXTCDE (1) - END IF - LEPS = EPS - ELSE - LEPS = EPS_DEFAULT - END IF -! - IF ( PRESENT(DCIN) ) THEN - IF ( DCIN .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', & - 'DCIN parameter must be >= 0' - CALL EXTCDE (1) - END IF - LDCIN = DCIN + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & + 'NFD must be even and greater than zero' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) + CONTINUE + CASE DEFAULT + WRITE(0,'(/1A,1A,1I2/)') 'W3GRD0 ERROR -- ', & + 'unsupported ICLO: ',ICLO + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END SELECT + + IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & + 'tripole grid closure requires NP even' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Setup finite difference coefficients + ! + CALL GET_FDW3 ( NFD, M, K, C ) + ! + ! -------------------------------------------------------------------- / + ! 3. Compute dF/dx & dF/dy + ! + DO I2 = LBO(2), UBO(2) + DO I1 = LBO(1), UBO(1) + IF ( PRESENT(MASK) ) THEN + IF ( MASK(I1,I2) ) CYCLE + END IF + IF ( IJG ) THEN + P = I1 + Q = I2 ELSE - LDCIN = ZERO - END IF -! -! -------------------------------------------------------------------- / -! 2. Call into double precision method -! - XT = XTIN; YT = YTIN; - INGRID = W3GRMC( GSU, XT, YT, RTYP, NS, IS, JS, CS8, & - EPS=LEPS, DCIN=LDCIN, WDTH=LWDTH, & - MASK=MASK, NMSK=NMSK, DEBUG=DEBUG ) - IF ( NS.GT.0 ) THEN - ALLOCATE( CS(NS) ) - CS(:) = CS8(:) - DEALLOCATE( CS8 ) + P = I2 + Q = I1 + END IF + CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, & + F4=F, DFDP=DFDP, DFDQ=DFDQ, & + MASK=MASK, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF END IF - - END FUNCTION W3GRMC_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3GRMC_R8( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, & - DCIN, WDTH, MASK, NMSK, DEBUG ) RESULT(INGRID) -! Double precision interface - LOGICAL :: INGRID - TYPE(T_GSU), INTENT(IN) :: GSU - REAL(8), INTENT(IN) :: XTIN - REAL(8), INTENT(IN) :: YTIN - CHARACTER(6), INTENT(IN):: RTYP - INTEGER, INTENT(OUT) :: NS - INTEGER, INTENT(INOUT), POINTER :: IS(:) - INTEGER, INTENT(INOUT), POINTER :: JS(:) - REAL(8), INTENT(INOUT), POINTER :: CS(:) - REAL(8), INTENT(IN) , OPTIONAL :: EPS - REAL(8), INTENT(IN) , OPTIONAL :: DCIN - REAL(8), INTENT(IN) , OPTIONAL :: WDTH - LOGICAL, INTENT(IN) , OPTIONAL :: MASK(:,:) - INTEGER, INTENT(IN) , OPTIONAL :: NMSK - LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG - -! Local parameters - LOGICAL, PARAMETER :: LCMP = .TRUE. - INTEGER, PARAMETER :: NMSK_DEFAULT = 2 - REAL(8), PARAMETER :: BIG = 1D16 - REAL(8) :: LEPS, LWDTH=ZERO - LOGICAL :: LDBG, FNCL, POLE, DOBLC, LMSK - INTEGER :: I, II, JJ, K, KK, MCS, MCSMAX - INTEGER :: IC(4), JC(4) - REAL(8) :: XT, YT, XC(4), YC(4) - REAL(8) :: XTC, YTC, XSC(4), YSC(4) - REAL(8) :: LDCIN, IXR, JXR, DD, LON0, LAT0, DMIN - REAL(8) :: IX, JX, CZS - INTEGER :: NZ - LOGICAL, POINTER :: LZ(:)=>NULL() - INTEGER, POINTER :: IZ(:)=>NULL(), JZ(:)=>NULL() - REAL(8), POINTER :: CZ(:)=>NULL() - LOGICAL :: IJG, LLG, LCLO - INTEGER :: ICLO, GKIND - INTEGER :: LBX, LBY, UBX, UBY, NX, NY + DFDX(I1,I2) = DFDP*DPDX(I1,I2) + DFDQ*DQDX(I1,I2) + DFDY(I1,I2) = DFDP*DPDY(I1,I2) + DFDQ*DQDY(I1,I2) + END DO !I1 + END DO !I2 + + END SUBROUTINE W3GRD0_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3GRD0_R8( NFD, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, & + DPDX, DPDY, DQDX, DQDY, & + F, DFDX, DFDY, MASK, RC ) + ! Double precision interface + INTEGER, INTENT(IN) :: NFD + LOGICAL, INTENT(IN) :: IJG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LBI(2), UBI(2) + INTEGER, INTENT(IN) :: LBO(2), UBO(2) + REAL(8), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: F(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(OUT) :: DFDX(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT) :: DFDY(LBO(1):UBO(1),LBO(2):UBO(2)) + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + INTEGER :: NP, NQ, I1, I2, P, Q + INTEGER :: ISTAT=0 + INTEGER :: K(0:NFD,0:NFD,1:NFD) + REAL(8) :: C(0:NFD,0:NFD,1:NFD) + REAL(8) :: DFDP, DFDQ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GRMC_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRD0_R8') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input -! - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & - 'grid search utility object not created' - CALL EXTCDE (1) - END IF -! - SELECT CASE (RTYP) - CASE ('nearpt') - CASE ('bilinr') - CASE ('bicubc') - CASE ('filter') - IF ( .NOT.PRESENT(WDTH) ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & - 'WDTH parameter is required with RTYP = filter' - CALL EXTCDE (1) - ELSE - LWDTH = WDTH - END IF - CASE DEFAULT - WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & - 'RTYP = '//RTYP//' not supported' - CALL EXTCDE (1) - END SELECT -! - IF ( PRESENT(EPS) ) THEN - IF ( EPS .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & - 'EPS parameter must be >= 0' - CALL EXTCDE (1) - END IF - LEPS = EPS + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & + 'NFD must be even and greater than zero' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) + CONTINUE + CASE DEFAULT + WRITE(0,'(/1A,1A,1I2/)') 'W3GRD0 ERROR -- ', & + 'unsupported ICLO: ',ICLO + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END SELECT + + IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & + 'tripole grid closure requires NP even' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Setup finite difference coefficients + ! + CALL GET_FDW3 ( NFD, M, K, C ) + ! + ! -------------------------------------------------------------------- / + ! 3. Compute dF/dx & dF/dy + ! + DO I2 = LBO(2), UBO(2) + DO I1 = LBO(1), UBO(1) + IF ( PRESENT(MASK) ) THEN + IF ( MASK(I1,I2) ) CYCLE + END IF + IF ( IJG ) THEN + P = I1 + Q = I2 ELSE - LEPS = EPS_DEFAULT + P = I2 + Q = I1 + END IF + CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, & + F8=F, DFDP=DFDP, DFDQ=DFDQ, & + MASK=MASK, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF END IF -! - IF ( PRESENT(DCIN) ) THEN - IF ( DCIN .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & - 'DCIN parameter must be >= 0' - CALL EXTCDE (1) - END IF - LDCIN = DCIN + DFDX(I1,I2) = DFDP*DPDX(I1,I2) + DFDQ*DQDX(I1,I2) + DFDY(I1,I2) = DFDP*DPDY(I1,I2) + DFDQ*DQDY(I1,I2) + END DO !I1 + END DO !I2 + + END SUBROUTINE W3GRD0_R8 + !/ + !/ End of W3GRD0 ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3DIV1( NFD, IJG, ICLO, PTILED, QTILED, & + !/ PRANGE, QRANGE, LBI, UBI, LBO, UBO, & + !/ DPDX, DPDY, DQDX, DQDY, & + !/ VX, VY, DIVV, MASK, RC ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute divergence of a vector field (V_x,V_y) defined + ! on a curvilinear coordinate grid (x(p,q),y(p,q)). + ! + ! 2. Method : + ! + ! Compute derivatives using finite-difference method. + ! Apply curvilinear grid metric. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NFD Int. I Finite-difference order (even) + ! IJG Log. I Logical flag indicating ordering of input + ! coord. arrays: T = (NP,NQ) and F = (NP,NQ) + ! ICLO Int. I Parameter indicating type of index space closure. + ! PTILED Log. I Logical flag indicating that input arrays are tiled + ! in P-axis with halos of width >= NFD/2 + ! QTILED Log. I Logical flag indicating that input arrays are tiled + ! in Q-axis with halos of width >= NFD/2 + ! PRANGE I.A. I Range of P index coordinate: P in [PRANGE(1),PRANGE(2)] + ! QRANGE I.A. I Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)] + ! LBI I.A. I Lower-bound of input arrays, DIMENSION(2) + ! UBI I.A. I Upper-bound of input arrays, DIMENSION(2) + ! LBO I.A. I Lower-bound of output arrays, DIMENSION(2) + ! UBO I.A. I Upper-bound of output arrays, DIMENSION(2) + ! DPDX R.A. I dp/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DPDY R.A. I dp/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DQDX R.A. I dq/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DQDY R.A. I dq/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! VX R.A. I x-component of input vector field, + ! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! VY R.A. I y-component of input vector field, + ! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DIVV R.A. O div(V), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! MASK L.A. I OPTIONAL logical mask (T = invalid, F = valid) + ! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! RC Int. O OPTIONAL return code (!= 0 if error occurs) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - If RC is not provided and an error occurs, then the routine will + ! report error to stderr and attempt to abort the calling program. + ! - When MASK is specified, points that are masked are excluded from + ! the finite-difference stencil. In order to avoid reaching across + ! masked regions, the stencil is modified to one-sided and/or the + ! finite-difference order is reduced. If the masking results in a + ! single point wide channel, then the derivative in the direction + ! across the channel is set to zero. + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3DIV1_R4( NFD, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, & + DPDX, DPDY, DQDX, DQDY, & + VX, VY, DIVV, MASK, RC ) + ! Single precision interface + INTEGER, INTENT(IN) :: NFD + LOGICAL, INTENT(IN) :: IJG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LBI(2), UBI(2) + INTEGER, INTENT(IN) :: LBO(2), UBO(2) + REAL(4), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: VX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: VY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(OUT) :: DIVV(LBO(1):UBO(1),LBO(2):UBO(2)) + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + INTEGER :: NP, NQ, I1, I2, P, Q + INTEGER :: ISTAT=0 + INTEGER :: K(0:NFD,0:NFD,1:NFD) + REAL(8) :: C(0:NFD,0:NFD,1:NFD) + REAL(8) :: DVXDP, DVXDQ, DVYDP, DVYDQ + REAL(8) :: DVXDX, DVYDY +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIV1_R4') +#endif + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3DIV1 ERROR -- ', & + 'NFD must be even and greater than zero' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) + CONTINUE + CASE DEFAULT + WRITE(0,'(/1A,1A,1I2/)') 'W3DIV1 ERROR -- ', & + 'unsupported ICLO: ',ICLO + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END SELECT + + IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3DIV1 ERROR -- ', & + 'tripole grid closure requires NP even' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Setup finite difference coefficients + ! + CALL GET_FDW3 ( NFD, M, K, C ) + ! + ! -------------------------------------------------------------------- / + ! 3. Compute div(V) = dV_x/dx + dV_y/dy + ! + DO I2 = LBO(2), UBO(2) + DO I1 = LBO(1), UBO(1) + IF ( PRESENT(MASK) ) THEN + IF ( MASK(I1,I2) ) CYCLE + END IF + IF ( IJG ) THEN + P = I1 + Q = I2 ELSE - LDCIN = ZERO + P = I2 + Q = I1 + END IF + CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, & + F4=VX, DFDP=DVXDP, DFDQ=DVXDQ, & + G4=VY, DGDP=DVYDP, DGDQ=DVYDQ, & + MASK=MASK, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF END IF -! - IF ( PRESENT(NMSK) ) THEN - IF ( NMSK .LT. ZERO .OR. NMSK .GE. 4 ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & - 'NMSK parameter must be >= 0 and < 4' - CALL EXTCDE (1) - END IF - MCSMAX = NMSK + DVXDX = DVXDP*DPDX(I1,I2) + DVXDQ*DQDX(I1,I2) + DVYDY = DVYDP*DPDY(I1,I2) + DVYDQ*DQDY(I1,I2) + DIVV(I1,I2) = DVXDX + DVYDY + END DO !I1 + END DO !I2 + + END SUBROUTINE W3DIV1_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3DIV1_R8( NFD, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, & + DPDX, DPDY, DQDX, DQDY, & + VX, VY, DIVV, MASK, RC ) + ! Double precision interface + INTEGER, INTENT(IN) :: NFD + LOGICAL, INTENT(IN) :: IJG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LBI(2), UBI(2) + INTEGER, INTENT(IN) :: LBO(2), UBO(2) + REAL(8), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: VX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: VY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(OUT) :: DIVV(LBO(1):UBO(1),LBO(2):UBO(2)) + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + INTEGER :: NP, NQ, I1, I2, P, Q + INTEGER :: ISTAT=0 + INTEGER :: K(0:NFD,0:NFD,1:NFD) + REAL(8) :: C(0:NFD,0:NFD,1:NFD) + REAL(8) :: DVXDP, DVXDQ, DVYDP, DVYDQ + REAL(8) :: DVXDX, DVYDY +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIV1_R8') +#endif + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & + 'NFD must be even and greater than zero' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) + CONTINUE + CASE DEFAULT + WRITE(0,'(/1A,1A,1I2/)') 'W3GRD0 ERROR -- ', & + 'unsupported ICLO: ',ICLO + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END SELECT + + IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & + 'tripole grid closure requires NP even' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Setup finite difference coefficients + ! + CALL GET_FDW3 ( NFD, M, K, C ) + ! + ! -------------------------------------------------------------------- / + ! 3. Compute div(V) = dV_x/dx + dV_y/dy + ! + DO I2 = LBO(2), UBO(2) + DO I1 = LBO(1), UBO(1) + IF ( PRESENT(MASK) ) THEN + IF ( MASK(I1,I2) ) CYCLE + END IF + IF ( IJG ) THEN + P = I1 + Q = I2 ELSE - MCSMAX = NMSK_DEFAULT + P = I2 + Q = I1 + END IF + CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, & + F8=VX, DFDP=DVXDP, DFDQ=DVXDQ, & + G8=VY, DGDP=DVYDP, DGDQ=DVYDQ, & + MASK=MASK, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF END IF -! -! -------------------------------------------------------------------- / -! 2. Initialize search -! - IF ( PRESENT(DEBUG) ) THEN - LDBG = DEBUG + DVXDX = DVXDP*DPDX(I1,I2) + DVXDQ*DQDX(I1,I2) + DVYDY = DVYDP*DPDY(I1,I2) + DVYDQ*DQDY(I1,I2) + DIVV(I1,I2) = DVXDX + DVYDY + END DO !I1 + END DO !I2 + + END SUBROUTINE W3DIV1_R8 + !/ + !/ End of W3DIV1 ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3DIV2( NFD, IJG, ICLO, PTILED, QTILED, & + !/ PRANGE, QRANGE, LBI, UBI, LBO, UBO, & + !/ DPDX, DPDY, DQDX, DQDY, & + !/ SXX, SYY, SXY, DSX, DSY, MASK, RC ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute divergence of a rank 2 symmetric tensor field (S_xx,S_yy,S_xy) + ! defined on a curvilinear coordinate grid (x(p,q),y(p,q)). + ! + ! 2. Method : + ! + ! Compute derivatives using finite-difference method. + ! Apply curvilinear grid metric. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NFD Int. I Finite-difference order (even) + ! IJG Log. I Logical flag indicating ordering of input + ! coord. arrays: T = (NP,NQ) and F = (NP,NQ) + ! ICLO Int. I Parameter indicating type of index space closure. + ! PTILED Log. I Logical flag indicating that input arrays are tiled + ! in P-axis with halos of width >= NFD/2 + ! QTILED Log. I Logical flag indicating that input arrays are tiled + ! in Q-axis with halos of width >= NFD/2 + ! PRANGE I.A. I Range of P index coordinate: P in [PRANGE(1),PRANGE(2)] + ! QRANGE I.A. I Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)] + ! LBI I.A. I Lower-bound of input arrays, DIMENSION(2) + ! UBI I.A. I Upper-bound of input arrays, DIMENSION(2) + ! LBO I.A. I Lower-bound of output arrays, DIMENSION(2) + ! UBO I.A. I Upper-bound of output arrays, DIMENSION(2) + ! DPDX R.A. I dp/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DPDY R.A. I dp/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DQDX R.A. I dq/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DQDY R.A. I dq/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! SXX R.A. I xx-component of input tensor field, + ! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! SYY R.A. I yy-component of input vector field, + ! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! SXY R.A. I xy-component of input vector field, + ! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! DSX R.A. O div(S)_x, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! DSY R.A. O div(S)_y, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) + ! MASK L.A. I OPTIONAL logical mask (T = invalid, F = valid) + ! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) + ! RC Int. O OPTIONAL return code (!= 0 if error occurs) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - If RC is not provided and an error occurs, then the routine will + ! report error to stderr and attempt to abort the calling program. + ! - When MASK is specified, points that are masked are excluded from + ! the finite-difference stencil. In order to avoid reaching across + ! masked regions, the stencil is modified to one-sided and/or the + ! finite-difference order is reduced. If the masking results in a + ! single point wide channel, then the derivative in the direction + ! across the channel is set to zero. + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3DIV2_R4( NFD, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, & + DPDX, DPDY, DQDX, DQDY, & + SXX, SYY, SXY, DSX, DSY, MASK, RC ) + ! Single precision interface + INTEGER, INTENT(IN) :: NFD + LOGICAL, INTENT(IN) :: IJG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LBI(2), UBI(2) + INTEGER, INTENT(IN) :: LBO(2), UBO(2) + REAL(4), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: SXX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: SYY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(IN) :: SXY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(4), INTENT(OUT) :: DSX(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(4), INTENT(OUT) :: DSY(LBO(1):UBO(1),LBO(2):UBO(2)) + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + INTEGER :: NP, NQ, I1, I2, P, Q + INTEGER :: ISTAT=0 + INTEGER :: K(0:NFD,0:NFD,1:NFD) + REAL(8) :: C(0:NFD,0:NFD,1:NFD) + REAL(8) :: DXXDP, DXXDQ, DYYDP, DYYDQ, DXYDP, DXYDQ + REAL(8) :: DXXDX, DYYDY, DXYDX, DXYDY +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIV2_R4') +#endif + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', & + 'NFD must be even and greater than zero' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) + CONTINUE + CASE DEFAULT + WRITE(0,'(/1A,1A,1I2/)') 'W3DIV2 ERROR -- ', & + 'unsupported ICLO: ',ICLO + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END SELECT + + IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', & + 'tripole grid closure requires NP even' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Setup finite difference coefficients + ! + CALL GET_FDW3 ( NFD, M, K, C ) + ! + ! -------------------------------------------------------------------- / + ! 3. Compute div(S) = (dS_xx/dx + dS_xy/dy, dS_xy/dx + dS_yy/dy) + ! + DO I2 = LBO(2), UBO(2) + DO I1 = LBO(1), UBO(1) + IF ( PRESENT(MASK) ) THEN + IF ( MASK(I1,I2) ) CYCLE + END IF + IF ( IJG ) THEN + P = I1 + Q = I2 ELSE - LDBG = .FALSE. - END IF -! -! Local pointers to grid search utility object data - IJG = GSU%PTR%IJG - LLG = GSU%PTR%LLG - ICLO = GSU%PTR%ICLO - LCLO = GSU%PTR%LCLO - GKIND = GSU%PTR%GKIND - LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; - UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; - NX = GSU%PTR%NX; NY = GSU%PTR%NY; -! - IF ( PRESENT(MASK) ) THEN - IF ( IJG ) THEN - IF ( .NOT.(UBOUND(MASK,1).EQ.NX.AND. & - UBOUND(MASK,2).EQ.NY) ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & - 'MASK array size does not agree with GSU index bounds' - CALL EXTCDE (1) - END IF - ELSE - IF ( .NOT.(UBOUND(MASK,2).EQ.NX.AND. & - UBOUND(MASK,1).EQ.NY) ) THEN - WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', & - 'MASK array size does not agree with GSU index bounds' - CALL EXTCDE (1) - END IF - END IF - END IF -! - NS = 0 - IF ( ASSOCIATED(IS) ) THEN - DEALLOCATE( IS ) - NULLIFY( IS ) - END IF - IF ( ASSOCIATED(JS) ) THEN - DEALLOCATE( JS ) - NULLIFY( JS ) - END IF - IF ( ASSOCIATED(CS) ) THEN - DEALLOCATE( CS ) - NULLIFY( CS ) + P = I2 + Q = I1 + END IF + CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, & + F4=SXX, DFDP=DXXDP, DFDQ=DXXDQ, & + G4=SYY, DGDP=DYYDP, DGDQ=DYYDQ, & + H4=SXY, DHDP=DXYDP, DHDQ=DXYDQ, & + MASK=MASK, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF END IF -! - XT = XTIN; YT = YTIN; - IF ( LDBG ) WRITE(*,'(/A,2E24.16)') 'W3GRMC_R8 - TARGET POINT:',XT,YT -! -! -------------------------------------------------------------------- / -! 3. Find enclosing cell and compute relative index space location -! - FNCL = LDCIN .GT. ZERO - INGRID = W3GFCL(GSU,XT,YT,IC,JC,XC,YC,POLE=POLE,EPS=LEPS,FNCL=FNCL,DEBUG=LDBG) - IF ( .NOT.INGRID .AND. .NOT.FNCL ) RETURN -! -!-----Compute cell relative index space location - LON0 = SUM(XC)/FOUR; LAT0 = SUM(YC)/FOUR; - IF ( D90-ABS(LAT0).GT.NEAR_POLE ) THEN -!---------non-pole cell: compute relative location using (lon,lat) - CALL GETPQR(XT,YT,XC,YC,IXR,JXR,EPS=LEPS,DEBUG=LDBG) + DXXDX = DXXDP*DPDX(I1,I2) + DXXDQ*DQDX(I1,I2) + DYYDY = DYYDP*DPDY(I1,I2) + DYYDQ*DQDY(I1,I2) + DXYDX = DXYDP*DPDX(I1,I2) + DXYDQ*DQDX(I1,I2) + DXYDY = DXYDP*DPDY(I1,I2) + DXYDQ*DQDY(I1,I2) + DSX(I1,I2) = DXXDX + DXYDY + DSY(I1,I2) = DXYDX + DYYDY + END DO !I1 + END DO !I2 + + END SUBROUTINE W3DIV2_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3DIV2_R8( NFD, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, & + DPDX, DPDY, DQDX, DQDY, & + SXX, SYY, SXY, DSX, DSY, MASK, RC ) + ! Double precision interface + INTEGER, INTENT(IN) :: NFD + LOGICAL, INTENT(IN) :: IJG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LBI(2), UBI(2) + INTEGER, INTENT(IN) :: LBO(2), UBO(2) + REAL(8), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: SXX(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: SYY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(IN) :: SXY(LBI(1):UBI(1),LBI(2):UBI(2)) + REAL(8), INTENT(OUT) :: DSX(LBO(1):UBO(1),LBO(2):UBO(2)) + REAL(8), INTENT(OUT) :: DSY(LBO(1):UBO(1),LBO(2):UBO(2)) + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + INTEGER :: NP, NQ, I1, I2, P, Q + INTEGER :: ISTAT=0 + INTEGER :: K(0:NFD,0:NFD,1:NFD) + REAL(8) :: C(0:NFD,0:NFD,1:NFD) + REAL(8) :: DXXDP, DXXDQ, DYYDP, DYYDQ, DXYDP, DXYDQ + REAL(8) :: DXXDX, DYYDY, DXYDX, DXYDY +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIV2_R8') +#endif + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', & + 'NFD must be even and greater than zero' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) + CONTINUE + CASE DEFAULT + WRITE(0,'(/1A,1A,1I2/)') 'W3DIV2 ERROR -- ', & + 'unsupported ICLO: ',ICLO + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END SELECT + + IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', & + 'tripole grid closure requires NP even' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Setup finite difference coefficients + ! + CALL GET_FDW3 ( NFD, M, K, C ) + ! + ! -------------------------------------------------------------------- / + ! 3. Compute div(S) = (dS_xx/dx + dS_xy/dy, dS_xy/dx + dS_yy/dy) + ! + DO I2 = LBO(2), UBO(2) + DO I1 = LBO(1), UBO(1) + IF ( PRESENT(MASK) ) THEN + IF ( MASK(I1,I2) ) CYCLE + END IF + IF ( IJG ) THEN + P = I1 + Q = I2 ELSE -!---------pole cell: compute relative location using stereographic projection - CALL W3SPLX(LON0,LAT0,ZERO,XT,YT,XTC,YTC) - DO I=1,4 - CALL W3SPLX(LON0,LAT0,ZERO,XC(I),YC(I),XSC(I),YSC(I)) - END DO - CALL GETPQR(XTC,YTC,XSC,YSC,IXR,JXR,EPS=LEPS,DEBUG=LDBG) - ENDIF - IF ( LDBG ) & - WRITE(*,'(A,2L2,2E24.16)') 'W3GRMC_R8 - RELATIVE:',INGRID,FNCL,IXR,JXR -! -!-----Set in grid if point is within DCIN cell width distance of closest cell - IF ( .NOT.INGRID .AND. FNCL ) THEN - DD = HALF + LDCIN - INGRID = ABS(IXR-HALF).LE.DD .AND. ABS(JXR-HALF).LE.DD - END IF - IF ( .NOT.INGRID ) RETURN -! -!-----Compute absolute index space location - IX = IC(1) + IXR; JX = JC(1) + JXR; -! -!-----Determine if target point is coincident with an -! unmasked source grid cell point (KK) - KK_LOOP: DO KK=1,4 - IF ( ABS(IC(KK)-IX).LE.LEPS .AND. & - ABS(JC(KK)-JX).LE.LEPS ) THEN - IF ( PRESENT(MASK) ) THEN - IF ( IJG ) THEN - IF ( .NOT.MASK(IC(KK)-LBX+1,JC(KK)-LBY+1) ) EXIT KK_LOOP - ELSE - IF ( .NOT.MASK(JC(KK)-LBY+1,IC(KK)-LBX+1) ) EXIT KK_LOOP - END IF - ELSE - EXIT KK_LOOP - END IF - END IF - END DO KK_LOOP -! -!-----Count number of masked points in source cell - MCS = 0 - IF ( PRESENT(MASK) ) THEN - DO K=1,4 - IF ( IJG ) THEN - IF ( MASK(IC(K)-LBX+1,JC(K)-LBY+1) ) MCS = MCS+1 - ELSE - IF ( MASK(JC(K)-LBY+1,IC(K)-LBX+1) ) MCS = MCS+1 - END IF - END DO - END IF -! -! -------------------------------------------------------------------- / -! 4. Compute source grid points and remapping coefficients -! - SELECT CASE (RTYP) - CASE ('nearpt') - ! *** nearest point *** - DMIN = BIG - DO K=1,4 - DD = (IX - IC(K))**2 + (JX - JC(K))**2 - IF ( DD .LT. DMIN ) THEN - DMIN = DD; II = IC(K); JJ = JC(K); - END IF - END DO - NZ = 1 - IF ( PRESENT(MASK) ) THEN - IF ( IJG ) THEN - IF ( MASK(II-LBX+1,JJ-LBY+1) ) NZ = 0 - ELSE - IF ( MASK(JJ-LBY+1,II-LBX+1) ) NZ = 0 - END IF - END IF - IF ( NZ.EQ.1 ) THEN - ! nearest point is unmasked - ! set number of points to one and coefficient to one - ALLOCATE( LZ(NZ), IZ(NZ), JZ(NZ), CZ(NZ) ) - LZ(NZ) = .TRUE. - IZ(NZ) = II - JZ(NZ) = JJ - CZ(NZ) = ONE - ELSE - ! nearest point is masked - ! set number of points to zero and return - NS = 0 - RETURN - END IF - CASE ('bilinr') - ! *** bilinear interpolation *** - IF ( KK.LE.4 ) THEN - ! coincident with unmasked point kk - ! set number of points to one and coefficient to one - NZ = 1 - ALLOCATE( LZ(NZ), IZ(NZ), JZ(NZ), CZ(NZ) ) - LZ(NZ) = .TRUE. - IZ(NZ) = IC(KK) - JZ(NZ) = JC(KK) - CZ(NZ) = ONE - ELSE - ! no coincident points - IF ( MCS.LE.MCSMAX ) THEN - ! unmasked or partially masked cell - ! set bilinear interpolation - CALL GETBLC( GSU, IC(1), JC(1), IXR, JXR, & - LCMP, NZ, LZ, IZ, JZ, CZ ) - ELSE - ! fully masked cell - ! set number of points to zero and return - NS = 0 - RETURN - END IF - END IF - CASE ('bicubc') - ! *** bicubic interpolation *** - IF ( KK.LE.4 ) THEN - ! coincident with unmasked point kk - ! set number of points to one and coefficient to one - NZ = 1 - ALLOCATE( LZ(NZ), IZ(NZ), JZ(NZ), CZ(NZ) ) - LZ(NZ) = .TRUE. - IZ(NZ) = IC(KK) - JZ(NZ) = JC(KK) - CZ(NZ) = ONE - ELSE - ! no coincident points - IF ( MCS.EQ.0 ) THEN - ! unmasked cell - ! get bicubic interpolation - CALL GETBCC( GSU, IC(1), JC(1), IXR, JXR, & - LCMP, NZ, LZ, IZ, JZ, CZ ) - ! check for masked points in bicubic stencil - DOBLC = .FALSE. - IF ( PRESENT(MASK) ) THEN - CHECK: DO K=1,NZ - IF ( LZ(K) ) THEN - IF ( IJG ) THEN - LMSK = MASK(IZ(K)-LBX+1,JZ(K)-LBY+1) - ELSE - LMSK = MASK(JZ(K)-LBY+1,IZ(K)-LBX+1) - END IF - IF ( LMSK ) THEN - DOBLC = .TRUE. - EXIT CHECK - END IF - END IF - END DO CHECK - END IF - IF ( DOBLC ) THEN - ! masked points in bicubic stencil - ! set bilinear interpolation - CALL GETBLC( GSU, IC(1), JC(1), IXR, JXR, & - LCMP, NZ, LZ, IZ, JZ, CZ ) - END IF - ELSE IF ( MCS.LE.MCSMAX ) THEN - ! partially masked cell - ! set bilinear interpolation - CALL GETBLC( GSU, IC(1), JC(1), IXR, JXR, & - LCMP, NZ, LZ, IZ, JZ, CZ ) - ELSE - ! fully masked cell - ! set number of points to zero and return - NS = 0 - RETURN - END IF - END IF - case ('filter') - ! *** gaussian filter *** - IF ( MCS.LE.MCSMAX ) THEN - ! unmasked or partially masked cell - ! get gaussian filter - CALL GETGFC( GSU, IC(1), JC(1), IXR, JXR, & - LWDTH, LCMP, NZ, LZ, IZ, JZ, CZ ) - ELSE - ! fully masked cell - ! set number of points to zero and return - NS = 0 - RETURN - END IF - END SELECT -! -! -------------------------------------------------------------------- / -! 5. Adjust for partially masked cell and enforce normalization -! - IF ( NZ .GT. 1 ) THEN - CZS = ZERO - DO K=1,NZ - IF ( LZ(K) ) THEN - IF ( PRESENT(MASK) ) THEN - IF ( IJG ) THEN - LMSK = MASK(IZ(K)-LBX+1,JZ(K)-LBY+1) - ELSE - LMSK = MASK(JZ(K)-LBY+1,IZ(K)-LBX+1) - END IF - IF ( LMSK ) THEN - LZ(K) = .FALSE. - CZ(K) = ZERO - ELSE - CZS = CZS + CZ(K) - END IF - ELSE - CZS = CZS + CZ(K) - END IF - END IF - END DO - IF ( CZS .GT. ZERO ) THEN - DO K=1,NZ - IF ( LZ(K) ) CZ(K) = CZ(K)/CZS - ENDDO - END IF - END IF -! -! -------------------------------------------------------------------- / -! 6. Load into return arrays and release work arrays -! - NS = 0 - DO K=1,NZ - IF ( LZ(K) ) NS = NS + 1 - END DO - IF ( NS.GT.0 ) THEN - ALLOCATE( IS(NS), JS(NS), CS(NS) ) - NS = 0 - DO K=1,NZ - IF ( LZ(K) ) THEN - NS = NS + 1 - IS(NS) = IZ(K) - JS(NS) = JZ(K) - CS(NS) = CZ(K) - END IF - END DO + P = I2 + Q = I1 + END IF + CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, P, Q, & + F8=SXX, DFDP=DXXDP, DFDQ=DXXDQ, & + G8=SYY, DGDP=DYYDP, DGDQ=DYYDQ, & + H8=SXY, DHDP=DXYDP, DHDQ=DXYDQ, & + MASK=MASK, RC=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF END IF + DXXDX = DXXDP*DPDX(I1,I2) + DXXDQ*DQDX(I1,I2) + DYYDY = DYYDP*DPDY(I1,I2) + DYYDQ*DQDY(I1,I2) + DXYDX = DXYDP*DPDX(I1,I2) + DXYDQ*DQDX(I1,I2) + DXYDY = DXYDP*DPDY(I1,I2) + DXYDQ*DQDY(I1,I2) + DSX(I1,I2) = DXXDX + DXYDY + DSY(I1,I2) = DXYDX + DYYDY + END DO !I1 + END DO !I2 + + END SUBROUTINE W3DIV2_R8 + !/ + !/ End of W3DIV2 ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3DIST( LLG, XT, YT, XS, YS ) RESULT(DIST) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute distance between two points. If spherical grid, then + ! distance is the angle (in degrees) between the two points. + ! + ! 2. Method : + ! + ! Map Projections -- A Working Manual, John P. Snyder + ! U.S. Geological Survey professional paper; 1395 + ! Chapter 5. Transformation of Map Graticules + ! + ! 3. Parameters : + ! + ! Return parameter + ! ---------------------------------------------------------------- + ! DIST Real O Distance + ! ---------------------------------------------------------------- + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! LLG Log. I Logical flag indicating the coordinate system: + ! T = spherical lat/lon (degrees) and F = Cartesian. + ! XT Real I X-coordinate of target point. + ! YT Real I Y-coordinate of target point. + ! XS Real I X-coordinate of source point. + ! YS Real I Y-coordinate of source point. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3DIST_R4( LLG, XT, YT, XS, YS ) RESULT(DIST) + ! Single precision interface + REAL(4) :: DIST + LOGICAL, INTENT(IN) :: LLG + REAL(4), INTENT(IN) :: XT, YT + REAL(4), INTENT(IN) :: XS, YS + + ! Local parameters + REAL(8) :: XT8, YT8, XS8, YS8 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIST_R4') +#endif + ! + !-----set inputs + XT8 = XT; YT8 = YT; + XS8 = XS; YS8 = YS; + ! + !-----call double precision method + DIST = W3DIST( LLG, XT8, YT8, XS8, YS8 ) + + END FUNCTION W3DIST_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ +#define DIST_WITH_SINE +#define DIST_CHECK_NAN____disabled + FUNCTION W3DIST_R8( LLG, XT, YT, XS, YS ) RESULT(DIST) + ! Double precision interface + REAL(8) :: DIST + LOGICAL, INTENT(IN) :: LLG + REAL(8), INTENT(IN) :: XT, YT + REAL(8), INTENT(IN) :: XS, YS + + ! Local parameters + REAL(8) :: DX, DY, SLAM, SPHI, ARGD +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIST_R8') +#endif + ! + !-----compute displacements + DX = XT - XS + DY = YT - YS + + IF ( LLG ) THEN !spherical coordinates + !---------check for longitudinal branch cut crossing + IF ( ABS(DX) .GT. D270 ) THEN + DX = DX - SIGN(D360,DX) + END IF +#ifdef DIST_WITH_SINE + !---------compute angular distance using sin(d/2) + ! (this equation is more accurate than cos(d)) + SLAM = SIN(HALF*DX*D2R) + SPHI = SIN(HALF*DY*D2R) + ARGD = SQRT( COS(YT*D2R)*COS(YS*D2R)*SLAM*SLAM + SPHI*SPHI ) + DIST = R2D*TWO*ASIN( ARGD ) +#else + !---------compute angular distance using cos(c) (min required + ! for rare situation of acos(1+small) generating NaN) + ARGD = MIN( ONE, COS(YT*D2R)*COS(YS*D2R)*COS(DX*D2R) & + + SIN(YT*D2R)*SIN(YS*D2R) ) + DIST = R2D*ACOS( ARGD ) +#endif + ELSE !cartesian coordinates + !---------compute cartesian distance + DIST = SQRT( DX**2 + DY**2 ) + END IF !cartesian coordinates +#ifdef DIST_CHECK_NAN + IF ( W3INAN(DIST) ) THEN + WRITE(0,'(/1A/)') 'W3DIST_R8 ERROR -- result is NaN' + CALL EXTCDE (1) + END IF +#endif - DEALLOCATE( LZ, IZ, JZ, CZ ) + END FUNCTION W3DIST_R8 + !/ + !/ End of W3DIST ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3SPLX( LAM0, PHI0, C0, LAM, PHI, X, Y ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute Cartesian coordinates from input longitude and latitude + ! using stereographic projection with center at (LAM0,PHI0) and + ! "standard circle" of angular distance C0 (in degrees) from the + ! center. + ! + ! 2. Method : + ! + ! Map Projections -- A Working Manual, John P. Snyder + ! U.S. Geological Survey professional paper; 1395 + ! Chapter 21. Stereographic projection + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! LAM0 Real I Longitude of center of projection. + ! PHI0 Real I Latitude of center of projection. + ! C0 Real I Angular distance from center of projection + ! where the scale factor is one. + ! LAM Real I Longitude of input point. + ! PHI Real I Latitude of input point. + ! X Real O Cartesian x-coordinate of input point. + ! Y Real O Cartesian y-coordinate of input point. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPLX_0D_R4( LAM0, PHI0, C0, LAM, PHI, X, Y ) + ! Single precision point interface + REAL(4), INTENT(IN) :: LAM0, PHI0, C0 + REAL(4), INTENT(IN) :: LAM, PHI + REAL(4), INTENT(OUT):: X, Y + + ! Local parameters + REAL(8) :: K, K0, CLAM, SLAM, CPHI0, CPHI, SPHI0, SPHI +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_0D_R4') +#endif - END FUNCTION W3GRMC_R8 -!/ -!/ End of W3GRMC ===================================================== / -!/ + CLAM = COS((LAM-LAM0)*D2R) + SLAM = SIN((LAM-LAM0)*D2R) + CPHI0 = COS(PHI0*D2R) + CPHI = COS(PHI*D2R) + SPHI0 = SIN(PHI0*D2R) + SPHI = SIN(PHI*D2R) + K0 = COS(HALF*C0*D2R)**2 + K = TWO*K0*REARTH/(ONE+SPHI0*SPHI+CPHI0*CPHI*CLAM) + X = K*CPHI*SLAM + Y = K*(CPHI0*SPHI-SPHI0*CPHI*CLAM) + + END SUBROUTINE W3SPLX_0D_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPLX_0D_R8( LAM0, PHI0, C0, LAM, PHI, X, Y ) + ! Double precision point interface + REAL(8), INTENT(IN) :: LAM0, PHI0, C0 + REAL(8), INTENT(IN) :: LAM, PHI + REAL(8), INTENT(OUT):: X, Y + + ! Local parameters + REAL(8) :: K, K0, CLAM, SLAM, CPHI0, CPHI, SPHI0, SPHI +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_0D_R8') +#endif + CLAM = COS((LAM-LAM0)*D2R) + SLAM = SIN((LAM-LAM0)*D2R) + CPHI0 = COS(PHI0*D2R) + CPHI = COS(PHI*D2R) + SPHI0 = SIN(PHI0*D2R) + SPHI = SIN(PHI*D2R) + K0 = COS(HALF*C0*D2R)**2 + K = TWO*K0*REARTH/(ONE+SPHI0*SPHI+CPHI0*CPHI*CLAM) + X = K*CPHI*SLAM + Y = K*(CPHI0*SPHI-SPHI0*CPHI*CLAM) + + END SUBROUTINE W3SPLX_0D_R8 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPLX_1D_R4( LAM0, PHI0, C0, LAM, PHI, X, Y ) + ! Single precision 1D array interface + REAL(4), INTENT(IN) :: LAM0, PHI0, C0 + REAL(4), INTENT(IN) :: LAM(:), PHI(:) + REAL(4), INTENT(OUT):: X(:), Y(:) + + ! Local parameters + INTEGER :: I +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_1D_R4') +#endif + DO I = LBOUND(LAM,1),UBOUND(LAM,1) + CALL W3SPLX( LAM0, PHI0, C0, LAM(I), PHI(I), X(I), Y(I) ) + ENDDO + + END SUBROUTINE W3SPLX_1D_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPLX_1D_R8( LAM0, PHI0, C0, LAM, PHI, X, Y ) + ! Double precision 1D array interface + REAL(8), INTENT(IN) :: LAM0, PHI0, C0 + REAL(8), INTENT(IN) :: LAM(:), PHI(:) + REAL(8), INTENT(OUT):: X(:), Y(:) + + ! Local parameters + INTEGER :: I +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_1D_R8') +#endif + DO I = LBOUND(LAM,1),UBOUND(LAM,1) + CALL W3SPLX( LAM0, PHI0, C0, LAM(I), PHI(I), X(I), Y(I) ) + ENDDO + + END SUBROUTINE W3SPLX_1D_R8 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPLX_2D_R4( LAM0, PHI0, C0, LAM, PHI, X, Y ) + ! Single precision 2D array interface + REAL(4), INTENT(IN) :: LAM0, PHI0, C0 + REAL(4), INTENT(IN) :: LAM(:,:), PHI(:,:) + REAL(4), INTENT(OUT):: X(:,:), Y(:,:) + + ! Local parameters + INTEGER :: I, J +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_2D_R4') +#endif + DO J = LBOUND(LAM,2),UBOUND(LAM,2) + DO I = LBOUND(LAM,1),UBOUND(LAM,1) + CALL W3SPLX( LAM0, PHI0, C0, LAM(I,J), PHI(I,J), X(I,J), Y(I,J) ) + ENDDO + ENDDO + + END SUBROUTINE W3SPLX_2D_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPLX_2D_R8( LAM0, PHI0, C0, LAM, PHI, X, Y ) + ! Double precision 2D array interface + REAL(8), INTENT(IN) :: LAM0, PHI0, C0 + REAL(8), INTENT(IN) :: LAM(:,:), PHI(:,:) + REAL(8), INTENT(OUT):: X(:,:), Y(:,:) + + ! Local parameters + INTEGER :: I, J +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_2D_R8') +#endif + DO J = LBOUND(LAM,2),UBOUND(LAM,2) + DO I = LBOUND(LAM,1),UBOUND(LAM,1) + CALL W3SPLX( LAM0, PHI0, C0, LAM(I,J), PHI(I,J), X(I,J), Y(I,J) ) + ENDDO + ENDDO + + END SUBROUTINE W3SPLX_2D_R8 + !/ + !/ End of W3SPLX ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3SPXL( LAM0, PHI0, X, Y, LAM, PHI ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute longitude and latitude coordinates from input Cartesian + ! coordinates using stereographic projection with center at (LAM0,PHI0) + ! and "standard circle" of angular distance C0 (in degrees) from the + ! center. + ! + ! 2. Method : + ! + ! Map Projections -- A Working Manual, John P. Snyder + ! U.S. Geological Survey professional paper; 1395 + ! Chapter 21. Stereographic projection + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! LAM0 Real I Longitude of center of projection. + ! PHI0 Real I Latitude of center of projection. + ! C0 Real I Angular distance from center of projection + ! where the scale factor is one. + ! X Real I Cartesian x-coordinate of input point. + ! Y Real I Cartesian y-coordinate of input point. + ! LAM Real O Longitude of input point. + ! PHI Real O Latitude of input point. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPXL_0D_R4( LAM0, PHI0, C0, X, Y, LAM, PHI ) + ! Single precision point interface + REAL(4), INTENT(IN) :: LAM0, PHI0, C0 + REAL(4), INTENT(IN) :: X, Y + REAL(4), INTENT(OUT):: LAM, PHI + + ! Local parameters + REAL(8) :: K0, RHO, C, COSC, SINC, CPHI0, SPHI0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_0D_R4') +#endif + K0 = COS(HALF*C0*D2R)**2 + RHO = SQRT(X*X+Y*Y) + C = TWO*ATAN2(RHO,TWO*REARTH*K0) + COSC = COS(C) + SINC = SIN(C) + CPHI0 = COS(PHI0*D2R) + SPHI0 = SIN(PHI0*D2R) + PHI = ASIN(COSC*SPHI0+Y*SINC*CPHI0/RHO)*R2D + LAM = LAM0 + ATAN2(X*SINC,RHO*CPHI0*COSC-Y*SPHI0*SINC)*R2D + + END SUBROUTINE W3SPXL_0D_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPXL_0D_R8( LAM0, PHI0, C0, X, Y, LAM, PHI ) + ! Double precision point interface + REAL(8), INTENT(IN) :: LAM0, PHI0, C0 + REAL(8), INTENT(IN) :: X, Y + REAL(8), INTENT(OUT):: LAM, PHI + + ! Local parameters + REAL(8) :: K0, RHO, C, COSC, SINC, CPHI0, SPHI0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_0D_R8') +#endif + K0 = COS(HALF*C0*D2R)**2 + RHO = SQRT(X*X+Y*Y) + C = TWO*ATAN2(RHO,TWO*REARTH*K0) + COSC = COS(C) + SINC = SIN(C) + CPHI0 = COS(PHI0*D2R) + SPHI0 = SIN(PHI0*D2R) + PHI = ASIN(COSC*SPHI0+Y*SINC*CPHI0/RHO)*R2D + LAM = LAM0 + ATAN2(X*SINC,RHO*CPHI0*COSC-Y*SPHI0*SINC)*R2D + + END SUBROUTINE W3SPXL_0D_R8 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPXL_1D_R4( LAM0, PHI0, C0, X, Y, LAM, PHI ) + ! Single precision 1D array interface + REAL(4), INTENT(IN) :: LAM0, PHI0, C0 + REAL(4), INTENT(IN) :: X(:), Y(:) + REAL(4), INTENT(OUT):: LAM(:), PHI(:) + + ! Local parameters + INTEGER :: I +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_1D_R4') +#endif -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3CKCL( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) & -!/ RESULT(INCELL) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Check if point lies within grid cell. -! -! 2. Method : -! -! Calculates cross products for vertex to vertex (i.e. cell side) -! vs vertex to target. If all cross products have the same sign, -! the point is considered to be within the cell. Since they can -! be "all positive" *or* "all negative", there are no pre-conditions -! that the order of specification of the vertices be clockwise vs. -! counter-clockwise geographically. The logical variable POLE is -! set to true if the grid cell includes a pole. -! -! 3. Parameters : -! -! Return parameter -! ---------------------------------------------------------------- -! INCELL Log. O Logical flag indicating point is in the cell -! ---------------------------------------------------------------- -! -! Parameter list -! ---------------------------------------------------------------- -! LLG Log. I Logical flag indicating the coordinate system: -! T = spherical lat/lon (degrees) and F = Cartesian. -! XT Real I X-coordinate of target point. -! YT Real I Y-coordinate of target point. -! XS R.A. I X-coordinates of source cell vertices. -! YS R.A. I Y-coordinates of source cell vertices. -! POLE Log. O OPTIONAL output logical flag to indicate -! the source cell contains a pole. -! EPS Real I OPTIONAL small non-zero tolerance used to check -! for point coincidence. -! DEBUG Log. I OPTIONAL logical flag to turn on debug mode. -! Default is FALSE. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! - For LL grids, this method assumes that the longitudes of point -! and grid cell vertices lie in the same range (i.e., both in [0:360] -! or [-180:180]). If the longitudes are not in the same range, then -! this method may result in a false positive. The burden is upon the -! caller to ensure that the longitude range of the point is the same -! as that of the grid cell vertices. -! - If enclosing cell includes a branch cut, then the coordinates of -! of the cell vertices AND the target point will be adjusted so -! that the branch cut is shifted 180 degrees. -! - If the enclosing cell includes a pole, then the cross-product check -! is performed using coordinates in a stereographic projection. -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3CKCL_R4( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) & - RESULT(INCELL) -! Single precision interface - LOGICAL :: INCELL - LOGICAL, INTENT(IN) :: LLG - REAL(4), INTENT(INOUT) :: XT, YT - INTEGER, INTENT(IN) :: NS - REAL(4), INTENT(INOUT) :: XS(NS), YS(NS) - LOGICAL, INTENT(OUT) :: POLE - REAL(4), INTENT(IN), OPTIONAL :: EPS - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: XT8, YT8, XS8(NS), YS8(NS), EPS8 + DO I = LBOUND(X,1),UBOUND(X,1) + CALL W3SPXL( LAM0, PHI0, C0, X(I), Y(I), LAM(I), PHI(I) ) + ENDDO + + END SUBROUTINE W3SPXL_1D_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPXL_1D_R8( LAM0, PHI0, C0, X, Y, LAM, PHI ) + ! Double precision 1D array interface + REAL(8), INTENT(IN) :: LAM0, PHI0, C0 + REAL(8), INTENT(IN) :: X(:), Y(:) + REAL(8), INTENT(OUT):: LAM(:), PHI(:) + + ! Local parameters + INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3CKCL_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_1D_R8') #endif -! -!-----set inputs - XT8 = XT; XS8 = XS; - YT8 = YT; YS8 = YS; - IF ( PRESENT(EPS) ) THEN - EPS8 = EPS - ELSE - EPS8 = EPS_DEFAULT - END IF -! -!-----call double precision method - INCELL = W3CKCL( LLG, XT8, YT8, NS, XS8, YS8, POLE, & - EPS=EPS8, DEBUG=DEBUG ) -! -!-----return branch cut shifted coordinates - XT = XT8; XS = XS8; - - END FUNCTION W3CKCL_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3CKCL_R8( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) & - RESULT(INCELL) -! Double precision interface - LOGICAL :: INCELL - LOGICAL, INTENT(IN) :: LLG - REAL(8), INTENT(INOUT) :: XT, YT - INTEGER, INTENT(IN) :: NS - REAL(8), INTENT(INOUT) :: XS(NS), YS(NS) - LOGICAL, INTENT(OUT) :: POLE - REAL(8), INTENT(IN), OPTIONAL :: EPS - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - REAL(8) :: LEPS - LOGICAL :: LDBG, LSBC, BCUT - INTEGER :: I, J, K, N - REAL(8) :: XXT, YYT, XXS(NS), YYS(NS) - REAL(8) :: XCT, YCT, XCS(NS), YCS(NS) - REAL(8) :: V1X, V1Y, V2X, V2Y, S90 - REAL(8) :: CROSS - REAL(8) :: SIGN1 + + DO I = LBOUND(X,1),UBOUND(X,1) + CALL W3SPXL( LAM0, PHI0, C0, X(I), Y(I), LAM(I), PHI(I) ) + ENDDO + + END SUBROUTINE W3SPXL_1D_R8 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPXL_2D_R4( LAM0, PHI0, C0, X, Y, LAM, PHI ) + ! Single precision 2D array interface + REAL(4), INTENT(IN) :: LAM0, PHI0, C0 + REAL(4), INTENT(IN) :: X(:,:), Y(:,:) + REAL(4), INTENT(OUT):: LAM(:,:), PHI(:,:) + + ! Local parameters + INTEGER :: I, J #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3CKCL_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_2D_R4') #endif - INCELL = .TRUE. -! -!-----must have >= 3 points to be a cell - IF ( NS .LT. 3 ) THEN - INCELL = .FALSE. - RETURN - END IF -! - IF ( PRESENT(EPS) ) THEN - IF ( EPS .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'W3CKCL_R8 ERROR -- ', & - 'EPS parameter must be >= 0' - CALL EXTCDE (1) - END IF - LEPS = EPS - ELSE - LEPS = EPS_DEFAULT - END IF - IF ( PRESENT(DEBUG) ) THEN - LDBG = DEBUG - ELSE - LDBG = .FALSE. - END IF -! -!-----set local copies - XXT = XT; XXS = XS; - YYT = YT; YYS = YS; -! -!-----check if cell includes a pole or branch cut - IF ( LLG ) THEN - N = 0 -!---------count longitudinal branch cut crossings - DO I=1,NS - J = MOD(I,NS) + 1 - IF ( ABS(XXS(J)-XXS(I)) .GT. D180 ) N = N + 1 - END DO -!---------multiple longitudinal branch cut crossing => cell includes branch cut - BCUT = N.GT.1 -!---------single longitudinal branch cut crossing -! or single vertex at 90 degrees => cell includes pole - POLE = N.EQ.1 .OR. COUNT(ABS(D90-ABS(YYS)).LE.LEPS).EQ.1 - ELSE - POLE = .FALSE. - BCUT = .FALSE. - END IF -! -!-----shift branch cut if necessary - IF ( BCUT ) THEN - IF ( MINVAL(XXS) .GE. ZERO ) THEN - WHERE ( XXS .GT. D180 ) XXS = XXS - D360 - IF ( XXT .GT. D180 ) XXT = XXT - D360 - ELSE - WHERE ( XXS .LT. ZERO ) XXS = XXS + D360 - IF ( XXT .LT. ZERO ) XXT = XXT + D360 - END IF - IF ( LDBG ) THEN - WRITE(*,'(A)') 'W3CKCL_R8 - CELL INCLUDES A BRANCH CUT' - WRITE(*,'(A,2E24.16,4(/A,1I1,A,2E24.16))') & - 'W3CKCL_R8 - SHIFT BRANCH CUT:',XXT,YYT, & - (' CORNER(',K,'):',XXS(K),YYS(K),K=1,4) - END IF - END IF -! -!-----check for coincidence with a cell vertex - DO I=1,NS -!---------if target point is coincident a cell vertex, then -! flag as in cell and return - IF ( ABS(XXT-XXS(I)).LE.LEPS .AND. ABS(YYT-YYS(I)).LE.LEPS ) THEN - IF ( LDBG ) & - WRITE(*,'(A,I1,A,2E24.16)') & - 'W3CKCL_R8 - COINCIDENT WITH CORNER(',I,'): ', & - ABS(XXT-XXS(I)),ABS(YYT-YYS(I)) -!-------------return branch cut shifted coordinates - IF ( BCUT ) THEN - XT = XXT; XS = XXS; - END IF - INCELL = .TRUE. - RETURN - END IF - END DO -! -!-----handle cell that includes a pole - IF ( POLE ) THEN -!---------perform cross-product check for each subcell - IF ( LDBG ) & - WRITE(*,'(A)') 'W3CKCL_R8 - CELL INCLUDES A POLE' - S90 = D90; IF ( MAXVAL(YS).LT.ZERO ) S90 = -D90; - SUBCELL_LOOP: DO I=1,NS - LSBC = .TRUE. - J = MOD(I,NS) + 1 - SIGN1 = 0.0 - DO K=1,4 - SELECT CASE (K) - CASE (1) -!---------------------vector from (xi,yi) to (xj,yj) - V1X = XXS(J) - XXS(I) - V1Y = YYS(J) - YYS(I) -!---------------------vector from (xi,yi) to (xt,yt) - V2X = XXT - XXS(I) - V2Y = YYT - YYS(I) - CASE (2) -!---------------------vector from (xj,yj) to (xj,90) - V1X = XXS(J) - XXS(J) - V1Y = S90 - YYS(J) -!---------------------vector from (xj,yj) to (xt,yt) - V2X = XXT - XXS(J) - V2Y = YYT - YYS(J) - CASE (3) -!---------------------vector from (xj,90) to (xi,90) - V1X = XXS(I) - XXS(J) - V1Y = S90 - S90 -!---------------------vector from (xj,90) to (xt,yt) - V2X = XXT - XXS(J) - V2Y = YYT - S90 - CASE (4) -!---------------------vector from (xi,90) to (xi,yi) - V1X = XXS(I) - XXS(I) - V1Y = YYS(I) - S90 -!---------------------vector from (xi,90) to (xt,yt) - V2X = XXT - XXS(I) - V2Y = YYT - S90 - END SELECT -!-----------------check for longitudinal branch cut crossing - IF ( ABS(V1X) .GT. D180 ) THEN - V1X = V1X - SIGN(D360,V1X) - END IF - IF ( ABS(V2X) .GT. D180 ) THEN - V2X = V2X - SIGN(D360,V2X) - END IF -!-----------------cross product - CROSS = V1X*V2Y - V1Y*V2X -!-----------------handle point that lies exacly on side or zero length side - IF ( ABS(CROSS) .LT. LEPS ) CROSS = ZERO - IF ( LDBG ) & - WRITE(*,'(A,3(I1,A),5E24.16)') 'W3CKCL_R8 - CROSS(', & - I,',',J,',',K,'):',V1X,V1Y,V2X,V2Y,CROSS -!-----------------if sign of cross product is not "unanimous" among the -! subcell sides, then target is outside the subcell - IF ( ABS(SIGN1) .LE. LEPS ) THEN - IF (ABS(CROSS) .GT. LEPS) SIGN1 = SIGN(ONE,CROSS) - ELSE - ! If point lies along a border, the cross product - ! is zero and its sign is not well defined - IF ( ABS(CROSS) .GT. LEPS ) THEN - IF ( SIGN(ONE,CROSS) .NE. SIGN1 ) THEN - LSBC = .FALSE. - CYCLE SUBCELL_LOOP - END IF - END IF - END IF - END DO !K - IF ( LSBC ) RETURN - END DO SUBCELL_LOOP - INCELL = .FALSE. - RETURN - ELSE -!---------use input coordinates - XCT = XXT; YCT = YYT; - XCS = XXS; YCS = YYS; - END IF !POLE -! -!-----perform cross-product cell check - SIGN1 = 0.0 - DO I=1,NS - J = MOD(I,NS) + 1 -!---------vector from (xi,yi) to (xj,yj) - V1X = XCS(J) - XCS(I) - V1Y = YCS(J) - YCS(I) -!---------vector from (xi,yi) to (xt,yt) - V2X = XCT - XCS(I) - V2Y = YCT - YCS(I) -!---------cross product - CROSS = V1X*V2Y - V1Y*V2X -!---------handle point that lies exacly on side or zero length side - IF ( ABS(CROSS) .LT. LEPS ) CROSS = ZERO - IF ( LDBG ) & - WRITE(*,'(A,2(I1,A),5E24.16)') 'W3CKCL_R8 - CROSS(', & - I,',',J,'):',V1X,V1Y,V2X,V2Y,CROSS -!---------if sign of cross product is not "unanimous" among the cell sides, -! then target is outside the cell - IF ( ABS(SIGN1) .LE. LEPS ) THEN - IF (ABS(CROSS) .GT. LEPS) SIGN1 = SIGN(ONE,CROSS) - ELSE - ! If point lies along a border, the cross product - ! is zero and its sign is not well defined - IF ( ABS(CROSS) .GT. LEPS ) THEN - IF ( SIGN(ONE,CROSS) .NE. SIGN1 ) THEN - INCELL = .FALSE. - RETURN - END IF - END IF - END IF - END DO -! -!-----return branch cut shifted coordinates - IF ( BCUT ) THEN - XT = XXT; XS = XXS; - END IF + DO J = LBOUND(X,2),UBOUND(X,2) + DO I = LBOUND(X,1),UBOUND(X,1) + CALL W3SPXL( LAM0, PHI0, C0, X(I,J), Y(I,J), LAM(I,J), PHI(I,J) ) + ENDDO + ENDDO + + END SUBROUTINE W3SPXL_2D_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SPXL_2D_R8( LAM0, PHI0, C0, X, Y, LAM, PHI ) + ! Double precision 2D array interface + REAL(8), INTENT(IN) :: LAM0, PHI0, C0 + REAL(8), INTENT(IN) :: X(:,:), Y(:,:) + REAL(8), INTENT(OUT):: LAM(:,:), PHI(:,:) + + ! Local parameters + INTEGER :: I, J +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_2D_R8') +#endif - END FUNCTION W3CKCL_R8 -!/ -!/ End of W3CKCL ===================================================== / -!/ + DO J = LBOUND(X,2),UBOUND(X,2) + DO I = LBOUND(X,1),UBOUND(X,1) + CALL W3SPXL( LAM0, PHI0, C0, X(I,J), Y(I,J), LAM(I,J), PHI(I,J) ) + ENDDO + ENDDO + + END SUBROUTINE W3SPXL_2D_R8 + !/ + !/ End of W3SPXL ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3TRLL( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute longitude and latitude for input coordinates in a + ! coordinate system with the North Pole placed at a latitude + ! PHI0 on a meridian LAM0 east of the central meridian. + ! + ! 2. Method : + ! + ! Map Projections -- A Working Manual, John P. Snyder + ! U.S. Geological Survey professional paper; 1395 + ! Chapter 5. Transformation of Map Graticules + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! LAM0 Real I Longitude of North Pole + ! PHI0 Real I Latitude of North Pole + ! LAM1 Real I Input Longitude + ! PHI1 Real I Input Latitude + ! LAM Real O Transformed Longitude + ! PHI Real O Transformed Latitude + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3TRLL_0D_R4( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) + ! Single precision point interface + REAL(4), INTENT(IN) :: LAM0, PHI0 + REAL(4), INTENT(IN) :: LAM1, PHI1 + REAL(4), INTENT(OUT):: LAM, PHI + + ! Local parameters + REAL(8) :: CLAM, SLAM, CALP, SALP, CPHI, SPHI +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_0D_R4') +#endif + CLAM = COS((LAM1-LAM0)*D2R) + SLAM = SIN((LAM1-LAM0)*D2R) + CALP = COS(PHI0*D2R) + SALP = SIN(PHI0*D2R) + CPHI = COS(PHI1*D2R) + SPHI = SIN(PHI1*D2R) + LAM = LAM0 + ATAN2(CPHI*SLAM,SALP*CPHI*CLAM+CALP*SPHI)*R2D + PHI = ASIN(SALP*SPHI-CALP*CPHI*CLAM)*R2D + + END SUBROUTINE W3TRLL_0D_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3TRLL_0D_R8( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) + ! Double precision point interface + REAL(8), INTENT(IN) :: LAM0, PHI0 + REAL(8), INTENT(IN) :: LAM1, PHI1 + REAL(8), INTENT(OUT):: LAM, PHI + + ! Local parameters + REAL(8) :: CLAM, SLAM, CALP, SALP, CPHI, SPHI +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_0D_R8') +#endif + CLAM = COS((LAM1-LAM0)*D2R) + SLAM = SIN((LAM1-LAM0)*D2R) + CALP = COS(PHI0*D2R) + SALP = SIN(PHI0*D2R) + CPHI = COS(PHI1*D2R) + SPHI = SIN(PHI1*D2R) + LAM = LAM0 + ATAN2(CPHI*SLAM,SALP*CPHI*CLAM+CALP*SPHI)*R2D + PHI = ASIN(SALP*SPHI-CALP*CPHI*CLAM)*R2D + + END SUBROUTINE W3TRLL_0D_R8 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3TRLL_1D_R4( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) + ! Single precision 1D array interface + REAL(4), INTENT(IN) :: LAM0, PHI0 + REAL(4), INTENT(IN) :: LAM1(:), PHI1(:) + REAL(4), INTENT(OUT):: LAM(:), PHI(:) + + ! Local parameters + INTEGER :: I +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_1D_R4') +#endif + DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) + CALL W3TRLL( LAM0, PHI0, LAM1(I), PHI1(I), LAM(I), PHI(I) ) + ENDDO + + END SUBROUTINE W3TRLL_1D_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3TRLL_1D_R8( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) + ! Double precision 1D array interface + REAL(8), INTENT(IN) :: LAM0, PHI0 + REAL(8), INTENT(IN) :: LAM1(:), PHI1(:) + REAL(8), INTENT(OUT):: LAM(:), PHI(:) + + ! Local parameters + INTEGER :: I +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_1D_R8') +#endif + DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) + CALL W3TRLL( LAM0, PHI0, LAM1(I), PHI1(I), LAM(I), PHI(I) ) + ENDDO + + END SUBROUTINE W3TRLL_1D_R8 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3TRLL_2D_R4( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) + ! Single precision 2D array interface + REAL(4), INTENT(IN) :: LAM0, PHI0 + REAL(4), INTENT(IN) :: LAM1(:,:), PHI1(:,:) + REAL(4), INTENT(OUT):: LAM(:,:), PHI(:,:) + + ! Local parameters + INTEGER :: I, J +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_2D_R4') +#endif + DO J = LBOUND(LAM1,2),UBOUND(LAM1,2) + DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) + CALL W3TRLL( LAM0, PHI0, LAM1(I,J), PHI1(I,J), LAM(I,J), PHI(I,J) ) + ENDDO + ENDDO + + END SUBROUTINE W3TRLL_2D_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3TRLL_2D_R8( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) + ! Double precision 2D array interface + REAL(8), INTENT(IN) :: LAM0, PHI0 + REAL(8), INTENT(IN) :: LAM1(:,:), PHI1(:,:) + REAL(8), INTENT(OUT):: LAM(:,:), PHI(:,:) + + ! Local parameters + INTEGER :: I, J +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_2D_R8') +#endif + DO J = LBOUND(LAM1,2),UBOUND(LAM1,2) + DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) + CALL W3TRLL( LAM0, PHI0, LAM1(I,J), PHI1(I,J), LAM(I,J), PHI(I,J) ) + ENDDO + ENDDO + + END SUBROUTINE W3TRLL_2D_R8 + !/ + !/ End of W3TRLL ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3LLAZ( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute azimuth (Az) east of north which point (LAM2,PHI2) bears + ! to point (LAM1,PHI1). + ! + ! 2. Method : + ! + ! Map Projections -- A Working Manual, John P. Snyder + ! U.S. Geological Survey professional paper; 1395 + ! Chapter 5. Transformation of Map Graticules + ! + ! 3. Parameters : + ! + ! Return parameter + ! ---------------------------------------------------------------- + ! AZ Real O Azimuth in degrees east of north + ! ---------------------------------------------------------------- + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! LAM1 Real I Longitude for point 1 + ! PHI1 Real I Latitude for point 1 + ! LAM2 Real I Longitude for point 2 + ! PHI2 Real I Latitude for point 2 + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3LLAZ_R4( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ) + ! Single precision interface + REAL(4) :: AZ + REAL(4), INTENT(IN):: LAM1, PHI1 + REAL(4), INTENT(IN):: LAM2, PHI2 + + ! Local parameters + REAL(8) :: CLAM, SLAM, CPH1, SPH1, CPH2, SPH2 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3LLAZ_R4') +#endif + CLAM = COS((LAM2-LAM1)*D2R) + SLAM = SIN((LAM2-LAM1)*D2R) + CPH1 = COS(PHI1*D2R) + SPH1 = SIN(PHI1*D2R) + CPH2 = COS(PHI2*D2R) + SPH2 = SIN(PHI2*D2R) + AZ = ATAN2(CPH2*SLAM,CPH1*SPH2-SPH1*CPH2*CLAM)*R2D + + END FUNCTION W3LLAZ_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3LLAZ_R8( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ) + ! Double precision interface + REAL(8) :: AZ + REAL(8), INTENT(IN):: LAM1, PHI1 + REAL(8), INTENT(IN):: LAM2, PHI2 + + ! Local parameters + REAL(8) :: CLAM, SLAM, CPH1, SPH1, CPH2, SPH2 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3LLAZ_R8') +#endif -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3CGDM( IJG, LLG, ICLO, PTILED, QTILED, & -!/ PRANGE, QRANGE, LBI, UBI, LBO, UBO, X, Y, & -!/ MASK, NFD, SPHERE, RADIUS, DX, DY, & -!/ GPPC, GQQC, GPQC, GSQR, & -!/ HPFC, HQFC, APPC, AQQC, APQC, & -!/ DXDP, DYDP, DXDQ, DYDQ, & -!/ DPDX, DPDY, DQDX, DQDY, & -!/ COSA, COSC, SINC, ANGL, RC ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute curvilinear grid derivatives and metric. -! -! 2. Method : -! -! Curvilinear grid is defined by the input coordinates as a function -! of the (P,Q) index coordinates: -! -! x = x(p,q), y = y(p,q), dp = dq = 1. -! -! When using spherical coordinates (llg=T) x = longitude and -! y = latitude in degrees. The optional sphere input (default is true) -! controls whether or not the spherical coordinate metric is applied. -! If sphere is true, then the spherical coordinate metric is applied -! to the coordinate derivatives with respect to p & q. In other words, -! -! dx/dp <= d2r*radius*cos(y)*(dx/dp), -! dx/dq <= d2r*radius*cos(y)*(dx/dq), -! dy/dp <= d2r*radius*(dy/dp), and -! dy/dq <= d2r*radius*(dy/dq). -! -! The default radius is Rearth. -! -! The covariant metric tensor components are -! -! g_pp = (dx/dp)*(dx/dp) + (dy/dp)*(dy/dp), -! g_qq = (dx/dq)*(dx/dq) + (dy/dq)*(dy/dq), -! g_pq = (dx/dp)*(dx/dq) + (dy/dp)*(dy/dq). -! -! The contravariant (associated) metric tensor components are -! -! g^pp = (dp/dx)*(dp/dx) + (dp/dy)*(dp/dy), -! g^qq = (dq/dx)*(dq/dx) + (dq/dy)*(dq/dy), -! g^pq = (dp/dx)*(dq/dx) + (dp/dy)*(dq/dy). -! -! The curvilinear scale factors are h_p = sqrt(g_pp) and h_q = sqrt(g_qq). -! The square root of determinant of metric tensor is -! -! sqrt(|g|) = sqrt( g_pp*g_qq - g_pq^2 ) -! = (dx/dp)(dy/dq) - (dx/dq)(dy/dp) -! = h_p*h_q*sqrt(sin(alpha)) -! = cell area. -! -! The curvilinear derivatives are computed as -! -! dp/dx = (1/sqrt(g))*(dy/dq), -! dp/dy = -(1/sqrt(g))*(dx/dq), -! dq/dx = -(1/sqrt(g))*(dy/dp), -! dq/dy = (1/sqrt(g))*(dx/dp). -! -! Orthogonality of grid can be checked by computing angle between the -! curvilinear coordinate unit vectors: -! -! cos(alpha) = g_pq/(h_p*h_q) = uvec_p \dot uvec_q, -! -! where -! -! uvec_p = (1/h_p)*(dx/dp)*uvec_x + (1/h_p)*(dy/dp)*uvec_y, -! uvec_q = (1/h_q)*(dx/dq)*uvec_x + (1/h_q)*(dy/dq)*uvec_y. -! -! The local cell rotation angle is (assuming orthogonal): -! -! cos(theta) = (1/h_p)*dx/dp, -! sin(theta) = (1/h_q)*dy/dp, -! theta = atan2((1/h_q)*dy/dp,(1/h_p)*dx/dp). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IJG Log. I Logical flag indicating ordering of input -! coord. arrays: T = (NP,NQ) and F = (NP,NQ) -! LLG Log. I Spherical coordinate (lon,lat) flag -! ICLO Int. I Parameter indicating type of index space closure -! PTILED Log. I Logical flag indicating that input arrays are tiled -! in P-axis with halos of width >= NFD/2 -! QTILED Log. I Logical flag indicating that input arrays are tiled -! in Q-axis with halos of width >= NFD/2 -! PRANGE I.A. I Range of P index coordinate: P in [PRANGE(1),PRANGE(2)] -! QRANGE I.A. I Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)] -! LBI I.A. I Lower-bound of input arrays, DIMENSION(2) -! UBI I.A. I Upper-bound of input arrays, DIMENSION(2) -! LBO I.A. I Lower-bound of output arrays, DIMENSION(2) -! UBO I.A. I Upper-bound of output arrays, DIMENSION(2) -! X R.A. I Gridded X-coordinates, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! Y R.A. I Gridded Y-coordinates, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! MASK L.A. I OPTIONAL logical mask (T = invalid, F = valid) -! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! NFD Int. I OPTIONAL finite-difference order (even), Default is NFD_DEFAULT. -! SPHERE Log. I OPTIONAL apply spherical coord metric if LLG, Default is T -! RADIUS Real I OPTIONAL radius for sphere. Default is REARTH -! DX Real I OPTIONAL constant spacing in x-direction -! DY Real I OPTIONAL constant spacing in y-direction -! GPPC R.A. O OPTIONAL g_pp, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! GQQC R.A. O OPTIONAL g_qq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! GPQC R.A. O OPTIONAL g_pq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! GSQR R.A. O OPTIONAL sqrt(|g|), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! HPFC R.A. O OPTIONAL h_p, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! HQFC R.A. O OPTIONAL h_q, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! APPC R.A. O OPTIONAL g^pp, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! AQQC R.A. O OPTIONAL g^qq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! APQC R.A. O OPTIONAL g^pq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! DXDP R.A. O OPTIONAL dx/dp, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! DYDP R.A. O OPTIONAL dy/dp, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! DXDQ R.A. O OPTIONAL dx/dq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! DYDQ R.A. O OPTIONAL dy/dq, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! DPDX R.A. O OPTIONAL dp/dx, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! DPDY R.A. O OPTIONAL dp/dy, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! DQDX R.A. O OPTIONAL dq/dx, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! DQDY R.A. O OPTIONAL dq/dy, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! COSA R.A. O OPTIONAL cos(alpha), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! COSC R.A. O OPTIONAL cos(theta), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! SINC R.A. O OPTIONAL sin(theta), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! ANGL R.A. O OPTIONAL theta, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! RC Int. O OPTIONAL return code (!= 0 if error occurs) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! - The derivatives and metric will be computed using the constant -! spacing DX and/or DY if they are specified. DX & DY are assumed -! to be in degrees when LLG = T. -! - The grid derivatives (dx/dp, dy/dp, dx/dq, dy/dq) are computed -! using a finite difference method. -! - When LLG = T, the finite differences are done in a polar -! stereographic projection. -! - If RC is not provided and an error occurs, then the routine will -! report error to stderr and attempt to abort the calling program. -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3CGDM_R4( IJG, LLG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, X, Y, & - MASK, NFD, SPHERE, RADIUS, DX, DY, & - GPPC, GQQC, GPQC, GSQR, & - HPFC, HQFC, APPC, AQQC, APQC, & - DXDP, DYDP, DXDQ, DYDQ, & - DPDX, DPDY, DQDX, DQDY, & - COSA, COSC, SINC, ANGL, RC ) -! Single precision interface - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LBI(2), UBI(2) - INTEGER, INTENT(IN) :: LBO(2), UBO(2) - REAL(4), INTENT(IN) :: X(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: Y(LBI(1):UBI(1),LBI(2):UBI(2)) - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) - INTEGER, INTENT(IN), OPTIONAL :: NFD - LOGICAL, INTENT(IN), OPTIONAL :: SPHERE - REAL(4), INTENT(IN), OPTIONAL :: RADIUS - REAL(4), INTENT(IN), OPTIONAL :: DX, DY - REAL(4), INTENT(OUT), OPTIONAL :: GPPC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: GQQC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: GPQC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: GSQR(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: HPFC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: HQFC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: APPC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: AQQC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: APQC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: DXDP(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: DYDP(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: DXDQ(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: DYDQ(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: DPDX(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: DPDY(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: DQDX(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: DQDY(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: COSA(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: COSC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: SINC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT), OPTIONAL :: ANGL(LBO(1):UBO(1),LBO(2):UBO(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - REAL(8), PARAMETER :: SMALL = 1D-15 - INTEGER :: ISTAT=0, N, NP, NQ, I1, I2, P, Q - LOGICAL :: SPHR - REAL(8) :: R, FACX, FACY - INTEGER, ALLOCATABLE :: K(:,:,:), K2(:,:,:) - REAL(8), ALLOCATABLE :: C(:,:,:), C2(:,:,:) - REAL(8) :: GPPCL, GQQCL, GPQCL - REAL(8) :: GSQRL, HPFCL, HQFCL - REAL(8) :: APPCL, AQQCL, APQCL - REAL(8) :: DXDPL, DYDPL, DXDQL, DYDQL - REAL(8) :: DPDXL, DPDYL, DQDXL, DQDYL - REAL(8) :: COSAL, SINAL, COSTP, SINTP, COSCL, SINCL, ANGLL + CLAM = COS((LAM2-LAM1)*D2R) + SLAM = SIN((LAM2-LAM1)*D2R) + CPH1 = COS(PHI1*D2R) + SPH1 = SIN(PHI1*D2R) + CPH2 = COS(PHI2*D2R) + SPH2 = SIN(PHI2*D2R) + AZ = ATAN2(CPH2*SLAM,CPH1*SPH2-SPH1*CPH2*CLAM)*R2D + + END FUNCTION W3LLAZ_R8 + !/ + !/ End of W3LLAZ ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3FDWT( N, ND, M, Z, X, C ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Compute finite-difference weights on arbitrarily spaced + ! 1-D node sets. + ! + ! 2. Method : + ! + ! Fornberg, B., Calculation of weights in finite difference formulas, + ! SIAM Rev. 40:685-691, 1998. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! N Int. I One less than total number of grid points; + ! n must not exceed the parameter nd below. + ! ND Int. I Dimension of X- and C-arrays in calling program + ! X(0:ND) and C(0:ND,0:M), respectively. + ! M Int. I Highest derivative for which weights are sought. + ! Z Real I Location where approximations are to be accurate. + ! X R.A. I Grid point locations, found in X(0:N) + ! C R.A. O Weights at grid locations X(0:N) for derivatives + ! of order 0:M, found in C(0:N,0:M) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3FDWT_R4 ( N, ND, M, Z, X, C ) + ! Single precision interface + INTEGER, INTENT(IN) :: N, ND, M + REAL(4), INTENT(IN) :: Z + REAL(4), INTENT(IN) :: X(0:ND) + REAL(4), INTENT(OUT) :: C(0:ND,0:M) + + ! Local parameters + INTEGER :: I, J, K, MN + REAL(8) :: C1, C2, C3, C4, C5 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3CGDM_R4') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3FDWT_R4') #endif -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - IF ( PRESENT(NFD) ) THEN - N = NFD - ELSE - N = NFD_DEFAULT - END IF - IF ( N.LE.0 .OR. MOD(N,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & - 'NFD must be even and greater than zero' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF + C1 = ONE + C4 = X(0)-Z + C(:,:) = ZERO + C(0,0) = ONE + ILOOP: DO I = 1,N + MN = MIN(I,M) + C2 = ONE + C5 = C4 + C4 = X(I)-Z + JLOOP: DO J = 0,I-1 + C3 = X(I)-X(J) + C2 = C2*C3 + IF ( J.EQ.I-1 ) THEN + DO K = MN,1,-1 + C(I,K) = C1*(K*C(I-1,K-1)-C5*C(I-1,K))/C2 + END DO + C(I,0) = -C1*C5*C(I-1,0)/C2 + END IF + DO K = MN,1,-1 + C(J,K) = (C4*C(J,K)-K*C(J,K-1))/C3 + END DO + C(J,0) = C4*C(J,0)/C3 + END DO JLOOP + C1 = C2 + END DO ILOOP + + END SUBROUTINE W3FDWT_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3FDWT_R8 ( N, ND, M, Z, X, C ) + ! Double precision interface + INTEGER, INTENT(IN) :: N, ND, M + REAL(8), INTENT(IN) :: Z + REAL(8), INTENT(IN) :: X(0:ND) + REAL(8), INTENT(OUT) :: C(0:ND,0:M) + + ! Local parameters + INTEGER :: I, J, K, MN + REAL(8) :: C1, C2, C3, C4, C5 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3FDWT_R4') +#endif - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 + C1 = ONE + C4 = X(0)-Z + C(:,:) = ZERO + C(0,0) = ONE + ILOOP: DO I = 1,N + MN = MIN(I,M) + C2 = ONE + C5 = C4 + C4 = X(I)-Z + JLOOP: DO J = 0,I-1 + C3 = X(I)-X(J) + C2 = C2*C3 + IF ( J.EQ.I-1 ) THEN + DO K = MN,1,-1 + C(I,K) = C1*(K*C(I-1,K-1)-C5*C(I-1,K))/C2 + END DO + C(I,0) = -C1*C5*C(I-1,0)/C2 + END IF + DO K = MN,1,-1 + C(J,K) = (C4*C(J,K)-K*C(J,K-1))/C3 + END DO + C(J,0) = C4*C(J,0)/C3 + END DO JLOOP + C1 = C2 + END DO ILOOP + + END SUBROUTINE W3FDWT_R8 + !/ + !/ End of W3FDWT ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3NNSC( NLVL ) RESULT(NNS) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Create nearest-neighbor (NNBR) search object. + ! + ! 2. Method : + ! + ! Notation + ! ( L, N): L = NNBR level; N = NNBR sequential index + ! {DI, DJ}: DI = I-index delta; DJ = J-index delta + ! + ! --------------------------------------------------- + ! | ( 2,21) | ( 2,20) | ( 2,19) | ( 2,18) | ( 2,17) | + ! | {-2,+2} | {-1,+2} | { 0,+2} | {+1,+2} | {+2,+2} | + ! --------------------------------------------------- + ! | ( 2,22) | ( 1, 7) | ( 1, 6) | ( 1, 5) | ( 2,16) | + ! | {-2,+1} | {-1,+1} | { 0,+1} | {+1,+1} | {+2,+1} | + ! --------------------------------------------------- + ! | ( 2,23) | ( 1, 8) | ( 0, 0) | ( 1, 4) | ( 2,15) | + ! | {-2, 0} | {-1, 0} | { 0, 0} | {+1, 0} | {+2, 0} | + ! --------------------------------------------------- + ! | ( 2,24) | ( 1, 1) | ( 1, 2) | ( 1, 3) | ( 2,14) | + ! | {-2,-1} | {-1,-1} | { 0,-1} | {+1,-1} | {+2,-1} | + ! --------------------------------------------------- + ! | ( 2, 9) | ( 2,10) | ( 2,11) | ( 2,12) | ( 2,13) | + ! | {-2,-2} | {-1,-2} | { 0,-2} | {+1,-2} | {+2,-2} | + ! --------------------------------------------------- + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3NNSC( NLVL ) RESULT(NNS) + TYPE(T_NNS), POINTER :: NNS + INTEGER, INTENT(IN) :: NLVL + + ! Local parameters + INTEGER :: I, J, L, N +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3NNSC') +#endif + ! + !-----allocate object + ALLOCATE(NNS) + + !-----initialize sizes + NNS%NLVL = NLVL + NNS%NNBR = (2*NLVL+1)**2 + + !-----allocate arrays + ALLOCATE(NNS%N1(0:NNS%NLVL)) + ALLOCATE(NNS%N2(0:NNS%NLVL)) + ALLOCATE(NNS%DI(0:NNS%NNBR-1)) + ALLOCATE(NNS%DJ(0:NNS%NNBR-1)) + + !-----compute index deltas for nearest-neighbor searches + N = 0 + !-----central point + L = 0 + NNS%N1(L) = 0; NNS%N2(L) = (2*L+1)**2-1; + NNS%DI(N) = 0; NNS%DJ(N) = 0; + !-----loop over levels + DO L=1,NNS%NLVL + !---------nnbr loop bounds + NNS%N1(L) = (2*L-1)**2; NNS%N2(L) = (2*L+1)**2-1; + !---------bottom-layer + J = -L + DO I=-L,L-1 + N = N + 1 + NNS%DI(N) = I; NNS%DJ(N) = J; + END DO + !---------right-layer + I = L + DO J=-L,L-1 + N = N + 1 + NNS%DI(N) = I; NNS%DJ(N) = J; + END DO + !---------top-layer + J = L + DO I=L,-L+1,-1 + N = N + 1 + NNS%DI(N) = I; NNS%DJ(N) = J; + END DO + !---------left-layer + I = -L + DO J=L,-L+1,-1 + N = N + 1 + NNS%DI(N) = I; NNS%DJ(N) = J; + END DO + END DO !loop over levels + + END FUNCTION W3NNSC + !/ + !/ End of W3NNSC ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3NNSD( NNS ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Destroy nearest-neighbor (NNBR) search object. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3NNSD( NNS ) + TYPE(T_NNS), POINTER :: NNS + + ! Local parameters +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3NNSD') +#endif + ! + IF ( ASSOCIATED(NNS) ) THEN + NNS%NLVL = 0 + NNS%NNBR = 0 + IF ( ASSOCIATED(NNS%N1) ) THEN + DEALLOCATE(NNS%N1); NULLIFY(NNS%N1); + END IF + IF ( ASSOCIATED(NNS%N2) ) THEN + DEALLOCATE(NNS%N2); NULLIFY(NNS%N2); + END IF + IF ( ASSOCIATED(NNS%DI) ) THEN + DEALLOCATE(NNS%DI); NULLIFY(NNS%DI); + END IF + IF ( ASSOCIATED(NNS%DJ) ) THEN + DEALLOCATE(NNS%DJ); NULLIFY(NNS%DJ); + END IF + DEALLOCATE(NNS) + NULLIFY(NNS) + END IF + + END SUBROUTINE W3NNSD + !/ + !/ End of W3NNSD ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3NNSP( NNS, IUNIT ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Print nearest-neighbor (NNBR) search object to IUNIT. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NNBR Type I Nearest-neighbor search object. + ! IUNIT Int. I OPTIONAL unit for output. Default is stdout. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3NNSP(NNS, IUNIT) + TYPE(T_NNS), INTENT(IN) :: NNS + INTEGER, OPTIONAL, INTENT(IN) :: IUNIT + + ! Local parameters + INTEGER :: NDST, L, N +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3NNSP') +#endif + ! + IF ( PRESENT(IUNIT) ) THEN + NDST = IUNIT + ELSE + NDST = 6 + END IF + ! + WRITE(NDST,'(A,2I6)') 'nlvl,nnbr:',NNS%NLVL,NNS%NNBR + DO L=0,NNS%NLVL + DO N=NNS%N1(L),NNS%N2(L) + WRITE(NDST,'(A,4I6)') 'l,n,di,dj:',L,N,NNS%DI(N),NNS%DJ(N) + END DO + END DO + + END SUBROUTINE W3NNSP + !/ + !/ End of W3NNSP ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3SORT( N, I, J, D ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Sort input arrays in increasing order according to input array D. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SORT_R4( N, I, J, D ) + ! Single precision interface. + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(INOUT) :: I(N) + INTEGER, INTENT(INOUT) :: J(N) + REAL(4), INTENT(INOUT) :: D(N) + + ! Local parameters + INTEGER :: K, L, IM, JM + REAL(4) :: DM +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SORT_R4') +#endif - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) - CONTINUE - CASE DEFAULT - WRITE(0,'(/1A,1A,1I2/)') 'W3CGDM ERROR -- ', & - 'unsupported ICLO: ',ICLO - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END SELECT + DO K=1, N-1 + DO L=K+1, N + IF ( D(L) .LT. D(K) ) THEN + IM = I(K); JM = J(K); DM = D(K); + I(K) = I(L); J(K) = J(L); D(K) = D(L); + I(L) = IM; J(L) = JM; D(L) = DM; + END IF + END DO !L + END DO !K + + END SUBROUTINE W3SORT_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SORT_R8( N, I, J, D ) + ! Double precision interface. + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(INOUT) :: I(N) + INTEGER, INTENT(INOUT) :: J(N) + REAL(8), INTENT(INOUT) :: D(N) + + ! Local parameters + INTEGER :: K, L, IM, JM + REAL(8) :: DM +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SORT_R8') +#endif - IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & - 'tripole grid closure requires NP even' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF + DO K=1, N-1 + DO L=K+1, N + IF ( D(L) .LT. D(K) ) THEN + IM = I(K); JM = J(K); DM = D(K); + I(K) = I(L); J(K) = J(L); D(K) = D(L); + I(L) = IM; J(L) = JM; D(L) = DM; + END IF + END DO !L + END DO !K + + END SUBROUTINE W3SORT_R8 + !/ + !/ End of W3SORT ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ SUBROUTINE W3ISRT( II, JJ, DD, N, I, J, D ) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Insert DD data into D at location where DD < D(K). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3ISRT_R4( II, JJ, DD, N, I, J, D ) + ! Single precision interface + INTEGER, INTENT(IN) :: II + INTEGER, INTENT(IN) :: JJ + REAL(4), INTENT(IN) :: DD + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(INOUT) :: I(N) + INTEGER, INTENT(INOUT) :: J(N) + REAL(4), INTENT(INOUT) :: D(N) + + ! Local parameters + INTEGER :: K, L +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3ISRT_R4') +#endif - IF ( PRESENT(SPHERE) ) THEN - SPHR = SPHERE - ELSE - SPHR = .TRUE. - END IF + K_LOOP: DO K=1,N + IF ( DD .LT. D(K) ) THEN + !-------------right-shift list (>= k) + DO L=N,K+1,-1 + I(L) = I(L-1); J(L) = J(L-1); D(L) = D(L-1); + END DO !L + !-------------insert point into list at k + I(K) = II; J(K) = JJ; D(K) = DD; + EXIT K_LOOP + END IF !dd.lt.d(k) + END DO K_LOOP + + END SUBROUTINE W3ISRT_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3ISRT_R8( II, JJ, DD, N, I, J, D ) + ! Double precision interface + INTEGER, INTENT(IN) :: II + INTEGER, INTENT(IN) :: JJ + REAL(8), INTENT(IN) :: DD + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(INOUT) :: I(N) + INTEGER, INTENT(INOUT) :: J(N) + REAL(8), INTENT(INOUT) :: D(N) + + ! Local parameters + INTEGER :: K, L +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3ISRT_R8') +#endif - IF ( PRESENT(RADIUS) ) THEN - R = RADIUS - ELSE - R = REARTH - END IF - FACY = R*D2R + K_LOOP: DO K=1,N + IF ( DD .LT. D(K) ) THEN + !-------------right-shift list (>= k) + DO L=N,K+1,-1 + I(L) = I(L-1); J(L) = J(L-1); D(L) = D(L-1); + END DO !L + !-------------insert point into list at k + I(K) = II; J(K) = JJ; D(K) = DD; + EXIT K_LOOP + END IF !dd.lt.d(k) + END DO K_LOOP + + END SUBROUTINE W3ISRT_R8 + !/ + !/ End of W3ISRT ===================================================== / + !/ + + + + + + + + + !/ + !/ =================================================================== / + !/ + !/ FUNCTION W3INAN( X ) RESULT(INAN) + !/ + !/ =================================================================== / + !/ + ! 1. Purpose : + ! + ! Return TRUE if input is infinite or NaN (not a number). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3INAN_R4( X ) RESULT(INAN) + ! Single precision interface + LOGICAL :: INAN + REAL(4), INTENT(IN) :: X + + ! Local parameters +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3INAN_R4') +#endif - IF ( PRESENT(DX) ) THEN - IF ( DX.LE.ZERO ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DX must be > 0' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - END IF + !-----return true if X is NaN or +Inf or -Inf + INAN = .NOT. ( X .GE. -HUGE(X) .AND. X .LE. HUGE(X) ) - IF ( PRESENT(DY) ) THEN - IF ( DY.LE.ZERO ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DY must be > 0' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - END IF -! -! -------------------------------------------------------------------- / -! 2. Setup finite difference coefficients -! - ALLOCATE ( K(0:N,0:N,1:N), C(0:N,0:N,1:N), STAT=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & - 'finite difference coeff allocation failed' - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - CALL GET_FDW3 ( N, M, K, C ) + END FUNCTION W3INAN_R4 + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION W3INAN_R8( X ) RESULT(INAN) + ! Double precision interface + LOGICAL :: INAN + REAL(8), INTENT(IN) :: X - ALLOCATE ( K2(0:2,0:2,1:2), C2(0:2,0:2,1:2), STAT=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & - 'finite difference coeff allocation for N=2 failed' - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - CALL GET_FDW3 ( 2, M, K2, C2 ) -! -! -------------------------------------------------------------------- / -! 3. Compute optional return quantities -! - DO I2 = LBO(2), UBO(2) - DO I1 = LBO(1), UBO(1) - IF ( IJG ) THEN - P = I1 - Q = I2 - ELSE - P = I2 - Q = I1 - END IF - IF ( PRESENT(DX) ) THEN - DXDPL = DX - DYDPL = ZERO - ELSE - CALL DXYDP( N, K, C, IJG, LLG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, DXDPL, DYDPL, & - MASK=MASK, X4=X, Y4=Y, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - END IF - IF ( PRESENT(DY) ) THEN - DXDQL = ZERO - DYDQL = DY - ELSE - CALL DXYDQ( N, K, C, IJG, LLG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, DXDQL, DYDQL, & - MASK=MASK, X4=X, Y4=Y, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - END IF - IF ( LLG .AND. SPHR ) THEN - FACX = FACY*COS(REAL(Y(I1,I2),8)*D2R) - DXDPL = DXDPL*FACX - DYDPL = DYDPL*FACY - DXDQL = DXDQL*FACX - DYDQL = DYDQL*FACY - END IF - GSQRL = DXDPL*DYDQL - DXDQL*DYDPL - IF ( GSQRL .LT. ZERO .AND. N .GT. 2 ) THEN -! WRITE(0,'(1A,1I0,1A,1I0,1A,1I0,2A)') & -! 'W3CGDM WARNING -- NFD = ',N, & -! ' yields GSQRL < 0 at (',P,',',Q,'):', & -! ' computing metrics using NFD = 2' - IF ( PRESENT(DX) ) THEN - DXDPL = DX - DYDPL = ZERO - ELSE - CALL DXYDP( 2, K2, C2, IJG, LLG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, DXDPL, DYDPL, & - MASK=MASK, X4=X, Y4=Y, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - END IF - IF ( PRESENT(DY) ) THEN - DXDQL = ZERO - DYDQL = DY - ELSE - CALL DXYDQ( 2, K2, C2, IJG, LLG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, DXDQL, DYDQL, & - MASK=MASK, X4=X, Y4=Y, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - END IF - IF ( LLG .AND. SPHR ) THEN - FACX = FACY*COS(REAL(Y(I1,I2),8)*D2R) - DXDPL = DXDPL*FACX - DYDPL = DYDPL*FACY - DXDQL = DXDQL*FACX - DYDQL = DYDQL*FACY - END IF - GSQRL = DXDPL*DYDQL - DXDQL*DYDPL - END IF - IF ( GSQRL .LT. ZERO ) THEN - ISTAT = 1 - WRITE(0,'(/1A,1A)') 'W3CGDM ERROR -- ', & - 'input coordinates do not define a '// & - 'right-handed coordinate system' - WRITE(0,'(1A,2A6,5A16)') 'W3CGDM ERROR --', & - 'P','Q','GSQRL','DXDPL','DYDQL','DXDQL','DYDPL' - WRITE(0,'(1A,2I6,5E16.8/)') 'W3CGDM ERROR --', & - P,Q,GSQRL,DXDPL,DYDQL,DXDQL,DYDPL - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - GPPCL = DXDPL*DXDPL + DYDPL*DYDPL - GQQCL = DXDQL*DXDQL + DYDQL*DYDQL - GPQCL = DXDPL*DXDQL + DYDPL*DYDQL - GSQRL = MAX(GSQRL,SMALL) - GPPCL = MAX(GPPCL,SMALL) - GQQCL = MAX(GQQCL,SMALL) - DPDXL = DYDQL/GSQRL - DPDYL =-DXDQL/GSQRL - DQDXL =-DYDPL/GSQRL - DQDYL = DXDPL/GSQRL - APPCL = DPDXL*DPDXL + DPDYL*DPDYL - AQQCL = DQDXL*DQDXL + DQDYL*DQDYL - APQCL = DPDXL*DQDXL + DPDYL*DQDYL - HPFCL = SQRT(GPPCL) - HQFCL = SQRT(GQQCL) - COSAL = GPQCL/(HPFCL*HQFCL) - SINAL = GSQRL**2/(GPPCL*GQQCL) - COSTP = DXDPL/HPFCL - SINTP = DYDPL/HQFCL - COSCL = SINAL*COSTP + COSAL*SINTP - SINCL = SINAL*SINTP - COSAL*COSTP - ANGLL = ATAN2(SINCL,COSCL)*R2D - IF (PRESENT(GPPC)) GPPC(I1,I2) = GPPCL - IF (PRESENT(GQQC)) GQQC(I1,I2) = GQQCL - IF (PRESENT(GPQC)) GPQC(I1,I2) = GPQCL - IF (PRESENT(APPC)) APPC(I1,I2) = APPCL - IF (PRESENT(AQQC)) AQQC(I1,I2) = AQQCL - IF (PRESENT(APQC)) APQC(I1,I2) = APQCL - IF (PRESENT(GSQR)) GSQR(I1,I2) = GSQRL - IF (PRESENT(HPFC)) HPFC(I1,I2) = HPFCL - IF (PRESENT(HQFC)) HQFC(I1,I2) = HQFCL - IF (PRESENT(DXDP)) DXDP(I1,I2) = DXDPL - IF (PRESENT(DYDP)) DYDP(I1,I2) = DYDPL - IF (PRESENT(DXDQ)) DXDQ(I1,I2) = DXDQL - IF (PRESENT(DYDQ)) DYDQ(I1,I2) = DYDQL - IF (PRESENT(DPDX)) DPDX(I1,I2) = DPDXL - IF (PRESENT(DPDY)) DPDY(I1,I2) = DPDYL - IF (PRESENT(DQDX)) DQDX(I1,I2) = DQDXL - IF (PRESENT(DQDY)) DQDY(I1,I2) = DQDYL - IF (PRESENT(COSA)) COSA(I1,I2) = COSAL - IF (PRESENT(COSC)) COSC(I1,I2) = COSCL - IF (PRESENT(SINC)) SINC(I1,I2) = SINCL - IF (PRESENT(ANGL)) ANGL(I1,I2) = ANGLL - END DO !I1 - END DO !I2 -! -! -------------------------------------------------------------------- / -! 4. Clean up -! - DEALLOCATE ( K, C, K2, C2 ) - - END SUBROUTINE W3CGDM_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3CGDM_R8( IJG, LLG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, X, Y, & - MASK, NFD, SPHERE, RADIUS, DX, DY, & - GPPC, GQQC, GPQC, GSQR, & - HPFC, HQFC, APPC, AQQC, APQC, & - DXDP, DYDP, DXDQ, DYDQ, & - DPDX, DPDY, DQDX, DQDY, & - COSA, COSC, SINC, ANGL, RC ) -! Double precision interface - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LBI(2), UBI(2) - INTEGER, INTENT(IN) :: LBO(2), UBO(2) - REAL(8), INTENT(IN) :: X(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: Y(LBI(1):UBI(1),LBI(2):UBI(2)) - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) - INTEGER, INTENT(IN), OPTIONAL :: NFD - LOGICAL, INTENT(IN), OPTIONAL :: SPHERE - REAL(8), INTENT(IN), OPTIONAL :: RADIUS - REAL(8), INTENT(IN), OPTIONAL :: DX, DY - REAL(8), INTENT(OUT), OPTIONAL :: GPPC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: GQQC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: GPQC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: GSQR(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: HPFC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: HQFC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: APPC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: AQQC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: APQC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DXDP(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DYDP(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DXDQ(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DYDQ(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DPDX(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DPDY(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DQDX(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DQDY(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: COSA(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: COSC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: SINC(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT), OPTIONAL :: ANGL(LBO(1):UBO(1),LBO(2):UBO(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - REAL(8), PARAMETER :: SMALL = 1D-15 - INTEGER :: ISTAT=0, N, NP, NQ, I1, I2, P, Q - LOGICAL :: SPHR - REAL(8) :: R, FACX, FACY - INTEGER, ALLOCATABLE :: K(:,:,:), K2(:,:,:) - REAL(8), ALLOCATABLE :: C(:,:,:), C2(:,:,:) - REAL(8) :: GPPCL, GQQCL, GPQCL - REAL(8) :: GSQRL, HPFCL, HQFCL - REAL(8) :: APPCL, AQQCL, APQCL - REAL(8) :: DXDPL, DYDPL, DXDQL, DYDQL - REAL(8) :: DPDXL, DPDYL, DQDXL, DQDYL - REAL(8) :: COSAL, SINAL, COSTP, SINTP, COSCL, SINCL, ANGLL + ! Local parameters #ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3CGDM_R8') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3INAN_R8') #endif -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - IF ( PRESENT(NFD) ) THEN - N = NFD - ELSE - N = NFD_DEFAULT - END IF - IF ( N.LE.0 .OR. MOD(N,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & - 'NFD must be even and greater than zero' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN + !-----return true if X is NaN or +Inf or -Inf + INAN = .NOT. ( X .GE. -HUGE(X) .AND. X .LE. HUGE(X) ) + + END FUNCTION W3INAN_R8 + !/ + !/ End of W3INAN ===================================================== / + !/ + + + + + + + + + !/ + !/ Internal Support Routines ========================================= / + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ + FUNCTION GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4, YG4, XG8, YG8, & + BBOX_ONLY, NCB, NNP, DEBUG ) RESULT(GSU) + ! *** INTERNAL SUBROUTINE *** + TYPE(T_GSU) :: GSU + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + INTEGER, INTENT(IN) :: LB(2) + INTEGER, INTENT(IN) :: UB(2) + REAL(4), TARGET, OPTIONAL :: XG4(LB(1):UB(1),LB(2):UB(2)) + REAL(4), TARGET, OPTIONAL :: YG4(LB(1):UB(1),LB(2):UB(2)) + REAL(8), TARGET, OPTIONAL :: XG8(LB(1):UB(1),LB(2):UB(2)) + REAL(8), TARGET, OPTIONAL :: YG8(LB(1):UB(1),LB(2):UB(2)) + LOGICAL, INTENT(IN), OPTIONAL :: BBOX_ONLY + INTEGER, INTENT(IN), OPTIONAL :: NCB + INTEGER, INTENT(IN), OPTIONAL :: NNP + LOGICAL, INTENT(IN), OPTIONAL :: DEBUG + + ! Local parameters + TYPE(CLASS_GSU), POINTER :: PTR + LOGICAL :: TYPE_R4, TYPE_R8 + LOGICAL :: LDBG, LBBOX, LBC, LPL, LNPL, LSPL + INTEGER :: LBX, LBY, UBX, UBY, NX, NY + INTEGER :: LXC, LYC, UXC, UYC + INTEGER :: I, J, K, L, N, IC(4), JC(4), IB, JB + INTEGER :: NS, IB1(2), IB2(2), JB1(2), JB2(2), IBC(4), JBC(4) + INTEGER :: ISTEP, ISTAT + REAL(8) :: XC(4), YC(4) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUC') +#endif + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + TYPE_R4 = PRESENT(XG4).AND.PRESENT(YG4) + TYPE_R8 = PRESENT(XG8).AND.PRESENT(YG8) + IF ( .NOT.TYPE_R4.AND..NOT.TYPE_R8 ) THEN + WRITE(0,'(/1A,1A,1I2/)') 'W3GSUC ERROR -- ', & + 'no input grid coordinates specified' + CALL EXTCDE (1) + END IF + + IF (IJG) THEN + LBX = LB(1) + LBY = LB(2) + UBX = UB(1) + UBY = UB(2) + ELSE + LBX = LB(2) + LBY = LB(1) + UBX = UB(2) + UBY = UB(1) + END IF + NX = UBX - LBX + 1 + NY = UBY - LBY + 1 + + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) + CONTINUE + CASE DEFAULT + WRITE(0,'(/1A,1A,1I2/)') 'W3GSUC ERROR -- ', & + 'unsupported ICLO: ',ICLO + CALL EXTCDE (1) + END SELECT + + IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NX,2).NE.0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', & + 'tripole grid closure requires NX=UBX-LBX+1 be even' + CALL EXTCDE (1) + END IF + + IF ( PRESENT(BBOX_ONLY) ) THEN + LBBOX = BBOX_ONLY + ELSE + LBBOX = .FALSE. + END IF + + IF ( PRESENT(NCB) ) THEN + IF ( NCB .LE. 0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', & + 'NCB must be greater than zero' + CALL EXTCDE (1) + END IF + END IF + ! + IF ( PRESENT(DEBUG) ) THEN + LDBG = DEBUG + ELSE + LDBG = .FALSE. + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate object and set grid related data and pointers + ! + ALLOCATE(PTR, STAT=ISTAT) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', & + 'gsu object allocation failed' + CALL EXTCDE (ISTAT) + END IF + PTR%IJG = IJG + PTR%LLG = LLG + PTR%ICLO = ICLO + PTR%LBX = LBX + PTR%LBY = LBY + PTR%UBX = UBX + PTR%UBY = UBY + PTR%NX = NX + PTR%NY = NY + IF (TYPE_R4) THEN + PTR%XG4 => XG4 + PTR%YG4 => YG4 + PTR%GKIND = 4 + ELSE + PTR%XG8 => XG8 + PTR%YG8 => YG8 + PTR%GKIND = 8 + END IF + NULLIFY( PTR%NNP ) + NULLIFY( PTR%B ) + NULLIFY( PTR%NNB ) + ! + ! -------------------------------------------------------------------- / + ! 3. Create nearest-neighbor point search object + ! + IF ( .NOT.LBBOX ) THEN + IF ( PRESENT(NNP) ) THEN + PTR%NNP => W3NNSC(NNP) + ELSE + PTR%NNP => W3NNSC(NNP_DEFAULT) + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 4. Construct bucket search "object" + ! + !-----number of cells + LXC = LBX; LYC = LBY; + SELECT CASE ( ICLO ) + CASE ( ICLO_NONE ) + UXC = UBX-1; UYC = UBY-1; + CASE ( ICLO_GRDI ) + UXC = UBX; UYC = UBY-1; + CASE ( ICLO_GRDJ ) + UXC = UBX-1; UYC = UBY; + CASE ( ICLO_TRDL ) + UXC = UBX; UYC = UBY; + CASE ( ICLO_TRPL ) + UXC = UBX; UYC = UBY; + END SELECT + ! + !-----initialize longitudinal periodicity flag (LCLO) + IF ( LLG .AND. ICLO.NE.ICLO_NONE ) THEN + PTR%LCLO = .TRUE. + ELSE + PTR%LCLO = .FALSE. + END IF + ! + !-----check existence of longitudinal branch cut + !-----check if source grid includes poles + IF ( LDBG ) THEN + WRITE(*,'(/A)') 'W3GSUC - check source grid' + END IF + LNPL = .FALSE. + LSPL = .FALSE. + DO I=LXC,UXC + DO J=LYC,UYC + !-------------create list of cell vertices + IC(1) = I ; JC(1) = J ; + IC(2) = I+1; JC(2) = J ; + IC(3) = I+1; JC(3) = J+1; + IC(4) = I ; JC(4) = J+1; + DO L=1,4 + !-----------------apply index closure + IF ( MOD(ICLO,2).EQ.0 ) & + IC(L) = LBX + MOD(NX - 1 + MOD(IC(L) - LBX + 1, NX), NX) + IF ( MOD(ICLO,3).EQ.0 ) & + JC(L) = LBY + MOD(NY - 1 + MOD(JC(L) - LBY + 1, NY), NY) + IF ( ICLO.EQ.ICLO_TRPL .AND. JC(L).GT.UBY ) THEN + IC(L) = UBX + LBX - IC(L) + JC(L) = 2*UBY - JC(L) + 1 + END IF + !-----------------copy cell vertex coordinates into local variables + IF ( IJG ) THEN + IF (TYPE_R4) THEN + XC(L) = XG4(IC(L),JC(L)) + YC(L) = YG4(IC(L),JC(L)) ELSE - CALL EXTCDE (ISTAT) + XC(L) = XG8(IC(L),JC(L)) + YC(L) = YG8(IC(L),JC(L)) END IF - END IF - - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 - - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) - CONTINUE - CASE DEFAULT - WRITE(0,'(/1A,1A,1I2/)') 'W3CGDM ERROR -- ', & - 'unsupported ICLO: ',ICLO - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END SELECT - - IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & - 'tripole grid closure requires NP even' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN + ELSE + IF (TYPE_R4) THEN + XC(L) = XG4(JC(L),IC(L)) + YC(L) = YG4(JC(L),IC(L)) ELSE - CALL EXTCDE (ISTAT) + XC(L) = XG8(JC(L),IC(L)) + YC(L) = YG8(JC(L),IC(L)) END IF - END IF - - IF ( PRESENT(SPHERE) ) THEN - SPHR = SPHERE - ELSE - SPHR = .TRUE. - END IF - - IF ( PRESENT(RADIUS) ) THEN - R = RADIUS - ELSE - R = REARTH - END IF - FACY = R*D2R - - IF ( PRESENT(DX) ) THEN - IF ( DX.LE.ZERO ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DX must be > 0' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF + END IF + END DO !L + !-------------check if cell includes a pole or branch cut + LPL = .FALSE. + LBC = .FALSE. + IF ( LLG ) THEN + !-----------------count longitudinal branch cut crossings + N = 0 + DO L=1,4 + K = MOD(L,4)+1 + IF ( ABS(XC(K)-XC(L)) .GT. D180 ) N = N + 1 + END DO + !-----------------multiple longitudinal branch cut crossing => cell includes branch cut + LBC = N.GT.1 + IF ( LBC .AND. LDBG ) & + WRITE(*,'(A,8I6)') & + 'W3GSUC -- cell includes branch cut:',IC(:),JC(:) + !-----------------single longitudinal branch cut crossing + ! or single vertex at 90 degrees => cell includes pole + LPL = N.EQ.1 .OR. COUNT(ABS(YC).EQ.D90).EQ.1 + IF ( LPL.AND.MINVAL(YC).GT.ZERO ) THEN + IF ( LDBG ) & + WRITE(*,'(A,8I6)') & + 'W3GSUC -- cell includes N-pole:',IC(:),JC(:) + LNPL = .TRUE. + END IF + IF ( LPL.AND.MAXVAL(YC).LT.ZERO ) THEN + IF ( LDBG ) & + WRITE(*,'(A,8I6)') & + 'W3GSUC -- cell includes S-pole:',IC(:),JC(:) + LSPL = .TRUE. + END IF + !-----------------longitudinal branch cut crossing => longitudinal closure + IF ( N.GT.0 ) PTR%LCLO = .TRUE. + END IF !LLG + END DO !J + END DO !I + ! + !-----compute domain for search buckets + ! if longitudinal periodicity, then force domain in x to [0:360] + ! if grid includes north pole, then set ymax = 90 degrees + ! if grid includes south pole, then set ymin = -90 degrees + IF (TYPE_R4) THEN + PTR%XMIN = MINVAL(XG4); PTR%XMAX = MAXVAL(XG4); + PTR%YMIN = MINVAL(YG4); PTR%YMAX = MAXVAL(YG4); + ELSE + PTR%XMIN = MINVAL(XG8); PTR%XMAX = MAXVAL(XG8); + PTR%YMIN = MINVAL(YG8); PTR%YMAX = MAXVAL(YG8); + END IF + IF ( PTR%LCLO ) THEN + PTR%XMIN = ZERO; PTR%XMAX = D360; + END IF + IF ( LSPL ) PTR%YMIN = -D90 + IF ( LNPL ) PTR%YMAX = D90 + PTR%L360 = PTR%XMIN.GE.ZERO + ! + !-----if bbox only, then set pointer and return + IF ( LBBOX ) THEN + GSU%PTR => PTR + RETURN + END IF + ! + !-----compute number of search buckets and bucket size + IF ( PRESENT(NCB) ) THEN + PTR%NBX = MAX(1,NX/NCB) + PTR%NBY = MAX(1,NY/NCB) + ELSE + PTR%NBX = MAX(1,NX/NCB_DEFAULT) + PTR%NBY = MAX(1,NY/NCB_DEFAULT) + END IF + PTR%DXB = (PTR%XMAX-PTR%XMIN)/REAL(PTR%NBX) + PTR%DYB = (PTR%YMAX-PTR%YMIN)/REAL(PTR%NBY) + ! + !-----print debug info + IF ( LDBG ) THEN + WRITE(*,'(/A,1I2,1L2,1I2)') 'W3GSUC - ICLO,LCLO,GKIND: ', & + PTR%ICLO,PTR%LCLO,PTR%GKIND + WRITE(*,'(A,4E24.16)') 'W3GSUC - grid search domain:', & + PTR%XMIN,PTR%YMIN,PTR%XMAX,PTR%YMAX + WRITE(*,'(A,2I6)') 'W3GSUC - number of search buckets:', & + PTR%NBX,PTR%NBY + WRITE(*,'(A,2E24.16)') 'W3GSUC - search bucket size:', & + PTR%DXB,PTR%DYB + END IF + ! + !-----allocate array of search buckets + ALLOCATE(PTR%B(PTR%NBY,PTR%NBX),STAT=ISTAT) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', & + 'search bucket array allocation failed' + CALL EXTCDE (ISTAT) + END IF + ! + !-----BEGIN ISTEP_LOOP + ! first step: compute number of cells in each bucket + ! second step: allocate buckets and assign cells to buckets + ISTEP_LOOP: DO ISTEP=1,2 + ! + !-----allocate search bucket cell lists + IF ( ISTEP .EQ. 2 ) THEN + DO IB=1,PTR%NBX + DO JB=1,PTR%NBY + NULLIFY(PTR%B(JB,IB)%I) + NULLIFY(PTR%B(JB,IB)%J) + IF ( PTR%B(JB,IB)%N .GT. 0 ) THEN + ALLOCATE(PTR%B(JB,IB)%I(PTR%B(JB,IB)%N),STAT=ISTAT) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,2A,3I6/)') 'W3GSUC ERROR -- ', & + 'search bucket cell-i list allocation failed -- ', & + 'bucket: ',IB,JB,N + CALL EXTCDE (ISTAT) + END IF + ALLOCATE(PTR%B(JB,IB)%J(PTR%B(JB,IB)%N),STAT=ISTAT) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,2A,3I6/)') 'W3GSUC ERROR -- ', & + 'search bucket cell-j list allocation failed -- ', & + 'bucket: ',IB,JB,N + CALL EXTCDE (ISTAT) + END IF END IF - END IF - - IF ( PRESENT(DY) ) THEN - IF ( DY.LE.ZERO ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DY must be > 0' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF + END DO + END DO + END IF !ISTEP.EQ.2 + ! + !-----build search bucket cell lists + PTR%B(:,:)%N = 0 + DO I=LXC,UXC + DO J=LYC,UYC + IF ( ICLO.EQ.ICLO_TRPL ) THEN + IF ( J.EQ.UYC .AND. I.GT.LBX+NX/2 ) CYCLE + ENDIF + !-------------create list of cell vertices + IC(1) = I ; JC(1) = J ; + IC(2) = I+1; JC(2) = J ; + IC(3) = I+1; JC(3) = J+1; + IC(4) = I ; JC(4) = J+1; + DO L=1,4 + !-----------------apply index closure + IF ( MOD(ICLO,2).EQ.0 ) & + IC(L) = LBX + MOD(NX - 1 + MOD(IC(L) - LBX + 1, NX), NX) + IF ( MOD(ICLO,3).EQ.0 ) & + JC(L) = LBY + MOD(NY - 1 + MOD(JC(L) - LBY + 1, NY), NY) + IF ( ICLO.EQ.ICLO_TRPL .AND. JC(L).GT.UBY ) THEN + IC(L) = UBX + LBX - IC(L) + JC(L) = 2*UBY - JC(L) + 1 END IF - END IF -! -! -------------------------------------------------------------------- / -! 2. Setup finite difference coefficients -! - ALLOCATE ( K(0:N,0:N,1:N), C(0:N,0:N,1:N), STAT=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & - 'finite difference coeff allocation failed' - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN + !-----------------copy cell vertex coordinates into local variables + IF ( IJG ) THEN + IF (TYPE_R4) THEN + XC(L) = XG4(IC(L),JC(L)) + YC(L) = YG4(IC(L),JC(L)) + ELSE + XC(L) = XG8(IC(L),JC(L)) + YC(L) = YG8(IC(L),JC(L)) + END IF ELSE - CALL EXTCDE (ISTAT) + IF (TYPE_R4) THEN + XC(L) = XG4(JC(L),IC(L)) + YC(L) = YG4(JC(L),IC(L)) + ELSE + XC(L) = XG8(JC(L),IC(L)) + YC(L) = YG8(JC(L),IC(L)) + END IF END IF - END IF - CALL GET_FDW3 ( N, M, K, C ) - - ALLOCATE ( K2(0:2,0:2,1:2), C2(0:2,0:2,1:2), STAT=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', & - 'finite difference coeff allocation for N=2 failed' - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN + END DO !L + !-------------check if cell includes a pole or branch cut + LPL = .FALSE. + LBC = .FALSE. + IF ( LLG ) THEN + !-----------------shift longitudes to appropriate range + XC = MOD(XC,D360) + IF ( PTR%LCLO .OR. PTR%L360 ) THEN + WHERE ( XC.LT.ZERO ) XC = XC + D360 ELSE - CALL EXTCDE (ISTAT) + WHERE ( XC.GT.D180 ) XC = XC - D360 END IF - END IF - CALL GET_FDW3 ( 2, M, K2, C2 ) -! -! -------------------------------------------------------------------- / -! 3. Compute optional return quantities -! - DO I2 = LBO(2), UBO(2) - DO I1 = LBO(1), UBO(1) - IF ( IJG ) THEN - P = I1 - Q = I2 - ELSE - P = I2 - Q = I1 - END IF - IF ( PRESENT(DX) ) THEN - DXDPL = DX - DYDPL = ZERO - ELSE - CALL DXYDP( N, K, C, IJG, LLG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, DXDPL, DYDPL, & - MASK=MASK, X8=X, Y8=Y, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - END IF - IF ( PRESENT(DY) ) THEN - DXDQL = ZERO - DYDQL = DY - ELSE - CALL DXYDQ( N, K, C, IJG, LLG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, DXDQL, DYDQL, & - MASK=MASK, X8=X, Y8=Y, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - END IF - IF ( LLG .AND. SPHR ) THEN - FACX = FACY*COS(REAL(Y(I1,I2),8)*D2R) - DXDPL = DXDPL*FACX - DYDPL = DYDPL*FACY - DXDQL = DXDQL*FACX - DYDQL = DYDQL*FACY - END IF - GSQRL = DXDPL*DYDQL - DXDQL*DYDPL - IF ( GSQRL .LT. ZERO .AND. N .GT. 2 ) THEN -! WRITE(0,'(1A,1I0,1A,1I0,1A,1I0,2A)') & -! 'W3CGDM WARNING -- NFD = ',N, & -! ' yields GSQRL < 0 at (',P,',',Q,'):', & -! ' computing metrics using NFD = 2' - IF ( PRESENT(DX) ) THEN - DXDPL = DX - DYDPL = ZERO - ELSE - CALL DXYDP( 2, K2, C2, IJG, LLG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, DXDPL, DYDPL, & - MASK=MASK, X8=X, Y8=Y, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - END IF - IF ( PRESENT(DY) ) THEN - DXDQL = ZERO - DYDQL = DY - ELSE - CALL DXYDQ( 2, K2, C2, IJG, LLG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, DXDQL, DYDQL, & - MASK=MASK, X8=X, Y8=Y, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - END IF - IF ( LLG .AND. SPHR ) THEN - FACX = FACY*COS(REAL(Y(I1,I2),8)*D2R) - DXDPL = DXDPL*FACX - DYDPL = DYDPL*FACY - DXDQL = DXDQL*FACX - DYDQL = DYDQL*FACY - END IF - GSQRL = DXDPL*DYDQL - DXDQL*DYDPL - END IF - IF ( GSQRL .LT. ZERO ) THEN - ISTAT = 1 - WRITE(0,'(/1A,1A)') 'W3CGDM ERROR -- ', & - 'input coordinates do not define a '// & - 'right-handed coordinate system' - WRITE(0,'(1A,2A6,5A16)') 'W3CGDM ERROR --', & - 'P','Q','GSQRL','DXDPL','DYDQL','DXDQL','DYDPL' - WRITE(0,'(1A,2I6,5E16.8/)') 'W3CGDM ERROR --', & - P,Q,GSQRL,DXDPL,DYDQL,DXDQL,DYDPL - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF + !-----------------count longitudinal branch cut crossings + N = 0 + DO L=1,4 + K = MOD(L,4)+1 + IF ( ABS(XC(K)-XC(L)) .GT. D180 ) N = N + 1 + END DO + !-----------------multiple longitudinal branch cut crossing => cell includes branch cut + LBC = N.GT.1 + !-----------------single longitudinal branch cut crossing + ! or single vertex at 90 degrees => cell includes pole + LPL = N.EQ.1 .OR. COUNT(ABS(YC).EQ.D90).EQ.1 + END IF !LLG + !-------------set bucket id for each cell vertex + DO L=1,4 + IBC(L) = INT((XC(L)-PTR%XMIN)/PTR%DXB)+1 + IF ( .NOT.PTR%LCLO ) IBC(L) = MIN(IBC(L),PTR%NBX) + JBC(L) = MIN(INT((YC(L)-PTR%YMIN)/PTR%DYB)+1,PTR%NBY) + END DO !L + !-------------set bucket overlap bounds + IF ( LPL ) THEN + !---------------cell includes pole: overlap includes full longitudinal range + NS = 1 + IB1(1) = 1 + IB2(1) = PTR%NBX + IF ( MINVAL(YC).GT.ZERO ) THEN + JB1(1) = MAX(1,MINVAL(JBC)) + JB2(1) = PTR%NBY + END IF + IF ( MAXVAL(YC).LT.ZERO ) THEN + JB1(1) = 1 + JB2(1) = MIN(PTR%NBY,MAXVAL(JBC)) + END IF + IB1(2) = 0 + IB2(2) = 0 + JB1(2) = 0 + JB2(2) = 0 + ELSE IF ( LBC ) THEN + !---------------cell includes branch cut: split overlap into two sets + NS = 2 + IB1(1) = PTR%NBX + IB2(1) = PTR%NBX + IB1(2) = 1 + IB2(2) = 1 + DO L=1,4 + IF ( IBC(L) .GT. PTR%NBX/2 ) THEN + IB1(1) = MIN(IB1(1),IBC(L)) + ELSE + IB2(2) = MAX(IB2(2),IBC(L)) + END IF + END DO !L + JB1(:) = MAX(1,MINVAL(JBC)) + JB2(:) = MIN(PTR%NBY,MAXVAL(JBC)) + ELSE + !---------------default: overlap computed from min/max + NS = 1 + IB1(1) = MAX(1,MINVAL(IBC)) + IB2(1) = MIN(PTR%NBX,MAXVAL(IBC)) + JB1(1) = MAX(1,MINVAL(JBC)) + JB2(1) = MIN(PTR%NBY,MAXVAL(JBC)) + IB1(2) = 0 + IB2(2) = 0 + JB1(2) = 0 + JB2(2) = 0 + END IF + !-------------debug output + IF ( LDBG .AND. ISTEP.EQ.1 ) THEN + WRITE(*,'(/A,2I6)') 'W3GSUC -- BUCKET SORT:',I,J + WRITE(*,'(A,2L6,1I6)') 'W3GSUC -- LBC,LPL:',LBC,LPL + WRITE(*,'(A,4I6)') 'W3GSUC -- IC:',IC(:) + WRITE(*,'(A,4I6)') 'W3GSUC -- JC:',JC(:) + WRITE(*,'(A,4E24.16)') 'W3GSUC -- XC:',XC(:) + WRITE(*,'(A,4E24.16)') 'W3GSUC -- YC:',YC(:) + WRITE(*,'(A,4I6)') 'W3GSUC -- IBC:',IBC(:) + WRITE(*,'(A,4I6)') 'W3GSUC -- JBC:',JBC(:) + WRITE(*,'(A,1I6)') 'W3GSUC -- NS:',NS + WRITE(*,'(A,4I6)') 'W3GSUC -- IB1:',IB1(:) + WRITE(*,'(A,4I6)') 'W3GSUC -- JB1:',JB1(:) + WRITE(*,'(A,4I6)') 'W3GSUC -- IB2:',IB2(:) + WRITE(*,'(A,4I6)') 'W3GSUC -- JB2:',JB2(:) + END IF + !-------------assign cell to buckets based on overlap + DO K=1,NS + DO IB=IB1(K),IB2(K) + DO JB=JB1(K),JB2(K) + PTR%B(JB,IB)%N = PTR%B(JB,IB)%N + 1 + IF ( ISTEP .EQ. 2 ) THEN + PTR%B(JB,IB)%I(PTR%B(JB,IB)%N) = IC(1) + PTR%B(JB,IB)%J(PTR%B(JB,IB)%N) = JC(1) END IF - GPPCL = DXDPL*DXDPL + DYDPL*DYDPL - GQQCL = DXDQL*DXDQL + DYDQL*DYDQL - GPQCL = DXDPL*DXDQL + DYDPL*DYDQL - GSQRL = MAX(GSQRL,SMALL) - GPPCL = MAX(GPPCL,SMALL) - GQQCL = MAX(GQQCL,SMALL) - DPDXL = DYDQL/GSQRL - DPDYL =-DXDQL/GSQRL - DQDXL =-DYDPL/GSQRL - DQDYL = DXDPL/GSQRL - APPCL = DPDXL*DPDXL + DPDYL*DPDYL - AQQCL = DQDXL*DQDXL + DQDYL*DQDYL - APQCL = DPDXL*DQDXL + DPDYL*DQDYL - HPFCL = SQRT(GPPCL) - HQFCL = SQRT(GQQCL) - COSAL = GPQCL/(HPFCL*HQFCL) - SINAL = GSQRL**2/(GPPCL*GQQCL) - COSTP = DXDPL/HPFCL - SINTP = DYDPL/HQFCL - COSCL = SINAL*COSTP + COSAL*SINTP - SINCL = SINAL*SINTP - COSAL*COSTP - ANGLL = ATAN2(SINCL,COSCL)*R2D - IF (PRESENT(GPPC)) GPPC(I1,I2) = GPPCL - IF (PRESENT(GQQC)) GQQC(I1,I2) = GQQCL - IF (PRESENT(GPQC)) GPQC(I1,I2) = GPQCL - IF (PRESENT(APPC)) APPC(I1,I2) = APPCL - IF (PRESENT(AQQC)) AQQC(I1,I2) = AQQCL - IF (PRESENT(APQC)) APQC(I1,I2) = APQCL - IF (PRESENT(GSQR)) GSQR(I1,I2) = GSQRL - IF (PRESENT(HPFC)) HPFC(I1,I2) = HPFCL - IF (PRESENT(HQFC)) HQFC(I1,I2) = HQFCL - IF (PRESENT(DXDP)) DXDP(I1,I2) = DXDPL - IF (PRESENT(DYDP)) DYDP(I1,I2) = DYDPL - IF (PRESENT(DXDQ)) DXDQ(I1,I2) = DXDQL - IF (PRESENT(DYDQ)) DYDQ(I1,I2) = DYDQL - IF (PRESENT(DPDX)) DPDX(I1,I2) = DPDXL - IF (PRESENT(DPDY)) DPDY(I1,I2) = DPDYL - IF (PRESENT(DQDX)) DQDX(I1,I2) = DQDXL - IF (PRESENT(DQDY)) DQDY(I1,I2) = DQDYL - IF (PRESENT(COSA)) COSA(I1,I2) = COSAL - IF (PRESENT(COSC)) COSC(I1,I2) = COSCL - IF (PRESENT(SINC)) SINC(I1,I2) = SINCL - IF (PRESENT(ANGL)) ANGL(I1,I2) = ATAN2(SINCL,COSCL)*R2D - IF (PRESENT(ANGL)) ANGL(I1,I2) = ANGLL - END DO !I1 - END DO !I2 -! -! -------------------------------------------------------------------- / -! 4. Clean up -! - DEALLOCATE ( K, C, K2, C2 ) - - END SUBROUTINE W3CGDM_R8 -!/ -!/ End of W3CGDM ===================================================== / -!/ - - - - - + END DO !JB + END DO !IB + END DO !K + END DO !J + END DO !I + ! + !-----END ISTEP_LOOP + END DO ISTEP_LOOP + ! + !-----create nearest-neighbor bucket search object + PTR%NNB => W3NNSC(NINT(HALF*MAX(PTR%NBX,PTR%NBY))) + ! + !-----print debug info + IF ( LDBG ) THEN + WRITE(*,'(/A,3I6,4E24.16)') 'W3GSUC - search bucket list:' + WRITE(*,'(3A6,4A14)') 'I','J','N','X1','Y1','X2','Y2' + DO IB=1,PTR%NBX + DO JB=1,PTR%NBY + WRITE(*,'(3I6,4E24.16)') IB,JB,PTR%B(JB,IB)%N, & + PTR%XMIN+(IB-1)*PTR%DXB,PTR%YMIN+(JB-1)*PTR%DYB, & + PTR%XMIN+(IB-0)*PTR%DXB,PTR%YMIN+(JB-0)*PTR%DYB + END DO + END DO + END IF + ! + ! -------------------------------------------------------------------- / + ! 5. Set return parameter + ! + GSU%PTR => PTR + + END FUNCTION GSU_CREATE + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE GETPQR( XT, YT, XS, YS, PR, QR, EPS, DEBUG ) + ! *** INTERNAL SUBROUTINE *** + ! Compute source grid cell-relative coordinates (PR,QR) for target point (XT,YT) + REAL(8), INTENT(IN) :: XT + REAL(8), INTENT(IN) :: YT + REAL(8), INTENT(IN) :: XS(4) + REAL(8), INTENT(IN) :: YS(4) + REAL(8), INTENT(OUT) :: PR + REAL(8), INTENT(OUT) :: QR + REAL(8), INTENT(IN), OPTIONAL :: EPS + LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG + + ! Local parameters + INTEGER, PARAMETER :: MAX_ITER = 10 + REAL(8), PARAMETER :: CONVERGE = 1D-6 + REAL(8) :: LEPS + LOGICAL :: LDBG + INTEGER :: K, ITER + REAL(8) :: DXT, DX1, DX2, DX3, DXP, DYT, DY1, DY2, DY3, DYP + REAL(8) :: MAT1, MAT2, MAT3, MAT4, DELP, DELQ, DET +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'GETPQR') +#endif - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3GRD0( NFD, IJG, ICLO, PTILED, QTILED, & -!/ PRANGE, QRANGE, LBI, UBI, LBO, UBO, & -!/ DPDX, DPDY, DQDX, DQDY, & -!/ F, DFDX, DFDY, MASK, RC ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute gradient of a scalar field F(x,y) defined on a -! curvilinear coordinate grid (x(p,q),y(p,q)). -! -! 2. Method : -! -! Compute derivatives using finite-difference method. -! Apply curvilinear grid metric. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NFD Int. I Finite-difference order (even) -! IJG Log. I Logical flag indicating ordering of input -! coord. arrays: T = (NP,NQ) and F = (NP,NQ) -! ICLO Int. I Parameter indicating type of index space closure. -! PTILED Log. I Logical flag indicating that input arrays are tiled -! in P-axis with halos of width >= NFD/2 -! QTILED Log. I Logical flag indicating that input arrays are tiled -! in Q-axis with halos of width >= NFD/2 -! PRANGE I.A. I Range of P index coordinate: P in [PRANGE(1),PRANGE(2)] -! QRANGE I.A. I Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)] -! LBI I.A. I Lower-bound of input arrays, DIMENSION(2) -! UBI I.A. I Upper-bound of input arrays, DIMENSION(2) -! LBO I.A. I Lower-bound of output arrays, DIMENSION(2) -! UBO I.A. I Upper-bound of output arrays, DIMENSION(2) -! DPDX R.A. I dp/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DPDY R.A. I dp/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DQDX R.A. I dq/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DQDY R.A. I dq/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! F R.A. I Scalar input field, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DFDX R.A. O df/dx, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! DFDY R.A. O df/dy, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! MASK L.A. I OPTIONAL logical mask (T = invalid, F = valid) -! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! RC Int. O OPTIONAL return code (!= 0 if error occurs) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! - If RC is not provided and an error occurs, then the routine will -! report error to stderr and attempt to abort the calling program. -! - When MASK is specified, points that are masked are excluded from -! the finite-difference stencil. In order to avoid reaching across -! masked regions, the stencil is modified to one-sided and/or the -! finite-difference order is reduced. If the masking results in a -! single point wide channel, then the derivative in the direction -! across the channel is set to zero. -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3GRD0_R4( NFD, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, & - DPDX, DPDY, DQDX, DQDY, & - F, DFDX, DFDY, MASK, RC ) -! Single precision interface - INTEGER, INTENT(IN) :: NFD - LOGICAL, INTENT(IN) :: IJG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LBI(2), UBI(2) - INTEGER, INTENT(IN) :: LBO(2), UBO(2) - REAL(4), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: F(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(OUT) :: DFDX(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT) :: DFDY(LBO(1):UBO(1),LBO(2):UBO(2)) - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - INTEGER :: NP, NQ, I1, I2, P, Q - INTEGER :: ISTAT=0 - INTEGER :: K(0:NFD,0:NFD,1:NFD) - REAL(8) :: C(0:NFD,0:NFD,1:NFD) - REAL(8) :: DFDP, DFDQ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GRD0_R4') -#endif -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - - IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & - 'NFD must be even and greater than zero' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 - - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) - CONTINUE - CASE DEFAULT - WRITE(0,'(/1A,1A,1I2/)') 'W3GRD0 ERROR -- ', & - 'unsupported ICLO: ',ICLO - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END SELECT - - IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & - 'tripole grid closure requires NP even' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF -! -! -------------------------------------------------------------------- / -! 2. Setup finite difference coefficients -! - CALL GET_FDW3 ( NFD, M, K, C ) -! -! -------------------------------------------------------------------- / -! 3. Compute dF/dx & dF/dy -! - DO I2 = LBO(2), UBO(2) - DO I1 = LBO(1), UBO(1) - IF ( PRESENT(MASK) ) THEN - IF ( MASK(I1,I2) ) CYCLE - END IF - IF ( IJG ) THEN - P = I1 - Q = I2 - ELSE - P = I2 - Q = I1 - END IF - CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, & - F4=F, DFDP=DFDP, DFDQ=DFDQ, & - MASK=MASK, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - DFDX(I1,I2) = DFDP*DPDX(I1,I2) + DFDQ*DQDX(I1,I2) - DFDY(I1,I2) = DFDP*DPDY(I1,I2) + DFDQ*DQDY(I1,I2) - END DO !I1 - END DO !I2 - - END SUBROUTINE W3GRD0_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3GRD0_R8( NFD, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, & - DPDX, DPDY, DQDX, DQDY, & - F, DFDX, DFDY, MASK, RC ) -! Double precision interface - INTEGER, INTENT(IN) :: NFD - LOGICAL, INTENT(IN) :: IJG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LBI(2), UBI(2) - INTEGER, INTENT(IN) :: LBO(2), UBO(2) - REAL(8), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: F(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(OUT) :: DFDX(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT) :: DFDY(LBO(1):UBO(1),LBO(2):UBO(2)) - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - INTEGER :: NP, NQ, I1, I2, P, Q - INTEGER :: ISTAT=0 - INTEGER :: K(0:NFD,0:NFD,1:NFD) - REAL(8) :: C(0:NFD,0:NFD,1:NFD) - REAL(8) :: DFDP, DFDQ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GRD0_R8') -#endif -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - - IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & - 'NFD must be even and greater than zero' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 - - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) - CONTINUE - CASE DEFAULT - WRITE(0,'(/1A,1A,1I2/)') 'W3GRD0 ERROR -- ', & - 'unsupported ICLO: ',ICLO - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END SELECT - - IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & - 'tripole grid closure requires NP even' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF -! -! -------------------------------------------------------------------- / -! 2. Setup finite difference coefficients -! - CALL GET_FDW3 ( NFD, M, K, C ) -! -! -------------------------------------------------------------------- / -! 3. Compute dF/dx & dF/dy -! - DO I2 = LBO(2), UBO(2) - DO I1 = LBO(1), UBO(1) - IF ( PRESENT(MASK) ) THEN - IF ( MASK(I1,I2) ) CYCLE - END IF - IF ( IJG ) THEN - P = I1 - Q = I2 - ELSE - P = I2 - Q = I1 - END IF - CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, & - F8=F, DFDP=DFDP, DFDQ=DFDQ, & - MASK=MASK, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - DFDX(I1,I2) = DFDP*DPDX(I1,I2) + DFDQ*DQDX(I1,I2) - DFDY(I1,I2) = DFDP*DPDY(I1,I2) + DFDQ*DQDY(I1,I2) - END DO !I1 - END DO !I2 - - END SUBROUTINE W3GRD0_R8 -!/ -!/ End of W3GRD0 ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3DIV1( NFD, IJG, ICLO, PTILED, QTILED, & -!/ PRANGE, QRANGE, LBI, UBI, LBO, UBO, & -!/ DPDX, DPDY, DQDX, DQDY, & -!/ VX, VY, DIVV, MASK, RC ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute divergence of a vector field (V_x,V_y) defined -! on a curvilinear coordinate grid (x(p,q),y(p,q)). -! -! 2. Method : -! -! Compute derivatives using finite-difference method. -! Apply curvilinear grid metric. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NFD Int. I Finite-difference order (even) -! IJG Log. I Logical flag indicating ordering of input -! coord. arrays: T = (NP,NQ) and F = (NP,NQ) -! ICLO Int. I Parameter indicating type of index space closure. -! PTILED Log. I Logical flag indicating that input arrays are tiled -! in P-axis with halos of width >= NFD/2 -! QTILED Log. I Logical flag indicating that input arrays are tiled -! in Q-axis with halos of width >= NFD/2 -! PRANGE I.A. I Range of P index coordinate: P in [PRANGE(1),PRANGE(2)] -! QRANGE I.A. I Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)] -! LBI I.A. I Lower-bound of input arrays, DIMENSION(2) -! UBI I.A. I Upper-bound of input arrays, DIMENSION(2) -! LBO I.A. I Lower-bound of output arrays, DIMENSION(2) -! UBO I.A. I Upper-bound of output arrays, DIMENSION(2) -! DPDX R.A. I dp/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DPDY R.A. I dp/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DQDX R.A. I dq/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DQDY R.A. I dq/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! VX R.A. I x-component of input vector field, -! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! VY R.A. I y-component of input vector field, -! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DIVV R.A. O div(V), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! MASK L.A. I OPTIONAL logical mask (T = invalid, F = valid) -! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! RC Int. O OPTIONAL return code (!= 0 if error occurs) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! - If RC is not provided and an error occurs, then the routine will -! report error to stderr and attempt to abort the calling program. -! - When MASK is specified, points that are masked are excluded from -! the finite-difference stencil. In order to avoid reaching across -! masked regions, the stencil is modified to one-sided and/or the -! finite-difference order is reduced. If the masking results in a -! single point wide channel, then the derivative in the direction -! across the channel is set to zero. -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3DIV1_R4( NFD, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, & - DPDX, DPDY, DQDX, DQDY, & - VX, VY, DIVV, MASK, RC ) -! Single precision interface - INTEGER, INTENT(IN) :: NFD - LOGICAL, INTENT(IN) :: IJG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LBI(2), UBI(2) - INTEGER, INTENT(IN) :: LBO(2), UBO(2) - REAL(4), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: VX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: VY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(OUT) :: DIVV(LBO(1):UBO(1),LBO(2):UBO(2)) - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - INTEGER :: NP, NQ, I1, I2, P, Q - INTEGER :: ISTAT=0 - INTEGER :: K(0:NFD,0:NFD,1:NFD) - REAL(8) :: C(0:NFD,0:NFD,1:NFD) - REAL(8) :: DVXDP, DVXDQ, DVYDP, DVYDQ - REAL(8) :: DVXDX, DVYDY -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3DIV1_R4') -#endif -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - - IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3DIV1 ERROR -- ', & - 'NFD must be even and greater than zero' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 - - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) - CONTINUE - CASE DEFAULT - WRITE(0,'(/1A,1A,1I2/)') 'W3DIV1 ERROR -- ', & - 'unsupported ICLO: ',ICLO - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END SELECT - - IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3DIV1 ERROR -- ', & - 'tripole grid closure requires NP even' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF -! -! -------------------------------------------------------------------- / -! 2. Setup finite difference coefficients -! - CALL GET_FDW3 ( NFD, M, K, C ) -! -! -------------------------------------------------------------------- / -! 3. Compute div(V) = dV_x/dx + dV_y/dy -! - DO I2 = LBO(2), UBO(2) - DO I1 = LBO(1), UBO(1) - IF ( PRESENT(MASK) ) THEN - IF ( MASK(I1,I2) ) CYCLE - END IF - IF ( IJG ) THEN - P = I1 - Q = I2 - ELSE - P = I2 - Q = I1 - END IF - CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, & - F4=VX, DFDP=DVXDP, DFDQ=DVXDQ, & - G4=VY, DGDP=DVYDP, DGDQ=DVYDQ, & - MASK=MASK, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - DVXDX = DVXDP*DPDX(I1,I2) + DVXDQ*DQDX(I1,I2) - DVYDY = DVYDP*DPDY(I1,I2) + DVYDQ*DQDY(I1,I2) - DIVV(I1,I2) = DVXDX + DVYDY - END DO !I1 - END DO !I2 - - END SUBROUTINE W3DIV1_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3DIV1_R8( NFD, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, & - DPDX, DPDY, DQDX, DQDY, & - VX, VY, DIVV, MASK, RC ) -! Double precision interface - INTEGER, INTENT(IN) :: NFD - LOGICAL, INTENT(IN) :: IJG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LBI(2), UBI(2) - INTEGER, INTENT(IN) :: LBO(2), UBO(2) - REAL(8), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: VX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: VY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(OUT) :: DIVV(LBO(1):UBO(1),LBO(2):UBO(2)) - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - INTEGER :: NP, NQ, I1, I2, P, Q - INTEGER :: ISTAT=0 - INTEGER :: K(0:NFD,0:NFD,1:NFD) - REAL(8) :: C(0:NFD,0:NFD,1:NFD) - REAL(8) :: DVXDP, DVXDQ, DVYDP, DVYDQ - REAL(8) :: DVXDX, DVYDY -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3DIV1_R8') -#endif -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - - IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & - 'NFD must be even and greater than zero' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 - - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) - CONTINUE - CASE DEFAULT - WRITE(0,'(/1A,1A,1I2/)') 'W3GRD0 ERROR -- ', & - 'unsupported ICLO: ',ICLO - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END SELECT - - IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', & - 'tripole grid closure requires NP even' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF -! -! -------------------------------------------------------------------- / -! 2. Setup finite difference coefficients -! - CALL GET_FDW3 ( NFD, M, K, C ) -! -! -------------------------------------------------------------------- / -! 3. Compute div(V) = dV_x/dx + dV_y/dy -! - DO I2 = LBO(2), UBO(2) - DO I1 = LBO(1), UBO(1) - IF ( PRESENT(MASK) ) THEN - IF ( MASK(I1,I2) ) CYCLE - END IF - IF ( IJG ) THEN - P = I1 - Q = I2 - ELSE - P = I2 - Q = I1 - END IF - CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, & - F8=VX, DFDP=DVXDP, DFDQ=DVXDQ, & - G8=VY, DGDP=DVYDP, DGDQ=DVYDQ, & - MASK=MASK, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - DVXDX = DVXDP*DPDX(I1,I2) + DVXDQ*DQDX(I1,I2) - DVYDY = DVYDP*DPDY(I1,I2) + DVYDQ*DQDY(I1,I2) - DIVV(I1,I2) = DVXDX + DVYDY - END DO !I1 - END DO !I2 - - END SUBROUTINE W3DIV1_R8 -!/ -!/ End of W3DIV1 ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3DIV2( NFD, IJG, ICLO, PTILED, QTILED, & -!/ PRANGE, QRANGE, LBI, UBI, LBO, UBO, & -!/ DPDX, DPDY, DQDX, DQDY, & -!/ SXX, SYY, SXY, DSX, DSY, MASK, RC ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute divergence of a rank 2 symmetric tensor field (S_xx,S_yy,S_xy) -! defined on a curvilinear coordinate grid (x(p,q),y(p,q)). -! -! 2. Method : -! -! Compute derivatives using finite-difference method. -! Apply curvilinear grid metric. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NFD Int. I Finite-difference order (even) -! IJG Log. I Logical flag indicating ordering of input -! coord. arrays: T = (NP,NQ) and F = (NP,NQ) -! ICLO Int. I Parameter indicating type of index space closure. -! PTILED Log. I Logical flag indicating that input arrays are tiled -! in P-axis with halos of width >= NFD/2 -! QTILED Log. I Logical flag indicating that input arrays are tiled -! in Q-axis with halos of width >= NFD/2 -! PRANGE I.A. I Range of P index coordinate: P in [PRANGE(1),PRANGE(2)] -! QRANGE I.A. I Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)] -! LBI I.A. I Lower-bound of input arrays, DIMENSION(2) -! UBI I.A. I Upper-bound of input arrays, DIMENSION(2) -! LBO I.A. I Lower-bound of output arrays, DIMENSION(2) -! UBO I.A. I Upper-bound of output arrays, DIMENSION(2) -! DPDX R.A. I dp/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DPDY R.A. I dp/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DQDX R.A. I dq/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DQDY R.A. I dq/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! SXX R.A. I xx-component of input tensor field, -! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! SYY R.A. I yy-component of input vector field, -! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! SXY R.A. I xy-component of input vector field, -! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! DSX R.A. O div(S)_x, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! DSY R.A. O div(S)_y, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2)) -! MASK L.A. I OPTIONAL logical mask (T = invalid, F = valid) -! DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2)) -! RC Int. O OPTIONAL return code (!= 0 if error occurs) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! - If RC is not provided and an error occurs, then the routine will -! report error to stderr and attempt to abort the calling program. -! - When MASK is specified, points that are masked are excluded from -! the finite-difference stencil. In order to avoid reaching across -! masked regions, the stencil is modified to one-sided and/or the -! finite-difference order is reduced. If the masking results in a -! single point wide channel, then the derivative in the direction -! across the channel is set to zero. -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3DIV2_R4( NFD, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, & - DPDX, DPDY, DQDX, DQDY, & - SXX, SYY, SXY, DSX, DSY, MASK, RC ) -! Single precision interface - INTEGER, INTENT(IN) :: NFD - LOGICAL, INTENT(IN) :: IJG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LBI(2), UBI(2) - INTEGER, INTENT(IN) :: LBO(2), UBO(2) - REAL(4), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: SXX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: SYY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(IN) :: SXY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(4), INTENT(OUT) :: DSX(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(4), INTENT(OUT) :: DSY(LBO(1):UBO(1),LBO(2):UBO(2)) - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - INTEGER :: NP, NQ, I1, I2, P, Q - INTEGER :: ISTAT=0 - INTEGER :: K(0:NFD,0:NFD,1:NFD) - REAL(8) :: C(0:NFD,0:NFD,1:NFD) - REAL(8) :: DXXDP, DXXDQ, DYYDP, DYYDQ, DXYDP, DXYDQ - REAL(8) :: DXXDX, DYYDY, DXYDX, DXYDY -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3DIV2_R4') -#endif -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - - IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', & - 'NFD must be even and greater than zero' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 - - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) - CONTINUE - CASE DEFAULT - WRITE(0,'(/1A,1A,1I2/)') 'W3DIV2 ERROR -- ', & - 'unsupported ICLO: ',ICLO - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END SELECT - - IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', & - 'tripole grid closure requires NP even' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF -! -! -------------------------------------------------------------------- / -! 2. Setup finite difference coefficients -! - CALL GET_FDW3 ( NFD, M, K, C ) -! -! -------------------------------------------------------------------- / -! 3. Compute div(S) = (dS_xx/dx + dS_xy/dy, dS_xy/dx + dS_yy/dy) -! - DO I2 = LBO(2), UBO(2) - DO I1 = LBO(1), UBO(1) - IF ( PRESENT(MASK) ) THEN - IF ( MASK(I1,I2) ) CYCLE - END IF - IF ( IJG ) THEN - P = I1 - Q = I2 - ELSE - P = I2 - Q = I1 - END IF - CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, & - F4=SXX, DFDP=DXXDP, DFDQ=DXXDQ, & - G4=SYY, DGDP=DYYDP, DGDQ=DYYDQ, & - H4=SXY, DHDP=DXYDP, DHDQ=DXYDQ, & - MASK=MASK, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - DXXDX = DXXDP*DPDX(I1,I2) + DXXDQ*DQDX(I1,I2) - DYYDY = DYYDP*DPDY(I1,I2) + DYYDQ*DQDY(I1,I2) - DXYDX = DXYDP*DPDX(I1,I2) + DXYDQ*DQDX(I1,I2) - DXYDY = DXYDP*DPDY(I1,I2) + DXYDQ*DQDY(I1,I2) - DSX(I1,I2) = DXXDX + DXYDY - DSY(I1,I2) = DXYDX + DYYDY - END DO !I1 - END DO !I2 - - END SUBROUTINE W3DIV2_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3DIV2_R8( NFD, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, & - DPDX, DPDY, DQDX, DQDY, & - SXX, SYY, SXY, DSX, DSY, MASK, RC ) -! Double precision interface - INTEGER, INTENT(IN) :: NFD - LOGICAL, INTENT(IN) :: IJG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LBI(2), UBI(2) - INTEGER, INTENT(IN) :: LBO(2), UBO(2) - REAL(8), INTENT(IN) :: DPDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: DPDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: DQDX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: DQDY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: SXX(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: SYY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(IN) :: SXY(LBI(1):UBI(1),LBI(2):UBI(2)) - REAL(8), INTENT(OUT) :: DSX(LBO(1):UBO(1),LBO(2):UBO(2)) - REAL(8), INTENT(OUT) :: DSY(LBO(1):UBO(1),LBO(2):UBO(2)) - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LBI(1):UBI(1),LBI(2):UBI(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - INTEGER :: NP, NQ, I1, I2, P, Q - INTEGER :: ISTAT=0 - INTEGER :: K(0:NFD,0:NFD,1:NFD) - REAL(8) :: C(0:NFD,0:NFD,1:NFD) - REAL(8) :: DXXDP, DXXDQ, DYYDP, DYYDQ, DXYDP, DXYDQ - REAL(8) :: DXXDX, DYYDY, DXYDX, DXYDY -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3DIV2_R8') -#endif -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - - IF ( NFD.LE.0 .OR. MOD(NFD,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', & - 'NFD must be even and greater than zero' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 - - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) - CONTINUE - CASE DEFAULT - WRITE(0,'(/1A,1A,1I2/)') 'W3DIV2 ERROR -- ', & - 'unsupported ICLO: ',ICLO - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END SELECT - - IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NP,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', & - 'tripole grid closure requires NP even' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF -! -! -------------------------------------------------------------------- / -! 2. Setup finite difference coefficients -! - CALL GET_FDW3 ( NFD, M, K, C ) -! -! -------------------------------------------------------------------- / -! 3. Compute div(S) = (dS_xx/dx + dS_xy/dy, dS_xy/dx + dS_yy/dy) -! - DO I2 = LBO(2), UBO(2) - DO I1 = LBO(1), UBO(1) - IF ( PRESENT(MASK) ) THEN - IF ( MASK(I1,I2) ) CYCLE - END IF - IF ( IJG ) THEN - P = I1 - Q = I2 - ELSE - P = I2 - Q = I1 - END IF - CALL DFDPQ ( NFD, K, C, IJG, ICLO, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, P, Q, & - F8=SXX, DFDP=DXXDP, DFDQ=DXXDQ, & - G8=SYY, DGDP=DYYDP, DGDQ=DYYDQ, & - H8=SXY, DHDP=DXYDP, DHDQ=DXYDQ, & - MASK=MASK, RC=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - DXXDX = DXXDP*DPDX(I1,I2) + DXXDQ*DQDX(I1,I2) - DYYDY = DYYDP*DPDY(I1,I2) + DYYDQ*DQDY(I1,I2) - DXYDX = DXYDP*DPDX(I1,I2) + DXYDQ*DQDX(I1,I2) - DXYDY = DXYDP*DPDY(I1,I2) + DXYDQ*DQDY(I1,I2) - DSX(I1,I2) = DXXDX + DXYDY - DSY(I1,I2) = DXYDX + DYYDY - END DO !I1 - END DO !I2 - - END SUBROUTINE W3DIV2_R8 -!/ -!/ End of W3DIV2 ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3DIST( LLG, XT, YT, XS, YS ) RESULT(DIST) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute distance between two points. If spherical grid, then -! distance is the angle (in degrees) between the two points. -! -! 2. Method : -! -! Map Projections -- A Working Manual, John P. Snyder -! U.S. Geological Survey professional paper; 1395 -! Chapter 5. Transformation of Map Graticules -! -! 3. Parameters : -! -! Return parameter -! ---------------------------------------------------------------- -! DIST Real O Distance -! ---------------------------------------------------------------- -! -! Parameter list -! ---------------------------------------------------------------- -! LLG Log. I Logical flag indicating the coordinate system: -! T = spherical lat/lon (degrees) and F = Cartesian. -! XT Real I X-coordinate of target point. -! YT Real I Y-coordinate of target point. -! XS Real I X-coordinate of source point. -! YS Real I Y-coordinate of source point. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3DIST_R4( LLG, XT, YT, XS, YS ) RESULT(DIST) -! Single precision interface - REAL(4) :: DIST - LOGICAL, INTENT(IN) :: LLG - REAL(4), INTENT(IN) :: XT, YT - REAL(4), INTENT(IN) :: XS, YS - -! Local parameters - REAL(8) :: XT8, YT8, XS8, YS8 -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3DIST_R4') -#endif -! -!-----set inputs - XT8 = XT; YT8 = YT; - XS8 = XS; YS8 = YS; -! -!-----call double precision method - DIST = W3DIST( LLG, XT8, YT8, XS8, YS8 ) - - END FUNCTION W3DIST_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ -#define DIST_WITH_SINE -#define DIST_CHECK_NAN____disabled - FUNCTION W3DIST_R8( LLG, XT, YT, XS, YS ) RESULT(DIST) -! Double precision interface - REAL(8) :: DIST - LOGICAL, INTENT(IN) :: LLG - REAL(8), INTENT(IN) :: XT, YT - REAL(8), INTENT(IN) :: XS, YS - -! Local parameters - REAL(8) :: DX, DY, SLAM, SPHI, ARGD -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3DIST_R8') -#endif -! -!-----compute displacements - DX = XT - XS - DY = YT - YS - - IF ( LLG ) THEN !spherical coordinates -!---------check for longitudinal branch cut crossing - IF ( ABS(DX) .GT. D270 ) THEN - DX = DX - SIGN(D360,DX) - END IF -#ifdef DIST_WITH_SINE -!---------compute angular distance using sin(d/2) -! (this equation is more accurate than cos(d)) - SLAM = SIN(HALF*DX*D2R) - SPHI = SIN(HALF*DY*D2R) - ARGD = SQRT( COS(YT*D2R)*COS(YS*D2R)*SLAM*SLAM + SPHI*SPHI ) - DIST = R2D*TWO*ASIN( ARGD ) -#else -!---------compute angular distance using cos(c) (min required -! for rare situation of acos(1+small) generating NaN) - ARGD = MIN( ONE, COS(YT*D2R)*COS(YS*D2R)*COS(DX*D2R) & - + SIN(YT*D2R)*SIN(YS*D2R) ) - DIST = R2D*ACOS( ARGD ) -#endif - ELSE !cartesian coordinates -!---------compute cartesian distance - DIST = SQRT( DX**2 + DY**2 ) - END IF !cartesian coordinates -#ifdef DIST_CHECK_NAN - IF ( W3INAN(DIST) ) THEN - WRITE(0,'(/1A/)') 'W3DIST_R8 ERROR -- result is NaN' - CALL EXTCDE (1) - END IF -#endif - - END FUNCTION W3DIST_R8 -!/ -!/ End of W3DIST ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3SPLX( LAM0, PHI0, C0, LAM, PHI, X, Y ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute Cartesian coordinates from input longitude and latitude -! using stereographic projection with center at (LAM0,PHI0) and -! "standard circle" of angular distance C0 (in degrees) from the -! center. -! -! 2. Method : -! -! Map Projections -- A Working Manual, John P. Snyder -! U.S. Geological Survey professional paper; 1395 -! Chapter 21. Stereographic projection -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! LAM0 Real I Longitude of center of projection. -! PHI0 Real I Latitude of center of projection. -! C0 Real I Angular distance from center of projection -! where the scale factor is one. -! LAM Real I Longitude of input point. -! PHI Real I Latitude of input point. -! X Real O Cartesian x-coordinate of input point. -! Y Real O Cartesian y-coordinate of input point. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPLX_0D_R4( LAM0, PHI0, C0, LAM, PHI, X, Y ) -! Single precision point interface - REAL(4), INTENT(IN) :: LAM0, PHI0, C0 - REAL(4), INTENT(IN) :: LAM, PHI - REAL(4), INTENT(OUT):: X, Y - -! Local parameters - REAL(8) :: K, K0, CLAM, SLAM, CPHI0, CPHI, SPHI0, SPHI -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPLX_0D_R4') -#endif - - CLAM = COS((LAM-LAM0)*D2R) - SLAM = SIN((LAM-LAM0)*D2R) - CPHI0 = COS(PHI0*D2R) - CPHI = COS(PHI*D2R) - SPHI0 = SIN(PHI0*D2R) - SPHI = SIN(PHI*D2R) - K0 = COS(HALF*C0*D2R)**2 - K = TWO*K0*REARTH/(ONE+SPHI0*SPHI+CPHI0*CPHI*CLAM) - X = K*CPHI*SLAM - Y = K*(CPHI0*SPHI-SPHI0*CPHI*CLAM) - - END SUBROUTINE W3SPLX_0D_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPLX_0D_R8( LAM0, PHI0, C0, LAM, PHI, X, Y ) -! Double precision point interface - REAL(8), INTENT(IN) :: LAM0, PHI0, C0 - REAL(8), INTENT(IN) :: LAM, PHI - REAL(8), INTENT(OUT):: X, Y - -! Local parameters - REAL(8) :: K, K0, CLAM, SLAM, CPHI0, CPHI, SPHI0, SPHI -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPLX_0D_R8') -#endif - - CLAM = COS((LAM-LAM0)*D2R) - SLAM = SIN((LAM-LAM0)*D2R) - CPHI0 = COS(PHI0*D2R) - CPHI = COS(PHI*D2R) - SPHI0 = SIN(PHI0*D2R) - SPHI = SIN(PHI*D2R) - K0 = COS(HALF*C0*D2R)**2 - K = TWO*K0*REARTH/(ONE+SPHI0*SPHI+CPHI0*CPHI*CLAM) - X = K*CPHI*SLAM - Y = K*(CPHI0*SPHI-SPHI0*CPHI*CLAM) - - END SUBROUTINE W3SPLX_0D_R8 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPLX_1D_R4( LAM0, PHI0, C0, LAM, PHI, X, Y ) -! Single precision 1D array interface - REAL(4), INTENT(IN) :: LAM0, PHI0, C0 - REAL(4), INTENT(IN) :: LAM(:), PHI(:) - REAL(4), INTENT(OUT):: X(:), Y(:) - -! Local parameters - INTEGER :: I -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPLX_1D_R4') -#endif - - DO I = LBOUND(LAM,1),UBOUND(LAM,1) - CALL W3SPLX( LAM0, PHI0, C0, LAM(I), PHI(I), X(I), Y(I) ) - ENDDO - - END SUBROUTINE W3SPLX_1D_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPLX_1D_R8( LAM0, PHI0, C0, LAM, PHI, X, Y ) -! Double precision 1D array interface - REAL(8), INTENT(IN) :: LAM0, PHI0, C0 - REAL(8), INTENT(IN) :: LAM(:), PHI(:) - REAL(8), INTENT(OUT):: X(:), Y(:) - -! Local parameters - INTEGER :: I -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPLX_1D_R8') -#endif - - DO I = LBOUND(LAM,1),UBOUND(LAM,1) - CALL W3SPLX( LAM0, PHI0, C0, LAM(I), PHI(I), X(I), Y(I) ) - ENDDO - - END SUBROUTINE W3SPLX_1D_R8 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPLX_2D_R4( LAM0, PHI0, C0, LAM, PHI, X, Y ) -! Single precision 2D array interface - REAL(4), INTENT(IN) :: LAM0, PHI0, C0 - REAL(4), INTENT(IN) :: LAM(:,:), PHI(:,:) - REAL(4), INTENT(OUT):: X(:,:), Y(:,:) - -! Local parameters - INTEGER :: I, J -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPLX_2D_R4') -#endif - - DO J = LBOUND(LAM,2),UBOUND(LAM,2) - DO I = LBOUND(LAM,1),UBOUND(LAM,1) - CALL W3SPLX( LAM0, PHI0, C0, LAM(I,J), PHI(I,J), X(I,J), Y(I,J) ) - ENDDO - ENDDO - - END SUBROUTINE W3SPLX_2D_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPLX_2D_R8( LAM0, PHI0, C0, LAM, PHI, X, Y ) -! Double precision 2D array interface - REAL(8), INTENT(IN) :: LAM0, PHI0, C0 - REAL(8), INTENT(IN) :: LAM(:,:), PHI(:,:) - REAL(8), INTENT(OUT):: X(:,:), Y(:,:) - -! Local parameters - INTEGER :: I, J -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPLX_2D_R8') -#endif - - DO J = LBOUND(LAM,2),UBOUND(LAM,2) - DO I = LBOUND(LAM,1),UBOUND(LAM,1) - CALL W3SPLX( LAM0, PHI0, C0, LAM(I,J), PHI(I,J), X(I,J), Y(I,J) ) - ENDDO - ENDDO - - END SUBROUTINE W3SPLX_2D_R8 -!/ -!/ End of W3SPLX ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3SPXL( LAM0, PHI0, X, Y, LAM, PHI ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute longitude and latitude coordinates from input Cartesian -! coordinates using stereographic projection with center at (LAM0,PHI0) -! and "standard circle" of angular distance C0 (in degrees) from the -! center. -! -! 2. Method : -! -! Map Projections -- A Working Manual, John P. Snyder -! U.S. Geological Survey professional paper; 1395 -! Chapter 21. Stereographic projection -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! LAM0 Real I Longitude of center of projection. -! PHI0 Real I Latitude of center of projection. -! C0 Real I Angular distance from center of projection -! where the scale factor is one. -! X Real I Cartesian x-coordinate of input point. -! Y Real I Cartesian y-coordinate of input point. -! LAM Real O Longitude of input point. -! PHI Real O Latitude of input point. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPXL_0D_R4( LAM0, PHI0, C0, X, Y, LAM, PHI ) -! Single precision point interface - REAL(4), INTENT(IN) :: LAM0, PHI0, C0 - REAL(4), INTENT(IN) :: X, Y - REAL(4), INTENT(OUT):: LAM, PHI - -! Local parameters - REAL(8) :: K0, RHO, C, COSC, SINC, CPHI0, SPHI0 -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPXL_0D_R4') -#endif - - K0 = COS(HALF*C0*D2R)**2 - RHO = SQRT(X*X+Y*Y) - C = TWO*ATAN2(RHO,TWO*REARTH*K0) - COSC = COS(C) - SINC = SIN(C) - CPHI0 = COS(PHI0*D2R) - SPHI0 = SIN(PHI0*D2R) - PHI = ASIN(COSC*SPHI0+Y*SINC*CPHI0/RHO)*R2D - LAM = LAM0 + ATAN2(X*SINC,RHO*CPHI0*COSC-Y*SPHI0*SINC)*R2D - - END SUBROUTINE W3SPXL_0D_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPXL_0D_R8( LAM0, PHI0, C0, X, Y, LAM, PHI ) -! Double precision point interface - REAL(8), INTENT(IN) :: LAM0, PHI0, C0 - REAL(8), INTENT(IN) :: X, Y - REAL(8), INTENT(OUT):: LAM, PHI - -! Local parameters - REAL(8) :: K0, RHO, C, COSC, SINC, CPHI0, SPHI0 -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPXL_0D_R8') -#endif - - K0 = COS(HALF*C0*D2R)**2 - RHO = SQRT(X*X+Y*Y) - C = TWO*ATAN2(RHO,TWO*REARTH*K0) - COSC = COS(C) - SINC = SIN(C) - CPHI0 = COS(PHI0*D2R) - SPHI0 = SIN(PHI0*D2R) - PHI = ASIN(COSC*SPHI0+Y*SINC*CPHI0/RHO)*R2D - LAM = LAM0 + ATAN2(X*SINC,RHO*CPHI0*COSC-Y*SPHI0*SINC)*R2D - - END SUBROUTINE W3SPXL_0D_R8 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPXL_1D_R4( LAM0, PHI0, C0, X, Y, LAM, PHI ) -! Single precision 1D array interface - REAL(4), INTENT(IN) :: LAM0, PHI0, C0 - REAL(4), INTENT(IN) :: X(:), Y(:) - REAL(4), INTENT(OUT):: LAM(:), PHI(:) - -! Local parameters - INTEGER :: I -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPXL_1D_R4') -#endif - - DO I = LBOUND(X,1),UBOUND(X,1) - CALL W3SPXL( LAM0, PHI0, C0, X(I), Y(I), LAM(I), PHI(I) ) - ENDDO - - END SUBROUTINE W3SPXL_1D_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPXL_1D_R8( LAM0, PHI0, C0, X, Y, LAM, PHI ) -! Double precision 1D array interface - REAL(8), INTENT(IN) :: LAM0, PHI0, C0 - REAL(8), INTENT(IN) :: X(:), Y(:) - REAL(8), INTENT(OUT):: LAM(:), PHI(:) - -! Local parameters - INTEGER :: I -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPXL_1D_R8') -#endif - - DO I = LBOUND(X,1),UBOUND(X,1) - CALL W3SPXL( LAM0, PHI0, C0, X(I), Y(I), LAM(I), PHI(I) ) - ENDDO - - END SUBROUTINE W3SPXL_1D_R8 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPXL_2D_R4( LAM0, PHI0, C0, X, Y, LAM, PHI ) -! Single precision 2D array interface - REAL(4), INTENT(IN) :: LAM0, PHI0, C0 - REAL(4), INTENT(IN) :: X(:,:), Y(:,:) - REAL(4), INTENT(OUT):: LAM(:,:), PHI(:,:) - -! Local parameters - INTEGER :: I, J -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPXL_2D_R4') -#endif - - DO J = LBOUND(X,2),UBOUND(X,2) - DO I = LBOUND(X,1),UBOUND(X,1) - CALL W3SPXL( LAM0, PHI0, C0, X(I,J), Y(I,J), LAM(I,J), PHI(I,J) ) - ENDDO - ENDDO - - END SUBROUTINE W3SPXL_2D_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SPXL_2D_R8( LAM0, PHI0, C0, X, Y, LAM, PHI ) -! Double precision 2D array interface - REAL(8), INTENT(IN) :: LAM0, PHI0, C0 - REAL(8), INTENT(IN) :: X(:,:), Y(:,:) - REAL(8), INTENT(OUT):: LAM(:,:), PHI(:,:) - -! Local parameters - INTEGER :: I, J -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SPXL_2D_R8') -#endif - - DO J = LBOUND(X,2),UBOUND(X,2) - DO I = LBOUND(X,1),UBOUND(X,1) - CALL W3SPXL( LAM0, PHI0, C0, X(I,J), Y(I,J), LAM(I,J), PHI(I,J) ) - ENDDO - ENDDO - - END SUBROUTINE W3SPXL_2D_R8 -!/ -!/ End of W3SPXL ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3TRLL( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute longitude and latitude for input coordinates in a -! coordinate system with the North Pole placed at a latitude -! PHI0 on a meridian LAM0 east of the central meridian. -! -! 2. Method : -! -! Map Projections -- A Working Manual, John P. Snyder -! U.S. Geological Survey professional paper; 1395 -! Chapter 5. Transformation of Map Graticules -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! LAM0 Real I Longitude of North Pole -! PHI0 Real I Latitude of North Pole -! LAM1 Real I Input Longitude -! PHI1 Real I Input Latitude -! LAM Real O Transformed Longitude -! PHI Real O Transformed Latitude -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3TRLL_0D_R4( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) -! Single precision point interface - REAL(4), INTENT(IN) :: LAM0, PHI0 - REAL(4), INTENT(IN) :: LAM1, PHI1 - REAL(4), INTENT(OUT):: LAM, PHI - -! Local parameters - REAL(8) :: CLAM, SLAM, CALP, SALP, CPHI, SPHI -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3TRLL_0D_R4') -#endif - - CLAM = COS((LAM1-LAM0)*D2R) - SLAM = SIN((LAM1-LAM0)*D2R) - CALP = COS(PHI0*D2R) - SALP = SIN(PHI0*D2R) - CPHI = COS(PHI1*D2R) - SPHI = SIN(PHI1*D2R) - LAM = LAM0 + ATAN2(CPHI*SLAM,SALP*CPHI*CLAM+CALP*SPHI)*R2D - PHI = ASIN(SALP*SPHI-CALP*CPHI*CLAM)*R2D - - END SUBROUTINE W3TRLL_0D_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3TRLL_0D_R8( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) -! Double precision point interface - REAL(8), INTENT(IN) :: LAM0, PHI0 - REAL(8), INTENT(IN) :: LAM1, PHI1 - REAL(8), INTENT(OUT):: LAM, PHI - -! Local parameters - REAL(8) :: CLAM, SLAM, CALP, SALP, CPHI, SPHI -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3TRLL_0D_R8') -#endif - - CLAM = COS((LAM1-LAM0)*D2R) - SLAM = SIN((LAM1-LAM0)*D2R) - CALP = COS(PHI0*D2R) - SALP = SIN(PHI0*D2R) - CPHI = COS(PHI1*D2R) - SPHI = SIN(PHI1*D2R) - LAM = LAM0 + ATAN2(CPHI*SLAM,SALP*CPHI*CLAM+CALP*SPHI)*R2D - PHI = ASIN(SALP*SPHI-CALP*CPHI*CLAM)*R2D - - END SUBROUTINE W3TRLL_0D_R8 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3TRLL_1D_R4( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) -! Single precision 1D array interface - REAL(4), INTENT(IN) :: LAM0, PHI0 - REAL(4), INTENT(IN) :: LAM1(:), PHI1(:) - REAL(4), INTENT(OUT):: LAM(:), PHI(:) - -! Local parameters - INTEGER :: I -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3TRLL_1D_R4') -#endif - - DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) - CALL W3TRLL( LAM0, PHI0, LAM1(I), PHI1(I), LAM(I), PHI(I) ) - ENDDO - - END SUBROUTINE W3TRLL_1D_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3TRLL_1D_R8( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) -! Double precision 1D array interface - REAL(8), INTENT(IN) :: LAM0, PHI0 - REAL(8), INTENT(IN) :: LAM1(:), PHI1(:) - REAL(8), INTENT(OUT):: LAM(:), PHI(:) - -! Local parameters - INTEGER :: I -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3TRLL_1D_R8') -#endif - - DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) - CALL W3TRLL( LAM0, PHI0, LAM1(I), PHI1(I), LAM(I), PHI(I) ) - ENDDO - - END SUBROUTINE W3TRLL_1D_R8 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3TRLL_2D_R4( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) -! Single precision 2D array interface - REAL(4), INTENT(IN) :: LAM0, PHI0 - REAL(4), INTENT(IN) :: LAM1(:,:), PHI1(:,:) - REAL(4), INTENT(OUT):: LAM(:,:), PHI(:,:) - -! Local parameters - INTEGER :: I, J -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3TRLL_2D_R4') -#endif - - DO J = LBOUND(LAM1,2),UBOUND(LAM1,2) - DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) - CALL W3TRLL( LAM0, PHI0, LAM1(I,J), PHI1(I,J), LAM(I,J), PHI(I,J) ) - ENDDO - ENDDO - - END SUBROUTINE W3TRLL_2D_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3TRLL_2D_R8( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) -! Double precision 2D array interface - REAL(8), INTENT(IN) :: LAM0, PHI0 - REAL(8), INTENT(IN) :: LAM1(:,:), PHI1(:,:) - REAL(8), INTENT(OUT):: LAM(:,:), PHI(:,:) - -! Local parameters - INTEGER :: I, J -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3TRLL_2D_R8') -#endif - - DO J = LBOUND(LAM1,2),UBOUND(LAM1,2) - DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) - CALL W3TRLL( LAM0, PHI0, LAM1(I,J), PHI1(I,J), LAM(I,J), PHI(I,J) ) - ENDDO - ENDDO - - END SUBROUTINE W3TRLL_2D_R8 -!/ -!/ End of W3TRLL ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3LLAZ( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute azimuth (Az) east of north which point (LAM2,PHI2) bears -! to point (LAM1,PHI1). -! -! 2. Method : -! -! Map Projections -- A Working Manual, John P. Snyder -! U.S. Geological Survey professional paper; 1395 -! Chapter 5. Transformation of Map Graticules -! -! 3. Parameters : -! -! Return parameter -! ---------------------------------------------------------------- -! AZ Real O Azimuth in degrees east of north -! ---------------------------------------------------------------- -! -! Parameter list -! ---------------------------------------------------------------- -! LAM1 Real I Longitude for point 1 -! PHI1 Real I Latitude for point 1 -! LAM2 Real I Longitude for point 2 -! PHI2 Real I Latitude for point 2 -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3LLAZ_R4( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ) -! Single precision interface - REAL(4) :: AZ - REAL(4), INTENT(IN):: LAM1, PHI1 - REAL(4), INTENT(IN):: LAM2, PHI2 - -! Local parameters - REAL(8) :: CLAM, SLAM, CPH1, SPH1, CPH2, SPH2 -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3LLAZ_R4') -#endif - - CLAM = COS((LAM2-LAM1)*D2R) - SLAM = SIN((LAM2-LAM1)*D2R) - CPH1 = COS(PHI1*D2R) - SPH1 = SIN(PHI1*D2R) - CPH2 = COS(PHI2*D2R) - SPH2 = SIN(PHI2*D2R) - AZ = ATAN2(CPH2*SLAM,CPH1*SPH2-SPH1*CPH2*CLAM)*R2D - - END FUNCTION W3LLAZ_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3LLAZ_R8( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ) -! Double precision interface - REAL(8) :: AZ - REAL(8), INTENT(IN):: LAM1, PHI1 - REAL(8), INTENT(IN):: LAM2, PHI2 - -! Local parameters - REAL(8) :: CLAM, SLAM, CPH1, SPH1, CPH2, SPH2 -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3LLAZ_R8') -#endif - - CLAM = COS((LAM2-LAM1)*D2R) - SLAM = SIN((LAM2-LAM1)*D2R) - CPH1 = COS(PHI1*D2R) - SPH1 = SIN(PHI1*D2R) - CPH2 = COS(PHI2*D2R) - SPH2 = SIN(PHI2*D2R) - AZ = ATAN2(CPH2*SLAM,CPH1*SPH2-SPH1*CPH2*CLAM)*R2D - - END FUNCTION W3LLAZ_R8 -!/ -!/ End of W3LLAZ ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3FDWT( N, ND, M, Z, X, C ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Compute finite-difference weights on arbitrarily spaced -! 1-D node sets. -! -! 2. Method : -! -! Fornberg, B., Calculation of weights in finite difference formulas, -! SIAM Rev. 40:685-691, 1998. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! N Int. I One less than total number of grid points; -! n must not exceed the parameter nd below. -! ND Int. I Dimension of X- and C-arrays in calling program -! X(0:ND) and C(0:ND,0:M), respectively. -! M Int. I Highest derivative for which weights are sought. -! Z Real I Location where approximations are to be accurate. -! X R.A. I Grid point locations, found in X(0:N) -! C R.A. O Weights at grid locations X(0:N) for derivatives -! of order 0:M, found in C(0:N,0:M) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3FDWT_R4 ( N, ND, M, Z, X, C ) -! Single precision interface - INTEGER, INTENT(IN) :: N, ND, M - REAL(4), INTENT(IN) :: Z - REAL(4), INTENT(IN) :: X(0:ND) - REAL(4), INTENT(OUT) :: C(0:ND,0:M) - -! Local parameters - INTEGER :: I, J, K, MN - REAL(8) :: C1, C2, C3, C4, C5 -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3FDWT_R4') -#endif - - C1 = ONE - C4 = X(0)-Z - C(:,:) = ZERO - C(0,0) = ONE - ILOOP: DO I = 1,N - MN = MIN(I,M) - C2 = ONE - C5 = C4 - C4 = X(I)-Z - JLOOP: DO J = 0,I-1 - C3 = X(I)-X(J) - C2 = C2*C3 - IF ( J.EQ.I-1 ) THEN - DO K = MN,1,-1 - C(I,K) = C1*(K*C(I-1,K-1)-C5*C(I-1,K))/C2 - END DO - C(I,0) = -C1*C5*C(I-1,0)/C2 - END IF - DO K = MN,1,-1 - C(J,K) = (C4*C(J,K)-K*C(J,K-1))/C3 - END DO - C(J,0) = C4*C(J,0)/C3 - END DO JLOOP - C1 = C2 - END DO ILOOP - - END SUBROUTINE W3FDWT_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3FDWT_R8 ( N, ND, M, Z, X, C ) -! Double precision interface - INTEGER, INTENT(IN) :: N, ND, M - REAL(8), INTENT(IN) :: Z - REAL(8), INTENT(IN) :: X(0:ND) - REAL(8), INTENT(OUT) :: C(0:ND,0:M) - -! Local parameters - INTEGER :: I, J, K, MN - REAL(8) :: C1, C2, C3, C4, C5 -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3FDWT_R4') -#endif - - C1 = ONE - C4 = X(0)-Z - C(:,:) = ZERO - C(0,0) = ONE - ILOOP: DO I = 1,N - MN = MIN(I,M) - C2 = ONE - C5 = C4 - C4 = X(I)-Z - JLOOP: DO J = 0,I-1 - C3 = X(I)-X(J) - C2 = C2*C3 - IF ( J.EQ.I-1 ) THEN - DO K = MN,1,-1 - C(I,K) = C1*(K*C(I-1,K-1)-C5*C(I-1,K))/C2 - END DO - C(I,0) = -C1*C5*C(I-1,0)/C2 - END IF - DO K = MN,1,-1 - C(J,K) = (C4*C(J,K)-K*C(J,K-1))/C3 - END DO - C(J,0) = C4*C(J,0)/C3 - END DO JLOOP - C1 = C2 - END DO ILOOP - - END SUBROUTINE W3FDWT_R8 -!/ -!/ End of W3FDWT ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3NNSC( NLVL ) RESULT(NNS) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Create nearest-neighbor (NNBR) search object. -! -! 2. Method : -! -! Notation -! ( L, N): L = NNBR level; N = NNBR sequential index -! {DI, DJ}: DI = I-index delta; DJ = J-index delta -! -! --------------------------------------------------- -! | ( 2,21) | ( 2,20) | ( 2,19) | ( 2,18) | ( 2,17) | -! | {-2,+2} | {-1,+2} | { 0,+2} | {+1,+2} | {+2,+2} | -! --------------------------------------------------- -! | ( 2,22) | ( 1, 7) | ( 1, 6) | ( 1, 5) | ( 2,16) | -! | {-2,+1} | {-1,+1} | { 0,+1} | {+1,+1} | {+2,+1} | -! --------------------------------------------------- -! | ( 2,23) | ( 1, 8) | ( 0, 0) | ( 1, 4) | ( 2,15) | -! | {-2, 0} | {-1, 0} | { 0, 0} | {+1, 0} | {+2, 0} | -! --------------------------------------------------- -! | ( 2,24) | ( 1, 1) | ( 1, 2) | ( 1, 3) | ( 2,14) | -! | {-2,-1} | {-1,-1} | { 0,-1} | {+1,-1} | {+2,-1} | -! --------------------------------------------------- -! | ( 2, 9) | ( 2,10) | ( 2,11) | ( 2,12) | ( 2,13) | -! | {-2,-2} | {-1,-2} | { 0,-2} | {+1,-2} | {+2,-2} | -! --------------------------------------------------- -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3NNSC( NLVL ) RESULT(NNS) - TYPE(T_NNS), POINTER :: NNS - INTEGER, INTENT(IN) :: NLVL - -! Local parameters - INTEGER :: I, J, L, N -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3NNSC') -#endif -! -!-----allocate object - ALLOCATE(NNS) - -!-----initialize sizes - NNS%NLVL = NLVL - NNS%NNBR = (2*NLVL+1)**2 - -!-----allocate arrays - ALLOCATE(NNS%N1(0:NNS%NLVL)) - ALLOCATE(NNS%N2(0:NNS%NLVL)) - ALLOCATE(NNS%DI(0:NNS%NNBR-1)) - ALLOCATE(NNS%DJ(0:NNS%NNBR-1)) - -!-----compute index deltas for nearest-neighbor searches - N = 0 -!-----central point - L = 0 - NNS%N1(L) = 0; NNS%N2(L) = (2*L+1)**2-1; - NNS%DI(N) = 0; NNS%DJ(N) = 0; -!-----loop over levels - DO L=1,NNS%NLVL -!---------nnbr loop bounds - NNS%N1(L) = (2*L-1)**2; NNS%N2(L) = (2*L+1)**2-1; -!---------bottom-layer - J = -L - DO I=-L,L-1 - N = N + 1 - NNS%DI(N) = I; NNS%DJ(N) = J; - END DO -!---------right-layer - I = L - DO J=-L,L-1 - N = N + 1 - NNS%DI(N) = I; NNS%DJ(N) = J; - END DO -!---------top-layer - J = L - DO I=L,-L+1,-1 - N = N + 1 - NNS%DI(N) = I; NNS%DJ(N) = J; - END DO -!---------left-layer - I = -L - DO J=L,-L+1,-1 - N = N + 1 - NNS%DI(N) = I; NNS%DJ(N) = J; - END DO - END DO !loop over levels - - END FUNCTION W3NNSC -!/ -!/ End of W3NNSC ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3NNSD( NNS ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Destroy nearest-neighbor (NNBR) search object. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3NNSD( NNS ) - TYPE(T_NNS), POINTER :: NNS - -! Local parameters -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3NNSD') -#endif -! - IF ( ASSOCIATED(NNS) ) THEN - NNS%NLVL = 0 - NNS%NNBR = 0 - IF ( ASSOCIATED(NNS%N1) ) THEN - DEALLOCATE(NNS%N1); NULLIFY(NNS%N1); - END IF - IF ( ASSOCIATED(NNS%N2) ) THEN - DEALLOCATE(NNS%N2); NULLIFY(NNS%N2); - END IF - IF ( ASSOCIATED(NNS%DI) ) THEN - DEALLOCATE(NNS%DI); NULLIFY(NNS%DI); - END IF - IF ( ASSOCIATED(NNS%DJ) ) THEN - DEALLOCATE(NNS%DJ); NULLIFY(NNS%DJ); - END IF - DEALLOCATE(NNS) - NULLIFY(NNS) - END IF - - END SUBROUTINE W3NNSD -!/ -!/ End of W3NNSD ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3NNSP( NNS, IUNIT ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Print nearest-neighbor (NNBR) search object to IUNIT. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NNBR Type I Nearest-neighbor search object. -! IUNIT Int. I OPTIONAL unit for output. Default is stdout. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3NNSP(NNS, IUNIT) - TYPE(T_NNS), INTENT(IN) :: NNS - INTEGER, OPTIONAL, INTENT(IN) :: IUNIT - -! Local parameters - INTEGER :: NDST, L, N -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3NNSP') -#endif -! - IF ( PRESENT(IUNIT) ) THEN - NDST = IUNIT - ELSE - NDST = 6 - END IF -! - WRITE(NDST,'(A,2I6)') 'nlvl,nnbr:',NNS%NLVL,NNS%NNBR - DO L=0,NNS%NLVL - DO N=NNS%N1(L),NNS%N2(L) - WRITE(NDST,'(A,4I6)') 'l,n,di,dj:',L,N,NNS%DI(N),NNS%DJ(N) - END DO - END DO - - END SUBROUTINE W3NNSP -!/ -!/ End of W3NNSP ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3SORT( N, I, J, D ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Sort input arrays in increasing order according to input array D. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SORT_R4( N, I, J, D ) -! Single precision interface. - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(INOUT) :: I(N) - INTEGER, INTENT(INOUT) :: J(N) - REAL(4), INTENT(INOUT) :: D(N) - -! Local parameters - INTEGER :: K, L, IM, JM - REAL(4) :: DM -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SORT_R4') -#endif - - DO K=1, N-1 - DO L=K+1, N - IF ( D(L) .LT. D(K) ) THEN - IM = I(K); JM = J(K); DM = D(K); - I(K) = I(L); J(K) = J(L); D(K) = D(L); - I(L) = IM; J(L) = JM; D(L) = DM; - END IF - END DO !L - END DO !K - - END SUBROUTINE W3SORT_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SORT_R8( N, I, J, D ) -! Double precision interface. - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(INOUT) :: I(N) - INTEGER, INTENT(INOUT) :: J(N) - REAL(8), INTENT(INOUT) :: D(N) - -! Local parameters - INTEGER :: K, L, IM, JM - REAL(8) :: DM -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3SORT_R8') -#endif - - DO K=1, N-1 - DO L=K+1, N - IF ( D(L) .LT. D(K) ) THEN - IM = I(K); JM = J(K); DM = D(K); - I(K) = I(L); J(K) = J(L); D(K) = D(L); - I(L) = IM; J(L) = JM; D(L) = DM; - END IF - END DO !L - END DO !K - - END SUBROUTINE W3SORT_R8 -!/ -!/ End of W3SORT ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ SUBROUTINE W3ISRT( II, JJ, DD, N, I, J, D ) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Insert DD data into D at location where DD < D(K). -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3ISRT_R4( II, JJ, DD, N, I, J, D ) -! Single precision interface - INTEGER, INTENT(IN) :: II - INTEGER, INTENT(IN) :: JJ - REAL(4), INTENT(IN) :: DD - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(INOUT) :: I(N) - INTEGER, INTENT(INOUT) :: J(N) - REAL(4), INTENT(INOUT) :: D(N) - -! Local parameters - INTEGER :: K, L -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3ISRT_R4') -#endif - - K_LOOP: DO K=1,N - IF ( DD .LT. D(K) ) THEN -!-------------right-shift list (>= k) - DO L=N,K+1,-1 - I(L) = I(L-1); J(L) = J(L-1); D(L) = D(L-1); - END DO !L -!-------------insert point into list at k - I(K) = II; J(K) = JJ; D(K) = DD; - EXIT K_LOOP - END IF !dd.lt.d(k) - END DO K_LOOP - - END SUBROUTINE W3ISRT_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3ISRT_R8( II, JJ, DD, N, I, J, D ) -! Double precision interface - INTEGER, INTENT(IN) :: II - INTEGER, INTENT(IN) :: JJ - REAL(8), INTENT(IN) :: DD - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(INOUT) :: I(N) - INTEGER, INTENT(INOUT) :: J(N) - REAL(8), INTENT(INOUT) :: D(N) - -! Local parameters - INTEGER :: K, L -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3ISRT_R8') -#endif - - K_LOOP: DO K=1,N - IF ( DD .LT. D(K) ) THEN -!-------------right-shift list (>= k) - DO L=N,K+1,-1 - I(L) = I(L-1); J(L) = J(L-1); D(L) = D(L-1); - END DO !L -!-------------insert point into list at k - I(K) = II; J(K) = JJ; D(K) = DD; - EXIT K_LOOP - END IF !dd.lt.d(k) - END DO K_LOOP - - END SUBROUTINE W3ISRT_R8 -!/ -!/ End of W3ISRT ===================================================== / -!/ - - - - - - - - -!/ -!/ =================================================================== / -!/ -!/ FUNCTION W3INAN( X ) RESULT(INAN) -!/ -!/ =================================================================== / -!/ -! 1. Purpose : -! -! Return TRUE if input is infinite or NaN (not a number). -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3INAN_R4( X ) RESULT(INAN) -! Single precision interface - LOGICAL :: INAN - REAL(4), INTENT(IN) :: X - -! Local parameters -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3INAN_R4') -#endif - -!-----return true if X is NaN or +Inf or -Inf - INAN = .NOT. ( X .GE. -HUGE(X) .AND. X .LE. HUGE(X) ) - - END FUNCTION W3INAN_R4 -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION W3INAN_R8( X ) RESULT(INAN) -! Double precision interface - LOGICAL :: INAN - REAL(8), INTENT(IN) :: X - -! Local parameters -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3INAN_R8') -#endif - -!-----return true if X is NaN or +Inf or -Inf - INAN = .NOT. ( X .GE. -HUGE(X) .AND. X .LE. HUGE(X) ) - - END FUNCTION W3INAN_R8 -!/ -!/ End of W3INAN ===================================================== / -!/ - - - - - - - - -!/ -!/ Internal Support Routines ========================================= / -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ - FUNCTION GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4, YG4, XG8, YG8, & - BBOX_ONLY, NCB, NNP, DEBUG ) RESULT(GSU) -! *** INTERNAL SUBROUTINE *** - TYPE(T_GSU) :: GSU - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - INTEGER, INTENT(IN) :: LB(2) - INTEGER, INTENT(IN) :: UB(2) - REAL(4), TARGET, OPTIONAL :: XG4(LB(1):UB(1),LB(2):UB(2)) - REAL(4), TARGET, OPTIONAL :: YG4(LB(1):UB(1),LB(2):UB(2)) - REAL(8), TARGET, OPTIONAL :: XG8(LB(1):UB(1),LB(2):UB(2)) - REAL(8), TARGET, OPTIONAL :: YG8(LB(1):UB(1),LB(2):UB(2)) - LOGICAL, INTENT(IN), OPTIONAL :: BBOX_ONLY - INTEGER, INTENT(IN), OPTIONAL :: NCB - INTEGER, INTENT(IN), OPTIONAL :: NNP - LOGICAL, INTENT(IN), OPTIONAL :: DEBUG - -! Local parameters - TYPE(CLASS_GSU), POINTER :: PTR - LOGICAL :: TYPE_R4, TYPE_R8 - LOGICAL :: LDBG, LBBOX, LBC, LPL, LNPL, LSPL - INTEGER :: LBX, LBY, UBX, UBY, NX, NY - INTEGER :: LXC, LYC, UXC, UYC - INTEGER :: I, J, K, L, N, IC(4), JC(4), IB, JB - INTEGER :: NS, IB1(2), IB2(2), JB1(2), JB2(2), IBC(4), JBC(4) - INTEGER :: ISTEP, ISTAT - REAL(8) :: XC(4), YC(4) -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'W3GSUC') -#endif -! -------------------------------------------------------------------- / -! 1. Test input -! - TYPE_R4 = PRESENT(XG4).AND.PRESENT(YG4) - TYPE_R8 = PRESENT(XG8).AND.PRESENT(YG8) - IF ( .NOT.TYPE_R4.AND..NOT.TYPE_R8 ) THEN - WRITE(0,'(/1A,1A,1I2/)') 'W3GSUC ERROR -- ', & - 'no input grid coordinates specified' - CALL EXTCDE (1) - END IF - - IF (IJG) THEN - LBX = LB(1) - LBY = LB(2) - UBX = UB(1) - UBY = UB(2) - ELSE - LBX = LB(2) - LBY = LB(1) - UBX = UB(2) - UBY = UB(1) - END IF - NX = UBX - LBX + 1 - NY = UBY - LBY + 1 - - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE, ICLO_GRDI, ICLO_GRDJ, ICLO_TRDL, ICLO_TRPL ) - CONTINUE - CASE DEFAULT - WRITE(0,'(/1A,1A,1I2/)') 'W3GSUC ERROR -- ', & - 'unsupported ICLO: ',ICLO - CALL EXTCDE (1) - END SELECT - - IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NX,2).NE.0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', & - 'tripole grid closure requires NX=UBX-LBX+1 be even' - CALL EXTCDE (1) - END IF - - IF ( PRESENT(BBOX_ONLY) ) THEN - LBBOX = BBOX_ONLY - ELSE - LBBOX = .FALSE. - END IF - - IF ( PRESENT(NCB) ) THEN - IF ( NCB .LE. 0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', & - 'NCB must be greater than zero' - CALL EXTCDE (1) - END IF - END IF -! - IF ( PRESENT(DEBUG) ) THEN - LDBG = DEBUG - ELSE - LDBG = .FALSE. - END IF -! -! -------------------------------------------------------------------- / -! 2. Allocate object and set grid related data and pointers -! - ALLOCATE(PTR, STAT=ISTAT) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', & - 'gsu object allocation failed' - CALL EXTCDE (ISTAT) - END IF - PTR%IJG = IJG - PTR%LLG = LLG - PTR%ICLO = ICLO - PTR%LBX = LBX - PTR%LBY = LBY - PTR%UBX = UBX - PTR%UBY = UBY - PTR%NX = NX - PTR%NY = NY - IF (TYPE_R4) THEN - PTR%XG4 => XG4 - PTR%YG4 => YG4 - PTR%GKIND = 4 - ELSE - PTR%XG8 => XG8 - PTR%YG8 => YG8 - PTR%GKIND = 8 - END IF - NULLIFY( PTR%NNP ) - NULLIFY( PTR%B ) - NULLIFY( PTR%NNB ) -! -! -------------------------------------------------------------------- / -! 3. Create nearest-neighbor point search object -! - IF ( .NOT.LBBOX ) THEN - IF ( PRESENT(NNP) ) THEN - PTR%NNP => W3NNSC(NNP) - ELSE - PTR%NNP => W3NNSC(NNP_DEFAULT) - END IF - END IF -! -! -------------------------------------------------------------------- / -! 4. Construct bucket search "object" -! -!-----number of cells - LXC = LBX; LYC = LBY; - SELECT CASE ( ICLO ) - CASE ( ICLO_NONE ) - UXC = UBX-1; UYC = UBY-1; - CASE ( ICLO_GRDI ) - UXC = UBX; UYC = UBY-1; - CASE ( ICLO_GRDJ ) - UXC = UBX-1; UYC = UBY; - CASE ( ICLO_TRDL ) - UXC = UBX; UYC = UBY; - CASE ( ICLO_TRPL ) - UXC = UBX; UYC = UBY; - END SELECT -! -!-----initialize longitudinal periodicity flag (LCLO) - IF ( LLG .AND. ICLO.NE.ICLO_NONE ) THEN - PTR%LCLO = .TRUE. - ELSE - PTR%LCLO = .FALSE. - END IF -! -!-----check existence of longitudinal branch cut -!-----check if source grid includes poles - IF ( LDBG ) THEN - WRITE(*,'(/A)') 'W3GSUC - check source grid' - END IF - LNPL = .FALSE. - LSPL = .FALSE. - DO I=LXC,UXC - DO J=LYC,UYC -!-------------create list of cell vertices - IC(1) = I ; JC(1) = J ; - IC(2) = I+1; JC(2) = J ; - IC(3) = I+1; JC(3) = J+1; - IC(4) = I ; JC(4) = J+1; - DO L=1,4 -!-----------------apply index closure - IF ( MOD(ICLO,2).EQ.0 ) & - IC(L) = LBX + MOD(NX - 1 + MOD(IC(L) - LBX + 1, NX), NX) - IF ( MOD(ICLO,3).EQ.0 ) & - JC(L) = LBY + MOD(NY - 1 + MOD(JC(L) - LBY + 1, NY), NY) - IF ( ICLO.EQ.ICLO_TRPL .AND. JC(L).GT.UBY ) THEN - IC(L) = UBX + LBX - IC(L) - JC(L) = 2*UBY - JC(L) + 1 - END IF -!-----------------copy cell vertex coordinates into local variables - IF ( IJG ) THEN - IF (TYPE_R4) THEN - XC(L) = XG4(IC(L),JC(L)) - YC(L) = YG4(IC(L),JC(L)) - ELSE - XC(L) = XG8(IC(L),JC(L)) - YC(L) = YG8(IC(L),JC(L)) - END IF - ELSE - IF (TYPE_R4) THEN - XC(L) = XG4(JC(L),IC(L)) - YC(L) = YG4(JC(L),IC(L)) - ELSE - XC(L) = XG8(JC(L),IC(L)) - YC(L) = YG8(JC(L),IC(L)) - END IF - END IF - END DO !L -!-------------check if cell includes a pole or branch cut - LPL = .FALSE. - LBC = .FALSE. - IF ( LLG ) THEN -!-----------------count longitudinal branch cut crossings - N = 0 - DO L=1,4 - K = MOD(L,4)+1 - IF ( ABS(XC(K)-XC(L)) .GT. D180 ) N = N + 1 - END DO -!-----------------multiple longitudinal branch cut crossing => cell includes branch cut - LBC = N.GT.1 - IF ( LBC .AND. LDBG ) & - WRITE(*,'(A,8I6)') & - 'W3GSUC -- cell includes branch cut:',IC(:),JC(:) -!-----------------single longitudinal branch cut crossing -! or single vertex at 90 degrees => cell includes pole - LPL = N.EQ.1 .OR. COUNT(ABS(YC).EQ.D90).EQ.1 - IF ( LPL.AND.MINVAL(YC).GT.ZERO ) THEN - IF ( LDBG ) & - WRITE(*,'(A,8I6)') & - 'W3GSUC -- cell includes N-pole:',IC(:),JC(:) - LNPL = .TRUE. - END IF - IF ( LPL.AND.MAXVAL(YC).LT.ZERO ) THEN - IF ( LDBG ) & - WRITE(*,'(A,8I6)') & - 'W3GSUC -- cell includes S-pole:',IC(:),JC(:) - LSPL = .TRUE. - END IF -!-----------------longitudinal branch cut crossing => longitudinal closure - IF ( N.GT.0 ) PTR%LCLO = .TRUE. - END IF !LLG - END DO !J - END DO !I -! -!-----compute domain for search buckets -! if longitudinal periodicity, then force domain in x to [0:360] -! if grid includes north pole, then set ymax = 90 degrees -! if grid includes south pole, then set ymin = -90 degrees - IF (TYPE_R4) THEN - PTR%XMIN = MINVAL(XG4); PTR%XMAX = MAXVAL(XG4); - PTR%YMIN = MINVAL(YG4); PTR%YMAX = MAXVAL(YG4); - ELSE - PTR%XMIN = MINVAL(XG8); PTR%XMAX = MAXVAL(XG8); - PTR%YMIN = MINVAL(YG8); PTR%YMAX = MAXVAL(YG8); - END IF - IF ( PTR%LCLO ) THEN - PTR%XMIN = ZERO; PTR%XMAX = D360; - END IF - IF ( LSPL ) PTR%YMIN = -D90 - IF ( LNPL ) PTR%YMAX = D90 - PTR%L360 = PTR%XMIN.GE.ZERO -! -!-----if bbox only, then set pointer and return - IF ( LBBOX ) THEN - GSU%PTR => PTR - RETURN - END IF -! -!-----compute number of search buckets and bucket size - IF ( PRESENT(NCB) ) THEN - PTR%NBX = MAX(1,NX/NCB) - PTR%NBY = MAX(1,NY/NCB) - ELSE - PTR%NBX = MAX(1,NX/NCB_DEFAULT) - PTR%NBY = MAX(1,NY/NCB_DEFAULT) - END IF - PTR%DXB = (PTR%XMAX-PTR%XMIN)/REAL(PTR%NBX) - PTR%DYB = (PTR%YMAX-PTR%YMIN)/REAL(PTR%NBY) -! -!-----print debug info - IF ( LDBG ) THEN - WRITE(*,'(/A,1I2,1L2,1I2)') 'W3GSUC - ICLO,LCLO,GKIND: ', & - PTR%ICLO,PTR%LCLO,PTR%GKIND - WRITE(*,'(A,4E24.16)') 'W3GSUC - grid search domain:', & - PTR%XMIN,PTR%YMIN,PTR%XMAX,PTR%YMAX - WRITE(*,'(A,2I6)') 'W3GSUC - number of search buckets:', & - PTR%NBX,PTR%NBY - WRITE(*,'(A,2E24.16)') 'W3GSUC - search bucket size:', & - PTR%DXB,PTR%DYB - END IF -! -!-----allocate array of search buckets - ALLOCATE(PTR%B(PTR%NBY,PTR%NBX),STAT=ISTAT) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', & - 'search bucket array allocation failed' - CALL EXTCDE (ISTAT) - END IF -! -!-----BEGIN ISTEP_LOOP -! first step: compute number of cells in each bucket -! second step: allocate buckets and assign cells to buckets - ISTEP_LOOP: DO ISTEP=1,2 -! -!-----allocate search bucket cell lists - IF ( ISTEP .EQ. 2 ) THEN - DO IB=1,PTR%NBX - DO JB=1,PTR%NBY - NULLIFY(PTR%B(JB,IB)%I) - NULLIFY(PTR%B(JB,IB)%J) - IF ( PTR%B(JB,IB)%N .GT. 0 ) THEN - ALLOCATE(PTR%B(JB,IB)%I(PTR%B(JB,IB)%N),STAT=ISTAT) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,2A,3I6/)') 'W3GSUC ERROR -- ', & - 'search bucket cell-i list allocation failed -- ', & - 'bucket: ',IB,JB,N - CALL EXTCDE (ISTAT) - END IF - ALLOCATE(PTR%B(JB,IB)%J(PTR%B(JB,IB)%N),STAT=ISTAT) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,2A,3I6/)') 'W3GSUC ERROR -- ', & - 'search bucket cell-j list allocation failed -- ', & - 'bucket: ',IB,JB,N - CALL EXTCDE (ISTAT) - END IF - END IF - END DO - END DO - END IF !ISTEP.EQ.2 -! -!-----build search bucket cell lists - PTR%B(:,:)%N = 0 - DO I=LXC,UXC - DO J=LYC,UYC - IF ( ICLO.EQ.ICLO_TRPL ) THEN - IF ( J.EQ.UYC .AND. I.GT.LBX+NX/2 ) CYCLE - ENDIF -!-------------create list of cell vertices - IC(1) = I ; JC(1) = J ; - IC(2) = I+1; JC(2) = J ; - IC(3) = I+1; JC(3) = J+1; - IC(4) = I ; JC(4) = J+1; - DO L=1,4 -!-----------------apply index closure - IF ( MOD(ICLO,2).EQ.0 ) & - IC(L) = LBX + MOD(NX - 1 + MOD(IC(L) - LBX + 1, NX), NX) - IF ( MOD(ICLO,3).EQ.0 ) & - JC(L) = LBY + MOD(NY - 1 + MOD(JC(L) - LBY + 1, NY), NY) - IF ( ICLO.EQ.ICLO_TRPL .AND. JC(L).GT.UBY ) THEN - IC(L) = UBX + LBX - IC(L) - JC(L) = 2*UBY - JC(L) + 1 - END IF -!-----------------copy cell vertex coordinates into local variables - IF ( IJG ) THEN - IF (TYPE_R4) THEN - XC(L) = XG4(IC(L),JC(L)) - YC(L) = YG4(IC(L),JC(L)) - ELSE - XC(L) = XG8(IC(L),JC(L)) - YC(L) = YG8(IC(L),JC(L)) - END IF - ELSE - IF (TYPE_R4) THEN - XC(L) = XG4(JC(L),IC(L)) - YC(L) = YG4(JC(L),IC(L)) - ELSE - XC(L) = XG8(JC(L),IC(L)) - YC(L) = YG8(JC(L),IC(L)) - END IF - END IF - END DO !L -!-------------check if cell includes a pole or branch cut - LPL = .FALSE. - LBC = .FALSE. - IF ( LLG ) THEN -!-----------------shift longitudes to appropriate range - XC = MOD(XC,D360) - IF ( PTR%LCLO .OR. PTR%L360 ) THEN - WHERE ( XC.LT.ZERO ) XC = XC + D360 - ELSE - WHERE ( XC.GT.D180 ) XC = XC - D360 - END IF -!-----------------count longitudinal branch cut crossings - N = 0 - DO L=1,4 - K = MOD(L,4)+1 - IF ( ABS(XC(K)-XC(L)) .GT. D180 ) N = N + 1 - END DO -!-----------------multiple longitudinal branch cut crossing => cell includes branch cut - LBC = N.GT.1 -!-----------------single longitudinal branch cut crossing -! or single vertex at 90 degrees => cell includes pole - LPL = N.EQ.1 .OR. COUNT(ABS(YC).EQ.D90).EQ.1 - END IF !LLG -!-------------set bucket id for each cell vertex - DO L=1,4 - IBC(L) = INT((XC(L)-PTR%XMIN)/PTR%DXB)+1 - IF ( .NOT.PTR%LCLO ) IBC(L) = MIN(IBC(L),PTR%NBX) - JBC(L) = MIN(INT((YC(L)-PTR%YMIN)/PTR%DYB)+1,PTR%NBY) - END DO !L -!-------------set bucket overlap bounds - IF ( LPL ) THEN -!---------------cell includes pole: overlap includes full longitudinal range - NS = 1 - IB1(1) = 1 - IB2(1) = PTR%NBX - IF ( MINVAL(YC).GT.ZERO ) THEN - JB1(1) = MAX(1,MINVAL(JBC)) - JB2(1) = PTR%NBY - END IF - IF ( MAXVAL(YC).LT.ZERO ) THEN - JB1(1) = 1 - JB2(1) = MIN(PTR%NBY,MAXVAL(JBC)) - END IF - IB1(2) = 0 - IB2(2) = 0 - JB1(2) = 0 - JB2(2) = 0 - ELSE IF ( LBC ) THEN -!---------------cell includes branch cut: split overlap into two sets - NS = 2 - IB1(1) = PTR%NBX - IB2(1) = PTR%NBX - IB1(2) = 1 - IB2(2) = 1 - DO L=1,4 - IF ( IBC(L) .GT. PTR%NBX/2 ) THEN - IB1(1) = MIN(IB1(1),IBC(L)) - ELSE - IB2(2) = MAX(IB2(2),IBC(L)) - END IF - END DO !L - JB1(:) = MAX(1,MINVAL(JBC)) - JB2(:) = MIN(PTR%NBY,MAXVAL(JBC)) - ELSE -!---------------default: overlap computed from min/max - NS = 1 - IB1(1) = MAX(1,MINVAL(IBC)) - IB2(1) = MIN(PTR%NBX,MAXVAL(IBC)) - JB1(1) = MAX(1,MINVAL(JBC)) - JB2(1) = MIN(PTR%NBY,MAXVAL(JBC)) - IB1(2) = 0 - IB2(2) = 0 - JB1(2) = 0 - JB2(2) = 0 - END IF -!-------------debug output - IF ( LDBG .AND. ISTEP.EQ.1 ) THEN - WRITE(*,'(/A,2I6)') 'W3GSUC -- BUCKET SORT:',I,J - WRITE(*,'(A,2L6,1I6)') 'W3GSUC -- LBC,LPL:',LBC,LPL - WRITE(*,'(A,4I6)') 'W3GSUC -- IC:',IC(:) - WRITE(*,'(A,4I6)') 'W3GSUC -- JC:',JC(:) - WRITE(*,'(A,4E24.16)') 'W3GSUC -- XC:',XC(:) - WRITE(*,'(A,4E24.16)') 'W3GSUC -- YC:',YC(:) - WRITE(*,'(A,4I6)') 'W3GSUC -- IBC:',IBC(:) - WRITE(*,'(A,4I6)') 'W3GSUC -- JBC:',JBC(:) - WRITE(*,'(A,1I6)') 'W3GSUC -- NS:',NS - WRITE(*,'(A,4I6)') 'W3GSUC -- IB1:',IB1(:) - WRITE(*,'(A,4I6)') 'W3GSUC -- JB1:',JB1(:) - WRITE(*,'(A,4I6)') 'W3GSUC -- IB2:',IB2(:) - WRITE(*,'(A,4I6)') 'W3GSUC -- JB2:',JB2(:) - END IF -!-------------assign cell to buckets based on overlap - DO K=1,NS - DO IB=IB1(K),IB2(K) - DO JB=JB1(K),JB2(K) - PTR%B(JB,IB)%N = PTR%B(JB,IB)%N + 1 - IF ( ISTEP .EQ. 2 ) THEN - PTR%B(JB,IB)%I(PTR%B(JB,IB)%N) = IC(1) - PTR%B(JB,IB)%J(PTR%B(JB,IB)%N) = JC(1) - END IF - END DO !JB - END DO !IB - END DO !K - END DO !J - END DO !I -! -!-----END ISTEP_LOOP - END DO ISTEP_LOOP -! -!-----create nearest-neighbor bucket search object - PTR%NNB => W3NNSC(NINT(HALF*MAX(PTR%NBX,PTR%NBY))) -! -!-----print debug info - IF ( LDBG ) THEN - WRITE(*,'(/A,3I6,4E24.16)') 'W3GSUC - search bucket list:' - WRITE(*,'(3A6,4A14)') 'I','J','N','X1','Y1','X2','Y2' - DO IB=1,PTR%NBX - DO JB=1,PTR%NBY - WRITE(*,'(3I6,4E24.16)') IB,JB,PTR%B(JB,IB)%N, & - PTR%XMIN+(IB-1)*PTR%DXB,PTR%YMIN+(JB-1)*PTR%DYB, & - PTR%XMIN+(IB-0)*PTR%DXB,PTR%YMIN+(JB-0)*PTR%DYB - END DO - END DO - END IF -! -! -------------------------------------------------------------------- / -! 5. Set return parameter -! - GSU%PTR => PTR - - END FUNCTION GSU_CREATE -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE GETPQR( XT, YT, XS, YS, PR, QR, EPS, DEBUG ) -! *** INTERNAL SUBROUTINE *** -! Compute source grid cell-relative coordinates (PR,QR) for target point (XT,YT) - REAL(8), INTENT(IN) :: XT - REAL(8), INTENT(IN) :: YT - REAL(8), INTENT(IN) :: XS(4) - REAL(8), INTENT(IN) :: YS(4) - REAL(8), INTENT(OUT) :: PR - REAL(8), INTENT(OUT) :: QR - REAL(8), INTENT(IN), OPTIONAL :: EPS - LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG - -! Local parameters - INTEGER, PARAMETER :: MAX_ITER = 10 - REAL(8), PARAMETER :: CONVERGE = 1D-6 - REAL(8) :: LEPS - LOGICAL :: LDBG - INTEGER :: K, ITER - REAL(8) :: DXT, DX1, DX2, DX3, DXP, DYT, DY1, DY2, DY3, DYP - REAL(8) :: MAT1, MAT2, MAT3, MAT4, DELP, DELQ, DET -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 - CALL STRACE (IENT, 'GETPQR') -#endif - - IF ( PRESENT(EPS) ) THEN - IF ( EPS .LT. ZERO ) THEN - WRITE(0,'(/2A/)') 'GETPQR ERROR -- ', & - 'EPS parameter must be >= 0' - CALL EXTCDE (1) - END IF - LEPS = EPS - ELSE - LEPS = EPS_DEFAULT - END IF - IF ( PRESENT(DEBUG) ) THEN - LDBG = DEBUG - ELSE - LDBG = .FALSE. - END IF -! -!-----handle point coincident with a cell vertex - DO K=1,4 - IF ( ABS(XT-XS(K)).LE.LEPS .AND. ABS(YT-YS(K)).LE.LEPS ) THEN - SELECT CASE ( K ) - CASE ( 1 ) - PR = ZERO; QR = ZERO; - CASE ( 2 ) - PR = ONE; QR = ZERO; - CASE ( 3 ) - PR = ONE; QR = ONE; - CASE ( 4 ) - PR = ZERO; QR = ONE; - END SELECT - IF ( LDBG ) & - WRITE(*,'(A,I3,4E24.16)') 'GETPQR - COINCIDENT:', & - K,ABS(XT-XS(K)),ABS(YT-YS(K)),PR,QR - RETURN - END IF - END DO -! -!-----set iteration parameters and initial guess - PR = HALF - QR = HALF - DYT = YT - YS(1) - DY1 = YS(2) - YS(1) - DY2 = YS(4) - YS(1) - DY3 = YS(3) - YS(2) - DY2 - DXT = XT - XS(1) - DX1 = XS(2) - XS(1) - DX2 = XS(4) - XS(1) - DX3 = XS(3) - XS(2) - DX2 - -!-----iterate to find (PR,QR) - ITER_LOOP: DO ITER=1,MAX_ITER - DYP = DYT - DY1*PR - DY2*QR - DY3*PR*QR - DXP = DXT - DX1*PR - DX2*QR - DX3*PR*QR - MAT1 = DY1 + DY3*QR - MAT2 = DY2 + DY3*PR - MAT3 = DX1 + DX3*QR - MAT4 = DX2 + DX3*PR - DET = MAT1*MAT4 - MAT2*MAT3 - DELP = (DYP*MAT4 - MAT2*DXP)/DET - DELQ = (MAT1*DXP - DYP*MAT3)/DET - IF ( LDBG ) & - WRITE(*,'(A,I3,4E24.16)') 'GETPQR - ITER:', & - ITER,PR,QR,DELP,DELQ - PR = PR + DELP - QR = QR + DELQ - IF ( ABS(DELP) < CONVERGE .AND. & - ABS(DELQ) < CONVERGE ) EXIT ITER_LOOP - END DO ITER_LOOP - -!-----if max iteration count exceeded, then exit with error - IF ( ITER .GT. MAX_ITER ) THEN - WRITE(0,'(/A)') & - 'GETPQR -- ERROR: exceeded max iteration count' - WRITE(0,'(A,2E24.16)') 'GETPQR - DEST POINT COORDS: ',XT,YT - DO K=1,4 - WRITE(0,'(A,I1,A,2E24.16)') & - 'GETPQR - SRC POINT ',K,': ',XS(K),YS(K) - END DO - WRITE(0,'(A,4E24.16)') & - 'GETPQR - CURRENT PR,QR,DELP,DELQ: ',PR,QR,DELP,DELQ - CALL EXTCDE (1) - END IF !(ITER.LE.MAX_ITER) - - END SUBROUTINE GETPQR -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE GETBLC( GSU, I, J, PR, QR, LCMP, NS, LS, IS, JS, CS ) -! *** INTERNAL SUBROUTINE *** -! Compute bilinear remap factors for a given point (P,Q) -! (I,J) = lower-left corner point of grid cell containing target point -! (PR,QR) = cell-relative coordinate of target point -! Double precision interface - TYPE(T_GSU), INTENT(IN) :: GSU - INTEGER, INTENT(IN) :: I, J - REAL(8), INTENT(IN) :: PR, QR - LOGICAL, INTENT(IN) :: LCMP - INTEGER, INTENT(OUT) :: NS - LOGICAL, POINTER, INTENT(INOUT) :: LS(:) - INTEGER, POINTER, INTENT(INOUT) :: IS(:), JS(:) - REAL(8), POINTER, INTENT(INOUT) :: CS(:) - -! Local parameters - LOGICAL :: IJG, LLG, LCLO - INTEGER :: ICLO, GKIND - INTEGER :: LBX, LBY, UBX, UBY, NX, NY - INTEGER :: ISTAT, K -! -!---- initialize - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/2A/)') 'GETBLC ERROR -- ', & - 'grid search utility object not created' - CALL EXTCDE (1) - END IF - IJG = GSU%PTR%IJG - LLG = GSU%PTR%LLG - ICLO = GSU%PTR%ICLO - LCLO = GSU%PTR%LCLO - GKIND = GSU%PTR%GKIND - LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; - UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; - NX = GSU%PTR%NX; NY = GSU%PTR%NY; -! -!---- check & deallocate - IF ( ASSOCIATED(LS) ) THEN - DEALLOCATE(LS); NULLIFY(LS); - END IF - IF ( ASSOCIATED(IS) ) THEN - DEALLOCATE(IS); NULLIFY(IS); - END IF - IF ( ASSOCIATED(JS) ) THEN - DEALLOCATE(JS); NULLIFY(JS); - END IF - IF ( ASSOCIATED(CS) ) THEN - DEALLOCATE(CS); NULLIFY(CS); - END IF -! -!---- set number of interpolation points and allocate arrays - NS = 4 - ALLOCATE( LS(NS), IS(NS), JS(NS), CS(NS), STAT=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,1A/)') 'GETBLC ERROR -- ', & - 'array allocation failed' - CALL EXTCDE (ISTAT) - END IF - LS(:) = .TRUE. - CS(:) = ZERO -! -!---- 4 source points for the bilinear interpolation -! (4)------------------(3) -! | | -! | PR | -! |-----. | -! | | | -! | |QR | -! | | | -! (1)------------------(2) - IS(1) = I ; JS(1) = J ; - IS(2) = I+1; JS(2) = J ; - IS(3) = I+1; JS(3) = J+1; - IS(4) = I ; JS(4) = J+1; -! -!---- apply index closure - DO K=1,NS - IF ( MOD(ICLO,2).EQ.0 ) & - IS(K) = LBX + MOD(NX - 1 + MOD(IS(K) - LBX + 1, NX), NX) - IF ( MOD(ICLO,3).EQ.0 ) & - JS(K) = LBY + MOD(NY - 1 + MOD(JS(K) - LBY + 1, NY), NY) - IF ( ICLO.EQ.ICLO_TRPL .AND. JS(K).GT.UBY ) THEN - IS(K) = UBX + LBX - IS(K) - JS(K) = 2*UBY - JS(K) + 1 - END IF - END DO -! -!---- calculate bilinear interpolation coefficients - IF ( LCMP ) THEN - CS(1) = (ONE-PR)*(ONE-QR) - CS(2) = PR*(ONE-QR) - CS(3) = PR*QR - CS(4) = (ONE-PR)*QR - END IF - - END SUBROUTINE GETBLC -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE GETBCC( GSU, I, J, PR, QR, LCMP, NS, LS, IS, JS, CS ) -! *** INTERNAL SUBROUTINE *** -! Compute bicubic remap factors for a given point (P,Q) -! (I,J) = lower-left corner point of grid cell containing target point -! (PR,QR) = cell-relative coordinate of target point - TYPE(T_GSU), INTENT(IN) :: GSU - INTEGER, INTENT(IN) :: I, J - REAL(8), INTENT(IN) :: PR, QR - LOGICAL, INTENT(IN) :: LCMP - INTEGER, INTENT(OUT) :: NS - LOGICAL, POINTER, INTENT(INOUT) :: LS(:) - INTEGER, POINTER, INTENT(INOUT) :: IS(:), JS(:) - REAL(8), POINTER, INTENT(INOUT) :: CS(:) - -! Local parameters - REAL(8), PARAMETER :: SMALL = 1D-6 - LOGICAL :: IJG, LLG, LCLO - INTEGER :: ICLO, GKIND - INTEGER :: LBX, LBY, UBX, UBY, NX, NY - INTEGER :: ISTAT, P, Q, II, JJ, K, L, N, M - REAL(8) :: PV(0:3), QV(0:3), PW(0:3), QW(0:3) - REAL(8) :: A(0:1,0:1,0:3) - REAL(8) :: W(0:3,0:3) = RESHAPE((/ 1, 0, -3, 2, & - 0, 0, 3, -2, & - 0, 1, -2, 1, & - 0, 0, -1, 1 /), & - (/4,4/)) - INTEGER, PARAMETER :: NFD = 2 ! finite-difference order (even) - INTEGER :: KFD(0:NFD,0:NFD) = RESHAPE((/ 0, 1, 2, & - -1, 0, 1, & - -2, -1, 0 /), & - (/NFD+1,NFD+1/)) - REAL(8) :: CFD(0:NFD,0:NFD) = HALF* RESHAPE((/ -3, 4, -1, & - -1, 0, 1, & - 1, -4, 3 /), & - (/NFD+1,NFD+1/)) - REAL(8) :: CS2D(-NFD/2:NFD,-NFD/2:NFD) -! -!---- initialize - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/2A/)') 'GETBCC ERROR -- ', & - 'grid search utility object not created' - CALL EXTCDE (1) - END IF - IJG = GSU%PTR%IJG - LLG = GSU%PTR%LLG - ICLO = GSU%PTR%ICLO - LCLO = GSU%PTR%LCLO - GKIND = GSU%PTR%GKIND - LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; - UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; - NX = GSU%PTR%NX; NY = GSU%PTR%NY; -! -!---- check & deallocate - IF ( ASSOCIATED(LS) ) THEN - DEALLOCATE(LS); NULLIFY(LS); - END IF - IF ( ASSOCIATED(IS) ) THEN - DEALLOCATE(IS); NULLIFY(IS); - END IF - IF ( ASSOCIATED(JS) ) THEN - DEALLOCATE(JS); NULLIFY(JS); - END IF - IF ( ASSOCIATED(CS) ) THEN - DEALLOCATE(CS); NULLIFY(CS); - END IF -! -!---- setup table of bicubic coefficients -! -! (0,1)----------------(1,1) -! | | -! | | -! |-----x(Pr,Qr) | -! | | | -! | | | -! | | | -! (0,0)----------------(1,0) -! -! Pv = [ Pr**0, Pr**1, Pr**2, Pr**3 ]^t -! Qv = [ Qr**0, Qr**1, Qr**2, Qr**3 ]^t -! -! Pw = W*Pv -! Qw = W*Qv -! -! A(i,j,0) = Pw(i )*Qw(j ) -! A(i,j,1) = Pw(i+2)*Qw(j ) -! A(i,j,2) = Pw(i )*Qw(j+2) -! A(i,j,3) = Pw(i+2)*Qw(j+2) -! -! F(Pr,Qr) = SUM[i=0:1]{ SUM[j=0:1]{ -! A(i,j,0) * F(i,j) + -! A(i,j,1) * Fp(i,j) + -! A(i,j,2) * Fq(i,j) + -! A(i,j,3) * Fpq(i,j) } } -! - DO K=0,3 - PV(K) = PR**K - QV(K) = QR**K - END DO - PW = MATMUL(PV,W) - QW = MATMUL(QV,W) - DO JJ=0,1 - DO II=0,1 - A(II,JJ,0) = PW(II) *QW(JJ) - A(II,JJ,1) = PW(II+2)*QW(JJ) - A(II,JJ,2) = PW(II) *QW(JJ+2) - A(II,JJ,3) = PW(II+2)*QW(JJ+2) - END DO - END DO -! -!---- source points for the bicubic interpolation -! The additional points are needed to construct derivatives (centered in space). -! If boundary points are not available one sided finite differences are used. -! -! (-1, 2).... (0, 2).....(1, 2).....(2, 2) -! . . . . -! . . . . -! . . . . -! . . . . -! . . . . -! (-1, 1).....(0, 1)-----(1, 1).....(2, 1) -! . | | . -! . | Pr | . -! . |----x | . -! . | |Qr | . -! . | | | . -! (-1, 0).....(0, 0)-----(1, 0).....(2, 0) -! . . . . -! . . . . -! . . . . -! . . . . -! . . . . -! (-1,-1).....(0,-1).....(1,-1).....(2,-1) -! -! Fp(i,j) = SUM[n=0:NFD]{ CFD(n,l)*F(i+KFD(n,l),j) } -! Fq(i,j) = SUM[n=0:NFD]{ CFD(n,k)*F(i,j+KFD(n,k)) } -! Fpq(i,j) = SUM[n=0:NFD]{ SUM[m=0:NFD]{ -! CFD(n,l)*CFD(m,k)*F(i+KFD(n,l),j+KFD(m,k)) } } -! -! (i,j) = (0,0),(1,0),(1,1),(0,1) -! l or k = 0 : one-sided finite-difference (left) -! l or k = 1 : centered finite-difference -! l or k = 2 : one-sided finite-difference (right) -! - CS2D = ZERO - DO JJ=0,1 - DO II=0,1 - P = I + II - Q = J + JJ - IF ( MOD(ICLO,2).EQ.0 ) THEN - K = NFD/2 - ELSE - IF (P-LBX.LT.NFD/2) THEN - K = P - LBX - ELSE IF (UBX-P.LT.NFD/2) THEN - K = NFD + P - UBX - ELSE - K = NFD/2 - END IF - END IF - IF ( MOD(ICLO,3).EQ.0 ) THEN - L = NFD/2 - ELSE IF ( ICLO.EQ.ICLO_TRPL ) THEN - IF (Q-LBY.LT.NFD/2) THEN - L = Q - LBY - ELSE - L = NFD/2 - END IF - ELSE - IF (Q-LBY.LT.NFD/2) THEN - L = Q - LBY - ELSE IF (UBY-Q.LT.NFD/2) THEN - L = NFD + Q - UBY - ELSE - L = NFD/2 - END IF - END IF - CS2D(II,JJ) = CS2D(II,JJ) + A(II,JJ,0) - DO N=0,NFD - CS2D(II+KFD(N,K),JJ) = CS2D(II+KFD(N,K),JJ) & - + A(II,JJ,1)*CFD(N,K) - CS2D(II,JJ+KFD(N,L)) = CS2D(II,JJ+KFD(N,L)) & - + A(II,JJ,2)*CFD(N,L) - DO M=0,NFD - CS2D(II+KFD(N,K),JJ+KFD(M,L)) = & - CS2D(II+KFD(N,K),JJ+KFD(M,L)) & - + A(II,JJ,3)*CFD(N,K)*CFD(M,L) - END DO - END DO - END DO - END DO -! -!---- set number of interpolation points and allocate arrays - NS = COUNT( ABS(CS2D) .GT. SMALL ) - ALLOCATE( LS(NS), IS(NS), JS(NS), CS(NS), STAT=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,1A/)') 'GETBCC ERROR -- ', & - 'array allocation failed' - CALL EXTCDE (ISTAT) - END IF - LS(:) = .TRUE. - CS(:) = ZERO -! -!---- load arrays and apply index closure - NS = 0 - DO JJ=-NFD/2,NFD - DO II=-NFD/2,NFD - IF ( ABS(CS2D(II,JJ)) .GT. SMALL ) THEN - NS = NS + 1 - IS(NS) = I + II - JS(NS) = J + JJ - CS(NS) = CS2D(II,JJ) - IF ( MOD(ICLO,2).EQ.0 ) & - IS(NS) = LBX + MOD(NX - 1 + MOD(IS(NS) - LBX + 1, NX), NX) - IF ( MOD(ICLO,3).EQ.0 ) & - JS(NS) = LBY + MOD(NY - 1 + MOD(JS(NS) - LBY + 1, NY), NY) - IF ( ICLO.EQ.ICLO_TRPL .AND. JS(NS).GT.UBY ) THEN - IS(NS) = UBX + LBX - IS(NS) - JS(NS) = 2*UBY - JS(NS) + 1 - END IF - END IF - END DO - END DO - - END SUBROUTINE GETBCC -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE GETGFC( GSU, I, J, PR, QR, WIDTH, LCMP, NS, LS, IS, JS, CS ) -! *** INTERNAL SUBROUTINE *** -! Compute gaussian filter remap factors for a given point (P,Q) -! (I,J) = lower-left corner point of grid cell containing target point -! (PR,QR) = cell-relative coordinate of target point -! Double precision interface - TYPE(T_GSU), INTENT(IN) :: GSU - INTEGER, INTENT(IN) :: I, J - REAL(8), INTENT(IN) :: PR, QR - REAL(8), INTENT(IN) :: WIDTH - LOGICAL, INTENT(IN) :: LCMP - INTEGER, INTENT(OUT) :: NS - LOGICAL, POINTER, INTENT(INOUT) :: LS(:) - INTEGER, POINTER, INTENT(INOUT) :: IS(:), JS(:) - REAL(8), POINTER, INTENT(INOUT) :: CS(:) - -! Local parameters -! Note, width (=nsig*sigma) is set to max(width,width_min) -! so that the filter includes at least one source point. - REAL(8), PARAMETER :: NSIG = 6.0D0 - REAL(8), PARAMETER :: WIDTH_MIN = 1.5D0 - LOGICAL :: IJG, LLG, LCLO - INTEGER :: ICLO, GKIND - INTEGER :: LBX, LBY, UBX, UBY, NX, NY - INTEGER :: ISTAT, K - INTEGER :: II, JJ, IMIN, JMIN, IMAX, JMAX - REAL(8) :: WDTH, SIG2, RMAX, R2MX, SFAC, R2, GIJ, GSUM -! -!---- initialize - IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN - WRITE(0,'(/2A/)') 'GETBLC ERROR -- ', & - 'grid search utility object not created' - CALL EXTCDE (1) - END IF - IJG = GSU%PTR%IJG - LLG = GSU%PTR%LLG - ICLO = GSU%PTR%ICLO - LCLO = GSU%PTR%LCLO - GKIND = GSU%PTR%GKIND - LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; - UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; - NX = GSU%PTR%NX; NY = GSU%PTR%NY; - WDTH = MAX(WIDTH,WIDTH_MIN) - SIG2 = (WDTH/NSIG)**2 - SFAC = -0.5D0/SIG2 - RMAX = 0.5D0*WDTH - R2MX = RMAX**2 - IMIN = INT(MIN(ZERO,PR)-RMAX) - JMIN = INT(MIN(ZERO,QR)-RMAX) - IMAX = CEILING(MAX(ZERO,PR)+RMAX) - JMAX = CEILING(MAX(ZERO,QR)+RMAX) -! -!---- check & deallocate - IF ( ASSOCIATED(LS) ) THEN - DEALLOCATE(LS); NULLIFY(LS); - END IF - IF ( ASSOCIATED(IS) ) THEN - DEALLOCATE(IS); NULLIFY(IS); - END IF - IF ( ASSOCIATED(JS) ) THEN - DEALLOCATE(JS); NULLIFY(JS); - END IF - IF ( ASSOCIATED(CS) ) THEN - DEALLOCATE(CS); NULLIFY(CS); - END IF -! -!---- set number of interpolation points and allocate arrays - NS = (IMAX-IMIN+1)*(JMAX-JMIN+1) - ALLOCATE( LS(NS), IS(NS), JS(NS), CS(NS), STAT=ISTAT ) - IF ( ISTAT .NE. 0 ) THEN - WRITE(0,'(/1A,1A/)') 'GETGFC ERROR -- ', & - 'array allocation failed' - CALL EXTCDE (ISTAT) - END IF - LS(:) = .FALSE. - CS(:) = ZERO -! -!---- calculate filter coefficients - GSUM = ZERO - DO JJ=JMIN,JMAX - DO II=IMIN,IMAX - K = (IMAX-IMIN+1)*(JJ-JMIN) + II - IMIN + 1 -!-------- source points for the filter - IS(K) = I + II - JS(K) = J + JJ -!-------- apply index closure - IF ( MOD(ICLO,2).EQ.0 ) & - IS(K) = LBX + MOD(NX - 1 + MOD(IS(K) - LBX + 1, NX), NX) - IF ( MOD(ICLO,3).EQ.0 ) & - JS(K) = LBY + MOD(NY - 1 + MOD(JS(K) - LBY + 1, NY), NY) - IF ( ICLO.EQ.ICLO_TRPL .AND. JS(K).GT.UBY ) THEN - IS(K) = UBX + LBX - IS(K) - JS(K) = 2*UBY - JS(K) + 1 - END IF -!-------- skip if source point is outside domain - IF ( IS(K).LT.LBX .OR. IS(K).GT.UBX ) CYCLE - IF ( JS(K).LT.LBY .OR. JS(K).GT.UBY ) CYCLE -!-------- compute distance - R2 = (PR - II)**2 + (QR - JJ)**2 -! IF ( R2.GT.R2MX ) CYCLE -!-------- compute coefficient - LS(K) = .TRUE. - IF ( LCMP ) THEN - GIJ = EXP( SFAC*R2 ) - GSUM = GSUM + GIJ - CS(K) = GIJ - END IF - END DO - END DO - IF ( LCMP ) THEN - WHERE ( LS ) CS = CS/GSUM - END IF - - END SUBROUTINE GETGFC -!/ -!/ ------------------------------------------------------------------- / -!/ -#define DXYDP_SINGLE_POINT_WIDE_CHANNEL_ERROR -#undef DXYDP_SINGLE_POINT_WIDE_CHANNEL_WARNING - SUBROUTINE DXYDP( N, K, C, IJG, LLG, ICLO, & - PTILED, QTILED, PRANGE, QRANGE, & - LB, UB, P, Q, DXDP, DYDP, MASK, & - X4, Y4, X8, Y8, RC ) -! *** INTERNAL SUBROUTINE *** - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K(0:N,0:N,1:N) - REAL(8), INTENT(IN) :: C(0:N,0:N,1:N) - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LB(2), UB(2) - INTEGER, INTENT(IN) :: P, Q - REAL(8), INTENT(OUT) :: DXDP, DYDP - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LB(1):UB(1),LB(2):UB(2)) - REAL(4), INTENT(IN), OPTIONAL :: X4(LB(1):UB(1),LB(2):UB(2)) - REAL(4), INTENT(IN), OPTIONAL :: Y4(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(IN), OPTIONAL :: X8(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(IN), OPTIONAL :: Y8(LB(1):UB(1),LB(2):UB(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - LOGICAL, PARAMETER :: DEBUG = .FALSE. - CHARACTER(64) :: FSTR - LOGICAL :: COMP_M, TYPE_R4, TYPE_R8 - INTEGER :: IHEM - INTEGER :: NP, NQ, LBP, LBQ, UBP, UBQ, P0, Q0 - INTEGER :: ISTAT=0, I, L, II, NI, II0, IIN - INTEGER :: KP(0:N), KQ(0:N) - LOGICAL :: MP(0:N) - REAL(8) :: XP(0:N) - REAL(8) :: YP(0:N) - REAL(8) :: UP(0:N) - REAL(8) :: VP(0:N) - REAL(8) :: X0, Y0, LON0, LAT0, C0 - REAL(8) :: D1DP, D2DP -! -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - - TYPE_R4 = PRESENT(X4).AND.PRESENT(Y4) - TYPE_R8 = PRESENT(X8).AND.PRESENT(Y8) - IF ( .NOT.TYPE_R4.AND..NOT.TYPE_R8 ) THEN - WRITE(0,'(/1A,1A/)') 'DXYDP ERROR -- ', & - 'no input grid coordinates specified' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 - - IF ( IJG ) THEN - LBP = LB(1); LBQ = LB(2) - UBP = UB(1); UBQ = UB(2) - ELSE - LBP = LB(2); LBQ = LB(1) - UBP = UB(2); UBQ = UB(1) - END IF - - IF ( P.LT.LBP .OR. P.GT.UBP .OR. Q.LT.LBQ .OR. Q.GT.UBQ ) THEN - WRITE(0,'(/1A,/1A,1L2,5I6,/1A,1L2,5I6/)') 'DXYDP ERROR -- '// & - 'input index coordinates outside input array bounds', & - 'DXYDP ERROR -- PTILED,PRANGE,P,LBP,UBP:',PTILED,PRANGE,P,LBP,UBP, & - 'DXYDP ERROR -- QTILED,QRANGE,Q,LBQ,UBQ:',QTILED,QRANGE,Q,LBQ,UBQ - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - P0 = P - Q0 = Q + IF ( PRESENT(EPS) ) THEN + IF ( EPS .LT. ZERO ) THEN + WRITE(0,'(/2A/)') 'GETPQR ERROR -- ', & + 'EPS parameter must be >= 0' + CALL EXTCDE (1) + END IF + LEPS = EPS + ELSE + LEPS = EPS_DEFAULT + END IF + IF ( PRESENT(DEBUG) ) THEN + LDBG = DEBUG + ELSE + LDBG = .FALSE. + END IF + ! + !-----handle point coincident with a cell vertex + DO K=1,4 + IF ( ABS(XT-XS(K)).LE.LEPS .AND. ABS(YT-YS(K)).LE.LEPS ) THEN + SELECT CASE ( K ) + CASE ( 1 ) + PR = ZERO; QR = ZERO; + CASE ( 2 ) + PR = ONE; QR = ZERO; + CASE ( 3 ) + PR = ONE; QR = ONE; + CASE ( 4 ) + PR = ZERO; QR = ONE; + END SELECT + IF ( LDBG ) & + WRITE(*,'(A,I3,4E24.16)') 'GETPQR - COINCIDENT:', & + K,ABS(XT-XS(K)),ABS(YT-YS(K)),PR,QR + RETURN + END IF + END DO + ! + !-----set iteration parameters and initial guess + PR = HALF + QR = HALF + DYT = YT - YS(1) + DY1 = YS(2) - YS(1) + DY2 = YS(4) - YS(1) + DY3 = YS(3) - YS(2) - DY2 + DXT = XT - XS(1) + DX1 = XS(2) - XS(1) + DX2 = XS(4) - XS(1) + DX3 = XS(3) - XS(2) - DX2 + + !-----iterate to find (PR,QR) + ITER_LOOP: DO ITER=1,MAX_ITER + DYP = DYT - DY1*PR - DY2*QR - DY3*PR*QR + DXP = DXT - DX1*PR - DX2*QR - DX3*PR*QR + MAT1 = DY1 + DY3*QR + MAT2 = DY2 + DY3*PR + MAT3 = DX1 + DX3*QR + MAT4 = DX2 + DX3*PR + DET = MAT1*MAT4 - MAT2*MAT3 + DELP = (DYP*MAT4 - MAT2*DXP)/DET + DELQ = (MAT1*DXP - DYP*MAT3)/DET + IF ( LDBG ) & + WRITE(*,'(A,I3,4E24.16)') 'GETPQR - ITER:', & + ITER,PR,QR,DELP,DELQ + PR = PR + DELP + QR = QR + DELQ + IF ( ABS(DELP) < CONVERGE .AND. & + ABS(DELQ) < CONVERGE ) EXIT ITER_LOOP + END DO ITER_LOOP + + !-----if max iteration count exceeded, then exit with error + IF ( ITER .GT. MAX_ITER ) THEN + WRITE(0,'(/A)') & + 'GETPQR -- ERROR: exceeded max iteration count' + WRITE(0,'(A,2E24.16)') 'GETPQR - DEST POINT COORDS: ',XT,YT + DO K=1,4 + WRITE(0,'(A,I1,A,2E24.16)') & + 'GETPQR - SRC POINT ',K,': ',XS(K),YS(K) + END DO + WRITE(0,'(A,4E24.16)') & + 'GETPQR - CURRENT PR,QR,DELP,DELQ: ',PR,QR,DELP,DELQ + CALL EXTCDE (1) + END IF !(ITER.LE.MAX_ITER) + + END SUBROUTINE GETPQR + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE GETBLC( GSU, I, J, PR, QR, LCMP, NS, LS, IS, JS, CS ) + ! *** INTERNAL SUBROUTINE *** + ! Compute bilinear remap factors for a given point (P,Q) + ! (I,J) = lower-left corner point of grid cell containing target point + ! (PR,QR) = cell-relative coordinate of target point + ! Double precision interface + TYPE(T_GSU), INTENT(IN) :: GSU + INTEGER, INTENT(IN) :: I, J + REAL(8), INTENT(IN) :: PR, QR + LOGICAL, INTENT(IN) :: LCMP + INTEGER, INTENT(OUT) :: NS + LOGICAL, POINTER, INTENT(INOUT) :: LS(:) + INTEGER, POINTER, INTENT(INOUT) :: IS(:), JS(:) + REAL(8), POINTER, INTENT(INOUT) :: CS(:) + + ! Local parameters + LOGICAL :: IJG, LLG, LCLO + INTEGER :: ICLO, GKIND + INTEGER :: LBX, LBY, UBX, UBY, NX, NY + INTEGER :: ISTAT, K + ! + !---- initialize + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/2A/)') 'GETBLC ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + IJG = GSU%PTR%IJG + LLG = GSU%PTR%LLG + ICLO = GSU%PTR%ICLO + LCLO = GSU%PTR%LCLO + GKIND = GSU%PTR%GKIND + LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; + UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; + NX = GSU%PTR%NX; NY = GSU%PTR%NY; + ! + !---- check & deallocate + IF ( ASSOCIATED(LS) ) THEN + DEALLOCATE(LS); NULLIFY(LS); + END IF + IF ( ASSOCIATED(IS) ) THEN + DEALLOCATE(IS); NULLIFY(IS); + END IF + IF ( ASSOCIATED(JS) ) THEN + DEALLOCATE(JS); NULLIFY(JS); + END IF + IF ( ASSOCIATED(CS) ) THEN + DEALLOCATE(CS); NULLIFY(CS); + END IF + ! + !---- set number of interpolation points and allocate arrays + NS = 4 + ALLOCATE( LS(NS), IS(NS), JS(NS), CS(NS), STAT=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,1A/)') 'GETBLC ERROR -- ', & + 'array allocation failed' + CALL EXTCDE (ISTAT) + END IF + LS(:) = .TRUE. + CS(:) = ZERO + ! + !---- 4 source points for the bilinear interpolation + ! (4)------------------(3) + ! | | + ! | PR | + ! |-----. | + ! | | | + ! | |QR | + ! | | | + ! (1)------------------(2) + IS(1) = I ; JS(1) = J ; + IS(2) = I+1; JS(2) = J ; + IS(3) = I+1; JS(3) = J+1; + IS(4) = I ; JS(4) = J+1; + ! + !---- apply index closure + DO K=1,NS IF ( MOD(ICLO,2).EQ.0 ) & - P0 = PRANGE(1) + MOD(NP - 1 + MOD(P0 - PRANGE(1) + 1, NP), NP) + IS(K) = LBX + MOD(NX - 1 + MOD(IS(K) - LBX + 1, NX), NX) IF ( MOD(ICLO,3).EQ.0 ) & - Q0 = QRANGE(1) + MOD(NQ - 1 + MOD(Q0 - QRANGE(1) + 1, NQ), NQ) - IF ( ICLO.EQ.ICLO_TRPL .AND. Q0.GT.QRANGE(2) ) THEN - P0 = PRANGE(2) + PRANGE(1) - P0 - Q0 = 2*QRANGE(2) - Q0 + 1 - END IF - IF ( P0.LT.PRANGE(1) .OR. P0.GT.PRANGE(2) .OR. & - Q0.LT.QRANGE(1) .OR. Q0.GT.QRANGE(2) ) THEN - WRITE(0,'(/1A,/1A,4I6,/1A,4I6/)') 'DXYDP ERROR -- '// & - 'shifted input index coordinates outside allowed range', & - 'DXYDP ERROR -- PRANGE,P,P0:',PRANGE,P,P0, & - 'DXYDP ERROR -- QRANGE,Q,Q0:',QRANGE,Q,Q0 - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - DXDP = ZERO - DYDP = ZERO - COMP_M = PRESENT(MASK) - IF ( COMP_M ) THEN - IF ( IJG ) THEN - IF ( MASK(P0,Q0) ) RETURN - ELSE - IF ( MASK(Q0,P0) ) RETURN - END IF - END IF -! -! -------------------------------------------------------------------- / -! 2. Compute DX/DP & DY/DP -! - IF ( MOD(ICLO,2).EQ.0 ) THEN - I = N/2 - ELSE - IF (P0-PRANGE(1).LT.N/2) THEN - I = P0 - PRANGE(1) - ELSE IF (PRANGE(2)-P0.LT.N/2) THEN - I = N + P0 - PRANGE(2) - ELSE - I = N/2 - END IF - END IF - - KP(:) = P + K(:,I,N) - KQ(:) = Q - IF ( .NOT.PTILED ) THEN - IF ( MOD(ICLO,2).EQ.0 ) THEN - KP = PRANGE(1) + MOD(NP - 1 + MOD(KP - PRANGE(1) + 1, NP), NP) - END IF - END IF - - IF ( MINVAL(KP).LT.LBP .OR. MAXVAL(KP).GT.UBP .OR. & - MINVAL(KQ).LT.LBQ .OR. MAXVAL(KQ).GT.UBQ ) THEN - WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DXYDP ERROR -- '// & - 'stencil index coordinates outside array bounds', & - 'DXYDP ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', & - PTILED,PRANGE,P,P0,LBP,UBP,MINVAL(KP),MAXVAL(KP), & - 'DXYDP ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', & - QTILED,QRANGE,Q,Q0,LBQ,UBQ,MINVAL(KQ),MAXVAL(KQ) - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - DO L = 0, N - IF ( IJG ) THEN - IF ( COMP_M ) MP(L) = MASK(KP(L),KQ(L)) - IF ( TYPE_R4 ) THEN - XP(L) = X4(KP(L),KQ(L)) - YP(L) = Y4(KP(L),KQ(L)) - ELSE - XP(L) = X8(KP(L),KQ(L)) - YP(L) = Y8(KP(L),KQ(L)) - END IF - ELSE - IF ( COMP_M ) MP(L) = MASK(KQ(L),KP(L)) - IF ( TYPE_R4 ) THEN - XP(L) = X4(KQ(L),KP(L)) - YP(L) = Y4(KQ(L),KP(L)) - ELSE - XP(L) = X8(KQ(L),KP(L)) - YP(L) = Y8(KQ(L),KP(L)) - END IF - END IF - END DO - - II = I - NI = N - II0 = 0 - IIN = N - IF ( COMP_M ) THEN - DO L = I-1, 0, -1 - IF ( MP(L) ) THEN - MP(0:L) = .TRUE. - EXIT - END IF - END DO - DO L = I+1, N - IF ( MP(L) ) THEN - MP(L:N) = .TRUE. - EXIT - END IF - END DO - II = COUNT(.NOT.MP(0:I)) - 1 - NI = COUNT(.NOT.MP(0:N)) - 1 - II0 = I - II - IIN = II0 + NI - END IF -#ifdef DXYDP_SINGLE_POINT_WIDE_CHANNEL_ERROR - IF ( NI.LE.0 ) THEN - WRITE(0,'(/1A,1A,4I6/)') 'DXYDP ERROR -- ', & - 'single point wide channel not allowed',P,Q,P0,Q0 - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF -#endif - - IF ( NI.GT.0 ) THEN - IF ( LLG ) THEN -#define DXYDP_USE_SPLX -#ifdef DXYDP_USE_SPLX - IF ( IJG ) THEN - IF ( TYPE_R4 ) THEN - X0 = X4(P,Q); Y0 = Y4(P,Q); - ELSE - X0 = X8(P,Q); Y0 = Y8(P,Q); - END IF - ELSE - IF ( TYPE_R4 ) THEN - X0 = X4(Q,P); Y0 = Y4(Q,P); - ELSE - X0 = X8(Q,P); Y0 = Y8(Q,P); - END IF - END IF - IHEM = 1; IF (MAXVAL(YP(II0:IIN)).LT.ZERO) IHEM = -1; - LON0 = ZERO; LAT0 = SIGN(D90,REAL(IHEM,8)); - C0 = D90 - ABS(Y0) - CALL W3SPLX(LON0,LAT0,C0,XP(II0:IIN),YP(II0:IIN), & - UP(II0:IIN),VP(II0:IIN)) - D1DP = DOT_PRODUCT(C(0:NI,II,NI),UP(II0:IIN)) - D2DP = DOT_PRODUCT(C(0:NI,II,NI),VP(II0:IIN)) - CALL SPDDP(LON0,C0,IHEM,X0,Y0,D1DP,D2DP,DXDP,DYDP) -#else - DXDP = DOT_PRODUCT(C(0:NI,II,NI),XP(II0:IIN)) - DYDP = DOT_PRODUCT(C(0:NI,II,NI),YP(II0:IIN)) -#endif - ELSE !.NOT.LLG - DXDP = DOT_PRODUCT(C(0:NI,II,NI),XP(II0:IIN)) - DYDP = DOT_PRODUCT(C(0:NI,II,NI),YP(II0:IIN)) - END IF !.NOT.LLG - IF ( DEBUG ) THEN - WRITE(FSTR,'(A,I0,A,I0,A)') & - '(/1A,12I8,5(/1A,2E16.8),/1A,', & - NI+1,'I16,3(/1A,',NI+1,'E16.8))' - WRITE(*,TRIM(FSTR)) & - 'DXYDP -- PRANGE,QRANGE,P,Q,P0,Q0,NI,II,II0,IIN:',& - PRANGE,QRANGE,P,Q,P0,Q0,NI,II,II0,IIN, & - 'DXYDP -- X0, Y0:',X0,Y0, & - 'DXYDP -- LON0,LAT0:',LON0,LAT0, & - 'DXYDP -- C0,IHEM:',C0,REAL(IHEM), & - 'DXYDP -- D1DP,D2DP:',D1DP,D2DP, & - 'DXYDP -- DXDP,DYDP:',DXDP,DYDP, & - 'DXYDP -- K:', K(0:NI,II,NI), & - 'DXYDP -- C:', C(0:NI,II,NI), & - 'DXYDP -- XP:',XP(II0:IIN), & - 'DXYDP -- YP:',YP(II0:IIN) - END IF - ELSE -#ifdef DXYDP_SINGLE_POINT_WIDE_CHANNEL_WARNING - WRITE(0,'(/1A,1A,4I6/)') 'DXYDP WARNING -- ', & - 'single point wide channel, DXDP & DYDP set to zero:',P,Q,P0,Q0 -#endif - DXDP = ZERO - DYDP = ZERO - END IF - - END SUBROUTINE DXYDP -!/ -!/ ------------------------------------------------------------------- / -!/ -#define DXYDQ_SINGLE_POINT_WIDE_CHANNEL_ERROR -#undef DXYDQ_SINGLE_POINT_WIDE_CHANNEL_WARNING - SUBROUTINE DXYDQ( N, K, C, IJG, LLG, ICLO, & - PTILED, QTILED, PRANGE, QRANGE, & - LB, UB, P, Q, DXDQ, DYDQ, MASK, & - X4, Y4, X8, Y8, RC ) -! *** INTERNAL SUBROUTINE *** - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K(0:N,0:N,1:N) - REAL(8), INTENT(IN) :: C(0:N,0:N,1:N) - LOGICAL, INTENT(IN) :: IJG - LOGICAL, INTENT(IN) :: LLG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LB(2), UB(2) - INTEGER, INTENT(IN) :: P, Q - REAL(8), INTENT(OUT) :: DXDQ, DYDQ - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LB(1):UB(1),LB(2):UB(2)) - REAL(4), INTENT(IN), OPTIONAL :: X4(LB(1):UB(1),LB(2):UB(2)) - REAL(4), INTENT(IN), OPTIONAL :: Y4(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(IN), OPTIONAL :: X8(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(IN), OPTIONAL :: Y8(LB(1):UB(1),LB(2):UB(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - LOGICAL, PARAMETER :: DEBUG = .FALSE. - CHARACTER(64) :: FSTR - LOGICAL :: COMP_M, TYPE_R4, TYPE_R8 - INTEGER :: IHEM - INTEGER :: NP, NQ, LBP, LBQ, UBP, UBQ, P0, Q0 - INTEGER :: ISTAT=0, J, L, JJ, NJ, JJ0, JJN - INTEGER :: KP(0:N), KQ(0:N) - LOGICAL :: MQ(0:N) - REAL(8) :: XQ(0:N) - REAL(8) :: YQ(0:N) - REAL(8) :: UQ(0:N) - REAL(8) :: VQ(0:N) - REAL(8) :: X0, Y0, LON0, LAT0, C0 - REAL(8) :: D1DQ, D2DQ -! -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - - TYPE_R4 = PRESENT(X4).AND.PRESENT(Y4) - TYPE_R8 = PRESENT(X8).AND.PRESENT(Y8) - IF ( .NOT.TYPE_R4.AND..NOT.TYPE_R8 ) THEN - WRITE(0,'(/1A,1A/)') 'DXYDQ ERROR -- ', & - 'no input grid coordinates specified' - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 - - IF ( IJG ) THEN - LBP = LB(1); LBQ = LB(2) - UBP = UB(1); UBQ = UB(2) + JS(K) = LBY + MOD(NY - 1 + MOD(JS(K) - LBY + 1, NY), NY) + IF ( ICLO.EQ.ICLO_TRPL .AND. JS(K).GT.UBY ) THEN + IS(K) = UBX + LBX - IS(K) + JS(K) = 2*UBY - JS(K) + 1 + END IF + END DO + ! + !---- calculate bilinear interpolation coefficients + IF ( LCMP ) THEN + CS(1) = (ONE-PR)*(ONE-QR) + CS(2) = PR*(ONE-QR) + CS(3) = PR*QR + CS(4) = (ONE-PR)*QR + END IF + + END SUBROUTINE GETBLC + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE GETBCC( GSU, I, J, PR, QR, LCMP, NS, LS, IS, JS, CS ) + ! *** INTERNAL SUBROUTINE *** + ! Compute bicubic remap factors for a given point (P,Q) + ! (I,J) = lower-left corner point of grid cell containing target point + ! (PR,QR) = cell-relative coordinate of target point + TYPE(T_GSU), INTENT(IN) :: GSU + INTEGER, INTENT(IN) :: I, J + REAL(8), INTENT(IN) :: PR, QR + LOGICAL, INTENT(IN) :: LCMP + INTEGER, INTENT(OUT) :: NS + LOGICAL, POINTER, INTENT(INOUT) :: LS(:) + INTEGER, POINTER, INTENT(INOUT) :: IS(:), JS(:) + REAL(8), POINTER, INTENT(INOUT) :: CS(:) + + ! Local parameters + REAL(8), PARAMETER :: SMALL = 1D-6 + LOGICAL :: IJG, LLG, LCLO + INTEGER :: ICLO, GKIND + INTEGER :: LBX, LBY, UBX, UBY, NX, NY + INTEGER :: ISTAT, P, Q, II, JJ, K, L, N, M + REAL(8) :: PV(0:3), QV(0:3), PW(0:3), QW(0:3) + REAL(8) :: A(0:1,0:1,0:3) + REAL(8) :: W(0:3,0:3) = RESHAPE((/ 1, 0, -3, 2, & + 0, 0, 3, -2, & + 0, 1, -2, 1, & + 0, 0, -1, 1 /), & + (/4,4/)) + INTEGER, PARAMETER :: NFD = 2 ! finite-difference order (even) + INTEGER :: KFD(0:NFD,0:NFD) = RESHAPE((/ 0, 1, 2, & + -1, 0, 1, & + -2, -1, 0 /), & + (/NFD+1,NFD+1/)) + REAL(8) :: CFD(0:NFD,0:NFD) = HALF* RESHAPE((/ -3, 4, -1, & + -1, 0, 1, & + 1, -4, 3 /), & + (/NFD+1,NFD+1/)) + REAL(8) :: CS2D(-NFD/2:NFD,-NFD/2:NFD) + ! + !---- initialize + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/2A/)') 'GETBCC ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + IJG = GSU%PTR%IJG + LLG = GSU%PTR%LLG + ICLO = GSU%PTR%ICLO + LCLO = GSU%PTR%LCLO + GKIND = GSU%PTR%GKIND + LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; + UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; + NX = GSU%PTR%NX; NY = GSU%PTR%NY; + ! + !---- check & deallocate + IF ( ASSOCIATED(LS) ) THEN + DEALLOCATE(LS); NULLIFY(LS); + END IF + IF ( ASSOCIATED(IS) ) THEN + DEALLOCATE(IS); NULLIFY(IS); + END IF + IF ( ASSOCIATED(JS) ) THEN + DEALLOCATE(JS); NULLIFY(JS); + END IF + IF ( ASSOCIATED(CS) ) THEN + DEALLOCATE(CS); NULLIFY(CS); + END IF + ! + !---- setup table of bicubic coefficients + ! + ! (0,1)----------------(1,1) + ! | | + ! | | + ! |-----x(Pr,Qr) | + ! | | | + ! | | | + ! | | | + ! (0,0)----------------(1,0) + ! + ! Pv = [ Pr**0, Pr**1, Pr**2, Pr**3 ]^t + ! Qv = [ Qr**0, Qr**1, Qr**2, Qr**3 ]^t + ! + ! Pw = W*Pv + ! Qw = W*Qv + ! + ! A(i,j,0) = Pw(i )*Qw(j ) + ! A(i,j,1) = Pw(i+2)*Qw(j ) + ! A(i,j,2) = Pw(i )*Qw(j+2) + ! A(i,j,3) = Pw(i+2)*Qw(j+2) + ! + ! F(Pr,Qr) = SUM[i=0:1]{ SUM[j=0:1]{ + ! A(i,j,0) * F(i,j) + + ! A(i,j,1) * Fp(i,j) + + ! A(i,j,2) * Fq(i,j) + + ! A(i,j,3) * Fpq(i,j) } } + ! + DO K=0,3 + PV(K) = PR**K + QV(K) = QR**K + END DO + PW = MATMUL(PV,W) + QW = MATMUL(QV,W) + DO JJ=0,1 + DO II=0,1 + A(II,JJ,0) = PW(II) *QW(JJ) + A(II,JJ,1) = PW(II+2)*QW(JJ) + A(II,JJ,2) = PW(II) *QW(JJ+2) + A(II,JJ,3) = PW(II+2)*QW(JJ+2) + END DO + END DO + ! + !---- source points for the bicubic interpolation + ! The additional points are needed to construct derivatives (centered in space). + ! If boundary points are not available one sided finite differences are used. + ! + ! (-1, 2).... (0, 2).....(1, 2).....(2, 2) + ! . . . . + ! . . . . + ! . . . . + ! . . . . + ! . . . . + ! (-1, 1).....(0, 1)-----(1, 1).....(2, 1) + ! . | | . + ! . | Pr | . + ! . |----x | . + ! . | |Qr | . + ! . | | | . + ! (-1, 0).....(0, 0)-----(1, 0).....(2, 0) + ! . . . . + ! . . . . + ! . . . . + ! . . . . + ! . . . . + ! (-1,-1).....(0,-1).....(1,-1).....(2,-1) + ! + ! Fp(i,j) = SUM[n=0:NFD]{ CFD(n,l)*F(i+KFD(n,l),j) } + ! Fq(i,j) = SUM[n=0:NFD]{ CFD(n,k)*F(i,j+KFD(n,k)) } + ! Fpq(i,j) = SUM[n=0:NFD]{ SUM[m=0:NFD]{ + ! CFD(n,l)*CFD(m,k)*F(i+KFD(n,l),j+KFD(m,k)) } } + ! + ! (i,j) = (0,0),(1,0),(1,1),(0,1) + ! l or k = 0 : one-sided finite-difference (left) + ! l or k = 1 : centered finite-difference + ! l or k = 2 : one-sided finite-difference (right) + ! + CS2D = ZERO + DO JJ=0,1 + DO II=0,1 + P = I + II + Q = J + JJ + IF ( MOD(ICLO,2).EQ.0 ) THEN + K = NFD/2 ELSE - LBP = LB(2); LBQ = LB(1) - UBP = UB(2); UBQ = UB(1) - END IF - - IF ( P.LT.LBP .OR. P.GT.UBP .OR. Q.LT.LBQ .OR. Q.GT.UBQ ) THEN - WRITE(0,'(/1A,/1A,1L2,5I6,/1A,1L2,5I6/)') 'DXYDQ ERROR -- '// & - 'input index coordinates outside input array bounds', & - 'DXYDQ ERROR -- PTILED,PRANGE,P,LBP,UBP:',PTILED,PRANGE,P,LBP,UBP, & - 'DXYDQ ERROR -- QTILED,QRANGE,Q,LBQ,UBQ:',QTILED,QRANGE,Q,LBQ,UBQ - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - P0 = P - Q0 = Q - IF ( MOD(ICLO,2).EQ.0 ) & - P0 = PRANGE(1) + MOD(NP - 1 + MOD(P0 - PRANGE(1) + 1, NP), NP) - IF ( MOD(ICLO,3).EQ.0 ) & - Q0 = QRANGE(1) + MOD(NQ - 1 + MOD(Q0 - QRANGE(1) + 1, NQ), NQ) - IF ( ICLO.EQ.ICLO_TRPL .AND. Q0.GT.QRANGE(2) ) THEN - P0 = PRANGE(2) + PRANGE(1) - P0 - Q0 = 2*QRANGE(2) - Q0 + 1 - END IF - IF ( P0.LT.PRANGE(1) .OR. P0.GT.PRANGE(2) .OR. & - Q0.LT.QRANGE(1) .OR. Q0.GT.QRANGE(2) ) THEN - WRITE(0,'(/1A,/1A,4I6,/1A,4I6/)') 'DXYDQ ERROR -- '// & - 'shifted input index coordinates outside allowed range', & - 'DXYDQ ERROR -- PRANGE,P,P0:',PRANGE,P,P0, & - 'DXYDQ ERROR -- QRANGE,Q,Q0:',QRANGE,Q,Q0 - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - DXDQ = ZERO - DYDQ = ZERO - COMP_M = PRESENT(MASK) - IF ( COMP_M ) THEN - IF ( IJG ) THEN - IF ( MASK(P0,Q0) ) RETURN - ELSE - IF ( MASK(Q0,P0) ) RETURN - END IF + IF (P-LBX.LT.NFD/2) THEN + K = P - LBX + ELSE IF (UBX-P.LT.NFD/2) THEN + K = NFD + P - UBX + ELSE + K = NFD/2 + END IF END IF -! -! -------------------------------------------------------------------- / -! 2. Compute DX/DQ & DY/DQ -! - IF ( MOD(ICLO,3).EQ.0 ) THEN - J = N/2 + IF ( MOD(ICLO,3).EQ.0 ) THEN + L = NFD/2 ELSE IF ( ICLO.EQ.ICLO_TRPL ) THEN - IF (Q0-QRANGE(1).LT.N/2) THEN - J = Q0 - QRANGE(1) - ELSE - J = N/2 - END IF - ELSE - IF (Q0-QRANGE(1).LT.N/2) THEN - J = Q0 - QRANGE(1) - ELSE IF (QRANGE(2)-Q0.LT.N/2) THEN - J = N + Q0 - QRANGE(2) - ELSE - J = N/2 - END IF - END IF - - KP(:) = P - KQ(:) = Q + K(:,J,N) - IF ( .NOT.QTILED ) THEN - IF ( MOD(ICLO,3).EQ.0 ) THEN - KQ = QRANGE(1) + MOD(NQ - 1 + MOD(KQ - QRANGE(1) + 1, NQ), NQ) - END IF - IF ( ICLO.EQ.ICLO_TRPL .AND. .NOT.PTILED ) THEN - WHERE ( KQ.GT.QRANGE(2) ) - KP = PRANGE(2) + PRANGE(1) - KP - KQ = 2*QRANGE(2) - KQ + 1 - END WHERE - END IF - END IF - - IF ( MINVAL(KP).LT.LBP .OR. MAXVAL(KP).GT.UBP .OR. & - MINVAL(KQ).LT.LBQ .OR. MAXVAL(KQ).GT.UBQ ) THEN - WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DXYDQ ERROR -- '// & - 'stencil index coordinates outside array bounds', & - 'DXYDQ ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', & - PTILED,PRANGE,P,P0,LBP,UBP,MINVAL(KP),MAXVAL(KP), & - 'DXYDQ ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', & - QTILED,QRANGE,Q,Q0,LBQ,UBQ,MINVAL(KQ),MAXVAL(KQ) - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - DO L = 0, N - IF ( IJG ) THEN - IF ( COMP_M ) MQ(L) = MASK(KP(L),KQ(L)) - IF ( TYPE_R4 ) THEN - XQ(L) = X4(KP(L),KQ(L)) - YQ(L) = Y4(KP(L),KQ(L)) - ELSE - XQ(L) = X8(KP(L),KQ(L)) - YQ(L) = Y8(KP(L),KQ(L)) - END IF - ELSE - IF ( COMP_M ) MQ(L) = MASK(KQ(L),KP(L)) - IF ( TYPE_R4 ) THEN - XQ(L) = X4(KQ(L),KP(L)) - YQ(L) = Y4(KQ(L),KP(L)) - ELSE - XQ(L) = X8(KQ(L),KP(L)) - YQ(L) = Y8(KQ(L),KP(L)) - END IF - END IF + IF (Q-LBY.LT.NFD/2) THEN + L = Q - LBY + ELSE + L = NFD/2 + END IF + ELSE + IF (Q-LBY.LT.NFD/2) THEN + L = Q - LBY + ELSE IF (UBY-Q.LT.NFD/2) THEN + L = NFD + Q - UBY + ELSE + L = NFD/2 + END IF + END IF + CS2D(II,JJ) = CS2D(II,JJ) + A(II,JJ,0) + DO N=0,NFD + CS2D(II+KFD(N,K),JJ) = CS2D(II+KFD(N,K),JJ) & + + A(II,JJ,1)*CFD(N,K) + CS2D(II,JJ+KFD(N,L)) = CS2D(II,JJ+KFD(N,L)) & + + A(II,JJ,2)*CFD(N,L) + DO M=0,NFD + CS2D(II+KFD(N,K),JJ+KFD(M,L)) = & + CS2D(II+KFD(N,K),JJ+KFD(M,L)) & + + A(II,JJ,3)*CFD(N,K)*CFD(M,L) + END DO END DO + END DO + END DO + ! + !---- set number of interpolation points and allocate arrays + NS = COUNT( ABS(CS2D) .GT. SMALL ) + ALLOCATE( LS(NS), IS(NS), JS(NS), CS(NS), STAT=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,1A/)') 'GETBCC ERROR -- ', & + 'array allocation failed' + CALL EXTCDE (ISTAT) + END IF + LS(:) = .TRUE. + CS(:) = ZERO + ! + !---- load arrays and apply index closure + NS = 0 + DO JJ=-NFD/2,NFD + DO II=-NFD/2,NFD + IF ( ABS(CS2D(II,JJ)) .GT. SMALL ) THEN + NS = NS + 1 + IS(NS) = I + II + JS(NS) = J + JJ + CS(NS) = CS2D(II,JJ) + IF ( MOD(ICLO,2).EQ.0 ) & + IS(NS) = LBX + MOD(NX - 1 + MOD(IS(NS) - LBX + 1, NX), NX) + IF ( MOD(ICLO,3).EQ.0 ) & + JS(NS) = LBY + MOD(NY - 1 + MOD(JS(NS) - LBY + 1, NY), NY) + IF ( ICLO.EQ.ICLO_TRPL .AND. JS(NS).GT.UBY ) THEN + IS(NS) = UBX + LBX - IS(NS) + JS(NS) = 2*UBY - JS(NS) + 1 + END IF + END IF + END DO + END DO + + END SUBROUTINE GETBCC + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE GETGFC( GSU, I, J, PR, QR, WIDTH, LCMP, NS, LS, IS, JS, CS ) + ! *** INTERNAL SUBROUTINE *** + ! Compute gaussian filter remap factors for a given point (P,Q) + ! (I,J) = lower-left corner point of grid cell containing target point + ! (PR,QR) = cell-relative coordinate of target point + ! Double precision interface + TYPE(T_GSU), INTENT(IN) :: GSU + INTEGER, INTENT(IN) :: I, J + REAL(8), INTENT(IN) :: PR, QR + REAL(8), INTENT(IN) :: WIDTH + LOGICAL, INTENT(IN) :: LCMP + INTEGER, INTENT(OUT) :: NS + LOGICAL, POINTER, INTENT(INOUT) :: LS(:) + INTEGER, POINTER, INTENT(INOUT) :: IS(:), JS(:) + REAL(8), POINTER, INTENT(INOUT) :: CS(:) + + ! Local parameters + ! Note, width (=nsig*sigma) is set to max(width,width_min) + ! so that the filter includes at least one source point. + REAL(8), PARAMETER :: NSIG = 6.0D0 + REAL(8), PARAMETER :: WIDTH_MIN = 1.5D0 + LOGICAL :: IJG, LLG, LCLO + INTEGER :: ICLO, GKIND + INTEGER :: LBX, LBY, UBX, UBY, NX, NY + INTEGER :: ISTAT, K + INTEGER :: II, JJ, IMIN, JMIN, IMAX, JMAX + REAL(8) :: WDTH, SIG2, RMAX, R2MX, SFAC, R2, GIJ, GSUM + ! + !---- initialize + IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN + WRITE(0,'(/2A/)') 'GETBLC ERROR -- ', & + 'grid search utility object not created' + CALL EXTCDE (1) + END IF + IJG = GSU%PTR%IJG + LLG = GSU%PTR%LLG + ICLO = GSU%PTR%ICLO + LCLO = GSU%PTR%LCLO + GKIND = GSU%PTR%GKIND + LBX = GSU%PTR%LBX; LBY = GSU%PTR%LBY; + UBX = GSU%PTR%UBX; UBY = GSU%PTR%UBY; + NX = GSU%PTR%NX; NY = GSU%PTR%NY; + WDTH = MAX(WIDTH,WIDTH_MIN) + SIG2 = (WDTH/NSIG)**2 + SFAC = -0.5D0/SIG2 + RMAX = 0.5D0*WDTH + R2MX = RMAX**2 + IMIN = INT(MIN(ZERO,PR)-RMAX) + JMIN = INT(MIN(ZERO,QR)-RMAX) + IMAX = CEILING(MAX(ZERO,PR)+RMAX) + JMAX = CEILING(MAX(ZERO,QR)+RMAX) + ! + !---- check & deallocate + IF ( ASSOCIATED(LS) ) THEN + DEALLOCATE(LS); NULLIFY(LS); + END IF + IF ( ASSOCIATED(IS) ) THEN + DEALLOCATE(IS); NULLIFY(IS); + END IF + IF ( ASSOCIATED(JS) ) THEN + DEALLOCATE(JS); NULLIFY(JS); + END IF + IF ( ASSOCIATED(CS) ) THEN + DEALLOCATE(CS); NULLIFY(CS); + END IF + ! + !---- set number of interpolation points and allocate arrays + NS = (IMAX-IMIN+1)*(JMAX-JMIN+1) + ALLOCATE( LS(NS), IS(NS), JS(NS), CS(NS), STAT=ISTAT ) + IF ( ISTAT .NE. 0 ) THEN + WRITE(0,'(/1A,1A/)') 'GETGFC ERROR -- ', & + 'array allocation failed' + CALL EXTCDE (ISTAT) + END IF + LS(:) = .FALSE. + CS(:) = ZERO + ! + !---- calculate filter coefficients + GSUM = ZERO + DO JJ=JMIN,JMAX + DO II=IMIN,IMAX + K = (IMAX-IMIN+1)*(JJ-JMIN) + II - IMIN + 1 + !-------- source points for the filter + IS(K) = I + II + JS(K) = J + JJ + !-------- apply index closure + IF ( MOD(ICLO,2).EQ.0 ) & + IS(K) = LBX + MOD(NX - 1 + MOD(IS(K) - LBX + 1, NX), NX) + IF ( MOD(ICLO,3).EQ.0 ) & + JS(K) = LBY + MOD(NY - 1 + MOD(JS(K) - LBY + 1, NY), NY) + IF ( ICLO.EQ.ICLO_TRPL .AND. JS(K).GT.UBY ) THEN + IS(K) = UBX + LBX - IS(K) + JS(K) = 2*UBY - JS(K) + 1 + END IF + !-------- skip if source point is outside domain + IF ( IS(K).LT.LBX .OR. IS(K).GT.UBX ) CYCLE + IF ( JS(K).LT.LBY .OR. JS(K).GT.UBY ) CYCLE + !-------- compute distance + R2 = (PR - II)**2 + (QR - JJ)**2 + ! IF ( R2.GT.R2MX ) CYCLE + !-------- compute coefficient + LS(K) = .TRUE. + IF ( LCMP ) THEN + GIJ = EXP( SFAC*R2 ) + GSUM = GSUM + GIJ + CS(K) = GIJ + END IF + END DO + END DO + IF ( LCMP ) THEN + WHERE ( LS ) CS = CS/GSUM + END IF + + END SUBROUTINE GETGFC + !/ + !/ ------------------------------------------------------------------- / + !/ +#define DXYDP_SINGLE_POINT_WIDE_CHANNEL_ERROR +#undef DXYDP_SINGLE_POINT_WIDE_CHANNEL_WARNING + SUBROUTINE DXYDP( N, K, C, IJG, LLG, ICLO, & + PTILED, QTILED, PRANGE, QRANGE, & + LB, UB, P, Q, DXDP, DYDP, MASK, & + X4, Y4, X8, Y8, RC ) + ! *** INTERNAL SUBROUTINE *** + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K(0:N,0:N,1:N) + REAL(8), INTENT(IN) :: C(0:N,0:N,1:N) + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LB(2), UB(2) + INTEGER, INTENT(IN) :: P, Q + REAL(8), INTENT(OUT) :: DXDP, DYDP + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LB(1):UB(1),LB(2):UB(2)) + REAL(4), INTENT(IN), OPTIONAL :: X4(LB(1):UB(1),LB(2):UB(2)) + REAL(4), INTENT(IN), OPTIONAL :: Y4(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(IN), OPTIONAL :: X8(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(IN), OPTIONAL :: Y8(LB(1):UB(1),LB(2):UB(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + LOGICAL, PARAMETER :: DEBUG = .FALSE. + CHARACTER(64) :: FSTR + LOGICAL :: COMP_M, TYPE_R4, TYPE_R8 + INTEGER :: IHEM + INTEGER :: NP, NQ, LBP, LBQ, UBP, UBQ, P0, Q0 + INTEGER :: ISTAT=0, I, L, II, NI, II0, IIN + INTEGER :: KP(0:N), KQ(0:N) + LOGICAL :: MP(0:N) + REAL(8) :: XP(0:N) + REAL(8) :: YP(0:N) + REAL(8) :: UP(0:N) + REAL(8) :: VP(0:N) + REAL(8) :: X0, Y0, LON0, LAT0, C0 + REAL(8) :: D1DP, D2DP + ! + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + TYPE_R4 = PRESENT(X4).AND.PRESENT(Y4) + TYPE_R8 = PRESENT(X8).AND.PRESENT(Y8) + IF ( .NOT.TYPE_R4.AND..NOT.TYPE_R8 ) THEN + WRITE(0,'(/1A,1A/)') 'DXYDP ERROR -- ', & + 'no input grid coordinates specified' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + IF ( IJG ) THEN + LBP = LB(1); LBQ = LB(2) + UBP = UB(1); UBQ = UB(2) + ELSE + LBP = LB(2); LBQ = LB(1) + UBP = UB(2); UBQ = UB(1) + END IF + + IF ( P.LT.LBP .OR. P.GT.UBP .OR. Q.LT.LBQ .OR. Q.GT.UBQ ) THEN + WRITE(0,'(/1A,/1A,1L2,5I6,/1A,1L2,5I6/)') 'DXYDP ERROR -- '// & + 'input index coordinates outside input array bounds', & + 'DXYDP ERROR -- PTILED,PRANGE,P,LBP,UBP:',PTILED,PRANGE,P,LBP,UBP, & + 'DXYDP ERROR -- QTILED,QRANGE,Q,LBQ,UBQ:',QTILED,QRANGE,Q,LBQ,UBQ + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + P0 = P + Q0 = Q + IF ( MOD(ICLO,2).EQ.0 ) & + P0 = PRANGE(1) + MOD(NP - 1 + MOD(P0 - PRANGE(1) + 1, NP), NP) + IF ( MOD(ICLO,3).EQ.0 ) & + Q0 = QRANGE(1) + MOD(NQ - 1 + MOD(Q0 - QRANGE(1) + 1, NQ), NQ) + IF ( ICLO.EQ.ICLO_TRPL .AND. Q0.GT.QRANGE(2) ) THEN + P0 = PRANGE(2) + PRANGE(1) - P0 + Q0 = 2*QRANGE(2) - Q0 + 1 + END IF + IF ( P0.LT.PRANGE(1) .OR. P0.GT.PRANGE(2) .OR. & + Q0.LT.QRANGE(1) .OR. Q0.GT.QRANGE(2) ) THEN + WRITE(0,'(/1A,/1A,4I6,/1A,4I6/)') 'DXYDP ERROR -- '// & + 'shifted input index coordinates outside allowed range', & + 'DXYDP ERROR -- PRANGE,P,P0:',PRANGE,P,P0, & + 'DXYDP ERROR -- QRANGE,Q,Q0:',QRANGE,Q,Q0 + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + DXDP = ZERO + DYDP = ZERO + COMP_M = PRESENT(MASK) + IF ( COMP_M ) THEN + IF ( IJG ) THEN + IF ( MASK(P0,Q0) ) RETURN + ELSE + IF ( MASK(Q0,P0) ) RETURN + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Compute DX/DP & DY/DP + ! + IF ( MOD(ICLO,2).EQ.0 ) THEN + I = N/2 + ELSE + IF (P0-PRANGE(1).LT.N/2) THEN + I = P0 - PRANGE(1) + ELSE IF (PRANGE(2)-P0.LT.N/2) THEN + I = N + P0 - PRANGE(2) + ELSE + I = N/2 + END IF + END IF + + KP(:) = P + K(:,I,N) + KQ(:) = Q + IF ( .NOT.PTILED ) THEN + IF ( MOD(ICLO,2).EQ.0 ) THEN + KP = PRANGE(1) + MOD(NP - 1 + MOD(KP - PRANGE(1) + 1, NP), NP) + END IF + END IF + + IF ( MINVAL(KP).LT.LBP .OR. MAXVAL(KP).GT.UBP .OR. & + MINVAL(KQ).LT.LBQ .OR. MAXVAL(KQ).GT.UBQ ) THEN + WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DXYDP ERROR -- '// & + 'stencil index coordinates outside array bounds', & + 'DXYDP ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', & + PTILED,PRANGE,P,P0,LBP,UBP,MINVAL(KP),MAXVAL(KP), & + 'DXYDP ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', & + QTILED,QRANGE,Q,Q0,LBQ,UBQ,MINVAL(KQ),MAXVAL(KQ) + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + DO L = 0, N + IF ( IJG ) THEN + IF ( COMP_M ) MP(L) = MASK(KP(L),KQ(L)) + IF ( TYPE_R4 ) THEN + XP(L) = X4(KP(L),KQ(L)) + YP(L) = Y4(KP(L),KQ(L)) + ELSE + XP(L) = X8(KP(L),KQ(L)) + YP(L) = Y8(KP(L),KQ(L)) + END IF + ELSE + IF ( COMP_M ) MP(L) = MASK(KQ(L),KP(L)) + IF ( TYPE_R4 ) THEN + XP(L) = X4(KQ(L),KP(L)) + YP(L) = Y4(KQ(L),KP(L)) + ELSE + XP(L) = X8(KQ(L),KP(L)) + YP(L) = Y8(KQ(L),KP(L)) + END IF + END IF + END DO + + II = I + NI = N + II0 = 0 + IIN = N + IF ( COMP_M ) THEN + DO L = I-1, 0, -1 + IF ( MP(L) ) THEN + MP(0:L) = .TRUE. + EXIT + END IF + END DO + DO L = I+1, N + IF ( MP(L) ) THEN + MP(L:N) = .TRUE. + EXIT + END IF + END DO + II = COUNT(.NOT.MP(0:I)) - 1 + NI = COUNT(.NOT.MP(0:N)) - 1 + II0 = I - II + IIN = II0 + NI + END IF +#ifdef DXYDP_SINGLE_POINT_WIDE_CHANNEL_ERROR + IF ( NI.LE.0 ) THEN + WRITE(0,'(/1A,1A,4I6/)') 'DXYDP ERROR -- ', & + 'single point wide channel not allowed',P,Q,P0,Q0 + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF +#endif - JJ = J - NJ = N - JJ0 = 0 - JJN = N - IF ( COMP_M ) THEN - DO L = J-1, 0, -1 - IF ( MQ(L) ) THEN - MQ(0:L) = .TRUE. - EXIT - END IF - END DO - DO L = J+1, N - IF ( MQ(L) ) THEN - MQ(L:N) = .TRUE. - EXIT - END IF - END DO - JJ = COUNT(.NOT.MQ(0:J)) - 1 - NJ = COUNT(.NOT.MQ(0:N)) - 1 - JJ0 = J - JJ - JJN = JJ0 + NJ + IF ( NI.GT.0 ) THEN + IF ( LLG ) THEN +#define DXYDP_USE_SPLX +#ifdef DXYDP_USE_SPLX + IF ( IJG ) THEN + IF ( TYPE_R4 ) THEN + X0 = X4(P,Q); Y0 = Y4(P,Q); + ELSE + X0 = X8(P,Q); Y0 = Y8(P,Q); + END IF + ELSE + IF ( TYPE_R4 ) THEN + X0 = X4(Q,P); Y0 = Y4(Q,P); + ELSE + X0 = X8(Q,P); Y0 = Y8(Q,P); + END IF END IF + IHEM = 1; IF (MAXVAL(YP(II0:IIN)).LT.ZERO) IHEM = -1; + LON0 = ZERO; LAT0 = SIGN(D90,REAL(IHEM,8)); + C0 = D90 - ABS(Y0) + CALL W3SPLX(LON0,LAT0,C0,XP(II0:IIN),YP(II0:IIN), & + UP(II0:IIN),VP(II0:IIN)) + D1DP = DOT_PRODUCT(C(0:NI,II,NI),UP(II0:IIN)) + D2DP = DOT_PRODUCT(C(0:NI,II,NI),VP(II0:IIN)) + CALL SPDDP(LON0,C0,IHEM,X0,Y0,D1DP,D2DP,DXDP,DYDP) +#else + DXDP = DOT_PRODUCT(C(0:NI,II,NI),XP(II0:IIN)) + DYDP = DOT_PRODUCT(C(0:NI,II,NI),YP(II0:IIN)) +#endif + ELSE !.NOT.LLG + DXDP = DOT_PRODUCT(C(0:NI,II,NI),XP(II0:IIN)) + DYDP = DOT_PRODUCT(C(0:NI,II,NI),YP(II0:IIN)) + END IF !.NOT.LLG + IF ( DEBUG ) THEN + WRITE(FSTR,'(A,I0,A,I0,A)') & + '(/1A,12I8,5(/1A,2E16.8),/1A,', & + NI+1,'I16,3(/1A,',NI+1,'E16.8))' + WRITE(*,TRIM(FSTR)) & + 'DXYDP -- PRANGE,QRANGE,P,Q,P0,Q0,NI,II,II0,IIN:',& + PRANGE,QRANGE,P,Q,P0,Q0,NI,II,II0,IIN, & + 'DXYDP -- X0, Y0:',X0,Y0, & + 'DXYDP -- LON0,LAT0:',LON0,LAT0, & + 'DXYDP -- C0,IHEM:',C0,REAL(IHEM), & + 'DXYDP -- D1DP,D2DP:',D1DP,D2DP, & + 'DXYDP -- DXDP,DYDP:',DXDP,DYDP, & + 'DXYDP -- K:', K(0:NI,II,NI), & + 'DXYDP -- C:', C(0:NI,II,NI), & + 'DXYDP -- XP:',XP(II0:IIN), & + 'DXYDP -- YP:',YP(II0:IIN) + END IF + ELSE +#ifdef DXYDP_SINGLE_POINT_WIDE_CHANNEL_WARNING + WRITE(0,'(/1A,1A,4I6/)') 'DXYDP WARNING -- ', & + 'single point wide channel, DXDP & DYDP set to zero:',P,Q,P0,Q0 +#endif + DXDP = ZERO + DYDP = ZERO + END IF + + END SUBROUTINE DXYDP + !/ + !/ ------------------------------------------------------------------- / + !/ +#define DXYDQ_SINGLE_POINT_WIDE_CHANNEL_ERROR +#undef DXYDQ_SINGLE_POINT_WIDE_CHANNEL_WARNING + SUBROUTINE DXYDQ( N, K, C, IJG, LLG, ICLO, & + PTILED, QTILED, PRANGE, QRANGE, & + LB, UB, P, Q, DXDQ, DYDQ, MASK, & + X4, Y4, X8, Y8, RC ) + ! *** INTERNAL SUBROUTINE *** + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K(0:N,0:N,1:N) + REAL(8), INTENT(IN) :: C(0:N,0:N,1:N) + LOGICAL, INTENT(IN) :: IJG + LOGICAL, INTENT(IN) :: LLG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LB(2), UB(2) + INTEGER, INTENT(IN) :: P, Q + REAL(8), INTENT(OUT) :: DXDQ, DYDQ + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LB(1):UB(1),LB(2):UB(2)) + REAL(4), INTENT(IN), OPTIONAL :: X4(LB(1):UB(1),LB(2):UB(2)) + REAL(4), INTENT(IN), OPTIONAL :: Y4(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(IN), OPTIONAL :: X8(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(IN), OPTIONAL :: Y8(LB(1):UB(1),LB(2):UB(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + LOGICAL, PARAMETER :: DEBUG = .FALSE. + CHARACTER(64) :: FSTR + LOGICAL :: COMP_M, TYPE_R4, TYPE_R8 + INTEGER :: IHEM + INTEGER :: NP, NQ, LBP, LBQ, UBP, UBQ, P0, Q0 + INTEGER :: ISTAT=0, J, L, JJ, NJ, JJ0, JJN + INTEGER :: KP(0:N), KQ(0:N) + LOGICAL :: MQ(0:N) + REAL(8) :: XQ(0:N) + REAL(8) :: YQ(0:N) + REAL(8) :: UQ(0:N) + REAL(8) :: VQ(0:N) + REAL(8) :: X0, Y0, LON0, LAT0, C0 + REAL(8) :: D1DQ, D2DQ + ! + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + TYPE_R4 = PRESENT(X4).AND.PRESENT(Y4) + TYPE_R8 = PRESENT(X8).AND.PRESENT(Y8) + IF ( .NOT.TYPE_R4.AND..NOT.TYPE_R8 ) THEN + WRITE(0,'(/1A,1A/)') 'DXYDQ ERROR -- ', & + 'no input grid coordinates specified' + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + IF ( IJG ) THEN + LBP = LB(1); LBQ = LB(2) + UBP = UB(1); UBQ = UB(2) + ELSE + LBP = LB(2); LBQ = LB(1) + UBP = UB(2); UBQ = UB(1) + END IF + + IF ( P.LT.LBP .OR. P.GT.UBP .OR. Q.LT.LBQ .OR. Q.GT.UBQ ) THEN + WRITE(0,'(/1A,/1A,1L2,5I6,/1A,1L2,5I6/)') 'DXYDQ ERROR -- '// & + 'input index coordinates outside input array bounds', & + 'DXYDQ ERROR -- PTILED,PRANGE,P,LBP,UBP:',PTILED,PRANGE,P,LBP,UBP, & + 'DXYDQ ERROR -- QTILED,QRANGE,Q,LBQ,UBQ:',QTILED,QRANGE,Q,LBQ,UBQ + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + P0 = P + Q0 = Q + IF ( MOD(ICLO,2).EQ.0 ) & + P0 = PRANGE(1) + MOD(NP - 1 + MOD(P0 - PRANGE(1) + 1, NP), NP) + IF ( MOD(ICLO,3).EQ.0 ) & + Q0 = QRANGE(1) + MOD(NQ - 1 + MOD(Q0 - QRANGE(1) + 1, NQ), NQ) + IF ( ICLO.EQ.ICLO_TRPL .AND. Q0.GT.QRANGE(2) ) THEN + P0 = PRANGE(2) + PRANGE(1) - P0 + Q0 = 2*QRANGE(2) - Q0 + 1 + END IF + IF ( P0.LT.PRANGE(1) .OR. P0.GT.PRANGE(2) .OR. & + Q0.LT.QRANGE(1) .OR. Q0.GT.QRANGE(2) ) THEN + WRITE(0,'(/1A,/1A,4I6,/1A,4I6/)') 'DXYDQ ERROR -- '// & + 'shifted input index coordinates outside allowed range', & + 'DXYDQ ERROR -- PRANGE,P,P0:',PRANGE,P,P0, & + 'DXYDQ ERROR -- QRANGE,Q,Q0:',QRANGE,Q,Q0 + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + DXDQ = ZERO + DYDQ = ZERO + COMP_M = PRESENT(MASK) + IF ( COMP_M ) THEN + IF ( IJG ) THEN + IF ( MASK(P0,Q0) ) RETURN + ELSE + IF ( MASK(Q0,P0) ) RETURN + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Compute DX/DQ & DY/DQ + ! + IF ( MOD(ICLO,3).EQ.0 ) THEN + J = N/2 + ELSE IF ( ICLO.EQ.ICLO_TRPL ) THEN + IF (Q0-QRANGE(1).LT.N/2) THEN + J = Q0 - QRANGE(1) + ELSE + J = N/2 + END IF + ELSE + IF (Q0-QRANGE(1).LT.N/2) THEN + J = Q0 - QRANGE(1) + ELSE IF (QRANGE(2)-Q0.LT.N/2) THEN + J = N + Q0 - QRANGE(2) + ELSE + J = N/2 + END IF + END IF + + KP(:) = P + KQ(:) = Q + K(:,J,N) + IF ( .NOT.QTILED ) THEN + IF ( MOD(ICLO,3).EQ.0 ) THEN + KQ = QRANGE(1) + MOD(NQ - 1 + MOD(KQ - QRANGE(1) + 1, NQ), NQ) + END IF + IF ( ICLO.EQ.ICLO_TRPL .AND. .NOT.PTILED ) THEN + WHERE ( KQ.GT.QRANGE(2) ) + KP = PRANGE(2) + PRANGE(1) - KP + KQ = 2*QRANGE(2) - KQ + 1 + END WHERE + END IF + END IF + + IF ( MINVAL(KP).LT.LBP .OR. MAXVAL(KP).GT.UBP .OR. & + MINVAL(KQ).LT.LBQ .OR. MAXVAL(KQ).GT.UBQ ) THEN + WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DXYDQ ERROR -- '// & + 'stencil index coordinates outside array bounds', & + 'DXYDQ ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', & + PTILED,PRANGE,P,P0,LBP,UBP,MINVAL(KP),MAXVAL(KP), & + 'DXYDQ ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', & + QTILED,QRANGE,Q,Q0,LBQ,UBQ,MINVAL(KQ),MAXVAL(KQ) + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + DO L = 0, N + IF ( IJG ) THEN + IF ( COMP_M ) MQ(L) = MASK(KP(L),KQ(L)) + IF ( TYPE_R4 ) THEN + XQ(L) = X4(KP(L),KQ(L)) + YQ(L) = Y4(KP(L),KQ(L)) + ELSE + XQ(L) = X8(KP(L),KQ(L)) + YQ(L) = Y8(KP(L),KQ(L)) + END IF + ELSE + IF ( COMP_M ) MQ(L) = MASK(KQ(L),KP(L)) + IF ( TYPE_R4 ) THEN + XQ(L) = X4(KQ(L),KP(L)) + YQ(L) = Y4(KQ(L),KP(L)) + ELSE + XQ(L) = X8(KQ(L),KP(L)) + YQ(L) = Y8(KQ(L),KP(L)) + END IF + END IF + END DO + + JJ = J + NJ = N + JJ0 = 0 + JJN = N + IF ( COMP_M ) THEN + DO L = J-1, 0, -1 + IF ( MQ(L) ) THEN + MQ(0:L) = .TRUE. + EXIT + END IF + END DO + DO L = J+1, N + IF ( MQ(L) ) THEN + MQ(L:N) = .TRUE. + EXIT + END IF + END DO + JJ = COUNT(.NOT.MQ(0:J)) - 1 + NJ = COUNT(.NOT.MQ(0:N)) - 1 + JJ0 = J - JJ + JJN = JJ0 + NJ + END IF #ifdef DXYDQ_SINGLE_POINT_WIDE_CHANNEL_ERROR - IF ( NJ.LE.0 ) THEN - WRITE(0,'(/1A,1A,4I6/)') 'DXYDQ ERROR -- ', & - 'single point wide channel not allowed',P,Q,P0,Q0 - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF + IF ( NJ.LE.0 ) THEN + WRITE(0,'(/1A,1A,4I6/)') 'DXYDQ ERROR -- ', & + 'single point wide channel not allowed',P,Q,P0,Q0 + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF #endif - IF ( NJ.GT.0 ) THEN - IF ( LLG ) THEN + IF ( NJ.GT.0 ) THEN + IF ( LLG ) THEN #define DXYDQ_USE_SPLX #ifdef DXYDQ_USE_SPLX - IF ( IJG ) THEN - IF ( TYPE_R4 ) THEN - X0 = X4(P,Q); Y0 = Y4(P,Q); - ELSE - X0 = X8(P,Q); Y0 = Y8(P,Q); - END IF - ELSE - IF ( TYPE_R4 ) THEN - X0 = X4(Q,P); Y0 = Y4(Q,P); - ELSE - X0 = X8(Q,P); Y0 = Y8(Q,P); - END IF - END IF - IHEM = 1; IF (MAXVAL(YQ(JJ0:JJN)).LT.ZERO) IHEM = -1; - LON0 = ZERO; LAT0 = SIGN(D90,REAL(IHEM,8)); - C0 = D90 - ABS(Y0) - CALL W3SPLX(LON0,LAT0,C0,XQ(JJ0:JJN),YQ(JJ0:JJN), & - UQ(JJ0:JJN),VQ(JJ0:JJN)) - D1DQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),UQ(JJ0:JJN)) - D2DQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),VQ(JJ0:JJN)) - CALL SPDDQ(LON0,C0,IHEM,X0,Y0,D1DQ,D2DQ,DXDQ,DYDQ) + IF ( IJG ) THEN + IF ( TYPE_R4 ) THEN + X0 = X4(P,Q); Y0 = Y4(P,Q); + ELSE + X0 = X8(P,Q); Y0 = Y8(P,Q); + END IF + ELSE + IF ( TYPE_R4 ) THEN + X0 = X4(Q,P); Y0 = Y4(Q,P); + ELSE + X0 = X8(Q,P); Y0 = Y8(Q,P); + END IF + END IF + IHEM = 1; IF (MAXVAL(YQ(JJ0:JJN)).LT.ZERO) IHEM = -1; + LON0 = ZERO; LAT0 = SIGN(D90,REAL(IHEM,8)); + C0 = D90 - ABS(Y0) + CALL W3SPLX(LON0,LAT0,C0,XQ(JJ0:JJN),YQ(JJ0:JJN), & + UQ(JJ0:JJN),VQ(JJ0:JJN)) + D1DQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),UQ(JJ0:JJN)) + D2DQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),VQ(JJ0:JJN)) + CALL SPDDQ(LON0,C0,IHEM,X0,Y0,D1DQ,D2DQ,DXDQ,DYDQ) #else - DXDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),XQ(JJ0:JJN)) - DYDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),YQ(JJ0:JJN)) + DXDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),XQ(JJ0:JJN)) + DYDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),YQ(JJ0:JJN)) #endif - ELSE !.NOT.LLG - DXDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),XQ(JJ0:JJN)) - DYDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),YQ(JJ0:JJN)) - END IF !.NOT.LLG - IF ( DEBUG ) THEN - WRITE(FSTR,'(A,I0,A,I0,A)') & - '(/1A,12I8,5(/1A,2E16.8),/1A,', & - NJ+1,'I16,3(/1A,',NJ+1,'E16.8))' - WRITE(*,TRIM(FSTR)) & - 'DXYDQ -- PRANGE,QRANGE,P,Q,P0,Q0,NJ,JJ,JJ0,JJN:',& - PRANGE,QRANGE,P,Q,P0,Q0,NJ,JJ,JJ0,JJN, & - 'DXYDQ -- X0, Y0:',X0,Y0, & - 'DXYDQ -- LON0,LAT0:',LON0,LAT0, & - 'DXYDQ -- C0,IHEM:',C0,REAL(IHEM), & - 'DXYDQ -- D1DQ,D1DQ:',D1DQ,D1DQ, & - 'DXYDQ -- DXDQ,DYDQ:',DXDQ,DYDQ, & - 'DXYDQ -- K:', K(0:NJ,JJ,NJ), & - 'DXYDQ -- C:', C(0:NJ,JJ,NJ), & - 'DXYDQ -- XQ:',XQ(JJ0:JJN), & - 'DXYDQ -- YQ:',YQ(JJ0:JJN) - END IF - ELSE + ELSE !.NOT.LLG + DXDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),XQ(JJ0:JJN)) + DYDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),YQ(JJ0:JJN)) + END IF !.NOT.LLG + IF ( DEBUG ) THEN + WRITE(FSTR,'(A,I0,A,I0,A)') & + '(/1A,12I8,5(/1A,2E16.8),/1A,', & + NJ+1,'I16,3(/1A,',NJ+1,'E16.8))' + WRITE(*,TRIM(FSTR)) & + 'DXYDQ -- PRANGE,QRANGE,P,Q,P0,Q0,NJ,JJ,JJ0,JJN:',& + PRANGE,QRANGE,P,Q,P0,Q0,NJ,JJ,JJ0,JJN, & + 'DXYDQ -- X0, Y0:',X0,Y0, & + 'DXYDQ -- LON0,LAT0:',LON0,LAT0, & + 'DXYDQ -- C0,IHEM:',C0,REAL(IHEM), & + 'DXYDQ -- D1DQ,D1DQ:',D1DQ,D1DQ, & + 'DXYDQ -- DXDQ,DYDQ:',DXDQ,DYDQ, & + 'DXYDQ -- K:', K(0:NJ,JJ,NJ), & + 'DXYDQ -- C:', C(0:NJ,JJ,NJ), & + 'DXYDQ -- XQ:',XQ(JJ0:JJN), & + 'DXYDQ -- YQ:',YQ(JJ0:JJN) + END IF + ELSE #ifdef DXYDQ_SINGLE_POINT_WIDE_CHANNEL_WARNING - WRITE(0,'(/1A,1A,4I6/)') 'DXYDQ WARNING -- ', & - 'single point wide channel, DXDQ & DYDQ set to zero:',P,Q,P0,Q0 + WRITE(0,'(/1A,1A,4I6/)') 'DXYDQ WARNING -- ', & + 'single point wide channel, DXDQ & DYDQ set to zero:',P,Q,P0,Q0 #endif - DXDQ = ZERO - DYDQ = ZERO - END IF - - END SUBROUTINE DXYDQ -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE SPDDP( LAM0, C0, IHEM, LAM, PHI, DXDP, DYDP, & - DLAMDP, DPHIDP ) -! *** INTERNAL SUBROUTINE *** -! Routine to compute polar stereographic transformation of -! grid derivatives dx/dp & dy/dp to dlam/dp & dphi/dp. -! -! mu = lam - lam0 -! nu = pi/4 - alpha*phi/2 -! k0 = cos(c0/2)**2 -! -! dlam/dx = ( 1/(2*R*k0)) * cot(nu) * cos(mu) -! dlam/dy = ( alpha/(2*R*k0)) * cot(nu) * sin(mu) -! dphi/dx = (-alpha/( R*k0)) * cos(nu)^2 * sin(mu) -! dphi/dy = ( 1/( R*k0)) * cos(nu)^2 * cos(mu) -! -! dlam/dp = dx/dp*dlam/dx + dy/dp*dlam/dy -! dphi/dp = dx/dp*dphi/dx + dy/dp*dphi/dy -! dlam/dq = dx/dq*dlam/dx + dy/dq*dlam/dy -! dphi/dq = dx/dq*dphi/dx + dy/dq*dphi/dy -! - REAL(8),INTENT(IN) :: LAM0, C0 - INTEGER,INTENT(IN) :: IHEM - REAL(8),INTENT(IN) :: LAM, PHI - REAL(8),INTENT(IN) :: DXDP, DYDP - REAL(8),INTENT(OUT):: DLAMDP, DPHIDP - -! Local parameters - REAL(8), PARAMETER :: SMALL = 1D-6 - REAL(8) :: K0, A, MU, NU, FAC - REAL(8) :: COSMU, SINMU, COSNU2, COTNU - REAL(8) :: DLAMDX, DLAMDY, DPHIDX, DPHIDY - - K0 = COS(HALF*C0*D2R)**2 - MU = (LAM-LAM0)*D2R - A = SIGN(ONE,REAL(IHEM,8)) - NU = PIO4 - A*HALF*PHI*D2R - NU = SIGN(MAX(SMALL,ABS(NU)),NU) - FAC = R2D*HALF/REARTH/K0 - - COSMU = COS(MU) - SINMU = SIN(MU) - COSNU2 = COS(NU)**2 - COTNU = ONE/TAN(NU) - - DLAMDX = FAC*COTNU*COSMU - DLAMDY = A*FAC*COTNU*SINMU - DPHIDX = -A*TWO*FAC*COSNU2*SINMU - DPHIDY = TWO*FAC*COSNU2*COSMU - - DLAMDP = DXDP*DLAMDX + DYDP*DLAMDY - DPHIDP = DXDP*DPHIDX + DYDP*DPHIDY - - END SUBROUTINE SPDDP -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE SPDDQ( LAM0, C0, IHEM, LAM, PHI, DXDQ, DYDQ, & - DLAMDQ, DPHIDQ ) -! *** INTERNAL SUBROUTINE *** -! Routine to compute polar stereographic transformation of -! grid derivatives dx/dq & dy/dq to dlam/dq & dphi/dq. -! -! mu = lam - lam0 -! nu = pi/4 - alpha*phi/2 -! k0 = cos(c0/2)**2 -! -! dlam/dx = ( 1/(2*R*k0)) * cot(nu) * cos(mu) -! dlam/dy = ( alpha/(2*R*k0)) * cot(nu) * sin(mu) -! dphi/dx = (-alpha/( R*k0)) * cos(nu)^2 * sin(mu) -! dphi/dy = ( 1/( R*k0)) * cos(nu)^2 * cos(mu) -! -! dlam/dp = dx/dp*dlam/dx + dy/dp*dlam/dy -! dphi/dp = dx/dp*dphi/dx + dy/dp*dphi/dy -! dlam/dq = dx/dq*dlam/dx + dy/dq*dlam/dy -! dphi/dq = dx/dq*dphi/dx + dy/dq*dphi/dy -! - REAL(8),INTENT(IN) :: LAM0, C0 - INTEGER,INTENT(IN) :: IHEM - REAL(8),INTENT(IN) :: LAM, PHI - REAL(8),INTENT(IN) :: DXDQ, DYDQ - REAL(8),INTENT(OUT):: DLAMDQ, DPHIDQ - -! Local parameters - REAL(8), PARAMETER :: SMALL = 1D-6 - REAL(8) :: K0, A, MU, NU, FAC - REAL(8) :: COSMU, SINMU, COSNU2, COTNU - REAL(8) :: DLAMDX, DLAMDY, DPHIDX, DPHIDY - - K0 = COS(HALF*C0*D2R)**2 - MU = (LAM-LAM0)*D2R - A = SIGN(ONE,REAL(IHEM,8)) - NU = PIO4 - A*HALF*PHI*D2R - NU = SIGN(MAX(SMALL,ABS(NU)),NU) - FAC = R2D*HALF/REARTH/K0 - - COSMU = COS(MU) - SINMU = SIN(MU) - COSNU2 = COS(NU)**2 - COTNU = ONE/TAN(NU) - - DLAMDX = FAC*COTNU*COSMU - DLAMDY = A*FAC*COTNU*SINMU - DPHIDX = -A*TWO*FAC*COSNU2*SINMU - DPHIDY = TWO*FAC*COSNU2*COSMU - - DLAMDQ = DXDQ*DLAMDX + DYDQ*DLAMDY - DPHIDQ = DXDQ*DPHIDX + DYDQ*DPHIDY - - END SUBROUTINE SPDDQ -!/ -!/ ------------------------------------------------------------------- / -!/ + DXDQ = ZERO + DYDQ = ZERO + END IF + + END SUBROUTINE DXYDQ + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE SPDDP( LAM0, C0, IHEM, LAM, PHI, DXDP, DYDP, & + DLAMDP, DPHIDP ) + ! *** INTERNAL SUBROUTINE *** + ! Routine to compute polar stereographic transformation of + ! grid derivatives dx/dp & dy/dp to dlam/dp & dphi/dp. + ! + ! mu = lam - lam0 + ! nu = pi/4 - alpha*phi/2 + ! k0 = cos(c0/2)**2 + ! + ! dlam/dx = ( 1/(2*R*k0)) * cot(nu) * cos(mu) + ! dlam/dy = ( alpha/(2*R*k0)) * cot(nu) * sin(mu) + ! dphi/dx = (-alpha/( R*k0)) * cos(nu)^2 * sin(mu) + ! dphi/dy = ( 1/( R*k0)) * cos(nu)^2 * cos(mu) + ! + ! dlam/dp = dx/dp*dlam/dx + dy/dp*dlam/dy + ! dphi/dp = dx/dp*dphi/dx + dy/dp*dphi/dy + ! dlam/dq = dx/dq*dlam/dx + dy/dq*dlam/dy + ! dphi/dq = dx/dq*dphi/dx + dy/dq*dphi/dy + ! + REAL(8),INTENT(IN) :: LAM0, C0 + INTEGER,INTENT(IN) :: IHEM + REAL(8),INTENT(IN) :: LAM, PHI + REAL(8),INTENT(IN) :: DXDP, DYDP + REAL(8),INTENT(OUT):: DLAMDP, DPHIDP + + ! Local parameters + REAL(8), PARAMETER :: SMALL = 1D-6 + REAL(8) :: K0, A, MU, NU, FAC + REAL(8) :: COSMU, SINMU, COSNU2, COTNU + REAL(8) :: DLAMDX, DLAMDY, DPHIDX, DPHIDY + + K0 = COS(HALF*C0*D2R)**2 + MU = (LAM-LAM0)*D2R + A = SIGN(ONE,REAL(IHEM,8)) + NU = PIO4 - A*HALF*PHI*D2R + NU = SIGN(MAX(SMALL,ABS(NU)),NU) + FAC = R2D*HALF/REARTH/K0 + + COSMU = COS(MU) + SINMU = SIN(MU) + COSNU2 = COS(NU)**2 + COTNU = ONE/TAN(NU) + + DLAMDX = FAC*COTNU*COSMU + DLAMDY = A*FAC*COTNU*SINMU + DPHIDX = -A*TWO*FAC*COSNU2*SINMU + DPHIDY = TWO*FAC*COSNU2*COSMU + + DLAMDP = DXDP*DLAMDX + DYDP*DLAMDY + DPHIDP = DXDP*DPHIDX + DYDP*DPHIDY + + END SUBROUTINE SPDDP + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE SPDDQ( LAM0, C0, IHEM, LAM, PHI, DXDQ, DYDQ, & + DLAMDQ, DPHIDQ ) + ! *** INTERNAL SUBROUTINE *** + ! Routine to compute polar stereographic transformation of + ! grid derivatives dx/dq & dy/dq to dlam/dq & dphi/dq. + ! + ! mu = lam - lam0 + ! nu = pi/4 - alpha*phi/2 + ! k0 = cos(c0/2)**2 + ! + ! dlam/dx = ( 1/(2*R*k0)) * cot(nu) * cos(mu) + ! dlam/dy = ( alpha/(2*R*k0)) * cot(nu) * sin(mu) + ! dphi/dx = (-alpha/( R*k0)) * cos(nu)^2 * sin(mu) + ! dphi/dy = ( 1/( R*k0)) * cos(nu)^2 * cos(mu) + ! + ! dlam/dp = dx/dp*dlam/dx + dy/dp*dlam/dy + ! dphi/dp = dx/dp*dphi/dx + dy/dp*dphi/dy + ! dlam/dq = dx/dq*dlam/dx + dy/dq*dlam/dy + ! dphi/dq = dx/dq*dphi/dx + dy/dq*dphi/dy + ! + REAL(8),INTENT(IN) :: LAM0, C0 + INTEGER,INTENT(IN) :: IHEM + REAL(8),INTENT(IN) :: LAM, PHI + REAL(8),INTENT(IN) :: DXDQ, DYDQ + REAL(8),INTENT(OUT):: DLAMDQ, DPHIDQ + + ! Local parameters + REAL(8), PARAMETER :: SMALL = 1D-6 + REAL(8) :: K0, A, MU, NU, FAC + REAL(8) :: COSMU, SINMU, COSNU2, COTNU + REAL(8) :: DLAMDX, DLAMDY, DPHIDX, DPHIDY + + K0 = COS(HALF*C0*D2R)**2 + MU = (LAM-LAM0)*D2R + A = SIGN(ONE,REAL(IHEM,8)) + NU = PIO4 - A*HALF*PHI*D2R + NU = SIGN(MAX(SMALL,ABS(NU)),NU) + FAC = R2D*HALF/REARTH/K0 + + COSMU = COS(MU) + SINMU = SIN(MU) + COSNU2 = COS(NU)**2 + COTNU = ONE/TAN(NU) + + DLAMDX = FAC*COTNU*COSMU + DLAMDY = A*FAC*COTNU*SINMU + DPHIDX = -A*TWO*FAC*COSNU2*SINMU + DPHIDY = TWO*FAC*COSNU2*COSMU + + DLAMDQ = DXDQ*DLAMDX + DYDQ*DLAMDY + DPHIDQ = DXDQ*DPHIDX + DYDQ*DPHIDY + + END SUBROUTINE SPDDQ + !/ + !/ ------------------------------------------------------------------- / + !/ #undef DFDPQ_SINGLE_POINT_WIDE_CHANNEL_ERROR #undef DFDPQ_SINGLE_POINT_WIDE_CHANNEL_WARNING - SUBROUTINE DFDPQ( N, K, C, IJG, ICLO, & - PTILED, QTILED, & - PRANGE, QRANGE, & - LB, UB, P, Q, & - F4, F8, DFDP, DFDQ, & - G4, G8, DGDP, DGDQ, & - H4, H8, DHDP, DHDQ, & - NSDP, ISDP, JSDP, CSDP, & - NSDQ, ISDQ, JSDQ, CSDQ, & - MASK, RC ) -! *** INTERNAL SUBROUTINE *** - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K(0:N,0:N,1:N) - REAL(8), INTENT(IN) :: C(0:N,0:N,1:N) - LOGICAL, INTENT(IN) :: IJG - INTEGER, INTENT(IN) :: ICLO - LOGICAL, INTENT(IN) :: PTILED, QTILED - INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) - INTEGER, INTENT(IN) :: LB(2), UB(2) - INTEGER, INTENT(IN) :: P, Q - REAL(4), INTENT(IN), OPTIONAL :: F4(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(IN), OPTIONAL :: F8(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DFDP, DFDQ - REAL(4), INTENT(IN), OPTIONAL :: G4(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(IN), OPTIONAL :: G8(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DGDP, DGDQ - REAL(4), INTENT(IN), OPTIONAL :: H4(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(IN), OPTIONAL :: H8(LB(1):UB(1),LB(2):UB(2)) - REAL(8), INTENT(OUT), OPTIONAL :: DHDP, DHDQ - INTEGER, INTENT(OUT), OPTIONAL :: NSDP - INTEGER, POINTER, OPTIONAL :: ISDP(:), JSDP(:) - REAL(8), POINTER, OPTIONAL :: CSDP(:) - INTEGER, INTENT(OUT), OPTIONAL :: NSDQ - INTEGER, POINTER, OPTIONAL :: ISDQ(:), JSDQ(:) - REAL(8), POINTER, OPTIONAL :: CSDQ(:) - LOGICAL, INTENT(IN), OPTIONAL :: MASK(LB(1):UB(1),LB(2):UB(2)) - INTEGER, INTENT(OUT), OPTIONAL :: RC - -! Local parameters - INTEGER, PARAMETER :: M = 1 ! order of derivative - LOGICAL, PARAMETER :: DEBUG = .FALSE. - CHARACTER(64) :: FSTR - LOGICAL :: COMP_M, COMP_F, COMP_G, COMP_H, TYPE_R4 - LOGICAL :: COMP_CP, COMP_CQ - INTEGER :: NP, NQ, LBP, LBQ, UBP, UBQ, P0, Q0 - INTEGER :: ISTAT=0, I, J, L, II, JJ, NI, NJ, II0, IIN, JJ0, JJN - INTEGER :: KP(0:N), KQ(0:N) - LOGICAL :: MP(0:N), MQ(0:N) - REAL(8) :: FP(0:N), FQ(0:N) - REAL(8) :: GP(0:N), GQ(0:N) - REAL(8) :: HP(0:N), HQ(0:N) - INTEGER :: IP(0:N), IQ(0:N) - INTEGER :: JP(0:N), JQ(0:N) -! -! -------------------------------------------------------------------- / -! 1. Check and setup inputs -! - IF ( PRESENT(RC) ) RC = 0 - - COMP_F = ( PRESENT(F4) .OR. PRESENT(F8) ) .AND. & - PRESENT(DFDP) .AND. PRESENT(DFDQ) - COMP_G = ( PRESENT(G4) .OR. PRESENT(G8) ) .AND. & - PRESENT(DGDP) .AND. PRESENT(DGDQ) - COMP_H = ( PRESENT(H4) .OR. PRESENT(H8) ) .AND. & - PRESENT(DHDP) .AND. PRESENT(DHDQ) - COMP_CP = PRESENT(NSDP) .AND. PRESENT(ISDP) .AND. & - PRESENT(JSDP) .AND. PRESENT(CSDP) - COMP_CQ = PRESENT(NSDQ) .AND. PRESENT(ISDQ) .AND. & - PRESENT(JSDQ) .AND. PRESENT(CSDQ) - IF ( .NOT.COMP_F.AND..NOT.COMP_G.AND..NOT.COMP_H.AND. & - .NOT.COMP_CP.AND..NOT.COMP_CQ ) RETURN - - IF ( COMP_F ) THEN - TYPE_R4 = PRESENT(F4) - ELSE IF ( COMP_G ) THEN - TYPE_R4 = PRESENT(G4) - ELSE IF ( COMP_H ) THEN - TYPE_R4 = PRESENT(H4) - END IF - - NP = PRANGE(2) - PRANGE(1) + 1 - NQ = QRANGE(2) - QRANGE(1) + 1 - + SUBROUTINE DFDPQ( N, K, C, IJG, ICLO, & + PTILED, QTILED, & + PRANGE, QRANGE, & + LB, UB, P, Q, & + F4, F8, DFDP, DFDQ, & + G4, G8, DGDP, DGDQ, & + H4, H8, DHDP, DHDQ, & + NSDP, ISDP, JSDP, CSDP, & + NSDQ, ISDQ, JSDQ, CSDQ, & + MASK, RC ) + ! *** INTERNAL SUBROUTINE *** + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K(0:N,0:N,1:N) + REAL(8), INTENT(IN) :: C(0:N,0:N,1:N) + LOGICAL, INTENT(IN) :: IJG + INTEGER, INTENT(IN) :: ICLO + LOGICAL, INTENT(IN) :: PTILED, QTILED + INTEGER, INTENT(IN) :: PRANGE(2), QRANGE(2) + INTEGER, INTENT(IN) :: LB(2), UB(2) + INTEGER, INTENT(IN) :: P, Q + REAL(4), INTENT(IN), OPTIONAL :: F4(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(IN), OPTIONAL :: F8(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DFDP, DFDQ + REAL(4), INTENT(IN), OPTIONAL :: G4(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(IN), OPTIONAL :: G8(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DGDP, DGDQ + REAL(4), INTENT(IN), OPTIONAL :: H4(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(IN), OPTIONAL :: H8(LB(1):UB(1),LB(2):UB(2)) + REAL(8), INTENT(OUT), OPTIONAL :: DHDP, DHDQ + INTEGER, INTENT(OUT), OPTIONAL :: NSDP + INTEGER, POINTER, OPTIONAL :: ISDP(:), JSDP(:) + REAL(8), POINTER, OPTIONAL :: CSDP(:) + INTEGER, INTENT(OUT), OPTIONAL :: NSDQ + INTEGER, POINTER, OPTIONAL :: ISDQ(:), JSDQ(:) + REAL(8), POINTER, OPTIONAL :: CSDQ(:) + LOGICAL, INTENT(IN), OPTIONAL :: MASK(LB(1):UB(1),LB(2):UB(2)) + INTEGER, INTENT(OUT), OPTIONAL :: RC + + ! Local parameters + INTEGER, PARAMETER :: M = 1 ! order of derivative + LOGICAL, PARAMETER :: DEBUG = .FALSE. + CHARACTER(64) :: FSTR + LOGICAL :: COMP_M, COMP_F, COMP_G, COMP_H, TYPE_R4 + LOGICAL :: COMP_CP, COMP_CQ + INTEGER :: NP, NQ, LBP, LBQ, UBP, UBQ, P0, Q0 + INTEGER :: ISTAT=0, I, J, L, II, JJ, NI, NJ, II0, IIN, JJ0, JJN + INTEGER :: KP(0:N), KQ(0:N) + LOGICAL :: MP(0:N), MQ(0:N) + REAL(8) :: FP(0:N), FQ(0:N) + REAL(8) :: GP(0:N), GQ(0:N) + REAL(8) :: HP(0:N), HQ(0:N) + INTEGER :: IP(0:N), IQ(0:N) + INTEGER :: JP(0:N), JQ(0:N) + ! + ! -------------------------------------------------------------------- / + ! 1. Check and setup inputs + ! + IF ( PRESENT(RC) ) RC = 0 + + COMP_F = ( PRESENT(F4) .OR. PRESENT(F8) ) .AND. & + PRESENT(DFDP) .AND. PRESENT(DFDQ) + COMP_G = ( PRESENT(G4) .OR. PRESENT(G8) ) .AND. & + PRESENT(DGDP) .AND. PRESENT(DGDQ) + COMP_H = ( PRESENT(H4) .OR. PRESENT(H8) ) .AND. & + PRESENT(DHDP) .AND. PRESENT(DHDQ) + COMP_CP = PRESENT(NSDP) .AND. PRESENT(ISDP) .AND. & + PRESENT(JSDP) .AND. PRESENT(CSDP) + COMP_CQ = PRESENT(NSDQ) .AND. PRESENT(ISDQ) .AND. & + PRESENT(JSDQ) .AND. PRESENT(CSDQ) + IF ( .NOT.COMP_F.AND..NOT.COMP_G.AND..NOT.COMP_H.AND. & + .NOT.COMP_CP.AND..NOT.COMP_CQ ) RETURN + + IF ( COMP_F ) THEN + TYPE_R4 = PRESENT(F4) + ELSE IF ( COMP_G ) THEN + TYPE_R4 = PRESENT(G4) + ELSE IF ( COMP_H ) THEN + TYPE_R4 = PRESENT(H4) + END IF + + NP = PRANGE(2) - PRANGE(1) + 1 + NQ = QRANGE(2) - QRANGE(1) + 1 + + IF ( IJG ) THEN + LBP = LB(1); LBQ = LB(2) + UBP = UB(1); UBQ = UB(2) + ELSE + LBP = LB(2); LBQ = LB(1) + UBP = UB(2); UBQ = UB(1) + END IF + + IF ( P.LT.LBP .OR. P.GT.UBP .OR. Q.LT.LBQ .OR. Q.GT.UBQ ) THEN + WRITE(0,'(/1A,/1A,1L2,5I6,/1A,1L2,5I6/)') 'DFDPQ ERROR -- '// & + 'input index coordinates outside input array bounds', & + 'DFDPQ ERROR -- PTILED,PRANGE,P,LBP,UBP:',PTILED,PRANGE,P,LBP,UBP, & + 'DFDPQ ERROR -- QTILED,QRANGE,Q,LBQ,UBQ:',QTILED,QRANGE,Q,LBQ,UBQ + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + P0 = P + Q0 = Q + IF ( MOD(ICLO,2).EQ.0 ) & + P0 = PRANGE(1) + MOD(NP - 1 + MOD(P0 - PRANGE(1) + 1, NP), NP) + IF ( MOD(ICLO,3).EQ.0 ) & + Q0 = QRANGE(1) + MOD(NQ - 1 + MOD(Q0 - QRANGE(1) + 1, NQ), NQ) + IF ( ICLO.EQ.ICLO_TRPL .AND. Q0.GT.QRANGE(2) ) THEN + P0 = PRANGE(2) + PRANGE(1) - P0 + Q0 = 2*QRANGE(2) - Q0 + 1 + END IF + IF ( P0.LT.PRANGE(1) .OR. P0.GT.PRANGE(2) .OR. & + Q0.LT.QRANGE(1) .OR. Q0.GT.QRANGE(2) ) THEN + WRITE(0,'(/1A,/1A,4I6,/1A,4I6/)') 'DFDPQ ERROR -- '// & + 'shifted input index coordinates outside allowed range', & + 'DFDPQ ERROR -- PRANGE,P,P0:',PRANGE,P,P0, & + 'DFDPQ ERROR -- QRANGE,Q,Q0:',QRANGE,Q,Q0 + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) + END IF + END IF + + COMP_M = PRESENT(MASK) + IF ( COMP_M ) THEN IF ( IJG ) THEN - LBP = LB(1); LBQ = LB(2) - UBP = UB(1); UBQ = UB(2) - ELSE - LBP = LB(2); LBQ = LB(1) - UBP = UB(2); UBQ = UB(1) - END IF - - IF ( P.LT.LBP .OR. P.GT.UBP .OR. Q.LT.LBQ .OR. Q.GT.UBQ ) THEN - WRITE(0,'(/1A,/1A,1L2,5I6,/1A,1L2,5I6/)') 'DFDPQ ERROR -- '// & - 'input index coordinates outside input array bounds', & - 'DFDPQ ERROR -- PTILED,PRANGE,P,LBP,UBP:',PTILED,PRANGE,P,LBP,UBP, & - 'DFDPQ ERROR -- QTILED,QRANGE,Q,LBQ,UBQ:',QTILED,QRANGE,Q,LBQ,UBQ - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - P0 = P - Q0 = Q - IF ( MOD(ICLO,2).EQ.0 ) & - P0 = PRANGE(1) + MOD(NP - 1 + MOD(P0 - PRANGE(1) + 1, NP), NP) - IF ( MOD(ICLO,3).EQ.0 ) & - Q0 = QRANGE(1) + MOD(NQ - 1 + MOD(Q0 - QRANGE(1) + 1, NQ), NQ) - IF ( ICLO.EQ.ICLO_TRPL .AND. Q0.GT.QRANGE(2) ) THEN - P0 = PRANGE(2) + PRANGE(1) - P0 - Q0 = 2*QRANGE(2) - Q0 + 1 - END IF - IF ( P0.LT.PRANGE(1) .OR. P0.GT.PRANGE(2) .OR. & - Q0.LT.QRANGE(1) .OR. Q0.GT.QRANGE(2) ) THEN - WRITE(0,'(/1A,/1A,4I6,/1A,4I6/)') 'DFDPQ ERROR -- '// & - 'shifted input index coordinates outside allowed range', & - 'DFDPQ ERROR -- PRANGE,P,P0:',PRANGE,P,P0, & - 'DFDPQ ERROR -- QRANGE,Q,Q0:',QRANGE,Q,Q0 - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF - END IF - - COMP_M = PRESENT(MASK) - IF ( COMP_M ) THEN - IF ( IJG ) THEN - IF ( MASK(P0,Q0) ) RETURN - ELSE - IF ( MASK(Q0,P0) ) RETURN - END IF - END IF -! -! -------------------------------------------------------------------- / -! 2. Compute DF/DP -! - IF ( COMP_F.OR.COMP_G.OR.COMP_H.OR.COMP_CP ) THEN + IF ( MASK(P0,Q0) ) RETURN + ELSE + IF ( MASK(Q0,P0) ) RETURN + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Compute DF/DP + ! + IF ( COMP_F.OR.COMP_G.OR.COMP_H.OR.COMP_CP ) THEN IF ( MOD(ICLO,2).EQ.0 ) THEN - I = N/2 + I = N/2 + ELSE + IF (P0-PRANGE(1).LT.N/2) THEN + I = P0 - PRANGE(1) + ELSE IF (PRANGE(2)-P0.LT.N/2) THEN + I = N + P0 - PRANGE(2) ELSE - IF (P0-PRANGE(1).LT.N/2) THEN - I = P0 - PRANGE(1) - ELSE IF (PRANGE(2)-P0.LT.N/2) THEN - I = N + P0 - PRANGE(2) - ELSE - I = N/2 - END IF + I = N/2 END IF + END IF KP(:) = P + K(:,I,N) KQ(:) = Q IF ( .NOT.PTILED ) THEN - IF ( MOD(ICLO,2).EQ.0 ) THEN - KP = PRANGE(1) + MOD(NP - 1 + MOD(KP - PRANGE(1) + 1, NP), NP) - END IF + IF ( MOD(ICLO,2).EQ.0 ) THEN + KP = PRANGE(1) + MOD(NP - 1 + MOD(KP - PRANGE(1) + 1, NP), NP) END IF + END IF IF ( MINVAL(KP).LT.LBP .OR. MAXVAL(KP).GT.UBP .OR. & MINVAL(KQ).LT.LBQ .OR. MAXVAL(KQ).GT.UBQ ) THEN - WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DFDPQ ERROR -- '// & - 'stencil index coordinates outside array bounds', & - 'DFDPQ ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', & - PTILED,PRANGE,P,P0,LBP,UBP,MINVAL(KP),MAXVAL(KP), & - 'DFDPQ ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', & - QTILED,QRANGE,Q,Q0,LBQ,UBQ,MINVAL(KQ),MAXVAL(KQ) - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF + WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DFDPQ ERROR -- '// & + 'stencil index coordinates outside array bounds', & + 'DFDPQ ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', & + PTILED,PRANGE,P,P0,LBP,UBP,MINVAL(KP),MAXVAL(KP), & + 'DFDPQ ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', & + QTILED,QRANGE,Q,Q0,LBQ,UBQ,MINVAL(KQ),MAXVAL(KQ) + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) END IF + END IF IF ( COMP_CP ) THEN - IP(:) = P0 + K(:,I,N) - JP(:) = Q0 - IF ( MOD(ICLO,2).EQ.0 ) THEN - IP = PRANGE(1) + MOD(NP - 1 + MOD(IP - PRANGE(1) + 1, NP), NP) - END IF + IP(:) = P0 + K(:,I,N) + JP(:) = Q0 + IF ( MOD(ICLO,2).EQ.0 ) THEN + IP = PRANGE(1) + MOD(NP - 1 + MOD(IP - PRANGE(1) + 1, NP), NP) END IF + END IF DO L = 0, N - IF ( IJG ) THEN - IF ( COMP_M ) MP(L) = MASK(KP(L),KQ(L)) - IF ( TYPE_R4 ) THEN - IF ( COMP_F ) FP(L) = F4(KP(L),KQ(L)) - IF ( COMP_G ) GP(L) = G4(KP(L),KQ(L)) - IF ( COMP_H ) HP(L) = H4(KP(L),KQ(L)) - ELSE - IF ( COMP_F ) FP(L) = F8(KP(L),KQ(L)) - IF ( COMP_G ) GP(L) = G8(KP(L),KQ(L)) - IF ( COMP_H ) HP(L) = H8(KP(L),KQ(L)) - END IF - ELSE - IF ( COMP_M ) MP(L) = MASK(KQ(L),KP(L)) - IF ( TYPE_R4 ) THEN - IF ( COMP_F ) FP(L) = F4(KQ(L),KP(L)) - IF ( COMP_G ) GP(L) = G4(KQ(L),KP(L)) - IF ( COMP_H ) HP(L) = H4(KQ(L),KP(L)) - ELSE - IF ( COMP_F ) FP(L) = F8(KQ(L),KP(L)) - IF ( COMP_G ) GP(L) = G8(KQ(L),KP(L)) - IF ( COMP_H ) HP(L) = H8(KQ(L),KP(L)) - END IF - END IF - END DO + IF ( IJG ) THEN + IF ( COMP_M ) MP(L) = MASK(KP(L),KQ(L)) + IF ( TYPE_R4 ) THEN + IF ( COMP_F ) FP(L) = F4(KP(L),KQ(L)) + IF ( COMP_G ) GP(L) = G4(KP(L),KQ(L)) + IF ( COMP_H ) HP(L) = H4(KP(L),KQ(L)) + ELSE + IF ( COMP_F ) FP(L) = F8(KP(L),KQ(L)) + IF ( COMP_G ) GP(L) = G8(KP(L),KQ(L)) + IF ( COMP_H ) HP(L) = H8(KP(L),KQ(L)) + END IF + ELSE + IF ( COMP_M ) MP(L) = MASK(KQ(L),KP(L)) + IF ( TYPE_R4 ) THEN + IF ( COMP_F ) FP(L) = F4(KQ(L),KP(L)) + IF ( COMP_G ) GP(L) = G4(KQ(L),KP(L)) + IF ( COMP_H ) HP(L) = H4(KQ(L),KP(L)) + ELSE + IF ( COMP_F ) FP(L) = F8(KQ(L),KP(L)) + IF ( COMP_G ) GP(L) = G8(KQ(L),KP(L)) + IF ( COMP_H ) HP(L) = H8(KQ(L),KP(L)) + END IF + END IF + END DO II = I NI = N II0 = 0 IIN = N IF ( COMP_M ) THEN - DO L = I-1, 0, -1 - IF ( MP(L) ) THEN - MP(0:L) = .TRUE. - EXIT - END IF - END DO - DO L = I+1, N - IF ( MP(L) ) THEN - MP(L:N) = .TRUE. - EXIT - END IF - END DO - II = COUNT(.NOT.MP(0:I)) - 1 - NI = COUNT(.NOT.MP(0:N)) - 1 - II0 = I - II - IIN = II0 + NI - END IF + DO L = I-1, 0, -1 + IF ( MP(L) ) THEN + MP(0:L) = .TRUE. + EXIT + END IF + END DO + DO L = I+1, N + IF ( MP(L) ) THEN + MP(L:N) = .TRUE. + EXIT + END IF + END DO + II = COUNT(.NOT.MP(0:I)) - 1 + NI = COUNT(.NOT.MP(0:N)) - 1 + II0 = I - II + IIN = II0 + NI + END IF #ifdef DFDPQ_SINGLE_POINT_WIDE_CHANNEL_ERROR IF ( NI.LE.0 ) THEN - WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ ERROR -- ', & - 'DFDP -- single point wide channel not allowed',P,Q,P0,Q0 - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF + WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ ERROR -- ', & + 'DFDP -- single point wide channel not allowed',P,Q,P0,Q0 + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) END IF + END IF #endif IF ( NI.GT.0 ) THEN - IF ( COMP_F ) DFDP = DOT_PRODUCT(C(0:NI,II,NI),FP(II0:IIN)) - IF ( COMP_G ) DGDP = DOT_PRODUCT(C(0:NI,II,NI),GP(II0:IIN)) - IF ( COMP_H ) DHDP = DOT_PRODUCT(C(0:NI,II,NI),HP(II0:IIN)) - IF ( COMP_CP ) THEN - IF ( ASSOCIATED(ISDP) ) DEALLOCATE(ISDP) - IF ( ASSOCIATED(JSDP) ) DEALLOCATE(JSDP) - IF ( ASSOCIATED(CSDP) ) DEALLOCATE(CSDP) - NSDP = NI+1 - ALLOCATE(ISDP(NSDP),JSDP(NSDP),CSDP(NSDP)) - ISDP(1:NSDP) = IP(II0:IIN) - JSDP(1:NSDP) = JP(II0:IIN) - CSDP(1:NSDP) = C(0:NI,II,NI) - END IF - IF ( DEBUG .AND. COMP_F ) THEN - WRITE(FSTR,'(A,I0,A,I0,A,I0,A)') '(/1A,8I6,E16.8,/1A,',& - NI+1,'I16,/1A,',NI+1,'E16.8,/1A,',NI+1,'E16.8)' - WRITE(*,TRIM(FSTR)) & - 'DFDPQ -- DFDP -- P,Q,P0,Q0,NI,II,II0,IIN,DFDP:',& - P,Q,P0,Q0,NI,II,II0,IIN,DFDP, & - 'DFDPQ -- DFDP -- K:', K(0:NI,II,NI), & - 'DFDPQ -- DFDP -- C:', C(0:NI,II,NI), & - 'DFDPQ -- DFDP -- FP:', FP(II0:IIN) - END IF - ELSE + IF ( COMP_F ) DFDP = DOT_PRODUCT(C(0:NI,II,NI),FP(II0:IIN)) + IF ( COMP_G ) DGDP = DOT_PRODUCT(C(0:NI,II,NI),GP(II0:IIN)) + IF ( COMP_H ) DHDP = DOT_PRODUCT(C(0:NI,II,NI),HP(II0:IIN)) + IF ( COMP_CP ) THEN + IF ( ASSOCIATED(ISDP) ) DEALLOCATE(ISDP) + IF ( ASSOCIATED(JSDP) ) DEALLOCATE(JSDP) + IF ( ASSOCIATED(CSDP) ) DEALLOCATE(CSDP) + NSDP = NI+1 + ALLOCATE(ISDP(NSDP),JSDP(NSDP),CSDP(NSDP)) + ISDP(1:NSDP) = IP(II0:IIN) + JSDP(1:NSDP) = JP(II0:IIN) + CSDP(1:NSDP) = C(0:NI,II,NI) + END IF + IF ( DEBUG .AND. COMP_F ) THEN + WRITE(FSTR,'(A,I0,A,I0,A,I0,A)') '(/1A,8I6,E16.8,/1A,',& + NI+1,'I16,/1A,',NI+1,'E16.8,/1A,',NI+1,'E16.8)' + WRITE(*,TRIM(FSTR)) & + 'DFDPQ -- DFDP -- P,Q,P0,Q0,NI,II,II0,IIN,DFDP:',& + P,Q,P0,Q0,NI,II,II0,IIN,DFDP, & + 'DFDPQ -- DFDP -- K:', K(0:NI,II,NI), & + 'DFDPQ -- DFDP -- C:', C(0:NI,II,NI), & + 'DFDPQ -- DFDP -- FP:', FP(II0:IIN) + END IF + ELSE #ifdef DFDPQ_SINGLE_POINT_WIDE_CHANNEL_WARNING - WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ WARNING -- ', & - 'single point wide channel, DFDP set to zero:',P,Q,P0,Q0 + WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ WARNING -- ', & + 'single point wide channel, DFDP set to zero:',P,Q,P0,Q0 #endif - IF ( COMP_F ) DFDP = ZERO - IF ( COMP_G ) DGDP = ZERO - IF ( COMP_H ) DHDP = ZERO - IF ( COMP_CP ) NSDP = 0 - END IF - - END IF -! -! -------------------------------------------------------------------- / -! 3. Compute DF/DQ -! - IF ( COMP_F.OR.COMP_G.OR.COMP_H.OR.COMP_CQ ) THEN + IF ( COMP_F ) DFDP = ZERO + IF ( COMP_G ) DGDP = ZERO + IF ( COMP_H ) DHDP = ZERO + IF ( COMP_CP ) NSDP = 0 + END IF + + END IF + ! + ! -------------------------------------------------------------------- / + ! 3. Compute DF/DQ + ! + IF ( COMP_F.OR.COMP_G.OR.COMP_H.OR.COMP_CQ ) THEN IF ( MOD(ICLO,3).EQ.0 ) THEN + J = N/2 + ELSE IF ( ICLO.EQ.ICLO_TRPL ) THEN + IF (Q0-QRANGE(1).LT.N/2) THEN + J = Q0 - QRANGE(1) + ELSE J = N/2 - ELSE IF ( ICLO.EQ.ICLO_TRPL ) THEN - IF (Q0-QRANGE(1).LT.N/2) THEN - J = Q0 - QRANGE(1) - ELSE - J = N/2 - END IF + END IF + ELSE + IF (Q0-QRANGE(1).LT.N/2) THEN + J = Q0 - QRANGE(1) + ELSE IF (QRANGE(2)-Q0.LT.N/2) THEN + J = N + Q0 - QRANGE(2) ELSE - IF (Q0-QRANGE(1).LT.N/2) THEN - J = Q0 - QRANGE(1) - ELSE IF (QRANGE(2)-Q0.LT.N/2) THEN - J = N + Q0 - QRANGE(2) - ELSE - J = N/2 - END IF + J = N/2 END IF + END IF KP(:) = P KQ(:) = Q + K(:,J,N) IF ( .NOT.QTILED ) THEN - IF ( MOD(ICLO,3).EQ.0 ) THEN - KQ = QRANGE(1) + MOD(NQ - 1 + MOD(KQ - QRANGE(1) + 1, NQ), NQ) - END IF - IF ( ICLO.EQ.ICLO_TRPL .AND. .NOT.PTILED ) THEN - WHERE ( KQ.GT.QRANGE(2) ) - KP = PRANGE(2) + PRANGE(1) - KP - KQ = 2*QRANGE(2) - KQ + 1 - END WHERE - END IF + IF ( MOD(ICLO,3).EQ.0 ) THEN + KQ = QRANGE(1) + MOD(NQ - 1 + MOD(KQ - QRANGE(1) + 1, NQ), NQ) + END IF + IF ( ICLO.EQ.ICLO_TRPL .AND. .NOT.PTILED ) THEN + WHERE ( KQ.GT.QRANGE(2) ) + KP = PRANGE(2) + PRANGE(1) - KP + KQ = 2*QRANGE(2) - KQ + 1 + END WHERE END IF + END IF IF ( MINVAL(KP).LT.LBP .OR. MAXVAL(KP).GT.UBP .OR. & MINVAL(KQ).LT.LBQ .OR. MAXVAL(KQ).GT.UBQ ) THEN - WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DFDPQ ERROR -- '// & - 'stencil index coordinates outside array bounds', & - 'DFDPQ ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', & - PTILED,PRANGE,P,P0,LBP,UBP,MINVAL(KP),MAXVAL(KP), & - 'DFDPQ ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', & - QTILED,QRANGE,Q,Q0,LBQ,UBQ,MINVAL(KQ),MAXVAL(KQ) - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF + WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DFDPQ ERROR -- '// & + 'stencil index coordinates outside array bounds', & + 'DFDPQ ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', & + PTILED,PRANGE,P,P0,LBP,UBP,MINVAL(KP),MAXVAL(KP), & + 'DFDPQ ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', & + QTILED,QRANGE,Q,Q0,LBQ,UBQ,MINVAL(KQ),MAXVAL(KQ) + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) END IF + END IF IF ( COMP_CQ ) THEN - IQ(:) = P0 - JQ(:) = Q0 + K(:,J,N) - IF ( MOD(ICLO,3).EQ.0 ) THEN - JQ = QRANGE(1) + MOD(NQ - 1 + MOD(JQ - QRANGE(1) + 1, NQ), NQ) - END IF - IF ( ICLO.EQ.ICLO_TRPL ) THEN - WHERE ( JQ.GT.QRANGE(2) ) - IQ = PRANGE(2) + PRANGE(1) - IQ - JQ = 2*QRANGE(2) - JQ + 1 - END WHERE - END IF + IQ(:) = P0 + JQ(:) = Q0 + K(:,J,N) + IF ( MOD(ICLO,3).EQ.0 ) THEN + JQ = QRANGE(1) + MOD(NQ - 1 + MOD(JQ - QRANGE(1) + 1, NQ), NQ) + END IF + IF ( ICLO.EQ.ICLO_TRPL ) THEN + WHERE ( JQ.GT.QRANGE(2) ) + IQ = PRANGE(2) + PRANGE(1) - IQ + JQ = 2*QRANGE(2) - JQ + 1 + END WHERE END IF + END IF DO L = 0, N - IF ( IJG ) THEN - IF ( COMP_M ) MQ(L) = MASK(KP(L),KQ(L)) - IF ( TYPE_R4 ) THEN - IF ( COMP_F ) FQ(L) = F4(KP(L),KQ(L)) - IF ( COMP_G ) GQ(L) = G4(KP(L),KQ(L)) - IF ( COMP_H ) HQ(L) = H4(KP(L),KQ(L)) - ELSE - IF ( COMP_F ) FQ(L) = F8(KP(L),KQ(L)) - IF ( COMP_G ) GQ(L) = G8(KP(L),KQ(L)) - IF ( COMP_H ) HQ(L) = H8(KP(L),KQ(L)) - END IF - ELSE - IF ( COMP_M ) MQ(L) = MASK(KQ(L),KP(L)) - IF ( TYPE_R4 ) THEN - IF ( COMP_F ) FQ(L) = F4(KQ(L),KP(L)) - IF ( COMP_G ) GQ(L) = G4(KQ(L),KP(L)) - IF ( COMP_H ) HQ(L) = H4(KQ(L),KP(L)) - ELSE - IF ( COMP_F ) FQ(L) = F8(KQ(L),KP(L)) - IF ( COMP_G ) GQ(L) = G8(KQ(L),KP(L)) - IF ( COMP_H ) HQ(L) = H8(KQ(L),KP(L)) - END IF - END IF - END DO + IF ( IJG ) THEN + IF ( COMP_M ) MQ(L) = MASK(KP(L),KQ(L)) + IF ( TYPE_R4 ) THEN + IF ( COMP_F ) FQ(L) = F4(KP(L),KQ(L)) + IF ( COMP_G ) GQ(L) = G4(KP(L),KQ(L)) + IF ( COMP_H ) HQ(L) = H4(KP(L),KQ(L)) + ELSE + IF ( COMP_F ) FQ(L) = F8(KP(L),KQ(L)) + IF ( COMP_G ) GQ(L) = G8(KP(L),KQ(L)) + IF ( COMP_H ) HQ(L) = H8(KP(L),KQ(L)) + END IF + ELSE + IF ( COMP_M ) MQ(L) = MASK(KQ(L),KP(L)) + IF ( TYPE_R4 ) THEN + IF ( COMP_F ) FQ(L) = F4(KQ(L),KP(L)) + IF ( COMP_G ) GQ(L) = G4(KQ(L),KP(L)) + IF ( COMP_H ) HQ(L) = H4(KQ(L),KP(L)) + ELSE + IF ( COMP_F ) FQ(L) = F8(KQ(L),KP(L)) + IF ( COMP_G ) GQ(L) = G8(KQ(L),KP(L)) + IF ( COMP_H ) HQ(L) = H8(KQ(L),KP(L)) + END IF + END IF + END DO JJ = J NJ = N JJ0 = 0 JJN = N IF ( COMP_M ) THEN - DO L = J-1, 0, -1 - IF ( MQ(L) ) THEN - MQ(0:L) = .TRUE. - EXIT - END IF - END DO - DO L = J+1, N - IF ( MQ(L) ) THEN - MQ(L:N) = .TRUE. - EXIT - END IF - END DO - JJ = COUNT(.NOT.MQ(0:J)) - 1 - NJ = COUNT(.NOT.MQ(0:N)) - 1 - JJ0 = J - JJ - JJN = JJ0 + NJ - END IF + DO L = J-1, 0, -1 + IF ( MQ(L) ) THEN + MQ(0:L) = .TRUE. + EXIT + END IF + END DO + DO L = J+1, N + IF ( MQ(L) ) THEN + MQ(L:N) = .TRUE. + EXIT + END IF + END DO + JJ = COUNT(.NOT.MQ(0:J)) - 1 + NJ = COUNT(.NOT.MQ(0:N)) - 1 + JJ0 = J - JJ + JJN = JJ0 + NJ + END IF #ifdef DFDPQ_SINGLE_POINT_WIDE_CHANNEL_ERROR IF ( NJ.LE.0 ) THEN - WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ ERROR -- ', & - 'DFDQ -- single point wide channel not allowed',P,Q,P0,Q0 - ISTAT = 1 - IF ( PRESENT(RC) ) THEN - RC = ISTAT - RETURN - ELSE - CALL EXTCDE (ISTAT) - END IF + WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ ERROR -- ', & + 'DFDQ -- single point wide channel not allowed',P,Q,P0,Q0 + ISTAT = 1 + IF ( PRESENT(RC) ) THEN + RC = ISTAT + RETURN + ELSE + CALL EXTCDE (ISTAT) END IF + END IF #endif IF ( NJ.GT.0 ) THEN - IF ( COMP_F ) DFDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),FQ(JJ0:JJN)) - IF ( COMP_G ) DGDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),GQ(JJ0:JJN)) - IF ( COMP_H ) DHDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),HQ(JJ0:JJN)) - IF ( COMP_CQ ) THEN - IF ( ASSOCIATED(ISDQ) ) DEALLOCATE(ISDQ) - IF ( ASSOCIATED(JSDQ) ) DEALLOCATE(JSDQ) - IF ( ASSOCIATED(CSDQ) ) DEALLOCATE(CSDQ) - NSDQ = NJ+1 - ALLOCATE(ISDQ(NSDQ),JSDQ(NSDQ),CSDQ(NSDQ)) - ISDQ(1:NSDQ) = IQ(JJ0:JJN) - JSDQ(1:NSDQ) = JQ(JJ0:JJN) - CSDQ(1:NSDQ) = C(0:NJ,JJ,NJ) - END IF - IF ( DEBUG .AND. COMP_F ) THEN - WRITE(FSTR,'(A,I0,A,I0,A,I0,A)') '(/1A,8I6,E16.8,/1A,',& - NJ+1,'I16,/1A,',NJ+1,'E16.8,/1A,',NJ+1,'E16.8)' - WRITE(*,TRIM(FSTR)) & - 'DFDPQ -- DFDQ -- P,Q,P0,Q0,NJ,JJ,JJ0,JJN,DFDQ:',& - P,Q,P0,Q0,NJ,JJ,JJ0,JJN,DFDQ, & - 'DFDPQ -- DFDQ -- K:', K(0:NJ,JJ,NJ), & - 'DFDPQ -- DFDQ -- C:', C(0:NJ,JJ,NJ), & - 'DFDPQ -- DFDQ -- FQ:', FQ(JJ0:JJN) - END IF - ELSE + IF ( COMP_F ) DFDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),FQ(JJ0:JJN)) + IF ( COMP_G ) DGDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),GQ(JJ0:JJN)) + IF ( COMP_H ) DHDQ = DOT_PRODUCT(C(0:NJ,JJ,NJ),HQ(JJ0:JJN)) + IF ( COMP_CQ ) THEN + IF ( ASSOCIATED(ISDQ) ) DEALLOCATE(ISDQ) + IF ( ASSOCIATED(JSDQ) ) DEALLOCATE(JSDQ) + IF ( ASSOCIATED(CSDQ) ) DEALLOCATE(CSDQ) + NSDQ = NJ+1 + ALLOCATE(ISDQ(NSDQ),JSDQ(NSDQ),CSDQ(NSDQ)) + ISDQ(1:NSDQ) = IQ(JJ0:JJN) + JSDQ(1:NSDQ) = JQ(JJ0:JJN) + CSDQ(1:NSDQ) = C(0:NJ,JJ,NJ) + END IF + IF ( DEBUG .AND. COMP_F ) THEN + WRITE(FSTR,'(A,I0,A,I0,A,I0,A)') '(/1A,8I6,E16.8,/1A,',& + NJ+1,'I16,/1A,',NJ+1,'E16.8,/1A,',NJ+1,'E16.8)' + WRITE(*,TRIM(FSTR)) & + 'DFDPQ -- DFDQ -- P,Q,P0,Q0,NJ,JJ,JJ0,JJN,DFDQ:',& + P,Q,P0,Q0,NJ,JJ,JJ0,JJN,DFDQ, & + 'DFDPQ -- DFDQ -- K:', K(0:NJ,JJ,NJ), & + 'DFDPQ -- DFDQ -- C:', C(0:NJ,JJ,NJ), & + 'DFDPQ -- DFDQ -- FQ:', FQ(JJ0:JJN) + END IF + ELSE #ifdef DFDPQ_SINGLE_POINT_WIDE_CHANNEL_WARNING - WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ WARNING -- ', & - 'single point wide channel, DFDQ set to zero:',P,Q,P0,Q0 + WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ WARNING -- ', & + 'single point wide channel, DFDQ set to zero:',P,Q,P0,Q0 #endif - IF ( COMP_F ) DFDQ = ZERO - IF ( COMP_G ) DGDQ = ZERO - IF ( COMP_H ) DHDQ = ZERO - IF ( COMP_CQ ) NSDQ = 0 - END IF - - END IF - - END SUBROUTINE DFDPQ -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE GET_FDW2( N, M, K, C ) -! *** INTERNAL SUBROUTINE *** - INTEGER,INTENT(IN) :: N, M - INTEGER,INTENT(OUT):: K(0:N,0:N) - REAL(8),INTENT(OUT):: C(0:N,0:N) - INTEGER :: I, J - REAL(8) :: A(0:N), B(0:N,0:M) - - DO I = 0, N - DO J = 0, N - K(J,I) = J-I - A(J) = K(J,I) - END DO - CALL W3FDWT( N, N, M, ZERO, A, B ) - C(0:N,I) = B(0:N,M) - !WRITE(0,'(A,I1,2X,11I16)') 'I=',I,K(0:N,I) - !WRITE(0,'(5X,11E16.8)') C(0:N,I) - END DO - - END SUBROUTINE GET_FDW2 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE GET_FDW3( N, M, K, C ) -! *** INTERNAL SUBROUTINE *** - INTEGER,INTENT(IN) :: N, M - INTEGER,INTENT(OUT):: K(0:N,0:N,1:N) - REAL(8),INTENT(OUT):: C(0:N,0:N,1:N) - INTEGER :: L, I, J - REAL(8) :: A(0:N), B(0:N,0:M) - - DO L = 1, N - !WRITE(0,'(A,I1,2X,11A)') 'L=',L,('----------------',I=0,L) - DO I = 0, L - DO J = 0, L - K(J,I,L) = J-I - A(J) = K(J,I,L) - END DO - CALL W3FDWT( L, N, M, ZERO, A, B ) - C(0:L,I,L) = B(0:L,M) - !WRITE(0,'(A,I1,2X,11I16)') 'I=',I,K(0:L,I,L) - !WRITE(0,'(5X,11E16.8)') C(0:L,I,L) - END DO + IF ( COMP_F ) DFDQ = ZERO + IF ( COMP_G ) DGDQ = ZERO + IF ( COMP_H ) DHDQ = ZERO + IF ( COMP_CQ ) NSDQ = 0 + END IF + + END IF + + END SUBROUTINE DFDPQ + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE GET_FDW2( N, M, K, C ) + ! *** INTERNAL SUBROUTINE *** + INTEGER,INTENT(IN) :: N, M + INTEGER,INTENT(OUT):: K(0:N,0:N) + REAL(8),INTENT(OUT):: C(0:N,0:N) + INTEGER :: I, J + REAL(8) :: A(0:N), B(0:N,0:M) + + DO I = 0, N + DO J = 0, N + K(J,I) = J-I + A(J) = K(J,I) + END DO + CALL W3FDWT( N, N, M, ZERO, A, B ) + C(0:N,I) = B(0:N,M) + !WRITE(0,'(A,I1,2X,11I16)') 'I=',I,K(0:N,I) + !WRITE(0,'(5X,11E16.8)') C(0:N,I) + END DO + + END SUBROUTINE GET_FDW2 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE GET_FDW3( N, M, K, C ) + ! *** INTERNAL SUBROUTINE *** + INTEGER,INTENT(IN) :: N, M + INTEGER,INTENT(OUT):: K(0:N,0:N,1:N) + REAL(8),INTENT(OUT):: C(0:N,0:N,1:N) + INTEGER :: L, I, J + REAL(8) :: A(0:N), B(0:N,0:M) + + DO L = 1, N + !WRITE(0,'(A,I1,2X,11A)') 'L=',L,('----------------',I=0,L) + DO I = 0, L + DO J = 0, L + K(J,I,L) = J-I + A(J) = K(J,I,L) END DO + CALL W3FDWT( L, N, M, ZERO, A, B ) + C(0:L,I,L) = B(0:L,M) + !WRITE(0,'(A,I1,2X,11I16)') 'I=',I,K(0:L,I,L) + !WRITE(0,'(5X,11E16.8)') C(0:L,I,L) + END DO + END DO - END SUBROUTINE GET_FDW3 -!/ -!/ ------------------------------------------------------------------- / -!/ -!/ -!/ End Internal Support Routines ===================================== / -!/ -!/ + END SUBROUTINE GET_FDW3 + !/ + !/ ------------------------------------------------------------------- / + !/ + !/ + !/ End Internal Support Routines ===================================== / + !/ + !/ @@ -9618,27 +9618,27 @@ END SUBROUTINE GET_FDW3 #ifndef ENABLE_WW3 -!/ -!/ Local routines for use outside of WW3 ============================= / -!/ - SUBROUTINE EXTCDE(IEXIT) + !/ + !/ Local routines for use outside of WW3 ============================= / + !/ + SUBROUTINE EXTCDE(IEXIT) #ifdef ENABLE_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif - INTEGER, INTENT(IN) :: IEXIT + INTEGER, INTENT(IN) :: IEXIT #ifdef ENABLE_MPI - INTEGER :: IERR_MPI - LOGICAL :: RUN - CALL MPI_INITIALIZED ( RUN, IERR_MPI ) - IF ( RUN ) THEN - CALL MPI_ABORT ( MPI_COMM_WORLD, IEXIT, IERR_MPI ) - END IF + INTEGER :: IERR_MPI + LOGICAL :: RUN + CALL MPI_INITIALIZED ( RUN, IERR_MPI ) + IF ( RUN ) THEN + CALL MPI_ABORT ( MPI_COMM_WORLD, IEXIT, IERR_MPI ) + END IF #endif - CALL EXIT(IEXIT) - END SUBROUTINE EXTCDE -!/ -!/ End local routines for use outside of WW3 ========================= / -!/ + CALL EXIT(IEXIT) + END SUBROUTINE EXTCDE + !/ + !/ End local routines for use outside of WW3 ========================= / + !/ #endif @@ -9648,7 +9648,7 @@ END SUBROUTINE EXTCDE -!/ -!/ End of module W3GSRUMD ============================================ / -!/ - END MODULE W3GSRUMD + !/ + !/ End of module W3GSRUMD ============================================ / + !/ +END MODULE W3GSRUMD diff --git a/model/src/w3idatmd.F90 b/model/src/w3idatmd.F90 index d77831126..83d9af3ee 100644 --- a/model/src/w3idatmd.F90 +++ b/model/src/w3idatmd.F90 @@ -1,7 +1,7 @@ !> @file !> @brief Define data structures to set up wave model input data for !> several models simultaneously. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 !> @@ -9,1104 +9,1095 @@ !> @brief Define data structures to set up wave model input data for !> several models simultaneously. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 !> !/ ------------------------------------------------------------------- / - MODULE W3IDATMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 02-Apr-2004 : Origination. ( version 3.06 ) -!/ 19-Jul-2006 : Adding auxiliary grids. ( version 3.10 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) -!/ (M. Accensi & F. Ardhuin, IFREMER) -!/ 21-Jun-2018 : Add FSWND input for SMC grid. JGLi ( version 6.04 ) -!/ 22-Mar-2021 : Momentum and air density support ( version 7.13 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Define data structures to set up wave model input data for -! several models simultaneously. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NIDATA Int. Public Number of models in array dim. -! IIDATA Int. Public Selected model for output, init. at -1. -! INPUT TYPE Public Basic data structure. -! INPUTS INPUT Public Array of data structures. -! ---------------------------------------------------------------- -! -! All elements of INPUT are aliased to pointers with the same -! name. Some aditional pointer provide previous equivalenced -! parameters. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! TLN I.A. Public Time for water level field. -! TC0/N I.A. Public Times for current fields. -! TW0/N I.A. Public Times for wind fields. -! TDN I.A. Public Time for mud density field. -! TTN I.A. Public Time for mud thickness field. -! TVN I.A. Public Time for mud viscosity field. -! TIN I.A. Public Time for ice field. (concentration) -! TU0/N I.A. Public Times for momentum fields. -! TR0/N I.A. Public Times for air density fields. -! TI1N I.A. Public Time for ice field. (parameter 1) -! TI2N I.A. Public Time for ice field. (parameter 2) -! TI3N I.A. Public Time for ice field. (parameter 3) -! TI4N I.A. Public Time for ice field. (parameter 4) -! TI5N I.A. Public Time for ice field. (parameter 5) -! TnN I.A. Public Time for data types 1-3. -! TDN I.A. Public Time for next data. -! TG0/N I.A. Public Times for grid motion data. -! TFN I.A. Public Array consolidating most above times. -! GA0/N Real Public Norm of grid speed vector. -! GD0/N Real Public Direction of grid speed vector. -! WX0/N R.A. Public Cartesian X and Y wind components -! WY0/N R.A. Public for both times. -! DT0/N R.A. Public Corr. air-sea temperature differences. -! CX0/N R.A. Public Cartesian X and Y current components -! CY0/N R.A. Public for both times. -! WLEV R.A. Public Next water level field. -! ICEI R.A. Public Ice concentrations. -! UX0/N R.A. Public Cartesian X and Y momentum components -! UY0/N R.A. Public for both times. -! RH0/N R.A. Public Air density for both times -! BERGI R.A. Public Iceberg damping coefficient -! IINIT Log. Public Flag for array initialization. -! FLLEV Log. Public Flag for water level input. -! FLCUR Log. Public Flag for current input. -! FLWIND Log. Public Flag for wind input. -! FLICE Log. Public Flag for ice input. +MODULE W3IDATMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 02-Apr-2004 : Origination. ( version 3.06 ) + !/ 19-Jul-2006 : Adding auxiliary grids. ( version 3.10 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) + !/ (M. Accensi & F. Ardhuin, IFREMER) + !/ 21-Jun-2018 : Add FSWND input for SMC grid. JGLi ( version 6.04 ) + !/ 22-Mar-2021 : Momentum and air density support ( version 7.13 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Define data structures to set up wave model input data for + ! several models simultaneously. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NIDATA Int. Public Number of models in array dim. + ! IIDATA Int. Public Selected model for output, init. at -1. + ! INPUT TYPE Public Basic data structure. + ! INPUTS INPUT Public Array of data structures. + ! ---------------------------------------------------------------- + ! + ! All elements of INPUT are aliased to pointers with the same + ! name. Some aditional pointer provide previous equivalenced + ! parameters. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! TLN I.A. Public Time for water level field. + ! TC0/N I.A. Public Times for current fields. + ! TW0/N I.A. Public Times for wind fields. + ! TDN I.A. Public Time for mud density field. + ! TTN I.A. Public Time for mud thickness field. + ! TVN I.A. Public Time for mud viscosity field. + ! TIN I.A. Public Time for ice field. (concentration) + ! TU0/N I.A. Public Times for momentum fields. + ! TR0/N I.A. Public Times for air density fields. + ! TI1N I.A. Public Time for ice field. (parameter 1) + ! TI2N I.A. Public Time for ice field. (parameter 2) + ! TI3N I.A. Public Time for ice field. (parameter 3) + ! TI4N I.A. Public Time for ice field. (parameter 4) + ! TI5N I.A. Public Time for ice field. (parameter 5) + ! TnN I.A. Public Time for data types 1-3. + ! TDN I.A. Public Time for next data. + ! TG0/N I.A. Public Times for grid motion data. + ! TFN I.A. Public Array consolidating most above times. + ! GA0/N Real Public Norm of grid speed vector. + ! GD0/N Real Public Direction of grid speed vector. + ! WX0/N R.A. Public Cartesian X and Y wind components + ! WY0/N R.A. Public for both times. + ! DT0/N R.A. Public Corr. air-sea temperature differences. + ! CX0/N R.A. Public Cartesian X and Y current components + ! CY0/N R.A. Public for both times. + ! WLEV R.A. Public Next water level field. + ! ICEI R.A. Public Ice concentrations. + ! UX0/N R.A. Public Cartesian X and Y momentum components + ! UY0/N R.A. Public for both times. + ! RH0/N R.A. Public Air density for both times + ! BERGI R.A. Public Iceberg damping coefficient + ! IINIT Log. Public Flag for array initialization. + ! FLLEV Log. Public Flag for water level input. + ! FLCUR Log. Public Flag for current input. + ! FLWIND Log. Public Flag for wind input. + ! FLICE Log. Public Flag for ice input. #ifdef W3_CESMCOUPLED -! HML R.A. Public Mixed layer depth + ! HML R.A. Public Mixed layer depth #endif -! FLTAUA Log. Public Flag for atmospheric momentum input -! FLRHOA Log. Public Flag for air density input -! INFLAGS1 L.A. Public Array consolidating the above six -! flags, as well as four additional -! data flags. -! INFLAGS2 L.A. Public Like INFLAGS1 but does *not* get changed -! when model reads last record of ice.ww3 -! FLAGSC L.A. Public Coupling or not for input variables -! JFIRST Int Public First index of arrays related to -! input fields. At present this is -! hardwired below. Field-related arrays -! (e.g., INFLAGS1) will be allocated from -! JFIRST:9 (e.g., ALLOCATE(INFLAGS1(JFIRST:9))). -! CXTIDE R.A. Public Tidal constituents of X current component -! CYTIDE R.A. Public Tidal constituents of Y current component -! WLTIDE R.A. Public Tidal constituents of water level -! FLLEVTIDE Log. Public Flag for use of tidal const. in water level input. -! FLCURTIDE Log. Public Flag for use of tidal const. in current input. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3NINP Subr. Public Set number of grids/models. -! W3DIMI Subr. Public Set dimensions of arrays. -! W3SETI Subr. Public Point to selected grid / model. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to proper model grid. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - The number of grids is taken from W3GDATMD, and needs to be -! set first with W3DIMG. -! -! - INFLAGS1 dimensioning is hardwired as INFLAGS1(-7:14) where lowest possible -! value of JFIRST is JFIRST=-7 -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/TIDE Use of tidal constituents -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Module private variable for checking error returns -!/ - INTEGER, PRIVATE :: ISTAT -!/ -!/ Conventional declarations -!/ - INTEGER :: NIDATA = -1, IIDATA = -1 + ! FLTAUA Log. Public Flag for atmospheric momentum input + ! FLRHOA Log. Public Flag for air density input + ! INFLAGS1 L.A. Public Array consolidating the above six + ! flags, as well as four additional + ! data flags. + ! INFLAGS2 L.A. Public Like INFLAGS1 but does *not* get changed + ! when model reads last record of ice.ww3 + ! FLAGSC L.A. Public Coupling or not for input variables + ! JFIRST Int Public First index of arrays related to + ! input fields. At present this is + ! hardwired below. Field-related arrays + ! (e.g., INFLAGS1) will be allocated from + ! JFIRST:9 (e.g., ALLOCATE(INFLAGS1(JFIRST:9))). + ! CXTIDE R.A. Public Tidal constituents of X current component + ! CYTIDE R.A. Public Tidal constituents of Y current component + ! WLTIDE R.A. Public Tidal constituents of water level + ! FLLEVTIDE Log. Public Flag for use of tidal const. in water level input. + ! FLCURTIDE Log. Public Flag for use of tidal const. in current input. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3NINP Subr. Public Set number of grids/models. + ! W3DIMI Subr. Public Set dimensions of arrays. + ! W3SETI Subr. Public Point to selected grid / model. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to proper model grid. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - The number of grids is taken from W3GDATMD, and needs to be + ! set first with W3DIMG. + ! + ! - INFLAGS1 dimensioning is hardwired as INFLAGS1(-7:14) where lowest possible + ! value of JFIRST is JFIRST=-7 + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/TIDE Use of tidal constituents + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + !/ Module private variable for checking error returns + !/ + INTEGER, PRIVATE :: ISTAT + !/ + !/ Conventional declarations + !/ + INTEGER :: NIDATA = -1, IIDATA = -1 - INTEGER :: JFIRST = 1 + INTEGER :: JFIRST = 1 #ifdef W3_TIDE - INTEGER :: NTIDE ! number of tidal constituents - REAL, ALLOCATABLE :: TIDEFREQ(:) + INTEGER :: NTIDE ! number of tidal constituents + REAL, ALLOCATABLE :: TIDEFREQ(:) #endif -!/ -!/ Data structure INPUT -!/ - TYPE, PUBLIC :: INPUT - INTEGER :: TFN(2,-7:10) - INTEGER :: TC0(2) - INTEGER :: TW0(2) - INTEGER :: TU0(2) - INTEGER :: TR0(2) - INTEGER :: TDN(2) - INTEGER :: TG0(2) - REAL :: GA0 - REAL :: GD0 - REAL :: GAN - REAL :: GDN + !/ + !/ Data structure INPUT + !/ + TYPE, PUBLIC :: INPUT + INTEGER :: TFN(2,-7:10) + INTEGER :: TC0(2) + INTEGER :: TW0(2) + INTEGER :: TU0(2) + INTEGER :: TR0(2) + INTEGER :: TDN(2) + INTEGER :: TG0(2) + REAL :: GA0 + REAL :: GD0 + REAL :: GAN + REAL :: GDN #ifdef W3_WRST - REAL, POINTER :: WXNwrst(:,:) - REAL, POINTER :: WYNwrst(:,:) + REAL, POINTER :: WXNwrst(:,:) + REAL, POINTER :: WYNwrst(:,:) #endif - REAL, POINTER :: WX0(:,:) - REAL, POINTER :: WY0(:,:) - REAL, POINTER :: DT0(:,:) - REAL, POINTER :: WXN(:,:) - REAL, POINTER :: WYN(:,:) - REAL, POINTER :: DTN(:,:) - REAL, POINTER :: CX0(:,:) - REAL, POINTER :: CY0(:,:) - REAL, POINTER :: CXN(:,:) - REAL, POINTER :: CYN(:,:) - REAL, POINTER :: WLEV(:,:) - REAL, POINTER :: ICEI(:,:) - REAL, POINTER :: UX0(:,:) - REAL, POINTER :: UY0(:,:) - REAL, POINTER :: UXN(:,:) - REAL, POINTER :: UYN(:,:) - REAL, POINTER :: RH0(:,:) - REAL, POINTER :: RHN(:,:) - REAL, POINTER :: BERGI(:,:) - REAL, POINTER :: MUDT(:,:) - REAL, POINTER :: MUDV(:,:) - REAL, POINTER :: MUDD(:,:) - REAL, POINTER :: ICEP1(:,:) - REAL, POINTER :: ICEP2(:,:) - REAL, POINTER :: ICEP3(:,:) - REAL, POINTER :: ICEP4(:,:) - REAL, POINTER :: ICEP5(:,:) + REAL, POINTER :: WX0(:,:) + REAL, POINTER :: WY0(:,:) + REAL, POINTER :: DT0(:,:) + REAL, POINTER :: WXN(:,:) + REAL, POINTER :: WYN(:,:) + REAL, POINTER :: DTN(:,:) + REAL, POINTER :: CX0(:,:) + REAL, POINTER :: CY0(:,:) + REAL, POINTER :: CXN(:,:) + REAL, POINTER :: CYN(:,:) + REAL, POINTER :: WLEV(:,:) + REAL, POINTER :: ICEI(:,:) + REAL, POINTER :: UX0(:,:) + REAL, POINTER :: UY0(:,:) + REAL, POINTER :: UXN(:,:) + REAL, POINTER :: UYN(:,:) + REAL, POINTER :: RH0(:,:) + REAL, POINTER :: RHN(:,:) + REAL, POINTER :: BERGI(:,:) + REAL, POINTER :: MUDT(:,:) + REAL, POINTER :: MUDV(:,:) + REAL, POINTER :: MUDD(:,:) + REAL, POINTER :: ICEP1(:,:) + REAL, POINTER :: ICEP2(:,:) + REAL, POINTER :: ICEP3(:,:) + REAL, POINTER :: ICEP4(:,:) + REAL, POINTER :: ICEP5(:,:) #ifdef W3_TIDE - REAL, POINTER :: CXTIDE(:,:,:,:) - REAL, POINTER :: CYTIDE(:,:,:,:) - REAL, POINTER :: WLTIDE(:,:,:,:) + REAL, POINTER :: CXTIDE(:,:,:,:) + REAL, POINTER :: CYTIDE(:,:,:,:) + REAL, POINTER :: WLTIDE(:,:,:,:) #endif #ifdef W3_CESMCOUPLED - REAL, POINTER :: HML(:,:) + REAL, POINTER :: HML(:,:) #endif - LOGICAL :: IINIT + LOGICAL :: IINIT #ifdef W3_WRST - LOGICAL :: WRSTIINIT=.FALSE. + LOGICAL :: WRSTIINIT=.FALSE. #endif -! note that if size of INFLAGS1 is changed, then TFLAGS in wminitmd.ftn -! also must be resized. - LOGICAL :: INFLAGS1(-7:14) - LOGICAL :: FLAGSC(-7:14) - LOGICAL :: INFLAGS2(-7:14) - END TYPE INPUT -!/ -!/ Data storage -!/ - TYPE(INPUT), TARGET, ALLOCATABLE :: INPUTS(:) -!/ -!/ Data aliasses for structure INPUT(S) -!/ - INTEGER, POINTER :: TFN(:,:), TLN(:), TC0(:), TCN(:), & - TW0(:), TWN(:), TU0(:), TUN(:), & - TIN(:), TR0(:), TRN(:), T0N(:), & - T1N(:), T2N(:), TDN(:), TG0(:), & - TGN(:), TTN(:), TVN(:), TZN(:), & - TI1(:), TI2(:), TI3(:), TI4(:), TI5(:) - REAL, POINTER :: GA0, GD0, GAN, GDN - REAL, POINTER :: WX0(:,:), WY0(:,:), DT0(:,:), & - WXN(:,:), WYN(:,:), DTN(:,:), & + ! note that if size of INFLAGS1 is changed, then TFLAGS in wminitmd.ftn + ! also must be resized. + LOGICAL :: INFLAGS1(-7:14) + LOGICAL :: FLAGSC(-7:14) + LOGICAL :: INFLAGS2(-7:14) + END TYPE INPUT + !/ + !/ Data storage + !/ + TYPE(INPUT), TARGET, ALLOCATABLE :: INPUTS(:) + !/ + !/ Data aliasses for structure INPUT(S) + !/ + INTEGER, POINTER :: TFN(:,:), TLN(:), TC0(:), TCN(:), & + TW0(:), TWN(:), TU0(:), TUN(:), & + TIN(:), TR0(:), TRN(:), T0N(:), & + T1N(:), T2N(:), TDN(:), TG0(:), & + TGN(:), TTN(:), TVN(:), TZN(:), & + TI1(:), TI2(:), TI3(:), TI4(:), TI5(:) + REAL, POINTER :: GA0, GD0, GAN, GDN + REAL, POINTER :: WX0(:,:), WY0(:,:), DT0(:,:), & + WXN(:,:), WYN(:,:), DTN(:,:), & #ifdef W3_WRST - WXNwrst(:,:),WYNwrst(:,:), & + WXNwrst(:,:),WYNwrst(:,:), & #endif - CX0(:,:), CY0(:,:), CXN(:,:), & - CYN(:,:), WLEV(:,:), ICEI(:,:), & - UX0(:,:), UY0(:,:), UXN(:,:), & - UYN(:,:), RH0(:,:), RHN(:,:), & - BERGI(:,:), MUDT(:,:), MUDV(:,:), & - MUDD(:,:), ICEP1(:,:), ICEP2(:,:), & - ICEP3(:,:), ICEP4(:,:), ICEP5(:,:) + CX0(:,:), CY0(:,:), CXN(:,:), & + CYN(:,:), WLEV(:,:), ICEI(:,:), & + UX0(:,:), UY0(:,:), UXN(:,:), & + UYN(:,:), RH0(:,:), RHN(:,:), & + BERGI(:,:), MUDT(:,:), MUDV(:,:), & + MUDD(:,:), ICEP1(:,:), ICEP2(:,:), & + ICEP3(:,:), ICEP4(:,:), ICEP5(:,:) #ifdef W3_TIDE - REAL, POINTER :: CXTIDE(:,:,:,:), & - CYTIDE(:,:,:,:), WLTIDE(:,:,:,:) + REAL, POINTER :: CXTIDE(:,:,:,:), & + CYTIDE(:,:,:,:), WLTIDE(:,:,:,:) #endif - LOGICAL, POINTER :: IINIT - LOGICAL, POINTER :: INFLAGS1(:), INFLAGS2(:), FLAGSC(:) - LOGICAL, POINTER :: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, & - FLRHOA - LOGICAL, POINTER :: FLMTH, FLMVS, FLMDN - LOGICAL, POINTER :: FLIC1, FLIC2, FLIC3, FLIC4, FLIC5 + LOGICAL, POINTER :: IINIT + LOGICAL, POINTER :: INFLAGS1(:), INFLAGS2(:), FLAGSC(:) + LOGICAL, POINTER :: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, & + FLRHOA + LOGICAL, POINTER :: FLMTH, FLMVS, FLMDN + LOGICAL, POINTER :: FLIC1, FLIC2, FLIC3, FLIC4, FLIC5 #ifdef W3_TIDE - LOGICAL, POINTER :: FLLEVTIDE, FLCURTIDE, & - FLLEVRESI, FLCURRESI + LOGICAL, POINTER :: FLLEVTIDE, FLCURTIDE, & + FLLEVRESI, FLCURRESI #endif #ifdef W3_CESMCOUPLED - REAL , POINTER :: HML(:,:) + REAL , POINTER :: HML(:,:) #endif -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Set up the number of grids to be used. -!> -!> @details Use data stored in NGRIDS in W3GDATMD. -!> -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE W3NINP ( NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 02-Apr-2004 : Origination. ( version 3.06 ) -!/ 19-Jul-2006 : Adding auxiliary grids. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 22-Mar-2021 : Momentum and air density support ( version 7.13 ) -!/ -! 1. Purpose : -! -! Set up the number of grids to be used. -! -! 2. Method : -! -! Use data stored in NGRIDS in W3GDATMD. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program that uses this grid structure. -! -! 6. Error messages : -! -! - Error checks on previous setting of variable NGRIDS. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS, NAUXGR - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Set up the number of grids to be used. + !> + !> @details Use data stored in NGRIDS in W3GDATMD. + !> + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE W3NINP ( NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 02-Apr-2004 : Origination. ( version 3.06 ) + !/ 19-Jul-2006 : Adding auxiliary grids. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 22-Mar-2021 : Momentum and air density support ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Set up the number of grids to be used. + ! + ! 2. Method : + ! + ! Use data stored in NGRIDS in W3GDATMD. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program that uses this grid structure. + ! + ! 6. Error messages : + ! + ! - Error checks on previous setting of variable NGRIDS. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS, NAUXGR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + USE W3SERVMD, ONLY: STRACE #endif -!/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I #ifdef W3_S - CALL STRACE (IENT, 'W3NINP') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3NINP') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) NGRIDS - CALL EXTCDE (1) - END IF -! -! -------------------------------------------------------------------- / -! 2. Set variable and allocate arrays -! - ALLOCATE ( INPUTS(-NAUXGR:NGRIDS), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - NIDATA = NGRIDS -! -! -------------------------------------------------------------------- / -! 3. Initialize parameters -! - DO I=-NAUXGR, NGRIDS - INPUTS(I)%TFN(1,:) = -1 - INPUTS(I)%TFN(2,:) = 0 - INPUTS(I)%TC0(1) = -1 - INPUTS(I)%TC0(2) = 0 - INPUTS(I)%TW0(1) = -1 - INPUTS(I)%TW0(2) = 0 - INPUTS(I)%TU0(1) = -1 - INPUTS(I)%TU0(2) = 0 - INPUTS(I)%TR0(1) = -1 - INPUTS(I)%TR0(2) = 0 - INPUTS(I)%TDN(1) = -1 - INPUTS(I)%TDN(2) = 0 - INPUTS(I)%TG0(1) = -1 - INPUTS(I)%TG0(2) = 0 - INPUTS(I)%GA0 = 0. - INPUTS(I)%GD0 = 0. - INPUTS(I)%GAN = 0. - INPUTS(I)%GDN = 0. - INPUTS(I)%IINIT = .FALSE. - INPUTS(I)%INFLAGS1 = .FALSE. - INPUTS(I)%INFLAGS2 = .FALSE. - INPUTS(I)%FLAGSC = .FALSE. - END DO -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) NGRIDS + CALL EXTCDE (1) + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Set variable and allocate arrays + ! + ALLOCATE ( INPUTS(-NAUXGR:NGRIDS), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + NIDATA = NGRIDS + ! + ! -------------------------------------------------------------------- / + ! 3. Initialize parameters + ! + DO I=-NAUXGR, NGRIDS + INPUTS(I)%TFN(1,:) = -1 + INPUTS(I)%TFN(2,:) = 0 + INPUTS(I)%TC0(1) = -1 + INPUTS(I)%TC0(2) = 0 + INPUTS(I)%TW0(1) = -1 + INPUTS(I)%TW0(2) = 0 + INPUTS(I)%TU0(1) = -1 + INPUTS(I)%TU0(2) = 0 + INPUTS(I)%TR0(1) = -1 + INPUTS(I)%TR0(2) = 0 + INPUTS(I)%TDN(1) = -1 + INPUTS(I)%TDN(2) = 0 + INPUTS(I)%TG0(1) = -1 + INPUTS(I)%TG0(2) = 0 + INPUTS(I)%GA0 = 0. + INPUTS(I)%GD0 = 0. + INPUTS(I)%GAN = 0. + INPUTS(I)%GDN = 0. + INPUTS(I)%IINIT = .FALSE. + INPUTS(I)%INFLAGS1 = .FALSE. + INPUTS(I)%INFLAGS2 = .FALSE. + INPUTS(I)%FLAGSC = .FALSE. + END DO + ! #ifdef W3_T - WRITE (NDST,9000) -NAUXGR, NGRIDS + WRITE (NDST,9000) -NAUXGR, NGRIDS #endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3NINP : NGRIDS NOT YET SET *** '/ & - ' NGRIDS = ',I10/ & - ' RUN W3NMOD FIRST'/) -! + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3NINP : NGRIDS NOT YET SET *** '/ & + ' NGRIDS = ',I10/ & + ' RUN W3NMOD FIRST'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3NINP : SETTING UP FOR ',I2,' -',I3,' GRIDS') +9000 FORMAT (' TEST W3NINP : SETTING UP FOR ',I2,' -',I3,' GRIDS') #endif -!/ -!/ End of W3NINP ----------------------------------------------------- / -!/ - END SUBROUTINE W3NINP -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize an individual data grid at the proper dimensions. -!> -!> @details Allocate directly into the structure array. Note that -!> this cannot be done through the pointer alias! -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> @param[in] FLAGSTIDEIN -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 02-Apr-2004 : Origination. ( version 3.06 ) -!/ 19-Jul-2006 : Adding auxiliary grids. ( version 3.10 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 21-Jun-2018 : Add FSWND input for SMC grid. JGLi ( version 6.04 ) -!/ 22-Mar-2021 : Momentum and air density support ( version 7.13 ) -!/ -! 1. Purpose : -! -! Initialize an individual data grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Main wave model drivers. -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - W3SETI needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS, NAUXGR, IGRID, W3SETG, NX, NY + !/ + !/ End of W3NINP ----------------------------------------------------- / + !/ + END SUBROUTINE W3NINP + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize an individual data grid at the proper dimensions. + !> + !> @details Allocate directly into the structure array. Note that + !> this cannot be done through the pointer alias! + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> @param[in] FLAGSTIDEIN + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 02-Apr-2004 : Origination. ( version 3.06 ) + !/ 19-Jul-2006 : Adding auxiliary grids. ( version 3.10 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 21-Jun-2018 : Add FSWND input for SMC grid. JGLi ( version 6.04 ) + !/ 22-Mar-2021 : Momentum and air density support ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Main wave model drivers. + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - W3SETI needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS, NAUXGR, IGRID, W3SETG, NX, NY #ifdef W3_SMC - USE W3GDATMD, ONLY: FSWND, NSEA -#endif - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3GDATMD, ONLY: FSWND, NSEA #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST - LOGICAL, INTENT(IN), OPTIONAL :: FLAGSTIDEIN(4) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID - LOGICAL :: FLAGSTIDE(4)=.FALSE. + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + USE W3SERVMD, ONLY: STRACE #endif -!/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + LOGICAL, INTENT(IN), OPTIONAL :: FLAGSTIDEIN(4) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID + LOGICAL :: FLAGSTIDE(4)=.FALSE. #ifdef W3_S - CALL STRACE (IENT, 'W3DIMI') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIMI') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NIDATA ) THEN - WRITE (NDSE,1002) IMOD, -NAUXGR, NIDATA - CALL EXTCDE (2) - END IF -! - IF ( INPUTS(IMOD)%IINIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NIDATA ) THEN + WRITE (NDSE,1002) IMOD, -NAUXGR, NIDATA + CALL EXTCDE (2) + END IF + ! + IF ( INPUTS(IMOD)%IINIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD + WRITE (NDST,9000) IMOD #endif -! - JGRID = IGRID - IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! + ! + JGRID = IGRID + IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! #ifdef W3_TIDE - IF ( PRESENT(FLAGSTIDEIN) ) THEN - FLAGSTIDE(:) = FLAGSTIDEIN(:) - END IF + IF ( PRESENT(FLAGSTIDEIN) ) THEN + FLAGSTIDE(:) = FLAGSTIDEIN(:) + END IF #endif - FLIC1 => INPUTS(IMOD)%INFLAGS1(-7) - FLIC2 => INPUTS(IMOD)%INFLAGS1(-6) - FLIC3 => INPUTS(IMOD)%INFLAGS1(-5) - FLIC4 => INPUTS(IMOD)%INFLAGS1(-4) - FLIC5 => INPUTS(IMOD)%INFLAGS1(-3) -! - FLMDN => INPUTS(IMOD)%INFLAGS1(-2) - FLMTH => INPUTS(IMOD)%INFLAGS1(-1) - FLMVS => INPUTS(IMOD)%INFLAGS1(0) -! - FLLEV => INPUTS(IMOD)%INFLAGS1(1) - FLCUR => INPUTS(IMOD)%INFLAGS1(2) + FLIC1 => INPUTS(IMOD)%INFLAGS1(-7) + FLIC2 => INPUTS(IMOD)%INFLAGS1(-6) + FLIC3 => INPUTS(IMOD)%INFLAGS1(-5) + FLIC4 => INPUTS(IMOD)%INFLAGS1(-4) + FLIC5 => INPUTS(IMOD)%INFLAGS1(-3) + ! + FLMDN => INPUTS(IMOD)%INFLAGS1(-2) + FLMTH => INPUTS(IMOD)%INFLAGS1(-1) + FLMVS => INPUTS(IMOD)%INFLAGS1(0) + ! + FLLEV => INPUTS(IMOD)%INFLAGS1(1) + FLCUR => INPUTS(IMOD)%INFLAGS1(2) #ifdef W3_TIDE - FLLEVTIDE => INPUTS(IMOD)%INFLAGS1(11) - FLCURTIDE => INPUTS(IMOD)%INFLAGS1(12) - FLLEVRESI => INPUTS(IMOD)%INFLAGS1(13) - FLCURRESI => INPUTS(IMOD)%INFLAGS1(14) -! - FLLEVTIDE = FLAGSTIDE(1) - FLCURTIDE = FLAGSTIDE(2) - FLLEVRESI = FLAGSTIDE(3) - FLCURRESI = FLAGSTIDE(4) + FLLEVTIDE => INPUTS(IMOD)%INFLAGS1(11) + FLCURTIDE => INPUTS(IMOD)%INFLAGS1(12) + FLLEVRESI => INPUTS(IMOD)%INFLAGS1(13) + FLCURRESI => INPUTS(IMOD)%INFLAGS1(14) + ! + FLLEVTIDE = FLAGSTIDE(1) + FLCURTIDE = FLAGSTIDE(2) + FLLEVRESI = FLAGSTIDE(3) + FLCURRESI = FLAGSTIDE(4) #endif - - FLWIND => INPUTS(IMOD)%INFLAGS1(3) - FLICE => INPUTS(IMOD)%INFLAGS1(4) - FLTAUA => INPUTS(IMOD)%INFLAGS1(5) - FLRHOA => INPUTS(IMOD)%INFLAGS1(6) -! -! notes: future improvement: flags for ICEPx should be -! "all or nothing" rather than 5 individual flags - IF ( FLIC1 ) THEN - ALLOCATE ( INPUTS(IMOD)%ICEP1(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( FLIC2 ) THEN - ALLOCATE ( INPUTS(IMOD)%ICEP2(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( FLIC3 ) THEN - ALLOCATE ( INPUTS(IMOD)%ICEP3(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( FLIC4 ) THEN - ALLOCATE ( INPUTS(IMOD)%ICEP4(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( FLIC5 ) THEN - ALLOCATE ( INPUTS(IMOD)%ICEP5(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLMDN ) THEN - ALLOCATE ( INPUTS(IMOD)%MUDD(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( FLMTH ) THEN - ALLOCATE ( INPUTS(IMOD)%MUDT(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( FLMVS ) THEN - ALLOCATE ( INPUTS(IMOD)%MUDV(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLLEV ) THEN - ALLOCATE ( INPUTS(IMOD)%WLEV(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLCUR ) THEN + FLWIND => INPUTS(IMOD)%INFLAGS1(3) + FLICE => INPUTS(IMOD)%INFLAGS1(4) + FLTAUA => INPUTS(IMOD)%INFLAGS1(5) + FLRHOA => INPUTS(IMOD)%INFLAGS1(6) + ! + ! notes: future improvement: flags for ICEPx should be + ! "all or nothing" rather than 5 individual flags + + IF ( FLIC1 ) THEN + ALLOCATE ( INPUTS(IMOD)%ICEP1(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( FLIC2 ) THEN + ALLOCATE ( INPUTS(IMOD)%ICEP2(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( FLIC3 ) THEN + ALLOCATE ( INPUTS(IMOD)%ICEP3(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( FLIC4 ) THEN + ALLOCATE ( INPUTS(IMOD)%ICEP4(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( FLIC5 ) THEN + ALLOCATE ( INPUTS(IMOD)%ICEP5(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( FLMDN ) THEN + ALLOCATE ( INPUTS(IMOD)%MUDD(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( FLMTH ) THEN + ALLOCATE ( INPUTS(IMOD)%MUDT(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( FLMVS ) THEN + ALLOCATE ( INPUTS(IMOD)%MUDV(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( FLLEV ) THEN + ALLOCATE ( INPUTS(IMOD)%WLEV(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( FLCUR ) THEN #ifdef W3_SMC - IF( FSWND ) THEN - ALLOCATE ( INPUTS(IMOD)%CX0(NSEA,1) , & - INPUTS(IMOD)%CY0(NSEA,1) , & - INPUTS(IMOD)%CXN(NSEA,1) , & - INPUTS(IMOD)%CYN(NSEA,1) , STAT=ISTAT ) - ELSE + IF( FSWND ) THEN + ALLOCATE ( INPUTS(IMOD)%CX0(NSEA,1) , & + INPUTS(IMOD)%CY0(NSEA,1) , & + INPUTS(IMOD)%CXN(NSEA,1) , & + INPUTS(IMOD)%CYN(NSEA,1) , STAT=ISTAT ) + ELSE #endif - ALLOCATE ( INPUTS(IMOD)%CX0(NX,NY) , & - INPUTS(IMOD)%CY0(NX,NY) , & - INPUTS(IMOD)%CXN(NX,NY) , & - INPUTS(IMOD)%CYN(NX,NY) , STAT=ISTAT ) + ALLOCATE ( INPUTS(IMOD)%CX0(NX,NY) , & + INPUTS(IMOD)%CY0(NX,NY) , & + INPUTS(IMOD)%CXN(NX,NY) , & + INPUTS(IMOD)%CYN(NX,NY) , STAT=ISTAT ) #ifdef W3_SMC - ENDIF + ENDIF #endif - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! #ifdef W3_TIDE - IF ( FLLEVTIDE ) THEN - ALLOCATE ( INPUTS(IMOD)%WLTIDE(NX,NY,NTIDE,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLCURTIDE ) THEN - ALLOCATE ( INPUTS(IMOD)%CXTIDE(NX,NY,NTIDE,2), & - INPUTS(IMOD)%CYTIDE(NX,NY,NTIDE,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF + IF ( FLLEVTIDE ) THEN + ALLOCATE ( INPUTS(IMOD)%WLTIDE(NX,NY,NTIDE,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( FLCURTIDE ) THEN + ALLOCATE ( INPUTS(IMOD)%CXTIDE(NX,NY,NTIDE,2), & + INPUTS(IMOD)%CYTIDE(NX,NY,NTIDE,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF #endif -! + ! #ifdef W3_WRST - IF(.NOT.(INPUTS(IMOD)%WRSTIINIT)) THEN - ALLOCATE ( INPUTS(IMOD)%WXNwrst(NX,NY) , & - INPUTS(IMOD)%WYNwrst(NX,NY) , STAT=ISTAT ) - INPUTS(IMOD)%WRSTIINIT=.TRUE. - ENDIF + IF(.NOT.(INPUTS(IMOD)%WRSTIINIT)) THEN + ALLOCATE ( INPUTS(IMOD)%WXNwrst(NX,NY) , & + INPUTS(IMOD)%WYNwrst(NX,NY) , STAT=ISTAT ) + INPUTS(IMOD)%WRSTIINIT=.TRUE. + ENDIF #endif - IF ( FLWIND ) THEN + IF ( FLWIND ) THEN #ifdef W3_SMC - IF( FSWND ) THEN - ALLOCATE ( INPUTS(IMOD)%WX0(NSEA,1) , & - INPUTS(IMOD)%WY0(NSEA,1) , & - INPUTS(IMOD)%DT0(NSEA,1) , & - INPUTS(IMOD)%WXN(NSEA,1) , & - INPUTS(IMOD)%WYN(NSEA,1) , & - INPUTS(IMOD)%DTN(NSEA,1) , STAT=ISTAT ) - ELSE + IF( FSWND ) THEN + ALLOCATE ( INPUTS(IMOD)%WX0(NSEA,1) , & + INPUTS(IMOD)%WY0(NSEA,1) , & + INPUTS(IMOD)%DT0(NSEA,1) , & + INPUTS(IMOD)%WXN(NSEA,1) , & + INPUTS(IMOD)%WYN(NSEA,1) , & + INPUTS(IMOD)%DTN(NSEA,1) , STAT=ISTAT ) + ELSE #endif - ALLOCATE ( INPUTS(IMOD)%WX0(NX,NY) , & - INPUTS(IMOD)%WY0(NX,NY) , & - INPUTS(IMOD)%DT0(NX,NY) , & - INPUTS(IMOD)%WXN(NX,NY) , & - INPUTS(IMOD)%WYN(NX,NY) , & - INPUTS(IMOD)%DTN(NX,NY) , STAT=ISTAT ) + ALLOCATE ( INPUTS(IMOD)%WX0(NX,NY) , & + INPUTS(IMOD)%WY0(NX,NY) , & + INPUTS(IMOD)%DT0(NX,NY) , & + INPUTS(IMOD)%WXN(NX,NY) , & + INPUTS(IMOD)%WYN(NX,NY) , & + INPUTS(IMOD)%DTN(NX,NY) , STAT=ISTAT ) #ifdef W3_SMC - ENDIF + ENDIF #endif - CHECK_ALLOC_STATUS ( ISTAT ) - INPUTS(IMOD)%DT0 = 0. - INPUTS(IMOD)%DTN = 0. - END IF -! - IF ( FLICE ) THEN - ALLOCATE ( INPUTS(IMOD)%ICEI(NX,NY), & - INPUTS(IMOD)%BERGI(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - INPUTS(IMOD)%BERGI = 0. - END IF -! - IF ( FLTAUA ) THEN + CHECK_ALLOC_STATUS ( ISTAT ) + INPUTS(IMOD)%DT0 = 0. + INPUTS(IMOD)%DTN = 0. + END IF + ! + IF ( FLICE ) THEN + ALLOCATE ( INPUTS(IMOD)%ICEI(NX,NY), & + INPUTS(IMOD)%BERGI(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + INPUTS(IMOD)%BERGI = 0. + END IF + ! + IF ( FLTAUA ) THEN #ifdef W3_SMC - IF( FSWND ) THEN - ALLOCATE ( INPUTS(IMOD)%UX0(NSEA,1) , & - INPUTS(IMOD)%UY0(NSEA,1) , & - INPUTS(IMOD)%UXN(NSEA,1) , & - INPUTS(IMOD)%UYN(NSEA,1) , STAT=ISTAT ) - ELSE + IF( FSWND ) THEN + ALLOCATE ( INPUTS(IMOD)%UX0(NSEA,1) , & + INPUTS(IMOD)%UY0(NSEA,1) , & + INPUTS(IMOD)%UXN(NSEA,1) , & + INPUTS(IMOD)%UYN(NSEA,1) , STAT=ISTAT ) + ELSE #endif - ALLOCATE ( INPUTS(IMOD)%UX0(NX,NY) , & - INPUTS(IMOD)%UY0(NX,NY) , & - INPUTS(IMOD)%UXN(NX,NY) , & - INPUTS(IMOD)%UYN(NX,NY) , STAT=ISTAT ) + ALLOCATE ( INPUTS(IMOD)%UX0(NX,NY) , & + INPUTS(IMOD)%UY0(NX,NY) , & + INPUTS(IMOD)%UXN(NX,NY) , & + INPUTS(IMOD)%UYN(NX,NY) , STAT=ISTAT ) #ifdef W3_SMC - ENDIF + ENDIF #endif - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLRHOA ) THEN + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( FLRHOA ) THEN #ifdef W3_SMC - IF( FSWND ) THEN - ALLOCATE ( INPUTS(IMOD)%RH0(NSEA,1) , & - INPUTS(IMOD)%RHN(NSEA,1) , STAT=ISTAT ) - ELSE + IF( FSWND ) THEN + ALLOCATE ( INPUTS(IMOD)%RH0(NSEA,1) , & + INPUTS(IMOD)%RHN(NSEA,1) , STAT=ISTAT ) + ELSE #endif - ALLOCATE ( INPUTS(IMOD)%RH0(NX,NY) , & - INPUTS(IMOD)%RHN(NX,NY) , STAT=ISTAT ) + ALLOCATE ( INPUTS(IMOD)%RH0(NX,NY) , & + INPUTS(IMOD)%RHN(NX,NY) , STAT=ISTAT ) #ifdef W3_SMC - ENDIF + ENDIF #endif - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! #ifdef W3_CESMCOUPLED - ALLOCATE ( INPUTS(IMOD)%HML(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( INPUTS(IMOD)%HML(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -! - INPUTS(IMOD)%IINIT = .TRUE. -! + ! + INPUTS(IMOD)%IINIT = .TRUE. + ! #ifdef W3_T - WRITE (NDST,9001) + WRITE (NDST,9001) #endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETI ( IMOD, NDSE, NDST ) -! + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETI ( IMOD, NDSE, NDST ) + ! #ifdef W3_T - WRITE (NDST,9002) + WRITE (NDST,9002) #endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! #ifdef W3_T - WRITE (NDST,9003) + WRITE (NDST,9003) #endif -! -! -------------------------------------------------------------------- / -! 5. Restore previous grid setting if necessary -! - IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) -! - RETURN -! -! Check inputs for stresses - IF(FLTAUA) THEN + ! + ! -------------------------------------------------------------------- / + ! 5. Restore previous grid setting if necessary + ! + IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) + ! + RETURN + ! + ! Check inputs for stresses + IF(FLTAUA) THEN #ifdef W3_FLX0 - WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " + WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " #endif #ifdef W3_FLX1 - WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " + WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " #endif #ifdef W3_FLX2 - WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " + WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " #endif #ifdef W3_FLX3 - WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " + WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " #endif #ifdef W3_FLX4 - WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " + WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " #endif - END IF -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DIMI : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DIMI : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NAUXGR = ',I10/ & - ' NIDATA = ',I10/) - 1003 FORMAT (/' *** ERROR W3DIMI : ARRAY(S) ALREADY ALLOCATED *** ') -! + END IF + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DIMI : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DIMI : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NAUXGR = ',I10/ & + ' NIDATA = ',I10/) +1003 FORMAT (/' *** ERROR W3DIMI : ARRAY(S) ALREADY ALLOCATED *** ') + ! #ifdef W3_T - 9000 FORMAT (' TEST W3DIMI : MODEL ',I4,' DIM. AT ',2I5,I7) - 9001 FORMAT (' TEST W3DIMI : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DIMI : POINTERS RESET') - 9003 FORMAT (' TEST W3DIMI : DIMENSIONS STORED') +9000 FORMAT (' TEST W3DIMI : MODEL ',I4,' DIM. AT ',2I5,I7) +9001 FORMAT (' TEST W3DIMI : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DIMI : POINTERS RESET') +9003 FORMAT (' TEST W3DIMI : DIMENSIONS STORED') #endif -!/ -!/ End of W3DIMI ----------------------------------------------------- / -!/ - END SUBROUTINE W3DIMI -!/ ------------------------------------------------------------------- / -!> -!> @brief Select one of the WAVEWATCH III grids / models. -!> -!> @details Point pointers to the proper variables in the proper element of -!> the GRIDS array. -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 02-Apr-2004 : Origination. ( version 3.06 ) -!/ 19-Jul-2006 : Adding auxiliary grids. ( version 3.10 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 22-Mar-2021 : Momentum and air density support ( version 7.13 ) -!/ -! 1. Purpose : -! -! Select one of the WAVEWATCH III grids / models. -! -! 2. Method : -! -! Point pointers to the proper variables in the proper element of -! the GRIDS array. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any subroutine. -! -! 6. Error messages : -! -! Many subroutines in the WAVEWATCH system. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NAUXGR -! - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ End of W3DIMI ----------------------------------------------------- / + !/ + END SUBROUTINE W3DIMI + !/ ------------------------------------------------------------------- / + !> + !> @brief Select one of the WAVEWATCH III grids / models. + !> + !> @details Point pointers to the proper variables in the proper element of + !> the GRIDS array. + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 02-Apr-2004 : Origination. ( version 3.06 ) + !/ 19-Jul-2006 : Adding auxiliary grids. ( version 3.10 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 22-Mar-2021 : Momentum and air density support ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Select one of the WAVEWATCH III grids / models. + ! + ! 2. Method : + ! + ! Point pointers to the proper variables in the proper element of + ! the GRIDS array. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any subroutine. + ! + ! 6. Error messages : + ! + ! Many subroutines in the WAVEWATCH system. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NAUXGR + ! + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + USE W3SERVMD, ONLY: STRACE #endif -!/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SETI') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SETI') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NIDATA .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NIDATA ) THEN - WRITE (NDSE,1002) IMOD, -NAUXGR, NIDATA - CALL EXTCDE (2) - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NIDATA .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NIDATA ) THEN + WRITE (NDSE,1002) IMOD, -NAUXGR, NIDATA + CALL EXTCDE (2) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD + WRITE (NDST,9000) IMOD #endif -! -! -------------------------------------------------------------------- / -! 2. Set model numbers -! - IIDATA = IMOD -! -! -------------------------------------------------------------------- / -! 3. Set pointers -! - TFN => INPUTS(IMOD)%TFN - TC0 => INPUTS(IMOD)%TC0 - TW0 => INPUTS(IMOD)%TW0 - TU0 => INPUTS(IMOD)%TU0 - TR0 => INPUTS(IMOD)%TR0 - TG0 => INPUTS(IMOD)%TG0 - TDN => INPUTS(IMOD)%TDN -! - TI1 => INPUTS(IMOD)%TFN(:,-7) - TI2 => INPUTS(IMOD)%TFN(:,-6) - TI3 => INPUTS(IMOD)%TFN(:,-5) - TI4 => INPUTS(IMOD)%TFN(:,-4) - TI5 => INPUTS(IMOD)%TFN(:,-3) -! - TZN => INPUTS(IMOD)%TFN(:,-2) - TTN => INPUTS(IMOD)%TFN(:,-1) - TVN => INPUTS(IMOD)%TFN(:,0) -! - TLN => INPUTS(IMOD)%TFN(:,1) - TCN => INPUTS(IMOD)%TFN(:,2) - TWN => INPUTS(IMOD)%TFN(:,3) - TIN => INPUTS(IMOD)%TFN(:,4) - TUN => INPUTS(IMOD)%TFN(:,5) - TRN => INPUTS(IMOD)%TFN(:,6) - T0N => INPUTS(IMOD)%TFN(:,7) - T1N => INPUTS(IMOD)%TFN(:,8) - T2N => INPUTS(IMOD)%TFN(:,9) - TGN => INPUTS(IMOD)%TFN(:,10) -! - GA0 => INPUTS(IMOD)%GA0 - GD0 => INPUTS(IMOD)%GD0 - GAN => INPUTS(IMOD)%GAN - GDN => INPUTS(IMOD)%GDN -! - IINIT => INPUTS(IMOD)%IINIT - INFLAGS1 => INPUTS(IMOD)%INFLAGS1 - INFLAGS2 => INPUTS(IMOD)%INFLAGS2 - FLAGSC => INPUTS(IMOD)%FLAGSC -! - FLIC1 => INPUTS(IMOD)%INFLAGS1(-7) - FLIC2 => INPUTS(IMOD)%INFLAGS1(-6) - FLIC3 => INPUTS(IMOD)%INFLAGS1(-5) - FLIC4 => INPUTS(IMOD)%INFLAGS1(-4) - FLIC5 => INPUTS(IMOD)%INFLAGS1(-3) -! - FLMDN => INPUTS(IMOD)%INFLAGS1(-2) - FLMTH => INPUTS(IMOD)%INFLAGS1(-1) - FLMVS => INPUTS(IMOD)%INFLAGS1(0) -! - FLLEV => INPUTS(IMOD)%INFLAGS1(1) - FLCUR => INPUTS(IMOD)%INFLAGS1(2) + ! + ! -------------------------------------------------------------------- / + ! 2. Set model numbers + ! + IIDATA = IMOD + ! + ! -------------------------------------------------------------------- / + ! 3. Set pointers + ! + TFN => INPUTS(IMOD)%TFN + TC0 => INPUTS(IMOD)%TC0 + TW0 => INPUTS(IMOD)%TW0 + TU0 => INPUTS(IMOD)%TU0 + TR0 => INPUTS(IMOD)%TR0 + TG0 => INPUTS(IMOD)%TG0 + TDN => INPUTS(IMOD)%TDN + ! + TI1 => INPUTS(IMOD)%TFN(:,-7) + TI2 => INPUTS(IMOD)%TFN(:,-6) + TI3 => INPUTS(IMOD)%TFN(:,-5) + TI4 => INPUTS(IMOD)%TFN(:,-4) + TI5 => INPUTS(IMOD)%TFN(:,-3) + ! + TZN => INPUTS(IMOD)%TFN(:,-2) + TTN => INPUTS(IMOD)%TFN(:,-1) + TVN => INPUTS(IMOD)%TFN(:,0) + ! + TLN => INPUTS(IMOD)%TFN(:,1) + TCN => INPUTS(IMOD)%TFN(:,2) + TWN => INPUTS(IMOD)%TFN(:,3) + TIN => INPUTS(IMOD)%TFN(:,4) + TUN => INPUTS(IMOD)%TFN(:,5) + TRN => INPUTS(IMOD)%TFN(:,6) + T0N => INPUTS(IMOD)%TFN(:,7) + T1N => INPUTS(IMOD)%TFN(:,8) + T2N => INPUTS(IMOD)%TFN(:,9) + TGN => INPUTS(IMOD)%TFN(:,10) + ! + GA0 => INPUTS(IMOD)%GA0 + GD0 => INPUTS(IMOD)%GD0 + GAN => INPUTS(IMOD)%GAN + GDN => INPUTS(IMOD)%GDN + ! + IINIT => INPUTS(IMOD)%IINIT + INFLAGS1 => INPUTS(IMOD)%INFLAGS1 + INFLAGS2 => INPUTS(IMOD)%INFLAGS2 + FLAGSC => INPUTS(IMOD)%FLAGSC + ! + FLIC1 => INPUTS(IMOD)%INFLAGS1(-7) + FLIC2 => INPUTS(IMOD)%INFLAGS1(-6) + FLIC3 => INPUTS(IMOD)%INFLAGS1(-5) + FLIC4 => INPUTS(IMOD)%INFLAGS1(-4) + FLIC5 => INPUTS(IMOD)%INFLAGS1(-3) + ! + FLMDN => INPUTS(IMOD)%INFLAGS1(-2) + FLMTH => INPUTS(IMOD)%INFLAGS1(-1) + FLMVS => INPUTS(IMOD)%INFLAGS1(0) + ! + FLLEV => INPUTS(IMOD)%INFLAGS1(1) + FLCUR => INPUTS(IMOD)%INFLAGS1(2) #ifdef W3_TIDE - FLLEVTIDE => INPUTS(IMOD)%INFLAGS1(11) - FLCURTIDE => INPUTS(IMOD)%INFLAGS1(12) - FLLEVRESI => INPUTS(IMOD)%INFLAGS1(13) - FLCURRESI => INPUTS(IMOD)%INFLAGS1(14) + FLLEVTIDE => INPUTS(IMOD)%INFLAGS1(11) + FLCURTIDE => INPUTS(IMOD)%INFLAGS1(12) + FLLEVRESI => INPUTS(IMOD)%INFLAGS1(13) + FLCURRESI => INPUTS(IMOD)%INFLAGS1(14) #endif - FLWIND => INPUTS(IMOD)%INFLAGS1(3) - FLICE => INPUTS(IMOD)%INFLAGS1(4) - FLTAUA => INPUTS(IMOD)%INFLAGS1(5) - FLRHOA => INPUTS(IMOD)%INFLAGS1(6) -! - IF ( IINIT ) THEN -! - IF ( FLIC1 ) THEN - ICEP1 => INPUTS(IMOD)%ICEP1 - END IF - IF ( FLIC2 ) THEN - ICEP2 => INPUTS(IMOD)%ICEP2 - END IF - IF ( FLIC3 ) THEN - ICEP3 => INPUTS(IMOD)%ICEP3 - END IF - IF ( FLIC4 ) THEN - ICEP4 => INPUTS(IMOD)%ICEP4 - END IF - IF ( FLIC5 ) THEN - ICEP5 => INPUTS(IMOD)%ICEP5 - END IF -! - IF ( FLMDN ) THEN - MUDD => INPUTS(IMOD)%MUDD - END IF - IF ( FLMTH ) THEN - MUDT => INPUTS(IMOD)%MUDT - END IF - IF ( FLMVS ) THEN - MUDV => INPUTS(IMOD)%MUDV - END IF -! - IF ( FLLEV ) THEN - WLEV => INPUTS(IMOD)%WLEV - END IF -! - IF ( FLCUR ) THEN - CX0 => INPUTS(IMOD)%CX0 - CY0 => INPUTS(IMOD)%CY0 - CXN => INPUTS(IMOD)%CXN - CYN => INPUTS(IMOD)%CYN - END IF + FLWIND => INPUTS(IMOD)%INFLAGS1(3) + FLICE => INPUTS(IMOD)%INFLAGS1(4) + FLTAUA => INPUTS(IMOD)%INFLAGS1(5) + FLRHOA => INPUTS(IMOD)%INFLAGS1(6) + ! + IF ( IINIT ) THEN + ! + IF ( FLIC1 ) THEN + ICEP1 => INPUTS(IMOD)%ICEP1 + END IF + IF ( FLIC2 ) THEN + ICEP2 => INPUTS(IMOD)%ICEP2 + END IF + IF ( FLIC3 ) THEN + ICEP3 => INPUTS(IMOD)%ICEP3 + END IF + IF ( FLIC4 ) THEN + ICEP4 => INPUTS(IMOD)%ICEP4 + END IF + IF ( FLIC5 ) THEN + ICEP5 => INPUTS(IMOD)%ICEP5 + END IF + ! + IF ( FLMDN ) THEN + MUDD => INPUTS(IMOD)%MUDD + END IF + IF ( FLMTH ) THEN + MUDT => INPUTS(IMOD)%MUDT + END IF + IF ( FLMVS ) THEN + MUDV => INPUTS(IMOD)%MUDV + END IF + ! + IF ( FLLEV ) THEN + WLEV => INPUTS(IMOD)%WLEV + END IF + ! + IF ( FLCUR ) THEN + CX0 => INPUTS(IMOD)%CX0 + CY0 => INPUTS(IMOD)%CY0 + CXN => INPUTS(IMOD)%CXN + CYN => INPUTS(IMOD)%CYN + END IF #ifdef W3_TIDE - IF ( FLLEVTIDE ) THEN - WLTIDE => INPUTS(IMOD)%WLTIDE - END IF - IF ( FLCURTIDE ) THEN - CXTIDE => INPUTS(IMOD)%CXTIDE - CYTIDE => INPUTS(IMOD)%CYTIDE - END IF + IF ( FLLEVTIDE ) THEN + WLTIDE => INPUTS(IMOD)%WLTIDE + END IF + IF ( FLCURTIDE ) THEN + CXTIDE => INPUTS(IMOD)%CXTIDE + CYTIDE => INPUTS(IMOD)%CYTIDE + END IF #endif -! + ! #ifdef W3_WRST - WXNwrst => INPUTS(IMOD)%WXNwrst - WYNwrst => INPUTS(IMOD)%WYNwrst + WXNwrst => INPUTS(IMOD)%WXNwrst + WYNwrst => INPUTS(IMOD)%WYNwrst #endif - IF ( FLWIND ) THEN - WX0 => INPUTS(IMOD)%WX0 - WY0 => INPUTS(IMOD)%WY0 - DT0 => INPUTS(IMOD)%DT0 - WXN => INPUTS(IMOD)%WXN - WYN => INPUTS(IMOD)%WYN - DTN => INPUTS(IMOD)%DTN - END IF -! - IF ( FLICE ) THEN - ICEI => INPUTS(IMOD)%ICEI - BERGI => INPUTS(IMOD)%BERGI - END IF + IF ( FLWIND ) THEN + WX0 => INPUTS(IMOD)%WX0 + WY0 => INPUTS(IMOD)%WY0 + DT0 => INPUTS(IMOD)%DT0 + WXN => INPUTS(IMOD)%WXN + WYN => INPUTS(IMOD)%WYN + DTN => INPUTS(IMOD)%DTN + END IF + ! + IF ( FLICE ) THEN + ICEI => INPUTS(IMOD)%ICEI + BERGI => INPUTS(IMOD)%BERGI + END IF #ifdef W3_CESMCOUPLED - HML => INPUTS(IMOD)%HML + HML => INPUTS(IMOD)%HML #endif -! - IF ( FLTAUA ) THEN - UX0 => INPUTS(IMOD)%UX0 - UY0 => INPUTS(IMOD)%UY0 - UXN => INPUTS(IMOD)%UXN - UYN => INPUTS(IMOD)%UYN - END IF -! - IF ( FLRHOA ) THEN - RH0 => INPUTS(IMOD)%RH0 - RHN => INPUTS(IMOD)%RHN - END IF -! - END IF -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3SETI : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3SETI : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NAUXGR = ',I10/ & - ' NIDATA = ',I10/) -! + ! + IF ( FLTAUA ) THEN + UX0 => INPUTS(IMOD)%UX0 + UY0 => INPUTS(IMOD)%UY0 + UXN => INPUTS(IMOD)%UXN + UYN => INPUTS(IMOD)%UYN + END IF + ! + IF ( FLRHOA ) THEN + RH0 => INPUTS(IMOD)%RH0 + RHN => INPUTS(IMOD)%RHN + END IF + ! + END IF + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3SETI : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3SETI : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NAUXGR = ',I10/ & + ' NIDATA = ',I10/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SETI : MODEL ',I4,' SELECTED') +9000 FORMAT (' TEST W3SETI : MODEL ',I4,' SELECTED') #endif -!/ -!/ End of W3SETI ----------------------------------------------------- / -!/ - END SUBROUTINE W3SETI -!/ -!/ End of module W3IDATMD -------------------------------------------- / -!/ - END MODULE W3IDATMD + !/ + !/ End of W3SETI ----------------------------------------------------- / + !/ + END SUBROUTINE W3SETI + !/ + !/ End of module W3IDATMD -------------------------------------------- / + !/ +END MODULE W3IDATMD diff --git a/model/src/w3igcmmd.F90 b/model/src/w3igcmmd.F90 index 41bea7fd7..14b942760 100644 --- a/model/src/w3igcmmd.F90 +++ b/model/src/w3igcmmd.F90 @@ -1,355 +1,354 @@ !> @file !> @brief Module used for coupling applications between ice model and WW3 with OASIS3-MCT. -!> +!> !> @author G. Boutin @date Aug-2016 !> #include "w3macros.h" !> -!> @brief Module used for coupling applications between ice model and WW3 with OASIS3-MCT. -!> -!> @author G. Boutin @date Aug-2016 -!> -!/ ------------------------------------------------------------------- / - MODULE W3IGCMMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | G. Boutin | -!/ | FORTRAN 90 | -!/ | Last update : Aug-2016 | -!/ +-----------------------------------+ -!/ -!/ Aug-2016 : Origination (G. Boutin) ( version 5.10 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Module used for coupling applications between ice model and WW3 with OASIS3-MCT -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! SND_FIELDS_TO_ICE Subr. Public Send fields to ice model -! RCV_FIELDS_FROM_ICE Subr. Public Receive fields from ice model -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! CPL_OASIS_SEND Subr. W3OACPMD Send fields -! CPL_OASIS_RECV Subr. W3OACPMD Receive fields -! ---------------------------------------------------------------- -! -! 5. Remarks -! 6. Switches : -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -! - IMPLICIT NONE -! - INCLUDE "mpif.h" -! - PRIVATE -! -! * Accessibility - PUBLIC SND_FIELDS_TO_ICE - PUBLIC RCV_FIELDS_FROM_ICE -! - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Send coupling fields to ice model. +!> @brief Module used for coupling applications between ice model and WW3 with OASIS3-MCT. !> -!> @author G. Boutin @date Aug-2016 +!> @author G. Boutin @date Aug-2016 !> - SUBROUTINE SND_FIELDS_TO_ICE() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | G. Boutin | -!/ | FORTRAN 90 | -!/ | Last update : Aug-2016 | -!/ +-----------------------------------+ -!/ -!/ Aug-2016 : Origination (G. Boutin) ( version 5.10 ) -!/ -! 1. Purpose : -! -! Send coupling fields to ice model -! -! 2. Method : -! 3. Parameters : -! 4. Subroutines used : -! -! Name Type Module Description -! ------------------------------------------------------------------- -! CPL_OASIS_SND Subr. W3OACPMD Send field to ice/ocean model -! ------------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ------------------------------------------------------------------ -! W3WAVE Subr. W3WAVEMD Wave model -! ------------------------------------------------------------------ -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_SND, SND_FLD, CPL_OASIS_SND - USE W3GDATMD, ONLY: NSEAL, NSEA - USE W3WDATMD, ONLY: ICEF - USE W3ADATMD, ONLY: TAUICE - USE W3ODATMD, ONLY: UNDEF, NAPROC, IAPROC -! !/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_SND - INTEGER :: IB_DO, NDSO - LOGICAL :: LL_ACTION - REAL(kind=8), DIMENSION(NSEAL) :: TMP - INTEGER :: JSEA, ISEA -! -!---------------------------------------------------------------------- -! * Executable part -! - DO IB_DO = 1, IL_NB_SND +MODULE W3IGCMMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | G. Boutin | + !/ | FORTRAN 90 | + !/ | Last update : Aug-2016 | + !/ +-----------------------------------+ + !/ + !/ Aug-2016 : Origination (G. Boutin) ( version 5.10 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Module used for coupling applications between ice model and WW3 with OASIS3-MCT + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! SND_FIELDS_TO_ICE Subr. Public Send fields to ice model + ! RCV_FIELDS_FROM_ICE Subr. Public Receive fields from ice model + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! CPL_OASIS_SEND Subr. W3OACPMD Send fields + ! CPL_OASIS_RECV Subr. W3OACPMD Receive fields + ! ---------------------------------------------------------------- + ! + ! 5. Remarks + ! 6. Switches : + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + IMPLICIT NONE + ! + INCLUDE "mpif.h" + ! + PRIVATE + ! + ! * Accessibility + PUBLIC SND_FIELDS_TO_ICE + PUBLIC RCV_FIELDS_FROM_ICE + ! +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Send coupling fields to ice model. + !> + !> @author G. Boutin @date Aug-2016 + !> + SUBROUTINE SND_FIELDS_TO_ICE() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | G. Boutin | + !/ | FORTRAN 90 | + !/ | Last update : Aug-2016 | + !/ +-----------------------------------+ + !/ + !/ Aug-2016 : Origination (G. Boutin) ( version 5.10 ) + !/ + ! 1. Purpose : + ! + ! Send coupling fields to ice model + ! + ! 2. Method : + ! 3. Parameters : + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------- + ! CPL_OASIS_SND Subr. W3OACPMD Send field to ice/ocean model + ! ------------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------ + ! W3WAVE Subr. W3WAVEMD Wave model + ! ------------------------------------------------------------------ + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_SND, SND_FLD, CPL_OASIS_SND + USE W3GDATMD, ONLY: NSEAL, NSEA + USE W3WDATMD, ONLY: ICEF + USE W3ADATMD, ONLY: TAUICE + USE W3ODATMD, ONLY: UNDEF, NAPROC, IAPROC + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_SND + INTEGER :: IB_DO, NDSO + LOGICAL :: LL_ACTION + REAL(kind=8), DIMENSION(NSEAL) :: TMP + INTEGER :: JSEA, ISEA + ! + !---------------------------------------------------------------------- + ! * Executable part + ! + DO IB_DO = 1, IL_NB_SND - SELECT CASE(SND_FLD(IB_DO)%CL_FIELD_NAME) + SELECT CASE(SND_FLD(IB_DO)%CL_FIELD_NAME) - ! - ! Ice floe diameters (m) - ! --------------------------------------------------------------------- - CASE ('WW3_ICEF') - TMP(1:NSEAL) = 0.0 - DO JSEA=1, NSEAL - ISEA=IAPROC+(JSEA-1)*NAPROC - IF(ICEF(ISEA) /= UNDEF) TMP(JSEA)=ICEF(ISEA) - END DO - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ! + ! Ice floe diameters (m) + ! --------------------------------------------------------------------- + CASE ('WW3_ICEF') + TMP(1:NSEAL) = 0.0 + DO JSEA=1, NSEAL + ISEA=IAPROC+(JSEA-1)*NAPROC + IF(ICEF(ISEA) /= UNDEF) TMP(JSEA)=ICEF(ISEA) + END DO + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - CASE ('WW3_TWIX') - TMP(1:NSEAL) = 0.0 - WHERE(TAUICE(1:NSEAL,1) /= UNDEF) TMP(1:NSEAL)=TAUICE(1:NSEAL,1) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + CASE ('WW3_TWIX') + TMP(1:NSEAL) = 0.0 + WHERE(TAUICE(1:NSEAL,1) /= UNDEF) TMP(1:NSEAL)=TAUICE(1:NSEAL,1) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - CASE ('WW3_TWIY') - TMP(1:NSEAL) = 0.0 - WHERE(TAUICE(1:NSEAL,2) /= UNDEF) TMP(1:NSEAL)=TAUICE(1:NSEAL,2) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + CASE ('WW3_TWIY') + TMP(1:NSEAL) = 0.0 + WHERE(TAUICE(1:NSEAL,2) /= UNDEF) TMP(1:NSEAL)=TAUICE(1:NSEAL,2) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - END SELECT + END SELECT - ENDDO -! -!/ ------------------------------------------------------------------- / - END SUBROUTINE SND_FIELDS_TO_ICE -!/ ------------------------------------------------------------------- / -!> -!> @brief Receive coupling fields from ice model. -!> -!> @param[in] ID_LCOMM MPI communicator. -!> @param[in] IDFLD Name of the exchange fields. -!> @param[inout] FXN First exchange field. -!> @param[inout] FYN Second exchange field. -!> @param[inout] FAN Third exchange field. -!> -!> @author G. Boutin @date Apr-2016 -!> - SUBROUTINE RCV_FIELDS_FROM_ICE(ID_LCOMM, IDFLD, FXN, FYN, FAN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | G. Boutin | -!/ | FORTRAN 90 | -!/ | Last update : April-2016 | -!/ +-----------------------------------+ -!/ -!/ Aug-2016 : Origination (G. Boutin) ( version 5.10 ) -!/ -! 1. Purpose : -! -! Receive coupling fields from ice model -! -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ID_LCOMM Char. I MPI communicator -! IDFLD Int. I Name of the exchange fields -! FXN Int. I/O First exchange field -! FYN Int. I/O Second exchange field -! FAN Int. I/O Third exchange field -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ------------------------------------------------------------------- -! CPL_OASIS_RCV Subr. W3OACPMD Receive fields from ice/ocean model -! W3S2XY Subr. W3SERVMD Convert from storage (NSEA) to spatial grid (NX, NY) -! ------------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ------------------------------------------------------------------ -! W3FLDG Subr. W3FLDSMD Manage input fields of depth, -! current, wind and ice concentration -! ------------------------------------------------------------------ -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_RCV, RCV_FLD, CPL_OASIS_RCV - USE W3GDATMD, ONLY: NX, NY, NSEAL, NSEA, MAPSF - USE W3ODATMD, ONLY: NAPROC, IAPROC - USE W3SERVMD, ONLY: W3S2XY -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ID_LCOMM - CHARACTER(LEN=3), INTENT(IN) :: IDFLD - REAL, INTENT(INOUT) :: FXN(:,:), FYN(:,:), FAN(:,:) -! -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - LOGICAL :: LL_ACTION - INTEGER :: IB_DO, IB_I, IB_J, IL_ERR, NDSO - REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_RCV - REAL(kind=8), DIMENSION(NSEAL) :: TMP - REAL, DIMENSION(1:NSEA) :: SND_BUFF,RCV_BUFF -! -!---------------------------------------------------------------------- -! * Executable part -! - RLA_OASIS_RCV(:,:) = 0.0 -! - DO IB_DO = 1, IL_NB_RCV - IF (IDFLD == 'IC5') THEN - SELECT CASE (RCV_FLD(IB_DO)%CL_FIELD_NAME) + ENDDO + ! + !/ ------------------------------------------------------------------- / + END SUBROUTINE SND_FIELDS_TO_ICE + !/ ------------------------------------------------------------------- / + !> + !> @brief Receive coupling fields from ice model. + !> + !> @param[in] ID_LCOMM MPI communicator. + !> @param[in] IDFLD Name of the exchange fields. + !> @param[inout] FXN First exchange field. + !> @param[inout] FYN Second exchange field. + !> @param[inout] FAN Third exchange field. + !> + !> @author G. Boutin @date Apr-2016 + !> + SUBROUTINE RCV_FIELDS_FROM_ICE(ID_LCOMM, IDFLD, FXN, FYN, FAN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | G. Boutin | + !/ | FORTRAN 90 | + !/ | Last update : April-2016 | + !/ +-----------------------------------+ + !/ + !/ Aug-2016 : Origination (G. Boutin) ( version 5.10 ) + !/ + ! 1. Purpose : + ! + ! Receive coupling fields from ice model + ! + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ID_LCOMM Char. I MPI communicator + ! IDFLD Int. I Name of the exchange fields + ! FXN Int. I/O First exchange field + ! FYN Int. I/O Second exchange field + ! FAN Int. I/O Third exchange field + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------- + ! CPL_OASIS_RCV Subr. W3OACPMD Receive fields from ice/ocean model + ! W3S2XY Subr. W3SERVMD Convert from storage (NSEA) to spatial grid (NX, NY) + ! ------------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------ + ! W3FLDG Subr. W3FLDSMD Manage input fields of depth, + ! current, wind and ice concentration + ! ------------------------------------------------------------------ + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_RCV, RCV_FLD, CPL_OASIS_RCV + USE W3GDATMD, ONLY: NX, NY, NSEAL, NSEA, MAPSF + USE W3ODATMD, ONLY: NAPROC, IAPROC + USE W3SERVMD, ONLY: W3S2XY + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ID_LCOMM + CHARACTER(LEN=3), INTENT(IN) :: IDFLD + REAL, INTENT(INOUT) :: FXN(:,:), FYN(:,:), FAN(:,:) + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + LOGICAL :: LL_ACTION + INTEGER :: IB_DO, IB_I, IB_J, IL_ERR, NDSO + REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_RCV + REAL(kind=8), DIMENSION(NSEAL) :: TMP + REAL, DIMENSION(1:NSEA) :: SND_BUFF,RCV_BUFF + ! + !---------------------------------------------------------------------- + ! * Executable part + ! + RLA_OASIS_RCV(:,:) = 0.0 + ! + DO IB_DO = 1, IL_NB_RCV + IF (IDFLD == 'IC5') THEN + SELECT CASE (RCV_FLD(IB_DO)%CL_FIELD_NAME) + ! + ! Ice floe diameters (m) + ! ---------------------------------------------------------------------- + CASE ('WW3__IC5') + + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + END DO + ! + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) + ! + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FAN) ! - ! Ice floe diameters (m) - ! ---------------------------------------------------------------------- - CASE ('WW3__IC5') + END IF + END SELECT + ! + ! Ice Concentration + ! ---------------------------------------------------------------------- + ELSE IF (IDFLD == 'ICE') THEN + SELECT CASE (RCV_FLD(IB_DO)%CL_FIELD_NAME) + CASE ('WW3__ICE') + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + END DO + ! + ! + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) + ! + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FAN) + ! + END IF + END SELECT + ! Ice Thickness + ! ---------------------------------------------------------------------- + ELSE IF (IDFLD == 'IC1') THEN + SELECT CASE (RCV_FLD(IB_DO)%CL_FIELD_NAME) + CASE ('WW3__IC1') + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + END DO - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - END DO - ! - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FAN) - ! - END IF - END SELECT - ! - ! Ice Concentration - ! ---------------------------------------------------------------------- - ELSE IF (IDFLD == 'ICE') THEN - SELECT CASE (RCV_FLD(IB_DO)%CL_FIELD_NAME) - CASE ('WW3__ICE') - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - END DO - ! - ! - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FAN) - ! - END IF - END SELECT - ! Ice Thickness - ! ---------------------------------------------------------------------- - ELSE IF (IDFLD == 'IC1') THEN - SELECT CASE (RCV_FLD(IB_DO)%CL_FIELD_NAME) - CASE ('WW3__IC1') - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - END DO + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) + ! + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FAN) + ENDIF + ! + END SELECT - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FAN) - ENDIF - ! - END SELECT - - END IF - END DO -! + END IF + END DO + ! -!/ ------------------------------------------------------------------- / - END SUBROUTINE RCV_FIELDS_FROM_ICE -!/ ------------------------------------------------------------------- / -!/ - END MODULE W3IGCMMD + !/ ------------------------------------------------------------------- / + END SUBROUTINE RCV_FIELDS_FROM_ICE + !/ ------------------------------------------------------------------- / + !/ +END MODULE W3IGCMMD !/ !/ ------------------------------------------------------------------- / - diff --git a/model/src/w3initmd.F90 b/model/src/w3initmd.F90 index 2549454d7..af90a37dc 100644 --- a/model/src/w3initmd.F90 +++ b/model/src/w3initmd.F90 @@ -1,786 +1,783 @@ !> @file !> @brief Contains module W3INITMD. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 !> #include "w3macros.h" -!> +!> !> @brief Contains module W3INITMD. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 !> !/ ------------------------------------------------------------------- / - MODULE W3INITMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2004 : Origination (out of W3WAVEMD). ( version 3.06 ) -!/ Multiple grid version. -!/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) -!/ 04-Jan-2005 : Add grid output flags to W3INIT. ( version 3.06 ) -!/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 21-Jul-2005 : Add output fields. ( version 3.07 ) -!/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) -!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) -!/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) -!/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) -!/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ Add user-defined field data. -!/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) -!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 29-Feb-2008 : Add NEC compiler directives. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 23-Jul-2009 : Implement unstructured grids ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) -!/ Reset UST initialization. -!/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ 30-Sep-2012 : Implemetation of tidal constituents ( version 4.09 ) -!/ 07-Dec-2012 : Initialize UST non-zero. ( version 4.11 ) -!/ 12-Dec-2012 : Changes for SMC grid. JG_Li ( version 4.11 ) -!/ 26-Dec-2012 : Modify field output MPI for new ( version 4.11 ) -!/ structure and smaller memory footprint. -!/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) -!/ 10-Oct-2013 : CG and WN values at DMIN for ISEA=0 ( version 4.12 ) -!/ 14-Nov-2013 : Remove UST(DIR) initialization. ( version 4.13 ) -!/ 15-Dec-2013 : Adds fluxes to ice ( version 5.01 ) -!/ 01-May-2017 : Adds directional MSS parameters ( version 6.04 ) -!/ 05-Jun-2018 : Adds PDLIB/MEMCHECK/DEBUG ( version 6.04 ) -!/ 21-Aug-2018 : Add WBT parameter ( version 6.06 ) -!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) -!/ 25-Sep-2020 : Extra fields for coupling restart ( version 7.10 ) -!/ 22-Mar-2021 : Extra coupling fields ( version 7.13 ) -!/ 22-Jun-2021 : GKE NL5 (Q. Liu) ( version 7.13 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -!/ Note: Changes in version numbers not logged above. -!/ -! 1. Purpose : -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! CRITOS R.P. Public Critical percentage of resources used -! for output to trigger warning. -! WWVER C*10 Public Model version number. -! SWITCHES C*256 Public switches taken from bin/switch -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3INIT Subr. Public Wave model initialization. -! W3MPII Subr. Public Initialize MPI data transpose. -! W3MPIO Subr. Public Initialize MPI output gathering. -! W3MPIP Subr. Public Initialize MPI point output gathering. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! !/MPIT Enable test output (MPI). -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / +MODULE W3INITMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 28-Dec-2004 : Origination (out of W3WAVEMD). ( version 3.06 ) + !/ Multiple grid version. + !/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) + !/ 04-Jan-2005 : Add grid output flags to W3INIT. ( version 3.06 ) + !/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 21-Jul-2005 : Add output fields. ( version 3.07 ) + !/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) + !/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) + !/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) + !/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) + !/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) + !/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) + !/ Add user-defined field data. + !/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) + !/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 29-Feb-2008 : Add NEC compiler directives. ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 23-Jul-2009 : Implement unstructured grids ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) + !/ Reset UST initialization. + !/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) + !/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) + !/ 30-Sep-2012 : Implemetation of tidal constituents ( version 4.09 ) + !/ 07-Dec-2012 : Initialize UST non-zero. ( version 4.11 ) + !/ 12-Dec-2012 : Changes for SMC grid. JG_Li ( version 4.11 ) + !/ 26-Dec-2012 : Modify field output MPI for new ( version 4.11 ) + !/ structure and smaller memory footprint. + !/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) + !/ 10-Oct-2013 : CG and WN values at DMIN for ISEA=0 ( version 4.12 ) + !/ 14-Nov-2013 : Remove UST(DIR) initialization. ( version 4.13 ) + !/ 15-Dec-2013 : Adds fluxes to ice ( version 5.01 ) + !/ 01-May-2017 : Adds directional MSS parameters ( version 6.04 ) + !/ 05-Jun-2018 : Adds PDLIB/MEMCHECK/DEBUG ( version 6.04 ) + !/ 21-Aug-2018 : Add WBT parameter ( version 6.06 ) + !/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) + !/ 25-Sep-2020 : Extra fields for coupling restart ( version 7.10 ) + !/ 22-Mar-2021 : Extra coupling fields ( version 7.13 ) + !/ 22-Jun-2021 : GKE NL5 (Q. Liu) ( version 7.13 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + !/ Note: Changes in version numbers not logged above. + !/ + ! 1. Purpose : + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! CRITOS R.P. Public Critical percentage of resources used + ! for output to trigger warning. + ! WWVER C*10 Public Model version number. + ! SWITCHES C*256 Public switches taken from bin/switch + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. Public Wave model initialization. + ! W3MPII Subr. Public Initialize MPI data transpose. + ! W3MPIO Subr. Public Initialize MPI output gathering. + ! W3MPIP Subr. Public Initialize MPI point output gathering. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! !/MPIT Enable test output (MPI). + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / ! module default IMPLICIT NONE PUBLIC -!/ - REAL, PARAMETER :: CRITOS = 15. - CHARACTER(LEN=10), PARAMETER :: WWVER = '7.14 ' - CHARACTER(LEN=512), PARAMETER :: SWITCHES = & - __WW3_SWITCHES__ -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize WAVEWATCH III. -!> -!> @details Initialize data structure and wave fields from data files. -!> Initialize grid from local and instantaneous data. -!> -!> @param[in] IMOD Model number. -!> @param[in] IsMulti -!> @param[in] FEXT Extension of data files. -!> @param[in] MDS Array with dataset numbers saved as NDS in W3ODATMD. -!> @param[in] MTRACE Array with subroutine tracing information. -!> @param[in] ODAT Output data, five parameters per output type. -!> @param[inout] FLGRD Flags for gridded output. -!> @param[inout] FLGR2 Flags for coupling output. -!> @param[inout] FLGD -!> @param[inout] FLG2 -!> @param[in] NPT Number of output points. -!> @param[inout] XPT Coordinates of output points. -!> @param[inout] YPT Coordinates of output points. -!> @param[in] PNAMES Output point names. -!> @param[in] IPRT Partitioning grid info. -!> @param[inout] PRTFRM Partitioning format flag. -!> @param[in] MPI_COMM MPI communicator to be used for model. -!> @param[in] FLAGSTIDEIN -!> -!> @author H. L. Tolman @date 03-Sep-2012 -!> - SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & - , FLGRD, & - FLGR2, FLGD, FLG2, NPT, XPT, YPT, PNAMES, & - IPRT, PRTFRM, MPI_COMM, FLAGSTIDEIN) - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 03-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 24-Jan-2002 : Zero time step for data ass. ( version 2.17 ) -!/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ Taken out of W3WAVE. -!/ 04-Jan-2005 : Add grid output flags to par list. ( version 3.06 ) -!/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) -!/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) -!/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) -!/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) -!/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) -!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 -!/ 13-Sep-2009 : Add coupling option ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.1 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) -!/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ -! 1. Purpose : -! -! Initialize WAVEWATCH III. -! -! 2. Method : -! -! Initialize data structure and wave fields from data files. -! Initialize grid from local and instantaneous data. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! FEXT Char I Extension of data files. -! MDS I.A. I Array with dataset numbers (see below), -! saved as NDS in W3ODATMD. -! 1: General output unit number ("log file"). -! 2: Error output unit number. -! 3: Test output unit number. -! 4: "screen", i.e., direct output location, -! can be the screen or the output file of -! the shell. -! 5: Model definition file unit number. -! 6: Restart file unit number. -! 7: Grid output file unit number. -! 8: Point output file unit number. -! 9: Input boundary data file unit number. -! 10: Output boundary data file unit number -! (first). -! 11: Track information file unit number. -! 12: Track output file unit number. -! MTRACE I.A. I Array with subroutine tracing information. -! 1: Output unit number for trace. -! 2: Maximum number of trace prints. -! ODAT I.A. I Output data, five parameters per output type -! 1-5 Data for OTYPE = 1; gridded fields. -! 1 YYYMMDD for first output. -! 2 HHMMSS for first output. -! 3 Output interval in seconds. -! 4 YYYMMDD for last output. -! 5 HHMMSS for last output. -! 6-10 Id. for OTYPE = 2; point output. -! 11-15 Id. for OTYPE = 3; track point output. -! 16-20 Id. for OTYPE = 4; restart files. -! 21-25 Id. for OTYPE = 5; boundary data. -! 31-35 Id. for OTYPE = 7; coupling data. -! 36-40 Id. for OTYPE = 8; second restart file -! FLGRD L.A. I Flags for gridded output. -! FLGR2 L.A. I Flags for coupling output. -! NPT Int. I Number of output points -! X/YPT R.A. I Coordinates of output points. -! PNAMES C.A. I Output point names. -! IPRT I.A. I Partitioning grid info. -! PRTFRM I.A. I Partitioning format flag. -! MPI_COMM Int. I MPI communicator to be used for model. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to data structure. -! W3SETW Subr. W3WDATMD Point to data structure. -! W3DIMW Subr. Id. Set array sizes in data structure. -! W3SETA Subr. W3ADATMD Point to data structure. -! W3DIMA Subr. Id. Set array sizes in data structure. -! W3SETI Subr. W3IDATMD Point to data structure. -! W3DIMI Subr. Id. Set array sizes in data structure. -! W3SETO Subr. W3ODATMD Point to data structure. -! W3DMO5 Subr. Id. Set array sizes in data structure. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! WWDATE Subr. Id. System date. -! WWTIME Subr. Id. System time. -! DSEC21 Func. W3TIMEMD Compute time difference. -! TICK21 Func. Id. Advance the clock. -! STME21 Func. Id. Print the time readable. -! PRTBLK Func. W3ARRYMD Print plot of array. -! W3IOGR Subr. W3IOGRMD Read/write model definition file. -! W3IORS Subr. W3IORSMD Read/write restart file. -! W3IOPP Subr. W3IOPOMD Preprocess point output. -! CALL MPI_COMM_SIZE, CALL MPI_COMM_RANK -! Subr. mpif.h Standard MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any program shell or integrated model which uses WAVEWATCH III. -! -! 6. Error messages : -! -! On opening of log file only. Other error messages are generated -! by W3IOGR and W3IORS. -! -! 7. Remarks : -! -! - The log file is called 'log.FEXT', where FEXT is passed to -! the routine. -! - The test output file is called 'test.FEXT' in shared memory -! version or testNNN.FEXT in distributed memory version. -! - A water level and ice coverage are transferred with the -! restart file. To assure consistency within the model, the -! water level and ice coverage are re-evaluated at the 0th -! time step in the actual wave model routine. -! - When running regtests in cases where disk is non-local -! (i.e. NFS used), there can be a huge improvment in compute -! time by using /var/tmp/ for log files. -! See commented line at "OPEN (MDS(1),FILE=..." -! -! 8. Structure : -! -! ---------------------------------------------------- -! 1. Set-up of idata structures and I/O. -! a Point to proper data structures. -! b Number of processors and processor number. -! c Open files. -! d Dataset unit numbers -! e Subroutine tracing -! f Initial and test outputs -! 2. Model definition. -! a Read model definition file ( W3IOGR ) -! b Save MAPSTA. -! c MPP preparation -! 3. Model initialization. -! a Read restart file. ( W3IORS ) -! b Compare grid and restart MAPSTA. -! c Initialize with winds if requested (set flag). -! d Initialize calm conditions if requested. -! e Preparations for prop. scheme. -! 4. Set-up output times. -! a Unpack ODAT. -! b Check if output available. -! c Get first time per output and overall. -! d Prepare point output ( W3IOPP ) -! 5. Define wavenumber grid. -! a Calculate depth. -! b Fill wavenumber and group velocity arrays. -! 6. Initialize arrays. -! 7. Write info to log file. -! 8. Final MPI set up ( W3MPII , W3MPIO , W3MPIP ) -! ---------------------------------------------------- -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS + !/ + REAL, PARAMETER :: CRITOS = 15. + CHARACTER(LEN=10), PARAMETER :: WWVER = '7.14 ' + CHARACTER(LEN=512), PARAMETER :: SWITCHES = & + __WW3_SWITCHES__ + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize WAVEWATCH III. + !> + !> @details Initialize data structure and wave fields from data files. + !> Initialize grid from local and instantaneous data. + !> + !> @param[in] IMOD Model number. + !> @param[in] IsMulti + !> @param[in] FEXT Extension of data files. + !> @param[in] MDS Array with dataset numbers saved as NDS in W3ODATMD. + !> @param[in] MTRACE Array with subroutine tracing information. + !> @param[in] ODAT Output data, five parameters per output type. + !> @param[inout] FLGRD Flags for gridded output. + !> @param[inout] FLGR2 Flags for coupling output. + !> @param[inout] FLGD + !> @param[inout] FLG2 + !> @param[in] NPT Number of output points. + !> @param[inout] XPT Coordinates of output points. + !> @param[inout] YPT Coordinates of output points. + !> @param[in] PNAMES Output point names. + !> @param[in] IPRT Partitioning grid info. + !> @param[inout] PRTFRM Partitioning format flag. + !> @param[in] MPI_COMM MPI communicator to be used for model. + !> @param[in] FLAGSTIDEIN + !> + !> @author H. L. Tolman @date 03-Sep-2012 + !> + SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & + , FLGRD, & + FLGR2, FLGD, FLG2, NPT, XPT, YPT, PNAMES, & + IPRT, PRTFRM, MPI_COMM, FLAGSTIDEIN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 03-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 24-Jan-2002 : Zero time step for data ass. ( version 2.17 ) + !/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 20-Aug-2003 : Output server options added. ( version 3.04 ) + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ Taken out of W3WAVE. + !/ 04-Jan-2005 : Add grid output flags to par list. ( version 3.06 ) + !/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) + !/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) + !/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) + !/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) + !/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) + !/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 + !/ 13-Sep-2009 : Add coupling option ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.1 ) + !/ (A. Roland and F. Ardhuin) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) + !/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) + !/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) + !/ + ! 1. Purpose : + ! + ! Initialize WAVEWATCH III. + ! + ! 2. Method : + ! + ! Initialize data structure and wave fields from data files. + ! Initialize grid from local and instantaneous data. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! FEXT Char I Extension of data files. + ! MDS I.A. I Array with dataset numbers (see below), + ! saved as NDS in W3ODATMD. + ! 1: General output unit number ("log file"). + ! 2: Error output unit number. + ! 3: Test output unit number. + ! 4: "screen", i.e., direct output location, + ! can be the screen or the output file of + ! the shell. + ! 5: Model definition file unit number. + ! 6: Restart file unit number. + ! 7: Grid output file unit number. + ! 8: Point output file unit number. + ! 9: Input boundary data file unit number. + ! 10: Output boundary data file unit number + ! (first). + ! 11: Track information file unit number. + ! 12: Track output file unit number. + ! MTRACE I.A. I Array with subroutine tracing information. + ! 1: Output unit number for trace. + ! 2: Maximum number of trace prints. + ! ODAT I.A. I Output data, five parameters per output type + ! 1-5 Data for OTYPE = 1; gridded fields. + ! 1 YYYMMDD for first output. + ! 2 HHMMSS for first output. + ! 3 Output interval in seconds. + ! 4 YYYMMDD for last output. + ! 5 HHMMSS for last output. + ! 6-10 Id. for OTYPE = 2; point output. + ! 11-15 Id. for OTYPE = 3; track point output. + ! 16-20 Id. for OTYPE = 4; restart files. + ! 21-25 Id. for OTYPE = 5; boundary data. + ! 31-35 Id. for OTYPE = 7; coupling data. + ! 36-40 Id. for OTYPE = 8; second restart file + ! FLGRD L.A. I Flags for gridded output. + ! FLGR2 L.A. I Flags for coupling output. + ! NPT Int. I Number of output points + ! X/YPT R.A. I Coordinates of output points. + ! PNAMES C.A. I Output point names. + ! IPRT I.A. I Partitioning grid info. + ! PRTFRM I.A. I Partitioning format flag. + ! MPI_COMM Int. I MPI communicator to be used for model. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to data structure. + ! W3SETW Subr. W3WDATMD Point to data structure. + ! W3DIMW Subr. Id. Set array sizes in data structure. + ! W3SETA Subr. W3ADATMD Point to data structure. + ! W3DIMA Subr. Id. Set array sizes in data structure. + ! W3SETI Subr. W3IDATMD Point to data structure. + ! W3DIMI Subr. Id. Set array sizes in data structure. + ! W3SETO Subr. W3ODATMD Point to data structure. + ! W3DMO5 Subr. Id. Set array sizes in data structure. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! WWDATE Subr. Id. System date. + ! WWTIME Subr. Id. System time. + ! DSEC21 Func. W3TIMEMD Compute time difference. + ! TICK21 Func. Id. Advance the clock. + ! STME21 Func. Id. Print the time readable. + ! PRTBLK Func. W3ARRYMD Print plot of array. + ! W3IOGR Subr. W3IOGRMD Read/write model definition file. + ! W3IORS Subr. W3IORSMD Read/write restart file. + ! W3IOPP Subr. W3IOPOMD Preprocess point output. + ! CALL MPI_COMM_SIZE, CALL MPI_COMM_RANK + ! Subr. mpif.h Standard MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any program shell or integrated model which uses WAVEWATCH III. + ! + ! 6. Error messages : + ! + ! On opening of log file only. Other error messages are generated + ! by W3IOGR and W3IORS. + ! + ! 7. Remarks : + ! + ! - The log file is called 'log.FEXT', where FEXT is passed to + ! the routine. + ! - The test output file is called 'test.FEXT' in shared memory + ! version or testNNN.FEXT in distributed memory version. + ! - A water level and ice coverage are transferred with the + ! restart file. To assure consistency within the model, the + ! water level and ice coverage are re-evaluated at the 0th + ! time step in the actual wave model routine. + ! - When running regtests in cases where disk is non-local + ! (i.e. NFS used), there can be a huge improvment in compute + ! time by using /var/tmp/ for log files. + ! See commented line at "OPEN (MDS(1),FILE=..." + ! + ! 8. Structure : + ! + ! ---------------------------------------------------- + ! 1. Set-up of idata structures and I/O. + ! a Point to proper data structures. + ! b Number of processors and processor number. + ! c Open files. + ! d Dataset unit numbers + ! e Subroutine tracing + ! f Initial and test outputs + ! 2. Model definition. + ! a Read model definition file ( W3IOGR ) + ! b Save MAPSTA. + ! c MPP preparation + ! 3. Model initialization. + ! a Read restart file. ( W3IORS ) + ! b Compare grid and restart MAPSTA. + ! c Initialize with winds if requested (set flag). + ! d Initialize calm conditions if requested. + ! e Preparations for prop. scheme. + ! 4. Set-up output times. + ! a Unpack ODAT. + ! b Check if output available. + ! c Get first time per output and overall. + ! d Prepare point output ( W3IOPP ) + ! 5. Define wavenumber grid. + ! a Calculate depth. + ! b Fill wavenumber and group velocity arrays. + ! 6. Initialize arrays. + ! 7. Write info to log file. + ! 8. Final MPI set up ( W3MPII , W3MPIO , W3MPIP ) + ! ---------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS #ifdef W3_MEMCHECK - USE MallocInfo_m + USE MallocInfo_m #endif -!/ - USE W3GDATMD, ONLY: W3SETG, RSTYPE - USE W3WDATMD, ONLY: W3SETW, W3DIMW - USE W3ADATMD, ONLY: W3SETA, W3DIMA + !/ + USE W3GDATMD, ONLY: W3SETG, RSTYPE + USE W3WDATMD, ONLY: W3SETW, W3DIMW + USE W3ADATMD, ONLY: W3SETA, W3DIMA #ifdef W3_MEMCHECK - USE W3ADATMD, ONLY: MALLINFOS -#endif - USE W3IDATMD, ONLY: W3SETI, W3DIMI - USE W3ODATMD, ONLY: W3SETO, W3DMO5 - USE W3IOGOMD, ONLY: W3FLGRDUPDT - USE W3IOGRMD, ONLY: W3IOGR - USE W3IORSMD, ONLY: W3IORS - USE W3IOPOMD, ONLY: W3IOPP - USE W3SERVMD, ONLY: ITRACE, EXTCDE, WWDATE, WWTIME + USE W3ADATMD, ONLY: MALLINFOS +#endif + USE W3IDATMD, ONLY: W3SETI, W3DIMI + USE W3ODATMD, ONLY: W3SETO, W3DMO5 + USE W3IOGOMD, ONLY: W3FLGRDUPDT + USE W3IOGRMD, ONLY: W3IOGR + USE W3IORSMD, ONLY: W3IORS + USE W3IOPOMD, ONLY: W3IOPP + USE W3SERVMD, ONLY: ITRACE, EXTCDE, WWDATE, WWTIME #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3TIMEMD, ONLY: DSEC21, TICK21, STME21 - USE W3ARRYMD, ONLY: PRTBLK -!/ - USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSTA, MAPST2, MAPFS, & - MAPSF, FLAGLL, & - ICLOSE, ZB, TRNX, TRNY, DMIN, DTCFL, DTMAX, & - FLCK, NK, NTH, NSPEC, SIG, GNAME + USE W3SERVMD, ONLY: STRACE +#endif + USE W3TIMEMD, ONLY: DSEC21, TICK21, STME21 + USE W3ARRYMD, ONLY: PRTBLK + !/ + USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSTA, MAPST2, MAPFS, & + MAPSF, FLAGLL, & + ICLOSE, ZB, TRNX, TRNY, DMIN, DTCFL, DTMAX, & + FLCK, NK, NTH, NSPEC, SIG, GNAME #ifdef W3_PDLIB - USE W3GDATMD, ONLY : FLCTH -#endif - USE W3WDATMD, ONLY: TIME, TLEV, TICE, TRHO, WLV, UST, USTDIR, VA - USE W3ODATMD, ONLY: NDSO, NDSE, NDST, SCREEN, NDS, NTPROC, & - NAPROC, IAPROC, NAPLOG, NAPOUT, NAPERR, & - NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, & - NAPPRT, TOFRST, DTOUT, TONEXT, TOLAST, & - FLOUT, FLOGRD, FLBPO, NOPTS, PTNME, & - PTLOC, IPTINT, PTIFAC, UNDEF, IDOUT, FLBPI, & - OUTPTS, FNMPRE, IX0, IXN, IXS, IY0, IYN, & - IYS, FLFORM, IOSTYP, UNIPTS, UPPROC, NOTYPE,& - FLOGR2, NOGRP, NGRPP, FLOGD, FLOG2 + USE W3GDATMD, ONLY : FLCTH +#endif + USE W3WDATMD, ONLY: TIME, TLEV, TICE, TRHO, WLV, UST, USTDIR, VA + USE W3ODATMD, ONLY: NDSO, NDSE, NDST, SCREEN, NDS, NTPROC, & + NAPROC, IAPROC, NAPLOG, NAPOUT, NAPERR, & + NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, & + NAPPRT, TOFRST, DTOUT, TONEXT, TOLAST, & + FLOUT, FLOGRD, FLBPO, NOPTS, PTNME, & + PTLOC, IPTINT, PTIFAC, UNDEF, IDOUT, FLBPI, & + OUTPTS, FNMPRE, IX0, IXN, IXS, IY0, IYN, & + IYS, FLFORM, IOSTYP, UNIPTS, UPPROC, NOTYPE,& + FLOGR2, NOGRP, NGRPP, FLOGD, FLOG2 #ifdef W3_NL5 - USE W3ODATMD, ONLY: TOSNL5 + USE W3ODATMD, ONLY: TOSNL5 #endif - USE W3ADATMD, ONLY: NSEALM, IAPPRO, FLCOLD, FLIWND, DW, CG, WN, & - UA, UD, U10, U10D, AS + USE W3ADATMD, ONLY: NSEALM, IAPPRO, FLCOLD, FLIWND, DW, CG, WN, & + UA, UD, U10, U10D, AS #ifdef W3_MPI - USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP + USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP #endif - USE W3IDATMD, ONLY: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, FLRHOA,& - FLMDN, FLMTH, FLMVS, FLIC1, FLIC2, FLIC3, & - FLIC4, FLIC5 - USE W3DISPMD, ONLY: WAVNU1, WAVNU3 - USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM + USE W3IDATMD, ONLY: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, FLRHOA,& + FLMDN, FLMTH, FLMVS, FLIC1, FLIC2, FLIC3, & + FLIC4, FLIC5 + USE W3DISPMD, ONLY: WAVNU1, WAVNU3 + USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM #ifdef W3_PDLIB - USE W3PARALL, ONLY: SYNCHRONIZE_IPGL_ETC_ARRAY, ISEA_TO_JSEA - use yowNodepool, only: npa - use yowRankModule, only : rank + USE W3PARALL, ONLY: SYNCHRONIZE_IPGL_ETC_ARRAY, ISEA_TO_JSEA + use yowNodepool, only: npa + use yowRankModule, only : rank #endif - USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE W3GDATMD, ONLY: GTYPE, UNGTYPE #ifdef W3_PDLIB - USE PDLIB_W3PROFSMD, ONLY : PDLIB_MAPSTA_INIT, SET_IOBDP_PDLIB, PDLIB_IOBP_INIT, SET_IOBPA_PDLIB - USE PDLIB_W3PROFSMD, ONLY : BLOCK_SOLVER_INIT, PDLIB_INIT, DEALLOCATE_PDLIB_GLOBAL - use yowDatapool, only: istatus + USE PDLIB_W3PROFSMD, ONLY : PDLIB_MAPSTA_INIT, SET_IOBDP_PDLIB, PDLIB_IOBP_INIT, SET_IOBPA_PDLIB + USE PDLIB_W3PROFSMD, ONLY : BLOCK_SOLVER_INIT, PDLIB_INIT, DEALLOCATE_PDLIB_GLOBAL + use yowDatapool, only: istatus #endif #ifdef W3_SETUP - USE W3WAVSET, ONLY : PREPARATION_FD_SCHEME - USE W3WDATMD, ONLY: ZETA_SETUP - USE W3GDATMD, ONLY : DO_CHANGE_WLV -#endif - USE W3TRIAMD, ONLY: NVECTRI, AREA_SI, COORDMAX, SPATIAL_GRID - USE W3GDATMD, ONLY: FSN,FSPSI,FSFCT,FSNIMP, FSTOTALIMP, FSTOTALEXP, XGRD, YGRD - USE W3GDATMD, ONLY: FSREFRACTION, FSFREQSHIFT - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC, INIT_GET_ISEA + USE W3WAVSET, ONLY : PREPARATION_FD_SCHEME + USE W3WDATMD, ONLY: ZETA_SETUP + USE W3GDATMD, ONLY : DO_CHANGE_WLV +#endif + USE W3TRIAMD, ONLY: NVECTRI, AREA_SI, COORDMAX, SPATIAL_GRID + USE W3GDATMD, ONLY: FSN,FSPSI,FSFCT,FSNIMP, FSTOTALIMP, FSTOTALEXP, XGRD, YGRD + USE W3GDATMD, ONLY: FSREFRACTION, FSFREQSHIFT + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC, INIT_GET_ISEA #ifdef W3_TIMINGS - USE W3PARALL, ONLY: PRINT_MY_TIME + USE W3PARALL, ONLY: PRINT_MY_TIME #endif -#ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - USE PDLIB_W3PROFSMD, ONLY: ALL_VA_INTEGRAL_PRINT, TEST_MPI_STATUS +#if defined W3_PDLIB && defined W3_DEBUGCOH + USE PDLIB_W3PROFSMD, ONLY: ALL_VA_INTEGRAL_PRINT, TEST_MPI_STATUS #endif -#ifdef W3_DEBUGINIT +#if defined W3_PDLIB && defined W3_DEBUGINIT USE PDLIB_W3PROFSMD, ONLY: PRINT_WN_STATISTIC #endif -#endif #ifdef W3_UOST - USE W3UOSTMD, ONLY: UOST_SETGRID -#endif -!/ -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, MDS(13), MTRACE(2), & - ODAT(40),NPT, IPRT(6),& - MPI_COMM - LOGICAL, INTENT(IN) :: IsMulti - REAL, INTENT(INOUT) :: XPT(NPT), YPT(NPT) - LOGICAL, INTENT(INOUT) :: FLGRD(NOGRP,NGRPP), FLGD(NOGRP),& - FLGR2(NOGRP,NGRPP), FLG2(NOGRP),& - PRTFRM - CHARACTER, INTENT(IN) :: FEXT*(*) - CHARACTER(LEN=40), INTENT(IN) :: PNAMES(NPT) - LOGICAL, INTENT(IN), OPTIONAL :: FLAGSTIDEIN(4) - INTEGER :: NSEALout, NSEALMout -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - integer :: IRANK, I, ISTAT - INTEGER :: IE, IFL, IFT, IERR, NTTOT, NTLOC, & - NTTARG, IK, IP, ITH, IX, IY, & - J, J0, TOUT(2), TLST(2), ISEA, IS, & - K, I1, I2, JSEA, NTTMAX + USE W3UOSTMD, ONLY: UOST_SETGRID +#endif + !/ +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, MDS(13), MTRACE(2), & + ODAT(40),NPT, IPRT(6),& + MPI_COMM + LOGICAL, INTENT(IN) :: IsMulti + REAL, INTENT(INOUT) :: XPT(NPT), YPT(NPT) + LOGICAL, INTENT(INOUT) :: FLGRD(NOGRP,NGRPP), FLGD(NOGRP),& + FLGR2(NOGRP,NGRPP), FLG2(NOGRP),& + PRTFRM + CHARACTER, INTENT(IN) :: FEXT*(*) + CHARACTER(LEN=40), INTENT(IN) :: PNAMES(NPT) + LOGICAL, INTENT(IN), OPTIONAL :: FLAGSTIDEIN(4) + INTEGER :: NSEALout, NSEALMout + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + integer :: IRANK, I, ISTAT + INTEGER :: IE, IFL, IFT, IERR, NTTOT, NTLOC, & + NTTARG, IK, IP, ITH, IX, IY, & + J, J0, TOUT(2), TLST(2), ISEA, IS, & + K, I1, I2, JSEA, NTTMAX #ifdef W3_DIST - INTEGER :: ISTEP, ISP, IW + INTEGER :: ISTEP, ISP, IW #endif #ifdef W3_MPI - INTEGER :: IERR_MPI, BGROUP, LGROUP + INTEGER :: IERR_MPI, BGROUP, LGROUP #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T - INTEGER :: NX0, NXN - INTEGER, ALLOCATABLE :: MAPOUT(:,:) + INTEGER :: NX0, NXN + INTEGER, ALLOCATABLE :: MAPOUT(:,:) #endif #ifdef W3_MPI - INTEGER, ALLOCATABLE :: TMPRNK(:) + INTEGER, ALLOCATABLE :: TMPRNK(:) #endif - INTEGER, ALLOCATABLE :: NT(:), MAPTST(:,:) + INTEGER, ALLOCATABLE :: NT(:), MAPTST(:,:) #ifdef W3_T - INTEGER, SAVE :: NXS = 49 + INTEGER, SAVE :: NXS = 49 #endif - REAL :: DTTST, DEPTH, FRACOS - REAL :: FACTOR - REAL :: WLVeff + REAL :: DTTST, DEPTH, FRACOS + REAL :: FACTOR + REAL :: WLVeff #ifdef W3_T - REAL, ALLOCATABLE :: XOUT(:,:) + REAL, ALLOCATABLE :: XOUT(:,:) #endif - LOGICAL :: OPENED - CHARACTER(LEN=8) :: STTIME - CHARACTER(LEN=10) :: STDATE - INTEGER :: ISPROC + LOGICAL :: OPENED + CHARACTER(LEN=8) :: STTIME + CHARACTER(LEN=10) :: STDATE + INTEGER :: ISPROC #ifdef W3_DIST - CHARACTER(LEN=12) :: FORMAT + CHARACTER(LEN=12) :: FORMAT #endif - CHARACTER(LEN=23) :: DTME21 - CHARACTER(LEN=30) :: LFILE, TFILE + CHARACTER(LEN=23) :: DTME21 + CHARACTER(LEN=30) :: LFILE, TFILE #ifdef W3_PDLIB - INTEGER :: IScal(1), IPROC -#endif -!/ -!/ ------------------------------------------------------------------- / -! -! 1. Set-up of data structures and I/O ----------------------------- / -! 1.a Point to proper data structures. -! + INTEGER :: IScal(1), IPROC +#endif + !/ + !/ ------------------------------------------------------------------- / + ! + ! 1. Set-up of data structures and I/O ----------------------------- / + ! 1.a Point to proper data structures. + ! #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif - CALL W3SETO ( IMOD, MDS(2), MDS(3) ) + CALL W3SETO ( IMOD, MDS(2), MDS(3) ) #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1a' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1a' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif - CALL W3SETG ( IMOD, MDS(2), MDS(3) ) + CALL W3SETG ( IMOD, MDS(2), MDS(3) ) #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1b' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1b' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif - CALL W3SETW ( IMOD, MDS(2), MDS(3) ) + CALL W3SETW ( IMOD, MDS(2), MDS(3) ) #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1c' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1c' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif - CALL W3SETA ( IMOD, MDS(2), MDS(3) ) + CALL W3SETA ( IMOD, MDS(2), MDS(3) ) #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1d' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1d' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif - CALL W3SETI ( IMOD, MDS(2), MDS(3) ) + CALL W3SETI ( IMOD, MDS(2), MDS(3) ) #ifdef W3_UOST - CALL UOST_SETGRID(IMOD) + CALL UOST_SETGRID(IMOD) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Case 2") + CALL PRINT_MY_TIME("Case 2") #endif #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1e' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -! -! 1.b Number of processors and processor number. -! Overwrite some initializations from W3ODATMD. -! -! ******************************************************* -! *** NOTE : OUTPUT PROCESSOR ASSIGNMENT NEEDS TO BE *** -! *** CONSISTENT WITH ASSIGNMENT IN WMINIT. *** -! ******************************************************* -! + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1e' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) +#endif + ! + ! + ! 1.b Number of processors and processor number. + ! Overwrite some initializations from W3ODATMD. + ! + ! ******************************************************* + ! *** NOTE : OUTPUT PROCESSOR ASSIGNMENT NEEDS TO BE *** + ! *** CONSISTENT WITH ASSIGNMENT IN WMINIT. *** + ! ******************************************************* + ! #ifdef W3_SHRD - NTPROC = 1 - NAPROC = 1 - IAPROC = 1 - IOSTYP = 1 -#endif -! -#ifdef W3_MPI - MPI_COMM_WAVE = MPI_COMM - CALL MPI_COMM_SIZE ( MPI_COMM_WAVE, NTPROC, IERR_MPI ) - NAPROC = NTPROC - CALL MPI_COMM_RANK ( MPI_COMM_WAVE, IAPROC, IERR_MPI ) - IAPROC = IAPROC + 1 -#endif -! - IF ( IOSTYP .LE. 1 ) THEN -! - NAPFLD = MAX(1,NAPROC-1) - NAPPNT = MAX(1,NAPROC-2) - NAPTRK = MAX(1,NAPROC-5) - NAPRST = NAPROC - NAPBPT = MAX(1,NAPROC-3) - NAPPRT = MAX(1,NAPROC-4) -! - ELSE -! - NAPPNT = NAPROC - IF ( UNIPTS .AND. UPPROC ) NAPROC = MAX(1,NTPROC - 1) - NAPFLD = NAPROC - NAPRST = NAPROC - NAPBPT = NAPROC - NAPTRK = NAPROC - NAPPRT = NAPROC -! - IF ( IOSTYP .EQ. 2 ) THEN - NAPROC = MAX(1,NAPROC-1) - ELSE IF ( IOSTYP .EQ. 3 ) THEN -! -! For field or coupling output -! - IF ( ODAT( 3).GT.0 .OR. ODAT(33).GT.0 ) THEN - NAPFLD = NAPROC - NAPROC = MAX(1,NAPROC-1) - END IF - IF ( ODAT(13).GT.0 ) THEN - NAPTRK = NAPROC - NAPROC = MAX(1,NAPROC-1) - END IF - IF ( ODAT(28).GT.0 ) THEN - NAPPRT = NAPROC - NAPROC = MAX(1,NAPROC-1) - END IF - IF ( ODAT( 8).GT.0 ) NAPPNT = NAPROC - IF ( ODAT(18).GT.0 ) NAPRST = NAPROC - IF ( ODAT(23).GT.0 ) NAPBPT = NAPROC - IF ( ( ODAT( 8).GT.0 .OR. ODAT(18).GT.0 .OR. & - ODAT(23).GT.0 ) ) NAPROC = MAX(1,NAPROC-1) - END IF + NTPROC = 1 + NAPROC = 1 + IAPROC = 1 + IOSTYP = 1 +#endif + ! +#ifdef W3_MPI + MPI_COMM_WAVE = MPI_COMM + CALL MPI_COMM_SIZE ( MPI_COMM_WAVE, NTPROC, IERR_MPI ) + NAPROC = NTPROC + CALL MPI_COMM_RANK ( MPI_COMM_WAVE, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 +#endif + ! + IF ( IOSTYP .LE. 1 ) THEN + ! + NAPFLD = MAX(1,NAPROC-1) + NAPPNT = MAX(1,NAPROC-2) + NAPTRK = MAX(1,NAPROC-5) + NAPRST = NAPROC + NAPBPT = MAX(1,NAPROC-3) + NAPPRT = MAX(1,NAPROC-4) + ! + ELSE + ! + NAPPNT = NAPROC + IF ( UNIPTS .AND. UPPROC ) NAPROC = MAX(1,NTPROC - 1) + NAPFLD = NAPROC + NAPRST = NAPROC + NAPBPT = NAPROC + NAPTRK = NAPROC + NAPPRT = NAPROC + ! + IF ( IOSTYP .EQ. 2 ) THEN + NAPROC = MAX(1,NAPROC-1) + ELSE IF ( IOSTYP .EQ. 3 ) THEN + ! + ! For field or coupling output + ! + IF ( ODAT( 3).GT.0 .OR. ODAT(33).GT.0 ) THEN + NAPFLD = NAPROC + NAPROC = MAX(1,NAPROC-1) END IF -! - FRACOS = 100. * REAL(NTPROC-NAPROC) / REAL(NTPROC) - IF ( FRACOS.GT.CRITOS .AND. IAPROC.EQ.NAPERR ) & - WRITE (NDSE,8002) FRACOS -! -#ifdef W3_MPI - IF ( NAPROC .EQ. NTPROC ) THEN - MPI_COMM_WCMP = MPI_COMM_WAVE - ELSE - CALL MPI_COMM_GROUP ( MPI_COMM_WAVE, BGROUP, IERR_MPI ) - ALLOCATE ( TMPRNK(NAPROC) ) - DO J=1, NAPROC - TMPRNK(J) = J - 1 - END DO - CALL MPI_GROUP_INCL ( BGROUP, NAPROC, TMPRNK, LGROUP, & - IERR_MPI ) - CALL MPI_COMM_CREATE ( MPI_COMM_WAVE, LGROUP, & - MPI_COMM_WCMP, IERR_MPI ) - CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) - CALL MPI_GROUP_FREE ( BGROUP, IERR_MPI ) - DEALLOCATE ( TMPRNK ) + IF ( ODAT(13).GT.0 ) THEN + NAPTRK = NAPROC + NAPROC = MAX(1,NAPROC-1) + END IF + IF ( ODAT(28).GT.0 ) THEN + NAPPRT = NAPROC + NAPROC = MAX(1,NAPROC-1) + END IF + IF ( ODAT( 8).GT.0 ) NAPPNT = NAPROC + IF ( ODAT(18).GT.0 ) NAPRST = NAPROC + IF ( ODAT(23).GT.0 ) NAPBPT = NAPROC + IF ( ( ODAT( 8).GT.0 .OR. ODAT(18).GT.0 .OR. & + ODAT(23).GT.0 ) ) NAPROC = MAX(1,NAPROC-1) END IF + END IF + ! + FRACOS = 100. * REAL(NTPROC-NAPROC) / REAL(NTPROC) + IF ( FRACOS.GT.CRITOS .AND. IAPROC.EQ.NAPERR ) & + WRITE (NDSE,8002) FRACOS + ! +#ifdef W3_MPI + IF ( NAPROC .EQ. NTPROC ) THEN + MPI_COMM_WCMP = MPI_COMM_WAVE + ELSE + CALL MPI_COMM_GROUP ( MPI_COMM_WAVE, BGROUP, IERR_MPI ) + ALLOCATE ( TMPRNK(NAPROC) ) + DO J=1, NAPROC + TMPRNK(J) = J - 1 + END DO + CALL MPI_GROUP_INCL ( BGROUP, NAPROC, TMPRNK, LGROUP, & + IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_WAVE, LGROUP, & + MPI_COMM_WCMP, IERR_MPI ) + CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) + CALL MPI_GROUP_FREE ( BGROUP, IERR_MPI ) + DEALLOCATE ( TMPRNK ) + END IF #endif -! - LPDLIB = .FALSE. + ! + LPDLIB = .FALSE. #ifdef W3_PDLIB LPDLIB = .TRUE. #endif - IF (FSTOTALIMP .and. .NOT. LPDLIB) THEN - WRITE(NDSE,*) 'IMPTOTAL is selected' - WRITE(NDSE,*) 'But PDLIB is not' - STOP 'Stop, case 1' - ELSE IF (FSTOTALEXP .and. .NOT. LPDLIB) THEN - WRITE(NDSE,*) 'EXPTOTAL is selected' - WRITE(NDSE,*) 'But PDLIB is not' - STOP 'Stop, case 1' - END IF -! -! 1.c Open files without unpacking MDS ,,, -! - IE = LEN_TRIM(FEXT) - LFILE = 'log.' // FEXT(:IE) - IFL = LEN_TRIM(LFILE) + IF (FSTOTALIMP .and. .NOT. LPDLIB) THEN + WRITE(NDSE,*) 'IMPTOTAL is selected' + WRITE(NDSE,*) 'But PDLIB is not' + STOP 'Stop, case 1' + ELSE IF (FSTOTALEXP .and. .NOT. LPDLIB) THEN + WRITE(NDSE,*) 'EXPTOTAL is selected' + WRITE(NDSE,*) 'But PDLIB is not' + STOP 'Stop, case 1' + END IF + ! + ! 1.c Open files without unpacking MDS ,,, + ! + IE = LEN_TRIM(FEXT) + LFILE = 'log.' // FEXT(:IE) + IFL = LEN_TRIM(LFILE) #ifdef W3_SHRD - TFILE = 'test.' // FEXT(:IE) + TFILE = 'test.' // FEXT(:IE) #endif #ifdef W3_DIST - IW = 1 + INT ( LOG10 ( REAL(NAPROC) + 0.5 ) ) - IW = MAX ( 3 , MIN ( 9 , IW ) ) - WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') & - '(A4,I', IW, '.', IW, ',2A)' - WRITE (TFILE,FORMAT) 'test', & - OUTPTS(IMOD)%IAPROC, '.', FEXT(:IE) -#endif - IFT = LEN_TRIM(TFILE) - J = LEN_TRIM(FNMPRE) -! -#ifndef W3_CESMCOUPLED - IF ( OUTPTS(IMOD)%IAPROC .EQ. OUTPTS(IMOD)%NAPLOG ) & - OPEN (MDS(1),FILE=FNMPRE(:J)//LFILE(:IFL),ERR=888,IOSTAT=IERR) -#endif -! - IF ( MDS(3).NE.MDS(1) .AND. MDS(3).NE.MDS(4) .AND. TSTOUT ) THEN - INQUIRE (MDS(3),OPENED=OPENED) - IF ( .NOT. OPENED ) OPEN & - (MDS(3),FILE=FNMPRE(:J)//TFILE(:IFT),ERR=889,IOSTAT=IERR) - END IF -! -! 1.d Dataset unit numbers -! - NDS = MDS - NDSO = NDS(1) - NDSE = NDS(2) - NDST = NDS(3) - SCREEN = NDS(4) -! -! 1.e Subroutine tracing -! - CALL ITRACE ( MTRACE(1), MTRACE(2) ) -! -! 1.f Initial and test outputs -! + IW = 1 + INT ( LOG10 ( REAL(NAPROC) + 0.5 ) ) + IW = MAX ( 3 , MIN ( 9 , IW ) ) + WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') & + '(A4,I', IW, '.', IW, ',2A)' + WRITE (TFILE,FORMAT) 'test', & + OUTPTS(IMOD)%IAPROC, '.', FEXT(:IE) +#endif + IFT = LEN_TRIM(TFILE) + J = LEN_TRIM(FNMPRE) + ! +#ifndef W3_CESMCOUPLED + IF ( OUTPTS(IMOD)%IAPROC .EQ. OUTPTS(IMOD)%NAPLOG ) & + OPEN (MDS(1),FILE=FNMPRE(:J)//LFILE(:IFL),ERR=888,IOSTAT=IERR) +#endif + ! + IF ( MDS(3).NE.MDS(1) .AND. MDS(3).NE.MDS(4) .AND. TSTOUT ) THEN + INQUIRE (MDS(3),OPENED=OPENED) + IF ( .NOT. OPENED ) OPEN & + (MDS(3),FILE=FNMPRE(:J)//TFILE(:IFT),ERR=889,IOSTAT=IERR) + END IF + ! + ! 1.d Dataset unit numbers + ! + NDS = MDS + NDSO = NDS(1) + NDSE = NDS(2) + NDST = NDS(3) + SCREEN = NDS(4) + ! + ! 1.e Subroutine tracing + ! + CALL ITRACE ( MTRACE(1), MTRACE(2) ) + ! + ! 1.f Initial and test outputs + ! #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif -! + ! - IF ( IAPROC .EQ. NAPLOG ) THEN - CALL WWDATE ( STDATE ) - CALL WWTIME ( STTIME ) - WRITE (NDSO,900) WWVER, STDATE, STTIME - END IF + IF ( IAPROC .EQ. NAPLOG ) THEN + CALL WWDATE ( STDATE ) + CALL WWTIME ( STTIME ) + WRITE (NDSO,900) WWVER, STDATE, STTIME + END IF #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2a' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2a' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif -! + ! #ifdef W3_S - CALL STRACE (IENT, 'W3INIT') + CALL STRACE (IENT, 'W3INIT') #endif #ifdef W3_T - WRITE(NDST,9000) IMOD, FEXT(:IE) - WRITE (NDST,9001) NTPROC, NAPROC, IAPROC, NAPLOG, NAPOUT, & - NAPERR, NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, NAPPRT - WRITE (NDST,9002) NDSO, NDSE, NDST, SCREEN - WRITE (NDST,9003) LFILE(:IFL), TFILE(:IFT) -#endif -! -! 2. Model definition ---------------------------------------------- / -! 2.a Read model definition file -! - CALL W3IOGR ( 'READ', NDS(5), IMOD, FEXT ) - IF (GTYPE .eq. UNGTYPE) THEN - CALL SPATIAL_GRID - CALL NVECTRI - CALL COORDMAX + WRITE(NDST,9000) IMOD, FEXT(:IE) + WRITE (NDST,9001) NTPROC, NAPROC, IAPROC, NAPLOG, NAPOUT, & + NAPERR, NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, NAPPRT + WRITE (NDST,9002) NDSO, NDSE, NDST, SCREEN + WRITE (NDST,9003) LFILE(:IFL), TFILE(:IFT) +#endif + ! + ! 2. Model definition ---------------------------------------------- / + ! 2.a Read model definition file + ! + CALL W3IOGR ( 'READ', NDS(5), IMOD, FEXT ) + IF (GTYPE .eq. UNGTYPE) THEN + CALL SPATIAL_GRID + CALL NVECTRI + CALL COORDMAX #ifdef W3_PDLIB - IF(.false.) THEN + IF(.false.) THEN #endif CALL AREA_SI(1) #ifdef W3_PDLIB - ENDIF -#endif ENDIF +#endif + ENDIF #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2b' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2b' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif #ifdef W3_PDLIB @@ -798,13 +795,13 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & #endif #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2c' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2c' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After PDLIB_INIT") + CALL PRINT_MY_TIME("After PDLIB_INIT") #endif #ifdef W3_PDLIB @@ -812,9 +809,9 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & #endif #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2cc' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2cc' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif #ifdef W3_PDLIB @@ -822,149 +819,145 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & #endif #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2d' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2d' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif -! Update of output parameter flags based on mod_def parameters (for 3D arrays) + ! Update of output parameter flags based on mod_def parameters (for 3D arrays) - CALL W3FLGRDUPDT ( NDSO, NDSE, FLGRD, FLGR2, FLGD, FLG2 ) + CALL W3FLGRDUPDT ( NDSO, NDSE, FLGRD, FLGR2, FLGD, FLG2 ) #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After W3FLGRDUPDT") + CALL PRINT_MY_TIME("After W3FLGRDUPDT") #endif - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF - IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,920) -! -! 2.b Save MAPSTA -! - ALLOCATE ( MAPTST(NY,NX) ) - MAPTST = MAPSTA + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,920) + ! + ! 2.b Save MAPSTA + ! + ALLOCATE ( MAPTST(NY,NX) ) + MAPTST = MAPSTA #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2e' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -! -! 2.c MPP preparation -! 2.c.1 Set simple counters and variables -! - CALL SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) - NSEAL = NSEALout - NSEALM = NSEALMout + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2e' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) +#endif + ! + ! + ! 2.c MPP preparation + ! 2.c.1 Set simple counters and variables + ! + CALL SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) + NSEAL = NSEALout + NSEALM = NSEALMout #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2f' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2f' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif #ifdef W3_DIST - IF ( NSEA .LT. NAPROC ) GOTO 820 - IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN - IF ( NSPEC .LT. NAPROC ) GOTO 821 - END IF + IF ( NSEA .LT. NAPROC ) GOTO 820 + IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN + IF ( NSPEC .LT. NAPROC ) GOTO 821 + END IF #endif #ifdef W3_PDLIB - IF ((IAPROC .LE. NAPROC).and.(GTYPE .eq. UNGTYPE)) THEN + IF ((IAPROC .LE. NAPROC).and.(GTYPE .eq. UNGTYPE)) THEN #endif #ifdef W3_PDLIB - CALL BLOCK_SOLVER_INIT(IMOD) - CALL PDLIB_IOBP_INIT(IMOD) - CALL SET_IOBPA_PDLIB + CALL BLOCK_SOLVER_INIT(IMOD) + CALL PDLIB_IOBP_INIT(IMOD) + CALL SET_IOBPA_PDLIB #endif #ifdef W3_PDLIB - ELSE IF (FSTOTALEXP) THEN -!AR: To do here the blocksolver ... - ENDIF + ELSE IF (FSTOTALEXP) THEN + !AR: To do here the blocksolver ... + ENDIF #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After BLOCK_SOLVER_INIT") + CALL PRINT_MY_TIME("After BLOCK_SOLVER_INIT") #endif #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2g' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -! -! 2.c.2 Allocate arrays -! - IF ( IAPROC .LE. NAPROC ) THEN - CALL W3DIMW ( IMOD, NDSE, NDST ) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2g' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) +#endif + ! + ! + ! 2.c.2 Allocate arrays + ! + IF ( IAPROC .LE. NAPROC ) THEN + CALL W3DIMW ( IMOD, NDSE, NDST ) #ifdef W3_MEMCHECK WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2h' call getMallocInfo(mallinfos) call printMallInfo(10000+IAPROC,mallInfos) #endif - ELSE - CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) + ELSE + CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) #ifdef W3_MEMCHECK WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2i' call getMallocInfo(mallinfos) call printMallInfo(10000+IAPROC,mallInfos) #endif - END IF + END IF #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After W3DIMW") + CALL PRINT_MY_TIME("After W3DIMW") #endif - CALL W3DIMA ( IMOD, NDSE, NDST ) + CALL W3DIMA ( IMOD, NDSE, NDST ) #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2j' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2j' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif - CALL W3DIMI ( IMOD, NDSE, NDST , FLAGSTIDEIN ) + CALL W3DIMI ( IMOD, NDSE, NDST , FLAGSTIDEIN ) #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After W3DIMI") + CALL PRINT_MY_TIME("After W3DIMI") #endif #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -! 2.c.3 Calculated expected number of prop. calls per processor -! - NTTOT = 0 - DO IK=1, NK - NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) - NTTOT = NTTOT + NTLOC*NTH - END DO - NTTARG = 1 + (NTTOT-1)/NAPROC - NTTARG = NTTARG + INT(DTMAX/(DTCFL*SIG(NK)/SIG(1))-0.001) - NTTMAX = NTTARG + 5 -! -! 2.c.4 Initialize IAPPRO -! - IAPPRO = 1 - ALLOCATE ( NT(NSPEC) ) - NT = NTTOT + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) +#endif + ! + ! 2.c.3 Calculated expected number of prop. calls per processor + ! + NTTOT = 0 + DO IK=1, NK + NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) + NTTOT = NTTOT + NTLOC*NTH + END DO + NTTARG = 1 + (NTTOT-1)/NAPROC + NTTARG = NTTARG + INT(DTMAX/(DTCFL*SIG(NK)/SIG(1))-0.001) + NTTMAX = NTTARG + 5 + ! + ! 2.c.4 Initialize IAPPRO + ! + IAPPRO = 1 + ALLOCATE ( NT(NSPEC) ) + NT = NTTOT #ifdef W3_DIST IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN -#endif -! -#ifdef W3_DIST + ! DO -#endif -! -! 2.c.5 First sweep filling IAPPRO -! -#ifdef W3_DIST + ! + ! 2.c.5 First sweep filling IAPPRO + ! DO IP=1, NAPROC ISTEP = IP ISP = 0 @@ -972,5965 +965,5360 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & DO J=1, 1+NSPEC/NAPROC ISP = ISP + ISTEP IF ( MOD(J,2) .EQ. 1 ) THEN - ISTEP = 2*(NAPROC-IP) + 1 + ISTEP = 2*(NAPROC-IP) + 1 + ELSE + ISTEP = 2*IP - 1 + END IF + IF ( ISP .LE. NSPEC ) THEN + IK = 1 + (ISP-1)/NTH + NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) + IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN + IAPPRO(ISP) = IP + NT(IP) = NT(IP) + NTLOC ELSE - ISTEP = 2*IP - 1 + IAPPRO(ISP) = -1 END IF - IF ( ISP .LE. NSPEC ) THEN + END IF + END DO + END DO + ! + ! 2.c.6 Second sweep filling IAPPRO + ! + DO IP=1, NAPROC + IF ( NT(IP) .LT. NTTARG ) THEN + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .EQ. -1 ) THEN IK = 1 + (ISP-1)/NTH NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN - IAPPRO(ISP) = IP - NT(IP) = NT(IP) + NTLOC - ELSE - IAPPRO(ISP) = -1 - END IF + IAPPRO(ISP) = IP + NT(IP) = NT(IP) + NTLOC + END IF END IF END DO - END DO -#endif -! -! 2.c.6 Second sweep filling IAPPRO -! -#ifdef W3_DIST - DO IP=1, NAPROC - IF ( NT(IP) .LT. NTTARG ) THEN - DO ISP=1, NSPEC - IF ( IAPPRO(ISP) .EQ. -1 ) THEN - IK = 1 + (ISP-1)/NTH - NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) - IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN - IAPPRO(ISP) = IP - NT(IP) = NT(IP) + NTLOC - END IF - END IF - END DO - END IF - END DO -#endif -! -! 2.c.7 Check if all served -! -#ifdef W3_DIST - IF ( MINVAL(IAPPRO(1:NSPEC)) .GT. 0 ) THEN - EXIT - ELSE - NTTARG = NTTARG + 1 - IF ( NTTARG .GE. NTTMAX ) EXIT - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8028) END IF -#endif -! -#ifdef W3_DIST END DO - END IF + ! + ! 2.c.7 Check if all served + ! + IF ( MINVAL(IAPPRO(1:NSPEC)) .GT. 0 ) THEN + EXIT + ELSE + NTTARG = NTTARG + 1 + IF ( NTTARG .GE. NTTMAX ) EXIT + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8028) + END IF + ! + END DO + END IF #endif -! + ! #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After Case 14") -#endif -! 2.c.8 Test output -! -#ifdef W3_T - WRITE (NDST,9020) - DO IP=1, NAPROC - WRITE (NDST,9021) IP, NT(IP), NTTARG - END DO + CALL PRINT_MY_TIME("After Case 14") #endif -! + ! 2.c.8 Test output + ! #ifdef W3_T - WRITE (NDST,9025) - DO IK=NK, 1, -1 - WRITE (NDST,9026) IK, (IAPPRO(ITH+(IK-1)*NTH),ITH=1,MIN(24,NTH)) - IF ( NTH .GT. 24 ) WRITE (NDST,9027) & - (IAPPRO(ITH+(IK-1)*NTH),ITH=25,NTH) - END DO -#endif -! -! 2.c.9 Test if any spectral points are left out -! + WRITE (NDST,9020) + DO IP=1, NAPROC + WRITE (NDST,9021) IP, NT(IP), NTTARG + END DO + ! + WRITE (NDST,9025) + DO IK=NK, 1, -1 + WRITE (NDST,9026) IK, (IAPPRO(ITH+(IK-1)*NTH),ITH=1,MIN(24,NTH)) + IF ( NTH .GT. 24 ) WRITE (NDST,9027) & + (IAPPRO(ITH+(IK-1)*NTH),ITH=25,NTH) + END DO +#endif + ! + ! 2.c.9 Test if any spectral points are left out + ! #ifdef W3_DIST IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN DO ISP=1, NSPEC IF ( IAPPRO(ISP) .EQ. -1. ) GOTO 829 - END DO + END DO END IF #endif - DEALLOCATE ( NT ) -! -! 3. Model initialization ------------------------------------------- / -! 3.a Read restart file -! - VA(:,:) = 0. + DEALLOCATE ( NT ) + ! + ! 3. Model initialization ------------------------------------------- / + ! 3.a Read restart file + ! + VA(:,:) = 0. #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before W3IORS call", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before W3IORS call", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before W3IORS") + CALL PRINT_MY_TIME("Before W3IORS") #endif - CALL W3IORS ( 'READ', NDS(6), SIG(NK), IMOD) + CALL W3IORS ( 'READ', NDS(6), SIG(NK), IMOD) #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After W3IORS") + CALL PRINT_MY_TIME("After W3IORS") #endif #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3a' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3a' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After W3IORS call", 1) -#endif - FLCOLD = RSTYPE.LE.1 .OR. RSTYPE.EQ.4 - IF ( IAPROC .EQ. NAPLOG ) THEN - IF (RSTYPE.EQ.0) THEN - WRITE (NDSO,930) 'cold start (idealized).' - ELSE IF ( RSTYPE .EQ. 1 ) THEN - WRITE (NDSO,930) 'cold start (wind).' - ELSE IF ( RSTYPE .EQ. 4 ) THEN - WRITE (NDSO,930) 'cold start (calm).' - ELSE - WRITE (NDSO,930) 'full restart.' - END IF - END IF + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After W3IORS call", 1) +#endif + FLCOLD = RSTYPE.LE.1 .OR. RSTYPE.EQ.4 + IF ( IAPROC .EQ. NAPLOG ) THEN + IF (RSTYPE.EQ.0) THEN + WRITE (NDSO,930) 'cold start (idealized).' + ELSE IF ( RSTYPE .EQ. 1 ) THEN + WRITE (NDSO,930) 'cold start (wind).' + ELSE IF ( RSTYPE .EQ. 4 ) THEN + WRITE (NDSO,930) 'cold start (calm).' + ELSE + WRITE (NDSO,930) 'full restart.' + END IF + END IF #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.2", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.2", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After restart inits") + CALL PRINT_MY_TIME("After restart inits") #endif -! -! 3.b Compare MAPSTA from grid and restart -! - DO IX=1, NX - DO IY=1, NY - IF ( ABS(MAPSTA(IY,IX)).EQ.2 .OR. & - ABS(MAPTST(IY,IX)).EQ.2 ) THEN - MAPSTA(IY,IX) = SIGN ( MAPTST(IY,IX) , MAPSTA(IY,IX) ) - END IF - END DO - END DO + ! + ! 3.b Compare MAPSTA from grid and restart + ! + DO IX=1, NX + DO IY=1, NY + IF ( ABS(MAPSTA(IY,IX)).EQ.2 .OR. & + ABS(MAPTST(IY,IX)).EQ.2 ) THEN + MAPSTA(IY,IX) = SIGN ( MAPTST(IY,IX) , MAPSTA(IY,IX) ) + END IF + END DO + END DO #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3b' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3b' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif -! + ! #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.3", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.3", 1) #endif -! -! 3.b2 Set MAPSTA associated to PDLIB -! + ! + ! 3.b2 Set MAPSTA associated to PDLIB + ! #ifdef W3_PDLIB - IF (GTYPE .eq. UNGTYPE) THEN - CALL PDLIB_MAPSTA_INIT(IMOD) - END IF + IF (GTYPE .eq. UNGTYPE) THEN + CALL PDLIB_MAPSTA_INIT(IMOD) + END IF #endif -! -! 3.c Initialization from wind fields -! - FLIWND = RSTYPE.EQ.1 + ! + ! 3.c Initialization from wind fields + ! + FLIWND = RSTYPE.EQ.1 #ifdef W3_T - IF ( FLIWND ) WRITE (NDST,9030) + IF ( FLIWND ) WRITE (NDST,9030) #endif -! -! 3.d Initialization with calm conditions -! + ! + ! 3.d Initialization with calm conditions + ! #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 5", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 5", 1) #endif - IF ( RSTYPE .EQ. 4 ) THEN - VA(:,:) = 0. + IF ( RSTYPE .EQ. 4 ) THEN + VA(:,:) = 0. #ifdef W3_T - WRITE (NDST,9031) + WRITE (NDST,9031) #endif - END IF + END IF #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 4' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -! 3.e Prepare propagation scheme -! - IF ( .NOT. FLCUR ) FLCK = .FALSE. + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 4' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) +#endif + ! + ! 3.e Prepare propagation scheme + ! + IF ( .NOT. FLCUR ) FLCK = .FALSE. #ifdef W3_PDLIB - IF (FSTOTALIMP .and. FSREFRACTION) THEN - FLCTH = .FALSE. - END IF - IF (FSTOTALIMP .and. FSFREQSHIFT) THEN - FLCK = .FALSE. - END IF + IF (FSTOTALIMP .and. FSREFRACTION) THEN + FLCTH = .FALSE. + END IF + IF (FSTOTALIMP .and. FSFREQSHIFT) THEN + FLCK = .FALSE. + END IF #endif -! -! 4. Set-up output times -------------------------------------------- * -! 4.a Unpack ODAT -! - DO J=1, NOTYPE - J0 = (J-1)*5 - TONEXT(1,J) = ODAT(J0+1) - TONEXT(2,J) = ODAT(J0+2) - DTOUT ( J) = REAL ( ODAT(J0+3) ) - TOLAST(1,J) = ODAT(J0+4) - TOLAST(2,J) = ODAT(J0+5) - END DO -! -! J=8, second stream of restart files - J=8 - J0 = (J-1)*5 - IF(ODAT(J0+1) .NE. 0) THEN - TONEXT(1,J) = ODAT(J0+1) - TONEXT(2,J) = ODAT(J0+2) - DTOUT ( J) = REAL ( ODAT(J0+3) ) - TOLAST(1,J) = ODAT(J0+4) - TOLAST(2,J) = ODAT(J0+5) - FLOUT(8) = .TRUE. - ELSE - FLOUT(8) = .FALSE. - END IF -! -! 4.b Check if output available -! - FLOUT(1) = .FALSE. - FLOGRD = FLGRD - FLOGD = FLGD - DO J=1, NOGRP - DO K=1, NGRPP - FLOUT(1) = FLOUT(1) .OR. FLOGRD(J,K) - END DO + ! + ! 4. Set-up output times -------------------------------------------- * + ! 4.a Unpack ODAT + ! + DO J=1, NOTYPE + J0 = (J-1)*5 + TONEXT(1,J) = ODAT(J0+1) + TONEXT(2,J) = ODAT(J0+2) + DTOUT ( J) = REAL ( ODAT(J0+3) ) + TOLAST(1,J) = ODAT(J0+4) + TOLAST(2,J) = ODAT(J0+5) + END DO + ! + ! J=8, second stream of restart files + J=8 + J0 = (J-1)*5 + IF(ODAT(J0+1) .NE. 0) THEN + TONEXT(1,J) = ODAT(J0+1) + TONEXT(2,J) = ODAT(J0+2) + DTOUT ( J) = REAL ( ODAT(J0+3) ) + TOLAST(1,J) = ODAT(J0+4) + TOLAST(2,J) = ODAT(J0+5) + FLOUT(8) = .TRUE. + ELSE + FLOUT(8) = .FALSE. + END IF + ! + ! 4.b Check if output available + ! + FLOUT(1) = .FALSE. + FLOGRD = FLGRD + FLOGD = FLGD + DO J=1, NOGRP + DO K=1, NGRPP + FLOUT(1) = FLOUT(1) .OR. FLOGRD(J,K) END DO + END DO #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 6", 1) -#endif -! - FLOUT(7) = .FALSE. - FLOGR2 = FLGR2 - FLOG2 = FLG2 - DO J=1, NOGRP - DO K=1, NGRPP - FLOUT(7) = FLOUT(7) .OR. FLOGR2(J,K) - END DO + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 6", 1) +#endif + ! + FLOUT(7) = .FALSE. + FLOGR2 = FLGR2 + FLOG2 = FLG2 + DO J=1, NOGRP + DO K=1, NGRPP + FLOUT(7) = FLOUT(7) .OR. FLOGR2(J,K) END DO -! - FLOUT(2) = NPT .GT. 0 -! - FLOUT(3) = .TRUE. -! - FLOUT(4) = .TRUE. -! - FLOUT(5) = FLBPO - IF ( FLBPO ) THEN - CALL W3DMO5 ( IMOD, NDSE, NDST, 4 ) - ELSE - DTOUT(5) = 0. - END IF -! - IX0 = MAX ( 1, IPRT(1) ) - IXN = MIN ( NX, IPRT(2) ) - IXS = MAX ( 1, IPRT(3) ) - IY0 = MAX ( 1, IPRT(4) ) - IYN = MIN ( NY, IPRT(5) ) - IYS = MAX ( 1, IPRT(6) ) - FLFORM = PRTFRM - FLOUT(6) = IX0.LE.IXN .AND. IY0.LE.IYN -! -! 4.c Get first time per output and overall. -! - TOFRST(1) = -1 - TOFRST(2) = 0 -! -! WRITE(*,*) 'We set NOTYPE=0 just for DEBUGGING' -! NOTYPE=0 ! ONLY FOR DEBUGGING PURPOSE + END DO + ! + FLOUT(2) = NPT .GT. 0 + ! + FLOUT(3) = .TRUE. + ! + FLOUT(4) = .TRUE. + ! + FLOUT(5) = FLBPO + IF ( FLBPO ) THEN + CALL W3DMO5 ( IMOD, NDSE, NDST, 4 ) + ELSE + DTOUT(5) = 0. + END IF + ! + IX0 = MAX ( 1, IPRT(1) ) + IXN = MIN ( NX, IPRT(2) ) + IXS = MAX ( 1, IPRT(3) ) + IY0 = MAX ( 1, IPRT(4) ) + IYN = MIN ( NY, IPRT(5) ) + IYS = MAX ( 1, IPRT(6) ) + FLFORM = PRTFRM + FLOUT(6) = IX0.LE.IXN .AND. IY0.LE.IYN + ! + ! 4.c Get first time per output and overall. + ! + TOFRST(1) = -1 + TOFRST(2) = 0 + ! + ! WRITE(*,*) 'We set NOTYPE=0 just for DEBUGGING' + ! NOTYPE=0 ! ONLY FOR DEBUGGING PURPOSE #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 7", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 7", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before NOTYPE loop") -#endif - DO J=1, NOTYPE -! -! ... check time step -! - DTOUT(J) = MAX ( 0. , DTOUT(J) ) - FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) -! -! ... get first time -! - IF ( FLOUT(J) ) THEN + CALL PRINT_MY_TIME("Before NOTYPE loop") +#endif + DO J=1, NOTYPE + ! + ! ... check time step + ! + DTOUT(J) = MAX ( 0. , DTOUT(J) ) + FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) + ! + ! ... get first time + ! + IF ( FLOUT(J) ) THEN #ifdef W3_NL5 - IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) -#endif - TOUT = TONEXT(:,J) - TLST = TOLAST(:,J) -! - DO - DTTST = DSEC21 ( TIME , TOUT ) - IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & - ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN - CALL TICK21 ( TOUT, DTOUT(J) ) - ELSE - EXIT - END IF - END DO -! -! ... reset first time -! - TONEXT(:,J) = TOUT -! -! ... check last time -! - DTTST = DSEC21 ( TOUT , TLST ) - IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. -! -! ... check overall first time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF - END IF - END IF -! + IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) +#endif + TOUT = TONEXT(:,J) + TLST = TOLAST(:,J) + ! + DO + DTTST = DSEC21 ( TIME , TOUT ) + IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & + ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN + CALL TICK21 ( TOUT, DTOUT(J) ) + ELSE + EXIT END IF -! END DO -! -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 5' -#endif -! -! J=8, second stream of restart files -! - J=8 -! -! ... check time step -! - DTOUT(J) = MAX ( 0. , DTOUT(J) ) - FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) -! -! ... get first time -! + ! + ! ... reset first time + ! + TONEXT(:,J) = TOUT + ! + ! ... check last time + ! + DTTST = DSEC21 ( TOUT , TLST ) + IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. + ! + ! ... check overall first time + ! IF ( FLOUT(J) ) THEN - TOUT = TONEXT(:,J) - TLST = TOLAST(:,J) -! - DO - DTTST = DSEC21 ( TIME , TOUT ) - IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & - ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN - CALL TICK21 ( TOUT, DTOUT(J) ) - ELSE - EXIT - END IF - END DO -! -! ... reset first time -! - TONEXT(:,J) = TOUT -! -! ... check last time -! - DTTST = DSEC21 ( TOUT , TLST ) - IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. -! -! ... check overall first time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF - END IF - END IF -! + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT + END IF + END IF + END IF + ! + END IF + ! + END DO + ! +#ifdef W3_MEMCHECK + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 5' +#endif + ! + ! J=8, second stream of restart files + ! + J=8 + ! + ! ... check time step + ! + DTOUT(J) = MAX ( 0. , DTOUT(J) ) + FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) + ! + ! ... get first time + ! + IF ( FLOUT(J) ) THEN + TOUT = TONEXT(:,J) + TLST = TOLAST(:,J) + ! + DO + DTTST = DSEC21 ( TIME , TOUT ) + IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & + ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN + CALL TICK21 ( TOUT, DTOUT(J) ) + ELSE + EXIT + END IF + END DO + ! + ! ... reset first time + ! + TONEXT(:,J) = TOUT + ! + ! ... check last time + ! + DTTST = DSEC21 ( TOUT , TLST ) + IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. + ! + ! ... check overall first time + ! + IF ( FLOUT(J) ) THEN + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT END IF -! END J=8 -! + END IF + END IF + ! + END IF + ! END J=8 + ! #ifdef W3_MEMCHECK - WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 5' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After NOTYPE loop") + CALL PRINT_MY_TIME("After NOTYPE loop") #endif #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.1", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.1", 1) #endif -! -! 4.d Preprocessing for point output. -! - IF ( FLOUT(2) ) CALL W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) + ! + ! 4.d Preprocessing for point output. + ! + IF ( FLOUT(2) ) CALL W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) #ifdef W3_PDLIB - CALL DEALLOCATE_PDLIB_GLOBAL(IMOD) + CALL DEALLOCATE_PDLIB_GLOBAL(IMOD) #endif -! + ! #ifdef W3_T - WRITE (NDST,9040) - DO J=1, 5 - WRITE (NDST,9041) TONEXT(1,J),TONEXT(2,J),DTOUT(J),FLOUT(J) - END DO - WRITE (NDST,9042) - WRITE (NDST,9043) TOFRST -#endif -! -! 5. Define wavenumber grid ----------------------------------------- * -! 5.a Calculate depth -! + WRITE (NDST,9040) + DO J=1, 5 + WRITE (NDST,9041) TONEXT(1,J),TONEXT(2,J),DTOUT(J),FLOUT(J) + END DO + WRITE (NDST,9042) + WRITE (NDST,9043) TOFRST +#endif + ! + ! 5. Define wavenumber grid ----------------------------------------- * + ! 5.a Calculate depth + ! #ifdef W3_T - ALLOCATE ( MAPOUT(NX,NY), XOUT(NX,NY) ) - XOUT = -1. + ALLOCATE ( MAPOUT(NX,NY), XOUT(NX,NY) ) + XOUT = -1. #endif -! - MAPTST = MOD(MAPST2/2,2) - MAPST2 = MAPST2 - 2*MAPTST + ! + MAPTST = MOD(MAPST2/2,2) + MAPST2 = MAPST2 - 2*MAPTST -! -!Li For multi-resolution SMC grid, these 1-NX and 1-NY nested loops -!Li may miss the refined cells as they are not 1-1 corresponding to -!Li the (Nx,NY) regular grid. The loop is now modified to run over -!Li full NSEA points. JGLi24Jan2012 -!Li DO IY=1, NY -!Li DO IX=1, NX -!Li ISEA = MAPFS(IY,IX) - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + ! + !Li For multi-resolution SMC grid, these 1-NX and 1-NY nested loops + !Li may miss the refined cells as they are not 1-1 corresponding to + !Li the (Nx,NY) regular grid. The loop is now modified to run over + !Li full NSEA points. JGLi24Jan2012 + !Li DO IY=1, NY + !Li DO IX=1, NX + !Li ISEA = MAPFS(IY,IX) + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) #ifdef W3_T - MAPOUT(IX,IY) = MAPSTA(IY,IX) + MAPOUT(IX,IY) = MAPSTA(IY,IX) #endif -!Li IF ( ISEA .NE. 0) THEN - WLVeff=WLV(ISEA) + !Li IF ( ISEA .NE. 0) THEN + WLVeff=WLV(ISEA) #ifdef W3_SETUP - IF (DO_CHANGE_WLV) THEN - WLVeff=WLVeff + ZETA_SETUP(ISEA) - END IF + IF (DO_CHANGE_WLV) THEN + WLVeff=WLVeff + ZETA_SETUP(ISEA) + END IF #endif - DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) + DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) #ifdef W3_T - XOUT(IX,IY) = DW(ISEA) + XOUT(IX,IY) = DW(ISEA) #endif - IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN - MAPTST(IY,IX) = 1 - MAPSTA(IY,IX) = -ABS(MAPSTA(IY,IX)) - END IF -!Li END IF - END DO -!Li END DO - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - WLVeff=WLV(ISEA) + IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN + MAPTST(IY,IX) = 1 + MAPSTA(IY,IX) = -ABS(MAPSTA(IY,IX)) + END IF + !Li END IF + END DO + !Li END DO + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + WLVeff=WLV(ISEA) #ifdef W3_SETUP - IF (DO_CHANGE_WLV) THEN - WLVeff=WLVeff + ZETA_SETUP(ISEA) - END IF + IF (DO_CHANGE_WLV) THEN + WLVeff=WLVeff + ZETA_SETUP(ISEA) + END IF #endif - DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) - IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN - VA(:,JSEA) = 0. - END IF - END DO -! + DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) + IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN + VA(:,JSEA) = 0. + END IF + END DO + ! #ifdef W3_PDLIB - IF ( IAPROC .LE. NAPROC ) THEN - CALL SET_IOBDP_PDLIB - ENDIF + IF ( IAPROC .LE. NAPROC ) THEN + CALL SET_IOBDP_PDLIB + ENDIF #endif -! + ! #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.2", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.2", 1) #endif -! - MAPST2 = MAPST2 + 2*MAPTST -! - DEALLOCATE ( MAPTST ) + ! + MAPST2 = MAPST2 + 2*MAPTST + ! + DEALLOCATE ( MAPTST ) #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 6' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 6' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif -! + ! #ifdef W3_T - WRITE (NDST,9050) - NX0 = 1 - DO - NXN = MIN ( NX0+NXS-1 , NX ) - CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & - NX0, NXN, 1, 1, NY, 1, 'Depth', 'm') - IF ( NXN .NE. NX ) THEN - NX0 = NX0 + NXS - ELSE - EXIT - END IF - END DO - DEALLOCATE ( MAPOUT, XOUT ) + WRITE (NDST,9050) + NX0 = 1 + DO + NXN = MIN ( NX0+NXS-1 , NX ) + CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & + NX0, NXN, 1, 1, NY, 1, 'Depth', 'm') + IF ( NXN .NE. NX ) THEN + NX0 = NX0 + NXS + ELSE + EXIT + END IF + END DO + DEALLOCATE ( MAPOUT, XOUT ) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before section 5.b") -#endif -! -! 5.b Fill wavenumber and group velocity arrays. -! - DO IS=0, NSEA - IF (IS.GT.0) THEN - DEPTH = MAX ( DMIN , DW(IS) ) - ELSE - DEPTH = DMIN - END IF -! + CALL PRINT_MY_TIME("Before section 5.b") +#endif + ! + ! 5.b Fill wavenumber and group velocity arrays. + ! + DO IS=0, NSEA + IF (IS.GT.0) THEN + DEPTH = MAX ( DMIN , DW(IS) ) + ELSE + DEPTH = DMIN + END IF + ! #ifdef W3_T1 - WRITE (NDST,9051) IS, DEPTH -#endif -! - DO IK=0, NK+1 -! -! Calculate wavenumbers and group velocities. - CALL WAVNU1(SIG(IK),DEPTH,WN(IK,IS),CG(IK,IS)) -! + WRITE (NDST,9051) IS, DEPTH +#endif + ! + DO IK=0, NK+1 + ! + ! Calculate wavenumbers and group velocities. + CALL WAVNU1(SIG(IK),DEPTH,WN(IK,IS),CG(IK,IS)) + ! #ifdef W3_T1 - WRITE (NDST,9052) IK, TPI/SIG(IK), WN(IK,IS), CG(IK,IS) + WRITE (NDST,9052) IK, TPI/SIG(IK), WN(IK,IS), CG(IK,IS) #endif -! - END DO - END DO + ! + END DO + END DO -! -! 6. Initialize arrays ---------------------------------------------- / -! Some initialized in W3IORS -! - UA = 0. - UD = 0. - U10 = 0. - U10D = 0. -! - AS = UNDEF -! - AS (0) = 0. - DW (0) = 0. -! -! 7. Write info to log file ----------------------------------------- / -! - IF ( IAPROC .EQ. NAPLOG ) THEN -! - WRITE (NDSO,970) GNAME - IF ( FLLEV ) WRITE (NDSO,971) 'Prescribed' - IF (.NOT. FLLEV ) WRITE (NDSO,971) 'No' - IF ( FLCUR ) WRITE (NDSO,972) 'Prescribed' - IF (.NOT. FLCUR ) WRITE (NDSO,972) 'No' - IF ( FLWIND ) WRITE (NDSO,973) 'Prescribed' - IF (.NOT. FLWIND) WRITE (NDSO,973) 'No' - IF ( FLICE ) WRITE (NDSO,974) 'Prescribed' - IF (.NOT. FLICE ) WRITE (NDSO,974) 'No' - IF ( FLTAUA ) WRITE (NDSO,988) 'Prescribed' - IF (.NOT. FLTAUA) WRITE (NDSO,988) 'No' - IF ( FLRHOA ) WRITE (NDSO,989) 'Prescribed' - IF (.NOT. FLRHOA) WRITE (NDSO,989) 'No' -! - IF ( FLMDN ) WRITE (NDSO,9972) 'Prescribed' - IF (.NOT. FLMDN ) WRITE (NDSO,9972) 'No' - IF ( FLMTH ) WRITE (NDSO,9971) 'Prescribed' - IF (.NOT. FLMTH ) WRITE (NDSO,9971) 'No' - IF ( FLMVS ) WRITE (NDSO,9970) 'Prescribed' - IF (.NOT. FLMVS ) WRITE (NDSO,9970) 'No' + ! + ! 6. Initialize arrays ---------------------------------------------- / + ! Some initialized in W3IORS + ! + UA = 0. + UD = 0. + U10 = 0. + U10D = 0. + ! + AS = UNDEF + ! + AS (0) = 0. + DW (0) = 0. + ! + ! 7. Write info to log file ----------------------------------------- / + ! + IF ( IAPROC .EQ. NAPLOG ) THEN + ! + WRITE (NDSO,970) GNAME + IF ( FLLEV ) WRITE (NDSO,971) 'Prescribed' + IF (.NOT. FLLEV ) WRITE (NDSO,971) 'No' + IF ( FLCUR ) WRITE (NDSO,972) 'Prescribed' + IF (.NOT. FLCUR ) WRITE (NDSO,972) 'No' + IF ( FLWIND ) WRITE (NDSO,973) 'Prescribed' + IF (.NOT. FLWIND) WRITE (NDSO,973) 'No' + IF ( FLICE ) WRITE (NDSO,974) 'Prescribed' + IF (.NOT. FLICE ) WRITE (NDSO,974) 'No' + IF ( FLTAUA ) WRITE (NDSO,988) 'Prescribed' + IF (.NOT. FLTAUA) WRITE (NDSO,988) 'No' + IF ( FLRHOA ) WRITE (NDSO,989) 'Prescribed' + IF (.NOT. FLRHOA) WRITE (NDSO,989) 'No' + ! + IF ( FLMDN ) WRITE (NDSO,9972) 'Prescribed' + IF (.NOT. FLMDN ) WRITE (NDSO,9972) 'No' + IF ( FLMTH ) WRITE (NDSO,9971) 'Prescribed' + IF (.NOT. FLMTH ) WRITE (NDSO,9971) 'No' + IF ( FLMVS ) WRITE (NDSO,9970) 'Prescribed' + IF (.NOT. FLMVS ) WRITE (NDSO,9970) 'No' - IF ( FLIC1 ) WRITE (NDSO,9973) 'Prescribed' - IF (.NOT. FLIC1 ) WRITE (NDSO,9973) 'No' - IF ( FLIC2 ) WRITE (NDSO,9974) 'Prescribed' - IF (.NOT. FLIC2 ) WRITE (NDSO,9974) 'No' - IF ( FLIC3 ) WRITE (NDSO,9975) 'Prescribed' - IF (.NOT. FLIC3 ) WRITE (NDSO,9975) 'No' - IF ( FLIC4 ) WRITE (NDSO,9976) 'Prescribed' - IF (.NOT. FLIC4 ) WRITE (NDSO,9976) 'No' - IF ( FLIC5 ) WRITE (NDSO,9977) 'Prescribed' - IF (.NOT. FLIC5 ) WRITE (NDSO,9977) 'No' + IF ( FLIC1 ) WRITE (NDSO,9973) 'Prescribed' + IF (.NOT. FLIC1 ) WRITE (NDSO,9973) 'No' + IF ( FLIC2 ) WRITE (NDSO,9974) 'Prescribed' + IF (.NOT. FLIC2 ) WRITE (NDSO,9974) 'No' + IF ( FLIC3 ) WRITE (NDSO,9975) 'Prescribed' + IF (.NOT. FLIC3 ) WRITE (NDSO,9975) 'No' + IF ( FLIC4 ) WRITE (NDSO,9976) 'Prescribed' + IF (.NOT. FLIC4 ) WRITE (NDSO,9976) 'No' + IF ( FLIC5 ) WRITE (NDSO,9977) 'Prescribed' + IF (.NOT. FLIC5 ) WRITE (NDSO,9977) 'No' - IF ( FLOUT(1) ) THEN - WRITE (NDSO,975) - DO J=1,NOGRP - DO K=1,NGRPP - IF ( FLOGRD(J,K) ) WRITE (NDSO,976) IDOUT(J,K) - END DO - END DO - END IF -! - IF ( FLOUT(7) ) THEN - WRITE (NDSO,987) - DO J=1,NOGRP - DO K=1,NGRPP - IF ( FLOGR2(J,K) ) WRITE (NDSO,976) IDOUT(J,K) - END DO - END DO - END IF -! - IF ( FLOUT(2) ) THEN - WRITE (NDSO,977) NOPTS - IF ( NOPTS .EQ. 0 ) THEN - WRITE (NDSO,978) - ELSE - IF ( FLAGLL ) THEN - WRITE (NDSO,979) - ELSE - WRITE (NDSO,985) - END IF - DO IP=1, NOPTS - IF ( FLAGLL ) THEN - WRITE (NDSO,980) IP, FACTOR*PTLOC(1,IP), & - FACTOR*PTLOC(2,IP), PTNME(IP) - ELSE - WRITE (NDSO,986) IP, FACTOR*PTLOC(1,IP), & - FACTOR*PTLOC(2,IP), PTNME(IP) - END IF - END DO - END IF - END IF -! - CALL STME21 ( TIME , DTME21 ) - WRITE (NDSO,981) DTME21 - IF (FLLEV) THEN - CALL STME21 ( TLEV , DTME21 ) - WRITE (NDSO,982) DTME21 - END IF - IF (FLICE) THEN - CALL STME21 ( TICE , DTME21 ) - WRITE (NDSO,983) DTME21 - END IF - IF (FLRHOA) THEN - CALL STME21 ( TRHO , DTME21 ) - WRITE (NDSO,990) DTME21 + IF ( FLOUT(1) ) THEN + WRITE (NDSO,975) + DO J=1,NOGRP + DO K=1,NGRPP + IF ( FLOGRD(J,K) ) WRITE (NDSO,976) IDOUT(J,K) + END DO + END DO + END IF + ! + IF ( FLOUT(7) ) THEN + WRITE (NDSO,987) + DO J=1,NOGRP + DO K=1,NGRPP + IF ( FLOGR2(J,K) ) WRITE (NDSO,976) IDOUT(J,K) + END DO + END DO + END IF + ! + IF ( FLOUT(2) ) THEN + WRITE (NDSO,977) NOPTS + IF ( NOPTS .EQ. 0 ) THEN + WRITE (NDSO,978) + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSO,979) + ELSE + WRITE (NDSO,985) + END IF + DO IP=1, NOPTS + IF ( FLAGLL ) THEN + WRITE (NDSO,980) IP, FACTOR*PTLOC(1,IP), & + FACTOR*PTLOC(2,IP), PTNME(IP) + ELSE + WRITE (NDSO,986) IP, FACTOR*PTLOC(1,IP), & + FACTOR*PTLOC(2,IP), PTNME(IP) END IF -! - WRITE (NDSO,984) -! + END DO END IF -! - IF ( NOPTS .EQ. 0 ) FLOUT(2) = .FALSE. + END IF + ! + CALL STME21 ( TIME , DTME21 ) + WRITE (NDSO,981) DTME21 + IF (FLLEV) THEN + CALL STME21 ( TLEV , DTME21 ) + WRITE (NDSO,982) DTME21 + END IF + IF (FLICE) THEN + CALL STME21 ( TICE , DTME21 ) + WRITE (NDSO,983) DTME21 + END IF + IF (FLRHOA) THEN + CALL STME21 ( TRHO , DTME21 ) + WRITE (NDSO,990) DTME21 + END IF + ! + WRITE (NDSO,984) + ! + END IF + ! + IF ( NOPTS .EQ. 0 ) FLOUT(2) = .FALSE. #ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 7 - After allocation of group velocities' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -! Boundary set up for the directions -! -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.3", 1) + WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 7 - After allocation of group velocities' + call getMallocInfo(mallinfos) + call printMallInfo(10000+IAPROC,mallInfos) #endif + ! + ! Boundary set up for the directions + ! #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.4", 1) -#endif -! -! 8. Final MPI set up ----------------------------------------------- / -! -#ifdef W3_MPI - CALL W3MPII ( IMOD ) -#endif -#ifdef W3_MPI - CALL W3MPIO ( IMOD ) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.3", 1) #endif + ! + ! 8. Final MPI set up ----------------------------------------------- / + ! #ifdef W3_MPI - IF ( FLOUT(2) ) CALL W3MPIP ( IMOD ) + CALL W3MPII ( IMOD ) + CALL W3MPIO ( IMOD ) + IF ( FLOUT(2) ) CALL W3MPIP ( IMOD ) #endif -! + ! #ifdef W3_DEBUGINIT - CALL PRINT_WN_STATISTIC("W3INIT leaving") + CALL PRINT_WN_STATISTIC("W3INIT leaving") #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Leaving W3INIT") -#endif - RETURN -! -! Escape locations read errors : -! -#ifdef W3_DIST - 820 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8020) NSEA, NAPROC - CALL EXTCDE ( 820 ) + CALL PRINT_MY_TIME("Leaving W3INIT") #endif -! + RETURN + ! + ! Escape locations read errors : + ! #ifdef W3_DIST - 821 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8021) NSPEC, NAPROC - CALL EXTCDE ( 821 ) -#endif -! -#ifdef W3_DIST - 829 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8029) - CALL EXTCDE ( 829 ) +820 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8020) NSEA, NAPROC + CALL EXTCDE ( 820 ) + ! +821 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8021) NSPEC, NAPROC + CALL EXTCDE ( 821 ) + ! +829 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8029) + CALL EXTCDE ( 829 ) #endif -! - 888 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8000) IERR - CALL EXTCDE ( 1 ) -! - 889 CONTINUE -! === no process number filtering for test file !!! === - WRITE (NDSE,8001) IERR - CALL EXTCDE ( 2 ) -! -! Formats -! - 900 FORMAT ( ' WAVEWATCH III log file ', & - ' version ',A/ & - ' ==================================', & - '==================================='/ & - 50X,'date : ',A10/50X,'time : ',A8) - 920 FORMAT (/' Model definition file read.') - 930 FORMAT ( ' Restart file read; ',A) -! - 970 FORMAT (/' Grid name : ',A) - 971 FORMAT (/' ',A,' water levels.') - 972 FORMAT ( ' ',A,' curents.') - 973 FORMAT ( ' ',A,' winds.') - 974 FORMAT ( ' ',A,' ice fields.') - 988 FORMAT ( ' ',A,' momentum') - 989 FORMAT ( ' ',A,' air density') - 9972 FORMAT( ' ',A,' mud density.') - 9971 FORMAT( ' ',A,' mud thickness.') - 9970 FORMAT( ' ',A,' mud viscosity.') - 9973 FORMAT( ' ',A,' ice parameter 1') - 9974 FORMAT( ' ',A,' ice parameter 2') - 9975 FORMAT( ' ',A,' ice parameter 3') - 9976 FORMAT( ' ',A,' ice parameter 4') - 9977 FORMAT( ' ',A,' ice parameter 5') + ! +888 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8000) IERR + CALL EXTCDE ( 1 ) + ! +889 CONTINUE + ! === no process number filtering for test file !!! === + WRITE (NDSE,8001) IERR + CALL EXTCDE ( 2 ) + ! + ! Formats + ! +900 FORMAT ( ' WAVEWATCH III log file ', & + ' version ',A/ & + ' ==================================', & + '==================================='/ & + 50X,'date : ',A10/50X,'time : ',A8) +920 FORMAT (/' Model definition file read.') +930 FORMAT ( ' Restart file read; ',A) + ! +970 FORMAT (/' Grid name : ',A) +971 FORMAT (/' ',A,' water levels.') +972 FORMAT ( ' ',A,' curents.') +973 FORMAT ( ' ',A,' winds.') +974 FORMAT ( ' ',A,' ice fields.') +988 FORMAT ( ' ',A,' momentum') +989 FORMAT ( ' ',A,' air density') +9972 FORMAT( ' ',A,' mud density.') +9971 FORMAT( ' ',A,' mud thickness.') +9970 FORMAT( ' ',A,' mud viscosity.') +9973 FORMAT( ' ',A,' ice parameter 1') +9974 FORMAT( ' ',A,' ice parameter 2') +9975 FORMAT( ' ',A,' ice parameter 3') +9976 FORMAT( ' ',A,' ice parameter 4') +9977 FORMAT( ' ',A,' ice parameter 5') -! - 975 FORMAT (/' Gridded output fields : '/ & - '--------------------------------------------------') - 976 FORMAT ( ' ',A) -! - 977 FORMAT (/' Point output requested for',I6,' points : '/ & - '------------------------------------------') - 978 FORMAT (/' Point output disabled') - 979 FORMAT & - (/' point | longitude | latitude | name '/ & - ' --------|-------------|-------------|----------------') - 985 FORMAT & - (/' point | X | Y | name '/ & - ' --------|-------------|-------------|----------------') - 980 FORMAT ( 5X,I5,' |',2(F10.2,' |'),2X,A) - 986 FORMAT ( 5X,I5,' |',2(F8.1,'E3 |'),2X,A) -! - 981 FORMAT (/' Initial time : ',A) - 982 FORMAT ( ' Water level time : ',A) - 983 FORMAT ( ' Ice field time : ',A) - 990 FORMAT ( ' Air density time : ',A) -! - 984 FORMAT (// & - 37X,' | input | output |'/ & - 37X,' |-----------------------|------------------|'/ & + ! +975 FORMAT (/' Gridded output fields : '/ & + '--------------------------------------------------') +976 FORMAT ( ' ',A) + ! +977 FORMAT (/' Point output requested for',I6,' points : '/ & + '------------------------------------------') +978 FORMAT (/' Point output disabled') +979 FORMAT & + (/' point | longitude | latitude | name '/ & + ' --------|-------------|-------------|----------------') +985 FORMAT & + (/' point | X | Y | name '/ & + ' --------|-------------|-------------|----------------') +980 FORMAT ( 5X,I5,' |',2(F10.2,' |'),2X,A) +986 FORMAT ( 5X,I5,' |',2(F8.1,'E3 |'),2X,A) + ! +981 FORMAT (/' Initial time : ',A) +982 FORMAT ( ' Water level time : ',A) +983 FORMAT ( ' Ice field time : ',A) +990 FORMAT ( ' Air density time : ',A) + ! +984 FORMAT (// & + 37X,' | input | output |'/ & + 37X,' |-----------------------|------------------|'/ & 2X,' step | pass | date time |', & - ' b w l c t r i i1 i5 d | g p t r b f c r2 |'/ & + ' b w l c t r i i1 i5 d | g p t r b f c r2 |'/ & 2X,'--------|------|---------------------|', & - '-----------------------|------------------|'/ & + '-----------------------|------------------|'/ & 2X,'--------+------+---------------------+', & - '---------------------------+--------------+') - 987 FORMAT (/' Coupling output fields : '/ & - '--------------------------------------------------') -! - 8000 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & - ' ERROR IN OPENING LOG FILE'/ & - ' IOSTAT =',I5/) - 8001 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & - ' ERROR IN OPENING TEST FILE'/ & - ' IOSTAT =',I5/) - 8002 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & - ' SIGNIFICANT PART OF RESOURCES RESERVED FOR', & - ' OUTPUT :',F6.1,'%'/) + '---------------------------+--------------+') +987 FORMAT (/' Coupling output fields : '/ & + '--------------------------------------------------') + ! +8000 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' ERROR IN OPENING LOG FILE'/ & + ' IOSTAT =',I5/) +8001 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' ERROR IN OPENING TEST FILE'/ & + ' IOSTAT =',I5/) +8002 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & + ' SIGNIFICANT PART OF RESOURCES RESERVED FOR', & + ' OUTPUT :',F6.1,'%'/) #ifdef W3_DIST - 8020 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & +8020 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & ' NUMBER OF SEA POINTS LESS THAN NUMBER OF PROC.'/ & ' NSEA, NAPROC =',2I8/) - 8021 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & - ' NUMBER OF SPECTRAL POINTS LESS THAN NUMBER OF PROC.'/ & +8021 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' NUMBER OF SPECTRAL POINTS LESS THAN NUMBER OF PROC.'/ & ' NSPEC, NAPROC =',2I8/) - 8028 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & +8028 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & ' INCREASING TARGET IN MPP PROPAGATION MAP.'/ & ' IMBALANCE BETWEEN OVERALL AND CFL TIME STEPS'/) - 8029 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & +8029 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & ' SOMETHING WRONG WITH MPP PROPAGATION MAP.'/ & ' CALL HENDRIK !!!'/) #endif -! -#ifdef W3_T - 9000 FORMAT ( 'TEST W3INIT: MOD. NR. AND FILE EXT.: ',I4,' [',A,']') - 9001 FORMAT ( ' NR. OF PROCESSORS : ',3I4/ & - ' ASSIGNED PROCESSORS ',9I4) - 9002 FORMAT ( ' DATA SET NUMBERS : ',4I4) - 9003 FORMAT ( ' LOG FILE : [',A,']'/ & - ' TEST FILE : [',A,']') -#endif -! -#ifdef W3_T - 9020 FORMAT (' TEST W3INIT : IP, NTTOT, NTTARG :') - 9021 FORMAT ( ' ',3I8) - 9025 FORMAT (' TEST W3INIT : MPP PROPAGATION MAP SPECTRAL COMP.') - 9026 FORMAT (4X,I4,2X,24I4) - 9027 FORMAT (10X,24I4) -#endif -! -#ifdef W3_T - 9030 FORMAT (' TEST W3INIT : INITIALIZATION USING WINDS, ', & - 'PERFORMED IN W3WAVE') - 9031 FORMAT (' TEST W3INIT : STARTING FROM CALM CONDITIONS') -#endif -! -#ifdef W3_T - 9040 FORMAT (' TEST W3INIT : OUTPUT DATA, FIRST TIME, STEP, FLAG') - 9041 FORMAT (' ',I9.8,I7.6,F8.1,3X,L1) - 9042 FORMAT (' TEST W3INIT : FIRST TIME :') - 9043 FORMAT (' ',I9.8,I7.6) -#endif -! + ! #ifdef W3_T - 9050 FORMAT (' TEST W3INIT : INITIAL DEPTHS') +9000 FORMAT ( 'TEST W3INIT: MOD. NR. AND FILE EXT.: ',I4,' [',A,']') +9001 FORMAT ( ' NR. OF PROCESSORS : ',3I4/ & + ' ASSIGNED PROCESSORS ',9I4) +9002 FORMAT ( ' DATA SET NUMBERS : ',4I4) +9003 FORMAT ( ' LOG FILE : [',A,']'/ & + ' TEST FILE : [',A,']') + ! +9020 FORMAT (' TEST W3INIT : IP, NTTOT, NTTARG :') +9021 FORMAT ( ' ',3I8) +9025 FORMAT (' TEST W3INIT : MPP PROPAGATION MAP SPECTRAL COMP.') +9026 FORMAT (4X,I4,2X,24I4) +9027 FORMAT (10X,24I4) + ! +9030 FORMAT (' TEST W3INIT : INITIALIZATION USING WINDS, ', & + 'PERFORMED IN W3WAVE') +9031 FORMAT (' TEST W3INIT : STARTING FROM CALM CONDITIONS') + ! +9040 FORMAT (' TEST W3INIT : OUTPUT DATA, FIRST TIME, STEP, FLAG') +9041 FORMAT (' ',I9.8,I7.6,F8.1,3X,L1) +9042 FORMAT (' TEST W3INIT : FIRST TIME :') +9043 FORMAT (' ',I9.8,I7.6) + ! +9050 FORMAT (' TEST W3INIT : INITIAL DEPTHS') #endif #ifdef W3_T1 - 9051 FORMAT (' TEST W3INIT : ISEA =',I6,' DEPTH =',F7.1, & - ' IK, T, K, CG :') - 9052 FORMAT (' ',I3,F8.2,F8.4,F8.2) -#endif -!/ -!/ End of W3INIT ----------------------------------------------------- / -!/ - END SUBROUTINE W3INIT -!/ ------------------------------------------------------------------- / -!> -!> @brief Perform initializations for MPI version of model. -!> Data transpose only. -!> -!> @details Some derived data types are defined. All communiction in -!> W3GATH, W3SCAT and W3WAVE are initialized so that all -!> communication can be performed with single MPI_STARTALL, -!> MPI_TESTALL and MPI_WAITALL calls. -!> -!> @param[in] IMOD Model number. -!> -!> @author H. L. Tolman @date 11-May-2007 -!> - SUBROUTINE W3MPII ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 11-May-2007 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ Taken out of W3WAVE. -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) -!/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ -! 1. Purpose : -! -! Perform initializations for MPI version of model. -! Data transpose only. -! -! 2. Method : -! -! Some derived data types are defined. All communiction in -! W3GATH, W3SCAT and W3WAVE are initialized so that all -! communication can be performed with single MPI_STARTALL, -! MPI_TESTALL and MPI_WAITALL calls. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_TYPE_VECTOR, MPI_TYPE_COMMIT -! Subr. mpif.h MPI derived data type routines. -! -! MPI_SEND_INIT, MPI_RECV_INIT -! Subr. mpif.h MPI persistent communication calls. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Basic MPP set up partially performed in W3INIT. -! - Each processor has to be able to send out individual error -! messages in this routine ! -! - No testing on IMOD, since only called by W3INIT. -! - In version 3.09 STORE was split into a send and receive -! buffer, to avoid/reduce possible conflicts between the FORTRAN -! and MPI standards when a gather is posted in a given buffer -! right after a send is completed. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI MPI communication calls. -! -! !/S Subroutine tracing, -! !/T Test output, general. -! !/MPIT Test output, MPI communications details. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! +9051 FORMAT (' TEST W3INIT : ISEA =',I6,' DEPTH =',F7.1, & + ' IK, T, K, CG :') +9052 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#endif + !/ + !/ End of W3INIT ----------------------------------------------------- / + !/ + END SUBROUTINE W3INIT + !/ ------------------------------------------------------------------- / + !> + !> @brief Perform initializations for MPI version of model. + !> Data transpose only. + !> + !> @details Some derived data types are defined. All communiction in + !> W3GATH, W3SCAT and W3WAVE are initialized so that all + !> communication can be performed with single MPI_STARTALL, + !> MPI_TESTALL and MPI_WAITALL calls. + !> + !> @param[in] IMOD Model number. + !> + !> @author H. L. Tolman @date 11-May-2007 + !> + SUBROUTINE W3MPII ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 11-May-2007 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ Taken out of W3WAVE. + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) + !/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ + ! 1. Purpose : + ! + ! Perform initializations for MPI version of model. + ! Data transpose only. + ! + ! 2. Method : + ! + ! Some derived data types are defined. All communiction in + ! W3GATH, W3SCAT and W3WAVE are initialized so that all + ! communication can be performed with single MPI_STARTALL, + ! MPI_TESTALL and MPI_WAITALL calls. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_TYPE_VECTOR, MPI_TYPE_COMMIT + ! Subr. mpif.h MPI derived data type routines. + ! + ! MPI_SEND_INIT, MPI_RECV_INIT + ! Subr. mpif.h MPI persistent communication calls. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Wave model initialization routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Basic MPP set up partially performed in W3INIT. + ! - Each processor has to be able to send out individual error + ! messages in this routine ! + ! - No testing on IMOD, since only called by W3INIT. + ! - In version 3.09 STORE was split into a send and receive + ! buffer, to avoid/reduce possible conflicts between the FORTRAN + ! and MPI standards when a gather is posted in a given buffer + ! right after a send is completed. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI MPI communication calls. + ! + ! !/S Subroutine tracing, + ! !/T Test output, general. + ! !/MPIT Test output, MPI communications details. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NSEA - USE W3ADATMD, ONLY: NSEALM - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE CONSTANTS, ONLY: LPDLIB -#ifdef W3_MPI - USE W3GDATMD, ONLY: NSPEC - USE W3WDATMD, ONLY: VA - USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC, & - WW3_SPEC_VEC, IAPPRO, WADATS, & - NRQSG1, IRQSG1, NRQSG2, IRQSG2, & - GSTORE, SSTORE, MPIBUF, BSTAT, & - BISPL, ISPLOC, IBFLOC, NSPLOC -#endif - USE W3ODATMD, ONLY: NDST, NAPROC, IAPROC -!/ -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NXXXX -#ifdef W3_MPI - INTEGER :: IERR_MPI, ISP, IH, ITARG, & - IERR1, IERR2, IP + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY: NSEA + USE W3ADATMD, ONLY: NSEALM + USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE CONSTANTS, ONLY: LPDLIB +#ifdef W3_MPI + USE W3GDATMD, ONLY: NSPEC + USE W3WDATMD, ONLY: VA + USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC, & + WW3_SPEC_VEC, IAPPRO, WADATS, & + NRQSG1, IRQSG1, NRQSG2, IRQSG2, & + GSTORE, SSTORE, MPIBUF, BSTAT, & + BISPL, ISPLOC, IBFLOC, NSPLOC +#endif + USE W3ODATMD, ONLY: NDST, NAPROC, IAPROC + !/ + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NXXXX +#ifdef W3_MPI + INTEGER :: IERR_MPI, ISP, IH, ITARG, & + IERR1, IERR2, IP #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3MPII') + CALL STRACE (IENT, 'W3MPII') #endif -! -! 1. Set up derived data types -------------------------------------- / -! - NXXXX = NSEALM * NAPROC -! + ! + ! 1. Set up derived data types -------------------------------------- / + ! + NXXXX = NSEALM * NAPROC + ! #ifdef W3_MPI - CALL MPI_TYPE_VECTOR ( NSEALM, 1, NAPROC, MPI_REAL, WW3_FIELD_VEC, IERR_MPI ) + CALL MPI_TYPE_VECTOR ( NSEALM, 1, NAPROC, MPI_REAL, WW3_FIELD_VEC, IERR_MPI ) + CALL MPI_TYPE_VECTOR ( NSEALM, 1, NSPEC, MPI_REAL, WW3_SPEC_VEC, IERR_MPI ) + CALL MPI_TYPE_COMMIT ( WW3_FIELD_VEC, IERR_MPI ) + CALL MPI_TYPE_COMMIT ( WW3_SPEC_VEC, IERR_MPI ) #endif -#ifdef W3_MPI - CALL MPI_TYPE_VECTOR ( NSEALM, 1, NSPEC, MPI_REAL, WW3_SPEC_VEC, IERR_MPI ) + ! +#ifdef W3_MPIT + WRITE (NDST,9010) WW3_FIELD_VEC, WW3_SPEC_VEC #endif + ! #ifdef W3_MPI - CALL MPI_TYPE_COMMIT ( WW3_FIELD_VEC, IERR_MPI ) -#endif -#ifdef W3_MPI - CALL MPI_TYPE_COMMIT ( WW3_SPEC_VEC, IERR_MPI ) -#endif -! -#ifdef W3_MPIT - WRITE (NDST,9010) WW3_FIELD_VEC, WW3_SPEC_VEC -#endif -! -#ifdef W3_MPI - IF( IAPROC .GT. NAPROC ) THEN - NSPLOC = 0 - NRQSG1 = 0 - NRQSG2 = 0 + IF( IAPROC .GT. NAPROC ) THEN + NSPLOC = 0 + NRQSG1 = 0 + NRQSG2 = 0 #endif #ifdef W3_MPIT - WRITE (NDST,9011) + WRITE (NDST,9011) #endif #ifdef W3_MPI - RETURN - END IF + RETURN + END IF #endif -! -! 2. Set up scatters and gathers for W3WAVE ------------------------- / -! ( persistent communication calls ) -! + ! + ! 2. Set up scatters and gathers for W3WAVE ------------------------- / + ! ( persistent communication calls ) + ! #ifdef W3_DIST - IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN + IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN #endif #ifdef W3_MPI NSPLOC = 0 DO ISP=1, NSPEC IF ( IAPPRO(ISP) .EQ. IAPROC ) NSPLOC = NSPLOC + 1 - END DO -#endif -! -#ifdef W3_MPI + END DO + ! NRQSG1 = NSPEC - NSPLOC ALLOCATE ( WADATS(IMOD)%IRQSG1(MAX(1,NRQSG1),2) ) IRQSG1 => WADATS(IMOD)%IRQSG1 IH = 0 #endif -! + ! #ifdef W3_MPIT WRITE (NDST,9021) #endif #ifdef W3_MPI DO ISP=1, NSPEC IF ( IAPPRO(ISP) .NE. IAPROC ) THEN - ITARG = IAPPRO(ISP) - 1 - IH = IH + 1 - CALL MPI_SEND_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,1), IERR1 ) - CALL MPI_RECV_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,2), IERR2 ) + ITARG = IAPPRO(ISP) - 1 + IH = IH + 1 + CALL MPI_SEND_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,1), IERR1 ) + CALL MPI_RECV_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,2), IERR2 ) #endif #ifdef W3_MPIT - WRITE (NDST,9022) IH, ISP, ITARG+1, IRQSG1(IH,1), IERR1, IRQSG1(IH,2), IERR2 + WRITE (NDST,9022) IH, ISP, ITARG+1, IRQSG1(IH,1), IERR1, IRQSG1(IH,2), IERR2 #endif #ifdef W3_MPI - END IF - END DO + END IF + END DO #endif #ifdef W3_MPIT WRITE (NDST,9023) WRITE (NDST,9020) NRQSG1 #endif -! -! 3. Set up scatters and gathers for W3SCAT and W3GATH -------------- / -! Also set up buffering of data. -! + ! + ! 3. Set up scatters and gathers for W3SCAT and W3GATH -------------- / + ! Also set up buffering of data. + ! #ifdef W3_MPI NRQSG2 = MAX( 1 , NAPROC-1 ) ALLOCATE ( WADATS(IMOD)%IRQSG2(NRQSG2*NSPLOC,2), & - WADATS(IMOD)%GSTORE(NAPROC*NSEALM,MPIBUF), & - WADATS(IMOD)%SSTORE(NAPROC*NSEALM,MPIBUF) ) + WADATS(IMOD)%GSTORE(NAPROC*NSEALM,MPIBUF), & + WADATS(IMOD)%SSTORE(NAPROC*NSEALM,MPIBUF) ) NRQSG2 = NAPROC - 1 -#endif -! -#ifdef W3_MPI + ! IRQSG2 => WADATS(IMOD)%IRQSG2 GSTORE => WADATS(IMOD)%GSTORE SSTORE => WADATS(IMOD)%SSTORE -#endif -! -#ifdef W3_MPI + ! IH = 0 ISPLOC = 0 IBFLOC = 0 WADATS(IMOD)%GSTORE = 0. WADATS(IMOD)%SSTORE = 0. #endif -! -! 3.a Loop over local spectral components -! + ! + ! 3.a Loop over local spectral components + ! #ifdef W3_MPIT WRITE (NDST,9031) #endif -! + ! #ifdef W3_MPI DO ISP=1, NSPEC IF ( IAPPRO(ISP) .EQ. IAPROC ) THEN -#endif -! -#ifdef W3_MPI - ISPLOC = ISPLOC + 1 - IBFLOC = IBFLOC + 1 - IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 -#endif -! -! 3.b Loop over non-local processes -! -#ifdef W3_MPI - DO IP=1, NAPROC - IF ( IP .NE. IAPROC ) THEN -#endif -! -#ifdef W3_MPI - ITARG = IP - 1 - IH = IH + 1 -#endif -! -#ifdef W3_MPI - CALL MPI_RECV_INIT ( WADATS(IMOD)%GSTORE(IP,IBFLOC), 1, & - WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG2(IH,1), IERR2 ) - CALL MPI_SEND_INIT ( WADATS(IMOD)%SSTORE(IP,IBFLOC), 1, & - WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG2(IH,2), IERR2 ) + ! + ISPLOC = ISPLOC + 1 + IBFLOC = IBFLOC + 1 + IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 + ! + ! 3.b Loop over non-local processes + ! + DO IP=1, NAPROC + IF ( IP .NE. IAPROC ) THEN + ! + ITARG = IP - 1 + IH = IH + 1 + ! + CALL MPI_RECV_INIT ( WADATS(IMOD)%GSTORE(IP,IBFLOC), 1, & + WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG2(IH,1), IERR2 ) + CALL MPI_SEND_INIT ( WADATS(IMOD)%SSTORE(IP,IBFLOC), 1, & + WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG2(IH,2), IERR2 ) #endif #ifdef W3_MPIT - WRITE (NDST,9032) IH, ISP, ITARG+1, IBFLOC, & - IRQSG2(IH,1), IERR1, IRQSG2(IH,2), IERR2 + WRITE (NDST,9032) IH, ISP, ITARG+1, IBFLOC, & + IRQSG2(IH,1), IERR1, IRQSG2(IH,2), IERR2 #endif -! -! ... End of loops -! + ! + ! ... End of loops + ! #ifdef W3_MPI - END IF - END DO -#endif -! -#ifdef W3_MPI - END IF - END DO + END IF + END DO + ! + END IF + END DO #endif -! + ! #ifdef W3_MPIT WRITE (NDST,9033) WRITE (NDST,9030) NSPLOC, NRQSG2, IH #endif -! -! 4. Initialize buffer management ----------------------------------- / -! + ! + ! 4. Initialize buffer management ----------------------------------- / + ! #ifdef W3_MPI BSTAT = 0 BISPL = 0 ISPLOC = 0 IBFLOC = 0 #endif -! + ! #ifdef W3_DIST - END IF -#endif - RETURN -! -! Format statements -! -#ifdef W3_MPIT - 9010 FORMAT ( ' TEST W3MPII: DATA TYPES DEFINED'/ & - ' WW3_FIELD_VEC : ',I10/ & - ' WW3_SPEC_VEC : ',I10) - 9011 FORMAT ( ' TEST W3MPII: NO COMPUTATIONS ON THIS NODE') -#endif -! -#ifdef W3_MPIT - 9020 FORMAT ( ' TEST W3MPII: W3WAVE COMM. SET UP FINISHED'/ & - ' NRQSG1 : ',I10) - 9021 FORMAT (/' TEST W3MPII: COMMUNICATION CALLS FOR W3WAVE '/ & - ' +------+------+------+--------------+--------------+'/ & - ' | IH | ISP | TARG | SCATTER | GATHER |'/ & - ' | | | | handle err | handle err |'/ & - ' +------+------+------+--------------+--------------+') - 9022 FORMAT ( ' |',3(I5,' |'),2(I9,I4,' |')) - 9023 FORMAT ( & - ' +------+------+------+--------------+--------------+'/) -#endif -! -#ifdef W3_MPIT - 9030 FORMAT ( ' TEST W3MPII: GATH/SCAT COMM. SET UP FINISHED'/ & - ' NSPLOC : ',I10/ & - ' NRQSG2 : ',I10/ & - ' TOTAL REQ. : ',I10/) - 9031 FORMAT (/' TEST W3MPII: COMM. CALLS FOR W3GATH/W3SCAT '/ & - ' +------+------+------+------+--------------+', & - '--------------+'/ & - ' | IH | ISP | TARG | IBFR | GATHER |', & - ' SCATTER |'/ & - ' | | | | | handle err |', & - ' handle err |'/ & - ' +------+------+------+------+--------------+', & - '--------------+') - 9032 FORMAT ( ' |',4(I5,' |'),2(I9,I4,' |')) - 9033 FORMAT ( ' +------+------+------+------+--------------+', & - '--------------+'/) -#endif -!/ -!/ End of W3MPII ----------------------------------------------------- / -!/ - END SUBROUTINE W3MPII -!/ ------------------------------------------------------------------- / -!> -!> @brief Prepare MPI persistent communication needed for WAVEWATCH I/O -!> routines. -!> -!> @details Create handles as needed. The communication as set up -!> in W3MPII uses tags with number ranging from 1 through NSPEC. -!> New and unique tags for IO related communication are assigned -!> here dynamically. No testing on IMOD, since only called by W3INIT. -!> -!> @param[in] IMOD Model number. -!> -!> @author H. L. Tolman @date 11-Nov-2015 -!> - SUBROUTINE W3MPIO ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 11-Nov-2015 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 11-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ Taken out of W3WAVE. -!/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 21-Jul-2005 : Add output fields. ( version 3.07 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 02-Aug-2006 : W3MPIP split off. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ Add user-defined field data. -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 25-Dec-2012 : Modify field output MPI for new ( version 4.11 ) -!/ structure and smaller memory footprint. -!/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) -!/ 11-Nov-2015 : Added ICEF ( version 5.08 ) -!/ -! 1. Purpose : -! -! Prepare MPI persistent communication needed for WAVEWATCH I/O -! routines. -! -! 2. Method : -! -! Create handles as needed. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3XDMA Subr. W3ADATMD Dimension expanded output arrays. -! W3SETA Subr. " Set pointers for output arrays -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_SEND_INIT, MPI_RECV_INIT -! Subr. mpif.h MPI persistent communication calls. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - The communication as set up in W3MPII uses tags with number -! ranging from 1 through NSPEC. New and unique tags for IO -! related communication are assigned here dynamically. -! - No testing on IMOD, since only called by W3INIT. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI MPI communication calls. -! -! !/S Enable subroutine tracing. -! !/MPIT Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -#ifdef W3_MPI - USE W3ADATMD, ONLY: W3XDMA, W3SETA, W3XETA - USE W3IORSMD, ONLY: OARST + END IF #endif - USE W3SERVMD, ONLY: EXTCDE + RETURN + ! + ! Format statements + ! +#ifdef W3_MPIT +9010 FORMAT ( ' TEST W3MPII: DATA TYPES DEFINED'/ & + ' WW3_FIELD_VEC : ',I10/ & + ' WW3_SPEC_VEC : ',I10) +9011 FORMAT ( ' TEST W3MPII: NO COMPUTATIONS ON THIS NODE') +9020 FORMAT ( ' TEST W3MPII: W3WAVE COMM. SET UP FINISHED'/ & + ' NRQSG1 : ',I10) +9021 FORMAT (/' TEST W3MPII: COMMUNICATION CALLS FOR W3WAVE '/ & + ' +------+------+------+--------------+--------------+'/ & + ' | IH | ISP | TARG | SCATTER | GATHER |'/ & + ' | | | | handle err | handle err |'/ & + ' +------+------+------+--------------+--------------+') +9022 FORMAT ( ' |',3(I5,' |'),2(I9,I4,' |')) +9023 FORMAT ( & + ' +------+------+------+--------------+--------------+'/) +9030 FORMAT ( ' TEST W3MPII: GATH/SCAT COMM. SET UP FINISHED'/ & + ' NSPLOC : ',I10/ & + ' NRQSG2 : ',I10/ & + ' TOTAL REQ. : ',I10/) +9031 FORMAT (/' TEST W3MPII: COMM. CALLS FOR W3GATH/W3SCAT '/ & + ' +------+------+------+------+--------------+', & + '--------------+'/ & + ' | IH | ISP | TARG | IBFR | GATHER |', & + ' SCATTER |'/ & + ' | | | | | handle err |', & + ' handle err |'/ & + ' +------+------+------+------+--------------+', & + '--------------+') +9032 FORMAT ( ' |',4(I5,' |'),2(I9,I4,' |')) +9033 FORMAT ( ' +------+------+------+------+--------------+', & + '--------------+'/) +#endif + !/ + !/ End of W3MPII ----------------------------------------------------- / + !/ + END SUBROUTINE W3MPII + !/ ------------------------------------------------------------------- / + !> + !> @brief Prepare MPI persistent communication needed for WAVEWATCH I/O + !> routines. + !> + !> @details Create handles as needed. The communication as set up + !> in W3MPII uses tags with number ranging from 1 through NSPEC. + !> New and unique tags for IO related communication are assigned + !> here dynamically. No testing on IMOD, since only called by W3INIT. + !> + !> @param[in] IMOD Model number. + !> + !> @author H. L. Tolman @date 11-Nov-2015 + !> + SUBROUTINE W3MPIO ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 11-Nov-2015 | + !/ +-----------------------------------+ + !/ + !/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 11-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 20-Aug-2003 : Output server options added. ( version 3.04 ) + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ Taken out of W3WAVE. + !/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 21-Jul-2005 : Add output fields. ( version 3.07 ) + !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 02-Aug-2006 : W3MPIP split off. ( version 3.10 ) + !/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) + !/ Add user-defined field data. + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 25-Dec-2012 : Modify field output MPI for new ( version 4.11 ) + !/ structure and smaller memory footprint. + !/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) + !/ 11-Nov-2015 : Added ICEF ( version 5.08 ) + !/ + ! 1. Purpose : + ! + ! Prepare MPI persistent communication needed for WAVEWATCH I/O + ! routines. + ! + ! 2. Method : + ! + ! Create handles as needed. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3XDMA Subr. W3ADATMD Dimension expanded output arrays. + ! W3SETA Subr. " Set pointers for output arrays + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_SEND_INIT, MPI_RECV_INIT + ! Subr. mpif.h MPI persistent communication calls. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Wave model initialization routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - The communication as set up in W3MPII uses tags with number + ! ranging from 1 through NSPEC. New and unique tags for IO + ! related communication are assigned here dynamically. + ! - No testing on IMOD, since only called by W3INIT. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI MPI communication calls. + ! + ! !/S Enable subroutine tracing. + ! !/MPIT Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! +#ifdef W3_MPI + USE W3ADATMD, ONLY: W3XDMA, W3SETA, W3XETA + USE W3IORSMD, ONLY: OARST +#endif + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3GDATMD, ONLY: NSEA - USE W3ADATMD, ONLY: NSEALM + !/ + USE W3GDATMD, ONLY: NSEA + USE W3ADATMD, ONLY: NSEALM #ifdef W3_MPI - USE W3GDATMD, ONLY: NX, NSPEC, MAPFS, E3DF, P2MSF, US3DF, USSPF - USE W3WDATMD, ONLY: VA, UST, USTDIR, ASF, FPIS, ICEF - USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC - USE W3ADATMD, ONLY: HS, WLM, T02 + USE W3GDATMD, ONLY: NX, NSPEC, MAPFS, E3DF, P2MSF, US3DF, USSPF + USE W3WDATMD, ONLY: VA, UST, USTDIR, ASF, FPIS, ICEF + USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC + USE W3ADATMD, ONLY: HS, WLM, T02 #endif #ifdef W3_MPI - USE W3ADATMD, ONLY: T0M1, THM, THS, FP0, THP0, & - DTDYN, FCUT, SPPNT, ABA, ABD, UBA, UBD,& - SXX, SYY, SXY, USERO, PHS, PTP, PLP, & - PDIR, PSI, PWS, PWST, PNR, PHIAW, PHIOC,& - TUSX, TUSY, TAUWIX, TAUWIY, TAUOX, & - TAUOY, USSX, USSY, MSSX, MSSY, MSSD, & - MSCX, MSCY, MSCD, PRMS, TPMS, CHARN, & - TWS, TAUWNX, TAUWNY, BHD, CGE, & - CFLXYMAX, CFLTHMAX, CFLKMAX, WHITECAP, & - BEDFORMS, PHIBBL, TAUBBL, T01, & - P2SMS, US3D, EF, TH1M, STH1M, TH2M, & - STH2M, HSIG, PHICE, TAUICE, USSP, & - STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD, & - HCMAXD, QP, PTHP0, PQP, PPE, PGW, PSW, & - PTM1, PT1, PT2, PEP, WBT, CX, CY, & - TAUOCX, TAUOCY, WNMEAN + USE W3ADATMD, ONLY: T0M1, THM, THS, FP0, THP0, & + DTDYN, FCUT, SPPNT, ABA, ABD, UBA, UBD,& + SXX, SYY, SXY, USERO, PHS, PTP, PLP, & + PDIR, PSI, PWS, PWST, PNR, PHIAW, PHIOC,& + TUSX, TUSY, TAUWIX, TAUWIY, TAUOX, & + TAUOY, USSX, USSY, MSSX, MSSY, MSSD, & + MSCX, MSCY, MSCD, PRMS, TPMS, CHARN, & + TWS, TAUWNX, TAUWNY, BHD, CGE, & + CFLXYMAX, CFLTHMAX, CFLKMAX, WHITECAP, & + BEDFORMS, PHIBBL, TAUBBL, T01, & + P2SMS, US3D, EF, TH1M, STH1M, TH2M, & + STH2M, HSIG, PHICE, TAUICE, USSP, & + STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD, & + HCMAXD, QP, PTHP0, PQP, PPE, PGW, PSW, & + PTM1, PT1, PT2, PEP, WBT, CX, CY, & + TAUOCX, TAUOCY, WNMEAN #endif #ifdef W3_CESMCOUPLED - USE W3ADATMD, ONLY: LANGMT, LAPROJ, ALPHAL, LASL, LASLPJ, & - ALPHALS, LAMULT + USE W3ADATMD, ONLY: LANGMT, LAPROJ, ALPHAL, LASL, LASLPJ, & + ALPHALS, LAMULT #endif #ifdef W3_MPI - USE W3GDATMD, ONLY: NK - USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NTPROC, FLOUT, & - NAPFLD, NAPPNT, NAPRST, NAPBPT, NAPTRK,& - NOGRP, NGRPP, NOGE, FLOGRR - USE W3ODATMD, ONLY: OUTPTS, NRQGO, NRQGO2, IRQGO, IRQGO2, & - FLOGRD, NRQPO, NRQPO2, IRQPO1, IRQPO2, & - NOPTS, IPTINT, NRQRS, IRQRS, NBLKRS, & - RSBLKS, IRQRSS, VAAUX, NRQBP, NRQBP2, & - IRQBP1, IRQBP2, NFBPO, NBO2, ISBPO, & - ABPOS, NRQTR, IRQTR, IT0PNT, IT0TRK, & - IT0PRT, NOSWLL, NOEXTR, NDSE, IOSTYP, & - FLOGR2 - USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC -#endif - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE CONSTANTS, ONLY: LPDLIB -!/ -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_MPI - INTEGER :: IK, IFJ - INTEGER :: IH, IT0, IROOT, IT, IERR, I0, & - IFROM, IX(4), IY(4), IS(4), & - IP(4), I, J, JSEA, ITARG, IB, & - JSEA0, JSEAN, NSEAB, IBOFF, & - ISEA, ISPROC, K, NRQMAX + USE W3GDATMD, ONLY: NK + USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NTPROC, FLOUT, & + NAPFLD, NAPPNT, NAPRST, NAPBPT, NAPTRK,& + NOGRP, NGRPP, NOGE, FLOGRR + USE W3ODATMD, ONLY: OUTPTS, NRQGO, NRQGO2, IRQGO, IRQGO2, & + FLOGRD, NRQPO, NRQPO2, IRQPO1, IRQPO2, & + NOPTS, IPTINT, NRQRS, IRQRS, NBLKRS, & + RSBLKS, IRQRSS, VAAUX, NRQBP, NRQBP2, & + IRQBP1, IRQBP2, NFBPO, NBO2, ISBPO, & + ABPOS, NRQTR, IRQTR, IT0PNT, IT0TRK, & + IT0PRT, NOSWLL, NOEXTR, NDSE, IOSTYP, & + FLOGR2 + USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC +#endif + USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE CONSTANTS, ONLY: LPDLIB + !/ + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ +#ifdef W3_MPI + INTEGER :: IK, IFJ + INTEGER :: IH, IT0, IROOT, IT, IERR, I0, & + IFROM, IX(4), IY(4), IS(4), & + IP(4), I, J, JSEA, ITARG, IB, & + JSEA0, JSEAN, NSEAB, IBOFF, & + ISEA, ISPROC, K, NRQMAX #endif #ifdef W3_S - INTEGER, SAVE :: IENT + INTEGER, SAVE :: IENT #endif #ifdef W3_MPI - LOGICAL :: FLGRDALL(NOGRP,NGRPP) - LOGICAL :: FLGRDARST(NOGRP,NGRPP) + LOGICAL :: FLGRDALL(NOGRP,NGRPP) + LOGICAL :: FLGRDARST(NOGRP,NGRPP) #endif #ifdef W3_MPIT - CHARACTER(LEN=5) :: STRING + CHARACTER(LEN=5) :: STRING #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3MPIO') + CALL STRACE (IENT, 'W3MPIO') #endif -! -! 1. Set-up for W3IOGO ---------------------------------------------- / -! + ! + ! 1. Set-up for W3IOGO ---------------------------------------------- / + ! #ifdef W3_MPI - DO J=1, NOGRP - DO K=1, NGRPP - FLGRDALL (J,K) = (FLOGRD(J,K) .OR. FLOGR2(J,K)) - FLGRDARST(J,K) = (FLGRDALL(J,K) .OR. FLOGRR(J,K)) - END DO - END DO -#endif -! -#ifdef W3_MPI - NRQGO = 0 - NRQGO2 = 0 - IT0 = NSPEC - IROOT = NAPFLD - 1 -#endif -! -! -#ifdef W3_MPI - IF ((FLOUT(1) .OR. FLOUT(7)).and.(.not. LPDLIB .or. & - (GTYPE .ne. UNGTYPE).or. .TRUE.)) THEN -#endif -! -! NRQMAX is the maximum number of output fields that require MPI communication, -! aimed to gather field values stored in each processor into one processor in -! charge of model output; for each of such fields, this routine requires one -! call to MPI_SEND_INIT and MPI_RECV_INIT storing the communication request -! handles in the vectors IRQGO and IRQGO2 respectively. -! NRQMAX is calculated as the sum of all fields described before (Hs) -! + 2 or 3 component fields (CUR) + 3 component fields + extra fields -! For group 1 fields except ICEF, all processors contain information on all -! grid points because they are input fields, and therefore this MPI -! communication is not necessary and they do not contribute to NRQMAX. -! -#ifdef W3_MPI - ! Calculation of NRQMAX splitted by output groups and field type - ! scalar 2-comp 3-comp - NRQMAX = 1 + 0 + 0 + & ! group 1 - 18 + 0 + 0 + & ! group 2 - 0 + 0 + 0 + & ! group 3 (extra contributions below) - 2+(NOGE(4)-2)*(NOSWLL+1) + 0 + 0 + & ! group 4 - 11 + 3 + 1 + & ! group 5 - 12 + 7 + 1 + & ! group 6 (extra contributions below) - 5 + 4 + 1 + & ! group 7 - 5 + 2 + 0 + & ! group 8 - 5 + 0 + 0 + & ! group 9 - NOEXTR + 0 + 0 ! group 10 + DO J=1, NOGRP + DO K=1, NGRPP + FLGRDALL (J,K) = (FLOGRD(J,K) .OR. FLOGR2(J,K)) + FLGRDARST(J,K) = (FLGRDALL(J,K) .OR. FLOGRR(J,K)) + END DO + END DO + ! + NRQGO = 0 + NRQGO2 = 0 + IT0 = NSPEC + IROOT = NAPFLD - 1 + ! + ! + IF ((FLOUT(1) .OR. FLOUT(7)).and.(.not. LPDLIB .or. & + (GTYPE .ne. UNGTYPE).or. .TRUE.)) THEN + ! + ! NRQMAX is the maximum number of output fields that require MPI communication, + ! aimed to gather field values stored in each processor into one processor in + ! charge of model output; for each of such fields, this routine requires one + ! call to MPI_SEND_INIT and MPI_RECV_INIT storing the communication request + ! handles in the vectors IRQGO and IRQGO2 respectively. + ! NRQMAX is calculated as the sum of all fields described before (Hs) + ! + 2 or 3 component fields (CUR) + 3 component fields + extra fields + ! For group 1 fields except ICEF, all processors contain information on all + ! grid points because they are input fields, and therefore this MPI + ! communication is not necessary and they do not contribute to NRQMAX. + ! + ! Calculation of NRQMAX splitted by output groups and field type + ! scalar 2-comp 3-comp + NRQMAX = 1 + 0 + 0 + & ! group 1 + 18 + 0 + 0 + & ! group 2 + 0 + 0 + 0 + & ! group 3 (extra contributions below) + 2+(NOGE(4)-2)*(NOSWLL+1) + 0 + 0 + & ! group 4 + 11 + 3 + 1 + & ! group 5 + 12 + 7 + 1 + & ! group 6 (extra contributions below) + 5 + 4 + 1 + & ! group 7 + 5 + 2 + 0 + & ! group 8 + 5 + 0 + 0 + & ! group 9 + NOEXTR + 0 + 0 ! group 10 - ! Extra contributions to NRQMAX from group 3 - DO IFJ=1,5 - IF ( FLGRDALL( 3,IFJ)) NRQMAX = NRQMAX + & - E3DF(3,IFJ) - E3DF(2,IFJ) + 1 - END DO - ! Extra contributions to NRQMAX from group 6 - IF ( FLGRDALL( 6,9)) NRQMAX = NRQMAX + & - P2MSF(3) - P2MSF(2) + 1 - IF ( FLGRDALL( 6, 8) ) NRQMAX = NRQMAX + 2*NK - IF ( FLGRDALL( 6,12) ) NRQMAX = NRQMAX + 2*NK -#endif -! -#ifdef W3_MPI - IF ( NRQMAX .GT. 0 ) THEN - ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO(NRQMAX) ) - ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO2(NRQMAX*NAPROC) ) - END IF - IRQGO => OUTPTS(IMOD)%OUT1%IRQGO - IRQGO2 => OUTPTS(IMOD)%OUT1%IRQGO2 + ! Extra contributions to NRQMAX from group 3 + DO IFJ=1,5 + IF ( FLGRDALL( 3,IFJ)) NRQMAX = NRQMAX + & + E3DF(3,IFJ) - E3DF(2,IFJ) + 1 + END DO + ! Extra contributions to NRQMAX from group 6 + IF ( FLGRDALL( 6,9)) NRQMAX = NRQMAX + & + P2MSF(3) - P2MSF(2) + 1 + IF ( FLGRDALL( 6, 8) ) NRQMAX = NRQMAX + 2*NK + IF ( FLGRDALL( 6,12) ) NRQMAX = NRQMAX + 2*NK + ! + IF ( NRQMAX .GT. 0 ) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO(NRQMAX) ) + ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO2(NRQMAX*NAPROC) ) + END IF + IRQGO => OUTPTS(IMOD)%OUT1%IRQGO + IRQGO2 => OUTPTS(IMOD)%OUT1%IRQGO2 + ! + ! 1.a Sends of fields + ! + IH = 0 + ! + IF ( IAPROC .LE. NAPROC ) THEN + IT = IT0 #endif -! -! 1.a Sends of fields -! -#ifdef W3_MPI - IH = 0 +#ifdef W3_MPIT + WRITE (NDST,9010) '(SEND)' #endif -! + ! #ifdef W3_MPI - IF ( IAPROC .LE. NAPROC ) THEN - IT = IT0 + IF ( FLGRDALL( 1, 12) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ICEF (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9010) '(SEND)' + WRITE (NDST,9011) IH, ' 1/09', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 1, 12) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (ICEF (IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 1/09', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 2/01', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HS (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WLM (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/02', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WLM (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (T02 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/03', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (T02 (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (T0M1 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/04', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (T0M1 (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (T01 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/04', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 2/05', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (T01 (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN + ! TP output shares FP0 internal field with FP + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (FP0 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/06', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN - ! TP output shares FP0 internal field with FP - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (FP0 (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (THM (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/07', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (THM (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (THS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/07', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 8) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (THS (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (THP0 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 9) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (THP0 (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HSIG (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/10', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HSIG (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STMAXE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/10', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/11', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (STMAXE (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 12) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STMAXD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/11', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/12', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 12) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (STMAXD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HMAXE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/12', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 2/13', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 13) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HMAXE (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HCMAXE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/13', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/14', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 14) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HCMAXE (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 15) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HMAXD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/14', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 2/15', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 15) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HMAXD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HCMAXD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/15', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 2/16', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 2, 17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WBT (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/17', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 16) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HCMAXD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 2, 19) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WNMEAN(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/16', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 2/19', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 3, 1) ) THEN + DO IK=E3DF(2,1),E3DF(3,1) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (EF(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'EF', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 17) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WBT (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END DO + END IF + ! + IF ( FLGRDALL( 3, 2) ) THEN + DO IK=E3DF(2,2),E3DF(3,2) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TH1M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/17', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, 'TH1M', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + END DO + END IF + ! + IF ( FLGRDALL( 3, 3) ) THEN + DO IK=E3DF(2,3),E3DF(3,3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STH1M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'STH1M', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 2, 19) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WNMEAN(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END DO + END IF + ! + IF ( FLGRDALL( 3, 4) ) THEN + DO IK=E3DF(2,4),E3DF(3,4) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TH2M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/19', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, 'TH2M', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + END DO + END IF + ! + IF ( FLGRDALL( 3, 5) ) THEN + DO IK=E3DF(2,5),E3DF(3,5) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STH2M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'STH2M', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 3, 1) ) THEN - DO IK=E3DF(2,1),E3DF(3,1) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (EF(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END DO + END IF + ! + IF ( FLGRDALL( 4, 1) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHS(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, 'EF', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 4/01', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4, 2) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PTP(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/02', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 3, 2) ) THEN - DO IK=E3DF(2,2),E3DF(3,2) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TH1M(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END DO + END IF + ! + IF ( FLGRDALL( 4, 3) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PLP(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, 'TH1M', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 4/03', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4, 4) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PDIR(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/04', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 3, 3) ) THEN - DO IK=E3DF(2,3),E3DF(3,3) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (STH1M(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END DO + END IF + ! + IF ( FLGRDALL( 4, 5) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PSI(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, 'STH1M', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 4/05', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4, 6) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PWS(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/06', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 3, 4) ) THEN - DO IK=E3DF(2,4),E3DF(3,4) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TH2M(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END DO + END IF + ! + IF ( FLGRDALL( 4, 7) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PTHP0(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, 'TH2M', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 4/07', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4, 8) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PQP (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/08', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 3, 5) ) THEN - DO IK=E3DF(2,5),E3DF(3,5) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (STH2M(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END DO + END IF + ! + IF ( FLGRDALL( 4, 9) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PPE (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, 'STH2M', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 4/09', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4,10) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PGW (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/10', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 1) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PHS(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END DO + END IF + ! + IF ( FLGRDALL( 4,11) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PSW (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/01', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 4/11', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4,12) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PTM1(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/12', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 2) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PTP(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END DO + END IF + ! + ! + IF ( FLGRDALL( 4,13) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PT1 (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/02', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 4/13', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4,14) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PT2 (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/14', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 3) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PLP(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END DO + END IF + ! + IF ( FLGRDALL( 4,15) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PEP (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/03', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 4/15', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4,16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PWST (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/16', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 4) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PDIR(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + ! + IF ( FLGRDALL( 4,17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PNR (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/04', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 4/17', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 5, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 5) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PSI(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/05', IROOT, IT, IRQGO(IH), IERR + WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ASF (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) #endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 6) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PWS(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 7) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PTHP0(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/07', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 8) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PQP (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/08', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 9) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PPE (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/09', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,10) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PGW (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/10', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,11) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PSW (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/11', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,12) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PTM1(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/12', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,13) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PT1 (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/13', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,14) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PT2 (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/14', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,15) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PEP (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/15', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,16) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PWST (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/16', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,17) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PNR (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/17', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (ASF (IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (CHARN(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (CGE (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PHIAW(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUWIX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUWIY(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 6) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUWNX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUWNY(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WHITECAP(1,1),NSEALM , MPI_REAL, IROOT,& - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/07', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 8) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WHITECAP(1,2),NSEALM , MPI_REAL, IROOT,& - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/08', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 9) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WHITECAP(1,3),NSEALM , MPI_REAL, IROOT,& - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/09', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5,10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WHITECAP(1,4),NSEALM , MPI_REAL, IROOT,& - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/10', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TWS(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/11', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (SXX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (SYY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (SXY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUOX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUOY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (BHD(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PHIOC (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TUSX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TUSY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 6) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (USSX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (USSY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PRMS (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TPMS (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 8) ) THEN - DO IK=1,2*NK - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (US3D(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'US3D ', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 9) ) THEN - DO K=P2MSF(2),P2MSF(3) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (P2SMS(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'P2SMS', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6,10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUICE (1,1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUICE (1,2),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6,11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PHICE (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/11', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif - -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 12) ) THEN - DO IK=1,2*NK - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (USSP(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'USSP ', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif - -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 13) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUOCX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUOCY(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI -#ifdef W3_CESMCOUPLED - IF ( FLGRDALL( 6, 14) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (LANGMT(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/14', IROOT, IT, IRQGO(IH), IERR -#endif - END IF -#endif !W3_CESMCOUPLED -#endif !W3_MPI -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (ABA (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (ABD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (UBA (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (UBD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (BEDFORMS(1,1),NSEALM , MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (BEDFORMS(1,2),NSEALM , MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (BEDFORMS(1,3),NSEALM , MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PHIBBL(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUBBL(1,1),NSEALM , MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUBBL(1,2),NSEALM , MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSSX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSSY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSCX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSCY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSSD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSCD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (QP (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (DTDYN(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (FCUT (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (CFLXYMAX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (CFLTHMAX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (CFLKMAX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - DO I=1, NOEXTR - IF ( FLGRDALL(10, I) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (USERO(1,I),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (STRING,'(A3,I2.2)') '10/', I - WRITE (NDST,9011) IH, STRING, IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF - END DO -#endif -! -#ifdef W3_MPI - NRQGO = IH -#endif -#ifdef W3_MPIT - WRITE (NDST,9012) - WRITE (NDST,9013) NRQGO, NRQMAX -#endif -! -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( NRQGO .GT. NRQMAX ) THEN - WRITE (NDSE,1010) NRQGO, NRQMAX - CALL EXTCDE (10) - END IF -#endif -! -#ifdef W3_MPI - IF ( IAPROC .EQ. NAPFLD ) THEN -#endif -! -! 1.b Setting up expanded arrays -! -#ifdef W3_MPI - IF (NAPFLD .EQ. NAPRST) THEN - CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDARST ) - ELSE - CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDALL ) - ENDIF -#endif -! -! 1.c Receives of fields -! -#ifdef W3_MPI - CALL W3XETA ( IMOD, NDSE, NDST ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9010) '(RECV)' -#endif -! -#ifdef W3_MPI - IH = 0 -#endif -! -#ifdef W3_MPI - DO I0=1, NAPROC - IT = IT0 - IFROM = I0 - 1 -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 1, 12) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 1/09', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (T02 (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (T0M1 (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/04', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (T01(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN - ! TP output shares FP0 internal field with FP - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/06', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/07', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 8) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (THS (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/08', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 9) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (THP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/09', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HSIG (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/10', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (STMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/11', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 12) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (STMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/12', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 13) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/13', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 14) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HCMAXE(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/14', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 15) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HMAXD (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/15', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 16) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HCMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/16', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 17) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WBT(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/17', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 19) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/19', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 1) ) THEN - DO IK=E3DF(2,1),E3DF(3,1) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (EF(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'EF', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 2) ) THEN - DO IK=E3DF(2,2),E3DF(3,2) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'TH1M', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 3) ) THEN - DO IK=E3DF(2,3),E3DF(3,3) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (STH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'STH1M', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 3, 4) ) THEN - DO IK=E3DF(2,4),E3DF(3,4) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CHARN(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, 'TH2M', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/02', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 5, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CGE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/03', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 3, 5) ) THEN - DO IK=E3DF(2,5),E3DF(3,5) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (STH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHIAW(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, 'STH2M', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/04', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 5, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWIX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 1) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PHS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWIY(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/01', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 5, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWNX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 2) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PTP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWNY(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/02', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 5, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,1),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/07', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 3) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PLP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,2),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/03', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/08', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 5, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,3),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/09', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 4) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PDIR(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,4),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/04', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/10', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 5, 11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TWS(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/11', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 5) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PSI(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 6, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (SXX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/05', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (SYY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 6) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PWS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (SXY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/06', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 6, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 7) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PTHP0(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/07', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 6, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BHD(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/03', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 8) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PQP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 6, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHIOC (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/08', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/04', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 6, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TUSX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4, 9) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PPE(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TUSY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/09', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 6, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USSX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4,10) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PGW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USSY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/10', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 6, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PRMS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4,11) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PSW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TPMS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/11', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 6, 8) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (US3D(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'US3D ', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4,12) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PTM1(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 6, 9) ) THEN + DO K=P2MSF(2),P2MSF(3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (P2SMS(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/12', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, 'P2SMS', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 6,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUICE (1,1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4,13) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PT1(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUICE (1,2),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/13', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! + IF ( FLGRDALL( 6,11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHICE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/11', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4,14) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PT2(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 6, 12) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USSP(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/14', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, 'USSP ', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 6, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOCX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4,15) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PEP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOCY(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/15', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END IF + ! +#ifdef W3_CESMCOUPLED + IF ( FLGRDALL( 6, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (LANGMT(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/14', IROOT, IT, IRQGO(IH), IERR #endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,16) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PWST (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF +#endif !W3_CESMCOUPLED + IF ( FLGRDALL( 7, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ABA (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/16', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ABD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 4,17) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PNR (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 7, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (UBA (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/17', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (UBD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 5, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (UST (I0), 1, WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 7, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BEDFORMS(1,1),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (USTDIR(I0), 1, WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BEDFORMS(1,2),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (ASF (I0), 1, WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BEDFORMS(1,3),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 7, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHIBBL(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/04', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 5, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 7, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUBBL(1,1),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/02', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUBBL(1,2),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 5, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (CGE (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 8, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSSX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/03', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSSY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 5, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PHIAW(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 8, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSCX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/04', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSCY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 5, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 8, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSSD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 8/03', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 8, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSCD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 8/04', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 8, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (QP (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/05', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 5, 6) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUWNX(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 9, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (DTDYN(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 9/01', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUWNY(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 9, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (FCUT (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 9/02', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 9, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CFLXYMAX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/03', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 5, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WHITECAP(I0,1),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 9, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CFLTHMAX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/07', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 9/04', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 9, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CFLKMAX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/05', IROOT, IT, IRQGO(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 5, 8) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WHITECAP(I0,2),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + DO I=1, NOEXTR + IF ( FLGRDALL(10, I) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USERO(1,I),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/08', IFROM, IT, IRQGO2(IH), IERR + WRITE (STRING,'(A3,I2.2)') '10/', I + WRITE (NDST,9011) IH, STRING, IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + END DO + ! + NRQGO = IH #endif -! +#ifdef W3_MPIT + WRITE (NDST,9012) + WRITE (NDST,9013) NRQGO, NRQMAX +#endif + ! #ifdef W3_MPI - IF ( FLGRDALL( 5, 9) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WHITECAP(I0,3),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( NRQGO .GT. NRQMAX ) THEN + WRITE (NDSE,1010) NRQGO, NRQMAX + CALL EXTCDE (10) + END IF + ! + IF ( IAPROC .EQ. NAPFLD ) THEN + ! + ! 1.b Setting up expanded arrays + ! + IF (NAPFLD .EQ. NAPRST) THEN + CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDARST ) + ELSE + CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDALL ) + ENDIF + ! + ! 1.c Receives of fields + ! + CALL W3XETA ( IMOD, NDSE, NDST ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/09', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9010) '(RECV)' #endif + ! #ifdef W3_MPI - END IF + IH = 0 + ! + DO I0=1, NAPROC + IT = IT0 + IFROM = I0 - 1 + ! + IF ( FLGRDALL( 1, 12) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 1/09', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 5,10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WHITECAP(I0,4),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/10', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/01', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 2, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/02', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 5,11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TWS(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (T02 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/11', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/03', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 2, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (T0M1 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/04', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (SXX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (T01(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/05', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (SYY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN + ! TP output shares FP0 internal field with FP + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/06', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (SXY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/07', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 2, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (THS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/08', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUOX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (THP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/09', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUOY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HSIG (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/10', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 2, 11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/11', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (BHD(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 12) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/03', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/12', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 2, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/13', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PHIOC (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HCMAXE(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/04', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/14', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 2, 15) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HMAXD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/15', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HCMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/16', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 2, 17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WBT(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 2/17', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 2, 19) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/19', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 6) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 3, 1) ) THEN + DO IK=E3DF(2,1),E3DF(3,1) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (EF(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, 'EF', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 3, 2) ) THEN + DO IK=E3DF(2,2),E3DF(3,2) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, 'TH1M', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END DO + END IF + ! + IF ( FLGRDALL( 3, 3) ) THEN + DO IK=E3DF(2,3),E3DF(3,3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'STH1M', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PRMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 3, 4) ) THEN + DO IK=E3DF(2,4),E3DF(3,4) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, 'TH2M', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TPMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 3, 5) ) THEN + DO IK=E3DF(2,5),E3DF(3,5) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, 'STH2M', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4, 1) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/01', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 8) ) THEN - DO IK=1,2*NK - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (US3D(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 4, 2) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PTP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, 'US3D ', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/02', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4, 3) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PLP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/03', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 9) ) THEN - DO K=P2MSF(2),P2MSF(3) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (P2SMS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 4, 4) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PDIR(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, 'P3SMS', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/04', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4, 5) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PSI(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/05', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6,10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUICE (I0,1),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 4, 6) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PWS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/06', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUICE (I0,2),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 4, 7) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PTHP0(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/07', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4, 8) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PQP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/08', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6,11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PHICE (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 4, 9) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PPE(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/11', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/09', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4,10) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PGW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/10', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 12) ) THEN - DO IK=1,2*NK - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (USSP(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 4,11) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PSW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, 'USSP ', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/11', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END DO - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4,12) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PTM1(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/12', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 6, 13) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 4,13) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PT1(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/13', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 4,14) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PT2(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/14', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END DO + END IF + ! + IF ( FLGRDALL( 4,15) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PEP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif -! -#ifdef W3_MPI -#ifdef W3_CESMCOUPLED - IF ( FLGRDALL( 6, 14) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (LANGMT(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR) #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/14', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/15', IFROM, IT, IRQGO2(IH), IERR #endif - END IF -#endif ! W3_CESMCOUPLED -#endif ! W3_MPI -! #ifdef W3_MPI - IF ( FLGRDALL( 7, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (ABA (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 4,16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PWST (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/16', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (ABD (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 4,17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PNR (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 4/17', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 5, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (UST (I0), 1, WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 7, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USTDIR(I0), 1, WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ASF (I0), 1, WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 5, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/02', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 7, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (BEDFORMS(I0,1),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CGE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/03', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (BEDFORMS(I0,2),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHIAW(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/04', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (BEDFORMS(I0,3),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/04', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 7, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWNX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWNY(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,1),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/07', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,2),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 5/08', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 8, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSCX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,3),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/09', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSCY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,4),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/10', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSSD (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 5,11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TWS(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/03', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 5/11', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSCD (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 6, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (SXX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/04', IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (QP (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (SYY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 9, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (DTDYN(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (SXY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 9, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (FCUT (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 6, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 9, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (CFLXYMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 9, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (CFLTHMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 6, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (BHD(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/04', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 6/03', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLGRDALL( 9, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (CFLKMAX(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 6, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHIOC (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 6/04', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - DO I=1, NOEXTR - !WRITE(740+IAPROC,*) 'SECOND : I=', I, ' / ', NOEXTR, ' val=', FLGRDALL(10, I) - IF ( FLGRDALL(10, I) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (USERO(I0,I),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 6, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (STRING,'(A3,I2.2)') '10/', I - WRITE (NDST,9011) IH, STRING, IFROM, IT, IRQGO2(IH), IERR + WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF - END DO + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif -! -#ifdef W3_MPI - END DO +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - NRQGO2 = IH + END IF + ! + IF ( FLGRDALL( 6, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9012) - WRITE (NDST,9014) NRQGO2, NRQMAX*NAPROC -#endif -! -#ifdef W3_MPI - CALL W3SETA ( IMOD, NDSE, NDST ) + WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif -! -#ifdef W3_MPI - IF ( NRQGO2 .GT. NRQMAX*NAPROC ) THEN - WRITE (NDSE,1011) NRQGO2, NRQMAX*NAPROC - CALL EXTCDE (11) - END IF +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - END IF + END IF + ! + IF ( FLGRDALL( 6, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PRMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif -! -! 2. Set-up for W3IORS ---------------------------------------------- / -! 2.a General preparations -! -#ifdef W3_MPI - NRQRS = 0 - IH = 0 - IROOT = NAPRST - 1 +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOUT(4) .OR. FLOUT(8) ) THEN - IF (OARST) THEN - ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(34*NAPROC) ) - ELSE - ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(3*NAPROC) ) - ENDIF - IRQRS => OUTPTS(IMOD)%OUT4%IRQRS + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TPMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif -! -! 2.b Fields at end of file (always) -! #ifdef W3_MPIT - WRITE (NDST,9020) -#endif -! -#ifdef W3_MPI - IF ( IAPROC.NE.NAPRST .AND. IAPROC.LE.NAPROC ) THEN + WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI + END IF + ! + IF ( FLGRDALL( 6, 8) ) THEN + DO IK=1,2*NK IH = IH + 1 - IT = IT0 + 1 - CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IT = IT + 1 + CALL MPI_RECV_INIT (US3D(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S U*', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, 'US3D ', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI + END DO + END IF + ! + IF ( FLGRDALL( 6, 9) ) THEN + DO K=P2MSF(2),P2MSF(3) IH = IH + 1 - IT = IT0 + 2 - CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IT = IT + 1 + CALL MPI_RECV_INIT (P2SMS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S UD', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, 'P3SMS', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 3 - CALL MPI_SEND_INIT (FPIS(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END DO + END IF + ! + IF ( FLGRDALL( 6,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUICE (I0,1),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR -#endif -! -#ifdef W3_MPI - ELSE IF ( IAPROC .EQ. NAPRST ) THEN - DO I0=1, NAPROC - IFROM = I0 - 1 - IF ( I0 .NE. IAPROC ) THEN + WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 1 - CALL MPI_RECV_INIT (UST (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUICE (I0,2),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R U*', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 2 - CALL MPI_RECV_INIT (USTDIR(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 6,11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHICE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R UD', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 6/11', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 3 - CALL MPI_RECV_INIT (FPIS(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLGRDALL( 6, 12) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USSP(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF - END DO - END IF + WRITE (NDST,9011) IH, 'USSP ', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF (OARST) THEN - IF ( FLOGRR( 1, 2) ) THEN - IH = IH + 1 - IT = IT0 + 4 - CALL MPI_SEND_INIT (CX(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END DO + END IF + ! + IF ( FLGRDALL( 6, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S CX', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 5 - CALL MPI_SEND_INIT (CY(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S CY', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! +#ifdef W3_CESMCOUPLED + IF ( FLGRDALL( 6, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (LANGMT(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR) +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/14', IFROM, IT, IRQGO2(IH), IERR #endif -! -#ifdef W3_MPI - IF ( FLOGRR( 1, 12) ) THEN - IH = IH + 1 - IT = IT0 + 6 - CALL MPI_SEND_INIT (ICEF(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF +#endif ! W3_CESMCOUPLED + IF ( FLGRDALL( 7, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ABA (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S IF', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 1) ) THEN - IH = IH + 1 - IT = IT0 + 7 - CALL MPI_SEND_INIT (HS (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ABD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S HS', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 2) ) THEN - IH = IH + 1 - IT = IT0 + 8 - CALL MPI_SEND_INIT (WLM (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 7, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S WL', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 4) ) THEN - IH = IH + 1 - IT = IT0 + 9 - CALL MPI_SEND_INIT (T0M1(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S T0', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - ENDIF + WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 5) ) THEN - IH = IH + 1 - IT = IT0 + 10 - CALL MPI_SEND_INIT (T01 (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 7, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (BEDFORMS(I0,1),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - ENDIF + WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 6) ) THEN - IH = IH + 1 - IT = IT0 + 11 - CALL MPI_SEND_INIT (FP0 (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (BEDFORMS(I0,2),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 7) ) THEN - IH = IH + 1 - IT = IT0 + 12 - CALL MPI_SEND_INIT (THM (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (BEDFORMS(I0,3),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S TH', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 19) ) THEN - IH = IH + 1 - IT = IT0 + 13 - CALL MPI_SEND_INIT (WNMEAN(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 7, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S WM', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 7/04', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 5, 2) ) THEN - IH = IH + 1 - IT = IT0 + 14 - CALL MPI_SEND_INIT (CHARN(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 7, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S CH', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - ENDIF + WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 5, 5) ) THEN - IH = IH + 1 - IT = IT0 + 15 - CALL MPI_SEND_INIT (TAUWIX(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S WX', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 16 - CALL MPI_SEND_INIT (TAUWIY(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 8, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S WY', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 5, 11) ) THEN - IH = IH + 1 - IT = IT0 + 17 - CALL MPI_SEND_INIT (TWS (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S TS', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 2) ) THEN - IH = IH + 1 - IT = IT0 + 18 - CALL MPI_SEND_INIT (TAUOX(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 8, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSCX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S OX', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 19 - CALL MPI_SEND_INIT (TAUOY(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSCY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S OY', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6, 3) ) THEN - IH = IH + 1 - IT = IT0 + 20 - CALL MPI_SEND_INIT (BHD (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 8, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSSD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S BH', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 8/03', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6, 4) ) THEN - IH = IH + 1 - IT = IT0 + 21 - CALL MPI_SEND_INIT (PHIOC(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 8, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSCD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S PH', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 8/04', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 5) ) THEN - IH = IH + 1 - IT = IT0 + 22 - CALL MPI_SEND_INIT (TUSX (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 8, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (QP (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S UX', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 8/05', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 23 - CALL MPI_SEND_INIT (TUSY (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 9, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (DTDYN(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S UY', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 9/01', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6, 6) ) THEN - IH = IH + 1 - IT = IT0 + 24 - CALL MPI_SEND_INIT (USSX (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 9, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (FCUT (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S SX', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 9/02', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 25 - CALL MPI_SEND_INIT (USSY (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 9, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CFLXYMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S SY', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 9/03', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6,10) ) THEN - IH = IH + 1 - IT = IT0 + 26 - CALL MPI_SEND_INIT (TAUICE(1,1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 9, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CFLTHMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S I1', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9011) IH, ' 9/04', IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 27 - CALL MPI_SEND_INIT (TAUICE(1,2), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + IF ( FLGRDALL( 9, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CFLKMAX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S I2', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9011) IH, ' 9/05', IFROM, IT, IRQGO2(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6,13) ) THEN - IH = IH + 1 - IT = IT0 + 28 - CALL MPI_SEND_INIT (TAUOCX(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + ! + DO I=1, NOEXTR + !WRITE(740+IAPROC,*) 'SECOND : I=', I, ' / ', NOEXTR, ' val=', FLGRDALL(10, I) + IF ( FLGRDALL(10, I) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USERO(I0,I),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S TX', IROOT, IT, IRQRS(IH), IERR + WRITE (STRING,'(A3,I2.2)') '10/', I + WRITE (NDST,9011) IH, STRING, IFROM, IT, IRQGO2(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 29 - CALL MPI_SEND_INIT (TAUOCY(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + END IF + END DO + ! + END DO + ! + NRQGO2 = IH #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S TY', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9012) + WRITE (NDST,9014) NRQGO2, NRQMAX*NAPROC #endif -! + ! #ifdef W3_MPI - IF ( FLOGRR( 7, 2) ) THEN - IH = IH + 1 - IT = IT0 + 30 - CALL MPI_SEND_INIT (UBA (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + CALL W3SETA ( IMOD, NDSE, NDST ) + ! + END IF + ! + IF ( NRQGO2 .GT. NRQMAX*NAPROC ) THEN + WRITE (NDSE,1011) NRQGO2, NRQMAX*NAPROC + CALL EXTCDE (11) + END IF + ! + END IF + ! + ! 2. Set-up for W3IORS ---------------------------------------------- / + ! 2.a General preparations + ! + NRQRS = 0 + IH = 0 + IROOT = NAPRST - 1 + ! + IF ( FLOUT(4) .OR. FLOUT(8) ) THEN + IF (OARST) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(34*NAPROC) ) + ELSE + ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(3*NAPROC) ) + ENDIF + IRQRS => OUTPTS(IMOD)%OUT4%IRQRS #endif + ! + ! 2.b Fields at end of file (always) + ! #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S BA', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9020) #endif + ! #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 31 - CALL MPI_SEND_INIT (UBD (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IF ( IAPROC.NE.NAPRST .AND. IAPROC.LE.NAPROC ) THEN + ! + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S BD', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9021) IH, 'S U*', IROOT, IT, IRQRS(IH), IERR #endif -! + ! #ifdef W3_MPI - IF ( FLOGRR( 7, 4) ) THEN - IH = IH + 1 - IT = IT0 + 32 - CALL MPI_SEND_INIT (PHIBBL(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S PB', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9021) IH, 'S UD', IROOT, IT, IRQRS(IH), IERR #endif -! + ! #ifdef W3_MPI - IF ( FLOGRR( 7, 5) ) THEN - IH = IH + 1 - IT = IT0 + 33 - CALL MPI_SEND_INIT (TAUBBL(1,1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + IH = IH + 1 + IT = IT0 + 3 + CALL MPI_SEND_INIT (FPIS(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR #endif + ! #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 34 - CALL MPI_SEND_INIT (TAUBBL(1,2), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + ELSE IF ( IAPROC .EQ. NAPRST ) THEN + DO I0=1, NAPROC + IFROM = I0 - 1 + IF ( I0 .NE. IAPROC ) THEN + ! + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_RECV_INIT (UST (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S T2', IROOT, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R U*', IFROM, IT, IRQRS(IH), IERR #endif + ! #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_RECV_INIT (USTDIR(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif -! -#ifdef W3_MPI - IF ( IAPROC .EQ. NAPRST ) THEN - IF (NAPRST .NE. NAPFLD) CALL W3XDMA ( IMOD, NDSE, NDST, FLOGRR ) - CALL W3XETA ( IMOD, NDSE, NDST ) +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R UD', IFROM, IT, IRQRS(IH), IERR #endif -! + ! #ifdef W3_MPI - DO I0=1, NAPROC - IFROM = I0 - 1 - IF ( FLOGRR( 1, 2) ) THEN - IH = IH + 1 - IT = IT0 + 4 - CALL MPI_RECV_INIT (CX (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IH = IH + 1 + IT = IT0 + 3 + CALL MPI_RECV_INIT (FPIS(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R CX', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IH = IT0 + 5 - IT = IT + 1 - CALL MPI_RECV_INIT (CY (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + END DO + END IF + ! + IF (OARST) THEN + IF ( FLOGRR( 1, 2) ) THEN + IH = IH + 1 + IT = IT0 + 4 + CALL MPI_SEND_INIT (CX(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R CY', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9021) IH, 'S CX', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 1, 12) ) THEN - IH = IH + 1 - IT = IT0 + 6 - CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IH = IH + 1 + IT = IT0 + 5 + CALL MPI_SEND_INIT (CY(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R IF', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF + WRITE (NDST,9021) IH, 'S CY', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 1) ) THEN - IH = IH + 1 - IT = IT0 + 7 - CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 1, 12) ) THEN + IH = IH + 1 + IT = IT0 + 6 + CALL MPI_SEND_INIT (ICEF(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R HS', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S IF', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 2) ) THEN - IH = IH + 1 - IT = IT0 + 8 - CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 2, 1) ) THEN + IH = IH + 1 + IT = IT0 + 7 + CALL MPI_SEND_INIT (HS (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R WL', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S HS', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLOGRR( 2, 2) ) THEN + IH = IH + 1 + IT = IT0 + 8 + CALL MPI_SEND_INIT (WLM (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S WL', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 4) ) THEN - IH = IH + 1 - IT = IT0 + 9 - CALL MPI_RECV_INIT (T0M1(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 2, 4) ) THEN + IH = IH + 1 + IT = IT0 + 9 + CALL MPI_SEND_INIT (T0M1(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R T0', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S T0', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - ENDIF + ENDIF + ! + IF ( FLOGRR( 2, 5) ) THEN + IH = IH + 1 + IT = IT0 + 10 + CALL MPI_SEND_INIT (T01 (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 5) ) THEN - IH = IH + 1 - IT = IT0 + 10 - CALL MPI_RECV_INIT (T01 (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + ENDIF + ! + IF ( FLOGRR( 2, 6) ) THEN + IH = IH + 1 + IT = IT0 + 11 + CALL MPI_SEND_INIT (FP0 (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - ENDIF + END IF + ! + IF ( FLOGRR( 2, 7) ) THEN + IH = IH + 1 + IT = IT0 + 12 + CALL MPI_SEND_INIT (THM (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S TH', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 6) ) THEN - IH = IH + 1 - IT = IT0 + 11 - CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 2, 19) ) THEN + IH = IH + 1 + IT = IT0 + 13 + CALL MPI_SEND_INIT (WNMEAN(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S WM', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLOGRR( 5, 2) ) THEN + IH = IH + 1 + IT = IT0 + 14 + CALL MPI_SEND_INIT (CHARN(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S CH', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 7) ) THEN - IH = IH + 1 - IT = IT0 + 12 - CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + ENDIF + ! + IF ( FLOGRR( 5, 5) ) THEN + IH = IH + 1 + IT = IT0 + 15 + CALL MPI_SEND_INIT (TAUWIX(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R TH', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S WX', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT0 + 16 + CALL MPI_SEND_INIT (TAUWIY(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S WY', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 2, 19) ) THEN - IH = IH + 1 - IT = IT0 + 13 - CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 5, 11) ) THEN + IH = IH + 1 + IT = IT0 + 17 + CALL MPI_SEND_INIT (TWS (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R WM', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S TS', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLOGRR( 6, 2) ) THEN + IH = IH + 1 + IT = IT0 + 18 + CALL MPI_SEND_INIT (TAUOX(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S OX', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 5, 2) ) THEN - IH = IH + 1 - IT = IT0 + 14 - CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IH = IH + 1 + IT = IT0 + 19 + CALL MPI_SEND_INIT (TAUOY(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R CH', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S OY', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - ENDIF + END IF + ! + IF ( FLOGRR( 6, 3) ) THEN + IH = IH + 1 + IT = IT0 + 20 + CALL MPI_SEND_INIT (BHD (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S BH', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 5, 5) ) THEN - IH = IH + 1 - IT = IT0 + 15 - CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 6, 4) ) THEN + IH = IH + 1 + IT = IT0 + 21 + CALL MPI_SEND_INIT (PHIOC(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R WX', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S PH', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 16 - CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 6, 5) ) THEN + IH = IH + 1 + IT = IT0 + 22 + CALL MPI_SEND_INIT (TUSX (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R WY', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S UX', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT0 + 23 + CALL MPI_SEND_INIT (TUSY (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S UY', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 5,11) ) THEN - IH = IH + 1 - IT = IT0 + 17 - CALL MPI_RECV_INIT (TWS (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 6, 6) ) THEN + IH = IH + 1 + IT = IT0 + 24 + CALL MPI_SEND_INIT (USSX (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R TS', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S SX', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT0 + 25 + CALL MPI_SEND_INIT (USSY (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S SY', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6, 2) ) THEN - IH = IH + 1 - IT = IT0 + 18 - CALL MPI_RECV_INIT (TAUOX(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 6,10) ) THEN + IH = IH + 1 + IT = IT0 + 26 + CALL MPI_SEND_INIT (TAUICE(1,1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R OX', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S I1', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 19 - CALL MPI_RECV_INIT (TAUOY(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IH = IH + 1 + IT = IT0 + 27 + CALL MPI_SEND_INIT (TAUICE(1,2), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R OY', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S I2', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLOGRR( 6,13) ) THEN + IH = IH + 1 + IT = IT0 + 28 + CALL MPI_SEND_INIT (TAUOCX(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S TX', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6, 3) ) THEN - IH = IH + 1 - IT = IT0 + 20 - CALL MPI_RECV_INIT (BHD (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IH = IH + 1 + IT = IT0 + 29 + CALL MPI_SEND_INIT (TAUOCY(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R BH', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S TY', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLOGRR( 7, 2) ) THEN + IH = IH + 1 + IT = IT0 + 30 + CALL MPI_SEND_INIT (UBA (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S BA', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6, 4) ) THEN - IH = IH + 1 - IT = IT0 + 21 - CALL MPI_RECV_INIT (PHIOC(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IH = IH + 1 + IT = IT0 + 31 + CALL MPI_SEND_INIT (UBD (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R PH', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S BD', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLOGRR( 7, 4) ) THEN + IH = IH + 1 + IT = IT0 + 32 + CALL MPI_SEND_INIT (PHIBBL(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S PB', IROOT, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6, 5) ) THEN - IH = IH + 1 - IT = IT0 + 22 - CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 7, 5) ) THEN + IH = IH + 1 + IT = IT0 + 33 + CALL MPI_SEND_INIT (TAUBBL(1,1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R UX', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 23 - CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IH = IH + 1 + IT = IT0 + 34 + CALL MPI_SEND_INIT (TAUBBL(1,2), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R UY', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'S T2', IROOT, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( IAPROC .EQ. NAPRST ) THEN + IF (NAPRST .NE. NAPFLD) CALL W3XDMA ( IMOD, NDSE, NDST, FLOGRR ) + CALL W3XETA ( IMOD, NDSE, NDST ) + ! + DO I0=1, NAPROC + IFROM = I0 - 1 + IF ( FLOGRR( 1, 2) ) THEN + IH = IH + 1 + IT = IT0 + 4 + CALL MPI_RECV_INIT (CX (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R CX', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6, 6) ) THEN - IH = IH + 1 - IT = IT0 + 24 - CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IH = IT0 + 5 + IT = IT + 1 + CALL MPI_RECV_INIT (CY (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R CY', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 25 - CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 1, 12) ) THEN + IH = IH + 1 + IT = IT0 + 6 + CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R IF', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLOGRR( 2, 1) ) THEN + IH = IH + 1 + IT = IT0 + 7 + CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R HS', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6,10) ) THEN - IH = IH + 1 - IT = IT0 + 26 - CALL MPI_RECV_INIT (TAUICE(I0,1),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 2, 2) ) THEN + IH = IH + 1 + IT = IT0 + 8 + CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R I1', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R WL', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 27 - CALL MPI_RECV_INIT (TAUICE(I0,2),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 2, 4) ) THEN + IH = IH + 1 + IT = IT0 + 9 + CALL MPI_RECV_INIT (T0M1(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R I2', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R T0', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + ENDIF + ! + IF ( FLOGRR( 2, 5) ) THEN + IH = IH + 1 + IT = IT0 + 10 + CALL MPI_RECV_INIT (T01 (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 6,13) ) THEN - IH = IH + 1 - IT = IT0 + 28 - CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + ENDIF + ! + IF ( FLOGRR( 2, 6) ) THEN + IH = IH + 1 + IT = IT0 + 11 + CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 29 - CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 2, 7) ) THEN + IH = IH + 1 + IT = IT0 + 12 + CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R TH', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLOGRR( 2, 19) ) THEN + IH = IH + 1 + IT = IT0 + 13 + CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R WM', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 7, 2) ) THEN - IH = IH + 1 - IT = IT0 + 30 - CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 5, 2) ) THEN + IH = IH + 1 + IT = IT0 + 14 + CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R BA', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R CH', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 31 - CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + ENDIF + ! + IF ( FLOGRR( 5, 5) ) THEN + IH = IH + 1 + IT = IT0 + 15 + CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R BD', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R WX', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + IH = IH + 1 + IT = IT0 + 16 + CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R WY', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 7, 4) ) THEN - IH = IH + 1 - IT = IT0 + 32 - CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 5,11) ) THEN + IH = IH + 1 + IT = IT0 + 17 + CALL MPI_RECV_INIT (TWS (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R PB', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R TS', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF + END IF + ! + IF ( FLOGRR( 6, 2) ) THEN + IH = IH + 1 + IT = IT0 + 18 + CALL MPI_RECV_INIT (TAUOX(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R OX', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IF ( FLOGRR( 7, 5) ) THEN - IH = IH + 1 - IT = IT0 + 33 - CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + IH = IH + 1 + IT = IT0 + 19 + CALL MPI_RECV_INIT (TAUOY(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R OY', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 34 - CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 6, 3) ) THEN + IH = IH + 1 + IT = IT0 + 20 + CALL MPI_RECV_INIT (BHD (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R T2', IFROM, IT, IRQRS(IH), IERR + WRITE (NDST,9021) IH, 'R BH', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF - END DO + END IF + ! + IF ( FLOGRR( 6, 4) ) THEN + IH = IH + 1 + IT = IT0 + 21 + CALL MPI_RECV_INIT (PHIOC(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R PH', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - CALL W3SETA ( IMOD, NDSE, NDST ) END IF - END IF + ! + IF ( FLOGRR( 6, 5) ) THEN + IH = IH + 1 + IT = IT0 + 22 + CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R UX', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - NRQRS = IH - IF (OARST) THEN - IT0 = IT0 + 34 - ELSE - IT0 = IT0 + 3 - ENDIF + IH = IH + 1 + IT = IT0 + 23 + CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif -! #ifdef W3_MPIT - WRITE (NDST,9022) - WRITE (NDST,9023) NRQRS + WRITE (NDST,9021) IH, 'R UY', IFROM, IT, IRQRS(IH), IERR #endif -! -! 2.c Data server mode -! #ifdef W3_MPI - IF ( IOSTYP .GT. 0 ) THEN + END IF + ! + IF ( FLOGRR( 6, 6) ) THEN + IH = IH + 1 + IT = IT0 + 24 + CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - NBLKRS = 10 - RSBLKS = MAX ( 5 , NSEALM/NBLKRS ) - IF ( NBLKRS*RSBLKS .LT. NSEALM ) RSBLKS = RSBLKS + 1 - NBLKRS = 1 + (NSEALM-1)/RSBLKS + IH = IH + 1 + IT = IT0 + 25 + CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif -! #ifdef W3_MPIT - WRITE (NDST,9025) RSBLKS, NBLKRS + WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IH = 0 + END IF + ! + IF ( FLOGRR( 6,10) ) THEN + IH = IH + 1 + IT = IT0 + 26 + CALL MPI_RECV_INIT (TAUICE(I0,1),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif -! -#ifdef W3_MPI - IF ((.NOT. LPDLIB).OR.(GTYPE .NE. UNGTYPE)) THEN - IF ( IAPROC .NE. NAPRST ) THEN +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R I1', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRSS(NBLKRS) ) - IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS + IH = IH + 1 + IT = IT0 + 27 + CALL MPI_RECV_INIT (TAUICE(I0,2),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R I2', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - DO IB=1, NBLKRS - IH = IH + 1 - IT = IT0 + 3 + IB - JSEA0 = 1 + (IB-1)*RSBLKS - JSEAN = MIN ( NSEALM , IB*RSBLKS ) - NSEAB = 1 + JSEAN - JSEA0 - CALL MPI_SEND_INIT (VA(1,JSEA0), NSPEC*NSEAB,& - MPI_REAL, IROOT, IT, MPI_COMM_WAVE, & - IRQRSS(IH), IERR ) + END IF + ! + IF ( FLOGRR( 6,13) ) THEN + IH = IH + 1 + IT = IT0 + 28 + CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9026) IH, 'S', IB, IROOT, IT, & - IRQRSS(IH), IERR, NSEAB + WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END DO + IH = IH + 1 + IT = IT0 + 29 + CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif -! -#ifdef W3_MPI - ELSE +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - ALLOCATE & - ( OUTPTS(IMOD)%OUT4%IRQRSS(NAPROC*NBLKRS) , & - OUTPTS(IMOD)%OUT4%VAAUX(NSPEC,2*RSBLKS,NAPROC) ) + END IF + ! + IF ( FLOGRR( 7, 2) ) THEN + IH = IH + 1 + IT = IT0 + 30 + CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R BA', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS - VAAUX => OUTPTS(IMOD)%OUT4%VAAUX - DO IB=1, NBLKRS - IT = IT0 + 3 + IB - JSEA0 = 1 + (IB-1)*RSBLKS - JSEAN = MIN ( NSEALM , IB*RSBLKS ) - NSEAB = 1 + JSEAN - JSEA0 - DO I0=1, NAPROC - IF ( I0 .NE. NAPRST ) THEN - IH = IH + 1 - IFROM = I0 - 1 - IBOFF = MOD(IB-1,2)*RSBLKS - CALL MPI_RECV_INIT (VAAUX(1,1+IBOFF,I0),& - NSPEC*NSEAB, MPI_REAL, IFROM, IT, & - MPI_COMM_WAVE, IRQRSS(IH), IERR ) + IH = IH + 1 + IT = IT0 + 31 + CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9026) IH, 'R', IB, IFROM, & - IT, IRQRSS(IH), IERR, NSEAB + WRITE (NDST,9021) IH, 'R BD', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - END IF - END DO - END DO + END IF + ! + IF ( FLOGRR( 7, 4) ) THEN + IH = IH + 1 + IT = IT0 + 32 + CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R PB', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI - END IF - END IF + END IF + ! + IF ( FLOGRR( 7, 5) ) THEN + IH = IH + 1 + IT = IT0 + 33 + CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif -! #ifdef W3_MPIT - WRITE (NDST,9027) - WRITE (NDST,9028) IH + WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR #endif #ifdef W3_MPI - IT0 = IT0 + NBLKRS + IH = IH + 1 + IT = IT0 + 34 + CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) #endif -! -#ifdef W3_MPI - END IF +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R T2', IFROM, IT, IRQRS(IH), IERR #endif -! #ifdef W3_MPI + END IF + END DO + ! + CALL W3SETA ( IMOD, NDSE, NDST ) END IF + END IF + ! + NRQRS = IH + IF (OARST) THEN + IT0 = IT0 + 34 + ELSE + IT0 = IT0 + 3 + ENDIF #endif -! -! 3. Set-up for W3IOBC ( SENDs ) ------------------------------------ / -! -#ifdef W3_MPI - NRQBP = 0 - NRQBP2 = 0 - IH = 0 - IT = IT0 - IROOT = NAPBPT - 1 + ! +#ifdef W3_MPIT + WRITE (NDST,9022) + WRITE (NDST,9023) NRQRS #endif -! + ! + ! 2.c Data server mode + ! #ifdef W3_MPI - IF ( FLOUT(5) ) THEN - ALLOCATE ( OUTPTS(IMOD)%OUT5%IRQBP1(NBO2(NFBPO)), & - OUTPTS(IMOD)%OUT5%IRQBP2(NBO2(NFBPO)) ) - IRQBP1 => OUTPTS(IMOD)%OUT5%IRQBP1 - IRQBP2 => OUTPTS(IMOD)%OUT5%IRQBP2 + IF ( IOSTYP .GT. 0 ) THEN + ! + NBLKRS = 10 + RSBLKS = MAX ( 5 , NSEALM/NBLKRS ) + IF ( NBLKRS*RSBLKS .LT. NSEALM ) RSBLKS = RSBLKS + 1 + NBLKRS = 1 + (NSEALM-1)/RSBLKS #endif -! -! 3.a Loops over files and points -! + ! #ifdef W3_MPIT - WRITE (NDST,9030) 'MPI_SEND_INIT' -#endif -! -#ifdef W3_MPI - DO J=1, NFBPO - DO I=NBO2(J-1)+1, NBO2(J) + WRITE (NDST,9025) RSBLKS, NBLKRS #endif -! #ifdef W3_MPI - IT = IT + 1 + IH = 0 + ! + IF ((.NOT. LPDLIB).OR.(GTYPE .NE. UNGTYPE)) THEN + IF ( IAPROC .NE. NAPRST ) THEN + ! + ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRSS(NBLKRS) ) + IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS + ! + DO IB=1, NBLKRS + IH = IH + 1 + IT = IT0 + 3 + IB + JSEA0 = 1 + (IB-1)*RSBLKS + JSEAN = MIN ( NSEALM , IB*RSBLKS ) + NSEAB = 1 + JSEAN - JSEA0 + CALL MPI_SEND_INIT (VA(1,JSEA0), NSPEC*NSEAB,& + MPI_REAL, IROOT, IT, MPI_COMM_WAVE, & + IRQRSS(IH), IERR ) #endif -! -! 3.b Residence processor of point -! -#ifdef W3_MPI - ISEA = ISBPO(I) - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) +#ifdef W3_MPIT + WRITE (NDST,9026) IH, 'S', IB, IROOT, IT, & + IRQRSS(IH), IERR, NSEAB #endif -! -! 3.c If stored locally, send data -! #ifdef W3_MPI - IF ( IAPROC .EQ. ISPROC ) THEN + END DO + ! + ELSE + ! + ALLOCATE & + ( OUTPTS(IMOD)%OUT4%IRQRSS(NAPROC*NBLKRS) , & + OUTPTS(IMOD)%OUT4%VAAUX(NSPEC,2*RSBLKS,NAPROC) ) + ! + IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS + VAAUX => OUTPTS(IMOD)%OUT4%VAAUX + DO IB=1, NBLKRS + IT = IT0 + 3 + IB + JSEA0 = 1 + (IB-1)*RSBLKS + JSEAN = MIN ( NSEALM , IB*RSBLKS ) + NSEAB = 1 + JSEAN - JSEA0 + DO I0=1, NAPROC + IF ( I0 .NE. NAPRST ) THEN IH = IH + 1 - CALL MPI_SEND_INIT (VA(1,JSEA),NSPEC,MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQBP1(IH), IERR) + IFROM = I0 - 1 + IBOFF = MOD(IB-1,2)*RSBLKS + CALL MPI_RECV_INIT (VAAUX(1,1+IBOFF,I0),& + NSPEC*NSEAB, MPI_REAL, IFROM, IT, & + MPI_COMM_WAVE, IRQRSS(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9031) IH, I, J, IROOT, IT, IRQBP1(IH), IERR + WRITE (NDST,9026) IH, 'R', IB, IFROM, & + IT, IRQRSS(IH), IERR, NSEAB #endif #ifdef W3_MPI END IF -#endif -! -#ifdef W3_MPI END DO END DO + ! + END IF + END IF #endif -! -! ... End of loops 4.a -! -#ifdef W3_MPI - NRQBP = IH -#endif -! + ! #ifdef W3_MPIT - WRITE (NDST,9032) - WRITE (NDST,9033) NRQBP + WRITE (NDST,9027) + WRITE (NDST,9028) IH #endif -! -! 3.d Set-up for W3IOBC ( RECVs ) ------------------------------------ / -! #ifdef W3_MPI - IF ( IAPROC .EQ. NAPBPT ) THEN + IT0 = IT0 + NBLKRS + ! + END IF + ! + END IF #endif -! -#ifdef W3_MPI - IH = 0 - IT = IT0 + ! + ! 3. Set-up for W3IOBC ( SENDs ) ------------------------------------ / + ! +#ifdef W3_MPI + NRQBP = 0 + NRQBP2 = 0 + IH = 0 + IT = IT0 + IROOT = NAPBPT - 1 + ! + IF ( FLOUT(5) ) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT5%IRQBP1(NBO2(NFBPO)), & + OUTPTS(IMOD)%OUT5%IRQBP2(NBO2(NFBPO)) ) + IRQBP1 => OUTPTS(IMOD)%OUT5%IRQBP1 + IRQBP2 => OUTPTS(IMOD)%OUT5%IRQBP2 +#endif + ! + ! 3.a Loops over files and points + ! +#ifdef W3_MPIT + WRITE (NDST,9030) 'MPI_SEND_INIT' +#endif + ! +#ifdef W3_MPI + DO J=1, NFBPO + DO I=NBO2(J-1)+1, NBO2(J) + ! + IT = IT + 1 + ! + ! 3.b Residence processor of point + ! + ISEA = ISBPO(I) + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + ! + ! 3.c If stored locally, send data + ! + IF ( IAPROC .EQ. ISPROC ) THEN + IH = IH + 1 + CALL MPI_SEND_INIT (VA(1,JSEA),NSPEC,MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQBP1(IH), IERR) #endif -! -! 3.e Loops over files and points -! #ifdef W3_MPIT - WRITE (NDST,9030) 'MPI_RECV_INIT' -#endif -! -#ifdef W3_MPI - DO J=1, NFBPO - DO I=NBO2(J-1)+1, NBO2(J) + WRITE (NDST,9031) IH, I, J, IROOT, IT, IRQBP1(IH), IERR #endif -! -! 3.f Residence processor of point -! #ifdef W3_MPI - ISEA = ISBPO(I) - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + END IF + ! + END DO + END DO #endif -! -! 3.g Receive in correct array -! + ! + ! ... End of loops 4.a + ! #ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - ITARG = ISPROC - 1 - CALL MPI_RECV_INIT (ABPOS(1,IH),NSPEC,MPI_REAL,& - ITARG, IT, MPI_COMM_WAVE, IRQBP2(IH), IERR) + NRQBP = IH #endif + ! #ifdef W3_MPIT - WRITE (NDST,9031) IH, I, J, ITARG, IT, IRQBP2(IH), IERR -#endif -! -#ifdef W3_MPI - END DO - END DO + WRITE (NDST,9032) + WRITE (NDST,9033) NRQBP #endif -! + ! + ! 3.d Set-up for W3IOBC ( RECVs ) ------------------------------------ / + ! #ifdef W3_MPI - NRQBP2 = IH + IF ( IAPROC .EQ. NAPBPT ) THEN + ! + IH = 0 + IT = IT0 #endif -! -! ... End of loops 4.e -! + ! + ! 3.e Loops over files and points + ! #ifdef W3_MPIT - WRITE (NDST,9032) - WRITE (NDST,9033) NRQBP2 + WRITE (NDST,9030) 'MPI_RECV_INIT' #endif -! + ! #ifdef W3_MPI - END IF + DO J=1, NFBPO + DO I=NBO2(J-1)+1, NBO2(J) + ! + ! 3.f Residence processor of point + ! + ISEA = ISBPO(I) + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + ! + ! 3.g Receive in correct array + ! + IH = IH + 1 + IT = IT + 1 + ITARG = ISPROC - 1 + CALL MPI_RECV_INIT (ABPOS(1,IH),NSPEC,MPI_REAL,& + ITARG, IT, MPI_COMM_WAVE, IRQBP2(IH), IERR) #endif -! -#ifdef W3_MPI - IT0 = IT0 + NBO2(NFBPO) +#ifdef W3_MPIT + WRITE (NDST,9031) IH, I, J, ITARG, IT, IRQBP2(IH), IERR #endif -! + ! #ifdef W3_MPI - END IF + END DO + END DO + ! + NRQBP2 = IH #endif -! + ! + ! ... End of loops 4.e + ! #ifdef W3_MPIT - WRITE (NDST,*) -#endif -! -! 4. Set-up for W3IOTR ---------------------------------------------- / -! -#ifdef W3_MPI - IH = 0 - IROOT = NAPTRK - 1 + WRITE (NDST,9032) + WRITE (NDST,9033) NRQBP2 #endif -! + ! #ifdef W3_MPI - IF ( FLOUT(3) ) THEN + END IF + ! + IT0 = IT0 + NBO2(NFBPO) + ! + END IF #endif -! -! 4.a U* -! + ! #ifdef W3_MPIT - WRITE (NDST,9040) + WRITE (NDST,*) #endif -! + ! + ! 4. Set-up for W3IOTR ---------------------------------------------- / + ! #ifdef W3_MPI - IF ( IAPROC .NE. NAPTRK ) THEN - ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2) ) - IRQTR => OUTPTS(IMOD)%OUT3%IRQTR - IH = IH + 1 - IT = IT0 + 1 - CALL MPI_SEND_INIT (UST (IAPROC),1,WW3_FIELD_VEC,& - IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) + IH = 0 + IROOT = NAPTRK - 1 + ! + IF ( FLOUT(3) ) THEN #endif + ! + ! 4.a U* + ! #ifdef W3_MPIT - WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR + WRITE (NDST,9040) #endif + ! #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 2 - CALL MPI_SEND_INIT (USTDIR(IAPROC),1,WW3_FIELD_VEC,& - IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) + IF ( IAPROC .NE. NAPTRK ) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2) ) + IRQTR => OUTPTS(IMOD)%OUT3%IRQTR + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_SEND_INIT (UST (IAPROC),1,WW3_FIELD_VEC,& + IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR + WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR #endif #ifdef W3_MPI - ELSE - ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2*NAPROC) ) - IRQTR => OUTPTS(IMOD)%OUT3%IRQTR - DO I0=1, NAPROC - IFROM = I0 - 1 - IF ( I0 .NE. IAPROC ) THEN - IH = IH + 1 - IT = IT0 + 1 - CALL MPI_RECV_INIT(UST (I0),1,WW3_FIELD_VEC,& - IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_SEND_INIT (USTDIR(IAPROC),1,WW3_FIELD_VEC,& + IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR + WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR #endif #ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 2 - CALL MPI_RECV_INIT(USTDIR(I0),1,WW3_FIELD_VEC,& - IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) + ELSE + ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2*NAPROC) ) + IRQTR => OUTPTS(IMOD)%OUT3%IRQTR + DO I0=1, NAPROC + IFROM = I0 - 1 + IF ( I0 .NE. IAPROC ) THEN + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_RECV_INIT(UST (I0),1,WW3_FIELD_VEC,& + IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) #endif #ifdef W3_MPIT - WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR -#endif -#ifdef W3_MPI - END IF - END DO - END IF + WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR #endif -! #ifdef W3_MPI - NRQTR = IH - IT0 = IT0 + 2 + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_RECV_INIT(USTDIR(I0),1,WW3_FIELD_VEC,& + IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) #endif -! #ifdef W3_MPIT - WRITE (NDST,9042) - WRITE (NDST,9043) NRQTR + WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR #endif -! #ifdef W3_MPI - END IF + END IF + END DO + END IF + ! + NRQTR = IH + IT0 = IT0 + 2 #endif -! -! 5. Set-up remaining counters -------------------------------------- / -! -#ifdef W3_MPI - IT0PRT = IT0 - IT0PNT = IT0PRT + 2*NAPROC - IT0TRK = IT0PNT + 5000 + ! +#ifdef W3_MPIT + WRITE (NDST,9042) + WRITE (NDST,9043) NRQTR #endif -! - RETURN -! -! Formats : -! + ! #ifdef W3_MPI - 1010 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO TOO SMALL *** '/) - 1011 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO2 TOO SMALL *** '/) -#endif -! -#ifdef W3_MPIT - 9010 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOGO ',A/ & - ' +------+-------+------+------+--------------+'/ & - ' | IH | ID | TARG | TAG | handle err |'/ & - ' +------+-------+------+------+--------------+') - 9011 FORMAT ( ' |',I5,' | ',A5,' |',2(I5,' |'),I9,I4,' |') - 9012 FORMAT ( ' +------+-------+------+------+--------------+') - 9013 FORMAT ( ' TEST W3MPIO: NRQGO :',2I10) - 9014 FORMAT ( ' TEST W3MPIO: NRQGO2:',2I10) + END IF #endif -! -#ifdef W3_MPIT - 9020 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (F)'/ & + ! + ! 5. Set-up remaining counters -------------------------------------- / + ! +#ifdef W3_MPI + IT0PRT = IT0 + IT0PNT = IT0PRT + 2*NAPROC + IT0TRK = IT0PNT + 5000 +#endif + ! + RETURN + ! + ! Formats : + ! +#ifdef W3_MPI +1010 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO TOO SMALL *** '/) +1011 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO2 TOO SMALL *** '/) +#endif + ! +#ifdef W3_MPIT +9010 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOGO ',A/ & + ' +------+-------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+-------+------+------+--------------+') +9011 FORMAT ( ' |',I5,' | ',A5,' |',2(I5,' |'),I9,I4,' |') +9012 FORMAT ( ' +------+-------+------+------+--------------+') +9013 FORMAT ( ' TEST W3MPIO: NRQGO :',2I10) +9014 FORMAT ( ' TEST W3MPIO: NRQGO2:',2I10) +9020 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (F)'/ & ' +------+------+------+------+--------------+'/ & ' | IH | ID | TARG | TAG | handle err |'/ & ' +------+------+------+------+--------------+') - 9021 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') - 9022 FORMAT ( ' +------+------+------+------+--------------+') - 9023 FORMAT ( ' TEST W3MPIO: NRQRS :',I10) -#endif -! -#ifdef W3_MPIT - 9025 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (S)'/ & - ' BLOCK SIZE / BLOCKS : ',2I6/ & - ' +------+------+------+------+--------------+---------+'/ & - ' | IH | ID | TARG | TAG | handle err | spectra |'/ & - ' +------+------+------+------+--------------+---------+') - 9026 FORMAT ( & - ' |',I5,' | ',A1,I3,' |',2(I5,' |'),I9,I4,' |',I8,' |') - 9027 FORMAT ( & - ' +------+------+------+------+--------------+---------+') - 9028 FORMAT ( ' TEST W3MPIO: IHMAX :',I10) -#endif -! -#ifdef W3_MPIT - 9030 FORMAT (/' TEST W3MPIO: ',A,' CALLS FOR W3IOBC'/ & +9021 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') +9022 FORMAT ( ' +------+------+------+------+--------------+') +9023 FORMAT ( ' TEST W3MPIO: NRQRS :',I10) +9025 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (S)'/ & + ' BLOCK SIZE / BLOCKS : ',2I6/ & + ' +------+------+------+------+--------------+---------+'/ & + ' | IH | ID | TARG | TAG | handle err | spectra |'/ & + ' +------+------+------+------+--------------+---------+') +9026 FORMAT ( & + ' |',I5,' | ',A1,I3,' |',2(I5,' |'),I9,I4,' |',I8,' |') +9027 FORMAT ( & + ' +------+------+------+------+--------------+---------+') +9028 FORMAT ( ' TEST W3MPIO: IHMAX :',I10) +9030 FORMAT (/' TEST W3MPIO: ',A,' CALLS FOR W3IOBC'/ & ' +------+------+---+------+------+--------------+'/ & ' | IH | IPT | F | TARG | TAG | handle err |'/ & ' +------+------+---+------+------+--------------+') - 9031 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') - 9032 FORMAT ( & +9031 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') +9032 FORMAT ( & ' +------+------+---+------+------+--------------+') - 9033 FORMAT ( ' TEST W3MPIO: NRQBC :',I10) - 9034 FORMAT ( ' TEST W3MPIO: TOTAL :',I10) -#endif -! -#ifdef W3_MPIT - 9040 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOTR'/ & +9033 FORMAT ( ' TEST W3MPIO: NRQBC :',I10) +9034 FORMAT ( ' TEST W3MPIO: TOTAL :',I10) +9040 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOTR'/ & ' +------+------+------+------+--------------+'/ & ' | IH | ID | TARG | TAG | handle err |'/ & ' +------+------+------+------+--------------+') - 9041 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') - 9042 FORMAT ( & +9041 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') +9042 FORMAT ( & ' +------+------+------+------+--------------+') - 9043 FORMAT ( ' TEST W3MPIO: NRQTR :',I10) -#endif -!/ -!/ End of W3MPIO ----------------------------------------------------- / -!/ - END SUBROUTINE W3MPIO -!/ ------------------------------------------------------------------- / -!> -!> @brief Prepare MPI persistent communication needed for WAVEWATCH I/O -!> routines. -!> -!> @details Create handles as needed. -!> -!> @param[in] IMOD Model number. -!> -!> @author H. L. Tolman @date 30-Oct-2009 -!> - SUBROUTINE W3MPIP ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ 02-Aug-2006 : Origination. ( version 3.10 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! Prepare MPI persistent communication needed for WAVEWATCH I/O -! routines. -! -! 2. Method : -! -! Create handles as needed. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_SEND_INIT, MPI_RECV_INIT -! Subr. mpif.h MPI persistent communication calls. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI MPI communication calls. -! -! !/S Enable subroutine tracing. -! !/MPIT Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +9043 FORMAT ( ' TEST W3MPIO: NRQTR :',I10) +#endif + !/ + !/ End of W3MPIO ----------------------------------------------------- / + !/ + END SUBROUTINE W3MPIO + !/ ------------------------------------------------------------------- / + !> + !> @brief Prepare MPI persistent communication needed for WAVEWATCH I/O + !> routines. + !> + !> @details Create handles as needed. + !> + !> @param[in] IMOD Model number. + !> + !> @author H. L. Tolman @date 30-Oct-2009 + !> + SUBROUTINE W3MPIP ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ + !/ 02-Aug-2006 : Origination. ( version 3.10 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ + ! 1. Purpose : + ! + ! Prepare MPI persistent communication needed for WAVEWATCH I/O + ! routines. + ! + ! 2. Method : + ! + ! Create handles as needed. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_SEND_INIT, MPI_RECV_INIT + ! Subr. mpif.h MPI persistent communication calls. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Wave model initialization routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI MPI communication calls. + ! + ! !/S Enable subroutine tracing. + ! !/MPIT Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -#ifdef W3_MPI - USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_MPI + USE W3SERVMD, ONLY: EXTCDE + !/ + USE W3GDATMD, ONLY: NX, NY, NSPEC, MAPFS + USE W3WDATMD, ONLY: VA + USE W3ADATMD, ONLY: MPI_COMM_WAVE, SPPNT + USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPROC, NAPPNT, FLOUT + USE W3ODATMD, ONLY: OUTPTS, NRQPO, NRQPO2, IRQPO1, IRQPO2, & + NOPTS, IPTINT, IT0PNT, IT0TRK, O2IRQI + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC +#endif + !/ + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ +#ifdef W3_MPI + INTEGER :: IH, IROOT, I, J, IT, IT0, JSEA, & + IERR, ITARG, IX(4), IY(4), & + K, IS(4), IP(4) +#endif + INTEGER :: itout +#ifdef W3_S + INTEGER, SAVE :: IENT #endif -!/ -#ifdef W3_MPI - USE W3GDATMD, ONLY: NX, NY, NSPEC, MAPFS - USE W3WDATMD, ONLY: VA - USE W3ADATMD, ONLY: MPI_COMM_WAVE, SPPNT - USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPROC, NAPPNT, FLOUT - USE W3ODATMD, ONLY: OUTPTS, NRQPO, NRQPO2, IRQPO1, IRQPO2, & - NOPTS, IPTINT, IT0PNT, IT0TRK, O2IRQI - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'W3MPIP') #endif -!/ -! + ! #ifdef W3_MPI - INCLUDE "mpif.h" + IF ( O2IRQI ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + ! 1. Set-up for W3IOPE/O ( SENDs ) ---------------------------------- / + ! + NRQPO = 0 + NRQPO2 = 0 + IH = 0 + IT0 = IT0PNT + IROOT = NAPPNT - 1 + ! + ALLOCATE ( OUTPTS(IMOD)%OUT2%IRQPO1(4*NOPTS), & + OUTPTS(IMOD)%OUT2%IRQPO2(4*NOPTS) ) + IRQPO1 => OUTPTS(IMOD)%OUT2%IRQPO1 + IRQPO2 => OUTPTS(IMOD)%OUT2%IRQPO2 + O2IRQI = .TRUE. +#endif + ! + ! 1.a Loop over output locations + ! +#ifdef W3_MPIT + WRITE (NDST,9010) 'MPI_SEND_INIT' +#endif + ! +#ifdef W3_MPI + DO I=1, NOPTS + DO K=1,4 + IX(K)=IPTINT(1,K,I) + IY(K)=IPTINT(2,K,I) + END DO + ! 1.b Loop over corner points + ! + DO J=1, 4 + ! + IT = IT0 + (I-1)*4 + J + IS(J) = MAPFS (IY(J),IX(J)) + IF ( IS(J) .EQ. 0 ) THEN + JSEA = 0 + IP(J) = NAPPNT + ELSE + CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) + END IF #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + ! + ! 1.c Send if point is stored here + ! #ifdef W3_MPI - INTEGER :: IH, IROOT, I, J, IT, IT0, JSEA, & - IERR, ITARG, IX(4), IY(4), & - K, IS(4), IP(4) -#endif - INTEGER :: itout -#ifdef W3_S - INTEGER, SAVE :: IENT + IF ( IP(J) .EQ. IAPROC ) THEN + IH = IH + 1 + CALL MPI_SEND_INIT ( VA(1,JSEA), NSPEC, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQPO1(IH), IERR ) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3MPIP') +#ifdef W3_MPIT + WRITE (NDST,9011) IH,I,J, IROOT,IT, IRQPO1(IH), IERR #endif -! #ifdef W3_MPI - IF ( O2IRQI ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) END IF + ! + ! ... End of loop 1.b + ! + END DO + ! + ! ... End of loop 1.a + ! + END DO + ! + NRQPO = IH #endif -! -! 1. Set-up for W3IOPE/O ( SENDs ) ---------------------------------- / -! -#ifdef W3_MPI - NRQPO = 0 - NRQPO2 = 0 - IH = 0 - IT0 = IT0PNT - IROOT = NAPPNT - 1 + ! +#ifdef W3_MPIT + WRITE (NDST,9012) + WRITE (NDST,9013) NRQPO #endif -! + ! + ! 1.d Set-up for W3IOPE/O ( RECVs ) ---------------------------------- / + ! #ifdef W3_MPI - ALLOCATE ( OUTPTS(IMOD)%OUT2%IRQPO1(4*NOPTS), & - OUTPTS(IMOD)%OUT2%IRQPO2(4*NOPTS) ) - IRQPO1 => OUTPTS(IMOD)%OUT2%IRQPO1 - IRQPO2 => OUTPTS(IMOD)%OUT2%IRQPO2 - O2IRQI = .TRUE. + IF ( IAPROC .EQ. NAPPNT ) THEN + ! + IH = 0 #endif -! -! 1.a Loop over output locations -! + ! + ! 2.e Loop over output locations + ! #ifdef W3_MPIT - WRITE (NDST,9010) 'MPI_SEND_INIT' + WRITE (NDST,9010) 'MPI_RECV_INIT' #endif -! + ! #ifdef W3_MPI DO I=1, NOPTS DO K=1,4 IX(K)=IPTINT(1,K,I) IY(K)=IPTINT(2,K,I) - END DO -#endif -! 1.b Loop over corner points -! -#ifdef W3_MPI + END DO + ! DO J=1, 4 -#endif -! -#ifdef W3_MPI + ! IT = IT0 + (I-1)*4 + J IS(J) = MAPFS (IY(J),IX(J)) IF ( IS(J) .EQ. 0 ) THEN - JSEA = 0 - IP(J) = NAPPNT - ELSE - CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) - END IF + JSEA = 0 + IP(J) = NAPPNT + ELSE + CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) + END IF #endif -! -! 1.c Send if point is stored here -! + ! + ! 1.g Receive in correct array + ! #ifdef W3_MPI - IF ( IP(J) .EQ. IAPROC ) THEN - IH = IH + 1 - CALL MPI_SEND_INIT ( VA(1,JSEA), NSPEC, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQPO1(IH), IERR ) + IH = IH + 1 + ITARG = IP(J) - 1 + CALL MPI_RECV_INIT ( SPPNT(1,1,J), NSPEC, MPI_REAL, & + ITARG, IT, MPI_COMM_WAVE, IRQPO2(IH), IERR ) #endif #ifdef W3_MPIT - WRITE (NDST,9011) IH,I,J, IROOT,IT, IRQPO1(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -! ... End of loop 1.b -! -#ifdef W3_MPI - END DO + WRITE (NDST,9011) IH,I,J, ITARG,IT, IRQPO2(IH), IERR #endif -! -! ... End of loop 1.a -! + ! + ! ... End of loop 1.f + ! #ifdef W3_MPI END DO + ! + ! ... End of loop 1.e + ! + END DO + ! + NRQPO2 = NOPTS*4 #endif -! -#ifdef W3_MPI - NRQPO = IH -#endif -! + ! #ifdef W3_MPIT WRITE (NDST,9012) - WRITE (NDST,9013) NRQPO + WRITE (NDST,9014) NRQPO2 #endif -! -! 1.d Set-up for W3IOPE/O ( RECVs ) ---------------------------------- / -! + ! #ifdef W3_MPI - IF ( IAPROC .EQ. NAPPNT ) THEN -#endif -! -#ifdef W3_MPI - IH = 0 -#endif -! -! 2.e Loop over output locations -! -#ifdef W3_MPIT - WRITE (NDST,9010) 'MPI_RECV_INIT' -#endif -! -#ifdef W3_MPI - DO I=1, NOPTS - DO K=1,4 - IX(K)=IPTINT(1,K,I) - IY(K)=IPTINT(2,K,I) - END DO -#endif -! -#ifdef W3_MPI - DO J=1, 4 -#endif -! -#ifdef W3_MPI - IT = IT0 + (I-1)*4 + J - IS(J) = MAPFS (IY(J),IX(J)) - IF ( IS(J) .EQ. 0 ) THEN - JSEA = 0 - IP(J) = NAPPNT - ELSE - CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) - END IF -#endif -! -! 1.g Receive in correct array -! -#ifdef W3_MPI - IH = IH + 1 - ITARG = IP(J) - 1 - CALL MPI_RECV_INIT ( SPPNT(1,1,J), NSPEC, MPI_REAL, & - ITARG, IT, MPI_COMM_WAVE, IRQPO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH,I,J, ITARG,IT, IRQPO2(IH), IERR -#endif -! -! ... End of loop 1.f -! -#ifdef W3_MPI - END DO -#endif -! -! ... End of loop 1.e -! -#ifdef W3_MPI - END DO -#endif -! -#ifdef W3_MPI - NRQPO2 = NOPTS*4 -#endif -! -#ifdef W3_MPIT - WRITE (NDST,9012) - WRITE (NDST,9014) NRQPO2 -#endif -! -#ifdef W3_MPI - END IF + END IF #endif -! -! + ! + ! #ifdef W3_MPI - IT0 = IT0 + 8*NOPTS + IT0 = IT0 + 8*NOPTS #endif -! -! 1.h Base tag number for track output -! + ! + ! 1.h Base tag number for track output + ! #ifdef W3_MPI - IT0TRK = IT0 + IT0TRK = IT0 #endif -! - RETURN -! -! Formats : -! + ! + RETURN + ! + ! Formats : + ! #ifdef W3_MPI - 1001 FORMAT (/' *** ERROR W3MPIP : ARRAYS ALREADY ALLOCATED *** '/) +1001 FORMAT (/' *** ERROR W3MPIP : ARRAYS ALREADY ALLOCATED *** '/) #endif -! + ! #ifdef W3_MPIT - 9010 FORMAT (/' TEST W3MPIP: ',A,' CALLS FOR W3IOPO'/ & +9010 FORMAT (/' TEST W3MPIP: ',A,' CALLS FOR W3IOPO'/ & ' +------+------+---+------+------+--------------+'/ & ' | IH | IPT | J | TARG | TAG | handle err |'/ & ' +------+------+---+------+------+--------------+') - 9011 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') - 9012 FORMAT ( & +9011 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') +9012 FORMAT ( & ' +------+------+---+------+------+--------------+') - 9013 FORMAT ( ' TEST W3MPIP: NRQPO :',I10) - 9014 FORMAT ( ' TEST W3MPIP: TOTAL :',I10) -#endif -!/ -!/ End of W3MPIP ----------------------------------------------------- / -!/ - END SUBROUTINE W3MPIP -!/ -!/ End of module W3INITMD -------------------------------------------- / -!/ - END MODULE W3INITMD +9013 FORMAT ( ' TEST W3MPIP: NRQPO :',I10) +9014 FORMAT ( ' TEST W3MPIP: TOTAL :',I10) +#endif + !/ + !/ End of W3MPIP ----------------------------------------------------- / + !/ + END SUBROUTINE W3MPIP + !/ + !/ End of module W3INITMD -------------------------------------------- / + !/ +END MODULE W3INITMD diff --git a/model/src/w3iobcmd.F90 b/model/src/w3iobcmd.F90 index f82c24d7a..f1da6a18d 100644 --- a/model/src/w3iobcmd.F90 +++ b/model/src/w3iobcmd.F90 @@ -1,848 +1,846 @@ !> @file !> @brief Processing of boundary data output. -!> +!> !> @author H. L. Tolman @date 01-Mar-2018 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / !> !> @brief Processing of boundary data output. -!> -!> @author H. L. Tolman @date 01-Mar-2018 !> - MODULE W3IOBCMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mar-2018 | -!/ +-----------------------------------+ -!/ -!/ See subroutine for update log. -!/ -!/ Copyright 2009-2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Processing of boundary data output. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! VERBPTBC C*10 Public Nest file version number. -! IDSTRBC C*32 Public Restart file ID string. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3IOBC Subr. Public Boundary data IO. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETO, W3SETG, W3SETW, W3SETA, W3DMO5 -! Subr. W3xDATMD Manage data structures. -! W3CSPC Subr. W3CSPCMD Spectral grid conversion. -! W3LLTOEQ Subr. W3CSPCMD Standard to rotated lat/lon conversion. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! None. -! -! 6. Switches : -! -! See subroutine W3IOBC. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Public variables (ID strings) -!/ - CHARACTER(LEN=10), PARAMETER :: VERBPTBC = '2018-03-01' - CHARACTER(LEN=32), PARAMETER :: & - IDSTRBC = 'WAVEWATCH III BOUNDARY DATA FILE' -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Write/read boundary conditions file(s). -!> -!> @details The file(s) are opened within the routine, the names are -!> pre-defined as nest.FILEXT for the input file and nest1.FILEXT -!> through nest9.FILEXT for up to 9 output files. -!> -!> @param[inout] INXOUT Test string for read/write. -!> @param[inout] NDSB Data set unit number. -!> @param[inout] TIME1 Present time (w), time of first field (r). -!> @param[inout] TIME2 Time of second field. -!> @param[inout] IOTST Test indictor for reading. -!> @param[inout] IMOD Optional grid number, defaults to 1. +!> @author H. L. Tolman @date 01-Mar-2018 !> -!> @author H. L. Tolman @date 20-Jan-2017 -!> - SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 12-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 20-May-1999 : Remove read bug for IPBP and RDBP ( see web page ) -!/ 30-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 13-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 19-Sep-2005 : Allow for change of spec. res. ( version 3.08 ) -!/ (on read only). -!/ 30-Sep-2005 : Add 'DUMP' option. ( version 3.08 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 28-Jul-2010 : Moving NKI, NTHI, XFRI, FR1I and -!/ TH1I to W3ODATMD. ( version 3.14.3 ) -!/ 31-Oct-2010 : Implementing unstructured grid ( version 3.14.3 ) -!/ (A. Roland and F. Ardhuin) -!/ 05-Apr-2011 : Moved the W3CSPC call into loop ( version 3.14.3 ) -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 03-Jul-2013 : Corrected ABPIN indices ( version 4.11 ) -!/ 14-Jan-2014 : Corrected ABPIN indices for W3CSPC ( version 4.18 ) -!/ 20-Jan-2017 : Allow input boundary points to lie outside the grid -!/ within a distance of 0.1 times the grid cell size. -!/ (T.J. Campbell, NRL) ( version 6.02 ) -!/ 01-Mar-2018 : Rotate boundary points and directions -!/ of input spectra for rotated grids ( version 6.02 ) -!/ 07-Oct-2019 : RTD option with standard lat-lon -!/ grid when nesting to rotated grid ( version 7.11 ) -!/ -! 1. Purpose : -! -! Write/read boundary conditions file(s). -! -! 2. Method : -! -! The file(s) are opened within the routine, the names are -! pre-defined as nest.FILEXT for the input file and nest1.FILEXT -! through nest9.FILEXT for up to 9 output files. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ', 'WRITE' or 'DUMP'. -! NDSB Int. I Data set unit number. -! TIME1 I.A. I/O Present time. (w) -! Time of first field. (r) -! TIME2 I.A. O Time of second field. (r) -! IOTST Int. O Test indictor for reading. -! 1 : File not found. -! 0 : Fields read. -! -1 : Past end of file. -! IMOD Int. I Optional grid number, defaults to 1. -! ---------------------------------------------------------------- -! (w) used for write only -! (r) used for write only -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! Tests on INXOUT, file status and data present in file. -! -! 7. Remarks : -! -! - Array dimensions are tested in W3IOGR. -! - Spectra are stored as frequency (sigma) spectra to guarantee -! conservation under grid transformation. -! - At the moment it is mplicitly assumed that the number of -! spectral components is larger that the number of spectra -! per time step per file. -! - Dump option used in multi-grid model. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/S Enable subroutine tracing. -! !/T General test output. -! !/T0 Point info test output. -! !/T1 Wave heights at input/output points. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -! - USE W3GDATMD, ONLY: W3SETG - USE W3WDATMD, ONLY: W3SETW - USE W3ADATMD, ONLY: W3SETA - USE W3ODATMD, ONLY: W3SETO, W3DMO5 - USE W3CSPCMD, ONLY: W3CSPC - USE W3TRIAMD, ONLY: W3NESTUG -! - USE W3GDATMD, ONLY: NK, NTH, NSPEC, NSEA, NSEAL, NX, NY, & - X0, Y0, SX, SY, GSU, MAPSTA, MAPFS, MAPSF, & - XFR, FR1, SIG2, TH, DTH, FILEXT, FACHFE, & - GTYPE, UNGTYPE, SMCTYPE - USE W3GDATMD, ONLY: DXYMAX +MODULE W3IOBCMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mar-2018 | + !/ +-----------------------------------+ + !/ + !/ See subroutine for update log. + !/ + !/ Copyright 2009-2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Processing of boundary data output. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! VERBPTBC C*10 Public Nest file version number. + ! IDSTRBC C*32 Public Restart file ID string. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3IOBC Subr. Public Boundary data IO. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETO, W3SETG, W3SETW, W3SETA, W3DMO5 + ! Subr. W3xDATMD Manage data structures. + ! W3CSPC Subr. W3CSPCMD Spectral grid conversion. + ! W3LLTOEQ Subr. W3CSPCMD Standard to rotated lat/lon conversion. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! None. + ! + ! 6. Switches : + ! + ! See subroutine W3IOBC. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + !/ Public variables (ID strings) + !/ + CHARACTER(LEN=10), PARAMETER :: VERBPTBC = '2018-03-01' + CHARACTER(LEN=32), PARAMETER :: & + IDSTRBC = 'WAVEWATCH III BOUNDARY DATA FILE' + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Write/read boundary conditions file(s). + !> + !> @details The file(s) are opened within the routine, the names are + !> pre-defined as nest.FILEXT for the input file and nest1.FILEXT + !> through nest9.FILEXT for up to 9 output files. + !> + !> @param[inout] INXOUT Test string for read/write. + !> @param[inout] NDSB Data set unit number. + !> @param[inout] TIME1 Present time (w), time of first field (r). + !> @param[inout] TIME2 Time of second field. + !> @param[inout] IOTST Test indictor for reading. + !> @param[inout] IMOD Optional grid number, defaults to 1. + !> + !> @author H. L. Tolman @date 20-Jan-2017 + !> + SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 12-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 20-May-1999 : Remove read bug for IPBP and RDBP ( see web page ) + !/ 30-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 13-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 19-Sep-2005 : Allow for change of spec. res. ( version 3.08 ) + !/ (on read only). + !/ 30-Sep-2005 : Add 'DUMP' option. ( version 3.08 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 28-Jul-2010 : Moving NKI, NTHI, XFRI, FR1I and + !/ TH1I to W3ODATMD. ( version 3.14.3 ) + !/ 31-Oct-2010 : Implementing unstructured grid ( version 3.14.3 ) + !/ (A. Roland and F. Ardhuin) + !/ 05-Apr-2011 : Moved the W3CSPC call into loop ( version 3.14.3 ) + !/ 12-Jun-2012 : Add /RTD option or rotated grid option. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 03-Jul-2013 : Corrected ABPIN indices ( version 4.11 ) + !/ 14-Jan-2014 : Corrected ABPIN indices for W3CSPC ( version 4.18 ) + !/ 20-Jan-2017 : Allow input boundary points to lie outside the grid + !/ within a distance of 0.1 times the grid cell size. + !/ (T.J. Campbell, NRL) ( version 6.02 ) + !/ 01-Mar-2018 : Rotate boundary points and directions + !/ of input spectra for rotated grids ( version 6.02 ) + !/ 07-Oct-2019 : RTD option with standard lat-lon + !/ grid when nesting to rotated grid ( version 7.11 ) + !/ + ! 1. Purpose : + ! + ! Write/read boundary conditions file(s). + ! + ! 2. Method : + ! + ! The file(s) are opened within the routine, the names are + ! pre-defined as nest.FILEXT for the input file and nest1.FILEXT + ! through nest9.FILEXT for up to 9 output files. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'READ', 'WRITE' or 'DUMP'. + ! NDSB Int. I Data set unit number. + ! TIME1 I.A. I/O Present time. (w) + ! Time of first field. (r) + ! TIME2 I.A. O Time of second field. (r) + ! IOTST Int. O Test indictor for reading. + ! 1 : File not found. + ! 0 : Fields read. + ! -1 : Past end of file. + ! IMOD Int. I Optional grid number, defaults to 1. + ! ---------------------------------------------------------------- + ! (w) used for write only + ! (r) used for write only + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! Tests on INXOUT, file status and data present in file. + ! + ! 7. Remarks : + ! + ! - Array dimensions are tested in W3IOGR. + ! - Spectra are stored as frequency (sigma) spectra to guarantee + ! conservation under grid transformation. + ! - At the moment it is mplicitly assumed that the number of + ! spectral components is larger that the number of spectra + ! per time step per file. + ! - Dump option used in multi-grid model. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/S Enable subroutine tracing. + ! !/T General test output. + ! !/T0 Point info test output. + ! !/T1 Wave heights at input/output points. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + ! + USE W3GDATMD, ONLY: W3SETG + USE W3WDATMD, ONLY: W3SETW + USE W3ADATMD, ONLY: W3SETA + USE W3ODATMD, ONLY: W3SETO, W3DMO5 + USE W3CSPCMD, ONLY: W3CSPC + USE W3TRIAMD, ONLY: W3NESTUG + ! + USE W3GDATMD, ONLY: NK, NTH, NSPEC, NSEA, NSEAL, NX, NY, & + X0, Y0, SX, SY, GSU, MAPSTA, MAPFS, MAPSF, & + XFR, FR1, SIG2, TH, DTH, FILEXT, FACHFE, & + GTYPE, UNGTYPE, SMCTYPE + USE W3GDATMD, ONLY: DXYMAX #ifdef W3_T1 - USE W3GDATMD, ONLY: SIG + USE W3GDATMD, ONLY: SIG #endif #ifdef W3_RTD - !! Use rotated N-Pole lat/lon and conversion sub. JGLi12Jun2012 - USE W3GDATMD, ONLY: PoLat, PoLon, AnglD - USE W3SERVMD, ONLY: W3LLTOEQ, W3EQTOLL, W3ACTURN -#endif - USE W3WDATMD, ONLY: VA - USE W3ADATMD, ONLY: CG - USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPROC, NAPERR, NAPBPT, & - NBI, NBI2, NFBPO, NBO, NBO2, NDSL, & - NKI, NTHI, XFRI, FR1I, TH1I, & - IPBPI, ISBPI, XBPI, YBPI, RDBPI, & - IPBPO, ISBPO, XBPO, YBPO, RDBPO, & - ABPI0, ABPIN, ABPOS, FLBPI, FILER, FILEW, & - FILED, SPCONV, FNMPRE - USE W3GSRUMD -! - USE W3SERVMD, ONLY: EXTCDE + !! Use rotated N-Pole lat/lon and conversion sub. JGLi12Jun2012 + USE W3GDATMD, ONLY: PoLat, PoLon, AnglD + USE W3SERVMD, ONLY: W3LLTOEQ, W3EQTOLL, W3ACTURN +#endif + USE W3WDATMD, ONLY: VA + USE W3ADATMD, ONLY: CG + USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPROC, NAPERR, NAPBPT, & + NBI, NBI2, NFBPO, NBO, NBO2, NDSL, & + NKI, NTHI, XFRI, FR1I, TH1I, & + IPBPI, ISBPI, XBPI, YBPI, RDBPI, & + IPBPO, ISBPO, XBPO, YBPO, RDBPO, & + ABPI0, ABPIN, ABPOS, FLBPI, FILER, FILEW, & + FILED, SPCONV, FNMPRE + USE W3GSRUMD + ! + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! #ifdef W3_SMC - USE W3PSMCMD, ONLY: W3SMCGMP -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSB - INTEGER, INTENT(INOUT) :: TIME1(2) - INTEGER, INTENT(OUT) :: TIME2(2), IOTST - INTEGER, INTENT(IN), OPTIONAL :: IMOD - CHARACTER, INTENT(IN) :: INXOUT*(*) -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IFILE, IERR, I, J, IX, IY, ISEA, & - IP, ISP, NPTS, ISOUT, IS, IGRD + USE W3PSMCMD, ONLY: W3SMCGMP +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSB + INTEGER, INTENT(INOUT) :: TIME1(2) + INTEGER, INTENT(OUT) :: TIME2(2), IOTST + INTEGER, INTENT(IN), OPTIONAL :: IMOD + CHARACTER, INTENT(IN) :: INXOUT*(*) + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IFILE, IERR, I, J, IX, IY, ISEA, & + IP, ISP, NPTS, ISOUT, IS, IGRD #ifdef W3_T1 - INTEGER :: IK, ITH + INTEGER :: IK, ITH #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T1 - REAL :: HS, HS0 + REAL :: HS, HS0 #endif #ifdef W3_RTD - !! Declare rotation angle and rotated lat/lon variables for - !! boundary points. JGLi12Jun2012 - REAL, ALLOCATABLE :: Anglbdy(:), ELatbdy(:), ELonbdy(:) - REAL :: Spectr(NK*NTH) - REAL :: XRLIM, YRLIM -#endif - REAL, ALLOCATABLE :: TMPSPC(:,:) - LOGICAL :: FLOK - CHARACTER(LEN=18) :: FILEN - CHARACTER(LEN=10) :: VERTST - CHARACTER(LEN=32) :: IDTST -!/ -!/ ------------------------------------------------------------------- / -!/ + !! Declare rotation angle and rotated lat/lon variables for + !! boundary points. JGLi12Jun2012 + REAL, ALLOCATABLE :: Anglbdy(:), ELatbdy(:), ELonbdy(:) + REAL :: Spectr(NK*NTH) + REAL :: XRLIM, YRLIM +#endif + REAL, ALLOCATABLE :: TMPSPC(:,:) + LOGICAL :: FLOK + CHARACTER(LEN=18) :: FILEN + CHARACTER(LEN=10) :: VERTST + CHARACTER(LEN=32) :: IDTST + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3IOBC') -#endif -! - IOTST = 0 -! -! test parameter list input ------------------------------------------ * -! - IF ( PRESENT(IMOD) ) THEN - IGRD = IMOD - ELSE - IGRD = 1 - END IF -! - CALL W3SETO ( IGRD, NDSE, NDST ) - CALL W3SETG ( IGRD, NDSE, NDST ) - CALL W3SETW ( IGRD, NDSE, NDST ) - CALL W3SETA ( IGRD, NDSE, NDST ) -! - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' .AND. & - INXOUT.NE.'DUMP' ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT - CALL EXTCDE ( 1 ) - END IF -! + CALL STRACE (IENT, 'W3IOBC') +#endif + ! + IOTST = 0 + ! + ! test parameter list input ------------------------------------------ * + ! + IF ( PRESENT(IMOD) ) THEN + IGRD = IMOD + ELSE + IGRD = 1 + END IF + ! + CALL W3SETO ( IGRD, NDSE, NDST ) + CALL W3SETG ( IGRD, NDSE, NDST ) + CALL W3SETW ( IGRD, NDSE, NDST ) + CALL W3SETA ( IGRD, NDSE, NDST ) + ! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' .AND. & + INXOUT.NE.'DUMP' ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT + CALL EXTCDE ( 1 ) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) INXOUT, FILER, FILEW, FILED, NDSB -#endif -! -! open file ---------------------------------------------------------- * -! - I = LEN_TRIM(FILEXT) - J = LEN_TRIM(FNMPRE) -! - IF ( INXOUT.EQ.'READ' .AND. FILER ) THEN - WRITE (FILEN,'(A5,A)') 'nest.', FILEXT(:I) + WRITE (NDST,9000) INXOUT, FILER, FILEW, FILED, NDSB +#endif + ! + ! open file ---------------------------------------------------------- * + ! + I = LEN_TRIM(FILEXT) + J = LEN_TRIM(FNMPRE) + ! + IF ( INXOUT.EQ.'READ' .AND. FILER ) THEN + WRITE (FILEN,'(A5,A)') 'nest.', FILEXT(:I) #ifdef W3_T - WRITE (NDST,9001) FILEN(:5+I), NDSB -#endif - OPEN (NDSB,FILE=FNMPRE(:J)//FILEN(:5+I),form='UNFORMATTED', convert=file_endian, & - ERR=801,IOSTAT=IERR,STATUS='OLD') - END IF -! - IF ( INXOUT.EQ.'WRITE' .AND. FILEW ) THEN - DO IFILE=1, NFBPO - NDSL(IFILE) = NDSB + IFILE - 1 - WRITE (FILEN,'(A4,I1,A1,A)') 'nest', IFILE, '.', & - FILEXT(:I) + WRITE (NDST,9001) FILEN(:5+I), NDSB +#endif + OPEN (NDSB,FILE=FNMPRE(:J)//FILEN(:5+I),form='UNFORMATTED', convert=file_endian, & + ERR=801,IOSTAT=IERR,STATUS='OLD') + END IF + ! + IF ( INXOUT.EQ.'WRITE' .AND. FILEW ) THEN + DO IFILE=1, NFBPO + NDSL(IFILE) = NDSB + IFILE - 1 + WRITE (FILEN,'(A4,I1,A1,A)') 'nest', IFILE, '.', & + FILEXT(:I) #ifdef W3_T - WRITE (NDST,9001) FILEN(:6+I), NDSL(IFILE) -#endif - OPEN (NDSL(IFILE),FILE=FNMPRE(:J)//FILEN(:6+I), & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) - END DO - END IF -! - IF ( INXOUT.EQ.'DUMP' .AND. FILED ) THEN - WRITE (FILEN,'(A5,A)') 'nest.', FILEXT(:I) + WRITE (NDST,9001) FILEN(:6+I), NDSL(IFILE) +#endif + OPEN (NDSL(IFILE),FILE=FNMPRE(:J)//FILEN(:6+I), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) + END DO + END IF + ! + IF ( INXOUT.EQ.'DUMP' .AND. FILED ) THEN + WRITE (FILEN,'(A5,A)') 'nest.', FILEXT(:I) #ifdef W3_T - WRITE (NDST,9001) FILEN(:5+I), NDSB -#endif - OPEN (NDSB,FILE=FNMPRE(:J)//FILEN(:5+I),form='UNFORMATTED', convert=file_endian, & - ERR=800,IOSTAT=IERR) - END IF -! -! test info ---------------------------------------------------------- * -! ( new files only ) -! ... writing -! - IF ( INXOUT.EQ.'WRITE' .AND. FILEW ) THEN - IF ( IAPROC .EQ. NAPBPT ) THEN - DO IFILE=1, NFBPO - WRITE (NDSL(IFILE)) & - IDSTRBC, VERBPTBC, NK, NTH, XFR, FR1, TH(1), & - NBO(IFILE)-NBO(IFILE-1) -! + WRITE (NDST,9001) FILEN(:5+I), NDSB +#endif + OPEN (NDSB,FILE=FNMPRE(:J)//FILEN(:5+I),form='UNFORMATTED', convert=file_endian, & + ERR=800,IOSTAT=IERR) + END IF + ! + ! test info ---------------------------------------------------------- * + ! ( new files only ) + ! ... writing + ! + IF ( INXOUT.EQ.'WRITE' .AND. FILEW ) THEN + IF ( IAPROC .EQ. NAPBPT ) THEN + DO IFILE=1, NFBPO + WRITE (NDSL(IFILE)) & + IDSTRBC, VERBPTBC, NK, NTH, XFR, FR1, TH(1), & + NBO(IFILE)-NBO(IFILE-1) + ! #ifdef W3_T - WRITE (NDST,9002) IFILE, NDSL(IFILE), IDSTRBC, & - VERBPTBC, NBO(IFILE)-NBO(IFILE-1) + WRITE (NDST,9002) IFILE, NDSL(IFILE), IDSTRBC, & + VERBPTBC, NBO(IFILE)-NBO(IFILE-1) #endif -! + ! #ifdef W3_RTD - ! By running the ww3_grid program the arrays XBPO, YBPO have been - ! remapped to standard lat-lon and stored in mod_def.* - ! -#endif - WRITE (NDSL(IFILE)) & - (XBPO(I),I=NBO(IFILE-1)+1,NBO(IFILE)), & - (YBPO(I),I=NBO(IFILE-1)+1,NBO(IFILE)), & - ((IPBPO(I,J),I=NBO(IFILE-1)+1,NBO(IFILE)),J=1,4),& - ((RDBPO(I,J),I=NBO(IFILE-1)+1,NBO(IFILE)),J=1,4) -! + ! By running the ww3_grid program the arrays XBPO, YBPO have been + ! remapped to standard lat-lon and stored in mod_def.* + ! +#endif + WRITE (NDSL(IFILE)) & + (XBPO(I),I=NBO(IFILE-1)+1,NBO(IFILE)), & + (YBPO(I),I=NBO(IFILE-1)+1,NBO(IFILE)), & + ((IPBPO(I,J),I=NBO(IFILE-1)+1,NBO(IFILE)),J=1,4),& + ((RDBPO(I,J),I=NBO(IFILE-1)+1,NBO(IFILE)),J=1,4) + ! #ifdef W3_T0 - WRITE (NDST,9003) - DO I=NBO(IFILE-1)+1, NBO(IFILE) - WRITE (NDST,9004) I-NBO(IFILE-1), XBPO(I), & - YBPO(I), (IPBPO(I,J),J=1,4), & - (RDBPO(I,J),J=1,4) - END DO -#endif -! - END DO - END IF - END IF -! -! ... dumping -! - IF ( INXOUT.EQ.'DUMP' .AND. FILED ) THEN - IF ( IAPROC .EQ. NAPBPT ) THEN - WRITE (NDSB) IDSTRBC, VERBPTBC, NK, NTH, XFR, FR1, TH(1), NBI -! + WRITE (NDST,9003) + DO I=NBO(IFILE-1)+1, NBO(IFILE) + WRITE (NDST,9004) I-NBO(IFILE-1), XBPO(I), & + YBPO(I), (IPBPO(I,J),J=1,4), & + (RDBPO(I,J),J=1,4) + END DO +#endif + ! + END DO + END IF + END IF + ! + ! ... dumping + ! + IF ( INXOUT.EQ.'DUMP' .AND. FILED ) THEN + IF ( IAPROC .EQ. NAPBPT ) THEN + WRITE (NDSB) IDSTRBC, VERBPTBC, NK, NTH, XFR, FR1, TH(1), NBI + ! #ifdef W3_T - WRITE (NDST,9002) 1, NDSB, IDSTRBC, VERBPTBC, NBI + WRITE (NDST,9002) 1, NDSB, IDSTRBC, VERBPTBC, NBI #endif -! - WRITE (NDSB) (XBPI(I),I=1,NBI), (YBPI(I),I=1,NBI), & - ((IPBPI(I,J),I=1,NBI),J=1,4), & - ((RDBPI(I,J),I=1,NBI),J=1,4) -! + ! + WRITE (NDSB) (XBPI(I),I=1,NBI), (YBPI(I),I=1,NBI), & + ((IPBPI(I,J),I=1,NBI),J=1,4), & + ((RDBPI(I,J),I=1,NBI),J=1,4) + ! #ifdef W3_T0 - WRITE (NDST,9003) - DO I=1, NBI - WRITE (NDST,9004) I, XBPI(I), YBPI(I), & - (IPBPI(I,J),J=1,4), (RDBPI(I,J),J=1,4) - END DO -#endif -! - END IF - END IF -! -! ... reading -! - IF ( INXOUT.EQ.'READ' .AND. FILER ) THEN -! - READ (NDSB,ERR=803,IOSTAT=IERR) & - IDTST, VERTST, NKI, NTHI, XFRI, FR1I, TH1I, NBI -! + WRITE (NDST,9003) + DO I=1, NBI + WRITE (NDST,9004) I, XBPI(I), YBPI(I), & + (IPBPI(I,J),J=1,4), (RDBPI(I,J),J=1,4) + END DO +#endif + ! + END IF + END IF + ! + ! ... reading + ! + IF ( INXOUT.EQ.'READ' .AND. FILER ) THEN + ! + READ (NDSB,ERR=803,IOSTAT=IERR) & + IDTST, VERTST, NKI, NTHI, XFRI, FR1I, TH1I, NBI + ! #ifdef W3_T - WRITE (NDST,9002) 1, NDSB, IDTST, VERTST, NBI -#endif -! - IF ( IDTST .NE. IDSTRBC ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,901) IDTST, IDSTRBC - CALL EXTCDE ( 10 ) - END IF - IF ( VERTST .NE. VERBPTBC ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,902) VERTST, VERBPTBC - CALL EXTCDE ( 11 ) - END IF -! -! Determines if the spectrum in nest file needs to be converted -! - SPCONV = NKI.NE.NK .OR. NTHI.NE.NTH .OR. & - ABS(XFRI/XFR-1.).GT.0.01 .OR. & - ABS(FR1I/FR1-1.).GT.0.01 .OR. & - ABS(TH1I-TH(1)).GT.0.01*DTH -! - CALL W3DMO5 ( IGRD, NDSE, NDST, 1 ) -! - READ (NDSB,ERR=803,IOSTAT=IERR) & - (XBPI(I),I=1,NBI), (YBPI(I),I=1,NBI), & - ((IPBPI(I,J),I=1,NBI),J=1,4), & - ((RDBPI(I,J),I=1,NBI),J=1,4) -! + WRITE (NDST,9002) 1, NDSB, IDTST, VERTST, NBI +#endif + ! + IF ( IDTST .NE. IDSTRBC ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,901) IDTST, IDSTRBC + CALL EXTCDE ( 10 ) + END IF + IF ( VERTST .NE. VERBPTBC ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,902) VERTST, VERBPTBC + CALL EXTCDE ( 11 ) + END IF + ! + ! Determines if the spectrum in nest file needs to be converted + ! + SPCONV = NKI.NE.NK .OR. NTHI.NE.NTH .OR. & + ABS(XFRI/XFR-1.).GT.0.01 .OR. & + ABS(FR1I/FR1-1.).GT.0.01 .OR. & + ABS(TH1I-TH(1)).GT.0.01*DTH + ! + CALL W3DMO5 ( IGRD, NDSE, NDST, 1 ) + ! + READ (NDSB,ERR=803,IOSTAT=IERR) & + (XBPI(I),I=1,NBI), (YBPI(I),I=1,NBI), & + ((IPBPI(I,J),I=1,NBI),J=1,4), & + ((RDBPI(I,J),I=1,NBI),J=1,4) + ! #ifdef W3_RTD - ! All boundary conditions position arrays XBPI, YBPI are defined - ! in standard lat/lon coordinates. If Polat = 90. (and Polon = -180.), - ! the b.c. positions don't need to be remapped - IF ( Polat < 90. ) THEN - !! Convert standard into rotated lat/lon. JGLi12Jun2012 - ALLOCATE ( Anglbdy(NBI), ELatbdy(NBI), ELonbdy(NBI) ) + ! All boundary conditions position arrays XBPI, YBPI are defined + ! in standard lat/lon coordinates. If Polat = 90. (and Polon = -180.), + ! the b.c. positions don't need to be remapped + IF ( Polat < 90. ) THEN + !! Convert standard into rotated lat/lon. JGLi12Jun2012 + ALLOCATE ( Anglbdy(NBI), ELatbdy(NBI), ELonbdy(NBI) ) - CALL W3LLTOEQ ( YBPI, XBPI, ELatbdy, ELonbdy, & - & Anglbdy, PoLat, PoLon, NBI ) + CALL W3LLTOEQ ( YBPI, XBPI, ELatbdy, ELonbdy, & + & Anglbdy, PoLat, PoLon, NBI ) - XBPI = ELonbdy - YBPI = ELatbdy - !! W3LLTOEQ outputs longitudes on 0->360 degree grid - !! Next section will revise to -180->180 convention if required - !! by nested model rotated grid; determined by X0 lon value - IF ( X0 .LT. 0.0 ) THEN - DO I=1, NBI - IF ( XBPI(I) .GT. 180.0) XBPI(I) = XBPI(I) - 360.0 - ENDDO - END IF - !! The old (4.18) W3GFPT was very strict so this loop reassigns RTD - !! values to within a tolerance of the boundary - possibly this is - !! no longer required after the 20-Jan-2017 change? - XRLIM = X0 + (NX-1) * SX - YRLIM = Y0 + (NY-1) * SY + XBPI = ELonbdy + YBPI = ELatbdy + !! W3LLTOEQ outputs longitudes on 0->360 degree grid + !! Next section will revise to -180->180 convention if required + !! by nested model rotated grid; determined by X0 lon value + IF ( X0 .LT. 0.0 ) THEN DO I=1, NBI - IF ( ABS(XBPI(I) - X0) .LT. SX/4.0 ) XBPI(I) = X0 - IF ( ABS(YBPI(I) - Y0) .LT. SY/4.0 ) YBPI(I) = Y0 - IF ( ABS(XBPI(I) - XRLIM) .LT. SX/4.0 ) XBPI(I) = XRLIM - IF ( ABS(YBPI(I) - YRLIM) .LT. SY/4.0 ) YBPI(I) = YRLIM + IF ( XBPI(I) .GT. 180.0) XBPI(I) = XBPI(I) - 360.0 ENDDO + END IF + !! The old (4.18) W3GFPT was very strict so this loop reassigns RTD + !! values to within a tolerance of the boundary - possibly this is + !! no longer required after the 20-Jan-2017 change? + XRLIM = X0 + (NX-1) * SX + YRLIM = Y0 + (NY-1) * SY + DO I=1, NBI + IF ( ABS(XBPI(I) - X0) .LT. SX/4.0 ) XBPI(I) = X0 + IF ( ABS(YBPI(I) - Y0) .LT. SY/4.0 ) YBPI(I) = Y0 + IF ( ABS(XBPI(I) - XRLIM) .LT. SX/4.0 ) XBPI(I) = XRLIM + IF ( ABS(YBPI(I) - YRLIM) .LT. SY/4.0 ) YBPI(I) = YRLIM + ENDDO - DEALLOCATE ( Anglbdy, ELatbdy, ELonbdy ) + DEALLOCATE ( Anglbdy, ELatbdy, ELonbdy ) - END IF ! ( Polat < 90. ) + END IF ! ( Polat < 90. ) #endif - FLOK = .TRUE. - IF (GTYPE .EQ. UNGTYPE) THEN - CALL W3NESTUG(DXYMAX,FLOK) + FLOK = .TRUE. + IF (GTYPE .EQ. UNGTYPE) THEN + CALL W3NESTUG(DXYMAX,FLOK) #ifdef W3_SMC - !Li For SMC grid check whether boundary points are within cell area. - ELSE IF( GTYPE .EQ. SMCTYPE ) THEN - CALL W3SMCGMP( IGRD, NBI, XBPI, YBPI, ISBPI ) - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,920) & - ( ISBPI(I), XBPI(I), YBPI(I), I=1,NBI ) -#endif - ELSE - DO I=1, NBI - ! W3GFTP: find the nearest grid point to the input boundary point - ! DCIN=0.1 is the distance outside of source grid in units of - ! cell width to treat target point as inside the source grid. - IF ( W3GFPT( GSU, XBPI(I), YBPI(I), IX, IY, DCIN=0.1 ) ) THEN - IF ( ABS(MAPSTA(IY,IX)) .NE. 2 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,909) IX, IY, ABS(MAPSTA(IY,IX)) - FLOK = .FALSE. - END IF - ELSE - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,910) I, XBPI(I), YBPI(I) - CALL EXTCDE ( 12 ) - END IF - ISBPI(I) = MAPFS(IY,IX) - END DO - END IF -! + !Li For SMC grid check whether boundary points are within cell area. + ELSE IF( GTYPE .EQ. SMCTYPE ) THEN + CALL W3SMCGMP( IGRD, NBI, XBPI, YBPI, ISBPI ) + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,920) & + ( ISBPI(I), XBPI(I), YBPI(I), I=1,NBI ) +#endif + ELSE + DO I=1, NBI + ! W3GFTP: find the nearest grid point to the input boundary point + ! DCIN=0.1 is the distance outside of source grid in units of + ! cell width to treat target point as inside the source grid. + IF ( W3GFPT( GSU, XBPI(I), YBPI(I), IX, IY, DCIN=0.1 ) ) THEN + IF ( ABS(MAPSTA(IY,IX)) .NE. 2 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,909) IX, IY, ABS(MAPSTA(IY,IX)) + FLOK = .FALSE. + END IF + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,910) I, XBPI(I), YBPI(I) + CALL EXTCDE ( 12 ) + END IF + ISBPI(I) = MAPFS(IY,IX) + END DO + END IF + ! #ifdef W3_T0 - WRITE (NDST,9003) + WRITE (NDST,9003) + DO I=1, NBI + WRITE (NDST,9005) I, ISBPI(I), XBPI(I), YBPI(I), & + (IPBPI(I,J),J=1,4), (RDBPI(I,J),J=1,4) + END DO +#endif + ! + IF ( .NOT.FLOK ) CALL EXTCDE ( 20 ) + ! + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 ) THEN + FLOK = .FALSE. DO I=1, NBI - WRITE (NDST,9005) I, ISBPI(I), XBPI(I), YBPI(I), & - (IPBPI(I,J),J=1,4), (RDBPI(I,J),J=1,4) - END DO -#endif -! - IF ( .NOT.FLOK ) CALL EXTCDE ( 20 ) -! - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 ) THEN - FLOK = .FALSE. - DO I=1, NBI - IF ( ISEA .EQ. ISBPI(I) ) FLOK = .TRUE. - END DO - IF ( .NOT.FLOK .AND. IAPROC.EQ.NAPERR ) & - WRITE (NDSE,911) IX, IY - END IF - END DO -! -! Read first time and allocate ABPI0/N -! - READ (NDSB,END=810,ERR=810) TIME2, NBI2 - BACKSPACE (NDSB) -#ifdef W3_T - WRITE (NDST,9012) NDSB, TIME2, NBI2 -#endif - CALL W3DMO5 ( IGRD, NDSE, NDST, 3 ) -! + IF ( ISEA .EQ. ISBPI(I) ) FLOK = .TRUE. + END DO + IF ( .NOT.FLOK .AND. IAPROC.EQ.NAPERR ) & + WRITE (NDSE,911) IX, IY END IF -! -! Save previous spectra on read -------------------------------------- * -! - IF ( INXOUT.EQ.'READ' .AND. .NOT.FILER ) THEN + END DO + ! + ! Read first time and allocate ABPI0/N + ! + READ (NDSB,END=810,ERR=810) TIME2, NBI2 + BACKSPACE (NDSB) #ifdef W3_T - WRITE (NDST,9020) -#endif - TIME1 = TIME2 - ABPI0(:,1:NBI2) = ABPIN(:,1:NBI2) - END IF -! -! TIME --------------------------------------------------------------- * -! - IF ( INXOUT .EQ. 'WRITE' ) THEN - DO IFILE=1, NFBPO - NPTS = NBO2(IFILE) - NBO2(IFILE-1) - WRITE (NDSL(IFILE)) TIME1, NPTS + WRITE (NDST,9012) NDSB, TIME2, NBI2 +#endif + CALL W3DMO5 ( IGRD, NDSE, NDST, 3 ) + ! + END IF + ! + ! Save previous spectra on read -------------------------------------- * + ! + IF ( INXOUT.EQ.'READ' .AND. .NOT.FILER ) THEN #ifdef W3_T - WRITE (NDST,9010) IFILE, NDSL(IFILE), TIME1, NPTS -#endif - END DO - END IF -! - IF ( INXOUT .EQ. 'DUMP' ) THEN - WRITE (NDSB) TIME1, NBI2 + WRITE (NDST,9020) +#endif + TIME1 = TIME2 + ABPI0(:,1:NBI2) = ABPIN(:,1:NBI2) + END IF + ! + ! TIME --------------------------------------------------------------- * + ! + IF ( INXOUT .EQ. 'WRITE' ) THEN + DO IFILE=1, NFBPO + NPTS = NBO2(IFILE) - NBO2(IFILE-1) + WRITE (NDSL(IFILE)) TIME1, NPTS #ifdef W3_T - WRITE (NDST,9011) NDSB, TIME1, NBI2 + WRITE (NDST,9010) IFILE, NDSL(IFILE), TIME1, NPTS #endif - END IF -! - IF ( INXOUT .EQ. 'READ' ) THEN - READ (NDSB,ERR=810,END=810) TIME2, NBI2 + END DO + END IF + ! + IF ( INXOUT .EQ. 'DUMP' ) THEN + WRITE (NDSB) TIME1, NBI2 #ifdef W3_T - WRITE (NDST,9011) NDSB, TIME2, NBI2 + WRITE (NDST,9011) NDSB, TIME1, NBI2 #endif - END IF -! -! Spectra ------------------------------------------------------------ * -! - IF ( INXOUT .EQ. 'WRITE' ) THEN -! + END IF + ! + IF ( INXOUT .EQ. 'READ' ) THEN + READ (NDSB,ERR=810,END=810) TIME2, NBI2 +#ifdef W3_T + WRITE (NDST,9011) NDSB, TIME2, NBI2 +#endif + END IF + ! + ! Spectra ------------------------------------------------------------ * + ! + IF ( INXOUT .EQ. 'WRITE' ) THEN + ! #ifdef W3_T1 - WRITE (NDST,9040) -#endif -! - DO IFILE=1, NFBPO - DO ISOUT=NBO2(IFILE-1)+1, NBO2(IFILE) -! - ISEA = ISBPO(ISOUT) -! -! ... Shared memory version data gather -! + WRITE (NDST,9040) +#endif + ! + DO IFILE=1, NFBPO + DO ISOUT=NBO2(IFILE-1)+1, NBO2(IFILE) + ! + ISEA = ISBPO(ISOUT) + ! + ! ... Shared memory version data gather + ! #ifdef W3_SHRD - DO IS=1, NSPEC - ABPOS(IS,ISOUT) = VA(IS,ISEA) * SIG2(IS) / & - CG(1+(IS-1)/NTH,ISEA) - END DO -#endif -! -! ... Distributed memory version data gather -! ( Array pre-filled in W3WAVE ) -! + DO IS=1, NSPEC + ABPOS(IS,ISOUT) = VA(IS,ISEA) * SIG2(IS) / & + CG(1+(IS-1)/NTH,ISEA) + END DO +#endif + ! + ! ... Distributed memory version data gather + ! ( Array pre-filled in W3WAVE ) + ! #ifdef W3_DIST - DO IS=1, NSPEC - ABPOS(IS,ISOUT) = ABPOS(IS,ISOUT) * SIG2(IS) / & - CG(1+(IS-1)/NTH,ISEA) - END DO + DO IS=1, NSPEC + ABPOS(IS,ISOUT) = ABPOS(IS,ISOUT) * SIG2(IS) / & + CG(1+(IS-1)/NTH,ISEA) + END DO #endif -! + ! #ifdef W3_RTD - ! Polat == 90. means the grid is standard lat-lon, and the spectra - ! need not be rotated back - IF ( Polat < 90. ) THEN - ! Added spectral turning for rotated grid - ! (rotate back to standard pole) - Spectr = ABPOS(:,ISOUT) - CALL W3ACTURN( NTH, NK, -AnglD(ISEA), Spectr ) - ABPOS(:,ISOUT) = Spectr - END IF -#endif -! - WRITE (NDSL(IFILE)) (ABPOS(IS,ISOUT),IS=1,NSPEC) -! + ! Polat == 90. means the grid is standard lat-lon, and the spectra + ! need not be rotated back + IF ( Polat < 90. ) THEN + ! Added spectral turning for rotated grid + ! (rotate back to standard pole) + Spectr = ABPOS(:,ISOUT) + CALL W3ACTURN( NTH, NK, -AnglD(ISEA), Spectr ) + ABPOS(:,ISOUT) = Spectr + END IF +#endif + ! + WRITE (NDSL(IFILE)) (ABPOS(IS,ISOUT),IS=1,NSPEC) + ! #ifdef W3_T1 - HS = 0. - DO IK=1, NK - DO ITH=1, NTH - IS = ITH + (IK-1)*NTH - HS = HS + ABPOS(IS,ISOUT)*SIG(IK) - END DO - END DO - HS = 4. * SQRT ( HS * DTH * 0.5 * (XFR-1./XFR) ) - WRITE (NDST,9041) NDSL(IFILE), ISOUT, ISEA, HS -#endif -! - END DO + HS = 0. + DO IK=1, NK + DO ITH=1, NTH + IS = ITH + (IK-1)*NTH + HS = HS + ABPOS(IS,ISOUT)*SIG(IK) END DO -! - END IF -! - IF ( INXOUT .EQ. 'DUMP' ) THEN - DO I=1, NBI2 - WRITE (NDSB) ABPIN(:,I) - END DO - END IF -! - IF ( INXOUT .EQ. 'READ' ) THEN -! - IF ( .NOT. SPCONV ) THEN - DO IP=1, NBI2 - READ (NDSB,ERR=803,IOSTAT=IERR) ABPIN(:,IP) - END DO - ELSE -! -! In this case the spectral resolution is not compatible and -! the spectrum TMPSPC in nest file must be re-gridded into ABPIN to fit the model run -! spectral conversion is done by W3CSPC in w3cspcmd.ftn -! - ALLOCATE ( TMPSPC(NKI*NTHI,NBI2) ) - DO IP=1, NBI2 - READ (NDSB,ERR=803,IOSTAT=IERR) TMPSPC(:,IP) - END DO - CALL W3CSPC ( TMPSPC , NKI, NTHI, XFRI, FR1I, TH1I, & - ABPIN(:,1:NBI2),NK, NTH, XFR, FR1, TH(1),& - NBI2, NDST, NDSE, FACHFE ) - DEALLOCATE ( TMPSPC ) - END IF -! + END DO + HS = 4. * SQRT ( HS * DTH * 0.5 * (XFR-1./XFR) ) + WRITE (NDST,9041) NDSL(IFILE), ISOUT, ISEA, HS +#endif + ! + END DO + END DO + ! + END IF + ! + IF ( INXOUT .EQ. 'DUMP' ) THEN + DO I=1, NBI2 + WRITE (NDSB) ABPIN(:,I) + END DO + END IF + ! + IF ( INXOUT .EQ. 'READ' ) THEN + ! + IF ( .NOT. SPCONV ) THEN + DO IP=1, NBI2 + READ (NDSB,ERR=803,IOSTAT=IERR) ABPIN(:,IP) + END DO + ELSE + ! + ! In this case the spectral resolution is not compatible and + ! the spectrum TMPSPC in nest file must be re-gridded into ABPIN to fit the model run + ! spectral conversion is done by W3CSPC in w3cspcmd.ftn + ! + ALLOCATE ( TMPSPC(NKI*NTHI,NBI2) ) + DO IP=1, NBI2 + READ (NDSB,ERR=803,IOSTAT=IERR) TMPSPC(:,IP) + END DO + CALL W3CSPC ( TMPSPC , NKI, NTHI, XFRI, FR1I, TH1I, & + ABPIN(:,1:NBI2),NK, NTH, XFR, FR1, TH(1),& + NBI2, NDST, NDSE, FACHFE ) + DEALLOCATE ( TMPSPC ) + END IF + ! #ifdef W3_T1 - WRITE (NDST,9042) - DO IP=1, NBI2 - HS = 0. - HS0 = 0. - DO ISP=1, NSPEC - HS = HS + ABPIN(ISP,IP)*SIG2(ISP) - IF ( .NOT.FILER ) HS0 = HS0 + ABPI0(ISP,IP)*SIG2(ISP) - END DO - HS = 4. * SQRT ( HS * DTH * 0.5 * (XFR-1./XFR) ) - HS0 = 4. * SQRT ( HS0 * DTH * 0.5 * (XFR-1./XFR) ) - WRITE (NDST,9043) IP, HS0, HS - END DO -#endif -! - END IF -! -! Set first spectra on first read ------------------------------------ * -! - IF ( INXOUT.EQ.'READ' .AND. FILER ) THEN + WRITE (NDST,9042) + DO IP=1, NBI2 + HS = 0. + HS0 = 0. + DO ISP=1, NSPEC + HS = HS + ABPIN(ISP,IP)*SIG2(ISP) + IF ( .NOT.FILER ) HS0 = HS0 + ABPI0(ISP,IP)*SIG2(ISP) + END DO + HS = 4. * SQRT ( HS * DTH * 0.5 * (XFR-1./XFR) ) + HS0 = 4. * SQRT ( HS0 * DTH * 0.5 * (XFR-1./XFR) ) + WRITE (NDST,9043) IP, HS0, HS + END DO +#endif + ! + END IF + ! + ! Set first spectra on first read ------------------------------------ * + ! + IF ( INXOUT.EQ.'READ' .AND. FILER ) THEN #ifdef W3_T - WRITE (NDST,9021) -#endif - TIME1 = TIME2 - DO IP=1, NBI2 - ABPI0(:,IP) = ABPIN(:,IP) - END DO - ABPI0(:,0) = 0. - ABPIN(:,0) = 0. - END IF -! -! Reset flags -------------------------------------------------------- * -! - IF ( INXOUT .EQ. 'WRITE' ) FILEW = .FALSE. - IF ( INXOUT .EQ. 'DUMP' ) FILED = .FALSE. - IF ( INXOUT .EQ. 'READ' ) FILER = .FALSE. -! - RETURN -! -! Escape locations IO errors -! - 800 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) FILEN, IERR - CALL EXTCDE ( 40 ) -! - 801 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) IMOD - IOTST = 1 - FLBPI = .FALSE. - RETURN -! - 802 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) - CALL EXTCDE ( 41 ) -! - 803 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) IERR - CALL EXTCDE ( 42 ) -! - 810 CONTINUE - IF ( FILER ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1010) - CALL EXTCDE ( 43 ) - END IF -! + WRITE (NDST,9021) +#endif + TIME1 = TIME2 + DO IP=1, NBI2 + ABPI0(:,IP) = ABPIN(:,IP) + END DO + ABPI0(:,0) = 0. + ABPIN(:,0) = 0. + END IF + ! + ! Reset flags -------------------------------------------------------- * + ! + IF ( INXOUT .EQ. 'WRITE' ) FILEW = .FALSE. + IF ( INXOUT .EQ. 'DUMP' ) FILED = .FALSE. + IF ( INXOUT .EQ. 'READ' ) FILER = .FALSE. + ! + RETURN + ! + ! Escape locations IO errors + ! +800 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) FILEN, IERR + CALL EXTCDE ( 40 ) + ! +801 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) IMOD + IOTST = 1 + FLBPI = .FALSE. + RETURN + ! +802 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) + CALL EXTCDE ( 41 ) + ! +803 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) IERR + CALL EXTCDE ( 42 ) + ! +810 CONTINUE + IF ( FILER ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1010) + CALL EXTCDE ( 43 ) + END IF + ! #ifdef W3_T - WRITE (NDST,9022) + WRITE (NDST,9022) #endif - TIME1(1) = TIME2(1) - TIME1(2) = TIME2(2) + TIME1(1) = TIME2(1) + TIME1(2) = TIME2(2) DO IP=0, NBI2 - DO ISP=1, NSPEC - ABPI0(ISP,IP) = ABPIN(ISP,IP) - END DO + DO ISP=1, NSPEC + ABPI0(ISP,IP) = ABPIN(ISP,IP) + END DO END DO -! - IOTST = -1 - FLBPI = .FALSE. - RETURN -! -! Formats -! - 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC :'/ & - ' ILLEGAL INXOUT VALUE: ',A/) - 901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC :'/ & - ' ILLEGAL IDSTRBC, READ : ',A/ & - ' CHECK : ',A/) - 902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC :'/ & - ' ILLEGAL VEROGR, READ : ',A/ & - ' CHECK : ',A/) -! - 909 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC :'/ & - ' POINT',2I4,' NOT ACTIVE SEA POINT (',I1,')') - 910 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC :'/ & - ' POINT',I4,2E14.6,' NOT LOCATED IN GRID') - 911 FORMAT ( ' *** WAVEWATCH III WARNING : POINT',2I7, & - ' WILL NOT BE UPDATED') - 920 FORMAT (/' *** SMCTYPE mapped boundary cells:'/ ((I8,2F9.3)) ) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & - ' ERROR IN OPENING FILE ',A/ & - ' IOSTAT =',I5/) -! -! Note: This 1001 error can occur when multi-grid time steps are not -! compatible. - 1001 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOBC : '/ & - ' INPUT FILE WITH BOUNDARY CONDITIONS NOT FOUND'/ & - ' BOUNDARY CONDITIONS WILL NOT BE UPDATED ',I5/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & - ' PREMATURE END OF FILE'/) - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & - ' ERROR IN READING FROM FILE'/ & - ' IOSTAT =',I5/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & - ' NO DATA IN INPUT FILE'/) -! + ! + IOTST = -1 + FLBPI = .FALSE. + RETURN + ! + ! Formats + ! +900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC :'/ & + ' ILLEGAL INXOUT VALUE: ',A/) +901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC :'/ & + ' ILLEGAL IDSTRBC, READ : ',A/ & + ' CHECK : ',A/) +902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC :'/ & + ' ILLEGAL VEROGR, READ : ',A/ & + ' CHECK : ',A/) + ! +909 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC :'/ & + ' POINT',2I4,' NOT ACTIVE SEA POINT (',I1,')') +910 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC :'/ & + ' POINT',I4,2E14.6,' NOT LOCATED IN GRID') +911 FORMAT ( ' *** WAVEWATCH III WARNING : POINT',2I7, & + ' WILL NOT BE UPDATED') +920 FORMAT (/' *** SMCTYPE mapped boundary cells:'/ ((I8,2F9.3)) ) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & + ' ERROR IN OPENING FILE ',A/ & + ' IOSTAT =',I5/) + ! + ! Note: This 1001 error can occur when multi-grid time steps are not + ! compatible. +1001 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOBC : '/ & + ' INPUT FILE WITH BOUNDARY CONDITIONS NOT FOUND'/ & + ' BOUNDARY CONDITIONS WILL NOT BE UPDATED ',I5/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & + ' PREMATURE END OF FILE'/) +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & + ' ERROR IN READING FROM FILE'/ & + ' IOSTAT =',I5/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & + ' NO DATA IN INPUT FILE'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3IOBC : INXOUT : ',A5/ & - ' FLAGS : ',3L2/ & - ' UNIT : ',I4) - 9001 FORMAT (' TEST W3IOBC : OPENING FILE ',A,' (',I2,')') - 9002 FORMAT (' TEST W3IOBC : FILE # : ',I4/ & - ' UNIT : ',I4/ & - ' ID : ',A/ & - ' VERSION : ',A/ & - ' POINTS : ',I4) -#endif -! +9000 FORMAT (' TEST W3IOBC : INXOUT : ',A5/ & + ' FLAGS : ',3L2/ & + ' UNIT : ',I4) +9001 FORMAT (' TEST W3IOBC : OPENING FILE ',A,' (',I2,')') +9002 FORMAT (' TEST W3IOBC : FILE # : ',I4/ & + ' UNIT : ',I4/ & + ' ID : ',A/ & + ' VERSION : ',A/ & + ' POINTS : ',I4) +#endif + ! #ifdef W3_T0 - 9003 FORMAT (' TEST W3IOBC : POINT DATA ') - 9004 FORMAT (' ',I3,2E10.3,2X,4I4,2X,4F5.2) - 9005 FORMAT (' ',I3,I4,2E10.3,2X,4I4,2X,4F5.2) +9003 FORMAT (' TEST W3IOBC : POINT DATA ') +9004 FORMAT (' ',I3,2E10.3,2X,4I4,2X,4F5.2) +9005 FORMAT (' ',I3,I4,2E10.3,2X,4I4,2X,4F5.2) #endif -! + ! #ifdef W3_T - 9010 FORMAT (' TEST W3IOBC : OUTPUT FILE ',I1,' UNIT',I3,' TIME', & - I9.8,I7.6,',',I5,' SPECTRA') - 9011 FORMAT (' TEST W3IOBC : INPUT FILE UNIT',I3,' TIME', & - I9.8,I7.6,',',I5,' SPECTRA') - 9012 FORMAT (' TEST W3IOBC : INPUT FILE UNIT',I3,' TIME', & - I9.8,I7.6,',',I5,' SPECTRA (TEST READ)') -#endif -! -#ifdef W3_T - 9020 FORMAT (' TEST W3IOBC : SAVING OLD DATA') - 9021 FORMAT (' TEST W3IOBC : SAVING FIRST DATA') - 9022 FORMAT (' TEST W3IOBC : EOF REACHED') -#endif -! +9010 FORMAT (' TEST W3IOBC : OUTPUT FILE ',I1,' UNIT',I3,' TIME', & + I9.8,I7.6,',',I5,' SPECTRA') +9011 FORMAT (' TEST W3IOBC : INPUT FILE UNIT',I3,' TIME', & + I9.8,I7.6,',',I5,' SPECTRA') +9012 FORMAT (' TEST W3IOBC : INPUT FILE UNIT',I3,' TIME', & + I9.8,I7.6,',',I5,' SPECTRA (TEST READ)') + ! +9020 FORMAT (' TEST W3IOBC : SAVING OLD DATA') +9021 FORMAT (' TEST W3IOBC : SAVING FIRST DATA') +9022 FORMAT (' TEST W3IOBC : EOF REACHED') +#endif + ! #ifdef W3_T1 - 9040 FORMAT (' TEST W3IOBC : UNIT, ISOUT, ISEA, HS(NO TAIL) ') - 9041 FORMAT ( ' ',I3,2I6,F8.2) - 9042 FORMAT (' TEST W3IOBC : IP, HS(NO TAIL) ') - 9043 FORMAT ( ' ',I6,2F8.2) -#endif -!/ -!/ End of W3IOBC ----------------------------------------------------- / -!/ - END SUBROUTINE W3IOBC -!/ -!/ End of module W3IOBCMD -------------------------------------------- / -!/ - END MODULE W3IOBCMD +9040 FORMAT (' TEST W3IOBC : UNIT, ISOUT, ISEA, HS(NO TAIL) ') +9041 FORMAT ( ' ',I3,2I6,F8.2) +9042 FORMAT (' TEST W3IOBC : IP, HS(NO TAIL) ') +9043 FORMAT ( ' ',I6,2F8.2) +#endif + !/ + !/ End of W3IOBC ----------------------------------------------------- / + !/ + END SUBROUTINE W3IOBC + !/ + !/ End of module W3IOBCMD -------------------------------------------- / + !/ +END MODULE W3IOBCMD diff --git a/model/src/w3iogomd.F90 b/model/src/w3iogomd.F90 index e394f55da..f69ff030b 100644 --- a/model/src/w3iogomd.F90 +++ b/model/src/w3iogomd.F90 @@ -1,1770 +1,1770 @@ !> @file !> @brief Gridded output of mean wave parameters. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 -!> +!> #include "w3macros.h" !> !> @brief Gridded output of mean wave parameters. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 !> !/ ------------------------------------------------------------------- / - MODULE W3IOGOMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-2001 : Origination. ( version 2.00 ) -!/ 23-Apr-2002 : Clean up. ( version 2.19 ) -!/ 29-Apr-2002 : Add output parameters 17-18. ( version 2.20 ) -!/ 30-May-2002 : Switch clean up. ( version 2.21 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 25-Oct-2004 : Multiple grid version. ( version 3.06 ) -!/ 27-Jun-2005 : Adding MAPST2. ( version 3.07 ) -!/ 21-Jul-2005 : Adding output fields 19-21. ( version 3.07 ) -!/ 23-Apr-2006 : Filter for directional spread. ( version 3.09 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 02-Apr-2007 : Adding partitioned output. ( version 3.11 ) -!/ Adding user slots for outputs. -!/ 08-Oct-2007 : Adding ST3 source term option. ( version 3.13 ) -!/ ( F. Ardhuin ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 13-Sep-2009 : Add coupling option ( version 3.14 ) -!/ 10-Mar-2009 : Add second order pressure ( version 3.14 ) -!/ 15-Sep-2010 : Adding ST4 source term option. ( version 3.14 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 05-Feb-2011 : Implement unstructured grid ( version 3.14.3 ) -!/ (A. Roland and F. Ardhuin) -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 25-Dec-2012 : New output structure and smaller ( version 4.11 ) -!/ memory footprint. -!/ 15-Apr-2013 : New subroutine to read param. names ( version 4.11 ) -!/ 21-Aug-2013 : Bug correction in W3IOGO: UBR, ABR ( version 4.11 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 31-Jan-2014 : Bug fix warning output (Tolman). ( version 4.18 ) -!/ 10-Feb-2014 : Bug correction for US3D: div. by df ( version 4.18 ) -!/ 30-Apr-2014 : Add th2m and sth2m calculation ( version 5.01 ) -!/ 27-May-2014 : Switch to OMPG switch. ( version 5.02 ) -!/ 27-Aug-2015 : Add ICEF,ICEH as output fields ( version 5.10 ) -!/ 01-Mar-2018 : Removed RTD code (now used in post ( version 6.02 ) -!/ processing code) -!/ 05-Jun-2018 : Add DEBUGSTP/SETUP ( version 6.04 ) -!/ 22-Aug-2018 : Add WBT output parameter ( version 6.06 ) -!/ 25-Sep-2019 : Corrected th2m and sth2m ( version 6.07 ) -!/ calculations. (J Dykes, NRL) -!/ 04-Oct-2019 : Optional one file per output stride ( version 7.00 ) -!/ (Roberto Padilla-Hernandez & J.H. Alves) -!/ 03-Nov-2020 : Factored out NAME matching into ( version 7.12 ) -!/ seperate subroutine. (C. Bunney) -!/ 15-Jan-2021 : Added TP output based on exsiting ( version 7.12 ) -!/ FP internal field. (C. Bunney) -!/ 22-Mar-2021 : Add extra coupling fields as output ( version 7.13 ) -!/ 21-Jul-2022 : Correct FP0 calc for peak energy in ( version 7.14 ) -!/ min/max freq band (B. Pouliot, CMC) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Gridded output of mean wave parameters. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! VEROGR C*10 Private Gridded output file version number. -! IDSTR C*30 Private Gridded output file ID string. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3OUTG Subr. Public Calculate mean parameters. -! W3IOGO Subr. Public IO to raw gridded fields file. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETO Subr. W3ODATMD Point to data structure. -! W3SETG Subr. W3GDATMD Point to data structure. -! W3SETW Subr. W3WDATMD Point to data structure. -! W3SETA Subr. W3ADATMD Point to data structure. -! W3XETA Subr. W3ADATMD Point to data structure. -! W3DIMW Subr. W3WDATMD Allocate data structure. -! W3DIMA Subr. W3ADATMD Allocate data structure. -! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) -! EXTCDE Subr. W3SERVMD Program abort with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - The different output fields are not folded in with this module -! due to the different requirements for a element '0' in some of -! the fields. -! -! 6. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/OMPG OpenMP compiler directive for loop splitting. -! -! !/O8 Filter for low wave heights ( HSMIN ) -! !/O9 Negative wave height alowed, other mean parameters will -! not be correct. -! -! !/ST0 No source terms. -! !/ST1 Source term set 1 (WAM equiv.) -! !/ST2 Source term set 2 (Tolman and Chalikov) -! !/ST3 Source term set 3 (WAM 4+) -! !/ST4 Source term set 4 (Ardhuin et al. 2009, 2010) -! !/ST6 Source term set 6 (BYDRZ) -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / +MODULE W3IOGOMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-2001 : Origination. ( version 2.00 ) + !/ 23-Apr-2002 : Clean up. ( version 2.19 ) + !/ 29-Apr-2002 : Add output parameters 17-18. ( version 2.20 ) + !/ 30-May-2002 : Switch clean up. ( version 2.21 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 25-Oct-2004 : Multiple grid version. ( version 3.06 ) + !/ 27-Jun-2005 : Adding MAPST2. ( version 3.07 ) + !/ 21-Jul-2005 : Adding output fields 19-21. ( version 3.07 ) + !/ 23-Apr-2006 : Filter for directional spread. ( version 3.09 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 02-Apr-2007 : Adding partitioned output. ( version 3.11 ) + !/ Adding user slots for outputs. + !/ 08-Oct-2007 : Adding ST3 source term option. ( version 3.13 ) + !/ ( F. Ardhuin ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 13-Sep-2009 : Add coupling option ( version 3.14 ) + !/ 10-Mar-2009 : Add second order pressure ( version 3.14 ) + !/ 15-Sep-2010 : Adding ST4 source term option. ( version 3.14 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 05-Feb-2011 : Implement unstructured grid ( version 3.14.3 ) + !/ (A. Roland and F. Ardhuin) + !/ 12-Jun-2012 : Add /RTD option or rotated grid option. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 25-Dec-2012 : New output structure and smaller ( version 4.11 ) + !/ memory footprint. + !/ 15-Apr-2013 : New subroutine to read param. names ( version 4.11 ) + !/ 21-Aug-2013 : Bug correction in W3IOGO: UBR, ABR ( version 4.11 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 31-Jan-2014 : Bug fix warning output (Tolman). ( version 4.18 ) + !/ 10-Feb-2014 : Bug correction for US3D: div. by df ( version 4.18 ) + !/ 30-Apr-2014 : Add th2m and sth2m calculation ( version 5.01 ) + !/ 27-May-2014 : Switch to OMPG switch. ( version 5.02 ) + !/ 27-Aug-2015 : Add ICEF,ICEH as output fields ( version 5.10 ) + !/ 01-Mar-2018 : Removed RTD code (now used in post ( version 6.02 ) + !/ processing code) + !/ 05-Jun-2018 : Add DEBUGSTP/SETUP ( version 6.04 ) + !/ 22-Aug-2018 : Add WBT output parameter ( version 6.06 ) + !/ 25-Sep-2019 : Corrected th2m and sth2m ( version 6.07 ) + !/ calculations. (J Dykes, NRL) + !/ 04-Oct-2019 : Optional one file per output stride ( version 7.00 ) + !/ (Roberto Padilla-Hernandez & J.H. Alves) + !/ 03-Nov-2020 : Factored out NAME matching into ( version 7.12 ) + !/ seperate subroutine. (C. Bunney) + !/ 15-Jan-2021 : Added TP output based on exsiting ( version 7.12 ) + !/ FP internal field. (C. Bunney) + !/ 22-Mar-2021 : Add extra coupling fields as output ( version 7.13 ) + !/ 21-Jul-2022 : Correct FP0 calc for peak energy in ( version 7.14 ) + !/ min/max freq band (B. Pouliot, CMC) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Gridded output of mean wave parameters. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! VEROGR C*10 Private Gridded output file version number. + ! IDSTR C*30 Private Gridded output file ID string. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3OUTG Subr. Public Calculate mean parameters. + ! W3IOGO Subr. Public IO to raw gridded fields file. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETO Subr. W3ODATMD Point to data structure. + ! W3SETG Subr. W3GDATMD Point to data structure. + ! W3SETW Subr. W3WDATMD Point to data structure. + ! W3SETA Subr. W3ADATMD Point to data structure. + ! W3XETA Subr. W3ADATMD Point to data structure. + ! W3DIMW Subr. W3WDATMD Allocate data structure. + ! W3DIMA Subr. W3ADATMD Allocate data structure. + ! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) + ! EXTCDE Subr. W3SERVMD Program abort with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - The different output fields are not folded in with this module + ! due to the different requirements for a element '0' in some of + ! the fields. + ! + ! 6. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/OMPG OpenMP compiler directive for loop splitting. + ! + ! !/O8 Filter for low wave heights ( HSMIN ) + ! !/O9 Negative wave height alowed, other mean parameters will + ! not be correct. + ! + ! !/ST0 No source terms. + ! !/ST1 Source term set 1 (WAM equiv.) + ! !/ST2 Source term set 2 (Tolman and Chalikov) + ! !/ST3 Source term set 3 (WAM 4+) + ! !/ST4 Source term set 4 (Ardhuin et al. 2009, 2010) + ! !/ST6 Source term set 6 (BYDRZ) + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif - !module default - IMPLICIT NONE -!/ - PUBLIC - CHARACTER(LEN=1024) :: FLDOUT -!/ -!/ Private parameter statements (ID strings) -!/ - CHARACTER(LEN=10), PARAMETER, PRIVATE :: VEROGR = '2019-10-04' - CHARACTER(LEN=30), PARAMETER, PRIVATE :: & - IDSTR = 'WAVEWATCH III GRID OUTPUT FILE' -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Updates the flags for output parameters based on the mod_def file -!> this is to prevent the allocation of big 3D arrays when not requested. -!> -!> @param[in] NDSO Output file logical unit number. -!> @param[in] NDSEN Error output file logical unit number. -!> @param[inout] FLGRD 1D array of flags for groups. -!> @param[inout] FLGR2 1D array of flags for groups. -!> @param[inout] FLGD 2D array of flags. -!> @param[inout] FLG2 2D array of flags. -!> -!> @author F. Ardhuin @date 15-Apr-2013 -!> - SUBROUTINE W3FLGRDUPDT ( NDSO, NDSEN, FLGRD, FLGR2, FLGD, FLG2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-Apr-2013 | -!/ +-----------------------------------+ -!/ -!/ 15-Apr-2013 : Origination. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Updates the flags for output parameters based on the mod_def file -! this is to prevent the allocation of big 3D arrays when not requested -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSO Int. I Output file logical unit number -! NDSEN R.A. I Error output file logical unit number -! FLGD,FLG2 L.A. O 1D array of flags for groups -! FLGRD L.A. O 2D array of flags -! FLGR2 L.A. O 2D array of flags -! ---------------------------------------------------------------- -! -! -! 4. Subroutines used : -! -! None -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. N/A -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF - USE W3ODATMD, ONLY: NOGRP, NGRPP + !module default + IMPLICIT NONE + !/ + PUBLIC + CHARACTER(LEN=1024) :: FLDOUT + !/ + !/ Private parameter statements (ID strings) + !/ + CHARACTER(LEN=10), PARAMETER, PRIVATE :: VEROGR = '2019-10-04' + CHARACTER(LEN=30), PARAMETER, PRIVATE :: & + IDSTR = 'WAVEWATCH III GRID OUTPUT FILE' + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Updates the flags for output parameters based on the mod_def file + !> this is to prevent the allocation of big 3D arrays when not requested. + !> + !> @param[in] NDSO Output file logical unit number. + !> @param[in] NDSEN Error output file logical unit number. + !> @param[inout] FLGRD 1D array of flags for groups. + !> @param[inout] FLGR2 1D array of flags for groups. + !> @param[inout] FLGD 2D array of flags. + !> @param[inout] FLG2 2D array of flags. + !> + !> @author F. Ardhuin @date 15-Apr-2013 + !> + SUBROUTINE W3FLGRDUPDT ( NDSO, NDSEN, FLGRD, FLGR2, FLGD, FLG2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-Apr-2013 | + !/ +-----------------------------------+ + !/ + !/ 15-Apr-2013 : Origination. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Updates the flags for output parameters based on the mod_def file + ! this is to prevent the allocation of big 3D arrays when not requested + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSO Int. I Output file logical unit number + ! NDSEN R.A. I Error output file logical unit number + ! FLGD,FLG2 L.A. O 1D array of flags for groups + ! FLGRD L.A. O 2D array of flags + ! FLGR2 L.A. O 2D array of flags + ! ---------------------------------------------------------------- + ! + ! + ! 4. Subroutines used : + ! + ! None + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. N/A + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF + USE W3ODATMD, ONLY: NOGRP, NGRPP #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSO, NDSEN - LOGICAL, INTENT(INOUT) :: FLGRD(NOGRP,NGRPP), FLGD(NOGRP), & - FLGR2(NOGRP,NGRPP), FLG2(NOGRP) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I - CHARACTER(LEN=10) :: VARNAME1(5),VARNAME2(5) + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSO, NDSEN + LOGICAL, INTENT(INOUT) :: FLGRD(NOGRP,NGRPP), FLGD(NOGRP), & + FLGR2(NOGRP,NGRPP), FLG2(NOGRP) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I + CHARACTER(LEN=10) :: VARNAME1(5),VARNAME2(5) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3FLGRDUPDT') + CALL STRACE (IENT, 'W3FLGRDUPDT') #endif -! - VARNAME1(1) = 'EF'; VARNAME2(1) = 'E3D' - VARNAME1(2) = 'TH1M'; VARNAME2(2) = 'TH1MF' - VARNAME1(3) = 'STH1M'; VARNAME2(3) = 'STH1MF' - VARNAME1(4) = 'TH2M'; VARNAME2(4) = 'TH2MF' - VARNAME1(5) = 'STH2M'; VARNAME2(5) = 'STH2MF' + ! + VARNAME1(1) = 'EF'; VARNAME2(1) = 'E3D' + VARNAME1(2) = 'TH1M'; VARNAME2(2) = 'TH1MF' + VARNAME1(3) = 'STH1M'; VARNAME2(3) = 'STH1MF' + VARNAME1(4) = 'TH2M'; VARNAME2(4) = 'TH2MF' + VARNAME1(5) = 'STH2M'; VARNAME2(5) = 'STH2MF' - DO I=1,5 - IF (E3DF(1,I).LE.0.OR.E3DF(3,I).LT.E3DF(2,I)) THEN - IF (FLGRD(3,I).OR.FLGR2(3,I)) THEN - WRITE(NDSEN,1008) VARNAME1(I),VARNAME2(I) - END IF - FLGRD(3,I)=.FALSE. - FLGR2(3,I)=.FALSE. - END IF - END DO - IF (US3DF(1).LE.0.OR.US3DF(3).LT.US3DF(2)) THEN - IF (FLGRD(6,8).OR.FLGR2(6,8)) THEN - WRITE(NDSEN,1008) 'USF','US3D' + DO I=1,5 + IF (E3DF(1,I).LE.0.OR.E3DF(3,I).LT.E3DF(2,I)) THEN + IF (FLGRD(3,I).OR.FLGR2(3,I)) THEN + WRITE(NDSEN,1008) VARNAME1(I),VARNAME2(I) END IF - FLGRD(6,8)=.FALSE. - FLGR2(6,8)=.FALSE. + FLGRD(3,I)=.FALSE. + FLGR2(3,I)=.FALSE. END IF - IF (USSPF(1).LE.0.OR.USSPF(2).LE.0) THEN - IF (FLGRD(6,12).OR.FLGR2(6,12)) THEN - WRITE(NDSEN,1008) 'USP','USSP' - END IF - FLGRD(6,12)=.FALSE. - FLGR2(6,12)=.FALSE. + END DO + IF (US3DF(1).LE.0.OR.US3DF(3).LT.US3DF(2)) THEN + IF (FLGRD(6,8).OR.FLGR2(6,8)) THEN + WRITE(NDSEN,1008) 'USF','US3D' END IF - IF (P2MSF(1).LE.0.OR.P2MSF(3).LT.P2MSF(2)) THEN - IF (FLGRD(6,9).OR.FLGR2(6,9)) THEN - WRITE(NDSEN,1008) 'P2L','P2SF' - END IF - FLGRD(6,9)=.FALSE. - FLGR2(6,9)=.FALSE. + FLGRD(6,8)=.FALSE. + FLGR2(6,8)=.FALSE. + END IF + IF (USSPF(1).LE.0.OR.USSPF(2).LE.0) THEN + IF (FLGRD(6,12).OR.FLGR2(6,12)) THEN + WRITE(NDSEN,1008) 'USP','USSP' END IF -! - FLGD(3) = .FALSE. - FLG2(3) = .FALSE. - IF(ANY(FLGRD(3,:))) FLGD(3)=.TRUE. - IF(ANY(FLGR2(3,:))) FLG2(3)=.TRUE. - FLGD(6) = .FALSE. - FLG2(6) = .FALSE. - IF(ANY(FLGRD(6,:))) FLGD(6)=.TRUE. - IF(ANY(FLGR2(6,:))) FLG2(6)=.TRUE. -! - RETURN -! - 1008 FORMAT (/' *** WAVEWATCH III WARNING : '/ & - ' PARAMETER ',A,' not allowed: need to set', & - ' parameter ',A,' in OUTS namelist (in ww3_grid.inp)' & - ' with proper bounds' ) -! - END SUBROUTINE W3FLGRDUPDT -!/ ------------------------------------------------------------------- / -!> -!> @brief Fills in FLG1D and FLG2D arrays from ASCII input file. -!> -!> @param[in] NDSI Input file logical unit number. -!> @param[in] NDSO Output file logical unit number. -!> @param[in] NDSS Screen file logical unit number. -!> @param[in] NDSEN Error output file logical unit number. -!> @param[in] COMSTR Comment string, usually '$'. -!> @param[out] FLG1D 1D array of flags for groups. -!> @param[out] FLG2D 2D array of flags. -!> @param[in] IAPROC Index of current processor. -!> @param[in] NAPOUT Index of processor for output (screen). -!> @param[out] IERR Error message number. -!> -!> @author F. Ardhuin @date 25-Sep-2020 -!> - SUBROUTINE W3READFLGRD ( NDSI , NDSO, NDSS, NDSEN, COMSTR, & - FLG1D, FLG2D, IAPROC, NAPOUT, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 25-Sep-2020 | -!/ +-----------------------------------+ -!/ -!/ 15-Apr-2013 : Origination. ( version 4.10 ) -!/ 31-Jan-2014 : Bug fix warning output (Tolman). ( version 4.18 ) -!/ 30-Apr-2014 : Add th2m and sth2m calculation ( version 5.01 ) -!/ 25-Sep-2020 : Calculate FLG1D for any processor ( version 7.10 ) -!/ 03-Nov-2020 : Factored out NAME matching into ( version 7.12 ) -!/ seperate subroutine (C. Bunney) -!/ -! 1. Purpose : -! -! Fills in FLG1D and FLG2D arrays from ASCII input file -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. I Input file logical unit number -! NDSO Int. I Output file logical unit number -! NDSS Int. I Screen file logical unit number -! NDSEN R.A. I Error output file logical unit number -! COMSTR Char I Comment string, usually '$' -! FLG1D L.A. O 1D array of flags for groups -! FLG2D L.A. O 2D array of flags -! IAPROC Int. I index of current processor -! NAPOUT Int. I index of processor for output (screen) -! IERR Int. O Error message number -! ---------------------------------------------------------------- -! -! -! 4. Subroutines used : -! -! None -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_SHEL Prog. N/A Actual wave model program -! WW3_OUTF Prog. N/A Output postprocessor. -! WW3_OUNF Prog. N/A NetCDF output postprocessor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: US3DF, USSPF - USE W3ODATMD, ONLY: NOGRP, NGRPP, NOGE, IDOUT - USE W3SERVMD, ONLY: NEXTLN, STRSPLIT, STR_TO_UPPER + FLGRD(6,12)=.FALSE. + FLGR2(6,12)=.FALSE. + END IF + IF (P2MSF(1).LE.0.OR.P2MSF(3).LT.P2MSF(2)) THEN + IF (FLGRD(6,9).OR.FLGR2(6,9)) THEN + WRITE(NDSEN,1008) 'P2L','P2SF' + END IF + FLGRD(6,9)=.FALSE. + FLGR2(6,9)=.FALSE. + END IF + ! + FLGD(3) = .FALSE. + FLG2(3) = .FALSE. + IF(ANY(FLGRD(3,:))) FLGD(3)=.TRUE. + IF(ANY(FLGR2(3,:))) FLG2(3)=.TRUE. + FLGD(6) = .FALSE. + FLG2(6) = .FALSE. + IF(ANY(FLGRD(6,:))) FLGD(6)=.TRUE. + IF(ANY(FLGR2(6,:))) FLG2(6)=.TRUE. + ! + RETURN + ! +1008 FORMAT (/' *** WAVEWATCH III WARNING : '/ & + ' PARAMETER ',A,' not allowed: need to set', & + ' parameter ',A,' in OUTS namelist (in ww3_grid.inp)' & + ' with proper bounds' ) + ! + END SUBROUTINE W3FLGRDUPDT + !/ ------------------------------------------------------------------- / + !> + !> @brief Fills in FLG1D and FLG2D arrays from ASCII input file. + !> + !> @param[in] NDSI Input file logical unit number. + !> @param[in] NDSO Output file logical unit number. + !> @param[in] NDSS Screen file logical unit number. + !> @param[in] NDSEN Error output file logical unit number. + !> @param[in] COMSTR Comment string, usually '$'. + !> @param[out] FLG1D 1D array of flags for groups. + !> @param[out] FLG2D 2D array of flags. + !> @param[in] IAPROC Index of current processor. + !> @param[in] NAPOUT Index of processor for output (screen). + !> @param[out] IERR Error message number. + !> + !> @author F. Ardhuin @date 25-Sep-2020 + !> + SUBROUTINE W3READFLGRD ( NDSI , NDSO, NDSS, NDSEN, COMSTR, & + FLG1D, FLG2D, IAPROC, NAPOUT, IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 25-Sep-2020 | + !/ +-----------------------------------+ + !/ + !/ 15-Apr-2013 : Origination. ( version 4.10 ) + !/ 31-Jan-2014 : Bug fix warning output (Tolman). ( version 4.18 ) + !/ 30-Apr-2014 : Add th2m and sth2m calculation ( version 5.01 ) + !/ 25-Sep-2020 : Calculate FLG1D for any processor ( version 7.10 ) + !/ 03-Nov-2020 : Factored out NAME matching into ( version 7.12 ) + !/ seperate subroutine (C. Bunney) + !/ + ! 1. Purpose : + ! + ! Fills in FLG1D and FLG2D arrays from ASCII input file + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. I Input file logical unit number + ! NDSO Int. I Output file logical unit number + ! NDSS Int. I Screen file logical unit number + ! NDSEN R.A. I Error output file logical unit number + ! COMSTR Char I Comment string, usually '$' + ! FLG1D L.A. O 1D array of flags for groups + ! FLG2D L.A. O 2D array of flags + ! IAPROC Int. I index of current processor + ! NAPOUT Int. I index of processor for output (screen) + ! IERR Int. O Error message number + ! ---------------------------------------------------------------- + ! + ! + ! 4. Subroutines used : + ! + ! None + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_SHEL Prog. N/A Actual wave model program + ! WW3_OUTF Prog. N/A Output postprocessor. + ! WW3_OUNF Prog. N/A NetCDF output postprocessor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: US3DF, USSPF + USE W3ODATMD, ONLY: NOGRP, NGRPP, NOGE, IDOUT + USE W3SERVMD, ONLY: NEXTLN, STRSPLIT, STR_TO_UPPER #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSI, NDSO, NDSS, NDSEN, IAPROC, NAPOUT - INTEGER, INTENT(OUT) :: IERR - CHARACTER(LEN=1) :: COMSTR - LOGICAL, INTENT(OUT) :: FLG2D(NOGRP,NGRPP), FLG1D(NOGRP) - CHARACTER(LEN=100) :: OUT_NAMES(100), TESTSTR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IFI, IFJ, IOUT + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSI, NDSO, NDSS, NDSEN, IAPROC, NAPOUT + INTEGER, INTENT(OUT) :: IERR + CHARACTER(LEN=1) :: COMSTR + LOGICAL, INTENT(OUT) :: FLG2D(NOGRP,NGRPP), FLG1D(NOGRP) + CHARACTER(LEN=100) :: OUT_NAMES(100), TESTSTR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IFI, IFJ, IOUT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - CHARACTER(LEN=1) :: AFLG - LOGICAL :: FLT, NAMES -!/ -!/ ------------------------------------------------------------------- / -!/ + CHARACTER(LEN=1) :: AFLG + LOGICAL :: FLT, NAMES + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3READFLGRD') + CALL STRACE (IENT, 'W3READFLGRD') #endif -! -! -! 1. Initialize flags -------------------------------------- * -! - IERR=0 - FLG2D(:,:)=.FALSE. ! Initialize FLG2D - FLG1D(:)=.FALSE. ! Initialize FLOG - NAMES =.FALSE. -! - DO IFI=1,NOGRP ! Loop over field output groups -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=2001,ERR=2002) AFLG - IF (AFLG.EQ.'T') THEN - FLG1D(IFI)=.TRUE. - ELSE IF (AFLG.EQ.'F') THEN - FLG1D(IFI)=.FALSE. - ELSE IF (AFLG.EQ.'N') THEN - NAMES=.TRUE. - EXIT - ELSE - IERR=1 - GOTO 2005 - END IF - IF ( FLG1D (IFI) ) THEN ! Skip if group not requested - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,'(A)',END=2001,ERR=2006,IOSTAT=IERR) & - FLDOUT - OUT_NAMES(:)='' - CALL STRSPLIT(FLDOUT,OUT_NAMES) - IFJ=0 - DO WHILE (len_trim(OUT_NAMES(IFJ+1)).NE.0) - IFJ=IFJ+1 - IF ( OUT_NAMES(IFJ) .EQ. 'T' ) & - FLG2D(IFI,IFJ)=.TRUE. - ENDDO - IF ( IAPROC .EQ. NAPOUT .AND. IFJ .LT. NOGE(IFI) ) WRITE(NDSEN,1007) IFI - ENDIF - END DO -! - IF (NAMES) THEN -! -! 2. Reads and splits list of output field names -! + ! + ! + ! 1. Initialize flags -------------------------------------- * + ! + IERR=0 + FLG2D(:,:)=.FALSE. ! Initialize FLG2D + FLG1D(:)=.FALSE. ! Initialize FLOG + NAMES =.FALSE. + ! + DO IFI=1,NOGRP ! Loop over field output groups + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=2001,ERR=2002) AFLG + IF (AFLG.EQ.'T') THEN + FLG1D(IFI)=.TRUE. + ELSE IF (AFLG.EQ.'F') THEN + FLG1D(IFI)=.FALSE. + ELSE IF (AFLG.EQ.'N') THEN + NAMES=.TRUE. + EXIT + ELSE + IERR=1 + GOTO 2005 + END IF + IF ( FLG1D (IFI) ) THEN ! Skip if group not requested CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,'(A)',END=2001,ERR=2003,IOSTAT=IERR) FLDOUT + READ (NDSI,'(A)',END=2001,ERR=2006,IOSTAT=IERR) & + FLDOUT OUT_NAMES(:)='' CALL STRSPLIT(FLDOUT,OUT_NAMES) - IOUT=0 - DO WHILE (len_trim(OUT_NAMES(IOUT+1)).NE.0) - CALL STR_TO_UPPER(OUT_NAMES(IOUT+1)) -! -! 2. Matches names with expected ... -! - TESTSTR=OUT_NAMES(IOUT+1) - CALL W3FLDTOIJ(TESTSTR, IFI, IFJ, IAPROC, NAPOUT, NDSEN) - - IF(IFI .NE. -1) THEN - FLG2D(IFI, IFJ) = .TRUE. - ENDIF -! - IOUT=IOUT+1 -! - END DO -! - END IF -! - FLT = .TRUE. - DO IFI=1, NOGRP - IF ( IAPROC .EQ. NAPOUT ) THEN - DO IFJ=1, NGRPP - IF ( FLG2D(IFI,IFJ) ) THEN - IF ( FLT ) THEN - WRITE (NDSO,1945) IDOUT(IFI,IFJ) - FLT = .FALSE. - ELSE - WRITE (NDSO,1946) IDOUT(IFI,IFJ) - END IF - END IF - END DO - END IF - IF(ANY(FLG2D(IFI,:))) FLG1D(IFI)=.TRUE. !Update FLG1D - END DO - IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( FLT ) WRITE (NDSO,1945) 'no fields defined' - END IF -! - RETURN -! - 2001 CONTINUE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN,1001) - RETURN - 2002 CONTINUE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN, 1002) IFI, IERR - RETURN - 2003 CONTINUE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN, 1003) IERR - RETURN -!2004 CONTINUE ! replaced by warning in code .... - 2005 CONTINUE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN, 1005) AFLG - RETURN - 2006 CONTINUE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN, 1006) IFI,IERR - RETURN -! - 1945 FORMAT ( ' Fields : ',A) - 1946 FORMAT ( ' ',A) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR : '/ & - ' ERROR IN READING OUTPUT FIELDS GROUP FLAGS ', & - I2, /, ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR : '/ & - ' ERROR READING OUTPUT FIELD NAMES FROM INPUT FILE'/& - ' IOSTAT =',I5/) -! - 1005 FORMAT (/' *** WAVEWATCH III ERROR : '/ & - ' WAS EXPECTING "T" "F" or "N", but found "',A,'".'/) -! - 1006 FORMAT (/' *** WAVEWATCH III ERROR : '/ & - ' ERROR IN READING OUTPUT FIELDS FLAGS FOR GROUP ', & - I2, /, ' IOSTAT =',I5/) -! - 1007 FORMAT (/' *** WAVEWATCH III WARNING : '/ & - ' NUMBER OF REQUESTED OUTPUT FIELD FLAGS IN GROUP ',& - I2, /,' LESS THAN AVAILABLE, CHECK DOCS FOR MORE OPTIONS') -! - END SUBROUTINE W3READFLGRD - -!/ ------------------------------------------------------------------- / -!> -!> @brief Fills in FLG1D and FLG2D arrays from ASCII input file. -!> -!> @param[in] NDSO Output file logical unit number. -!> @param[in] NDSS Screen file logical unit number. -!> @param[in] NDSEN Error output file logical unit number. -!> @param[in] FLDOUT List of field names. -!> @param[out] FLG1D 1D array of flags for groups. -!> @param[out] FLG2D 2D array of flags. -!> @param[in] IAPROC Index of current processor. -!> @param[in] NAPOUT Index of processor for output (screen). -!> @param[out] IERR Error message number. -!> -!> @author F. Ardhuin @date 25-Sep-2020 -!> - SUBROUTINE W3FLGRDFLAG ( NDSO, NDSS, NDSEN, FLDOUT, & - FLG1D, FLG2D, IAPROC, NAPOUT, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 25-Sep-2020 | -!/ +-----------------------------------+ -!/ -!/ 15-Apr-2013 : Origination. ( version 4.10 ) -!/ 31-Jan-2014 : Bug fix warning output (Tolman). ( version 4.18 ) -!/ 30-Apr-2014 : Add th2m and sth2m calculation ( version 5.01 ) -!/ 17-Feb-2016 : New version for namelist use ( version 5.11 ) -!/ 25-Sep-2020 : Calculate FLG1D for any processor ( version 7.10 ) -!/ 03-Nov-2020 : Factored out NAME matching into ( version 7.12 ) -!/ seperate subroutine (C. Bunney) -!/ -! 1. Purpose : -! -! Fills in FLG1D and FLG2D arrays from ASCII input file -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSO Int. I Output file logical unit number -! NDSS Int. I Screen file logical unit number -! NDSEN R.A. I Error output file logical unit number -! FLDOUT Cha. I List of field names -! FLG1D L.A. O 1D array of flags for groups -! FLG2D L.A. O 2D array of flags -! IAPROC Int. I index of current processor -! NAPOUT Int. I index of processor for output (screen) -! IERR Int. O Error message number -! ---------------------------------------------------------------- -! -! -! 4. Subroutines used : -! -! None -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_SHEL Prog. N/A Actual wave model program -! WW3_OUTF Prog. N/A Output postprocessor. -! WW3_OUNF Prog. N/A NetCDF output postprocessor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3ODATMD, ONLY: NOGRP, NGRPP, IDOUT - USE W3SERVMD, ONLY: STRSPLIT, STR_TO_UPPER - USE W3GDATMD, ONLY: US3DF, USSPF -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSO, NDSS, NDSEN, IAPROC, NAPOUT - CHARACTER(1024), INTENT(IN) :: FLDOUT - INTEGER, INTENT(OUT) :: IERR - LOGICAL, INTENT(OUT) :: FLG2D(NOGRP,NGRPP), FLG1D(NOGRP) - CHARACTER(LEN=100) :: OUT_NAMES(100), TESTSTR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, IFI, IFJ, IOUT -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - LOGICAL :: FLT -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3FLGRDFLAG') -#endif -! -! -! 1. Initialize flags -------------------------------------- * -! - IERR=0 - FLG2D(:,:)=.FALSE. ! Initialize FLG2D - FLG1D(:)=.FALSE. ! Initialize FLOG -! -! 2. Splits list of output field names -! + IFJ=0 + DO WHILE (len_trim(OUT_NAMES(IFJ+1)).NE.0) + IFJ=IFJ+1 + IF ( OUT_NAMES(IFJ) .EQ. 'T' ) & + FLG2D(IFI,IFJ)=.TRUE. + ENDDO + IF ( IAPROC .EQ. NAPOUT .AND. IFJ .LT. NOGE(IFI) ) WRITE(NDSEN,1007) IFI + ENDIF + END DO + ! + IF (NAMES) THEN + ! + ! 2. Reads and splits list of output field names + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,'(A)',END=2001,ERR=2003,IOSTAT=IERR) FLDOUT OUT_NAMES(:)='' CALL STRSPLIT(FLDOUT,OUT_NAMES) IOUT=0 DO WHILE (len_trim(OUT_NAMES(IOUT+1)).NE.0) CALL STR_TO_UPPER(OUT_NAMES(IOUT+1)) -! -! 2. Matches names with expected ... -! + ! + ! 2. Matches names with expected ... + ! TESTSTR=OUT_NAMES(IOUT+1) CALL W3FLDTOIJ(TESTSTR, IFI, IFJ, IAPROC, NAPOUT, NDSEN) IF(IFI .NE. -1) THEN FLG2D(IFI, IFJ) = .TRUE. ENDIF -! + ! IOUT=IOUT+1 -! + ! END DO -! - FLT = .TRUE. - DO IFI=1, NOGRP - IF ( IAPROC .EQ. NAPOUT ) THEN - DO IFJ=1, NGRPP - IF ( FLG2D(IFI,IFJ) ) THEN - IF ( FLT ) THEN - WRITE (NDSO,1945) IDOUT(IFI,IFJ) - FLT = .FALSE. - ELSE - WRITE (NDSO,1946) IDOUT(IFI,IFJ) - END IF + ! + END IF + ! + FLT = .TRUE. + DO IFI=1, NOGRP + IF ( IAPROC .EQ. NAPOUT ) THEN + DO IFJ=1, NGRPP + IF ( FLG2D(IFI,IFJ) ) THEN + IF ( FLT ) THEN + WRITE (NDSO,1945) IDOUT(IFI,IFJ) + FLT = .FALSE. + ELSE + WRITE (NDSO,1946) IDOUT(IFI,IFJ) END IF - END DO - ENDIF - IF(ANY(FLG2D(IFI,:))) FLG1D(IFI)=.TRUE. !Update FLG1D - END DO + END IF + END DO + END IF + IF(ANY(FLG2D(IFI,:))) FLG1D(IFI)=.TRUE. !Update FLG1D + END DO + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( FLT ) WRITE (NDSO,1945) 'no fields defined' + END IF + ! + RETURN + ! +2001 CONTINUE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN,1001) + RETURN +2002 CONTINUE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN, 1002) IFI, IERR + RETURN +2003 CONTINUE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN, 1003) IERR + RETURN + !2004 CONTINUE ! replaced by warning in code .... +2005 CONTINUE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN, 1005) AFLG + RETURN +2006 CONTINUE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN, 1006) IFI,IERR + RETURN + ! +1945 FORMAT ( ' Fields : ',A) +1946 FORMAT ( ' ',A) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR : '/ & + ' ERROR IN READING OUTPUT FIELDS GROUP FLAGS ', & + I2, /, ' IOSTAT =',I5/) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR : '/ & + ' ERROR READING OUTPUT FIELD NAMES FROM INPUT FILE'/& + ' IOSTAT =',I5/) + ! +1005 FORMAT (/' *** WAVEWATCH III ERROR : '/ & + ' WAS EXPECTING "T" "F" or "N", but found "',A,'".'/) + ! +1006 FORMAT (/' *** WAVEWATCH III ERROR : '/ & + ' ERROR IN READING OUTPUT FIELDS FLAGS FOR GROUP ', & + I2, /, ' IOSTAT =',I5/) + ! +1007 FORMAT (/' *** WAVEWATCH III WARNING : '/ & + ' NUMBER OF REQUESTED OUTPUT FIELD FLAGS IN GROUP ',& + I2, /,' LESS THAN AVAILABLE, CHECK DOCS FOR MORE OPTIONS') + ! + END SUBROUTINE W3READFLGRD + + !/ ------------------------------------------------------------------- / + !> + !> @brief Fills in FLG1D and FLG2D arrays from ASCII input file. + !> + !> @param[in] NDSO Output file logical unit number. + !> @param[in] NDSS Screen file logical unit number. + !> @param[in] NDSEN Error output file logical unit number. + !> @param[in] FLDOUT List of field names. + !> @param[out] FLG1D 1D array of flags for groups. + !> @param[out] FLG2D 2D array of flags. + !> @param[in] IAPROC Index of current processor. + !> @param[in] NAPOUT Index of processor for output (screen). + !> @param[out] IERR Error message number. + !> + !> @author F. Ardhuin @date 25-Sep-2020 + !> + SUBROUTINE W3FLGRDFLAG ( NDSO, NDSS, NDSEN, FLDOUT, & + FLG1D, FLG2D, IAPROC, NAPOUT, IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 25-Sep-2020 | + !/ +-----------------------------------+ + !/ + !/ 15-Apr-2013 : Origination. ( version 4.10 ) + !/ 31-Jan-2014 : Bug fix warning output (Tolman). ( version 4.18 ) + !/ 30-Apr-2014 : Add th2m and sth2m calculation ( version 5.01 ) + !/ 17-Feb-2016 : New version for namelist use ( version 5.11 ) + !/ 25-Sep-2020 : Calculate FLG1D for any processor ( version 7.10 ) + !/ 03-Nov-2020 : Factored out NAME matching into ( version 7.12 ) + !/ seperate subroutine (C. Bunney) + !/ + ! 1. Purpose : + ! + ! Fills in FLG1D and FLG2D arrays from ASCII input file + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSO Int. I Output file logical unit number + ! NDSS Int. I Screen file logical unit number + ! NDSEN R.A. I Error output file logical unit number + ! FLDOUT Cha. I List of field names + ! FLG1D L.A. O 1D array of flags for groups + ! FLG2D L.A. O 2D array of flags + ! IAPROC Int. I index of current processor + ! NAPOUT Int. I index of processor for output (screen) + ! IERR Int. O Error message number + ! ---------------------------------------------------------------- + ! + ! + ! 4. Subroutines used : + ! + ! None + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_SHEL Prog. N/A Actual wave model program + ! WW3_OUTF Prog. N/A Output postprocessor. + ! WW3_OUNF Prog. N/A NetCDF output postprocessor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3ODATMD, ONLY: NOGRP, NGRPP, IDOUT + USE W3SERVMD, ONLY: STRSPLIT, STR_TO_UPPER + USE W3GDATMD, ONLY: US3DF, USSPF +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSO, NDSS, NDSEN, IAPROC, NAPOUT + CHARACTER(1024), INTENT(IN) :: FLDOUT + INTEGER, INTENT(OUT) :: IERR + LOGICAL, INTENT(OUT) :: FLG2D(NOGRP,NGRPP), FLG1D(NOGRP) + CHARACTER(LEN=100) :: OUT_NAMES(100), TESTSTR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, IFI, IFJ, IOUT +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + LOGICAL :: FLT + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'W3FLGRDFLAG') +#endif + ! + ! + ! 1. Initialize flags -------------------------------------- * + ! + IERR=0 + FLG2D(:,:)=.FALSE. ! Initialize FLG2D + FLG1D(:)=.FALSE. ! Initialize FLOG + ! + ! 2. Splits list of output field names + ! + OUT_NAMES(:)='' + CALL STRSPLIT(FLDOUT,OUT_NAMES) + IOUT=0 + DO WHILE (len_trim(OUT_NAMES(IOUT+1)).NE.0) + CALL STR_TO_UPPER(OUT_NAMES(IOUT+1)) + ! + ! 2. Matches names with expected ... + ! + TESTSTR=OUT_NAMES(IOUT+1) + CALL W3FLDTOIJ(TESTSTR, IFI, IFJ, IAPROC, NAPOUT, NDSEN) + + IF(IFI .NE. -1) THEN + FLG2D(IFI, IFJ) = .TRUE. + ENDIF + ! + IOUT=IOUT+1 + ! + END DO + ! + FLT = .TRUE. + DO IFI=1, NOGRP IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( FLT ) WRITE (NDSO,1945) 'no fields defined' + DO IFJ=1, NGRPP + IF ( FLG2D(IFI,IFJ) ) THEN + IF ( FLT ) THEN + WRITE (NDSO,1945) IDOUT(IFI,IFJ) + FLT = .FALSE. + ELSE + WRITE (NDSO,1946) IDOUT(IFI,IFJ) + END IF + END IF + END DO ENDIF -! - RETURN -! - 1945 FORMAT ( ' Fields : ',A) - 1946 FORMAT ( ' ',A) -! -! 1004 FORMAT (/' *** WAVEWATCH III WARNING : '/ & -! ' REQUESTED OUTPUT FIELD ',A,' WAS NOT RECOGNIZED.'/) -!! -! 1008 FORMAT (/' *** WAVEWATCH III WARNING : '/ & -! ' PARAMETER ',A,' not allowed: need to set', & -! ' parameter ',A,' in OUTS namelist (in ww3_grid.inp)') -! - END SUBROUTINE W3FLGRDFLAG + IF(ANY(FLG2D(IFI,:))) FLG1D(IFI)=.TRUE. !Update FLG1D + END DO + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( FLT ) WRITE (NDSO,1945) 'no fields defined' + ENDIF + ! + RETURN + ! +1945 FORMAT ( ' Fields : ',A) +1946 FORMAT ( ' ',A) + ! + ! 1004 FORMAT (/' *** WAVEWATCH III WARNING : '/ & + ! ' REQUESTED OUTPUT FIELD ',A,' WAS NOT RECOGNIZED.'/) + !! + ! 1008 FORMAT (/' *** WAVEWATCH III WARNING : '/ & + ! ' PARAMETER ',A,' not allowed: need to set', & + ! ' parameter ',A,' in OUTS namelist (in ww3_grid.inp)') + ! + END SUBROUTINE W3FLGRDFLAG -!/ ------------------------------------------------------------------- / -!> -!> @brief Returns the group/field (I/J) indices for a named output field. -!> -!> @param[in] FLD Field names. -!> @param[out] I Output group number (IFI). -!> @param[out] J Output field number (IFJ). -!> @param[in] IAPROC Index of current processor. -!> @param[in] NAPOUT Index of processor for output (screen). -!> @param[in] NDSEN Error output file logical unit number. -!> -!> @author C. Bunney @date 22-Mar-2021 -!> - SUBROUTINE W3FLDTOIJ(FLD, I, J, IAPROC, NAPOUT, NDSEN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 03-Nov-2020 : Origination. ( version 7.12 ) -!/ 22-Mar-2021 : Add extra coupling fields as output ( version 7.13 ) -! -! 1. Purpose : -! -! Returns the group/field (I/J) indices for a named output field. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FLD Cha. I Field names -! I Int. O Output group number (IFI) -! J Int. O Output field number (IFJ) -! IAPROC Int. I index of current processor -! NAPOUT Int. I index of processor for output (screen) -! NDSEN R.A. I Error output file logical unit number -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: US3DF, USSPF -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER(LEN=*), INTENT(IN) :: FLD - INTEGER, INTENT(IN) :: IAPROC, NAPOUT, NDSEN - INTEGER, INTENT(OUT) :: I, J + !/ ------------------------------------------------------------------- / + !> + !> @brief Returns the group/field (I/J) indices for a named output field. + !> + !> @param[in] FLD Field names. + !> @param[out] I Output group number (IFI). + !> @param[out] J Output field number (IFJ). + !> @param[in] IAPROC Index of current processor. + !> @param[in] NAPOUT Index of processor for output (screen). + !> @param[in] NDSEN Error output file logical unit number. + !> + !> @author C. Bunney @date 22-Mar-2021 + !> + SUBROUTINE W3FLDTOIJ(FLD, I, J, IAPROC, NAPOUT, NDSEN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 03-Nov-2020 : Origination. ( version 7.12 ) + !/ 22-Mar-2021 : Add extra coupling fields as output ( version 7.13 ) + ! + ! 1. Purpose : + ! + ! Returns the group/field (I/J) indices for a named output field. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FLD Cha. I Field names + ! I Int. O Output group number (IFI) + ! J Int. O Output field number (IFJ) + ! IAPROC Int. I index of current processor + ! NAPOUT Int. I index of processor for output (screen) + ! NDSEN R.A. I Error output file logical unit number + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: US3DF, USSPF + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER(LEN=*), INTENT(IN) :: FLD + INTEGER, INTENT(IN) :: IAPROC, NAPOUT, NDSEN + INTEGER, INTENT(OUT) :: I, J - I = -1 - J = -1 + I = -1 + J = -1 - SELECT CASE(TRIM(FLD(1:6))) -! -! Group 1 -! - CASE('DPT') - I = 1 - J = 1 - CASE('CUR') - I = 1 - J = 2 - CASE('WND') - I = 1 - J = 3 - CASE('AST') - I = 1 - J = 4 - CASE('WLV') - I = 1 - J = 5 - CASE('ICE') - I = 1 - J = 6 - CASE('IBG') - I = 1 - J = 7 - CASE('TAU') - I = 1 - J = 8 - CASE('RHO') - I = 1 - J = 9 + SELECT CASE(TRIM(FLD(1:6))) + ! + ! Group 1 + ! + CASE('DPT') + I = 1 + J = 1 + CASE('CUR') + I = 1 + J = 2 + CASE('WND') + I = 1 + J = 3 + CASE('AST') + I = 1 + J = 4 + CASE('WLV') + I = 1 + J = 5 + CASE('ICE') + I = 1 + J = 6 + CASE('IBG') + I = 1 + J = 7 + CASE('TAU') + I = 1 + J = 8 + CASE('RHO') + I = 1 + J = 9 #ifdef W3_BT4 - CASE('D50') - I = 1 - J = 10 + CASE('D50') + I = 1 + J = 10 #endif #ifdef W3_IS2 - CASE('IC1') - I = 1 - J = 11 - CASE('IC5') - I = 1 - J = 12 + CASE('IC1') + I = 1 + J = 11 + CASE('IC5') + I = 1 + J = 12 #endif -! Group 2 -! + ! Group 2 + ! #ifdef W3_OASACM - CASE('AHS') - I = 2 - J = 1 + CASE('AHS') + I = 2 + J = 1 #endif #ifdef W3_OASOCM - CASE('OHS') - I = 2 - J = 1 + CASE('OHS') + I = 2 + J = 1 #endif - CASE('HS') - I = 2 - J = 1 - CASE('LM') - I = 2 - J = 2 - CASE('T02') - I = 2 - J = 3 - CASE('T0M1') - I = 2 - J = 4 - CASE('T01') - I = 2 - J = 5 - CASE('FP') - I = 2 - J = 6 - CASE('DIR') - I = 2 - J = 7 - CASE('SPR') - I = 2 - J = 8 - CASE('DP') - I = 2 - J = 9 - CASE('HIG') - I = 2 - J = 10 - CASE('MXE') - I = 2 - J = 11 - CASE('MXES') - I = 2 - J = 12 - CASE('MXH') - I = 2 - J = 13 - CASE('MXHC') - I = 2 - J = 14 - CASE('SDMH') - I = 2 - J = 15 - CASE('SDMHC') - I = 2 - J = 16 - CASE('WBT') - I = 2 - J = 17 - CASE('TP') ! Uses FP0 internally, as per FP - I = 2 - J = 18 - CASE('WNM') - I = 2 - J = 19 + CASE('HS') + I = 2 + J = 1 + CASE('LM') + I = 2 + J = 2 + CASE('T02') + I = 2 + J = 3 + CASE('T0M1') + I = 2 + J = 4 + CASE('T01') + I = 2 + J = 5 + CASE('FP') + I = 2 + J = 6 + CASE('DIR') + I = 2 + J = 7 + CASE('SPR') + I = 2 + J = 8 + CASE('DP') + I = 2 + J = 9 + CASE('HIG') + I = 2 + J = 10 + CASE('MXE') + I = 2 + J = 11 + CASE('MXES') + I = 2 + J = 12 + CASE('MXH') + I = 2 + J = 13 + CASE('MXHC') + I = 2 + J = 14 + CASE('SDMH') + I = 2 + J = 15 + CASE('SDMHC') + I = 2 + J = 16 + CASE('WBT') + I = 2 + J = 17 + CASE('TP') ! Uses FP0 internally, as per FP + I = 2 + J = 18 + CASE('WNM') + I = 2 + J = 19 #ifdef W3_OASOCM - CASE('THM') - I = 2 - J = 20 + CASE('THM') + I = 2 + J = 20 #endif -! -! Group 3 -! - CASE('EF') - I = 3 - J = 1 - CASE('TH1M') - I = 3 - J = 2 - CASE('STH1M') - I = 3 - J = 3 - CASE('TH2M') - I = 3 - J = 4 - CASE('STH2M') - I = 3 - J = 5 - CASE('WN') - I = 3 - J = 6 -! -! Group 4 -! - CASE('PHS') - I = 4 - J = 1 - CASE('PTP') - I = 4 - J = 2 - CASE('PLP') - I = 4 - J = 3 - CASE('PDIR') - I = 4 - J = 4 - CASE('PSPR') - I = 4 - J = 5 - CASE('PWS') - I = 4 - J = 6 - CASE('PDP') - I = 4 - J = 7 - CASE('PQP') - I = 4 - J = 8 - CASE('PPE') - I = 4 - J = 9 - CASE('PGW') - I = 4 - J = 10 - CASE('PSW') - I = 4 - J = 11 - CASE('PTM10') - I = 4 - J = 12 - CASE('PT01') - I = 4 - J = 13 - CASE('PT02') - I = 4 - J = 14 - CASE('PEP') - I = 4 - J = 15 - CASE('TWS') - I = 4 - J = 16 - CASE('PNR') - I = 4 - J = 17 -! -! Group 5 -! - CASE('UST') - I = 5 - J = 1 + ! + ! Group 3 + ! + CASE('EF') + I = 3 + J = 1 + CASE('TH1M') + I = 3 + J = 2 + CASE('STH1M') + I = 3 + J = 3 + CASE('TH2M') + I = 3 + J = 4 + CASE('STH2M') + I = 3 + J = 5 + CASE('WN') + I = 3 + J = 6 + ! + ! Group 4 + ! + CASE('PHS') + I = 4 + J = 1 + CASE('PTP') + I = 4 + J = 2 + CASE('PLP') + I = 4 + J = 3 + CASE('PDIR') + I = 4 + J = 4 + CASE('PSPR') + I = 4 + J = 5 + CASE('PWS') + I = 4 + J = 6 + CASE('PDP') + I = 4 + J = 7 + CASE('PQP') + I = 4 + J = 8 + CASE('PPE') + I = 4 + J = 9 + CASE('PGW') + I = 4 + J = 10 + CASE('PSW') + I = 4 + J = 11 + CASE('PTM10') + I = 4 + J = 12 + CASE('PT01') + I = 4 + J = 13 + CASE('PT02') + I = 4 + J = 14 + CASE('PEP') + I = 4 + J = 15 + CASE('TWS') + I = 4 + J = 16 + CASE('PNR') + I = 4 + J = 17 + ! + ! Group 5 + ! + CASE('UST') + I = 5 + J = 1 #ifdef W3_OASACM - CASE('ACHA') - I = 5 - J = 2 + CASE('ACHA') + I = 5 + J = 2 #endif #ifdef W3_OASOCM - CASE('OCHA') - I = 5 - J = 2 + CASE('OCHA') + I = 5 + J = 2 #endif - CASE('CHA') - I = 5 - J = 2 - CASE('CGE') - I = 5 - J = 3 - CASE('FAW') - I = 5 - J = 4 - CASE('TAW') - I = 5 - J = 5 - CASE('TWA') - I = 5 - J = 6 - CASE('WCC') - I = 5 - J = 7 - CASE('WCF') - I = 5 - J = 8 - CASE('WCH') - I = 5 - J = 9 - CASE('WCM') - I = 5 - J = 10 - CASE('FWS') - I = 5 - J = 11 -! -! Group 6 -! - CASE('SXY') - I = 6 - J = 1 - CASE('TWO') - I = 6 - J = 2 - CASE('BHD') + CASE('CHA') + I = 5 + J = 2 + CASE('CGE') + I = 5 + J = 3 + CASE('FAW') + I = 5 + J = 4 + CASE('TAW') + I = 5 + J = 5 + CASE('TWA') + I = 5 + J = 6 + CASE('WCC') + I = 5 + J = 7 + CASE('WCF') + I = 5 + J = 8 + CASE('WCH') + I = 5 + J = 9 + CASE('WCM') + I = 5 + J = 10 + CASE('FWS') + I = 5 + J = 11 + ! + ! Group 6 + ! + CASE('SXY') + I = 6 + J = 1 + CASE('TWO') + I = 6 + J = 2 + CASE('BHD') + I = 6 + J = 3 + CASE('FOC') + I = 6 + J = 4 + CASE('TUS') + I = 6 + J = 5 + CASE('USS') + I = 6 + J = 6 + CASE('P2S') + I = 6 + J = 7 + CASE('USF') + IF (US3DF(1).GE.1) THEN I = 6 - J = 3 - CASE('FOC') - I = 6 - J = 4 - CASE('TUS') - I = 6 - J = 5 - CASE('USS') - I = 6 - J = 6 - CASE('P2S') - I = 6 - J = 7 - CASE('USF') - IF (US3DF(1).GE.1) THEN - I = 6 - J = 8 - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSEN,1008) 'USF','US3D' - END IF - CASE('P2L') - I = 6 - J = 9 - CASE('TWI') - I = 6 - J = 10 - CASE('FIC') - I = 6 - J = 11 - CASE('USP') - IF (USSPF(1).GE.1) THEN - I = 6 - J = 12 - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSEN,1008) 'USP','USSP' - END IF - CASE('TOC') + J = 8 + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSEN,1008) 'USF','US3D' + END IF + CASE('P2L') + I = 6 + J = 9 + CASE('TWI') + I = 6 + J = 10 + CASE('FIC') + I = 6 + J = 11 + CASE('USP') + IF (USSPF(1).GE.1) THEN I = 6 - J = 13 -! -! Group 7 -! - CASE('ABR') - I = 7 - J = 1 - CASE('UBR') - I = 7 - J = 2 - CASE('BED') - I = 7 - J = 3 - CASE('FBB') - I = 7 - J = 4 - CASE('TBB') - I = 7 - J = 5 -! -! Group 8 -! - CASE('MSS') - I = 8 - J = 1 - CASE('MSC') - I = 8 - J = 2 - CASE('MSD') - I = 8 - J = 3 - CASE('MCD') - I = 8 - J = 4 - CASE('QP') - I = 8 - J = 5 -! -! Group 9 -! - CASE('DTD') - I = 9 - J = 1 - CASE('FC') - I = 9 - J = 2 - CASE('CFX') - I = 9 - J = 3 - CASE('CFD') - I = 9 - J = 4 - CASE('CFK') - I = 9 - J = 5 -! -! Group 10 -! - CASE('U1') - I = 10 - J = 1 - CASE('U2') - I = 10 - J = 1 -! Not found: + J = 12 + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSEN,1008) 'USP','USSP' + END IF + CASE('TOC') + I = 6 + J = 13 + ! + ! Group 7 + ! + CASE('ABR') + I = 7 + J = 1 + CASE('UBR') + I = 7 + J = 2 + CASE('BED') + I = 7 + J = 3 + CASE('FBB') + I = 7 + J = 4 + CASE('TBB') + I = 7 + J = 5 + ! + ! Group 8 + ! + CASE('MSS') + I = 8 + J = 1 + CASE('MSC') + I = 8 + J = 2 + CASE('MSD') + I = 8 + J = 3 + CASE('MCD') + I = 8 + J = 4 + CASE('QP') + I = 8 + J = 5 + ! + ! Group 9 + ! + CASE('DTD') + I = 9 + J = 1 + CASE('FC') + I = 9 + J = 2 + CASE('CFX') + I = 9 + J = 3 + CASE('CFD') + I = 9 + J = 4 + CASE('CFK') + I = 9 + J = 5 + ! + ! Group 10 + ! + CASE('U1') + I = 10 + J = 1 + CASE('U2') + I = 10 + J = 1 + ! Not found: #ifdef W3_COU - CASE('DRY') + CASE('DRY') #endif - CASE('UNSET') - CASE DEFAULT - I = -1 - J = -1 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN,1004) TRIM(FLD) - END SELECT + CASE('UNSET') + CASE DEFAULT + I = -1 + J = -1 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSEN,1004) TRIM(FLD) + END SELECT - 1004 FORMAT (/' *** WAVEWATCH III WARNING : '/ & - ' REQUESTED OUTPUT FIELD ',A,' WAS NOT RECOGNIZED.'/) -! - 1008 FORMAT (/' *** WAVEWATCH III WARNING : '/ & - ' PARAMETER ',A,' not allowed: need to set', & - ' parameter ',A,' in OUTS namelist (in ww3_grid.inp)') -! - END SUBROUTINE W3FLDTOIJ +1004 FORMAT (/' *** WAVEWATCH III WARNING : '/ & + ' REQUESTED OUTPUT FIELD ',A,' WAS NOT RECOGNIZED.'/) + ! +1008 FORMAT (/' *** WAVEWATCH III WARNING : '/ & + ' PARAMETER ',A,' not allowed: need to set', & + ' parameter ',A,' in OUTS namelist (in ww3_grid.inp)') + ! + END SUBROUTINE W3FLDTOIJ -!/ ------------------------------------------------------------------- / -!> -!> @brief Fill necessary arrays with gridded data for output. -!> -!> @param[in] A Input spectra, left in par list to changeshape. -!> @param[in] FLPART Flag for filling fields with partition data. -!> @param[in] FLOUTG Flag for file field output. -!> @param[in] FLOUTG2 Flag for coupling field output. -!> -!> @author H. L. Tolman @date 10-Apr-2015 -!> - SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Apr-2015 | -!/ +-----------------------------------+ -!/ -!/ 10-Dec-1998 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 04-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 19-Oct-2004 : Multiple grid version. ( version 3.06 ) -!/ 21-Jul-2005 : Adding output fields 19-21. ( version 3.07 ) -!/ 23-Apr-2006 : Filter for directional spread. ( version 3.09 ) -!/ 02-Apr-2007 : Adding partitioned output. ( version 3.11 ) -!/ Adding user slots for outputs. -!/ 08-Oct-2007 : Adding ST3 source term option. ( version 3.13 ) -!/ ( F. Ardhuin ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 25-Dec-2012 : New output structure and smaller ( version 4.11 ) -!/ memory footprint. -!/ 10-Feb-2014 : Bug correction for US3D: div. by df ( version 4.18 ) -!/ 30-Apr-2014 : Add th2m and sth2m calculation ( version 5.01 ) -!/ 27-May-2014 : Switch to OMPG switch. ( version 5.02 ) -!/ 10-Apr-2015 : Remove unused variables ( version 5.08 ) -!/ 10-Jan-2017 : Separate Stokes drift calculation ( version 6.01 ) -!/ 01-Mar-2018 : Removed RTD code (now used in post ( version 6.02 ) -!/ processing code) -!/ 22-Aug-2018 : Add WBT parameter ( version 6.06 ) -!/ 25-Sep-2019 : Corrected th2m and sth2m ( version 6.07 ) -!/ calculations. (J Dykes, NRL) -!/ -! 1. Purpose : -! -! Fill necessary arrays with gridded data for output. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Input spectra. Left in par list to change -! shape. -! FLPART Log. I Flag for filling fields with part. data. -! FLOUTG Log. I Flag for file field output -! FLOUTG2 Log. I Flag for coupling field output -! ---------------------------------------------------------------- -! -! Locally saved parameters -! ---------------------------------------------------------------- -! HSMIN Real Filter level in Hs for calculation of mean -! wave parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/OMPG OpenMP compiler directive for loop splitting. -! -! !/O8 Filter for low wave heights ( HSMIN ) -! !/O9 Negative wave height alowed, other mean parameters will -! not be correct. -! -! !/ST0 No source terms. -! !/ST1 Source term set 1 (WAM equiv.) -! !/ST2 Source term set 2 (Tolman and Chalikov) -! !/ST3 Source term set 3 (WAM 4+) -! !/ST6 Source term set 6 (BYDRZ) -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD - USE W3WDATMD, ONLY: UST, FPIS - USE W3ADATMD, ONLY: CG, WN, DW - USE W3ADATMD, ONLY: HS, WLM, T02, T0M1, T01, FP0, & - THM, THS, THP0 - USE W3ADATMD, ONLY: ABA, ABD, UBA, UBD, FCUT, SXX, & - SYY, SXY, PHS, PTP, PLP, PDIR, PSI, PWS, & - PWST, PNR, USERO, TUSX, TUSY, PRMS, TPMS, & - USSX, USSY, MSSX, MSSY, MSSD, MSCX, MSCY, & - MSCD, CHARN, & - BHD, CGE, P2SMS, US3D, EF, TH1M, STH1M, & - TH2M, STH2M, HSIG, STMAXE, STMAXD, & - HCMAXE, HMAXE, HCMAXD, HMAXD, USSP, QP, PQP,& - PTHP0, PPE, PGW, PSW, PTM1, PT1, PT2, PEP, & - WBT - USE W3ODATMD, ONLY: NDST, UNDEF, IAPROC, NAPROC, NAPFLD, & - ICPRT, DTPRT, WSCUT, NOSWLL, FLOGRD, FLOGR2,& - NOGRP, NGRPP - USE W3ADATMD, ONLY: NSEALM + !/ ------------------------------------------------------------------- / + !> + !> @brief Fill necessary arrays with gridded data for output. + !> + !> @param[in] A Input spectra, left in par list to changeshape. + !> @param[in] FLPART Flag for filling fields with partition data. + !> @param[in] FLOUTG Flag for file field output. + !> @param[in] FLOUTG2 Flag for coupling field output. + !> + !> @author H. L. Tolman @date 10-Apr-2015 + !> + SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Apr-2015 | + !/ +-----------------------------------+ + !/ + !/ 10-Dec-1998 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 04-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 19-Oct-2004 : Multiple grid version. ( version 3.06 ) + !/ 21-Jul-2005 : Adding output fields 19-21. ( version 3.07 ) + !/ 23-Apr-2006 : Filter for directional spread. ( version 3.09 ) + !/ 02-Apr-2007 : Adding partitioned output. ( version 3.11 ) + !/ Adding user slots for outputs. + !/ 08-Oct-2007 : Adding ST3 source term option. ( version 3.13 ) + !/ ( F. Ardhuin ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 25-Dec-2012 : New output structure and smaller ( version 4.11 ) + !/ memory footprint. + !/ 10-Feb-2014 : Bug correction for US3D: div. by df ( version 4.18 ) + !/ 30-Apr-2014 : Add th2m and sth2m calculation ( version 5.01 ) + !/ 27-May-2014 : Switch to OMPG switch. ( version 5.02 ) + !/ 10-Apr-2015 : Remove unused variables ( version 5.08 ) + !/ 10-Jan-2017 : Separate Stokes drift calculation ( version 6.01 ) + !/ 01-Mar-2018 : Removed RTD code (now used in post ( version 6.02 ) + !/ processing code) + !/ 22-Aug-2018 : Add WBT parameter ( version 6.06 ) + !/ 25-Sep-2019 : Corrected th2m and sth2m ( version 6.07 ) + !/ calculations. (J Dykes, NRL) + !/ + ! 1. Purpose : + ! + ! Fill necessary arrays with gridded data for output. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Input spectra. Left in par list to change + ! shape. + ! FLPART Log. I Flag for filling fields with part. data. + ! FLOUTG Log. I Flag for file field output + ! FLOUTG2 Log. I Flag for coupling field output + ! ---------------------------------------------------------------- + ! + ! Locally saved parameters + ! ---------------------------------------------------------------- + ! HSMIN Real Filter level in Hs for calculation of mean + ! wave parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/OMPG OpenMP compiler directive for loop splitting. + ! + ! !/O8 Filter for low wave heights ( HSMIN ) + ! !/O9 Negative wave height alowed, other mean parameters will + ! not be correct. + ! + ! !/ST0 No source terms. + ! !/ST1 Source term set 1 (WAM equiv.) + ! !/ST2 Source term set 2 (Tolman and Chalikov) + ! !/ST3 Source term set 3 (WAM 4+) + ! !/ST6 Source term set 6 (BYDRZ) + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD + USE W3WDATMD, ONLY: UST, FPIS + USE W3ADATMD, ONLY: CG, WN, DW + USE W3ADATMD, ONLY: HS, WLM, T02, T0M1, T01, FP0, & + THM, THS, THP0 + USE W3ADATMD, ONLY: ABA, ABD, UBA, UBD, FCUT, SXX, & + SYY, SXY, PHS, PTP, PLP, PDIR, PSI, PWS, & + PWST, PNR, USERO, TUSX, TUSY, PRMS, TPMS, & + USSX, USSY, MSSX, MSSY, MSSD, MSCX, MSCY, & + MSCD, CHARN, & + BHD, CGE, P2SMS, US3D, EF, TH1M, STH1M, & + TH2M, STH2M, HSIG, STMAXE, STMAXD, & + HCMAXE, HMAXE, HCMAXD, HMAXD, USSP, QP, PQP,& + PTHP0, PPE, PGW, PSW, PTM1, PT1, PT2, PEP, & + WBT + USE W3ODATMD, ONLY: NDST, UNDEF, IAPROC, NAPROC, NAPFLD, & + ICPRT, DTPRT, WSCUT, NOSWLL, FLOGRD, FLOGR2,& + NOGRP, NGRPP + USE W3ADATMD, ONLY: NSEALM #ifdef W3_CESMCOUPLED - ! USSX, USSY : surface Stokes drift (SD) - ! USSXH, USSYH : surface layer (SL) averaged SD - ! LANGMT : La_t - ! LAPROJ : La_{Proj} - ! LASL : La_{SL} - ! LASLPJ : La_{SL,Proj} - ! ALPHAL : angle between wind and Langmuir cells (SL averaged) - ! ALPHALS : angle between wind and Langmuir cells (surface) - ! UD : wind direction - ! LAMULT : enhancement factor - ! HML : mixing layer depth (from coupler) - USE W3ADATMD, ONLY: LAMULT, USSXH, USSYH, LANGMT, LAPROJ, & - ALPHAL, ALPHALS, LASL, UD, LASLPJ - USE W3IDATMD, ONLY: HML - USE W3WDATMD, ONLY: ASF + ! USSX, USSY : surface Stokes drift (SD) + ! USSXH, USSYH : surface layer (SL) averaged SD + ! LANGMT : La_t + ! LAPROJ : La_{Proj} + ! LASL : La_{SL} + ! LASLPJ : La_{SL,Proj} + ! ALPHAL : angle between wind and Langmuir cells (SL averaged) + ! ALPHALS : angle between wind and Langmuir cells (surface) + ! UD : wind direction + ! LAMULT : enhancement factor + ! HML : mixing layer depth (from coupler) + USE W3ADATMD, ONLY: LAMULT, USSXH, USSYH, LANGMT, LAPROJ, & + ALPHAL, ALPHALS, LASL, UD, LASLPJ + USE W3IDATMD, ONLY: HML + USE W3WDATMD, ONLY: ASF #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE W3PARALL, ONLY : INIT_GET_ISEA -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK,0:NSEAL) - LOGICAL, INTENT(IN) :: FLPART, FLOUTG, FLOUTG2 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IK, ITH, JSEA, ISEA, IX, IY, & - IKP0(NSEAL), NKH(NSEAL), & - I, J, LKMS, HKMS, ITL + ! + USE W3PARALL, ONLY : INIT_GET_ISEA + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK,0:NSEAL) + LOGICAL, INTENT(IN) :: FLPART, FLOUTG, FLOUTG2 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IK, ITH, JSEA, ISEA, IX, IY, & + IKP0(NSEAL), NKH(NSEAL), & + I, J, LKMS, HKMS, ITL #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: FXPMC, FACTOR, FACTOR2, EBAND, FKD, & - AABS, UABS, & - XL, XH, XL2, XH2, EL, EH, DENOM, KD, & - M1, M2, MA, MB, MC, STEX, STEY, STED - REAL :: ET(NSEAL), EWN(NSEAL), ETR(NSEAL), & - ETX(NSEAL), ETY(NSEAL), AB(NSEAL), & - ETXX(NSEAL), ETYY(NSEAL), ETXY(NSEAL),& - ABX(NSEAL), ABY(NSEAL),ET02(NSEAL), & - EBD(NK,NSEAL), EC(NSEAL), & - ABR(NSEAL), UBR(NSEAL), UBS(NSEAL), & - ABX2(NSEAL), ABY2(NSEAL), & - AB2X(NSEAL), AB2Y(NSEAL), & - ABST(NSEAL), ABXX(NSEAL), & - ABYY(NSEAL), ABXY(NSEAL), & - ABYX(NSEAL), EET1(NSEAL), & - ETUSCX(NSEAL), ETUSCY(NSEAL), & - ETMSSL(NSEAL), ETMSSCL(NSEAL), & - ETTPMM(NSEAL), ETF(NSEAL), & - ET1(NSEAL), ABX2M(NSEAL), & - ABY2M(NSEAL), ABXM(NSEAL), & - ABYM(NSEAL), ABXYM(NSEAL), & - MSSXM(NSEAL), MSSYM(NSEAL), & - MSSXTM(NSEAL), MSSYTM(NSEAL), & - MSSXYM(NSEAL), THMP(NSEAL), & - T02P(NSEAL), NV(NSEAL), NS(NSEAL), & - NB(NSEAL), MODE(NSEAL), & - MU(NSEAL), NI(NSEAL), STMAXEL(NSEAL),& - PHI(21,NSEAL),PHIST(NSEAL), & - EBC(NK,NSEAL), ABP(NSEAL), & - STMAXDL(NSEAL), TLPHI(NSEAL), & - WL02X(NSEAL), WL02Y(NSEAL), & - ALPXT(NSEAL), ALPYT(NSEAL), & - ALPXY(NSEAL), SCREST(NSEAL) - REAL USSCO, FT1 - REAL, SAVE :: HSMIN = 0.01 - LOGICAL :: FLOLOC(NOGRP,NGRPP) + REAL :: FXPMC, FACTOR, FACTOR2, EBAND, FKD, & + AABS, UABS, & + XL, XH, XL2, XH2, EL, EH, DENOM, KD, & + M1, M2, MA, MB, MC, STEX, STEY, STED + REAL :: ET(NSEAL), EWN(NSEAL), ETR(NSEAL), & + ETX(NSEAL), ETY(NSEAL), AB(NSEAL), & + ETXX(NSEAL), ETYY(NSEAL), ETXY(NSEAL),& + ABX(NSEAL), ABY(NSEAL),ET02(NSEAL), & + EBD(NK,NSEAL), EC(NSEAL), & + ABR(NSEAL), UBR(NSEAL), UBS(NSEAL), & + ABX2(NSEAL), ABY2(NSEAL), & + AB2X(NSEAL), AB2Y(NSEAL), & + ABST(NSEAL), ABXX(NSEAL), & + ABYY(NSEAL), ABXY(NSEAL), & + ABYX(NSEAL), EET1(NSEAL), & + ETUSCX(NSEAL), ETUSCY(NSEAL), & + ETMSSL(NSEAL), ETMSSCL(NSEAL), & + ETTPMM(NSEAL), ETF(NSEAL), & + ET1(NSEAL), ABX2M(NSEAL), & + ABY2M(NSEAL), ABXM(NSEAL), & + ABYM(NSEAL), ABXYM(NSEAL), & + MSSXM(NSEAL), MSSYM(NSEAL), & + MSSXTM(NSEAL), MSSYTM(NSEAL), & + MSSXYM(NSEAL), THMP(NSEAL), & + T02P(NSEAL), NV(NSEAL), NS(NSEAL), & + NB(NSEAL), MODE(NSEAL), & + MU(NSEAL), NI(NSEAL), STMAXEL(NSEAL),& + PHI(21,NSEAL),PHIST(NSEAL), & + EBC(NK,NSEAL), ABP(NSEAL), & + STMAXDL(NSEAL), TLPHI(NSEAL), & + WL02X(NSEAL), WL02Y(NSEAL), & + ALPXT(NSEAL), ALPYT(NSEAL), & + ALPXY(NSEAL), SCREST(NSEAL) + REAL USSCO, FT1 + REAL, SAVE :: HSMIN = 0.01 + LOGICAL :: FLOLOC(NOGRP,NGRPP) #ifdef W3_CESMCOUPLED - ! SWW: angle between wind and waves - ! HSL: surface layer depth (=0.2*HML) - REAL :: SWW !angle between wind and waves - REAL :: HSL !surface layer depth (=0.2*HML) - ! tmp variables for surface and SL averaged SD - REAL :: ETUSSX(NSEAL), & - ETUSSY(NSEAL), & - ETUSSXH(NSEAL), & - ETUSSYH(NSEAL) + ! SWW: angle between wind and waves + ! HSL: surface layer depth (=0.2*HML) + REAL :: SWW !angle between wind and waves + REAL :: HSL !surface layer depth (=0.2*HML) + ! tmp variables for surface and SL averaged SD + REAL :: ETUSSX(NSEAL), & + ETUSSY(NSEAL), & + ETUSSXH(NSEAL), & + ETUSSYH(NSEAL) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3OUTG') + CALL STRACE (IENT, 'W3OUTG') #endif - DO I=1,NOGRP - DO J=1,NGRPP - FLOLOC(I,J) = & + DO I=1,NOGRP + DO J=1,NGRPP + FLOLOC(I,J) = & ((FLOUTG.AND.FLOGRD(I,J)).OR.(FLOUTG2.AND.FLOGR2(I,J))) - END DO - END DO -! - FXPMC = 0.66 * GRAV / 28. - HSMIN = HSMIN - FT1 = 0.3333 * SIG(NK)**2 * DTH * SIG(NK) -! -! 1. Initialize storage arrays -------------------------------------- * -! - ET = 0. - ET02 = 0. - EWN = 0. - ETR = 0. - ET1 = 0. - EET1 = 0. - ETX = 0. - ETY = 0. - ETXX = 0. - ETYY = 0. - ETXY = 0. - ABR = 0. - ABA = 0. - ABD = 0. - UBR = 0. - UBA = 0. - UBD = 0. - UBS = 0. - SXX = 0. - SYY = 0. - SXY = 0. - USSX = 0. - USSY = 0. - TUSX = 0. - TUSY = 0. - MSSX = 0. - MSSY = 0. - MSSD = 0. - MSCX = 0. - MSCY = 0. - MSCD = 0. - PRMS = 0. - TPMS = 0. - ETUSCY = 0. - ETUSCY = 0. - ETMSSL = 0. - ETMSSCL= 0. - ETTPMM = 0. - EBD = 0. - EC = 0. - ETF = 0. - EBC = 0. - BHD = 0. - MSSXM = 0. - MSSYM = 0. - MSSXTM = 0. - MSSYTM = 0. - MSSXYM = 0. - PHI = 0. - PHIST = 0. - TLPHI = 0. - STMAXEL = 0. - STMAXDL = 0. -! - HS = UNDEF - WLM = UNDEF - T0M1 = UNDEF - T01 = UNDEF - T02 = UNDEF - FP0 = UNDEF - THM = UNDEF - THS = UNDEF - THP0 = UNDEF - HSIG = UNDEF - WL02X = UNDEF - WL02Y = UNDEF - ALPXY = UNDEF - ALPXT = UNDEF - ALPYT = UNDEF - THMP = UNDEF - T02P = UNDEF - SCREST = UNDEF - NV = UNDEF - NS = UNDEF - NB = UNDEF - MU = UNDEF - NI = UNDEF - MODE = UNDEF - STMAXE = UNDEF - STMAXD = UNDEF - HCMAXE = UNDEF - HMAXE = UNDEF - HCMAXD = UNDEF - HMAXD = UNDEF - QP = UNDEF - WBT = UNDEF -! + END DO + END DO + ! + FXPMC = 0.66 * GRAV / 28. + HSMIN = HSMIN + FT1 = 0.3333 * SIG(NK)**2 * DTH * SIG(NK) + ! + ! 1. Initialize storage arrays -------------------------------------- * + ! + ET = 0. + ET02 = 0. + EWN = 0. + ETR = 0. + ET1 = 0. + EET1 = 0. + ETX = 0. + ETY = 0. + ETXX = 0. + ETYY = 0. + ETXY = 0. + ABR = 0. + ABA = 0. + ABD = 0. + UBR = 0. + UBA = 0. + UBD = 0. + UBS = 0. + SXX = 0. + SYY = 0. + SXY = 0. + USSX = 0. + USSY = 0. + TUSX = 0. + TUSY = 0. + MSSX = 0. + MSSY = 0. + MSSD = 0. + MSCX = 0. + MSCY = 0. + MSCD = 0. + PRMS = 0. + TPMS = 0. + ETUSCY = 0. + ETUSCY = 0. + ETMSSL = 0. + ETMSSCL= 0. + ETTPMM = 0. + EBD = 0. + EC = 0. + ETF = 0. + EBC = 0. + BHD = 0. + MSSXM = 0. + MSSYM = 0. + MSSXTM = 0. + MSSYTM = 0. + MSSXYM = 0. + PHI = 0. + PHIST = 0. + TLPHI = 0. + STMAXEL = 0. + STMAXDL = 0. + ! + HS = UNDEF + WLM = UNDEF + T0M1 = UNDEF + T01 = UNDEF + T02 = UNDEF + FP0 = UNDEF + THM = UNDEF + THS = UNDEF + THP0 = UNDEF + HSIG = UNDEF + WL02X = UNDEF + WL02Y = UNDEF + ALPXY = UNDEF + ALPXT = UNDEF + ALPYT = UNDEF + THMP = UNDEF + T02P = UNDEF + SCREST = UNDEF + NV = UNDEF + NS = UNDEF + NB = UNDEF + MU = UNDEF + NI = UNDEF + MODE = UNDEF + STMAXE = UNDEF + STMAXD = UNDEF + HCMAXE = UNDEF + HMAXE = UNDEF + HCMAXD = UNDEF + HMAXD = UNDEF + QP = UNDEF + WBT = UNDEF + ! #ifdef W3_CESMCOUPLED - ETUSSX = 0. - ETUSSY = 0. - ETUSCX = 0. - ETUSCY = 0. - ETUSSXH = 0. - ETUSSYH = 0 - LANGMT = UNDEF - LAPROJ = UNDEF - LASL = UNDEF - LASLPJ = UNDEF - ALPHAL = UNDEF - ALPHALS = UNDEF - USSX = 0. - USSY = 0. - USSXH = 0. - USSYH = 0. - LAMULT = 1. + ETUSSX = 0. + ETUSSY = 0. + ETUSCX = 0. + ETUSCY = 0. + ETUSSXH = 0. + ETUSSYH = 0 + LANGMT = UNDEF + LAPROJ = UNDEF + LASL = UNDEF + LASLPJ = UNDEF + ALPHAL = UNDEF + ALPHALS = UNDEF + USSX = 0. + USSY = 0. + USSXH = 0. + USSYH = 0. + LAMULT = 1. #endif -! -! 2. Integral over discrete part of spectrum ------------------------ * -! - DO IK=1, NK -! -! 2.a Initialize energy in band -! - AB = 0. - ABX = 0. - ABY = 0. - ABX2 = 0. - ABY2 = 0. - AB2X = 0. - AB2Y = 0. - ABXX = 0. - ABYY = 0. - ABXY = 0. - ABYX = 0. - ABST = 0. -! -! 2.b Integrate energy in band -! - DO ITH=1, NTH -! + ! + ! 2. Integral over discrete part of spectrum ------------------------ * + ! + DO IK=1, NK + ! + ! 2.a Initialize energy in band + ! + AB = 0. + ABX = 0. + ABY = 0. + ABX2 = 0. + ABY2 = 0. + AB2X = 0. + AB2Y = 0. + ABXX = 0. + ABYY = 0. + ABXY = 0. + ABYX = 0. + ABST = 0. + ! + ! 2.b Integrate energy in band + ! + DO ITH=1, NTH + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR) + !$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR) #endif -! - DO JSEA=1, NSEAL - NKH(JSEA) = MIN ( NK , & - INT(FACTI2+FACTI1*LOG(MAX(1.E-7,FCUT(JSEA)))) ) - AB (JSEA) = AB (JSEA) + A(ITH,IK,JSEA) - ABX(JSEA) = ABX(JSEA) + A(ITH,IK,JSEA)*ECOS(ITH) - ABY(JSEA) = ABY(JSEA) + A(ITH,IK,JSEA)*ESIN(ITH) -! These are the integrals with cos^2 and sin^2 - ABX2(JSEA) = ABX2(JSEA) + A(ITH,IK,JSEA)*EC2(ITH) - ABY2(JSEA) = ABY2(JSEA) + A(ITH,IK,JSEA)*ES2(ITH) -! Using trig identities to represent cos2theta and sin2theta. - AB2X(JSEA) = AB2X(JSEA) + A(ITH,IK,JSEA)*(2*EC2(ITH) - 1) - AB2Y(JSEA) = AB2Y(JSEA) + A(ITH,IK,JSEA)*(2*ESC(ITH)) - ABYX(JSEA) = ABYX(JSEA) + A(ITH,IK,JSEA)*ESC(ITH) - IF (ITH.LE.NTH/2) THEN - ABST(JSEA) = ABST(JSEA) + & - A(ITH,IK,JSEA)*A(ITH+NTH/2,IK,JSEA) - END IF - CALL INIT_GET_ISEA(ISEA, JSEA) - FACTOR = MAX ( 0.5 , CG(IK,ISEA)/SIG(IK)*WN(IK,ISEA) ) - ABXX(JSEA) = ABXX(JSEA) + ((1.+EC2(ITH))*FACTOR-0.5) * & - A(ITH,IK,JSEA) - ABYY(JSEA) = ABYY(JSEA) + ((1.+ES2(ITH))*FACTOR-0.5) * & - A(ITH,IK,JSEA) - ABXY(JSEA) = ABXY(JSEA) + ESC(ITH)*FACTOR * A(ITH,IK,JSEA) - END DO -! + ! + DO JSEA=1, NSEAL + NKH(JSEA) = MIN ( NK , & + INT(FACTI2+FACTI1*LOG(MAX(1.E-7,FCUT(JSEA)))) ) + AB (JSEA) = AB (JSEA) + A(ITH,IK,JSEA) + ABX(JSEA) = ABX(JSEA) + A(ITH,IK,JSEA)*ECOS(ITH) + ABY(JSEA) = ABY(JSEA) + A(ITH,IK,JSEA)*ESIN(ITH) + ! These are the integrals with cos^2 and sin^2 + ABX2(JSEA) = ABX2(JSEA) + A(ITH,IK,JSEA)*EC2(ITH) + ABY2(JSEA) = ABY2(JSEA) + A(ITH,IK,JSEA)*ES2(ITH) + ! Using trig identities to represent cos2theta and sin2theta. + AB2X(JSEA) = AB2X(JSEA) + A(ITH,IK,JSEA)*(2*EC2(ITH) - 1) + AB2Y(JSEA) = AB2Y(JSEA) + A(ITH,IK,JSEA)*(2*ESC(ITH)) + ABYX(JSEA) = ABYX(JSEA) + A(ITH,IK,JSEA)*ESC(ITH) + IF (ITH.LE.NTH/2) THEN + ABST(JSEA) = ABST(JSEA) + & + A(ITH,IK,JSEA)*A(ITH+NTH/2,IK,JSEA) + END IF + CALL INIT_GET_ISEA(ISEA, JSEA) + FACTOR = MAX ( 0.5 , CG(IK,ISEA)/SIG(IK)*WN(IK,ISEA) ) + ABXX(JSEA) = ABXX(JSEA) + ((1.+EC2(ITH))*FACTOR-0.5) * & + A(ITH,IK,JSEA) + ABYY(JSEA) = ABYY(JSEA) + ((1.+ES2(ITH))*FACTOR-0.5) * & + A(ITH,IK,JSEA) + ABXY(JSEA) = ABXY(JSEA) + ESC(ITH)*FACTOR * A(ITH,IK,JSEA) + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - END DO -! -! 2.c Finalize integration over band and update mean arrays -! -! + ! + END DO + ! + ! 2.c Finalize integration over band and update mean arrays + ! + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR,FACTOR2,MA,MC,MB,KD,FKD,USSCO,M1,M2) + !$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR,FACTOR2,MA,MC,MB,KD,FKD,USSCO,M1,M2) #endif -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - FACTOR = DDEN(IK) / CG(IK,ISEA) - EBD(IK,JSEA) = AB(JSEA) * FACTOR - ET (JSEA) = ET (JSEA) + EBD(IK,JSEA) + ! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + FACTOR = DDEN(IK) / CG(IK,ISEA) + EBD(IK,JSEA) = AB(JSEA) * FACTOR + ET (JSEA) = ET (JSEA) + EBD(IK,JSEA) #ifdef W3_IG1 - IF (IK.EQ.NINT(IGPARS(5))) HSIG(JSEA) = 4*SQRT(ET(JSEA)) + IF (IK.EQ.NINT(IGPARS(5))) HSIG(JSEA) = 4*SQRT(ET(JSEA)) #endif - ETF(JSEA) = ETF(JSEA) + EBD(IK,JSEA) * CG(IK,ISEA) - EWN(JSEA) = EWN(JSEA) + EBD(IK,JSEA) / WN(IK,ISEA) - ETR(JSEA) = ETR(JSEA) + EBD(IK,JSEA) / SIG(IK) - ET1(JSEA) = ET1(JSEA) + EBD(IK,JSEA) * SIG(IK) - EET1(JSEA) = EET1(JSEA)+ EBD(IK,JSEA)**2 * SIG(IK) - ET02(JSEA) = ET02(JSEA)+ EBD(IK,JSEA) * SIG(IK)**2 - ETX(JSEA) = ETX(JSEA) + ABX(JSEA) * FACTOR - ETY(JSEA) = ETY(JSEA) + ABY(JSEA) * FACTOR - TUSX(JSEA) = TUSX(JSEA) + ABX(JSEA)*FACTOR & - *GRAV*WN(IK,ISEA)/SIG(IK) - TUSY(JSEA) = TUSY(JSEA) + ABY(JSEA)*FACTOR & - *GRAV*WN(IK,ISEA)/SIG(IK) - ETXX(JSEA) = ETXX(JSEA) + ABX2(JSEA) * FACTOR* WN(IK,ISEA)**2 - ETYY(JSEA) = ETYY(JSEA) + ABY2(JSEA) * FACTOR* WN(IK,ISEA)**2 - ETXY(JSEA) = ETXY(JSEA) + ABYX(JSEA) * FACTOR* WN(IK,ISEA)**2 - IF (SIG(IK)*0.5*(1+XFR).LT.0.4*TPI) THEN - ETMSSL(JSEA) = ETMSSL(JSEA) + AB(JSEA)*FACTOR & - *WN(IK,ISEA)**2 - ELSE - IF (SIG(MAX(IK-1,1))*0.5*(1+XFR).LT.0.4*TPI) THEN - ETMSSL(JSEA) = ETMSSL(JSEA) + AB(JSEA)*FACTOR & - *(SIG(IK)*0.5*(1+1/XFR)-(0.4*TPI))/DSII(IK) & - *WN(IK,ISEA)**2 - FACTOR2 = SIG(IK)**5/(GRAV**2)/DSII(IK) - ETMSSCL(JSEA) = AB(JSEA)*FACTOR*FACTOR2 - END IF - END IF -! - UBS(JSEA) = UBS(JSEA) + AB(JSEA) * SIG(IK)**2 -! -! 2nd order equivalent surface pressure spectral density at K=0 -! this is used for microseismic or microbarom sources -! Finite water depth corrections (Ardhuin & Herbers 2013) are not -! included here. -! - FACTOR2 = DTH*2/(TPI**2) & - * SIG(IK) & - * (TPI*SIG(IK)/CG(IK,ISEA))**2 & ! Jacobian^2 to get E(f,th) from A(k,th) - * ABST(JSEA) -! -! Integration over seismic radian frequency : *2*dsigma -! - PRMS(JSEA) = PRMS(JSEA) + FACTOR2 * 2 * DSII(IK) - IF ( FLOLOC (6, 9).AND.(IK.GE.P2MSF(2).AND.IK.LE.P2MSF(3))) & - P2SMS(JSEA,IK) = FACTOR2 * 2 * TPI - IF (FACTOR2 .GT. ETTPMM(JSEA)) THEN - ETTPMM(JSEA) = FACTOR2 - TPMS(JSEA) = TPI/SIG(IK) - END IF + ETF(JSEA) = ETF(JSEA) + EBD(IK,JSEA) * CG(IK,ISEA) + EWN(JSEA) = EWN(JSEA) + EBD(IK,JSEA) / WN(IK,ISEA) + ETR(JSEA) = ETR(JSEA) + EBD(IK,JSEA) / SIG(IK) + ET1(JSEA) = ET1(JSEA) + EBD(IK,JSEA) * SIG(IK) + EET1(JSEA) = EET1(JSEA)+ EBD(IK,JSEA)**2 * SIG(IK) + ET02(JSEA) = ET02(JSEA)+ EBD(IK,JSEA) * SIG(IK)**2 + ETX(JSEA) = ETX(JSEA) + ABX(JSEA) * FACTOR + ETY(JSEA) = ETY(JSEA) + ABY(JSEA) * FACTOR + TUSX(JSEA) = TUSX(JSEA) + ABX(JSEA)*FACTOR & + *GRAV*WN(IK,ISEA)/SIG(IK) + TUSY(JSEA) = TUSY(JSEA) + ABY(JSEA)*FACTOR & + *GRAV*WN(IK,ISEA)/SIG(IK) + ETXX(JSEA) = ETXX(JSEA) + ABX2(JSEA) * FACTOR* WN(IK,ISEA)**2 + ETYY(JSEA) = ETYY(JSEA) + ABY2(JSEA) * FACTOR* WN(IK,ISEA)**2 + ETXY(JSEA) = ETXY(JSEA) + ABYX(JSEA) * FACTOR* WN(IK,ISEA)**2 + IF (SIG(IK)*0.5*(1+XFR).LT.0.4*TPI) THEN + ETMSSL(JSEA) = ETMSSL(JSEA) + AB(JSEA)*FACTOR & + *WN(IK,ISEA)**2 + ELSE + IF (SIG(MAX(IK-1,1))*0.5*(1+XFR).LT.0.4*TPI) THEN + ETMSSL(JSEA) = ETMSSL(JSEA) + AB(JSEA)*FACTOR & + *(SIG(IK)*0.5*(1+1/XFR)-(0.4*TPI))/DSII(IK) & + *WN(IK,ISEA)**2 + FACTOR2 = SIG(IK)**5/(GRAV**2)/DSII(IK) + ETMSSCL(JSEA) = AB(JSEA)*FACTOR*FACTOR2 + END IF + END IF + ! + UBS(JSEA) = UBS(JSEA) + AB(JSEA) * SIG(IK)**2 + ! + ! 2nd order equivalent surface pressure spectral density at K=0 + ! this is used for microseismic or microbarom sources + ! Finite water depth corrections (Ardhuin & Herbers 2013) are not + ! included here. + ! + FACTOR2 = DTH*2/(TPI**2) & + * SIG(IK) & + * (TPI*SIG(IK)/CG(IK,ISEA))**2 & ! Jacobian^2 to get E(f,th) from A(k,th) + * ABST(JSEA) + ! + ! Integration over seismic radian frequency : *2*dsigma + ! + PRMS(JSEA) = PRMS(JSEA) + FACTOR2 * 2 * DSII(IK) + IF ( FLOLOC (6, 9).AND.(IK.GE.P2MSF(2).AND.IK.LE.P2MSF(3))) & + P2SMS(JSEA,IK) = FACTOR2 * 2 * TPI + IF (FACTOR2 .GT. ETTPMM(JSEA)) THEN + ETTPMM(JSEA) = FACTOR2 + TPMS(JSEA) = TPI/SIG(IK) + END IF #ifdef W3_CESMCOUPLED -! Get surface layer depth - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - HSL = HML(IX,IY)/5. ! depth over which SD is averaged + ! Get surface layer depth + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + HSL = HML(IX,IY)/5. ! depth over which SD is averaged #endif -! -! Directional moments in the last freq. band -! - IF (IK.EQ.NK) THEN - FACTOR2 = SIG(IK)**5/(GRAV**2)/DSII(IK) - ETUSCX(JSEA) = ABX(JSEA)*FACTOR*FACTOR2 - ETUSCY(JSEA) = ABY(JSEA)*FACTOR*FACTOR2 -! -! NB: the slope PDF is proportional to ell1=ETYY*EC2-2*ETXY*ECS+ETYY*ES2 = A*EC2-2*B*ECS+C*ES2 -! This is an ellipse equation with axis direction given by dir=0.5*ATAN2(-2.*ETXY,ETYY-ETXX) -! - MA = ABX2(JSEA) * FACTOR * FACTOR2 - MC = ABY2(JSEA) * FACTOR * FACTOR2 - MB = ABYX(JSEA) * FACTOR * FACTOR2 -! -! Old definitions: MSCX(JSEA) = ABX2(JSEA) * FACTOR * FACTOR2 -! MSCY(JSEA) = ABY2(JSEA) * FACTOR * FACTOR2 - MSCD(JSEA)=0.5*ATAN2(2*MB,MA-MC) + ! + ! Directional moments in the last freq. band + ! + IF (IK.EQ.NK) THEN + FACTOR2 = SIG(IK)**5/(GRAV**2)/DSII(IK) + ETUSCX(JSEA) = ABX(JSEA)*FACTOR*FACTOR2 + ETUSCY(JSEA) = ABY(JSEA)*FACTOR*FACTOR2 + ! + ! NB: the slope PDF is proportional to ell1=ETYY*EC2-2*ETXY*ECS+ETYY*ES2 = A*EC2-2*B*ECS+C*ES2 + ! This is an ellipse equation with axis direction given by dir=0.5*ATAN2(-2.*ETXY,ETYY-ETXX) + ! + MA = ABX2(JSEA) * FACTOR * FACTOR2 + MC = ABY2(JSEA) * FACTOR * FACTOR2 + MB = ABYX(JSEA) * FACTOR * FACTOR2 + ! + ! Old definitions: MSCX(JSEA) = ABX2(JSEA) * FACTOR * FACTOR2 + ! MSCY(JSEA) = ABY2(JSEA) * FACTOR * FACTOR2 + MSCD(JSEA)=0.5*ATAN2(2*MB,MA-MC) - MSCX(JSEA)= MA*COS(MSCD(JSEA))**2 & - +2*MB*SIN(MSCD(JSEA))*COS(MSCD(JSEA))+MA*SIN(MSCD(JSEA))**2 - MSCY(JSEA)= MC*COS(MSCD(JSEA))**2 & - -2*MB*SIN(MSCD(JSEA))*COS(MSCD(JSEA))+MA*SIN(MSCD(JSEA))**2 - END IF -! -! Deep water limits -! - KD = MAX ( 0.001 , WN(IK,ISEA) * DW(ISEA) ) - IF ( KD .LT. 6. ) THEN - FKD = FACTOR / SINH(KD)**2 - ABR(JSEA) = ABR(JSEA) + AB(JSEA) * FKD - ABA(JSEA) = ABA(JSEA) + ABX(JSEA) * FKD - ABD(JSEA) = ABD(JSEA) + ABY(JSEA) * FKD - UBR(JSEA) = UBR(JSEA) + AB(JSEA) * SIG(IK)**2 * FKD - UBA(JSEA) = UBA(JSEA) + ABX(JSEA) * SIG(IK)**2 * FKD - UBD(JSEA) = UBD(JSEA) + ABY(JSEA) * SIG(IK)**2 * FKD - USSCO=FKD*SIG(IK)*WN(IK,ISEA)*COSH(2.*KD) - BHD(JSEA) = BHD(JSEA) + & - GRAV*WN(IK,ISEA) * EBD(IK,JSEA) / (SINH(2.*KD)) + MSCX(JSEA)= MA*COS(MSCD(JSEA))**2 & + +2*MB*SIN(MSCD(JSEA))*COS(MSCD(JSEA))+MA*SIN(MSCD(JSEA))**2 + MSCY(JSEA)= MC*COS(MSCD(JSEA))**2 & + -2*MB*SIN(MSCD(JSEA))*COS(MSCD(JSEA))+MA*SIN(MSCD(JSEA))**2 + END IF + ! + ! Deep water limits + ! + KD = MAX ( 0.001 , WN(IK,ISEA) * DW(ISEA) ) + IF ( KD .LT. 6. ) THEN + FKD = FACTOR / SINH(KD)**2 + ABR(JSEA) = ABR(JSEA) + AB(JSEA) * FKD + ABA(JSEA) = ABA(JSEA) + ABX(JSEA) * FKD + ABD(JSEA) = ABD(JSEA) + ABY(JSEA) * FKD + UBR(JSEA) = UBR(JSEA) + AB(JSEA) * SIG(IK)**2 * FKD + UBA(JSEA) = UBA(JSEA) + ABX(JSEA) * SIG(IK)**2 * FKD + UBD(JSEA) = UBD(JSEA) + ABY(JSEA) * SIG(IK)**2 * FKD + USSCO=FKD*SIG(IK)*WN(IK,ISEA)*COSH(2.*KD) + BHD(JSEA) = BHD(JSEA) + & + GRAV*WN(IK,ISEA) * EBD(IK,JSEA) / (SINH(2.*KD)) #ifdef W3_CESMCOUPLED - ! Surface Stokes Drift - ETUSSX(JSEA) = ETUSSX(JSEA) + ABX(JSEA)*FACTOR*SIG(IK) & - *WN(IK,ISEA)*COSH(2*WN(IK,ISEA)*DW(ISEA)) & - /(SINH(WN(IK,ISEA)*DW(ISEA)))**2 - ETUSSY(JSEA) = ETUSSY(JSEA) + ABY(JSEA)*FACTOR*SIG(IK) & - *WN(IK,ISEA)*COSH(2*WN(IK,ISEA)*DW(ISEA)) & - /(SINH(WN(IK,ISEA)*DW(ISEA)))**2 - ! Depth averaged Stokes Drift - ETUSSXH(JSEA) = ETUSSXH(JSEA) + ABX(JSEA)*FACTOR*SIG(IK) & - *(1.-EXP(-2.*WN(IK,ISEA)*HSL))/2./HSL & - *COSH(2*WN(IK,ISEA)*DW(ISEA)) & - /(SINH(WN(IK,ISEA)*DW(ISEA)))**2 - ETUSSYH(JSEA) = ETUSSYH(JSEA) + ABY(JSEA)*FACTOR*SIG(IK) & - *(1.-EXP(-2.*WN(IK,ISEA)*HSL))/2./HSL & - *COSH(2*WN(IK,ISEA)*DW(ISEA)) & - /(SINH(WN(IK,ISEA)*DW(ISEA)))**2 + ! Surface Stokes Drift + ETUSSX(JSEA) = ETUSSX(JSEA) + ABX(JSEA)*FACTOR*SIG(IK) & + *WN(IK,ISEA)*COSH(2*WN(IK,ISEA)*DW(ISEA)) & + /(SINH(WN(IK,ISEA)*DW(ISEA)))**2 + ETUSSY(JSEA) = ETUSSY(JSEA) + ABY(JSEA)*FACTOR*SIG(IK) & + *WN(IK,ISEA)*COSH(2*WN(IK,ISEA)*DW(ISEA)) & + /(SINH(WN(IK,ISEA)*DW(ISEA)))**2 + ! Depth averaged Stokes Drift + ETUSSXH(JSEA) = ETUSSXH(JSEA) + ABX(JSEA)*FACTOR*SIG(IK) & + *(1.-EXP(-2.*WN(IK,ISEA)*HSL))/2./HSL & + *COSH(2*WN(IK,ISEA)*DW(ISEA)) & + /(SINH(WN(IK,ISEA)*DW(ISEA)))**2 + ETUSSYH(JSEA) = ETUSSYH(JSEA) + ABY(JSEA)*FACTOR*SIG(IK) & + *(1.-EXP(-2.*WN(IK,ISEA)*HSL))/2./HSL & + *COSH(2*WN(IK,ISEA)*DW(ISEA)) & + /(SINH(WN(IK,ISEA)*DW(ISEA)))**2 #endif - ELSE - USSCO=FACTOR*SIG(IK)*2.*WN(IK,ISEA) + ELSE + USSCO=FACTOR*SIG(IK)*2.*WN(IK,ISEA) #ifdef W3_CESMCOUPLED - ! deep water limit - ! Surface Stokes Drift - ETUSSX(JSEA) = ETUSSX(JSEA) + ABX(JSEA)*FACTOR*SIG(IK) & - *2.*WN(IK,ISEA) - ETUSSY(JSEA) = ETUSSY(JSEA) + ABY(JSEA)*FACTOR*SIG(IK) & - *2.*WN(IK,ISEA) - ! Depth averaged Stokes Drift - ETUSSXH(JSEA) = ETUSSXH(JSEA) + ABX(JSEA)*FACTOR*SIG(IK) & - *(1.-EXP(-2.*WN(IK,ISEA)*HSL))/HSL - ETUSSYH(JSEA) = ETUSSYH(JSEA) + ABY(JSEA)*FACTOR*SIG(IK) & - *(1.-EXP(-2.*WN(IK,ISEA)*HSL))/HSL + ! deep water limit + ! Surface Stokes Drift + ETUSSX(JSEA) = ETUSSX(JSEA) + ABX(JSEA)*FACTOR*SIG(IK) & + *2.*WN(IK,ISEA) + ETUSSY(JSEA) = ETUSSY(JSEA) + ABY(JSEA)*FACTOR*SIG(IK) & + *2.*WN(IK,ISEA) + ! Depth averaged Stokes Drift + ETUSSXH(JSEA) = ETUSSXH(JSEA) + ABX(JSEA)*FACTOR*SIG(IK) & + *(1.-EXP(-2.*WN(IK,ISEA)*HSL))/HSL + ETUSSYH(JSEA) = ETUSSYH(JSEA) + ABY(JSEA)*FACTOR*SIG(IK) & + *(1.-EXP(-2.*WN(IK,ISEA)*HSL))/HSL #endif - END IF -! - ABXX(JSEA) = MAX ( 0. , ABXX(JSEA) ) * FACTOR - ABYY(JSEA) = MAX ( 0. , ABYY(JSEA) ) * FACTOR - ABXY(JSEA) = ABXY(JSEA) * FACTOR - SXX(JSEA) = SXX(JSEA) + ABXX(JSEA) - SYY(JSEA) = SYY(JSEA) + ABYY(JSEA) - SXY(JSEA) = SXY(JSEA) + ABXY(JSEA) - EBD(IK,JSEA) = EBD(IK,JSEA) / DSII(IK) -! - IF ( FLOLOC( 3, 1).AND.(IK.GE.E3DF(2,1).AND.IK.LE.E3DF(3,1))) & - EF(JSEA,IK) = EBD(IK,JSEA) * TPI -! - USSX(JSEA) = USSX(JSEA) + ABX(JSEA)*USSCO - USSY(JSEA) = USSY(JSEA) + ABY(JSEA)*USSCO -! -! Fills the 3D Stokes drift spectrum array -! ! The US3D Stokes drift specrum array is now calculated in a -! subroutine and called at the end of this subroutine -! IF ( FLOLOC( 6, 8).AND.(IK.GE.US3DF(2).AND.IK.LE.US3DF(3) )) THEN -! US3D(JSEA,IK) = ABX(JSEA)*USSCO/(DSII(IK)*TPIINV) -! US3D(JSEA,NK+IK) = ABY(JSEA)*USSCO/(DSII(IK)*TPIINV) -! END IF - IF ( FLOLOC( 3, 2).AND.(IK.GE.E3DF(2,2).AND.IK.LE.E3DF(3,2))) & - TH1M(JSEA,IK)= MOD ( 630. - RADE*ATAN2(ABY(JSEA),ABX(JSEA)) , 360. ) - M1 = SQRT(ABX(JSEA)**2+ABY(JSEA)**2)/MAX(1E-20,AB(JSEA)) - IF ( FLOLOC( 3, 3).AND.(IK.GE.E3DF(2,3).AND.IK.LE.E3DF(3,3))) & + END IF + ! + ABXX(JSEA) = MAX ( 0. , ABXX(JSEA) ) * FACTOR + ABYY(JSEA) = MAX ( 0. , ABYY(JSEA) ) * FACTOR + ABXY(JSEA) = ABXY(JSEA) * FACTOR + SXX(JSEA) = SXX(JSEA) + ABXX(JSEA) + SYY(JSEA) = SYY(JSEA) + ABYY(JSEA) + SXY(JSEA) = SXY(JSEA) + ABXY(JSEA) + EBD(IK,JSEA) = EBD(IK,JSEA) / DSII(IK) + ! + IF ( FLOLOC( 3, 1).AND.(IK.GE.E3DF(2,1).AND.IK.LE.E3DF(3,1))) & + EF(JSEA,IK) = EBD(IK,JSEA) * TPI + ! + USSX(JSEA) = USSX(JSEA) + ABX(JSEA)*USSCO + USSY(JSEA) = USSY(JSEA) + ABY(JSEA)*USSCO + ! + ! Fills the 3D Stokes drift spectrum array + ! ! The US3D Stokes drift specrum array is now calculated in a + ! subroutine and called at the end of this subroutine + ! IF ( FLOLOC( 6, 8).AND.(IK.GE.US3DF(2).AND.IK.LE.US3DF(3) )) THEN + ! US3D(JSEA,IK) = ABX(JSEA)*USSCO/(DSII(IK)*TPIINV) + ! US3D(JSEA,NK+IK) = ABY(JSEA)*USSCO/(DSII(IK)*TPIINV) + ! END IF + IF ( FLOLOC( 3, 2).AND.(IK.GE.E3DF(2,2).AND.IK.LE.E3DF(3,2))) & + TH1M(JSEA,IK)= MOD ( 630. - RADE*ATAN2(ABY(JSEA),ABX(JSEA)) , 360. ) + M1 = SQRT(ABX(JSEA)**2+ABY(JSEA)**2)/MAX(1E-20,AB(JSEA)) + IF ( FLOLOC( 3, 3).AND.(IK.GE.E3DF(2,3).AND.IK.LE.E3DF(3,3))) & STH1M(JSEA,IK)= SQRT(ABS(2.*(1-M1)))*RADE - IF ( FLOLOC( 3, 4).AND.(IK.GE.E3DF(2,4).AND.IK.LE.E3DF(3,4))) & - TH2M(JSEA,IK)= MOD ( 270. - RADE*0.5*ATAN2(ABY2(JSEA),AB2X(JSEA)) , 180. ) - M2 = SQRT(AB2X(JSEA)**2+AB2Y(JSEA)**2)/MAX(1E-20,AB(JSEA)) - IF ( FLOLOC( 3, 5).AND.(IK.GE.E3DF(2,5).AND.IK.LE.E3DF(3,5))) & + IF ( FLOLOC( 3, 4).AND.(IK.GE.E3DF(2,4).AND.IK.LE.E3DF(3,4))) & + TH2M(JSEA,IK)= MOD ( 270. - RADE*0.5*ATAN2(ABY2(JSEA),AB2X(JSEA)) , 180. ) + M2 = SQRT(AB2X(JSEA)**2+AB2Y(JSEA)**2)/MAX(1E-20,AB(JSEA)) + IF ( FLOLOC( 3, 5).AND.(IK.GE.E3DF(2,5).AND.IK.LE.E3DF(3,5))) & STH2M(JSEA,IK)= SQRT(ABS(0.5*(1-M2)))*RADE - END DO -! + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - END DO -! -! Start of Space-Time Extremes Section - IF ( ( STEXU .GT. 0. .AND. STEYU .GT. 0. ) & - .OR. ( STEDU .GT. 0. ) ) THEN -! Space-Time extremes -! (for references: -! - Krogstad et al, OMAE 2004 -! - Baxevani and Rychlik, OE 2006 -! - Adler and Taylor, 2007 -! - Fedele, JPO 2012 -! - Fedele et al, OM 2013 -! - Benetazzo et al, JPO 2015) -! -! Compute spectral parameters wrt the mean wave direction -! (no tail contribution - Prognostic) + ! + END DO + ! + ! Start of Space-Time Extremes Section + IF ( ( STEXU .GT. 0. .AND. STEYU .GT. 0. ) & + .OR. ( STEDU .GT. 0. ) ) THEN + ! Space-Time extremes + ! (for references: + ! - Krogstad et al, OMAE 2004 + ! - Baxevani and Rychlik, OE 2006 + ! - Adler and Taylor, 2007 + ! - Fedele, JPO 2012 + ! - Fedele et al, OM 2013 + ! - Benetazzo et al, JPO 2015) + ! + ! Compute spectral parameters wrt the mean wave direction + ! (no tail contribution - Prognostic) DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) IX = MAPSF(ISEA,1) @@ -1772,105 +1772,105 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) IF ( MAPSTA(IY,IX) .GT. 0 ) THEN IF ( ABS(ETX(JSEA))+ABS(ETY(JSEA)) .GT. 1.E-7 ) THEN THMP(JSEA) = ATAN2(ETY(JSEA),ETX(JSEA)) - END IF END IF - END DO -! + END IF + END DO + ! DO IK=1, NK -! + ! ABX2M = 0. ABY2M = 0. ABXM = 0. ABYM = 0. ABXYM = 0. -! + ! DO ITH=1, NTH -! + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA) + !$OMP PARALLEL DO PRIVATE(JSEA) #endif -! + ! DO JSEA=1, NSEAL ABX2M(JSEA) = ABX2M(JSEA) + A(ITH,IK,JSEA)* & - (ECOS(ITH)*COS(THMP(JSEA))+ESIN(ITH)*SIN(THMP(JSEA)))**2 + (ECOS(ITH)*COS(THMP(JSEA))+ESIN(ITH)*SIN(THMP(JSEA)))**2 ABY2M(JSEA) = ABY2M(JSEA) + A(ITH,IK,JSEA)* & - (ESIN(ITH)*COS(THMP(JSEA))-ECOS(ITH)*SIN(THMP(JSEA)))**2 + (ESIN(ITH)*COS(THMP(JSEA))-ECOS(ITH)*SIN(THMP(JSEA)))**2 ABXM(JSEA) = ABXM(JSEA) + A(ITH,IK,JSEA)* & - (ECOS(ITH)*COS(THMP(JSEA))+ESIN(ITH)*SIN(THMP(JSEA))) + (ECOS(ITH)*COS(THMP(JSEA))+ESIN(ITH)*SIN(THMP(JSEA))) ABYM(JSEA) = ABYM(JSEA) + A(ITH,IK,JSEA)* & - (ESIN(ITH)*COS(THMP(JSEA))-ECOS(ITH)*SIN(THMP(JSEA))) + (ESIN(ITH)*COS(THMP(JSEA))-ECOS(ITH)*SIN(THMP(JSEA))) ABXYM(JSEA) = ABXYM(JSEA) + A(ITH,IK,JSEA)* & - (ECOS(ITH)*COS(THMP(JSEA))+ESIN(ITH)*SIN(THMP(JSEA)))* & - (ESIN(ITH)*COS(THMP(JSEA))-ECOS(ITH)*SIN(THMP(JSEA))) - END DO -! + (ECOS(ITH)*COS(THMP(JSEA))+ESIN(ITH)*SIN(THMP(JSEA)))* & + (ESIN(ITH)*COS(THMP(JSEA))-ECOS(ITH)*SIN(THMP(JSEA))) + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - END DO -! + ! + END DO + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR) + !$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR) #endif -! + ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) FACTOR = DDEN(IK) / CG(IK,ISEA) MSSXM(JSEA) = MSSXM(JSEA) + ABX2M(JSEA)*FACTOR* & - WN(IK,ISEA)**2 + WN(IK,ISEA)**2 MSSYM(JSEA) = MSSYM(JSEA) + ABY2M(JSEA)*FACTOR* & - WN(IK,ISEA)**2 + WN(IK,ISEA)**2 MSSXTM(JSEA) = MSSXTM(JSEA) + ABXM(JSEA)*FACTOR*WN(IK,ISEA)* & - SIG(IK) + SIG(IK) MSSYTM(JSEA) = MSSYTM(JSEA) + ABYM(JSEA)*FACTOR*WN(IK,ISEA)* & - SIG(IK) + SIG(IK) MSSXYM(JSEA) = MSSXYM(JSEA) + ABXYM(JSEA)*FACTOR* & - WN(IK,ISEA)**2 - END DO -! + WN(IK,ISEA)**2 + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - END DO + ! + END DO #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA,STEX,STEY,STED,ITL,IK) + !$OMP PARALLEL DO PRIVATE(JSEA,STEX,STEY,STED,ITL,IK) #endif -! - DO JSEA=1, NSEAL -! -! Mean wave period (no tail contribution - Prognostic) + ! + DO JSEA=1, NSEAL + ! + ! Mean wave period (no tail contribution - Prognostic) IF ( ET02(JSEA) .GT. 1.E-7 ) THEN T02P(JSEA) = TPI * SQRT(ET(JSEA) / ET02(JSEA) ) - END IF -! -! Mean wavelength and mean crest length (02) for space-time extremes + END IF + ! + ! Mean wavelength and mean crest length (02) for space-time extremes IF ( MSSXM(JSEA) .GT. 1.E-7 ) THEN WL02X(JSEA) = TPI * SQRT(ET(JSEA) / MSSXM(JSEA)) - END IF + END IF IF ( MSSYM(JSEA) .GT. 1.E-7 ) THEN WL02Y(JSEA) = TPI * SQRT(ET(JSEA) / MSSYM(JSEA)) - END IF -! -! Irregularity parameters for space-time extremes + END IF + ! + ! Irregularity parameters for space-time extremes IF ((MSSXM(JSEA) .GT. 1.E-7) .AND. (ET02(JSEA) .GT. 1.E-7)) THEN ALPXT(JSEA) = MSSXTM(JSEA) / (SQRT(MSSXM(JSEA) * ET02(JSEA))) - ENDIF + ENDIF IF ((MSSYM(JSEA) .GT. 1.E-7) .AND. (ET02(JSEA) .GT. 1.E-7)) THEN ALPYT(JSEA) = MSSYTM(JSEA) / (SQRT(MSSYM(JSEA) * ET02(JSEA))) - ENDIF + ENDIF IF ((MSSXM(JSEA) .GT. 1.E-7) .AND. (MSSYM(JSEA) .GT. 1.E-7)) THEN ALPXY(JSEA) = MSSXYM(JSEA) / (SQRT(MSSXM(JSEA) * MSSYM(JSEA))) - ENDIF -! -! Short-crestedness parameter + ENDIF + ! + ! Short-crestedness parameter IF (MSSXM(JSEA) .GT. 1.E-7) THEN SCREST(JSEA) = SQRT(MSSYM(JSEA)/MSSXM(JSEA)) - END IF -! -! Space domain size (user-defined or default) + END IF + ! + ! Space domain size (user-defined or default) IF ( STEXU .GT. 0 .AND. STEYU .GT. 0 ) THEN STEX = STEXU STEY = STEYU @@ -1878,2523 +1878,2520 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) STEX = 0. STEY = 0. END IF -! -! Time domain size (user-defined or default) + ! + ! Time domain size (user-defined or default) IF ( STEDU .GT. 0 ) THEN STED = STEDU - ELSE + ELSE STED = 0. - END IF -! -! Average numbers of waves in the space-time domain (Volume+Sides+Borders) + END IF + ! + ! Average numbers of waves in the space-time domain (Volume+Sides+Borders) IF ((WL02X(JSEA) .GT. 1.E-7) .AND. (WL02Y(JSEA) .GT. 1.E-7) & - .AND. (T02P(JSEA) .GT. 1.E-7)) THEN + .AND. (T02P(JSEA) .GT. 1.E-7)) THEN NV(JSEA) = TPI*(STEX*STEY*STED)/ & - (WL02X(JSEA)*WL02Y(JSEA)*T02P(JSEA)) * & - SQRT(1-ALPXT(JSEA)**2-ALPYT(JSEA)**2 - & - ALPXY(JSEA)**2+2*ALPXT(JSEA)*ALPYT(JSEA)*ALPXY(JSEA)) + (WL02X(JSEA)*WL02Y(JSEA)*T02P(JSEA)) * & + SQRT(1-ALPXT(JSEA)**2-ALPYT(JSEA)**2 - & + ALPXY(JSEA)**2+2*ALPXT(JSEA)*ALPYT(JSEA)*ALPXY(JSEA)) NS(JSEA) = SQRT(TPI)*((STEX*STED)/(WL02X(JSEA)*T02P(JSEA)) * & - SQRT(1-ALPXT(JSEA)**2) + & - (STEY*STED)/(WL02Y(JSEA)*T02P(JSEA)) * & - SQRT(1-ALPYT(JSEA)**2) + & - (STEX*STEY)/(WL02X(JSEA)*WL02Y(JSEA)) * & - SQRT(1-ALPXY(JSEA)**2)) + SQRT(1-ALPXT(JSEA)**2) + & + (STEY*STED)/(WL02Y(JSEA)*T02P(JSEA)) * & + SQRT(1-ALPYT(JSEA)**2) + & + (STEX*STEY)/(WL02X(JSEA)*WL02Y(JSEA)) * & + SQRT(1-ALPXY(JSEA)**2)) NB(JSEA) = STEX/WL02X(JSEA) + STEY/WL02Y(JSEA) + & - STED/T02P(JSEA) - END IF -! -! Integral measure of wave steepness (Fedele & Tayfun, 2009) MU, as a -! function of the spectral width parameter NI (Longuet-Higgins, 1985) + STED/T02P(JSEA) + END IF + ! + ! Integral measure of wave steepness (Fedele & Tayfun, 2009) MU, as a + ! function of the spectral width parameter NI (Longuet-Higgins, 1985) IF (ET1(JSEA) .GT. 1.E-7) THEN NI(JSEA) = SQRT(ET(JSEA)*ET02(JSEA)/ET1(JSEA)**2 - 1) - ENDIF + ENDIF IF (ET(JSEA) .GT. 1.E-7) THEN MU(JSEA) = ET1(JSEA)**2/GRAV * (ET(JSEA))**(-1.5) * & - (1-NI(JSEA)+NI(JSEA)**2) - ENDIF -! -! Mode of the Adler&Taylor distribution -! (normalized on the standard deviation = Hs/4) -! Time extremes - IF ((STEX .EQ. 0) .AND. (STEY .EQ. 0)) THEN - MODE(JSEA) = SQRT(2.*LOG(NB(JSEA))) -! Space extremes (strictly for STEX*STEY >> WL02X*WL02Y) - ELSEIF (STED .EQ. 0) THEN - MODE(JSEA) = SQRT(2.*LOG(NS(JSEA))+LOG(2.*LOG(NS(JSEA))+ & - LOG(2.*LOG(NS(JSEA))))) -! Space-time extremes (strictly for STEX*STEY >> WL02X*WL02Y) - ELSEIF ((WL02X(JSEA) .GT. 1.E-7) .AND. (WL02Y(JSEA) .GT. 1.E-7) & - .AND. (T02P(JSEA) .GT. 1.E-7)) THEN - MODE(JSEA) = SQRT(2.*LOG(NV(JSEA))+2.*LOG(2.*LOG(NV(JSEA))+ & - 2.*LOG(2.*LOG(NV(JSEA))))) - ENDIF -! -! Expected maximum sea surface elevation in the ST domain - nonlinear -! (in meters, Hs/4=SQRT(ET(JSEA))) - STMAXE(JSEA) = SQRT(ET(JSEA)) * & - ( MODE(JSEA)+0.5*MU(JSEA)*MODE(JSEA)**2 + & - 0.5772*(1+MU(JSEA)*MODE(JSEA)) / & - (MODE(JSEA)-(2*NV(JSEA)*MODE(JSEA)+NS(JSEA)) / & - (NV(JSEA)*MODE(JSEA)**2+NS(JSEA)*MODE(JSEA)+NB(JSEA))) ) -! -! Standard deviation of the maximum sea surface elevation in ST domain -! - nonlinear (in meters, Hs/4=SQRT(ET(JSEA))) - STMAXD(JSEA) = SQRT(ET(JSEA)) * & - ( PI*(1+MU(JSEA)*MODE(JSEA))/SQRT(6.) / & - (MODE(JSEA)-(2*NV(JSEA)*MODE(JSEA)+NS(JSEA)) / & - (NV(JSEA)*MODE(JSEA)**2+NS(JSEA)*MODE(JSEA)+NB(JSEA))) ) -! -! Autocovariance (time) function (normalized on the maximum, i.e. total -! variance) - IF (T02P(JSEA) .GT. 1.E-7) THEN - TLPHI(JSEA) = 0.3*T02P(JSEA) - DO ITL = 1, 21 - DO IK = 1, NK-3, 4 - PHI(ITL,JSEA) = PHI(ITL,JSEA) + & - (XFR**3*EBD(IK+3,JSEA)*COS(XFR**3*SIG(IK)*TLPHI(JSEA))+ & - XFR**2*EBD(IK+2,JSEA)*COS(XFR**2*SIG(IK)*TLPHI(JSEA))+ & - XFR*EBD(IK+1,JSEA)*COS(XFR*SIG(IK)*TLPHI(JSEA)) + & - EBD(IK,JSEA)*COS(SIG(IK)*TLPHI(JSEA)))*DSII(IK) - ENDDO - TLPHI(JSEA) = TLPHI(JSEA) + T02P(JSEA)/20. + (1-NI(JSEA)+NI(JSEA)**2) + ENDIF + ! + ! Mode of the Adler&Taylor distribution + ! (normalized on the standard deviation = Hs/4) + ! Time extremes + IF ((STEX .EQ. 0) .AND. (STEY .EQ. 0)) THEN + MODE(JSEA) = SQRT(2.*LOG(NB(JSEA))) + ! Space extremes (strictly for STEX*STEY >> WL02X*WL02Y) + ELSEIF (STED .EQ. 0) THEN + MODE(JSEA) = SQRT(2.*LOG(NS(JSEA))+LOG(2.*LOG(NS(JSEA))+ & + LOG(2.*LOG(NS(JSEA))))) + ! Space-time extremes (strictly for STEX*STEY >> WL02X*WL02Y) + ELSEIF ((WL02X(JSEA) .GT. 1.E-7) .AND. (WL02Y(JSEA) .GT. 1.E-7) & + .AND. (T02P(JSEA) .GT. 1.E-7)) THEN + MODE(JSEA) = SQRT(2.*LOG(NV(JSEA))+2.*LOG(2.*LOG(NV(JSEA))+ & + 2.*LOG(2.*LOG(NV(JSEA))))) + ENDIF + ! + ! Expected maximum sea surface elevation in the ST domain - nonlinear + ! (in meters, Hs/4=SQRT(ET(JSEA))) + STMAXE(JSEA) = SQRT(ET(JSEA)) * & + ( MODE(JSEA)+0.5*MU(JSEA)*MODE(JSEA)**2 + & + 0.5772*(1+MU(JSEA)*MODE(JSEA)) / & + (MODE(JSEA)-(2*NV(JSEA)*MODE(JSEA)+NS(JSEA)) / & + (NV(JSEA)*MODE(JSEA)**2+NS(JSEA)*MODE(JSEA)+NB(JSEA))) ) + ! + ! Standard deviation of the maximum sea surface elevation in ST domain + ! - nonlinear (in meters, Hs/4=SQRT(ET(JSEA))) + STMAXD(JSEA) = SQRT(ET(JSEA)) * & + ( PI*(1+MU(JSEA)*MODE(JSEA))/SQRT(6.) / & + (MODE(JSEA)-(2*NV(JSEA)*MODE(JSEA)+NS(JSEA)) / & + (NV(JSEA)*MODE(JSEA)**2+NS(JSEA)*MODE(JSEA)+NB(JSEA))) ) + ! + ! Autocovariance (time) function (normalized on the maximum, i.e. total + ! variance) + IF (T02P(JSEA) .GT. 1.E-7) THEN + TLPHI(JSEA) = 0.3*T02P(JSEA) + DO ITL = 1, 21 + DO IK = 1, NK-3, 4 + PHI(ITL,JSEA) = PHI(ITL,JSEA) + & + (XFR**3*EBD(IK+3,JSEA)*COS(XFR**3*SIG(IK)*TLPHI(JSEA))+ & + XFR**2*EBD(IK+2,JSEA)*COS(XFR**2*SIG(IK)*TLPHI(JSEA))+ & + XFR*EBD(IK+1,JSEA)*COS(XFR*SIG(IK)*TLPHI(JSEA)) + & + EBD(IK,JSEA)*COS(SIG(IK)*TLPHI(JSEA)))*DSII(IK) + ENDDO + TLPHI(JSEA) = TLPHI(JSEA) + T02P(JSEA)/20. ENDDO PHI(:,JSEA) = PHI(:,JSEA)/ET(JSEA) -! -! First minimum of the autocovariance function (absolute value) - PHIST(JSEA) = ABS(MINVAL(PHI(:,JSEA),1)) - ENDIF -! -! Wave height of the wave with the maximum expected crest height -! and corresponding standard deviation -! (according to Boccotti Quasi-Determinism theory - linear) + ! + ! First minimum of the autocovariance function (absolute value) + PHIST(JSEA) = ABS(MINVAL(PHI(:,JSEA),1)) + ENDIF + ! + ! Wave height of the wave with the maximum expected crest height + ! and corresponding standard deviation + ! (according to Boccotti Quasi-Determinism theory - linear) STMAXEL(JSEA) = SQRT(ET(JSEA)) * ( MODE(JSEA)+0.5772 / & - (MODE(JSEA)-(2*NV(JSEA)*MODE(JSEA)+NS(JSEA)) / & - (NV(JSEA)*MODE(JSEA)**2+NS(JSEA)*MODE(JSEA)+NB(JSEA))) ) + (MODE(JSEA)-(2*NV(JSEA)*MODE(JSEA)+NS(JSEA)) / & + (NV(JSEA)*MODE(JSEA)**2+NS(JSEA)*MODE(JSEA)+NB(JSEA))) ) STMAXDL(JSEA) = SQRT(ET(JSEA)) * & - ( PI/SQRT(6.) / & - (MODE(JSEA)-(2*NV(JSEA)*MODE(JSEA)+NS(JSEA)) / & - (NV(JSEA)*MODE(JSEA)**2+NS(JSEA)*MODE(JSEA)+NB(JSEA))) ) + ( PI/SQRT(6.) / & + (MODE(JSEA)-(2*NV(JSEA)*MODE(JSEA)+NS(JSEA)) / & + (NV(JSEA)*MODE(JSEA)**2+NS(JSEA)*MODE(JSEA)+NB(JSEA))) ) HCMAXE(JSEA) = STMAXEL(JSEA)*(1+PHIST(JSEA)) HCMAXD(JSEA) = STMAXDL(JSEA)*(1+PHIST(JSEA)) -! Maximum expected wave height and corresponding standard deviation -! (according to Boccotti Quasi-Determinism theory - linear) + ! Maximum expected wave height and corresponding standard deviation + ! (according to Boccotti Quasi-Determinism theory - linear) HMAXE(JSEA) = STMAXEL(JSEA)*SQRT(2*(1+PHIST(JSEA))) HMAXD(JSEA) = STMAXDL(JSEA)*SQRT(2*(1+PHIST(JSEA))) - ENDDO -! + ENDDO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! + ! -! End of Space-Time Extremes Section - ENDIF -! -! 3. Finalize computation of mean parameters ------------------------ * -! + ! End of Space-Time Extremes Section + ENDIF + ! + ! 3. Finalize computation of mean parameters ------------------------ * + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,EBAND) + !$OMP PARALLEL DO PRIVATE(JSEA,ISEA,EBAND) #endif -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) + ! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) #ifdef W3_CESMCOUPLED - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - HS = HML(IX,IY)/5. ! depth over which SD is averaged + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + HS = HML(IX,IY)/5. ! depth over which SD is averaged #endif -! -! 3.a Directional mss parameters -! NB: the slope PDF is proportional to ell1=ETYY*EC2-2*ETXY*ECS+ETXX*ES2 = C*EC2-2*B*ECS+A*ES2 -! This is an ellipse equation with axis direction given by dir=0.5*ATAN2(2.*ETXY,ETXX-ETYY) -! From matlab script: t0=0.5*(atan2(2.*B,A-C)); -! From matlab script: A2=A.*cos(t0).^2+2.*B.*sin(t0).*cos(t0)+A.*cos(t0).^2+C.*sin(t0)^2; -! From matlab script: C2=C.*cos(t0)^2-2.*B.*sin(t0).*cos(t0)+A.*sin(t0).^2; - MSSD(JSEA)=0.5*(ATAN2(2*ETXY(JSEA),ETXX(JSEA)-ETYY(JSEA))) - MSSX(JSEA) = ETXX(JSEA)*COS(MSSD(JSEA))**2 & - +2*ETXY(JSEA)*SIN(MSSD(JSEA))*COS(MSSD(JSEA))+ETYY(JSEA)*SIN(MSSD(JSEA))**2 - MSSY(JSEA) = ETYY(JSEA)*COS(MSSD(JSEA))**2 & - -2*ETXY(JSEA)*SIN(MSSD(JSEA))*COS(MSSD(JSEA))+ETXX(JSEA)*SIN(MSSD(JSEA))**2 -! -! 3.b Add tail -! ( DTH * SIG absorbed in FTxx ) + ! + ! 3.a Directional mss parameters + ! NB: the slope PDF is proportional to ell1=ETYY*EC2-2*ETXY*ECS+ETXX*ES2 = C*EC2-2*B*ECS+A*ES2 + ! This is an ellipse equation with axis direction given by dir=0.5*ATAN2(2.*ETXY,ETXX-ETYY) + ! From matlab script: t0=0.5*(atan2(2.*B,A-C)); + ! From matlab script: A2=A.*cos(t0).^2+2.*B.*sin(t0).*cos(t0)+A.*cos(t0).^2+C.*sin(t0)^2; + ! From matlab script: C2=C.*cos(t0)^2-2.*B.*sin(t0).*cos(t0)+A.*sin(t0).^2; + MSSD(JSEA)=0.5*(ATAN2(2*ETXY(JSEA),ETXX(JSEA)-ETYY(JSEA))) + MSSX(JSEA) = ETXX(JSEA)*COS(MSSD(JSEA))**2 & + +2*ETXY(JSEA)*SIN(MSSD(JSEA))*COS(MSSD(JSEA))+ETYY(JSEA)*SIN(MSSD(JSEA))**2 + MSSY(JSEA) = ETYY(JSEA)*COS(MSSD(JSEA))**2 & + -2*ETXY(JSEA)*SIN(MSSD(JSEA))*COS(MSSD(JSEA))+ETXX(JSEA)*SIN(MSSD(JSEA))**2 + ! + ! 3.b Add tail + ! ( DTH * SIG absorbed in FTxx ) - EBAND = AB(JSEA) / CG(NK,ISEA) - ET (JSEA) = ET (JSEA) + FTE * EBAND - EWN(JSEA) = EWN(JSEA) + FTWL * EBAND - ETF(JSEA) = ETF(JSEA) + GRAV * FTTR * EBAND ! this is the integral of CgE in deep water - ETR(JSEA) = ETR(JSEA) + FTTR * EBAND - ET1(JSEA) = ET1(JSEA) + FT1 * EBAND - EET1(JSEA)= ET1(JSEA) + FT1 * EBAND**2 - ET02(JSEA)= ET02(JSEA)+ EBAND* 0.5 * SIG(NK)**4 * DTH - ETX(JSEA) = ETX(JSEA) + FTE * ABX(JSEA) / CG(NK,ISEA) - ETY(JSEA) = ETY(JSEA) + FTE * ABY(JSEA) / CG(NK,ISEA) - SXX(JSEA) = SXX(JSEA) + FTE * ABXX(JSEA) / CG(NK,ISEA) - SYY(JSEA) = SYY(JSEA) + FTE * ABYY(JSEA) / CG(NK,ISEA) - SXY(JSEA) = SXY(JSEA) + FTE * ABXY(JSEA) / CG(NK,ISEA) + EBAND = AB(JSEA) / CG(NK,ISEA) + ET (JSEA) = ET (JSEA) + FTE * EBAND + EWN(JSEA) = EWN(JSEA) + FTWL * EBAND + ETF(JSEA) = ETF(JSEA) + GRAV * FTTR * EBAND ! this is the integral of CgE in deep water + ETR(JSEA) = ETR(JSEA) + FTTR * EBAND + ET1(JSEA) = ET1(JSEA) + FT1 * EBAND + EET1(JSEA)= ET1(JSEA) + FT1 * EBAND**2 + ET02(JSEA)= ET02(JSEA)+ EBAND* 0.5 * SIG(NK)**4 * DTH + ETX(JSEA) = ETX(JSEA) + FTE * ABX(JSEA) / CG(NK,ISEA) + ETY(JSEA) = ETY(JSEA) + FTE * ABY(JSEA) / CG(NK,ISEA) + SXX(JSEA) = SXX(JSEA) + FTE * ABXX(JSEA) / CG(NK,ISEA) + SYY(JSEA) = SYY(JSEA) + FTE * ABYY(JSEA) / CG(NK,ISEA) + SXY(JSEA) = SXY(JSEA) + FTE * ABXY(JSEA) / CG(NK,ISEA) #ifdef W3_CESMCOUPLED - ! tail for SD - ETUSSX(JSEA) = ETUSSX(JSEA) + 2*GRAV*ETUSCX(JSEA)/SIG(NK) - ETUSSY(JSEA) = ETUSSY(JSEA) + 2*GRAV*ETUSCY(JSEA)/SIG(NK) + ! tail for SD + ETUSSX(JSEA) = ETUSSX(JSEA) + 2*GRAV*ETUSCX(JSEA)/SIG(NK) + ETUSSY(JSEA) = ETUSSY(JSEA) + 2*GRAV*ETUSCY(JSEA)/SIG(NK) #endif -! -! Tail for surface stokes drift is commented out: very sensitive to tail power -! -! USSX(JSEA) = USSX(JSEA) + 2*GRAV*ETUSCX(JSEA)/SIG(NK) -! USSY(JSEA) = USSY(JSEA) + 2*GRAV*ETUSCY(JSEA)/SIG(NK) - UBS(JSEA) = UBS(JSEA) + FTWL * EBAND/GRAV - END DO -! + ! + ! Tail for surface stokes drift is commented out: very sensitive to tail power + ! + ! USSX(JSEA) = USSX(JSEA) + 2*GRAV*ETUSCX(JSEA)/SIG(NK) + ! USSY(JSEA) = USSY(JSEA) + 2*GRAV*ETUSCY(JSEA)/SIG(NK) + UBS(JSEA) = UBS(JSEA) + FTWL * EBAND/GRAV + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - SXX = SXX * DWAT * GRAV - SYY = SYY * DWAT * GRAV - SXY = SXY * DWAT * GRAV -! + ! + SXX = SXX * DWAT * GRAV + SYY = SYY * DWAT * GRAV + SXY = SXY * DWAT * GRAV + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,IX,IY) + !$OMP PARALLEL DO PRIVATE(JSEA,ISEA,IX,IY) #endif -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF ( MAPSTA(IY,IX) .GT. 0 ) THEN + ! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF ( MAPSTA(IY,IX) .GT. 0 ) THEN #ifdef W3_O9 - IF ( ET(JSEA) .GE. 0. ) THEN + IF ( ET(JSEA) .GE. 0. ) THEN #endif - HS (JSEA) = 4. * SQRT ( ET(JSEA) ) + HS (JSEA) = 4. * SQRT ( ET(JSEA) ) #ifdef W3_O9 - ELSE - HS (JSEA) = - 4. * SQRT ( -ET(JSEA) ) - END IF + ELSE + HS (JSEA) = - 4. * SQRT ( -ET(JSEA) ) + END IF #endif - IF ( ET(JSEA) .GT. 1.E-7 ) THEN - QP(JSEA) = ( 2. / ET(JSEA)**2 ) * EET1(JSEA) * TPIINV**2 - WLM(JSEA) = EWN(JSEA) / ET(JSEA) * TPI - T0M1(JSEA) = ETR(JSEA) / ET(JSEA) * TPI - THS(JSEA) = RADE * SQRT ( MAX ( 0. , 2. * ( 1. - SQRT ( & - MAX(0.,(ETX(JSEA)**2+ETY(JSEA)**2)/ET(JSEA)**2) ) ) ) ) - IF ( THS(JSEA) .LT. 0.01*RADE*DTH ) THS(JSEA) = 0. - ELSE - WLM(JSEA) = 0. - T0M1(JSEA) = TPI / SIG(NK) - THS(JSEA) = 0. - END IF - IF ( ABS(ETX(JSEA))+ABS(ETY(JSEA)) .GT. 1.E-7 ) THEN - THM(JSEA) = ATAN2(ETY(JSEA),ETX(JSEA)) - ELSE - THM(JSEA) = 0. - END IF - ABR(JSEA) = SQRT ( 2. * MAX ( 0. , ABR(JSEA) ) ) - IF ( ABR(JSEA) .GE. 1.E-7 ) THEN - ABD(JSEA) = ATAN2(ABD(JSEA),ABA(JSEA)) - ELSE - ABD(JSEA) = 0. - ENDIF - ABA(JSEA) = ABR(JSEA) - UBR(JSEA) = SQRT ( 2. * MAX ( 0. , UBR(JSEA) ) ) - IF ( UBR(JSEA) .GE. 1.E-7 ) THEN - UBD(JSEA) = ATAN2(UBD(JSEA),UBA(JSEA)) - ELSE - UBD(JSEA) = 0. - ENDIF - UBA(JSEA) = UBR(JSEA) - CGE(JSEA) = DWAT*GRAV*ETF(JSEA) - IF ( ET02(JSEA) .GT. 1.E-7 .AND. ET(JSEA) .GT. 0 ) THEN - T02(JSEA) = TPI * SQRT(ET(JSEA) / ET02(JSEA) ) - T01(JSEA) = TPI * ET(JSEA) / ET1(JSEA) - ELSE - T02(JSEA) = TPI / SIG(NK) - T01(JSEA)= T02(JSEA) - ENDIF + IF ( ET(JSEA) .GT. 1.E-7 ) THEN + QP(JSEA) = ( 2. / ET(JSEA)**2 ) * EET1(JSEA) * TPIINV**2 + WLM(JSEA) = EWN(JSEA) / ET(JSEA) * TPI + T0M1(JSEA) = ETR(JSEA) / ET(JSEA) * TPI + THS(JSEA) = RADE * SQRT ( MAX ( 0. , 2. * ( 1. - SQRT ( & + MAX(0.,(ETX(JSEA)**2+ETY(JSEA)**2)/ET(JSEA)**2) ) ) ) ) + IF ( THS(JSEA) .LT. 0.01*RADE*DTH ) THS(JSEA) = 0. + ELSE + WLM(JSEA) = 0. + T0M1(JSEA) = TPI / SIG(NK) + THS(JSEA) = 0. + END IF + IF ( ABS(ETX(JSEA))+ABS(ETY(JSEA)) .GT. 1.E-7 ) THEN + THM(JSEA) = ATAN2(ETY(JSEA),ETX(JSEA)) + ELSE + THM(JSEA) = 0. + END IF + ABR(JSEA) = SQRT ( 2. * MAX ( 0. , ABR(JSEA) ) ) + IF ( ABR(JSEA) .GE. 1.E-7 ) THEN + ABD(JSEA) = ATAN2(ABD(JSEA),ABA(JSEA)) + ELSE + ABD(JSEA) = 0. + ENDIF + ABA(JSEA) = ABR(JSEA) + UBR(JSEA) = SQRT ( 2. * MAX ( 0. , UBR(JSEA) ) ) + IF ( UBR(JSEA) .GE. 1.E-7 ) THEN + UBD(JSEA) = ATAN2(UBD(JSEA),UBA(JSEA)) + ELSE + UBD(JSEA) = 0. + ENDIF + UBA(JSEA) = UBR(JSEA) + CGE(JSEA) = DWAT*GRAV*ETF(JSEA) + IF ( ET02(JSEA) .GT. 1.E-7 .AND. ET(JSEA) .GT. 0 ) THEN + T02(JSEA) = TPI * SQRT(ET(JSEA) / ET02(JSEA) ) + T01(JSEA) = TPI * ET(JSEA) / ET1(JSEA) + ELSE + T02(JSEA) = TPI / SIG(NK) + T01(JSEA)= T02(JSEA) + ENDIF #ifdef W3_CESMCOUPLED - !TODO is this affected by the NXXX vs. NSEALM? - ! Should LAMULT, etc. be NSEAML length? - ! Output Stokes drift and Langmuir numbers - ! USERO(JSEA,1) = HS(JSEA) / MAX ( 0.001 , DW(JSEA) ) - ! USERO(JSEA,2) = ASF(ISEA) - IF (ETUSSX(JSEA) .NE. 0. .OR. ETUSSY(JSEA) .NE. 0.) THEN + !TODO is this affected by the NXXX vs. NSEALM? + ! Should LAMULT, etc. be NSEAML length? + ! Output Stokes drift and Langmuir numbers + ! USERO(JSEA,1) = HS(JSEA) / MAX ( 0.001 , DW(JSEA) ) + ! USERO(JSEA,2) = ASF(ISEA) + IF (ETUSSX(JSEA) .NE. 0. .OR. ETUSSY(JSEA) .NE. 0.) THEN - USSX(JSEA) = ETUSSX(JSEA) - USSY(JSEA) = ETUSSY(JSEA) - USSXH(JSEA) = ETUSSXH(JSEA) - USSYH(JSEA) = ETUSSYH(JSEA) + USSX(JSEA) = ETUSSX(JSEA) + USSY(JSEA) = ETUSSY(JSEA) + USSXH(JSEA) = ETUSSXH(JSEA) + USSYH(JSEA) = ETUSSYH(JSEA) - ! this check is to divide by zeror error with gx17 - ! is there a better way to do this check? - IF( SQRT(USSX(JSEA)**2 + USSY(JSEA)**2) .GT. 0) THEN - IF( SQRT(USSXH(JSEA)**2+USSYH(JSEA)**2) .GT. 0) THEN + ! this check is to divide by zeror error with gx17 + ! is there a better way to do this check? + IF( SQRT(USSX(JSEA)**2 + USSY(JSEA)**2) .GT. 0) THEN + IF( SQRT(USSXH(JSEA)**2+USSYH(JSEA)**2) .GT. 0) THEN - LANGMT(JSEA) = SQRT ( UST(ISEA) * ASF(ISEA) & - * SQRT ( DAIR / DWAT ) & - / SQRT ( USSX(JSEA)**2 + USSY(JSEA)**2 ) ) - ! Calculating Langmuir Number for misaligned wind and waves - ! see Van Roekel et al., 2012 - ! take z1 = 4 * HS - ! SWW: angle between Stokes drift and wind + LANGMT(JSEA) = SQRT ( UST(ISEA) * ASF(ISEA) & + * SQRT ( DAIR / DWAT ) & + / SQRT ( USSX(JSEA)**2 + USSY(JSEA)**2 ) ) + ! Calculating Langmuir Number for misaligned wind and waves + ! see Van Roekel et al., 2012 + ! take z1 = 4 * HS + ! SWW: angle between Stokes drift and wind - ! no Stokes depth - SWW = ATAN2(USSY(JSEA),USSX(JSEA)) - UD(ISEA) - ! ALPHALS: angle between wind and LC direction, Surface - ! Stokes drift - ! LR check for divide by zero - if ((LANGMT(JSEA)**2 & - /0.4*LOG(MAX(ABS(HML(IX,IY)/4./HS(JSEA)),1.0))+COS(SWW)).eq.0.) then - print *, 'LR warning A denom 0.' - ! This appears to be a decimal precision error - ! The first term equals minus the second term to 6 decimal places - ! The denominator should be a very small number (e-7) - ! ATAN(sin(sww)/small number) tends to pi/2 - ! So I hardcoded this here. - ALPHALS(JSEA) = -1.5707956594501575 - else + ! no Stokes depth + SWW = ATAN2(USSY(JSEA),USSX(JSEA)) - UD(ISEA) + ! ALPHALS: angle between wind and LC direction, Surface + ! Stokes drift + ! LR check for divide by zero + if ((LANGMT(JSEA)**2 & + /0.4*LOG(MAX(ABS(HML(IX,IY)/4./HS(JSEA)),1.0))+COS(SWW)).eq.0.) then + print *, 'LR warning A denom 0.' + ! This appears to be a decimal precision error + ! The first term equals minus the second term to 6 decimal places + ! The denominator should be a very small number (e-7) + ! ATAN(sin(sww)/small number) tends to pi/2 + ! So I hardcoded this here. + ALPHALS(JSEA) = -1.5707956594501575 + else - ALPHALS(JSEA) = ATAN(SIN(SWW) / (LANGMT(JSEA)**2 & - /0.4*LOG(MAX(ABS(HML(IX,IY)/4./HS(JSEA)),1.0))+COS(SWW))) - end if + ALPHALS(JSEA) = ATAN(SIN(SWW) / (LANGMT(JSEA)**2 & + /0.4*LOG(MAX(ABS(HML(IX,IY)/4./HS(JSEA)),1.0))+COS(SWW))) + end if - ALPHALS(JSEA) = ATAN( SIN(SWW) / ( LANGMT(JSEA)**2 & - /0.4*LOG(MAX(ABS(HML(IX,IY)/4./HS(JSEA)),1.0))+COS(SWW))) - LAPROJ(JSEA) = LANGMT(JSEA) & - * SQRT(ABS(COS(ALPHALS(JSEA))) & - / ABS(COS(SWW-ALPHALS(JSEA)))) - ! Stokes depth - SWW = ATAN2(USSYH(JSEA),USSXH(JSEA)) - UD(ISEA) - ! ALPHAL: angle between wind and LC direction + ALPHALS(JSEA) = ATAN( SIN(SWW) / ( LANGMT(JSEA)**2 & + /0.4*LOG(MAX(ABS(HML(IX,IY)/4./HS(JSEA)),1.0))+COS(SWW))) + LAPROJ(JSEA) = LANGMT(JSEA) & + * SQRT(ABS(COS(ALPHALS(JSEA))) & + / ABS(COS(SWW-ALPHALS(JSEA)))) + ! Stokes depth + SWW = ATAN2(USSYH(JSEA),USSXH(JSEA)) - UD(ISEA) + ! ALPHAL: angle between wind and LC direction - ! LR check for divide by zero (same as above) - if ((LANGMT(JSEA)**2 & - /0.4*LOG(MAX(ABS(HML(IX,IY)/4./HS(JSEA)),1.0))+COS(SWW)).eq.0.) then - print *, 'LR warning B denom 0.' - ALPHAL(JSEA) = -1.5707956594501575 - else + ! LR check for divide by zero (same as above) + if ((LANGMT(JSEA)**2 & + /0.4*LOG(MAX(ABS(HML(IX,IY)/4./HS(JSEA)),1.0))+COS(SWW)).eq.0.) then + print *, 'LR warning B denom 0.' + ALPHAL(JSEA) = -1.5707956594501575 + else - ALPHAL(JSEA) = ATAN(SIN(SWW) / (LANGMT(JSEA)**2 & - /0.4*LOG(MAX(ABS(HML(IX,IY)/4./HS(JSEA)),1.0))+COS(SWW))) - end if - LASL(JSEA) = SQRT(UST(ISEA)*ASF(ISEA) & - * SQRT(DAIR/DWAT) & - / SQRT(USSXH(JSEA)**2+USSYH(JSEA)**2)) - LASLPJ(JSEA) = LASL(JSEA) * SQRT(ABS(COS(ALPHAL(JSEA))) & - / ABS(COS(SWW-ALPHAL(JSEA)))) - ! LAMULT - LAMULT(JSEA) = MIN(5.0, ABS(COS(ALPHAL(JSEA))) * & - SQRT(1.0+(1.5*LASLPJ(JSEA))**(-2)+(5.4*real(LASLPJ(JSEA),kind=8))**(-4))) - ! user defined output - USERO(JSEA,1) = HML(IX,IY) - !USERO(JSEA,2) = COS(ALPHAL(JSEA) - END IF - END IF + ALPHAL(JSEA) = ATAN(SIN(SWW) / (LANGMT(JSEA)**2 & + /0.4*LOG(MAX(ABS(HML(IX,IY)/4./HS(JSEA)),1.0))+COS(SWW))) + end if + LASL(JSEA) = SQRT(UST(ISEA)*ASF(ISEA) & + * SQRT(DAIR/DWAT) & + / SQRT(USSXH(JSEA)**2+USSYH(JSEA)**2)) + LASLPJ(JSEA) = LASL(JSEA) * SQRT(ABS(COS(ALPHAL(JSEA))) & + / ABS(COS(SWW-ALPHAL(JSEA)))) + ! LAMULT + LAMULT(JSEA) = MIN(5.0, ABS(COS(ALPHAL(JSEA))) * & + SQRT(1.0+(1.5*LASLPJ(JSEA))**(-2)+(5.4*real(LASLPJ(JSEA),kind=8))**(-4))) + ! user defined output + USERO(JSEA,1) = HML(IX,IY) + !USERO(JSEA,2) = COS(ALPHAL(JSEA) END IF -#endif -! -! Add here USERO(JSEA,1) ... -! END IF - END DO -! + END IF +#endif + ! + ! Add here USERO(JSEA,1) ... + ! + END IF + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! -! 3.b Clean-up small values if !/O8 switch selected -! + ! + ! 3.b Clean-up small values if !/O8 switch selected + ! #ifdef W3_O8 - DO JSEA=1, NSEAL - IF ( HS(JSEA).LE.HSMIN .AND. HS(JSEA).NE.UNDEF) THEN - WLM(JSEA) = UNDEF - T02(JSEA) = UNDEF - T0M1(JSEA) = UNDEF - THM(JSEA) = UNDEF - THS(JSEA) = UNDEF - END IF - END DO + DO JSEA=1, NSEAL + IF ( HS(JSEA).LE.HSMIN .AND. HS(JSEA).NE.UNDEF) THEN + WLM(JSEA) = UNDEF + T02(JSEA) = UNDEF + T0M1(JSEA) = UNDEF + THM(JSEA) = UNDEF + THS(JSEA) = UNDEF + END IF + END DO #endif -! -! 4. Peak frequencies and directions -------------------------------- * -! 4.a Initialize -! + ! + ! 4. Peak frequencies and directions -------------------------------- * + ! 4.a Initialize + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA) + !$OMP PARALLEL DO PRIVATE(JSEA) #endif -! - DO JSEA=1, NSEAL - EC (JSEA) = EBD(NK,JSEA) - FP0 (JSEA) = UNDEF - IKP0(JSEA) = NK - THP0(JSEA) = UNDEF - END DO -! + ! + DO JSEA=1, NSEAL + EC (JSEA) = EBD(NK,JSEA) + FP0 (JSEA) = UNDEF + IKP0(JSEA) = NK + THP0(JSEA) = UNDEF + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! -! 4.b Discrete peak frequencies -! - DO IK=NK-1, 1, -1 -! + ! + ! 4.b Discrete peak frequencies + ! + DO IK=NK-1, 1, -1 + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA) + !$OMP PARALLEL DO PRIVATE(JSEA) #endif -! - DO JSEA=1, NSEAL - IF ( EC(JSEA) .LT. EBD(IK,JSEA) ) THEN - EC (JSEA) = EBD(IK,JSEA) - IKP0(JSEA) = IK - END IF - END DO -! + ! + DO JSEA=1, NSEAL + IF ( EC(JSEA) .LT. EBD(IK,JSEA) ) THEN + EC (JSEA) = EBD(IK,JSEA) + IKP0(JSEA) = IK + END IF + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - END DO -! + ! + END DO + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA) + !$OMP PARALLEL DO PRIVATE(JSEA) #endif -! - DO JSEA=1, NSEAL - IF ( IKP0(JSEA) .NE. NK ) FP0(JSEA) = SIG(IKP0(JSEA)) * TPIINV - END DO -! + ! + DO JSEA=1, NSEAL + IF ( IKP0(JSEA) .NE. NK ) FP0(JSEA) = SIG(IKP0(JSEA)) * TPIINV + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! -! 4.c Continuous peak frequencies -! - XL = 1./XFR - 1. - XH = XFR - 1. - XL2 = XL**2 - XH2 = XH**2 -! + ! + ! 4.c Continuous peak frequencies + ! + XL = 1./XFR - 1. + XH = XFR - 1. + XL2 = XL**2 + XH2 = XH**2 + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA,EL,EH,DENOM) + !$OMP PARALLEL DO PRIVATE(JSEA,EL,EH,DENOM) #endif -! - DO JSEA=1, NSEAL - IF ( IKP0(JSEA) .NE. NK ) THEN - IF ( IKP0(JSEA) .EQ. 1 ) THEN - EL = - EBD(IKP0(JSEA), JSEA) - ELSE - EL = EBD(IKP0(JSEA)-1, JSEA) - EBD(IKP0(JSEA), JSEA) - END IF + ! + DO JSEA=1, NSEAL + IF ( IKP0(JSEA) .NE. NK ) THEN + IF ( IKP0(JSEA) .EQ. 1 ) THEN + EL = - EBD(IKP0(JSEA), JSEA) + ELSE + EL = EBD(IKP0(JSEA)-1, JSEA) - EBD(IKP0(JSEA), JSEA) + END IF - EH = EBD(IKP0(JSEA)+1, JSEA) - EBD(IKP0(JSEA), JSEA) + EH = EBD(IKP0(JSEA)+1, JSEA) - EBD(IKP0(JSEA), JSEA) - DENOM = XL*EH - XH*EL - FP0(JSEA) = FP0 (JSEA) * ( 1. + 0.5 * ( XL2*EH - XH2*EL ) & - / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) - END IF - END DO -! -#ifdef W3_OMPG -!$OMP END PARALLEL DO -#endif -! -! 4.d Peak directions -! + DENOM = XL*EH - XH*EL + FP0(JSEA) = FP0 (JSEA) * ( 1. + 0.5 * ( XL2*EH - XH2*EL ) & + / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) + END IF + END DO + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA) + !$OMP END PARALLEL DO #endif -! - DO JSEA=1, NSEAL - ETX(JSEA) = 0. - ETY(JSEA) = 0. - END DO -! + ! + ! 4.d Peak directions + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP PARALLEL DO PRIVATE(JSEA) #endif -! - DO ITH=1, NTH -! + ! + DO JSEA=1, NSEAL + ETX(JSEA) = 0. + ETY(JSEA) = 0. + END DO + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA) + !$OMP END PARALLEL DO #endif -! - DO JSEA=1, NSEAL - IF ( IKP0(JSEA) .NE. NK ) THEN - ETX(JSEA) = ETX(JSEA) + A(ITH,IKP0(JSEA),JSEA)*ECOS(ITH) - ETY(JSEA) = ETY(JSEA) + A(ITH,IKP0(JSEA),JSEA)*ESIN(ITH) - END IF - END DO -! + ! + DO ITH=1, NTH + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP PARALLEL DO PRIVATE(JSEA) #endif -! - END DO -! + ! + DO JSEA=1, NSEAL + IF ( IKP0(JSEA) .NE. NK ) THEN + ETX(JSEA) = ETX(JSEA) + A(ITH,IKP0(JSEA),JSEA)*ECOS(ITH) + ETY(JSEA) = ETY(JSEA) + A(ITH,IKP0(JSEA),JSEA)*ESIN(ITH) + END IF + END DO + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA) + !$OMP END PARALLEL DO #endif -! - DO JSEA=1, NSEAL - IF ( ABS(ETX(JSEA))+ABS(ETY(JSEA)) .GT. 1.E-7 .AND. & - FP0(JSEA).NE.UNDEF ) & - THP0(JSEA) = ATAN2(ETY(JSEA),ETX(JSEA)) - ETX(JSEA) = 0. - ETY(JSEA) = 0. - END DO -! + ! + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP PARALLEL DO PRIVATE(JSEA) #endif -! + ! + DO JSEA=1, NSEAL + IF ( ABS(ETX(JSEA))+ABS(ETY(JSEA)) .GT. 1.E-7 .AND. & + FP0(JSEA).NE.UNDEF ) & + THP0(JSEA) = ATAN2(ETY(JSEA),ETX(JSEA)) + ETX(JSEA) = 0. + ETY(JSEA) = 0. + END DO + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,IX,IY) + !$OMP END PARALLEL DO + !$OMP PARALLEL DO PRIVATE(JSEA,ISEA,IX,IY) #endif -! - DO JSEA =1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF ( MAPSTA(IY,IX) .LE. 0 ) THEN - FP0 (JSEA) = UNDEF - THP0(JSEA) = UNDEF - END IF - END DO -! + ! + DO JSEA =1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF ( MAPSTA(IY,IX) .LE. 0 ) THEN + FP0 (JSEA) = UNDEF + THP0(JSEA) = UNDEF + END IF + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! -! 5. Test output (local to MPP only) -! + ! + ! 5. Test output (local to MPP only) + ! #ifdef W3_T - WRITE (NDST,9050) - DO JSEA =1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF ( HS(JSEA) .EQ. UNDEF ) THEN - WRITE (NDST,9051) ISEA, IX, IY - ELSE IF ( WLM(JSEA) .EQ. UNDEF ) THEN - WRITE (NDST,9052) ISEA, IX, IY, HS(JSEA) - ELSE IF ( FP0(JSEA) .EQ. UNDEF ) THEN - WRITE (NDST,9053) ISEA, IX, IY, HS(JSEA), WLM(JSEA), & - T0M1(JSEA), RADE*THM(JSEA), THS(JSEA) - ELSE - WRITE (NDST,9054) ISEA, IX, IY, HS(JSEA), WLM(JSEA), & - T0M1(JSEA), RADE*THM(JSEA), THS(JSEA), FP0(JSEA),& - THP0(JSEA) - END IF - END DO + WRITE (NDST,9050) + DO JSEA =1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF ( HS(JSEA) .EQ. UNDEF ) THEN + WRITE (NDST,9051) ISEA, IX, IY + ELSE IF ( WLM(JSEA) .EQ. UNDEF ) THEN + WRITE (NDST,9052) ISEA, IX, IY, HS(JSEA) + ELSE IF ( FP0(JSEA) .EQ. UNDEF ) THEN + WRITE (NDST,9053) ISEA, IX, IY, HS(JSEA), WLM(JSEA), & + T0M1(JSEA), RADE*THM(JSEA), THS(JSEA) + ELSE + WRITE (NDST,9054) ISEA, IX, IY, HS(JSEA), WLM(JSEA), & + T0M1(JSEA), RADE*THM(JSEA), THS(JSEA), FP0(JSEA),& + THP0(JSEA) + END IF + END DO #endif -! -! 6. Fill arrays wth partitioned data -! - IF ( FLPART ) THEN -! -! 6.a Initializations -! - PHS = UNDEF - PTP = UNDEF - PLP = UNDEF - PDIR = UNDEF - PSI = UNDEF - PWS = UNDEF - PWST = UNDEF - PNR = UNDEF - PTHP0 = UNDEF - PQP = UNDEF - PPE = UNDEF - PGW = UNDEF - PSW = UNDEF - PTM1 = UNDEF - PT1 = UNDEF - PT2 = UNDEF - PEP = UNDEF -! -! 6.b Loop over local sea points -! + ! + ! 6. Fill arrays wth partitioned data + ! + IF ( FLPART ) THEN + ! + ! 6.a Initializations + ! + PHS = UNDEF + PTP = UNDEF + PLP = UNDEF + PDIR = UNDEF + PSI = UNDEF + PWS = UNDEF + PWST = UNDEF + PNR = UNDEF + PTHP0 = UNDEF + PQP = UNDEF + PPE = UNDEF + PGW = UNDEF + PSW = UNDEF + PTM1 = UNDEF + PT1 = UNDEF + PT2 = UNDEF + PEP = UNDEF + ! + ! 6.b Loop over local sea points + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(ISEA,JSEA,IX,IY,I,J) + !$OMP PARALLEL DO PRIVATE(ISEA,JSEA,IX,IY,I,J) #endif -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) -! - IF ( MAPSTA(IY,IX).GT.0 ) THEN - I = ICPRT(JSEA,2) - PNR(JSEA) = MAX ( 0. , REAL(ICPRT(JSEA,1)-1) ) - IF ( ICPRT(JSEA,1).GE.1 ) PWST(JSEA) = DTPRT(6,I) - END IF -! - IF ( MAPSTA(IY,IX).GT.0 .AND. ICPRT(JSEA,1).GT.1 ) THEN - I = ICPRT(JSEA,2) + 1 - IF ( DTPRT(6,I) .GE. WSCUT ) THEN - PHS(JSEA,0) = DTPRT(1,I) - PTP(JSEA,0) = DTPRT(2,I) - PLP(JSEA,0) = DTPRT(3,I) - ! (PDIR is already in degrees nautical - convert back to - ! Cartesian in radians to maintain internal convention) - IF(DTPRT(4,I) .NE. UNDEF) THEN - PDIR(JSEA,0) = (270. - DTPRT(4,I)) * DERA - ENDIF - PSI(JSEA,0) = DTPRT(5,I) - PWS(JSEA,0) = DTPRT(6,I) - ! (PTHP0 is already in degrees nautical - convert back to - ! Cartesian in radians to maintain internal convention) - IF(DTPRT(7,I) .NE. UNDEF) THEN - PTHP0(JSEA,0) = (270. - DTPRT(7,I)) * DERA - ENDIF - PSW(JSEA,0) = DTPRT(8,I) - PPE(JSEA,0) = DTPRT(9,I) - PQP(JSEA,0) = DTPRT(10,I) - PGW(JSEA,0) = DTPRT(11,I) - PTM1(JSEA,0) = DTPRT(12,I) - PT1(JSEA,0) = DTPRT(13,I) - PT2(JSEA,0) = DTPRT(14,I) - PEP(JSEA,0) = DTPRT(15,I) - I = I + 1 - END IF - DO J=1, NOSWLL - IF ( I .GT. ICPRT(JSEA,2)+ICPRT(JSEA,1)-1 ) EXIT - PHS(JSEA,J) = DTPRT(1,I) - PTP(JSEA,J) = DTPRT(2,I) - PLP(JSEA,J) = DTPRT(3,I) - ! (PDIR is already in degrees nautical - convert back to - ! Cartesian in radians to maintain internal convention) - IF(DTPRT(4,I) .NE. UNDEF) THEN - PDIR(JSEA,J) = (270. - DTPRT(4,I)) * DERA - ENDIF - PSI(JSEA,J) = DTPRT(5,I) - PWS(JSEA,J) = DTPRT(6,I) - ! (PTHP0 is already in degrees nautical - convert back to - ! Cartesian in radians to maintain internal convention) - IF(DTPRT(7,I) .NE. UNDEF) THEN - PTHP0(JSEA,J) = (270. - DTPRT(7,I)) * DERA - ENDIF - PSW(JSEA,J) = DTPRT(8,I) - PPE(JSEA,J) = DTPRT(9,I) - PQP(JSEA,J) = DTPRT(10,I) - PGW(JSEA,J) = DTPRT(11,I) - PTM1(JSEA,J) = DTPRT(12,I) - PT1(JSEA,J) = DTPRT(13,I) - PT2(JSEA,J) = DTPRT(14,I) - PEP(JSEA,J) = DTPRT(15,I) - I = I + 1 - END DO - END IF -! - END DO -! + ! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + ! + IF ( MAPSTA(IY,IX).GT.0 ) THEN + I = ICPRT(JSEA,2) + PNR(JSEA) = MAX ( 0. , REAL(ICPRT(JSEA,1)-1) ) + IF ( ICPRT(JSEA,1).GE.1 ) PWST(JSEA) = DTPRT(6,I) + END IF + ! + IF ( MAPSTA(IY,IX).GT.0 .AND. ICPRT(JSEA,1).GT.1 ) THEN + I = ICPRT(JSEA,2) + 1 + IF ( DTPRT(6,I) .GE. WSCUT ) THEN + PHS(JSEA,0) = DTPRT(1,I) + PTP(JSEA,0) = DTPRT(2,I) + PLP(JSEA,0) = DTPRT(3,I) + ! (PDIR is already in degrees nautical - convert back to + ! Cartesian in radians to maintain internal convention) + IF(DTPRT(4,I) .NE. UNDEF) THEN + PDIR(JSEA,0) = (270. - DTPRT(4,I)) * DERA + ENDIF + PSI(JSEA,0) = DTPRT(5,I) + PWS(JSEA,0) = DTPRT(6,I) + ! (PTHP0 is already in degrees nautical - convert back to + ! Cartesian in radians to maintain internal convention) + IF(DTPRT(7,I) .NE. UNDEF) THEN + PTHP0(JSEA,0) = (270. - DTPRT(7,I)) * DERA + ENDIF + PSW(JSEA,0) = DTPRT(8,I) + PPE(JSEA,0) = DTPRT(9,I) + PQP(JSEA,0) = DTPRT(10,I) + PGW(JSEA,0) = DTPRT(11,I) + PTM1(JSEA,0) = DTPRT(12,I) + PT1(JSEA,0) = DTPRT(13,I) + PT2(JSEA,0) = DTPRT(14,I) + PEP(JSEA,0) = DTPRT(15,I) + I = I + 1 + END IF + DO J=1, NOSWLL + IF ( I .GT. ICPRT(JSEA,2)+ICPRT(JSEA,1)-1 ) EXIT + PHS(JSEA,J) = DTPRT(1,I) + PTP(JSEA,J) = DTPRT(2,I) + PLP(JSEA,J) = DTPRT(3,I) + ! (PDIR is already in degrees nautical - convert back to + ! Cartesian in radians to maintain internal convention) + IF(DTPRT(4,I) .NE. UNDEF) THEN + PDIR(JSEA,J) = (270. - DTPRT(4,I)) * DERA + ENDIF + PSI(JSEA,J) = DTPRT(5,I) + PWS(JSEA,J) = DTPRT(6,I) + ! (PTHP0 is already in degrees nautical - convert back to + ! Cartesian in radians to maintain internal convention) + IF(DTPRT(7,I) .NE. UNDEF) THEN + PTHP0(JSEA,J) = (270. - DTPRT(7,I)) * DERA + ENDIF + PSW(JSEA,J) = DTPRT(8,I) + PPE(JSEA,J) = DTPRT(9,I) + PQP(JSEA,J) = DTPRT(10,I) + PGW(JSEA,J) = DTPRT(11,I) + PTM1(JSEA,J) = DTPRT(12,I) + PT1(JSEA,J) = DTPRT(13,I) + PT2(JSEA,J) = DTPRT(14,I) + PEP(JSEA,J) = DTPRT(15,I) + I = I + 1 + END DO + END IF + ! + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! + ! - END IF + END IF - IF (FLOLOC( 6, 8)) THEN - CALL CALC_U3STOKES(A,1) - END IF -! - IF (FLOLOC( 6, 12)) THEN - CALL CALC_U3STOKES(A,2) - ENDIF -! -! Dominant wave breaking probability -! - IF (FLOLOC(2, 17)) CALL CALC_WBT(A) -! - RETURN -! -! Formats -! + IF (FLOLOC( 6, 8)) THEN + CALL CALC_U3STOKES(A,1) + END IF + ! + IF (FLOLOC( 6, 12)) THEN + CALL CALC_U3STOKES(A,2) + ENDIF + ! + ! Dominant wave breaking probability + ! + IF (FLOLOC(2, 17)) CALL CALC_WBT(A) + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9050 FORMAT (' TEST W3OUTG : ISEA, IX, IY, HS, L, Tm, THm, THs', & - ', FP0, THP0') - 9051 FORMAT (2X,I8,2I8) - 9052 FORMAT (2X,I8,2I8,F6.2) - 9053 FORMAT (2X,I8,2I8,F6.2,F7.1,F6.2,2F6.1) - 9054 FORMAT (2X,I8,2I8,F6.2,F7.1,F6.2,2F6.1,F6.3,F6.0) +9050 FORMAT (' TEST W3OUTG : ISEA, IX, IY, HS, L, Tm, THm, THs', & + ', FP0, THP0') +9051 FORMAT (2X,I8,2I8) +9052 FORMAT (2X,I8,2I8,F6.2) +9053 FORMAT (2X,I8,2I8,F6.2,F7.1,F6.2,2F6.1) +9054 FORMAT (2X,I8,2I8,F6.2,F7.1,F6.2,2F6.1,F6.3,F6.0) #endif -!/ -!/ End of W3OUTG ----------------------------------------------------- / -!/ - END SUBROUTINE W3OUTG -!/ ------------------------------------------------------------------- / -!/ -!> -!> @brief Read/write gridded output. -!> -!> @details Fields in file are determined by flags in FLOGRD in W3ODATMD. -!> -!> @param[inout] INXOUT Test string for read/write. -!> @param[inout] NDSOG File unit number. -!> @param[inout] IOTST Test indictor for reading. -!> @param[inout] IMOD Model number for W3GDAT etc. -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 04-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 24-Jan-2001 : Flat grid version (formats only) ( version 2.06 ) -!/ 23-Apr-2002 : Clean up ( version 2.19 ) -!/ 29-Apr-2002 : Add output types 17-18. ( version 2.20 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 25-Oct-2004 : Multiple grid version. ( version 3.06 ) -!/ 27-Jun-2005 : Adding MAPST2. ( version 3.07 ) -!/ 21-Jul-2005 : Adding output fields 19-21. ( version 3.07 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 02-Apr-2007 : Adding partitioned output. ( version 3.11 ) -!/ Adding user slots for outputs. -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 31-Oct-2010 : Implement unstructured grids ( version 3.14 ) -!/ (A. Roland and F. Ardhuin) -!/ 05-Feb-2011 : Renumbering of output fields ( version 3.14 ) -!/ (F. Ardhuin) -!/ 25-Dec-2012 : New output structure and smaller ( version 4.11 ) -!/ memory footprint. -!/ 21-Aug-2013 : Added missing cos,sin for UBA, ABA ( version 4.11 ) -!/ 27-Nov-2013 : Management of coupling output ( version 4.18 ) -!/ 01-Mar-2018 : Removed RTD code (now used in post ( version 6.02 ) -!/ processing code) -!/ 25-Aug-2018 : Add WBT parameter ( version 6.06 ) -!/ 22-Mar-2021 : Add extra coupling fields as output ( version 7.13 ) -!/ -! 1. Purpose : -! -! Read/write gridded output. -! -! 2. Method : -! -! Fields in file are determined by flags in FLOGRD in W3ODATMD. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ' and 'WRITE'. -! NDSOG Int. I File unit number. -! IOTST Int. O Test indictor for reading. -! 0 : Fields read. -! -1 : Past end of file. -! IMOD Int. I Model number for W3GDAT etc. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation above. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! WW3_OUTF Prog. N/A Ouput postprocessor. -! WW3_GRIB Prog. N/A Ouput postprocessor. -! GX_OUTF Prog. N/A Ouput postprocessor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! Tests on INXOUT, file status and on array dimensions. -! -! 7. Remarks : -! -! - MAPSTA is dumped as it contains information on the ice edge. -! Dynamic ice edges require MAPSTA to be dumped every time step. -! - The output file has the pre-defined name 'out_grd.FILEXT'. -! - The current components CX and CY are written to out_grd as -! components, but converted to magnitude and direction in most -! gridded and point output post-processors (except gx_outf). -! - All written direction are in degrees, nautical convention, -! but in reading, all is convered back to radians and cartesian -! conventions. -! - Before writing, wind and current directions are converted, -! wave directions are already in correct convention (see W3OUTG). -! - In MPP version of model data is supposed to be gatherd at the -! correct processor before the routine is called. -! - In MPP version routine is called by only one process, therefore -! no test on process for error messages is needed. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/ST1 First source term package (WAM3). -! !/ST2 Second source term package (TC96). -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD -!/ - USE W3WDATMD, ONLY: W3SETW, W3DIMW - USE W3ADATMD, ONLY: W3SETA, W3DIMA, W3XETA - USE W3ODATMD, ONLY: W3SETO -!/ - USE W3WDATMD, ONLY: TIME, DINIT, WLV, ICE, ICEF, ICEH, BERG, & - UST, USTDIR, ASF, RHOAIR - USE W3ADATMD, ONLY: AINIT, DW, UA, UD, AS, CX, CY, WN, & - TAUA, TAUADIR - USE W3ADATMD, ONLY: HS, WLM, T02, T0M1, T01, FP0, THM, THS, THP0,& - WBT, WNMEAN - USE W3ADATMD, ONLY: DTDYN, FCUT, ABA, ABD, UBA, UBD, SXX, SYY, SXY,& - PHS, PTP, PLP, PDIR, PSI, PWS, PWST, PNR, & - PTHP0, PQP, PPE, PGW, PSW, PTM1, PT1, PT2, & - PEP, USERO, TAUOX, TAUOY, TAUWIX, TAUWIY, & - PHIAW, PHIOC, TUSX, TUSY, PRMS, TPMS, & - USSX, USSY, MSSX, MSSY, MSSD, MSCX, MSCY, & - MSCD, QP, TAUWNX, TAUWNY, CHARN, TWS, BHD, & - PHIBBL, TAUBBL, WHITECAP, BEDFORMS, CGE, EF, & - CFLXYMAX, CFLTHMAX, CFLKMAX, P2SMS, US3D, & - TH1M, STH1M, TH2M, STH2M, HSIG, PHICE, TAUICE,& - STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD, HCMAXD,& - USSP, TAUOCX, TAUOCY -!/ - USE W3ODATMD, ONLY: NOGRP, NGRPP, IDOUT, UNDEF, NDST, NDSE, & - FLOGRD, IPASS => IPASS1, WRITE => WRITE1, & - FNMPRE, NOSWLL, NOEXTR -!/ - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, only : IAPROC - USE W3ODATMD, ONLY : OFILES + !/ + !/ End of W3OUTG ----------------------------------------------------- / + !/ + END SUBROUTINE W3OUTG + !/ ------------------------------------------------------------------- / + !/ + !> + !> @brief Read/write gridded output. + !> + !> @details Fields in file are determined by flags in FLOGRD in W3ODATMD. + !> + !> @param[inout] INXOUT Test string for read/write. + !> @param[inout] NDSOG File unit number. + !> @param[inout] IOTST Test indictor for reading. + !> @param[inout] IMOD Model number for W3GDAT etc. + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 04-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 24-Jan-2001 : Flat grid version (formats only) ( version 2.06 ) + !/ 23-Apr-2002 : Clean up ( version 2.19 ) + !/ 29-Apr-2002 : Add output types 17-18. ( version 2.20 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 25-Oct-2004 : Multiple grid version. ( version 3.06 ) + !/ 27-Jun-2005 : Adding MAPST2. ( version 3.07 ) + !/ 21-Jul-2005 : Adding output fields 19-21. ( version 3.07 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 02-Apr-2007 : Adding partitioned output. ( version 3.11 ) + !/ Adding user slots for outputs. + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 31-Oct-2010 : Implement unstructured grids ( version 3.14 ) + !/ (A. Roland and F. Ardhuin) + !/ 05-Feb-2011 : Renumbering of output fields ( version 3.14 ) + !/ (F. Ardhuin) + !/ 25-Dec-2012 : New output structure and smaller ( version 4.11 ) + !/ memory footprint. + !/ 21-Aug-2013 : Added missing cos,sin for UBA, ABA ( version 4.11 ) + !/ 27-Nov-2013 : Management of coupling output ( version 4.18 ) + !/ 01-Mar-2018 : Removed RTD code (now used in post ( version 6.02 ) + !/ processing code) + !/ 25-Aug-2018 : Add WBT parameter ( version 6.06 ) + !/ 22-Mar-2021 : Add extra coupling fields as output ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Read/write gridded output. + ! + ! 2. Method : + ! + ! Fields in file are determined by flags in FLOGRD in W3ODATMD. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'READ' and 'WRITE'. + ! NDSOG Int. I File unit number. + ! IOTST Int. O Test indictor for reading. + ! 0 : Fields read. + ! -1 : Past end of file. + ! IMOD Int. I Model number for W3GDAT etc. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation above. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! WW3_OUTF Prog. N/A Ouput postprocessor. + ! WW3_GRIB Prog. N/A Ouput postprocessor. + ! GX_OUTF Prog. N/A Ouput postprocessor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! Tests on INXOUT, file status and on array dimensions. + ! + ! 7. Remarks : + ! + ! - MAPSTA is dumped as it contains information on the ice edge. + ! Dynamic ice edges require MAPSTA to be dumped every time step. + ! - The output file has the pre-defined name 'out_grd.FILEXT'. + ! - The current components CX and CY are written to out_grd as + ! components, but converted to magnitude and direction in most + ! gridded and point output post-processors (except gx_outf). + ! - All written direction are in degrees, nautical convention, + ! but in reading, all is convered back to radians and cartesian + ! conventions. + ! - Before writing, wind and current directions are converted, + ! wave directions are already in correct convention (see W3OUTG). + ! - In MPP version of model data is supposed to be gatherd at the + ! correct processor before the routine is called. + ! - In MPP version routine is called by only one process, therefore + ! no test on process for error messages is needed. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/ST1 First source term package (WAM3). + ! !/ST2 Second source term package (TC96). + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD + !/ + USE W3WDATMD, ONLY: W3SETW, W3DIMW + USE W3ADATMD, ONLY: W3SETA, W3DIMA, W3XETA + USE W3ODATMD, ONLY: W3SETO + !/ + USE W3WDATMD, ONLY: TIME, DINIT, WLV, ICE, ICEF, ICEH, BERG, & + UST, USTDIR, ASF, RHOAIR + USE W3ADATMD, ONLY: AINIT, DW, UA, UD, AS, CX, CY, WN, & + TAUA, TAUADIR + USE W3ADATMD, ONLY: HS, WLM, T02, T0M1, T01, FP0, THM, THS, THP0,& + WBT, WNMEAN + USE W3ADATMD, ONLY: DTDYN, FCUT, ABA, ABD, UBA, UBD, SXX, SYY, SXY,& + PHS, PTP, PLP, PDIR, PSI, PWS, PWST, PNR, & + PTHP0, PQP, PPE, PGW, PSW, PTM1, PT1, PT2, & + PEP, USERO, TAUOX, TAUOY, TAUWIX, TAUWIY, & + PHIAW, PHIOC, TUSX, TUSY, PRMS, TPMS, & + USSX, USSY, MSSX, MSSY, MSSD, MSCX, MSCY, & + MSCD, QP, TAUWNX, TAUWNY, CHARN, TWS, BHD, & + PHIBBL, TAUBBL, WHITECAP, BEDFORMS, CGE, EF, & + CFLXYMAX, CFLTHMAX, CFLKMAX, P2SMS, US3D, & + TH1M, STH1M, TH2M, STH2M, HSIG, PHICE, TAUICE,& + STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD, HCMAXD,& + USSP, TAUOCX, TAUOCY + !/ + USE W3ODATMD, ONLY: NOGRP, NGRPP, IDOUT, UNDEF, NDST, NDSE, & + FLOGRD, IPASS => IPASS1, WRITE => WRITE1, & + FNMPRE, NOSWLL, NOEXTR + !/ + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, only : IAPROC + USE W3ODATMD, ONLY : OFILES #ifdef W3_SETUP - USE W3WDATMD, ONLY: ZETA_SETUP + USE W3WDATMD, ONLY: ZETA_SETUP #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - use w3timemd , only: set_user_timestring - use w3odatmd , only: use_user_histname, user_histfname -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(INOUT) :: IOTST - INTEGER, INTENT(IN) :: NDSOG - INTEGER, INTENT(IN), OPTIONAL :: IMOD - CHARACTER, INTENT(IN) :: INXOUT*(*) - CHARACTER(LEN=15) :: TIMETAG -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IGRD, IERR, I, J, IX, IY, MOGRP, & - MGRPP, ISEA, MOSWLL, IK, IFI, IFJ & - ,IFILOUT - INTEGER, ALLOCATABLE :: MAPTMP(:,:) + use w3timemd , only: set_user_timestring + use w3odatmd , only: use_user_histname, user_histfname + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(INOUT) :: IOTST + INTEGER, INTENT(IN) :: NDSOG + INTEGER, INTENT(IN), OPTIONAL :: IMOD + CHARACTER, INTENT(IN) :: INXOUT*(*) + CHARACTER(LEN=15) :: TIMETAG + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IGRD, IERR, I, J, IX, IY, MOGRP, & + MGRPP, ISEA, MOSWLL, IK, IFI, IFJ & + ,IFILOUT + INTEGER, ALLOCATABLE :: MAPTMP(:,:) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: AUX1(NSEA), AUX2(NSEA), & - AUX3(NSEA), AUX4(NSEA) + REAL :: AUX1(NSEA), AUX2(NSEA), & + AUX3(NSEA), AUX4(NSEA) #ifdef W3_SMC - REAL :: UDARC + REAL :: UDARC #endif - CHARACTER(LEN=30) :: IDTST, TNAME - CHARACTER(LEN=10) :: VERTST - CHARACTER(len=512) :: FNAME - character(len=16) :: user_timestring !YYYY-MM-DD-SSSSS -!/ -!/ ------------------------------------------------------------------- / -!/ + CHARACTER(LEN=30) :: IDTST, TNAME + CHARACTER(LEN=10) :: VERTST + CHARACTER(len=512) :: FNAME + character(len=16) :: user_timestring !YYYY-MM-DD-SSSSS + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3IOGO') + CALL STRACE (IENT, 'W3IOGO') #endif -! -! test input parameters ---------------------------------------------- * -! - IF ( PRESENT(IMOD) ) THEN - IGRD = IMOD - ELSE - IGRD = 1 - END IF -! - CALL W3SETO ( IGRD, NDSE, NDST ) - CALL W3SETG ( IGRD, NDSE, NDST ) - CALL W3SETA ( IGRD, NDSE, NDST ) + ! + ! test input parameters ---------------------------------------------- * + ! + IF ( PRESENT(IMOD) ) THEN + IGRD = IMOD + ELSE + IGRD = 1 + END IF + ! + CALL W3SETO ( IGRD, NDSE, NDST ) + CALL W3SETG ( IGRD, NDSE, NDST ) + CALL W3SETA ( IGRD, NDSE, NDST ) #ifdef W3_MPI - CALL W3XETA ( IGRD, NDSE, NDST ) + CALL W3XETA ( IGRD, NDSE, NDST ) #endif - CALL W3SETW ( IGRD, NDSE, NDST ) -! - IPASS = IPASS + 1 - IOTST = 0 -! - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' ) THEN - WRITE (NDSE,900) INXOUT - CALL EXTCDE ( 1 ) - END IF -! - IF ( IPASS.EQ.1 .AND. OFILES(1) .EQ. 0) THEN - WRITE = INXOUT.EQ.'WRITE' - ELSE - IF ( WRITE .AND. INXOUT.EQ.'READ' ) THEN - WRITE (NDSE,901) INXOUT - CALL EXTCDE ( 2 ) - END IF - END IF -! + CALL W3SETW ( IGRD, NDSE, NDST ) + ! + IPASS = IPASS + 1 + IOTST = 0 + ! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' ) THEN + WRITE (NDSE,900) INXOUT + CALL EXTCDE ( 1 ) + END IF + ! + IF ( IPASS.EQ.1 .AND. OFILES(1) .EQ. 0) THEN + WRITE = INXOUT.EQ.'WRITE' + ELSE + IF ( WRITE .AND. INXOUT.EQ.'READ' ) THEN + WRITE (NDSE,901) INXOUT + CALL EXTCDE ( 2 ) + END IF + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IPASS, INXOUT, WRITE, NDSOG, IGRD, FILEXT + WRITE (NDST,9000) IPASS, INXOUT, WRITE, NDSOG, IGRD, FILEXT #endif -! -! -! open file ---------------------------------------------------------- * -! ( IPASS = 1 ) -! - IF ( IPASS.EQ.1 .AND. OFILES(1) .EQ. 0) THEN - I = LEN_TRIM(FILEXT) - J = LEN_TRIM(FNMPRE) - if (use_user_histname) then - if (len_trim(user_histfname) == 0 ) then - call extcde (60, MSG="user history filename requested"// & + ! + ! + ! open file ---------------------------------------------------------- * + ! ( IPASS = 1 ) + ! + IF ( IPASS.EQ.1 .AND. OFILES(1) .EQ. 0) THEN + I = LEN_TRIM(FILEXT) + J = LEN_TRIM(FNMPRE) + if (use_user_histname) then + if (len_trim(user_histfname) == 0 ) then + call extcde (60, MSG="user history filename requested"// & " but not provided") - end if - call set_user_timestring(time,user_timestring) - fname = trim(user_histfname)//trim(user_timestring) - else - fname = 'out_grd.'//FILEXT(:I) - end if -! -#ifdef W3_T - WRITE (NDST,9001) FNMPRE(:J)//trim(fname) -#endif - IF ( WRITE ) THEN - OPEN (NDSOG,FILE=FNMPRE(:J)//trim(fname), & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) - ELSE - OPEN (NDSOG,FILE=FNMPRE(:J)//trim(fname), & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR,STATUS='OLD') - END IF -! - REWIND ( NDSOG ) -! -! test info --------------------------------------------------------- * -! ( IPASS = 1 ) -! - IF ( WRITE ) THEN - WRITE (NDSOG) & - IDSTR, VEROGR, GNAME, NOGRP, NGRPP, NSEA, NX, NY, & - UNDEF, NOSWLL - ELSE - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - IDTST, VERTST, TNAME, MOGRP, MGRPP, NSEA, NX, NY, & - UNDEF, MOSWLL -! - IF ( IDTST .NE. IDSTR ) THEN - WRITE (NDSE,902) IDTST, IDSTR - CALL EXTCDE ( 20 ) - END IF - IF ( VERTST .NE. VEROGR ) THEN - WRITE (NDSE,903) VERTST, VEROGR - CALL EXTCDE ( 21 ) - END IF - IF ( NOGRP .NE. MOGRP .OR. NGRPP .NE. MGRPP ) THEN - WRITE (NDSE,904) MOGRP, MGRPP, NOGRP, NGRPP - CALL EXTCDE ( 22 ) - END IF - IF ( TNAME .NE. GNAME ) THEN - WRITE (NDSE,905) TNAME, GNAME - END IF - IF ( NOSWLL .NE. MOSWLL ) THEN - WRITE (NDSE,906) MOSWLL, NOSWLL - CALL EXTCDE ( 24 ) - END IF -! - END IF -! + end if + call set_user_timestring(time,user_timestring) + fname = trim(user_histfname)//trim(user_timestring) + else + fname = 'out_grd.'//FILEXT(:I) + end if + ! #ifdef W3_T - WRITE (NDST,9002) IDSTR, VEROGR, GNAME, NSEA, NX, NY, & - UNDEF + WRITE (NDST,9001) FNMPRE(:J)//trim(fname) #endif -! + IF ( WRITE ) THEN + OPEN (NDSOG,FILE=FNMPRE(:J)//trim(fname), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) + ELSE + OPEN (NDSOG,FILE=FNMPRE(:J)//trim(fname), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR,STATUS='OLD') + END IF + ! + REWIND ( NDSOG ) + ! + ! test info --------------------------------------------------------- * + ! ( IPASS = 1 ) + ! + IF ( WRITE ) THEN + WRITE (NDSOG) & + IDSTR, VEROGR, GNAME, NOGRP, NGRPP, NSEA, NX, NY, & + UNDEF, NOSWLL + ELSE + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + IDTST, VERTST, TNAME, MOGRP, MGRPP, NSEA, NX, NY, & + UNDEF, MOSWLL + ! + IF ( IDTST .NE. IDSTR ) THEN + WRITE (NDSE,902) IDTST, IDSTR + CALL EXTCDE ( 20 ) END IF -! -! IN CASE OF GENERATION OF A NEW FILE OUTPUT EVERY DELTA OUTPUT -! open file ---------------------------------------------------------- * -! ( IPASS = 1 ) -! - IF ( IPASS.GE.1 .AND. OFILES(1) .EQ. 1) THEN - WRITE = INXOUT.EQ.'WRITE' - ELSE - IF ( WRITE .AND. INXOUT.EQ.'READ' ) THEN - WRITE (NDSE,901) INXOUT - CALL EXTCDE ( 2 ) - END IF + IF ( VERTST .NE. VEROGR ) THEN + WRITE (NDSE,903) VERTST, VEROGR + CALL EXTCDE ( 21 ) END IF - -! - IF ( IPASS.GE.1 .AND. OFILES(1) .EQ. 1) THEN - I = LEN_TRIM(FILEXT) - J = LEN_TRIM(FNMPRE) - if (use_user_histname) then - if (len_trim(user_histfname) == 0 ) then - call extcde (60, MSG="user history filename requested"// & - " but not provided") - end if - call set_user_timestring(time,user_timestring) - fname = trim(user_histfname)//trim(user_timestring) - else -! -! Create TIMETAG for file name using YYYYMMDD.HHMMS prefix - WRITE(TIMETAG,"(i8.8,'.'i6.6)")TIME(1),TIME(2) + IF ( NOGRP .NE. MOGRP .OR. NGRPP .NE. MGRPP ) THEN + WRITE (NDSE,904) MOGRP, MGRPP, NOGRP, NGRPP + CALL EXTCDE ( 22 ) + END IF + IF ( TNAME .NE. GNAME ) THEN + WRITE (NDSE,905) TNAME, GNAME + END IF + IF ( NOSWLL .NE. MOSWLL ) THEN + WRITE (NDSE,906) MOSWLL, NOSWLL + CALL EXTCDE ( 24 ) + END IF + ! + END IF + ! #ifdef W3_T - WRITE (NDST,9001) FNMPRE(:J)//TIMETAG//'.out_grd.'//FILEXT(:I) + WRITE (NDST,9002) IDSTR, VEROGR, GNAME, NSEA, NX, NY, & + UNDEF #endif - fname = TIMETAG//'.out_grd.'//FILEXT(:I) - end if - IF ( WRITE ) THEN - OPEN (NDSOG,FILE=FNMPRE(:J)//trim(fname), & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) - ELSE - OPEN (NDSOG,FILE=FNMPRE(:J)//'out_grd.'//FILEXT(:I), & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR,STATUS='OLD') - END IF -! - REWIND ( NDSOG ) -! -! test info --------------------------------------------------------- * -! ( IPASS >= 1 & OFILES(1) = 1) -! - IF ( WRITE ) THEN - WRITE (NDSOG) & - IDSTR, VEROGR, GNAME, NOGRP, NGRPP, NSEA, NX, NY, & - UNDEF, NOSWLL - ELSE - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - IDTST, VERTST, TNAME, MOGRP, MGRPP, NSEA, NX, NY, & - UNDEF, MOSWLL -! - IF ( IDTST .NE. IDSTR ) THEN - WRITE (NDSE,902) IDTST, IDSTR - CALL EXTCDE ( 20 ) - END IF - IF ( VERTST .NE. VEROGR ) THEN - WRITE (NDSE,903) VERTST, VEROGR - CALL EXTCDE ( 21 ) - END IF - IF ( NOGRP .NE. MOGRP .OR. NGRPP .NE. MGRPP ) THEN - WRITE (NDSE,904) MOGRP, MGRPP, NOGRP, NGRPP - CALL EXTCDE ( 22 ) - END IF - IF ( TNAME .NE. GNAME ) THEN - WRITE (NDSE,905) TNAME, GNAME - END IF - IF ( NOSWLL .NE. MOSWLL ) THEN - WRITE (NDSE,906) MOSWLL, NOSWLL - CALL EXTCDE ( 24 ) - END IF -! - END IF -! + ! + END IF + ! + ! IN CASE OF GENERATION OF A NEW FILE OUTPUT EVERY DELTA OUTPUT + ! open file ---------------------------------------------------------- * + ! ( IPASS = 1 ) + ! + IF ( IPASS.GE.1 .AND. OFILES(1) .EQ. 1) THEN + WRITE = INXOUT.EQ.'WRITE' + ELSE + IF ( WRITE .AND. INXOUT.EQ.'READ' ) THEN + WRITE (NDSE,901) INXOUT + CALL EXTCDE ( 2 ) + END IF + END IF + + ! + IF ( IPASS.GE.1 .AND. OFILES(1) .EQ. 1) THEN + I = LEN_TRIM(FILEXT) + J = LEN_TRIM(FNMPRE) + if (use_user_histname) then + if (len_trim(user_histfname) == 0 ) then + call extcde (60, MSG="user history filename requested"// & + " but not provided") + end if + call set_user_timestring(time,user_timestring) + fname = trim(user_histfname)//trim(user_timestring) + else + ! + ! Create TIMETAG for file name using YYYYMMDD.HHMMS prefix + WRITE(TIMETAG,"(i8.8,'.'i6.6)")TIME(1),TIME(2) #ifdef W3_T - WRITE (NDST,9002) IDSTR, VEROGR, GNAME, NSEA, NX, NY, & - UNDEF + WRITE (NDST,9001) FNMPRE(:J)//TIMETAG//'.out_grd.'//FILEXT(:I) #endif -! - END IF -! -! TIME and flags ----------------------------------------------------- * -! + fname = TIMETAG//'.out_grd.'//FILEXT(:I) + end if IF ( WRITE ) THEN - WRITE (NDSOG) TIME, FLOGRD - ELSE - READ (NDSOG,END=803,ERR=802,IOSTAT=IERR) TIME, FLOGRD + OPEN (NDSOG,FILE=FNMPRE(:J)//trim(fname), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) + ELSE + OPEN (NDSOG,FILE=FNMPRE(:J)//'out_grd.'//FILEXT(:I), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR,STATUS='OLD') + END IF + ! + REWIND ( NDSOG ) + ! + ! test info --------------------------------------------------------- * + ! ( IPASS >= 1 & OFILES(1) = 1) + ! + IF ( WRITE ) THEN + WRITE (NDSOG) & + IDSTR, VEROGR, GNAME, NOGRP, NGRPP, NSEA, NX, NY, & + UNDEF, NOSWLL + ELSE + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + IDTST, VERTST, TNAME, MOGRP, MGRPP, NSEA, NX, NY, & + UNDEF, MOSWLL + ! + IF ( IDTST .NE. IDSTR ) THEN + WRITE (NDSE,902) IDTST, IDSTR + CALL EXTCDE ( 20 ) + END IF + IF ( VERTST .NE. VEROGR ) THEN + WRITE (NDSE,903) VERTST, VEROGR + CALL EXTCDE ( 21 ) + END IF + IF ( NOGRP .NE. MOGRP .OR. NGRPP .NE. MGRPP ) THEN + WRITE (NDSE,904) MOGRP, MGRPP, NOGRP, NGRPP + CALL EXTCDE ( 22 ) + END IF + IF ( TNAME .NE. GNAME ) THEN + WRITE (NDSE,905) TNAME, GNAME END IF -! + IF ( NOSWLL .NE. MOSWLL ) THEN + WRITE (NDSE,906) MOSWLL, NOSWLL + CALL EXTCDE ( 24 ) + END IF + ! + END IF + ! #ifdef W3_T - WRITE (NDST,9003) TIME, FLOGRD + WRITE (NDST,9002) IDSTR, VEROGR, GNAME, NSEA, NX, NY, & + UNDEF #endif -! -! MAPSTA ------------------------------------------------------------- * -! - ALLOCATE ( MAPTMP(NY,NX) ) - IF ( WRITE ) THEN - MAPTMP = MAPSTA + 8*MAPST2 - WRITE (NDSOG) & - ((MAPTMP(IY,IX),IX=1,NX),IY=1,NY) - ELSE - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - ((MAPTMP(IY,IX),IX=1,NX),IY=1,NY) - MAPSTA = MOD(MAPTMP+2,8) - 2 - MAPST2 = (MAPTMP-MAPSTA) / 8 + ! + END IF + ! + ! TIME and flags ----------------------------------------------------- * + ! + IF ( WRITE ) THEN + WRITE (NDSOG) TIME, FLOGRD + ELSE + READ (NDSOG,END=803,ERR=802,IOSTAT=IERR) TIME, FLOGRD + END IF + ! +#ifdef W3_T + WRITE (NDST,9003) TIME, FLOGRD +#endif + ! + ! MAPSTA ------------------------------------------------------------- * + ! + ALLOCATE ( MAPTMP(NY,NX) ) + IF ( WRITE ) THEN + MAPTMP = MAPSTA + 8*MAPST2 + WRITE (NDSOG) & + ((MAPTMP(IY,IX),IX=1,NX),IY=1,NY) + ELSE + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + ((MAPTMP(IY,IX),IX=1,NX),IY=1,NY) + MAPSTA = MOD(MAPTMP+2,8) - 2 + MAPST2 = (MAPTMP-MAPSTA) / 8 + END IF + DEALLOCATE ( MAPTMP ) + ! + ! Fields ---------------------------------------------- * + ! + ! Initialization ---------------------------------------------- * + ! + IF ( WRITE ) THEN + DO ISEA=1, NSEA + IF ( MAPSTA(MAPSF(ISEA,2),MAPSF(ISEA,1)) .LT. 0 ) THEN + ! + IF ( FLOGRD( 2, 2) ) WLM (ISEA) = UNDEF + IF ( FLOGRD( 2, 3) ) T02 (ISEA) = UNDEF + IF ( FLOGRD( 2, 4) ) T0M1 (ISEA) = UNDEF + IF ( FLOGRD( 2, 5) ) T01 (ISEA) = UNDEF + IF ( FLOGRD( 2, 6) .OR. FLOGRD( 2,18) ) & + FP0 (ISEA) = UNDEF ! FP or TP + IF ( FLOGRD( 2, 7) ) THM (ISEA) = UNDEF + IF ( FLOGRD( 2, 8) ) THS (ISEA) = UNDEF + IF ( FLOGRD( 2, 9) ) THP0 (ISEA) = UNDEF + UST (ISEA) = UNDEF + USTDIR(ISEA) = UNDEF + IF ( FLOGRD( 2,10) ) HSIG (ISEA) = UNDEF + IF ( FLOGRD( 2,11) ) STMAXE(ISEA) = UNDEF + IF ( FLOGRD( 2,12) ) STMAXD(ISEA) = UNDEF + IF ( FLOGRD( 2,13) ) HMAXE (ISEA) = UNDEF + IF ( FLOGRD( 2,14) ) HCMAXE(ISEA) = UNDEF + IF ( FLOGRD( 2,15) ) HMAXD (ISEA) = UNDEF + IF ( FLOGRD( 2,16) ) HCMAXD(ISEA) = UNDEF + IF ( FLOGRD( 2,17) ) WBT (ISEA) = UNDEF + IF ( FLOGRD( 2,19) ) WNMEAN(ISEA) = UNDEF + ! + IF ( FLOGRD( 3, 1) ) EF (ISEA,:) = UNDEF + IF ( FLOGRD( 3, 2) ) TH1M (ISEA,:) = UNDEF + IF ( FLOGRD( 3, 3) ) STH1M(ISEA,:) = UNDEF + IF ( FLOGRD( 3, 4) ) TH2M (ISEA,:) = UNDEF + IF ( FLOGRD( 3, 5) ) STH2M(ISEA,:) = UNDEF + ! + IF ( FLOGRD( 4, 1) ) PHS (ISEA,:) = UNDEF + IF ( FLOGRD( 4, 2) ) PTP (ISEA,:) = UNDEF + IF ( FLOGRD( 4, 3) ) PLP (ISEA,:) = UNDEF + IF ( FLOGRD( 4, 4) ) PDIR (ISEA,:) = UNDEF + IF ( FLOGRD( 4, 5) ) PSI (ISEA,:) = UNDEF + IF ( FLOGRD( 4, 6) ) PWS (ISEA,:) = UNDEF + IF ( FLOGRD( 4, 7) ) PTHP0(ISEA,:) = UNDEF + IF ( FLOGRD( 4, 8) ) PQP (ISEA,:) = UNDEF + IF ( FLOGRD( 4, 9) ) PPE(ISEA,:) = UNDEF + IF ( FLOGRD( 4,10) ) PGW(ISEA,:) = UNDEF + IF ( FLOGRD( 4,11) ) PSW (ISEA,:) = UNDEF + IF ( FLOGRD( 4,12) ) PTM1(ISEA,:) = UNDEF + IF ( FLOGRD( 4,13) ) PT1 (ISEA,:) = UNDEF + IF ( FLOGRD( 4,14) ) PT2 (ISEA,:) = UNDEF + IF ( FLOGRD( 4,15) ) PEP (ISEA,:) = UNDEF + IF ( FLOGRD( 4,16) ) PWST(ISEA ) = UNDEF + IF ( FLOGRD( 4,17) ) PNR (ISEA ) = UNDEF + ! + IF ( FLOGRD( 5, 2) ) CHARN (ISEA) = UNDEF + IF ( FLOGRD( 5, 3) ) CGE (ISEA) = UNDEF + IF ( FLOGRD( 5, 4) ) PHIAW (ISEA) = UNDEF + IF ( FLOGRD( 5, 5) ) THEN + TAUWIX(ISEA) = UNDEF + TAUWIY(ISEA) = UNDEF + END IF + IF ( FLOGRD( 5, 6) ) THEN + TAUWNX(ISEA) = UNDEF + TAUWNY(ISEA) = UNDEF + END IF + IF ( FLOGRD( 5, 7) ) WHITECAP(ISEA,1) = UNDEF + IF ( FLOGRD( 5, 8) ) WHITECAP(ISEA,2) = UNDEF + IF ( FLOGRD( 5, 9) ) WHITECAP(ISEA,3) = UNDEF + IF ( FLOGRD( 5,10) ) WHITECAP(ISEA,4) = UNDEF + ! + IF ( FLOGRD( 6, 1) ) THEN + SXX (ISEA) = UNDEF + SYY (ISEA) = UNDEF + SXY (ISEA) = UNDEF + END IF + IF ( FLOGRD( 6, 2) ) THEN + TAUOX (ISEA) = UNDEF + TAUOY (ISEA) = UNDEF + END IF + IF ( FLOGRD( 6, 3) ) BHD(ISEA) = UNDEF + IF ( FLOGRD( 6, 4) ) PHIOC (ISEA) = UNDEF + IF ( FLOGRD( 6, 5) ) THEN + TUSX (ISEA) = UNDEF + TUSY (ISEA) = UNDEF + END IF + IF ( FLOGRD( 6, 6) ) THEN + USSX (ISEA) = UNDEF + USSY (ISEA) = UNDEF + END IF + IF ( FLOGRD( 6, 7) ) THEN + PRMS (ISEA) = UNDEF + TPMS (ISEA) = UNDEF + END IF + IF ( FLOGRD( 6, 8) ) US3D(ISEA,:) = UNDEF + IF ( FLOGRD( 6, 9) ) P2SMS(ISEA,:) = UNDEF + IF ( FLOGRD( 6, 10) ) TAUICE(ISEA,:) = UNDEF + IF ( FLOGRD( 6, 11) ) PHICE(ISEA) = UNDEF + IF ( FLOGRD( 6, 12) ) USSP(ISEA,:) = UNDEF + IF ( FLOGRD( 6, 13) ) THEN + TAUOCX(ISEA) = UNDEF + TAUOCY(ISEA) = UNDEF + END IF + ! + IF ( FLOGRD( 7, 1) ) THEN + ABA (ISEA) = UNDEF + ABD (ISEA) = UNDEF + END IF + IF ( FLOGRD( 7, 2) ) THEN + UBA (ISEA) = UNDEF + UBD (ISEA) = UNDEF + END IF + IF ( FLOGRD( 7, 3) ) BEDFORMS(ISEA,:) = UNDEF + IF ( FLOGRD( 7, 4) ) PHIBBL(ISEA) = UNDEF + IF ( FLOGRD( 7, 5) ) TAUBBL(ISEA,:) = UNDEF + ! + IF ( FLOGRD( 8, 1) ) THEN + MSSX (ISEA) = UNDEF + MSSY (ISEA) = UNDEF + END IF + IF ( FLOGRD( 8, 2) ) THEN + MSCX (ISEA) = UNDEF + MSCY (ISEA) = UNDEF + END IF + IF ( FLOGRD( 8, 3) ) MSSD (ISEA) = UNDEF + IF ( FLOGRD( 8, 4) ) MSCD (ISEA) = UNDEF + IF ( FLOGRD( 8, 5) ) QP (ISEA) = UNDEF + ! + IF ( FLOGRD( 9, 1) ) DTDYN (ISEA) = UNDEF + IF ( FLOGRD( 9, 2) ) FCUT (ISEA) = UNDEF + IF ( FLOGRD( 9, 3) ) CFLXYMAX(ISEA) = UNDEF + IF ( FLOGRD( 9, 4) ) CFLTHMAX(ISEA) = UNDEF + IF ( FLOGRD( 9, 5) ) CFLKMAX(ISEA) = UNDEF + ! END IF - DEALLOCATE ( MAPTMP ) -! -! Fields ---------------------------------------------- * -! -! Initialization ---------------------------------------------- * -! - IF ( WRITE ) THEN - DO ISEA=1, NSEA - IF ( MAPSTA(MAPSF(ISEA,2),MAPSF(ISEA,1)) .LT. 0 ) THEN -! - IF ( FLOGRD( 2, 2) ) WLM (ISEA) = UNDEF - IF ( FLOGRD( 2, 3) ) T02 (ISEA) = UNDEF - IF ( FLOGRD( 2, 4) ) T0M1 (ISEA) = UNDEF - IF ( FLOGRD( 2, 5) ) T01 (ISEA) = UNDEF - IF ( FLOGRD( 2, 6) .OR. FLOGRD( 2,18) ) & - FP0 (ISEA) = UNDEF ! FP or TP - IF ( FLOGRD( 2, 7) ) THM (ISEA) = UNDEF - IF ( FLOGRD( 2, 8) ) THS (ISEA) = UNDEF - IF ( FLOGRD( 2, 9) ) THP0 (ISEA) = UNDEF - UST (ISEA) = UNDEF - USTDIR(ISEA) = UNDEF - IF ( FLOGRD( 2,10) ) HSIG (ISEA) = UNDEF - IF ( FLOGRD( 2,11) ) STMAXE(ISEA) = UNDEF - IF ( FLOGRD( 2,12) ) STMAXD(ISEA) = UNDEF - IF ( FLOGRD( 2,13) ) HMAXE (ISEA) = UNDEF - IF ( FLOGRD( 2,14) ) HCMAXE(ISEA) = UNDEF - IF ( FLOGRD( 2,15) ) HMAXD (ISEA) = UNDEF - IF ( FLOGRD( 2,16) ) HCMAXD(ISEA) = UNDEF - IF ( FLOGRD( 2,17) ) WBT (ISEA) = UNDEF - IF ( FLOGRD( 2,19) ) WNMEAN(ISEA) = UNDEF -! - IF ( FLOGRD( 3, 1) ) EF (ISEA,:) = UNDEF - IF ( FLOGRD( 3, 2) ) TH1M (ISEA,:) = UNDEF - IF ( FLOGRD( 3, 3) ) STH1M(ISEA,:) = UNDEF - IF ( FLOGRD( 3, 4) ) TH2M (ISEA,:) = UNDEF - IF ( FLOGRD( 3, 5) ) STH2M(ISEA,:) = UNDEF -! - IF ( FLOGRD( 4, 1) ) PHS (ISEA,:) = UNDEF - IF ( FLOGRD( 4, 2) ) PTP (ISEA,:) = UNDEF - IF ( FLOGRD( 4, 3) ) PLP (ISEA,:) = UNDEF - IF ( FLOGRD( 4, 4) ) PDIR (ISEA,:) = UNDEF - IF ( FLOGRD( 4, 5) ) PSI (ISEA,:) = UNDEF - IF ( FLOGRD( 4, 6) ) PWS (ISEA,:) = UNDEF - IF ( FLOGRD( 4, 7) ) PTHP0(ISEA,:) = UNDEF - IF ( FLOGRD( 4, 8) ) PQP (ISEA,:) = UNDEF - IF ( FLOGRD( 4, 9) ) PPE(ISEA,:) = UNDEF - IF ( FLOGRD( 4,10) ) PGW(ISEA,:) = UNDEF - IF ( FLOGRD( 4,11) ) PSW (ISEA,:) = UNDEF - IF ( FLOGRD( 4,12) ) PTM1(ISEA,:) = UNDEF - IF ( FLOGRD( 4,13) ) PT1 (ISEA,:) = UNDEF - IF ( FLOGRD( 4,14) ) PT2 (ISEA,:) = UNDEF - IF ( FLOGRD( 4,15) ) PEP (ISEA,:) = UNDEF - IF ( FLOGRD( 4,16) ) PWST(ISEA ) = UNDEF - IF ( FLOGRD( 4,17) ) PNR (ISEA ) = UNDEF -! - IF ( FLOGRD( 5, 2) ) CHARN (ISEA) = UNDEF - IF ( FLOGRD( 5, 3) ) CGE (ISEA) = UNDEF - IF ( FLOGRD( 5, 4) ) PHIAW (ISEA) = UNDEF - IF ( FLOGRD( 5, 5) ) THEN - TAUWIX(ISEA) = UNDEF - TAUWIY(ISEA) = UNDEF - END IF - IF ( FLOGRD( 5, 6) ) THEN - TAUWNX(ISEA) = UNDEF - TAUWNY(ISEA) = UNDEF - END IF - IF ( FLOGRD( 5, 7) ) WHITECAP(ISEA,1) = UNDEF - IF ( FLOGRD( 5, 8) ) WHITECAP(ISEA,2) = UNDEF - IF ( FLOGRD( 5, 9) ) WHITECAP(ISEA,3) = UNDEF - IF ( FLOGRD( 5,10) ) WHITECAP(ISEA,4) = UNDEF -! - IF ( FLOGRD( 6, 1) ) THEN - SXX (ISEA) = UNDEF - SYY (ISEA) = UNDEF - SXY (ISEA) = UNDEF - END IF - IF ( FLOGRD( 6, 2) ) THEN - TAUOX (ISEA) = UNDEF - TAUOY (ISEA) = UNDEF - END IF - IF ( FLOGRD( 6, 3) ) BHD(ISEA) = UNDEF - IF ( FLOGRD( 6, 4) ) PHIOC (ISEA) = UNDEF - IF ( FLOGRD( 6, 5) ) THEN - TUSX (ISEA) = UNDEF - TUSY (ISEA) = UNDEF - END IF - IF ( FLOGRD( 6, 6) ) THEN - USSX (ISEA) = UNDEF - USSY (ISEA) = UNDEF - END IF - IF ( FLOGRD( 6, 7) ) THEN - PRMS (ISEA) = UNDEF - TPMS (ISEA) = UNDEF - END IF - IF ( FLOGRD( 6, 8) ) US3D(ISEA,:) = UNDEF - IF ( FLOGRD( 6, 9) ) P2SMS(ISEA,:) = UNDEF - IF ( FLOGRD( 6, 10) ) TAUICE(ISEA,:) = UNDEF - IF ( FLOGRD( 6, 11) ) PHICE(ISEA) = UNDEF - IF ( FLOGRD( 6, 12) ) USSP(ISEA,:) = UNDEF - IF ( FLOGRD( 6, 13) ) THEN - TAUOCX(ISEA) = UNDEF - TAUOCY(ISEA) = UNDEF - END IF -! - IF ( FLOGRD( 7, 1) ) THEN - ABA (ISEA) = UNDEF - ABD (ISEA) = UNDEF - END IF - IF ( FLOGRD( 7, 2) ) THEN - UBA (ISEA) = UNDEF - UBD (ISEA) = UNDEF - END IF - IF ( FLOGRD( 7, 3) ) BEDFORMS(ISEA,:) = UNDEF - IF ( FLOGRD( 7, 4) ) PHIBBL(ISEA) = UNDEF - IF ( FLOGRD( 7, 5) ) TAUBBL(ISEA,:) = UNDEF -! - IF ( FLOGRD( 8, 1) ) THEN - MSSX (ISEA) = UNDEF - MSSY (ISEA) = UNDEF - END IF - IF ( FLOGRD( 8, 2) ) THEN - MSCX (ISEA) = UNDEF - MSCY (ISEA) = UNDEF - END IF - IF ( FLOGRD( 8, 3) ) MSSD (ISEA) = UNDEF - IF ( FLOGRD( 8, 4) ) MSCD (ISEA) = UNDEF - IF ( FLOGRD( 8, 5) ) QP (ISEA) = UNDEF -! - IF ( FLOGRD( 9, 1) ) DTDYN (ISEA) = UNDEF - IF ( FLOGRD( 9, 2) ) FCUT (ISEA) = UNDEF - IF ( FLOGRD( 9, 3) ) CFLXYMAX(ISEA) = UNDEF - IF ( FLOGRD( 9, 4) ) CFLTHMAX(ISEA) = UNDEF - IF ( FLOGRD( 9, 5) ) CFLKMAX(ISEA) = UNDEF -! - END IF -! - IF ( MAPSTA(MAPSF(ISEA,2),MAPSF(ISEA,1)) .EQ. 2 ) THEN -! - IF ( FLOGRD( 5, 4) ) PHIAW (ISEA) = UNDEF - IF ( FLOGRD( 5, 5) ) THEN - TAUWIX(ISEA) = UNDEF - TAUWIY(ISEA) = UNDEF - END IF - IF ( FLOGRD( 5, 6) ) THEN - TAUWNX(ISEA) = UNDEF - TAUWNY(ISEA) = UNDEF - END IF - IF ( FLOGRD( 5, 7) ) WHITECAP(ISEA,1) = UNDEF - IF ( FLOGRD( 5, 8) ) WHITECAP(ISEA,2) = UNDEF - IF ( FLOGRD( 5, 9) ) WHITECAP(ISEA,3) = UNDEF - IF ( FLOGRD( 5,10) ) WHITECAP(ISEA,4) = UNDEF -! - IF ( FLOGRD( 6, 2) )THEN - TAUOX (ISEA) = UNDEF - TAUOY (ISEA) = UNDEF - END IF - IF ( FLOGRD( 6, 4) ) PHIOC (ISEA) = UNDEF -! - IF ( FLOGRD( 7, 3) ) BEDFORMS(ISEA,:) = UNDEF - IF ( FLOGRD( 7, 4) ) PHIBBL(ISEA) = UNDEF - IF ( FLOGRD( 7, 5) ) TAUBBL(ISEA,:) = UNDEF -! - END IF -! - END DO -! - ELSE - IF (.NOT.DINIT) CALL W3DIMW ( IGRD, NDSE, NDST, .TRUE. ) - IF (.NOT.AINIT) CALL W3DIMA ( IGRD, NDSE, NDST, .TRUE. ) + ! + IF ( MAPSTA(MAPSF(ISEA,2),MAPSF(ISEA,1)) .EQ. 2 ) THEN + ! + IF ( FLOGRD( 5, 4) ) PHIAW (ISEA) = UNDEF + IF ( FLOGRD( 5, 5) ) THEN + TAUWIX(ISEA) = UNDEF + TAUWIY(ISEA) = UNDEF + END IF + IF ( FLOGRD( 5, 6) ) THEN + TAUWNX(ISEA) = UNDEF + TAUWNY(ISEA) = UNDEF + END IF + IF ( FLOGRD( 5, 7) ) WHITECAP(ISEA,1) = UNDEF + IF ( FLOGRD( 5, 8) ) WHITECAP(ISEA,2) = UNDEF + IF ( FLOGRD( 5, 9) ) WHITECAP(ISEA,3) = UNDEF + IF ( FLOGRD( 5,10) ) WHITECAP(ISEA,4) = UNDEF + ! + IF ( FLOGRD( 6, 2) )THEN + TAUOX (ISEA) = UNDEF + TAUOY (ISEA) = UNDEF + END IF + IF ( FLOGRD( 6, 4) ) PHIOC (ISEA) = UNDEF + ! + IF ( FLOGRD( 7, 3) ) BEDFORMS(ISEA,:) = UNDEF + IF ( FLOGRD( 7, 4) ) PHIBBL(ISEA) = UNDEF + IF ( FLOGRD( 7, 5) ) TAUBBL(ISEA,:) = UNDEF + ! END IF -! -! Actual output ---------------------------------------------- * - DO IFI=1, NOGRP - DO IFJ=1, NGRPP + ! + END DO + ! + ELSE + IF (.NOT.DINIT) CALL W3DIMW ( IGRD, NDSE, NDST, .TRUE. ) + IF (.NOT.AINIT) CALL W3DIMA ( IGRD, NDSE, NDST, .TRUE. ) + END IF + ! + ! Actual output ---------------------------------------------- * + DO IFI=1, NOGRP + DO IFJ=1, NGRPP IF ( FLOGRD(IFI,IFJ) ) THEN -! + ! #ifdef W3_T - WRITE (NDST,9010) FLOGRD(IFI,IFJ), IDOUT(IFI,IFJ) + WRITE (NDST,9010) FLOGRD(IFI,IFJ), IDOUT(IFI,IFJ) #endif -! - IF ( WRITE ) THEN -! -! Section 1) -! - IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN - WRITE ( NDSOG ) DW(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN - WRITE ( NDSOG ) CX(1:NSEA) - WRITE ( NDSOG ) CY(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN - DO ISEA=1, NSEA + ! + IF ( WRITE ) THEN + ! + ! Section 1) + ! + IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN + WRITE ( NDSOG ) DW(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN + WRITE ( NDSOG ) CX(1:NSEA) + WRITE ( NDSOG ) CY(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN + DO ISEA=1, NSEA #ifdef W3_SMC - !!Li Rotate map-east wind in Arctic part back to local east. JGLi02Feb2016 - IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN - UDARC = UD(ISEA) - ANGARC(ISEA - NGLO)*DERA - UD(ISEA) = MOD(TPI + UDARC, TPI) - ENDIF + !!Li Rotate map-east wind in Arctic part back to local east. JGLi02Feb2016 + IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN + UDARC = UD(ISEA) - ANGARC(ISEA - NGLO)*DERA + UD(ISEA) = MOD(TPI + UDARC, TPI) + ENDIF #endif - IF (UA(ISEA) .NE.UNDEF) THEN - AUX1(ISEA) = UA(ISEA)*COS(UD(ISEA)) - AUX2(ISEA) = UA(ISEA)*SIN(UD(ISEA)) - ELSE - AUX1(ISEA) = UNDEF - AUX2(ISEA) = UNDEF - END IF - END DO - WRITE ( NDSOG ) AUX1 - WRITE ( NDSOG ) AUX2 - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN - WRITE ( NDSOG ) AS(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN - WRITE ( NDSOG ) WLV(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN - WRITE ( NDSOG ) ICE(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 7 ) THEN - WRITE ( NDSOG ) BERG(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN - DO ISEA=1, NSEA + IF (UA(ISEA) .NE.UNDEF) THEN + AUX1(ISEA) = UA(ISEA)*COS(UD(ISEA)) + AUX2(ISEA) = UA(ISEA)*SIN(UD(ISEA)) + ELSE + AUX1(ISEA) = UNDEF + AUX2(ISEA) = UNDEF + END IF + END DO + WRITE ( NDSOG ) AUX1 + WRITE ( NDSOG ) AUX2 + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN + WRITE ( NDSOG ) AS(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN + WRITE ( NDSOG ) WLV(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN + WRITE ( NDSOG ) ICE(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 7 ) THEN + WRITE ( NDSOG ) BERG(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN + DO ISEA=1, NSEA #ifdef W3_SMC - !!Li Rotate map-east momentum in Arctic part back to local east. JGLi02Feb2016 - IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN - UDARC = TAUADIR(ISEA) - ANGARC(ISEA - NGLO)*DERA - TAUADIR(ISEA) = MOD(TPI + UDARC, TPI) - ENDIF + !!Li Rotate map-east momentum in Arctic part back to local east. JGLi02Feb2016 + IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN + UDARC = TAUADIR(ISEA) - ANGARC(ISEA - NGLO)*DERA + TAUADIR(ISEA) = MOD(TPI + UDARC, TPI) + ENDIF #endif - IF (TAUA(ISEA) .NE.UNDEF) THEN - AUX1(ISEA) = TAUA(ISEA)*COS(TAUADIR(ISEA)) - AUX2(ISEA) = TAUA(ISEA)*SIN(TAUADIR(ISEA)) - ELSE - AUX1(ISEA) = UNDEF - AUX2(ISEA) = UNDEF - END IF - END DO - WRITE ( NDSOG ) AUX1 - WRITE ( NDSOG ) AUX2 - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN - WRITE ( NDSOG ) RHOAIR(1:NSEA) + IF (TAUA(ISEA) .NE.UNDEF) THEN + AUX1(ISEA) = TAUA(ISEA)*COS(TAUADIR(ISEA)) + AUX2(ISEA) = TAUA(ISEA)*SIN(TAUADIR(ISEA)) + ELSE + AUX1(ISEA) = UNDEF + AUX2(ISEA) = UNDEF + END IF + END DO + WRITE ( NDSOG ) AUX1 + WRITE ( NDSOG ) AUX2 + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN + WRITE ( NDSOG ) RHOAIR(1:NSEA) #ifdef W3_BT4 - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN - WRITE ( NDSOG ) SED_D50(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN + WRITE ( NDSOG ) SED_D50(1:NSEA) #endif #ifdef W3_IS2 - ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN - WRITE (NDSOG ) ICEH(1:NSEA) - ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN - WRITE (NDSOG ) ICEF(1:NSEA) + ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN + WRITE (NDSOG ) ICEH(1:NSEA) + ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN + WRITE (NDSOG ) ICEF(1:NSEA) #endif #ifdef W3_SETUP - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 13 ) THEN - WRITE ( NDSOG ) ZETA_SETUP(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 13 ) THEN + WRITE ( NDSOG ) ZETA_SETUP(1:NSEA) #endif -! -! Section 2) -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN - WRITE ( NDSOG ) HS(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN - WRITE ( NDSOG ) WLM(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN - WRITE ( NDSOG ) T02(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN - WRITE ( NDSOG ) T0M1(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN - WRITE ( NDSOG ) T01(1:NSEA) - ELSE IF ( (IFI .EQ. 2 .AND. IFJ .EQ. 6) .OR. & - (IFI .EQ. 2 .AND. IFJ .EQ. 18) ) THEN - ! Note: TP output is derived from FP field. - WRITE ( NDSOG ) FP0(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN - WRITE ( NDSOG ) THM(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN - WRITE ( NDSOG ) THS(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN - WRITE ( NDSOG ) THP0(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 10 ) THEN - WRITE ( NDSOG ) HSIG(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 11 ) THEN - WRITE ( NDSOG ) STMAXE(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 12 ) THEN - WRITE ( NDSOG ) STMAXD(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 13 ) THEN - WRITE ( NDSOG ) HMAXE(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 14 ) THEN - WRITE ( NDSOG ) HCMAXE(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 15 ) THEN - WRITE ( NDSOG ) HMAXD(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 16 ) THEN - WRITE ( NDSOG ) HCMAXD(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 17 ) THEN - WRITE ( NDSOG ) WBT(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN - WRITE ( NDSOG ) WNMEAN(1:NSEA) -! -! Section 3) -! - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 1 ) THEN - WRITE ( NDSOG ) EF(1:NSEA,E3DF(2,1):E3DF(3,1)) - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 2 ) THEN - WRITE ( NDSOG ) TH1M(1:NSEA,E3DF(2,2):E3DF(3,2)) - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 3 ) THEN - WRITE ( NDSOG ) STH1M(1:NSEA,E3DF(2,3):E3DF(3,3)) - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 4 ) THEN - WRITE ( NDSOG ) TH2M(1:NSEA,E3DF(2,4):E3DF(3,4)) - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 5 ) THEN - WRITE ( NDSOG ) STH2M(1:NSEA,E3DF(2,5):E3DF(3,5)) - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 6) THEN - WRITE ( NDSOG ) WN(1:NK,1:NSEA) -! -! Section 4) -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN - WRITE ( NDSOG ) PHS(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN - WRITE ( NDSOG ) PTP(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN - WRITE ( NDSOG ) PLP(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN - WRITE ( NDSOG ) PDIR(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN - WRITE ( NDSOG ) PSI(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN - WRITE ( NDSOG ) PWS(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 7 ) THEN - WRITE ( NDSOG ) PTHP0(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 8 ) THEN - WRITE ( NDSOG ) PQP(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 9 ) THEN - WRITE ( NDSOG ) PPE(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 10 ) THEN - WRITE ( NDSOG ) PGW(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 11 ) THEN - WRITE ( NDSOG ) PSW(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 12 ) THEN - WRITE ( NDSOG ) PTM1(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 13 ) THEN - WRITE ( NDSOG ) PT1(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 14 ) THEN - WRITE ( NDSOG ) PT2(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 15 ) THEN - WRITE ( NDSOG ) PEP(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16 ) THEN - WRITE ( NDSOG ) PWST(1:NSEA) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17 ) THEN - WRITE ( NDSOG ) PNR(1:NSEA) -! -! Section 5) -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN - AUX1(ISEA) = UST(ISEA) * ASF(ISEA) * & - COS(USTDIR(ISEA)) - AUX2(ISEA) = UST(ISEA) * ASF(ISEA) * & - SIN(USTDIR(ISEA)) - ELSE - AUX1(ISEA) = UNDEF - AUX2(ISEA) = UNDEF - END IF - END DO - WRITE ( NDSOG ) AUX1 - WRITE ( NDSOG ) AUX2 - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 2 ) THEN - WRITE ( NDSOG ) CHARN(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 3 ) THEN - WRITE ( NDSOG ) CGE(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 4 ) THEN - WRITE ( NDSOG ) PHIAW(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 5 ) THEN - WRITE ( NDSOG ) TAUWIX(1:NSEA) - WRITE ( NDSOG ) TAUWIY(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 6 ) THEN - WRITE ( NDSOG ) TAUWNX(1:NSEA) - WRITE ( NDSOG ) TAUWNY(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 7 ) THEN - WRITE ( NDSOG ) WHITECAP(1:NSEA,1) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 8 ) THEN - WRITE ( NDSOG ) WHITECAP(1:NSEA,2) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 9 ) THEN - WRITE ( NDSOG ) WHITECAP(1:NSEA,3) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 10 ) THEN - WRITE ( NDSOG ) WHITECAP(1:NSEA,4) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 11 ) THEN - WRITE ( NDSOG ) TWS(1:NSEA) -! -! Section 6) -! - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 1 ) THEN - WRITE ( NDSOG ) SXX(1:NSEA) - WRITE ( NDSOG ) SYY(1:NSEA) - WRITE ( NDSOG ) SXY(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 2 ) THEN - WRITE ( NDSOG ) TAUOX(1:NSEA) - WRITE ( NDSOG ) TAUOY(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 3 ) THEN - WRITE ( NDSOG ) BHD(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 4 ) THEN - WRITE ( NDSOG ) PHIOC(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 5 ) THEN - WRITE ( NDSOG ) TUSX(1:NSEA) - WRITE ( NDSOG ) TUSY(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 6 ) THEN - WRITE ( NDSOG ) USSX(1:NSEA) - WRITE ( NDSOG ) USSY(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 7 ) THEN - WRITE ( NDSOG ) PRMS(1:NSEA) - WRITE ( NDSOG ) TPMS(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 8 ) THEN - WRITE ( NDSOG ) US3D(1:NSEA, US3DF(2):US3DF(3)) - WRITE ( NDSOG ) US3D(1:NSEA,NK+US3DF(2):NK+US3DF(3)) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 9 ) THEN - WRITE ( NDSOG ) P2SMS(1:NSEA,P2MSF(2):P2MSF(3)) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 10 ) THEN - WRITE ( NDSOG ) TAUICE(1:NSEA,1) - WRITE ( NDSOG ) TAUICE(1:NSEA,2) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 11 ) THEN - WRITE ( NDSOG ) PHICE(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 12 ) THEN - WRITE ( NDSOG ) USSP(1:NSEA, 1:USSPF(2)) - WRITE ( NDSOG ) USSP(1:NSEA,NK+1:NK+USSPF(2)) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 13 ) THEN - WRITE ( NDSOG ) TAUOCX(1:NSEA) - WRITE ( NDSOG ) TAUOCY(1:NSEA) -! -! Section 7) -! - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 1 ) THEN - DO ISEA=1, NSEA - IF ( ABA(ISEA) .NE. UNDEF ) THEN - AUX1(ISEA) = ABA(ISEA)*COS(ABD(ISEA)) - AUX2(ISEA) = ABA(ISEA)*SIN(ABD(ISEA)) - ELSE - AUX1(ISEA) = UNDEF - AUX2(ISEA) = UNDEF - END IF - END DO - WRITE ( NDSOG ) AUX1 - WRITE ( NDSOG ) AUX2 - !WRITE ( NDSOG ) ABA(1:NSEA) - !WRITE ( NDSOG ) ABD(1:NSEA) - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 2 ) THEN - DO ISEA=1, NSEA - IF ( UBA(ISEA) .NE. UNDEF ) THEN - AUX1(ISEA) = UBA(ISEA)*COS(UBD(ISEA)) - AUX2(ISEA) = UBA(ISEA)*SIN(UBD(ISEA)) - ELSE - AUX1(ISEA) = UNDEF - AUX2(ISEA) = UNDEF - END IF - END DO - WRITE ( NDSOG ) AUX1 - WRITE ( NDSOG ) AUX2 -! WRITE ( NDSOG ) UBA(1:NSEA) -! WRITE ( NDSOG ) UBD(1:NSEA) - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 3 ) THEN - WRITE ( NDSOG ) BEDFORMS(1:NSEA,1) - WRITE ( NDSOG ) BEDFORMS(1:NSEA,2) - WRITE ( NDSOG ) BEDFORMS(1:NSEA,3) - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 4 ) THEN - WRITE ( NDSOG ) PHIBBL(1:NSEA) - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 5 ) THEN - WRITE ( NDSOG ) TAUBBL(1:NSEA,1) - WRITE ( NDSOG ) TAUBBL(1:NSEA,2) -! -! Section 8) -! - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 1 ) THEN - WRITE ( NDSOG ) MSSX(1:NSEA) - WRITE ( NDSOG ) MSSY(1:NSEA) - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 2 ) THEN - WRITE ( NDSOG ) MSCX(1:NSEA) - WRITE ( NDSOG ) MSCY(1:NSEA) - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 3 ) THEN - WRITE ( NDSOG ) MSSD(1:NSEA) - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 4 ) THEN - WRITE ( NDSOG ) MSCD(1:NSEA) - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 5 ) THEN - WRITE ( NDSOG ) QP(1:NSEA) -! -! Section 9) -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN - WRITE ( NDSOG ) DTDYN(1:NSEA) - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN - WRITE ( NDSOG ) FCUT(1:NSEA) - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN - WRITE ( NDSOG ) CFLXYMAX(1:NSEA) - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN - WRITE ( NDSOG ) CFLTHMAX(1:NSEA) - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 5 ) THEN - WRITE ( NDSOG ) CFLKMAX(1:NSEA) -! -! Section 10) -! - ELSE IF ( IFI .EQ. 10 ) THEN - WRITE ( NDSOG ) USERO(1:NSEA,IFJ) -! - END IF -! - ELSE -! -! Start of reading ...... -! -! Section 1) -! - IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) DW(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) CX(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) CY(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) UA(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) UD(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) AS(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) WLV(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ICE(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 7 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) BERG(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) TAUA(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) TAUADIR(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) RHOAIR(1:NSEA) + ! + ! Section 2) + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN + WRITE ( NDSOG ) HS(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN + WRITE ( NDSOG ) WLM(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN + WRITE ( NDSOG ) T02(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN + WRITE ( NDSOG ) T0M1(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN + WRITE ( NDSOG ) T01(1:NSEA) + ELSE IF ( (IFI .EQ. 2 .AND. IFJ .EQ. 6) .OR. & + (IFI .EQ. 2 .AND. IFJ .EQ. 18) ) THEN + ! Note: TP output is derived from FP field. + WRITE ( NDSOG ) FP0(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN + WRITE ( NDSOG ) THM(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN + WRITE ( NDSOG ) THS(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN + WRITE ( NDSOG ) THP0(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 10 ) THEN + WRITE ( NDSOG ) HSIG(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 11 ) THEN + WRITE ( NDSOG ) STMAXE(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 12 ) THEN + WRITE ( NDSOG ) STMAXD(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 13 ) THEN + WRITE ( NDSOG ) HMAXE(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 14 ) THEN + WRITE ( NDSOG ) HCMAXE(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 15 ) THEN + WRITE ( NDSOG ) HMAXD(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 16 ) THEN + WRITE ( NDSOG ) HCMAXD(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 17 ) THEN + WRITE ( NDSOG ) WBT(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN + WRITE ( NDSOG ) WNMEAN(1:NSEA) + ! + ! Section 3) + ! + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 1 ) THEN + WRITE ( NDSOG ) EF(1:NSEA,E3DF(2,1):E3DF(3,1)) + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 2 ) THEN + WRITE ( NDSOG ) TH1M(1:NSEA,E3DF(2,2):E3DF(3,2)) + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 3 ) THEN + WRITE ( NDSOG ) STH1M(1:NSEA,E3DF(2,3):E3DF(3,3)) + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 4 ) THEN + WRITE ( NDSOG ) TH2M(1:NSEA,E3DF(2,4):E3DF(3,4)) + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 5 ) THEN + WRITE ( NDSOG ) STH2M(1:NSEA,E3DF(2,5):E3DF(3,5)) + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 6) THEN + WRITE ( NDSOG ) WN(1:NK,1:NSEA) + ! + ! Section 4) + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN + WRITE ( NDSOG ) PHS(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN + WRITE ( NDSOG ) PTP(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN + WRITE ( NDSOG ) PLP(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN + WRITE ( NDSOG ) PDIR(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN + WRITE ( NDSOG ) PSI(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN + WRITE ( NDSOG ) PWS(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 7 ) THEN + WRITE ( NDSOG ) PTHP0(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 8 ) THEN + WRITE ( NDSOG ) PQP(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 9 ) THEN + WRITE ( NDSOG ) PPE(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 10 ) THEN + WRITE ( NDSOG ) PGW(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 11 ) THEN + WRITE ( NDSOG ) PSW(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 12 ) THEN + WRITE ( NDSOG ) PTM1(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 13 ) THEN + WRITE ( NDSOG ) PT1(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 14 ) THEN + WRITE ( NDSOG ) PT2(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 15 ) THEN + WRITE ( NDSOG ) PEP(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16 ) THEN + WRITE ( NDSOG ) PWST(1:NSEA) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17 ) THEN + WRITE ( NDSOG ) PNR(1:NSEA) + ! + ! Section 5) + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN + AUX1(ISEA) = UST(ISEA) * ASF(ISEA) * & + COS(USTDIR(ISEA)) + AUX2(ISEA) = UST(ISEA) * ASF(ISEA) * & + SIN(USTDIR(ISEA)) + ELSE + AUX1(ISEA) = UNDEF + AUX2(ISEA) = UNDEF + END IF + END DO + WRITE ( NDSOG ) AUX1 + WRITE ( NDSOG ) AUX2 + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 2 ) THEN + WRITE ( NDSOG ) CHARN(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 3 ) THEN + WRITE ( NDSOG ) CGE(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 4 ) THEN + WRITE ( NDSOG ) PHIAW(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 5 ) THEN + WRITE ( NDSOG ) TAUWIX(1:NSEA) + WRITE ( NDSOG ) TAUWIY(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 6 ) THEN + WRITE ( NDSOG ) TAUWNX(1:NSEA) + WRITE ( NDSOG ) TAUWNY(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 7 ) THEN + WRITE ( NDSOG ) WHITECAP(1:NSEA,1) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 8 ) THEN + WRITE ( NDSOG ) WHITECAP(1:NSEA,2) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 9 ) THEN + WRITE ( NDSOG ) WHITECAP(1:NSEA,3) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 10 ) THEN + WRITE ( NDSOG ) WHITECAP(1:NSEA,4) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 11 ) THEN + WRITE ( NDSOG ) TWS(1:NSEA) + ! + ! Section 6) + ! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 1 ) THEN + WRITE ( NDSOG ) SXX(1:NSEA) + WRITE ( NDSOG ) SYY(1:NSEA) + WRITE ( NDSOG ) SXY(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 2 ) THEN + WRITE ( NDSOG ) TAUOX(1:NSEA) + WRITE ( NDSOG ) TAUOY(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 3 ) THEN + WRITE ( NDSOG ) BHD(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 4 ) THEN + WRITE ( NDSOG ) PHIOC(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 5 ) THEN + WRITE ( NDSOG ) TUSX(1:NSEA) + WRITE ( NDSOG ) TUSY(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 6 ) THEN + WRITE ( NDSOG ) USSX(1:NSEA) + WRITE ( NDSOG ) USSY(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 7 ) THEN + WRITE ( NDSOG ) PRMS(1:NSEA) + WRITE ( NDSOG ) TPMS(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 8 ) THEN + WRITE ( NDSOG ) US3D(1:NSEA, US3DF(2):US3DF(3)) + WRITE ( NDSOG ) US3D(1:NSEA,NK+US3DF(2):NK+US3DF(3)) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 9 ) THEN + WRITE ( NDSOG ) P2SMS(1:NSEA,P2MSF(2):P2MSF(3)) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 10 ) THEN + WRITE ( NDSOG ) TAUICE(1:NSEA,1) + WRITE ( NDSOG ) TAUICE(1:NSEA,2) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 11 ) THEN + WRITE ( NDSOG ) PHICE(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 12 ) THEN + WRITE ( NDSOG ) USSP(1:NSEA, 1:USSPF(2)) + WRITE ( NDSOG ) USSP(1:NSEA,NK+1:NK+USSPF(2)) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 13 ) THEN + WRITE ( NDSOG ) TAUOCX(1:NSEA) + WRITE ( NDSOG ) TAUOCY(1:NSEA) + ! + ! Section 7) + ! + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 1 ) THEN + DO ISEA=1, NSEA + IF ( ABA(ISEA) .NE. UNDEF ) THEN + AUX1(ISEA) = ABA(ISEA)*COS(ABD(ISEA)) + AUX2(ISEA) = ABA(ISEA)*SIN(ABD(ISEA)) + ELSE + AUX1(ISEA) = UNDEF + AUX2(ISEA) = UNDEF + END IF + END DO + WRITE ( NDSOG ) AUX1 + WRITE ( NDSOG ) AUX2 + !WRITE ( NDSOG ) ABA(1:NSEA) + !WRITE ( NDSOG ) ABD(1:NSEA) + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 2 ) THEN + DO ISEA=1, NSEA + IF ( UBA(ISEA) .NE. UNDEF ) THEN + AUX1(ISEA) = UBA(ISEA)*COS(UBD(ISEA)) + AUX2(ISEA) = UBA(ISEA)*SIN(UBD(ISEA)) + ELSE + AUX1(ISEA) = UNDEF + AUX2(ISEA) = UNDEF + END IF + END DO + WRITE ( NDSOG ) AUX1 + WRITE ( NDSOG ) AUX2 + ! WRITE ( NDSOG ) UBA(1:NSEA) + ! WRITE ( NDSOG ) UBD(1:NSEA) + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 3 ) THEN + WRITE ( NDSOG ) BEDFORMS(1:NSEA,1) + WRITE ( NDSOG ) BEDFORMS(1:NSEA,2) + WRITE ( NDSOG ) BEDFORMS(1:NSEA,3) + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 4 ) THEN + WRITE ( NDSOG ) PHIBBL(1:NSEA) + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 5 ) THEN + WRITE ( NDSOG ) TAUBBL(1:NSEA,1) + WRITE ( NDSOG ) TAUBBL(1:NSEA,2) + ! + ! Section 8) + ! + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 1 ) THEN + WRITE ( NDSOG ) MSSX(1:NSEA) + WRITE ( NDSOG ) MSSY(1:NSEA) + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 2 ) THEN + WRITE ( NDSOG ) MSCX(1:NSEA) + WRITE ( NDSOG ) MSCY(1:NSEA) + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 3 ) THEN + WRITE ( NDSOG ) MSSD(1:NSEA) + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 4 ) THEN + WRITE ( NDSOG ) MSCD(1:NSEA) + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 5 ) THEN + WRITE ( NDSOG ) QP(1:NSEA) + ! + ! Section 9) + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN + WRITE ( NDSOG ) DTDYN(1:NSEA) + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN + WRITE ( NDSOG ) FCUT(1:NSEA) + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN + WRITE ( NDSOG ) CFLXYMAX(1:NSEA) + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN + WRITE ( NDSOG ) CFLTHMAX(1:NSEA) + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 5 ) THEN + WRITE ( NDSOG ) CFLKMAX(1:NSEA) + ! + ! Section 10) + ! + ELSE IF ( IFI .EQ. 10 ) THEN + WRITE ( NDSOG ) USERO(1:NSEA,IFJ) + ! + END IF + ! + ELSE + ! + ! Start of reading ...... + ! + ! Section 1) + ! + IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) DW(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) CX(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) CY(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) UA(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) UD(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) AS(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) WLV(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ICE(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 7 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) BERG(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) TAUA(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) TAUADIR(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) RHOAIR(1:NSEA) #ifdef W3_BT4 - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) SED_D50(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) SED_D50(1:NSEA) #endif #ifdef W3_IS2 - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ICEH(1:NSEA) - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ICEF(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ICEH(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ICEF(1:NSEA) #endif #ifdef W3_SETUP - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 13 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ZETA_SETUP(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 13 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ZETA_SETUP(1:NSEA) #endif -! -! Section 2) -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) HS(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) WLM(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) T02(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) T0M1(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) T01(1:NSEA) - ELSE IF ( (IFI .EQ. 2 .AND. IFJ .EQ. 6) .OR. & - (IFI .EQ. 2 .AND. IFJ .EQ. 18) ) THEN - ! Note: TP output is derived from FP field. - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) FP0(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) THM(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) THS(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - THP0(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 10 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - HSIG(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 11 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - STMAXE(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 12 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - STMAXD(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 13 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - HMAXE(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 14 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - HCMAXE(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 15 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - HMAXD(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 16 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - HCMAXD(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 17 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) WBT(1:NSEA) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - WNMEAN(1:NSEA) -! -! Section 3) -! - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 1 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - EF(1:NSEA,E3DF(2,1):E3DF(3,1)) - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 2 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TH1M(1:NSEA,E3DF(2,2):E3DF(3,2)) - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 3 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - STH1M(1:NSEA,E3DF(2,3):E3DF(3,3)) - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 4 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TH2M(1:NSEA,E3DF(2,4):E3DF(3,4)) - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 5 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - STH2M(1:NSEA,E3DF(2,5):E3DF(3,5)) - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 6) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - WN(1:NK,1:NSEA) -! -! Section 4) -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PHS(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PTP(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PLP(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PDIR(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PSI(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PWS(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 7 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PTHP0(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 8 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PQP(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 9 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PPE(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 10 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PGW(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 11 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PSW(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 12 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PTM1(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 13 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PT1(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 14 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PT2(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 15 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PEP(1:NSEA,0:NOSWLL) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PWST(1:NSEA) - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) PNR(1:NSEA) -! -! Section 5) -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - UST(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - USTDIR(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 2 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - CHARN(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 3 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) CGE(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 4 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PHIAW(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 5 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUWIX(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUWIY(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 6 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUWNX(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUWNY(1:NSEA) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 7 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - WHITECAP(1:NSEA,1) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 8 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - WHITECAP(1:NSEA,2) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 9 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - WHITECAP(1:NSEA,3) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 10 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - WHITECAP(1:NSEA,4) - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 11 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TWS(1:NSEA) -! -! Section 6) -! - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 1 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) SXX(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) SYY(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) SXY(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 2 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUOX(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUOY(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 3 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - BHD(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 4 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PHIOC(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 5 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TUSX(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TUSY(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 6 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - USSX(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - USSY(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 7 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PRMS(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TPMS(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 8 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - US3D(1:NSEA,US3DF(2):US3DF(3)) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - US3D(1:NSEA,NK+US3DF(2):NK+US3DF(3)) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 9 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - P2SMS(1:NSEA,P2MSF(2):P2MSF(3)) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 10 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUICE(1:NSEA,1) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUICE(1:NSEA,2) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 11 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PHICE(1:NSEA) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 12 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - USSP(1:NSEA,1:USSPF(2)) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - USSP(1:NSEA,NK+1:NK+USSPF(2)) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 13 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUOCX(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUOCY(1:NSEA) + ! + ! Section 2) + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) HS(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) WLM(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) T02(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) T0M1(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) T01(1:NSEA) + ELSE IF ( (IFI .EQ. 2 .AND. IFJ .EQ. 6) .OR. & + (IFI .EQ. 2 .AND. IFJ .EQ. 18) ) THEN + ! Note: TP output is derived from FP field. + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) FP0(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) THM(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) THS(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + THP0(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 10 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + HSIG(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 11 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + STMAXE(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 12 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + STMAXD(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 13 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + HMAXE(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 14 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + HCMAXE(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 15 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + HMAXD(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 16 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + HCMAXD(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 17 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) WBT(1:NSEA) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + WNMEAN(1:NSEA) + ! + ! Section 3) + ! + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 1 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + EF(1:NSEA,E3DF(2,1):E3DF(3,1)) + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 2 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TH1M(1:NSEA,E3DF(2,2):E3DF(3,2)) + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 3 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + STH1M(1:NSEA,E3DF(2,3):E3DF(3,3)) + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 4 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TH2M(1:NSEA,E3DF(2,4):E3DF(3,4)) + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 5 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + STH2M(1:NSEA,E3DF(2,5):E3DF(3,5)) + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 6) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + WN(1:NK,1:NSEA) + ! + ! Section 4) + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PHS(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PTP(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PLP(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PDIR(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PSI(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PWS(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 7 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PTHP0(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 8 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PQP(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 9 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PPE(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 10 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PGW(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 11 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PSW(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 12 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PTM1(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 13 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PT1(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 14 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PT2(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 15 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PEP(1:NSEA,0:NOSWLL) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PWST(1:NSEA) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) PNR(1:NSEA) + ! + ! Section 5) + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + UST(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + USTDIR(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 2 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + CHARN(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 3 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) CGE(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 4 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PHIAW(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 5 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUWIX(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUWIY(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 6 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUWNX(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUWNY(1:NSEA) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 7 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + WHITECAP(1:NSEA,1) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 8 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + WHITECAP(1:NSEA,2) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 9 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + WHITECAP(1:NSEA,3) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 10 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + WHITECAP(1:NSEA,4) + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 11 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TWS(1:NSEA) + ! + ! Section 6) + ! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 1 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) SXX(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) SYY(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) SXY(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 2 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUOX(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUOY(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 3 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + BHD(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 4 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PHIOC(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 5 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TUSX(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TUSY(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 6 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + USSX(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + USSY(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 7 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PRMS(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TPMS(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 8 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + US3D(1:NSEA,US3DF(2):US3DF(3)) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + US3D(1:NSEA,NK+US3DF(2):NK+US3DF(3)) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 9 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + P2SMS(1:NSEA,P2MSF(2):P2MSF(3)) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 10 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUICE(1:NSEA,1) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUICE(1:NSEA,2) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 11 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PHICE(1:NSEA) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 12 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + USSP(1:NSEA,1:USSPF(2)) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + USSP(1:NSEA,NK+1:NK+USSPF(2)) + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 13 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUOCX(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUOCY(1:NSEA) -! -! Section 7) -! - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 1 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ABA(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ABD(1:NSEA) - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 2 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) UBA(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) UBD(1:NSEA) - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 3 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - BEDFORMS(1:NSEA,1) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - BEDFORMS(1:NSEA,2) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - BEDFORMS(1:NSEA,3) - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 4 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - PHIBBL(1:NSEA) - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 5 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUBBL(1:NSEA,1) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - TAUBBL(1:NSEA,2) -! -! Section 8) -! - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 1 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - MSSX(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - MSSY(1:NSEA) - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 2 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - MSCX(1:NSEA) - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - MSCY(1:NSEA) - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 3 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - MSSD(1:NSEA) - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 4 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - MSCD(1:NSEA) - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 5 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) QP(1:NSEA) -! -! Section 9) -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - DTDYN(1:NSEA) - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - FCUT(1:NSEA) - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - CFLXYMAX(1:NSEA) - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - CFLTHMAX(1:NSEA) - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 5 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - CFLKMAX(1:NSEA) -! -! Section 10) -! - ELSE IF ( IFI .EQ. 10 ) THEN - READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & - USERO(1:NSEA,IFJ) - END IF -! -! End of test on WRITE/READ: -! - END IF -! -! End of test on FLOGRD(IFI,IFJ): -! + ! + ! Section 7) + ! + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 1 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ABA(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ABD(1:NSEA) + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 2 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) UBA(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) UBD(1:NSEA) + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 3 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + BEDFORMS(1:NSEA,1) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + BEDFORMS(1:NSEA,2) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + BEDFORMS(1:NSEA,3) + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 4 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + PHIBBL(1:NSEA) + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 5 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUBBL(1:NSEA,1) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + TAUBBL(1:NSEA,2) + ! + ! Section 8) + ! + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 1 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + MSSX(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + MSSY(1:NSEA) + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 2 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + MSCX(1:NSEA) + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + MSCY(1:NSEA) + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 3 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + MSSD(1:NSEA) + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 4 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + MSCD(1:NSEA) + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 5 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) QP(1:NSEA) + ! + ! Section 9) + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + DTDYN(1:NSEA) + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + FCUT(1:NSEA) + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + CFLXYMAX(1:NSEA) + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + CFLTHMAX(1:NSEA) + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 5 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + CFLKMAX(1:NSEA) + ! + ! Section 10) + ! + ELSE IF ( IFI .EQ. 10 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) & + USERO(1:NSEA,IFJ) + END IF + ! + ! End of test on WRITE/READ: + ! END IF -! -! End of IFI and IFJ loops -! - END DO - END DO -! -! Flush the buffers for write -! - IF ( WRITE ) CALL FLUSH ( NDSOG ) -! - IF(OFILES(1) .EQ. 1) CLOSE(NDSOG) -! + ! + ! End of test on FLOGRD(IFI,IFJ): + ! + END IF + ! + ! End of IFI and IFJ loops + ! + END DO + END DO + ! + ! Flush the buffers for write + ! + IF ( WRITE ) CALL FLUSH ( NDSOG ) + ! + IF(OFILES(1) .EQ. 1) CLOSE(NDSOG) + ! #ifdef W3_MPI - CALL W3SETA ( IGRD, NDSE, NDST ) + CALL W3SETA ( IGRD, NDSE, NDST ) #endif -! - RETURN -! -! Escape locations read errors -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 41 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 42 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 43 ) -! - 803 CONTINUE - IOTST = -1 + ! + RETURN + ! + ! Escape locations read errors + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 41 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 42 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 43 ) + ! +803 CONTINUE + IOTST = -1 #ifdef W3_T - WRITE (NDST,9020) + WRITE (NDST,9020) #endif - RETURN -! -! Formats -! - 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & - ' ILEGAL INXOUT VALUE: ',A/) - 901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & - ' MIXED READ/WRITE, LAST REQUEST: ',A/) - 902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & - ' ILEGAL IDSTR, READ : ',A/ & - ' CHECK : ',A/) - 903 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & - ' ILEGAL VEROGR, READ : ',A/ & - ' CHECK : ',A/) - 904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & - ' DIFFERENT NUMBER OF FIELDS, FILE :',I8,I8/ & - ' PROGRAM :',I8,I8/) - 905 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOGO :'/ & - ' ILEGAL GNAME, READ : ',A/ & - ' CHECK : ',A/) - 906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & - ' ILEGAL NOSWLL, READ : ',I4/ & - ' CHECK : ',I4/) -! -! 999 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & -! ' PLEASE UPDATE FIELDS !!! '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO : '/ & - ' ERROR IN OPENING FILE'/ & - ' IOSTAT =',I5/) - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO : '/ & - ' PREMATURE END OF FILE'/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO : '/ & - ' ERROR IN READING FROM FILE'/ & - ' IOSTAT =',I5/) -! + RETURN + ! + ! Formats + ! +900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & + ' ILEGAL INXOUT VALUE: ',A/) +901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & + ' MIXED READ/WRITE, LAST REQUEST: ',A/) +902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & + ' ILEGAL IDSTR, READ : ',A/ & + ' CHECK : ',A/) +903 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & + ' ILEGAL VEROGR, READ : ',A/ & + ' CHECK : ',A/) +904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & + ' DIFFERENT NUMBER OF FIELDS, FILE :',I8,I8/ & + ' PROGRAM :',I8,I8/) +905 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOGO :'/ & + ' ILEGAL GNAME, READ : ',A/ & + ' CHECK : ',A/) +906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & + ' ILEGAL NOSWLL, READ : ',I4/ & + ' CHECK : ',I4/) + ! + ! 999 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO :'/ & + ! ' PLEASE UPDATE FIELDS !!! '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO : '/ & + ' ERROR IN OPENING FILE'/ & + ' IOSTAT =',I5/) +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO : '/ & + ' PREMATURE END OF FILE'/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGO : '/ & + ' ERROR IN READING FROM FILE'/ & + ' IOSTAT =',I5/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3IOGO : IPASS =',I4,' INXOUT = ',A, & - ' WRITE = ',L1,' UNIT =',I3/ & - ' IGRD =',I3,' FEXT = ',A) - 9001 FORMAT (' TEST W3IOGO : OPENING NEW FILE [',A,']') - 9002 FORMAT (' TEST W3IOGO : TEST PARAMETERS:'/ & - ' IDSTR : ',A/ & - ' VEROGR : ',A/ & - ' GNAME : ',A/ & - ' NSEA :',I6/ & - ' NX,NY : ',I9,I12/ & - ' UNDEF : ',F8.2) - 9003 FORMAT (' TEST W3IOGO : TIME :',I9.8,I7.6/ & - ' FLAGS :',20L2,1X,20L2/ & - ' ',20L2,2X,20L2/ & - ' ',20L2,2X,20L2/ & - ' ',20L2,2X,20L2/ & - ' ',20L2,2X,20L2) - 9010 FORMAT (' TEST W3IOGO : PROC = ',L1,' FOR ',A) - 9020 FORMAT (' TEST W3IOGO : END OF FILE REACHED') +9000 FORMAT (' TEST W3IOGO : IPASS =',I4,' INXOUT = ',A, & + ' WRITE = ',L1,' UNIT =',I3/ & + ' IGRD =',I3,' FEXT = ',A) +9001 FORMAT (' TEST W3IOGO : OPENING NEW FILE [',A,']') +9002 FORMAT (' TEST W3IOGO : TEST PARAMETERS:'/ & + ' IDSTR : ',A/ & + ' VEROGR : ',A/ & + ' GNAME : ',A/ & + ' NSEA :',I6/ & + ' NX,NY : ',I9,I12/ & + ' UNDEF : ',F8.2) +9003 FORMAT (' TEST W3IOGO : TIME :',I9.8,I7.6/ & + ' FLAGS :',20L2,1X,20L2/ & + ' ',20L2,2X,20L2/ & + ' ',20L2,2X,20L2/ & + ' ',20L2,2X,20L2/ & + ' ',20L2,2X,20L2) +9010 FORMAT (' TEST W3IOGO : PROC = ',L1,' FOR ',A) +9020 FORMAT (' TEST W3IOGO : END OF FILE REACHED') #endif -!/ -!/ End of W3IOGO ----------------------------------------------------- / -!/ - END SUBROUTINE W3IOGO -!/ -!/ ------------------------------------------------------------------- / -!> -!> @brief Output Stokes drift related parameters. -!> -!> @details This code is built for the purpose of outputting Stokes -!> drift related parameters that can be utilized to obtain full -!> Stokes drift profiles external to the wave model. -!> -!> @param[in] A Input spectra, left in par list to change shape. -!> @param[in] USS_SWITCH Switch if computing US3D (spectral) or USSP (partitions). -!> -!> @author H. L. Tolman @date 10-Jan-2017 -!> - SUBROUTINE CALC_U3STOKES ( A , USS_SWITCH ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 10-Jan-2017 : Separate Stokes drift calculation ( version 6.01 ) -!/ -! 1. Purpose : -! -! This code is built for the purpose of outputting Stokes drift -! related parameters that can be utilized to obtain full -! Stokes drift profiles external to the wave model. -! -! Option 1: USS_SWITCH == 1 -! This method is for outputing the Stokes drift frequency -! spectrum for spectral frequency bands as defined by the -! WW3 computation spectral frequency grid. -! Output Quantity: Stokes drift frequency spectrum [m/s/Hz] -! X and Y componenets. -! -! Option 2: USS_SWITCH == 2 -! This method is for outputing the surface Stokes drift -! for a specified frequency partition/band of the -! wave spectrum. These partitions do not need to be -! matched to WW3's computation spectral frequency grid, -! and will rather sum the contributions of the WW3 bands -! into the output partition. The partitions are defined -! in the ww3_grid.inp namelist section. -! Output Quantity: Stokes drift surface velocity [m/s] -! X and Y components -! For each partition (up to 25). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Input spectra. Left in par list to change -! shape. -! USS_SWITCH I I Switch if computing US3D (spectral) or USSP -! (partitions) -! ---------------------------------------------------------------- -! -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/OMPG OpenMP compiler directive for loop splitting. -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPIINV, GRAV, TPI - USE W3GDATMD, ONLY: DDEN, DSII, XFR, SIG, NK, NTH, NSEAl, & - ECOS, ESIN, US3DF, USSPF, USSP_WN - USE W3ADATMD, ONLY: CG, WN, DW - USE W3ADATMD, ONLY: USSX, USSY, US3D, USSP - USE W3ODATMD, ONLY: IAPROC, NAPROC - USE W3PARALL, ONLY: INIT_GET_ISEA + !/ + !/ End of W3IOGO ----------------------------------------------------- / + !/ + END SUBROUTINE W3IOGO + !/ + !/ ------------------------------------------------------------------- / + !> + !> @brief Output Stokes drift related parameters. + !> + !> @details This code is built for the purpose of outputting Stokes + !> drift related parameters that can be utilized to obtain full + !> Stokes drift profiles external to the wave model. + !> + !> @param[in] A Input spectra, left in par list to change shape. + !> @param[in] USS_SWITCH Switch if computing US3D (spectral) or USSP (partitions). + !> + !> @author H. L. Tolman @date 10-Jan-2017 + !> + SUBROUTINE CALC_U3STOKES ( A , USS_SWITCH ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 10-Jan-2017 : Separate Stokes drift calculation ( version 6.01 ) + !/ + ! 1. Purpose : + ! + ! This code is built for the purpose of outputting Stokes drift + ! related parameters that can be utilized to obtain full + ! Stokes drift profiles external to the wave model. + ! + ! Option 1: USS_SWITCH == 1 + ! This method is for outputing the Stokes drift frequency + ! spectrum for spectral frequency bands as defined by the + ! WW3 computation spectral frequency grid. + ! Output Quantity: Stokes drift frequency spectrum [m/s/Hz] + ! X and Y componenets. + ! + ! Option 2: USS_SWITCH == 2 + ! This method is for outputing the surface Stokes drift + ! for a specified frequency partition/band of the + ! wave spectrum. These partitions do not need to be + ! matched to WW3's computation spectral frequency grid, + ! and will rather sum the contributions of the WW3 bands + ! into the output partition. The partitions are defined + ! in the ww3_grid.inp namelist section. + ! Output Quantity: Stokes drift surface velocity [m/s] + ! X and Y components + ! For each partition (up to 25). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Input spectra. Left in par list to change + ! shape. + ! USS_SWITCH I I Switch if computing US3D (spectral) or USSP + ! (partitions) + ! ---------------------------------------------------------------- + ! + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/OMPG OpenMP compiler directive for loop splitting. + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPIINV, GRAV, TPI + USE W3GDATMD, ONLY: DDEN, DSII, XFR, SIG, NK, NTH, NSEAl, & + ECOS, ESIN, US3DF, USSPF, USSP_WN + USE W3ADATMD, ONLY: CG, WN, DW + USE W3ADATMD, ONLY: USSX, USSY, US3D, USSP + USE W3ODATMD, ONLY: IAPROC, NAPROC + USE W3PARALL, ONLY: INIT_GET_ISEA #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK,0:NSEAL) - INTEGER, INTENT(IN) :: USS_SWITCH -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IK, ITH, ISEA, JSEA - INTEGER :: IKST, IKFI, IB + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK,0:NSEAL) + INTEGER, INTENT(IN) :: USS_SWITCH + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IK, ITH, ISEA, JSEA + INTEGER :: IKST, IKFI, IB #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: FACTOR, FKD,KD - REAL :: ABX(NSEAL), ABY(NSEAL), USSCO - REAL :: MINDIFF - INTEGER :: Spc2Bnd(NK) -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: FACTOR, FKD,KD + REAL :: ABX(NSEAL), ABY(NSEAL), USSCO + REAL :: MINDIFF + INTEGER :: Spc2Bnd(NK) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'CALC_U3STOKES') + CALL STRACE (IENT, 'CALC_U3STOKES') #endif -! -! 1. Initialize storage arrays -------------------------------------- * -! -! 2. Integral over discrete part of spectrum ------------------------ * -! - !Two options ----------------------------------------------------| - ! USS_SWITCH == 1 -> Old option, Stokes drift integrated in same | - ! wavenumber bands as model integrates. | - ! USS_SWITCH == 2 -> New option, Stokes drift integrated in a | - ! defined number (NP) of user specified | - ! partitions, where NP and the frequency | - ! ranges for each partition can be user | - ! defined at run-time. | - !----------------------------------------------------------------| + ! + ! 1. Initialize storage arrays -------------------------------------- * + ! + ! 2. Integral over discrete part of spectrum ------------------------ * + ! + !Two options ----------------------------------------------------| + ! USS_SWITCH == 1 -> Old option, Stokes drift integrated in same | + ! wavenumber bands as model integrates. | + ! USS_SWITCH == 2 -> New option, Stokes drift integrated in a | + ! defined number (NP) of user specified | + ! partitions, where NP and the frequency | + ! ranges for each partition can be user | + ! defined at run-time. | + !----------------------------------------------------------------| - if (USS_SWITCH==1) then - IKST=US3DF(2)!Start at US3DF(2) - IKFI=US3DF(3)!End at US3DF(3) - ELSEif (USS_SWITCH==2) then - IKST=1 ! Start at 1 - IKFI=NK ! End at NK - ENDIF + if (USS_SWITCH==1) then + IKST=US3DF(2)!Start at US3DF(2) + IKFI=US3DF(3)!End at US3DF(3) + ELSEif (USS_SWITCH==2) then + IKST=1 ! Start at 1 + IKFI=NK ! End at NK + ENDIF -! Initialize US3D/USSP - IF (USS_SWITCH.eq.1) then - US3D(:,:)=0.0 - ELSEIF (USS_SWITCH.eq.2) then - USSP(:,:)=0.0 - ENDIF - DO IK=IKST,IKFI !1, NK -! -! 2.a Initialize energy in band -! - ABX = 0. - ABY = 0. - ! -! 2.b Integrate energy in band -! - DO ITH=1, NTH -! + ! Initialize US3D/USSP + IF (USS_SWITCH.eq.1) then + US3D(:,:)=0.0 + ELSEIF (USS_SWITCH.eq.2) then + USSP(:,:)=0.0 + ENDIF + DO IK=IKST,IKFI !1, NK + ! + ! 2.a Initialize energy in band + ! + ABX = 0. + ABY = 0. + ! + ! 2.b Integrate energy in band + ! + DO ITH=1, NTH + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA) + !$OMP PARALLEL DO PRIVATE(JSEA) #endif -! - DO JSEA=1, NSEAL - ABX(JSEA) = ABX(JSEA) + A(ITH,IK,JSEA)*ECOS(ITH) - ABY(JSEA) = ABY(JSEA) + A(ITH,IK,JSEA)*ESIN(ITH) - END DO -! + ! + DO JSEA=1, NSEAL + ABX(JSEA) = ABX(JSEA) + A(ITH,IK,JSEA)*ECOS(ITH) + ABY(JSEA) = ABY(JSEA) + A(ITH,IK,JSEA)*ESIN(ITH) + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - END DO -! -! 2.c Finalize integration over band and update mean arrays -! -! + ! + END DO + ! + ! 2.c Finalize integration over band and update mean arrays + ! + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR,KD,FKD,USSCO,MINDIFF,IB) + !$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR,KD,FKD,USSCO,MINDIFF,IB) #endif -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - FACTOR = DDEN(IK) / CG(IK,ISEA) -! -! Deep water limits -! - KD = MAX ( 0.001 , WN(IK,ISEA) * DW(ISEA) ) - IF ( KD .LT. 6. ) THEN - FKD = FACTOR / SINH(KD)**2 - USSCO=FKD*SIG(IK)*WN(IK,ISEA)*COSH(2.*KD) - ELSE - USSCO=FACTOR*SIG(IK)*2.*WN(IK,ISEA) - END IF -! -! - !USSX(JSEA) = USSX(JSEA) + ABX(JSEA)*USSCO - !USSY(JSEA) = USSY(JSEA) + ABY(JSEA)*USSCO -! -! Fills the 3D Stokes drift spectrum array or surface Stokes partitions -! - IF (USS_SWITCH==1) THEN - !Old method fills into WW3 bands - IF (IK.GE.US3DF(2).and.IK.LE.US3DF(3)) then - US3D(JSEA,IK) = ABX(JSEA)*USSCO/(DSII(IK)*TPIINV) - US3D(JSEA,NK+IK) = ABY(JSEA)*USSCO/(DSII(IK)*TPIINV) - ENDIF - ELSEIF (USS_SWITCH==2) THEN - ! Match each spectral component to the nearest partition - MINDIFF=1.e8 - Spc2BND(IK) = 1 - MINDIFF=abs(USSP_WN(1)-WN(IK,ISEA)) - DO IB=2,USSPF(2) - IF (MinDiff .gt. abs(USSP_WN(IB)-WN(IK,ISEA))) then - Spc2BND(IK) = IB - MinDiff = abs(USSP_WN(IB)-WN(IK,ISEA)) - ENDIF - ENDDO - !Put spectral energey into whichever band central wavenumber fits in - USSP(JSEA,Spc2Bnd(IK)) = USSP(JSEA,Spc2Bnd(IK)) + ABX(JSEA)*USSCO - USSP(JSEA,NK+Spc2BND(IK)) = USSP(JSEA,NK+Spc2Bnd(IK)) + ABY(JSEA)*USSCO + ! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + FACTOR = DDEN(IK) / CG(IK,ISEA) + ! + ! Deep water limits + ! + KD = MAX ( 0.001 , WN(IK,ISEA) * DW(ISEA) ) + IF ( KD .LT. 6. ) THEN + FKD = FACTOR / SINH(KD)**2 + USSCO=FKD*SIG(IK)*WN(IK,ISEA)*COSH(2.*KD) + ELSE + USSCO=FACTOR*SIG(IK)*2.*WN(IK,ISEA) + END IF + ! + ! + !USSX(JSEA) = USSX(JSEA) + ABX(JSEA)*USSCO + !USSY(JSEA) = USSY(JSEA) + ABY(JSEA)*USSCO + ! + ! Fills the 3D Stokes drift spectrum array or surface Stokes partitions + ! + IF (USS_SWITCH==1) THEN + !Old method fills into WW3 bands + IF (IK.GE.US3DF(2).and.IK.LE.US3DF(3)) then + US3D(JSEA,IK) = ABX(JSEA)*USSCO/(DSII(IK)*TPIINV) + US3D(JSEA,NK+IK) = ABY(JSEA)*USSCO/(DSII(IK)*TPIINV) + ENDIF + ELSEIF (USS_SWITCH==2) THEN + ! Match each spectral component to the nearest partition + MINDIFF=1.e8 + Spc2BND(IK) = 1 + MINDIFF=abs(USSP_WN(1)-WN(IK,ISEA)) + DO IB=2,USSPF(2) + IF (MinDiff .gt. abs(USSP_WN(IB)-WN(IK,ISEA))) then + Spc2BND(IK) = IB + MinDiff = abs(USSP_WN(IB)-WN(IK,ISEA)) ENDIF - END DO + ENDDO + !Put spectral energey into whichever band central wavenumber fits in + USSP(JSEA,Spc2Bnd(IK)) = USSP(JSEA,Spc2Bnd(IK)) + ABX(JSEA)*USSCO + USSP(JSEA,NK+Spc2BND(IK)) = USSP(JSEA,NK+Spc2Bnd(IK)) + ABY(JSEA)*USSCO + ENDIF + END DO #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif - END DO -! - RETURN -! -!/ End of CALC_U3STOKES -!----------------------------------------------------- / -!/ - END SUBROUTINE CALC_U3STOKES -!/ -!/ ------------------------------------------------------------------- / -!> -!> @brief Estimate the dominant wave breaking probability b_T. -!> -!> @details Estimate the dominant wave breaking probability b_T based on -!> the empirical parameterization proposed by Babanin et al. (2001). -!> -!> @verbatim -!> From their Fig. 12, we have -!> -!> b_T = 85.1 * [(εp - 0.055) * (1 + H_s/d)]^2.33, -!> -!> where ε is the significant steepness of the spectral peak, H_s is -!> the significant wave height, d is the water depth. -!> -!> For more details, please see -!> Banner et al. 2000: JPO, 30, 3145 - 3160. -!> Babanin et al. 2001: JGR, 106(C6), 11569 - 11676. -!> @endverbatim -!> -!> @param[in] A Input wave action spectra N(j, θ, k). -!> -!> @author Q. Liu @date 24-Aug-2018 -!> - SUBROUTINE CALC_WBT (A) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 24-Aug-2018 | -!/ +-----------------------------------+ -!/ -!/ 24-Aug-2018 : Origination. ( version 6.06 ) -!/ -! 1. Purpose : -! -! Estimate the dominant wave breaking probability b_T based on -! the empirical parameterization proposed by Babanin et al. (2001). -! From their Fig. 12, we have -! -! b_T = 85.1 * [(εp - 0.055) * (1 + H_s/d)]^2.33, -! -! where ε is the significant steepness of the spectral peak, H_s is -! the significant wave height, d is the water depth. -! -! For more details, please see -! Banner et al. 2000: JPO, 30, 3145 - 3160. -! Babanin et al. 2001: JGR, 106(C6), 11569 - 11676. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Input wave action spectra N(j, θ, k) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3OUTG Subr. Public Calculate mean parameters. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3DISPMD, ONLY: WAVNU1 - USE W3ADATMD, ONLY: U10, U10D, WBT - USE W3ADATMD, ONLY: CG, WN, DW - USE W3GDATMD, ONLY: NK, NTH, NSEAL, SIG, ESIN, ECOS, DTH, DSII, & - FTE, XFR, MAPSF, MAPSTA, DMIN - USE W3GDATMD, ONLY: BTBETA - USE W3PARALL, ONLY: INIT_GET_ISEA + END DO + ! + RETURN + ! + !/ End of CALC_U3STOKES + !----------------------------------------------------- / + !/ + END SUBROUTINE CALC_U3STOKES + !/ + !/ ------------------------------------------------------------------- / + !> + !> @brief Estimate the dominant wave breaking probability b_T. + !> + !> @details Estimate the dominant wave breaking probability b_T based on + !> the empirical parameterization proposed by Babanin et al. (2001). + !> + !> @verbatim + !> From their Fig. 12, we have + !> + !> b_T = 85.1 * [(εp - 0.055) * (1 + H_s/d)]^2.33, + !> + !> where ε is the significant steepness of the spectral peak, H_s is + !> the significant wave height, d is the water depth. + !> + !> For more details, please see + !> Banner et al. 2000: JPO, 30, 3145 - 3160. + !> Babanin et al. 2001: JGR, 106(C6), 11569 - 11676. + !> @endverbatim + !> + !> @param[in] A Input wave action spectra N(j, θ, k). + !> + !> @author Q. Liu @date 24-Aug-2018 + !> + SUBROUTINE CALC_WBT (A) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 24-Aug-2018 | + !/ +-----------------------------------+ + !/ + !/ 24-Aug-2018 : Origination. ( version 6.06 ) + !/ + ! 1. Purpose : + ! + ! Estimate the dominant wave breaking probability b_T based on + ! the empirical parameterization proposed by Babanin et al. (2001). + ! From their Fig. 12, we have + ! + ! b_T = 85.1 * [(εp - 0.055) * (1 + H_s/d)]^2.33, + ! + ! where ε is the significant steepness of the spectral peak, H_s is + ! the significant wave height, d is the water depth. + ! + ! For more details, please see + ! Banner et al. 2000: JPO, 30, 3145 - 3160. + ! Babanin et al. 2001: JGR, 106(C6), 11569 - 11676. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Input wave action spectra N(j, θ, k) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3OUTG Subr. Public Calculate mean parameters. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3DISPMD, ONLY: WAVNU1 + USE W3ADATMD, ONLY: U10, U10D, WBT + USE W3ADATMD, ONLY: CG, WN, DW + USE W3GDATMD, ONLY: NK, NTH, NSEAL, SIG, ESIN, ECOS, DTH, DSII, & + FTE, XFR, MAPSF, MAPSTA, DMIN + USE W3GDATMD, ONLY: BTBETA + USE W3PARALL, ONLY: INIT_GET_ISEA #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A (NTH, NK, 0:NSEAL) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + ! + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A (NTH, NK, 0:NSEAL) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! - INTEGER :: FPOPT = 0 -! - INTEGER :: IK, ITH, ISEA, JSEA, IKM, IKL, IKH, IX, IY - REAL :: TDPT, TU10, TUDIR, SINU, COSU, TC, TFORCE - REAL :: ESIG(NK) ! E(σ) - REAL :: FACTOR, ET, HS, ETP, HSP, SIGP, KP, & - CGP, WSTP - REAL :: XL, XH, XL2, XH2, EL, EH, DENOM - REAL :: TWBT -!/ -!/ ------------------------------------------------------------------- / -!/ + ! + INTEGER :: FPOPT = 0 + ! + INTEGER :: IK, ITH, ISEA, JSEA, IKM, IKL, IKH, IX, IY + REAL :: TDPT, TU10, TUDIR, SINU, COSU, TC, TFORCE + REAL :: ESIG(NK) ! E(σ) + REAL :: FACTOR, ET, HS, ETP, HSP, SIGP, KP, & + CGP, WSTP + REAL :: XL, XH, XL2, XH2, EL, EH, DENOM + REAL :: TWBT + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'CALC_WBT') + CALL STRACE (IENT, 'CALC_WBT') #endif -! - DO JSEA = 1, NSEAL -! JSEA 2 ISEA - CALL INIT_GET_ISEA(ISEA, JSEA) -! -! check the status of this grid point [escape if this point is excluded] -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF ( MAPSTA(IY,IX) .LE. 0 ) CYCLE -! -! Wind info. is required to select wind sea partition from the wave -! spectrum. Two wind velocities are availabe: -! - U10 & U10D (w3adatmd) -! - UST & USTDIR (w3wdatmd) -! * U10D & USTDIR are not really the same when swell are present. -! -! Following Janssen et al. (1989) and Bidlot (2001), spectral components -! are considered to be subject to local wind forcing when -! -! c / [U cos(θ - φ)] < β, -! -! where c is the phase velocity c = σ/k, φ is the wind direction, U is -! the wind speed U10, (sometimes approximated by U10≅ 28 * ust), β is -! the constant forcing parameter with β∈ [1.0, 2.0]. By default, we use -! β = 1.2(Bidlot 2001). -! - TDPT = MAX(DW(ISEA), DMIN) ! water depth d - TU10 = U10(ISEA) ! wind velocity U10 - TUDIR = U10D(ISEA) ! wind direction φ (rad) - SINU = SIN(TUDIR) ! sinφ - COSU = COS(TUDIR) ! cosφ -! - ESIG = 0. ! E(σ) - ET = 0. ! ΣE(σ)δσ - ETP = 0. ! ΣE(σ)δσ at peak only -! - DO IK = 1, NK - TC = SIG(IK) / WN(IK, ISEA) ! phase velocity c=σ/k - FACTOR = SIG(IK) / CG(IK, ISEA) ! σ / cg - FACTOR = FACTOR * DTH ! σ / cg * δθ -! - DO ITH = 1, NTH - TFORCE = TC - TU10 * (COSU*ECOS(ITH)+SINU*ESIN(ITH)) & - * BTBETA + ! + DO JSEA = 1, NSEAL + ! JSEA 2 ISEA + CALL INIT_GET_ISEA(ISEA, JSEA) + ! + ! check the status of this grid point [escape if this point is excluded] + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF ( MAPSTA(IY,IX) .LE. 0 ) CYCLE + ! + ! Wind info. is required to select wind sea partition from the wave + ! spectrum. Two wind velocities are availabe: + ! - U10 & U10D (w3adatmd) + ! - UST & USTDIR (w3wdatmd) + ! * U10D & USTDIR are not really the same when swell are present. + ! + ! Following Janssen et al. (1989) and Bidlot (2001), spectral components + ! are considered to be subject to local wind forcing when + ! + ! c / [U cos(θ - φ)] < β, + ! + ! where c is the phase velocity c = σ/k, φ is the wind direction, U is + ! the wind speed U10, (sometimes approximated by U10≅ 28 * ust), β is + ! the constant forcing parameter with β∈ [1.0, 2.0]. By default, we use + ! β = 1.2(Bidlot 2001). + ! + TDPT = MAX(DW(ISEA), DMIN) ! water depth d + TU10 = U10(ISEA) ! wind velocity U10 + TUDIR = U10D(ISEA) ! wind direction φ (rad) + SINU = SIN(TUDIR) ! sinφ + COSU = COS(TUDIR) ! cosφ + ! + ESIG = 0. ! E(σ) + ET = 0. ! ΣE(σ)δσ + ETP = 0. ! ΣE(σ)δσ at peak only + ! + DO IK = 1, NK + TC = SIG(IK) / WN(IK, ISEA) ! phase velocity c=σ/k + FACTOR = SIG(IK) / CG(IK, ISEA) ! σ / cg + FACTOR = FACTOR * DTH ! σ / cg * δθ + ! + DO ITH = 1, NTH + TFORCE = TC - TU10 * (COSU*ECOS(ITH)+SINU*ESIN(ITH)) & + * BTBETA - IF (TFORCE .LT. 0.) THEN ! wind sea component - ESIG(IK) = ESIG(IK) + A(ITH, IK, JSEA) * FACTOR - ENDIF - ENDDO ! ITH -! - ENDDO ! IK -! -! ESIG is E(σ) of the wind sea after filtration of any background swell. -! Now we need to get Hs & σp for the wind sea spectrum. -! FTE = 0.25 * SIG(NK) * DTH * SIG(NK) [ww3_grid.ftn] -! - ET = SUM(ESIG * DSII) - ET = ET + ESIG(NK) * FTE / (DTH * SIG(NK)) ! FTE: add tail - HS = 4. * SQRT(MAX(0., ET)) ! Hs -! -! Get σp from E(σ) -! -! Here we have tried three different ways to calculate FP: -! -! FPOPT = 0: fp defined by Young (1999, p. 239) -! FPOPT = 1: parabolic fit around the discrete peak frequency, as used -! by ww3_outp -! FPOPT = 2: discrete peak frequency -! -! When the discrete peak frequency is used: -! * For XFR = 1.1, the **discrete** peak region [0.7σp, 1.3σp] will be -! {0.75, 0.83, 0.91, 1., 1.1, 1.21, 1.33}σp, -! * and for XFR = 1.07, the **discrete** peak region becomes -! {0.71, 0.76, 0.82, 0.87, 0.93, 1., 1.07, 1.14, 1.23, 1.31}σp. -! -! Thus, a good approximation to the range [0.7σp, 1.3σp] is guranteed -! by each XFR. I however found using the discrete peak frequency yielded -! step-wise results. According to my test, the smoothest results were -! obtained with FPOPT = 0. For simplicity, the δσ values (DSII) are -! not modified. -! - IKM = MAXLOC(ESIG, 1) ! index for σp -! - IF (FPOPT .EQ. 0) THEN -! FP defined in Ian's book - SIGP = SUM(ESIG**4. * SIG(1:NK) * DSII) / & - MAX(1E-10, SUM(ESIG**4. * DSII)) -! - ELSE IF (FPOPT .EQ. 1) THEN -! Parabolic fit around the discrete peak (ww3_outp.ftn) - XL = 1./XFR - 1. - XH = XFR - 1. - XL2 = XL**2. - XH2 = XH**2. - IKL = MAX ( 1 , IKM-1 ) - IKH = MIN ( NK , IKM+1 ) - EL = ESIG(IKL) - ESIG(IKM) - EH = ESIG(IKH) - ESIG(IKM) - DENOM = XL*EH - XH*EL - SIGP = SIG(IKM) * (1. + 0.5 * ( XL2*EH - XH2*EL) & - / SIGN (MAX(ABS(DENOM), 1.E-15), DENOM)) ! σp -! - ELSE IF (FPOPT .EQ. 2) THEN -! Discrete peak (Give stepwise results, not used by default) - SIGP = SIG(IKM) + IF (TFORCE .LT. 0.) THEN ! wind sea component + ESIG(IK) = ESIG(IK) + A(ITH, IK, JSEA) * FACTOR ENDIF -! -! kp from σp (linear dispersion) -! -! N(k, θ) at first step is zero → σp=0 → floating divided by zero error - IF (SIGP < 1E-6) SIGP = SIG(NK) ! Hsp & b_T will be still 0. -! - CALL WAVNU1 (SIGP, TDPT, KP, CGP) -! -! { /1.3σp }1/2 -! peak wave height Hp = 4 { | E(σ) dσ } -! { /0.7σp } -! - DO IK = 1, NK - IF ( (SIG(IK) >= 0.7 * SIGP) .AND. & - (SIG(IK) <= 1.3 * SIGP) ) THEN - ETP = ETP + ESIG(IK) * DSII(IK) - ENDIF - ENDDO ! IK - HSP = 4. * SQRT(MAX(0., ETP)) -! -! significant steepness of the peak region εp -! - WSTP = 0.5 * KP * HSP -! -! Dominant wave breaking b_T -! - TWBT = 85.1 * (MAX(0.0, WSTP - 0.055) * (1 + HS/TDPT))**2.33 - WBT(JSEA) = MIN(1.0, TWBT) -! - ENDDO ! JSEA -!/ -!/ End of CALC_WBT -------------------------------------------------- / -!/ - END SUBROUTINE CALC_WBT -!/ ------------------------------------------------------------------- / - END MODULE W3IOGOMD + ENDDO ! ITH + ! + ENDDO ! IK + ! + ! ESIG is E(σ) of the wind sea after filtration of any background swell. + ! Now we need to get Hs & σp for the wind sea spectrum. + ! FTE = 0.25 * SIG(NK) * DTH * SIG(NK) [ww3_grid.ftn] + ! + ET = SUM(ESIG * DSII) + ET = ET + ESIG(NK) * FTE / (DTH * SIG(NK)) ! FTE: add tail + HS = 4. * SQRT(MAX(0., ET)) ! Hs + ! + ! Get σp from E(σ) + ! + ! Here we have tried three different ways to calculate FP: + ! + ! FPOPT = 0: fp defined by Young (1999, p. 239) + ! FPOPT = 1: parabolic fit around the discrete peak frequency, as used + ! by ww3_outp + ! FPOPT = 2: discrete peak frequency + ! + ! When the discrete peak frequency is used: + ! * For XFR = 1.1, the **discrete** peak region [0.7σp, 1.3σp] will be + ! {0.75, 0.83, 0.91, 1., 1.1, 1.21, 1.33}σp, + ! * and for XFR = 1.07, the **discrete** peak region becomes + ! {0.71, 0.76, 0.82, 0.87, 0.93, 1., 1.07, 1.14, 1.23, 1.31}σp. + ! + ! Thus, a good approximation to the range [0.7σp, 1.3σp] is guranteed + ! by each XFR. I however found using the discrete peak frequency yielded + ! step-wise results. According to my test, the smoothest results were + ! obtained with FPOPT = 0. For simplicity, the δσ values (DSII) are + ! not modified. + ! + IKM = MAXLOC(ESIG, 1) ! index for σp + ! + IF (FPOPT .EQ. 0) THEN + ! FP defined in Ian's book + SIGP = SUM(ESIG**4. * SIG(1:NK) * DSII) / & + MAX(1E-10, SUM(ESIG**4. * DSII)) + ! + ELSE IF (FPOPT .EQ. 1) THEN + ! Parabolic fit around the discrete peak (ww3_outp.ftn) + XL = 1./XFR - 1. + XH = XFR - 1. + XL2 = XL**2. + XH2 = XH**2. + IKL = MAX ( 1 , IKM-1 ) + IKH = MIN ( NK , IKM+1 ) + EL = ESIG(IKL) - ESIG(IKM) + EH = ESIG(IKH) - ESIG(IKM) + DENOM = XL*EH - XH*EL + SIGP = SIG(IKM) * (1. + 0.5 * ( XL2*EH - XH2*EL) & + / SIGN (MAX(ABS(DENOM), 1.E-15), DENOM)) ! σp + ! + ELSE IF (FPOPT .EQ. 2) THEN + ! Discrete peak (Give stepwise results, not used by default) + SIGP = SIG(IKM) + ENDIF + ! + ! kp from σp (linear dispersion) + ! + ! N(k, θ) at first step is zero → σp=0 → floating divided by zero error + IF (SIGP < 1E-6) SIGP = SIG(NK) ! Hsp & b_T will be still 0. + ! + CALL WAVNU1 (SIGP, TDPT, KP, CGP) + ! + ! { /1.3σp }1/2 + ! peak wave height Hp = 4 { | E(σ) dσ } + ! { /0.7σp } + ! + DO IK = 1, NK + IF ( (SIG(IK) >= 0.7 * SIGP) .AND. & + (SIG(IK) <= 1.3 * SIGP) ) THEN + ETP = ETP + ESIG(IK) * DSII(IK) + ENDIF + ENDDO ! IK + HSP = 4. * SQRT(MAX(0., ETP)) + ! + ! significant steepness of the peak region εp + ! + WSTP = 0.5 * KP * HSP + ! + ! Dominant wave breaking b_T + ! + TWBT = 85.1 * (MAX(0.0, WSTP - 0.055) * (1 + HS/TDPT))**2.33 + WBT(JSEA) = MIN(1.0, TWBT) + ! + ENDDO ! JSEA + !/ + !/ End of CALC_WBT -------------------------------------------------- / + !/ + END SUBROUTINE CALC_WBT + !/ ------------------------------------------------------------------- / +END MODULE W3IOGOMD diff --git a/model/src/w3iogoncdmd.F90 b/model/src/w3iogoncdmd.F90 index 0e40cc7d4..2f4a31e0e 100644 --- a/model/src/w3iogoncdmd.F90 +++ b/model/src/w3iogoncdmd.F90 @@ -93,13 +93,13 @@ subroutine w3iogoncd () ! ------------------------------------------------------------- if (use_user_histname) then - if (len_trim(user_histfname) == 0 ) then - call extcde (60, msg="user history filename requested but not provided") - end if - call set_user_timestring(time,user_timestring) - fname = trim(user_histfname)//trim(user_timestring)//'.nc' + if (len_trim(user_histfname) == 0 ) then + call extcde (60, msg="user history filename requested but not provided") + end if + call set_user_timestring(time,user_timestring) + fname = trim(user_histfname)//trim(user_timestring)//'.nc' else - write(fname,'(a,i8.8,a1,i6.6,a)')trim(fnmpre),time(1),'.',time(2),'.out_grd.'//trim(filext)//'.nc' + write(fname,'(a,i8.8,a1,i6.6,a)')trim(fnmpre),time(1),'.',time(2),'.out_grd.'//trim(filext)//'.nc' end if len_s = noswll + 1 ! 0:noswll @@ -109,12 +109,12 @@ subroutine w3iogoncd () ! define the dimensions required for the requested gridded fields do n = 1,size(outvars) - if (outvars(n)%validout) then - if(trim(outvars(n)%dims) == 's')s_axis = .true. - if(trim(outvars(n)%dims) == 'm')m_axis = .true. - if(trim(outvars(n)%dims) == 'p')p_axis = .true. - if(trim(outvars(n)%dims) == 'k')k_axis = .true. - end if + if (outvars(n)%validout) then + if(trim(outvars(n)%dims) == 's')s_axis = .true. + if(trim(outvars(n)%dims) == 'm')m_axis = .true. + if(trim(outvars(n)%dims) == 'p')p_axis = .true. + if(trim(outvars(n)%dims) == 'k')k_axis = .true. + end if end do ! allocate arrays if needed @@ -155,28 +155,28 @@ subroutine w3iogoncd () dimid3(1:2) = (/xtid, ytid/) dimid4(1:2) = (/xtid, ytid/) do n = 1,size(outvars) - if (trim(outvars(n)%dims) == 's') then - dimid4(3:4) = (/stid, timid/) - dimid => dimid4 - else if (trim(outvars(n)%dims) == 'm') then - dimid4(3:4) = (/mtid, timid/) - dimid => dimid4 - else if (trim(outvars(n)%dims) == 'p') then - dimid4(3:4) = (/ptid, timid/) - dimid => dimid4 - else if (trim(outvars(n)%dims) == 'k') then - dimid4(3:4) = (/ktid, timid/) - dimid => dimid4 - else - dimid3(3) = timid - dimid => dimid3 - end if - - ierr = nf90_def_var(ncid, trim(outvars(n)%var_name), nf90_float, dimid, varid) - call handle_err(ierr, 'define variable '//trim((outvars(n)%var_name))) - ierr = nf90_put_att(ncid, varid, 'units' , trim(outvars(n)%unit_name)) - ierr = nf90_put_att(ncid, varid, 'long_name' , trim(outvars(n)%long_name)) - ierr = nf90_put_att(ncid, varid, '_FillValue', undef) + if (trim(outvars(n)%dims) == 's') then + dimid4(3:4) = (/stid, timid/) + dimid => dimid4 + else if (trim(outvars(n)%dims) == 'm') then + dimid4(3:4) = (/mtid, timid/) + dimid => dimid4 + else if (trim(outvars(n)%dims) == 'p') then + dimid4(3:4) = (/ptid, timid/) + dimid => dimid4 + else if (trim(outvars(n)%dims) == 'k') then + dimid4(3:4) = (/ktid, timid/) + dimid => dimid4 + else + dimid3(3) = timid + dimid => dimid3 + end if + + ierr = nf90_def_var(ncid, trim(outvars(n)%var_name), nf90_float, dimid, varid) + call handle_err(ierr, 'define variable '//trim((outvars(n)%var_name))) + ierr = nf90_put_att(ncid, varid, 'units' , trim(outvars(n)%unit_name)) + ierr = nf90_put_att(ncid, varid, 'long_name' , trim(outvars(n)%long_name)) + ierr = nf90_put_att(ncid, varid, '_FillValue', undef) end do ! end variable definitions ierr = nf90_enddef(ncid) @@ -202,157 +202,157 @@ subroutine w3iogoncd () ! write the requested variables do n = 1,size(outvars) - vname = trim(outvars(n)%var_name) - if (trim(outvars(n)%dims) == 's') then - var3d => var3ds - ! Group 4 - if(vname .eq. 'PHS') call write_var3d(vname, phs (1:nsea,0:noswll) ) - if(vname .eq. 'PTP') call write_var3d(vname, ptp (1:nsea,0:noswll) ) - if(vname .eq. 'PLP') call write_var3d(vname, plp (1:nsea,0:noswll) ) - if(vname .eq. 'PDIR') call write_var3d(vname, pdir (1:nsea,0:noswll) ) - if(vname .eq. 'PSI') call write_var3d(vname, psi (1:nsea,0:noswll) ) - if(vname .eq. 'PWS') call write_var3d(vname, pws (1:nsea,0:noswll) ) - if(vname .eq. 'PDP') call write_var3d(vname, pthp0 (1:nsea,0:noswll) ) - if(vname .eq. 'PQP') call write_var3d(vname, pqp (1:nsea,0:noswll) ) - if(vname .eq. 'PPE') call write_var3d(vname, ppe (1:nsea,0:noswll) ) - if(vname .eq. 'PGW') call write_var3d(vname, pgw (1:nsea,0:noswll) ) - if(vname .eq. 'PSW') call write_var3d(vname, psw (1:nsea,0:noswll) ) - if(vname .eq. 'PTM1') call write_var3d(vname, ptm1 (1:nsea,0:noswll) ) - if(vname .eq. 'PT1') call write_var3d(vname, pt1 (1:nsea,0:noswll) ) - if(vname .eq. 'PT2') call write_var3d(vname, pt2 (1:nsea,0:noswll) ) - if(vname .eq. 'PEP') call write_var3d(vname, pep (1:nsea,0:noswll) ) - - else if (trim(outvars(n)%dims) == 'm') then ! m axis - var3d => var3dm - ! Group 6 - if (vname .eq. 'P2SMS') call write_var3d(vname, p2sms (1:nsea,p2msf(2):p2msf(3)) ) - - else if (trim(outvars(n)%dims) == 'p') then ! partition axis - var3d => var3dp - ! Group 6 - if (vname .eq. 'USSPX') call write_var3d(vname, ussp (1:nsea, 1:usspf(2)) ) - if (vname .eq. 'USSPY') call write_var3d(vname, ussp (1:nsea,nk+1:nk+usspf(2)) ) - - else if (trim(outvars(n)%dims) == 'k') then ! freq axis - var3d => var3dk - ! Group 3 - if(vname .eq. 'EF') call write_var3d(vname, ef (1:nsea,e3df(2,1):e3df(3,1)) ) - if(vname .eq. 'TH1M') call write_var3d(vname, ef (1:nsea,e3df(2,2):e3df(3,2)) ) - if(vname .eq. 'STH1M') call write_var3d(vname, ef (1:nsea,e3df(2,3):e3df(3,3)) ) - if(vname .eq. 'TH2M') call write_var3d(vname, ef (1:nsea,e3df(2,4):e3df(3,4)) ) - if(vname .eq. 'STH2M') call write_var3d(vname, ef (1:nsea,e3df(2,5):e3df(3,5)) ) - !TODO: wn has reversed indices (1:nk, 1:nsea) - ! Group 6 - if (vname .eq. 'US3DX') call write_var3d(vname, us3d (1:nsea, us3df(2):us3df(3)) ) - if (vname .eq. 'US3DY') call write_var3d(vname, us3d (1:nsea,nk+us3df(2):nk+us3df(3)) ) - - else - ! Group 1 - if (vname .eq. 'DW') call write_var2d(vname, dw (1:nsea), init0='false') - if (vname .eq. 'CX') call write_var2d(vname, cx (1:nsea), init0='false') - if (vname .eq. 'CY') call write_var2d(vname, cy (1:nsea), init0='false') - if (vname .eq. 'UAX') call write_var2d(vname, ua (1:nsea), dir=cos(ud(1:nsea)), init0='false') - if (vname .eq. 'UAY') call write_var2d(vname, ua (1:nsea), dir=sin(ud(1:nsea)), init0='false') - if (vname .eq. 'AS') call write_var2d(vname, as (1:nsea), init0='false') - if (vname .eq. 'WLV') call write_var2d(vname, wlv (1:nsea), init0='false') - if (vname .eq. 'ICE') call write_var2d(vname, ice (1:nsea), init0='false') - if (vname .eq. 'BERG') call write_var2d(vname, berg (1:nsea), init0='false') - if (vname .eq. 'TAUX') call write_var2d(vname, taua (1:nsea), dir=cos(tauadir(1:nsea)), init0='false') - if (vname .eq. 'TAUY') call write_var2d(vname, taua (1:nsea), dir=sin(tauadir(1:nsea)), init0='false') - if (vname .eq. 'RHOAIR') call write_var2d(vname, rhoair (1:nsea), init0='false') - if (vname .eq. 'ICEH') call write_var2d(vname, iceh (1:nsea), init0='false') - if (vname .eq. 'ICEF') call write_var2d(vname, icef (1:nsea), init0='false') - - ! Group 2 - if (vname .eq. 'HS') call write_var2d(vname, hs (1:nsea) ) - if (vname .eq. 'WLM') call write_var2d(vname, wlm (1:nsea) ) - if (vname .eq. 'T02') call write_var2d(vname, t02 (1:nsea) ) - if (vname .eq. 'T0M1') call write_var2d(vname, t0m1 (1:nsea) ) - if (vname .eq. 'T01') call write_var2d(vname, t01 (1:nsea) ) - if (vname .eq. 'FP0') call write_var2d(vname, fp0 (1:nsea) ) - if (vname .eq. 'THM') call write_var2d(vname, thm (1:nsea) ) - if (vname .eq. 'THS') call write_var2d(vname, ths (1:nsea) ) - if (vname .eq. 'THP0') call write_var2d(vname, thp0 (1:nsea) ) - if (vname .eq. 'HSIG') call write_var2d(vname, hsig (1:nsea) ) - if (vname .eq. 'STMAXE') call write_var2d(vname, stmaxe (1:nsea) ) - if (vname .eq. 'STMAXD') call write_var2d(vname, stmaxd (1:nsea) ) - if (vname .eq. 'HMAXE') call write_var2d(vname, hmaxe (1:nsea) ) - if (vname .eq. 'HCMAXE') call write_var2d(vname, hcmaxe (1:nsea) ) - if (vname .eq. 'HMAXD') call write_var2d(vname, hmaxd (1:nsea) ) - if (vname .eq. 'HCMAXD') call write_var2d(vname, hcmaxd (1:nsea) ) - if (vname .eq. 'WBT') call write_var2d(vname, wbt (1:nsea) ) - if (vname .eq. 'WNMEAN') call write_var2d(vname, wnmean (1:nsea), init0='false') - - ! Group 4 - if(vname .eq. 'PWST') call write_var2d(vname, pwst (1:nsea) ) - if(vname .eq. 'PNR') call write_var2d(vname, pnr (1:nsea) ) - - ! Group 5 - if (vname .eq. 'USTX') call write_var2d(vname, ust (1:nsea)*asf(1:nsea), dir=cos(ustdir(1:nsea)), usemask='true') - if (vname .eq. 'USTY') call write_var2d(vname, ust (1:nsea)*asf(1:nsea), dir=sin(ustdir(1:nsea)), usemask='true') - if (vname .eq. 'CHA') call write_var2d(vname, charn (1:nsea) ) - if (vname .eq. 'CGE') call write_var2d(vname, cge (1:nsea) ) - if (vname .eq. 'PHIAW') call write_var2d(vname, phiaw (1:nsea), init2='true') - if (vname .eq. 'TAUWIX') call write_var2d(vname, tauwix (1:nsea), init2='true') - if (vname .eq. 'TAUWIY') call write_var2d(vname, tauwiy (1:nsea), init2='true') - if (vname .eq. 'TAUWNX') call write_var2d(vname, tauwnx (1:nsea), init2='true') - if (vname .eq. 'TAUWNY') call write_var2d(vname, tauwny (1:nsea), init2='true') - if (vname .eq. 'WCC') call write_var2d(vname, whitecap (1:nsea,1), init2='true') - if (vname .eq. 'WCF') call write_var2d(vname, whitecap (1:nsea,2), init2='true') - if (vname .eq. 'WCH') call write_var2d(vname, whitecap (1:nsea,3), init2='true') - if (vname .eq. 'WCM') call write_var2d(vname, whitecap (1:nsea,4), init2='true') - if (vname .eq. 'TWS') call write_var2d(vname, tws (1:nsea) ) - - ! Group 6 - if (vname .eq. 'SXX') call write_var2d(vname, sxx (1:nsea) ) - if (vname .eq. 'SYY') call write_var2d(vname, syy (1:nsea) ) - if (vname .eq. 'SXY') call write_var2d(vname, sxy (1:nsea) ) - if (vname .eq. 'TAUOX') call write_var2d(vname, tauox (1:nsea), init2='true') - if (vname .eq. 'TAUOY') call write_var2d(vname, tauoy (1:nsea), init2='true') - if (vname .eq. 'BHD') call write_var2d(vname, bhd (1:nsea) ) - if (vname .eq. 'PHIOC') call write_var2d(vname, phioc (1:nsea), init2='true') - if (vname .eq. 'TUSX') call write_var2d(vname, tusx (1:nsea) ) - if (vname .eq. 'TUSY') call write_var2d(vname, tusy (1:nsea) ) - if (vname .eq. 'USSX') call write_var2d(vname, ussx (1:nsea) ) - if (vname .eq. 'USSY') call write_var2d(vname, ussy (1:nsea) ) - if (vname .eq. 'PRMS') call write_var2d(vname, prms (1:nsea) ) - if (vname .eq. 'TPMS') call write_var2d(vname, tpms (1:nsea) ) - if (vname .eq. 'TAUICEX') call write_var2d(vname, tauice (1:nsea,1) ) - if (vname .eq. 'TAUICEY') call write_var2d(vname, tauice (1:nsea,2) ) - if (vname .eq. 'PHICE') call write_var2d(vname, phice (1:nsea) ) - if (vname .eq. 'TAUOCX') call write_var2d(vname, tauocx (1:nsea) ) - if (vname .eq. 'TAUOCY') call write_var2d(vname, tauocy (1:nsea) ) + vname = trim(outvars(n)%var_name) + if (trim(outvars(n)%dims) == 's') then + var3d => var3ds + ! Group 4 + if(vname .eq. 'PHS') call write_var3d(vname, phs (1:nsea,0:noswll) ) + if(vname .eq. 'PTP') call write_var3d(vname, ptp (1:nsea,0:noswll) ) + if(vname .eq. 'PLP') call write_var3d(vname, plp (1:nsea,0:noswll) ) + if(vname .eq. 'PDIR') call write_var3d(vname, pdir (1:nsea,0:noswll) ) + if(vname .eq. 'PSI') call write_var3d(vname, psi (1:nsea,0:noswll) ) + if(vname .eq. 'PWS') call write_var3d(vname, pws (1:nsea,0:noswll) ) + if(vname .eq. 'PDP') call write_var3d(vname, pthp0 (1:nsea,0:noswll) ) + if(vname .eq. 'PQP') call write_var3d(vname, pqp (1:nsea,0:noswll) ) + if(vname .eq. 'PPE') call write_var3d(vname, ppe (1:nsea,0:noswll) ) + if(vname .eq. 'PGW') call write_var3d(vname, pgw (1:nsea,0:noswll) ) + if(vname .eq. 'PSW') call write_var3d(vname, psw (1:nsea,0:noswll) ) + if(vname .eq. 'PTM1') call write_var3d(vname, ptm1 (1:nsea,0:noswll) ) + if(vname .eq. 'PT1') call write_var3d(vname, pt1 (1:nsea,0:noswll) ) + if(vname .eq. 'PT2') call write_var3d(vname, pt2 (1:nsea,0:noswll) ) + if(vname .eq. 'PEP') call write_var3d(vname, pep (1:nsea,0:noswll) ) + + else if (trim(outvars(n)%dims) == 'm') then ! m axis + var3d => var3dm + ! Group 6 + if (vname .eq. 'P2SMS') call write_var3d(vname, p2sms (1:nsea,p2msf(2):p2msf(3)) ) + + else if (trim(outvars(n)%dims) == 'p') then ! partition axis + var3d => var3dp + ! Group 6 + if (vname .eq. 'USSPX') call write_var3d(vname, ussp (1:nsea, 1:usspf(2)) ) + if (vname .eq. 'USSPY') call write_var3d(vname, ussp (1:nsea,nk+1:nk+usspf(2)) ) + + else if (trim(outvars(n)%dims) == 'k') then ! freq axis + var3d => var3dk + ! Group 3 + if(vname .eq. 'EF') call write_var3d(vname, ef (1:nsea,e3df(2,1):e3df(3,1)) ) + if(vname .eq. 'TH1M') call write_var3d(vname, ef (1:nsea,e3df(2,2):e3df(3,2)) ) + if(vname .eq. 'STH1M') call write_var3d(vname, ef (1:nsea,e3df(2,3):e3df(3,3)) ) + if(vname .eq. 'TH2M') call write_var3d(vname, ef (1:nsea,e3df(2,4):e3df(3,4)) ) + if(vname .eq. 'STH2M') call write_var3d(vname, ef (1:nsea,e3df(2,5):e3df(3,5)) ) + !TODO: wn has reversed indices (1:nk, 1:nsea) + ! Group 6 + if (vname .eq. 'US3DX') call write_var3d(vname, us3d (1:nsea, us3df(2):us3df(3)) ) + if (vname .eq. 'US3DY') call write_var3d(vname, us3d (1:nsea,nk+us3df(2):nk+us3df(3)) ) + + else + ! Group 1 + if (vname .eq. 'DW') call write_var2d(vname, dw (1:nsea), init0='false') + if (vname .eq. 'CX') call write_var2d(vname, cx (1:nsea), init0='false') + if (vname .eq. 'CY') call write_var2d(vname, cy (1:nsea), init0='false') + if (vname .eq. 'UAX') call write_var2d(vname, ua (1:nsea), dir=cos(ud(1:nsea)), init0='false') + if (vname .eq. 'UAY') call write_var2d(vname, ua (1:nsea), dir=sin(ud(1:nsea)), init0='false') + if (vname .eq. 'AS') call write_var2d(vname, as (1:nsea), init0='false') + if (vname .eq. 'WLV') call write_var2d(vname, wlv (1:nsea), init0='false') + if (vname .eq. 'ICE') call write_var2d(vname, ice (1:nsea), init0='false') + if (vname .eq. 'BERG') call write_var2d(vname, berg (1:nsea), init0='false') + if (vname .eq. 'TAUX') call write_var2d(vname, taua (1:nsea), dir=cos(tauadir(1:nsea)), init0='false') + if (vname .eq. 'TAUY') call write_var2d(vname, taua (1:nsea), dir=sin(tauadir(1:nsea)), init0='false') + if (vname .eq. 'RHOAIR') call write_var2d(vname, rhoair (1:nsea), init0='false') + if (vname .eq. 'ICEH') call write_var2d(vname, iceh (1:nsea), init0='false') + if (vname .eq. 'ICEF') call write_var2d(vname, icef (1:nsea), init0='false') + + ! Group 2 + if (vname .eq. 'HS') call write_var2d(vname, hs (1:nsea) ) + if (vname .eq. 'WLM') call write_var2d(vname, wlm (1:nsea) ) + if (vname .eq. 'T02') call write_var2d(vname, t02 (1:nsea) ) + if (vname .eq. 'T0M1') call write_var2d(vname, t0m1 (1:nsea) ) + if (vname .eq. 'T01') call write_var2d(vname, t01 (1:nsea) ) + if (vname .eq. 'FP0') call write_var2d(vname, fp0 (1:nsea) ) + if (vname .eq. 'THM') call write_var2d(vname, thm (1:nsea) ) + if (vname .eq. 'THS') call write_var2d(vname, ths (1:nsea) ) + if (vname .eq. 'THP0') call write_var2d(vname, thp0 (1:nsea) ) + if (vname .eq. 'HSIG') call write_var2d(vname, hsig (1:nsea) ) + if (vname .eq. 'STMAXE') call write_var2d(vname, stmaxe (1:nsea) ) + if (vname .eq. 'STMAXD') call write_var2d(vname, stmaxd (1:nsea) ) + if (vname .eq. 'HMAXE') call write_var2d(vname, hmaxe (1:nsea) ) + if (vname .eq. 'HCMAXE') call write_var2d(vname, hcmaxe (1:nsea) ) + if (vname .eq. 'HMAXD') call write_var2d(vname, hmaxd (1:nsea) ) + if (vname .eq. 'HCMAXD') call write_var2d(vname, hcmaxd (1:nsea) ) + if (vname .eq. 'WBT') call write_var2d(vname, wbt (1:nsea) ) + if (vname .eq. 'WNMEAN') call write_var2d(vname, wnmean (1:nsea), init0='false') + + ! Group 4 + if(vname .eq. 'PWST') call write_var2d(vname, pwst (1:nsea) ) + if(vname .eq. 'PNR') call write_var2d(vname, pnr (1:nsea) ) + + ! Group 5 + if (vname .eq. 'USTX') call write_var2d(vname, ust (1:nsea)*asf(1:nsea), dir=cos(ustdir(1:nsea)), usemask='true') + if (vname .eq. 'USTY') call write_var2d(vname, ust (1:nsea)*asf(1:nsea), dir=sin(ustdir(1:nsea)), usemask='true') + if (vname .eq. 'CHA') call write_var2d(vname, charn (1:nsea) ) + if (vname .eq. 'CGE') call write_var2d(vname, cge (1:nsea) ) + if (vname .eq. 'PHIAW') call write_var2d(vname, phiaw (1:nsea), init2='true') + if (vname .eq. 'TAUWIX') call write_var2d(vname, tauwix (1:nsea), init2='true') + if (vname .eq. 'TAUWIY') call write_var2d(vname, tauwiy (1:nsea), init2='true') + if (vname .eq. 'TAUWNX') call write_var2d(vname, tauwnx (1:nsea), init2='true') + if (vname .eq. 'TAUWNY') call write_var2d(vname, tauwny (1:nsea), init2='true') + if (vname .eq. 'WCC') call write_var2d(vname, whitecap (1:nsea,1), init2='true') + if (vname .eq. 'WCF') call write_var2d(vname, whitecap (1:nsea,2), init2='true') + if (vname .eq. 'WCH') call write_var2d(vname, whitecap (1:nsea,3), init2='true') + if (vname .eq. 'WCM') call write_var2d(vname, whitecap (1:nsea,4), init2='true') + if (vname .eq. 'TWS') call write_var2d(vname, tws (1:nsea) ) + + ! Group 6 + if (vname .eq. 'SXX') call write_var2d(vname, sxx (1:nsea) ) + if (vname .eq. 'SYY') call write_var2d(vname, syy (1:nsea) ) + if (vname .eq. 'SXY') call write_var2d(vname, sxy (1:nsea) ) + if (vname .eq. 'TAUOX') call write_var2d(vname, tauox (1:nsea), init2='true') + if (vname .eq. 'TAUOY') call write_var2d(vname, tauoy (1:nsea), init2='true') + if (vname .eq. 'BHD') call write_var2d(vname, bhd (1:nsea) ) + if (vname .eq. 'PHIOC') call write_var2d(vname, phioc (1:nsea), init2='true') + if (vname .eq. 'TUSX') call write_var2d(vname, tusx (1:nsea) ) + if (vname .eq. 'TUSY') call write_var2d(vname, tusy (1:nsea) ) + if (vname .eq. 'USSX') call write_var2d(vname, ussx (1:nsea) ) + if (vname .eq. 'USSY') call write_var2d(vname, ussy (1:nsea) ) + if (vname .eq. 'PRMS') call write_var2d(vname, prms (1:nsea) ) + if (vname .eq. 'TPMS') call write_var2d(vname, tpms (1:nsea) ) + if (vname .eq. 'TAUICEX') call write_var2d(vname, tauice (1:nsea,1) ) + if (vname .eq. 'TAUICEY') call write_var2d(vname, tauice (1:nsea,2) ) + if (vname .eq. 'PHICE') call write_var2d(vname, phice (1:nsea) ) + if (vname .eq. 'TAUOCX') call write_var2d(vname, tauocx (1:nsea) ) + if (vname .eq. 'TAUOCY') call write_var2d(vname, tauocy (1:nsea) ) #ifdef W3_CESMCOUPLED - if (vname .eq. 'LANGMT') call write_var2d(vname, langmt (1:nsea) ) + if (vname .eq. 'LANGMT') call write_var2d(vname, langmt (1:nsea) ) #endif - ! Group 7 - if (vname .eq. 'ABAX') call write_var2d(vname, aba (1:nsea), dir=cos(abd(1:nsea)) ) - if (vname .eq. 'ABAY') call write_var2d(vname, aba (1:nsea), dir=sin(abd(1:nsea)) ) - if (vname .eq. 'UBAX') call write_var2d(vname, uba (1:nsea), dir=cos(ubd(1:nsea)) ) - if (vname .eq. 'UBAY') call write_var2d(vname, uba (1:nsea), dir=sin(ubd(1:nsea)) ) - if (vname .eq. 'BED') call write_var2d(vname, bedforms (1:nsea,1), init2='true') - if (vname .eq. 'RIPPLEX') call write_var2d(vname, bedforms (1:nsea,2), init2='true') - if (vname .eq. 'RIPPLEY') call write_var2d(vname, bedforms (1:nsea,3), init2='true') - if (vname .eq. 'PHIBBL') call write_var2d(vname, phibbl (1:nsea), init2='true') - if (vname .eq. 'TAUBBLX') call write_var2d(vname, taubbl (1:nsea,1), init2='true') - if (vname .eq. 'TAUBBLY') call write_var2d(vname, taubbl (1:nsea,2), init2='true') - - ! Group 8 - if (vname .eq. 'MSSX') call write_var2d(vname, mssx (1:nsea) ) - if (vname .eq. 'MSSY') call write_var2d(vname, mssy (1:nsea) ) - if (vname .eq. 'MSCX') call write_var2d(vname, mscx (1:nsea) ) - if (vname .eq. 'MSCY') call write_var2d(vname, mscy (1:nsea) ) - !TODO: remaining variables have inconsistency between shel_inp listing and iogo code - - ! Group 9 - if (vname .eq. 'DTDYN') call write_var2d(vname, dtdyn (1:nsea) ) - if (vname .eq. 'FCUT') call write_var2d(vname, fcut (1:nsea) ) - if (vname .eq.'CFLXYMAX') call write_var2d(vname, cflxymax (1:nsea) ) - if (vname .eq.'CFLTHMAX') call write_var2d(vname, cflthmax (1:nsea) ) - if (vname .eq. 'CFLKMAX') call write_var2d(vname, cflkmax (1:nsea) ) - - ! Group 10 - end if + ! Group 7 + if (vname .eq. 'ABAX') call write_var2d(vname, aba (1:nsea), dir=cos(abd(1:nsea)) ) + if (vname .eq. 'ABAY') call write_var2d(vname, aba (1:nsea), dir=sin(abd(1:nsea)) ) + if (vname .eq. 'UBAX') call write_var2d(vname, uba (1:nsea), dir=cos(ubd(1:nsea)) ) + if (vname .eq. 'UBAY') call write_var2d(vname, uba (1:nsea), dir=sin(ubd(1:nsea)) ) + if (vname .eq. 'BED') call write_var2d(vname, bedforms (1:nsea,1), init2='true') + if (vname .eq. 'RIPPLEX') call write_var2d(vname, bedforms (1:nsea,2), init2='true') + if (vname .eq. 'RIPPLEY') call write_var2d(vname, bedforms (1:nsea,3), init2='true') + if (vname .eq. 'PHIBBL') call write_var2d(vname, phibbl (1:nsea), init2='true') + if (vname .eq. 'TAUBBLX') call write_var2d(vname, taubbl (1:nsea,1), init2='true') + if (vname .eq. 'TAUBBLY') call write_var2d(vname, taubbl (1:nsea,2), init2='true') + + ! Group 8 + if (vname .eq. 'MSSX') call write_var2d(vname, mssx (1:nsea) ) + if (vname .eq. 'MSSY') call write_var2d(vname, mssy (1:nsea) ) + if (vname .eq. 'MSCX') call write_var2d(vname, mscx (1:nsea) ) + if (vname .eq. 'MSCY') call write_var2d(vname, mscy (1:nsea) ) + !TODO: remaining variables have inconsistency between shel_inp listing and iogo code + + ! Group 9 + if (vname .eq. 'DTDYN') call write_var2d(vname, dtdyn (1:nsea) ) + if (vname .eq. 'FCUT') call write_var2d(vname, fcut (1:nsea) ) + if (vname .eq.'CFLXYMAX') call write_var2d(vname, cflxymax (1:nsea) ) + if (vname .eq.'CFLTHMAX') call write_var2d(vname, cflthmax (1:nsea) ) + if (vname .eq. 'CFLKMAX') call write_var2d(vname, cflkmax (1:nsea) ) + + ! Group 10 + end if end do if (s_axis) deallocate(var3ds) @@ -389,15 +389,15 @@ subroutine write_var2d(vname, var, dir, usemask, init0, init2) lmask = .false. if (present(usemask)) then - lmask = (trim(usemask) == "true") + lmask = (trim(usemask) == "true") end if linit0 = .true. if (present(init0)) then - linit0 = (trim(init0) == "true") + linit0 = (trim(init0) == "true") end if linit2 = .false. if (present(init2)) then - linit2 = (trim(init2) == "true") + linit2 = (trim(init2) == "true") end if ! DEBUG @@ -406,28 +406,28 @@ subroutine write_var2d(vname, var, dir, usemask, init0, init2) var2d = undef do isea = 1,nsea - ! initialization - varloc = var(isea) - if (linit0) then - if (mapsta(mapsf(isea,2),mapsf(isea,1)) < 0) varloc = undef - end if - if (linit2) then - if (mapsta(mapsf(isea,2),mapsf(isea,1)) == 2) varloc = undef - end if - - if (present(dir)) then - if (varloc .ne. undef) then - if (lmask) then - if (mapsta(mapsf(isea,2),mapsf(isea,1)) == 1) then - var2d(mapsf(isea,1),mapsf(isea,2)) = varloc*dir(isea) - end if - else - var2d(mapsf(isea,1),mapsf(isea,2)) = varloc*dir(isea) - end if + ! initialization + varloc = var(isea) + if (linit0) then + if (mapsta(mapsf(isea,2),mapsf(isea,1)) < 0) varloc = undef + end if + if (linit2) then + if (mapsta(mapsf(isea,2),mapsf(isea,1)) == 2) varloc = undef + end if + + if (present(dir)) then + if (varloc .ne. undef) then + if (lmask) then + if (mapsta(mapsf(isea,2),mapsf(isea,1)) == 1) then + var2d(mapsf(isea,1),mapsf(isea,2)) = varloc*dir(isea) + end if + else + var2d(mapsf(isea,1),mapsf(isea,2)) = varloc*dir(isea) end if - else - var2d(mapsf(isea,1),mapsf(isea,2)) = varloc - end if + end if + else + var2d(mapsf(isea,1),mapsf(isea,2)) = varloc + end if end do ierr = nf90_open(trim(fname), nf90_write, ncid) @@ -457,7 +457,7 @@ subroutine write_var3d(vname, var, init2) linit2 = .false. if (present(init2)) then - linit2 = (trim(init2) == "true") + linit2 = (trim(init2) == "true") end if lb = lbound(var,2) @@ -470,13 +470,13 @@ subroutine write_var3d(vname, var, init2) var3d = undef do isea = 1,nsea - ! initialization - varloc(:) = var(isea,:) - if (mapsta(mapsf(isea,2),mapsf(isea,1)) < 0) varloc(:) = undef - if (linit2) then - if (mapsta(mapsf(isea,2),mapsf(isea,1)) == 2) varloc(:) = undef - end if - var3d(mapsf(isea,1),mapsf(isea,2),:) = varloc(:) + ! initialization + varloc(:) = var(isea,:) + if (mapsta(mapsf(isea,2),mapsf(isea,1)) < 0) varloc(:) = undef + if (linit2) then + if (mapsta(mapsf(isea,2),mapsf(isea,1)) == 2) varloc(:) = undef + end if + var3d(mapsf(isea,1),mapsf(isea,2),:) = varloc(:) end do ierr = nf90_open(trim(fname), nf90_write, ncid) @@ -500,8 +500,8 @@ subroutine handle_err(ierr,string) character(len=*), intent(in) :: string if (ierr /= nf90_noerr) then - write(ndse,*) "*** WAVEWATCH III netcdf error: ",trim(string),':',trim(nf90_strerror(ierr)) - call extcde ( 49 ) + write(ndse,*) "*** WAVEWATCH III netcdf error: ",trim(string),':',trim(nf90_strerror(ierr)) + call extcde ( 49 ) end if end subroutine handle_err diff --git a/model/src/w3iogrmd.F90 b/model/src/w3iogrmd.F90 index a364c676d..7c4d11c64 100644 --- a/model/src/w3iogrmd.F90 +++ b/model/src/w3iogrmd.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Reading/writing of model definition file. -!> +!> !> @author H. L. Tolman !> @author F. Ardhuin !> @date 15-Apr-2020 @@ -10,1868 +10,1817 @@ !/ ------------------------------------------------------------------- / !> !> @brief Reading/writing of model definition file. -!> +!> !> @details Arrays allocated here on read or ing ww3_grid on write. !> !> @author H. L. Tolman !> @author F. Ardhuin !> @date 15-Apr-2020 !> - MODULE W3IOGRMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ ! F. Ardhuin ! -!/ | FORTRAN 90 | -!/ | Last update : 15-Apr-2020 | -!/ +-----------------------------------+ -!/ -!/ For updates see W3IOGR documentation. -!/ -! 1. Purpose : -! -! Reading/writing of model definition file . -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! VERGRD C*10 Private Model definition file version number. -! IDSTR C*35 Private Model definition file ID string. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3IOGR Subr. Public Read/write model definition file. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to data structure for spatial gr. -! W3DIMX Subr. Id. Set up arrays for spatial grid. -! W3DIMS Subr. Id. Set array dimensions for a spec. grid. -! W3SETO Subr. W3ODATMD Point to data structure for spatial gr. -! W3DMO5 Subr. Id. Set array dimensions. -! INPTAB Subr. W3SRC2MD Fill interpolation tables for -! dispersion relation. -! DISTAB Subr. W3DISPMD Input coefficient lookup table. -! INSNL1 Subr. W3SNL1MD Initialization of the DIA. -! INSNL2 Subr. W3SNL2MD Initialization of WRT. -! INSNL3 Subr. W3SNL3MD Initialization of GMD. -! INSNL5 Subr. W3SNL5MD Initialization of GKE. -! INSNLS Subr. W3SNLSMD Initialization of nonlinear `smoother'. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - Arrays allocated here on read or ing ww3_grid on write. -! -! 6. Switches : -! -! See subroutine. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Private parameter statements (ID strings) -!/ - CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERGRD = '2021-08-06' - CHARACTER(LEN=35), PARAMETER, PRIVATE :: & - IDSTR = 'WAVEWATCH III MODEL DEFINITION FILE' -!/ -!/ Public variables -!/ -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Reading and writing of the model definition file. -!> -!> @details The file is opened within the routine, the name is pre-defined -!> and the unit number is given in the parameter list. The model -!> definition file is written using UNFORMATTED write statements. -!> -!> @param[in] INXOUT Test string for read/write. -!> @param[in] NDSM File unit number. -!> @param[in] IMOD Model number for W3GDAT etc. -!> @param[in] FEXT File extension to be used. -!> -!> @author H. L. Tolman -!> @author F. Ardhuin -!> @date 19-Oct-2020 - - SUBROUTINE W3IOGR ( INXOUT, NDSM, IMOD, FEXT ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ ! F. Ardhuin ! -!/ | FORTRAN 90 | -!/ | Last update : 19-Oct-2020 | -!/ +-----------------------------------+ -!/ -!/ 14-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) -!/ 09-Jan-2001 : Flat grid option. ( version 2.06 ) -!/ 02-Feb-2001 : Exact-NL version 3.0 ( version 2.07 ) -!/ 27-Feb-2001 : Third propagation scheme added. ( version 2.08 ) -!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) -!/ 29-Mar-2001 : Sub-grid islands added. ( version 2.10 ) -!/ 11-Jan-2002 : Sub-grid ice added. ( version 2.15 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 27-Aug-2002 : Exact-NL version 4.0 ( version 2.22 ) -!/ 26-Nov-2002 : Adding first VDIA and MDIA. ( version 3.01 ) -!/ 01-Aug-2003 : Adding moving grid GSE correction. ( version 3.03 ) -!/ 08-Mar-2004 : Multiple grid version. ( version 3.06 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 24-Jun-2005 : Add MAPST2 processing. ( version 3.07 ) -!/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) -!/ 23-Jun-2006 : Add W3SLN1 parameters. ( version 3.09 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 25-Jul-2006 : Reorder for 'GRID' option to read ( version 3.10 ) -!/ spectral data also. -!/ 28-Oct-2006 : Add partitioning pars. ( version 3.10 ) -!/ 26-Mar-2007 : Add partitioning pars. ( version 3.11 ) -!/ 16-Apr-2006 : Add Miche limiter pars. ( version 3.11 ) -!/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) -!/ 09-Oct-2007 : Adding WAM cycle 4+ Sin and Sds. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Fix ndst arg in call to w3dmo5. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 23-Dec-2009 : Addition of COU namelists ( version 3.14 ) -!/ 31-Oct-2010 : Implement unstructured grids ( version 3.14 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 13-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) -!/ from 3.15 (HLT). ( version 4.08 ) -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) -!/ 19-Dec-2012 : Add NOSWLL to file. ( version 4.11 ) -!/ 01-Jul-2013 : Document UQ / UNO switches in file ( version 4.12 ) -!/ 10-Sep-2013 : Add IG1 parameters ( version 4.12 ) -!/ 16-Sep-2013 : Add Arctic part in SMC grid. ( version 4.12 ) -!/ 11-Nov-2013 : Make SMC and RTD grids compatible. ( version 4.13 ) -!/ 06-Mar-2014 : Writes out a help message on error ( version 4.18 ) -!/ 10-Mar-2014 : Add IC2 parameters ( version 5.01 ) -!/ 29-May-2014 : Add IC3 parameters ( version 5.01 ) -!/ 20-Aug-2016 : Add IOBPA ( version 5.12 ) -!/ 08-Mar-2018 : Add FSWND for SMC grid. ( version 6.02 ) -!/ 05-Jun-2018 : Add PDLIB/DEBUGINIT and implcit scheme parameters -!/ for unstructured grids ( version 6.04 ) -!/ 27-Jul-2018 : Added PTMETH and PTFCUT parameters ( version 6.05 ) -!/ (C. Bunney, UKMO) -!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) -!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) -!/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) -!/ 18-Jun-2020 : Adds 360-day calendar option ( version 7.08 ) -!/ 19-Oct-2020 : Add AIRCMIN, AIRGB parameters ( version 7.08 ) -!/ 07-07-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.12 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Reading and writing of the model definition file. -! -! 2. Method : -! -! The file is opened within the routine, the name is pre-defined -! and the unit number is given in the parameter list. The model -! definition file is written using UNFORMATTED write statements. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ', 'WRITE' and 'GRID'. -! NDSM Int. I File unit number. -! IMOD Int. I Model number for W3GDAT etc. -! FEXT C*(*) I File extension to be used. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See above. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ...... Prog. N/A All WAVEWATCH III aux programs and -! drivers. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! Tests on INXOUT, file status and on array dimensions. -! -! 7. Remarks : -! -! - The model definition file has the pre-defined name -! 'mod_def.FILEXT'. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI MPI calls -! -! !/LNn Select source terms -! !/STn -! !/NLn -! !/BTn -! !/DBn -! !/TRn -! !/BSn -! !/XXn -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD +MODULE W3IOGRMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ ! F. Ardhuin ! + !/ | FORTRAN 90 | + !/ | Last update : 15-Apr-2020 | + !/ +-----------------------------------+ + !/ + !/ For updates see W3IOGR documentation. + !/ + ! 1. Purpose : + ! + ! Reading/writing of model definition file . + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! VERGRD C*10 Private Model definition file version number. + ! IDSTR C*35 Private Model definition file ID string. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. Public Read/write model definition file. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to data structure for spatial gr. + ! W3DIMX Subr. Id. Set up arrays for spatial grid. + ! W3DIMS Subr. Id. Set array dimensions for a spec. grid. + ! W3SETO Subr. W3ODATMD Point to data structure for spatial gr. + ! W3DMO5 Subr. Id. Set array dimensions. + ! INPTAB Subr. W3SRC2MD Fill interpolation tables for + ! dispersion relation. + ! DISTAB Subr. W3DISPMD Input coefficient lookup table. + ! INSNL1 Subr. W3SNL1MD Initialization of the DIA. + ! INSNL2 Subr. W3SNL2MD Initialization of WRT. + ! INSNL3 Subr. W3SNL3MD Initialization of GMD. + ! INSNL5 Subr. W3SNL5MD Initialization of GKE. + ! INSNLS Subr. W3SNLSMD Initialization of nonlinear `smoother'. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - Arrays allocated here on read or ing ww3_grid on write. + ! + ! 6. Switches : + ! + ! See subroutine. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + !/ Private parameter statements (ID strings) + !/ + CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERGRD = '2021-08-06' + CHARACTER(LEN=35), PARAMETER, PRIVATE :: & + IDSTR = 'WAVEWATCH III MODEL DEFINITION FILE' + !/ + !/ Public variables + !/ + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Reading and writing of the model definition file. + !> + !> @details The file is opened within the routine, the name is pre-defined + !> and the unit number is given in the parameter list. The model + !> definition file is written using UNFORMATTED write statements. + !> + !> @param[in] INXOUT Test string for read/write. + !> @param[in] NDSM File unit number. + !> @param[in] IMOD Model number for W3GDAT etc. + !> @param[in] FEXT File extension to be used. + !> + !> @author H. L. Tolman + !> @author F. Ardhuin + !> @date 19-Oct-2020 + + SUBROUTINE W3IOGR ( INXOUT, NDSM, IMOD, FEXT ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ ! F. Ardhuin ! + !/ | FORTRAN 90 | + !/ | Last update : 19-Oct-2020 | + !/ +-----------------------------------+ + !/ + !/ 14-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) + !/ 09-Jan-2001 : Flat grid option. ( version 2.06 ) + !/ 02-Feb-2001 : Exact-NL version 3.0 ( version 2.07 ) + !/ 27-Feb-2001 : Third propagation scheme added. ( version 2.08 ) + !/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) + !/ 29-Mar-2001 : Sub-grid islands added. ( version 2.10 ) + !/ 11-Jan-2002 : Sub-grid ice added. ( version 2.15 ) + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 27-Aug-2002 : Exact-NL version 4.0 ( version 2.22 ) + !/ 26-Nov-2002 : Adding first VDIA and MDIA. ( version 3.01 ) + !/ 01-Aug-2003 : Adding moving grid GSE correction. ( version 3.03 ) + !/ 08-Mar-2004 : Multiple grid version. ( version 3.06 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 24-Jun-2005 : Add MAPST2 processing. ( version 3.07 ) + !/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) + !/ 23-Jun-2006 : Add W3SLN1 parameters. ( version 3.09 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 25-Jul-2006 : Reorder for 'GRID' option to read ( version 3.10 ) + !/ spectral data also. + !/ 28-Oct-2006 : Add partitioning pars. ( version 3.10 ) + !/ 26-Mar-2007 : Add partitioning pars. ( version 3.11 ) + !/ 16-Apr-2006 : Add Miche limiter pars. ( version 3.11 ) + !/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) + !/ 09-Oct-2007 : Adding WAM cycle 4+ Sin and Sds. ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Fix ndst arg in call to w3dmo5. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 23-Dec-2009 : Addition of COU namelists ( version 3.14 ) + !/ 31-Oct-2010 : Implement unstructured grids ( version 3.14 ) + !/ (A. Roland and F. Ardhuin) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 12-Jun-2012 : Add /RTD option or rotated grid option. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 13-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) + !/ from 3.15 (HLT). ( version 4.08 ) + !/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) + !/ 19-Dec-2012 : Add NOSWLL to file. ( version 4.11 ) + !/ 01-Jul-2013 : Document UQ / UNO switches in file ( version 4.12 ) + !/ 10-Sep-2013 : Add IG1 parameters ( version 4.12 ) + !/ 16-Sep-2013 : Add Arctic part in SMC grid. ( version 4.12 ) + !/ 11-Nov-2013 : Make SMC and RTD grids compatible. ( version 4.13 ) + !/ 06-Mar-2014 : Writes out a help message on error ( version 4.18 ) + !/ 10-Mar-2014 : Add IC2 parameters ( version 5.01 ) + !/ 29-May-2014 : Add IC3 parameters ( version 5.01 ) + !/ 20-Aug-2016 : Add IOBPA ( version 5.12 ) + !/ 08-Mar-2018 : Add FSWND for SMC grid. ( version 6.02 ) + !/ 05-Jun-2018 : Add PDLIB/DEBUGINIT and implcit scheme parameters + !/ for unstructured grids ( version 6.04 ) + !/ 27-Jul-2018 : Added PTMETH and PTFCUT parameters ( version 6.05 ) + !/ (C. Bunney, UKMO) + !/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) + !/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) + !/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) + !/ 18-Jun-2020 : Adds 360-day calendar option ( version 7.08 ) + !/ 19-Oct-2020 : Add AIRCMIN, AIRGB parameters ( version 7.08 ) + !/ 07-07-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.12 ) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Reading and writing of the model definition file. + ! + ! 2. Method : + ! + ! The file is opened within the routine, the name is pre-defined + ! and the unit number is given in the parameter list. The model + ! definition file is written using UNFORMATTED write statements. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'READ', 'WRITE' and 'GRID'. + ! NDSM Int. I File unit number. + ! IMOD Int. I Model number for W3GDAT etc. + ! FEXT C*(*) I File extension to be used. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See above. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Wave model initialization routine. + ! ...... Prog. N/A All WAVEWATCH III aux programs and + ! drivers. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! Tests on INXOUT, file status and on array dimensions. + ! + ! 7. Remarks : + ! + ! - The model definition file has the pre-defined name + ! 'mod_def.FILEXT'. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI MPI calls + ! + ! !/LNn Select source terms + ! !/STn + ! !/NLn + ! !/BTn + ! !/DBn + ! !/TRn + ! !/BSn + ! !/XXn + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD #ifdef W3_MPI - USE W3ADATMD, ONLY: MPI_COMM_WAVE + USE W3ADATMD, ONLY: MPI_COMM_WAVE #endif - USE W3ODATMD + USE W3ODATMD #ifdef W3_ST2 - USE W3SRC2MD, ONLY: INPTAB + USE W3SRC2MD, ONLY: INPTAB #endif #ifdef W3_ST3 - USE W3SRC3MD, ONLY: INSIN3 + USE W3SRC3MD, ONLY: INSIN3 #endif #ifdef W3_ST4 - USE W3SRC4MD, ONLY: INSIN4, TAUT, TAUHFT, TAUHFT2, & - DELU, DELTAUW, DELUST, & - DELALP, DELTAIL, & - DIKCUMUL + USE W3SRC4MD, ONLY: INSIN4, TAUT, TAUHFT, TAUHFT2, & + DELU, DELTAUW, DELUST, & + DELALP, DELTAIL, & + DIKCUMUL #endif #ifdef W3_NL1 - USE W3SNL1MD, ONLY: INSNL1 + USE W3SNL1MD, ONLY: INSNL1 #endif #ifdef W3_NL2 - USE W3SNL2MD, ONLY: INSNL2 + USE W3SNL2MD, ONLY: INSNL2 #endif #ifdef W3_NL3 - USE W3SNL3MD, ONLY: INSNL3 + USE W3SNL3MD, ONLY: INSNL3 #endif #ifdef W3_NL5 - USE W3SNL5MD, ONLY: INSNL5 + USE W3SNL5MD, ONLY: INSNL5 #endif #ifdef W3_NLS - USE W3SNLSMD, ONLY: INSNLS + USE W3SNLSMD, ONLY: INSNLS #endif #ifdef W3_IS2 - USE W3SIS2MD, ONLY: INSIS2 + USE W3SIS2MD, ONLY: INSIS2 #endif - USE W3TIMEMD, ONLY: CALTYPE - USE W3SERVMD, ONLY: EXTCDE + USE W3TIMEMD, ONLY: CALTYPE + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3DISPMD + USE W3DISPMD #ifdef W3_UOST - USE W3UOSTMD, ONLY: UOST_INITGRID + USE W3UOSTMD, ONLY: UOST_INITGRID #endif #ifdef W3_MEMCHECK - USE W3ADATMD, ONLY: MALLINFOS - USE MallocInfo_m + USE W3ADATMD, ONLY: MALLINFOS + USE MallocInfo_m #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSM - INTEGER, INTENT(IN), OPTIONAL :: IMOD - CHARACTER, INTENT(IN) :: INXOUT*(*) - CHARACTER, INTENT(IN), OPTIONAL :: FEXT*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IGRD, IERR, I, J, MTH, MK, ISEA, IX, IY - INTEGER :: IEXT, IPRE + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSM + INTEGER, INTENT(IN), OPTIONAL :: IMOD + CHARACTER, INTENT(IN) :: INXOUT*(*) + CHARACTER, INTENT(IN), OPTIONAL :: FEXT*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IGRD, IERR, I, J, MTH, MK, ISEA, IX, IY + INTEGER :: IEXT, IPRE #ifdef W3_ST4 - INTEGER :: IK, ITH, IK2, ITH2 + INTEGER :: IK, ITH, IK2, ITH2 #endif - INTEGER, ALLOCATABLE :: MAPTMP(:,:) + INTEGER, ALLOCATABLE :: MAPTMP(:,:) #ifdef W3_MPI - INTEGER :: IERR_MPI, IP + INTEGER :: IERR_MPI, IP #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T - INTEGER :: K -#endif - LOGICAL :: WRITE, FLTEST = .FALSE., TESTLL, & - FLSNL2 = .FALSE. - LOGICAL, SAVE :: FLINP = .FALSE. , FLDISP = .FALSE., & - FLIS = .FALSE. - CHARACTER(LEN=10) :: VERTST - CHARACTER(LEN=13) :: TEMPXT - CHARACTER(LEN=30) :: TNAME0, TNAME1, TNAME2, TNAME3, & - TNAME4, TNAME5, TNAME6, & - TNAMEP, TNAMEG, TNAMEF, TNAMEI - CHARACTER(LEN=30) :: FNAME0, FNAME1, FNAME2, FNAME3, & - FNAME4, FNAME5, FNAME6, & - FNAMEP, FNAMEG, FNAMEF, FNAMEI - CHARACTER(LEN=35) :: IDTST - CHARACTER(LEN=60) :: MESSAGE(5) - LOGICAL :: GLOBAL + INTEGER :: K +#endif + LOGICAL :: WRITE, FLTEST = .FALSE., TESTLL, & + FLSNL2 = .FALSE. + LOGICAL, SAVE :: FLINP = .FALSE. , FLDISP = .FALSE., & + FLIS = .FALSE. + CHARACTER(LEN=10) :: VERTST + CHARACTER(LEN=13) :: TEMPXT + CHARACTER(LEN=30) :: TNAME0, TNAME1, TNAME2, TNAME3, & + TNAME4, TNAME5, TNAME6, & + TNAMEP, TNAMEG, TNAMEF, TNAMEI + CHARACTER(LEN=30) :: FNAME0, FNAME1, FNAME2, FNAME3, & + FNAME4, FNAME5, FNAME6, & + FNAMEP, FNAMEG, FNAMEF, FNAMEI + CHARACTER(LEN=35) :: IDTST + CHARACTER(LEN=60) :: MESSAGE(5) + LOGICAL :: GLOBAL - REAL, ALLOCATABLE :: XGRD4(:,:), YGRD4(:,:) -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL, ALLOCATABLE :: XGRD4(:,:), YGRD4(:,:) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3IOGR') + CALL STRACE (IENT, 'W3IOGR') #endif -! + ! #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 1' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif - MESSAGE =(/ ' MOD DEF FILE WAS GENERATED WITH A DIFFERENT ', & - ' WW3 VERSION OR USING A DIFFERENT SWITCH FILE. ', & - ' MAKE SURE WW3_GRID IS COMPILED WITH SAME SWITCH', & - ' AS WW3_SHEL OR WW3_MULTI, RUN WW3_GRID AGAIN ', & - ' AND THEN TRY AGAIN THE PROGRAM YOU JUST USED. '/) -! - TNAMEF = '------------------------------' - TNAME0 = '------------------------------' - TNAME1 = '------------------------------' - TNAME2 = '------------------------------' - TNAME3 = '------------------------------' - TNAME4 = '------------------------------' - TNAME5 = '------------------------------' - TNAME6 = '------------------------------' - TNAMEP = '------------------------------' - TNAMEG = '------------------------------' - TNAMEI = '------------------------------' -! + MESSAGE =(/ ' MOD DEF FILE WAS GENERATED WITH A DIFFERENT ', & + ' WW3 VERSION OR USING A DIFFERENT SWITCH FILE. ', & + ' MAKE SURE WW3_GRID IS COMPILED WITH SAME SWITCH', & + ' AS WW3_SHEL OR WW3_MULTI, RUN WW3_GRID AGAIN ', & + ' AND THEN TRY AGAIN THE PROGRAM YOU JUST USED. '/) + ! + TNAMEF = '------------------------------' + TNAME0 = '------------------------------' + TNAME1 = '------------------------------' + TNAME2 = '------------------------------' + TNAME3 = '------------------------------' + TNAME4 = '------------------------------' + TNAME5 = '------------------------------' + TNAME6 = '------------------------------' + TNAMEP = '------------------------------' + TNAMEG = '------------------------------' + TNAMEI = '------------------------------' + ! #ifdef W3_FLX1 - TNAMEF = 'Wu (1980) ' + TNAMEF = 'Wu (1980) ' #endif #ifdef W3_FLX2 - TNAMEF = 'Tolman and Chalikov (1996) ' + TNAMEF = 'Tolman and Chalikov (1996) ' #endif #ifdef W3_FLX3 - TNAMEF = 'T and C(1996) with cap on Cd ' + TNAMEF = 'T and C(1996) with cap on Cd ' #endif #ifdef W3_FLX4 - TNAMEF = 'Hwang (2011) with cap on Cd ' + TNAMEF = 'Hwang (2011) with cap on Cd ' #endif #ifdef W3_FLX5 - TNAMEF = 'Direct use of stress ' + TNAMEF = 'Direct use of stress ' #endif #ifdef W3_LN0 - TNAME0 = 'Not defined ' + TNAME0 = 'Not defined ' #endif #ifdef W3_LN1 - TNAME0 = 'Cavaleri and M.-R. (1982) ' + TNAME0 = 'Cavaleri and M.-R. (1982) ' #endif #ifdef W3_ST0 - TNAME1 = 'Not defined ' + TNAME1 = 'Not defined ' #endif #ifdef W3_ST1 - TNAME1 = 'WAM cycles 1 through 3 ' + TNAME1 = 'WAM cycles 1 through 3 ' #endif #ifdef W3_ST2 - TNAME1 = 'Tolman and Chalikov (1996) ' + TNAME1 = 'Tolman and Chalikov (1996) ' #endif #ifdef W3_ST3 - TNAME1 = 'WAM cycle 4+ ' + TNAME1 = 'WAM cycle 4+ ' #endif #ifdef W3_ST4 - TNAME1 = 'Ardhuin et al. (2009+) ' + TNAME1 = 'Ardhuin et al. (2009+) ' #endif #ifdef W3_ST6 - TNAME1 = 'BYDB input and dissipation ' + TNAME1 = 'BYDB input and dissipation ' #endif #ifdef W3_NL0 - TNAME2 = 'Not defined ' + TNAME2 = 'Not defined ' #endif #ifdef W3_NL1 - TNAME2 = 'Discrete Interaction Approx. ' + TNAME2 = 'Discrete Interaction Approx. ' #endif #ifdef W3_NL2 - TNAME2 = 'Exact nonlinear interactions ' + TNAME2 = 'Exact nonlinear interactions ' #endif #ifdef W3_NL3 - TNAME2 = 'Generalized Multiple DIA ' + TNAME2 = 'Generalized Multiple DIA ' #endif #ifdef W3_NL4 - TNAME2 = 'Two Scaled Approximation ' + TNAME2 = 'Two Scaled Approximation ' #endif #ifdef W3_NL5 - TNAME2 = 'Generalized Kinetic Equation ' + TNAME2 = 'Generalized Kinetic Equation ' #endif #ifdef W3_BT0 - TNAME3 = 'Not defined ' + TNAME3 = 'Not defined ' #endif #ifdef W3_BT1 - TNAME3 = 'JONSWAP ' + TNAME3 = 'JONSWAP ' #endif #ifdef W3_BT4 - TNAME3 = 'SHOWEX ' + TNAME3 = 'SHOWEX ' #endif #ifdef W3_BT8 - TNAME3 = 'Muddy Bed (D & L) ' + TNAME3 = 'Muddy Bed (D & L) ' #endif #ifdef W3_IC1 - TNAMEI = 'Ice sink term (uniform k_i) ' + TNAMEI = 'Ice sink term (uniform k_i) ' #endif #ifdef W3_IC2 - TNAMEI = 'Ice sink term (Lui et al) ' + TNAMEI = 'Ice sink term (Lui et al) ' #endif #ifdef W3_IC3 - TNAMEI = 'Ice sink term (Wang and Shen) ' + TNAMEI = 'Ice sink term (Wang and Shen) ' #endif #ifdef W3_IC4 - TNAMEI = 'Ice sink term (empirical) ' + TNAMEI = 'Ice sink term (empirical) ' #endif #ifdef W3_IC5 - TNAMEI = 'Ice sink term (eff. medium) ' + TNAMEI = 'Ice sink term (eff. medium) ' #endif #ifdef W3_DB0 - TNAME4 = 'Not defined ' + TNAME4 = 'Not defined ' #endif #ifdef W3_DB1 - TNAME4 = 'Battjes and Janssen (1978) ' + TNAME4 = 'Battjes and Janssen (1978) ' #endif #ifdef W3_TR0 - TNAME5 = 'Not defined ' + TNAME5 = 'Not defined ' #endif #ifdef W3_BS0 - TNAME6 = 'Not defined ' + TNAME6 = 'Not defined ' #endif #ifdef W3_PR0 - TNAMEP = 'No propagation ' + TNAMEP = 'No propagation ' #endif #ifdef W3_PR1 - TNAMEP = 'First order upstream ' + TNAMEP = 'First order upstream ' #endif #ifdef W3_UQ - TNAMEP = '3rd order UQ scheme ' + TNAMEP = '3rd order UQ scheme ' #endif #ifdef W3_UNO - TNAMEP = '2nd order UNO scheme ' + TNAMEP = '2nd order UNO scheme ' #endif #ifdef W3_PR0 - TNAMEG = 'No GSE aleviation ' + TNAMEG = 'No GSE aleviation ' #endif #ifdef W3_PR1 - TNAMEG = 'No GSE aleviation (1up prop) ' + TNAMEG = 'No GSE aleviation (1up prop) ' #endif #ifdef W3_PR2 - TNAMEG = 'Diffusion operator ' + TNAMEG = 'Diffusion operator ' #endif #ifdef W3_PR3 - TNAMEG = 'Averaging operator ' -#endif -! - FNAMEF = TNAMEF - FNAME0 = TNAME0 - FNAME1 = TNAME1 - FNAME2 = TNAME2 - FNAME3 = TNAME3 - FNAME4 = TNAME4 - FNAME5 = TNAME5 - FNAME6 = TNAME6 - FNAMEP = TNAMEP - FNAMEG = TNAMEG - FNAMEI = TNAMEI -! + TNAMEG = 'Averaging operator ' +#endif + ! + FNAMEF = TNAMEF + FNAME0 = TNAME0 + FNAME1 = TNAME1 + FNAME2 = TNAME2 + FNAME3 = TNAME3 + FNAME4 = TNAME4 + FNAME5 = TNAME5 + FNAME6 = TNAME6 + FNAMEP = TNAMEP + FNAMEG = TNAMEG + FNAMEI = TNAMEI + ! #ifdef W3_T - FLTEST = .TRUE. + FLTEST = .TRUE. #endif #ifdef W3_NL2 - FLSNL2 = .TRUE. -#endif -! -! test input parameters ---------------------------------------------- * -! - IF ( PRESENT(IMOD) ) THEN - IGRD = IMOD - ELSE - IGRD = 1 - END IF -! - IF ( PRESENT(FEXT) ) THEN - TEMPXT = FEXT - ELSE - TEMPXT = 'ww3' - END IF -! - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' & - .AND. INXOUT.NE.'GRID') THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT - CALL EXTCDE ( 1 ) - END IF -! - WRITE = INXOUT .EQ. 'WRITE' -! + FLSNL2 = .TRUE. +#endif + ! + ! test input parameters ---------------------------------------------- * + ! + IF ( PRESENT(IMOD) ) THEN + IGRD = IMOD + ELSE + IGRD = 1 + END IF + ! + IF ( PRESENT(FEXT) ) THEN + TEMPXT = FEXT + ELSE + TEMPXT = 'ww3' + END IF + ! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' & + .AND. INXOUT.NE.'GRID') THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT + CALL EXTCDE ( 1 ) + END IF + ! + WRITE = INXOUT .EQ. 'WRITE' + ! #ifdef W3_T - WRITE (NDST,9000) INXOUT, WRITE, NDSM, IGRD, TEMPXT + WRITE (NDST,9000) INXOUT, WRITE, NDSM, IGRD, TEMPXT #endif -! - CALL W3SETO ( IGRD, NDSE, NDST ) - CALL W3SETG ( IGRD, NDSE, NDST ) - FILEXT = TEMPXT + ! + CALL W3SETO ( IGRD, NDSE, NDST ) + CALL W3SETG ( IGRD, NDSE, NDST ) + FILEXT = TEMPXT #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 2' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) -#endif -! -! open file ---------------------------------------------------------- * -! - IEXT = LEN_TRIM(FILEXT) - IPRE = LEN_TRIM(FNMPRE) -! -!AR: ADD DEBUGFLAG WRITE(*,*) 'FILE=', FNMPRE(:IPRE)//'mod_def.'//FILEXT(:IEXT) - IF ( WRITE ) THEN - OPEN (NDSM,FILE=FNMPRE(:IPRE)//'mod_def.'//FILEXT(:IEXT), & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) - ELSE - OPEN (NDSM,FILE=FNMPRE(:IPRE)//'mod_def.'//FILEXT(:IEXT), & - form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=800,IOSTAT=IERR) - ENDIF -! - REWIND ( NDSM ) -! -! Dimensions and test information -------------------------------------- -! - IF ( WRITE ) THEN - WRITE (NDSM) & - IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & - NBI, NFBPO, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & - FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & - FNAMEF, FNAMEI -! + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + ! + ! open file ---------------------------------------------------------- * + ! + IEXT = LEN_TRIM(FILEXT) + IPRE = LEN_TRIM(FNMPRE) + ! + !AR: ADD DEBUGFLAG WRITE(*,*) 'FILE=', FNMPRE(:IPRE)//'mod_def.'//FILEXT(:IEXT) + IF ( WRITE ) THEN + OPEN (NDSM,FILE=FNMPRE(:IPRE)//'mod_def.'//FILEXT(:IEXT), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) + ELSE + OPEN (NDSM,FILE=FNMPRE(:IPRE)//'mod_def.'//FILEXT(:IEXT), & + form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=800,IOSTAT=IERR) + ENDIF + ! + REWIND ( NDSM ) + ! + ! Dimensions and test information -------------------------------------- + ! + IF ( WRITE ) THEN + WRITE (NDSM) & + IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & + NBI, NFBPO, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & + FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & + FNAMEF, FNAMEI + ! #ifdef W3_SMC - WRITE (NDSM) NCel, NUFc, NVFc, NRLv, MRFct - WRITE (NDSM) NGLO, NARC, NBGL, NBAC, NBSMC + WRITE (NDSM) NCel, NUFc, NVFc, NRLv, MRFct + WRITE (NDSM) NGLO, NARC, NBGL, NBAC, NBSMC #endif -! - WRITE (NDSM) & - (NBO(I),I=0,NFBPO), (NBO2(I),I=0,NFBPO) + ! + WRITE (NDSM) & + (NBO(I),I=0,NFBPO), (NBO2(I),I=0,NFBPO) #ifdef W3_T - WRITE (NDST,9001) IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & - NBI, NFBPO, 9, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & - FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & - FNAMEF, FNAMEI - WRITE (NDST,9002) (NBO(I),I=0,NFBPO) - WRITE (NDST,9003) (NBO2(I),I=0,NFBPO) -#endif - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - IDTST, VERTST, NX, NY, NSEA, MTH, MK, & - NBI, NFBPO, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & - FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & - FNAMEF, FNAMEI -! + WRITE (NDST,9001) IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & + NBI, NFBPO, 9, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & + FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & + FNAMEF, FNAMEI + WRITE (NDST,9002) (NBO(I),I=0,NFBPO) + WRITE (NDST,9003) (NBO2(I),I=0,NFBPO) +#endif + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + IDTST, VERTST, NX, NY, NSEA, MTH, MK, & + NBI, NFBPO, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & + FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & + FNAMEF, FNAMEI + ! #ifdef W3_SMC - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - NCel, NUFc, NVFc, NRLv, MRFct - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - NGLO, NARC, NBGL, NBAC, NBSMC -#endif -! - NK = MK - NTH = MTH - NK2 = NK + 2 - NSPEC = NK * NTH + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + NCel, NUFc, NVFc, NRLv, MRFct + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + NGLO, NARC, NBGL, NBAC, NBSMC +#endif + ! + NK = MK + NTH = MTH + NK2 = NK + 2 + NSPEC = NK * NTH #ifdef W3_T - WRITE (NDST,9001) IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & - NBI, NFBPO, 9, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & - FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & - FNAMEF, FNAMEI -#endif -! - IF ( IDTST .NE. IDSTR ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,901) IDTST, IDSTR - CALL EXTCDE ( 10 ) - END IF - IF ( VERTST .NE. VERGRD ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,902) VERTST, VERGRD - CALL EXTCDE ( 11 ) - END IF - IF ( NFBPO .GT. 9 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,904) NFBPO, 9 - CALL EXTCDE ( 13 ) - END IF - IF ( FNAME0 .NE. TNAME0 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 0, FILEXT(:IEXT), FNAME0, TNAME0, & - MESSAGE - CALL EXTCDE ( 14 ) - END IF - IF ( FNAME1 .NE. TNAME1 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 1, FILEXT(:IEXT), FNAME1, TNAME1, & - MESSAGE - CALL EXTCDE ( 15 ) - END IF - IF ( FNAME2 .NE. TNAME2 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 2, FILEXT(:IEXT), FNAME2, TNAME2, & - MESSAGE - CALL EXTCDE ( 16 ) - END IF - IF ( FNAME3 .NE. TNAME3 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 3, FILEXT(:IEXT), FNAME3, TNAME3, & - MESSAGE - CALL EXTCDE ( 17 ) - END IF - IF ( FNAMEI .NE. TNAMEI ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 3, FILEXT(:IEXT), FNAMEI, TNAMEI, & - MESSAGE - CALL EXTCDE ( 17 ) - END IF - IF ( FNAME4 .NE. TNAME4 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 4, FILEXT(:IEXT), FNAME4, TNAME4, & - MESSAGE - CALL EXTCDE ( 18 ) - END IF - IF ( FNAME5 .NE. TNAME5 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 5, FILEXT(:IEXT), FNAME5, TNAME5, & - MESSAGE - CALL EXTCDE ( 19 ) - END IF - IF ( FNAME6 .NE. TNAME6 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 6, FILEXT(:IEXT), FNAME6, TNAME6, & - MESSAGE - CALL EXTCDE ( 20 ) - END IF - IF ( FNAMEP .NE. TNAMEP ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,906) FNAMEP, TNAMEP - CALL EXTCDE ( 22 ) - END IF - IF ( FNAMEG .NE. TNAMEG ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,907) FNAMEG, TNAMEG, MESSAGE - CALL EXTCDE ( 22 ) - END IF - IF ( FNAMEF .NE. TNAMEF ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,908) FILEXT(:IEXT), FNAMEF, TNAMEF, MESSAGE - CALL EXTCDE ( 24 ) - END IF -! - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - (NBO(I),I=0,NFBPO), (NBO2(I),I=0,NFBPO) + WRITE (NDST,9001) IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & + NBI, NFBPO, 9, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & + FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & + FNAMEF, FNAMEI +#endif + ! + IF ( IDTST .NE. IDSTR ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,901) IDTST, IDSTR + CALL EXTCDE ( 10 ) + END IF + IF ( VERTST .NE. VERGRD ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,902) VERTST, VERGRD + CALL EXTCDE ( 11 ) + END IF + IF ( NFBPO .GT. 9 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,904) NFBPO, 9 + CALL EXTCDE ( 13 ) + END IF + IF ( FNAME0 .NE. TNAME0 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 0, FILEXT(:IEXT), FNAME0, TNAME0, & + MESSAGE + CALL EXTCDE ( 14 ) + END IF + IF ( FNAME1 .NE. TNAME1 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 1, FILEXT(:IEXT), FNAME1, TNAME1, & + MESSAGE + CALL EXTCDE ( 15 ) + END IF + IF ( FNAME2 .NE. TNAME2 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 2, FILEXT(:IEXT), FNAME2, TNAME2, & + MESSAGE + CALL EXTCDE ( 16 ) + END IF + IF ( FNAME3 .NE. TNAME3 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 3, FILEXT(:IEXT), FNAME3, TNAME3, & + MESSAGE + CALL EXTCDE ( 17 ) + END IF + IF ( FNAMEI .NE. TNAMEI ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 3, FILEXT(:IEXT), FNAMEI, TNAMEI, & + MESSAGE + CALL EXTCDE ( 17 ) + END IF + IF ( FNAME4 .NE. TNAME4 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 4, FILEXT(:IEXT), FNAME4, TNAME4, & + MESSAGE + CALL EXTCDE ( 18 ) + END IF + IF ( FNAME5 .NE. TNAME5 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 5, FILEXT(:IEXT), FNAME5, TNAME5, & + MESSAGE + CALL EXTCDE ( 19 ) + END IF + IF ( FNAME6 .NE. TNAME6 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 6, FILEXT(:IEXT), FNAME6, TNAME6, & + MESSAGE + CALL EXTCDE ( 20 ) + END IF + IF ( FNAMEP .NE. TNAMEP ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,906) FNAMEP, TNAMEP + CALL EXTCDE ( 22 ) + END IF + IF ( FNAMEG .NE. TNAMEG ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,907) FNAMEG, TNAMEG, MESSAGE + CALL EXTCDE ( 22 ) + END IF + IF ( FNAMEF .NE. TNAMEF ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,908) FILEXT(:IEXT), FNAMEF, TNAMEF, MESSAGE + CALL EXTCDE ( 24 ) + END IF + ! + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + (NBO(I),I=0,NFBPO), (NBO2(I),I=0,NFBPO) #ifdef W3_T - WRITE (NDST,9002) (NBO(I),I=0,NFBPO) - WRITE (NDST,9003) (NBO2(I),I=0,NFBPO) + WRITE (NDST,9002) (NBO(I),I=0,NFBPO) + WRITE (NDST,9003) (NBO2(I),I=0,NFBPO) #endif -! - ENDIF + ! + ENDIF #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 3' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif -! -! Parameters in modules --------------------------------------------- * -! Module W3GDAT GRID -! - ALLOCATE ( MAPTMP(NY,NX) ) -! - IF ( WRITE ) THEN - MAPTMP = MAPSTA + 8*MAPST2 - WRITE (NDSM) & - GTYPE, FLAGLL, ICLOSE -! -! Writes different kind of information depending on grid type -! - SELECT CASE ( GTYPE ) -!!Li SMCTYPE shares info with RLGTYPE. JGLi12Oct2020 - CASE ( RLGTYPE, SMCTYPE ) - WRITE (NDSM) & - SX, SY, X0, Y0 - CASE ( CLGTYPE ) - WRITE (NDSM) & - REAL(XGRD), REAL(YGRD) - CASE (UNGTYPE) - WRITE (NDSM) & - FSN, FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP, & - FSBCCFL, FSREFRACTION, FSFREQSHIFT, FSSOURCE, & - DO_CHANGE_WLV, SOLVERTHR_STP, CRIT_DEP_STP, & - NTRI,COUNTOT, COUNTRI, NNZ, & - B_JGS_TERMINATE_MAXITER, & - B_JGS_TERMINATE_DIFFERENCE, & - B_JGS_TERMINATE_NORM, & - B_JGS_LIMITER, & - B_JGS_BLOCK_GAUSS_SEIDEL, & - B_JGS_USE_JACOBI, & - B_JGS_MAXITER, & - B_JGS_PMIN, & - B_JGS_DIFF_THR, & - B_JGS_NORM_THR, & - B_JGS_NLEVEL, & - B_JGS_SOURCE_NONLINEAR - !Init COUNTCON to zero, it needs to be set somewhere or - !removed - COUNTCON=0 - WRITE (NDSM) & - X0, Y0, SX, SY, DXYMAX, XGRD, YGRD, TRIGP, TRIA, & - LEN, IEN, ANGLE0, ANGLE, SI, MAXX, MAXY, & - DXYMAX, INDEX_CELL, CCON, COUNTCON, IE_CELL, & - POS_CELL, IOBP, IOBPA, IOBDP, IOBPD, IAA, JAA, POSI - END SELECT !GTYPE -! - WRITE (NDSM) & - ZB, MAPTMP, MAPFS, MAPSF, TRFLAG -! + ! + ! Parameters in modules --------------------------------------------- * + ! Module W3GDAT GRID + ! + ALLOCATE ( MAPTMP(NY,NX) ) + ! + IF ( WRITE ) THEN + MAPTMP = MAPSTA + 8*MAPST2 + WRITE (NDSM) & + GTYPE, FLAGLL, ICLOSE + ! + ! Writes different kind of information depending on grid type + ! + SELECT CASE ( GTYPE ) + !!Li SMCTYPE shares info with RLGTYPE. JGLi12Oct2020 + CASE ( RLGTYPE, SMCTYPE ) + WRITE (NDSM) & + SX, SY, X0, Y0 + CASE ( CLGTYPE ) + WRITE (NDSM) & + REAL(XGRD), REAL(YGRD) + CASE (UNGTYPE) + WRITE (NDSM) & + FSN, FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP, & + FSBCCFL, FSREFRACTION, FSFREQSHIFT, FSSOURCE, & + DO_CHANGE_WLV, SOLVERTHR_STP, CRIT_DEP_STP, & + NTRI,COUNTOT, COUNTRI, NNZ, & + B_JGS_TERMINATE_MAXITER, & + B_JGS_TERMINATE_DIFFERENCE, & + B_JGS_TERMINATE_NORM, & + B_JGS_LIMITER, & + B_JGS_BLOCK_GAUSS_SEIDEL, & + B_JGS_USE_JACOBI, & + B_JGS_MAXITER, & + B_JGS_PMIN, & + B_JGS_DIFF_THR, & + B_JGS_NORM_THR, & + B_JGS_NLEVEL, & + B_JGS_SOURCE_NONLINEAR + !Init COUNTCON to zero, it needs to be set somewhere or + !removed + COUNTCON=0 + WRITE (NDSM) & + X0, Y0, SX, SY, DXYMAX, XGRD, YGRD, TRIGP, TRIA, & + LEN, IEN, ANGLE0, ANGLE, SI, MAXX, MAXY, & + DXYMAX, INDEX_CELL, CCON, COUNTCON, IE_CELL, & + POS_CELL, IOBP, IOBPA, IOBDP, IOBPD, IAA, JAA, POSI + END SELECT !GTYPE + ! + WRITE (NDSM) & + ZB, MAPTMP, MAPFS, MAPSF, TRFLAG + ! #ifdef W3_SMC - IF( GTYPE .EQ. SMCTYPE ) THEN - WRITE (NDSM) NLvCel, NLvUFc, NLvVFc - WRITE (NDSM) IJKCel, IJKUFc, IJKVFc, ISMCBP - WRITE (NDSM) ICLBAC - WRITE (NDSM) ANGARC - WRITE (NDSM) CTRNX, CTRNY, CLATF - IF ( FLTEST ) THEN - WRITE (NDSE,"(' NRLv, MRFct and NBSMC values are',3I9)") NRLv, MRFct, NBSMC - WRITE (NDSE,"(' IJKCel, IJKUFc, IJKVFc Write for',3I9)") NCel, NUFc, NVFc - WRITE (NDSE,"(' CTRNXY transparency write for 2x', I9)") NCel - ENDIF + IF( GTYPE .EQ. SMCTYPE ) THEN + WRITE (NDSM) NLvCel, NLvUFc, NLvVFc + WRITE (NDSM) IJKCel, IJKUFc, IJKVFc, ISMCBP + WRITE (NDSM) ICLBAC + WRITE (NDSM) ANGARC + WRITE (NDSM) CTRNX, CTRNY, CLATF + IF ( FLTEST ) THEN + WRITE (NDSE,"(' NRLv, MRFct and NBSMC values are',3I9)") NRLv, MRFct, NBSMC + WRITE (NDSE,"(' IJKCel, IJKUFc, IJKVFc Write for',3I9)") NCel, NUFc, NVFc + WRITE (NDSE,"(' CTRNXY transparency write for 2x', I9)") NCel ENDIF -#endif -! - IF ( TRFLAG .NE. 0 ) WRITE (NDSM) TRNX, TRNY - WRITE (NDSM) & - DTCFL, DTCFLI, DTMAX, DTMIN, DMIN, CTMAX, & - FICE0, FICEN, FICEL, PFMOVE, FLDRY, FLCX, FLCY, FLCTH, & - FLCK, FLSOU, FLBPI, FLBPO, CLATS, CLATIS, CTHG0S, & - STEXU, STEYU, STEDU, IICEHMIN, IICEHINIT, IICEDISP, & - ICESCALES(1:4), CALTYPE, CMPRTRCK, IICEHFAC, IICEHDISP,& - IICEDDISP, IICEFDISP, BTBETA, & - AAIRCMIN, AAIRGB + ENDIF +#endif + ! + IF ( TRFLAG .NE. 0 ) WRITE (NDSM) TRNX, TRNY + WRITE (NDSM) & + DTCFL, DTCFLI, DTMAX, DTMIN, DMIN, CTMAX, & + FICE0, FICEN, FICEL, PFMOVE, FLDRY, FLCX, FLCY, FLCTH, & + FLCK, FLSOU, FLBPI, FLBPO, CLATS, CLATIS, CTHG0S, & + STEXU, STEYU, STEDU, IICEHMIN, IICEHINIT, IICEDISP, & + ICESCALES(1:4), CALTYPE, CMPRTRCK, IICEHFAC, IICEHDISP,& + IICEDDISP, IICEFDISP, BTBETA, & + AAIRCMIN, AAIRGB - WRITE(NDSM)GRIDSHIFT + WRITE(NDSM)GRIDSHIFT #ifdef W3_SEC1 - WRITE (NDSM) NITERSEC1 + WRITE (NDSM) NITERSEC1 #endif #ifdef W3_RTD - !! Add rotated Polat/lon and AnglD to mod_def JGLi12Jun2012 - WRITE (NDSM) PoLat, PoLon, AnglD, FLAGUNR + !! Add rotated Polat/lon and AnglD to mod_def JGLi12Jun2012 + WRITE (NDSM) PoLat, PoLon, AnglD, FLAGUNR #endif -!! WRITE(NDSM) & -!! COUG_2D, COUG_RAD3D, COUG_US3D - ELSE + !! WRITE(NDSM) & + !! COUG_2D, COUG_RAD3D, COUG_US3D + ELSE #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 4' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - GTYPE, FLAGLL, ICLOSE -!!Li IF (.NOT.GINIT) CALL W3DIMX ( IGRD, NX, NY, NSEA, NDSE, NDST ) - IF (.NOT.GINIT) CALL W3DIMX ( IGRD, NX, NY, NSEA, NDSE, NDST & + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + GTYPE, FLAGLL, ICLOSE + !!Li IF (.NOT.GINIT) CALL W3DIMX ( IGRD, NX, NY, NSEA, NDSE, NDST ) + IF (.NOT.GINIT) CALL W3DIMX ( IGRD, NX, NY, NSEA, NDSE, NDST & #ifdef W3_SMC - , NCel, NUFc, NVFc, NRLv, NBSMC & - , NARC, NBAC, NSPEC & -#endif - ) -! -! Reads different kind of information depending on grid type -! - SELECT CASE ( GTYPE ) -!!Li SMCTYPE shares info with RLGTYPE. JGLi12Oct2020 - CASE ( RLGTYPE, SMCTYPE ) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - SX, SY, X0, Y0 - DO IX=1,NX - XGRD(:,IX) = REAL(X0 + REAL(IX-1)*SX) - END DO - DO IY=1,NY - YGRD(IY,:) = REAL(Y0 + REAL(IY-1)*SY) - END DO - CASE ( CLGTYPE ) - ALLOCATE(XGRD4(NY,NX),YGRD4(NY,NX)); XGRD4 = 0.; YGRD4 = 0. - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - XGRD4, YGRD4 - XGRD = XGRD4 - YGRD = YGRD4 - DEALLOCATE(XGRD4, YGRD4) - !Set SX, SY, X0, Y0 to large values if curvilinear grid - X0 = HUGE(X0); Y0 = HUGE(Y0) - SX = HUGE(SX); SY = HUGE(SY) - CASE (UNGTYPE) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - FSN, FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP, & - FSBCCFL, FSREFRACTION, FSFREQSHIFT, FSSOURCE, & - DO_CHANGE_WLV, SOLVERTHR_STP, CRIT_DEP_STP, & - NTRI,COUNTOT, COUNTRI, NNZ, & - B_JGS_TERMINATE_MAXITER, & - B_JGS_TERMINATE_DIFFERENCE, & - B_JGS_TERMINATE_NORM, & - B_JGS_LIMITER, & - B_JGS_BLOCK_GAUSS_SEIDEL, & - B_JGS_USE_JACOBI, & - B_JGS_MAXITER, & - B_JGS_PMIN, & - B_JGS_DIFF_THR, & - B_JGS_NORM_THR, & - B_JGS_NLEVEL, & - B_JGS_SOURCE_NONLINEAR - IF (.NOT. GUGINIT) THEN - CALL W3DIMUG ( IGRD, NTRI, NX, COUNTOT, NNZ, NDSE, NDST ) - END IF + , NCel, NUFc, NVFc, NRLv, NBSMC & + , NARC, NBAC, NSPEC & +#endif + ) + ! + ! Reads different kind of information depending on grid type + ! + SELECT CASE ( GTYPE ) + !!Li SMCTYPE shares info with RLGTYPE. JGLi12Oct2020 + CASE ( RLGTYPE, SMCTYPE ) + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SX, SY, X0, Y0 + DO IX=1,NX + XGRD(:,IX) = REAL(X0 + REAL(IX-1)*SX) + END DO + DO IY=1,NY + YGRD(IY,:) = REAL(Y0 + REAL(IY-1)*SY) + END DO + CASE ( CLGTYPE ) + ALLOCATE(XGRD4(NY,NX),YGRD4(NY,NX)); XGRD4 = 0.; YGRD4 = 0. + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + XGRD4, YGRD4 + XGRD = XGRD4 + YGRD = YGRD4 + DEALLOCATE(XGRD4, YGRD4) + !Set SX, SY, X0, Y0 to large values if curvilinear grid + X0 = HUGE(X0); Y0 = HUGE(Y0) + SX = HUGE(SX); SY = HUGE(SY) + CASE (UNGTYPE) + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + FSN, FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP, & + FSBCCFL, FSREFRACTION, FSFREQSHIFT, FSSOURCE, & + DO_CHANGE_WLV, SOLVERTHR_STP, CRIT_DEP_STP, & + NTRI,COUNTOT, COUNTRI, NNZ, & + B_JGS_TERMINATE_MAXITER, & + B_JGS_TERMINATE_DIFFERENCE, & + B_JGS_TERMINATE_NORM, & + B_JGS_LIMITER, & + B_JGS_BLOCK_GAUSS_SEIDEL, & + B_JGS_USE_JACOBI, & + B_JGS_MAXITER, & + B_JGS_PMIN, & + B_JGS_DIFF_THR, & + B_JGS_NORM_THR, & + B_JGS_NLEVEL, & + B_JGS_SOURCE_NONLINEAR + IF (.NOT. GUGINIT) THEN + CALL W3DIMUG ( IGRD, NTRI, NX, COUNTOT, NNZ, NDSE, NDST ) + END IF #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 5' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) -#endif - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - X0, Y0, SX, SY, DXYMAX, XGRD, YGRD, TRIGP, TRIA, & - LEN, IEN, ANGLE0, ANGLE, SI, MAXX, MAXY, & - DXYMAX, INDEX_CELL, CCON, COUNTCON, IE_CELL, & - POS_CELL, IOBP, IOBPA, IOBDP, IOBPD, IAA, JAA, POSI + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + X0, Y0, SX, SY, DXYMAX, XGRD, YGRD, TRIGP, TRIA, & + LEN, IEN, ANGLE0, ANGLE, SI, MAXX, MAXY, & + DXYMAX, INDEX_CELL, CCON, COUNTCON, IE_CELL, & + POS_CELL, IOBP, IOBPA, IOBDP, IOBPD, IAA, JAA, POSI #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 6' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif - END SELECT !GTYPE -! - IF (GTYPE.NE.UNGTYPE) CALL W3GNTX ( IGRD, NDSE, NDST ) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - ZB, MAPTMP, MAPFS, MAPSF, TRFLAG -! + END SELECT !GTYPE + ! + IF (GTYPE.NE.UNGTYPE) CALL W3GNTX ( IGRD, NDSE, NDST ) + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ZB, MAPTMP, MAPFS, MAPSF, TRFLAG + ! #ifdef W3_SMC - IF( GTYPE .EQ. SMCTYPE ) THEN - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - NLvCel, NLvUFc, NLvVFc - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - IJKCel, IJKUFc, IJKVFc, ISMCBP - DO J=lbound(IJKCel,2), ubound(IJKCel,2) - IJKCel3(J) = IJKCel(3,J) - IJKCel4(J) = IJKCel(4,J) - END DO - DO J=lbound(IJKVFc,2), ubound(IJKVFc,2) - IJKVFc5(J) = IJKVFc(5,J) - IJKVFc6(J) = IJKVFc(6,J) - END DO - DO J=lbound(IJKUFc,2), ubound(IJKUFc,2) - IJKUFc5(J) = IJKUFc(5,J) - IJKUFc6(J) = IJKUFc(6,J) - END DO - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - ICLBAC - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - ANGARC - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - CTRNX, CTRNY, CLATF - ENDIF -#endif -! - MAPSTA = MOD(MAPTMP+2,8) - 2 - MAPST2 = (MAPTMP-MAPSTA) / 8 - MAPSF(:,3) = MAPSF(:,2) + (MAPSF(:,1)-1)*NY - IF ( TRFLAG .NE. 0 ) THEN - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) TRNX, TRNY - END IF + IF( GTYPE .EQ. SMCTYPE ) THEN + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + NLvCel, NLvUFc, NLvVFc + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + IJKCel, IJKUFc, IJKVFc, ISMCBP + DO J=lbound(IJKCel,2), ubound(IJKCel,2) + IJKCel3(J) = IJKCel(3,J) + IJKCel4(J) = IJKCel(4,J) + END DO + DO J=lbound(IJKVFc,2), ubound(IJKVFc,2) + IJKVFc5(J) = IJKVFc(5,J) + IJKVFc6(J) = IJKVFc(6,J) + END DO + DO J=lbound(IJKUFc,2), ubound(IJKUFc,2) + IJKUFc5(J) = IJKUFc(5,J) + IJKUFc6(J) = IJKUFc(6,J) + END DO + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ICLBAC + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ANGARC + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + CTRNX, CTRNY, CLATF + ENDIF +#endif + ! + MAPSTA = MOD(MAPTMP+2,8) - 2 + MAPST2 = (MAPTMP-MAPSTA) / 8 + MAPSF(:,3) = MAPSF(:,2) + (MAPSF(:,1)-1)*NY + IF ( TRFLAG .NE. 0 ) THEN + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) TRNX, TRNY + END IF #ifdef W3_UOST - ! UOST (Unresolved Obstacles Source Term) is enabled. - ! setting TRNX, TRNY to null values - TRNX = 1 - TRNY = 1 + ! UOST (Unresolved Obstacles Source Term) is enabled. + ! setting TRNX, TRNY to null values + TRNX = 1 + TRNY = 1 #endif - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - DTCFL, DTCFLI, DTMAX, DTMIN, DMIN, CTMAX, & - FICE0, FICEN, FICEL, PFMOVE, FLDRY, FLCX, FLCY, & - FLCTH, FLCK, FLSOU, FLBPI, FLBPO, CLATS, CLATIS, & - CTHG0S, STEXU, STEYU, STEDU, IICEHMIN, IICEHINIT, & - IICEDISP, ICESCALES(1:4), CALTYPE, CMPRTRCK, IICEHFAC, & - IICEDDISP, IICEHDISP, IICEFDISP, BTBETA, & - AAIRCMIN, AAIRGB + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + DTCFL, DTCFLI, DTMAX, DTMIN, DMIN, CTMAX, & + FICE0, FICEN, FICEL, PFMOVE, FLDRY, FLCX, FLCY, & + FLCTH, FLCK, FLSOU, FLBPI, FLBPO, CLATS, CLATIS, & + CTHG0S, STEXU, STEYU, STEDU, IICEHMIN, IICEHINIT, & + IICEDISP, ICESCALES(1:4), CALTYPE, CMPRTRCK, IICEHFAC, & + IICEDDISP, IICEHDISP, IICEFDISP, BTBETA, & + AAIRCMIN, AAIRGB - READ(NDSM,END=801,ERR=802,IOSTAT=IERR)GRIDSHIFT + READ(NDSM,END=801,ERR=802,IOSTAT=IERR)GRIDSHIFT #ifdef W3_SEC1 - READ (NDSM) NITERSEC1 + READ (NDSM) NITERSEC1 #endif -! + ! #ifdef W3_RTD - !! Read rotated Polat/lon and AnglD from mod_def JGLi12Jun2012 - READ (NDSM) PoLat, PoLon, AnglD, FLAGUNR + !! Read rotated Polat/lon and AnglD from mod_def JGLi12Jun2012 + READ (NDSM) PoLat, PoLon, AnglD, FLAGUNR #endif -! - END IF + ! + END IF #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 7' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif -! + ! #ifdef W3_T - WRITE (NDST,9010) GTYPE, FLAGLL, ICLOSE, SX, SY, X0, Y0, TRFLAG - WRITE (NDST,9011) 'MAPSTA' + WRITE (NDST,9010) GTYPE, FLAGLL, ICLOSE, SX, SY, X0, Y0, TRFLAG + WRITE (NDST,9011) 'MAPSTA' + DO IY=MIN(NY,20), 1, -1 + WRITE (NDST,9012) (MAPSTA(IY,IX),IX=1,MIN(NX,30)) + END DO + WRITE (NDST,9011) 'MAPST2' + DO IY=MIN(NY,20), 1, -1 + WRITE (NDST,9012) (MAPST2(IY,IX),IX=1,MIN(NX,30)) + END DO + WRITE (NDST,9011) 'MAPFS' + DO IY=MIN(NY,20), 1, -1 + WRITE (NDST,9013) (MAPFS(IY,IX),IX=1,MIN(NX,12)) + END DO + IF ( TRFLAG .NE. 0 ) THEN + WRITE (NDST,9011) 'TRNX' DO IY=MIN(NY,20), 1, -1 - WRITE (NDST,9012) (MAPSTA(IY,IX),IX=1,MIN(NX,30)) - END DO - WRITE (NDST,9011) 'MAPST2' + WRITE (NDST,9014) (TRNX(IY,IX),IX=1,MIN(NX,12)) + END DO + WRITE (NDST,9011) 'TRNY' DO IY=MIN(NY,20), 1, -1 - WRITE (NDST,9012) (MAPST2(IY,IX),IX=1,MIN(NX,30)) - END DO - WRITE (NDST,9011) 'MAPFS' - DO IY=MIN(NY,20), 1, -1 - WRITE (NDST,9013) (MAPFS(IY,IX),IX=1,MIN(NX,12)) - END DO - IF ( TRFLAG .NE. 0 ) THEN - WRITE (NDST,9011) 'TRNX' - DO IY=MIN(NY,20), 1, -1 - WRITE (NDST,9014) (TRNX(IY,IX),IX=1,MIN(NX,12)) - END DO - WRITE (NDST,9011) 'TRNY' - DO IY=MIN(NY,20), 1, -1 - WRITE (NDST,9014) (TRNY(IY,IX),IX=1,MIN(NX,12)) - END DO - END IF + WRITE (NDST,9014) (TRNY(IY,IX),IX=1,MIN(NX,12)) + END DO + END IF #endif -! - DEALLOCATE ( MAPTMP ) -! + ! + DEALLOCATE ( MAPTMP ) + ! #ifdef W3_T - WRITE (NDST,9015) DTCFL, DTCFLI, DTMAX, DTMIN, & - DMIN, CTMAX, FICE0, FICEN, FICEL, PFMOVE, & - STEXU, STEYU, STEDU - WRITE (NDST,9016) FLDRY, FLCX, FLCY, FLCTH, FLCK, & - FLSOU, FLBPI, FLBPO - WRITE (NDST,9017) (CLATS(ISEA),ISEA=1,1), & - (CLATIS(ISEA),ISEA=1,1), (CTHG0S(IY),ISEA=1,1) -#endif -! -! Spectral parameters ------------------------------------------------ * -! Module W3GDATMD SGRD -! - IF ( WRITE ) THEN - WRITE (NDSM) & - MAPWN, MAPTH, DTH, TH, ESIN, ECOS, ES2, ESC, EC2, & - XFR, FR1, SIG, SIG2, DSIP, DSII, DDEN, DDEN2, FTE, & - FTF, FTWN, FTTR, FTWL, FACTI1, FACTI2, FACHFA, FACHFE - ELSE - IF (.NOT.SINIT) CALL W3DIMS ( IGRD, NK, NTH, NDSE, NDST ) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - MAPWN, MAPTH, DTH, TH, ESIN, ECOS, ES2, ESC, EC2, & - XFR, FR1, SIG, SIG2, DSIP, DSII, DDEN, DDEN2, FTE, & - FTF, FTWN, FTTR, FTWL, FACTI1, FACTI2, FACHFA, FACHFE - END IF + WRITE (NDST,9015) DTCFL, DTCFLI, DTMAX, DTMIN, & + DMIN, CTMAX, FICE0, FICEN, FICEL, PFMOVE, & + STEXU, STEYU, STEDU + WRITE (NDST,9016) FLDRY, FLCX, FLCY, FLCTH, FLCK, & + FLSOU, FLBPI, FLBPO + WRITE (NDST,9017) (CLATS(ISEA),ISEA=1,1), & + (CLATIS(ISEA),ISEA=1,1), (CTHG0S(IY),ISEA=1,1) +#endif + ! + ! Spectral parameters ------------------------------------------------ * + ! Module W3GDATMD SGRD + ! + IF ( WRITE ) THEN + WRITE (NDSM) & + MAPWN, MAPTH, DTH, TH, ESIN, ECOS, ES2, ESC, EC2, & + XFR, FR1, SIG, SIG2, DSIP, DSII, DDEN, DDEN2, FTE, & + FTF, FTWN, FTTR, FTWL, FACTI1, FACTI2, FACHFA, FACHFE + ELSE + IF (.NOT.SINIT) CALL W3DIMS ( IGRD, NK, NTH, NDSE, NDST ) + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + MAPWN, MAPTH, DTH, TH, ESIN, ECOS, ES2, ESC, EC2, & + XFR, FR1, SIG, SIG2, DSIP, DSII, DDEN, DDEN2, FTE, & + FTF, FTWN, FTTR, FTWL, FACTI1, FACTI2, FACHFA, FACHFE + END IF -! + ! #ifdef W3_T - WRITE (NDST,9030) (MAPWN(I),I=1,8), (MAPTH(I),I=1,8), DTH*RADE, & - (TH(I)*RADE,I=1,4), (ESIN(I),I=1,4), (ECOS(I),I=1,4), & - XFR, SIG(1)*TPIINV, SIG(NK)*TPIINV, FTE, FTF, FTWN, FTTR, & - FTWL, FACTI1, FACTI2, FACHFA, FACHFE -#endif -! -! -! Output flags for 3D parameters ------------------------------------- * -! Module W3GDATMD - IF ( WRITE ) THEN - WRITE (NDSM) & - E3DF, P2MSF, US3DF,USSPF, USSP_WN - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - E3DF, P2MSF, US3DF,USSPF, USSP_WN - END IF + WRITE (NDST,9030) (MAPWN(I),I=1,8), (MAPTH(I),I=1,8), DTH*RADE, & + (TH(I)*RADE,I=1,4), (ESIN(I),I=1,4), (ECOS(I),I=1,4), & + XFR, SIG(1)*TPIINV, SIG(NK)*TPIINV, FTE, FTF, FTWN, FTTR, & + FTWL, FACTI1, FACTI2, FACHFA, FACHFE +#endif + ! + ! + ! Output flags for 3D parameters ------------------------------------- * + ! Module W3GDATMD + IF ( WRITE ) THEN + WRITE (NDSM) & + E3DF, P2MSF, US3DF,USSPF, USSP_WN + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + E3DF, P2MSF, US3DF,USSPF, USSP_WN + END IF - IF ( INXOUT .EQ. 'GRID' ) THEN - CLOSE (NDSM) - RETURN - END IF -! -! Parameters for output boundary points ------------------------------ * -! Module W3ODATMD OUT5 -! - IF ( WRITE ) THEN - WRITE (NDSM) & - XBPO, YBPO, RDBPO, IPBPO, ISBPO - ELSE - CALL W3DMO5 ( IGRD, NDSE, NDST, 2 ) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - XBPO, YBPO, RDBPO, IPBPO, ISBPO - END IF -! + IF ( INXOUT .EQ. 'GRID' ) THEN + CLOSE (NDSM) + RETURN + END IF + ! + ! Parameters for output boundary points ------------------------------ * + ! Module W3ODATMD OUT5 + ! + IF ( WRITE ) THEN + WRITE (NDSM) & + XBPO, YBPO, RDBPO, IPBPO, ISBPO + ELSE + CALL W3DMO5 ( IGRD, NDSE, NDST, 2 ) + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + XBPO, YBPO, RDBPO, IPBPO, ISBPO + END IF + ! #ifdef W3_T - WRITE (NDST,9020) - DO I=1, NFBPO - WRITE (NDST,9021) I - DO J=NBO(I-1)+1,NBO(I) - WRITE (NDST,9022) J-NBO(I-1), (IPBPO(J,K),K=1,4), & - (RDBPO(J,K),K=1,4) - END DO - WRITE (NDST,9023) (ISBPO(J),J=NBO2(I-1)+1,NBO2(I)) - END DO -#endif -! -! Parameters for spectral partitioning ------------------------------ * -! Module W3ODATMD OUT6 -! - IF ( WRITE ) THEN - WRITE (NDSM) & - IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL, & - PTMETH, PTFCUT - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL, & - PTMETH, PTFCUT - END IF -! + WRITE (NDST,9020) + DO I=1, NFBPO + WRITE (NDST,9021) I + DO J=NBO(I-1)+1,NBO(I) + WRITE (NDST,9022) J-NBO(I-1), (IPBPO(J,K),K=1,4), & + (RDBPO(J,K),K=1,4) + END DO + WRITE (NDST,9023) (ISBPO(J),J=NBO2(I-1)+1,NBO2(I)) + END DO +#endif + ! + ! Parameters for spectral partitioning ------------------------------ * + ! Module W3ODATMD OUT6 + ! + IF ( WRITE ) THEN + WRITE (NDSM) & + IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL, & + PTMETH, PTFCUT + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL, & + PTMETH, PTFCUT + END IF + ! #ifdef W3_T - WRITE (NDST,9025) IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL -#endif -! -! Numerical parameters ----------------------------------------------- * -! Module W3GDATMD NPAR -! - IF ( WRITE ) THEN - WRITE (NDSM) & - FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, FACSD, FHMAX, & - FFACBERG, DELAB, FWTABLE + WRITE (NDST,9025) IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL +#endif + ! + ! Numerical parameters ----------------------------------------------- * + ! Module W3GDATMD NPAR + ! + IF ( WRITE ) THEN + WRITE (NDSM) & + FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, FACSD, FHMAX, & + FFACBERG, DELAB, FWTABLE #ifdef W3_RWND - WRITE (NDSM) & - RWINDC + WRITE (NDSM) & + RWINDC #endif #ifdef W3_WCOR - WRITE (NDSM) & - WWCOR + WRITE (NDSM) & + WWCOR #endif #ifdef W3_REF1 - WRITE (NDSM) & - RREF, REFPARS, REFLC, REFLD + WRITE (NDSM) & + RREF, REFPARS, REFLC, REFLD #endif #ifdef W3_IG1 - WRITE (NDSM) & - IGPARS(1:12) + WRITE (NDSM) & + IGPARS(1:12) #endif #ifdef W3_IC2 - WRITE (NDSM) & - IC2PARS(1:8) + WRITE (NDSM) & + IC2PARS(1:8) #endif #ifdef W3_IC3 - WRITE (NDSM) & - IC3PARS + WRITE (NDSM) & + IC3PARS #endif #ifdef W3_IC4 - WRITE (NDSM) & - IC4PARS,IC4_KI,IC4_FC + WRITE (NDSM) & + IC4PARS,IC4_KI,IC4_FC #endif #ifdef W3_IC5 - WRITE (NDSM) & - IC5PARS + WRITE (NDSM) & + IC5PARS #endif - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, FACSD, FHMAX, & - FFACBERG, DELAB, FWTABLE + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, FACSD, FHMAX, & + FFACBERG, DELAB, FWTABLE #ifdef W3_RWND - READ (NDSM) & - RWINDC + READ (NDSM) & + RWINDC #endif #ifdef W3_WCOR - READ (NDSM) & - WWCOR + READ (NDSM) & + WWCOR #endif #ifdef W3_REF1 - READ (NDSM) & - RREF, REFPARS, REFLC, REFLD + READ (NDSM) & + RREF, REFPARS, REFLC, REFLD #endif #ifdef W3_IG1 - READ (NDSM) & - IGPARS(1:12) + READ (NDSM) & + IGPARS(1:12) #endif #ifdef W3_IC2 - READ (NDSM) & - IC2PARS(1:8) + READ (NDSM) & + IC2PARS(1:8) #endif #ifdef W3_IC3 - READ (NDSM) & - IC3PARS + READ (NDSM) & + IC3PARS #endif #ifdef W3_IC4 - READ (NDSM) & - IC4PARS,IC4_KI,IC4_FC + READ (NDSM) & + IC4PARS,IC4_KI,IC4_FC #endif #ifdef W3_IC5 - READ (NDSM) & - IC5PARS + READ (NDSM) & + IC5PARS #endif - END IF -! + END IF + ! #ifdef W3_T - WRITE (NDST,9040) FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, & - FACSD, FHMAX -#endif -! -! Source term parameters --------------------------------------------- * -! Module W3GDATMD SFLP -! Module W3GDATMD SLNP -! Module W3GDATMD SRCP -! Module W3GDATMD SNLP -! Module W3GDATMD SBTP -! -#ifdef W3_FLX2 - IF ( WRITE ) THEN - WRITE (NDSM) NITTIN, CINXSI - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) NITTIN, CINXSI - END IF -#endif -! + WRITE (NDST,9040) FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, & + FACSD, FHMAX +#endif + ! + ! Source term parameters --------------------------------------------- * + ! Module W3GDATMD SFLP + ! Module W3GDATMD SLNP + ! Module W3GDATMD SRCP + ! Module W3GDATMD SNLP + ! Module W3GDATMD SBTP + ! #ifdef W3_FLX2 - IF ( FLTEST ) WRITE (NDST,9048) NITTIN, CINXSI -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) NITTIN, CINXSI + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) NITTIN, CINXSI + END IF + IF ( FLTEST ) WRITE (NDST,9048) NITTIN, CINXSI +#endif + ! #ifdef W3_FLX3 - IF ( WRITE ) THEN - WRITE (NDSM) & - NITTIN, CINXSI, CD_MAX, CAP_ID - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - NITTIN, CINXSI, CD_MAX, CAP_ID - END IF -#endif -! -#ifdef W3_FLX3 - IF ( FLTEST ) WRITE (NDST,9048) NITTIN, CAP_ID, CINXSI, CD_MAX -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) & + NITTIN, CINXSI, CD_MAX, CAP_ID + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + NITTIN, CINXSI, CD_MAX, CAP_ID + END IF + IF ( FLTEST ) WRITE (NDST,9048) NITTIN, CAP_ID, CINXSI, CD_MAX +#endif + ! #ifdef W3_FLX4 - IF ( WRITE ) THEN - WRITE (NDSM) FLX4A0 - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) FLX4A0 - END IF -#endif -! -! + IF ( WRITE ) THEN + WRITE (NDSM) FLX4A0 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) FLX4A0 + END IF +#endif + ! + ! #ifdef W3_LN1 - IF ( WRITE ) THEN - WRITE (NDSM) SLNC1, FSPM, FSHF - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SLNC1, FSPM, FSHF - END IF -#endif -! -#ifdef W3_LN1 - IF ( FLTEST ) WRITE (NDST,9049) SLNC1, FSPM, FSHF -#endif -! -#ifdef W3_ST1 - IF ( WRITE ) THEN - WRITE (NDSM) SINC1, SDSC1 - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SINC1, SDSC1 - END IF -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) SLNC1, FSPM, FSHF + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SLNC1, FSPM, FSHF + END IF + IF ( FLTEST ) WRITE (NDST,9049) SLNC1, FSPM, FSHF +#endif + ! #ifdef W3_ST1 - IF ( FLTEST ) WRITE (NDST,9050) SINC1, SDSC1 -#endif -! -#ifdef W3_ST2 - IF ( WRITE ) THEN - WRITE (NDSM) & - ZWIND, FSWELL, & - SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS, & - CDSA0, CDSA1, CDSA2, SDSALN, & - CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, XF2 - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - ZWIND, FSWELL, & - SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS, & - CDSA0, CDSA1, CDSA2, SDSALN, & - CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, XF2 - IF ( .NOT. FLINP ) CALL INPTAB - FLINP = .TRUE. - END IF -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) SINC1, SDSC1 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SINC1, SDSC1 + END IF + IF ( FLTEST ) WRITE (NDST,9050) SINC1, SDSC1 +#endif + ! #ifdef W3_ST2 - IF ( FLTEST ) WRITE (NDST,9050) & - ZWIND, FSWELL, CDSA0, CDSA1, CDSA2, & - SDSALN, CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, & - XF2, SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) & + ZWIND, FSWELL, & + SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS, & + CDSA0, CDSA1, CDSA2, SDSALN, & + CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, XF2 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ZWIND, FSWELL, & + SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS, & + CDSA0, CDSA1, CDSA2, SDSALN, & + CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, XF2 + IF ( .NOT. FLINP ) CALL INPTAB + FLINP = .TRUE. + END IF + IF ( FLTEST ) WRITE (NDST,9050) & + ZWIND, FSWELL, CDSA0, CDSA1, CDSA2, & + SDSALN, CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, & + XF2, SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS +#endif + ! #ifdef W3_ST3 - IF ( WRITE ) THEN - WRITE (NDSM) & - ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & - SSWELLF, SSDSC1, WWNMEANP, WWNMEANPTAIL, SSTXFTF,& - SSTXFTFTAIL, SSTXFTWN, & - DDELTA1, DDELTA2, SSTXFTF, SSTXFTWN, & - FFXPM, FFXFM - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & - SSWELLF, SSDSC1, WWNMEANP, WWNMEANPTAIL, SSTXFTF,& - SSTXFTFTAIL, SSTXFTWN, & - DDELTA1, DDELTA2, SSTXFTF, SSTXFTWN, & - FFXPM, FFXFM - IF ( .NOT. FLINP ) THEN - CALL INSIN3 - FLINP = .TRUE. - END IF - END IF + IF ( WRITE ) THEN + WRITE (NDSM) & + ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & + SSWELLF, SSDSC1, WWNMEANP, WWNMEANPTAIL, SSTXFTF,& + SSTXFTFTAIL, SSTXFTWN, & + DDELTA1, DDELTA2, SSTXFTF, SSTXFTWN, & + FFXPM, FFXFM + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & + SSWELLF, SSDSC1, WWNMEANP, WWNMEANPTAIL, SSTXFTF,& + SSTXFTFTAIL, SSTXFTWN, & + DDELTA1, DDELTA2, SSTXFTF, SSTXFTWN, & + FFXPM, FFXFM + IF ( .NOT. FLINP ) THEN + CALL INSIN3 + FLINP = .TRUE. + END IF + END IF #endif -! + ! #ifdef W3_ST4 - IF ( WRITE ) THEN - CALL INSIN4(.TRUE.) - WRITE (NDSM) & - ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & - TTAUWSHELTER, SSWELLFPAR, SSWELLF, SSINBR, & - ZZ0RAT, SSDSC, & - SSDSISO, SSDSBR, SSDSBT, SSDSBM, SSDSP, & - SSDSCOS, SSDSDTH, WWNMEANP, WWNMEANPTAIL,SSTXFTF,& - SSTXFTFTAIL, SSTXFTWN, SSTXFTF, SSTXFTWN, & - SSDSBRF1, SSDSBRF2, SSDSBRFDF,SSDSBCK, SSDSABK, & - SSDSPBK, SSDSBINT, FFXPM, FFXFM, FFXFA, & - SSDSHCK, DELUST, DELTAIL, DELTAUW, & - DELU, DELALP, TAUT, TAUHFT, TAUHFT2, & - IKTAB, DCKI, QBI, SATINDICES, SATWEIGHTS, & - DIKCUMUL, CUMULW - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & - TTAUWSHELTER, SSWELLFPAR, SSWELLF, SSINBR, & - ZZ0RAT, SSDSC, & - SSDSISO, SSDSBR, SSDSBT, SSDSBM, SSDSP, & - SSDSCOS, SSDSDTH, WWNMEANP, WWNMEANPTAIL,SSTXFTF,& - SSTXFTFTAIL, SSTXFTWN, SSTXFTF, SSTXFTWN, & - SSDSBRF1, SSDSBRF2, SSDSBRFDF,SSDSBCK, SSDSABK, & - SSDSPBK, SSDSBINT, FFXPM, FFXFM, FFXFA, & - SSDSHCK, DELUST, DELTAIL, DELTAUW, & - DELU, DELALP, TAUT, TAUHFT, TAUHFT2, & - IKTAB, DCKI, QBI, SATINDICES, SATWEIGHTS, & - DIKCUMUL, CUMULW - END IF -#endif -! + IF ( WRITE ) THEN + CALL INSIN4(.TRUE.) + WRITE (NDSM) & + ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & + TTAUWSHELTER, SSWELLFPAR, SSWELLF, SSINBR, & + ZZ0RAT, SSDSC, & + SSDSISO, SSDSBR, SSDSBT, SSDSBM, SSDSP, & + SSDSCOS, SSDSDTH, WWNMEANP, WWNMEANPTAIL,SSTXFTF,& + SSTXFTFTAIL, SSTXFTWN, SSTXFTF, SSTXFTWN, & + SSDSBRF1, SSDSBRF2, SSDSBRFDF,SSDSBCK, SSDSABK, & + SSDSPBK, SSDSBINT, FFXPM, FFXFM, FFXFA, & + SSDSHCK, DELUST, DELTAIL, DELTAUW, & + DELU, DELALP, TAUT, TAUHFT, TAUHFT2, & + IKTAB, DCKI, QBI, SATINDICES, SATWEIGHTS, & + DIKCUMUL, CUMULW + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & + TTAUWSHELTER, SSWELLFPAR, SSWELLF, SSINBR, & + ZZ0RAT, SSDSC, & + SSDSISO, SSDSBR, SSDSBT, SSDSBM, SSDSP, & + SSDSCOS, SSDSDTH, WWNMEANP, WWNMEANPTAIL,SSTXFTF,& + SSTXFTFTAIL, SSTXFTWN, SSTXFTF, SSTXFTWN, & + SSDSBRF1, SSDSBRF2, SSDSBRFDF,SSDSBCK, SSDSABK, & + SSDSPBK, SSDSBINT, FFXPM, FFXFM, FFXFA, & + SSDSHCK, DELUST, DELTAIL, DELTAUW, & + DELU, DELALP, TAUT, TAUHFT, TAUHFT2, & + IKTAB, DCKI, QBI, SATINDICES, SATWEIGHTS, & + DIKCUMUL, CUMULW + END IF +#endif + ! #ifdef W3_ST6 - IF ( WRITE ) THEN - WRITE (NDSM) SIN6A0, SDS6ET, SDS6A1, SDS6A2, & - SDS6P1, SDS6P2, SWL6S6, SWL6B1, SWL6CSTB1,& - SIN6WS, SIN6FC - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - SIN6A0, SDS6ET, SDS6A1, SDS6A2, & - SDS6P1, SDS6P2, SWL6S6, SWL6B1, SWL6CSTB1,& - SIN6WS, SIN6FC - END IF -#endif -! -! ... Nonlinear interactions -! -#ifdef W3_NL1 - IF ( WRITE ) THEN - WRITE (NDSM) & - SNLC1, LAM, KDCON, KDMN, SNLS1, SNLS2, SNLS3 - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - SNLC1, LAM, KDCON, KDMN, SNLS1, SNLS2, SNLS3 - END IF -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) SIN6A0, SDS6ET, SDS6A1, SDS6A2, & + SDS6P1, SDS6P2, SWL6S6, SWL6B1, SWL6CSTB1,& + SIN6WS, SIN6FC + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SIN6A0, SDS6ET, SDS6A1, SDS6A2, & + SDS6P1, SDS6P2, SWL6S6, SWL6B1, SWL6CSTB1,& + SIN6WS, SIN6FC + END IF +#endif + ! + ! ... Nonlinear interactions + ! #ifdef W3_NL1 - IF ( FLTEST ) WRITE (NDST,9051) SNLC1, LAM, & - KDCON, KDMN, SNLS1, SNLS2, SNLS3 -#endif -! -#ifdef W3_NL2 - IF ( WRITE ) THEN - WRITE (NDSM) IQTPE, NLTAIL, NDPTHS - WRITE (NDSM) DPTHNL - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - IQTPE, NLTAIL, NDPTHS - ALLOCATE ( MPARS(IGRD)%SNLPS%DPTHNL(NDPTHS) ) - DPTHNL => MPARS(IGRD)%SNLPS%DPTHNL - PINIT = .TRUE. - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) DPTHNL - END IF -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) & + SNLC1, LAM, KDCON, KDMN, SNLS1, SNLS2, SNLS3 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SNLC1, LAM, KDCON, KDMN, SNLS1, SNLS2, SNLS3 + END IF + IF ( FLTEST ) WRITE (NDST,9051) SNLC1, LAM, & + KDCON, KDMN, SNLS1, SNLS2, SNLS3 +#endif + ! #ifdef W3_NL2 - IF ( FLTEST ) WRITE (NDST,9051) IQTPE, NLTAIL, NDPTHS - IF ( FLTEST ) WRITE (NDST,9151) DPTHNL -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) IQTPE, NLTAIL, NDPTHS + WRITE (NDSM) DPTHNL + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + IQTPE, NLTAIL, NDPTHS + ALLOCATE ( MPARS(IGRD)%SNLPS%DPTHNL(NDPTHS) ) + DPTHNL => MPARS(IGRD)%SNLPS%DPTHNL + PINIT = .TRUE. + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) DPTHNL + END IF + IF ( FLTEST ) WRITE (NDST,9051) IQTPE, NLTAIL, NDPTHS + IF ( FLTEST ) WRITE (NDST,9151) DPTHNL +#endif + ! #ifdef W3_NL3 - IF ( WRITE ) THEN - WRITE (NDSM) SNLNQ, SNLMSC, SNLNSC, SNLSFD, SNLSFS - WRITE (NDSM) SNLL(1:SNLNQ), SNLM(1:SNLNQ), & - SNLT(1:SNLNQ), SNLCD(1:SNLNQ), & - SNLCS(1:SNLNQ) - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - SNLNQ, SNLMSC, SNLNSC, SNLSFD, SNLSFS - ALLOCATE ( MPARS(IGRD)%SNLPS%SNLL(SNLNQ), & - MPARS(IGRD)%SNLPS%SNLM(SNLNQ), & - MPARS(IGRD)%SNLPS%SNLT(SNLNQ), & - MPARS(IGRD)%SNLPS%SNLCD(SNLNQ), & - MPARS(IGRD)%SNLPS%SNLCS(SNLNQ) ) - SNLL => MPARS(IGRD)%SNLPS%SNLL - SNLM => MPARS(IGRD)%SNLPS%SNLM - SNLT => MPARS(IGRD)%SNLPS%SNLT - SNLCD => MPARS(IGRD)%SNLPS%SNLCD - SNLCS => MPARS(IGRD)%SNLPS%SNLCS - PINIT = .TRUE. - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - SNLL, SNLM, SNLT, SNLCD, SNLCS - END IF -#endif -! -#ifdef W3_NL3 - IF ( FLTEST ) WRITE (NDST,9051) SNLNQ, SNLMSC, SNLNSC, & - SNLSFD, SNLSFS - IF ( FLTEST ) THEN - DO I=1, SNLNQ - WRITE (NDST,9151) SNLL(I), SNLM(I), SNLT(I), & - SNLCD(I), SNLCS(I) - END DO - END IF -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) SNLNQ, SNLMSC, SNLNSC, SNLSFD, SNLSFS + WRITE (NDSM) SNLL(1:SNLNQ), SNLM(1:SNLNQ), & + SNLT(1:SNLNQ), SNLCD(1:SNLNQ), & + SNLCS(1:SNLNQ) + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SNLNQ, SNLMSC, SNLNSC, SNLSFD, SNLSFS + ALLOCATE ( MPARS(IGRD)%SNLPS%SNLL(SNLNQ), & + MPARS(IGRD)%SNLPS%SNLM(SNLNQ), & + MPARS(IGRD)%SNLPS%SNLT(SNLNQ), & + MPARS(IGRD)%SNLPS%SNLCD(SNLNQ), & + MPARS(IGRD)%SNLPS%SNLCS(SNLNQ) ) + SNLL => MPARS(IGRD)%SNLPS%SNLL + SNLM => MPARS(IGRD)%SNLPS%SNLM + SNLT => MPARS(IGRD)%SNLPS%SNLT + SNLCD => MPARS(IGRD)%SNLPS%SNLCD + SNLCS => MPARS(IGRD)%SNLPS%SNLCS + PINIT = .TRUE. + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SNLL, SNLM, SNLT, SNLCD, SNLCS + END IF + IF ( FLTEST ) WRITE (NDST,9051) SNLNQ, SNLMSC, SNLNSC, & + SNLSFD, SNLSFS + IF ( FLTEST ) THEN + DO I=1, SNLNQ + WRITE (NDST,9151) SNLL(I), SNLM(I), SNLT(I), & + SNLCD(I), SNLCS(I) + END DO + END IF +#endif + ! #ifdef W3_NL4 - IF ( WRITE ) THEN - WRITE (NDSM) ITSA, IALT - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - ITSA, IALT - END IF -#endif -! -#ifdef W3_NL4 - IF ( FLTEST ) WRITE (NDST,9051) ITSA, IALT -#endif -! -! (QL: INXOUT = Grid option ?) + IF ( WRITE ) THEN + WRITE (NDSM) ITSA, IALT + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ITSA, IALT + END IF + IF ( FLTEST ) WRITE (NDST,9051) ITSA, IALT +#endif + ! + ! (QL: INXOUT = Grid option ?) #ifdef W3_NL5 - IF (WRITE) THEN - CALL INSNL5 - WRITE (NDSM) QR5DPT, QR5OML, QI5DIS, QI5KEV, & - QI5NNZ, QI5IPL, QI5PMX - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - QR5DPT, QR5OML, QI5DIS, QI5KEV, & - QI5NNZ, QI5IPL, QI5PMX - END IF - IF ( FLTEST ) WRITE (NDST,9051) QR5DPT, QR5OML, QI5DIS, & - QI5KEV, QI5NNZ, QI5IPL, & - QI5PMX -#endif -! -#ifdef W3_NLS - IF ( WRITE ) THEN - WRITE (NDSM) & - CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 - END IF -#endif -! + IF (WRITE) THEN + CALL INSNL5 + WRITE (NDSM) QR5DPT, QR5OML, QI5DIS, QI5KEV, & + QI5NNZ, QI5IPL, QI5PMX + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + QR5DPT, QR5OML, QI5DIS, QI5KEV, & + QI5NNZ, QI5IPL, QI5PMX + END IF + IF ( FLTEST ) WRITE (NDST,9051) QR5DPT, QR5OML, QI5DIS, & + QI5KEV, QI5NNZ, QI5IPL, & + QI5PMX +#endif + ! #ifdef W3_NLS - IF ( FLTEST ) WRITE (NDST,9251) & - CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) & + CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 + END IF + IF ( FLTEST ) WRITE (NDST,9251) & + CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 +#endif + ! #ifdef W3_NL1 - IF ( .NOT. WRITE ) CALL INSNL1 ( IGRD ) + IF ( .NOT. WRITE ) CALL INSNL1 ( IGRD ) #endif #ifdef W3_NL3 - IF ( .NOT. WRITE ) CALL INSNL3 + IF ( .NOT. WRITE ) CALL INSNL3 #endif #ifdef W3_NLS - IF ( .NOT. WRITE ) CALL INSNLS + IF ( .NOT. WRITE ) CALL INSNLS #endif -! -! Layered barriers needed for file management in xnl_init -! + ! + ! Layered barriers needed for file management in xnl_init + ! #ifdef W3_MPI - IF ( FLSNL2 .AND. .NOT.WRITE ) THEN - DO IP=1, IAPROC-1 - CALL MPI_BARRIER ( MPI_COMM_WAVE, IERR_MPI ) - END DO - END IF + IF ( FLSNL2 .AND. .NOT.WRITE ) THEN + DO IP=1, IAPROC-1 + CALL MPI_BARRIER ( MPI_COMM_WAVE, IERR_MPI ) + END DO + END IF #endif #ifdef W3_NL2 - IF ( .NOT. WRITE ) CALL INSNL2 + IF ( .NOT. WRITE ) CALL INSNL2 #endif #ifdef W3_MPI - IF ( FLSNL2 .AND. .NOT.WRITE ) THEN - DO IP=IAPROC, NAPROC-1 - CALL MPI_BARRIER ( MPI_COMM_WAVE, IERR_MPI ) - END DO - END IF -#endif -! -! ... Bottom friction ... -! + IF ( FLSNL2 .AND. .NOT.WRITE ) THEN + DO IP=IAPROC, NAPROC-1 + CALL MPI_BARRIER ( MPI_COMM_WAVE, IERR_MPI ) + END DO + END IF +#endif + ! + ! ... Bottom friction ... + ! #ifdef W3_BT1 - IF ( WRITE ) THEN - WRITE (NDSM) SBTC1 - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SBTC1 - END IF -#endif -! -#ifdef W3_BT1 - IF ( FLTEST ) WRITE (NDST,9052) SBTC1 -#endif -! -! + IF ( WRITE ) THEN + WRITE (NDSM) SBTC1 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SBTC1 + END IF + IF ( FLTEST ) WRITE (NDST,9052) SBTC1 +#endif + ! + ! #ifdef W3_BT4 - IF ( WRITE ) THEN - WRITE (NDSM) & - SBTCX, SED_D50, SED_PSIC - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - SBTCX, SED_D50, SED_PSIC - END IF -#endif -! -! ... Depth induced breaking ... -! + IF ( WRITE ) THEN + WRITE (NDSM) & + SBTCX, SED_D50, SED_PSIC + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SBTCX, SED_D50, SED_PSIC + END IF +#endif + ! + ! ... Depth induced breaking ... + ! #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 8' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 8' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif #ifdef W3_DB1 - IF ( WRITE ) THEN - WRITE (NDSM) & - SDBC1, SDBC2, FDONLY - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - SDBC1, SDBC2, FDONLY - END IF -#endif -! -#ifdef W3_DB1 - IF ( FLTEST ) WRITE (NDST,9053) SDBC1, SDBC2, FDONLY + IF ( WRITE ) THEN + WRITE (NDSM) & + SDBC1, SDBC2, FDONLY + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SDBC1, SDBC2, FDONLY + END IF + ! + IF ( FLTEST ) WRITE (NDST,9053) SDBC1, SDBC2, FDONLY #endif #ifdef W3_UOST - IF ( WRITE ) THEN - WRITE (NDSM) UOSTFILELOCAL, UOSTFILESHADOW, & - UOSTFACTORLOCAL, UOSTFACTORSHADOW - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - UOSTFILELOCAL, UOSTFILESHADOW, & - UOSTFACTORLOCAL, UOSTFACTORSHADOW - CALL UOST_INITGRID(IGRD, UOSTFILELOCAL, UOSTFILESHADOW, & - UOSTFACTORLOCAL, UOSTFACTORSHADOW) + IF ( WRITE ) THEN + WRITE (NDSM) UOSTFILELOCAL, UOSTFILESHADOW, & + UOSTFACTORLOCAL, UOSTFACTORSHADOW + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + UOSTFILELOCAL, UOSTFILESHADOW, & + UOSTFACTORLOCAL, UOSTFACTORSHADOW + CALL UOST_INITGRID(IGRD, UOSTFILELOCAL, UOSTFILESHADOW, & + UOSTFACTORLOCAL, UOSTFACTORSHADOW) #endif #ifdef W3_UOST - END IF + END IF #endif -! + ! #ifdef W3_IS1 - IF ( WRITE ) THEN - WRITE (NDSM) IS1C1, IS1C2 - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) IS1C1, IS1C2 - END IF + IF ( WRITE ) THEN + WRITE (NDSM) IS1C1, IS1C2 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) IS1C1, IS1C2 + END IF #endif -! + ! #ifdef W3_IS2 - IF ( WRITE ) THEN - WRITE (NDSM) IS2PARS - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) IS2PARS - IF ( .NOT. FLIS ) THEN - CALL INSIS2 - FLIS = .TRUE. - END IF - END IF -#endif -! -! Propagation scheme ------------------------------------------------- * -! Module W3GDATMD PROP -! -#ifdef W3_PR2 - IF ( WRITE ) THEN - WRITE (NDSM) DTME, CLATMN - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - DTME, CLATMN - END IF + IF ( WRITE ) THEN + WRITE (NDSM) IS2PARS + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) IS2PARS + IF ( .NOT. FLIS ) THEN + CALL INSIS2 + FLIS = .TRUE. + END IF + END IF #endif -! + ! + ! Propagation scheme ------------------------------------------------- * + ! Module W3GDATMD PROP + ! #ifdef W3_PR2 - IF ( FLTEST ) WRITE (NDST,9060) DTME, CLATMN -#endif -! -#ifdef W3_PR3 - IF ( WRITE ) THEN - WRITE (NDSM) WDCG, WDTH - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - WDCG, WDTH - END IF -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) DTME, CLATMN + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + DTME, CLATMN + END IF + ! + IF ( FLTEST ) WRITE (NDST,9060) DTME, CLATMN +#endif + ! #ifdef W3_PR3 - IF ( FLTEST ) WRITE (NDST,9060) WDCG, WDTH -#endif -! -#ifdef W3_SMC - IF ( WRITE ) THEN - WRITE(NDSM) DTMS, Refran, FUNO3, FVERG, FSWND, ARCTC - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - DTMS, Refran, FUNO3, FVERG, FSWND, ARCTC - END IF -#endif -! + IF ( WRITE ) THEN + WRITE (NDSM) WDCG, WDTH + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + WDCG, WDTH + END IF + ! + IF ( FLTEST ) WRITE (NDST,9060) WDCG, WDTH +#endif + ! #ifdef W3_SMC - IF ( FLTEST ) WRITE (NDST,9260) DTMS, Refran -#endif -! + IF ( WRITE ) THEN + WRITE(NDSM) DTMS, Refran, FUNO3, FVERG, FSWND, ARCTC + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + DTMS, Refran, FUNO3, FVERG, FSWND, ARCTC + END IF + ! + IF ( FLTEST ) WRITE (NDST,9260) DTMS, Refran +#endif + ! #ifdef W3_FLD1 - IF ( WRITE ) THEN - WRITE (NDSM) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 - END IF + IF ( WRITE ) THEN + WRITE (NDSM) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + END IF #endif #ifdef W3_FLD2 - IF ( WRITE ) THEN - WRITE (NDSM) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 - END IF -#endif -! -! Interpolation tables ( fill locally ) ----------------------------- * -! Module W3DISPMD -! - IF ( .NOT.WRITE .AND. .NOT.FLDISP ) THEN + IF ( WRITE ) THEN + WRITE (NDSM) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + END IF +#endif + ! + ! Interpolation tables ( fill locally ) ----------------------------- * + ! Module W3DISPMD + ! + IF ( .NOT.WRITE .AND. .NOT.FLDISP ) THEN #ifdef W3_T - WRITE (NDST,9070) + WRITE (NDST,9070) #endif - CALL DISTAB - FLDISP = .TRUE. - END IF -! - CLOSE ( NDSM ) + CALL DISTAB + FLDISP = .TRUE. + END IF + ! + CLOSE ( NDSM ) #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 9' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) -#endif -! - RETURN -! -! Escape locations read errors --------------------------------------- * -! - 800 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) FILEXT(:IEXT), IERR - CALL EXTCDE ( 50 ) -! - 801 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) FILEXT(:IEXT) - CALL EXTCDE ( 51 ) -! - 802 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) FILEXT(:IEXT), IERR, & - MESSAGE - CALL EXTCDE ( 52 ) -! -! Formats -! - 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' ILEGAL INXOUT VALUE: ',A/) - 901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' ILEGAL IDSTR, READ : ',A/ & - ' CHECK : ',A/) - 902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' ILEGAL VERGRD, READ : ',A/ & - ' CHECK : ',A/) - 904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' ILEGAL NFBPO READ : ',I8/ & - ' CHECK : ',I8/) - 905 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' UNEXPECTED SOURCE TERM IDENTIFIER',I2/ & - ' IN mod_def.',A,' FILE : ',A/ & - ' EXPECTED FROM switch FILE : ',A,/ & - 5(A,/) /) -! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) - 906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' UNEXPECTED PROPAGATION SCHEME IDENTIFIER'/ & - ' IN FILE :',A/ & - ' EXPECTED :',A/ & - ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) - 907 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' UNEXPECTED GSE ALEVIATION IDENTIFIER'/ & - ' IN FILE :',A/ & - ' EXPECTED :',A/ & - , 5(A,/) /) -! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) - 908 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' UNEXPECTED FLUX PARAMETERIZATION IDENTIFIER'/ & - ' IN mod_def.',A,' :',A/ & - ' EXPECTED :',A/ & - , 5(A,/) /) -! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/ & - ' ERROR IN OPENING mod_def.',A,' FILE'/ & - ' IOSTAT =',I5/) - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/ & - ' PREMATURE END OF mod_def.',A,' FILE'/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/, & - ' ERROR IN READING FROM mod_def.',A,' FILE'/ & - ' IOSTAT =',I5, & - 5(A,/) /) -! -#ifdef W3_T - 9000 FORMAT (' TEST W3IOGR : INXOUT = ',A,', WRITE = ',L1, & - ', UNIT =',I3,', IGRD =',I3,', FEXT = ',A) - 9001 FORMAT (' TEST W3IOGR : TEST PARAMETERS :'/ & - ' IDSTR : ',A/ & - ' VERGRD : ',A/ & - ' NX/Y/SEA : ',3I10/ & - ' NTH,NK : ',2I10/ & - ' NBI : ',I10/ & - ' NFBPO : ',2I10/ & - ' GNAME : ',A/ & - ' FNAME0 : ',A/ & - ' FNAME1 : ',A/ & - ' FNAME2 : ',A/ & - ' FNAME3 : ',A/ & - ' FNAME4 : ',A/ & - ' FNAME5 : ',A/ & - ' FNAME6 : ',A/ & - ' FNAMEP : ',A/ & - ' FNAMEG : ',A/ & - ' FNAMEF : ',A/ & - ' FNAMEI : ',A) - 9002 FORMAT (' NBO : ',10I5) - 9003 FORMAT (' NBO2 : ',10I5) -#endif -! + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 9' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + ! + RETURN + ! + ! Escape locations read errors --------------------------------------- * + ! +800 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) FILEXT(:IEXT), IERR + CALL EXTCDE ( 50 ) + ! +801 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) FILEXT(:IEXT) + CALL EXTCDE ( 51 ) + ! +802 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) FILEXT(:IEXT), IERR, & + MESSAGE + CALL EXTCDE ( 52 ) + ! + ! Formats + ! +900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' ILEGAL INXOUT VALUE: ',A/) +901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' ILEGAL IDSTR, READ : ',A/ & + ' CHECK : ',A/) +902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' ILEGAL VERGRD, READ : ',A/ & + ' CHECK : ',A/) +904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' ILEGAL NFBPO READ : ',I8/ & + ' CHECK : ',I8/) +905 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' UNEXPECTED SOURCE TERM IDENTIFIER',I2/ & + ' IN mod_def.',A,' FILE : ',A/ & + ' EXPECTED FROM switch FILE : ',A,/ & + 5(A,/) /) + ! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) +906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' UNEXPECTED PROPAGATION SCHEME IDENTIFIER'/ & + ' IN FILE :',A/ & + ' EXPECTED :',A/ & + ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) +907 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' UNEXPECTED GSE ALEVIATION IDENTIFIER'/ & + ' IN FILE :',A/ & + ' EXPECTED :',A/ & + , 5(A,/) /) + ! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) +908 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' UNEXPECTED FLUX PARAMETERIZATION IDENTIFIER'/ & + ' IN mod_def.',A,' :',A/ & + ' EXPECTED :',A/ & + , 5(A,/) /) + ! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/ & + ' ERROR IN OPENING mod_def.',A,' FILE'/ & + ' IOSTAT =',I5/) +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/ & + ' PREMATURE END OF mod_def.',A,' FILE'/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/, & + ' ERROR IN READING FROM mod_def.',A,' FILE'/ & + ' IOSTAT =',I5, & + 5(A,/) /) + ! #ifdef W3_T - 9010 FORMAT (' TEST W3IOGR : MODULE W3GDATMD GRID'/ & - ' GTYPE : ',I9/ & - ' FLAGLL : ',L9/ & - ' ICLOSE : ',I9/ & - ' SX, SY : ',2E10.3/ & - ' X0, Y0 : ',2E10.3/ & - ' TRFLAG : ',I9) - 9011 FORMAT (' LOWER LEFT PART OF ',A) - 9012 FORMAT (' ',4X,30I2) - 9013 FORMAT (' ',12I6) - 9014 FORMAT (' ',12F6.2) - 9015 FORMAT (' STEPS : ',4F8.1/ & - ' DEPTH : ',F8.1,F10.3/ & - ' FICE0/N: ',F9.2,F8.2/ & - ' FICEL : ',F9.1 / & - ' PFMOVE : ',F9.2 / & - ' STEXU : ',F9.2 / & - ' STEYU : ',F9.2 / & - ' STEDU : ',F9.2) -#endif -! -#ifdef W3_T - 9016 FORMAT (' FLAGS : ',8L2) - 9017 FORMAT (' CLATS : ',3F8.3,' ...'/ & - ' CLATIS : ',3F8.3,' ...'/ & - ' CTHG0S : ',3E11.3,' ...') -#endif -! -#ifdef W3_T - 9020 FORMAT (' TEST W3IOGR : MODULE W3ODATMD OUT5') - 9021 FORMAT (' INTERPOLATION DATA : FILE ',I1) - 9022 FORMAT (' ',I5,2X,4I4,2X,4F5.2) - 9023 FORMAT (' ',10I7) - 9025 FORMAT (' TEST W3IOGR : MODULE W3ODATMD OUT6'/ & - ' PARTITIONING DATA :',I5,3E10.3,L4,2X,I4) -#endif -! -#ifdef W3_T - 9030 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SGRD'/ & - ' MAPWN : ',8I4,' ...'/ & - ' MAPTH : ',8I4,' ...'/ & - ' DTH : ',F6.1/ & - ' TH : ',4F6.1,' ...'/ & - ' ESIN : ',4F6.3,' ...'/ & - ' ECOS : ',4F6.3,' ...'/ & - ' XFR : ',F6.3/ & - ' FR : ',F6.3,' ...',F6.3/ & - ' FACs : ',6E10.3/ & - ' ',3E10.3) -#endif -! -#ifdef W3_T - 9040 FORMAT (' TEST W3IOGR : MODULE W3GDATMD NPAR'/ & - ' FACs : ',5E10.3/ & - ' ',4E10.3) -#endif -! +9000 FORMAT (' TEST W3IOGR : INXOUT = ',A,', WRITE = ',L1, & + ', UNIT =',I3,', IGRD =',I3,', FEXT = ',A) +9001 FORMAT (' TEST W3IOGR : TEST PARAMETERS :'/ & + ' IDSTR : ',A/ & + ' VERGRD : ',A/ & + ' NX/Y/SEA : ',3I10/ & + ' NTH,NK : ',2I10/ & + ' NBI : ',I10/ & + ' NFBPO : ',2I10/ & + ' GNAME : ',A/ & + ' FNAME0 : ',A/ & + ' FNAME1 : ',A/ & + ' FNAME2 : ',A/ & + ' FNAME3 : ',A/ & + ' FNAME4 : ',A/ & + ' FNAME5 : ',A/ & + ' FNAME6 : ',A/ & + ' FNAMEP : ',A/ & + ' FNAMEG : ',A/ & + ' FNAMEF : ',A/ & + ' FNAMEI : ',A) +9002 FORMAT (' NBO : ',10I5) +9003 FORMAT (' NBO2 : ',10I5) + ! +9010 FORMAT (' TEST W3IOGR : MODULE W3GDATMD GRID'/ & + ' GTYPE : ',I9/ & + ' FLAGLL : ',L9/ & + ' ICLOSE : ',I9/ & + ' SX, SY : ',2E10.3/ & + ' X0, Y0 : ',2E10.3/ & + ' TRFLAG : ',I9) +9011 FORMAT (' LOWER LEFT PART OF ',A) +9012 FORMAT (' ',4X,30I2) +9013 FORMAT (' ',12I6) +9014 FORMAT (' ',12F6.2) +9015 FORMAT (' STEPS : ',4F8.1/ & + ' DEPTH : ',F8.1,F10.3/ & + ' FICE0/N: ',F9.2,F8.2/ & + ' FICEL : ',F9.1 / & + ' PFMOVE : ',F9.2 / & + ' STEXU : ',F9.2 / & + ' STEYU : ',F9.2 / & + ' STEDU : ',F9.2) + ! +9016 FORMAT (' FLAGS : ',8L2) +9017 FORMAT (' CLATS : ',3F8.3,' ...'/ & + ' CLATIS : ',3F8.3,' ...'/ & + ' CTHG0S : ',3E11.3,' ...') + ! +9020 FORMAT (' TEST W3IOGR : MODULE W3ODATMD OUT5') +9021 FORMAT (' INTERPOLATION DATA : FILE ',I1) +9022 FORMAT (' ',I5,2X,4I4,2X,4F5.2) +9023 FORMAT (' ',10I7) +9025 FORMAT (' TEST W3IOGR : MODULE W3ODATMD OUT6'/ & + ' PARTITIONING DATA :',I5,3E10.3,L4,2X,I4) + ! +9030 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SGRD'/ & + ' MAPWN : ',8I4,' ...'/ & + ' MAPTH : ',8I4,' ...'/ & + ' DTH : ',F6.1/ & + ' TH : ',4F6.1,' ...'/ & + ' ESIN : ',4F6.3,' ...'/ & + ' ECOS : ',4F6.3,' ...'/ & + ' XFR : ',F6.3/ & + ' FR : ',F6.3,' ...',F6.3/ & + ' FACs : ',6E10.3/ & + ' ',3E10.3) + ! +9040 FORMAT (' TEST W3IOGR : MODULE W3GDATMD NPAR'/ & + ' FACs : ',5E10.3/ & + ' ',4E10.3) +#endif + ! #ifdef W3_FLX2 - 9048 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SFLP'/ & - ' FLUXES : ',I5,3X,E10.3) +9048 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SFLP'/ & + ' FLUXES : ',I5,3X,E10.3) #endif #ifdef W3_FLX3 - 9048 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SFLP'/ & - ' FLUXES : ',2I5,3X,2E10.3) +9048 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SFLP'/ & + ' FLUXES : ',2I5,3X,2E10.3) #endif -! + ! #ifdef W3_LN1 - 9049 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SLNP'/ & - ' INPUT : ',3E10.3) +9049 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SLNP'/ & + ' INPUT : ',3E10.3) #endif -! + ! #ifdef W3_ST1 - 9050 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SRCP'/ & - ' INPUT : ',E10.3/ & - ' DISSIP : ',E10.3) +9050 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SRCP'/ & + ' INPUT : ',E10.3/ & + ' DISSIP : ',E10.3) #endif #ifdef W3_ST2 - 9050 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SRCP'/ & - ' INPUT : ',2E10.3/ & - ' DISSIP : ',4E10.3/ & - ' ',5E10.3/ & - ' ',3E10.3/ & - ' STAB2 : ',6E10.3) -#endif -! +9050 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SRCP'/ & + ' INPUT : ',2E10.3/ & + ' DISSIP : ',4E10.3/ & + ' ',5E10.3/ & + ' ',3E10.3/ & + ' STAB2 : ',6E10.3) +#endif + ! #ifdef W3_NL1 - 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & - ' DATA : ',2E10.3/ & - ' ',5E10.3) +9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & + ' DATA : ',2E10.3/ & + ' ',5E10.3) #endif -! + ! #ifdef W3_NL2 - 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & - ' DATA : ',I4,F5.1,I4) - 9151 FORMAT (' ',5F7.1) +9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & + ' DATA : ',I4,F5.1,I4) +9151 FORMAT (' ',5F7.1) #endif -! + ! #ifdef W3_NL3 - 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & - ' DATA : ',I4,4F8.3) - 9151 FORMAT (' ',2F8.3,F6.1,2E12.4) +9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & + ' DATA : ',I4,4F8.3) +9151 FORMAT (' ',2F8.3,F6.1,2E12.4) #endif -! + ! #ifdef W3_NL4 - 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & - ' DATA : ',I4,I4) +9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & + ' DATA : ',I4,I4) #endif -! + ! #ifdef W3_NL5 - 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & - ' DATA : ', F7.1, F8.2, 2I2.1, I12, 2I2.1) +9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & + ' DATA : ', F7.1, F8.2, 2I2.1, I12, 2I2.1) #endif -! + ! #ifdef W3_NLS - 9251 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP (NLS)'/ & - ' DATA : ',F8.3,E12.4,4F8.3) +9251 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP (NLS)'/ & + ' DATA : ',F8.3,E12.4,4F8.3) #endif -! + ! #ifdef W3_BT1 - 9052 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SBTP'/ & - ' DATA : ',E10.3) +9052 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SBTP'/ & + ' DATA : ',E10.3) #endif -! + ! #ifdef W3_DB1 - 9053 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SDBP'/ & - ' DATA : ',2E10.3,L4) +9053 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SDBP'/ & + ' DATA : ',2E10.3,L4) #endif -! + ! #ifdef W3_PR2 - 9060 FORMAT (' TEST W3IOGR : MODULE W3GDATMD PROP'/ & - ' DATA : ',2E10.3) +9060 FORMAT (' TEST W3IOGR : MODULE W3GDATMD PROP'/ & + ' DATA : ',2E10.3) #endif -! + ! #ifdef W3_PR3 - 9060 FORMAT (' TEST W3IOGR : MODULE W3GDATMD PROP'/ & - ' DATA : ',2F6.2) +9060 FORMAT (' TEST W3IOGR : MODULE W3GDATMD PROP'/ & + ' DATA : ',2F6.2) #endif -! + ! #ifdef W3_SMC - 9260 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SMCG'/ & - ' DATA : ',3E10.3) +9260 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SMCG'/ & + ' DATA : ',3E10.3) #endif -! + ! #ifdef W3_T - 9070 FORMAT (' TEST W3IOGR : DISPERSION INTEPOLATION TABLES') -#endif -!/ -!/ End of W3IOGR ----------------------------------------------------- / -!/ - END SUBROUTINE W3IOGR -!/ -!/ End of module W3IOGRMD -------------------------------------------- / -!/ - END MODULE W3IOGRMD +9070 FORMAT (' TEST W3IOGR : DISPERSION INTEPOLATION TABLES') +#endif + !/ + !/ End of W3IOGR ----------------------------------------------------- / + !/ + END SUBROUTINE W3IOGR + !/ + !/ End of module W3IOGRMD -------------------------------------------- / + !/ +END MODULE W3IOGRMD diff --git a/model/src/w3iopomd.F90 b/model/src/w3iopomd.F90 index 3383a292d..802685869 100644 --- a/model/src/w3iopomd.F90 +++ b/model/src/w3iopomd.F90 @@ -1,8 +1,8 @@ !> @file !> @brief Process point output. -!> +!> !> @author H. L. Tolman @date 05-Jun-2018 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / @@ -10,1505 +10,1465 @@ !> @brief Process point output. !> !> @details Allocation of allocatable arrays takes place at different -!> places throughout the code, in W3IOPP on write, and in W3IOPO on +!> places throughout the code, in W3IOPP on write, and in W3IOPO on !> read. !> !> @author H. L. Tolman @date 05-Jun-2018 !> - MODULE W3IOPOMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 05-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 25-Jan-2001 : Origination. ( version 2.00 ) -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 11-Jun-2001 : Clean-up. ( version 2.11 ) -!/ 10-Nov-2004 : Multiple grid version. ( version 3.06 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 25-Jul-2006 : Adding grid ID per point. ( version 3.10 ) -!/ 01-May-2007 : Move O7a output from W3INIT. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Oct-2010 : Implement unstructured grid ( version 3.14.4 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.07 ) -!/ 25-Feb-2013 : ITOUT=0 bug correction for UG grids ( version 4.08 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 05-Jun-2018 : Add SETUP ( version 6.04 ) -!/ 04-Oct-2019 : Optional one file per output stride ( version 7.00 ) -!/ (R. Padilla-Hernandez & J.H. Alves) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Process point output. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! VEROPT C*10 Private Point output file version number. -! IDSTR C*32 Private Point output file ID string. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3IOPP Subr. Public Preprocessing of point output req. -! W3IOPE Subr. Public Extract point data from grid. -! W3IOPO Subr. Public Point data IO. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETO Subr. W3ODATMD Data structure management. -! W3SETG Subr. W3GDATMD Data structure management. -! W3SETW Subr. W3WDATMD Data structure management. -! W3DMO2 Subr. W3ODATMD Data structure management. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Program abort with exit code. -! MPI_STARTALL, MPIWAITALL -! Subr. MPI persistent communication routines. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - Allocation of allocatable arrays takes place at different -! places throughout the code, in W3IOPP on write, and in -! W3IOPO on read. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI MPI message passing. -! -! !/O7a Diagnostic output for output points. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Private parameter statements (ID strings) -!/ - CHARACTER(LEN=10), PARAMETER, PRIVATE :: VEROPT = '2021-04-06' - CHARACTER(LEN=31), PARAMETER, PRIVATE :: & - IDSTR = 'WAVEWATCH III POINT OUTPUT FILE' -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Preprocessing of point output. -!> -!> @details Check location of points in grid and calculate interpolation -!> factors. -!> -!> @param[in] NPT Number of output points in input. -!> @param[inout] XPT X (longitude) coordinates of output points. -!> @param[inout] YPT Y (latitude) coordinates of output points. -!> @param[in] PNAMES Names of output points. -!> @param[in] IMOD Grid ID number. -!> -!> @author H. L. Tolman @date 02-Sep-2012 -!> - SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 02-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 14-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 30-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 09-Nov-2004 : Multiple grid version. ( version 3.06 ) -!/ 25-Jul-2006 : Adding grid ID per point. ( version 3.10 ) -!/ 01-May-2007 : Move O7a output from W3INIT. ( version 3.11 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.07 ) -!/ 01-Mar-2018 : Add option to unrotate spectra ( version 6.02 ) -!/ from RTD grid models -!/ -! 1. Purpose : -! -! Preprocessing of point output. -! -! 2. Method : -! -! Check location of points in grid and calculate interpolation -! factors. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NPT Int. I Number of output points in input. -! XPT R.A. I/O X (longitude) coordinates of output points. -! YPT R.A. I/O Id. Y. -! PNAMES C*40 I Names of output points. -! IMOD Int. I Grid ID number. -! ---------------------------------------------------------------- -! -! Local data -! ---------------------------------------------------------------- -! ACC Real "Accuracy" factor to determine if output point -! is grid point. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Warnings for points out of the grid or on land. -! -! 7. Remarks : -! -! - The output points are obtained by bi-linear interpolation from -! the spectra at the grid points. Given the possibility of ice -! coverage, the actual interpolation factors can only be -! determined at the actual output time. Hence only the basic -! bilinear interpolation factors are stored. -! - Implementation of the /O7a diagnostic output section is -! currently incomplete and non-functional for curvilinear grids -! and/or tripole grids -! -! 8. Structure : -! -! ------------------------------------------- -! Determine grid range -! do for all defined points -! ----------------------------------------- -! Check if point within grid -! Calculate interpolation data -! Check if point not on land -! Store interpolation data -! ------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! !/O7a Diagnostic output for output points. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GSRUMD - USE W3GDATMD, ONLY: NTH, NK, NSPEC, NX, NY, X0, Y0, SX, GSU,& - RLGTYPE, CLGTYPE, UNGTYPE, GTYPE, FLAGLL, & - ICLOSE,ICLOSE_NONE,ICLOSE_SMPL,ICLOSE_TRPL, & - MAPSTA, MAPFS, FILEXT, ZB, TRNX, TRNY - USE W3GDATMD, ONLY: TRIGP,MAXX, MAXY, DXYMAX +MODULE W3IOPOMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 05-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 25-Jan-2001 : Origination. ( version 2.00 ) + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 11-Jun-2001 : Clean-up. ( version 2.11 ) + !/ 10-Nov-2004 : Multiple grid version. ( version 3.06 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 25-Jul-2006 : Adding grid ID per point. ( version 3.10 ) + !/ 01-May-2007 : Move O7a output from W3INIT. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 29-Oct-2010 : Implement unstructured grid ( version 3.14.4 ) + !/ (A. Roland and F. Ardhuin) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 12-Jun-2012 : Add /RTD option or rotated grid option. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.07 ) + !/ 25-Feb-2013 : ITOUT=0 bug correction for UG grids ( version 4.08 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 05-Jun-2018 : Add SETUP ( version 6.04 ) + !/ 04-Oct-2019 : Optional one file per output stride ( version 7.00 ) + !/ (R. Padilla-Hernandez & J.H. Alves) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Process point output. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! VEROPT C*10 Private Point output file version number. + ! IDSTR C*32 Private Point output file ID string. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3IOPP Subr. Public Preprocessing of point output req. + ! W3IOPE Subr. Public Extract point data from grid. + ! W3IOPO Subr. Public Point data IO. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETO Subr. W3ODATMD Data structure management. + ! W3SETG Subr. W3GDATMD Data structure management. + ! W3SETW Subr. W3WDATMD Data structure management. + ! W3DMO2 Subr. W3ODATMD Data structure management. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Program abort with exit code. + ! MPI_STARTALL, MPIWAITALL + ! Subr. MPI persistent communication routines. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - Allocation of allocatable arrays takes place at different + ! places throughout the code, in W3IOPP on write, and in + ! W3IOPO on read. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI MPI message passing. + ! + ! !/O7a Diagnostic output for output points. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + !/ Private parameter statements (ID strings) + !/ + CHARACTER(LEN=10), PARAMETER, PRIVATE :: VEROPT = '2021-04-06' + CHARACTER(LEN=31), PARAMETER, PRIVATE :: & + IDSTR = 'WAVEWATCH III POINT OUTPUT FILE' + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Preprocessing of point output. + !> + !> @details Check location of points in grid and calculate interpolation + !> factors. + !> + !> @param[in] NPT Number of output points in input. + !> @param[inout] XPT X (longitude) coordinates of output points. + !> @param[inout] YPT Y (latitude) coordinates of output points. + !> @param[in] PNAMES Names of output points. + !> @param[in] IMOD Grid ID number. + !> + !> @author H. L. Tolman @date 02-Sep-2012 + !> + SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 02-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 14-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 30-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 09-Nov-2004 : Multiple grid version. ( version 3.06 ) + !/ 25-Jul-2006 : Adding grid ID per point. ( version 3.10 ) + !/ 01-May-2007 : Move O7a output from W3INIT. ( version 3.11 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 12-Jun-2012 : Add /RTD option or rotated grid option. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.07 ) + !/ 01-Mar-2018 : Add option to unrotate spectra ( version 6.02 ) + !/ from RTD grid models + !/ + ! 1. Purpose : + ! + ! Preprocessing of point output. + ! + ! 2. Method : + ! + ! Check location of points in grid and calculate interpolation + ! factors. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NPT Int. I Number of output points in input. + ! XPT R.A. I/O X (longitude) coordinates of output points. + ! YPT R.A. I/O Id. Y. + ! PNAMES C*40 I Names of output points. + ! IMOD Int. I Grid ID number. + ! ---------------------------------------------------------------- + ! + ! Local data + ! ---------------------------------------------------------------- + ! ACC Real "Accuracy" factor to determine if output point + ! is grid point. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Wave model initialization routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Warnings for points out of the grid or on land. + ! + ! 7. Remarks : + ! + ! - The output points are obtained by bi-linear interpolation from + ! the spectra at the grid points. Given the possibility of ice + ! coverage, the actual interpolation factors can only be + ! determined at the actual output time. Hence only the basic + ! bilinear interpolation factors are stored. + ! - Implementation of the /O7a diagnostic output section is + ! currently incomplete and non-functional for curvilinear grids + ! and/or tripole grids + ! + ! 8. Structure : + ! + ! ------------------------------------------- + ! Determine grid range + ! do for all defined points + ! ----------------------------------------- + ! Check if point within grid + ! Calculate interpolation data + ! Check if point not on land + ! Store interpolation data + ! ------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! !/O7a Diagnostic output for output points. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GSRUMD + USE W3GDATMD, ONLY: NTH, NK, NSPEC, NX, NY, X0, Y0, SX, GSU,& + RLGTYPE, CLGTYPE, UNGTYPE, GTYPE, FLAGLL, & + ICLOSE,ICLOSE_NONE,ICLOSE_SMPL,ICLOSE_TRPL, & + MAPSTA, MAPFS, FILEXT, ZB, TRNX, TRNY + USE W3GDATMD, ONLY: TRIGP,MAXX, MAXY, DXYMAX #ifdef W3_RTD - !! Use rotated N-Pole lat/lon and conversion sub. JGLi12Jun2012 - USE W3GDATMD, ONLY: PoLat, PoLon, FLAGUNR - USE W3SERVMD, ONLY: W3LLTOEQ -#endif - USE W3ODATMD, ONLY: W3DMO2 - USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPERR, NAPOUT, SCREEN, & - NOPTS, PTLOC, PTNME, GRDID, IPTINT, PTIFAC - USE W3SERVMD, ONLY: EXTCDE + !! Use rotated N-Pole lat/lon and conversion sub. JGLi12Jun2012 + USE W3GDATMD, ONLY: PoLat, PoLon, FLAGUNR + USE W3SERVMD, ONLY: W3LLTOEQ +#endif + USE W3ODATMD, ONLY: W3DMO2 + USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPERR, NAPOUT, SCREEN, & + NOPTS, PTLOC, PTNME, GRDID, IPTINT, PTIFAC + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3TRIAMD -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NPT, IMOD - REAL, INTENT(INOUT) :: XPT(NPT), YPT(NPT) - CHARACTER(LEN=40),INTENT(IN) :: PNAMES(NPT) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - LOGICAL :: INGRID - INTEGER :: IPT, J, K - INTEGER :: IX1, IY1, IXS, IYS + USE W3SERVMD, ONLY: STRACE +#endif + USE W3TRIAMD + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NPT, IMOD + REAL, INTENT(INOUT) :: XPT(NPT), YPT(NPT) + CHARACTER(LEN=40),INTENT(IN) :: PNAMES(NPT) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + LOGICAL :: INGRID + INTEGER :: IPT, J, K + INTEGER :: IX1, IY1, IXS, IYS #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif + INTEGER :: IX(4), IY(4) ! Indices of points used in interp. + REAL :: RD(4) ! Interpolation coefficient + REAL, PARAMETER :: ACC = 0.05 + REAL :: FACTOR + INTEGER :: ITOUT ! Triangle index in unstructured grids #ifdef W3_O7a - INTEGER :: IX0, IXN, IY0, IYN, NNX, & - KX, KY, JX, IIX, IX2, IY2, IS1 -#endif - INTEGER :: IX(4), IY(4) ! Indices of points used in interp. - REAL :: RD(4) ! Interpolation coefficient -#ifdef W3_O7a - REAL :: RD1, RD2, RDTOT, ZBOX(4), DEPTH -#endif - REAL, PARAMETER :: ACC = 0.05 - REAL :: FACTOR - INTEGER :: ITOUT ! Triangle index in unstructured grids -#ifdef W3_O7a - CHARACTER(LEN=1) :: SEA(5), LND(5), OUT(5) - CHARACTER(LEN=9) :: PARTS - CHARACTER(LEN=1), ALLOCATABLE :: STRING(:), LINE1(:), LINE2(:) -#endif -! -#ifdef W3_O7a - DATA SEA / ' ', 's', 'e', 'a', ' ' / - DATA LND / ' ', 'l', 'n', 'd', ' ' / - DATA OUT / ' ', 'x', 'x', 'x', ' ' / -#endif -!/ + INTEGER :: IX0, IXN, IY0, IYN, NNX, & + KX, KY, JX, IIX, IX2, IY2, IS1 + REAL :: RD1, RD2, RDTOT, ZBOX(4), DEPTH + CHARACTER(LEN=1) :: SEA(5), LND(5), OUT(5) + CHARACTER(LEN=9) :: PARTS + CHARACTER(LEN=1), ALLOCATABLE :: STRING(:), LINE1(:), LINE2(:) + ! + DATA SEA / ' ', 's', 'e', 'a', ' ' / + DATA LND / ' ', 'l', 'n', 'd', ' ' / + DATA OUT / ' ', 'x', 'x', 'x', ' ' / +#endif + !/ #ifdef W3_RTD - !! Declare a few temporary variables for rotated grid. JGLi12Jun2012 - REAL, ALLOCATABLE :: EquLon(:),EquLat(:),StdLon(:),StdLat(:),AnglPT(:) + !! Declare a few temporary variables for rotated grid. JGLi12Jun2012 + REAL, ALLOCATABLE :: EquLon(:),EquLat(:),StdLon(:),StdLat(:),AnglPT(:) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3IOPP') -#endif -! - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF -! - CALL W3DMO2 ( IMOD, NDSE, NDST, NPT ) - GRDID = FILEXT -! - NOPTS = 0 -! + CALL STRACE (IENT, 'W3IOPP') +#endif + ! + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + ! + CALL W3DMO2 ( IMOD, NDSE, NDST, NPT ) + GRDID = FILEXT + ! + NOPTS = 0 + ! #ifdef W3_RTD - !! Convert standard lon/lat to rotated lon/lat JGLi12Jun2012 - ALLOCATE( EquLon(NPT), EquLat(NPT), & - & StdLon(NPT), StdLat(NPT), AnglPT(NPT) ) + !! Convert standard lon/lat to rotated lon/lat JGLi12Jun2012 + ALLOCATE( EquLon(NPT), EquLat(NPT), & + & StdLon(NPT), StdLat(NPT), AnglPT(NPT) ) - StdLon = XPT - StdLat = YPT + StdLon = XPT + StdLat = YPT - CALL W3LLTOEQ ( StdLat, StdLon, EquLat, EquLon, & - & AnglPT, PoLat, PoLon, NPT ) + CALL W3LLTOEQ ( StdLat, StdLon, EquLat, EquLon, & + & AnglPT, PoLat, PoLon, NPT ) - XPT = EquLon - YPT = EquLat + XPT = EquLon + YPT = EquLat #endif -! -! Removed by F.A. 2011/04/04 /T CALL W3GSUP( GSU, NDST ) -! -! Loop over output points -! - DO IPT=1, NPT -! + ! + ! Removed by F.A. 2011/04/04 /T CALL W3GSUP( GSU, NDST ) + ! + ! Loop over output points + ! + DO IPT=1, NPT + ! #ifdef W3_T - WRITE (NDST,9010) IPT, XPT(IPT), YPT(IPT), PNAMES(IPT) + WRITE (NDST,9010) IPT, XPT(IPT), YPT(IPT), PNAMES(IPT) #endif -! + ! #ifdef W3_RTD - !! Need to wrap rotated Elon values greater than X0. JGLi12Jun2012 - XPT(IPT) = MOD( EquLon(IPT)+360.0, 360.0 ) - IF( XPT(IPT) .LT. X0 ) XPT(IPT) = XPT(IPT) + 360.0 -#endif -! -! Check if point within grid and compute interpolation weights -! - IF (GTYPE .NE. UNGTYPE) THEN - INGRID = W3GRMP( GSU, XPT(IPT), YPT(IPT), IX, IY, RD ) - ELSE - CALL IS_IN_UNGRID(IMOD, DBLE(XPT(IPT)), DBLE(YPT(IPT)), itout, IX, IY, RD) - INGRID = (ITOUT.GT.0) - END IF -! - IF ( .NOT.INGRID ) THEN - IF ( IAPROC .EQ. NAPERR ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSE,1000) XPT(IPT), YPT(IPT), PNAMES(IPT) - ELSE - WRITE (NDSE,1001) XPT(IPT), YPT(IPT), PNAMES(IPT) - END IF - END IF - CYCLE + !! Need to wrap rotated Elon values greater than X0. JGLi12Jun2012 + XPT(IPT) = MOD( EquLon(IPT)+360.0, 360.0 ) + IF( XPT(IPT) .LT. X0 ) XPT(IPT) = XPT(IPT) + 360.0 +#endif + ! + ! Check if point within grid and compute interpolation weights + ! + IF (GTYPE .NE. UNGTYPE) THEN + INGRID = W3GRMP( GSU, XPT(IPT), YPT(IPT), IX, IY, RD ) + ELSE + CALL IS_IN_UNGRID(IMOD, DBLE(XPT(IPT)), DBLE(YPT(IPT)), itout, IX, IY, RD) + INGRID = (ITOUT.GT.0) + END IF + ! + IF ( .NOT.INGRID ) THEN + IF ( IAPROC .EQ. NAPERR ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSE,1000) XPT(IPT), YPT(IPT), PNAMES(IPT) + ELSE + WRITE (NDSE,1001) XPT(IPT), YPT(IPT), PNAMES(IPT) END IF -! + END IF + CYCLE + END IF + ! #ifdef W3_T - DO K = 1,4 - WRITE (NDST,9012) IX(K), IY(K), RD(K) - END DO -#endif -! -! Check if point not on land -! - IF ( MAPSTA(IY(1),IX(1)) .EQ. 0 .AND. & - MAPSTA(IY(2),IX(2)) .EQ. 0 .AND. & - MAPSTA(IY(3),IX(3)) .EQ. 0 .AND. & - MAPSTA(IY(4),IX(4)) .EQ. 0 ) THEN - IF ( IAPROC .EQ. NAPERR ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSE,1002) XPT(IPT), YPT(IPT), PNAMES(IPT) - ELSE - WRITE (NDSE,1003) XPT(IPT), YPT(IPT), PNAMES(IPT) - END IF - END IF - CYCLE + DO K = 1,4 + WRITE (NDST,9012) IX(K), IY(K), RD(K) + END DO +#endif + ! + ! Check if point not on land + ! + IF ( MAPSTA(IY(1),IX(1)) .EQ. 0 .AND. & + MAPSTA(IY(2),IX(2)) .EQ. 0 .AND. & + MAPSTA(IY(3),IX(3)) .EQ. 0 .AND. & + MAPSTA(IY(4),IX(4)) .EQ. 0 ) THEN + IF ( IAPROC .EQ. NAPERR ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSE,1002) XPT(IPT), YPT(IPT), PNAMES(IPT) + ELSE + WRITE (NDSE,1003) XPT(IPT), YPT(IPT), PNAMES(IPT) END IF -! -! Store interpolation data -! - NOPTS = NOPTS + 1 -! - PTLOC (1,NOPTS) = XPT(IPT) - PTLOC (2,NOPTS) = YPT(IPT) + END IF + CYCLE + END IF + ! + ! Store interpolation data + ! + NOPTS = NOPTS + 1 + ! + PTLOC (1,NOPTS) = XPT(IPT) + PTLOC (2,NOPTS) = YPT(IPT) #ifdef W3_RTD - !! Store the standard lon/lat in PTLOC for output purpose, assuming - !! they are not used for any inside calculation. JGLi12Jun2012 - PTLOC (1,NOPTS) = StdLon(IPT) - PTLOC (2,NOPTS) = StdLat(IPT) -#endif -! - DO K = 1,4 - IPTINT(1,K,NOPTS) = IX(K) - IPTINT(2,K,NOPTS) = IY(K) - PTIFAC(K,NOPTS) = RD(K) - END DO + !! Store the standard lon/lat in PTLOC for output purpose, assuming + !! they are not used for any inside calculation. JGLi12Jun2012 + PTLOC (1,NOPTS) = StdLon(IPT) + PTLOC (2,NOPTS) = StdLat(IPT) +#endif + ! + DO K = 1,4 + IPTINT(1,K,NOPTS) = IX(K) + IPTINT(2,K,NOPTS) = IY(K) + PTIFAC(K,NOPTS) = RD(K) + END DO - PTNME(NOPTS) = PNAMES(IPT) -! - END DO ! End loop over output points (IPT). -! + PTNME(NOPTS) = PNAMES(IPT) + ! + END DO ! End loop over output points (IPT). + ! #ifdef W3_RTD - DEALLOCATE( EquLon, EquLat, StdLon, StdLat, AnglPT ) + DEALLOCATE( EquLon, EquLat, StdLon, StdLat, AnglPT ) #endif -! -! Diagnostic output -! + ! + ! Diagnostic output + ! #ifdef W3_O7a - IF ( IAPROC .EQ. NAPOUT ) THEN - WRITE (SCREEN,940) NOPTS - DO J=1, NOPTS -#endif -! -#ifdef W3_O7a - WRITE (SCREEN,941) PTNME(J), PTLOC(:,J)*FACTOR - IX(:) = IPTINT(1,:,J) - IY(:) = IPTINT(2,:,J) - RD(:) = PTIFAC(:,J) - WRITE (SCREEN,942) (IX(K),IY(K),RD(K),K=1,4) -#endif -! -#ifdef W3_O7a - ZBOX = 0. - RDTOT = 0. - DO K = 1,4 - IF ( MAPFS(IY(K),IX(K)) .GT. 0 ) THEN - ZBOX(K) = ZB(IX(K)) - RDTOT = RDTOT + RD(K) - END IF - END DO - RDTOT = MAX ( 1.E-7 , RDTOT ) -#endif -! -#ifdef W3_O7a - DEPTH = - ( RD(1)*ZBOX(1) + & - RD(2)*ZBOX(2) + & - RD(3)*ZBOX(3) + & - RD(4)*ZBOX(4) ) / RDTOT - WRITE (SCREEN,943) DEPTH -#endif -! -#ifdef W3_O7a - ! *** implementation of O7a option with curvilinear grids is incomplete *** -#endif -! -#ifdef W3_O7a - IF ( RD1 .LT. 0.05 ) IX2 = IX1 - IF ( RD1 .GT. 0.95 ) IX1 = IX2 - IF ( RD2 .LT. 0.05 ) IY2 = IY1 - IF ( RD2 .GT. 0.95 ) IY1 = IY2 - IX0 = IX1 - 1 - IXN = IX2 + 1 - IY0 = MAX ( 1 , IY1 - 1 ) - IYN = MIN ( IY2 + 1 , NY ) - NNX = 13 * ( IXN - IX0 + 1 ) -#endif -! -#ifdef W3_O7a - ALLOCATE ( STRING(NNX), LINE1(NNX), LINE2(NNX) ) - DO KX=1, NNX - LINE1(KX) = ' ' - LINE2(KX) = '-' - END DO - DO KX=7, NNX, 13 - LINE1(KX) = '|' - LINE2(KX) = '+' - END DO -#endif -! -#ifdef W3_O7a - IF ( ICLOSE.NE.ICLOSE_NONE ) THEN - WRITE (SCREEN,945) (1+MOD(KX+NX-1,NX),KX=IX0,IXN) - ELSE - WRITE (SCREEN,945) (KX,KX=IX0,IXN) - END IF - WRITE (SCREEN,946) LINE1 -#endif -! -#ifdef W3_O7a - DO KY=IYN, IY0, -1 -#endif -! -#ifdef W3_O7a - STRING = LINE1 - DO KX=IX0, IXN - IF ( ICLOSE.NE.ICLOSE_NONE .OR. (KX.GE.1 .AND. KX.LE.NX) ) THEN - IIX = 1 + MOD(KX-1+NX,NX) - IS1 = MAPFS(KY,IIX) - IF ( MAPSTA(KY,IIX) .NE. 0 ) THEN - WRITE (PARTS,'(F8.1,1X)') -ZB(IS1) - NNX = 2 + (KX-IX0)*13 - DO JX=1, 9 - STRING(NNX+JX:NNX+JX) = PARTS(JX:JX) - END DO - ENDIF - END IF - END DO - WRITE (SCREEN,946) STRING -#endif -! -#ifdef W3_O7a - STRING = LINE2 - DO KX=IX0, IXN - NNX = 5 + (KX-IX0)*13 - IF ( ICLOSE.EQ.ICLOSE_NONE .AND. (KX.LT.1.OR.KX.GT.NX) ) THEN - STRING(NNX:NNX+4) = OUT - ELSE - IIX = 1 + MOD(KX-1+NX,NX) - IF ( MAPSTA(KY,IIX) .EQ. 0 ) THEN - STRING(NNX:NNX+4) = LND - ELSE - STRING(NNX:NNX+4) = SEA - END IF - END IF - END DO - WRITE (SCREEN,947) KY, STRING -#endif -! -#ifdef W3_O7a - STRING = LINE1 - DO KX=IX0, IXN - IF ( ICLOSE.NE.ICLOSE_NONE .OR. (KX.GE.1 .AND. KX.LE.NX) ) THEN - IS1 = MAPFS(KY,KX) - IIX = 1 + MOD(KX-1+NX,NX) - IF ( MAPSTA(KY,IIX) .NE. 0 ) THEN - WRITE (PARTS,'(I4,1A,I4)') & - NINT(1000.*TRNX(KY,IIX)), & - '|', NINT(1000.*TRNY(KY,IIX)) - NNX = 2 + (KX-IX0)*13 - DO JX=1, 9 - STRING(NNX+JX:NNX+JX) = PARTS(JX:JX) - END DO - ENDIF - END IF + IF ( IAPROC .EQ. NAPOUT ) THEN + WRITE (SCREEN,940) NOPTS + DO J=1, NOPTS + ! + WRITE (SCREEN,941) PTNME(J), PTLOC(:,J)*FACTOR + IX(:) = IPTINT(1,:,J) + IY(:) = IPTINT(2,:,J) + RD(:) = PTIFAC(:,J) + WRITE (SCREEN,942) (IX(K),IY(K),RD(K),K=1,4) + ! + ZBOX = 0. + RDTOT = 0. + DO K = 1,4 + IF ( MAPFS(IY(K),IX(K)) .GT. 0 ) THEN + ZBOX(K) = ZB(IX(K)) + RDTOT = RDTOT + RD(K) + END IF + END DO + RDTOT = MAX ( 1.E-7 , RDTOT ) + ! + DEPTH = - ( RD(1)*ZBOX(1) + & + RD(2)*ZBOX(2) + & + RD(3)*ZBOX(3) + & + RD(4)*ZBOX(4) ) / RDTOT + WRITE (SCREEN,943) DEPTH + ! + ! *** implementation of O7a option with curvilinear grids is incomplete *** + ! + IF ( RD1 .LT. 0.05 ) IX2 = IX1 + IF ( RD1 .GT. 0.95 ) IX1 = IX2 + IF ( RD2 .LT. 0.05 ) IY2 = IY1 + IF ( RD2 .GT. 0.95 ) IY1 = IY2 + IX0 = IX1 - 1 + IXN = IX2 + 1 + IY0 = MAX ( 1 , IY1 - 1 ) + IYN = MIN ( IY2 + 1 , NY ) + NNX = 13 * ( IXN - IX0 + 1 ) + ! + ALLOCATE ( STRING(NNX), LINE1(NNX), LINE2(NNX) ) + DO KX=1, NNX + LINE1(KX) = ' ' + LINE2(KX) = '-' + END DO + DO KX=7, NNX, 13 + LINE1(KX) = '|' + LINE2(KX) = '+' + END DO + ! + IF ( ICLOSE.NE.ICLOSE_NONE ) THEN + WRITE (SCREEN,945) (1+MOD(KX+NX-1,NX),KX=IX0,IXN) + ELSE + WRITE (SCREEN,945) (KX,KX=IX0,IXN) + END IF + WRITE (SCREEN,946) LINE1 + ! + DO KY=IYN, IY0, -1 + ! + STRING = LINE1 + DO KX=IX0, IXN + IF ( ICLOSE.NE.ICLOSE_NONE .OR. (KX.GE.1 .AND. KX.LE.NX) ) THEN + IIX = 1 + MOD(KX-1+NX,NX) + IS1 = MAPFS(KY,IIX) + IF ( MAPSTA(KY,IIX) .NE. 0 ) THEN + WRITE (PARTS,'(F8.1,1X)') -ZB(IS1) + NNX = 2 + (KX-IX0)*13 + DO JX=1, 9 + STRING(NNX+JX:NNX+JX) = PARTS(JX:JX) END DO - WRITE (SCREEN,946) STRING - WRITE (SCREEN,946) LINE1 -#endif -! -#ifdef W3_O7a - END DO -#endif -! -#ifdef W3_O7a - IF ( ICLOSE.NE.ICLOSE_NONE ) THEN - WRITE (SCREEN,945) (1+MOD(KX+NX-1,NX),KX=IX0,IXN) + ENDIF + END IF + END DO + WRITE (SCREEN,946) STRING + ! + STRING = LINE2 + DO KX=IX0, IXN + NNX = 5 + (KX-IX0)*13 + IF ( ICLOSE.EQ.ICLOSE_NONE .AND. (KX.LT.1.OR.KX.GT.NX) ) THEN + STRING(NNX:NNX+4) = OUT + ELSE + IIX = 1 + MOD(KX-1+NX,NX) + IF ( MAPSTA(KY,IIX) .EQ. 0 ) THEN + STRING(NNX:NNX+4) = LND ELSE - WRITE (SCREEN,945) (KX,KX=IX0,IXN) + STRING(NNX:NNX+4) = SEA END IF - DEALLOCATE ( STRING, LINE1, LINE2 ) -#endif - -#ifdef W3_O7a - END DO - WRITE (SCREEN,*) - WRITE (SCREEN,*) + END IF + END DO + WRITE (SCREEN,947) KY, STRING + ! + STRING = LINE1 + DO KX=IX0, IXN + IF ( ICLOSE.NE.ICLOSE_NONE .OR. (KX.GE.1 .AND. KX.LE.NX) ) THEN + IS1 = MAPFS(KY,KX) + IIX = 1 + MOD(KX-1+NX,NX) + IF ( MAPSTA(KY,IIX) .NE. 0 ) THEN + WRITE (PARTS,'(I4,1A,I4)') & + NINT(1000.*TRNX(KY,IIX)), & + '|', NINT(1000.*TRNY(KY,IIX)) + NNX = 2 + (KX-IX0)*13 + DO JX=1, 9 + STRING(NNX+JX:NNX+JX) = PARTS(JX:JX) + END DO + ENDIF + END IF + END DO + WRITE (SCREEN,946) STRING + WRITE (SCREEN,946) LINE1 + ! + END DO + ! + IF ( ICLOSE.NE.ICLOSE_NONE ) THEN + WRITE (SCREEN,945) (1+MOD(KX+NX-1,NX),KX=IX0,IXN) + ELSE + WRITE (SCREEN,945) (KX,KX=IX0,IXN) END IF -#endif -! - RETURN -! -! Formats -! + DEALLOCATE ( STRING, LINE1, LINE2 ) + + END DO + WRITE (SCREEN,*) + WRITE (SCREEN,*) + END IF +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_O7a - 940 FORMAT (/' Diagnostic output for output points [',I3,'] :'/& - '--------------------------------------------'/ & - ' Bottom level in m above grid point'/ & - ' X/Y transparency in thousands below') - 941 FORMAT (/' Point ',A,' at ',2F8.2,' (degr or km)'/ & - ' -------------------------------------------------') - 942 FORMAT ( ' Interp. cell :',4(' (',2I5,F4.2,')')) - 943 FORMAT ( ' Depth (water level = 0) :',F10.1,' m'/) - 945 FORMAT ( ' IX = ',4I13) - 946 FORMAT ( ' ',52A1) - 947 FORMAT ( ' IY =',I5,2X,52A1) -#endif -! - 1000 FORMAT (/' *** WAVEWATCH-III WARNING :'/ & - ' OUTPUT POINT OUT OF GRID : ',2F10.3,2X,A/ & - ' POINT SKIPPPED '/) - 1001 FORMAT (/' *** WAVEWATCH-III WARNING :'/ & - ' OUTPUT POINT OUT OF GRID : ',2E10.3,2X,A/ & - ' POINT SKIPPPED '/) -! - 1002 FORMAT (/' *** WAVEWATCH-III WARNING :'/ & - ' OUTPUT POINT ON LAND : ',2F10.3,2X,A/ & - ' POINT SKIPPPED '/) - 1003 FORMAT (/' *** WAVEWATCH-III WARNING :'/ & - ' OUTPUT POINT ON LAND : ',2E10.3,2X,A/ & - ' POINT SKIPPPED '/) -! +940 FORMAT (/' Diagnostic output for output points [',I3,'] :'/& + '--------------------------------------------'/ & + ' Bottom level in m above grid point'/ & + ' X/Y transparency in thousands below') +941 FORMAT (/' Point ',A,' at ',2F8.2,' (degr or km)'/ & + ' -------------------------------------------------') +942 FORMAT ( ' Interp. cell :',4(' (',2I5,F4.2,')')) +943 FORMAT ( ' Depth (water level = 0) :',F10.1,' m'/) +945 FORMAT ( ' IX = ',4I13) +946 FORMAT ( ' ',52A1) +947 FORMAT ( ' IY =',I5,2X,52A1) +#endif + ! +1000 FORMAT (/' *** WAVEWATCH-III WARNING :'/ & + ' OUTPUT POINT OUT OF GRID : ',2F10.3,2X,A/ & + ' POINT SKIPPPED '/) +1001 FORMAT (/' *** WAVEWATCH-III WARNING :'/ & + ' OUTPUT POINT OUT OF GRID : ',2E10.3,2X,A/ & + ' POINT SKIPPPED '/) + ! +1002 FORMAT (/' *** WAVEWATCH-III WARNING :'/ & + ' OUTPUT POINT ON LAND : ',2F10.3,2X,A/ & + ' POINT SKIPPPED '/) +1003 FORMAT (/' *** WAVEWATCH-III WARNING :'/ & + ' OUTPUT POINT ON LAND : ',2E10.3,2X,A/ & + ' POINT SKIPPPED '/) + ! #ifdef W3_T - 9010 FORMAT (' TEST W3IOPP : INPUT : ',I4,2F12.2,2X,A) - 9011 FORMAT (' CORR. : ',2F12.2) - 9012 FORMAT (' TEST W3IOPP : INT. DATA: ',2I6,1F8.2) - 9013 FORMAT (' TEST W3IOPP : INT. DATA B): ',4I4,2F8.2) - 9020 FORMAT (' TEST W3IOPP : PREPROCESSED DATA',I4,2X,A,2X,2F12.2, & - 4(/' ',2I5,2F6.3)) - 9021 FORMAT (' TEST W3IOPP : PREPROCESSED DATA',I4,2X,A,2X,2F12.2, & - 4(/' ',2I5,F6.3)) -#endif -!/ -!/ End of W3IOPP ----------------------------------------------------- / -!/ - END SUBROUTINE W3IOPP -!/ ------------------------------------------------------------------- / -!> -!> @brief Extract point output data and store in output COMMONs. -!> -!> @details This action is taken from an earlier version of W3IOPO -!> so that the point output postprocessor does not need the full -!> sea-point grid to be able to run. Note that the output spectrum -!> is F(f,theta). Interpolation is performed for this spectrum. -!> -!> @param[in] A Action spectra on storage grid. -!> -!> @author H. L. Tolman @date 12-Jun-2012 -!> - SUBROUTINE W3IOPE ( A ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 12-Jun-2012 | -!/ +-----------------------------------+ -!/ -!/ 12-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 25-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 11-Jun-2001 : Clean-up. ( version 2.11 ) -!/ 09-Nov-2004 : Multiple grid version. ( version 3.06 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) -!/ (A. Roland and F. Ardhuin) -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 01-Mar-2018 : Add option to unrotate spectra ( version 6.02 ) -!/ from RTD grid models -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ -! 1. Purpose : -! -! Extract point output data and store in output COMMONs. This -! action is taken from an earlier version of W3IOPO so that the -! point output postprocessor does not need the full sea-point -! grid to be able to run. -! Note that the output spectrum is F(f,theta). Interpolation -! is performed for this spectrum. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action spectra on storage grid. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - To allow for dynamic ice edges, interpolation factors are -! calculated for every time step separately. -! - Wind current and depth data are interpolated ignoring ice, -! spectrum is interpolated removing ice points. -! - Spectra are left in par list to allow for change of shape of -! arrays. -! - IMOD is not passed to this routine. Since it is used only -! in W3WAVE, it is assumed that the pointer are set -! appropriately outside this routine. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Switch for message passing method. -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, SIG, NX, NY, NSEA, NSEAL, & - MAPSTA, MAPFS +9010 FORMAT (' TEST W3IOPP : INPUT : ',I4,2F12.2,2X,A) +9011 FORMAT (' CORR. : ',2F12.2) +9012 FORMAT (' TEST W3IOPP : INT. DATA: ',2I6,1F8.2) +9013 FORMAT (' TEST W3IOPP : INT. DATA B): ',4I4,2F8.2) +9020 FORMAT (' TEST W3IOPP : PREPROCESSED DATA',I4,2X,A,2X,2F12.2, & + 4(/' ',2I5,2F6.3)) +9021 FORMAT (' TEST W3IOPP : PREPROCESSED DATA',I4,2X,A,2X,2F12.2, & + 4(/' ',2I5,F6.3)) +#endif + !/ + !/ End of W3IOPP ----------------------------------------------------- / + !/ + END SUBROUTINE W3IOPP + !/ ------------------------------------------------------------------- / + !> + !> @brief Extract point output data and store in output COMMONs. + !> + !> @details This action is taken from an earlier version of W3IOPO + !> so that the point output postprocessor does not need the full + !> sea-point grid to be able to run. Note that the output spectrum + !> is F(f,theta). Interpolation is performed for this spectrum. + !> + !> @param[in] A Action spectra on storage grid. + !> + !> @author H. L. Tolman @date 12-Jun-2012 + !> + SUBROUTINE W3IOPE ( A ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 12-Jun-2012 | + !/ +-----------------------------------+ + !/ + !/ 12-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 25-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 11-Jun-2001 : Clean-up. ( version 2.11 ) + !/ 09-Nov-2004 : Multiple grid version. ( version 3.06 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) + !/ (A. Roland and F. Ardhuin) + !/ 12-Jun-2012 : Add /RTD option or rotated grid option. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 01-Mar-2018 : Add option to unrotate spectra ( version 6.02 ) + !/ from RTD grid models + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ + ! 1. Purpose : + ! + ! Extract point output data and store in output COMMONs. This + ! action is taken from an earlier version of W3IOPO so that the + ! point output postprocessor does not need the full sea-point + ! grid to be able to run. + ! Note that the output spectrum is F(f,theta). Interpolation + ! is performed for this spectrum. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action spectra on storage grid. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - To allow for dynamic ice edges, interpolation factors are + ! calculated for every time step separately. + ! - Wind current and depth data are interpolated ignoring ice, + ! spectrum is interpolated removing ice points. + ! - Spectra are left in par list to allow for change of shape of + ! arrays. + ! - IMOD is not passed to this routine. Since it is used only + ! in W3WAVE, it is assumed that the pointer are set + ! appropriately outside this routine. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Switch for message passing method. + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, SIG, NX, NY, NSEA, NSEAL, & + MAPSTA, MAPFS #ifdef W3_RTD - !! Use spectral rotation sub and angle. JGLi12Jun2012 - USE W3GDATMD, ONLY: NSPEC, AnglD, FLAGUNR - USE W3SERVMD, ONLY: W3ACTURN + !! Use spectral rotation sub and angle. JGLi12Jun2012 + USE W3GDATMD, ONLY: NSPEC, AnglD, FLAGUNR + USE W3SERVMD, ONLY: W3ACTURN #endif - USE W3WDATMD, ONLY: ICE, ICEH, ICEF + USE W3WDATMD, ONLY: ICE, ICEH, ICEF #ifdef W3_FLX5 - USE W3WDATMD, ONLY: RHOAIR + USE W3WDATMD, ONLY: RHOAIR #endif - USE W3ADATMD, ONLY: CG, DW, UA, UD, AS, CX, CY, & - SP => SPPNT + USE W3ADATMD, ONLY: CG, DW, UA, UD, AS, CX, CY, & + SP => SPPNT #ifdef W3_FLX5 - USE W3ADATMD, ONLY: TAUA, TAUADIR + USE W3ADATMD, ONLY: TAUA, TAUADIR #endif - USE W3ODATMD, ONLY: NDST, NOPTS, IPTINT, PTIFAC, IL, IW, II, & - DPO, WAO, WDO, ASO, CAO, CDO, ICEO, ICEHO, & - ICEFO, SPCO, NAPROC + USE W3ODATMD, ONLY: NDST, NOPTS, IPTINT, PTIFAC, IL, IW, II, & + DPO, WAO, WDO, ASO, CAO, CDO, ICEO, ICEHO, & + ICEFO, SPCO, NAPROC #ifdef W3_FLX5 - USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO + USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO #endif #ifdef W3_SETUP - USE W3WDATMD, ONLY: ZETA_SETUP - USE W3ODATMD, ONLY: ZET_SETO + USE W3WDATMD, ONLY: ZETA_SETUP + USE W3ODATMD, ONLY: ZET_SETO #endif #ifdef W3_MPI - USE W3ODATMD, ONLY: IRQPO2 + USE W3ODATMD, ONLY: IRQPO2 #endif - USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK,0:NSEAL) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, IX1, IY1, IX(4), IY(4), J, IS(4), & - IM(4), IK, ITH, ISP + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK,0:NSEAL) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, IX1, IY1, IX(4), IY(4), J, IS(4), & + IM(4), IK, ITH, ISP #ifdef W3_MPI - INTEGER :: IOFF, IERR_MPI - INTEGER :: STAT(MPI_STATUS_SIZE,4*NOPTS) + INTEGER :: IOFF, IERR_MPI + INTEGER :: STAT(MPI_STATUS_SIZE,4*NOPTS) #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: RD(4), RDS, RDI, FACRD, & - WNDX, WNDY, CURX, CURY, FAC1(NK), & - FAC2(NK), FAC3(NK), FAC4(NK) + REAL :: RD(4), RDS, RDI, FACRD, & + WNDX, WNDY, CURX, CURY, FAC1(NK), & + FAC2(NK), FAC3(NK), FAC4(NK) #ifdef W3_FLX5 - REAL :: TAUX, TAUY + REAL :: TAUX, TAUY #endif - INTEGER :: JSEA, ISEA + INTEGER :: JSEA, ISEA #ifdef W3_T - REAL :: SPTEST(NK,NTH) + REAL :: SPTEST(NK,NTH) #endif #ifdef W3_RTD - REAL :: Spectr(NSPEC), AnglDIS - INTEGER :: IROT + REAL :: Spectr(NSPEC), AnglDIS + INTEGER :: IROT #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3IOPE') -#endif -! - CX(0) = 0. - CY(0) = 0. -! -! Loop over spectra -------------------------------------------------- * -! - DO I=1, NOPTS -! + CALL STRACE (IENT, 'W3IOPE') +#endif + ! + CX(0) = 0. + CY(0) = 0. + ! + ! Loop over spectra -------------------------------------------------- * + ! + DO I=1, NOPTS + ! #ifdef W3_T - WRITE (NDST,9000) I -#endif -! -! Unpack interpolation data -! - IX(:) = IPTINT(1,:,I) - IY(:) = IPTINT(2,:,I) - RD(:) = PTIFAC(:,I) -! + WRITE (NDST,9000) I +#endif + ! + ! Unpack interpolation data + ! + IX(:) = IPTINT(1,:,I) + IY(:) = IPTINT(2,:,I) + RD(:) = PTIFAC(:,I) + ! #ifdef W3_T -! WRITE (NDST,9001) IX1, IY1, IX(2) -#endif -! -! -! Correct for land and ice and get sea point counters -! - IL(I) = 0 - IW(I) = 0 - II(I) = 0 - RDS = 0. - RDI = 0. -! - DO J=1, 4 - IS(J) = MAPFS (IY(J),IX(J)) - IM(J) = MAPSTA(IY(J),IX(J)) - IF ( IM(J).GT.0 ) THEN - IW(I) = IW(I) + 1 - RDS = RDS + RD(J) + ! WRITE (NDST,9001) IX1, IY1, IX(2) +#endif + ! + ! + ! Correct for land and ice and get sea point counters + ! + IL(I) = 0 + IW(I) = 0 + II(I) = 0 + RDS = 0. + RDI = 0. + ! + DO J=1, 4 + IS(J) = MAPFS (IY(J),IX(J)) + IM(J) = MAPSTA(IY(J),IX(J)) + IF ( IM(J).GT.0 ) THEN + IW(I) = IW(I) + 1 + RDS = RDS + RD(J) #ifdef W3_RTD - IROT = IS(J) ! For rotation angle + IROT = IS(J) ! For rotation angle #endif - ELSE - IF ( IM(J).LT.0 ) THEN - II(I) = II(I) + 1 - RDI = RDI + RD(J) - ELSE - IL(I) = IL(I) + 1 - RD(J) = 0. - END IF - END IF - END DO -! -! Depth, wind and current, ignore ice -! - IF ( RDS+RDI .GT. 1.E-7 ) THEN - FACRD = 1. / (RDS+RDI) - RD = RD * FACRD + ELSE + IF ( IM(J).LT.0 ) THEN + II(I) = II(I) + 1 + RDI = RDI + RD(J) + ELSE + IL(I) = IL(I) + 1 + RD(J) = 0. END IF -! + END IF + END DO + ! + ! Depth, wind and current, ignore ice + ! + IF ( RDS+RDI .GT. 1.E-7 ) THEN + FACRD = 1. / (RDS+RDI) + RD = RD * FACRD + END IF + ! #ifdef W3_T - WRITE (NDST,9002) (IS(J),J=1,4), (IM(J),J=1,4), (RD(J),J=1,4) -#endif -! -! Interpolate ice depth, wind, stresses, rho air and current -! - IF (.NOT. LPDLIB) THEN - ICEFO(I) = 0 - DO J=1, 4 - ISEA = MAPFS(IY(J),IX(J)) + WRITE (NDST,9002) (IS(J),J=1,4), (IM(J),J=1,4), (RD(J),J=1,4) +#endif + ! + ! Interpolate ice depth, wind, stresses, rho air and current + ! + IF (.NOT. LPDLIB) THEN + ICEFO(I) = 0 + DO J=1, 4 + ISEA = MAPFS(IY(J),IX(J)) #ifdef W3_DIST JSEA = 1 + (ISEA-1)/NAPROC #endif #ifdef W3_SHRD JSEA = ISEA #endif - ICEFO(I) = ICEFO(I) + RD(J)*ICEF(JSEA) - END DO - ELSE - ICEFO(I) = RD(1)*ICEF(IS(1)) + RD(2)*ICEF(IS(2)) + & - RD(3)*ICEF(IS(3)) + RD(4)*ICEF(IS(4)) - END IF + ICEFO(I) = ICEFO(I) + RD(J)*ICEF(JSEA) + END DO + ELSE + ICEFO(I) = RD(1)*ICEF(IS(1)) + RD(2)*ICEF(IS(2)) + & + RD(3)*ICEF(IS(3)) + RD(4)*ICEF(IS(4)) + END IF - ICEO(I) = RD(1)*ICE(IS(1)) + RD(2)*ICE(IS(2)) + & - RD(3)*ICE(IS(3)) + RD(4)*ICE(IS(4)) + ICEO(I) = RD(1)*ICE(IS(1)) + RD(2)*ICE(IS(2)) + & + RD(3)*ICE(IS(3)) + RD(4)*ICE(IS(4)) - ICEHO(I) = RD(1)*ICEH(IS(1)) + RD(2)*ICEH(IS(2)) + & - RD(3)*ICEH(IS(3)) + RD(4)*ICEH(IS(4)) -! - DPO(I) = RD(1)*DW(IS(1)) + RD(2)*DW(IS(2)) + & - RD(3)*DW(IS(3)) + RD(4)*DW(IS(4)) + ICEHO(I) = RD(1)*ICEH(IS(1)) + RD(2)*ICEH(IS(2)) + & + RD(3)*ICEH(IS(3)) + RD(4)*ICEH(IS(4)) + ! + DPO(I) = RD(1)*DW(IS(1)) + RD(2)*DW(IS(2)) + & + RD(3)*DW(IS(3)) + RD(4)*DW(IS(4)) #ifdef W3_SETUP - DPO(I) = RD(1)*ZETA_SETUP(IS(1)) + & - RD(2)*ZETA_SETUP(IS(2)) + & - RD(3)*ZETA_SETUP(IS(3)) + & - RD(4)*ZETA_SETUP(IS(4)) + DPO(I) = RD(1)*ZETA_SETUP(IS(1)) + & + RD(2)*ZETA_SETUP(IS(2)) + & + RD(3)*ZETA_SETUP(IS(3)) + & + RD(4)*ZETA_SETUP(IS(4)) #endif -! + ! #ifdef W3_FLX5 - DAIRO(I) = RD(1)*RHOAIR(IS(1)) + RD(2)*RHOAIR(IS(2)) + & - RD(3)*RHOAIR(IS(3)) + RD(4)*RHOAIR(IS(4)) -#endif -! - WNDX = RD(1) * UA(IS(1)) * COS(UD(IS(1))) + & - RD(2) * UA(IS(2)) * COS(UD(IS(2))) + & - RD(3) * UA(IS(3)) * COS(UD(IS(3))) + & - RD(4) * UA(IS(4)) * COS(UD(IS(4))) - WNDY = RD(1) * UA(IS(1)) * SIN(UD(IS(1))) + & - RD(2) * UA(IS(2)) * SIN(UD(IS(2))) + & - RD(3) * UA(IS(3)) * SIN(UD(IS(3))) + & - RD(4) * UA(IS(4)) * SIN(UD(IS(4))) -! - WAO(I) = SQRT ( WNDX**2 + WNDY**2 ) - IF ( WAO(I).GT.1.E-7 ) THEN - WDO(I) = ATAN2(WNDY,WNDX) + DAIRO(I) = RD(1)*RHOAIR(IS(1)) + RD(2)*RHOAIR(IS(2)) + & + RD(3)*RHOAIR(IS(3)) + RD(4)*RHOAIR(IS(4)) +#endif + ! + WNDX = RD(1) * UA(IS(1)) * COS(UD(IS(1))) + & + RD(2) * UA(IS(2)) * COS(UD(IS(2))) + & + RD(3) * UA(IS(3)) * COS(UD(IS(3))) + & + RD(4) * UA(IS(4)) * COS(UD(IS(4))) + WNDY = RD(1) * UA(IS(1)) * SIN(UD(IS(1))) + & + RD(2) * UA(IS(2)) * SIN(UD(IS(2))) + & + RD(3) * UA(IS(3)) * SIN(UD(IS(3))) + & + RD(4) * UA(IS(4)) * SIN(UD(IS(4))) + ! + WAO(I) = SQRT ( WNDX**2 + WNDY**2 ) + IF ( WAO(I).GT.1.E-7 ) THEN + WDO(I) = ATAN2(WNDY,WNDX) #ifdef W3_RTD - IF ( FLAGUNR ) WDO(I) = WDO(I) - AnglD(IS(1))*DERA + IF ( FLAGUNR ) WDO(I) = WDO(I) - AnglD(IS(1))*DERA #endif - ELSE - WDO(I) = 0. - END IF -! + ELSE + WDO(I) = 0. + END IF + ! #ifdef W3_FLX5 - TAUX = RD(1) * TAUA(IS(1)) * COS(TAUADIR(IS(1))) + & - RD(2) * TAUA(IS(2)) * COS(TAUADIR(IS(2))) + & - RD(3) * TAUA(IS(3)) * COS(TAUADIR(IS(3))) + & - RD(4) * TAUA(IS(4)) * COS(TAUADIR(IS(4))) - TAUY = RD(1) * TAUA(IS(1)) * SIN(TAUADIR(IS(1))) + & - RD(2) * TAUA(IS(2)) * SIN(TAUADIR(IS(2))) + & - RD(3) * TAUA(IS(3)) * SIN(TAUADIR(IS(3))) + & - RD(4) * TAUA(IS(4)) * SIN(TAUADIR(IS(4))) -! - TAUAO(I) = SQRT ( TAUX**2 + TAUY**2 ) - IF ( TAUAO(I).GT.1.E-7 ) THEN - TAUDO(I) = ATAN2(TAUY,TAUX) + TAUX = RD(1) * TAUA(IS(1)) * COS(TAUADIR(IS(1))) + & + RD(2) * TAUA(IS(2)) * COS(TAUADIR(IS(2))) + & + RD(3) * TAUA(IS(3)) * COS(TAUADIR(IS(3))) + & + RD(4) * TAUA(IS(4)) * COS(TAUADIR(IS(4))) + TAUY = RD(1) * TAUA(IS(1)) * SIN(TAUADIR(IS(1))) + & + RD(2) * TAUA(IS(2)) * SIN(TAUADIR(IS(2))) + & + RD(3) * TAUA(IS(3)) * SIN(TAUADIR(IS(3))) + & + RD(4) * TAUA(IS(4)) * SIN(TAUADIR(IS(4))) + ! + TAUAO(I) = SQRT ( TAUX**2 + TAUY**2 ) + IF ( TAUAO(I).GT.1.E-7 ) THEN + TAUDO(I) = ATAN2(TAUY,TAUX) #ifdef W3_RTD - IF ( FLAGUNR ) TAUDO(I) = TAUDO(I) - AnglD(IS(1))*DERA -#endif - ELSE - TAUDO(I) = 0. - END IF -! -#endif - ASO(I) = RD(1)*AS(IS(1)) + RD(2)*AS(IS(2)) + & - RD(3)*AS(IS(3)) + RD(4)*AS(IS(4)) -! - CURX = RD(1)*CX(IS(1)) + RD(2)*CX(IS(2)) + & - RD(3)*CX(IS(3)) + RD(4)*CX(IS(4)) - CURY = RD(1)*CY(IS(1)) + RD(2)*CY(IS(2)) + & - RD(3)*CY(IS(3)) + RD(4)*CY(IS(4)) -! - CAO(I) = SQRT ( CURX**2 + CURY**2 ) - IF ( CAO(I).GT.1.E-7 ) THEN - CDO(I) = ATAN2(CURY,CURX) + IF ( FLAGUNR ) TAUDO(I) = TAUDO(I) - AnglD(IS(1))*DERA +#endif + ELSE + TAUDO(I) = 0. + END IF + ! +#endif + ASO(I) = RD(1)*AS(IS(1)) + RD(2)*AS(IS(2)) + & + RD(3)*AS(IS(3)) + RD(4)*AS(IS(4)) + ! + CURX = RD(1)*CX(IS(1)) + RD(2)*CX(IS(2)) + & + RD(3)*CX(IS(3)) + RD(4)*CX(IS(4)) + CURY = RD(1)*CY(IS(1)) + RD(2)*CY(IS(2)) + & + RD(3)*CY(IS(3)) + RD(4)*CY(IS(4)) + ! + CAO(I) = SQRT ( CURX**2 + CURY**2 ) + IF ( CAO(I).GT.1.E-7 ) THEN + CDO(I) = ATAN2(CURY,CURX) #ifdef W3_RTD - IF ( FLAGUNR ) CDO(I) = CDO(I) - AnglD(IS(1))*DERA -#endif - ELSE - CDO(I) = 0. - END IF -! -! Interp. weights for spectra, no ice points (spectra by def. zero) -! - IF ( RDS .GT. 1.E-7 ) THEN - FACRD = (RDS+RDI) / RDS - RD = RD * FACRD - END IF -! + IF ( FLAGUNR ) CDO(I) = CDO(I) - AnglD(IS(1))*DERA +#endif + ELSE + CDO(I) = 0. + END IF + ! + ! Interp. weights for spectra, no ice points (spectra by def. zero) + ! + IF ( RDS .GT. 1.E-7 ) THEN + FACRD = (RDS+RDI) / RDS + RD = RD * FACRD + END IF + ! #ifdef W3_T - WRITE (NDST,9003) (RD(J),J=1,4) + WRITE (NDST,9003) (RD(J),J=1,4) #endif -! -! Extract spectra, shared memory version -! (done in separate step for MPP compatibility) -! + ! + ! Extract spectra, shared memory version + ! (done in separate step for MPP compatibility) + ! #ifdef W3_SHRD - DO J=1, 4 - DO IK=1, NK - DO ITH=1, NTH - SP(ITH,IK,J) = A(ITH,IK,IS(J)) - END DO - END DO + DO J=1, 4 + DO IK=1, NK + DO ITH=1, NTH + SP(ITH,IK,J) = A(ITH,IK,IS(J)) END DO + END DO + END DO #endif -! -! Extract spectra, distributed memory version(s) -! + ! + ! Extract spectra, distributed memory version(s) + ! #ifdef W3_MPI - IOFF = 1 + 4*(I-1) - CALL MPI_STARTALL ( 4, IRQPO2(IOFF), IERR_MPI ) - CALL MPI_WAITALL ( 4, IRQPO2(IOFF), STAT, IERR_MPI ) -#endif -! -! Interpolate spectrum -! - DO IK=1, NK - FAC1(IK) = TPI * SIG(IK) / CG(IK,IS(1)) - FAC2(IK) = TPI * SIG(IK) / CG(IK,IS(2)) - FAC3(IK) = TPI * SIG(IK) / CG(IK,IS(3)) - FAC4(IK) = TPI * SIG(IK) / CG(IK,IS(4)) - END DO -! - DO IK=1,NK - DO ITH=1,NTH - ISP = ITH + (IK-1)*NTH - SPCO(ISP,I) = RD(1) * SP(ITH,IK,1) * FAC1(IK) & - + RD(2) * SP(ITH,IK,2) * FAC2(IK) & - + RD(3) * SP(ITH,IK,3) * FAC3(IK) & - + RD(4) * SP(ITH,IK,4) * FAC4(IK) + IOFF = 1 + 4*(I-1) + CALL MPI_STARTALL ( 4, IRQPO2(IOFF), IERR_MPI ) + CALL MPI_WAITALL ( 4, IRQPO2(IOFF), STAT, IERR_MPI ) +#endif + ! + ! Interpolate spectrum + ! + DO IK=1, NK + FAC1(IK) = TPI * SIG(IK) / CG(IK,IS(1)) + FAC2(IK) = TPI * SIG(IK) / CG(IK,IS(2)) + FAC3(IK) = TPI * SIG(IK) / CG(IK,IS(3)) + FAC4(IK) = TPI * SIG(IK) / CG(IK,IS(4)) + END DO + ! + DO IK=1,NK + DO ITH=1,NTH + ISP = ITH + (IK-1)*NTH + SPCO(ISP,I) = RD(1) * SP(ITH,IK,1) * FAC1(IK) & + + RD(2) * SP(ITH,IK,2) * FAC2(IK) & + + RD(3) * SP(ITH,IK,3) * FAC3(IK) & + + RD(4) * SP(ITH,IK,4) * FAC4(IK) #ifdef W3_T - SPTEST(IK,ITH) = SPCO(ISP,I) + SPTEST(IK,ITH) = SPCO(ISP,I) #endif - END DO - END DO -! + END DO + END DO + ! #ifdef W3_RTD - !! Rotate the interpolated spectrum by -AnglD(IS(1)). JGLi12Jun2012 - !! SPCO still holds action not energy spectrum yet. JGLi18Jun2013 - !! Use new index IROT rather than IS(1) as in some cases - !! IS(1) will be a coast point and have an index of 0. C.Bunney 15/02/2011 - IF ( FLAGUNR ) THEN - Spectr = SPCO(:,I) - AnglDIS = -AnglD(IROT) - CALL W3ACTURN( NTH, NK, AnglDIS, Spectr ) - SPCO(:,I) = Spectr - END IF + !! Rotate the interpolated spectrum by -AnglD(IS(1)). JGLi12Jun2012 + !! SPCO still holds action not energy spectrum yet. JGLi18Jun2013 + !! Use new index IROT rather than IS(1) as in some cases + !! IS(1) will be a coast point and have an index of 0. C.Bunney 15/02/2011 + IF ( FLAGUNR ) THEN + Spectr = SPCO(:,I) + AnglDIS = -AnglD(IROT) + CALL W3ACTURN( NTH, NK, AnglDIS, Spectr ) + SPCO(:,I) = Spectr + END IF #endif -! + ! #ifdef W3_T - WRITE (NDST,9004) DPO(I), WAO(I), WDO(I)*RADE, & - CAO(I), CDO(I)*RADE + WRITE (NDST,9004) DPO(I), WAO(I), WDO(I)*RADE, & + CAO(I), CDO(I)*RADE #endif -! FA COMMENTED OUT: BUG -!At line 1974 of file w3arrymd.f90 -!Fortran runtime error: Index '52' of dimension 1 of array 'pnum2' above upper bound of 51 + ! FA COMMENTED OUT: BUG + !At line 1974 of file w3arrymd.f90 + !Fortran runtime error: Index '52' of dimension 1 of array 'pnum2' above upper bound of 51 #ifdef W3_T - ! CALL PRT2DS (NDST, NK, NK, NTH, SPTEST, SIG(1:), ' ', 1.,0.,& - ! 0.0001, 'E(f,theta)', 'm**2s', 'TEST OUTPUT' ) -#endif -! - END DO -! - RETURN -! -! Formats -! + ! CALL PRT2DS (NDST, NK, NK, NTH, SPTEST, SIG(1:), ' ', 1.,0.,& + ! 0.0001, 'E(f,theta)', 'm**2s', 'TEST OUTPUT' ) +#endif + ! + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3IOPE : POINT NR.:',I3) - 9001 FORMAT (' TEST W3IOPE :',2I8,' (',I3,')') - 9002 FORMAT (' TEST W3IOPE :',4I7,2X,4I2,2X,4F5.2) - 9003 FORMAT (' TEST W3IOPE :',40X,4F5.2) - 9004 FORMAT (' TEST W3IOPE :',F8.1,2(F7.2,F7.1)) -#endif -!/ -!/ End of W3IOPE ----------------------------------------------------- / -!/ - END SUBROUTINE W3IOPE -!/ ------------------------------------------------------------------- / -!> -!> @brief Read/write point output. -!> -!> @param[in] INXOUT Test string for read/write. -!> @param[in] NDSOP File unit number. -!> @param[out] IOTST Test indictor for reading. -!> @param[in] IMOD Model number for W3GDAT etc. -!> -!> @author H. L. Tolman @date 25-Jul-2006 -!> - SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-Jul-2006 | -!/ +-----------------------------------+ -!/ -!/ 07-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 30-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 10-Nov-2004 : Multiple grid version. ( version 3.06 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 25-Jul-2006 : Adding grid ID per point. ( version 3.10 ) -!/ 27-Aug-2015 : Adding interpolation for the ice. ( version 5.10 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ -! 1. Purpose : -! -! Read/write point output. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ' and 'WRITE'. -! NDSOP Int. I File unit number. -! IOTST Int. O Test indictor for reading. -! 0 : Data read. -! -1 : Past end of file. -! IMOD I(O) I Model number for W3GDAT etc. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! WW3_OUTP Prog. N/A Postprocessing for point output. -! GX_OUTP Prog. N/A Grads postprocessing for point output. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! Tests on INXOUT, file status and on array dimensions. -! -! 7. Remarks : -! -! - The output file has the pre-defined name 'out_pnt.FILEXT'. -! - In MPP version of model data is supposed to be gatherd at the -! correct processor before the routine is called. -! - No error output filtering needed. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: W3SETG - USE W3WDATMD, ONLY: W3SETW - USE W3ODATMD, ONLY: W3SETO, W3DMO2 -!/ - USE W3GDATMD, ONLY: NTH, NK, NSPEC, FILEXT - USE W3WDATMD, ONLY: TIME - USE W3ODATMD, ONLY: NDST, NDSE, IPASS => IPASS2, NOPTS, IPTINT, & - IL, IW, II, PTLOC, PTIFAC, DPO, WAO, WDO, & - ASO, CAO, CDO, SPCO, PTNME, O2INIT, FNMPRE, & - GRDID, ICEO, ICEHO, ICEFO +9000 FORMAT (' TEST W3IOPE : POINT NR.:',I3) +9001 FORMAT (' TEST W3IOPE :',2I8,' (',I3,')') +9002 FORMAT (' TEST W3IOPE :',4I7,2X,4I2,2X,4F5.2) +9003 FORMAT (' TEST W3IOPE :',40X,4F5.2) +9004 FORMAT (' TEST W3IOPE :',F8.1,2(F7.2,F7.1)) +#endif + !/ + !/ End of W3IOPE ----------------------------------------------------- / + !/ + END SUBROUTINE W3IOPE + !/ ------------------------------------------------------------------- / + !> + !> @brief Read/write point output. + !> + !> @param[in] INXOUT Test string for read/write. + !> @param[in] NDSOP File unit number. + !> @param[out] IOTST Test indictor for reading. + !> @param[in] IMOD Model number for W3GDAT etc. + !> + !> @author H. L. Tolman @date 25-Jul-2006 + !> + SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-Jul-2006 | + !/ +-----------------------------------+ + !/ + !/ 07-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 30-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 10-Nov-2004 : Multiple grid version. ( version 3.06 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 25-Jul-2006 : Adding grid ID per point. ( version 3.10 ) + !/ 27-Aug-2015 : Adding interpolation for the ice. ( version 5.10 ) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ + ! 1. Purpose : + ! + ! Read/write point output. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'READ' and 'WRITE'. + ! NDSOP Int. I File unit number. + ! IOTST Int. O Test indictor for reading. + ! 0 : Data read. + ! -1 : Past end of file. + ! IMOD I(O) I Model number for W3GDAT etc. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! WW3_OUTP Prog. N/A Postprocessing for point output. + ! GX_OUTP Prog. N/A Grads postprocessing for point output. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! Tests on INXOUT, file status and on array dimensions. + ! + ! 7. Remarks : + ! + ! - The output file has the pre-defined name 'out_pnt.FILEXT'. + ! - In MPP version of model data is supposed to be gatherd at the + ! correct processor before the routine is called. + ! - No error output filtering needed. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: W3SETG + USE W3WDATMD, ONLY: W3SETW + USE W3ODATMD, ONLY: W3SETO, W3DMO2 + !/ + USE W3GDATMD, ONLY: NTH, NK, NSPEC, FILEXT + USE W3WDATMD, ONLY: TIME + USE W3ODATMD, ONLY: NDST, NDSE, IPASS => IPASS2, NOPTS, IPTINT, & + IL, IW, II, PTLOC, PTIFAC, DPO, WAO, WDO, & + ASO, CAO, CDO, SPCO, PTNME, O2INIT, FNMPRE, & + GRDID, ICEO, ICEHO, ICEFO #ifdef W3_FLX5 - USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO + USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO #endif - USE W3ODATMD, ONLY : OFILES -!/ + USE W3ODATMD, ONLY : OFILES + !/ #ifdef W3_SETUP - USE W3ODATMD, ONLY: ZET_SETO + USE W3ODATMD, ONLY: ZET_SETO #endif -!/ - USE W3SERVMD, ONLY: EXTCDE + !/ + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - use constants, only: file_endian -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSOP - INTEGER, INTENT(OUT) :: IOTST - INTEGER, INTENT(IN), OPTIONAL :: IMOD - CHARACTER, INTENT(IN) :: INXOUT*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ local parameters -!/ - INTEGER :: IGRD, IERR, MK, MTH, I, J + use constants, only: file_endian + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSOP + INTEGER, INTENT(OUT) :: IOTST + INTEGER, INTENT(IN), OPTIONAL :: IMOD + CHARACTER, INTENT(IN) :: INXOUT*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ local parameters + !/ + INTEGER :: IGRD, IERR, MK, MTH, I, J #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - LOGICAL,SAVE :: WRITE - CHARACTER(LEN=31) :: IDTST - CHARACTER(LEN=10) :: VERTST -!/ - CHARACTER(LEN=15) :: TIMETAG -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + LOGICAL,SAVE :: WRITE + CHARACTER(LEN=31) :: IDTST + CHARACTER(LEN=10) :: VERTST + !/ + CHARACTER(LEN=15) :: TIMETAG + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3IOPO') -#endif - IPASS = IPASS + 1 - IOTST = 0 -! -! test input parameters ---------------------------------------------- * -! - IF ( PRESENT(IMOD) ) THEN - IGRD = IMOD - ELSE - IGRD = 1 + CALL STRACE (IENT, 'W3IOPO') +#endif + IPASS = IPASS + 1 + IOTST = 0 + ! + ! test input parameters ---------------------------------------------- * + ! + IF ( PRESENT(IMOD) ) THEN + IGRD = IMOD + ELSE + IGRD = 1 + END IF + ! + CALL W3SETO ( IGRD, NDSE, NDST ) + CALL W3SETG ( IGRD, NDSE, NDST ) + CALL W3SETW ( IGRD, NDSE, NDST ) + ! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' ) THEN + WRITE (NDSE,900) INXOUT + CALL EXTCDE ( 1 ) + END IF + ! + ! IF ( IPASS.EQ.1 ) THEN + IF ( IPASS.EQ.1 .AND. OFILES(2) .EQ. 0) THEN + WRITE = INXOUT.EQ.'WRITE' + ELSE + IF ( WRITE .AND. INXOUT.EQ.'READ' ) THEN + WRITE (NDSE,901) INXOUT + CALL EXTCDE ( 2 ) + END IF + END IF + ! + ! open file ---------------------------------------------------------- * + ! + IF ( IPASS.EQ.1 .AND. OFILES(2) .EQ. 0 ) THEN + ! + I = LEN_TRIM(FILEXT) + J = LEN_TRIM(FNMPRE) + ! +#ifdef W3_T + WRITE (NDST,9001) FNMPRE(:J)//'out_pnt.'//FILEXT(:I) +#endif + IF ( WRITE ) THEN + OPEN (NDSOP,FILE=FNMPRE(:J)//'out_pnt.'//FILEXT(:I), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) + ELSE + OPEN (NDSOP,FILE=FNMPRE(:J)//'out_pnt.'//FILEXT(:I), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR,STATUS='OLD') + END IF + ! + REWIND ( NDSOP ) + ! + ! test info ---------------------------------------------------------- * + ! ( IPASS = 1 ) + ! + IF ( WRITE ) THEN + WRITE (NDSOP) & + IDSTR, VEROPT, NK, NTH, NOPTS + ELSE + READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & + IDTST, VERTST, MK, MTH, NOPTS + ! + IF ( IDTST .NE. IDSTR ) THEN + WRITE (NDSE,902) IDTST, IDSTR + CALL EXTCDE ( 10 ) END IF -! - CALL W3SETO ( IGRD, NDSE, NDST ) - CALL W3SETG ( IGRD, NDSE, NDST ) - CALL W3SETW ( IGRD, NDSE, NDST ) -! - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' ) THEN - WRITE (NDSE,900) INXOUT - CALL EXTCDE ( 1 ) + IF ( VERTST .NE. VEROPT ) THEN + WRITE (NDSE,903) VERTST, VEROPT + CALL EXTCDE ( 11 ) END IF -! -! IF ( IPASS.EQ.1 ) THEN - IF ( IPASS.EQ.1 .AND. OFILES(2) .EQ. 0) THEN - WRITE = INXOUT.EQ.'WRITE' - ELSE - IF ( WRITE .AND. INXOUT.EQ.'READ' ) THEN - WRITE (NDSE,901) INXOUT - CALL EXTCDE ( 2 ) - END IF + IF (NK.NE.MK .OR. NTH.NE.MTH) THEN + WRITE (NDSE,904) MK, MTH, NK, NTH + CALL EXTCDE ( 12 ) END IF -! -! open file ---------------------------------------------------------- * -! - IF ( IPASS.EQ.1 .AND. OFILES(2) .EQ. 0 ) THEN -! - I = LEN_TRIM(FILEXT) - J = LEN_TRIM(FNMPRE) -! + IF ( .NOT. O2INIT ) & + CALL W3DMO2 ( IGRD, NDSE, NDST, NOPTS ) + END IF + ! #ifdef W3_T - WRITE (NDST,9001) FNMPRE(:J)//'out_pnt.'//FILEXT(:I) + WRITE (NDST,9002) IDSTR, VEROPT, NK, NTH, NOPTS #endif - IF ( WRITE ) THEN - OPEN (NDSOP,FILE=FNMPRE(:J)//'out_pnt.'//FILEXT(:I), & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) - ELSE - OPEN (NDSOP,FILE=FNMPRE(:J)//'out_pnt.'//FILEXT(:I), & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR,STATUS='OLD') - END IF -! - REWIND ( NDSOP ) -! -! test info ---------------------------------------------------------- * -! ( IPASS = 1 ) -! - IF ( WRITE ) THEN - WRITE (NDSOP) & - IDSTR, VEROPT, NK, NTH, NOPTS - ELSE - READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & - IDTST, VERTST, MK, MTH, NOPTS -! - IF ( IDTST .NE. IDSTR ) THEN - WRITE (NDSE,902) IDTST, IDSTR - CALL EXTCDE ( 10 ) - END IF - IF ( VERTST .NE. VEROPT ) THEN - WRITE (NDSE,903) VERTST, VEROPT - CALL EXTCDE ( 11 ) - END IF - IF (NK.NE.MK .OR. NTH.NE.MTH) THEN - WRITE (NDSE,904) MK, MTH, NK, NTH - CALL EXTCDE ( 12 ) - END IF - IF ( .NOT. O2INIT ) & - CALL W3DMO2 ( IGRD, NDSE, NDST, NOPTS ) - END IF -! -#ifdef W3_T - WRITE (NDST,9002) IDSTR, VEROPT, NK, NTH, NOPTS -#endif -! -! Point specific info ------------------------------------------------ * -! ( IPASS = 1 ) -! - IF ( WRITE ) THEN - WRITE (NDSOP) & - ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS) - ELSE - READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & - ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS) - END IF -! + ! + ! Point specific info ------------------------------------------------ * + ! ( IPASS = 1 ) + ! + IF ( WRITE ) THEN + WRITE (NDSOP) & + ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS) + ELSE + READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & + ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS) + END IF + ! #ifdef W3_T - WRITE (NDST,9003) - DO I=1, NOPTS - WRITE (NDST,9004) I, PTLOC(1,I), PTLOC(2,I), PTNME(I) - END DO -#endif -! - END IF -! -! - IF ( IPASS.GE. 1 .AND. OFILES(2) .EQ. 1) THEN - WRITE = INXOUT.EQ.'WRITE' - ELSE - IF ( WRITE .AND. INXOUT.EQ.'READ' ) THEN - WRITE (NDSE,901) INXOUT - CALL EXTCDE ( 2 ) - END IF - END IF + WRITE (NDST,9003) + DO I=1, NOPTS + WRITE (NDST,9004) I, PTLOC(1,I), PTLOC(2,I), PTNME(I) + END DO +#endif + ! + END IF + ! + ! + IF ( IPASS.GE. 1 .AND. OFILES(2) .EQ. 1) THEN + WRITE = INXOUT.EQ.'WRITE' + ELSE + IF ( WRITE .AND. INXOUT.EQ.'READ' ) THEN + WRITE (NDSE,901) INXOUT + CALL EXTCDE ( 2 ) + END IF + END IF -! open file ---------------------------------------------------------- * -! - IF ( IPASS.GE.1 .AND. OFILES(2) .EQ. 1) THEN -! - I = LEN_TRIM(FILEXT) - J = LEN_TRIM(FNMPRE) + ! open file ---------------------------------------------------------- * + ! + IF ( IPASS.GE.1 .AND. OFILES(2) .EQ. 1) THEN + ! + I = LEN_TRIM(FILEXT) + J = LEN_TRIM(FNMPRE) -! Create TIMETAG for file name using YYYYMMDD.HHMMS prefix - WRITE(TIMETAG,"(i8.8,'.'i6.6)")TIME(1),TIME(2) -! + ! Create TIMETAG for file name using YYYYMMDD.HHMMS prefix + WRITE(TIMETAG,"(i8.8,'.'i6.6)")TIME(1),TIME(2) + ! #ifdef W3_T - WRITE (NDST,9001) FNMPRE(:J)//TIMETAG//'.out_pnt.'// & - FILEXT(:I) + WRITE (NDST,9001) FNMPRE(:J)//TIMETAG//'.out_pnt.'// & + FILEXT(:I) #endif - IF ( WRITE ) THEN - OPEN (NDSOP,FILE=FNMPRE(:J)//TIMETAG//'.out_pnt.' & - //FILEXT(:I),form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) - END IF -! - REWIND ( NDSOP ) -! -! -! test info ---------------------------------------------------------- * -! ( IPASS GE.1 .AND. OFILES(2) .EQ. 1) -! - IF ( WRITE ) THEN - WRITE (NDSOP) & - IDSTR, VEROPT, NK, NTH, NOPTS - ELSE - READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & - IDTST, VERTST, MK, MTH, NOPTS -! - IF ( IDTST .NE. IDSTR ) THEN - WRITE (NDSE,902) IDTST, IDSTR - CALL EXTCDE ( 10 ) - END IF - IF ( VERTST .NE. VEROPT ) THEN - WRITE (NDSE,903) VERTST, VEROPT - CALL EXTCDE ( 11 ) - END IF - IF (NK.NE.MK .OR. NTH.NE.MTH) THEN - WRITE (NDSE,904) MK, MTH, NK, NTH - CALL EXTCDE ( 12 ) - END IF - IF ( .NOT. O2INIT ) & - CALL W3DMO2 ( IGRD, NDSE, NDST, NOPTS ) - END IF -! -#ifdef W3_T - WRITE (NDST,9002) IDSTR, VEROPT, NK, NTH, NOPTS -#endif -! -! Point specific info ------------------------------------------------ * -! ( IPASS GE.1 .AND. OFILES(2) .EQ. 1) -! - IF ( WRITE ) THEN - WRITE (NDSOP) & - ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS) - ELSE - READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & - ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS) - END IF -! -#ifdef W3_T - WRITE (NDST,9003) - DO I=1, NOPTS - WRITE (NDST,9004) I, PTLOC(1,I), PTLOC(2,I), PTNME(I) - END DO -#endif -! - END IF -! -! -! TIME --------------------------------------------------------------- * -! IF ( WRITE ) THEN - WRITE (NDSOP) TIME - ELSE - READ (NDSOP,END=803,ERR=802,IOSTAT=IERR) TIME + OPEN (NDSOP,FILE=FNMPRE(:J)//TIMETAG//'.out_pnt.' & + //FILEXT(:I),form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) + END IF + ! + REWIND ( NDSOP ) + ! + ! + ! test info ---------------------------------------------------------- * + ! ( IPASS GE.1 .AND. OFILES(2) .EQ. 1) + ! + IF ( WRITE ) THEN + WRITE (NDSOP) & + IDSTR, VEROPT, NK, NTH, NOPTS + ELSE + READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & + IDTST, VERTST, MK, MTH, NOPTS + ! + IF ( IDTST .NE. IDSTR ) THEN + WRITE (NDSE,902) IDTST, IDSTR + CALL EXTCDE ( 10 ) + END IF + IF ( VERTST .NE. VEROPT ) THEN + WRITE (NDSE,903) VERTST, VEROPT + CALL EXTCDE ( 11 ) END IF -! + IF (NK.NE.MK .OR. NTH.NE.MTH) THEN + WRITE (NDSE,904) MK, MTH, NK, NTH + CALL EXTCDE ( 12 ) + END IF + IF ( .NOT. O2INIT ) & + CALL W3DMO2 ( IGRD, NDSE, NDST, NOPTS ) + END IF + ! #ifdef W3_T - WRITE (NDST,9010) TIME + WRITE (NDST,9002) IDSTR, VEROPT, NK, NTH, NOPTS #endif -! -! -! Loop over spectra -------------------------------------------------- * -! + ! + ! Point specific info ------------------------------------------------ * + ! ( IPASS GE.1 .AND. OFILES(2) .EQ. 1) + ! + IF ( WRITE ) THEN + WRITE (NDSOP) & + ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS) + ELSE + READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & + ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS) + END IF + ! +#ifdef W3_T + WRITE (NDST,9003) DO I=1, NOPTS -! - IF ( WRITE ) THEN - ! set IW, II and IL to 0 because it is not used and gives & - ! outlier values in out_pnt.points - IW(I) = 0 - II(I) = 0 - IL(I) = 0 - WRITE (NDSOP) & - IW(I), II(I), IL(I), DPO(I), WAO(I), WDO(I), & + WRITE (NDST,9004) I, PTLOC(1,I), PTLOC(2,I), PTNME(I) + END DO +#endif + ! + END IF + ! + ! + ! TIME --------------------------------------------------------------- * + ! + IF ( WRITE ) THEN + WRITE (NDSOP) TIME + ELSE + READ (NDSOP,END=803,ERR=802,IOSTAT=IERR) TIME + END IF + ! +#ifdef W3_T + WRITE (NDST,9010) TIME +#endif + ! + ! + ! Loop over spectra -------------------------------------------------- * + ! + DO I=1, NOPTS + ! + IF ( WRITE ) THEN + ! set IW, II and IL to 0 because it is not used and gives & + ! outlier values in out_pnt.points + IW(I) = 0 + II(I) = 0 + IL(I) = 0 + WRITE (NDSOP) & + IW(I), II(I), IL(I), DPO(I), WAO(I), WDO(I), & #ifdef W3_FLX5 - TAUAO(I), TAUDO(I), DAIRO(I), & + TAUAO(I), TAUDO(I), DAIRO(I), & #endif #ifdef W3_SETUP ZET_SETO(I), & #endif - ASO(I), CAO(I), CDO(I), ICEO(I), ICEHO(I), & - ICEFO(I), GRDID(I), (SPCO(J,I),J=1,NSPEC) - ELSE - READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & - IW(I), II(I), IL(I), DPO(I), WAO(I), WDO(I), & + ASO(I), CAO(I), CDO(I), ICEO(I), ICEHO(I), & + ICEFO(I), GRDID(I), (SPCO(J,I),J=1,NSPEC) + ELSE + READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & + IW(I), II(I), IL(I), DPO(I), WAO(I), WDO(I), & #ifdef W3_FLX5 - TAUAO(I), TAUDO(I), DAIRO(I), & + TAUAO(I), TAUDO(I), DAIRO(I), & #endif #ifdef W3_SETUP ZET_SETO(I), & #endif - ASO(I), CAO(I), CDO(I), ICEO(I), ICEHO(I), & - ICEFO(I), GRDID(I), (SPCO(J,I),J=1,NSPEC) - END IF -! - END DO - IF (OFILES(2) .EQ. 1) CLOSE (NDSOP) -! - RETURN -! -! Escape locations read errors -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 20 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 21 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 22 ) -! - 803 CONTINUE - IOTST = -1 + ASO(I), CAO(I), CDO(I), ICEO(I), ICEHO(I), & + ICEFO(I), GRDID(I), (SPCO(J,I),J=1,NSPEC) + END IF + ! + END DO + IF (OFILES(2) .EQ. 1) CLOSE (NDSOP) + ! + RETURN + ! + ! Escape locations read errors + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 20 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 21 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 22 ) + ! +803 CONTINUE + IOTST = -1 #ifdef W3_T - WRITE (NDST,9011) -#endif - RETURN -! -! Formats -! - 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/ & - ' ILEGAL INXOUT VALUE: ',A/) - 901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/ & - ' MIXED READ/WRITE, LAST REQUEST: ',A/) - 902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/ & - ' ILEGAL IDSTR, READ : ',A/ & - ' CHECK : ',A/) - 903 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/ & - ' ILEGAL VEROPT, READ : ',A/ & - ' CHECK : ',A/) - 904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/ & - ' ERROR IN SPECTRA, MK, MTH : ',2I8/ & - ' ARRAY DIMENSIONS : ',2I8/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO : '/ & - ' ERROR IN OPENING FILE'/ & - ' IOSTAT =',I5/) - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO : '/ & - ' PREMATURE END OF FILE'/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO : '/ & - ' ERROR IN READING FROM FILE'/ & - ' IOSTAT =',I5/) -! + WRITE (NDST,9011) +#endif + RETURN + ! + ! Formats + ! +900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/ & + ' ILEGAL INXOUT VALUE: ',A/) +901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/ & + ' MIXED READ/WRITE, LAST REQUEST: ',A/) +902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/ & + ' ILEGAL IDSTR, READ : ',A/ & + ' CHECK : ',A/) +903 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/ & + ' ILEGAL VEROPT, READ : ',A/ & + ' CHECK : ',A/) +904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/ & + ' ERROR IN SPECTRA, MK, MTH : ',2I8/ & + ' ARRAY DIMENSIONS : ',2I8/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO : '/ & + ' ERROR IN OPENING FILE'/ & + ' IOSTAT =',I5/) +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO : '/ & + ' PREMATURE END OF FILE'/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO : '/ & + ' ERROR IN READING FROM FILE'/ & + ' IOSTAT =',I5/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3IOPO : IPASS =',I4,' INXOUT = ',A, & - ' WRITE = ',L1,' UNIT =',I3/ & - ' IGRD =',I3,' FEXT = ',A) -#endif +9000 FORMAT (' TEST W3IOPO : IPASS =',I4,' INXOUT = ',A, & + ' WRITE = ',L1,' UNIT =',I3/ & + ' IGRD =',I3,' FEXT = ',A) -#ifdef W3_T - 9001 FORMAT (' TEST W3IOPO : OPENING NEW FILE [',A,']') - 9002 FORMAT (' TEST W3IOPO : TEST PARAMETERS:'/ & - ' IDSTR : ',A/ & - ' VEROPT : ',A/ & - ' NK,NTH :',I5,I8/ & - ' NOPT :',I5) - 9003 FORMAT (' TEST W3IOPO : POINT LOCATION AND ID') - 9004 FORMAT (3X,I4,2F10.2,2X,A) -#endif -! -#ifdef W3_T - 9010 FORMAT (' TEST W3IOPO : TIME :',I9.8,I7.6) - 9011 FORMAT (' TEST W3IOPO : END OF FILE REACHED') -#endif -! -#ifdef W3_T - 9020 FORMAT (' TEST W3IOPO : POINT NR.:',I5) - 9021 FORMAT (' TEST W3IOPO :',2I4,2F6.3) - 9022 FORMAT (' TEST W3IOPO :',4I7,2X,4I2,2X,4F5.2) - 9030 FORMAT (' TEST W3IOPO :',F8.1,2(F7.2,F7.1)) -#endif -!/ -!/ End of W3IOPO ----------------------------------------------------- / -!/ - END SUBROUTINE W3IOPO -!/ -!/ End of module W3IOPOMD -------------------------------------------- / -!/ - END MODULE W3IOPOMD +9001 FORMAT (' TEST W3IOPO : OPENING NEW FILE [',A,']') +9002 FORMAT (' TEST W3IOPO : TEST PARAMETERS:'/ & + ' IDSTR : ',A/ & + ' VEROPT : ',A/ & + ' NK,NTH :',I5,I8/ & + ' NOPT :',I5) +9003 FORMAT (' TEST W3IOPO : POINT LOCATION AND ID') +9004 FORMAT (3X,I4,2F10.2,2X,A) + ! +9010 FORMAT (' TEST W3IOPO : TIME :',I9.8,I7.6) +9011 FORMAT (' TEST W3IOPO : END OF FILE REACHED') + ! +9020 FORMAT (' TEST W3IOPO : POINT NR.:',I5) +9021 FORMAT (' TEST W3IOPO :',2I4,2F6.3) +9022 FORMAT (' TEST W3IOPO :',4I7,2X,4I2,2X,4F5.2) +9030 FORMAT (' TEST W3IOPO :',F8.1,2(F7.2,F7.1)) +#endif + !/ + !/ End of W3IOPO ----------------------------------------------------- / + !/ + END SUBROUTINE W3IOPO + !/ + !/ End of module W3IOPOMD -------------------------------------------- / + !/ +END MODULE W3IOPOMD diff --git a/model/src/w3iorsmd.F90 b/model/src/w3iorsmd.F90 index c3d99d6d0..91ae5316c 100644 --- a/model/src/w3iorsmd.F90 +++ b/model/src/w3iorsmd.F90 @@ -1,514 +1,514 @@ !> @file !> @brief Read/write restart files. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / !> !> @brief Read/write restart files. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 !> - MODULE W3IORSMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 2003 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ See subroutine for update log. -!/ -! 1. Purpose : -! -! Read/write restart files. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! VERINI C*10 Private Restart file version number. -! IDSTR C*26 Private Restart file UD string. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3IORS Subr. Public Read/write restart files. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETO, W3SETG, W3SETW, W3DIMW -! Subr. W3xDATMD Manage data structures. -! STRACE Subr. W3SERVMD Subroutine tracing. (!/S) -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! MPI_STARTALL, MPI_WAITALL (!/MPI) -! Subr. MPI persistent communication routines -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! See also routine. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / +MODULE W3IORSMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 2003 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ See subroutine for update log. + !/ + ! 1. Purpose : + ! + ! Read/write restart files. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! VERINI C*10 Private Restart file version number. + ! IDSTR C*26 Private Restart file UD string. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3IORS Subr. Public Read/write restart files. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETO, W3SETG, W3SETW, W3DIMW + ! Subr. W3xDATMD Manage data structures. + ! STRACE Subr. W3SERVMD Subroutine tracing. (!/S) + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! MPI_STARTALL, MPI_WAITALL (!/MPI) + ! Subr. MPI persistent communication routines + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See also routine. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / !module default IMPLICIT NONE - PUBLIC -!/ - ! Add fields needed for OASIS coupling in restart - LOGICAL :: OARST -!/ -!/ Private parameter statements (ID strings) -!/ - CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERINI = '2021-05-28' - CHARACTER(LEN=26), PARAMETER, PRIVATE :: & - IDSTR = 'WAVEWATCH III RESTART FILE' -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Reads/writes restart files. -!> -!> @details -!> @verbatim -!> The file is opened within the routine, the name is pre-defined -!> and the unit number is given in the parameter list. The restart -!> file is written using UNFORMATTED write statements. The routine -!> generates new names when called more than once. File names are : -!> -!> restart000.FILEXT -!> restart001.FILEXT -!> restart002.FILEXT etc. -!> -!> Optionally, a second stream of restart files is generated given -!> a secondary stride definad by an additional start/end time line -!> triggered by an optional argument added to the end of the stan- -!> dard restart request line (a sixth argument flag set to T). File -!> names include a time-tag prefix: -!> -!> YYYYMMDD.HHMMSS.restart.FILEXT -!> -!> The file to be read thus always is unnumbered, whereas all -!> written files are automatically numbered. -!> @endverbatim -!> -!> @param[in] INXOUT Test string for read/write. -!> @param[inout] NDSR File unit number. -!> @param[in] DUMFPI Dummy values for FPIS for cold start. -!> @param[in] IMOD Optional grid number, defaults to 1. -!> @param[in] FLRSTRT A second request for restart files (optional TRUE). -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 12-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 27-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 30-Apr-2002 : Add ice for transparencies. ( version 2.20 ) -!/ 13-Nov-2002 : Add stress as vector. ( version 3.00 ) -!/ 19-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 09-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 24-Jun-2005 : Adding MAPST2. ( version 3.07 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 22-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) -!/ 21-Apr-2008 : Remove PGI bug internal files. ( version 3.14 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Output file name with 3 digit id. ( version 3.14 ) -!/ (W. E. Rogers, NRL) -!/ 14-Nov-2013 : Remove cold start init. UST(DIR). ( version 4.13 ) -!/ 31-May-2016 : Optimize restart file size for un- ( version 5.10 ) -!/ structured grid and restart read. -!/ (M. Ward, NCI, S. Zieger, BOM) -!/ 10-Mar-2017 : File access mode changed to 'STREAM'( version 6.02 ) -!/ (S. Zieger, BOM) -!/ 09-Aug-2017 : Bug fix for MPI restart read issue ( version 6.02 ) -!/ (T. Campbell, NRL) -!/ 05-Jun-2018 : Add PDLIB/TIMINGS/DEBUGIO ( version 6.04 ) -!/ DEBUGINIT/MPI -!/ 19-Dec-2019 : Optional second stream of ( version 7.00 ) -!/ restart files -!/ (Roberto Padilla-Hernandez & J.H. Alves) -!/ 25-Sep-2020 : Extra fields for coupled restart ( version 7.10 ) -!/ 22-Mar-2021 : Add new coupling fields in restart ( version 7.13 ) -!/ 18-May-2021 : Read by default all extra restart ( version 7.13 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Reads/writes restart files. -! -! 2. Method : -! -! The file is opened within the routine, the name is pre-defined -! and the unit number is given in the parameter list. The restart -! file is written using UNFORMATTED write statements. The routine -! generates new names when called more than once. File names are : -! -! restart000.FILEXT -! restart001.FILEXT -! restart002.FILEXT etc. -! -! Optionally, a second stream of restart files is generated given -! a secondary stride definad by an additional start/end time line -! triggered by an optional argument added to the end of the stan- -! dard restart request line (a sixth argument flag set to T). File -! names include a time-tag prefix: -! -! YYYYMMDD.HHMMSS.restart.FILEXT -! -! The file to be read thus always is unnumbered, whereas all -! written files are automatically numbered. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ' Reading of a restart file. -! 'HOT' Writing a full restart from the model. -! 'COLD' Writing a cold start file. -! 'WIND' Initialize fields using first wind -! field. -! 'CALM' Starting from calm conditions. -! NDSR Int. I/O File unit number. -! DUMFPI Real I Dummy values for FPIS for cold start. -! RSTYPE Int. O Type of input field, -! 0 : cold start, -! 1 : cold start with fetch-limited spectra, -! 2 : full restart, -! 3 : for writing file. -! 4 : starting from calm. -! IMOD Int. I Optional grid number, defaults to 1. -! FLRSTRT LOGIC I OTIONAL TRUE: A second request for restart files -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! WW3_STRT Prog. N/A Initial conditions program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! Tests on INXOUT, file status and on array dimensions. -! -! 7. Remarks : -! -! - MAPSTA is dumped as it contains information on inactive points. -! Note that the original MAPSTA is dumped in the model def. file -! for use in the initial conditions (and output) programs. -! - Note that MAPSTA and MAPST2 data is combinded in the file. -! - The depth is recalculated in a write to avoid floating point -! errors in W3STRT. -! - Fields and field info read by all, written by las processor -! only. -! - The MPP version of the model will perform a gather here to -! maximize hiding of communication with IO. -! -! 8. Structure : -! -! +---------------------------------------------------------------+ -! | initialisations | -! | test INXOUT | -! | open file | -! +---------------------------------------------------------------| -! | WRITE ? | -! | Y N | -! |-------------------------------|-------------------------------| -! | Write identifiers and | Write identifiers and | -! | dimensions. | dimensions. | -! | | Check ident. and dimensions. | -! +-------------------------------+-------------------------------| -! | Full restart ? | -! | Y N | -! |-------------------------------|-------------------------------| -! | read/write/test time | | -! +-------------------------------+-------------------------------| -! | WRITE ? | -! | Y N | -! |-------------------------------|-------------------------------| -! | TYPE = 'WIND' ? | TYPE = 'WIND' ? | -! | Y N | Y N | -! |---------------|---------------|---------------|---------------| -! | close file | write spectra | gen. fetch-l. | read spectra | -! | RETURN | | spectra. | | -! |---------------+---------------+---------------+---------------| -! | WRITE ? | -! | Y N | -! |-------------------------------|-------------------------------| -! | TYPE = 'FULL' ? | TYPE = 'FULL' ? | -! | Y N | Y N | -! |---------------|---------------|---------------|---------------| -! | write level & | ( prep. level | read level & | initalize l.& | -! | (ice) map & | for test | (ice) map.& | times | -! | times | output ) | times | ( no ice ) | -! +---------------+---------------+---------------+-------------- + -! -! 9. Switches : -! -! !/SEED Linear input / seeding option. -! !/LNx -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: W3SETG, W3SETREF, RSTYPE - USE W3ODATMD, ONLY: W3SETO - USE W3WDATMD, only: W3SETW, W3DIMW - USE W3ADATMD, ONLY: W3SETA, W3XETA, NSEALM - USE W3ADATMD, ONLY: CX, CY, HS, WLM, T0M1, T01, FP0, THM, CHARN,& - TAUWIX, TAUWIY, TWS, TAUOX, TAUOY, BHD, & - PHIOC, TUSX, TUSY, USSX, USSY, TAUICE, & - UBA, UBD, PHIBBL, TAUBBL, TAUOCX, TAUOCY, & - WNMEAN -!/ - USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, NSPEC, MAPSTA, MAPST2, & - GNAME, FILEXT, GTYPE, UNGTYPE - USE W3TRIAMD, ONLY: SET_UG_IOBP + PUBLIC + !/ + ! Add fields needed for OASIS coupling in restart + LOGICAL :: OARST + !/ + !/ Private parameter statements (ID strings) + !/ + CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERINI = '2021-05-28' + CHARACTER(LEN=26), PARAMETER, PRIVATE :: & + IDSTR = 'WAVEWATCH III RESTART FILE' + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Reads/writes restart files. + !> + !> @details + !> @verbatim + !> The file is opened within the routine, the name is pre-defined + !> and the unit number is given in the parameter list. The restart + !> file is written using UNFORMATTED write statements. The routine + !> generates new names when called more than once. File names are : + !> + !> restart000.FILEXT + !> restart001.FILEXT + !> restart002.FILEXT etc. + !> + !> Optionally, a second stream of restart files is generated given + !> a secondary stride definad by an additional start/end time line + !> triggered by an optional argument added to the end of the stan- + !> dard restart request line (a sixth argument flag set to T). File + !> names include a time-tag prefix: + !> + !> YYYYMMDD.HHMMSS.restart.FILEXT + !> + !> The file to be read thus always is unnumbered, whereas all + !> written files are automatically numbered. + !> @endverbatim + !> + !> @param[in] INXOUT Test string for read/write. + !> @param[inout] NDSR File unit number. + !> @param[in] DUMFPI Dummy values for FPIS for cold start. + !> @param[in] IMOD Optional grid number, defaults to 1. + !> @param[in] FLRSTRT A second request for restart files (optional TRUE). + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 12-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 27-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 30-Apr-2002 : Add ice for transparencies. ( version 2.20 ) + !/ 13-Nov-2002 : Add stress as vector. ( version 3.00 ) + !/ 19-Aug-2003 : Output server options added. ( version 3.04 ) + !/ 09-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 24-Jun-2005 : Adding MAPST2. ( version 3.07 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 22-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) + !/ 21-Apr-2008 : Remove PGI bug internal files. ( version 3.14 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Output file name with 3 digit id. ( version 3.14 ) + !/ (W. E. Rogers, NRL) + !/ 14-Nov-2013 : Remove cold start init. UST(DIR). ( version 4.13 ) + !/ 31-May-2016 : Optimize restart file size for un- ( version 5.10 ) + !/ structured grid and restart read. + !/ (M. Ward, NCI, S. Zieger, BOM) + !/ 10-Mar-2017 : File access mode changed to 'STREAM'( version 6.02 ) + !/ (S. Zieger, BOM) + !/ 09-Aug-2017 : Bug fix for MPI restart read issue ( version 6.02 ) + !/ (T. Campbell, NRL) + !/ 05-Jun-2018 : Add PDLIB/TIMINGS/DEBUGIO ( version 6.04 ) + !/ DEBUGINIT/MPI + !/ 19-Dec-2019 : Optional second stream of ( version 7.00 ) + !/ restart files + !/ (Roberto Padilla-Hernandez & J.H. Alves) + !/ 25-Sep-2020 : Extra fields for coupled restart ( version 7.10 ) + !/ 22-Mar-2021 : Add new coupling fields in restart ( version 7.13 ) + !/ 18-May-2021 : Read by default all extra restart ( version 7.13 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Reads/writes restart files. + ! + ! 2. Method : + ! + ! The file is opened within the routine, the name is pre-defined + ! and the unit number is given in the parameter list. The restart + ! file is written using UNFORMATTED write statements. The routine + ! generates new names when called more than once. File names are : + ! + ! restart000.FILEXT + ! restart001.FILEXT + ! restart002.FILEXT etc. + ! + ! Optionally, a second stream of restart files is generated given + ! a secondary stride definad by an additional start/end time line + ! triggered by an optional argument added to the end of the stan- + ! dard restart request line (a sixth argument flag set to T). File + ! names include a time-tag prefix: + ! + ! YYYYMMDD.HHMMSS.restart.FILEXT + ! + ! The file to be read thus always is unnumbered, whereas all + ! written files are automatically numbered. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'READ' Reading of a restart file. + ! 'HOT' Writing a full restart from the model. + ! 'COLD' Writing a cold start file. + ! 'WIND' Initialize fields using first wind + ! field. + ! 'CALM' Starting from calm conditions. + ! NDSR Int. I/O File unit number. + ! DUMFPI Real I Dummy values for FPIS for cold start. + ! RSTYPE Int. O Type of input field, + ! 0 : cold start, + ! 1 : cold start with fetch-limited spectra, + ! 2 : full restart, + ! 3 : for writing file. + ! 4 : starting from calm. + ! IMOD Int. I Optional grid number, defaults to 1. + ! FLRSTRT LOGIC I OTIONAL TRUE: A second request for restart files + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Wave model initialization routine. + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! WW3_STRT Prog. N/A Initial conditions program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! Tests on INXOUT, file status and on array dimensions. + ! + ! 7. Remarks : + ! + ! - MAPSTA is dumped as it contains information on inactive points. + ! Note that the original MAPSTA is dumped in the model def. file + ! for use in the initial conditions (and output) programs. + ! - Note that MAPSTA and MAPST2 data is combinded in the file. + ! - The depth is recalculated in a write to avoid floating point + ! errors in W3STRT. + ! - Fields and field info read by all, written by las processor + ! only. + ! - The MPP version of the model will perform a gather here to + ! maximize hiding of communication with IO. + ! + ! 8. Structure : + ! + ! +---------------------------------------------------------------+ + ! | initialisations | + ! | test INXOUT | + ! | open file | + ! +---------------------------------------------------------------| + ! | WRITE ? | + ! | Y N | + ! |-------------------------------|-------------------------------| + ! | Write identifiers and | Write identifiers and | + ! | dimensions. | dimensions. | + ! | | Check ident. and dimensions. | + ! +-------------------------------+-------------------------------| + ! | Full restart ? | + ! | Y N | + ! |-------------------------------|-------------------------------| + ! | read/write/test time | | + ! +-------------------------------+-------------------------------| + ! | WRITE ? | + ! | Y N | + ! |-------------------------------|-------------------------------| + ! | TYPE = 'WIND' ? | TYPE = 'WIND' ? | + ! | Y N | Y N | + ! |---------------|---------------|---------------|---------------| + ! | close file | write spectra | gen. fetch-l. | read spectra | + ! | RETURN | | spectra. | | + ! |---------------+---------------+---------------+---------------| + ! | WRITE ? | + ! | Y N | + ! |-------------------------------|-------------------------------| + ! | TYPE = 'FULL' ? | TYPE = 'FULL' ? | + ! | Y N | Y N | + ! |---------------|---------------|---------------|---------------| + ! | write level & | ( prep. level | read level & | initalize l.& | + ! | (ice) map & | for test | (ice) map.& | times | + ! | times | output ) | times | ( no ice ) | + ! +---------------+---------------+---------------+-------------- + + ! + ! 9. Switches : + ! + ! !/SEED Linear input / seeding option. + ! !/LNx + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: W3SETG, W3SETREF, RSTYPE + USE W3ODATMD, ONLY: W3SETO + USE W3WDATMD, only: W3SETW, W3DIMW + USE W3ADATMD, ONLY: W3SETA, W3XETA, NSEALM + USE W3ADATMD, ONLY: CX, CY, HS, WLM, T0M1, T01, FP0, THM, CHARN,& + TAUWIX, TAUWIY, TWS, TAUOX, TAUOY, BHD, & + PHIOC, TUSX, TUSY, USSX, USSY, TAUICE, & + UBA, UBD, PHIBBL, TAUBBL, TAUOCX, TAUOCY, & + WNMEAN + !/ + USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, NSPEC, MAPSTA, MAPST2, & + GNAME, FILEXT, GTYPE, UNGTYPE + USE W3TRIAMD, ONLY: SET_UG_IOBP USE W3WDATMD, only : DINIT, VA, TIME, TLEV, TICE, TRHO, ICE, UST USE W3WDATMD, only : USTDIR, ASF, FPIS, ICEF, TIC1, TIC5, WLV #ifdef W3_WRST - USE W3IDATMD, ONLY: WXN, WYN, W3SETI - USE W3IDATMD, ONLY: WXNwrst, WYNwrst + USE W3IDATMD, ONLY: WXN, WYN, W3SETI + USE W3IDATMD, ONLY: WXNwrst, WYNwrst #endif - USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPROC, NAPERR, NAPRST, & - IFILE => IFILE4, FNMPRE, NTPROC, IOSTYP, & - FLOGRR, NOGRP, NGRPP, SCREEN + USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPROC, NAPERR, NAPRST, & + IFILE => IFILE4, FNMPRE, NTPROC, IOSTYP, & + FLOGRR, NOGRP, NGRPP, SCREEN #ifdef W3_MPI - USE W3ODATMD, ONLY: NRQRS, NBLKRS, RSBLKS, IRQRS, IRQRSS, & - VAAUX - USE W3ADATMD, ONLY: MPI_COMM_WCMP + USE W3ODATMD, ONLY: NRQRS, NBLKRS, RSBLKS, IRQRS, IRQRSS, & + VAAUX + USE W3ADATMD, ONLY: MPI_COMM_WCMP #endif -!/ - USE W3SERVMD, ONLY: EXTCDE - USE CONSTANTS, only: LPDLIB, file_endian - USE W3PARALL, ONLY: INIT_GET_ISEA, INIT_GET_JSEA_ISPROC - USE W3GDATMD, ONLY: NK, NTH + !/ + USE W3SERVMD, ONLY: EXTCDE + USE CONSTANTS, only: LPDLIB, file_endian + USE W3PARALL, ONLY: INIT_GET_ISEA, INIT_GET_JSEA_ISPROC + USE W3GDATMD, ONLY: NK, NTH #ifdef W3_TIMINGS - USE W3PARALL, ONLY: PRINT_MY_TIME + USE W3PARALL, ONLY: PRINT_MY_TIME #endif - USE w3odatmd, ONLY : RUNTYPE, INITFILE + USE w3odatmd, ONLY : RUNTYPE, INITFILE #ifdef W3_PDLIB USE PDLIB_FIELD_VEC #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! use w3timemd, only: set_user_timestring use w3odatmd, only: use_user_restname, user_restfname, ndso -! + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER :: NDSR -! INTEGER, INTENT(IN) :: NDSR - INTEGER, INTENT(IN), OPTIONAL :: IMOD - REAL, INTENT(INOUT) :: DUMFPI - CHARACTER, INTENT(IN) :: INXOUT*(*) - LOGICAL, INTENT(IN),OPTIONAL :: FLRSTRT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, PARAMETER :: LRB = 4 -! - INTEGER :: IGRD, I, J, LRECL, NSIZE, IERR, & - NSEAT, MSPEC, TTIME(2), ISEA, JSEA, & - NREC, NPART, IPART, IX, IY, IXL, IP, & - NPRTX2, NPRTY2, IYL, ITMP - INTEGER, ALLOCATABLE :: MAPTMP(:,:) + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER :: NDSR + ! INTEGER, INTENT(IN) :: NDSR + INTEGER, INTENT(IN), OPTIONAL :: IMOD + REAL, INTENT(INOUT) :: DUMFPI + CHARACTER, INTENT(IN) :: INXOUT*(*) + LOGICAL, INTENT(IN),OPTIONAL :: FLRSTRT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, PARAMETER :: LRB = 4 + ! + INTEGER :: IGRD, I, J, LRECL, NSIZE, IERR, & + NSEAT, MSPEC, TTIME(2), ISEA, JSEA, & + NREC, NPART, IPART, IX, IY, IXL, IP, & + NPRTX2, NPRTY2, IYL, ITMP + INTEGER, ALLOCATABLE :: MAPTMP(:,:) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_MPI - INTEGER :: IERR_MPI, IH, IB, ISEA0, ISEAN, & - NRQ, NSEAL_MIN + INTEGER :: IERR_MPI, IH, IB, ISEA0, ISEAN, & + NRQ, NSEAL_MIN #endif - INTEGER(KIND=8) :: RPOS + INTEGER(KIND=8) :: RPOS #ifdef W3_MPI - INTEGER, ALLOCATABLE :: STAT1(:,:), STAT2(:,:) - REAL, ALLOCATABLE :: VGBUFF(:), VLBUFF(:) + INTEGER, ALLOCATABLE :: STAT1(:,:), STAT2(:,:) + REAL, ALLOCATABLE :: VGBUFF(:), VLBUFF(:) #endif - REAL(KIND=LRB), ALLOCATABLE :: WRITEBUFF(:), TMP(:), TMP2(:) + REAL(KIND=LRB), ALLOCATABLE :: WRITEBUFF(:), TMP(:), TMP2(:) - LOGICAL :: WRITE, IOSFLG - LOGICAL :: FLOGOA(NOGRP,NGRPP) - LOGICAL :: NDSROPN - CHARACTER(LEN=4) :: TYPE - CHARACTER(LEN=10) :: VERTST - CHARACTER(LEN=512) :: FNAME - CHARACTER(LEN=26) :: IDTST - CHARACTER(LEN=30) :: TNAME - CHARACTER(LEN=15) :: TIMETAG - character(len=16) :: user_timestring !YYYY-MM-DD-SSSSS - logical :: exists -!/ -!/ ------------------------------------------------------------------- / -!/ + LOGICAL :: WRITE, IOSFLG + LOGICAL :: FLOGOA(NOGRP,NGRPP) + LOGICAL :: NDSROPN + CHARACTER(LEN=4) :: TYPE + CHARACTER(LEN=10) :: VERTST + CHARACTER(LEN=512) :: FNAME + CHARACTER(LEN=26) :: IDTST + CHARACTER(LEN=30) :: TNAME + CHARACTER(LEN=15) :: TIMETAG + character(len=16) :: user_timestring !YYYY-MM-DD-SSSSS + logical :: exists + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3IORS') + CALL STRACE (IENT, 'W3IORS') #endif -! -! -! Constant NDSR for using mpiifort in ZEUS ... paralell runs crashing -! because compiler doesn't accept reciclyng of UNIT for FORMATTED or -! UNFORMATTED files in OPEN -! -! NDSR = 525 + ! + ! + ! Constant NDSR for using mpiifort in ZEUS ... paralell runs crashing + ! because compiler doesn't accept reciclyng of UNIT for FORMATTED or + ! UNFORMATTED files in OPEN + ! + ! NDSR = 525 - IOSFLG = IOSTYP .GT. 0 -! -! test parameter list input ------------------------------------------ * -! - IF ( PRESENT(IMOD) ) THEN - IGRD = IMOD - ELSE - IGRD = 1 - END IF -! - CALL W3SETO ( IGRD, NDSE, NDST ) - CALL W3SETG ( IGRD, NDSE, NDST ) - CALL W3SETW ( IGRD, NDSE, NDST ) + IOSFLG = IOSTYP .GT. 0 + ! + ! test parameter list input ------------------------------------------ * + ! + IF ( PRESENT(IMOD) ) THEN + IGRD = IMOD + ELSE + IGRD = 1 + END IF + ! + CALL W3SETO ( IGRD, NDSE, NDST ) + CALL W3SETG ( IGRD, NDSE, NDST ) + CALL W3SETW ( IGRD, NDSE, NDST ) #ifdef W3_WRST - CALL W3SETI ( IGRD, NDSE, NDST ) + CALL W3SETI ( IGRD, NDSE, NDST ) #endif -! - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'HOT' .AND. & - INXOUT.NE.'COLD' .AND. INXOUT.NE.'WIND' .AND. & - INXOUT.NE.'CALM' ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT - CALL EXTCDE ( 1 ) - END IF -! - WRITE = INXOUT .NE. 'READ' - IF ( INXOUT .EQ. 'HOT' ) THEN - TYPE = 'FULL' - ELSE - TYPE = INXOUT - END IF -! + ! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'HOT' .AND. & + INXOUT.NE.'COLD' .AND. INXOUT.NE.'WIND' .AND. & + INXOUT.NE.'CALM' ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT + CALL EXTCDE ( 1 ) + END IF + ! + WRITE = INXOUT .NE. 'READ' + IF ( INXOUT .EQ. 'HOT' ) THEN + TYPE = 'FULL' + ELSE + TYPE = INXOUT + END IF + ! #ifdef W3_T - WRITE (NDST,9000) INXOUT, WRITE, NTPROC, NAPROC, IAPROC, NAPRST + WRITE (NDST,9000) INXOUT, WRITE, NTPROC, NAPROC, IAPROC, NAPRST #endif -! -! initializations ---------------------------------------------------- * -! - IF ( .NOT.DINIT ) THEN - IF ( IAPROC .LE. NAPROC ) THEN - CALL W3DIMW ( IMOD, NDSE, NDST ) - ELSE - CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) - END IF - END IF -! - IF ( IAPROC .LE. NAPROC ) VA(:,0) = 0. -! - LRECL = MAX ( LRB*NSPEC , & - LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) - NSIZE = LRECL / LRB -! --- Allocate buffer array with zeros (used to -! fill bytes up to size LRECL). --- - ALLOCATE(WRITEBUFF(NSIZE)) - WRITEBUFF(:) = 0. -! -! Allocate memory to receive fields needed for coupling - IF (OARST) THEN - ALLOCATE(TMP(NSEA)) - ALLOCATE(TMP2(NSEA)) - ENDIF -! -! open file ---------------------------------------------------------- * -! + ! + ! initializations ---------------------------------------------------- * + ! + IF ( .NOT.DINIT ) THEN + IF ( IAPROC .LE. NAPROC ) THEN + CALL W3DIMW ( IMOD, NDSE, NDST ) + ELSE + CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) + END IF + END IF + ! + IF ( IAPROC .LE. NAPROC ) VA(:,0) = 0. + ! + LRECL = MAX ( LRB*NSPEC , & + LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) + NSIZE = LRECL / LRB + ! --- Allocate buffer array with zeros (used to + ! fill bytes up to size LRECL). --- + ALLOCATE(WRITEBUFF(NSIZE)) + WRITEBUFF(:) = 0. + ! + ! Allocate memory to receive fields needed for coupling + IF (OARST) THEN + ALLOCATE(TMP(NSEA)) + ALLOCATE(TMP2(NSEA)) + ENDIF + ! + ! open file ---------------------------------------------------------- * + ! if (use_user_restname) then - ierr = -99 - if (.not. write) then - if (runtype == 'initial') then - if (len_trim(initfile) == 0) then - ! no IC file, use startup option - goto 800 - else - ! IC file exists - use it - fname = trim(initfile) - end if + ierr = -99 + if (.not. write) then + if (runtype == 'initial') then + if (len_trim(initfile) == 0) then + ! no IC file, use startup option + goto 800 else - call set_user_timestring(time,user_timestring) - fname = trim(user_restfname)//trim(user_timestring) - inquire( file=trim(fname), exist=exists) - if (.not. exists) then - call extcde (60, msg="required initial/restart file " // trim(fname) // " does not exist") - end if + ! IC file exists - use it + fname = trim(initfile) end if - else + else call set_user_timestring(time,user_timestring) fname = trim(user_restfname)//trim(user_timestring) - end if - ! write out filename - if (iaproc == naprst) then - IF ( WRITE ) THEN - write (ndso,'(a)') 'WW3: writing restart file '//trim(fname) - else - write (ndso,'(a)') 'WW3: reading initial/restart file '//trim(fname) + inquire( file=trim(fname), exist=exists) + if (.not. exists) then + call extcde (60, msg="required initial/restart file " // trim(fname) // " does not exist") end if - end if - if ( write ) then - IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) & - open (ndsr,file=trim(fname), form='unformatted', convert=file_endian, & - ACCESS='STREAM',ERR=800,IOSTAT=IERR) + end if + else + call set_user_timestring(time,user_timestring) + fname = trim(user_restfname)//trim(user_timestring) + end if + ! write out filename + if (iaproc == naprst) then + IF ( WRITE ) THEN + write (ndso,'(a)') 'WW3: writing restart file '//trim(fname) + else + write (ndso,'(a)') 'WW3: reading initial/restart file '//trim(fname) + end if + end if + if ( write ) then + IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) & + open (ndsr,file=trim(fname), form='unformatted', convert=file_endian, & + ACCESS='STREAM',ERR=800,IOSTAT=IERR) ELSE ! READ - open (ndsr, file=trim(fname), form='unformatted', convert=file_endian, & - ACCESS='STREAM',ERR=800,IOSTAT=IERR, & - STATUS='OLD',ACTION='READ') - END IF + open (ndsr, file=trim(fname), form='unformatted', convert=file_endian, & + ACCESS='STREAM',ERR=800,IOSTAT=IERR, & + STATUS='OLD',ACTION='READ') + END IF else I = LEN_TRIM(FILEXT) J = LEN_TRIM(FNMPRE) -! -!CHECKPOINT RESTART FILE + ! + !CHECKPOINT RESTART FILE ITMP=0 IF ( PRESENT(FLRSTRT) ) THEN IF (FLRSTRT) THEN @@ -518,1037 +518,1004 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) END IF END IF IF(ITMP.NE.1)THEN ! FNAME is not set above, so do it here - IF ( IFILE.EQ.0 ) THEN - FNAME = 'restart.'//FILEXT(:I) - ELSE - FNAME = 'restartNNN.'//FILEXT(:I) - IF ( WRITE .AND. IAPROC.EQ.NAPRST ) & + IF ( IFILE.EQ.0 ) THEN + FNAME = 'restart.'//FILEXT(:I) + ELSE + FNAME = 'restartNNN.'//FILEXT(:I) + IF ( WRITE .AND. IAPROC.EQ.NAPRST ) & WRITE (FNAME(8:10),'(I3.3)') IFILE END IF END IF IFILE = IFILE + 1 -! + ! #ifdef W3_T - WRITE (NDST,9001) trim(FNAME), LRECL + WRITE (NDST,9001) trim(FNAME), LRECL #endif -! + ! IF(NDST.EQ.NDSR)THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE(NDSE,'(A,I8)')'UNIT NUMBERS OF RESTART FILE AND '& - //'TEST OUTPUT ARE THE SAME : ',NDST - CALL EXTCDE ( 15 ) + IF ( IAPROC .EQ. NAPERR ) & + WRITE(NDSE,'(A,I8)')'UNIT NUMBERS OF RESTART FILE AND '& + //'TEST OUTPUT ARE THE SAME : ',NDST + CALL EXTCDE ( 15 ) ENDIF IF ( WRITE ) THEN - IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) & - OPEN (NDSR,FILE=FNMPRE(:J)//trim(FNAME),form='UNFORMATTED', convert=file_endian, & - ACCESS='STREAM',ERR=800,IOSTAT=IERR) - ELSE - OPEN (NDSR,FILE=FNMPRE(:J)//trim(FNAME),form='UNFORMATTED', convert=file_endian, & - ACCESS='STREAM',ERR=800,IOSTAT=IERR, & - STATUS='OLD',ACTION='READ') - END IF + IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) & + OPEN (NDSR,FILE=FNMPRE(:J)//trim(FNAME),form='UNFORMATTED', convert=file_endian, & + ACCESS='STREAM',ERR=800,IOSTAT=IERR) + ELSE + OPEN (NDSR,FILE=FNMPRE(:J)//trim(FNAME),form='UNFORMATTED', convert=file_endian, & + ACCESS='STREAM',ERR=800,IOSTAT=IERR, & + STATUS='OLD',ACTION='READ') + END IF end if -! -! test info ---------------------------------------------------------- * -! - IF ( WRITE ) THEN -! - IF ( IAPROC .EQ. NAPRST ) THEN -! Because data has mixed data types we do not know how many -! bytes remain to fill up to LRECL. --- -! --- Make the entire record zero --- - WRITEBUFF(:) = 0. - WRITE (NDSR,POS=1) WRITEBUFF -! --- Replace zeros with data --- - WRITE (NDSR,POS=1) IDSTR, VERINI, GNAME, TYPE, NSEA, & - NSPEC, FLOGRR - END IF - RSTYPE = 3 -! - ELSE - READ (NDSR,POS=1,ERR=802,IOSTAT=IERR) & - IDTST, VERTST, TNAME, TYPE, NSEAT, MSPEC, FLOGOA -! - IF ( IDTST .NE. IDSTR ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,901) IDTST, IDSTR - CALL EXTCDE ( 10 ) - END IF - IF ( VERTST .NE. VERINI ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,902) VERTST, VERINI - CALL EXTCDE ( 11 ) - END IF - IF ( TNAME .NE. GNAME ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,903) TNAME, GNAME - END IF - IF (TYPE.NE.'FULL' .AND. TYPE.NE.'COLD' .AND. & - TYPE.NE.'WIND' .AND. TYPE.NE.'CALM' ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,904) TYPE - CALL EXTCDE ( 12 ) - END IF - IF (NSEAT.NE.NSEA .OR. NSPEC.NE.MSPEC) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) MSPEC, NSEAT, NSPEC, NSEA - CALL EXTCDE ( 13 ) - END IF - IF (TYPE.EQ.'FULL') THEN - RSTYPE = 2 - ELSE IF (TYPE.EQ.'WIND') THEN - RSTYPE = 1 - ELSE IF (TYPE.EQ.'CALM') THEN - RSTYPE = 4 - ELSE - RSTYPE = 0 - END IF + ! + ! test info ---------------------------------------------------------- * + ! + IF ( WRITE ) THEN + ! + IF ( IAPROC .EQ. NAPRST ) THEN + ! Because data has mixed data types we do not know how many + ! bytes remain to fill up to LRECL. --- + ! --- Make the entire record zero --- + WRITEBUFF(:) = 0. + WRITE (NDSR,POS=1) WRITEBUFF + ! --- Replace zeros with data --- + WRITE (NDSR,POS=1) IDSTR, VERINI, GNAME, TYPE, NSEA, & + NSPEC, FLOGRR + END IF + RSTYPE = 3 + ! + ELSE + READ (NDSR,POS=1,ERR=802,IOSTAT=IERR) & + IDTST, VERTST, TNAME, TYPE, NSEAT, MSPEC, FLOGOA + ! + IF ( IDTST .NE. IDSTR ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,901) IDTST, IDSTR + CALL EXTCDE ( 10 ) + END IF + IF ( VERTST .NE. VERINI ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,902) VERTST, VERINI + CALL EXTCDE ( 11 ) + END IF + IF ( TNAME .NE. GNAME ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,903) TNAME, GNAME + END IF + IF (TYPE.NE.'FULL' .AND. TYPE.NE.'COLD' .AND. & + TYPE.NE.'WIND' .AND. TYPE.NE.'CALM' ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,904) TYPE + CALL EXTCDE ( 12 ) + END IF + IF (NSEAT.NE.NSEA .OR. NSPEC.NE.MSPEC) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) MSPEC, NSEAT, NSPEC, NSEA + CALL EXTCDE ( 13 ) + END IF + IF (TYPE.EQ.'FULL') THEN + RSTYPE = 2 + ELSE IF (TYPE.EQ.'WIND') THEN + RSTYPE = 1 + ELSE IF (TYPE.EQ.'CALM') THEN + RSTYPE = 4 + ELSE + RSTYPE = 0 + END IF - IF (.NOT. WRITE .AND. OARST .AND. IAPROC .EQ. NAPROC) THEN - DO I=1, NOGRP - DO J=1, NGRPP - IF (FLOGRR(I,J) .AND. .NOT. FLOGOA(I,J)) THEN - WRITE(SCREEN,1000) I, J - ENDIF - ENDDO - ENDDO - ENDIF -! - END IF -! - 100 CONTINUE -! + IF (.NOT. WRITE .AND. OARST .AND. IAPROC .EQ. NAPROC) THEN + DO I=1, NOGRP + DO J=1, NGRPP + IF (FLOGRR(I,J) .AND. .NOT. FLOGOA(I,J)) THEN + WRITE(SCREEN,1000) I, J + ENDIF + ENDDO + ENDDO + ENDIF + ! + END IF + ! +100 CONTINUE + ! #ifdef W3_T - WRITE (NDST,9002) IDSTR, VERINI, GNAME, TYPE, & - NSEA, NSEAL, NSPEC + WRITE (NDST,9002) IDSTR, VERINI, GNAME, TYPE, & + NSEA, NSEAL, NSPEC #endif -! -! TIME if required --------------------------------------------------- * -! - IF (TYPE.EQ.'FULL') THEN - RPOS = 1_8 + LRECL*(2-1_8) - IF ( WRITE ) THEN - IF ( IAPROC .EQ. NAPRST ) THEN - WRITEBUFF(:) = 0. - WRITE (NDSR,POS=RPOS) WRITEBUFF - WRITE (NDSR,POS=RPOS) TIME - END IF - ELSE - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) TTIME + ! + ! TIME if required --------------------------------------------------- * + ! + IF (TYPE.EQ.'FULL') THEN + RPOS = 1_8 + LRECL*(2-1_8) + IF ( WRITE ) THEN + IF ( IAPROC .EQ. NAPRST ) THEN + WRITEBUFF(:) = 0. + WRITE (NDSR,POS=RPOS) WRITEBUFF + WRITE (NDSR,POS=RPOS) TIME + END IF + ELSE + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) TTIME #ifdef W3_CESMCOUPLED - if (runtype == 'branch' .or. runtype == 'continue') then - IF (TIME(1).NE.TTIME(1) .OR. TIME(2).NE.TTIME(2)) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,906) TTIME, TIME - CALL EXTCDE ( 20 ) - END IF - end if + if (runtype == 'branch' .or. runtype == 'continue') then + IF (TIME(1).NE.TTIME(1) .OR. TIME(2).NE.TTIME(2)) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,906) TTIME, TIME + CALL EXTCDE ( 20 ) + END IF + end if #else - IF (TIME(1).NE.TTIME(1) .OR. TIME(2).NE.TTIME(2)) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,906) TTIME, TIME - CALL EXTCDE ( 20 ) - END IF + IF (TIME(1).NE.TTIME(1) .OR. TIME(2).NE.TTIME(2)) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,906) TTIME, TIME + CALL EXTCDE ( 20 ) + END IF #endif - END IF -! + END IF + ! #ifdef W3_T - WRITE (NDST,9003) TIME - ELSE - WRITE (NDST,9004) + WRITE (NDST,9003) TIME + ELSE + WRITE (NDST,9004) #endif -! + ! + END IF + ! + ! Spectra ------------------------------------------------------------ * + ! ( Bail out if write for TYPE.EQ.'WIND' ) + ! + IF ( WRITE ) THEN + IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN + IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) THEN + CLOSE ( NDSR ) END IF -! -! Spectra ------------------------------------------------------------ * -! ( Bail out if write for TYPE.EQ.'WIND' ) -! - IF ( WRITE ) THEN - IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN - IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) THEN - CLOSE ( NDSR ) - END IF #ifdef W3_T - WRITE (NDST,9005) TYPE + WRITE (NDST,9005) TYPE #endif - ! Clean up file handles and allocated arrays - INQUIRE (UNIT=NDSR, OPENED=NDSROPN) - IF (NDSROPN) CLOSE(NDSR) - IF (ALLOCATED(WRITEBUFF)) DEALLOCATE(WRITEBUFF) - IF (ALLOCATED(TMP)) DEALLOCATE(TMP) - IF (ALLOCATED(TMP2)) DEALLOCATE(TMP2) + ! Clean up file handles and allocated arrays + INQUIRE (UNIT=NDSR, OPENED=NDSROPN) + IF (NDSROPN) CLOSE(NDSR) + IF (ALLOCATED(WRITEBUFF)) DEALLOCATE(WRITEBUFF) + IF (ALLOCATED(TMP)) DEALLOCATE(TMP) + IF (ALLOCATED(TMP2)) DEALLOCATE(TMP2) - RETURN - ELSE IF ( IAPROC.LE.NAPROC .OR. IAPROC.EQ. NAPRST ) THEN -! -! Original non-server version writing of spectra -! - IF ( .NOT.IOSFLG .OR. (NAPROC.EQ.1.AND.NAPRST.EQ.1) ) THEN - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - NREC = ISEA + 2 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITEBUFF(:) = 0. - WRITEBUFF(1:NSPEC) = VA(1:NSPEC,JSEA) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - END DO -! -! I/O server version writing of spectra ( !/MPI ) -! -#ifdef W3_MPI - ELSE -#endif -! + RETURN + ELSE IF ( IAPROC.LE.NAPROC .OR. IAPROC.EQ. NAPRST ) THEN + ! + ! Original non-server version writing of spectra + ! + IF ( .NOT.IOSFLG .OR. (NAPROC.EQ.1.AND.NAPRST.EQ.1) ) THEN + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + NREC = ISEA + 2 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITEBUFF(:) = 0. + WRITEBUFF(1:NSPEC) = VA(1:NSPEC,JSEA) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + END DO + ! + ! I/O server version writing of spectra ( !/MPI ) + ! #ifdef W3_MPI - IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN + ELSE + ! + IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before UNST_PDLIB_WRITE_TO_FILE") + CALL PRINT_MY_TIME("Before UNST_PDLIB_WRITE_TO_FILE") #endif #ifdef W3_PDLIB CALL UNST_PDLIB_WRITE_TO_FILE(NDSR) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After UNST_PDLIB_WRITE_TO_FILE") + CALL PRINT_MY_TIME("After UNST_PDLIB_WRITE_TO_FILE") #endif #ifdef W3_MPI - ELSE -#endif + ELSE -#ifdef W3_MPI - IF ( IAPROC .NE. NAPRST ) THEN - NRQ = 1 - ELSE IF ( NAPRST .LE. NAPROC ) THEN - NRQ = NAPROC - 1 - ELSE - NRQ = NAPROC - END IF -#endif -! -#ifdef W3_MPI - ALLOCATE ( STAT1(MPI_STATUS_SIZE,NRQ) ) - IF ( IAPROC .EQ. NAPRST ) CALL MPI_STARTALL & - ( NRQ, IRQRSS, IERR_MPI ) -#endif -! -#ifdef W3_MPI - DO IB=1, NBLKRS - ISEA0 = 1 + (IB-1)*RSBLKS*NAPROC - ISEAN = MIN ( NSEA , IB*RSBLKS*NAPROC ) -#endif -! -#ifdef W3_MPI - IF ( IAPROC .EQ. NAPRST ) THEN -#endif -! -#ifdef W3_MPI - IH = 1 + NRQ * (IB-1) - CALL MPI_WAITALL & - ( NRQ, IRQRSS(IH), STAT1, IERR_MPI ) - IF ( IB .LT. NBLKRS ) THEN - IH = 1 + NRQ * IB - CALL MPI_STARTALL & - ( NRQ, IRQRSS(IH), IERR_MPI ) - END IF -#endif -! -#ifdef W3_MPI - DO ISEA=ISEA0, ISEAN - NREC = ISEA + 2 - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, IP) - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITEBUFF(:) = 0. - IF ( IP .EQ. NAPRST ) THEN - WRITEBUFF(1:NSPEC) = VA(1:NSPEC,JSEA) - ELSE - JSEA = JSEA - 2*((IB-1)/2)*RSBLKS - WRITEBUFF(1:NSPEC) = VAAUX(1:NSPEC,JSEA,IP) - END IF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - WRITEBUFF - END DO -#endif -! -#ifdef W3_MPI - ELSE -#endif -! -#ifdef W3_MPI - CALL MPI_STARTALL & - ( 1, IRQRSS(IB), IERR_MPI ) - CALL MPI_WAITALL & - ( 1, IRQRSS(IB), STAT1, IERR_MPI ) -#endif -! -#ifdef W3_MPI - END IF - END DO -#endif -! -#ifdef W3_MPI - DEALLOCATE ( STAT1 ) + IF ( IAPROC .NE. NAPRST ) THEN + NRQ = 1 + ELSE IF ( NAPRST .LE. NAPROC ) THEN + NRQ = NAPROC - 1 + ELSE + NRQ = NAPROC + END IF + ! + ALLOCATE ( STAT1(MPI_STATUS_SIZE,NRQ) ) + IF ( IAPROC .EQ. NAPRST ) CALL MPI_STARTALL & + ( NRQ, IRQRSS, IERR_MPI ) + ! + DO IB=1, NBLKRS + ISEA0 = 1 + (IB-1)*RSBLKS*NAPROC + ISEAN = MIN ( NSEA , IB*RSBLKS*NAPROC ) + ! + IF ( IAPROC .EQ. NAPRST ) THEN + ! + IH = 1 + NRQ * (IB-1) + CALL MPI_WAITALL & + ( NRQ, IRQRSS(IH), STAT1, IERR_MPI ) + IF ( IB .LT. NBLKRS ) THEN + IH = 1 + NRQ * IB + CALL MPI_STARTALL & + ( NRQ, IRQRSS(IH), IERR_MPI ) END IF + ! + DO ISEA=ISEA0, ISEAN + NREC = ISEA + 2 + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, IP) + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITEBUFF(:) = 0. + IF ( IP .EQ. NAPRST ) THEN + WRITEBUFF(1:NSPEC) = VA(1:NSPEC,JSEA) + ELSE + JSEA = JSEA - 2*((IB-1)/2)*RSBLKS + WRITEBUFF(1:NSPEC) = VAAUX(1:NSPEC,JSEA,IP) + END IF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + WRITEBUFF + END DO + ! + ELSE + ! + CALL MPI_STARTALL & + ( 1, IRQRSS(IB), IERR_MPI ) + CALL MPI_WAITALL & + ( 1, IRQRSS(IB), STAT1, IERR_MPI ) + ! + END IF + END DO + ! + DEALLOCATE ( STAT1 ) + END IF #endif -! - END IF -! - END IF - ELSE -! -! Reading spectra -! - IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN + ! + END IF + ! + END IF + ELSE + ! + ! Reading spectra + ! + IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN #ifdef W3_T - WRITE (NDST,9020) TYPE + WRITE (NDST,9020) TYPE #endif - ELSE - IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN + ELSE + IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before UNST_PDLIB_READ_FROM_FILE") + CALL PRINT_MY_TIME("Before UNST_PDLIB_READ_FROM_FILE") #endif #ifdef W3_PDLIB - CALL UNST_PDLIB_READ_FROM_FILE(NDSR) + CALL UNST_PDLIB_READ_FROM_FILE(NDSR) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After UNST_PDLIB_READ_FROM_FILE") -#endif - ELSE -#ifdef W3_MPI - NSEAL_MIN = 1 + (NSEA-NAPROC)/NAPROC - IF ( NAPROC.GT.1 ) THEN -!/ ----------- Large number of small-sized record reads will tend ---- * -!/ to perform badly on most file systems. We read this part -!/ using streams and scatter the results using MPI. -!/ ( M. WARD, NCI ) -! -! Begin computational proc. only section ---------------- * - IF ( IAPROC.LE.NAPROC ) THEN -! -! Main loop --------------------------------------------- * - ALLOCATE( VGBUFF( NSIZE * NAPROC ) ) - ALLOCATE( VLBUFF( NSIZE ) ) -! - DO JSEA = 1, NSEAL_MIN -! Read NAPROC records into buffer VGBUFF. ------------- * - IF ( IAPROC .EQ. NAPROC ) THEN - RPOS = 1_8 + (2 + (JSEA - 1_8) * NAPROC) * LRECL - READ(NDSR, POS=RPOS,ERR=802,IOSTAT=IERR) VGBUFF(:) - ELSE - VGBUFF(:) = 0. - END IF -! Distribute one record to each rank. - CALL MPI_SCATTER(VGBUFF, NSIZE, MPI_REAL, & - VLBUFF, NSIZE, MPI_REAL, & - NAPROC-1, MPI_COMM_WCMP, IERR ) -! Transfer the spectral content of VLBUFF to VA. ------ * - VA(1:NSPEC,JSEA) = VLBUFF(1:NSPEC) - END DO -! -! Include remainder values (switch to record format) ---- * - JSEA = NSEAL_MIN + 1 - IF ( JSEA.EQ.NSEAL ) THEN - ISEA = IAPROC + (JSEA - 1) * NAPROC - NREC = ISEA + 2 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR, POS=RPOS, ERR=802, IOSTAT=IERR) & - (VA(I,JSEA), I=1,NSPEC) - END IF -! - DEALLOCATE( VGBUFF ) - DEALLOCATE( VLBUFF ) -! -! End computational proc. only section ------------------ * - END IF -! - ELSE + CALL PRINT_MY_TIME("After UNST_PDLIB_READ_FROM_FILE") #endif - VA = 0. - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - NREC = ISEA + 2 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (VA(I,JSEA),I=1,NSPEC) - ENDDO + ELSE #ifdef W3_MPI + NSEAL_MIN = 1 + (NSEA-NAPROC)/NAPROC + IF ( NAPROC.GT.1 ) THEN + !/ ----------- Large number of small-sized record reads will tend ---- * + !/ to perform badly on most file systems. We read this part + !/ using streams and scatter the results using MPI. + !/ ( M. WARD, NCI ) + ! + ! Begin computational proc. only section ---------------- * + IF ( IAPROC.LE.NAPROC ) THEN + ! + ! Main loop --------------------------------------------- * + ALLOCATE( VGBUFF( NSIZE * NAPROC ) ) + ALLOCATE( VLBUFF( NSIZE ) ) + ! + DO JSEA = 1, NSEAL_MIN + ! Read NAPROC records into buffer VGBUFF. ------------- * + IF ( IAPROC .EQ. NAPROC ) THEN + RPOS = 1_8 + (2 + (JSEA - 1_8) * NAPROC) * LRECL + READ(NDSR, POS=RPOS,ERR=802,IOSTAT=IERR) VGBUFF(:) + ELSE + VGBUFF(:) = 0. + END IF + ! Distribute one record to each rank. + CALL MPI_SCATTER(VGBUFF, NSIZE, MPI_REAL, & + VLBUFF, NSIZE, MPI_REAL, & + NAPROC-1, MPI_COMM_WCMP, IERR ) + ! Transfer the spectral content of VLBUFF to VA. ------ * + VA(1:NSPEC,JSEA) = VLBUFF(1:NSPEC) + END DO + ! + ! Include remainder values (switch to record format) ---- * + JSEA = NSEAL_MIN + 1 + IF ( JSEA.EQ.NSEAL ) THEN + ISEA = IAPROC + (JSEA - 1) * NAPROC + NREC = ISEA + 2 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR, POS=RPOS, ERR=802, IOSTAT=IERR) & + (VA(I,JSEA), I=1,NSPEC) + END IF + ! + DEALLOCATE( VGBUFF ) + DEALLOCATE( VLBUFF ) + ! + ! End computational proc. only section ------------------ * END IF + ! + ELSE #endif - END IF + VA = 0. + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + NREC = ISEA + 2 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (VA(I,JSEA),I=1,NSPEC) + ENDDO +#ifdef W3_MPI END IF +#endif END IF + END IF + END IF - VA = MAX(0.,VA) -! + VA = MAX(0.,VA) + ! #ifdef W3_T - WRITE (NDST,9006) + WRITE (NDST,9006) #endif -! -! Water level etc. if required --------------------------------------- * -! ( For cold start write test output and cold start initialize -! water levels. Note that MAPSTA overwrites the one read from the -! model definition file, so that it need not be initialized. ) -! - NREC = NSEA + 3 - NPART = 1 + (NSEA-1)/NSIZE - NPRTX2 = 1 + (NX-1)/NSIZE - NPRTY2 = 1 + (NY-1)/NSIZE -! - IF ( WRITE ) THEN -! - IF (TYPE.EQ.'FULL') THEN -! - IF ( IAPROC .EQ. NAPRST ) THEN -! + ! + ! Water level etc. if required --------------------------------------- * + ! ( For cold start write test output and cold start initialize + ! water levels. Note that MAPSTA overwrites the one read from the + ! model definition file, so that it need not be initialized. ) + ! + NREC = NSEA + 3 + NPART = 1 + (NSEA-1)/NSIZE + NPRTX2 = 1 + (NX-1)/NSIZE + NPRTY2 = 1 + (NY-1)/NSIZE + ! + IF ( WRITE ) THEN + ! + IF (TYPE.EQ.'FULL') THEN + ! + IF ( IAPROC .EQ. NAPRST ) THEN + ! #ifdef W3_MPI - ALLOCATE ( STAT2(MPI_STATUS_SIZE,NRQRS) ) - CALL MPI_WAITALL & - ( NRQRS, IRQRS , STAT2, IERR_MPI ) - DEALLOCATE ( STAT2 ) + ALLOCATE ( STAT2(MPI_STATUS_SIZE,NRQRS) ) + CALL MPI_WAITALL & + ( NRQRS, IRQRS , STAT2, IERR_MPI ) + DEALLOCATE ( STAT2 ) #endif -! - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITEBUFF(:) = 0. - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - TLEV, TICE, TRHO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO + ! + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITEBUFF(:) = 0. + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + TLEV, TICE, TRHO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO #ifdef W3_WRST - ! The WRST switch saves the values of wind in the - ! restart file and then uses the wind for the first - ! time step here. This is needed when coupling with - ! an atm model that does not have 10m wind speeds at - ! initialization. If there is no restart, wind is zero + ! The WRST switch saves the values of wind in the + ! restart file and then uses the wind for the first + ! time step here. This is needed when coupling with + ! an atm model that does not have 10m wind speeds at + ! initialization. If there is no restart, wind is zero #endif #ifdef W3_WRST - DO IX=1, NX - DO IPART=1,NPRTY2 - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (WXN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & - MIN(NY,IPART*NSIZE)) - END DO - END DO - DO IX=1, NX - DO IPART=1,NPRTY2 - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (WYN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & - MIN(NY,IPART*NSIZE)) - END DO - END DO + DO IX=1, NX + DO IPART=1,NPRTY2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (WXN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO + DO IX=1, NX + DO IPART=1,NPRTY2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (WYN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO #endif - ALLOCATE ( MAPTMP(NY,NX) ) - MAPTMP = MAPSTA + 8*MAPST2 - DO IY=1, NY - DO IPART=1,NPRTX2 - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (MAPTMP(IY,IXL),IXL=1+(IPART-1)*NSIZE, & - MIN(NX,IPART*NSIZE)) - END DO - END DO - DEALLOCATE ( MAPTMP ) - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (UST(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (FPIS(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - IF (OARST) THEN + ALLOCATE ( MAPTMP(NY,NX) ) + MAPTMP = MAPSTA + 8*MAPST2 + DO IY=1, NY + DO IPART=1,NPRTX2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (MAPTMP(IY,IXL),IXL=1+(IPART-1)*NSIZE, & + MIN(NX,IPART*NSIZE)) + END DO + END DO + DEALLOCATE ( MAPTMP ) + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (UST(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (FPIS(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + IF (OARST) THEN #ifdef W3_MPI - CALL W3XETA ( IGRD, NDSE, NDST ) + CALL W3XETA ( IGRD, NDSE, NDST ) #endif -! - IF ( FLOGRR(1,2) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) CX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) CY(1:NSEA) - ENDIF - IF ( FLOGRR(1,12) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) ICEF(1:NSEA) - IF ( FLOGRR(2,1) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) HS(1:NSEA) - IF ( FLOGRR(2,2) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) WLM(1:NSEA) - IF ( FLOGRR(2,4) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) T0M1(1:NSEA) - IF ( FLOGRR(2,5) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) T01(1:NSEA) - IF ( FLOGRR(2,6) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) FP0(1:NSEA) - IF ( FLOGRR(2,7) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) THM(1:NSEA) - IF ( FLOGRR(2,19) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) WNMEAN(1:NSEA) - IF ( FLOGRR(5,2) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) CHARN(1:NSEA) - IF ( FLOGRR(5,5) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUWIX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUWIY(1:NSEA) - ENDIF - IF ( FLOGRR(5,11) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) TWS(1:NSEA) - IF ( FLOGRR(6,2) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOY(1:NSEA) - ENDIF - IF ( FLOGRR(6,3) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) BHD(1:NSEA) - IF ( FLOGRR(6,4) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) PHIOC(1:NSEA) - IF ( FLOGRR(6,5) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TUSX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TUSY(1:NSEA) - ENDIF - IF ( FLOGRR(6,6) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) USSX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) USSY(1:NSEA) - ENDIF - IF ( FLOGRR(6,10) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUICE(1:NSEA,1) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUICE(1:NSEA,2) - ENDIF - IF ( FLOGRR(6,13) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOCX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOCY(1:NSEA) - ENDIF - IF ( FLOGRR(7,2) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) UBA(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) UBD(1:NSEA) - ENDIF - IF ( FLOGRR(7,4) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) PHIBBL(1:NSEA) - IF ( FLOGRR(7,5) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUBBL(1:NSEA,1) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUBBL(1:NSEA,2) - ENDIF -! + ! + IF ( FLOGRR(1,2) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) CX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) CY(1:NSEA) + ENDIF + IF ( FLOGRR(1,12) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) ICEF(1:NSEA) + IF ( FLOGRR(2,1) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) HS(1:NSEA) + IF ( FLOGRR(2,2) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) WLM(1:NSEA) + IF ( FLOGRR(2,4) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) T0M1(1:NSEA) + IF ( FLOGRR(2,5) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) T01(1:NSEA) + IF ( FLOGRR(2,6) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) FP0(1:NSEA) + IF ( FLOGRR(2,7) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) THM(1:NSEA) + IF ( FLOGRR(2,19) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) WNMEAN(1:NSEA) + IF ( FLOGRR(5,2) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) CHARN(1:NSEA) + IF ( FLOGRR(5,5) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUWIX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUWIY(1:NSEA) + ENDIF + IF ( FLOGRR(5,11) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) TWS(1:NSEA) + IF ( FLOGRR(6,2) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOY(1:NSEA) + ENDIF + IF ( FLOGRR(6,3) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) BHD(1:NSEA) + IF ( FLOGRR(6,4) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) PHIOC(1:NSEA) + IF ( FLOGRR(6,5) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TUSX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TUSY(1:NSEA) + ENDIF + IF ( FLOGRR(6,6) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) USSX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) USSY(1:NSEA) + ENDIF + IF ( FLOGRR(6,10) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUICE(1:NSEA,1) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUICE(1:NSEA,2) + ENDIF + IF ( FLOGRR(6,13) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOCX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOCY(1:NSEA) + ENDIF + IF ( FLOGRR(7,2) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) UBA(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) UBD(1:NSEA) + ENDIF + IF ( FLOGRR(7,4) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) PHIBBL(1:NSEA) + IF ( FLOGRR(7,5) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUBBL(1:NSEA,1) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUBBL(1:NSEA,2) + ENDIF + ! #ifdef W3_MPI - CALL W3SETA ( IGRD, NDSE, NDST ) + CALL W3SETA ( IGRD, NDSE, NDST ) #endif - ENDIF + ENDIF #ifdef W3_T - WRITE (NDST,9007) - ELSE - DO ISEA=1, NSEA - WLV(ISEA) = 0. - ICE(ISEA) = 0. - END DO - WRITE (NDST,9008) + WRITE (NDST,9007) + ELSE + DO ISEA=1, NSEA + WLV(ISEA) = 0. + ICE(ISEA) = 0. + END DO + WRITE (NDST,9008) #endif - END IF - END IF - ELSE - IF (TYPE.EQ.'FULL') THEN - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - TLEV, TICE, TRHO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO + END IF + END IF + ELSE + IF (TYPE.EQ.'FULL') THEN + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + TLEV, TICE, TRHO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO #ifdef W3_WRST - DO IX=1, NX - DO IPART=1,NPRTY2 - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (WXNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & - MIN(NY,IPART*NSIZE)) - END DO - END DO - DO IX=1, NX - DO IPART=1,NPRTY2 - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (WYNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & - MIN(NY,IPART*NSIZE)) - END DO - END DO + DO IX=1, NX + DO IPART=1,NPRTY2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (WXNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO + DO IX=1, NX + DO IPART=1,NPRTY2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (WYNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO #endif - ALLOCATE ( MAPTMP(NY,NX) ) - DO IY=1, NY - DO IPART=1,NPRTX2 - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (MAPTMP(IY,IXL),IXL=1+(IPART-1)*NSIZE, & - MIN(NX,IPART*NSIZE)) - END DO - END DO - MAPSTA = MOD(MAPTMP+2,8) - 2 - MAPST2 = (MAPTMP-MAPSTA) / 8 - DEALLOCATE ( MAPTMP ) -! -! Updates reflections maps: -! - IF (GTYPE.EQ.UNGTYPE) THEN + ALLOCATE ( MAPTMP(NY,NX) ) + DO IY=1, NY + DO IPART=1,NPRTX2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (MAPTMP(IY,IXL),IXL=1+(IPART-1)*NSIZE, & + MIN(NX,IPART*NSIZE)) + END DO + END DO + MAPSTA = MOD(MAPTMP+2,8) - 2 + MAPST2 = (MAPTMP-MAPSTA) / 8 + DEALLOCATE ( MAPTMP ) + ! + ! Updates reflections maps: + ! + IF (GTYPE.EQ.UNGTYPE) THEN #ifdef W3_REF1 - ELSE - CALL W3SETREF + ELSE + CALL W3SETREF #endif - ENDIF -! - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (UST(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (FPIS(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - IF (OARST) THEN - IF ( FLOGOA(1,2) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) CX(1:NSEA) - READ (NDSR,ERR=802,IOSTAT=IERR) CY(1:NSEA) - ENDIF - IF ( FLOGOA(1,12) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) ICEF(1:NSEA) - ENDIF - IF ( FLOGOA(2,1) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) HS(I) = TMP(J) - ENDDO - ENDIF - IF ( FLOGOA(2,2) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) WLM(I) = TMP(J) - ENDDO - ENDIF - IF ( FLOGOA(2,4) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) T0M1(I) = TMP(J) - ENDDO - ENDIF - IF ( FLOGOA(2,5) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) T01(I) = TMP(J) - ENDDO - ENDIF - IF ( FLOGOA(2,6) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) FP0(I) = TMP(J) - ENDDO - ENDIF - IF ( FLOGOA(2,7) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THM(I) = TMP(J) - ENDDO - ENDIF - IF ( FLOGOA(2,19) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) WNMEAN(I) = TMP(J) - ENDDO - ENDIF - IF ( FLOGOA(5,2) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) CHARN(I) = TMP(J) - ENDDO - ENDIF - IF ( FLOGOA(5,5) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TAUWIX(I) = TMP(J) - TAUWIY(I) = TMP2(J) - ENDIF - ENDDO - ENDIF - IF ( FLOGOA(5,11) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) TWS(I) = TMP(J) - ENDDO - ENDIF - IF ( FLOGOA(6,2) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TAUOX(I) = TMP(J) - TAUOY(I) = TMP2(J) - ENDIF - ENDDO - ENDIF - IF ( FLOGOA(6,3) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) BHD(I) = TMP(J) - ENDDO - ENDIF - IF ( FLOGOA(6,4) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) PHIOC(I) = TMP(J) - ENDDO + ENDIF + ! + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (UST(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (FPIS(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + IF (OARST) THEN + IF ( FLOGOA(1,2) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) CX(1:NSEA) + READ (NDSR,ERR=802,IOSTAT=IERR) CY(1:NSEA) + ENDIF + IF ( FLOGOA(1,12) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) ICEF(1:NSEA) + ENDIF + IF ( FLOGOA(2,1) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) HS(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(2,2) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) WLM(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(2,4) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) T0M1(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(2,5) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) T01(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(2,6) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) FP0(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(2,7) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THM(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(2,19) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) WNMEAN(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(5,2) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) CHARN(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(5,5) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TAUWIX(I) = TMP(J) + TAUWIY(I) = TMP2(J) ENDIF - IF ( FLOGOA(6,5) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TUSX(I) = TMP(J) - TUSY(I) = TMP2(J) - ENDIF - ENDDO + ENDDO + ENDIF + IF ( FLOGOA(5,11) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) TWS(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(6,2) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TAUOX(I) = TMP(J) + TAUOY(I) = TMP2(J) ENDIF - IF ( FLOGOA(6,6) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - USSX(I) = TMP(J) - USSY(I) = TMP2(J) - ENDIF - ENDDO + ENDDO + ENDIF + IF ( FLOGOA(6,3) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) BHD(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(6,4) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) PHIOC(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(6,5) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TUSX(I) = TMP(J) + TUSY(I) = TMP2(J) ENDIF - IF ( FLOGOA(6,10) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TAUICE(I,1) = TMP(J) - TAUICE(I,2) = TMP2(J) - ENDIF - ENDDO + ENDDO + ENDIF + IF ( FLOGOA(6,6) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + USSX(I) = TMP(J) + USSY(I) = TMP2(J) ENDIF - IF ( FLOGOA(6,13) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TAUOCX(I) = TMP(J) - TAUOCY(I) = TMP2(J) - ENDIF - ENDDO + ENDDO + ENDIF + IF ( FLOGOA(6,10) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TAUICE(I,1) = TMP(J) + TAUICE(I,2) = TMP2(J) ENDIF - IF ( FLOGOA(7,2) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - UBA(I) = TMP(J) - UBD(I) = TMP2(J) - ENDIF - ENDDO + ENDDO + ENDIF + IF ( FLOGOA(6,13) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TAUOCX(I) = TMP(J) + TAUOCY(I) = TMP2(J) ENDIF - IF ( FLOGOA(7,4) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) PHIBBL(I) = TMP(J) - ENDDO + ENDDO + ENDIF + IF ( FLOGOA(7,2) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + UBA(I) = TMP(J) + UBD(I) = TMP2(J) ENDIF - IF ( FLOGOA(7,5) ) THEN - READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) - READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) - DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TAUBBL(I,1) = TMP(J) - TAUBBL(I,2) = TMP2(J) - ENDIF - ENDDO + ENDDO + ENDIF + IF ( FLOGOA(7,4) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) PHIBBL(I) = TMP(J) + ENDDO + ENDIF + IF ( FLOGOA(7,5) ) THEN + READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) + READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) + DO I=1, NSEALM + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TAUBBL(I,1) = TMP(J) + TAUBBL(I,2) = TMP2(J) ENDIF - ENDIF + ENDDO + ENDIF + ENDIF #ifdef W3_T - WRITE (NDST,9007) + WRITE (NDST,9007) #endif - ELSE - TLEV(1) = -1 - TLEV(2) = 0 - TICE(1) = -1 - TICE(2) = 0 - TRHO(1) = -1 - TIC1(1) = -1 - TIC1(2) = 0 - TIC5(1) = -1 - TIC5(2) = 0 + ELSE + TLEV(1) = -1 + TLEV(2) = 0 + TICE(1) = -1 + TICE(2) = 0 + TRHO(1) = -1 + TIC1(1) = -1 + TIC1(2) = 0 + TIC5(1) = -1 + TIC5(2) = 0 #ifdef W3_WRST - WXNwrst = 0. - WYNwrst = 0. + WXNwrst = 0. + WYNwrst = 0. #endif - WLV = 0. - ICE = 0. - ASF = 1. - FPIS = DUMFPI + WLV = 0. + ICE = 0. + ASF = 1. + FPIS = DUMFPI - ! Initialize coupled fields if no restart is present - IF (OARST) THEN - CX = 0. - CY = 0. - ICEF = 0. - HS = 0. - WLM = 0. - T0M1 = 0. - T01 = 0. - FP0 = 1. - THM = 0. - WNMEAN = 0. - CHARN = 0.0185 - TAUWIX = 0. - TAUWIY = 0. - TWS = 0. - TAUOX = 0. - TAUOY = 0. - BHD = 0. - PHIOC = 0. - TUSX = 0. - TUSY = 0. - USSX = 0. - USSY = 0. - TAUOCX = 0. - TAUOCY = 0. - TAUICE = 0. - UBA = 0. - UBD = 0. - PHIBBL = 0. - TAUBBL = 0. - ENDIF + ! Initialize coupled fields if no restart is present + IF (OARST) THEN + CX = 0. + CY = 0. + ICEF = 0. + HS = 0. + WLM = 0. + T0M1 = 0. + T01 = 0. + FP0 = 1. + THM = 0. + WNMEAN = 0. + CHARN = 0.0185 + TAUWIX = 0. + TAUWIY = 0. + TWS = 0. + TAUOX = 0. + TAUOY = 0. + BHD = 0. + PHIOC = 0. + TUSX = 0. + TUSY = 0. + USSX = 0. + USSY = 0. + TAUOCX = 0. + TAUOCY = 0. + TAUICE = 0. + UBA = 0. + UBD = 0. + PHIBBL = 0. + TAUBBL = 0. + ENDIF #ifdef W3_T - WRITE (NDST,9008) + WRITE (NDST,9008) #endif - END IF - END IF -! -! Close file --------------------------------------------------------- * -! - IF (WRITE) THEN + END IF + END IF + ! + ! Close file --------------------------------------------------------- * + ! + IF (WRITE) THEN IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) THEN CLOSE ( NDSR ) END IF - ELSE - CLOSE ( NDSR ) - END IF -! - IF (ALLOCATED(WRITEBUFF)) DEALLOCATE(WRITEBUFF) - IF (ALLOCATED(TMP)) DEALLOCATE(TMP) - IF (ALLOCATED(TMP2)) DEALLOCATE(TMP2) -! - RETURN -! -! Escape locations read errors : -! - 800 CONTINUE + ELSE + CLOSE ( NDSR ) + END IF + ! + IF (ALLOCATED(WRITEBUFF)) DEALLOCATE(WRITEBUFF) + IF (ALLOCATED(TMP)) DEALLOCATE(TMP) + IF (ALLOCATED(TMP2)) DEALLOCATE(TMP2) + ! + RETURN + ! + ! Escape locations read errors : + ! +800 CONTINUE #ifdef W3_LN0 - TYPE = 'WIND' - RSTYPE = 1 + TYPE = 'WIND' + RSTYPE = 1 #endif #ifdef W3_SEED - TYPE = 'CALM' - RSTYPE = 4 + TYPE = 'CALM' + RSTYPE = 4 #endif #ifdef W3_LN1 - TYPE = 'CALM' - RSTYPE = 4 + TYPE = 'CALM' + RSTYPE = 4 #endif - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,990) TYPE, IERR - GOTO 100 -! - 801 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,991) - CALL EXTCDE ( 30 ) -! - 802 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,992) IERR - CALL EXTCDE ( 31 ) -! - 803 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,993) IERR, RPOS - CALL EXTCDE ( 31 ) -! -! -! Formats -! - 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' ILLEGAL INXOUT VALUE: ',A/) - 901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' ILLEGAL IDSTR, READ : ',A/ & - ' CHECK : ',A/) - 902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' ILLEGAL VERINI, READ : ',A/ & - ' CHECK : ',A/) - 903 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS :'/ & - ' ILLEGAL GNAME, READ : ',A/ & - ' CHECK : ',A/) - 904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' ILLEGAL TYPE : ',A/) - 905 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' CONFLICTING NSPEC, NSEA GRID : ',2I8/ & - ' EXPECTED : ',2I8/) - 906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' CONFLICTING TIMES: FILE : ',I10.8,I8.6/ & - ' MODEL : ',I10.8,I8.6/) -! - 990 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS : '/ & - ' NO READABLE RESTART FILE, ', & - 'INITIALIZE WITH ''',A,''' INSTEAD'/ & - ' IOSTAT =',I5/) - 991 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & - ' PREMATURE END OF FILE'/) - 992 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & - ' ERROR IN READING FROM FILE'/ & - ' IOSTAT =',I5/) - 993 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & - ' ERROR IN WRITING TO FILE'/ & - ' IOSTAT =',I5,', POS =',I11 /) - 1000 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS : '/ & - ' REQUESTED EXTRA RESTART GROUP',I2,' FIELD',I2, / & - ' IS NOT PRESENT IN THE RESTART FILE.'/ & - ' THIS MAY CAUSE INSTABILITIES IN COUPLED CONFIGURATIONS') -! -! + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,990) TYPE, IERR + GOTO 100 + ! +801 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,991) + CALL EXTCDE ( 30 ) + ! +802 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,992) IERR + CALL EXTCDE ( 31 ) + ! +803 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,993) IERR, RPOS + CALL EXTCDE ( 31 ) + ! + ! + ! Formats + ! +900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' ILLEGAL INXOUT VALUE: ',A/) +901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' ILLEGAL IDSTR, READ : ',A/ & + ' CHECK : ',A/) +902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' ILLEGAL VERINI, READ : ',A/ & + ' CHECK : ',A/) +903 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS :'/ & + ' ILLEGAL GNAME, READ : ',A/ & + ' CHECK : ',A/) +904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' ILLEGAL TYPE : ',A/) +905 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' CONFLICTING NSPEC, NSEA GRID : ',2I8/ & + ' EXPECTED : ',2I8/) +906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' CONFLICTING TIMES: FILE : ',I10.8,I8.6/ & + ' MODEL : ',I10.8,I8.6/) + ! +990 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS : '/ & + ' NO READABLE RESTART FILE, ', & + 'INITIALIZE WITH ''',A,''' INSTEAD'/ & + ' IOSTAT =',I5/) +991 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & + ' PREMATURE END OF FILE'/) +992 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & + ' ERROR IN READING FROM FILE'/ & + ' IOSTAT =',I5/) +993 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & + ' ERROR IN WRITING TO FILE'/ & + ' IOSTAT =',I5,', POS =',I11 /) +1000 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS : '/ & + ' REQUESTED EXTRA RESTART GROUP',I2,' FIELD',I2, / & + ' IS NOT PRESENT IN THE RESTART FILE.'/ & + ' THIS MAY CAUSE INSTABILITIES IN COUPLED CONFIGURATIONS') + ! + ! #ifdef W3_T - 9000 FORMAT (' TEST W3IORS : TEST PARAMETERS :'/ & - ' INXOUT : ',A,/ & - ' WRITE : ',L10/ & - ' NTPROC : ',I10/ & - ' NAPROC : ',I10/ & - ' IAPROC : ',I10/ & - ' NAPRST : ',I10) - 9001 FORMAT (' FNAME : ',A/ & - ' LRECL : ',I10) - 9002 FORMAT (' IDSTR : ',A/ & - ' VERINI : ',A/ & - ' GNAME : ',A/ & - ' TYPE : ',A/ & - ' NSEA : ',I10/ & - ' NSEAL : ',I10/ & - ' NSPEC : ',I10) - 9003 FORMAT (' TEST W3IORS :',I10.8,I8.6,' UTC') - 9004 FORMAT (' TEST W3IORS : TIME NOT AVAILABLE ') - 9005 FORMAT (' TEST W3IORS : NO SPECTRA, TYPE=''',A,''' ') - 9006 FORMAT (' TEST W3IORS : SPECTRA PROCESSED ') - 9007 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED ') - 9008 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED (DUMMY)') +9000 FORMAT (' TEST W3IORS : TEST PARAMETERS :'/ & + ' INXOUT : ',A,/ & + ' WRITE : ',L10/ & + ' NTPROC : ',I10/ & + ' NAPROC : ',I10/ & + ' IAPROC : ',I10/ & + ' NAPRST : ',I10) +9001 FORMAT (' FNAME : ',A/ & + ' LRECL : ',I10) +9002 FORMAT (' IDSTR : ',A/ & + ' VERINI : ',A/ & + ' GNAME : ',A/ & + ' TYPE : ',A/ & + ' NSEA : ',I10/ & + ' NSEAL : ',I10/ & + ' NSPEC : ',I10) +9003 FORMAT (' TEST W3IORS :',I10.8,I8.6,' UTC') +9004 FORMAT (' TEST W3IORS : TIME NOT AVAILABLE ') +9005 FORMAT (' TEST W3IORS : NO SPECTRA, TYPE=''',A,''' ') +9006 FORMAT (' TEST W3IORS : SPECTRA PROCESSED ') +9007 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED ') +9008 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED (DUMMY)') + ! +9020 FORMAT (' TEST W3IORS : RSTYPE = ',A,', PERFORMED BY W3INIT') #endif -! -#ifdef W3_T - 9020 FORMAT (' TEST W3IORS : RSTYPE = ',A,', PERFORMED BY W3INIT') -#endif -!/ -!/ End of W3IORS ----------------------------------------------------- / -!/ - END SUBROUTINE W3IORS - - - - - - - - - -!/ -!/ End of module W3IORSMD -------------------------------------------- / -!/ - END MODULE W3IORSMD + !/ + !/ End of W3IORS ----------------------------------------------------- / + !/ + END SUBROUTINE W3IORS + !/ + !/ End of module W3IORSMD -------------------------------------------- / + !/ +END MODULE W3IORSMD diff --git a/model/src/w3iosfmd.F90 b/model/src/w3iosfmd.F90 index 75809698f..fa8d93cd1 100644 --- a/model/src/w3iosfmd.F90 +++ b/model/src/w3iosfmd.F90 @@ -1,773 +1,773 @@ !> @file !> @brief I/O and computational routines for the wave-field separation !> output. -!> +!> !> @author H. L. Tolman @date 25-Jul-2018 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / !> !> @brief I/O and computational routines for the wave-field separation !> output. -!> -!> @author H. L. Tolman @date 25-Jul-2018 -!> - MODULE W3IOSFMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-Jul-2018 | -!/ +-----------------------------------+ -!/ -!/ 27-Jun-2006 : Origination. ( version 3.09 ) -!/ 02-Nov-2006 : Origination W3CPRT and W3IOSF. ( version 3.10 ) -!/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Fix unitialized dtsiz in w3iosf. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Mar-2012 : Reparing test output under MPI. ( version 4.07 ) -!/ 08-Jun-2018 : use W3ADATMD, W3PARALL, INIT_GET_ISEA and -!/ INIT_GET_JSEA_ISPROC ( version 6.04 ) -!/ 25-Jul-2018 : Changed DIMXP size for partitioning ( version 6.05 ) -!/ methods 4 and 5. (C Bunney, UKMO) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! I/O and computational routines for the wave-field separation -! output. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! VERPRT C*10 Private Partition file version number. -! IDSTR C*35 Private Partition file ID string. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3CPRT Subr. Public Partition all requested local spectra. -! W3IOSF Subr. Public Processing and output of partitioned -! wave data. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3PART Subr. W3PARTMD Spectral partition for single spectrum. -! STRACE Sur. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! MPI_SEND, MPI_RECV -! MPI send and recieve routines -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Private parameter statements (ID strings) -!/ - CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERPRT = '2018-07-25' - CHARACTER(LEN=35), PARAMETER, PRIVATE :: & - IDSTR = 'WAVEWATCH III PARTITIONED DATA FILE' -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Partitioning of spectra into fields for all grid points that -!> are locally stored. -!> -!> @param[in] IMOD Grid number. !> !> @author H. L. Tolman @date 25-Jul-2018 -!> - SUBROUTINE W3CPRT ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-Jul-2018 ! -!/ +-----------------------------------+ -!/ -!/ 30-Oct-2006 : Origination. ( version 3.10 ) -!/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) -!/ 25-Jul-2018 : Changed DIMXP size for partitioning ( version 6.05 ) -!/ methods 4 and 5. (C Bunney, UKMO) -!/ -! 1. Purpose : -! -! Partitioning of spectra into fields for all grid points that -! are locally stored. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Grid number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3PART Subr. W3PARTMD Spectral partition for single spectrum. -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Although a sparse (IX,IY) grid is looked for, th major loop -! is still over NSEAL to simplify storage. -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS -! - USE W3PARTMD, ONLY: W3PART +!> +MODULE W3IOSFMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-Jul-2018 | + !/ +-----------------------------------+ + !/ + !/ 27-Jun-2006 : Origination. ( version 3.09 ) + !/ 02-Nov-2006 : Origination W3CPRT and W3IOSF. ( version 3.10 ) + !/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Fix unitialized dtsiz in w3iosf. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Mar-2012 : Reparing test output under MPI. ( version 4.07 ) + !/ 08-Jun-2018 : use W3ADATMD, W3PARALL, INIT_GET_ISEA and + !/ INIT_GET_JSEA_ISPROC ( version 6.04 ) + !/ 25-Jul-2018 : Changed DIMXP size for partitioning ( version 6.05 ) + !/ methods 4 and 5. (C Bunney, UKMO) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! I/O and computational routines for the wave-field separation + ! output. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! VERPRT C*10 Private Partition file version number. + ! IDSTR C*35 Private Partition file ID string. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3CPRT Subr. Public Partition all requested local spectra. + ! W3IOSF Subr. Public Processing and output of partitioned + ! wave data. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3PART Subr. W3PARTMD Spectral partition for single spectrum. + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! MPI_SEND, MPI_RECV + ! MPI send and recieve routines + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + !/ Private parameter statements (ID strings) + !/ + CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERPRT = '2018-07-25' + CHARACTER(LEN=35), PARAMETER, PRIVATE :: & + IDSTR = 'WAVEWATCH III PARTITIONED DATA FILE' + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Partitioning of spectra into fields for all grid points that + !> are locally stored. + !> + !> @param[in] IMOD Grid number. + !> + !> @author H. L. Tolman @date 25-Jul-2018 + !> + SUBROUTINE W3CPRT ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-Jul-2018 ! + !/ +-----------------------------------+ + !/ + !/ 30-Oct-2006 : Origination. ( version 3.10 ) + !/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) + !/ 25-Jul-2018 : Changed DIMXP size for partitioning ( version 6.05 ) + !/ methods 4 and 5. (C Bunney, UKMO) + !/ + ! 1. Purpose : + ! + ! Partitioning of spectra into fields for all grid points that + ! are locally stored. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Grid number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3PART Subr. W3PARTMD Spectral partition for single spectrum. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Although a sparse (IX,IY) grid is looked for, th major loop + ! is still over NSEAL to simplify storage. + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS + ! + USE W3PARTMD, ONLY: W3PART #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NSEA, NSEAL, MAPSF, MAPSTA, NK, NTH, SIG - USE W3ADATMD, ONLY: WN, CG, U10, U10D, DW - USE W3ODATMD, ONLY: IAPROC, NAPROC, OUTPTS, O6INIT, & - ICPRT, DTPRT, DIMP, PTMETH - USE W3WDATMD, ONLY: VA, ASF - USE W3ADATMD, ONLY: NSEALM - USE W3PARALL, ONLY: INIT_GET_ISEA, INIT_GET_JSEA_ISPROC + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY: NSEA, NSEAL, MAPSF, MAPSTA, NK, NTH, SIG + USE W3ADATMD, ONLY: WN, CG, U10, U10D, DW + USE W3ODATMD, ONLY: IAPROC, NAPROC, OUTPTS, O6INIT, & + ICPRT, DTPRT, DIMP, PTMETH + USE W3WDATMD, ONLY: VA, ASF + USE W3ADATMD, ONLY: NSEALM + USE W3PARALL, ONLY: INIT_GET_ISEA, INIT_GET_JSEA_ISPROC #ifdef W3_T - USE W3ODATMD, ONLY: NDST -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: DIMXP, JSEA, ISEA, IX, IY, & - IK, ITH, NP, TMPSIZ, OLDSIZ, FINSIZ - INTEGER, SAVE :: TSFAC = 7 + USE W3ODATMD, ONLY: NDST +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: DIMXP, JSEA, ISEA, IX, IY, & + IK, ITH, NP, TMPSIZ, OLDSIZ, FINSIZ + INTEGER, SAVE :: TSFAC = 7 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: UABS, UDIR, DEPTH, FACT, E2(NK,NTH) - REAL, ALLOCATABLE :: XP(:,:), TMP(:,:), TMP2(:,:) -!/ + REAL :: UABS, UDIR, DEPTH, FACT, E2(NK,NTH) + REAL, ALLOCATABLE :: XP(:,:), TMP(:,:), TMP2(:,:) + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3CPRT') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! - IF(PTMETH .EQ. 4 .OR. PTMETH .EQ. 5) THEN - ! Partitioning methods 4 and 5 only ever create 2 partitions - ! C. Bunney, 25-Jul-18 - DIMXP = 2 - ELSE - DIMXP = ((NK+1)/2) * ((NTH-1)/2) - ENDIF + CALL STRACE (IENT, 'W3CPRT') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! + IF(PTMETH .EQ. 4 .OR. PTMETH .EQ. 5) THEN + ! Partitioning methods 4 and 5 only ever create 2 partitions + ! C. Bunney, 25-Jul-18 + DIMXP = 2 + ELSE + DIMXP = ((NK+1)/2) * ((NTH-1)/2) + ENDIF - ALLOCATE ( XP(DIMP,0:DIMXP) ) -! - IF ( O6INIT ) THEN - DEALLOCATE ( OUTPTS(IMOD)%OUT6%DTPRT ) - ELSE - ALLOCATE ( OUTPTS(IMOD)%OUT6%ICPRT(NSEALM+1,2) ) - ICPRT => OUTPTS(IMOD)%OUT6%ICPRT - O6INIT = .TRUE. - END IF - ICPRT = 0 - ICPRT(1,2) = 1 -! - TMPSIZ = TSFAC * NSEAL - ALLOCATE ( TMP(DIMP,TMPSIZ) ) -! -#ifdef W3_T - WRITE (NDST,9000) DIMP, DIMXP, TMPSIZ -#endif -! -! -------------------------------------------------------------------- / -! 1. Loop over sea points -! - DO JSEA=1, NSEAL -! -! -------------------------------------------------------------------- / -! 2. Check need for processing -! - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - ICPRT(JSEA+1,2) = ICPRT(JSEA,2) -! - IF ( MAPSTA(IY,IX) .LT. 0 ) CYCLE -! -! -------------------------------------------------------------------- / -! 3. Prepare for partitioning -! - UABS = U10(ISEA)*ASF(ISEA) - UDIR = U10D(ISEA)*RADE - DEPTH = DW(ISEA) -! - DO IK=1, NK - FACT = TPI * SIG(IK) / CG(IK,ISEA) - DO ITH=1, NTH - E2(IK,ITH) = VA(ITH+(IK-1)*NTH,JSEA) * FACT - END DO - END DO -! -! -------------------------------------------------------------------- / -! 4. perform partitioning -! -!AR: NaN checks should results in immediate stop after trace ... - IF (DEPTH.NE.DEPTH) THEN - WRITE(6,*) 'IOSF:',ISEA,IX,IY,DW(ISEA),DEPTH - WRITE(*,*) 'FOUND NaN in depth' - STOP 'CRITICAL ERROR IN DEPTH ARRAY' - END IF - CALL W3PART ( E2, UABS, UDIR, DEPTH, WN(1:NK,ISEA), & - NP, XP, DIMXP ) -! -! -------------------------------------------------------------------- / -! 5. Store results (temp) -! - IF ( NP .GE. 0 ) THEN - ICPRT( JSEA ,1) = NP + 1 - ICPRT(JSEA+1,2) = ICPRT(JSEA,2) + NP + 1 -! - IF ( ICPRT(JSEA,2)+NP .GT. TMPSIZ ) THEN - ALLOCATE ( TMP2(DIMP,TMPSIZ) ) - TMP2 = TMP - DEALLOCATE ( TMP ) - OLDSIZ = TMPSIZ - TMPSIZ = TMPSIZ + MAX ( TSFAC*NSEAL , DIMXP ) - ALLOCATE ( TMP(DIMP,TMPSIZ) ) - TMP(:,1:OLDSIZ) = TMP2(:,1:OLDSIZ) - TMP(:,OLDSIZ+1:) = 0. - DEALLOCATE ( TMP2 ) + ALLOCATE ( XP(DIMP,0:DIMXP) ) + ! + IF ( O6INIT ) THEN + DEALLOCATE ( OUTPTS(IMOD)%OUT6%DTPRT ) + ELSE + ALLOCATE ( OUTPTS(IMOD)%OUT6%ICPRT(NSEALM+1,2) ) + ICPRT => OUTPTS(IMOD)%OUT6%ICPRT + O6INIT = .TRUE. + END IF + ICPRT = 0 + ICPRT(1,2) = 1 + ! + TMPSIZ = TSFAC * NSEAL + ALLOCATE ( TMP(DIMP,TMPSIZ) ) + ! #ifdef W3_T - WRITE (NDST,9050) JSEA, OLDSIZ, TMPSIZ -#endif - END IF -! - TMP(:,ICPRT(JSEA,2):ICPRT(JSEA,2)+NP) = XP(:,0:NP) -! - END IF -! -! -------------------------------------------------------------------- / -! 6. End of loop and clean up -! + WRITE (NDST,9000) DIMP, DIMXP, TMPSIZ +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Loop over sea points + ! + DO JSEA=1, NSEAL + ! + ! -------------------------------------------------------------------- / + ! 2. Check need for processing + ! + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + ICPRT(JSEA+1,2) = ICPRT(JSEA,2) + ! + IF ( MAPSTA(IY,IX) .LT. 0 ) CYCLE + ! + ! -------------------------------------------------------------------- / + ! 3. Prepare for partitioning + ! + UABS = U10(ISEA)*ASF(ISEA) + UDIR = U10D(ISEA)*RADE + DEPTH = DW(ISEA) + ! + DO IK=1, NK + FACT = TPI * SIG(IK) / CG(IK,ISEA) + DO ITH=1, NTH + E2(IK,ITH) = VA(ITH+(IK-1)*NTH,JSEA) * FACT END DO -! - FINSIZ = ICPRT(NSEAL+1,2) - 1 -! + END DO + ! + ! -------------------------------------------------------------------- / + ! 4. perform partitioning + ! + !AR: NaN checks should results in immediate stop after trace ... + IF (DEPTH.NE.DEPTH) THEN + WRITE(6,*) 'IOSF:',ISEA,IX,IY,DW(ISEA),DEPTH + WRITE(*,*) 'FOUND NaN in depth' + STOP 'CRITICAL ERROR IN DEPTH ARRAY' + END IF + CALL W3PART ( E2, UABS, UDIR, DEPTH, WN(1:NK,ISEA), & + NP, XP, DIMXP ) + ! + ! -------------------------------------------------------------------- / + ! 5. Store results (temp) + ! + IF ( NP .GE. 0 ) THEN + ICPRT( JSEA ,1) = NP + 1 + ICPRT(JSEA+1,2) = ICPRT(JSEA,2) + NP + 1 + ! + IF ( ICPRT(JSEA,2)+NP .GT. TMPSIZ ) THEN + ALLOCATE ( TMP2(DIMP,TMPSIZ) ) + TMP2 = TMP + DEALLOCATE ( TMP ) + OLDSIZ = TMPSIZ + TMPSIZ = TMPSIZ + MAX ( TSFAC*NSEAL , DIMXP ) + ALLOCATE ( TMP(DIMP,TMPSIZ) ) + TMP(:,1:OLDSIZ) = TMP2(:,1:OLDSIZ) + TMP(:,OLDSIZ+1:) = 0. + DEALLOCATE ( TMP2 ) #ifdef W3_T - WRITE (NDST,9060) - WRITE (NDST,9061) (CMPLX(JSEA,ICPRT(JSEA,:)),JSEA=1,MIN(100,NSEAL)) - WRITE (NDST,9062) FINSIZ -#endif -! - ALLOCATE ( OUTPTS(IMOD)%OUT6%DTPRT(DIMP,MAX(1,FINSIZ)) ) - DTPRT => OUTPTS(IMOD)%OUT6%DTPRT - IF ( FINSIZ .GT. 0 ) THEN - DTPRT = TMP(:,1:FINSIZ) - ELSE - DTPRT = 0. + WRITE (NDST,9050) JSEA, OLDSIZ, TMPSIZ +#endif END IF -! - DEALLOCATE ( XP, TMP ) -! - RETURN -! -! Formats -! + ! + TMP(:,ICPRT(JSEA,2):ICPRT(JSEA,2)+NP) = XP(:,0:NP) + ! + END IF + ! + ! -------------------------------------------------------------------- / + ! 6. End of loop and clean up + ! + END DO + ! + FINSIZ = ICPRT(NSEAL+1,2) - 1 + ! #ifdef W3_T - 9000 FORMAT (' TEST W3CPRT : DIMP, DIMXP, TMPSIZ :',I2,2I6) - 9050 FORMAT (' TEST W3CPRT : POINT',I4,', STORAGE',2I6) - 9060 FORMAT (' TEST W3CPRT : COUNTERS FOR STORAGE (JSEA,NP,ST):') - 9061 FORMAT (100(' ',5(2F9.0)/)) - 9062 FORMAT (' TEST W3CPRT : FINAL STORAGE SIZE :',I6) -#endif -!/ -!/ End of W3CPRT ----------------------------------------------------- / -!/ - END SUBROUTINE W3CPRT + WRITE (NDST,9060) + WRITE (NDST,9061) (CMPLX(JSEA,ICPRT(JSEA,:)),JSEA=1,MIN(100,NSEAL)) + WRITE (NDST,9062) FINSIZ +#endif + ! + ALLOCATE ( OUTPTS(IMOD)%OUT6%DTPRT(DIMP,MAX(1,FINSIZ)) ) + DTPRT => OUTPTS(IMOD)%OUT6%DTPRT + IF ( FINSIZ .GT. 0 ) THEN + DTPRT = TMP(:,1:FINSIZ) + ELSE + DTPRT = 0. + END IF + ! + DEALLOCATE ( XP, TMP ) + ! + RETURN + ! + ! Formats + ! +#ifdef W3_T +9000 FORMAT (' TEST W3CPRT : DIMP, DIMXP, TMPSIZ :',I2,2I6) +9050 FORMAT (' TEST W3CPRT : POINT',I4,', STORAGE',2I6) +9060 FORMAT (' TEST W3CPRT : COUNTERS FOR STORAGE (JSEA,NP,ST):') +9061 FORMAT (100(' ',5(2F9.0)/)) +9062 FORMAT (' TEST W3CPRT : FINAL STORAGE SIZE :',I6) +#endif + !/ + !/ End of W3CPRT ----------------------------------------------------- / + !/ + END SUBROUTINE W3CPRT -!/ ------------------------------------------------------------------- / -!> -!> @brief Write partitioned spectral data to file. -!> -!> @details Unlike other WAVEWATCH III IO routines, this one writes only. -!> First ad-hoc version. -!> -!> Writing to formatted or unformatted file with ID headers. -!> -!> @param[in] NDSPT Unit number. -!> @param[in] IMOD Grid number. -!> -!> @author H. L. Tolman @date 30-Oct-2009 -!> - SUBROUTINE W3IOSF ( NDSPT, IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ 02-Nov-2006 : Origination. ( version 1.10 ) -!/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 30-Oct-2009 : Fix unitialized dtsiz error. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! Write partitioned spectrakl data to file. Unlike other -! WAVEWATCH III IO routines, this one writes only. -! First ad-hoc version. -! -! 2. Method : -! -! Writing to formatted or unformatted file with ID headers. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSPT Int. I Unit number. -! IMOD Int. I Grid number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! MPI_SEND, MPI_RECV -! MPI send and recieve routines -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS - USE W3SERVMD, ONLY: EXTCDE + !/ ------------------------------------------------------------------- / + !> + !> @brief Write partitioned spectral data to file. + !> + !> @details Unlike other WAVEWATCH III IO routines, this one writes only. + !> First ad-hoc version. + !> + !> Writing to formatted or unformatted file with ID headers. + !> + !> @param[in] NDSPT Unit number. + !> @param[in] IMOD Grid number. + !> + !> @author H. L. Tolman @date 30-Oct-2009 + !> + SUBROUTINE W3IOSF ( NDSPT, IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ + !/ 02-Nov-2006 : Origination. ( version 1.10 ) + !/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 30-Oct-2009 : Fix unitialized dtsiz error. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ + ! 1. Purpose : + ! + ! Write partitioned spectrakl data to file. Unlike other + ! WAVEWATCH III IO routines, this one writes only. + ! First ad-hoc version. + ! + ! 2. Method : + ! + ! Writing to formatted or unformatted file with ID headers. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSPT Int. I Unit number. + ! IMOD Int. I Grid number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! MPI_SEND, MPI_RECV + ! MPI send and recieve routines + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE W3GDATMD, ONLY: FILEXT, NSEA, XGRD, YGRD, MAPSF, FLAGLL + ! + USE W3GDATMD, ONLY: FILEXT, NSEA, XGRD, YGRD, MAPSF, FLAGLL #ifdef W3_MPI - USE W3GDATMD, ONLY: NSEAL -#endif - USE W3WDATMD, ONLY: TIME, ASF - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPPRT, NAPERR, & - IPASS => IPASS6, FLFORM, FNMPRE, OUTPTS, & - IX0, IXN, IXS, IY0, IYN, IYS, DIMP - USE W3ADATMD, ONLY: DW, U10, U10D, CX, CY - USE W3ADATMD, ONLY: NSEALM - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC + USE W3GDATMD, ONLY: NSEAL +#endif + USE W3WDATMD, ONLY: TIME, ASF + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPPRT, NAPERR, & + IPASS => IPASS6, FLFORM, FNMPRE, OUTPTS, & + IX0, IXN, IXS, IY0, IYN, IYS, DIMP + USE W3ADATMD, ONLY: DW, U10, U10D, CX, CY + USE W3ADATMD, ONLY: NSEALM + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC #ifdef W3_MPI - USE W3ADATMD, ONLY: MPI_COMM_WAVE - USE W3ODATMD, ONLY: ICPRT, DTPRT, IT0PRT + USE W3ADATMD, ONLY: MPI_COMM_WAVE + USE W3ODATMD, ONLY: ICPRT, DTPRT, IT0PRT #endif #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSPT, IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, J, IERR, ISEA, JSEA, JAPROC, & - IX, IY, IP, IOFF, DTSIZ=0 + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSPT, IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, J, IERR, ISEA, JSEA, JAPROC, & + IX, IY, IP, IOFF, DTSIZ=0 #ifdef W3_MPI - INTEGER :: ICSIZ, IERR_MPI, IT, & - STATUS(MPI_STATUS_SIZE,1), JSLM + INTEGER :: ICSIZ, IERR_MPI, IT, & + STATUS(MPI_STATUS_SIZE,1), JSLM #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER, POINTER :: ICP(:,:) - REAL :: X, Y, DEPTH, UABS, UDIR, CABS, CDIR - REAL, POINTER :: DTP(:,:) -! - TYPE PROCS - INTEGER, POINTER :: ICPRT(:,:) - REAL, POINTER :: DTPRT(:,:) - END TYPE PROCS -! - TYPE(PROCS), TARGET, ALLOCATABLE :: PROC(:) -! -! -------------------------------------------------------------------- / -! 0. Initializations -! + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER, POINTER :: ICP(:,:) + REAL :: X, Y, DEPTH, UABS, UDIR, CABS, CDIR + REAL, POINTER :: DTP(:,:) + ! + TYPE PROCS + INTEGER, POINTER :: ICPRT(:,:) + REAL, POINTER :: DTPRT(:,:) + END TYPE PROCS + ! + TYPE(PROCS), TARGET, ALLOCATABLE :: PROC(:) + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! #ifdef W3_S - CALL STRACE (IENT, 'W3IOSF') + CALL STRACE (IENT, 'W3IOSF') #endif -! - IPASS = IPASS + 1 + ! + IPASS = IPASS + 1 #ifdef W3_MPI - ICSIZ = 2 * ( NSEALM + 1 ) + ICSIZ = 2 * ( NSEALM + 1 ) #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) IPASS, FLFORM, NDSPT, IMOD, IAPROC, NAPPRT -#endif -! -! -------------------------------------------------------------------- / -! 1. Set up file ( IPASS = 1 and proper processor ) -! - IF ( IPASS.EQ.1 .AND. IAPROC.EQ.NAPPRT ) THEN -! -! 1.a Open file -! - I = LEN_TRIM(FILEXT) - J = LEN_TRIM(FNMPRE) -! + WRITE (NDST,9000) IPASS, FLFORM, NDSPT, IMOD, IAPROC, NAPPRT +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Set up file ( IPASS = 1 and proper processor ) + ! + IF ( IPASS.EQ.1 .AND. IAPROC.EQ.NAPPRT ) THEN + ! + ! 1.a Open file + ! + I = LEN_TRIM(FILEXT) + J = LEN_TRIM(FNMPRE) + ! #ifdef W3_T - WRITE (NDST,9010) FNMPRE(:J)//'partition.'//FILEXT(:I) -#endif -! - IF ( FLFORM ) THEN - OPEN (NDSPT,FILE=FNMPRE(:J)//'partition.'//FILEXT(:I), & - ERR=800,IOSTAT=IERR) - ELSE - OPEN (NDSPT,FILE=FNMPRE(:J)//'partition.'//FILEXT(:I), & - form='UNFORMATTED',convert=file_endian,ERR=800,IOSTAT=IERR) - END IF -! - REWIND (NDSPT) -! -! 1.b Header info -! - IF ( FLFORM ) THEN - WRITE (NDSPT,910) IDSTR, VERPRT - IF ( FLAGLL ) THEN - WRITE (NDSPT,911) ' yyyymmdd hhmmss '// & - 'lat lon name nprt'// & - ' depth ubas udir cabs cdir' - ELSE - WRITE (NDSPT,911) ' yyyymmdd hhmmss '// & - 'X Y name nprt'// & - ' depth ubas udir cabs cdir' - END IF - WRITE (NDSPT,911) ' hs tp lp '// & - ' theta sp wf' - ELSE - WRITE ( NDSPT ) IDSTR, VERPRT - IF ( FLAGLL ) THEN - WRITE ( NDSPT ) ' yyyymmdd hhmmss '// & - 'lat lon name nprt'// & - ' depth ubas udir cabs cdir' - ELSE - WRITE ( NDSPT ) ' yyyymmdd hhmmss '// & - 'X Y name nprt'// & - ' depth ubas udir cabs cdir' - END IF - WRITE ( NDSPT ) ' hs tp lp '// & - ' theta sp wf' - END IF -! + WRITE (NDST,9010) FNMPRE(:J)//'partition.'//FILEXT(:I) +#endif + ! + IF ( FLFORM ) THEN + OPEN (NDSPT,FILE=FNMPRE(:J)//'partition.'//FILEXT(:I), & + ERR=800,IOSTAT=IERR) + ELSE + OPEN (NDSPT,FILE=FNMPRE(:J)//'partition.'//FILEXT(:I), & + form='UNFORMATTED',convert=file_endian,ERR=800,IOSTAT=IERR) + END IF + ! + REWIND (NDSPT) + ! + ! 1.b Header info + ! + IF ( FLFORM ) THEN + WRITE (NDSPT,910) IDSTR, VERPRT + IF ( FLAGLL ) THEN + WRITE (NDSPT,911) ' yyyymmdd hhmmss '// & + 'lat lon name nprt'// & + ' depth ubas udir cabs cdir' + ELSE + WRITE (NDSPT,911) ' yyyymmdd hhmmss '// & + 'X Y name nprt'// & + ' depth ubas udir cabs cdir' + END IF + WRITE (NDSPT,911) ' hs tp lp '// & + ' theta sp wf' + ELSE + WRITE ( NDSPT ) IDSTR, VERPRT + IF ( FLAGLL ) THEN + WRITE ( NDSPT ) ' yyyymmdd hhmmss '// & + 'lat lon name nprt'// & + ' depth ubas udir cabs cdir' + ELSE + WRITE ( NDSPT ) ' yyyymmdd hhmmss '// & + 'X Y name nprt'// & + ' depth ubas udir cabs cdir' END IF -! -! -------------------------------------------------------------------- / -! 2. Send data if output is non-local ( MPI only ) -! Leave routine after send -! - IF ( IAPROC.NE.NAPPRT .AND. IAPROC.LE.NAPROC ) THEN -! + WRITE ( NDSPT ) ' hs tp lp '// & + ' theta sp wf' + END IF + ! + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Send data if output is non-local ( MPI only ) + ! Leave routine after send + ! + IF ( IAPROC.NE.NAPPRT .AND. IAPROC.LE.NAPROC ) THEN + ! #ifdef W3_T - WRITE (NDST,9020) IAPROC, NAPPRT, NSEALM+1 + WRITE (NDST,9020) IAPROC, NAPPRT, NSEALM+1 #endif -! + ! #ifdef W3_MPI - IT = IT0PRT + IAPROC - 1 - CALL MPI_SEND ( ICPRT, ICSIZ, MPI_REAL, NAPPRT-1, IT, & - MPI_COMM_WAVE, IERR_MPI ) - DTSIZ = ICPRT(NSEAL+1,2) - 1 + IT = IT0PRT + IAPROC - 1 + CALL MPI_SEND ( ICPRT, ICSIZ, MPI_REAL, NAPPRT-1, IT, & + MPI_COMM_WAVE, IERR_MPI ) + DTSIZ = ICPRT(NSEAL+1,2) - 1 #endif -! + ! #ifdef W3_T - WRITE (NDST,9021) IAPROC, NAPPRT, DTSIZ + WRITE (NDST,9021) IAPROC, NAPPRT, DTSIZ #endif -! + ! #ifdef W3_MPI - IT = IT0PRT + NAPROC + IAPROC - 1 - IF ( DTSIZ .GT. 0 ) CALL MPI_SEND & - ( DTPRT, 6*DTSIZ, MPI_REAL, NAPPRT-1, & - IT, MPI_COMM_WAVE, IERR_MPI ) -#endif -! - END IF -! - IF ( IAPROC .NE. NAPPRT ) RETURN -! -! -------------------------------------------------------------------- / -! 3. Point to and/or gather data -! 3.a Set up storage -! - ALLOCATE ( PROC(NAPROC) ) -! -! 3.b Point to local data -! - IF ( IAPROC .LE. NAPROC ) THEN - PROC(IAPROC)%ICPRT => OUTPTS(IMOD)%OUT6%ICPRT - PROC(IAPROC)%DTPRT => OUTPTS(IMOD)%OUT6%DTPRT - END IF -! -! 3.c Allocate and get counters and arrrays -! - DO JAPROC=1, NAPROC - IF ( IAPROC .EQ. JAPROC ) CYCLE -! + IT = IT0PRT + NAPROC + IAPROC - 1 + IF ( DTSIZ .GT. 0 ) CALL MPI_SEND & + ( DTPRT, 6*DTSIZ, MPI_REAL, NAPPRT-1, & + IT, MPI_COMM_WAVE, IERR_MPI ) +#endif + ! + END IF + ! + IF ( IAPROC .NE. NAPPRT ) RETURN + ! + ! -------------------------------------------------------------------- / + ! 3. Point to and/or gather data + ! 3.a Set up storage + ! + ALLOCATE ( PROC(NAPROC) ) + ! + ! 3.b Point to local data + ! + IF ( IAPROC .LE. NAPROC ) THEN + PROC(IAPROC)%ICPRT => OUTPTS(IMOD)%OUT6%ICPRT + PROC(IAPROC)%DTPRT => OUTPTS(IMOD)%OUT6%DTPRT + END IF + ! + ! 3.c Allocate and get counters and arrrays + ! + DO JAPROC=1, NAPROC + IF ( IAPROC .EQ. JAPROC ) CYCLE + ! #ifdef W3_T - WRITE (NDST,9030) JAPROC, NSEALM+1 + WRITE (NDST,9030) JAPROC, NSEALM+1 #endif -! + ! #ifdef W3_MPI - ALLOCATE ( PROC(JAPROC)%ICPRT(NSEALM+1,2) ) - ICP => PROC(JAPROC)%ICPRT - IT = IT0PRT + JAPROC - 1 - CALL MPI_RECV ( ICP, ICSIZ, MPI_REAL, JAPROC-1, IT, & - MPI_COMM_WAVE, STATUS, IERR_MPI ) - JSLM = 1 + (NSEA-JAPROC)/NAPROC - DTSIZ = ICP(JSLM+1,2) - 1 -#endif -! + ALLOCATE ( PROC(JAPROC)%ICPRT(NSEALM+1,2) ) + ICP => PROC(JAPROC)%ICPRT + IT = IT0PRT + JAPROC - 1 + CALL MPI_RECV ( ICP, ICSIZ, MPI_REAL, JAPROC-1, IT, & + MPI_COMM_WAVE, STATUS, IERR_MPI ) + JSLM = 1 + (NSEA-JAPROC)/NAPROC + DTSIZ = ICP(JSLM+1,2) - 1 +#endif + ! #ifdef W3_T - WRITE (NDST,9031) JAPROC, DTSIZ + WRITE (NDST,9031) JAPROC, DTSIZ #endif -! + ! #ifdef W3_MPI - ALLOCATE ( PROC(JAPROC)%DTPRT(DIMP,MAX(1,DTSIZ)) ) - DTP => PROC(JAPROC)%DTPRT - IT = IT0PRT + NAPROC + JAPROC - 1 - IF ( DTSIZ .GT. 0 ) CALL MPI_RECV & - ( DTP, DIMP*DTSIZ, MPI_REAL, JAPROC-1, & - IT, MPI_COMM_WAVE, STATUS, IERR_MPI ) -#endif -! + ALLOCATE ( PROC(JAPROC)%DTPRT(DIMP,MAX(1,DTSIZ)) ) + DTP => PROC(JAPROC)%DTPRT + IT = IT0PRT + NAPROC + JAPROC - 1 + IF ( DTSIZ .GT. 0 ) CALL MPI_RECV & + ( DTP, DIMP*DTSIZ, MPI_REAL, JAPROC-1, & + IT, MPI_COMM_WAVE, STATUS, IERR_MPI ) +#endif + ! + END DO + ! + ! -------------------------------------------------------------------- / + ! 4. Write all data for which partitions are found + ! 4.a General loop over all sea points + ! + DO ISEA=1, NSEA + ! + ! 4.b Check for partitioned data at sea point + ! + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, JAPROC) + ! + ICP => PROC(JAPROC)%ICPRT + DTP => PROC(JAPROC)%DTPRT + ! + IF ( ICP(JSEA,1) .EQ. 0 ) CYCLE + ! + ! 4.c Process point ID line + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF ( IX.LT.IX0 .OR. IX.GT.IXN .OR. MOD(IX-IX0,IXS).NE.0 ) CYCLE + IF ( IY.LT.IY0 .OR. IY.GT.IYN .OR. MOD(IY-IY0,IYS).NE.0 ) CYCLE + X = XGRD(IY,IX) + Y = YGRD(IY,IX) + DEPTH = DW(ISEA) + UABS = U10(ISEA)*ASF(ISEA) + UDIR = MOD ( 270. - U10D(ISEA)*RADE , 360. ) + CABS = SQRT ( CX(ISEA)**2 + CY(ISEA)**2 ) + IF ( CABS .LT. 1.E-3 ) THEN + CDIR = 0. + ELSE + CDIR = ATAN2 ( CY(ISEA), CX(ISEA) ) * RADE + CDIR = MOD ( 270. - CDIR , 360. ) + END IF + ! + IF ( FLFORM ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSPT,940) TIME, Y, X, & + 'grid_point', ICP(JSEA,1) - 1, & + DEPTH, UABS, UDIR, CABS, CDIR + ELSE + WRITE (NDSPT,941) TIME, X*1.E-3, Y*1.E-3, & + 'grid_point', ICP(JSEA,1) - 1, & + DEPTH, UABS, UDIR, CABS, CDIR + END IF + ELSE + IF ( FLAGLL ) THEN + WRITE ( NDSPT ) TIME, Y, X, & + 'grid_point', ICP(JSEA,1) - 1, & + DEPTH, UABS, UDIR, CABS, CDIR + ELSE + WRITE ( NDSPT ) TIME, X*1.E-3, Y*1.E-3, & + 'grid_point', ICP(JSEA,1) - 1, & + DEPTH, UABS, UDIR, CABS, CDIR + END IF + END IF + ! + ! 4.d Process partitions for this point + ! + IOFF = ICP(JSEA,2) + ! + IF ( FLFORM ) THEN + DO IP=0, ICP(JSEA,1) - 1 + WRITE (NDSPT,942) IP, DTP(:,IP+IOFF) END DO -! -! -------------------------------------------------------------------- / -! 4. Write all data for which partitions are found -! 4.a General loop over all sea points -! - DO ISEA=1, NSEA -! -! 4.b Check for partitioned data at sea point -! - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, JAPROC) -! - ICP => PROC(JAPROC)%ICPRT - DTP => PROC(JAPROC)%DTPRT -! - IF ( ICP(JSEA,1) .EQ. 0 ) CYCLE -! -! 4.c Process point ID line -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF ( IX.LT.IX0 .OR. IX.GT.IXN .OR. MOD(IX-IX0,IXS).NE.0 ) CYCLE - IF ( IY.LT.IY0 .OR. IY.GT.IYN .OR. MOD(IY-IY0,IYS).NE.0 ) CYCLE - X = XGRD(IY,IX) - Y = YGRD(IY,IX) - DEPTH = DW(ISEA) - UABS = U10(ISEA)*ASF(ISEA) - UDIR = MOD ( 270. - U10D(ISEA)*RADE , 360. ) - CABS = SQRT ( CX(ISEA)**2 + CY(ISEA)**2 ) - IF ( CABS .LT. 1.E-3 ) THEN - CDIR = 0. - ELSE - CDIR = ATAN2 ( CY(ISEA), CX(ISEA) ) * RADE - CDIR = MOD ( 270. - CDIR , 360. ) - END IF -! - IF ( FLFORM ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSPT,940) TIME, Y, X, & - 'grid_point', ICP(JSEA,1) - 1, & - DEPTH, UABS, UDIR, CABS, CDIR - ELSE - WRITE (NDSPT,941) TIME, X*1.E-3, Y*1.E-3, & - 'grid_point', ICP(JSEA,1) - 1, & - DEPTH, UABS, UDIR, CABS, CDIR - END IF - ELSE - IF ( FLAGLL ) THEN - WRITE ( NDSPT ) TIME, Y, X, & - 'grid_point', ICP(JSEA,1) - 1, & - DEPTH, UABS, UDIR, CABS, CDIR - ELSE - WRITE ( NDSPT ) TIME, X*1.E-3, Y*1.E-3, & - 'grid_point', ICP(JSEA,1) - 1, & - DEPTH, UABS, UDIR, CABS, CDIR - END IF - END IF -! -! 4.d Process partitions for this point -! - IOFF = ICP(JSEA,2) -! - IF ( FLFORM ) THEN - DO IP=0, ICP(JSEA,1) - 1 - WRITE (NDSPT,942) IP, DTP(:,IP+IOFF) - END DO - ELSE - DO IP=0, ICP(JSEA,1) - 1 - WRITE ( NDSPT ) IP, DTP(:,IP+IOFF) - END DO - END IF -! + ELSE + DO IP=0, ICP(JSEA,1) - 1 + WRITE ( NDSPT ) IP, DTP(:,IP+IOFF) END DO -! -! -------------------------------------------------------------------- / -! 5. Clean up data structure -! + END IF + ! + END DO + ! + ! -------------------------------------------------------------------- / + ! 5. Clean up data structure + ! #ifdef W3_MPI - DO JAPROC=1, NAPROC - IF ( IAPROC .EQ. JAPROC ) CYCLE - DEALLOCATE ( PROC(JAPROC)%ICPRT, PROC(JAPROC)%DTPRT ) - END DO + DO JAPROC=1, NAPROC + IF ( IAPROC .EQ. JAPROC ) CYCLE + DEALLOCATE ( PROC(JAPROC)%ICPRT, PROC(JAPROC)%DTPRT ) + END DO +#endif + ! + DEALLOCATE ( PROC ) + ! + RETURN + ! + ! Escape locations read errors --------------------------------------- * + ! +800 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) IERR + CALL EXTCDE ( 1 ) + ! + ! Formats + ! +910 FORMAT (A,1X,A) +911 FORMAT (A) + ! +940 FORMAT (1X,I8.8,1X,I6.6,2F8.3,2X,'''',A10,'''', & + 1X,I2,F7.1,F5.1,f6.1,F5.2,F6.1) +941 FORMAT (1X,I8.8,1X,I6.6,2(F8.1,'E3'),2X,'''',A10,'''', & + 1X,I2,F7.1,F5.1,f6.1,F5.2,F6.1) +942 FORMAT (I3,3F8.2,2F9.2,F7.2) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOSF : '/ & + ' ERROR IN OPENING FILE'/ & + ' IOSTAT =',I5/) + ! +#ifdef W3_T +9000 FORMAT (' TEST W3IOSF : IPASS =',I4,', FLFROM = ',L1, & + ', NDSPT =',I3,', IMOD =',I3,','/ & + ' IAPROC, NAPPRT =',2I4) +9010 FORMAT (' TEST W3IOSF : OPENING NEW FILE [',A,']') +9020 FORMAT (' TEST W3IOSF : SENDING ICPRT FROM',I3,' TO',I3, & + ' WITH SIZE :',I6) #endif -! - DEALLOCATE ( PROC ) -! - RETURN -! -! Escape locations read errors --------------------------------------- * -! - 800 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) IERR - CALL EXTCDE ( 1 ) -! -! Formats -! - 910 FORMAT (A,1X,A) - 911 FORMAT (A) -! - 940 FORMAT (1X,I8.8,1X,I6.6,2F8.3,2X,'''',A10,'''', & - 1X,I2,F7.1,F5.1,f6.1,F5.2,F6.1) - 941 FORMAT (1X,I8.8,1X,I6.6,2(F8.1,'E3'),2X,'''',A10,'''', & - 1X,I2,F7.1,F5.1,f6.1,F5.2,F6.1) - 942 FORMAT (I3,3F8.2,2F9.2,F7.2) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOSF : '/ & - ' ERROR IN OPENING FILE'/ & - ' IOSTAT =',I5/) -! #ifdef W3_T - 9000 FORMAT (' TEST W3IOSF : IPASS =',I4,', FLFROM = ',L1, & - ', NDSPT =',I3,', IMOD =',I3,','/ & - ' IAPROC, NAPPRT =',2I4) - 9010 FORMAT (' TEST W3IOSF : OPENING NEW FILE [',A,']') - 9020 FORMAT (' TEST W3IOSF : SENDING ICPRT FROM',I3,' TO',I3, & - ' WITH SIZE :',I6) +9021 FORMAT (' TEST W3IOSF : SENDING DTPRT FROM',I3,' TO',I3, & + ' WITH SIZE :',I6) #endif -#ifdef W3_MPIT - 9021 FORMAT (' TEST W3IOSF : SENDING DTPRT FROM',I3,' TO',I3, & - ' WITH SIZE :',I6) +#ifdef W3_T +9030 FORMAT (' TEST W3IOSF : RECEIVING ICPRT FROM',I3, & + ' WITH SIZE :',I6) #endif #ifdef W3_T - 9030 FORMAT (' TEST W3IOSF : RECEIVING ICPRT FROM',I3, & - ' WITH SIZE :',I6) -#endif -#ifdef W3_MPIT - 9031 FORMAT (' TEST W3IOSF : RECEIVING DTPRT FROM',I3, & - ' WITH SIZE :',I6) -#endif -!/ -!/ End of W3IOSF ----------------------------------------------------- / -!/ - END SUBROUTINE W3IOSF -!/ -!/ End of module W3IOSFMD -------------------------------------------- / -!/ - END MODULE W3IOSFMD +9031 FORMAT (' TEST W3IOSF : RECEIVING DTPRT FROM',I3, & + ' WITH SIZE :',I6) +#endif + !/ + !/ End of W3IOSF ----------------------------------------------------- / + !/ + END SUBROUTINE W3IOSF + !/ + !/ End of module W3IOSFMD -------------------------------------------- / + !/ +END MODULE W3IOSFMD diff --git a/model/src/w3iotrmd.F90 b/model/src/w3iotrmd.F90 index 390d10f4d..63b46ac04 100644 --- a/model/src/w3iotrmd.F90 +++ b/model/src/w3iotrmd.F90 @@ -1,924 +1,914 @@ !> @file !> @brief Generate track output. -!> +!> !> @author H. L. Tolman @date 26-Dec-2012 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / !> !> @brief Generate track output. -!> -!> @author H. L. Tolman @date 26-Dec-2012 -!> - MODULE W3IOTRMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2012 | -!/ +-----------------------------------+ -! -!/ See subroutine for update history. -!/ -! 1. Purpose : -! -! Generate track output. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! VERTRK C*10 Private Version number of routine. -! IDSTRI C*34 Private ID string input file. -! IDSTRO C*34 Private ID string output file. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3IOTR Subr. Public Track output subroutine. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETO Subr. W3ODATMD Point to data structure. -! W3SETG Subr. W3GDATMD Point to data structure. -! W3SETW Subr. W3WDATMD Point to data structure. -! W3SETA Subr. W3ADATMD Point to data structure. -! W3DMO3 Subr. W3ODATMD Allocate work arrays. -! STRACE Subr. W3SERVMD Subroutine tracing. -! TICK21 Subr. W3TIMEMD Increment time. -! DSEC21 Func. W3TIMEMD Time difference. -! MPI_SEND, MPI_RECV, MPI_STARTALL, MPI_WAITALL -! MPI send and recieve routines -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! See documentation of W3IOTR. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ Private parameter statements (ID strings) -!/ - CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERTRK = '2018-06-08' - CHARACTER(LEN=34), PARAMETER, PRIVATE :: & - IDSTRI = 'WAVEWATCH III TRACK LOCATIONS DATA', & - IDSTRO = 'WAVEWATCH III TRACK OUTPUT SPECTRA' -!/ - CONTAINS -!/ ------------------------------------------------------------------- / !> -!> @brief Perform output of spectral information along provided tracks. -!> -!> @details -!> @verbatim -!> Time and location data for the track is read from the file -!> track_i.FILEXT, and output spectra additional information are -!> written to track_o.FILEXT. -!> -!> The spectrum dumped is the frequency-direction spectrum in -!> m**2/Hz/rad. -!> -!> The output spectra are energy density spectra in terms of the -!> true frequency and a direction in radians. The corresponding -!> band widths are part of the file header. -!> @endverbatim -!> -!> @param[inout] NDSINP Unit number of input file track_i.FILEXT. -!> @param[inout] NDSOUT Unit number of output file track_o.FILEXT. -!> @param[inout] A Spectra (shape conversion through par list). -!> @param[inout] IMOD Model grid number. +!> @author H. L. Tolman @date 26-Dec-2012 !> -!> @author H. L. Tolman @date 08-Jun-2018 -!> - SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 08-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 22-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 27-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 24-Jan-2001 : Flat grid version ( version 2.06 ) -!/ 20-Aug-2003 : Output through NAPTRK, seq. file. ( version 3.04 ) -!/ 24-Nov-2004 : Multiple grid version. ( version 3.06 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 27-Jun-2005 : Adding MAPST2, ( version 3.07 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 26-Dec-2012 : Initialize ASPTRK. ( version 4.11 ) -!/ 12-Dec-2014 : Modify instanciation of NRQTR ( version 5.04 ) -!/ 08-Jun-2018 : use W3PARALL/INIT_GET_JSEA_ISPROC ( version 6.04 ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Perform output of spectral information along provided tracks. -! -! 2. Method : -! -! Time and location data for the track is read from the file -! track_i.FILEXT, and output spectra additional information are -! written to track_o.FILEXT. -! -! The spectrum dumped is the frequency-direction spectrum in -! m**2/Hz/rad. -! -! The output spectra are energy density spectra in terms of the -! true frequency and a direction in radians. The corresponding -! band widths are part of the file header. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSINP Int. I Unit number of input file track_i.FILEXT -! If negative, file is unformatted and v.v. -! NDSOUT Int. I Unit number of output file track_o.FILEXT -! A R.A. I Spectra (shape conversion through par list). -! IMOD Int. I Model grid number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - If input file not found, a warning is printed and output -! type is disabled. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI MPI interface routines. -! -! !/S Enable subroutine tracing. -! !/T General test output. -! !/T1 Test output on track point status. -! !/T2 Test output of mask arrays. -! !/T3 Test output for writing of file. -! -! 10. Remarks : -! -! Regarding section 3.e.2 "Optimize: omit points that are not -! strictly required.". This optimization saves disk space but -! results in output files that are more difficult to use. For -! example, matlab built-in function "griddata" requires all four -! bounding points. This means that a post-processing code must -! have extra logic do deal with cases without all four bounding -! points (interpolation along a line, or nearest neighbor). -! A namelist variable has been add to make this feature optional. -! Default, original behavior: TRCKCMPR = T (in /MISC/ namelist). -! Save all points: TRCKCMPR = F (in /MISC/ namelist). -! Within the present routine, the logical is named "CMPRTRCK". -! -! 11. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ - USE W3GDATMD, ONLY: W3SETG, CMPRTRCK - USE W3WDATMD, ONLY: W3SETW - USE W3ADATMD, ONLY: W3SETA - USE W3ODATMD, ONLY: W3SETO, W3DMO3 -!/ - USE W3GDATMD, ONLY: NK, NTH, NSPEC, NSEA, NSEAL, NX, NY, & - FLAGLL, ICLOSE, XGRD, YGRD, GSU, & - DPDX, DPDY, DQDX, DQDY, MAPSTA, MAPST2, & - MAPFS, TH, DTH, SIG, DSIP, XFR, FILEXT - USE W3GSRUMD, ONLY: W3GFCL +MODULE W3IOTRMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Dec-2012 | + !/ +-----------------------------------+ + ! + !/ See subroutine for update history. + !/ + ! 1. Purpose : + ! + ! Generate track output. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! VERTRK C*10 Private Version number of routine. + ! IDSTRI C*34 Private ID string input file. + ! IDSTRO C*34 Private ID string output file. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3IOTR Subr. Public Track output subroutine. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETO Subr. W3ODATMD Point to data structure. + ! W3SETG Subr. W3GDATMD Point to data structure. + ! W3SETW Subr. W3WDATMD Point to data structure. + ! W3SETA Subr. W3ADATMD Point to data structure. + ! W3DMO3 Subr. W3ODATMD Allocate work arrays. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! TICK21 Subr. W3TIMEMD Increment time. + ! DSEC21 Func. W3TIMEMD Time difference. + ! MPI_SEND, MPI_RECV, MPI_STARTALL, MPI_WAITALL + ! MPI send and recieve routines + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See documentation of W3IOTR. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ Private parameter statements (ID strings) + !/ + CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERTRK = '2018-06-08' + CHARACTER(LEN=34), PARAMETER, PRIVATE :: & + IDSTRI = 'WAVEWATCH III TRACK LOCATIONS DATA', & + IDSTRO = 'WAVEWATCH III TRACK OUTPUT SPECTRA' + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Perform output of spectral information along provided tracks. + !> + !> @details + !> @verbatim + !> Time and location data for the track is read from the file + !> track_i.FILEXT, and output spectra additional information are + !> written to track_o.FILEXT. + !> + !> The spectrum dumped is the frequency-direction spectrum in + !> m**2/Hz/rad. + !> + !> The output spectra are energy density spectra in terms of the + !> true frequency and a direction in radians. The corresponding + !> band widths are part of the file header. + !> @endverbatim + !> + !> @param[inout] NDSINP Unit number of input file track_i.FILEXT. + !> @param[inout] NDSOUT Unit number of output file track_o.FILEXT. + !> @param[inout] A Spectra (shape conversion through par list). + !> @param[inout] IMOD Model grid number. + !> + !> @author H. L. Tolman @date 08-Jun-2018 + !> + SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 08-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 22-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 27-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 24-Jan-2001 : Flat grid version ( version 2.06 ) + !/ 20-Aug-2003 : Output through NAPTRK, seq. file. ( version 3.04 ) + !/ 24-Nov-2004 : Multiple grid version. ( version 3.06 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 27-Jun-2005 : Adding MAPST2, ( version 3.07 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 26-Dec-2012 : Initialize ASPTRK. ( version 4.11 ) + !/ 12-Dec-2014 : Modify instanciation of NRQTR ( version 5.04 ) + !/ 08-Jun-2018 : use W3PARALL/INIT_GET_JSEA_ISPROC ( version 6.04 ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Perform output of spectral information along provided tracks. + ! + ! 2. Method : + ! + ! Time and location data for the track is read from the file + ! track_i.FILEXT, and output spectra additional information are + ! written to track_o.FILEXT. + ! + ! The spectrum dumped is the frequency-direction spectrum in + ! m**2/Hz/rad. + ! + ! The output spectra are energy density spectra in terms of the + ! true frequency and a direction in radians. The corresponding + ! band widths are part of the file header. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSINP Int. I Unit number of input file track_i.FILEXT + ! If negative, file is unformatted and v.v. + ! NDSOUT Int. I Unit number of output file track_o.FILEXT + ! A R.A. I Spectra (shape conversion through par list). + ! IMOD Int. I Model grid number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - If input file not found, a warning is printed and output + ! type is disabled. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI MPI interface routines. + ! + ! !/S Enable subroutine tracing. + ! !/T General test output. + ! !/T1 Test output on track point status. + ! !/T2 Test output of mask arrays. + ! !/T3 Test output for writing of file. + ! + ! 10. Remarks : + ! + ! Regarding section 3.e.2 "Optimize: omit points that are not + ! strictly required.". This optimization saves disk space but + ! results in output files that are more difficult to use. For + ! example, matlab built-in function "griddata" requires all four + ! bounding points. This means that a post-processing code must + ! have extra logic do deal with cases without all four bounding + ! points (interpolation along a line, or nearest neighbor). + ! A namelist variable has been add to make this feature optional. + ! Default, original behavior: TRCKCMPR = T (in /MISC/ namelist). + ! Save all points: TRCKCMPR = F (in /MISC/ namelist). + ! Within the present routine, the logical is named "CMPRTRCK". + ! + ! 11. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + USE W3GDATMD, ONLY: W3SETG, CMPRTRCK + USE W3WDATMD, ONLY: W3SETW + USE W3ADATMD, ONLY: W3SETA + USE W3ODATMD, ONLY: W3SETO, W3DMO3 + !/ + USE W3GDATMD, ONLY: NK, NTH, NSPEC, NSEA, NSEAL, NX, NY, & + FLAGLL, ICLOSE, XGRD, YGRD, GSU, & + DPDX, DPDY, DQDX, DQDY, MAPSTA, MAPST2, & + MAPFS, TH, DTH, SIG, DSIP, XFR, FILEXT + USE W3GSRUMD, ONLY: W3GFCL #ifdef W3_T - USE W3GSRUMD, ONLY: W3GSUP + USE W3GSRUMD, ONLY: W3GSUP #endif - USE W3GDATMD, ONLY: MAXX, MAXY, GTYPE, UNGTYPE - USE W3WDATMD, ONLY: TIME, UST - USE W3ADATMD, ONLY: CG, DW, CX, CY, UA, UD, AS + USE W3GDATMD, ONLY: MAXX, MAXY, GTYPE, UNGTYPE + USE W3WDATMD, ONLY: TIME, UST + USE W3ADATMD, ONLY: CG, DW, CX, CY, UA, UD, AS #ifdef W3_MPI - USE W3ADATMD, ONLY: MPI_COMM_WAVE + USE W3ADATMD, ONLY: MPI_COMM_WAVE #endif - USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPROC, NAPTRK, NAPERR, & - IPASS => IPASS3, ATOLAST => TOLAST, & - ADTOUT => DTOUT, O3INIT, STOP, MASK1, & - MASK2, TRCKID, FNMPRE + USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPROC, NAPTRK, NAPERR, & + IPASS => IPASS3, ATOLAST => TOLAST, & + ADTOUT => DTOUT, O3INIT, STOP, MASK1, & + MASK2, TRCKID, FNMPRE #ifdef W3_MPI - USE W3ODATMD, ONLY: IT0TRK, NRQTR, IRQTR + USE W3ODATMD, ONLY: IT0TRK, NRQTR, IRQTR #endif -!/ - USE W3TIMEMD - USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC - USE w3SERVMD, ONLY : STRSPLIT + !/ + USE W3TIMEMD + USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC + USE w3SERVMD, ONLY : STRSPLIT #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSINP, NDSOUT, IMOD - REAL, INTENT(IN) :: A(NTH,NK,0:NSEAL) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, PARAMETER :: OTYPE = 3 - INTEGER :: NDSTI, NDSTO, ISPROC, IERR, & - IK, ITH, IX, IY, TIMEB(2), TIMEE(2), & - TTIME(2), IX1, IX2, IY1, IY2, & - IXX(4), IYY(4), I, J, ISEA, JSEA, & - TOLAST(2) + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSINP, NDSOUT, IMOD + REAL, INTENT(IN) :: A(NTH,NK,0:NSEAL) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, PARAMETER :: OTYPE = 3 + INTEGER :: NDSTI, NDSTO, ISPROC, IERR, & + IK, ITH, IX, IY, TIMEB(2), TIMEE(2), & + TTIME(2), IX1, IX2, IY1, IY2, & + IXX(4), IYY(4), I, J, ISEA, JSEA, & + TOLAST(2) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T - INTEGER :: NREAD, NTRACK, NSPECO, NLOCO + INTEGER :: NREAD, NTRACK, NSPECO, NLOCO #endif #ifdef W3_T3 - INTEGER :: ISPT + INTEGER :: ISPT #endif #ifdef W3_MPI - INTEGER :: IT, IROOT, IFROM, IERR_MPI - INTEGER, ALLOCATABLE :: STATUS(:,:) -#endif - REAL :: XN, YN, XT, YT, RD, X, Y, WX, WY, & - SPEC(NK,NTH), FACTOR, ASPTRK(NTH,NK),& - DTOUT, XX(4), YY(4) - REAL, SAVE :: RDCHCK = 0.05, RTCHCK = 0.05 - LOGICAL :: FORMI, FLAG1, FLAG2, INGRID - CHARACTER :: TRCKT*32, LINE*1024, TSTSTR*3, IDTST*34 - CHARACTER(LEN=100) :: LIST(5) + INTEGER :: IT, IROOT, IFROM, IERR_MPI + INTEGER, ALLOCATABLE :: STATUS(:,:) +#endif + REAL :: XN, YN, XT, YT, RD, X, Y, WX, WY, & + SPEC(NK,NTH), FACTOR, ASPTRK(NTH,NK),& + DTOUT, XX(4), YY(4) + REAL, SAVE :: RDCHCK = 0.05, RTCHCK = 0.05 + LOGICAL :: FORMI, FLAG1, FLAG2, INGRID + CHARACTER :: TRCKT*32, LINE*1024, TSTSTR*3, IDTST*34 + CHARACTER(LEN=100) :: LIST(5) #ifdef W3_T1 - CHARACTER(LEN=17), SAVE :: TSTLOC = ' ' + CHARACTER(LEN=17), SAVE :: TSTLOC = ' ' #endif #ifdef W3_T2 - CHARACTER(LEN=1) :: MAPSTR(NX) -#endif -! - EQUIVALENCE (IXX(1),IX1) , (IXX(2),IX2) , & - (IYY(1),IY1) , (IYY(3),IY2) -!/ -!/ ------------------------------------------------------------------- / -!/ + CHARACTER(LEN=1) :: MAPSTR(NX) +#endif + ! + EQUIVALENCE (IXX(1),IX1) , (IXX(2),IX2) , & + (IYY(1),IY1) , (IYY(3),IY2) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3IOTR') -#endif -! - CALL W3SETO ( IMOD, NDSE, NDST ) - CALL W3SETG ( IMOD, NDSE, NDST ) - CALL W3SETA ( IMOD, NDSE, NDST ) - CALL W3SETW ( IMOD, NDSE, NDST ) -! - TOLAST = ATOLAST(:,OTYPE) - DTOUT = ADTOUT(OTYPE) -! - IF ( .NOT. O3INIT ) CALL W3DMO3 ( IMOD, NDSE, NDST ) -! - FORMI = NDSINP .GT. 0 - NDSTI = ABS(NDSINP) - NDSTO = ABS(NDSOUT) - - IF (GTYPE .EQ. UNGTYPE) THEN - XN = MAXX - YN = MAXY - ENDIF -! - ISPROC = IAPROC - IPASS = IPASS + 1 -! - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF -! - ASPTRK = 0. -! + CALL STRACE (IENT, 'W3IOTR') +#endif + ! + CALL W3SETO ( IMOD, NDSE, NDST ) + CALL W3SETG ( IMOD, NDSE, NDST ) + CALL W3SETA ( IMOD, NDSE, NDST ) + CALL W3SETW ( IMOD, NDSE, NDST ) + ! + TOLAST = ATOLAST(:,OTYPE) + DTOUT = ADTOUT(OTYPE) + ! + IF ( .NOT. O3INIT ) CALL W3DMO3 ( IMOD, NDSE, NDST ) + ! + FORMI = NDSINP .GT. 0 + NDSTI = ABS(NDSINP) + NDSTO = ABS(NDSOUT) + + IF (GTYPE .EQ. UNGTYPE) THEN + XN = MAXX + YN = MAXY + ENDIF + ! + ISPROC = IAPROC + IPASS = IPASS + 1 + ! + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + ! + ASPTRK = 0. + ! #ifdef W3_T - WRITE (NDST,9000) TIME + WRITE (NDST,9000) TIME #endif -! + ! #ifdef W3_MPI - IF ( NRQTR .NE. 0 ) THEN - CALL MPI_STARTALL ( NRQTR, IRQTR, IERR_MPI ) - ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQTR) ) - CALL MPI_WAITALL ( NRQTR, IRQTR , STATUS, IERR_MPI ) - DEALLOCATE ( STATUS ) - END IF + IF ( NRQTR .NE. 0 ) THEN + CALL MPI_STARTALL ( NRQTR, IRQTR, IERR_MPI ) + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQTR) ) + CALL MPI_WAITALL ( NRQTR, IRQTR , STATUS, IERR_MPI ) + DEALLOCATE ( STATUS ) + END IF #endif -! -! 1. First pass through routine ------------------------------------- * -! - IF ( IPASS .EQ. 1 ) THEN -! + ! + ! 1. First pass through routine ------------------------------------- * + ! + IF ( IPASS .EQ. 1 ) THEN + ! #ifdef W3_T - WRITE (NDST,9010) TOLAST, DTOUT, NDSTI, NDSTO, FORMI -#endif -! Removed by F.A. 2010/12/24 /T CALL W3GSUP ( GSU, NDST ) -! - I = LEN_TRIM(FILEXT) - J = LEN_TRIM(FNMPRE) -! -! 1.a Open input file -! - IF ( FORMI ) THEN + WRITE (NDST,9010) TOLAST, DTOUT, NDSTI, NDSTO, FORMI +#endif + ! Removed by F.A. 2010/12/24 /T CALL W3GSUP ( GSU, NDST ) + ! + I = LEN_TRIM(FILEXT) + J = LEN_TRIM(FNMPRE) + ! + ! 1.a Open input file + ! + IF ( FORMI ) THEN #ifdef W3_T - WRITE (NDST,9011) FNMPRE(:J)//'track_i.'//FILEXT(:I), & - 'FORMATTED' + WRITE (NDST,9011) FNMPRE(:J)//'track_i.'//FILEXT(:I), & + 'FORMATTED' #endif - OPEN (NDSTI,FILE=FNMPRE(:J)//'track_i.'//FILEXT(:I), & - STATUS='OLD',ERR=800,FORM='FORMATTED',IOSTAT=IERR) - READ (NDSTI,'(A)',ERR=801,END=802,IOSTAT=IERR) IDTST - ELSE + OPEN (NDSTI,FILE=FNMPRE(:J)//'track_i.'//FILEXT(:I), & + STATUS='OLD',ERR=800,FORM='FORMATTED',IOSTAT=IERR) + READ (NDSTI,'(A)',ERR=801,END=802,IOSTAT=IERR) IDTST + ELSE #ifdef W3_T - WRITE (NDST,9011) FNMPRE(:J)//'track_i.'//FILEXT(:I), & - 'UNFORMATTED' -#endif - OPEN (NDSTI,FILE=FNMPRE(:J)//'track_i.'//FILEXT(:I), & - STATUS='OLD',ERR=800,form='UNFORMATTED', convert=file_endian,IOSTAT=IERR) - READ (NDSTI,ERR=801,END=802,IOSTAT=IERR) IDTST - END IF -! - IF ( IDTST .NE. IDSTRI ) GOTO 803 -! -! 1.b Open output file -! - IF ( IAPROC .EQ. NAPTRK ) THEN -#ifdef W3_T - WRITE (NDST,9012) FNMPRE(:J)//'track_o.'//FILEXT(:I), & - 'UNFORMATTED' -#endif - OPEN (NDSTO,FILE=FNMPRE(:J)//'track_o.'//FILEXT(:I), & - form='UNFORMATTED', convert=file_endian,ERR=810,IOSTAT=IERR) - WRITE (NDSTO,ERR=811,IOSTAT=IERR) IDSTRO, FLAGLL, NK, & - NTH, XFR - WRITE (NDSTO,ERR=811,IOSTAT=IERR) 0.5*PI-TH(1), -DTH, & - (SIG(IK)*TPIINV,IK=1,NK), & - (DSIP(IK)*TPIINV,IK=1,NK) - END IF -! -! 1.c Initialize maps -! + WRITE (NDST,9011) FNMPRE(:J)//'track_i.'//FILEXT(:I), & + 'UNFORMATTED' +#endif + OPEN (NDSTI,FILE=FNMPRE(:J)//'track_i.'//FILEXT(:I), & + STATUS='OLD',ERR=800,form='UNFORMATTED', convert=file_endian,IOSTAT=IERR) + READ (NDSTI,ERR=801,END=802,IOSTAT=IERR) IDTST + END IF + ! + IF ( IDTST .NE. IDSTRI ) GOTO 803 + ! + ! 1.b Open output file + ! + IF ( IAPROC .EQ. NAPTRK ) THEN #ifdef W3_T - WRITE (NDST,9015) -#endif -! - MASK2 = .FALSE. - TRCKID = '' -! - END IF -! -! 2. Preparations --------------------------------------------------- * -! 2.a Shift mask arrays -! + WRITE (NDST,9012) FNMPRE(:J)//'track_o.'//FILEXT(:I), & + 'UNFORMATTED' +#endif + OPEN (NDSTO,FILE=FNMPRE(:J)//'track_o.'//FILEXT(:I), & + form='UNFORMATTED', convert=file_endian,ERR=810,IOSTAT=IERR) + WRITE (NDSTO,ERR=811,IOSTAT=IERR) IDSTRO, FLAGLL, NK, & + NTH, XFR + WRITE (NDSTO,ERR=811,IOSTAT=IERR) 0.5*PI-TH(1), -DTH, & + (SIG(IK)*TPIINV,IK=1,NK), & + (DSIP(IK)*TPIINV,IK=1,NK) + END IF + ! + ! 1.c Initialize maps + ! #ifdef W3_T - WRITE (NDST,9020) + WRITE (NDST,9015) #endif -! - MASK1 = MASK2 + ! MASK2 = .FALSE. -! -! 2.b Set time frame -! - TIMEB = TIME - TIMEE = TIME - CALL TICK21 ( TIMEE , DTOUT ) -! - IF ( DSEC21(TIMEE,TOLAST) .LT. 0. ) THEN - TIMEE = TOLAST + TRCKID = '' + ! + END IF + ! + ! 2. Preparations --------------------------------------------------- * + ! 2.a Shift mask arrays + ! #ifdef W3_T - WRITE (NDST,9022) + WRITE (NDST,9020) +#endif + ! + MASK1 = MASK2 + MASK2 = .FALSE. + ! + ! 2.b Set time frame + ! + TIMEB = TIME + TIMEE = TIME + CALL TICK21 ( TIMEE , DTOUT ) + ! + IF ( DSEC21(TIMEE,TOLAST) .LT. 0. ) THEN + TIMEE = TOLAST +#ifdef W3_T + WRITE (NDST,9022) #endif - END IF -! + END IF + ! #ifdef W3_T - WRITE (NDST,9021) TIMEB, TIMEE + WRITE (NDST,9021) TIMEB, TIMEE #endif -! -! 3. Loop over input points ----------------------------------------- * -! + ! + ! 3. Loop over input points ----------------------------------------- * + ! #ifdef W3_T - NREAD = 0 - NTRACK = 0 -#endif -! -! 3.a Read new track point (infinite loop) -! - IF ( STOP ) THEN - TOLAST = TIME + NREAD = 0 + NTRACK = 0 +#endif + ! + ! 3.a Read new track point (infinite loop) + ! + IF ( STOP ) THEN + TOLAST = TIME #ifdef W3_T - WRITE (NDST,9034) + WRITE (NDST,9034) #endif - GOTO 399 - END IF -! + GOTO 399 + END IF + ! #ifdef W3_T1 - WRITE (NDST,9030) -#endif -! - DO -! - IF ( FORMI ) THEN - READ (NDSTI,'(A)',ERR=801,END=390,IOSTAT=IERR) LINE - LIST(:)='' - CALL STRSPLIT(LINE,LIST) - READ(LIST(1),'(I8)') TTIME(1) - READ(LIST(2),'(I6)') TTIME(2) - READ(LIST(3),*) XT - READ(LIST(4),*) YT - IF(SIZE(LIST).GE.5) TRCKT=LIST(5) - ELSE - READ (NDSTI, ERR=801,END=390,IOSTAT=IERR) TTIME, XT, YT, TRCKT - END IF + WRITE (NDST,9030) +#endif + ! + DO + ! + IF ( FORMI ) THEN + READ (NDSTI,'(A)',ERR=801,END=390,IOSTAT=IERR) LINE + LIST(:)='' + CALL STRSPLIT(LINE,LIST) + READ(LIST(1),'(I8)') TTIME(1) + READ(LIST(2),'(I6)') TTIME(2) + READ(LIST(3),*) XT + READ(LIST(4),*) YT + IF(SIZE(LIST).GE.5) TRCKT=LIST(5) + ELSE + READ (NDSTI, ERR=801,END=390,IOSTAT=IERR) TTIME, XT, YT, TRCKT + END IF #ifdef W3_T - NREAD = NREAD + 1 + NREAD = NREAD + 1 #endif -! -! 3.b Point before time interval -! - IF ( DSEC21(TIMEB,TTIME) .LT. 0. ) THEN + ! + ! 3.b Point before time interval + ! + IF ( DSEC21(TIMEB,TTIME) .LT. 0. ) THEN #ifdef W3_T1 - WRITE (NDST,9031) TTIME,FACTOR*XT,FACTOR*YT,'TOO EARLY' -#endif - CYCLE - END IF -! -! 3.c Point after time interval -! - IF ( DSEC21(TIMEE,TTIME) .GT. 0. ) THEN - BACKSPACE (NDSTI) + WRITE (NDST,9031) TTIME,FACTOR*XT,FACTOR*YT,'TOO EARLY' +#endif + CYCLE + END IF + ! + ! 3.c Point after time interval + ! + IF ( DSEC21(TIMEE,TTIME) .GT. 0. ) THEN + BACKSPACE (NDSTI) #ifdef W3_T - NREAD = NREAD - 1 + NREAD = NREAD - 1 #endif #ifdef W3_T1 - WRITE (NDST,9031) TTIME,FACTOR*XT,FACTOR*YT,'TOO LATE' -#endif - GOTO 399 - END IF -! -! 3.d Check time in interval -! - FLAG1 = DSEC21(TTIME,TIMEE) .GT. RTCHCK*DTOUT - FLAG2 = DSEC21(TIMEB,TTIME) .GT. RTCHCK*DTOUT -! -! 3.e Check point coordinates -! + WRITE (NDST,9031) TTIME,FACTOR*XT,FACTOR*YT,'TOO LATE' +#endif + GOTO 399 + END IF + ! + ! 3.d Check time in interval + ! + FLAG1 = DSEC21(TTIME,TIMEE) .GT. RTCHCK*DTOUT + FLAG2 = DSEC21(TIMEB,TTIME) .GT. RTCHCK*DTOUT + ! + ! 3.e Check point coordinates + ! -! 3.e.1 Initial identification of computational grid points to include. -! -! Find cell that encloses target point (note that the returned -! cell corner indices are adjusted for global wrapping and the -! coordinates are adjusted to avoid branch cut crossings) - INGRID = W3GFCL( GSU, XT, YT, IXX, IYY, XX, YY ) - IF ( .NOT. INGRID ) THEN + ! 3.e.1 Initial identification of computational grid points to include. + ! + ! Find cell that encloses target point (note that the returned + ! cell corner indices are adjusted for global wrapping and the + ! coordinates are adjusted to avoid branch cut crossings) + INGRID = W3GFCL( GSU, XT, YT, IXX, IYY, XX, YY ) + IF ( .NOT. INGRID ) THEN #ifdef W3_T1 - WRITE (NDST,9031) TTIME, FACTOR*XT, FACTOR*YT, & - 'OUT OF GRID' -#endif - CYCLE - END IF -! -! Change cell-corners from counter-clockwise to column-major order - IX = IXX(4); IY = IYY(4); - IXX(4) = IXX(3); IYY(4) = IYY(3); - IXX(3) = IX; IYY(3) = IY; -! -! 3.e.2 Optimize: omit points that are not strictly required. -! See "Remarks" + WRITE (NDST,9031) TTIME, FACTOR*XT, FACTOR*YT, & + 'OUT OF GRID' +#endif + CYCLE + END IF + ! + ! Change cell-corners from counter-clockwise to column-major order + IX = IXX(4); IY = IYY(4); + IXX(4) = IXX(3); IYY(4) = IYY(3); + IXX(3) = IX; IYY(3) = IY; + ! + ! 3.e.2 Optimize: omit points that are not strictly required. + ! See "Remarks" - IF(CMPRTRCK)THEN ! perform track compression + IF(CMPRTRCK)THEN ! perform track compression -! Project onto I-axis - RD = DPDX(IYY(1),IXX(1))*(XT-XX(1)) & + ! Project onto I-axis + RD = DPDX(IYY(1),IXX(1))*(XT-XX(1)) & + DPDY(IYY(1),IXX(1))*(YT-YY(1)) -! -! Collapse to left or right if within tolerance - IF ( RD .LT. RDCHCK ) THEN - IXX(2) = IXX(1) - IXX(4) = IXX(3) - ELSE IF ( RD .GT. 1.-RDCHCK ) THEN - IXX(1) = IXX(2) - IXX(3) = IXX(4) - END IF -! -! Project onto J-axis - RD = DQDX(IYY(1),IXX(1))*(XT-XX(1)) & + ! + ! Collapse to left or right if within tolerance + IF ( RD .LT. RDCHCK ) THEN + IXX(2) = IXX(1) + IXX(4) = IXX(3) + ELSE IF ( RD .GT. 1.-RDCHCK ) THEN + IXX(1) = IXX(2) + IXX(3) = IXX(4) + END IF + ! + ! Project onto J-axis + RD = DQDX(IYY(1),IXX(1))*(XT-XX(1)) & + DQDY(IYY(1),IXX(1))*(YT-YY(1)) -! -! Collapse to top or bottom if within tolerance - IF ( RD .LT. RDCHCK ) THEN - IYY(3) = IYY(1) - IYY(4) = IYY(2) - ELSE IF ( RD .GT. 1.-RDCHCK ) THEN - IYY(1) = IYY(3) - IYY(2) = IYY(4) - END IF + ! + ! Collapse to top or bottom if within tolerance + IF ( RD .LT. RDCHCK ) THEN + IYY(3) = IYY(1) + IYY(4) = IYY(2) + ELSE IF ( RD .GT. 1.-RDCHCK ) THEN + IYY(1) = IYY(3) + IYY(2) = IYY(4) + END IF - END IF ! IF(CMPRTRCK)THEN -! -! 3.f Mark the four corner points -! - DO J=1, 4 -! - IX = IXX(J) - IY = IYY(J) - IF(GTYPE .EQ. UNGTYPE) THEN - X = XGRD(1,IX) - Y = YGRD(1,IX) - ENDIF - MASK1(IY,IX) = MASK1(IY,IX) .OR. FLAG1 - MASK2(IY,IX) = MASK2(IY,IX) .OR. FLAG2 - TRCKID(IY,IX) = TRCKT -! + END IF ! IF(CMPRTRCK)THEN + ! + ! 3.f Mark the four corner points + ! + DO J=1, 4 + ! + IX = IXX(J) + IY = IYY(J) + IF(GTYPE .EQ. UNGTYPE) THEN + X = XGRD(1,IX) + Y = YGRD(1,IX) + ENDIF + MASK1(IY,IX) = MASK1(IY,IX) .OR. FLAG1 + MASK2(IY,IX) = MASK2(IY,IX) .OR. FLAG2 + TRCKID(IY,IX) = TRCKT + ! #ifdef W3_T1 - IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN - IF ( MAPST2(IY,IX) .EQ. 0 ) THEN - TSTLOC(4*J-3:4*J-1) = 'LND' - ELSE - TSTLOC(4*J-3:4*J-1) = 'XCL' - END IF - ELSE IF ( MAPSTA(IY,IX) .LT. 0 ) THEN - IF ( MAPST2(IY,IX) .EQ. 1 ) THEN - TSTLOC(4*J-3:4*J-1) = 'ICE' - ELSE IF ( MAPST2(IY,IX) .EQ. 2 ) THEN - TSTLOC(4*J-3:4*J-1) = 'DRY' - ELSE - TSTLOC(4*J-3:4*J-1) = 'DIS' - END IF - ELSE IF ( MAPSTA(IY,IX) .GT. 0 ) THEN - TSTLOC(4*J-3:4*J-1) = 'SEA' - END IF + IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN + IF ( MAPST2(IY,IX) .EQ. 0 ) THEN + TSTLOC(4*J-3:4*J-1) = 'LND' + ELSE + TSTLOC(4*J-3:4*J-1) = 'XCL' + END IF + ELSE IF ( MAPSTA(IY,IX) .LT. 0 ) THEN + IF ( MAPST2(IY,IX) .EQ. 1 ) THEN + TSTLOC(4*J-3:4*J-1) = 'ICE' + ELSE IF ( MAPST2(IY,IX) .EQ. 2 ) THEN + TSTLOC(4*J-3:4*J-1) = 'DRY' + ELSE + TSTLOC(4*J-3:4*J-1) = 'DIS' + END IF + ELSE IF ( MAPSTA(IY,IX) .GT. 0 ) THEN + TSTLOC(4*J-3:4*J-1) = 'SEA' + END IF #endif -! - END DO -! + ! + END DO + ! #ifdef W3_T1 - WRITE (NDST,9031) TTIME, FACTOR*XT, FACTOR*YT, TSTLOC, & - IXX(1), IXX(2), IYY(1), IYY(3), FLAG1, FLAG2 + WRITE (NDST,9031) TTIME, FACTOR*XT, FACTOR*YT, TSTLOC, & + IXX(1), IXX(2), IYY(1), IYY(3), FLAG1, FLAG2 #endif -! + ! #ifdef W3_T - NTRACK = NTRACK + 1 -#endif -! - END DO -! -! 3.g End of input file escape location -! - 390 CONTINUE + NTRACK = NTRACK + 1 +#endif + ! + END DO + ! + ! 3.g End of input file escape location + ! +390 CONTINUE #ifdef W3_T - WRITE (NDST,9033) -#endif - STOP = .TRUE. -! -! 3.h Read end escape location -! - 399 CONTINUE -! -! 3.h Mask test output -! + WRITE (NDST,9033) +#endif + STOP = .TRUE. + ! + ! 3.h Read end escape location + ! +399 CONTINUE + ! + ! 3.h Mask test output + ! #ifdef W3_T2 - WRITE (NDST,9035) - DO IY=NY,1,-1 - DO IX=1, NX - IF ( MASK1(IY,IX) ) THEN - MAPSTR(IX) = 'X' - ELSE IF ( MASK2(IY,IX) ) THEN - MAPSTR(IX) = 'x' - ELSE - MAPSTR(IX) = '.' - END IF - END DO - WRITE (NDST,9036) MAPSTR - END DO + WRITE (NDST,9035) + DO IY=NY,1,-1 + DO IX=1, NX + IF ( MASK1(IY,IX) ) THEN + MAPSTR(IX) = 'X' + ELSE IF ( MASK2(IY,IX) ) THEN + MAPSTR(IX) = 'x' + ELSE + MAPSTR(IX) = '.' + END IF + END DO + WRITE (NDST,9036) MAPSTR + END DO #endif -! -! 4. Write data for flagged locations ------------------------------- * -! + ! + ! 4. Write data for flagged locations ------------------------------- * + ! #ifdef W3_T - NLOCO = 0 - NSPECO = 0 + NLOCO = 0 + NSPECO = 0 #endif #ifdef W3_MPI - IT = IT0TRK - IROOT = NAPTRK - 1 - ALLOCATE ( STATUS(MPI_STATUS_SIZE,1) ) -#endif -! - DO IY=1, NY - DO IX=1, NX - IF ( MASK1(IY,IX) ) THEN -! - IF(GTYPE .EQ. UNGTYPE) THEN - X = XGRD(1,IX) - Y = YGRD(1,IX) - ELSE - X = XGRD(IY,IX) - Y = YGRD(IY,IX) - ENDIF + IT = IT0TRK + IROOT = NAPTRK - 1 + ALLOCATE ( STATUS(MPI_STATUS_SIZE,1) ) +#endif + ! + DO IY=1, NY + DO IX=1, NX + IF ( MASK1(IY,IX) ) THEN + ! + IF(GTYPE .EQ. UNGTYPE) THEN + X = XGRD(1,IX) + Y = YGRD(1,IX) + ELSE + X = XGRD(IY,IX) + Y = YGRD(IY,IX) + ENDIF #ifdef W3_MPI - IT = IT + 1 + IT = IT + 1 #endif #ifdef W3_T - NLOCO = NLOCO + 1 -#endif -! -! 4.a Status of point -! - IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN - IF ( MAPST2(IY,IX) .EQ. 0 ) THEN - TSTSTR = 'LND' - ELSE - TSTSTR = 'XCL' - END IF - ELSE IF ( MAPSTA(IY,IX) .LT. 0 ) THEN - IF ( MAPST2(IY,IX) .EQ. 1 ) THEN - TSTSTR = 'ICE' - ELSE IF ( MAPST2(IY,IX) .EQ. 2 ) THEN - TSTSTR = 'DRY' - ELSE - TSTSTR = 'DIS' - END IF - ELSE - TSTSTR = 'SEA' - END IF -! + NLOCO = NLOCO + 1 +#endif + ! + ! 4.a Status of point + ! + IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN + IF ( MAPST2(IY,IX) .EQ. 0 ) THEN + TSTSTR = 'LND' + ELSE + TSTSTR = 'XCL' + END IF + ELSE IF ( MAPSTA(IY,IX) .LT. 0 ) THEN + IF ( MAPST2(IY,IX) .EQ. 1 ) THEN + TSTSTR = 'ICE' + ELSE IF ( MAPST2(IY,IX) .EQ. 2 ) THEN + TSTSTR = 'DRY' + ELSE + TSTSTR = 'DIS' + END IF + ELSE + TSTSTR = 'SEA' + END IF + ! #ifdef W3_T - IF ( TSTSTR .EQ. 'SEA' ) NSPECO = NSPECO + 1 -#endif -! -! 4.b Determine where point is stored -! ( land point assumed stored on IAPROC = NAPTRK -! set to -99 in test output ) -! - ISEA = MAPFS(IY,IX) - IF ( ISEA .EQ. 0 ) THEN - ISPROC = NAPTRK + IF ( TSTSTR .EQ. 'SEA' ) NSPECO = NSPECO + 1 +#endif + ! + ! 4.b Determine where point is stored + ! ( land point assumed stored on IAPROC = NAPTRK + ! set to -99 in test output ) + ! + ISEA = MAPFS(IY,IX) + IF ( ISEA .EQ. 0 ) THEN + ISPROC = NAPTRK #ifdef W3_T3 - ISPT = -99 + ISPT = -99 #endif - ELSE - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + ELSE + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) #ifdef W3_T3 - ISPT = ISPROC + ISPT = ISPROC #endif - END IF + END IF #ifdef W3_MPI - IFROM = ISPROC - 1 + IFROM = ISPROC - 1 #endif -! 4.c Spectrum is at local processor, but this is not the NAPTRK -! Send the spectrum to NAPTRK + ! 4.c Spectrum is at local processor, but this is not the NAPTRK + ! Send the spectrum to NAPTRK - IF ( ISPROC.EQ.IAPROC .AND. IAPROC.NE.NAPTRK ) THEN + IF ( ISPROC.EQ.IAPROC .AND. IAPROC.NE.NAPTRK ) THEN #ifdef W3_T3 - WRITE (NDST,9040) IX, IY, ISEA, ISPT, 'SENDING' + WRITE (NDST,9040) IX, IY, ISEA, ISPT, 'SENDING' #endif #ifdef W3_MPI - CALL MPI_SEND ( A(1,1,JSEA), NSPEC, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IERR_MPI ) -#endif - END IF -! -! 4.d This is NAPTRK, perform all output -! - IF ( IAPROC .EQ. NAPTRK ) THEN -! -! 4.e Sea point, prepare data -! - IF ( TSTSTR .EQ. 'SEA' ) THEN -! - WX = UA(ISEA) * COS(UD(ISEA)) - WY = UA(ISEA) * SIN(UD(ISEA)) -! -! ..... Local spectra -! - IF ( IAPROC .EQ. ISPROC ) THEN - DO IK=1, NK - DO ITH=1, NTH - SPEC(IK,ITH) = & - TPI*A(ITH,IK,JSEA)*SIG(IK)/CG(IK,ISEA) - END DO - END DO -! -! ..... Non-local spectra -! - ELSE + CALL MPI_SEND ( A(1,1,JSEA), NSPEC, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IERR_MPI ) +#endif + END IF + ! + ! 4.d This is NAPTRK, perform all output + ! + IF ( IAPROC .EQ. NAPTRK ) THEN + ! + ! 4.e Sea point, prepare data + ! + IF ( TSTSTR .EQ. 'SEA' ) THEN + ! + WX = UA(ISEA) * COS(UD(ISEA)) + WY = UA(ISEA) * SIN(UD(ISEA)) + ! + ! ..... Local spectra + ! + IF ( IAPROC .EQ. ISPROC ) THEN + DO IK=1, NK + DO ITH=1, NTH + SPEC(IK,ITH) = & + TPI*A(ITH,IK,JSEA)*SIG(IK)/CG(IK,ISEA) + END DO + END DO + ! + ! ..... Non-local spectra + ! + ELSE #ifdef W3_T3 - WRITE (NDST,9040) IX, IY, ISEA, ISPT, & - 'RECEIVING' + WRITE (NDST,9040) IX, IY, ISEA, ISPT, & + 'RECEIVING' #endif #ifdef W3_MPI - CALL MPI_RECV (ASPTRK, NSPEC, MPI_REAL,& - IFROM, IT, MPI_COMM_WAVE, & - STATUS, IERR_MPI ) -#endif -! - DO IK=1, NK - DO ITH=1, NTH - SPEC(IK,ITH) = & - TPI*ASPTRK(ITH,IK)*SIG(IK)/CG(IK,ISEA) - END DO - END DO - END IF -! -! 4.e Sea point, write general data + spectrum -! - WRITE (NDSTO,ERR=811,IOSTAT=IERR) & - TIME, X, Y, TSTSTR, TRCKID(IY,IX) - WRITE (NDSTO,ERR=811,IOSTAT=IERR) & - DW(ISEA), CX(ISEA), CY(ISEA), WX, WY, & - UST(ISEA), AS(ISEA), SPEC -! -! 4.f Non-sea point, write -! - ELSE - WRITE (NDSTO,ERR=811,IOSTAT=IERR) & - TIME, X, Y, TSTSTR, TRCKID(IY,IX) -! -! ..... Sea and non-sea points processed -! - END IF -! -! ..... End of action at NAPTRK -! + CALL MPI_RECV (ASPTRK, NSPEC, MPI_REAL,& + IFROM, IT, MPI_COMM_WAVE, & + STATUS, IERR_MPI ) +#endif + ! + DO IK=1, NK + DO ITH=1, NTH + SPEC(IK,ITH) = & + TPI*ASPTRK(ITH,IK)*SIG(IK)/CG(IK,ISEA) + END DO + END DO + END IF + ! + ! 4.e Sea point, write general data + spectrum + ! + WRITE (NDSTO,ERR=811,IOSTAT=IERR) & + TIME, X, Y, TSTSTR, TRCKID(IY,IX) + WRITE (NDSTO,ERR=811,IOSTAT=IERR) & + DW(ISEA), CX(ISEA), CY(ISEA), WX, WY, & + UST(ISEA), AS(ISEA), SPEC + ! + ! 4.f Non-sea point, write + ! + ELSE + WRITE (NDSTO,ERR=811,IOSTAT=IERR) & + TIME, X, Y, TSTSTR, TRCKID(IY,IX) + ! + ! ..... Sea and non-sea points processed + ! + END IF + ! + ! ..... End of action at NAPTRK + ! #ifdef W3_T3 - WRITE (NDST,9040) IX, IY, ISEA, ISPT, 'WRITTEN', time + WRITE (NDST,9040) IX, IY, ISEA, ISPT, 'WRITTEN', time #endif - END IF -! -! ..... Close IF for mask flag (top section 4) -! - END IF -! -! ..... End of loop over map -! - END DO - END DO -! + END IF + ! + ! ..... Close IF for mask flag (top section 4) + ! + END IF + ! + ! ..... End of loop over map + ! + END DO + END DO + ! #ifdef W3_MPI - DEALLOCATE ( STATUS ) + DEALLOCATE ( STATUS ) #endif -! + ! #ifdef W3_T - WRITE (NDST,9090) NTRACK, NREAD, NSPECO, NLOCO -#endif -! - GOTO 888 -! -! Error Escape Locations -! - 800 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) FILEXT(:I), IERR - GOTO 880 -! - 801 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) FILEXT(:I), IERR - GOTO 880 -! - 802 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) FILEXT(:I) - GOTO 880 -! - 803 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) FILEXT(:I), IDSTRI, IDTST - GOTO 880 -! - 810 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1010) FILEXT(:I), IERR - GOTO 880 -! - 811 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1011) FILEXT(:I), IERR -! -! Disabeling output -! - 880 CONTINUE - ATOLAST(:,3) = TIME + WRITE (NDST,9090) NTRACK, NREAD, NSPECO, NLOCO +#endif + ! + GOTO 888 + ! + ! Error Escape Locations + ! +800 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) FILEXT(:I), IERR + GOTO 880 + ! +801 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) FILEXT(:I), IERR + GOTO 880 + ! +802 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) FILEXT(:I) + GOTO 880 + ! +803 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) FILEXT(:I), IDSTRI, IDTST + GOTO 880 + ! +810 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1010) FILEXT(:I), IERR + GOTO 880 + ! +811 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1011) FILEXT(:I), IERR + ! + ! Disabeling output + ! +880 CONTINUE + ATOLAST(:,3) = TIME #ifdef W3_T - WRITE (NDST,9080) -#endif -! - 888 CONTINUE -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & - ' INPUT FILE WITH TRACK DATA NOT FOUND ', & - '(FILE track_i.',A,' IOSTAT =',I6,')'/ & - ' TRACK OUTPUT DISABLED '/) - 1001 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & - ' ERROR IN READING FILE track_i.',A,' IOSTAT =',I6/& - ' (ADITIONAL) TRACK OUTPUT DISABLED '/) - 1002 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & - ' PREMATURE END OF FILE track_i.',A/ & - ' TRACK OUTPUT DISABLED '/) - 1003 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & - ' UNEXPECTED CONTENTS OF OF FILE track_i.',A/ & - ' EXPECTED : ',A/ & - ' FOUND : ',A/ & - ' TRACK OUTPUT DISABLED '/) - 1010 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & - ' ERROR IN OPENING OUTPUT FILE ', & - '(FILE track_o.',A,' IOSTAT =',I6,')'/ & - ' TRACK OUTPUT DISABLED '/) - 1011 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & - ' ERROR IN WRITING TO FILE track_o.',A,' IOSTAT =',I6/ & - ' (ADITIONAL) TRACK OUTPUT DISABLED '/) -! + WRITE (NDST,9080) +#endif + ! +888 CONTINUE + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & + ' INPUT FILE WITH TRACK DATA NOT FOUND ', & + '(FILE track_i.',A,' IOSTAT =',I6,')'/ & + ' TRACK OUTPUT DISABLED '/) +1001 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & + ' ERROR IN READING FILE track_i.',A,' IOSTAT =',I6/& + ' (ADITIONAL) TRACK OUTPUT DISABLED '/) +1002 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & + ' PREMATURE END OF FILE track_i.',A/ & + ' TRACK OUTPUT DISABLED '/) +1003 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & + ' UNEXPECTED CONTENTS OF OF FILE track_i.',A/ & + ' EXPECTED : ',A/ & + ' FOUND : ',A/ & + ' TRACK OUTPUT DISABLED '/) +1010 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & + ' ERROR IN OPENING OUTPUT FILE ', & + '(FILE track_o.',A,' IOSTAT =',I6,')'/ & + ' TRACK OUTPUT DISABLED '/) +1011 FORMAT (/' *** WAVEWATCH III WARNING IN W3IOTR : '/ & + ' ERROR IN WRITING TO FILE track_o.',A,' IOSTAT =',I6/ & + ' (ADITIONAL) TRACK OUTPUT DISABLED '/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3IOTR : MODEL TIME : ',I8.8,I7.6) - 9010 FORMAT (' LAST OUTPUT TIME : ',I8.8,I7.6/ & - ' OUTPUT TIME INC, : ',F6.0/ & - ' UNIT NUMBERS : ',2I4/ & - ' FORMAT FLAGS : ',L4) - 9011 FORMAT (' TEST W3IOTR : OPENING INPUT : ',A,' [',A,']') - 9012 FORMAT (' TEST W3IOTR : OPENING OUTPUT : ',A,' [',A,']') - 9015 FORMAT (' TEST W3IOTR : PREPARING MASKS') -#endif -! -#ifdef W3_T - 9020 FORMAT (' TEST W3IOTR : SHIFTING MASKS') - 9021 FORMAT (' TEST W3IOTR : OUTPUT TIME FRAME: ',I8.8,I7.6/ & - ' ',I8.8,I7.6) - 9022 FORMAT (' TEST W3IOTR : ENDING TIME REACHED') -#endif -! +9000 FORMAT (' TEST W3IOTR : MODEL TIME : ',I8.8,I7.6) +9010 FORMAT (' LAST OUTPUT TIME : ',I8.8,I7.6/ & + ' OUTPUT TIME INC, : ',F6.0/ & + ' UNIT NUMBERS : ',2I4/ & + ' FORMAT FLAGS : ',L4) +9011 FORMAT (' TEST W3IOTR : OPENING INPUT : ',A,' [',A,']') +9012 FORMAT (' TEST W3IOTR : OPENING OUTPUT : ',A,' [',A,']') +9015 FORMAT (' TEST W3IOTR : PREPARING MASKS') +9020 FORMAT (' TEST W3IOTR : SHIFTING MASKS') +9021 FORMAT (' TEST W3IOTR : OUTPUT TIME FRAME: ',I8.8,I7.6/ & + ' ',I8.8,I7.6) +9022 FORMAT (' TEST W3IOTR : ENDING TIME REACHED') +9033 FORMAT (' TEST W3IOTR : END OF INPUT FILE') +9034 FORMAT (' TEST W3IOTR : OUTPUT TYPE DISABLED') +9090 FORMAT (' TEST W3IOTR : NUMBER OF TRACK P: ',I10, & + ' (OUT OF',I10,')'/ & + ' NUMBER OF SPECTRA: ',I10, & + ' (OUT OF',I10,')') +9080 FORMAT (' TEST W3IOTR : OUTPUT TYPE DISABLED.') +#endif + ! #ifdef W3_T1 - 9030 FORMAT (' TEST W3IOTR : POINT-BY-POINT STATUS') - 9031 FORMAT (' ',I8.8,I7.6,2F9.2,1X,A,1X,4I4,2L3) -#endif -#ifdef W3_T - 9033 FORMAT (' TEST W3IOTR : END OF INPUT FILE') - 9034 FORMAT (' TEST W3IOTR : OUTPUT TYPE DISABLED') +9030 FORMAT (' TEST W3IOTR : POINT-BY-POINT STATUS') +9031 FORMAT (' ',I8.8,I7.6,2F9.2,1X,A,1X,4I4,2L3) #endif #ifdef W3_T2 - 9035 FORMAT (' TEST W3IOTR : DUMP OF MAPS : ') - 9036 FORMAT (132A1) +9035 FORMAT (' TEST W3IOTR : DUMP OF MAPS : ') +9036 FORMAT (132A1) #endif -! + ! #ifdef W3_T3 - 9040 FORMAT (' TEST W3IOTR : POINT',2I4,' (',I6,')', & - ' ON PROCESS',I4,2X,A,I10.8,I7.6) -#endif -#ifdef W3_T - 9090 FORMAT (' TEST W3IOTR : NUMBER OF TRACK P: ',I10, & - ' (OUT OF',I10,')'/ & - ' NUMBER OF SPECTRA: ',I10, & - ' (OUT OF',I10,')') -#endif -! -#ifdef W3_T - 9080 FORMAT (' TEST W3IOTR : OUTPUT TYPE DISABLED.') -#endif -!/ -!/ End of W3IOTR ----------------------------------------------------- / -!/ - END SUBROUTINE W3IOTR -!/ -!/ End of module W3IOTRMD -------------------------------------------- / -!/ - END MODULE W3IOTRMD +9040 FORMAT (' TEST W3IOTR : POINT',2I4,' (',I6,')', & + ' ON PROCESS',I4,2X,A,I10.8,I7.6) +#endif + !/ + !/ End of W3IOTR ----------------------------------------------------- / + !/ + END SUBROUTINE W3IOTR + !/ + !/ End of module W3IOTRMD -------------------------------------------- / + !/ +END MODULE W3IOTRMD diff --git a/model/src/w3meminfo.F90 b/model/src/w3meminfo.F90 index aa87f21cc..988de9c7d 100644 --- a/model/src/w3meminfo.F90 +++ b/model/src/w3meminfo.F90 @@ -1,261 +1,261 @@ module MallocInfo_m -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init pdlib part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init pdlib part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! use :: iso_c_binding implicit none -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3XXXX') + CALL STRACE (IENT, 'W3XXXX') #endif - - !> This structure type is used to return information about the dynamic memory allocator. - type, bind(c) :: MallInfo_t - !> This is the total size of memory allocated with sbrk by malloc, in bytes. - integer(c_int) :: arena - !> This is the number of chunks not in use. (The memory allocator internally gets chunks of memory from the operating system, and then carves them up to satisfy individual malloc requests; see Efficiency and Malloc.) - integer(c_int) :: ordblks - !> This field is unused. - integer(c_int) :: smblks - !> This is the total number of chunks allocated with mmap. - integer(c_int) :: hblks - !> This is the total size of memory allocated with mmap, in bytes. - integer(c_int) :: hblkhd - !> This field is unused. - integer(c_int) :: usmblks - !> This field is unused. - integer(c_int) :: fsmblks - !> This is the total size of memory occupied by chunks handed out by malloc. - integer(c_int) :: uordblks - !> This is the total size of memory occupied by free (not in use) chunks. - integer(c_int) :: fordblks - !> This is the size of the top-most releasable chunk that normally borders the end of the heap (i.e., the high end of the virtual address space’s data segment). - integer(c_int) :: keepcost + + !> This structure type is used to return information about the dynamic memory allocator. + type, bind(c) :: MallInfo_t + !> This is the total size of memory allocated with sbrk by malloc, in bytes. + integer(c_int) :: arena + !> This is the number of chunks not in use. (The memory allocator internally gets chunks of memory from the operating system, and then carves them up to satisfy individual malloc requests; see Efficiency and Malloc.) + integer(c_int) :: ordblks + !> This field is unused. + integer(c_int) :: smblks + !> This is the total number of chunks allocated with mmap. + integer(c_int) :: hblks + !> This is the total size of memory allocated with mmap, in bytes. + integer(c_int) :: hblkhd + !> This field is unused. + integer(c_int) :: usmblks + !> This field is unused. + integer(c_int) :: fsmblks + !> This is the total size of memory occupied by chunks handed out by malloc. + integer(c_int) :: uordblks + !> This is the total size of memory occupied by free (not in use) chunks. + integer(c_int) :: fordblks + !> This is the size of the top-most releasable chunk that normally borders the end of the heap (i.e., the high end of the virtual address space’s data segment). + integer(c_int) :: keepcost end type MallInfo_t - - interface - function mallinfo() bind(c, name="mallinfo") result(data) - use :: iso_c_binding - implicit none - - type, bind(c) :: MallInfo_t - integer(c_int) :: arena - integer(c_int) :: ordblks - integer(c_int) :: smblks - integer(c_int) :: hblks - integer(c_int) :: hblkhd - integer(c_int) :: usmblks - integer(c_int) :: fsmblks - integer(c_int) :: uordblks - integer(c_int) :: fordblks - integer(c_int) :: keepcost - end type MallInfo_t - type(MallInfo_t) :: data - end function mallinfo - end interface - - contains - + + interface + function mallinfo() bind(c, name="mallinfo") result(data) + use :: iso_c_binding + implicit none + + type, bind(c) :: MallInfo_t + integer(c_int) :: arena + integer(c_int) :: ordblks + integer(c_int) :: smblks + integer(c_int) :: hblks + integer(c_int) :: hblkhd + integer(c_int) :: usmblks + integer(c_int) :: fsmblks + integer(c_int) :: uordblks + integer(c_int) :: fordblks + integer(c_int) :: keepcost + end type MallInfo_t + type(MallInfo_t) :: data + end function mallinfo + end interface + +contains + subroutine getMallocInfo(malinfo) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | THomas Huxhorn (BGS IT&E GmbH | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init pdlib part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | THomas Huxhorn (BGS IT&E GmbH | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init pdlib part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! implicit none -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3XXXX') + CALL STRACE (IENT, 'W3XXXX') #endif type(MallInfo_t), intent(out) :: malinfo malinfo = mallinfo() end subroutine getMallocInfo - + subroutine printMallInfo(ihdnl,malinfo) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init pdlib part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init pdlib part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! implicit none -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3XXXX') + CALL STRACE (IENT, 'W3XXXX') #endif real :: ib2m integer(8) :: vmsize, vmRSS - integer, intent(in) :: ihdnl + integer, intent(in) :: ihdnl type(MallInfo_t), intent(in) :: malinfo - if (ihdnl .lt. 1) stop 'ihndl not set' + if (ihdnl .lt. 1) stop 'ihndl not set' ib2m=1./REAL(1024**2) vmsize = getVmSize() vmRSS = getVMRSS() @@ -265,89 +265,89 @@ subroutine printMallInfo(ihdnl,malinfo) !write(*,'(A72,I10)') "Total number of chunks allocated with mmap. ", malinfo%hblks !write(*,'(A72,I10)') "Number of chunks not in use. ", malinfo%ordblks !write(*,'(A72,2F20.10)') "Total size of memory occupied by free (not in use) chunks. ", malinfo%fordblks*ib2m - !write(*,'(A72,2F20.10)') "Size of the top-most releasable chunk borders end of the heap", malinfo%keepcost*ib2m - write(ihdnl,'(A72,2F20.10)') "VM size in proc ", vmsize/1024. + !write(*,'(A72,2F20.10)') "Size of the top-most releasable chunk borders end of the heap", malinfo%keepcost*ib2m + write(ihdnl,'(A72,2F20.10)') "VM size in proc ", vmsize/1024. write(ihdnl,'(A72,2F20.10)') "RSS size in prof ", vmRSS/1024. call flush(ihdnl) end subroutine printMallInfo -!VmPeak: Peak virtual memory usage -!VmSize: Current virtual memory usage -!VmLck: Current mlocked memory -!VmHWM: Peak resident set size -!VmRSS: Resident set size -!VmData: Size of "data" segment -!VmStk: Size of stack -!VmExe: Size of "text" segment -!VmLib: Shared library usage -!VmPTE: Pagetable entries size -!VmSwap: Swap space used + !VmPeak: Peak virtual memory usage + !VmSize: Current virtual memory usage + !VmLck: Current mlocked memory + !VmHWM: Peak resident set size + !VmRSS: Resident set size + !VmData: Size of "data" segment + !VmStk: Size of stack + !VmExe: Size of "text" segment + !VmLib: Shared library usage + !VmPTE: Pagetable entries size + !VmSwap: Swap space used function getVmSize() result(vmsize) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init pdlib part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init pdlib part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! implicit none -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3XXXX') + CALL STRACE (IENT, 'W3XXXX') #endif integer(8) :: vmsize character(len=80) :: stat_key, stat_value @@ -361,79 +361,79 @@ function getVmSize() result(vmsize) exit end if end do - 88 close(unit=1000) - if (vmsize == 0) goto 99 - return - ! - 99 print *, 'ERROR: procfs not mounted or not compatible' +88 close(unit=1000) + if (vmsize == 0) goto 99 + return + ! +99 print *, 'ERROR: procfs not mounted or not compatible' vmsize = -1 end function getVmSize function getVmRSS() result(vmRSS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init pdlib part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init pdlib part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! implicit none -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3XXXX') + CALL STRACE (IENT, 'W3XXXX') #endif integer(8) :: vmRSS character(len=80) :: stat_key, stat_value @@ -447,23 +447,23 @@ function getVmRSS() result(vmRSS) exit end if end do - 88 close(unit=1000) - if (vmRSS == 0) goto 99 - return - ! - 99 print *, 'ERROR: procfs not mounted or not compatible' +88 close(unit=1000) + if (vmRSS == 0) goto 99 + return + ! +99 print *, 'ERROR: procfs not mounted or not compatible' vmRSS = -1 end function getVmRSS - + end module MallocInfo_m !program test ! use MallocInfo_m ! implicit none -! type(MallInfo_t) :: mallinfos(10000) +! type(MallInfo_t) :: mallinfos(10000) ! integer :: i, nInfos ! integer, allocatable :: data(:) -! +! ! allocate(data(0)) ! nInfos = 0 ! do i=1, 10 @@ -471,20 +471,20 @@ end module MallocInfo_m ! deallocate(data) ! allocate(data(i*100000)) ! nInfos = nInfos+1 -! call getMallocInfo(mallinfos(nInfos)) +! call getMallocInfo(mallinfos(nInfos)) ! call printMallInfo(IAPROC,mallInfos(nInfos)) ! call sleep(1) ! end do - + ! do i=10, 1, -1 ! write(*,*) "Iteration",i ! deallocate(data) ! allocate(data(i*100000)) ! nInfos = nInfos+1 -! call getMallocInfo(mallinfos(nInfos)) -! call printMallInfo(IAPROC,mallInfos(nInfos)) +! call getMallocInfo(mallinfos(nInfos)) +! call printMallInfo(IAPROC,mallInfos(nInfos)) ! call sleep(1) ! end do - + ! write(*,*) "Total size of memory allocated with sbrk. min, mean, max", minval(mallinfos(1:nInfos)%arena), sum(mallinfos(1:nInfos)%arena)/nInfos, maxval(mallinfos(1:nInfos)%arena) !end program diff --git a/model/src/w3metamd.F90 b/model/src/w3metamd.F90 index e1e04da04..496f1a829 100644 --- a/model/src/w3metamd.F90 +++ b/model/src/w3metamd.F90 @@ -9,380 +9,380 @@ !> and a linked list construct for dynamic storage. !> !> ### Change log -!> Date | Ver | Comments +!> Date | Ver | Comments !> ------------|------|--------- -!> 16-Dec-2020 | 7.12 | Creation +!> 16-Dec-2020 | 7.12 | Creation !> !> @author Chris Bunney @date 16-Dec-2020 !> !/ ------------------------------------------------------------------- / - MODULE W3METAMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 16-Dec-2020 | -!/ +-----------------------------------+ -!/ -!/ 16-Dec-2020 : Creation ( version 7.12 ) -!/ -! 1. Purpose : -! -! Provides types for handling "meta data" (attribute/value pairs) -! and a linked list construct for dynamic storage. -!/ ------------------------------------------------------------------- / - - !> Value to represent "unset" character variable - CHARACTER(LEN=*), PARAMETER :: UNSETC = "unset" - !> Value to represent "unset" real variable - REAL, PARAMETER :: UNSETR = HUGE(1.0) - - !> Type for storing a user defined metadata pair as linked list element - TYPE META_PAIR_T - CHARACTER(LEN=64) :: ATTNAME = UNSETC !< Attribute name - CHARACTER(LEN=120) :: ATTVAL = UNSETC !< Attribute value - CHARACTER :: TYPE = 'c' !< Attribute type (c,i,f/r) - TYPE(META_PAIR_T), POINTER :: NEXT !< Pointer to next node - END TYPE META_PAIR_T - - !> Linked list of meta data pairs - TYPE META_LIST_T - TYPE (META_PAIR_T), POINTER :: HEAD => NULL(), TAIL => NULL() - INTEGER :: N = 0 !< Num elements in list - END TYPE META_LIST_T - - !> Interface to facilitate adding real/int/character values to list - INTERFACE META_LIST_APPEND - MODULE PROCEDURE META_LIST_APPEND_M !< Append a META_PAIR_T - MODULE PROCEDURE META_LIST_APPEND_R !< Append a REAL value - MODULE PROCEDURE META_LIST_APPEND_I !< Append an INTEGER value - MODULE PROCEDURE META_LIST_APPEND_C !< Append a CHARACTER value - END INTERFACE META_LIST_APPEND - - CONTAINS - - -!/ ------------------------------------------------------------------- / -!> @brief Deletes all entries in list. -!> -!> @param[in,out] LIST The list to clear. -!> -!> @author Chris Bunney -!/ ------------------------------------------------------------------- / - SUBROUTINE DEL_META_LIST(LIST) - - IMPLICIT NONE - - TYPE(META_LIST_T), INTENT(INOUT) :: LIST -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(META_PAIR_T), POINTER :: P - - IF(.NOT. ASSOCIATED(LIST%HEAD)) RETURN - - DO - NULLIFY(P) - IF(ASSOCIATED(LIST%HEAD%NEXT)) P => LIST%HEAD%NEXT - DEALLOCATE(LIST%HEAD) - IF(.NOT. ASSOCIATED(P)) EXIT - LIST%HEAD => P - ENDDO - - NULLIFY(LIST%HEAD) - NULLIFY(LIST%TAIL) - LIST%N = 0 - - END SUBROUTINE DEL_META_LIST - - -!/ ------------------------------------------------------------------- / -!> @brief Create a deep copy of a meta data list -!> -!> @details A "deep copy" ensures that a copy is made of the underlying -!> linked list, rather than a simply copy of the pointers to the -!> existing list. -!> -!> @param[in] LIST The list to copy -!> -!> @returns A new META_LIST_T -!> -!> @author Chris Bunney -!> -!/ ------------------------------------------------------------------- / - FUNCTION COPY_META_LIST(LIST) RESULT(COPY) - - IMPLICIT NONE - - TYPE(META_LIST_T), INTENT(IN) :: LIST - TYPE(META_LIST_T) :: COPY -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(META_PAIR_T), POINTER :: P - - NULLIFY(COPY%HEAD) - NULLIFY(COPY%TAIL) - COPY%N = 0 - IF(LIST%N .EQ. 0) RETURN - - ! Deep copy list - P => LIST%HEAD - DO - CALL META_LIST_APPEND_M(COPY, P) - IF(.NOT. ASSOCIATED(P%NEXT)) EXIT - P => P%NEXT - ENDDO - - END FUNCTION COPY_META_LIST - - -!/ ------------------------------------------------------------------- / -!> @brief Prints meta pairs in list to screen -!> -!> @param[in] LIST Linked list of meta data to print -!> -!> @author Chris Bunney -!/ ------------------------------------------------------------------- / - SUBROUTINE PRINT_META_LIST(LIST) - - IMPLICIT NONE - - TYPE(META_LIST_T), INTENT(IN) :: LIST -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(META_PAIR_T), POINTER :: P - - IF(.NOT. ASSOCIATED(LIST%HEAD)) THEN - WRITE(*,*) 'List empty.' - RETURN - ENDIF - - P => LIST%HEAD - DO - WRITE(*, '(A," [",A1,"] : ", A)') TRIM(P%ATTNAME), P%TYPE, & - TRIM(P%ATTVAL) - IF(.NOT. ASSOCIATED(P%NEXT)) EXIT - P => P%NEXT - ENDDO - - END SUBROUTINE PRINT_META_LIST - - -!/ ------------------------------------------------------------------- / -!> @brief Append META_PAIR_T object to list -!> -!> @param[in,out] LIST The list to append to -!> @param[in] META The META_PAIR_T object to append. -!> -!> @author Chris Bunney -!/ ------------------------------------------------------------------- / - SUBROUTINE META_LIST_APPEND_M(LIST, META) - - IMPLICIT NONE - - TYPE(META_LIST_T), INTENT(INOUT) :: LIST - TYPE(META_PAIR_T), INTENT(IN) :: META -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(META_PAIR_T), POINTER :: P - - ALLOCATE(P) - - ! Empty list? - IF(LIST%N .EQ. 0) THEN +MODULE W3METAMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 16-Dec-2020 | + !/ +-----------------------------------+ + !/ + !/ 16-Dec-2020 : Creation ( version 7.12 ) + !/ + ! 1. Purpose : + ! + ! Provides types for handling "meta data" (attribute/value pairs) + ! and a linked list construct for dynamic storage. + !/ ------------------------------------------------------------------- / + + !> Value to represent "unset" character variable + CHARACTER(LEN=*), PARAMETER :: UNSETC = "unset" + !> Value to represent "unset" real variable + REAL, PARAMETER :: UNSETR = HUGE(1.0) + + !> Type for storing a user defined metadata pair as linked list element + TYPE META_PAIR_T + CHARACTER(LEN=64) :: ATTNAME = UNSETC !< Attribute name + CHARACTER(LEN=120) :: ATTVAL = UNSETC !< Attribute value + CHARACTER :: TYPE = 'c' !< Attribute type (c,i,f/r) + TYPE(META_PAIR_T), POINTER :: NEXT !< Pointer to next node + END TYPE META_PAIR_T + + !> Linked list of meta data pairs + TYPE META_LIST_T + TYPE (META_PAIR_T), POINTER :: HEAD => NULL(), TAIL => NULL() + INTEGER :: N = 0 !< Num elements in list + END TYPE META_LIST_T + + !> Interface to facilitate adding real/int/character values to list + INTERFACE META_LIST_APPEND + MODULE PROCEDURE META_LIST_APPEND_M !< Append a META_PAIR_T + MODULE PROCEDURE META_LIST_APPEND_R !< Append a REAL value + MODULE PROCEDURE META_LIST_APPEND_I !< Append an INTEGER value + MODULE PROCEDURE META_LIST_APPEND_C !< Append a CHARACTER value + END INTERFACE META_LIST_APPEND + +CONTAINS + + + !/ ------------------------------------------------------------------- / + !> @brief Deletes all entries in list. + !> + !> @param[in,out] LIST The list to clear. + !> + !> @author Chris Bunney + !/ ------------------------------------------------------------------- / + SUBROUTINE DEL_META_LIST(LIST) + + IMPLICIT NONE + + TYPE(META_LIST_T), INTENT(INOUT) :: LIST + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(META_PAIR_T), POINTER :: P + + IF(.NOT. ASSOCIATED(LIST%HEAD)) RETURN + + DO + NULLIFY(P) + IF(ASSOCIATED(LIST%HEAD%NEXT)) P => LIST%HEAD%NEXT + DEALLOCATE(LIST%HEAD) + IF(.NOT. ASSOCIATED(P)) EXIT + LIST%HEAD => P + ENDDO + + NULLIFY(LIST%HEAD) + NULLIFY(LIST%TAIL) + LIST%N = 0 + + END SUBROUTINE DEL_META_LIST + + + !/ ------------------------------------------------------------------- / + !> @brief Create a deep copy of a meta data list + !> + !> @details A "deep copy" ensures that a copy is made of the underlying + !> linked list, rather than a simply copy of the pointers to the + !> existing list. + !> + !> @param[in] LIST The list to copy + !> + !> @returns A new META_LIST_T + !> + !> @author Chris Bunney + !> + !/ ------------------------------------------------------------------- / + FUNCTION COPY_META_LIST(LIST) RESULT(COPY) + + IMPLICIT NONE + + TYPE(META_LIST_T), INTENT(IN) :: LIST + TYPE(META_LIST_T) :: COPY + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(META_PAIR_T), POINTER :: P + + NULLIFY(COPY%HEAD) + NULLIFY(COPY%TAIL) + COPY%N = 0 + IF(LIST%N .EQ. 0) RETURN + + ! Deep copy list + P => LIST%HEAD + DO + CALL META_LIST_APPEND_M(COPY, P) + IF(.NOT. ASSOCIATED(P%NEXT)) EXIT + P => P%NEXT + ENDDO + + END FUNCTION COPY_META_LIST + + + !/ ------------------------------------------------------------------- / + !> @brief Prints meta pairs in list to screen + !> + !> @param[in] LIST Linked list of meta data to print + !> + !> @author Chris Bunney + !/ ------------------------------------------------------------------- / + SUBROUTINE PRINT_META_LIST(LIST) + + IMPLICIT NONE + + TYPE(META_LIST_T), INTENT(IN) :: LIST + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(META_PAIR_T), POINTER :: P + + IF(.NOT. ASSOCIATED(LIST%HEAD)) THEN + WRITE(*,*) 'List empty.' + RETURN + ENDIF + + P => LIST%HEAD + DO + WRITE(*, '(A," [",A1,"] : ", A)') TRIM(P%ATTNAME), P%TYPE, & + TRIM(P%ATTVAL) + IF(.NOT. ASSOCIATED(P%NEXT)) EXIT + P => P%NEXT + ENDDO + + END SUBROUTINE PRINT_META_LIST + + + !/ ------------------------------------------------------------------- / + !> @brief Append META_PAIR_T object to list + !> + !> @param[in,out] LIST The list to append to + !> @param[in] META The META_PAIR_T object to append. + !> + !> @author Chris Bunney + !/ ------------------------------------------------------------------- / + SUBROUTINE META_LIST_APPEND_M(LIST, META) + + IMPLICIT NONE + + TYPE(META_LIST_T), INTENT(INOUT) :: LIST + TYPE(META_PAIR_T), INTENT(IN) :: META + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(META_PAIR_T), POINTER :: P + + ALLOCATE(P) + + ! Empty list? + IF(LIST%N .EQ. 0) THEN !IF(.NOT. ASSOCIATED(LIST%HEAD)) THEN - LIST%HEAD => P - ELSE - LIST%TAIL%NEXT => P - ENDIF - LIST%TAIL => P - - P%ATTNAME = META%ATTNAME - P%ATTVAL = META%ATTVAL - P%TYPE = META%TYPE - - NULLIFY(P%NEXT) - - LIST%N = LIST%N + 1 - - END SUBROUTINE META_LIST_APPEND_M - - -!/ ------------------------------------------------------------------- / -!> @brief Append REAL value attribute to list -!> -!> @param[in,out] LIST The list to append to -!> @param[in] ATTNAME The attribute name -!> @param[in] RVAL The attribute value (REAL) -!> -!> @author Chris Bunney -!/ ------------------------------------------------------------------- / - SUBROUTINE META_LIST_APPEND_R(LIST, ATTNAME, RVAL) - - IMPLICIT NONE - - TYPE(META_LIST_T), INTENT(INOUT) :: LIST - CHARACTER(*), INTENT(IN) :: ATTNAME - REAL, INTENT(IN) :: RVAL -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(META_PAIR_T) :: META - - META%ATTNAME = ATTNAME - WRITE(META%ATTVAL,*) RVAL - META%TYPE = 'r' - CALL META_LIST_APPEND(LIST, META) - - END SUBROUTINE META_LIST_APPEND_R - - -!/ ------------------------------------------------------------------- / -!> @brief Append INTEGER value attribute to list -!> -!> @param[in,out] LIST The list to append to -!> @param[in] ATTNAME The attribute name -!> @param[in] IVAL The attribute value (INTEGER) -!> -!> @author Chris Bunney -!/ ------------------------------------------------------------------- / - SUBROUTINE META_LIST_APPEND_I(LIST, ATTNAME, IVAL) - - IMPLICIT NONE - - TYPE(META_LIST_T), INTENT(INOUT) :: LIST - CHARACTER(*), INTENT(IN) :: ATTNAME - INTEGER, INTENT(IN) :: IVAL -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(META_PAIR_T) :: META - - META%ATTNAME = ATTNAME - WRITE(META%ATTVAL,*) IVAL - META%TYPE = 'i' - CALL META_LIST_APPEND(LIST, META) - - END SUBROUTINE META_LIST_APPEND_I - - -!/ ------------------------------------------------------------------- / -!> @brief Append CHARACTER string value attribute to list -!> -!> @param[in,out] LIST The list to append to -!> @param[in] ATTNAME The attribute name -!> @param[in] SVAL The attribute value (CHARACTER string) -!> -!> @author Chris Bunney -!/ ------------------------------------------------------------------- / - SUBROUTINE META_LIST_APPEND_C(LIST, ATTNAME, SVAL) - - IMPLICIT NONE - - TYPE(META_LIST_T), INTENT(INOUT) :: LIST - CHARACTER(*), INTENT(IN) :: ATTNAME, SVAL -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(META_PAIR_T) :: META - - META%ATTNAME = ATTNAME - META%ATTVAL = SVAL - META%TYPE = 'c' - CALL META_LIST_APPEND(LIST, META) - - END SUBROUTINE META_LIST_APPEND_C - - -!/ ------------------------------------------------------------------- / -!> @brief Find (first) entry in list with matching attname -!> -!> @param[in] LIST List to search -!> @param[in] ATTN Attribute name to search for -!> @param[out] META Meta data type to store matched result in -!> @param[out] ERR Error status (0=Found, 1=Empty list, 2=Not found) -!> -!> @author Chris Bunney -!/ ------------------------------------------------------------------- / - SUBROUTINE META_LIST_FIND_ATTR(LIST, ATTN, META, ERR) - IMPLICIT NONE - - TYPE(META_LIST_T), INTENT(IN) :: LIST - CHARACTER(*), INTENT(IN) :: ATTN - TYPE(META_PAIR_T), POINTER, INTENT(OUT) :: META - INTEGER, INTENT(OUT) :: ERR - - ERR = 0 - - ! Empty list? - IF(.NOT. ASSOCIATED(LIST%HEAD)) THEN - ERR = 1 + LIST%HEAD => P + ELSE + LIST%TAIL%NEXT => P + ENDIF + LIST%TAIL => P + + P%ATTNAME = META%ATTNAME + P%ATTVAL = META%ATTVAL + P%TYPE = META%TYPE + + NULLIFY(P%NEXT) + + LIST%N = LIST%N + 1 + + END SUBROUTINE META_LIST_APPEND_M + + + !/ ------------------------------------------------------------------- / + !> @brief Append REAL value attribute to list + !> + !> @param[in,out] LIST The list to append to + !> @param[in] ATTNAME The attribute name + !> @param[in] RVAL The attribute value (REAL) + !> + !> @author Chris Bunney + !/ ------------------------------------------------------------------- / + SUBROUTINE META_LIST_APPEND_R(LIST, ATTNAME, RVAL) + + IMPLICIT NONE + + TYPE(META_LIST_T), INTENT(INOUT) :: LIST + CHARACTER(*), INTENT(IN) :: ATTNAME + REAL, INTENT(IN) :: RVAL + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(META_PAIR_T) :: META + + META%ATTNAME = ATTNAME + WRITE(META%ATTVAL,*) RVAL + META%TYPE = 'r' + CALL META_LIST_APPEND(LIST, META) + + END SUBROUTINE META_LIST_APPEND_R + + + !/ ------------------------------------------------------------------- / + !> @brief Append INTEGER value attribute to list + !> + !> @param[in,out] LIST The list to append to + !> @param[in] ATTNAME The attribute name + !> @param[in] IVAL The attribute value (INTEGER) + !> + !> @author Chris Bunney + !/ ------------------------------------------------------------------- / + SUBROUTINE META_LIST_APPEND_I(LIST, ATTNAME, IVAL) + + IMPLICIT NONE + + TYPE(META_LIST_T), INTENT(INOUT) :: LIST + CHARACTER(*), INTENT(IN) :: ATTNAME + INTEGER, INTENT(IN) :: IVAL + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(META_PAIR_T) :: META + + META%ATTNAME = ATTNAME + WRITE(META%ATTVAL,*) IVAL + META%TYPE = 'i' + CALL META_LIST_APPEND(LIST, META) + + END SUBROUTINE META_LIST_APPEND_I + + + !/ ------------------------------------------------------------------- / + !> @brief Append CHARACTER string value attribute to list + !> + !> @param[in,out] LIST The list to append to + !> @param[in] ATTNAME The attribute name + !> @param[in] SVAL The attribute value (CHARACTER string) + !> + !> @author Chris Bunney + !/ ------------------------------------------------------------------- / + SUBROUTINE META_LIST_APPEND_C(LIST, ATTNAME, SVAL) + + IMPLICIT NONE + + TYPE(META_LIST_T), INTENT(INOUT) :: LIST + CHARACTER(*), INTENT(IN) :: ATTNAME, SVAL + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(META_PAIR_T) :: META + + META%ATTNAME = ATTNAME + META%ATTVAL = SVAL + META%TYPE = 'c' + CALL META_LIST_APPEND(LIST, META) + + END SUBROUTINE META_LIST_APPEND_C + + + !/ ------------------------------------------------------------------- / + !> @brief Find (first) entry in list with matching attname + !> + !> @param[in] LIST List to search + !> @param[in] ATTN Attribute name to search for + !> @param[out] META Meta data type to store matched result in + !> @param[out] ERR Error status (0=Found, 1=Empty list, 2=Not found) + !> + !> @author Chris Bunney + !/ ------------------------------------------------------------------- / + SUBROUTINE META_LIST_FIND_ATTR(LIST, ATTN, META, ERR) + IMPLICIT NONE + + TYPE(META_LIST_T), INTENT(IN) :: LIST + CHARACTER(*), INTENT(IN) :: ATTN + TYPE(META_PAIR_T), POINTER, INTENT(OUT) :: META + INTEGER, INTENT(OUT) :: ERR + + ERR = 0 + + ! Empty list? + IF(.NOT. ASSOCIATED(LIST%HEAD)) THEN + ERR = 1 + RETURN + ENDIF + + META => LIST%HEAD + + DO + IF(TRIM(META%ATTNAME) == TRIM(ATTN)) RETURN + IF(.NOT. ASSOCIATED(META%NEXT)) EXIT + META => META%NEXT + ENDDO + + ! Not found + NULLIFY(META) + ERR = 2 + + END SUBROUTINE META_LIST_FIND_ATTR + + + !/ ------------------------------------------------------------------- / + !> @brief Tests whether list contains an entry with specified attname + !> + !> @param[in] LIST The list to search + !> @param[in] ATTN Attribute name to search for + !> + !> @returns LOGICAL: True if match found, False otherwise. + !> + !> @author Chris Bunney + !/ ------------------------------------------------------------------- / + FUNCTION META_LIST_HAS_ATTR(LIST, ATTN) RESULT(FOUND) + + IMPLICIT NONE + + TYPE(META_LIST_T), INTENT(IN) :: LIST + CHARACTER(*), INTENT(IN) :: ATTN + LOGICAL :: FOUND + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(META_PAIR_T), POINTER :: P + + FOUND = .FALSE. + + ! Empty list? + IF(.NOT. ASSOCIATED(LIST%HEAD)) THEN + RETURN + ENDIF + + P => LIST%HEAD + + DO + IF(TRIM(P%ATTNAME) == TRIM(ATTN)) THEN + FOUND = .TRUE. RETURN ENDIF - META => LIST%HEAD - - DO - IF(TRIM(META%ATTNAME) == TRIM(ATTN)) RETURN - IF(.NOT. ASSOCIATED(META%NEXT)) EXIT - META => META%NEXT - ENDDO - - ! Not found - NULLIFY(META) - ERR = 2 + IF(.NOT. ASSOCIATED(P%NEXT)) EXIT + P => P%NEXT + ENDDO - END SUBROUTINE META_LIST_FIND_ATTR + END FUNCTION META_LIST_HAS_ATTR - -!/ ------------------------------------------------------------------- / -!> @brief Tests whether list contains an entry with specified attname -!> -!> @param[in] LIST The list to search -!> @param[in] ATTN Attribute name to search for -!> -!> @returns LOGICAL: True if match found, False otherwise. -!> -!> @author Chris Bunney -!/ ------------------------------------------------------------------- / - FUNCTION META_LIST_HAS_ATTR(LIST, ATTN) RESULT(FOUND) - - IMPLICIT NONE - - TYPE(META_LIST_T), INTENT(IN) :: LIST - CHARACTER(*), INTENT(IN) :: ATTN - LOGICAL :: FOUND -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(META_PAIR_T), POINTER :: P - - FOUND = .FALSE. - - ! Empty list? - IF(.NOT. ASSOCIATED(LIST%HEAD)) THEN - RETURN - ENDIF - - P => LIST%HEAD - - DO - IF(TRIM(P%ATTNAME) == TRIM(ATTN)) THEN - FOUND = .TRUE. - RETURN - ENDIF - - IF(.NOT. ASSOCIATED(P%NEXT)) EXIT - P => P%NEXT - ENDDO - - END FUNCTION META_LIST_HAS_ATTR - -!/ ------------------------------------------------------------------- / - END MODULE W3METAMD + !/ ------------------------------------------------------------------- / +END MODULE W3METAMD !/ ------------------------------------------------------------------- / diff --git a/model/src/w3nmlbouncmd.F90 b/model/src/w3nmlbouncmd.F90 index 9e803188b..4d8ef25b2 100644 --- a/model/src/w3nmlbouncmd.F90 +++ b/model/src/w3nmlbouncmd.F90 @@ -1,22 +1,22 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3NMLBOUNCMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutines. -!/ -! 1. Purpose : -! -! Manages namelists from configuration file ww3_bounc.nml for ww3_bounc program -! +#include "w3macros.h" !/ ------------------------------------------------------------------- / +MODULE W3NMLBOUNCMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutines. + !/ + ! 1. Purpose : + ! + ! Manages namelists from configuration file ww3_bounc.nml for ww3_bounc program + ! + !/ ------------------------------------------------------------------- / ! module defaults IMPLICIT NONE @@ -39,71 +39,71 @@ MODULE W3NMLBOUNCMD - CONTAINS -!/ ------------------------------------------------------------------- / +CONTAINS + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLBOUNC (NDSI, INFILE, NML_BOUND, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! -! 1. Purpose : -! -! Reads all the namelist to define the input boundary -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! INFILE Char. -! NML_BOUND type. -! IERR Int. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_BOUND_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! WW3_BOUNC Prog. N/A Preprocess input boundaries. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! + ! 1. Purpose : + ! + ! Reads all the namelist to define the input boundary + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! INFILE Char. + ! NML_BOUND type. + ! IERR Int. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_BOUND_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! WW3_BOUNC Prog. N/A Preprocess input boundaries. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -113,18 +113,18 @@ SUBROUTINE W3NMLBOUNC (NDSI, INFILE, NML_BOUND, IERR) TYPE(NML_BOUND_T), INTENT(INOUT) :: NML_BOUND INTEGER, INTENT(OUT) :: IERR #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'W3NMLBOUNC') + CALL STRACE (IENT, 'W3NMLBOUNC') #endif ! open namelist log file NDSN = 3 OPEN (NDSN, file=TRIM(INFILE)//'.log', form='formatted', iostat=IERR) - IF (IERR.NE.0) THEN + IF (IERR.NE.0) THEN WRITE (NDSE,'(A)') 'ERROR: open full nml file '//TRIM(INFILE)//'.log failed' RETURN END IF @@ -147,74 +147,74 @@ SUBROUTINE W3NMLBOUNC (NDSI, INFILE, NML_BOUND, IERR) END SUBROUTINE W3NMLBOUNC -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_BOUND_NML (NDSI, NML_BOUND) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_BOUND Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLBOUNC Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_BOUND Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLBOUNC Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -227,12 +227,12 @@ SUBROUTINE READ_BOUND_NML (NDSI, NML_BOUND) TYPE(NML_BOUND_T) :: BOUND NAMELIST /BOUND_NML/ BOUND #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_BOUND_NML') + CALL STRACE (IENT, 'READ_BOUND_NML') #endif ! set default values for track structure @@ -246,8 +246,8 @@ SUBROUTINE READ_BOUND_NML (NDSI, NML_BOUND) READ (NDSI, nml=BOUND_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_BOUND_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_BOUND_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (1) END IF @@ -256,7 +256,7 @@ SUBROUTINE READ_BOUND_NML (NDSI, NML_BOUND) END SUBROUTINE READ_BOUND_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -265,83 +265,83 @@ END SUBROUTINE READ_BOUND_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_BOUND_NML (NML_BOUND) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_BOUND Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLBOUNC Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_BOUND Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLBOUNC Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_BOUND_T), INTENT(IN) :: NML_BOUND #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_BOUND_NML') + CALL STRACE (IENT, 'REPORT_BOUND_NML') #endif - WRITE (MSG,'(A)') 'BOUND % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'MODE = ', TRIM(NML_BOUND%MODE) - WRITE (NDSN,11) TRIM(MSG),'INTERP = ', NML_BOUND%INTERP - WRITE (NDSN,11) TRIM(MSG),'VERBOSE = ', NML_BOUND%VERBOSE - WRITE (NDSN,10) TRIM(MSG),'FILE = ', TRIM(NML_BOUND%FILE) + WRITE (MSG,'(A)') 'BOUND % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'MODE = ', TRIM(NML_BOUND%MODE) + WRITE (NDSN,11) TRIM(MSG),'INTERP = ', NML_BOUND%INTERP + WRITE (NDSN,11) TRIM(MSG),'VERBOSE = ', NML_BOUND%VERBOSE + WRITE (NDSN,10) TRIM(MSG),'FILE = ', TRIM(NML_BOUND%FILE) 10 FORMAT (A,2X,A,A) @@ -349,7 +349,7 @@ SUBROUTINE REPORT_BOUND_NML (NML_BOUND) END SUBROUTINE REPORT_BOUND_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -357,54 +357,3 @@ END SUBROUTINE REPORT_BOUND_NML END MODULE W3NMLBOUNCMD !/ ------------------------------------------------------------------- / - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/model/src/w3nmlboundmd.F90 b/model/src/w3nmlboundmd.F90 index 1c4b54644..c17378bf1 100644 --- a/model/src/w3nmlboundmd.F90 +++ b/model/src/w3nmlboundmd.F90 @@ -1,22 +1,22 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3NMLBOUNDMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2021 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutines. -!/ -! 1. Purpose : -! -! Manages namelists from configuration file ww3_bound.nml for ww3_bound program -! +#include "w3macros.h" !/ ------------------------------------------------------------------- / +MODULE W3NMLBOUNDMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2021 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutines. + !/ + ! 1. Purpose : + ! + ! Manages namelists from configuration file ww3_bound.nml for ww3_bound program + ! + !/ ------------------------------------------------------------------- / ! module defaults IMPLICIT NONE @@ -39,70 +39,70 @@ MODULE W3NMLBOUNDMD - CONTAINS -!/ ------------------------------------------------------------------- / +CONTAINS + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLBOUND (NDSI, INFILE, NML_BOUND, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2021 | -!/ +-----------------------------------+ -!/ -! -! 1. Purpose : -! -! Reads all the namelist to define the input boundary -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! INFILE Char. -! NML_BOUND type. -! IERR Int. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_BOUND_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! WW3_BOUND Prog. N/A Preprocess input boundaries. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2021 | + !/ +-----------------------------------+ + !/ + ! + ! 1. Purpose : + ! + ! Reads all the namelist to define the input boundary + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! INFILE Char. + ! NML_BOUND type. + ! IERR Int. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_BOUND_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! WW3_BOUND Prog. N/A Preprocess input boundaries. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE -!/S USE W3SERVMD, ONLY: STRACE + !/S USE W3SERVMD, ONLY: STRACE IMPLICIT NONE @@ -110,15 +110,15 @@ SUBROUTINE W3NMLBOUND (NDSI, INFILE, NML_BOUND, IERR) CHARACTER*(*), INTENT(IN) :: INFILE !< input file name TYPE(NML_BOUND_T), INTENT(INOUT) :: NML_BOUND !< bound structure INTEGER, INTENT(OUT) :: IERR !< error code -!/S INTEGER, SAVE :: IENT = 0 !< strace error code + !/S INTEGER, SAVE :: IENT = 0 !< strace error code IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLBOUND') + !/S CALL STRACE (IENT, 'W3NMLBOUND') ! open namelist log file NDSN = 3 OPEN (NDSN, file=TRIM(INFILE)//'.log', form='formatted', iostat=IERR) - IF (IERR.NE.0) THEN + IF (IERR.NE.0) THEN WRITE (NDSE,'(A)') 'ERROR: open full nml file '//TRIM(INFILE)//'.log failed' RETURN END IF @@ -141,73 +141,73 @@ SUBROUTINE W3NMLBOUND (NDSI, INFILE, NML_BOUND, IERR) END SUBROUTINE W3NMLBOUND -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_BOUND_NML (NDSI, NML_BOUND) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2021 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_BOUND Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLBOUND Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2021 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_BOUND Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLBOUND Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE + !/S USE W3SERVMD, ONLY: STRACE IMPLICIT NONE @@ -218,10 +218,10 @@ SUBROUTINE READ_BOUND_NML (NDSI, NML_BOUND) INTEGER :: IERR !< error code TYPE(NML_BOUND_T) :: BOUND !< bound structure NAMELIST /BOUND_NML/ BOUND !< boudn namelist -!/S INTEGER, SAVE :: IENT = 0 !< strace error code + !/S INTEGER, SAVE :: IENT = 0 !< strace error code IERR = 0 -!/S CALL STRACE (IENT, 'READ_BOUND_NML') + !/S CALL STRACE (IENT, 'READ_BOUND_NML') ! set default values for track structure BOUND%MODE = 'WRITE' @@ -234,8 +234,8 @@ SUBROUTINE READ_BOUND_NML (NDSI, NML_BOUND) READ (NDSI, nml=BOUND_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_BOUND_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_BOUND_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (1) END IF @@ -244,7 +244,7 @@ SUBROUTINE READ_BOUND_NML (NDSI, NML_BOUND) END SUBROUTINE READ_BOUND_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -253,77 +253,77 @@ END SUBROUTINE READ_BOUND_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_BOUND_NML (NML_BOUND) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2021 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_BOUND Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLBOUND Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -!/S USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2021 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_BOUND Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLBOUND Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + !/S USE W3SERVMD, ONLY: STRACE IMPLICIT NONE TYPE(NML_BOUND_T), INTENT(IN) :: NML_BOUND !< bound structure -!/S INTEGER, SAVE :: IENT = 0 ! strace error code + !/S INTEGER, SAVE :: IENT = 0 ! strace error code -!/S CALL STRACE (IENT, 'REPORT_BOUND_NML') + !/S CALL STRACE (IENT, 'REPORT_BOUND_NML') - WRITE (MSG,'(A)') 'BOUND % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'MODE = ', TRIM(NML_BOUND%MODE) - WRITE (NDSN,11) TRIM(MSG),'INTERP = ', NML_BOUND%INTERP - WRITE (NDSN,11) TRIM(MSG),'VERBOSE = ', NML_BOUND%VERBOSE - WRITE (NDSN,10) TRIM(MSG),'FILE = ', TRIM(NML_BOUND%FILE) + WRITE (MSG,'(A)') 'BOUND % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'MODE = ', TRIM(NML_BOUND%MODE) + WRITE (NDSN,11) TRIM(MSG),'INTERP = ', NML_BOUND%INTERP + WRITE (NDSN,11) TRIM(MSG),'VERBOSE = ', NML_BOUND%VERBOSE + WRITE (NDSN,10) TRIM(MSG),'FILE = ', TRIM(NML_BOUND%FILE) 10 FORMAT (A,2X,A,A) @@ -331,7 +331,7 @@ SUBROUTINE REPORT_BOUND_NML (NML_BOUND) END SUBROUTINE REPORT_BOUND_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / END MODULE W3NMLBOUNDMD diff --git a/model/src/w3nmlgridmd.F90 b/model/src/w3nmlgridmd.F90 index 305ccef37..79271a2b2 100644 --- a/model/src/w3nmlgridmd.F90 +++ b/model/src/w3nmlgridmd.F90 @@ -1,22 +1,22 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3NMLGRIDMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutines. -!/ -! 1. Purpose : -! -! Manages namelists from configuration file ww3_grid.nml for ww3_grid program -! -!/ ------------------------------------------------------------------- / +#include "w3macros.h" +!/ ------------------------------------------------------------------- / +MODULE W3NMLGRIDMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutines. + !/ + ! 1. Purpose : + ! + ! Manages namelists from configuration file ww3_grid.nml for ww3_grid program + ! + !/ ------------------------------------------------------------------- / ! module defaults IMPLICIT NONE @@ -243,127 +243,127 @@ MODULE W3NMLGRIDMD - CONTAINS -!/ ------------------------------------------------------------------- / +CONTAINS + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLGRID (NDSI, INFILE, NML_SPECTRUM, NML_RUN, & - NML_TIMESTEPS, NML_GRID, NML_RECT, NML_CURV, & - NML_UNST, NML_SMC, NML_DEPTH, NML_MASK, & - NML_OBST, NML_SLOPE, NML_SED, NML_INBND_COUNT, & - NML_INBND_POINT, NML_EXCL_COUNT, & - NML_EXCL_POINT, NML_EXCL_BODY, & - NML_OUTBND_COUNT, NML_OUTBND_LINE, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! -! 1. Purpose : -! -! Reads all the namelist to define the model grid -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! INFILE Char. -! NML_SPECTRUM Type -! NML_RUN Type -! NML_TIMESTEPS Type -! NML_GRID Type -! NML_RECT Type -! NML_CURV Type -! NML_UNST Type -! NML_SMC Type -! NML_DEPTH Type -! NML_MASK Type -! NML_OBST Type -! NML_SLOPE Type -! NML_SED Type -! NML_INBND_COUNT Type -! NML_INBND_POINT Type -! NML_EXCL_COUNT Type -! NML_EXCL_POINT Type -! NML_EXCL_BODY Type -! NML_OUTBND_COUNT Type -! NML_OUTBND_LINE Type -! IERR Int. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_SPECTRUM_NML -! REPORT_SPECTRUM_NML -! READ_RUN_NML -! REPORT_RUN_NML -! READ_TIMESTEPS_NML -! REPORT_TIMESTEPS_NML -! READ_GRID_NML -! REPORT_GRID_NML -! READ_RECT_NML -! REPORT_RECT_NML -! READ_CURV_NML -! REPORT_CURV_NML -! READ_UNST_NML -! REPORT_UNST_NML -! READ_SMC_NML -! REPORT_SMC_NML -! READ_DEPTH_NML -! REPORT_DEPTH_NML -! READ_MASK_NML -! REPORT_MASK_NML -! READ_OBST_NML -! REPORT_OBST_NML -! READ_SLOPE_NML -! REPORT_SLOPE_NML -! READ_SED_NML -! REPORT_SED_NML -! READ_INBOUND_NML -! REPORT_INBOUND_NML -! READ_EXCLUDED_NML -! REPORT_EXCLUDED_NML -! READ_OUTBOUND_NML -! REPORT_OUTBOUND_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! WW3_GRID Prog. N/A Preprocess model grid. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + NML_TIMESTEPS, NML_GRID, NML_RECT, NML_CURV, & + NML_UNST, NML_SMC, NML_DEPTH, NML_MASK, & + NML_OBST, NML_SLOPE, NML_SED, NML_INBND_COUNT, & + NML_INBND_POINT, NML_EXCL_COUNT, & + NML_EXCL_POINT, NML_EXCL_BODY, & + NML_OUTBND_COUNT, NML_OUTBND_LINE, IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! + ! 1. Purpose : + ! + ! Reads all the namelist to define the model grid + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! INFILE Char. + ! NML_SPECTRUM Type + ! NML_RUN Type + ! NML_TIMESTEPS Type + ! NML_GRID Type + ! NML_RECT Type + ! NML_CURV Type + ! NML_UNST Type + ! NML_SMC Type + ! NML_DEPTH Type + ! NML_MASK Type + ! NML_OBST Type + ! NML_SLOPE Type + ! NML_SED Type + ! NML_INBND_COUNT Type + ! NML_INBND_POINT Type + ! NML_EXCL_COUNT Type + ! NML_EXCL_POINT Type + ! NML_EXCL_BODY Type + ! NML_OUTBND_COUNT Type + ! NML_OUTBND_LINE Type + ! IERR Int. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_SPECTRUM_NML + ! REPORT_SPECTRUM_NML + ! READ_RUN_NML + ! REPORT_RUN_NML + ! READ_TIMESTEPS_NML + ! REPORT_TIMESTEPS_NML + ! READ_GRID_NML + ! REPORT_GRID_NML + ! READ_RECT_NML + ! REPORT_RECT_NML + ! READ_CURV_NML + ! REPORT_CURV_NML + ! READ_UNST_NML + ! REPORT_UNST_NML + ! READ_SMC_NML + ! REPORT_SMC_NML + ! READ_DEPTH_NML + ! REPORT_DEPTH_NML + ! READ_MASK_NML + ! REPORT_MASK_NML + ! READ_OBST_NML + ! REPORT_OBST_NML + ! READ_SLOPE_NML + ! REPORT_SLOPE_NML + ! READ_SED_NML + ! REPORT_SED_NML + ! READ_INBOUND_NML + ! REPORT_INBOUND_NML + ! READ_EXCLUDED_NML + ! REPORT_EXCLUDED_NML + ! READ_OUTBOUND_NML + ! REPORT_OUTBOUND_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! WW3_GRID Prog. N/A Preprocess model grid. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -392,18 +392,18 @@ SUBROUTINE W3NMLGRID (NDSI, INFILE, NML_SPECTRUM, NML_RUN, & TYPE(NML_OUTBND_LINE_T), ALLOCATABLE, INTENT(INOUT) :: NML_OUTBND_LINE(:) INTEGER, INTENT(OUT) :: IERR #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'W3NMLGRID') + CALL STRACE (IENT, 'W3NMLGRID') #endif ! open namelist log file NDSN = 3 OPEN (NDSN, file=TRIM(INFILE)//'.log', form='formatted', iostat=IERR) - IF (IERR.NE.0) THEN + IF (IERR.NE.0) THEN WRITE (NDSE,'(A)') 'ERROR: open full nml file '//TRIM(INFILE)//'.log failed' RETURN END IF @@ -486,74 +486,74 @@ SUBROUTINE W3NMLGRID (NDSI, INFILE, NML_SPECTRUM, NML_RUN, & END SUBROUTINE W3NMLGRID -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_SPECTRUM_NML (NDSI, NML_SPECTRUM) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_SPECTRUM Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_SPECTRUM Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -566,12 +566,12 @@ SUBROUTINE READ_SPECTRUM_NML (NDSI, NML_SPECTRUM) TYPE(NML_SPECTRUM_T) :: SPECTRUM NAMELIST /SPECTRUM_NML/ SPECTRUM #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_SPECTRUM_NML') + CALL STRACE (IENT, 'READ_SPECTRUM_NML') #endif ! set default values for spectrum structure @@ -586,8 +586,8 @@ SUBROUTINE READ_SPECTRUM_NML (NDSI, NML_SPECTRUM) READ (NDSI, nml=SPECTRUM_NML, iostat=IERR, iomsg=MSG) IF (IERR.NE.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_SPECTRUM_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_SPECTRUM_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (1) END IF @@ -596,71 +596,71 @@ SUBROUTINE READ_SPECTRUM_NML (NDSI, NML_SPECTRUM) END SUBROUTINE READ_SPECTRUM_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_RUN_NML (NDSI, NML_RUN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_RUN Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_RUN Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -673,12 +673,12 @@ SUBROUTINE READ_RUN_NML (NDSI, NML_RUN) TYPE(NML_RUN_T) :: RUN NAMELIST /RUN_NML/ RUN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_RUN_NML') + CALL STRACE (IENT, 'READ_RUN_NML') #endif ! set default values for run structure @@ -694,8 +694,8 @@ SUBROUTINE READ_RUN_NML (NDSI, NML_RUN) READ (NDSI, nml=RUN_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_RUN_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_RUN_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (2) END IF @@ -704,71 +704,71 @@ SUBROUTINE READ_RUN_NML (NDSI, NML_RUN) END SUBROUTINE READ_RUN_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_TIMESTEPS_NML (NDSI, NML_TIMESTEPS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_TIMESTEPS Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_TIMESTEPS Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -781,12 +781,12 @@ SUBROUTINE READ_TIMESTEPS_NML (NDSI, NML_TIMESTEPS) TYPE(NML_TIMESTEPS_T) :: TIMESTEPS NAMELIST /TIMESTEPS_NML/ TIMESTEPS #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_TIMESTEPS_NML') + CALL STRACE (IENT, 'READ_TIMESTEPS_NML') #endif ! set default values for timesteps structure @@ -800,8 +800,8 @@ SUBROUTINE READ_TIMESTEPS_NML (NDSI, NML_TIMESTEPS) READ (NDSI, nml=TIMESTEPS_NML, iostat=IERR, iomsg=MSG) IF (IERR.NE.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_TIMESTEPS_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_TIMESTEPS_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (3) END IF @@ -810,72 +810,72 @@ SUBROUTINE READ_TIMESTEPS_NML (NDSI, NML_TIMESTEPS) END SUBROUTINE READ_TIMESTEPS_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_GRID_NML (NDSI, NML_GRID) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_GRID Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_GRID Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -888,12 +888,12 @@ SUBROUTINE READ_GRID_NML (NDSI, NML_GRID) TYPE(NML_GRID_T) :: GRID NAMELIST /GRID_NML/ GRID #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_GRID_NML') + CALL STRACE (IENT, 'READ_GRID_NML') #endif ! set default values for grid structure @@ -910,8 +910,8 @@ SUBROUTINE READ_GRID_NML (NDSI, NML_GRID) READ (NDSI, nml=GRID_NML, iostat=IERR, iomsg=MSG) IF (IERR.NE.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_GRID_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_GRID_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (4) END IF @@ -920,71 +920,71 @@ SUBROUTINE READ_GRID_NML (NDSI, NML_GRID) END SUBROUTINE READ_GRID_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_RECT_NML (NDSI, NML_RECT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_RECT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_RECT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -997,12 +997,12 @@ SUBROUTINE READ_RECT_NML (NDSI, NML_RECT) TYPE(NML_RECT_T) :: RECT NAMELIST /RECT_NML/ RECT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_RECT_NML') + CALL STRACE (IENT, 'READ_RECT_NML') #endif ! set default values for rect structure @@ -1020,8 +1020,8 @@ SUBROUTINE READ_RECT_NML (NDSI, NML_RECT) READ (NDSI, nml=RECT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_RECT_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_RECT_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (5) END IF @@ -1030,71 +1030,71 @@ SUBROUTINE READ_RECT_NML (NDSI, NML_RECT) END SUBROUTINE READ_RECT_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_CURV_NML (NDSI, NML_CURV) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_CURV Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_CURV Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1107,18 +1107,18 @@ SUBROUTINE READ_CURV_NML (NDSI, NML_CURV) TYPE(NML_CURV_T) :: CURV NAMELIST /CURV_NML/ CURV #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_CURV_NML') + CALL STRACE (IENT, 'READ_CURV_NML') #endif ! set default values for curv structure CURV%NX = 0 CURV%NY = 0 -! + ! CURV%XCOORD%SF = 1. CURV%XCOORD%OFF = 0. CURV%XCOORD%FILENAME = 'unset' @@ -1127,7 +1127,7 @@ SUBROUTINE READ_CURV_NML (NDSI, NML_CURV) CURV%XCOORD%IDFM = 1 CURV%XCOORD%FORMAT = '(....)' CURV%XCOORD%FROM = 'NAME' -! + ! CURV%YCOORD%SF = 1. CURV%YCOORD%OFF = 0. CURV%YCOORD%FILENAME = 'unset' @@ -1142,8 +1142,8 @@ SUBROUTINE READ_CURV_NML (NDSI, NML_CURV) READ (NDSI, nml=CURV_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_CURV_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_CURV_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (6) END IF @@ -1152,71 +1152,71 @@ SUBROUTINE READ_CURV_NML (NDSI, NML_CURV) END SUBROUTINE READ_CURV_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_UNST_NML (NDSI, NML_UNST) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_UNST Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_UNST Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1229,12 +1229,12 @@ SUBROUTINE READ_UNST_NML (NDSI, NML_UNST) TYPE(NML_UNST_T) :: UNST NAMELIST /UNST_NML/ UNST #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_UNST_NML') + CALL STRACE (IENT, 'READ_UNST_NML') #endif ! set default values for unst structure @@ -1251,8 +1251,8 @@ SUBROUTINE READ_UNST_NML (NDSI, NML_UNST) READ (NDSI, nml=UNST_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_UNST_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_UNST_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (7) END IF @@ -1261,72 +1261,72 @@ SUBROUTINE READ_UNST_NML (NDSI, NML_UNST) END SUBROUTINE READ_UNST_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_SMC Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_SMC Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1339,12 +1339,12 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) TYPE(NML_SMC_T) :: SMC NAMELIST /SMC_NML/ SMC #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_SMC_NML') + CALL STRACE (IENT, 'READ_SMC_NML') #endif ! set default values for smc structure @@ -1353,43 +1353,43 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) SMC%MCELS%IDLA = 1 SMC%MCELS%IDFM = 1 SMC%MCELS%FORMAT = '(....)' -! + ! SMC%ISIDE%FILENAME = 'unset' SMC%ISIDE%IDF = 32 SMC%ISIDE%IDLA = 1 SMC%ISIDE%IDFM = 1 SMC%ISIDE%FORMAT = '(....)' -! + ! SMC%JSIDE%FILENAME = 'unset' SMC%JSIDE%IDF = 33 SMC%JSIDE%IDLA = 1 SMC%JSIDE%IDFM = 1 SMC%JSIDE%FORMAT = '(....)' -! + ! SMC%SUBTR%FILENAME = 'unset' SMC%SUBTR%IDF = 34 SMC%SUBTR%IDLA = 1 SMC%SUBTR%IDFM = 1 SMC%SUBTR%FORMAT = '(....)' -! + ! SMC%BUNDY%FILENAME = 'unset' SMC%BUNDY%IDF = 35 SMC%BUNDY%IDLA = 1 SMC%BUNDY%IDFM = 1 SMC%BUNDY%FORMAT = '(....)' -! + ! SMC%MBARC%FILENAME = 'unset' SMC%MBARC%IDF = 36 SMC%MBARC%IDLA = 1 SMC%MBARC%IDFM = 1 SMC%MBARC%FORMAT = '(....)' -! + ! SMC%AISID%FILENAME = 'unset' SMC%AISID%IDF = 37 SMC%AISID%IDLA = 1 SMC%AISID%IDFM = 1 SMC%AISID%FORMAT = '(....)' -! + ! SMC%AJSID%FILENAME = 'unset' SMC%AJSID%IDF = 38 SMC%AJSID%IDLA = 1 @@ -1402,8 +1402,8 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) READ (NDSI, nml=SMC_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_SMC_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_SMC_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (8) END IF @@ -1412,71 +1412,71 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) END SUBROUTINE READ_SMC_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_DEPTH_NML (NDSI, NML_DEPTH) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_DEPTH Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_DEPTH Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1489,12 +1489,12 @@ SUBROUTINE READ_DEPTH_NML (NDSI, NML_DEPTH) TYPE(NML_DEPTH_T) :: DEPTH NAMELIST /DEPTH_NML/ DEPTH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_DEPTH_NML') + CALL STRACE (IENT, 'READ_DEPTH_NML') #endif ! set default values for depth structure @@ -1511,8 +1511,8 @@ SUBROUTINE READ_DEPTH_NML (NDSI, NML_DEPTH) READ (NDSI, nml=DEPTH_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_DEPTH_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_DEPTH_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (9) END IF @@ -1521,71 +1521,71 @@ SUBROUTINE READ_DEPTH_NML (NDSI, NML_DEPTH) END SUBROUTINE READ_DEPTH_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_MASK_NML (NDSI, NML_MASK) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_MASK Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_MASK Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1598,12 +1598,12 @@ SUBROUTINE READ_MASK_NML (NDSI, NML_MASK) TYPE(NML_MASK_T) :: MASK NAMELIST /MASK_NML/ MASK #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_MASK_NML') + CALL STRACE (IENT, 'READ_MASK_NML') #endif ! set default values for mask structure @@ -1620,8 +1620,8 @@ SUBROUTINE READ_MASK_NML (NDSI, NML_MASK) READ (NDSI, nml=MASK_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_MASK_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_MASK_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (10) END IF @@ -1630,72 +1630,72 @@ SUBROUTINE READ_MASK_NML (NDSI, NML_MASK) END SUBROUTINE READ_MASK_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_OBST_NML (NDSI, NML_OBST) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_OBST Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_OBST Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1708,12 +1708,12 @@ SUBROUTINE READ_OBST_NML (NDSI, NML_OBST) TYPE(NML_OBST_T) :: OBST NAMELIST /OBST_NML/ OBST #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_OBST_NML') + CALL STRACE (IENT, 'READ_OBST_NML') #endif ! set default values for obst structure @@ -1730,8 +1730,8 @@ SUBROUTINE READ_OBST_NML (NDSI, NML_OBST) READ (NDSI, nml=OBST_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_OBST_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_OBST_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (11) END IF @@ -1740,72 +1740,72 @@ SUBROUTINE READ_OBST_NML (NDSI, NML_OBST) END SUBROUTINE READ_OBST_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_SLOPE_NML (NDSI, NML_SLOPE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_SLOPE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_SLOPE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1818,12 +1818,12 @@ SUBROUTINE READ_SLOPE_NML (NDSI, NML_SLOPE) TYPE(NML_SLOPE_T) :: SLOPE NAMELIST /SLOPE_NML/ SLOPE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_SLOPE_NML') + CALL STRACE (IENT, 'READ_SLOPE_NML') #endif ! set default values for slope structure @@ -1840,8 +1840,8 @@ SUBROUTINE READ_SLOPE_NML (NDSI, NML_SLOPE) READ (NDSI, nml=SLOPE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_SLOPE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_SLOPE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (12) END IF @@ -1850,73 +1850,73 @@ SUBROUTINE READ_SLOPE_NML (NDSI, NML_SLOPE) END SUBROUTINE READ_SLOPE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_SED_NML (NDSI, NML_SED) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_SED Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_SED Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1929,12 +1929,12 @@ SUBROUTINE READ_SED_NML (NDSI, NML_SED) TYPE(NML_SED_T) :: SED NAMELIST /SED_NML/ SED #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_SED_NML') + CALL STRACE (IENT, 'READ_SED_NML') #endif ! set default values for sed structure @@ -1951,8 +1951,8 @@ SUBROUTINE READ_SED_NML (NDSI, NML_SED) READ (NDSI, nml=SED_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_SED_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_SED_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (13) END IF @@ -1961,74 +1961,74 @@ SUBROUTINE READ_SED_NML (NDSI, NML_SED) END SUBROUTINE READ_SED_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_INBOUND_NML (NDSI, NML_INBND_COUNT, NML_INBND_POINT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_INBND_COUNT Type. -! NML_INBND_POINT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_INBND_COUNT Type. + ! NML_INBND_POINT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -2044,12 +2044,12 @@ SUBROUTINE READ_INBOUND_NML (NDSI, NML_INBND_COUNT, NML_INBND_POINT) TYPE(NML_INBND_POINT_T), ALLOCATABLE :: INBND_POINT(:) NAMELIST /INBND_POINT_NML/ INBND_POINT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_INBOUND_NML') + CALL STRACE (IENT, 'READ_INBOUND_NML') #endif ! set default values for inbnd count structure @@ -2060,8 +2060,8 @@ SUBROUTINE READ_INBOUND_NML (NDSI, NML_INBND_COUNT, NML_INBND_POINT) READ (NDSI, nml=INBND_COUNT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_INBND_COUNT_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_INBND_COUNT_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (14) END IF @@ -2083,8 +2083,8 @@ SUBROUTINE READ_INBOUND_NML (NDSI, NML_INBND_COUNT, NML_INBND_POINT) READ (NDSI, nml=INBND_POINT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_INBND_POINT_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_INBND_POINT_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (15) END IF @@ -2094,75 +2094,75 @@ SUBROUTINE READ_INBOUND_NML (NDSI, NML_INBND_COUNT, NML_INBND_POINT) END SUBROUTINE READ_INBOUND_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_EXCLUDED_NML (NDSI, NML_EXCL_COUNT, NML_EXCL_POINT, & - NML_EXCL_BODY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_EXCL_COUNT Type. -! NML_EXCL_POINT Type. -! NML_EXCL_BODY Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + NML_EXCL_BODY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_EXCL_COUNT Type. + ! NML_EXCL_POINT Type. + ! NML_EXCL_BODY Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -2181,12 +2181,12 @@ SUBROUTINE READ_EXCLUDED_NML (NDSI, NML_EXCL_COUNT, NML_EXCL_POINT, & TYPE(NML_EXCL_BODY_T), ALLOCATABLE :: EXCL_BODY(:) NAMELIST /EXCL_BODY_NML/ EXCL_BODY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_EXCLUDED_NML') + CALL STRACE (IENT, 'READ_EXCLUDED_NML') #endif ! set default values for excl count structure @@ -2198,8 +2198,8 @@ SUBROUTINE READ_EXCLUDED_NML (NDSI, NML_EXCL_COUNT, NML_EXCL_POINT, & READ (NDSI, nml=EXCL_COUNT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_EXCL_COUNT_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_EXCL_COUNT_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (16) END IF @@ -2221,8 +2221,8 @@ SUBROUTINE READ_EXCLUDED_NML (NDSI, NML_EXCL_COUNT, NML_EXCL_POINT, & READ (NDSI, nml=EXCL_POINT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_EXCL_POINT_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_EXCL_POINT_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (17) END IF @@ -2243,8 +2243,8 @@ SUBROUTINE READ_EXCLUDED_NML (NDSI, NML_EXCL_COUNT, NML_EXCL_POINT, & READ (NDSI, nml=EXCL_POINT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_EXCL_POINT_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_EXCL_POINT_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (18) END IF @@ -2255,73 +2255,73 @@ SUBROUTINE READ_EXCLUDED_NML (NDSI, NML_EXCL_COUNT, NML_EXCL_POINT, & END SUBROUTINE READ_EXCLUDED_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_OUTBOUND_NML (NDSI, NML_OUTBND_COUNT, NML_OUTBND_LINE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_OUTBND_COUNT Type. -! NML_OUTBND_LINE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_OUTBND_COUNT Type. + ! NML_OUTBND_LINE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -2338,12 +2338,12 @@ SUBROUTINE READ_OUTBOUND_NML (NDSI, NML_OUTBND_COUNT, NML_OUTBND_LINE) NAMELIST /OUTBND_LINE_NML/ OUTBND_LINE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_OUTBOUND_NML') + CALL STRACE (IENT, 'READ_OUTBOUND_NML') #endif ! set default values for outbnd count structure @@ -2354,8 +2354,8 @@ SUBROUTINE READ_OUTBOUND_NML (NDSI, NML_OUTBND_COUNT, NML_OUTBND_LINE) READ (NDSI, nml=OUTBND_COUNT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_OUTBND_COUNT_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_OUTBND_COUNT_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (19) END IF @@ -2379,8 +2379,8 @@ SUBROUTINE READ_OUTBOUND_NML (NDSI, NML_OUTBND_COUNT, NML_OUTBND_LINE) READ (NDSI, nml=OUTBND_LINE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_OUTBND_LINE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_OUTBND_LINE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (20) END IF @@ -2390,90 +2390,90 @@ SUBROUTINE READ_OUTBOUND_NML (NDSI, NML_OUTBND_COUNT, NML_OUTBND_LINE) END SUBROUTINE READ_OUTBOUND_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_SPECTRUM_NML (NML_SPECTRUM) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_SPECTRUM Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_SPECTRUM Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_SPECTRUM_T), INTENT(IN) :: NML_SPECTRUM #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_SPECTRUM_NML') + CALL STRACE (IENT, 'REPORT_SPECTRUM_NML') #endif - WRITE (MSG,'(A)') 'SPECTRUM % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,14) TRIM(MSG),'XFR = ', NML_SPECTRUM%XFR - WRITE (NDSN,14) TRIM(MSG),'FREQ1 = ', NML_SPECTRUM%FREQ1 - WRITE (NDSN,11) TRIM(MSG),'NK = ', NML_SPECTRUM%NK - WRITE (NDSN,11) TRIM(MSG),'NTH = ', NML_SPECTRUM%NTH - WRITE (NDSN,14) TRIM(MSG),'THOFF = ', NML_SPECTRUM%THOFF + WRITE (MSG,'(A)') 'SPECTRUM % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,14) TRIM(MSG),'XFR = ', NML_SPECTRUM%XFR + WRITE (NDSN,14) TRIM(MSG),'FREQ1 = ', NML_SPECTRUM%FREQ1 + WRITE (NDSN,11) TRIM(MSG),'NK = ', NML_SPECTRUM%NK + WRITE (NDSN,11) TRIM(MSG),'NTH = ', NML_SPECTRUM%NTH + WRITE (NDSN,14) TRIM(MSG),'THOFF = ', NML_SPECTRUM%THOFF 10 FORMAT (A,2X,A,A) 11 FORMAT (A,2X,A,I8) @@ -2482,89 +2482,89 @@ SUBROUTINE REPORT_SPECTRUM_NML (NML_SPECTRUM) END SUBROUTINE REPORT_SPECTRUM_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_RUN_NML (NML_RUN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_RUN Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_RUN Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_RUN_T), INTENT(IN) :: NML_RUN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_RUN_NML') + CALL STRACE (IENT, 'REPORT_RUN_NML') #endif - WRITE (MSG,'(A)') 'RUN % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,13) TRIM(MSG),'FLDRY = ', NML_RUN%FLDRY - WRITE (NDSN,13) TRIM(MSG),'FLCX = ', NML_RUN%FLCX - WRITE (NDSN,13) TRIM(MSG),'FLCY = ', NML_RUN%FLCY - WRITE (NDSN,13) TRIM(MSG),'FLCTH = ', NML_RUN%FLCTH - WRITE (NDSN,13) TRIM(MSG),'FLCK = ', NML_RUN%FLCK - WRITE (NDSN,13) TRIM(MSG),'FLSOU = ', NML_RUN%FLSOU + WRITE (MSG,'(A)') 'RUN % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,13) TRIM(MSG),'FLDRY = ', NML_RUN%FLDRY + WRITE (NDSN,13) TRIM(MSG),'FLCX = ', NML_RUN%FLCX + WRITE (NDSN,13) TRIM(MSG),'FLCY = ', NML_RUN%FLCY + WRITE (NDSN,13) TRIM(MSG),'FLCTH = ', NML_RUN%FLCTH + WRITE (NDSN,13) TRIM(MSG),'FLCK = ', NML_RUN%FLCK + WRITE (NDSN,13) TRIM(MSG),'FLSOU = ', NML_RUN%FLSOU 10 FORMAT (A,2X,A,A) @@ -2574,86 +2574,86 @@ SUBROUTINE REPORT_RUN_NML (NML_RUN) END SUBROUTINE REPORT_RUN_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_TIMESTEPS_NML (NML_TIMESTEPS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_TIMESTEPS Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_TIMESTEPS Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_TIMESTEPS_T), INTENT(IN) :: NML_TIMESTEPS #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_TIMESTEPS_NML') + CALL STRACE (IENT, 'REPORT_TIMESTEPS_NML') #endif - WRITE (MSG,'(A)') 'TIMESTEPS % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,14) TRIM(MSG),'DTMAX = ', NML_TIMESTEPS%DTMAX - WRITE (NDSN,14) TRIM(MSG),'DTXY = ', NML_TIMESTEPS%DTXY - WRITE (NDSN,14) TRIM(MSG),'DTKTH = ', NML_TIMESTEPS%DTKTH - WRITE (NDSN,14) TRIM(MSG),'DTMIN = ', NML_TIMESTEPS%DTMIN + WRITE (MSG,'(A)') 'TIMESTEPS % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,14) TRIM(MSG),'DTMAX = ', NML_TIMESTEPS%DTMAX + WRITE (NDSN,14) TRIM(MSG),'DTXY = ', NML_TIMESTEPS%DTXY + WRITE (NDSN,14) TRIM(MSG),'DTKTH = ', NML_TIMESTEPS%DTKTH + WRITE (NDSN,14) TRIM(MSG),'DTMIN = ', NML_TIMESTEPS%DTMIN 10 FORMAT (A,2X,A,A) 11 FORMAT (A,2X,A,I8) @@ -2662,90 +2662,90 @@ SUBROUTINE REPORT_TIMESTEPS_NML (NML_TIMESTEPS) END SUBROUTINE REPORT_TIMESTEPS_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_GRID_NML (NML_GRID) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_GRID Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_GRID Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_GRID_T), INTENT(IN) :: NML_GRID #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_GRID_NML') + CALL STRACE (IENT, 'REPORT_GRID_NML') #endif - WRITE (MSG,'(A)') 'GRID % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'NAME = ', TRIM(NML_GRID%NAME) - WRITE (NDSN,10) TRIM(MSG),'NML = ', TRIM(NML_GRID%NML) - WRITE (NDSN,10) TRIM(MSG),'TYPE = ', TRIM(NML_GRID%TYPE) - WRITE (NDSN,10) TRIM(MSG),'COORD = ', TRIM(NML_GRID%COORD) - WRITE (NDSN,10) TRIM(MSG),'CLOS = ', TRIM(NML_GRID%CLOS) - WRITE (NDSN,14) TRIM(MSG),'ZLIM = ', NML_GRID%ZLIM - WRITE (NDSN,14) TRIM(MSG),'DMIN = ', NML_GRID%DMIN + WRITE (MSG,'(A)') 'GRID % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'NAME = ', TRIM(NML_GRID%NAME) + WRITE (NDSN,10) TRIM(MSG),'NML = ', TRIM(NML_GRID%NML) + WRITE (NDSN,10) TRIM(MSG),'TYPE = ', TRIM(NML_GRID%TYPE) + WRITE (NDSN,10) TRIM(MSG),'COORD = ', TRIM(NML_GRID%COORD) + WRITE (NDSN,10) TRIM(MSG),'CLOS = ', TRIM(NML_GRID%CLOS) + WRITE (NDSN,14) TRIM(MSG),'ZLIM = ', NML_GRID%ZLIM + WRITE (NDSN,14) TRIM(MSG),'DMIN = ', NML_GRID%DMIN 10 FORMAT (A,2X,A,A) 11 FORMAT (A,2X,A,I8) @@ -2754,90 +2754,90 @@ SUBROUTINE REPORT_GRID_NML (NML_GRID) END SUBROUTINE REPORT_GRID_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_RECT_NML (NML_RECT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_RECT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_RECT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_RECT_T), INTENT(IN) :: NML_RECT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_RECT_NML') + CALL STRACE (IENT, 'REPORT_RECT_NML') #endif - WRITE (MSG,'(A)') 'RECT % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,11) TRIM(MSG),'NX = ', NML_RECT%NX - WRITE (NDSN,11) TRIM(MSG),'NY = ', NML_RECT%NY - WRITE (NDSN,14) TRIM(MSG),'SX = ', NML_RECT%SX - WRITE (NDSN,14) TRIM(MSG),'SY = ', NML_RECT%SY - WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_RECT%SF - WRITE (NDSN,14) TRIM(MSG),'X0 = ', NML_RECT%X0 - WRITE (NDSN,14) TRIM(MSG),'Y0 = ', NML_RECT%Y0 - WRITE (NDSN,14) TRIM(MSG),'SF0 = ', NML_RECT%SF0 + WRITE (MSG,'(A)') 'RECT % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,11) TRIM(MSG),'NX = ', NML_RECT%NX + WRITE (NDSN,11) TRIM(MSG),'NY = ', NML_RECT%NY + WRITE (NDSN,14) TRIM(MSG),'SX = ', NML_RECT%SX + WRITE (NDSN,14) TRIM(MSG),'SY = ', NML_RECT%SY + WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_RECT%SF + WRITE (NDSN,14) TRIM(MSG),'X0 = ', NML_RECT%X0 + WRITE (NDSN,14) TRIM(MSG),'Y0 = ', NML_RECT%Y0 + WRITE (NDSN,14) TRIM(MSG),'SF0 = ', NML_RECT%SF0 10 FORMAT (A,2X,A,A) 11 FORMAT (A,2X,A,I8) @@ -2846,103 +2846,103 @@ SUBROUTINE REPORT_RECT_NML (NML_RECT) END SUBROUTINE REPORT_RECT_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_CURV_NML (NML_CURV) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_CURV Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_CURV Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_CURV_T), INTENT(IN) :: NML_CURV #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_CURV_NML') + CALL STRACE (IENT, 'REPORT_CURV_NML') #endif - WRITE (MSG,'(A)') 'CURV % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,11) TRIM(MSG),'NX = ', NML_CURV%NX - WRITE (NDSN,11) TRIM(MSG),'NY = ', NML_CURV%NY -! - WRITE (NDSN,14) TRIM(MSG),'XCOORD % SF = ', NML_CURV%XCOORD%SF - WRITE (NDSN,14) TRIM(MSG),'XCOORD % OFF = ', NML_CURV%XCOORD%OFF - WRITE (NDSN,10) TRIM(MSG),'XCOORD % FILENAME = ', TRIM(NML_CURV%XCOORD%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'XCOORD % IDF = ', NML_CURV%XCOORD%IDF - WRITE (NDSN,11) TRIM(MSG),'XCOORD % IDLA = ', NML_CURV%XCOORD%IDLA - WRITE (NDSN,11) TRIM(MSG),'XCOORD % IDFM = ', NML_CURV%XCOORD%IDFM - WRITE (NDSN,10) TRIM(MSG),'XCOORD % FORMAT = ', TRIM(NML_CURV%XCOORD%FORMAT) - WRITE (NDSN,10) TRIM(MSG),'XCOORD % FROM = ', TRIM(NML_CURV%XCOORD%FROM) -! - WRITE (NDSN,14) TRIM(MSG),'YCOORD % SF = ', NML_CURV%YCOORD%SF - WRITE (NDSN,14) TRIM(MSG),'YCOORD % OFF = ', NML_CURV%YCOORD%OFF - WRITE (NDSN,10) TRIM(MSG),'YCOORD % FILENAME = ', TRIM(NML_CURV%YCOORD%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'YCOORD % IDF = ', NML_CURV%YCOORD%IDF - WRITE (NDSN,11) TRIM(MSG),'YCOORD % IDLA = ', NML_CURV%YCOORD%IDLA - WRITE (NDSN,11) TRIM(MSG),'YCOORD % IDFM = ', NML_CURV%YCOORD%IDFM - WRITE (NDSN,10) TRIM(MSG),'YCOORD % FORMAT = ', TRIM(NML_CURV%YCOORD%FORMAT) - WRITE (NDSN,10) TRIM(MSG),'YCOORD % FROM = ', TRIM(NML_CURV%YCOORD%FROM) + WRITE (MSG,'(A)') 'CURV % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,11) TRIM(MSG),'NX = ', NML_CURV%NX + WRITE (NDSN,11) TRIM(MSG),'NY = ', NML_CURV%NY + ! + WRITE (NDSN,14) TRIM(MSG),'XCOORD % SF = ', NML_CURV%XCOORD%SF + WRITE (NDSN,14) TRIM(MSG),'XCOORD % OFF = ', NML_CURV%XCOORD%OFF + WRITE (NDSN,10) TRIM(MSG),'XCOORD % FILENAME = ', TRIM(NML_CURV%XCOORD%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'XCOORD % IDF = ', NML_CURV%XCOORD%IDF + WRITE (NDSN,11) TRIM(MSG),'XCOORD % IDLA = ', NML_CURV%XCOORD%IDLA + WRITE (NDSN,11) TRIM(MSG),'XCOORD % IDFM = ', NML_CURV%XCOORD%IDFM + WRITE (NDSN,10) TRIM(MSG),'XCOORD % FORMAT = ', TRIM(NML_CURV%XCOORD%FORMAT) + WRITE (NDSN,10) TRIM(MSG),'XCOORD % FROM = ', TRIM(NML_CURV%XCOORD%FROM) + ! + WRITE (NDSN,14) TRIM(MSG),'YCOORD % SF = ', NML_CURV%YCOORD%SF + WRITE (NDSN,14) TRIM(MSG),'YCOORD % OFF = ', NML_CURV%YCOORD%OFF + WRITE (NDSN,10) TRIM(MSG),'YCOORD % FILENAME = ', TRIM(NML_CURV%YCOORD%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'YCOORD % IDF = ', NML_CURV%YCOORD%IDF + WRITE (NDSN,11) TRIM(MSG),'YCOORD % IDLA = ', NML_CURV%YCOORD%IDLA + WRITE (NDSN,11) TRIM(MSG),'YCOORD % IDFM = ', NML_CURV%YCOORD%IDFM + WRITE (NDSN,10) TRIM(MSG),'YCOORD % FORMAT = ', TRIM(NML_CURV%YCOORD%FORMAT) + WRITE (NDSN,10) TRIM(MSG),'YCOORD % FROM = ', TRIM(NML_CURV%YCOORD%FROM) 10 FORMAT (A,2X,A,A) @@ -2952,91 +2952,91 @@ SUBROUTINE REPORT_CURV_NML (NML_CURV) END SUBROUTINE REPORT_CURV_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_UNST_NML (NML_UNST) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_UNST Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_UNST Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_UNST_T), INTENT(IN) :: NML_UNST #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_UNST_NML') + CALL STRACE (IENT, 'REPORT_UNST_NML') #endif - WRITE (MSG,'(A)') 'UNST % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_UNST%SF - WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_UNST%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_UNST%IDF - WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_UNST%IDLA - WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_UNST%IDFM - WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_UNST%FORMAT) -! - WRITE (NDSN,10) TRIM(MSG),'UGOBCFILE = ', TRIM(NML_UNST%UGOBCFILE) + WRITE (MSG,'(A)') 'UNST % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_UNST%SF + WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_UNST%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_UNST%IDF + WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_UNST%IDLA + WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_UNST%IDFM + WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_UNST%FORMAT) + ! + WRITE (NDSN,10) TRIM(MSG),'UGOBCFILE = ', TRIM(NML_UNST%UGOBCFILE) 10 FORMAT (A,2X,A,A) @@ -3046,131 +3046,131 @@ SUBROUTINE REPORT_UNST_NML (NML_UNST) END SUBROUTINE REPORT_UNST_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_SMC_NML (NML_SMC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_SMC Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_SMC Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_SMC_T), INTENT(IN) :: NML_SMC #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - -#ifdef W3_S - CALL STRACE (IENT, 'REPORT_SMC_NML') -#endif - - WRITE (MSG,'(A)') 'SMC % ' - WRITE (NDSN,'(A)') -! - WRITE (NDSN,10) TRIM(MSG),'MCELS % FILENAME = ', TRIM(NML_SMC%MCELS%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'MCELS % IDF = ', NML_SMC%MCELS%IDF - WRITE (NDSN,11) TRIM(MSG),'MCELS % IDLA = ', NML_SMC%MCELS%IDLA - WRITE (NDSN,11) TRIM(MSG),'MCELS % IDFM = ', NML_SMC%MCELS%IDFM - WRITE (NDSN,10) TRIM(MSG),'MCELS % FORMAT = ', TRIM(NML_SMC%MCELS%FORMAT) -! - WRITE (NDSN,10) TRIM(MSG),'ISIDE % FILENAME = ', TRIM(NML_SMC%ISIDE%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'ISIDE % IDF = ', NML_SMC%ISIDE%IDF - WRITE (NDSN,11) TRIM(MSG),'ISIDE % IDLA = ', NML_SMC%ISIDE%IDLA - WRITE (NDSN,11) TRIM(MSG),'ISIDE % IDFM = ', NML_SMC%ISIDE%IDFM - WRITE (NDSN,10) TRIM(MSG),'ISIDE % FORMAT = ', TRIM(NML_SMC%ISIDE%FORMAT) -! - WRITE (NDSN,10) TRIM(MSG),'JSIDE % FILENAME = ', TRIM(NML_SMC%JSIDE%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'JSIDE % IDF = ', NML_SMC%JSIDE%IDF - WRITE (NDSN,11) TRIM(MSG),'JSIDE % IDLA = ', NML_SMC%JSIDE%IDLA - WRITE (NDSN,11) TRIM(MSG),'JSIDE % IDFM = ', NML_SMC%JSIDE%IDFM - WRITE (NDSN,10) TRIM(MSG),'JSIDE % FORMAT = ', TRIM(NML_SMC%JSIDE%FORMAT) -! - WRITE (NDSN,10) TRIM(MSG),'SUBTR % FILENAME = ', TRIM(NML_SMC%SUBTR%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'SUBTR % IDF = ', NML_SMC%SUBTR%IDF - WRITE (NDSN,11) TRIM(MSG),'SUBTR % IDLA = ', NML_SMC%SUBTR%IDLA - WRITE (NDSN,11) TRIM(MSG),'SUBTR % IDFM = ', NML_SMC%SUBTR%IDFM - WRITE (NDSN,10) TRIM(MSG),'SUBTR % FORMAT = ', TRIM(NML_SMC%SUBTR%FORMAT) -! - WRITE (NDSN,10) TRIM(MSG),'BUNDY % FILENAME = ', TRIM(NML_SMC%BUNDY%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'BUNDY % IDF = ', NML_SMC%BUNDY%IDF - WRITE (NDSN,11) TRIM(MSG),'BUNDY % IDLA = ', NML_SMC%BUNDY%IDLA - WRITE (NDSN,11) TRIM(MSG),'BUNDY % IDFM = ', NML_SMC%BUNDY%IDFM - WRITE (NDSN,10) TRIM(MSG),'BUNDY % FORMAT = ', TRIM(NML_SMC%BUNDY%FORMAT) -! - WRITE (NDSN,10) TRIM(MSG),'MBARC % FILENAME = ', TRIM(NML_SMC%MBARC%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'MBARC % IDF = ', NML_SMC%MBARC%IDF - WRITE (NDSN,11) TRIM(MSG),'MBARC % IDLA = ', NML_SMC%MBARC%IDLA - WRITE (NDSN,11) TRIM(MSG),'MBARC % IDFM = ', NML_SMC%MBARC%IDFM - WRITE (NDSN,10) TRIM(MSG),'MBARC % FORMAT = ', TRIM(NML_SMC%MBARC%FORMAT) -! - WRITE (NDSN,10) TRIM(MSG),'AISID % FILENAME = ', TRIM(NML_SMC%AISID%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'AISID % IDF = ', NML_SMC%AISID%IDF - WRITE (NDSN,11) TRIM(MSG),'AISID % IDLA = ', NML_SMC%AISID%IDLA - WRITE (NDSN,11) TRIM(MSG),'AISID % IDFM = ', NML_SMC%AISID%IDFM - WRITE (NDSN,10) TRIM(MSG),'AISID % FORMAT = ', TRIM(NML_SMC%AISID%FORMAT) -! - WRITE (NDSN,10) TRIM(MSG),'AJSID % FILENAME = ', TRIM(NML_SMC%AJSID%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'AJSID % IDF = ', NML_SMC%AJSID%IDF - WRITE (NDSN,11) TRIM(MSG),'AJSID % IDLA = ', NML_SMC%AJSID%IDLA - WRITE (NDSN,11) TRIM(MSG),'AJSID % IDFM = ', NML_SMC%AJSID%IDFM - WRITE (NDSN,10) TRIM(MSG),'AJSID % FORMAT = ', TRIM(NML_SMC%AJSID%FORMAT) + INTEGER, SAVE :: IENT = 0 +#endif + +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_SMC_NML') +#endif + + WRITE (MSG,'(A)') 'SMC % ' + WRITE (NDSN,'(A)') + ! + WRITE (NDSN,10) TRIM(MSG),'MCELS % FILENAME = ', TRIM(NML_SMC%MCELS%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'MCELS % IDF = ', NML_SMC%MCELS%IDF + WRITE (NDSN,11) TRIM(MSG),'MCELS % IDLA = ', NML_SMC%MCELS%IDLA + WRITE (NDSN,11) TRIM(MSG),'MCELS % IDFM = ', NML_SMC%MCELS%IDFM + WRITE (NDSN,10) TRIM(MSG),'MCELS % FORMAT = ', TRIM(NML_SMC%MCELS%FORMAT) + ! + WRITE (NDSN,10) TRIM(MSG),'ISIDE % FILENAME = ', TRIM(NML_SMC%ISIDE%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'ISIDE % IDF = ', NML_SMC%ISIDE%IDF + WRITE (NDSN,11) TRIM(MSG),'ISIDE % IDLA = ', NML_SMC%ISIDE%IDLA + WRITE (NDSN,11) TRIM(MSG),'ISIDE % IDFM = ', NML_SMC%ISIDE%IDFM + WRITE (NDSN,10) TRIM(MSG),'ISIDE % FORMAT = ', TRIM(NML_SMC%ISIDE%FORMAT) + ! + WRITE (NDSN,10) TRIM(MSG),'JSIDE % FILENAME = ', TRIM(NML_SMC%JSIDE%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'JSIDE % IDF = ', NML_SMC%JSIDE%IDF + WRITE (NDSN,11) TRIM(MSG),'JSIDE % IDLA = ', NML_SMC%JSIDE%IDLA + WRITE (NDSN,11) TRIM(MSG),'JSIDE % IDFM = ', NML_SMC%JSIDE%IDFM + WRITE (NDSN,10) TRIM(MSG),'JSIDE % FORMAT = ', TRIM(NML_SMC%JSIDE%FORMAT) + ! + WRITE (NDSN,10) TRIM(MSG),'SUBTR % FILENAME = ', TRIM(NML_SMC%SUBTR%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'SUBTR % IDF = ', NML_SMC%SUBTR%IDF + WRITE (NDSN,11) TRIM(MSG),'SUBTR % IDLA = ', NML_SMC%SUBTR%IDLA + WRITE (NDSN,11) TRIM(MSG),'SUBTR % IDFM = ', NML_SMC%SUBTR%IDFM + WRITE (NDSN,10) TRIM(MSG),'SUBTR % FORMAT = ', TRIM(NML_SMC%SUBTR%FORMAT) + ! + WRITE (NDSN,10) TRIM(MSG),'BUNDY % FILENAME = ', TRIM(NML_SMC%BUNDY%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'BUNDY % IDF = ', NML_SMC%BUNDY%IDF + WRITE (NDSN,11) TRIM(MSG),'BUNDY % IDLA = ', NML_SMC%BUNDY%IDLA + WRITE (NDSN,11) TRIM(MSG),'BUNDY % IDFM = ', NML_SMC%BUNDY%IDFM + WRITE (NDSN,10) TRIM(MSG),'BUNDY % FORMAT = ', TRIM(NML_SMC%BUNDY%FORMAT) + ! + WRITE (NDSN,10) TRIM(MSG),'MBARC % FILENAME = ', TRIM(NML_SMC%MBARC%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'MBARC % IDF = ', NML_SMC%MBARC%IDF + WRITE (NDSN,11) TRIM(MSG),'MBARC % IDLA = ', NML_SMC%MBARC%IDLA + WRITE (NDSN,11) TRIM(MSG),'MBARC % IDFM = ', NML_SMC%MBARC%IDFM + WRITE (NDSN,10) TRIM(MSG),'MBARC % FORMAT = ', TRIM(NML_SMC%MBARC%FORMAT) + ! + WRITE (NDSN,10) TRIM(MSG),'AISID % FILENAME = ', TRIM(NML_SMC%AISID%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'AISID % IDF = ', NML_SMC%AISID%IDF + WRITE (NDSN,11) TRIM(MSG),'AISID % IDLA = ', NML_SMC%AISID%IDLA + WRITE (NDSN,11) TRIM(MSG),'AISID % IDFM = ', NML_SMC%AISID%IDFM + WRITE (NDSN,10) TRIM(MSG),'AISID % FORMAT = ', TRIM(NML_SMC%AISID%FORMAT) + ! + WRITE (NDSN,10) TRIM(MSG),'AJSID % FILENAME = ', TRIM(NML_SMC%AJSID%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'AJSID % IDF = ', NML_SMC%AJSID%IDF + WRITE (NDSN,11) TRIM(MSG),'AJSID % IDLA = ', NML_SMC%AJSID%IDLA + WRITE (NDSN,11) TRIM(MSG),'AJSID % IDFM = ', NML_SMC%AJSID%IDFM + WRITE (NDSN,10) TRIM(MSG),'AJSID % FORMAT = ', TRIM(NML_SMC%AJSID%FORMAT) 10 FORMAT (A,2X,A,A) @@ -3181,92 +3181,92 @@ SUBROUTINE REPORT_SMC_NML (NML_SMC) END SUBROUTINE REPORT_SMC_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_DEPTH_NML (NML_DEPTH) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_DEPTH Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_DEPTH Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_DEPTH_T), INTENT(IN) :: NML_DEPTH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_DEPTH_NML') + CALL STRACE (IENT, 'REPORT_DEPTH_NML') #endif - WRITE (MSG,'(A)') 'DEPTH % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_DEPTH%SF - WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_DEPTH%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_DEPTH%IDF - WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_DEPTH%IDLA - WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_DEPTH%IDFM - WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_DEPTH%FORMAT) - WRITE (NDSN,10) TRIM(MSG),'FROM = ', TRIM(NML_DEPTH%FROM) + WRITE (MSG,'(A)') 'DEPTH % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_DEPTH%SF + WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_DEPTH%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_DEPTH%IDF + WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_DEPTH%IDLA + WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_DEPTH%IDFM + WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_DEPTH%FORMAT) + WRITE (NDSN,10) TRIM(MSG),'FROM = ', TRIM(NML_DEPTH%FROM) 10 FORMAT (A,2X,A,A) @@ -3276,90 +3276,90 @@ SUBROUTINE REPORT_DEPTH_NML (NML_DEPTH) END SUBROUTINE REPORT_DEPTH_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_MASK_NML (NML_MASK) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_MASK Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_MASK Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_MASK_T), INTENT(IN) :: NML_MASK #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_MASK_NML') + CALL STRACE (IENT, 'REPORT_MASK_NML') #endif - WRITE (MSG,'(A)') 'MASK % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_MASK%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_MASK%IDF - WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_MASK%IDLA - WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_MASK%IDFM - WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_MASK%FORMAT) - WRITE (NDSN,10) TRIM(MSG),'FROM = ', TRIM(NML_MASK%FROM) + WRITE (MSG,'(A)') 'MASK % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_MASK%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_MASK%IDF + WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_MASK%IDLA + WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_MASK%IDFM + WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_MASK%FORMAT) + WRITE (NDSN,10) TRIM(MSG),'FROM = ', TRIM(NML_MASK%FROM) 10 FORMAT (A,2X,A,A) @@ -3369,93 +3369,93 @@ SUBROUTINE REPORT_MASK_NML (NML_MASK) END SUBROUTINE REPORT_MASK_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_OBST_NML (NML_OBST) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_OBST Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_OBST Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_OBST_T), INTENT(IN) :: NML_OBST #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_OBST_NML') + CALL STRACE (IENT, 'REPORT_OBST_NML') #endif - WRITE (MSG,'(A)') 'OBST % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_OBST%SF - WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_OBST%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_OBST%IDF - WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_OBST%IDLA - WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_OBST%IDFM - WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_OBST%FORMAT) - WRITE (NDSN,10) TRIM(MSG),'FROM = ', TRIM(NML_OBST%FROM) + WRITE (MSG,'(A)') 'OBST % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_OBST%SF + WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_OBST%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_OBST%IDF + WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_OBST%IDLA + WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_OBST%IDFM + WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_OBST%FORMAT) + WRITE (NDSN,10) TRIM(MSG),'FROM = ', TRIM(NML_OBST%FROM) 10 FORMAT (A,2X,A,A) @@ -3465,7 +3465,7 @@ SUBROUTINE REPORT_OBST_NML (NML_OBST) END SUBROUTINE REPORT_OBST_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -3473,86 +3473,86 @@ END SUBROUTINE REPORT_OBST_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_SLOPE_NML (NML_SLOPE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_SLOPE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_SLOPE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_SLOPE_T), INTENT(IN) :: NML_SLOPE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_SLOPE_NML') + CALL STRACE (IENT, 'REPORT_SLOPE_NML') #endif - WRITE (MSG,'(A)') 'SLOPE % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_SLOPE%SF - WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_SLOPE%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_SLOPE%IDF - WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_SLOPE%IDLA - WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_SLOPE%IDFM - WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_SLOPE%FORMAT) - WRITE (NDSN,10) TRIM(MSG),'FROM = ', TRIM(NML_SLOPE%FROM) + WRITE (MSG,'(A)') 'SLOPE % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_SLOPE%SF + WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_SLOPE%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_SLOPE%IDF + WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_SLOPE%IDLA + WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_SLOPE%IDFM + WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_SLOPE%FORMAT) + WRITE (NDSN,10) TRIM(MSG),'FROM = ', TRIM(NML_SLOPE%FROM) 10 FORMAT (A,2X,A,A) @@ -3562,7 +3562,7 @@ SUBROUTINE REPORT_SLOPE_NML (NML_SLOPE) END SUBROUTINE REPORT_SLOPE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -3571,86 +3571,86 @@ END SUBROUTINE REPORT_SLOPE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_SED_NML (NML_SED) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_SED Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_SED Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_SED_T), INTENT(IN) :: NML_SED #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_SED_NML') + CALL STRACE (IENT, 'REPORT_SED_NML') #endif - WRITE (MSG,'(A)') 'SED % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_SED%SF - WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_SED%FILENAME) - WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_SED%IDF - WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_SED%IDLA - WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_SED%IDFM - WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_SED%FORMAT) - WRITE (NDSN,10) TRIM(MSG),'FROM = ', TRIM(NML_SED%FROM) + WRITE (MSG,'(A)') 'SED % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,14) TRIM(MSG),'SF = ', NML_SED%SF + WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_SED%FILENAME) + WRITE (NDSN,11) TRIM(MSG),'IDF = ', NML_SED%IDF + WRITE (NDSN,11) TRIM(MSG),'IDLA = ', NML_SED%IDLA + WRITE (NDSN,11) TRIM(MSG),'IDFM = ', NML_SED%IDFM + WRITE (NDSN,10) TRIM(MSG),'FORMAT = ', TRIM(NML_SED%FORMAT) + WRITE (NDSN,10) TRIM(MSG),'FROM = ', TRIM(NML_SED%FROM) 10 FORMAT (A,2X,A,A) @@ -3660,72 +3660,72 @@ SUBROUTINE REPORT_SED_NML (NML_SED) END SUBROUTINE REPORT_SED_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_INBOUND_NML (NML_INBND_COUNT, NML_INBND_POINT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_INBND_COUNT Type -! NML_INBND_POINT Type -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_INBND_COUNT Type + ! NML_INBND_POINT Type + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -3736,11 +3736,11 @@ SUBROUTINE REPORT_INBOUND_NML (NML_INBND_COUNT, NML_INBND_POINT) ! locals INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_INBOUND_NML') + CALL STRACE (IENT, 'REPORT_INBOUND_NML') #endif WRITE (MSG,'(A)') 'INBND_COUNT % ' @@ -3765,71 +3765,71 @@ SUBROUTINE REPORT_INBOUND_NML (NML_INBND_COUNT, NML_INBND_POINT) END SUBROUTINE REPORT_INBOUND_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_EXCLUDED_NML (NML_EXCL_COUNT, NML_EXCL_POINT, NML_EXCL_BODY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_EXCL_COUNT Type -! NML_EXCL_POINT Type -! NML_EXCL_BODY Type -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_EXCL_COUNT Type + ! NML_EXCL_POINT Type + ! NML_EXCL_BODY Type + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -3841,11 +3841,11 @@ SUBROUTINE REPORT_EXCLUDED_NML (NML_EXCL_COUNT, NML_EXCL_POINT, NML_EXCL_BODY) ! locals INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_EXCLUDED_NML') + CALL STRACE (IENT, 'REPORT_EXCLUDED_NML') #endif WRITE (MSG,'(A)') 'EXCL_COUNT % ' @@ -3881,70 +3881,70 @@ SUBROUTINE REPORT_EXCLUDED_NML (NML_EXCL_COUNT, NML_EXCL_POINT, NML_EXCL_BODY) END SUBROUTINE REPORT_EXCLUDED_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_OUTBOUND_NML (NML_OUTBND_COUNT, NML_OUTBND_LINE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_OUTBND_COUNT Type -! NML_OUTBND_LINE Type -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLGRID Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_OUTBND_COUNT Type + ! NML_OUTBND_LINE Type + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLGRID Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -3955,11 +3955,11 @@ SUBROUTINE REPORT_OUTBOUND_NML (NML_OUTBND_COUNT, NML_OUTBND_LINE) ! locals INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_OUTBOUND_NML') + CALL STRACE (IENT, 'REPORT_OUTBOUND_NML') #endif WRITE (MSG,'(A)') 'OUTBND_COUNT % ' @@ -3986,7 +3986,7 @@ SUBROUTINE REPORT_OUTBOUND_NML (NML_OUTBND_COUNT, NML_OUTBND_LINE) END SUBROUTINE REPORT_OUTBOUND_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -3998,4 +3998,3 @@ END SUBROUTINE REPORT_OUTBOUND_NML END MODULE W3NMLGRIDMD !/ ------------------------------------------------------------------- / - diff --git a/model/src/w3nmlmultimd.F90 b/model/src/w3nmlmultimd.F90 index b0208096c..e64b04429 100644 --- a/model/src/w3nmlmultimd.F90 +++ b/model/src/w3nmlmultimd.F90 @@ -1,22 +1,22 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3NMLMULTIMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutines. -!/ -! 1. Purpose : -! -! Manages namelists from configuration file ww3_multi.nml for ww3_multi program -! +#include "w3macros.h" !/ ------------------------------------------------------------------- / +MODULE W3NMLMULTIMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutines. + !/ + ! 1. Purpose : + ! + ! Manages namelists from configuration file ww3_multi.nml for ww3_multi program + ! + !/ ------------------------------------------------------------------- / ! module defaults IMPLICIT NONE @@ -56,21 +56,21 @@ MODULE W3NMLMULTIMD CHARACTER(13) :: MUD_THICKNESS CHARACTER(13) :: MUD_VISCOSITY END TYPE NML_MODEL_FORCING_T -! + ! TYPE NML_MODEL_ASSIM_T CHARACTER(13) :: MEAN CHARACTER(13) :: SPEC1D CHARACTER(13) :: SPEC2D END TYPE NML_MODEL_ASSIM_T -! + ! TYPE NML_MODEL_RESOURCE_T INTEGER :: RANK_ID INTEGER :: GROUP_ID REAL(4) :: COMM_FRAC(2) LOGICAL :: BOUND_FLAG END TYPE NML_MODEL_RESOURCE_T -! - TYPE NML_MODEL_GRID_T + ! + TYPE NML_MODEL_GRID_T CHARACTER(13) :: NAME TYPE(NML_MODEL_FORCING_T) :: FORCING TYPE(NML_MODEL_ASSIM_T) :: ASSIM @@ -96,13 +96,13 @@ MODULE W3NMLMULTIMD LOGICAL :: MUD_THICKNESS LOGICAL :: MUD_VISCOSITY END TYPE NML_INPUT_FORCING_T -! + ! TYPE NML_INPUT_ASSIM_T LOGICAL :: MEAN LOGICAL :: SPEC1D LOGICAL :: SPEC2D END TYPE NML_INPUT_ASSIM_T -! + ! TYPE NML_INPUT_GRID_T CHARACTER(13) :: NAME TYPE(NML_INPUT_FORCING_T) :: FORCING @@ -115,16 +115,16 @@ MODULE W3NMLMULTIMD TYPE NML_FIELD_T CHARACTER(1024) :: LIST END TYPE NML_FIELD_T -! + ! TYPE NML_POINT_T CHARACTER(13) :: NAME CHARACTER(64) :: FILE END TYPE NML_POINT_T -! + ! TYPE NML_TRACK_T LOGICAL :: FORMAT END TYPE NML_TRACK_T -! + ! TYPE NML_PARTITION_T INTEGER :: X0 INTEGER :: XN @@ -134,7 +134,7 @@ MODULE W3NMLMULTIMD INTEGER :: NY LOGICAL :: FORMAT END TYPE NML_PARTITION_T -! + ! #ifdef W3_COU TYPE NML_COUPLING_T CHARACTER(1024) :: SENT @@ -142,11 +142,11 @@ MODULE W3NMLMULTIMD LOGICAL :: COUPLET0 END TYPE NML_COUPLING_T #endif -! + ! TYPE NML_RESTART_T CHARACTER(1024) :: EXTRA END TYPE NML_RESTART_T -! + ! TYPE NML_OUTPUT_TYPE_T TYPE(NML_POINT_T) :: POINT TYPE(NML_FIELD_T) :: FIELD @@ -161,14 +161,14 @@ MODULE W3NMLMULTIMD ! output date structure - TYPE NML_OUTPUT_TIME_T + TYPE NML_OUTPUT_TIME_T CHARACTER(15) :: START CHARACTER(15) :: STRIDE CHARACTER(15) :: STOP CHARACTER(1) :: OUTFFILE -! + ! END TYPE NML_OUTPUT_TIME_T -! + ! TYPE NML_OUTPUT_DATE_T TYPE(NML_OUTPUT_TIME_T) :: FIELD TYPE(NML_OUTPUT_TIME_T) :: POINT @@ -189,7 +189,7 @@ MODULE W3NMLMULTIMD INTEGER :: N_MOV INTEGER :: N_TOT END TYPE NML_HOMOG_COUNT_T -! + ! TYPE NML_HOMOG_INPUT_T CHARACTER(15) :: NAME CHARACTER(15) :: DATE @@ -205,105 +205,105 @@ MODULE W3NMLMULTIMD - CONTAINS -!/ ------------------------------------------------------------------- / +CONTAINS + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLMULTIDEF (MPI_COMM, NDSI, INFILE, NML_DOMAIN, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -! -! 1. Purpose : -! -! Reads the domain definition namelist to define the number of -! model and forcing grids -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MPI_COMM Int. Public Communicator used in the wave MODEL. -! NDSI Int. -! INFILE Char. -! NML_DOMAIN type. -! IERR Int. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_DOMAIN_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINITNML Subr. N/A Model configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + ! + ! 1. Purpose : + ! + ! Reads the domain definition namelist to define the number of + ! model and forcing grids + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MPI_COMM Int. Public Communicator used in the wave MODEL. + ! NDSI Int. + ! INFILE Char. + ! NML_DOMAIN type. + ! IERR Int. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_DOMAIN_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINITNML Subr. N/A Model configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE, IMPROC, NMPLOG #ifdef W3_MPI - USE WMMDATMD, ONLY: MPI_COMM_MWAVE + USE WMMDATMD, ONLY: MPI_COMM_MWAVE #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE INTEGER, INTENT(IN) :: MPI_COMM, NDSI CHARACTER*(*), INTENT(IN) :: INFILE - TYPE(NML_DOMAIN_T), INTENT(OUT) :: NML_DOMAIN + TYPE(NML_DOMAIN_T), INTENT(OUT) :: NML_DOMAIN INTEGER, INTENT(OUT) :: IERR ! locals #ifdef W3_MPI - INTEGER :: IERR_MPI + INTEGER :: IERR_MPI #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'W3NMLMULTIDEF') + CALL STRACE (IENT, 'W3NMLMULTIDEF') #endif #ifdef W3_MPI - MPI_COMM_MWAVE = MPI_COMM - CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) - IMPROC = IMPROC + 1 + MPI_COMM_MWAVE = MPI_COMM + CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 #endif ! open namelist log file @@ -333,104 +333,104 @@ SUBROUTINE W3NMLMULTIDEF (MPI_COMM, NDSI, INFILE, NML_DOMAIN, IERR) END SUBROUTINE W3NMLMULTIDEF -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLMULTICONF (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & - NML_INPUT_GRID, NML_MODEL_GRID, & - NML_OUTPUT_TYPE, NML_OUTPUT_DATE, & - NML_HOMOG_COUNT, NML_HOMOG_INPUT, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) - -! 1. Purpose : -! -! Reads all the namelist to define the multi grid -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MPI_COMM Int. Public Communicator used in the wave MODEL. -! NDSI -! INFILE -! NML_DOMAIN -! NML_INPUT_GRID -! NML_MODEL_GRID -! NML_OUTPUT_TYPE -! NML_OUTPUT_DATE -! NML_HOMOG_COUNT -! NML_HOMOG_INPUT -! IERR -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_INPUT_GRID_NML -! REPORT_INPUT_GRID_NML -! READ_MODEL_GRID_NML -! REPORT_MODEL_GRID_NML -! READ_OUTPUT_TYPE_NML -! REPORT_OUTPUT_TYPE_NML -! READ_OUTPUT_DATE_NML -! REPORT_OUTPUT_DATE_NML -! READ_HOMOGENEOUS_NML -! REPORT_HOMOGENEOUS_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINITNML Subr. N/A Model configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + NML_INPUT_GRID, NML_MODEL_GRID, & + NML_OUTPUT_TYPE, NML_OUTPUT_DATE, & + NML_HOMOG_COUNT, NML_HOMOG_INPUT, IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + + ! 1. Purpose : + ! + ! Reads all the namelist to define the multi grid + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MPI_COMM Int. Public Communicator used in the wave MODEL. + ! NDSI + ! INFILE + ! NML_DOMAIN + ! NML_INPUT_GRID + ! NML_MODEL_GRID + ! NML_OUTPUT_TYPE + ! NML_OUTPUT_DATE + ! NML_HOMOG_COUNT + ! NML_HOMOG_INPUT + ! IERR + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_INPUT_GRID_NML + ! REPORT_INPUT_GRID_NML + ! READ_MODEL_GRID_NML + ! REPORT_MODEL_GRID_NML + ! READ_OUTPUT_TYPE_NML + ! REPORT_OUTPUT_TYPE_NML + ! READ_OUTPUT_DATE_NML + ! REPORT_OUTPUT_DATE_NML + ! READ_HOMOGENEOUS_NML + ! REPORT_HOMOGENEOUS_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINITNML Subr. N/A Model configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE, IMPROC, NMPLOG #ifdef W3_MPI - USE WMMDATMD, ONLY: MPI_COMM_MWAVE + USE WMMDATMD, ONLY: MPI_COMM_MWAVE #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -438,8 +438,8 @@ SUBROUTINE W3NMLMULTICONF (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & INTEGER, INTENT(IN) :: MPI_COMM, NDSI CHARACTER*(*), INTENT(IN) :: INFILE TYPE(NML_DOMAIN_T), INTENT(INOUT) :: NML_DOMAIN - TYPE(NML_INPUT_GRID_T), INTENT(INOUT) :: NML_INPUT_GRID(:) - TYPE(NML_MODEL_GRID_T), INTENT(INOUT) :: NML_MODEL_GRID(:) + TYPE(NML_INPUT_GRID_T), INTENT(INOUT) :: NML_INPUT_GRID(:) + TYPE(NML_MODEL_GRID_T), INTENT(INOUT) :: NML_MODEL_GRID(:) TYPE(NML_OUTPUT_TYPE_T), INTENT(INOUT) :: NML_OUTPUT_TYPE(:) TYPE(NML_OUTPUT_DATE_T), INTENT(INOUT) :: NML_OUTPUT_DATE(:) TYPE(NML_HOMOG_COUNT_T), INTENT(INOUT) :: NML_HOMOG_COUNT @@ -448,21 +448,21 @@ SUBROUTINE W3NMLMULTICONF (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & ! locals #ifdef W3_MPI - INTEGER :: IERR_MPI + INTEGER :: IERR_MPI #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'W3NMLMULTICONF') + CALL STRACE (IENT, 'W3NMLMULTICONF') #endif #ifdef W3_MPI - MPI_COMM_MWAVE = MPI_COMM - CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) - IMPROC = IMPROC + 1 + MPI_COMM_MWAVE = MPI_COMM + CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 #endif ! open namelist log file @@ -509,79 +509,79 @@ SUBROUTINE W3NMLMULTICONF (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & END SUBROUTINE W3NMLMULTICONF -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) - -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_DOMAIN Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTIDEF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_DOMAIN Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTIDEF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -594,12 +594,12 @@ SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) TYPE(NML_DOMAIN_T) :: DOMAIN NAMELIST /DOMAIN_NML/ DOMAIN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_DOMAIN_NML') + CALL STRACE (IENT, 'READ_DOMAIN_NML') #endif ! set default values for model definition data @@ -619,8 +619,8 @@ SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) READ (NDSI, nml=DOMAIN_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_DOMAIN_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_DOMAIN_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (1) END IF @@ -643,80 +643,80 @@ SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) END SUBROUTINE READ_DOMAIN_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_INPUT_GRID_NML (NDSI, NRINP, NML_INPUT_GRID) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ 22-Mar-2021 : Update namelist, new input fields ( version 7.13 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NRINP Int. -! NML_INPUT_GRID Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ 22-Mar-2021 : Update namelist, new input fields ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NRINP Int. + ! NML_INPUT_GRID Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -730,20 +730,20 @@ SUBROUTINE READ_INPUT_GRID_NML (NDSI, NRINP, NML_INPUT_GRID) TYPE(NML_INPUT_GRID_T) :: INPUT(MAX_NRINP) NAMELIST /INPUT_GRID_NML/ INPUT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_INPUT_GRID_NML') + CALL STRACE (IENT, 'READ_INPUT_GRID_NML') #endif ! test NRINP IF (NRINP.GT.MAX_NRINP) THEN WRITE (MDSE,'(A,/A,I6,/A,I6)') & - 'ERROR: READ_INPUT_GRID_NML: NRINP > MAX_NRINP', & - 'ERROR: READ_INPUT_GRID_NML: NRINP = ', NRINP, & - 'ERROR: READ_INPUT_GRID_NML: MAX_NRINP = ',MAX_NRINP + 'ERROR: READ_INPUT_GRID_NML: NRINP > MAX_NRINP', & + 'ERROR: READ_INPUT_GRID_NML: NRINP = ', NRINP, & + 'ERROR: READ_INPUT_GRID_NML: MAX_NRINP = ',MAX_NRINP CALL EXTCDE (6) END IF @@ -777,8 +777,8 @@ SUBROUTINE READ_INPUT_GRID_NML (NDSI, NRINP, NML_INPUT_GRID) READ (NDSI, nml=INPUT_GRID_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_INPUT_GRID_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_INPUT_GRID_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (7) END IF @@ -797,80 +797,80 @@ SUBROUTINE READ_INPUT_GRID_NML (NDSI, NRINP, NML_INPUT_GRID) END SUBROUTINE READ_INPUT_GRID_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_MODEL_GRID_NML (NDSI, NRGRD, NML_MODEL_GRID) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ 22-Mar-2021 : Update namelist, new input fields ( version 7.13 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NRGRD Int. -! NML_MODEL_GRID Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ 22-Mar-2021 : Update namelist, new input fields ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NRGRD Int. + ! NML_MODEL_GRID Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -884,20 +884,20 @@ SUBROUTINE READ_MODEL_GRID_NML (NDSI, NRGRD, NML_MODEL_GRID) TYPE(NML_MODEL_GRID_T) :: MODEL(MAX_NRGRD) NAMELIST /MODEL_GRID_NML/ MODEL #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_MODEL_GRID_NML') + CALL STRACE (IENT, 'READ_MODEL_GRID_NML') #endif ! test NRGRD IF (NRGRD.GT.MAX_NRGRD) THEN WRITE (MDSE,'(A,/A,I6,/A,I6)') & - 'ERROR: READ_MODEL_GRID_NML: NRGRD > MAX_NRGRD', & - 'ERROR: READ_MODEL_GRID_NML: NRGRD = ', NRGRD, & - 'ERROR: READ_MODEL_GRID_NML: MAX_NRGRD = ',MAX_NRGRD + 'ERROR: READ_MODEL_GRID_NML: NRGRD > MAX_NRGRD', & + 'ERROR: READ_MODEL_GRID_NML: NRGRD = ', NRGRD, & + 'ERROR: READ_MODEL_GRID_NML: MAX_NRGRD = ',MAX_NRGRD CALL EXTCDE (9) END IF @@ -935,8 +935,8 @@ SUBROUTINE READ_MODEL_GRID_NML (NDSI, NRGRD, NML_MODEL_GRID) READ (NDSI, nml=MODEL_GRID_NML, iostat=IERR, iomsg=MSG) IF (IERR.NE.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_MODEL_GRID_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_MODEL_GRID_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (10) END IF @@ -955,80 +955,80 @@ SUBROUTINE READ_MODEL_GRID_NML (NDSI, NRGRD, NML_MODEL_GRID) END SUBROUTINE READ_MODEL_GRID_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NRGRD, NML_OUTPUT_TYPE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 25-Sep-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ 25-Sep-2020 : Update namelist ( version 7.10 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NRGRD Int. -! NML_OUTPUT_TYPE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 25-Sep-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ 25-Sep-2020 : Update namelist ( version 7.10 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NRGRD Int. + ! NML_OUTPUT_TYPE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1043,12 +1043,12 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NRGRD, NML_OUTPUT_TYPE) TYPE(NML_OUTPUT_TYPE_T) :: ITYPE(MAX_NRGRD) NAMELIST /OUTPUT_TYPE_NML/ ALLTYPE, ITYPE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_OUTPUT_TYPE_NML') + CALL STRACE (IENT, 'READ_OUTPUT_TYPE_NML') #endif ! if no model grids, then exit @@ -1098,8 +1098,8 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NRGRD, NML_OUTPUT_TYPE) READ (NDSI, nml=OUTPUT_TYPE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_OUTPUT_TYPE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_OUTPUT_TYPE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (12) END IF @@ -1113,90 +1113,90 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NRGRD, NML_OUTPUT_TYPE) READ (NDSI, nml=OUTPUT_TYPE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_OUTPUT_TYPE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_OUTPUT_TYPE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (13) END IF ! save namelist NML_OUTPUT_TYPE = ITYPE(1:NRGRD) - + END SUBROUTINE READ_OUTPUT_TYPE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NRGRD, NML_OUTPUT_DATE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NRGRD Int. -! NML_OUTPUT_DATE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NRGRD Int. + ! NML_OUTPUT_DATE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1211,12 +1211,12 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NRGRD, NML_OUTPUT_DATE) TYPE(NML_OUTPUT_DATE_T) :: IDATE(MAX_NRGRD) NAMELIST /OUTPUT_DATE_NML/ ALLDATE, IDATE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_OUTPUT_DATE_NML') + CALL STRACE (IENT, 'READ_OUTPUT_DATE_NML') #endif ! if no model grids, then exit @@ -1288,8 +1288,8 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NRGRD, NML_OUTPUT_DATE) READ (NDSI, nml=OUTPUT_DATE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_OUTPUT_DATE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_OUTPUT_DATE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (14) END IF @@ -1303,8 +1303,8 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NRGRD, NML_OUTPUT_DATE) READ (NDSI, nml=OUTPUT_DATE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_OUTPUT_DATE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_OUTPUT_DATE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (15) END IF @@ -1314,79 +1314,79 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NRGRD, NML_OUTPUT_DATE) END SUBROUTINE READ_OUTPUT_DATE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_HOMOG_COUNT Type. -! NML_HOMOG_INPUT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_HOMOG_COUNT Type. + ! NML_HOMOG_INPUT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1402,12 +1402,12 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) TYPE(NML_HOMOG_INPUT_T), ALLOCATABLE :: HOMOG_INPUT(:) NAMELIST /HOMOG_INPUT_NML/ HOMOG_INPUT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_HOMOGENEOUS_NML') + CALL STRACE (IENT, 'READ_HOMOGENEOUS_NML') #endif @@ -1421,8 +1421,8 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) READ (NDSI, nml=HOMOG_COUNT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_HOMOGENEOUS_NML: namelist HOMOG_COUNT read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_HOMOGENEOUS_NML: namelist HOMOG_COUNT read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (16) END IF @@ -1447,8 +1447,8 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) READ (NDSI, nml=HOMOG_INPUT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_HOMOGENEOUS_NML: namelist HOMOG_INPUT_NML read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_HOMOGENEOUS_NML: namelist HOMOG_INPUT_NML read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (17) END IF @@ -1456,10 +1456,10 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) NML_HOMOG_COUNT = HOMOG_COUNT NML_HOMOG_INPUT = HOMOG_INPUT - + END SUBROUTINE READ_HOMOGENEOUS_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -1469,93 +1469,93 @@ END SUBROUTINE READ_HOMOGENEOUS_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_DOMAIN_NML (NML_DOMAIN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_DOMAIN Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_DOMAIN Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_DOMAIN_T), INTENT(IN) :: NML_DOMAIN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_DOMAIN_NML') + CALL STRACE (IENT, 'REPORT_DOMAIN_NML') #endif - WRITE (MSG,'(A)') 'DOMAIN % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,11) TRIM(MSG),'NRINP = ', NML_DOMAIN%NRINP - WRITE (NDSN,11) TRIM(MSG),'NRGRD = ', NML_DOMAIN%NRGRD - WRITE (NDSN,13) TRIM(MSG),'UNIPTS = ', NML_DOMAIN%UNIPTS - WRITE (NDSN,11) TRIM(MSG),'IOSTYP = ', NML_DOMAIN%IOSTYP - WRITE (NDSN,13) TRIM(MSG),'UPPROC = ', NML_DOMAIN%UPPROC - WRITE (NDSN,13) TRIM(MSG),'PSHARE = ', NML_DOMAIN%PSHARE - WRITE (NDSN,13) TRIM(MSG),'FLGHG1 = ', NML_DOMAIN%FLGHG1 - WRITE (NDSN,13) TRIM(MSG),'FLGHG2 = ', NML_DOMAIN%FLGHG2 - WRITE (NDSN,10) TRIM(MSG),'START = ', TRIM(NML_DOMAIN%START) - WRITE (NDSN,10) TRIM(MSG),'STOP = ', TRIM(NML_DOMAIN%STOP) + WRITE (MSG,'(A)') 'DOMAIN % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,11) TRIM(MSG),'NRINP = ', NML_DOMAIN%NRINP + WRITE (NDSN,11) TRIM(MSG),'NRGRD = ', NML_DOMAIN%NRGRD + WRITE (NDSN,13) TRIM(MSG),'UNIPTS = ', NML_DOMAIN%UNIPTS + WRITE (NDSN,11) TRIM(MSG),'IOSTYP = ', NML_DOMAIN%IOSTYP + WRITE (NDSN,13) TRIM(MSG),'UPPROC = ', NML_DOMAIN%UPPROC + WRITE (NDSN,13) TRIM(MSG),'PSHARE = ', NML_DOMAIN%PSHARE + WRITE (NDSN,13) TRIM(MSG),'FLGHG1 = ', NML_DOMAIN%FLGHG1 + WRITE (NDSN,13) TRIM(MSG),'FLGHG2 = ', NML_DOMAIN%FLGHG2 + WRITE (NDSN,10) TRIM(MSG),'START = ', TRIM(NML_DOMAIN%START) + WRITE (NDSN,10) TRIM(MSG),'STOP = ', TRIM(NML_DOMAIN%STOP) 10 FORMAT (A,2X,A,A) 11 FORMAT (A,2X,A,I8) @@ -1563,77 +1563,77 @@ SUBROUTINE REPORT_DOMAIN_NML (NML_DOMAIN) END SUBROUTINE REPORT_DOMAIN_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_INPUT_GRID_NML (NRINP, NML_INPUT_GRID) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ 22-Mar-2021 : Update namelist, new input fields ( version 7.13 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NRINP Int. -! NML_INPUT_GRID Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ 22-Mar-2021 : Update namelist, new input fields ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NRINP Int. + ! NML_INPUT_GRID Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1644,11 +1644,11 @@ SUBROUTINE REPORT_INPUT_GRID_NML (NRINP, NML_INPUT_GRID) ! locals INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_INPUT_GRID_NML') + CALL STRACE (IENT, 'REPORT_INPUT_GRID_NML') #endif DO I = 1,NRINP @@ -1680,77 +1680,77 @@ SUBROUTINE REPORT_INPUT_GRID_NML (NRINP, NML_INPUT_GRID) END SUBROUTINE REPORT_INPUT_GRID_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_MODEL_GRID_NML (NRGRD, NML_MODEL_GRID) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ 22-Mar-2021 : Update namelist, new input fields ( version 7.13 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NRGRD Int. -! NML_MODEL_GRID Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ 22-Mar-2021 : Update namelist, new input fields ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NRGRD Int. + ! NML_MODEL_GRID Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1761,11 +1761,11 @@ SUBROUTINE REPORT_MODEL_GRID_NML (NRGRD, NML_MODEL_GRID) ! locals INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_MODEL_GRID_NML') + CALL STRACE (IENT, 'REPORT_MODEL_GRID_NML') #endif DO I = 1,NRGRD @@ -1792,7 +1792,7 @@ SUBROUTINE REPORT_MODEL_GRID_NML (NRGRD, NML_MODEL_GRID) WRITE (NDSN,11) TRIM(MSG),'RESOURCE % RANK_ID = ', NML_MODEL_GRID(I)%RESOURCE%RANK_ID WRITE (NDSN,11) TRIM(MSG),'RESOURCE % GROUP_ID = ', NML_MODEL_GRID(I)%RESOURCE%GROUP_ID WRITE (NDSN,12) TRIM(MSG),'RESOURCE % COMM_FRAC = ', NML_MODEL_GRID(I)%RESOURCE%COMM_FRAC(1), & - NML_MODEL_GRID(I)%RESOURCE%COMM_FRAC(2) + NML_MODEL_GRID(I)%RESOURCE%COMM_FRAC(2) WRITE (NDSN,13) TRIM(MSG),'RESOURCE % BOUND_FLAG = ', NML_MODEL_GRID(I)%RESOURCE%BOUND_FLAG END DO WRITE (NDSN,'(A)') @@ -1804,77 +1804,77 @@ SUBROUTINE REPORT_MODEL_GRID_NML (NRGRD, NML_MODEL_GRID) END SUBROUTINE REPORT_MODEL_GRID_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_OUTPUT_TYPE_NML (NRGRD, NML_OUTPUT_TYPE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 25-Sep-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ 25-Sep-2020 : Update namelist ( version 7.10 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NRGRD Int. -! NML_OUTPUT_TYPE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 25-Sep-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ 25-Sep-2020 : Update namelist ( version 7.10 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NRGRD Int. + ! NML_OUTPUT_TYPE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1885,11 +1885,11 @@ SUBROUTINE REPORT_OUTPUT_TYPE_NML (NRGRD, NML_OUTPUT_TYPE) ! locals INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_OUTPUT_TYPE_NML') + CALL STRACE (IENT, 'REPORT_OUTPUT_TYPE_NML') #endif DO I=1,NRGRD @@ -1921,76 +1921,76 @@ SUBROUTINE REPORT_OUTPUT_TYPE_NML (NRGRD, NML_OUTPUT_TYPE) END SUBROUTINE REPORT_OUTPUT_TYPE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_OUTPUT_DATE_NML (NRGRD, NML_OUTPUT_DATE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NRGRD Int. -! NML_OUTPUT_DATE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NRGRD Int. + ! NML_OUTPUT_DATE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -2001,11 +2001,11 @@ SUBROUTINE REPORT_OUTPUT_DATE_NML (NRGRD, NML_OUTPUT_DATE) ! locals INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_OUTPUT_DATE_NML') + CALL STRACE (IENT, 'REPORT_OUTPUT_DATE_NML') #endif DO I=1,NRGRD @@ -2044,76 +2044,76 @@ SUBROUTINE REPORT_OUTPUT_DATE_NML (NRGRD, NML_OUTPUT_DATE) END SUBROUTINE REPORT_OUTPUT_DATE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_HOMOGENEOUS_NML (NML_HOMOG_COUNT, NML_HOMOG_INPUT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2016 : Adding comments ( version 5.12 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_HOMOG_COUNT Type. -! NML_HOMOG_INPUT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLMULTICONF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2016 : Adding comments ( version 5.12 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_HOMOG_COUNT Type. + ! NML_HOMOG_INPUT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLMULTICONF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -2124,11 +2124,11 @@ SUBROUTINE REPORT_HOMOGENEOUS_NML (NML_HOMOG_COUNT, NML_HOMOG_INPUT) ! locals INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_HOMOGENEOUS_NML') + CALL STRACE (IENT, 'REPORT_HOMOGENEOUS_NML') #endif WRITE (MSG,'(A)') 'HOMOG_COUNT % ' @@ -2156,7 +2156,7 @@ SUBROUTINE REPORT_HOMOGENEOUS_NML (NML_HOMOG_COUNT, NML_HOMOG_INPUT) END SUBROUTINE REPORT_HOMOGENEOUS_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / diff --git a/model/src/w3nmlounfmd.F90 b/model/src/w3nmlounfmd.F90 index 1ff1b254c..f0c7f100b 100644 --- a/model/src/w3nmlounfmd.F90 +++ b/model/src/w3nmlounfmd.F90 @@ -1,22 +1,22 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3NMLOUNFMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 12-Jan-2021 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutines. -!/ -! 1. Purpose : -! -! Manages namelists from configuration file ww3_ounf.nml for ww3_ounf program -! +#include "w3macros.h" !/ ------------------------------------------------------------------- / +MODULE W3NMLOUNFMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 12-Jan-2021 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutines. + !/ + ! 1. Purpose : + ! + ! Manages namelists from configuration file ww3_ounf.nml for ww3_ounf program + ! + !/ ------------------------------------------------------------------- / ! module defaults IMPLICIT NONE @@ -70,73 +70,73 @@ MODULE W3NMLOUNFMD - CONTAINS -!/ ------------------------------------------------------------------- / +CONTAINS + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLOUNF (NDSI, INFILE, NML_FIELD, NML_FILE, NML_SMC, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 12-Jan-2021 | -!/ +-----------------------------------+ -!/ -! -! 1. Purpose : -! -! Reads all the namelist to define the output field -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! INFILE Char. -! NML_FIELD type. -! NML_FILE type. -! NML_SMC type. -! IERR Int. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_FIELD_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! WW3_OUNF Prog. N/A Postprocess output fields. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 12-Jan-2021 | + !/ +-----------------------------------+ + !/ + ! + ! 1. Purpose : + ! + ! Reads all the namelist to define the output field + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! INFILE Char. + ! NML_FIELD type. + ! NML_FILE type. + ! NML_SMC type. + ! IERR Int. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_FIELD_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! WW3_OUNF Prog. N/A Postprocess output fields. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -148,18 +148,18 @@ SUBROUTINE W3NMLOUNF (NDSI, INFILE, NML_FIELD, NML_FILE, NML_SMC, IERR) TYPE(NML_SMC_T), INTENT(INOUT) :: NML_SMC INTEGER, INTENT(OUT) :: IERR #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'W3NMLOUNF') + CALL STRACE (IENT, 'W3NMLOUNF') #endif ! open namelist log file NDSN = 3 OPEN (NDSN, file=TRIM(INFILE)//'.log', form='formatted', iostat=IERR) - IF (IERR.NE.0) THEN + IF (IERR.NE.0) THEN WRITE (NDSE,'(A)') 'ERROR: open full nml file '//TRIM(INFILE)//'.log failed' RETURN END IF @@ -190,74 +190,74 @@ SUBROUTINE W3NMLOUNF (NDSI, INFILE, NML_FIELD, NML_FILE, NML_SMC, IERR) END SUBROUTINE W3NMLOUNF -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_FIELD_NML (NDSI, NML_FIELD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 12-Jan-2021 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_FIELD Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 12-Jan-2021 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_FIELD Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif USE CONSTANTS, ONLY: UNDEF @@ -271,12 +271,12 @@ SUBROUTINE READ_FIELD_NML (NDSI, NML_FIELD) TYPE(NML_FIELD_T) :: FIELD NAMELIST /FIELD_NML/ FIELD #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_FIELD_NML') + CALL STRACE (IENT, 'READ_FIELD_NML') #endif ! set default values for field structure @@ -302,8 +302,8 @@ SUBROUTINE READ_FIELD_NML (NDSI, NML_FIELD) READ (NDSI, nml=FIELD_NML, iostat=IERR, iomsg=MSG) IF (IERR.NE.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_FIELD_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_FIELD_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (1) END IF @@ -315,71 +315,71 @@ SUBROUTINE READ_FIELD_NML (NDSI, NML_FIELD) END SUBROUTINE READ_FIELD_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_FILE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_FILE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -392,12 +392,12 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) TYPE(NML_FILE_T) :: FILE NAMELIST /FILE_NML/ FILE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_FILE_NML') + CALL STRACE (IENT, 'READ_FILE_NML') #endif ! set default values for file structure @@ -413,8 +413,8 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) READ (NDSI, nml=FILE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_FILE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_FILE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (2) END IF @@ -423,71 +423,71 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) END SUBROUTINE READ_FILE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 19-Sep-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_SMC Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 19-Sep-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_SMC Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -500,12 +500,12 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) TYPE(NML_SMC_T) :: SMC NAMELIST /SMC_NML/ SMC #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_SMC_NML') + CALL STRACE (IENT, 'READ_SMC_NML') #endif ! set default values for smc structure @@ -521,8 +521,8 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) READ (NDSI, nml=SMC_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_SMC_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_SMC_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (3) END IF @@ -531,98 +531,98 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) END SUBROUTINE READ_SMC_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_FIELD_NML (NML_FIELD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_FIELD Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_FIELD Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_FIELD_T), INTENT(IN) :: NML_FIELD #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_FIELD_NML') + CALL STRACE (IENT, 'REPORT_FIELD_NML') #endif - WRITE (MSG,'(A)') 'FIELD % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'TIMESTART = ', TRIM(NML_FIELD%TIMESTART) - WRITE (NDSN,10) TRIM(MSG),'TIMESTRIDE = ', TRIM(NML_FIELD%TIMESTRIDE) - WRITE (NDSN,10) TRIM(MSG),'TIMECOUNT = ', TRIM(NML_FIELD%TIMECOUNT) + WRITE (MSG,'(A)') 'FIELD % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'TIMESTART = ', TRIM(NML_FIELD%TIMESTART) + WRITE (NDSN,10) TRIM(MSG),'TIMESTRIDE = ', TRIM(NML_FIELD%TIMESTRIDE) + WRITE (NDSN,10) TRIM(MSG),'TIMECOUNT = ', TRIM(NML_FIELD%TIMECOUNT) - WRITE (NDSN,11) TRIM(MSG),'TIMESPLIT = ', NML_FIELD%TIMESPLIT - WRITE (NDSN,10) TRIM(MSG),'LIST = ', TRIM(NML_FIELD%LIST) - WRITE (NDSN,10) TRIM(MSG),'PARTITION = ', TRIM(NML_FIELD%PARTITION) - WRITE (NDSN,13) TRIM(MSG),'SAMEFILE = ', NML_FIELD%SAMEFILE - WRITE (NDSN,11) TRIM(MSG),'TYPE = ', NML_FIELD%TYPE - WRITE (NDSN,10) TRIM(MSG),'FCVARS = ', NML_FIELD%FCVARS - WRITE (NDSN,10) TRIM(MSG),'TIMEREF = ', NML_FIELD%TIMEREF - WRITE (NDSN,14) TRIM(MSG),'NOVAL = ', NML_FIELD%NOVAL - WRITE (NDSN,13) TRIM(MSG),'MAPSTA = ', NML_FIELD%MAPSTA + WRITE (NDSN,11) TRIM(MSG),'TIMESPLIT = ', NML_FIELD%TIMESPLIT + WRITE (NDSN,10) TRIM(MSG),'LIST = ', TRIM(NML_FIELD%LIST) + WRITE (NDSN,10) TRIM(MSG),'PARTITION = ', TRIM(NML_FIELD%PARTITION) + WRITE (NDSN,13) TRIM(MSG),'SAMEFILE = ', NML_FIELD%SAMEFILE + WRITE (NDSN,11) TRIM(MSG),'TYPE = ', NML_FIELD%TYPE + WRITE (NDSN,10) TRIM(MSG),'FCVARS = ', NML_FIELD%FCVARS + WRITE (NDSN,10) TRIM(MSG),'TIMEREF = ', NML_FIELD%TIMEREF + WRITE (NDSN,14) TRIM(MSG),'NOVAL = ', NML_FIELD%NOVAL + WRITE (NDSN,13) TRIM(MSG),'MAPSTA = ', NML_FIELD%MAPSTA 10 FORMAT (A,2X,A,A) @@ -632,187 +632,187 @@ SUBROUTINE REPORT_FIELD_NML (NML_FIELD) END SUBROUTINE REPORT_FIELD_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_FILE_NML (NML_FILE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_FILE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_FILE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_FILE_T), INTENT(IN) :: NML_FILE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_FILE_NML') + CALL STRACE (IENT, 'REPORT_FILE_NML') #endif - WRITE (MSG,'(A)') 'FILE % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'PREFIX = ', TRIM(NML_FILE%PREFIX) - WRITE (NDSN,11) TRIM(MSG),'NETCDF = ', NML_FILE%NETCDF - WRITE (NDSN,11) TRIM(MSG),'IX0 = ', NML_FILE%IX0 - WRITE (NDSN,11) TRIM(MSG),'IXN = ', NML_FILE%IXN - WRITE (NDSN,11) TRIM(MSG),'IY0 = ', NML_FILE%IY0 - WRITE (NDSN,11) TRIM(MSG),'IYN = ', NML_FILE%IYN + WRITE (MSG,'(A)') 'FILE % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'PREFIX = ', TRIM(NML_FILE%PREFIX) + WRITE (NDSN,11) TRIM(MSG),'NETCDF = ', NML_FILE%NETCDF + WRITE (NDSN,11) TRIM(MSG),'IX0 = ', NML_FILE%IX0 + WRITE (NDSN,11) TRIM(MSG),'IXN = ', NML_FILE%IXN + WRITE (NDSN,11) TRIM(MSG),'IY0 = ', NML_FILE%IY0 + WRITE (NDSN,11) TRIM(MSG),'IYN = ', NML_FILE%IYN 10 FORMAT (A,2X,A,A) 11 FORMAT (A,2X,A,I12) END SUBROUTINE REPORT_FILE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_SMC_NML (NML_SMC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 19-Sep-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_SMC Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNF Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 19-Sep-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_SMC Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNF Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_SMC_T), INTENT(IN) :: NML_SMC #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_SMC_NML') + CALL STRACE (IENT, 'REPORT_SMC_NML') #endif - WRITE (MSG,'(A)') 'SMC % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,11) TRIM(MSG),'TYPE = ', NML_SMC%TYPE - WRITE (NDSN,14) TRIM(MSG),'SXO = ', NML_SMC%SXO - WRITE (NDSN,14) TRIM(MSG),'SYO = ', NML_SMC%SYO - WRITE (NDSN,14) TRIM(MSG),'EXO = ', NML_SMC%EXO - WRITE (NDSN,14) TRIM(MSG),'EYO = ', NML_SMC%EYO - WRITE (NDSN,11) TRIM(MSG),'CELFAC = ', NML_SMC%CELFAC + WRITE (MSG,'(A)') 'SMC % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,11) TRIM(MSG),'TYPE = ', NML_SMC%TYPE + WRITE (NDSN,14) TRIM(MSG),'SXO = ', NML_SMC%SXO + WRITE (NDSN,14) TRIM(MSG),'SYO = ', NML_SMC%SYO + WRITE (NDSN,14) TRIM(MSG),'EXO = ', NML_SMC%EXO + WRITE (NDSN,14) TRIM(MSG),'EYO = ', NML_SMC%EYO + WRITE (NDSN,11) TRIM(MSG),'CELFAC = ', NML_SMC%CELFAC 11 FORMAT (A,2X,A,I12) 14 FORMAT (A,2X,A,F8.2) END SUBROUTINE REPORT_SMC_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -820,54 +820,3 @@ END SUBROUTINE REPORT_SMC_NML END MODULE W3NMLOUNFMD !/ ------------------------------------------------------------------- / - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/model/src/w3nmlounpmd.F90 b/model/src/w3nmlounpmd.F90 index fe3417fcc..56c11ca05 100644 --- a/model/src/w3nmlounpmd.F90 +++ b/model/src/w3nmlounpmd.F90 @@ -1,22 +1,22 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3NMLOUNPMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutines. -!/ -! 1. Purpose : -! -! Manages namelists from configuration file ww3_ounp.nml for ww3_ounp program -! +#include "w3macros.h" !/ ------------------------------------------------------------------- / +MODULE W3NMLOUNPMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutines. + !/ + ! 1. Purpose : + ! + ! Manages namelists from configuration file ww3_ounp.nml for ww3_ounp program + ! + !/ ------------------------------------------------------------------- / ! module defaults IMPLICIT NONE @@ -78,76 +78,76 @@ MODULE W3NMLOUNPMD - CONTAINS -!/ ------------------------------------------------------------------- / +CONTAINS + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLOUNP (NDSI, INFILE, NML_POINT, NML_FILE, & - NML_SPECTRA, NML_PARAM, NML_SOURCE, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! -! 1. Purpose : -! -! Reads all the namelist to define the output point -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! INFILE Char. -! NML_POINT type. -! NML_FILE type. -! NML_SPECTRA type. -! NML_PARAM type. -! NML_SOURCE type. -! IERR Int. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_POINT_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! WW3_OUNP Prog. N/A Postprocess output points. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + NML_SPECTRA, NML_PARAM, NML_SOURCE, IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! + ! 1. Purpose : + ! + ! Reads all the namelist to define the output point + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! INFILE Char. + ! NML_POINT type. + ! NML_FILE type. + ! NML_SPECTRA type. + ! NML_PARAM type. + ! NML_SOURCE type. + ! IERR Int. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_POINT_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! WW3_OUNP Prog. N/A Postprocess output points. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -161,18 +161,18 @@ SUBROUTINE W3NMLOUNP (NDSI, INFILE, NML_POINT, NML_FILE, & TYPE(NML_SOURCE_T), INTENT(INOUT) :: NML_SOURCE INTEGER, INTENT(OUT) :: IERR #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'W3NMLOUNP') + CALL STRACE (IENT, 'W3NMLOUNP') #endif ! open namelist log file NDSN = 3 OPEN (NDSN, file=TRIM(INFILE)//'.log', form='formatted', iostat=IERR) - IF (IERR.NE.0) THEN + IF (IERR.NE.0) THEN WRITE (NDSE,'(A)') 'ERROR: open full nml file '//TRIM(INFILE)//'.log failed' RETURN END IF @@ -211,74 +211,74 @@ SUBROUTINE W3NMLOUNP (NDSI, INFILE, NML_POINT, NML_FILE, & END SUBROUTINE W3NMLOUNP -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_POINT_NML (NDSI, NML_POINT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_POINT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNP Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_POINT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNP Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -291,12 +291,12 @@ SUBROUTINE READ_POINT_NML (NDSI, NML_POINT) TYPE(NML_POINT_T) :: POINT NAMELIST /POINT_NML/ POINT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_POINT_NML') + CALL STRACE (IENT, 'READ_POINT_NML') #endif ! set default values for point structure @@ -315,8 +315,8 @@ SUBROUTINE READ_POINT_NML (NDSI, NML_POINT) READ (NDSI, nml=POINT_NML, iostat=IERR, iomsg=MSG) IF (IERR.NE.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_POINT_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_POINT_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (1) END IF @@ -325,71 +325,71 @@ SUBROUTINE READ_POINT_NML (NDSI, NML_POINT) END SUBROUTINE READ_POINT_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_FILE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNP Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_FILE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNP Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -407,7 +407,7 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_FILE_NML') + CALL STRACE (IENT, 'READ_FILE_NML') #endif ! set default values for file structure @@ -420,8 +420,8 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) READ (NDSI, nml=FILE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_FILE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_FILE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (2) END IF @@ -430,71 +430,71 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) END SUBROUTINE READ_FILE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_SPECTRA_NML (NDSI, NML_SPECTRA) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_SPECTRA Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNP Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_SPECTRA Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNP Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -512,7 +512,7 @@ SUBROUTINE READ_SPECTRA_NML (NDSI, NML_SPECTRA) IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_SPECTRA_NML') + CALL STRACE (IENT, 'READ_SPECTRA_NML') #endif ! set default values for spectra structure @@ -527,8 +527,8 @@ SUBROUTINE READ_SPECTRA_NML (NDSI, NML_SPECTRA) READ (NDSI, nml=SPECTRA_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_SPECTRA_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_SPECTRA_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (3) END IF @@ -537,70 +537,70 @@ SUBROUTINE READ_SPECTRA_NML (NDSI, NML_SPECTRA) END SUBROUTINE READ_SPECTRA_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_PARAM_NML (NDSI, NML_PARAM) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_PARAM Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNP Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_PARAM Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNP Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -618,7 +618,7 @@ SUBROUTINE READ_PARAM_NML (NDSI, NML_PARAM) IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_PARAM_NML') + CALL STRACE (IENT, 'READ_PARAM_NML') #endif ! set default values for param structure @@ -629,8 +629,8 @@ SUBROUTINE READ_PARAM_NML (NDSI, NML_PARAM) READ (NDSI, nml=PARAM_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_PARAM_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_PARAM_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (4) END IF @@ -639,69 +639,69 @@ SUBROUTINE READ_PARAM_NML (NDSI, NML_PARAM) END SUBROUTINE READ_PARAM_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_SOURCE_NML (NDSI, NML_SOURCE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_SOURCE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNP Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_SOURCE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNP Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -719,7 +719,7 @@ SUBROUTINE READ_SOURCE_NML (NDSI, NML_SOURCE) IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_SOURCE_NML') + CALL STRACE (IENT, 'READ_SOURCE_NML') #endif ! set default values for source structure @@ -740,8 +740,8 @@ SUBROUTINE READ_SOURCE_NML (NDSI, NML_SOURCE) READ (NDSI, nml=SOURCE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_SOURCE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_SOURCE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (5) END IF @@ -750,7 +750,7 @@ SUBROUTINE READ_SOURCE_NML (NDSI, NML_SOURCE) END SUBROUTINE READ_SOURCE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -758,89 +758,89 @@ END SUBROUTINE READ_SOURCE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_POINT_NML (NML_POINT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_POINT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNP Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_POINT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNP Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_POINT_T), INTENT(IN) :: NML_POINT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_POINT_NML') + CALL STRACE (IENT, 'REPORT_POINT_NML') #endif - WRITE (MSG,'(A)') 'POINT % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'TIMESTART = ', TRIM(NML_POINT%TIMESTART) - WRITE (NDSN,10) TRIM(MSG),'TIMESTRIDE = ', TRIM(NML_POINT%TIMESTRIDE) - WRITE (NDSN,10) TRIM(MSG),'TIMECOUNT = ', TRIM(NML_POINT%TIMECOUNT) + WRITE (MSG,'(A)') 'POINT % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'TIMESTART = ', TRIM(NML_POINT%TIMESTART) + WRITE (NDSN,10) TRIM(MSG),'TIMESTRIDE = ', TRIM(NML_POINT%TIMESTRIDE) + WRITE (NDSN,10) TRIM(MSG),'TIMECOUNT = ', TRIM(NML_POINT%TIMECOUNT) - WRITE (NDSN,11) TRIM(MSG),'TIMESPLIT = ', NML_POINT%TIMESPLIT - WRITE (NDSN,10) TRIM(MSG),'LIST = ', TRIM(NML_POINT%LIST) - WRITE (NDSN,13) TRIM(MSG),'SAMEFILE = ', NML_POINT%SAMEFILE - WRITE (NDSN,11) TRIM(MSG),'BUFFER = ', NML_POINT%BUFFER - WRITE (NDSN,11) TRIM(MSG),'TYPE = ', NML_POINT%TYPE - WRITE (NDSN,13) TRIM(MSG),'DIMORDER = ', NML_POINT%DIMORDER + WRITE (NDSN,11) TRIM(MSG),'TIMESPLIT = ', NML_POINT%TIMESPLIT + WRITE (NDSN,10) TRIM(MSG),'LIST = ', TRIM(NML_POINT%LIST) + WRITE (NDSN,13) TRIM(MSG),'SAMEFILE = ', NML_POINT%SAMEFILE + WRITE (NDSN,11) TRIM(MSG),'BUFFER = ', NML_POINT%BUFFER + WRITE (NDSN,11) TRIM(MSG),'TYPE = ', NML_POINT%TYPE + WRITE (NDSN,13) TRIM(MSG),'DIMORDER = ', NML_POINT%DIMORDER 10 FORMAT (A,2X,A,A) 11 FORMAT (A,2X,A,I8) @@ -848,88 +848,88 @@ SUBROUTINE REPORT_POINT_NML (NML_POINT) END SUBROUTINE REPORT_POINT_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_FILE_NML (NML_FILE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_FILE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNP Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_FILE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNP Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_FILE_T), INTENT(IN) :: NML_FILE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_FILE_NML') + CALL STRACE (IENT, 'REPORT_FILE_NML') #endif - WRITE (MSG,'(A)') 'FILE % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'PREFIX = ', TRIM(NML_FILE%PREFIX) - WRITE (NDSN,11) TRIM(MSG),'NETCDF = ', NML_FILE%NETCDF + WRITE (MSG,'(A)') 'FILE % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'PREFIX = ', TRIM(NML_FILE%PREFIX) + WRITE (NDSN,11) TRIM(MSG),'NETCDF = ', NML_FILE%NETCDF 10 FORMAT (A,2X,A,A) @@ -937,86 +937,86 @@ SUBROUTINE REPORT_FILE_NML (NML_FILE) END SUBROUTINE REPORT_FILE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_SPECTRA_NML (NML_SPECTRA) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_SPECTRA Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNP Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_SPECTRA Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNP Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_SPECTRA_T), INTENT(IN) :: NML_SPECTRA #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_SPECTRA_NML') + CALL STRACE (IENT, 'REPORT_SPECTRA_NML') #endif - WRITE (MSG,'(A)') 'SPECTRA % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,11) TRIM(MSG),'OUTPUT = ', NML_SPECTRA%OUTPUT - WRITE (NDSN,14) TRIM(MSG),'SCALE_FAC = ', NML_SPECTRA%SCALE_FAC - WRITE (NDSN,14) TRIM(MSG),'OUTPUT_FAC = ', NML_SPECTRA%OUTPUT_FAC - WRITE (NDSN,11) TRIM(MSG),'TYPE = ', NML_SPECTRA%TYPE + WRITE (MSG,'(A)') 'SPECTRA % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,11) TRIM(MSG),'OUTPUT = ', NML_SPECTRA%OUTPUT + WRITE (NDSN,14) TRIM(MSG),'SCALE_FAC = ', NML_SPECTRA%SCALE_FAC + WRITE (NDSN,14) TRIM(MSG),'OUTPUT_FAC = ', NML_SPECTRA%OUTPUT_FAC + WRITE (NDSN,11) TRIM(MSG),'TYPE = ', NML_SPECTRA%TYPE 11 FORMAT (A,2X,A,I8) @@ -1024,173 +1024,173 @@ SUBROUTINE REPORT_SPECTRA_NML (NML_SPECTRA) END SUBROUTINE REPORT_SPECTRA_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_PARAM_NML (NML_PARAM) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_PARAM Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNP Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_PARAM Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNP Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_PARAM_T), INTENT(IN) :: NML_PARAM #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_PARAM_NML') + CALL STRACE (IENT, 'REPORT_PARAM_NML') #endif - WRITE (MSG,'(A)') 'PARAM % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,11) TRIM(MSG),'OUTPUT = ', NML_PARAM%OUTPUT + WRITE (MSG,'(A)') 'PARAM % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,11) TRIM(MSG),'OUTPUT = ', NML_PARAM%OUTPUT 11 FORMAT (A,2X,A,I8) END SUBROUTINE REPORT_PARAM_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_SOURCE_NML (NML_SOURCE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_SOURCE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLOUNP Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_SOURCE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLOUNP Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_SOURCE_T), INTENT(IN) :: NML_SOURCE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_SOURCE_NML') + CALL STRACE (IENT, 'REPORT_SOURCE_NML') #endif - WRITE (MSG,'(A)') 'SOURCE % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,11) TRIM(MSG),'OUTPUT = ', NML_SOURCE%OUTPUT - WRITE (NDSN,14) TRIM(MSG),'SCALE_FAC = ', NML_SOURCE%SCALE_FAC - WRITE (NDSN,14) TRIM(MSG),'OUTPUT_FAC = ', NML_SOURCE%OUTPUT_FAC - WRITE (NDSN,11) TRIM(MSG),'TABLE_FAC = ', NML_SOURCE%TABLE_FAC - WRITE (NDSN,13) TRIM(MSG),'SPECTRUM = ', NML_SOURCE%SPECTRUM - WRITE (NDSN,13) TRIM(MSG),'INPUT = ', NML_SOURCE%INPUT - WRITE (NDSN,13) TRIM(MSG),'INTERACTIONS = ', NML_SOURCE%INTERACTIONS - WRITE (NDSN,13) TRIM(MSG),'DISSIPATION = ', NML_SOURCE%DISSIPATION - WRITE (NDSN,13) TRIM(MSG),'ICE = ', NML_SOURCE%ICE - WRITE (NDSN,13) TRIM(MSG),'TOTAL = ', NML_SOURCE%TOTAL + WRITE (MSG,'(A)') 'SOURCE % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,11) TRIM(MSG),'OUTPUT = ', NML_SOURCE%OUTPUT + WRITE (NDSN,14) TRIM(MSG),'SCALE_FAC = ', NML_SOURCE%SCALE_FAC + WRITE (NDSN,14) TRIM(MSG),'OUTPUT_FAC = ', NML_SOURCE%OUTPUT_FAC + WRITE (NDSN,11) TRIM(MSG),'TABLE_FAC = ', NML_SOURCE%TABLE_FAC + WRITE (NDSN,13) TRIM(MSG),'SPECTRUM = ', NML_SOURCE%SPECTRUM + WRITE (NDSN,13) TRIM(MSG),'INPUT = ', NML_SOURCE%INPUT + WRITE (NDSN,13) TRIM(MSG),'INTERACTIONS = ', NML_SOURCE%INTERACTIONS + WRITE (NDSN,13) TRIM(MSG),'DISSIPATION = ', NML_SOURCE%DISSIPATION + WRITE (NDSN,13) TRIM(MSG),'ICE = ', NML_SOURCE%ICE + WRITE (NDSN,13) TRIM(MSG),'TOTAL = ', NML_SOURCE%TOTAL @@ -1200,61 +1200,10 @@ SUBROUTINE REPORT_SOURCE_NML (NML_SOURCE) END SUBROUTINE REPORT_SOURCE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / END MODULE W3NMLOUNPMD !/ ------------------------------------------------------------------- / - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/model/src/w3nmlprncmd.F90 b/model/src/w3nmlprncmd.F90 index e9b447051..06fa39576 100644 --- a/model/src/w3nmlprncmd.F90 +++ b/model/src/w3nmlprncmd.F90 @@ -1,22 +1,22 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3NMLPRNCMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutines. -!/ -! 1. Purpose : -! -! Manages namelists from configuration file ww3_prnc.nml for ww3_prnc program -! +#include "w3macros.h" !/ ------------------------------------------------------------------- / +MODULE W3NMLPRNCMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutines. + !/ + ! 1. Purpose : + ! + ! Manages namelists from configuration file ww3_prnc.nml for ww3_prnc program + ! + !/ ------------------------------------------------------------------- / ! module defaults IMPLICIT NONE @@ -76,72 +76,72 @@ MODULE W3NMLPRNCMD - CONTAINS -!/ ------------------------------------------------------------------- / +CONTAINS + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLPRNC (NDSI, INFILE, NML_FORCING, NML_FILE, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 04-Jan-2018 | -!/ +-----------------------------------+ -!/ -! -! 1. Purpose : -! -! Reads all the namelist to define the forcing field -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! INFILE Char. -! NML_FORCING type. -! NML_FILE type. -! IERR Int. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_FORCING_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! WW3_PRNC Prog. N/A Preprocess forcing fields. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 04-Jan-2018 | + !/ +-----------------------------------+ + !/ + ! + ! 1. Purpose : + ! + ! Reads all the namelist to define the forcing field + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! INFILE Char. + ! NML_FORCING type. + ! NML_FILE type. + ! IERR Int. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_FORCING_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! WW3_PRNC Prog. N/A Preprocess forcing fields. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -152,18 +152,18 @@ SUBROUTINE W3NMLPRNC (NDSI, INFILE, NML_FORCING, NML_FILE, IERR) TYPE(NML_FILE_T), INTENT(INOUT) :: NML_FILE INTEGER, INTENT(OUT) :: IERR #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'W3NMLPRNC') + CALL STRACE (IENT, 'W3NMLPRNC') #endif ! open namelist log file NDSN = 3 OPEN (NDSN, file=TRIM(INFILE)//'.log', form='formatted', iostat=IERR) - IF (IERR.NE.0) THEN + IF (IERR.NE.0) THEN WRITE (NDSE,'(A)') 'ERROR: open full nml file '//TRIM(INFILE)//'.log failed' RETURN END IF @@ -190,74 +190,74 @@ SUBROUTINE W3NMLPRNC (NDSI, INFILE, NML_FORCING, NML_FILE, IERR) END SUBROUTINE W3NMLPRNC -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_FORCING_NML (NDSI, NML_FORCING) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_FORCING Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLPRNC Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_FORCING Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLPRNC Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -270,18 +270,18 @@ SUBROUTINE READ_FORCING_NML (NDSI, NML_FORCING) TYPE(NML_FORCING_T) :: FORCING NAMELIST /FORCING_NML/ FORCING #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_FORCING_NML') + CALL STRACE (IENT, 'READ_FORCING_NML') #endif ! set default values for forcing structure FORCING%TIMESTART = '19000101 000000' FORCING%TIMESTOP = '29001231 000000' -! + ! FORCING%FIELD%ICE_PARAM1 = .FALSE. FORCING%FIELD%ICE_PARAM2 = .FALSE. FORCING%FIELD%ICE_PARAM3 = .FALSE. @@ -299,10 +299,10 @@ SUBROUTINE READ_FORCING_NML (NDSI, NML_FORCING) FORCING%FIELD%ICE_CONC = .FALSE. FORCING%FIELD%ICE_BERG = .FALSE. FORCING%FIELD%DATA_ASSIM = .FALSE. -! + ! FORCING%GRID%LATLON = .FALSE. FORCING%GRID%ASIS = .FALSE. -! + ! FORCING%TIDAL = 'unset' @@ -311,8 +311,8 @@ SUBROUTINE READ_FORCING_NML (NDSI, NML_FORCING) READ (NDSI, nml=FORCING_NML, iostat=IERR, iomsg=MSG) IF (IERR.NE.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_FORCING_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_FORCING_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (1) END IF @@ -332,71 +332,71 @@ SUBROUTINE READ_FORCING_NML (NDSI, NML_FORCING) END SUBROUTINE READ_FORCING_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 04-Jan-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_FILE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLPRNC Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 04-Jan-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_FILE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLPRNC Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -409,12 +409,12 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) TYPE(NML_FILE_T) :: FILE NAMELIST /FILE_NML/ FILE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_FILE_NML') + CALL STRACE (IENT, 'READ_FILE_NML') #endif ! set default values for file structure @@ -431,8 +431,8 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) READ (NDSI, nml=FILE_NML, iostat=IERR, iomsg=MSG) IF (IERR.NE.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_FILE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_FILE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (4) END IF @@ -441,7 +441,7 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) END SUBROUTINE READ_FILE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -449,104 +449,104 @@ END SUBROUTINE READ_FILE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_FORCING_NML (NML_FORCING) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_FORCING Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLPRNC Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_FORCING Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLPRNC Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_FORCING_T), INTENT(IN) :: NML_FORCING #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_FORCING_NML') + CALL STRACE (IENT, 'REPORT_FORCING_NML') #endif - WRITE (MSG,'(A)') 'FORCING % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'TIMESTART = ', TRIM(NML_FORCING%TIMESTART) - WRITE (NDSN,10) TRIM(MSG),'TIMESTOP = ', TRIM(NML_FORCING%TIMESTOP) - - WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_PARAM1 = ', NML_FORCING%FIELD%ICE_PARAM1 - WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_PARAM2 = ', NML_FORCING%FIELD%ICE_PARAM2 - WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_PARAM3 = ', NML_FORCING%FIELD%ICE_PARAM3 - WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_PARAM4 = ', NML_FORCING%FIELD%ICE_PARAM4 - WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_PARAM5 = ', NML_FORCING%FIELD%ICE_PARAM5 - WRITE (NDSN,13) TRIM(MSG),'FIELD % MUD_DENSITY = ', NML_FORCING%FIELD%MUD_DENSITY - WRITE (NDSN,13) TRIM(MSG),'FIELD % MUD_THICKNESS = ', NML_FORCING%FIELD%MUD_THICKNESS - WRITE (NDSN,13) TRIM(MSG),'FIELD % MUD_VISCOSITY = ', NML_FORCING%FIELD%MUD_VISCOSITY - WRITE (NDSN,13) TRIM(MSG),'FIELD % WATER_LEVELS = ', NML_FORCING%FIELD%WATER_LEVELS - WRITE (NDSN,13) TRIM(MSG),'FIELD % CURRENTS = ', NML_FORCING%FIELD%CURRENTS - WRITE (NDSN,13) TRIM(MSG),'FIELD % WINDS = ', NML_FORCING%FIELD%WINDS - WRITE (NDSN,13) TRIM(MSG),'FIELD % WINDS_AST = ', NML_FORCING%FIELD%WINDS_AST - WRITE (NDSN,13) TRIM(MSG),'FIELD % ATM_MOMENTUM = ', NML_FORCING%FIELD%ATM_MOMENTUM - WRITE (NDSN,13) TRIM(MSG),'FIELD % AIR_DENSITY = ', NML_FORCING%FIELD%AIR_DENSITY - WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_CONC = ', NML_FORCING%FIELD%ICE_CONC - WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_BERG = ', NML_FORCING%FIELD%ICE_BERG - WRITE (NDSN,13) TRIM(MSG),'FIELD % DATA_ASSIM = ', NML_FORCING%FIELD%DATA_ASSIM - - WRITE (NDSN,13) TRIM(MSG),'GRID % ASIS = ', NML_FORCING%GRID%ASIS - WRITE (NDSN,13) TRIM(MSG),'GRID % LATLON = ', NML_FORCING%GRID%LATLON - - WRITE (NDSN,10) TRIM(MSG),'TIDAL = ', TRIM(NML_FORCING%TIDAL) + WRITE (MSG,'(A)') 'FORCING % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'TIMESTART = ', TRIM(NML_FORCING%TIMESTART) + WRITE (NDSN,10) TRIM(MSG),'TIMESTOP = ', TRIM(NML_FORCING%TIMESTOP) + + WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_PARAM1 = ', NML_FORCING%FIELD%ICE_PARAM1 + WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_PARAM2 = ', NML_FORCING%FIELD%ICE_PARAM2 + WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_PARAM3 = ', NML_FORCING%FIELD%ICE_PARAM3 + WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_PARAM4 = ', NML_FORCING%FIELD%ICE_PARAM4 + WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_PARAM5 = ', NML_FORCING%FIELD%ICE_PARAM5 + WRITE (NDSN,13) TRIM(MSG),'FIELD % MUD_DENSITY = ', NML_FORCING%FIELD%MUD_DENSITY + WRITE (NDSN,13) TRIM(MSG),'FIELD % MUD_THICKNESS = ', NML_FORCING%FIELD%MUD_THICKNESS + WRITE (NDSN,13) TRIM(MSG),'FIELD % MUD_VISCOSITY = ', NML_FORCING%FIELD%MUD_VISCOSITY + WRITE (NDSN,13) TRIM(MSG),'FIELD % WATER_LEVELS = ', NML_FORCING%FIELD%WATER_LEVELS + WRITE (NDSN,13) TRIM(MSG),'FIELD % CURRENTS = ', NML_FORCING%FIELD%CURRENTS + WRITE (NDSN,13) TRIM(MSG),'FIELD % WINDS = ', NML_FORCING%FIELD%WINDS + WRITE (NDSN,13) TRIM(MSG),'FIELD % WINDS_AST = ', NML_FORCING%FIELD%WINDS_AST + WRITE (NDSN,13) TRIM(MSG),'FIELD % ATM_MOMENTUM = ', NML_FORCING%FIELD%ATM_MOMENTUM + WRITE (NDSN,13) TRIM(MSG),'FIELD % AIR_DENSITY = ', NML_FORCING%FIELD%AIR_DENSITY + WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_CONC = ', NML_FORCING%FIELD%ICE_CONC + WRITE (NDSN,13) TRIM(MSG),'FIELD % ICE_BERG = ', NML_FORCING%FIELD%ICE_BERG + WRITE (NDSN,13) TRIM(MSG),'FIELD % DATA_ASSIM = ', NML_FORCING%FIELD%DATA_ASSIM + + WRITE (NDSN,13) TRIM(MSG),'GRID % ASIS = ', NML_FORCING%GRID%ASIS + WRITE (NDSN,13) TRIM(MSG),'GRID % LATLON = ', NML_FORCING%GRID%LATLON + + WRITE (NDSN,10) TRIM(MSG),'TIDAL = ', TRIM(NML_FORCING%TIDAL) 10 FORMAT (A,2X,A,A) @@ -554,100 +554,100 @@ SUBROUTINE REPORT_FORCING_NML (NML_FORCING) END SUBROUTINE REPORT_FORCING_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_FILE_NML (NML_FILE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 04-Jan-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_FILE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLPRNC Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 04-Jan-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_FILE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLPRNC Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_FILE_T), INTENT(IN) :: NML_FILE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_FILE_NML') + CALL STRACE (IENT, 'REPORT_FILE_NML') #endif - WRITE (MSG,'(A)') 'FILE % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_FILE%FILENAME) - WRITE (NDSN,10) TRIM(MSG),'LONGITUDE = ', TRIM(NML_FILE%LONGITUDE) - WRITE (NDSN,10) TRIM(MSG),'LATITUDE = ', TRIM(NML_FILE%LATITUDE) - WRITE (NDSN,10) TRIM(MSG),'VAR(1) = ', TRIM(NML_FILE%VAR(1)) - WRITE (NDSN,10) TRIM(MSG),'VAR(2) = ', TRIM(NML_FILE%VAR(2)) - WRITE (NDSN,10) TRIM(MSG),'VAR(3) = ', TRIM(NML_FILE%VAR(3)) - WRITE (NDSN,10) TRIM(MSG),'TIMESHIFT = ', TRIM(NML_FILE%TIMESHIFT) + WRITE (MSG,'(A)') 'FILE % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'FILENAME = ', TRIM(NML_FILE%FILENAME) + WRITE (NDSN,10) TRIM(MSG),'LONGITUDE = ', TRIM(NML_FILE%LONGITUDE) + WRITE (NDSN,10) TRIM(MSG),'LATITUDE = ', TRIM(NML_FILE%LATITUDE) + WRITE (NDSN,10) TRIM(MSG),'VAR(1) = ', TRIM(NML_FILE%VAR(1)) + WRITE (NDSN,10) TRIM(MSG),'VAR(2) = ', TRIM(NML_FILE%VAR(2)) + WRITE (NDSN,10) TRIM(MSG),'VAR(3) = ', TRIM(NML_FILE%VAR(3)) + WRITE (NDSN,10) TRIM(MSG),'TIMESHIFT = ', TRIM(NML_FILE%TIMESHIFT) 10 FORMAT (A,2X,A,A) END SUBROUTINE REPORT_FILE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -656,21 +656,3 @@ END SUBROUTINE REPORT_FILE_NML END MODULE W3NMLPRNCMD !/ ------------------------------------------------------------------- / - - - - - - - - - - - - - - - - - - diff --git a/model/src/w3nmlshelmd.F90 b/model/src/w3nmlshelmd.F90 index d55277605..89676ab49 100644 --- a/model/src/w3nmlshelmd.F90 +++ b/model/src/w3nmlshelmd.F90 @@ -1,22 +1,22 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3NMLSHELMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutines. -!/ -! 1. Purpose : -! -! Manages namelists from configuration file ww3_shel.nml for ww3_shel program -! -!/ ------------------------------------------------------------------- / +MODULE W3NMLSHELMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutines. + !/ + ! 1. Purpose : + ! + ! Manages namelists from configuration file ww3_shel.nml for ww3_shel program + ! + !/ ------------------------------------------------------------------- / ! module defaults IMPLICIT NONE @@ -50,13 +50,13 @@ MODULE W3NMLSHELMD CHARACTER(13) :: MUD_THICKNESS CHARACTER(13) :: MUD_VISCOSITY END TYPE NML_FORCING_T -! + ! TYPE NML_ASSIM_T CHARACTER(13) :: MEAN CHARACTER(13) :: SPEC1D CHARACTER(13) :: SPEC2D END TYPE NML_ASSIM_T -! + ! TYPE NML_INPUT_T TYPE(NML_FORCING_T) :: FORCING TYPE(NML_ASSIM_T) :: ASSIM @@ -66,15 +66,15 @@ MODULE W3NMLSHELMD TYPE NML_FIELD_T CHARACTER(1024) :: LIST END TYPE NML_FIELD_T -! + ! TYPE NML_POINT_T CHARACTER(64) :: FILE END TYPE NML_POINT_T -! + ! TYPE NML_TRACK_T LOGICAL :: FORMAT END TYPE NML_TRACK_T -! + ! TYPE NML_PARTITION_T INTEGER :: X0 INTEGER :: XN @@ -84,7 +84,7 @@ MODULE W3NMLSHELMD INTEGER :: NY LOGICAL :: FORMAT END TYPE NML_PARTITION_T -! + ! #ifdef W3_COU TYPE NML_COUPLING_T CHARACTER(1024) :: SENT @@ -92,11 +92,11 @@ MODULE W3NMLSHELMD LOGICAL :: COUPLET0 END TYPE NML_COUPLING_T #endif -! + ! TYPE NML_RESTART_T CHARACTER(1024) :: EXTRA END TYPE NML_RESTART_T -! + ! TYPE NML_OUTPUT_TYPE_T TYPE(NML_POINT_T) :: POINT TYPE(NML_FIELD_T) :: FIELD @@ -117,7 +117,7 @@ MODULE W3NMLSHELMD CHARACTER(15) :: STOP CHARACTER(15) :: OUTFFILE END TYPE NML_OUTPUT_TIME_T -! + ! TYPE NML_OUTPUT_DATE_T TYPE(NML_OUTPUT_TIME_T) :: FIELD TYPE(NML_OUTPUT_TIME_T) :: POINT @@ -149,7 +149,7 @@ MODULE W3NMLSHELMD INTEGER :: N_MOV INTEGER :: N_TOT END TYPE NML_HOMOG_COUNT_T -! + ! TYPE NML_HOMOG_INPUT_T CHARACTER(15) :: NAME CHARACTER(15) :: DATE @@ -165,94 +165,94 @@ MODULE W3NMLSHELMD - CONTAINS +CONTAINS -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLSHEL (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & - NML_INPUT, NML_OUTPUT_TYPE, NML_OUTPUT_DATE, & - NML_HOMOG_COUNT, NML_HOMOG_INPUT, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 18-Apr-2018 | -!/ +-----------------------------------+ -!/ - -! 1. Purpose : -! -! Reads all the namelist to define the single grid -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MPI_COMM Int. Public Communicator used in the wave MODEL. -! NDSI -! INFILE -! NML_DOMAIN -! NML_INPUT -! NML_OUTPUT_TYPE -! NML_OUTPUT_DATE -! NML_HOMOG_COUNT -! NML_HOMOG_INPUT -! IERR -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_DOMAIN_NML -! REPORT_DOMAIN_NML -! READ_INPUT_NML -! REPORT_INPUT_NML -! READ_OUTPUT_TYPE_NML -! REPORT_OUTPUT_TYPE_NML -! READ_OUTPUT_DATE_NML -! REPORT_OUTPUT_DATE_NML -! READ_HOMOGENEOUS_NML -! REPORT_HOMOGENEOUS_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_SHEL Prog. N/A Single grid main program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + NML_INPUT, NML_OUTPUT_TYPE, NML_OUTPUT_DATE, & + NML_HOMOG_COUNT, NML_HOMOG_INPUT, IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 18-Apr-2018 | + !/ +-----------------------------------+ + !/ + + ! 1. Purpose : + ! + ! Reads all the namelist to define the single grid + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MPI_COMM Int. Public Communicator used in the wave MODEL. + ! NDSI + ! INFILE + ! NML_DOMAIN + ! NML_INPUT + ! NML_OUTPUT_TYPE + ! NML_OUTPUT_DATE + ! NML_HOMOG_COUNT + ! NML_HOMOG_INPUT + ! IERR + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_DOMAIN_NML + ! REPORT_DOMAIN_NML + ! READ_INPUT_NML + ! REPORT_INPUT_NML + ! READ_OUTPUT_TYPE_NML + ! REPORT_OUTPUT_TYPE_NML + ! READ_OUTPUT_DATE_NML + ! REPORT_OUTPUT_DATE_NML + ! READ_HOMOGENEOUS_NML + ! REPORT_HOMOGENEOUS_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_SHEL Prog. N/A Single grid main program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE, IMPROC, NMPLOG #ifdef W3_MPI - USE WMMDATMD, ONLY: MPI_COMM_MWAVE + USE WMMDATMD, ONLY: MPI_COMM_MWAVE #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -269,22 +269,22 @@ SUBROUTINE W3NMLSHEL (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & ! locals #ifdef W3_MPI - INTEGER :: IERR_MPI + INTEGER :: IERR_MPI #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - logical :: is_open + logical :: is_open IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'W3NMLSHEL') + CALL STRACE (IENT, 'W3NMLSHEL') #endif #ifdef W3_MPI - MPI_COMM_MWAVE = MPI_COMM - CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) - IMPROC = IMPROC + 1 + MPI_COMM_MWAVE = MPI_COMM + CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 #endif ! open namelist log file @@ -298,12 +298,12 @@ SUBROUTINE W3NMLSHEL (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & inquire (unit=ndsi, opened=is_open) if (.not. is_open) then - ! open input file - open (NDSI, FILE=TRIM(INFILE), form='formatted', status='old', iostat=IERR) - IF (IERR.NE.0) THEN - WRITE (MDSE,'(A)') 'ERROR: open input file '//TRIM(INFILE)//' failed' - RETURN - END IF + ! open input file + open (NDSI, FILE=TRIM(INFILE), form='formatted', status='old', iostat=IERR) + IF (IERR.NE.0) THEN + WRITE (MDSE,'(A)') 'ERROR: open input file '//TRIM(INFILE)//' failed' + RETURN + END IF end if ! read domain namelist @@ -332,75 +332,75 @@ SUBROUTINE W3NMLSHEL (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & END SUBROUTINE W3NMLSHEL -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 18-Apr-2018 | -!/ +-----------------------------------+ -!/ - -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_DOMAIN Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLSHEL Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 18-Apr-2018 | + !/ +-----------------------------------+ + !/ + + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_DOMAIN Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLSHEL Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -413,12 +413,12 @@ SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) TYPE(NML_DOMAIN_T) :: DOMAIN NAMELIST /DOMAIN_NML/ DOMAIN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_DOMAIN_NML') + CALL STRACE (IENT, 'READ_DOMAIN_NML') #endif ! set default values for domain structure @@ -431,8 +431,8 @@ SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) READ (NDSI, nml=DOMAIN_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_DOMAIN_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_DOMAIN_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (1) END IF @@ -447,78 +447,78 @@ SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) END SUBROUTINE READ_DOMAIN_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_INPUT_NML (NDSI, NML_INPUT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_INPUT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLSHEL Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_INPUT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLSHEL Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -531,12 +531,12 @@ SUBROUTINE READ_INPUT_NML (NDSI, NML_INPUT) TYPE(NML_INPUT_T) :: INPUT NAMELIST /INPUT_NML/ INPUT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_INPUT_NML') + CALL STRACE (IENT, 'READ_INPUT_NML') #endif @@ -564,8 +564,8 @@ SUBROUTINE READ_INPUT_NML (NDSI, NML_INPUT) READ (NDSI, nml=INPUT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_INPUT_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_INPUT_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (3) END IF @@ -574,77 +574,77 @@ SUBROUTINE READ_INPUT_NML (NDSI, NML_INPUT) END SUBROUTINE READ_INPUT_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NML_OUTPUT_TYPE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 25-Sep-2020 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_OUTPUT_TYPE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLSHEL Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 25-Sep-2020 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_OUTPUT_TYPE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLSHEL Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -657,12 +657,12 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NML_OUTPUT_TYPE) TYPE(NML_OUTPUT_TYPE_T) :: TYPE NAMELIST /OUTPUT_TYPE_NML/ TYPE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_OUTPUT_TYPE_NML') + CALL STRACE (IENT, 'READ_OUTPUT_TYPE_NML') #endif ! set default values for output type structure @@ -689,8 +689,8 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NML_OUTPUT_TYPE) READ (NDSI, nml=OUTPUT_TYPE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_OUTPUT_TYPE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_OUTPUT_TYPE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (4) END IF @@ -699,77 +699,77 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NML_OUTPUT_TYPE) END SUBROUTINE READ_OUTPUT_TYPE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NML_OUTPUT_DATE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 18-Apr-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_OUTPUT_DATE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLSHEL Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 18-Apr-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_OUTPUT_DATE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLSHEL Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -782,12 +782,12 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NML_OUTPUT_DATE) TYPE(NML_OUTPUT_DATE_T) :: DATE NAMELIST /OUTPUT_DATE_NML/ DATE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_OUTPUT_DATE_NML') + CALL STRACE (IENT, 'READ_OUTPUT_DATE_NML') #endif ! set default values for output_date structure @@ -824,8 +824,8 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NML_OUTPUT_DATE) READ (NDSI, nml=OUTPUT_DATE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_OUTPUT_DATE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_OUTPUT_DATE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (5) END IF @@ -834,78 +834,78 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NML_OUTPUT_DATE) END SUBROUTINE READ_OUTPUT_DATE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_HOMOG_COUNT Type. -! NML_HOMOG_INPUT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLSHEL Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_HOMOG_COUNT Type. + ! NML_HOMOG_INPUT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLSHEL Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -921,12 +921,12 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) TYPE(NML_HOMOG_INPUT_T), ALLOCATABLE :: HOMOG_INPUT(:) NAMELIST /HOMOG_INPUT_NML/ HOMOG_INPUT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_HOMOGENEOUS_NML') + CALL STRACE (IENT, 'READ_HOMOGENEOUS_NML') #endif ! set default values for homogeneous number structure @@ -953,15 +953,15 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) READ (NDSI, nml=HOMOG_COUNT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_HOMOGENEOUS_NML: namelist HOMOG_COUNT read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_HOMOGENEOUS_NML: namelist HOMOG_COUNT read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (6) END IF ! allocate the total count of homogeneous input HOMOG_COUNT%N_TOT = HOMOG_COUNT%N_IC1 + HOMOG_COUNT%N_IC2 + HOMOG_COUNT%N_IC3 + HOMOG_COUNT%N_IC4 + HOMOG_COUNT%N_IC5 + & - HOMOG_COUNT%N_MDN + HOMOG_COUNT%N_MTH + HOMOG_COUNT%N_MVS + HOMOG_COUNT%N_LEV + HOMOG_COUNT%N_CUR + & - HOMOG_COUNT%N_WND + HOMOG_COUNT%N_ICE + HOMOG_COUNT%N_TAU + HOMOG_COUNT%N_RHO + HOMOG_COUNT%N_MOV + HOMOG_COUNT%N_MDN + HOMOG_COUNT%N_MTH + HOMOG_COUNT%N_MVS + HOMOG_COUNT%N_LEV + HOMOG_COUNT%N_CUR + & + HOMOG_COUNT%N_WND + HOMOG_COUNT%N_ICE + HOMOG_COUNT%N_TAU + HOMOG_COUNT%N_RHO + HOMOG_COUNT%N_MOV ALLOCATE(HOMOG_INPUT(HOMOG_COUNT%N_TOT)) ALLOCATE(NML_HOMOG_INPUT(HOMOG_COUNT%N_TOT)) @@ -981,8 +981,8 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) READ (NDSI, nml=HOMOG_INPUT_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (MDSE,'(A,/A)') & - 'ERROR: READ_HOMOGENEOUS_NML: namelist HOMOG_INPUT_NML read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_HOMOGENEOUS_NML: namelist HOMOG_INPUT_NML read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (7) END IF @@ -993,7 +993,7 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) END SUBROUTINE READ_HOMOGENEOUS_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -1002,85 +1002,85 @@ END SUBROUTINE READ_HOMOGENEOUS_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_DOMAIN_NML (NML_DOMAIN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 18-Apr-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_DOMAIN Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLSHEL Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 18-Apr-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_DOMAIN Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLSHEL Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_DOMAIN_T), INTENT(IN) :: NML_DOMAIN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_DOMAIN_NML') + CALL STRACE (IENT, 'REPORT_DOMAIN_NML') #endif - WRITE (MSG,'(A)') 'DOMAIN % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,11) TRIM(MSG),'IOSTYP = ', NML_DOMAIN%IOSTYP - WRITE (NDSN,10) TRIM(MSG),'START = ', TRIM(NML_DOMAIN%START) - WRITE (NDSN,10) TRIM(MSG),'STOP = ', TRIM(NML_DOMAIN%STOP) + WRITE (MSG,'(A)') 'DOMAIN % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,11) TRIM(MSG),'IOSTYP = ', NML_DOMAIN%IOSTYP + WRITE (NDSN,10) TRIM(MSG),'START = ', TRIM(NML_DOMAIN%START) + WRITE (NDSN,10) TRIM(MSG),'STOP = ', TRIM(NML_DOMAIN%STOP) 10 FORMAT (A,2X,A,A) 11 FORMAT (A,2X,A,I8) @@ -1088,74 +1088,74 @@ SUBROUTINE REPORT_DOMAIN_NML (NML_DOMAIN) END SUBROUTINE REPORT_DOMAIN_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_INPUT_NML (NML_INPUT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_INPUT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLSHEL Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_INPUT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLSHEL Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1164,11 +1164,11 @@ SUBROUTINE REPORT_INPUT_NML (NML_INPUT) ! locals #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_INPUT_NML') + CALL STRACE (IENT, 'REPORT_INPUT_NML') #endif WRITE (MSG,'(A)') 'INPUT GRID % :' @@ -1197,74 +1197,74 @@ SUBROUTINE REPORT_INPUT_NML (NML_INPUT) END SUBROUTINE REPORT_INPUT_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_OUTPUT_TYPE_NML (NML_OUTPUT_TYPE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 25-Sep-2020 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_OUTPUT_TYPE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLSHEL Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 25-Sep-2020 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_OUTPUT_TYPE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLSHEL Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1273,11 +1273,11 @@ SUBROUTINE REPORT_OUTPUT_TYPE_NML (NML_OUTPUT_TYPE) ! locals #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_OUTPUT_TYPE_NML') + CALL STRACE (IENT, 'REPORT_OUTPUT_TYPE_NML') #endif WRITE (MSG,'(A)') 'OUTPUT TYPE % ' @@ -1305,74 +1305,74 @@ SUBROUTINE REPORT_OUTPUT_TYPE_NML (NML_OUTPUT_TYPE) END SUBROUTINE REPORT_OUTPUT_TYPE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_OUTPUT_DATE_NML (NML_OUTPUT_DATE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 18-Apr-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_OUTPUT_DATE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLSHEL Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 18-Apr-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_OUTPUT_DATE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLSHEL Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1381,11 +1381,11 @@ SUBROUTINE REPORT_OUTPUT_DATE_NML (NML_OUTPUT_DATE) ! locals #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_OUTPUT_DATE_NML') + CALL STRACE (IENT, 'REPORT_OUTPUT_DATE_NML') #endif WRITE (MSG,'(A)') 'OUTPUT DATE MODEL GRID % ' @@ -1422,75 +1422,75 @@ SUBROUTINE REPORT_OUTPUT_DATE_NML (NML_OUTPUT_DATE) END SUBROUTINE REPORT_OUTPUT_DATE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_HOMOGENEOUS_NML (NML_HOMOG_COUNT, NML_HOMOG_INPUT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_HOMOG_COUNT Type. -! NML_HOMOG_INPUT Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMLSHEL Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Uses MPI communications -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_HOMOG_COUNT Type. + ! NML_HOMOG_INPUT Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMLSHEL Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Uses MPI communications + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -1501,11 +1501,11 @@ SUBROUTINE REPORT_HOMOGENEOUS_NML (NML_HOMOG_COUNT, NML_HOMOG_INPUT) ! locals INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_HOMOGENEOUS_NML') + CALL STRACE (IENT, 'REPORT_HOMOGENEOUS_NML') #endif WRITE (MSG,'(A)') 'HOMOG_COUNT % ' @@ -1546,7 +1546,7 @@ SUBROUTINE REPORT_HOMOGENEOUS_NML (NML_HOMOG_COUNT, NML_HOMOG_INPUT) END SUBROUTINE REPORT_HOMOGENEOUS_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / diff --git a/model/src/w3nmltrncmd.F90 b/model/src/w3nmltrncmd.F90 index da72a35f8..0b6dadab6 100644 --- a/model/src/w3nmltrncmd.F90 +++ b/model/src/w3nmltrncmd.F90 @@ -1,22 +1,22 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3NMLTRNCMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutines. -!/ -! 1. Purpose : -! -! Manages namelists from configuration file ww3_trnc.nml for ww3_trnc program -! +#include "w3macros.h" !/ ------------------------------------------------------------------- / +MODULE W3NMLTRNCMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutines. + !/ + ! 1. Purpose : + ! + ! Manages namelists from configuration file ww3_trnc.nml for ww3_trnc program + ! + !/ ------------------------------------------------------------------- / ! module defaults IMPLICIT NONE @@ -44,72 +44,72 @@ MODULE W3NMLTRNCMD - CONTAINS -!/ ------------------------------------------------------------------- / +CONTAINS + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLTRNC (NDSI, INFILE, NML_TRACK, NML_FILE, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! -! 1. Purpose : -! -! Reads all the namelist to define the output track -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! INFILE Char. -! NML_TRACK type. -! NML_FILE type. -! IERR Int. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_TRACK_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! WW3_TRNC Prog. N/A Postprocess output tracks. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! + ! 1. Purpose : + ! + ! Reads all the namelist to define the output track + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! INFILE Char. + ! NML_TRACK type. + ! NML_FILE type. + ! IERR Int. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_TRACK_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! WW3_TRNC Prog. N/A Postprocess output tracks. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -120,18 +120,18 @@ SUBROUTINE W3NMLTRNC (NDSI, INFILE, NML_TRACK, NML_FILE, IERR) TYPE(NML_FILE_T), INTENT(INOUT) :: NML_FILE INTEGER, INTENT(OUT) :: IERR #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'W3NMLTRNC') + CALL STRACE (IENT, 'W3NMLTRNC') #endif ! open namelist log file NDSN = 3 OPEN (NDSN, file=TRIM(INFILE)//'.log', form='formatted', iostat=IERR) - IF (IERR.NE.0) THEN + IF (IERR.NE.0) THEN WRITE (NDSE,'(A)') 'ERROR: open full nml file '//TRIM(INFILE)//'.log failed' RETURN END IF @@ -158,74 +158,74 @@ SUBROUTINE W3NMLTRNC (NDSI, INFILE, NML_TRACK, NML_FILE, IERR) END SUBROUTINE W3NMLTRNC -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_TRACK_NML (NDSI, NML_TRACK) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_TRACK Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLTRNC Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_TRACK Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLTRNC Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -238,12 +238,12 @@ SUBROUTINE READ_TRACK_NML (NDSI, NML_TRACK) TYPE(NML_TRACK_T) :: TRACK NAMELIST /TRACK_NML/ TRACK #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_TRACK_NML') + CALL STRACE (IENT, 'READ_TRACK_NML') #endif ! set default values for track structure @@ -257,8 +257,8 @@ SUBROUTINE READ_TRACK_NML (NDSI, NML_TRACK) READ (NDSI, nml=TRACK_NML, iostat=IERR, iomsg=MSG) IF (IERR.NE.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_TRACK_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_TRACK_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (1) END IF @@ -267,71 +267,71 @@ SUBROUTINE READ_TRACK_NML (NDSI, NML_TRACK) END SUBROUTINE READ_TRACK_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_FILE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLTRNC Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_FILE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLTRNC Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -344,12 +344,12 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) TYPE(NML_FILE_T) :: FILE NAMELIST /FILE_NML/ FILE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_FILE_NML') + CALL STRACE (IENT, 'READ_FILE_NML') #endif ! set default values for file structure @@ -361,8 +361,8 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) READ (NDSI, nml=FILE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_FILE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_FILE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (2) END IF @@ -371,7 +371,7 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) END SUBROUTINE READ_FILE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -379,84 +379,84 @@ END SUBROUTINE READ_FILE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_TRACK_NML (NML_TRACK) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_TRACK Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLTRNC Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_TRACK Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLTRNC Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_TRACK_T), INTENT(IN) :: NML_TRACK #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_TRACK_NML') + CALL STRACE (IENT, 'REPORT_TRACK_NML') #endif - WRITE (MSG,'(A)') 'TRACK % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'TIMESTART = ', TRIM(NML_TRACK%TIMESTART) - WRITE (NDSN,10) TRIM(MSG),'TIMESTRIDE = ', TRIM(NML_TRACK%TIMESTRIDE) - WRITE (NDSN,10) TRIM(MSG),'TIMECOUNT = ', TRIM(NML_TRACK%TIMECOUNT) + WRITE (MSG,'(A)') 'TRACK % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'TIMESTART = ', TRIM(NML_TRACK%TIMESTART) + WRITE (NDSN,10) TRIM(MSG),'TIMESTRIDE = ', TRIM(NML_TRACK%TIMESTRIDE) + WRITE (NDSN,10) TRIM(MSG),'TIMECOUNT = ', TRIM(NML_TRACK%TIMECOUNT) - WRITE (NDSN,11) TRIM(MSG),'TIMESPLIT = ', NML_TRACK%TIMESPLIT + WRITE (NDSN,11) TRIM(MSG),'TIMESPLIT = ', NML_TRACK%TIMESPLIT 10 FORMAT (A,2X,A,A) @@ -464,88 +464,88 @@ SUBROUTINE REPORT_TRACK_NML (NML_TRACK) END SUBROUTINE REPORT_TRACK_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_FILE_NML (NML_FILE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_FILE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLTRNC Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_FILE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLTRNC Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_FILE_T), INTENT(IN) :: NML_FILE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_FILE_NML') + CALL STRACE (IENT, 'REPORT_FILE_NML') #endif - WRITE (MSG,'(A)') 'FILE % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'PREFIX = ', TRIM(NML_FILE%PREFIX) - WRITE (NDSN,11) TRIM(MSG),'NETCDF = ', NML_FILE%NETCDF + WRITE (MSG,'(A)') 'FILE % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'PREFIX = ', TRIM(NML_FILE%PREFIX) + WRITE (NDSN,11) TRIM(MSG),'NETCDF = ', NML_FILE%NETCDF 10 FORMAT (A,2X,A,A) @@ -553,7 +553,7 @@ SUBROUTINE REPORT_FILE_NML (NML_FILE) END SUBROUTINE REPORT_FILE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / @@ -562,54 +562,3 @@ END SUBROUTINE REPORT_FILE_NML END MODULE W3NMLTRNCMD !/ ------------------------------------------------------------------- / - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/model/src/w3nmluprstrmd.F90 b/model/src/w3nmluprstrmd.F90 index f4504d363..dff43745c 100644 --- a/model/src/w3nmluprstrmd.F90 +++ b/model/src/w3nmluprstrmd.F90 @@ -1,22 +1,22 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3NMLUPRSTRMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 06-Oct-2020 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutines. -!/ -! 1. Purpose : -! -! Manages namelists from configuration file ww3_uprstr.nml for ww3_uprstr program -! +#include "w3macros.h" !/ ------------------------------------------------------------------- / +MODULE W3NMLUPRSTRMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 06-Oct-2020 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutines. + !/ + ! 1. Purpose : + ! + ! Manages namelists from configuration file ww3_uprstr.nml for ww3_uprstr program + ! + !/ ------------------------------------------------------------------- / ! module defaults IMPLICIT NONE @@ -44,73 +44,73 @@ MODULE W3NMLUPRSTRMD - CONTAINS -!/ ------------------------------------------------------------------- / +CONTAINS + !/ ------------------------------------------------------------------- / SUBROUTINE W3NMLUPRSTR (NDSI, INFILE, NML_RESTART, NML_UPDATE, IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 06-Oct-2020 | -!/ +-----------------------------------+ -!/ -! -! 1. Purpose : -! -! Reads all the namelist to define the output field -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! INFILE Char. -! NML_RESTART type. -! NML_UPDATE type. -! IERR Int. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! READ_RESTART_NML -! READ_UPDATE_NML -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! WW3_UPRSTR Prog. N/A Update restart file -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 06-Oct-2020 | + !/ +-----------------------------------+ + !/ + ! + ! 1. Purpose : + ! + ! Reads all the namelist to define the output field + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! INFILE Char. + ! NML_RESTART type. + ! NML_UPDATE type. + ! IERR Int. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! READ_RESTART_NML + ! READ_UPDATE_NML + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! WW3_UPRSTR Prog. N/A Update restart file + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -121,12 +121,12 @@ SUBROUTINE W3NMLUPRSTR (NDSI, INFILE, NML_RESTART, NML_UPDATE, IERR) TYPE(NML_UPDATE_T), INTENT(INOUT) :: NML_UPDATE INTEGER, INTENT(OUT) :: IERR #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'W3NMLUPRSTR') + CALL STRACE (IENT, 'W3NMLUPRSTR') #endif ! open namelist log file @@ -159,71 +159,71 @@ SUBROUTINE W3NMLUPRSTR (NDSI, INFILE, NML_RESTART, NML_UPDATE, IERR) END SUBROUTINE W3NMLUPRSTR -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_RESTART_NML (NDSI, NML_RESTART) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 06-Oct-2020 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_RESTART Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLUPRSTR Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 06-Oct-2020 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_RESTART Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLUPRSTR Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -236,12 +236,12 @@ SUBROUTINE READ_RESTART_NML (NDSI, NML_RESTART) TYPE(NML_RESTART_T) :: RESTART NAMELIST /RESTART_NML/ RESTART #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_RESTART_NML') + CALL STRACE (IENT, 'READ_RESTART_NML') #endif ! set default values @@ -252,8 +252,8 @@ SUBROUTINE READ_RESTART_NML (NDSI, NML_RESTART) READ (NDSI, nml=RESTART_NML, iostat=IERR, iomsg=MSG) IF (IERR.NE.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_RESTART_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_RESTART_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (1) END IF @@ -262,71 +262,71 @@ SUBROUTINE READ_RESTART_NML (NDSI, NML_RESTART) END SUBROUTINE READ_RESTART_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE READ_UPDATE_NML (NDSI, NML_UPDATE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 06-Oct-2020 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSI Int. -! NML_UPDATE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLUPRSTR Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 06-Oct-2020 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSI Int. + ! NML_UPDATE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLUPRSTR Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE @@ -339,12 +339,12 @@ SUBROUTINE READ_UPDATE_NML (NDSI, NML_UPDATE) TYPE(NML_UPDATE_T) :: UPDATE NAMELIST /UPDATE_NML/ UPDATE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif IERR = 0 #ifdef W3_S - CALL STRACE (IENT, 'READ_UPDATE_NML') + CALL STRACE (IENT, 'READ_UPDATE_NML') #endif ! set default values for update approach @@ -361,8 +361,8 @@ SUBROUTINE READ_UPDATE_NML (NDSI, NML_UPDATE) READ (NDSI, nml=UPDATE_NML, iostat=IERR, iomsg=MSG) IF (IERR.GT.0) THEN WRITE (NDSE,'(A,/A)') & - 'ERROR: READ_UPDATE_NML: namelist read error', & - 'ERROR: '//TRIM(MSG) + 'ERROR: READ_UPDATE_NML: namelist read error', & + 'ERROR: '//TRIM(MSG) CALL EXTCDE (2) END IF @@ -371,186 +371,186 @@ SUBROUTINE READ_UPDATE_NML (NDSI, NML_UPDATE) END SUBROUTINE READ_UPDATE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_RESTART_NML (NML_RESTART) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 06-Oct-2020 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_RESTART Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLUPRSTR Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 06-Oct-2020 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_RESTART Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLUPRSTR Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_RESTART_T), INTENT(IN) :: NML_RESTART #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_RESTART_NML') + CALL STRACE (IENT, 'REPORT_RESTART_NML') #endif - WRITE (MSG,'(A)') 'RESTART % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'RESTARTTIME = ', TRIM(NML_RESTART%RESTARTTIME) + WRITE (MSG,'(A)') 'RESTART % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'RESTARTTIME = ', TRIM(NML_RESTART%RESTARTTIME) 10 FORMAT (A,2X,A,A) END SUBROUTINE REPORT_RESTART_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / SUBROUTINE REPORT_UPDATE_NML (NML_UPDATE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 06-Oct-2020 | -!/ +-----------------------------------+ -!/ -!/ -! 1. Purpose : -! -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NML_UPDATE Type. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD SUBROUTINE tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name TYPE Module Description -! ---------------------------------------------------------------- -! W3NMLUPRSTR Subr. N/A Namelist configuration routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 06-Oct-2020 | + !/ +-----------------------------------+ + !/ + !/ + ! 1. Purpose : + ! + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NML_UPDATE Type. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD SUBROUTINE tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name TYPE Module Description + ! ---------------------------------------------------------------- + ! W3NMLUPRSTR Subr. N/A Namelist configuration routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif IMPLICIT NONE TYPE(NML_UPDATE_T), INTENT(IN) :: NML_UPDATE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'REPORT_UPDATE_NML') + CALL STRACE (IENT, 'REPORT_UPDATE_NML') #endif - WRITE (MSG,'(A)') 'UPDATE % ' - WRITE (NDSN,'(A)') - WRITE (NDSN,10) TRIM(MSG),'UPDPROC = ', TRIM(NML_UPDATE%UPDPROC) - ! PRCNTG only used by UPD0F - IF (TRIM(NML_UPDATE%UPDPROC) .EQ. 'UPD0F') THEN - WRITE (NDSN,11) TRIM(MSG),'PRCNTG = ', NML_UPDATE%PRCNTG - ELSE - WRITE (NDSN,11) TRIM(MSG),'PRCNTGCAP = ', NML_UPDATE%PRCNTGCAP - ! THRWSEA only used by UPD5/6 - IF ((TRIM(NML_UPDATE%UPDPROC) .EQ. 'UPD5') .OR. & - (TRIM(NML_UPDATE%UPDPROC) .EQ. 'UPD6')) THEN - WRITE (NDSN,11) TRIM(MSG),'THRWSEA = ', NML_UPDATE%THRWSEA - ENDIF - WRITE (NDSN,10) TRIM(MSG),'FILE = ', TRIM(NML_UPDATE%FILE) + WRITE (MSG,'(A)') 'UPDATE % ' + WRITE (NDSN,'(A)') + WRITE (NDSN,10) TRIM(MSG),'UPDPROC = ', TRIM(NML_UPDATE%UPDPROC) + ! PRCNTG only used by UPD0F + IF (TRIM(NML_UPDATE%UPDPROC) .EQ. 'UPD0F') THEN + WRITE (NDSN,11) TRIM(MSG),'PRCNTG = ', NML_UPDATE%PRCNTG + ELSE + WRITE (NDSN,11) TRIM(MSG),'PRCNTGCAP = ', NML_UPDATE%PRCNTGCAP + ! THRWSEA only used by UPD5/6 + IF ((TRIM(NML_UPDATE%UPDPROC) .EQ. 'UPD5') .OR. & + (TRIM(NML_UPDATE%UPDPROC) .EQ. 'UPD6')) THEN + WRITE (NDSN,11) TRIM(MSG),'THRWSEA = ', NML_UPDATE%THRWSEA ENDIF + WRITE (NDSN,10) TRIM(MSG),'FILE = ', TRIM(NML_UPDATE%FILE) + ENDIF 10 FORMAT (A,2X,A,A) 11 FORMAT (A,2X,A,F5.3) END SUBROUTINE REPORT_UPDATE_NML -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / diff --git a/model/src/w3oacpmd.F90 b/model/src/w3oacpmd.F90 index d4190384f..72e48e4e1 100644 --- a/model/src/w3oacpmd.F90 +++ b/model/src/w3oacpmd.F90 @@ -1,1238 +1,1147 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3OACPMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ July-2013 : Origination. ( version 4.18 ) -!/ For upgrades see subroutines. -!/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ 25-Sep-2020 : Coupling at T+0 support ( version 7.10 ) -!/ 22-Mar-2021 : Adds extra coupling fields ( version 7.13 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Generic Module used for coupling applications with OASIS3-MCT -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! CPL_OASIS_INIT Subr. Public Initialize the coupling -! CPL_OASIS_GRID Subr. Public Grids defintion -! CPL_OASIS_DEFINE Subr. Public Partition definition -! CPL_OASIS_SND Subr. Public Send fields to ocean/atmos model -! CPL_OASIS_RCV Subr. Public Receive fields from ocean/atmos model -! CPL_OASIS_FINALIZE Subr. Public Finalize the coupling -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! -------------------------------------------------------------------- -! GET_LIST_EXCH_FIELD Subr. W3OACPMD List of the exchanged fields -! STRSPLIT Subr. W3SERVMD Splits string into words -! -------------------------------------------------------------------- -! -! 5. Remarks -! -! Module adapted from WRF-OASIS routine implemented by -! Sebastien Masson (IPSL), Guillaume Samson (Legos) and Eric Maisonnave (Cerfacs) -! -! 6. Switches : -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE MOD_OASIS ! OASIS3-MCT module -! - IMPLICIT NONE - PRIVATE -! - INTEGER :: IL_COMPID ! Component model ID returned by oasis_init_comp - CHARACTER(LEN=6) :: CL_MODEL_NAME = 'wwatch' ! Model name (same as in namcouple) - INTEGER :: IL_ERR ! Return error code - INTEGER, PUBLIC :: IL_NB_RCV, IL_NB_SND ! Number of coupling fields - INTEGER, PARAMETER :: IP_MAXFLD=50 ! Maximum number of coupling fields - INTEGER :: NNODES ! Total numbers of cell in the grid -! - TYPE, PUBLIC :: CPL_FIELD ! Type for coupling field information - CHARACTER(LEN = 8) :: CL_FIELD_NAME ! Name of the coupling field - INTEGER :: IL_FIELD_ID ! Field ID - END TYPE CPL_FIELD -! - TYPE(CPL_FIELD), DIMENSION(IP_MAXFLD), PUBLIC :: RCV_FLD, SND_FLD ! Coupling fields -! - INTEGER, PUBLIC :: ID_OASIS_TIME=0 ! time counter for coupling exchanges -! - LOGICAL, PUBLIC :: CPLT0 ! Flag for coupling at T+0 -! -! * Accessibility - PUBLIC CPL_OASIS_INIT - PUBLIC CPL_OASIS_GRID - PUBLIC CPL_OASIS_DEFINE - PUBLIC CPL_OASIS_SND - PUBLIC CPL_OASIS_RCV - PUBLIC CPL_OASIS_FINALIZE -! - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE CPL_OASIS_INIT(ID_LCOMM) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | FORTRAN 90 | -!/ | Last update : April-2016 | -!/ +-----------------------------------+ -!/ -!/ Jul-2013 : Origination. ( version 4.18 ) -!/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ -! 1. Purpose : -! -! Initialize the coupling -! -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ID_LCOMM Int. O MPI communicator -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_SHEL Prog. - Main program -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -! * Argument - INTEGER, INTENT(OUT) :: ID_LCOMM ! Model local communicator -! -!---------------------------------------------------------------------- -! * Executable part -! - !! Initialize the coupling - CALL OASIS_INIT_COMP(IL_COMPID, CL_MODEL_NAME, IL_ERR) - IF (IL_ERR /= 0) THEN - CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_INIT', 'Problem during oasis_init_comp') - ENDIF -! - !! Get the value of a local MPI communicator to be used by WW3 for its internal parallelisation - CALL OASIS_GET_LOCALCOMM(ID_LCOMM, IL_ERR) - IF (IL_ERR /= 0) THEN - CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_INIT', 'Problem during oasis_get_localcomm') - ENDIF -! -!/ ------------------------------------------------------------------- / - END SUBROUTINE CPL_OASIS_INIT -!/ ------------------------------------------------------------------- / - SUBROUTINE CPL_OASIS_GRID(LD_MASTER,ID_LCOMM) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | V. Garnier | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : April-2016 | -!/ +-----------------------------------+ -!/ -!/ Jul-2013 : Origination. ( version 4.18 ) -!/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ Sept-2016 : Correct bug MPI (J. Pianezze) ( version 5.12 ) -!/ -! 1. Purpose : -! -! Grid data file definition -! -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! LD_MASTER Bool. I Flag to know the master process -! ID_LCOMM Int. I MPI communicator -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_SHEL Prog. - Main program -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE CONSTANTS, ONLY: RADIUS, DERA - USE W3GDATMD, ONLY: NX, NY, FLAGLL, XGRD, YGRD, MAPSTA, & - & HPFAC, HQFAC, GTYPE, & - & UNGTYPE, RLGTYPE, CLGTYPE, SMCTYPE +MODULE W3OACPMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ July-2013 : Origination. ( version 4.18 ) + !/ For upgrades see subroutines. + !/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ 25-Sep-2020 : Coupling at T+0 support ( version 7.10 ) + !/ 22-Mar-2021 : Adds extra coupling fields ( version 7.13 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Generic Module used for coupling applications with OASIS3-MCT + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! CPL_OASIS_INIT Subr. Public Initialize the coupling + ! CPL_OASIS_GRID Subr. Public Grids defintion + ! CPL_OASIS_DEFINE Subr. Public Partition definition + ! CPL_OASIS_SND Subr. Public Send fields to ocean/atmos model + ! CPL_OASIS_RCV Subr. Public Receive fields from ocean/atmos model + ! CPL_OASIS_FINALIZE Subr. Public Finalize the coupling + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! -------------------------------------------------------------------- + ! GET_LIST_EXCH_FIELD Subr. W3OACPMD List of the exchanged fields + ! STRSPLIT Subr. W3SERVMD Splits string into words + ! -------------------------------------------------------------------- + ! + ! 5. Remarks + ! + ! Module adapted from WRF-OASIS routine implemented by + ! Sebastien Masson (IPSL), Guillaume Samson (Legos) and Eric Maisonnave (Cerfacs) + ! + ! 6. Switches : + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE MOD_OASIS ! OASIS3-MCT module + ! + IMPLICIT NONE + PRIVATE + ! + INTEGER :: IL_COMPID ! Component model ID returned by oasis_init_comp + CHARACTER(LEN=6) :: CL_MODEL_NAME = 'wwatch' ! Model name (same as in namcouple) + INTEGER :: IL_ERR ! Return error code + INTEGER, PUBLIC :: IL_NB_RCV, IL_NB_SND ! Number of coupling fields + INTEGER, PARAMETER :: IP_MAXFLD=50 ! Maximum number of coupling fields + INTEGER :: NNODES ! Total numbers of cell in the grid + ! + TYPE, PUBLIC :: CPL_FIELD ! Type for coupling field information + CHARACTER(LEN = 8) :: CL_FIELD_NAME ! Name of the coupling field + INTEGER :: IL_FIELD_ID ! Field ID + END TYPE CPL_FIELD + ! + TYPE(CPL_FIELD), DIMENSION(IP_MAXFLD), PUBLIC :: RCV_FLD, SND_FLD ! Coupling fields + ! + INTEGER, PUBLIC :: ID_OASIS_TIME=0 ! time counter for coupling exchanges + ! + LOGICAL, PUBLIC :: CPLT0 ! Flag for coupling at T+0 + ! + ! * Accessibility + PUBLIC CPL_OASIS_INIT + PUBLIC CPL_OASIS_GRID + PUBLIC CPL_OASIS_DEFINE + PUBLIC CPL_OASIS_SND + PUBLIC CPL_OASIS_RCV + PUBLIC CPL_OASIS_FINALIZE + ! +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE CPL_OASIS_INIT(ID_LCOMM) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | FORTRAN 90 | + !/ | Last update : April-2016 | + !/ +-----------------------------------+ + !/ + !/ Jul-2013 : Origination. ( version 4.18 ) + !/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ + ! 1. Purpose : + ! + ! Initialize the coupling + ! + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ID_LCOMM Int. O MPI communicator + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_SHEL Prog. - Main program + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + ! * Argument + INTEGER, INTENT(OUT) :: ID_LCOMM ! Model local communicator + ! + !---------------------------------------------------------------------- + ! * Executable part + ! + !! Initialize the coupling + CALL OASIS_INIT_COMP(IL_COMPID, CL_MODEL_NAME, IL_ERR) + IF (IL_ERR /= 0) THEN + CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_INIT', 'Problem during oasis_init_comp') + ENDIF + ! + !! Get the value of a local MPI communicator to be used by WW3 for its internal parallelisation + CALL OASIS_GET_LOCALCOMM(ID_LCOMM, IL_ERR) + IF (IL_ERR /= 0) THEN + CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_INIT', 'Problem during oasis_get_localcomm') + ENDIF + ! + !/ ------------------------------------------------------------------- / + END SUBROUTINE CPL_OASIS_INIT + !/ ------------------------------------------------------------------- / + SUBROUTINE CPL_OASIS_GRID(LD_MASTER,ID_LCOMM) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | V. Garnier | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : April-2016 | + !/ +-----------------------------------+ + !/ + !/ Jul-2013 : Origination. ( version 4.18 ) + !/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ Sept-2016 : Correct bug MPI (J. Pianezze) ( version 5.12 ) + !/ + ! 1. Purpose : + ! + ! Grid data file definition + ! + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! LD_MASTER Bool. I Flag to know the master process + ! ID_LCOMM Int. I MPI communicator + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_SHEL Prog. - Main program + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE CONSTANTS, ONLY: RADIUS, DERA + USE W3GDATMD, ONLY: NX, NY, FLAGLL, XGRD, YGRD, MAPSTA, & + & HPFAC, HQFAC, GTYPE, & + & UNGTYPE, RLGTYPE, CLGTYPE, SMCTYPE #ifdef W3_SMC - USE W3GDATMD, ONLY: NSEA, X0, Y0, MRFct, SX, SY, IJKCel + USE W3GDATMD, ONLY: NSEA, X0, Y0, MRFct, SX, SY, IJKCel #endif #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - LOGICAL, INTENT(IN) :: LD_MASTER ! MASTER process or not - INTEGER, INTENT(IN) :: ID_LCOMM ! Model local communicator -! -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, ALLOCATABLE :: MASK(:,:) - INTEGER :: I, IX, IY, NXW, NXE, NYS, NYN, INODE, IERR_MPI - REAL, ALLOCATABLE :: LON(:,:),LAT(:,:),AREA(:,:), & - CORLON(:,:,:),CORLAT(:,:,:) - REAL :: FACTOR -#ifdef W3_SMC - REAL :: DLON, DLAT + INCLUDE "mpif.h" #endif -!/ ------------------------------------------------------------------- / -! - IF (LD_MASTER) THEN -! - ! - ! 0. Create grids file - ! -------------------------------- - CALL OASIS_START_GRIDS_WRITING(IERR_MPI) - ! - ! 1. Get the lat/lon/corners,areas and masks - ! ------------------------------------------- - IF (GTYPE .EQ. RLGTYPE .OR. GTYPE .EQ. CLGTYPE) THEN -! - IF (FLAGLL) THEN - FACTOR = 1. - ELSE - FACTOR = 1. / (RADIUS * DERA) - END IF - ! - ! 1.1. regular and curvilinear grids - ! ---------------------------------- - NNODES = NX*NY - NXW=1 - NXE=NX - NYS=1 - NYN=NY - ! - ! lat/lon - ALLOCATE ( LON(NNODES,1), LAT(NNODES,1) ) - I = 0 - DO IY = NYS, NYN - DO IX = NXW, NXE - I = I+1 - LON(I,1)=XGRD(IY,IX)*FACTOR - LAT(I,1)=YGRD(IY,IX)*FACTOR - END DO - END DO - ! - ! areas, corners - ALLOCATE ( AREA(NNODES,1), CORLON(NNODES,1,4), CORLAT(NNODES,1,4) ) - I = 0 - DO IY = NYS, NYN - DO IX = NXW, NXE - I = I+1 - CORLON(I,1,1)=LON(I,1)+HPFAC(IY,IX)/2.*FACTOR - CORLON(I,1,2)=LON(I,1)-HPFAC(IY,IX)/2.*FACTOR - CORLON(I,1,3)=LON(I,1)-HPFAC(IY,IX)/2.*FACTOR - CORLON(I,1,4)=LON(I,1)+HPFAC(IY,IX)/2.*FACTOR - CORLAT(I,1,1)=LAT(I,1)+HQFAC(IY,IX)/2.*FACTOR - CORLAT(I,1,2)=LAT(I,1)+HQFAC(IY,IX)/2.*FACTOR - CORLAT(I,1,3)=LAT(I,1)-HQFAC(IY,IX)/2.*FACTOR - CORLAT(I,1,4)=LAT(I,1)-HQFAC(IY,IX)/2.*FACTOR - AREA(I,1)=HPFAC(IY,IX)*HQFAC(IY,IX) - END DO - END DO - ! - ! Model grid mask - ALLOCATE ( MASK(NNODES,1) ) - I = 0 - DO IY = NYS, NYN - DO IX = NXW, NXE - I = I+1 - ! Get the mask : 0 - sea / 1 - open boundary cells (the land is already excluded) - IF ((MAPSTA(IY,IX) .EQ. 1)) THEN - MASK(I,1) = 0 - ELSE - MASK(I,1) = 1 - END IF - END DO - END DO + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + LOGICAL, INTENT(IN) :: LD_MASTER ! MASTER process or not + INTEGER, INTENT(IN) :: ID_LCOMM ! Model local communicator + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, ALLOCATABLE :: MASK(:,:) + INTEGER :: I, IX, IY, NXW, NXE, NYS, NYN, INODE, IERR_MPI + REAL, ALLOCATABLE :: LON(:,:),LAT(:,:),AREA(:,:), & + CORLON(:,:,:),CORLAT(:,:,:) + REAL :: FACTOR #ifdef W3_SMC - ELSE IF( GTYPE .EQ. SMCTYPE ) THEN - ! - ! 1.2. SMC grids - ! ---------------------------------- - NNODES = NSEA - ! - ! Calculate the smallest grid cell increments depending on the number of SMC levels - DLON = SX / MRFct - DLAT = SY / MRFct - ! - ALLOCATE ( LON(NNODES,1), LAT(NNODES,1) ) - ALLOCATE ( AREA(NNODES,1), CORLON(NNODES,1,4), CORLAT(NNODES,1,4) ) - ALLOCATE ( MASK(NNODES,1) ) - DO I=1, NNODES - ! lat/lon - LON(I,1) = X0 + (IJKCel(1,I) + IJKCel(3,I)*0.5)*DLON - LAT(I,1) = Y0 + (IJKCel(2,I) + IJKCel(4,I)*0.5)*DLAT - ! corners - CORLON(I,1,1) = X0 + IJKCel(1,I)*DLON - CORLON(I,1,2) = X0 + (IJKCel(1,I) + IJKCel(3,I))*DLON - CORLON(I,1,3) = CORLON(I,1,2) - CORLON(I,1,4) = CORLON(I,1,1) - CORLAT(I,1,1) = Y0 + IJKCel(2,I)*DLAT - CORLAT(I,1,2)=CORLAT(I,1,1) - CORLAT(I,1,3) = Y0 + (IJKCel(2,I) + IJKCel(4,I))*DLAT - CORLAT(I,1,4)=CORLAT(I,1,3) - ! areas - AREA(I,1) = 0.25 * IJKCEL(3,I)*DLON * IJKCEL(4,I)*DLAT - ! Model grid mask - MASK(I,1) = 1 - ENDDO + REAL :: DLON, DLAT #endif -! - ELSE - ! - ! 1.3. Unstructured grids - ! ---------------------------------- - WRITE(*,*) 'TO BE IMPLEMENT FOR UNSTRUCTURED GRIDS' - STOP - END IF - ! - CALL OASIS_WRITE_GRID('ww3t',NNODES,1,LON,LAT) - CALL OASIS_WRITE_CORNER('ww3t',NNODES,1,4,CORLON,CORLAT) - CALL OASIS_WRITE_AREA('ww3t',NNODES,1,AREA) - CALL OASIS_WRITE_MASK('ww3t',NNODES,1,MASK) - ! - ! 2. Terminate grid writing - ! ------------------------- - CALL OASIS_TERMINATE_GRIDS_WRITING() - ! - DEALLOCATE(LON) - DEALLOCATE(LAT) - DEALLOCATE(CORLON) - DEALLOCATE(CORLAT) - DEALLOCATE(AREA) - DEALLOCATE(MASK) - ! - ENDIF -! -#ifdef W3_MPI - CALL MPI_BCAST(NNODES,1,MPI_INTEGER,0,ID_LCOMM,IERR_MPI) -#endif -! -!/ ------------------------------------------------------------------- / - END SUBROUTINE CPL_OASIS_GRID -!/ ------------------------------------------------------------------- / - SUBROUTINE CPL_OASIS_DEFINE(NDSO,RCV_STR,SND_STR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | V. Garnier | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 08-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ Jul-2013 : Origination. ( version 4.18 ) -!/ April-2016 : Add coupling for unstructured grids ( version 5.07 ) -!/ (R. Baraille & J. Pianezze) -!/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ 08-Jun-2018 : use INIT_GET_ISEA ( version 6.04 ) -!/ -! 1. Purpose : -! -! Partition definition and coupling fields declaration -! -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSO Int. I Id. of the output file -! RCV_STR Char. I Name of receive fields -! SND_STR Char. I Name of send fields -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! GET_LIST_EXCH_FIELD Subr. W3OACPMD List of the exchanged fields -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_SHEL Prog. - Main program -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3GDATMD, ONLY: NSEAL,NSEA, NX, NY, MAPSTA, MAPSF, GTYPE, & - & UNGTYPE, RLGTYPE, CLGTYPE, SMCTYPE - USE W3ODATMD, ONLY: NAPROC, IAPROC - USE W3PARALL, ONLY : INIT_GET_ISEA -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSO - CHARACTER(LEN=1024), INTENT(IN) :: RCV_STR,SND_STR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IB_I,I - INTEGER :: IL_PART_ID ! PartitionID - INTEGER, ALLOCATABLE, DIMENSION(:) :: ILA_PARAL ! Description of the local partition in the global index space - INTEGER, DIMENSION(4) :: ILA_SHAPE ! Vector giving the min & max index for each dim of the fields - INTEGER, DIMENSION(2) :: ILA_VAR_NODIMS ! rank of fields & number of bundles (1 with OASIS3-MCT) - INTEGER :: ISEA, JSEA, IX, IY - INTEGER :: NHXW, NHXE, NHYS, NHYN ! size of the halo at the western, eastern, southern, northern boundaries - LOGICAL :: LL_MPI_FILE ! to check if there an mpi.txt file for domain decompasition -!/ -!/ ------------------------------------------------------------------- / -!/ Executable part -!/ -! - IF (GTYPE .EQ. RLGTYPE .OR. GTYPE .EQ. CLGTYPE) THEN - ! - ! 1.1. regular and curvilinear grids - ! ---------------------------------- - NHXW = 1 ; NHXE = NX ; NHYS = 1 ; NHYN = NY - NHXW = NHXW - 1 - NHXE = NX - NHXE - NHYS = NHYS - 1 - NHYN = NY - NHYN - ! - ALLOCATE(ILA_PARAL(2+NSEAL*2)) - ! - ! * Define the partition : OASIS ORANGE partition - ILA_PARAL(1) = 3 - ! - ! * total number of segments of the global domain - ILA_PARAL(2) = NSEAL - ! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA,JSEA) - - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - ILA_PARAL(JSEA*2+1) = (IY - NHYN -1)*(NX - NHXE - NHXW) + (IX - NHXW - 1) - ILA_PARAL(JSEA*2+2) = 1 + !/ ------------------------------------------------------------------- / + ! + IF (LD_MASTER) THEN + ! + ! + ! 0. Create grids file + ! -------------------------------- + CALL OASIS_START_GRIDS_WRITING(IERR_MPI) + ! + ! 1. Get the lat/lon/corners,areas and masks + ! ------------------------------------------- + IF (GTYPE .EQ. RLGTYPE .OR. GTYPE .EQ. CLGTYPE) THEN + ! + IF (FLAGLL) THEN + FACTOR = 1. + ELSE + FACTOR = 1. / (RADIUS * DERA) + END IF + ! + ! 1.1. regular and curvilinear grids + ! ---------------------------------- + NNODES = NX*NY + NXW=1 + NXE=NX + NYS=1 + NYN=NY + ! + ! lat/lon + ALLOCATE ( LON(NNODES,1), LAT(NNODES,1) ) + I = 0 + DO IY = NYS, NYN + DO IX = NXW, NXE + I = I+1 + LON(I,1)=XGRD(IY,IX)*FACTOR + LAT(I,1)=YGRD(IY,IX)*FACTOR END DO + END DO + ! + ! areas, corners + ALLOCATE ( AREA(NNODES,1), CORLON(NNODES,1,4), CORLAT(NNODES,1,4) ) + I = 0 + DO IY = NYS, NYN + DO IX = NXW, NXE + I = I+1 + CORLON(I,1,1)=LON(I,1)+HPFAC(IY,IX)/2.*FACTOR + CORLON(I,1,2)=LON(I,1)-HPFAC(IY,IX)/2.*FACTOR + CORLON(I,1,3)=LON(I,1)-HPFAC(IY,IX)/2.*FACTOR + CORLON(I,1,4)=LON(I,1)+HPFAC(IY,IX)/2.*FACTOR + CORLAT(I,1,1)=LAT(I,1)+HQFAC(IY,IX)/2.*FACTOR + CORLAT(I,1,2)=LAT(I,1)+HQFAC(IY,IX)/2.*FACTOR + CORLAT(I,1,3)=LAT(I,1)-HQFAC(IY,IX)/2.*FACTOR + CORLAT(I,1,4)=LAT(I,1)-HQFAC(IY,IX)/2.*FACTOR + AREA(I,1)=HPFAC(IY,IX)*HQFAC(IY,IX) + END DO + END DO + ! + ! Model grid mask + ALLOCATE ( MASK(NNODES,1) ) + I = 0 + DO IY = NYS, NYN + DO IX = NXW, NXE + I = I+1 + ! Get the mask : 0 - sea / 1 - open boundary cells (the land is already excluded) + IF ((MAPSTA(IY,IX) .EQ. 1)) THEN + MASK(I,1) = 0 + ELSE + MASK(I,1) = 1 + END IF + END DO + END DO #ifdef W3_SMC - ELSE IF( GTYPE .EQ. SMCTYPE ) THEN - ! - ! 1.2. SMC grids - ! ---------------------------------- - ALLOCATE(ILA_PARAL(2+NSEAL)) - ! - ! * Define the partition : OASIS POINTS partition - ILA_PARAL(1) = 4 - ! - ! * total number of segments of the global domain - ILA_PARAL(2) = NSEAL - ! - DO JSEA=1, NSEAL - ILA_PARAL(JSEA+2) = IAPROC + (JSEA-1)*NAPROC - ENDDO + ELSE IF( GTYPE .EQ. SMCTYPE ) THEN + ! + ! 1.2. SMC grids + ! ---------------------------------- + NNODES = NSEA + ! + ! Calculate the smallest grid cell increments depending on the number of SMC levels + DLON = SX / MRFct + DLAT = SY / MRFct + ! + ALLOCATE ( LON(NNODES,1), LAT(NNODES,1) ) + ALLOCATE ( AREA(NNODES,1), CORLON(NNODES,1,4), CORLAT(NNODES,1,4) ) + ALLOCATE ( MASK(NNODES,1) ) + DO I=1, NNODES + ! lat/lon + LON(I,1) = X0 + (IJKCel(1,I) + IJKCel(3,I)*0.5)*DLON + LAT(I,1) = Y0 + (IJKCel(2,I) + IJKCel(4,I)*0.5)*DLAT + ! corners + CORLON(I,1,1) = X0 + IJKCel(1,I)*DLON + CORLON(I,1,2) = X0 + (IJKCel(1,I) + IJKCel(3,I))*DLON + CORLON(I,1,3) = CORLON(I,1,2) + CORLON(I,1,4) = CORLON(I,1,1) + CORLAT(I,1,1) = Y0 + IJKCel(2,I)*DLAT + CORLAT(I,1,2)=CORLAT(I,1,1) + CORLAT(I,1,3) = Y0 + (IJKCel(2,I) + IJKCel(4,I))*DLAT + CORLAT(I,1,4)=CORLAT(I,1,3) + ! areas + AREA(I,1) = 0.25 * IJKCEL(3,I)*DLON * IJKCEL(4,I)*DLAT + ! Model grid mask + MASK(I,1) = 1 + ENDDO #endif -! + ! ELSE - ! - ! 1.3. Unstructured grids - ! ---------------------------------- - WRITE(*,*) 'TO BE VERIFIED FOR UNSTRUCTURED GRIDS' - STOP - ! - DO JSEA=1,NSEAL - ILA_PARAL(JSEA*2+1) = (IAPROC-1) + (JSEA-1)*NAPROC - ILA_PARAL(JSEA*2+2) = 1 - END DO - ! - ENDIF + ! + ! 1.3. Unstructured grids + ! ---------------------------------- + WRITE(*,*) 'TO BE IMPLEMENT FOR UNSTRUCTURED GRIDS' + STOP + END IF ! - ! 2. Partition definition + CALL OASIS_WRITE_GRID('ww3t',NNODES,1,LON,LAT) + CALL OASIS_WRITE_CORNER('ww3t',NNODES,1,4,CORLON,CORLAT) + CALL OASIS_WRITE_AREA('ww3t',NNODES,1,AREA) + CALL OASIS_WRITE_MASK('ww3t',NNODES,1,MASK) + ! + ! 2. Terminate grid writing + ! ------------------------- + CALL OASIS_TERMINATE_GRIDS_WRITING() + ! + DEALLOCATE(LON) + DEALLOCATE(LAT) + DEALLOCATE(CORLON) + DEALLOCATE(CORLAT) + DEALLOCATE(AREA) + DEALLOCATE(MASK) + ! + ENDIF + ! +#ifdef W3_MPI + CALL MPI_BCAST(NNODES,1,MPI_INTEGER,0,ID_LCOMM,IERR_MPI) +#endif + ! + !/ ------------------------------------------------------------------- / + END SUBROUTINE CPL_OASIS_GRID + !/ ------------------------------------------------------------------- / + SUBROUTINE CPL_OASIS_DEFINE(NDSO,RCV_STR,SND_STR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | V. Garnier | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 08-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ Jul-2013 : Origination. ( version 4.18 ) + !/ April-2016 : Add coupling for unstructured grids ( version 5.07 ) + !/ (R. Baraille & J. Pianezze) + !/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ 08-Jun-2018 : use INIT_GET_ISEA ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Partition definition and coupling fields declaration + ! + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSO Int. I Id. of the output file + ! RCV_STR Char. I Name of receive fields + ! SND_STR Char. I Name of send fields + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! GET_LIST_EXCH_FIELD Subr. W3OACPMD List of the exchanged fields + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_SHEL Prog. - Main program + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GDATMD, ONLY: NSEAL,NSEA, NX, NY, MAPSTA, MAPSF, GTYPE, & + & UNGTYPE, RLGTYPE, CLGTYPE, SMCTYPE + USE W3ODATMD, ONLY: NAPROC, IAPROC + USE W3PARALL, ONLY : INIT_GET_ISEA + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSO + CHARACTER(LEN=1024), INTENT(IN) :: RCV_STR,SND_STR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IB_I,I + INTEGER :: IL_PART_ID ! PartitionID + INTEGER, ALLOCATABLE, DIMENSION(:) :: ILA_PARAL ! Description of the local partition in the global index space + INTEGER, DIMENSION(4) :: ILA_SHAPE ! Vector giving the min & max index for each dim of the fields + INTEGER, DIMENSION(2) :: ILA_VAR_NODIMS ! rank of fields & number of bundles (1 with OASIS3-MCT) + INTEGER :: ISEA, JSEA, IX, IY + INTEGER :: NHXW, NHXE, NHYS, NHYN ! size of the halo at the western, eastern, southern, northern boundaries + LOGICAL :: LL_MPI_FILE ! to check if there an mpi.txt file for domain decompasition + !/ + !/ ------------------------------------------------------------------- / + !/ Executable part + !/ + ! + IF (GTYPE .EQ. RLGTYPE .OR. GTYPE .EQ. CLGTYPE) THEN + ! + ! 1.1. regular and curvilinear grids ! ---------------------------------- - CALL OASIS_DEF_PARTITION(IL_PART_ID, ILA_PARAL,IL_ERR,NNODES) - IF(IL_ERR /= 0) THEN - CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_DEFINE', 'Problem during oasis_def_partition') - ENDIF + NHXW = 1 ; NHXE = NX ; NHYS = 1 ; NHYN = NY + NHXW = NHXW - 1 + NHXE = NX - NHXE + NHYS = NHYS - 1 + NHYN = NY - NHYN ! - ! 3. Coupling fields declaration - ! ---------------------------------- - ILA_SHAPE(:) = (/1, NSEAL, 1, 1 /) + ALLOCATE(ILA_PARAL(2+NSEAL*2)) ! - ILA_VAR_NODIMS(1) = 2 ! rank of fields array - ILA_VAR_NODIMS(2) = 1 ! always 1 with OASIS3-MCT 2.0 + ! * Define the partition : OASIS ORANGE partition + ILA_PARAL(1) = 3 ! - CALL GET_LIST_EXCH_FIELD(NDSO, RCV_FLD, SND_FLD, IL_NB_RCV, IL_NB_SND, RCV_STR, SND_STR) + ! * total number of segments of the global domain + ILA_PARAL(2) = NSEAL ! - ! 3.1 Send coupling fields - ! ---------------------------------- - DO IB_I = 1, IL_NB_SND - CALL OASIS_DEF_VAR (SND_FLD(IB_I)%IL_FIELD_ID & - & , SND_FLD(IB_I)%CL_FIELD_NAME & - & , IL_PART_ID & - & , ILA_VAR_NODIMS & - & , OASIS_OUT & - & , ILA_SHAPE & - & , OASIS_REAL & - & , IL_ERR ) - - IF (IL_ERR /= 0) THEN - CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_DEFINE', 'Problem during oasis_def_var') - ENDIF + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA,JSEA) + + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + ILA_PARAL(JSEA*2+1) = (IY - NHYN -1)*(NX - NHXE - NHXW) + (IX - NHXW - 1) + ILA_PARAL(JSEA*2+2) = 1 + END DO +#ifdef W3_SMC + ELSE IF( GTYPE .EQ. SMCTYPE ) THEN + ! + ! 1.2. SMC grids + ! ---------------------------------- + ALLOCATE(ILA_PARAL(2+NSEAL)) + ! + ! * Define the partition : OASIS POINTS partition + ILA_PARAL(1) = 4 + ! + ! * total number of segments of the global domain + ILA_PARAL(2) = NSEAL + ! + DO JSEA=1, NSEAL + ILA_PARAL(JSEA+2) = IAPROC + (JSEA-1)*NAPROC ENDDO - ! - ! 3.2 Received coupling fields - ! ---------------------------------- - DO IB_I = 1, IL_NB_RCV - CALL OASIS_DEF_VAR (RCV_FLD(IB_I)%IL_FIELD_ID & - & , RCV_FLD(IB_I)%CL_FIELD_NAME & - & , IL_PART_ID & - & , ILA_VAR_NODIMS & - & , OASIS_IN & - & , ILA_SHAPE & - & , OASIS_REAL & - & , IL_ERR ) - ! - IF (IL_ERR /= 0) THEN - CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_DEFINE', 'Problem during oasis_def_var') - ENDIF - ENDDO +#endif + ! + ELSE + ! + ! 1.3. Unstructured grids + ! ---------------------------------- + WRITE(*,*) 'TO BE VERIFIED FOR UNSTRUCTURED GRIDS' + STOP ! - ! 4. End of definition phase - ! ---------------------------------- - CALL OASIS_ENDDEF(IL_ERR) + DO JSEA=1,NSEAL + ILA_PARAL(JSEA*2+1) = (IAPROC-1) + (JSEA-1)*NAPROC + ILA_PARAL(JSEA*2+2) = 1 + END DO + ! + ENDIF + ! + ! 2. Partition definition + ! ---------------------------------- + CALL OASIS_DEF_PARTITION(IL_PART_ID, ILA_PARAL,IL_ERR,NNODES) + IF(IL_ERR /= 0) THEN + CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_DEFINE', 'Problem during oasis_def_partition') + ENDIF + ! + ! 3. Coupling fields declaration + ! ---------------------------------- + ILA_SHAPE(:) = (/1, NSEAL, 1, 1 /) + ! + ILA_VAR_NODIMS(1) = 2 ! rank of fields array + ILA_VAR_NODIMS(2) = 1 ! always 1 with OASIS3-MCT 2.0 + ! + CALL GET_LIST_EXCH_FIELD(NDSO, RCV_FLD, SND_FLD, IL_NB_RCV, IL_NB_SND, RCV_STR, SND_STR) + ! + ! 3.1 Send coupling fields + ! ---------------------------------- + DO IB_I = 1, IL_NB_SND + CALL OASIS_DEF_VAR (SND_FLD(IB_I)%IL_FIELD_ID & + & , SND_FLD(IB_I)%CL_FIELD_NAME & + & , IL_PART_ID & + & , ILA_VAR_NODIMS & + & , OASIS_OUT & + & , ILA_SHAPE & + & , OASIS_REAL & + & , IL_ERR ) IF (IL_ERR /= 0) THEN - CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_DEFINE', 'Problem during oasis_enddef') - ENDIF -! -!/ ------------------------------------------------------------------- / - END SUBROUTINE CPL_OASIS_DEFINE -!/ ------------------------------------------------------------------- / - SUBROUTINE CPL_OASIS_SND(ID_NB, ID_TIME, RDA_FIELD, LD_ACTION) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | FORTRAN 90 | -!/ | Last update : April-2016 | -!/ +-----------------------------------+ -!/ -!/ Jul-2013 : Origination. ( version 4.18 ) -!/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ -! 1. Purpose : -! -! In the model time step loop, each process sends its parts of the coupling field -! -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ID_NB Int. I Number of the field to be send -! ID_TIME Int. I Atmosphere time-step in seconds -! RDA_FIELD Real I Coupling field array to be send -! LD_ACTION Bool. O Action performed -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! SND_FIELDS_TO_ATMOS Subr. W3AGCMMD Send fields to atmos. model -! SND_FIELDS_TO_OCEAN Subr. W3OGCMMD Send fields to ocean model -! SND_FIELDS_TO_ICE Subr. W3IGCMMD Send fields to ice model -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ID_NB ! Number of the field to be send - INTEGER, INTENT(IN) :: ID_TIME ! Atmosphere time-step in seconds - REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: RDA_FIELD ! Coupling field array to be send - LOGICAL, INTENT(OUT) :: LD_ACTION ! Action performed -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IL_INFO ! OASIS3-MCT info argument -!/ -!/ ------------------------------------------------------------------- / -!/ Executable part -!/ - CALL OASIS_PUT ( SND_FLD(ID_NB)%IL_FIELD_ID & - & , ID_TIME & - & , RDA_FIELD & - & , IL_INFO & - & ) + CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_DEFINE', 'Problem during oasis_def_var') + ENDIF + ENDDO + ! + ! 3.2 Received coupling fields + ! ---------------------------------- + DO IB_I = 1, IL_NB_RCV + CALL OASIS_DEF_VAR (RCV_FLD(IB_I)%IL_FIELD_ID & + & , RCV_FLD(IB_I)%CL_FIELD_NAME & + & , IL_PART_ID & + & , ILA_VAR_NODIMS & + & , OASIS_IN & + & , ILA_SHAPE & + & , OASIS_REAL & + & , IL_ERR ) + ! + IF (IL_ERR /= 0) THEN + CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_DEFINE', 'Problem during oasis_def_var') + ENDIF + ENDDO + ! + ! 4. End of definition phase + ! ---------------------------------- + CALL OASIS_ENDDEF(IL_ERR) - LD_ACTION = IL_INFO == OASIS_SENT .OR. IL_INFO == OASIS_TOREST .OR. & - & IL_INFO == OASIS_SENTOUT .OR. IL_INFO == OASIS_TORESTOUT + IF (IL_ERR /= 0) THEN + CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_DEFINE', 'Problem during oasis_enddef') + ENDIF + ! + !/ ------------------------------------------------------------------- / + END SUBROUTINE CPL_OASIS_DEFINE + !/ ------------------------------------------------------------------- / + SUBROUTINE CPL_OASIS_SND(ID_NB, ID_TIME, RDA_FIELD, LD_ACTION) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | FORTRAN 90 | + !/ | Last update : April-2016 | + !/ +-----------------------------------+ + !/ + !/ Jul-2013 : Origination. ( version 4.18 ) + !/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ + ! 1. Purpose : + ! + ! In the model time step loop, each process sends its parts of the coupling field + ! + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ID_NB Int. I Number of the field to be send + ! ID_TIME Int. I Atmosphere time-step in seconds + ! RDA_FIELD Real I Coupling field array to be send + ! LD_ACTION Bool. O Action performed + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! SND_FIELDS_TO_ATMOS Subr. W3AGCMMD Send fields to atmos. model + ! SND_FIELDS_TO_OCEAN Subr. W3OGCMMD Send fields to ocean model + ! SND_FIELDS_TO_ICE Subr. W3IGCMMD Send fields to ice model + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ID_NB ! Number of the field to be send + INTEGER, INTENT(IN) :: ID_TIME ! Atmosphere time-step in seconds + REAL(KIND=8), DIMENSION(:,:), INTENT(IN) :: RDA_FIELD ! Coupling field array to be send + LOGICAL, INTENT(OUT) :: LD_ACTION ! Action performed + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IL_INFO ! OASIS3-MCT info argument + !/ + !/ ------------------------------------------------------------------- / + !/ Executable part + !/ + CALL OASIS_PUT ( SND_FLD(ID_NB)%IL_FIELD_ID & + & , ID_TIME & + & , RDA_FIELD & + & , IL_INFO & + & ) -!/ ------------------------------------------------------------------- / - END SUBROUTINE CPL_OASIS_SND -!/ ------------------------------------------------------------------- / - SUBROUTINE CPL_OASIS_RCV(ID_NB, ID_TIME, RDA_FIELD, LD_ACTION) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | FORTRAN 90 | -!/ | Last update : April-2016 | -!/ +-----------------------------------+ -!/ -!/ Jul-2013 : Origination. ( version 4.18 ) -!/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ -! 1. Purpose : -! -! In the model time step loop, each process receives its parts of the coupling field -! -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ID_NB Int. I Number of the field to be received -! ID_TIME Int. I Ocean time-step in seconds -! RDA_FIELD Real I Coupling field array to be received -! LD_ACTION Bool. O Action performed -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! RCV_FIELDS_FROM_ATMOS Subr. W3AGCMMD Receive fields from atmos. model -! RCV_FIELDS_FROM_OCEAN Subr. W3OGCMMD Receive fields from ocean model -! RCV_FIELDS_FROM_ICE Subr. W3IGCMMD Receive fields from ice model -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ID_NB ! Number of the field to be received - INTEGER, INTENT(IN) :: ID_TIME ! Ocean time-step in seconds - REAL(KIND=8), DIMENSION(:,:), INTENT(OUT) :: RDA_FIELD ! Coupling field array to be received - LOGICAL, INTENT(OUT) :: LD_ACTION ! Action performed -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IL_INFO ! OASIS3-MCT info argument -!/ -!/ ------------------------------------------------------------------- / -!/ Executable part -!/ - CALL OASIS_GET ( RCV_fld(ID_NB)%IL_FIELD_ID & - & , ID_TIME & - & , RDA_FIELD & - & , IL_INFO & - & ) -! - LD_ACTION = IL_INFO == OASIS_RECVD .OR. IL_INFO == OASIS_FROMREST .OR. & - & IL_INFO == OASIS_RECVOUT .OR. IL_INFO == OASIS_FROMRESTOUT -! -!/ ------------------------------------------------------------------- / - END SUBROUTINE CPL_OASIS_RCV -!/ ------------------------------------------------------------------- / - SUBROUTINE CPL_OASIS_FINALIZE -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | FORTRAN 90 | -!/ | Last update : April-2016 | -!/ +-----------------------------------+ -!/ -!/ Jul-2013 : Origination. ( version 4.18 ) -!/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ -! 1. Purpose : -! -! Terminate the coupling -! -! 2. Method : -! 3. Parameters : -! 4. Subroutines used : -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_SHEL Prog. - Main program -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ Executable part -!/ - CALL OASIS_TERMINATE(IL_ERR) -! - IF (IL_ERR /= 0) THEN - CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_FINALIZE', 'Problem during oasis_terminate') - ENDIF -! -!/ ------------------------------------------------------------------- / - END SUBROUTINE CPL_OASIS_FINALIZE -!/ ------------------------------------------------------------------- / - SUBROUTINE GET_LIST_EXCH_FIELD(NDSO, RCV, SND, ID_NB_RCV, ID_NB_SND, RCV_STR, SND_STR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | V. Garnier | -!/ | A.C. Bennis | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ Jul-2013 : Origination. ( version 4.18 ) -!/ Mar-2014 : J. Pianezze (LPO) : Add atmospheric fields ( version 5.07 ) -!/ Apr-2015 : M. Accensi (LPO) : Add fields selection ( version 5.07 ) -!/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ 22-Mar-2021 : Adds extra coupling fields ( version 7.13 ) -!/ -! 1. Purpose : -! -! Provides the list of coupling fields -! -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSO Int. I Id. of the output file -! RCV Type I/O Received variables -! SND Type I/O Send variables -! ID_NB_RCV Int. I/O Number of received variables -! ID_NB_SND Int. I/O Number of send variables -! RCV_STR Char. I Name of the received variables -! SND_STR Char I Name of the send variables -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRSPLIT Subr. W3SERVMD Splits string into words -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! CPL_OASIS_DEFINE Subr. W3OACPMD Partition definition -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks : -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3SERVMD, ONLY: STRSPLIT -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - TYPE(CPL_FIELD), DIMENSION(IP_MAXFLD), INTENT (INOUT) :: RCV, SND - INTEGER, INTENT(INOUT) :: ID_NB_RCV, ID_NB_SND - INTEGER, INTENT(IN) :: NDSO - CHARACTER(LEN=1024), INTENT(IN) :: RCV_STR, SND_STR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER(LEN=100) :: OUT_NAMES(50), TESTSTR - INTEGER :: IOUT -!/ -!/ ------------------------------------------------------------------- / -!/ Executable part -!/ - ! - ! 1. Coupling fields received by WW3 - ! ---------------------------------- - ID_NB_RCV = 0 - ! - OUT_NAMES(:)='' - CALL STRSPLIT(RCV_STR,OUT_NAMES) - IOUT=0 - DO WHILE (LEN_TRIM(OUT_NAMES(IOUT+1)).NE.0) - TESTSTR=OUT_NAMES(IOUT+1) - SELECT CASE(TRIM(TESTSTR(1:6))) - ! -! -! OCEAM MODEL VARIABLES -! + LD_ACTION = IL_INFO == OASIS_SENT .OR. IL_INFO == OASIS_TOREST .OR. & + & IL_INFO == OASIS_SENTOUT .OR. IL_INFO == OASIS_TORESTOUT + + !/ ------------------------------------------------------------------- / + END SUBROUTINE CPL_OASIS_SND + !/ ------------------------------------------------------------------- / + SUBROUTINE CPL_OASIS_RCV(ID_NB, ID_TIME, RDA_FIELD, LD_ACTION) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | FORTRAN 90 | + !/ | Last update : April-2016 | + !/ +-----------------------------------+ + !/ + !/ Jul-2013 : Origination. ( version 4.18 ) + !/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ + ! 1. Purpose : + ! + ! In the model time step loop, each process receives its parts of the coupling field + ! + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ID_NB Int. I Number of the field to be received + ! ID_TIME Int. I Ocean time-step in seconds + ! RDA_FIELD Real I Coupling field array to be received + ! LD_ACTION Bool. O Action performed + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! RCV_FIELDS_FROM_ATMOS Subr. W3AGCMMD Receive fields from atmos. model + ! RCV_FIELDS_FROM_OCEAN Subr. W3OGCMMD Receive fields from ocean model + ! RCV_FIELDS_FROM_ICE Subr. W3IGCMMD Receive fields from ice model + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ID_NB ! Number of the field to be received + INTEGER, INTENT(IN) :: ID_TIME ! Ocean time-step in seconds + REAL(KIND=8), DIMENSION(:,:), INTENT(OUT) :: RDA_FIELD ! Coupling field array to be received + LOGICAL, INTENT(OUT) :: LD_ACTION ! Action performed + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IL_INFO ! OASIS3-MCT info argument + !/ + !/ ------------------------------------------------------------------- / + !/ Executable part + !/ + CALL OASIS_GET ( RCV_fld(ID_NB)%IL_FIELD_ID & + & , ID_TIME & + & , RDA_FIELD & + & , IL_INFO & + & ) + ! + LD_ACTION = IL_INFO == OASIS_RECVD .OR. IL_INFO == OASIS_FROMREST .OR. & + & IL_INFO == OASIS_RECVOUT .OR. IL_INFO == OASIS_FROMRESTOUT + ! + !/ ------------------------------------------------------------------- / + END SUBROUTINE CPL_OASIS_RCV + !/ ------------------------------------------------------------------- / + SUBROUTINE CPL_OASIS_FINALIZE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | FORTRAN 90 | + !/ | Last update : April-2016 | + !/ +-----------------------------------+ + !/ + !/ Jul-2013 : Origination. ( version 4.18 ) + !/ April-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ + ! 1. Purpose : + ! + ! Terminate the coupling + ! + ! 2. Method : + ! 3. Parameters : + ! 4. Subroutines used : + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_SHEL Prog. - Main program + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ Executable part + !/ + CALL OASIS_TERMINATE(IL_ERR) + ! + IF (IL_ERR /= 0) THEN + CALL OASIS_ABORT(IL_COMPID, 'CPL_OASIS_FINALIZE', 'Problem during oasis_terminate') + ENDIF + ! + !/ ------------------------------------------------------------------- / + END SUBROUTINE CPL_OASIS_FINALIZE + !/ ------------------------------------------------------------------- / + SUBROUTINE GET_LIST_EXCH_FIELD(NDSO, RCV, SND, ID_NB_RCV, ID_NB_SND, RCV_STR, SND_STR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | V. Garnier | + !/ | A.C. Bennis | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ Jul-2013 : Origination. ( version 4.18 ) + !/ Mar-2014 : J. Pianezze (LPO) : Add atmospheric fields ( version 5.07 ) + !/ Apr-2015 : M. Accensi (LPO) : Add fields selection ( version 5.07 ) + !/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ 22-Mar-2021 : Adds extra coupling fields ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Provides the list of coupling fields + ! + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSO Int. I Id. of the output file + ! RCV Type I/O Received variables + ! SND Type I/O Send variables + ! ID_NB_RCV Int. I/O Number of received variables + ! ID_NB_SND Int. I/O Number of send variables + ! RCV_STR Char. I Name of the received variables + ! SND_STR Char I Name of the send variables + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRSPLIT Subr. W3SERVMD Splits string into words + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! CPL_OASIS_DEFINE Subr. W3OACPMD Partition definition + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks : + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3SERVMD, ONLY: STRSPLIT + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + TYPE(CPL_FIELD), DIMENSION(IP_MAXFLD), INTENT (INOUT) :: RCV, SND + INTEGER, INTENT(INOUT) :: ID_NB_RCV, ID_NB_SND + INTEGER, INTENT(IN) :: NDSO + CHARACTER(LEN=1024), INTENT(IN) :: RCV_STR, SND_STR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER(LEN=100) :: OUT_NAMES(50), TESTSTR + INTEGER :: IOUT + !/ + !/ ------------------------------------------------------------------- / + !/ Executable part + !/ + ! + ! 1. Coupling fields received by WW3 + ! ---------------------------------- + ID_NB_RCV = 0 + ! + OUT_NAMES(:)='' + CALL STRSPLIT(RCV_STR,OUT_NAMES) + IOUT=0 + DO WHILE (LEN_TRIM(OUT_NAMES(IOUT+1)).NE.0) + TESTSTR=OUT_NAMES(IOUT+1) + SELECT CASE(TRIM(TESTSTR(1:6))) + ! + ! + ! OCEAN MODEL VARIABLES + ! #ifdef W3_OASOCM CASE('DRY') - ! wet-drying at the middle of the cell - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDH' -#endif -! -#ifdef W3_OASOCM - ! wet-drying at u-location - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDU' -#endif -! -#ifdef W3_OASOCM - ! wet-drying at v-location - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDV' -#endif -! -#ifdef W3_OASOCM + ! wet-drying at the middle of the cell + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDH' + ! + ! wet-drying at u-location + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDU' + ! + ! wet-drying at v-location + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDV' + ! CASE('SSH') - ! ssh : sea surface height (m) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__SSH' -#endif -! -#ifdef W3_OASOCM + ! ssh : sea surface height (m) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__SSH' + ! CASE('CUR') - ! uz : sea surface zonal currents (m.s-1) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OSSU' -#endif -! -#ifdef W3_OASOCM - ! vz : sea surface meridional currents (m.s-1) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OSSV' + ! uz : sea surface zonal currents (m.s-1) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OSSU' + ! + ! vz : sea surface meridional currents (m.s-1) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OSSV' #endif -! + ! -! -! ATMOSPHERE MODEL VARIABLES -! + ! + ! ATMOSPHERE MODEL VARIABLES + ! #ifdef W3_OASACM CASE('WND') - ! U10 : 10m u-wind speed (m.s-1) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__U10' -#endif -! -#ifdef W3_OASACM - ! V10 : 10m v-wind speed (m.s-1) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__V10' -#endif -! -#ifdef W3_OASACM + ! U10 : 10m u-wind speed (m.s-1) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__U10' + ! + ! V10 : 10m v-wind speed (m.s-1) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__V10' + ! CASE('TAU') - ! UTAUA : u-momentum (m2.s-2) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_UTAU' -#endif -! -#ifdef W3_OASACM - ! V10 : v-momentum speed (m2.s-2) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_VTAU' -#endif -! -#ifdef W3_OASACM + ! UTAUA : u-momentum (m2.s-2) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_UTAU' + ! + ! V10 : v-momentum speed (m2.s-2) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_VTAU' + ! CASE('RHO') - ! rhoa : air density (kg.m-3) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_RHOA' + ! rhoa : air density (kg.m-3) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_RHOA' #endif -! + ! -! -! ICE MODEL VARIABLES -! + ! + ! ICE MODEL VARIABLES + ! #ifdef W3_OASICM CASE('IC1') - ! IC1 : ice thickness (m) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__IC1' -#endif -! -#ifdef W3_OASICM + ! IC1 : ice thickness (m) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__IC1' + ! CASE('IC5') - ! ICEF : ice floe diameters (m) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__IC5' -#endif -! -#ifdef W3_OASICM + ! ICEF : ice floe diameters (m) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__IC5' + ! CASE('ICE') - ! ICE : ice concentration (n.d) - ID_NB_RCV=ID_NB_RCV+1 - RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__ICE' + ! ICE : ice concentration (n.d) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__ICE' #endif -! + ! - CASE DEFAULT - WRITE (NDSO,1001) TRIM(TESTSTR(1:6)) - END SELECT - IOUT=IOUT+1 - END DO - ! - ! 2. Coupling fields sent by WW3 - ! ---------------------------------- - ID_NB_SND = 0 - ! - OUT_NAMES(:)='' - CALL STRSPLIT(SND_STR,OUT_NAMES) - IOUT=0 - DO WHILE (LEN_TRIM(OUT_NAMES(IOUT+1)).NE.0) - TESTSTR=OUT_NAMES(IOUT+1) - SELECT CASE(TRIM(TESTSTR(1:6))) - ! -! -! OCEAM MODEL VARIABLES -! -#ifdef W3_OASOCM - CASE('OHS') - ! Significant wave height (m) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3__OHS' -#endif -! -#ifdef W3_OASOCM - CASE('DRY') - ! mask to manage wet-drying - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ODRY' -#endif -! -#ifdef W3_OASOCM - CASE('T0M1') - ! T0M1 / wave_t0m1 : mean period (s) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_T0M1' -#endif -! -#ifdef W3_OASOCM - CASE('T01') - ! T01 / wave_t01 : mean period (s) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3__T01' -#endif -! -#ifdef W3_OASOCM - CASE('DIR') - ! THM / wave_thm : cosinus of mean direction (n/a) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_CDIR' -#endif -! -#ifdef W3_OASOCM - ! THM / wave_thm : sinus of mean direction (n/a) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_SDIR' -#endif -! -#ifdef W3_OASOCM - CASE('THM') - ! THM / wave_thm : mean direction (n/a) - ! exchange the mean direction instead of cos/sin projection - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3__DIR' -#endif -! -#ifdef W3_OASOCM - CASE('BHD') - ! BHD / wave_bhd : wave-induced Bernoulli head pressure (bhd in N.m-1) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3__BHD' -#endif -! -#ifdef W3_OASOCM - CASE('TWO') - ! tauox / wave_tauox : x-component of the wave-ocean momentum flux (tauox in m2.s-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWOX' -#endif -! -#ifdef W3_OASOCM - ! tauoy / wave_tauoy : y-component of the wave-ocean momentum flux (tauox in m2.s-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWOY' -#endif -! -#ifdef W3_OASOCM - CASE('TOC') - ! tauocx / wave_tauocx : x-component of the total wave-ocean momentum flux (tauocx in m2.s-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TOCX' -#endif -! -#ifdef W3_OASOCM - ! tauocy / wave_tauocy : y-component of the total wave-ocean momentum flux (tauocx in m2.s-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TOCY' -#endif -! -#ifdef W3_OASOCM - CASE('FOC') - ! phioc / wave_phioc : Wave-to-ocean TKE flux (phioc in W.m-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FOC' -#endif -! -#ifdef W3_OASOCM - CASE('TBB') - ! Momentum flux due to bottom friction, u component (m2.s-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TBBX' -#endif -! -#ifdef W3_OASOCM - ! Momentum flux due to bottom friction, v component (m2.s-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TBBY' -#endif -! -#ifdef W3_OASOCM - CASE('FBB') - ! phibbl / wave_phibbl : Energy flux due to bottom friction (phioc in W.m-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FBB' -#endif -! -#ifdef W3_OASOCM - CASE('UBR') - ! uba / wave_ubrx : x component of the rms amplitude of orbital velocity of the waves (m/s) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_UBRX' -#endif -! -#ifdef W3_OASOCM - ! uba / wave_ubry : y component of the rms amplitude of orbital velocity of the waves (m/s) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_UBRY' -#endif -! -#ifdef W3_OASOCM - CASE('TAW') - ! tauwix / wave_tauwix : Net wave-supported stress, u component (tauwix in m2.s-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TAWX' -#endif -! -#ifdef W3_OASOCM - ! tauwiy / wave_tauwiy : ! Net wave-supported stress, v component (tauwix in m2.s-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TAWY' -#endif -! -#ifdef W3_OASOCM - CASE('LM') - ! wlm / wave_wlm : mean length wave (m) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3___LM' -#endif -! -#ifdef W3_OASOCM - CASE('WNM') - ! wnmean / wave_wnmean : mean wave number (m-1) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3__WNM' -#endif -! -#ifdef W3_OASOCM - CASE('TUS') - ! Volume transport associated to Stokes drift, u component (m2.s-1) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TUSX' -#endif -! -#ifdef W3_OASOCM - ! Volume transport associated to Stokes drift, v component (m2.s-1) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TUSY' -#endif -! -#ifdef W3_OASOCM - CASE('USS') - ! Surface Stokes drift, u component (m.s-1) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_USSX' -#endif -! + CASE DEFAULT + WRITE (NDSO,1001) TRIM(TESTSTR(1:6)) + END SELECT + IOUT=IOUT+1 + END DO + ! + ! 2. Coupling fields sent by WW3 + ! ---------------------------------- + ID_NB_SND = 0 + ! + OUT_NAMES(:)='' + CALL STRSPLIT(SND_STR,OUT_NAMES) + IOUT=0 + DO WHILE (LEN_TRIM(OUT_NAMES(IOUT+1)).NE.0) + TESTSTR=OUT_NAMES(IOUT+1) + SELECT CASE(TRIM(TESTSTR(1:6))) + ! + ! + ! OCEAN MODEL VARIABLES + ! #ifdef W3_OASOCM - ! Surface Stokes drift, v component (m.s-1) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_USSY' -#endif -! -#ifdef W3_OASOCM - CASE('OCHA') - ! Charnock Coefficient (-) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_OCHA' + CASE('OHS') + ! Significant wave height (m) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__OHS' + ! + CASE('DRY') + ! mask to manage wet-drying + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ODRY' + ! + CASE('T0M1') + ! T0M1 / wave_t0m1 : mean period (s) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_T0M1' + ! + CASE('T01') + ! T01 / wave_t01 : mean period (s) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__T01' + ! + CASE('DIR') + ! THM / wave_thm : cosinus of mean direction (n/a) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_CDIR' + ! + ! THM / wave_thm : sinus of mean direction (n/a) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_SDIR' + ! + CASE('THM') + ! THM / wave_thm : mean direction (n/a) + ! exchange the mean direction instead of cos/sin projection + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__DIR' + ! + CASE('BHD') + ! BHD / wave_bhd : wave-induced Bernoulli head pressure (bhd in N.m-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__BHD' + ! + CASE('TWO') + ! tauox / wave_tauox : x-component of the wave-ocean momentum flux (tauox in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWOX' + ! + ! tauoy / wave_tauoy : y-component of the wave-ocean momentum flux (tauox in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWOY' + ! + CASE('TOC') + ! tauocx / wave_tauocx : x-component of the total wave-ocean momentum flux (tauocx in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TOCX' + ! + ! tauocy / wave_tauocy : y-component of the total wave-ocean momentum flux (tauocx in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TOCY' + ! + CASE('FOC') + ! phioc / wave_phioc : Wave-to-ocean TKE flux (phioc in W.m-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FOC' + ! + CASE('TBB') + ! Momentum flux due to bottom friction, u component (m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TBBX' + ! + ! Momentum flux due to bottom friction, v component (m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TBBY' + ! + CASE('FBB') + ! phibbl / wave_phibbl : Energy flux due to bottom friction (phioc in W.m-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FBB' + ! + CASE('UBR') + ! uba / wave_ubrx : x component of the rms amplitude of orbital velocity of the waves (m/s) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_UBRX' + ! + ! uba / wave_ubry : y component of the rms amplitude of orbital velocity of the waves (m/s) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_UBRY' + ! + CASE('TAW') + ! tauwix / wave_tauwix : Net wave-supported stress, u component (tauwix in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TAWX' + ! + ! tauwiy / wave_tauwiy : ! Net wave-supported stress, v component (tauwix in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TAWY' + ! + CASE('LM') + ! wlm / wave_wlm : mean length wave (m) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3___LM' + ! + CASE('WNM') + ! wnmean / wave_wnmean : mean wave number (m-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__WNM' + ! + CASE('TUS') + ! Volume transport associated to Stokes drift, u component (m2.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TUSX' + ! + ! Volume transport associated to Stokes drift, v component (m2.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TUSY' + ! + CASE('USS') + ! Surface Stokes drift, u component (m.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_USSX' + ! + ! Surface Stokes drift, v component (m.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_USSY' + ! + CASE('OCHA') + ! Charnock Coefficient (-) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_OCHA' #endif -! -! ATMOSPHERE MODEL VARIABLES -! -#ifdef W3_OASACM - CASE('AHS') - ! Significant wave height (m) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3__AHS' -#endif -! -#ifdef W3_OASACM - CASE('CUR') - ! Ocean sea surface current (m.s-1) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_WSSU' -#endif -! -#ifdef W3_OASACM - ! Ocean sea surface current (m.s-1) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_WSSV' -#endif -! -#ifdef W3_OASACM - CASE('ACHA') - ! Charnock Coefficient (-) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ACHA' -#endif -! + ! + ! ATMOSPHERE MODEL VARIABLES + ! #ifdef W3_OASACM - CASE('FP') - ! Peak frequency (s-1) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3___FP' -#endif -! -#ifdef W3_OASACM - CASE('TP') - ! Peak period (s) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3___TP' -#endif -! -#ifdef W3_OASACM - CASE('FWS') - ! Wind_sea_mean_period_T0M1 (s) - ID_NB_SND=ID_NB_SND+1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FWS' + CASE('AHS') + ! Significant wave height (m) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__AHS' + ! + CASE('CUR') + ! Ocean sea surface current (m.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_WSSU' + ! + ! Ocean sea surface current (m.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_WSSV' + ! + CASE('ACHA') + ! Charnock Coefficient (-) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ACHA' + ! + CASE('FP') + ! Peak frequency (s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3___FP' + ! + CASE('TP') + ! Peak period (s) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3___TP' + ! + CASE('FWS') + ! Wind_sea_mean_period_T0M1 (s) + ID_NB_SND=ID_NB_SND+1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FWS' #endif -! + ! -! -! ICE MODEL VARIABLES -! -#ifdef W3_OASICM - CASE('IC5') - ! Ice floe diameters (m) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ICEF' -#endif -! + ! + ! ICE MODEL VARIABLES + ! #ifdef W3_OASICM - CASE('TWI') - ! TWIX : x stress to ice , u component (twix in m2.s-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWIX' -#endif -! -#ifdef W3_OASICM - ! TWIY : y stress to ice , v component (twiy in m2.s-2) - ID_NB_SND = ID_NB_SND +1 - SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWIY' + CASE('IC5') + ! Ice floe diameters (m) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ICEF' + ! + CASE('TWI') + ! TWIX : x stress to ice , u component (twix in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWIX' + ! TWIY : y stress to ice , v component (twiy in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWIY' #endif - ! - CASE DEFAULT - WRITE (NDSO,1002) TRIM(TESTSTR(1:6)) - END SELECT - IOUT=IOUT+1 - END DO -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III WARNING IN W3OACPMD : '/ & - ' REQUESTED COUPLING RECEIVED FIELD ',A,' WAS NOT RECOGNIZED.'/) -! - 1002 FORMAT (/' *** WAVEWATCH III WARNING IN W3OACPMD : '/ & - ' REQUESTED COUPLING SENT FIELD ',A,' WAS NOT RECOGNIZED.'/) -!/ -!/ ------------------------------------------------------------------- / - END SUBROUTINE GET_LIST_EXCH_FIELD -!/ ------------------------------------------------------------------- / -!/ - END MODULE W3OACPMD + ! + CASE DEFAULT + WRITE (NDSO,1002) TRIM(TESTSTR(1:6)) + END SELECT + IOUT=IOUT+1 + END DO + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III WARNING IN W3OACPMD : '/ & + ' REQUESTED COUPLING RECEIVED FIELD ',A,' WAS NOT RECOGNIZED.'/) + ! +1002 FORMAT (/' *** WAVEWATCH III WARNING IN W3OACPMD : '/ & + ' REQUESTED COUPLING SENT FIELD ',A,' WAS NOT RECOGNIZED.'/) + !/ + !/ ------------------------------------------------------------------- / + END SUBROUTINE GET_LIST_EXCH_FIELD + !/ ------------------------------------------------------------------- / + !/ +END MODULE W3OACPMD !/ !/ ------------------------------------------------------------------- / diff --git a/model/src/w3odatmd.F90 b/model/src/w3odatmd.F90 index c6da30d71..be6082a41 100644 --- a/model/src/w3odatmd.F90 +++ b/model/src/w3odatmd.F90 @@ -1,1886 +1,1874 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3ODATMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 13-Dec-2004 : Origination. ( version 3.06 ) -!/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) -!/ 29-Sep-2005 : Second storage for input bound. sp. ( version 3.08 ) -!/ Add FILED for the dump of data. -!/ 26-Jun-2006 : Add output type 6, wave field sep. ( version 3.09 ) -!/ Wiring of code only. -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 24-Jul-2006 : Adding unified point output storage.( version 3.10 ) -!/ 25-Jul-2006 : Originating grid ID for points. ( version 3.10 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 30-Oct-2006 : Add pars for partitioning. ( version 3.10 ) -!/ 26-Mar-2007 : Add pars for partitioning. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 14-Jul-2010 : Fix VAAUX declaration bug. ( version 3.14.2 ) -!/ 27-Jul-2010 : Add NKI, NTHI, XFRI, FR1I, TH1I. ( version 3.14.3 ) -!/ 08-Nov-2010 : Implementing unstructured grids ( version 3.14.4 ) -!/ (A. Roland and F. Ardhuin) -!/ 18-Dec-2012 : New 2D field output structure, ( version 4.11 ) -!/ reducing memory footprint for fields. -!/ 19-Dec-2012 : Move NOSWLL to data structure. ( version 4.11 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 27-Aug-2015 : Adding interpolated ICEF (mean ice ( version 5.10 ) -!/ floe diameter), ICEH (ice thickness) -!/ and ICE (ice concentration). -!/ 01-Mar-2018 : Include UNDEF from constants.ftn to ( version 6.02 ) -!/ avoid circular referencing in w3servmd -!/ 05-Jun-2018 : Add SETUP ( version 6.04 ) -!/ 27-Jul-2018 : Added PTMETH and PTFCUT variables ( version 6.05 ) -!/ for alternative partition methods. -!/ (C. Bunney, UKMO) -!/ 25-Sep-2020 : Flags for coupling restart ( version 7.10 ) -!/ 15-Jan-2020 : Added TP based on existing FP ( version 7.12 ) -!/ internal fields. (C. Bunney, UKMO) -!/ 22-Mar-2021 : Add extra coupling variables ( version 7.13 ) -!/ 07-Jun-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.13 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Define data structures to set up wave model grids and aliases -! to use individual grids transparently. Also includes subroutines -! to manage data structure and pointing to individual models. -! This module considers the parameters required for model output. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NOUTP Int. Public Number of models in array dim. -! IOUTP Int. Public Selected model for output, init. at -1. -! IOSTYP Int. Public Output data server type. -! NOGRP I.P. Public Number of output field groups -! NGRPP I.P. Public Max numb of parameters per output group -! NOGE I.P. Public Number of output group elements -! NOTYPE I.P. Public Number of output types -! NOEXTR I.P. Public Number of extra (user available) -! output fields. -! DIMP I.P. Public Number of parameters in partition -! output group -! IDOUT C.A. Public ID strings for output fields. -! FNMPRE Char Public File name preamble. -! UNDEF Real Public Value for undefined parameters in -! gridded output fields. -! UNIPTS Log. Public Flag for unified point output (output -! to single file). -! UPPROC Log. Public FLag for dedicated point output proc. -! OUTPUT TYPE Public Data structure defining output. -! OUTPTS GRID Public Array of output for models. -! ---------------------------------------------------------------- -! -! Elements of OUTPUT are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NDSO Int. Public General output unit number ("log -! file"). -! NDSE Int. Public Error output unit number. -! NDST Int. Public Test output unit number. -! SCREEN Int. Public Unit for 'direct' output. -! NTPROC Int. Public Number of processors. -! NAPROC Int. Public Number of processors for computation. -! IAPROC Int. Public Actual processor number (base 1), -! NAPLOG Int. Public Proc. dealing with log output. -! NAPOUT Int. Public Proc. dealing with standard output. -! NAPERR Int. Public Proc. dealing with error output. -! NAPFLD Int. Public Proc. dealing with raw field output. -! NAPPNT Int. Public Proc. dealing with raw point output. -! NAPTRK Int. Public Proc. dealing with track output. -! NAPRST Int. Public Proc. dealing with restart output. -! NAPBPT Int. Public Proc. dealing with boundary output. -! NAPPRT Int. Public Proc. dealing with partition output. -! NOSWLL I.P. Public Number of swell fields from part. -! to be used in field output. -! TOSNL5 I.A. Public Times for point ouput (!/NL5) -! TOFRST I.A. Public Times for first output. -! TONEXT I.A. Public Times for next output. -! TOLAST I.A. Public Times for last output. -! TBPI0 I.A Public Time of first set of input boundary -! spectra. -! TBPIN I.A Public Id. second set. -! NDS I.A. Public Data set numbers (see W3INIT). -! DTOUT R.A. Public Output intervals. -! FLOUT L.A. Public Output flags. -! OUT1 TYPE Public Data structure of type OTYPE1 with -! suppl. data for output type 1. -! OUT2 TYPE Public Data structure of type OTYPE2 with -! suppl. data for output type 2. -! OUT3 TYPE Public Data structure of type OTYPE3 with -! suppl. data for output type 3. -! OUT4 TYPE Public Data structure of type OTYPE4 with -! suppl. data for output type 4. -! OUT5 TYPE Public Data structure of type OTYPE5 with -! suppl. data for output type 5. -! OUT6 TYPE Public Data structure of type OTYPE6 with -! suppl. data for output type 6. -! OFILES I.A. Public Output in one or several files. -! ---------------------------------------------------------------- -! -! Elements of OUT1 are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! IPASS1 Int. Public Pass counter for file management, -! renamed to IPASS in routine. -! WRITE1 Int. Public Write flag for file management, -! renamed to WRITE in routine. -! NRQGO(2) Int. Public Number of MPI handles W3IOGO. -! IRQGO I.A. Public Array with MPI handles W3IOGO. -! FLOGRD L.A. Public FLags for output fields. -! FLOGR2 L.A. Public FLags for coupling fields. -! FLOGRR L.A. Public FLags for optional coupling restart (2D). -! FLOGD L.A. Public Flags for output groups -! FLOG2 L.A. Public Flags for coupling groups -! FLOGR L.A. Public FLags for optional coupling restart (1D). -! ---------------------------------------------------------------- -! -! Elements of OUT2 are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! IPASS2 Int. Public Pass counter for file management, -! renamed to IPASS in routine. -! NOPTS Int. Public Number of output points. -! NRQPO(2) Int. Public Number of MPI handles IRQPOn. (!/MPI) -! IPTINT I.A. Public (I,J)-indices of enclosing cell corner points -! IL I.A. Public Number of land points in interpola- -! tion box for output point. -! IW I.A. Public Id. water. -! II I.A. Public Id. ice. -! IRQPO1/2 I.A. Public Array with MPI handles. (!/MPI) -! PTLOC R.A. Public Name of output locations. -! PTIFAC R.A. Public Interpolation weights. -! DPO R.A. Public Interpolated depths. -! WAO R.A. Public Interpolated wind speeds. -! WDO R.A. Public Interpolated wind directions. -! ASO R.A. Public Interpolated air-sea temp. diff. -! TAUAO R.A. Public Interpolated atm. stresses. -! TAUDO R.A. Public Interpolated atm. stres directions. -! DAIRO R.A. Public Interpolated rho atmosphere. -! CAO R.A. Public Interpolated current speeds. -! CDO R.A. Public Interpolated current directions. -! SPCO R.A. Public Output spectra. -! ICEO R.A. Public Interpolated ice concentration. -! ICEHO R.A. Public Interpolated ice thickness. -! ICEFO R.A. Public Interpolated ice floe. -! PTNME C.A. Public Output locations. -! GRDID C.A. Public Originating grid ID. -! O2INIT Log. Public Flag for array initialization. -! O2IRQI Log. Public Flag for array initialization. -! ---------------------------------------------------------------- -! -! Elements of OUT3 are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! IPASS3 Int. Public Pass counter for file management, -! renamed to IPASS in routine. -! IT0PNT Int. Public Base tag number of MPI communication. -! IT0TRK Int. Public Base tag number of MPI communication. -! IT0PRT Int. Public Base tag number of MPI communication. -! NRQTR Int. Public Number of handles in IRQTR. -! IRQTR I.A. Public Array with MPI handles. -! O3INIT Log. Public Flag for array initialization. -! STOP Log. Public Flag for end of output. -! MASKn L.A. Public Mask arrays for internal use. -! ---------------------------------------------------------------- -! -! Elements of OUT4 are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! IFILE4 Int. Public File number for output files. -! NBLKRS Int. Public Number of blocks in communication of -! spectra. -! RSBLKS Int. Public Corresponding block size. -! NRQSR Int. Public Number of MPI handles. -! IRQRS I.A. Public Array with MPI handles. -! IRQRSS I.A. Public Array with MPI handles. -! VAAUX R.A. Public Aux. spectra storage. -! ---------------------------------------------------------------- -! -! Elements of OUT5 are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NBI(2) Int. Public Number of input bound. points. -! NFBPO Int. Public Number of files for output bound. data. -! NRQBP(2) Int. Public Number of MPI handles. -! NKI,NTHI Int. Public Size of input spectra -! NBO(2) I.A. Public Number of output bound. pts. per file. -! NDSL I.A. Public Array with unit numbers. -! IPBPI I.A. Public Interpolation data input b.p. -! ISBPI I.A. Public Sea point counters for input b.p. -! IRQBP1/2 I.A. Public Array with MPI handles. -! XFRI, FR1I, TH1I -! Real Public Definition of input spectra. -! X/YBPI R.A. Public Location of input boundary points. -! RDBPI R.A. Public Interpolation factors input b.p. -! ABPI0/N R.A. Public Storage of spectra from which to -! interpolate b.d. -! BBPI0/N R.A. Public idem, secondary storage. -! ABPOS R.A. Public Temporarily storage for output b.d. -! IPBPO, ISBPO, X/YBPO, RDBPO -! Misc. Public Id. for output b.p. -! FLBPI Log. Public Flag for input of boundary data. -! FLBPO Log. Public Flag for output of boundary data. -! FILER/W/D Log. Public Read/write flags for file management. -! SPCONV Log. Public Flag for change of spectral res. -! O5INIn Log. Public Flag for array initializations. -! ---------------------------------------------------------------- -! -! Elements of OUT6 are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! IPASS6 Int. Public Pass counter for file management, -! renamed to IPASS in routine. -! IHMAX Int. Public Number of discrete spectral levels. -! IX0/N/S Int. Public First-last-step IX counters. -! IY0/N/S Int. Public Idem IY counters. -! HSPMIN Real Public Minimum significant height per part. -! WSMULT Real Public Multiplier for wind sea boundary. -! WSCUT Real Public Cut-off wind factor for wind seas. -! ICPRT I.A. Public Counters for partitions. -! DTPRT R.A. Public Data from partitions. -! FLCOMB Log. Public Flag for combining wind seas. -! FLFORM Log. Public Flag for (un)formatted output -! O6INIT Log. Public Flag for array initializations. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3NOUT Subr. Public Set number of grids. -! W3DMO2 Subr. Public Allocate arrays output type 2. -! W3DMO3 Subr. Public Allocate arrays output type 3. -! W3DMO5 Subr. Public Allocate arrays output type 5. -! W3SETO Subr. Public Point to selected grid / model. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to proper model grid. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - The number of grids is taken from W3GDATMD, and needs to be -! set first with W3DIMG. -! -! 6. Switches : -! -! !/MPI MPI specific calls. -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY : UNDEF +MODULE W3ODATMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 13-Dec-2004 : Origination. ( version 3.06 ) + !/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) + !/ 29-Sep-2005 : Second storage for input bound. sp. ( version 3.08 ) + !/ Add FILED for the dump of data. + !/ 26-Jun-2006 : Add output type 6, wave field sep. ( version 3.09 ) + !/ Wiring of code only. + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 24-Jul-2006 : Adding unified point output storage.( version 3.10 ) + !/ 25-Jul-2006 : Originating grid ID for points. ( version 3.10 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 30-Oct-2006 : Add pars for partitioning. ( version 3.10 ) + !/ 26-Mar-2007 : Add pars for partitioning. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 14-Jul-2010 : Fix VAAUX declaration bug. ( version 3.14.2 ) + !/ 27-Jul-2010 : Add NKI, NTHI, XFRI, FR1I, TH1I. ( version 3.14.3 ) + !/ 08-Nov-2010 : Implementing unstructured grids ( version 3.14.4 ) + !/ (A. Roland and F. Ardhuin) + !/ 18-Dec-2012 : New 2D field output structure, ( version 4.11 ) + !/ reducing memory footprint for fields. + !/ 19-Dec-2012 : Move NOSWLL to data structure. ( version 4.11 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 27-Aug-2015 : Adding interpolated ICEF (mean ice ( version 5.10 ) + !/ floe diameter), ICEH (ice thickness) + !/ and ICE (ice concentration). + !/ 01-Mar-2018 : Include UNDEF from constants.ftn to ( version 6.02 ) + !/ avoid circular referencing in w3servmd + !/ 05-Jun-2018 : Add SETUP ( version 6.04 ) + !/ 27-Jul-2018 : Added PTMETH and PTFCUT variables ( version 6.05 ) + !/ for alternative partition methods. + !/ (C. Bunney, UKMO) + !/ 25-Sep-2020 : Flags for coupling restart ( version 7.10 ) + !/ 15-Jan-2020 : Added TP based on existing FP ( version 7.12 ) + !/ internal fields. (C. Bunney, UKMO) + !/ 22-Mar-2021 : Add extra coupling variables ( version 7.13 ) + !/ 07-Jun-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.13 ) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Define data structures to set up wave model grids and aliases + ! to use individual grids transparently. Also includes subroutines + ! to manage data structure and pointing to individual models. + ! This module considers the parameters required for model output. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NOUTP Int. Public Number of models in array dim. + ! IOUTP Int. Public Selected model for output, init. at -1. + ! IOSTYP Int. Public Output data server type. + ! NOGRP I.P. Public Number of output field groups + ! NGRPP I.P. Public Max numb of parameters per output group + ! NOGE I.P. Public Number of output group elements + ! NOTYPE I.P. Public Number of output types + ! NOEXTR I.P. Public Number of extra (user available) + ! output fields. + ! DIMP I.P. Public Number of parameters in partition + ! output group + ! IDOUT C.A. Public ID strings for output fields. + ! FNMPRE Char Public File name preamble. + ! UNDEF Real Public Value for undefined parameters in + ! gridded output fields. + ! UNIPTS Log. Public Flag for unified point output (output + ! to single file). + ! UPPROC Log. Public FLag for dedicated point output proc. + ! OUTPUT TYPE Public Data structure defining output. + ! OUTPTS GRID Public Array of output for models. + ! ---------------------------------------------------------------- + ! + ! Elements of OUTPUT are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NDSO Int. Public General output unit number ("log + ! file"). + ! NDSE Int. Public Error output unit number. + ! NDST Int. Public Test output unit number. + ! SCREEN Int. Public Unit for 'direct' output. + ! NTPROC Int. Public Number of processors. + ! NAPROC Int. Public Number of processors for computation. + ! IAPROC Int. Public Actual processor number (base 1), + ! NAPLOG Int. Public Proc. dealing with log output. + ! NAPOUT Int. Public Proc. dealing with standard output. + ! NAPERR Int. Public Proc. dealing with error output. + ! NAPFLD Int. Public Proc. dealing with raw field output. + ! NAPPNT Int. Public Proc. dealing with raw point output. + ! NAPTRK Int. Public Proc. dealing with track output. + ! NAPRST Int. Public Proc. dealing with restart output. + ! NAPBPT Int. Public Proc. dealing with boundary output. + ! NAPPRT Int. Public Proc. dealing with partition output. + ! NOSWLL I.P. Public Number of swell fields from part. + ! to be used in field output. + ! TOSNL5 I.A. Public Times for point ouput (!/NL5) + ! TOFRST I.A. Public Times for first output. + ! TONEXT I.A. Public Times for next output. + ! TOLAST I.A. Public Times for last output. + ! TBPI0 I.A Public Time of first set of input boundary + ! spectra. + ! TBPIN I.A Public Id. second set. + ! NDS I.A. Public Data set numbers (see W3INIT). + ! DTOUT R.A. Public Output intervals. + ! FLOUT L.A. Public Output flags. + ! OUT1 TYPE Public Data structure of type OTYPE1 with + ! suppl. data for output type 1. + ! OUT2 TYPE Public Data structure of type OTYPE2 with + ! suppl. data for output type 2. + ! OUT3 TYPE Public Data structure of type OTYPE3 with + ! suppl. data for output type 3. + ! OUT4 TYPE Public Data structure of type OTYPE4 with + ! suppl. data for output type 4. + ! OUT5 TYPE Public Data structure of type OTYPE5 with + ! suppl. data for output type 5. + ! OUT6 TYPE Public Data structure of type OTYPE6 with + ! suppl. data for output type 6. + ! OFILES I.A. Public Output in one or several files. + ! ---------------------------------------------------------------- + ! + ! Elements of OUT1 are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! IPASS1 Int. Public Pass counter for file management, + ! renamed to IPASS in routine. + ! WRITE1 Int. Public Write flag for file management, + ! renamed to WRITE in routine. + ! NRQGO(2) Int. Public Number of MPI handles W3IOGO. + ! IRQGO I.A. Public Array with MPI handles W3IOGO. + ! FLOGRD L.A. Public FLags for output fields. + ! FLOGR2 L.A. Public FLags for coupling fields. + ! FLOGRR L.A. Public FLags for optional coupling restart (2D). + ! FLOGD L.A. Public Flags for output groups + ! FLOG2 L.A. Public Flags for coupling groups + ! FLOGR L.A. Public FLags for optional coupling restart (1D). + ! ---------------------------------------------------------------- + ! + ! Elements of OUT2 are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! IPASS2 Int. Public Pass counter for file management, + ! renamed to IPASS in routine. + ! NOPTS Int. Public Number of output points. + ! NRQPO(2) Int. Public Number of MPI handles IRQPOn. (!/MPI) + ! IPTINT I.A. Public (I,J)-indices of enclosing cell corner points + ! IL I.A. Public Number of land points in interpola- + ! tion box for output point. + ! IW I.A. Public Id. water. + ! II I.A. Public Id. ice. + ! IRQPO1/2 I.A. Public Array with MPI handles. (!/MPI) + ! PTLOC R.A. Public Name of output locations. + ! PTIFAC R.A. Public Interpolation weights. + ! DPO R.A. Public Interpolated depths. + ! WAO R.A. Public Interpolated wind speeds. + ! WDO R.A. Public Interpolated wind directions. + ! ASO R.A. Public Interpolated air-sea temp. diff. + ! TAUAO R.A. Public Interpolated atm. stresses. + ! TAUDO R.A. Public Interpolated atm. stres directions. + ! DAIRO R.A. Public Interpolated rho atmosphere. + ! CAO R.A. Public Interpolated current speeds. + ! CDO R.A. Public Interpolated current directions. + ! SPCO R.A. Public Output spectra. + ! ICEO R.A. Public Interpolated ice concentration. + ! ICEHO R.A. Public Interpolated ice thickness. + ! ICEFO R.A. Public Interpolated ice floe. + ! PTNME C.A. Public Output locations. + ! GRDID C.A. Public Originating grid ID. + ! O2INIT Log. Public Flag for array initialization. + ! O2IRQI Log. Public Flag for array initialization. + ! ---------------------------------------------------------------- + ! + ! Elements of OUT3 are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! IPASS3 Int. Public Pass counter for file management, + ! renamed to IPASS in routine. + ! IT0PNT Int. Public Base tag number of MPI communication. + ! IT0TRK Int. Public Base tag number of MPI communication. + ! IT0PRT Int. Public Base tag number of MPI communication. + ! NRQTR Int. Public Number of handles in IRQTR. + ! IRQTR I.A. Public Array with MPI handles. + ! O3INIT Log. Public Flag for array initialization. + ! STOP Log. Public Flag for end of output. + ! MASKn L.A. Public Mask arrays for internal use. + ! ---------------------------------------------------------------- + ! + ! Elements of OUT4 are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! IFILE4 Int. Public File number for output files. + ! NBLKRS Int. Public Number of blocks in communication of + ! spectra. + ! RSBLKS Int. Public Corresponding block size. + ! NRQSR Int. Public Number of MPI handles. + ! IRQRS I.A. Public Array with MPI handles. + ! IRQRSS I.A. Public Array with MPI handles. + ! VAAUX R.A. Public Aux. spectra storage. + ! ---------------------------------------------------------------- + ! + ! Elements of OUT5 are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NBI(2) Int. Public Number of input bound. points. + ! NFBPO Int. Public Number of files for output bound. data. + ! NRQBP(2) Int. Public Number of MPI handles. + ! NKI,NTHI Int. Public Size of input spectra + ! NBO(2) I.A. Public Number of output bound. pts. per file. + ! NDSL I.A. Public Array with unit numbers. + ! IPBPI I.A. Public Interpolation data input b.p. + ! ISBPI I.A. Public Sea point counters for input b.p. + ! IRQBP1/2 I.A. Public Array with MPI handles. + ! XFRI, FR1I, TH1I + ! Real Public Definition of input spectra. + ! X/YBPI R.A. Public Location of input boundary points. + ! RDBPI R.A. Public Interpolation factors input b.p. + ! ABPI0/N R.A. Public Storage of spectra from which to + ! interpolate b.d. + ! BBPI0/N R.A. Public idem, secondary storage. + ! ABPOS R.A. Public Temporarily storage for output b.d. + ! IPBPO, ISBPO, X/YBPO, RDBPO + ! Misc. Public Id. for output b.p. + ! FLBPI Log. Public Flag for input of boundary data. + ! FLBPO Log. Public Flag for output of boundary data. + ! FILER/W/D Log. Public Read/write flags for file management. + ! SPCONV Log. Public Flag for change of spectral res. + ! O5INIn Log. Public Flag for array initializations. + ! ---------------------------------------------------------------- + ! + ! Elements of OUT6 are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! IPASS6 Int. Public Pass counter for file management, + ! renamed to IPASS in routine. + ! IHMAX Int. Public Number of discrete spectral levels. + ! IX0/N/S Int. Public First-last-step IX counters. + ! IY0/N/S Int. Public Idem IY counters. + ! HSPMIN Real Public Minimum significant height per part. + ! WSMULT Real Public Multiplier for wind sea boundary. + ! WSCUT Real Public Cut-off wind factor for wind seas. + ! ICPRT I.A. Public Counters for partitions. + ! DTPRT R.A. Public Data from partitions. + ! FLCOMB Log. Public Flag for combining wind seas. + ! FLFORM Log. Public Flag for (un)formatted output + ! O6INIT Log. Public Flag for array initializations. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3NOUT Subr. Public Set number of grids. + ! W3DMO2 Subr. Public Allocate arrays output type 2. + ! W3DMO3 Subr. Public Allocate arrays output type 3. + ! W3DMO5 Subr. Public Allocate arrays output type 5. + ! W3SETO Subr. Public Point to selected grid / model. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to proper model grid. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - The number of grids is taken from W3GDATMD, and needs to be + ! set first with W3DIMG. + ! + ! 6. Switches : + ! + ! !/MPI MPI specific calls. + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY : UNDEF - ! module default - IMPLICIT NONE + ! module default + IMPLICIT NONE - PUBLIC -!/ -!/ Module private variable for checking error returns -!/ - INTEGER, PRIVATE :: ISTAT -!/ -!/ Conventional declarations -!/ - INTEGER :: NOUTP = -1, IOUTP = -1, IOSTYP = 1 -! - INTEGER, PARAMETER :: NOGRP = 10 - INTEGER, PARAMETER :: NGRPP = 20 - INTEGER, PARAMETER :: DIMP = 15 - INTEGER :: NOGE(NOGRP) - INTEGER :: NOTYPE - INTEGER, PARAMETER :: NOEXTR= 2 - CHARACTER(LEN=20) :: IDOUT(NOGRP,NGRPP) - CHARACTER(LEN=80) :: FNMPRE = './' - !Moved UNDEF to constants and included above - !REAL :: UNDEF = -999.9 - LOGICAL :: UNIPTS = .FALSE., UPPROC = .FALSE. -!/ -!/ Set NOGE and IDOUT identifiers in W3NOUT -!/ -!/ Data structures -!/ - TYPE OTYPE1 - INTEGER :: IPASS1 + PUBLIC + !/ + !/ Module private variable for checking error returns + !/ + INTEGER, PRIVATE :: ISTAT + !/ + !/ Conventional declarations + !/ + INTEGER :: NOUTP = -1, IOUTP = -1, IOSTYP = 1 + ! + INTEGER, PARAMETER :: NOGRP = 10 + INTEGER, PARAMETER :: NGRPP = 20 + INTEGER, PARAMETER :: DIMP = 15 + INTEGER :: NOGE(NOGRP) + INTEGER :: NOTYPE + INTEGER, PARAMETER :: NOEXTR= 2 + CHARACTER(LEN=20) :: IDOUT(NOGRP,NGRPP) + CHARACTER(LEN=80) :: FNMPRE = './' + !Moved UNDEF to constants and included above + !REAL :: UNDEF = -999.9 + LOGICAL :: UNIPTS = .FALSE., UPPROC = .FALSE. + !/ + !/ Set NOGE and IDOUT identifiers in W3NOUT + !/ + !/ Data structures + !/ + TYPE OTYPE1 + INTEGER :: IPASS1 #ifdef W3_MPI - INTEGER :: NRQGO, NRQGO2 - INTEGER, POINTER :: IRQGO(:), IRQGO2(:) -#endif - LOGICAL :: FLOGRD(NOGRP,NGRPP), FLOGD(NOGRP), & - FLOGR2(NOGRP,NGRPP), FLOG2(NOGRP), & - FLOGRR(NOGRP,NGRPP), FLOGR(NOGRP), & - WRITE1 - END TYPE OTYPE1 -!/ - TYPE OTYPE2 - INTEGER :: IPASS2, NOPTS + INTEGER :: NRQGO, NRQGO2 + INTEGER, POINTER :: IRQGO(:), IRQGO2(:) +#endif + LOGICAL :: FLOGRD(NOGRP,NGRPP), FLOGD(NOGRP), & + FLOGR2(NOGRP,NGRPP), FLOG2(NOGRP), & + FLOGRR(NOGRP,NGRPP), FLOGR(NOGRP), & + WRITE1 + END TYPE OTYPE1 + !/ + TYPE OTYPE2 + INTEGER :: IPASS2, NOPTS #ifdef W3_MPI - INTEGER :: NRQPO, NRQPO2 + INTEGER :: NRQPO, NRQPO2 #endif - INTEGER, POINTER :: IPTINT(:,:,:), IL(:), IW(:), II(:) + INTEGER, POINTER :: IPTINT(:,:,:), IL(:), IW(:), II(:) #ifdef W3_MPI - INTEGER, POINTER :: IRQPO1(:), IRQPO2(:) + INTEGER, POINTER :: IRQPO1(:), IRQPO2(:) #endif - REAL, POINTER :: PTLOC(:,:), PTIFAC(:,:), & - DPO(:), WAO(:), WDO(:), ASO(:), & + REAL, POINTER :: PTLOC(:,:), PTIFAC(:,:), & + DPO(:), WAO(:), WDO(:), ASO(:), & #ifdef W3_FLX5 - TAUAO(:), TAUDO(:), DAIRO(:), & + TAUAO(:), TAUDO(:), DAIRO(:), & #endif - CAO(:), CDO(:), ICEO(:), ICEHO(:), & - ICEFO(:), SPCO(:,:) - REAL, POINTER :: ZET_SETO(:) ! For the wave setup. + CAO(:), CDO(:), ICEO(:), ICEHO(:), & + ICEFO(:), SPCO(:,:) + REAL, POINTER :: ZET_SETO(:) ! For the wave setup. - CHARACTER(LEN=40), POINTER :: PTNME(:) - CHARACTER(LEN=13), POINTER :: GRDID(:) - LOGICAL :: O2INIT + CHARACTER(LEN=40), POINTER :: PTNME(:) + CHARACTER(LEN=13), POINTER :: GRDID(:) + LOGICAL :: O2INIT #ifdef W3_MPI - LOGICAL :: O2IRQI + LOGICAL :: O2IRQI #endif - END TYPE OTYPE2 -!/ - TYPE OTYPE3 - INTEGER :: IPASS3 + END TYPE OTYPE2 + !/ + TYPE OTYPE3 + INTEGER :: IPASS3 #ifdef W3_MPI - INTEGER :: IT0PNT, IT0TRK, IT0PRT, NRQTR - INTEGER, POINTER :: IRQTR(:) -#endif - LOGICAL :: O3INIT, STOP - LOGICAL, POINTER :: MASK1(:,:), MASK2(:,:) - CHARACTER(LEN=32), POINTER :: TRCKID(:,:) - END TYPE OTYPE3 -!/ - TYPE OTYPE4 - INTEGER :: IFILE4 + INTEGER :: IT0PNT, IT0TRK, IT0PRT, NRQTR + INTEGER, POINTER :: IRQTR(:) +#endif + LOGICAL :: O3INIT, STOP + LOGICAL, POINTER :: MASK1(:,:), MASK2(:,:) + CHARACTER(LEN=32), POINTER :: TRCKID(:,:) + END TYPE OTYPE3 + !/ + TYPE OTYPE4 + INTEGER :: IFILE4 #ifdef W3_MPI - INTEGER :: NRQRS, NBLKRS, RSBLKS - INTEGER, POINTER :: IRQRS(:), IRQRSS(:) - REAL, POINTER :: VAAUX(:,:,:) -#endif - END TYPE OTYPE4 -!/ - TYPE OTYPE5 - INTEGER :: NBI, NBI2, NFBPO, NBO(0:9), & - NBO2(0:9), NDSL(9), NKI, NTHI + INTEGER :: NRQRS, NBLKRS, RSBLKS + INTEGER, POINTER :: IRQRS(:), IRQRSS(:) + REAL, POINTER :: VAAUX(:,:,:) +#endif + END TYPE OTYPE4 + !/ + TYPE OTYPE5 + INTEGER :: NBI, NBI2, NFBPO, NBO(0:9), & + NBO2(0:9), NDSL(9), NKI, NTHI #ifdef W3_MPI - INTEGER :: NRQBP = 0, NRQBP2 = 0 + INTEGER :: NRQBP = 0, NRQBP2 = 0 #endif - INTEGER, POINTER :: IPBPI(:,:), ISBPI(:), & - IPBPO(:,:), ISBPO(:) + INTEGER, POINTER :: IPBPI(:,:), ISBPI(:), & + IPBPO(:,:), ISBPO(:) #ifdef W3_MPI - INTEGER, POINTER :: IRQBP1(:), IRQBP2(:) -#endif - REAL :: XFRI, FR1I, TH1I - REAL, POINTER :: XBPI(:), YBPI(:), RDBPI(:,:), & - XBPO(:), YBPO(:), RDBPO(:,:), & - ABPI0(:,:), ABPIN(:,:), ABPOS(:,:), & - BBPI0(:,:), BBPIN(:,:) - LOGICAL :: O5INI1, O5INI2, O5INI3, O5INI4 - LOGICAL :: FLBPI, FLBPO, FILER, FILEW, FILED, & - SPCONV - END TYPE OTYPE5 -!/ - TYPE OTYPE6 - INTEGER :: IPASS6, IHMAX, IX0, IXN, IXS, & - IY0, IYN, IYS - INTEGER, POINTER :: ICPRT(:,:) - REAL :: HSPMIN, WSMULT, WSCUT - REAL, POINTER :: DTPRT(:,:) - LOGICAL :: FLFORM, FLCOMB, O6INIT - INTEGER :: PTMETH ! C. Bunney; Partitioning method - REAL :: PTFCUT ! C. Bunney; Part. 5 freq cut - END TYPE OTYPE6 -!/ - TYPE OUTPUT - INTEGER :: NDSO, NDSE, NDST, SCREEN - INTEGER :: NTPROC, NAPROC, IAPROC, NAPLOG, & - NAPOUT, NAPERR, NAPFLD, NAPPNT, & - NAPTRK, NAPRST, NAPBPT, NAPPRT - INTEGER :: NOSWLL + INTEGER, POINTER :: IRQBP1(:), IRQBP2(:) +#endif + REAL :: XFRI, FR1I, TH1I + REAL, POINTER :: XBPI(:), YBPI(:), RDBPI(:,:), & + XBPO(:), YBPO(:), RDBPO(:,:), & + ABPI0(:,:), ABPIN(:,:), ABPOS(:,:), & + BBPI0(:,:), BBPIN(:,:) + LOGICAL :: O5INI1, O5INI2, O5INI3, O5INI4 + LOGICAL :: FLBPI, FLBPO, FILER, FILEW, FILED, & + SPCONV + END TYPE OTYPE5 + !/ + TYPE OTYPE6 + INTEGER :: IPASS6, IHMAX, IX0, IXN, IXS, & + IY0, IYN, IYS + INTEGER, POINTER :: ICPRT(:,:) + REAL :: HSPMIN, WSMULT, WSCUT + REAL, POINTER :: DTPRT(:,:) + LOGICAL :: FLFORM, FLCOMB, O6INIT + INTEGER :: PTMETH ! C. Bunney; Partitioning method + REAL :: PTFCUT ! C. Bunney; Part. 5 freq cut + END TYPE OTYPE6 + !/ + TYPE OUTPUT + INTEGER :: NDSO, NDSE, NDST, SCREEN + INTEGER :: NTPROC, NAPROC, IAPROC, NAPLOG, & + NAPOUT, NAPERR, NAPFLD, NAPPNT, & + NAPTRK, NAPRST, NAPBPT, NAPPRT + INTEGER :: NOSWLL #ifdef W3_NL5 - INTEGER :: TOSNL5(2) -#endif - INTEGER :: TOFRST(2), TONEXT(2,8), TOLAST(2,8), & - TBPI0(2), TBPIN(2), NDS(13), OFILES(7) - REAL :: DTOUT(8) - LOGICAL :: FLOUT(8) - TYPE(OTYPE1) :: OUT1 - TYPE(OTYPE2) :: OUT2 - TYPE(OTYPE3) :: OUT3 - TYPE(OTYPE4) :: OUT4 - TYPE(OTYPE5) :: OUT5 - TYPE(OTYPE6) :: OUT6 - END TYPE OUTPUT -!/ -!/ Data storage -!/ - TYPE(OUTPUT), TARGET, ALLOCATABLE :: OUTPTS(:) -!/ -!/ Data aliasses for structure OUTPUT -!/ - INTEGER, POINTER :: NDSO, NDSE, NDST, SCREEN - INTEGER, POINTER :: NTPROC, NAPROC, IAPROC, NAPLOG, & - NAPOUT, NAPERR, NAPFLD, NAPPNT, & - NAPTRK, NAPRST, NAPBPT, NAPPRT - INTEGER, POINTER :: NOSWLL + INTEGER :: TOSNL5(2) +#endif + INTEGER :: TOFRST(2), TONEXT(2,8), TOLAST(2,8), & + TBPI0(2), TBPIN(2), NDS(13), OFILES(7) + REAL :: DTOUT(8) + LOGICAL :: FLOUT(8) + TYPE(OTYPE1) :: OUT1 + TYPE(OTYPE2) :: OUT2 + TYPE(OTYPE3) :: OUT3 + TYPE(OTYPE4) :: OUT4 + TYPE(OTYPE5) :: OUT5 + TYPE(OTYPE6) :: OUT6 + END TYPE OUTPUT + !/ + !/ Data storage + !/ + TYPE(OUTPUT), TARGET, ALLOCATABLE :: OUTPTS(:) + !/ + !/ Data aliasses for structure OUTPUT + !/ + INTEGER, POINTER :: NDSO, NDSE, NDST, SCREEN + INTEGER, POINTER :: NTPROC, NAPROC, IAPROC, NAPLOG, & + NAPOUT, NAPERR, NAPFLD, NAPPNT, & + NAPTRK, NAPRST, NAPBPT, NAPPRT + INTEGER, POINTER :: NOSWLL #ifdef W3_NL5 - INTEGER, POINTER :: TOSNL5(:) -#endif - INTEGER, POINTER :: TOFRST(:), TONEXT(:,:), TOLAST(:,:), & - TBPI0(:), TBPIN(:), NDS(:) - INTEGER, POINTER :: OFILES(:) - REAL, POINTER :: DTOUT(:) - LOGICAL, POINTER :: FLOUT(:) -!/ -!/ Data aliasses for substructures for output types -!/ Type 1 ... -!/ - INTEGER, POINTER :: IPASS1 + INTEGER, POINTER :: TOSNL5(:) +#endif + INTEGER, POINTER :: TOFRST(:), TONEXT(:,:), TOLAST(:,:), & + TBPI0(:), TBPIN(:), NDS(:) + INTEGER, POINTER :: OFILES(:) + REAL, POINTER :: DTOUT(:) + LOGICAL, POINTER :: FLOUT(:) + !/ + !/ Data aliasses for substructures for output types + !/ Type 1 ... + !/ + INTEGER, POINTER :: IPASS1 #ifdef W3_MPI - INTEGER, POINTER :: NRQGO, NRQGO2 - INTEGER, POINTER :: IRQGO(:), IRQGO2(:) -#endif - LOGICAL, POINTER :: FLOGRD(:,:), FLOGR2(:,:), & - FLOGRR(:,:),FLOGD(:), FLOG2(:), & - FLOGR(:), WRITE1 -!/ -!/ Type 2 ... -!/ - INTEGER, POINTER :: IPASS2, NOPTS + INTEGER, POINTER :: NRQGO, NRQGO2 + INTEGER, POINTER :: IRQGO(:), IRQGO2(:) +#endif + LOGICAL, POINTER :: FLOGRD(:,:), FLOGR2(:,:), & + FLOGRR(:,:),FLOGD(:), FLOG2(:), & + FLOGR(:), WRITE1 + !/ + !/ Type 2 ... + !/ + INTEGER, POINTER :: IPASS2, NOPTS #ifdef W3_MPI - INTEGER, POINTER :: NRQPO, NRQPO2 + INTEGER, POINTER :: NRQPO, NRQPO2 #endif - INTEGER, POINTER :: IPTINT(:,:,:), IL(:), IW(:), II(:) + INTEGER, POINTER :: IPTINT(:,:,:), IL(:), IW(:), II(:) #ifdef W3_MPI - INTEGER, POINTER :: IRQPO1(:), IRQPO2(:) + INTEGER, POINTER :: IRQPO1(:), IRQPO2(:) #endif - REAL, POINTER :: PTLOC(:,:), PTIFAC(:,:), & - DPO(:), WAO(:), WDO(:), ASO(:), & + REAL, POINTER :: PTLOC(:,:), PTIFAC(:,:), & + DPO(:), WAO(:), WDO(:), ASO(:), & #ifdef W3_FLX5 - TAUAO(:), TAUDO(:), DAIRO(:), & -#endif - CAO(:), CDO(:), ICEO(:), ICEHO(:), & - ICEFO(:), SPCO(:,:) - REAL, POINTER :: ZET_SETO(:) -! - CHARACTER(LEN=40), POINTER :: PTNME(:) - CHARACTER(LEN=13), POINTER :: GRDID(:) - LOGICAL, POINTER :: O2INIT + TAUAO(:), TAUDO(:), DAIRO(:), & +#endif + CAO(:), CDO(:), ICEO(:), ICEHO(:), & + ICEFO(:), SPCO(:,:) + REAL, POINTER :: ZET_SETO(:) + ! + CHARACTER(LEN=40), POINTER :: PTNME(:) + CHARACTER(LEN=13), POINTER :: GRDID(:) + LOGICAL, POINTER :: O2INIT #ifdef W3_MPI - LOGICAL, POINTER :: O2IRQI + LOGICAL, POINTER :: O2IRQI #endif -!/ -!/ Type 3 ... -!/ - INTEGER, POINTER :: IPASS3 + !/ + !/ Type 3 ... + !/ + INTEGER, POINTER :: IPASS3 #ifdef W3_MPI - INTEGER, POINTER :: IT0PNT, IT0TRK, IT0PRT, NRQTR - INTEGER, POINTER :: IRQTR(:) -#endif - LOGICAL, POINTER :: O3INIT, STOP - LOGICAL, POINTER :: MASK1(:,:), MASK2(:,:) - CHARACTER(LEN=32), POINTER :: TRCKID(:,:) -!/ -!/ Type 4 ... -!/ - INTEGER, POINTER :: IFILE4 + INTEGER, POINTER :: IT0PNT, IT0TRK, IT0PRT, NRQTR + INTEGER, POINTER :: IRQTR(:) +#endif + LOGICAL, POINTER :: O3INIT, STOP + LOGICAL, POINTER :: MASK1(:,:), MASK2(:,:) + CHARACTER(LEN=32), POINTER :: TRCKID(:,:) + !/ + !/ Type 4 ... + !/ + INTEGER, POINTER :: IFILE4 #ifdef W3_MPI - INTEGER, POINTER :: NRQRS, NBLKRS, RSBLKS - INTEGER, POINTER :: IRQRS(:), IRQRSS(:) - REAL, POINTER :: VAAUX(:,:,:) -#endif -!/ -!/ Type 5 ... -!/ - INTEGER, POINTER :: NBI, NBI2, NFBPO, NKI, NTHI - INTEGER, POINTER :: NBO(:), NBO2(:), NDSL(:) + INTEGER, POINTER :: NRQRS, NBLKRS, RSBLKS + INTEGER, POINTER :: IRQRS(:), IRQRSS(:) + REAL, POINTER :: VAAUX(:,:,:) +#endif + !/ + !/ Type 5 ... + !/ + INTEGER, POINTER :: NBI, NBI2, NFBPO, NKI, NTHI + INTEGER, POINTER :: NBO(:), NBO2(:), NDSL(:) #ifdef W3_MPI - INTEGER, POINTER :: NRQBP, NRQBP2 + INTEGER, POINTER :: NRQBP, NRQBP2 #endif - INTEGER, POINTER :: IPBPI(:,:), ISBPI(:), & - IPBPO(:,:), ISBPO(:) + INTEGER, POINTER :: IPBPI(:,:), ISBPI(:), & + IPBPO(:,:), ISBPO(:) #ifdef W3_MPI - INTEGER, POINTER :: IRQBP1(:), IRQBP2(:) -#endif - REAL, POINTER :: XFRI, FR1I, TH1I - REAL, POINTER :: XBPI(:), YBPI(:), RDBPI(:,:), & - XBPO(:), YBPO(:), RDBPO(:,:), & - ABPI0(:,:), ABPIN(:,:), ABPOS(:,:), & - BBPI0(:,:), BBPIN(:,:) - LOGICAL, POINTER :: O5INI1, O5INI2, O5INI3, O5INI4 - LOGICAL, POINTER :: FLBPI, FLBPO, FILER, FILEW, FILED, & - SPCONV -!/ -!/ Type 6 ... -!/ - INTEGER, POINTER :: IPASS6, IHMAX, IX0, IXN, IXS, & - IY0, IYN, IYS, ICPRT(:,:) - REAL, POINTER :: HSPMIN, WSMULT, WSCUT, DTPRT(:,:) - LOGICAL, POINTER :: FLFORM, FLCOMB, O6INIT - INTEGER, POINTER :: PTMETH ! C. Bunney; Partitioning method - REAL, POINTER :: PTFCUT ! C. Bunney; Part. 5 freq cut - character(len=8) :: runtype = '' !< @public the run type (startup,branch,continue) - character(len=256) :: initfile = '' !< @public name of wave initial condition file - !! if runtype is startup or branch run, then initfile is used - logical :: use_user_histname = .false. !<@public logical flag for user set history filenames - logical :: use_user_restname = .false. !<@public logical flag for user set restart filenames - character(len=512) :: user_histfname = '' !<@public user history filename prefix, timestring - !! YYYY-MM-DD-SSSSS will be appended - character(len=512) :: user_restfname = '' !<@public user restart filename prefix, timestring - !! YYYY-MM-DD-SSSSS will be appended - logical :: histwr = .false. !<@public logical to trigger history write - !! if true => write history file (snapshot) - logical :: rstwr = .false. !<@public logical to trigger restart write - !! if true => write restart - logical :: user_netcdf_grdout = .false. !<@public logical flag to use netCDF for gridded - !! field output - character(len= 36) :: time_origin = '' !< @public the time_origin used for netCDF output - character(len= 36) :: calendar_name = '' !< @public the calendar used for netCDF output - integer(kind=8) :: elapsed_secs = 0 !< @public the time in seconds from the time_origin -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3NOUT ( NDSERR, NDSTST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 13-Dec-2004 : Origination. ( version 3.06 ) -!/ 27-Jun-2006 : Adding file name preamble ( version 3.09 ) -!/ 24-Jul-2006 : Adding unified point output storage.( version 3.10 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 30-Oct-2006 : Add pars for partitioning. ( version 3.10 ) -!/ 26-Mar-2007 : Add pars for partitioning. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 18-Dec-2012 : Moving IDOUT initialization here. ( version 4.11 ) -!/ 19-Dec-2012 : Move NOSWLL to data structure. ( version 4.11 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 22-Mar-2021 : Add extra coupling variables ( version 7.13 ) -!/ -! 1. Purpose : -! -! Set up the number of grids to be used. -! -! 2. Method : -! -! Use data stored in NGRIDS in W3GDATMD. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSERR Int. I Error output unit number. -! NDSTST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation below. -! -! 5. Called by : -! -! Any main program that uses this grid structure. -! -! 6. Error messages : -! -! - Error checks on previous setting of variable NGRIDS. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS, NAUXGR - USE W3SERVMD, ONLY: EXTCDE + INTEGER, POINTER :: IRQBP1(:), IRQBP2(:) +#endif + REAL, POINTER :: XFRI, FR1I, TH1I + REAL, POINTER :: XBPI(:), YBPI(:), RDBPI(:,:), & + XBPO(:), YBPO(:), RDBPO(:,:), & + ABPI0(:,:), ABPIN(:,:), ABPOS(:,:), & + BBPI0(:,:), BBPIN(:,:) + LOGICAL, POINTER :: O5INI1, O5INI2, O5INI3, O5INI4 + LOGICAL, POINTER :: FLBPI, FLBPO, FILER, FILEW, FILED, & + SPCONV + !/ + !/ Type 6 ... + !/ + INTEGER, POINTER :: IPASS6, IHMAX, IX0, IXN, IXS, & + IY0, IYN, IYS, ICPRT(:,:) + REAL, POINTER :: HSPMIN, WSMULT, WSCUT, DTPRT(:,:) + LOGICAL, POINTER :: FLFORM, FLCOMB, O6INIT + INTEGER, POINTER :: PTMETH ! C. Bunney; Partitioning method + REAL, POINTER :: PTFCUT ! C. Bunney; Part. 5 freq cut + character(len=8) :: runtype = '' !< @public the run type (startup,branch,continue) + character(len=256) :: initfile = '' !< @public name of wave initial condition file + !! if runtype is startup or branch run, then initfile is used + logical :: use_user_histname = .false. !<@public logical flag for user set history filenames + logical :: use_user_restname = .false. !<@public logical flag for user set restart filenames + character(len=512) :: user_histfname = '' !<@public user history filename prefix, timestring + !! YYYY-MM-DD-SSSSS will be appended + character(len=512) :: user_restfname = '' !<@public user restart filename prefix, timestring + !! YYYY-MM-DD-SSSSS will be appended + logical :: histwr = .false. !<@public logical to trigger history write + !! if true => write history file (snapshot) + logical :: rstwr = .false. !<@public logical to trigger restart write + !! if true => write restart + logical :: user_netcdf_grdout = .false. !<@public logical flag to use netCDF for gridded + !! field output + character(len= 36) :: time_origin = '' !< @public the time_origin used for netCDF output + character(len= 36) :: calendar_name = '' !< @public the calendar used for netCDF output + integer(kind=8) :: elapsed_secs = 0 !< @public the time in seconds from the time_origin + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3NOUT ( NDSERR, NDSTST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 13-Dec-2004 : Origination. ( version 3.06 ) + !/ 27-Jun-2006 : Adding file name preamble ( version 3.09 ) + !/ 24-Jul-2006 : Adding unified point output storage.( version 3.10 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 30-Oct-2006 : Add pars for partitioning. ( version 3.10 ) + !/ 26-Mar-2007 : Add pars for partitioning. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 18-Dec-2012 : Moving IDOUT initialization here. ( version 4.11 ) + !/ 19-Dec-2012 : Move NOSWLL to data structure. ( version 4.11 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 22-Mar-2021 : Add extra coupling variables ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Set up the number of grids to be used. + ! + ! 2. Method : + ! + ! Use data stored in NGRIDS in W3GDATMD. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSERR Int. I Error output unit number. + ! NDSTST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation below. + ! + ! 5. Called by : + ! + ! Any main program that uses this grid structure. + ! + ! 6. Error messages : + ! + ! - Error checks on previous setting of variable NGRIDS. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS, NAUXGR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSERR, NDSTST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, NLOW, J + USE W3SERVMD, ONLY: STRACE +#endif + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSERR, NDSTST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, NLOW, J #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - CHARACTER(LEN=20) :: STRING -!/ + CHARACTER(LEN=20) :: STRING + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3NOUT') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSERR,1001) NGRIDS - CALL EXTCDE (1) - END IF -! -! -------------------------------------------------------------------- / -! 2. Set variable and allocate arrays -! - NLOW = MIN ( 0 , -NAUXGR ) - ALLOCATE ( OUTPTS(NLOW:NGRIDS), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - NOUTP = NGRIDS -! -! -------------------------------------------------------------------- / -! 3. Initialize parameters -! - DO I=NLOW, NGRIDS -! - OUTPTS(I)%NDSO = 6 - OUTPTS(I)%NDSE = 6 - OUTPTS(I)%NDST = 6 - OUTPTS(I)%SCREEN = 6 -! - OUTPTS(I)%NTPROC = 1 - OUTPTS(I)%NAPROC = 1 - OUTPTS(I)%IAPROC = 1 - OUTPTS(I)%NAPLOG = 1 - OUTPTS(I)%NAPOUT = 1 - OUTPTS(I)%NAPERR = 1 - OUTPTS(I)%NAPFLD = 1 - OUTPTS(I)%NAPPNT = 1 - OUTPTS(I)%NAPTRK = 1 - OUTPTS(I)%NAPRST = 1 - OUTPTS(I)%NAPBPT = 1 - OUTPTS(I)%NAPPRT = 1 -! - OUTPTS(I)%NOSWLL = -1 -! - OUTPTS(I)%TBPI0 = (-1,0) - OUTPTS(I)%TBPIN = (-1,0) -! - OUTPTS(I)%OUT1%IPASS1 = 0 + CALL STRACE (IENT, 'W3NOUT') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSERR,1001) NGRIDS + CALL EXTCDE (1) + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Set variable and allocate arrays + ! + NLOW = MIN ( 0 , -NAUXGR ) + ALLOCATE ( OUTPTS(NLOW:NGRIDS), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + NOUTP = NGRIDS + ! + ! -------------------------------------------------------------------- / + ! 3. Initialize parameters + ! + DO I=NLOW, NGRIDS + ! + OUTPTS(I)%NDSO = 6 + OUTPTS(I)%NDSE = 6 + OUTPTS(I)%NDST = 6 + OUTPTS(I)%SCREEN = 6 + ! + OUTPTS(I)%NTPROC = 1 + OUTPTS(I)%NAPROC = 1 + OUTPTS(I)%IAPROC = 1 + OUTPTS(I)%NAPLOG = 1 + OUTPTS(I)%NAPOUT = 1 + OUTPTS(I)%NAPERR = 1 + OUTPTS(I)%NAPFLD = 1 + OUTPTS(I)%NAPPNT = 1 + OUTPTS(I)%NAPTRK = 1 + OUTPTS(I)%NAPRST = 1 + OUTPTS(I)%NAPBPT = 1 + OUTPTS(I)%NAPPRT = 1 + ! + OUTPTS(I)%NOSWLL = -1 + ! + OUTPTS(I)%TBPI0 = (-1,0) + OUTPTS(I)%TBPIN = (-1,0) + ! + OUTPTS(I)%OUT1%IPASS1 = 0 #ifdef W3_MPI - OUTPTS(I)%OUT1%NRQGO = 0 - OUTPTS(I)%OUT1%NRQGO2 = 0 + OUTPTS(I)%OUT1%NRQGO = 0 + OUTPTS(I)%OUT1%NRQGO2 = 0 #endif -! - OUTPTS(I)%OUT2%IPASS2 = 0 - OUTPTS(I)%OUT2%NOPTS = 0 - OUTPTS(I)%OUT2%O2INIT = .FALSE. + ! + OUTPTS(I)%OUT2%IPASS2 = 0 + OUTPTS(I)%OUT2%NOPTS = 0 + OUTPTS(I)%OUT2%O2INIT = .FALSE. #ifdef W3_MPI - OUTPTS(I)%OUT2%O2IRQI = .FALSE. + OUTPTS(I)%OUT2%O2IRQI = .FALSE. #endif -! - OUTPTS(I)%OUT3%IPASS3 = 0 - OUTPTS(I)%OUT3%O3INIT = .FALSE. - OUTPTS(I)%OUT3%STOP = .FALSE. + ! + OUTPTS(I)%OUT3%IPASS3 = 0 + OUTPTS(I)%OUT3%O3INIT = .FALSE. + OUTPTS(I)%OUT3%STOP = .FALSE. #ifdef W3_MPI - OUTPTS(I)%OUT3%NRQTR = 0 + OUTPTS(I)%OUT3%NRQTR = 0 #endif -! - OUTPTS(I)%OUT4%IFILE4 = 0 + ! + OUTPTS(I)%OUT4%IFILE4 = 0 #ifdef W3_MPI - OUTPTS(I)%OUT4%NRQRS = 0 -#endif -! - OUTPTS(I)%OUT5%O5INI1 = .FALSE. - OUTPTS(I)%OUT5%O5INI2 = .FALSE. - OUTPTS(I)%OUT5%O5INI3 = .FALSE. - OUTPTS(I)%OUT5%O5INI4 = .FALSE. - OUTPTS(I)%OUT5%FILER = .TRUE. - OUTPTS(I)%OUT5%FILEW = .TRUE. - OUTPTS(I)%OUT5%FILED = .TRUE. -! - OUTPTS(I)%OUT6%IPASS6 = 0 - OUTPTS(I)%OUT6%O6INIT = .FALSE. -! - END DO -! -! Set IDOUT -! Commented outlines represent reserved slots. -! - DO I=1, NOGRP - DO J=1, NGRPP - IDOUT(I,J) = 'Undefined / Not Used' - END DO - END DO -! -! 1) Forcing fields -! - NOGE(1) = 9 + OUTPTS(I)%OUT4%NRQRS = 0 +#endif + ! + OUTPTS(I)%OUT5%O5INI1 = .FALSE. + OUTPTS(I)%OUT5%O5INI2 = .FALSE. + OUTPTS(I)%OUT5%O5INI3 = .FALSE. + OUTPTS(I)%OUT5%O5INI4 = .FALSE. + OUTPTS(I)%OUT5%FILER = .TRUE. + OUTPTS(I)%OUT5%FILEW = .TRUE. + OUTPTS(I)%OUT5%FILED = .TRUE. + ! + OUTPTS(I)%OUT6%IPASS6 = 0 + OUTPTS(I)%OUT6%O6INIT = .FALSE. + ! + END DO + ! + ! Set IDOUT + ! Commented outlines represent reserved slots. + ! + DO I=1, NOGRP + DO J=1, NGRPP + IDOUT(I,J) = 'Undefined / Not Used' + END DO + END DO + ! + ! 1) Forcing fields + ! + NOGE(1) = 9 #ifdef W3_BT4 - NOGE(1) = 10 + NOGE(1) = 10 #endif #ifdef W3_IS2 - NOGE(1) = 12 ! CB + NOGE(1) = 12 ! CB #endif #ifdef W3_SETUP NOGE(1) = 13 ! CB #endif -! - IDOUT( 1, 1) = 'Water depth ' - IDOUT( 1, 2) = 'Current vel. ' - IDOUT( 1, 3) = 'Wind speed ' - IDOUT( 1, 4) = 'Air-sea temp. dif. ' - IDOUT( 1, 5) = 'Water level ' - IDOUT( 1, 6) = 'Ice concentration ' - IDOUT( 1, 7) = 'Iceberg damp coeffic' - IDOUT( 1, 8) = 'Atmospheric momentum' - IDOUT( 1, 9) = 'Air density ' + ! + IDOUT( 1, 1) = 'Water depth ' + IDOUT( 1, 2) = 'Current vel. ' + IDOUT( 1, 3) = 'Wind speed ' + IDOUT( 1, 4) = 'Air-sea temp. dif. ' + IDOUT( 1, 5) = 'Water level ' + IDOUT( 1, 6) = 'Ice concentration ' + IDOUT( 1, 7) = 'Iceberg damp coeffic' + IDOUT( 1, 8) = 'Atmospheric momentum' + IDOUT( 1, 9) = 'Air density ' #ifdef W3_BT4 - IDOUT( 1, 10) = 'Sediment diam D50 ' + IDOUT( 1, 10) = 'Sediment diam D50 ' #endif #ifdef W3_IS2 - IDOUT( 1, 11) = 'ice thickness ' - IDOUT( 1, 12) = 'Avg. ice floe diam. ' + IDOUT( 1, 11) = 'ice thickness ' + IDOUT( 1, 12) = 'Avg. ice floe diam. ' #endif #ifdef W3_SETUP IDOUT( 1, 13) = 'wave induced setup' #endif -! -! 2) Standard mean wave parameters -! - NOGE(2) = 19 + ! + ! 2) Standard mean wave parameters + ! + NOGE(2) = 19 #ifdef W3_OASOCM - NOGE(2) = 20 -#endif -! - IDOUT( 2, 1) = 'Wave height ' - IDOUT( 2, 2) = 'Mean wave length ' - IDOUT( 2, 3) = 'Mean wave period(+2)' - IDOUT( 2, 4) = 'Mean wave period(-1)' - IDOUT( 2, 5) = 'Mean wave period(+1)' - IDOUT( 2, 6) = 'Peak frequency ' - IDOUT( 2, 7) = 'Mean wave dir. a1b1 ' - IDOUT( 2, 8) = 'Mean dir. spr. a1b1 ' - IDOUT( 2, 9) = 'Peak direction ' - IDOUT( 2, 10) = 'Infragravity height' - IDOUT( 2, 11) = 'Space-Time Max E ' - IDOUT( 2, 12) = 'Space-Time Max Std ' - IDOUT( 2, 13) = 'Space-Time Hmax ' - IDOUT( 2, 14) = 'Spc-Time Hmax^crest' - IDOUT( 2, 15) = 'STD Space-Time Hmax' - IDOUT( 2, 16) = 'STD ST Hmax^crest ' - IDOUT( 2, 17) = 'Dominant wave bT ' - IDOUT( 2, 18) = 'Peak prd. (from fp)' - IDOUT( 2, 19) = 'Mean wave number ' + NOGE(2) = 20 +#endif + ! + IDOUT( 2, 1) = 'Wave height ' + IDOUT( 2, 2) = 'Mean wave length ' + IDOUT( 2, 3) = 'Mean wave period(+2)' + IDOUT( 2, 4) = 'Mean wave period(-1)' + IDOUT( 2, 5) = 'Mean wave period(+1)' + IDOUT( 2, 6) = 'Peak frequency ' + IDOUT( 2, 7) = 'Mean wave dir. a1b1 ' + IDOUT( 2, 8) = 'Mean dir. spr. a1b1 ' + IDOUT( 2, 9) = 'Peak direction ' + IDOUT( 2, 10) = 'Infragravity height' + IDOUT( 2, 11) = 'Space-Time Max E ' + IDOUT( 2, 12) = 'Space-Time Max Std ' + IDOUT( 2, 13) = 'Space-Time Hmax ' + IDOUT( 2, 14) = 'Spc-Time Hmax^crest' + IDOUT( 2, 15) = 'STD Space-Time Hmax' + IDOUT( 2, 16) = 'STD ST Hmax^crest ' + IDOUT( 2, 17) = 'Dominant wave bT ' + IDOUT( 2, 18) = 'Peak prd. (from fp)' + IDOUT( 2, 19) = 'Mean wave number ' #ifdef W3_OASOCM - IDOUT( 2, 20) = 'Mean wave dir. norot' -#endif -! IDOUT( 2,10) = 'Mean wave dir. a2b2' -! IDOUT( 2,11) = 'Mean dir. spr. a2b2' -! IDOUT( 2,12) = 'Windsea height(Sin)' -! IDOUT( 2,13) = 'Windsea peak f(Sin)' -! IDOUT( 2,14) = 'Subrange waveheight' -! -! 3) Frequency-dependent standard parameters -! - NOGE(3) = 6 -! - IDOUT( 3, 1) = '1D Freq. Spectrum ' - IDOUT( 3, 2) = 'Mean wave dir. a1b1 ' - IDOUT( 3, 3) = 'Mean dir. spr. a1b1 ' - IDOUT( 3, 4) = 'Mean wave dir. a2b2 ' - IDOUT( 3, 5) = 'Mean dir. spr. a2b2 ' - IDOUT( 3, 6) = 'Wavenumber array ' -! -! 4) Spectral Partitions parameters -! - NOGE(4) = 17 -! - IDOUT( 4, 1) = 'Part. wave height ' - IDOUT( 4, 2) = 'Part. peak period ' - IDOUT( 4, 3) = 'Part. peak wave len.' - IDOUT( 4, 4) = 'Part. mean direction' - IDOUT( 4, 5) = 'Part. dir. spread ' - IDOUT( 4, 6) = 'Part. wind sea frac.' - IDOUT( 4, 7) = 'Part. peak direction' - IDOUT( 4, 8) = 'Part. peakedness ' - IDOUT( 4, 9) = 'Part. peak enh. fac.' - IDOUT( 4,10) = 'Part. gaussian width' - IDOUT( 4,11) = 'Part. spectral width' - IDOUT( 4,12) = 'Part. mean per. (-1)' - IDOUT( 4,13) = 'Part. mean per. (+1)' - IDOUT( 4,14) = 'Part. mean per. (+2)' - IDOUT( 4,15) = 'Part. peak density ' - IDOUT( 4,16) = 'Total wind sea frac.' - IDOUT( 4,17) = 'Number of partitions' -! -! 5) Atmosphere-waves layer -! - NOGE(5) = 11 -! - IDOUT( 5, 1) = 'Friction velocity ' - IDOUT( 5, 2) = 'Charnock parameter ' - IDOUT( 5, 3) = 'Energy flux ' - IDOUT( 5, 4) = 'Wind-wave enrgy flux' - IDOUT( 5, 5) = 'Wind-wave net mom. f' - IDOUT( 5, 6) = 'Wind-wave neg.mom.f.' - IDOUT( 5, 7) = 'Whitecap coverage ' - IDOUT( 5, 8) = 'Whitecap mean thick.' - IDOUT( 5, 9) = 'Mean breaking height' - IDOUT( 5,10) = 'Dominant break prob ' - IDOUT( 5,11) = 'Wind sea period' ! C.Bunney - reinstated this as is used in ww3_ounf - ! Is it suposed to be defunct? It is not in ww3_outf... -! -! 6) Wave-ocean layer -! - NOGE(6) = 13 -! - IDOUT( 6, 1) = 'Radiation stresses ' - IDOUT( 6, 2) = 'Wave-ocean mom. flux' - IDOUT( 6, 3) = 'wave ind p Bern Head' - IDOUT( 6, 4) = 'Wave-ocean TKE flux' - IDOUT( 6, 5) = 'Stokes transport ' - IDOUT( 6, 6) = 'Stokes drift at z=0 ' - IDOUT( 6, 7) = '2nd order pressure ' - IDOUT( 6, 8) = 'Stokes drft spectrum' - IDOUT( 6, 9) = '2nd ord press spectr' - IDOUT( 6,10) = 'Wave-ice mom. flux ' - IDOUT( 6,11) = 'Wave-ice energy flux' - IDOUT( 6,12) = 'Split Surface Stokes' - IDOUT( 6,13) = 'Tot wav-ocn mom flux' + IDOUT( 2, 20) = 'Mean wave dir. norot' +#endif + ! IDOUT( 2,10) = 'Mean wave dir. a2b2' + ! IDOUT( 2,11) = 'Mean dir. spr. a2b2' + ! IDOUT( 2,12) = 'Windsea height(Sin)' + ! IDOUT( 2,13) = 'Windsea peak f(Sin)' + ! IDOUT( 2,14) = 'Subrange waveheight' + ! + ! 3) Frequency-dependent standard parameters + ! + NOGE(3) = 6 + ! + IDOUT( 3, 1) = '1D Freq. Spectrum ' + IDOUT( 3, 2) = 'Mean wave dir. a1b1 ' + IDOUT( 3, 3) = 'Mean dir. spr. a1b1 ' + IDOUT( 3, 4) = 'Mean wave dir. a2b2 ' + IDOUT( 3, 5) = 'Mean dir. spr. a2b2 ' + IDOUT( 3, 6) = 'Wavenumber array ' + ! + ! 4) Spectral Partitions parameters + ! + NOGE(4) = 17 + ! + IDOUT( 4, 1) = 'Part. wave height ' + IDOUT( 4, 2) = 'Part. peak period ' + IDOUT( 4, 3) = 'Part. peak wave len.' + IDOUT( 4, 4) = 'Part. mean direction' + IDOUT( 4, 5) = 'Part. dir. spread ' + IDOUT( 4, 6) = 'Part. wind sea frac.' + IDOUT( 4, 7) = 'Part. peak direction' + IDOUT( 4, 8) = 'Part. peakedness ' + IDOUT( 4, 9) = 'Part. peak enh. fac.' + IDOUT( 4,10) = 'Part. gaussian width' + IDOUT( 4,11) = 'Part. spectral width' + IDOUT( 4,12) = 'Part. mean per. (-1)' + IDOUT( 4,13) = 'Part. mean per. (+1)' + IDOUT( 4,14) = 'Part. mean per. (+2)' + IDOUT( 4,15) = 'Part. peak density ' + IDOUT( 4,16) = 'Total wind sea frac.' + IDOUT( 4,17) = 'Number of partitions' + ! + ! 5) Atmosphere-waves layer + ! + NOGE(5) = 11 + ! + IDOUT( 5, 1) = 'Friction velocity ' + IDOUT( 5, 2) = 'Charnock parameter ' + IDOUT( 5, 3) = 'Energy flux ' + IDOUT( 5, 4) = 'Wind-wave enrgy flux' + IDOUT( 5, 5) = 'Wind-wave net mom. f' + IDOUT( 5, 6) = 'Wind-wave neg.mom.f.' + IDOUT( 5, 7) = 'Whitecap coverage ' + IDOUT( 5, 8) = 'Whitecap mean thick.' + IDOUT( 5, 9) = 'Mean breaking height' + IDOUT( 5,10) = 'Dominant break prob ' + IDOUT( 5,11) = 'Wind sea period' ! C.Bunney - reinstated this as is used in ww3_ounf + ! Is it suposed to be defunct? It is not in ww3_outf... + ! + ! 6) Wave-ocean layer + ! + NOGE(6) = 13 + ! + IDOUT( 6, 1) = 'Radiation stresses ' + IDOUT( 6, 2) = 'Wave-ocean mom. flux' + IDOUT( 6, 3) = 'wave ind p Bern Head' + IDOUT( 6, 4) = 'Wave-ocean TKE flux' + IDOUT( 6, 5) = 'Stokes transport ' + IDOUT( 6, 6) = 'Stokes drift at z=0 ' + IDOUT( 6, 7) = '2nd order pressure ' + IDOUT( 6, 8) = 'Stokes drft spectrum' + IDOUT( 6, 9) = '2nd ord press spectr' + IDOUT( 6,10) = 'Wave-ice mom. flux ' + IDOUT( 6,11) = 'Wave-ice energy flux' + IDOUT( 6,12) = 'Split Surface Stokes' + IDOUT( 6,13) = 'Tot wav-ocn mom flux' #ifdef W3_CESMCOUPLED - IDOUT( 6,14) = 'Turbulent Langmuir number' -#endif -! -! 7) Wave-bottom layer -! - NOGE(7) = 5 -! - IDOUT( 7, 1) = 'Bottom rms ampl. ' - IDOUT( 7, 2) = 'Bottom rms velocity ' - IDOUT( 7, 3) = 'Bedform parameters ' - IDOUT( 7, 4) = 'Energy diss. in WBBL' - IDOUT( 7, 5) = 'Moment. loss in WBBL' -! IDOUT( 7, 6) = 'Bottom mean period ' -! IDOUT( 7, 7) = 'Bottom mean direct ' -! IDOUT( 7, 8) = 'Bottom direct spread' -! IDOUT( 7, 9) = 'Calc grain rough K_N' -! -! 8) Spectrum parameters -! - NOGE(8) = 5 -! - IDOUT( 8, 1) = 'Mean square slopes ' - IDOUT( 8, 2) = 'Phillips tail const' - IDOUT( 8, 3) = 'Slope direction ' - IDOUT( 8, 4) = 'Tail slope direction' - IDOUT( 8, 5) = 'Goda peakedness parm' -! IDOUT( 8, 3) = 'Lx-Ly mean wvlength' -! IDOUT( 8, 4) = 'Surf grad correl XT' -! IDOUT( 8, 5) = 'Surf grad correl YT' -! IDOUT( 8, 6) = 'Surf grad correl XY' -! IDOUT( 8, 7) = 'Surface crest param' -! IDOUT( 8, 3) = '3rd spectral moment ' -! IDOUT( 8, 4) = '4th spectral moment ' -! IDOUT( 8, 6) = 'Kurtosis ' -! IDOUT( 8, 7) = 'Skewness ' -! -! 9) Numerical diagnostics -! - NOGE(9) = 5 -! - IDOUT( 9, 1) = 'Avg. time step. ' - IDOUT( 9, 2) = 'Cut-off freq. ' - IDOUT( 9, 3) = 'Maximum spatial CFL ' - IDOUT( 9, 4) = 'Maximum angular CFL ' - IDOUT( 9, 5) = 'Maximum k advect CFL' -! IDOUT( 9, 6) = 'Avg intrsp proptstep' -! -! 10) User defined -! - NOGE(10) = NOEXTR -! - DO I=1, MIN ( 20 , NOEXTR ) - WRITE (STRING,'(A14,I2.2,A4)') 'User defined #', I, ' ' - IDOUT(10, I) = STRING - END DO -! + IDOUT( 6,14) = 'Turbulent Langmuir number' +#endif + ! + ! 7) Wave-bottom layer + ! + NOGE(7) = 5 + ! + IDOUT( 7, 1) = 'Bottom rms ampl. ' + IDOUT( 7, 2) = 'Bottom rms velocity ' + IDOUT( 7, 3) = 'Bedform parameters ' + IDOUT( 7, 4) = 'Energy diss. in WBBL' + IDOUT( 7, 5) = 'Moment. loss in WBBL' + ! IDOUT( 7, 6) = 'Bottom mean period ' + ! IDOUT( 7, 7) = 'Bottom mean direct ' + ! IDOUT( 7, 8) = 'Bottom direct spread' + ! IDOUT( 7, 9) = 'Calc grain rough K_N' + ! + ! 8) Spectrum parameters + ! + NOGE(8) = 5 + ! + IDOUT( 8, 1) = 'Mean square slopes ' + IDOUT( 8, 2) = 'Phillips tail const' + IDOUT( 8, 3) = 'Slope direction ' + IDOUT( 8, 4) = 'Tail slope direction' + IDOUT( 8, 5) = 'Goda peakedness parm' + ! IDOUT( 8, 3) = 'Lx-Ly mean wvlength' + ! IDOUT( 8, 4) = 'Surf grad correl XT' + ! IDOUT( 8, 5) = 'Surf grad correl YT' + ! IDOUT( 8, 6) = 'Surf grad correl XY' + ! IDOUT( 8, 7) = 'Surface crest param' + ! IDOUT( 8, 3) = '3rd spectral moment ' + ! IDOUT( 8, 4) = '4th spectral moment ' + ! IDOUT( 8, 6) = 'Kurtosis ' + ! IDOUT( 8, 7) = 'Skewness ' + ! + ! 9) Numerical diagnostics + ! + NOGE(9) = 5 + ! + IDOUT( 9, 1) = 'Avg. time step. ' + IDOUT( 9, 2) = 'Cut-off freq. ' + IDOUT( 9, 3) = 'Maximum spatial CFL ' + IDOUT( 9, 4) = 'Maximum angular CFL ' + IDOUT( 9, 5) = 'Maximum k advect CFL' + ! IDOUT( 9, 6) = 'Avg intrsp proptstep' + ! + ! 10) User defined + ! + NOGE(10) = NOEXTR + ! + DO I=1, MIN ( 20 , NOEXTR ) + WRITE (STRING,'(A14,I2.2,A4)') 'User defined #', I, ' ' + IDOUT(10, I) = STRING + END DO + ! #ifdef W3_T - WRITE (NDSTST,9000) NGRIDS -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3NOUT : NGRIDS NOT YET SET *** '/ & - ' NGRIDS = ',I10/ & - ' RUN W3NMOD FIRST'/) -! + WRITE (NDSTST,9000) NGRIDS +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3NOUT : NGRIDS NOT YET SET *** '/ & + ' NGRIDS = ',I10/ & + ' RUN W3NMOD FIRST'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3NOUT : SETTING UP FOR ',I4,' GRIDS') -#endif -!/ -!/ End of W3NOUT ----------------------------------------------------- / -!/ - END SUBROUTINE W3NOUT -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DMO2 ( IMOD, NDSE, NDST, NPT ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 | -!/ +-----------------------------------+ -!/ -!/ 10-Nov-2004 : Origination. ( version 3.06 ) -!/ 24-Jul-2006 : Adding unified point output storage.( version 3.10 ) -!/ 25-Jul-2006 : Originating grid ID for points. ( version 3.10 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Initialize an individual data storage for point output. -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! NPT Int. I Array size. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation below. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOPO Subr. W3IOPOMD Point output module. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - W3SETO needs to be called after allocation to point to -! proper allocated arrays. -! - Note that NOPTS is overwritten in W3IOPP. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: W3SETG, NGRIDS, NAUXGR, IGRID, NSPEC - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST, NPT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID, NLOW +9000 FORMAT (' TEST W3NOUT : SETTING UP FOR ',I4,' GRIDS') +#endif + !/ + !/ End of W3NOUT ----------------------------------------------------- / + !/ + END SUBROUTINE W3NOUT + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DMO2 ( IMOD, NDSE, NDST, NPT ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 | + !/ +-----------------------------------+ + !/ + !/ 10-Nov-2004 : Origination. ( version 3.06 ) + !/ 24-Jul-2006 : Adding unified point output storage.( version 3.10 ) + !/ 25-Jul-2006 : Originating grid ID for points. ( version 3.10 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data storage for point output. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! NPT Int. I Array size. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation below. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOPO Subr. W3IOPOMD Point output module. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - W3SETO needs to be called after allocation to point to + ! proper allocated arrays. + ! - Note that NOPTS is overwritten in W3IOPP. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: W3SETG, NGRIDS, NAUXGR, IGRID, NSPEC + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST, NPT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID, NLOW #ifdef W3_S - CALL STRACE (IENT, 'W3DMO2') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - NLOW = MIN ( 0 , -NAUXGR ) - IF ( IMOD.LT.NLOW .OR. IMOD.GT.NOUTP ) THEN - WRITE (NDSE,1002) IMOD, NLOW, NOUTP - CALL EXTCDE (2) - END IF -! - IF ( OUTPTS(IMOD)%OUT2%O2INIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -! + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DMO2') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + NLOW = MIN ( 0 , -NAUXGR ) + IF ( IMOD.LT.NLOW .OR. IMOD.GT.NOUTP ) THEN + WRITE (NDSE,1002) IMOD, NLOW, NOUTP + CALL EXTCDE (2) + END IF + ! + IF ( OUTPTS(IMOD)%OUT2%O2INIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! - JGRID = IGRID - IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! - ALLOCATE ( OUTPTS(IMOD)%OUT2%IPTINT(2,4,NPT) , & - OUTPTS(IMOD)%OUT2%IL(NPT) , & - OUTPTS(IMOD)%OUT2%IW(NPT) , & - OUTPTS(IMOD)%OUT2%II(NPT) , & - OUTPTS(IMOD)%OUT2%PTIFAC(4,NPT) , & - OUTPTS(IMOD)%OUT2%PTNME(NPT) , & - OUTPTS(IMOD)%OUT2%GRDID(NPT) , & - OUTPTS(IMOD)%OUT2%DPO(NPT) , & - OUTPTS(IMOD)%OUT2%WAO(NPT) , & - OUTPTS(IMOD)%OUT2%ZET_SETO(NPT) , & - OUTPTS(IMOD)%OUT2%WDO(NPT) , & - OUTPTS(IMOD)%OUT2%ASO(NPT) , & + WRITE (NDST,9000) IMOD +#endif + ! + JGRID = IGRID + IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + ALLOCATE ( OUTPTS(IMOD)%OUT2%IPTINT(2,4,NPT) , & + OUTPTS(IMOD)%OUT2%IL(NPT) , & + OUTPTS(IMOD)%OUT2%IW(NPT) , & + OUTPTS(IMOD)%OUT2%II(NPT) , & + OUTPTS(IMOD)%OUT2%PTIFAC(4,NPT) , & + OUTPTS(IMOD)%OUT2%PTNME(NPT) , & + OUTPTS(IMOD)%OUT2%GRDID(NPT) , & + OUTPTS(IMOD)%OUT2%DPO(NPT) , & + OUTPTS(IMOD)%OUT2%WAO(NPT) , & + OUTPTS(IMOD)%OUT2%ZET_SETO(NPT) , & + OUTPTS(IMOD)%OUT2%WDO(NPT) , & + OUTPTS(IMOD)%OUT2%ASO(NPT) , & #ifdef W3_FLX5 - OUTPTS(IMOD)%OUT2%TAUAO(NPT) , & - OUTPTS(IMOD)%OUT2%TAUDO(NPT) , & - OUTPTS(IMOD)%OUT2%DAIRO(NPT) , & -#endif - OUTPTS(IMOD)%OUT2%CAO(NPT) , & - OUTPTS(IMOD)%OUT2%CDO(NPT) , & - OUTPTS(IMOD)%OUT2%ICEO(NPT) , & - OUTPTS(IMOD)%OUT2%ICEHO(NPT) , & - OUTPTS(IMOD)%OUT2%ICEFO(NPT) , & - OUTPTS(IMOD)%OUT2%SPCO(NSPEC,NPT) , & - OUTPTS(IMOD)%OUT2%PTLOC(2,NPT) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - OUTPTS(IMOD)%OUT2%O2INIT = .TRUE. -! + OUTPTS(IMOD)%OUT2%TAUAO(NPT) , & + OUTPTS(IMOD)%OUT2%TAUDO(NPT) , & + OUTPTS(IMOD)%OUT2%DAIRO(NPT) , & +#endif + OUTPTS(IMOD)%OUT2%CAO(NPT) , & + OUTPTS(IMOD)%OUT2%CDO(NPT) , & + OUTPTS(IMOD)%OUT2%ICEO(NPT) , & + OUTPTS(IMOD)%OUT2%ICEHO(NPT) , & + OUTPTS(IMOD)%OUT2%ICEFO(NPT) , & + OUTPTS(IMOD)%OUT2%SPCO(NSPEC,NPT) , & + OUTPTS(IMOD)%OUT2%PTLOC(2,NPT) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + OUTPTS(IMOD)%OUT2%O2INIT = .TRUE. + ! #ifdef W3_T - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETO ( IMOD, NDSE, NDST ) -! + WRITE (NDST,9001) +#endif + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETO ( IMOD, NDSE, NDST ) + ! #ifdef W3_T - WRITE (NDST,9002) -#endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! - NOPTS = NPT -! + WRITE (NDST,9002) +#endif + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! + NOPTS = NPT + ! #ifdef W3_T - WRITE (NDST,9003) -#endif -! -! -------------------------------------------------------------------- / -! 5. Restore previous grid setting if necessary -! - IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DMO2 : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DMO2 : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NLOW = ',I10/ & - ' NOUTP = ',I10/) - 1003 FORMAT (/' *** ERROR W3DMO2 : ARRAY(S) ALREADY ALLOCATED *** ') -! + WRITE (NDST,9003) +#endif + ! + ! -------------------------------------------------------------------- / + ! 5. Restore previous grid setting if necessary + ! + IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DMO2 : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DMO2 : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NLOW = ',I10/ & + ' NOUTP = ',I10/) +1003 FORMAT (/' *** ERROR W3DMO2 : ARRAY(S) ALREADY ALLOCATED *** ') + ! #ifdef W3_T - 9000 FORMAT (' TEST W3DMO2 : MODEL ',I4) - 9001 FORMAT (' TEST W3DMO2 : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DMO2 : POINTERS RESET') - 9003 FORMAT (' TEST W3DMO2 : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DMO2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3DMO2 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DMO3 ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 24-Nov-2004 : Origination. ( version 3.06 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Initialize an individual data storage for track output. -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation below. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOTR Subr. W3IOTRMD Track output module. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - W3SETO needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD, !/DIST, !/MPI -! Shared / distributed memory model -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: W3SETG, NGRIDS, IGRID, NX, NY - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT (' TEST W3DMO2 : MODEL ',I4) +9001 FORMAT (' TEST W3DMO2 : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DMO2 : POINTERS RESET') +9003 FORMAT (' TEST W3DMO2 : DIMENSIONS STORED') +#endif + !/ + !/ End of W3DMO2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3DMO2 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DMO3 ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 24-Nov-2004 : Origination. ( version 3.06 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data storage for track output. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation below. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOTR Subr. W3IOTRMD Track output module. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - W3SETO needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD, !/DIST, !/MPI + ! Shared / distributed memory model + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: W3SETG, NGRIDS, IGRID, NX, NY + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID + USE W3SERVMD, ONLY: STRACE +#endif + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3DMO3') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NOUTP ) THEN - WRITE (NDSE,1002) IMOD, NOUTP - CALL EXTCDE (2) - END IF -! - IF ( OUTPTS(IMOD)%OUT3%O3INIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -! + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DMO3') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NOUTP ) THEN + WRITE (NDSE,1002) IMOD, NOUTP + CALL EXTCDE (2) + END IF + ! + IF ( OUTPTS(IMOD)%OUT3%O3INIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! - JGRID = IGRID - IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! - ALLOCATE ( OUTPTS(IMOD)%OUT3%MASK1(NY,NX) , & - OUTPTS(IMOD)%OUT3%MASK2(NY,NX) , & - OUTPTS(IMOD)%OUT3%TRCKID(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - OUTPTS(IMOD)%OUT3%O3INIT = .TRUE. -! + WRITE (NDST,9000) IMOD +#endif + ! + JGRID = IGRID + IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + ALLOCATE ( OUTPTS(IMOD)%OUT3%MASK1(NY,NX) , & + OUTPTS(IMOD)%OUT3%MASK2(NY,NX) , & + OUTPTS(IMOD)%OUT3%TRCKID(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + OUTPTS(IMOD)%OUT3%O3INIT = .TRUE. + ! #ifdef W3_T - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETO ( IMOD, NDSE, NDST ) -! + WRITE (NDST,9001) +#endif + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETO ( IMOD, NDSE, NDST ) + ! #ifdef W3_T - WRITE (NDST,9002) + WRITE (NDST,9002) #endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! #ifdef W3_T - WRITE (NDST,9003) -#endif -! -! -------------------------------------------------------------------- / -! 5. Restore previous grid setting if necessary -! - IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DMO3 : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DMO3 : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NOUTP = ',I10/) - 1003 FORMAT (/' *** ERROR W3DMO3 : ARRAY(S) ALREADY ALLOCATED *** ') -! + WRITE (NDST,9003) +#endif + ! + ! -------------------------------------------------------------------- / + ! 5. Restore previous grid setting if necessary + ! + IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DMO3 : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DMO3 : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NOUTP = ',I10/) +1003 FORMAT (/' *** ERROR W3DMO3 : ARRAY(S) ALREADY ALLOCATED *** ') + ! #ifdef W3_T - 9000 FORMAT (' TEST W3DMO3 : MODEL ',I4) - 9001 FORMAT (' TEST W3DMO3 : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DMO3 : POINTERS RESET') - 9003 FORMAT (' TEST W3DMO3 : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DMO3 ----------------------------------------------------- / -!/ - END SUBROUTINE W3DMO3 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DMO5 ( IMOD, NDSE, NDST, IBLOCK ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 13-Dec-2004 : Origination. ( version 3.06 ) -!/ 06-Sep-2005 : Second storage for input bound. sp. ( version 3.08 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Initialize an individual data storage for boundary data. -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! IBLOCK Int. I Select block to allocate. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation below. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOBC Subr. W3IOBCMD Boundary data output module. -! W3IOGR Subr. W3IOGRMD Grid data output module. -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! WW3_GRID Prog. N/A Grid preprocessing program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: W3SETG, NGRIDS, IGRID, NX, NY, NSPEC - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT (' TEST W3DMO3 : MODEL ',I4) +9001 FORMAT (' TEST W3DMO3 : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DMO3 : POINTERS RESET') +9003 FORMAT (' TEST W3DMO3 : DIMENSIONS STORED') +#endif + !/ + !/ End of W3DMO3 ----------------------------------------------------- / + !/ + END SUBROUTINE W3DMO3 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DMO5 ( IMOD, NDSE, NDST, IBLOCK ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 13-Dec-2004 : Origination. ( version 3.06 ) + !/ 06-Sep-2005 : Second storage for input bound. sp. ( version 3.08 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data storage for boundary data. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! IBLOCK Int. I Select block to allocate. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation below. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOBC Subr. W3IOBCMD Boundary data output module. + ! W3IOGR Subr. W3IOGRMD Grid data output module. + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! WW3_GRID Prog. N/A Grid preprocessing program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: W3SETG, NGRIDS, IGRID, NX, NY, NSPEC + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST, IBLOCK -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST, IBLOCK + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID #ifdef W3_S - CALL STRACE (IENT, 'W3DMO5') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NOUTP ) THEN - WRITE (NDSE,1002) IMOD, NOUTP - CALL EXTCDE (2) - END IF -! + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DMO5') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NOUTP ) THEN + WRITE (NDSE,1002) IMOD, NOUTP + CALL EXTCDE (2) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD, IBLOCK -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays and reset pointers -! - SELECT CASE (IBLOCK) -! - CASE (1) -! - ALLOCATE ( OUTPTS(IMOD)%OUT5%IPBPI(NBI,4), & - OUTPTS(IMOD)%OUT5%ISBPI(NBI) , & - OUTPTS(IMOD)%OUT5%XBPI(NBI) , & - OUTPTS(IMOD)%OUT5%YBPI(NBI) , & - OUTPTS(IMOD)%OUT5%RDBPI(NBI,4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - IPBPI => OUTPTS(IMOD)%OUT5%IPBPI - ISBPI => OUTPTS(IMOD)%OUT5%ISBPI - XBPI => OUTPTS(IMOD)%OUT5%XBPI - YBPI => OUTPTS(IMOD)%OUT5%YBPI - RDBPI => OUTPTS(IMOD)%OUT5%RDBPI -! - OUTPTS(IMOD)%OUT5%O5INI1 = .TRUE. -! - CASE (2) -! - ALLOCATE ( OUTPTS(IMOD)%OUT5%IPBPO(NBO(NFBPO),4), & - OUTPTS(IMOD)%OUT5%ISBPO(4*NBO(NFBPO)), & - OUTPTS(IMOD)%OUT5%XBPO(NBO(NFBPO)) , & - OUTPTS(IMOD)%OUT5%YBPO(NBO(NFBPO)) , & - OUTPTS(IMOD)%OUT5%RDBPO(NBO(NFBPO),4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - IPBPO => OUTPTS(IMOD)%OUT5%IPBPO - ISBPO => OUTPTS(IMOD)%OUT5%ISBPO - XBPO => OUTPTS(IMOD)%OUT5%XBPO - YBPO => OUTPTS(IMOD)%OUT5%YBPO - RDBPO => OUTPTS(IMOD)%OUT5%RDBPO -! - OUTPTS(IMOD)%OUT5%O5INI2 = .TRUE. - OUTPTS(IMOD)%OUT5%ISBPO = 0 -! - CASE (3) -! - ALLOCATE ( OUTPTS(IMOD)%OUT5%ABPI0(NSPEC,0:NBI2), & - OUTPTS(IMOD)%OUT5%ABPIN(NSPEC,0:NBI2), & - OUTPTS(IMOD)%OUT5%BBPI0(NSPEC,0:NBI), & - OUTPTS(IMOD)%OUT5%BBPIN(NSPEC,0:NBI), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - ABPI0 => OUTPTS(IMOD)%OUT5%ABPI0 - ABPIN => OUTPTS(IMOD)%OUT5%ABPIN - BBPI0 => OUTPTS(IMOD)%OUT5%BBPI0 - BBPIN => OUTPTS(IMOD)%OUT5%BBPIN - BBPI0 = -1. -! - OUTPTS(IMOD)%OUT5%O5INI3 = .TRUE. -! - CASE (4) -! - ALLOCATE ( OUTPTS(IMOD)%OUT5%ABPOS(NSPEC,0:NBO2(NFBPO)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - ABPOS => OUTPTS(IMOD)%OUT5%ABPOS -! - OUTPTS(IMOD)%OUT5%O5INI4 = .TRUE. -! - CASE DEFAULT - WRITE (NDSE,1010) - CALL EXTCDE (10) -! - END SELECT -! + WRITE (NDST,9000) IMOD, IBLOCK +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays and reset pointers + ! + SELECT CASE (IBLOCK) + ! + CASE (1) + ! + ALLOCATE ( OUTPTS(IMOD)%OUT5%IPBPI(NBI,4), & + OUTPTS(IMOD)%OUT5%ISBPI(NBI) , & + OUTPTS(IMOD)%OUT5%XBPI(NBI) , & + OUTPTS(IMOD)%OUT5%YBPI(NBI) , & + OUTPTS(IMOD)%OUT5%RDBPI(NBI,4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + IPBPI => OUTPTS(IMOD)%OUT5%IPBPI + ISBPI => OUTPTS(IMOD)%OUT5%ISBPI + XBPI => OUTPTS(IMOD)%OUT5%XBPI + YBPI => OUTPTS(IMOD)%OUT5%YBPI + RDBPI => OUTPTS(IMOD)%OUT5%RDBPI + ! + OUTPTS(IMOD)%OUT5%O5INI1 = .TRUE. + ! + CASE (2) + ! + ALLOCATE ( OUTPTS(IMOD)%OUT5%IPBPO(NBO(NFBPO),4), & + OUTPTS(IMOD)%OUT5%ISBPO(4*NBO(NFBPO)), & + OUTPTS(IMOD)%OUT5%XBPO(NBO(NFBPO)) , & + OUTPTS(IMOD)%OUT5%YBPO(NBO(NFBPO)) , & + OUTPTS(IMOD)%OUT5%RDBPO(NBO(NFBPO),4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + IPBPO => OUTPTS(IMOD)%OUT5%IPBPO + ISBPO => OUTPTS(IMOD)%OUT5%ISBPO + XBPO => OUTPTS(IMOD)%OUT5%XBPO + YBPO => OUTPTS(IMOD)%OUT5%YBPO + RDBPO => OUTPTS(IMOD)%OUT5%RDBPO + ! + OUTPTS(IMOD)%OUT5%O5INI2 = .TRUE. + OUTPTS(IMOD)%OUT5%ISBPO = 0 + ! + CASE (3) + ! + ALLOCATE ( OUTPTS(IMOD)%OUT5%ABPI0(NSPEC,0:NBI2), & + OUTPTS(IMOD)%OUT5%ABPIN(NSPEC,0:NBI2), & + OUTPTS(IMOD)%OUT5%BBPI0(NSPEC,0:NBI), & + OUTPTS(IMOD)%OUT5%BBPIN(NSPEC,0:NBI), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + ABPI0 => OUTPTS(IMOD)%OUT5%ABPI0 + ABPIN => OUTPTS(IMOD)%OUT5%ABPIN + BBPI0 => OUTPTS(IMOD)%OUT5%BBPI0 + BBPIN => OUTPTS(IMOD)%OUT5%BBPIN + BBPI0 = -1. + ! + OUTPTS(IMOD)%OUT5%O5INI3 = .TRUE. + ! + CASE (4) + ! + ALLOCATE ( OUTPTS(IMOD)%OUT5%ABPOS(NSPEC,0:NBO2(NFBPO)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + ABPOS => OUTPTS(IMOD)%OUT5%ABPOS + ! + OUTPTS(IMOD)%OUT5%O5INI4 = .TRUE. + ! + CASE DEFAULT + WRITE (NDSE,1010) + CALL EXTCDE (10) + ! + END SELECT + ! #ifdef W3_T - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DMO5 : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DMO5 : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NOUTP = ',I10/) - 1010 FORMAT (/' *** ERROR W3DMO5 : ILLEGAL BLOCK NUMBER *** '/ & - ' IBLOCK = ',I10/) -! + WRITE (NDST,9001) +#endif + ! + ! -------------------------------------------------------------------- / + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DMO5 : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DMO5 : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NOUTP = ',I10/) +1010 FORMAT (/' *** ERROR W3DMO5 : ILLEGAL BLOCK NUMBER *** '/ & + ' IBLOCK = ',I10/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3DMO5 : MODEL AND BLOCK ',2I4) - 9001 FORMAT (' TEST W3DMO5 : ARRAYS ALLOCATED') -#endif -!/ -!/ End of W3DMO5 ----------------------------------------------------- / -!/ - END SUBROUTINE W3DMO5 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-Sep-2020 | -!/ +-----------------------------------+ -!/ -!/ 13-Dec-2004 : Origination. ( version 3.06 ) -!/ 06-Sep-2005 : Second storage for input bound. sp. ( version 3.08 ) -!/ 24-Jul-2006 : Adding unified point output storage.( version 3.10 ) -!/ 25-Jul-2006 : Originating grid ID for points. ( version 3.10 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 30-Oct-2006 : Add pars for partitioning. ( version 3.10 ) -!/ 26-Mar-2007 : Add pars for partitioning. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 27-Jul-2010 : Add NKI, NTHI, XFRI, FR1I, TH1I. ( version 3.14.3 ) -!/ 19-Dec-2012 : Move NOSWLL to data structure. ( version 4.11 ) -!/ 12-Dec-2014 : Modify instanciation of NRQTR ( version 5.04 ) -!/ 25-Sep-2020 : Flags for coupling restart ( version 7.10 ) -!/ -! 1. Purpose : -! -! Select one of the WAVEWATCH III grids / models. -! -! 2. Method : -! -! Point pointers to the proper variables in the proper element of -! the GRIDS array. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSERR Int. I Error output unit number. -! NDSTST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation below. -! -! 5. Called by : -! -! Many subroutines in the WAVEWATCH system. -! -! 6. Error messages : -! -! Checks on parameter list IMOD. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/MPI MPI specific calls. -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NAUXGR - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT (' TEST W3DMO5 : MODEL AND BLOCK ',2I4) +9001 FORMAT (' TEST W3DMO5 : ARRAYS ALLOCATED') +#endif + !/ + !/ End of W3DMO5 ----------------------------------------------------- / + !/ + END SUBROUTINE W3DMO5 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-Sep-2020 | + !/ +-----------------------------------+ + !/ + !/ 13-Dec-2004 : Origination. ( version 3.06 ) + !/ 06-Sep-2005 : Second storage for input bound. sp. ( version 3.08 ) + !/ 24-Jul-2006 : Adding unified point output storage.( version 3.10 ) + !/ 25-Jul-2006 : Originating grid ID for points. ( version 3.10 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 30-Oct-2006 : Add pars for partitioning. ( version 3.10 ) + !/ 26-Mar-2007 : Add pars for partitioning. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 27-Jul-2010 : Add NKI, NTHI, XFRI, FR1I, TH1I. ( version 3.14.3 ) + !/ 19-Dec-2012 : Move NOSWLL to data structure. ( version 4.11 ) + !/ 12-Dec-2014 : Modify instanciation of NRQTR ( version 5.04 ) + !/ 25-Sep-2020 : Flags for coupling restart ( version 7.10 ) + !/ + ! 1. Purpose : + ! + ! Select one of the WAVEWATCH III grids / models. + ! + ! 2. Method : + ! + ! Point pointers to the proper variables in the proper element of + ! the GRIDS array. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSERR Int. I Error output unit number. + ! NDSTST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation below. + ! + ! 5. Called by : + ! + ! Many subroutines in the WAVEWATCH system. + ! + ! 6. Error messages : + ! + ! Checks on parameter list IMOD. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/MPI MPI specific calls. + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NAUXGR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSERR, NDSTST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NLOW - INTEGER :: J -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSERR, NDSTST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NLOW + INTEGER :: J #ifdef W3_S - CALL STRACE (IENT, 'W3SETO') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NOUTP .EQ. -1 ) THEN - WRITE (NDSERR,1001) - CALL EXTCDE (1) - END IF -! - NLOW = MIN ( 0 , -NAUXGR ) - IF ( IMOD.LT.NLOW .OR. IMOD.GT.NOUTP ) THEN - WRITE (NDSERR,1002) IMOD, NLOW, NOUTP - CALL EXTCDE (2) - END IF -! + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SETO') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NOUTP .EQ. -1 ) THEN + WRITE (NDSERR,1001) + CALL EXTCDE (1) + END IF + ! + NLOW = MIN ( 0 , -NAUXGR ) + IF ( IMOD.LT.NLOW .OR. IMOD.GT.NOUTP ) THEN + WRITE (NDSERR,1002) IMOD, NLOW, NOUTP + CALL EXTCDE (2) + END IF + ! #ifdef W3_T - WRITE (NDSTST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Set model number -! - IOUTP = IMOD -! -! -------------------------------------------------------------------- / -! 3. Set pointers in structure OUTPUT -! - NDSO => OUTPTS(IMOD)%NDSO - NDSE => OUTPTS(IMOD)%NDSE - NDST => OUTPTS(IMOD)%NDST - SCREEN => OUTPTS(IMOD)%SCREEN -! - NTPROC => OUTPTS(IMOD)%NTPROC - NAPROC => OUTPTS(IMOD)%NAPROC - IAPROC => OUTPTS(IMOD)%IAPROC - NAPLOG => OUTPTS(IMOD)%NAPLOG - NAPOUT => OUTPTS(IMOD)%NAPOUT - NAPERR => OUTPTS(IMOD)%NAPERR - NAPFLD => OUTPTS(IMOD)%NAPFLD - NAPPNT => OUTPTS(IMOD)%NAPPNT - NAPTRK => OUTPTS(IMOD)%NAPTRK - NAPRST => OUTPTS(IMOD)%NAPRST - NAPBPT => OUTPTS(IMOD)%NAPBPT - NAPPRT => OUTPTS(IMOD)%NAPPRT -! - NOSWLL => OUTPTS(IMOD)%NOSWLL -! + WRITE (NDSTST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Set model number + ! + IOUTP = IMOD + ! + ! -------------------------------------------------------------------- / + ! 3. Set pointers in structure OUTPUT + ! + NDSO => OUTPTS(IMOD)%NDSO + NDSE => OUTPTS(IMOD)%NDSE + NDST => OUTPTS(IMOD)%NDST + SCREEN => OUTPTS(IMOD)%SCREEN + ! + NTPROC => OUTPTS(IMOD)%NTPROC + NAPROC => OUTPTS(IMOD)%NAPROC + IAPROC => OUTPTS(IMOD)%IAPROC + NAPLOG => OUTPTS(IMOD)%NAPLOG + NAPOUT => OUTPTS(IMOD)%NAPOUT + NAPERR => OUTPTS(IMOD)%NAPERR + NAPFLD => OUTPTS(IMOD)%NAPFLD + NAPPNT => OUTPTS(IMOD)%NAPPNT + NAPTRK => OUTPTS(IMOD)%NAPTRK + NAPRST => OUTPTS(IMOD)%NAPRST + NAPBPT => OUTPTS(IMOD)%NAPBPT + NAPPRT => OUTPTS(IMOD)%NAPPRT + ! + NOSWLL => OUTPTS(IMOD)%NOSWLL + ! #ifdef W3_NL5 - TOSNL5 => OUTPTS(IMOD)%TOSNL5 -#endif - TOFRST => OUTPTS(IMOD)%TOFRST - TONEXT => OUTPTS(IMOD)%TONEXT - TOLAST => OUTPTS(IMOD)%TOLAST - TBPI0 => OUTPTS(IMOD)%TBPI0 - TBPIN => OUTPTS(IMOD)%TBPIN - NDS => OUTPTS(IMOD)%NDS - OFILES => OUTPTS(IMOD)%OFILES -! - DTOUT => OUTPTS(IMOD)%DTOUT - FLOUT => OUTPTS(IMOD)%FLOUT -! - IPASS1 => OUTPTS(IMOD)%OUT1%IPASS1 - WRITE1 => OUTPTS(IMOD)%OUT1%WRITE1 + TOSNL5 => OUTPTS(IMOD)%TOSNL5 +#endif + TOFRST => OUTPTS(IMOD)%TOFRST + TONEXT => OUTPTS(IMOD)%TONEXT + TOLAST => OUTPTS(IMOD)%TOLAST + TBPI0 => OUTPTS(IMOD)%TBPI0 + TBPIN => OUTPTS(IMOD)%TBPIN + NDS => OUTPTS(IMOD)%NDS + OFILES => OUTPTS(IMOD)%OFILES + ! + DTOUT => OUTPTS(IMOD)%DTOUT + FLOUT => OUTPTS(IMOD)%FLOUT + ! + IPASS1 => OUTPTS(IMOD)%OUT1%IPASS1 + WRITE1 => OUTPTS(IMOD)%OUT1%WRITE1 #ifdef W3_MPI - NRQGO => OUTPTS(IMOD)%OUT1%NRQGO - NRQGO2 => OUTPTS(IMOD)%OUT1%NRQGO2 - IF ( NRQGO .NE. 0 ) IRQGO => OUTPTS(IMOD)%OUT1%IRQGO - IF ( NRQGO2 .NE. 0 ) IRQGO2 => OUTPTS(IMOD)%OUT1%IRQGO2 -#endif - FLOGRD => OUTPTS(IMOD)%OUT1%FLOGRD - FLOGR2 => OUTPTS(IMOD)%OUT1%FLOGR2 - FLOGRR => OUTPTS(IMOD)%OUT1%FLOGRR - FLOGD => OUTPTS(IMOD)%OUT1%FLOGD - FLOG2 => OUTPTS(IMOD)%OUT1%FLOG2 - FLOGR => OUTPTS(IMOD)%OUT1%FLOGR -! - IPASS2 => OUTPTS(IMOD)%OUT2%IPASS2 - NOPTS => OUTPTS(IMOD)%OUT2%NOPTS + NRQGO => OUTPTS(IMOD)%OUT1%NRQGO + NRQGO2 => OUTPTS(IMOD)%OUT1%NRQGO2 + IF ( NRQGO .NE. 0 ) IRQGO => OUTPTS(IMOD)%OUT1%IRQGO + IF ( NRQGO2 .NE. 0 ) IRQGO2 => OUTPTS(IMOD)%OUT1%IRQGO2 +#endif + FLOGRD => OUTPTS(IMOD)%OUT1%FLOGRD + FLOGR2 => OUTPTS(IMOD)%OUT1%FLOGR2 + FLOGRR => OUTPTS(IMOD)%OUT1%FLOGRR + FLOGD => OUTPTS(IMOD)%OUT1%FLOGD + FLOG2 => OUTPTS(IMOD)%OUT1%FLOG2 + FLOGR => OUTPTS(IMOD)%OUT1%FLOGR + ! + IPASS2 => OUTPTS(IMOD)%OUT2%IPASS2 + NOPTS => OUTPTS(IMOD)%OUT2%NOPTS #ifdef W3_MPI - NRQPO => OUTPTS(IMOD)%OUT2%NRQPO - NRQPO2 => OUTPTS(IMOD)%OUT2%NRQPO2 + NRQPO => OUTPTS(IMOD)%OUT2%NRQPO + NRQPO2 => OUTPTS(IMOD)%OUT2%NRQPO2 #endif - O2INIT => OUTPTS(IMOD)%OUT2%O2INIT + O2INIT => OUTPTS(IMOD)%OUT2%O2INIT #ifdef W3_MPI - O2IRQI => OUTPTS(IMOD)%OUT2%O2IRQI -#endif -! - IF ( O2INIT ) THEN - IPTINT => OUTPTS(IMOD)%OUT2%IPTINT - IL => OUTPTS(IMOD)%OUT2%IL - IW => OUTPTS(IMOD)%OUT2%IW - II => OUTPTS(IMOD)%OUT2%II - PTLOC => OUTPTS(IMOD)%OUT2%PTLOC - PTIFAC => OUTPTS(IMOD)%OUT2%PTIFAC - DPO => OUTPTS(IMOD)%OUT2%DPO - WAO => OUTPTS(IMOD)%OUT2%WAO - ZET_SETO => OUTPTS(IMOD)%OUT2%ZET_SETO - WDO => OUTPTS(IMOD)%OUT2%WDO - ASO => OUTPTS(IMOD)%OUT2%ASO + O2IRQI => OUTPTS(IMOD)%OUT2%O2IRQI +#endif + ! + IF ( O2INIT ) THEN + IPTINT => OUTPTS(IMOD)%OUT2%IPTINT + IL => OUTPTS(IMOD)%OUT2%IL + IW => OUTPTS(IMOD)%OUT2%IW + II => OUTPTS(IMOD)%OUT2%II + PTLOC => OUTPTS(IMOD)%OUT2%PTLOC + PTIFAC => OUTPTS(IMOD)%OUT2%PTIFAC + DPO => OUTPTS(IMOD)%OUT2%DPO + WAO => OUTPTS(IMOD)%OUT2%WAO + ZET_SETO => OUTPTS(IMOD)%OUT2%ZET_SETO + WDO => OUTPTS(IMOD)%OUT2%WDO + ASO => OUTPTS(IMOD)%OUT2%ASO #ifdef W3_FLX5 - TAUAO => OUTPTS(IMOD)%OUT2%TAUAO - TAUDO => OUTPTS(IMOD)%OUT2%TAUDO - DAIRO => OUTPTS(IMOD)%OUT2%DAIRO -#endif - CAO => OUTPTS(IMOD)%OUT2%CAO - CDO => OUTPTS(IMOD)%OUT2%CDO - ICEO => OUTPTS(IMOD)%OUT2%ICEO - ICEHO => OUTPTS(IMOD)%OUT2%ICEHO - ICEFO => OUTPTS(IMOD)%OUT2%ICEFO - SPCO => OUTPTS(IMOD)%OUT2%SPCO - PTNME => OUTPTS(IMOD)%OUT2%PTNME - GRDID => OUTPTS(IMOD)%OUT2%GRDID - END IF -! + TAUAO => OUTPTS(IMOD)%OUT2%TAUAO + TAUDO => OUTPTS(IMOD)%OUT2%TAUDO + DAIRO => OUTPTS(IMOD)%OUT2%DAIRO +#endif + CAO => OUTPTS(IMOD)%OUT2%CAO + CDO => OUTPTS(IMOD)%OUT2%CDO + ICEO => OUTPTS(IMOD)%OUT2%ICEO + ICEHO => OUTPTS(IMOD)%OUT2%ICEHO + ICEFO => OUTPTS(IMOD)%OUT2%ICEFO + SPCO => OUTPTS(IMOD)%OUT2%SPCO + PTNME => OUTPTS(IMOD)%OUT2%PTNME + GRDID => OUTPTS(IMOD)%OUT2%GRDID + END IF + ! #ifdef W3_MPI - IF ( O2IRQI ) THEN - IRQPO1 => OUTPTS(IMOD)%OUT2%IRQPO1 - IRQPO2 => OUTPTS(IMOD)%OUT2%IRQPO2 - END IF + IF ( O2IRQI ) THEN + IRQPO1 => OUTPTS(IMOD)%OUT2%IRQPO1 + IRQPO2 => OUTPTS(IMOD)%OUT2%IRQPO2 + END IF #endif -! - IPASS3 => OUTPTS(IMOD)%OUT3%IPASS3 + ! + IPASS3 => OUTPTS(IMOD)%OUT3%IPASS3 #ifdef W3_MPI - IT0PNT => OUTPTS(IMOD)%OUT3%IT0PNT - IT0TRK => OUTPTS(IMOD)%OUT3%IT0TRK - IT0PRT => OUTPTS(IMOD)%OUT3%IT0PRT - NRQTR => OUTPTS(IMOD)%OUT3%NRQTR - IF ( NRQTR .NE. 0 ) IRQTR => OUTPTS(IMOD)%OUT3%IRQTR -#endif - O3INIT => OUTPTS(IMOD)%OUT3%O3INIT - STOP => OUTPTS(IMOD)%OUT3%STOP -! - IF ( O3INIT ) THEN - MASK1 => OUTPTS(IMOD)%OUT3%MASK1 - MASK2 => OUTPTS(IMOD)%OUT3%MASK2 - TRCKID => OUTPTS(IMOD)%OUT3%TRCKID - END IF -! - IFILE4 => OUTPTS(IMOD)%OUT4%IFILE4 + IT0PNT => OUTPTS(IMOD)%OUT3%IT0PNT + IT0TRK => OUTPTS(IMOD)%OUT3%IT0TRK + IT0PRT => OUTPTS(IMOD)%OUT3%IT0PRT + NRQTR => OUTPTS(IMOD)%OUT3%NRQTR + IF ( NRQTR .NE. 0 ) IRQTR => OUTPTS(IMOD)%OUT3%IRQTR +#endif + O3INIT => OUTPTS(IMOD)%OUT3%O3INIT + STOP => OUTPTS(IMOD)%OUT3%STOP + ! + IF ( O3INIT ) THEN + MASK1 => OUTPTS(IMOD)%OUT3%MASK1 + MASK2 => OUTPTS(IMOD)%OUT3%MASK2 + TRCKID => OUTPTS(IMOD)%OUT3%TRCKID + END IF + ! + IFILE4 => OUTPTS(IMOD)%OUT4%IFILE4 #ifdef W3_MPI - NRQRS => OUTPTS(IMOD)%OUT4%NRQRS - NBLKRS => OUTPTS(IMOD)%OUT4%NBLKRS - RSBLKS => OUTPTS(IMOD)%OUT4%RSBLKS - IF ( NRQRS .NE. 0 ) THEN - IRQRS => OUTPTS(IMOD)%OUT4%IRQRS - END IF - IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS - VAAUX => OUTPTS(IMOD)%OUT4%VAAUX -#endif -! - NBI => OUTPTS(IMOD)%OUT5%NBI - NBI2 => OUTPTS(IMOD)%OUT5%NBI2 - NFBPO => OUTPTS(IMOD)%OUT5%NFBPO + NRQRS => OUTPTS(IMOD)%OUT4%NRQRS + NBLKRS => OUTPTS(IMOD)%OUT4%NBLKRS + RSBLKS => OUTPTS(IMOD)%OUT4%RSBLKS + IF ( NRQRS .NE. 0 ) THEN + IRQRS => OUTPTS(IMOD)%OUT4%IRQRS + END IF + IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS + VAAUX => OUTPTS(IMOD)%OUT4%VAAUX +#endif + ! + NBI => OUTPTS(IMOD)%OUT5%NBI + NBI2 => OUTPTS(IMOD)%OUT5%NBI2 + NFBPO => OUTPTS(IMOD)%OUT5%NFBPO #ifdef W3_MPI - NRQBP => OUTPTS(IMOD)%OUT5%NRQBP - NRQBP2 => OUTPTS(IMOD)%OUT5%NRQBP2 -#endif - NBO => OUTPTS(IMOD)%OUT5%NBO - NBO2 => OUTPTS(IMOD)%OUT5%NBO2 - NDSL => OUTPTS(IMOD)%OUT5%NDSL - NKI => OUTPTS(IMOD)%OUT5%NKI - NTHI => OUTPTS(IMOD)%OUT5%NTHI - XFRI => OUTPTS(IMOD)%OUT5%XFRI - FR1I => OUTPTS(IMOD)%OUT5%FR1I - TH1I => OUTPTS(IMOD)%OUT5%TH1I - FLBPI => OUTPTS(IMOD)%OUT5%FLBPI - FLBPO => OUTPTS(IMOD)%OUT5%FLBPO - FILER => OUTPTS(IMOD)%OUT5%FILER - FILEW => OUTPTS(IMOD)%OUT5%FILEW - FILED => OUTPTS(IMOD)%OUT5%FILED - SPCONV => OUTPTS(IMOD)%OUT5%SPCONV - O5INI1 => OUTPTS(IMOD)%OUT5%O5INI1 - O5INI2 => OUTPTS(IMOD)%OUT5%O5INI2 - O5INI3 => OUTPTS(IMOD)%OUT5%O5INI3 - O5INI4 => OUTPTS(IMOD)%OUT5%O5INI4 -! - IF ( O5INI1 ) THEN - IPBPI => OUTPTS(IMOD)%OUT5%IPBPI - ISBPI => OUTPTS(IMOD)%OUT5%ISBPI - XBPI => OUTPTS(IMOD)%OUT5%XBPI - YBPI => OUTPTS(IMOD)%OUT5%YBPI - RDBPI => OUTPTS(IMOD)%OUT5%RDBPI - END IF -! - IF ( O5INI2 ) THEN - IPBPO => OUTPTS(IMOD)%OUT5%IPBPO - ISBPO => OUTPTS(IMOD)%OUT5%ISBPO - XBPO => OUTPTS(IMOD)%OUT5%XBPO - YBPO => OUTPTS(IMOD)%OUT5%YBPO - RDBPO => OUTPTS(IMOD)%OUT5%RDBPO - END IF -! - IF ( O5INI3 ) THEN - ABPI0 => OUTPTS(IMOD)%OUT5%ABPI0 - ABPIN => OUTPTS(IMOD)%OUT5%ABPIN - BBPI0 => OUTPTS(IMOD)%OUT5%BBPI0 - BBPIN => OUTPTS(IMOD)%OUT5%BBPIN - END IF -! - IF ( O5INI4 ) THEN - ABPOS => OUTPTS(IMOD)%OUT5%ABPOS - END IF -! + NRQBP => OUTPTS(IMOD)%OUT5%NRQBP + NRQBP2 => OUTPTS(IMOD)%OUT5%NRQBP2 +#endif + NBO => OUTPTS(IMOD)%OUT5%NBO + NBO2 => OUTPTS(IMOD)%OUT5%NBO2 + NDSL => OUTPTS(IMOD)%OUT5%NDSL + NKI => OUTPTS(IMOD)%OUT5%NKI + NTHI => OUTPTS(IMOD)%OUT5%NTHI + XFRI => OUTPTS(IMOD)%OUT5%XFRI + FR1I => OUTPTS(IMOD)%OUT5%FR1I + TH1I => OUTPTS(IMOD)%OUT5%TH1I + FLBPI => OUTPTS(IMOD)%OUT5%FLBPI + FLBPO => OUTPTS(IMOD)%OUT5%FLBPO + FILER => OUTPTS(IMOD)%OUT5%FILER + FILEW => OUTPTS(IMOD)%OUT5%FILEW + FILED => OUTPTS(IMOD)%OUT5%FILED + SPCONV => OUTPTS(IMOD)%OUT5%SPCONV + O5INI1 => OUTPTS(IMOD)%OUT5%O5INI1 + O5INI2 => OUTPTS(IMOD)%OUT5%O5INI2 + O5INI3 => OUTPTS(IMOD)%OUT5%O5INI3 + O5INI4 => OUTPTS(IMOD)%OUT5%O5INI4 + ! + IF ( O5INI1 ) THEN + IPBPI => OUTPTS(IMOD)%OUT5%IPBPI + ISBPI => OUTPTS(IMOD)%OUT5%ISBPI + XBPI => OUTPTS(IMOD)%OUT5%XBPI + YBPI => OUTPTS(IMOD)%OUT5%YBPI + RDBPI => OUTPTS(IMOD)%OUT5%RDBPI + END IF + ! + IF ( O5INI2 ) THEN + IPBPO => OUTPTS(IMOD)%OUT5%IPBPO + ISBPO => OUTPTS(IMOD)%OUT5%ISBPO + XBPO => OUTPTS(IMOD)%OUT5%XBPO + YBPO => OUTPTS(IMOD)%OUT5%YBPO + RDBPO => OUTPTS(IMOD)%OUT5%RDBPO + END IF + ! + IF ( O5INI3 ) THEN + ABPI0 => OUTPTS(IMOD)%OUT5%ABPI0 + ABPIN => OUTPTS(IMOD)%OUT5%ABPIN + BBPI0 => OUTPTS(IMOD)%OUT5%BBPI0 + BBPIN => OUTPTS(IMOD)%OUT5%BBPIN + END IF + ! + IF ( O5INI4 ) THEN + ABPOS => OUTPTS(IMOD)%OUT5%ABPOS + END IF + ! #ifdef W3_MPI - IF ( NRQBP .NE. 0 ) IRQBP1 => OUTPTS(IMOD)%OUT5%IRQBP1 - IF ( NRQBP2 .NE. 0 ) IRQBP2 => OUTPTS(IMOD)%OUT5%IRQBP2 -#endif -! - IPASS6 => OUTPTS(IMOD)%OUT6%IPASS6 - IHMAX => OUTPTS(IMOD)%OUT6%IHMAX - HSPMIN => OUTPTS(IMOD)%OUT6%HSPMIN - WSMULT => OUTPTS(IMOD)%OUT6%WSMULT - WSCUT => OUTPTS(IMOD)%OUT6%WSCUT - IX0 => OUTPTS(IMOD)%OUT6%IX0 - IXN => OUTPTS(IMOD)%OUT6%IXN - IXS => OUTPTS(IMOD)%OUT6%IXS - IY0 => OUTPTS(IMOD)%OUT6%IY0 - IYN => OUTPTS(IMOD)%OUT6%IYN - IYS => OUTPTS(IMOD)%OUT6%IYS - ICPRT => OUTPTS(IMOD)%OUT6%ICPRT - DTPRT => OUTPTS(IMOD)%OUT6%DTPRT - FLCOMB => OUTPTS(IMOD)%OUT6%FLCOMB - PTMETH => OUTPTS(IMOD)%OUT6%PTMETH - PTFCUT => OUTPTS(IMOD)%OUT6%PTFCUT - FLFORM => OUTPTS(IMOD)%OUT6%FLFORM - O6INIT => OUTPTS(IMOD)%OUT6%O6INIT -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3SETO : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3SETO : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NLOW = ',I10/ & - ' NOUTP = ',I10/) -! + IF ( NRQBP .NE. 0 ) IRQBP1 => OUTPTS(IMOD)%OUT5%IRQBP1 + IF ( NRQBP2 .NE. 0 ) IRQBP2 => OUTPTS(IMOD)%OUT5%IRQBP2 +#endif + ! + IPASS6 => OUTPTS(IMOD)%OUT6%IPASS6 + IHMAX => OUTPTS(IMOD)%OUT6%IHMAX + HSPMIN => OUTPTS(IMOD)%OUT6%HSPMIN + WSMULT => OUTPTS(IMOD)%OUT6%WSMULT + WSCUT => OUTPTS(IMOD)%OUT6%WSCUT + IX0 => OUTPTS(IMOD)%OUT6%IX0 + IXN => OUTPTS(IMOD)%OUT6%IXN + IXS => OUTPTS(IMOD)%OUT6%IXS + IY0 => OUTPTS(IMOD)%OUT6%IY0 + IYN => OUTPTS(IMOD)%OUT6%IYN + IYS => OUTPTS(IMOD)%OUT6%IYS + ICPRT => OUTPTS(IMOD)%OUT6%ICPRT + DTPRT => OUTPTS(IMOD)%OUT6%DTPRT + FLCOMB => OUTPTS(IMOD)%OUT6%FLCOMB + PTMETH => OUTPTS(IMOD)%OUT6%PTMETH + PTFCUT => OUTPTS(IMOD)%OUT6%PTFCUT + FLFORM => OUTPTS(IMOD)%OUT6%FLFORM + O6INIT => OUTPTS(IMOD)%OUT6%O6INIT + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3SETO : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3SETO : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NLOW = ',I10/ & + ' NOUTP = ',I10/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SETO : MODEL ',I4,' SELECTED') -#endif -!/ -!/ End of W3SETO ----------------------------------------------------- / -!/ - END SUBROUTINE W3SETO -!/ -!/ End of module W3ODATMD -------------------------------------------- / -!/ - END MODULE W3ODATMD +9000 FORMAT (' TEST W3SETO : MODEL ',I4,' SELECTED') +#endif + !/ + !/ End of W3SETO ----------------------------------------------------- / + !/ + END SUBROUTINE W3SETO + !/ + !/ End of module W3ODATMD -------------------------------------------- / + !/ +END MODULE W3ODATMD diff --git a/model/src/w3ogcmmd.F90 b/model/src/w3ogcmmd.F90 index cfe365c43..64b10bad4 100644 --- a/model/src/w3ogcmmd.F90 +++ b/model/src/w3ogcmmd.F90 @@ -1,638 +1,638 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3OGCMMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ Jul-2013 : Origination. ( version 4.18 ) -!/ For upgrades see subroutines. -!/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ 22-Mar-2021 : Add extra coupling variables ( version 7.13 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Module used for coupling applications between oceanic model and WW3 with OASIS3-MCT -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! SND_FIELDS_TO_OCEAN Subr. Public Send fields to ocean model -! RCV_FIELDS_FROM_OCEAN Subr. Public Receive fields from ocean model -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! CPL_OASIS_SEND Subr. W3OACPMD Send fields -! CPL_OASIS_RECV Subr. W3OACPMD Receive fields -! ---------------------------------------------------------------- -! -! 5. Remarks -! 6. Switches : -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -! - IMPLICIT NONE -! - INCLUDE "mpif.h" -! - PRIVATE -! -! * Accessibility - PUBLIC SND_FIELDS_TO_OCEAN - PUBLIC RCV_FIELDS_FROM_OCEAN -! - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE SND_FIELDS_TO_OCEAN() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ Jul-2013 : Origination. ( version 4.18 ) -!/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ 22-Mar-2021 : Add extra coupling variables ( version 7.13 ) -!/ -! 1. Purpose : -! -! Send coupling fields to oceanic model -! -! 2. Method : -! 3. Parameters : -! 4. Subroutines used : -! -! Name Type Module Description -! ------------------------------------------------------------------- -! CPL_OASIS_SND Subr. W3OACPMD Send field to atmos/ocean model -! ------------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ------------------------------------------------------------------ -! W3WAVE Subr. W3WAVEMD Wave model -! ------------------------------------------------------------------ -! -! 6. Error messages : -! 7. Remarks : -! -! According to the present implementation, fields are sent at each coupling time step to OASIS -! Consequently, OASIS cannot estimate any time average -! For such an application, one must estimate the fields at each time step -! (or a time step smaller than the coupling time step). -! In such conditions, OASIS get the information every time step -! but only send the information to the other code when the time matches the coupling time. -! -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_SND, SND_FLD, CPL_OASIS_SND - USE W3GDATMD, ONLY: NSEAL, MAPSTA, MAPSF - USE W3ADATMD, ONLY: HS, T0M1, T01, THM, BHD, TAUOX, TAUOY, PHIOC,& - UBA, UBD, TAUWIX, TAUWIY, TUSX, TUSY, USSX, & - USSY, WLM, PHIBBL,TAUBBL, CHARN, TAUOCX, & - TAUOCY, WNMEAN - USE W3ODATMD, ONLY: NAPROC, IAPROC, UNDEF - USE CONSTANTS, ONLY: PI, DERA -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -! -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, ISEA, IX, IY - INTEGER, DIMENSION(NSEAL) :: MASK - REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_SND - INTEGER :: IB_DO - LOGICAL :: LL_ACTION - REAL(kind=8), DIMENSION(NSEAL) :: TMP -! -!---------------------------------------------------------------------- -! * Executable part -! - DO I = 1, NSEAL - ISEA = IAPROC + (I-1)*NAPROC - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - ! Get the mask : 1 - sea 0 - open boundary cells dried cells - MASK(I) = MOD(MAPSTA(IY,IX),2) - END DO - ! - DO IB_DO = 1, IL_NB_SND - ! - ! Mask - wet-drying - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_ODRY') THEN - TMP(1:NSEAL) = 0.0 - WHERE(MASK(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=MASK(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Mean wave period (tmn in s) (m0,-1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_T0M1') THEN - TMP(1:NSEAL) = 0.0 - WHERE(T0M1(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=T0M1(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Mean wave period (tmn in s) (m0,1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__T01') THEN - TMP(1:NSEAL) = 0.0 - WHERE(T01(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=T01(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Mean wave number (wnm in m-1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__WNM') THEN - TMP(1:NSEAL) = 0.0 - WHERE(WNMEAN(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=WNMEAN(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Charnock coefficient (-) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OCHA') THEN - TMP(1:NSEAL) = 0.0 - WHERE(CHARN(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=CHARN(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Wave height (hs in m) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__OHS') THEN - TMP(1:NSEAL) = 0.0 - WHERE(HS(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=HS(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Cosinus of Mean wave direction (cos(theta) in radians) - ! --------------------------------------------------------------------- - ! dir : nautical convention (GRIDDED files) - 0 degree from north, 90 from east - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_CDIR') THEN - TMP(1:NSEAL) = 0.0 - WHERE(THM(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=COS(THM(1:NSEAL)) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Sinus of Mean wave direction (sin(theta) in radians) - ! --------------------------------------------------------------------- - ! dir : nautical convention (GRIDDED files) - 0 degree from north, 90 from east - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_SDIR') THEN - TMP(1:NSEAL) = 0.0 - WHERE(THM(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=SIN(THM(1:NSEAL)) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Mean wave direction theta in radians - ! --------------------------------------------------------------------- - ! dir : nautical convention (GRIDDED files) - 0 degree from north, 90 from east - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__DIR') THEN - TMP(1:NSEAL) = 0.0 - WHERE(THM /= UNDEF) TMP(1:NSEAL)=THM(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Wave-induced Bernoulli head pressure (bhd in N.m-1) (J term, Smith JPO 2006) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__BHD') THEN - TMP(1:NSEAL) = 0.0 - WHERE(BHD(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=BHD(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Wave-ocean momentum flux (tauox in m2.s-2) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TWOX') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TAUOX(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUOX(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Wave-ocean momentum flux (tauoy in m2.s-2) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TWOY') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TAUOY(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUOY(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Wave-ocean total momentum flux (tauocx in Pa) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TOCX') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TAUOCX(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUOCX(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Wave-ocean total momentum flux (tauocy in Pa) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TOCY') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TAUOCY(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUOCY(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Wave-to-ocean TKE flux (phioc in W.m-2) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__FOC') THEN - TMP(1:NSEAL) = 0.0 - WHERE(PHIOC(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=PHIOC(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Momentum flux due to bottom friction (taubblx in m2.s-2) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TBBX') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TAUBBL(1:NSEAL,1) /= UNDEF) TMP(1:NSEAL)=TAUBBL(1:NSEAL,1) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Momentum flux due to bottom friction (taubbly in m2.s-2) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TBBY') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TAUBBL(1:NSEAL,2) /= UNDEF) TMP(1:NSEAL)=TAUBBL(1:NSEAL,2) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Energy flux due to bottom friction (phibbl in W.m-2) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__FBB') THEN - TMP(1:NSEAL) = 0.0 - WHERE(PHIBBL(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=PHIBBL(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! rms amplitude of orbital velocity of the waves (ubr in m.s-1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__UBR') THEN - TMP(1:NSEAL) = 0.0 - WHERE(UBA(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=UBA(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! x component of the near-bottom rms wave velocity (in m.s-1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_UBRX') THEN - TMP(1:NSEAL) = 0.0 - WHERE(UBA(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=UBA(1:NSEAL)*COS(UBD(1:NSEAL)) - RLA_OASIS_SND(:,1) = TMP(1:NSEAL) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! y component of the near-bottom rms wave velocity (in m.s-1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_UBRY') THEN - TMP(1:NSEAL) = 0.0 - WHERE(UBA(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=UBA(1:NSEAL)*SIN(UBD(1:NSEAL)) - RLA_OASIS_SND(:,1) = TMP(1:NSEAL) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Net wave-supported stress, u component (tauwix in m2.s-2) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TAWX') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TAUWIX(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUWIX(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Net wave-supported stress, v component (tauwix in m2.s-2) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TAWY') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TAUWIY(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUWIY(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Volume transport associated to Stokes drift, u component (tusx in m2.s-1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TUSX') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TUSX(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TUSX(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Volume transport associated to Stokes drift, v component (tusy in m2.s-1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TUSY') THEN - TMP(1:NSEAL) = 0.0 - WHERE(TUSY(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TUSY(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Surface Stokes drift, u component (ussx in m.s-1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_USSX') THEN - TMP(1:NSEAL) = 0.0 - WHERE(USSX(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=USSX(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Surface Stokes drift, v component (ussy in m.s-1) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_USSY') THEN - TMP(1:NSEAL) = 0.0 - WHERE(USSY(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=USSY(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ! Mean wave length (wlm in m) - ! --------------------------------------------------------------------- - IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3___LM') THEN - TMP(1:NSEAL) = 0.0 - WHERE(WLM(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=WLM(1:NSEAL) - RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) - CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) - ENDIF - ! - ENDDO -!/ ------------------------------------------------------------------- / - END SUBROUTINE SND_FIELDS_TO_OCEAN -!/ ------------------------------------------------------------------- / - SUBROUTINE RCV_FIELDS_FROM_OCEAN(ID_LCOMM, IDFLD, FXN, FYN, FAN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Thevenin | -!/ | FORTRAN 90 | -!/ | Last update : April-2016 | -!/ +-----------------------------------+ -!/ -!/ Jul-2013 : Origination. ( version 4.18 ) -!/ Apr-2014 : Add IDFLD, FXN, FYX and FAN (M. Accensi) ( version 5.07 ) -!/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) -!/ -! 1. Purpose : -! -! Receive coupling fields from oceanic model -! -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ID_LCOMM Char. I MPI communicator -! IDFLD Int. I Name of the exchange fields -! FXN Int. I/O First exchange field -! FYN Int. I/O Second exchange field -! FAN Int. I/O Third exchange field -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ------------------------------------------------------------------- -! CPL_OASIS_RCV Subr. W3OACPMD Receive fields from atmos/ocean model -! W3S2XY Subr. W3SERVMD Convert from storage (NSEA) to spatial grid (NX, NY) -! ------------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ------------------------------------------------------------------ -! W3FLDG Subr. W3FLDSMD Manage input fields of depth, -! current, wind and ice concentration -! ------------------------------------------------------------------ -! -! 6. Error messages : -! 7. Remarks : -! -! IDFLD C*3 I/O ID string for field type, valid are: 'LEV', 'CUR' (J=1,2) -! -! 8. Structure : -! 9. Switches : -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_RCV, RCV_FLD, CPL_OASIS_RCV - USE W3GDATMD, ONLY: NX, NY, NSEAL, NSEA, MAPSF - USE W3ODATMD, ONLY: NAPROC, IAPROC - USE W3SERVMD, ONLY: W3S2XY -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ID_LCOMM - CHARACTER(LEN=3), INTENT(IN) :: IDFLD - REAL, INTENT(INOUT) :: FXN(:,:), FYN(:,:), FAN(:,:) -! -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - LOGICAL :: LL_ACTION - INTEGER :: IB_DO, IB_I, IB_J, IL_ERR - INTEGER, SAVE :: ID_OASIS_TIME_WETDRYONLYONCE = -1 - REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_RCV - REAL(kind=8), DIMENSION(NSEAL) :: TMP, MASKT, MASKU, MASKV - REAL, DIMENSION(1:NSEA) :: SND_BUFF,RCV_BUFF -! -!---------------------------------------------------------------------- -! * Executable part -! - MASKT(:)=1. - MASKU(:)=1. - MASKV(:)=1. - RLA_OASIS_RCV(:,:) = 0.0 -! -! --------------------------------------------------------------------- -! Perform mask variables -! --------------------------------------------------------------------- -! -! For the same coupling time, W3FLDG is called for the level and current variables. -! As RCV_FIELDS_FROM_OCEAN is called from W3FLDG, the following test prevents to -! exchange the wet-dry variables more than once per coupling time. -!cval well but it cannot work because MASKT,MASKU,MASKV variable are not global variable -!cval Anyway we will give up the exchange of mask, it is not a good idea at all +MODULE W3OGCMMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ Jul-2013 : Origination. ( version 4.18 ) + !/ For upgrades see subroutines. + !/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ 22-Mar-2021 : Add extra coupling variables ( version 7.13 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Module used for coupling applications between oceanic model and WW3 with OASIS3-MCT + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! SND_FIELDS_TO_OCEAN Subr. Public Send fields to ocean model + ! RCV_FIELDS_FROM_OCEAN Subr. Public Receive fields from ocean model + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! CPL_OASIS_SEND Subr. W3OACPMD Send fields + ! CPL_OASIS_RECV Subr. W3OACPMD Receive fields + ! ---------------------------------------------------------------- + ! + ! 5. Remarks + ! 6. Switches : + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + IMPLICIT NONE + ! + INCLUDE "mpif.h" + ! + PRIVATE + ! + ! * Accessibility + PUBLIC SND_FIELDS_TO_OCEAN + PUBLIC RCV_FIELDS_FROM_OCEAN + ! +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE SND_FIELDS_TO_OCEAN() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ Jul-2013 : Origination. ( version 4.18 ) + !/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ 22-Mar-2021 : Add extra coupling variables ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Send coupling fields to oceanic model + ! + ! 2. Method : + ! 3. Parameters : + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------- + ! CPL_OASIS_SND Subr. W3OACPMD Send field to atmos/ocean model + ! ------------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------ + ! W3WAVE Subr. W3WAVEMD Wave model + ! ------------------------------------------------------------------ + ! + ! 6. Error messages : + ! 7. Remarks : + ! + ! According to the present implementation, fields are sent at each coupling time step to OASIS + ! Consequently, OASIS cannot estimate any time average + ! For such an application, one must estimate the fields at each time step + ! (or a time step smaller than the coupling time step). + ! In such conditions, OASIS get the information every time step + ! but only send the information to the other code when the time matches the coupling time. + ! + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_SND, SND_FLD, CPL_OASIS_SND + USE W3GDATMD, ONLY: NSEAL, MAPSTA, MAPSF + USE W3ADATMD, ONLY: HS, T0M1, T01, THM, BHD, TAUOX, TAUOY, PHIOC,& + UBA, UBD, TAUWIX, TAUWIY, TUSX, TUSY, USSX, & + USSY, WLM, PHIBBL,TAUBBL, CHARN, TAUOCX, & + TAUOCY, WNMEAN + USE W3ODATMD, ONLY: NAPROC, IAPROC, UNDEF + USE CONSTANTS, ONLY: PI, DERA + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, ISEA, IX, IY + INTEGER, DIMENSION(NSEAL) :: MASK + REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_SND + INTEGER :: IB_DO + LOGICAL :: LL_ACTION + REAL(kind=8), DIMENSION(NSEAL) :: TMP + ! + !---------------------------------------------------------------------- + ! * Executable part + ! + DO I = 1, NSEAL + ISEA = IAPROC + (I-1)*NAPROC + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + ! Get the mask : 1 - sea 0 - open boundary cells dried cells + MASK(I) = MOD(MAPSTA(IY,IX),2) + END DO + ! + DO IB_DO = 1, IL_NB_SND + ! + ! Mask - wet-drying + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_ODRY') THEN + TMP(1:NSEAL) = 0.0 + WHERE(MASK(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=MASK(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Mean wave period (tmn in s) (m0,-1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_T0M1') THEN + TMP(1:NSEAL) = 0.0 + WHERE(T0M1(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=T0M1(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Mean wave period (tmn in s) (m0,1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__T01') THEN + TMP(1:NSEAL) = 0.0 + WHERE(T01(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=T01(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Mean wave number (wnm in m-1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__WNM') THEN + TMP(1:NSEAL) = 0.0 + WHERE(WNMEAN(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=WNMEAN(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Charnock coefficient (-) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OCHA') THEN + TMP(1:NSEAL) = 0.0 + WHERE(CHARN(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=CHARN(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Wave height (hs in m) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__OHS') THEN + TMP(1:NSEAL) = 0.0 + WHERE(HS(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=HS(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Cosinus of Mean wave direction (cos(theta) in radians) + ! --------------------------------------------------------------------- + ! dir : nautical convention (GRIDDED files) - 0 degree from north, 90 from east + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_CDIR') THEN + TMP(1:NSEAL) = 0.0 + WHERE(THM(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=COS(THM(1:NSEAL)) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Sinus of Mean wave direction (sin(theta) in radians) + ! --------------------------------------------------------------------- + ! dir : nautical convention (GRIDDED files) - 0 degree from north, 90 from east + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_SDIR') THEN + TMP(1:NSEAL) = 0.0 + WHERE(THM(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=SIN(THM(1:NSEAL)) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Mean wave direction theta in radians + ! --------------------------------------------------------------------- + ! dir : nautical convention (GRIDDED files) - 0 degree from north, 90 from east + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__DIR') THEN + TMP(1:NSEAL) = 0.0 + WHERE(THM /= UNDEF) TMP(1:NSEAL)=THM(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Wave-induced Bernoulli head pressure (bhd in N.m-1) (J term, Smith JPO 2006) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__BHD') THEN + TMP(1:NSEAL) = 0.0 + WHERE(BHD(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=BHD(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Wave-ocean momentum flux (tauox in m2.s-2) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TWOX') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TAUOX(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUOX(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Wave-ocean momentum flux (tauoy in m2.s-2) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TWOY') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TAUOY(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUOY(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Wave-ocean total momentum flux (tauocx in Pa) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TOCX') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TAUOCX(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUOCX(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Wave-ocean total momentum flux (tauocy in Pa) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TOCY') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TAUOCY(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUOCY(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Wave-to-ocean TKE flux (phioc in W.m-2) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__FOC') THEN + TMP(1:NSEAL) = 0.0 + WHERE(PHIOC(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=PHIOC(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Momentum flux due to bottom friction (taubblx in m2.s-2) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TBBX') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TAUBBL(1:NSEAL,1) /= UNDEF) TMP(1:NSEAL)=TAUBBL(1:NSEAL,1) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Momentum flux due to bottom friction (taubbly in m2.s-2) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TBBY') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TAUBBL(1:NSEAL,2) /= UNDEF) TMP(1:NSEAL)=TAUBBL(1:NSEAL,2) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Energy flux due to bottom friction (phibbl in W.m-2) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__FBB') THEN + TMP(1:NSEAL) = 0.0 + WHERE(PHIBBL(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=PHIBBL(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! rms amplitude of orbital velocity of the waves (ubr in m.s-1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__UBR') THEN + TMP(1:NSEAL) = 0.0 + WHERE(UBA(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=UBA(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! x component of the near-bottom rms wave velocity (in m.s-1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_UBRX') THEN + TMP(1:NSEAL) = 0.0 + WHERE(UBA(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=UBA(1:NSEAL)*COS(UBD(1:NSEAL)) + RLA_OASIS_SND(:,1) = TMP(1:NSEAL) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! y component of the near-bottom rms wave velocity (in m.s-1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_UBRY') THEN + TMP(1:NSEAL) = 0.0 + WHERE(UBA(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=UBA(1:NSEAL)*SIN(UBD(1:NSEAL)) + RLA_OASIS_SND(:,1) = TMP(1:NSEAL) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Net wave-supported stress, u component (tauwix in m2.s-2) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TAWX') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TAUWIX(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUWIX(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Net wave-supported stress, v component (tauwix in m2.s-2) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TAWY') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TAUWIY(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TAUWIY(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Volume transport associated to Stokes drift, u component (tusx in m2.s-1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TUSX') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TUSX(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TUSX(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Volume transport associated to Stokes drift, v component (tusy in m2.s-1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_TUSY') THEN + TMP(1:NSEAL) = 0.0 + WHERE(TUSY(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=TUSY(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Surface Stokes drift, u component (ussx in m.s-1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_USSX') THEN + TMP(1:NSEAL) = 0.0 + WHERE(USSX(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=USSX(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Surface Stokes drift, v component (ussy in m.s-1) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_USSY') THEN + TMP(1:NSEAL) = 0.0 + WHERE(USSY(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=USSY(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ! Mean wave length (wlm in m) + ! --------------------------------------------------------------------- + IF (SND_FLD(IB_DO)%CL_FIELD_NAME == 'WW3___LM') THEN + TMP(1:NSEAL) = 0.0 + WHERE(WLM(1:NSEAL) /= UNDEF) TMP(1:NSEAL)=WLM(1:NSEAL) + RLA_OASIS_SND(:,1) = DBLE(TMP(1:NSEAL)) + CALL CPL_OASIS_SND(IB_DO, ID_OASIS_TIME, RLA_OASIS_SND, LL_ACTION) + ENDIF + ! + ENDDO + !/ ------------------------------------------------------------------- / + END SUBROUTINE SND_FIELDS_TO_OCEAN + !/ ------------------------------------------------------------------- / + SUBROUTINE RCV_FIELDS_FROM_OCEAN(ID_LCOMM, IDFLD, FXN, FYN, FAN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Thevenin | + !/ | FORTRAN 90 | + !/ | Last update : April-2016 | + !/ +-----------------------------------+ + !/ + !/ Jul-2013 : Origination. ( version 4.18 ) + !/ Apr-2014 : Add IDFLD, FXN, FYX and FAN (M. Accensi) ( version 5.07 ) + !/ Apr-2016 : Add comments (J. Pianezze) ( version 5.07 ) + !/ + ! 1. Purpose : + ! + ! Receive coupling fields from oceanic model + ! + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ID_LCOMM Char. I MPI communicator + ! IDFLD Int. I Name of the exchange fields + ! FXN Int. I/O First exchange field + ! FYN Int. I/O Second exchange field + ! FAN Int. I/O Third exchange field + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------- + ! CPL_OASIS_RCV Subr. W3OACPMD Receive fields from atmos/ocean model + ! W3S2XY Subr. W3SERVMD Convert from storage (NSEA) to spatial grid (NX, NY) + ! ------------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------ + ! W3FLDG Subr. W3FLDSMD Manage input fields of depth, + ! current, wind and ice concentration + ! ------------------------------------------------------------------ + ! + ! 6. Error messages : + ! 7. Remarks : + ! + ! IDFLD C*3 I/O ID string for field type, valid are: 'LEV', 'CUR' (J=1,2) + ! + ! 8. Structure : + ! 9. Switches : + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3OACPMD, ONLY: ID_OASIS_TIME, IL_NB_RCV, RCV_FLD, CPL_OASIS_RCV + USE W3GDATMD, ONLY: NX, NY, NSEAL, NSEA, MAPSF + USE W3ODATMD, ONLY: NAPROC, IAPROC + USE W3SERVMD, ONLY: W3S2XY + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ID_LCOMM + CHARACTER(LEN=3), INTENT(IN) :: IDFLD + REAL, INTENT(INOUT) :: FXN(:,:), FYN(:,:), FAN(:,:) + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + LOGICAL :: LL_ACTION + INTEGER :: IB_DO, IB_I, IB_J, IL_ERR + INTEGER, SAVE :: ID_OASIS_TIME_WETDRYONLYONCE = -1 + REAL(kind=8), DIMENSION(NSEAL,1) :: RLA_OASIS_RCV + REAL(kind=8), DIMENSION(NSEAL) :: TMP, MASKT, MASKU, MASKV + REAL, DIMENSION(1:NSEA) :: SND_BUFF,RCV_BUFF + ! + !---------------------------------------------------------------------- + ! * Executable part + ! + MASKT(:)=1. + MASKU(:)=1. + MASKV(:)=1. + RLA_OASIS_RCV(:,:) = 0.0 + ! + ! --------------------------------------------------------------------- + ! Perform mask variables + ! --------------------------------------------------------------------- + ! + ! For the same coupling time, W3FLDG is called for the level and current variables. + ! As RCV_FIELDS_FROM_OCEAN is called from W3FLDG, the following test prevents to + ! exchange the wet-dry variables more than once per coupling time. + !cval well but it cannot work because MASKT,MASKU,MASKV variable are not global variable + !cval Anyway we will give up the exchange of mask, it is not a good idea at all - IF (ID_OASIS_TIME > ID_OASIS_TIME_WETDRYONLYONCE) THEN - ! - DO IB_DO = 1, IL_NB_RCV - ! - ! Land mask - u - ! --------------------------------------------------------------------- - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OWDH') THEN + IF (ID_OASIS_TIME > ID_OASIS_TIME_WETDRYONLYONCE) THEN + ! + DO IB_DO = 1, IL_NB_RCV + ! + ! Land mask - u + ! --------------------------------------------------------------------- + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OWDH') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - MASKT(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - ENDIF - ENDIF + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + MASKT(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + ENDIF + ENDIF + ! + ! Land mask - h + ! --------------------------------------------------------------------- + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OWDU') THEN + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + MASKU(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + ENDIF + ENDIF + ! + ! Land mask - v + ! --------------------------------------------------------------------- + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OWDV') THEN + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + MASKV(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) + ENDIF + ENDIF + ! + ENDDO + ! + ENDIF + ! + ! --------------------------------------------------------------------- + ! Treatment of the dynamical variables + ! --------------------------------------------------------------------- + DO IB_DO = 1, IL_NB_RCV + ! + ! Sea surface Height (m) + ! --------------------------------------------------------------------- + IF (IDFLD == 'LEV') THEN + ! + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__SSH') THEN + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) * MASKT(1:NSEAL) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + ENDDO ! - ! Land mask - h - ! --------------------------------------------------------------------- - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OWDU') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - MASKU(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - ENDIF - ENDIF + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) ! - ! Land mask - v - ! --------------------------------------------------------------------- - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OWDV') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - MASKV(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) - ENDIF - ENDIF + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FAN) ! - ENDDO - ! + ENDIF + ENDIF ENDIF -! -! --------------------------------------------------------------------- -! Treatment of the dynamical variables -! --------------------------------------------------------------------- - DO IB_DO = 1, IL_NB_RCV - ! - ! Sea surface Height (m) - ! --------------------------------------------------------------------- - IF (IDFLD == 'LEV') THEN - ! - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3__SSH') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) * MASKT(1:NSEAL) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - ENDDO - ! - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FAN) - ! - ENDIF - ENDIF - ENDIF - ! - ! Ocean sea surface current (m.s-1) - ! --------------------------------------------------------------------- - IF (IDFLD == 'CUR') THEN - ! - ! u-component - ! --------------------------------------------------------------------- - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OSSU') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) * MASKU(1:NSEAL) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - ENDDO - ! - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FXN) - ! - ENDIF - ENDIF + ! + ! Ocean sea surface current (m.s-1) + ! --------------------------------------------------------------------- + IF (IDFLD == 'CUR') THEN + ! + ! u-component + ! --------------------------------------------------------------------- + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OSSU') THEN + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) * MASKU(1:NSEAL) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + ENDDO ! - ! v-component - ! --------------------------------------------------------------------- - IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OSSV') THEN - CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) - IF (LL_ACTION) THEN - TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) * MASKV(1:NSEAL) - SND_BUFF(1:NSEA) = 0.0 - DO IB_I = 1, NSEAL - IB_J = IAPROC + (IB_I-1)*NAPROC - SND_BUFF(IB_J) = TMP(IB_I) - ENDDO - ! - CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & - RCV_BUFF(1:NSEA), & - NSEA, & - MPI_REAL, & - MPI_SUM, & - ID_LCOMM, & - IL_ERR) - ! - ! Convert from storage (NSEA) to spatial grid (NX, NY) - CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FYN) - ! - ENDIF - ENDIF - ENDIF - ENDDO -! - ID_OASIS_TIME_WETDRYONLYONCE = ID_OASIS_TIME -! -!/ ------------------------------------------------------------------- / - END SUBROUTINE RCV_FIELDS_FROM_OCEAN -!/ ------------------------------------------------------------------- / -!/ - END MODULE W3OGCMMD + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) + ! + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FXN) + ! + ENDIF + ENDIF + ! + ! v-component + ! --------------------------------------------------------------------- + IF (RCV_FLD(IB_DO)%CL_FIELD_NAME == 'WW3_OSSV') THEN + CALL CPL_OASIS_RCV(IB_DO, ID_OASIS_TIME, RLA_OASIS_RCV, LL_ACTION) + IF (LL_ACTION) THEN + TMP(1:NSEAL) = RLA_OASIS_RCV(1:NSEAL,1) * MASKV(1:NSEAL) + SND_BUFF(1:NSEA) = 0.0 + DO IB_I = 1, NSEAL + IB_J = IAPROC + (IB_I-1)*NAPROC + SND_BUFF(IB_J) = TMP(IB_I) + ENDDO + ! + CALL MPI_ALLREDUCE(SND_BUFF(1:NSEA), & + RCV_BUFF(1:NSEA), & + NSEA, & + MPI_REAL, & + MPI_SUM, & + ID_LCOMM, & + IL_ERR) + ! + ! Convert from storage (NSEA) to spatial grid (NX, NY) + CALL W3S2XY(NSEA,NSEA,NX,NY,RCV_BUFF(1:NSEA),MAPSF,FYN) + ! + ENDIF + ENDIF + ENDIF + ENDDO + ! + ID_OASIS_TIME_WETDRYONLYONCE = ID_OASIS_TIME + ! + !/ ------------------------------------------------------------------- / + END SUBROUTINE RCV_FIELDS_FROM_OCEAN + !/ ------------------------------------------------------------------- / + !/ +END MODULE W3OGCMMD !/ !/ ------------------------------------------------------------------- / diff --git a/model/src/w3ounfmetamd.F90 b/model/src/w3ounfmetamd.F90 index 5939ecf70..fd00c7bb3 100644 --- a/model/src/w3ounfmetamd.F90 +++ b/model/src/w3ounfmetamd.F90 @@ -150,3898 +150,3891 @@ !> @author Chris Bunney @date 02-Nov-2020 !> !> ### Change log -!> Date | Ver | Comments +!> Date | Ver | Comments !> ------------|------|--------- -!> 02-Nov-2020 | 7.12 | Creation +!> 02-Nov-2020 | 7.12 | Creation !> 26-Jan-2021 | 7.12 | Added Tp and alternative dir/mag metadata for directional fields. -!> 16-Dec-2020 | 7.12 | Added user partition templates and coordinate reference system. +!> 16-Dec-2020 | 7.12 | Added user partition templates and coordinate reference system. !> 02-Feb-2021 | 7.12 | Improved partitioned parameter template string implementation. !> 22-Mar-2021 | 7.12 | Add extra coupling fields !> 02-Sep-2021 | 7.12 | Add coordinates attribute !> - MODULE W3OUNFMETAMD -!/ -!/ 02-Nov-2020 : Creation ( version 7.12 ) -!/ 26-Jan-2021 : Added TP and alternative dir/mag ( version 7.12 ) -!/ metadata for directional fields. -!/ 16-Dec-2020 : Added user partition templates ( version 7.12 ) -!/ and coordinate reference system. -!/ Freeform meta data uses linked list. -!/ 02-Feb-2021 : Improved partitioned parameter ( version 7.12 ) -!/ template string implementation. -!/ 22-Mar-2021 : Adds extra coupling fields ( version 7.13 ) -!/ 02-Sep-2021 : Add coordinates attribute ( version 7.12 ) -!/ -!/ ------------------------------------------------------------------- / -!/ - USE NETCDF - USE CONSTANTS, ONLY: TPIINV - USE W3GDATMD, ONLY: SIG, NK, GTYPE, UNGTYPE +MODULE W3OUNFMETAMD + !/ + !/ 02-Nov-2020 : Creation ( version 7.12 ) + !/ 26-Jan-2021 : Added TP and alternative dir/mag ( version 7.12 ) + !/ metadata for directional fields. + !/ 16-Dec-2020 : Added user partition templates ( version 7.12 ) + !/ and coordinate reference system. + !/ Freeform meta data uses linked list. + !/ 02-Feb-2021 : Improved partitioned parameter ( version 7.12 ) + !/ template string implementation. + !/ 22-Mar-2021 : Adds extra coupling fields ( version 7.13 ) + !/ 02-Sep-2021 : Add coordinates attribute ( version 7.12 ) + !/ + !/ ------------------------------------------------------------------- / + !/ + USE NETCDF + USE CONSTANTS, ONLY: TPIINV + USE W3GDATMD, ONLY: SIG, NK, GTYPE, UNGTYPE #ifdef W3_RTD - USE W3GDATMD, ONLY : FLAGUNR, POLAT, POLON + USE W3GDATMD, ONLY : FLAGUNR, POLAT, POLON #endif #ifdef W3_SMC - USE W3SMCOMD, ONLY : SMCOTYPE -#endif - USE W3ODATMD, ONLY: PTMETH, PTFCUT, NOGRP, NOGE, NGRPP, & - NDSE, FNMPRE, NOSWLL - USE W3SERVMD, ONLY: EXTCDE, STR_TO_UPPER - - USE W3METAMD - - IMPLICIT NONE - - PUBLIC - - LOGICAL, PRIVATE :: DEBUG = .FALSE. !< Control debug output to screen - - !> Meta-data input filename - CHARACTER(LEN=*), PARAMETER :: FN_META = "ounfmeta.inp" - - !> String token for integer partition number - CHARACTER(LEN=*), PARAMETER :: IPART_TOKEN = "" - - !> String token for partition descriptive string (space separated) - CHARACTER(LEN=*), PARAMETER :: SPART_TOKEN = "" - - !> String token for partition descriptive string (underscore separated) - CHARACTER(LEN=*), PARAMETER :: SPART_TOKEN_ = "" - - !> Type for storing WW3 netCDF metadata for a variable - TYPE META_T - REAL :: FSC !< Scaling factor for data - REAL :: VMIN !< "valid_min" attribute - REAL :: VMAX = UNSETR !< "valid_max" attribute - CHARACTER(LEN=24) :: UNITS = UNSETC !< SI units for field - CHARACTER(LEN=50) :: ENAME = UNSETC !< Field name used in output filename - CHARACTER(LEN=80) :: VARNM = UNSETC, & !< netCDF variable name - VARNL = UNSETC !< "long_name" attibute - CHARACTER(LEN=120) :: VARNS = UNSETC, & !< "standard_name" attribute - VARNG = UNSETC, & !< "globwave_name" attribute - VARND = UNSETC !< "direction_convention" attribute - CHARACTER(LEN=512) :: VARNC = UNSETC !< "comment attribute - TYPE(META_LIST_T) :: EXTRA !< List of user defined meta data - - ! For updating meta only: - INTEGER :: IFI = 0, & !< Group index to update - IFJ = 0, & !< Field index to update - IFC = 1 !< Component index to update - CHARACTER(LEN=6) :: FLDID = '' !< Field ID to update - ENDTYPE META_T - - !> Type for storage of meta data aggregated by component (NFIELD) - TYPE FIELD_T - TYPE(META_T), POINTER :: META(:) !< Pointer to meta data for field - END TYPE FIELD_T - - !> Type for storage of meta data aggregated by field (IFI) - TYPE GROUP_T - TYPE(FIELD_T), ALLOCATABLE :: FIELD(:) !< Pointer to fields in group - END TYPE GROUP_T - - !> Storage for meta data aggregated by group (IFJ) - TYPE(GROUP_T), ALLOCATABLE :: GROUP(:) - - !> Storage for the Global meta data (free form) - TYPE(META_LIST_T) :: GLOBAL_META - - !> Flag for using default (true) or user-defined (false) global meta data - LOGICAL :: FL_DEFAULT_GBL_META = .TRUE. - - ! Storage for coordinate reference system (CRS) metadata: - CHARACTER(LEN=128) :: CRS_NAME = '' !< Coordinate reference system (CRS) name - TYPE(META_LIST_T) :: CRS_META !< Meta data list for CRS - LOGICAL :: CRS_IS_DEFAULT = .FALSE. !< True if CRS set by this module - - !> "coordinates" attribute - for defining auxiliary coordinates (for all variables) - CHARACTER(LEN=256) :: COORDS_ATTR = '' - - !> Type for storing partitioned parameter template strings. - !> Defined as a linked-list - TYPE PART_TMPL_T - CHARACTER(LEN=128) :: TMPL !< Placeholder - CHARACTER(LEN=128), ALLOCATABLE :: PART_TEXT(:) !< Partition description - INTEGER(KIND=2) :: NP !< Num parts (max NOSWLL) - TYPE(PART_TMPL_T), POINTER :: NEXT !< LinkedList pointer - END TYPE PART_TMPL_T - - !> User-defined partitionted paratmeters template strings - TYPE(PART_TMPL_T), POINTER :: PART_TMPL - - INTEGER :: NCVARTYPE !< NetCDF variable type (2=int, 3=real, 4=depends) - CHARACTER(LEN=30) :: DIRCOM !< Directional convention comment - CHARACTER(LEN=128) :: PARTCOM !< Partitioning method comment - CHARACTER(LEN=15) :: SNAMEP(5) !< Part. standard name templates - - !> Flag for vector (true) or direction/magnitude (false) convention - !> for directional fields - LOGICAL, PRIVATE :: VECTOR - LOGICAL :: FLRTD = .FALSE. !< Flag for rototed pole grid - - CONTAINS - -!/ ------------------------------------------------------------------- / -!> @brief Allocates space for the META_T arrays and sets some defaults. -!> -!> @details By default, directional fields will be set up to output -!> a magnitude and direction field. Alternatively, if VEC is set to -!> True, then u/v vectors will be generated instead. -!> -!> @note - vector output is currently only implemented for the -!> "current" and "wind" fields. -!> -!> @param VEC Output vectors for directional fields rather than -!> direction/magnitude. -!> -!> @author Chris Bunney @date 09-Mar-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE INIT_META(VEC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ 22-Mar-2021 : Added vector flag ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Allocates space for the META_T arrays and sets some constants. -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - LOGICAL, INTENT(IN), OPTIONAL :: VEC -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - LOGICAL :: FLGNML - INTEGER :: I, J - - VECTOR = .TRUE. - IF(PRESENT(VEC)) VECTOR = VEC -#ifdef W3_RTD - ! Is the grid really rotated? - IF ( POLAT < 90. ) FLRTD = .True. + USE W3SMCOMD, ONLY : SMCOTYPE #endif -#ifdef W3_SMC + USE W3ODATMD, ONLY: PTMETH, PTFCUT, NOGRP, NOGE, NGRPP, & + NDSE, FNMPRE, NOSWLL + USE W3SERVMD, ONLY: EXTCDE, STR_TO_UPPER + + USE W3METAMD + + IMPLICIT NONE + + PUBLIC + + LOGICAL, PRIVATE :: DEBUG = .FALSE. !< Control debug output to screen + + !> Meta-data input filename + CHARACTER(LEN=*), PARAMETER :: FN_META = "ounfmeta.inp" + + !> String token for integer partition number + CHARACTER(LEN=*), PARAMETER :: IPART_TOKEN = "" + + !> String token for partition descriptive string (space separated) + CHARACTER(LEN=*), PARAMETER :: SPART_TOKEN = "" + + !> String token for partition descriptive string (underscore separated) + CHARACTER(LEN=*), PARAMETER :: SPART_TOKEN_ = "" + + !> Type for storing WW3 netCDF metadata for a variable + TYPE META_T + REAL :: FSC !< Scaling factor for data + REAL :: VMIN !< "valid_min" attribute + REAL :: VMAX = UNSETR !< "valid_max" attribute + CHARACTER(LEN=24) :: UNITS = UNSETC !< SI units for field + CHARACTER(LEN=50) :: ENAME = UNSETC !< Field name used in output filename + CHARACTER(LEN=80) :: VARNM = UNSETC, & !< netCDF variable name + VARNL = UNSETC !< "long_name" attibute + CHARACTER(LEN=120) :: VARNS = UNSETC, & !< "standard_name" attribute + VARNG = UNSETC, & !< "globwave_name" attribute + VARND = UNSETC !< "direction_convention" attribute + CHARACTER(LEN=512) :: VARNC = UNSETC !< "comment attribute + TYPE(META_LIST_T) :: EXTRA !< List of user defined meta data + + ! For updating meta only: + INTEGER :: IFI = 0, & !< Group index to update + IFJ = 0, & !< Field index to update + IFC = 1 !< Component index to update + CHARACTER(LEN=6) :: FLDID = '' !< Field ID to update + ENDTYPE META_T + + !> Type for storage of meta data aggregated by component (NFIELD) + TYPE FIELD_T + TYPE(META_T), POINTER :: META(:) !< Pointer to meta data for field + END TYPE FIELD_T + + !> Type for storage of meta data aggregated by field (IFI) + TYPE GROUP_T + TYPE(FIELD_T), ALLOCATABLE :: FIELD(:) !< Pointer to fields in group + END TYPE GROUP_T + + !> Storage for meta data aggregated by group (IFJ) + TYPE(GROUP_T), ALLOCATABLE :: GROUP(:) + + !> Storage for the Global meta data (free form) + TYPE(META_LIST_T) :: GLOBAL_META + + !> Flag for using default (true) or user-defined (false) global meta data + LOGICAL :: FL_DEFAULT_GBL_META = .TRUE. + + ! Storage for coordinate reference system (CRS) metadata: + CHARACTER(LEN=128) :: CRS_NAME = '' !< Coordinate reference system (CRS) name + TYPE(META_LIST_T) :: CRS_META !< Meta data list for CRS + LOGICAL :: CRS_IS_DEFAULT = .FALSE. !< True if CRS set by this module + + !> "coordinates" attribute - for defining auxiliary coordinates (for all variables) + CHARACTER(LEN=256) :: COORDS_ATTR = '' + + !> Type for storing partitioned parameter template strings. + !> Defined as a linked-list + TYPE PART_TMPL_T + CHARACTER(LEN=128) :: TMPL !< Placeholder + CHARACTER(LEN=128), ALLOCATABLE :: PART_TEXT(:) !< Partition description + INTEGER(KIND=2) :: NP !< Num parts (max NOSWLL) + TYPE(PART_TMPL_T), POINTER :: NEXT !< LinkedList pointer + END TYPE PART_TMPL_T + + !> User-defined partitionted paratmeters template strings + TYPE(PART_TMPL_T), POINTER :: PART_TMPL + + INTEGER :: NCVARTYPE !< NetCDF variable type (2=int, 3=real, 4=depends) + CHARACTER(LEN=30) :: DIRCOM !< Directional convention comment + CHARACTER(LEN=128) :: PARTCOM !< Partitioning method comment + CHARACTER(LEN=15) :: SNAMEP(5) !< Part. standard name templates + + !> Flag for vector (true) or direction/magnitude (false) convention + !> for directional fields + LOGICAL, PRIVATE :: VECTOR + LOGICAL :: FLRTD = .FALSE. !< Flag for rototed pole grid + +CONTAINS + + !/ ------------------------------------------------------------------- / + !> @brief Allocates space for the META_T arrays and sets some defaults. + !> + !> @details By default, directional fields will be set up to output + !> a magnitude and direction field. Alternatively, if VEC is set to + !> True, then u/v vectors will be generated instead. + !> + !> @note - vector output is currently only implemented for the + !> "current" and "wind" fields. + !> + !> @param VEC Output vectors for directional fields rather than + !> direction/magnitude. + !> + !> @author Chris Bunney @date 09-Mar-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE INIT_META(VEC) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ 22-Mar-2021 : Added vector flag ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Allocates space for the META_T arrays and sets some constants. + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + LOGICAL, INTENT(IN), OPTIONAL :: VEC + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + LOGICAL :: FLGNML + INTEGER :: I, J + + VECTOR = .TRUE. + IF(PRESENT(VEC)) VECTOR = VEC #ifdef W3_RTD - ! SMC type 3/4 outputs are currently on standard pole grid only - IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) FLRTD = .FALSE. -#endif + ! Is the grid really rotated? + IF ( POLAT < 90. ) FLRTD = .True. #endif -#ifdef W3_RTD - ! +#if defined W3_SMC && defined W3_RTD + ! SMC type 3/4 outputs are currently on standard pole grid only + IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) FLRTD = .FALSE. #endif - ! 1. Allocate nested GROUP, FIELD structure: - ALLOCATE(GROUP(NOGRP)) - DO I = 1,NOGRP - ALLOCATE(GROUP(I)%FIELD(NOGE(I))) - DO J = 1,NOGE(I) - ALLOCATE(GROUP(I)%FIELD(J)%META(3)) ! Hardcode to 3 components for the moment - ENDDO + ! 1. Allocate nested GROUP, FIELD structure: + ALLOCATE(GROUP(NOGRP)) + DO I = 1,NOGRP + ALLOCATE(GROUP(I)%FIELD(NOGE(I))) + DO J = 1,NOGE(I) + ALLOCATE(GROUP(I)%FIELD(J)%META(3)) ! Hardcode to 3 components for the moment ENDDO + ENDDO - ! 1.1 Make sure partitioned template pointer is null (i.e. empty list) - NULLIFY(PART_TMPL) + ! 1.1 Make sure partitioned template pointer is null (i.e. empty list) + NULLIFY(PART_TMPL) - ! 2. Set direction convention: - DIRCOM = "" + ! 2. Set direction convention: + DIRCOM = "" #ifdef W3_RTD - IF( FLRTD ) THEN - IF ( FLAGUNR ) THEN - DIRCOM = 'True North' - ELSE IF ( .NOT. FLAGUNR ) THEN - DIRCOM = 'Rotated Pole Grid North' - ENDIF + IF( FLRTD ) THEN + IF ( FLAGUNR ) THEN + DIRCOM = 'True North' + ELSE IF ( .NOT. FLAGUNR ) THEN + DIRCOM = 'Rotated Pole Grid North' ENDIF + ENDIF #endif - ! Set partitioning method comment and standard name templates: - IF( PTMETH .LE. 3 ) THEN - SNAMEP(1) = 'wind' - SNAMEP(2) = 'primary swell' - SNAMEP(3) = 'secondary swell' - SNAMEP(4) = 'tertiary swell' - SNAMEP(5) = 'swell' - ELSE - SNAMEP(1) = 'wind' - SNAMEP(2) = 'swell' - SNAMEP(3:5) = '' + ! Set partitioning method comment and standard name templates: + IF( PTMETH .LE. 3 ) THEN + SNAMEP(1) = 'wind' + SNAMEP(2) = 'primary swell' + SNAMEP(3) = 'secondary swell' + SNAMEP(4) = 'tertiary swell' + SNAMEP(5) = 'swell' + ELSE + SNAMEP(1) = 'wind' + SNAMEP(2) = 'swell' + SNAMEP(3:5) = '' + ENDIF + + IF ( PTMETH .EQ. 1 ) THEN + PARTCOM = "Wind sea and swells defined using topographic " // & + "partitions and partition wave-age cut-off " // & + "(WWIII default scheme)" + ELSE IF ( PTMETH .EQ. 2 ) THEN + PARTCOM = "Wind sea and swells defined using topographic " // & + "partitions and spectral wave-age cut-off" + ELSE IF ( PTMETH .EQ. 3 ) THEN + PARTCOM = "Wave components defined using topographic " // & + "partitions only" + ELSE IF ( PTMETH .EQ. 4 ) THEN + PARTCOM = "Wind sea and swell defined using spectral " // & + "wave-age cut-off" + ELSE IF ( PTMETH .EQ. 5 ) THEN + WRITE(PARTCOM, '("Wave components defined using ",F5.3,' // & + '"Hz spectral frequency cutoff")') PTFCUT + ELSE + WRITE(PARTCOM, '("PTM_",I1,"_Unknown")') PTMETH + ENDIF + + ! 3. Set the default values for the OUNF netCDF meta data. + CALL DEFAULT_META() + + ! Set the default coordiante reference system (if applicable) + CALL DEFAULT_CRS_META() + + ! If the ounfmeta.inp exists, read this in to override defaults: + INQUIRE(FILE=TRIM(FNMPRE)//"ounfmeta.inp", EXIST=FLGNML) + IF(FLGNML) THEN + CALL READ_META() + ENDIF + + END SUBROUTINE INIT_META + ! + !/ ------------------------------------------------------------------- / + !> @brief De-allocates memory used for the META_T arrays + !> + !> @author Chris Bunney @date 09-Nov-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE TEARDOWN_META() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 09-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! De-allocates memory used for the META_T arrays + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, J + + DO I = 1,NOGRP + DO J = 1,NOGE(I) + DEALLOCATE(GROUP(I)%FIELD(J)%META) + ENDDO + DEALLOCATE(GROUP(I)%FIELD) + ENDDO + DEALLOCATE(GROUP) + + CALL DEL_META_LIST(GLOBAL_META) + CALL DEL_META_LIST(CRS_META) + + END SUBROUTINE TEARDOWN_META + + !/ ------------------------------------------------------------------- / + !> @brief Reads the next valid line from the user meta input file. + !> + !> @details Lines are repeatedly read in from the input file until + !> a valid input line is reached. Blank lines and comment lines + !> (starting with $) are skipped. + !> + !> If the end of file is reached before any valid line is read + !> then EOF is set to true. + !> + !> If the next valid line is a new section marker (META or TEMPLATE) + !> then the NEW_SECTION flag is set to true. + !> + !> @param[in] NDMI Unit number of input file + !> @param[out] BUF Next input line read from file + !> @param[in,out] ILINE Line number of file + !> @param[out] EOF True if end-of-file is reached. + !> @param[out] NEW_SECTION True if new section marker found + !> + !> @author Chris Bunney @date 09-Nov-2020 + !/ ------------------------------------------------------------------- / + + SUBROUTINE NEXT_LINE(NDMI, BUF, ILINE, EOF, NEW_SECTION) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 09-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Reads the next valid line from the user meta input file. + ! + ! 2. Method : + ! Lines are repeatedly read in from the input file until + ! a valid input line is reached. Blank lines and comment lines + ! (starting with $) are skipped. + ! + ! If the end of file is reached before any valid line is read + ! then EOF is set to true. + ! + ! If the next valid line is a new section marker (META or TEMPLATE) + ! then the NEW_SECTION flag is set to true. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDMI Int. I Unit number of input file + ! BUF Char. O Next input line read from file + ! ILINE Int. I/O Line number of file + ! EOF Bool. O True if end-of-file is reached. + ! NEW_SECTION + ! Bool. O True if new section marker found + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NDMI + CHARACTER(*), INTENT(OUT) :: BUF + INTEGER, INTENT(INOUT) :: ILINE + LOGICAL, INTENT(OUT) :: EOF + LOGICAL, INTENT(OUT), OPTIONAL :: NEW_SECTION + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IERR + CHARACTER(LEN=10) :: TEST + + EOF = .FALSE. + + ! Keep reading from file until we read a line that is not: + ! - a blank line + ! - a comment line (starting with $) + ! - the end of the file + DO + READ(NDMI, '(A)', iostat=IERR, err=101, end=100) BUF + + ILINE = ILINE + 1 + + ! Remove any tab characters from buffer (replace with a space) + CALL NOTABS(BUF) + + ! Empty line? + IF(TRIM(BUF) == '') THEN + IF(DEBUG) WRITE(*,'(I5,1X,A20)') ILINE, '[blank line]' + CYCLE ENDIF - IF ( PTMETH .EQ. 1 ) THEN - PARTCOM = "Wind sea and swells defined using topographic " // & - "partitions and partition wave-age cut-off " // & - "(WWIII default scheme)" - ELSE IF ( PTMETH .EQ. 2 ) THEN - PARTCOM = "Wind sea and swells defined using topographic " // & - "partitions and spectral wave-age cut-off" - ELSE IF ( PTMETH .EQ. 3 ) THEN - PARTCOM = "Wave components defined using topographic " // & - "partitions only" - ELSE IF ( PTMETH .EQ. 4 ) THEN - PARTCOM = "Wind sea and swell defined using spectral " // & - "wave-age cut-off" - ELSE IF ( PTMETH .EQ. 5 ) THEN - WRITE(PARTCOM, '("Wave components defined using ",F5.3,' // & - '"Hz spectral frequency cutoff")') PTFCUT - ELSE - WRITE(PARTCOM, '("PTM_",I1,"_Unknown")') PTMETH + IF(TRIM(BUF) == "$ DEBUG ON") THEN + WRITE(*,'(I5,1X,A20)') ILINE, '[DEBUG ON]' + DEBUG = .TRUE. + CYCLE ENDIF - ! 3. Set the default values for the OUNF netCDF meta data. - CALL DEFAULT_META() - - ! Set the default coordiante reference system (if applicable) - CALL DEFAULT_CRS_META() - - ! If the ounfmeta.inp exists, read this in to override defaults: - INQUIRE(FILE=TRIM(FNMPRE)//"ounfmeta.inp", EXIST=FLGNML) - IF(FLGNML) THEN - CALL READ_META() + IF(TRIM(BUF) == "$ DEBUG OFF") THEN + WRITE(*,'(I5,1X,A20)') ILINE, '[DEBUG OFF]' + DEBUG = .FALSE. + CYCLE ENDIF - END SUBROUTINE INIT_META -! -!/ ------------------------------------------------------------------- / -!> @brief De-allocates memory used for the META_T arrays -!> -!> @author Chris Bunney @date 09-Nov-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE TEARDOWN_META() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 09-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! De-allocates memory used for the META_T arrays -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, J - - DO I = 1,NOGRP - DO J = 1,NOGE(I) - DEALLOCATE(GROUP(I)%FIELD(J)%META) - ENDDO - DEALLOCATE(GROUP(I)%FIELD) - ENDDO - DEALLOCATE(GROUP) - - CALL DEL_META_LIST(GLOBAL_META) - CALL DEL_META_LIST(CRS_META) - - END SUBROUTINE TEARDOWN_META + ! Read first token on line: + READ(BUF, *) TEST -!/ ------------------------------------------------------------------- / -!> @brief Reads the next valid line from the user meta input file. -!> -!> @details Lines are repeatedly read in from the input file until -!> a valid input line is reached. Blank lines and comment lines -!> (starting with $) are skipped. -!> -!> If the end of file is reached before any valid line is read -!> then EOF is set to true. -!> -!> If the next valid line is a new section marker (META or TEMPLATE) -!> then the NEW_SECTION flag is set to true. -!> -!> @param[in] NDMI Unit number of input file -!> @param[out] BUF Next input line read from file -!> @param[in,out] ILINE Line number of file -!> @param[out] EOF True if end-of-file is reached. -!> @param[out] NEW_SECTION True if new section marker found -!> -!> @author Chris Bunney @date 09-Nov-2020 -!/ ------------------------------------------------------------------- / - - SUBROUTINE NEXT_LINE(NDMI, BUF, ILINE, EOF, NEW_SECTION) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 09-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Reads the next valid line from the user meta input file. -! -! 2. Method : -! Lines are repeatedly read in from the input file until -! a valid input line is reached. Blank lines and comment lines -! (starting with $) are skipped. -! -! If the end of file is reached before any valid line is read -! then EOF is set to true. -! -! If the next valid line is a new section marker (META or TEMPLATE) -! then the NEW_SECTION flag is set to true. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDMI Int. I Unit number of input file -! BUF Char. O Next input line read from file -! ILINE Int. I/O Line number of file -! EOF Bool. O True if end-of-file is reached. -! NEW_SECTION -! Bool. O True if new section marker found -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NDMI - CHARACTER(*), INTENT(OUT) :: BUF - INTEGER, INTENT(INOUT) :: ILINE - LOGICAL, INTENT(OUT) :: EOF - LOGICAL, INTENT(OUT), OPTIONAL :: NEW_SECTION -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IERR - CHARACTER(LEN=10) :: TEST - - EOF = .FALSE. - - ! Keep reading from file until we read a line that is not: - ! - a blank line - ! - a comment line (starting with $) - ! - the end of the file - DO - READ(NDMI, '(A)', iostat=IERR, err=101, end=100) BUF - - ILINE = ILINE + 1 + ! Check for comment: + IF(TEST(1:1) == "$" .OR. TRIM(BUF) == '') THEN + IF(DEBUG) WRITE(*,'(I5,1X,A20)') ILINE, '[comment line]' + CYCLE + ENDIF - ! Remove any tab characters from buffer (replace with a space) - CALL NOTABS(BUF) + ! Check if is section header + IF(PRESENT(NEW_SECTION)) THEN + CALL STR_TO_UPPER(TEST) + SELECT CASE(TEST) + CASE ("META", "TEMPLATE", "CRS") + NEW_SECTION = .TRUE. + CASE DEFAULT + NEW_SECTION = .FALSE. + END SELECT + ENDIF - ! Empty line? - IF(TRIM(BUF) == '') THEN - IF(DEBUG) WRITE(*,'(I5,1X,A20)') ILINE, '[blank line]' - CYCLE + ! Anything else can be considered the "next line" + RETURN + ENDDO + + !/ Escape locations + ! + ! End of file +100 CONTINUE + BUF = '' + EOF = .TRUE. + RETURN + ! + ! I/O Error +101 CONTINUE + WRITE(NDSE, 1000) FN_META, ILINE, IERR + CALL EXTCDE(10) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' ERROR READING METADATA FILE'/ & + ' FILENAME = ', A / & + ' LINE NO = ', I5 / & + ' IOSTAT =',I5 /) + ! + END SUBROUTINE NEXT_LINE + + !/ ------------------------------------------------------------------- / + !> @brief Replaces tab characters in a string with a space. + !> + !> @remark Assumes ASCII encoding (Tab character is ASCII value 9) + !> + !> @param[in,out] STR Character string to process + !> + !> @author Chris Bunney @date 02-Nov-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE NOTABS(STR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 02-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 02-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Replaces tab characters in a string with a space. + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! STR Char. I/O Character string to process + ! ---------------------------------------------------------------- + ! + ! 3. Remarks : + ! + ! Assumes ASCII encoding! Tab character is ASCII value 9. + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + CHARACTER(*), INTENT(INOUT) :: STR + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, PARAMETER :: ASCII_TAB = 9 + INTEGER :: SLEN + INTEGER :: I + ! + SLEN = LEN_TRIM(STR) + + DO I=1,SLEN + IF(ICHAR(STR(I:I)) == ASCII_TAB) THEN + STR(I:I) = ' ' + ENDIF + ENDDO + + END SUBROUTINE NOTABS + + !/ ------------------------------------------------------------------- / + !> @brief Replaces single characters in a string. + !> + !> @returns A new string + !> + !> @param[in] STR Character string to process + !> @param[in] C Character to search for + !> @param[in] REP Character to substitute + !> + !> @author Chris Bunney @date 02-Feb-2021 + !/ ------------------------------------------------------------------- / + FUNCTION REPLACE_CHAR(STR, C, REP) RESULT(OSTR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 02-Fev-2021 | + !/ +-----------------------------------+ + !/ + !/ 02-Feb-2021 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Replaces single characters in a string. Returns a new string, + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! STR CharArr I Character string to process + ! C Char I Character to search for + ! REP Char I Character to substitute + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + CHARACTER(*) :: STR + CHARACTER :: C, REP + CHARACTER(LEN(STR)) :: OSTR + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I + + OSTR = TRIM(STR) + DO + I = INDEX(TRIM(OSTR), C) + IF(I .LE. 0) EXIT + OSTR(I:I) = REP + ENDDO + + END FUNCTION REPLACE_CHAR + + !/ ------------------------------------------------------------------- / + !> @brief Reads meta data entries from the ountmeta.inp file + !> + !> @details This is the main entry routine for parsing the ounfmeta.inp + !> file. Values read from the file will be used to update or add to + !> the default meta data values set in the default_meta() + !> subroutine. + !> + !> @author Chris Bunney @date 26-Jan-2021 + !/ ------------------------------------------------------------------- / + SUBROUTINE READ_META() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 26-Jan-2021 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ 26-Jan-2021 : Added TP and alternative dir/mag ( version 7.12 ) + !/ metadata for directional fields. + !/ + ! + ! 1. Purpose : + ! + ! Reads meta data entries from the ountmeta.inp file and update + ! default values set via the DEFAULT_META subroutine. + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IERR, I, NDMI + CHARACTER(LEN=256) :: BUF + TYPE(META_T), POINTER :: PMETA + CHARACTER(LEN=32) :: TEST, TESTU + + INTEGER :: IFI, IFJ, IFC + INTEGER :: ILINE, MCNT + LOGICAL :: EOF + + NDMI = 60 + ILINE = 0 + MCNT = 0 + + OPEN(UNIT=NDMI, FILE=TRIM(FNMPRE)//TRIM(FN_META), & + STATUS="OLD", IOSTAT=IERR) + + IF(IERR .NE. 0) THEN + WRITE(NDSE, 5010) TRIM(FNMPRE)//TRIM(FN_META), IERR + CALL EXTCDE(10) + ENDIF + + ! Loop over file, skipping comments or blank lines, until we find + ! a META line. + DO + CALL NEXT_LINE(NDMI, BUF, ILINE, EOF) + IF(EOF) EXIT + + ! Read first token on line: + READ(BUF, *) TEST + + ! A new meta-data section will start with the keyword "META" + TESTU = TEST + CALL STR_TO_UPPER(TESTU) + IF(TESTU == "META") THEN + MCNT = MCNT + 1 + + IF(DEBUG) WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[META header]', TRIM(BUF) + + ! Get the IFI, IFJ, IFC values from the header: + I = INDEX(BUF, TRIM(TEST)) + 4 ! Handles lower/mixed-case META keyword + CALL DECODE_HEADER(BUF(I:), ILINE, IFI, IFJ, IFC) + IF(IFI .EQ. -1) THEN + WRITE(NDSE, 5011) TRIM(BUF(I:)), TRIM(FN_META), ILINE + CALL EXTCDE(10) ENDIF - IF(TRIM(BUF) == "$ DEBUG ON") THEN - WRITE(*,'(I5,1X,A20)') ILINE, '[DEBUG ON]' - DEBUG = .TRUE. + ! IFI = 999 is a section for the "global" meta data + IF(IFI .EQ. 999) THEN + CALL READ_FREEFORM_META_LIST(NDMI, ILINE, GLOBAL_META) CYCLE ENDIF - IF(TRIM(BUF) == "$ DEBUG OFF") THEN - WRITE(*,'(I5,1X,A20)') ILINE, '[DEBUG OFF]' - DEBUG = .FALSE. - CYCLE + ! Error checking on size of IFJ, ICOMP, IPART. + IF(IFI .LT. 1 .OR. IFI .GT. NOGRP) THEN + WRITE(NDSE,5013) NOGRP, TRIM(FN_META), ILINE + CALL EXTCDE(1) ENDIF - - ! Read first token on line: - READ(BUF, *) TEST - - ! Check for comment: - IF(TEST(1:1) == "$" .OR. TRIM(BUF) == '') THEN - IF(DEBUG) WRITE(*,'(I5,1X,A20)') ILINE, '[comment line]' - CYCLE + IF(IFJ .LT. 1 .OR. IFJ .GT. NOGE(IFI)) THEN + WRITE(NDSE,5014) NOGE(IFI), TRIM(FN_META), ILINE + CALL EXTCDE(1) ENDIF - - ! Check if is section header - IF(PRESENT(NEW_SECTION)) THEN - CALL STR_TO_UPPER(TEST) - SELECT CASE(TEST) - CASE ("META", "TEMPLATE", "CRS") - NEW_SECTION = .TRUE. - CASE DEFAULT - NEW_SECTION = .FALSE. - END SELECT + IF(IFC .LT. 1 .OR. IFC .GT. 3) THEN + WRITE(NDSE,5015) TRIM(FN_META), ILINE + CALL EXTCDE(1) ENDIF - ! Anything else can be considered the "next line" - RETURN - ENDDO - -!/ Escape locations -! -! End of file - 100 CONTINUE - BUF = '' - EOF = .TRUE. - RETURN -! -! I/O Error - 101 CONTINUE - WRITE(NDSE, 1000) FN_META, ILINE, IERR - CALL EXTCDE(10) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' ERROR READING METADATA FILE'/ & - ' FILENAME = ', A / & - ' LINE NO = ', I5 / & - ' IOSTAT =',I5 /) -! - END SUBROUTINE NEXT_LINE - -!/ ------------------------------------------------------------------- / -!> @brief Replaces tab characters in a string with a space. -!> -!> @remark Assumes ASCII encoding (Tab character is ASCII value 9) -!> -!> @param[in,out] STR Character string to process -!> -!> @author Chris Bunney @date 02-Nov-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE NOTABS(STR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 02-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 02-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Replaces tab characters in a string with a space. -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! STR Char. I/O Character string to process -! ---------------------------------------------------------------- -! -! 3. Remarks : -! -! Assumes ASCII encoding! Tab character is ASCII value 9. -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - CHARACTER(*), INTENT(INOUT) :: STR -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, PARAMETER :: ASCII_TAB = 9 - INTEGER :: SLEN - INTEGER :: I -! - SLEN = LEN_TRIM(STR) - - DO I=1,SLEN - IF(ICHAR(STR(I:I)) == ASCII_TAB) THEN - STR(I:I) = ' ' - ENDIF - ENDDO + ! Select correct variable metadata entry: + PMETA => GROUP(IFI)%FIELD(IFJ)%META(IFC) - END SUBROUTINE NOTABS + ! Update the metadata with values from file: + CALL READ_META_PAIRS(NDMI, PMETA, ILINE) -!/ ------------------------------------------------------------------- / -!> @brief Replaces single characters in a string. -!> -!> @returns A new string -!> -!> @param[in] STR Character string to process -!> @param[in] C Character to search for -!> @param[in] REP Character to substitute -!> -!> @author Chris Bunney @date 02-Feb-2021 -!/ ------------------------------------------------------------------- / - FUNCTION REPLACE_CHAR(STR, C, REP) RESULT(OSTR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 02-Fev-2021 | -!/ +-----------------------------------+ -!/ -!/ 02-Feb-2021 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Replaces single characters in a string. Returns a new string, -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! STR CharArr I Character string to process -! C Char I Character to search for -! REP Char I Character to substitute -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - CHARACTER(*) :: STR - CHARACTER :: C, REP - CHARACTER(LEN(STR)) :: OSTR -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I + ELSE IF(TESTU == "TEMPLATE") THEN + BACKSPACE(NDMI) ! We will reprocess this line + CALL READ_PART_TMPL(NDMI, ILINE) + CYCLE - OSTR = TRIM(STR) - DO - I = INDEX(TRIM(OSTR), C) - IF(I .LE. 0) EXIT - OSTR(I:I) = REP - ENDDO + ELSE IF(TESTU == "CRS") THEN + BACKSPACE(NDMI) ! We will reprocess this line + CALL READ_CRS_META(NDMI, ILINE) + CYCLE - END FUNCTION REPLACE_CHAR + ELSE + ! Anything else is a syntax error + WRITE(NDSE, 5012) TRIM(FN_META), ILINE, TRIM(BUF) + CALL EXTCDE(10) + ENDIF + ENDDO + + CLOSE(NDMI) + !WRITE(*, 5000) MCNT, N_GBLMETA, N_CRSMETA + RETURN + ! +5000 FORMAT(/' Read in: ',I3,' variable metadata entries' / & + ' and: ',I3,' global meta data entries' / & + ' and: ',I3,' CRS meta data entries' /) + ! +5010 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' ERROR OPENING METADATA FILE'/ & + ' FILENAME = ', A / & + ' IOSTAT =', I5 /) + ! +5011 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' UNKNOWN FIELD ID: ',A / & + ' FILENAME = ', A / & + ' LINE =', I5 /) + ! +5012 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' SYNTAX ERROR ' / & + ' FILENAME = ', A / & + ' LINE =', I5 / & + ' => ', A /) + ! +5013 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & + ' IFI value should be in range 1,',I2 / & + ' FILENAME = ', A / & + ' LINE =', I5 / & + ' => ', A /) + ! +5014 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & + ' IFJ value should be in range 1,',I2 / & + ' FILENAME = ', A / & + ' LINE =', I5 / & + ' => ', A /) + ! +5015 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & + ' IFC value should be in range 1,3' / & + ' FILENAME = ', A / & + ' LINE =', I5 / & + ' => ', A /) + ! + END SUBROUTINE READ_META + + !/ ------------------------------------------------------------------- / + !> @brief Decode the META header line. + !> + !> @details The internal WW3 field can be specified either as an + !> [IFI, IFJ] integer combination, or a field ID tag (such as "HS"). + !> + !> Both forms can also specify an optional component (IFC) integer + !> value for multi-component fields (defaults to 1). + !> + !> Field name ID tags are case-insensitive, HS == hs == Hs. + !> + !> @param[in] BUF Input header string (without leading META tag) + !> @param[in] ILINE Line number (for error reporting) + !> @param[out] IFI Output group number + !> @param[out] IFJ Output field number + !> @param[out] IFC Component number (defaults to 1) + !> + !> @author Chris Bunney @date 02-Feb-2021 + !/ ------------------------------------------------------------------- / + SUBROUTINE DECODE_HEADER(BUF, ILINE, IFI, IFJ, IFC) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 02-Feb-2021 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ 02-Feb-2021 : NODEFAULT option for Global meta ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Decode the META header line. + ! + ! 2. Method: + ! + ! The internal WW3 field can be specified either as an [IFI, IFJ] + ! integer combination, or a field ID tag (such as "HS"). + ! + ! Both forms can also specify an optional component (IFC) integer + ! value for multi-component fields (defaults to 1). + ! + ! Field name ID tags are case-insensitive, HS == hs == Hs. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! BUF Char. I Input header string (without leading META tag) + ! ILINE Int. I Line number (for error reporting) + ! IFI Int. O Output group number + ! IFJ Int. O Output field number + ! IFC Int. O Component number (defaults to 1) + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + USE W3IOGOMD, ONLY: W3FLDTOIJ + + IMPLICIT NONE + + CHARACTER(*), INTENT(IN) :: BUF + INTEGER, INTENT(IN) :: ILINE + INTEGER, INTENT(OUT) :: IFI, IFJ, IFC + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IERR, I + CHARACTER(LEN=10) :: FLD, OFLD, OPT + + IFI = 0 + IFJ = 1 + IFC = 1 + FLD = '' + + ! Is first value an int? + READ(BUF, *, IOSTAT=IERR) IFI + IF(IERR .EQ. 0) THEN + ! Try reading 3 values: + READ(BUF, *, iostat=IERR) IFI, IFJ, IFC + IF(IERR .NE. 0) THEN + ! Try just two values: + READ(BUF, *, IOSTAt=IERR) IFI, IFJ + ENDIF + ELSE + ! Try reading field ID plus component + READ(BUF, *, IOSTAT=IERR) FLD, IFC -!/ ------------------------------------------------------------------- / -!> @brief Reads meta data entries from the ountmeta.inp file -!> -!> @details This is the main entry routine for parsing the ounfmeta.inp -!> file. Values read from the file will be used to update or add to -!> the default meta data values set in the default_meta() -!> subroutine. -!> -!> @author Chris Bunney @date 26-Jan-2021 -!/ ------------------------------------------------------------------- / - SUBROUTINE READ_META() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 26-Jan-2021 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ 26-Jan-2021 : Added TP and alternative dir/mag ( version 7.12 ) -!/ metadata for directional fields. -!/ -! -! 1. Purpose : -! -! Reads meta data entries from the ountmeta.inp file and update -! default values set via the DEFAULT_META subroutine. -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IERR, I, NDMI - CHARACTER(LEN=256) :: BUF - TYPE(META_T), POINTER :: PMETA - CHARACTER(LEN=32) :: TEST, TESTU + IF(ierr .NE. 0) THEN + ! Try just fldid + READ(BUF, *, IOSTAT=IERR) FLD + ENDIF + ENDIF - INTEGER :: IFI, IFJ, IFC - INTEGER :: ILINE, MCNT - LOGICAL :: EOF + IF(IERR .NE. 0) THEN + WRITE(NDSE, 6000) TRIM(FN_META), ILINE, TRIM(BUF) + CALL EXTCDE(10) + ENDIf + + OFLD = FLD + CALL STR_TO_UPPER(FLD) ! field names are case insensitive + + ! If string value (FLDID), then decode into IFI,IFJ value: + IF(FLD /= '') THEN + ! Special case for "global" attributes + IF(TRIM(FLD) == "GLOBAL") THEN + IF(DEBUG) WRITE(*,'(6X,A20,1X,A)') '[GLOBAL meta sec.]', TRIM(BUF) + IFI = 999 ! Marker for global section + + ! check for any options: + I = INDEX(BUF, TRIM(OFLD)) + LEN_TRIM(OFLD) + OPT = ADJUSTL(BUF(I:)) + CALL STR_TO_UPPER(OPT) + SELECT CASE(TRIM(OPT)) + CASE("") + CONTINUE ! no option + CASE("NODEFAULT") + FL_DEFAULT_GBL_META = .FALSE. + IF(DEBUG) WRITE(*,'(6X,A20,1X,A)') '[GLOBAL meta]', 'Defaults disabled' + CASE DEFAULT + WRITE(NDSE, *) "Unknown GLOBAL extra option: [", TRIM(OPT), "]" + END SELECT + ELSE + IF(DEBUG) WRITE(*,'(6X,A20,1X,A)') '[Decoding field ID]', TRIM(BUF) + CALL W3FLDTOIJ(FLD, IFI, IFJ, 1, 1, 1) + ENDIF + ENDIF + + IF(DEBUG) WRITE(*,'(6X,A20,1X,I4,2I2)') '[IFI, IFJ, IFC]', IFI,IFJ,IFC + ! +6000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' SYNTAX ERROR IN SECTION HEADER. ' / & + ' FILENAME = ', A / & + ' LINE NO =', I5 / & + ' => ', A /) + ! + END SUBROUTINE DECODE_HEADER + + !/ ------------------------------------------------------------------- / + !> @brief Reads in attribute name/value pairs and updates the relevant + !> values in the META type. + !> + !> @details Keeps looping over input lines in file until next META section + !> or EOF is found. Splits meta pairs on the = character. + !> + !> Note - the "extra" metadata pair can also provide a variable + !> type ("c", "i", or "r"; for character, int or real respectively) + !> + !> @param[in] NDMI Unit number of metadata input file + !> @param[out] META Pointer to META type + !> @param[in,out] ILINE Current line number in file + !> + !> @author Chris Bunney @date 09-11-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE READ_META_PAIRS(NDMI, META, ILINE) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 09-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Reads in attribute name/value pairs and updates the relevant + ! values in the META type. + ! + ! 2. Method: + ! + ! Keeps looping over input lines in file until next META section + ! or EOF is found. Splits meta pairs on the = character. + ! + ! Note - the "extra" metadata pair can also provide a variable + ! type ("c", "i", or "r"; for character, int or real respectively) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDMI Int. I Unit number of metadata input file + ! META Int.Ptr. O Pointer to META type + ! ILINE Int. I/O Current line number in file + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + INTEGER, INTENT(IN) :: NDMI + TYPE(META_T), INTENT(INOUT), POINTER :: META + INTEGER, INTENT(INOUT) :: ILINE + !/ ------------------------------------------------------------------- / + !/ Local parameters + ! + CHARACTER(LEN=256) :: BUF + CHARACTER(LEN=128) :: ATTN, ATTV, TMP + CHARACTER(LEN=16) :: ATT_TYPE!, TEST + INTEGER :: I, IERR + REAL :: R + LOGICAL :: EOF, NEW + TYPE(META_PAIR_T) :: EXTRA + + ! Keep reading lines until we hit EOF or anoter META keyword + DO + CALL NEXT_LINE(NDMI, BUF, ILINE, EOF, NEW_SECTION=NEW) + IF(EOF) THEN + BACKSPACE(NDMI) + RETURN + ENDIF - NDMI = 60 - ILINE = 0 - MCNT = 0 + IF(NEW) THEN + IF(DEBUG) WRITE(*,'(I5,1X,A20)') ILINE, '[--end of section--]' + ILINE = ILINE - 1 + BACKSPACE(NDMI) + EXIT + ENDIF - OPEN(UNIT=NDMI, FILE=TRIM(FNMPRE)//TRIM(FN_META), & - STATUS="OLD", IOSTAT=IERR) + IF(DEBUG) WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[META pair]', TRIM(BUF) - IF(IERR .NE. 0) THEN - WRITE(NDSE, 5010) TRIM(FNMPRE)//TRIM(FN_META), IERR + ! Meta data should be formatted as "attr_name = attr_value" + I = INDEX(BUF, "=") + IF( I .LT. 1 ) THEN + WRITE(NDSE, 7000) FN_META, ILINE, TRIM(BUF) CALL EXTCDE(10) ENDIF - ! Loop over file, skipping comments or blank lines, until we find - ! a META line. - DO - CALL NEXT_LINE(NDMI, BUF, ILINE, EOF) - IF(EOF) EXIT - - ! Read first token on line: - READ(BUF, *) TEST - - ! A new meta-data section will start with the keyword "META" - TESTU = TEST - CALL STR_TO_UPPER(TESTU) - IF(TESTU == "META") THEN - MCNT = MCNT + 1 - - IF(DEBUG) WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[META header]', TRIM(BUF) - - ! Get the IFI, IFJ, IFC values from the header: - I = INDEX(BUF, TRIM(TEST)) + 4 ! Handles lower/mixed-case META keyword - CALL DECODE_HEADER(BUF(I:), ILINE, IFI, IFJ, IFC) - IF(IFI .EQ. -1) THEN - WRITE(NDSE, 5011) TRIM(BUF(I:)), TRIM(FN_META), ILINE - CALL EXTCDE(10) - ENDIF - - ! IFI = 999 is a section for the "global" meta data - IF(IFI .EQ. 999) THEN - CALL READ_FREEFORM_META_LIST(NDMI, ILINE, GLOBAL_META) - CYCLE - ENDIF - - ! Error checking on size of IFJ, ICOMP, IPART. - IF(IFI .LT. 1 .OR. IFI .GT. NOGRP) THEN - WRITE(NDSE,5013) NOGRP, TRIM(FN_META), ILINE - CALL EXTCDE(1) - ENDIF - IF(IFJ .LT. 1 .OR. IFJ .GT. NOGE(IFI)) THEN - WRITE(NDSE,5014) NOGE(IFI), TRIM(FN_META), ILINE - CALL EXTCDE(1) - ENDIF - IF(IFC .LT. 1 .OR. IFC .GT. 3) THEN - WRITE(NDSE,5015) TRIM(FN_META), ILINE - CALL EXTCDE(1) - ENDIF - - ! Select correct variable metadata entry: - PMETA => GROUP(IFI)%FIELD(IFJ)%META(IFC) - - ! Update the metadata with values from file: - CALL READ_META_PAIRS(NDMI, PMETA, ILINE) - - ELSE IF(TESTU == "TEMPLATE") THEN - BACKSPACE(NDMI) ! We will reprocess this line - CALL READ_PART_TMPL(NDMI, ILINE) - CYCLE - - ELSE IF(TESTU == "CRS") THEN - BACKSPACE(NDMI) ! We will reprocess this line - CALL READ_CRS_META(NDMI, ILINE) - CYCLE + ATTN = ADJUSTL(BUF(1:I-1)) + ATTV = ADJUSTL(BUF(I+1:)) - ELSE - ! Anything else is a syntax error - WRITE(NDSE, 5012) TRIM(FN_META), ILINE, TRIM(BUF) - CALL EXTCDE(10) - ENDIF - ENDDO + ! Some compilers won't read an "empty" string unless quoted: + IF(TRIM(ATTV) == '') THEN + ATTV='""' + ENDIF - CLOSE(NDMI) - !WRITE(*, 5000) MCNT, N_GBLMETA, N_CRSMETA - RETURN -! - 5000 FORMAT(/' Read in: ',I3,' variable metadata entries' / & - ' and: ',I3,' global meta data entries' / & - ' and: ',I3,' CRS meta data entries' /) -! - 5010 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' ERROR OPENING METADATA FILE'/ & - ' FILENAME = ', A / & - ' IOSTAT =', I5 /) -! - 5011 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' UNKNOWN FIELD ID: ',A / & - ' FILENAME = ', A / & - ' LINE =', I5 /) -! - 5012 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' SYNTAX ERROR ' / & - ' FILENAME = ', A / & - ' LINE =', I5 / & - ' => ', A /) -! - 5013 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & - ' IFI value should be in range 1,',I2 / & - ' FILENAME = ', A / & - ' LINE =', I5 / & - ' => ', A /) -! - 5014 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & - ' IFJ value should be in range 1,',I2 / & - ' FILENAME = ', A / & - ' LINE =', I5 / & - ' => ', A /) -! - 5015 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & - ' IFC value should be in range 1,3' / & - ' FILENAME = ', A / & - ' LINE =', I5 / & - ' => ', A /) -! - END SUBROUTINE READ_META + IERR = 0 + SELECT CASE(TRIM(attn)) + ! Character variables + ! Note: Using internal reads will allow the use of quote marks in strings + CASE("varnm") + READ(attv, *, IOSTAT=IERR) META%VARNM -!/ ------------------------------------------------------------------- / -!> @brief Decode the META header line. -!> -!> @details The internal WW3 field can be specified either as an -!> [IFI, IFJ] integer combination, or a field ID tag (such as "HS"). -!> -!> Both forms can also specify an optional component (IFC) integer -!> value for multi-component fields (defaults to 1). -!> -!> Field name ID tags are case-insensitive, HS == hs == Hs. -!> -!> @param[in] BUF Input header string (without leading META tag) -!> @param[in] ILINE Line number (for error reporting) -!> @param[out] IFI Output group number -!> @param[out] IFJ Output field number -!> @param[out] IFC Component number (defaults to 1) -!> -!> @author Chris Bunney @date 02-Feb-2021 -!/ ------------------------------------------------------------------- / - SUBROUTINE DECODE_HEADER(BUF, ILINE, IFI, IFJ, IFC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 02-Feb-2021 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ 02-Feb-2021 : NODEFAULT option for Global meta ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Decode the META header line. -! -! 2. Method: -! -! The internal WW3 field can be specified either as an [IFI, IFJ] -! integer combination, or a field ID tag (such as "HS"). -! -! Both forms can also specify an optional component (IFC) integer -! value for multi-component fields (defaults to 1). -! -! Field name ID tags are case-insensitive, HS == hs == Hs. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! BUF Char. I Input header string (without leading META tag) -! ILINE Int. I Line number (for error reporting) -! IFI Int. O Output group number -! IFJ Int. O Output field number -! IFC Int. O Component number (defaults to 1) -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - USE W3IOGOMD, ONLY: W3FLDTOIJ + CASE("ename") + READ(attv, *, IOSTAT=IERR) META%ENAME - IMPLICIT NONE + CASE("standard_name", "varns") + READ(attv, *, IOSTAT=IERR) META%VARNS - CHARACTER(*), INTENT(IN) :: BUF - INTEGER, INTENT(IN) :: ILINE - INTEGER, INTENT(OUT) :: IFI, IFJ, IFC -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IERR, I - CHARACTER(LEN=10) :: FLD, OFLD, OPT - - IFI = 0 - IFJ = 1 - IFC = 1 - FLD = '' - - ! Is first value an int? - READ(BUF, *, IOSTAT=IERR) IFI - IF(IERR .EQ. 0) THEN - ! Try reading 3 values: - READ(BUF, *, iostat=IERR) IFI, IFJ, IFC - IF(IERR .NE. 0) THEN - ! Try just two values: - READ(BUF, *, IOSTAt=IERR) IFI, IFJ - ENDIF - ELSE - ! Try reading field ID plus component - READ(BUF, *, IOSTAT=IERR) FLD, IFC + CASE("long_name", "varnl") + READ(attv, *, IOSTAT=IERR) META%VARNL - IF(ierr .NE. 0) THEN - ! Try just fldid - READ(BUF, *, IOSTAT=IERR) FLD - ENDIF - ENDIF + CASE("globwave_name", "varng") + READ(attv, *, IOSTAT=IERR) META%VARNG - IF(IERR .NE. 0) THEN - WRITE(NDSE, 6000) TRIM(FN_META), ILINE, TRIM(BUF) - CALL EXTCDE(10) - ENDIf - - OFLD = FLD - CALL STR_TO_UPPER(FLD) ! field names are case insensitive - - ! If string value (FLDID), then decode into IFI,IFJ value: - IF(FLD /= '') THEN - ! Special case for "global" attributes - IF(TRIM(FLD) == "GLOBAL") THEN - IF(DEBUG) WRITE(*,'(6X,A20,1X,A)') '[GLOBAL meta sec.]', TRIM(BUF) - IFI = 999 ! Marker for global section - - ! check for any options: - I = INDEX(BUF, TRIM(OFLD)) + LEN_TRIM(OFLD) - OPT = ADJUSTL(BUF(I:)) - CALL STR_TO_UPPER(OPT) - SELECT CASE(TRIM(OPT)) - CASE("") - CONTINUE ! no option - CASE("NODEFAULT") - FL_DEFAULT_GBL_META = .FALSE. - IF(DEBUG) WRITE(*,'(6X,A20,1X,A)') '[GLOBAL meta]', 'Defaults disabled' - CASE DEFAULT - WRITE(NDSE, *) "Unknown GLOBAL extra option: [", TRIM(OPT), "]" - END SELECT - ELSE - IF(DEBUG) WRITE(*,'(6X,A20,1X,A)') '[Decoding field ID]', TRIM(BUF) - CALL W3FLDTOIJ(FLD, IFI, IFJ, 1, 1, 1) - ENDIF - ENDIF + CASE("direction_reference", "dir_ref", "varnd") + READ(attv, *, IOSTAT=IERR) META%VARND - IF(DEBUG) WRITE(*,'(6X,A20,1X,I4,2I2)') '[IFI, IFJ, IFC]', IFI,IFJ,IFC -! - 6000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' SYNTAX ERROR IN SECTION HEADER. ' / & - ' FILENAME = ', A / & - ' LINE NO =', I5 / & - ' => ', A /) -! - END SUBROUTINE DECODE_HEADER + CASE("comment", "varnc") + READ(attv, *, IOSTAT=IERR) META%VARNC -!/ ------------------------------------------------------------------- / -!> @brief Reads in attribute name/value pairs and updates the relevant -!> values in the META type. -!> -!> @details Keeps looping over input lines in file until next META section -!> or EOF is found. Splits meta pairs on the = character. -!> -!> Note - the "extra" metadata pair can also provide a variable -!> type ("c", "i", or "r"; for character, int or real respectively) -!> -!> @param[in] NDMI Unit number of metadata input file -!> @param[out] META Pointer to META type -!> @param[in,out] ILINE Current line number in file -!> -!> @author Chris Bunney @date 09-11-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE READ_META_PAIRS(NDMI, META, ILINE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 09-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Reads in attribute name/value pairs and updates the relevant -! values in the META type. -! -! 2. Method: -! -! Keeps looping over input lines in file until next META section -! or EOF is found. Splits meta pairs on the = character. -! -! Note - the "extra" metadata pair can also provide a variable -! type ("c", "i", or "r"; for character, int or real respectively) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDMI Int. I Unit number of metadata input file -! META Int.Ptr. O Pointer to META type -! ILINE Int. I/O Current line number in file -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - INTEGER, INTENT(IN) :: NDMI - TYPE(META_T), INTENT(INOUT), POINTER :: META - INTEGER, INTENT(INOUT) :: ILINE -!/ ------------------------------------------------------------------- / -!/ Local parameters -! - CHARACTER(LEN=256) :: BUF - CHARACTER(LEN=128) :: ATTN, ATTV, TMP - CHARACTER(LEN=16) :: ATT_TYPE!, TEST - INTEGER :: I, IERR - REAL :: R - LOGICAL :: EOF, NEW - TYPE(META_PAIR_T) :: EXTRA - - ! Keep reading lines until we hit EOF or anoter META keyword - DO - CALL NEXT_LINE(NDMI, BUF, ILINE, EOF, NEW_SECTION=NEW) - IF(EOF) THEN - BACKSPACE(NDMI) - RETURN - ENDIF + CASE("units") + READ(attv, *, IOSTAT=IERR) META%UNITS - IF(NEW) THEN - IF(DEBUG) WRITE(*,'(I5,1X,A20)') ILINE, '[--end of section--]' - ILINE = ILINE - 1 - BACKSPACE(NDMI) - EXIT - ENDIF + ! Real variables + CASE("valid_min", "vmin") + READ(attv, *, IOSTAT=IERR) META%VMIN - IF(DEBUG) WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[META pair]', TRIM(BUF) + CASE("valid_max", "vmax") + READ(attv, *, IOSTAT=IERR) META%VMAX - ! Meta data should be formatted as "attr_name = attr_value" - I = INDEX(BUF, "=") - IF( I .LT. 1 ) THEN - WRITE(NDSE, 7000) FN_META, ILINE, TRIM(BUF) - CALL EXTCDE(10) - ENDIF + CASE("scale_factor", "fsc") + READ(attv, *, IOSTAT=IERR) META%FSC - ATTN = ADJUSTL(BUF(1:I-1)) - ATTV = ADJUSTL(BUF(I+1:)) + ! Default case will be the "extra" meta data variable + CASE DEFAULT + TMP = ATTV + CALL GET_ATTVAL_TYPE(TMP, ILINE, ATTV, ATT_TYPE) - ! Some compilers won't read an "empty" string unless quoted: - IF(TRIM(ATTV) == '') THEN - ATTV='""' + IF(DEBUG) THEN + WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[META extra]', & + TRIM(attn)//' = '//TRIM(attv)//' (type: '//TRIM(att_type)//")" ENDIF - IERR = 0 - SELECT CASE(TRIM(attn)) - ! Character variables - ! Note: Using internal reads will allow the use of quote marks in strings - CASE("varnm") - READ(attv, *, IOSTAT=IERR) META%VARNM + EXTRA%ATTNAME = TRIM(attn) + EXTRA%ATTVAL = TRIM(attv) + EXTRA%TYPE = TRIM(att_type) + CALL META_LIST_APPEND(META%EXTRA, EXTRA) - CASE("ename") - READ(attv, *, IOSTAT=IERR) META%ENAME + END SELECT - CASE("standard_name", "varns") - READ(attv, *, IOSTAT=IERR) META%VARNS + IF(IERR /= 0) THEN + WRITE(NDSE, 7002) FN_META, ILINE, TRIM(BUF) + CALL EXTCDE(10) + ENDIF - CASE("long_name", "varnl") - READ(attv, *, IOSTAT=IERR) META%VARNL + ENDDO + + RETURN + ! +7000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' SYNTAX ERROR IN METADATA FILE ' / & + ' SHOULD BE "attr_name = attr_value" ' / & + ' FILENAME = ', A / & + ' LINE NO =', I5 / & + ' => ', A /) + ! +7002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' IO ERROR READING ATTRIBUTE' / & + ' FILENAME = ', A / & + ' LINE NO =', I5 / & + ' => ', A /) + ! + END SUBROUTINE READ_META_PAIRS + + !/ ------------------------------------------------------------------- / + !> @brief Gets the attribute value and optional variable type from + !> the passed in string. + !> + !> @details If two freeform values can be read from the input string, + !> it is assumed to be a value and type, otherwise if only one value + !> can be read the type is assumed to be "character". + !> + !> It is important to quote strings if they contain spaces. + !> + !> Valid types are "c" "r/f", and "i" for character, real/float and + !> integer values. + !> + !> @param[in] BUF Input string to process + !> @param[in] ILINE Line number (for error reporting) + !> @param[out] ATTV Attribute value + !> @param[out] ATT_TYPE Attribute type + !> + !> @author Chris Bunney @date 09-Nov-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE GET_ATTVAL_TYPE(BUF, ILINE, ATTV, ATT_TYPE) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 09-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Gets the attribute value and optional variable type from + ! the passed in string. + ! + ! 2. Method: + ! + ! If two freeform values can be read from the input string, it is + ! assumed to be a value and type, otherwise if only one value can + ! be read the type is assumed to be "character". + ! + ! It is important to quote strings if they contain spaces. + ! + ! Valid types are "c" "r/f", and "i" for character, real/float and + ! integer values. + + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! BUF Char. I Input string to process + ! ILINE Int. I Line number (for error reporting) + ! ATTV Char. O Attribute value + ! ATT_TYPE Char. O Attribute type + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + CHARACTER(*), INTENT(IN) :: BUF + INTEGER, INTENT(IN) :: ILINE + CHARACTER(*), INTENT(OUT) :: ATTV, ATT_TYPE + !/ ------------------------------------------------------------------- / + !/ Local parameters + ! + REAL :: R + INTEGER :: I, IERR + + ! Get attribute and type (default to "c" if no type set) + ATT_TYPE = 'c' + ATTV = '' + READ(BUF, *, IOSTAT=IERR) ATTV, ATT_TYPE + IF(IERR /= 0) READ(BUF, *, IOSTAT=IERR) ATTV + + ! Check attr values are valid w.r.t. attr type + SELECT CASE(TRIM(att_type)) + + CASE("i") + READ(attv, *, iostat=ierr) i + IF(ierr .ne. 0) then + WRITE(NDSE, 8001) "INTEGER", TRIM(FN_META), ILINE, TRIM(ATTV) + CALL EXTCDE(10) + ENDIF - CASE("globwave_name", "varng") - READ(attv, *, IOSTAT=IERR) META%VARNG + CASE("r", "f") + READ(attv, *, iostat=ierr) r + IF(ierr .ne. 0) THEN + WRITE(NDSE, 8001) "REAL/FLOAT", TRIM(FN_META), ILINE, TRIM(ATTV) + CALL EXTCDE(10) + ENDIF - CASE("direction_reference", "dir_ref", "varnd") - READ(attv, *, IOSTAT=IERR) META%VARND + CASE("c") + ! Always ok. - CASE("comment", "varnc") - READ(attv, *, IOSTAT=IERR) META%VARNC + CASE DEFAULT + WRITE(NDSE, 8002) TRIM(FN_META), ILINE, TRIM(BUF) + CALL EXTCDE(10) - CASE("units") - READ(attv, *, IOSTAT=IERR) META%UNITS + END SELECT + ! +8001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' VALUE IS NOT A VALID ', A / & + ' FILENAME = ', A / & + ' LINE NO =', I5 / & + ' => ', A /) + ! +8002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' ATTRIBUTE TYPE SHOULD BE ONE OF [c,i,r] '/ & + ' FILENAME = ', A / & + ' LINE NO =', I5 / & + ' => ', A /) + ! + END SUBROUTINE GET_ATTVAL_TYPE + + !/ ------------------------------------------------------------------- / + !> @brief Reads in freeform attribute name/value pairs. + !> + !> @details Keeps looping over input lines in file until next section + !> or EOF is found. Splits meta pairs on the `=` character. + !> + !> Freeform metadata pairs can also provide a variable type + !> ("c", "i", or "r"; for character, int or real respectively). + !> String values with spaces should be quoted. + !> + !> @param[in] NDMI Unit number of metadata input file + !> @param[in,out] ILINE Current line number in file + !> @param[in,out] METALIST A META_LIST_T object to append to + !> + !> @author Chris Bunney @date 16-Dec-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE READ_FREEFORM_META_LIST(NDMI, ILINE, METALIST) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 16-Dec-2020 | + !/ +-----------------------------------+ + !/ + !/ 16-Dec-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Reads in freeform attribute name/value pairs. + ! + ! 2. Method: + ! + ! Keeps looping over input lines in file until next section + ! or EOF is found. Splits meta pairs on the = character. + ! + ! Freeform metadata pairs can also provide a variable type + ! ("c", "i", or "r"; for character, int or real respectively). + ! String values with spaces should be quoted. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDMI Char. I Unit number of metadata input file + ! ILINE Int. I/O Current line number in file + ! METALIST Type. I/O A META_LIST_T object to append to + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + INTEGER, INTENT(IN) :: NDMI + INTEGER, INTENT(INOUT) :: ILINE + TYPE(META_LIST_T), INTENT(INOUT) :: METALIST + + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER(LEN=256) :: BUF + CHARACTER(LEN=128) :: ATTN, ATTV, TMP + CHARACTER(LEN=16) :: ATT_TYPE + INTEGER :: I, IERR + REAL :: R + LOGICAL :: EOF, NEW + TYPE(META_PAIR_T) :: META + ! + ! Keep reading lines until we hit EOF or anoter META keyword + DO + CALL NEXT_LINE(NDMI, BUF, ILINE, EOF, NEW_SECTION=NEW) + IF(EOF) THEN + BACKSPACE(NDMI) + RETURN + ENDIF - ! Real variables - CASE("valid_min", "vmin") - READ(attv, *, IOSTAT=IERR) META%VMIN + IF(NEW) THEN + IF(DEBUG) WRITE(*,'(I5,1X,A20)') ILINE, '[--end of section--]' + ILINE = ILINE - 1 + BACKSPACE(NDMI) + EXIT + ENDIF - CASE("valid_max", "vmax") - READ(attv, *, IOSTAT=IERR) META%VMAX + ! Split attr name/value pair + I = INDEX(BUF, "=") + IF( I .LT. 1 ) THEN + WRITE(NDSE, 9000) TRIM(FN_META), ILINE, TRIM(BUF) + CALL EXTCDE(10) + ENDIF - CASE("scale_factor", "fsc") - READ(attv, *, IOSTAT=IERR) META%FSC + ATTN = ADJUSTL(BUF(1:I-1)) + TMP = ADJUSTL(BUF(I+1:)) - ! Default case will be the "extra" meta data variable - CASE DEFAULT - TMP = ATTV - CALL GET_ATTVAL_TYPE(TMP, ILINE, ATTV, ATT_TYPE) + ! Get type, if set: + CALL GET_ATTVAL_TYPE(TMP, ILINE, ATTV, ATT_TYPE) - IF(DEBUG) THEN - WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[META extra]', & - TRIM(attn)//' = '//TRIM(attv)//' (type: '//TRIM(att_type)//")" - ENDIF + IF(DEBUG) THEN + WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[FREEFORM meta]', & + TRIM(attn)//' = '//TRIM(attv)//' (type: '//TRIM(att_type)//")" + ENDIF - EXTRA%ATTNAME = TRIM(attn) - EXTRA%ATTVAL = TRIM(attv) - EXTRA%TYPE = TRIM(att_type) - CALL META_LIST_APPEND(META%EXTRA, EXTRA) - END SELECT + META%ATTNAME = TRIM(ATTN) + META%ATTVAL = TRIM(ATTV) + META%TYPE = TRIM(ATT_TYPE) + + CALL META_LIST_APPEND(METALIST, META) + + ENDDO + ! +9000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' SYNTAX ERROR IN METADATA FILE ' / & + ' SHOULD BE "attr_name = attr_value" ' / & + ' FILENAME = ', A / & + ' LINE NO =', I5 / & + ' => ', A /) + ! + END SUBROUTINE READ_FREEFORM_META_LIST + + !/ ------------------------------------------------------------------- / + !> @brief Reads in metadata for the coordinate reference system (CRS). + !> + !> @details The "grid_mapping_name" must be supplied as an attribute. + !> + !> @param[in] NDMI Unit number of metadata input file + !> @param[in,out] ILINE Current line number in file + !> + !> @author Chris Bunney @date 07-Dec-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE READ_CRS_META(NDMI, ILINE) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 07-Dec-2020 | + !/ +-----------------------------------+ + !/ + !/ 07-Dec-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Reads in metadata for the coordinate reference system (CRS) + ! scalar variable. The "grid_mapping_name" must be supplied as + ! an attribute. + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDMI Char. I Unit number of metadata input file + ! ILINE Int. I/O Current line number in file + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + INTEGER, INTENT(IN) :: NDMI + INTEGER, INTENT(INOUT) :: ILINE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER(LEN=128) :: BUF, PREV_NAME + INTEGER :: I, IERR + + PREV_NAME = CRS_NAME + + ! Re-read header line (we only want the second field) + READ(NDMI, '(A)') BUF + READ(BUF, *, IOSTAT=IERR) CRS_NAME, CRS_NAME + IF(IERR /= 0 ) THEN + WRITE(NDSE,1000) + WRITE(NDSE,2000) TRIM(FN_META), ILINE, TRIM(BUF) + CALL EXTCDE(10) + ENDIF + IF(DEBUG) WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[CRS id]', TRIM(CRS_NAME) - IF(IERR /= 0) THEN - WRITE(NDSE, 7002) FN_META, ILINE, TRIM(BUF) - CALL EXTCDE(10) - ENDIF + IF(CRS_META%N .NE. 0) THEN + IF(CRS_IS_DEFAULT) THEN + WRITE(NDSE,1001) TRIM(PREV_NAME) + CRS_IS_DEFAULT = .FALSE. + ELSE + WRITE(NDSE,1002) TRIM(PREV_NAME) + ENDIF + WRITE(NDSE,2000) TRIM(FN_META), ILINE, TRIM(BUF) + CALL DEL_META_LIST(CRS_META) + ENDIF - ENDDO + CALL READ_FREEFORM_META_LIST(NDMI, ILINE, CRS_META) - RETURN -! - 7000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' SYNTAX ERROR IN METADATA FILE ' / & - ' SHOULD BE "attr_name = attr_value" ' / & - ' FILENAME = ', A / & - ' LINE NO =', I5 / & - ' => ', A /) -! - 7002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' IO ERROR READING ATTRIBUTE' / & - ' FILENAME = ', A / & - ' LINE NO =', I5 / & - ' => ', A /) -! - END SUBROUTINE READ_META_PAIRS + ! Check that "grid_mapping_name" is defined + IF(.NOT. META_LIST_HAS_ATTR(CRS_META, "grid_mapping_name")) THEN + WRITE(NDSE, 1003) + WRITE(NDSE, 2000) TRIM(FN_META), ILINE, "" + CALL EXTCDE(10) + ENDIF + + RETURN + +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' ERROR READING CRS HEADER - MISSING CRS NAME?' ) + ! +1001 FORMAT (/' *** WARNING : USER DEFINED CRS SECTION WILL ' / & + ' OVERIDE DEFAULT CRS DEFINITION FOR GRID' / & + ' PREV CRS = ', A ) + ! +1002 FORMAT (/' *** WARNING : DUPLICATE CRS SECTION WILL ' / & + ' OVERRIDE PREVIOUS CRS DEFINITION' / & + ' PREV CRS = ', A ) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' CRS SECTION DOES NOT CONTAIN MANDATORY '/ & + ' ATTRIBUTE "grid_mapping_name"' ) + +2000 FORMAT ( ' FILENAME = ', A / & + ' LINE NO = ', I5 / & + ' => ', A /) + ! + + END SUBROUTINE READ_CRS_META + + !/ ------------------------------------------------------------------- / + !> @brief Set up a default coordinate reference system for the grid + !> + !> @details The default coordinate reference system (CRS) will be defined + !> based on the type of grid the model is formulated on, e.g. + !> regular lat-lon, rotated pole, etc. + !> + !> @remark See "Grid Mappings" section of CF conventions: + !> - https://cfconventions.org/Data/cf-conventions/cf-conventions-1.7/build/ch05s06.html + !> - https://cfconventions.org/Data/cf-conventions/cf-conventions-1.7/build/apf.html + !> + !> @author Chris Bunney @date 25-May-2021 + !/ ------------------------------------------------------------------- / + SUBROUTINE DEFAULT_CRS_META() + IMPLICIT NONE + + TYPE(META_PAIR_T) :: META + + IF(FLRTD) THEN +#ifdef W3_RTD + ! Rotated pole location + CRS_NAME = 'rotated_pole' + CALL META_LIST_APPEND(CRS_META, & + 'grid_mapping_name', 'rotated_latitude_longitude') + CALL META_LIST_APPEND(CRS_META, & + 'grid_north_pole_latitude', POLAT) + CALL META_LIST_APPEND(CRS_META, & + 'grid_north_pole_longitude', POLON) + CRS_IS_DEFAULT = .TRUE. +#endif + ELSE IF(GTYPE .EQ. UNGTYPE) THEN + ! ! What do we want for unstructure grids? + ELSE + ! Lat/lon grid + CRS_NAME = 'crs' + CALL META_LIST_APPEND(CRS_META, & + 'grid_mapping_name', 'latitude_longitude') + ! TODO: Default to a spherical Earth? + CALL META_LIST_APPEND(CRS_META, & + 'semi_major_axis', 6371000.0) + CALL META_LIST_APPEND(CRS_META, & + 'inverse_flattening', 0.0) + ENDIF + + END SUBROUTINE DEFAULT_CRS_META + + !/ ------------------------------------------------------------------- / + !> @brief Get the meta data for a particular field. + !> + !> @details The required field is specified using the group (IFI) and + !> field (IFJ) index. Optionally, the component (ICOMP) and partition + !> (IPART) numbers can be specified for vector/tensor or partitioned + !> parameter fields. If not specified, these default to 1. + + !> A copy of the meta-data is returned, rather than a pointer. + !> This is because in the case of paritioned parameters, the metadata + !> will be updated with the partition number. + !> + !> @param[in] IFI Output group number + !> @param[in] IFJ Output field number + !> @param[in] ICOMP Component number (defaults to 1) + !> @param[in] IPART Partition number (defaults to 1) + !> + !> @author Chris Bunney @date 02-Nov-2020 + !/ ------------------------------------------------------------------- / + FUNCTION GETMETA(IFI, IFJ, ICOMP, IPART) RESULT(META) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 02-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Returns a META_T type containig the netCDF matadata for the + ! requested field + ! + ! 2. Method : + ! + ! A copy of the meta-data is returned, rather than a pointer. This + ! is because in the case of paritioned parameters, the metadata + ! will be updated with the partition number. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IFI Int. I Output group number + ! IFJ Int. I Output field number + ! ICOMP Int. I Component number (defaults to 1) + ! IPART Int. I Partition number (defaults to 1) + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + INTEGER, INTENT(IN) :: IFI, IFJ + INTEGER, INTENT(IN), OPTIONAL :: ICOMP, IPART + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IFP, IFC + TYPE(META_T) :: META ! Not pointer as we might need to modify it + + IFC = 1 + IFP = 1 + IF(PRESENT(ICOMP)) IFC = ICOMP + IF(PRESENT(IPART)) IFP = IPART + + ! Error checking on size of IFJ, ICOMP, IPART. + IF(IFI .LT. 1 .OR. IFI .GT. NOGRP) THEN + WRITE(NDSE,1000) NOGRP + CALL EXTCDE(1) + ENDIF + IF(IFJ .LT. 1 .OR. IFJ .GT. NOGE(IFI)) THEN + WRITE(NDSE,1001) NOGE(IFI) + CALL EXTCDE(1) + ENDIF + IF(IFC .LT. 1 .OR. IFC .GT. 3) THEN + WRITE(NDSE,1002) + CALL EXTCDE(1) + ENDIF + + META = META_DEEP_COPY(GROUP(IFI)%FIELD(IFJ)%META(IFC)) + + ! For partitioned data, expand in the partition number: + IF(IFI .EQ. 4) THEN + CALL ADD_PARTNO(META, IFP) + ENDIF + + RETURN + +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & + ' GETMETA: IFI value should be in range 1,',I2 / ) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & + ' GETMETA: IFJ value should be in range 1,',I2 / ) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & + ' GETMETA: IFC value should be in range 1,3' / ) + ! + END FUNCTION GETMETA + + !/ ------------------------------------------------------------------- / + !> @brief Reads in a TEMPLATE section from file. + !> + !> @details This section defines a list of text strings that will be + !> used to replace a "placeholder string" when generating metadata + !> for partitioned parameters. + !> + !> Format of section is: + !> + !> \code + !> TEMPLATE + !> Value for partition IPART=0 + !> Value for partition IPART=1 + !> Value for partition IPART=2 + !> ... + !> Value for partition IPART=N + !> \endcode + !> + !> @param[in,out] NDMI Unit number + !> @param[in,out] ILINE Line number + !> + !> @author Chris Bunney @date 04-Dec-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE READ_PART_TMPL(NDMI, ILINE) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 04-Dec-2020 | + !/ +-----------------------------------+ + !/ + !/ 04-Dec-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Reads in a TEMPLATE section from file. + ! This section defines a list of text strings that will be used + ! to replace a "placeholder string" when generating metadata for + ! partitioned parameters. + ! + ! Format of section is: + ! + ! TEMPLATE + ! Value for partition IPART=0 + ! Value for partition IPART=1 + ! Value for partition IPART=2 + ! ... + ! Value for partition IPART=N + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDMI Int. I/O Unit number + ! ILINE Int. I/O Line number + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + INTEGER, INTENT(IN) :: NDMI + INTEGER, INTENT(INOUT) :: ILINE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER(LEN=256) :: BUF, ID + INTEGER :: IERR + LOGICAL :: EOF, NEW + TYPE(PART_TMPL_T), POINTER :: P + + ! Re-read META line to get template string ID (the 2nd field) + READ(NDMI, '(A)') BUF + READ(BUF, *, IOSTAT=IERR) ID, ID + IF(IERR /= 0) THEN + WRITE(NDSE, 1000) FN_META, ILINE, BUF + CALL EXTCDE(10) + ENDIF + ID = "<" // TRIM(ID) // ">" -!/ ------------------------------------------------------------------- / -!> @brief Gets the attribute value and optional variable type from -!> the passed in string. -!> -!> @details If two freeform values can be read from the input string, -!> it is assumed to be a value and type, otherwise if only one value -!> can be read the type is assumed to be "character". -!> -!> It is important to quote strings if they contain spaces. -!> -!> Valid types are "c" "r/f", and "i" for character, real/float and -!> integer values. -!> -!> @param[in] BUF Input string to process -!> @param[in] ILINE Line number (for error reporting) -!> @param[out] ATTV Attribute value -!> @param[out] ATT_TYPE Attribute type -!> -!> @author Chris Bunney @date 09-Nov-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE GET_ATTVAL_TYPE(BUF, ILINE, ATTV, ATT_TYPE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 09-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Gets the attribute value and optional variable type from -! the passed in string. -! -! 2. Method: -! -! If two freeform values can be read from the input string, it is -! assumed to be a value and type, otherwise if only one value can -! be read the type is assumed to be "character". -! -! It is important to quote strings if they contain spaces. -! -! Valid types are "c" "r/f", and "i" for character, real/float and -! integer values. - -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! BUF Char. I Input string to process -! ILINE Int. I Line number (for error reporting) -! ATTV Char. O Attribute value -! ATT_TYPE Char. O Attribute type -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE + IF(DEBUG) WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[template id]', TRIM(ID) - CHARACTER(*), INTENT(IN) :: BUF - INTEGER, INTENT(IN) :: ILINE - CHARACTER(*), INTENT(OUT) :: ATTV, ATT_TYPE -!/ ------------------------------------------------------------------- / -!/ Local parameters -! - REAL :: R - INTEGER :: I, IERR - - ! Get attribute and type (default to "c" if no type set) - ATT_TYPE = 'c' - ATTV = '' - READ(BUF, *, IOSTAT=IERR) ATTV, ATT_TYPE - IF(IERR /= 0) READ(BUF, *, IOSTAT=IERR) ATTV - - ! Check attr values are valid w.r.t. attr type - SELECT CASE(TRIM(att_type)) - - CASE("i") - READ(attv, *, iostat=ierr) i - IF(ierr .ne. 0) then - WRITE(NDSE, 8001) "INTEGER", TRIM(FN_META), ILINE, TRIM(ATTV) - CALL EXTCDE(10) - ENDIF - - CASE("r", "f") - READ(attv, *, iostat=ierr) r - IF(ierr .ne. 0) THEN - WRITE(NDSE, 8001) "REAL/FLOAT", TRIM(FN_META), ILINE, TRIM(ATTV) - CALL EXTCDE(10) - ENDIF - - CASE("c") - ! Always ok. + ! Extend list of partition template types: + IF(ASSOCIATED(PART_TMPL)) THEN + ! Got to end of list + P => PART_TMPL + DO WHILE(ASSOCIATED(P%NEXT)) + P => P%NEXT + ENDDO + ALLOCATE(P%NEXT) + P => P%NEXT + ELSE + ALLOCATE(PART_TMPL) + P => PART_TMPL + ENDIF + + ! Set template id and read template strings from file: + P%TMPL = TRIM(ID) + ALLOCATE(P%PART_TEXT(0:NOSWLL)) + NULLIFY(P%NEXT) + P%NP = 0 + + DO + CALL NEXT_LINE(NDMI, BUF, ILINE, EOF, NEW_SECTION=NEW) + IF(EOF) THEN + BACKSPACE(NDMI) + RETURN + ENDIF - CASE DEFAULT - WRITE(NDSE, 8002) TRIM(FN_META), ILINE, TRIM(BUF) - CALL EXTCDE(10) + IF(NEW) THEN + ! Start of new meta data entry + IF(DEBUG) WRITE(*,'(I5,1X,A20)') ILINE, '[--end of section--]' + ILINE = ILINE - 1 + BACKSPACE(NDMI) + EXIT + ENDIF - END SELECT -! - 8001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' VALUE IS NOT A VALID ', A / & - ' FILENAME = ', A / & - ' LINE NO =', I5 / & - ' => ', A /) -! - 8002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' ATTRIBUTE TYPE SHOULD BE ONE OF [c,i,r] '/ & - ' FILENAME = ', A / & - ' LINE NO =', I5 / & - ' => ', A /) -! - END SUBROUTINE GET_ATTVAL_TYPE + ! Check we have not exceeded NOSWLL + IF(P%NP .GT. NOSWLL) THEN + WRITE(*,*) "Too many partition entries (NOSWLL=",NOSWLL,"). Ignoring" + CYCLE + ENDIF -!/ ------------------------------------------------------------------- / -!> @brief Reads in freeform attribute name/value pairs. -!> -!> @details Keeps looping over input lines in file until next section -!> or EOF is found. Splits meta pairs on the `=` character. -!> -!> Freeform metadata pairs can also provide a variable type -!> ("c", "i", or "r"; for character, int or real respectively). -!> String values with spaces should be quoted. -!> -!> @param[in] NDMI Unit number of metadata input file -!> @param[in,out] ILINE Current line number in file -!> @param[in,out] METALIST A META_LIST_T object to append to -!> -!> @author Chris Bunney @date 16-Dec-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE READ_FREEFORM_META_LIST(NDMI, ILINE, METALIST) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 16-Dec-2020 | -!/ +-----------------------------------+ -!/ -!/ 16-Dec-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Reads in freeform attribute name/value pairs. -! -! 2. Method: -! -! Keeps looping over input lines in file until next section -! or EOF is found. Splits meta pairs on the = character. -! -! Freeform metadata pairs can also provide a variable type -! ("c", "i", or "r"; for character, int or real respectively). -! String values with spaces should be quoted. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDMI Char. I Unit number of metadata input file -! ILINE Int. I/O Current line number in file -! METALIST Type. I/O A META_LIST_T object to append to -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - INTEGER, INTENT(IN) :: NDMI - INTEGER, INTENT(INOUT) :: ILINE - TYPE(META_LIST_T), INTENT(INOUT) :: METALIST + ! Add string to array of partition text + IF(DEBUG) THEN + WRITE(*,'(I5,1X,A20,1X,I1,1X,A)') ILINE, '[part template]', & + P%NP, TRIM(BUF) + ENDIF -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER(LEN=256) :: BUF - CHARACTER(LEN=128) :: ATTN, ATTV, TMP - CHARACTER(LEN=16) :: ATT_TYPE - INTEGER :: I, IERR - REAL :: R - LOGICAL :: EOF, NEW - TYPE(META_PAIR_T) :: META -! - ! Keep reading lines until we hit EOF or anoter META keyword - DO - CALL NEXT_LINE(NDMI, BUF, ILINE, EOF, NEW_SECTION=NEW) - IF(EOF) THEN - BACKSPACE(NDMI) - RETURN - ENDIF + P%PART_TEXT(P%NP) = TRIM(ADJUSTL(BUF)) ! Zero indexed + P%NP = P%NP + 1 + ENDDO + + RETURN + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & + ' ERROR READING PART HEADER - MISSING TEMPLATE ID?'/ & + ' FILENAME = ', A / & + ' LINE NO =', I5 / & + ' => ', A /) + ! + END SUBROUTINE READ_PART_TMPL + + + !/ ------------------------------------------------------------------- / + !> @brief Prints the patition templates to screen (for debug use). + !> @author Chris Bunney @date 04-Dec-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE PRINT_PART_TMPL() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 04-Dec-2020 | + !/ +-----------------------------------+ + !/ + !/ 04-Dec-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Prints the patition templates to screen (for debug use). + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(PART_TMPL_T), POINTER :: P + INTEGER :: I + + PRINT*,'==============' + IF(.NOT. ASSOCIATED(PART_TMPL)) THEN + PRINT*,'Empty partition list' + RETURN + ENDIF - IF(NEW) THEN - IF(DEBUG) WRITE(*,'(I5,1X,A20)') ILINE, '[--end of section--]' - ILINE = ILINE - 1 - BACKSPACE(NDMI) - EXIT + P => PART_TMPL + DO + PRINT*,P%TMPL + DO I=0,P%NP - 1 + PRINT*,' - ',I,TRIM(P%PART_TEXT(I)) + ENDDO + IF(.NOT. ASSOCIATED(P%NEXT)) EXIT + P => P%NEXT + ENDDO + PRINT*,'==============' + END SUBROUTINE PRINT_PART_TMPL + + !/ ------------------------------------------------------------------- / + !> @brief Adds partition number to meta-data. + !> + !> @details Replaces all instances of "" in the provided meta data + !> with the partition number IPART. + !> + !> @param[in] META Meta data type + !> @param[in] IPART Partition number + !> + !> @author Chris Bunney @date 02-Nov-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE ADD_PARTNO(META, IPART) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 02-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Adds partition number to meta-data. + ! + ! 2. Method : + ! + ! Replaces all instances of "" in the provided meta data with + ! the partition number IPART. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! META META_T I Meta data type + ! IPART Int. I Partition number + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + TYPE(META_T), INTENT(INOUT) :: META + INTEGER, INTENT(IN) :: IPART + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER(LEN=80) :: TMP + INTEGER :: I, J + TYPE(META_PAIR_T), POINTER :: P + + CALL PARTNO_STRING_SUB(META%ENAME, IPART) + CALL PARTNO_STRING_SUB(META%VARNM, IPART) + CALL PARTNO_STRING_SUB(META%VARNL, IPART) + CALL PARTNO_STRING_SUB(META%VARNS, IPART) + CALL PARTNO_STRING_SUB(META%VARNG, IPART) + CALL PARTNO_STRING_SUB(META%VARNC, IPART) + CALL PARTNO_STRING_SUB(META%VARND, IPART) + IF(META%EXTRA%N .GT. 0) THEN + P => META%EXTRA%HEAD + DO + CALL PARTNO_STRING_SUB(P%ATTNAME, IPART) + IF(P%TYPE .EQ. "c") THEN + CALL PARTNO_STRING_SUB(P%ATTVAL, IPART) ENDIF + IF(.NOT. ASSOCIATED(P%NEXT)) EXIT + P => P%NEXT + ENDDO + ENDIF + + END SUBROUTINE ADD_PARTNO + + !/ ------------------------------------------------------------------- / + !> @brief Performs string substition of placeholder strings with + !> partition number specfic values. + !> + !> @details The placeholder \ is automatically replaced with the + !> partition number (0, 1, 2, etc). + !> + !> Other template placeholders can be defined in the ounfmeta.inp + !> file by the user. + !> + !> @param[in,out] INSTR Input string + !> @param[in] IPART Partition number + !> + !> @author Chris Bunney @date 02-Nov-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE PARTNO_STRING_SUB(INSTR, IPART) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 02-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Performs string substition of placeholder strings with partition + ! number specfic values. + ! + ! The placeholder is automatically replaced with the + ! partition number (0, 1, 2, etc). + ! + ! Other template placeholders can be defined in the ounfmeta.inp + ! file by the user. + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INSTR Char. I/O Input string + ! IPART Int. I Partition number + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + CHARACTER(LEN=*), INTENT(INOUT) :: INSTR + INTEGER, INTENT(IN) :: IPART + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, J, ISN + TYPE(PART_TMPL_T), POINTER :: P + CHARACTER(LEN=512) :: TMPL + + ISN = IPART + 1 + IF(PTMETH .LE. 3) THEN + IF (ISN .GT. 5) ISN = 5 + ELSE + IF (ISN .GT. 2) ISN = 2 + ENDIF + + ! Set partition number (built-in IPART template) + I = INDEX(INSTR, IPART_TOKEN) + J = I + LEN_TRIM(IPART_TOKEN) + IF(I .GT. 0) THEN + WRITE(TMPL, '(A,I1,A)') INSTR(1:I-1), IPART, INSTR(J:LEN(INSTR)) + INSTR = TMPL + ENDIF + + ! Set standard name string (built-in SPART template) + I = INDEX(INSTR, SPART_TOKEN) + J = I + LEN_TRIM(SPART_TOKEN) + + IF(I .GT. 0) THEN + INSTR = INSTR(1:I-1) // TRIM(SNAMEP(ISN)) // INSTR(J:LEN(INSTR)) + ENDIF + + ! Also try underscore separated version: + I = INDEX(INSTR, SPART_TOKEN_) + J = I + LEN_TRIM(SPART_TOKEN_) + + IF(I .GT. 0) THEN + INSTR = INSTR(1:I-1) // TRIM(REPLACE_CHAR(SNAMEP(ISN), " ", "_")) & + // INSTR(J:LEN(INSTR)) + ENDIF + + ! Merge in user defined partition templates (if any): + IF(.NOT. ASSOCIATED(PART_TMPL)) RETURN + + P => PART_TMPL + DO + I = INDEX(INSTR, TRIM(P%TMPL)) + J = I + LEN_TRIM(P%TMPL) - ! Split attr name/value pair - I = INDEX(BUF, "=") - IF( I .LT. 1 ) THEN - WRITE(NDSE, 9000) TRIM(FN_META), ILINE, TRIM(BUF) + IF(I .GT. 0) THEN + IF(IPART .GE. P%NP) THEN + WRITE(NDSE, 1000) TRIM(P%TMPL), P%NP, IPART CALL EXTCDE(10) ENDIF + INSTR = INSTR(1:I-1) // TRIM(P%PART_TEXT(IPART)) // INSTR(J:LEN(INSTR)) + ENDIF - ATTN = ADJUSTL(BUF(1:I-1)) - TMP = ADJUSTL(BUF(I+1:)) - - ! Get type, if set: - CALL GET_ATTVAL_TYPE(TMP, ILINE, ATTV, ATT_TYPE) + ! Try "underscore" version : + I = LEN_TRIM(P%TMPL) + TMPL = P%TMPL(1:I-1) // "_>" + I = INDEX(INSTR, TRIM(TMPL)) + J = I + LEN_TRIM(TMPL) + IF(I .GT. 0) THEN + INSTR = INSTR(1:I-1) // TRIM(REPLACE_CHAR(P%PART_TEXT(IPART), " ", "_")) & + // INSTR(J:LEN(INSTR)) + ENDIF - IF(DEBUG) THEN - WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[FREEFORM meta]', & - TRIM(attn)//' = '//TRIM(attv)//' (type: '//TRIM(att_type)//")" - ENDIF + IF(.NOT. ASSOCIATED(P%NEXT)) EXIT + P => P%NEXT + ENDDO + + RETURN + +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & + ' NOT ENOUGH USER DEFINED ENTRIES FOR TEMPLATE' / & + ' TEMPLATE ID : ',A / & + ' NUM ENTRIES : ',I2 / & + ' REQESTED IPART* : ',I2 / & + ' (*Note: IPART is zero-refernced)' / & + ' Please update your ounfmeta.inp file.' /) + + END SUBROUTINE PARTNO_STRING_SUB + + !/ ------------------------------------------------------------------- / + !> @brief Writes the meta-data entries for a variable. + !> + !> @details Attribute pairs defined in META are written to the netCDF + !> variable specificed in the VARID handle. + !> + !> There are two stages to the write - first all "mandatory" or + !> "pre-defined" attributes are written out (those defined in the + !> META_T type). Secondly, if there is any user-defined "extra" + !> freeform meta data defined, this is written out via a separate + !> call to write_freeform_meta_list(). + !> + !> @param[in,out] NCID NetCDF file ID + !> @param[in,out] VARID NetCDF variable ID + !> @param[in] META Meta data type + !> @param[out] ERR Error value + !> + !> @author Chris Bunney @date 02-Nov-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE WRITE_META(NCID, VARID, META, ERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 02-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Writes the meta-data entries for a variable. + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NCID Int. I/O NetCDF file ID + ! VARID Int. I/O NetCDF variable ID + ! META Int. I Meta data type + ! ERR Int. O Error value + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NCID, VARID + TYPE(META_T), INTENT(IN) :: META + INTEGER, INTENT(OUT) :: ERR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IVAL, VAL + REAL :: RVAL + !/ + ERR = NF90_PUT_ATT(NCID, VARID, 'long_name', META%VARNL) + IF(ERR /= NF90_NOERR) RETURN + + IF(META%VARNS .NE. '' .AND. META%VARNS .NE. UNSETC) THEN + ERR = NF90_PUT_ATT(NCID, VARID, 'standard_name', META%VARNS) + IF(ERR /= NF90_NOERR) RETURN + ENDIF + IF(META%VARNG .NE. '' .AND. META%VARNG .NE. UNSETC) THEN + ERR = NF90_PUT_ATT(NCID, VARID, 'globwave_name', META%VARNG) + IF(ERR /= NF90_NOERR) RETURN + ENDIF + + ERR = NF90_PUT_ATT(NCID, VARID, 'units', META%UNITS) + IF(ERR /= NF90_NOERR) RETURN + + ! Fill value dependent on variable type + IF(NCVARTYPE .EQ. 2) THEN + ERR = NF90_PUT_ATT(NCID, VARID, '_FillValue', NF90_FILL_SHORT) + ELSE + ERR = NF90_PUT_ATT(NCID, VARID, '_FillValue', NF90_FILL_FLOAT) + END IF + IF(ERR /= NF90_NOERR) RETURN + + ERR = NF90_PUT_ATT(NCID, VARID, 'scale_factor', META%FSC) + IF(ERR /= NF90_NOERR) RETURN + + ERR = NF90_PUT_ATT(NCID, VARID, 'add_offset', 0.) + IF(ERR /= NF90_NOERR) RETURN + + ! For variables with vartype SHORT, the valid min/max + ! are scaled by scale_factor and converted to integers. + ! If vartype is FLOAT, then no scaling is performed and + ! valid min/max are written out directly as floats. + IF(NCVARTYPE .EQ. 2) THEN + VAL = NINT(META%VMIN / META%FSC) + ERR = NF90_PUT_ATT(NCID, VARID,'valid_min', VAL) + IF(ERR /= NF90_NOERR) RETURN - META%ATTNAME = TRIM(ATTN) - META%ATTVAL = TRIM(ATTV) - META%TYPE = TRIM(ATT_TYPE) + VAL = NINT(META%VMAX / META%FSC) + ERR = NF90_PUT_ATT(NCID, VARID,'valid_max', VAL) + IF(ERR /= NF90_NOERR) RETURN + ELSE + ERR = NF90_PUT_ATT(NCID, VARID,'valid_min', META%VMIN) + IF(ERR /= NF90_NOERR) RETURN - CALL META_LIST_APPEND(METALIST, META) + ERR = NF90_PUT_ATT(NCID, VARID,'valid_max', META%VMAX) + IF(ERR /= NF90_NOERR) RETURN + ENDIF - ENDDO -! - 9000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' SYNTAX ERROR IN METADATA FILE ' / & - ' SHOULD BE "attr_name = attr_value" ' / & - ' FILENAME = ', A / & - ' LINE NO =', I5 / & - ' => ', A /) -! - END SUBROUTINE READ_FREEFORM_META_LIST + IF(META%VARNC .NE. '' .AND. META%VARNC .NE. UNSETC) THEN + ERR = NF90_PUT_ATT(NCID, VARID, 'comment', META%VARNC) + IF(ERR /= NF90_NOERR) RETURN + ENDIF -!/ ------------------------------------------------------------------- / -!> @brief Reads in metadata for the coordinate reference system (CRS). -!> -!> @details The "grid_mapping_name" must be supplied as an attribute. -!> -!> @param[in] NDMI Unit number of metadata input file -!> @param[in,out] ILINE Current line number in file -!> -!> @author Chris Bunney @date 07-Dec-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE READ_CRS_META(NDMI, ILINE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 07-Dec-2020 | -!/ +-----------------------------------+ -!/ -!/ 07-Dec-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Reads in metadata for the coordinate reference system (CRS) -! scalar variable. The "grid_mapping_name" must be supplied as -! an attribute. -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDMI Char. I Unit number of metadata input file -! ILINE Int. I/O Current line number in file -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - INTEGER, INTENT(IN) :: NDMI - INTEGER, INTENT(INOUT) :: ILINE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER(LEN=128) :: BUF, PREV_NAME - INTEGER :: I, IERR - - PREV_NAME = CRS_NAME - - ! Re-read header line (we only want the second field) - READ(NDMI, '(A)') BUF - READ(BUF, *, IOSTAT=IERR) CRS_NAME, CRS_NAME - IF(IERR /= 0 ) THEN - WRITE(NDSE,1000) - WRITE(NDSE,2000) TRIM(FN_META), ILINE, TRIM(BUF) - CALL EXTCDE(10) - ENDIF - IF(DEBUG) WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[CRS id]', TRIM(CRS_NAME) - - IF(CRS_META%N .NE. 0) THEN - IF(CRS_IS_DEFAULT) THEN - WRITE(NDSE,1001) TRIM(PREV_NAME) - CRS_IS_DEFAULT = .FALSE. - ELSE - WRITE(NDSE,1002) TRIM(PREV_NAME) - ENDIF - WRITE(NDSE,2000) TRIM(FN_META), ILINE, TRIM(BUF) - CALL DEL_META_LIST(CRS_META) - ENDIF + IF(META%VARND .NE. '' .AND. META%VARND .NE. UNSETC) THEN + ERR = NF90_PUT_ATT(NCID, VARID, 'direction_reference', META%VARND) + IF(ERR /= NF90_NOERR) RETURN + END IF - CALL READ_FREEFORM_META_LIST(NDMI, ILINE, CRS_META) + IF(CRS_NAME .NE. '' .AND. CRS_NAME .NE. UNSETC) THEN + ERR = NF90_PUT_ATT(NCID, VARID, 'grid_mapping', CRS_NAME) + IF(ERR /= NF90_NOERR) RETURN + ENDIF - ! Check that "grid_mapping_name" is defined - IF(.NOT. META_LIST_HAS_ATTR(CRS_META, "grid_mapping_name")) THEN - WRITE(NDSE, 1003) - WRITE(NDSE, 2000) TRIM(FN_META), ILINE, "" - CALL EXTCDE(10) - ENDIF + IF(COORDS_ATTR .NE. '' .AND. COORDS_ATTR .NE. UNSETC) THEN + ERR = NF90_PUT_ATT(NCID, VARID, 'coordinates', ADJUSTL(COORDS_ATTR)) + IF(ERR /= NF90_NOERR) RETURN + ENDIF - RETURN + IF (META%EXTRA%N .GT. 0) THEN + CALL WRITE_FREEFORM_META_LIST(NCID, VARID, META%EXTRA, ERR) + IF(ERR /= NF90_NOERR) RETURN + ENDIF + + RETURN + ! + END SUBROUTINE WRITE_META + + !/ ------------------------------------------------------------------- / + !> @brief Writes the user meta-data entries for the global attributes. + !> + !> @details Global meta-data is stored as a meta-data list, so this + !> is essentially a convenience/legacy function that calls the + !> write_freeform_meta_list() subroutine. + !> + !> @param[in] NCID NetCDF file ID + !> @param[out] ERR Error value + !> + !> @author Chris Bunney @date 09-Nov-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE WRITE_GLOBAL_META(NCID, ERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 09-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Writes the user meta-data entries for the global attributes + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NCID Int. I/O NetCDF file ID + ! ERR Int. O Error value + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NCID + INTEGER, INTENT(OUT) :: ERR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CALL WRITE_FREEFORM_META_LIST(NCID, NF90_GLOBAL, GLOBAL_META, ERR) + END SUBROUTINE WRITE_GLOBAL_META + + !/ ------------------------------------------------------------------- / + !> @brief Writes the freeform user meta-data entries for a NetCDF variable + !> + !> @param[in,out] NCID NetCDF file ID + !> @param[in,out] VARID NetCDF variable ID + !> @param[in] METALIST META_LIST_T object to write + !> @param[out] ERR Error value + !> + !> @author Chris Bunney @date 16-Dec-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE WRITE_FREEFORM_META_LIST(NCID, VARID, METALIST, ERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 16-Dec-2020 | + !/ +-----------------------------------+ + !/ + !/ 16-Dec-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Writes the freeform user meta-data entries for a NetCDF variable + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NCID Int. I/O NetCDF file ID + ! VARID Int. I/O NetCDF file ID + ! METALIST Type. I META_LIST_T object to write + ! ERR Int. O Error value + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NCID, VARID + TYPE(META_LIST_T), INTENT(IN) :: METALIST + INTEGER, INTENT(OUT) :: ERR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, IVAL + REAL :: RVAL + TYPE(META_PAIR_T), POINTER :: P + + IF(METALIST%N .EQ. 0) RETURN + + P => METALIST%HEAD + + ! Loop over global metadata pairs: + DO + + IF (P%ATTNAME .EQ. '' .OR. & + P%ATTNAME .EQ. UNSETC) CYCLE + + SELECT CASE(P%TYPE) + + CASE('i') + READ(P%ATTVAL, *) IVAL + ERR = NF90_PUT_ATT(NCID, VARID, P%ATTNAME, IVAL) + IF(ERR /= NF90_NOERR) RETURN - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' ERROR READING CRS HEADER - MISSING CRS NAME?' ) -! - 1001 FORMAT (/' *** WARNING : USER DEFINED CRS SECTION WILL ' / & - ' OVERIDE DEFAULT CRS DEFINITION FOR GRID' / & - ' PREV CRS = ', A ) -! - 1002 FORMAT (/' *** WARNING : DUPLICATE CRS SECTION WILL ' / & - ' OVERRIDE PREVIOUS CRS DEFINITION' / & - ' PREV CRS = ', A ) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' CRS SECTION DOES NOT CONTAIN MANDATORY '/ & - ' ATTRIBUTE "grid_mapping_name"' ) - - 2000 FORMAT ( ' FILENAME = ', A / & - ' LINE NO = ', I5 / & - ' => ', A /) -! - - END SUBROUTINE READ_CRS_META + CASE('r', 'f') + READ(P%ATTVAL, *) RVAL + ERR = NF90_PUT_ATT(NCID, VARID, P%ATTNAME, RVAL) + IF(ERR /= NF90_NOERR) RETURN -!/ ------------------------------------------------------------------- / -!> @brief Set up a default coordinate reference system for the grid -!> -!> @details The default coordinate reference system (CRS) will be defined -!> based on the type of grid the model is formulated on, e.g. -!> regular lat-lon, rotated pole, etc. -!> -!> @remark See "Grid Mappings" section of CF conventions: -!> - https://cfconventions.org/Data/cf-conventions/cf-conventions-1.7/build/ch05s06.html -!> - https://cfconventions.org/Data/cf-conventions/cf-conventions-1.7/build/apf.html -!> -!> @author Chris Bunney @date 25-May-2021 -!/ ------------------------------------------------------------------- / - SUBROUTINE DEFAULT_CRS_META() - IMPLICIT NONE + CASE('c') + ERR = NF90_PUT_ATT(NCID, VARID, P%ATTNAME, & + P%ATTVAL) + IF(ERR /= NF90_NOERR) RETURN - TYPE(META_PAIR_T) :: META + CASE DEFAULT + WRITE(NDSE,1000) P%TYPE + CALL EXTCDE(10) + END SELECT - IF(FLRTD) THEN -#ifdef W3_RTD - ! Rotated pole location - CRS_NAME = 'rotated_pole' - CALL META_LIST_APPEND(CRS_META, & - 'grid_mapping_name', 'rotated_latitude_longitude') - CALL META_LIST_APPEND(CRS_META, & - 'grid_north_pole_latitude', POLAT) - CALL META_LIST_APPEND(CRS_META, & - 'grid_north_pole_longitude', POLON) - CRS_IS_DEFAULT = .TRUE. -#endif - ELSE IF(GTYPE .EQ. UNGTYPE) THEN -! ! What do we want for unstructure grids? - ELSE - ! Lat/lon grid - CRS_NAME = 'crs' - CALL META_LIST_APPEND(CRS_META, & - 'grid_mapping_name', 'latitude_longitude') - ! TODO: Default to a spherical Earth? - CALL META_LIST_APPEND(CRS_META, & - 'semi_major_axis', 6371000.0) - CALL META_LIST_APPEND(CRS_META, & - 'inverse_flattening', 0.0) - ENDIF - - END SUBROUTINE DEFAULT_CRS_META - -!/ ------------------------------------------------------------------- / -!> @brief Get the meta data for a particular field. -!> -!> @details The required field is specified using the group (IFI) and -!> field (IFJ) index. Optionally, the component (ICOMP) and partition -!> (IPART) numbers can be specified for vector/tensor or partitioned -!> parameter fields. If not specified, these default to 1. - -!> A copy of the meta-data is returned, rather than a pointer. -!> This is because in the case of paritioned parameters, the metadata -!> will be updated with the partition number. -!> -!> @param[in] IFI Output group number -!> @param[in] IFJ Output field number -!> @param[in] ICOMP Component number (defaults to 1) -!> @param[in] IPART Partition number (defaults to 1) -!> -!> @author Chris Bunney @date 02-Nov-2020 -!/ ------------------------------------------------------------------- / - FUNCTION GETMETA(IFI, IFJ, ICOMP, IPART) RESULT(META) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 02-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Returns a META_T type containig the netCDF matadata for the -! requested field -! -! 2. Method : -! -! A copy of the meta-data is returned, rather than a pointer. This -! is because in the case of paritioned parameters, the metadata -! will be updated with the partition number. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IFI Int. I Output group number -! IFJ Int. I Output field number -! ICOMP Int. I Component number (defaults to 1) -! IPART Int. I Partition number (defaults to 1) -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - INTEGER, INTENT(IN) :: IFI, IFJ - INTEGER, INTENT(IN), OPTIONAL :: ICOMP, IPART -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IFP, IFC - TYPE(META_T) :: META ! Not pointer as we might need to modify it - - IFC = 1 - IFP = 1 - IF(PRESENT(ICOMP)) IFC = ICOMP - IF(PRESENT(IPART)) IFP = IPART - - ! Error checking on size of IFJ, ICOMP, IPART. - IF(IFI .LT. 1 .OR. IFI .GT. NOGRP) THEN - WRITE(NDSE,1000) NOGRP - CALL EXTCDE(1) - ENDIF - IF(IFJ .LT. 1 .OR. IFJ .GT. NOGE(IFI)) THEN - WRITE(NDSE,1001) NOGE(IFI) - CALL EXTCDE(1) - ENDIF - IF(IFC .LT. 1 .OR. IFC .GT. 3) THEN - WRITE(NDSE,1002) - CALL EXTCDE(1) - ENDIF - - META = META_DEEP_COPY(GROUP(IFI)%FIELD(IFJ)%META(IFC)) - - ! For partitioned data, expand in the partition number: - IF(IFI .EQ. 4) THEN - CALL ADD_PARTNO(META, IFP) - ENDIF - - RETURN - - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & - ' GETMETA: IFI value should be in range 1,',I2 / ) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & - ' GETMETA: IFJ value should be in range 1,',I2 / ) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & - ' GETMETA: IFC value should be in range 1,3' / ) -! - END FUNCTION GETMETA - -!/ ------------------------------------------------------------------- / -!> @brief Reads in a TEMPLATE section from file. -!> -!> @details This section defines a list of text strings that will be -!> used to replace a "placeholder string" when generating metadata -!> for partitioned parameters. -!> -!> Format of section is: -!> -!> \code -!> TEMPLATE -!> Value for partition IPART=0 -!> Value for partition IPART=1 -!> Value for partition IPART=2 -!> ... -!> Value for partition IPART=N -!> \endcode -!> -!> @param[in,out] NDMI Unit number -!> @param[in,out] ILINE Line number -!> -!> @author Chris Bunney @date 04-Dec-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE READ_PART_TMPL(NDMI, ILINE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 04-Dec-2020 | -!/ +-----------------------------------+ -!/ -!/ 04-Dec-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Reads in a TEMPLATE section from file. -! This section defines a list of text strings that will be used -! to replace a "placeholder string" when generating metadata for -! partitioned parameters. -! -! Format of section is: -! -! TEMPLATE -! Value for partition IPART=0 -! Value for partition IPART=1 -! Value for partition IPART=2 -! ... -! Value for partition IPART=N -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDMI Int. I/O Unit number -! ILINE Int. I/O Line number -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - INTEGER, INTENT(IN) :: NDMI - INTEGER, INTENT(INOUT) :: ILINE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER(LEN=256) :: BUF, ID - INTEGER :: IERR - LOGICAL :: EOF, NEW - TYPE(PART_TMPL_T), POINTER :: P - - ! Re-read META line to get template string ID (the 2nd field) - READ(NDMI, '(A)') BUF - READ(BUF, *, IOSTAT=IERR) ID, ID - IF(IERR /= 0) THEN - WRITE(NDSE, 1000) FN_META, ILINE, BUF - CALL EXTCDE(10) - ENDIF - ID = "<" // TRIM(ID) // ">" - - IF(DEBUG) WRITE(*,'(I5,1X,A20,1X,A)') ILINE, '[template id]', TRIM(ID) - - ! Extend list of partition template types: - IF(ASSOCIATED(PART_TMPL)) THEN - ! Got to end of list - P => PART_TMPL - DO WHILE(ASSOCIATED(P%NEXT)) - P => P%NEXT - ENDDO - ALLOCATE(P%NEXT) - P => P%NEXT - ELSE - ALLOCATE(PART_TMPL) - P => PART_TMPL - ENDIF - - ! Set template id and read template strings from file: - P%TMPL = TRIM(ID) - ALLOCATE(P%PART_TEXT(0:NOSWLL)) - NULLIFY(P%NEXT) - P%NP = 0 - - DO - CALL NEXT_LINE(NDMI, BUF, ILINE, EOF, NEW_SECTION=NEW) - IF(EOF) THEN - BACKSPACE(NDMI) - RETURN - ENDIF - - IF(NEW) THEN - ! Start of new meta data entry - IF(DEBUG) WRITE(*,'(I5,1X,A20)') ILINE, '[--end of section--]' - ILINE = ILINE - 1 - BACKSPACE(NDMI) - EXIT - ENDIF - - ! Check we have not exceeded NOSWLL - IF(P%NP .GT. NOSWLL) THEN - WRITE(*,*) "Too many partition entries (NOSWLL=",NOSWLL,"). Ignoring" - CYCLE - ENDIF - - ! Add string to array of partition text - IF(DEBUG) THEN - WRITE(*,'(I5,1X,A20,1X,I1,1X,A)') ILINE, '[part template]', & - P%NP, TRIM(BUF) - ENDIF - - P%PART_TEXT(P%NP) = TRIM(ADJUSTL(BUF)) ! Zero indexed - P%NP = P%NP + 1 - ENDDO - - RETURN -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : '/ & - ' ERROR READING PART HEADER - MISSING TEMPLATE ID?'/ & - ' FILENAME = ', A / & - ' LINE NO =', I5 / & - ' => ', A /) -! - END SUBROUTINE READ_PART_TMPL - - -!/ ------------------------------------------------------------------- / -!> @brief Prints the patition templates to screen (for debug use). -!> @author Chris Bunney @date 04-Dec-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE PRINT_PART_TMPL() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 04-Dec-2020 | -!/ +-----------------------------------+ -!/ -!/ 04-Dec-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Prints the patition templates to screen (for debug use). -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(PART_TMPL_T), POINTER :: P - INTEGER :: I - - PRINT*,'==============' - IF(.NOT. ASSOCIATED(PART_TMPL)) THEN - PRINT*,'Empty partition list' - RETURN - ENDIF - - P => PART_TMPL - DO - PRINT*,P%TMPL - DO I=0,P%NP - 1 - PRINT*,' - ',I,TRIM(P%PART_TEXT(I)) - ENDDO - IF(.NOT. ASSOCIATED(P%NEXT)) EXIT - P => P%NEXT - ENDDO - PRINT*,'==============' - END SUBROUTINE PRINT_PART_TMPL - -!/ ------------------------------------------------------------------- / -!> @brief Adds partition number to meta-data. -!> -!> @details Replaces all instances of "" in the provided meta data -!> with the partition number IPART. -!> -!> @param[in] META Meta data type -!> @param[in] IPART Partition number -!> -!> @author Chris Bunney @date 02-Nov-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE ADD_PARTNO(META, IPART) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 02-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Adds partition number to meta-data. -! -! 2. Method : -! -! Replaces all instances of "" in the provided meta data with -! the partition number IPART. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! META META_T I Meta data type -! IPART Int. I Partition number -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - TYPE(META_T), INTENT(INOUT) :: META - INTEGER, INTENT(IN) :: IPART -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER(LEN=80) :: TMP - INTEGER :: I, J - TYPE(META_PAIR_T), POINTER :: P - - CALL PARTNO_STRING_SUB(META%ENAME, IPART) - CALL PARTNO_STRING_SUB(META%VARNM, IPART) - CALL PARTNO_STRING_SUB(META%VARNL, IPART) - CALL PARTNO_STRING_SUB(META%VARNS, IPART) - CALL PARTNO_STRING_SUB(META%VARNG, IPART) - CALL PARTNO_STRING_SUB(META%VARNC, IPART) - CALL PARTNO_STRING_SUB(META%VARND, IPART) - IF(META%EXTRA%N .GT. 0) THEN - P => META%EXTRA%HEAD - DO - CALL PARTNO_STRING_SUB(P%ATTNAME, IPART) - IF(P%TYPE .EQ. "c") THEN - CALL PARTNO_STRING_SUB(P%ATTVAL, IPART) - ENDIF - IF(.NOT. ASSOCIATED(P%NEXT)) EXIT - P => P%NEXT - ENDDO - ENDIF - - END SUBROUTINE ADD_PARTNO - -!/ ------------------------------------------------------------------- / -!> @brief Performs string substition of placeholder strings with -!> partition number specfic values. -!> -!> @details The placeholder \ is automatically replaced with the -!> partition number (0, 1, 2, etc). -!> -!> Other template placeholders can be defined in the ounfmeta.inp -!> file by the user. -!> -!> @param[in,out] INSTR Input string -!> @param[in] IPART Partition number -!> -!> @author Chris Bunney @date 02-Nov-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE PARTNO_STRING_SUB(INSTR, IPART) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 02-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Performs string substition of placeholder strings with partition -! number specfic values. -! -! The placeholder is automatically replaced with the -! partition number (0, 1, 2, etc). -! -! Other template placeholders can be defined in the ounfmeta.inp -! file by the user. -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INSTR Char. I/O Input string -! IPART Int. I Partition number -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - CHARACTER(LEN=*), INTENT(INOUT) :: INSTR - INTEGER, INTENT(IN) :: IPART -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, J, ISN - TYPE(PART_TMPL_T), POINTER :: P - CHARACTER(LEN=512) :: TMPL - - ISN = IPART + 1 - IF(PTMETH .LE. 3) THEN - IF (ISN .GT. 5) ISN = 5 - ELSE - IF (ISN .GT. 2) ISN = 2 - ENDIF - - ! Set partition number (built-in IPART template) - I = INDEX(INSTR, IPART_TOKEN) - J = I + LEN_TRIM(IPART_TOKEN) - IF(I .GT. 0) THEN - WRITE(TMPL, '(A,I1,A)') INSTR(1:I-1), IPART, INSTR(J:LEN(INSTR)) - INSTR = TMPL - ENDIF - - ! Set standard name string (built-in SPART template) - I = INDEX(INSTR, SPART_TOKEN) - J = I + LEN_TRIM(SPART_TOKEN) - - IF(I .GT. 0) THEN - INSTR = INSTR(1:I-1) // TRIM(SNAMEP(ISN)) // INSTR(J:LEN(INSTR)) - ENDIF - - ! Also try underscore separated version: - I = INDEX(INSTR, SPART_TOKEN_) - J = I + LEN_TRIM(SPART_TOKEN_) - - IF(I .GT. 0) THEN - INSTR = INSTR(1:I-1) // TRIM(REPLACE_CHAR(SNAMEP(ISN), " ", "_")) & - // INSTR(J:LEN(INSTR)) - ENDIF - - ! Merge in user defined partition templates (if any): - IF(.NOT. ASSOCIATED(PART_TMPL)) RETURN - - P => PART_TMPL + IF(.NOT. ASSOCIATED(P%NEXT)) EXIT + P => P%NEXT + ENDDO + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & + ' WRITE_FREEFORM_META: Unknown attribute' / & + ' data type: ', A1 / ) + ! + END SUBROUTINE WRITE_FREEFORM_META_LIST + + !/ ------------------------------------------------------------------- / + !> @brief Writes meta-data to the screen - for debugging purposes. + !> + !> @param[in] META Meta data type + !> + !> @author Chris Bunney @date 09-Nov-2020 + !/ ------------------------------------------------------------------- / + SUBROUTINE PRINT_META(META) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 02-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 09-Nov-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Writes meta-data to the screen - for debugging purposes. + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! VARID Int. I/O NetCDF variable ID + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + TYPE(META_T), INTENT(IN) :: META + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(META_PAIR_T), POINTER :: P + + WRITE(*,*) META%VARNM + WRITE(*,"(A20,':',1X,A)") "Standard name", TRIM(META%VARNS) + WRITE(*,"(A20,':',1X,A)") "Long name", TRIM(META%VARNL) + WRITE(*,"(A20,':',1X,A)") "Units", TRIM(META%UNITS) + WRITE(*,"(A20,':',1X,A)") "GLOBWAVE name", TRIM(META%VARNG) + WRITE(*,"(A20,':',1X,A)") "Direction conv", TRIM(META%VARND) + WRITE(*,"(A20,':',1X,A)") "Comment", TRIM(META%VARNC) + WRITE(*,"(A20,':',1X,2F12.3)") "Min/Max", META%VMIN, META%VMAX + IF(META%EXTRA%N .GT. 0) THEN + P => META%EXTRA%HEAD DO - I = INDEX(INSTR, TRIM(P%TMPL)) - J = I + LEN_TRIM(P%TMPL) - - IF(I .GT. 0) THEN - IF(IPART .GE. P%NP) THEN - WRITE(NDSE, 1000) TRIM(P%TMPL), P%NP, IPART - CALL EXTCDE(10) - ENDIF - INSTR = INSTR(1:I-1) // TRIM(P%PART_TEXT(IPART)) // INSTR(J:LEN(INSTR)) - ENDIF - - ! Try "underscore" version : - I = LEN_TRIM(P%TMPL) - TMPL = P%TMPL(1:I-1) // "_>" - I = INDEX(INSTR, TRIM(TMPL)) - J = I + LEN_TRIM(TMPL) - IF(I .GT. 0) THEN - INSTR = INSTR(1:I-1) // TRIM(REPLACE_CHAR(P%PART_TEXT(IPART), " ", "_")) & - // INSTR(J:LEN(INSTR)) - ENDIF - + WRITE(*,"(A20,':',1X,A)") TRIM(P%ATTNAME), TRIM(P%ATTVAL) IF(.NOT. ASSOCIATED(P%NEXT)) EXIT P => P%NEXT ENDDO - - RETURN - - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & - ' NOT ENOUGH USER DEFINED ENTRIES FOR TEMPLATE' / & - ' TEMPLATE ID : ',A / & - ' NUM ENTRIES : ',I2 / & - ' REQESTED IPART* : ',I2 / & - ' (*Note: IPART is zero-refernced)' / & - ' Please update your ounfmeta.inp file.' /) - - END SUBROUTINE PARTNO_STRING_SUB - -!/ ------------------------------------------------------------------- / -!> @brief Writes the meta-data entries for a variable. -!> -!> @details Attribute pairs defined in META are written to the netCDF -!> variable specificed in the VARID handle. -!> -!> There are two stages to the write - first all "mandatory" or -!> "pre-defined" attributes are written out (those defined in the -!> META_T type). Secondly, if there is any user-defined "extra" -!> freeform meta data defined, this is written out via a separate -!> call to write_freeform_meta_list(). -!> -!> @param[in,out] NCID NetCDF file ID -!> @param[in,out] VARID NetCDF variable ID -!> @param[in] META Meta data type -!> @param[out] ERR Error value -!> -!> @author Chris Bunney @date 02-Nov-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE WRITE_META(NCID, VARID, META, ERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 02-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Writes the meta-data entries for a variable. -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NCID Int. I/O NetCDF file ID -! VARID Int. I/O NetCDF variable ID -! META Int. I Meta data type -! ERR Int. O Error value -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NCID, VARID - TYPE(META_T), INTENT(IN) :: META - INTEGER, INTENT(OUT) :: ERR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IVAL, VAL - REAL :: RVAL -!/ - ERR = NF90_PUT_ATT(NCID, VARID, 'long_name', META%VARNL) - IF(ERR /= NF90_NOERR) RETURN - - IF(META%VARNS .NE. '' .AND. META%VARNS .NE. UNSETC) THEN - ERR = NF90_PUT_ATT(NCID, VARID, 'standard_name', META%VARNS) - IF(ERR /= NF90_NOERR) RETURN - ENDIF - - IF(META%VARNG .NE. '' .AND. META%VARNG .NE. UNSETC) THEN - ERR = NF90_PUT_ATT(NCID, VARID, 'globwave_name', META%VARNG) - IF(ERR /= NF90_NOERR) RETURN - ENDIF - - ERR = NF90_PUT_ATT(NCID, VARID, 'units', META%UNITS) - IF(ERR /= NF90_NOERR) RETURN - - ! Fill value dependent on variable type - IF(NCVARTYPE .EQ. 2) THEN - ERR = NF90_PUT_ATT(NCID, VARID, '_FillValue', NF90_FILL_SHORT) - ELSE - ERR = NF90_PUT_ATT(NCID, VARID, '_FillValue', NF90_FILL_FLOAT) - END IF - IF(ERR /= NF90_NOERR) RETURN - - ERR = NF90_PUT_ATT(NCID, VARID, 'scale_factor', META%FSC) - IF(ERR /= NF90_NOERR) RETURN - - ERR = NF90_PUT_ATT(NCID, VARID, 'add_offset', 0.) - IF(ERR /= NF90_NOERR) RETURN - - ! For variables with vartype SHORT, the valid min/max - ! are scaled by scale_factor and converted to integers. - ! If vartype is FLOAT, then no scaling is performed and - ! valid min/max are written out directly as floats. - IF(NCVARTYPE .EQ. 2) THEN - VAL = NINT(META%VMIN / META%FSC) - ERR = NF90_PUT_ATT(NCID, VARID,'valid_min', VAL) - IF(ERR /= NF90_NOERR) RETURN - - VAL = NINT(META%VMAX / META%FSC) - ERR = NF90_PUT_ATT(NCID, VARID,'valid_max', VAL) - IF(ERR /= NF90_NOERR) RETURN - ELSE - ERR = NF90_PUT_ATT(NCID, VARID,'valid_min', META%VMIN) - IF(ERR /= NF90_NOERR) RETURN - - ERR = NF90_PUT_ATT(NCID, VARID,'valid_max', META%VMAX) - IF(ERR /= NF90_NOERR) RETURN - ENDIF - - IF(META%VARNC .NE. '' .AND. META%VARNC .NE. UNSETC) THEN - ERR = NF90_PUT_ATT(NCID, VARID, 'comment', META%VARNC) - IF(ERR /= NF90_NOERR) RETURN - ENDIF - - IF(META%VARND .NE. '' .AND. META%VARND .NE. UNSETC) THEN - ERR = NF90_PUT_ATT(NCID, VARID, 'direction_reference', META%VARND) - IF(ERR /= NF90_NOERR) RETURN - END IF - - IF(CRS_NAME .NE. '' .AND. CRS_NAME .NE. UNSETC) THEN - ERR = NF90_PUT_ATT(NCID, VARID, 'grid_mapping', CRS_NAME) - IF(ERR /= NF90_NOERR) RETURN - ENDIF - - IF(COORDS_ATTR .NE. '' .AND. COORDS_ATTR .NE. UNSETC) THEN - ERR = NF90_PUT_ATT(NCID, VARID, 'coordinates', ADJUSTL(COORDS_ATTR)) - IF(ERR /= NF90_NOERR) RETURN - ENDIF - - IF (META%EXTRA%N .GT. 0) THEN - CALL WRITE_FREEFORM_META_LIST(NCID, VARID, META%EXTRA, ERR) - IF(ERR /= NF90_NOERR) RETURN - ENDIF - - RETURN -! - END SUBROUTINE WRITE_META - -!/ ------------------------------------------------------------------- / -!> @brief Writes the user meta-data entries for the global attributes. -!> -!> @details Global meta-data is stored as a meta-data list, so this -!> is essentially a convenience/legacy function that calls the -!> write_freeform_meta_list() subroutine. -!> -!> @param[in] NCID NetCDF file ID -!> @param[out] ERR Error value -!> -!> @author Chris Bunney @date 09-Nov-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE WRITE_GLOBAL_META(NCID, ERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 09-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Writes the user meta-data entries for the global attributes -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NCID Int. I/O NetCDF file ID -! ERR Int. O Error value -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NCID - INTEGER, INTENT(OUT) :: ERR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CALL WRITE_FREEFORM_META_LIST(NCID, NF90_GLOBAL, GLOBAL_META, ERR) - END SUBROUTINE WRITE_GLOBAL_META - -!/ ------------------------------------------------------------------- / -!> @brief Writes the freeform user meta-data entries for a NetCDF variable -!> -!> @param[in,out] NCID NetCDF file ID -!> @param[in,out] VARID NetCDF variable ID -!> @param[in] METALIST META_LIST_T object to write -!> @param[out] ERR Error value -!> -!> @author Chris Bunney @date 16-Dec-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE WRITE_FREEFORM_META_LIST(NCID, VARID, METALIST, ERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 16-Dec-2020 | -!/ +-----------------------------------+ -!/ -!/ 16-Dec-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Writes the freeform user meta-data entries for a NetCDF variable -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NCID Int. I/O NetCDF file ID -! VARID Int. I/O NetCDF file ID -! METALIST Type. I META_LIST_T object to write -! ERR Int. O Error value -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NCID, VARID - TYPE(META_LIST_T), INTENT(IN) :: METALIST - INTEGER, INTENT(OUT) :: ERR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, IVAL - REAL :: RVAL - TYPE(META_PAIR_T), POINTER :: P - - IF(METALIST%N .EQ. 0) RETURN - - P => METALIST%HEAD - - ! Loop over global metadata pairs: - DO - - IF (P%ATTNAME .EQ. '' .OR. & - P%ATTNAME .EQ. UNSETC) CYCLE - - SELECT CASE(P%TYPE) - - CASE('i') - READ(P%ATTVAL, *) IVAL - ERR = NF90_PUT_ATT(NCID, VARID, P%ATTNAME, IVAL) - IF(ERR /= NF90_NOERR) RETURN - - CASE('r', 'f') - READ(P%ATTVAL, *) RVAL - ERR = NF90_PUT_ATT(NCID, VARID, P%ATTNAME, RVAL) - IF(ERR /= NF90_NOERR) RETURN - - CASE('c') - ERR = NF90_PUT_ATT(NCID, VARID, P%ATTNAME, & - P%ATTVAL) - IF(ERR /= NF90_NOERR) RETURN - - CASE DEFAULT - WRITE(NDSE,1000) P%TYPE - CALL EXTCDE(10) - END SELECT - - IF(.NOT. ASSOCIATED(P%NEXT)) EXIT - P => P%NEXT - ENDDO -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNFMETA : ' / & - ' WRITE_FREEFORM_META: Unknown attribute' / & - ' data type: ', A1 / ) -! - END SUBROUTINE WRITE_FREEFORM_META_LIST - -!/ ------------------------------------------------------------------- / -!> @brief Writes meta-data to the screen - for debugging purposes. -!> -!> @param[in] META Meta data type -!> -!> @author Chris Bunney @date 09-Nov-2020 -!/ ------------------------------------------------------------------- / - SUBROUTINE PRINT_META(META) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 02-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 09-Nov-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Writes meta-data to the screen - for debugging purposes. -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! VARID Int. I/O NetCDF variable ID -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - TYPE(META_T), INTENT(IN) :: META -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(META_PAIR_T), POINTER :: P - - WRITE(*,*) META%VARNM - WRITE(*,"(A20,':',1X,A)") "Standard name", TRIM(META%VARNS) - WRITE(*,"(A20,':',1X,A)") "Long name", TRIM(META%VARNL) - WRITE(*,"(A20,':',1X,A)") "Units", TRIM(META%UNITS) - WRITE(*,"(A20,':',1X,A)") "GLOBWAVE name", TRIM(META%VARNG) - WRITE(*,"(A20,':',1X,A)") "Direction conv", TRIM(META%VARND) - WRITE(*,"(A20,':',1X,A)") "Comment", TRIM(META%VARNC) - WRITE(*,"(A20,':',1X,2F12.3)") "Min/Max", META%VMIN, META%VMAX - IF(META%EXTRA%N .GT. 0) THEN - P => META%EXTRA%HEAD - DO - WRITE(*,"(A20,':',1X,A)") TRIM(P%ATTNAME), TRIM(P%ATTVAL) - IF(.NOT. ASSOCIATED(P%NEXT)) EXIT - P => P%NEXT - ENDDO - ENDIF - - END SUBROUTINE PRINT_META - -!/ ------------------------------------------------------------------- / -!> @brief Performs "deep" copy of a META_T type. -!> -!> @details A "deep" copy ensures that the linked list data in the EXTRA -!> field is copied, rather than just copying the pointer. -!> -!> Calls copy_meta_list() internally to copy the EXTRA linked list. -!> -!> @returns A new META_T variable -!> -!> @param[in] META META data structure to copy -!> -!> @author Chris Bunney @date 16-Dec-2020 -!/ ------------------------------------------------------------------- / - FUNCTION META_DEEP_COPY(META) RESULT(COPY) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 16-Dec-2020 | -!/ +-----------------------------------+ -!/ -!/ 16-Dec-2020 : Creation ( version 7.12 ) -!/ -! -! 1. Purpose : -! -! Performs "Deep" copy of a META_T type. This ensures that the -! linked list data in the EXTRA field is copied, rather than just -! copying the pointer. -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! META META_T. I META data structure to copy -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - TYPE(META_T), INTENT(IN) :: META - TYPE(META_T) :: COPY - - ! Shallow copy first: - COPY = META - - ! Now deep copy the EXTRA field (is pointer) - COPY%EXTRA = COPY_META_LIST(META%EXTRA) - - END FUNCTION META_DEEP_COPY - -!/ ------------------------------------------------------------------- / -!> @brief Populates the default meta data for ww3_ounf output fields. -!> -!> @remark VMIN and VMAX are now set in the units of the output field. -!> Previously, they were set with scaled values based on the scaling -!> factor FSC. The scaling is now performed (if necessary) in the -!> WRITE_META subroutine. -!> -!> @remark FSC (scale factor) is only applied to data and valid_min/max -!> if the netCDF variable type is NF90_SHORT. -!> -!> @author Chris Bunney @date 22-Mar-2021 -!/ ------------------------------------------------------------------- / - SUBROUTINE DEFAULT_META() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 02-Nov-2020 : Creation ( version 7.12 ) -!/ 22-Mar-2021 : Adds extra coupling fields ( version 7.13 ) -!/ -! -! 1. Purpose : -! -! Populates the default meta data for ww3_ounf. -! -! 2. Remarks : -! -! VMIN and VMAX are now set in the units of the output field. -! Previously, they were set with scaled values based on the scaling -! factor FSC. The scaling is now performed (if necessary) in the -! WRITE_META subroutine. -! -! FSC (scale factor) is only applied to data and valid_min/max if -! the netCDF variable type is NF90_SHORT. -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - TYPE(META_T), POINTER :: META(:) -! -!----------GROUP 1 ---------------- -! -! IFI=1, IFJ=1, DPT - META => GROUP(1)%FIELD(1)%META - META(1)%FSC = 0.5 - META(1)%UNITS = 'm' - META(1)%ENAME = '.dpt' - META(1)%VARNM = 'dpt' - META(1)%VARNL ='depth' - META(1)%VARNS ='depth' - META(1)%VARNG ='depth' - META(1)%VARNC ='' - META(1)%VARND ='' - META(1)%VMIN = -45000 - META(1)%VMAX = 70000 -! IFI=1, IFJ=2, CUR - META => GROUP(1)%FIELD(2)%META - META(1)%ENAME = '.cur' - META(1)%VARND = DIRCOM - IF(VECTOR) THEN - META(1)%FSC = 0.01 - META(1)%UNITS = 'm s-1' - META(1)%VMIN = -9.9 - META(1)%VMAX = 9.9 - META(1)%VARNM='ucur' - META(1)%VARNL='eastward current' - META(1)%VARNS='eastward_sea_water_velocity' - META(1)%VARNG='eastward_sea_water_velocity' - META(1)%VARNC='cur=sqrt(U**2+V**2)' - - ! Second component - META(2) = META(1) - META(2)%VARNM='vcur' - META(2)%VARNL='northward current' - META(2)%VARNS='northward_sea_water_velocity' - META(2)%VARNG='northward_sea_water_velocity' - META(2)%VARNC='cur=sqrt(U**2+V**2)' - ELSE - META(1)%FSC = 0.01 - META(1)%UNITS = 'm s-1' - META(1)%VMIN = 0 - META(1)%VMAX = 10.0 - META(1)%VARNM='cspd' - META(1)%VARNL='current speed' - META(1)%VARNS='sea_water_speed' - META(1)%VARNG='sea_water_speed' - - ! Second component - META(2) = META(1) - META(2)%FSC = 0.1 - META(2)%VARNM='cdir' - META(2)%UNITS= 'degrees' - META(2)%VARNL='current direction (toward)' - META(2)%VARNS='direction_of_sea_water_velocity' - META(2)%VARNG='direction_of_sea_water_velocity' - META(2)%VMIN = 0 - META(2)%VMAX = 360.0 - ENDIF ! VECTOR -! IFI=1, IFJ=3 - META => GROUP(1)%FIELD(3)%META - META(1)%ENAME = '.wnd' - META(1)%VARND = DIRCOM - IF(VECTOR) THEN - META(1)%FSC = 0.1 - META(1)%UNITS = 'm s-1' - META(1)%VARNM='uwnd' - META(1)%VARNL='eastward_wind' - META(1)%VARNS='eastward_wind' - META(1)%VARNG='eastward_wind' - META(1)%VARNC='wind=sqrt(U10**2+V10**2)' - META(1)%VMIN = -99.0 - META(1)%VMAX = 99.0 - - ! Second component - META(2) = META(1) - META(2)%VARNM='vwnd' - META(2)%VARNL='northward_wind' - META(2)%VARNS='northward_wind' - META(2)%VARNG='northward_wind' - META(2)%VARNC='wind=sqrt(U10**2+V10**2)' - ELSE - META(1)%FSC = 0.01 - META(1)%UNITS= 'm s-1' - META(1)%VARNM='wspd' - META(1)%VARNL='wind speed' - META(1)%VARNS='wind_speed' - META(1)%VARNG='wind_speed' - META(1)%VMIN = 0.0 - META(1)%VMAX = 100.0 - - ! Second component - META(2) = META(1) - META(2)%FSC = 0.1 - META(2)%VARNM='wdir' - META(2)%UNITS='degrees' - META(2)%VARNL='wind direction (from)' - META(2)%VARNS='wind_from_direction' - META(2)%VARNG='wind_from_direction' - META(2)%VMIN = 0.0 - META(2)%VMAX = 360.0 - ENDIF ! VECTOR -! IFI=1, IFJ=4, AST - META => GROUP(1)%FIELD(4)%META - META(1)%FSC = 0.1 - META(1)%ENAME = '.ast' - META(1)%UNITS = 'K' - META(1)%VARNM='ast' - META(1)%VARNL='air sea temperature difference' - !META(1)%VARNS='air_sea_temperature_difference' - META(1)%VARNS='' - META(1)%VARNG='air_sea_temperature_difference' - META(1)%VMIN = 0 - META(1)%VMAX = 400 -! IFI=1, IFJ=5, WLV - META => GROUP(1)%FIELD(5)%META - META(1)%FSC = 0.01 - META(1)%UNITS = 'm' - META(1)%ENAME = '.wlv' - META(1)%VARNM='wlv' - META(1)%VARNL='sea surface height above sea level' - META(1)%VARNS='sea_surface_height_above_mean_sea_level' - META(1)%VARNG='sea_surface_height_above_sea_level' - META(1)%VMIN = 0 - META(1)%VMAX = 100 -! IFI=1, IFJ=6, ICE - META => GROUP(1)%FIELD(6)%META - META(1)%FSC = 0.001 - META(1)%UNITS = '1' - META(1)%ENAME = '.ice' - META(1)%VARNM='ice' - META(1)%VARNL='sea ice area fraction' - META(1)%VARNS='sea_ice_area_fraction' - META(1)%VARNG='sea_ice_area_fraction' - META(1)%VMIN = 0 - META(1)%VMAX = 1 -! IFI=1, IFJ=7, IBG - META => GROUP(1)%FIELD(7)%META - META(1)%FSC = 0.0001 - META(1)%UNITS = 'km-1' - META(1)%ENAME = '.ibg' - META(1)%VARNM='ibg' - META(1)%VARNL='icebergs_damping' - !META(1)%VARNS='icebergs_induced_attenuation_scale_for_waves' - META(1)%VARNS='' - META(1)%VARNG='icebergs_damping' - META(1)%VMIN = 0 - META(1)%VMAX = 3.2 -! IFI=1, IFJ=8, TAUA - META => GROUP(1)%FIELD(8)%META + ENDIF + + END SUBROUTINE PRINT_META + + !/ ------------------------------------------------------------------- / + !> @brief Performs "deep" copy of a META_T type. + !> + !> @details A "deep" copy ensures that the linked list data in the EXTRA + !> field is copied, rather than just copying the pointer. + !> + !> Calls copy_meta_list() internally to copy the EXTRA linked list. + !> + !> @returns A new META_T variable + !> + !> @param[in] META META data structure to copy + !> + !> @author Chris Bunney @date 16-Dec-2020 + !/ ------------------------------------------------------------------- / + FUNCTION META_DEEP_COPY(META) RESULT(COPY) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 16-Dec-2020 | + !/ +-----------------------------------+ + !/ + !/ 16-Dec-2020 : Creation ( version 7.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Performs "Deep" copy of a META_T type. This ensures that the + ! linked list data in the EXTRA field is copied, rather than just + ! copying the pointer. + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! META META_T. I META data structure to copy + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + TYPE(META_T), INTENT(IN) :: META + TYPE(META_T) :: COPY + + ! Shallow copy first: + COPY = META + + ! Now deep copy the EXTRA field (is pointer) + COPY%EXTRA = COPY_META_LIST(META%EXTRA) + + END FUNCTION META_DEEP_COPY + + !/ ------------------------------------------------------------------- / + !> @brief Populates the default meta data for ww3_ounf output fields. + !> + !> @remark VMIN and VMAX are now set in the units of the output field. + !> Previously, they were set with scaled values based on the scaling + !> factor FSC. The scaling is now performed (if necessary) in the + !> WRITE_META subroutine. + !> + !> @remark FSC (scale factor) is only applied to data and valid_min/max + !> if the netCDF variable type is NF90_SHORT. + !> + !> @author Chris Bunney @date 22-Mar-2021 + !/ ------------------------------------------------------------------- / + SUBROUTINE DEFAULT_META() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 02-Nov-2020 : Creation ( version 7.12 ) + !/ 22-Mar-2021 : Adds extra coupling fields ( version 7.13 ) + !/ + ! + ! 1. Purpose : + ! + ! Populates the default meta data for ww3_ounf. + ! + ! 2. Remarks : + ! + ! VMIN and VMAX are now set in the units of the output field. + ! Previously, they were set with scaled values based on the scaling + ! factor FSC. The scaling is now performed (if necessary) in the + ! WRITE_META subroutine. + ! + ! FSC (scale factor) is only applied to data and valid_min/max if + ! the netCDF variable type is NF90_SHORT. + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + TYPE(META_T), POINTER :: META(:) + ! + !----------GROUP 1 ---------------- + ! + ! IFI=1, IFJ=1, DPT + META => GROUP(1)%FIELD(1)%META + META(1)%FSC = 0.5 + META(1)%UNITS = 'm' + META(1)%ENAME = '.dpt' + META(1)%VARNM = 'dpt' + META(1)%VARNL ='depth' + META(1)%VARNS ='depth' + META(1)%VARNG ='depth' + META(1)%VARNC ='' + META(1)%VARND ='' + META(1)%VMIN = -45000 + META(1)%VMAX = 70000 + ! IFI=1, IFJ=2, CUR + META => GROUP(1)%FIELD(2)%META + META(1)%ENAME = '.cur' + META(1)%VARND = DIRCOM + IF(VECTOR) THEN META(1)%FSC = 0.01 - META(1)%UNITS = 'Pa' - META(1)%ENAME = '.taua' - META(1)%VARNM='utaua' - META(1)%VARNL='surface_downward_eastward_stress' - META(1)%VARNS='surface_downward_eastward_stress' - META(1)%VARNG='surface_downward_eastward_stress' - META(2)%VARNC='taua=sqrt(utaua**2+vtaua**2)' - META(1)%VMIN = -320 - META(1)%VMAX = 320 - META(1)%VARND = DIRCOM + META(1)%UNITS = 'm s-1' + META(1)%VMIN = -9.9 + META(1)%VMAX = 9.9 + META(1)%VARNM='ucur' + META(1)%VARNL='eastward current' + META(1)%VARNS='eastward_sea_water_velocity' + META(1)%VARNG='eastward_sea_water_velocity' + META(1)%VARNC='cur=sqrt(U**2+V**2)' ! Second component META(2) = META(1) - META(2)%VARNM='vtaua' - META(2)%VARNL='surface_downward_northward_stress' - META(2)%VARNS='surface_downward_northward_stress' - META(2)%VARNG='surface_downward_northward_stress' - META(2)%VARNC='taua=sqrt(utaua**2+vtaua**2)' -! IFI=1, IFJ=9, RHO - META => GROUP(1)%FIELD(9)%META - META(1)%FSC = 0.0001 - META(1)%UNITS = 'kg m-3' - META(1)%ENAME = '.rhoa' - META(1)%VARNM='rhoa' - META(1)%VARNL='air_density' - META(1)%VARNS='air_density' - META(1)%VARNG='air_density' - META(1)%VMIN = 0 - META(1)%VMAX = 2 -! IFI=1, IFJ=10, D50 -#ifdef W3_BT4 - META => GROUP(1)%FIELD(10)%META - META(1)%FSC = 0.001 - META(1)%UNITS = 'Krumbein phi scale' - META(1)%ENAME = '.d50' - META(1)%VARNM='d50' - META(1)%VARNL='grain_size' - !META(1)%VARNS='sediment_grain_size' - META(1)%VARNS='' - META(1)%VARNG='sediment_grain_size' - META(1)%VMIN = -10.0 - META(1)%VMAX = 32.0 -#endif -! IFI=1, IFJ=11, IC1 -#ifdef W3_IS2 - META => GROUP(1)%FIELD(11)%META - META(1)%FSC = 0.001 - META(1)%UNITS = 'm' - META(1)%ENAME = '.ic1' - META(1)%VARNM='ic1' - META(1)%VARNL='ice thickness' - META(1)%VARNS='sea_ice_thickness' - META(1)%VARNG='ice_thickness' - META(1)%VMIN = 0 - META(1)%VMAX = 30 -#endif -! IFI=1, IFJ=12, IC5 -#ifdef W3_IS2 - META => GROUP(1)%FIELD(12)%META - META(1)%FSC = 0.05 - META(1)%UNITS = 'm' - META(1)%ENAME = '.ic5' - META(1)%VARNM='ic5' - META(1)%VARNL='maximum floe diameter' - !META(1)%VARNS='maximum_ice_floe_diameter' - META(1)%VARNS='' - META(1)%VARNG='maximum_ice_floe_diameter' - META(1)%VMIN = 0 - META(1)%VMAX = 1500 -#endif -! -!----------GROUP 2 ---------------- -! -! IFI=2, IFJ=1, HS - META => GROUP(2)%FIELD(1)%META - META(1)%FSC = 0.002 - META(1)%UNITS = 'm' - META(1)%ENAME = '.hs' - META(1)%VARNM='hs' - META(1)%VARNL='significant height of wind and swell waves' - META(1)%VARNS='sea_surface_wave_significant_height' - META(1)%VARNG='significant_wave_height' - META(1)%VMIN = 0 - META(1)%VMAX = 64 -! IFI=2, IFJ=2, LM - META => GROUP(2)%FIELD(2)%META - META(1)%FSC = 1. - META(1)%UNITS = 'm' - META(1)%ENAME = '.lm' - META(1)%VARNM='lm' - META(1)%VARNL='mean wave length' - !META(1)%VARNS='mean_wave_length' - META(1)%VARNS='' - META(1)%VARNG='mean_wave_length' - META(1)%VMIN = 0 - META(1)%VMAX = 3200 -! IFI=2, IFJ=3, T02 - META => GROUP(2)%FIELD(3)%META + META(2)%VARNM='vcur' + META(2)%VARNL='northward current' + META(2)%VARNS='northward_sea_water_velocity' + META(2)%VARNG='northward_sea_water_velocity' + META(2)%VARNC='cur=sqrt(U**2+V**2)' + ELSE META(1)%FSC = 0.01 - META(1)%UNITS = 's' - META(1)%ENAME = '.t02' - META(1)%VARNM='t02' - META(1)%VARNL='mean period T02' - META(1)%VARNS='sea_surface_wind_wave_mean_period' // & - '_from_variance_spectral_density_second_frequency_moment' - META(1)%VARNG='mean_period_t02' - META(1)%VMIN = 0 - META(1)%VMAX = 50 -! IFI=2, IFJ=4, T0M1 - META => GROUP(2)%FIELD(4)%META - META(1)%FSC = 0.01 - META(1)%UNITS = 's' - META(1)%ENAME = '.t0m1' - META(1)%VARNM='t0m1' - META(1)%VARNL='mean period T0m1' - META(1)%VARNS='sea_surface_wind_wave_mean_period_from_variance' // & - '_spectral_density_inverse_frequency_moment' - META(1)%VARNG='mean_period_t0m1' - META(1)%VMIN = 0 - META(1)%VMAX = 50 -! IFI=2, IFJ=5, T01 - META => GROUP(2)%FIELD(5)%META - META(1)%FSC = 0.01 - META(1)%UNITS = 's' - META(1)%ENAME = '.t01' - META(1)%VARNM='t01' - META(1)%VARNL='mean period T01' - META(1)%VARNS='sea_surface_wind_wave_mean_period_from_variance' // & - '_spectral_density_first_frequency_moment' - META(1)%VARNG='mean_period_t01' - META(1)%VMIN = 0 - META(1)%VMAX = 50 -! IFI=2, IFJ=6, FP - META => GROUP(2)%FIELD(6)%META - META(1)%FSC = 0.001 - META(1)%UNITS = 's-1' - META(1)%ENAME = '.fp' - META(1)%VARNM='fp' - META(1)%VARNL='wave peak frequency' - !META(1)%VARNS='sea_surface_wave_peak_frequency' - META(1)%VARNS='' - META(1)%VARNG='dominant_wave_frequency' - META(1)%VMIN = 0 - META(1)%VMAX = 10 -! IFI=2, IFJ=7, DIR - META => GROUP(2)%FIELD(7)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'degree' - META(1)%ENAME = '.dir' - META(1)%VARNM='dir' - META(1)%VARNL='wave mean direction' - META(1)%VARNS='sea_surface_wave_from_direction' - META(1)%VARNG='wave_from_direction' - META(1)%VARND=DIRCOM - META(1)%VMIN = 0 - META(1)%VMAX = 360 -! IFI=2, IFJ=8, SPR - META => GROUP(2)%FIELD(8)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'degree' - META(1)%ENAME = '.spr' - META(1)%VARNM='spr' - META(1)%VARNL='directional spread' - META(1)%VARNS='sea_surface_wave_directional_spread' - META(1)%VARNG='directional_spread' - META(1)%VMIN = 0 - META(1)%VMAX = 90 -! IFI=2, IFJ=9, DP - META => GROUP(2)%FIELD(9)%META - META(1)%FSC = 1. - META(1)%UNITS = 'degree' - META(1)%ENAME = '.dp' - META(1)%VARNM='dp' - META(1)%VARNL='peak direction' - META(1)%VARNS='sea_surface_wave_peak_direction' - META(1)%VARNG='dominant_wave_direction' - META(1)%VARND=DIRCOM - META(1)%VMIN = 0 - META(1)%VMAX = 360 -! IFI=2, IFJ=10, HIG - META => GROUP(2)%FIELD(10)%META - META(1)%FSC = 0.0002 - META(1)%UNITS = 'm' - META(1)%ENAME = '.hig' - META(1)%VARNM='hig' - META(1)%VARNL='infragravity_wave_height' - !META(1)%VARNS='sea_surface_wave_infragravity_significant_height' - META(1)%VARNS='' - META(1)%VARNG='infragravity_significant_wave_height' - META(1)%VMIN = 0 - META(1)%VMAX = 1.0 -! IFI=2, IFJ=11, MXE - META => GROUP(2)%FIELD(11)%META - META(1)%FSC = 0.002 - META(1)%UNITS = 'm' - META(1)%ENAME = '.mxe' - META(1)%VARNM='stmaxe' - META(1)%VARNL='expected maximum sea surface elevation (nonlinear,2nd order)' - !META(1)%VARNS='expected maximum sea surface elevation (nonlinear,2nd order)' - META(1)%VARNS='' - META(1)%VARNG='expected maximum sea surface elevation (nonlinear,2nd order)' - META(1)%VMIN = 0 - META(1)%VMAX = 64 -! IFI=2, IFJ=12, MXES - META => GROUP(2)%FIELD(12)%META - META(1)%FSC = 0.002 - META(1)%UNITS = 'm' - META(1)%ENAME = '.mxes' - META(1)%VARNM='stmaxd' - META(1)%VARNL='standard deviation of maximum sea surface elevation (nonlinear,2nd order)' - !META(1)%VARNS='std of expected maximum sea surface elevation (nonlinear,2nd order)' - META(1)%VARNS='' - META(1)%VARNG='standard deviation of maximum sea surface elevation (nonlinear,2nd order)' - META(1)%VMIN = 0 - META(1)%VMAX = 64 -! IFI=2, IFJ=13, MXH - META => GROUP(2)%FIELD(13)%META - META(1)%FSC = 0.002 - META(1)%UNITS = 'm' - META(1)%ENAME = '.mxh' - META(1)%VARNM='hmaxe' - META(1)%VARNL='expected maximum wave height (linear, 1st order)' - !META(1)%VARNS='expected maximum wave height (linear, 1st order)' - META(1)%VARNS='' - META(1)%VARNG='expected maximum wave height (linear, 1st order)' - META(1)%VMIN = 0 - META(1)%VMAX = 64 -! IFI=2, IFJ=14, MXHC - META => GROUP(2)%FIELD(14)%META - META(1)%FSC = 0.002 - META(1)%UNITS = 'm' - META(1)%ENAME = '.mxhc' - META(1)%VARNM='hcmaxe' - META(1)%VARNL='expected maximum wave height from crest (linear, 1st order)' - !META(1)%VARNS='expected maximum wave height from crest (linear, 1st order)' - META(1)%VARNS='' - META(1)%VARNG='expected maximum wave height from crest (linear, 1st order)' - META(1)%VMIN = 0 - META(1)%VMAX = 64 -! IFI=2, IFJ=15, SDMH - META => GROUP(2)%FIELD(15)%META - META(1)%FSC = 0.002 - META(1)%UNITS = 'm' - META(1)%ENAME = '.sdmh' - META(1)%VARNM='hmaxd' - META(1)%VARNL='STD of maximum wave height (linear, 1st order)' - !META(1)%VARNS='STD of maximum wave height (linear, 1st order)' - META(1)%VARNS='' - META(1)%VARNG='STD of maximum wave height (linear, 1st order)' - META(1)%VMIN = 0 - META(1)%VMAX = 64 -! IFI=2, IFJ=16, SDMHC - META => GROUP(2)%FIELD(16)%META - META(1)%FSC = 0.002 - META(1)%UNITS = 'm' - META(1)%ENAME = '.sdmhc' - META(1)%VARNM='hcmaxd' - META(1)%VARNL='STD of maximum wave height from crest (linear, 1st order)' - !META(1)%VARNS='STD of maximum wave height from crest (linear, 1st order)' - META(1)%VARNS='' - META(1)%VARNG='STD of maximum wave height from crest (linear, 1st order)' - META(1)%VMIN = 0 - META(1)%VMAX = 64 -! IFI=2, IFJ=17, WBT - META => GROUP(2)%FIELD(17)%META - META(1)%FSC = 0.001 - META(1)%UNITS = '1' - META(1)%ENAME = '.wbt' - META(1)%VARNM='wbt' - META(1)%VARNL='dominant wave breaking probability' - !META(1)%VARNS='dominant_wave_breaking_probability' - META(1)%VARNS='' - META(1)%VARNG='dominant_wave_breaking_probability' - META(1)%VMIN = 0 - META(1)%VMAX = 1 -! IFI=2, IFJ=18, TP - META => GROUP(2)%FIELD(18)%META - META(1)%FSC = 0.01 - META(1)%UNITS = 's' - META(1)%ENAME = '.tp' - META(1)%VARNM='tp' - META(1)%VARNL='wave peak period' - META(1)%VARNS='sea_surface_wave_peak_period' - META(1)%VARNG='dominant_wave_period' - META(1)%VMIN = 0 - META(1)%VMAX = 50 -! IFI=2, IFJ=19 - META => GROUP(2)%FIELD(19)%META - META(1)%FSC = 0.001 - META(1)%UNITS = 'm-1' - META(1)%ENAME = '.wnm' - META(1)%VARNM='wnm' - META(1)%VARNL='mean wave number' - META(1)%VARNS='' - META(1)%VARNG='' - META(1)%VMIN = 0 - META(1)%VMAX = 32 -! -!---------- GROUP 3 ---------------- -! -! IFI=3, IFJ=1, EF - META => GROUP(3)%FIELD(1)%META - META(1)%VARNM='ef' - META(1)%VARNL='wave_elevation_spectrum' - META(1)%VARNS='sea_surface_wave_variance_spectral_density' - IF (NCVARTYPE.LE.3) THEN - META(1)%UNITS = 'log10(m2 s+1E-12)' - !META(1)%VARNS='base_ten_logarithm_of_power_spectral_density_of_surface_elevation' - META(1)%VARNC='base_ten_logarithm' - META(1)%FSC = 0.0004 - META(1)%VMIN = -12. - META(1)%VMAX = 12. - ELSE - META(1)%UNITS = 'm2 s' - META(1)%FSC = 1. - META(1)%VMIN = 0. - META(1)%VMAX = 1.e12 - END IF - META(1)%ENAME = '.ef' - META(1)%VARNG = META(1)%VARNS -! IFI=3, IFJ=2, TH1M - META => GROUP(3)%FIELD(2)%META - ! Information for spectral - META(1)%FSC = 0.1 - META(1)%VARNM='th1m' - META(1)%VARNL='mean wave direction frequency spectrum' - !META(1)%VARNS='sea_surface_wave_from_direction_frequency_spectrum' - META(1)%VARNS='' - META(1)%VARNG = META(1)%VARNS - META(1)%VARND=DIRCOM - META(1)%UNITS = 'degree' - META(1)%ENAME = '.th1m' - META(1)%VMIN = 0 - META(1)%VMAX = 360 -! IFI=3, IFJ=3, STH1M - META => GROUP(3)%FIELD(3)%META - ! Information for spectral - META(1)%FSC = 0.01 - META(1)%VARNM='sth1m' - META(1)%VARNL='spreading frequency spectrum' - !META(1)%VARNS='sea_surface_wave_spreading_spectrum' - META(1)%VARNS='' - META(1)%VARNG = META(1)%VARNS - META(1)%UNITS = 'degree' - META(1)%ENAME = '.sth1m' - META(1)%VMIN = 0 - META(1)%VMAX = 90 -! IFI=3, IFJ=4, TH2M - META => GROUP(3)%FIELD(4)%META - META(1)%FSC = 0.1 - META(1)%VARNM='th2m' - META(1)%VARNL='second mean wave direction frequency spectrum' - !META(1)%VARNS='sea_surface_wave_from_direction_frequency_spectrum_from_second_moments' - META(1)%VARNS='' - META(1)%VARNG = META(1)%VARNS - META(1)%VARND=DIRCOM - META(1)%UNITS = 'degree' - META(1)%ENAME = '.th2m' - META(1)%VMIN = 0 - META(1)%VMAX = 360 -! IFI=3, IFJ=5, STH2M - META => GROUP(3)%FIELD(5)%META - META(1)%FSC = 0.01 - META(1)%VARNM='sth2m' - META(1)%VARNL='second spreading frequency spectrum' - !META(1)%VARNS='sea_surface_wave_spreading_spectrum_from_second_moments' - META(1)%VARNS='' - META(1)%VARNG = META(1)%VARNS - META(1)%UNITS = 'degree' - META(1)%ENAME = '.sth2m' - META(1)%VMIN = 0 - META(1)%VMAX = 90 -! IFI=3, IFJ=6, WN - META => GROUP(3)%FIELD(6)%META - ! Information for spectral - META(1)%FSC = 0.001 - META(1)%UNITS = 'm-1' - META(1)%ENAME = '.wn' - META(1)%VARNM='wn' - META(1)%VARNL='wave numbers' - !META(1)%VARNS='wave_numbers' - META(1)%VARNS='' - META(1)%VARNG='wave_numbers' - META(1)%VMIN = 0 - META(1)%VMAX = 32 -! -!---------- GROUP 4 ---------------- -! -! IFI=4, IFJ=1, PHS - META => GROUP(4)%FIELD(1)%META - META(1)%FSC = 0.002 - META(1)%UNITS = 'm' - META(1)%ENAME = '.phs'// IPART_TOKEN - META(1)%VARNM = 'phs'// IPART_TOKEN - META(1)%VARNL = 'wave significant height partition '// IPART_TOKEN - META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_significant_height' - META(1)%VARNG = 'significant_wave_height_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 64 -! IFI=4, IFJ=2, PTP - META => GROUP(4)%FIELD(2)%META - META(1)%FSC = 0.01 - META(1)%UNITS = 's' - META(1)%ENAME = '.ptp'// IPART_TOKEN - META(1)%VARNM = 'ptp'// IPART_TOKEN - META(1)%VARNL = 'peak period partition '// IPART_TOKEN - META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_period_at_variance' // & - '_spectral_density_maximum' - META(1)%VARNG = 'dominant_wave_period_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 100 -! IFI=4, IFJ=3, PLP - META => GROUP(4)%FIELD(3)%META - META(1)%FSC = 1. - META(1)%UNITS = 'm' - META(1)%ENAME = '.plp'// IPART_TOKEN - META(1)%VARNM = 'plp'// IPART_TOKEN - META(1)%VARNL = 'peak wave length partition '// IPART_TOKEN - !META(1)%VARNS = 'peak_wave_length_partition_'// SPART_TOKEN_ - META(1)%VARNS = '' - META(1)%VARNG = 'peak_wave_length_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 10000 -! IFI=4, IFJ=4, PDIR - META => GROUP(4)%FIELD(4)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'degree' - META(1)%ENAME = '.pdir'// IPART_TOKEN - META(1)%VARNM = 'pdir'// IPART_TOKEN - META(1)%VARNL = 'wave mean direction partition '// IPART_TOKEN - META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_from_direction' - META(1)%VARNG = 'wave_from_direction_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VARND = DIRCOM - META(1)%VMIN = 0 - META(1)%VMAX = 360 -! IFI=4, IFJ=5, PSPR - META => GROUP(4)%FIELD(5)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'degree' - META(1)%ENAME = '.pspr'// IPART_TOKEN - META(1)%VARNM = 'pspr'// IPART_TOKEN - META(1)%VARNL = 'directional spread partition '// IPART_TOKEN - META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_diectional_spread' - META(1)%VARNG = 'directional_spread_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 90 -! IFI=4, IFJ=6, PWS - META => GROUP(4)%FIELD(6)%META - META(1)%FSC = 0.001 - META(1)%UNITS = '1' - META(1)%ENAME = '.pws'// IPART_TOKEN - META(1)%VARNM = 'pws'// IPART_TOKEN - META(1)%VARNL = 'wind sea fraction in partition '// IPART_TOKEN - !META(1)%VARNS = 'wind_sea_fraction_in_partition_'// IPART_TOKEN - META(1)%VARNS = '' - META(1)%VARNG = 'wind_sea_fraction_in_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 1 -! IFI=4, IFJ=7, PDP - META => GROUP(4)%FIELD(7)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'degree' - META(1)%ENAME = '.pdp'// IPART_TOKEN - META(1)%VARNM = 'pdp'// IPART_TOKEN - META(1)%VARNL = 'peak direction partition '// IPART_TOKEN - META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_from_direction_at_variance' // & - '_spectral_density_maximum' - META(1)%VARNG = 'dominant_wave_from_direction_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VARND = DIRCOM - META(1)%VMIN = 0 - META(1)%VMAX = 360 -! IFI=4, IFJ=8, PQP - META => GROUP(4)%FIELD(8)%META - META(1)%FSC = 0.01 - META(1)%UNITS = '1' - META(1)%ENAME = '.pqp'// IPART_TOKEN - META(1)%VARNM = 'pqp'// IPART_TOKEN - META(1)%VARNL = 'peakedness partition '// IPART_TOKEN - !META(1)%VARNS = 'sea_surface_wave_peakedness_partition_'// IPART_TOKEN - META(1)%VARNS = '' - META(1)%VARNG = 'wave_peakedness_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 320 -! IFI=4, IFJ=9, PPE - META => GROUP(4)%FIELD(9)%META - META(1)%FSC = 0.01 - META(1)%UNITS = '1' - META(1)%ENAME = '.ppe'// IPART_TOKEN - META(1)%VARNM = 'ppe'// IPART_TOKEN - META(1)%VARNL = 'peak enhancement factor partition '// IPART_TOKEN - !META(1)%VARNS = 'wave_peak_enhancement_factor_partition_'// IPART_TOKEN - META(1)%VARNS = '' - META(1)%VARNG = 'wave_peak_enhancement_factor_partition_'// IPART_TOKEN - META(1)%VARNC = 'JONSWAP peak enhancement factor; ' // PARTCOM - META(1)%VARND = '' - META(1)%VMIN = 0 - META(1)%VMAX = 320 -! IFI=4, IFJ=10, PGW - META => GROUP(4)%FIELD(10)%META - META(1)%FSC = 0.0001 - META(1)%UNITS = 's-1' - META(1)%ENAME = '.pgw'// IPART_TOKEN - META(1)%VARNM = 'pgw'// IPART_TOKEN - META(1)%VARNL = 'frequency width partition '// IPART_TOKEN - !META(1)%VARNS = 'Gaussian_frequency_spread_partition_'// IPART_TOKEN - META(1)%VARNS = '' - META(1)%VARNG = 'Gaussian_frequency_spread_partition_'// IPART_TOKEN - META(1)%VARNC = 'Gaussian least-square fit to ' // & - 'omni-directional spectral partition; ' // PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 3.2 -! IFI=4, IFJ=11, PSW - META => GROUP(4)%FIELD(11)%META - META(1)%FSC = 0.0001 - META(1)%UNITS = '1' - META(1)%ENAME = '.psw'// IPART_TOKEN - META(1)%VARNM = 'psw'// IPART_TOKEN - META(1)%VARNL = 'spectral width partition '// IPART_TOKEN - !META(1)%VARNS = 'sea_surface_wave_spectral_width_partition_'// IPART_TOKEN - META(1)%VARNS = '' - META(1)%VARNG = 'wave_spectral_width_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 3.2 -! IFI=4, IFJ=12, PTM10 - META => GROUP(4)%FIELD(12)%META - META(1)%FSC = 0.01 - META(1)%UNITS = 's' - META(1)%ENAME = '.ptm10c'// IPART_TOKEN - META(1)%VARNM = 'ptm10c'// IPART_TOKEN - META(1)%VARNL = 'mean period Tm10 partition '// IPART_TOKEN - META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_mean_period_from_variance' // & - '_spectral_density_inverse_frequency_moment' - META(1)%VARNG = 'mean_wave_period_Tm10_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 100 -! IFI=4, IFJ=13, PT01 - META => GROUP(4)%FIELD(13)%META - META(1)%FSC = 0.01 - META(1)%UNITS = 's' - META(1)%ENAME = '.pt01c'// IPART_TOKEN - META(1)%VARNM = 'pt01c'// IPART_TOKEN - META(1)%VARNL = 'mean period T01 partition '// IPART_TOKEN - META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_mean_period_from_variance' // & - '_spectral_density_first_frequency_moment' - META(1)%VARNG = 'mean_wave_period_T01_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 100 -! IFI=4, IFJ=14, PT02 - META => GROUP(4)%FIELD(14)%META - META(1)%FSC = 0.01 - META(1)%UNITS = 's' - META(1)%ENAME = '.pt02c'// IPART_TOKEN - META(1)%VARNM = 'pt02c'// IPART_TOKEN - META(1)%VARNL = 'mean period T02 partition '// IPART_TOKEN - META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_mean_period_from_variance' // & - '_spectral_density_second_frequency_moment' - META(1)%VARNG = 'mean_wave_period_T02_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 100 -! IFI=4, IFJ=15, PEP - META => GROUP(4)%FIELD(15)%META - META(1)%FSC = 0.02 - META(1)%UNITS = 'm2 s rad-1' - META(1)%ENAME = '.pep'// IPART_TOKEN - META(1)%VARNM = 'pep'// IPART_TOKEN - META(1)%VARNL = 'energy at peak frequency partition '// IPART_TOKEN - !META(1)%VARNS = 'sea_surface_wave_energy_at_variance_spectral_density_maximum_partition_'// IPART_TOKEN - META(1)%VARNS = '' - META(1)%VARNG = 'wave_energy_at_variance_spectral_density_maximum_partition_'// IPART_TOKEN - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 200 -! IFI=4, IFJ=16, TWS - META => GROUP(4)%FIELD(16)%META - META(1)%FSC = 0.001 - META(1)%UNITS = '1' - META(1)%ENAME = '.tws' - META(1)%VARNM = 'tws' - META(1)%VARNL = 'wind sea fraction' - !META(1)%VARNS = 'wind_sea_fraction' - META(1)%VARNS = '' - META(1)%VARNG = 'wind_sea_fraction' - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 1 -! IFI=4, IFJ=17, PNR - META => GROUP(4)%FIELD(17)%META - META(1)%FSC = 1. - META(1)%UNITS = '1' - META(1)%ENAME = '.pnr' - META(1)%VARNM = 'pnr' - META(1)%VARNL = 'number of wave partitions' - !META(1)%VARNS = 'number_of_wave_partitions' - META(1)%VARNS = '' - META(1)%VARNG = 'number_of_wave_partitions' - META(1)%VARNC = PARTCOM - META(1)%VMIN = 0 - META(1)%VMAX = 100 -! -!---------- GROUP 5 ---------------- -! -! IFI=5, IFJ=1, UST - META => GROUP(5)%FIELD(1)%META - ! First component - META(1)%FSC = 0.01 - META(1)%ENAME = '.ust' META(1)%UNITS = 'm s-1' - META(1)%VARNM='uust' - META(1)%VARNL='eastward friction velocity' - !META(1)%VARNS='eastward_friction_velocity' - META(1)%VARNS='' - META(1)%VARNG='eastward_friction_velocity' - META(1)%VARNC='ust=sqrt(uust**2+vust**2)' - META(1)%VARND=DIRCOM - META(1)%VMIN = -99.0 - META(1)%VMAX = 99.0 - - ! Second component - META(2) = META(1) - META(2)%VARNM='vust' - META(2)%VARNL='northward friction velocity' - !META(2)%VARNS='northward_friction_velocity' - META(2)%VARNS='' - META(2)%VARNG='northward_friction_velocity' -! IFI=5, IFJ=2, CHA - META => GROUP(5)%FIELD(2)%META - META(1)%FSC = 1.E-5 - META(1)%UNITS = '1' - META(1)%ENAME = '.cha' - META(1)%VARNM='cha' - META(1)%VARNL='charnock coefficient for surface roughness length for momentum in air' - META(1)%VARNS='charnock_coefficient_for_surface_roughness_length_for_momentum_in_air' - META(1)%VARNG='charnock_coefficient' - META(1)%VMIN = 0 - META(1)%VMAX = 0.327 -! IFI=5, IFJ=3, CGE - META => GROUP(5)%FIELD(3)%META - META(1)%FSC = 0.1 !0.01 - META(1)%UNITS = 'kW m-1' - META(1)%ENAME = '.cge' - META(1)%VARNM='cge' - META(1)%VARNL='wave energy flux' - !META(1)%VARNS='sea_surface_wind_wave_energy_flux' - META(1)%VARNS='' - META(1)%VARNG='wave_energy_flux' - META(1)%VMIN = 0 - META(1)%VMAX = 999 -! IFI=5, IFJ=4, FAW - META => GROUP(5)%FIELD(4)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'W m-2' - META(1)%ENAME = '.faw' - META(1)%VARNM='faw' - META(1)%VARNL='wind to wave energy flux' - META(1)%VARNS='wind_mixing_energy_flux_into_sea_water' - META(1)%VARNG='wind_to_wave_energy_flux' - META(1)%VMIN = 0 - META(1)%VMAX = 999 -! IFI=5, IFJ=5, TAW - META => GROUP(5)%FIELD(5)%META - ! First component - META(1)%FSC = 0.000001 - META(1)%UNITS = 'm2 s-2' - META(1)%ENAME = '.taw' - META(1)%VARNM='utaw' - META(1)%VARNL='eastward wave supported wind stress' - !META(1)%VARNS='eastward_wave_supported_wind_stress' - META(1)%VARNS='' - META(1)%VARNC='taw=sqrt(utaw**2+vtaw**2)' - META(1)%VARNG='eastward_wave_supported_wind_stress' - META(1)%VARND=DIRCOM - META(1)%VMIN = -0.032 - META(1)%VMAX = 0.032 - - ! Second component - META(2) = META(1) - META(2)%VARNM='vtaw' - META(2)%VARNL='northward wave supported wind stress' - !META(2)%VARNS='northward_wave_supported_wind_stress' - META(2)%VARNS='' - META(2)%VARNG='northward_wave_supported_wind_stress' - META(2)%VARNC='taw=sqrt(utaw**2+vtaw**2)' -! IFI=5, IFJ=6, TWA - META => GROUP(5)%FIELD(6)%META - ! First component - META(1)%FSC = 0.0001 - META(1)%ENAME = '.twa' - META(1)%UNITS = 'm2 s-2' - META(1)%VARNM='utwa' - META(1)%VARNL='eastward wave to wind stress' - !META(1)%VARNS='eastward_wave_to_wind_stress' - META(1)%VARNS='' - META(1)%VARNG='eastward_wave_to_wind_stress' - META(1)%VARNC='twa=sqrt(utwa**2+vtwa**2)' - META(1)%VARND=DIRCOM - META(1)%VMIN = -3.2 - META(1)%VMAX = 3.2 - - ! Second component - META(2) = META(1) - META(2)%VARNM='vtwa' - META(2)%VARNL='northward wave to wind stress' - !META(2)%VARNS='northward_wave_to_wind_stress' - META(2)%VARNS='' - META(2)%VARNG='northward_wave_to_wind_stress' - META(2)%VARNC='twa=sqrt(utwa**2+vtwa**2)' -! IFI=5, IFJ=7, WCC - META => GROUP(5)%FIELD(7)%META - META(1)%FSC = 0.0001 - META(1)%UNITS = '1' - META(1)%ENAME = '.wcc' - META(1)%VARNM='wcc' - META(1)%VARNL='whitecap coverage' - !META(1)%VARNS='whitecap_coverage' - META(1)%VARNS='' - META(1)%VARNG='whitecap_coverage' - META(1)%VARNC='' - META(1)%VARND='' META(1)%VMIN = 0 - META(1)%VMAX = 1 -! IFI=5, IFJ=8, WCF - META => GROUP(5)%FIELD(8)%META - META(1)%FSC = 0.001 - META(1)%UNITS = 'm' - META(1)%ENAME = '.wcf' - META(1)%VARNM='wcf' - META(1)%VARNL='whitecap foam thickness' - !META(1)%VARNS='whitecap_foam_thickness' - META(1)%VARNS='' - META(1)%VARNG='whitecap_foam_thickness' - META(1)%VMIN = 0 - META(1)%VMAX = 10 -! IFI=5, IFJ=9, WCH - META => GROUP(5)%FIELD(9)%META - META(1)%FSC = 0.002 - META(1)%UNITS = 'm' - META(1)%ENAME = '.wch' - META(1)%VARNM='wch' - META(1)%VARNL='significant breaking wave height' - !META(1)%VARNS='significant_breaking_wave_height' - META(1)%VARNS='' - META(1)%VARNG='significant_breaking_wave_height' - META(1)%VMIN = 0 - META(1)%VMAX = 64 -! IFI=5, IFJ=10, WCM - META => GROUP(5)%FIELD(10)%META - META(1)%FSC = 0.0001 - META(1)%UNITS = '1' - META(1)%ENAME = '.wcm' - META(1)%VARNM='wcm' - META(1)%VARNL='whitecap moment' - !META(1)%VARNS='whitecap_moment' - META(1)%VARNS='' - META(1)%VARNG='whitecap_moment' - META(1)%VMIN = 0 - META(1)%VMAX = 1 -! IFI=5, IFJ=11, FWS - META => GROUP(5)%FIELD(11)%META - META(1)%FSC = 0.002 - META(1)%UNITS = 's' - META(1)%ENAME = '.fws' - META(1)%VARNM='fws' - META(1)%VARNL='Wind_sea_mean_period_T0M1' - META(1)%VARNS='sea_surface_wind_wave_mean_period_from_variance' // & - '_spectral_density_inverse_frequency_moment' - META(1)%VARNG='Wind_sea_mean_period_T0M1' - META(1)%VARNC='' - META(1)%VARND='' - META(1)%VMIN = 0 - META(1)%VMAX = 64 -! -!---------- GROUP 6 ---------------- -! -! IFI=6, IFJ=1, SXY - META => GROUP(6)%FIELD(1)%META - META(1)%FSC = 10. - META(1)%UNITS = 'N m-1' - META(1)%ENAME = '.sxy' - META(1)%VARND = DIRCOM - META(1)%VMIN = -30000 - META(1)%VMAX = 30000 - - ! First component - META(1)%VARNM='sxx' - META(1)%VARNL='Radiation stress component Sxx' - !META(1)%VARNS='radiation_stress_component_sxx' - META(1)%VARNS='' - - ! S6cond component - META(2) = META(1) - META(2)%VARNM='syy' - META(2)%VARNL='Radiation stress component Syy' - !META(2)%VARNS='radiation_stress_component_syy' - META(2)%VARNS='' - - ! Third component - META(3) = META(1) - META(3)%FSC = 1. - META(3)%VARNM='sxy' - META(3)%VARNL='Radiation stress component Sxy' - !META(3)%VARNS='radiation_stress_component_sxy' - META(3)%VARNS='' -! IFI=6, IFJ=2, TWO - META => GROUP(6)%FIELD(2)%META - META(1)%FSC = 0.000001 - META(1)%UNITS = 'm2 s-2' - META(1)%ENAME = '.two' - META(1)%VMIN = -0.032 - META(1)%VMAX = 0.032 - META(1)%VARND = DIRCOM - - ! First component - META(1)%VARNM='utwo' - META(1)%VARNL='eastward wave to ocean stress' - !META(1)%VARNS='eastward_wave_to_ocean_stress' - META(1)%VARNS='' - META(1)%VARNG='eastward_wave_to_ocean_stress' - META(1)%VARNC='two=sqrt(utwo**2+vtwo**2)' + META(1)%VMAX = 10.0 + META(1)%VARNM='cspd' + META(1)%VARNL='current speed' + META(1)%VARNS='sea_water_speed' + META(1)%VARNG='sea_water_speed' ! Second component META(2) = META(1) - META(2)%VARNM='vtwo' - META(2)%VARNL='northward wave to ocean stress' - !META(2)%VARNS='northward_wave_to_ocean_stress' - META(2)%VARNS='' - META(2)%VARNG='northward_wave_to_ocean_stress' - META(2)%VARNC='two=sqrt(utwo**2+vtwo**2)' -! IFI=6, IFJ=3, BHD - META => GROUP(6)%FIELD(3)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'm2 s-2' - META(1)%ENAME = '.bhd' - META(1)%VARNM='bhd' - META(1)%VARNL='radiation pressure (Bernouilli Head)' - !META(1)%VARNS='radiation_pressure' - META(1)%VARNS='' - META(1)%VARNG='radiation_pressure' - META(1)%VMIN = 0 - META(1)%VMAX = 100 -! IFI=6, IFJ=4, FOC - META => GROUP(6)%FIELD(4)%META + META(2)%FSC = 0.1 + META(2)%VARNM='cdir' + META(2)%UNITS= 'degrees' + META(2)%VARNL='current direction (toward)' + META(2)%VARNS='direction_of_sea_water_velocity' + META(2)%VARNG='direction_of_sea_water_velocity' + META(2)%VMIN = 0 + META(2)%VMAX = 360.0 + ENDIF ! VECTOR + ! IFI=1, IFJ=3 + META => GROUP(1)%FIELD(3)%META + META(1)%ENAME = '.wnd' + META(1)%VARND = DIRCOM + IF(VECTOR) THEN META(1)%FSC = 0.1 - META(1)%UNITS = 'W m-2' - META(1)%ENAME = '.foc' - META(1)%VARNM='foc' - META(1)%VARNL='wave to ocean energy flux' - !META(1)%VARNS='wave_to_ocean_energy_flux' - META(1)%VARNS='' - META(1)%VARNG='wave_to_ocean_energy_flux' - META(1)%VMIN = 0 - META(1)%VMAX = 999 -! IFI=6, IFJ=5, TUS - META => GROUP(6)%FIELD(5)%META - META(1)%FSC = 0.001 - META(1)%UNITS = 'm2 s-1' - META(1)%ENAME = '.tus' - META(1)%VARND = DIRCOM - META(1)%VMIN = -32.0 ! C Hansen: The former values of +-9.9 might be - META(1)%VMAX = 32.0 ! exceeded more frequently in real storms - - ! First component - META(1)%VARNM='utus' - META(1)%VARNL='eastward stokes transport' - !META(1)%VARNS='eastward_stokes_transport' - META(1)%VARNS='' - META(1)%VARNG='eastward_stokes_transport' - META(1)%VARNC='tus=sqrt(utus**2+vtus**2)' + META(1)%UNITS = 'm s-1' + META(1)%VARNM='uwnd' + META(1)%VARNL='eastward_wind' + META(1)%VARNS='eastward_wind' + META(1)%VARNG='eastward_wind' + META(1)%VARNC='wind=sqrt(U10**2+V10**2)' + META(1)%VMIN = -99.0 + META(1)%VMAX = 99.0 ! Second component META(2) = META(1) - META(2)%VARNM='vtus' - META(2)%VARNL='northward stokes transport' - !META(2)%VARNS='northward_stokes_transport' - META(2)%VARNS='' - META(2)%VARNG='northward_stokes_transport' - META(2)%VARNC='tus=sqrt(utus**2+vtus**2)' - -! IFI=6, IFJ=6, USS - META => GROUP(6)%FIELD(6)%META - META(1)%FSC = 0.0005 - META(1)%UNITS = 'm s-1' - META(1)%ENAME = '.uss' - - ! First component - META(1)%VARNM='uuss' - META(1)%VARNL='eastward surface stokes drift' - META(1)%VARNS='sea_surface_wave_stokes_drift_eastward_velocity' - META(1)%VARNG='eastward_surface_stokes_drift' - META(1)%VARNC='uss=sqrt(uuss**2+vuss**2)' - META(1)%VARND=DIRCOM - META(1)%VMIN = -4.95 - META(1)%VMAX = 4.95 + META(2)%VARNM='vwnd' + META(2)%VARNL='northward_wind' + META(2)%VARNS='northward_wind' + META(2)%VARNG='northward_wind' + META(2)%VARNC='wind=sqrt(U10**2+V10**2)' + ELSE + META(1)%FSC = 0.01 + META(1)%UNITS= 'm s-1' + META(1)%VARNM='wspd' + META(1)%VARNL='wind speed' + META(1)%VARNS='wind_speed' + META(1)%VARNG='wind_speed' + META(1)%VMIN = 0.0 + META(1)%VMAX = 100.0 ! Second component META(2) = META(1) - META(2)%VARNM='vuss' - META(2)%VARNL='northward surface stokes drift' - META(2)%VARNS='sea_surface_wave_stokes_drift_northward_velocity' - META(2)%VARNG='northward_surface_stokes_drift' - WRITE(META(2)%VARNC,'(A,F8.4,A,F8.4,A)') 'Frequency range ',SIG(1)*TPIINV,' to ',SIG(NK)*TPIINV,' Hz' -! IFI=6, IFJ=7, P2S - META => GROUP(6)%FIELD(7)%META - META(1)%FSC = 0.01 - META(1)%ENAME = '.p2s' - META(1)%UNITS = 'm4' - META(1)%VMIN = -150 - META(1)%VMAX = 320 - - ! First component + META(2)%FSC = 0.1 + META(2)%VARNM='wdir' + META(2)%UNITS='degrees' + META(2)%VARNL='wind direction (from)' + META(2)%VARNS='wind_from_direction' + META(2)%VARNG='wind_from_direction' + META(2)%VMIN = 0.0 + META(2)%VMAX = 360.0 + ENDIF ! VECTOR + ! IFI=1, IFJ=4, AST + META => GROUP(1)%FIELD(4)%META + META(1)%FSC = 0.1 + META(1)%ENAME = '.ast' + META(1)%UNITS = 'K' + META(1)%VARNM='ast' + META(1)%VARNL='air sea temperature difference' + !META(1)%VARNS='air_sea_temperature_difference' + META(1)%VARNS='' + META(1)%VARNG='air_sea_temperature_difference' + META(1)%VMIN = 0 + META(1)%VMAX = 400 + ! IFI=1, IFJ=5, WLV + META => GROUP(1)%FIELD(5)%META + META(1)%FSC = 0.01 + META(1)%UNITS = 'm' + META(1)%ENAME = '.wlv' + META(1)%VARNM='wlv' + META(1)%VARNL='sea surface height above sea level' + META(1)%VARNS='sea_surface_height_above_mean_sea_level' + META(1)%VARNG='sea_surface_height_above_sea_level' + META(1)%VMIN = 0 + META(1)%VMAX = 100 + ! IFI=1, IFJ=6, ICE + META => GROUP(1)%FIELD(6)%META + META(1)%FSC = 0.001 + META(1)%UNITS = '1' + META(1)%ENAME = '.ice' + META(1)%VARNM='ice' + META(1)%VARNL='sea ice area fraction' + META(1)%VARNS='sea_ice_area_fraction' + META(1)%VARNG='sea_ice_area_fraction' + META(1)%VMIN = 0 + META(1)%VMAX = 1 + ! IFI=1, IFJ=7, IBG + META => GROUP(1)%FIELD(7)%META + META(1)%FSC = 0.0001 + META(1)%UNITS = 'km-1' + META(1)%ENAME = '.ibg' + META(1)%VARNM='ibg' + META(1)%VARNL='icebergs_damping' + !META(1)%VARNS='icebergs_induced_attenuation_scale_for_waves' + META(1)%VARNS='' + META(1)%VARNG='icebergs_damping' + META(1)%VMIN = 0 + META(1)%VMAX = 3.2 + ! IFI=1, IFJ=8, TAUA + META => GROUP(1)%FIELD(8)%META + META(1)%FSC = 0.01 + META(1)%UNITS = 'Pa' + META(1)%ENAME = '.taua' + META(1)%VARNM='utaua' + META(1)%VARNL='surface_downward_eastward_stress' + META(1)%VARNS='surface_downward_eastward_stress' + META(1)%VARNG='surface_downward_eastward_stress' + META(2)%VARNC='taua=sqrt(utaua**2+vtaua**2)' + META(1)%VMIN = -320 + META(1)%VMAX = 320 + META(1)%VARND = DIRCOM + + ! Second component + META(2) = META(1) + META(2)%VARNM='vtaua' + META(2)%VARNL='surface_downward_northward_stress' + META(2)%VARNS='surface_downward_northward_stress' + META(2)%VARNG='surface_downward_northward_stress' + META(2)%VARNC='taua=sqrt(utaua**2+vtaua**2)' + ! IFI=1, IFJ=9, RHO + META => GROUP(1)%FIELD(9)%META + META(1)%FSC = 0.0001 + META(1)%UNITS = 'kg m-3' + META(1)%ENAME = '.rhoa' + META(1)%VARNM='rhoa' + META(1)%VARNL='air_density' + META(1)%VARNS='air_density' + META(1)%VARNG='air_density' + META(1)%VMIN = 0 + META(1)%VMAX = 2 + ! IFI=1, IFJ=10, D50 +#ifdef W3_BT4 + META => GROUP(1)%FIELD(10)%META + META(1)%FSC = 0.001 + META(1)%UNITS = 'Krumbein phi scale' + META(1)%ENAME = '.d50' + META(1)%VARNM='d50' + META(1)%VARNL='grain_size' + !META(1)%VARNS='sediment_grain_size' + META(1)%VARNS='' + META(1)%VARNG='sediment_grain_size' + META(1)%VMIN = -10.0 + META(1)%VMAX = 32.0 +#endif + ! IFI=1, IFJ=11, IC1 +#ifdef W3_IS2 + META => GROUP(1)%FIELD(11)%META + META(1)%FSC = 0.001 + META(1)%UNITS = 'm' + META(1)%ENAME = '.ic1' + META(1)%VARNM='ic1' + META(1)%VARNL='ice thickness' + META(1)%VARNS='sea_ice_thickness' + META(1)%VARNG='ice_thickness' + META(1)%VMIN = 0 + META(1)%VMAX = 30 + ! IFI=1, IFJ=12, IC5 + META => GROUP(1)%FIELD(12)%META + META(1)%FSC = 0.05 + META(1)%UNITS = 'm' + META(1)%ENAME = '.ic5' + META(1)%VARNM='ic5' + META(1)%VARNL='maximum floe diameter' + !META(1)%VARNS='maximum_ice_floe_diameter' + META(1)%VARNS='' + META(1)%VARNG='maximum_ice_floe_diameter' + META(1)%VMIN = 0 + META(1)%VMAX = 1500 +#endif + ! + !----------GROUP 2 ---------------- + ! + ! IFI=2, IFJ=1, HS + META => GROUP(2)%FIELD(1)%META + META(1)%FSC = 0.002 + META(1)%UNITS = 'm' + META(1)%ENAME = '.hs' + META(1)%VARNM='hs' + META(1)%VARNL='significant height of wind and swell waves' + META(1)%VARNS='sea_surface_wave_significant_height' + META(1)%VARNG='significant_wave_height' + META(1)%VMIN = 0 + META(1)%VMAX = 64 + ! IFI=2, IFJ=2, LM + META => GROUP(2)%FIELD(2)%META + META(1)%FSC = 1. + META(1)%UNITS = 'm' + META(1)%ENAME = '.lm' + META(1)%VARNM='lm' + META(1)%VARNL='mean wave length' + !META(1)%VARNS='mean_wave_length' + META(1)%VARNS='' + META(1)%VARNG='mean_wave_length' + META(1)%VMIN = 0 + META(1)%VMAX = 3200 + ! IFI=2, IFJ=3, T02 + META => GROUP(2)%FIELD(3)%META + META(1)%FSC = 0.01 + META(1)%UNITS = 's' + META(1)%ENAME = '.t02' + META(1)%VARNM='t02' + META(1)%VARNL='mean period T02' + META(1)%VARNS='sea_surface_wind_wave_mean_period' // & + '_from_variance_spectral_density_second_frequency_moment' + META(1)%VARNG='mean_period_t02' + META(1)%VMIN = 0 + META(1)%VMAX = 50 + ! IFI=2, IFJ=4, T0M1 + META => GROUP(2)%FIELD(4)%META + META(1)%FSC = 0.01 + META(1)%UNITS = 's' + META(1)%ENAME = '.t0m1' + META(1)%VARNM='t0m1' + META(1)%VARNL='mean period T0m1' + META(1)%VARNS='sea_surface_wind_wave_mean_period_from_variance' // & + '_spectral_density_inverse_frequency_moment' + META(1)%VARNG='mean_period_t0m1' + META(1)%VMIN = 0 + META(1)%VMAX = 50 + ! IFI=2, IFJ=5, T01 + META => GROUP(2)%FIELD(5)%META + META(1)%FSC = 0.01 + META(1)%UNITS = 's' + META(1)%ENAME = '.t01' + META(1)%VARNM='t01' + META(1)%VARNL='mean period T01' + META(1)%VARNS='sea_surface_wind_wave_mean_period_from_variance' // & + '_spectral_density_first_frequency_moment' + META(1)%VARNG='mean_period_t01' + META(1)%VMIN = 0 + META(1)%VMAX = 50 + ! IFI=2, IFJ=6, FP + META => GROUP(2)%FIELD(6)%META + META(1)%FSC = 0.001 + META(1)%UNITS = 's-1' + META(1)%ENAME = '.fp' + META(1)%VARNM='fp' + META(1)%VARNL='wave peak frequency' + !META(1)%VARNS='sea_surface_wave_peak_frequency' + META(1)%VARNS='' + META(1)%VARNG='dominant_wave_frequency' + META(1)%VMIN = 0 + META(1)%VMAX = 10 + ! IFI=2, IFJ=7, DIR + META => GROUP(2)%FIELD(7)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'degree' + META(1)%ENAME = '.dir' + META(1)%VARNM='dir' + META(1)%VARNL='wave mean direction' + META(1)%VARNS='sea_surface_wave_from_direction' + META(1)%VARNG='wave_from_direction' + META(1)%VARND=DIRCOM + META(1)%VMIN = 0 + META(1)%VMAX = 360 + ! IFI=2, IFJ=8, SPR + META => GROUP(2)%FIELD(8)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'degree' + META(1)%ENAME = '.spr' + META(1)%VARNM='spr' + META(1)%VARNL='directional spread' + META(1)%VARNS='sea_surface_wave_directional_spread' + META(1)%VARNG='directional_spread' + META(1)%VMIN = 0 + META(1)%VMAX = 90 + ! IFI=2, IFJ=9, DP + META => GROUP(2)%FIELD(9)%META + META(1)%FSC = 1. + META(1)%UNITS = 'degree' + META(1)%ENAME = '.dp' + META(1)%VARNM='dp' + META(1)%VARNL='peak direction' + META(1)%VARNS='sea_surface_wave_peak_direction' + META(1)%VARNG='dominant_wave_direction' + META(1)%VARND=DIRCOM + META(1)%VMIN = 0 + META(1)%VMAX = 360 + ! IFI=2, IFJ=10, HIG + META => GROUP(2)%FIELD(10)%META + META(1)%FSC = 0.0002 + META(1)%UNITS = 'm' + META(1)%ENAME = '.hig' + META(1)%VARNM='hig' + META(1)%VARNL='infragravity_wave_height' + !META(1)%VARNS='sea_surface_wave_infragravity_significant_height' + META(1)%VARNS='' + META(1)%VARNG='infragravity_significant_wave_height' + META(1)%VMIN = 0 + META(1)%VMAX = 1.0 + ! IFI=2, IFJ=11, MXE + META => GROUP(2)%FIELD(11)%META + META(1)%FSC = 0.002 + META(1)%UNITS = 'm' + META(1)%ENAME = '.mxe' + META(1)%VARNM='stmaxe' + META(1)%VARNL='expected maximum sea surface elevation (nonlinear,2nd order)' + !META(1)%VARNS='expected maximum sea surface elevation (nonlinear,2nd order)' + META(1)%VARNS='' + META(1)%VARNG='expected maximum sea surface elevation (nonlinear,2nd order)' + META(1)%VMIN = 0 + META(1)%VMAX = 64 + ! IFI=2, IFJ=12, MXES + META => GROUP(2)%FIELD(12)%META + META(1)%FSC = 0.002 + META(1)%UNITS = 'm' + META(1)%ENAME = '.mxes' + META(1)%VARNM='stmaxd' + META(1)%VARNL='standard deviation of maximum sea surface elevation (nonlinear,2nd order)' + !META(1)%VARNS='std of expected maximum sea surface elevation (nonlinear,2nd order)' + META(1)%VARNS='' + META(1)%VARNG='standard deviation of maximum sea surface elevation (nonlinear,2nd order)' + META(1)%VMIN = 0 + META(1)%VMAX = 64 + ! IFI=2, IFJ=13, MXH + META => GROUP(2)%FIELD(13)%META + META(1)%FSC = 0.002 + META(1)%UNITS = 'm' + META(1)%ENAME = '.mxh' + META(1)%VARNM='hmaxe' + META(1)%VARNL='expected maximum wave height (linear, 1st order)' + !META(1)%VARNS='expected maximum wave height (linear, 1st order)' + META(1)%VARNS='' + META(1)%VARNG='expected maximum wave height (linear, 1st order)' + META(1)%VMIN = 0 + META(1)%VMAX = 64 + ! IFI=2, IFJ=14, MXHC + META => GROUP(2)%FIELD(14)%META + META(1)%FSC = 0.002 + META(1)%UNITS = 'm' + META(1)%ENAME = '.mxhc' + META(1)%VARNM='hcmaxe' + META(1)%VARNL='expected maximum wave height from crest (linear, 1st order)' + !META(1)%VARNS='expected maximum wave height from crest (linear, 1st order)' + META(1)%VARNS='' + META(1)%VARNG='expected maximum wave height from crest (linear, 1st order)' + META(1)%VMIN = 0 + META(1)%VMAX = 64 + ! IFI=2, IFJ=15, SDMH + META => GROUP(2)%FIELD(15)%META + META(1)%FSC = 0.002 + META(1)%UNITS = 'm' + META(1)%ENAME = '.sdmh' + META(1)%VARNM='hmaxd' + META(1)%VARNL='STD of maximum wave height (linear, 1st order)' + !META(1)%VARNS='STD of maximum wave height (linear, 1st order)' + META(1)%VARNS='' + META(1)%VARNG='STD of maximum wave height (linear, 1st order)' + META(1)%VMIN = 0 + META(1)%VMAX = 64 + ! IFI=2, IFJ=16, SDMHC + META => GROUP(2)%FIELD(16)%META + META(1)%FSC = 0.002 + META(1)%UNITS = 'm' + META(1)%ENAME = '.sdmhc' + META(1)%VARNM='hcmaxd' + META(1)%VARNL='STD of maximum wave height from crest (linear, 1st order)' + !META(1)%VARNS='STD of maximum wave height from crest (linear, 1st order)' + META(1)%VARNS='' + META(1)%VARNG='STD of maximum wave height from crest (linear, 1st order)' + META(1)%VMIN = 0 + META(1)%VMAX = 64 + ! IFI=2, IFJ=17, WBT + META => GROUP(2)%FIELD(17)%META + META(1)%FSC = 0.001 + META(1)%UNITS = '1' + META(1)%ENAME = '.wbt' + META(1)%VARNM='wbt' + META(1)%VARNL='dominant wave breaking probability' + !META(1)%VARNS='dominant_wave_breaking_probability' + META(1)%VARNS='' + META(1)%VARNG='dominant_wave_breaking_probability' + META(1)%VMIN = 0 + META(1)%VMAX = 1 + ! IFI=2, IFJ=18, TP + META => GROUP(2)%FIELD(18)%META + META(1)%FSC = 0.01 + META(1)%UNITS = 's' + META(1)%ENAME = '.tp' + META(1)%VARNM='tp' + META(1)%VARNL='wave peak period' + META(1)%VARNS='sea_surface_wave_peak_period' + META(1)%VARNG='dominant_wave_period' + META(1)%VMIN = 0 + META(1)%VMAX = 50 + ! IFI=2, IFJ=19 + META => GROUP(2)%FIELD(19)%META + META(1)%FSC = 0.001 + META(1)%UNITS = 'm-1' + META(1)%ENAME = '.wnm' + META(1)%VARNM='wnm' + META(1)%VARNL='mean wave number' + META(1)%VARNS='' + META(1)%VARNG='' + META(1)%VMIN = 0 + META(1)%VMAX = 32 + ! + !---------- GROUP 3 ---------------- + ! + ! IFI=3, IFJ=1, EF + META => GROUP(3)%FIELD(1)%META + META(1)%VARNM='ef' + META(1)%VARNL='wave_elevation_spectrum' + META(1)%VARNS='sea_surface_wave_variance_spectral_density' + IF (NCVARTYPE.LE.3) THEN + META(1)%UNITS = 'log10(m2 s+1E-12)' + !META(1)%VARNS='base_ten_logarithm_of_power_spectral_density_of_surface_elevation' + META(1)%VARNC='base_ten_logarithm' + META(1)%FSC = 0.0004 + META(1)%VMIN = -12. + META(1)%VMAX = 12. + ELSE + META(1)%UNITS = 'm2 s' + META(1)%FSC = 1. + META(1)%VMIN = 0. + META(1)%VMAX = 1.e12 + END IF + META(1)%ENAME = '.ef' + META(1)%VARNG = META(1)%VARNS + ! IFI=3, IFJ=2, TH1M + META => GROUP(3)%FIELD(2)%META + ! Information for spectral + META(1)%FSC = 0.1 + META(1)%VARNM='th1m' + META(1)%VARNL='mean wave direction frequency spectrum' + !META(1)%VARNS='sea_surface_wave_from_direction_frequency_spectrum' + META(1)%VARNS='' + META(1)%VARNG = META(1)%VARNS + META(1)%VARND=DIRCOM + META(1)%UNITS = 'degree' + META(1)%ENAME = '.th1m' + META(1)%VMIN = 0 + META(1)%VMAX = 360 + ! IFI=3, IFJ=3, STH1M + META => GROUP(3)%FIELD(3)%META + ! Information for spectral + META(1)%FSC = 0.01 + META(1)%VARNM='sth1m' + META(1)%VARNL='spreading frequency spectrum' + !META(1)%VARNS='sea_surface_wave_spreading_spectrum' + META(1)%VARNS='' + META(1)%VARNG = META(1)%VARNS + META(1)%UNITS = 'degree' + META(1)%ENAME = '.sth1m' + META(1)%VMIN = 0 + META(1)%VMAX = 90 + ! IFI=3, IFJ=4, TH2M + META => GROUP(3)%FIELD(4)%META + META(1)%FSC = 0.1 + META(1)%VARNM='th2m' + META(1)%VARNL='second mean wave direction frequency spectrum' + !META(1)%VARNS='sea_surface_wave_from_direction_frequency_spectrum_from_second_moments' + META(1)%VARNS='' + META(1)%VARNG = META(1)%VARNS + META(1)%VARND=DIRCOM + META(1)%UNITS = 'degree' + META(1)%ENAME = '.th2m' + META(1)%VMIN = 0 + META(1)%VMAX = 360 + ! IFI=3, IFJ=5, STH2M + META => GROUP(3)%FIELD(5)%META + META(1)%FSC = 0.01 + META(1)%VARNM='sth2m' + META(1)%VARNL='second spreading frequency spectrum' + !META(1)%VARNS='sea_surface_wave_spreading_spectrum_from_second_moments' + META(1)%VARNS='' + META(1)%VARNG = META(1)%VARNS + META(1)%UNITS = 'degree' + META(1)%ENAME = '.sth2m' + META(1)%VMIN = 0 + META(1)%VMAX = 90 + ! IFI=3, IFJ=6, WN + META => GROUP(3)%FIELD(6)%META + ! Information for spectral + META(1)%FSC = 0.001 + META(1)%UNITS = 'm-1' + META(1)%ENAME = '.wn' + META(1)%VARNM='wn' + META(1)%VARNL='wave numbers' + !META(1)%VARNS='wave_numbers' + META(1)%VARNS='' + META(1)%VARNG='wave_numbers' + META(1)%VMIN = 0 + META(1)%VMAX = 32 + ! + !---------- GROUP 4 ---------------- + ! + ! IFI=4, IFJ=1, PHS + META => GROUP(4)%FIELD(1)%META + META(1)%FSC = 0.002 + META(1)%UNITS = 'm' + META(1)%ENAME = '.phs'// IPART_TOKEN + META(1)%VARNM = 'phs'// IPART_TOKEN + META(1)%VARNL = 'wave significant height partition '// IPART_TOKEN + META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_significant_height' + META(1)%VARNG = 'significant_wave_height_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 64 + ! IFI=4, IFJ=2, PTP + META => GROUP(4)%FIELD(2)%META + META(1)%FSC = 0.01 + META(1)%UNITS = 's' + META(1)%ENAME = '.ptp'// IPART_TOKEN + META(1)%VARNM = 'ptp'// IPART_TOKEN + META(1)%VARNL = 'peak period partition '// IPART_TOKEN + META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_period_at_variance' // & + '_spectral_density_maximum' + META(1)%VARNG = 'dominant_wave_period_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 100 + ! IFI=4, IFJ=3, PLP + META => GROUP(4)%FIELD(3)%META + META(1)%FSC = 1. + META(1)%UNITS = 'm' + META(1)%ENAME = '.plp'// IPART_TOKEN + META(1)%VARNM = 'plp'// IPART_TOKEN + META(1)%VARNL = 'peak wave length partition '// IPART_TOKEN + !META(1)%VARNS = 'peak_wave_length_partition_'// SPART_TOKEN_ + META(1)%VARNS = '' + META(1)%VARNG = 'peak_wave_length_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 10000 + ! IFI=4, IFJ=4, PDIR + META => GROUP(4)%FIELD(4)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'degree' + META(1)%ENAME = '.pdir'// IPART_TOKEN + META(1)%VARNM = 'pdir'// IPART_TOKEN + META(1)%VARNL = 'wave mean direction partition '// IPART_TOKEN + META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_from_direction' + META(1)%VARNG = 'wave_from_direction_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VARND = DIRCOM + META(1)%VMIN = 0 + META(1)%VMAX = 360 + ! IFI=4, IFJ=5, PSPR + META => GROUP(4)%FIELD(5)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'degree' + META(1)%ENAME = '.pspr'// IPART_TOKEN + META(1)%VARNM = 'pspr'// IPART_TOKEN + META(1)%VARNL = 'directional spread partition '// IPART_TOKEN + META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_diectional_spread' + META(1)%VARNG = 'directional_spread_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 90 + ! IFI=4, IFJ=6, PWS + META => GROUP(4)%FIELD(6)%META + META(1)%FSC = 0.001 + META(1)%UNITS = '1' + META(1)%ENAME = '.pws'// IPART_TOKEN + META(1)%VARNM = 'pws'// IPART_TOKEN + META(1)%VARNL = 'wind sea fraction in partition '// IPART_TOKEN + !META(1)%VARNS = 'wind_sea_fraction_in_partition_'// IPART_TOKEN + META(1)%VARNS = '' + META(1)%VARNG = 'wind_sea_fraction_in_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 1 + ! IFI=4, IFJ=7, PDP + META => GROUP(4)%FIELD(7)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'degree' + META(1)%ENAME = '.pdp'// IPART_TOKEN + META(1)%VARNM = 'pdp'// IPART_TOKEN + META(1)%VARNL = 'peak direction partition '// IPART_TOKEN + META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_from_direction_at_variance' // & + '_spectral_density_maximum' + META(1)%VARNG = 'dominant_wave_from_direction_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VARND = DIRCOM + META(1)%VMIN = 0 + META(1)%VMAX = 360 + ! IFI=4, IFJ=8, PQP + META => GROUP(4)%FIELD(8)%META + META(1)%FSC = 0.01 + META(1)%UNITS = '1' + META(1)%ENAME = '.pqp'// IPART_TOKEN + META(1)%VARNM = 'pqp'// IPART_TOKEN + META(1)%VARNL = 'peakedness partition '// IPART_TOKEN + !META(1)%VARNS = 'sea_surface_wave_peakedness_partition_'// IPART_TOKEN + META(1)%VARNS = '' + META(1)%VARNG = 'wave_peakedness_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 320 + ! IFI=4, IFJ=9, PPE + META => GROUP(4)%FIELD(9)%META + META(1)%FSC = 0.01 + META(1)%UNITS = '1' + META(1)%ENAME = '.ppe'// IPART_TOKEN + META(1)%VARNM = 'ppe'// IPART_TOKEN + META(1)%VARNL = 'peak enhancement factor partition '// IPART_TOKEN + !META(1)%VARNS = 'wave_peak_enhancement_factor_partition_'// IPART_TOKEN + META(1)%VARNS = '' + META(1)%VARNG = 'wave_peak_enhancement_factor_partition_'// IPART_TOKEN + META(1)%VARNC = 'JONSWAP peak enhancement factor; ' // PARTCOM + META(1)%VARND = '' + META(1)%VMIN = 0 + META(1)%VMAX = 320 + ! IFI=4, IFJ=10, PGW + META => GROUP(4)%FIELD(10)%META + META(1)%FSC = 0.0001 + META(1)%UNITS = 's-1' + META(1)%ENAME = '.pgw'// IPART_TOKEN + META(1)%VARNM = 'pgw'// IPART_TOKEN + META(1)%VARNL = 'frequency width partition '// IPART_TOKEN + !META(1)%VARNS = 'Gaussian_frequency_spread_partition_'// IPART_TOKEN + META(1)%VARNS = '' + META(1)%VARNG = 'Gaussian_frequency_spread_partition_'// IPART_TOKEN + META(1)%VARNC = 'Gaussian least-square fit to ' // & + 'omni-directional spectral partition; ' // PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 3.2 + ! IFI=4, IFJ=11, PSW + META => GROUP(4)%FIELD(11)%META + META(1)%FSC = 0.0001 + META(1)%UNITS = '1' + META(1)%ENAME = '.psw'// IPART_TOKEN + META(1)%VARNM = 'psw'// IPART_TOKEN + META(1)%VARNL = 'spectral width partition '// IPART_TOKEN + !META(1)%VARNS = 'sea_surface_wave_spectral_width_partition_'// IPART_TOKEN + META(1)%VARNS = '' + META(1)%VARNG = 'wave_spectral_width_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 3.2 + ! IFI=4, IFJ=12, PTM10 + META => GROUP(4)%FIELD(12)%META + META(1)%FSC = 0.01 + META(1)%UNITS = 's' + META(1)%ENAME = '.ptm10c'// IPART_TOKEN + META(1)%VARNM = 'ptm10c'// IPART_TOKEN + META(1)%VARNL = 'mean period Tm10 partition '// IPART_TOKEN + META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_mean_period_from_variance' // & + '_spectral_density_inverse_frequency_moment' + META(1)%VARNG = 'mean_wave_period_Tm10_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 100 + ! IFI=4, IFJ=13, PT01 + META => GROUP(4)%FIELD(13)%META + META(1)%FSC = 0.01 + META(1)%UNITS = 's' + META(1)%ENAME = '.pt01c'// IPART_TOKEN + META(1)%VARNM = 'pt01c'// IPART_TOKEN + META(1)%VARNL = 'mean period T01 partition '// IPART_TOKEN + META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_mean_period_from_variance' // & + '_spectral_density_first_frequency_moment' + META(1)%VARNG = 'mean_wave_period_T01_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 100 + ! IFI=4, IFJ=14, PT02 + META => GROUP(4)%FIELD(14)%META + META(1)%FSC = 0.01 + META(1)%UNITS = 's' + META(1)%ENAME = '.pt02c'// IPART_TOKEN + META(1)%VARNM = 'pt02c'// IPART_TOKEN + META(1)%VARNL = 'mean period T02 partition '// IPART_TOKEN + META(1)%VARNS = 'sea_surface_'// SPART_TOKEN_ //'_wave_mean_period_from_variance' // & + '_spectral_density_second_frequency_moment' + META(1)%VARNG = 'mean_wave_period_T02_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 100 + ! IFI=4, IFJ=15, PEP + META => GROUP(4)%FIELD(15)%META + META(1)%FSC = 0.02 + META(1)%UNITS = 'm2 s rad-1' + META(1)%ENAME = '.pep'// IPART_TOKEN + META(1)%VARNM = 'pep'// IPART_TOKEN + META(1)%VARNL = 'energy at peak frequency partition '// IPART_TOKEN + !META(1)%VARNS = 'sea_surface_wave_energy_at_variance_spectral_density_maximum_partition_'// IPART_TOKEN + META(1)%VARNS = '' + META(1)%VARNG = 'wave_energy_at_variance_spectral_density_maximum_partition_'// IPART_TOKEN + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 200 + ! IFI=4, IFJ=16, TWS + META => GROUP(4)%FIELD(16)%META + META(1)%FSC = 0.001 + META(1)%UNITS = '1' + META(1)%ENAME = '.tws' + META(1)%VARNM = 'tws' + META(1)%VARNL = 'wind sea fraction' + !META(1)%VARNS = 'wind_sea_fraction' + META(1)%VARNS = '' + META(1)%VARNG = 'wind_sea_fraction' + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 1 + ! IFI=4, IFJ=17, PNR + META => GROUP(4)%FIELD(17)%META + META(1)%FSC = 1. + META(1)%UNITS = '1' + META(1)%ENAME = '.pnr' + META(1)%VARNM = 'pnr' + META(1)%VARNL = 'number of wave partitions' + !META(1)%VARNS = 'number_of_wave_partitions' + META(1)%VARNS = '' + META(1)%VARNG = 'number_of_wave_partitions' + META(1)%VARNC = PARTCOM + META(1)%VMIN = 0 + META(1)%VMAX = 100 + ! + !---------- GROUP 5 ---------------- + ! + ! IFI=5, IFJ=1, UST + META => GROUP(5)%FIELD(1)%META + ! First component + META(1)%FSC = 0.01 + META(1)%ENAME = '.ust' + META(1)%UNITS = 'm s-1' + META(1)%VARNM='uust' + META(1)%VARNL='eastward friction velocity' + !META(1)%VARNS='eastward_friction_velocity' + META(1)%VARNS='' + META(1)%VARNG='eastward_friction_velocity' + META(1)%VARNC='ust=sqrt(uust**2+vust**2)' + META(1)%VARND=DIRCOM + META(1)%VMIN = -99.0 + META(1)%VMAX = 99.0 + + ! Second component + META(2) = META(1) + META(2)%VARNM='vust' + META(2)%VARNL='northward friction velocity' + !META(2)%VARNS='northward_friction_velocity' + META(2)%VARNS='' + META(2)%VARNG='northward_friction_velocity' + ! IFI=5, IFJ=2, CHA + META => GROUP(5)%FIELD(2)%META + META(1)%FSC = 1.E-5 + META(1)%UNITS = '1' + META(1)%ENAME = '.cha' + META(1)%VARNM='cha' + META(1)%VARNL='charnock coefficient for surface roughness length for momentum in air' + META(1)%VARNS='charnock_coefficient_for_surface_roughness_length_for_momentum_in_air' + META(1)%VARNG='charnock_coefficient' + META(1)%VMIN = 0 + META(1)%VMAX = 0.327 + ! IFI=5, IFJ=3, CGE + META => GROUP(5)%FIELD(3)%META + META(1)%FSC = 0.1 !0.01 + META(1)%UNITS = 'kW m-1' + META(1)%ENAME = '.cge' + META(1)%VARNM='cge' + META(1)%VARNL='wave energy flux' + !META(1)%VARNS='sea_surface_wind_wave_energy_flux' + META(1)%VARNS='' + META(1)%VARNG='wave_energy_flux' + META(1)%VMIN = 0 + META(1)%VMAX = 999 + ! IFI=5, IFJ=4, FAW + META => GROUP(5)%FIELD(4)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'W m-2' + META(1)%ENAME = '.faw' + META(1)%VARNM='faw' + META(1)%VARNL='wind to wave energy flux' + META(1)%VARNS='wind_mixing_energy_flux_into_sea_water' + META(1)%VARNG='wind_to_wave_energy_flux' + META(1)%VMIN = 0 + META(1)%VMAX = 999 + ! IFI=5, IFJ=5, TAW + META => GROUP(5)%FIELD(5)%META + ! First component + META(1)%FSC = 0.000001 + META(1)%UNITS = 'm2 s-2' + META(1)%ENAME = '.taw' + META(1)%VARNM='utaw' + META(1)%VARNL='eastward wave supported wind stress' + !META(1)%VARNS='eastward_wave_supported_wind_stress' + META(1)%VARNS='' + META(1)%VARNC='taw=sqrt(utaw**2+vtaw**2)' + META(1)%VARNG='eastward_wave_supported_wind_stress' + META(1)%VARND=DIRCOM + META(1)%VMIN = -0.032 + META(1)%VMAX = 0.032 + + ! Second component + META(2) = META(1) + META(2)%VARNM='vtaw' + META(2)%VARNL='northward wave supported wind stress' + !META(2)%VARNS='northward_wave_supported_wind_stress' + META(2)%VARNS='' + META(2)%VARNG='northward_wave_supported_wind_stress' + META(2)%VARNC='taw=sqrt(utaw**2+vtaw**2)' + ! IFI=5, IFJ=6, TWA + META => GROUP(5)%FIELD(6)%META + ! First component + META(1)%FSC = 0.0001 + META(1)%ENAME = '.twa' + META(1)%UNITS = 'm2 s-2' + META(1)%VARNM='utwa' + META(1)%VARNL='eastward wave to wind stress' + !META(1)%VARNS='eastward_wave_to_wind_stress' + META(1)%VARNS='' + META(1)%VARNG='eastward_wave_to_wind_stress' + META(1)%VARNC='twa=sqrt(utwa**2+vtwa**2)' + META(1)%VARND=DIRCOM + META(1)%VMIN = -3.2 + META(1)%VMAX = 3.2 + + ! Second component + META(2) = META(1) + META(2)%VARNM='vtwa' + META(2)%VARNL='northward wave to wind stress' + !META(2)%VARNS='northward_wave_to_wind_stress' + META(2)%VARNS='' + META(2)%VARNG='northward_wave_to_wind_stress' + META(2)%VARNC='twa=sqrt(utwa**2+vtwa**2)' + ! IFI=5, IFJ=7, WCC + META => GROUP(5)%FIELD(7)%META + META(1)%FSC = 0.0001 + META(1)%UNITS = '1' + META(1)%ENAME = '.wcc' + META(1)%VARNM='wcc' + META(1)%VARNL='whitecap coverage' + !META(1)%VARNS='whitecap_coverage' + META(1)%VARNS='' + META(1)%VARNG='whitecap_coverage' + META(1)%VARNC='' + META(1)%VARND='' + META(1)%VMIN = 0 + META(1)%VMAX = 1 + ! IFI=5, IFJ=8, WCF + META => GROUP(5)%FIELD(8)%META + META(1)%FSC = 0.001 + META(1)%UNITS = 'm' + META(1)%ENAME = '.wcf' + META(1)%VARNM='wcf' + META(1)%VARNL='whitecap foam thickness' + !META(1)%VARNS='whitecap_foam_thickness' + META(1)%VARNS='' + META(1)%VARNG='whitecap_foam_thickness' + META(1)%VMIN = 0 + META(1)%VMAX = 10 + ! IFI=5, IFJ=9, WCH + META => GROUP(5)%FIELD(9)%META + META(1)%FSC = 0.002 + META(1)%UNITS = 'm' + META(1)%ENAME = '.wch' + META(1)%VARNM='wch' + META(1)%VARNL='significant breaking wave height' + !META(1)%VARNS='significant_breaking_wave_height' + META(1)%VARNS='' + META(1)%VARNG='significant_breaking_wave_height' + META(1)%VMIN = 0 + META(1)%VMAX = 64 + ! IFI=5, IFJ=10, WCM + META => GROUP(5)%FIELD(10)%META + META(1)%FSC = 0.0001 + META(1)%UNITS = '1' + META(1)%ENAME = '.wcm' + META(1)%VARNM='wcm' + META(1)%VARNL='whitecap moment' + !META(1)%VARNS='whitecap_moment' + META(1)%VARNS='' + META(1)%VARNG='whitecap_moment' + META(1)%VMIN = 0 + META(1)%VMAX = 1 + ! IFI=5, IFJ=11, FWS + META => GROUP(5)%FIELD(11)%META + META(1)%FSC = 0.002 + META(1)%UNITS = 's' + META(1)%ENAME = '.fws' + META(1)%VARNM='fws' + META(1)%VARNL='Wind_sea_mean_period_T0M1' + META(1)%VARNS='sea_surface_wind_wave_mean_period_from_variance' // & + '_spectral_density_inverse_frequency_moment' + META(1)%VARNG='Wind_sea_mean_period_T0M1' + META(1)%VARNC='' + META(1)%VARND='' + META(1)%VMIN = 0 + META(1)%VMAX = 64 + ! + !---------- GROUP 6 ---------------- + ! + ! IFI=6, IFJ=1, SXY + META => GROUP(6)%FIELD(1)%META + META(1)%FSC = 10. + META(1)%UNITS = 'N m-1' + META(1)%ENAME = '.sxy' + META(1)%VARND = DIRCOM + META(1)%VMIN = -30000 + META(1)%VMAX = 30000 + + ! First component + META(1)%VARNM='sxx' + META(1)%VARNL='Radiation stress component Sxx' + !META(1)%VARNS='radiation_stress_component_sxx' + META(1)%VARNS='' + + ! S6cond component + META(2) = META(1) + META(2)%VARNM='syy' + META(2)%VARNL='Radiation stress component Syy' + !META(2)%VARNS='radiation_stress_component_syy' + META(2)%VARNS='' + + ! Third component + META(3) = META(1) + META(3)%FSC = 1. + META(3)%VARNM='sxy' + META(3)%VARNL='Radiation stress component Sxy' + !META(3)%VARNS='radiation_stress_component_sxy' + META(3)%VARNS='' + ! IFI=6, IFJ=2, TWO + META => GROUP(6)%FIELD(2)%META + META(1)%FSC = 0.000001 + META(1)%UNITS = 'm2 s-2' + META(1)%ENAME = '.two' + META(1)%VMIN = -0.032 + META(1)%VMAX = 0.032 + META(1)%VARND = DIRCOM + + ! First component + META(1)%VARNM='utwo' + META(1)%VARNL='eastward wave to ocean stress' + !META(1)%VARNS='eastward_wave_to_ocean_stress' + META(1)%VARNS='' + META(1)%VARNG='eastward_wave_to_ocean_stress' + META(1)%VARNC='two=sqrt(utwo**2+vtwo**2)' + + ! Second component + META(2) = META(1) + META(2)%VARNM='vtwo' + META(2)%VARNL='northward wave to ocean stress' + !META(2)%VARNS='northward_wave_to_ocean_stress' + META(2)%VARNS='' + META(2)%VARNG='northward_wave_to_ocean_stress' + META(2)%VARNC='two=sqrt(utwo**2+vtwo**2)' + ! IFI=6, IFJ=3, BHD + META => GROUP(6)%FIELD(3)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'm2 s-2' + META(1)%ENAME = '.bhd' + META(1)%VARNM='bhd' + META(1)%VARNL='radiation pressure (Bernouilli Head)' + !META(1)%VARNS='radiation_pressure' + META(1)%VARNS='' + META(1)%VARNG='radiation_pressure' + META(1)%VMIN = 0 + META(1)%VMAX = 100 + ! IFI=6, IFJ=4, FOC + META => GROUP(6)%FIELD(4)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'W m-2' + META(1)%ENAME = '.foc' + META(1)%VARNM='foc' + META(1)%VARNL='wave to ocean energy flux' + !META(1)%VARNS='wave_to_ocean_energy_flux' + META(1)%VARNS='' + META(1)%VARNG='wave_to_ocean_energy_flux' + META(1)%VMIN = 0 + META(1)%VMAX = 999 + ! IFI=6, IFJ=5, TUS + META => GROUP(6)%FIELD(5)%META + META(1)%FSC = 0.001 + META(1)%UNITS = 'm2 s-1' + META(1)%ENAME = '.tus' + META(1)%VARND = DIRCOM + META(1)%VMIN = -32.0 ! C Hansen: The former values of +-9.9 might be + META(1)%VMAX = 32.0 ! exceeded more frequently in real storms + + ! First component + META(1)%VARNM='utus' + META(1)%VARNL='eastward stokes transport' + !META(1)%VARNS='eastward_stokes_transport' + META(1)%VARNS='' + META(1)%VARNG='eastward_stokes_transport' + META(1)%VARNC='tus=sqrt(utus**2+vtus**2)' + + ! Second component + META(2) = META(1) + META(2)%VARNM='vtus' + META(2)%VARNL='northward stokes transport' + !META(2)%VARNS='northward_stokes_transport' + META(2)%VARNS='' + META(2)%VARNG='northward_stokes_transport' + META(2)%VARNC='tus=sqrt(utus**2+vtus**2)' + + ! IFI=6, IFJ=6, USS + META => GROUP(6)%FIELD(6)%META + META(1)%FSC = 0.0005 + META(1)%UNITS = 'm s-1' + META(1)%ENAME = '.uss' + + ! First component + META(1)%VARNM='uuss' + META(1)%VARNL='eastward surface stokes drift' + META(1)%VARNS='sea_surface_wave_stokes_drift_eastward_velocity' + META(1)%VARNG='eastward_surface_stokes_drift' + META(1)%VARNC='uss=sqrt(uuss**2+vuss**2)' + META(1)%VARND=DIRCOM + META(1)%VMIN = -4.95 + META(1)%VMAX = 4.95 + + ! Second component + META(2) = META(1) + META(2)%VARNM='vuss' + META(2)%VARNL='northward surface stokes drift' + META(2)%VARNS='sea_surface_wave_stokes_drift_northward_velocity' + META(2)%VARNG='northward_surface_stokes_drift' + WRITE(META(2)%VARNC,'(A,F8.4,A,F8.4,A)') 'Frequency range ',SIG(1)*TPIINV,' to ',SIG(NK)*TPIINV,' Hz' + ! IFI=6, IFJ=7, P2S + META => GROUP(6)%FIELD(7)%META + META(1)%FSC = 0.01 + META(1)%ENAME = '.p2s' + META(1)%UNITS = 'm4' + META(1)%VMIN = -150 + META(1)%VMAX = 320 + + ! First component + META(1)%VARNL='power spectral density of equivalent surface pressure' + !META(1)%VARNS='power_spectral_density_of_equivalent_surface_pressure' + META(1)%VARNS='' + META(1)%VARNG='power_spectral_density_of_equivalent_surface_pressure' + META(1)%VARNM='fp2s' + + ! Second component + META(2) = META(1) + META(2)%VARNM='pp2s' + META(2)%UNITS= 's-1' + META(2)%VARNL='peak period of power spectral density of equivalent surface pressure' + !META(2)%VARNS='peak_period_of_power_spectral_density_of_equivalent_surface_pressure' + META(2)%VARNS='' + META(2)%VARNG='peak_period_of_power_spectral_density_of_equivalent_surface_pressure' + + ! IFI=6, IFJ=8, USF + META => GROUP(6)%FIELD(8)%META + META(1)%UNITS = 'm s-1 Hz-1' + META(1)%FSC = 0.0005 + META(1)%ENAME = '.usf' + META(1)%VMIN = -4.95 + META(1)%VMAX = 4.95 + META(1)%VARND = DIRCOM + + ! First component + META(1)%VARNM='uusf' + META(1)%VARNL='eastward spectral variance of surface stokes drift' + !META(1)%VARNS='eastward_spectral_variance_of_surface_stokes_drift' + META(1)%VARNS='' + META(1)%VARNC='usf=sqrt(uusf**2+vusf**2)' + META(1)%VARNG='eastward_spectral_variance_of_surface_stokes_drift' + + ! Second component + META(2) = META(1) + META(2)%VARNM='vusf' + META(2)%VARNL='northward spectral variance of surface stokes drift' + !META(2)%VARNS='northward_spectral_variance_of_surface_stokes_drift' + META(2)%VARNS='' + META(2)%VARNG='northward_spectral_variance_of_surface_stokes_drift' + META(2)%VARNC='usf=sqrt(uusf**2+vusf**2)' + ! IFI=6, IFJ=9, P2L + META => GROUP(6)%FIELD(9)%META + ! Information for spectral microseismic generation data (2nd file) + META(1)%FSC = 0.0004 + META(1)%VARNM='p2l' + META(1)%VARNL='base ten logarithm of power spectral density of equivalent surface pressure' + !META(1)%VARNS='base_ten_logarithm_of_power_spectral_density_of_equivalent_surface_pressure' + META(1)%VARNS='' + META(1)%VARNG='base_ten_logarithm_of_power_spectral_density_of_equivalent_surface_pressure' + IF (NCVARTYPE.EQ.2) THEN + META(1)%UNITS='log10(Pa2 m2 s+1E-12)' + META(1)%VMIN = -12. + META(1)%VMAX = 12. + ELSE + META(1)%UNITS='Pa2 m2 s' META(1)%VARNL='power spectral density of equivalent surface pressure' !META(1)%VARNS='power_spectral_density_of_equivalent_surface_pressure' - META(1)%VARNS='' META(1)%VARNG='power_spectral_density_of_equivalent_surface_pressure' - META(1)%VARNM='fp2s' - - ! Second component - META(2) = META(1) - META(2)%VARNM='pp2s' - META(2)%UNITS= 's-1' - META(2)%VARNL='peak period of power spectral density of equivalent surface pressure' - !META(2)%VARNS='peak_period_of_power_spectral_density_of_equivalent_surface_pressure' - META(2)%VARNS='' - META(2)%VARNG='peak_period_of_power_spectral_density_of_equivalent_surface_pressure' - -! IFI=6, IFJ=8, USF - META => GROUP(6)%FIELD(8)%META - META(1)%UNITS = 'm s-1 Hz-1' - META(1)%FSC = 0.0005 - META(1)%ENAME = '.usf' - META(1)%VMIN = -4.95 - META(1)%VMAX = 4.95 - META(1)%VARND = DIRCOM - - ! First component - META(1)%VARNM='uusf' - META(1)%VARNL='eastward spectral variance of surface stokes drift' - !META(1)%VARNS='eastward_spectral_variance_of_surface_stokes_drift' - META(1)%VARNS='' - META(1)%VARNC='usf=sqrt(uusf**2+vusf**2)' - META(1)%VARNG='eastward_spectral_variance_of_surface_stokes_drift' - - ! Second component - META(2) = META(1) - META(2)%VARNM='vusf' - META(2)%VARNL='northward spectral variance of surface stokes drift' - !META(2)%VARNS='northward_spectral_variance_of_surface_stokes_drift' - META(2)%VARNS='' - META(2)%VARNG='northward_spectral_variance_of_surface_stokes_drift' - META(2)%VARNC='usf=sqrt(uusf**2+vusf**2)' -! IFI=6, IFJ=9, P2L - META => GROUP(6)%FIELD(9)%META - ! Information for spectral microseismic generation data (2nd file) - META(1)%FSC = 0.0004 - META(1)%VARNM='p2l' - META(1)%VARNL='base ten logarithm of power spectral density of equivalent surface pressure' - !META(1)%VARNS='base_ten_logarithm_of_power_spectral_density_of_equivalent_surface_pressure' - META(1)%VARNS='' - META(1)%VARNG='base_ten_logarithm_of_power_spectral_density_of_equivalent_surface_pressure' - IF (NCVARTYPE.EQ.2) THEN - META(1)%UNITS='log10(Pa2 m2 s+1E-12)' - META(1)%VMIN = -12. - META(1)%VMAX = 12. - ELSE - META(1)%UNITS='Pa2 m2 s' - META(1)%VARNL='power spectral density of equivalent surface pressure' - !META(1)%VARNS='power_spectral_density_of_equivalent_surface_pressure' - META(1)%VARNG='power_spectral_density_of_equivalent_surface_pressure' - META(1)%VMIN = 0. - META(1)%VMAX = 1.e12 - ENDIF - META(1)%VARNC='' - META(1)%VARND='' - META(1)%ENAME='.p2l' -! IFI=6, IFJ=10, TWI - META => GROUP(6)%FIELD(10)%META - META(1)%FSC = 0.000001 - META(1)%UNITS = 'm2 s-2' - META(1)%ENAME = '.tic' - META(1)%VMIN = -0.032 - META(1)%VMAX = 0.032 - META(1)%VARND = DIRCOM - - ! First component - META(1)%VARNL='eastward wave to sea ice stress' - META(1)%VARNM='utic' - !META(1)%VARNS='eastward_wave_to_sea_ice_stress' - META(1)%VARNS='' - META(1)%VARNG='eastward_wave_to_sea_ice_stress' - META(1)%VARNC='two=sqrt(utwo**2+vtwo**2)' - ! Second component - META(2) = META(1) - META(2)%VARNM='vtic' - META(2)%VARNL='northward wave to sea ice stress' - !META(2)%VARNS='northward_wave_to_sea_ice_stress' - META(2)%VARNS='' - META(2)%VARNG='northward_wave_to_sea_ice_stress' - META(2)%VARNC='two=sqrt(utwo**2+vtwo**2)' -! IFI=6, IFJ=11, FIC - META => GROUP(6)%FIELD(11)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'W m-2' - META(1)%ENAME = '.fic' - META(1)%VARNM='fic' - META(1)%VARNL='wave to sea ice energy flux' - !META(1)%VARNS='wave_to_sea_ice_energy_flux' - META(1)%VARNS='' - META(1)%VARNG='wave_to_sea_ice_energy_flux' - META(1)%VMIN = 0 - META(1)%VMAX = 999 -! IFI=6, IFJ=12, USP - META => GROUP(6)%FIELD(12)%META - META(1)%UNITS = 'm s-1' - META(1)%FSC = 0.0005 - META(1)%ENAME = '.usp' - META(1)%VARND = DIRCOM - META(1)%VMIN = -9.99 - META(1)%VMAX = 9.98 - - ! First component - META(1)%VARNM='ussp' - META(1)%VARNL='eastward partitioned surface stokes drift' - !META(1)%VARNS='eastward_partitioned_surface_stokes_drift' - META(1)%VARNS='' - META(1)%VARNG='eastward_partitioned_surface_stokes_drift' - META(1)%VARNC='usp=sqrt(ussp**2+vssp**2)' - - ! Second component - META(2) = META(1) - META(2)%VARNM='vssp' - META(2)%VARNL='northward partitioned surface stokes drift' - !META(2)%VARNS='northward_partitioned_surface_stokes_drift' - META(2)%VARNS='' - META(2)%VARNG='northward_partitioned_surface_stokes_drift' - META(2)%VARNC='usp=sqrt(ussp**2+vssp**2)' -! IFI=6, IFJ=13 - META => GROUP(6)%FIELD(13)%META - META(1)%UNITS = 'Pa' - META(1)%FSC = 0.01 - META(1)%ENAME = '.toc' - META(1)%VMIN = -320 - META(1)%VMAX = 320 - META(1)%VARND = DIRCOM - - ! First component - META(1)%VARNM='utoc' - META(1)%VARNL='eastward total wave to ocean stres' - META(1)%VARNS='' - META(1)%VARNG='' - META(1)%VARNC='toc=sqrt(utoc**2+vtoc**2)' - - ! Second component - META(2) = META(1) - META(2)%VARNM='vtoc' - META(2)%VARNL='northward total wave to ocean stres' - META(2)%VARNS='' - META(2)%VARNG='' - META(2)%VARNC='toc=sqrt(utoc**2+vtoc**2)' -! -!---------- GROUP 7 ---------------- -! -! IFI=7, IFJ=1, ABR - META => GROUP(7)%FIELD(1)%META - META(1)%FSC = 0.01 - META(1)%ENAME = '.abr' - META(1)%UNITS = 'm' - META(1)%VMIN = -180 - META(1)%VMAX = 180 - META(1)%VARND = DIRCOM - - ! First component - META(1)%VARNM='uabr' - META(1)%VARNL='rms of bottom displacement amplitude zonal' - !META(1)%VARNS='rms_of_bottom_displacement_amplitude_zonal' - META(1)%VARNS='' - META(1)%VARNG='rms_of_bottom_displacement_amplitude_zonal' - META(1)%VARNC='abr=sqrt(uabr**2+vabr**2)' - - ! Second component - META(2) = META(1) - META(2)%VARNM='vabr' - META(2)%VARNL='rms of bottom displacement amplitude meridional' - !META(2)%VARNS='rms_of_bottom_displacement_amplitude_meridional' - META(2)%VARNS='' - META(2)%VARNG='rms_of_bottom_displacement_amplitude_meridional' - META(2)%VARNC='abr=sqrt(uabr**2+vabr**2)' -! IFI=7, IFJ=2, UBR - META => GROUP(7)%FIELD(2)%META - META(1)%FSC = 0.01 - META(1)%ENAME = '.ubr' - META(1)%UNITS = 'm s-1' - META(1)%VMIN = -180 - META(1)%VMAX = 180 - META(1)%VARND = DIRCOM - - ! First component - META(1)%VARNM='uubr' - META(1)%VARNL='rms of bottom velocity amplitude zonal' - !META(1)%VARNS='rms_of_bottom_velocity_amplitude_zonal' - META(1)%VARNS='' - META(1)%VARNG='rms_of_bottom_velocity_amplitude_zonal' - META(1)%VARNC='ubr=sqrt(uubr**2+vubr**2)' - - ! Second component - META(2) = META(1) - META(2)%VARNM='vubr' - META(2)%VARNL='rms of bottom velocity amplitude meridional' - !META(2)%VARNS='rms_of_bottom_velocity_amplitude_meridional' - META(2)%VARNS='' - META(2)%VARNG='rms_of_bottom_velocity_amplitude_meridional' -! IFI=7, IFJ=3, BED - META => GROUP(7)%FIELD(3)%META - META(1)%FSC = 0.001 - META(1)%UNITS = 'm' - META(1)%ENAME = '.bed' - META(1)%VMIN = 0 - META(1)%VMAX = 30 - META(1)%VARND = DIRCOM - - ! First component - META(1)%VARNM='bed' - META(1)%VARNL='bottom roughness' - !META(1)%VARNS='sea bottom roughness length' - META(1)%VARNS='' - META(1)%VARNG='ripple_wavelength' - META(1)%VARNC='ripple_length=sqrt(ripplex**2+rippley**2)' - - ! Second component - META(2) = META(1) - META(2)%VARNM='ripplex' - META(2)%VARNL='eastward sea bottom ripple wavelength' - !META(2)%VARNS='eastward_ripple_wavelength' - META(2)%VARNS='' - META(2)%VARNG='eastward_ripple_wavelength' - META(2)%VARNC='ripple_length=sqrt(ripplex**2+rippley**2)' - - ! Third component - META(3) = META(1) - META(3)%VARNM='rippley' - META(3)%VARNL='northward sea bottom ripple wavelength' - !META(3)%VARNS='northward_ripple_wavelength' - META(3)%VARNS='' - META(3)%VARNG='northward_ripple_wavelength' - META(3)%VARNC='ripple_length=sqrt(ripplex**2+rippley**2)' -! IFI=7, IFJ=4, FBB - META => GROUP(7)%FIELD(4)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'W m-2' - META(1)%ENAME = '.fbb' - META(1)%VARNM='fbb' - META(1)%VARNL='wave dissipation in bbl' - !META(1)%VARNS='wave_energy_dissipation_in_bottom_boundary_layer' - META(1)%VARNS='' - META(1)%VARNG='wave_dissipation_in_bbl' - META(1)%VMIN = 0 - META(1)%VMAX = 999 -! IFI=7, IFJ=5, TBB - META => GROUP(7)%FIELD(5)%META - META(1)%FSC = 0.000001 - META(1)%UNITS = 'm2 s-2' - META(1)%ENAME = '.tbb' - META(1)%VMIN = -0.032 - META(1)%VMAX = 0.032 - META(1)%VARND = DIRCOM - - ! First component - META(1)%VARNM='utbb' - META(1)%VARNL='eastward wave to bbl stress' - !META(1)%VARNS='eastward_wave_to_bottom_boundary_layer_stress' - META(1)%VARNS='' - META(1)%VARNG='eastward_wave_to_bbl_stress' - META(1)%VARNC='tbb=sqrt(utbb**2+vtbb**2)' - - ! Second component - META(2) = META(1) - META(2)%VARNM='vtbb' - META(2)%VARNL='northward wave to bbl stress' - !META(2)%VARNS='northward_wave_to_bottom_boundary_layer_stress' - META(2)%VARNS='' - META(2)%VARNG='northward_wave_to_bbl_stress' - META(2)%VARNC='tbb=sqrt(utbb**2+vtbb**2)' -! -!---------- GROUP 8 ---------------- -! IFI=8, IFJ=1, MSS - META => GROUP(8)%FIELD(1)%META - META(1)%FSC = 0.00001 - META(1)%ENAME = '.mss' - META(1)%UNITS = '1' - META(1)%VMIN = 0 - META(1)%VMAX = 0.3 - META(1)%VARND = DIRCOM - WRITE(META(1)%VARNC,'(A,F8.4,A,F8.4,A)') 'Frequency range ',SIG(1)*TPIINV,' to ',SIG(NK)*TPIINV,' Hz' - - ! First component - META(1)%VARNM='mssu' - META(1)%VARNL='downwave mean square slope' - META(1)%VARNS='sea_surface_wave_mean_square_upwave_slope' - META(1)%VARNG='x_mean_square_slope' - META(1)%VARNC='mss=mssu+mssc' - - ! Second component - META(2) = META(1) - META(2)%VARNM='mssc' - META(2)%VARNL='crosswave mean square slope' - META(2)%VARNS='sea_surface_wave_mean_square_crosswave_slope' - META(2)%VARNG='y_mean_square_slope' -! IFI=8, IFJ=2, MSC - META => GROUP(8)%FIELD(2)%META - META(1)%FSC = 1E-7 - META(1)%ENAME = '.msc' - META(1)%UNITS = '1' - META(1)%VMIN = 0 - META(1)%VMAX = 0.003 - META(1)%VARND = DIRCOM - - ! First component - META(1)%VARNM='mscx' - META(1)%VARNL='eastward phillips constant' - !META(1)%VARNS='eastward_phillips_constant' - META(1)%VARNS='' - META(1)%VARNG='eastward_phillips_constant' - META(1)%VARNC='msc=mscx+mscy' - - ! Second component - META(2) = META(1) - META(2)%VARNM='mscy' - META(2)%VARNL='northward phillips constant' - !META(2)%VARNS='northward_phillips_constant' - META(2)%VARNS='' - META(2)%VARNG='northward_phillips_constant' - META(2)%VARNC='msc=mscx+mscy' -! IFI=8, IFJ=3, MSD - META => GROUP(8)%FIELD(3)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'degree' - META(1)%ENAME = '.msd' - META(1)%VARNM='mssd' - META(1)%VARNL='u direction for mss' - META(1)%VARNS='sea_surface_mean_square_upwave_slope_direction' - META(1)%VARNG='sea_surface_wave_dominant_mean_square_slope_direction' - WRITE(META(1)%VARNC,'(A,F8.4,A,F8.4,A)') 'Frequency range ',SIG(1)*TPIINV,' to ',SIG(NK)*TPIINV,' Hz' - META(1)%VARND = DIRCOM - META(1)%VMIN = 0 - META(1)%VMAX = 360 -! IFI=8, IFJ=4, MCD - META => GROUP(8)%FIELD(4)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'degree' - META(1)%ENAME = '.mcd' - META(1)%VARNM='mscd' - META(1)%VARNL='x direction for msc' - !META(1)%VARNS='sea_surface_wave_dominant_mean_square_slope_direction_in_highest_frequency' - META(1)%VARNS='' - META(1)%VARNG='sea_surface_wave_dominant_mean_square_slope_direction_in_highest_frequency' - META(1)%VARND = DIRCOM - META(1)%VMIN = 0 - META(1)%VMAX = 360 -! IFI=8, IFJ=5, QP - META => GROUP(8)%FIELD(5)%META - META(1)%FSC = 0.001 - META(1)%UNITS = '1' - META(1)%ENAME = '.qp' - META(1)%VARNM='qp' - META(1)%VARNL='peakedness' - !META(1)%VARNS='sea_surface_wave_peakedness' - META(1)%VARNS='' - META(1)%VARNG='wave_peakedness' - META(1)%VARNC='Goda wave peakedness parameter' - META(1)%VMIN = 0 - META(1)%VMAX = 32 -! -!---------- GROUP 9 ---------------- -! -! IFI=9, IFJ=1, DTD - META => GROUP(9)%FIELD(1)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'min.' - META(1)%ENAME = '.dtd' - META(1)%VARNM='dtd' - META(1)%VARNL='dynamic time step' - !META(1)%VARNS='dynamic_time_step' - META(1)%VARNS='' - META(1)%VARNG='dynamic_time_step' - META(1)%VMIN = 0 - META(1)%VMAX = 3200 -! IFI=9, IFJ=2, FC - META => GROUP(9)%FIELD(2)%META - META(1)%FSC = 0.001 - META(1)%UNITS = 's-1' - META(1)%ENAME = '.fc' - META(1)%VARNM='fc' - META(1)%VARNL='cut off frequency' - !META(1)%VARNS='cut_off_frequency' - META(1)%VARNS='' - META(1)%VARNG='cut_off_frequency' - META(1)%VMIN = 0 - META(1)%VMAX = 8 -! IFI=9, IFJ=3, CFX - META => GROUP(9)%FIELD(3)%META - META(1)%FSC = 0.01 - META(1)%UNITS = '1' - META(1)%ENAME = '.cfx' - META(1)%VARNM='cfx' - META(1)%VARNL='maximum cfl for spatial advection' - !META(1)%VARNS='maximum_cfl_for_spatial_advection' - META(1)%VARNS='' - META(1)%VARNG='maximum_cfl_for_spatial_advection' - META(1)%VMIN = 0 - META(1)%VMAX = 320 -! IFI=9, IFJ=4, CFD - META => GROUP(9)%FIELD(4)%META - META(1)%FSC = 0.01 - META(1)%UNITS = '1' - META(1)%ENAME = '.cfd' - META(1)%VARNM='cfd' - META(1)%VARNL='maximum cfl for direction advection' - !META(1)%VARNS='maximum_cfl_for_direction_advection' - META(1)%VARNS='' - META(1)%VARNG='maximum_cfl_for_direction_advection' - META(1)%VMIN = 0 - META(1)%VMAX = 320 -! IFI=9, IFJ=5, CFK - META => GROUP(9)%FIELD(5)%META - META(1)%FSC = 0.01 - META(1)%UNITS = '1' - META(1)%ENAME = '.cfk' - META(1)%VARNM='cfk' - META(1)%VARNL='maximum cfl for frequency advection' - !META(1)%VARNS='maximum_cfl_for_frequency_advection' - META(1)%VARNS='' - META(1)%VARNG='maximum_cfl_for_frequency_advection' - META(1)%VMIN = 0 - META(1)%VMAX = 320 -! -! ------ Group 10 (User defined) ------- -! -! IFI=10, IFJ=1 - META => GROUP(10)%FIELD(1)%META - META(1)%FSC = 0.1 - META(1)%UNITS = 'm' - META(1)%VMIN = 0 - META(1)%VMAX = 0 - WRITE (META(1)%ENAME,'(A2,I2.2)') '.u' - WRITE (META(1)%VARNM,'(A1,I2.2)') 'u' - WRITE (META(1)%VARNL,'(A12,I2.2)') 'User_defined' - WRITE (META(1)%VARNS,'(A12,I2.2)') 'User_defined' - WRITE (META(1)%VARNG,'(A12,I2.2)') 'user_defined' -! - END SUBROUTINE DEFAULT_META -!/ ------------------------------------------------------------------- / - - END MODULE W3OUNFMETAMD + META(1)%VMIN = 0. + META(1)%VMAX = 1.e12 + ENDIF + META(1)%VARNC='' + META(1)%VARND='' + META(1)%ENAME='.p2l' + ! IFI=6, IFJ=10, TWI + META => GROUP(6)%FIELD(10)%META + META(1)%FSC = 0.000001 + META(1)%UNITS = 'm2 s-2' + META(1)%ENAME = '.tic' + META(1)%VMIN = -0.032 + META(1)%VMAX = 0.032 + META(1)%VARND = DIRCOM + + ! First component + META(1)%VARNL='eastward wave to sea ice stress' + META(1)%VARNM='utic' + !META(1)%VARNS='eastward_wave_to_sea_ice_stress' + META(1)%VARNS='' + META(1)%VARNG='eastward_wave_to_sea_ice_stress' + META(1)%VARNC='two=sqrt(utwo**2+vtwo**2)' + ! Second component + META(2) = META(1) + META(2)%VARNM='vtic' + META(2)%VARNL='northward wave to sea ice stress' + !META(2)%VARNS='northward_wave_to_sea_ice_stress' + META(2)%VARNS='' + META(2)%VARNG='northward_wave_to_sea_ice_stress' + META(2)%VARNC='two=sqrt(utwo**2+vtwo**2)' + ! IFI=6, IFJ=11, FIC + META => GROUP(6)%FIELD(11)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'W m-2' + META(1)%ENAME = '.fic' + META(1)%VARNM='fic' + META(1)%VARNL='wave to sea ice energy flux' + !META(1)%VARNS='wave_to_sea_ice_energy_flux' + META(1)%VARNS='' + META(1)%VARNG='wave_to_sea_ice_energy_flux' + META(1)%VMIN = 0 + META(1)%VMAX = 999 + ! IFI=6, IFJ=12, USP + META => GROUP(6)%FIELD(12)%META + META(1)%UNITS = 'm s-1' + META(1)%FSC = 0.0005 + META(1)%ENAME = '.usp' + META(1)%VARND = DIRCOM + META(1)%VMIN = -9.99 + META(1)%VMAX = 9.98 + + ! First component + META(1)%VARNM='ussp' + META(1)%VARNL='eastward partitioned surface stokes drift' + !META(1)%VARNS='eastward_partitioned_surface_stokes_drift' + META(1)%VARNS='' + META(1)%VARNG='eastward_partitioned_surface_stokes_drift' + META(1)%VARNC='usp=sqrt(ussp**2+vssp**2)' + + ! Second component + META(2) = META(1) + META(2)%VARNM='vssp' + META(2)%VARNL='northward partitioned surface stokes drift' + !META(2)%VARNS='northward_partitioned_surface_stokes_drift' + META(2)%VARNS='' + META(2)%VARNG='northward_partitioned_surface_stokes_drift' + META(2)%VARNC='usp=sqrt(ussp**2+vssp**2)' + ! IFI=6, IFJ=13 + META => GROUP(6)%FIELD(13)%META + META(1)%UNITS = 'Pa' + META(1)%FSC = 0.01 + META(1)%ENAME = '.toc' + META(1)%VMIN = -320 + META(1)%VMAX = 320 + META(1)%VARND = DIRCOM + + ! First component + META(1)%VARNM='utoc' + META(1)%VARNL='eastward total wave to ocean stres' + META(1)%VARNS='' + META(1)%VARNG='' + META(1)%VARNC='toc=sqrt(utoc**2+vtoc**2)' + + ! Second component + META(2) = META(1) + META(2)%VARNM='vtoc' + META(2)%VARNL='northward total wave to ocean stres' + META(2)%VARNS='' + META(2)%VARNG='' + META(2)%VARNC='toc=sqrt(utoc**2+vtoc**2)' + ! + !---------- GROUP 7 ---------------- + ! + ! IFI=7, IFJ=1, ABR + META => GROUP(7)%FIELD(1)%META + META(1)%FSC = 0.01 + META(1)%ENAME = '.abr' + META(1)%UNITS = 'm' + META(1)%VMIN = -180 + META(1)%VMAX = 180 + META(1)%VARND = DIRCOM + + ! First component + META(1)%VARNM='uabr' + META(1)%VARNL='rms of bottom displacement amplitude zonal' + !META(1)%VARNS='rms_of_bottom_displacement_amplitude_zonal' + META(1)%VARNS='' + META(1)%VARNG='rms_of_bottom_displacement_amplitude_zonal' + META(1)%VARNC='abr=sqrt(uabr**2+vabr**2)' + + ! Second component + META(2) = META(1) + META(2)%VARNM='vabr' + META(2)%VARNL='rms of bottom displacement amplitude meridional' + !META(2)%VARNS='rms_of_bottom_displacement_amplitude_meridional' + META(2)%VARNS='' + META(2)%VARNG='rms_of_bottom_displacement_amplitude_meridional' + META(2)%VARNC='abr=sqrt(uabr**2+vabr**2)' + ! IFI=7, IFJ=2, UBR + META => GROUP(7)%FIELD(2)%META + META(1)%FSC = 0.01 + META(1)%ENAME = '.ubr' + META(1)%UNITS = 'm s-1' + META(1)%VMIN = -180 + META(1)%VMAX = 180 + META(1)%VARND = DIRCOM + + ! First component + META(1)%VARNM='uubr' + META(1)%VARNL='rms of bottom velocity amplitude zonal' + !META(1)%VARNS='rms_of_bottom_velocity_amplitude_zonal' + META(1)%VARNS='' + META(1)%VARNG='rms_of_bottom_velocity_amplitude_zonal' + META(1)%VARNC='ubr=sqrt(uubr**2+vubr**2)' + + ! Second component + META(2) = META(1) + META(2)%VARNM='vubr' + META(2)%VARNL='rms of bottom velocity amplitude meridional' + !META(2)%VARNS='rms_of_bottom_velocity_amplitude_meridional' + META(2)%VARNS='' + META(2)%VARNG='rms_of_bottom_velocity_amplitude_meridional' + ! IFI=7, IFJ=3, BED + META => GROUP(7)%FIELD(3)%META + META(1)%FSC = 0.001 + META(1)%UNITS = 'm' + META(1)%ENAME = '.bed' + META(1)%VMIN = 0 + META(1)%VMAX = 30 + META(1)%VARND = DIRCOM + + ! First component + META(1)%VARNM='bed' + META(1)%VARNL='bottom roughness' + !META(1)%VARNS='sea bottom roughness length' + META(1)%VARNS='' + META(1)%VARNG='ripple_wavelength' + META(1)%VARNC='ripple_length=sqrt(ripplex**2+rippley**2)' + + ! Second component + META(2) = META(1) + META(2)%VARNM='ripplex' + META(2)%VARNL='eastward sea bottom ripple wavelength' + !META(2)%VARNS='eastward_ripple_wavelength' + META(2)%VARNS='' + META(2)%VARNG='eastward_ripple_wavelength' + META(2)%VARNC='ripple_length=sqrt(ripplex**2+rippley**2)' + + ! Third component + META(3) = META(1) + META(3)%VARNM='rippley' + META(3)%VARNL='northward sea bottom ripple wavelength' + !META(3)%VARNS='northward_ripple_wavelength' + META(3)%VARNS='' + META(3)%VARNG='northward_ripple_wavelength' + META(3)%VARNC='ripple_length=sqrt(ripplex**2+rippley**2)' + ! IFI=7, IFJ=4, FBB + META => GROUP(7)%FIELD(4)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'W m-2' + META(1)%ENAME = '.fbb' + META(1)%VARNM='fbb' + META(1)%VARNL='wave dissipation in bbl' + !META(1)%VARNS='wave_energy_dissipation_in_bottom_boundary_layer' + META(1)%VARNS='' + META(1)%VARNG='wave_dissipation_in_bbl' + META(1)%VMIN = 0 + META(1)%VMAX = 999 + ! IFI=7, IFJ=5, TBB + META => GROUP(7)%FIELD(5)%META + META(1)%FSC = 0.000001 + META(1)%UNITS = 'm2 s-2' + META(1)%ENAME = '.tbb' + META(1)%VMIN = -0.032 + META(1)%VMAX = 0.032 + META(1)%VARND = DIRCOM + + ! First component + META(1)%VARNM='utbb' + META(1)%VARNL='eastward wave to bbl stress' + !META(1)%VARNS='eastward_wave_to_bottom_boundary_layer_stress' + META(1)%VARNS='' + META(1)%VARNG='eastward_wave_to_bbl_stress' + META(1)%VARNC='tbb=sqrt(utbb**2+vtbb**2)' + + ! Second component + META(2) = META(1) + META(2)%VARNM='vtbb' + META(2)%VARNL='northward wave to bbl stress' + !META(2)%VARNS='northward_wave_to_bottom_boundary_layer_stress' + META(2)%VARNS='' + META(2)%VARNG='northward_wave_to_bbl_stress' + META(2)%VARNC='tbb=sqrt(utbb**2+vtbb**2)' + ! + !---------- GROUP 8 ---------------- + ! IFI=8, IFJ=1, MSS + META => GROUP(8)%FIELD(1)%META + META(1)%FSC = 0.00001 + META(1)%ENAME = '.mss' + META(1)%UNITS = '1' + META(1)%VMIN = 0 + META(1)%VMAX = 0.3 + META(1)%VARND = DIRCOM + WRITE(META(1)%VARNC,'(A,F8.4,A,F8.4,A)') 'Frequency range ',SIG(1)*TPIINV,' to ',SIG(NK)*TPIINV,' Hz' + + ! First component + META(1)%VARNM='mssu' + META(1)%VARNL='downwave mean square slope' + META(1)%VARNS='sea_surface_wave_mean_square_upwave_slope' + META(1)%VARNG='x_mean_square_slope' + META(1)%VARNC='mss=mssu+mssc' + + ! Second component + META(2) = META(1) + META(2)%VARNM='mssc' + META(2)%VARNL='crosswave mean square slope' + META(2)%VARNS='sea_surface_wave_mean_square_crosswave_slope' + META(2)%VARNG='y_mean_square_slope' + ! IFI=8, IFJ=2, MSC + META => GROUP(8)%FIELD(2)%META + META(1)%FSC = 1E-7 + META(1)%ENAME = '.msc' + META(1)%UNITS = '1' + META(1)%VMIN = 0 + META(1)%VMAX = 0.003 + META(1)%VARND = DIRCOM + + ! First component + META(1)%VARNM='mscx' + META(1)%VARNL='eastward phillips constant' + !META(1)%VARNS='eastward_phillips_constant' + META(1)%VARNS='' + META(1)%VARNG='eastward_phillips_constant' + META(1)%VARNC='msc=mscx+mscy' + + ! Second component + META(2) = META(1) + META(2)%VARNM='mscy' + META(2)%VARNL='northward phillips constant' + !META(2)%VARNS='northward_phillips_constant' + META(2)%VARNS='' + META(2)%VARNG='northward_phillips_constant' + META(2)%VARNC='msc=mscx+mscy' + ! IFI=8, IFJ=3, MSD + META => GROUP(8)%FIELD(3)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'degree' + META(1)%ENAME = '.msd' + META(1)%VARNM='mssd' + META(1)%VARNL='u direction for mss' + META(1)%VARNS='sea_surface_mean_square_upwave_slope_direction' + META(1)%VARNG='sea_surface_wave_dominant_mean_square_slope_direction' + WRITE(META(1)%VARNC,'(A,F8.4,A,F8.4,A)') 'Frequency range ',SIG(1)*TPIINV,' to ',SIG(NK)*TPIINV,' Hz' + META(1)%VARND = DIRCOM + META(1)%VMIN = 0 + META(1)%VMAX = 360 + ! IFI=8, IFJ=4, MCD + META => GROUP(8)%FIELD(4)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'degree' + META(1)%ENAME = '.mcd' + META(1)%VARNM='mscd' + META(1)%VARNL='x direction for msc' + !META(1)%VARNS='sea_surface_wave_dominant_mean_square_slope_direction_in_highest_frequency' + META(1)%VARNS='' + META(1)%VARNG='sea_surface_wave_dominant_mean_square_slope_direction_in_highest_frequency' + META(1)%VARND = DIRCOM + META(1)%VMIN = 0 + META(1)%VMAX = 360 + ! IFI=8, IFJ=5, QP + META => GROUP(8)%FIELD(5)%META + META(1)%FSC = 0.001 + META(1)%UNITS = '1' + META(1)%ENAME = '.qp' + META(1)%VARNM='qp' + META(1)%VARNL='peakedness' + !META(1)%VARNS='sea_surface_wave_peakedness' + META(1)%VARNS='' + META(1)%VARNG='wave_peakedness' + META(1)%VARNC='Goda wave peakedness parameter' + META(1)%VMIN = 0 + META(1)%VMAX = 32 + ! + !---------- GROUP 9 ---------------- + ! + ! IFI=9, IFJ=1, DTD + META => GROUP(9)%FIELD(1)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'min.' + META(1)%ENAME = '.dtd' + META(1)%VARNM='dtd' + META(1)%VARNL='dynamic time step' + !META(1)%VARNS='dynamic_time_step' + META(1)%VARNS='' + META(1)%VARNG='dynamic_time_step' + META(1)%VMIN = 0 + META(1)%VMAX = 3200 + ! IFI=9, IFJ=2, FC + META => GROUP(9)%FIELD(2)%META + META(1)%FSC = 0.001 + META(1)%UNITS = 's-1' + META(1)%ENAME = '.fc' + META(1)%VARNM='fc' + META(1)%VARNL='cut off frequency' + !META(1)%VARNS='cut_off_frequency' + META(1)%VARNS='' + META(1)%VARNG='cut_off_frequency' + META(1)%VMIN = 0 + META(1)%VMAX = 8 + ! IFI=9, IFJ=3, CFX + META => GROUP(9)%FIELD(3)%META + META(1)%FSC = 0.01 + META(1)%UNITS = '1' + META(1)%ENAME = '.cfx' + META(1)%VARNM='cfx' + META(1)%VARNL='maximum cfl for spatial advection' + !META(1)%VARNS='maximum_cfl_for_spatial_advection' + META(1)%VARNS='' + META(1)%VARNG='maximum_cfl_for_spatial_advection' + META(1)%VMIN = 0 + META(1)%VMAX = 320 + ! IFI=9, IFJ=4, CFD + META => GROUP(9)%FIELD(4)%META + META(1)%FSC = 0.01 + META(1)%UNITS = '1' + META(1)%ENAME = '.cfd' + META(1)%VARNM='cfd' + META(1)%VARNL='maximum cfl for direction advection' + !META(1)%VARNS='maximum_cfl_for_direction_advection' + META(1)%VARNS='' + META(1)%VARNG='maximum_cfl_for_direction_advection' + META(1)%VMIN = 0 + META(1)%VMAX = 320 + ! IFI=9, IFJ=5, CFK + META => GROUP(9)%FIELD(5)%META + META(1)%FSC = 0.01 + META(1)%UNITS = '1' + META(1)%ENAME = '.cfk' + META(1)%VARNM='cfk' + META(1)%VARNL='maximum cfl for frequency advection' + !META(1)%VARNS='maximum_cfl_for_frequency_advection' + META(1)%VARNS='' + META(1)%VARNG='maximum_cfl_for_frequency_advection' + META(1)%VMIN = 0 + META(1)%VMAX = 320 + ! + ! ------ Group 10 (User defined) ------- + ! + ! IFI=10, IFJ=1 + META => GROUP(10)%FIELD(1)%META + META(1)%FSC = 0.1 + META(1)%UNITS = 'm' + META(1)%VMIN = 0 + META(1)%VMAX = 0 + WRITE (META(1)%ENAME,'(A2,I2.2)') '.u' + WRITE (META(1)%VARNM,'(A1,I2.2)') 'u' + WRITE (META(1)%VARNL,'(A12,I2.2)') 'User_defined' + WRITE (META(1)%VARNS,'(A12,I2.2)') 'User_defined' + WRITE (META(1)%VARNG,'(A12,I2.2)') 'user_defined' + ! + END SUBROUTINE DEFAULT_META + !/ ------------------------------------------------------------------- / + +END MODULE W3OUNFMETAMD diff --git a/model/src/w3parall.F90 b/model/src/w3parall.F90 index 4ea781601..789f807c5 100644 --- a/model/src/w3parall.F90 +++ b/model/src/w3parall.F90 @@ -1,1228 +1,1228 @@ - MODULE W3PARALL -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Parallel routines for implicit solver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +MODULE W3PARALL + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Parallel routines for implicit solver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3SERVMD, ONLY: STRACE +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! + ! #ifdef W3_PDLIB - INTEGER :: PDLIB_NSEAL, PDLIB_NSEALM - INTEGER, ALLOCATABLE :: JX_TO_JSEA(:), ISEA_TO_JSEA(:) + INTEGER :: PDLIB_NSEAL, PDLIB_NSEALM + INTEGER, ALLOCATABLE :: JX_TO_JSEA(:), ISEA_TO_JSEA(:) #endif - INTEGER, ALLOCATABLE :: ListISPnextDir(:), ListISPprevDir(:) - INTEGER, ALLOCATABLE :: ListISPnextFreq(:), ListISPprevFreq(:) + INTEGER, ALLOCATABLE :: ListISPnextDir(:), ListISPprevDir(:) + INTEGER, ALLOCATABLE :: ListISPnextFreq(:), ListISPprevFreq(:) - LOGICAL, PARAMETER :: LSLOC = .true. - INTEGER, PARAMETER :: IMEM = 1 + LOGICAL, PARAMETER :: LSLOC = .true. + INTEGER, PARAMETER :: IMEM = 1 - REAL, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 - REAL, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 - REAL, PARAMETER :: ZERO = 0.0d0 + REAL, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 + REAL, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 + REAL, PARAMETER :: ZERO = 0.0d0 - REAL*8, PARAMETER :: THR8 = TINY(1.d0) - REAL, PARAMETER :: THR = TINY(1.0) - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE WAV_MY_WTIME(eTime) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + REAL*8, PARAMETER :: THR8 = TINY(1.d0) + REAL, PARAMETER :: THR = TINY(1.0) +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE WAV_MY_WTIME(eTime) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - IMPLICIT NONE + USE W3SERVMD, ONLY: STRACE +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + IMPLICIT NONE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER mpimode - REAL(8), intent(out) :: eTime + INTEGER mpimode + REAL(8), intent(out) :: eTime #ifdef W3_MPI - REAL(8) mpi_wtime + REAL(8) mpi_wtime #endif - mpimode=0 + mpimode=0 #ifdef W3_MPI - mpimode=1 - eTime=mpi_wtime() + mpimode=1 + eTime=mpi_wtime() #endif #ifdef W3_S - CALL STRACE (IENT, 'WAV_MY_WTIME') -#endif - IF (mpimode .eq. 0) THEN - CALL CPU_TIME(eTime) - END IF -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ + CALL STRACE (IENT, 'WAV_MY_WTIME') +#endif + IF (mpimode .eq. 0) THEN + CALL CPU_TIME(eTime) + END IF + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ END SUBROUTINE WAV_MY_WTIME -!/ ------------------------------------------------------------------- / - SUBROUTINE PRINT_MY_TIME(string) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Print timings -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE PRINT_MY_TIME(string) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Print timings + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3ODATMD, ONLY : IAPROC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3SERVMD, ONLY: STRACE +#endif + USE W3ODATMD, ONLY : IAPROC + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -! - character(*), intent(in) :: string - REAL(8) :: eTime + !/ + !/ ------------------------------------------------------------------- / + ! + character(*), intent(in) :: string + REAL(8) :: eTime #ifdef W3_S - CALL STRACE (IENT, 'PRINT_MY_TIME') + CALL STRACE (IENT, 'PRINT_MY_TIME') #endif - CALL WAV_MY_WTIME(eTime) - WRITE(740+IAPROC,*) 'TIMING time=', eTime, ' at step ', string -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ + CALL WAV_MY_WTIME(eTime) + WRITE(740+IAPROC,*) 'TIMING time=', eTime, ' at step ', string + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ END SUBROUTINE PRINT_MY_TIME -!/ ------------------------------------------------------------------- / - SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute refraction part in matrix -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute refraction part in matrix + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & - CTMAX, DMIN, DTH, CTHG0S, MAPSF - USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, DDDX, & - DDDY, DW + USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & + EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & + CTMAX, DMIN, DTH, CTHG0S, MAPSF + USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, DDDX, & + DDDY, DW #ifdef W3_REFRX - USE W3ADATMD, ONLY: DCDX, DCDY -#endif - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, only : IAPROC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3ADATMD, ONLY: DCDX, DCDY +#endif + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, only : IAPROC + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -!/ - REAL, intent(out) :: CAD(NSPEC) - INTEGER, intent(in) :: ISEA - REAL, intent(in) :: DTG - INTEGER :: ISP, IK, ITH, IX, IY - REAL :: FRK(NK), FRG(NK), DSDD(0:NK+1) - REAL :: FACTH, DCXY, DCYX, DCXXYY, DTTST - REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0 - REAL :: VCFLT(NSPEC), DEPTH, FDG - REAL :: FDDMAX + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + !/ + REAL, intent(out) :: CAD(NSPEC) + INTEGER, intent(in) :: ISEA + REAL, intent(in) :: DTG + INTEGER :: ISP, IK, ITH, IX, IY + REAL :: FRK(NK), FRG(NK), DSDD(0:NK+1) + REAL :: FACTH, DCXY, DCYX, DCXXYY, DTTST + REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0 + REAL :: VCFLT(NSPEC), DEPTH, FDG + REAL :: FDDMAX #ifdef W3_S - CALL STRACE (IENT, 'PROP_REFRACTION_PR1') -#endif - IX=MAPSF(ISEA,1) - IY=MAPSF(ISEA,2) - eDDDX=DDDX(IY,IX) - eDDDY=DDDY(IY,IX) - eCTHG0 = CTHG0S(ISEA) - FACTH = DTG / DTH - ! - FDG = FACTH * eCTHG0 - DEPTH = MAX ( DMIN , DW(ISEA) ) - DO IK=0, NK+1 - IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN - DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH - ELSE - DSDD(IK) = 0. - END IF - END DO - FDDMAX=0 - DO ITH=1, NTH - FDDMAX = MAX ( FDDMAX , ABS(ESIN(ITH)*eDDDX - ECOS(ITH)*eDDDY ) ) - END DO - DO IK=1, NK - FRK(IK) = FACTH * DSDD(IK) / WN(IK,ISEA) - !FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) - FRG(IK) = FDG * CG(IK,ISEA) - END DO - DO ISP=1, NSPEC - VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) + & + CALL STRACE (IENT, 'PROP_REFRACTION_PR1') +#endif + IX=MAPSF(ISEA,1) + IY=MAPSF(ISEA,2) + eDDDX=DDDX(IY,IX) + eDDDY=DDDY(IY,IX) + eCTHG0 = CTHG0S(ISEA) + FACTH = DTG / DTH + ! + FDG = FACTH * eCTHG0 + DEPTH = MAX ( DMIN , DW(ISEA) ) + DO IK=0, NK+1 + IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN + DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH + ELSE + DSDD(IK) = 0. + END IF + END DO + FDDMAX=0 + DO ITH=1, NTH + FDDMAX = MAX ( FDDMAX , ABS(ESIN(ITH)*eDDDX - ECOS(ITH)*eDDDY ) ) + END DO + DO IK=1, NK + FRK(IK) = FACTH * DSDD(IK) / WN(IK,ISEA) + !FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) + FRG(IK) = FDG * CG(IK,ISEA) + END DO + DO ISP=1, NSPEC + VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) + & FRK(MAPWN(ISP)) * ( ESIN(ISP)*eDDDX - ECOS(ISP)*eDDDY ) - END DO -! + END DO + ! #ifdef W3_REFRX -! 3.c @C/@x refraction and great-circle propagation - VCFLT = 0. - FRK = 0. - DO IK=1, NK - FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) - END DO - DO ISP=1, NSPEC - VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & - + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(ISP,1,MAPWN(ISP)) & - - ECOS(ISP)*DCDY(ISP,1,MAPWN(ISP)) ) - END DO -#endif -! - IF ( FLCUR ) THEN - eDCXDX=DCXDX(IY,IX) - eDCXDY=DCXDY(IY,IX) - eDCYDX=DCYDX(IY,IX) - eDCYDY=DCYDY(IY,IX) - DCYX = FACTH * eDCYDX - DCXXYY = FACTH * ( eDCXDX - eDCYDY ) - DCXY = FACTH * eDCXDY - DO ISP=1, NSPEC - VCFLT(ISP) = VCFLT(ISP) + ES2(ISP)*DCYX + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY - END DO - END IF - DO ISP=1,NSPEC - CAD(ISP)=DBLE(VCFLT(ISP)) + ! 3.c @C/@x refraction and great-circle propagation + VCFLT = 0. + FRK = 0. + DO IK=1, NK + FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) + END DO + DO ISP=1, NSPEC + VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(ISP,1,MAPWN(ISP)) & + - ECOS(ISP)*DCDY(ISP,1,MAPWN(ISP)) ) + END DO +#endif + ! + IF ( FLCUR ) THEN + eDCXDX=DCXDX(IY,IX) + eDCXDY=DCXDY(IY,IX) + eDCYDX=DCYDX(IY,IX) + eDCYDY=DCYDY(IY,IX) + DCYX = FACTH * eDCYDX + DCXXYY = FACTH * ( eDCXDX - eDCYDY ) + DCXY = FACTH * eDCXDY + DO ISP=1, NSPEC + VCFLT(ISP) = VCFLT(ISP) + ES2(ISP)*DCYX + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY END DO -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ + END IF + DO ISP=1,NSPEC + CAD(ISP)=DBLE(VCFLT(ISP)) + END DO + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ END SUBROUTINE PROP_REFRACTION_PR1 -!/ ------------------------------------------------------------------- / -! - SUBROUTINE PROP_REFRACTION_PR3(IP, ISEA, DTG, CAD, DoLimiter) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute refraction part in matrix alternative approach -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + ! + SUBROUTINE PROP_REFRACTION_PR3(IP, ISEA, DTG, CAD, DoLimiter) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute refraction part in matrix alternative approach + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & - CTMAX, DMIN, DTH, CTHG0S, MAPSF, SIG - USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, DDDX, & - DDDY, DW - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, only : IAPROC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3SERVMD, ONLY: STRACE +#endif + USE CONSTANTS, ONLY : LPDLIB + USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & + EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & + CTMAX, DMIN, DTH, CTHG0S, MAPSF, SIG + USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, DDDX, & + DDDY, DW + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, only : IAPROC + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL, intent(out) :: CAD(NSPEC) - INTEGER, intent(in) :: ISEA, IP - REAL, intent(in) :: DTG - logical, intent(in) :: DoLimiter - INTEGER :: ISP, IK, ITH, IX, IY - REAL :: FRK(NK), FRG(NK), DSDD(0:NK+1) - REAL :: FACTH, DCXY, DCYX, DCXXYY, DTTST - REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0 - REAL :: VCFLT(NSPEC), DEPTH, FDG, CG1(0:NK+1), WN1(0:NK+1) - REAL :: FDDMAX, CFLTHMAX, VELNOFILT, CTMAX_eff + INTEGER, SAVE :: IENT = 0 +#endif + REAL, intent(out) :: CAD(NSPEC) + INTEGER, intent(in) :: ISEA, IP + REAL, intent(in) :: DTG + logical, intent(in) :: DoLimiter + INTEGER :: ISP, IK, ITH, IX, IY + REAL :: FRK(NK), FRG(NK), DSDD(0:NK+1) + REAL :: FACTH, DCXY, DCYX, DCXXYY, DTTST + REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0 + REAL :: VCFLT(NSPEC), DEPTH, FDG, CG1(0:NK+1), WN1(0:NK+1) + REAL :: FDDMAX, CFLTHMAX, VELNOFILT, CTMAX_eff #ifdef W3_S - CALL STRACE (IENT, 'PROP_REFRACTION_PR3') + CALL STRACE (IENT, 'PROP_REFRACTION_PR3') #endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - eDDDX=DDDX(1,IP) - eDDDY=DDDY(1,IP) - eCTHG0 = CTHG0S(ISEA) - FACTH = 1.0 / DTH - ! - FDG = FACTH * eCTHG0 - DEPTH = MAX ( DMIN , DW(ISEA) ) - DO IK=0, NK+1 - IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN - DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH - ELSE - DSDD(IK) = 0. - END IF - END DO - DO IK=1, NK - FRK(IK) = FACTH * DSDD(IK) / WN(IK,ISEA) - FRG(IK) = FDG * CG(IK,ISEA) - END DO - IF (FLCUR) THEN - eDCXDX = DCXDX(1,IP) - eDCXDY = DCXDY(1,IP) - eDCYDX = DCYDX(1,IP) - eDCYDY = DCYDY(1,IP) - DCYX = FACTH * eDCYDX - DCXXYY = FACTH * ( eDCXDX - eDCYDY ) - DCXY = FACTH * eDCXDY - DO ISP=1, NSPEC - VCFLT(ISP) = ES2(ISP)*DCYX + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY - END DO + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + eDDDX=DDDX(1,IP) + eDDDY=DDDY(1,IP) + eCTHG0 = CTHG0S(ISEA) + FACTH = 1.0 / DTH + ! + FDG = FACTH * eCTHG0 + DEPTH = MAX ( DMIN , DW(ISEA) ) + DO IK=0, NK+1 + IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN + DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH ELSE - VCFLT=0 + DSDD(IK) = 0. END IF -! -#ifdef W3_REFRX -! 3.c @C/@x refraction and great-circle propagation - DO IK=1, NK - FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) - END DO -#endif -! - CTMAX_eff=CTMAX/DTG + END DO + DO IK=1, NK + FRK(IK) = FACTH * DSDD(IK) / WN(IK,ISEA) + FRG(IK) = FDG * CG(IK,ISEA) + END DO + IF (FLCUR) THEN + eDCXDX = DCXDX(1,IP) + eDCXDY = DCXDY(1,IP) + eDCYDX = DCYDX(1,IP) + eDCYDY = DCYDY(1,IP) + DCYX = FACTH * eDCYDX + DCXXYY = FACTH * ( eDCXDX - eDCYDY ) + DCXY = FACTH * eDCXDY DO ISP=1, NSPEC - VELNOFILT = VCFLT(ISP) & + VCFLT(ISP) = ES2(ISP)*DCYX + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY + END DO + ELSE + VCFLT=0 + END IF + ! +#ifdef W3_REFRX + ! 3.c @C/@x refraction and great-circle propagation + DO IK=1, NK + FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) + END DO +#endif + ! + CTMAX_eff=CTMAX/DTG + DO ISP=1, NSPEC + VELNOFILT = VCFLT(ISP) & + FRG(MAPWN(ISP)) * ECOS(ISP) & + FRK(MAPWN(ISP)) * (ESIN(ISP)*eDDDX - ECOS(ISP)*eDDDY) -! -! Puts filtering on total velocity (including currents and great circle effects) -! the filtering limits VCFLT to be less than CTMAX -! this modification was proposed by F. Ardhuin 2011/03/06 -! - IF (DoLimiter) THEN - VCFLT(ISP)=SIGN(MIN(ABS(VELNOFILT),CTMAX_eff),VELNOFILT) - ELSE - VCFLT(ISP)=VELNOFILT - END IF - END DO - DO ISP=1,NSPEC - CAD(ISP)=DBLE(VCFLT(ISP)) - END DO -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ + ! + ! Puts filtering on total velocity (including currents and great circle effects) + ! the filtering limits VCFLT to be less than CTMAX + ! this modification was proposed by F. Ardhuin 2011/03/06 + ! + IF (DoLimiter) THEN + VCFLT(ISP)=SIGN(MIN(ABS(VELNOFILT),CTMAX_eff),VELNOFILT) + ELSE + VCFLT(ISP)=VELNOFILT + END IF + END DO + DO ISP=1,NSPEC + CAD(ISP)=DBLE(VCFLT(ISP)) + END DO + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ END SUBROUTINE PROP_REFRACTION_PR3 -!/ ------------------------------------------------------------------- / - SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute freq. shift in matrix -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute freq. shift in matrix + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & - CTMAX, DMIN, DTH, MAPSF - USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, CX, CY, DDDX, DDDY, DW - USE W3ODATMD, only : IAPROC - IMPLICIT NONE -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3SERVMD, ONLY: STRACE +#endif + USE CONSTANTS, ONLY : LPDLIB + USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & + EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & + CTMAX, DMIN, DTH, MAPSF + USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, CX, CY, DDDX, DDDY, DW + USE W3ODATMD, only : IAPROC + IMPLICIT NONE + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER, intent(in) :: ISEA, IP - REAL, intent(out) :: DMM(0:NK2) - REAL, intent(in) :: DTG - REAL, intent(out) :: CAS(NSPEC) - REAL :: DB(NK2), DSDD(0:NK+1) - REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eCX, eCY, eDDDX, EDDDY - REAL :: DCXX, DCXYYX, DCYY, FKD, FACK - REAL :: VELNOFILT, VELFAC, DEPTH - REAL :: CFLK(NK2,NTH), FKC(NTH), FKD0 - INTEGER :: IK, ITH, ISP, IY, IX + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER, intent(in) :: ISEA, IP + REAL, intent(out) :: DMM(0:NK2) + REAL, intent(in) :: DTG + REAL, intent(out) :: CAS(NSPEC) + REAL :: DB(NK2), DSDD(0:NK+1) + REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eCX, eCY, eDDDX, EDDDY + REAL :: DCXX, DCXYYX, DCYY, FKD, FACK + REAL :: VELNOFILT, VELFAC, DEPTH + REAL :: CFLK(NK2,NTH), FKC(NTH), FKD0 + INTEGER :: IK, ITH, ISP, IY, IX #ifdef W3_S - CALL STRACE (IENT, 'PROP_FREQ_SHIFT') -#endif -! - IF (LPDLIB) THEN - eDCXDX = DCXDX(1,IP) - eDCXDY = DCXDY(1,IP) - eDCYDX = DCYDX(1,IP) - eDCYDY = DCYDY(1,IP) - eDDDX = DDDX(1,IP) - eDDDY = DDDY(1,IP) + CALL STRACE (IENT, 'PROP_FREQ_SHIFT') +#endif + ! + IF (LPDLIB) THEN + eDCXDX = DCXDX(1,IP) + eDCXDY = DCXDY(1,IP) + eDCYDX = DCYDX(1,IP) + eDCYDY = DCYDY(1,IP) + eDDDX = DDDX(1,IP) + eDDDY = DDDY(1,IP) + ELSE + IX=MAPSF(ISEA,1) + IY=MAPSF(ISEA,2) + eDCXDX=DCXDX(IY,IX) + eDCXDY=DCXDY(IY,IX) + eDCYDX=DCYDX(IY,IX) + eDCYDY=DCYDY(IY,IX) + eDDDX=DDDX(IY,IX) + eDDDY=DDDY(IY,IX) + ENDIF + eCX=CX(ISEA) + eCY=CY(ISEA) + DCXX = - eDCXDX + DCXYYX = - ( eDCXDY + eDCYDX ) + DCYY = - eDCYDY + FKD = ( eCX*eDDDX + eCY*eDDDY ) + FACK = DTG + DO ITH=1, NTH + FKC(ITH) = EC2(ITH)*DCXX + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY + END DO + DO IK=0, NK + DB(IK+1) = DSIP(IK) / CG(IK,ISEA) + DMM(IK+1) = DBLE(WN(IK+1,ISEA) - WN(IK,ISEA)) + END DO + DB(NK+2) = DSIP(NK+1) / CG(NK+1,ISEA) + DMM(NK+2) = ZERO + DMM(0)=DMM(1) + ! + DEPTH = MAX ( DMIN , DW(ISEA) ) + DO IK=0, NK+1 + IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN + DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH ELSE - IX=MAPSF(ISEA,1) - IY=MAPSF(ISEA,2) - eDCXDX=DCXDX(IY,IX) - eDCXDY=DCXDY(IY,IX) - eDCYDX=DCYDX(IY,IX) - eDCYDY=DCYDY(IY,IX) - eDDDX=DDDX(IY,IX) - eDDDY=DDDY(IY,IX) - ENDIF - eCX=CX(ISEA) - eCY=CY(ISEA) - DCXX = - eDCXDX - DCXYYX = - ( eDCXDY + eDCYDX ) - DCYY = - eDCYDY - FKD = ( eCX*eDDDX + eCY*eDDDY ) - FACK = DTG + DSDD(IK) = 0. + END IF + END DO + DO IK=0, NK+1 + FKD0 = FKD / CG(IK,ISEA) * DSDD(IK) + VELFAC = FACK/DB(IK+1) DO ITH=1, NTH - FKC(ITH) = EC2(ITH)*DCXX + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY - END DO - DO IK=0, NK - DB(IK+1) = DSIP(IK) / CG(IK,ISEA) - DMM(IK+1) = DBLE(WN(IK+1,ISEA) - WN(IK,ISEA)) - END DO - DB(NK+2) = DSIP(NK+1) / CG(NK+1,ISEA) - DMM(NK+2) = ZERO - DMM(0)=DMM(1) -! - DEPTH = MAX ( DMIN , DW(ISEA) ) - DO IK=0, NK+1 - IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN - DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH - ELSE - DSDD(IK) = 0. - END IF - END DO - DO IK=0, NK+1 - FKD0 = FKD / CG(IK,ISEA) * DSDD(IK) - VELFAC = FACK/DB(IK+1) - DO ITH=1, NTH - VELNOFILT = ( FKD0 + WN(IK,ISEA)*FKC(ITH) ) * VELFAC - CFLK(IK+1,ITH) = VELNOFILT/VELFAC - END DO + VELNOFILT = ( FKD0 + WN(IK,ISEA)*FKC(ITH) ) * VELFAC + CFLK(IK+1,ITH) = VELNOFILT/VELFAC END DO - DO IK=1,NK - DO ITH=1,NTH - ISP=ITH + (IK-1)*NTH - CAS(ISP)=DBLE(CFLK(IK,ITH)) - END DO + END DO + DO IK=1,NK + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + CAS(ISP)=DBLE(CFLK(IK,ITH)) END DO -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ + END DO + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ END SUBROUTINE PROP_FREQ_SHIFT -!/ ------------------------------------------------------------------- / - SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute freq. shift alternative approach -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! + !/ ------------------------------------------------------------------- / + SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute freq. shift alternative approach + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & - CTMAX, DMIN, DTH, MAPSF - USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, CX, CY, DDDX, DDDY, DW - USE W3ODATMD, only : IAPROC + USE W3SERVMD, ONLY: STRACE +#endif + USE CONSTANTS, ONLY : LPDLIB + USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & + EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & + CTMAX, DMIN, DTH, MAPSF + USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, CX, CY, DDDX, DDDY, DW + USE W3ODATMD, only : IAPROC - IMPLICIT NONE + IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, intent(in) :: ISEA, IP - REAL, intent(out) :: CWNB_M2(1-NTH:NSPEC) - REAL, intent(out) :: DWNI_M2(NK) - REAL, intent(in) :: DTG - ! - REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eCX, eCY, eDDDX, EDDDY - REAL :: DCXX, DCXYYX, DCYY, FKD, FACK - REAL :: DEPTH - REAL :: FKC(NTH), FKD0 - REAL :: VCWN(1-NTH:NSPEC+NTH) - REAL :: DSDD(0:NK+1) - REAL :: sumDiff, sumDiff1, sumDiff2, sumDiff3 - REAL :: sumDiff0, sumDiff4, sumDiff5 - INTEGER :: IK, ITH, ISP, IY, IX + INTEGER, intent(in) :: ISEA, IP + REAL, intent(out) :: CWNB_M2(1-NTH:NSPEC) + REAL, intent(out) :: DWNI_M2(NK) + REAL, intent(in) :: DTG + ! + REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eCX, eCY, eDDDX, EDDDY + REAL :: DCXX, DCXYYX, DCYY, FKD, FACK + REAL :: DEPTH + REAL :: FKC(NTH), FKD0 + REAL :: VCWN(1-NTH:NSPEC+NTH) + REAL :: DSDD(0:NK+1) + REAL :: sumDiff, sumDiff1, sumDiff2, sumDiff3 + REAL :: sumDiff0, sumDiff4, sumDiff5 + INTEGER :: IK, ITH, ISP, IY, IX -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'PROP_FREQ_SHIFT_M2') + CALL STRACE (IENT, 'PROP_FREQ_SHIFT_M2') #endif - IF (LPDLIB) THEN - eDCXDX = DCXDX(1,IP) - eDCXDY = DCXDY(1,IP) - eDCYDX = DCYDX(1,IP) - eDCYDY = DCYDY(1,IP) - eDDDX = DDDX(1,IP) - eDDDY = DDDY(1,IP) - ELSE - IX=MAPSF(ISEA,1) - IY=MAPSF(ISEA,2) - eDCXDX=DCXDX(IY,IX) - eDCXDY=DCXDY(IY,IX) - eDCYDX=DCYDX(IY,IX) - eDCYDY=DCYDY(IY,IX) - eDDDX=DDDX(IY,IX) - eDDDY=DDDY(IY,IX) - ENDIF + IF (LPDLIB) THEN + eDCXDX = DCXDX(1,IP) + eDCXDY = DCXDY(1,IP) + eDCYDX = DCYDX(1,IP) + eDCYDY = DCYDY(1,IP) + eDDDX = DDDX(1,IP) + eDDDY = DDDY(1,IP) + ELSE + IX=MAPSF(ISEA,1) + IY=MAPSF(ISEA,2) + eDCXDX=DCXDX(IY,IX) + eDCXDY=DCXDY(IY,IX) + eDCYDX=DCYDX(IY,IX) + eDCYDY=DCYDY(IY,IX) + eDDDX=DDDX(IY,IX) + eDDDY=DDDY(IY,IX) + ENDIF - eCX = CX(ISEA) - eCY = CY(ISEA) - FACK = DTG - DCXX = - FACK * eDCXDX - DCXYYX = - FACK * ( eDCXDY + eDCYDX ) - DCYY = - FACK * eDCYDY - FKD = FACK * ( eCX*eDDDX + eCY*eDDDY ) + eCX = CX(ISEA) + eCY = CY(ISEA) + FACK = DTG + DCXX = - FACK * eDCXDX + DCXYYX = - FACK * ( eDCXDY + eDCYDX ) + DCYY = - FACK * eDCYDY + FKD = FACK * ( eCX*eDDDX + eCY*eDDDY ) + DO ITH=1, NTH + FKC(ITH) = EC2(ITH)*DCXX + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY + END DO + ! + DEPTH = MAX ( DMIN , DW(ISEA) ) + DO IK=0, NK+1 + IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN + DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH + ELSE + DSDD(IK) = 0. + END IF + END DO + ISP = -NTH + DO IK=0, NK+1 + FKD0 = FKD / CG(IK,ISEA) * DSDD(IK) DO ITH=1, NTH - FKC(ITH) = EC2(ITH)*DCXX + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY - END DO -! - DEPTH = MAX ( DMIN , DW(ISEA) ) - DO IK=0, NK+1 - IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN - DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH - ELSE - DSDD(IK) = 0. - END IF - END DO - ISP = -NTH - DO IK=0, NK+1 - FKD0 = FKD / CG(IK,ISEA) * DSDD(IK) - DO ITH=1, NTH - ISP = ISP + 1 - VCWN(ISP) = FKD0 + WN(IK,ISEA)*FKC(ITH) - END DO + ISP = ISP + 1 + VCWN(ISP) = FKD0 + WN(IK,ISEA)*FKC(ITH) END DO + END DO - sumDiff=0 - DO ISP=1-NTH,NSPEC - CWNB_M2(ISP) = DBLE(0.5 * ( VCWN(ISP) + VCWN(ISP+NTH) )) - sumDiff = sumDiff + MAX(CWNB_M2(ISP), ZERO) - END DO - DO IK=1,NK - DWNI_M2(IK) = DBLE( CG(IK,ISEA) / DSIP(IK) ) - END DO -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ + sumDiff=0 + DO ISP=1-NTH,NSPEC + CWNB_M2(ISP) = DBLE(0.5 * ( VCWN(ISP) + VCWN(ISP+NTH) )) + sumDiff = sumDiff + MAX(CWNB_M2(ISP), ZERO) + END DO + DO IK=1,NK + DWNI_M2(IK) = DBLE( CG(IK,ISEA) / DSIP(IK) ) + END DO + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ END SUBROUTINE PROP_FREQ_SHIFT_M2 -!/ ------------------------------------------------------------------- / - SUBROUTINE SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Sync global local arrays -! 2. Method : -! All the process need to have IPGL_tot and IPGL_TO_PROC -! This is especially the case for the output process. -! So we need some painful exportation business -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Sync global local arrays + ! 2. Method : + ! All the process need to have IPGL_tot and IPGL_TO_PROC + ! This is especially the case for the output process. + ! So we need some painful exportation business + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_PDLIB - USE yowDatapool, only: istatus - USE yowNodepool, only: np_global - USE W3ODATMD, ONLY: NTPROC, NAPROC, IAPROC - USE W3GDATMD, ONLY: MAPSF, NSEA - USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP - USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot - USE WMMDATMD, ONLY: MDATAS -#endif - IMPLICIT NONE + USE yowDatapool, only: istatus + USE yowNodepool, only: np_global + USE W3ODATMD, ONLY: NTPROC, NAPROC, IAPROC + USE W3GDATMD, ONLY: MAPSF, NSEA + USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP + USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot + USE WMMDATMD, ONLY: MDATAS +#endif + IMPLICIT NONE #ifdef W3_PDLIB - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif - INTEGER, intent(in) :: IMOD - logical, intent(in) :: IsMulti + INTEGER, intent(in) :: IMOD + logical, intent(in) :: IsMulti #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_PDLIB - INTEGER :: Iarr(1) - INTEGER :: ISEA, IP_glob - INTEGER :: IPROC, IERR_MPI, istat + INTEGER :: Iarr(1) + INTEGER :: ISEA, IP_glob + INTEGER :: IPROC, IERR_MPI, istat #endif #ifdef W3_S - CALL STRACE (IENT, 'SYNCHRONIZE_IPGL_ETC_ARRAY') + CALL STRACE (IENT, 'SYNCHRONIZE_IPGL_ETC_ARRAY') #endif #ifdef W3_PDLIB - IF (IAPROC .le. NAPROC) THEN - IF (IAPROC .eq. 1) THEN - Iarr(1)=np_global - DO IPROC=NAPROC+1,NTPROC - CALL MPI_SEND(Iarr,1,MPI_INT, IPROC-1, 37, MPI_COMM_WAVE, IERR_MPI) - END DO - DO IPROC=NAPROC+1,NTPROC - CALL MPI_SEND(ipgl_tot,np_global,MPI_INT, IPROC-1, 43, MPI_COMM_WAVE, IERR_MPI) - CALL MPI_SEND(ipgl_to_proc,np_global,MPI_INT, IPROC-1, 91, MPI_COMM_WAVE, IERR_MPI) - END DO - END IF - ELSE - CALL MPI_RECV(Iarr,1,MPI_INT, 0, 37, MPI_COMM_WAVE, istatus, IERR_MPI) - np_global=Iarr(1) - allocate(IPGL_tot(np_global), IPGL_TO_PROC(np_global), stat=istat) - CALL MPI_RECV(ipgl_tot,np_global,MPI_INT, 0, 43, MPI_COMM_WAVE, istatus, IERR_MPI) - CALL MPI_RECV(ipgl_to_proc,np_global,MPI_INT, 0, 91, MPI_COMM_WAVE, istatus, IERR_MPI) - END IF - IF (IsMulti) THEN - WRITE(*,*) ' Before allocation of MDATAS % SEA_IPGL, SEA_IPGL_TO_PROC : IMOD=', IMOD, ' NSEA=', NSEA - ALLOCATE(MDATAS(IMOD)%SEA_IPGL(NSEA), MDATAS(IMOD)%SEA_IPGL_TO_PROC(NSEA), STAT=ISTAT) - !CHECK_ALLOC_STATUS ( ISTAT ) - DO ISEA=1,NSEA - IP_glob = MAPSF(ISEA, 1) - MDATAS(IMOD)%SEA_IPGL(ISEA) = IPGL_tot(IP_glob) - MDATAS(IMOD)%SEA_IPGL_TO_PROC(ISEA) = IPGL_TO_PROC(IP_glob) - END DO - END IF -#endif -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ + IF (IAPROC .le. NAPROC) THEN + IF (IAPROC .eq. 1) THEN + Iarr(1)=np_global + DO IPROC=NAPROC+1,NTPROC + CALL MPI_SEND(Iarr,1,MPI_INT, IPROC-1, 37, MPI_COMM_WAVE, IERR_MPI) + END DO + DO IPROC=NAPROC+1,NTPROC + CALL MPI_SEND(ipgl_tot,np_global,MPI_INT, IPROC-1, 43, MPI_COMM_WAVE, IERR_MPI) + CALL MPI_SEND(ipgl_to_proc,np_global,MPI_INT, IPROC-1, 91, MPI_COMM_WAVE, IERR_MPI) + END DO + END IF + ELSE + CALL MPI_RECV(Iarr,1,MPI_INT, 0, 37, MPI_COMM_WAVE, istatus, IERR_MPI) + np_global=Iarr(1) + allocate(IPGL_tot(np_global), IPGL_TO_PROC(np_global), stat=istat) + CALL MPI_RECV(ipgl_tot,np_global,MPI_INT, 0, 43, MPI_COMM_WAVE, istatus, IERR_MPI) + CALL MPI_RECV(ipgl_to_proc,np_global,MPI_INT, 0, 91, MPI_COMM_WAVE, istatus, IERR_MPI) + END IF + IF (IsMulti) THEN + WRITE(*,*) ' Before allocation of MDATAS % SEA_IPGL, SEA_IPGL_TO_PROC : IMOD=', IMOD, ' NSEA=', NSEA + ALLOCATE(MDATAS(IMOD)%SEA_IPGL(NSEA), MDATAS(IMOD)%SEA_IPGL_TO_PROC(NSEA), STAT=ISTAT) + !CHECK_ALLOC_STATUS ( ISTAT ) + DO ISEA=1,NSEA + IP_glob = MAPSF(ISEA, 1) + MDATAS(IMOD)%SEA_IPGL(ISEA) = IPGL_tot(IP_glob) + MDATAS(IMOD)%SEA_IPGL_TO_PROC(ISEA) = IPGL_TO_PROC(IP_glob) + END DO + END IF +#endif + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ END SUBROUTINE SYNCHRONIZE_IPGL_ETC_ARRAY -!/ ....................----------------------------------------------- / - SUBROUTINE SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Setup nseal, nsealm in contect of pdlib -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ....................----------------------------------------------- / + SUBROUTINE SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Setup nseal, nsealm in contect of pdlib + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ -!/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / #ifdef W3_PDLIB - use yowDatapool, only: istatus - use yowNodepool, only: npa - use yowRankModule, only : rank - USE W3GDATMD, ONLY: GTYPE, UNGTYPE + use yowDatapool, only: istatus + use yowNodepool, only: npa + use yowRankModule, only : rank + USE W3GDATMD, ONLY: GTYPE, UNGTYPE #endif #ifdef W3_MPI - USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP -#endif - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: NSEA - USE W3ODATMD, ONLY: NTPROC, NAPROC, IAPROC - IMPLICIT NONE - INTEGER, intent(out) :: NSEALout, NSEALMout -!/ Local parameters -!/ + USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP +#endif + USE CONSTANTS, ONLY : LPDLIB + USE W3GDATMD, ONLY: NSEA + USE W3ODATMD, ONLY: NTPROC, NAPROC, IAPROC + IMPLICIT NONE + INTEGER, intent(out) :: NSEALout, NSEALMout + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'SET_UP_NSEAL_NSEALM') + CALL STRACE (IENT, 'SET_UP_NSEAL_NSEALM') #endif #ifdef W3_SHRD - NSEALout = NSEA - NSEALMout = NSEA + NSEALout = NSEA + NSEALMout = NSEA #endif -! + ! #ifdef W3_DIST - IF (.NOT. LPDLIB ) THEN + IF (.NOT. LPDLIB ) THEN + IF ( IAPROC .LE. NAPROC ) THEN + NSEALout = 1 + (NSEA-IAPROC)/NAPROC + ELSE + NSEALout = 0 + END IF + NSEALMout = 1 + (NSEA-1)/NAPROC + ELSE +#endif +#ifdef W3_PDLIB + IF (GTYPE .eq. UNGTYPE) THEN + NSEALout = PDLIB_NSEAL + NSEALMout = PDLIB_NSEALM + ELSE IF ( IAPROC .LE. NAPROC ) THEN NSEALout = 1 + (NSEA-IAPROC)/NAPROC ELSE NSEALout = 0 END IF NSEALMout = 1 + (NSEA-1)/NAPROC - ELSE -#endif -#ifdef W3_PDLIB - IF (GTYPE .eq. UNGTYPE) THEN - NSEALout = PDLIB_NSEAL - NSEALMout = PDLIB_NSEALM - ELSE - IF ( IAPROC .LE. NAPROC ) THEN - NSEALout = 1 + (NSEA-IAPROC)/NAPROC - ELSE - NSEALout = 0 - END IF - NSEALMout = 1 + (NSEA-1)/NAPROC - ENDIF + ENDIF #endif #ifdef W3_DIST - ENDIF + ENDIF #endif -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ END SUBROUTINE SET_UP_NSEAL_NSEALM -!/ ------------------------------------------------------------------- / - SUBROUTINE INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Set Jsea for all schemes -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Set Jsea for all schemes + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC - USE W3GDATMD, ONLY: GTYPE, UNGTYPE, MAPSF - USE CONSTANTS, ONLY : LPDLIB + !/ + USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC + USE W3GDATMD, ONLY: GTYPE, UNGTYPE, MAPSF + USE CONSTANTS, ONLY : LPDLIB #ifdef W3_PDLIB - USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot - use yowNodepool, only: ipgl, iplg -#endif - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot + use yowNodepool, only: ipgl, iplg +#endif + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / - INTEGER, intent(in) :: ISEA - INTEGER, intent(out) :: JSEA, ISPROC - INTEGER IP_glob + !/ + !/ ------------------------------------------------------------------- / + INTEGER, intent(in) :: ISEA + INTEGER, intent(out) :: JSEA, ISPROC + INTEGER IP_glob #ifdef W3_S - CALL STRACE (IENT, 'INIT_GET_JSEA_ISPROC') + CALL STRACE (IENT, 'INIT_GET_JSEA_ISPROC') #endif #ifdef W3_PDLIB - IF ((.NOT. LPDLIB ).or.(GTYPE .ne. UNGTYPE)) THEN + IF ((.NOT. LPDLIB ).or.(GTYPE .ne. UNGTYPE)) THEN #endif - JSEA = 1 + (ISEA-1)/NAPROC - ISPROC = ISEA - (JSEA-1)*NAPROC + JSEA = 1 + (ISEA-1)/NAPROC + ISPROC = ISEA - (JSEA-1)*NAPROC #ifdef W3_PDLIB + ELSE + IP_glob = MAPSF(ISEA,1) + IF (IAPROC .le. NAPROC) THEN + JSEA = ISEA_TO_JSEA(ISEA) ELSE - IP_glob = MAPSF(ISEA,1) - IF (IAPROC .le. NAPROC) THEN - JSEA = ISEA_TO_JSEA(ISEA) - ELSE - JSEA = -1 - END IF - ISPROC = IPGL_TO_PROC(IP_glob) - ENDIF + JSEA = -1 + END IF + ISPROC = IPGL_TO_PROC(IP_glob) + ENDIF #endif -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ END SUBROUTINE INIT_GET_JSEA_ISPROC -!/ ------------------------------------------------------------------- / - SUBROUTINE GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Set belongings of jsea in context of pdlib -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Set belongings of jsea in context of pdlib + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC - USE W3GDATMD, ONLY: GTYPE, UNGTYPE, MAPSF - USE CONSTANTS, ONLY : LPDLIB + !/ + USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC + USE W3GDATMD, ONLY: GTYPE, UNGTYPE, MAPSF + USE CONSTANTS, ONLY : LPDLIB #ifdef W3_PDLIB - USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot, IPGL_npa - use yowNodepool, only: ipgl, iplg -#endif - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot, IPGL_npa + use yowNodepool, only: ipgl, iplg +#endif + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER, intent(in) :: ISEA - INTEGER, intent(out) :: JSEA, IBELONG - INTEGER ISPROC, IX, JX + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER, intent(in) :: ISEA + INTEGER, intent(out) :: JSEA, IBELONG + INTEGER ISPROC, IX, JX #ifdef W3_S - CALL STRACE (IENT, 'GET_JSEA_IBELONG') + CALL STRACE (IENT, 'GET_JSEA_IBELONG') #endif - IF (.NOT. LPDLIB) THEN - JSEA = 1 + (ISEA-1)/NAPROC - ISPROC = ISEA - (JSEA-1)*NAPROC - IF (ISPROC .eq. IAPROC) THEN - IBELONG=1 - ELSE - IBELONG=0 - END IF + IF (.NOT. LPDLIB) THEN + JSEA = 1 + (ISEA-1)/NAPROC + ISPROC = ISEA - (JSEA-1)*NAPROC + IF (ISPROC .eq. IAPROC) THEN + IBELONG=1 ELSE + IBELONG=0 + END IF + ELSE #ifdef W3_PDLIB - IF (GTYPE .ne. UNGTYPE) THEN + IF (GTYPE .ne. UNGTYPE) THEN JSEA = 1 + (ISEA-1)/NAPROC ISPROC = ISEA - (JSEA-1)*NAPROC IF (ISPROC .eq. IAPROC) THEN @@ -1247,236 +1247,235 @@ SUBROUTINE GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) END IF ENDIF #endif - ENDIF -!/ -!/ End of INIT_GET_ISEA ---------------------------------------------- / -!/ + ENDIF + !/ + !/ End of INIT_GET_ISEA ---------------------------------------------- / + !/ END SUBROUTINE GET_JSEA_IBELONG -!/ ------------------------------------------------------------------- / - SUBROUTINE INIT_GET_ISEA(ISEA, JSEA) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Set Isea for all schemes -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE INIT_GET_ISEA(ISEA, JSEA) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Set Isea for all schemes + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE CONSTANTS, ONLY : LPDLIB + !/ + USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC + USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE CONSTANTS, ONLY : LPDLIB #ifdef W3_PDLIB - USE YOWNODEPOOL, ONLY: iplg -#endif -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -!/ ------------------------------------------------------------------- / -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -! - USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE CONSTANTS, ONLY : LPDLIB + USE YOWNODEPOOL, ONLY: iplg +#endif + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + !/ ------------------------------------------------------------------- / + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + ! + USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC + USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE CONSTANTS, ONLY : LPDLIB #ifdef W3_PDLIB - USE YOWNODEPOOL, ONLY: iplg + USE YOWNODEPOOL, ONLY: iplg #endif - IMPLICIT NONE + IMPLICIT NONE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, intent(in) :: JSEA - INTEGER, intent(out) :: ISEA + INTEGER, intent(in) :: JSEA + INTEGER, intent(out) :: ISEA #ifdef W3_S - CALL STRACE (IENT, 'INIT_GET_ISEA') + CALL STRACE (IENT, 'INIT_GET_ISEA') #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif #ifdef W3_DIST - IF (.NOT. LPDLIB) THEN - ISEA = IAPROC + (JSEA-1)*NAPROC - ELSE + IF (.NOT. LPDLIB) THEN + ISEA = IAPROC + (JSEA-1)*NAPROC + ELSE #endif #ifdef W3_PDLIB - IF (GTYPE .eq. UNGTYPE) THEN - ISEA = iplg(JSEA) - ELSE - ISEA = IAPROC + (JSEA-1)*NAPROC - ENDIF + IF (GTYPE .eq. UNGTYPE) THEN + ISEA = iplg(JSEA) + ELSE + ISEA = IAPROC + (JSEA-1)*NAPROC + ENDIF #endif #ifdef W3_DIST - ENDIF + ENDIF #endif -!/ -!/ End of INIT_GET_ISEA ------------------------------------------------ / -!/ + !/ + !/ End of INIT_GET_ISEA ------------------------------------------------ / + !/ END SUBROUTINE INIT_GET_ISEA -!********************************************************************** -!* An array of size (NSEA) is send but only the (1:NSEAL) values * -!* are correct. The program synchonizes everything on all nodes. * -!********************************************************************** - SUBROUTINE SYNCHRONIZE_GLOBAL_ARRAY(TheVar) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Sync global array in context of pdlib -! 2. Method : -! An array of size (NSEA) is send but only the (1:NSEAL) values -! are correct. The program synchonizes everything on all nodes. -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !********************************************************************** + !* An array of size (NSEA) is send but only the (1:NSEAL) values * + !* are correct. The program synchonizes everything on all nodes. * + !********************************************************************** + SUBROUTINE SYNCHRONIZE_GLOBAL_ARRAY(TheVar) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Sync global array in context of pdlib + ! 2. Method : + ! An array of size (NSEA) is send but only the (1:NSEAL) values + ! are correct. The program synchonizes everything on all nodes. + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE W3GDATMD, ONLY: NSEAL, NSEA, NX + ! + USE W3GDATMD, ONLY: NSEAL, NSEA, NX #ifdef W3_PDLIB - USE W3ODATMD, only : IAPROC, NAPROC, NTPROC - USE W3ADATMD, ONLY: MPI_COMM_WCMP - use yowDatapool, only: rtype, istatus - USE yowNodepool, only: npa - use yowNodepool, only: iplg -#endif - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3ODATMD, only : IAPROC, NAPROC, NTPROC + USE W3ADATMD, ONLY: MPI_COMM_WCMP + use yowDatapool, only: rtype, istatus + USE yowNodepool, only: npa + use yowNodepool, only: iplg +#endif + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif - INTEGER ISEA, JSEA, Status(NX), rStatus(NX) - INTEGER IPROC, I, ierr, IP, IX, IP_glob - REAL*8, intent(inout) :: TheVar(NX) - REAL*8 rVect(NX) - Status=0 + INTEGER ISEA, JSEA, Status(NX), rStatus(NX) + INTEGER IPROC, I, ierr, IP, IX, IP_glob + REAL*8, intent(inout) :: TheVar(NX) + REAL*8 rVect(NX) + Status=0 #ifdef W3_S - CALL STRACE (IENT, 'SYNCHRONIZE_GLOBAL_ARRAY') + CALL STRACE (IENT, 'SYNCHRONIZE_GLOBAL_ARRAY') #endif #ifdef W3_PDLIB - DO IP=1,npa - IP_glob=iplg(IP) - Status(IP_glob)=1 - END DO - IF (IAPROC .eq. 1) THEN - DO iProc=2,NAPROC - CALL MPI_RECV(rVect,NX,rtype, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) - CALL MPI_RECV(rStatus,NX,MPI_INTEGER, iProc-1, 23, MPI_COMM_WCMP, istatus, ierr) - DO I=1,NX - IF (rStatus(I) .eq. 1) THEN - TheVar(I)=rVect(I) - Status(I)=1 - END IF - END DO - END DO - DO IPROC=2,NAPROC - CALL MPI_SEND(TheVar,NX,rtype, iProc-1, 29, MPI_COMM_WCMP, ierr) + DO IP=1,npa + IP_glob=iplg(IP) + Status(IP_glob)=1 + END DO + IF (IAPROC .eq. 1) THEN + DO iProc=2,NAPROC + CALL MPI_RECV(rVect,NX,rtype, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) + CALL MPI_RECV(rStatus,NX,MPI_INTEGER, iProc-1, 23, MPI_COMM_WCMP, istatus, ierr) + DO I=1,NX + IF (rStatus(I) .eq. 1) THEN + TheVar(I)=rVect(I) + Status(I)=1 + END IF END DO - ELSE - CALL MPI_SEND(TheVar,NX,rtype, 0, 19, MPI_COMM_WCMP, ierr) - CALL MPI_SEND(Status,NX,MPI_INTEGER, 0, 23, MPI_COMM_WCMP, ierr) - CALL MPI_RECV(TheVar,NX,rtype, 0, 29, MPI_COMM_WCMP, istatus, ierr) - END IF -#endif -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ + END DO + DO IPROC=2,NAPROC + CALL MPI_SEND(TheVar,NX,rtype, iProc-1, 29, MPI_COMM_WCMP, ierr) + END DO + ELSE + CALL MPI_SEND(TheVar,NX,rtype, 0, 19, MPI_COMM_WCMP, ierr) + CALL MPI_SEND(Status,NX,MPI_INTEGER, 0, 23, MPI_COMM_WCMP, ierr) + CALL MPI_RECV(TheVar,NX,rtype, 0, 29, MPI_COMM_WCMP, istatus, ierr) + END IF +#endif + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ END SUBROUTINE SYNCHRONIZE_GLOBAL_ARRAY + !/ ------------------------------------------------------------------- / +END MODULE W3PARALL !/ ------------------------------------------------------------------- / - END MODULE W3PARALL -!/ ------------------------------------------------------------------- / - diff --git a/model/src/w3partmd.F90 b/model/src/w3partmd.F90 index 95a5c98f3..49a52f680 100644 --- a/model/src/w3partmd.F90 +++ b/model/src/w3partmd.F90 @@ -15,1534 +15,1531 @@ !> @author Barbara Tracey, H. L. Tolman, M. Szyszka, Chris Bunney !> @date 23 Jul 2018 !> - MODULE W3PARTMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III USACE/NOAA | -!/ | Barbara Tracy | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Jul-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Nov-2006 : Origination. ( version 3.10 ) -!/ 02-Nov-2006 : Adding tail to integration. ( version 3.10 ) -!/ 24-Mar-2007 : Bug fix IMI, adding overall field ( version 3.11 ) -!/ and sorting. -!/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) -!/ 02-Dec-2010 : Adding a mapping PMAP between ( version 3.14 ) -!/ original and combined partitions -!/ ( M. Szyszka ) -!/ 23-Jul-2018 : Added alternative partitioning ( version 6.05 ) -!/ methods (C. Bunney, UKMO) -! 1. Purpose : -! -! Spectral partitioning according to the watershed method. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! MK, MTH Int. Private Dimensions of stored neighour array. -! NEIGH I.A. Private Nearest Neighbor array. -! ---------------------------------------------------------------- -! Note: IHMAX, HSPMIN, WSMULT, WSCUT and FLCOMB used from W3ODATMD. -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3PART Subr. Public Interface to watershed routines. -! PTSORT Subr. Public Sort discretized image. -! PTNGHB Subr. Public Defeine nearest neighbours. -! PT_FLD Subr. Public Incremental flooding algorithm. -! FIFO_ADD, FIFO_EMPTY, FIFO_FIRST -! Subr. PT_FLD Queue management. -! PTMEAN Subr. Public Compute mean parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine traceing. -! WAVNU1 Subr. W3DISPMD Wavenumber computation. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3ODATMD, ONLY: IHMAX, HSPMIN, WSMULT, DIMP, PTMETH, PTFCUT -! - PUBLIC -! - !> Nearest neighbour array frequency dimension size - INTEGER, PRIVATE :: MK = -1 - !> Nearest neighbour array direction dimension size - INTEGER, PRIVATE :: MTH = -1 - !> Nearest neighbour array - INTEGER, ALLOCATABLE, PRIVATE :: NEIGH(:,:) -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> @brief Interface to watershed partitioning routines. -!> -!> @details Watershed Algorithm of Vincent and Soille, 1991, -!> implemented by Barbara Tracy (USACE/ERDC) for NOAA/NCEP. -!> -!> This version of W3PART contains alternate Met Office partitioning -!> methods, selected at runtime using the \c PTMETH namlist variable: -!> -# Standard WW3 partitioning, as per original method described -!> by Barbary Tracy. -!> -# Met Office extended partitioning using split-partitions -!> (removes the wind sea part of any swell partiton and combines -!> with total wind sea partition). -!> -# Met Office "wave systems" - no classification or combining of -!> wind sea partitions. All partitions output and ordered simply -!> by wave height. -!> -# Classic, simple wave age based partitioning generating -!> a single wind sea and swell partition. -!> -# 2-band partitioning; produces hi and low freqency band partitions -!> using a user-defined cutoff frequency (\c PTFCUT). -!> -!> @remarks -!> - \c DIMXP will always be of size 2 when using \c PTMETH 4 or 5. -!> -!> - To achieve minimum storage but guaranteed storage of all -!> partitions DIMXP = ((NK+1)/2) * ((NTH-1)/2) -!> unless specified otherwise below. -!> -!> @param[in] SPEC 2-D spectrum E(f,theta) -!> @param[in] UABS Wind speed -!> @param[in] UDIR Wind direction -!> @param[in] DEPTH Water depth -!> @param[in] WN Wavenumebers for each frequency -!> @param[out] NP Number of partitions found -!> (-1=Spectrum without minumum energy; -!> 0=Spectrum with minumum energy but no partitions) -!> @param[out] XP Parameters describing partitions. -!> Entry '0' contains entire spectrum -!> @param[in] DIMXP Second dimension of XP -!> -!> @author Barbara Tracey, H. L. Tolman, M. Szyszka, Chris Bunney -!> @date 23 Jul 2018 -!> - SUBROUTINE W3PART ( SPEC, UABS, UDIR, DEPTH, WN, NP, XP, DIMXP ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III USACE/NOAA | -!/ | Barbara Tracy | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 02-Dec-2010 ! -!/ +-----------------------------------+ -!/ -!/ 28-Oct-2006 : Origination. ( version 3.10 ) -!/ 02-Dec-2010 : Adding a mapping PMAP between ( version 3.14 ) -!/ original and combined partitions -!/ ( M. Szyszka ) -!/ -! 1. Purpose : -! -! Interface to watershed partitioning routines. -! -! 2. Method : -! -! Watershed Algorithm of Vincent and Soille, 1991, implemented by -! Barbara Tracy (USACE/ERDC) for NOAA/NCEP. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! SPEC R.A. I 2-D spectrum E(f,theta). -! UABS Real I Wind speed. -! UDIR Real I Wind direction. -! DEPTH Real I Water depth. -! WN R.A. I Wavenumebers for each frequency. -! NP Int. O Number of partitions. -! -1 : Spectrum without minumum energy. -! 0 : Spectrum with minumum energy. -! but no partitions. -! XP R.A. O Parameters describing partitions. -! Entry '0' contains entire spectrum. -! DIMXP Int. I Second dimension of XP. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! - To achieve minimum storage but guaranteed storage of all -! partitions DIMXP = ((NK+1)/2) * ((NTH-1)/2) unless specified -! otherwise below. -! -! This version of W3PART contains alternate Met Office partitioning -! methods, selected at runtime using the PTMETH namlist variable: -! 1) Standard WW3 partitioning -! 2) Met Office extended partitioning using split-partitions -! (removes the wind sea part of any swell partiton and combines -! with total wind sea partition). -! 3) Met Office "wave systems" - no classification or combining of -! wind sea partitions. All partitions output and ordered simply -! by wave height. -! 4) Classic, simple wave age based partitioning generating -! a single wind sea and swell partition. [DIMXP = 2] -! 5) 2-band partitioning; produces hi and low freqency band partitions -! using a user-defined cutoff frequency (PTFCUT). [DIMXP = 2] -! -! (Chris Bunney, UK Met Office, Jul 2018) -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS +MODULE W3PARTMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III USACE/NOAA | + !/ | Barbara Tracy | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Jul-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Nov-2006 : Origination. ( version 3.10 ) + !/ 02-Nov-2006 : Adding tail to integration. ( version 3.10 ) + !/ 24-Mar-2007 : Bug fix IMI, adding overall field ( version 3.11 ) + !/ and sorting. + !/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) + !/ 02-Dec-2010 : Adding a mapping PMAP between ( version 3.14 ) + !/ original and combined partitions + !/ ( M. Szyszka ) + !/ 23-Jul-2018 : Added alternative partitioning ( version 6.05 ) + !/ methods (C. Bunney, UKMO) + ! 1. Purpose : + ! + ! Spectral partitioning according to the watershed method. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! MK, MTH Int. Private Dimensions of stored neighour array. + ! NEIGH I.A. Private Nearest Neighbor array. + ! ---------------------------------------------------------------- + ! Note: IHMAX, HSPMIN, WSMULT, WSCUT and FLCOMB used from W3ODATMD. + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3PART Subr. Public Interface to watershed routines. + ! PTSORT Subr. Public Sort discretized image. + ! PTNGHB Subr. Public Defeine nearest neighbours. + ! PT_FLD Subr. Public Incremental flooding algorithm. + ! FIFO_ADD, FIFO_EMPTY, FIFO_FIRST + ! Subr. PT_FLD Queue management. + ! PTMEAN Subr. Public Compute mean parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine traceing. + ! WAVNU1 Subr. W3DISPMD Wavenumber computation. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3ODATMD, ONLY: IHMAX, HSPMIN, WSMULT, DIMP, PTMETH, PTFCUT + ! + PUBLIC + ! + !> Nearest neighbour array frequency dimension size + INTEGER, PRIVATE :: MK = -1 + !> Nearest neighbour array direction dimension size + INTEGER, PRIVATE :: MTH = -1 + !> Nearest neighbour array + INTEGER, ALLOCATABLE, PRIVATE :: NEIGH(:,:) + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> @brief Interface to watershed partitioning routines. + !> + !> @details Watershed Algorithm of Vincent and Soille, 1991, + !> implemented by Barbara Tracy (USACE/ERDC) for NOAA/NCEP. + !> + !> This version of W3PART contains alternate Met Office partitioning + !> methods, selected at runtime using the \c PTMETH namlist variable: + !> -# Standard WW3 partitioning, as per original method described + !> by Barbary Tracy. + !> -# Met Office extended partitioning using split-partitions + !> (removes the wind sea part of any swell partiton and combines + !> with total wind sea partition). + !> -# Met Office "wave systems" - no classification or combining of + !> wind sea partitions. All partitions output and ordered simply + !> by wave height. + !> -# Classic, simple wave age based partitioning generating + !> a single wind sea and swell partition. + !> -# 2-band partitioning; produces hi and low freqency band partitions + !> using a user-defined cutoff frequency (\c PTFCUT). + !> + !> @remarks + !> - \c DIMXP will always be of size 2 when using \c PTMETH 4 or 5. + !> + !> - To achieve minimum storage but guaranteed storage of all + !> partitions DIMXP = ((NK+1)/2) * ((NTH-1)/2) + !> unless specified otherwise below. + !> + !> @param[in] SPEC 2-D spectrum E(f,theta) + !> @param[in] UABS Wind speed + !> @param[in] UDIR Wind direction + !> @param[in] DEPTH Water depth + !> @param[in] WN Wavenumebers for each frequency + !> @param[out] NP Number of partitions found + !> (-1=Spectrum without minumum energy; + !> 0=Spectrum with minumum energy but no partitions) + !> @param[out] XP Parameters describing partitions. + !> Entry '0' contains entire spectrum + !> @param[in] DIMXP Second dimension of XP + !> + !> @author Barbara Tracey, H. L. Tolman, M. Szyszka, Chris Bunney + !> @date 23 Jul 2018 + !> + SUBROUTINE W3PART ( SPEC, UABS, UDIR, DEPTH, WN, NP, XP, DIMXP ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III USACE/NOAA | + !/ | Barbara Tracy | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 02-Dec-2010 ! + !/ +-----------------------------------+ + !/ + !/ 28-Oct-2006 : Origination. ( version 3.10 ) + !/ 02-Dec-2010 : Adding a mapping PMAP between ( version 3.14 ) + !/ original and combined partitions + !/ ( M. Szyszka ) + !/ + ! 1. Purpose : + ! + ! Interface to watershed partitioning routines. + ! + ! 2. Method : + ! + ! Watershed Algorithm of Vincent and Soille, 1991, implemented by + ! Barbara Tracy (USACE/ERDC) for NOAA/NCEP. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! SPEC R.A. I 2-D spectrum E(f,theta). + ! UABS Real I Wind speed. + ! UDIR Real I Wind direction. + ! DEPTH Real I Water depth. + ! WN R.A. I Wavenumebers for each frequency. + ! NP Int. O Number of partitions. + ! -1 : Spectrum without minumum energy. + ! 0 : Spectrum with minumum energy. + ! but no partitions. + ! XP R.A. O Parameters describing partitions. + ! Entry '0' contains entire spectrum. + ! DIMXP Int. I Second dimension of XP. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - To achieve minimum storage but guaranteed storage of all + ! partitions DIMXP = ((NK+1)/2) * ((NTH-1)/2) unless specified + ! otherwise below. + ! + ! This version of W3PART contains alternate Met Office partitioning + ! methods, selected at runtime using the PTMETH namlist variable: + ! 1) Standard WW3 partitioning + ! 2) Met Office extended partitioning using split-partitions + ! (removes the wind sea part of any swell partiton and combines + ! with total wind sea partition). + ! 3) Met Office "wave systems" - no classification or combining of + ! wind sea partitions. All partitions output and ordered simply + ! by wave height. + ! 4) Classic, simple wave age based partitioning generating + ! a single wind sea and swell partition. [DIMXP = 2] + ! 5) 2-band partitioning; produces hi and low freqency band partitions + ! using a user-defined cutoff frequency (PTFCUT). [DIMXP = 2] + ! + ! (Chris Bunney, UK Met Office, Jul 2018) + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH - USE W3ODATMD, ONLY: WSCUT, FLCOMB -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(OUT) :: NP - INTEGER, INTENT(IN) :: DIMXP - REAL, INTENT(IN) :: SPEC(NK,NTH), WN(NK), UABS, & - UDIR, DEPTH - REAL, INTENT(OUT) :: XP(DIMP,0:DIMXP) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IMI(NSPEC), IMD(NSPEC), & - IMO(NSPEC), IND(NSPEC), NP_MAX, & - IP, IT(1), INDEX(DIMXP), NWS, & - IPW, IPT, ISP - INTEGER :: PMAP(DIMXP) + ! + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH + USE W3ODATMD, ONLY: WSCUT, FLCOMB + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(OUT) :: NP + INTEGER, INTENT(IN) :: DIMXP + REAL, INTENT(IN) :: SPEC(NK,NTH), WN(NK), UABS, & + UDIR, DEPTH + REAL, INTENT(OUT) :: XP(DIMP,0:DIMXP) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IMI(NSPEC), IMD(NSPEC), & + IMO(NSPEC), IND(NSPEC), NP_MAX, & + IP, IT(1), INDEX(DIMXP), NWS, & + IPW, IPT, ISP + INTEGER :: PMAP(DIMXP) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: ZP(NSPEC), ZMIN, ZMAX, Z(NSPEC), & - FACT, WSMAX, HSMAX - REAL :: TP(DIMP,DIMXP) - INTEGER :: IK, WIND_PART ! ChrisB; added for new - REAL :: C, UPAR, SIGCUT ! UKMO partioning methods -!/ -!/ ------------------------------------------------------------------- / -! 0. Initializations -! + REAL :: ZP(NSPEC), ZMIN, ZMAX, Z(NSPEC), & + FACT, WSMAX, HSMAX + REAL :: TP(DIMP,DIMXP) + INTEGER :: IK, WIND_PART ! ChrisB; added for new + REAL :: C, UPAR, SIGCUT ! UKMO partioning methods + !/ + !/ ------------------------------------------------------------------- / + ! 0. Initializations + ! #ifdef W3_S - CALL STRACE (IENT, 'W3PART') + CALL STRACE (IENT, 'W3PART') #endif -! - NP = 0 - XP = 0. -! -! -------------------------------------------------------------------- / -! 1. Process input spectrum -! 1.a 2-D to 1-D spectrum -! - DO ITH=1, NTH - ZP(1+(ITH-1)*NK:ITH*NK) = SPEC(:,ITH) - END DO + ! + NP = 0 + XP = 0. + ! + ! -------------------------------------------------------------------- / + ! 1. Process input spectrum + ! 1.a 2-D to 1-D spectrum + ! + DO ITH=1, NTH + ZP(1+(ITH-1)*NK:ITH*NK) = SPEC(:,ITH) + END DO -! -! PTMETH == 4 : Do simple partitioning based solely on the -! wave age criterion (produces one swell and one wind sea only): -! - IF( PTMETH .EQ. 4 ) THEN - DO IK=1, NK - DO ITH=1, NTH - ISP = IK + (ITH-1) * NK ! index into partition array IMO + ! + ! PTMETH == 4 : Do simple partitioning based solely on the + ! wave age criterion (produces one swell and one wind sea only): + ! + IF( PTMETH .EQ. 4 ) THEN + DO IK=1, NK + DO ITH=1, NTH + ISP = IK + (ITH-1) * NK ! index into partition array IMO - UPAR = WSMULT * UABS * MAX(0.0, COS(TH(ITH)-DERA*UDIR)) - C = SIG(IK) / WN(IK) + UPAR = WSMULT * UABS * MAX(0.0, COS(TH(ITH)-DERA*UDIR)) + C = SIG(IK) / WN(IK) - IF( UPAR .LE. C ) THEN - ! Is swell: - IMO(ISP) = 2 - ELSE - ! Is wind sea: - IMO(ISP) = 1 - ENDIF - ENDDO + IF( UPAR .LE. C ) THEN + ! Is swell: + IMO(ISP) = 2 + ELSE + ! Is wind sea: + IMO(ISP) = 1 + ENDIF ENDDO + ENDDO - ! We have a max of up to two partitions: - NP_MAX=2 + ! We have a max of up to two partitions: + NP_MAX=2 - ! Calculate mean parameters: - CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & - NP, XP, DIMXP, PMAP ) + ! Calculate mean parameters: + CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & + NP, XP, DIMXP, PMAP ) - ! No more processing required, return: - RETURN - ENDIF ! PTMETH == 4 -! -! PTMETH == 5 : produce "high" and "low" band partitions -! using a frequency cutoff: -! - IF( PTMETH .EQ. 5 ) THEN - SIGCUT = TPI * PTFCUT - DO IK = 1, NK - ! If bin center <= freq cutoff then mark as "low band". - IF(SIG(IK) .LE. SIGCUT) THEN - IP = 2 - ELSE - IP = 1 - ENDIF - - DO ITH=1, NTH - ISP = IK + (ITH-1) * NK ! index into partition array IMO - IMO(ISP) = IP - ENDDO - ENDDO + ! No more processing required, return: + RETURN + ENDIF ! PTMETH == 4 + ! + ! PTMETH == 5 : produce "high" and "low" band partitions + ! using a frequency cutoff: + ! + IF( PTMETH .EQ. 5 ) THEN + SIGCUT = TPI * PTFCUT + DO IK = 1, NK + ! If bin center <= freq cutoff then mark as "low band". + IF(SIG(IK) .LE. SIGCUT) THEN + IP = 2 + ELSE + IP = 1 + ENDIF - ! We only ever have 2 partitions: - NP_MAX=2 + DO ITH=1, NTH + ISP = IK + (ITH-1) * NK ! index into partition array IMO + IMO(ISP) = IP + ENDDO + ENDDO - ! Calculate mean parameters: - CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & - NP, XP, DIMXP, PMAP ) + ! We only ever have 2 partitions: + NP_MAX=2 - ! No more processing required, return: - RETURN - ENDIF ! PTMETH == 5 -! -! 1.b Invert spectrum and 'digitize' -! - ZMIN = MINVAL ( ZP ) - ZMAX = MAXVAL ( ZP ) - IF ( ZMAX-ZMIN .LT. 1.E-9 ) RETURN -! - Z = ZMAX - ZP -! - FACT = REAL(IHMAX-1) / ( ZMAX - ZMIN ) - IMI = MAX ( 1 , MIN ( IHMAX , NINT ( 1. + Z*FACT ) ) ) -! -! 1.c Sort digitized image -! - CALL PTSORT ( IMI, IND, IHMAX ) -! -! -------------------------------------------------------------------- / -! 2. Perform partitioning -! 2.a Update nearest neighbor info as needed. -! - CALL PTNGHB -! -! 2.b Incremental flooding -! - CALL PT_FLD ( IMI, IND, IMO, ZP, NP_MAX ) -! -! 2.c Compute parameters per partition -! NP and NX initialized inside routine. -! + ! Calculate mean parameters: CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & - NP, XP, DIMXP, PMAP ) -! -! 2.d PTMETH == 2: move the wind sea part of the partitions into a -! seperate partition and recalculate the mean parameters. -! - IF ( NP .GT. 0 .AND. PTMETH .EQ. 2 ) THEN - WIND_PART = NP_MAX + NP, XP, DIMXP, PMAP ) - DO IK=1, NK - DO ITH=1, NTH - ISP = IK + (ITH-1) * NK ! index into partition array IMO - UPAR = WSMULT * UABS * MAX(0.0, COS(TH(ITH)-DERA*UDIR)) - C = SIG(IK) / WN(IK) + ! No more processing required, return: + RETURN + ENDIF ! PTMETH == 5 + ! + ! 1.b Invert spectrum and 'digitize' + ! + ZMIN = MINVAL ( ZP ) + ZMAX = MAXVAL ( ZP ) + IF ( ZMAX-ZMIN .LT. 1.E-9 ) RETURN + ! + Z = ZMAX - ZP + ! + FACT = REAL(IHMAX-1) / ( ZMAX - ZMIN ) + IMI = MAX ( 1 , MIN ( IHMAX , NINT ( 1. + Z*FACT ) ) ) + ! + ! 1.c Sort digitized image + ! + CALL PTSORT ( IMI, IND, IHMAX ) + ! + ! -------------------------------------------------------------------- / + ! 2. Perform partitioning + ! 2.a Update nearest neighbor info as needed. + ! + CALL PTNGHB + ! + ! 2.b Incremental flooding + ! + CALL PT_FLD ( IMI, IND, IMO, ZP, NP_MAX ) + ! + ! 2.c Compute parameters per partition + ! NP and NX initialized inside routine. + ! + CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & + NP, XP, DIMXP, PMAP ) + ! + ! 2.d PTMETH == 2: move the wind sea part of the partitions into a + ! seperate partition and recalculate the mean parameters. + ! + IF ( NP .GT. 0 .AND. PTMETH .EQ. 2 ) THEN + WIND_PART = NP_MAX - IF( C .LT. UPAR ) THEN - ! Bin is wind forced - mark as new wind partition: - WIND_PART = NP_MAX + 1 + DO IK=1, NK + DO ITH=1, NTH + ISP = IK + (ITH-1) * NK ! index into partition array IMO + UPAR = WSMULT * UABS * MAX(0.0, COS(TH(ITH)-DERA*UDIR)) + C = SIG(IK) / WN(IK) - ! Update status map to show new wind partition - IMO(ISP) = WIND_PART - ENDIF - ENDDO - ENDDO + IF( C .LT. UPAR ) THEN + ! Bin is wind forced - mark as new wind partition: + WIND_PART = NP_MAX + 1 - IF( WIND_PART .NE. NP_MAX ) THEN - ! Some bins were marked as wind sea - recalculate - ! integrated parameters: - NP_MAX = WIND_PART - CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & - NP, XP, DIMXP, PMAP ) + ! Update status map to show new wind partition + IMO(ISP) = WIND_PART ENDIF + ENDDO + ENDDO + + IF( WIND_PART .NE. NP_MAX ) THEN + ! Some bins were marked as wind sea - recalculate + ! integrated parameters: + NP_MAX = WIND_PART + CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & + NP, XP, DIMXP, PMAP ) ENDIF -! -! -------------------------------------------------------------------- / -! 3. Sort and recombine wind seas as needed -! 3.a Sort by wind sea fraction -! - IF ( NP .LE. 1 ) RETURN + ENDIF + ! + ! -------------------------------------------------------------------- / + ! 3. Sort and recombine wind seas as needed + ! 3.a Sort by wind sea fraction + ! + IF ( NP .LE. 1 ) RETURN + + ! ----------------------------------------------------------------- + ! PTMETH == 3: Don't classify or combine any partitions as wind sea. + ! Simply sort by HS and return. + ! ----------------------------------------------------------------- + IF( PTMETH .EQ. 3 ) THEN + TP(:,1:NP) = XP(:,1:NP) + XP(:,1:NP) = 0. + + DO IP=1, NP + IT = MAXLOC(TP(1,1:NP)) + XP(:,IP) = TP(:,IT(1)) + TP(1,IT(1)) = -1. + END DO - ! ----------------------------------------------------------------- - ! PTMETH == 3: Don't classify or combine any partitions as wind sea. - ! Simply sort by HS and return. - ! ----------------------------------------------------------------- - IF( PTMETH .EQ. 3 ) THEN - TP(:,1:NP) = XP(:,1:NP) - XP(:,1:NP) = 0. + RETURN ! Don't process any further + ENDIF ! PTMETH == 3 - DO IP=1, NP - IT = MAXLOC(TP(1,1:NP)) - XP(:,IP) = TP(:,IT(1)) - TP(1,IT(1)) = -1. + ! ----------------------------------------------------------------- + ! PTMETH == 1: Default WW3 partitioning. + ! ----------------------------------------------------------------- + TP(:,1:NP) = XP(:,1:NP) + XP(:,1:NP) = 0. + INDEX(1:NP) = 0 + NWS = 0 + ! + DO IP=1, NP + IT = MAXLOC(TP(6,1:NP)) + INDEX(IP) = IT(1) + XP(:,IP) = TP(:,INDEX(IP)) + IF ( TP(6,IT(1)) .GE. WSCUT ) NWS = NWS + 1 + TP(6,IT(1)) = -1. + END DO + ! + ! 3.b Combine wind seas as needed and resort + ! + IF ( NWS.GT.1 .AND. FLCOMB ) THEN + IPW = PMAP(INDEX(1)) + DO IP=2, NWS + IPT = PMAP(INDEX(IP)) + DO ISP=1, NSPEC + IF ( IMO(ISP) .EQ. IPT ) IMO(ISP) = IPW END DO - - RETURN ! Don't process any further - ENDIF ! PTMETH == 3 - - ! ----------------------------------------------------------------- - ! PTMETH == 1: Default WW3 partitioning. - ! ----------------------------------------------------------------- + END DO + ! + CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & + NP, XP, DIMXP, PMAP ) + IF ( NP .LE. 1 ) RETURN + ! TP(:,1:NP) = XP(:,1:NP) XP(:,1:NP) = 0. INDEX(1:NP) = 0 NWS = 0 -! + ! DO IP=1, NP IT = MAXLOC(TP(6,1:NP)) INDEX(IP) = IT(1) XP(:,IP) = TP(:,INDEX(IP)) IF ( TP(6,IT(1)) .GE. WSCUT ) NWS = NWS + 1 TP(6,IT(1)) = -1. - END DO -! -! 3.b Combine wind seas as needed and resort -! - IF ( NWS.GT.1 .AND. FLCOMB ) THEN - IPW = PMAP(INDEX(1)) - DO IP=2, NWS - IPT = PMAP(INDEX(IP)) - DO ISP=1, NSPEC - IF ( IMO(ISP) .EQ. IPT ) IMO(ISP) = IPW - END DO - END DO -! - CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & - NP, XP, DIMXP, PMAP ) - IF ( NP .LE. 1 ) RETURN -! - TP(:,1:NP) = XP(:,1:NP) - XP(:,1:NP) = 0. - INDEX(1:NP) = 0 - NWS = 0 -! - DO IP=1, NP - IT = MAXLOC(TP(6,1:NP)) - INDEX(IP) = IT(1) - XP(:,IP) = TP(:,INDEX(IP)) - IF ( TP(6,IT(1)) .GE. WSCUT ) NWS = NWS + 1 - TP(6,IT(1)) = -1. - END DO -! - END IF -! -! 3.c Sort remaining fields by wave height -! - NWS = MIN ( 1 , NWS ) -! - TP(:,1:NP) = XP(:,1:NP) - XP(:,1:NP) = 0. -! - IF ( NWS .GT. 0 ) THEN - XP(:,1) = TP(:,1) - TP(1,1) = -1. - NWS = 1 - END IF -! - DO IP=NWS+1, NP - IT = MAXLOC(TP(1,1:NP)) - XP(:,IP) = TP(:,IT(1)) - TP(1,IT(1)) = -1. - END DO -! -! -------------------------------------------------------------------- / -! 4. End of routine -! - RETURN -!/ -!/ End of W3PART ----------------------------------------------------- / -!/ - END SUBROUTINE W3PART -!/ ------------------------------------------------------------------- / -!> -!> @brief Sorts the image data in ascending order. -!> -!> @details This sort original to F. T. Tracy (2006) -!> -!> @param[in] IMI Input discretized spectrum -!> @param[out] IND Sorted data -!> @param[in] IHMAX Number of integer levels -!> -!> @author Barbara Tracy -!> @date 19 Oct 2006 -!> - SUBROUTINE PTSORT ( IMI, IND, IHMAX ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III USACE/NOAA | -!/ | Barbara Tracy | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 19-Oct-2006 ! -!/ +-----------------------------------+ -!/ -!/ 19-Oct-2006 : Origination. ( version 3.10 ) -!/ -! 1. Purpose : -! -! This subroutine sorts the image data in ascending order. -! This sort original to F.T.Tracy (2006) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMI I.A. I Input discretized spectrum. -! IND I.A. O Sorted data. -! IHMAX Int. I Number of integer levels. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! + END DO + ! + END IF + ! + ! 3.c Sort remaining fields by wave height + ! + NWS = MIN ( 1 , NWS ) + ! + TP(:,1:NP) = XP(:,1:NP) + XP(:,1:NP) = 0. + ! + IF ( NWS .GT. 0 ) THEN + XP(:,1) = TP(:,1) + TP(1,1) = -1. + NWS = 1 + END IF + ! + DO IP=NWS+1, NP + IT = MAXLOC(TP(1,1:NP)) + XP(:,IP) = TP(:,IT(1)) + TP(1,IT(1)) = -1. + END DO + ! + ! -------------------------------------------------------------------- / + ! 4. End of routine + ! + RETURN + !/ + !/ End of W3PART ----------------------------------------------------- / + !/ + END SUBROUTINE W3PART + !/ ------------------------------------------------------------------- / + !> + !> @brief Sorts the image data in ascending order. + !> + !> @details This sort original to F. T. Tracy (2006) + !> + !> @param[in] IMI Input discretized spectrum + !> @param[out] IND Sorted data + !> @param[in] IHMAX Number of integer levels + !> + !> @author Barbara Tracy + !> @date 19 Oct 2006 + !> + SUBROUTINE PTSORT ( IMI, IND, IHMAX ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III USACE/NOAA | + !/ | Barbara Tracy | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 19-Oct-2006 ! + !/ +-----------------------------------+ + !/ + !/ 19-Oct-2006 : Origination. ( version 3.10 ) + !/ + ! 1. Purpose : + ! + ! This subroutine sorts the image data in ascending order. + ! This sort original to F.T.Tracy (2006) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMI I.A. I Input discretized spectrum. + ! IND I.A. O Sorted data. + ! IHMAX Int. I Number of integer levels. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE W3GDATMD, ONLY: NSPEC -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IHMAX, IMI(NSPEC) - INTEGER, INTENT(OUT) :: IND(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, IN, IV + ! + USE W3GDATMD, ONLY: NSPEC + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IHMAX, IMI(NSPEC) + INTEGER, INTENT(OUT) :: IND(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, IN, IV #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: NUMV(IHMAX), IADDR(IHMAX), & - IORDER(NSPEC) -!/ + INTEGER :: NUMV(IHMAX), IADDR(IHMAX), & + IORDER(NSPEC) + !/ #ifdef W3_S - CALL STRACE (IENT, 'PTSORT') + CALL STRACE (IENT, 'PTSORT') #endif -! -! -------------------------------------------------------------------- / -! 1. Occurences per height -! - NUMV = 0 - DO I=1, NSPEC - NUMV(IMI(I)) = NUMV(IMI(I)) + 1 - END DO -! -! -------------------------------------------------------------------- / -! 2. Starting address per height -! - IADDR(1) = 1 - DO I=1, IHMAX-1 - IADDR(I+1) = IADDR(I) + NUMV(I) - END DO -! -! -------------------------------------------------------------------- / -! 3. Order points -! - DO I=1, NSPEC - IV = IMI(I) - IN = IADDR(IV) - IORDER(I) = IN - IADDR(IV) = IN + 1 - END DO -! -! -------------------------------------------------------------------- / -! 4. Sort points -! - DO I=1, NSPEC - IND(IORDER(I)) = I - END DO -! - RETURN -!/ -!/ End of PTSORT ----------------------------------------------------- / -!/ - END SUBROUTINE PTSORT -!/ ------------------------------------------------------------------- / -!> -!> @brief Nearest neighbour calculation -!> -!> @details -!> Computes the nearest neighbors for each grid point. Wrapping of -!> directional distribution (0 to 360) is taken care of using the -!> nearest neighbor system -!> -!> @param[in] IMI Input discretized spectrum -!> @param[out] IMD Sorted data -!> @param[in] IHMAX Number of integer levels -!> -!> @author Barbara Tracy -!> @date 20 Oct 2006 -!> - SUBROUTINE PTNGHB -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III USACE/NOAA | -!/ | Barbara Tracy | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 20-Oct-2006 ! -!/ +-----------------------------------+ -!/ -!/ 20-Oct-2006 : Origination. ( version 3.10 ) -!/ -! 1. Purpose : -! -! This subroutine computes the nearest neighbors for each grid -! point. Wrapping of directional distribution (0 to 360)is taken -! care of using the nearest neighbor system -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMI I.A. I Input discretized spectrum. -! IMD I.A. O Sorted data. -! IHMAX Int. I Number of integer levels. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NK, NTH, NSPEC -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -! INTEGER, INTENT(IN) :: IHMAX, IMI(NSPEC) -! INTEGER, INTENT(IN) :: IMD(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: N, J, I, K + ! + ! -------------------------------------------------------------------- / + ! 1. Occurences per height + ! + NUMV = 0 + DO I=1, NSPEC + NUMV(IMI(I)) = NUMV(IMI(I)) + 1 + END DO + ! + ! -------------------------------------------------------------------- / + ! 2. Starting address per height + ! + IADDR(1) = 1 + DO I=1, IHMAX-1 + IADDR(I+1) = IADDR(I) + NUMV(I) + END DO + ! + ! -------------------------------------------------------------------- / + ! 3. Order points + ! + DO I=1, NSPEC + IV = IMI(I) + IN = IADDR(IV) + IORDER(I) = IN + IADDR(IV) = IN + 1 + END DO + ! + ! -------------------------------------------------------------------- / + ! 4. Sort points + ! + DO I=1, NSPEC + IND(IORDER(I)) = I + END DO + ! + RETURN + !/ + !/ End of PTSORT ----------------------------------------------------- / + !/ + END SUBROUTINE PTSORT + !/ ------------------------------------------------------------------- / + !> + !> @brief Nearest neighbour calculation + !> + !> @details + !> Computes the nearest neighbors for each grid point. Wrapping of + !> directional distribution (0 to 360) is taken care of using the + !> nearest neighbor system + !> + !> @param[in] IMI Input discretized spectrum + !> @param[out] IMD Sorted data + !> @param[in] IHMAX Number of integer levels + !> + !> @author Barbara Tracy + !> @date 20 Oct 2006 + !> + SUBROUTINE PTNGHB + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III USACE/NOAA | + !/ | Barbara Tracy | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 20-Oct-2006 ! + !/ +-----------------------------------+ + !/ + !/ 20-Oct-2006 : Origination. ( version 3.10 ) + !/ + ! 1. Purpose : + ! + ! This subroutine computes the nearest neighbors for each grid + ! point. Wrapping of directional distribution (0 to 360)is taken + ! care of using the nearest neighbor system + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMI I.A. I Input discretized spectrum. + ! IMD I.A. O Sorted data. + ! IHMAX Int. I Number of integer levels. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + USE W3SERVMD, ONLY: STRACE #endif -!/ + ! + USE W3GDATMD, ONLY: NK, NTH, NSPEC + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + ! INTEGER, INTENT(IN) :: IHMAX, IMI(NSPEC) + ! INTEGER, INTENT(IN) :: IMD(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: N, J, I, K #ifdef W3_S - CALL STRACE (IENT, 'PTNGHB') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'PTNGHB') #endif -! -! -------------------------------------------------------------------- / -! 1. Check on need of processing -! - IF ( MK.EQ.NK .AND. MTH.EQ.NTH ) RETURN -! - IF ( MK.GT.0 ) DEALLOCATE ( NEIGH ) - ALLOCATE ( NEIGH(9,NSPEC) ) - MK = NK - MTH = NTH -! -! -------------------------------------------------------------------- / -! 2. Build map -! - NEIGH = 0 -! -! ... Base loop -! - DO N = 1, NSPEC -! - J = (N-1) / NK + 1 - I = N - (J-1) * NK - K = 0 -! -! ... Point at the left(1) -! - IF ( I .NE. 1 ) THEN - K = K + 1 - NEIGH(K, N) = N - 1 - END IF -! -! ... Point at the right (2) -! - IF ( I .NE. NK ) THEN - K = K + 1 - NEIGH(K, N) = N + 1 - END IF -! -! ... Point at the bottom(3) -! - IF ( J .NE. 1 ) THEN - K = K + 1 - NEIGH(K, N) = N - NK - END IF -! -! ... ADD Point at bottom_wrap to top -! - IF ( J .EQ. 1 ) THEN - K = K + 1 - NEIGH(K,N) = NSPEC - (NK-I) - END IF -! -! ... Point at the top(4) -! - IF ( J .NE. NTH ) THEN - K = K + 1 - NEIGH(K, N) = N + NK - END IF -! -! ... ADD Point to top_wrap to bottom -! - IF ( J .EQ. NTH ) THEN - K = K + 1 - NEIGH(K,N) = N - (NTH-1) * NK - END IF -! -! ... Point at the bottom, left(5) -! - IF ( (I.NE.1) .AND. (J.NE.1) ) THEN - K = K + 1 - NEIGH(K, N) = N - NK - 1 - END IF -! -! ... Point at the bottom, left with wrap. -! - IF ( (I.NE.1) .AND. (J.EQ.1) ) THEN - K = K + 1 - NEIGH(K,N) = N - 1 + NK * (NTH-1) - END IF -! -! ... Point at the bottom, right(6) -! - IF ( (I.NE.NK) .AND. (J.NE.1) ) THEN - K = K + 1 - NEIGH(K, N) = N - NK + 1 - END IF -! -! ... Point at the bottom, right with wrap -! - IF ( (I.NE.NK) .AND. (J.EQ.1) ) THEN - K = K + 1 - NEIGH(K,N) = N + 1 + NK * (NTH - 1) - END IF -! -! ... Point at the top, left(7) -! - IF ( (I.NE.1) .AND. (J.NE.NTH) ) THEN - K = K + 1 - NEIGH(K, N) = N + NK - 1 - END IF -! -! ... Point at the top, left with wrap -! - IF ( (I.NE.1) .AND. (J.EQ.NTH) ) THEN - K = K + 1 - NEIGH(K,N) = N - 1 - (NK) * (NTH-1) - END IF -! -! ... Point at the top, right(8) -! - IF ( (I.NE.NK) .AND. (J.NE.NTH) ) THEN - K = K + 1 - NEIGH(K, N) = N + NK + 1 - END IF -! -! ... Point at top, right with wrap -! -! - IF ( (I.NE.NK) .AND. (J.EQ.NTH) ) THEN - K = K + 1 - NEIGH(K,N) = N + 1 - (NK) * (NTH-1) - END IF -! - NEIGH(9,N) = K -! - END DO -! - RETURN -!/ -!/ End of PTNGHB ----------------------------------------------------- / -!/ - END SUBROUTINE PTNGHB -!/ ------------------------------------------------------------------- / -!> -!> @brief Image watersheding -!> -!> @details -!> This subroutine does incremental flooding of the image to -!> determine the watershed image. -!> -!> @param[in] IMI Input discretized spectrum -!> @param[in] IND Sorted addresses -!> @param[out] IMO Output partitioned spectrum -!> @param[in] ZP Spectral array -!> @param[out] NPART Number of partitions found -!> -!> @author H.L. Tolman -!> @date 01 Nov 2006 -!> - SUBROUTINE PT_FLD ( IMI, IND, IMO, ZP, NPART ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Nov-2006 ! -!/ +-----------------------------------+ -!/ -!/ 01-Nov-2006 : Origination. ( version 3.10 ) -!/ -! 1. Purpose : -! -! This subroutine does incremental flooding of the image to -! determine the watershed image. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMI I.A. I Input discretized spectrum. -! IND I.A. I Sorted addresses. -! IMO I.A. O Output partitioned spectrum. -! ZP R.A. I Spectral array. -! NPART Int. O Number of partitions found. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! + ! + ! -------------------------------------------------------------------- / + ! 1. Check on need of processing + ! + IF ( MK.EQ.NK .AND. MTH.EQ.NTH ) RETURN + ! + IF ( MK.GT.0 ) DEALLOCATE ( NEIGH ) + ALLOCATE ( NEIGH(9,NSPEC) ) + MK = NK + MTH = NTH + ! + ! -------------------------------------------------------------------- / + ! 2. Build map + ! + NEIGH = 0 + ! + ! ... Base loop + ! + DO N = 1, NSPEC + ! + J = (N-1) / NK + 1 + I = N - (J-1) * NK + K = 0 + ! + ! ... Point at the left(1) + ! + IF ( I .NE. 1 ) THEN + K = K + 1 + NEIGH(K, N) = N - 1 + END IF + ! + ! ... Point at the right (2) + ! + IF ( I .NE. NK ) THEN + K = K + 1 + NEIGH(K, N) = N + 1 + END IF + ! + ! ... Point at the bottom(3) + ! + IF ( J .NE. 1 ) THEN + K = K + 1 + NEIGH(K, N) = N - NK + END IF + ! + ! ... ADD Point at bottom_wrap to top + ! + IF ( J .EQ. 1 ) THEN + K = K + 1 + NEIGH(K,N) = NSPEC - (NK-I) + END IF + ! + ! ... Point at the top(4) + ! + IF ( J .NE. NTH ) THEN + K = K + 1 + NEIGH(K, N) = N + NK + END IF + ! + ! ... ADD Point to top_wrap to bottom + ! + IF ( J .EQ. NTH ) THEN + K = K + 1 + NEIGH(K,N) = N - (NTH-1) * NK + END IF + ! + ! ... Point at the bottom, left(5) + ! + IF ( (I.NE.1) .AND. (J.NE.1) ) THEN + K = K + 1 + NEIGH(K, N) = N - NK - 1 + END IF + ! + ! ... Point at the bottom, left with wrap. + ! + IF ( (I.NE.1) .AND. (J.EQ.1) ) THEN + K = K + 1 + NEIGH(K,N) = N - 1 + NK * (NTH-1) + END IF + ! + ! ... Point at the bottom, right(6) + ! + IF ( (I.NE.NK) .AND. (J.NE.1) ) THEN + K = K + 1 + NEIGH(K, N) = N - NK + 1 + END IF + ! + ! ... Point at the bottom, right with wrap + ! + IF ( (I.NE.NK) .AND. (J.EQ.1) ) THEN + K = K + 1 + NEIGH(K,N) = N + 1 + NK * (NTH - 1) + END IF + ! + ! ... Point at the top, left(7) + ! + IF ( (I.NE.1) .AND. (J.NE.NTH) ) THEN + K = K + 1 + NEIGH(K, N) = N + NK - 1 + END IF + ! + ! ... Point at the top, left with wrap + ! + IF ( (I.NE.1) .AND. (J.EQ.NTH) ) THEN + K = K + 1 + NEIGH(K,N) = N - 1 - (NK) * (NTH-1) + END IF + ! + ! ... Point at the top, right(8) + ! + IF ( (I.NE.NK) .AND. (J.NE.NTH) ) THEN + K = K + 1 + NEIGH(K, N) = N + NK + 1 + END IF + ! + ! ... Point at top, right with wrap + ! + ! + IF ( (I.NE.NK) .AND. (J.EQ.NTH) ) THEN + K = K + 1 + NEIGH(K,N) = N + 1 - (NK) * (NTH-1) + END IF + ! + NEIGH(9,N) = K + ! + END DO + ! + RETURN + !/ + !/ End of PTNGHB ----------------------------------------------------- / + !/ + END SUBROUTINE PTNGHB + !/ ------------------------------------------------------------------- / + !> + !> @brief Image watersheding + !> + !> @details + !> This subroutine does incremental flooding of the image to + !> determine the watershed image. + !> + !> @param[in] IMI Input discretized spectrum + !> @param[in] IND Sorted addresses + !> @param[out] IMO Output partitioned spectrum + !> @param[in] ZP Spectral array + !> @param[out] NPART Number of partitions found + !> + !> @author H.L. Tolman + !> @date 01 Nov 2006 + !> + SUBROUTINE PT_FLD ( IMI, IND, IMO, ZP, NPART ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Nov-2006 ! + !/ +-----------------------------------+ + !/ + !/ 01-Nov-2006 : Origination. ( version 3.10 ) + !/ + ! 1. Purpose : + ! + ! This subroutine does incremental flooding of the image to + ! determine the watershed image. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMI I.A. I Input discretized spectrum. + ! IND I.A. I Sorted addresses. + ! IMO I.A. O Output partitioned spectrum. + ! ZP R.A. I Spectral array. + ! NPART Int. O Number of partitions found. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE W3GDATMD, ONLY: NSPEC -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMI(NSPEC), IND(NSPEC) - INTEGER, INTENT(OUT) :: IMO(NSPEC), NPART - REAL, INTENT(IN) :: ZP(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: MASK, INIT, IWSHED, IMD(NSPEC), & - IC_LABEL, IFICT_PIXEL, M, IH, MSAVE, & - IP, I, IPP, IC_DIST, IEMPTY, IPPP, & - JL, JN, IPT, J - INTEGER :: IQ(NSPEC), IQ_START, IQ_END + ! + USE W3GDATMD, ONLY: NSPEC + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMI(NSPEC), IND(NSPEC) + INTEGER, INTENT(OUT) :: IMO(NSPEC), NPART + REAL, INTENT(IN) :: ZP(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: MASK, INIT, IWSHED, IMD(NSPEC), & + IC_LABEL, IFICT_PIXEL, M, IH, MSAVE, & + IP, I, IPP, IC_DIST, IEMPTY, IPPP, & + JL, JN, IPT, J + INTEGER :: IQ(NSPEC), IQ_START, IQ_END #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: ZPMAX, EP1, DIFF -!/ + REAL :: ZPMAX, EP1, DIFF + !/ #ifdef W3_S - CALL STRACE (IENT, 'PT_FLD') + CALL STRACE (IENT, 'PT_FLD') #endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! - MASK = -2 - INIT = -1 - IWSHED = 0 - IMO = INIT - IC_LABEL = 0 - IMD = 0 - IFICT_PIXEL = -100 -! - IQ_START = 1 - IQ_END = 1 -! - ZPMAX = MAXVAL ( ZP ) -! -! -------------------------------------------------------------------- / -! 1. Loop over levels -! - M = 1 -! - DO IH=1, IHMAX - MSAVE = M -! -! 1.a Pixels at level IH -! - DO - IP = IND(M) - IF ( IMI(IP) .NE. IH ) EXIT -! -! Flag the point, if it stays flagge, it is a separate minimum. -! - IMO(IP) = MASK -! -! Consider neighbors. If there is neighbor, set distance and add -! to queue. -! - DO I=1, NEIGH(9,IP) - IPP = NEIGH(I,IP) - IF ( (IMO(IPP).GT.0) .OR. (IMO(IPP).EQ.IWSHED) ) THEN - IMD(IP) = 1 - CALL FIFO_ADD (IP) - EXIT + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! + MASK = -2 + INIT = -1 + IWSHED = 0 + IMO = INIT + IC_LABEL = 0 + IMD = 0 + IFICT_PIXEL = -100 + ! + IQ_START = 1 + IQ_END = 1 + ! + ZPMAX = MAXVAL ( ZP ) + ! + ! -------------------------------------------------------------------- / + ! 1. Loop over levels + ! + M = 1 + ! + DO IH=1, IHMAX + MSAVE = M + ! + ! 1.a Pixels at level IH + ! + DO + IP = IND(M) + IF ( IMI(IP) .NE. IH ) EXIT + ! + ! Flag the point, if it stays flagge, it is a separate minimum. + ! + IMO(IP) = MASK + ! + ! Consider neighbors. If there is neighbor, set distance and add + ! to queue. + ! + DO I=1, NEIGH(9,IP) + IPP = NEIGH(I,IP) + IF ( (IMO(IPP).GT.0) .OR. (IMO(IPP).EQ.IWSHED) ) THEN + IMD(IP) = 1 + CALL FIFO_ADD (IP) + EXIT + END IF + END DO + ! + IF ( M+1 .GT. NSPEC ) THEN + EXIT + ELSE + M = M + 1 + END IF + ! + END DO + ! + ! 1.b Process the queue + ! + IC_DIST = 1 + CALL FIFO_ADD (IFICT_PIXEL) + ! + DO + CALL FIFO_FIRST (IP) + ! + ! Check for end of processing + ! + IF ( IP .EQ. IFICT_PIXEL ) THEN + CALL FIFO_EMPTY (IEMPTY) + IF ( IEMPTY .EQ. 1 ) THEN + EXIT + ELSE + CALL FIFO_ADD (IFICT_PIXEL) + IC_DIST = IC_DIST + 1 + CALL FIFO_FIRST (IP) + END IF + END IF + ! + ! Process queue + ! + DO I=1, NEIGH(9,IP) + IPP = NEIGH(I,IP) + ! + ! Check for labeled watersheds or basins + ! + IF ( (IMD(IPP).LT.IC_DIST) .AND. ( (IMO(IPP).GT.0) .OR. & + (IMO(IPP).EQ.IWSHED))) THEN + ! + IF ( IMO(IPP) .GT. 0 ) THEN + ! + IF ((IMO(IP) .EQ. MASK) .OR. (IMO(IP) .EQ. & + IWSHED)) THEN + IMO(IP) = IMO(IPP) + ELSE IF (IMO(IP) .NE. IMO(IPP)) THEN + IMO(IP) = IWSHED END IF - END DO -! - IF ( M+1 .GT. NSPEC ) THEN - EXIT - ELSE - M = M + 1 - END IF -! - END DO -! -! 1.b Process the queue -! - IC_DIST = 1 - CALL FIFO_ADD (IFICT_PIXEL) -! - DO - CALL FIFO_FIRST (IP) -! -! Check for end of processing -! - IF ( IP .EQ. IFICT_PIXEL ) THEN - CALL FIFO_EMPTY (IEMPTY) - IF ( IEMPTY .EQ. 1 ) THEN - EXIT - ELSE - CALL FIFO_ADD (IFICT_PIXEL) - IC_DIST = IC_DIST + 1 - CALL FIFO_FIRST (IP) - END IF + ! + ELSE IF (IMO(IP) .EQ. MASK) THEN + ! + IMO(IP) = IWSHED + ! END IF -! -! Process queue -! - DO I=1, NEIGH(9,IP) - IPP = NEIGH(I,IP) -! -! Check for labeled watersheds or basins -! - IF ( (IMD(IPP).LT.IC_DIST) .AND. ( (IMO(IPP).GT.0) .OR. & - (IMO(IPP).EQ.IWSHED))) THEN -! - IF ( IMO(IPP) .GT. 0 ) THEN -! - IF ((IMO(IP) .EQ. MASK) .OR. (IMO(IP) .EQ. & - IWSHED)) THEN - IMO(IP) = IMO(IPP) - ELSE IF (IMO(IP) .NE. IMO(IPP)) THEN - IMO(IP) = IWSHED - END IF -! - ELSE IF (IMO(IP) .EQ. MASK) THEN -! - IMO(IP) = IWSHED -! - END IF -! - ELSE IF ( (IMO(IPP).EQ.MASK) .AND. (IMD(IPP).EQ.0) ) THEN -! - IMD(IPP) = IC_DIST + 1 - CALL FIFO_ADD (IPP) -! + ! + ELSE IF ( (IMO(IPP).EQ.MASK) .AND. (IMD(IPP).EQ.0) ) THEN + ! + IMD(IPP) = IC_DIST + 1 + CALL FIFO_ADD (IPP) + ! + END IF + ! + END DO + ! + END DO + ! + ! 1.c Check for mask values in IMO to identify new basins + ! + M = MSAVE + ! + DO + IP = IND(M) + IF ( IMI(IP) .NE. IH ) EXIT + IMD(IP) = 0 + ! + IF (IMO(IP) .EQ. MASK) THEN + ! + ! ... New label for pixel + ! + IC_LABEL = IC_LABEL + 1 + CALL FIFO_ADD (IP) + IMO(IP) = IC_LABEL + ! + ! ... and all connected to it ... + ! + DO + CALL FIFO_EMPTY (IEMPTY) + IF ( IEMPTY .EQ. 1 ) EXIT + CALL FIFO_FIRST (IPP) + ! + DO I=1, NEIGH(9,IPP) + IPPP = NEIGH(I,IPP) + IF ( IMO(IPPP) .EQ. MASK ) THEN + CALL FIFO_ADD (IPPP) + IMO(IPPP) = IC_LABEL END IF -! END DO -! - END DO -! -! 1.c Check for mask values in IMO to identify new basins -! - M = MSAVE -! - DO - IP = IND(M) - IF ( IMI(IP) .NE. IH ) EXIT - IMD(IP) = 0 -! - IF (IMO(IP) .EQ. MASK) THEN -! -! ... New label for pixel -! - IC_LABEL = IC_LABEL + 1 - CALL FIFO_ADD (IP) - IMO(IP) = IC_LABEL -! -! ... and all connected to it ... -! - DO - CALL FIFO_EMPTY (IEMPTY) - IF ( IEMPTY .EQ. 1 ) EXIT - CALL FIFO_FIRST (IPP) -! - DO I=1, NEIGH(9,IPP) - IPPP = NEIGH(I,IPP) - IF ( IMO(IPPP) .EQ. MASK ) THEN - CALL FIFO_ADD (IPPP) - IMO(IPPP) = IC_LABEL - END IF - END DO -! - END DO -! - END IF -! - IF ( M + 1 .GT. NSPEC ) THEN - EXIT - ELSE - M = M + 1 - END IF -! + ! END DO -! - END DO -! -! -------------------------------------------------------------------- / -! 2. Find nearest neighbor of 0 watershed points and replace -! use original input to check which group to affiliate with 0 -! Soring changes first in IMD to assure symetry in adjustment. -! - DO J=1, 5 - IMD = IMO - DO JL=1 , NSPEC - IPT = -1 - IF ( IMO(JL) .EQ. 0 ) THEN - EP1 = ZPMAX - DO JN=1, NEIGH (9,JL) - DIFF = ABS ( ZP(JL) - ZP(NEIGH(JN,JL))) - IF ( (DIFF.LE.EP1) .AND. (IMO(NEIGH(JN,JL)).NE.0) ) THEN - EP1 = DIFF - IPT = JN - END IF - END DO - IF ( IPT .GT. 0 ) IMD(JL) = IMO(NEIGH(IPT,JL)) + ! + END IF + ! + IF ( M + 1 .GT. NSPEC ) THEN + EXIT + ELSE + M = M + 1 + END IF + ! + END DO + ! + END DO + ! + ! -------------------------------------------------------------------- / + ! 2. Find nearest neighbor of 0 watershed points and replace + ! use original input to check which group to affiliate with 0 + ! Soring changes first in IMD to assure symetry in adjustment. + ! + DO J=1, 5 + IMD = IMO + DO JL=1 , NSPEC + IPT = -1 + IF ( IMO(JL) .EQ. 0 ) THEN + EP1 = ZPMAX + DO JN=1, NEIGH (9,JL) + DIFF = ABS ( ZP(JL) - ZP(NEIGH(JN,JL))) + IF ( (DIFF.LE.EP1) .AND. (IMO(NEIGH(JN,JL)).NE.0) ) THEN + EP1 = DIFF + IPT = JN END IF END DO - IMO = IMD - IF ( MINVAL(IMO) .GT. 0 ) EXIT - END DO -! - NPART = IC_LABEL -! - RETURN -! - CONTAINS -!/ ------------------------------------------------------------------- / -!> @brief Add point to FIFO queue -!> -!> @param[in] IV Point to add -!> -!> @author Barbara Tracy -!> @date 01 Nov 2006 - SUBROUTINE FIFO_ADD ( IV ) + IF ( IPT .GT. 0 ) IMD(JL) = IMO(NEIGH(IPT,JL)) + END IF + END DO + IMO = IMD + IF ( MINVAL(IMO) .GT. 0 ) EXIT + END DO + ! + NPART = IC_LABEL + ! + RETURN + ! + CONTAINS + !/ ------------------------------------------------------------------- / + !> @brief Add point to FIFO queue + !> + !> @param[in] IV Point to add + !> + !> @author Barbara Tracy + !> @date 01 Nov 2006 + SUBROUTINE FIFO_ADD ( IV ) INTEGER, INTENT(IN) :: IV -! + ! IQ(IQ_END) = IV -! + ! IQ_END = IQ_END + 1 IF ( IQ_END .GT. NSPEC ) IQ_END = 1 -! + ! RETURN END SUBROUTINE FIFO_ADD -!/ ------------------------------------------------------------------- / -!> @brief Check if queue is empty. -!> -!> @param[out] IEMPTY Set to 1 if queue is empty, else 0 -!> -!> @author Barbara Tracy -!> @date 01 Nov 2006 -!> - SUBROUTINE FIFO_EMPTY ( IEMPTY ) + !/ ------------------------------------------------------------------- / + !> @brief Check if queue is empty. + !> + !> @param[out] IEMPTY Set to 1 if queue is empty, else 0 + !> + !> @author Barbara Tracy + !> @date 01 Nov 2006 + !> + SUBROUTINE FIFO_EMPTY ( IEMPTY ) INTEGER, INTENT(OUT) :: IEMPTY -! + ! IF ( IQ_START .NE. IQ_END ) THEN IEMPTY = 0 ELSE IEMPTY = 1 END IF -! + ! RETURN END SUBROUTINE FIFO_EMPTY -!/ ------------------------------------------------------------------- / -!> @brief Get point out of queue. -!> -!> @param[out] IV Returned point -!> -!> @author Barbara Tracy -!> @date 01 Nov 2006 -!> - SUBROUTINE FIFO_FIRST ( IV ) + !/ ------------------------------------------------------------------- / + !> @brief Get point out of queue. + !> + !> @param[out] IV Returned point + !> + !> @author Barbara Tracy + !> @date 01 Nov 2006 + !> + SUBROUTINE FIFO_FIRST ( IV ) INTEGER, INTENT(OUT) :: IV -! + ! IV = IQ(IQ_START) -! + ! IQ_START = IQ_START + 1 IF ( IQ_START .GT. NSPEC ) IQ_START = 1 -! + ! RETURN END SUBROUTINE FIFO_FIRST -!/ -!/ End of PT_FLD ----------------------------------------------------- / -!/ - END SUBROUTINE PT_FLD -!/ ------------------------------------------------------------------- / -!> @brief Compute mean parameters per partition -!> -!> @param[in] NPI Number of partitions found. -!> @param[in] IMO Partition map. -!> @param[in] ZP Input spectrum. -!> @param[in] DEPTH Water depth. -!> @param[in] UABS Wind speed. -!> @param[in] UDIR Wind direction. -!> @param[in] WN Wavenumebers for each frequency. -!> @param[out] NPO Number of partitions with mean parameters. -!> @param[out] XP Array with output parameters. -!> @param[in] DIMXP Second dimension of XP. -!> @param[out] PMAP Mapping between orig. and combined partitions -!> -!> @author Barbara Tracy, H. L. Tolman, M. Szyszka, C. Bunney -!> @date 02 Dec 2010 -!> - SUBROUTINE PTMEAN ( NPI, IMO, ZP, DEPTH, UABS, UDIR, WN, & - NPO, XP, DIMXP, PMAP ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III USACE/NOAA | -!/ | Barbara Tracy | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 02-Dec-2010 ! -!/ +-----------------------------------+ -!/ -!/ 28-Oct-2006 : Origination. ( version 3.10 ) -!/ 02-Nov-2006 : Adding tail to integration. ( version 3.10 ) -!/ 24-Mar-2007 : Adding overall field. ( version 3.11 ) -!/ 02-Dec-2010 : Adding a mapping PMAP between ( version 3.14 ) -!/ original and combined partitions -!/ ( M. Szyszka ) -!/ -! 1. Purpose : -! -! Compute mean parameters per partition. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NPI Int. I Number of partitions found. -! IMO I.A. I Partition map. -! ZP R.A. I Input spectrum. -! DEPTH Real I Water depth. -! UABS Real I Wind speed. -! UDIR Real I Wind direction. -! WN R.A. I Wavenumebers for each frequency. -! NPO Int. O Number of partitions with mean parameters. -! XP R.A. O Array with output parameters. -! DIMXP int. I Second dimension of XP. -! PMAP I.A. O Mapping between orig. and combined partitions -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! WAVNU1 Subr. W3DISPMD Wavenumber computation. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE CONSTANTS + !/ + !/ End of PT_FLD ----------------------------------------------------- / + !/ + END SUBROUTINE PT_FLD + !/ ------------------------------------------------------------------- / + !> @brief Compute mean parameters per partition + !> + !> @param[in] NPI Number of partitions found. + !> @param[in] IMO Partition map. + !> @param[in] ZP Input spectrum. + !> @param[in] DEPTH Water depth. + !> @param[in] UABS Wind speed. + !> @param[in] UDIR Wind direction. + !> @param[in] WN Wavenumebers for each frequency. + !> @param[out] NPO Number of partitions with mean parameters. + !> @param[out] XP Array with output parameters. + !> @param[in] DIMXP Second dimension of XP. + !> @param[out] PMAP Mapping between orig. and combined partitions + !> + !> @author Barbara Tracy, H. L. Tolman, M. Szyszka, C. Bunney + !> @date 02 Dec 2010 + !> + SUBROUTINE PTMEAN ( NPI, IMO, ZP, DEPTH, UABS, UDIR, WN, & + NPO, XP, DIMXP, PMAP ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III USACE/NOAA | + !/ | Barbara Tracy | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 02-Dec-2010 ! + !/ +-----------------------------------+ + !/ + !/ 28-Oct-2006 : Origination. ( version 3.10 ) + !/ 02-Nov-2006 : Adding tail to integration. ( version 3.10 ) + !/ 24-Mar-2007 : Adding overall field. ( version 3.11 ) + !/ 02-Dec-2010 : Adding a mapping PMAP between ( version 3.14 ) + !/ original and combined partitions + !/ ( M. Szyszka ) + !/ + ! 1. Purpose : + ! + ! Compute mean parameters per partition. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NPI Int. I Number of partitions found. + ! IMO I.A. I Partition map. + ! ZP R.A. I Input spectrum. + ! DEPTH Real I Water depth. + ! UABS Real I Wind speed. + ! UDIR Real I Wind direction. + ! WN R.A. I Wavenumebers for each frequency. + ! NPO Int. O Number of partitions with mean parameters. + ! XP R.A. O Array with output parameters. + ! DIMXP int. I Second dimension of XP. + ! PMAP I.A. O Mapping between orig. and combined partitions + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! WAVNU1 Subr. W3DISPMD Wavenumber computation. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE CONSTANTS #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3DISPMD, ONLY: WAVNU1 -! - USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG, DSII, DSIP, & - ECOS, ESIN, XFR, FACHFE, TH, FTE - USE W3ODATMD, ONLY: IAPROC, NAPERR, NDSE, NDST -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NPI, IMO(NSPEC), DIMXP - INTEGER, INTENT(OUT) :: NPO, PMAP(DIMXP) - REAL, INTENT(IN) :: ZP(NSPEC), DEPTH, UABS, UDIR, WN(NK) - REAL, INTENT(OUT) :: XP(DIMP,0:DIMXP) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IK, ITH, ISP, IP, IFPMAX(0:NPI) + USE W3DISPMD, ONLY: WAVNU1 + ! + USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG, DSII, DSIP, & + ECOS, ESIN, XFR, FACHFE, TH, FTE + USE W3ODATMD, ONLY: IAPROC, NAPERR, NDSE, NDST + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NPI, IMO(NSPEC), DIMXP + INTEGER, INTENT(OUT) :: NPO, PMAP(DIMXP) + REAL, INTENT(IN) :: ZP(NSPEC), DEPTH, UABS, UDIR, WN(NK) + REAL, INTENT(OUT) :: XP(DIMP,0:DIMXP) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IK, ITH, ISP, IP, IFPMAX(0:NPI) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: SUMF(0:NK+1,0:NPI), SUMFW(NK,0:NPI), & - SUMFX(NK,0:NPI), SUMFY(NK,0:NPI), & - SUME(0:NPI), SUMEW(0:NPI), & - SUMEX(0:NPI), SUMEY(0:NPI), & - EFPMAX(0:NPI), FCDIR(NTH) - REAL,DIMENSION(0:NPI) :: SUME1, SUME2, SUMEM1, SUMQP - REAL :: HS, XL, XH, XL2, XH2, EL, EH, DENOM, & - SIGP, WNP, CGP, UPAR, C(NK), RD, FACT - REAL :: QP, M0, M1, M2, MM1, FSPRD, EPM_FP, ALP_PM - REAL :: Y, YHAT, XHAT, SUMXY, SUMYLOGY, NUMER,& - SUMY, SUMXXY, SUMXYLOGY, SUMEXP, SUMEYP - REAL :: FTEII -!/ + REAL :: SUMF(0:NK+1,0:NPI), SUMFW(NK,0:NPI), & + SUMFX(NK,0:NPI), SUMFY(NK,0:NPI), & + SUME(0:NPI), SUMEW(0:NPI), & + SUMEX(0:NPI), SUMEY(0:NPI), & + EFPMAX(0:NPI), FCDIR(NTH) + REAL,DIMENSION(0:NPI) :: SUME1, SUME2, SUMEM1, SUMQP + REAL :: HS, XL, XH, XL2, XH2, EL, EH, DENOM, & + SIGP, WNP, CGP, UPAR, C(NK), RD, FACT + REAL :: QP, M0, M1, M2, MM1, FSPRD, EPM_FP, ALP_PM + REAL :: Y, YHAT, XHAT, SUMXY, SUMYLOGY, NUMER,& + SUMY, SUMXXY, SUMXYLOGY, SUMEXP, SUMEYP + REAL :: FTEII + !/ #ifdef W3_S - CALL STRACE (IENT, 'PTMEAN') + CALL STRACE (IENT, 'PTMEAN') #endif -! -! -------------------------------------------------------------------- / -! 1. Check on need of processing -! - NPO = 0 - XP = 0. -! - IF ( NPI .EQ. 0 ) RETURN -! -! -------------------------------------------------------------------- / -! 2. Initialize arrays -! - SUMF = 0. - SUMFW = 0. - SUMFX = 0. - SUMFY = 0. - SUME = 0. -! - SUME1 = 0. !/ first spectral moment - SUME2 = 0. !/ second spectral moment - SUMEM1 = 0. !/ inverse spectral moment - SUMQP = 0. !/ peakedness parameter -! - SUMEW = 0. - SUMEX = 0. - SUMEY = 0. - IFPMAX = 0 - EFPMAX = 0. -! - DO IK=1, NK - C(IK) = SIG(IK) / WN(IK) + ! + ! -------------------------------------------------------------------- / + ! 1. Check on need of processing + ! + NPO = 0 + XP = 0. + ! + IF ( NPI .EQ. 0 ) RETURN + ! + ! -------------------------------------------------------------------- / + ! 2. Initialize arrays + ! + SUMF = 0. + SUMFW = 0. + SUMFX = 0. + SUMFY = 0. + SUME = 0. + ! + SUME1 = 0. !/ first spectral moment + SUME2 = 0. !/ second spectral moment + SUMEM1 = 0. !/ inverse spectral moment + SUMQP = 0. !/ peakedness parameter + ! + SUMEW = 0. + SUMEX = 0. + SUMEY = 0. + IFPMAX = 0 + EFPMAX = 0. + ! + DO IK=1, NK + C(IK) = SIG(IK) / WN(IK) + END DO + ! + DO ITH=1, NTH + UPAR = WSMULT * UABS * MAX(0.,COS(TH(ITH)-DERA*UDIR)) + IF ( UPAR .LT. C(NK) ) THEN + FCDIR(ITH) = SIG(NK+1) + ELSE + DO IK=NK-1, 2, -1 + IF ( UPAR .LT. C(IK) ) EXIT END DO -! + RD = (C(IK)-UPAR) / (C(IK)-C(IK+1)) + IF ( RD .LT. 0 ) THEN + IK = 0 + RD = MAX ( 0., RD+1. ) + END IF + FCDIR(ITH) = RD*SIG(IK+1) + (1.-RD)*SIG(IK) + END IF + END DO + ! + ! -------------------------------------------------------------------- / + ! 3. Spectral integrals and preps + ! 3.a Integrals + ! NOTE: Factor DTH only used in Hs computation. + ! + DO IK=1, NK DO ITH=1, NTH - UPAR = WSMULT * UABS * MAX(0.,COS(TH(ITH)-DERA*UDIR)) - IF ( UPAR .LT. C(NK) ) THEN - FCDIR(ITH) = SIG(NK+1) - ELSE - DO IK=NK-1, 2, -1 - IF ( UPAR .LT. C(IK) ) EXIT - END DO - RD = (C(IK)-UPAR) / (C(IK)-C(IK+1)) - IF ( RD .LT. 0 ) THEN - IK = 0 - RD = MAX ( 0., RD+1. ) - END IF - FCDIR(ITH) = RD*SIG(IK+1) + (1.-RD)*SIG(IK) - END IF - END DO -! -! -------------------------------------------------------------------- / -! 3. Spectral integrals and preps -! 3.a Integrals -! NOTE: Factor DTH only used in Hs computation. -! + ISP = IK + (ITH-1)*NK + IP = IMO(ISP) + FACT = MAX ( 0. , MIN ( 1. , & + 1. - ( FCDIR(ITH) - 0.5*(SIG(IK-1)+SIG(IK)) ) / DSIP(IK) ) ) + SUMF (IK, 0) = SUMF (IK, 0) + ZP(ISP) + SUMFW(IK, 0) = SUMFW(IK, 0) + ZP(ISP) * FACT + SUMFX(IK, 0) = SUMFX(IK, 0) + ZP(ISP) * ECOS(ITH) + SUMFY(IK, 0) = SUMFY(IK, 0) + ZP(ISP) * ESIN(ITH) + IF ( IP .EQ. 0 ) CYCLE + SUMF (IK,IP) = SUMF (IK,IP) + ZP(ISP) + SUMFW(IK,IP) = SUMFW(IK,IP) + ZP(ISP) * FACT + SUMFX(IK,IP) = SUMFX(IK,IP) + ZP(ISP) * ECOS(ITH) + SUMFY(IK,IP) = SUMFY(IK,IP) + ZP(ISP) * ESIN(ITH) + END DO + END DO + SUMF(NK+1,:) = SUMF(NK,:) * FACHFE + ! + DO IP=0, NPI DO IK=1, NK - DO ITH=1, NTH - ISP = IK + (ITH-1)*NK - IP = IMO(ISP) - FACT = MAX ( 0. , MIN ( 1. , & - 1. - ( FCDIR(ITH) - 0.5*(SIG(IK-1)+SIG(IK)) ) / DSIP(IK) ) ) - SUMF (IK, 0) = SUMF (IK, 0) + ZP(ISP) - SUMFW(IK, 0) = SUMFW(IK, 0) + ZP(ISP) * FACT - SUMFX(IK, 0) = SUMFX(IK, 0) + ZP(ISP) * ECOS(ITH) - SUMFY(IK, 0) = SUMFY(IK, 0) + ZP(ISP) * ESIN(ITH) - IF ( IP .EQ. 0 ) CYCLE - SUMF (IK,IP) = SUMF (IK,IP) + ZP(ISP) - SUMFW(IK,IP) = SUMFW(IK,IP) + ZP(ISP) * FACT - SUMFX(IK,IP) = SUMFX(IK,IP) + ZP(ISP) * ECOS(ITH) - SUMFY(IK,IP) = SUMFY(IK,IP) + ZP(ISP) * ESIN(ITH) - END DO - END DO - SUMF(NK+1,:) = SUMF(NK,:) * FACHFE -! - DO IP=0, NPI - DO IK=1, NK - SUME (IP) = SUME (IP) + SUMF (IK,IP) * DSII(IK) - SUMQP(IP) = SUMQP(IP) + SUMF (IK,IP)**2 * DSII(IK) * SIG(IK) - SUME1(IP) = SUME1(IP) + SUMF (IK,IP) * DSII(IK) * SIG(IK) - SUME2(IP) = SUME2(IP) + SUMF (IK,IP) * DSII(IK) * SIG(IK)**2 - SUMEM1(IP) = SUMEM1(IP) + SUMF (IK,IP) * DSII(IK) / SIG(IK) + SUME (IP) = SUME (IP) + SUMF (IK,IP) * DSII(IK) + SUMQP(IP) = SUMQP(IP) + SUMF (IK,IP)**2 * DSII(IK) * SIG(IK) + SUME1(IP) = SUME1(IP) + SUMF (IK,IP) * DSII(IK) * SIG(IK) + SUME2(IP) = SUME2(IP) + SUMF (IK,IP) * DSII(IK) * SIG(IK)**2 + SUMEM1(IP) = SUMEM1(IP) + SUMF (IK,IP) * DSII(IK) / SIG(IK) - SUMEW(IP) = SUMEW(IP) + SUMFW(IK,IP) * DSII(IK) - SUMEX(IP) = SUMEX(IP) + SUMFX(IK,IP) * DSII(IK) - SUMEY(IP) = SUMEY(IP) + SUMFY(IK,IP) * DSII(IK) - IF ( SUMF(IK,IP) .GT. EFPMAX(IP) ) THEN - IFPMAX(IP) = IK - EFPMAX(IP) = SUMF(IK,IP) - END IF - END DO + SUMEW(IP) = SUMEW(IP) + SUMFW(IK,IP) * DSII(IK) + SUMEX(IP) = SUMEX(IP) + SUMFX(IK,IP) * DSII(IK) + SUMEY(IP) = SUMEY(IP) + SUMFY(IK,IP) * DSII(IK) + IF ( SUMF(IK,IP) .GT. EFPMAX(IP) ) THEN + IFPMAX(IP) = IK + EFPMAX(IP) = SUMF(IK,IP) + END IF + END DO - !SUME (IP) = SUME (IP) + SUMF (NK,IP) * FTE - !SUME1(IP) = SUME1(IP) + SUMF (NK,IP) * FTE - !SUME2(IP) = SUME2(IP) + SUMF (NK,IP) * FTE - !SUMEM1(IP) = SUMEM1(IP) + SUMF (NK,IP) * FTE - !SUMQP(IP) = SUMQP(IP) + SUMF (NK,IP) * FTE - !SUMEW(IP) = SUMEW(IP) + SUMFW(NK,IP) * FTE - !SUMEX(IP) = SUMEX(IP) + SUMFX(NK,IP) * FTE - !SUMEY(IP) = SUMEY(IP) + SUMFY(NK,IP) * FTE - ! Met Office: Proposed bugfix for tail calculations, previously - ! PT1 and PT2 values were found to be too low when using the - ! FTE scaling factor for the tail. I think there are two issues: - ! 1. energy spectrum is scaled in radian frequency space above by DSII. - ! This needs to be consistent and FTE contains a DTH*SIG(NK) - ! factor that is not used in the DSII scaled calcs above - ! 2. the tail fit calcs for period parameters needs to follow - ! the form used in w3iogomd and scaling should be - ! based on the relationship between FTE and FT1, FTTR etc. - ! as per w3iogomd and ww3_grid - FTEII = FTE / (DTH * SIG(NK)) - SUME (IP) = SUME (IP) + SUMF (NK,IP) * FTEII - SUME1(IP) = SUME1(IP) + SUMF (NK,IP) * SIG(NK) * FTEII * (0.3333 / 0.25) - SUME2(IP) = SUME2(IP) + SUMF (NK,IP) * SIG(NK)**2 * FTEII * (0.5 / 0.25) - SUMEM1(IP) = SUMEM1(IP) + SUMF (NK,IP) / SIG(NK) * FTEII * (0.2 / 0.25) - SUMQP(IP) = SUMQP(IP) + SUMF (NK,IP) * FTEII - SUMEW(IP) = SUMEW(IP) + SUMFW(NK,IP) * FTEII - SUMEX(IP) = SUMEX(IP) + SUMFX(NK,IP) * FTEII - SUMEY(IP) = SUMEY(IP) + SUMFY(NK,IP) * FTEII + !SUME (IP) = SUME (IP) + SUMF (NK,IP) * FTE + !SUME1(IP) = SUME1(IP) + SUMF (NK,IP) * FTE + !SUME2(IP) = SUME2(IP) + SUMF (NK,IP) * FTE + !SUMEM1(IP) = SUMEM1(IP) + SUMF (NK,IP) * FTE + !SUMQP(IP) = SUMQP(IP) + SUMF (NK,IP) * FTE + !SUMEW(IP) = SUMEW(IP) + SUMFW(NK,IP) * FTE + !SUMEX(IP) = SUMEX(IP) + SUMFX(NK,IP) * FTE + !SUMEY(IP) = SUMEY(IP) + SUMFY(NK,IP) * FTE + ! Met Office: Proposed bugfix for tail calculations, previously + ! PT1 and PT2 values were found to be too low when using the + ! FTE scaling factor for the tail. I think there are two issues: + ! 1. energy spectrum is scaled in radian frequency space above by DSII. + ! This needs to be consistent and FTE contains a DTH*SIG(NK) + ! factor that is not used in the DSII scaled calcs above + ! 2. the tail fit calcs for period parameters needs to follow + ! the form used in w3iogomd and scaling should be + ! based on the relationship between FTE and FT1, FTTR etc. + ! as per w3iogomd and ww3_grid + FTEII = FTE / (DTH * SIG(NK)) + SUME (IP) = SUME (IP) + SUMF (NK,IP) * FTEII + SUME1(IP) = SUME1(IP) + SUMF (NK,IP) * SIG(NK) * FTEII * (0.3333 / 0.25) + SUME2(IP) = SUME2(IP) + SUMF (NK,IP) * SIG(NK)**2 * FTEII * (0.5 / 0.25) + SUMEM1(IP) = SUMEM1(IP) + SUMF (NK,IP) / SIG(NK) * FTEII * (0.2 / 0.25) + SUMQP(IP) = SUMQP(IP) + SUMF (NK,IP) * FTEII + SUMEW(IP) = SUMEW(IP) + SUMFW(NK,IP) * FTEII + SUMEX(IP) = SUMEX(IP) + SUMFX(NK,IP) * FTEII + SUMEY(IP) = SUMEY(IP) + SUMFY(NK,IP) * FTEII - END DO -! -! -------------------------------------------------------------------- / -! 4. Compute pars -! - NPO = -1 -! - DO IP=0, NPI -! - SUMEXP = 0. - SUMEYP = 0. -! - M0 = SUME(IP) * DTH * TPIINV - HS = 4. * SQRT ( MAX( M0 , 0. ) ) - IF ( HS .LT. HSPMIN ) THEN - ! For wind cutoff and 2-band partitioning methods, keep the - ! partition, but set the integrated parameters to UNDEF - ! for Hs values less that HSPMIN: - IF( PTMETH .EQ. 4 .OR. PTMETH .EQ. 5 ) THEN - NPO = NPO + 1 - XP(:,NPO) = UNDEF - XP(6,NPO) = 0.0 ! Set wind sea frac to zero - ENDIF - CYCLE + END DO + ! + ! -------------------------------------------------------------------- / + ! 4. Compute pars + ! + NPO = -1 + ! + DO IP=0, NPI + ! + SUMEXP = 0. + SUMEYP = 0. + ! + M0 = SUME(IP) * DTH * TPIINV + HS = 4. * SQRT ( MAX( M0 , 0. ) ) + IF ( HS .LT. HSPMIN ) THEN + ! For wind cutoff and 2-band partitioning methods, keep the + ! partition, but set the integrated parameters to UNDEF + ! for Hs values less that HSPMIN: + IF( PTMETH .EQ. 4 .OR. PTMETH .EQ. 5 ) THEN + NPO = NPO + 1 + XP(:,NPO) = UNDEF + XP(6,NPO) = 0.0 ! Set wind sea frac to zero ENDIF -! - IF ( NPO .GE. DIMXP ) GOTO 2000 - NPO = NPO + 1 - IF (IP.GT.0)THEN - IF(NPO.LT.1)CYCLE - PMAP(NPO) = IP - ENDIF -! - M1 = SUME1(IP) * DTH * TPIINV**2 - M2 = SUME2(IP) * DTH * TPIINV**3 - MM1 = SUMEM1(IP) * DTH - QP = SUMQP(IP) *(DTH * TPIINV)**2 -! M1 = MAX( M1, 1.E-7 ) -! M2 = MAX( M2, 1.E-7 ) -! - XL = 1. / XFR - 1. - XH = XFR - 1. - XL2 = XL**2 - XH2 = XH**2 - EL = SUMF(IFPMAX(IP)-1,IP) - SUMF(IFPMAX(IP),IP) - EH = SUMF(IFPMAX(IP)+1,IP) - SUMF(IFPMAX(IP),IP) - DENOM = XL*EH - XH*EL - SIGP = SIG(IFPMAX(IP)) - IF (DENOM.NE.0.) THEN - SIGP = SIGP *( 1. + 0.5 * ( XL2*EH - XH2*EL ) & - / SIGN ( ABS(DENOM) , DENOM ) ) - END IF - CALL WAVNU1 ( SIGP, DEPTH, WNP, CGP ) -! - !/ --- Parabolic fit around the spectral peak --- - IK = IFPMAX(IP) - EFPMAX(IP) = SUMF(IK,IP) * DTH - IF (IK.GT.1 .AND. IK.LT.NK) THEN - EL = SUMF(IK-1,IP) * DTH - EH = SUMF(IK+1,IP) * DTH - NUMER = 0.125 * ( EL - EH )**2 - DENOM = EL - 2. * EFPMAX(IP) + EH - IF (DENOM.NE.0.) EFPMAX(IP) = EFPMAX(IP) & - - NUMER / SIGN( ABS(DENOM),DENOM ) - END IF -! - !/ --- Weighted least-squares regression to estimate frequency - !/ spread (FSPRD) to an exponential function: - !/ E(f) = A * exp(-1/2*(f-fp)/B)**2 , - !/ where B is frequency spread and E(f) is used for - !/ weighting to avoid greater weights to smalll values - !/ in ordinary least-square fit. --- - FSPRD = UNDEF - SUMY = 0. - SUMXY = 0. - SUMXXY = 0. - SUMYLOGY = 0. - SUMXYLOGY = 0. -! - DO IK=1, NK - Y = SUMF(IK,IP)*DTH + CYCLE + ENDIF + ! + IF ( NPO .GE. DIMXP ) GOTO 2000 + NPO = NPO + 1 + IF (IP.GT.0)THEN + IF(NPO.LT.1)CYCLE + PMAP(NPO) = IP + ENDIF + ! + M1 = SUME1(IP) * DTH * TPIINV**2 + M2 = SUME2(IP) * DTH * TPIINV**3 + MM1 = SUMEM1(IP) * DTH + QP = SUMQP(IP) *(DTH * TPIINV)**2 + ! M1 = MAX( M1, 1.E-7 ) + ! M2 = MAX( M2, 1.E-7 ) + ! + XL = 1. / XFR - 1. + XH = XFR - 1. + XL2 = XL**2 + XH2 = XH**2 + EL = SUMF(IFPMAX(IP)-1,IP) - SUMF(IFPMAX(IP),IP) + EH = SUMF(IFPMAX(IP)+1,IP) - SUMF(IFPMAX(IP),IP) + DENOM = XL*EH - XH*EL + SIGP = SIG(IFPMAX(IP)) + IF (DENOM.NE.0.) THEN + SIGP = SIGP *( 1. + 0.5 * ( XL2*EH - XH2*EL ) & + / SIGN ( ABS(DENOM) , DENOM ) ) + END IF + CALL WAVNU1 ( SIGP, DEPTH, WNP, CGP ) + ! + !/ --- Parabolic fit around the spectral peak --- + IK = IFPMAX(IP) + EFPMAX(IP) = SUMF(IK,IP) * DTH + IF (IK.GT.1 .AND. IK.LT.NK) THEN + EL = SUMF(IK-1,IP) * DTH + EH = SUMF(IK+1,IP) * DTH + NUMER = 0.125 * ( EL - EH )**2 + DENOM = EL - 2. * EFPMAX(IP) + EH + IF (DENOM.NE.0.) EFPMAX(IP) = EFPMAX(IP) & + - NUMER / SIGN( ABS(DENOM),DENOM ) + END IF + ! + !/ --- Weighted least-squares regression to estimate frequency + !/ spread (FSPRD) to an exponential function: + !/ E(f) = A * exp(-1/2*(f-fp)/B)**2 , + !/ where B is frequency spread and E(f) is used for + !/ weighting to avoid greater weights to smalll values + !/ in ordinary least-square fit. --- + FSPRD = UNDEF + SUMY = 0. + SUMXY = 0. + SUMXXY = 0. + SUMYLOGY = 0. + SUMXYLOGY = 0. + ! + DO IK=1, NK + Y = SUMF(IK,IP)*DTH ! --- sums for weighted least-squares --- - IF (Y.GE.1.E-15) THEN - YHAT = LOG(Y) - XHAT = -0.5 * ( (SIG(IK)-SIGP)*TPIINV )**2 - SUMY = SUMY + Y - SUMXY = SUMXY + XHAT * YHAT - SUMXXY = SUMXXY + XHAT * XHAT * Y - SUMYLOGY = SUMYLOGY + Y * YHAT - SUMXYLOGY = SUMXYLOGY + SUMXY * YHAT - END IF - END DO -! - NUMER = SUMY * SUMXXY - SUMXY**2 - DENOM = SUMY * SUMXYLOGY - SUMXY * SUMYLOGY - IF (DENOM.NE.0.) FSPRD = SQRT( NUMER / SIGN(ABS(DENOM),NUMER) ) -! - SUMEXP = SUMFX(IFPMAX(IP),IP) * DSII(IFPMAX(IP)) - SUMEYP = SUMFY(IFPMAX(IP),IP) * DSII(IFPMAX(IP)) -! - !/ --- Significant wave height --- - XP(1,NPO) = HS - !/ --- Peak wave period --- - XP(2,NPO) = TPI / SIGP - !/ --- Peak wave length --- - XP(3,NPO) = TPI / WNP - !/ --- Mean wave direction --- - XP(4,NPO) = MOD( 630.-ATAN2(SUMEY(IP),SUMEX(IP))*RADE , 360. ) - !/ --- Mean directional spread --- - XP(5,NPO) = RADE * SQRT ( MAX ( 0. , 2. * ( 1. - SQRT ( & - MAX(0.,(SUMEX(IP)**2+SUMEY(IP)**2)/SUME(IP)**2) ) ) ) ) - !/ --- Wind sea fraction --- - XP(6,NPO) = SUMEW(IP) / SUME(IP) - !/ --- Peak wave direction --- - XP(7,NPO) = MOD(630.-ATAN2(SUMEYP,SUMEXP)*RADE , 360.) - !/ --- Spectral width (Longuet-Higgins 1975) --- - XP(8,NPO) = SQRT( MAX( 1. , M2*M0 / M1**2 ) - 1. ) - !/ --- JONSWAP peak enhancement parameter (E(fp)/EPM(fp))--- - ! EPM_FMX = ALPHA_PM_FMX * GRAV**2 * TPI * SIGP**-5 * EXP(-5/4) - ALP_PM = 0.3125 * HS**2 * (SIGP)**4 - EPM_FP = ALP_PM * TPI * (SIGP**(-5)) * 2.865048E-1 - XP(9,NPO) = MAX( EFPMAX(IP) / EPM_FP , 1.0 ) - !/ --- peakedness parameter (Goda 1970) --- - XP(10,NPO) = 2. * QP / M0**2 - !/ --- gaussian frequency width --- - XP(11,NPO) = FSPRD - !/ --- wave energy period (inverse moment) --- - XP(12,NPO) = MM1 / M0 - !/ --- mean wave period (first moment) --- - XP(13,NPO) = M0 / M1 - !/ --- zero-upcrossing period (second moment) --- - XP(14,NPO) = SQRT( M0 / M2 ) - !/ --- peak spectral density (one-dimensional) --- - XP(15,NPO) = EFPMAX(IP) -! - END DO -! - RETURN -! -! Escape locations read errors --------------------------------------- * -! - 2000 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) NPO+1 - RETURN -! -! Formats -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN PTMEAN :'/ & - ' XP ARRAY TOO SMALL AT PARTITION',I6/) -!/ -!/ End of PTMEAN ----------------------------------------------------- / -!/ - END SUBROUTINE PTMEAN -!/ -!/ End of module W3PARTMD -------------------------------------------- / -!/ - END MODULE W3PARTMD + IF (Y.GE.1.E-15) THEN + YHAT = LOG(Y) + XHAT = -0.5 * ( (SIG(IK)-SIGP)*TPIINV )**2 + SUMY = SUMY + Y + SUMXY = SUMXY + XHAT * YHAT + SUMXXY = SUMXXY + XHAT * XHAT * Y + SUMYLOGY = SUMYLOGY + Y * YHAT + SUMXYLOGY = SUMXYLOGY + SUMXY * YHAT + END IF + END DO + ! + NUMER = SUMY * SUMXXY - SUMXY**2 + DENOM = SUMY * SUMXYLOGY - SUMXY * SUMYLOGY + IF (DENOM.NE.0.) FSPRD = SQRT( NUMER / SIGN(ABS(DENOM),NUMER) ) + ! + SUMEXP = SUMFX(IFPMAX(IP),IP) * DSII(IFPMAX(IP)) + SUMEYP = SUMFY(IFPMAX(IP),IP) * DSII(IFPMAX(IP)) + ! + !/ --- Significant wave height --- + XP(1,NPO) = HS + !/ --- Peak wave period --- + XP(2,NPO) = TPI / SIGP + !/ --- Peak wave length --- + XP(3,NPO) = TPI / WNP + !/ --- Mean wave direction --- + XP(4,NPO) = MOD( 630.-ATAN2(SUMEY(IP),SUMEX(IP))*RADE , 360. ) + !/ --- Mean directional spread --- + XP(5,NPO) = RADE * SQRT ( MAX ( 0. , 2. * ( 1. - SQRT ( & + MAX(0.,(SUMEX(IP)**2+SUMEY(IP)**2)/SUME(IP)**2) ) ) ) ) + !/ --- Wind sea fraction --- + XP(6,NPO) = SUMEW(IP) / SUME(IP) + !/ --- Peak wave direction --- + XP(7,NPO) = MOD(630.-ATAN2(SUMEYP,SUMEXP)*RADE , 360.) + !/ --- Spectral width (Longuet-Higgins 1975) --- + XP(8,NPO) = SQRT( MAX( 1. , M2*M0 / M1**2 ) - 1. ) + !/ --- JONSWAP peak enhancement parameter (E(fp)/EPM(fp))--- + ! EPM_FMX = ALPHA_PM_FMX * GRAV**2 * TPI * SIGP**-5 * EXP(-5/4) + ALP_PM = 0.3125 * HS**2 * (SIGP)**4 + EPM_FP = ALP_PM * TPI * (SIGP**(-5)) * 2.865048E-1 + XP(9,NPO) = MAX( EFPMAX(IP) / EPM_FP , 1.0 ) + !/ --- peakedness parameter (Goda 1970) --- + XP(10,NPO) = 2. * QP / M0**2 + !/ --- gaussian frequency width --- + XP(11,NPO) = FSPRD + !/ --- wave energy period (inverse moment) --- + XP(12,NPO) = MM1 / M0 + !/ --- mean wave period (first moment) --- + XP(13,NPO) = M0 / M1 + !/ --- zero-upcrossing period (second moment) --- + XP(14,NPO) = SQRT( M0 / M2 ) + !/ --- peak spectral density (one-dimensional) --- + XP(15,NPO) = EFPMAX(IP) + ! + END DO + ! + RETURN + ! + ! Escape locations read errors --------------------------------------- * + ! +2000 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) NPO+1 + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN PTMEAN :'/ & + ' XP ARRAY TOO SMALL AT PARTITION',I6/) + !/ + !/ End of PTMEAN ----------------------------------------------------- / + !/ + END SUBROUTINE PTMEAN + !/ + !/ End of module W3PARTMD -------------------------------------------- / + !/ +END MODULE W3PARTMD diff --git a/model/src/w3pro1md.F90 b/model/src/w3pro1md.F90 index aac0a7fb4..16db90356 100644 --- a/model/src/w3pro1md.F90 +++ b/model/src/w3pro1md.F90 @@ -1,1187 +1,1165 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3PRO1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 05-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 04-Feb-2000 : Origination ( version 2.00 ) -!/ 28-Mar-2001 : Partial time step bug fix (proper ( version 2.10 ) -!/ ingest of boundaries). -!/ 02-Apr-2001 : Sub-grid obstructions. ( version 2.10 ) -!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) -!/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Improved XY boundary conditions. ( version 3.08 ) -!/ 10-Jan-2007 : Clean-up FACVX/Y compute. ( version 3.10 ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 29-May-2014 : Adding OMPH switch. ( version 5.02 ) -!/ 08-May-2014 : Implement tripolar grid for first order propagation -!/ scheme ( version 5.03 ) -!/ (W. E. Rogers, NRL) -!/ 05-Jun-2018 : Add DEBUG ( version 6.04 ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Bundles routines for first order propagation scheme in single -! module. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3MAP1 Subr. Public Set up auxiliary maps. -! W3XYP1 Subr. Public First order spatial propagation. -! W3KTP1 Subr. Public First order spectral propagation. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! DSEC21 Func. W3TIMEMD Time difference. -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3MAP1 ( MAPSTA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Dec-2010 | -!/ +-----------------------------------+ -!/ -!/ 19-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 14-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 10-Jan-2007 : Clean-up FACVX/Y compute. ( version 3.10 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! Generate 'map' arrays for the first order upstream scheme. -! -! 2. Method : -! -! See section 3. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MAPSTA I.A. I Status map. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! ------------------------------------------------------ -! 1. Initialize arrays. -! 2. Fill arrays. -! 3. Invert arrays. -! ------------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NTH, NSPEC, NX, NY, ICLOSE, & - ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL - USE W3ADATMD, ONLY: IS0, IS2, FACVX, FACVY - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE +MODULE W3PRO1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 05-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 04-Feb-2000 : Origination ( version 2.00 ) + !/ 28-Mar-2001 : Partial time step bug fix (proper ( version 2.10 ) + !/ ingest of boundaries). + !/ 02-Apr-2001 : Sub-grid obstructions. ( version 2.10 ) + !/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) + !/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 07-Sep-2005 : Improved XY boundary conditions. ( version 3.08 ) + !/ 10-Jan-2007 : Clean-up FACVX/Y compute. ( version 3.10 ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 29-May-2014 : Adding OMPH switch. ( version 5.02 ) + !/ 08-May-2014 : Implement tripolar grid for first order propagation + !/ scheme ( version 5.03 ) + !/ (W. E. Rogers, NRL) + !/ 05-Jun-2018 : Add DEBUG ( version 6.04 ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Bundles routines for first order propagation scheme in single + ! module. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3MAP1 Subr. Public Set up auxiliary maps. + ! W3XYP1 Subr. Public First order spatial propagation. + ! W3KTP1 Subr. Public First order spectral propagation. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! DSEC21 Func. W3TIMEMD Time difference. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3MAP1 ( MAPSTA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Dec-2010 | + !/ +-----------------------------------+ + !/ + !/ 19-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 14-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 10-Jan-2007 : Clean-up FACVX/Y compute. ( version 3.10 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ + ! 1. Purpose : + ! + ! Generate 'map' arrays for the first order upstream scheme. + ! + ! 2. Method : + ! + ! See section 3. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MAPSTA I.A. I Status map. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! ------------------------------------------------------ + ! 1. Initialize arrays. + ! 2. Fill arrays. + ! 3. Invert arrays. + ! ------------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NTH, NSPEC, NX, NY, ICLOSE, & + ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL + USE W3ADATMD, ONLY: IS0, IS2, FACVX, FACVY + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MAPSTA(NY*NX) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IX, IY, IXY, ISP, IXNEXT + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MAPSTA(NY*NX) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IX, IY, IXY, ISP, IXNEXT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3MAP1') + CALL STRACE (IENT, 'W3MAP1') #endif -! + ! -! 1. Initialize x-y arrays ------------------------------------------ * -! - FACVX = 0. - FACVY = 0. -! -! 2. Fill x-y arrays ------------------------------------------------ * -! -!.....FACVY + ! 1. Initialize x-y arrays ------------------------------------------ * + ! + FACVX = 0. + FACVY = 0. + ! + ! 2. Fill x-y arrays ------------------------------------------------ * + ! + !.....FACVY + DO IX=1, NX + DO IY=1, NY-1 + IXY = IY +(IX-1)*NY + IF ( MAPSTA( IXY ) .NE. 0 ) FACVY(IXY) = FACVY(IXY) + 1. + !.........next point : j+1 : increment IXY by 1 + IF ( MAPSTA(IXY+1) .NE. 0 ) FACVY(IXY) = FACVY(IXY) + 1. + END DO + END DO + ! + !.....FACVY for IY=NY + IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN + IY=NY DO IX=1, NX - DO IY=1, NY-1 - IXY = IY +(IX-1)*NY - IF ( MAPSTA( IXY ) .NE. 0 ) FACVY(IXY) = FACVY(IXY) + 1. -!.........next point : j+1 : increment IXY by 1 - IF ( MAPSTA(IXY+1) .NE. 0 ) FACVY(IXY) = FACVY(IXY) + 1. - END DO - END DO -! -!.....FACVY for IY=NY - IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN - IY=NY - DO IX=1, NX - IXY = IY +(IX-1)*NY - IF ( MAPSTA( IXY ) .NE. 0 ) FACVY(IXY) = FACVY(IXY) + 1. -!...........next point: j+1: tripole: j==>j+1==>j and i==>ni-i+1 - IXNEXT=NX-IX+1 - IXY = IY +(IXNEXT-1)*NY - IF ( MAPSTA( IXY ) .NE. 0 ) FACVY(IXY) = FACVY(IXY) + 1. - END DO -!BGR: Adding the following lines to compute FACVX over all -! IX for IY=NY (this allows along-seam propagation). -! Located here since already inside "TRPL" if-block. -!{ - DO IX=1, NX-1 - IXY = IY +(IX-1)*NY - IF ( MAPSTA( IXY ) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. - IF ( MAPSTA(IXY+NY) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. - END DO -!} - END IF -! -!.....FACVX + IXY = IY +(IX-1)*NY + IF ( MAPSTA( IXY ) .NE. 0 ) FACVY(IXY) = FACVY(IXY) + 1. + !...........next point: j+1: tripole: j==>j+1==>j and i==>ni-i+1 + IXNEXT=NX-IX+1 + IXY = IY +(IXNEXT-1)*NY + IF ( MAPSTA( IXY ) .NE. 0 ) FACVY(IXY) = FACVY(IXY) + 1. + END DO + !BGR: Adding the following lines to compute FACVX over all + ! IX for IY=NY (this allows along-seam propagation). + ! Located here since already inside "TRPL" if-block. + !{ DO IX=1, NX-1 - DO IY=2, NY-1 - IXY = IY +(IX-1)*NY - IF ( MAPSTA( IXY ) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. -!.........next point : i+1 : increment IXY by NY - IF ( MAPSTA(IXY+NY) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. - END DO - END DO -! -!.....FACVX for IX=NX - IF ( ICLOSE.NE.ICLOSE_NONE ) THEN - DO IY=2, NY-1 - IXY = IY +(NX-1)*NY - IF ( MAPSTA(IXY) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. -!...........next point : i+1 : increment IXY by NY -!...........IXY+NY=IY+(IX-1)*NY+NY = IY+IX*NY = IY+NX*NY ==> wrap to IY - IF ( MAPSTA(IY ) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. - END DO - END IF -! -! 3. Invert x-y arrays ---------------------------------------------- * -! - DO IXY=1, NX*NY - IF ( FACVX(IXY) .NE. 0. ) FACVX(IXY) = 1. / FACVX(IXY) - IF ( FACVY(IXY) .NE. 0. ) FACVY(IXY) = 1. / FACVY(IXY) - END DO -! -! 4. Fill theta arrays ---------------------------------------------- * -! - DO ISP=1, NSPEC - IS2 (ISP) = ISP + 1 - IS0 (ISP) = ISP - 1 - END DO -! - DO ISP=NTH, NSPEC, NTH - IS2(ISP) = IS2(ISP) - NTH - END DO -! - DO ISP=1, NSPEC, NTH - IS0(ISP) = IS0(ISP) + NTH - END DO -! - RETURN -!/ -!/ End of W3MAP1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3MAP1 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2014 | -!/ +-----------------------------------+ -!/ -!/ 07-Jul-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 14-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 28-Mar-2001 : Partial time step bug fix. ( version 2.10 ) -!/ 02-Apr-2001 : Sub-grid obstructions. ( version 2.10 ) -!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) -!/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Improved XY boundary conditions. ( version 3.08 ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 29-May-2014 : Adding OMPH switch. ( version 5.02 ) -!/ -! 1. Purpose : -! -! Propagation in physical space for a given spectral component. -! -! 2. Method : -! -! First order scheme with flux formulation. -! Curvilinear grid implementation: Fluxes are computed in index space -! and then transformed back into physical space. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH -! DTG Real I Total time step. -! MAPSTA I.A. I Grid point status map. -! FIELD R.A. I/O Wave action spectral densities on full -! grid. -! VGX/Y Real I Speed of grid. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! NTLOC Int. Number of local steps. -! DTLOC Real Local propagation time step. -! VCX R.A. Propagation velocities in index space. -! VCY R.A. -! CXTOT R.A. Propagation velocities in physical space. -! CYTOT R.A. -! VFLX R.A. Discrete fluxes between grid points in index space. -! VFLY R.A. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The local work arrays are initialized on the first entry to -! the routine. -! - Curvilinear grid implementation. Variables FACX, FACY, CCOS, CSIN, -! CCURX, CCURY are not needed and have been removed. FACX is accounted -! for as approriate in this subroutine. FACX is also accounted for in -! the case of .NOT.FLCX. Since FACX is removed, there is now a check for -! .NOT.FLCX in this subroutine. In CFL calcs dx and dy are omitted, -! since dx=dy=1 in index space. Curvilinear grid derivatives -! (DPDY, DQDX, etc.) and metric (GSQRT) are brought in via W3GDATMD. -! - Standard VCB calculation for Y is: -! VCB = FACVY(IXY) * ( VCY2D(IY,IX) + VCY2D(IY+1,IX) ) -! This is to calculate the flux VCY(IY+0.5). For the tripole grid, -! we cannot do it this way, since the sign of VCY flips as we jump -! over the seam. If we were to do it this way, VCY(IY) and VCY(IY+1) -! are two numbers of similar magnitude and opposite sign, so the -! average of the two gives something close to zero, so energy does -! not leave via VCY(IY+0.5). One alternative is: -! VCB = VCY2D(IY,IX) -! Another alternative is : -! VCB = FACVY(IXY) * ( VCY2D(IY,IX) - VCY2D(IY+1,IX) ) -! Both appear to give correct results for ww3_tp2.13. We use the -! second alternative. -! -! 8. Structure : -! -! --------------------------------------- -! 1. Preparations -! a Set constants -! b Initialize arrays -! 2. Calculate local discrete fluxes -! 3. Calculate propagation fluxes -! 4. Propagate -! 5. Update boundary conditions -! --------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! !/OMPH Hybrid OpenMP directives. -! -! !/T Enable general test output. -! !/T1 Test output local fluxes (V)FX-YL. -! !/T2 Test output propagation fluxes (V)FLX-Y. -! !/T3 Test output propagation. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -! - USE W3TIMEMD, ONLY: DSEC21 -! - USE W3GDATMD, ONLY: NK, NTH, SIG, ECOS, ESIN, NX, NY, NSEA, & - MAPSF, DTCFL, ICLOSE, CLATS, FLCX, FLCY, & - ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & - FLAGLL, DPDX, DPDY, DQDX, DQDY, GSQRT - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, FACVX, FACVY - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, ONLY: NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, & - BBPI0, BBPIN, NDSE, IAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE + IXY = IY +(IX-1)*NY + IF ( MAPSTA( IXY ) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. + IF ( MAPSTA(IXY+NY) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. + END DO + !} + END IF + ! + !.....FACVX + DO IX=1, NX-1 + DO IY=2, NY-1 + IXY = IY +(IX-1)*NY + IF ( MAPSTA( IXY ) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. + !.........next point : i+1 : increment IXY by NY + IF ( MAPSTA(IXY+NY) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. + END DO + END DO + ! + !.....FACVX for IX=NX + IF ( ICLOSE.NE.ICLOSE_NONE ) THEN + DO IY=2, NY-1 + IXY = IY +(NX-1)*NY + IF ( MAPSTA(IXY) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. + !...........next point : i+1 : increment IXY by NY + !...........IXY+NY=IY+(IX-1)*NY+NY = IY+IX*NY = IY+NX*NY ==> wrap to IY + IF ( MAPSTA(IY ) .NE. 0 ) FACVX(IXY) = FACVX(IXY) + 1. + END DO + END IF + ! + ! 3. Invert x-y arrays ---------------------------------------------- * + ! + DO IXY=1, NX*NY + IF ( FACVX(IXY) .NE. 0. ) FACVX(IXY) = 1. / FACVX(IXY) + IF ( FACVY(IXY) .NE. 0. ) FACVY(IXY) = 1. / FACVY(IXY) + END DO + ! + ! 4. Fill theta arrays ---------------------------------------------- * + ! + DO ISP=1, NSPEC + IS2 (ISP) = ISP + 1 + IS0 (ISP) = ISP - 1 + END DO + ! + DO ISP=NTH, NSPEC, NTH + IS2(ISP) = IS2(ISP) - NTH + END DO + ! + DO ISP=1, NSPEC, NTH + IS0(ISP) = IS0(ISP) + NTH + END DO + ! + RETURN + !/ + !/ End of W3MAP1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3MAP1 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2014 | + !/ +-----------------------------------+ + !/ + !/ 07-Jul-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 14-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 28-Mar-2001 : Partial time step bug fix. ( version 2.10 ) + !/ 02-Apr-2001 : Sub-grid obstructions. ( version 2.10 ) + !/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) + !/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 07-Sep-2005 : Improved XY boundary conditions. ( version 3.08 ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 29-May-2014 : Adding OMPH switch. ( version 5.02 ) + !/ + ! 1. Purpose : + ! + ! Propagation in physical space for a given spectral component. + ! + ! 2. Method : + ! + ! First order scheme with flux formulation. + ! Curvilinear grid implementation: Fluxes are computed in index space + ! and then transformed back into physical space. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH + ! DTG Real I Total time step. + ! MAPSTA I.A. I Grid point status map. + ! FIELD R.A. I/O Wave action spectral densities on full + ! grid. + ! VGX/Y Real I Speed of grid. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! NTLOC Int. Number of local steps. + ! DTLOC Real Local propagation time step. + ! VCX R.A. Propagation velocities in index space. + ! VCY R.A. + ! CXTOT R.A. Propagation velocities in physical space. + ! CYTOT R.A. + ! VFLX R.A. Discrete fluxes between grid points in index space. + ! VFLY R.A. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - The local work arrays are initialized on the first entry to + ! the routine. + ! - Curvilinear grid implementation. Variables FACX, FACY, CCOS, CSIN, + ! CCURX, CCURY are not needed and have been removed. FACX is accounted + ! for as approriate in this subroutine. FACX is also accounted for in + ! the case of .NOT.FLCX. Since FACX is removed, there is now a check for + ! .NOT.FLCX in this subroutine. In CFL calcs dx and dy are omitted, + ! since dx=dy=1 in index space. Curvilinear grid derivatives + ! (DPDY, DQDX, etc.) and metric (GSQRT) are brought in via W3GDATMD. + ! - Standard VCB calculation for Y is: + ! VCB = FACVY(IXY) * ( VCY2D(IY,IX) + VCY2D(IY+1,IX) ) + ! This is to calculate the flux VCY(IY+0.5). For the tripole grid, + ! we cannot do it this way, since the sign of VCY flips as we jump + ! over the seam. If we were to do it this way, VCY(IY) and VCY(IY+1) + ! are two numbers of similar magnitude and opposite sign, so the + ! average of the two gives something close to zero, so energy does + ! not leave via VCY(IY+0.5). One alternative is: + ! VCB = VCY2D(IY,IX) + ! Another alternative is : + ! VCB = FACVY(IXY) * ( VCY2D(IY,IX) - VCY2D(IY+1,IX) ) + ! Both appear to give correct results for ww3_tp2.13. We use the + ! second alternative. + ! + ! 8. Structure : + ! + ! --------------------------------------- + ! 1. Preparations + ! a Set constants + ! b Initialize arrays + ! 2. Calculate local discrete fluxes + ! 3. Calculate propagation fluxes + ! 4. Propagate + ! 5. Update boundary conditions + ! --------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! !/OMPH Hybrid OpenMP directives. + ! + ! !/T Enable general test output. + ! !/T1 Test output local fluxes (V)FX-YL. + ! !/T2 Test output propagation fluxes (V)FLX-Y. + ! !/T3 Test output propagation. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + ! + USE W3TIMEMD, ONLY: DSEC21 + ! + USE W3GDATMD, ONLY: NK, NTH, SIG, ECOS, ESIN, NX, NY, NSEA, & + MAPSF, DTCFL, ICLOSE, CLATS, FLCX, FLCY, & + ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & + FLAGLL, DPDX, DPDY, DQDX, DQDY, GSQRT + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, FACVX, FACVY + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, ONLY: NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, & + BBPI0, BBPIN, NDSE, IAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISP, MAPSTA(NY*NX) - REAL, INTENT(IN) :: DTG, VGX, VGY - REAL, INTENT(INOUT) :: FIELD(1-NY:NY*(NX+2)) -!/ -!/ ------------------------------------------------------------------ / -!/ Local parameters -!/ - INTEGER :: IK, ITH, NTLOC, ITLOC, ISEA, IXY, & - IY0, IX, IY, JXN, JXP, JYN, JYP, & - IBI, NYMAX + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISP, MAPSTA(NY*NX) + REAL, INTENT(IN) :: DTG, VGX, VGY + REAL, INTENT(INOUT) :: FIELD(1-NY:NY*(NX+2)) + !/ + !/ ------------------------------------------------------------------ / + !/ Local parameters + !/ + INTEGER :: IK, ITH, NTLOC, ITLOC, ISEA, IXY, & + IY0, IX, IY, JXN, JXP, JYN, JYP, & + IBI, NYMAX #ifdef W3_T3 - INTEGER :: IXF, IYF + INTEGER :: IXF, IYF #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: CG0, CGL, CGA, CC, CGN - REAL :: DTLOC,DTRAD, VCB - REAL :: RD1, RD2 - REAL :: CP, CQ + REAL :: CG0, CGL, CGA, CC, CGN + REAL :: DTLOC,DTRAD, VCB + REAL :: RD1, RD2 + REAL :: CP, CQ #ifdef W3_T3 - REAL :: AOLD + REAL :: AOLD #endif -!/ -!/ Automatic work arrays -!/ - REAL :: CXTOT2D(NY,NX) - REAL :: CYTOT2D(NY,NX) - REAL :: FLD2D(NY+1,NX+1) - REAL :: VCX2D(NY,NX+1) - REAL :: VCY2D(NY+1,NX) - REAL :: VFLX2D(1:NY,0:NX) - REAL :: VFLY2D(NY,NX) + !/ + !/ Automatic work arrays + !/ + REAL :: CXTOT2D(NY,NX) + REAL :: CYTOT2D(NY,NX) + REAL :: FLD2D(NY+1,NX+1) + REAL :: VCX2D(NY,NX+1) + REAL :: VCY2D(NY+1,NX) + REAL :: VFLX2D(1:NY,0:NX) + REAL :: VFLY2D(NY,NX) -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3XYP1') + CALL STRACE (IENT, 'W3XYP1') #endif -! -! 1. Preparations --------------------------------------------------- * + ! + ! 1. Preparations --------------------------------------------------- * -! 1.a Set constants -! - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH -! - CG0 = 0.575 * GRAV / SIG(1) - CGL = 0.575 * GRAV / SIG(IK) -! - IF ( FLCUR ) THEN - CGA = SQRT(MAXVAL((CGL*ECOS(ITH)+CX(1:NSEA))**2 & - +(CGL*ESIN(ITH)+CY(1:NSEA))**2)) - CC = SQRT(MAXVAL(CX(1:NSEA)**2+CY(1:NSEA)**2)) + ! 1.a Set constants + ! + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + ! + CG0 = 0.575 * GRAV / SIG(1) + CGL = 0.575 * GRAV / SIG(IK) + ! + IF ( FLCUR ) THEN + CGA = SQRT(MAXVAL((CGL*ECOS(ITH)+CX(1:NSEA))**2 & + +(CGL*ESIN(ITH)+CY(1:NSEA))**2)) + CC = SQRT(MAXVAL(CX(1:NSEA)**2+CY(1:NSEA)**2)) #ifdef W3_MGP - CGA = SQRT(MAXVAL((CGL*ECOS(ITH)+CX(1:NSEA)-VGX)**2 & - +(CGL*ESIN(ITH)+CY(1:NSEA)-VGY)**2)) - CC = SQRT(MAXVAL((CX(1:NSEA)-VGX)**2+(CY(1:NSEA)-VGY)**2)) + CGA = SQRT(MAXVAL((CGL*ECOS(ITH)+CX(1:NSEA)-VGX)**2 & + +(CGL*ESIN(ITH)+CY(1:NSEA)-VGY)**2)) + CC = SQRT(MAXVAL((CX(1:NSEA)-VGX)**2+(CY(1:NSEA)-VGY)**2)) #endif - ELSE - CGA = CGL + ELSE + CGA = CGL #ifdef W3_MGP - CGA = SQRT((CGL*ECOS(ITH)-VGX)**2+(CGL*ESIN(ITH)-VGY)**2) + CGA = SQRT((CGL*ECOS(ITH)-VGX)**2+(CGL*ESIN(ITH)-VGY)**2) #endif - CC = 0. - END IF -! - CGN = 0.9999 * MAX ( CGA, CC, 0.001*CG0 ) -! - NTLOC = 1 + INT(DTG/(DTCFL*CG0/CGN)) - DTLOC = DTG / REAL(NTLOC) - DTRAD = DTLOC - IF ( FLAGLL ) DTRAD=DTRAD/(DERA*RADIUS) + CC = 0. + END IF + ! + CGN = 0.9999 * MAX ( CGA, CC, 0.001*CG0 ) + ! + NTLOC = 1 + INT(DTG/(DTCFL*CG0/CGN)) + DTLOC = DTG / REAL(NTLOC) + DTRAD = DTLOC + IF ( FLAGLL ) DTRAD=DTRAD/(DERA*RADIUS) -! + ! #ifdef W3_T - WRITE (NDST,9000) NTLOC - WRITE (NDST,9001) ISP, ITH, IK + WRITE (NDST,9000) NTLOC + WRITE (NDST,9001) ISP, ITH, IK #endif -! -! ====================== Loop partial ================================ * -! - DO ITLOC=1, NTLOC -! -! 1.b Initialize arrays -! + ! + ! ====================== Loop partial ================================ * + ! + DO ITLOC=1, NTLOC + ! + ! 1.b Initialize arrays + ! #ifdef W3_T1 WRITE (NDST,9010) ITLOC #endif -! - VCX2D = 0. - VCY2D = 0. - CXTOT2D = 0. - CYTOT2D = 0. - FLD2D = 0. - VFLX2D = 0. - VFLY2D = 0. -! -! 2. Calculate field and velocities --------------------------------- * -! -! FIELD = A / CG * CLATS -! VCX = COS*CG / CLATS -! VCY = SIN*CG -! + ! + VCX2D = 0. + VCY2D = 0. + CXTOT2D = 0. + CYTOT2D = 0. + FLD2D = 0. + VFLX2D = 0. + VFLY2D = 0. + ! + ! 2. Calculate field and velocities --------------------------------- * + ! + ! FIELD = A / CG * CLATS + ! VCX = COS*CG / CLATS + ! VCY = SIN*CG + ! #ifdef W3_T1 WRITE (NDST,9020) #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IXY, IX, IY) + !$OMP PARALLEL DO PRIVATE (ISEA, IXY, IX, IY) #endif -! - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) + ! + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) - FLD2D(IY,IX) = FIELD(IXY) / CG(IK,ISEA) * CLATS(ISEA) + FLD2D(IY,IX) = FIELD(IXY) / CG(IK,ISEA) * CLATS(ISEA) - CXTOT2D(IY,IX) = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) - CYTOT2D(IY,IX) = ESIN(ITH) * CG(IK,ISEA) + CXTOT2D(IY,IX) = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) + CYTOT2D(IY,IX) = ESIN(ITH) * CG(IK,ISEA) #ifdef W3_MGP - CXTOT2D(IY,IX) = CXTOT2D(IY,IX) - VGX/CLATS(ISEA) - CYTOT2D(IY,IX) = CYTOT2D(IY,IX) - VGY + CXTOT2D(IY,IX) = CXTOT2D(IY,IX) - VGX/CLATS(ISEA) + CYTOT2D(IY,IX) = CYTOT2D(IY,IX) - VGY #endif #ifdef W3_T1 - WRITE (NDST,9021) ISEA, IXY, FLD2D(IY,IX), & - CXTOT2D(IY,IX), CYTOT2D(IY,IX) + WRITE (NDST,9021) ISEA, IXY, FLD2D(IY,IX), & + CXTOT2D(IY,IX), CYTOT2D(IY,IX) #endif - END DO -! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - IF ( FLCUR ) THEN - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + ! + IF ( FLCUR ) THEN + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) - CXTOT2D(IY,IX) = CXTOT2D(IY,IX) + CX(ISEA)/CLATS(ISEA) - CYTOT2D(IY,IX) = CYTOT2D(IY,IX) + CY(ISEA) + CXTOT2D(IY,IX) = CXTOT2D(IY,IX) + CX(ISEA)/CLATS(ISEA) + CYTOT2D(IY,IX) = CYTOT2D(IY,IX) + CY(ISEA) - END DO - END IF - - IF ( FLCX ) THEN - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - CP=CXTOT2D(IY,IX)*DPDX(IY,IX)+CYTOT2D(IY,IX)*DPDY(IY,IX) - VCX2D(IY,IX) = CP*DTRAD - END DO - ELSE - VCX2D=0.0 - ENDIF + END DO + END IF - IF ( FLCY ) THEN - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - CQ=CXTOT2D(IY,IX)*DQDX(IY,IX)+CYTOT2D(IY,IX)*DQDY(IY,IX) - VCY2D(IY,IX) = CQ*DTRAD - END DO - ELSE - VCY2D=0.0 - ENDIF + IF ( FLCX ) THEN + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + CP=CXTOT2D(IY,IX)*DPDX(IY,IX)+CYTOT2D(IY,IX)*DPDY(IY,IX) + VCX2D(IY,IX) = CP*DTRAD + END DO + ELSE + VCX2D=0.0 + ENDIF -! Transform FIELD to index space, i.e. straightened space -! Bugfix: This is now done *before* adding the ghost row, so that ghost -! row will be in index space (bug applied only to global, irregular -! grids, so it did not apply to any test case that existed w/v4.18) - FLD2D(1:NY,1:NX)=FLD2D(1:NY,1:NX)*GSQRT(1:NY,1:NX) + IF ( FLCY ) THEN + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + CQ=CXTOT2D(IY,IX)*DQDX(IY,IX)+CYTOT2D(IY,IX)*DQDY(IY,IX) + VCY2D(IY,IX) = CQ*DTRAD + END DO + ELSE + VCY2D=0.0 + ENDIF + + ! Transform FIELD to index space, i.e. straightened space + ! Bugfix: This is now done *before* adding the ghost row, so that ghost + ! row will be in index space (bug applied only to global, irregular + ! grids, so it did not apply to any test case that existed w/v4.18) + FLD2D(1:NY,1:NX)=FLD2D(1:NY,1:NX)*GSQRT(1:NY,1:NX) -! -! Deal with longitude closure by duplicating one row *to the right* -! in FIELD/FLD2D, VCX - IF ( ICLOSE.NE.ICLOSE_NONE ) THEN + ! + ! Deal with longitude closure by duplicating one row *to the right* + ! in FIELD/FLD2D, VCX + IF ( ICLOSE.NE.ICLOSE_NONE ) THEN #ifdef W3_T1 - WRITE (NDST,9024) + WRITE (NDST,9024) #endif - DO IY=1, NY - FLD2D(IY,NX+1)=FLD2D(IY,1) - VCX2D(IY,NX+1)=VCX2D(IY,1) + DO IY=1, NY + FLD2D(IY,NX+1)=FLD2D(IY,1) + VCX2D(IY,NX+1)=VCX2D(IY,1) #ifdef W3_T1 - WRITE (NDST,9025) IY, FLD2D(IY,NX+1), VCX2D(IY,NX+1) + WRITE (NDST,9025) IY, FLD2D(IY,NX+1), VCX2D(IY,NX+1) #endif - END DO - END IF + END DO + END IF -! Deal with tripole closure by duplicating one row *at the top* -! in FIELD/FLD2D, VCY - IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN - DO IX=1,NX -!...........next point: j+1: tripole: j==>j+1==>j and i==>ni-i+1 - FLD2D(NY+1,IX)=FLD2D(NY,NX-IX+1) - VCY2D(NY+1,IX)=VCY2D(NY,NX-IX+1) - END DO - END IF + ! Deal with tripole closure by duplicating one row *at the top* + ! in FIELD/FLD2D, VCY + IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN + DO IX=1,NX + !...........next point: j+1: tripole: j==>j+1==>j and i==>ni-i+1 + FLD2D(NY+1,IX)=FLD2D(NY,NX-IX+1) + VCY2D(NY+1,IX)=VCY2D(NY,NX-IX+1) + END DO + END IF -! -! 3. Calculate propagation fluxes ----------------------------------- * -! - NYMAX=NY-1 - IF ( ICLOSE.EQ.ICLOSE_TRPL ) NYMAX=NY -! + ! + ! 3. Calculate propagation fluxes ----------------------------------- * + ! + NYMAX=NY-1 + IF ( ICLOSE.EQ.ICLOSE_TRPL ) NYMAX=NY + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (IX, IY, IXY, VCB) + !$OMP PARALLEL DO PRIVATE (IX, IY, IXY, VCB) #endif -! - DO IX=1, NX - DO IY=1, NYMAX - IXY = IY +(IX-1)*NY - VCB = FACVX(IXY) * ( VCX2D(IY,IX) + VCX2D(IY,IX+1) ) - VFLX2D(IY,IX) = MAX ( VCB , 0. ) * FLD2D(IY,IX) & - + MIN ( VCB , 0. ) * FLD2D(IY,IX+1) - END DO + ! + DO IX=1, NX + DO IY=1, NYMAX + IXY = IY +(IX-1)*NY + VCB = FACVX(IXY) * ( VCX2D(IY,IX) + VCX2D(IY,IX+1) ) + VFLX2D(IY,IX) = MAX ( VCB , 0. ) * FLD2D(IY,IX) & + + MIN ( VCB , 0. ) * FLD2D(IY,IX+1) END DO -! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! -! Deal with longitude closure by duplicating one row *to the left* -! in VFLX. Note that a similar action is not take for tripole grid, -! since tripole seam is only: IY=NY communicating with other points -! at IY=NY, not a case of IY=NY communicating with IY=1 - IF ( ICLOSE.NE.ICLOSE_NONE ) THEN + ! + ! Deal with longitude closure by duplicating one row *to the left* + ! in VFLX. Note that a similar action is not take for tripole grid, + ! since tripole seam is only: IY=NY communicating with other points + ! at IY=NY, not a case of IY=NY communicating with IY=1 + IF ( ICLOSE.NE.ICLOSE_NONE ) THEN #ifdef W3_T2 - WRITE (NDST,9032) + WRITE (NDST,9032) #endif - DO IY=1, NY - VFLX2D(IY,0) = VFLX2D(IY,NX) + DO IY=1, NY + VFLX2D(IY,0) = VFLX2D(IY,NX) #ifdef W3_T2 - WRITE (NDST,9033) IY, VFLX2D(IY,0) + WRITE (NDST,9033) IY, VFLX2D(IY,0) #endif - END DO - END IF -! + END DO + END IF + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (IX, IY, IXY, VCB) + !$OMP PARALLEL DO PRIVATE (IX, IY, IXY, VCB) #endif -! - DO IX=1, NX - DO IY=1, NY-1 - IXY = IY +(IX-1)*NY - VCB = FACVY(IXY) * ( VCY2D(IY,IX) + VCY2D(IY+1,IX) ) - VFLY2D(IY,IX) = MAX ( VCB , 0. ) * FLD2D(IY,IX) & - + MIN ( VCB , 0. ) * FLD2D(IY+1,IX) - END DO + ! + DO IX=1, NX + DO IY=1, NY-1 + IXY = IY +(IX-1)*NY + VCB = FACVY(IXY) * ( VCY2D(IY,IX) + VCY2D(IY+1,IX) ) + VFLY2D(IY,IX) = MAX ( VCB , 0. ) * FLD2D(IY,IX) & + + MIN ( VCB , 0. ) * FLD2D(IY+1,IX) END DO -! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! + ! -! For tripole grid, include IY=NY in calculation. VCB is handled -! differently. See notes in Section "7. Remarks" above. - IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN - IY=NY -! + ! For tripole grid, include IY=NY in calculation. VCB is handled + ! differently. See notes in Section "7. Remarks" above. + IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN + IY=NY + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (IXY, VCB, IX) + !$OMP PARALLEL DO PRIVATE (IXY, VCB, IX) #endif -! - DO IX=1, NX - IXY = IY +(IX-1)*NY - VCB = FACVY(IXY) * ( VCY2D(IY,IX) - VCY2D(IY+1,IX) ) - VFLY2D(IY,IX) = MAX ( VCB , 0. ) * FLD2D(IY,IX) & - + MIN ( VCB , 0. ) * FLD2D(IY+1,IX) - END DO -! + ! + DO IX=1, NX + IXY = IY +(IX-1)*NY + VCB = FACVY(IXY) * ( VCY2D(IY,IX) - VCY2D(IY+1,IX) ) + VFLY2D(IY,IX) = MAX ( VCB , 0. ) * FLD2D(IY,IX) & + + MIN ( VCB , 0. ) * FLD2D(IY+1,IX) + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - END IF + ! + END IF -! 4. Propagate ------------------------------------------------------ * -! + ! 4. Propagate ------------------------------------------------------ * + ! #ifdef W3_T3 - WRITE (NDST,9040) + WRITE (NDST,9040) #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IXY, JXN, JXP, JYN, JYP, IX, IY) + !$OMP PARALLEL DO PRIVATE (ISEA, IXY, JXN, JXP, JYN, JYP, IX, IY) #endif -! - DO ISEA=1, NSEA -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) + ! + DO ISEA=1, NSEA + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) #ifdef W3_T3 - AOLD = FLD2D(IY,IX) * CG(IK,ISEA) / CLATS(ISEA) + AOLD = FLD2D(IY,IX) * CG(IK,ISEA) / CLATS(ISEA) #endif -! - IF (MAPSTA(IXY).EQ.1) THEN -! - IF ( VFLX2D(IY,IX-1) .GT. 0. ) THEN - JXN = -1 - ELSE - JXN = 0 - END IF - IF ( VFLX2D(IY,IX) .LT. 0. ) THEN - JXP = 1 - ELSE - JXP = 0 - END IF - IF ( VFLY2D(IY-1,IX) .GT. 0. ) THEN - JYN = -1 - ELSE - JYN = 0 - END IF - IF ( VFLY2D(IY,IX) .LT. 0. ) THEN - JYP = 1 - ELSE - JYP = 0 - END IF -! - FLD2D(IY,IX) = FLD2D(IY,IX) & - + ATRNX(IXY,JXN) * VFLX2D(IY,IX-1) & - - ATRNX(IXY,JXP) * VFLX2D(IY,IX) & - + ATRNY(IXY,JYN) * VFLY2D(IY-1,IX) & - - ATRNY(IXY,JYP) * VFLY2D(IY,IX) + ! + IF (MAPSTA(IXY).EQ.1) THEN + ! + IF ( VFLX2D(IY,IX-1) .GT. 0. ) THEN + JXN = -1 + ELSE + JXN = 0 + END IF + IF ( VFLX2D(IY,IX) .LT. 0. ) THEN + JXP = 1 + ELSE + JXP = 0 + END IF + IF ( VFLY2D(IY-1,IX) .GT. 0. ) THEN + JYN = -1 + ELSE + JYN = 0 + END IF + IF ( VFLY2D(IY,IX) .LT. 0. ) THEN + JYP = 1 + ELSE + JYP = 0 + END IF + ! + FLD2D(IY,IX) = FLD2D(IY,IX) & + + ATRNX(IXY,JXN) * VFLX2D(IY,IX-1) & + - ATRNX(IXY,JXP) * VFLX2D(IY,IX) & + + ATRNY(IXY,JYN) * VFLY2D(IY-1,IX) & + - ATRNY(IXY,JYP) * VFLY2D(IY,IX) #ifdef W3_T3 - WRITE (NDST,9041) ISEA, IXY, IXY-NY, IXY-1, & - VFLX2D(IY,IX-1), VFLX2D(IY,IX), VFLY2D(IY-1,IX), & - VFLY2D(IY,IX) , CG(IK,ISEA)/CLATS(ISEA),AOLD, & - FLD2D(IY,IX) + WRITE (NDST,9041) ISEA, IXY, IXY-NY, IXY-1, & + VFLX2D(IY,IX-1), VFLX2D(IY,IX), VFLY2D(IY-1,IX), & + VFLY2D(IY,IX) , CG(IK,ISEA)/CLATS(ISEA),AOLD, & + FLD2D(IY,IX) #endif -! -! + ! + ! #ifdef W3_T3 - WRITE (NDST,9042) ISEA, MAPSTA(IXY), AOLD,FLD2D(IY,IX) + WRITE (NDST,9042) ISEA, MAPSTA(IXY), AOLD,FLD2D(IY,IX) #endif -! - END IF ! IF (MAPSTA(IXY).EQ.1) THEN + ! + END IF ! IF (MAPSTA(IXY).EQ.1) THEN - FLD2D(IY,IX) = CG(IK,ISEA) / CLATS(ISEA) * FLD2D(IY,IX) + FLD2D(IY,IX) = CG(IK,ISEA) / CLATS(ISEA) * FLD2D(IY,IX) - END DO ! DO ISEA=1, NSEA -! + END DO ! DO ISEA=1, NSEA + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! + ! -! Transform FIELD back to physical space, i.e. may be curvilinear - FLD2D(1:NY,1:NX)=FLD2D(1:NY,1:NX)/GSQRT(1:NY,1:NX) -! -! 5. Update boundary conditions ------------------------------------- * -! - IF ( FLBPI ) THEN - RD1 = DSEC21 ( TBPI0, TIME ) - DTG * & - REAL(NTLOC-ITLOC)/REAL(NTLOC) - RD2 = DSEC21 ( TBPI0, TBPIN ) - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF - DO IBI=1, NBI - IX = MAPSF(ISBPI(IBI),1) - IY = MAPSF(ISBPI(IBI),2) - FLD2D(IY,IX) = RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) - END DO + ! Transform FIELD back to physical space, i.e. may be curvilinear + FLD2D(1:NY,1:NX)=FLD2D(1:NY,1:NX)/GSQRT(1:NY,1:NX) + ! + ! 5. Update boundary conditions ------------------------------------- * + ! + IF ( FLBPI ) THEN + RD1 = DSEC21 ( TBPI0, TIME ) - DTG * & + REAL(NTLOC-ITLOC)/REAL(NTLOC) + RD2 = DSEC21 ( TBPI0, TBPIN ) + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. END IF -! -! 6. Put back in 1d shape ------------------------------------------- * -! - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) - FIELD(IXY) = FLD2D(IY,IX) + DO IBI=1, NBI + IX = MAPSF(ISBPI(IBI),1) + IY = MAPSF(ISBPI(IBI),2) + FLD2D(IY,IX) = RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) END DO -! -! ... End of partial time step loop -! - END DO ! DO ITLOC=1, NTLOC -! - RETURN -! -! Formats -! + END IF + ! + ! 6. Put back in 1d shape ------------------------------------------- * + ! + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + FIELD(IXY) = FLD2D(IY,IX) + END DO + ! + ! ... End of partial time step loop + ! + END DO ! DO ITLOC=1, NTLOC + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3XYP1 : NTLOC :',I4) - 9001 FORMAT (' TEST W3XYP1 : ISP, ITH, IK :',I8,2I4) +9000 FORMAT (' TEST W3XYP1 : NTLOC :',I4) +9001 FORMAT (' TEST W3XYP1 : ISP, ITH, IK :',I8,2I4) #endif -! + ! #ifdef W3_T1 - 9010 FORMAT (' TEST W3XYP1 : INIT. VFX-YL, ITLOC =',I3) +9010 FORMAT (' TEST W3XYP1 : INIT. VFX-YL, ITLOC =',I3) +9020 FORMAT (' TEST W3XYP1 : ISEA, IXY, FIELD, VCX, VCY') +9021 FORMAT (' ',2I8,3E12.4) +9024 FORMAT (' TEST W3XYP1 : GLOBAL CLOSURE: IY, FIELD, VCX ') +9025 FORMAT (' ',I4,2E12.4) #endif -! -#ifdef W3_T1 - 9020 FORMAT (' TEST W3XYP1 : ISEA, IXY, FIELD, VCX, VCY') - 9021 FORMAT (' ',2I8,3E12.4) - 9024 FORMAT (' TEST W3XYP1 : GLOBAL CLOSURE: IY, FIELD, VCX ') - 9025 FORMAT (' ',I4,2E12.4) -#endif -! + ! #ifdef W3_T2 - 9032 FORMAT (' TEST W3XYP1 : CLOSE. : IY, VFLX') - 9033 FORMAT (' ',I4,E12.4) +9032 FORMAT (' TEST W3XYP1 : CLOSE. : IY, VFLX') +9033 FORMAT (' ',I4,E12.4) #endif -! + ! #ifdef W3_T3 - 9040 FORMAT (' TEST W3XYP1 : PROPAGATION '/ & - ' ISEA, IXY(3), , FLX(2), FLY(2), FAC, A(2)') - 9041 FORMAT (2X,4I5,1X,4E10.3,1X,E10.3,1X,2E10.3) - 9042 FORMAT (2X,I5,'( MAP = ',I2,' )',56X,2E10.3) +9040 FORMAT (' TEST W3XYP1 : PROPAGATION '/ & + ' ISEA, IXY(3), , FLX(2), FLY(2), FAC, A(2)') +9041 FORMAT (2X,4I5,1X,4E10.3,1X,E10.3,1X,2E10.3) +9042 FORMAT (2X,I5,'( MAP = ',I2,' )',56X,2E10.3) #endif -!/ -!/ End of W3XYP1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3XYP1 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3KTP1 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & - DDDX, DDDY, CX, CY, DCXDX, DCXDY, DCYDX, & - DCYDY, DCDX, DCDY, VA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 20-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 29-Aug-1997 : Final FORTRAN 77 ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Propagation in spectral space. -! -! 2. Method : -! -! First order scheme. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISEA Int. I Number of sea point. -! FACTH/K Real I Factor in propagation velocity. -! CTHG0 Real I Factor in great circle refracftion term. -! CG R.A. I Local group velocities. -! WN R.A. I Local wavenumbers. -! DEPTH Real I Depth. -! DDDx Real I Depth gradients. -! CX/Y Real I Current components. -! DCxDx Real I Current gradients. -! DCDX-Y Real I Phase speed gradients. -! VA R.A. I/O Spectrum. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! DSDD R.A. Partial derivative of sigma for depth. -! FRK, FRG, FKC -! R.A. Partial velocity terms. -! DWNI R.A. Inverse band width. -! CTH-WN R.A. Propagation velocities of local fluxes. -! FLTH-WN R.A. Propagation fluxes. -! AA R.A. Extracted spectrum -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Preparations -! a Calculate DSDD -! b Extract spectrum -! 2. Refraction velocities -! a Filter level depth reffraction. -! b Depth refratcion velocity. -! c Current refraction velocity. -! 3. Wavenumber shift velocities -! a Prepare directional arrays -! b Calcuate velocity. -! 4. Refraction -! a Discrete fluxes. -! b Propagation fluxes. -! c Refraction. -! 5. Wavenumber shifts. -! a Discrete fluxes. -! b Propagation fluxes. -! c Refraction. -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! C/S Enable subroutine tracing. -! C/T Enable general test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, ES2, & - ESC, EC2, FACHFA, MAPWN, FLCTH, FLCK, CTMAX - USE W3ADATMD, ONLY: IS0, IS2 - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, ONLY: NDST + !/ + !/ End of W3XYP1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3XYP1 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3KTP1 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & + DDDX, DDDY, CX, CY, DCXDX, DCXDY, DCYDX, & + DCYDY, DCDX, DCDY, VA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 20-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 29-Aug-1997 : Final FORTRAN 77 ( version 1.18 ) + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Propagation in spectral space. + ! + ! 2. Method : + ! + ! First order scheme. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISEA Int. I Number of sea point. + ! FACTH/K Real I Factor in propagation velocity. + ! CTHG0 Real I Factor in great circle refracftion term. + ! CG R.A. I Local group velocities. + ! WN R.A. I Local wavenumbers. + ! DEPTH Real I Depth. + ! DDDx Real I Depth gradients. + ! CX/Y Real I Current components. + ! DCxDx Real I Current gradients. + ! DCDX-Y Real I Phase speed gradients. + ! VA R.A. I/O Spectrum. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! DSDD R.A. Partial derivative of sigma for depth. + ! FRK, FRG, FKC + ! R.A. Partial velocity terms. + ! DWNI R.A. Inverse band width. + ! CTH-WN R.A. Propagation velocities of local fluxes. + ! FLTH-WN R.A. Propagation fluxes. + ! AA R.A. Extracted spectrum + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Preparations + ! a Calculate DSDD + ! b Extract spectrum + ! 2. Refraction velocities + ! a Filter level depth reffraction. + ! b Depth refratcion velocity. + ! c Current refraction velocity. + ! 3. Wavenumber shift velocities + ! a Prepare directional arrays + ! b Calcuate velocity. + ! 4. Refraction + ! a Discrete fluxes. + ! b Propagation fluxes. + ! c Refraction. + ! 5. Wavenumber shifts. + ! a Discrete fluxes. + ! b Propagation fluxes. + ! c Refraction. + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! C/S Enable subroutine tracing. + ! C/T Enable general test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, ES2, & + ESC, EC2, FACHFA, MAPWN, FLCTH, FLCK, CTMAX + USE W3ADATMD, ONLY: IS0, IS2 + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, ONLY: NDST #ifdef W3_DEBUG - USE W3ODATMD, only : IAPROC + USE W3ODATMD, only : IAPROC #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISEA - REAL, INTENT(IN) :: FACTH, FACK, CTHG0, CG(0:NK+1), & - WN(0:NK+1), DEPTH, DDDX, DDDY, & - CX, CY, DCXDX, DCXDY, DCYDX, DCYDY - REAL, INTENT(IN) :: DCDX(0:NK+1), DCDY(0:NK+1) - REAL, INTENT(INOUT) :: VA(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK, ISP, ITH0 + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISEA + REAL, INTENT(IN) :: FACTH, FACK, CTHG0, CG(0:NK+1), & + WN(0:NK+1), DEPTH, DDDX, DDDY, & + CX, CY, DCXDX, DCXDY, DCYDX, DCYDY + REAL, INTENT(IN) :: DCDX(0:NK+1), DCDY(0:NK+1) + REAL, INTENT(INOUT) :: VA(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK, ISP, ITH0 + REAL :: FDDMAX, FDG, DCYX, DCXXYY, DCXY, & + DCXX, DCXYYX, DCYY, FKD, FKD0, CTHB, & + CWNB + REAL :: VCTH(NSPEC), VCWN(1-NTH:NSPEC+NTH), & + VAA(1-NTH:NSPEC+NTH), VFLTH(NSPEC), & + VFLWN(1-NTH:NSPEC), DSDD(0:NK+1), & + FRK(NK), FRG(NK), FKC(NTH), DWNI(NK) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3KTP1') #endif - REAL :: FDDMAX, FDG, DCYX, DCXXYY, DCXY, & - DCXX, DCXYYX, DCYY, FKD, FKD0, CTHB, & - CWNB - REAL :: VCTH(NSPEC), VCWN(1-NTH:NSPEC+NTH), & - VAA(1-NTH:NSPEC+NTH), VFLTH(NSPEC), & - VFLWN(1-NTH:NSPEC), DSDD(0:NK+1), & - FRK(NK), FRG(NK), FKC(NTH), DWNI(NK) -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3KTP1') -#endif -! + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_T - WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX - WRITE (NDST,9001) ISEA, DEPTH, CX, CY, & - DDDX, DDDY, DCXDX, DCXDY, DCYDX, DCYDY + WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX + WRITE (NDST,9001) ISEA, DEPTH, CX, CY, & + DDDX, DDDY, DCXDX, DCXDY, DCYDX, DCYDY #endif -! -! 1. Preparations --------------------------------------------------- * -! 1.a Array with partial derivative of sigma versus depth -! - DO IK=0, NK+1 - IF ( DEPTH*WN(IK) .LT. 5. ) THEN - DSDD(IK) = MAX ( 0. , & - CG(IK)*WN(IK)-0.5*SIG(IK) ) / DEPTH - ELSE - DSDD(IK) = 0. - END IF - END DO -! + ! + ! 1. Preparations --------------------------------------------------- * + ! 1.a Array with partial derivative of sigma versus depth + ! + DO IK=0, NK+1 + IF ( DEPTH*WN(IK) .LT. 5. ) THEN + DSDD(IK) = MAX ( 0. , & + CG(IK)*WN(IK)-0.5*SIG(IK) ) / DEPTH + ELSE + DSDD(IK) = 0. + END IF + END DO + ! #ifdef W3_T - WRITE (NDST,9010) - DO IK=1, NK+1 - WRITE (NDST,9011) IK, TPI/SIG(IK), TPI/WN(IK), & - CG(IK), DSDD(IK) - END DO + WRITE (NDST,9010) + DO IK=1, NK+1 + WRITE (NDST,9011) IK, TPI/SIG(IK), TPI/WN(IK), & + CG(IK), DSDD(IK) + END DO #endif -! -! 1.b Extract spectrum -! + ! + ! 1.b Extract spectrum + ! + DO ISP=1, NSPEC + VAA(ISP) = VA(ISP) + END DO + ! + ! 2. Refraction velocities ------------------------------------------ * + ! + IF ( FLCTH ) THEN + ! + ! 2.a Set slope filter for depth refraction + ! + FDDMAX = 0. + FDG = FACTH * CTHG0 + ! + DO ITH=1, NTH + FDDMAX = MAX ( FDDMAX , ABS ( & + ESIN(ITH)*DDDX - ECOS(ITH)*DDDY ) ) + END DO + ! + DO IK=1, NK + FRK(IK) = FACTH * DSDD(IK) / WN(IK) + FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) + FRG(IK) = FDG * CG(IK) + END DO + ! + ! 2.b Depth refraction and great-circle propagation + ! DO ISP=1, NSPEC - VAA(ISP) = VA(ISP) - END DO -! -! 2. Refraction velocities ------------------------------------------ * -! - IF ( FLCTH ) THEN -! -! 2.a Set slope filter for depth refraction -! - FDDMAX = 0. - FDG = FACTH * CTHG0 -! - DO ITH=1, NTH - FDDMAX = MAX ( FDDMAX , ABS ( & - ESIN(ITH)*DDDX - ECOS(ITH)*DDDY ) ) - END DO -! - DO IK=1, NK - FRK(IK) = FACTH * DSDD(IK) / WN(IK) - FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) - FRG(IK) = FDG * CG(IK) - END DO -! -! 2.b Depth refraction and great-circle propagation -! - DO ISP=1, NSPEC - VCTH(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & - + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DDDX - ECOS(ISP)*DDDY ) - END DO -#ifdef W3_DEBUG - WRITE(740+IAPROC,*) 'pro1 FACTH=', FACTH - WRITE(740+IAPROC,*) 'pro1 CTHG0=', CTHG0 - WRITE(740+IAPROC,*) 'pro1 FDG=', FDG - WRITE(740+IAPROC,*) 'pro1 FDDMAX=', FDDMAX - WRITE(740+IAPROC,*) 'pro1 sum(FRK)=', sum(FRK) - WRITE(740+IAPROC,*) 'pro1 sum(FRG)=', sum(FRG) - WRITE(740+IAPROC,*) 'pro1 sum(DSDD)=', sum(DSDD) - WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' sum(VCTH)=', sum(VCTH) - FLUSH(740+IAPROC) -#endif - -! -#ifdef W3_REFRX -! 2.c @C/@x refraction and great-circle propagation - VCTH = 0. - FRK = 0. - FDDMAX = 0. -#endif -! -#ifdef W3_REFRX - DO ISP=1, NSPEC - FDDMAX = MAX ( FDDMAX , ABS ( & - ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) - END DO -#endif -! + VCTH(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DDDX - ECOS(ISP)*DDDY ) + END DO + ! #ifdef W3_REFRX - DO IK=1, NK - FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) - FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) - FRG(IK) = FDG * CG(IK) - END DO - DO ISP=1, NSPEC - VCTH(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & - + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & - - ECOS(ISP)*DCDY(MAPWN(ISP)) ) - END DO + ! 2.c @C/@x refraction and great-circle propagation + VCTH = 0. + FRK = 0. + FDDMAX = 0. + ! + DO ISP=1, NSPEC + FDDMAX = MAX ( FDDMAX , ABS ( & + ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) + END DO + ! + DO IK=1, NK + FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) + FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) + FRG(IK) = FDG * CG(IK) + END DO + DO ISP=1, NSPEC + VCTH(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & + - ECOS(ISP)*DCDY(MAPWN(ISP)) ) + END DO #endif -! -! 2.d Current refraction -! - IF ( FLCUR ) THEN -! - DCYX = FACTH * DCYDX - DCXXYY = FACTH * ( DCXDX - DCYDY ) - DCXY = FACTH * DCXDY -! - DO ISP=1, NSPEC - VCTH(ISP) = VCTH(ISP) + ES2(ISP)*DCYX & - + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY - END DO -! - END IF -! - END IF -! -! 3. Wavenumber shift velocities ------------------------------------ * -! - IF ( FLCK ) THEN -! - DCXX = - FACK * DCXDX - DCXYYX = - FACK * ( DCXDY + DCYDX ) - DCYY = - FACK * DCYDY - FKD = FACK * ( CX*DDDX + CY*DDDY ) -! - DO ITH=1, NTH - FKC(ITH) = EC2(ITH)*DCXX + & - ESC(ITH)*DCXYYX + ES2(ITH)*DCYY - END DO -! - ISP = -NTH - DO IK=0, NK+1 - FKD0 = FKD / CG(IK) * DSDD(IK) - DO ITH=1, NTH - ISP = ISP + 1 - VCWN(ISP) = FKD0 + WN(IK)*FKC(ITH) - END DO - END DO -! - ITH0 = NSPEC - NTH - DO ITH=1, NTH - VAA(ITH+NSPEC) = FACHFA * VAA(ITH+ITH0) - VAA(ITH- NTH ) = 0. - END DO -! - DO IK=1, NK - DWNI(IK) = CG(IK) / DSIP(IK) - END DO -! - END IF -! -! 4. Refraction ----------------------------------------------------- * -! - IF ( FLCTH ) THEN -! -! 4.a Boundary velocity and fluxes -! - DO ISP=1, NSPEC - CTHB = 0.5 * ( VCTH(ISP) + VCTH(IS2(ISP)) ) - VFLTH(ISP) = MAX ( CTHB , 0. ) * VAA(ISP) & - + MIN ( CTHB , 0. ) * VAA(IS2(ISP)) - END DO -! -! 4.b Propagation -! - DO ISP=1, NSPEC - VA(ISP) = VA(ISP) + VFLTH(IS0(ISP)) - VFLTH(ISP ) - END DO -! - END IF -! -! 5. Wavenumber shifts ---------------------------------------------- * -! - IF ( FLCK ) THEN -! -! 5.a Boundary velocity and fluxes -! - DO ISP=1-NTH, NSPEC - CWNB = 0.5 * ( VCWN(ISP) + VCWN(ISP+NTH) ) - VFLWN(ISP) = MAX ( CWNB , 0. ) * VAA( ISP ) & - + MIN ( CWNB , 0. ) * VAA(ISP+NTH) - END DO -! -! 5.c Propagation -! - DO ISP=1, NSPEC - VA(ISP) = VA(ISP) + DWNI(MAPWN(ISP)) * & - ( VFLWN(ISP-NTH) - VFLWN(ISP) ) - END DO -! - END IF -! - RETURN -! -! Formats -! + ! + ! 2.d Current refraction + ! + IF ( FLCUR ) THEN + ! + DCYX = FACTH * DCYDX + DCXXYY = FACTH * ( DCXDX - DCYDY ) + DCXY = FACTH * DCXDY + ! + DO ISP=1, NSPEC + VCTH(ISP) = VCTH(ISP) + ES2(ISP)*DCYX & + + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY + END DO + ! + END IF + ! + END IF + ! + ! 3. Wavenumber shift velocities ------------------------------------ * + ! + IF ( FLCK ) THEN + ! + DCXX = - FACK * DCXDX + DCXYYX = - FACK * ( DCXDY + DCYDX ) + DCYY = - FACK * DCYDY + FKD = FACK * ( CX*DDDX + CY*DDDY ) + ! + DO ITH=1, NTH + FKC(ITH) = EC2(ITH)*DCXX + & + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY + END DO + ! + ISP = -NTH + DO IK=0, NK+1 + FKD0 = FKD / CG(IK) * DSDD(IK) + DO ITH=1, NTH + ISP = ISP + 1 + VCWN(ISP) = FKD0 + WN(IK)*FKC(ITH) + END DO + END DO + ! + ITH0 = NSPEC - NTH + DO ITH=1, NTH + VAA(ITH+NSPEC) = FACHFA * VAA(ITH+ITH0) + VAA(ITH- NTH ) = 0. + END DO + ! + DO IK=1, NK + DWNI(IK) = CG(IK) / DSIP(IK) + END DO + ! + END IF + ! + ! 4. Refraction ----------------------------------------------------- * + ! + IF ( FLCTH ) THEN + ! + ! 4.a Boundary velocity and fluxes + ! + DO ISP=1, NSPEC + CTHB = 0.5 * ( VCTH(ISP) + VCTH(IS2(ISP)) ) + VFLTH(ISP) = MAX ( CTHB , 0. ) * VAA(ISP) & + + MIN ( CTHB , 0. ) * VAA(IS2(ISP)) + END DO + ! + ! 4.b Propagation + ! + DO ISP=1, NSPEC + VA(ISP) = VA(ISP) + VFLTH(IS0(ISP)) - VFLTH(ISP ) + END DO + ! + END IF + ! + ! 5. Wavenumber shifts ---------------------------------------------- * + ! + IF ( FLCK ) THEN + ! + ! 5.a Boundary velocity and fluxes + ! + DO ISP=1-NTH, NSPEC + CWNB = 0.5 * ( VCWN(ISP) + VCWN(ISP+NTH) ) + VFLWN(ISP) = MAX ( CWNB , 0. ) * VAA( ISP ) & + + MIN ( CWNB , 0. ) * VAA(ISP+NTH) + END DO + ! + ! 5.c Propagation + ! + DO ISP=1, NSPEC + VA(ISP) = VA(ISP) + DWNI(MAPWN(ISP)) * & + ( VFLWN(ISP-NTH) - VFLWN(ISP) ) + END DO + ! + END IF + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3KTP1 : FLCTH-K, FACTH-K, CTMAX :', & - 2L2,2E10.3,F7.3) - 9001 FORMAT (' TEST W3KTP1 : LOCAL DATA :',I7,F7.1,2F6.2,1X, & - 6E10.3) - 9010 FORMAT (' TEST W3KTP1 : IK, T, L, CG, DSDD : ') - 9011 FORMAT (' ',I3,F7.2,F7.1,F7.2,E11.3) +9000 FORMAT (' TEST W3KTP1 : FLCTH-K, FACTH-K, CTMAX :', & + 2L2,2E10.3,F7.3) +9001 FORMAT (' TEST W3KTP1 : LOCAL DATA :',I7,F7.1,2F6.2,1X, & + 6E10.3) +9010 FORMAT (' TEST W3KTP1 : IK, T, L, CG, DSDD : ') +9011 FORMAT (' ',I3,F7.2,F7.1,F7.2,E11.3) #endif -!/ -!/ End of W3KTP1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3KTP1 -!/ -!/ End of module W3PRO1MD -------------------------------------------- / -!/ - END MODULE W3PRO1MD + !/ + !/ End of W3KTP1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3KTP1 + !/ + !/ End of module W3PRO1MD -------------------------------------------- / + !/ +END MODULE W3PRO1MD diff --git a/model/src/w3pro2md.F90 b/model/src/w3pro2md.F90 index 3997d17c9..4ae31f242 100644 --- a/model/src/w3pro2md.F90 +++ b/model/src/w3pro2md.F90 @@ -1,1652 +1,1630 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3PRO2MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2014 | -!/ +-----------------------------------+ -!/ -!/ 04-Feb-2000 : Origination. ( version 2.00 ) -!/ 24-Jan-2001 : Flat grid version ( version 2.06 ) -!/ 08-Feb-2001 : UQ routines moved to own module ( version 2.08 ) -!/ 09-Feb-2001 : Clean up of parameter lists ( version 2.08 ) -!/ 14-Feb-2001 : Unit numbers in UQ routines ( version 2.08 ) -!/ 13-Nov-2001 : Sub-grid obstacles added. ( version 2.14 ) -!/ 26-Dec-2002 : Moving grid option. ( version 3.02 ) -!/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Improved XY boundary conditions. ( version 3.08 ) -!/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives. -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) -!/ factor with DXDP and DXDQ terms. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third -!/ and second order schemes. ( version 4.12 ) -!/ 29-May-2014 : Adding OMPH switch. ( version 5.02 ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Bundles routines for third order porpagation scheme in single -! module. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! TRNMIN R.P. Private Minimum transparancy for local -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3MAP2 Subr. Public Set up auxiliary maps. -! W3XYP2 Subr. Public Third order spatial propagation. -! W3KTP2 Subr. Public Third order spectral propagation. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! W3QCK1 Subr. W3UQCKMD Regular grid UQ scheme. -! W3QCK2 Subr. Id. Irregular grid UQ scheme. -! W3QCK3 Subr. Id. Regular grid UQ scheme + obstructions. -! W3UNO2 Subr. W3UNO2MD UNO2 scheme for irregular grid. -! W3UNO2r Subr. Id. UNO2 scheme reduced to regular grid. -! W3UNO2s Subr. Id. UNO2 regular grid with subgrid -! obstruction. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/UQ 3rd order UQ propagation scheme. -! !/UNO 2nd order UNO propagation scheme. -! -! !/MGP Correct for motion of grid. -! -! !/OMPH Hybrid OpenMP directives. -! -! !/TDYN, !/DSS0, !/XW0, !/XW1 -! Diffusion options in W3XYP2 -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ Public variables -!/ - PUBLIC -!/ -!/ Private data -!/ - REAL, PRIVATE, PARAMETER:: TRNMIN = 0.95 -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3MAP2 -!/ -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 09-Nov-2005 | -!/ +-----------------------------------+ -!/ -!/ 19-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 15-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 09-Feb-2001 : Clean up of parameter lists ( version 2.08 ) -!/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) -!/ -! 1. Purpose : -! -! Generate 'map' arrays for the ULTIMATE QUICKEST scheme. -! -! 2. Method : -! -! MAPX2, MAPY2, MAPTH2 and MAPWN2 contain consecutive 1-D spatial -! grid counters (e.g., IXY = (IX-1)*MY + IY). The arrays are -! devided in three parts. For MAPX2, these ranges are : -! -! 1 - NMX0 Counters IXY for which grid point (IX,IY) and -! (IX+1,IY) both are active grid points. -! NMX0+1 - NMX1 Id. only (IX,IY) active. -! NMX1+1 - NMX2 Id. only (IX+1,IY) active. -! -! The array MAPY2 has a similar layout varying IY instead of IX. -! MAPXY contains similar information for the cross term in the -! diffusion correction (counter NMXY only). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Wave model routine. -! --------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! ------------------------------------------------------ -! 1. Map MAPX2 -! a Range 1 to NMX0 -! b Range NMX0+1 to NMX1 -! c Range NMX1+1 to NMX2 -! 2. Map MAPY2 -! a Range 1 to NMY0 -! b Range NMY0+1 to NMY1 -! c Range NMY1+1 to NMY2 -! 3. Map MAPAXY and MAPXY -! 4. Maps for intra-spectral propagation -! a MAPTH2, MAPATK -! b MAPWN2 -! ------------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NK, NTH, NSPEC, NX, NY, NSEA, MAPSTA - USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & - NMXY, MAPX2, MAPY2, MAPAXY, MAPXY, & - MAPTH2, MAPWN2 - USE W3ODATMD, ONLY: NDST +MODULE W3PRO2MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2014 | + !/ +-----------------------------------+ + !/ + !/ 04-Feb-2000 : Origination. ( version 2.00 ) + !/ 24-Jan-2001 : Flat grid version ( version 2.06 ) + !/ 08-Feb-2001 : UQ routines moved to own module ( version 2.08 ) + !/ 09-Feb-2001 : Clean up of parameter lists ( version 2.08 ) + !/ 14-Feb-2001 : Unit numbers in UQ routines ( version 2.08 ) + !/ 13-Nov-2001 : Sub-grid obstacles added. ( version 2.14 ) + !/ 26-Dec-2002 : Moving grid option. ( version 3.02 ) + !/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 07-Sep-2005 : Improved XY boundary conditions. ( version 3.08 ) + !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives. + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) + !/ factor with DXDP and DXDQ terms. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third + !/ and second order schemes. ( version 4.12 ) + !/ 29-May-2014 : Adding OMPH switch. ( version 5.02 ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Bundles routines for third order porpagation scheme in single + ! module. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! TRNMIN R.P. Private Minimum transparancy for local + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3MAP2 Subr. Public Set up auxiliary maps. + ! W3XYP2 Subr. Public Third order spatial propagation. + ! W3KTP2 Subr. Public Third order spectral propagation. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! W3QCK1 Subr. W3UQCKMD Regular grid UQ scheme. + ! W3QCK2 Subr. Id. Irregular grid UQ scheme. + ! W3QCK3 Subr. Id. Regular grid UQ scheme + obstructions. + ! W3UNO2 Subr. W3UNO2MD UNO2 scheme for irregular grid. + ! W3UNO2r Subr. Id. UNO2 scheme reduced to regular grid. + ! W3UNO2s Subr. Id. UNO2 regular grid with subgrid + ! obstruction. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/UQ 3rd order UQ propagation scheme. + ! !/UNO 2nd order UNO propagation scheme. + ! + ! !/MGP Correct for motion of grid. + ! + ! !/OMPH Hybrid OpenMP directives. + ! + ! !/TDYN, !/DSS0, !/XW0, !/XW1 + ! Diffusion options in W3XYP2 + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ Public variables + !/ + PUBLIC + !/ + !/ Private data + !/ + REAL, PRIVATE, PARAMETER:: TRNMIN = 0.95 + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3MAP2 + !/ + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 09-Nov-2005 | + !/ +-----------------------------------+ + !/ + !/ 19-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 15-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 09-Feb-2001 : Clean up of parameter lists ( version 2.08 ) + !/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) + !/ + ! 1. Purpose : + ! + ! Generate 'map' arrays for the ULTIMATE QUICKEST scheme. + ! + ! 2. Method : + ! + ! MAPX2, MAPY2, MAPTH2 and MAPWN2 contain consecutive 1-D spatial + ! grid counters (e.g., IXY = (IX-1)*MY + IY). The arrays are + ! devided in three parts. For MAPX2, these ranges are : + ! + ! 1 - NMX0 Counters IXY for which grid point (IX,IY) and + ! (IX+1,IY) both are active grid points. + ! NMX0+1 - NMX1 Id. only (IX,IY) active. + ! NMX1+1 - NMX2 Id. only (IX+1,IY) active. + ! + ! The array MAPY2 has a similar layout varying IY instead of IX. + ! MAPXY contains similar information for the cross term in the + ! diffusion correction (counter NMXY only). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Wave model routine. + ! --------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! ------------------------------------------------------ + ! 1. Map MAPX2 + ! a Range 1 to NMX0 + ! b Range NMX0+1 to NMX1 + ! c Range NMX1+1 to NMX2 + ! 2. Map MAPY2 + ! a Range 1 to NMY0 + ! b Range NMY0+1 to NMY1 + ! c Range NMY1+1 to NMY2 + ! 3. Map MAPAXY and MAPXY + ! 4. Maps for intra-spectral propagation + ! a MAPTH2, MAPATK + ! b MAPWN2 + ! ------------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NK, NTH, NSPEC, NX, NY, NSEA, MAPSTA + USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & + NMXY, MAPX2, MAPY2, MAPAXY, MAPXY, & + MAPTH2, MAPWN2 + USE W3ODATMD, ONLY: NDST #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IX, IY, IXY0, IX2, IY2, IX0, IY0, & - IK, ITH, ISP, ISP0, ISP2 + USE W3SERVMD, ONLY: STRACE +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IX, IY, IXY0, IX2, IY2, IX0, IY0, & + IK, ITH, ISP, ISP0, ISP2 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T - INTEGER :: MAPTXY(NY,NX), I, IXY - INTEGER :: MAPTST(NK+2,NTH) + INTEGER :: MAPTXY(NY,NX), I, IXY + INTEGER :: MAPTST(NK+2,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3MAP2') + CALL STRACE (IENT, 'W3MAP2') #endif -! -! 1. Map MAPX2 ------------------------------------------------------ * -! 1.a Range 1 to NMX0 -! + ! + ! 1. Map MAPX2 ------------------------------------------------------ * + ! 1.a Range 1 to NMX0 + ! #ifdef W3_T - MAPTXY = 0. -#endif -! - NMX0 = 0 - DO IX=1, NX - IXY0 = (IX-1)*NY - IX2 = 1 + MOD(IX,NX) - DO IY=2, NY-1 - IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN - NMX0 = NMX0 + 1 - MAPX2(NMX0) = IXY0 + IY + MAPTXY = 0. +#endif + ! + NMX0 = 0 + DO IX=1, NX + IXY0 = (IX-1)*NY + IX2 = 1 + MOD(IX,NX) + DO IY=2, NY-1 + IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN + NMX0 = NMX0 + 1 + MAPX2(NMX0) = IXY0 + IY #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 #endif - END IF - END DO - END DO -! -! 1.b Range NMX0+1 to NMX1 -! - NMX1 = NMX0 - DO IX=1, NX - IXY0 = (IX-1)*NY - IX2 = 1 + MOD(IX,NX) - DO IY=2, NY-1 - IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).NE.1 ) THEN - NMX1 = NMX1 + 1 - MAPX2(NMX1) = IXY0 + IY + END IF + END DO + END DO + ! + ! 1.b Range NMX0+1 to NMX1 + ! + NMX1 = NMX0 + DO IX=1, NX + IXY0 = (IX-1)*NY + IX2 = 1 + MOD(IX,NX) + DO IY=2, NY-1 + IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).NE.1 ) THEN + NMX1 = NMX1 + 1 + MAPX2(NMX1) = IXY0 + IY #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 #endif - END IF - END DO - END DO -! -! 1.c Range NMX1+1 to NMX2 -! - NMX2 = NMX1 - DO IX=1, NX - IXY0 = (IX-1)*NY - IX2 = 1 + MOD(IX,NX) - DO IY=2, NY-1 - IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN - NMX2 = NMX2 + 1 - MAPX2(NMX2) = IXY0 + IY + END IF + END DO + END DO + ! + ! 1.c Range NMX1+1 to NMX2 + ! + NMX2 = NMX1 + DO IX=1, NX + IXY0 = (IX-1)*NY + IX2 = 1 + MOD(IX,NX) + DO IY=2, NY-1 + IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN + NMX2 = NMX2 + 1 + MAPX2(NMX2) = IXY0 + IY #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 #endif - END IF - END DO - END DO -! + END IF + END DO + END DO + ! #ifdef W3_T - WRITE (NDST,9000) 'MAPX2', NMX0, NMX1-NMX0, & - NMX2-NMX1, NMX2 - DO IY=NY, 1, -1 - WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) - END DO -#endif -! -! 2. Map MAPY2 ------------------------------------------------------ * -! 2.a Range 1 to NMY0 -! -#ifdef W3_T - MAPTXY = 0. -#endif -! - NMY0 = 0 - DO IX=1, NX - IXY0 = (IX-1)*NY - DO IY=1, NY-1 - IY2 = IY + 1 - IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN - NMY0 = NMY0 + 1 - MAPY2(NMY0) = IXY0 + IY + WRITE (NDST,9000) 'MAPX2', NMX0, NMX1-NMX0, & + NMX2-NMX1, NMX2 + DO IY=NY, 1, -1 + WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) + END DO +#endif + ! + ! 2. Map MAPY2 ------------------------------------------------------ * + ! 2.a Range 1 to NMY0 + ! #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 -#endif - END IF - END DO - END DO -! -! 2.b Range NMY0+1 to NMY1 -! - NMY1 = NMY0 - DO IX=1, NX - IXY0 = (IX-1)*NY - DO IY=1, NY-1 - IY2 = IY + 1 - IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).NE.1 ) THEN - NMY1 = NMY1 + 1 - MAPY2(NMY1) = IXY0 + IY + MAPTXY = 0. +#endif + ! + NMY0 = 0 + DO IX=1, NX + IXY0 = (IX-1)*NY + DO IY=1, NY-1 + IY2 = IY + 1 + IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN + NMY0 = NMY0 + 1 + MAPY2(NMY0) = IXY0 + IY #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 #endif - END IF - END DO - END DO -! -! 2.c Range NMY1+1 to NMY2 -! - NMY2 = NMY1 - DO IX=1, NX - IXY0 = (IX-1)*NY - DO IY=1, NY-1 - IY2 = IY + 1 - IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN - NMY2 = NMY2 + 1 - MAPY2(NMY2) = IXY0 + IY -#ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 -#endif - END IF - END DO - END DO -! + END IF + END DO + END DO + ! + ! 2.b Range NMY0+1 to NMY1 + ! + NMY1 = NMY0 + DO IX=1, NX + IXY0 = (IX-1)*NY + DO IY=1, NY-1 + IY2 = IY + 1 + IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).NE.1 ) THEN + NMY1 = NMY1 + 1 + MAPY2(NMY1) = IXY0 + IY #ifdef W3_T - WRITE (NDST,9000) 'MAPY2', NMY0, NMY1-NMY0, & - NMY2-NMY1, NMY2 - DO IY=NY, 1, -1 - WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) - END DO + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 #endif -! -! 3. Map MAPAXY and MAPXY ------------------------------------------- * -! - NACT = 0 - DO IX=1, NX - IY0 = (IX-1)*NY - DO IY=2, NY-1 - IF ( MAPSTA(IY,IX).EQ.1 ) THEN - NACT = NACT + 1 - MAPAXY(NACT) = IY0 + IY - END IF - END DO - END DO -! - NMXY = 0 - DO IX=1, NX - IXY0 = (IX-1)*NY - IX2 = IX+1 - IF ( IX .EQ. NX ) IX2 = 1 - DO IY=2, NY-1 - IF ( MAPSTA( IY ,IX ).GE.1 .AND. & - MAPSTA( IY ,IX2).GE.1 .AND. & - MAPSTA(IY+1,IX ).GE.1 .AND. & - MAPSTA(IY+1,IX2).GE.1 ) THEN - NMXY = NMXY + 1 - MAPXY(NMXY) = IXY0 + IY - END IF - END DO - END DO -! -! 4. Maps for intra-spectral propagation ---------------------------- * -! - IF ( MAPTH2(1) .NE. 0 ) RETURN -! + END IF + END DO + END DO + ! + ! 2.c Range NMY1+1 to NMY2 + ! + NMY2 = NMY1 + DO IX=1, NX + IXY0 = (IX-1)*NY + DO IY=1, NY-1 + IY2 = IY + 1 + IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN + NMY2 = NMY2 + 1 + MAPY2(NMY2) = IXY0 + IY #ifdef W3_T - MAPTST = 0 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 #endif -! -! 4.a MAPTH2 and MAPBTK -! - DO IK=1, NK - DO ITH=1, NTH - ISP = ITH + (IK-1)*NTH - ISP2 = (IK+1) + (ITH-1)*(NK+2) - MAPTH2(ISP) = ISP2 + END IF + END DO + END DO + ! #ifdef W3_T - MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 -#endif - END DO - END DO -! + WRITE (NDST,9000) 'MAPY2', NMY0, NMY1-NMY0, & + NMY2-NMY1, NMY2 + DO IY=NY, 1, -1 + WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) + END DO +#endif + ! + ! 3. Map MAPAXY and MAPXY ------------------------------------------- * + ! + NACT = 0 + DO IX=1, NX + IY0 = (IX-1)*NY + DO IY=2, NY-1 + IF ( MAPSTA(IY,IX).EQ.1 ) THEN + NACT = NACT + 1 + MAPAXY(NACT) = IY0 + IY + END IF + END DO + END DO + ! + NMXY = 0 + DO IX=1, NX + IXY0 = (IX-1)*NY + IX2 = IX+1 + IF ( IX .EQ. NX ) IX2 = 1 + DO IY=2, NY-1 + IF ( MAPSTA( IY ,IX ).GE.1 .AND. & + MAPSTA( IY ,IX2).GE.1 .AND. & + MAPSTA(IY+1,IX ).GE.1 .AND. & + MAPSTA(IY+1,IX2).GE.1 ) THEN + NMXY = NMXY + 1 + MAPXY(NMXY) = IXY0 + IY + END IF + END DO + END DO + ! + ! 4. Maps for intra-spectral propagation ---------------------------- * + ! + IF ( MAPTH2(1) .NE. 0 ) RETURN + ! #ifdef W3_T - WRITE (NDST,9000) 'MAPTH2', ISP, 0, 0, ISP - DO IK=NK+2, 1, -1 - WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) - END DO + MAPTST = 0 #endif -! + ! + ! 4.a MAPTH2 and MAPBTK + ! + DO IK=1, NK + DO ITH=1, NTH + ISP = ITH + (IK-1)*NTH + ISP2 = (IK+1) + (ITH-1)*(NK+2) + MAPTH2(ISP) = ISP2 #ifdef W3_T - MAPTST = 0 + MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 #endif -! -! 4.b MAPWN2 -! - ISP0 = 0 - DO IK=1, NK-1 - DO ITH=1, NTH - ISP0 = ISP0 + 1 - ISP2 = (IK+1) + (ITH-1)*(NK+2) - MAPWN2(ISP0) = ISP2 + END DO + END DO + ! #ifdef W3_T - MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 -#endif - END DO - END DO -! + WRITE (NDST,9000) 'MAPTH2', ISP, 0, 0, ISP + DO IK=NK+2, 1, -1 + WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) + END DO + MAPTST = 0 +#endif + ! + ! 4.b MAPWN2 + ! + ISP0 = 0 + DO IK=1, NK-1 DO ITH=1, NTH ISP0 = ISP0 + 1 - ISP2 = NK+1 + (ITH-1)*(NK+2) + ISP2 = (IK+1) + (ITH-1)*(NK+2) MAPWN2(ISP0) = ISP2 #ifdef W3_T - MAPTST(NK+1,ITH) = MAPTST(NK+1,ITH) + 2 + MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 #endif - END DO -! - DO ITH=1, NTH - ISP0 = ISP0 + 1 - ISP2 = 1 + (ITH-1)*(NK+2) - MAPWN2(ISP0) = ISP2 + END DO + END DO + ! + DO ITH=1, NTH + ISP0 = ISP0 + 1 + ISP2 = NK+1 + (ITH-1)*(NK+2) + MAPWN2(ISP0) = ISP2 #ifdef W3_T - MAPTST(1,ITH) = MAPTST(1,ITH) + 4 -#endif - END DO -! + MAPTST(NK+1,ITH) = MAPTST(NK+1,ITH) + 2 +#endif + END DO + ! + DO ITH=1, NTH + ISP0 = ISP0 + 1 + ISP2 = 1 + (ITH-1)*(NK+2) + MAPWN2(ISP0) = ISP2 #ifdef W3_T - WRITE (NDST,9000) 'MAPWN2', NSPEC-NTH, NTH, NTH, NSPEC+NTH - DO IK=NK+2, 1, -1 - WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) - END DO + MAPTST(1,ITH) = MAPTST(1,ITH) + 4 #endif -! - RETURN -! -! Formats -! + END DO + ! #ifdef W3_T - 9000 FORMAT (/' TEST W3MAP2 : TEST MAP FOR PROPAGATION'/ & - ' MAP : ',A/ & - ' CENTRAL : ',I6/ & - ' ABOVE : ',I6/ & - ' BELOW : ',I6/ & - ' TOTAL : ',I6/) - 9001 FORMAT (1X,130I1) -#endif -! + WRITE (NDST,9000) 'MAPWN2', NSPEC-NTH, NTH, NTH, NSPEC+NTH + DO IK=NK+2, 1, -1 + WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9010 FORMAT (' TEST W3MAP2 : COMPOSITE MAPS TH2, WN2 AND BTK') - 9011 FORMAT (2X,60I2) -#endif -!/ -!/ End of W3MAP2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3MAP2 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2014 | -!/ +-----------------------------------+ -!/ -!/ 07-Jul-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 15-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 24-Jan-2001 : Flat grid version ( version 2.06 ) -!/ 09-Feb-2001 : Clean up of parameter lists ( version 2.08 ) -!/ 14-Feb-2001 : Unit numbers in UQ routines ( version 2.08 ) -!/ 13-Nov-2001 : Sub-grid obstructions. ( version 2.14 ) -!/ 26-Dec-2002 : Moving grid option, ( version 3.02 ) -!/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Improved boundary conditions. ( version 3.08 ) -!/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives. -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) -!/ factor with DXDP and DXDQ terms. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third -!/ and second order schemes. ( version 4.12 ) -!/ 29-May-2014 : Adding OMPH switch. ( version 5.02 ) -!/ -! 1. Purpose : -! -! Propagation in physical space for a given spectral component. -! -! 2. Method : -! -! Third-order ULTIMATE QUICKEST scheme and diffusion correction -! for linear dispersion (see manual). -! Curvilinear grid implementation: Fluxes are computed in index space -! and then transformed back into physical space. The diffusion term -! is handled in physical space. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH -! DTG Real I Total time step. -! MAPSTA I.A. I Grid point status map. -! MAPFS I.A. I Storage map. -! VQ R.A. I/O Field to propagate. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! NTLOC Int Number of local time steps. -! DTLOC Real Local propagation time step. -! CGD Real Deep water group velocity. -! DSSD, DNND Deep water diffusion coefficients. -! VLCFLX R.A. Local courant numbers in index space (norm. velocities) -! VLCFLY R.A. -! CXTOT R.A. Propagation velocities in physical space. -! CYTOT R.A. -! CELLP Real Cell Reynolds/Peclet number used to calculate -! diffusion coefficient for growing spectral -! components. -! DFRR Real Relative frequency increment. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Wave model routine. -! --------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Note that the ULTIMATE limiter does not guarantee non-zero -! energies. -! - The present scheme shows a strong distortion when propaga- -! ting a field under an angle with the grid in a truly 2-D -! fashion. Propagation is therefore split along the two -! axes. -! - Two boundary treatments are available. The first uses real -! boundaries in each space. In this case waves will not -! penetrate in narrow straights under an angle with the grid. -! This behavior is improved by using a 'soft' option, in -! which the 'X' or 'Y' sweep allows for energy to go onto -! the land. This improves the above behavior, but implies -! that X-Y connenctions are required in barriers for them -! to become inpenetrable. -! - If TDYN is set to zero, ALL diffusion is skipped. Set TDYN -! to a small positive number to have growth diffusion only. -! - Curvilinear grid implementation. Variables FACX, FACY, CCOS, CSIN, -! CCURX, CCURY are not needed and have been removed. FACX is accounted -! for as approriate in this subroutine. FACX is also accounted for in -! the case of .NOT.FLCX. Since FACX is removed, there is now a check for -! .NOT.FLCX in this subroutine. In CFL calcs dx and dy are omitted, -! since dx=dy=1 in index space. Curvilinear grid derivatives -! (DPDY, DQDX, etc.) and metric (GSQRT) are brought in via W3GDATMD. -! - Factors VFDIFX_FAC VFDIFY_FAC VFDIFC_FAC are introduced so that results -! match for test case tp2.3. Use of these factors is optional and removal -! can significantly reduce size/cost of code. These variants are marked as -! CURV1 or CURV2. NCEP will make final decision re: which version to adopt. -! CURV1 is the shorter version and results do not match the original code -! for all test cases. CURV2 is the longer version and results do match the -! original. DETAILED EXPLANATION: Discrepancies occur at the boundaries. -! This is because, at the boundaries, the pre-curvilinear version zeros out -! some terms in the diffusion calculation. Since they are zeroed out, -! they aren't there to *cancel* certain other terms: these "other terms" -! affect the result, so they have to be retained in the long vesion (CURV2) -! to get an exact match. In the short version, the "canceling out" is -! performed prior to coding the scheme, so both the canceled and canceling -! terms are always omitted. -! -! 8. Structure : -! -! --------------------------------------------- -! 1. Preparations -! a Set constants -! b Initialize arrays -! 2. Prepare arrays -! a Velocities and 'Q' -! b diffusion coefficients -! 3. Loop over sub-steps -! ---------------------------------------- -! a Propagate -! b Update boundary conditions -! c Diffusion correction -! ---------------------------------------- -! 4. Store Q field in spectra -! --------------------------------------------- -! -! 9. Switches : -! -! !/MGP Correct for motion of grid. -! -! !/TDYN Dynamic increase of DTME -! !/DSS0 Disable diffusion in propagation direction -! !/XW0 Propagation diffusion only. -! !/XW1 Growth diffusion only. -! -! !/OMPH Hybrid OpenMP directives. -! -! !/S Enable subroutine tracing. -! -! !/T Enable general test output. -! !/T1 Dump of input field and fluxes. -! !/T2 Dump of output field. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -! - USE W3TIMEMD, ONLY: DSEC21 -! - USE W3GDATMD, ONLY: NK, NTH, DTH, XFR, ESIN, ECOS, SIG, NX, NY, & - NSEA, SX, SY, MAPSF, ICLOSE, FLCX, FLCY, & - ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & - DTCFL, CLATS, DTME, CLATMN, FLAGLL, & - HPFAC, HQFAC, DPDX, DPDY, DQDX, DQDY, GSQRT - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: CG, WN, U10, CX, CY, ATRNX, ATRNY, ITIME, & - NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & - NMXY, MAPX2, MAPY2, MAPAXY, MAPXY - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & - ISBPI, BBPI0, BBPIN, IAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT (/' TEST W3MAP2 : TEST MAP FOR PROPAGATION'/ & + ' MAP : ',A/ & + ' CENTRAL : ',I6/ & + ' ABOVE : ',I6/ & + ' BELOW : ',I6/ & + ' TOTAL : ',I6/) +9001 FORMAT (1X,130I1) +9010 FORMAT (' TEST W3MAP2 : COMPOSITE MAPS TH2, WN2 AND BTK') +9011 FORMAT (2X,60I2) +#endif + !/ + !/ End of W3MAP2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3MAP2 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2014 | + !/ +-----------------------------------+ + !/ + !/ 07-Jul-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 15-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 24-Jan-2001 : Flat grid version ( version 2.06 ) + !/ 09-Feb-2001 : Clean up of parameter lists ( version 2.08 ) + !/ 14-Feb-2001 : Unit numbers in UQ routines ( version 2.08 ) + !/ 13-Nov-2001 : Sub-grid obstructions. ( version 2.14 ) + !/ 26-Dec-2002 : Moving grid option, ( version 3.02 ) + !/ 20-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 07-Sep-2005 : Improved boundary conditions. ( version 3.08 ) + !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives. + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) + !/ factor with DXDP and DXDQ terms. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third + !/ and second order schemes. ( version 4.12 ) + !/ 29-May-2014 : Adding OMPH switch. ( version 5.02 ) + !/ + ! 1. Purpose : + ! + ! Propagation in physical space for a given spectral component. + ! + ! 2. Method : + ! + ! Third-order ULTIMATE QUICKEST scheme and diffusion correction + ! for linear dispersion (see manual). + ! Curvilinear grid implementation: Fluxes are computed in index space + ! and then transformed back into physical space. The diffusion term + ! is handled in physical space. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH + ! DTG Real I Total time step. + ! MAPSTA I.A. I Grid point status map. + ! MAPFS I.A. I Storage map. + ! VQ R.A. I/O Field to propagate. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! NTLOC Int Number of local time steps. + ! DTLOC Real Local propagation time step. + ! CGD Real Deep water group velocity. + ! DSSD, DNND Deep water diffusion coefficients. + ! VLCFLX R.A. Local courant numbers in index space (norm. velocities) + ! VLCFLY R.A. + ! CXTOT R.A. Propagation velocities in physical space. + ! CYTOT R.A. + ! CELLP Real Cell Reynolds/Peclet number used to calculate + ! diffusion coefficient for growing spectral + ! components. + ! DFRR Real Relative frequency increment. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Wave model routine. + ! --------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Note that the ULTIMATE limiter does not guarantee non-zero + ! energies. + ! - The present scheme shows a strong distortion when propaga- + ! ting a field under an angle with the grid in a truly 2-D + ! fashion. Propagation is therefore split along the two + ! axes. + ! - Two boundary treatments are available. The first uses real + ! boundaries in each space. In this case waves will not + ! penetrate in narrow straights under an angle with the grid. + ! This behavior is improved by using a 'soft' option, in + ! which the 'X' or 'Y' sweep allows for energy to go onto + ! the land. This improves the above behavior, but implies + ! that X-Y connenctions are required in barriers for them + ! to become inpenetrable. + ! - If TDYN is set to zero, ALL diffusion is skipped. Set TDYN + ! to a small positive number to have growth diffusion only. + ! - Curvilinear grid implementation. Variables FACX, FACY, CCOS, CSIN, + ! CCURX, CCURY are not needed and have been removed. FACX is accounted + ! for as approriate in this subroutine. FACX is also accounted for in + ! the case of .NOT.FLCX. Since FACX is removed, there is now a check for + ! .NOT.FLCX in this subroutine. In CFL calcs dx and dy are omitted, + ! since dx=dy=1 in index space. Curvilinear grid derivatives + ! (DPDY, DQDX, etc.) and metric (GSQRT) are brought in via W3GDATMD. + ! - Factors VFDIFX_FAC VFDIFY_FAC VFDIFC_FAC are introduced so that results + ! match for test case tp2.3. Use of these factors is optional and removal + ! can significantly reduce size/cost of code. These variants are marked as + ! CURV1 or CURV2. NCEP will make final decision re: which version to adopt. + ! CURV1 is the shorter version and results do not match the original code + ! for all test cases. CURV2 is the longer version and results do match the + ! original. DETAILED EXPLANATION: Discrepancies occur at the boundaries. + ! This is because, at the boundaries, the pre-curvilinear version zeros out + ! some terms in the diffusion calculation. Since they are zeroed out, + ! they aren't there to *cancel* certain other terms: these "other terms" + ! affect the result, so they have to be retained in the long vesion (CURV2) + ! to get an exact match. In the short version, the "canceling out" is + ! performed prior to coding the scheme, so both the canceled and canceling + ! terms are always omitted. + ! + ! 8. Structure : + ! + ! --------------------------------------------- + ! 1. Preparations + ! a Set constants + ! b Initialize arrays + ! 2. Prepare arrays + ! a Velocities and 'Q' + ! b diffusion coefficients + ! 3. Loop over sub-steps + ! ---------------------------------------- + ! a Propagate + ! b Update boundary conditions + ! c Diffusion correction + ! ---------------------------------------- + ! 4. Store Q field in spectra + ! --------------------------------------------- + ! + ! 9. Switches : + ! + ! !/MGP Correct for motion of grid. + ! + ! !/TDYN Dynamic increase of DTME + ! !/DSS0 Disable diffusion in propagation direction + ! !/XW0 Propagation diffusion only. + ! !/XW1 Growth diffusion only. + ! + ! !/OMPH Hybrid OpenMP directives. + ! + ! !/S Enable subroutine tracing. + ! + ! !/T Enable general test output. + ! !/T1 Dump of input field and fluxes. + ! !/T2 Dump of output field. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + ! + USE W3TIMEMD, ONLY: DSEC21 + ! + USE W3GDATMD, ONLY: NK, NTH, DTH, XFR, ESIN, ECOS, SIG, NX, NY, & + NSEA, SX, SY, MAPSF, ICLOSE, FLCX, FLCY, & + ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & + DTCFL, CLATS, DTME, CLATMN, FLAGLL, & + HPFAC, HQFAC, DPDX, DPDY, DQDX, DQDY, GSQRT + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: CG, WN, U10, CX, CY, ATRNX, ATRNY, ITIME, & + NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & + NMXY, MAPX2, MAPY2, MAPAXY, MAPXY + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & + ISBPI, BBPI0, BBPIN, IAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_UQ - USE W3UQCKMD + USE W3UQCKMD #endif #ifdef W3_UNO - USE W3UNO2MD -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISP, MAPSTA(NY*NX), MAPFS(NY*NX) - REAL, INTENT(IN) :: DTG, VGX, VGY - REAL, INTENT(INOUT) :: VQ(1-NY:NY*(NX+2)) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK, NTLOC, ITLOC, ISEA, IXY, & - IX,IY, IY0, IP, IBI - INTEGER :: TTEST(2),DTTST + USE W3UNO2MD +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISP, MAPSTA(NY*NX), MAPFS(NY*NX) + REAL, INTENT(IN) :: DTG, VGX, VGY + REAL, INTENT(INOUT) :: VQ(1-NY:NY*(NX+2)) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK, NTLOC, ITLOC, ISEA, IXY, & + IX,IY, IY0, IP, IBI + INTEGER :: TTEST(2),DTTST #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & - CXMIN, CXMAX, CYMIN, CYMAX - REAL :: DTLOC, DTRAD, & - DFRR, CELLP, CGD, DSSD, & - DNND, DCELL, XWIND, TFAC, DSS, DNN - REAL :: RD1, RD2 - REAL :: RFAC, DFAC, DVQ, QXX, QXY, QYY - REAL :: CP, CQ - LOGICAL :: YFIRST - LOGICAL :: GLOBAL -!/ -!/ Automatic work arrays -!/ - REAL :: VLCFLX((NX+1)*NY), VLCFLY((NX+1)*NY),& - VFDIFX(1-NY:NX*NY), VFDIFY(NX*NY), & - VFDIFC(1-NY:NX*NY), VDXX((NX+1)*NY), & - VDYY(NX*NY), VDXY((NX+1)*NY) + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & + CXMIN, CXMAX, CYMIN, CYMAX + REAL :: DTLOC, DTRAD, & + DFRR, CELLP, CGD, DSSD, & + DNND, DCELL, XWIND, TFAC, DSS, DNN + REAL :: RD1, RD2 + REAL :: RFAC, DFAC, DVQ, QXX, QXY, QYY + REAL :: CP, CQ + LOGICAL :: YFIRST + LOGICAL :: GLOBAL + !/ + !/ Automatic work arrays + !/ + REAL :: VLCFLX((NX+1)*NY), VLCFLY((NX+1)*NY),& + VFDIFX(1-NY:NX*NY), VFDIFY(NX*NY), & + VFDIFC(1-NY:NX*NY), VDXX((NX+1)*NY), & + VDYY(NX*NY), VDXY((NX+1)*NY) - REAL :: CXTOT((NX+1)*NY), CYTOT(NX*NY) - REAL :: VQ_OLD(1-NY:NY*(NX+2)) -!CURV2: BEGIN ----------------------------------------------------------------- - REAL :: VFDIFX_FAC(1-NY:NX*NY), & - VFDIFY_FAC(1-NY:NX*NY), & - VFDIFC_FAC(1-NY:NX*NY) -!CURV2: END ------------------------------------------------------------------- -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: CXTOT((NX+1)*NY), CYTOT(NX*NY) + REAL :: VQ_OLD(1-NY:NY*(NX+2)) + !CURV2: BEGIN ----------------------------------------------------------------- + REAL :: VFDIFX_FAC(1-NY:NX*NY), & + VFDIFY_FAC(1-NY:NX*NY), & + VFDIFC_FAC(1-NY:NX*NY) + !CURV2: END ------------------------------------------------------------------- + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3XYP2') -#endif -! -! IF ( MAXVAL(VQ) .EQ. 0. ) THEN -! IF ( NBI .EQ. 0 ) THEN -! RETURN -! ELSE -! IF ( MAXVAL(BBPI0(ISP,:)) .EQ. 0. .AND. & -! MAXVAL(BBPIN(ISP,:)) .EQ. 0. ) RETURN -! END IF -! END IF -! -! 1. Preparations --------------------------------------------------- * + CALL STRACE (IENT, 'W3XYP2') +#endif + ! + ! IF ( MAXVAL(VQ) .EQ. 0. ) THEN + ! IF ( NBI .EQ. 0 ) THEN + ! RETURN + ! ELSE + ! IF ( MAXVAL(BBPI0(ISP,:)) .EQ. 0. .AND. & + ! MAXVAL(BBPIN(ISP,:)) .EQ. 0. ) RETURN + ! END IF + ! END IF + ! + ! 1. Preparations --------------------------------------------------- * - IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN - IF (IAPROC .EQ. NAPERR) & - WRITE(NDSE,*)'SUBROUTINE W3XYP2 IS NOT YET ADAPTED FOR '// & - 'TRIPOLE GRIDS. STOPPING NOW.' - CALL EXTCDE ( 1 ) - END IF + IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN + IF (IAPROC .EQ. NAPERR) & + WRITE(NDSE,*)'SUBROUTINE W3XYP2 IS NOT YET ADAPTED FOR '// & + 'TRIPOLE GRIDS. STOPPING NOW.' + CALL EXTCDE ( 1 ) + END IF -! 1.a Set constants -! - GLOBAL = ICLOSE.NE.ICLOSE_NONE - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH -! - CG0 = 0.575 * GRAV / SIG(1) - CGA = 0.575 * GRAV / SIG(IK) - CGX = CGA * ECOS(ITH) - CGY = CGA * ESIN(ITH) + ! 1.a Set constants + ! + GLOBAL = ICLOSE.NE.ICLOSE_NONE + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + ! + CG0 = 0.575 * GRAV / SIG(1) + CGA = 0.575 * GRAV / SIG(IK) + CGX = CGA * ECOS(ITH) + CGY = CGA * ESIN(ITH) #ifdef W3_MGP - CGX = CGX - VGX - CGY = CGY - VGY -#endif -! - IF ( FLCUR ) THEN - CXMIN = MINVAL ( CX(1:NSEA) ) - CXMAX = MAXVAL ( CX(1:NSEA) ) - CYMIN = MINVAL ( CY(1:NSEA) ) - CYMAX = MAXVAL ( CY(1:NSEA) ) - IF ( ABS(CGX+CXMIN) .GT. ABS(CGX+CXMAX) ) THEN - CGX = CGX + CXMIN - ELSE - CGX = CGX + CXMAX - END IF - IF ( ABS(CGY+CYMIN) .GT. ABS(CGY+CYMAX) ) THEN - CGY = CGY + CYMIN - ELSE - CGY = CGY + CYMAX - END IF - CXC = MAX ( ABS(CXMIN) , ABS(CXMAX) ) - CYC = MAX ( ABS(CYMIN) , ABS(CYMAX) ) -#ifdef W3_MGP - CXC = MAX ( ABS(CXMIN-VGX) , ABS(CXMAX-VGX) ) - CYC = MAX ( ABS(CYMIN-VGY) , ABS(CYMAX-VGY) ) -#endif - ELSE - CXC = 0. - CYC = 0. - END IF -! - CGN = 0.9999 * MAX( ABS(CGX) , ABS(CGY) , CXC, CYC, 0.001*CG0 ) -! - NTLOC = 1 + INT(DTG/(DTCFL*CG0/CGN)) - DTLOC = DTG / REAL(NTLOC) - DTRAD = DTLOC - IF ( FLAGLL ) DTRAD=DTRAD/(DERA*RADIUS) -! - IF ( FLAGLL ) THEN - RFAC = DERA * RADIUS - DFAC = 1. / RFAC**2 + CGX = CGX - VGX + CGY = CGY - VGY +#endif + ! + IF ( FLCUR ) THEN + CXMIN = MINVAL ( CX(1:NSEA) ) + CXMAX = MAXVAL ( CX(1:NSEA) ) + CYMIN = MINVAL ( CY(1:NSEA) ) + CYMAX = MAXVAL ( CY(1:NSEA) ) + IF ( ABS(CGX+CXMIN) .GT. ABS(CGX+CXMAX) ) THEN + CGX = CGX + CXMIN + ELSE + CGX = CGX + CXMAX + END IF + IF ( ABS(CGY+CYMIN) .GT. ABS(CGY+CYMAX) ) THEN + CGY = CGY + CYMIN ELSE - RFAC = 1. - DFAC = 1. + CGY = CGY + CYMAX END IF -! - TTEST(1) = TIME(1) - TTEST(2) = 0 - DTTST = DSEC21(TTEST,TIME) - YFIRST = MOD(NINT(DTTST/DTG),2) .EQ. 0 -! + CXC = MAX ( ABS(CXMIN) , ABS(CXMAX) ) + CYC = MAX ( ABS(CYMIN) , ABS(CYMAX) ) +#ifdef W3_MGP + CXC = MAX ( ABS(CXMIN-VGX) , ABS(CXMAX-VGX) ) + CYC = MAX ( ABS(CYMIN-VGY) , ABS(CYMAX-VGY) ) +#endif + ELSE + CXC = 0. + CYC = 0. + END IF + ! + CGN = 0.9999 * MAX( ABS(CGX) , ABS(CGY) , CXC, CYC, 0.001*CG0 ) + ! + NTLOC = 1 + INT(DTG/(DTCFL*CG0/CGN)) + DTLOC = DTG / REAL(NTLOC) + DTRAD = DTLOC + IF ( FLAGLL ) DTRAD=DTRAD/(DERA*RADIUS) + ! + IF ( FLAGLL ) THEN + RFAC = DERA * RADIUS + DFAC = 1. / RFAC**2 + ELSE + RFAC = 1. + DFAC = 1. + END IF + ! + TTEST(1) = TIME(1) + TTEST(2) = 0 + DTTST = DSEC21(TTEST,TIME) + YFIRST = MOD(NINT(DTTST/DTG),2) .EQ. 0 + ! #ifdef W3_T - WRITE (NDST,9000) YFIRST - WRITE (NDST,9001) ISP, ITH, IK, ECOS(ITH), ESIN(ITH) + WRITE (NDST,9000) YFIRST + WRITE (NDST,9001) ISP, ITH, IK, ECOS(ITH), ESIN(ITH) #endif -! + ! #ifdef W3_TDYN - IF ( ISP .EQ. 1 ) DTME = DTME + DTG -#endif -! - IF ( DTME .NE. 0. ) THEN - DFRR = XFR - 1. - CELLP = 10. - CGD = 0.5 * GRAV / SIG(IK) - DSSD = ( DFRR * CGD )**2 * DTME / 12. - DNND = ( CGD * DTH )**2 * DTME / 12. + IF ( ISP .EQ. 1 ) DTME = DTME + DTG +#endif + ! + IF ( DTME .NE. 0. ) THEN + DFRR = XFR - 1. + CELLP = 10. + CGD = 0.5 * GRAV / SIG(IK) + DSSD = ( DFRR * CGD )**2 * DTME / 12. + DNND = ( CGD * DTH )**2 * DTME / 12. #ifdef W3_T - WRITE (NDST,9002) DFRR, CELLP, DTME - ELSE - WRITE (NDST,9003) + WRITE (NDST,9002) DFRR, CELLP, DTME + ELSE + WRITE (NDST,9003) #endif - END IF + END IF -! -! 1.b Initialize arrays -! + ! + ! 1.b Initialize arrays + ! #ifdef W3_T - WRITE (NDST,9010) -#endif -! - VLCFLX = 0. - VLCFLY = 0. - VFDIFX = 0. - VFDIFY = 0. - VFDIFC = 0. - VDXX = 0. - VDYY = 0. - VDXY = 0. - CXTOT = 0. - CYTOT = 0. -! -! 2. Calculate velocities and diffusion coefficients ---------------- * -! 2.a Velocities -! -! Q = ( A / CG * CLATS ) -! LCFLX = ( COS*CG / CLATS ) * DT / DX -! LCFLY = ( SIN*CG ) * DT / DX -! + WRITE (NDST,9010) +#endif + ! + VLCFLX = 0. + VLCFLY = 0. + VFDIFX = 0. + VFDIFY = 0. + VFDIFC = 0. + VDXX = 0. + VDYY = 0. + VDXY = 0. + CXTOT = 0. + CYTOT = 0. + ! + ! 2. Calculate velocities and diffusion coefficients ---------------- * + ! 2.a Velocities + ! + ! Q = ( A / CG * CLATS ) + ! LCFLX = ( COS*CG / CLATS ) * DT / DX + ! LCFLY = ( SIN*CG ) * DT / DX + ! #ifdef W3_T - WRITE (NDST,9020) NSEA + WRITE (NDST,9020) NSEA #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IXY) -#endif -! - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - VQ (IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) - CXTOT(IXY) = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) - CYTOT(IXY) = ESIN(ITH) * CG(IK,ISEA) + !$OMP PARALLEL DO PRIVATE (ISEA, IXY) +#endif + ! + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + VQ (IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) + CXTOT(IXY) = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) + CYTOT(IXY) = ESIN(ITH) * CG(IK,ISEA) #ifdef W3_MGP - CXTOT(IXY) = CXTOT(IXY) - VGX/CLATS(ISEA) - CYTOT(IXY) = CYTOT(IXY) - VGY + CXTOT(IXY) = CXTOT(IXY) - VGX/CLATS(ISEA) + CYTOT(IXY) = CYTOT(IXY) - VGY #endif #ifdef W3_T1 - IF ( .NOT. FLCUR ) & - WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & - VQ(IXY), CXTOT(IXY), CYTOT(IXY) + IF ( .NOT. FLCUR ) & + WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & + VQ(IXY), CXTOT(IXY), CYTOT(IXY) #endif - END DO -! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - IF ( FLCUR ) THEN + ! + IF ( FLCUR ) THEN #ifdef W3_T - WRITE (NDST,9022) + WRITE (NDST,9022) #endif - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - CXTOT(IXY) = CXTOT(IXY) + CX(ISEA)/CLATS(ISEA) - CYTOT(IXY) = CYTOT(IXY) + CY(ISEA) + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + CXTOT(IXY) = CXTOT(IXY) + CX(ISEA)/CLATS(ISEA) + CYTOT(IXY) = CYTOT(IXY) + CY(ISEA) #ifdef W3_T1 - WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & - VQ(IXY), CXTOT(IXY), CYTOT(IXY) + WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & + VQ(IXY), CXTOT(IXY), CYTOT(IXY) #endif - END DO - END IF + END DO + END IF -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, CP, CQ) -#endif -! - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) - CP=CXTOT(IXY)*DPDX(IY,IX)+CYTOT(IXY)*DPDY(IY,IX) - CQ=CXTOT(IXY)*DQDX(IY,IX)+CYTOT(IXY)*DQDY(IY,IX) - VLCFLX(IXY) = CP*DTRAD - VLCFLY(IXY) = CQ*DTRAD - END DO -! + !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, CP, CQ) +#endif + ! + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + CP=CXTOT(IXY)*DPDX(IY,IX)+CYTOT(IXY)*DPDY(IY,IX) + CQ=CXTOT(IXY)*DQDX(IY,IX)+CYTOT(IXY)*DQDY(IY,IX) + VLCFLX(IXY) = CP*DTRAD + VLCFLY(IXY) = CQ*DTRAD + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! -! 2.b Diffusion coefficients -! - IF ( DTME .NE. 0. ) THEN -! + ! + ! 2.b Diffusion coefficients + ! + IF ( DTME .NE. 0. ) THEN + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, & -!$OMP& DCELL, XWIND, TFAC, DSS, DNN) -#endif -! - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) - IF ( MIN ( ATRNX(IXY,1) , ATRNX(IXY,-1) , & - ATRNY(IXY,1) , ATRNY(IXY,-1) ) .GT. TRNMIN ) THEN - DCELL = CGD * MIN ( HPFAC(IY,IX)*RFAC, & - HQFAC(IY,IX)*RFAC ) / CELLP - XWIND = 3.3 * U10(ISEA)*WN(IK,ISEA)/SIG(IK) - 2.3 - XWIND = MAX ( 0. , MIN ( 1. , XWIND ) ) + !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, & + !$OMP& DCELL, XWIND, TFAC, DSS, DNN) +#endif + ! + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + IF ( MIN ( ATRNX(IXY,1) , ATRNX(IXY,-1) , & + ATRNY(IXY,1) , ATRNY(IXY,-1) ) .GT. TRNMIN ) THEN + DCELL = CGD * MIN ( HPFAC(IY,IX)*RFAC, & + HQFAC(IY,IX)*RFAC ) / CELLP + XWIND = 3.3 * U10(ISEA)*WN(IK,ISEA)/SIG(IK) - 2.3 + XWIND = MAX ( 0. , MIN ( 1. , XWIND ) ) #ifdef W3_XW0 - XWIND = 0. + XWIND = 0. #endif #ifdef W3_XW1 - XWIND = 1. + XWIND = 1. #endif - TFAC = MIN ( 1. , (CLATS(ISEA)/CLATMN)**2 ) - DSS = XWIND * DCELL + (1.-XWIND) * DSSD * TFAC + TFAC = MIN ( 1. , (CLATS(ISEA)/CLATMN)**2 ) + DSS = XWIND * DCELL + (1.-XWIND) * DSSD * TFAC #ifdef W3_DSS0 - DSS = 0. + DSS = 0. #endif - DNN = XWIND * DCELL + (1.-XWIND) * DNND * TFAC + DNN = XWIND * DCELL + (1.-XWIND) * DNND * TFAC - VDXX(IXY) = DTLOC * (DSS*ECOS(ITH)**2+DNN*ESIN(ITH)**2) - VDYY(IXY) = DTLOC * (DSS*ESIN(ITH)**2+DNN*ECOS(ITH)**2) & - / CLATS(ISEA)**2 - VDXY(IXY) = DTLOC * (DSS-DNN) * ESIN(ITH)*ECOS(ITH) & - / CLATS(ISEA) + VDXX(IXY) = DTLOC * (DSS*ECOS(ITH)**2+DNN*ESIN(ITH)**2) + VDYY(IXY) = DTLOC * (DSS*ESIN(ITH)**2+DNN*ECOS(ITH)**2) & + / CLATS(ISEA)**2 + VDXY(IXY) = DTLOC * (DSS-DNN) * ESIN(ITH)*ECOS(ITH) & + / CLATS(ISEA) - END IF - END DO -! -#ifdef W3_OMPH -!$OMP END PARALLEL DO -#endif -! END IF -! -! 3. Loop over sub-steps -------------------------------------------- * -! - DO ITLOC=1, NTLOC -! -! 3.a Propagate fields -! + END DO + ! +#ifdef W3_OMPH + !$OMP END PARALLEL DO +#endif + ! + END IF + ! + ! 3. Loop over sub-steps -------------------------------------------- * + ! + DO ITLOC=1, NTLOC + ! + ! 3.a Propagate fields + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY ) + !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY ) #endif -! + ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) IXY = MAPSF(ISEA,3) VQ(IXY)= VQ(IXY) * GSQRT(IY,IX) END DO -! + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - IF ( YFIRST ) THEN -! + ! + IF ( YFIRST ) THEN + ! #ifdef W3_UQ - IF ( FLCY ) CALL W3QCK3 & - (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & - .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & - NMY1, NMY2, NDSE, NDST ) - IF ( FLCX ) CALL W3QCK3 & - (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & - GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & - NMX1, NMX2, NDSE, NDST ) -#endif -! + IF ( FLCY ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) + IF ( FLCX ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) +#endif + ! #ifdef W3_UNO - IF ( FLCY ) CALL W3UNO2s & - (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & - .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & - NMY1, NMY2, NDSE, NDST ) - IF ( FLCX ) CALL W3UNO2s & - (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & - GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & - NMX1, NMX2, NDSE, NDST ) -#endif -! - ELSE -! + IF ( FLCY ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) + IF ( FLCX ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) +#endif + ! + ELSE + ! #ifdef W3_UQ - IF ( FLCX ) CALL W3QCK3 & - (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & - GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & - NMX1, NMX2, NDSE, NDST ) - IF ( FLCY ) CALL W3QCK3 & - (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & - .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & - NMY1, NMY2, NDSE, NDST ) -#endif -! + IF ( FLCX ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) + IF ( FLCY ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) +#endif + ! #ifdef W3_UNO - IF ( FLCX ) CALL W3UNO2s & - (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & - GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & - NMX1, NMX2, NDSE, NDST ) - IF ( FLCY ) CALL W3UNO2s & - (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & - .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & - NMY1, NMY2, NDSE, NDST ) -#endif -! - END IF -! + IF ( FLCX ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) + IF ( FLCY ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) +#endif + ! + END IF + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY ) + !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY ) #endif -! + ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) IXY = MAPSF(ISEA,3) VQ(IXY)= VQ(IXY) / GSQRT(IY,IX) END DO -! + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO -#endif -! -! 3.b Update boundaries -! - IF ( FLBPI ) THEN - RD1 = DSEC21 ( TBPI0, TIME ) - DTG * & - REAL(NTLOC-ITLOC)/REAL(NTLOC) - RD2 = DSEC21 ( TBPI0, TBPIN ) - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF - DO IBI=1, NBI - ISEA = ISBPI(IBI) - IXY = MAPSF(ISBPI(IBI),3) - VQ(IXY) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - / CG(IK,ISEA) * CLATS(ISEA) - END DO - END IF -! -! 3.c Diffusion correction -! - IF ( DTME .NE. 0. ) THEN + !$OMP END PARALLEL DO +#endif + ! + ! 3.b Update boundaries + ! + IF ( FLBPI ) THEN + RD1 = DSEC21 ( TBPI0, TIME ) - DTG * & + REAL(NTLOC-ITLOC)/REAL(NTLOC) + RD2 = DSEC21 ( TBPI0, TBPIN ) + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. + END IF + DO IBI=1, NBI + ISEA = ISBPI(IBI) + IXY = MAPSF(ISBPI(IBI),3) + VQ(IXY) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + / CG(IK,ISEA) * CLATS(ISEA) + END DO + END IF + ! + ! 3.c Diffusion correction + ! + IF ( DTME .NE. 0. ) THEN - IF ( GLOBAL ) THEN - DO IY=1, NY - VQ(IY+NX*NY) = VQ(IY) - END DO - END IF + IF ( GLOBAL ) THEN + DO IY=1, NY + VQ(IY+NX*NY) = VQ(IY) + END DO + END IF -!CURV2: BEGIN ----------------------------------------------------------------- - VFDIFX_FAC=0.0 - DO IP=1, NMX0 - IXY = MAPX2(IP) - VFDIFX_FAC(IXY) = 1.0 - END DO - VFDIFY_FAC=0.0 - DO IP=1, NMY0 - IXY = MAPY2(IP) - VFDIFY_FAC(IXY) = 1.0 - END DO - VFDIFC_FAC=0.0 - DO IP=1, NMXY - IXY = MAPXY(IP) - VFDIFC_FAC(IXY) = 1.0 - END DO - IF ( GLOBAL ) THEN - IY0 = (NX-1)*NY - DO IY=1, NY - VFDIFX_FAC(IY-NY) = VFDIFX_FAC(IY+IY0) - VFDIFC_FAC(IY-NY) = VFDIFC_FAC(IY+IY0) - END DO - END IF -!CURV2: END ------------------------------------------------------------------- + !CURV2: BEGIN ----------------------------------------------------------------- + VFDIFX_FAC=0.0 + DO IP=1, NMX0 + IXY = MAPX2(IP) + VFDIFX_FAC(IXY) = 1.0 + END DO + VFDIFY_FAC=0.0 + DO IP=1, NMY0 + IXY = MAPY2(IP) + VFDIFY_FAC(IXY) = 1.0 + END DO + VFDIFC_FAC=0.0 + DO IP=1, NMXY + IXY = MAPXY(IP) + VFDIFC_FAC(IXY) = 1.0 + END DO + IF ( GLOBAL ) THEN + IY0 = (NX-1)*NY + DO IY=1, NY + VFDIFX_FAC(IY-NY) = VFDIFX_FAC(IY+IY0) + VFDIFC_FAC(IY-NY) = VFDIFC_FAC(IY+IY0) + END DO + END IF + !CURV2: END ------------------------------------------------------------------- - VQ_OLD = VQ -! + VQ_OLD = VQ + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, & -!$OMP& QXX, QYY, QXY, DVQ ) -#endif -! - DO IP=1, NACT - IXY = MAPAXY(IP) - ISEA = MAPFS(IXY) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, & + !$OMP& QXX, QYY, QXY, DVQ ) +#endif + ! + DO IP=1, NACT + IXY = MAPAXY(IP) + ISEA = MAPFS(IXY) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) -!CURV1: DOES NOT GIVE EXACT MATCH TO EARLIER WW3 VERSION FOR TEST CASE TP2.3 -!CURV1: NEAR THE BOUNDARY, NOTE THAT THIS VERSION USES NON-ACTIVE GRID POINTS -!CURV1: IN ITS CALCS. THIS IS NO PROBLEM, AS LONG AS THE NON-ACTIVE GRID POINTS -!CURV1: EXIST IN THE ARRAY AND ARE VQ=0. ALSO NOTE THAT WITH THE SHORT VERSION -!CURV1: OF THE CODE, VFDIF?_FAC VARIABLES CAN BE REMOVED AND 3-4 DO LOOPS ABOVE -!CURV1: CAN BE REMOVED. -!CURV1: BEGIN ----------------------------------------------------------------- -! QXX = VQ_OLD(IXY+NY) - 2.0*VQ_OLD(IXY) + VQ_OLD(IXY-NY) -! QYY = VQ_OLD(IXY+1) - 2.0*VQ_OLD(IXY) + VQ_OLD(IXY-1) -! QXY = VQ_OLD(IXY+NY+1) - VQ_OLD(IXY-NY+1) & -! - VQ_OLD(IXY+NY-1) + VQ_OLD(IXY-NY-1) -!CURV1: END ------------------------------------------------------------------- + !CURV1: DOES NOT GIVE EXACT MATCH TO EARLIER WW3 VERSION FOR TEST CASE TP2.3 + !CURV1: NEAR THE BOUNDARY, NOTE THAT THIS VERSION USES NON-ACTIVE GRID POINTS + !CURV1: IN ITS CALCS. THIS IS NO PROBLEM, AS LONG AS THE NON-ACTIVE GRID POINTS + !CURV1: EXIST IN THE ARRAY AND ARE VQ=0. ALSO NOTE THAT WITH THE SHORT VERSION + !CURV1: OF THE CODE, VFDIF?_FAC VARIABLES CAN BE REMOVED AND 3-4 DO LOOPS ABOVE + !CURV1: CAN BE REMOVED. + !CURV1: BEGIN ----------------------------------------------------------------- + ! QXX = VQ_OLD(IXY+NY) - 2.0*VQ_OLD(IXY) + VQ_OLD(IXY-NY) + ! QYY = VQ_OLD(IXY+1) - 2.0*VQ_OLD(IXY) + VQ_OLD(IXY-1) + ! QXY = VQ_OLD(IXY+NY+1) - VQ_OLD(IXY-NY+1) & + ! - VQ_OLD(IXY+NY-1) + VQ_OLD(IXY-NY-1) + !CURV1: END ------------------------------------------------------------------- -!CURV2: DOES GIVE EXACT MATCH TO EARLIER WW3 VERSION FOR TEST CASE TP2.3. NOTE -!CURV2: THAT IF VFDIFC_FAC VARIABLES ARE ALL UNITY, MANY TERMS CANCEL OUT. -!CURV2: HOWEVER, VFDIFC_FAC IS ZERO WHEN A RELATED VQ POINT IS NOT AN ACTIVE -!CURV2: GRID POINT -!CURV2: BEGIN ----------------------------------------------------------------- - QXX = VFDIFX_FAC(IXY) *VQ_OLD(IXY+NY) & - - VFDIFX_FAC(IXY) *VQ_OLD(IXY) & - - VFDIFX_FAC(IXY-NY)*VQ_OLD(IXY) & - + VFDIFX_FAC(IXY-NY)*VQ_OLD(IXY-NY) - QYY = VFDIFY_FAC(IXY) *VQ_OLD(IXY+1) & - - VFDIFY_FAC(IXY) *VQ_OLD(IXY) & - - VFDIFY_FAC(IXY-1) *VQ_OLD(IXY) & - + VFDIFY_FAC(IXY-1) *VQ_OLD(IXY-1) - QXY = VFDIFC_FAC(IXY) *VQ_OLD(IXY) & - + VFDIFC_FAC(IXY-NY-1)*VQ_OLD(IXY) & - - VFDIFC_FAC(IXY-1) *VQ_OLD(IXY) & - - VFDIFC_FAC(IXY-NY) *VQ_OLD(IXY) & - + VFDIFC_FAC(IXY-NY) *VQ_OLD(IXY+1) & - - VFDIFC_FAC(IXY) *VQ_OLD(IXY+1) & - + VFDIFC_FAC(IXY-1) *VQ_OLD(IXY-1) & - - VFDIFC_FAC(IXY-NY-1)*VQ_OLD(IXY-1) & - + VFDIFC_FAC(IXY-1) *VQ_OLD(IXY+NY) & - - VFDIFC_FAC(IXY) *VQ_OLD(IXY+NY) & - + VFDIFC_FAC(IXY-NY) *VQ_OLD(IXY-NY) & - - VFDIFC_FAC(IXY-NY-1)*VQ_OLD(IXY-NY) & - + VFDIFC_FAC(IXY) *VQ_OLD(IXY+NY+1) & - - VFDIFC_FAC(IXY-1) *VQ_OLD(IXY+NY-1) & - + VFDIFC_FAC(IXY-NY-1)*VQ_OLD(IXY-NY-1) & - - VFDIFC_FAC(IXY-NY) *VQ_OLD(IXY-NY+1) -!CURV2: END ------------------------------------------------------------------- -! - QXY = 0.25*QXY -! - DVQ = VDXX(IXY)*( DPDX(IY,IX)*DPDX(IY,IX)*QXX & - + 2.0*DPDX(IY,IX)*DQDX(IY,IX)*QXY & - + DQDX(IY,IX)*DQDX(IY,IX)*QYY ) & - + VDYY(IXY)*( DPDY(IY,IX)*DPDY(IY,IX)*QXX & - + 2.0*DPDY(IY,IX)*DQDY(IY,IX)*QXY & - + DQDY(IY,IX)*DQDY(IY,IX)*QYY) & - + 2.0*VDXY(IXY)*( DPDX(IY,IX)*DPDY(IY,IX)*QXX & - + DQDX(IY,IX)*DQDY(IY,IX)*QYY & - + ( DPDX(IY,IX)*DQDY(IY,IX) & - + DQDX(IY,IX)*DPDY(IY,IX) )*QXY ) -! - VQ(IXY) = VQ_OLD(IXY) + DVQ * DFAC -! - END DO -! + !CURV2: DOES GIVE EXACT MATCH TO EARLIER WW3 VERSION FOR TEST CASE TP2.3. NOTE + !CURV2: THAT IF VFDIFC_FAC VARIABLES ARE ALL UNITY, MANY TERMS CANCEL OUT. + !CURV2: HOWEVER, VFDIFC_FAC IS ZERO WHEN A RELATED VQ POINT IS NOT AN ACTIVE + !CURV2: GRID POINT + !CURV2: BEGIN ----------------------------------------------------------------- + QXX = VFDIFX_FAC(IXY) *VQ_OLD(IXY+NY) & + - VFDIFX_FAC(IXY) *VQ_OLD(IXY) & + - VFDIFX_FAC(IXY-NY)*VQ_OLD(IXY) & + + VFDIFX_FAC(IXY-NY)*VQ_OLD(IXY-NY) + QYY = VFDIFY_FAC(IXY) *VQ_OLD(IXY+1) & + - VFDIFY_FAC(IXY) *VQ_OLD(IXY) & + - VFDIFY_FAC(IXY-1) *VQ_OLD(IXY) & + + VFDIFY_FAC(IXY-1) *VQ_OLD(IXY-1) + QXY = VFDIFC_FAC(IXY) *VQ_OLD(IXY) & + + VFDIFC_FAC(IXY-NY-1)*VQ_OLD(IXY) & + - VFDIFC_FAC(IXY-1) *VQ_OLD(IXY) & + - VFDIFC_FAC(IXY-NY) *VQ_OLD(IXY) & + + VFDIFC_FAC(IXY-NY) *VQ_OLD(IXY+1) & + - VFDIFC_FAC(IXY) *VQ_OLD(IXY+1) & + + VFDIFC_FAC(IXY-1) *VQ_OLD(IXY-1) & + - VFDIFC_FAC(IXY-NY-1)*VQ_OLD(IXY-1) & + + VFDIFC_FAC(IXY-1) *VQ_OLD(IXY+NY) & + - VFDIFC_FAC(IXY) *VQ_OLD(IXY+NY) & + + VFDIFC_FAC(IXY-NY) *VQ_OLD(IXY-NY) & + - VFDIFC_FAC(IXY-NY-1)*VQ_OLD(IXY-NY) & + + VFDIFC_FAC(IXY) *VQ_OLD(IXY+NY+1) & + - VFDIFC_FAC(IXY-1) *VQ_OLD(IXY+NY-1) & + + VFDIFC_FAC(IXY-NY-1)*VQ_OLD(IXY-NY-1) & + - VFDIFC_FAC(IXY-NY) *VQ_OLD(IXY-NY+1) + !CURV2: END ------------------------------------------------------------------- + ! + QXY = 0.25*QXY + ! + DVQ = VDXX(IXY)*( DPDX(IY,IX)*DPDX(IY,IX)*QXX & + + 2.0*DPDX(IY,IX)*DQDX(IY,IX)*QXY & + + DQDX(IY,IX)*DQDX(IY,IX)*QYY ) & + + VDYY(IXY)*( DPDY(IY,IX)*DPDY(IY,IX)*QXX & + + 2.0*DPDY(IY,IX)*DQDY(IY,IX)*QXY & + + DQDY(IY,IX)*DQDY(IY,IX)*QYY) & + + 2.0*VDXY(IXY)*( DPDX(IY,IX)*DPDY(IY,IX)*QXX & + + DQDX(IY,IX)*DQDY(IY,IX)*QYY & + + ( DPDX(IY,IX)*DQDY(IY,IX) & + + DQDX(IY,IX)*DPDY(IY,IX) )*QXY ) + ! + VQ(IXY) = VQ_OLD(IXY) + DVQ * DFAC + ! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - END IF -! - YFIRST = .NOT. YFIRST - END DO -! -! 4. Store results in VQ in proper format --------------------------- * -! + ! + END IF + ! + YFIRST = .NOT. YFIRST + END DO + ! + ! 4. Store results in VQ in proper format --------------------------- * + ! #ifdef W3_T - WRITE (NDST,9040) NSEA + WRITE (NDST,9040) NSEA #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IXY ) + !$OMP PARALLEL DO PRIVATE (ISEA, IXY ) #endif -! - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .GT. 0 ) THEN + ! + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .GT. 0 ) THEN #ifdef W3_T2 - WRITE (NDST,9041) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), VQ(IXY) + WRITE (NDST,9041) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), VQ(IXY) #endif - VQ(IXY) = MAX ( 0. , CG(IK,ISEA) / CLATS(ISEA) * VQ(IXY) ) -! ELSE -! VQ(IXY) = 0. - END IF - END DO -! + VQ(IXY) = MAX ( 0. , CG(IK,ISEA) / CLATS(ISEA) * VQ(IXY) ) + ! ELSE + ! VQ(IXY) = 0. + END IF + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO -#endif -! - RETURN -! -! Formats -! -#ifdef W3_T - 9000 FORMAT (' TEST W3XYP2 : YFIRST :',L2) - 9001 FORMAT (' TEST W3XYP2 : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) - 9002 FORMAT (' TEST W3XYP2 : DFRR, CELLP, DTME :',3E10.3) - 9003 FORMAT (' TEST W3XYP2 : NO DISPERSION CORRECTION ') -#endif -! -#ifdef W3_T - 9010 FORMAT (' TEST W3XYP2 : INITIALIZE ARRAYS') + !$OMP END PARALLEL DO #endif -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9020 FORMAT (' TEST W3XYP2 : CALCULATING LCFLX/Y AND DSS/NN (NSEA=', & - I6,')') +9000 FORMAT (' TEST W3XYP2 : YFIRST :',L2) +9001 FORMAT (' TEST W3XYP2 : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) +9002 FORMAT (' TEST W3XYP2 : DFRR, CELLP, DTME :',3E10.3) +9003 FORMAT (' TEST W3XYP2 : NO DISPERSION CORRECTION ') +9010 FORMAT (' TEST W3XYP2 : INITIALIZE ARRAYS') +9020 FORMAT (' TEST W3XYP2 : CALCULATING LCFLX/Y AND DSS/NN (NSEA=', & + I6,')') +9022 FORMAT (' TEST W3XYP2 : CORRECTING FOR CURRENT') +9040 FORMAT (' TEST W3XYP2 : FIELD AFTER PROP. (NSEA=',I6,')') #endif #ifdef W3_T1 - 9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) -#endif -#ifdef W3_T - 9022 FORMAT (' TEST W3XYP2 : CORRECTING FOR CURRENT') -#endif -! -#ifdef W3_T - 9040 FORMAT (' TEST W3XYP2 : FIELD AFTER PROP. (NSEA=',I6,')') +9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) #endif #ifdef W3_T2 - 9041 FORMAT (1X,I6,2I5,E12.4) -#endif -!/ -!/ End of W3XYP2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3XYP2 -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE W3KTP2 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & - DDDX, DDDY, CX, CY, DCXDX, DCXDY, & - DCYDX, DCYDY, DCDX, DCDY, VA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Jul-2013 | -!/ +-----------------------------------+ -!/ -!/ 14-Feb-2000 : Origination. ( version 2.08 ) -!/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third -!/ and second order schemes. ( version 4.12 ) -!/ -! 1. Purpose : -! -! Propagation in spectral space. -! -! 2. Method : -! -! Third order QUICKEST scheme with ULTIMATE limiter. -! -! As with the spatial propagation, the two spaces are considered -! independently, but the propagation is performed in a 2-D space. -! Compared to the propagation in physical space, the directions -! rerpesent a closed space and are therefore comparable to the -! longitudinal or 'X' propagation. The wavenumber space has to be -! extended to allow for boundary treatment. Using a simple first -! order boundary treatment at both sided, two points need to -! be added. This implies that the spectrum needs to be extended, -! shifted and rotated, as is performed using MAPTH2 as set -! in W3MAP3. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISEA Int. I Number of sea point. -! FACTH/K Real I Factor in propagation velocity. -! CTHG0 Real I Factor in great circle refracftion term. -! MAPxx2 I.A. I Propagation and storage maps. -! CG R.A. I Local group velocities. -! WN R.A. I Local wavenumbers. -! DEPTH R.A. I Depth. -! DDDx Real I Depth gradients. -! CX/Y Real I Current components. -! DCxDx Real I Current gradients. -! DCDX-Y Real I Phase speed gradients. -! VA R.A. I/O Spectrum. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! DSDD R.A. Partial derivative of sigma for depth. -! FDD, FDU, FDG, FCD, FCU -! R.A. Directionally varying part of depth, current and -! great-circle refraction terms and of consit. -! of Ck term. -! CFLT-K R.A. Propagation velocities of local fluxes. -! DB R.A. Wavenumber band widths at cell centers. -! DM R.A. Wavenumber band widths between cell centers and -! next cell center. -! Q R.A. Extracted spectrum -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! W3QCK1 Actual propagation routine. -! W3QCK2 Actual propagation routine. -! STRACE Service routine. -! -! 5. Called by : -! -! W3WAVE Wave model routine. -! -! 6. Error messages : -! -! None. -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Preparations -! a Initialize arrays -! b Set constants and counters -! 2. Point preparations -! a Calculate DSDD -! b Extract spectrum -! 3. Refraction velocities -! a Filter level depth reffraction. -! b Depth refratcion velocity. -! c Current refraction velocity. -! 4. Wavenumber shift velocities -! a Prepare directional arrays -! b Calcuate velocity. -! 5. Propagate. -! 6. Store results. -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & - CTMAX - USE W3ADATMD, ONLY: MAPTH2, MAPWN2, ITIME - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, ONLY: NDSE, NDST +9041 FORMAT (1X,I6,2I5,E12.4) +#endif + !/ + !/ End of W3XYP2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3XYP2 + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE W3KTP2 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & + DDDX, DDDY, CX, CY, DCXDX, DCXDY, & + DCYDX, DCYDY, DCDX, DCDY, VA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Jul-2013 | + !/ +-----------------------------------+ + !/ + !/ 14-Feb-2000 : Origination. ( version 2.08 ) + !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third + !/ and second order schemes. ( version 4.12 ) + !/ + ! 1. Purpose : + ! + ! Propagation in spectral space. + ! + ! 2. Method : + ! + ! Third order QUICKEST scheme with ULTIMATE limiter. + ! + ! As with the spatial propagation, the two spaces are considered + ! independently, but the propagation is performed in a 2-D space. + ! Compared to the propagation in physical space, the directions + ! rerpesent a closed space and are therefore comparable to the + ! longitudinal or 'X' propagation. The wavenumber space has to be + ! extended to allow for boundary treatment. Using a simple first + ! order boundary treatment at both sided, two points need to + ! be added. This implies that the spectrum needs to be extended, + ! shifted and rotated, as is performed using MAPTH2 as set + ! in W3MAP3. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISEA Int. I Number of sea point. + ! FACTH/K Real I Factor in propagation velocity. + ! CTHG0 Real I Factor in great circle refracftion term. + ! MAPxx2 I.A. I Propagation and storage maps. + ! CG R.A. I Local group velocities. + ! WN R.A. I Local wavenumbers. + ! DEPTH R.A. I Depth. + ! DDDx Real I Depth gradients. + ! CX/Y Real I Current components. + ! DCxDx Real I Current gradients. + ! DCDX-Y Real I Phase speed gradients. + ! VA R.A. I/O Spectrum. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! DSDD R.A. Partial derivative of sigma for depth. + ! FDD, FDU, FDG, FCD, FCU + ! R.A. Directionally varying part of depth, current and + ! great-circle refraction terms and of consit. + ! of Ck term. + ! CFLT-K R.A. Propagation velocities of local fluxes. + ! DB R.A. Wavenumber band widths at cell centers. + ! DM R.A. Wavenumber band widths between cell centers and + ! next cell center. + ! Q R.A. Extracted spectrum + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! W3QCK1 Actual propagation routine. + ! W3QCK2 Actual propagation routine. + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3WAVE Wave model routine. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Preparations + ! a Initialize arrays + ! b Set constants and counters + ! 2. Point preparations + ! a Calculate DSDD + ! b Extract spectrum + ! 3. Refraction velocities + ! a Filter level depth reffraction. + ! b Depth refratcion velocity. + ! c Current refraction velocity. + ! 4. Wavenumber shift velocities + ! a Prepare directional arrays + ! b Calcuate velocity. + ! 5. Propagate. + ! 6. Store results. + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & + EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & + CTMAX + USE W3ADATMD, ONLY: MAPTH2, MAPWN2, ITIME + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, ONLY: NDSE, NDST #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_UQ - USE W3UQCKMD + USE W3UQCKMD #endif #ifdef W3_UNO - USE W3UNO2MD -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISEA - REAL, INTENT(IN) :: FACTH, FACK, CTHG0, CG(0:NK+1), & - WN(0:NK+1), DEPTH, DDDX, DDDY, & - CX, CY, DCXDX, DCXDY, DCYDX, DCYDY - REAL, INTENT(IN) :: DCDX(0:NK+1), DCDY(0:NK+1) - REAL, INTENT(INOUT) :: VA(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK, ISP + USE W3UNO2MD +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISEA + REAL, INTENT(IN) :: FACTH, FACK, CTHG0, CG(0:NK+1), & + WN(0:NK+1), DEPTH, DDDX, DDDY, & + CX, CY, DCXDX, DCXDY, DCYDX, DCYDY + REAL, INTENT(IN) :: DCDX(0:NK+1), DCDY(0:NK+1) + REAL, INTENT(INOUT) :: VA(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK, ISP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: FDDMAX, FDG, FKD, FKD0, DCYX, & - DCXXYY, DCXY, DCXX, DCXYYX, DCYY - REAL :: DSDD(0:NK+1), FRK(NK), FRG(NK), & - FKC(NTH), VQ(-NK-1:NK2*(NTH+2)), & - DB(NK2,NTH+1), DM(NK2,0:NTH+1), & - VCFLT(NK2*(NTH+1)), CFLK(NK2,NTH) -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: FDDMAX, FDG, FKD, FKD0, DCYX, & + DCXXYY, DCXY, DCXX, DCXYYX, DCYY + REAL :: DSDD(0:NK+1), FRK(NK), FRG(NK), & + FKC(NTH), VQ(-NK-1:NK2*(NTH+2)), & + DB(NK2,NTH+1), DM(NK2,0:NTH+1), & + VCFLT(NK2*(NTH+1)), CFLK(NK2,NTH) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3KTP2') -#endif -! -! 1. Preparations --------------------------------------------------- * -! 1.a Initialize arrays -! - IF ( FLCK ) VQ = 0. -! + CALL STRACE (IENT, 'W3KTP2') +#endif + ! + ! 1. Preparations --------------------------------------------------- * + ! 1.a Initialize arrays + ! + IF ( FLCK ) VQ = 0. + ! #ifdef W3_T - WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX - WRITE (NDST,9010) ISEA, DEPTH, CX, CY, DDDX, DDDY, & - DCXDX, DCXDY, DCYDX, DCYDY -#endif -! -! 2. Preparation for point ------------------------------------------ * -! 2.a Array with partial derivative of sigma versus depth -! - DO IK=0, NK+1 - IF ( DEPTH*WN(IK) .LT. 5. ) THEN - DSDD(IK) = MAX ( 0. , & - CG(IK)*WN(IK)-0.5*SIG(IK) ) / DEPTH - ELSE - DSDD(IK) = 0. - END IF - END DO -! + WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX + WRITE (NDST,9010) ISEA, DEPTH, CX, CY, DDDX, DDDY, & + DCXDX, DCXDY, DCYDX, DCYDY +#endif + ! + ! 2. Preparation for point ------------------------------------------ * + ! 2.a Array with partial derivative of sigma versus depth + ! + DO IK=0, NK+1 + IF ( DEPTH*WN(IK) .LT. 5. ) THEN + DSDD(IK) = MAX ( 0. , & + CG(IK)*WN(IK)-0.5*SIG(IK) ) / DEPTH + ELSE + DSDD(IK) = 0. + END IF + END DO + ! #ifdef W3_T - WRITE (NDST,9020) - DO IK=1, NK+1 - WRITE (NDST,9021) IK, TPI/SIG(IK), TPI/WN(IK), & - CG(IK), DSDD(IK) - END DO -#endif -! -! 2.b Extract spectrum -! + WRITE (NDST,9020) + DO IK=1, NK+1 + WRITE (NDST,9021) IK, TPI/SIG(IK), TPI/WN(IK), & + CG(IK), DSDD(IK) + END DO +#endif + ! + ! 2.b Extract spectrum + ! + DO ISP=1, NSPEC + VQ(MAPTH2(ISP)) = VA(ISP) + END DO + ! + ! 3. Refraction velocities ------------------------------------------ * + ! + IF ( FLCTH ) THEN + ! + ! 3.a Set slope filter for depth refraction + ! + FDDMAX = 0. + FDG = FACTH * CTHG0 + ! + DO ITH=1, NTH/2 + FDDMAX = MAX(FDDMAX,ABS(ESIN(ITH)*DDDX-ECOS(ITH)*DDDY)) + END DO + ! + DO IK=1, NK + FRK(IK) = FACTH * DSDD(IK) / WN(IK) + FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) + FRG(IK) = FDG * CG(IK) + END DO + ! + ! 3.b Depth refraction and great-circle propagation + ! DO ISP=1, NSPEC - VQ(MAPTH2(ISP)) = VA(ISP) - END DO -! -! 3. Refraction velocities ------------------------------------------ * -! - IF ( FLCTH ) THEN -! -! 3.a Set slope filter for depth refraction -! - FDDMAX = 0. - FDG = FACTH * CTHG0 -! - DO ITH=1, NTH/2 - FDDMAX = MAX(FDDMAX,ABS(ESIN(ITH)*DDDX-ECOS(ITH)*DDDY)) - END DO -! - DO IK=1, NK - FRK(IK) = FACTH * DSDD(IK) / WN(IK) - FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) - FRG(IK) = FDG * CG(IK) - END DO -! -! 3.b Depth refraction and great-circle propagation -! - DO ISP=1, NSPEC - VCFLT(MAPTH2(ISP)) = FRG(MAPWN(ISP)) * ECOS(ISP) & + VCFLT(MAPTH2(ISP)) = FRG(MAPWN(ISP)) * ECOS(ISP) & + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DDDX - ECOS(ISP)*DDDY ) - END DO -! -#ifdef W3_REFRX -! 3.c @C/@x refraction and great-circle propagation - VCFLT = 0. - FRK = 0. - FDDMAX = 0. -#endif -! -#ifdef W3_REFRX - DO ISP=1, NSPEC - FDDMAX = MAX ( FDDMAX , ABS ( & - ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) - END DO -#endif -! + END DO + ! #ifdef W3_REFRX - DO IK=1, NK - FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) - END DO - DO ISP=1, NSPEC - VCFLT(MAPTH2(ISP)) = FRG(MAPWN(ISP)) * ECOS(ISP) & - + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & - - ECOS(ISP)*DCDY(MAPWN(ISP)) ) - END DO + ! 3.c @C/@x refraction and great-circle propagation + VCFLT = 0. + FRK = 0. + FDDMAX = 0. + ! + DO ISP=1, NSPEC + FDDMAX = MAX ( FDDMAX , ABS ( & + ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) + END DO + ! + DO IK=1, NK + FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) + END DO + DO ISP=1, NSPEC + VCFLT(MAPTH2(ISP)) = FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & + - ECOS(ISP)*DCDY(MAPWN(ISP)) ) + END DO #endif -! -! 3.d Current refraction -! - IF ( FLCUR ) THEN -! - DCYX = FACTH * DCYDX - DCXXYY = FACTH * ( DCXDX - DCYDY ) - DCXY = FACTH * DCXDY -! - DO ISP=1, NSPEC - VCFLT(MAPTH2(ISP)) = VCFLT(MAPTH2(ISP)) + & - ES2(ISP)*DCYX + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY - END DO -! - END IF -! - END IF -! -! 4. Wavenumber shift velocities ------------------------------------ * -! FACK is just the time step, which is accounted for in W3QCK2 -! + ! + ! 3.d Current refraction + ! + IF ( FLCUR ) THEN + ! + DCYX = FACTH * DCYDX + DCXXYY = FACTH * ( DCXDX - DCYDY ) + DCXY = FACTH * DCXDY + ! + DO ISP=1, NSPEC + VCFLT(MAPTH2(ISP)) = VCFLT(MAPTH2(ISP)) + & + ES2(ISP)*DCYX + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY + END DO + ! + END IF + ! + END IF + ! + ! 4. Wavenumber shift velocities ------------------------------------ * + ! FACK is just the time step, which is accounted for in W3QCK2 + ! + IF ( FLCK ) THEN + ! + ! 4.a Directionally dependent part + ! + DCXX = - DCXDX + DCXYYX = - ( DCXDY + DCYDX ) + DCYY = - DCYDY + FKD = ( CX*DDDX + CY*DDDY ) + ! + DO ITH=1, NTH + FKC(ITH) = EC2(ITH)*DCXX + & + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY + END DO + ! + ! 4.b Velocities + ! + DO IK=0, NK+1 + FKD0 = FKD / CG(IK) * DSDD(IK) + DO ITH=1, NTH + CFLK(IK+1,ITH) = FKD0 + WN(IK)*FKC(ITH) + END DO + END DO + ! + ! 4.c Band widths + ! + DO IK=0, NK + DB(IK+1,1) = DSIP(IK) / CG(IK) + DM(IK+1,1) = WN(IK+1) - WN(IK) + END DO + DB(NK+2,1) = DSIP(NK+1) / CG(NK+1) + DM(NK+2,1) = 0. + ! + DO ITH=2, NTH + DO IK=1, NK+2 + DB(IK,ITH) = DB(IK,1) + DM(IK,ITH) = DM(IK,1) + END DO + END DO + ! + END IF + ! + ! 5. Propagate ------------------------------------------------------ * + ! + IF ( MOD(ITIME,2) .EQ. 0 ) THEN IF ( FLCK ) THEN -! -! 4.a Directionally dependent part -! - DCXX = - DCXDX - DCXYYX = - ( DCXDY + DCYDX ) - DCYY = - DCYDY - FKD = ( CX*DDDX + CY*DDDY ) -! - DO ITH=1, NTH - FKC(ITH) = EC2(ITH)*DCXX + & - ESC(ITH)*DCXYYX + ES2(ITH)*DCYY - END DO -! -! 4.b Velocities -! - DO IK=0, NK+1 - FKD0 = FKD / CG(IK) * DSDD(IK) - DO ITH=1, NTH - CFLK(IK+1,ITH) = FKD0 + WN(IK)*FKC(ITH) - END DO - END DO -! -! 4.c Band widths -! - DO IK=0, NK - DB(IK+1,1) = DSIP(IK) / CG(IK) - DM(IK+1,1) = WN(IK+1) - WN(IK) - END DO - DB(NK+2,1) = DSIP(NK+1) / CG(NK+1) - DM(NK+2,1) = 0. -! - DO ITH=2, NTH - DO IK=1, NK+2 - DB(IK,ITH) = DB(IK,1) - DM(IK,ITH) = DM(IK,1) - END DO - END DO -! - END IF -! -! 5. Propagate ------------------------------------------------------ * -! - IF ( MOD(ITIME,2) .EQ. 0 ) THEN - IF ( FLCK ) THEN - DO ITH=1, NTH - VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) - END DO -! + DO ITH=1, NTH + VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) + END DO + ! #ifdef W3_UQ - CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & - VQ, .FALSE., 1, MAPTH2, NSPEC, & - MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & - NDSE, NDST ) + CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) #endif -! + ! #ifdef W3_UNO - CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & - VQ, .FALSE., 1, MAPTH2, NSPEC, & - MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & - NDSE, NDST ) -#endif - END IF - IF ( FLCTH ) THEN -! + CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) +#endif + END IF + IF ( FLCTH ) THEN + ! #ifdef W3_UQ - CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & - NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & - NSPEC, NDSE, NDST ) + CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & + NSPEC, NDSE, NDST ) #endif -! + ! #ifdef W3_UNO - CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & - NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& - NSPEC, NDSE, NDST ) + CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& + NSPEC, NDSE, NDST ) #endif -! - END IF - ELSE - IF ( FLCTH ) THEN -! + ! + END IF + ELSE + IF ( FLCTH ) THEN + ! #ifdef W3_UQ - CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & - NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & - NSPEC, NDSE, NDST ) + CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & + NSPEC, NDSE, NDST ) #endif -! + ! #ifdef W3_UNO - CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & - NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& - NSPEC, NDSE, NDST ) -#endif -! - END IF - IF ( FLCK ) THEN - DO ITH=1, NTH - VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) - END DO -! + CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& + NSPEC, NDSE, NDST ) +#endif + ! + END IF + IF ( FLCK ) THEN + DO ITH=1, NTH + VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) + END DO + ! #ifdef W3_UQ - CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & - VQ, .FALSE., 1, MAPTH2, NSPEC, & - MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & - NDSE, NDST ) + CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) #endif -! + ! #ifdef W3_UNO - CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & - VQ, .FALSE., 1, MAPTH2, NSPEC, & - MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & - NDSE, NDST ) + CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) #endif -! - END IF - END IF -! -! 6. Store reults --------------------------------------------------- * -! - DO ISP=1, NSPEC - VA(ISP) = VQ(MAPTH2(ISP)) - END DO -! - RETURN -! -! Formats -! + ! + END IF + END IF + ! + ! 6. Store reults --------------------------------------------------- * + ! + DO ISP=1, NSPEC + VA(ISP) = VQ(MAPTH2(ISP)) + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3KTP2 : FLCTH-K, FACTH-K, CTMAX :', & - 2L2,2E10.3,F7.3) - 9010 FORMAT ( ' TEST W3KTP2 : LOCAL DATA :',I7,F7.1,2F6.2,1X,6E10.2) - 9020 FORMAT ( ' TEST W3KTP2 : IK, T, L, CG, DSDD : ') - 9021 FORMAT ( ' ',I3,F7.2,F7.1,F7.2,E11.3) +9000 FORMAT ( ' TEST W3KTP2 : FLCTH-K, FACTH-K, CTMAX :', & + 2L2,2E10.3,F7.3) +9010 FORMAT ( ' TEST W3KTP2 : LOCAL DATA :',I7,F7.1,2F6.2,1X,6E10.2) +9020 FORMAT ( ' TEST W3KTP2 : IK, T, L, CG, DSDD : ') +9021 FORMAT ( ' ',I3,F7.2,F7.1,F7.2,E11.3) #endif -! + ! #ifdef W3_T0 - 9040 FORMAT (/' TEST W3KTP2 : NORMALIZED ',A/) - 9041 FORMAT (1X,60(1X,I2)) - 9042 FORMAT (1X,60I3) -#endif -!/ -!/ End of W3KTP2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3KTP2 -!/ -!/ End of module W3PRO2MD -------------------------------------------- / -!/ - END MODULE W3PRO2MD - +9040 FORMAT (/' TEST W3KTP2 : NORMALIZED ',A/) +9041 FORMAT (1X,60(1X,I2)) +9042 FORMAT (1X,60I3) +#endif + !/ + !/ End of W3KTP2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3KTP2 + !/ + !/ End of module W3PRO2MD -------------------------------------------- / + !/ +END MODULE W3PRO2MD diff --git a/model/src/w3pro3md.F90 b/model/src/w3pro3md.F90 index afec95b66..157b9be09 100644 --- a/model/src/w3pro3md.F90 +++ b/model/src/w3pro3md.F90 @@ -1,376 +1,376 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3PRO3MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2014 | -!/ +-----------------------------------+ -!/ -!/ 27-Feb-2000 : Origination. ( version 2.08 ) -!/ 17-Sep-2000 : Clean-up. ( version 2.13 ) -!/ 10-Dec-2001 : Sub-grid obstructions. ( version 2.14 ) -!/ 16-Oct-2002 : Change INTENT for ATRN in W3XYP3. ( version 3.00 ) -!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) -!/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) -!/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Upgrade XY boundary conditions. ( version 3.08 ) -!/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives. -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 01-Apr-2008 : Bug fix W3MAP3 MAPSTA range check. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 17-Aug-2010 : Add test output W3XYP3. ( version 3.14.5 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 26-Dec-2012 : More initializations. ( version 4.11 ) -!/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third -!/ and second order schemes. ( version 4.12 ) -!/ 12-Sep-2013 : Add documentation for global clos. ( version 4.12 ) -!/ 27-May-2014 : Adding OMPH switch. ( version 5.02 ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Bundles routines for third order propagation scheme in single -! module. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! TRNMIN R.P. Private Minimum transparancy for local -! switching off of averaging. -! ---------------------------------------------------------------- -! -! Also work arrays for W3KTP3 (private). -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3MAP3 Subr. Public Set up auxiliary maps. -! W3MAPT Subr. Public Set up transparency map for GSE. -! W3XYP3 Subr. Public Third order spatial propagation. -! W3KTP3 Subr. Public Third order spectral propagation. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! W3QCK1 Subr. W3UQCKMD Regular grid UQ scheme. -! W3QCK2 Subr. Id. Irregular grid UQ scheme. -! W3QCK3 Subr. Id. Regular grid UQ scheme + obstructions. -! W3UNO2 Subr. W3UNO2MD UNO2 scheme for irregular grid. -! W3UNO2r Subr. Id. UNO2 scheme reduced to regular grid. -! W3UNO2s Subr. Id. UNO2 regular grid with subgrid -! obstruction. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - The averaging is not performed around semi-transparent grid -! points to avoid that leaking through barriers occurs. -! -! 6. Switches : -! -! !/UQ 3rd order UQ propagation scheme. -! !/UNO 2nd order UNO propagation scheme. -! -! !/MGP Moving grid corrections. -! !/MGG Moving grid corrections. -! -! !/OMPH Hybrid OpenMP directives. -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ Public variables -!/ - PUBLIC -!/ -!/ Private data -!/ - REAL, PRIVATE, PARAMETER:: TRNMIN = 0.95 -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3MAP3 -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Apr-2008 | -!/ +-----------------------------------+ -!/ -!/ 27-Feb-2000 : Origination. ( version 2.08 ) -!/ 10-Dec-2001 : Sub-grid obstructions. ( version 2.14 ) -!/ (array allocation only.) -!/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) -!/ 01-Apr-2008 : Bug fix sec. 4 MAPSTA range check. ( version 3.13 ) -!/ -! 1. Purpose : -! -! Generate 'map' arrays for the ULTIMATE QUICKEST scheme. -! -! 2. Method : -! -! MAPX2, MAPY2, MAPTH2 and MAPWN2 contain consecutive 1-D spatial -! grid counters (e.g., IXY = (IX-1)*MY + IY). The arrays are -! devided in three parts. For MAPX2, these ranges are : -! -! 1 - NMX0 Counters IXY for which grid point (IX,IY) and -! (IX+1,IY) both are active grid points. -! NMX0+1 - NMX1 Id. only (IX,IY) active. -! NMX1+1 - NMX2 Id. only (IX+1,IY) active. -! -! The array MAPY2 has a similar layout varying IY instead of IX. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! ------------------------------------------------------ -! 1. Map MAPX2 -! a Range 1 to NMX0 -! b Range NMX0+1 to NMX1 -! c Range NMX1+1 to NMX2 -! 2. Map MAPY2 -! a Range 1 to NMY0 -! b Range NMY0+1 to NMY1 -! c Range NMY1+1 to NMY2 -! 3. Map MAPAXY -! 4. Map MAPCXY -! 5. Maps for intra-spectral propagation -! a MAPTH2, MAPATK -! b MAPWN2 -! ------------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NK, NTH, NSPEC, NX, NY, NSEA, MAPSTA, MAPSF,& - GTYPE - USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & - NCENT, MAPX2, MAPY2, MAPAXY, MAPCXY, & - MAPTH2, MAPWN2 - USE W3ODATMD, ONLY: NDST +MODULE W3PRO3MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2014 | + !/ +-----------------------------------+ + !/ + !/ 27-Feb-2000 : Origination. ( version 2.08 ) + !/ 17-Sep-2000 : Clean-up. ( version 2.13 ) + !/ 10-Dec-2001 : Sub-grid obstructions. ( version 2.14 ) + !/ 16-Oct-2002 : Change INTENT for ATRN in W3XYP3. ( version 3.00 ) + !/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) + !/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) + !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 07-Sep-2005 : Upgrade XY boundary conditions. ( version 3.08 ) + !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives. + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 01-Apr-2008 : Bug fix W3MAP3 MAPSTA range check. ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 17-Aug-2010 : Add test output W3XYP3. ( version 3.14.5 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 26-Dec-2012 : More initializations. ( version 4.11 ) + !/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third + !/ and second order schemes. ( version 4.12 ) + !/ 12-Sep-2013 : Add documentation for global clos. ( version 4.12 ) + !/ 27-May-2014 : Adding OMPH switch. ( version 5.02 ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Bundles routines for third order propagation scheme in single + ! module. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! TRNMIN R.P. Private Minimum transparancy for local + ! switching off of averaging. + ! ---------------------------------------------------------------- + ! + ! Also work arrays for W3KTP3 (private). + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3MAP3 Subr. Public Set up auxiliary maps. + ! W3MAPT Subr. Public Set up transparency map for GSE. + ! W3XYP3 Subr. Public Third order spatial propagation. + ! W3KTP3 Subr. Public Third order spectral propagation. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! W3QCK1 Subr. W3UQCKMD Regular grid UQ scheme. + ! W3QCK2 Subr. Id. Irregular grid UQ scheme. + ! W3QCK3 Subr. Id. Regular grid UQ scheme + obstructions. + ! W3UNO2 Subr. W3UNO2MD UNO2 scheme for irregular grid. + ! W3UNO2r Subr. Id. UNO2 scheme reduced to regular grid. + ! W3UNO2s Subr. Id. UNO2 regular grid with subgrid + ! obstruction. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - The averaging is not performed around semi-transparent grid + ! points to avoid that leaking through barriers occurs. + ! + ! 6. Switches : + ! + ! !/UQ 3rd order UQ propagation scheme. + ! !/UNO 2nd order UNO propagation scheme. + ! + ! !/MGP Moving grid corrections. + ! !/MGG Moving grid corrections. + ! + ! !/OMPH Hybrid OpenMP directives. + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ Public variables + !/ + PUBLIC + !/ + !/ Private data + !/ + REAL, PRIVATE, PARAMETER:: TRNMIN = 0.95 + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3MAP3 + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Apr-2008 | + !/ +-----------------------------------+ + !/ + !/ 27-Feb-2000 : Origination. ( version 2.08 ) + !/ 10-Dec-2001 : Sub-grid obstructions. ( version 2.14 ) + !/ (array allocation only.) + !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) + !/ 01-Apr-2008 : Bug fix sec. 4 MAPSTA range check. ( version 3.13 ) + !/ + ! 1. Purpose : + ! + ! Generate 'map' arrays for the ULTIMATE QUICKEST scheme. + ! + ! 2. Method : + ! + ! MAPX2, MAPY2, MAPTH2 and MAPWN2 contain consecutive 1-D spatial + ! grid counters (e.g., IXY = (IX-1)*MY + IY). The arrays are + ! devided in three parts. For MAPX2, these ranges are : + ! + ! 1 - NMX0 Counters IXY for which grid point (IX,IY) and + ! (IX+1,IY) both are active grid points. + ! NMX0+1 - NMX1 Id. only (IX,IY) active. + ! NMX1+1 - NMX2 Id. only (IX+1,IY) active. + ! + ! The array MAPY2 has a similar layout varying IY instead of IX. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! ------------------------------------------------------ + ! 1. Map MAPX2 + ! a Range 1 to NMX0 + ! b Range NMX0+1 to NMX1 + ! c Range NMX1+1 to NMX2 + ! 2. Map MAPY2 + ! a Range 1 to NMY0 + ! b Range NMY0+1 to NMY1 + ! c Range NMY1+1 to NMY2 + ! 3. Map MAPAXY + ! 4. Map MAPCXY + ! 5. Maps for intra-spectral propagation + ! a MAPTH2, MAPATK + ! b MAPWN2 + ! ------------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NK, NTH, NSPEC, NX, NY, NSEA, MAPSTA, MAPSF,& + GTYPE + USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & + NCENT, MAPX2, MAPY2, MAPAXY, MAPCXY, & + MAPTH2, MAPWN2 + USE W3ODATMD, ONLY: NDST #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IX, IY, IXY0, IX2, IY2, IX0, IY0, & - ISEA, IK, ITH, ISP, ISP0, ISP2, NCENTC + USE W3SERVMD, ONLY: STRACE +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IX, IY, IXY0, IX2, IY2, IX0, IY0, & + ISEA, IK, ITH, ISP, ISP0, ISP2, NCENTC #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T - INTEGER :: MAPTXY(NY,NX), I, IXY - INTEGER :: MAPTST(NK+2,NTH) + INTEGER :: MAPTXY(NY,NX), I, IXY + INTEGER :: MAPTST(NK+2,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3MAP3') + CALL STRACE (IENT, 'W3MAP3') #endif -! - IF (GTYPE .LT. 3) THEN -! 1. Map MAPX2 ------------------------------------------------------ * -! 1.a Range 1 to NMX0 -! + ! + IF (GTYPE .LT. 3) THEN + ! 1. Map MAPX2 ------------------------------------------------------ * + ! 1.a Range 1 to NMX0 + ! #ifdef W3_T MAPTXY = 0. #endif -! + ! NMX0 = 0 DO IX=1, NX IXY0 = (IX-1)*NY IX2 = 1 + MOD(IX,NX) DO IY=2, NY-1 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN - NMX0 = NMX0 + 1 - MAPX2(NMX0) = IXY0 + IY + NMX0 = NMX0 + 1 + MAPX2(NMX0) = IXY0 + IY #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 #endif - END IF - END DO + END IF END DO -! -! 1.b Range NMX0+1 to NMX1 -! + END DO + ! + ! 1.b Range NMX0+1 to NMX1 + ! NMX1 = NMX0 DO IX=1, NX IXY0 = (IX-1)*NY IX2 = 1 + MOD(IX,NX) DO IY=2, NY-1 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).NE.1 ) THEN - NMX1 = NMX1 + 1 - MAPX2(NMX1) = IXY0 + IY + NMX1 = NMX1 + 1 + MAPX2(NMX1) = IXY0 + IY #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 #endif - END IF - END DO + END IF END DO -! -! 1.c Range NMX1+1 to NMX2 -! + END DO + ! + ! 1.c Range NMX1+1 to NMX2 + ! NMX2 = NMX1 DO IX=1, NX IXY0 = (IX-1)*NY IX2 = 1 + MOD(IX,NX) DO IY=2, NY-1 IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN - NMX2 = NMX2 + 1 - MAPX2(NMX2) = IXY0 + IY + NMX2 = NMX2 + 1 + MAPX2(NMX2) = IXY0 + IY #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 #endif - END IF - END DO + END IF END DO -! + END DO + ! #ifdef W3_T WRITE (NDST,9000) 'MAPX2', NMX0, NMX1-NMX0, & - NMX2-NMX1, NMX2 + NMX2-NMX1, NMX2 DO IY=NY, 1, -1 WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) - END DO + END DO #endif -! -! 2. Map MAPY2 ------------------------------------------------------ * -! 2.a Range 1 to NMY0 -! + ! + ! 2. Map MAPY2 ------------------------------------------------------ * + ! 2.a Range 1 to NMY0 + ! #ifdef W3_T MAPTXY = 0. #endif -! + ! NMY0 = 0 DO IX=1, NX IXY0 = (IX-1)*NY DO IY=1, NY-1 IY2 = IY + 1 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN - NMY0 = NMY0 + 1 - MAPY2(NMY0) = IXY0 + IY + NMY0 = NMY0 + 1 + MAPY2(NMY0) = IXY0 + IY #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 #endif - END IF - END DO + END IF END DO -! -! 2.b Range NMY0+1 to NMY1 -! + END DO + ! + ! 2.b Range NMY0+1 to NMY1 + ! NMY1 = NMY0 DO IX=1, NX IXY0 = (IX-1)*NY DO IY=1, NY-1 IY2 = IY + 1 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).NE.1 ) THEN - NMY1 = NMY1 + 1 - MAPY2(NMY1) = IXY0 + IY + NMY1 = NMY1 + 1 + MAPY2(NMY1) = IXY0 + IY #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 #endif - END IF - END DO + END IF END DO -! -! 2.c Range NMY1+1 to NMY2 -! + END DO + ! + ! 2.c Range NMY1+1 to NMY2 + ! NMY2 = NMY1 DO IX=1, NX IXY0 = (IX-1)*NY DO IY=1, NY-1 IY2 = IY + 1 IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN - NMY2 = NMY2 + 1 - MAPY2(NMY2) = IXY0 + IY + NMY2 = NMY2 + 1 + MAPY2(NMY2) = IXY0 + IY #ifdef W3_T - MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 #endif - END IF - END DO - END DO -! + END IF + END DO + END DO + ! #ifdef W3_T WRITE (NDST,9000) 'MAPY2', NMY0, NMY1-NMY0, & - NMY2-NMY1, NMY2 + NMY2-NMY1, NMY2 DO IY=NY, 1, -1 WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) - END DO + END DO #endif -! -! 3. Map MAPAXY ----------------------------------------------------- * -! + ! + ! 3. Map MAPAXY ----------------------------------------------------- * + ! NACT = 0 DO IX=1, NX IY0 = (IX-1)*NY DO IY=2, NY-1 IF ( MAPSTA(IY,IX).EQ.1 ) THEN - NACT = NACT + 1 - MAPAXY(NACT) = IY0 + IY - END IF - END DO + NACT = NACT + 1 + MAPAXY(NACT) = IY0 + IY + END IF END DO -! -! 4. Map MAPCXY ----------------------------------------------------- * -! + END DO + ! + ! 4. Map MAPCXY ----------------------------------------------------- * + ! NCENT = 0 NCENTC = NSEA MAPCXY = 0 -! + ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) IX0 = IX-1 @@ -381,1677 +381,1658 @@ SUBROUTINE W3MAP3 IF ( IX .EQ. NX ) IX2 = 1 IF ( IX .EQ. 1 ) IX0 = NX IF ( MAPSTA(IY,IX).EQ.2 .OR. MAPSTA(IY,IX).LT.0 ) THEN - MAPCXY(NCENTC) = ISEA - NCENTC = NCENTC - 1 - ELSE IF ( MAPSTA(IY0,IX0).GE.1 .AND. & - MAPSTA(IY0,IX ).GE.1 .AND. & - MAPSTA(IY0,IX2).GE.1 .AND. & - MAPSTA(IY ,IX0).GE.1 .AND. & - MAPSTA(IY ,IX2).GE.1 .AND. & - MAPSTA(IY2,IX0).GE.1 .AND. & - MAPSTA(IY2,IX ).GE.1 .AND. & - MAPSTA(IY2,IX2).GE.1 ) THEN - NCENT = NCENT + 1 - MAPCXY(NCENT) = ISEA - ELSE - MAPCXY(NCENTC) = ISEA - NCENTC = NCENTC - 1 - END IF - END DO - END IF -! -! 5. Maps for intra-spectral propagation ---------------------------- * -! - IF ( MAPTH2(1) .NE. 0 ) RETURN -! -#ifdef W3_T - MAPTST = 0 -#endif -! -! 5.a MAPTH2 and MAPBTK -! - DO IK=1, NK - DO ITH=1, NTH - ISP = ITH + (IK-1)*NTH - ISP2 = (IK+1) + (ITH-1)*(NK+2) - MAPTH2(ISP) = ISP2 -#ifdef W3_T - MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 -#endif - END DO - END DO -! + MAPCXY(NCENTC) = ISEA + NCENTC = NCENTC - 1 + ELSE IF ( MAPSTA(IY0,IX0).GE.1 .AND. & + MAPSTA(IY0,IX ).GE.1 .AND. & + MAPSTA(IY0,IX2).GE.1 .AND. & + MAPSTA(IY ,IX0).GE.1 .AND. & + MAPSTA(IY ,IX2).GE.1 .AND. & + MAPSTA(IY2,IX0).GE.1 .AND. & + MAPSTA(IY2,IX ).GE.1 .AND. & + MAPSTA(IY2,IX2).GE.1 ) THEN + NCENT = NCENT + 1 + MAPCXY(NCENT) = ISEA + ELSE + MAPCXY(NCENTC) = ISEA + NCENTC = NCENTC - 1 + END IF + END DO + END IF + ! + ! 5. Maps for intra-spectral propagation ---------------------------- * + ! + IF ( MAPTH2(1) .NE. 0 ) RETURN + ! #ifdef W3_T - WRITE (NDST,9000) 'MAPTH2', ISP, 0, 0, ISP - DO IK=NK+2, 1, -1 - WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) - END DO + MAPTST = 0 #endif -! + ! + ! 5.a MAPTH2 and MAPBTK + ! + DO IK=1, NK + DO ITH=1, NTH + ISP = ITH + (IK-1)*NTH + ISP2 = (IK+1) + (ITH-1)*(NK+2) + MAPTH2(ISP) = ISP2 #ifdef W3_T - MAPTST = 0 + MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 #endif -! -! 5.b MAPWN2 -! - ISP0 = 0 - DO IK=1, NK-1 - DO ITH=1, NTH - ISP0 = ISP0 + 1 - ISP2 = (IK+1) + (ITH-1)*(NK+2) - MAPWN2(ISP0) = ISP2 + END DO + END DO + ! #ifdef W3_T - MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 -#endif - END DO - END DO -! + WRITE (NDST,9000) 'MAPTH2', ISP, 0, 0, ISP + DO IK=NK+2, 1, -1 + WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) + END DO + MAPTST = 0 +#endif + ! + ! 5.b MAPWN2 + ! + ISP0 = 0 + DO IK=1, NK-1 DO ITH=1, NTH ISP0 = ISP0 + 1 - ISP2 = NK+1 + (ITH-1)*(NK+2) + ISP2 = (IK+1) + (ITH-1)*(NK+2) MAPWN2(ISP0) = ISP2 #ifdef W3_T - MAPTST(NK+1,ITH) = MAPTST(NK+1,ITH) + 2 + MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 #endif - END DO -! - DO ITH=1, NTH - ISP0 = ISP0 + 1 - ISP2 = 1 + (ITH-1)*(NK+2) - MAPWN2(ISP0) = ISP2 + END DO + END DO + ! + DO ITH=1, NTH + ISP0 = ISP0 + 1 + ISP2 = NK+1 + (ITH-1)*(NK+2) + MAPWN2(ISP0) = ISP2 #ifdef W3_T - MAPTST(1,ITH) = MAPTST(1,ITH) + 4 -#endif - END DO -! + MAPTST(NK+1,ITH) = MAPTST(NK+1,ITH) + 2 +#endif + END DO + ! + DO ITH=1, NTH + ISP0 = ISP0 + 1 + ISP2 = 1 + (ITH-1)*(NK+2) + MAPWN2(ISP0) = ISP2 #ifdef W3_T - WRITE (NDST,9000) 'MAPWN2', NSPEC-NTH, NTH, NTH, NSPEC+NTH - DO IK=NK+2, 1, -1 - WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) - END DO + MAPTST(1,ITH) = MAPTST(1,ITH) + 4 #endif -! - RETURN -! -! Formats -! + END DO + ! #ifdef W3_T - 9000 FORMAT (/' TEST W3MAP3 : TEST MAP FOR PROPAGATION'/ & - ' MAP : ',A/ & - ' CENTRAL : ',I6/ & - ' ABOVE : ',I6/ & - ' BELOW : ',I6/ & - ' TOTAL : ',I6/) - 9001 FORMAT (1X,130I1) -#endif -! + WRITE (NDST,9000) 'MAPWN2', NSPEC-NTH, NTH, NTH, NSPEC+NTH + DO IK=NK+2, 1, -1 + WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9010 FORMAT (' TEST W3MAP3 : COMPOSITE MAPS TH2, WN2 AND BTK') - 9011 FORMAT (2X,60I2) -#endif -!/ -!/ End of W3MAP3 ----------------------------------------------------- / -!/ - END SUBROUTINE W3MAP3 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3MAPT -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 17-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 10-Dec-2001 : Origination. ( version 2.14 ) -!/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Generate 'map' arrays for the ULTIMATE QUICKEST scheme to combine -! GSE alleviation with obstructions. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF - USE W3ADATMD, ONLY: ATRNX, ATRNY, MAPTRN +9000 FORMAT (/' TEST W3MAP3 : TEST MAP FOR PROPAGATION'/ & + ' MAP : ',A/ & + ' CENTRAL : ',I6/ & + ' ABOVE : ',I6/ & + ' BELOW : ',I6/ & + ' TOTAL : ',I6/) +9001 FORMAT (1X,130I1) +9010 FORMAT (' TEST W3MAP3 : COMPOSITE MAPS TH2, WN2 AND BTK') +9011 FORMAT (2X,60I2) +#endif + !/ + !/ End of W3MAP3 ----------------------------------------------------- / + !/ + END SUBROUTINE W3MAP3 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3MAPT + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 17-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 10-Dec-2001 : Origination. ( version 2.14 ) + !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Generate 'map' arrays for the ULTIMATE QUICKEST scheme to combine + ! GSE alleviation with obstructions. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF + USE W3ADATMD, ONLY: ATRNX, ATRNY, MAPTRN #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISEA, IXY + USE W3SERVMD, ONLY: STRACE +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISEA, IXY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3MAPT') + CALL STRACE (IENT, 'W3MAPT') #endif -! -! 1. Map MAPTRN ----------------------------------------------------- * -! - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) + ! + ! 1. Map MAPTRN ----------------------------------------------------- * + ! + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) -!notes: Oct 22 2012: I changed this because it *looks* like a bug. -! I have not confirmed that it is a bug. -! Old code is given (2 lines). Only the first line is -! changed. + !notes: Oct 22 2012: I changed this because it *looks* like a bug. + ! I have not confirmed that it is a bug. + ! Old code is given (2 lines). Only the first line is + ! changed. -!old MAPTRN(IXY) = MIN( ATRNX(IXY,1) ,ATRNY(IXY,-1) , & -!old ATRNY(IXY,1), ATRNY(IXY,-1) ) .LT. TRNMIN + !old MAPTRN(IXY) = MIN( ATRNX(IXY,1) ,ATRNY(IXY,-1) , & + !old ATRNY(IXY,1), ATRNY(IXY,-1) ) .LT. TRNMIN - MAPTRN(IXY) = MIN( ATRNX(IXY,1) ,ATRNX(IXY,-1) , & - ATRNY(IXY,1), ATRNY(IXY,-1) ) .LT. TRNMIN - END DO -! - RETURN -! -! Formats -!/ -!/ End of W3MAPT ----------------------------------------------------- / -!/ - END SUBROUTINE W3MAPT -!/ ------------------------------------------------------------------- / - SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2014 | -!/ +-----------------------------------+ -!/ -!/ 27-Feb-2000 : Origination. ( version 2.08 ) -!/ 17-Sep-2000 : Clean-up. ( version 2.13 ) -!/ 10-Dec-2001 : Sub-grid obstructions. ( version 2.14 ) -!/ 16-Oct-2002 : Change INTENT for ATRNRX/Y. ( version 3.00 ) -!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) -!/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) -!/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Upgrade XY boundary conditions. ( version 3.08 ) -!/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives. -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 17-Aug-2010 : Add test output. ( version 3.14.5 ) -!/ 30-Oct-2010 : Implement unstructured grid ( version 3.14 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third -!/ and second order schemes. ( version 4.12 ) -!/ 12-Sep-2013 : Add documentation for global clos. ( version 4.12 ) -!/ 27-May-2014 : Adding OMPH switch. ( version 5.02 ) -!/ -! 1. Purpose : -! -! Propagation in phyiscal space for a given spectral component. -! -! 2. Method : -! -! Third-order ULTIMATE QUICKEST scheme with averaging. -! Curvilinear grid implementation: Fluxes are computed in index space -! and then transformed back into physical space. The diffusion term -! is handled in physical space. The averaging scheme is adapted for -! curvilinear grids by applying the appropriate local rotations and -! adjustments to interpolation weights which control the strength of -! the averaging in axial directions. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH -! DTG Real I Total time step. -! MAPSTA I.A. I Grid point status map. -! MAPFS I.A. I Storage map. -! VQ R.A. I/O Field to propagate. -! VGX/Y Real I Speed of grid. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! NTLOC Int Number of local time steps. -! DTLOC Real Local propagation time step. -! VCFL0X R.A. Local courant numbers for absolute group vel. -! using local X-grid step. -! VCFL0Y R.A. Id. in Y. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! W3QCK3 Actual propagation algorithm -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3WAVE Wave model routine. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Note that the ULTIMATE limiter does not guarantee non-zero -! energies. -! - The present scheme shows a strong distorsion when propaga- -! ting a field under an angle with the grid in a truly 2-D -! fashion. Propagation is therefore split along the two -! axes. -! - Two boundary treatments are available. The first uses real -! boundaries in each space. In this case waves will not -! penetrate in narrow straights under an angle with the grid. -! This behavior is improved by using a 'soft' option, in -! which the 'X' or 'Y' sweep allows for energy to go onto -! the land. This improves the above behavior, but implies -! that X-Y connenctions are required in barriers for them -! to become inpenetrable. -! - Note that unlike in W3XYP2, isotropic diffusion is never -! used for growth. -! - Curvilinear grid implementation. Variables FACX, FACY, CCOS, CSIN, -! CCURX, CCURY are not needed and have been removed. FACX is accounted -! for as approriate in this subroutine. FACX is also accounted for in -! the case of .NOT.FLCX. Since FACX is removed, there is now a check for -! .NOT.FLCX in this subroutine. In CFL calcs dx and dy are omitted, -! since dx=dy=1 in index space. Curvilinear grid derivatives -! (DPDY, DQDX, etc.) and metric (GSQRT) are brought in via W3GDATMD. -! - The strength of the averaging scheme is dependent on grid resolution. -! Since grid resolution is non-uniform for curvilinear grids, this means -! that the strength of the averaging is also non-uniform. This may not be -! a desirable effect. A potential future upgrade would be to add an -! additional term/factor that balances the effect of the spatial -! variation of grid resolution. -! -! 8. Structure : -! -! --------------------------------------------- -! 1. Preparations -! a Set constants -! b Initialize arrays -! 2. Prepare arrays -! a Velocities and 'Q' -! 3. Loop over sub-steps -! ---------------------------------------- -! a Average -! b Propagate -! c Update boundaries. -! ---------------------------------------- -! 4. Store Q field in spectra -! --------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! !/OMPH Hybrid OpenMP directives. -! -! !/MGP Moving grid corrections. -! !/MGG Moving grid corrections. -! -! !/T Enable general test output. -! !/T0 Dump of precalcaulted interpolation data. -! !/T1 Dump of input field and fluxes. -! !/T2 Dump of output field (before boundary update). -! !/T3 Dump of output field (final). -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -! - USE W3TIMEMD, ONLY: DSEC21 -! - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, DTCFL, CLATS, & - ICLOSE, FLCX, FLCY, NK, NTH, DTH, XFR, & - ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & - ECOS, ESIN, SIG, WDCG, WDTH, PFMOVE, & - FLAGLL, DPDX, DPDY, DQDX, DQDY, GSQRT - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & - NCENT, MAPX2, MAPY2, MAPAXY, MAPCXY, & - MAPTRN, CG, CX, CY, ATRNX, ATRNY, ITIME - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & - ISBPI, BBPI0, BBPIN, IAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE + MAPTRN(IXY) = MIN( ATRNX(IXY,1) ,ATRNX(IXY,-1) , & + ATRNY(IXY,1), ATRNY(IXY,-1) ) .LT. TRNMIN + END DO + ! + RETURN + ! + ! Formats + !/ + !/ End of W3MAPT ----------------------------------------------------- / + !/ + END SUBROUTINE W3MAPT + !/ ------------------------------------------------------------------- / + SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2014 | + !/ +-----------------------------------+ + !/ + !/ 27-Feb-2000 : Origination. ( version 2.08 ) + !/ 17-Sep-2000 : Clean-up. ( version 2.13 ) + !/ 10-Dec-2001 : Sub-grid obstructions. ( version 2.14 ) + !/ 16-Oct-2002 : Change INTENT for ATRNRX/Y. ( version 3.00 ) + !/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) + !/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) + !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 07-Sep-2005 : Upgrade XY boundary conditions. ( version 3.08 ) + !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives. + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 17-Aug-2010 : Add test output. ( version 3.14.5 ) + !/ 30-Oct-2010 : Implement unstructured grid ( version 3.14 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third + !/ and second order schemes. ( version 4.12 ) + !/ 12-Sep-2013 : Add documentation for global clos. ( version 4.12 ) + !/ 27-May-2014 : Adding OMPH switch. ( version 5.02 ) + !/ + ! 1. Purpose : + ! + ! Propagation in phyiscal space for a given spectral component. + ! + ! 2. Method : + ! + ! Third-order ULTIMATE QUICKEST scheme with averaging. + ! Curvilinear grid implementation: Fluxes are computed in index space + ! and then transformed back into physical space. The diffusion term + ! is handled in physical space. The averaging scheme is adapted for + ! curvilinear grids by applying the appropriate local rotations and + ! adjustments to interpolation weights which control the strength of + ! the averaging in axial directions. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH + ! DTG Real I Total time step. + ! MAPSTA I.A. I Grid point status map. + ! MAPFS I.A. I Storage map. + ! VQ R.A. I/O Field to propagate. + ! VGX/Y Real I Speed of grid. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! NTLOC Int Number of local time steps. + ! DTLOC Real Local propagation time step. + ! VCFL0X R.A. Local courant numbers for absolute group vel. + ! using local X-grid step. + ! VCFL0Y R.A. Id. in Y. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! W3QCK3 Actual propagation algorithm + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3WAVE Wave model routine. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Note that the ULTIMATE limiter does not guarantee non-zero + ! energies. + ! - The present scheme shows a strong distorsion when propaga- + ! ting a field under an angle with the grid in a truly 2-D + ! fashion. Propagation is therefore split along the two + ! axes. + ! - Two boundary treatments are available. The first uses real + ! boundaries in each space. In this case waves will not + ! penetrate in narrow straights under an angle with the grid. + ! This behavior is improved by using a 'soft' option, in + ! which the 'X' or 'Y' sweep allows for energy to go onto + ! the land. This improves the above behavior, but implies + ! that X-Y connenctions are required in barriers for them + ! to become inpenetrable. + ! - Note that unlike in W3XYP2, isotropic diffusion is never + ! used for growth. + ! - Curvilinear grid implementation. Variables FACX, FACY, CCOS, CSIN, + ! CCURX, CCURY are not needed and have been removed. FACX is accounted + ! for as approriate in this subroutine. FACX is also accounted for in + ! the case of .NOT.FLCX. Since FACX is removed, there is now a check for + ! .NOT.FLCX in this subroutine. In CFL calcs dx and dy are omitted, + ! since dx=dy=1 in index space. Curvilinear grid derivatives + ! (DPDY, DQDX, etc.) and metric (GSQRT) are brought in via W3GDATMD. + ! - The strength of the averaging scheme is dependent on grid resolution. + ! Since grid resolution is non-uniform for curvilinear grids, this means + ! that the strength of the averaging is also non-uniform. This may not be + ! a desirable effect. A potential future upgrade would be to add an + ! additional term/factor that balances the effect of the spatial + ! variation of grid resolution. + ! + ! 8. Structure : + ! + ! --------------------------------------------- + ! 1. Preparations + ! a Set constants + ! b Initialize arrays + ! 2. Prepare arrays + ! a Velocities and 'Q' + ! 3. Loop over sub-steps + ! ---------------------------------------- + ! a Average + ! b Propagate + ! c Update boundaries. + ! ---------------------------------------- + ! 4. Store Q field in spectra + ! --------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! !/OMPH Hybrid OpenMP directives. + ! + ! !/MGP Moving grid corrections. + ! !/MGG Moving grid corrections. + ! + ! !/T Enable general test output. + ! !/T0 Dump of precalcaulted interpolation data. + ! !/T1 Dump of input field and fluxes. + ! !/T2 Dump of output field (before boundary update). + ! !/T3 Dump of output field (final). + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + ! + USE W3TIMEMD, ONLY: DSEC21 + ! + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, DTCFL, CLATS, & + ICLOSE, FLCX, FLCY, NK, NTH, DTH, XFR, & + ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & + ECOS, ESIN, SIG, WDCG, WDTH, PFMOVE, & + FLAGLL, DPDX, DPDY, DQDX, DQDY, GSQRT + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & + NCENT, MAPX2, MAPY2, MAPAXY, MAPCXY, & + MAPTRN, CG, CX, CY, ATRNX, ATRNY, ITIME + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & + ISBPI, BBPI0, BBPIN, IAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_UQ - USE W3UQCKMD + USE W3UQCKMD #endif #ifdef W3_UNO - USE W3UNO2MD -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISP, MAPSTA(NY*NX), MAPFS(NY*NX) - REAL, INTENT(IN) :: DTG, VGX, VGY - REAL, INTENT(INOUT) :: VQ(1-NY:NY*(NX+2)) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK, NTLOC, ITLOC, ISEA, IXY, IP - INTEGER :: IX, IY, IXC, IYC, IBI - INTEGER :: IIXY1(NSEA), IIXY2(NSEA), & - IIXY3(NSEA), IIXY4(NSEA) - INTEGER :: TTEST(2),DTTST + USE W3UNO2MD +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISP, MAPSTA(NY*NX), MAPFS(NY*NX) + REAL, INTENT(IN) :: DTG, VGX, VGY + REAL, INTENT(INOUT) :: VQ(1-NY:NY*(NX+2)) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK, NTLOC, ITLOC, ISEA, IXY, IP + INTEGER :: IX, IY, IXC, IYC, IBI + INTEGER :: IIXY1(NSEA), IIXY2(NSEA), & + IIXY3(NSEA), IIXY4(NSEA) + INTEGER :: TTEST(2),DTTST #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & - CXMIN, CXMAX, CYMIN, CYMAX - REAL :: CGC, FGSE = 1. - REAL :: FTH, FTHX, FTHY, FCG, FCGX, FCGY - REAL :: DTLOC, DTRAD, & - DXCGN, DYCGN, DXCGS, DYCGS, DXCGC, & - DYCGC - REAL :: RDI1(NSEA), RDI2(NSEA), & - RDI3(NSEA), RDI4(NSEA) - REAL :: TMPX, TMPY, RD1, RD2, RD3, RD4 - LOGICAL :: YFIRST - LOGICAL :: GLOBAL - REAL :: CP, CQ -!/ -!/ Automatic work arrays -!/ - INTEGER :: MAPSTX(1-2*NY:NY*(NX+2)) - REAL :: VLCFLX((NX+1)*NY), VLCFLY((NX+1)*NY),& - AQ(1-NY:NY*(NX+2)) - REAL :: CXTOT((NX+1)*NY), CYTOT(NX*NY) -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & + CXMIN, CXMAX, CYMIN, CYMAX + REAL :: CGC, FGSE = 1. + REAL :: FTH, FTHX, FTHY, FCG, FCGX, FCGY + REAL :: DTLOC, DTRAD, & + DXCGN, DYCGN, DXCGS, DYCGS, DXCGC, & + DYCGC + REAL :: RDI1(NSEA), RDI2(NSEA), & + RDI3(NSEA), RDI4(NSEA) + REAL :: TMPX, TMPY, RD1, RD2, RD3, RD4 + LOGICAL :: YFIRST + LOGICAL :: GLOBAL + REAL :: CP, CQ + !/ + !/ Automatic work arrays + !/ + INTEGER :: MAPSTX(1-2*NY:NY*(NX+2)) + REAL :: VLCFLX((NX+1)*NY), VLCFLY((NX+1)*NY),& + AQ(1-NY:NY*(NX+2)) + REAL :: CXTOT((NX+1)*NY), CYTOT(NX*NY) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3XYP3') + CALL STRACE (IENT, 'W3XYP3') #endif -! -! 1. Preparations --------------------------------------------------- * + ! + ! 1. Preparations --------------------------------------------------- * - IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN -!/ ------------------------------------------------------------------- / - IF (IAPROC .EQ. NAPERR) & - WRITE(NDSE,*)'SUBROUTINE W3XYP3 IS NOT YET ADAPTED FOR '// & - 'TRIPOLE GRIDS. STOPPING NOW.' - CALL EXTCDE ( 1 ) - END IF + IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN + !/ ------------------------------------------------------------------- / + IF (IAPROC .EQ. NAPERR) & + WRITE(NDSE,*)'SUBROUTINE W3XYP3 IS NOT YET ADAPTED FOR '// & + 'TRIPOLE GRIDS. STOPPING NOW.' + CALL EXTCDE ( 1 ) + END IF -! 1.a Set constants -! - GLOBAL = ICLOSE.NE.ICLOSE_NONE - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH -! - CG0 = 0.575 * GRAV / SIG(1) - CGA = 0.575 * GRAV / SIG(IK) - CGX = CGA * ECOS(ITH) - CGY = CGA * ESIN(ITH) + ! 1.a Set constants + ! + GLOBAL = ICLOSE.NE.ICLOSE_NONE + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + ! + CG0 = 0.575 * GRAV / SIG(1) + CGA = 0.575 * GRAV / SIG(IK) + CGX = CGA * ECOS(ITH) + CGY = CGA * ESIN(ITH) #ifdef W3_MGP - CGX = CGX - VGX - CGY = CGY - VGY + CGX = CGX - VGX + CGY = CGY - VGY #endif - CGC = SQRT ( CGX**2 + CGY**2 ) + CGC = SQRT ( CGX**2 + CGY**2 ) #ifdef W3_MGG - FGSE = ( CGA / MAX(0.001*CGA,CGC) )**PFMOVE -#endif -! - IF ( FLCUR ) THEN - CXMIN = MINVAL ( CX(1:NSEA) ) - CXMAX = MAXVAL ( CX(1:NSEA) ) - CYMIN = MINVAL ( CY(1:NSEA) ) - CYMAX = MAXVAL ( CY(1:NSEA) ) - IF ( ABS(CGX+CXMIN) .GT. ABS(CGX+CXMAX) ) THEN - CGX = CGX + CXMIN - ELSE - CGX = CGX + CXMAX - END IF - IF ( ABS(CGY+CYMIN) .GT. ABS(CGY+CYMAX) ) THEN - CGY = CGY + CYMIN - ELSE - CGY = CGY + CYMAX - END IF - CXC = MAX ( ABS(CXMIN) , ABS(CXMAX) ) - CYC = MAX ( ABS(CYMIN) , ABS(CYMAX) ) + FGSE = ( CGA / MAX(0.001*CGA,CGC) )**PFMOVE +#endif + ! + IF ( FLCUR ) THEN + CXMIN = MINVAL ( CX(1:NSEA) ) + CXMAX = MAXVAL ( CX(1:NSEA) ) + CYMIN = MINVAL ( CY(1:NSEA) ) + CYMAX = MAXVAL ( CY(1:NSEA) ) + IF ( ABS(CGX+CXMIN) .GT. ABS(CGX+CXMAX) ) THEN + CGX = CGX + CXMIN + ELSE + CGX = CGX + CXMAX + END IF + IF ( ABS(CGY+CYMIN) .GT. ABS(CGY+CYMAX) ) THEN + CGY = CGY + CYMIN + ELSE + CGY = CGY + CYMAX + END IF + CXC = MAX ( ABS(CXMIN) , ABS(CXMAX) ) + CYC = MAX ( ABS(CYMIN) , ABS(CYMAX) ) #ifdef W3_MGP - CXC = MAX ( ABS(CXMIN-VGX) , ABS(CXMAX-VGX) ) - CYC = MAX ( ABS(CYMIN-VGY) , ABS(CYMAX-VGY) ) -#endif - ELSE - CXC = 0. - CYC = 0. - END IF -! - CGN = MAX ( ABS(CGX) , ABS(CGY) , CXC, CYC, 0.001*CG0 ) -! - NTLOC = 1 + INT(DTG/(DTCFL*CG0/CGN)) - DTLOC = DTG / REAL(NTLOC) - DTRAD = DTLOC - IF ( FLAGLL ) DTRAD=DTRAD/(DERA*RADIUS) -! - TTEST(1) = TIME(1) - TTEST(2) = 0 - DTTST = DSEC21(TTEST,TIME) - YFIRST = MOD(NINT(DTTST/DTG),2) .EQ. 0 -! + CXC = MAX ( ABS(CXMIN-VGX) , ABS(CXMAX-VGX) ) + CYC = MAX ( ABS(CYMIN-VGY) , ABS(CYMAX-VGY) ) +#endif + ELSE + CXC = 0. + CYC = 0. + END IF + ! + CGN = MAX ( ABS(CGX) , ABS(CGY) , CXC, CYC, 0.001*CG0 ) + ! + NTLOC = 1 + INT(DTG/(DTCFL*CG0/CGN)) + DTLOC = DTG / REAL(NTLOC) + DTRAD = DTLOC + IF ( FLAGLL ) DTRAD=DTRAD/(DERA*RADIUS) + ! + TTEST(1) = TIME(1) + TTEST(2) = 0 + DTTST = DSEC21(TTEST,TIME) + YFIRST = MOD(NINT(DTTST/DTG),2) .EQ. 0 + ! #ifdef W3_T - WRITE (NDST,9000) YFIRST - WRITE (NDST,9001) ISP, ITH, IK, ECOS(ITH), ESIN(ITH) + WRITE (NDST,9000) YFIRST + WRITE (NDST,9001) ISP, ITH, IK, ECOS(ITH), ESIN(ITH) #endif -! -! 1.b Initialize arrays -! + ! + ! 1.b Initialize arrays + ! #ifdef W3_T - WRITE (NDST,9010) -#endif -! - VLCFLX = 0. - VLCFLY = 0. - CXTOT = 0. - CYTOT = 0. -! - MAPSTX(1:NX*NY) = MAPSTA(1:NX*NY) -! - IF ( GLOBAL ) THEN - MAPSTX(1-2*NY:0) = MAPSTA((NX-2)*NY+1:NX*NY) - MAPSTX(NX*NY+1:NX*NY+2*NY) = MAPSTA(1:2*NY) - ELSE - MAPSTX(1-2*NY:0) = 0 - MAPSTX(NX*NY+1:NX*NY+2*NY) = 0 - END IF -! -! 1.c Pre-calculate interpolation info -! - FTH = FGSE * WDTH * DTH * DTLOC - FCG = FGSE * WDCG * 0.5 * (XFR-1./XFR) * DTLOC - IF ( FLAGLL ) THEN - FTH = FTH / RADIUS / DERA - FCG = FCG / RADIUS / DERA - END IF - FCG = FCG / REAL(NTLOC) !TJC: required to match original (is this correct?) - FTHX = - FTH * ESIN(ITH) - FTHY = FTH * ECOS(ITH) - FCGX = FCG * ECOS(ITH) - FCGY = FCG * ESIN(ITH) -! + WRITE (NDST,9010) +#endif + ! + VLCFLX = 0. + VLCFLY = 0. + CXTOT = 0. + CYTOT = 0. + ! + MAPSTX(1:NX*NY) = MAPSTA(1:NX*NY) + ! + IF ( GLOBAL ) THEN + MAPSTX(1-2*NY:0) = MAPSTA((NX-2)*NY+1:NX*NY) + MAPSTX(NX*NY+1:NX*NY+2*NY) = MAPSTA(1:2*NY) + ELSE + MAPSTX(1-2*NY:0) = 0 + MAPSTX(NX*NY+1:NX*NY+2*NY) = 0 + END IF + ! + ! 1.c Pre-calculate interpolation info + ! + FTH = FGSE * WDTH * DTH * DTLOC + FCG = FGSE * WDCG * 0.5 * (XFR-1./XFR) * DTLOC + IF ( FLAGLL ) THEN + FTH = FTH / RADIUS / DERA + FCG = FCG / RADIUS / DERA + END IF + FCG = FCG / REAL(NTLOC) !TJC: required to match original (is this correct?) + FTHX = - FTH * ESIN(ITH) + FTHY = FTH * ECOS(ITH) + FCGX = FCG * ECOS(ITH) + FCGY = FCG * ESIN(ITH) + ! #ifdef W3_T0 - WRITE (NDST,9011) + WRITE (NDST,9011) #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, TMPX, TMPY, & -!$OMP& DXCGN, DYCGN, DXCGS, DYCGS, DXCGC, DYCGC, & -!$OMP& IXC, IYC) + !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, TMPX, TMPY, & + !$OMP& DXCGN, DYCGN, DXCGS, DYCGS, DXCGC, DYCGC, & + !$OMP& IXC, IYC) #endif -! - DO ISEA=1, NSEA -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) -! -! 1.c.1 Normal and parallel width ... -! - TMPX = FTHX / CLATS(ISEA) - TMPY = FTHY - DXCGN = DPDX(IY,IX)*TMPX + DPDY(IY,IX)*TMPY - DYCGN = DQDX(IY,IX)*TMPX + DQDY(IY,IX)*TMPY - TMPX = FCGX / CLATS(ISEA) - TMPY = FCGY - DXCGS = DPDX(IY,IX)*TMPX + DPDY(IY,IX)*TMPY - DYCGS = DQDX(IY,IX)*TMPX + DQDY(IY,IX)*TMPY -! -! 1.c.2 "Sum" corner (and mirror image) ... -! - DXCGC = DXCGN + DXCGS - DYCGC = DYCGN + DYCGS -! - IXC = NY - IF ( DXCGC .LT. 0. ) IXC = - IXC - IYC = 1 - IF ( DYCGC .LT. 0. ) IYC = - IYC -! - IIXY1(ISEA) = IXC + IYC - IF ( ABS(DXCGC) .GT. ABS(DYCGC) ) THEN - IIXY2(ISEA) = IXC - RDI1 (ISEA) = ABS(DYCGC/DXCGC) - RDI2 (ISEA) = ABS(DXCGC) - ELSE - IIXY2(ISEA) = IYC - IF ( ABS(DYCGC) .GT. 1.E-5 ) THEN - RDI1(ISEA) = ABS(DXCGC/DYCGC) - ELSE - RDI1(ISEA) = 1. - END IF - RDI2(ISEA) = ABS(DYCGC) - END IF -! + ! + DO ISEA=1, NSEA + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + ! + ! 1.c.1 Normal and parallel width ... + ! + TMPX = FTHX / CLATS(ISEA) + TMPY = FTHY + DXCGN = DPDX(IY,IX)*TMPX + DPDY(IY,IX)*TMPY + DYCGN = DQDX(IY,IX)*TMPX + DQDY(IY,IX)*TMPY + TMPX = FCGX / CLATS(ISEA) + TMPY = FCGY + DXCGS = DPDX(IY,IX)*TMPX + DPDY(IY,IX)*TMPY + DYCGS = DQDX(IY,IX)*TMPX + DQDY(IY,IX)*TMPY + ! + ! 1.c.2 "Sum" corner (and mirror image) ... + ! + DXCGC = DXCGN + DXCGS + DYCGC = DYCGN + DYCGS + ! + IXC = NY + IF ( DXCGC .LT. 0. ) IXC = - IXC + IYC = 1 + IF ( DYCGC .LT. 0. ) IYC = - IYC + ! + IIXY1(ISEA) = IXC + IYC + IF ( ABS(DXCGC) .GT. ABS(DYCGC) ) THEN + IIXY2(ISEA) = IXC + RDI1 (ISEA) = ABS(DYCGC/DXCGC) + RDI2 (ISEA) = ABS(DXCGC) + ELSE + IIXY2(ISEA) = IYC + IF ( ABS(DYCGC) .GT. 1.E-5 ) THEN + RDI1(ISEA) = ABS(DXCGC/DYCGC) + ELSE + RDI1(ISEA) = 1. + END IF + RDI2(ISEA) = ABS(DYCGC) + END IF + ! #ifdef W3_T0 - WRITE (NDST,9012) ISEA, ITH, IIXY1(ISEA), IIXY2(ISEA), & - RDI1(ISEA), RDI2(ISEA)*CG(IK,1) -#endif -! -! 1.c.2 "Difference" corner (and mirror image) ... -! - DXCGC = DXCGN - DXCGS - DYCGC = DYCGN - DYCGS -! - IXC = NY - IF ( DXCGC .LT. 0. ) IXC = - IXC - IYC = 1 - IF ( DYCGC .LT. 0. ) IYC = - IYC -! - IIXY3(ISEA) = IXC + IYC - IF ( ABS(DXCGC) .GT. ABS(DYCGC) ) THEN - IIXY4(ISEA) = IXC - RDI3 (ISEA) = ABS(DYCGC/DXCGC) - RDI4 (ISEA) = ABS(DXCGC) - ELSE - IIXY4(ISEA) = IYC - IF ( ABS(DYCGC) .GT. 1.E-5 ) THEN - RDI3(ISEA) = ABS(DXCGC/DYCGC) - ELSE - RDI3(ISEA) = 1. - END IF - RDI4(ISEA) = ABS(DYCGC) - END IF -! + WRITE (NDST,9012) ISEA, ITH, IIXY1(ISEA), IIXY2(ISEA), & + RDI1(ISEA), RDI2(ISEA)*CG(IK,1) +#endif + ! + ! 1.c.2 "Difference" corner (and mirror image) ... + ! + DXCGC = DXCGN - DXCGS + DYCGC = DYCGN - DYCGS + ! + IXC = NY + IF ( DXCGC .LT. 0. ) IXC = - IXC + IYC = 1 + IF ( DYCGC .LT. 0. ) IYC = - IYC + ! + IIXY3(ISEA) = IXC + IYC + IF ( ABS(DXCGC) .GT. ABS(DYCGC) ) THEN + IIXY4(ISEA) = IXC + RDI3 (ISEA) = ABS(DYCGC/DXCGC) + RDI4 (ISEA) = ABS(DXCGC) + ELSE + IIXY4(ISEA) = IYC + IF ( ABS(DYCGC) .GT. 1.E-5 ) THEN + RDI3(ISEA) = ABS(DXCGC/DYCGC) + ELSE + RDI3(ISEA) = 1. + END IF + RDI4(ISEA) = ABS(DYCGC) + END IF + ! #ifdef W3_T0 - WRITE (NDST,9013) IIXY3(ISEA), IIXY4(ISEA), RDI3(ISEA), & - RDI4(ISEA)*CG(IK,1) + WRITE (NDST,9013) IIXY3(ISEA), IIXY4(ISEA), RDI3(ISEA), & + RDI4(ISEA)*CG(IK,1) #endif -! - END DO -! + ! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO -#endif -! -! 2. Calculate velocities and diffusion coefficients ---------------- * -! 2.a Velocities -! -! Q = ( A / CG * CLATS ) -! LCFLX = ( COS*CG / CLATS ) * DT / DX -! LCFLY = ( SIN*CG ) * DT / DY -! + !$OMP END PARALLEL DO +#endif + ! + ! 2. Calculate velocities and diffusion coefficients ---------------- * + ! 2.a Velocities + ! + ! Q = ( A / CG * CLATS ) + ! LCFLX = ( COS*CG / CLATS ) * DT / DX + ! LCFLY = ( SIN*CG ) * DT / DY + ! #ifdef W3_T - WRITE (NDST,9020) NSEA + WRITE (NDST,9020) NSEA #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IXY) -#endif -! - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - VQ (IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) - CXTOT(IXY) = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) - CYTOT(IXY) = ESIN(ITH) * CG(IK,ISEA) + !$OMP PARALLEL DO PRIVATE (ISEA, IXY) +#endif + ! + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + VQ (IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) + CXTOT(IXY) = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) + CYTOT(IXY) = ESIN(ITH) * CG(IK,ISEA) #ifdef W3_MGP - CXTOT(IXY) = CXTOT(IXY) - VGX/CLATS(ISEA) - CYTOT(IXY) = CYTOT(IXY) - VGY + CXTOT(IXY) = CXTOT(IXY) - VGX/CLATS(ISEA) + CYTOT(IXY) = CYTOT(IXY) - VGY #endif #ifdef W3_T1 - IF ( .NOT. FLCUR ) & - WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & - VQ(IXY), CXTOT(IXY), CYTOT(IXY) + IF ( .NOT. FLCUR ) & + WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & + VQ(IXY), CXTOT(IXY), CYTOT(IXY) #endif - END DO -! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - IF ( FLCUR ) THEN + ! + IF ( FLCUR ) THEN #ifdef W3_T - WRITE (NDST,9022) + WRITE (NDST,9022) #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA,IXY) + !$OMP PARALLEL DO PRIVATE (ISEA,IXY) #endif -! - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - CXTOT(IXY) = CXTOT(IXY) + CX(ISEA)/CLATS(ISEA) - CYTOT(IXY) = CYTOT(IXY) + CY(ISEA) + ! + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + CXTOT(IXY) = CXTOT(IXY) + CX(ISEA)/CLATS(ISEA) + CYTOT(IXY) = CYTOT(IXY) + CY(ISEA) #ifdef W3_T1 - WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & - VQ(IXY), CXTOT(IXY), CYTOT(IXY) + WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & + VQ(IXY), CXTOT(IXY), CYTOT(IXY) #endif - END DO -! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! + ! + END IF + ! +#ifdef W3_OMPH + !$OMP PARALLEL DO PRIVATE (ISEA,IX, IY, IXY, CP, CQ) +#endif + ! + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + CP = CXTOT(IXY)*DPDX(IY,IX) + CYTOT(IXY)*DPDY(IY,IX) + CQ = CXTOT(IXY)*DQDX(IY,IX) + CYTOT(IXY)*DQDY(IY,IX) + VLCFLX(IXY) = CP*DTRAD + VLCFLY(IXY) = CQ*DTRAD + END DO + ! +#ifdef W3_OMPH + !$OMP END PARALLEL DO +#endif + ! + ! 3. Loop over sub-steps -------------------------------------------- * + ! + DO ITLOC=1, NTLOC + ! + ! 3.a Average + ! + AQ = VQ + VQ = 0. + ! + ! 3.a.1 Central points + ! + DO IP=1, NCENT + ISEA = MAPCXY(IP) + IXY = MAPSF(ISEA,3) + IF ( MAPTRN(IXY) ) THEN + VQ(IXY) = AQ(IXY) + ELSE + RD1 = RDI1(ISEA) + RD2 = MIN ( 1. , RDI2(ISEA) * CG(IK,ISEA) ) + RD3 = RDI3(ISEA) + RD4 = MIN ( 1. , RDI4(ISEA) * CG(IK,ISEA) ) + VQ(IXY ) = VQ(IXY ) & + + AQ(IXY) * (3.-RD2-RD4)/3. + VQ(IXY+IIXY1(ISEA)) = VQ(IXY+IIXY1(ISEA)) & + + AQ(IXY) * RD2*RD1/6. + VQ(IXY+IIXY2(ISEA)) = VQ(IXY+IIXY2(ISEA)) & + + AQ(IXY) * (1.-RD1)*RD2/6. + VQ(IXY+IIXY3(ISEA)) = VQ(IXY+IIXY3(ISEA)) & + + AQ(IXY) * RD4*RD3/6. + VQ(IXY+IIXY4(ISEA)) = VQ(IXY+IIXY4(ISEA)) & + + AQ(IXY) * (1.-RD3)*RD4/6. + VQ(IXY-IIXY1(ISEA)) = VQ(IXY-IIXY1(ISEA)) & + + AQ(IXY) * RD2*RD1/6. + VQ(IXY-IIXY2(ISEA)) = VQ(IXY-IIXY2(ISEA)) & + + AQ(IXY) * (1.-RD1)*RD2/6. + VQ(IXY-IIXY3(ISEA)) = VQ(IXY-IIXY3(ISEA)) & + + AQ(IXY) * RD4*RD3/6. + VQ(IXY-IIXY4(ISEA)) = VQ(IXY-IIXY4(ISEA)) & + + AQ(IXY) * (1.-RD3)*RD4/6. END IF -! + END DO + ! + ! 3.a.2 Near-coast points + ! + DO IP=NCENT+1, NSEA + ISEA = MAPCXY(IP) + IX = MAPSF(ISEA,1) + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .LE. 0 ) CYCLE + IF ( MAPTRN(IXY) ) THEN + VQ(IXY) = AQ(IXY) + ELSE + RD1 = RDI1(ISEA) + RD3 = RDI3(ISEA) + RD2 = MIN ( 1. , RDI2(ISEA) * CG(IK,ISEA) ) + RD4 = MIN ( 1. , RDI4(ISEA) * CG(IK,ISEA) ) + VQ(IXY ) = VQ(IXY ) & + + AQ(IXY) * (3.-RD2-RD4)/3. + ! + IXC = SIGN(NY,IIXY1(ISEA)) + IYC = IIXY1(ISEA) - IXC + IF ( MAPSTX(IXY+IIXY1(ISEA)) .GE. 1 .AND. & + .NOT. ( MAPSTX(IXY+IXC).LE.0 .AND. & + MAPSTX(IXY+IYC).LE.0 ) ) THEN + VQ(IXY+IIXY1(ISEA)) = VQ(IXY+IIXY1(ISEA)) & + + AQ(IXY) * RD2*RD1/6. + ELSE + VQ(IXY ) = VQ(IXY ) & + + AQ(IXY) * RD2*RD1/6. + END IF + IF ( MAPSTX(IXY-IIXY1(ISEA)) .GE. 1 .AND. & + .NOT. ( MAPSTX(IXY-IXC).LE.0 .AND. & + MAPSTX(IXY-IYC).LE.0 ) ) THEN + VQ(IXY-IIXY1(ISEA)) = VQ(IXY-IIXY1(ISEA)) & + + AQ(IXY) * RD2*RD1/6. + ELSE + VQ(IXY ) = VQ(IXY ) & + + AQ(IXY) * RD2*RD1/6. + END IF + + IF ( MAPSTX(IXY+IIXY2(ISEA)) .GE. 1 ) THEN + VQ(IXY+IIXY2(ISEA)) = VQ(IXY+IIXY2(ISEA)) & + + AQ(IXY) * (1.-RD1)*RD2/6. + ELSE + VQ(IXY ) = VQ(IXY ) & + + AQ(IXY) * (1.-RD1)*RD2/6. + END IF + IF ( MAPSTX(IXY-IIXY2(ISEA)) .GE. 1 ) THEN + VQ(IXY-IIXY2(ISEA)) = VQ(IXY-IIXY2(ISEA)) & + + AQ(IXY) * (1.-RD1)*RD2/6. + ELSE + VQ(IXY ) = VQ(IXY ) & + + AQ(IXY) * (1.-RD1)*RD2/6. + END IF + ! + IXC = SIGN(NY,IIXY3(ISEA)) + IYC = IIXY3(ISEA) - IXC + IF ( MAPSTX(IXY+IIXY3(ISEA)) .GE. 1 .AND. & + .NOT. ( MAPSTX(IXY+IXC).LE.0 .AND. & + MAPSTX(IXY+IYC).LE.0 ) ) THEN + VQ(IXY+IIXY3(ISEA)) = VQ(IXY+IIXY3(ISEA)) & + + AQ(IXY) * RD4*RD3/6. + ELSE + VQ(IXY ) = VQ(IXY ) & + + AQ(IXY) * RD4*RD3/6. + END IF + IF ( MAPSTX(IXY-IIXY3(ISEA)) .GE. 1 .AND. & + .NOT. ( MAPSTX(IXY-IXC).LE.0 .AND. & + MAPSTX(IXY-IYC).LE.0 ) ) THEN + VQ(IXY-IIXY3(ISEA)) = VQ(IXY-IIXY3(ISEA)) & + + AQ(IXY) * RD4*RD3/6. + ELSE + VQ(IXY ) = VQ(IXY ) & + + AQ(IXY) * RD4*RD3/6. + END IF + ! + IF ( MAPSTX(IXY+IIXY4(ISEA)) .GE. 1 ) THEN + VQ(IXY+IIXY4(ISEA)) = VQ(IXY+IIXY4(ISEA)) & + + AQ(IXY) * (1.-RD3)*RD4/6. + ELSE + VQ(IXY ) = VQ(IXY ) & + + AQ(IXY) * (1.-RD3)*RD4/6. + END IF + IF ( MAPSTX(IXY-IIXY4(ISEA)) .GE. 1 ) THEN + VQ(IXY-IIXY4(ISEA)) = VQ(IXY-IIXY4(ISEA)) & + + AQ(IXY) * (1.-RD3)*RD4/6. + ELSE + VQ(IXY ) = VQ(IXY ) & + + AQ(IXY) * (1.-RD3)*RD4/6. + END IF + ! + END IF + ! + END DO + ! + ! 3.a.3 Restore boundary data + ! + DO IXY=1, NX*NY + IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) + END DO + ! + ! 3.a.4 Global closure (averaging only, propagation is closed in W3QCK3). + ! + IF ( GLOBAL ) THEN + DO IY=1, NY + VQ(IY ) = VQ(IY ) + VQ(NX*NY+IY) + VQ((NX-1)*NY+IY) = VQ((NX-1)*NY+IY) + VQ(IY-NY) + END DO + END IF + ! + ! 3.b Propagate fields + ! + ! Transform VQ to straightened space + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA,IX, IY, IXY, CP, CQ) + !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY) #endif -! + ! DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) - CP = CXTOT(IXY)*DPDX(IY,IX) + CYTOT(IXY)*DPDY(IY,IX) - CQ = CXTOT(IXY)*DQDX(IY,IX) + CYTOT(IXY)*DQDY(IY,IX) - VLCFLX(IXY) = CP*DTRAD - VLCFLY(IXY) = CQ*DTRAD + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + VQ(IXY)= VQ(IXY) * GSQRT(IY,IX) END DO -! + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO -#endif -! -! 3. Loop over sub-steps -------------------------------------------- * -! - DO ITLOC=1, NTLOC -! -! 3.a Average -! - AQ = VQ - VQ = 0. -! -! 3.a.1 Central points -! - DO IP=1, NCENT - ISEA = MAPCXY(IP) - IXY = MAPSF(ISEA,3) - IF ( MAPTRN(IXY) ) THEN - VQ(IXY) = AQ(IXY) - ELSE - RD1 = RDI1(ISEA) - RD2 = MIN ( 1. , RDI2(ISEA) * CG(IK,ISEA) ) - RD3 = RDI3(ISEA) - RD4 = MIN ( 1. , RDI4(ISEA) * CG(IK,ISEA) ) - VQ(IXY ) = VQ(IXY ) & - + AQ(IXY) * (3.-RD2-RD4)/3. - VQ(IXY+IIXY1(ISEA)) = VQ(IXY+IIXY1(ISEA)) & - + AQ(IXY) * RD2*RD1/6. - VQ(IXY+IIXY2(ISEA)) = VQ(IXY+IIXY2(ISEA)) & - + AQ(IXY) * (1.-RD1)*RD2/6. - VQ(IXY+IIXY3(ISEA)) = VQ(IXY+IIXY3(ISEA)) & - + AQ(IXY) * RD4*RD3/6. - VQ(IXY+IIXY4(ISEA)) = VQ(IXY+IIXY4(ISEA)) & - + AQ(IXY) * (1.-RD3)*RD4/6. - VQ(IXY-IIXY1(ISEA)) = VQ(IXY-IIXY1(ISEA)) & - + AQ(IXY) * RD2*RD1/6. - VQ(IXY-IIXY2(ISEA)) = VQ(IXY-IIXY2(ISEA)) & - + AQ(IXY) * (1.-RD1)*RD2/6. - VQ(IXY-IIXY3(ISEA)) = VQ(IXY-IIXY3(ISEA)) & - + AQ(IXY) * RD4*RD3/6. - VQ(IXY-IIXY4(ISEA)) = VQ(IXY-IIXY4(ISEA)) & - + AQ(IXY) * (1.-RD3)*RD4/6. - END IF - END DO -! -! 3.a.2 Near-coast points -! - DO IP=NCENT+1, NSEA - ISEA = MAPCXY(IP) - IX = MAPSF(ISEA,1) - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .LE. 0 ) CYCLE - IF ( MAPTRN(IXY) ) THEN - VQ(IXY) = AQ(IXY) - ELSE - RD1 = RDI1(ISEA) - RD3 = RDI3(ISEA) - RD2 = MIN ( 1. , RDI2(ISEA) * CG(IK,ISEA) ) - RD4 = MIN ( 1. , RDI4(ISEA) * CG(IK,ISEA) ) - VQ(IXY ) = VQ(IXY ) & - + AQ(IXY) * (3.-RD2-RD4)/3. -! - IXC = SIGN(NY,IIXY1(ISEA)) - IYC = IIXY1(ISEA) - IXC - IF ( MAPSTX(IXY+IIXY1(ISEA)) .GE. 1 .AND. & - .NOT. ( MAPSTX(IXY+IXC).LE.0 .AND. & - MAPSTX(IXY+IYC).LE.0 ) ) THEN - VQ(IXY+IIXY1(ISEA)) = VQ(IXY+IIXY1(ISEA)) & - + AQ(IXY) * RD2*RD1/6. - ELSE - VQ(IXY ) = VQ(IXY ) & - + AQ(IXY) * RD2*RD1/6. - END IF - IF ( MAPSTX(IXY-IIXY1(ISEA)) .GE. 1 .AND. & - .NOT. ( MAPSTX(IXY-IXC).LE.0 .AND. & - MAPSTX(IXY-IYC).LE.0 ) ) THEN - VQ(IXY-IIXY1(ISEA)) = VQ(IXY-IIXY1(ISEA)) & - + AQ(IXY) * RD2*RD1/6. - ELSE - VQ(IXY ) = VQ(IXY ) & - + AQ(IXY) * RD2*RD1/6. - END IF - - IF ( MAPSTX(IXY+IIXY2(ISEA)) .GE. 1 ) THEN - VQ(IXY+IIXY2(ISEA)) = VQ(IXY+IIXY2(ISEA)) & - + AQ(IXY) * (1.-RD1)*RD2/6. - ELSE - VQ(IXY ) = VQ(IXY ) & - + AQ(IXY) * (1.-RD1)*RD2/6. - END IF - IF ( MAPSTX(IXY-IIXY2(ISEA)) .GE. 1 ) THEN - VQ(IXY-IIXY2(ISEA)) = VQ(IXY-IIXY2(ISEA)) & - + AQ(IXY) * (1.-RD1)*RD2/6. - ELSE - VQ(IXY ) = VQ(IXY ) & - + AQ(IXY) * (1.-RD1)*RD2/6. - END IF -! - IXC = SIGN(NY,IIXY3(ISEA)) - IYC = IIXY3(ISEA) - IXC - IF ( MAPSTX(IXY+IIXY3(ISEA)) .GE. 1 .AND. & - .NOT. ( MAPSTX(IXY+IXC).LE.0 .AND. & - MAPSTX(IXY+IYC).LE.0 ) ) THEN - VQ(IXY+IIXY3(ISEA)) = VQ(IXY+IIXY3(ISEA)) & - + AQ(IXY) * RD4*RD3/6. - ELSE - VQ(IXY ) = VQ(IXY ) & - + AQ(IXY) * RD4*RD3/6. - END IF - IF ( MAPSTX(IXY-IIXY3(ISEA)) .GE. 1 .AND. & - .NOT. ( MAPSTX(IXY-IXC).LE.0 .AND. & - MAPSTX(IXY-IYC).LE.0 ) ) THEN - VQ(IXY-IIXY3(ISEA)) = VQ(IXY-IIXY3(ISEA)) & - + AQ(IXY) * RD4*RD3/6. - ELSE - VQ(IXY ) = VQ(IXY ) & - + AQ(IXY) * RD4*RD3/6. - END IF -! - IF ( MAPSTX(IXY+IIXY4(ISEA)) .GE. 1 ) THEN - VQ(IXY+IIXY4(ISEA)) = VQ(IXY+IIXY4(ISEA)) & - + AQ(IXY) * (1.-RD3)*RD4/6. - ELSE - VQ(IXY ) = VQ(IXY ) & - + AQ(IXY) * (1.-RD3)*RD4/6. - END IF - IF ( MAPSTX(IXY-IIXY4(ISEA)) .GE. 1 ) THEN - VQ(IXY-IIXY4(ISEA)) = VQ(IXY-IIXY4(ISEA)) & - + AQ(IXY) * (1.-RD3)*RD4/6. - ELSE - VQ(IXY ) = VQ(IXY ) & - + AQ(IXY) * (1.-RD3)*RD4/6. - END IF -! - END IF -! - END DO -! -! 3.a.3 Restore boundary data -! - DO IXY=1, NX*NY - IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) - END DO -! -! 3.a.4 Global closure (averaging only, propagation is closed in W3QCK3). -! - IF ( GLOBAL ) THEN - DO IY=1, NY - VQ(IY ) = VQ(IY ) + VQ(NX*NY+IY) - VQ((NX-1)*NY+IY) = VQ((NX-1)*NY+IY) + VQ(IY-NY) - END DO - END IF -! -! 3.b Propagate fields -! -! Transform VQ to straightened space -! -#ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY) -#endif -! - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) - VQ(IXY)= VQ(IXY) * GSQRT(IY,IX) - END DO -! -#ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - IF ( YFIRST ) THEN -! + ! + IF ( YFIRST ) THEN + ! #ifdef W3_UQ - IF ( FLCY ) CALL W3QCK3 & - (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & - .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & - NMY1, NMY2, NDSE, NDST ) - IF ( FLCX ) CALL W3QCK3 & - (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & - GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & - NMX1, NMX2, NDSE, NDST ) -#endif -! + IF ( FLCY ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) + IF ( FLCX ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) +#endif + ! #ifdef W3_UNO - IF ( FLCY ) CALL W3UNO2s & - (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & - .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & - NMY1, NMY2, NDSE, NDST ) - IF ( FLCX ) CALL W3UNO2s & - (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & - GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & - NMX1, NMX2, NDSE, NDST ) -#endif -! - ELSE -! + IF ( FLCY ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) + IF ( FLCX ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) +#endif + ! + ELSE + ! #ifdef W3_UQ - IF ( FLCX ) CALL W3QCK3 & - (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & - GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & - NMX1, NMX2, NDSE, NDST ) - IF ( FLCY ) CALL W3QCK3 & - (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & - .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & - NMY1, NMY2, NDSE, NDST ) -#endif -! + IF ( FLCX ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) + IF ( FLCY ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) +#endif + ! #ifdef W3_UNO - IF ( FLCX ) CALL W3UNO2s & - (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & - GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & - NMX1, NMX2, NDSE, NDST ) - IF ( FLCY ) CALL W3UNO2s & - (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & - .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & - NMY1, NMY2, NDSE, NDST ) -#endif -! - END IF -! -! Transform VQ back to normal space -! + IF ( FLCX ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) + IF ( FLCY ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) +#endif + ! + END IF + ! + ! Transform VQ back to normal space + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY) -#endif -! - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) - VQ(IXY)= VQ(IXY) / GSQRT(IY,IX) - END DO -! + !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY) +#endif + ! + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + VQ(IXY)= VQ(IXY) / GSQRT(IY,IX) + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! -! 3.c Update boundaries -! + ! + ! 3.c Update boundaries + ! #ifdef W3_T - WRITE (NDST,9030) NSEA + WRITE (NDST,9030) NSEA #endif -! + ! #ifdef W3_T2 - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .GT. 0 ) THEN - WRITE(NDST,9031)ISEA,MAPSF(ISEA,1),MAPSF(ISEA,2),VQ(IXY) - VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) - END IF - END DO -#endif -! - IF ( FLBPI ) THEN - RD1 = DSEC21 ( TBPI0, TIME ) - DTG * & - REAL(NTLOC-ITLOC)/REAL(NTLOC) - RD2 = DSEC21 ( TBPI0, TBPIN ) - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF - DO IBI=1, NBI - IXY = MAPSF(ISBPI(IBI),3) - VQ(IXY) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) - END DO - END IF -! - YFIRST = .NOT. YFIRST + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .GT. 0 ) THEN + WRITE(NDST,9031)ISEA,MAPSF(ISEA,1),MAPSF(ISEA,2),VQ(IXY) + VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) + END IF + END DO +#endif + ! + IF ( FLBPI ) THEN + RD1 = DSEC21 ( TBPI0, TIME ) - DTG * & + REAL(NTLOC-ITLOC)/REAL(NTLOC) + RD2 = DSEC21 ( TBPI0, TBPIN ) + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. + END IF + DO IBI=1, NBI + IXY = MAPSF(ISBPI(IBI),3) + VQ(IXY) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) END DO -! -! 4. Store results in VQ in proper format --------------------------- * -! + END IF + ! + YFIRST = .NOT. YFIRST + END DO + ! + ! 4. Store results in VQ in proper format --------------------------- * + ! #ifdef W3_T - WRITE (NDST,9040) NSEA + WRITE (NDST,9040) NSEA #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (ISEA, IXY) + !$OMP PARALLEL DO PRIVATE (ISEA, IXY) #endif -! - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .GT. 0 ) THEN + ! + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .GT. 0 ) THEN #ifdef W3_T3 - WRITE (NDST,9041) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), VQ(IXY) + WRITE (NDST,9041) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), VQ(IXY) #endif - VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) - END IF - END DO -! + VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) + END IF + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3XYP3 : YFIRST :',L2) - 9001 FORMAT (' TEST W3XYP3 : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) -#endif -! -#ifdef W3_T - 9010 FORMAT (' TEST W3XYP3 : INITIALIZE ARRAYS') +9000 FORMAT (' TEST W3XYP3 : YFIRST :',L2) +9001 FORMAT (' TEST W3XYP3 : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) +9010 FORMAT (' TEST W3XYP3 : INITIALIZE ARRAYS') +9020 FORMAT (' TEST W3XYP3 : CALCULATING VCFL0X/Y (NSEA=',I6,')') +9022 FORMAT (' TEST W3XYP3 : CALCULATING VCFLUX/Y') +9030 FORMAT (' TEST W3XYP3 : FIELD BEFORE BPI. (NSEA=',I6,')') +9040 FORMAT (' TEST W3XYP3 : FIELD AFTER PROP. (NSEA=',I6,')') #endif #ifdef W3_T0 - 9011 FORMAT (' TEST W3XYP3 : PREPARE AVERAGING') - 9012 FORMAT (' ',4I4,2F7.3) - 9013 FORMAT (' ',8X,2I4,2F7.3) -#endif -! -#ifdef W3_T - 9020 FORMAT (' TEST W3XYP3 : CALCULATING VCFL0X/Y (NSEA=',I6,')') +9011 FORMAT (' TEST W3XYP3 : PREPARE AVERAGING') +9012 FORMAT (' ',4I4,2F7.3) +9013 FORMAT (' ',8X,2I4,2F7.3) #endif + ! #ifdef W3_T1 - 9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) -#endif -#ifdef W3_T - 9022 FORMAT (' TEST W3XYP3 : CALCULATING VCFLUX/Y') -#endif -! -#ifdef W3_T - 9030 FORMAT (' TEST W3XYP3 : FIELD BEFORE BPI. (NSEA=',I6,')') +9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) #endif + ! #ifdef W3_T2 - 9031 FORMAT (1X,I6,2I5,E12.4) -#endif -! -#ifdef W3_T - 9040 FORMAT (' TEST W3XYP3 : FIELD AFTER PROP. (NSEA=',I6,')') +9031 FORMAT (1X,I6,2I5,E12.4) #endif + ! #ifdef W3_T3 - 9041 FORMAT (1X,I6,2I5,E12.4) -#endif -!/ -!/ End of W3XYP3 ----------------------------------------------------- / -!/ - END SUBROUTINE W3XYP3 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & - DDDX, DDDY, CX, CY, DCXDX, DCXDY, & - DCYDX, DCYDY, DCDX, DCDY, VA, CFLTHMAX, CFLKMAX ) -!/ -!/ *** THIS ROUTINE SHOULD BE IDENTICAL TO W3KTP2 *** -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Jul-2013 | -!/ +-----------------------------------+ -!/ -!/ 14-Feb-2000 : Origination. ( version 2.08 ) -!/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 06-Mar-2011 : Output of maximum CFL (F. Ardhuin) ( version 3.14 ) -!/ 24-Aug-2011 : Limiter on k advection (F. Ardhuin) ( version 4.04 ) -!/ 25-Aug-2011 : DEPTH = MAX ( DMIN, DW(ISEA) ) ( version 4.04 ) -!/ 26-Dec-2012 : More initializations. ( version 4.11 ) -!/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third -!/ and second order schemes. ( version 4.12 ) -!/ -! 1. Purpose : -! -! Propagation in spectral space. -! -! 2. Method : -! -! Third order QUICKEST scheme with ULTIMATE limiter. -! -! As with the spatial propagation, the two spaces are considered -! independently, but the propagation is performed in a 2-D space. -! Compared to the propagation in physical space, the directions -! rerpesent a closed space and are therefore comparable to the -! longitudinal or 'X' propagation. The wavenumber space has to be -! extended to allow for boundary treatment. Using a simple first -! order boundary treatment at both sided, two points need to -! be added. This implies that the spectrum needs to be extended, -! shifted and rotated, as is performed using MAPTH2 as set -! in W3MAP3. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISEA Int. I Number of sea point. -! FACTH/K Real I Factor in propagation velocity. -! CTHG0 Real I Factor in great circle refracftion term. -! MAPxx2 I.A. I Propagation and storage maps. -! CG R.A. I Local group velocities. -! WN R.A. I Local wavenumbers. -! DW R.A. I Depth. -! DDDx Real I Depth gradients. -! CX/Y Real I Current components. -! DCxDx Real I Current gradients. -! DCDX-Y Real I Phase speed gradients. -! VA R.A. I/O Spectrum. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! DSDD R.A. Partial derivative of sigma for depth. -! FDD, FDU, FDG, FCD, FCU -! R.A. Directionally varying part of depth, current and -! great-circle refraction terms and of consit. -! of Ck term. -! CFLT-K R.A. Propagation velocities of local fluxes. -! DB R.A. Wavenumber band widths at cell centers. -! DM R.A. Wavenumber band widths between cell centers and -! next cell center. -! Q R.A. Extracted spectrum -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! W3QCK1 Actual propagation routine. -! W3QCK2 Actual propagation routine. -! STRACE Service routine. -! -! 5. Called by : -! -! W3WAVE Wave model routine. -! -! 6. Error messages : -! -! None. -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Preparations -! a Initialize arrays -! b Set constants and counters -! 2. Point preparations -! a Calculate DSDD -! b Extract spectrum -! 3. Refraction velocities -! a Filter level depth reffraction. -! b Depth refratcion velocity. -! c Current refraction velocity. -! 4. Wavenumber shift velocities -! a Prepare directional arrays -! b Calcuate velocity. -! 5. Propagate. -! 6. Store results. -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & - CTMAX, DMIN - USE W3ADATMD, ONLY: MAPTH2, MAPWN2, ITIME - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, ONLY: NDSE, NDST +9041 FORMAT (1X,I6,2I5,E12.4) +#endif + !/ + !/ End of W3XYP3 ----------------------------------------------------- / + !/ + END SUBROUTINE W3XYP3 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & + DDDX, DDDY, CX, CY, DCXDX, DCXDY, & + DCYDX, DCYDY, DCDX, DCDY, VA, CFLTHMAX, CFLKMAX ) + !/ + !/ *** THIS ROUTINE SHOULD BE IDENTICAL TO W3KTP2 *** + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Jul-2013 | + !/ +-----------------------------------+ + !/ + !/ 14-Feb-2000 : Origination. ( version 2.08 ) + !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 06-Mar-2011 : Output of maximum CFL (F. Ardhuin) ( version 3.14 ) + !/ 24-Aug-2011 : Limiter on k advection (F. Ardhuin) ( version 4.04 ) + !/ 25-Aug-2011 : DEPTH = MAX ( DMIN, DW(ISEA) ) ( version 4.04 ) + !/ 26-Dec-2012 : More initializations. ( version 4.11 ) + !/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third + !/ and second order schemes. ( version 4.12 ) + !/ + ! 1. Purpose : + ! + ! Propagation in spectral space. + ! + ! 2. Method : + ! + ! Third order QUICKEST scheme with ULTIMATE limiter. + ! + ! As with the spatial propagation, the two spaces are considered + ! independently, but the propagation is performed in a 2-D space. + ! Compared to the propagation in physical space, the directions + ! rerpesent a closed space and are therefore comparable to the + ! longitudinal or 'X' propagation. The wavenumber space has to be + ! extended to allow for boundary treatment. Using a simple first + ! order boundary treatment at both sided, two points need to + ! be added. This implies that the spectrum needs to be extended, + ! shifted and rotated, as is performed using MAPTH2 as set + ! in W3MAP3. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISEA Int. I Number of sea point. + ! FACTH/K Real I Factor in propagation velocity. + ! CTHG0 Real I Factor in great circle refracftion term. + ! MAPxx2 I.A. I Propagation and storage maps. + ! CG R.A. I Local group velocities. + ! WN R.A. I Local wavenumbers. + ! DW R.A. I Depth. + ! DDDx Real I Depth gradients. + ! CX/Y Real I Current components. + ! DCxDx Real I Current gradients. + ! DCDX-Y Real I Phase speed gradients. + ! VA R.A. I/O Spectrum. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! DSDD R.A. Partial derivative of sigma for depth. + ! FDD, FDU, FDG, FCD, FCU + ! R.A. Directionally varying part of depth, current and + ! great-circle refraction terms and of consit. + ! of Ck term. + ! CFLT-K R.A. Propagation velocities of local fluxes. + ! DB R.A. Wavenumber band widths at cell centers. + ! DM R.A. Wavenumber band widths between cell centers and + ! next cell center. + ! Q R.A. Extracted spectrum + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! W3QCK1 Actual propagation routine. + ! W3QCK2 Actual propagation routine. + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3WAVE Wave model routine. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Preparations + ! a Initialize arrays + ! b Set constants and counters + ! 2. Point preparations + ! a Calculate DSDD + ! b Extract spectrum + ! 3. Refraction velocities + ! a Filter level depth reffraction. + ! b Depth refratcion velocity. + ! c Current refraction velocity. + ! 4. Wavenumber shift velocities + ! a Prepare directional arrays + ! b Calcuate velocity. + ! 5. Propagate. + ! 6. Store results. + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & + EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & + CTMAX, DMIN + USE W3ADATMD, ONLY: MAPTH2, MAPWN2, ITIME + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, ONLY: NDSE, NDST #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_UQ - USE W3UQCKMD + USE W3UQCKMD #endif #ifdef W3_UNO - USE W3UNO2MD -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISEA - REAL, INTENT(IN) :: FACTH, FACK, CTHG0, CG(0:NK+1), & - WN(0:NK+1), DW, DDDX, DDDY, & - CX, CY, DCXDX, DCXDY, DCYDX, DCYDY - REAL, INTENT(IN) :: DCDX(0:NK+1), DCDY(0:NK+1) - REAL, INTENT(INOUT) :: VA(NSPEC) - REAL, INTENT(OUT) :: CFLTHMAX, CFLKMAX -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK, ISP + USE W3UNO2MD +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISEA + REAL, INTENT(IN) :: FACTH, FACK, CTHG0, CG(0:NK+1), & + WN(0:NK+1), DW, DDDX, DDDY, & + CX, CY, DCXDX, DCXDY, DCYDX, DCYDY + REAL, INTENT(IN) :: DCDX(0:NK+1), DCDY(0:NK+1) + REAL, INTENT(INOUT) :: VA(NSPEC) + REAL, INTENT(OUT) :: CFLTHMAX, CFLKMAX + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK, ISP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: FDDMAX, FDG, FKD, FKD0, DCYX, & - DCXXYY, DCXY, DCXX, DCXYYX, DCYY, & - VELNOFILT, VELFAC, DEPTH - REAL :: DSDD(0:NK+1), FRK(NK), FRG(NK), & - FKC(NTH), VQ(-NK-1:NK2*(NTH+2)), & - DB(NK2,NTH+1), DM(NK2,0:NTH+1), & - VCFLT(NK2*(NTH+1)), CFLK(NK2,NTH) -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: FDDMAX, FDG, FKD, FKD0, DCYX, & + DCXXYY, DCXY, DCXX, DCXYYX, DCYY, & + VELNOFILT, VELFAC, DEPTH + REAL :: DSDD(0:NK+1), FRK(NK), FRG(NK), & + FKC(NTH), VQ(-NK-1:NK2*(NTH+2)), & + DB(NK2,NTH+1), DM(NK2,0:NTH+1), & + VCFLT(NK2*(NTH+1)), CFLK(NK2,NTH) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3KTP3') -#endif -! -! 1. Preparations --------------------------------------------------- * -! 1.a Initialize arrays -! - DEPTH = MAX ( DMIN, DW ) - VQ = 0. - IF ( FLCTH ) VCFLT = 0. - IF ( FLCK ) CFLK = 0. - CFLTHMAX = 0. - CFLKMAX = 0. -! + CALL STRACE (IENT, 'W3KTP3') +#endif + ! + ! 1. Preparations --------------------------------------------------- * + ! 1.a Initialize arrays + ! + DEPTH = MAX ( DMIN, DW ) + VQ = 0. + IF ( FLCTH ) VCFLT = 0. + IF ( FLCK ) CFLK = 0. + CFLTHMAX = 0. + CFLKMAX = 0. + ! #ifdef W3_T - WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX - WRITE (NDST,9010) ISEA, DEPTH, CX, CY, DDDX, DDDY, & - DCXDX, DCXDY, DCYDX, DCYDY -#endif -! -! 2. Preparation for point ------------------------------------------ * -! 2.a Array with partial derivative of sigma versus depth -! - DO IK=0, NK+1 - IF ( DEPTH*WN(IK) .LT. 5. ) THEN - DSDD(IK) = MAX ( 0. , & - CG(IK)*WN(IK)-0.5*SIG(IK) ) / DEPTH - ELSE - DSDD(IK) = 0. - END IF - END DO -! + WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX + WRITE (NDST,9010) ISEA, DEPTH, CX, CY, DDDX, DDDY, & + DCXDX, DCXDY, DCYDX, DCYDY +#endif + ! + ! 2. Preparation for point ------------------------------------------ * + ! 2.a Array with partial derivative of sigma versus depth + ! + DO IK=0, NK+1 + IF ( DEPTH*WN(IK) .LT. 5. ) THEN + DSDD(IK) = MAX ( 0. , & + CG(IK)*WN(IK)-0.5*SIG(IK) ) / DEPTH + ELSE + DSDD(IK) = 0. + END IF + END DO + ! #ifdef W3_T - WRITE (NDST,9020) - DO IK=1, NK+1 - WRITE (NDST,9021) IK, TPI/SIG(IK), TPI/WN(IK), & - CG(IK), DSDD(IK) - END DO -#endif -! -! 2.b Extract spectrum -! - DO ISP=1, NSPEC - VQ(MAPTH2(ISP)) = VA(ISP) + WRITE (NDST,9020) + DO IK=1, NK+1 + WRITE (NDST,9021) IK, TPI/SIG(IK), TPI/WN(IK), & + CG(IK), DSDD(IK) + END DO +#endif + ! + ! 2.b Extract spectrum + ! + DO ISP=1, NSPEC + VQ(MAPTH2(ISP)) = VA(ISP) + END DO + ! + ! 3. Refraction velocities ------------------------------------------ * + ! + IF ( FLCTH ) THEN + ! + ! 3.a Set slope filter for depth refraction + ! + ! N.B.: FACTH = DTG / DTH / REAL(NTLOC) (value set in w3wavemd) + ! namely, FACTH*VC=1 corresponds to CFL=1 + ! + FDDMAX = 0. + FDG = FACTH * CTHG0 + ! + DO ITH=1, NTH/2 + FDDMAX = MAX(FDDMAX,ABS(ESIN(ITH)*DDDX-ECOS(ITH)*DDDY)) + END DO + ! + DO IK=1, NK + FRK(IK) = FACTH * DSDD(IK) / WN(IK) + ! + ! Removes the filtering that was done at that stage (F. Ardhuin 2011/03/06) + ! + ! FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) + FRG(IK) = FDG * CG(IK) + END DO + ! + ! 3.b Current refraction + ! + IF ( FLCUR ) THEN + ! + DCYX = FACTH * DCYDX + DCXXYY = FACTH * ( DCXDX - DCYDY ) + DCXY = FACTH * DCXDY + ! + DO ISP=1, NSPEC + VCFLT(MAPTH2(ISP)) = ES2(ISP)*DCYX + & + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY END DO -! -! 3. Refraction velocities ------------------------------------------ * -! - IF ( FLCTH ) THEN -! -! 3.a Set slope filter for depth refraction -! -! N.B.: FACTH = DTG / DTH / REAL(NTLOC) (value set in w3wavemd) -! namely, FACTH*VC=1 corresponds to CFL=1 -! - FDDMAX = 0. - FDG = FACTH * CTHG0 -! - DO ITH=1, NTH/2 - FDDMAX = MAX(FDDMAX,ABS(ESIN(ITH)*DDDX-ECOS(ITH)*DDDY)) - END DO -! - DO IK=1, NK - FRK(IK) = FACTH * DSDD(IK) / WN(IK) -! -! Removes the filtering that was done at that stage (F. Ardhuin 2011/03/06) -! -! FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) - FRG(IK) = FDG * CG(IK) - END DO -! -! 3.b Current refraction -! - IF ( FLCUR ) THEN -! - DCYX = FACTH * DCYDX - DCXXYY = FACTH * ( DCXDX - DCYDY ) - DCXY = FACTH * DCXDY -! - DO ISP=1, NSPEC - VCFLT(MAPTH2(ISP)) = ES2(ISP)*DCYX + & - ESC(ISP)*DCXXYY - EC2(ISP)*DCXY - END DO -! - ELSE - VCFLT(:)=0. - END IF -! -! 3.c Depth refraction and great-circle propagation -! + ! + ELSE + VCFLT(:)=0. + END IF + ! + ! 3.c Depth refraction and great-circle propagation + ! #ifdef W3_REFRX -! 3.d @C/@x refraction and great-circle propagation - FRK = 0. - FDDMAX = 0. + ! 3.d @C/@x refraction and great-circle propagation + FRK = 0. + FDDMAX = 0. + ! + DO ISP=1, NSPEC + FDDMAX = MAX ( FDDMAX , ABS ( & + ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) + END DO + DO IK=1, NK + FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) + END DO #endif -! -#ifdef W3_REFRX - DO ISP=1, NSPEC - FDDMAX = MAX ( FDDMAX , ABS ( & - ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) - END DO - DO IK=1, NK - FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) - END DO -#endif -! - DO ISP=1, NSPEC - VELNOFILT = VCFLT(MAPTH2(ISP)) & - + FRG(MAPWN(ISP)) * ECOS(ISP) & - + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DDDX - ECOS(ISP)*DDDY ) -! + ! + DO ISP=1, NSPEC + VELNOFILT = VCFLT(MAPTH2(ISP)) & + + FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DDDX - ECOS(ISP)*DDDY ) + ! #ifdef W3_REFRX -! 3.d @C/@x refraction and great-circle propagation - VELNOFILT = VCFLT(MAPTH2(ISP)) & - + FRG(MAPWN(ISP)) * ECOS(ISP) & - + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & - - ECOS(ISP)*DCDY(MAPWN(ISP)) ) -#endif - CFLTHMAX = MAX(CFLTHMAX, ABS(VELNOFILT)) -! -! Puts filtering on total velocity (including currents and great circle effects) -! the filtering limits VCFLT to be less than CTMAX -! this modification was proposed by F. Ardhuin 2011/03/06 -! - VCFLT(MAPTH2(ISP))=SIGN(MIN(ABS(VELNOFILT),CTMAX),VELNOFILT) - END DO - END IF -! -! 4. Wavenumber shift velocities ------------------------------------ * -! N.B.: FACK = DTG / REAL(NTLOC) (value set in w3wavemd) -! namely, FACK*VC/DK=1 corresponds to CFL=1 -! + ! 3.d @C/@x refraction and great-circle propagation + VELNOFILT = VCFLT(MAPTH2(ISP)) & + + FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & + - ECOS(ISP)*DCDY(MAPWN(ISP)) ) +#endif + CFLTHMAX = MAX(CFLTHMAX, ABS(VELNOFILT)) + ! + ! Puts filtering on total velocity (including currents and great circle effects) + ! the filtering limits VCFLT to be less than CTMAX + ! this modification was proposed by F. Ardhuin 2011/03/06 + ! + VCFLT(MAPTH2(ISP))=SIGN(MIN(ABS(VELNOFILT),CTMAX),VELNOFILT) + END DO + END IF + ! + ! 4. Wavenumber shift velocities ------------------------------------ * + ! N.B.: FACK = DTG / REAL(NTLOC) (value set in w3wavemd) + ! namely, FACK*VC/DK=1 corresponds to CFL=1 + ! + IF ( FLCK ) THEN + ! + ! 4.a Directionally dependent part + ! + DCXX = - DCXDX + DCXYYX = - ( DCXDY + DCYDX ) + DCYY = - DCYDY + FKD = ( CX*DDDX + CY*DDDY ) + ! + DO ITH=1, NTH + FKC(ITH) = EC2(ITH)*DCXX + & + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY + END DO + ! + ! 4.b Band widths + ! + DO IK=0, NK + DB(IK+1,1) = DSIP(IK) / CG(IK) + DM(IK+1,1) = WN(IK+1) - WN(IK) + END DO + DB(NK+2,1) = DSIP(NK+1) / CG(NK+1) + DM(NK+2,1) = 0. + ! + DO ITH=2, NTH + DO IK=1, NK+2 + DB(IK,ITH) = DB(IK,1) + DM(IK,ITH) = DM(IK,1) + END DO + END DO + ! + ! 4.c Velocities + ! + DO IK=0, NK+1 + FKD0 = FKD / CG(IK) * DSDD(IK) + VELFAC = FACK/DB(IK+1,1) + DO ITH=1, NTH + ! + ! Puts filtering on velocity (needs the band widths) + ! + VELNOFILT = ( FKD0 + WN(IK)*FKC(ITH) ) * VELFAC ! this is velocity * DT / DK + CFLKMAX = MAX(CFLKMAX, ABS(VELNOFILT)) + CFLK(IK+1,ITH) = SIGN(MIN(ABS(VELNOFILT),CTMAX),VELNOFILT)/VELFAC + !CFLK(IK+1,ITH) = FKD0 + WN(IK)*FKC(ITH) ! this was without the limiter ... + END DO + END DO + ! + END IF + ! + ! 5. Propagate ------------------------------------------------------ * + ! + IF ( MOD(ITIME,2) .EQ. 0 ) THEN IF ( FLCK ) THEN -! -! 4.a Directionally dependent part -! - DCXX = - DCXDX - DCXYYX = - ( DCXDY + DCYDX ) - DCYY = - DCYDY - FKD = ( CX*DDDX + CY*DDDY ) -! - DO ITH=1, NTH - FKC(ITH) = EC2(ITH)*DCXX + & - ESC(ITH)*DCXYYX + ES2(ITH)*DCYY - END DO -! -! 4.b Band widths -! - DO IK=0, NK - DB(IK+1,1) = DSIP(IK) / CG(IK) - DM(IK+1,1) = WN(IK+1) - WN(IK) - END DO - DB(NK+2,1) = DSIP(NK+1) / CG(NK+1) - DM(NK+2,1) = 0. -! - DO ITH=2, NTH - DO IK=1, NK+2 - DB(IK,ITH) = DB(IK,1) - DM(IK,ITH) = DM(IK,1) - END DO - END DO -! -! 4.c Velocities -! - DO IK=0, NK+1 - FKD0 = FKD / CG(IK) * DSDD(IK) - VELFAC = FACK/DB(IK+1,1) - DO ITH=1, NTH -! -! Puts filtering on velocity (needs the band widths) -! - VELNOFILT = ( FKD0 + WN(IK)*FKC(ITH) ) * VELFAC ! this is velocity * DT / DK - CFLKMAX = MAX(CFLKMAX, ABS(VELNOFILT)) - CFLK(IK+1,ITH) = SIGN(MIN(ABS(VELNOFILT),CTMAX),VELNOFILT)/VELFAC - !CFLK(IK+1,ITH) = FKD0 + WN(IK)*FKC(ITH) ! this was without the limiter ... - END DO - END DO -! - END IF -! -! 5. Propagate ------------------------------------------------------ * -! - IF ( MOD(ITIME,2) .EQ. 0 ) THEN - IF ( FLCK ) THEN - DO ITH=1, NTH - VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) - END DO -! + DO ITH=1, NTH + VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) + END DO + ! #ifdef W3_UQ - CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & - VQ, .FALSE., 1, MAPTH2, NSPEC, & - MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & - NDSE, NDST ) + CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) #endif -! + ! #ifdef W3_UNO - CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & - VQ, .FALSE., 1, MAPTH2, NSPEC, & - MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & - NDSE, NDST ) -#endif -! - END IF - IF ( FLCTH ) THEN -! + CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) +#endif + ! + END IF + IF ( FLCTH ) THEN + ! #ifdef W3_UQ - CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & - NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & - NSPEC, NDSE, NDST ) + CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & + NSPEC, NDSE, NDST ) #endif -! + ! #ifdef W3_UNO - CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & - NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& - NSPEC, NDSE, NDST ) + CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& + NSPEC, NDSE, NDST ) #endif -! - END IF - ELSE - IF ( FLCTH ) THEN -! + ! + END IF + ELSE + IF ( FLCTH ) THEN + ! #ifdef W3_UQ - CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & - NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & - NSPEC, NDSE, NDST ) + CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & + NSPEC, NDSE, NDST ) #endif -! + ! #ifdef W3_UNO - CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & - NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& - NSPEC, NDSE, NDST ) -#endif -! - END IF - IF ( FLCK ) THEN - DO ITH=1, NTH - VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) - END DO -! + CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& + NSPEC, NDSE, NDST ) +#endif + ! + END IF + IF ( FLCK ) THEN + DO ITH=1, NTH + VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) + END DO + ! #ifdef W3_UQ - CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & - VQ, .FALSE., 1, MAPTH2, NSPEC, & - MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & - NDSE, NDST ) + CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) #endif -! + ! #ifdef W3_UNO - CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & - VQ, .FALSE., 1, MAPTH2, NSPEC, & - MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & - NDSE, NDST ) + CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) #endif -! - END IF - END IF -! -! 6. Store reults --------------------------------------------------- * -! - DO ISP=1, NSPEC - VA(ISP) = VQ(MAPTH2(ISP)) - END DO -! - RETURN -! -! Formats -! + ! + END IF + END IF + ! + ! 6. Store reults --------------------------------------------------- * + ! + DO ISP=1, NSPEC + VA(ISP) = VQ(MAPTH2(ISP)) + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3KTP3 : FLCTH-K, FACTH-K, CTMAX :', & - 2L2,2E10.3,F7.3) - 9010 FORMAT ( ' TEST W3KTP3 : LOCAL DATA :',I7,F7.1,2F6.2,1X,6E10.2) - 9020 FORMAT ( ' TEST W3KTP3 : IK, T, L, CG, DSDD : ') - 9021 FORMAT ( ' ',I3,F7.2,F7.1,F7.2,E11.3) +9000 FORMAT ( ' TEST W3KTP3 : FLCTH-K, FACTH-K, CTMAX :', & + 2L2,2E10.3,F7.3) +9010 FORMAT ( ' TEST W3KTP3 : LOCAL DATA :',I7,F7.1,2F6.2,1X,6E10.2) +9020 FORMAT ( ' TEST W3KTP3 : IK, T, L, CG, DSDD : ') +9021 FORMAT ( ' ',I3,F7.2,F7.1,F7.2,E11.3) #endif -! + ! #ifdef W3_T0 - 9040 FORMAT (/' TEST W3KTP3 : NORMALIZED ',A/) - 9041 FORMAT (1X,60(1X,I2)) - 9042 FORMAT (1X,60I3) -#endif -!/ -!/ End of W3KTP3 ----------------------------------------------------- / -!/ - END SUBROUTINE W3KTP3 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, CFLXYMAX, VGX, VGY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 31-Oct-2010 | -!/ +-----------------------------------+ -!/ -!/ 07-Mar-2011 : Origination. ( version 3.14 ) -!/ -! 1. Purpose : -! -! Computes the maximum CFL number for spatial advection. Used for diagnostic -! purposes. (Could be used to define a local time step ...) -! -! 2. Method : -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISEA Int. I Index of grid point. -! DTG Real I Total time step. -! MAPSTA I.A. I Grid point status map. -! MAPFS I.A. I Storage map. -! CFLXYMAX Real O Maximum CFL number for XY propagation. -! VGX/Y Real I Speed of grid. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! NTLOC Int Number of local time steps. -! DTLOC Real Local propagation time step. -! VCFL0X R.A. Local courant numbers for absolute group vel. -! using local X-grid step. -! VCFL0Y R.A. Id. in Y. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3WAVE Wave model routine. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Curvilinear grid implementation. Variables FACX, FACY, CCOS, CSIN, -! CCURX, CCURY are not needed and have been removed. FACX is accounted -! for as approriate in this subroutine. FACX is also accounted for in -! the case of .NOT.FLCX. Since FACX is removed, there is now a check for -! .NOT.FLCX in this subroutine. In CFL calcs dx and dy are omitted, -! since dx=dy=1 in index space. Curvilinear grid derivatives -! (DPDY, DQDX, etc.) and metric (GSQRT) are brought in via W3GDATMD. -! -! 8. Structure : -! -! --------------------------------------------- -! --------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! !/MGP Moving grid corrections. -! !/MGG Moving grid corrections. -! -! !/T Enable general test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -! - USE W3TIMEMD, ONLY: DSEC21 -! - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, DTCFL, CLATS, & - FLCX, FLCY, NK, NTH, DTH, XFR, & - ECOS, ESIN, SIG, WDCG, WDTH, PFMOVE, & - FLAGLL, DPDX, DPDY, DQDX, DQDY, GSQRT - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & - NCENT, MAPX2, MAPY2, MAPAXY, MAPCXY, & - MAPTRN, CG, CX, CY, ATRNX, ATRNY, ITIME - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & - ISBPI, BBPI0, BBPIN +9040 FORMAT (/' TEST W3KTP3 : NORMALIZED ',A/) +9041 FORMAT (1X,60(1X,I2)) +9042 FORMAT (1X,60I3) +#endif + !/ + !/ End of W3KTP3 ----------------------------------------------------- / + !/ + END SUBROUTINE W3KTP3 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, CFLXYMAX, VGX, VGY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 31-Oct-2010 | + !/ +-----------------------------------+ + !/ + !/ 07-Mar-2011 : Origination. ( version 3.14 ) + !/ + ! 1. Purpose : + ! + ! Computes the maximum CFL number for spatial advection. Used for diagnostic + ! purposes. (Could be used to define a local time step ...) + ! + ! 2. Method : + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISEA Int. I Index of grid point. + ! DTG Real I Total time step. + ! MAPSTA I.A. I Grid point status map. + ! MAPFS I.A. I Storage map. + ! CFLXYMAX Real O Maximum CFL number for XY propagation. + ! VGX/Y Real I Speed of grid. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! NTLOC Int Number of local time steps. + ! DTLOC Real Local propagation time step. + ! VCFL0X R.A. Local courant numbers for absolute group vel. + ! using local X-grid step. + ! VCFL0Y R.A. Id. in Y. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3WAVE Wave model routine. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Curvilinear grid implementation. Variables FACX, FACY, CCOS, CSIN, + ! CCURX, CCURY are not needed and have been removed. FACX is accounted + ! for as approriate in this subroutine. FACX is also accounted for in + ! the case of .NOT.FLCX. Since FACX is removed, there is now a check for + ! .NOT.FLCX in this subroutine. In CFL calcs dx and dy are omitted, + ! since dx=dy=1 in index space. Curvilinear grid derivatives + ! (DPDY, DQDX, etc.) and metric (GSQRT) are brought in via W3GDATMD. + ! + ! 8. Structure : + ! + ! --------------------------------------------- + ! --------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! !/MGP Moving grid corrections. + ! !/MGG Moving grid corrections. + ! + ! !/T Enable general test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + ! + USE W3TIMEMD, ONLY: DSEC21 + ! + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, DTCFL, CLATS, & + FLCX, FLCY, NK, NTH, DTH, XFR, & + ECOS, ESIN, SIG, WDCG, WDTH, PFMOVE, & + FLAGLL, DPDX, DPDY, DQDX, DQDY, GSQRT + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & + NCENT, MAPX2, MAPY2, MAPAXY, MAPCXY, & + MAPTRN, CG, CX, CY, ATRNX, ATRNY, ITIME + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & + ISBPI, BBPI0, BBPIN #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISEA, MAPSTA(NY*NX), MAPFS(NY*NX) - REAL, INTENT(IN) :: DTG, VGX, VGY - REAL, INTENT(INOUT) :: CFLXYMAX -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK, IXY, IP - INTEGER :: IX, IY, IXC, IYC, IBI + USE W3SERVMD, ONLY: STRACE +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISEA, MAPSTA(NY*NX), MAPFS(NY*NX) + REAL, INTENT(IN) :: DTG, VGX, VGY + REAL, INTENT(INOUT) :: CFLXYMAX + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK, IXY, IP + INTEGER :: IX, IY, IXC, IYC, IBI #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & - CXMIN, CXMAX, CYMIN, CYMAX - REAL :: CGC, FGSE = 1. - REAL :: FTH, FTHX, FTHY, FCG, FCGX, FCGY - REAL :: CP, CQ -!/ -!/ Automatic work arrays -!/ - REAL :: VLCFLX, VLCFLY - REAL :: CXTOT, CYTOT -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & + CXMIN, CXMAX, CYMIN, CYMAX + REAL :: CGC, FGSE = 1. + REAL :: FTH, FTHX, FTHY, FCG, FCGX, FCGY + REAL :: CP, CQ + !/ + !/ Automatic work arrays + !/ + REAL :: VLCFLX, VLCFLY + REAL :: CXTOT, CYTOT + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3XYCFL') -#endif -! -! 1. Preparations --------------------------------------------------- * -! 1.a Set constants -! -! - CFLXYMAX=0. - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) - DO IK=1,NK - DO ITH=1,NTH - CXTOT = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) - CYTOT = ESIN(ITH) * CG(IK,ISEA) + CALL STRACE (IENT, 'W3XYCFL') +#endif + ! + ! 1. Preparations --------------------------------------------------- * + ! 1.a Set constants + ! + ! + CFLXYMAX=0. + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + DO IK=1,NK + DO ITH=1,NTH + CXTOT = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) + CYTOT = ESIN(ITH) * CG(IK,ISEA) #ifdef W3_MGP - CXTOT = CXTOT - VGX/CLATS(ISEA) - CYTOT = CYTOT - VGY + CXTOT = CXTOT - VGX/CLATS(ISEA) + CYTOT = CYTOT - VGY #endif - IF ( FLCUR ) THEN - CXTOT = CXTOT + CX(ISEA)/CLATS(ISEA) - CYTOT = CYTOT + CY(ISEA) - END IF + IF ( FLCUR ) THEN + CXTOT = CXTOT + CX(ISEA)/CLATS(ISEA) + CYTOT = CYTOT + CY(ISEA) + END IF - CP = CXTOT*DPDX(IY,IX) + CYTOT*DPDY(IY,IX) - CQ = CXTOT*DQDX(IY,IX) + CYTOT*DQDY(IY,IX) - VLCFLX = CP*DTG - VLCFLY = CQ*DTG - CFLXYMAX = MAX(VLCFLX,VLCFLY,CFLXYMAX) - END DO - END DO + CP = CXTOT*DPDX(IY,IX) + CYTOT*DPDY(IY,IX) + CQ = CXTOT*DQDX(IY,IX) + CYTOT*DQDY(IY,IX) + VLCFLX = CP*DTG + VLCFLY = CQ*DTG + CFLXYMAX = MAX(VLCFLX,VLCFLY,CFLXYMAX) + END DO + END DO - RETURN -!/ -!/ End of W3XYCFL ----------------------------------------------------- / -!/ - END SUBROUTINE W3CFLXY + RETURN + !/ + !/ End of W3XYCFL ----------------------------------------------------- / + !/ + END SUBROUTINE W3CFLXY -!/ -!/ End of module W3PRO3MD -------------------------------------------- / -!/ - END MODULE W3PRO3MD + !/ + !/ End of module W3PRO3MD -------------------------------------------- / + !/ +END MODULE W3PRO3MD diff --git a/model/src/w3profsmd.F90 b/model/src/w3profsmd.F90 index 71e2cdc09..ed61eb1c1 100644 --- a/model/src/w3profsmd.F90 +++ b/model/src/w3profsmd.F90 @@ -1,419 +1,419 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3PROFSMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Aron Roland | -!/ | Fabrice Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-Apr-2020 | -!/ +-----------------------------------+ -!/ -!/ XX-Nov-2007 : Origination. ( version 3.10 ) -!/ 03-Nov-2011 : Adding shoreline reflection ( version 4.04 ) -!/ 03-Jun-2013 : Removed assign statements ( version 4.10 ) -!/ 20-Jun-2013 : Update test output for time steps ( version 4.10 ) -!/ 17-Oct-2013 : Removes boundary nodes from CFL ( version 4.12 ) -!/ 15-Dec-2013 : Bug fix for implicit scheme ( version 4.16 ) -!/ 18-Aug-2016 : Corrected boundary treatment ( version 4.16 ) -!/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) -! -! 1. Purpose : -! -! Propagation schemes for unstructured grids using fluctuation splitting -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3XYPUG Subr. Public Generic fluctuation splitting operations -! W3XYPFSN2 Subr. Public advection with N scheme (Csik et al. 2002) -! W3XYPFSPSI Subr. Public advection with FCT scheme -! W3XYPFSFCT2 Subr. Public advection with FCT scheme -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 5. Remarks : -! For a detailed description of the schemes and their properties, see -! Roland (2008), Ph.D. Thesis, T. U. Darmstadt. -! -! 6. Switches : -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3XYPUG ( ISP, FACX, FACY, DTG, VQ, VGX, VGY, LCALC ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Aron Roland | -!/ | FORTRAN 90 | -!/ | Last update : 10-Jan-2011 | -!/ +-----------------------------------+ -!/ -!/ 10-Jan-2008 : Origination. ( version 3.13 ) -!/ 10-Jan-2011 : Addition of implicit scheme ( version 3.14.4 ) -!/ -! 1. Purpose : -! -! Propagation in physical space for a given spectral component. -! Gives the choice of scheme on unstructured grid -! -! 2. Method : -! -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH -! FACX/Y Real I Factor in propagation velocity. -! ( 1 or 0 * DT / DX ) -! DTG Real I Total time step. -! VQ R.A. I/O Field to propagate. -! VGX/Y Real I Speed of grid. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! VCFL0X R.A. Local courant numbers for absolute group vel. -! using local X-grid step. -! VCFL0Y R.A. Id. in Y. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! +MODULE W3PROFSMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Aron Roland | + !/ | Fabrice Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-Apr-2020 | + !/ +-----------------------------------+ + !/ + !/ XX-Nov-2007 : Origination. ( version 3.10 ) + !/ 03-Nov-2011 : Adding shoreline reflection ( version 4.04 ) + !/ 03-Jun-2013 : Removed assign statements ( version 4.10 ) + !/ 20-Jun-2013 : Update test output for time steps ( version 4.10 ) + !/ 17-Oct-2013 : Removes boundary nodes from CFL ( version 4.12 ) + !/ 15-Dec-2013 : Bug fix for implicit scheme ( version 4.16 ) + !/ 18-Aug-2016 : Corrected boundary treatment ( version 4.16 ) + !/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) + ! + ! 1. Purpose : + ! + ! Propagation schemes for unstructured grids using fluctuation splitting + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3XYPUG Subr. Public Generic fluctuation splitting operations + ! W3XYPFSN2 Subr. Public advection with N scheme (Csik et al. 2002) + ! W3XYPFSPSI Subr. Public advection with FCT scheme + ! W3XYPFSFCT2 Subr. Public advection with FCT scheme + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! For a detailed description of the schemes and their properties, see + ! Roland (2008), Ph.D. Thesis, T. U. Darmstadt. + ! + ! 6. Switches : + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3XYPUG ( ISP, FACX, FACY, DTG, VQ, VGX, VGY, LCALC ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Aron Roland | + !/ | FORTRAN 90 | + !/ | Last update : 10-Jan-2011 | + !/ +-----------------------------------+ + !/ + !/ 10-Jan-2008 : Origination. ( version 3.13 ) + !/ 10-Jan-2011 : Addition of implicit scheme ( version 3.14.4 ) + !/ + ! 1. Purpose : + ! + ! Propagation in physical space for a given spectral component. + ! Gives the choice of scheme on unstructured grid + ! + ! 2. Method : + ! + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH + ! FACX/Y Real I Factor in propagation velocity. + ! ( 1 or 0 * DT / DX ) + ! DTG Real I Total time step. + ! VQ R.A. I/O Field to propagate. + ! VGX/Y Real I Speed of grid. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! VCFL0X R.A. Local courant numbers for absolute group vel. + ! using local X-grid step. + ! VCFL0Y R.A. Id. in Y. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! -! 5. Called by : -! -! W3WAVE Wave model routine. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! make the interface between the WAVEWATCH and the WWM code. -! -! 8. Structure : -! -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! -! 10. Source code : -!/ ------------------------------------------------------------------- / -!/ -! - USE CONSTANTS -! - USE W3TIMEMD, ONLY: DSEC21 -! - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, MAPFS, DTCFL, CLATS, & - FLCX, FLCY, NK, NTH, DTH, XFR, & - ECOS, ESIN, SIG, PFMOVE,IEN, & - NTRI, TRIGP, CCON , & - IE_CELL, POS_CELL, IOBP, IOBPD, IOBDP, & - FSN, FSPSI, FSFCT, FSNIMP, GTYPE, UNGTYPE - - USE W3WDATMD, ONLY: TIME - USE W3ODATMD, ONLY: TBPI0, TBPIN, FLBPI - USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, ITIME, CFLXYMAX, DW - USE W3IDATMD, ONLY: FLCUR -! USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & -! ISBPI, BBPI0, BBPIN + ! 5. Called by : + ! + ! W3WAVE Wave model routine. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! make the interface between the WAVEWATCH and the WWM code. + ! + ! 8. Structure : + ! + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + !/ + ! + USE CONSTANTS + ! + USE W3TIMEMD, ONLY: DSEC21 + ! + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, MAPFS, DTCFL, CLATS, & + FLCX, FLCY, NK, NTH, DTH, XFR, & + ECOS, ESIN, SIG, PFMOVE,IEN, & + NTRI, TRIGP, CCON , & + IE_CELL, POS_CELL, IOBP, IOBPD, IOBDP, & + FSN, FSPSI, FSFCT, FSNIMP, GTYPE, UNGTYPE + + USE W3WDATMD, ONLY: TIME + USE W3ODATMD, ONLY: TBPI0, TBPIN, FLBPI + USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, ITIME, CFLXYMAX, DW + USE W3IDATMD, ONLY: FLCUR + ! USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & + ! ISBPI, BBPI0, BBPIN #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISP - REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY - REAL, INTENT(INOUT) :: VQ(1-NY:NY*(NX+2)) - LOGICAL, INTENT(IN) :: LCALC -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK, ISEA, IXY - INTEGER :: IX + + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISP + REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY + REAL, INTENT(INOUT) :: VQ(1-NY:NY*(NX+2)) + LOGICAL, INTENT(IN) :: LCALC + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK, ISEA, IXY + INTEGER :: IX #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: CCOS, CSIN, CCURX, CCURY - REAL :: C(NX,2) - REAL :: RD1, RD2 -!/ -!/ Automatic work arrays -!/ - REAL :: VLCFLX((NX+1)*NY), VLCFLY(NX*NY) - DOUBLE PRECISION :: AC(NX) -!/ ------------------------------------------------------------------- / -! -! 1. Preparations --------------------------------------------------- * -! 1.a Set constants -! - + REAL :: CCOS, CSIN, CCURX, CCURY + REAL :: C(NX,2) + REAL :: RD1, RD2 + !/ + !/ Automatic work arrays + !/ + REAL :: VLCFLX((NX+1)*NY), VLCFLY(NX*NY) + DOUBLE PRECISION :: AC(NX) + !/ ------------------------------------------------------------------- / + ! + ! 1. Preparations --------------------------------------------------- * + ! 1.a Set constants + ! + #ifdef W3_S - CALL STRACE (IENT, 'W3XYPUG') + CALL STRACE (IENT, 'W3XYPUG') #endif - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - - CCOS = FACX * ECOS(ITH) - CSIN = FACY * ESIN(ITH) - CCURX = FACX - CCURY = FACY -! -! 1.b Initialize arrays -! - VLCFLX = 0. - VLCFLY = 0. -! -! 1.c Set depth -! - CALL SETDEPTH -! -! -! 2. Calculate velocities ---------------- * -! - DO ISEA = 1, NSEA - IXY = MAPSF(ISEA,3) - VQ(IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) - VLCFLX(IXY) = CCOS * CG(IK,ISEA) / CLATS(ISEA) - VLCFLY(IXY) = CSIN * CG(IK,ISEA) + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + + CCOS = FACX * ECOS(ITH) + CSIN = FACY * ESIN(ITH) + CCURX = FACX + CCURY = FACY + ! + ! 1.b Initialize arrays + ! + VLCFLX = 0. + VLCFLY = 0. + ! + ! 1.c Set depth + ! + CALL SETDEPTH + ! + ! + ! 2. Calculate velocities ---------------- * + ! + DO ISEA = 1, NSEA + IXY = MAPSF(ISEA,3) + VQ(IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) + VLCFLX(IXY) = CCOS * CG(IK,ISEA) / CLATS(ISEA) + VLCFLY(IXY) = CSIN * CG(IK,ISEA) #ifdef W3_MGP - VLCFLX(IXY) = VLCFLX(IXY) - CCURX*VGX/CLATS(ISEA) - VLCFLY(IXY) = VLCFLY(IXY) - CCURY*VGY + VLCFLX(IXY) = VLCFLX(IXY) - CCURX*VGX/CLATS(ISEA) + VLCFLY(IXY) = VLCFLY(IXY) - CCURY*VGY #endif - END DO - - IF ( FLCUR ) THEN - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) -! -! Currents are not included on coastal boundaries (IOBP(IXY).EQ.0) -! - IF (IOBP(IXY) .EQ. 1) THEN - VLCFLX(IXY) = VLCFLX(IXY) + CCURX*CX(ISEA)/CLATS(ISEA) - VLCFLY(IXY) = VLCFLY(IXY) + CCURY*CY(ISEA) - END IF - END DO - END IF - -! -! 3. initialize fluctuation splitting arrays ( to fit with WWM notations) -! - AC(1:NX) = DBLE(VQ(1:NX)) * IOBDP(1:NX) - C(1:NX,1) = VLCFLX(1:NX) * IOBDP(1:NX) - C(1:NX,2) = VLCFLY(1:NX) * IOBDP(1:NX) + END DO -! -! 4. Prepares boundary update -! - IF ( FLBPI ) THEN - RD1 = DSEC21 ( TBPI0, TIME ) - RD2 = DSEC21 ( TBPI0, TBPIN ) - ELSE - RD1=1. - RD2=0. - END IF -! -! 4. propagate using the selected scheme -! - IF (FSN) THEN - CALL W3XYPFSN2 (ISP, C, LCALC, RD1, RD2, DTG, AC) - ELSE IF (FSPSI) THEN - CALL W3XYPFSPSI2 (ISP, C, LCALC, RD1, RD2, DTG, AC) - ELSE IF (FSFCT) THEN - CALL W3XYPFSFCT2 (ISP, C, LCALC, RD1, RD2, DTG, AC) - ELSE IF (FSNIMP) THEN - CALL W3XYPFSNIMP(ISP, C, LCALC, RD1, RD2, DTG, AC) - ENDIF -! - DO IX=1,NX - ISEA=MAPFS(1,IX) - VQ(IX)=REAL(AC(IX)) - ENDDO - -! 6. Store results in VQ in proper format --------------------------- * -! + IF ( FLCUR ) THEN DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) + IXY = MAPSF(ISEA,3) + ! + ! Currents are not included on coastal boundaries (IOBP(IXY).EQ.0) + ! + IF (IOBP(IXY) .EQ. 1) THEN + VLCFLX(IXY) = VLCFLX(IXY) + CCURX*CX(ISEA)/CLATS(ISEA) + VLCFLY(IXY) = VLCFLY(IXY) + CCURY*CY(ISEA) + END IF END DO - END SUBROUTINE W3XYPUG -!/ ------------------------------------------------------------------- / - SUBROUTINE W3CFLUG ( ISEA, NKCFL, FACX, FACY, DT, MAPFS, CFLXYMAX, & - VGX, VGY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Fabrice Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jun-2013 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2011 : Origination. ( version 3.14 ) -!/ 20-Jun-2013 : Computes only up to NKCFL for tests ( version 4.10 ) -!/ 1-Jun-2017 : Rewrite routine for performance ( version 5.xx ) -!/ -! 1. Purpose : -! -! Computes the max CFL number for output purposes -! -! 2. Method : -! -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISEA Int. I Index of sea point -! NKCFL Int. I Maximum frequency index -! FACX/Y Real I Factor in propagation velocity. -! ( 1 or 0 * DT / DX ) -! DT Real I Time step. -! MAPFS I.A. I Storage map. -! CFLXYMAX Real Maxmimum CFL for spatial advection -! VGX/Y Real I Speed of grid. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! VCFL0X R.A. Local courant numbers for absolute group vel. -! using local X-grid step. -! VCFL0Y R.A. Id. in Y. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! + END IF -! 5. Called by : -! -! W3WAVE Wave model routine. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! make the interface between the WAVEWATCH and the WWM code. -! -! 8. Structure : -! -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! -! 10. Source code : -!/ ------------------------------------------------------------------- / -!/ -! - USE CONSTANTS -! - USE W3TIMEMD, ONLY: DSEC21 -! - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, DTCFL, CLATS, & - FLCX, FLCY, NK, NTH, DTH, XFR, & - ECOS, ESIN, SIG, PFMOVE,IEN, INDEX_CELL, & - NTRI, TRIGP, CCON , & - IE_CELL, POS_CELL, COUNTRI, SI, IOBP - - USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, ITIME, DW - USE W3IDATMD, ONLY: FLCUR + ! + ! 3. initialize fluctuation splitting arrays ( to fit with WWM notations) + ! + AC(1:NX) = DBLE(VQ(1:NX)) * IOBDP(1:NX) + C(1:NX,1) = VLCFLX(1:NX) * IOBDP(1:NX) + C(1:NX,2) = VLCFLY(1:NX) * IOBDP(1:NX) + + ! + ! 4. Prepares boundary update + ! + IF ( FLBPI ) THEN + RD1 = DSEC21 ( TBPI0, TIME ) + RD2 = DSEC21 ( TBPI0, TBPIN ) + ELSE + RD1=1. + RD2=0. + END IF + ! + ! 4. propagate using the selected scheme + ! + IF (FSN) THEN + CALL W3XYPFSN2 (ISP, C, LCALC, RD1, RD2, DTG, AC) + ELSE IF (FSPSI) THEN + CALL W3XYPFSPSI2 (ISP, C, LCALC, RD1, RD2, DTG, AC) + ELSE IF (FSFCT) THEN + CALL W3XYPFSFCT2 (ISP, C, LCALC, RD1, RD2, DTG, AC) + ELSE IF (FSNIMP) THEN + CALL W3XYPFSNIMP(ISP, C, LCALC, RD1, RD2, DTG, AC) + ENDIF + ! + DO IX=1,NX + ISEA=MAPFS(1,IX) + VQ(IX)=REAL(AC(IX)) + ENDDO + + ! 6. Store results in VQ in proper format --------------------------- * + ! + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) + END DO + END SUBROUTINE W3XYPUG + !/ ------------------------------------------------------------------- / + SUBROUTINE W3CFLUG ( ISEA, NKCFL, FACX, FACY, DT, MAPFS, CFLXYMAX, & + VGX, VGY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Fabrice Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jun-2013 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2011 : Origination. ( version 3.14 ) + !/ 20-Jun-2013 : Computes only up to NKCFL for tests ( version 4.10 ) + !/ 1-Jun-2017 : Rewrite routine for performance ( version 5.xx ) + !/ + ! 1. Purpose : + ! + ! Computes the max CFL number for output purposes + ! + ! 2. Method : + ! + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISEA Int. I Index of sea point + ! NKCFL Int. I Maximum frequency index + ! FACX/Y Real I Factor in propagation velocity. + ! ( 1 or 0 * DT / DX ) + ! DT Real I Time step. + ! MAPFS I.A. I Storage map. + ! CFLXYMAX Real Maxmimum CFL for spatial advection + ! VGX/Y Real I Speed of grid. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! VCFL0X R.A. Local courant numbers for absolute group vel. + ! using local X-grid step. + ! VCFL0Y R.A. Id. in Y. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + + ! 5. Called by : + ! + ! W3WAVE Wave model routine. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! make the interface between the WAVEWATCH and the WWM code. + ! + ! 8. Structure : + ! + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + !/ + ! + USE CONSTANTS + ! + USE W3TIMEMD, ONLY: DSEC21 + ! + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, DTCFL, CLATS, & + FLCX, FLCY, NK, NTH, DTH, XFR, & + ECOS, ESIN, SIG, PFMOVE,IEN, INDEX_CELL, & + NTRI, TRIGP, CCON , & + IE_CELL, POS_CELL, COUNTRI, SI, IOBP + + USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, ITIME, DW + USE W3IDATMD, ONLY: FLCUR #ifdef W3_T - USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & - ISBPI, BBPI0, BBPIN + USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & + ISBPI, BBPI0, BBPIN #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISEA, NKCFL, MAPFS(NY*NX) - REAL, INTENT(IN) :: FACX, FACY, DT, VGX, VGY - REAL, INTENT(INOUT) :: CFLXYMAX -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK - INTEGER :: IP, IP2, ISEA2, I, J, IE, IV, I1, I2, I3 + + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISEA, NKCFL, MAPFS(NY*NX) + REAL, INTENT(IN) :: FACX, FACY, DT, VGX, VGY + REAL, INTENT(INOUT) :: CFLXYMAX + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK + INTEGER :: IP, IP2, ISEA2, I, J, IE, IV, I1, I2, I3 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: CCOS, CSIN, CCURX, CCURY - REAL :: C(NX,2) - REAL*8 :: KELEM(3), KTMP(3), LAMBDA(2) - REAL*8 :: KKSUM, DTMAXEXP -!/ -!/ Velocities -!/ - REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 - REAL*8, PARAMETER :: THR8 = TINY(1.0d0) - REAL, PARAMETER :: THR = TINY(1.0) - -!/ ------------------------------------------------------------------- / -! -! 1. Preparations --------------------------------------------------- * -! 1.a Set constants -! - + REAL :: CCOS, CSIN, CCURX, CCURY + REAL :: C(NX,2) + REAL*8 :: KELEM(3), KTMP(3), LAMBDA(2) + REAL*8 :: KKSUM, DTMAXEXP + !/ + !/ Velocities + !/ + REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 + REAL*8, PARAMETER :: THR8 = TINY(1.0d0) + REAL, PARAMETER :: THR = TINY(1.0) + + !/ ------------------------------------------------------------------- / + ! + ! 1. Preparations --------------------------------------------------- * + ! 1.a Set constants + ! + #ifdef W3_S - CALL STRACE (IENT, 'W3CFLUG') + CALL STRACE (IENT, 'W3CFLUG') #endif - CFLXYMAX=1E-10 - IP = MAPSF(ISEA,3) -! -! CFL no important on boundary -! - IF (IOBP(IP).EQ.1) THEN - CCURX = FACX - CCURY = FACY -! -! Loop over spectral components -! + CFLXYMAX=1E-10 + IP = MAPSF(ISEA,3) + ! + ! CFL no important on boundary + ! + IF (IOBP(IP).EQ.1) THEN + CCURX = FACX + CCURY = FACY + ! + ! Loop over spectral components + ! DO IK=1,NKCFL DO ITH=1,NTH - CCOS = FACX * ECOS(ITH) - CSIN = FACY * ESIN(ITH) + CCOS = FACX * ECOS(ITH) + CSIN = FACY * ESIN(ITH) C(:,:)=0. -! -! 2. Calculate advection velocities: group speed ---------------- * -! -!AR: needs to be rewritten for speed ... single node computation is costly ... -!MA: you are right but now it is only called if CFX and UNST for CFL profiling + ! + ! 2. Calculate advection velocities: group speed ---------------- * + ! + !AR: needs to be rewritten for speed ... single node computation is costly ... + !MA: you are right but now it is only called if CFX and UNST for CFL profiling DO I = INDEX_CELL(IP), INDEX_CELL(IP+1)-1 IE=IE_CELL(I) ! TRIGP(IV,IE)=IP with IV=POS_CELL(I) @@ -426,1243 +426,1243 @@ SUBROUTINE W3CFLUG ( ISEA, NKCFL, FACX, FACY, DT, MAPFS, CFLXYMAX, & C(IP2,1) = C(IP2,1) - CCURX*VGX/CLATS(ISEA2) C(IP2,2) = C(IP2,2) - CCURY*VGY #endif - IF ( FLCUR ) THEN - IF (IOBP(IP2) .EQ. 1) THEN + IF ( FLCUR ) THEN + IF (IOBP(IP2) .EQ. 1) THEN C(IP2,1) = C(IP2,1) + CCURX*CX(ISEA2)/CLATS(ISEA2) C(IP2,2) = C(IP2,2) + CCURY*CY(ISEA2) - END IF - END IF ! end of ( FLCUR ) - END DO + END IF + END IF ! end of ( FLCUR ) END DO -! -!3. Calculate K-Values and contour based quantities ... -! + END DO + ! + !3. Calculate K-Values and contour based quantities ... + ! KKSUM = 0.d0 DO I = INDEX_CELL(IP), INDEX_CELL(IP+1)-1 - IE=IE_CELL(I) ! TRIGP(IV,IE)=IP + IE=IE_CELL(I) ! TRIGP(IV,IE)=IP IV=POS_CELL(I) - I1 = TRIGP(1,IE) + I1 = TRIGP(1,IE) I2 = TRIGP(2,IE) I3 = TRIGP(3,IE) LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Advection speed in X direction LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) ! Advection speed in Y direction - KELEM(1) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians - KELEM(2) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) ! K-Values - so called Flux Jacobians - KELEM(3) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) ! K-Values - so called Flux Jacobians + KELEM(1) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians + KELEM(2) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) ! K-Values - so called Flux Jacobians + KELEM(3) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) ! K-Values - so called Flux Jacobians KTMP = KELEM ! Copy KELEM = MAX(0.d0,KTMP) KKSUM = KKSUM + KELEM(IV) - END DO ! COUNTRI -! + END DO ! COUNTRI + ! DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM) CFLXYMAX = MAX(DBLE(DT)/DTMAXEXP,DBLE(CFLXYMAX)) - END DO END DO - END IF -! - RETURN - END SUBROUTINE W3CFLUG -!/ ------------------------------------------------------------------- / + END DO + END IF + ! + RETURN + END SUBROUTINE W3CFLUG + !/ ------------------------------------------------------------------- / - SUBROUTINE W3XYPFSN2 ( ISP, C, LCALC, RD10, RD20, DT, AC) - -!/ -!/ -!/ +-----------------------------------+ -!/ | WWIII Version of the WWM FS Code | -!/ | by Aron Roland | -!/ | and Fabrice Ardhuin | -!/ | for use in WWIII | -!/ | GPL License | -!/ | Last update : 15-Apr-2020 | -!/ +-----------------------------------+ -!/ -!/ 19-Dec-2007 : Origination. ( version 3.13 ) -!/ 25-Aug-2011 : Change of method for IOBPD ( version 4.04 ) -!/ 03-Nov-2011 : Addition of shoreline reflection ( version 4.04 ) -!/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) -!/ -!/ -! 1. Purpose : -! Advection of a scalar in a arbitary velocity field on unstructured meshes -! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space -! This is the standard explicit N-Scheme from Roe as formulated in Abgrall -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Subroutine tracing (!/S switch) -! -! 5. Called by : -! -! W3XYPUG Routine for advection on unstructured grid -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & - IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBP, IOBDP, & - IOBPA, FSBCCFL + SUBROUTINE W3XYPFSN2 ( ISP, C, LCALC, RD10, RD20, DT, AC) + + !/ + !/ + !/ +-----------------------------------+ + !/ | WWIII Version of the WWM FS Code | + !/ | by Aron Roland | + !/ | and Fabrice Ardhuin | + !/ | for use in WWIII | + !/ | GPL License | + !/ | Last update : 15-Apr-2020 | + !/ +-----------------------------------+ + !/ + !/ 19-Dec-2007 : Origination. ( version 3.13 ) + !/ 25-Aug-2011 : Change of method for IOBPD ( version 4.04 ) + !/ 03-Nov-2011 : Addition of shoreline reflection ( version 4.04 ) + !/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) + !/ + !/ + ! 1. Purpose : + ! Advection of a scalar in a arbitary velocity field on unstructured meshes + ! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space + ! This is the standard explicit N-Scheme from Roe as formulated in Abgrall + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Subroutine tracing (!/S switch) + ! + ! 5. Called by : + ! + ! W3XYPUG Routine for advection on unstructured grid + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & + IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBP, IOBDP, & + IOBPA, FSBCCFL #ifdef W3_REF1 - USE W3GDATMD, ONLY : REFPARS + USE W3GDATMD, ONLY : REFPARS #endif - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: CG, ITER, DW - USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN - USE W3TIMEMD, ONLY: DSEC21 + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: CG, ITER, DW + USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN + USE W3TIMEMD, ONLY: DSEC21 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE - - INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction - REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the given velocity field - REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, - DOUBLE PRECISION, INTENT(INOUT):: AC(:) ! Wave Action before and after advection - REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary conditions - LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction + REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the given velocity field + REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, + DOUBLE PRECISION, INTENT(INOUT):: AC(:) ! Wave Action before and after advection + REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary conditions + LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 - REAL*8, PARAMETER :: THR8 = TINY(1.0d0) - REAL, PARAMETER :: THR = TINY(1.0) -!/ -!/ ------------------------------------------------------------------- / -!/ -! -! local integer -! - INTEGER :: IP, IE, IT, I1, I2, I3, ITH, IK - INTEGER :: IBI, NI(3) -! -! local real -! - REAL :: RD1, RD2 -! -! local double -! - REAL*8 :: UTILDE, BOUNDARY_FORCING - REAL*8 :: CFLXY - REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 - REAL*8 :: FL111, FL112, FL211, FL212, FL311, FL312 - REAL*8 :: DTSI(NX), U(NX) - REAL*8 :: DTMAXGL, DTMAXEXP, REST - REAL*8 :: LAMBDA(2), KTMP(3), CLOC(2,3) - REAL*8 :: KELEM(3,NTRI), FLALL(3,NTRI) - REAL*8 :: KKSUM(NX), ST(NX) - REAL*8 :: NM(NTRI) + REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 + REAL*8, PARAMETER :: THR8 = TINY(1.0d0) + REAL, PARAMETER :: THR = TINY(1.0) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + ! local integer + ! + INTEGER :: IP, IE, IT, I1, I2, I3, ITH, IK + INTEGER :: IBI, NI(3) + ! + ! local real + ! + REAL :: RD1, RD2 + ! + ! local double + ! + REAL*8 :: UTILDE, BOUNDARY_FORCING + REAL*8 :: CFLXY + REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 + REAL*8 :: FL111, FL112, FL211, FL212, FL311, FL312 + REAL*8 :: DTSI(NX), U(NX) + REAL*8 :: DTMAXGL, DTMAXEXP, REST + REAL*8 :: LAMBDA(2), KTMP(3), CLOC(2,3) + REAL*8 :: KELEM(3,NTRI), FLALL(3,NTRI) + REAL*8 :: KKSUM(NX), ST(NX) + REAL*8 :: NM(NTRI) #ifdef W3_S - CALL STRACE (IENT, 'W3XYPFSN') + CALL STRACE (IENT, 'W3XYPFSN') #endif -! 1. initialisation + ! 1. initialisation - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - DTMAXGL = DBLE(10.E10) -! -!2 Propagation -!2.a Calculate K-Values and contour based quantities ... -! - DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... - - I1 = TRIGP(1,IE) ! Index of the Element Nodes (TRIGP) - I2 = TRIGP(2,IE) - I3 = TRIGP(3,IE) - NI = TRIGP(:,IE) - LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction - LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) - KELEM(1,IE) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians - KELEM(2,IE) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) - KELEM(3,IE) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) -! - KTMP = KELEM(:,IE) ! Copy - NM(IE) = - 1.D0/MIN(-THR8,SUM(MIN(0.d0,KTMP))) ! N-Values - KELEM(:,IE) = MAX(0.d0,KTMP) - FL11 = C(I2,1) * IEN(IE,1) + C(I2,2) * IEN(IE,2) ! Weights for Simpson Integration - FL12 = C(I3,1) * IEN(IE,1) + C(I3,2) * IEN(IE,2) - FL21 = C(I3,1) * IEN(IE,3) + C(I3,2) * IEN(IE,4) - FL22 = C(I1,1) * IEN(IE,3) + C(I1,2) * IEN(IE,4) - FL31 = C(I1,1) * IEN(IE,5) + C(I1,2) * IEN(IE,6) - FL32 = C(I2,1) * IEN(IE,5) + C(I2,2) * IEN(IE,6) - FL111 = 2.d0*FL11+FL12 - FL112 = 2.d0*FL12+FL11 - FL211 = 2.d0*FL21+FL22 - FL212 = 2.d0*FL22+FL21 - FL311 = 2.d0*FL31+FL32 - FL312 = 2.d0*FL32+FL31 - FLALL(1,IE) = (FL311 + FL212) * ONESIXTH + KELEM(1,IE) - FLALL(2,IE) = (FL111 + FL312) * ONESIXTH + KELEM(2,IE) - FLALL(3,IE) = (FL211 + FL112) * ONESIXTH + KELEM(3,IE) - ! IF (I1.EQ.1.OR.I2.EQ.1.OR.I3.EQ.1) WRITE(6,*) 'TEST N1 :',IK,ITH,IP,IE,KELEM(:,IE),'##',LAMBDA - END DO ! NTRI - - IF (LCALC) THEN ! If the current field or water level changes estimate the iteration number based on the new flow field and the CFL number of the scheme - KKSUM = 0.d0 - DO IE = 1, NTRI - NI = TRIGP(:,IE) - KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) - END DO ! IE - DTMAXEXP = 1E10 ! initialize to large number - DO IP = 1, NX - IF (IOBP(IP) .EQ. 1 .OR. FSBCCFL) THEN - DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP(IP)) - DTMAXGL = MIN( DTMAXGL, DTMAXEXP) - END IF - END DO ! IP - CFLXY = DBLE(DT)/DTMAXGL - REST = ABS(MOD(CFLXY,1.0d0)) - IF (REST .LT. THR8) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) - ELSE IF (REST .GT. THR8 .AND. REST .LT. 0.5d0) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 - ELSE - ITER(IK,ITH) = ABS(NINT(CFLXY)) - END IF - END IF ! LCALC - - DO IP = 1, NX - DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/SI(IP) ! Some precalculations for the time integration. - END DO - - DO IT = 1, ITER(IK,ITH) - U = AC - ST = 0.d0 - DO IE = 1, NTRI - NI = TRIGP(:,IE) - UTILDE = NM(IE) * (DOT_PRODUCT(FLALL(:,IE),U(NI))) - ST(NI) = ST(NI) + KELEM(:,IE) * (U(NI) - UTILDE) ! the 2nd term are the theta values of each node ... - END DO ! IE - - DO IP = 1, NX -! -! IOBPD=0 : waves coming from land (or outside grid) -! Possibly set flux to zero by multiplying ST by IOBPD but also in UTILDE multiply U(NI) by IOBPD ... -! - U(IP) = MAX(0.d0,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA(IP)))*DBLE(IOBPD(ITH,IP)) + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + DTMAXGL = DBLE(10.E10) + ! + !2 Propagation + !2.a Calculate K-Values and contour based quantities ... + ! + DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... + + I1 = TRIGP(1,IE) ! Index of the Element Nodes (TRIGP) + I2 = TRIGP(2,IE) + I3 = TRIGP(3,IE) + NI = TRIGP(:,IE) + LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction + LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) + KELEM(1,IE) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians + KELEM(2,IE) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) + KELEM(3,IE) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) + ! + KTMP = KELEM(:,IE) ! Copy + NM(IE) = - 1.D0/MIN(-THR8,SUM(MIN(0.d0,KTMP))) ! N-Values + KELEM(:,IE) = MAX(0.d0,KTMP) + FL11 = C(I2,1) * IEN(IE,1) + C(I2,2) * IEN(IE,2) ! Weights for Simpson Integration + FL12 = C(I3,1) * IEN(IE,1) + C(I3,2) * IEN(IE,2) + FL21 = C(I3,1) * IEN(IE,3) + C(I3,2) * IEN(IE,4) + FL22 = C(I1,1) * IEN(IE,3) + C(I1,2) * IEN(IE,4) + FL31 = C(I1,1) * IEN(IE,5) + C(I1,2) * IEN(IE,6) + FL32 = C(I2,1) * IEN(IE,5) + C(I2,2) * IEN(IE,6) + FL111 = 2.d0*FL11+FL12 + FL112 = 2.d0*FL12+FL11 + FL211 = 2.d0*FL21+FL22 + FL212 = 2.d0*FL22+FL21 + FL311 = 2.d0*FL31+FL32 + FL312 = 2.d0*FL32+FL31 + FLALL(1,IE) = (FL311 + FL212) * ONESIXTH + KELEM(1,IE) + FLALL(2,IE) = (FL111 + FL312) * ONESIXTH + KELEM(2,IE) + FLALL(3,IE) = (FL211 + FL112) * ONESIXTH + KELEM(3,IE) + ! IF (I1.EQ.1.OR.I2.EQ.1.OR.I3.EQ.1) WRITE(6,*) 'TEST N1 :',IK,ITH,IP,IE,KELEM(:,IE),'##',LAMBDA + END DO ! NTRI + + IF (LCALC) THEN ! If the current field or water level changes estimate the iteration number based on the new flow field and the CFL number of the scheme + KKSUM = 0.d0 + DO IE = 1, NTRI + NI = TRIGP(:,IE) + KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) + END DO ! IE + DTMAXEXP = 1E10 ! initialize to large number + DO IP = 1, NX + IF (IOBP(IP) .EQ. 1 .OR. FSBCCFL) THEN + DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP(IP)) + DTMAXGL = MIN( DTMAXGL, DTMAXEXP) + END IF + END DO ! IP + CFLXY = DBLE(DT)/DTMAXGL + REST = ABS(MOD(CFLXY,1.0d0)) + IF (REST .LT. THR8) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + ELSE IF (REST .GT. THR8 .AND. REST .LT. 0.5d0) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 + ELSE + ITER(IK,ITH) = ABS(NINT(CFLXY)) + END IF + END IF ! LCALC + + DO IP = 1, NX + DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/SI(IP) ! Some precalculations for the time integration. + END DO + + DO IT = 1, ITER(IK,ITH) + U = AC + ST = 0.d0 + DO IE = 1, NTRI + NI = TRIGP(:,IE) + UTILDE = NM(IE) * (DOT_PRODUCT(FLALL(:,IE),U(NI))) + ST(NI) = ST(NI) + KELEM(:,IE) * (U(NI) - UTILDE) ! the 2nd term are the theta values of each node ... + END DO ! IE + + DO IP = 1, NX + ! + ! IOBPD=0 : waves coming from land (or outside grid) + ! Possibly set flux to zero by multiplying ST by IOBPD but also in UTILDE multiply U(NI) by IOBPD ... + ! + U(IP) = MAX(0.d0,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA(IP)))*DBLE(IOBPD(ITH,IP)) #ifdef W3_REF1 - IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values #endif - END DO -! update spectrum - AC = U -! -! 4 Update boundaries: performs interpolation in time as done in rect grids (e.g. w3pro1md.ftn) -! - IF ( FLBPI ) THEN -! -! 4.1 In this case the boundary is read from the nest.ww3 file -! - RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) - RD2=RD20 - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF -! -! Overwrites only the incoming energy ( IOBPD(ITH,IP) = 0) -! - DO IBI=1, NBI - IP = MAPSF(ISBPI(IBI),1) - AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) - END DO + END DO + ! update spectrum + AC = U + ! + ! 4 Update boundaries: performs interpolation in time as done in rect grids (e.g. w3pro1md.ftn) + ! + IF ( FLBPI ) THEN + ! + ! 4.1 In this case the boundary is read from the nest.ww3 file + ! + RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) + RD2=RD20 + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. + END IF + ! + ! Overwrites only the incoming energy ( IOBPD(ITH,IP) = 0) + ! + DO IBI=1, NBI + IP = MAPSF(ISBPI(IBI),1) + AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) + END DO - ENDIF -! - END DO ! End of loop on time steps -! CALL EXTCDE ( 99 ) -!/ -!/ End of W3XYPFSN ----------------------------------------------------- / -!/ - END SUBROUTINE W3XYPFSN2 - -!/ ------------------------------------------------------------------- / - SUBROUTINE W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) - -!/ -!/ -!/ +-----------------------------------+ -!/ | WWIII Version of the WWM FS Code | -!/ | by Aron Roland | -!/ | for use in WWIII | -!/ | GPL License | -!/ | Last update : 19-Dec-2007 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! Advection of a scalar in a arbitary velocity field on unstructured meshes -! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space -! This is the standard explicit N-Scheme from Roe as formulated in Abgrall -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Subroutine tracing (!/S switch) -! -! 5. Called by : -! -! W3XYPUG Routine for advection on unstructured grid -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & - IEN, TRIGP, CLATS, MAPSF, IOBPA, IOBPD, IOBP, NNZ, IOBDP + ENDIF + ! + END DO ! End of loop on time steps + ! CALL EXTCDE ( 99 ) + !/ + !/ End of W3XYPFSN ----------------------------------------------------- / + !/ + END SUBROUTINE W3XYPFSN2 + + !/ ------------------------------------------------------------------- / + SUBROUTINE W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) + + !/ + !/ + !/ +-----------------------------------+ + !/ | WWIII Version of the WWM FS Code | + !/ | by Aron Roland | + !/ | for use in WWIII | + !/ | GPL License | + !/ | Last update : 19-Dec-2007 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! Advection of a scalar in a arbitary velocity field on unstructured meshes + ! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space + ! This is the standard explicit N-Scheme from Roe as formulated in Abgrall + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Subroutine tracing (!/S switch) + ! + ! 5. Called by : + ! + ! W3XYPUG Routine for advection on unstructured grid + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & + IEN, TRIGP, CLATS, MAPSF, IOBPA, IOBPD, IOBP, NNZ, IOBDP #ifdef W3_REF1 - USE W3GDATMD, ONLY : REFPARS + USE W3GDATMD, ONLY : REFPARS #endif - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: CG, ITER - USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN - USE W3TIMEMD, ONLY: DSEC21 + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: CG, ITER + USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN + USE W3TIMEMD, ONLY: DSEC21 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE - - INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction - REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the given velocity field - REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, - DOUBLE PRECISION,INTENT(INOUT) :: AC(:) ! Wave Action before and after advection - REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary conditions - LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction + REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the given velocity field + REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, + DOUBLE PRECISION,INTENT(INOUT) :: AC(:) ! Wave Action before and after advection + REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary conditions + LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 - REAL*8, PARAMETER :: THR8 = TINY(1.0d0) - REAL, PARAMETER :: THR = TINY(1.0) -!/ -!/ ------------------------------------------------------------------- / -!/ -! -! local integer -! - INTEGER :: IP, IE, IT, I1, I2, I3, ITH, IK - INTEGER :: IBI, NI(3) -! -! local real -! - REAL :: RD1, RD2 -!: -! local double -! - REAL*8 :: UTILDE, BOUNDARY_FORCING - REAL*8 :: FT, CFLXY - REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 - REAL*8 :: FL111, FL112, FL211, FL212, FL311, FL312 - REAL*8 :: DTSI(NX), U(NX) - REAL*8 :: DTMAXGL, DTMAXEXP, REST - REAL*8 :: LAMBDA(2), KTMP(3), TMP(3) - REAL*8 :: THETA_L(3), BET1(3), BETAHAT(3) - REAL*8 :: KELEM(3,NTRI), FLALL(3,NTRI) - REAL*8 :: KKSUM(NX), ST(NX) - REAL*8 :: NM(NTRI) + REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 + REAL*8, PARAMETER :: THR8 = TINY(1.0d0) + REAL, PARAMETER :: THR = TINY(1.0) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + ! local integer + ! + INTEGER :: IP, IE, IT, I1, I2, I3, ITH, IK + INTEGER :: IBI, NI(3) + ! + ! local real + ! + REAL :: RD1, RD2 + !: + ! local double + ! + REAL*8 :: UTILDE, BOUNDARY_FORCING + REAL*8 :: FT, CFLXY + REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 + REAL*8 :: FL111, FL112, FL211, FL212, FL311, FL312 + REAL*8 :: DTSI(NX), U(NX) + REAL*8 :: DTMAXGL, DTMAXEXP, REST + REAL*8 :: LAMBDA(2), KTMP(3), TMP(3) + REAL*8 :: THETA_L(3), BET1(3), BETAHAT(3) + REAL*8 :: KELEM(3,NTRI), FLALL(3,NTRI) + REAL*8 :: KKSUM(NX), ST(NX) + REAL*8 :: NM(NTRI) #ifdef W3_S - CALL STRACE (IENT, 'W3XYPFSN') + CALL STRACE (IENT, 'W3XYPFSN') #endif -! 1. initialisation + ! 1. initialisation - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - DTMAXGL = DBLE(10.E10) -! -!2 Propagation -!2.a Calculate K-Values and contour based quantities ... -! - DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... - I1 = TRIGP(1,IE) ! Index of the Element Nodes (TRIGP) - I2 = TRIGP(2,IE) - I3 = TRIGP(3,IE) - LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction - LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) - KELEM(1,IE) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians - KELEM(2,IE) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) - KELEM(3,IE) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) - KTMP = KELEM(:,IE) ! Copy - NM(IE) = - 1.D0/MIN(-THR8,SUM(MIN(0.d0,KTMP))) ! N-Values - KELEM(:,IE) = MAX(0.d0,KTMP) - FL11 = C(I2,1) * IEN(IE,1) + C(I2,2) * IEN(IE,2) ! Weights for Simpson Integration - FL12 = C(I3,1) * IEN(IE,1) + C(I3,2) * IEN(IE,2) - FL21 = C(I3,1) * IEN(IE,3) + C(I3,2) * IEN(IE,4) - FL22 = C(I1,1) * IEN(IE,3) + C(I1,2) * IEN(IE,4) - FL31 = C(I1,1) * IEN(IE,5) + C(I1,2) * IEN(IE,6) - FL32 = C(I2,1) * IEN(IE,5) + C(I2,2) * IEN(IE,6) - FL111 = 2.d0*FL11+FL12 - FL112 = 2.d0*FL12+FL11 - FL211 = 2.d0*FL21+FL22 - FL212 = 2.d0*FL22+FL21 - FL311 = 2.d0*FL31+FL32 - FL312 = 2.d0*FL32+FL31 - FLALL(1,IE) = (FL311 + FL212)! * ONESIXTH + KELEM(1,IE) - FLALL(2,IE) = (FL111 + FL312)! * ONESIXTH + KELEM(2,IE) - FLALL(3,IE) = (FL211 + FL112)! * ONESIXTH + KELEM(3,IE) - END DO ! NTRI - - IF (LCALC) THEN ! If the current field or water level changes estimate the iteration number based on the new flow field and the CFL number of the scheme - KKSUM = 0.d0 - DO IE = 1, NTRI - NI = TRIGP(:,IE) - KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) - END DO ! IE - DTMAXEXP = 1E10 ! initialize to large number - DO IP = 1, NX - DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP(IP)) - DTMAXGL = MIN( DTMAXGL, DTMAXEXP) - END DO ! IP - CFLXY = DBLE(DT)/DTMAXGL - REST = ABS(MOD(CFLXY,1.0d0)) - IF (REST .LT. THR8) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) - ELSE IF (REST .GT. THR8 .AND. REST .LT. 0.5d0) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 - ELSE - ITER(IK,ITH) = ABS(NINT(CFLXY)) - END IF - END IF ! LCALC - - DO IP = 1, NX - DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/SI(IP) ! Some precalculations for the time integration. - END DO - - DO IT = 1, ITER(IK,ITH) - U = AC - - ST = 0.d0 - - DO IE = 1, NTRI - NI = TRIGP(:,IE) - FT =-ONESIXTH*DOT_PRODUCT(U(NI),FLALL(:,IE)) - UTILDE = NM(IE) * ( DOT_PRODUCT(KELEM(:,IE),U(NI)) - FT ) - THETA_L(:) = KELEM(:,IE) * (U(NI) - UTILDE) - IF (ABS(FT) .GT. 0.0d0) THEN - BET1(:) = THETA_L(:)/FT - IF (ANY( BET1 .LT. 0.0d0) ) THEN - BETAHAT(1) = BET1(1) + 0.5d0 * BET1(2) - BETAHAT(2) = BET1(2) + 0.5d0 * BET1(3) - BETAHAT(3) = BET1(3) + 0.5d0 * BET1(1) - BET1(1) = MAX(0.d0,MIN(BETAHAT(1),1.d0-BETAHAT(2),1.d0)) - BET1(2) = MAX(0.d0,MIN(BETAHAT(2),1.d0-BETAHAT(3),1.d0)) - BET1(3) = MAX(0.d0,MIN(BETAHAT(3),1.d0-BETAHAT(1),1.d0)) - THETA_L(:) = FT * BET1 - END IF - ELSE - THETA_L(:) = 0.d0 - END IF - ST(NI) = ST(NI) + THETA_L ! the 2nd term are the theta values of each node ... - END DO - - DO IP = 1, NX - U(IP) = MAX(0.d0,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA(IP)))*DBLE(IOBPD(ITH,IP)) + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + DTMAXGL = DBLE(10.E10) + ! + !2 Propagation + !2.a Calculate K-Values and contour based quantities ... + ! + DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... + I1 = TRIGP(1,IE) ! Index of the Element Nodes (TRIGP) + I2 = TRIGP(2,IE) + I3 = TRIGP(3,IE) + LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction + LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) + KELEM(1,IE) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians + KELEM(2,IE) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) + KELEM(3,IE) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) + KTMP = KELEM(:,IE) ! Copy + NM(IE) = - 1.D0/MIN(-THR8,SUM(MIN(0.d0,KTMP))) ! N-Values + KELEM(:,IE) = MAX(0.d0,KTMP) + FL11 = C(I2,1) * IEN(IE,1) + C(I2,2) * IEN(IE,2) ! Weights for Simpson Integration + FL12 = C(I3,1) * IEN(IE,1) + C(I3,2) * IEN(IE,2) + FL21 = C(I3,1) * IEN(IE,3) + C(I3,2) * IEN(IE,4) + FL22 = C(I1,1) * IEN(IE,3) + C(I1,2) * IEN(IE,4) + FL31 = C(I1,1) * IEN(IE,5) + C(I1,2) * IEN(IE,6) + FL32 = C(I2,1) * IEN(IE,5) + C(I2,2) * IEN(IE,6) + FL111 = 2.d0*FL11+FL12 + FL112 = 2.d0*FL12+FL11 + FL211 = 2.d0*FL21+FL22 + FL212 = 2.d0*FL22+FL21 + FL311 = 2.d0*FL31+FL32 + FL312 = 2.d0*FL32+FL31 + FLALL(1,IE) = (FL311 + FL212)! * ONESIXTH + KELEM(1,IE) + FLALL(2,IE) = (FL111 + FL312)! * ONESIXTH + KELEM(2,IE) + FLALL(3,IE) = (FL211 + FL112)! * ONESIXTH + KELEM(3,IE) + END DO ! NTRI + + IF (LCALC) THEN ! If the current field or water level changes estimate the iteration number based on the new flow field and the CFL number of the scheme + KKSUM = 0.d0 + DO IE = 1, NTRI + NI = TRIGP(:,IE) + KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) + END DO ! IE + DTMAXEXP = 1E10 ! initialize to large number + DO IP = 1, NX + DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP(IP)) + DTMAXGL = MIN( DTMAXGL, DTMAXEXP) + END DO ! IP + CFLXY = DBLE(DT)/DTMAXGL + REST = ABS(MOD(CFLXY,1.0d0)) + IF (REST .LT. THR8) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + ELSE IF (REST .GT. THR8 .AND. REST .LT. 0.5d0) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 + ELSE + ITER(IK,ITH) = ABS(NINT(CFLXY)) + END IF + END IF ! LCALC + + DO IP = 1, NX + DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/SI(IP) ! Some precalculations for the time integration. + END DO + + DO IT = 1, ITER(IK,ITH) + U = AC + + ST = 0.d0 + + DO IE = 1, NTRI + NI = TRIGP(:,IE) + FT =-ONESIXTH*DOT_PRODUCT(U(NI),FLALL(:,IE)) + UTILDE = NM(IE) * ( DOT_PRODUCT(KELEM(:,IE),U(NI)) - FT ) + THETA_L(:) = KELEM(:,IE) * (U(NI) - UTILDE) + IF (ABS(FT) .GT. 0.0d0) THEN + BET1(:) = THETA_L(:)/FT + IF (ANY( BET1 .LT. 0.0d0) ) THEN + BETAHAT(1) = BET1(1) + 0.5d0 * BET1(2) + BETAHAT(2) = BET1(2) + 0.5d0 * BET1(3) + BETAHAT(3) = BET1(3) + 0.5d0 * BET1(1) + BET1(1) = MAX(0.d0,MIN(BETAHAT(1),1.d0-BETAHAT(2),1.d0)) + BET1(2) = MAX(0.d0,MIN(BETAHAT(2),1.d0-BETAHAT(3),1.d0)) + BET1(3) = MAX(0.d0,MIN(BETAHAT(3),1.d0-BETAHAT(1),1.d0)) + THETA_L(:) = FT * BET1 + END IF + ELSE + THETA_L(:) = 0.d0 + END IF + ST(NI) = ST(NI) + THETA_L ! the 2nd term are the theta values of each node ... + END DO + + DO IP = 1, NX + U(IP) = MAX(0.d0,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA(IP)))*DBLE(IOBPD(ITH,IP)) #ifdef W3_REF1 - IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values #endif - END DO + END DO -! update spectrum - AC = U -! -! 4 Update boundaries: performs interpolation in time as done in rect grids (e.g. w3pro1md.ftn) -! - IF ( FLBPI ) THEN -! -! 4.1 In this case the boundary is read from the nest.ww3 file -! - RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) - RD2=RD20 - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF -! -! Overwrites only the incoming energy ( IOBPD(ITH,IP) = 0) -! - DO IBI=1, NBI - IP = MAPSF(ISBPI(IBI),1) - AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) - END DO + ! update spectrum + AC = U + ! + ! 4 Update boundaries: performs interpolation in time as done in rect grids (e.g. w3pro1md.ftn) + ! + IF ( FLBPI ) THEN + ! + ! 4.1 In this case the boundary is read from the nest.ww3 file + ! + RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) + RD2=RD20 + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. + END IF + ! + ! Overwrites only the incoming energy ( IOBPD(ITH,IP) = 0) + ! + DO IBI=1, NBI + IP = MAPSF(ISBPI(IBI),1) + AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) + END DO - ENDIF -! - END DO ! End of loop on time steps -! CALL EXTCDE ( 99 ) -!/ -!/ End of W3XYPFSN ----------------------------------------------------- / -!/ - END SUBROUTINE W3XYPFSPSI2 - -!/ ------------------------------------------------------------------- / - SUBROUTINE W3XYPFSNIMP ( ISP, C, LCALC, RD10, RD20, DT, AC) - -!/ -!/ -!/ +-----------------------------------+ -!/ | WWIII Version of the WWM FS Code | -!/ | by Aron Roland | -!/ | for use in WWIII | -!/ | GPL License | -!/ | Last update : 15-Dec-2013 | -!/ +-----------------------------------+ -!/ -!/ 15-Dec-2013 : Bug fix for implicit scheme ( version 4.16 ) -!/ -! 1. Purpose : -! Advection of a scalar in a arbitary velocity field on unstructured meshes -! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space -! This is the standard explicit N-Scheme from Roe as formulated in Abgrall -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Subroutine tracing (!/S switch) -! -! 5. Called by : -! -! W3XYPUG Routine for advection on unstructured grid -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & - IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBPA, IOBP, IAA, JAA, POSI, & - TRIA, NNZ + ENDIF + ! + END DO ! End of loop on time steps + ! CALL EXTCDE ( 99 ) + !/ + !/ End of W3XYPFSN ----------------------------------------------------- / + !/ + END SUBROUTINE W3XYPFSPSI2 + + !/ ------------------------------------------------------------------- / + SUBROUTINE W3XYPFSNIMP ( ISP, C, LCALC, RD10, RD20, DT, AC) + + !/ + !/ + !/ +-----------------------------------+ + !/ | WWIII Version of the WWM FS Code | + !/ | by Aron Roland | + !/ | for use in WWIII | + !/ | GPL License | + !/ | Last update : 15-Dec-2013 | + !/ +-----------------------------------+ + !/ + !/ 15-Dec-2013 : Bug fix for implicit scheme ( version 4.16 ) + !/ + ! 1. Purpose : + ! Advection of a scalar in a arbitary velocity field on unstructured meshes + ! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space + ! This is the standard explicit N-Scheme from Roe as formulated in Abgrall + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Subroutine tracing (!/S switch) + ! + ! 5. Called by : + ! + ! W3XYPUG Routine for advection on unstructured grid + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & + IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBPA, IOBP, IAA, JAA, POSI, & + TRIA, NNZ #ifdef W3_REF1 - USE W3GDATMD, ONLY : REFPARS + USE W3GDATMD, ONLY : REFPARS #endif - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: CG, ITER - USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN - USE W3TIMEMD, ONLY: DSEC21 + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: CG, ITER + USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN + USE W3TIMEMD, ONLY: DSEC21 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE - - INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction - REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the given velocity field - REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, - DOUBLE PRECISION,INTENT(INOUT) :: AC(:) ! Wave Action before and after advection - REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary conditions - LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction + REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the given velocity field + REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, + DOUBLE PRECISION,INTENT(INOUT) :: AC(:) ! Wave Action before and after advection + REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary conditions + LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 - REAL*8, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 - REAL*8, PARAMETER :: THR8 = TINY(1.0d0) - REAL, PARAMETER :: THR = TINY(1.0) -!/ -!/ ------------------------------------------------------------------- / -!/ -! -! local integer -! - INTEGER :: IP, IE, POS, I1, I2, I3, I, J, ITH, IK - INTEGER :: IBI -! -! local real -! - REAL :: RD1, RD2 -!: -! local double -! - REAL*8 :: BOUNDARY_FORCING - REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 - REAL*8 :: U(NX) - REAL*8 :: DTMAXGL - REAL*8 :: LAMBDA(2) - REAL*8 :: KP(3,NTRI) - REAL*8 :: K1, DTK, TMP3, KM(3), K(3) - REAL*8 :: NM(NTRI), CRFS(3), DELTAL(3,NTRI) - REAL*8 :: B(NX), X(NX) - REAL*8 :: ASPAR(NNZ) - - INTEGER :: IWKSP( 20*NX ) - INTEGER :: FLJU(NX) - INTEGER :: FLJAU(NNZ+1) - - - INTEGER :: POS_TRICK(3,2) - - INTEGER :: IPAR(16) - INTEGER :: IERROR ! IWK ! ERROR Indicator and Work Array Size, - INTEGER :: JAU(NNZ+1), JU(NX) - - REAL*8 :: FPAR(16) ! DROPTOL - REAL*8 :: WKSP( 8 * NX ) ! REAL WORKSPACES - REAL*8 :: AU(NNZ+1) - REAL*8 :: INIU(NX) - - external bcgstab - - POS_TRICK(1,1) = 2 - POS_TRICK(1,2) = 3 - POS_TRICK(2,1) = 3 - POS_TRICK(2,2) = 1 - POS_TRICK(3,1) = 1 - POS_TRICK(3,2) = 2 + REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 + REAL*8, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 + REAL*8, PARAMETER :: THR8 = TINY(1.0d0) + REAL, PARAMETER :: THR = TINY(1.0) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + ! local integer + ! + INTEGER :: IP, IE, POS, I1, I2, I3, I, J, ITH, IK + INTEGER :: IBI + ! + ! local real + ! + REAL :: RD1, RD2 + !: + ! local double + ! + REAL*8 :: BOUNDARY_FORCING + REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 + REAL*8 :: U(NX) + REAL*8 :: DTMAXGL + REAL*8 :: LAMBDA(2) + REAL*8 :: KP(3,NTRI) + REAL*8 :: K1, DTK, TMP3, KM(3), K(3) + REAL*8 :: NM(NTRI), CRFS(3), DELTAL(3,NTRI) + REAL*8 :: B(NX), X(NX) + REAL*8 :: ASPAR(NNZ) + + INTEGER :: IWKSP( 20*NX ) + INTEGER :: FLJU(NX) + INTEGER :: FLJAU(NNZ+1) + + + INTEGER :: POS_TRICK(3,2) + + INTEGER :: IPAR(16) + INTEGER :: IERROR ! IWK ! ERROR Indicator and Work Array Size, + INTEGER :: JAU(NNZ+1), JU(NX) + + REAL*8 :: FPAR(16) ! DROPTOL + REAL*8 :: WKSP( 8 * NX ) ! REAL WORKSPACES + REAL*8 :: AU(NNZ+1) + REAL*8 :: INIU(NX) + + external bcgstab + + POS_TRICK(1,1) = 2 + POS_TRICK(1,2) = 3 + POS_TRICK(2,1) = 3 + POS_TRICK(2,2) = 1 + POS_TRICK(3,1) = 1 + POS_TRICK(3,2) = 2 #ifdef W3_S - CALL STRACE (IENT, 'W3XYPFSN') + CALL STRACE (IENT, 'W3XYPFSN') #endif -! 1. initialisation + ! 1. initialisation - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - DTMAXGL = DBLE(10.E10) + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + DTMAXGL = DBLE(10.E10) - IF (.FALSE.) THEN - WRITE(*,*) 'NNZ', NNZ - WRITE(*,*) 'MINVAL IAA,JAA', MINVAL(IAA), MINVAL(JAA) - WRITE(*,*) 'MINVAL IAA,JAA', MAXVAL(IAA), MAXVAL(JAA) - WRITE(*,*) 'MAX/MIN POSI', MAXVAL(POSI), MINVAL(POSI) - WRITE(*,*) 'AC, AQ', SUM(AC) - END IF -! -!2 Propagation -!2.a Calculate K-Values and contour based quantities ... -! - DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... - I1 = TRIGP(1,IE) ! Index of the Element Nodes (TRIGP) - I2 = TRIGP(2,IE) - I3 = TRIGP(3,IE) - LAMBDA(1) = ONESIXTH * (C(I1,1)+C(I2,1)+C(I3,1)) - LAMBDA(2) = ONESIXTH * (C(I1,2)+C(I2,2)+C(I3,2)) - K(1) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) - K(2) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) - K(3) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) - KP(1,IE) = MAX(0.d0,K(1)) - KP(2,IE) = MAX(0.d0,K(2)) - KP(3,IE) = MAX(0.d0,K(3)) - KM(1) = MIN(0.d0,K(1)) - KM(2) = MIN(0.d0,K(2)) - KM(3) = MIN(0.d0,K(3)) - FL11 = C(I2,1)*IEN(IE,1)+C(I2,2)*IEN(IE,2) - FL12 = C(I3,1)*IEN(IE,1)+C(I3,2)*IEN(IE,2) - FL21 = C(I3,1)*IEN(IE,3)+C(I3,2)*IEN(IE,4) - FL22 = C(I1,1)*IEN(IE,3)+C(I1,2)*IEN(IE,4) - FL31 = C(I1,1)*IEN(IE,5)+C(I1,2)*IEN(IE,6) - FL32 = C(I2,1)*IEN(IE,5)+C(I2,2)*IEN(IE,6) - CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) - CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) - CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) - DELTAL(:,IE) = CRFS(:)- KP(:,IE) - NM(IE) = 1.d0/MIN(DBLE(THR),SUM(KM(:))) - END DO ! NTRI - - U = DBLE(AC) - J = 0 - ASPAR = 0.d0 - B = 0.d0 - DO IP = 1, NX - DO I = 1, CCON(IP) - J = J + 1 - IE = IE_CELL(J) - POS = POS_CELL(J) - K1 = KP(POS,IE) * IOBPD(ITH,IP) - IF (K1 > 0.) THEN - DTK = K1 * DT - TMP3 = DTK * NM(IE) - I1 = POSI(1,J) - I2 = POSI(2,J) - I3 = POSI(3,J) - ASPAR(I1) = ONETHIRD * TRIA(IE) + DTK - TMP3 * DELTAL(POS,IE) + ASPAR(I1) - ASPAR(I2) = - TMP3 * DELTAL(POS_TRICK(POS,1),IE) + ASPAR(I2) - ASPAR(I3) = - TMP3 * DELTAL(POS_TRICK(POS,2),IE) + ASPAR(I3) - B(IP) = B(IP) + ONETHIRD * TRIA(IE) * U(IP) - ELSE - I1 = POSI(1,J) - ASPAR(I1) = ONETHIRD * TRIA(IE) + ASPAR(I1) - B(IP) = B(IP) + ONETHIRD * TRIA(IE) * U(IP) - END IF - END DO ! End loop over connected elements ... - END DO -! -!2DO setup a semi-implicit integration scheme for source terms only ... -! - IPAR(1) = 0 ! always 0 to start an iterative solver - IPAR(2) = 1 ! right preconditioning - IPAR(3) = 1 ! use convergence test scheme 1 - IPAR(4) = 8*NX ! - IPAR(5) = 15 - IPAR(6) = 1000 ! use at most 1000 matvec's - FPAR(1) = DBLE(1.0E-8) ! relative tolerance 1.0E-6 - FPAR(2) = DBLE(1.0E-10) ! absolute tolerance 1.0E-10 - FPAR(11) = 0.d0 ! clearing the FLOPS counter - - AU = 0. - FLJAU = 0 - FLJU = 0 - JAU = 0 - JU = 0 - - CALL ILU0 (NX, ASPAR, JAA, IAA, AU, FLJAU, FLJU, IWKSP, IERROR) - -! WRITE(*,*) 'PRECONDITIONER', IERROR - -! IF (SUM(AC) .GT. 0.) THEN - IF (.FALSE.) THEN - WRITE(*,*) SUM(AC) - WRITE(*,*) 'CALL SOLVER' - WRITE(*,*) 'WRITE CG', SUM(CG) - WRITE(*,*) 'B, X, AC, U', SUM(B), SUM(X), SUM(AC), SUM(U) - WRITE(*,*) 'IPAR, FPAR', SUM(IPAR), SUM(FPAR) - WRITE(*,*) 'WKSP, INIU', SUM(WKSP), SUM(INIU) - WRITE(*,*) 'ASPAR, JAA, IAA',SUM(ASPAR), SUM(IAA), SUM(JAA) - WRITE(*,*) 'AU, FLJAU, FLJU',SUM(AU), SUM(FLJAU), SUM(FLJU) - END IF - - INIU = U - X = 0.d0 - - CALL RUNRC (NX, B, X, IPAR, FPAR, WKSP, INIU, ASPAR, JAA, IAA, AU, FLJAU, FLJU, BCGSTAB) - - IF (.FALSE.) THEN - WRITE(*,*) 'SOLUTION' - WRITE(*,*) 'B, X, AC, U', SUM(B), SUM(X), SUM(AC), SUM(U) - WRITE(*,*) 'IPAR, FPAR', SUM(IPAR), SUM(FPAR) - WRITE(*,*) 'WKSP, INIU', SUM(WKSP), SUM(INIU) - WRITE(*,*) 'ASPAR, JAA, IAA', SUM(ASPAR), SUM(JAA), SUM(IAA) - WRITE(*,*) 'AU, FLJAU, FLJU', SUM(AU), SUM(FLJAU), SUM(FLJU) - END IF - - DO IP = 1,NX - U(IP) = MAX(0.d0,X(IP)*DBLE(IOBPD(ITH,IP))) + IF (.FALSE.) THEN + WRITE(*,*) 'NNZ', NNZ + WRITE(*,*) 'MINVAL IAA,JAA', MINVAL(IAA), MINVAL(JAA) + WRITE(*,*) 'MINVAL IAA,JAA', MAXVAL(IAA), MAXVAL(JAA) + WRITE(*,*) 'MAX/MIN POSI', MAXVAL(POSI), MINVAL(POSI) + WRITE(*,*) 'AC, AQ', SUM(AC) + END IF + ! + !2 Propagation + !2.a Calculate K-Values and contour based quantities ... + ! + DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... + I1 = TRIGP(1,IE) ! Index of the Element Nodes (TRIGP) + I2 = TRIGP(2,IE) + I3 = TRIGP(3,IE) + LAMBDA(1) = ONESIXTH * (C(I1,1)+C(I2,1)+C(I3,1)) + LAMBDA(2) = ONESIXTH * (C(I1,2)+C(I2,2)+C(I3,2)) + K(1) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) + K(2) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) + K(3) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) + KP(1,IE) = MAX(0.d0,K(1)) + KP(2,IE) = MAX(0.d0,K(2)) + KP(3,IE) = MAX(0.d0,K(3)) + KM(1) = MIN(0.d0,K(1)) + KM(2) = MIN(0.d0,K(2)) + KM(3) = MIN(0.d0,K(3)) + FL11 = C(I2,1)*IEN(IE,1)+C(I2,2)*IEN(IE,2) + FL12 = C(I3,1)*IEN(IE,1)+C(I3,2)*IEN(IE,2) + FL21 = C(I3,1)*IEN(IE,3)+C(I3,2)*IEN(IE,4) + FL22 = C(I1,1)*IEN(IE,3)+C(I1,2)*IEN(IE,4) + FL31 = C(I1,1)*IEN(IE,5)+C(I1,2)*IEN(IE,6) + FL32 = C(I2,1)*IEN(IE,5)+C(I2,2)*IEN(IE,6) + CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) + CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) + CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) + DELTAL(:,IE) = CRFS(:)- KP(:,IE) + NM(IE) = 1.d0/MIN(DBLE(THR),SUM(KM(:))) + END DO ! NTRI + + U = DBLE(AC) + J = 0 + ASPAR = 0.d0 + B = 0.d0 + DO IP = 1, NX + DO I = 1, CCON(IP) + J = J + 1 + IE = IE_CELL(J) + POS = POS_CELL(J) + K1 = KP(POS,IE) * IOBPD(ITH,IP) + IF (K1 > 0.) THEN + DTK = K1 * DT + TMP3 = DTK * NM(IE) + I1 = POSI(1,J) + I2 = POSI(2,J) + I3 = POSI(3,J) + ASPAR(I1) = ONETHIRD * TRIA(IE) + DTK - TMP3 * DELTAL(POS,IE) + ASPAR(I1) + ASPAR(I2) = - TMP3 * DELTAL(POS_TRICK(POS,1),IE) + ASPAR(I2) + ASPAR(I3) = - TMP3 * DELTAL(POS_TRICK(POS,2),IE) + ASPAR(I3) + B(IP) = B(IP) + ONETHIRD * TRIA(IE) * U(IP) + ELSE + I1 = POSI(1,J) + ASPAR(I1) = ONETHIRD * TRIA(IE) + ASPAR(I1) + B(IP) = B(IP) + ONETHIRD * TRIA(IE) * U(IP) + END IF + END DO ! End loop over connected elements ... + END DO + ! + !2DO setup a semi-implicit integration scheme for source terms only ... + ! + IPAR(1) = 0 ! always 0 to start an iterative solver + IPAR(2) = 1 ! right preconditioning + IPAR(3) = 1 ! use convergence test scheme 1 + IPAR(4) = 8*NX ! + IPAR(5) = 15 + IPAR(6) = 1000 ! use at most 1000 matvec's + FPAR(1) = DBLE(1.0E-8) ! relative tolerance 1.0E-6 + FPAR(2) = DBLE(1.0E-10) ! absolute tolerance 1.0E-10 + FPAR(11) = 0.d0 ! clearing the FLOPS counter + + AU = 0. + FLJAU = 0 + FLJU = 0 + JAU = 0 + JU = 0 + + CALL ILU0 (NX, ASPAR, JAA, IAA, AU, FLJAU, FLJU, IWKSP, IERROR) + + ! WRITE(*,*) 'PRECONDITIONER', IERROR + + ! IF (SUM(AC) .GT. 0.) THEN + IF (.FALSE.) THEN + WRITE(*,*) SUM(AC) + WRITE(*,*) 'CALL SOLVER' + WRITE(*,*) 'WRITE CG', SUM(CG) + WRITE(*,*) 'B, X, AC, U', SUM(B), SUM(X), SUM(AC), SUM(U) + WRITE(*,*) 'IPAR, FPAR', SUM(IPAR), SUM(FPAR) + WRITE(*,*) 'WKSP, INIU', SUM(WKSP), SUM(INIU) + WRITE(*,*) 'ASPAR, JAA, IAA',SUM(ASPAR), SUM(IAA), SUM(JAA) + WRITE(*,*) 'AU, FLJAU, FLJU',SUM(AU), SUM(FLJAU), SUM(FLJU) + END IF + + INIU = U + X = 0.d0 + + CALL RUNRC (NX, B, X, IPAR, FPAR, WKSP, INIU, ASPAR, JAA, IAA, AU, FLJAU, FLJU, BCGSTAB) + + IF (.FALSE.) THEN + WRITE(*,*) 'SOLUTION' + WRITE(*,*) 'B, X, AC, U', SUM(B), SUM(X), SUM(AC), SUM(U) + WRITE(*,*) 'IPAR, FPAR', SUM(IPAR), SUM(FPAR) + WRITE(*,*) 'WKSP, INIU', SUM(WKSP), SUM(INIU) + WRITE(*,*) 'ASPAR, JAA, IAA', SUM(ASPAR), SUM(JAA), SUM(IAA) + WRITE(*,*) 'AU, FLJAU, FLJU', SUM(AU), SUM(FLJAU), SUM(FLJU) + END IF + + DO IP = 1,NX + U(IP) = MAX(0.d0,X(IP)*DBLE(IOBPD(ITH,IP))) #ifdef W3_REF1 - IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values #endif - END DO -! -! update spectrum - AC = REAL(U) -! -! 4 Update boundaries: performs interpolation in time as done in rect grids (e.g. w3pro1md.ftn) -! - IF ( FLBPI ) THEN - RD1=RD10 - RD2=RD20 - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF -! -! Time interpolation as done in rect grids -! - DO IBI=1, NBI - IP = MAPSF(ISBPI(IBI),1) - AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - *IOBPA(IP)*(1-IOBPD(ITH,IP)) / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) - END DO - END IF - -! CALL EXTCDE ( 99 ) -!/ -!/ End of W3XYPFSNIMP------------------------------------------------- / -!/ - END SUBROUTINE W3XYPFSNIMP - -!/ ------------------------------------------------------------------- / - - SUBROUTINE W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) -!/ -!/ -!/ +-----------------------------------+ -!/ | WWIII Version of the WWM FS Code | -!/ | by Aron Roland | -!/ | for use in WWIII | -!/ | GPL License | -!/ | Last update : 19-Dec-2007 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! Advection of a scalar in a arbitary velocity field on unstructured meshes -! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Subroutine tracing (!/S switch) -! -! 5. Called by : -! -! W3XYPUG Routine for advection on unstructured grid -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & - IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBPA, TRIA, IOBDP + END DO + ! + ! update spectrum + AC = REAL(U) + ! + ! 4 Update boundaries: performs interpolation in time as done in rect grids (e.g. w3pro1md.ftn) + ! + IF ( FLBPI ) THEN + RD1=RD10 + RD2=RD20 + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. + END IF + ! + ! Time interpolation as done in rect grids + ! + DO IBI=1, NBI + IP = MAPSF(ISBPI(IBI),1) + AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + *IOBPA(IP)*(1-IOBPD(ITH,IP)) / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) + END DO + END IF + + ! CALL EXTCDE ( 99 ) + !/ + !/ End of W3XYPFSNIMP------------------------------------------------- / + !/ + END SUBROUTINE W3XYPFSNIMP + + !/ ------------------------------------------------------------------- / + + SUBROUTINE W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) + !/ + !/ + !/ +-----------------------------------+ + !/ | WWIII Version of the WWM FS Code | + !/ | by Aron Roland | + !/ | for use in WWIII | + !/ | GPL License | + !/ | Last update : 19-Dec-2007 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! Advection of a scalar in a arbitary velocity field on unstructured meshes + ! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Subroutine tracing (!/S switch) + ! + ! 5. Called by : + ! + ! W3XYPUG Routine for advection on unstructured grid + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & + IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBPA, TRIA, IOBDP #ifdef W3_REF1 - USE W3GDATMD, ONLY : REFPARS + USE W3GDATMD, ONLY : REFPARS #endif - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: CG, ITER - USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN - USE W3TIMEMD, ONLY: DSEC21 + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: CG, ITER + USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN + USE W3TIMEMD, ONLY: DSEC21 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE - - INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction - REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the given velocity field - REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, - DOUBLE PRECISION, INTENT(INOUT) :: AC(:) ! Wave Action before and after advection - REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary condition - LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction + REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the given velocity field + REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, + DOUBLE PRECISION, INTENT(INOUT) :: AC(:) ! Wave Action before and after advection + REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary condition + LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 - REAL*8, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 - REAL*8, PARAMETER :: THR8 = TINY(1.0d0) - REAL, PARAMETER :: THR = TINY(1.0) -!/ -!/ ------------------------------------------------------------------- / -!/ -! -! local integer -! - INTEGER :: IP, IE, IT, I1, I2, I3, I, ITH, IK - INTEGER :: IBI, NI(3) -! -! local real -! - REAL :: RD1, RD2 -!: -! local double -! - REAL*8 :: UTILDE, BOUNDARY_FORCING - REAL*8 :: FT, CFLXY - REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 - REAL*8 :: FL111, FL112, FL211, FL212, FL311, FL312 - REAL*8 :: DTSI(NX), U(NX), DT4AI - REAL*8 :: DTMAXGL, DTMAXEXP, REST - REAL*8 :: LAMBDA(2), KTMP(3), TMP(3) - REAL*8 :: BET1(3), BETAHAT(3) - REAL*8 :: THETA_L(3,NTRI), THETA_H(3,NTRI), THETA_ACE(3,NTRI), UTMP(3) - REAL*8 :: WII(2,NX), UL(NX), USTARI(2,NX) - - REAL*8 :: PM(NX), PP(NX), UIM(NX), UIP(NX) - - REAL*8 :: KELEM(3,NTRI), FLALL(3,NTRI) - REAL*8 :: KKSUM(NX), ST(NX), BETA - REAL*8 :: NM(NTRI) + REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 + REAL*8, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 + REAL*8, PARAMETER :: THR8 = TINY(1.0d0) + REAL, PARAMETER :: THR = TINY(1.0) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + ! local integer + ! + INTEGER :: IP, IE, IT, I1, I2, I3, I, ITH, IK + INTEGER :: IBI, NI(3) + ! + ! local real + ! + REAL :: RD1, RD2 + !: + ! local double + ! + REAL*8 :: UTILDE, BOUNDARY_FORCING + REAL*8 :: FT, CFLXY + REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 + REAL*8 :: FL111, FL112, FL211, FL212, FL311, FL312 + REAL*8 :: DTSI(NX), U(NX), DT4AI + REAL*8 :: DTMAXGL, DTMAXEXP, REST + REAL*8 :: LAMBDA(2), KTMP(3), TMP(3) + REAL*8 :: BET1(3), BETAHAT(3) + REAL*8 :: THETA_L(3,NTRI), THETA_H(3,NTRI), THETA_ACE(3,NTRI), UTMP(3) + REAL*8 :: WII(2,NX), UL(NX), USTARI(2,NX) + + REAL*8 :: PM(NX), PP(NX), UIM(NX), UIP(NX) + + REAL*8 :: KELEM(3,NTRI), FLALL(3,NTRI) + REAL*8 :: KKSUM(NX), ST(NX), BETA + REAL*8 :: NM(NTRI) #ifdef W3_S - CALL STRACE (IENT, 'W3XYPFSFCT2') + CALL STRACE (IENT, 'W3XYPFSFCT2') #endif -! 1. initialisation + ! 1. initialisation - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - DTMAXGL = DBLE(10.E10) -! -!2 Propagation -!2.a Calculate K-Values and contour based quantities ... -! - DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... - I1 = TRIGP(1,IE) ! Index of the Element Nodes (TRIGP) - I2 = TRIGP(2,IE) - I3 = TRIGP(3,IE) - LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction - LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) - KELEM(1,IE) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians - KELEM(2,IE) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) - KELEM(3,IE) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) - KTMP = KELEM(:,IE) ! Copy - NM(IE) = - 1.D0/MIN(-THR8,SUM(MIN(0.d0,KTMP))) ! N-Values - FL11 = C(I2,1) * IEN(IE,1) + C(I2,2) * IEN(IE,2) ! Weights for Simpson Integration - FL12 = C(I3,1) * IEN(IE,1) + C(I3,2) * IEN(IE,2) - FL21 = C(I3,1) * IEN(IE,3) + C(I3,2) * IEN(IE,4) - FL22 = C(I1,1) * IEN(IE,3) + C(I1,2) * IEN(IE,4) - FL31 = C(I1,1) * IEN(IE,5) + C(I1,2) * IEN(IE,6) - FL32 = C(I2,1) * IEN(IE,5) + C(I2,2) * IEN(IE,6) - FL111 = 2.d0*FL11+FL12 - FL112 = 2.d0*FL12+FL11 - FL211 = 2.d0*FL21+FL22 - FL212 = 2.d0*FL22+FL21 - FL311 = 2.d0*FL31+FL32 - FL312 = 2.d0*FL32+FL31 - FLALL(1,IE) = (FL311 + FL212)! * ONESIXTH + KELEM(1,IE) - FLALL(2,IE) = (FL111 + FL312)! * ONESIXTH + KELEM(2,IE) - FLALL(3,IE) = (FL211 + FL112)! * ONESIXTH + KELEM(3,IE) - END DO ! NTRI - - IF (LCALC) THEN ! If the current field or water level changes estimate the iteration number based on the new flow field and the CFL number of the scheme - KKSUM = 0.d0 - DO IE = 1, NTRI - NI = TRIGP(:,IE) - KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) - END DO ! IE - DTMAXEXP = 1E10 ! initialize to large number - DO IP = 1, NX - DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP(IP)) - DTMAXGL = MIN( DTMAXGL, DTMAXEXP) - END DO ! IP - CFLXY = DBLE(DT)/DTMAXGL - REST = ABS(MOD(CFLXY,1.0d0)) - IF (REST .LT. THR8) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) - ELSE IF (REST .GT. THR8 .AND. REST .LT. 0.5d0) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 - ELSE - ITER(IK,ITH) = ABS(NINT(CFLXY)) - END IF - END IF ! LCALC - - DT4AI = DBLE(DT)/DBLE(ITER(IK,ITH)) - DTSI(:) = DT4AI/SI(:) ! Some precalculations for the time integration. - - U = AC - UL = U -! -! Now loop on sub-timesteps -! - DO IT = 1, ITER(IK,ITH) - - ST = 0.d0 - - DO IE = 1, NTRI - NI = TRIGP(:,IE) - UTMP = U(NI) - FT = - ONESIXTH*DOT_PRODUCT(UTMP,FLALL(:,IE)) - TMP = MAX(0.d0,KELEM(:,IE)) - UTILDE = NM(IE) * ( DOT_PRODUCT(TMP,UTMP) - FT ) - THETA_L(:,IE) = TMP * ( UTMP - UTILDE ) - IF (ABS(FT) .GT. DBLE(THR)) THEN - BET1(:) = THETA_L(:,IE)/FT - IF (ANY( BET1 .LT. 0.0d0) ) THEN - BETAHAT(1) = BET1(1) + 0.5d0 * BET1(2) - BETAHAT(2) = BET1(2) + 0.5d0 * BET1(3) - BETAHAT(3) = BET1(3) + 0.5d0 * BET1(1) - BET1(1) = MAX(0.d0,MIN(BETAHAT(1),1.d0-BETAHAT(2),1.d0)) - BET1(2) = MAX(0.d0,MIN(BETAHAT(2),1.d0-BETAHAT(3),1.d0)) - BET1(3) = MAX(0.d0,MIN(BETAHAT(3),1.d0-BETAHAT(1),1.d0)) - THETA_L(:,IE) = FT * BET1 - END IF - ELSE - THETA_L(:,IE) = 0.d0 - END IF -! THETA_H(:,IE) = (ONETHIRD+DT4AI/(2.d0*TRIA(IE)) * KELEM(:,IE))*FT ! LAX-WENDROFF - THETA_H(:,IE) = (1./3.+2./3.* KELEM(:,IE)/SUM(ABS(KELEM(:,IE))) )*FT ! CENTRAL SCHEME - ! Antidiffusive residual according to the higher order nonmonotone scheme - THETA_ACE(:,IE) = ((THETA_H(:,IE) - THETA_L(:,IE))) * DT4AI/SI(NI) - ST(NI) = ST(NI) + THETA_L(:,IE)*DT4AI/SI(NI) - END DO - -! UL = MAX(0.d0,U-ST)*DBLE(IOBPD(ITH,:))!*DBLE(IOBDP(:)) ... add for IOBDP dry/wet flag. - - DO IP = 1,NX - UL(IP) = MAX(0.d0,U(IP)-ST(IP))*DBLE(IOBPD(ITH,IP)) - END DO - - USTARI(1,:) = MAX(UL,U) - USTARI(2,:) = MIN(UL,U) - - UIP = -THR8 - UIM = THR8 - PP = 0.d0 - PM = 0.d0 - DO IE = 1, NTRI - NI = TRIGP(:,IE) - PP(NI) = PP(NI) + MAX( THR8, -THETA_ACE(:,IE)) - PM(NI) = PM(NI) + MIN( -THR8, -THETA_ACE(:,IE)) - UIP(NI) = MAX (UIP(NI), MAXVAL( USTARI(1,NI) )) - UIM(NI) = MIN (UIM(NI), MINVAL( USTARI(2,NI) )) - END DO - - WII(1,:) = MIN(1.0d0,(UIP-UL)/MAX( THR8,PP)) - WII(2,:) = MIN(1.0d0,(UIM-UL)/MIN(-THR8,PM)) - - ST = 0.d0 - DO IE = 1, NTRI - DO I = 1, 3 - IP = TRIGP(I,IE) - IF (-THETA_ACE(I,IE) .GE. 0.) THEN - TMP(I) = WII(1,IP) - ELSE - TMP(I) = WII(2,IP) - END IF - END DO - BETA = MINVAL(TMP) - NI = TRIGP(:,IE) - ST(NI) = ST(NI) + BETA * THETA_ACE(:,IE) - END DO - - DO IP = 1,NX -! -! IOBPD is the switch for removing energy coming from the shoreline -! - U(IP) = MAX(0.d0,UL(IP)-ST(IP))*DBLE(IOBPD(ITH,IP)) + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + DTMAXGL = DBLE(10.E10) + ! + !2 Propagation + !2.a Calculate K-Values and contour based quantities ... + ! + DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... + I1 = TRIGP(1,IE) ! Index of the Element Nodes (TRIGP) + I2 = TRIGP(2,IE) + I3 = TRIGP(3,IE) + LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction + LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) + KELEM(1,IE) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians + KELEM(2,IE) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) + KELEM(3,IE) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) + KTMP = KELEM(:,IE) ! Copy + NM(IE) = - 1.D0/MIN(-THR8,SUM(MIN(0.d0,KTMP))) ! N-Values + FL11 = C(I2,1) * IEN(IE,1) + C(I2,2) * IEN(IE,2) ! Weights for Simpson Integration + FL12 = C(I3,1) * IEN(IE,1) + C(I3,2) * IEN(IE,2) + FL21 = C(I3,1) * IEN(IE,3) + C(I3,2) * IEN(IE,4) + FL22 = C(I1,1) * IEN(IE,3) + C(I1,2) * IEN(IE,4) + FL31 = C(I1,1) * IEN(IE,5) + C(I1,2) * IEN(IE,6) + FL32 = C(I2,1) * IEN(IE,5) + C(I2,2) * IEN(IE,6) + FL111 = 2.d0*FL11+FL12 + FL112 = 2.d0*FL12+FL11 + FL211 = 2.d0*FL21+FL22 + FL212 = 2.d0*FL22+FL21 + FL311 = 2.d0*FL31+FL32 + FL312 = 2.d0*FL32+FL31 + FLALL(1,IE) = (FL311 + FL212)! * ONESIXTH + KELEM(1,IE) + FLALL(2,IE) = (FL111 + FL312)! * ONESIXTH + KELEM(2,IE) + FLALL(3,IE) = (FL211 + FL112)! * ONESIXTH + KELEM(3,IE) + END DO ! NTRI + + IF (LCALC) THEN ! If the current field or water level changes estimate the iteration number based on the new flow field and the CFL number of the scheme + KKSUM = 0.d0 + DO IE = 1, NTRI + NI = TRIGP(:,IE) + KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) + END DO ! IE + DTMAXEXP = 1E10 ! initialize to large number + DO IP = 1, NX + DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP(IP)) + DTMAXGL = MIN( DTMAXGL, DTMAXEXP) + END DO ! IP + CFLXY = DBLE(DT)/DTMAXGL + REST = ABS(MOD(CFLXY,1.0d0)) + IF (REST .LT. THR8) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + ELSE IF (REST .GT. THR8 .AND. REST .LT. 0.5d0) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 + ELSE + ITER(IK,ITH) = ABS(NINT(CFLXY)) + END IF + END IF ! LCALC + + DT4AI = DBLE(DT)/DBLE(ITER(IK,ITH)) + DTSI(:) = DT4AI/SI(:) ! Some precalculations for the time integration. + + U = AC + UL = U + ! + ! Now loop on sub-timesteps + ! + DO IT = 1, ITER(IK,ITH) + + ST = 0.d0 + + DO IE = 1, NTRI + NI = TRIGP(:,IE) + UTMP = U(NI) + FT = - ONESIXTH*DOT_PRODUCT(UTMP,FLALL(:,IE)) + TMP = MAX(0.d0,KELEM(:,IE)) + UTILDE = NM(IE) * ( DOT_PRODUCT(TMP,UTMP) - FT ) + THETA_L(:,IE) = TMP * ( UTMP - UTILDE ) + IF (ABS(FT) .GT. DBLE(THR)) THEN + BET1(:) = THETA_L(:,IE)/FT + IF (ANY( BET1 .LT. 0.0d0) ) THEN + BETAHAT(1) = BET1(1) + 0.5d0 * BET1(2) + BETAHAT(2) = BET1(2) + 0.5d0 * BET1(3) + BETAHAT(3) = BET1(3) + 0.5d0 * BET1(1) + BET1(1) = MAX(0.d0,MIN(BETAHAT(1),1.d0-BETAHAT(2),1.d0)) + BET1(2) = MAX(0.d0,MIN(BETAHAT(2),1.d0-BETAHAT(3),1.d0)) + BET1(3) = MAX(0.d0,MIN(BETAHAT(3),1.d0-BETAHAT(1),1.d0)) + THETA_L(:,IE) = FT * BET1 + END IF + ELSE + THETA_L(:,IE) = 0.d0 + END IF + ! THETA_H(:,IE) = (ONETHIRD+DT4AI/(2.d0*TRIA(IE)) * KELEM(:,IE))*FT ! LAX-WENDROFF + THETA_H(:,IE) = (1./3.+2./3.* KELEM(:,IE)/SUM(ABS(KELEM(:,IE))) )*FT ! CENTRAL SCHEME + ! Antidiffusive residual according to the higher order nonmonotone scheme + THETA_ACE(:,IE) = ((THETA_H(:,IE) - THETA_L(:,IE))) * DT4AI/SI(NI) + ST(NI) = ST(NI) + THETA_L(:,IE)*DT4AI/SI(NI) + END DO + + ! UL = MAX(0.d0,U-ST)*DBLE(IOBPD(ITH,:))!*DBLE(IOBDP(:)) ... add for IOBDP dry/wet flag. + + DO IP = 1,NX + UL(IP) = MAX(0.d0,U(IP)-ST(IP))*DBLE(IOBPD(ITH,IP)) + END DO + + USTARI(1,:) = MAX(UL,U) + USTARI(2,:) = MIN(UL,U) + + UIP = -THR8 + UIM = THR8 + PP = 0.d0 + PM = 0.d0 + DO IE = 1, NTRI + NI = TRIGP(:,IE) + PP(NI) = PP(NI) + MAX( THR8, -THETA_ACE(:,IE)) + PM(NI) = PM(NI) + MIN( -THR8, -THETA_ACE(:,IE)) + UIP(NI) = MAX (UIP(NI), MAXVAL( USTARI(1,NI) )) + UIM(NI) = MIN (UIM(NI), MINVAL( USTARI(2,NI) )) + END DO + + WII(1,:) = MIN(1.0d0,(UIP-UL)/MAX( THR8,PP)) + WII(2,:) = MIN(1.0d0,(UIM-UL)/MIN(-THR8,PM)) + + ST = 0.d0 + DO IE = 1, NTRI + DO I = 1, 3 + IP = TRIGP(I,IE) + IF (-THETA_ACE(I,IE) .GE. 0.) THEN + TMP(I) = WII(1,IP) + ELSE + TMP(I) = WII(2,IP) + END IF + END DO + BETA = MINVAL(TMP) + NI = TRIGP(:,IE) + ST(NI) = ST(NI) + BETA * THETA_ACE(:,IE) + END DO + + DO IP = 1,NX + ! + ! IOBPD is the switch for removing energy coming from the shoreline + ! + U(IP) = MAX(0.d0,UL(IP)-ST(IP))*DBLE(IOBPD(ITH,IP)) #ifdef W3_REF1 - IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values #endif - END DO -! -! update spectrum - AC = U -! -! 4 Update boundaries: performs interpolation in time as done in rect grids (e.g. w3pro1md.ftn) -! - IF ( FLBPI ) THEN -! -! 4.1 In this case the boundary is read from the nest.ww3 file -! - RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) - RD2=RD20 - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF -! -! Overwrites only the incoming energy ( IOBPD(ITH,IP) = 0) -! - DO IBI=1, NBI - IP = MAPSF(ISBPI(IBI),1) - AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) - END DO + END DO + ! + ! update spectrum + AC = U + ! + ! 4 Update boundaries: performs interpolation in time as done in rect grids (e.g. w3pro1md.ftn) + ! + IF ( FLBPI ) THEN + ! + ! 4.1 In this case the boundary is read from the nest.ww3 file + ! + RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) + RD2=RD20 + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. + END IF + ! + ! Overwrites only the incoming energy ( IOBPD(ITH,IP) = 0) + ! + DO IBI=1, NBI + IP = MAPSF(ISBPI(IBI),1) + AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) + END DO - ENDIF -! - END DO ! End of loop on time steps -! CALL EXTCDE ( 99 ) -!/ -!/ End of W3XYPFSN ----------------------------------------------------- / -!/ - END SUBROUTINE W3XYPFSFCT2 -!/ ------------------------------------------------------------------- / - SUBROUTINE SETDEPTH -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init pdlib part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ENDIF + ! + END DO ! End of loop on time steps + ! CALL EXTCDE ( 99 ) + !/ + !/ End of W3XYPFSN ----------------------------------------------------- / + !/ + END SUBROUTINE W3XYPFSFCT2 + !/ ------------------------------------------------------------------- / + SUBROUTINE SETDEPTH + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init pdlib part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: MAPSF, NSEAL, DMIN, IOBDP, MAPSTA, IOBP, MAPFS, NX - USE W3ADATMD, ONLY: DW + ! + USE CONSTANTS, ONLY : LPDLIB + USE W3GDATMD, ONLY: MAPSF, NSEAL, DMIN, IOBDP, MAPSTA, IOBP, MAPFS, NX + USE W3ADATMD, ONLY: DW - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -! - INTEGER :: JSEA, ISEA, IX, IP - REAL*8, PARAMETER :: DTHR = 10E-6 + !/ + !/ ------------------------------------------------------------------- / + ! + INTEGER :: JSEA, ISEA, IX, IP + REAL*8, PARAMETER :: DTHR = 10E-6 #ifdef W3_S - CALL STRACE (IENT, 'SETDEPTH') + CALL STRACE (IENT, 'SETDEPTH') #endif - IOBDP = 1 - DO IP=1,NX - IF (DW(IP) .LT. DMIN + DTHR) IOBDP(IP) = 0 - !WRITE(*,*) ip, ip_glob, MAPSTA(1,IP_glob), IOBP(IP_glob), DW(ISEA), DMIN - END DO + IOBDP = 1 + DO IP=1,NX + IF (DW(IP) .LT. DMIN + DTHR) IOBDP(IP) = 0 + !WRITE(*,*) ip, ip_glob, MAPSTA(1,IP_glob), IOBP(IP_glob), DW(ISEA), DMIN + END DO END SUBROUTINE SETDEPTH -!/ ------------------------------------------------------------------- / - -END MODULE W3PROFSMD + !/ ------------------------------------------------------------------- / + +END MODULE W3PROFSMD !-------------------------------------------------------------------------- @@ -1720,7 +1720,7 @@ END MODULE W3PROFSMD ! BCGSTAB == 8 * n ! TFQMR == 11 * n ! FOM == (n+3)*(m+2) + (m+1)*m/2 (m = ipar(5), default m=15) -! GMRES == (n+3)*(m+2) + (m+1)*m/2 (m = ipar(5), default m=15) +! GMRES == (n+3)*(m+2) + (m+1)*m/2 (m = ipar(5), default m=15) ! GMRES is no longer available ! FGMRES == 2*n*(m+1) + (m+1)*m/2 + 3*m + 2 (m = ipar(5), ! default m=15) @@ -2008,776 +2008,776 @@ END MODULE W3PROFSMD ! call atmux(n,w(ipar(8)),w(ipar(9)),a,ja,ia) ! goto 10 ! else if (ipar(1).eq.3) then -! left preconditioner solver -! goto 10 -! else if (ipar(1).eq.4) then -! left preconditioner transposed solve -! goto 10 -! else if (ipar(1).eq.5) then -! right preconditioner solve -! goto 10 -! else if (ipar(1).eq.6) then -! right preconditioner transposed solve -! goto 10 -! else if (ipar(1).eq.10) then -! call my own stopping test routine -! goto 10 -! else if (ipar(1).gt.0) then -! ipar(1) is an unspecified code -! else -! the iterative solver terminated with code = ipar(1) -! endif -! -! This segment of pseudo-code assumes the matrix is in CSR format, -! AMUX and ATMUX are two routines from the SPARSKIT MATVEC module. -! They perform matrix-vector multiplications for CSR matrices, -! where w(ipar(8)) is the first element of the input vectors to the -! two routines, and w(ipar(9)) is the first element of the output -! vectors from them. For simplicity, we did not show the name of -! the routine that performs the preconditioning operations or the -! convergence tests. -!----------------------------------------------------------------------- - subroutine bcgstab(n, rhs, sol, ipar, fpar, w) - implicit none - integer n, ipar(16) - real*8 rhs(n), sol(n), fpar(16), w(n,8) -!----------------------------------------------------------------------- -! BCGSTAB --- Bi Conjugate Gradient stabilized (BCGSTAB) -! This is an improved BCG routine. (1) no matrix transpose is -! involved. (2) the convergence is smoother. -! -! -! Algorithm: -! Initialization - r = b - A x, r0 = r, p = r, rho = (r0, r), -! Iterate - -! (1) v = A p -! (2) alpha = rho / (r0, v) -! (3) s = r - alpha v -! (4) t = A s -! (5) omega = (t, s) / (t, t) -! (6) x = x + alpha * p + omega * s -! (7) r = s - omega * t -! convergence test goes here -! (8) beta = rho, rho = (r0, r), beta = rho * alpha / (beta * omega) -! p = r + beta * (p - omega * v) -! -! in this routine, before successful return, the fpar's are -! fpar(3) == initial (preconditionied-)residual norm -! fpar(4) == target (preconditionied-)residual norm -! fpar(5) == current (preconditionied-)residual norm -! fpar(6) == current residual norm or error -! fpar(7) == current rho (rhok = ) -! fpar(8) == alpha -! fpar(9) == omega -! -! Usage of the work space W -! w(:, 1) = r0, the initial residual vector -! w(:, 2) = r, current residual vector -! w(:, 3) = s -! w(:, 4) = t -! w(:, 5) = v -! w(:, 6) = p -! w(:, 7) = tmp, used in preconditioning, etc. -! w(:, 8) = delta x, the correction to the answer is accumulated -! here, so that the right-preconditioning may be applied -! at the end -!----------------------------------------------------------------------- -! external routines used -! - real*8 ddot - logical stopbis, brkdn - external ddot, stopbis, brkdn -! - real*8 one - parameter(one=1.0D0) -! -! local variables -! - integer i - real*8 alpha,beta,rho,omega - logical lp, rp - save lp, rp -! -! where to go -! - if (ipar(1).gt.0) then - !!goto (10, 20, 40, 50, 60, 70, 80, 90, 100, 110) ipar(10) - SELECT CASE (ipar(10)) - CASE (1) - GOTO 10 - CASE (2) - GOTO 20 - CASE (3) - GOTO 40 - CASE (4) - GOTO 50 - CASE (5) - GOTO 60 - CASE (6) - GOTO 70 - CASE (7) - GOTO 80 - CASE (8) - GOTO 90 - CASE (9) - GOTO 100 - CASE (10) - GOTO 110 - END SELECT - else if (ipar(1).lt.0) then - goto 900 - endif -! -! call the initialization routine -! - call bisinit(ipar,fpar,8*n,1,lp,rp,w) - if (ipar(1).lt.0) return -! -! perform a matvec to compute the initial residual -! - ipar(1) = 1 - ipar(8) = 1 - ipar(9) = 1 + n - do i = 1, n - w(i,1) = sol(i) - enddo - ipar(10) = 1 - return - 10 ipar(7) = ipar(7) + 1 - ipar(13) = ipar(13) + 1 - do i = 1, n - w(i,1) = rhs(i) - w(i,2) - enddo - fpar(11) = fpar(11) + n - if (lp) then - ipar(1) = 3 - ipar(10) = 2 - return - endif -! - 20 if (lp) then - do i = 1, n - w(i,1) = w(i,2) - w(i,6) = w(i,2) - enddo - else - do i = 1, n - w(i,2) = w(i,1) - w(i,6) = w(i,1) - enddo - endif -! - fpar(7) = ddot(n,w,w) - fpar(11) = fpar(11) + 2 * n - fpar(5) = sqrt(fpar(7)) - fpar(3) = fpar(5) - if (abs(ipar(3)).eq.2) then - fpar(4) = fpar(1) * sqrt(ddot(n,rhs,rhs)) + fpar(2) - fpar(11) = fpar(11) + 2 * n - else if (ipar(3).ne.999) then - fpar(4) = fpar(1) * fpar(3) + fpar(2) - endif - if (ipar(3).ge.0) fpar(6) = fpar(5) - if (ipar(3).ge.0 .and. fpar(5).le.fpar(4) .and. ipar(3).ne.999) then - goto 900 - endif -! -! beginning of the iterations -! -! Step (1), v = A p - 30 if (rp) then - ipar(1) = 5 - ipar(8) = 5*n+1 - if (lp) then - ipar(9) = 4*n + 1 - else - ipar(9) = 6*n + 1 - endif - ipar(10) = 3 - return - endif -! - 40 ipar(1) = 1 - if (rp) then - ipar(8) = ipar(9) - else - ipar(8) = 5*n+1 - endif - if (lp) then - ipar(9) = 6*n + 1 - else - ipar(9) = 4*n + 1 - endif - ipar(10) = 4 - return - 50 if (lp) then - ipar(1) = 3 - ipar(8) = ipar(9) - ipar(9) = 4*n + 1 - ipar(10) = 5 - return - endif -! - 60 ipar(7) = ipar(7) + 1 -! -! step (2) - alpha = ddot(n,w(1,1),w(1,5)) - fpar(11) = fpar(11) + 2 * n - if (brkdn(alpha, ipar)) goto 900 - alpha = fpar(7) / alpha - fpar(8) = alpha -! -! step (3) - do i = 1, n - w(i,3) = w(i,2) - alpha * w(i,5) - enddo - fpar(11) = fpar(11) + 2 * n -! -! Step (4): the second matvec -- t = A s -! - if (rp) then - ipar(1) = 5 - ipar(8) = n+n+1 - if (lp) then - ipar(9) = ipar(8)+n - else - ipar(9) = 6*n + 1 - endif - ipar(10) = 6 - return - endif -! - 70 ipar(1) = 1 - if (rp) then - ipar(8) = ipar(9) - else - ipar(8) = n+n+1 - endif - if (lp) then - ipar(9) = 6*n + 1 - else - ipar(9) = 3*n + 1 - endif - ipar(10) = 7 - return - 80 if (lp) then - ipar(1) = 3 - ipar(8) = ipar(9) - ipar(9) = 3*n + 1 - ipar(10) = 8 - return - endif - 90 ipar(7) = ipar(7) + 1 -! -! step (5) - omega = ddot(n,w(1,4),w(1,4)) - fpar(11) = fpar(11) + n + n - if (brkdn(omega,ipar)) goto 900 - omega = ddot(n,w(1,4),w(1,3)) / omega - fpar(11) = fpar(11) + n + n - if (brkdn(omega,ipar)) goto 900 - fpar(9) = omega - alpha = fpar(8) -! -! step (6) and (7) - do i = 1, n - w(i,7) = alpha * w(i,6) + omega * w(i,3) - w(i,8) = w(i,8) + w(i,7) - w(i,2) = w(i,3) - omega * w(i,4) - enddo - fpar(11) = fpar(11) + 6 * n + 1 -! -! convergence test - if (ipar(3).eq.999) then - ipar(1) = 10 - ipar(8) = 7*n + 1 - ipar(9) = 6*n + 1 - ipar(10) = 9 - return - endif - if (stopbis(n,ipar,2,fpar,w(1,2),w(1,7),one)) goto 900 - 100 if (ipar(3).eq.999.and.ipar(11).eq.1) goto 900 -! -! step (8): computing new p and rho -! - rho = fpar(7) - fpar(7) = ddot(n,w(1,2),w(1,1)) - omega = fpar(9) - beta = fpar(7) * fpar(8) / (fpar(9) * rho) - do i = 1, n - w(i,6) = w(i,2) + beta * (w(i,6) - omega * w(i,5)) - enddo - fpar(11) = fpar(11) + 6 * n + 3 - if (brkdn(fpar(7),ipar)) goto 900 -! -! end of an iteration -! - goto 30 -! -! some clean up job to do +! left preconditioner solver +! goto 10 +! else if (ipar(1).eq.4) then +! left preconditioner transposed solve +! goto 10 +! else if (ipar(1).eq.5) then +! right preconditioner solve +! goto 10 +! else if (ipar(1).eq.6) then +! right preconditioner transposed solve +! goto 10 +! else if (ipar(1).eq.10) then +! call my own stopping test routine +! goto 10 +! else if (ipar(1).gt.0) then +! ipar(1) is an unspecified code +! else +! the iterative solver terminated with code = ipar(1) +! endif ! - 900 if (rp) then - if (ipar(1).lt.0) ipar(12) = ipar(1) - ipar(1) = 5 - ipar(8) = 7*n + 1 - ipar(9) = ipar(8) - n - ipar(10) = 10 - return - endif +! This segment of pseudo-code assumes the matrix is in CSR format, +! AMUX and ATMUX are two routines from the SPARSKIT MATVEC module. +! They perform matrix-vector multiplications for CSR matrices, +! where w(ipar(8)) is the first element of the input vectors to the +! two routines, and w(ipar(9)) is the first element of the output +! vectors from them. For simplicity, we did not show the name of +! the routine that performs the preconditioning operations or the +! convergence tests. +!----------------------------------------------------------------------- +subroutine bcgstab(n, rhs, sol, ipar, fpar, w) + implicit none + integer n, ipar(16) + real*8 rhs(n), sol(n), fpar(16), w(n,8) + !----------------------------------------------------------------------- + ! BCGSTAB --- Bi Conjugate Gradient stabilized (BCGSTAB) + ! This is an improved BCG routine. (1) no matrix transpose is + ! involved. (2) the convergence is smoother. + ! + ! + ! Algorithm: + ! Initialization - r = b - A x, r0 = r, p = r, rho = (r0, r), + ! Iterate - + ! (1) v = A p + ! (2) alpha = rho / (r0, v) + ! (3) s = r - alpha v + ! (4) t = A s + ! (5) omega = (t, s) / (t, t) + ! (6) x = x + alpha * p + omega * s + ! (7) r = s - omega * t + ! convergence test goes here + ! (8) beta = rho, rho = (r0, r), beta = rho * alpha / (beta * omega) + ! p = r + beta * (p - omega * v) + ! + ! in this routine, before successful return, the fpar's are + ! fpar(3) == initial (preconditionied-)residual norm + ! fpar(4) == target (preconditionied-)residual norm + ! fpar(5) == current (preconditionied-)residual norm + ! fpar(6) == current residual norm or error + ! fpar(7) == current rho (rhok = ) + ! fpar(8) == alpha + ! fpar(9) == omega + ! + ! Usage of the work space W + ! w(:, 1) = r0, the initial residual vector + ! w(:, 2) = r, current residual vector + ! w(:, 3) = s + ! w(:, 4) = t + ! w(:, 5) = v + ! w(:, 6) = p + ! w(:, 7) = tmp, used in preconditioning, etc. + ! w(:, 8) = delta x, the correction to the answer is accumulated + ! here, so that the right-preconditioning may be applied + ! at the end + !----------------------------------------------------------------------- + ! external routines used + ! + real*8 ddot + logical stopbis, brkdn + external ddot, stopbis, brkdn + ! + real*8 one + parameter(one=1.0D0) + ! + ! local variables + ! + integer i + real*8 alpha,beta,rho,omega + logical lp, rp + save lp, rp + ! + ! where to go + ! + if (ipar(1).gt.0) then + !!goto (10, 20, 40, 50, 60, 70, 80, 90, 100, 110) ipar(10) + SELECT CASE (ipar(10)) + CASE (1) + GOTO 10 + CASE (2) + GOTO 20 + CASE (3) + GOTO 40 + CASE (4) + GOTO 50 + CASE (5) + GOTO 60 + CASE (6) + GOTO 70 + CASE (7) + GOTO 80 + CASE (8) + GOTO 90 + CASE (9) + GOTO 100 + CASE (10) + GOTO 110 + END SELECT + else if (ipar(1).lt.0) then + goto 900 + endif + ! + ! call the initialization routine + ! + call bisinit(ipar,fpar,8*n,1,lp,rp,w) + if (ipar(1).lt.0) return + ! + ! perform a matvec to compute the initial residual + ! + ipar(1) = 1 + ipar(8) = 1 + ipar(9) = 1 + n + do i = 1, n + w(i,1) = sol(i) + enddo + ipar(10) = 1 + return +10 ipar(7) = ipar(7) + 1 + ipar(13) = ipar(13) + 1 + do i = 1, n + w(i,1) = rhs(i) - w(i,2) + enddo + fpar(11) = fpar(11) + n + if (lp) then + ipar(1) = 3 + ipar(10) = 2 + return + endif + ! +20 if (lp) then + do i = 1, n + w(i,1) = w(i,2) + w(i,6) = w(i,2) + enddo + else + do i = 1, n + w(i,2) = w(i,1) + w(i,6) = w(i,1) + enddo + endif + ! + fpar(7) = ddot(n,w,w) + fpar(11) = fpar(11) + 2 * n + fpar(5) = sqrt(fpar(7)) + fpar(3) = fpar(5) + if (abs(ipar(3)).eq.2) then + fpar(4) = fpar(1) * sqrt(ddot(n,rhs,rhs)) + fpar(2) + fpar(11) = fpar(11) + 2 * n + else if (ipar(3).ne.999) then + fpar(4) = fpar(1) * fpar(3) + fpar(2) + endif + if (ipar(3).ge.0) fpar(6) = fpar(5) + if (ipar(3).ge.0 .and. fpar(5).le.fpar(4) .and. ipar(3).ne.999) then + goto 900 + endif + ! + ! beginning of the iterations + ! + ! Step (1), v = A p +30 if (rp) then + ipar(1) = 5 + ipar(8) = 5*n+1 + if (lp) then + ipar(9) = 4*n + 1 + else + ipar(9) = 6*n + 1 + endif + ipar(10) = 3 + return + endif + ! +40 ipar(1) = 1 + if (rp) then + ipar(8) = ipar(9) + else + ipar(8) = 5*n+1 + endif + if (lp) then + ipar(9) = 6*n + 1 + else + ipar(9) = 4*n + 1 + endif + ipar(10) = 4 + return +50 if (lp) then + ipar(1) = 3 + ipar(8) = ipar(9) + ipar(9) = 4*n + 1 + ipar(10) = 5 + return + endif + ! +60 ipar(7) = ipar(7) + 1 + ! + ! step (2) + alpha = ddot(n,w(1,1),w(1,5)) + fpar(11) = fpar(11) + 2 * n + if (brkdn(alpha, ipar)) goto 900 + alpha = fpar(7) / alpha + fpar(8) = alpha + ! + ! step (3) + do i = 1, n + w(i,3) = w(i,2) - alpha * w(i,5) + enddo + fpar(11) = fpar(11) + 2 * n + ! + ! Step (4): the second matvec -- t = A s + ! + if (rp) then + ipar(1) = 5 + ipar(8) = n+n+1 + if (lp) then + ipar(9) = ipar(8)+n + else + ipar(9) = 6*n + 1 + endif + ipar(10) = 6 + return + endif + ! +70 ipar(1) = 1 + if (rp) then + ipar(8) = ipar(9) + else + ipar(8) = n+n+1 + endif + if (lp) then + ipar(9) = 6*n + 1 + else + ipar(9) = 3*n + 1 + endif + ipar(10) = 7 + return +80 if (lp) then + ipar(1) = 3 + ipar(8) = ipar(9) + ipar(9) = 3*n + 1 + ipar(10) = 8 + return + endif +90 ipar(7) = ipar(7) + 1 + ! + ! step (5) + omega = ddot(n,w(1,4),w(1,4)) + fpar(11) = fpar(11) + n + n + if (brkdn(omega,ipar)) goto 900 + omega = ddot(n,w(1,4),w(1,3)) / omega + fpar(11) = fpar(11) + n + n + if (brkdn(omega,ipar)) goto 900 + fpar(9) = omega + alpha = fpar(8) + ! + ! step (6) and (7) + do i = 1, n + w(i,7) = alpha * w(i,6) + omega * w(i,3) + w(i,8) = w(i,8) + w(i,7) + w(i,2) = w(i,3) - omega * w(i,4) + enddo + fpar(11) = fpar(11) + 6 * n + 1 + ! + ! convergence test + if (ipar(3).eq.999) then + ipar(1) = 10 + ipar(8) = 7*n + 1 + ipar(9) = 6*n + 1 + ipar(10) = 9 + return + endif + if (stopbis(n,ipar,2,fpar,w(1,2),w(1,7),one)) goto 900 +100 if (ipar(3).eq.999.and.ipar(11).eq.1) goto 900 + ! + ! step (8): computing new p and rho + ! + rho = fpar(7) + fpar(7) = ddot(n,w(1,2),w(1,1)) + omega = fpar(9) + beta = fpar(7) * fpar(8) / (fpar(9) * rho) + do i = 1, n + w(i,6) = w(i,2) + beta * (w(i,6) - omega * w(i,5)) + enddo + fpar(11) = fpar(11) + 6 * n + 3 + if (brkdn(fpar(7),ipar)) goto 900 + ! + ! end of an iteration + ! + goto 30 + ! + ! some clean up job to do + ! +900 if (rp) then + if (ipar(1).lt.0) ipar(12) = ipar(1) + ipar(1) = 5 + ipar(8) = 7*n + 1 + ipar(9) = ipar(8) - n + ipar(10) = 10 + return + endif - 110 if (rp) then - call tidycg(n,ipar,fpar,sol,w(1,7)) - else - call tidycg(n,ipar,fpar,sol,w(1,8)) - endif -! - return -!-----end-of-bcgstab +110 if (rp) then + call tidycg(n,ipar,fpar,sol,w(1,7)) + else + call tidycg(n,ipar,fpar,sol,w(1,8)) + endif + ! + return + !-----end-of-bcgstab end subroutine bcgstab !----------------------------------------------------------------------- - subroutine implu(np,umm,beta,ypiv,u,permut,full) - real*8 umm,beta,ypiv(*),u(*),x, xpiv - logical full, perm, permut(*) - integer np,k,npm1 -!----------------------------------------------------------------------- -! performs implicitly one step of the lu factorization of a -! banded hessenberg matrix. -!----------------------------------------------------------------------- - if (np .le. 1) goto 12 - npm1 = np - 1 -! -! -- perform previous step of the factorization- -! +subroutine implu(np,umm,beta,ypiv,u,permut,full) + real*8 umm,beta,ypiv(*),u(*),x, xpiv + logical full, perm, permut(*) + integer np,k,npm1 + !----------------------------------------------------------------------- + ! performs implicitly one step of the lu factorization of a + ! banded hessenberg matrix. + !----------------------------------------------------------------------- + if (np .le. 1) goto 12 + npm1 = np - 1 + ! + ! -- perform previous step of the factorization- + ! do k=1,npm1 - if (.not. permut(k)) goto 5 - x=u(k) - u(k) = u(k+1) - u(k+1) = x - 5 u(k+1) = u(k+1) - ypiv(k)*u(k) + if (.not. permut(k)) goto 5 + x=u(k) + u(k) = u(k+1) + u(k+1) = x +5 u(k+1) = u(k+1) - ypiv(k)*u(k) end do -!----------------------------------------------------------------------- -! now determine pivotal information to be used in the next call -!----------------------------------------------------------------------- - 12 umm = u(np) - perm = (beta .gt. abs(umm)) - if (.not. perm) goto 4 - xpiv = umm / beta - u(np) = beta - goto 8 - 4 xpiv = beta/umm - 8 permut(np) = perm - ypiv(np) = xpiv - if (.not. full) return -! shift everything up if full... + !----------------------------------------------------------------------- + ! now determine pivotal information to be used in the next call + !----------------------------------------------------------------------- +12 umm = u(np) + perm = (beta .gt. abs(umm)) + if (.not. perm) goto 4 + xpiv = umm / beta + u(np) = beta + goto 8 +4 xpiv = beta/umm +8 permut(np) = perm + ypiv(np) = xpiv + if (.not. full) return + ! shift everything up if full... do k=1,npm1 - ypiv(k) = ypiv(k+1) - permut(k) = permut(k+1) + ypiv(k) = ypiv(k+1) + permut(k) = permut(k+1) end do - return -!-----end-of-implu + return + !-----end-of-implu end subroutine implu !----------------------------------------------------------------------- - subroutine uppdir(n,p,np,lbp,indp,y,u,usav,flops) - implicit none +subroutine uppdir(n,p,np,lbp,indp,y,u,usav,flops) + implicit none - integer :: k,np,n,npm1,j,ju,indp,lbp - real*8 :: p(n,lbp), y(*), u(*), usav(*), x, flops - -!----------------------------------------------------------------------- -! updates the conjugate directions p given the upper part of the -! banded upper triangular matrix u. u contains the non zero -! elements of the column of the triangular matrix.. -!----------------------------------------------------------------------- - real*8 zero - parameter(zero=0.0D0) -! - npm1=np-1 - if (np .le. 1) goto 12 - j=indp - ju = npm1 - 10 if (j .le. 0) j=lbp - x = u(ju) /usav(j) - if (x .eq. zero) goto 115 + integer :: k,np,n,npm1,j,ju,indp,lbp + real*8 :: p(n,lbp), y(*), u(*), usav(*), x, flops + + !----------------------------------------------------------------------- + ! updates the conjugate directions p given the upper part of the + ! banded upper triangular matrix u. u contains the non zero + ! elements of the column of the triangular matrix.. + !----------------------------------------------------------------------- + real*8 zero + parameter(zero=0.0D0) + ! + npm1=np-1 + if (np .le. 1) goto 12 + j=indp + ju = npm1 +10 if (j .le. 0) j=lbp + x = u(ju) /usav(j) + if (x .eq. zero) goto 115 do k=1,n - y(k) = y(k) - x*p(k,j) + y(k) = y(k) - x*p(k,j) end do - flops = flops + 2*n - 115 j = j-1 - ju = ju -1 - if (ju .ge. 1) goto 10 - 12 indp = indp + 1 - if (indp .gt. lbp) indp = 1 - usav(indp) = u(np) + flops = flops + 2*n +115 j = j-1 + ju = ju -1 + if (ju .ge. 1) goto 10 +12 indp = indp + 1 + if (indp .gt. lbp) indp = 1 + usav(indp) = u(np) do k=1,n - p(k,indp) = y(k) + p(k,indp) = y(k) end do - return -!----------------------------------------------------------------------- -!-------end-of-uppdir--------------------------------------------------- + return + !----------------------------------------------------------------------- + !-------end-of-uppdir--------------------------------------------------- end subroutine uppdir - subroutine givens(x,y,c,s) - implicit none +subroutine givens(x,y,c,s) + implicit none - real*8 :: x,y,c,s -!----------------------------------------------------------------------- -! Given x and y, this subroutine generates a Givens' rotation c, s. -! And apply the rotation on (x,y) ==> (sqrt(x**2 + y**2), 0). -! (See P 202 of "matrix computation" by Golub and van Loan.) -!----------------------------------------------------------------------- - real*8 :: t,one,zero - parameter (zero=0.0D0,one=1.0D0) -! - if (x.eq.zero .and. y.eq.zero) then - c = one - s = zero - else if (abs(y).gt.abs(x)) then - t = x / y - x = sqrt(one+t*t) - s = sign(one / x, y) - c = t*s - else if (abs(y).le.abs(x)) then - t = y / x - y = sqrt(one+t*t) - c = sign(one / y, x) - s = t*c - else -! -! X or Y must be an invalid floating-point number, set both to zero -! - x = zero - y = zero - c = one - s = zero - endif - x = abs(x*y) -! -! end of givens -! - return + real*8 :: x,y,c,s + !----------------------------------------------------------------------- + ! Given x and y, this subroutine generates a Givens' rotation c, s. + ! And apply the rotation on (x,y) ==> (sqrt(x**2 + y**2), 0). + ! (See P 202 of "matrix computation" by Golub and van Loan.) + !----------------------------------------------------------------------- + real*8 :: t,one,zero + parameter (zero=0.0D0,one=1.0D0) + ! + if (x.eq.zero .and. y.eq.zero) then + c = one + s = zero + else if (abs(y).gt.abs(x)) then + t = x / y + x = sqrt(one+t*t) + s = sign(one / x, y) + c = t*s + else if (abs(y).le.abs(x)) then + t = y / x + y = sqrt(one+t*t) + c = sign(one / y, x) + s = t*c + else + ! + ! X or Y must be an invalid floating-point number, set both to zero + ! + x = zero + y = zero + c = one + s = zero + endif + x = abs(x*y) + ! + ! end of givens + ! + return end subroutine givens !-----end-of-givens !----------------------------------------------------------------------- - logical function stopbis(n,ipar,mvpi,fpar,r,delx,sx) - implicit none - integer n,mvpi,ipar(16) - real*8 fpar(16), r(n), delx(n), sx, ddot - external ddot -!----------------------------------------------------------------------- -! function for determining the stopping criteria. return value of -! true if the stopbis criteria is satisfied. -!----------------------------------------------------------------------- - if (ipar(11) .eq. 1) then - stopbis = .true. - else - stopbis = .false. +logical function stopbis(n,ipar,mvpi,fpar,r,delx,sx) + implicit none + integer n,mvpi,ipar(16) + real*8 fpar(16), r(n), delx(n), sx, ddot + external ddot + !----------------------------------------------------------------------- + ! function for determining the stopping criteria. return value of + ! true if the stopbis criteria is satisfied. + !----------------------------------------------------------------------- + if (ipar(11) .eq. 1) then + stopbis = .true. + else + stopbis = .false. + endif + if (ipar(6).gt.0 .and. ipar(7).ge.ipar(6)) then + ipar(1) = -1 + stopbis = .true. + endif + if (stopbis) return + ! + ! computes errors + ! + fpar(5) = sqrt(ddot(n,r,r)) + fpar(11) = fpar(11) + 2 * n + if (ipar(3).lt.0) then + ! + ! compute the change in the solution vector + ! + fpar(6) = sx * sqrt(ddot(n,delx,delx)) + fpar(11) = fpar(11) + 2 * n + if (ipar(7).lt.mvpi+mvpi+1) then + ! + ! if this is the end of the first iteration, set fpar(3:4) + ! + fpar(3) = fpar(6) + if (ipar(3).eq.-1) then + fpar(4) = fpar(1) * fpar(3) + fpar(2) endif - if (ipar(6).gt.0 .and. ipar(7).ge.ipar(6)) then - ipar(1) = -1 - stopbis = .true. - endif - if (stopbis) return -! -! computes errors -! - fpar(5) = sqrt(ddot(n,r,r)) - fpar(11) = fpar(11) + 2 * n - if (ipar(3).lt.0) then -! -! compute the change in the solution vector -! - fpar(6) = sx * sqrt(ddot(n,delx,delx)) - fpar(11) = fpar(11) + 2 * n - if (ipar(7).lt.mvpi+mvpi+1) then -! -! if this is the end of the first iteration, set fpar(3:4) -! - fpar(3) = fpar(6) - if (ipar(3).eq.-1) then - fpar(4) = fpar(1) * fpar(3) + fpar(2) - endif - endif - else - fpar(6) = fpar(5) - endif -! -! .. the test is struct this way so that when the value in fpar(6) -! is not a valid number, STOPBIS is set to .true. -! - if (fpar(6).gt.fpar(4)) then - stopbis = .false. - ipar(11) = 0 - else - stopbis = .true. - ipar(11) = 1 - endif -! - return + endif + else + fpar(6) = fpar(5) + endif + ! + ! .. the test is struct this way so that when the value in fpar(6) + ! is not a valid number, STOPBIS is set to .true. + ! + if (fpar(6).gt.fpar(4)) then + stopbis = .false. + ipar(11) = 0 + else + stopbis = .true. + ipar(11) = 1 + endif + ! + return end function stopbis !-----end-of-stopbis !----------------------------------------------------------------------- - subroutine tidycg(n,ipar,fpar,sol,delx) - implicit none - integer i,n,ipar(16) - real*8 fpar(16),sol(n),delx(n) -!----------------------------------------------------------------------- -! Some common operations required before terminating the CG routines -!----------------------------------------------------------------------- - real*8 zero - parameter(zero=0.0D0) -! - if (ipar(12).ne.0) then - ipar(1) = ipar(12) - else if (ipar(1).gt.0) then - if ((ipar(3).eq.999 .and. ipar(11).eq.1) .or. & - & fpar(6).le.fpar(4)) then - ipar(1) = 0 - else if (ipar(7).ge.ipar(6) .and. ipar(6).gt.0) then - ipar(1) = -1 - else - ipar(1) = -10 - endif - endif - if (fpar(3).gt.zero .and. fpar(6).gt.zero .and. ipar(7).gt.ipar(13)) then - fpar(7) = log10(fpar(3) / fpar(6)) / dble(ipar(7)-ipar(13)) - else - fpar(7) = zero - endif - do i = 1, n - sol(i) = sol(i) + delx(i) - enddo - return +subroutine tidycg(n,ipar,fpar,sol,delx) + implicit none + integer i,n,ipar(16) + real*8 fpar(16),sol(n),delx(n) + !----------------------------------------------------------------------- + ! Some common operations required before terminating the CG routines + !----------------------------------------------------------------------- + real*8 zero + parameter(zero=0.0D0) + ! + if (ipar(12).ne.0) then + ipar(1) = ipar(12) + else if (ipar(1).gt.0) then + if ((ipar(3).eq.999 .and. ipar(11).eq.1) .or. & + & fpar(6).le.fpar(4)) then + ipar(1) = 0 + else if (ipar(7).ge.ipar(6) .and. ipar(6).gt.0) then + ipar(1) = -1 + else + ipar(1) = -10 + endif + endif + if (fpar(3).gt.zero .and. fpar(6).gt.zero .and. ipar(7).gt.ipar(13)) then + fpar(7) = log10(fpar(3) / fpar(6)) / dble(ipar(7)-ipar(13)) + else + fpar(7) = zero + endif + do i = 1, n + sol(i) = sol(i) + delx(i) + enddo + return end subroutine tidycg !-----end-of-tidycg !----------------------------------------------------------------------- - logical function brkdn(alpha, ipar) - implicit none - integer ipar(16) - real*8 alpha, beta, zero, one - parameter (zero=0.0D0, one=1.0D0) -!----------------------------------------------------------------------- -! test whether alpha is zero or an abnormal number, if yes, -! this routine will return .true. -! -! If alpha == 0, ipar(1) = -3, -! if alpha is an abnormal number, ipar(1) = -9. -!----------------------------------------------------------------------- - brkdn = .false. - if (alpha.gt.zero) then - beta = one / alpha - if (.not. beta.gt.zero) then - brkdn = .true. - ipar(1) = -9 - endif - else if (alpha.lt.zero) then - beta = one / alpha - if (.not. beta.lt.zero) then - brkdn = .true. - ipar(1) = -9 - endif - else if (alpha.eq.zero) then - brkdn = .true. - ipar(1) = -3 - else - brkdn = .true. - ipar(1) = -9 - endif - return +logical function brkdn(alpha, ipar) + implicit none + integer ipar(16) + real*8 alpha, beta, zero, one + parameter (zero=0.0D0, one=1.0D0) + !----------------------------------------------------------------------- + ! test whether alpha is zero or an abnormal number, if yes, + ! this routine will return .true. + ! + ! If alpha == 0, ipar(1) = -3, + ! if alpha is an abnormal number, ipar(1) = -9. + !----------------------------------------------------------------------- + brkdn = .false. + if (alpha.gt.zero) then + beta = one / alpha + if (.not. beta.gt.zero) then + brkdn = .true. + ipar(1) = -9 + endif + else if (alpha.lt.zero) then + beta = one / alpha + if (.not. beta.lt.zero) then + brkdn = .true. + ipar(1) = -9 + endif + else if (alpha.eq.zero) then + brkdn = .true. + ipar(1) = -3 + else + brkdn = .true. + ipar(1) = -9 + endif + return end function brkdn !-----end-of-brkdn !----------------------------------------------------------------------- - subroutine bisinit(ipar,fpar,wksize,dsc,lp,rp,wk) - implicit none - integer i,ipar(16),wksize,dsc - logical lp,rp - real*8 fpar(16),wk(*) -!----------------------------------------------------------------------- -! some common initializations for the iterative solvers -!----------------------------------------------------------------------- - real*8 zero, one - parameter(zero=0.0D0, one=1.0D0) -! -! ipar(1) = -2 inidcate that there are not enough space in the work -! array -! - if (ipar(4).lt.wksize) then - ipar(1) = -2 - ipar(4) = wksize - return - endif -! - if (ipar(2).gt.2) then - lp = .true. - rp = .true. - else if (ipar(2).eq.2) then - lp = .false. - rp = .true. - else if (ipar(2).eq.1) then - lp = .true. - rp = .false. - else - lp = .false. - rp = .false. - endif - if (ipar(3).eq.0) ipar(3) = dsc -! .. clear the ipar elements used - ipar(7) = 0 - ipar(8) = 0 - ipar(9) = 0 - ipar(10) = 0 - ipar(11) = 0 - ipar(12) = 0 - ipar(13) = 0 -! -! fpar(1) must be between (0, 1), fpar(2) must be positive, -! fpar(1) and fpar(2) can NOT both be zero -! Normally return ipar(1) = -4 to indicate any of above error -! - if (fpar(1).lt.zero .or. fpar(1).ge.one .or. fpar(2).lt.zero .or. & - & (fpar(1).eq.zero .and. fpar(2).eq.zero)) then - if (ipar(1).eq.0) then - ipar(1) = -4 - return - else - fpar(1) = 1.0D-6 - fpar(2) = 1.0D-16 - endif - endif -! .. clear the fpar elements - do i = 3, 10 - fpar(i) = zero - enddo - if (fpar(11).lt.zero) fpar(11) = zero -! .. clear the used portion of the work array to zero - do i = 1, wksize - wk(i) = zero - enddo -! +subroutine bisinit(ipar,fpar,wksize,dsc,lp,rp,wk) + implicit none + integer i,ipar(16),wksize,dsc + logical lp,rp + real*8 fpar(16),wk(*) + !----------------------------------------------------------------------- + ! some common initializations for the iterative solvers + !----------------------------------------------------------------------- + real*8 zero, one + parameter(zero=0.0D0, one=1.0D0) + ! + ! ipar(1) = -2 inidcate that there are not enough space in the work + ! array + ! + if (ipar(4).lt.wksize) then + ipar(1) = -2 + ipar(4) = wksize + return + endif + ! + if (ipar(2).gt.2) then + lp = .true. + rp = .true. + else if (ipar(2).eq.2) then + lp = .false. + rp = .true. + else if (ipar(2).eq.1) then + lp = .true. + rp = .false. + else + lp = .false. + rp = .false. + endif + if (ipar(3).eq.0) ipar(3) = dsc + ! .. clear the ipar elements used + ipar(7) = 0 + ipar(8) = 0 + ipar(9) = 0 + ipar(10) = 0 + ipar(11) = 0 + ipar(12) = 0 + ipar(13) = 0 + ! + ! fpar(1) must be between (0, 1), fpar(2) must be positive, + ! fpar(1) and fpar(2) can NOT both be zero + ! Normally return ipar(1) = -4 to indicate any of above error + ! + if (fpar(1).lt.zero .or. fpar(1).ge.one .or. fpar(2).lt.zero .or. & + & (fpar(1).eq.zero .and. fpar(2).eq.zero)) then + if (ipar(1).eq.0) then + ipar(1) = -4 return -!-----end-of-bisinit + else + fpar(1) = 1.0D-6 + fpar(2) = 1.0D-16 + endif + endif + ! .. clear the fpar elements + do i = 3, 10 + fpar(i) = zero + enddo + if (fpar(11).lt.zero) fpar(11) = zero + ! .. clear the used portion of the work array to zero + do i = 1, wksize + wk(i) = zero + enddo + ! + return + !-----end-of-bisinit end subroutine bisinit !----------------------------------------------------------------------- - subroutine mgsro(full,lda,n,m,ind,ops,vec,hh,ierr) - implicit none - logical full - integer lda,m,n,ind,ierr - real*8 ops,hh(m),vec(lda,m) -!----------------------------------------------------------------------- -! MGSRO -- Modified Gram-Schmidt procedure with Selective Re- -! Orthogonalization -! The ind'th vector of VEC is orthogonalized against the rest of -! the vectors. -! -! The test for performing re-orthogonalization is performed for -! each indivadual vectors. If the cosine between the two vectors -! is greater than 0.99 (REORTH = 0.99**2), re-orthogonalization is -! performed. The norm of the 'new' vector is kept in variable NRM0, -! and updated after operating with each vector. -! -! full -- .ture. if it is necessary to orthogonalize the ind'th -! against all the vectors vec(:,1:ind-1), vec(:,ind+2:m) -! .false. only orthogonalize againt vec(:,1:ind-1) -! lda -- the leading dimension of VEC -! n -- length of the vector in VEC -! m -- number of vectors can be stored in VEC -! ind -- index to the vector to be changed -! ops -- operation counts -! vec -- vector of LDA X M storing the vectors -! hh -- coefficient of the orthogonalization -! ierr -- error code -! 0 : successful return -! -1: zero input vector -! -2: input vector contains abnormal numbers -! -3: input vector is a linear combination of others -! -! External routines used: real*8 ddot -!----------------------------------------------------------------------- - integer i,k - real*8 nrm0, nrm1, fct, thr, ddot, zero, one, reorth - parameter (zero=0.0D0, one=1.0D0, reorth=0.98D0) - external ddot -! -! compute the norm of the input vector -! - nrm0 = ddot(n,vec(1,ind),vec(1,ind)) - ops = ops + n + n - thr = nrm0 * reorth - if (nrm0.le.zero) then - ierr = - 1 - return - else if (nrm0.gt.zero .and. one/nrm0.gt.zero) then - ierr = 0 - else - ierr = -2 - return - endif -! -! Modified Gram-Schmidt loop -! - if (full) then - do i = ind+1, m - fct = ddot(n,vec(1,ind),vec(1,i)) - hh(i) = fct +subroutine mgsro(full,lda,n,m,ind,ops,vec,hh,ierr) + implicit none + logical full + integer lda,m,n,ind,ierr + real*8 ops,hh(m),vec(lda,m) + !----------------------------------------------------------------------- + ! MGSRO -- Modified Gram-Schmidt procedure with Selective Re- + ! Orthogonalization + ! The ind'th vector of VEC is orthogonalized against the rest of + ! the vectors. + ! + ! The test for performing re-orthogonalization is performed for + ! each indivadual vectors. If the cosine between the two vectors + ! is greater than 0.99 (REORTH = 0.99**2), re-orthogonalization is + ! performed. The norm of the 'new' vector is kept in variable NRM0, + ! and updated after operating with each vector. + ! + ! full -- .ture. if it is necessary to orthogonalize the ind'th + ! against all the vectors vec(:,1:ind-1), vec(:,ind+2:m) + ! .false. only orthogonalize againt vec(:,1:ind-1) + ! lda -- the leading dimension of VEC + ! n -- length of the vector in VEC + ! m -- number of vectors can be stored in VEC + ! ind -- index to the vector to be changed + ! ops -- operation counts + ! vec -- vector of LDA X M storing the vectors + ! hh -- coefficient of the orthogonalization + ! ierr -- error code + ! 0 : successful return + ! -1: zero input vector + ! -2: input vector contains abnormal numbers + ! -3: input vector is a linear combination of others + ! + ! External routines used: real*8 ddot + !----------------------------------------------------------------------- + integer i,k + real*8 nrm0, nrm1, fct, thr, ddot, zero, one, reorth + parameter (zero=0.0D0, one=1.0D0, reorth=0.98D0) + external ddot + ! + ! compute the norm of the input vector + ! + nrm0 = ddot(n,vec(1,ind),vec(1,ind)) + ops = ops + n + n + thr = nrm0 * reorth + if (nrm0.le.zero) then + ierr = - 1 + return + else if (nrm0.gt.zero .and. one/nrm0.gt.zero) then + ierr = 0 + else + ierr = -2 + return + endif + ! + ! Modified Gram-Schmidt loop + ! + if (full) then + do i = ind+1, m + fct = ddot(n,vec(1,ind),vec(1,i)) + hh(i) = fct + do k = 1, n + vec(k,ind) = vec(k,ind) - fct * vec(k,i) + end do + ops = ops + 4 * n + 2 + if (fct*fct.gt.thr) then + fct = ddot(n,vec(1,ind),vec(1,i)) + hh(i) = hh(i) + fct do k = 1, n - vec(k,ind) = vec(k,ind) - fct * vec(k,i) + vec(k,ind) = vec(k,ind) - fct * vec(k,i) end do - ops = ops + 4 * n + 2 - if (fct*fct.gt.thr) then - fct = ddot(n,vec(1,ind),vec(1,i)) - hh(i) = hh(i) + fct - do k = 1, n - vec(k,ind) = vec(k,ind) - fct * vec(k,i) - end do - ops = ops + 4*n + 1 - endif - nrm0 = nrm0 - hh(i) * hh(i) - if (nrm0.lt.zero) nrm0 = zero - thr = nrm0 * reorth - end do + ops = ops + 4*n + 1 endif -! + nrm0 = nrm0 - hh(i) * hh(i) + if (nrm0.lt.zero) nrm0 = zero + thr = nrm0 * reorth + end do + endif + ! do i = 1, ind-1 - fct = ddot(n,vec(1,ind),vec(1,i)) - hh(i) = fct - do k = 1, n - vec(k,ind) = vec(k,ind) - fct * vec(k,i) - end do - ops = ops + 4 * n + 2 - if (fct*fct.gt.thr) then - fct = ddot(n,vec(1,ind),vec(1,i)) - hh(i) = hh(i) + fct - do k = 1, n - vec(k,ind) = vec(k,ind) - fct * vec(k,i) - end do - ops = ops + 4*n + 1 - endif - nrm0 = nrm0 - hh(i) * hh(i) - if (nrm0.lt.zero) nrm0 = zero - thr = nrm0 * reorth + fct = ddot(n,vec(1,ind),vec(1,i)) + hh(i) = fct + do k = 1, n + vec(k,ind) = vec(k,ind) - fct * vec(k,i) + end do + ops = ops + 4 * n + 2 + if (fct*fct.gt.thr) then + fct = ddot(n,vec(1,ind),vec(1,i)) + hh(i) = hh(i) + fct + do k = 1, n + vec(k,ind) = vec(k,ind) - fct * vec(k,i) + end do + ops = ops + 4*n + 1 + endif + nrm0 = nrm0 - hh(i) * hh(i) + if (nrm0.lt.zero) nrm0 = zero + thr = nrm0 * reorth end do -! -! test the resulting vector -! - nrm1 = sqrt(ddot(n,vec(1,ind),vec(1,ind))) - ops = ops + n + n - hh(ind) = nrm1 ! statement label 75 - if (nrm1.le.zero) then - ierr = -3 - return - endif -! -! scale the resulting vector -! - fct = one / nrm1 + ! + ! test the resulting vector + ! + nrm1 = sqrt(ddot(n,vec(1,ind),vec(1,ind))) + ops = ops + n + n + hh(ind) = nrm1 ! statement label 75 + if (nrm1.le.zero) then + ierr = -3 + return + endif + ! + ! scale the resulting vector + ! + fct = one / nrm1 do k = 1, n - vec(k,ind) = vec(k,ind) * fct + vec(k,ind) = vec(k,ind) * fct end do - ops = ops + n + 1 -! -! normal return -! - ierr = 0 - return + ops = ops + n + 1 + ! + ! normal return + ! + ierr = 0 + return ! end subroutine mgsro end subroutine mgsro !----------------------------------------------------------------------c @@ -2813,1002 +2813,1002 @@ end subroutine mgsro !----------------------------------------------------------------------c ! 1) M A T R I X B Y V E C T O R P R O D U C T S c !----------------------------------------------------------------------c - subroutine amux (n, x, y, a,ja,ia) - real*8 x(*), y(*), a(*) - integer n, ja(*), ia(*) -!----------------------------------------------------------------------- -! A times a vector -!----------------------------------------------------------------------- -! multiplies a matrix by a vector using the dot product form -! Matrix A is stored in compressed sparse row storage. -! -! on entry: -!---------- -! n = row dimension of A -! x = real array of length equal to the column dimension of -! the A matrix. -! a, ja, -! ia = input matrix in compressed sparse row format. -! -! on return: -!----------- -! y = real array of length n, containing the product y=Ax -! -!----------------------------------------------------------------------- -! local variables -! - real*8 t - integer i, k -!----------------------------------------------------------------------- +subroutine amux (n, x, y, a,ja,ia) + real*8 x(*), y(*), a(*) + integer n, ja(*), ia(*) + !----------------------------------------------------------------------- + ! A times a vector + !----------------------------------------------------------------------- + ! multiplies a matrix by a vector using the dot product form + ! Matrix A is stored in compressed sparse row storage. + ! + ! on entry: + !---------- + ! n = row dimension of A + ! x = real array of length equal to the column dimension of + ! the A matrix. + ! a, ja, + ! ia = input matrix in compressed sparse row format. + ! + ! on return: + !----------- + ! y = real array of length n, containing the product y=Ax + ! + !----------------------------------------------------------------------- + ! local variables + ! + real*8 t + integer i, k + !----------------------------------------------------------------------- do i = 1,n -! -! compute the inner product of row i with vector x -! - t = 0.0d0 - do k=ia(i), ia(i+1)-1 - t = t + a(k)*x(ja(k)) - end do -! -! store result in y(i) -! - y(i) = t + ! + ! compute the inner product of row i with vector x + ! + t = 0.0d0 + do k=ia(i), ia(i+1)-1 + t = t + a(k)*x(ja(k)) + end do + ! + ! store result in y(i) + ! + y(i) = t end do -! - return -!---------end-of-amux--------------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !---------end-of-amux--------------------------------------------------- + !----------------------------------------------------------------------- end subroutine amux !----------------------------------------------------------------------- - subroutine amuxms (n, x, y, a,ja) - real*8 x(*), y(*), a(*) - integer n, ja(*) -!----------------------------------------------------------------------- -! A times a vector in MSR format -!----------------------------------------------------------------------- -! multiplies a matrix by a vector using the dot product form -! Matrix A is stored in Modified Sparse Row storage. -! -! on entry: -!---------- -! n = row dimension of A -! x = real array of length equal to the column dimension of -! the A matrix. -! a, ja,= input matrix in modified compressed sparse row format. -! -! on return: -!----------- -! y = real array of length n, containing the product y=Ax -! -!----------------------------------------------------------------------- -! local variables -! - integer i, k -!----------------------------------------------------------------------- +subroutine amuxms (n, x, y, a,ja) + real*8 x(*), y(*), a(*) + integer n, ja(*) + !----------------------------------------------------------------------- + ! A times a vector in MSR format + !----------------------------------------------------------------------- + ! multiplies a matrix by a vector using the dot product form + ! Matrix A is stored in Modified Sparse Row storage. + ! + ! on entry: + !---------- + ! n = row dimension of A + ! x = real array of length equal to the column dimension of + ! the A matrix. + ! a, ja,= input matrix in modified compressed sparse row format. + ! + ! on return: + !----------- + ! y = real array of length n, containing the product y=Ax + ! + !----------------------------------------------------------------------- + ! local variables + ! + integer i, k + !----------------------------------------------------------------------- do i=1, n - y(i) = a(i)*x(i) + y(i) = a(i)*x(i) end do do i = 1,n -! -! compute the inner product of row i with vector x -! - do k=ja(i), ja(i+1)-1 - y(i) = y(i) + a(k) *x(ja(k)) - end do + ! + ! compute the inner product of row i with vector x + ! + do k=ja(i), ja(i+1)-1 + y(i) = y(i) + a(k) *x(ja(k)) + end do end do -! - return -!---------end-of-amuxm-------------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !---------end-of-amuxm-------------------------------------------------- + !----------------------------------------------------------------------- end subroutine amuxms !----------------------------------------------------------------------- - subroutine atmux (n, x, y, a, ja, ia) - real*8 x(*), y(*), a(*) - integer n, ia(*), ja(*) -!----------------------------------------------------------------------- -! transp( A ) times a vector -!----------------------------------------------------------------------- -! multiplies the transpose of a matrix by a vector when the original -! matrix is stored in compressed sparse row storage. Can also be -! viewed as the product of a matrix by a vector when the original -! matrix is stored in the compressed sparse column format. -!----------------------------------------------------------------------- -! -! on entry: -!---------- -! n = row dimension of A -! x = real array of length equal to the column dimension of -! the A matrix. -! a, ja, -! ia = input matrix in compressed sparse row format. -! -! on return: -!----------- -! y = real array of length n, containing the product y=transp(A)*x -! -!----------------------------------------------------------------------- -! local variables -! - integer i, k -!----------------------------------------------------------------------- -! -! zero out output vector -! +subroutine atmux (n, x, y, a, ja, ia) + real*8 x(*), y(*), a(*) + integer n, ia(*), ja(*) + !----------------------------------------------------------------------- + ! transp( A ) times a vector + !----------------------------------------------------------------------- + ! multiplies the transpose of a matrix by a vector when the original + ! matrix is stored in compressed sparse row storage. Can also be + ! viewed as the product of a matrix by a vector when the original + ! matrix is stored in the compressed sparse column format. + !----------------------------------------------------------------------- + ! + ! on entry: + !---------- + ! n = row dimension of A + ! x = real array of length equal to the column dimension of + ! the A matrix. + ! a, ja, + ! ia = input matrix in compressed sparse row format. + ! + ! on return: + !----------- + ! y = real array of length n, containing the product y=transp(A)*x + ! + !----------------------------------------------------------------------- + ! local variables + ! + integer i, k + !----------------------------------------------------------------------- + ! + ! zero out output vector + ! do i=1,n - y(i) = 0.0 + y(i) = 0.0 end do -! -! loop over the rows -! + ! + ! loop over the rows + ! do i = 1,n - do k=ia(i), ia(i+1)-1 - y(ja(k)) = y(ja(k)) + x(i)*a(k) - end do + do k=ia(i), ia(i+1)-1 + y(ja(k)) = y(ja(k)) + x(i)*a(k) + end do end do -! - return -!-------------end-of-atmux---------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !-------------end-of-atmux---------------------------------------------- + !----------------------------------------------------------------------- end subroutine atmux -!----------------------------------------------------------------------- - subroutine atmuxr (m, n, x, y, a, ja, ia) - real*8 x(*), y(*), a(*) - integer m, n, ia(*), ja(*) !----------------------------------------------------------------------- -! transp( A ) times a vector, A can be rectangular -!----------------------------------------------------------------------- -! See also atmux. The essential difference is how the solution vector -! is initially zeroed. If using this to multiply rectangular CSC -! matrices by a vector, m number of rows, n is number of columns. -!----------------------------------------------------------------------- -! -! on entry: -!---------- -! m = column dimension of A -! n = row dimension of A -! x = real array of length equal to the column dimension of -! the A matrix. -! a, ja, -! ia = input matrix in compressed sparse row format. -! -! on return: -!----------- -! y = real array of length n, containing the product y=transp(A)*x -! -!----------------------------------------------------------------------- -! local variables -! - integer i, k -!----------------------------------------------------------------------- -! -! zero out output vector -! +subroutine atmuxr (m, n, x, y, a, ja, ia) + real*8 x(*), y(*), a(*) + integer m, n, ia(*), ja(*) + !----------------------------------------------------------------------- + ! transp( A ) times a vector, A can be rectangular + !----------------------------------------------------------------------- + ! See also atmux. The essential difference is how the solution vector + ! is initially zeroed. If using this to multiply rectangular CSC + ! matrices by a vector, m number of rows, n is number of columns. + !----------------------------------------------------------------------- + ! + ! on entry: + !---------- + ! m = column dimension of A + ! n = row dimension of A + ! x = real array of length equal to the column dimension of + ! the A matrix. + ! a, ja, + ! ia = input matrix in compressed sparse row format. + ! + ! on return: + !----------- + ! y = real array of length n, containing the product y=transp(A)*x + ! + !----------------------------------------------------------------------- + ! local variables + ! + integer i, k + !----------------------------------------------------------------------- + ! + ! zero out output vector + ! do i=1,m - y(i) = 0.0 + y(i) = 0.0 end do -! -! loop over the rows -! + ! + ! loop over the rows + ! do i = 1,n - do k=ia(i), ia(i+1)-1 - y(ja(k)) = y(ja(k)) + x(i)*a(k) - end do + do k=ia(i), ia(i+1)-1 + y(ja(k)) = y(ja(k)) + x(i)*a(k) + end do end do -! - return -!-------------end-of-atmuxr--------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !-------------end-of-atmuxr--------------------------------------------- + !----------------------------------------------------------------------- end subroutine atmuxr -!----------------------------------------------------------------------- - subroutine amuxe (n,x,y,na,ncol,a,ja) - implicit none - - integer :: n, na, ncol, ja(na,*) - real*8 :: x(n), y(n), a(na,*) - -!----------------------------------------------------------------------- -! A times a vector in Ellpack Itpack format (ELL) -!----------------------------------------------------------------------- -! multiplies a matrix by a vector when the original matrix is stored -! in the ellpack-itpack sparse format. -!----------------------------------------------------------------------- -! -! on entry: -!---------- -! n = row dimension of A -! x = real array of length equal to the column dimension of -! the A matrix. -! na = integer. The first dimension of arrays a and ja -! as declared by the calling program. -! ncol = integer. The number of active columns in array a. -! (i.e., the number of generalized diagonals in matrix.) -! a, ja = the real and integer arrays of the itpack format -! (a(i,k),k=1,ncol contains the elements of row i in matrix -! ja(i,k),k=1,ncol contains their column numbers) -! -! on return: -!----------- -! y = real array of length n, containing the product y=y=A*x -! -!----------------------------------------------------------------------- -! local variables -! - integer i, j !----------------------------------------------------------------------- +subroutine amuxe (n,x,y,na,ncol,a,ja) + implicit none + + integer :: n, na, ncol, ja(na,*) + real*8 :: x(n), y(n), a(na,*) + + !----------------------------------------------------------------------- + ! A times a vector in Ellpack Itpack format (ELL) + !----------------------------------------------------------------------- + ! multiplies a matrix by a vector when the original matrix is stored + ! in the ellpack-itpack sparse format. + !----------------------------------------------------------------------- + ! + ! on entry: + !---------- + ! n = row dimension of A + ! x = real array of length equal to the column dimension of + ! the A matrix. + ! na = integer. The first dimension of arrays a and ja + ! as declared by the calling program. + ! ncol = integer. The number of active columns in array a. + ! (i.e., the number of generalized diagonals in matrix.) + ! a, ja = the real and integer arrays of the itpack format + ! (a(i,k),k=1,ncol contains the elements of row i in matrix + ! ja(i,k),k=1,ncol contains their column numbers) + ! + ! on return: + !----------- + ! y = real array of length n, containing the product y=y=A*x + ! + !----------------------------------------------------------------------- + ! local variables + ! + integer i, j + !----------------------------------------------------------------------- do i=1, n - y(i) = 0.0 + y(i) = 0.0 end do do j=1,ncol - do i = 1,n - y(i) = y(i)+a(i,j)*x(ja(i,j)) - end do + do i = 1,n + y(i) = y(i)+a(i,j)*x(ja(i,j)) + end do end do -! - return -!--------end-of-amuxe--------------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !--------end-of-amuxe--------------------------------------------------- + !----------------------------------------------------------------------- end subroutine amuxe !----------------------------------------------------------------------- - subroutine amuxd (n,x,y,diag,ndiag,idiag,ioff) - integer n, ndiag, idiag, ioff(idiag) - real*8 x(n), y(n), diag(ndiag,idiag) -!----------------------------------------------------------------------- -! A times a vector in Diagonal storage format (DIA) -!----------------------------------------------------------------------- -! multiplies a matrix by a vector when the original matrix is stored -! in the diagonal storage format. -!----------------------------------------------------------------------- -! -! on entry: -!---------- -! n = row dimension of A -! x = real array of length equal to the column dimension of -! the A matrix. -! ndiag = integer. The first dimension of array adiag as declared in -! the calling program. -! idiag = integer. The number of diagonals in the matrix. -! diag = real array containing the diagonals stored of A. -! idiag = number of diagonals in matrix. -! diag = real array of size (ndiag x idiag) containing the diagonals -! -! ioff = integer array of length idiag, containing the offsets of the -! diagonals of the matrix: -! diag(i,k) contains the element a(i,i+ioff(k)) of the matrix. -! -! on return: -!----------- -! y = real array of length n, containing the product y=A*x -! -!----------------------------------------------------------------------- -! local variables -! - integer j, k, io, i1, i2 -!----------------------------------------------------------------------- +subroutine amuxd (n,x,y,diag,ndiag,idiag,ioff) + integer n, ndiag, idiag, ioff(idiag) + real*8 x(n), y(n), diag(ndiag,idiag) + !----------------------------------------------------------------------- + ! A times a vector in Diagonal storage format (DIA) + !----------------------------------------------------------------------- + ! multiplies a matrix by a vector when the original matrix is stored + ! in the diagonal storage format. + !----------------------------------------------------------------------- + ! + ! on entry: + !---------- + ! n = row dimension of A + ! x = real array of length equal to the column dimension of + ! the A matrix. + ! ndiag = integer. The first dimension of array adiag as declared in + ! the calling program. + ! idiag = integer. The number of diagonals in the matrix. + ! diag = real array containing the diagonals stored of A. + ! idiag = number of diagonals in matrix. + ! diag = real array of size (ndiag x idiag) containing the diagonals + ! + ! ioff = integer array of length idiag, containing the offsets of the + ! diagonals of the matrix: + ! diag(i,k) contains the element a(i,i+ioff(k)) of the matrix. + ! + ! on return: + !----------- + ! y = real array of length n, containing the product y=A*x + ! + !----------------------------------------------------------------------- + ! local variables + ! + integer j, k, io, i1, i2 + !----------------------------------------------------------------------- do j=1, n - y(j) = 0.0d0 + y(j) = 0.0d0 end do do j=1, idiag - io = ioff(j) - i1 = max0(1,1-io) - i2 = min0(n,n-io) - do k=i1, i2 - y(k) = y(k)+diag(k,j)*x(k+io) - end do + io = ioff(j) + i1 = max0(1,1-io) + i2 = min0(n,n-io) + do k=i1, i2 + y(k) = y(k)+diag(k,j)*x(k+io) + end do end do -! - return -!----------end-of-amuxd------------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !----------end-of-amuxd------------------------------------------------- + !----------------------------------------------------------------------- end subroutine amuxd !----------------------------------------------------------------------- - subroutine amuxj (n, x, y, jdiag, a, ja, ia) - integer n, jdiag, ja(*), ia(*) - real*8 x(n), y(n), a(*) -!----------------------------------------------------------------------- -! A times a vector in Jagged-Diagonal storage format (JAD) -!----------------------------------------------------------------------- -! multiplies a matrix by a vector when the original matrix is stored -! in the jagged diagonal storage format. -!----------------------------------------------------------------------- -! -! on entry: -!---------- -! n = row dimension of A -! x = real array of length equal to the column dimension of -! the A matrix. -! jdiag = integer. The number of jadded-diagonals in the data-structure. -! a = real array containing the jadded diagonals of A stored -! in succession (in decreasing lengths) -! j = integer array containing the colum indices of the -! corresponding elements in a. -! ia = integer array containing the lengths of the jagged diagonals -! -! on return: -!----------- -! y = real array of length n, containing the product y=A*x -! -! Note: -!------- -! Permutation related to the JAD format is not performed. -! this can be done by: -! call permvec (n,y,y,iperm) -! after the call to amuxj, where iperm is the permutation produced -! by csrjad. -!----------------------------------------------------------------------- -! local variables -! - integer i, ii, k1, ilen, j -!----------------------------------------------------------------------- +subroutine amuxj (n, x, y, jdiag, a, ja, ia) + integer n, jdiag, ja(*), ia(*) + real*8 x(n), y(n), a(*) + !----------------------------------------------------------------------- + ! A times a vector in Jagged-Diagonal storage format (JAD) + !----------------------------------------------------------------------- + ! multiplies a matrix by a vector when the original matrix is stored + ! in the jagged diagonal storage format. + !----------------------------------------------------------------------- + ! + ! on entry: + !---------- + ! n = row dimension of A + ! x = real array of length equal to the column dimension of + ! the A matrix. + ! jdiag = integer. The number of jadded-diagonals in the data-structure. + ! a = real array containing the jadded diagonals of A stored + ! in succession (in decreasing lengths) + ! j = integer array containing the colum indices of the + ! corresponding elements in a. + ! ia = integer array containing the lengths of the jagged diagonals + ! + ! on return: + !----------- + ! y = real array of length n, containing the product y=A*x + ! + ! Note: + !------- + ! Permutation related to the JAD format is not performed. + ! this can be done by: + ! call permvec (n,y,y,iperm) + ! after the call to amuxj, where iperm is the permutation produced + ! by csrjad. + !----------------------------------------------------------------------- + ! local variables + ! + integer i, ii, k1, ilen, j + !----------------------------------------------------------------------- do i=1, n - y(i) = 0.0d0 + y(i) = 0.0d0 end do do ii=1, jdiag - k1 = ia(ii)-1 - ilen = ia(ii+1)-k1-1 - do j=1,ilen - y(j)= y(j)+a(k1+j)*x(ja(k1+j)) - end do + k1 = ia(ii)-1 + ilen = ia(ii+1)-k1-1 + do j=1,ilen + y(j)= y(j)+a(k1+j)*x(ja(k1+j)) + end do end do -! - return -!----------end-of-amuxj------------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !----------end-of-amuxj------------------------------------------------- + !----------------------------------------------------------------------- end subroutine amuxj !----------------------------------------------------------------------- - subroutine vbrmv(nr, nc, ia, ja, ka, a, kvstr, kvstc, x, b) -!----------------------------------------------------------------------- - integer nr, nc, ia(nr+1), ja(*), ka(*), kvstr(nr+1), kvstc(*) - real*8 a(*), x(*), b(*) -!----------------------------------------------------------------------- -! Sparse matrix-full vector product, in VBR format. -!----------------------------------------------------------------------- -! On entry: -!-------------- -! nr, nc = number of block rows and columns in matrix A -! ia,ja,ka,a,kvstr,kvstc = matrix A in variable block row format -! x = multiplier vector in full format -! -! On return: -!--------------- -! b = product of matrix A times vector x in full format -! -! Algorithm: -!--------------- -! Perform multiplication by traversing a in order. -! -!----------------------------------------------------------------------- -!-----local variables - integer n, i, j, ii, jj, k, istart, istop - real*8 xjj -!--------------------------------- - n = kvstc(nc+1)-1 - do i = 1, n - b(i) = 0.d0 - enddo -!--------------------------------- - k = 1 - do i = 1, nr - istart = kvstr(i) - istop = kvstr(i+1)-1 - do j = ia(i), ia(i+1)-1 - do jj = kvstc(ja(j)), kvstc(ja(j)+1)-1 - xjj = x(jj) - do ii = istart, istop - b(ii) = b(ii) + xjj*a(k) - k = k + 1 - enddo - enddo - enddo +subroutine vbrmv(nr, nc, ia, ja, ka, a, kvstr, kvstc, x, b) + !----------------------------------------------------------------------- + integer nr, nc, ia(nr+1), ja(*), ka(*), kvstr(nr+1), kvstc(*) + real*8 a(*), x(*), b(*) + !----------------------------------------------------------------------- + ! Sparse matrix-full vector product, in VBR format. + !----------------------------------------------------------------------- + ! On entry: + !-------------- + ! nr, nc = number of block rows and columns in matrix A + ! ia,ja,ka,a,kvstr,kvstc = matrix A in variable block row format + ! x = multiplier vector in full format + ! + ! On return: + !--------------- + ! b = product of matrix A times vector x in full format + ! + ! Algorithm: + !--------------- + ! Perform multiplication by traversing a in order. + ! + !----------------------------------------------------------------------- + !-----local variables + integer n, i, j, ii, jj, k, istart, istop + real*8 xjj + !--------------------------------- + n = kvstc(nc+1)-1 + do i = 1, n + b(i) = 0.d0 + enddo + !--------------------------------- + k = 1 + do i = 1, nr + istart = kvstr(i) + istop = kvstr(i+1)-1 + do j = ia(i), ia(i+1)-1 + do jj = kvstc(ja(j)), kvstc(ja(j)+1)-1 + xjj = x(jj) + do ii = istart, istop + b(ii) = b(ii) + xjj*a(k) + k = k + 1 + enddo enddo -!--------------------------------- - return + enddo + enddo + !--------------------------------- + return end subroutine vbrmv !----------------------------------------------------------------------- !----------------------end-of-vbrmv------------------------------------- !----------------------------------------------------------------------- -!----------------------------------------------------------------------c -! 2) T R I A N G U L A R S Y S T E M S O L U T I O N S c -!----------------------------------------------------------------------c - subroutine lsol (n,x,y,al,jal,ial) - integer n, jal(*),ial(n+1) - real*8 x(n), y(n), al(*) -!----------------------------------------------------------------------- -! solves L x = y ; L = lower unit triang. / CSR format -!----------------------------------------------------------------------- -! solves a unit lower triangular system by standard (sequential ) -! forward elimination - matrix stored in CSR format. -!----------------------------------------------------------------------- -! -! On entry: -!---------- -! n = integer. dimension of problem. -! y = real array containg the right side. -! -! al, -! jal, -! ial, = Lower triangular matrix stored in compressed sparse row -! format. -! -! On return: -!----------- -! x = The solution of L x = y. -!-------------------------------------------------------------------- -! local variables -! - integer k, j - real*8 t -!----------------------------------------------------------------------- - x(1) = y(1) - do k = 2, n - t = y(k) - do j = ial(k), ial(k+1)-1 - t = t-al(j)*x(jal(j)) - end do - x(k) = t - end do -! - return -!----------end-of-lsol-------------------------------------------------- -!----------------------------------------------------------------------- -end subroutine lsol -!----------------------------------------------------------------------- - subroutine ldsol (n,x,y,al,jal) - integer n, jal(*) - real*8 x(n), y(n), al(*) -!----------------------------------------------------------------------- -! Solves L x = y L = triangular. MSR format -!----------------------------------------------------------------------- -! solves a (non-unit) lower triangular system by standard (sequential) -! forward elimination - matrix stored in MSR format -! with diagonal elements already inverted (otherwise do inversion, -! al(1:n) = 1.0/al(1:n), before calling ldsol). -!----------------------------------------------------------------------- -! -! On entry: -!---------- -! n = integer. dimension of problem. -! y = real array containg the right hand side. -! -! al, -! jal, = Lower triangular matrix stored in Modified Sparse Row -! format. -! -! On return: -!----------- -! x = The solution of L x = y . -!-------------------------------------------------------------------- -! local variables -! - integer k, j - real*8 t -!----------------------------------------------------------------------- - x(1) = y(1)*al(1) +!----------------------------------------------------------------------c +! 2) T R I A N G U L A R S Y S T E M S O L U T I O N S c +!----------------------------------------------------------------------c +subroutine lsol (n,x,y,al,jal,ial) + integer n, jal(*),ial(n+1) + real*8 x(n), y(n), al(*) + !----------------------------------------------------------------------- + ! solves L x = y ; L = lower unit triang. / CSR format + !----------------------------------------------------------------------- + ! solves a unit lower triangular system by standard (sequential ) + ! forward elimination - matrix stored in CSR format. + !----------------------------------------------------------------------- + ! + ! On entry: + !---------- + ! n = integer. dimension of problem. + ! y = real array containg the right side. + ! + ! al, + ! jal, + ! ial, = Lower triangular matrix stored in compressed sparse row + ! format. + ! + ! On return: + !----------- + ! x = The solution of L x = y. + !-------------------------------------------------------------------- + ! local variables + ! + integer k, j + real*8 t + !----------------------------------------------------------------------- + x(1) = y(1) do k = 2, n - t = y(k) - do j = jal(k), jal(k+1)-1 - t = t - al(j)*x(jal(j)) - end do - x(k) = al(k)*t + t = y(k) + do j = ial(k), ial(k+1)-1 + t = t-al(j)*x(jal(j)) + end do + x(k) = t end do - return -!----------end-of-ldsol------------------------------------------------- + ! + return + !----------end-of-lsol-------------------------------------------------- + !----------------------------------------------------------------------- +end subroutine lsol !----------------------------------------------------------------------- +subroutine ldsol (n,x,y,al,jal) + integer n, jal(*) + real*8 x(n), y(n), al(*) + !----------------------------------------------------------------------- + ! Solves L x = y L = triangular. MSR format + !----------------------------------------------------------------------- + ! solves a (non-unit) lower triangular system by standard (sequential) + ! forward elimination - matrix stored in MSR format + ! with diagonal elements already inverted (otherwise do inversion, + ! al(1:n) = 1.0/al(1:n), before calling ldsol). + !----------------------------------------------------------------------- + ! + ! On entry: + !---------- + ! n = integer. dimension of problem. + ! y = real array containg the right hand side. + ! + ! al, + ! jal, = Lower triangular matrix stored in Modified Sparse Row + ! format. + ! + ! On return: + !----------- + ! x = The solution of L x = y . + !-------------------------------------------------------------------- + ! local variables + ! + integer k, j + real*8 t + !----------------------------------------------------------------------- + x(1) = y(1)*al(1) + do k = 2, n + t = y(k) + do j = jal(k), jal(k+1)-1 + t = t - al(j)*x(jal(j)) + end do + x(k) = al(k)*t + end do + return + !----------end-of-ldsol------------------------------------------------- + !----------------------------------------------------------------------- end subroutine ldsol !----------------------------------------------------------------------- - subroutine lsolc (n,x,y,al,jal,ial) - integer n, jal(*),ial(*) - real*8 x(n), y(n), al(*) -!----------------------------------------------------------------------- -! SOLVES L x = y ; where L = unit lower trang. CSC format -!----------------------------------------------------------------------- -! solves a unit lower triangular system by standard (sequential ) -! forward elimination - matrix stored in CSC format. -!----------------------------------------------------------------------- -! -! On entry: -!---------- -! n = integer. dimension of problem. -! y = real*8 array containg the right side. -! -! al, -! jal, -! ial, = Lower triangular matrix stored in compressed sparse column -! format. -! -! On return: -!----------- -! x = The solution of L x = y. -!----------------------------------------------------------------------- -! local variables -! - integer k, j - real*8 t -!----------------------------------------------------------------------- +subroutine lsolc (n,x,y,al,jal,ial) + integer n, jal(*),ial(*) + real*8 x(n), y(n), al(*) + !----------------------------------------------------------------------- + ! SOLVES L x = y ; where L = unit lower trang. CSC format + !----------------------------------------------------------------------- + ! solves a unit lower triangular system by standard (sequential ) + ! forward elimination - matrix stored in CSC format. + !----------------------------------------------------------------------- + ! + ! On entry: + !---------- + ! n = integer. dimension of problem. + ! y = real*8 array containg the right side. + ! + ! al, + ! jal, + ! ial, = Lower triangular matrix stored in compressed sparse column + ! format. + ! + ! On return: + !----------- + ! x = The solution of L x = y. + !----------------------------------------------------------------------- + ! local variables + ! + integer k, j + real*8 t + !----------------------------------------------------------------------- do k=1,n - x(k) = y(k) + x(k) = y(k) end do do k = 1, n-1 - t = x(k) - do j = ial(k), ial(k+1)-1 - x(jal(j)) = x(jal(j)) - t*al(j) - end do + t = x(k) + do j = ial(k), ial(k+1)-1 + x(jal(j)) = x(jal(j)) - t*al(j) + end do end do -! - return -!----------end-of-lsolc------------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !----------end-of-lsolc------------------------------------------------- + !----------------------------------------------------------------------- end subroutine lsolc !----------------------------------------------------------------------- - subroutine ldsolc (n,x,y,al,jal) - integer n, jal(*) - real*8 x(n), y(n), al(*) -!----------------------------------------------------------------------- -! Solves L x = y ; L = nonunit Low. Triang. MSC format -!----------------------------------------------------------------------- -! solves a (non-unit) lower triangular system by standard (sequential) -! forward elimination - matrix stored in Modified Sparse Column format -! with diagonal elements already inverted (otherwise do inversion, -! al(1:n) = 1.0/al(1:n), before calling ldsol). -!----------------------------------------------------------------------- -! -! On entry: -!---------- -! n = integer. dimension of problem. -! y = real array containg the right hand side. -! -! al, -! jal, -! ial, = Lower triangular matrix stored in Modified Sparse Column -! format. -! -! On return: -!----------- -! x = The solution of L x = y . -!-------------------------------------------------------------------- -! local variables -! - integer k, j - real*8 t -!----------------------------------------------------------------------- +subroutine ldsolc (n,x,y,al,jal) + integer n, jal(*) + real*8 x(n), y(n), al(*) + !----------------------------------------------------------------------- + ! Solves L x = y ; L = nonunit Low. Triang. MSC format + !----------------------------------------------------------------------- + ! solves a (non-unit) lower triangular system by standard (sequential) + ! forward elimination - matrix stored in Modified Sparse Column format + ! with diagonal elements already inverted (otherwise do inversion, + ! al(1:n) = 1.0/al(1:n), before calling ldsol). + !----------------------------------------------------------------------- + ! + ! On entry: + !---------- + ! n = integer. dimension of problem. + ! y = real array containg the right hand side. + ! + ! al, + ! jal, + ! ial, = Lower triangular matrix stored in Modified Sparse Column + ! format. + ! + ! On return: + !----------- + ! x = The solution of L x = y . + !-------------------------------------------------------------------- + ! local variables + ! + integer k, j + real*8 t + !----------------------------------------------------------------------- do k=1,n - x(k) = y(k) + x(k) = y(k) end do - do k = 1, n - x(k) = x(k)*al(k) - t = x(k) - do j = jal(k), jal(k+1)-1 - x(jal(j)) = x(jal(j)) - t*al(j) - end do + do k = 1, n + x(k) = x(k)*al(k) + t = x(k) + do j = jal(k), jal(k+1)-1 + x(jal(j)) = x(jal(j)) - t*al(j) + end do end do -! - return -!----------end-of-lsolc------------------------------------------------ -!----------------------------------------------------------------------- + ! + return + !----------end-of-lsolc------------------------------------------------ + !----------------------------------------------------------------------- end subroutine ldsolc -!----------------------------------------------------------------------- - subroutine ldsoll (n,x,y,al,jal,nlev,lev,ilev) - integer n, nlev, jal(*), ilev(nlev+1), lev(n) - real*8 x(n), y(n), al(*) !----------------------------------------------------------------------- -! Solves L x = y L = triangular. Uses LEVEL SCHEDULING/MSR format -!----------------------------------------------------------------------- -! -! On entry: -!---------- -! n = integer. dimension of problem. -! y = real array containg the right hand side. -! -! al, -! jal, = Lower triangular matrix stored in Modified Sparse Row -! format. -! nlev = number of levels in matrix -! lev = integer array of length n, containing the permutation -! that defines the levels in the level scheduling ordering. -! ilev = pointer to beginning of levels in lev. -! the numbers lev(i) to lev(i+1)-1 contain the row numbers -! that belong to level number i, in the level shcheduling -! ordering. -! -! On return: -!----------- -! x = The solution of L x = y . -!-------------------------------------------------------------------- - integer ii, jrow, i, k - real*8 t -! -! outer loop goes through the levels. (SEQUENTIAL loop) -! +subroutine ldsoll (n,x,y,al,jal,nlev,lev,ilev) + integer n, nlev, jal(*), ilev(nlev+1), lev(n) + real*8 x(n), y(n), al(*) + !----------------------------------------------------------------------- + ! Solves L x = y L = triangular. Uses LEVEL SCHEDULING/MSR format + !----------------------------------------------------------------------- + ! + ! On entry: + !---------- + ! n = integer. dimension of problem. + ! y = real array containg the right hand side. + ! + ! al, + ! jal, = Lower triangular matrix stored in Modified Sparse Row + ! format. + ! nlev = number of levels in matrix + ! lev = integer array of length n, containing the permutation + ! that defines the levels in the level scheduling ordering. + ! ilev = pointer to beginning of levels in lev. + ! the numbers lev(i) to lev(i+1)-1 contain the row numbers + ! that belong to level number i, in the level shcheduling + ! ordering. + ! + ! On return: + !----------- + ! x = The solution of L x = y . + !-------------------------------------------------------------------- + integer ii, jrow, i, k + real*8 t + ! + ! outer loop goes through the levels. (SEQUENTIAL loop) + ! do ii=1, nlev -! -! next loop executes within the same level. PARALLEL loop -! - do i=ilev(ii), ilev(ii+1)-1 - jrow = lev(i) -! -! compute inner product of row jrow with x -! - t = y(jrow) - do k=jal(jrow), jal(jrow+1)-1 - t = t - al(k)*x(jal(k)) - end do - x(jrow) = t*al(jrow) - end do + ! + ! next loop executes within the same level. PARALLEL loop + ! + do i=ilev(ii), ilev(ii+1)-1 + jrow = lev(i) + ! + ! compute inner product of row jrow with x + ! + t = y(jrow) + do k=jal(jrow), jal(jrow+1)-1 + t = t - al(k)*x(jal(k)) + end do + x(jrow) = t*al(jrow) + end do end do - return -!----------------------------------------------------------------------- + return + !----------------------------------------------------------------------- end subroutine ldsoll !----------------------------------------------------------------------- - subroutine usol (n,x,y,au,jau,iau) - integer n, jau(*),iau(n+1) - real*8 x(n), y(n), au(*) -!----------------------------------------------------------------------- -! Solves U x = y U = unit upper triangular. -!----------------------------------------------------------------------- -! solves a unit upper triangular system by standard (sequential ) -! backward elimination - matrix stored in CSR format. -!----------------------------------------------------------------------- -! -! On entry: -!---------- -! n = integer. dimension of problem. -! y = real array containg the right side. -! -! au, -! jau, -! iau, = Lower triangular matrix stored in compressed sparse row -! format. -! -! On return: -!----------- -! x = The solution of U x = y . -!-------------------------------------------------------------------- -! local variables -! - integer k, j - real*8 t -!----------------------------------------------------------------------- - x(n) = y(n) - do k = n-1,1,-1 - t = y(k) - do j = iau(k), iau(k+1)-1 - t = t - au(j)*x(jau(j)) - end do - x(k) = t +subroutine usol (n,x,y,au,jau,iau) + integer n, jau(*),iau(n+1) + real*8 x(n), y(n), au(*) + !----------------------------------------------------------------------- + ! Solves U x = y U = unit upper triangular. + !----------------------------------------------------------------------- + ! solves a unit upper triangular system by standard (sequential ) + ! backward elimination - matrix stored in CSR format. + !----------------------------------------------------------------------- + ! + ! On entry: + !---------- + ! n = integer. dimension of problem. + ! y = real array containg the right side. + ! + ! au, + ! jau, + ! iau, = Lower triangular matrix stored in compressed sparse row + ! format. + ! + ! On return: + !----------- + ! x = The solution of U x = y . + !-------------------------------------------------------------------- + ! local variables + ! + integer k, j + real*8 t + !----------------------------------------------------------------------- + x(n) = y(n) + do k = n-1,1,-1 + t = y(k) + do j = iau(k), iau(k+1)-1 + t = t - au(j)*x(jau(j)) + end do + x(k) = t end do -! - return -!----------end-of-usol-------------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !----------end-of-usol-------------------------------------------------- + !----------------------------------------------------------------------- end subroutine usol -!----------------------------------------------------------------------- - subroutine udsol (n,x,y,au,jau) - integer n, jau(*) - real*8 x(n), y(n),au(*) -!----------------------------------------------------------------------- -! Solves U x = y ; U = upper triangular in MSR format !----------------------------------------------------------------------- -! solves a non-unit upper triangular matrix by standard (sequential ) -! backward elimination - matrix stored in MSR format. -! with diagonal elements already inverted (otherwise do inversion, -! au(1:n) = 1.0/au(1:n), before calling). -!----------------------------------------------------------------------- -! -! On entry: -!---------- -! n = integer. dimension of problem. -! y = real array containg the right side. -! -! au, -! jau, = Lower triangular matrix stored in modified sparse row -! format. -! -! On return: -!----------- -! x = The solution of U x = y . -!-------------------------------------------------------------------- -! local variables -! - integer k, j - real*8 t -!----------------------------------------------------------------------- - x(n) = y(n)*au(n) +subroutine udsol (n,x,y,au,jau) + integer n, jau(*) + real*8 x(n), y(n),au(*) + !----------------------------------------------------------------------- + ! Solves U x = y ; U = upper triangular in MSR format + !----------------------------------------------------------------------- + ! solves a non-unit upper triangular matrix by standard (sequential ) + ! backward elimination - matrix stored in MSR format. + ! with diagonal elements already inverted (otherwise do inversion, + ! au(1:n) = 1.0/au(1:n), before calling). + !----------------------------------------------------------------------- + ! + ! On entry: + !---------- + ! n = integer. dimension of problem. + ! y = real array containg the right side. + ! + ! au, + ! jau, = Lower triangular matrix stored in modified sparse row + ! format. + ! + ! On return: + !----------- + ! x = The solution of U x = y . + !-------------------------------------------------------------------- + ! local variables + ! + integer k, j + real*8 t + !----------------------------------------------------------------------- + x(n) = y(n)*au(n) do k = n-1,1,-1 - t = y(k) - do j = jau(k), jau(k+1)-1 - t = t - au(j)*x(jau(j)) - end do - x(k) = au(k)*t + t = y(k) + do j = jau(k), jau(k+1)-1 + t = t - au(j)*x(jau(j)) + end do + x(k) = au(k)*t end do -! - return -!----------end-of-udsol------------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !----------end-of-udsol------------------------------------------------- + !----------------------------------------------------------------------- end subroutine udsol -!----------------------------------------------------------------------- - subroutine usolc (n,x,y,au,jau,iau) - real*8 x(*), y(*), au(*) - integer n, jau(*),iau(*) -!----------------------------------------------------------------------- -! SOUVES U x = y ; where U = unit upper trang. CSC format -!----------------------------------------------------------------------- -! solves a unit upper triangular system by standard (sequential ) -! forward elimination - matrix stored in CSC format. -!----------------------------------------------------------------------- -! -! On entry: -!---------- -! n = integer. dimension of problem. -! y = real*8 array containg the right side. -! -! au, -! jau, -! iau, = Uower triangular matrix stored in compressed sparse column -! format. -! -! On return: -!----------- -! x = The solution of U x = y. -!----------------------------------------------------------------------- -! local variables -! - integer k, j - real*8 t !----------------------------------------------------------------------- +subroutine usolc (n,x,y,au,jau,iau) + real*8 x(*), y(*), au(*) + integer n, jau(*),iau(*) + !----------------------------------------------------------------------- + ! SOUVES U x = y ; where U = unit upper trang. CSC format + !----------------------------------------------------------------------- + ! solves a unit upper triangular system by standard (sequential ) + ! forward elimination - matrix stored in CSC format. + !----------------------------------------------------------------------- + ! + ! On entry: + !---------- + ! n = integer. dimension of problem. + ! y = real*8 array containg the right side. + ! + ! au, + ! jau, + ! iau, = Uower triangular matrix stored in compressed sparse column + ! format. + ! + ! On return: + !----------- + ! x = The solution of U x = y. + !----------------------------------------------------------------------- + ! local variables + ! + integer k, j + real*8 t + !----------------------------------------------------------------------- do k=1,n - x(k) = y(k) + x(k) = y(k) end do do k = n,1,-1 - t = x(k) - do j = iau(k), iau(k+1)-1 - x(jau(j)) = x(jau(j)) - t*au(j) - end do + t = x(k) + do j = iau(k), iau(k+1)-1 + x(jau(j)) = x(jau(j)) - t*au(j) + end do end do -! - return -!----------end-of-usolc------------------------------------------------- -!----------------------------------------------------------------------- + ! + return + !----------end-of-usolc------------------------------------------------- + !----------------------------------------------------------------------- end subroutine usolc !----------------------------------------------------------------------- - subroutine udsolc (n,x,y,au,jau) - integer n, jau(*) - real*8 x(n), y(n), au(*) -!----------------------------------------------------------------------- -! Solves U x = y ; U = nonunit Up. Triang. MSC format -!----------------------------------------------------------------------- -! solves a (non-unit) upper triangular system by standard (sequential) -! forward elimination - matrix stored in Modified Sparse Column format -! with diagonal elements already inverted (otherwise do inversion, -! auuuul(1:n) = 1.0/au(1:n), before calling ldsol). -!----------------------------------------------------------------------- -! -! On entry: -!---------- -! n = integer. dimension of problem. -! y = real*8 array containg the right hand side. -! -! au, -! jau, = Upper triangular matrix stored in Modified Sparse Column -! format. -! -! On return: -!----------- -! x = The solution of U x = y . -!-------------------------------------------------------------------- -! local variables -! - integer k, j - real*8 t -!----------------------------------------------------------------------- +subroutine udsolc (n,x,y,au,jau) + integer n, jau(*) + real*8 x(n), y(n), au(*) + !----------------------------------------------------------------------- + ! Solves U x = y ; U = nonunit Up. Triang. MSC format + !----------------------------------------------------------------------- + ! solves a (non-unit) upper triangular system by standard (sequential) + ! forward elimination - matrix stored in Modified Sparse Column format + ! with diagonal elements already inverted (otherwise do inversion, + ! auuuul(1:n) = 1.0/au(1:n), before calling ldsol). + !----------------------------------------------------------------------- + ! + ! On entry: + !---------- + ! n = integer. dimension of problem. + ! y = real*8 array containg the right hand side. + ! + ! au, + ! jau, = Upper triangular matrix stored in Modified Sparse Column + ! format. + ! + ! On return: + !----------- + ! x = The solution of U x = y . + !-------------------------------------------------------------------- + ! local variables + ! + integer k, j + real*8 t + !----------------------------------------------------------------------- do k=1,n - x(k) = y(k) + x(k) = y(k) end do do k = n,1,-1 - x(k) = x(k)*au(k) - t = x(k) - do j = jau(k), jau(k+1)-1 - x(jau(j)) = x(jau(j)) - t*au(j) - end do + x(k) = x(k)*au(k) + t = x(k) + do j = jau(k), jau(k+1)-1 + x(jau(j)) = x(jau(j)) - t*au(j) + end do end do -! - return -!----------end-of-udsolc------------------------------------------------ -!----------------------------------------------------------------------- + ! + return + !----------end-of-udsolc------------------------------------------------ + !----------------------------------------------------------------------- end subroutine udsolc !----------------------------------------------------------------------- - subroutine lusol(n, y, x, alu, jlu, ju) - implicit none +subroutine lusol(n, y, x, alu, jlu, ju) + implicit none - integer :: n, jlu(*), ju(*) - real*8 :: x(n), y(n), alu(*) - -!----------------------------------------------------------------------- - integer :: i,k -! -! forward solve -! + integer :: n, jlu(*), ju(*) + real*8 :: x(n), y(n), alu(*) + + !----------------------------------------------------------------------- + integer :: i,k + ! + ! forward solve + ! do i = 1, n - x(i) = y(i) - do k=jlu(i),ju(i)-1 - x(i) = x(i) - alu(k)* x(jlu(k)) - end do + x(i) = y(i) + do k=jlu(i),ju(i)-1 + x(i) = x(i) - alu(k)* x(jlu(k)) + end do end do do i = n, 1, -1 - do k=ju(i),jlu(i+1)-1 - x(i) = x(i) - alu(k)*x(jlu(k)) - end do - x(i) = alu(i)*x(i) + do k=ju(i),jlu(i+1)-1 + x(i) = x(i) - alu(k)*x(jlu(k)) + end do + x(i) = alu(i)*x(i) end do -! - return -!----------------end of lusol ------------------------------------------ + ! + return + !----------------end of lusol ------------------------------------------ end subroutine lusol !----------------------------------------------------------------------- - subroutine lutsol(n, y, x, alu, jlu, ju) - implicit none +subroutine lutsol(n, y, x, alu, jlu, ju) + implicit none - integer :: n, jlu(*), ju(*) - real*8 :: x(n), y(n), alu(*) - -!----------------------------------------------------------------------- -! local variables -! - integer :: i,k -! + integer :: n, jlu(*), ju(*) + real*8 :: x(n), y(n), alu(*) + + !----------------------------------------------------------------------- + ! local variables + ! + integer :: i,k + ! do i = 1, n - x(i) = y(i) + x(i) = y(i) end do -! -! forward solve (with U^T) -! + ! + ! forward solve (with U^T) + ! do i = 1, n - x(i) = x(i) * alu(i) - do k=ju(i),jlu(i+1)-1 - x(jlu(k)) = x(jlu(k)) - alu(k)* x(i) - end do + x(i) = x(i) * alu(i) + do k=ju(i),jlu(i+1)-1 + x(jlu(k)) = x(jlu(k)) - alu(k)* x(i) + end do end do -! -! backward solve (with L^T) -! - do i = n, 1, -1 - do k=jlu(i),ju(i)-1 - x(jlu(k)) = x(jlu(k)) - alu(k)*x(i) - end do + ! + ! backward solve (with L^T) + ! + do i = n, 1, -1 + do k=jlu(i),ju(i)-1 + x(jlu(k)) = x(jlu(k)) - alu(k)*x(i) + end do end do -! - return -!----------------end of lutsol ----------------------------------------- -!----------------------------------------------------------------------- + ! + return + !----------------end of lutsol ----------------------------------------- + !----------------------------------------------------------------------- end subroutine lutsol -!----------------------------------------------------------------------- - subroutine qsplit(a,ind,n,ncut) - implicit none - - integer :: n, ind(n), ncut - real*8 :: a(n) - -!----------------------------------------------------------------------- -! does a quick-sort split of a real array. -! on input a(1:n). is a real array -! on output a(1:n) is permuted such that its elements satisfy: -! -! abs(a(i)) .ge. abs(a(ncut)) for i .lt. ncut and -! abs(a(i)) .le. abs(a(ncut)) for i .gt. ncut -! -! ind(1:n) is an integer array which permuted in the same way as a(*). !----------------------------------------------------------------------- - real*8 :: tmp, abskey - integer :: itmp, first, last, j, mid -!----- - first = 1 - last = n - if (ncut .lt. first .or. ncut .gt. last) return -! -! outer loop -- while mid .ne. ncut do -! - 1 mid = first - abskey = abs(a(mid)) +subroutine qsplit(a,ind,n,ncut) + implicit none + + integer :: n, ind(n), ncut + real*8 :: a(n) + + !----------------------------------------------------------------------- + ! does a quick-sort split of a real array. + ! on input a(1:n). is a real array + ! on output a(1:n) is permuted such that its elements satisfy: + ! + ! abs(a(i)) .ge. abs(a(ncut)) for i .lt. ncut and + ! abs(a(i)) .le. abs(a(ncut)) for i .gt. ncut + ! + ! ind(1:n) is an integer array which permuted in the same way as a(*). + !----------------------------------------------------------------------- + real*8 :: tmp, abskey + integer :: itmp, first, last, j, mid + !----- + first = 1 + last = n + if (ncut .lt. first .or. ncut .gt. last) return + ! + ! outer loop -- while mid .ne. ncut do + ! +1 mid = first + abskey = abs(a(mid)) do j=first+1, last - if (abs(a(j)) .gt. abskey) then - mid = mid+1 -! interchange - tmp = a(mid) - itmp = ind(mid) - a(mid) = a(j) - ind(mid) = ind(j) - a(j) = tmp - ind(j) = itmp - endif + if (abs(a(j)) .gt. abskey) then + mid = mid+1 + ! interchange + tmp = a(mid) + itmp = ind(mid) + a(mid) = a(j) + ind(mid) = ind(j) + a(j) = tmp + ind(j) = itmp + endif end do -! -! interchange -! - tmp = a(mid) - a(mid) = a(first) - a(first) = tmp -! - itmp = ind(mid) - ind(mid) = ind(first) - ind(first) = itmp -! -! test for while loop -! - if (mid .eq. ncut) return - if (mid .gt. ncut) then - last = mid-1 - else - first = mid+1 - endif - goto 1 -!----------------end-of-qsplit------------------------------------------ -!----------------------------------------------------------------------- + ! + ! interchange + ! + tmp = a(mid) + a(mid) = a(first) + a(first) = tmp + ! + itmp = ind(mid) + ind(mid) = ind(first) + ind(first) = itmp + ! + ! test for while loop + ! + if (mid .eq. ncut) return + if (mid .gt. ncut) then + last = mid-1 + else + first = mid+1 + endif + goto 1 + !----------------end-of-qsplit------------------------------------------ + !----------------------------------------------------------------------- end subroutine qsplit - subroutine runrc(n,rhs,sol,ipar,fpar,wk,guess,a,ja,ia,au,jau,ju,solver) - implicit none - integer n,ipar(16),ia(n+1),ja(*),ju(*),jau(*) - real*8 fpar(16),rhs(n),sol(n),guess(n),wk(*),a(*),au(*) - external solver -!----------------------------------------------------------------------- -! the actual tester. It starts the iterative linear system solvers -! with a initial guess suppied by the user. -! -! The structure {au, jau, ju} is assumed to have the output from -! the ILU* routines in ilut.f. -! -!----------------------------------------------------------------------- -! local variables -! - integer :: i, its -! real :: dtime, dt(2), time -! external dtime - save its -! -! ipar(2) can be 0, 1, 2, please don't use 3 -! - if (ipar(2).gt.2) then - WRITE(*,*) 'I can not do both left and right preconditioning.' - return - endif +subroutine runrc(n,rhs,sol,ipar,fpar,wk,guess,a,ja,ia,au,jau,ju,solver) + implicit none + integer n,ipar(16),ia(n+1),ja(*),ju(*),jau(*) + real*8 fpar(16),rhs(n),sol(n),guess(n),wk(*),a(*),au(*) + external solver + !----------------------------------------------------------------------- + ! the actual tester. It starts the iterative linear system solvers + ! with a initial guess suppied by the user. + ! + ! The structure {au, jau, ju} is assumed to have the output from + ! the ILU* routines in ilut.f. + ! + !----------------------------------------------------------------------- + ! local variables + ! + integer :: i, its + ! real :: dtime, dt(2), time + ! external dtime + save its + ! + ! ipar(2) can be 0, 1, 2, please don't use 3 + ! + if (ipar(2).gt.2) then + WRITE(*,*) 'I can not do both left and right preconditioning.' + return + endif - its = 0 -! - do i = 1, n - sol(i) = guess(i) - enddo -! - ipar(1) = 0 -! time = dtime(dt) + its = 0 + ! + do i = 1, n + sol(i) = guess(i) + enddo + ! + ipar(1) = 0 + ! time = dtime(dt) - 10 call solver(n,rhs,sol,ipar,fpar,wk) +10 call solver(n,rhs,sol,ipar,fpar,wk) - if (ipar(7).ne.its) then - its = ipar(7) - endif - if (ipar(1).eq.1) then - call amux(n, wk(ipar(8)), wk(ipar(9)), a, ja, ia) - goto 10 - else if (ipar(1).eq.2) then - call atmux(n, wk(ipar(8)), wk(ipar(9)), a, ja, ia) - goto 10 - else if (ipar(1).eq.3 .or. ipar(1).eq.5) then - call lusol(n,wk(ipar(8)),wk(ipar(9)),au,jau,ju) - goto 10 - else if (ipar(1).eq.4 .or. ipar(1).eq.6) then - call lutsol(n,wk(ipar(8)),wk(ipar(9)),au,jau,ju) - goto 10 - else if (ipar(1).le.0) then - if (ipar(1).eq.0) then -! WRITE(*,*) 'Iterative sovler has satisfied convergence test.' - else if (ipar(1).eq.-1) then - WRITE(*,*) 'Iterative solver has iterated too many times.' - else if (ipar(1).eq.-2) then - WRITE(*,*) 'Iterative solver was not given enough work space.' - WRITE(*,*) 'The work space should at least have ', ipar(4), & - & ' elements.' - else if (ipar(1).eq.-3) then - WRITE(*,*) 'Iterative sovler is facing a break-down.' - else - WRITE(*,*) 'Iterative solver terminated. code =', ipar(1) - endif - endif + if (ipar(7).ne.its) then + its = ipar(7) + endif + if (ipar(1).eq.1) then + call amux(n, wk(ipar(8)), wk(ipar(9)), a, ja, ia) + goto 10 + else if (ipar(1).eq.2) then + call atmux(n, wk(ipar(8)), wk(ipar(9)), a, ja, ia) + goto 10 + else if (ipar(1).eq.3 .or. ipar(1).eq.5) then + call lusol(n,wk(ipar(8)),wk(ipar(9)),au,jau,ju) + goto 10 + else if (ipar(1).eq.4 .or. ipar(1).eq.6) then + call lutsol(n,wk(ipar(8)),wk(ipar(9)),au,jau,ju) + goto 10 + else if (ipar(1).le.0) then + if (ipar(1).eq.0) then + ! WRITE(*,*) 'Iterative sovler has satisfied convergence test.' + else if (ipar(1).eq.-1) then + WRITE(*,*) 'Iterative solver has iterated too many times.' + else if (ipar(1).eq.-2) then + WRITE(*,*) 'Iterative solver was not given enough work space.' + WRITE(*,*) 'The work space should at least have ', ipar(4), & + & ' elements.' + else if (ipar(1).eq.-3) then + WRITE(*,*) 'Iterative sovler is facing a break-down.' + else + WRITE(*,*) 'Iterative solver terminated. code =', ipar(1) + endif + endif end subroutine runrc !-----end-of-runrc !----------------------------------------------------------------------c @@ -3820,671 +3820,671 @@ end subroutine runrc ! ============ arguments have changed w.r.t. earlier versions. Some c ! Calling sequences may also have changed c ! - subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) -!----------------------------------------------------------------------- - implicit none - integer n - real*8 a(*),alu(*),w(n+1),droptol - integer ja(*),ia(n+1),jlu(*),ju(n),jw(2*n),lfil,iwk,ierr -!----------------------------------------------------------------------* -! *** ILUT preconditioner *** * -! incomplete LU factorization with dual truncation mechanism * -!----------------------------------------------------------------------* -! Author: Yousef Saad *May, 5, 1990, Latest revision, August 1996 * -!----------------------------------------------------------------------* -! PARAMETERS -!----------- -! -! on entry: -!========== -! n = integer. The row dimension of the matrix A. The matrix -! -! a,ja,ia = matrix stored in Compressed Sparse Row format. -! -! lfil = integer. The fill-in parameter. Each row of L and each row -! of U will have a maximum of lfil elements (excluding the -! diagonal element). lfil must be .ge. 0. -! ** WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO -! EARLIER VERSIONS. -! -! droptol = real*8. Sets the threshold for dropping small terms in the -! factorization. See below for details on dropping strategy. -! -! -! iwk = integer. The lengths of arrays alu and jlu. If the arrays -! are not big enough to store the ILU factorizations, ilut -! will stop with an error message. -! -! On return: -!=========== -! -! alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing -! the L and U factors together. The diagonal (stored in -! alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix -! contains the i-th row of L (excluding the diagonal entry=1) -! followed by the i-th row of U. -! -! ju = integer array of length n containing the pointers to -! the beginning of each row of U in the matrix alu,jlu. -! -! ierr = integer. Error message with the following meaning. -! ierr = 0 --> successful return. -! ierr .gt. 0 --> zero pivot encountered at step number ierr. -! ierr = -1 --> Error. input matrix may be wrong. -! (The elimination process has generated a -! row in L or U whose length is .gt. n.) -! ierr = -2 --> The matrix L overflows the array al. -! ierr = -3 --> The matrix U overflows the array alu. -! ierr = -4 --> Illegal value for lfil. -! ierr = -5 --> zero row encountered. -! -! work arrays: -!============= -! jw = integer work array of length 2*n. -! w = real work array of length n+1. -! -!---------------------------------------------------------------------- -! w, ju (1:n) store the working array [1:ii-1 = L-part, ii:n = u] -! jw(n+1:2n) stores nonzero indicators -! -! Notes: -! ------ -! The diagonal elements of the input matrix must be nonzero (at least -! 'structurally'). -! -!----------------------------------------------------------------------* -!---- Dual drop strategy works as follows. * -! * -! 1) Theresholding in L and U as set by droptol. Any element whose * -! magnitude is less than some tolerance (relative to the abs * -! value of diagonal element in u) is dropped. * -! * -! 2) Keeping only the largest lfil elements in the i-th row of L * -! and the largest lfil elements in the i-th row of U (excluding * -! diagonal elements). * -! * -! Flexibility: one can use droptol=0 to get a strategy based on * -! keeping the largest elements in each row of L and U. Taking * -! droptol .ne. 0 but lfil=n will give the usual threshold strategy * -! (however, fill-in is then mpredictible). * -!----------------------------------------------------------------------* -! locals - integer ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,lenn - real*8 tnorm, t, abs, s, fact - if (lfil .lt. 0) goto 998 -!----------------------------------------------------------------------- -! initialize ju0 (points to next element to be added to alu,jlu) -! and pointer array. -!----------------------------------------------------------------------- - ju0 = n+2 - jlu(1) = ju0 -! -! initialize nonzero indicator array. -! +subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) + !----------------------------------------------------------------------- + implicit none + integer n + real*8 a(*),alu(*),w(n+1),droptol + integer ja(*),ia(n+1),jlu(*),ju(n),jw(2*n),lfil,iwk,ierr + !----------------------------------------------------------------------* + ! *** ILUT preconditioner *** * + ! incomplete LU factorization with dual truncation mechanism * + !----------------------------------------------------------------------* + ! Author: Yousef Saad *May, 5, 1990, Latest revision, August 1996 * + !----------------------------------------------------------------------* + ! PARAMETERS + !----------- + ! + ! on entry: + !========== + ! n = integer. The row dimension of the matrix A. The matrix + ! + ! a,ja,ia = matrix stored in Compressed Sparse Row format. + ! + ! lfil = integer. The fill-in parameter. Each row of L and each row + ! of U will have a maximum of lfil elements (excluding the + ! diagonal element). lfil must be .ge. 0. + ! ** WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO + ! EARLIER VERSIONS. + ! + ! droptol = real*8. Sets the threshold for dropping small terms in the + ! factorization. See below for details on dropping strategy. + ! + ! + ! iwk = integer. The lengths of arrays alu and jlu. If the arrays + ! are not big enough to store the ILU factorizations, ilut + ! will stop with an error message. + ! + ! On return: + !=========== + ! + ! alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing + ! the L and U factors together. The diagonal (stored in + ! alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix + ! contains the i-th row of L (excluding the diagonal entry=1) + ! followed by the i-th row of U. + ! + ! ju = integer array of length n containing the pointers to + ! the beginning of each row of U in the matrix alu,jlu. + ! + ! ierr = integer. Error message with the following meaning. + ! ierr = 0 --> successful return. + ! ierr .gt. 0 --> zero pivot encountered at step number ierr. + ! ierr = -1 --> Error. input matrix may be wrong. + ! (The elimination process has generated a + ! row in L or U whose length is .gt. n.) + ! ierr = -2 --> The matrix L overflows the array al. + ! ierr = -3 --> The matrix U overflows the array alu. + ! ierr = -4 --> Illegal value for lfil. + ! ierr = -5 --> zero row encountered. + ! + ! work arrays: + !============= + ! jw = integer work array of length 2*n. + ! w = real work array of length n+1. + ! + !---------------------------------------------------------------------- + ! w, ju (1:n) store the working array [1:ii-1 = L-part, ii:n = u] + ! jw(n+1:2n) stores nonzero indicators + ! + ! Notes: + ! ------ + ! The diagonal elements of the input matrix must be nonzero (at least + ! 'structurally'). + ! + !----------------------------------------------------------------------* + !---- Dual drop strategy works as follows. * + ! * + ! 1) Theresholding in L and U as set by droptol. Any element whose * + ! magnitude is less than some tolerance (relative to the abs * + ! value of diagonal element in u) is dropped. * + ! * + ! 2) Keeping only the largest lfil elements in the i-th row of L * + ! and the largest lfil elements in the i-th row of U (excluding * + ! diagonal elements). * + ! * + ! Flexibility: one can use droptol=0 to get a strategy based on * + ! keeping the largest elements in each row of L and U. Taking * + ! droptol .ne. 0 but lfil=n will give the usual threshold strategy * + ! (however, fill-in is then mpredictible). * + !----------------------------------------------------------------------* + ! locals + integer ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,lenn + real*8 tnorm, t, abs, s, fact + if (lfil .lt. 0) goto 998 + !----------------------------------------------------------------------- + ! initialize ju0 (points to next element to be added to alu,jlu) + ! and pointer array. + !----------------------------------------------------------------------- + ju0 = n+2 + jlu(1) = ju0 + ! + ! initialize nonzero indicator array. + ! do j=1,n - jw(n+j) = 0 + jw(n+j) = 0 end do -!----------------------------------------------------------------------- -! beginning of main loop. -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! beginning of main loop. + !----------------------------------------------------------------------- do ii = 1, n - j1 = ia(ii) - j2 = ia(ii+1) - 1 - - tnorm = 0.0d0 - do k=j1,j2 - tnorm = tnorm+abs(a(k)) - end do - if (abs(tnorm) .lt. tiny(1.)) goto 999 - - tnorm = tnorm/real(j2-j1+1) -! -! unpack L-part and U-part of row of A in arrays w -! - lenu = 1 - lenl = 0 - jw(ii) = ii - w(ii) = 0.0 - jw(n+ii) = ii -! - do j = j1, j2 - k = ja(j) - t = a(j) - if (k .lt. ii) then - lenl = lenl+1 - jw(lenl) = k - w(lenl) = t - jw(n+k) = lenl - else if (k .eq. ii) then - w(ii) = t - else - lenu = lenu+1 - jpos = ii+lenu-1 - jw(jpos) = k - w(jpos) = t - jw(n+k) = jpos - endif - end do - jj = 0 - lenn = 0 -! -! eliminate previous rows -! - 150 jj = jj+1 - if (jj .gt. lenl) goto 160 -!----------------------------------------------------------------------- -! in order to do the elimination in the correct order we must select -! the smallest column index among jw(k), k=jj+1, ..., lenl. -!----------------------------------------------------------------------- - jrow = jw(jj) - k = jj -! -! determine smallest column index -! - do j=jj+1,lenl - if (jw(j) .lt. jrow) then - jrow = jw(j) - k = j - endif - end do -! - if (k .ne. jj) then -! exchange in jw - j = jw(jj) - jw(jj) = jw(k) - jw(k) = j -! exchange in jr - jw(n+jrow) = jj - jw(n+j) = k -! exchange in w - s = w(jj) - w(jj) = w(k) - w(k) = s - endif -! -! zero out element in row by setting jw(n+jrow) to zero. -! - jw(n+jrow) = 0 -! -! get the multiplier for row to be eliminated (jrow). -! - fact = w(jj)*alu(jrow) - if (abs(fact) .le. droptol) goto 150 -! -! combine current row and row jrow -! - do k = ju(jrow), jlu(jrow+1)-1 - s = fact*alu(k) - j = jlu(k) - jpos = jw(n+j) - if (j .ge. ii) then -! -! dealing with upper part. -! - if (jpos .eq. 0) then -! -! this is a fill-in element -! - lenu = lenu+1 - if (lenu .gt. n) goto 995 - i = ii+lenu-1 - jw(i) = j - jw(n+j) = i - w(i) = - s - else -! -! this is not a fill-in element -! - w(jpos) = w(jpos) - s - - endif - else -! -! dealing with lower part. -! - if (jpos .eq. 0) then -! -! this is a fill-in element -! - lenl = lenl+1 - if (lenl .gt. n) goto 995 - jw(lenl) = j - jw(n+j) = lenl - w(lenl) = - s - else -! -! this is not a fill-in element -! - w(jpos) = w(jpos) - s - endif - endif - end do -! -! store this pivot element -- (from left to right -- no danger of -! overlap with the working elements in L (pivots). -! - lenn = lenn+1 - w(lenn) = fact - jw(lenn) = jrow - goto 150 - 160 continue -! -! reset double-pointer to zero (U-part) -! - do k=1, lenu - jw(n+jw(ii+k-1)) = 0 - end do -! -! update L-matrix -! - lenl = lenn - lenn = min0(lenl,lfil) -! -! sort by quick-split -! - call qsplit (w,jw,lenl,lenn) -! -! store L-part -! - do k=1, lenn - if (ju0 .gt. iwk) goto 996 - alu(ju0) = w(k) - jlu(ju0) = jw(k) - ju0 = ju0+1 - end do -! -! save pointer to beginning of row ii of U -! - ju(ii) = ju0 -! -! update U-matrix -- first apply dropping strategy -! - lenn = 0 - do k=1, lenu-1 - if (abs(w(ii+k)) .gt. droptol*tnorm) then - lenn = lenn+1 - w(ii+lenn) = w(ii+k) - jw(ii+lenn) = jw(ii+k) - endif - enddo - lenu = lenn+1 - lenn = min0(lenu,lfil) -! - call qsplit (w(ii+1), jw(ii+1), lenu-1,lenn) -! -! copy -! - t = abs(w(ii)) - if (lenn + ju0 .gt. iwk) goto 997 - do k=ii+1,ii+lenn-1 - jlu(ju0) = jw(k) - alu(ju0) = w(k) - t = t + abs(w(k) ) - ju0 = ju0+1 - end do -! -! store inverse of diagonal element of u -! -!2do check if it works ... after correction ... - if (abs(w(ii)) .lt. tiny(1.d0)) w(ii) = (0.0001d0 + droptol)*tnorm -! - alu(ii) = 1.0d0/ w(ii) -! -! update pointer to beginning of next row of U. -! - jlu(ii+1) = ju0 -!----------------------------------------------------------------------- -! end main loop -!----------------------------------------------------------------------- + j1 = ia(ii) + j2 = ia(ii+1) - 1 + + tnorm = 0.0d0 + do k=j1,j2 + tnorm = tnorm+abs(a(k)) + end do + if (abs(tnorm) .lt. tiny(1.)) goto 999 + + tnorm = tnorm/real(j2-j1+1) + ! + ! unpack L-part and U-part of row of A in arrays w + ! + lenu = 1 + lenl = 0 + jw(ii) = ii + w(ii) = 0.0 + jw(n+ii) = ii + ! + do j = j1, j2 + k = ja(j) + t = a(j) + if (k .lt. ii) then + lenl = lenl+1 + jw(lenl) = k + w(lenl) = t + jw(n+k) = lenl + else if (k .eq. ii) then + w(ii) = t + else + lenu = lenu+1 + jpos = ii+lenu-1 + jw(jpos) = k + w(jpos) = t + jw(n+k) = jpos + endif + end do + jj = 0 + lenn = 0 + ! + ! eliminate previous rows + ! +150 jj = jj+1 + if (jj .gt. lenl) goto 160 + !----------------------------------------------------------------------- + ! in order to do the elimination in the correct order we must select + ! the smallest column index among jw(k), k=jj+1, ..., lenl. + !----------------------------------------------------------------------- + jrow = jw(jj) + k = jj + ! + ! determine smallest column index + ! + do j=jj+1,lenl + if (jw(j) .lt. jrow) then + jrow = jw(j) + k = j + endif + end do + ! + if (k .ne. jj) then + ! exchange in jw + j = jw(jj) + jw(jj) = jw(k) + jw(k) = j + ! exchange in jr + jw(n+jrow) = jj + jw(n+j) = k + ! exchange in w + s = w(jj) + w(jj) = w(k) + w(k) = s + endif + ! + ! zero out element in row by setting jw(n+jrow) to zero. + ! + jw(n+jrow) = 0 + ! + ! get the multiplier for row to be eliminated (jrow). + ! + fact = w(jj)*alu(jrow) + if (abs(fact) .le. droptol) goto 150 + ! + ! combine current row and row jrow + ! + do k = ju(jrow), jlu(jrow+1)-1 + s = fact*alu(k) + j = jlu(k) + jpos = jw(n+j) + if (j .ge. ii) then + ! + ! dealing with upper part. + ! + if (jpos .eq. 0) then + ! + ! this is a fill-in element + ! + lenu = lenu+1 + if (lenu .gt. n) goto 995 + i = ii+lenu-1 + jw(i) = j + jw(n+j) = i + w(i) = - s + else + ! + ! this is not a fill-in element + ! + w(jpos) = w(jpos) - s + + endif + else + ! + ! dealing with lower part. + ! + if (jpos .eq. 0) then + ! + ! this is a fill-in element + ! + lenl = lenl+1 + if (lenl .gt. n) goto 995 + jw(lenl) = j + jw(n+j) = lenl + w(lenl) = - s + else + ! + ! this is not a fill-in element + ! + w(jpos) = w(jpos) - s + endif + endif + end do + ! + ! store this pivot element -- (from left to right -- no danger of + ! overlap with the working elements in L (pivots). + ! + lenn = lenn+1 + w(lenn) = fact + jw(lenn) = jrow + goto 150 +160 continue + ! + ! reset double-pointer to zero (U-part) + ! + do k=1, lenu + jw(n+jw(ii+k-1)) = 0 + end do + ! + ! update L-matrix + ! + lenl = lenn + lenn = min0(lenl,lfil) + ! + ! sort by quick-split + ! + call qsplit (w,jw,lenl,lenn) + ! + ! store L-part + ! + do k=1, lenn + if (ju0 .gt. iwk) goto 996 + alu(ju0) = w(k) + jlu(ju0) = jw(k) + ju0 = ju0+1 + end do + ! + ! save pointer to beginning of row ii of U + ! + ju(ii) = ju0 + ! + ! update U-matrix -- first apply dropping strategy + ! + lenn = 0 + do k=1, lenu-1 + if (abs(w(ii+k)) .gt. droptol*tnorm) then + lenn = lenn+1 + w(ii+lenn) = w(ii+k) + jw(ii+lenn) = jw(ii+k) + endif + enddo + lenu = lenn+1 + lenn = min0(lenu,lfil) + ! + call qsplit (w(ii+1), jw(ii+1), lenu-1,lenn) + ! + ! copy + ! + t = abs(w(ii)) + if (lenn + ju0 .gt. iwk) goto 997 + do k=ii+1,ii+lenn-1 + jlu(ju0) = jw(k) + alu(ju0) = w(k) + t = t + abs(w(k) ) + ju0 = ju0+1 + end do + ! + ! store inverse of diagonal element of u + ! + !2do check if it works ... after correction ... + if (abs(w(ii)) .lt. tiny(1.d0)) w(ii) = (0.0001d0 + droptol)*tnorm + ! + alu(ii) = 1.0d0/ w(ii) + ! + ! update pointer to beginning of next row of U. + ! + jlu(ii+1) = ju0 + !----------------------------------------------------------------------- + ! end main loop + !----------------------------------------------------------------------- end do - ierr = 0 - return -! -! incomprehensible error. Matrix must be wrong. -! - 995 ierr = -1 - return -! -! insufficient storage in L. -! - 996 ierr = -2 - return -! -! insufficient storage in U. -! - 997 ierr = -3 - return -! -! illegal lfil entered. -! - 998 ierr = -4 - return -! -! zero row encountered -! - 999 ierr = -5 - return -!----------------end-of-ilut-------------------------------------------- -!----------------------------------------------------------------------- + ierr = 0 + return + ! + ! incomprehensible error. Matrix must be wrong. + ! +995 ierr = -1 + return + ! + ! insufficient storage in L. + ! +996 ierr = -2 + return + ! + ! insufficient storage in U. + ! +997 ierr = -3 + return + ! + ! illegal lfil entered. + ! +998 ierr = -4 + return + ! + ! zero row encountered + ! +999 ierr = -5 + return + !----------------end-of-ilut-------------------------------------------- + !----------------------------------------------------------------------- end subroutine ilut !---------------------------------------------------------------------- ! subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ipoint1, ipoint2, ierr) - subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ierr) +subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ierr) - !implicit real*8 (a-h,o-z) - real*8 a(*), alu(*), tl - integer n, ju0, ii, jj, i, j, jcol, js, jf, jm, jrow, jw, ierr - integer ja(*), ia(*), ju(*), jlu(*), iw(n) -! -!----------------------------------------------------------------------- - ju0 = n+2 - jlu(1) = ju0 !!! - iw = 0 - do ii = 1, n - js = ju0 - do j=ia(ii),ia(ii+1)-1 - jcol = ja(j) - if (jcol .eq. ii) then - alu(ii) = a(j) - iw(jcol) = ii - ju(ii) = ju0 !!! - else - alu(ju0) = a(j) - jlu(ju0) = ja(j) - iw(jcol) = ju0 - ju0 = ju0+1 - endif - end do - jlu(ii+1) = ju0 !!! - jf = ju0-1 - jm = ju(ii)-1 -! exit if diagonal element is reached. - do j=js, jm - jrow = jlu(j) - tl = alu(j)*alu(jrow) - alu(j) = tl -! perform linear combination - do jj = ju(jrow), jlu(jrow+1)-1 - jw = iw(jlu(jj)) - if (jw .ne. 0) then - alu(jw) = alu(jw) - tl*alu(jj) -! write(*,*) ii, jw, jj - end if - end do - end do -! invert and store diagonal element. - if (abs(alu(ii)) .lt. tiny(1.)) goto 600 - alu(ii) = 1.0d0/alu(ii) -! reset pointer iw to zero - iw(ii) = 0 - do i = js, jf - iw(jlu(i)) = 0 - end do - end do + !implicit real*8 (a-h,o-z) + real*8 a(*), alu(*), tl + integer n, ju0, ii, jj, i, j, jcol, js, jf, jm, jrow, jw, ierr + integer ja(*), ia(*), ju(*), jlu(*), iw(n) + ! + !----------------------------------------------------------------------- + ju0 = n+2 + jlu(1) = ju0 !!! + iw = 0 + do ii = 1, n + js = ju0 + do j=ia(ii),ia(ii+1)-1 + jcol = ja(j) + if (jcol .eq. ii) then + alu(ii) = a(j) + iw(jcol) = ii + ju(ii) = ju0 !!! + else + alu(ju0) = a(j) + jlu(ju0) = ja(j) + iw(jcol) = ju0 + ju0 = ju0+1 + endif + end do + jlu(ii+1) = ju0 !!! + jf = ju0-1 + jm = ju(ii)-1 + ! exit if diagonal element is reached. + do j=js, jm + jrow = jlu(j) + tl = alu(j)*alu(jrow) + alu(j) = tl + ! perform linear combination + do jj = ju(jrow), jlu(jrow+1)-1 + jw = iw(jlu(jj)) + if (jw .ne. 0) then + alu(jw) = alu(jw) - tl*alu(jj) + ! write(*,*) ii, jw, jj + end if + end do + end do + ! invert and store diagonal element. + if (abs(alu(ii)) .lt. tiny(1.)) goto 600 + alu(ii) = 1.0d0/alu(ii) + ! reset pointer iw to zero + iw(ii) = 0 + do i = js, jf + iw(jlu(i)) = 0 + end do + end do - ierr = 0 - return + ierr = 0 + return -! zero pivot : - 600 ierr = ii - return + ! zero pivot : +600 ierr = ii + return end subroutine ilu0 !----------------------------------------------------------------------- ! subroutine pgmres(n, im, rhs, sol, eps, maxits, ierr) ! subroutine pgmres(n, im, rhs, sol, eps, maxits, aspar, ierr) - subroutine pgmres(n, im, rhs, sol, eps, maxits, aspar, nnz, ia, ja, alu, jlu, ju, vv, ierr) -!----------------------------------------------------------------------- -! use datapool, only : nnz, ia, ja, alu, jlu, ju, vv, aspar!, rhs, sol - implicit none - - integer :: n, im, maxits, ierr, nnz - - integer :: ja(nnz), ia(n+1) - integer :: jlu(nnz+1), ju(n) - real*8 :: vv(n,im+1), alu(nnz+1) - real*8 :: aspar(nnz) - - real*8 :: rhs(*), sol(*) - - real*8 :: eps - real*8 :: eps1, epsmac, gam, t, ddot, dnrm2, ro, tl - - integer :: i,i1,j,jj,k,k1,iii,ii,ju0 - integer :: its,jrow,jcol,jf,jm,js,jw - - real*8 :: hh(im+1,im), c(im), s(im), rs(im+1) - real*8 :: iw(n) - - logical :: lblas = .false. ! use sparskit matvec and external blas libs (true), don't use them (false) - logical :: lilu = .true. ! use simple ilu preconditioner - - data epsmac/1.d-16/ - -! ilu0 preconditioner - - if (lilu) then - ju0 = n+2 - jlu(1) = ju0 !!! - iw = 0 - do ii = 1, n - js = ju0 - do j=ia(ii),ia(ii+1)-1 - jcol = ja(j) - if (jcol .eq. ii) then - alu(ii) = aspar(j) - iw(jcol) = ii - ju(ii) = ju0 !!! - else - alu(ju0) = aspar(j) - jlu(ju0) = ja(j) - iw(jcol) = ju0 - ju0 = ju0+1 - endif - end do - jlu(ii+1) = ju0 !!! - jf = ju0-1 - jm = ju(ii)-1 -! exit if diagonal element is reached. - do j=js, jm - jrow = jlu(j) - tl = alu(j)*alu(jrow) - alu(j) = tl -! perform linear combination - do jj = ju(jrow), jlu(jrow+1)-1 - jw = int(iw(jlu(jj))) - if (jw .ne. 0) then - alu(jw) = alu(jw) - tl*alu(jj) -! write(*,*) ii, jw, jj - end if - end do - end do -! invert and store diagonal element. - if (abs(alu(ii)) .lt. epsmac) then - write (*,*) 'zero pivot' - stop - end if - alu(ii) = 1.0d0/alu(ii) -! reset pointer iw to zero - iw(ii) = 0 - do i = js, jf - iw(jlu(i)) = 0 - end do - end do -! end preconditioner - end if -!------------------------------------------------------------- - its = 0 -! outer loop starts here.. - if (lblas) then - call amux (n, sol, vv, aspar, ja, ia) - else - do iii = 1, n - t = 0.0d0 - do k = ia(iii), ia(iii+1)-1 - t = t + aspar(k) * sol(ja(k)) - end do - vv(iii,1) = t - end do - end if - do j=1,n - vv(j,1) = rhs(j) - vv(j,1) - end do - 20 if (lblas) then - ro = dnrm2(n, vv) - else - ro = sqrt(sum(vv(:,1)*vv(:,1))) - end if - if (abs(ro) .lt. epsmac) goto 999 - t = 1.0d0 / ro - do j=1, n - vv(j,1) = vv(j,1)*t - end do - if (its .eq. 0) eps1=eps*ro -! initialize 1-st term of rhs of hessenberg system.. - rs(1) = ro - i = 0 - 4 i=i+1 - its = its + 1 - i1 = i + 1 - if (lblas) then - call lusol (n, vv(1,i), rhs, alu, jlu, ju) - call amux (n, rhs, vv(1,i1), aspar, ja, ia) - else - do iii = 1, n !- lusol - rhs(iii) = vv(iii,i) - do k=jlu(iii),ju(iii)-1 - rhs(iii) = rhs(iii) - alu(k)* rhs(jlu(k)) - end do - end do - do iii = n, 1, -1 - do k=ju(iii),jlu(iii+1)-1 - rhs(iii) = rhs(iii) - alu(k)*rhs(jlu(k)) - end do - rhs(iii) = alu(iii)*rhs(iii) - end do - do iii = 1, n !- amux - t = 0.0d0 - do k = ia(iii), ia(iii+1)-1 - t = t + aspar(k) * rhs(ja(k)) - end do - vv(iii,i1) = t - end do - end if -! modified gram - schmidt... - if (lblas) then - do j=1, i - t = ddot(n, vv(1,j),vv(1,i1)) - hh(j,i) = t - call daxpy(n, -t, vv(1,j), 1, vv(1,i1), 1) - t = dnrm2(n, vv(1,i1)) - end do - else - do j=1, i - t = 0.d0 - do iii = 1,n - t = t + vv(iii,j)*vv(iii,i1) - end do - hh(j,i) = t - vv(:,i1) = vv(:,i1) - t * vv(:,j) - t = sqrt(sum(vv(:,i1)*vv(:,i1))) - end do - end if - hh(i1,i) = t - if ( abs(t) .lt. epsmac) goto 58 - t = 1.0d0/t - do k=1,n - vv(k,i1) = vv(k,i1)*t - end do -! done with modified gram schimd and arnoldi step.. now update factorization of hh -58 if (i .eq. 1) goto 121 - do k=2,i - k1 = k-1 - t = hh(k1,i) - hh(k1,i) = c(k1)*t + s(k1)*hh(k,i) - hh(k,i) = -s(k1)*t + c(k1)*hh(k,i) - end do -121 gam = sqrt(hh(i,i)**2 + hh(i1,i)**2) - if (abs(gam) .lt. epsmac) gam = epsmac -! get next plane rotation - c(i) = hh(i,i)/gam - s(i) = hh(i1,i)/gam - rs(i1) = -s(i)*rs(i) - rs(i) = c(i)*rs(i) -! detrermine residual norm and test for convergence- - hh(i,i) = c(i)*hh(i,i) + s(i)*hh(i1,i) - ro = abs(rs(i1)) - if (i .lt. im .and. (ro .gt. eps1)) goto 4 -! now compute solution. first solve upper triangular system. - rs(i) = rs(i)/hh(i,i) - do ii=2,i - k=i-ii+1 - k1 = k+1 - t=rs(k) - do j=k1,i - t = t-hh(k,j)*rs(j) - end do - rs(k) = t/hh(k,k) - end do -! form linear combination of v(*,i)'s to get solution - t = rs(1) - do k=1, n - rhs(k) = vv(k,1)*t - end do - do j = 2, i - t = rs(j) - do k=1, n - rhs(k) = rhs(k)+t*vv(k,j) - end do - end do -! call preconditioner. - if (lblas) then - call lusol (n, rhs, rhs, alu, jlu, ju) - else - do iii = 1, n - do k=jlu(iii),ju(iii)-1 - rhs(iii) = rhs(iii) - alu(k)* rhs(jlu(k)) - end do - end do - do iii = n, 1, -1 - do k=ju(iii),jlu(iii+1)-1 - rhs(iii) = rhs(iii) - alu(k)*rhs(jlu(k)) - end do - rhs(iii) = alu(iii)*rhs(iii) - end do - end if - do k=1, n - sol(k) = sol(k) + rhs(k) - end do -! restart outer loop when necessary - if (ro .le. eps1) goto 990 - if (its .ge. maxits) goto 991 -! else compute residual vector and continue.. - do j=1,i - jj = i1-j+1 - rs(jj-1) = -s(jj-1)*rs(jj) - rs(jj) = c(jj-1)*rs(jj) - end do - do j=1,i1 - t = rs(j) - if (j .eq. 1) t = t-1.0d0 - if (lblas) then - call daxpy (n, t, vv(1,j), 1, vv, 1) - else - vv(:,j) = vv(:,j) + t * vv(:,1) +subroutine pgmres(n, im, rhs, sol, eps, maxits, aspar, nnz, ia, ja, alu, jlu, ju, vv, ierr) + !----------------------------------------------------------------------- + ! use datapool, only : nnz, ia, ja, alu, jlu, ju, vv, aspar!, rhs, sol + implicit none + + integer :: n, im, maxits, ierr, nnz + + integer :: ja(nnz), ia(n+1) + integer :: jlu(nnz+1), ju(n) + real*8 :: vv(n,im+1), alu(nnz+1) + real*8 :: aspar(nnz) + + real*8 :: rhs(*), sol(*) + + real*8 :: eps + real*8 :: eps1, epsmac, gam, t, ddot, dnrm2, ro, tl + + integer :: i,i1,j,jj,k,k1,iii,ii,ju0 + integer :: its,jrow,jcol,jf,jm,js,jw + + real*8 :: hh(im+1,im), c(im), s(im), rs(im+1) + real*8 :: iw(n) + + logical :: lblas = .false. ! use sparskit matvec and external blas libs (true), don't use them (false) + logical :: lilu = .true. ! use simple ilu preconditioner + + data epsmac/1.d-16/ + + ! ilu0 preconditioner + + if (lilu) then + ju0 = n+2 + jlu(1) = ju0 !!! + iw = 0 + do ii = 1, n + js = ju0 + do j=ia(ii),ia(ii+1)-1 + jcol = ja(j) + if (jcol .eq. ii) then + alu(ii) = aspar(j) + iw(jcol) = ii + ju(ii) = ju0 !!! + else + alu(ju0) = aspar(j) + jlu(ju0) = ja(j) + iw(jcol) = ju0 + ju0 = ju0+1 + endif + end do + jlu(ii+1) = ju0 !!! + jf = ju0-1 + jm = ju(ii)-1 + ! exit if diagonal element is reached. + do j=js, jm + jrow = jlu(j) + tl = alu(j)*alu(jrow) + alu(j) = tl + ! perform linear combination + do jj = ju(jrow), jlu(jrow+1)-1 + jw = int(iw(jlu(jj))) + if (jw .ne. 0) then + alu(jw) = alu(jw) - tl*alu(jj) + ! write(*,*) ii, jw, jj end if - end do -! 199 format(' its =', i4, ' res. norm =', d20.6) -! restart outer loop. - goto 20 - 990 ierr = 0 - return - 991 ierr = 1 - return - 999 continue - ierr = -1 - return -!--------------------------------------------------------------------- + end do + end do + ! invert and store diagonal element. + if (abs(alu(ii)) .lt. epsmac) then + write (*,*) 'zero pivot' + stop + end if + alu(ii) = 1.0d0/alu(ii) + ! reset pointer iw to zero + iw(ii) = 0 + do i = js, jf + iw(jlu(i)) = 0 + end do + end do + ! end preconditioner + end if + !------------------------------------------------------------- + its = 0 + ! outer loop starts here.. + if (lblas) then + call amux (n, sol, vv, aspar, ja, ia) + else + do iii = 1, n + t = 0.0d0 + do k = ia(iii), ia(iii+1)-1 + t = t + aspar(k) * sol(ja(k)) + end do + vv(iii,1) = t + end do + end if + do j=1,n + vv(j,1) = rhs(j) - vv(j,1) + end do +20 if (lblas) then + ro = dnrm2(n, vv) + else + ro = sqrt(sum(vv(:,1)*vv(:,1))) + end if + if (abs(ro) .lt. epsmac) goto 999 + t = 1.0d0 / ro + do j=1, n + vv(j,1) = vv(j,1)*t + end do + if (its .eq. 0) eps1=eps*ro + ! initialize 1-st term of rhs of hessenberg system.. + rs(1) = ro + i = 0 +4 i=i+1 + its = its + 1 + i1 = i + 1 + if (lblas) then + call lusol (n, vv(1,i), rhs, alu, jlu, ju) + call amux (n, rhs, vv(1,i1), aspar, ja, ia) + else + do iii = 1, n !- lusol + rhs(iii) = vv(iii,i) + do k=jlu(iii),ju(iii)-1 + rhs(iii) = rhs(iii) - alu(k)* rhs(jlu(k)) + end do + end do + do iii = n, 1, -1 + do k=ju(iii),jlu(iii+1)-1 + rhs(iii) = rhs(iii) - alu(k)*rhs(jlu(k)) + end do + rhs(iii) = alu(iii)*rhs(iii) + end do + do iii = 1, n !- amux + t = 0.0d0 + do k = ia(iii), ia(iii+1)-1 + t = t + aspar(k) * rhs(ja(k)) + end do + vv(iii,i1) = t + end do + end if + ! modified gram - schmidt... + if (lblas) then + do j=1, i + t = ddot(n, vv(1,j),vv(1,i1)) + hh(j,i) = t + call daxpy(n, -t, vv(1,j), 1, vv(1,i1), 1) + t = dnrm2(n, vv(1,i1)) + end do + else + do j=1, i + t = 0.d0 + do iii = 1,n + t = t + vv(iii,j)*vv(iii,i1) + end do + hh(j,i) = t + vv(:,i1) = vv(:,i1) - t * vv(:,j) + t = sqrt(sum(vv(:,i1)*vv(:,i1))) + end do + end if + hh(i1,i) = t + if ( abs(t) .lt. epsmac) goto 58 + t = 1.0d0/t + do k=1,n + vv(k,i1) = vv(k,i1)*t + end do + ! done with modified gram schimd and arnoldi step.. now update factorization of hh +58 if (i .eq. 1) goto 121 + do k=2,i + k1 = k-1 + t = hh(k1,i) + hh(k1,i) = c(k1)*t + s(k1)*hh(k,i) + hh(k,i) = -s(k1)*t + c(k1)*hh(k,i) + end do +121 gam = sqrt(hh(i,i)**2 + hh(i1,i)**2) + if (abs(gam) .lt. epsmac) gam = epsmac + ! get next plane rotation + c(i) = hh(i,i)/gam + s(i) = hh(i1,i)/gam + rs(i1) = -s(i)*rs(i) + rs(i) = c(i)*rs(i) + ! detrermine residual norm and test for convergence- + hh(i,i) = c(i)*hh(i,i) + s(i)*hh(i1,i) + ro = abs(rs(i1)) + if (i .lt. im .and. (ro .gt. eps1)) goto 4 + ! now compute solution. first solve upper triangular system. + rs(i) = rs(i)/hh(i,i) + do ii=2,i + k=i-ii+1 + k1 = k+1 + t=rs(k) + do j=k1,i + t = t-hh(k,j)*rs(j) + end do + rs(k) = t/hh(k,k) + end do + ! form linear combination of v(*,i)'s to get solution + t = rs(1) + do k=1, n + rhs(k) = vv(k,1)*t + end do + do j = 2, i + t = rs(j) + do k=1, n + rhs(k) = rhs(k)+t*vv(k,j) + end do + end do + ! call preconditioner. + if (lblas) then + call lusol (n, rhs, rhs, alu, jlu, ju) + else + do iii = 1, n + do k=jlu(iii),ju(iii)-1 + rhs(iii) = rhs(iii) - alu(k)* rhs(jlu(k)) + end do + end do + do iii = n, 1, -1 + do k=ju(iii),jlu(iii+1)-1 + rhs(iii) = rhs(iii) - alu(k)*rhs(jlu(k)) + end do + rhs(iii) = alu(iii)*rhs(iii) + end do + end if + do k=1, n + sol(k) = sol(k) + rhs(k) + end do + ! restart outer loop when necessary + if (ro .le. eps1) goto 990 + if (its .ge. maxits) goto 991 + ! else compute residual vector and continue.. + do j=1,i + jj = i1-j+1 + rs(jj-1) = -s(jj-1)*rs(jj) + rs(jj) = c(jj-1)*rs(jj) + end do + do j=1,i1 + t = rs(j) + if (j .eq. 1) t = t-1.0d0 + if (lblas) then + call daxpy (n, t, vv(1,j), 1, vv, 1) + else + vv(:,j) = vv(:,j) + t * vv(:,1) + end if + end do + ! 199 format(' its =', i4, ' res. norm =', d20.6) + ! restart outer loop. + goto 20 +990 ierr = 0 + return +991 ierr = 1 + return +999 continue + ierr = -1 + return + !--------------------------------------------------------------------- end subroutine pgmres !----------------------------------------------------------------------- @@ -4492,192 +4492,192 @@ end subroutine pgmres !----------------------------------------------------------------------- ! subroutine from blas1.f90 !----------------------------------------------------------------------- - DOUBLE PRECISION FUNCTION DNRM2(N,X) -! .. Scalar Arguments .. - INTEGER N -! .. -! .. Array Arguments .. - DOUBLE PRECISION X(*) -! .. -! -! Purpose -! ======= -! -! DNRM2 returns the euclidean norm of a vector via the function -! name, so that -! -! DNRM2 := sqrt( x'*x ) -! -! Further Details -! =============== -! -! -- This version written on 25-October-1982. -! Modified on 14-October-1993 to inline the call to DLASSQ. -! Sven Hammarling, Nag Ltd. -! -! ===================================================================== -! -! .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -! .. -! .. Local Scalars .. - DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ - INTEGER IX -! .. -! .. Intrinsic Functions .. - INTRINSIC ABS,SQRT -! .. - IF (N.LT.1 ) THEN - NORM = ZERO - ELSE IF (N.EQ.1) THEN - NORM = ABS(X(1)) - ELSE - SCALE = ZERO - SSQ = ONE -! The following loop is equivalent to this call to the LAPACK -! auxiliary routine: -! CALL DLASSQ( N, X, SCALE, SSQ ) -! - DO IX = 1,1 + (N-1) - IF (X(IX).NE.ZERO) THEN - ABSXI = ABS(X(IX)) - IF (SCALE.LT.ABSXI) THEN - SSQ = ONE + SSQ* (SCALE/ABSXI)**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + (ABSXI/SCALE)**2 - END IF - END IF - end do - NORM = SCALE*SQRT(SSQ) +DOUBLE PRECISION FUNCTION DNRM2(N,X) + ! .. Scalar Arguments .. + INTEGER N + ! .. + ! .. Array Arguments .. + DOUBLE PRECISION X(*) + ! .. + ! + ! Purpose + ! ======= + ! + ! DNRM2 returns the euclidean norm of a vector via the function + ! name, so that + ! + ! DNRM2 := sqrt( x'*x ) + ! + ! Further Details + ! =============== + ! + ! -- This version written on 25-October-1982. + ! Modified on 14-October-1993 to inline the call to DLASSQ. + ! Sven Hammarling, Nag Ltd. + ! + ! ===================================================================== + ! + ! .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) + ! .. + ! .. Local Scalars .. + DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ + INTEGER IX + ! .. + ! .. Intrinsic Functions .. + INTRINSIC ABS,SQRT + ! .. + IF (N.LT.1 ) THEN + NORM = ZERO + ELSE IF (N.EQ.1) THEN + NORM = ABS(X(1)) + ELSE + SCALE = ZERO + SSQ = ONE + ! The following loop is equivalent to this call to the LAPACK + ! auxiliary routine: + ! CALL DLASSQ( N, X, SCALE, SSQ ) + ! + DO IX = 1,1 + (N-1) + IF (X(IX).NE.ZERO) THEN + ABSXI = ABS(X(IX)) + IF (SCALE.LT.ABSXI) THEN + SSQ = ONE + SSQ* (SCALE/ABSXI)**2 + SCALE = ABSXI + ELSE + SSQ = SSQ + (ABSXI/SCALE)**2 + END IF END IF -! - DNRM2 = NORM - RETURN -! -! End of DNRM2. -! + end do + NORM = SCALE*SQRT(SSQ) + END IF + ! + DNRM2 = NORM + RETURN + ! + ! End of DNRM2. + ! END function dnrm2 !----------------------------------------------------------------------- - SUBROUTINE DLASSQ( N, X, SCALE, SUMSQ ) -! -! -- LAPACK auxiliary routine (version 3.1) -- -! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -! November 2006 - INTEGER N -DOUBLE PRECISION SCALE, SUMSQ -DOUBLE PRECISION X( * ) -! -! DLASSQ returns the values scl and smsq such that -! -! ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -! -! where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is -! assumed to be non-negative and scl returns the value -! -! scl = max( scale, abs( x( i ) ) ). -! -! SCALE (input/output) DOUBLE PRECISION -! On entry, the value scale in the equation above. -! On exit, SCALE is overwritten with scl , the scaling factor -! for the sum of squares. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - INTEGER IX - DOUBLE PRECISION ABSXI - INTRINSIC ABS -! - IF( N.GT.0 ) THEN - DO IX = 1, 1 + ( N-1 ) - IF( X( IX ).NE.ZERO ) THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 - SCALE = ABSXI - ELSE - SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 - END IF - END IF - END DO +SUBROUTINE DLASSQ( N, X, SCALE, SUMSQ ) + ! + ! -- LAPACK auxiliary routine (version 3.1) -- + ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + ! November 2006 + INTEGER N + DOUBLE PRECISION SCALE, SUMSQ + DOUBLE PRECISION X( * ) + ! + ! DLASSQ returns the values scl and smsq such that + ! + ! ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, + ! + ! where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is + ! assumed to be non-negative and scl returns the value + ! + ! scl = max( scale, abs( x( i ) ) ). + ! + ! SCALE (input/output) DOUBLE PRECISION + ! On entry, the value scale in the equation above. + ! On exit, SCALE is overwritten with scl , the scaling factor + ! for the sum of squares. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + INTEGER IX + DOUBLE PRECISION ABSXI + INTRINSIC ABS + ! + IF( N.GT.0 ) THEN + DO IX = 1, 1 + ( N-1 ) + IF( X( IX ).NE.ZERO ) THEN + ABSXI = ABS( X( IX ) ) + IF( SCALE.LT.ABSXI ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 + SCALE = ABSXI + ELSE + SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 END IF - RETURN + END IF + END DO + END IF + RETURN END SUBROUTINE DLASSQ !------------------------------------------------------------------------- - double precision function ddot(n,dx,dy) -! -! forms the dot product of two vectors. -! uses unrolled loops for increments equal to one. -! jack dongarra, linpack, 3/11/78. -! - double precision dx(*),dy(*),dtemp - integer i,m,mp1,n -! - ddot = 0.0d0 - dtemp = 0.0d0 - if(n.le.0)return +double precision function ddot(n,dx,dy) + ! + ! forms the dot product of two vectors. + ! uses unrolled loops for increments equal to one. + ! jack dongarra, linpack, 3/11/78. + ! + double precision dx(*),dy(*),dtemp + integer i,m,mp1,n + ! + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 +20 m = mod(n,5) + if( m .eq. 0 ) go to 40 do i = 1,m - dtemp = dtemp + dx(i)*dy(i) + dtemp = dtemp + dx(i)*dy(i) end do - if( n .lt. 5 ) go to 60 - 40 mp1 = m + 1 + if( n .lt. 5 ) go to 60 +40 mp1 = m + 1 do i = mp1,n,5 - dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + & - & dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + & + & dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) end do - 60 ddot = dtemp - return +60 ddot = dtemp + return end function ddot !---------------------------------------------------------------------- - subroutine daxpy(n,da,dx,incx,dy,incy) -! -! constant times a vector plus a vector. -! uses unrolled loops for increments equal to one. -! jack dongarra, linpack, 3/11/78. -! - double precision dx(1),dy(1),da - integer i,incx,incy,ix,iy,m,mp1,n -! - if(n.le.0)return - if (abs(da) .lt. tiny(1.d0)) return - if(incx.eq.1.and.incy.eq.1)go to 20 -! -! code for unequal increments or equal increments -! not equal to 1 -! - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 +subroutine daxpy(n,da,dx,incx,dy,incy) + ! + ! constant times a vector plus a vector. + ! uses unrolled loops for increments equal to one. + ! jack dongarra, linpack, 3/11/78. + ! + double precision dx(1),dy(1),da + integer i,incx,incy,ix,iy,m,mp1,n + ! + if(n.le.0)return + if (abs(da) .lt. tiny(1.d0)) return + if(incx.eq.1.and.incy.eq.1)go to 20 + ! + ! code for unequal increments or equal increments + ! not equal to 1 + ! + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 do i = 1,n - dy(iy) = dy(iy) + da*dx(ix) - ix = ix + incx - iy = iy + incy + dy(iy) = dy(iy) + da*dx(ix) + ix = ix + incx + iy = iy + incy end do - return -! -! code for both increments equal to 1 -! -! -! clean-up loop -! - 20 m = mod(n,4) - if( m .eq. 0 ) go to 40 + return + ! + ! code for both increments equal to 1 + ! + ! + ! clean-up loop + ! +20 m = mod(n,4) + if( m .eq. 0 ) go to 40 do i = 1,m - dy(i) = dy(i) + da*dx(i) + dy(i) = dy(i) + da*dx(i) end do - if( n .lt. 4 ) return - 40 mp1 = m + 1 + if( n .lt. 4 ) return +40 mp1 = m + 1 do i = mp1,n,4 - dy(i) = dy(i) + da*dx(i) - dy(i + 1) = dy(i + 1) + da*dx(i + 1) - dy(i + 2) = dy(i + 2) + da*dx(i + 2) - dy(i + 3) = dy(i + 3) + da*dx(i + 3) + dy(i) = dy(i) + da*dx(i) + dy(i + 1) = dy(i + 1) + da*dx(i + 1) + dy(i + 2) = dy(i + 2) + da*dx(i + 2) + dy(i + 3) = dy(i + 3) + da*dx(i + 3) end do - return + return end subroutine daxpy diff --git a/model/src/w3profsmd_pdlib.F90 b/model/src/w3profsmd_pdlib.F90 index 81757788d..89ea1363a 100644 --- a/model/src/w3profsmd_pdlib.F90 +++ b/model/src/w3profsmd_pdlib.F90 @@ -1,3983 +1,3763 @@ #include "w3macros.h" !/ !/ ------------------------------------------------------------------- / - MODULE PDLIB_W3PROFSMD -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 95 | -!/ | Last update : 1-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2016 : Origination ( version 6.04 ) -!/ -! 1. Purpose : PDLIB version of UGTYPE including fully implicit -! discretization. This works is based on the thesis -! of Roland, 2008 and represents the continues -! development of the solution of the WAE on unstructured -! grids. Following the quest since one decade we -! continuesly improve the aplicability and robustness of -! the source code and the methods. The development and -! implementation of the involved schemes was funded over -! the past decade by IFREMER, SHOM, USACE, NCEP/NOAA, -! BGS IT&E GmbH, Zanke & Partner and Roland & Partner. -! The PDLIB (Parallel Decomposition Library) library, -! which is used here is courtesy to BGS IT&E GmbH and -! has it's own license, which is the same as WW3. As of -! the origin of the methods, ideas and source code. This -! code was 1st developed in the WWM-III (Roland, 2008) and -! the ported to WW3. This is true for all source code -! related to UGTYPE. -! -! -! 2. Method : We apply here the framework of Residual Distributions -! schemes for hyperbolic problems for nonlinear propagation -! laws based on the work of Richiuotto et al. 2005. -! We supply the N-scheme, PSI-scheme and Lax-FCT-scheme -! as explicit methods ranging from 1st order time space -! to most optimal PSI method up to 2nd order Lax-FCT-scheme. -! For the implicit implementation we used up to now only -! the N-Scheme. Higher order schemes are up to now rather -! a research feature than for practical application. The -! reason is given in Cavalleri et al. 2018, we do not -! resolve enough physics in order to be able to run -! 2nd or even higher order schemes. -! Use the numerical schemes with the needed care and -! do proper convergence analysis on the time step and -! grid size as well as solver threshold depedency. -! Think about the time and spatial scales of your -! u r intending to resolve! Multiscale modelling needs -! much work on the side of the modeler and much more -! time for the grid generation and the validation of the -! final model -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +MODULE PDLIB_W3PROFSMD + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 95 | + !/ | Last update : 1-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2016 : Origination ( version 6.04 ) + !/ + ! 1. Purpose : PDLIB version of UGTYPE including fully implicit + ! discretization. This works is based on the thesis + ! of Roland, 2008 and represents the continues + ! development of the solution of the WAE on unstructured + ! grids. Following the quest since one decade we + ! continuesly improve the aplicability and robustness of + ! the source code and the methods. The development and + ! implementation of the involved schemes was funded over + ! the past decade by IFREMER, SHOM, USACE, NCEP/NOAA, + ! BGS IT&E GmbH, Zanke & Partner and Roland & Partner. + ! The PDLIB (Parallel Decomposition Library) library, + ! which is used here is courtesy to BGS IT&E GmbH and + ! has it's own license, which is the same as WW3. As of + ! the origin of the methods, ideas and source code. This + ! code was 1st developed in the WWM-III (Roland, 2008) and + ! the ported to WW3. This is true for all source code + ! related to UGTYPE. + ! + ! + ! 2. Method : We apply here the framework of Residual Distributions + ! schemes for hyperbolic problems for nonlinear propagation + ! laws based on the work of Richiuotto et al. 2005. + ! We supply the N-scheme, PSI-scheme and Lax-FCT-scheme + ! as explicit methods ranging from 1st order time space + ! to most optimal PSI method up to 2nd order Lax-FCT-scheme. + ! For the implicit implementation we used up to now only + ! the N-Scheme. Higher order schemes are up to now rather + ! a research feature than for practical application. The + ! reason is given in Cavalleri et al. 2018, we do not + ! resolve enough physics in order to be able to run + ! 2nd or even higher order schemes. + ! Use the numerical schemes with the needed care and + ! do proper convergence analysis on the time step and + ! grid size as well as solver threshold depedency. + ! Think about the time and spatial scales of your + ! u r intending to resolve! Multiscale modelling needs + ! much work on the side of the modeler and much more + ! time for the grid generation and the validation of the + ! final model + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3SERVMD, only: STRACE +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ -!/ Public variables -!/ - LOGICAL :: MAPSTA_HACK = .FALSE. - REAL, ALLOCATABLE :: ASPAR_JAC(:,:), ASPAR_DIAG_SOURCES(:,:), ASPAR_DIAG_ALL(:,:), B_JAC(:,:) - REAL, ALLOCATABLE :: CAD_THE(:,:), CAS_SIG(:,:) - REAL, ALLOCATABLE :: CWNB_SIG_M2(:,:) - REAL, ALLOCATABLE :: U_JAC(:,:) - REAL, ALLOCATABLE :: COFRM4(:) - INTEGER, ALLOCATABLE :: IS0_pdlib(:) - INTEGER :: FreqShiftMethod = 2 - LOGICAL :: FSGEOADVECT - INTEGER :: POS_TRICK(3,2) + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ + !/ Public variables + !/ + LOGICAL :: MAPSTA_HACK = .FALSE. + REAL, ALLOCATABLE :: ASPAR_JAC(:,:), ASPAR_DIAG_SOURCES(:,:), ASPAR_DIAG_ALL(:,:), B_JAC(:,:) + REAL, ALLOCATABLE :: CAD_THE(:,:), CAS_SIG(:,:) + REAL, ALLOCATABLE :: CWNB_SIG_M2(:,:) + REAL, ALLOCATABLE :: U_JAC(:,:) + REAL, ALLOCATABLE :: COFRM4(:) + INTEGER, ALLOCATABLE :: IS0_pdlib(:) + INTEGER :: FreqShiftMethod = 2 + LOGICAL :: FSGEOADVECT + INTEGER :: POS_TRICK(3,2) #ifdef W3_DEBUGSRC - INTEGER :: TESTNODE = 1 -#endif -! -!/ ------------------------------------------------------------------- / -! - CONTAINS -! -!/ ------------------------------------------------------------------- / -! -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_INIT(IMOD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init pdlib part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + INTEGER :: TESTNODE = 1 +#endif + ! + !/ ------------------------------------------------------------------- / + ! +CONTAINS + ! + !/ ------------------------------------------------------------------- / + ! + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_INIT(IMOD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init pdlib part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE + USE W3SERVMD, only: STRACE #endif -! - USE W3GDATMD, only: FLCX, FLCY + ! + USE W3GDATMD, only: FLCX, FLCY #ifdef W3_MEMCHECK - USE MallocInfo_m -#endif - USE CONSTANTS, only : GRAV, TPI - USE W3GDATMD, only: XGRD, YGRD, NX, NSEA, NTRI, TRIGP, NSPEC, NSEAL - USE W3GDATMD, only: MAPSTA, MAPFS, GRIDS, NTH, SIG, NK - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3GDATMD, only: CCON, COUNTCON, INDEX_CELL, IE_CELL - USE W3GDATMD, only: IOBP, IOBPA, IOBPD, IOBDP, SI + USE MallocInfo_m +#endif + USE CONSTANTS, only : GRAV, TPI + USE W3GDATMD, only: XGRD, YGRD, NX, NSEA, NTRI, TRIGP, NSPEC, NSEAL + USE W3GDATMD, only: MAPSTA, MAPFS, GRIDS, NTH, SIG, NK + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3GDATMD, only: CCON, COUNTCON, INDEX_CELL, IE_CELL + USE W3GDATMD, only: IOBP, IOBPA, IOBPD, IOBDP, SI #ifdef W3_MEMCHECK - USE W3ADATMD, only: MALLINFOS -#endif - - USE W3ADATMD, only: MPI_COMM_WCMP, MPI_COMM_WAVE - USE W3ODATMD, only: IAPROC, NAPROC, NTPROC - USE yowDatapool, only: istatus - USE yowpdlibMain, only: initFromGridDim - USE YOWNODEPOOL, only: npa, np, iplg - USE W3PARALL, only : PDLIB_NSEAL, PDLIB_NSEALM - USE W3PARALL, only : JX_TO_JSEA, ISEA_TO_JSEA - USE yowfunction, only : ComputeListNP_ListNPA_ListIPLG, pdlib_abort -!/ - IMPLICIT NONE - INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3ADATMD, only: MALLINFOS +#endif + + USE W3ADATMD, only: MPI_COMM_WCMP, MPI_COMM_WAVE + USE W3ODATMD, only: IAPROC, NAPROC, NTPROC + USE yowDatapool, only: istatus + USE yowpdlibMain, only: initFromGridDim + USE YOWNODEPOOL, only: npa, np, iplg + USE W3PARALL, only : PDLIB_NSEAL, PDLIB_NSEALM + USE W3PARALL, only : JX_TO_JSEA, ISEA_TO_JSEA + USE yowfunction, only : ComputeListNP_ListNPA_ListIPLG, pdlib_abort + !/ + IMPLICIT NONE + INCLUDE "mpif.h" + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -!! INCLUDE "mpif.h" - INTEGER :: istat - INTEGER :: I, J, IBND_MAP, ISEA, IP, IX, JSEA, nb - INTEGER :: IP_glob - INTEGER :: myrank, ierr, iproc - INTEGER, ALLOCATABLE :: NSEAL_arr(:) - INTEGER :: IERR_MPI - INTEGER :: IScal(1) - INTEGER, INTENT(in) :: IMOD - INTEGER :: IK, ISP - INTEGER IK0, ISP0, ITH - REAL :: eSIG, eFR - REAL, PARAMETER :: COEF4 = 5.0E-7 + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + !! INCLUDE "mpif.h" + INTEGER :: istat + INTEGER :: I, J, IBND_MAP, ISEA, IP, IX, JSEA, nb + INTEGER :: IP_glob + INTEGER :: myrank, ierr, iproc + INTEGER, ALLOCATABLE :: NSEAL_arr(:) + INTEGER :: IERR_MPI + INTEGER :: IScal(1) + INTEGER, INTENT(in) :: IMOD + INTEGER :: IK, ISP + INTEGER IK0, ISP0, ITH + REAL :: eSIG, eFR + REAL, PARAMETER :: COEF4 = 5.0E-7 #ifdef W3_S - CALL STRACE (IENT, 'PDLIB_INIT') + CALL STRACE (IENT, 'PDLIB_INIT') #endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'PDLIB_INIT, IMOD (no print)' - WRITE(740+IAPROC,*) 'NAPROC=', NAPROC - WRITE(740+IAPROC,*) 'NTPROC=', NTPROC - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_INIT, IMOD (no print)' + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC + WRITE(740+IAPROC,*) 'NTPROC=', NTPROC + FLUSH(740+IAPROC) #endif - PDLIB_NSEAL = 0 + PDLIB_NSEAL = 0 - IF (IAPROC .le. NAPROC) THEN + IF (IAPROC .le. NAPROC) THEN - CALL MPI_COMM_RANK(MPI_COMM_WCMP, myrank, ierr) -! -#ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'PDLIB_INIT, IAPROC=', IAPROC - WRITE(740+IAPROC,*) 'PDLIB_INIT, NAPROC=', NAPROC - WRITE(740+IAPROC,*) 'PDLIB_INIT, myrank=', myrank - FLUSH(740+IAPROC) -#endif -! - CALL initFromGridDim(NX,NTRI,TRIGP,NSPEC,MPI_COMM_WCMP) -! + CALL MPI_COMM_RANK(MPI_COMM_WCMP, myrank, ierr) + ! #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'After initFromGridDim' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_INIT, IAPROC=', IAPROC + WRITE(740+IAPROC,*) 'PDLIB_INIT, NAPROC=', NAPROC + WRITE(740+IAPROC,*) 'PDLIB_INIT, myrank=', myrank + FLUSH(740+IAPROC) #endif -! - ! - ! Now the computation of NSEAL - ! -! - DO IP = 1, npa - IX = iplg(IP) - ISEA = MAPFS(1,IX) - IF (ISEA .gt. 0) PDLIB_NSEAL = PDLIB_NSEAL + 1 - END DO + ! + CALL initFromGridDim(NX,NTRI,TRIGP,NSPEC,MPI_COMM_WCMP) + ! #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'npa is augmented domain over NX' - WRITE(740+IAPROC,*) 'PDLIB_NSEAL is basicall npa but only over the wet points' - WRITE(740+IAPROC,*) 'NSEAL is set to PDLIB_NSEAL' - WRITE(740+IAPROC,*) 'PDLIB_NSEAL=', PDLIB_NSEAL - WRITE(740+IAPROC,*) 'NSEAL =', NSEAL, 'NP =', NP, 'NPA =', NPA - FLUSH(740+IAPROC) -#endif - ALLOCATE(JX_TO_JSEA(npa), ISEA_TO_JSEA(NSEA), stat=istat) + WRITE(740+IAPROC,*) 'After initFromGridDim' + FLUSH(740+IAPROC) +#endif + ! + ! + ! Now the computation of NSEAL + ! + ! + DO IP = 1, npa + IX = iplg(IP) + ISEA = MAPFS(1,IX) + IF (ISEA .gt. 0) PDLIB_NSEAL = PDLIB_NSEAL + 1 + END DO #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'ISEA_TO_JSEA ALLOCATEd' - FLUSH(740+IAPROC) -#endif - if(istat /= 0) CALL PDLIB_ABORT(3) - JSEA = 0 - JX_TO_JSEA = 0 - ISEA_TO_JSEA = 0 - DO IP = 1, npa - IX = iplg(IP) - ISEA = MAPFS(1,IX) - IF (ISEA .gt. 0) THEN - JSEA=JSEA+1 - JX_TO_JSEA(IP)=JSEA - ISEA_TO_JSEA(ISEA)=JSEA - END IF - END DO -! + WRITE(740+IAPROC,*) 'npa is augmented domain over NX' + WRITE(740+IAPROC,*) 'PDLIB_NSEAL is basicall npa but only over the wet points' + WRITE(740+IAPROC,*) 'NSEAL is set to PDLIB_NSEAL' + WRITE(740+IAPROC,*) 'PDLIB_NSEAL=', PDLIB_NSEAL + WRITE(740+IAPROC,*) 'NSEAL =', NSEAL, 'NP =', NP, 'NPA =', NPA + FLUSH(740+IAPROC) +#endif + ALLOCATE(JX_TO_JSEA(npa), ISEA_TO_JSEA(NSEA), stat=istat) #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'After JX_TO_JSEA, ISEA_TO_JSEA and friend computation' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ISEA_TO_JSEA ALLOCATEd' + FLUSH(740+IAPROC) #endif - ! - ! Map a point in (1:PDLIB_NSEAL) to a point in (1:NSEA) - ! - nb=0 - DO IX=1,NX - IF (MAPFS(1,IX) .gt. 0) nb = nb + 1 - END DO - - IF (nb .ne. NSEA) THEN - WRITE(*,*) 'Logical error in computation of NSEA / nb' - WRITE(*,*) 'nb=', nb, ' NSEA=', NSEA - STOP + if(istat /= 0) CALL PDLIB_ABORT(3) + JSEA = 0 + JX_TO_JSEA = 0 + ISEA_TO_JSEA = 0 + DO IP = 1, npa + IX = iplg(IP) + ISEA = MAPFS(1,IX) + IF (ISEA .gt. 0) THEN + JSEA=JSEA+1 + JX_TO_JSEA(IP)=JSEA + ISEA_TO_JSEA(ISEA)=JSEA END IF + END DO + ! #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'nb / NSEA consistency check' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'After JX_TO_JSEA, ISEA_TO_JSEA and friend computation' + FLUSH(740+IAPROC) #endif - END IF - FSGEOADVECT = .FALSE. - IF ((FLCX .eqv. .TRUE.).and.(FLCY .eqv. .TRUE.)) THEN - FSGEOADVECT =.TRUE. - END IF ! - ! Compute NSEALM + ! Map a point in (1:PDLIB_NSEAL) to a point in (1:NSEA) ! - IF (IAPROC .le. NAPROC) THEN - IF (IAPROC .eq. 1) THEN - ALLOCATE(NSEAL_arr(NAPROC)) - NSEAL_arr(1)=PDLIB_NSEAL - DO IPROC=2,NAPROC - CALL MPI_RECV(IScal,1,MPI_INT, IPROC-1, 23, MPI_COMM_WAVE, istatus, IERR_MPI) - NSEAL_arr(IPROC)=IScal(1) - END DO - PDLIB_NSEALM=maxval(NSEAL_arr) - DEALLOCATE(NSEAL_arr) - ELSE - IScal(1)=PDLIB_NSEAL - CALL MPI_SEND(IScal,1,MPI_INT, 0, 23, MPI_COMM_WAVE, IERR_MPI) - END IF + nb=0 + DO IX=1,NX + IF (MAPFS(1,IX) .gt. 0) nb = nb + 1 + END DO + + IF (nb .ne. NSEA) THEN + WRITE(*,*) 'Logical error in computation of NSEA / nb' + WRITE(*,*) 'nb=', nb, ' NSEA=', NSEA + STOP END IF - ! +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'nb / NSEA consistency check' + FLUSH(740+IAPROC) +#endif + END IF + FSGEOADVECT = .FALSE. + IF ((FLCX .eqv. .TRUE.).and.(FLCY .eqv. .TRUE.)) THEN + FSGEOADVECT =.TRUE. + END IF + ! + ! Compute NSEALM + ! + IF (IAPROC .le. NAPROC) THEN IF (IAPROC .eq. 1) THEN - IScal(1)=PDLIB_NSEALM - DO IPROC = 2 , NTPROC - CALL MPI_SEND(IScal,1,MPI_INT, IPROC-1, 24, MPI_COMM_WAVE, IERR_MPI) + ALLOCATE(NSEAL_arr(NAPROC)) + NSEAL_arr(1)=PDLIB_NSEAL + DO IPROC=2,NAPROC + CALL MPI_RECV(IScal,1,MPI_INT, IPROC-1, 23, MPI_COMM_WAVE, istatus, IERR_MPI) + NSEAL_arr(IPROC)=IScal(1) END DO + PDLIB_NSEALM=maxval(NSEAL_arr) + DEALLOCATE(NSEAL_arr) ELSE - CALL MPI_RECV(IScal,1,MPI_INT, 0, 24, MPI_COMM_WAVE, istatus, IERR_MPI) - PDLIB_NSEALM=IScal(1) + IScal(1)=PDLIB_NSEAL + CALL MPI_SEND(IScal,1,MPI_INT, 0, 23, MPI_COMM_WAVE, IERR_MPI) END IF + END IF + ! + IF (IAPROC .eq. 1) THEN + IScal(1)=PDLIB_NSEALM + DO IPROC = 2 , NTPROC + CALL MPI_SEND(IScal,1,MPI_INT, IPROC-1, 24, MPI_COMM_WAVE, IERR_MPI) + END DO + ELSE + CALL MPI_RECV(IScal,1,MPI_INT, 0, 24, MPI_COMM_WAVE, istatus, IERR_MPI) + PDLIB_NSEALM=IScal(1) + END IF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'ALLOCATEd(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) - WRITE(740+IAPROC,*) 'PDLIB_NSEALM=', PDLIB_NSEALM - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ALLOCATEd(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) + WRITE(740+IAPROC,*) 'PDLIB_NSEALM=', PDLIB_NSEALM + FLUSH(740+IAPROC) #endif -! - CALL ComputeListNP_ListNPA_ListIPLG - ALLOCATE(COFRM4(NK)) - DO IK=1,NK - eSIG=SIG(IK) - eFR=eSIG/TPI - COFRM4(IK)=COEF4*GRAV/(eFR**4) - END DO - ALLOCATE(IS0_pdlib(NSPEC)) - DO ISP=1, NSPEC - IS0_pdlib(ISP) = ISP - 1 - END DO - DO ISP=1, NSPEC, NTH - IS0_pdlib(ISP) = IS0_pdlib(ISP) + NTH - END DO - - DO JSEA=1, PDLIB_NSEAL - IP = JSEA - IP_glob = iplg(IP) - ISEA = MAPFS(1,IP_glob) - IF (ISEA .ne. IP_glob) THEN - WRITE(*,*) JSEA, PDLIB_NSEAL, IP, IP_glob, ISEA - WRITE(*,*) 'ISEA .ne. IP_glob' - CALL PDLIB_ABORT(20) - ENDIF - ENDDO -! -! -!/ -!/ End of PDLIB_INIT ------------------------------------------- / -!/ - END SUBROUTINE PDLIB_INIT -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_MAPSTA_INIT(IMOD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init mapsta part for pdlib -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! + CALL ComputeListNP_ListNPA_ListIPLG + ALLOCATE(COFRM4(NK)) + DO IK=1,NK + eSIG=SIG(IK) + eFR=eSIG/TPI + COFRM4(IK)=COEF4*GRAV/(eFR**4) + END DO + ALLOCATE(IS0_pdlib(NSPEC)) + DO ISP=1, NSPEC + IS0_pdlib(ISP) = ISP - 1 + END DO + DO ISP=1, NSPEC, NTH + IS0_pdlib(ISP) = IS0_pdlib(ISP) + NTH + END DO + + DO JSEA=1, PDLIB_NSEAL + IP = JSEA + IP_glob = iplg(IP) + ISEA = MAPFS(1,IP_glob) + IF (ISEA .ne. IP_glob) THEN + WRITE(*,*) JSEA, PDLIB_NSEAL, IP, IP_glob, ISEA + WRITE(*,*) 'ISEA .ne. IP_glob' + CALL PDLIB_ABORT(20) + ENDIF + ENDDO + ! + ! + !/ + !/ End of PDLIB_INIT ------------------------------------------- / + !/ + END SUBROUTINE PDLIB_INIT + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_MAPSTA_INIT(IMOD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init mapsta part for pdlib + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only : INDEX_MAP, NBND_MAP, NSEA, NSEAL, MAPSTA, GRIDS, NX, NTH - USE W3GDATMD, only : MAPSTA_LOC, NBND_MAP, INDEX_MAP - USE W3ODATMD, only : IAPROC, NAPROC - USE YOWNODEPOOL, only: iplg, npa - USE yowfunction, only: pdlib_abort - USE W3ODATMD, only: IAPROC -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only : INDEX_MAP, NBND_MAP, NSEA, NSEAL, MAPSTA, GRIDS, NX, NTH + USE W3GDATMD, only : MAPSTA_LOC, NBND_MAP, INDEX_MAP + USE W3ODATMD, only : IAPROC, NAPROC + USE YOWNODEPOOL, only: iplg, npa + USE yowfunction, only: pdlib_abort + USE W3ODATMD, only: IAPROC + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: IBND_MAP, ISEA, JSEA, IX, IP, IP_glob - INTEGER, INTENT(in) :: IMOD - INTEGER :: Status(NX), istat - REAL :: rtmp(nseal) + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: IBND_MAP, ISEA, JSEA, IX, IP, IP_glob + INTEGER, INTENT(in) :: IMOD + INTEGER :: Status(NX), istat + REAL :: rtmp(nseal) #ifdef W3_S - CALL STRACE (IENT, 'PDLIB_MAPSTA_INIT') + CALL STRACE (IENT, 'PDLIB_MAPSTA_INIT') #endif #ifdef W3_DEBUGINIT - WRITE(*,*) 'Passing by PDLIB_MAPSTA_INIT IAPROC=', IAPROC + WRITE(*,*) 'Passing by PDLIB_MAPSTA_INIT IAPROC=', IAPROC #endif - IF (IAPROC .gt. NAPROC) THEN - RETURN + IF (IAPROC .gt. NAPROC) THEN + RETURN + END IF + + ALLOCATE(GRIDS(IMOD)%MAPSTA_LOC(npa), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(5) + MAPSTA_LOC => GRIDS(IMOD)%MAPSTA_LOC + NBND_MAP => GRIDS(IMOD)%NBND_MAP + Status = 0 + DO IP=1,npa + IP_glob=iplg(IP) + Status(IP_glob)=IP + MAPSTA_LOC(IP)=MAPSTA(1,IP_glob) + END DO + NBND_MAP = 0 + DO IX=1,NX + IF ((MAPSTA(1,IX) .lt. 1).and.(Status(IX).gt.0)) THEN + NBND_MAP = NBND_MAP + 1 END IF - - ALLOCATE(GRIDS(IMOD)%MAPSTA_LOC(npa), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(5) - MAPSTA_LOC => GRIDS(IMOD)%MAPSTA_LOC - NBND_MAP => GRIDS(IMOD)%NBND_MAP - Status = 0 - DO IP=1,npa - IP_glob=iplg(IP) - Status(IP_glob)=IP - MAPSTA_LOC(IP)=MAPSTA(1,IP_glob) - END DO - NBND_MAP = 0 - DO IX=1,NX - IF ((MAPSTA(1,IX) .lt. 1).and.(Status(IX).gt.0)) THEN - NBND_MAP = NBND_MAP + 1 - END IF - END DO - - ALLOCATE(GRIDS(IMOD)%INDEX_MAP(NBND_MAP), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(6) - INDEX_MAP => GRIDS(IMOD)%INDEX_MAP - IBND_MAP = 0 - DO IX = 1, NX - IF ((MAPSTA(1,IX) .lt. 1).and.(Status(IX).gt.0)) THEN - IBND_MAP = IBND_MAP + 1 - INDEX_MAP(IBND_MAP) = Status(IX) - END IF - END DO -!/ -!/ End of W3SPR4 ----------------------------------------------------- / -!/ - END SUBROUTINE PDLIB_MAPSTA_INIT -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_IOBP_INIT(IMOD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init mapsta part for pdlib -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END DO + + ALLOCATE(GRIDS(IMOD)%INDEX_MAP(NBND_MAP), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(6) + INDEX_MAP => GRIDS(IMOD)%INDEX_MAP + IBND_MAP = 0 + DO IX = 1, NX + IF ((MAPSTA(1,IX) .lt. 1).and.(Status(IX).gt.0)) THEN + IBND_MAP = IBND_MAP + 1 + INDEX_MAP(IBND_MAP) = Status(IX) + END IF + END DO + !/ + !/ End of W3SPR4 ----------------------------------------------------- / + !/ + END SUBROUTINE PDLIB_MAPSTA_INIT + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_IOBP_INIT(IMOD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init mapsta part for pdlib + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only : INDEX_MAP, NBND_MAP, NSEA, NSEAL, GRIDS, NX, NTH - USE W3GDATMD, only : IOBP, IOBDP, IOBPA, IOBPD, NBND_MAP, INDEX_MAP - USE W3GDATMD, only : IOBP_LOC, IOBPD_LOC, IOBDP_LOC, IOBPA_LOC - USE W3ODATMD, only : IAPROC, NAPROC - USE YOWNODEPOOL, only: iplg, npa - USE yowfunction, only: pdlib_abort - USE W3ODATMD, only: IAPROC -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only : INDEX_MAP, NBND_MAP, NSEA, NSEAL, GRIDS, NX, NTH + USE W3GDATMD, only : IOBP, IOBDP, IOBPA, IOBPD, NBND_MAP, INDEX_MAP + USE W3GDATMD, only : IOBP_LOC, IOBPD_LOC, IOBDP_LOC, IOBPA_LOC + USE W3ODATMD, only : IAPROC, NAPROC + USE YOWNODEPOOL, only: iplg, npa + USE yowfunction, only: pdlib_abort + USE W3ODATMD, only: IAPROC + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: IBND_MAP, ISEA, JSEA, IX, IP, IP_glob - INTEGER, INTENT(in) :: IMOD - INTEGER :: Status(NX), istat - REAL :: rtmp(nseal) + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: IBND_MAP, ISEA, JSEA, IX, IP, IP_glob + INTEGER, INTENT(in) :: IMOD + INTEGER :: Status(NX), istat + REAL :: rtmp(nseal) #ifdef W3_S - CALL STRACE (IENT, 'PDLIB_MAPSTA_INIT') + CALL STRACE (IENT, 'PDLIB_MAPSTA_INIT') #endif #ifdef W3_DEBUGINIT - WRITE(*,*) 'Passing by PDLIB_MAPSTA_INIT IAPROC=', IAPROC + WRITE(*,*) 'Passing by PDLIB_MAPSTA_INIT IAPROC=', IAPROC #endif - IF (IAPROC .gt. NAPROC) THEN - RETURN - END IF - - ALLOCATE(GRIDS(IMOD)%IOBP_LOC(NPA), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(7) - ALLOCATE(GRIDS(IMOD)%IOBPD_LOC(NTH,NPA), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(8) - ALLOCATE(GRIDS(IMOD)%IOBDP_LOC(NPA), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(9) - ALLOCATE(GRIDS(IMOD)%IOBPA_LOC(NPA), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(9) - - IOBP_loc => GRIDS(IMOD)%IOBP_LOC - IOBPA_loc => GRIDS(IMOD)%IOBPA_LOC - IOBPD_loc => GRIDS(IMOD)%IOBPD_LOC - IOBDP_loc => GRIDS(IMOD)%IOBDP_LOC - - DO IP = 1, npa - IP_glob = iplg(IP) - IOBP_loc(IP) = IOBP(IP_glob) - IOBPD_loc(:,IP) = IOBPD(:,IP_glob) - END DO - - IOBDP_loc = 0 - IOBP => NULL() - IOBPD => NULL() - DEALLOCATE(GRIDS(IMOD)%IOBP,GRIDS(IMOD)%IOBPD) - CALL SET_IOBPA_PDLIB -!/ -!/ End of W3SPR4 ----------------------------------------------------- / -!/ - END SUBROUTINE PDLIB_IOBP_INIT -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_W3XYPUG ( ISP, FACX, FACY, DTG, VGX, VGY, LCALC ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 10-Jan-2011 | -!/ +-----------------------------------+ -!/ -!/ 10-Jan-2008 : Origination. ( version 3.13 ) -!/ 10-Jan-2011 : Addition of implicit scheme ( version 3.14.4 ) -!/ 06-Feb-2014 : PDLIB parallelization -!/ -! 1. Purpose : Explicit advection schemes driver -! -! Propagation in physical space for a given spectral component. -! Gives the choice of scheme on unstructured grid -! Use the geographical parall algorithms for further speed. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! 5. Called by : -! -! W3WAVE Wave model routine. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! make the interface between the WAVEWATCH and the WWM code. -! -! 8. Structure : -! -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! -! 10. Source code : -!/ ------------------------------------------------------------------- / -!/ -! - USE CONSTANTS -! - USE W3TIMEMD, only: DSEC21 -! - USE W3GDATMD, only: NX, NY, MAPFS, CLATS, & - FLCX, FLCY, NK, NTH, DTH, XFR, & - ECOS, ESIN, SIG, PFMOVE, & - IOBP, IOBPD, & - FSN, FSPSI, FSFCT, FSNIMP, & - GTYPE, UNGTYPE, NBND_MAP, INDEX_MAP - USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE YOWNODEPOOL, only: iplg, npa - USE W3WDATMD, only: TIME, VA - USE W3ODATMD, only: TBPI0, TBPIN, FLBPI - USE W3ADATMD, only: CG, CX, CY, ITIME, DW - USE W3IDATMD, only: FLCUR, FLLEV - USE W3GDATMD, only: NSEAL - USE W3ODATMD, only: IAPROC - USE W3DISPMD, only : WAVNU_LOCAL - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISP - REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY - LOGICAL, INTENT(IN) :: LCALC - LOGICAL :: SCHEME -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ - INTEGER :: ITH, IK, ISEA - INTEGER :: I, J, IE, IBND_MAP - INTEGER :: IP_glob - REAL :: CCOS, CSIN, CCURX, CCURY, WN1, CG1 - REAL :: C(npa,2) - REAL :: RD1, RD2 -!/ -!/ Automatic work arrays -!/ - REAL :: VLCFLX(npa), VLCFLY(npa) - REAL :: AC(npa) - REAL :: AC_MAP(NBND_MAP) - INTEGER :: JSEA, IP -!/ ------------------------------------------------------------------- / -! -! 1. Preparations --------------------------------------------------- * -! 1.a Set constants -! + IF (IAPROC .gt. NAPROC) THEN + RETURN + END IF + + ALLOCATE(GRIDS(IMOD)%IOBP_LOC(NPA), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(7) + ALLOCATE(GRIDS(IMOD)%IOBPD_LOC(NTH,NPA), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(8) + ALLOCATE(GRIDS(IMOD)%IOBDP_LOC(NPA), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(9) + ALLOCATE(GRIDS(IMOD)%IOBPA_LOC(NPA), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(9) + + IOBP_loc => GRIDS(IMOD)%IOBP_LOC + IOBPA_loc => GRIDS(IMOD)%IOBPA_LOC + IOBPD_loc => GRIDS(IMOD)%IOBPD_LOC + IOBDP_loc => GRIDS(IMOD)%IOBDP_LOC + + DO IP = 1, npa + IP_glob = iplg(IP) + IOBP_loc(IP) = IOBP(IP_glob) + IOBPD_loc(:,IP) = IOBPD(:,IP_glob) + END DO + + IOBDP_loc = 0 + IOBP => NULL() + IOBPD => NULL() + DEALLOCATE(GRIDS(IMOD)%IOBP,GRIDS(IMOD)%IOBPD) + CALL SET_IOBPA_PDLIB + !/ + !/ End of W3SPR4 ----------------------------------------------------- / + !/ + END SUBROUTINE PDLIB_IOBP_INIT + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_W3XYPUG ( ISP, FACX, FACY, DTG, VGX, VGY, LCALC ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 10-Jan-2011 | + !/ +-----------------------------------+ + !/ + !/ 10-Jan-2008 : Origination. ( version 3.13 ) + !/ 10-Jan-2011 : Addition of implicit scheme ( version 3.14.4 ) + !/ 06-Feb-2014 : PDLIB parallelization + !/ + ! 1. Purpose : Explicit advection schemes driver + ! + ! Propagation in physical space for a given spectral component. + ! Gives the choice of scheme on unstructured grid + ! Use the geographical parall algorithms for further speed. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! W3WAVE Wave model routine. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! make the interface between the WAVEWATCH and the WWM code. + ! + ! 8. Structure : + ! + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + !/ + ! + USE CONSTANTS + ! + USE W3TIMEMD, only: DSEC21 + ! + USE W3GDATMD, only: NX, NY, MAPFS, CLATS, & + FLCX, FLCY, NK, NTH, DTH, XFR, & + ECOS, ESIN, SIG, PFMOVE, & + IOBP, IOBPD, & + FSN, FSPSI, FSFCT, FSNIMP, & + GTYPE, UNGTYPE, NBND_MAP, INDEX_MAP + USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE YOWNODEPOOL, only: iplg, npa + USE W3WDATMD, only: TIME, VA + USE W3ODATMD, only: TBPI0, TBPIN, FLBPI + USE W3ADATMD, only: CG, CX, CY, ITIME, DW + USE W3IDATMD, only: FLCUR, FLLEV + USE W3GDATMD, only: NSEAL + USE W3ODATMD, only: IAPROC + USE W3DISPMD, only : WAVNU_LOCAL + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISP + REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY + LOGICAL, INTENT(IN) :: LCALC + LOGICAL :: SCHEME + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ + INTEGER :: ITH, IK, ISEA + INTEGER :: I, J, IE, IBND_MAP + INTEGER :: IP_glob + REAL :: CCOS, CSIN, CCURX, CCURY, WN1, CG1 + REAL :: C(npa,2) + REAL :: RD1, RD2 + !/ + !/ Automatic work arrays + !/ + REAL :: VLCFLX(npa), VLCFLY(npa) + REAL :: AC(npa) + REAL :: AC_MAP(NBND_MAP) + INTEGER :: JSEA, IP + !/ ------------------------------------------------------------------- / + ! + ! 1. Preparations --------------------------------------------------- * + ! 1.a Set constants + ! #ifdef W3_S - CALL STRACE (IENT, 'W3XYPUG') + CALL STRACE (IENT, 'W3XYPUG') #endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'Begin of PDLIB_W3XYPUG' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Begin of PDLIB_W3XYPUG' + FLUSH(740+IAPROC) #endif - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - CCOS = FACX * ECOS(ITH) - CSIN = FACY * ESIN(ITH) - CCURX = FACX - CCURY = FACY -! -! 1.b Initialize arrays -! - VLCFLX = 0. - VLCFLY = 0. - AC = 0. -! -! 2. Calculate velocities ---------------- * -! - DO JSEA = 1, NSEAL - IP = JSEA - IP_glob = iplg(IP) - ISEA = MAPFS(1,IP_glob) - !write(*,*) 'IP TEST', JSEA, ISEA, IP, IP_glob + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + CCOS = FACX * ECOS(ITH) + CSIN = FACY * ESIN(ITH) + CCURX = FACX + CCURY = FACY + ! + ! 1.b Initialize arrays + ! + VLCFLX = 0. + VLCFLY = 0. + AC = 0. + ! + ! 2. Calculate velocities ---------------- * + ! + DO JSEA = 1, NSEAL + IP = JSEA + IP_glob = iplg(IP) + ISEA = MAPFS(1,IP_glob) + !write(*,*) 'IP TEST', JSEA, ISEA, IP, IP_glob #ifdef NOCGTABLE - CALL WAVNU_LOCAL(SIG(IK),DW(ISEA),WN1,CG1) - AC(IP) = VA(ISP,JSEA) / CG1 * CLATS(ISEA) - VLCFLX(IP) = CCOS * CG1 / CLATS(ISEA) - VLCFLY(IP) = CSIN * CG(IK,ISEA) + CALL WAVNU_LOCAL(SIG(IK),DW(ISEA),WN1,CG1) + AC(IP) = VA(ISP,JSEA) / CG1 * CLATS(ISEA) + VLCFLX(IP) = CCOS * CG1 / CLATS(ISEA) + VLCFLY(IP) = CSIN * CG(IK,ISEA) #else - AC(IP) = VA(ISP,JSEA) / CG(IK,ISEA) * CLATS(ISEA) - VLCFLX(IP) = CCOS * CG(IK,ISEA) / CLATS(ISEA) - VLCFLY(IP) = CSIN * CG(IK,ISEA) + AC(IP) = VA(ISP,JSEA) / CG(IK,ISEA) * CLATS(ISEA) + VLCFLX(IP) = CCOS * CG(IK,ISEA) / CLATS(ISEA) + VLCFLY(IP) = CSIN * CG(IK,ISEA) #endif #ifdef W3_MGP - VLCFLX(IP) = VLCFLX(IP) - CCURX*VGX/CLATS(ISEA) - VLCFLY(IP) = VLCFLY(IP) - CCURY*VGY + VLCFLX(IP) = VLCFLX(IP) - CCURX*VGX/CLATS(ISEA) + VLCFLY(IP) = VLCFLY(IP) - CCURY*VGY #endif - END DO -#ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'ISP=', ISP, ' ITH=', ITH, ' IK=', IK - WRITE(740+IAPROC,*) '1: maxval(VLCFLX)=', maxval(VLCFLX) - WRITE(740+IAPROC,*) '1: maxval(VLCFLY)=', maxval(VLCFLY) - WRITE(740+IAPROC,*) 'FLCUR=', FLCUR - FLUSH(740+IAPROC) -#endif - IF ( FLCUR ) THEN - DO JSEA=1, NSEAL - IP = JSEA - IP_glob = iplg(IP) - ISEA = MAPFS(1,IP_glob) -! -! Currents are not included on coastal boundaries (COUNTSEACON(IXY) .NE. PDLIB_CCON(IXY)) -! - IF (IOBP_LOC(IP) .GT. 0) THEN - VLCFLX(IP) = VLCFLX(IP) + CCURX*CX(ISEA)/CLATS(ISEA) - VLCFLY(IP) = VLCFLY(IP) + CCURY*CY(ISEA) - END IF - END DO - END IF - - C(:,1) = VLCFLX(:) * IOBDP_LOC - C(:,2) = VLCFLY(:) * IOBDP_LOC -! -! 4. Prepares boundary update -! - IF ( FLBPI ) THEN - RD1 = DSEC21 ( TBPI0, TIME ) - RD2 = DSEC21 ( TBPI0, TBPIN ) - ELSE - RD1=1. - RD2=0. - END IF -! -! Saving data for MAPSTA business -! - IF (MAPSTA_HACK) THEN - DO IBND_MAP=1,NBND_MAP - IP=INDEX_MAP(IBND_MAP) - AC_MAP(IBND_MAP) = AC(IP) - END DO - END IF -! -! 4. propagate using the selected scheme -! -#ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'maxval(C)=', maxval(C) - FLUSH(740+IAPROC) -#endif - IF (FSN) THEN - CALL PDLIB_W3XYPFSN2(ISP, C, LCALC, RD1, RD2, DTG, AC) - ELSE IF (FSPSI) THEN - CALL PDLIB_W3XYPFSPSI2(ISP, C, LCALC, RD1, RD2, DTG, AC) - ELSE IF (FSFCT) THEN - CALL PDLIB_W3XYPFSFCT2(ISP, C, LCALC, RD1, RD2, DTG, AC) - ELSE IF (FSNIMP) THEN - STOP 'For PDLIB and FSNIMP, no function has been programmed yet' - ENDIF -! - IF (MAPSTA_HACK) THEN - DO IBND_MAP=1,NBND_MAP - IP=INDEX_MAP(IBND_MAP) - AC(IP) = AC_MAP(IBND_MAP) - END DO - END IF + END DO #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'After solutioning' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'ISP=', ISP, ' ITH=', ITH, ' IK=', IK + WRITE(740+IAPROC,*) '1: maxval(VLCFLX)=', maxval(VLCFLX) + WRITE(740+IAPROC,*) '1: maxval(VLCFLY)=', maxval(VLCFLY) + WRITE(740+IAPROC,*) 'FLCUR=', FLCUR + FLUSH(740+IAPROC) #endif - -! 6. Store results in VQ in proper format --------------------------- * -! + IF ( FLCUR ) THEN DO JSEA=1, NSEAL IP = JSEA IP_glob = iplg(IP) - ISEA=MAPFS(1,IP_glob) - VA(ISP,JSEA) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*AC(IP) ) + ISEA = MAPFS(1,IP_glob) + ! + ! Currents are not included on coastal boundaries (COUNTSEACON(IXY) .NE. PDLIB_CCON(IXY)) + ! + IF (IOBP_LOC(IP) .GT. 0) THEN + VLCFLX(IP) = VLCFLX(IP) + CCURX*CX(ISEA)/CLATS(ISEA) + VLCFLY(IP) = VLCFLY(IP) + CCURY*CY(ISEA) + END IF + END DO + END IF + + C(:,1) = VLCFLX(:) * IOBDP_LOC + C(:,2) = VLCFLY(:) * IOBDP_LOC + ! + ! 4. Prepares boundary update + ! + IF ( FLBPI ) THEN + RD1 = DSEC21 ( TBPI0, TIME ) + RD2 = DSEC21 ( TBPI0, TBPIN ) + ELSE + RD1=1. + RD2=0. + END IF + ! + ! Saving data for MAPSTA business + ! + IF (MAPSTA_HACK) THEN + DO IBND_MAP=1,NBND_MAP + IP=INDEX_MAP(IBND_MAP) + AC_MAP(IBND_MAP) = AC(IP) END DO + END IF + ! + ! 4. propagate using the selected scheme + ! #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'Leaving PDLIB_W3XYPUG' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'maxval(C)=', maxval(C) + FLUSH(740+IAPROC) #endif -!/ -!/ End of W3SPR4 ----------------------------------------------------- / -!/ - END SUBROUTINE PDLIB_W3XYPUG -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Explicit N-Scheme -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + IF (FSN) THEN + CALL PDLIB_W3XYPFSN2(ISP, C, LCALC, RD1, RD2, DTG, AC) + ELSE IF (FSPSI) THEN + CALL PDLIB_W3XYPFSPSI2(ISP, C, LCALC, RD1, RD2, DTG, AC) + ELSE IF (FSFCT) THEN + CALL PDLIB_W3XYPFSFCT2(ISP, C, LCALC, RD1, RD2, DTG, AC) + ELSE IF (FSNIMP) THEN + STOP 'For PDLIB and FSNIMP, no function has been programmed yet' + ENDIF + ! + IF (MAPSTA_HACK) THEN + DO IBND_MAP=1,NBND_MAP + IP=INDEX_MAP(IBND_MAP) + AC(IP) = AC_MAP(IBND_MAP) + END DO + END IF +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'After solutioning' + FLUSH(740+IAPROC) +#endif + + ! 6. Store results in VQ in proper format --------------------------- * + ! + DO JSEA=1, NSEAL + IP = JSEA + IP_glob = iplg(IP) + ISEA=MAPFS(1,IP_glob) + VA(ISP,JSEA) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*AC(IP) ) + END DO +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'Leaving PDLIB_W3XYPUG' + FLUSH(740+IAPROC) +#endif + !/ + !/ End of W3SPR4 ----------------------------------------------------- / + !/ + END SUBROUTINE PDLIB_W3XYPUG + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Explicit N-Scheme + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only: NK, NTH, NX, IEN, CLATS, MAPSF - USE W3GDATMD, only: IOBPD_LOC, IOBP_LOC, IOBDP_LOC, IOBPA_LOC, FSBCCFL - USE W3WDATMD, only: TIME - USE W3ADATMD, only: CG, ITER, DW , CFLXYMAX, NSEALM - USE W3ODATMD, only: NDSE, NDST, FLBPI, NBI, TBPIN, ISBPI, BBPI0, BBPIN - USE W3TIMEMD, only: DSEC21 - USE W3ADATMD, only: MPI_COMM_WCMP - USE W3GDATMD, only: NSEAL, DMIN, NSEA + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only: NK, NTH, NX, IEN, CLATS, MAPSF + USE W3GDATMD, only: IOBPD_LOC, IOBP_LOC, IOBDP_LOC, IOBPA_LOC, FSBCCFL + USE W3WDATMD, only: TIME + USE W3ADATMD, only: CG, ITER, DW , CFLXYMAX, NSEALM + USE W3ODATMD, only: NDSE, NDST, FLBPI, NBI, TBPIN, ISBPI, BBPI0, BBPIN + USE W3TIMEMD, only: DSEC21 + USE W3ADATMD, only: MPI_COMM_WCMP + USE W3GDATMD, only: NSEAL, DMIN, NSEA #ifdef W3_REF1 - USE W3GDATMD, only: REFPARS -#endif - USE YOWNODEPOOL, only: PDLIB_SI, PDLIB_IEN, PDLIB_TRIA, ipgl, iplg, npa, np - use yowElementpool, only: ne, INE - use yowDatapool, only: rtype - use yowExchangeModule, only : PDLIB_exchange1DREAL - USE W3ODATMD, only : IAPROC - USE MPI, only : MPI_MIN - USE W3PARALL, only : INIT_GET_JSEA_ISPROC - USE W3PARALL, only : ONESIXTH, ZERO, THR - USE yowRankModule, only : IPGL_npa - IMPLICIT NONE - INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, - ! actual Wave Direction - REAL, INTENT(IN) :: DT ! Time intervall for which the - ! advection should be computed - ! for the given velocity field - REAL, INTENT(IN) :: C(npa,2) ! Velocity field in it's - ! X- and Y- Components, - REAL, INTENT(INOUT) :: AC(npa) ! Wave Action before and - ! after advection - REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation - ! coefficients for boundary - ! conditions - LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of - ! the max. Global Time step + USE W3GDATMD, only: REFPARS +#endif + USE YOWNODEPOOL, only: PDLIB_SI, PDLIB_IEN, PDLIB_TRIA, ipgl, iplg, npa, np + use yowElementpool, only: ne, INE + use yowDatapool, only: rtype + use yowExchangeModule, only : PDLIB_exchange1DREAL + USE W3ODATMD, only : IAPROC + USE MPI, only : MPI_MIN + USE W3PARALL, only : INIT_GET_JSEA_ISPROC + USE W3PARALL, only : ONESIXTH, ZERO, THR + USE yowRankModule, only : IPGL_npa + IMPLICIT NONE + INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, + ! actual Wave Direction + REAL, INTENT(IN) :: DT ! Time intervall for which the + ! advection should be computed + ! for the given velocity field + REAL, INTENT(IN) :: C(npa,2) ! Velocity field in it's + ! X- and Y- Components, + REAL, INTENT(INOUT) :: AC(npa) ! Wave Action before and + ! after advection + REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation + ! coefficients for boundary + ! conditions + LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of + ! the max. Global Time step #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_REF1 - INTEGER(KIND=1) :: IOBPDR(NX) -#endif - INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK - INTEGER :: IBI, NI(3) - INTEGER :: JX -! -! local REAL -! - REAL :: RD1, RD2 -!: -! local double -! - REAL :: UTILDE - REAL :: SUMTHETA - REAL :: FT, CFLXY - REAL :: FL11, FL12, FL21, FL22, FL31, FL32 - REAL :: FL111, FL112, FL211, FL212, FL311, FL312 - REAL :: DTSI(npa), U(npa) - REAL :: DTMAX_GL, DTMAX, DTMAXEXP, REST - REAL :: LAMBDA(2), KTMP(3) - REAL :: KELEM(3,NE), FLALL(3,NE) - REAL :: KKSUM(npa), ST(npa) - REAL :: NM(NE) - INTEGER :: ISPROC, JSEA, IP_glob, ierr, IX - REAL :: eSumAC, sumAC, sumBPI0, sumBPIN, sumCG, sumCLATS - LOGICAL :: testWrite - REAL :: FIN(1), FOUT(1) + INTEGER(KIND=1) :: IOBPDR(NX) +#endif + INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK + INTEGER :: IBI, NI(3) + INTEGER :: JX + ! + ! local REAL + ! + REAL :: RD1, RD2 + !: + ! local double + ! + REAL :: UTILDE + REAL :: SUMTHETA + REAL :: FT, CFLXY + REAL :: FL11, FL12, FL21, FL22, FL31, FL32 + REAL :: FL111, FL112, FL211, FL212, FL311, FL312 + REAL :: DTSI(npa), U(npa) + REAL :: DTMAX_GL, DTMAX, DTMAXEXP, REST + REAL :: LAMBDA(2), KTMP(3) + REAL :: KELEM(3,NE), FLALL(3,NE) + REAL :: KKSUM(npa), ST(npa) + REAL :: NM(NE) + INTEGER :: ISPROC, JSEA, IP_glob, ierr, IX + REAL :: eSumAC, sumAC, sumBPI0, sumBPIN, sumCG, sumCLATS + LOGICAL :: testWrite + REAL :: FIN(1), FOUT(1) #ifdef W3_S - CALL STRACE (IENT, 'W3XYPFSN') + CALL STRACE (IENT, 'W3XYPFSN') #endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 1' - FLUSH(740+IAPROC) - CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC in input") + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 1' + FLUSH(740+IAPROC) + CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC in input") #endif - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - DTMAX = DBLE(10.E10) -! + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + DTMAX = DBLE(10.E10) + ! #ifdef W3_REF1 - IOBPDR(:)=(1-IOBP_LOC(:))*(1-IOBPD_LOC(ITH,:)) + IOBPDR(:)=(1-IOBP_LOC(:))*(1-IOBPD_LOC(ITH,:)) #endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'NX=', NX - WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 2' - FLUSH(740+IAPROC) -#endif -! -!2 Propagation -!2.a Calculate K-Values and contour based quantities ... -! - DO IE = 1, ne - I1 = INE(1,IE) - I2 = INE(2,IE) - I3 = INE(3,IE) - LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction - LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) - KELEM(1,IE) = LAMBDA(1) * PDLIB_IEN(1,IE) + LAMBDA(2) * PDLIB_IEN(2,IE) ! K-Values - so called Flux Jacobians - KELEM(2,IE) = LAMBDA(1) * PDLIB_IEN(3,IE) + LAMBDA(2) * PDLIB_IEN(4,IE) - KELEM(3,IE) = LAMBDA(1) * PDLIB_IEN(5,IE) + LAMBDA(2) * PDLIB_IEN(6,IE) - KTMP = KELEM(:,IE) ! Copy - NM(IE) = - 1.D0/MIN(-THR,SUM(MIN(ZERO,KTMP))) ! N-Values - KELEM(:,IE) = MAX(ZERO,KTMP) - FL11 = C(I2,1) * PDLIB_IEN(1,IE) + C(I2,2) * PDLIB_IEN(2,IE) ! Weights for Simpson Integration - FL12 = C(I3,1) * PDLIB_IEN(1,IE) + C(I3,2) * PDLIB_IEN(2,IE) - FL21 = C(I3,1) * PDLIB_IEN(3,IE) + C(I3,2) * PDLIB_IEN(4,IE) - FL22 = C(I1,1) * PDLIB_IEN(3,IE) + C(I1,2) * PDLIB_IEN(4,IE) - FL31 = C(I1,1) * PDLIB_IEN(5,IE) + C(I1,2) * PDLIB_IEN(6,IE) - FL32 = C(I2,1) * PDLIB_IEN(5,IE) + C(I2,2) * PDLIB_IEN(6,IE) - FL111 = 2.d0*FL11+FL12 - FL112 = 2.d0*FL12+FL11 - FL211 = 2.d0*FL21+FL22 - FL212 = 2.d0*FL22+FL21 - FL311 = 2.d0*FL31+FL32 - FL312 = 2.d0*FL32+FL31 - FLALL(1,IE) = (FL311 + FL212) * ONESIXTH + KELEM(1,IE) - FLALL(2,IE) = (FL111 + FL312) * ONESIXTH + KELEM(2,IE) - FLALL(3,IE) = (FL211 + FL112) * ONESIXTH + KELEM(3,IE) - END DO -#ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 3' - FLUSH(740+IAPROC) -#endif - IF (LCALC) THEN - KKSUM = ZERO - DO IE = 1, NE - NI = INE(:,IE) - KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) - END DO - DTMAXEXP = 1.E10 - DO IP = 1, np - IP_glob = iplg(IP) - IF (IOBP_LOC(IP) .EQ. 1 .OR. FSBCCFL) THEN - DTMAXEXP = PDLIB_SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP_LOC(IP)) - DTMAX = MIN( DTMAX, DTMAXEXP) - ENDIF - CFLXYMAX(IP) = MAX(CFLXYMAX(IP),DBLE(DT)/DTMAXEXP) - END DO - FIN(1)=DTMAX - CALL MPI_ALLREDUCE(FIN,FOUT,1,rtype,MPI_MIN,MPI_COMM_WCMP,ierr) - DTMAX_GL=FOUT(1) - CFLXY = DBLE(DT)/DTMAX_GL - REST = ABS(MOD(CFLXY,1.0d0)) - IF (REST .LT. THR) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) - ELSE IF (REST .GT. THR .AND. REST .LT. 0.5d0) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 - ELSE - ITER(IK,ITH) = ABS(NINT(CFLXY)) - END IF - END IF ! LCALC + WRITE(740+IAPROC,*) 'NX=', NX + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 2' + FLUSH(740+IAPROC) +#endif + ! + !2 Propagation + !2.a Calculate K-Values and contour based quantities ... + ! + DO IE = 1, ne + I1 = INE(1,IE) + I2 = INE(2,IE) + I3 = INE(3,IE) + LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction + LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) + KELEM(1,IE) = LAMBDA(1) * PDLIB_IEN(1,IE) + LAMBDA(2) * PDLIB_IEN(2,IE) ! K-Values - so called Flux Jacobians + KELEM(2,IE) = LAMBDA(1) * PDLIB_IEN(3,IE) + LAMBDA(2) * PDLIB_IEN(4,IE) + KELEM(3,IE) = LAMBDA(1) * PDLIB_IEN(5,IE) + LAMBDA(2) * PDLIB_IEN(6,IE) + KTMP = KELEM(:,IE) ! Copy + NM(IE) = - 1.D0/MIN(-THR,SUM(MIN(ZERO,KTMP))) ! N-Values + KELEM(:,IE) = MAX(ZERO,KTMP) + FL11 = C(I2,1) * PDLIB_IEN(1,IE) + C(I2,2) * PDLIB_IEN(2,IE) ! Weights for Simpson Integration + FL12 = C(I3,1) * PDLIB_IEN(1,IE) + C(I3,2) * PDLIB_IEN(2,IE) + FL21 = C(I3,1) * PDLIB_IEN(3,IE) + C(I3,2) * PDLIB_IEN(4,IE) + FL22 = C(I1,1) * PDLIB_IEN(3,IE) + C(I1,2) * PDLIB_IEN(4,IE) + FL31 = C(I1,1) * PDLIB_IEN(5,IE) + C(I1,2) * PDLIB_IEN(6,IE) + FL32 = C(I2,1) * PDLIB_IEN(5,IE) + C(I2,2) * PDLIB_IEN(6,IE) + FL111 = 2.d0*FL11+FL12 + FL112 = 2.d0*FL12+FL11 + FL211 = 2.d0*FL21+FL22 + FL212 = 2.d0*FL22+FL21 + FL311 = 2.d0*FL31+FL32 + FL312 = 2.d0*FL32+FL31 + FLALL(1,IE) = (FL311 + FL212) * ONESIXTH + KELEM(1,IE) + FLALL(2,IE) = (FL111 + FL312) * ONESIXTH + KELEM(2,IE) + FLALL(3,IE) = (FL211 + FL112) * ONESIXTH + KELEM(3,IE) + END DO #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 3' + FLUSH(740+IAPROC) #endif - DO IP = 1, npa - DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/PDLIB_SI(IP) ! Some precalculations for the time integration. + IF (LCALC) THEN + KKSUM = ZERO + DO IE = 1, NE + NI = INE(:,IE) + KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) END DO + DTMAXEXP = 1.E10 + DO IP = 1, np + IP_glob = iplg(IP) + IF (IOBP_LOC(IP) .EQ. 1 .OR. FSBCCFL) THEN + DTMAXEXP = PDLIB_SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP_LOC(IP)) + DTMAX = MIN( DTMAX, DTMAXEXP) + ENDIF + CFLXYMAX(IP) = MAX(CFLXYMAX(IP),DBLE(DT)/DTMAXEXP) + END DO + FIN(1)=DTMAX + CALL MPI_ALLREDUCE(FIN,FOUT,1,rtype,MPI_MIN,MPI_COMM_WCMP,ierr) + DTMAX_GL=FOUT(1) + CFLXY = DBLE(DT)/DTMAX_GL + REST = ABS(MOD(CFLXY,1.0d0)) + IF (REST .LT. THR) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + ELSE IF (REST .GT. THR .AND. REST .LT. 0.5d0) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 + ELSE + ITER(IK,ITH) = ABS(NINT(CFLXY)) + END IF + END IF ! LCALC #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4.1' - FLUSH(740+IAPROC) - CALL SCAL_INTEGRAL_PRINT_R4(PDLIB_SI, "PDLIB_SI in input") - WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4.2' - FLUSH(740+IAPROC) - CALL SCAL_INTEGRAL_PRINT_R4(DTSI, "DTSI in input") - WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 5' - WRITE(740+IAPROC,*) 'IK=', IK, ' ITH=', ITH - WRITE(740+IAPROC,*) 'ITER=', ITER(IK,ITH) - FLUSH(740+IAPROC) -#endif - DO IT = 1, ITER(IK,ITH) -#ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'IK=', IK, ' ITH=', ITH - WRITE(740+IAPROC,*) 'IT=', IT, ' ITER=', ITER(IK,ITH) - FLUSH(740+IAPROC) - IF (testWrite) THEN - WRITE(740+IAPROC,*) 'IT=', IT - FLUSH(740+IAPROC) - END IF -#endif - U = DBLE(AC) - ST = ZERO - DO IE = 1, NE - NI = INE(:,IE) - UTILDE = NM(IE) * (DOT_PRODUCT(FLALL(:,IE),U(NI))) - ST(NI) = ST(NI) + KELEM(:,IE) * (U(NI) - UTILDE) ! the 2nd term are the theta values of each node ... - END DO ! IE -#ifdef W3_DEBUGSOLVER - IF (testWrite) THEN - CALL SCAL_INTEGRAL_PRINT_R4(ST, "ST in loop") - END IF -#endif -! -! IOBPD=0 : waves coming from land -! IOBPD=1 : waves coming from the coast -! - DO IP = 1, npa - U(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA_LOC(IP)))*DBLE(IOBPD_LOC(ITH,IP))*IOBDP_LOC(IP) -#ifdef W3_REF1 - IF (REFPARS(3).LT.0.5.AND.IOBPD_LOC(ITH,IP).EQ.0.AND.IOBPA_LOC(IP).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4' + FLUSH(740+IAPROC) #endif - END DO + DO IP = 1, npa + DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/PDLIB_SI(IP) ! Some precalculations for the time integration. + END DO #ifdef W3_DEBUGSOLVER - IF (testWrite) THEN - CALL SCAL_INTEGRAL_PRINT_R4(U, "U in loop") - END IF + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4.1' + FLUSH(740+IAPROC) + CALL SCAL_INTEGRAL_PRINT_R4(PDLIB_SI, "PDLIB_SI in input") + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4.2' + FLUSH(740+IAPROC) + CALL SCAL_INTEGRAL_PRINT_R4(DTSI, "DTSI in input") + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 5' + WRITE(740+IAPROC,*) 'IK=', IK, ' ITH=', ITH + WRITE(740+IAPROC,*) 'ITER=', ITER(IK,ITH) + FLUSH(740+IAPROC) #endif - AC = REAL(U) - + DO IT = 1, ITER(IK,ITH) #ifdef W3_DEBUGSOLVER - IF (testWrite) THEN - CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC before synchronization") - END IF + WRITE(740+IAPROC,*) 'IK=', IK, ' ITH=', ITH + WRITE(740+IAPROC,*) 'IT=', IT, ' ITER=', ITER(IK,ITH) + FLUSH(740+IAPROC) + IF (testWrite) THEN + WRITE(740+IAPROC,*) 'IT=', IT + FLUSH(740+IAPROC) + END IF #endif -! CALL PDLIB_exchange1DREAL(AC) -#ifdef W3_DEBUGSOLVER - IF (testWrite) THEN - CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC after synchronization") - END IF -#endif -! -! 5 Update boundaries ... would be better to omit any if clause in this loop ... -! a possibility would be to use NBI = 0 when FLBPI is FALSE and loop on IBI whatever the value of NBI -! - IF ( FLBPI ) THEN - RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) - RD2=RD20 - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF -#ifdef W3_DEBUGSOLVER - sumAC=0 - sumBPI0=0 - sumBPIN=0 - sumCG=0 - sumCLATS=0 -#endif - DO IBI = 1, NBI - IP_glob = MAPSF(ISBPI(IBI),1) - JX=IPGL_npa(IP_glob) - IF (JX .gt. 0) THEN - AC(JX) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) + U = DBLE(AC) + ST = ZERO + DO IE = 1, NE + NI = INE(:,IE) + UTILDE = NM(IE) * (DOT_PRODUCT(FLALL(:,IE),U(NI))) + ST(NI) = ST(NI) + KELEM(:,IE) * (U(NI) - UTILDE) ! the 2nd term are the theta values of each node ... + END DO ! IE #ifdef W3_DEBUGSOLVER - sumAC=sumAC + AC(JX) - sumBPI0=sumBPI0 + BBPI0(ISP,IBI) - sumBPIN=sumBPIN + BBPIN(ISP,IBI) - sumCG=sumCG + CG(IK,ISBPI(IBI)) - sumCLATS=sumCLATS + CLATS(ISBPI(IBI)) + IF (testWrite) THEN + CALL SCAL_INTEGRAL_PRINT_R4(ST, "ST in loop") + END IF #endif - END IF - END DO + ! + ! IOBPD=0 : waves coming from land + ! IOBPD=1 : waves coming from the coast + ! + DO IP = 1, npa + U(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA_LOC(IP)))*DBLE(IOBPD_LOC(ITH,IP))*IOBDP_LOC(IP) +#ifdef W3_REF1 + IF (REFPARS(3).LT.0.5.AND.IOBPD_LOC(ITH,IP).EQ.0.AND.IOBPA_LOC(IP).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values +#endif + END DO +#ifdef W3_DEBUGSOLVER + IF (testWrite) THEN + CALL SCAL_INTEGRAL_PRINT_R4(U, "U in loop") + END IF +#endif + AC = REAL(U) + +#ifdef W3_DEBUGSOLVER + IF (testWrite) THEN + CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC in loop") + END IF +#endif + ! + ! 5 Update boundaries ... would be better to omit any if clause in this loop ... + ! a possibility would be to use NBI = 0 when FLBPI is FALSE and loop on IBI whatever the value of NBI + ! + IF ( FLBPI ) THEN + RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) + RD2=RD20 + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. END IF +#ifdef W3_DEBUGSOLVER + sumAC=0 + sumBPI0=0 + sumBPIN=0 + sumCG=0 + sumCLATS=0 +#endif + DO IBI = 1, NBI + IP_glob = MAPSF(ISBPI(IBI),1) + JX=IPGL_npa(IP_glob) + IF (JX .gt. 0) THEN + AC(JX) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) +#ifdef W3_DEBUGSOLVER + sumAC=sumAC + AC(JX) + sumBPI0=sumBPI0 + BBPI0(ISP,IBI) + sumBPIN=sumBPIN + BBPIN(ISP,IBI) + sumCG=sumCG + CG(IK,ISBPI(IBI)) + sumCLATS=sumCLATS + CLATS(ISBPI(IBI)) +#endif + END IF + END DO + END IF #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'NBI=', NBI - WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 - WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumAC=', sumAC - WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPI0=', sumBPI0 - WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPIN=', sumBPIN - WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCG=', sumCG - WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCLATS=', sumCLATS - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'NBI=', NBI + WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumAC=', sumAC + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPI0=', sumBPI0 + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPIN=', sumBPIN + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCG=', sumCG + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCLATS=', sumCLATS + FLUSH(740+IAPROC) #endif - CALL PDLIB_exchange1DREAL(AC) + CALL PDLIB_exchange1DREAL(AC) #ifdef W3_DEBUGSOLVER - IF (testWrite) THEN - CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC after FLBPI") - END IF + IF (testWrite) THEN + CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC after FLBPI") + END IF #endif - END DO + END DO #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 6' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 6' + FLUSH(740+IAPROC) #endif - END SUBROUTINE PDLIB_W3XYPFSN2 -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Explicit PSI-Scheme -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END SUBROUTINE PDLIB_W3XYPFSN2 + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Explicit PSI-Scheme + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only : NK, NTH, NX, IEN, CLATS, MAPSF, IOBPA, NNZ - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3WDATMD, only: TIME - USE W3ADATMD, only: CG, ITER, CFLXYMAX - USE W3ODATMD, only: NDSE, NDST, FLBPI, NBI, ISBPI, BBPI0, BBPIN - USE W3TIMEMD, only: DSEC21 - USE W3GDATMD, only: NSEAL, DMIN + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only : NK, NTH, NX, IEN, CLATS, MAPSF, IOBPA, NNZ + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3WDATMD, only: TIME + USE W3ADATMD, only: CG, ITER, CFLXYMAX + USE W3ODATMD, only: NDSE, NDST, FLBPI, NBI, ISBPI, BBPI0, BBPIN + USE W3TIMEMD, only: DSEC21 + USE W3GDATMD, only: NSEAL, DMIN #ifdef W3_REF1 - USE W3GDATMD, only: REFPARS -#endif - USE W3ADATMD, only: MPI_COMM_WCMP - use yowElementpool, only: ne, INE - use YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, PDLIB_SI, iplg, npa - USE W3ODATMD, only : IAPROC - use yowDatapool, only: rtype - use yowExchangeModule, only : PDLIB_exchange1DREAL - USE MPI, only : MPI_MIN - USE W3PARALL, only : INIT_GET_JSEA_ISPROC - USE W3PARALL, only : ONESIXTH, THR, ZERO - USE yowRankModule, only : IPGL_npa - IMPLICIT NONE - INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, - ! actual Wave Direction - REAL, INTENT(IN) :: DT ! Time interval for which the - ! advection should be computed - ! for the given velocity field - REAL, INTENT(IN) :: C(npa,2) ! Velocity field in its - ! X- and Y- Components, - REAL, INTENT(INOUT) :: AC(npa) ! Wave Action before and - ! after advection - REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation - ! coefficients for boundary - ! conditions - LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of - ! the max. Global Time step + USE W3GDATMD, only: REFPARS +#endif + USE W3ADATMD, only: MPI_COMM_WCMP + use yowElementpool, only: ne, INE + use YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, PDLIB_SI, iplg, npa + USE W3ODATMD, only : IAPROC + use yowDatapool, only: rtype + use yowExchangeModule, only : PDLIB_exchange1DREAL + USE MPI, only : MPI_MIN + USE W3PARALL, only : INIT_GET_JSEA_ISPROC + USE W3PARALL, only : ONESIXTH, THR, ZERO + USE yowRankModule, only : IPGL_npa + IMPLICIT NONE + INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, + ! actual Wave Direction + REAL, INTENT(IN) :: DT ! Time interval for which the + ! advection should be computed + ! for the given velocity field + REAL, INTENT(IN) :: C(npa,2) ! Velocity field in its + ! X- and Y- Components, + REAL, INTENT(INOUT) :: AC(npa) ! Wave Action before and + ! after advection + REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation + ! coefficients for boundary + ! conditions + LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of + ! the max. Global Time step #ifdef W3_REF1 - INTEGER(KIND=1) :: IOBPDR_LOC(NPA) + INTEGER(KIND=1) :: IOBPDR_LOC(NPA) #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK - INTEGER :: IBI, NI(3), JX - INTEGER :: ISPROC, IP_glob, JSEA, ierr - REAL :: RD1, RD2 - REAL :: UTILDE - REAL :: SUMTHETA - REAL :: FL1, FL2, FL3 - REAL :: FT, CFLXY - REAL :: FL11, FL12, FL21, FL22, FL31, FL32 - REAL :: FL111, FL112, FL211, FL212, FL311, FL312 - REAL :: DTSI(npa), U(npa) - REAL :: DTMAX, DTMAX_GL, DTMAXEXP, REST - REAL :: LAMBDA(2), KTMP(3), TMP(3) - REAL :: THETA_L(3), BET1(3), BETAHAT(3) - REAL :: KELEM(3,NE), FLALL(3,NE) - REAL :: KKSUM(npa), ST(npa) - REAL :: NM(NE) + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK + INTEGER :: IBI, NI(3), JX + INTEGER :: ISPROC, IP_glob, JSEA, ierr + REAL :: RD1, RD2 + REAL :: UTILDE + REAL :: SUMTHETA + REAL :: FL1, FL2, FL3 + REAL :: FT, CFLXY + REAL :: FL11, FL12, FL21, FL22, FL31, FL32 + REAL :: FL111, FL112, FL211, FL212, FL311, FL312 + REAL :: DTSI(npa), U(npa) + REAL :: DTMAX, DTMAX_GL, DTMAXEXP, REST + REAL :: LAMBDA(2), KTMP(3), TMP(3) + REAL :: THETA_L(3), BET1(3), BETAHAT(3) + REAL :: KELEM(3,NE), FLALL(3,NE) + REAL :: KKSUM(npa), ST(npa) + REAL :: NM(NE) #ifdef W3_S - CALL STRACE (IENT, 'W3XYPFSN') + CALL STRACE (IENT, 'W3XYPFSN') #endif - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - DTMAX = DBLE(10.E10) + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + DTMAX = DBLE(10.E10) #ifdef W3_REF1 - IOBPDR_LOC(:)=(1-IOBP_LOC(:))*(1-IOBPD_LOC(ITH,:)) -#endif + IOBPDR_LOC(:)=(1-IOBP_LOC(:))*(1-IOBPD_LOC(ITH,:)) +#endif + DO IE = 1, NE + I1 = INE(1,IE) + I2 = INE(2,IE) + I3 = INE(3,IE) + LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction + LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) + KELEM(1,IE) = LAMBDA(1) * PDLIB_IEN(1,IE) + LAMBDA(2) * PDLIB_IEN(2,IE) ! K-Values - so called Flux Jacobians + KELEM(2,IE) = LAMBDA(1) * PDLIB_IEN(3,IE) + LAMBDA(2) * PDLIB_IEN(4,IE) + KELEM(3,IE) = LAMBDA(1) * PDLIB_IEN(5,IE) + LAMBDA(2) * PDLIB_IEN(6,IE) + KTMP = KELEM(:,IE) ! Copy + NM(IE) = - 1.D0/MIN(-THR,SUM(MIN(ZERO,KTMP))) ! N-Values + KELEM(:,IE) = MAX(ZERO,KTMP) + FL11 = C(I2,1) * PDLIB_IEN(1,IE) + C(I2,2) * PDLIB_IEN(2,IE) ! Weights for Simpson Integration + FL12 = C(I3,1) * PDLIB_IEN(1,IE) + C(I3,2) * PDLIB_IEN(2,IE) + FL21 = C(I3,1) * PDLIB_IEN(3,IE) + C(I3,2) * PDLIB_IEN(4,IE) + FL22 = C(I1,1) * PDLIB_IEN(3,IE) + C(I1,2) * PDLIB_IEN(4,IE) + FL31 = C(I1,1) * PDLIB_IEN(5,IE) + C(I1,2) * PDLIB_IEN(6,IE) + FL32 = C(I2,1) * PDLIB_IEN(5,IE) + C(I2,2) * PDLIB_IEN(6,IE) + FL111 = 2.d0*FL11+FL12 + FL112 = 2.d0*FL12+FL11 + FL211 = 2.d0*FL21+FL22 + FL212 = 2.d0*FL22+FL21 + FL311 = 2.d0*FL31+FL32 + FL312 = 2.d0*FL32+FL31 + FLALL(1,IE) = (FL311 + FL212)! * ONESIXTH + KELEM(1,IE) + FLALL(2,IE) = (FL111 + FL312)! * ONESIXTH + KELEM(2,IE) + FLALL(3,IE) = (FL211 + FL112)! * ONESIXTH + KELEM(3,IE) + END DO + IF (LCALC) THEN + KKSUM = ZERO DO IE = 1, NE - I1 = INE(1,IE) - I2 = INE(2,IE) - I3 = INE(3,IE) - LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction - LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) - KELEM(1,IE) = LAMBDA(1) * PDLIB_IEN(1,IE) + LAMBDA(2) * PDLIB_IEN(2,IE) ! K-Values - so called Flux Jacobians - KELEM(2,IE) = LAMBDA(1) * PDLIB_IEN(3,IE) + LAMBDA(2) * PDLIB_IEN(4,IE) - KELEM(3,IE) = LAMBDA(1) * PDLIB_IEN(5,IE) + LAMBDA(2) * PDLIB_IEN(6,IE) - KTMP = KELEM(:,IE) ! Copy - NM(IE) = - 1.D0/MIN(-THR,SUM(MIN(ZERO,KTMP))) ! N-Values - KELEM(:,IE) = MAX(ZERO,KTMP) - FL11 = C(I2,1) * PDLIB_IEN(1,IE) + C(I2,2) * PDLIB_IEN(2,IE) ! Weights for Simpson Integration - FL12 = C(I3,1) * PDLIB_IEN(1,IE) + C(I3,2) * PDLIB_IEN(2,IE) - FL21 = C(I3,1) * PDLIB_IEN(3,IE) + C(I3,2) * PDLIB_IEN(4,IE) - FL22 = C(I1,1) * PDLIB_IEN(3,IE) + C(I1,2) * PDLIB_IEN(4,IE) - FL31 = C(I1,1) * PDLIB_IEN(5,IE) + C(I1,2) * PDLIB_IEN(6,IE) - FL32 = C(I2,1) * PDLIB_IEN(5,IE) + C(I2,2) * PDLIB_IEN(6,IE) - FL111 = 2.d0*FL11+FL12 - FL112 = 2.d0*FL12+FL11 - FL211 = 2.d0*FL21+FL22 - FL212 = 2.d0*FL22+FL21 - FL311 = 2.d0*FL31+FL32 - FL312 = 2.d0*FL32+FL31 - FLALL(1,IE) = (FL311 + FL212)! * ONESIXTH + KELEM(1,IE) - FLALL(2,IE) = (FL111 + FL312)! * ONESIXTH + KELEM(2,IE) - FLALL(3,IE) = (FL211 + FL112)! * ONESIXTH + KELEM(3,IE) + NI = INE(:,IE) + KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) END DO - IF (LCALC) THEN - KKSUM = ZERO - DO IE = 1, NE - NI = INE(:,IE) - KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) - END DO - DO IP = 1, npa - DTMAXEXP = PDLIB_SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP_LOC(IP)) - DTMAX = MIN( DTMAX, DTMAXEXP) - CFLXYMAX(IP) = MAX(CFLXYMAX(IP),DBLE(DT)/DTMAXEXP) - END DO ! IP - CALL MPI_ALLREDUCE(DTMAX,DTMAX_GL,1,rtype,MPI_MIN,MPI_COMM_WCMP,ierr) - CFLXY = DBLE(DT)/DTMAX_GL - REST = ABS(MOD(CFLXY,1.0d0)) - IF (REST .LT. THR) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) - ELSE IF (REST .GT. THR .AND. REST .LT. 0.5d0) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 + DO IP = 1, npa + DTMAXEXP = PDLIB_SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP_LOC(IP)) + DTMAX = MIN( DTMAX, DTMAXEXP) + CFLXYMAX(IP) = MAX(CFLXYMAX(IP),DBLE(DT)/DTMAXEXP) + END DO ! IP + CALL MPI_ALLREDUCE(DTMAX,DTMAX_GL,1,rtype,MPI_MIN,MPI_COMM_WCMP,ierr) + CFLXY = DBLE(DT)/DTMAX_GL + REST = ABS(MOD(CFLXY,1.0d0)) + IF (REST .LT. THR) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + ELSE IF (REST .GT. THR .AND. REST .LT. 0.5d0) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 + ELSE + ITER(IK,ITH) = ABS(NINT(CFLXY)) + END IF + END IF + DO IP = 1, npa + DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/PDLIB_SI(IP) ! Some precalculations for the time integration. + END DO + DO IT = 1, ITER(IK,ITH) + U = DBLE(AC) + ST = ZERO + DO IE = 1, NE + NI = INE(:,IE) + FT = -ONESIXTH*DOT_PRODUCT(U(NI),FLALL(:,IE)) + UTILDE = NM(IE) * ( DOT_PRODUCT(KELEM(:,IE),U(NI)) - FT ) + THETA_L(:) = KELEM(:,IE) * (U(NI) - UTILDE) + IF (ABS(FT) .GT. 0.0d0) THEN + BET1(:) = THETA_L(:)/FT + IF (ANY( BET1 .LT. 0.0d0) ) THEN + BETAHAT(1) = BET1(1) + 0.5d0 * BET1(2) + BETAHAT(2) = BET1(2) + 0.5d0 * BET1(3) + BETAHAT(3) = BET1(3) + 0.5d0 * BET1(1) + BET1(1) = MAX(ZERO,MIN(BETAHAT(1),1.d0-BETAHAT(2),1.d0)) + BET1(2) = MAX(ZERO,MIN(BETAHAT(2),1.d0-BETAHAT(3),1.d0)) + BET1(3) = MAX(ZERO,MIN(BETAHAT(3),1.d0-BETAHAT(1),1.d0)) + THETA_L(:) = FT * BET1 + END IF ELSE - ITER(IK,ITH) = ABS(NINT(CFLXY)) + THETA_L(:) = ZERO END IF - END IF - DO IP = 1, npa - DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/PDLIB_SI(IP) ! Some precalculations for the time integration. + ST(NI) = ST(NI) + THETA_L ! the 2nd term are the theta values of each node ... END DO - DO IT = 1, ITER(IK,ITH) - U = DBLE(AC) - ST = ZERO - DO IE = 1, NE - NI = INE(:,IE) - FT = -ONESIXTH*DOT_PRODUCT(U(NI),FLALL(:,IE)) - UTILDE = NM(IE) * ( DOT_PRODUCT(KELEM(:,IE),U(NI)) - FT ) - THETA_L(:) = KELEM(:,IE) * (U(NI) - UTILDE) - IF (ABS(FT) .GT. 0.0d0) THEN - BET1(:) = THETA_L(:)/FT - IF (ANY( BET1 .LT. 0.0d0) ) THEN - BETAHAT(1) = BET1(1) + 0.5d0 * BET1(2) - BETAHAT(2) = BET1(2) + 0.5d0 * BET1(3) - BETAHAT(3) = BET1(3) + 0.5d0 * BET1(1) - BET1(1) = MAX(ZERO,MIN(BETAHAT(1),1.d0-BETAHAT(2),1.d0)) - BET1(2) = MAX(ZERO,MIN(BETAHAT(2),1.d0-BETAHAT(3),1.d0)) - BET1(3) = MAX(ZERO,MIN(BETAHAT(3),1.d0-BETAHAT(1),1.d0)) - THETA_L(:) = FT * BET1 - END IF - ELSE - THETA_L(:) = ZERO - END IF - ST(NI) = ST(NI) + THETA_L ! the 2nd term are the theta values of each node ... - END DO - DO IP = 1, npa - U(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA_LOC(IP)))*IOBPD_LOC(ITH,IP)*IOBDP_LOC(IP) + DO IP = 1, npa + U(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA_LOC(IP)))*IOBPD_LOC(ITH,IP)*IOBDP_LOC(IP) #ifdef W3_REF1 - IF (REFPARS(3).LT.0.5.AND.IOBPD_LOC(ITH,IP).EQ.0.AND.IOBPA_LOC(IP).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values + IF (REFPARS(3).LT.0.5.AND.IOBPD_LOC(ITH,IP).EQ.0.AND.IOBPA_LOC(IP).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values #endif - END DO - AC = REAL(U) -! -! 5 Update boundaries ... this should be implemented differently ... it is better to omit any if clause in this loop ... -! - IF ( FLBPI ) THEN - RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) - RD2=RD20 - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF -! -! NB: this treatment of the open boundary (time interpolation) is different from -! the constant boundary in the structured grids ... which restores the boundary -! to the initial value: IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) -! Why this difference ? -! - DO IBI=1, NBI - IP_glob = MAPSF(ISBPI(IBI),1) - JX=IPGL_npa(IP_glob) - IF (JX .gt. 0) THEN - AC(JX) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) - END IF - ENDDO - END IF - CALL PDLIB_exchange1DREAL(AC) - END DO ! IT - END SUBROUTINE PDLIB_W3XYPFSPSI2 -!/ ------------------------------------------------------------------- / - SUBROUTINE TEST_MPI_STATUS(string) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Check mpi status -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE W3ADATMD, only : MPI_COMM_WCMP - USE W3GDATMD, only : GTYPE, UNGTYPE - USE W3ODATMD, only : IAPROC, NAPROC, NTPROC - use yowDatapool, only: rtype, istatus - IMPLICIT NONE - INCLUDE "mpif.h" - CHARACTER(*), INTENT(in) :: string - REAL VcollExp(1) - REAL rVect(1) - INTEGER iProc, ierr - WRITE(740+IAPROC,*) 'TEST_MPI_STATUS, at string=', string - FLUSH(740+IAPROC) - IF (IAPROC .gt. NAPROC) THEN - RETURN - END IF - WRITE(740+IAPROC,*) 'After status settings' - FLUSH(740+IAPROC) - ! - ! Now find global arrays - ! - IF (IAPROC .eq. 1) THEN - DO iProc=2,NAPROC - CALL MPI_RECV(rVect,1,MPI_REAL, iProc-1, 37, MPI_COMM_WCMP, istatus, ierr) - END DO - ELSE - CALL MPI_SEND(VcollExp,1,MPI_REAL, 0, 37, MPI_COMM_WCMP, ierr) - END IF - WRITE(740+IAPROC,*) 'Leaving the TEST_MPI_STATUS' - FLUSH(740+IAPROC) - END SUBROUTINE TEST_MPI_STATUS -!/ ------------------------------------------------------------------- / -!/ ------------ SCALAR FUNCTIONALITY --------------------------------- / -!/ --------------- REAL V(NSEAL) ------------------------------------- / -!/ --------------- NSEAL = npa --------------------------------------- / -!/ ------- maxidx = npa or np for arrays that have been -------------- / -!/ ------- synchronized or not --------------------------------------- / -!/ ------- CheckUncovered is because some the triangulation ---------- / -!/ ------- may not cover all nodes ----------------------------------- / -!/ ------------------------------------------------------------------- / - SUBROUTINE SCAL_INTEGRAL_PRINT_GENERAL(V, string, maxidx, CheckUncovered, PrintFullValue) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3GDATMD, only : NK, NTH, FTE - USE W3GDATMD, only : NSPEC, NX, NY, NSEAL, MAPFS - USE W3ADATMD, only : MPI_COMM_WCMP - USE W3GDATMD, only : GTYPE, UNGTYPE - USE W3ODATMD, only : IAPROC, NAPROC, NTPROC - use yowDatapool, only: rtype, istatus - USE YOWNODEPOOL, only: npa, iplg - USE W3PARALL, only: INIT_GET_ISEA - IMPLICIT NONE - INCLUDE "mpif.h" + END DO + AC = REAL(U) ! - REAL*8, INTENT(in) :: V(NSEAL) - CHARACTER(*), INTENT(in) :: string - INTEGER, INTENT(IN) :: maxidx - LOGICAL, INTENT(in) :: CheckUncovered - LOGICAL, INTENT(in) :: PrintFullValue + ! 5 Update boundaries ... this should be implemented differently ... it is better to omit any if clause in this loop ... ! - REAL*8, allocatable :: Vcoll(:) - INTEGER, allocatable :: Status(:) - REAL*8, allocatable :: ListVal(:) - INTEGER, allocatable :: ListIdx(:) - INTEGER singV(2) - REAL CoherencyError, eVal1, eVal2, eErr - INTEGER NSEAL_dist, maxidx_dist - INTEGER JSEA, ISEA, iProc, I, IX, ierr, ISP, IP, IP_glob - INTEGER nbIncorr, idx - INTEGER ITH, IK - - IF (IAPROC .gt. NAPROC) THEN - RETURN - END IF - IF (GTYPE .ne. UNGTYPE) THEN - RETURN + IF ( FLBPI ) THEN + RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) + RD2=RD20 + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. + END IF + ! + ! NB: this treatment of the open boundary (time interpolation) is different from + ! the constant boundary in the structured grids ... which restores the boundary + ! to the initial value: IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) + ! Why this difference ? + ! + DO IBI=1, NBI + IP_glob = MAPSF(ISBPI(IBI),1) + JX=IPGL_npa(IP_glob) + IF (JX .gt. 0) THEN + AC(JX) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) + END IF + ENDDO END IF - ! - ! Now find global arrays - ! - IF (IAPROC .eq. 1) THEN - CoherencyError=0 - allocate(Vcoll(NX), Status(NX)) - Vcoll=0 - Status=0 - DO JSEA=1,maxidx - IP = JSEA - IP_glob = iplg(IP) - ISEA=MAPFS(1,IP_glob) - Vcoll(IP_glob)=V(JSEA) - Status(IP_glob)=1 - END DO - DO iProc=2,NAPROC - CALL MPI_RECV(singV,2,MPI_INTEGER, iProc-1, 360, MPI_COMM_WCMP, istatus, ierr) - NSEAL_dist = singV(1) - maxidx_dist = singV(2) - allocate(ListVal(NSEAL_dist), ListIdx(NSEAL_dist)) - CALL MPI_RECV(ListVal, NSEAL_dist, MPI_REAL8, iProc-1, 370, MPI_COMM_WCMP, istatus, ierr) - CALL MPI_RECV(ListIdx, NSEAL_dist, MPI_INTEGER, iProc-1, 430, MPI_COMM_WCMP, istatus, ierr) - DO idx=1,maxidx_dist - IP_glob = ListIdx(idx) - eVal1 = Vcoll(IP_glob) - eVal2 = ListVal(idx) - Vcoll(IP_glob) = eVal2 - IF (Status(IP_glob) .eq. 1) THEN - eErr=abs(eVal1 - eVal2) - CoherencyError = CoherencyError + eErr - END IF - Status(IP_glob) = 1 - END DO - deallocate(ListVal, ListIdx) - END DO - WRITE(740+IAPROC,'(a,f14.7,f14.7,a,a)') 'sum,coh=', sum(Vcoll), CoherencyError, ' ', TRIM(string) - nbIncorr=0 - DO IX=1,NX - ISEA=MAPFS(1,IX) - IF (ISEA .gt. 0) THEN - IF (Status(IX) .eq. 0) THEN - nbIncorr=nbIncorr+1 - END IF + CALL PDLIB_exchange1DREAL(AC) + END DO ! IT + END SUBROUTINE PDLIB_W3XYPFSPSI2 + !/ ------------------------------------------------------------------- / + SUBROUTINE TEST_MPI_STATUS(string) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Check mpi status + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE W3ADATMD, only : MPI_COMM_WCMP + USE W3GDATMD, only : GTYPE, UNGTYPE + USE W3ODATMD, only : IAPROC, NAPROC, NTPROC + use yowDatapool, only: rtype, istatus + IMPLICIT NONE + INCLUDE "mpif.h" + CHARACTER(*), INTENT(in) :: string + REAL VcollExp(1) + REAL rVect(1) + INTEGER iProc, ierr + WRITE(740+IAPROC,*) 'TEST_MPI_STATUS, at string=', string + FLUSH(740+IAPROC) + IF (IAPROC .gt. NAPROC) THEN + RETURN + END IF + WRITE(740+IAPROC,*) 'After status settings' + FLUSH(740+IAPROC) + ! + ! Now find global arrays + ! + IF (IAPROC .eq. 1) THEN + DO iProc=2,NAPROC + CALL MPI_RECV(rVect,1,MPI_REAL, iProc-1, 37, MPI_COMM_WCMP, istatus, ierr) + END DO + ELSE + CALL MPI_SEND(VcollExp,1,MPI_REAL, 0, 37, MPI_COMM_WCMP, ierr) + END IF + WRITE(740+IAPROC,*) 'Leaving the TEST_MPI_STATUS' + FLUSH(740+IAPROC) + END SUBROUTINE TEST_MPI_STATUS + !/ ------------------------------------------------------------------- / + !/ ------------ SCALAR FUNCTIONALITY --------------------------------- / + !/ --------------- REAL V(NSEAL) ------------------------------------- / + !/ --------------- NSEAL = npa --------------------------------------- / + !/ ------- maxidx = npa or np for arrays that have been -------------- / + !/ ------- synchronized or not --------------------------------------- / + !/ ------- CheckUncovered is because some the triangulation ---------- / + !/ ------- may not cover all nodes ----------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE SCAL_INTEGRAL_PRINT_GENERAL(V, string, maxidx, CheckUncovered, PrintFullValue) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GDATMD, only : NK, NTH, FTE + USE W3GDATMD, only : NSPEC, NX, NY, NSEAL, MAPFS + USE W3ADATMD, only : MPI_COMM_WCMP + USE W3GDATMD, only : GTYPE, UNGTYPE + USE W3ODATMD, only : IAPROC, NAPROC, NTPROC + use yowDatapool, only: rtype, istatus + USE YOWNODEPOOL, only: npa, iplg + USE W3PARALL, only: INIT_GET_ISEA + IMPLICIT NONE + INCLUDE "mpif.h" + ! + REAL*8, INTENT(in) :: V(NSEAL) + CHARACTER(*), INTENT(in) :: string + INTEGER, INTENT(IN) :: maxidx + LOGICAL, INTENT(in) :: CheckUncovered + LOGICAL, INTENT(in) :: PrintFullValue + ! + REAL*8, allocatable :: Vcoll(:) + INTEGER, allocatable :: Status(:) + REAL*8, allocatable :: ListVal(:) + INTEGER, allocatable :: ListIdx(:) + INTEGER singV(2) + REAL CoherencyError, eVal1, eVal2, eErr + INTEGER NSEAL_dist, maxidx_dist + INTEGER JSEA, ISEA, iProc, I, IX, ierr, ISP, IP, IP_glob + INTEGER nbIncorr, idx + INTEGER ITH, IK + + IF (IAPROC .gt. NAPROC) THEN + RETURN + END IF + IF (GTYPE .ne. UNGTYPE) THEN + RETURN + END IF + ! + ! Now find global arrays + ! + IF (IAPROC .eq. 1) THEN + CoherencyError=0 + allocate(Vcoll(NX), Status(NX)) + Vcoll=0 + Status=0 + DO JSEA=1,maxidx + IP = JSEA + IP_glob = iplg(IP) + ISEA=MAPFS(1,IP_glob) + Vcoll(IP_glob)=V(JSEA) + Status(IP_glob)=1 + END DO + DO iProc=2,NAPROC + CALL MPI_RECV(singV,2,MPI_INTEGER, iProc-1, 360, MPI_COMM_WCMP, istatus, ierr) + NSEAL_dist = singV(1) + maxidx_dist = singV(2) + allocate(ListVal(NSEAL_dist), ListIdx(NSEAL_dist)) + CALL MPI_RECV(ListVal, NSEAL_dist, MPI_REAL8, iProc-1, 370, MPI_COMM_WCMP, istatus, ierr) + CALL MPI_RECV(ListIdx, NSEAL_dist, MPI_INTEGER, iProc-1, 430, MPI_COMM_WCMP, istatus, ierr) + DO idx=1,maxidx_dist + IP_glob = ListIdx(idx) + eVal1 = Vcoll(IP_glob) + eVal2 = ListVal(idx) + Vcoll(IP_glob) = eVal2 + IF (Status(IP_glob) .eq. 1) THEN + eErr=abs(eVal1 - eVal2) + CoherencyError = CoherencyError + eErr END IF + Status(IP_glob) = 1 END DO - IF (CheckUncovered) THEN - IF (nbIncorr .gt. 0) THEN - WRITE(*,*) ' nbIncorr=', nbIncorr - WRITE(*,*) ' NX=', NX - WRITE(*,*) ' NSEAL=', NSEAL - WRITE(*,*) ' npa=', npa - STOP + deallocate(ListVal, ListIdx) + END DO + WRITE(740+IAPROC,'(a,f14.7,f14.7,a,a)') 'sum,coh=', sum(Vcoll), CoherencyError, ' ', TRIM(string) + nbIncorr=0 + DO IX=1,NX + ISEA=MAPFS(1,IX) + IF (ISEA .gt. 0) THEN + IF (Status(IX) .eq. 0) THEN + nbIncorr=nbIncorr+1 END IF END IF - IF (PrintFullValue) THEN - WRITE(740+IAPROC,*) 'Value of V at nodes' - DO IX=1,NX - WRITE(740+IAPROC,*) 'IX=', IX, ' V=', Vcoll(IX) - END DO + END DO + IF (CheckUncovered) THEN + IF (nbIncorr .gt. 0) THEN + WRITE(*,*) ' nbIncorr=', nbIncorr + WRITE(*,*) ' NX=', NX + WRITE(*,*) ' NSEAL=', NSEAL + WRITE(*,*) ' npa=', npa + STOP END IF - FLUSH(740+IAPROC) - deallocate(Vcoll, Status) - ELSE - singV(1) = NSEAL - singV(2) = maxidx - CALL MPI_SEND(singV,2,MPI_INTEGER, 0, 360, MPI_COMM_WCMP, ierr) - allocate(ListVal(NSEAL), ListIdx(NSEAL)) - DO JSEA=1,NSEAL - IP = JSEA - IP_glob = iplg(IP) - ISEA=MAPFS(1,IP_glob) - ListVal(JSEA) = V(JSEA) - ListIdx(JSEA) = IP_glob - END DO - CALL MPI_SEND(ListVal, NSEAL, MPI_REAL8, 0, 370, MPI_COMM_WCMP, ierr) - CALL MPI_SEND(ListIdx, NSEAL, MPI_INTEGER, 0, 430, MPI_COMM_WCMP, ierr) - deallocate(ListVal, ListIdx) END IF - END SUBROUTINE SCAL_INTEGRAL_PRINT_GENERAL -!/ ------------------------------------------------------------------- / - SUBROUTINE SCAL_INTEGRAL_PRINT_R8(V, string) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE W3GDATMD, only : NSEAL - IMPLICIT NONE - REAL*8, INTENT(in) :: V(NSEAL) - CHARACTER(*), INTENT(in) :: string - REAL*8 :: V8(NSEAL) - LOGICAL :: CheckUncovered = .FALSE. - LOGICAL :: PrintFullValue = .FALSE. - V8 = V - CALL SCAL_INTEGRAL_PRINT_GENERAL(V8, string, NSEAL, CheckUncovered, PrintFullValue) - END SUBROUTINE SCAL_INTEGRAL_PRINT_R8 -!/ ------------------------------------------------------------------- / - SUBROUTINE SCAL_INTEGRAL_PRINT_R4(V, string) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE W3GDATMD, only : NSEAL - IMPLICIT NONE - REAL, INTENT(in) :: V(NSEAL) - CHARACTER(*), INTENT(in) :: string - LOGICAL :: CheckUncovered = .FALSE. - LOGICAL :: PrintFullValue = .FALSE. - REAL*8 V8(NSEAL) - V8 = DBLE(V) - CALL SCAL_INTEGRAL_PRINT_GENERAL(V8, string, NSEAL, CheckUncovered, PrintFullValue) - END SUBROUTINE SCAL_INTEGRAL_PRINT_R4 -!/ ------------------------------------------------------------------- / - SUBROUTINE ALL_VAOLD_INTEGRAL_PRINT(string, choice) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE W3GDATMD, only : NSEAL - USE W3WDATMD, only : VAOLD - USE W3ODATMD, only : IAPROC - USE W3GDATMD, only : NSPEC - USE YOWNODEPOOL, only: np, npa - IMPLICIT NONE - CHARACTER(*), INTENT(in) :: string - INTEGER, INTENT(in) :: choice - REAL :: FIELD(NSPEC,NSEAL) - INTEGER ISPEC, JSEA, maxidx - LOGICAL :: PrintMinISP = .FALSE. - LOGICAL :: LocalizeMaximum = .FALSE. - DO JSEA=1,NSEAL - DO ISPEC=1,NSPEC - FIELD(ISPEC,JSEA) = VAOLD(ISPEC,JSEA) + IF (PrintFullValue) THEN + WRITE(740+IAPROC,*) 'Value of V at nodes' + DO IX=1,NX + WRITE(740+IAPROC,*) 'IX=', IX, ' V=', Vcoll(IX) END DO - END DO - IF (choice .eq. 1) THEN - maxidx = npa - ELSE - maxidx = np - END IF -! CALL ALL_FIELD_INTEGRAL_PRINT_GENERAL(FIELD, string) - CALL CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(FIELD, string, maxidx, PrintMinISP, LocalizeMaximum) - END SUBROUTINE ALL_VAOLD_INTEGRAL_PRINT -!/ ------------------------------------------------------------------- / - SUBROUTINE ALL_VA_INTEGRAL_PRINT(IMOD, string, choice) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE W3GDATMD, only : NSEAL, NSEA, NX, NY - USE W3WDATMD, only : VA - USE W3ODATMD, only : IAPROC, NAPROC - USE W3GDATMD, only : NSPEC, GRIDS, GTYPE, UNGTYPE - USE YOWNODEPOOL, only: npa, np, iplg - IMPLICIT NONE - INTEGER, INTENT(in) :: IMOD - CHARACTER(*), INTENT(in) :: string - INTEGER, INTENT(in) :: choice - REAL :: FIELD(NSPEC,NSEAL) - INTEGER ISPEC, JSEA, IP_glob, maxidx - LOGICAL :: PrintMinISP = .FALSE. - LOGICAL :: LocalizeMaximum = .FALSE. - INTEGER :: TEST_IP = 46 - INTEGER :: TEST_ISP = 370 - IF (GRIDS(IMOD)%GTYPE .ne. UNGTYPE) THEN - RETURN - END IF - IF (IAPROC .gt. NAPROC) THEN - RETURN END IF - WRITE(740+IAPROC,*) 'Entering ALL_INTEGRAL_PRINT, NSEAL=', NSEAL FLUSH(740+IAPROC) - IF (NSEAL .ne. npa) THEN - Print *, 'NSEAL=', NSEAL, " npa=", npa - STOP - END IF + deallocate(Vcoll, Status) + ELSE + singV(1) = NSEAL + singV(2) = maxidx + CALL MPI_SEND(singV,2,MPI_INTEGER, 0, 360, MPI_COMM_WCMP, ierr) + allocate(ListVal(NSEAL), ListIdx(NSEAL)) DO JSEA=1,NSEAL - IP_glob=iplg(JSEA) - DO ISPEC=1,NSPEC - FIELD(ISPEC,JSEA) = VA(ISPEC,JSEA) - IF ((IP_glob .eq. TEST_IP).and.(ISPEC .eq. TEST_ISP)) THEN - WRITE(740+IAPROC,*) 'ASS TEST_IP=', TEST_IP, ' TEST_ISP=', TEST_ISP, ' val=', VA(ISPEC,JSEA) + IP = JSEA + IP_glob = iplg(IP) + ISEA=MAPFS(1,IP_glob) + ListVal(JSEA) = V(JSEA) + ListIdx(JSEA) = IP_glob + END DO + CALL MPI_SEND(ListVal, NSEAL, MPI_REAL8, 0, 370, MPI_COMM_WCMP, ierr) + CALL MPI_SEND(ListIdx, NSEAL, MPI_INTEGER, 0, 430, MPI_COMM_WCMP, ierr) + deallocate(ListVal, ListIdx) + END IF + END SUBROUTINE SCAL_INTEGRAL_PRINT_GENERAL + !/ ------------------------------------------------------------------- / + SUBROUTINE SCAL_INTEGRAL_PRINT_R8(V, string) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE W3GDATMD, only : NSEAL + IMPLICIT NONE + REAL*8, INTENT(in) :: V(NSEAL) + CHARACTER(*), INTENT(in) :: string + REAL*8 :: V8(NSEAL) + LOGICAL :: CheckUncovered = .FALSE. + LOGICAL :: PrintFullValue = .FALSE. + V8 = V + CALL SCAL_INTEGRAL_PRINT_GENERAL(V8, string, NSEAL, CheckUncovered, PrintFullValue) + END SUBROUTINE SCAL_INTEGRAL_PRINT_R8 + !/ ------------------------------------------------------------------- / + SUBROUTINE SCAL_INTEGRAL_PRINT_R4(V, string) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE W3GDATMD, only : NSEAL + IMPLICIT NONE + REAL, INTENT(in) :: V(NSEAL) + CHARACTER(*), INTENT(in) :: string + LOGICAL :: CheckUncovered = .FALSE. + LOGICAL :: PrintFullValue = .FALSE. + REAL*8 V8(NSEAL) + V8 = DBLE(V) + CALL SCAL_INTEGRAL_PRINT_GENERAL(V8, string, NSEAL, CheckUncovered, PrintFullValue) + END SUBROUTINE SCAL_INTEGRAL_PRINT_R4 + !/ ------------------------------------------------------------------- / + SUBROUTINE ALL_VAOLD_INTEGRAL_PRINT(string, choice) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE W3GDATMD, only : NSEAL + USE W3WDATMD, only : VAOLD + USE W3ODATMD, only : IAPROC + USE W3GDATMD, only : NSPEC + USE YOWNODEPOOL, only: np, npa + IMPLICIT NONE + CHARACTER(*), INTENT(in) :: string + INTEGER, INTENT(in) :: choice + REAL :: FIELD(NSPEC,NSEAL) + INTEGER ISPEC, JSEA, maxidx + LOGICAL :: PrintMinISP = .FALSE. + LOGICAL :: LocalizeMaximum = .FALSE. + DO JSEA=1,NSEAL + DO ISPEC=1,NSPEC + FIELD(ISPEC,JSEA) = VAOLD(ISPEC,JSEA) + END DO + END DO + IF (choice .eq. 1) THEN + maxidx = npa + ELSE + maxidx = np + END IF + ! CALL ALL_FIELD_INTEGRAL_PRINT_GENERAL(FIELD, string) + CALL CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(FIELD, string, maxidx, PrintMinISP, LocalizeMaximum) + END SUBROUTINE ALL_VAOLD_INTEGRAL_PRINT + !/ ------------------------------------------------------------------- / + SUBROUTINE ALL_VA_INTEGRAL_PRINT(IMOD, string, choice) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE W3GDATMD, only : NSEAL, NSEA, NX, NY + USE W3WDATMD, only : VA + USE W3ODATMD, only : IAPROC, NAPROC + USE W3GDATMD, only : NSPEC, GRIDS, GTYPE, UNGTYPE + USE YOWNODEPOOL, only: npa, np, iplg + IMPLICIT NONE + INTEGER, INTENT(in) :: IMOD + CHARACTER(*), INTENT(in) :: string + INTEGER, INTENT(in) :: choice + REAL :: FIELD(NSPEC,NSEAL) + INTEGER ISPEC, JSEA, IP_glob, maxidx + LOGICAL :: PrintMinISP = .FALSE. + LOGICAL :: LocalizeMaximum = .FALSE. + INTEGER :: TEST_IP = 46 + INTEGER :: TEST_ISP = 370 + IF (GRIDS(IMOD)%GTYPE .ne. UNGTYPE) THEN + RETURN + END IF + IF (IAPROC .gt. NAPROC) THEN + RETURN + END IF + WRITE(740+IAPROC,*) 'Entering ALL_INTEGRAL_PRINT, NSEAL=', NSEAL + FLUSH(740+IAPROC) + IF (NSEAL .ne. npa) THEN + Print *, 'NSEAL=', NSEAL, " npa=", npa + STOP + END IF + DO JSEA=1,NSEAL + IP_glob=iplg(JSEA) + DO ISPEC=1,NSPEC + FIELD(ISPEC,JSEA) = VA(ISPEC,JSEA) + IF ((IP_glob .eq. TEST_IP).and.(ISPEC .eq. TEST_ISP)) THEN + WRITE(740+IAPROC,*) 'ASS TEST_IP=', TEST_IP, ' TEST_ISP=', TEST_ISP, ' val=', VA(ISPEC,JSEA) + END IF + END DO + END DO + WRITE(740+IAPROC,*) 'Before call to ALL_FIELD_INTEGRAL' + WRITE(740+IAPROC,*) 'NSPEC=', NSPEC, ' NX=', NX + FLUSH(740+IAPROC) + IF (choice .eq. 1) THEN + maxidx = npa + ELSE + maxidx = np + END IF + CALL CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(FIELD, string, maxidx, PrintMinISP, LocalizeMaximum) + WRITE(740+IAPROC,*) 'After call to ALL_FIELD_INTEGRAL' + FLUSH(740+IAPROC) + END SUBROUTINE ALL_VA_INTEGRAL_PRINT + !/ ------------------------------------------------------------------- / + SUBROUTINE ALL_FIELD_INTEGRAL_PRINT(FIELD, string) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE W3GDATMD, only : NSEAL + USE W3WDATMD, only : VA + USE W3ODATMD, only : IAPROC + USE W3GDATMD, only : NSPEC + IMPLICIT NONE + INTEGER maxidx + REAL, INTENT(in) :: FIELD(NSPEC,NSEAL) + CHARACTER(*), INTENT(in) :: string + LOGICAL :: PrintMinISP = .FALSE. + LOGICAL :: LocalizeMaximum = .FALSE. + maxidx = NSEAL + CALL CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(FIELD, string, maxidx, PrintMinISP, LocalizeMaximum) + END SUBROUTINE ALL_FIELD_INTEGRAL_PRINT + !/ ------------------------------------------------------------------- / + !/ ------- Coherency info for TheARR(NSPEC,npa) ---------------------- / + !/ ----------- maxidx is np or npa ----------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(TheARR, string, maxidx, PrintMinISP, LocalizeMaximum) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE W3GDATMD, only : NK, NTH + USE W3GDATMD, only : NSPEC, NX, NY, NSEAL, MAPFS + USE W3ADATMD, only : MPI_COMM_WCMP + USE W3GDATMD, only : GTYPE, UNGTYPE + USE W3ODATMD, only : IAPROC, NAPROC, NTPROC + use yowDatapool, only: rtype, istatus + USE YOWNODEPOOL, only: npa, iplg + USE W3PARALL, only: INIT_GET_ISEA + IMPLICIT NONE + INCLUDE "mpif.h" + CHARACTER(*), INTENT(in) :: string + INTEGER, INTENT(in) :: maxidx + REAL, INTENT(in) :: TheARR(NSPEC, npa) + LOGICAL, INTENT(in) :: PrintMinISP, LocalizeMaximum + ! + REAL Vcoll(NSPEC,NX), VcollExp(NSPEC*NX), rVect(NSPEC*NX) + REAL CoherencyError_Max, CoherencyError_Sum + REAL eVal1, eVal2, eErr + INTEGER LocateMax_I, LocateMax_ISP + INTEGER rStatus(NX), Status(NX) + INTEGER JSEA, ISEA, iProc, I, IX, ierr, ISP, IP, IP_glob + REAL :: mval, eVal, eSum + REAL :: TheMax, TheSum, TheNb, TheAvg + REAL :: eFact, Threshold + LOGICAL :: IsFirst + INTEGER nbIncorr, n_control + INTEGER ITH, IK + INTEGER :: TEST_IP = 46 + INTEGER :: TEST_ISP = 370 + IF (IAPROC .gt. NAPROC) THEN + RETURN + END IF + IF (GTYPE .ne. UNGTYPE) THEN + RETURN + END IF + WRITE(740+IAPROC,*) 'CHECK_ARRAY_INTEGRAL NSEAL=', NSEAL, ' npa=', npa, ' maxidx=', maxidx + VcollExp=0 + Status=0 + DO IP=1,maxidx + IP_glob=iplg(IP) + DO ISP=1,NSPEC + VcollExp(ISP+NSPEC*(IP_glob-1)) = TheARR(ISP,IP) + IF ((IP_glob .eq. TEST_IP).and.(ISP .eq. TEST_ISP)) THEN + WRITE(740+IAPROC,*) 'TEST_IP=', TEST_IP, ' TEST_ISP=', TEST_ISP, ' val=', TheARR(ISP,IP) + END IF + END DO + Status(IP_glob)=1 + END DO + ! + ! Now find global arrays + ! + CoherencyError_Max = 0 + CoherencyError_Sum = 0 + LocateMax_I = -1 + LocateMax_ISP = -1 + + n_control = 0 + IF (IAPROC .eq. 1) THEN + DO iProc=2,NAPROC + CALL MPI_RECV(rVect ,NSPEC*NX,MPI_REAL , iProc-1, 37, MPI_COMM_WCMP, istatus, ierr) + CALL MPI_RECV(rStatus,NX ,MPI_INTEGER, iProc-1, 43, MPI_COMM_WCMP, istatus, ierr) + DO I=1,NX + IF (rStatus(I) .eq. 1) THEN + DO ISP=1,NSPEC + eVal1 = VcollExp(ISP+NSPEC*(I-1)) + eVal2 = rVect(ISP+NSPEC*(I-1)) + IF (Status(I) .eq. 1) THEN + eErr=abs(eVal1 - eVal2) + CoherencyError_Sum = CoherencyError_Sum + eErr + IF (eErr .gt. CoherencyError_Max) THEN + CoherencyError_Max = eErr + LocateMax_I = I + LocateMax_ISP = ISP + END IF + IF (ISP .eq. 1) THEN + n_control = n_control + 1 + END IF + ELSE + VcollExp(ISP+NSPEC*(I-1))=eVal2 + END IF + END DO + Status(I)=1 END IF END DO END DO - WRITE(740+IAPROC,*) 'Before call to ALL_FIELD_INTEGRAL' - WRITE(740+IAPROC,*) 'NSPEC=', NSPEC, ' NX=', NX - FLUSH(740+IAPROC) - IF (choice .eq. 1) THEN - maxidx = npa - ELSE - maxidx = np - END IF - CALL CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(FIELD, string, maxidx, PrintMinISP, LocalizeMaximum) - WRITE(740+IAPROC,*) 'After call to ALL_FIELD_INTEGRAL' - FLUSH(740+IAPROC) - END SUBROUTINE ALL_VA_INTEGRAL_PRINT -!/ ------------------------------------------------------------------- / - SUBROUTINE ALL_FIELD_INTEGRAL_PRINT(FIELD, string) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE W3GDATMD, only : NSEAL - USE W3WDATMD, only : VA - USE W3ODATMD, only : IAPROC - USE W3GDATMD, only : NSPEC - IMPLICIT NONE - INTEGER maxidx - REAL, INTENT(in) :: FIELD(NSPEC,NSEAL) - CHARACTER(*), INTENT(in) :: string - LOGICAL :: PrintMinISP = .FALSE. - LOGICAL :: LocalizeMaximum = .FALSE. - maxidx = NSEAL - CALL CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(FIELD, string, maxidx, PrintMinISP, LocalizeMaximum) - END SUBROUTINE ALL_FIELD_INTEGRAL_PRINT -!/ ------------------------------------------------------------------- / -!/ ------- Coherency info for TheARR(NSPEC,npa) ---------------------- / -!/ ----------- maxidx is np or npa ----------------------------------- / -!/ ------------------------------------------------------------------- / - SUBROUTINE CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(TheARR, string, maxidx, PrintMinISP, LocalizeMaximum) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE W3GDATMD, only : NK, NTH - USE W3GDATMD, only : NSPEC, NX, NY, NSEAL, MAPFS - USE W3ADATMD, only : MPI_COMM_WCMP - USE W3GDATMD, only : GTYPE, UNGTYPE - USE W3ODATMD, only : IAPROC, NAPROC, NTPROC - use yowDatapool, only: rtype, istatus - USE YOWNODEPOOL, only: npa, iplg - USE W3PARALL, only: INIT_GET_ISEA - IMPLICIT NONE - INCLUDE "mpif.h" - CHARACTER(*), INTENT(in) :: string - INTEGER, INTENT(in) :: maxidx - REAL, INTENT(in) :: TheARR(NSPEC, npa) - LOGICAL, INTENT(in) :: PrintMinISP, LocalizeMaximum - ! - REAL Vcoll(NSPEC,NX), VcollExp(NSPEC*NX), rVect(NSPEC*NX) - REAL CoherencyError_Max, CoherencyError_Sum - REAL eVal1, eVal2, eErr - INTEGER LocateMax_I, LocateMax_ISP - INTEGER rStatus(NX), Status(NX) - INTEGER JSEA, ISEA, iProc, I, IX, ierr, ISP, IP, IP_glob - REAL :: mval, eVal, eSum - REAL :: TheMax, TheSum, TheNb, TheAvg - REAL :: eFact, Threshold - LOGICAL :: IsFirst - INTEGER nbIncorr, n_control - INTEGER ITH, IK - INTEGER :: TEST_IP = 46 - INTEGER :: TEST_ISP = 370 - IF (IAPROC .gt. NAPROC) THEN - RETURN - END IF - IF (GTYPE .ne. UNGTYPE) THEN - RETURN - END IF - WRITE(740+IAPROC,*) 'CHECK_ARRAY_INTEGRAL NSEAL=', NSEAL, ' npa=', npa, ' maxidx=', maxidx - VcollExp=0 - Status=0 - DO IP=1,maxidx - IP_glob=iplg(IP) + ELSE + CALL MPI_SEND(VcollExp,NSPEC*NX,MPI_REAL , 0, 37, MPI_COMM_WCMP, ierr) + CALL MPI_SEND(Status ,NX ,MPI_INTEGER, 0, 43, MPI_COMM_WCMP, ierr) + END IF + IF (IAPROC .eq. 1) THEN + DO I=1,NX DO ISP=1,NSPEC - VcollExp(ISP+NSPEC*(IP_glob-1)) = TheARR(ISP,IP) - IF ((IP_glob .eq. TEST_IP).and.(ISP .eq. TEST_ISP)) THEN - WRITE(740+IAPROC,*) 'TEST_IP=', TEST_IP, ' TEST_ISP=', TEST_ISP, ' val=', TheARR(ISP,IP) - END IF + Vcoll(ISP,I)=VcollExp(ISP + NSPEC*(I-1)) END DO - Status(IP_glob)=1 END DO - ! - ! Now find global arrays - ! - CoherencyError_Max = 0 - CoherencyError_Sum = 0 - LocateMax_I = -1 - LocateMax_ISP = -1 - - n_control = 0 - IF (IAPROC .eq. 1) THEN - DO iProc=2,NAPROC - CALL MPI_RECV(rVect ,NSPEC*NX,MPI_REAL , iProc-1, 37, MPI_COMM_WCMP, istatus, ierr) - CALL MPI_RECV(rStatus,NX ,MPI_INTEGER, iProc-1, 43, MPI_COMM_WCMP, istatus, ierr) - DO I=1,NX - IF (rStatus(I) .eq. 1) THEN - DO ISP=1,NSPEC - eVal1 = VcollExp(ISP+NSPEC*(I-1)) - eVal2 = rVect(ISP+NSPEC*(I-1)) - IF (Status(I) .eq. 1) THEN - eErr=abs(eVal1 - eVal2) - CoherencyError_Sum = CoherencyError_Sum + eErr - IF (eErr .gt. CoherencyError_Max) THEN - CoherencyError_Max = eErr - LocateMax_I = I - LocateMax_ISP = ISP - END IF - IF (ISP .eq. 1) THEN - n_control = n_control + 1 - END IF - ELSE - VcollExp(ISP+NSPEC*(I-1))=eVal2 - END IF - END DO - Status(I)=1 - END IF + nbIncorr=0 + DO IX=1,NX + ISEA=MAPFS(1,IX) + IF (ISEA .gt. 0) THEN + IF (Status(IX) .eq. 0) THEN + nbIncorr=nbIncorr+1 + END IF + END IF + END DO + IF (nbIncorr .gt. 0) THEN + WRITE(*,*) ' nbIncorr=', nbIncorr + WRITE(*,*) ' NX=', NX + WRITE(*,*) ' npa=', npa + STOP + END IF + WRITE(740+IAPROC,*) 'CHECK_ARRAY_INTEGRAL n_control=', n_control + WRITE(740+IAPROC,*) 'ARRAY_NX sum,coh=', sum(Vcoll), CoherencyError_Sum, TRIM(string) + WRITE(740+IAPROC,*) 'ARRAY_NX max,loc=', CoherencyError_Max,LocateMax_I,LocateMax_ISP, TRIM(string) + IF (PrintMinISP) THEN + DO ISP=1,NSPEC + IsFirst=.true. + eSum=0 + DO IP=1,maxidx + eVal=abs(Vcoll(ISP, IP)) + eSum=eSum + eVal + IF (IsFirst.eqv. .true.) then + mval=eVal + ELSE + IF (eVal .lt. mval) THEN + mval=eVal + ENDIF + ENDIF + IsFirst=.false. END DO + WRITE(740+IAPROC,*) 'ISP=', ISP, ' mval/sum=', mval, eSum END DO - ELSE - CALL MPI_SEND(VcollExp,NSPEC*NX,MPI_REAL , 0, 37, MPI_COMM_WCMP, ierr) - CALL MPI_SEND(Status ,NX ,MPI_INTEGER, 0, 43, MPI_COMM_WCMP, ierr) + FLUSH(740+IAPROC) END IF - IF (IAPROC .eq. 1) THEN - DO I=1,NX + IF (LocalizeMaximum) THEN + TheMax=0 + TheNb=0 + TheSum=0 + DO IP=1,maxidx DO ISP=1,NSPEC - Vcoll(ISP,I)=VcollExp(ISP + NSPEC*(I-1)) - END DO - END DO - nbIncorr=0 - DO IX=1,NX - ISEA=MAPFS(1,IX) - IF (ISEA .gt. 0) THEN - IF (Status(IX) .eq. 0) THEN - nbIncorr=nbIncorr+1 + eVal = abs(Vcoll(ISP, IP)) + TheSum = TheSum + eVal + TheNb = TheNb + 1 + IF (eVal .gt. TheMax) THEN + TheMax=eVal END IF - END IF + END DO END DO - IF (nbIncorr .gt. 0) THEN - WRITE(*,*) ' nbIncorr=', nbIncorr - WRITE(*,*) ' NX=', NX - WRITE(*,*) ' npa=', npa - STOP - END IF - WRITE(740+IAPROC,*) 'CHECK_ARRAY_INTEGRAL n_control=', n_control - WRITE(740+IAPROC,*) 'ARRAY_NX sum,coh=', sum(Vcoll), CoherencyError_Sum, TRIM(string) - WRITE(740+IAPROC,*) 'ARRAY_NX max,loc=', CoherencyError_Max,LocateMax_I,LocateMax_ISP, TRIM(string) - IF (PrintMinISP) THEN + TheAvg = TheSum / TheNb + WRITE(740+IAPROC,*) 'TheAvg/TheMax=', TheAvg, TheMax + eFact=0.5 + Threshold=eFact * TheMax + DO IP=1,maxidx DO ISP=1,NSPEC - IsFirst=.true. - eSum=0 - DO IP=1,maxidx - eVal=abs(Vcoll(ISP, IP)) - eSum=eSum + eVal - IF (IsFirst.eqv. .true.) then - mval=eVal - ELSE - IF (eVal .lt. mval) THEN - mval=eVal - ENDIF - ENDIF - IsFirst=.false. - END DO - WRITE(740+IAPROC,*) 'ISP=', ISP, ' mval/sum=', mval, eSum - END DO - FLUSH(740+IAPROC) - END IF - IF (LocalizeMaximum) THEN - TheMax=0 - TheNb=0 - TheSum=0 - DO IP=1,maxidx - DO ISP=1,NSPEC - eVal = abs(Vcoll(ISP, IP)) - TheSum = TheSum + eVal - TheNb = TheNb + 1 - IF (eVal .gt. TheMax) THEN - TheMax=eVal - END IF - END DO - END DO - TheAvg = TheSum / TheNb - WRITE(740+IAPROC,*) 'TheAvg/TheMax=', TheAvg, TheMax - eFact=0.5 - Threshold=eFact * TheMax - DO IP=1,maxidx - DO ISP=1,NSPEC - eVal = abs(Vcoll(ISP, IP)) - IF (eVal .gt. Threshold) THEN - WRITE(740+IAPROC,*) 'ISP/IP/val=', ISP, IP, eVal - END IF - END DO + eVal = abs(Vcoll(ISP, IP)) + IF (eVal .gt. Threshold) THEN + WRITE(740+IAPROC,*) 'ISP/IP/val=', ISP, IP, eVal + END IF END DO - FLUSH(740+IAPROC) - END IF - END IF - END SUBROUTINE CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct -!/ ------------------------------------------------------------------- / -!* maxidx should be "np" or "npa" * - SUBROUTINE CHECK_ARRAY_INTEGRAL_NX_R8(TheARR, string, maxidx) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE W3GDATMD, only : NSPEC - USE YOWNODEPOOL, only: npa - CHARACTER(*), INTENT(in) :: string - INTEGER, INTENT(in) :: maxidx - REAL, INTENT(in) :: TheARR(NSPEC, npa) - REAL*8 :: TheARR_red(npa) -! LOGICAL :: FULL_NSPEC = .FALSE. -! LOGICAL :: PrintMinISP = .FALSE. -! LOGICAL :: LocalizeMaximum = .FALSE. -! LOGICAL :: CheckUncovered = .FALSE. -! LOGICAL :: PrintFullValue = .FALSE. - LOGICAL :: FULL_NSPEC = .TRUE. - LOGICAL :: PrintMinISP = .TRUE. - LOGICAL :: LocalizeMaximum = .TRUE. - LOGICAL :: CheckUncovered = .TRUE. - LOGICAL :: PrintFullValue = .TRUE. - IF (FULL_NSPEC) THEN - CALL CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(TheARR, string, maxidx, PrintMinISP, LocalizeMaximum) - ELSE - DO IP=1,npa - TheARR_red(IP) = SUM(ABS(TheArr(:,IP))) END DO - CALL SCAL_INTEGRAL_PRINT_GENERAL(TheARR_red, string, maxidx, CheckUncovered, PrintFullValue) + FLUSH(740+IAPROC) END IF - END SUBROUTINE CHECK_ARRAY_INTEGRAL_NX_R8 -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Explicit LF-FCT scheme -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END IF + END SUBROUTINE CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct + !/ ------------------------------------------------------------------- / + !* maxidx should be "np" or "npa" * + SUBROUTINE CHECK_ARRAY_INTEGRAL_NX_R8(TheARR, string, maxidx) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE W3GDATMD, only : NSPEC + USE YOWNODEPOOL, only: npa + CHARACTER(*), INTENT(in) :: string + INTEGER, INTENT(in) :: maxidx + REAL, INTENT(in) :: TheARR(NSPEC, npa) + REAL*8 :: TheARR_red(npa) + ! LOGICAL :: FULL_NSPEC = .FALSE. + ! LOGICAL :: PrintMinISP = .FALSE. + ! LOGICAL :: LocalizeMaximum = .FALSE. + ! LOGICAL :: CheckUncovered = .FALSE. + ! LOGICAL :: PrintFullValue = .FALSE. + LOGICAL :: FULL_NSPEC = .TRUE. + LOGICAL :: PrintMinISP = .TRUE. + LOGICAL :: LocalizeMaximum = .TRUE. + LOGICAL :: CheckUncovered = .TRUE. + LOGICAL :: PrintFullValue = .TRUE. + IF (FULL_NSPEC) THEN + CALL CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(TheARR, string, maxidx, PrintMinISP, LocalizeMaximum) + ELSE + DO IP=1,npa + TheARR_red(IP) = SUM(ABS(TheArr(:,IP))) + END DO + CALL SCAL_INTEGRAL_PRINT_GENERAL(TheARR_red, string, maxidx, CheckUncovered, PrintFullValue) + END IF + END SUBROUTINE CHECK_ARRAY_INTEGRAL_NX_R8 + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Explicit LF-FCT scheme + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only :NK, NTH, NX, IEN, CLATS, MAPSF, TRIA - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3WDATMD, only: TIME - USE W3ADATMD, only: CG, ITER, CFLXYMAX - USE W3ODATMD, only: NDSE, NDST, FLBPI, NBI, ISBPI, BBPI0, BBPIN - USE W3TIMEMD, only: DSEC21 - USE W3GDATMD, only: NSEAL, IOBPA + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only :NK, NTH, NX, IEN, CLATS, MAPSF, TRIA + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3WDATMD, only: TIME + USE W3ADATMD, only: CG, ITER, CFLXYMAX + USE W3ODATMD, only: NDSE, NDST, FLBPI, NBI, ISBPI, BBPI0, BBPIN + USE W3TIMEMD, only: DSEC21 + USE W3GDATMD, only: NSEAL, IOBPA #ifdef W3_REF1 USE W3GDATMD, only: REFPARS #endif - USE W3ADATMD, only: MPI_COMM_WCMP - use yowElementpool, only: ne, INE - use YOWNODEPOOL, only: PDLIB_SI, PDLIB_IEN, PDLIB_TRIA - use YOWNODEPOOL, only: iplg, npa - use yowDatapool, only: rtype - USE W3ODATMD, only : IAPROC - USE MPI, only : MPI_MIN - USE W3PARALL, only : INIT_GET_JSEA_ISPROC, ONESIXTH, ZERO - USE W3PARALL, only : THR - use yowExchangeModule, only : PDLIB_exchange1DREAL - USE yowRankModule, only : IPGL_npa - IMPLICIT NONE - INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, - ! actual Wave Direction - REAL, INTENT(IN) :: DT ! Time intervall for which the - ! advection should be computed - ! for the given velocity field - REAL, INTENT(IN) :: C(npa,2) ! Velocity field in its - ! X- and Y- Components, - REAL, INTENT(INOUT) :: AC(npa) ! Wave Action before and after - ! advection - REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation - ! coefficients for boundary - ! condition - LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of - ! the max. Global Time step - INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK - INTEGER :: IBI, NI(3), JX - REAL :: RD1, RD2 - REAL :: UTILDE - REAL :: SUMTHETA - REAL :: FL1, FL2, FL3 - REAL :: FT, CFLXY - REAL :: FL11, FL12, FL21, FL22, FL31, FL32 - REAL :: FL111, FL112, FL211, FL212, FL311, FL312 - REAL :: DTSI(npa), U(npa), DT4AI, TMP1 - REAL :: DTMAX_GL, DTMAX, DTMAXEXP, REST - REAL :: LAMBDA(2), KTMP(3), TMP(3) - REAL :: BET1(3), BETAHAT(3) - REAL :: THETA_L(3,NE), THETA_H(3,NE), THETA_ACE(3,NE), UTMP(3) - REAL :: WII(2,npa), UL(npa), USTARI(2,npa) - REAL :: PM(npa), PP(npa), UIM(npa), UIP(npa) - REAL :: KELEM(3,NE), FLALL(3,NE) - REAL :: KKSUM(npa), ST(npa), BETA - REAL :: NM(NE) - INTEGER :: ISproc, IP_glob, JSEA, ierr - REAL :: eScal + USE W3ADATMD, only: MPI_COMM_WCMP + use yowElementpool, only: ne, INE + use YOWNODEPOOL, only: PDLIB_SI, PDLIB_IEN, PDLIB_TRIA + use YOWNODEPOOL, only: iplg, npa + use yowDatapool, only: rtype + USE W3ODATMD, only : IAPROC + USE MPI, only : MPI_MIN + USE W3PARALL, only : INIT_GET_JSEA_ISPROC, ONESIXTH, ZERO + USE W3PARALL, only : THR + use yowExchangeModule, only : PDLIB_exchange1DREAL + USE yowRankModule, only : IPGL_npa + IMPLICIT NONE + INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, + ! actual Wave Direction + REAL, INTENT(IN) :: DT ! Time intervall for which the + ! advection should be computed + ! for the given velocity field + REAL, INTENT(IN) :: C(npa,2) ! Velocity field in its + ! X- and Y- Components, + REAL, INTENT(INOUT) :: AC(npa) ! Wave Action before and after + ! advection + REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation + ! coefficients for boundary + ! condition + LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of + ! the max. Global Time step + INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK + INTEGER :: IBI, NI(3), JX + REAL :: RD1, RD2 + REAL :: UTILDE + REAL :: SUMTHETA + REAL :: FL1, FL2, FL3 + REAL :: FT, CFLXY + REAL :: FL11, FL12, FL21, FL22, FL31, FL32 + REAL :: FL111, FL112, FL211, FL212, FL311, FL312 + REAL :: DTSI(npa), U(npa), DT4AI, TMP1 + REAL :: DTMAX_GL, DTMAX, DTMAXEXP, REST + REAL :: LAMBDA(2), KTMP(3), TMP(3) + REAL :: BET1(3), BETAHAT(3) + REAL :: THETA_L(3,NE), THETA_H(3,NE), THETA_ACE(3,NE), UTMP(3) + REAL :: WII(2,npa), UL(npa), USTARI(2,npa) + REAL :: PM(npa), PP(npa), UIM(npa), UIP(npa) + REAL :: KELEM(3,NE), FLALL(3,NE) + REAL :: KKSUM(npa), ST(npa), BETA + REAL :: NM(NE) + INTEGER :: ISproc, IP_glob, JSEA, ierr + REAL :: eScal #ifdef W3_REF1 - INTEGER(KIND=1) :: IOBPDR_LOC(NPA) + INTEGER(KIND=1) :: IOBPDR_LOC(NPA) #endif - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - DTMAX = DBLE(10.E10) + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + DTMAX = DBLE(10.E10) #ifdef W3_REF1 - IOBPDR_LOC(:)=(1-IOBP_LOC(:))*(1-IOBPD_LOC(ITH,:)) -#endif + IOBPDR_LOC(:)=(1-IOBP_LOC(:))*(1-IOBPD_LOC(ITH,:)) +#endif + DO IE = 1, NE + I1 = INE(1,IE) ! Index of the Element Nodes + I2 = INE(2,IE) + I3 = INE(3,IE) + LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction + LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) + KELEM(1,IE) = LAMBDA(1) * PDLIB_IEN(1,IE) + LAMBDA(2) * PDLIB_IEN(2,IE) ! K-Values - so called Flux Jacobians + KELEM(2,IE) = LAMBDA(1) * PDLIB_IEN(3,IE) + LAMBDA(2) * PDLIB_IEN(4,IE) + KELEM(3,IE) = LAMBDA(1) * PDLIB_IEN(5,IE) + LAMBDA(2) * PDLIB_IEN(6,IE) + KTMP = KELEM(:,IE) ! Copy + NM(IE) = - 1.D0/MIN(-THR,SUM(MIN(ZERO,KTMP))) ! N-Values + FL11 = C(I2,1) * PDLIB_IEN(1,IE) + C(I2,2) * PDLIB_IEN(2,IE) ! Weights for Simpson Integration + FL12 = C(I3,1) * PDLIB_IEN(1,IE) + C(I3,2) * PDLIB_IEN(2,IE) + FL21 = C(I3,1) * PDLIB_IEN(3,IE) + C(I3,2) * PDLIB_IEN(4,IE) + FL22 = C(I1,1) * PDLIB_IEN(3,IE) + C(I1,2) * PDLIB_IEN(4,IE) + FL31 = C(I1,1) * PDLIB_IEN(5,IE) + C(I1,2) * PDLIB_IEN(6,IE) + FL32 = C(I2,1) * PDLIB_IEN(5,IE) + C(I2,2) * PDLIB_IEN(6,IE) + FL111 = 2.d0*FL11+FL12 + FL112 = 2.d0*FL12+FL11 + FL211 = 2.d0*FL21+FL22 + FL212 = 2.d0*FL22+FL21 + FL311 = 2.d0*FL31+FL32 + FL312 = 2.d0*FL32+FL31 + FLALL(1,IE) = (FL311 + FL212)! * ONESIXTH + KELEM(1,IE) + FLALL(2,IE) = (FL111 + FL312)! * ONESIXTH + KELEM(2,IE) + FLALL(3,IE) = (FL211 + FL112)! * ONESIXTH + KELEM(3,IE) + END DO + ! If the current field or water level changes estimate the iteration + ! number based on the new flow field and the CFL number of the scheme + IF (LCALC) THEN + KKSUM = ZERO DO IE = 1, NE - I1 = INE(1,IE) ! Index of the Element Nodes - I2 = INE(2,IE) - I3 = INE(3,IE) - LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction - LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) - KELEM(1,IE) = LAMBDA(1) * PDLIB_IEN(1,IE) + LAMBDA(2) * PDLIB_IEN(2,IE) ! K-Values - so called Flux Jacobians - KELEM(2,IE) = LAMBDA(1) * PDLIB_IEN(3,IE) + LAMBDA(2) * PDLIB_IEN(4,IE) - KELEM(3,IE) = LAMBDA(1) * PDLIB_IEN(5,IE) + LAMBDA(2) * PDLIB_IEN(6,IE) - KTMP = KELEM(:,IE) ! Copy - NM(IE) = - 1.D0/MIN(-THR,SUM(MIN(ZERO,KTMP))) ! N-Values - FL11 = C(I2,1) * PDLIB_IEN(1,IE) + C(I2,2) * PDLIB_IEN(2,IE) ! Weights for Simpson Integration - FL12 = C(I3,1) * PDLIB_IEN(1,IE) + C(I3,2) * PDLIB_IEN(2,IE) - FL21 = C(I3,1) * PDLIB_IEN(3,IE) + C(I3,2) * PDLIB_IEN(4,IE) - FL22 = C(I1,1) * PDLIB_IEN(3,IE) + C(I1,2) * PDLIB_IEN(4,IE) - FL31 = C(I1,1) * PDLIB_IEN(5,IE) + C(I1,2) * PDLIB_IEN(6,IE) - FL32 = C(I2,1) * PDLIB_IEN(5,IE) + C(I2,2) * PDLIB_IEN(6,IE) - FL111 = 2.d0*FL11+FL12 - FL112 = 2.d0*FL12+FL11 - FL211 = 2.d0*FL21+FL22 - FL212 = 2.d0*FL22+FL21 - FL311 = 2.d0*FL31+FL32 - FL312 = 2.d0*FL32+FL31 - FLALL(1,IE) = (FL311 + FL212)! * ONESIXTH + KELEM(1,IE) - FLALL(2,IE) = (FL111 + FL312)! * ONESIXTH + KELEM(2,IE) - FLALL(3,IE) = (FL211 + FL112)! * ONESIXTH + KELEM(3,IE) + NI = INE(:,IE) + KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) + END DO ! IE + DO IP = 1, npa + DTMAXEXP = PDLIB_SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP_LOC(IP)) + DTMAX = MIN( DTMAX, DTMAXEXP) + CFLXYMAX(IP) = MAX(CFLXYMAX(IP),DBLE(DT)/DTMAXEXP) END DO -! If the current field or water level changes estimate the iteration -! number based on the new flow field and the CFL number of the scheme - IF (LCALC) THEN - KKSUM = ZERO - DO IE = 1, NE - NI = INE(:,IE) - KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) - END DO ! IE - DO IP = 1, npa - DTMAXEXP = PDLIB_SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*IOBDP_LOC(IP)) - DTMAX = MIN( DTMAX, DTMAXEXP) - CFLXYMAX(IP) = MAX(CFLXYMAX(IP),DBLE(DT)/DTMAXEXP) - END DO - CALL MPI_ALLREDUCE(DTMAX,DTMAX_GL,1,rtype,MPI_MIN,MPI_COMM_WCMP,ierr) - CFLXY = DBLE(DT)/DTMAX_GL - REST = ABS(MOD(CFLXY,1.0d0)) - IF (REST .LT. THR) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) - ELSE IF (REST .GT. THR .AND. REST .LT. 0.5d0) THEN - ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 + CALL MPI_ALLREDUCE(DTMAX,DTMAX_GL,1,rtype,MPI_MIN,MPI_COMM_WCMP,ierr) + CFLXY = DBLE(DT)/DTMAX_GL + REST = ABS(MOD(CFLXY,1.0d0)) + IF (REST .LT. THR) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + ELSE IF (REST .GT. THR .AND. REST .LT. 0.5d0) THEN + ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 + ELSE + ITER(IK,ITH) = ABS(NINT(CFLXY)) + END IF + END IF ! LCALC + DT4AI = DBLE(DT)/DBLE(ITER(IK,ITH)) + DTSI(:) = DT4AI/PDLIB_SI(:) ! Some precalculations for the time integration. + + U = DBLE(AC) ! correct + UL = U + DO IT = 1, ITER(IK,ITH) + ST = ZERO + DO IE = 1, NE + NI = INE(:,IE) + UTMP = U(NI) + FT = - ONESIXTH*DOT_PRODUCT(UTMP,FLALL(:,IE)) + TMP = MAX(ZERO,KELEM(:,IE)) + UTILDE = NM(IE) * ( DOT_PRODUCT(TMP,UTMP) - FT ) + THETA_L(:,IE) = TMP * ( UTMP - UTILDE ) + IF (ABS(FT) .GT. THR) THEN + BET1(:) = THETA_L(:,IE)/FT + IF (ANY( BET1 .LT. 0.0d0) ) THEN + BETAHAT(1) = BET1(1) + 0.5d0 * BET1(2) + BETAHAT(2) = BET1(2) + 0.5d0 * BET1(3) + BETAHAT(3) = BET1(3) + 0.5d0 * BET1(1) + BET1(1) = MAX(ZERO,MIN(BETAHAT(1),1.d0-BETAHAT(2),1.d0)) + BET1(2) = MAX(ZERO,MIN(BETAHAT(2),1.d0-BETAHAT(3),1.d0)) + BET1(3) = MAX(ZERO,MIN(BETAHAT(3),1.d0-BETAHAT(1),1.d0)) + THETA_L(:,IE) = FT * BET1 + END IF ELSE - ITER(IK,ITH) = ABS(NINT(CFLXY)) + THETA_L(:,IE) = ZERO END IF - END IF ! LCALC - DT4AI = DBLE(DT)/DBLE(ITER(IK,ITH)) - DTSI(:) = DT4AI/PDLIB_SI(:) ! Some precalculations for the time integration. - - U = DBLE(AC) ! correct - UL = U - DO IT = 1, ITER(IK,ITH) - ST = ZERO - DO IE = 1, NE - NI = INE(:,IE) - UTMP = U(NI) - FT = - ONESIXTH*DOT_PRODUCT(UTMP,FLALL(:,IE)) - TMP = MAX(ZERO,KELEM(:,IE)) - UTILDE = NM(IE) * ( DOT_PRODUCT(TMP,UTMP) - FT ) - THETA_L(:,IE) = TMP * ( UTMP - UTILDE ) - IF (ABS(FT) .GT. THR) THEN - BET1(:) = THETA_L(:,IE)/FT - IF (ANY( BET1 .LT. 0.0d0) ) THEN - BETAHAT(1) = BET1(1) + 0.5d0 * BET1(2) - BETAHAT(2) = BET1(2) + 0.5d0 * BET1(3) - BETAHAT(3) = BET1(3) + 0.5d0 * BET1(1) - BET1(1) = MAX(ZERO,MIN(BETAHAT(1),1.d0-BETAHAT(2),1.d0)) - BET1(2) = MAX(ZERO,MIN(BETAHAT(2),1.d0-BETAHAT(3),1.d0)) - BET1(3) = MAX(ZERO,MIN(BETAHAT(3),1.d0-BETAHAT(1),1.d0)) - THETA_L(:,IE) = FT * BET1 - END IF - ELSE - THETA_L(:,IE) = ZERO - END IF -! THETA_H(:,IE) = (ONETHIRD+DT4AI/(2.d0*PDLIB_TRIA(IE)) * KELEM(:,IE))*FT ! LAX-WENDROFF - THETA_H(:,IE) = (1./3.+2./3.* KELEM(:,IE)/SUM(ABS(KELEM(:,IE))) )*FT ! CENTRAL SCHEME - ! Antidiffusive residual according to the higher order nonmonotone scheme - THETA_ACE(:,IE) = ((THETA_H(:,IE) - THETA_L(:,IE))) * DT4AI/PDLIB_SI(NI) - ST(NI) = ST(NI) + THETA_L(:,IE)*DT4AI/PDLIB_SI(NI) - END DO + ! THETA_H(:,IE) = (ONETHIRD+DT4AI/(2.d0*PDLIB_TRIA(IE)) * KELEM(:,IE))*FT ! LAX-WENDROFF + THETA_H(:,IE) = (1./3.+2./3.* KELEM(:,IE)/SUM(ABS(KELEM(:,IE))) )*FT ! CENTRAL SCHEME + ! Antidiffusive residual according to the higher order nonmonotone scheme + THETA_ACE(:,IE) = ((THETA_H(:,IE) - THETA_L(:,IE))) * DT4AI/PDLIB_SI(NI) + ST(NI) = ST(NI) + THETA_L(:,IE)*DT4AI/PDLIB_SI(NI) + END DO - DO IP = 1, npa - UL(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA_LOC(IP)))*IOBPD_LOC(ITH,IP)*IOBDP_LOC(IP) + DO IP = 1, npa + UL(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA_LOC(IP)))*IOBPD_LOC(ITH,IP)*IOBDP_LOC(IP) #ifdef W3_REF1 - IF (REFPARS(3).LT.0.5.AND.IOBPD_LOC(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values + IF (REFPARS(3).LT.0.5.AND.IOBPD_LOC(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values #endif - END DO + END DO - USTARI(1,:) = MAX(UL,U) - USTARI(2,:) = MIN(UL,U) - UIP = -THR - UIM = THR - PP = ZERO - PM = ZERO - DO IE = 1, NE - NI = INE(:,IE) - PP(NI) = PP(NI) + MAX( THR, -THETA_ACE(:,IE)) - PM(NI) = PM(NI) + MIN( -THR, -THETA_ACE(:,IE)) - UIP(NI) = MAX (UIP(NI), MAXVAL( USTARI(1,NI) )) - UIM(NI) = MIN (UIM(NI), MINVAL( USTARI(2,NI) )) - END DO - WII(1,:) = MIN(1.0d0,(UIP-UL) / PP) - WII(2,:) = MIN(1.0d0,(UIM-UL) / PM) - ST = ZERO - DO IE = 1, NE - DO I = 1, 3 - IP = INE(I,IE) - IF (-THETA_ACE(I,IE) .GE. 0.) THEN - TMP(I) = WII(1,IP) - ELSE - TMP(I) = WII(2,IP) - END IF - END DO - BETA = MINVAL(TMP) - NI = INE(:,IE) - ST(NI) = ST(NI) + BETA * THETA_ACE(:,IE) - END DO -! -! IOBPD is the switch for removing energy coming from the shoreline -! - DO IP = 1,npa - U(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA_LOC(IP)))*IOBPD_LOC(ITH,IP)*IOBDP_LOC(IP) -#ifdef W3_REF1 - IF (REFPARS(3).LT.0.5.AND.IOBPD_LOC(ITH,IP).EQ.0.AND.IOBPA_LOC(IP).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values -#endif - END DO - AC = REAL(U) -! -! 5 Update open boundaries ... this should be implemented differently ... it is better to omit any if clause in this loop ... -! - IF ( FLBPI ) THEN - RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) - RD2=RD20 - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 + USTARI(1,:) = MAX(UL,U) + USTARI(2,:) = MIN(UL,U) + UIP = -THR + UIM = THR + PP = ZERO + PM = ZERO + DO IE = 1, NE + NI = INE(:,IE) + PP(NI) = PP(NI) + MAX( THR, -THETA_ACE(:,IE)) + PM(NI) = PM(NI) + MIN( -THR, -THETA_ACE(:,IE)) + UIP(NI) = MAX (UIP(NI), MAXVAL( USTARI(1,NI) )) + UIM(NI) = MIN (UIM(NI), MINVAL( USTARI(2,NI) )) + END DO + WII(1,:) = MIN(1.0d0,(UIP-UL) / PP) + WII(2,:) = MIN(1.0d0,(UIM-UL) / PM) + ST = ZERO + DO IE = 1, NE + DO I = 1, 3 + IP = INE(I,IE) + IF (-THETA_ACE(I,IE) .GE. 0.) THEN + TMP(I) = WII(1,IP) ELSE - RD1 = 0. - RD2 = 1. + TMP(I) = WII(2,IP) END IF -! -! NB: this treatment of the open boundary (time interpolation) is different from -! the constant boundary in the structured grids ... which restores the boundary -! to the initial value: IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) -! Why this difference ? -! - DO IBI=1, NBI - IP_glob = MAPSF(ISBPI(IBI),1) - JX=IPGL_npa(IP_glob) - IF (JX .gt. 0) THEN - AC(JX) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) - END IF - ENDDO - END IF - CALL PDLIB_exchange1DREAL(AC) - U = DBLE(AC) - END DO ! IT -! CALL EXTCDE ( 99 ) -!/ -!/ End of W3XYPFSN --------------------------------------------------- / -!/ - END SUBROUTINE PDLIB_W3XYPFSFCT2 -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_W3XYPUG_BLOCK_IMPLICIT(IMOD, FACX, FACY, DTG, VGX, VGY) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Block Explicit N-Scheme -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3ODATMD, only: IAPROC - USE W3GDATMD, only: B_JGS_USE_JACOBI - IMPLICIT NONE - INTEGER, INTENT(IN) :: IMOD - REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY -#ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'B_JGS_USE_JACOBI=', B_JGS_USE_JACOBI - FLUSH(740+IAPROC) -#endif - IF (B_JGS_USE_JACOBI) THEN - CALL PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(IMOD, FACX, FACY, DTG, VGX, VGY) - RETURN - END IF - WRITE(*,*) 'Error: You need to use with JGS_USE_JACOBI' - STOP 'Correct your implicit solver options' -!/ -!/ End of W3XYPFSN --------------------------------------------------- / -!/ - END SUBROUTINE PDLIB_W3XYPUG_BLOCK_IMPLICIT -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_W3XYPUG_BLOCK_EXPLICIT(IMOD, FACX, FACY, DTG, VGX, VGY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Driver for block explicit routine -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3ODATMD, only: IAPROC - USE W3GDATMD, only: B_JGS_USE_JACOBI - IMPLICIT NONE - INTEGER, INTENT(IN) :: IMOD - REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY - Print *, 'Before PDLIB_EXPLICIT_BLOCK' - CALL PDLIB_EXPLICIT_BLOCK(IMOD, FACX, FACY, DTG, VGX, VGY) -!/ -!/ End of W3XYPFSN ----------------------------------------------------- / -!/ - END SUBROUTINE PDLIB_W3XYPUG_BLOCK_EXPLICIT -!/ --------------------------------------------------------------------- / - SUBROUTINE PRINT_WN_STATISTIC(string) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - - USE W3ODATMD, only : IAPROC - USE W3GDATMD, only: NK - USE W3ADATMD, only: WN - USE W3GDATMD, only: NSEAL - USE YOWNODEPOOL, only: NP - IMPLICIT NONE - CHARACTER(*), INTENT(in) :: string - REAL TotalSumDMM, eDMM, sumDMM - INTEGER IP, IK, ISEA - WRITE(740+IAPROC,*) 'PRINT_WN_STATISTIC' - TotalSumDMM=0 - DO ISEA=1,NSEAL - sumDMM=0 - DO IK=0, NK - eDMM = WN(IK+1,ISEA) - WN(IK,ISEA) - sumDMM=sumDMM + abs(eDMM) - END DO - IF (ISEA .eq. 1) THEN - WRITE(740+IAPROC,*) 'ISEA=', ISEA - WRITE(740+IAPROC,*) 'sumDMM=', sumDMM - END IF - TotalSumDMM = TotalSumDMM + sumDMM - END DO - WRITE(740+IAPROC,*) 'string=', string - WRITE(740+IAPROC,*) 'TotalSumDMM=', TotalSumDMM - FLUSH(740+IAPROC) -!/ -!/ End of W3XYPFSN --------------------------------------------------- / -!/ - END SUBROUTINE PRINT_WN_STATISTIC -!/ ------------------------------------------------------------------- / - SUBROUTINE WRITE_VAR_TO_TEXT_FILE(TheArr, eFile) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only : NK, NTH - USE W3WDATMD, only : VA - USE W3GDATMD, only : NSPEC, NX, NY, NSEAL, MAPFS - USE W3ADATMD, only : MPI_COMM_WCMP - USE W3GDATMD, only : GTYPE, UNGTYPE - USE W3ODATMD, only : IAPROC, NAPROC, NTPROC - use yowDatapool, only: rtype, istatus - USE YOWNODEPOOL, only: npa, iplg, np - USE W3PARALL, only: INIT_GET_ISEA - IMPLICIT NONE - INCLUDE "mpif.h" - CHARACTER(*), INTENT(in) :: eFile - REAL, INTENT(in) :: TheARR(NSPEC, npa) - ! - REAL Vcoll(NSPEC,NX), VcollExp(NSPEC*NX), rVect(NSPEC*NX) - REAL CoherencyError, eVal1, eVal2, eErr - INTEGER rStatus(NX), Status(NX) - INTEGER JSEA, ISEA, iProc, I, IX, ierr, ISP, IP, IP_glob - INTEGER nbIncorr - INTEGER ITH, IK - INTEGER fhndl - REAL eSum - IF (IAPROC .gt. NAPROC) THEN - RETURN - END IF - IF (GTYPE .ne. UNGTYPE) THEN - RETURN - END IF - VcollExp=0 - Status=0 - DO IP=1,np - IP_glob=iplg(IP) - DO ISP=1,NSPEC - VcollExp(ISP+NSPEC*(IP_glob-1))=TheARR(ISP,IP) END DO - Status(IP_glob)=1 + BETA = MINVAL(TMP) + NI = INE(:,IE) + ST(NI) = ST(NI) + BETA * THETA_ACE(:,IE) END DO ! - ! Now find global arrays + ! IOBPD is the switch for removing energy coming from the shoreline ! - CoherencyError=0 - IF (IAPROC .eq. 1) THEN - DO iProc=2,NAPROC - CALL MPI_RECV(rVect ,NSPEC*NX,MPI_DOUBLE , iProc-1, 37, MPI_COMM_WCMP, istatus, ierr) - CALL MPI_RECV(rStatus,NX ,MPI_INTEGER, iProc-1, 43, MPI_COMM_WCMP, istatus, ierr) - DO I=1,NX - IF (rStatus(I) .eq. 1) THEN - DO ISP=1,NSPEC - eVal1=VcollExp(ISP+NSPEC*(I-1)) - eVal2=rVect(ISP+NSPEC*(I-1)) - VcollExp(ISP+NSPEC*(I-1))=rVect(ISP+NSPEC*(I-1)) - IF (Status(I) .eq. 1) THEN - eErr=abs(eVal1 - eVal2) - CoherencyError = CoherencyError + eErr - ELSE - VcollExp(ISP+NSPEC*(I-1))=eVal2 - END IF - END DO - Status(I)=1 - END IF - END DO - END DO - ELSE - CALL MPI_SEND(VcollExp,NSPEC*NX,MPI_DOUBLE , 0, 37, MPI_COMM_WCMP, ierr) - CALL MPI_SEND(Status ,NX ,MPI_INTEGER, 0, 43, MPI_COMM_WCMP, ierr) + DO IP = 1,npa + U(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA_LOC(IP)))*IOBPD_LOC(ITH,IP)*IOBDP_LOC(IP) +#ifdef W3_REF1 + IF (REFPARS(3).LT.0.5.AND.IOBPD_LOC(ITH,IP).EQ.0.AND.IOBPA_LOC(IP).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values +#endif + END DO + AC = REAL(U) + ! + ! 5 Update open boundaries ... this should be implemented differently ... it is better to omit any if clause in this loop ... + ! + IF ( FLBPI ) THEN + RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) + RD2=RD20 + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. + END IF + ! + ! NB: this treatment of the open boundary (time interpolation) is different from + ! the constant boundary in the structured grids ... which restores the boundary + ! to the initial value: IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) + ! Why this difference ? + ! + DO IBI=1, NBI + IP_glob = MAPSF(ISBPI(IBI),1) + JX=IPGL_npa(IP_glob) + IF (JX .gt. 0) THEN + AC(JX) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) + END IF + ENDDO END IF - IF (IAPROC .eq. 1) THEN - DO I=1,NX - DO ISP=1,NSPEC - Vcoll(ISP,I)=VcollExp(ISP + NSPEC*(I-1)) - END DO - END DO - OPEN(fhndl, FILE=eFile) - DO IX=1,NX - eSum=sum(VColl(:,IX)) - WRITE(fhndl,*) 'IX=', IX, 'eSum=', eSum - END DO - CLOSE(fhndl) + CALL PDLIB_exchange1DREAL(AC) + U = DBLE(AC) + END DO ! IT + ! CALL EXTCDE ( 99 ) + !/ + !/ End of W3XYPFSN --------------------------------------------------- / + !/ + END SUBROUTINE PDLIB_W3XYPFSFCT2 + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_W3XYPUG_BLOCK_IMPLICIT(IMOD, FACX, FACY, DTG, VGX, VGY) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Block Explicit N-Scheme + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, only: STRACE +#endif + ! + USE W3ODATMD, only: IAPROC + USE W3GDATMD, only: B_JGS_USE_JACOBI + IMPLICIT NONE + INTEGER, INTENT(IN) :: IMOD + REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'B_JGS_USE_JACOBI=', B_JGS_USE_JACOBI + FLUSH(740+IAPROC) +#endif + IF (B_JGS_USE_JACOBI) THEN + CALL PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(IMOD, FACX, FACY, DTG, VGX, VGY) + RETURN + END IF + WRITE(*,*) 'Error: You need to use with JGS_USE_JACOBI' + STOP 'Correct your implicit solver options' + !/ + !/ End of W3XYPFSN --------------------------------------------------- / + !/ + END SUBROUTINE PDLIB_W3XYPUG_BLOCK_IMPLICIT + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_W3XYPUG_BLOCK_EXPLICIT(IMOD, FACX, FACY, DTG, VGX, VGY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Driver for block explicit routine + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, only: STRACE +#endif + ! + USE W3ODATMD, only: IAPROC + USE W3GDATMD, only: B_JGS_USE_JACOBI + IMPLICIT NONE + INTEGER, INTENT(IN) :: IMOD + REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY + Print *, 'Before PDLIB_EXPLICIT_BLOCK' + CALL PDLIB_EXPLICIT_BLOCK(IMOD, FACX, FACY, DTG, VGX, VGY) + !/ + !/ End of W3XYPFSN ----------------------------------------------------- / + !/ + END SUBROUTINE PDLIB_W3XYPUG_BLOCK_EXPLICIT + !/ --------------------------------------------------------------------- / + SUBROUTINE PRINT_WN_STATISTIC(string) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, only: STRACE +#endif + ! + + USE W3ODATMD, only : IAPROC + USE W3GDATMD, only: NK + USE W3ADATMD, only: WN + USE W3GDATMD, only: NSEAL + USE YOWNODEPOOL, only: NP + IMPLICIT NONE + CHARACTER(*), INTENT(in) :: string + REAL TotalSumDMM, eDMM, sumDMM + INTEGER IP, IK, ISEA + WRITE(740+IAPROC,*) 'PRINT_WN_STATISTIC' + TotalSumDMM=0 + DO ISEA=1,NSEAL + sumDMM=0 + DO IK=0, NK + eDMM = WN(IK+1,ISEA) - WN(IK,ISEA) + sumDMM=sumDMM + abs(eDMM) + END DO + IF (ISEA .eq. 1) THEN + WRITE(740+IAPROC,*) 'ISEA=', ISEA + WRITE(740+IAPROC,*) 'sumDMM=', sumDMM END IF -!/ -!/ End of W3XYPFSN ----------------------------------------------------- / -!/ - END SUBROUTINE WRITE_VAR_TO_TEXT_FILE -!/ ------------------------------------------------------------------- / - SUBROUTINE PrintTotalOffContrib(string) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Source code for parallel debugging -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + TotalSumDMM = TotalSumDMM + sumDMM + END DO + WRITE(740+IAPROC,*) 'string=', string + WRITE(740+IAPROC,*) 'TotalSumDMM=', TotalSumDMM + FLUSH(740+IAPROC) + !/ + !/ End of W3XYPFSN --------------------------------------------------- / + !/ + END SUBROUTINE PRINT_WN_STATISTIC + !/ ------------------------------------------------------------------- / + SUBROUTINE WRITE_VAR_TO_TEXT_FILE(TheArr, eFile) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE YOWNODEPOOL, only: PDLIB_CCON, NPA, PDLIB_I_DIAG, PDLIB_JA, PDLIB_IA_P - USE W3GDATMD, only: NSPEC - USE W3ODATMD, only : IAPROC - IMPLICIT NONE - CHARACTER(*), INTENT(in) :: string - INTEGER J, IP, JP, I, ISP - REAL TheSum1, TheSum2 - J = 0 - TheSum1=0 - DO IP = 1, npa - DO I = 1, PDLIB_CCON(IP) - J = J + 1 - IF (J .ne. PDLIB_I_DIAG(IP)) THEN + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only : NK, NTH + USE W3WDATMD, only : VA + USE W3GDATMD, only : NSPEC, NX, NY, NSEAL, MAPFS + USE W3ADATMD, only : MPI_COMM_WCMP + USE W3GDATMD, only : GTYPE, UNGTYPE + USE W3ODATMD, only : IAPROC, NAPROC, NTPROC + use yowDatapool, only: rtype, istatus + USE YOWNODEPOOL, only: npa, iplg, np + USE W3PARALL, only: INIT_GET_ISEA + IMPLICIT NONE + INCLUDE "mpif.h" + CHARACTER(*), INTENT(in) :: eFile + REAL, INTENT(in) :: TheARR(NSPEC, npa) + ! + REAL Vcoll(NSPEC,NX), VcollExp(NSPEC*NX), rVect(NSPEC*NX) + REAL CoherencyError, eVal1, eVal2, eErr + INTEGER rStatus(NX), Status(NX) + INTEGER JSEA, ISEA, iProc, I, IX, ierr, ISP, IP, IP_glob + INTEGER nbIncorr + INTEGER ITH, IK + INTEGER fhndl + REAL eSum + IF (IAPROC .gt. NAPROC) THEN + RETURN + END IF + IF (GTYPE .ne. UNGTYPE) THEN + RETURN + END IF + VcollExp=0 + Status=0 + DO IP=1,np + IP_glob=iplg(IP) + DO ISP=1,NSPEC + VcollExp(ISP+NSPEC*(IP_glob-1))=TheARR(ISP,IP) + END DO + Status(IP_glob)=1 + END DO + ! + ! Now find global arrays + ! + CoherencyError=0 + IF (IAPROC .eq. 1) THEN + DO iProc=2,NAPROC + CALL MPI_RECV(rVect ,NSPEC*NX,MPI_DOUBLE , iProc-1, 37, MPI_COMM_WCMP, istatus, ierr) + CALL MPI_RECV(rStatus,NX ,MPI_INTEGER, iProc-1, 43, MPI_COMM_WCMP, istatus, ierr) + DO I=1,NX + IF (rStatus(I) .eq. 1) THEN DO ISP=1,NSPEC - TheSum1=TheSum1 + abs(ASPAR_JAC(ISP,J)) + eVal1=VcollExp(ISP+NSPEC*(I-1)) + eVal2=rVect(ISP+NSPEC*(I-1)) + VcollExp(ISP+NSPEC*(I-1))=rVect(ISP+NSPEC*(I-1)) + IF (Status(I) .eq. 1) THEN + eErr=abs(eVal1 - eVal2) + CoherencyError = CoherencyError + eErr + ELSE + VcollExp(ISP+NSPEC*(I-1))=eVal2 + END IF END DO + Status(I)=1 END IF END DO END DO - ! - TheSum2=0 - DO IP = 1, npa - DO i = PDLIB_IA_P(IP)+1, PDLIB_IA_P(IP+1) - JP=PDLIB_JA(I) - IF (JP .ne. IP) THEN - DO ISP=1,NSPEC - TheSum2=TheSum2 + abs(ASPAR_JAC(ISP,I)) - END DO - END IF + ELSE + CALL MPI_SEND(VcollExp,NSPEC*NX,MPI_DOUBLE , 0, 37, MPI_COMM_WCMP, ierr) + CALL MPI_SEND(Status ,NX ,MPI_INTEGER, 0, 43, MPI_COMM_WCMP, ierr) + END IF + IF (IAPROC .eq. 1) THEN + DO I=1,NX + DO ISP=1,NSPEC + Vcoll(ISP,I)=VcollExp(ISP + NSPEC*(I-1)) END DO END DO - WRITE(740+IAPROC,'(a,f14.7,f14.7,a,a)') 'TheSum12=', TheSum1, TheSum2, ' ', string - FLUSH(740+IAPROC) -!/ -!/ End of W3XYPFSN --------------------------------------------------- / -!/ - END SUBROUTINE PrintTotalOffContrib -!/ ------------------------------------------------------------------- / - SUBROUTINE COMPUTE_MEAN_PARAM (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute mean prarameter -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + OPEN(fhndl, FILE=eFile) + DO IX=1,NX + eSum=sum(VColl(:,IX)) + WRITE(fhndl,*) 'IX=', IX, 'eSum=', eSum + END DO + CLOSE(fhndl) + END IF + !/ + !/ End of W3XYPFSN ----------------------------------------------------- / + !/ + END SUBROUTINE WRITE_VAR_TO_TEXT_FILE + !/ ------------------------------------------------------------------- / + SUBROUTINE PrintTotalOffContrib(string) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Source code for parallel debugging + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, only: STRACE +#endif + ! + USE YOWNODEPOOL, only: PDLIB_CCON, NPA, PDLIB_I_DIAG, PDLIB_JA, PDLIB_IA_P + USE W3GDATMD, only: NSPEC + USE W3ODATMD, only : IAPROC + IMPLICIT NONE + CHARACTER(*), INTENT(in) :: string + INTEGER J, IP, JP, I, ISP + REAL TheSum1, TheSum2 + J = 0 + TheSum1=0 + DO IP = 1, npa + DO I = 1, PDLIB_CCON(IP) + J = J + 1 + IF (J .ne. PDLIB_I_DIAG(IP)) THEN + DO ISP=1,NSPEC + TheSum1=TheSum1 + abs(ASPAR_JAC(ISP,J)) + END DO + END IF + END DO + END DO + ! + TheSum2=0 + DO IP = 1, npa + DO i = PDLIB_IA_P(IP)+1, PDLIB_IA_P(IP+1) + JP=PDLIB_JA(I) + IF (JP .ne. IP) THEN + DO ISP=1,NSPEC + TheSum2=TheSum2 + abs(ASPAR_JAC(ISP,I)) + END DO + END IF + END DO + END DO + WRITE(740+IAPROC,'(a,f14.7,f14.7,a,a)') 'TheSum12=', TheSum1, TheSum2, ' ', string + FLUSH(740+IAPROC) + !/ + !/ End of W3XYPFSN --------------------------------------------------- / + !/ + END SUBROUTINE PrintTotalOffContrib + !/ ------------------------------------------------------------------- / + SUBROUTINE COMPUTE_MEAN_PARAM (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute mean prarameter + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE + USE W3SERVMD, only: STRACE #endif -! - USE CONSTANTS - USE W3GDATMD, only: NK, NTH, SIG, DDEN, FTE, FTF, FTWN + ! + USE CONSTANTS + USE W3GDATMD, only: NK, NTH, SIG, DDEN, FTE, FTF, FTWN #ifdef W3_T - USE W3ODATMD, only: NDST + USE W3ODATMD, only: NDST #endif #ifdef W3_S - USE W3SERVMD, only: STRACE + USE W3SERVMD, only: STRACE #endif -! - IMPLICIT NONE - REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK) - REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX - INTEGER :: IK, ITH + ! + IMPLICIT NONE + REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK) + REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX + INTEGER :: IK, ITH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: EB(NK), EBAND + REAL :: EB(NK), EBAND #ifdef W3_S - CALL STRACE (IENT, 'W3SPR0') -#endif -! - EMEAN = 0. - FMEAN = 0. - WNMEAN = 0. - AMAX = 0. -! -! 1. Integral over directions -! - DO IK=1, NK - EB(IK) = 0. - DO ITH=1, NTH - EB(IK) = EB(IK) + A(ITH,IK) - AMAX = MAX ( AMAX , A(ITH,IK) ) - END DO - END DO -! -! 2. Integrate over directions -! - DO IK=1, NK - EB(IK) = EB(IK) * DDEN(IK) / CG(IK) - EMEAN = EMEAN + EB(IK) - FMEAN = FMEAN + EB(IK) / SIG(IK) - WNMEAN = WNMEAN + EB(IK) / SQRT(WN(IK)) - END DO -! -! 3. Add tail beyond discrete spectrum -! ( DTH * SIG absorbed in FTxx ) -! - EBAND = EB(NK) / DDEN(NK) - EMEAN = EMEAN + EBAND * FTE - FMEAN = FMEAN + EBAND * FTF - WNMEAN = WNMEAN + EBAND * FTWN -! -! 4. Final processing -! - FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) - WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 -! + CALL STRACE (IENT, 'W3SPR0') +#endif + ! + EMEAN = 0. + FMEAN = 0. + WNMEAN = 0. + AMAX = 0. + ! + ! 1. Integral over directions + ! + DO IK=1, NK + EB(IK) = 0. + DO ITH=1, NTH + EB(IK) = EB(IK) + A(ITH,IK) + AMAX = MAX ( AMAX , A(ITH,IK) ) + END DO + END DO + ! + ! 2. Integrate over directions + ! + DO IK=1, NK + EB(IK) = EB(IK) * DDEN(IK) / CG(IK) + EMEAN = EMEAN + EB(IK) + FMEAN = FMEAN + EB(IK) / SIG(IK) + WNMEAN = WNMEAN + EB(IK) / SQRT(WN(IK)) + END DO + ! + ! 3. Add tail beyond discrete spectrum + ! ( DTH * SIG absorbed in FTxx ) + ! + EBAND = EB(NK) / DDEN(NK) + EMEAN = EMEAN + EBAND * FTE + FMEAN = FMEAN + EBAND * FTF + WNMEAN = WNMEAN + EBAND * FTWN + ! + ! 4. Final processing + ! + FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) + WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 + ! #ifdef W3_T - WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN + WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SPR0 : E,F,WN MEAN ',3E10.3) -#endif -!/ -!/ End of W3SPR0 ----------------------------------------------------- / -!/ - END SUBROUTINE COMPUTE_MEAN_PARAM -!/ ------------------------------------------------------------------- / - SUBROUTINE calcARRAY_JACOBI(DTG,FACX,FACY,VGX,VGY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute matrix coefficients for advection part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +9000 FORMAT (' TEST W3SPR0 : E,F,WN MEAN ',3E10.3) +#endif + !/ + !/ End of W3SPR0 ----------------------------------------------------- / + !/ + END SUBROUTINE COMPUTE_MEAN_PARAM + !/ ------------------------------------------------------------------- / + SUBROUTINE calcARRAY_JACOBI(DTG,FACX,FACY,VGX,VGY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute matrix coefficients for advection part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3GDATMD, only: NSEAL, CLATS - USE W3GDATMD, only: MAPSTA - USE W3WDATMD, only: VA - USE W3ADATMD, only: CG, DW, WN, CX, CY + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3GDATMD, only: NSEAL, CLATS + USE W3GDATMD, only: MAPSTA + USE W3WDATMD, only: VA + USE W3ADATMD, only: CG, DW, WN, CX, CY #ifdef W3_MEMCHECK - USE W3ADATMD, only: MALLINFOS -#endif - USE W3IDATMD, only: FLCUR, FLLEV - USE W3GDATMD, only: ECOS, ESIN, MAPFS - USE W3PARALL, only : ONESIXTH, ZERO, THR - use yowElementpool, only: ne, INE - USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & - PDLIB_CCON, PDLIB_POS_CELL2, PDLIB_IE_CELL2, NP, NPA, & - PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & - PDLIB_I_DIAG, PDLIB_JA - USE W3ODATMD, only : IAPROC - USE W3PARALL, only : ZERO + USE W3ADATMD, only: MALLINFOS +#endif + USE W3IDATMD, only: FLCUR, FLLEV + USE W3GDATMD, only: ECOS, ESIN, MAPFS + USE W3PARALL, only : ONESIXTH, ZERO, THR + use yowElementpool, only: ne, INE + USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & + PDLIB_CCON, PDLIB_POS_CELL2, PDLIB_IE_CELL2, NP, NPA, & + PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & + PDLIB_I_DIAG, PDLIB_JA + USE W3ODATMD, only : IAPROC + USE W3PARALL, only : ZERO #ifdef W3_MEMCHECK - USE MallocInfo_m + USE MallocInfo_m #endif #ifdef W3_DB1 - USE W3SDB1MD - USE W3GDATMD, only: SDBSC + USE W3SDB1MD + USE W3GDATMD, only: SDBSC #endif #ifdef W3_BT1 - USE W3SBT1MD + USE W3SBT1MD #endif #ifdef W3_BT4 - USE W3SBT4MD + USE W3SBT4MD #endif #ifdef W3_BT8 - USE W3SBT8MD + USE W3SBT8MD #endif #ifdef W3_BT9 - USE W3SBT9MD + USE W3SBT9MD #endif #ifdef W3_IC1 - USE W3SIC1MD + USE W3SIC1MD #endif #ifdef W3_IC2 - USE W3SIC2MD + USE W3SIC2MD #endif #ifdef W3_IC3 - USE W3SIC3MD + USE W3SIC3MD #endif #ifdef W3_TR1 - USE W3STR1MD -#endif - implicit none - REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY - INTEGER :: IP, ISP, ISEA, IP_glob - INTEGER :: idx, IS - INTEGER :: I, J, ITH, IK, J2 - INTEGER :: IE, POS, JSEA - INTEGER :: I1, I2, I3, NI(3) - INTEGER :: counter + USE W3STR1MD +#endif + implicit none + REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY + INTEGER :: IP, ISP, ISEA, IP_glob + INTEGER :: idx, IS + INTEGER :: I, J, ITH, IK, J2 + INTEGER :: IE, POS, JSEA + INTEGER :: I1, I2, I3, NI(3) + INTEGER :: counter #ifdef W3_REF1 - INTEGER :: eIOBPDR -#endif - REAL :: DTK, TMP3 - REAL :: LAMBDA(2) - REAL :: FL11, FL12 - REAL :: FL21, FL22 - REAL :: FL31, FL32 - REAL :: CRFS(3), K(3) - REAL :: KP(3,NSPEC,NE) - REAL :: KM(3), CXY(3,2) - REAL :: K1, eSI, eVS, eVD - REAL :: eVal1, eVal2, eVal3 - REAL :: DELTAL(3,NSPEC,NE) - REAL :: NM(NSPEC,NE) - REAL :: TRIA03, SIDT, CCOS, CSIN - REAL :: SPEC(NSPEC), DEPTH + INTEGER :: eIOBPDR +#endif + REAL :: DTK, TMP3 + REAL :: LAMBDA(2) + REAL :: FL11, FL12 + REAL :: FL21, FL22 + REAL :: FL31, FL32 + REAL :: CRFS(3), K(3) + REAL :: KP(3,NSPEC,NE) + REAL :: KM(3), CXY(3,2) + REAL :: K1, eSI, eVS, eVD + REAL :: eVal1, eVal2, eVal3 + REAL :: DELTAL(3,NSPEC,NE) + REAL :: NM(NSPEC,NE) + REAL :: TRIA03, SIDT, CCOS, CSIN + REAL :: SPEC(NSPEC), DEPTH #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'calcARRAY_JACOBI, begin' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'calcARRAY_JACOBI, begin' + FLUSH(740+IAPROC) #endif - I = 0 - IE = 0 - POS = 0 - I1 = 0 - I2 = 0 - I3 = 0 - DTK = 0 - TMP3 = 0 + I = 0 + IE = 0 + POS = 0 + I1 = 0 + I2 = 0 + I3 = 0 + DTK = 0 + TMP3 = 0 #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 0' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) -#endif - - DO IE = 1, NE - I1 = INE(1,IE) - I2 = INE(2,IE) - I3 = INE(3,IE) - NI = INE(:,IE) - DO IS = 1, NSPEC - ITH = 1 + MOD(IS-1,NTH) - IK = 1 + (IS-1)/NTH - CCOS = FACX * ECOS(ITH) - CSIN = FACY * ESIN(ITH) - CXY(:,1) = CCOS * CG(IK,NI) / CLATS(NI) - CXY(:,2) = CSIN * CG(IK,NI) - IF (FLCUR) THEN - CXY(:,1) = CXY(:,1) + FACX * CX(NI)/CLATS(NI) - CXY(:,2) = CXY(:,2) + FACY * CY(NI) - ENDIF + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 0' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) +#endif + + DO IE = 1, NE + I1 = INE(1,IE) + I2 = INE(2,IE) + I3 = INE(3,IE) + NI = INE(:,IE) + DO IS = 1, NSPEC + ITH = 1 + MOD(IS-1,NTH) + IK = 1 + (IS-1)/NTH + CCOS = FACX * ECOS(ITH) + CSIN = FACY * ESIN(ITH) + CXY(:,1) = CCOS * CG(IK,NI) / CLATS(NI) + CXY(:,2) = CSIN * CG(IK,NI) + IF (FLCUR) THEN + CXY(:,1) = CXY(:,1) + FACX * CX(NI)/CLATS(NI) + CXY(:,2) = CXY(:,2) + FACY * CY(NI) + ENDIF #ifdef W3_MGP CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) CXY(:,2) = CXY(:,2) - CCURY*VGY #endif - FL11 = CXY(2,1)*PDLIB_IEN(1,IE)+CXY(2,2)*PDLIB_IEN(2,IE) - FL12 = CXY(3,1)*PDLIB_IEN(1,IE)+CXY(3,2)*PDLIB_IEN(2,IE) - FL21 = CXY(3,1)*PDLIB_IEN(3,IE)+CXY(3,2)*PDLIB_IEN(4,IE) - FL22 = CXY(1,1)*PDLIB_IEN(3,IE)+CXY(1,2)*PDLIB_IEN(4,IE) - FL31 = CXY(1,1)*PDLIB_IEN(5,IE)+CXY(1,2)*PDLIB_IEN(6,IE) - FL32 = CXY(2,1)*PDLIB_IEN(5,IE)+CXY(2,2)*PDLIB_IEN(6,IE) - CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) - CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) - CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) - LAMBDA(1) = ONESIXTH * SUM(CXY(:,1)) - LAMBDA(2) = ONESIXTH * SUM(CXY(:,2)) - K(1) = LAMBDA(1) * PDLIB_IEN(1,IE) + LAMBDA(2) * PDLIB_IEN(2,IE) - K(2) = LAMBDA(1) * PDLIB_IEN(3,IE) + LAMBDA(2) * PDLIB_IEN(4,IE) - K(3) = LAMBDA(1) * PDLIB_IEN(5,IE) + LAMBDA(2) * PDLIB_IEN(6,IE) - KP(:,IS,IE) = MAX(ZERO,K(:)) - DELTAL(:,IS,IE) = CRFS(:) - KP(:,IS,IE) - KM(:) = MIN(ZERO,K(:)) - NM(IS,IE) = 1.d0/MIN(-THR,SUM(KM)) - ENDDO - END DO - - J = 0 - DO IP = 1, npa - IP_glob=iplg(IP) - DO I = 1, PDLIB_CCON(IP) - J = J + 1 - IE = PDLIB_IE_CELL2(I,IP) - POS = PDLIB_POS_CELL2(I,IP) - I1 = PDLIB_POSI(1,J) - I2 = PDLIB_POSI(2,J) - I3 = PDLIB_POSI(3,J) + FL11 = CXY(2,1)*PDLIB_IEN(1,IE)+CXY(2,2)*PDLIB_IEN(2,IE) + FL12 = CXY(3,1)*PDLIB_IEN(1,IE)+CXY(3,2)*PDLIB_IEN(2,IE) + FL21 = CXY(3,1)*PDLIB_IEN(3,IE)+CXY(3,2)*PDLIB_IEN(4,IE) + FL22 = CXY(1,1)*PDLIB_IEN(3,IE)+CXY(1,2)*PDLIB_IEN(4,IE) + FL31 = CXY(1,1)*PDLIB_IEN(5,IE)+CXY(1,2)*PDLIB_IEN(6,IE) + FL32 = CXY(2,1)*PDLIB_IEN(5,IE)+CXY(2,2)*PDLIB_IEN(6,IE) + CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) + CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) + CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) + LAMBDA(1) = ONESIXTH * SUM(CXY(:,1)) + LAMBDA(2) = ONESIXTH * SUM(CXY(:,2)) + K(1) = LAMBDA(1) * PDLIB_IEN(1,IE) + LAMBDA(2) * PDLIB_IEN(2,IE) + K(2) = LAMBDA(1) * PDLIB_IEN(3,IE) + LAMBDA(2) * PDLIB_IEN(4,IE) + K(3) = LAMBDA(1) * PDLIB_IEN(5,IE) + LAMBDA(2) * PDLIB_IEN(6,IE) + KP(:,IS,IE) = MAX(ZERO,K(:)) + DELTAL(:,IS,IE) = CRFS(:) - KP(:,IS,IE) + KM(:) = MIN(ZERO,K(:)) + NM(IS,IE) = 1.d0/MIN(-THR,SUM(KM)) + ENDDO + END DO + + J = 0 + DO IP = 1, npa + IP_glob=iplg(IP) + DO I = 1, PDLIB_CCON(IP) + J = J + 1 + IE = PDLIB_IE_CELL2(I,IP) + POS = PDLIB_POS_CELL2(I,IP) + I1 = PDLIB_POSI(1,J) + I2 = PDLIB_POSI(2,J) + I3 = PDLIB_POSI(3,J) #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'I1=', I1, ' PDLIB_I_DIAG=', PDLIB_I_DIAG(IP) + WRITE(740+IAPROC,*) 'I1=', I1, ' PDLIB_I_DIAG=', PDLIB_I_DIAG(IP) #endif - DO ISP=1,NSPEC - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - K1 = KP(POS,ISP,IE) + DO ISP=1,NSPEC + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + K1 = KP(POS,ISP,IE) #ifdef W3_REF1 - eIOBPDR=(1-IOBP_LOC(IP_glob))*(1-IOBPD_LOC(ITH,IP_glob)) - IF (eIOBPDR .eq. 1) THEN - K1=ZERO - END IF + eIOBPDR=(1-IOBP_LOC(IP_glob))*(1-IOBPD_LOC(ITH,IP_glob)) + IF (eIOBPDR .eq. 1) THEN + K1=ZERO + END IF #endif - TRIA03 = 1./3. * PDLIB_TRIA(IE) - DTK = K1 * DTG * IOBDP_LOC(IP) * (1-IOBPA_LOC(IP)) * IOBPD_LOC(ITH,IP) - B_JAC(ISP,IP) = B_JAC(ISP,IP) + TRIA03 * VA(ISP,IP) * IOBDP_LOC(IP) * (1-IOBPA_LOC(IP)) * IOBPD_LOC(ITH,IP) - TMP3 = DTK * NM(ISP,IE) - IF (FSGEOADVECT) THEN - ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + TRIA03 + DTK - TMP3*DELTAL(POS,ISP,IE) - ASPAR_JAC(ISP,I2) = ASPAR_JAC(ISP,I2) - TMP3*DELTAL(POS_TRICK(POS,1),ISP,IE) - ASPAR_JAC(ISP,I3) = ASPAR_JAC(ISP,I3) - TMP3*DELTAL(POS_TRICK(POS,2),ISP,IE) - ELSE - ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + TRIA03 - END IF - END DO + TRIA03 = 1./3. * PDLIB_TRIA(IE) + DTK = K1 * DTG * IOBDP_LOC(IP) * (1-IOBPA_LOC(IP)) * IOBPD_LOC(ITH,IP) + B_JAC(ISP,IP) = B_JAC(ISP,IP) + TRIA03 * VA(ISP,IP) * IOBDP_LOC(IP) * (1-IOBPA_LOC(IP)) * IOBPD_LOC(ITH,IP) + TMP3 = DTK * NM(ISP,IE) + IF (FSGEOADVECT) THEN + ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + TRIA03 + DTK - TMP3*DELTAL(POS,ISP,IE) + ASPAR_JAC(ISP,I2) = ASPAR_JAC(ISP,I2) - TMP3*DELTAL(POS_TRICK(POS,1),ISP,IE) + ASPAR_JAC(ISP,I3) = ASPAR_JAC(ISP,I3) - TMP3*DELTAL(POS_TRICK(POS,2),ISP,IE) + ELSE + ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + TRIA03 + END IF END DO END DO + END DO #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 1' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) #endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'sum(VA)=', sum(VA) - CALL PrintTotalOffContrib("Offdiag after the geo advection") -#endif -!/ -!/ End of W3XYPFSN ----------------------------------------------------- / -!/ - END SUBROUTINE calcARRAY_JACOBI -!/ ------------------------------------------------------------------- / - SUBROUTINE calcARRAY_JACOBI_VEC(DTG,FACX,FACY,VGX,VGY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute matrix coefficients for advection part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + WRITE(740+IAPROC,*) 'sum(VA)=', sum(VA) + CALL PrintTotalOffContrib("Offdiag after the geo advection") +#endif + !/ + !/ End of W3XYPFSN ----------------------------------------------------- / + !/ + END SUBROUTINE calcARRAY_JACOBI + !/ ------------------------------------------------------------------- / + SUBROUTINE calcARRAY_JACOBI_VEC(DTG,FACX,FACY,VGX,VGY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute matrix coefficients for advection part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3GDATMD, only: NSEAL, CLATS - USE W3GDATMD, only: MAPSTA, SIG - USE W3WDATMD, only: VA - USE W3ADATMD, only: CG, DW, WN, CX, CY + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3GDATMD, only: NSEAL, CLATS + USE W3GDATMD, only: MAPSTA, SIG + USE W3WDATMD, only: VA + USE W3ADATMD, only: CG, DW, WN, CX, CY #ifdef W3_MEMCHECK - USE W3ADATMD, only: MALLINFOS -#endif - USE W3IDATMD, only: FLCUR, FLLEV - USE W3GDATMD, only: ECOS, ESIN, MAPFS - USE W3PARALL, only : ONESIXTH, ZERO, THR - use yowElementpool, only: ne, INE - USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & - PDLIB_IE_CELL2, PDLIB_POS_CELL2, PDLIB_CCON, NP, NPA, & - PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & - PDLIB_I_DIAG, PDLIB_JA, PDLIB_TRIA03, PDLIB_SI - USE W3ODATMD, only : IAPROC - USE W3PARALL, only : ZERO - USE W3DISPMD, only : WAVNU_LOCAL + USE W3ADATMD, only: MALLINFOS +#endif + USE W3IDATMD, only: FLCUR, FLLEV + USE W3GDATMD, only: ECOS, ESIN, MAPFS + USE W3PARALL, only : ONESIXTH, ZERO, THR + use yowElementpool, only: ne, INE + USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & + PDLIB_IE_CELL2, PDLIB_POS_CELL2, PDLIB_CCON, NP, NPA, & + PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & + PDLIB_I_DIAG, PDLIB_JA, PDLIB_TRIA03, PDLIB_SI + USE W3ODATMD, only : IAPROC + USE W3PARALL, only : ZERO + USE W3DISPMD, only : WAVNU_LOCAL #ifdef W3_MEMCHECK - USE MallocInfo_m + USE MallocInfo_m #endif #ifdef W3_DB1 - USE W3SDB1MD - USE W3GDATMD, only: SDBSC + USE W3SDB1MD + USE W3GDATMD, only: SDBSC #endif #ifdef W3_BT1 - USE W3SBT1MD + USE W3SBT1MD #endif #ifdef W3_BT4 - USE W3SBT4MD + USE W3SBT4MD #endif #ifdef W3_BT8 - USE W3SBT8MD + USE W3SBT8MD #endif #ifdef W3_BT9 - USE W3SBT9MD + USE W3SBT9MD #endif #ifdef W3_IC1 - USE W3SIC1MD + USE W3SIC1MD #endif #ifdef W3_IC2 - USE W3SIC2MD + USE W3SIC2MD #endif #ifdef W3_IC3 - USE W3SIC3MD + USE W3SIC3MD #endif #ifdef W3_TR1 - USE W3STR1MD -#endif - implicit none - REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY - INTEGER :: IP, ISP, ISEA, IP_glob - INTEGER :: idx, IS - INTEGER :: I, J, ITH, IK, J2 - INTEGER :: IE, POS, JSEA - INTEGER :: I1, I2, I3, NI(3) - INTEGER :: counter, IB1, IB2 -#ifdef W3_REF1 - INTEGER :: eIOBPDR -#endif - REAL :: DTK, TMP3 - REAL :: LAMBDA(2) - REAL :: FL11, FL12 - REAL :: FL21, FL22 - REAL :: FL31, FL32 - REAL :: CRFS(3), K(3) - REAL :: KP(3,NE), CXYY(2,3) - REAL :: KM(3), CXY(2,NPA) - REAL :: K1, eSI, eVS, eVD - REAL :: eVal1, eVal2, eVal3 - REAL :: DELTAL(3,NE), CG1, WN1 - REAL :: TRIA03, SIDT, CCOS, CSIN - REAL :: SPEC(NSPEC), DEPTH, CCOSA(NTH), CSINA(NTH) - INTEGER :: IOBPTH1(NTH), IOBPTH2(NTH) - -#ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'calcARRAY_JACOBI, begin' - FLUSH(740+IAPROC) -#endif - - I = 0 - IE = 0 - POS = 0 - I1 = 0 - I2 = 0 - I3 = 0 - DTK = 0 - TMP3 = 0 - - CCOSA = FACX * ECOS - CSINA = FACX * ESIN - -#ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 0' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) -#endif - DO ISP = 1, NSPEC - - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - CCOS = CCOSA(ITH) - CSIN = CSINA(ITH) - - DO IP = 1, NPA - - IP_GLOB = IPLG(IP) -#ifdef NOCGTABLE - CALL WAVNU_LOCAL(SIG(IK),DW(IP_GLOB),WN1,CG1) -#else - CG1 = CG(IK,IP_GLOB) -#endif - CXY(1,IP) = CCOS * CG1/CLATS(IP_GLOB) - CXY(2,IP) = CSIN * CG1 - IF (FLCUR) THEN - CXY(1,IP) = CXY(1,IP) + FACX * CX(IP_GLOB)/CLATS(IP_GLOB) - CXY(2,IP) = CXY(2,IP) + FACY * CY(IP_GLOB) - ENDIF -#ifdef W3_MGP - CXY(1,IP) = CXY(1,IP) - CCURX*VGX/CLATS(ISEA) - CXY(2,IP) = CXY(2,IP) - CCURY*VGY -#endif - ENDDO - - DO IE = 1, NE - NI = INE(:,IE) - CXYY(1,:) = CXY(1,NI) - CXYY(2,:) = CXY(2,NI) - FL11 = CXYY(1,2)*PDLIB_IEN(1,IE)+CXYY(2,2)*PDLIB_IEN(2,IE) - FL12 = CXYY(1,3)*PDLIB_IEN(1,IE)+CXYY(2,3)*PDLIB_IEN(2,IE) - FL21 = CXYY(1,3)*PDLIB_IEN(3,IE)+CXYY(2,3)*PDLIB_IEN(4,IE) - FL22 = CXYY(1,1)*PDLIB_IEN(3,IE)+CXYY(2,1)*PDLIB_IEN(4,IE) - FL31 = CXYY(1,1)*PDLIB_IEN(5,IE)+CXYY(2,1)*PDLIB_IEN(6,IE) - FL32 = CXYY(1,2)*PDLIB_IEN(5,IE)+CXYY(2,2)*PDLIB_IEN(6,IE) - CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) - CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) - CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) - LAMBDA(1) = ONESIXTH * SUM(CXYY(1,:)) - LAMBDA(2) = ONESIXTH * SUM(CXYY(2,:)) - K(1) = LAMBDA(1) * PDLIB_IEN(1,IE) + LAMBDA(2) * PDLIB_IEN(2,IE) - K(2) = LAMBDA(1) * PDLIB_IEN(3,IE) + LAMBDA(2) * PDLIB_IEN(4,IE) - K(3) = LAMBDA(1) * PDLIB_IEN(5,IE) + LAMBDA(2) * PDLIB_IEN(6,IE) - KP(1:3,IE) = MAX(ZERO,K(1:3)) - DELTAL(1:3,IE) = (CRFS(1:3) - KP(1:3,IE)) * 1.d0/MIN(-THR,SUM(MIN(ZERO,K(1:3)))) - ENDDO - - J = 0 - DO IP = 1, np - IB1 = (1-IOBPA_LOC(IP)) * IOBPD_LOC(ITH,IP) - IB2 = IOBPD_LOC(ITH,IP) - IF (IOBDP_LOC(IP) .eq. 1) THEN - DO I = 1, PDLIB_CCON(IP) - J = J + 1 - IE = PDLIB_IE_CELL2(I,IP) - POS = PDLIB_POS_CELL2(I,IP) -#ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'I1=', I1, ' PDLIB_I_DIAG=', PDLIB_I_DIAG(IP) -#endif + USE W3STR1MD +#endif + implicit none + REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY + INTEGER :: IP, ISP, ISEA, IP_glob + INTEGER :: idx, IS + INTEGER :: I, J, ITH, IK, J2 + INTEGER :: IE, POS, JSEA + INTEGER :: I1, I2, I3, NI(3) + INTEGER :: counter, IB1, IB2 #ifdef W3_REF1 - eIOBPDR=(1-IOBP_LOC(IP))*(1-IOBPD_LOC(ITH,IP)) - IF (eIOBPDR .eq. 1) THEN - K1=ZERO - END IF -#endif - DTK = KP(POS,IE) * DTG * IB1 - - I1 = PDLIB_POSI(1,J) - I2 = PDLIB_POSI(2,J) - I3 = PDLIB_POSI(3,J) - - B_JAC(ISP,IP) = B_JAC(ISP,IP) + PDLIB_TRIA03(IE) * VA(ISP,IP) * IB2 - - IF (FSGEOADVECT) THEN - ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + PDLIB_TRIA03(IE) + DTK - DTK * DELTAL(POS,IE) - ASPAR_JAC(ISP,I2) = ASPAR_JAC(ISP,I2) - DTK * DELTAL(POS_TRICK(POS,1),IE) - ASPAR_JAC(ISP,I3) = ASPAR_JAC(ISP,I3) - DTK * DELTAL(POS_TRICK(POS,2),IE) - ELSE - ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + PDLIB_TRIA03(IE) - ENDIF - END DO - ELSE - DO I = 1, PDLIB_CCON(IP) - J = J + 1 - I1 = PDLIB_POSI(1,J) - IE = PDLIB_IE_CELL2(I,IP) - ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + PDLIB_TRIA03(IE) - END DO - B_JAC(ISP,IP) = 0. - ENDIF - END DO - END DO ! ISP + INTEGER :: eIOBPDR +#endif + REAL :: DTK, TMP3 + REAL :: LAMBDA(2) + REAL :: FL11, FL12 + REAL :: FL21, FL22 + REAL :: FL31, FL32 + REAL :: CRFS(3), K(3) + REAL :: KP(3,NE), CXYY(2,3) + REAL :: KM(3), CXY(2,NPA) + REAL :: K1, eSI, eVS, eVD + REAL :: eVal1, eVal2, eVal3 + REAL :: DELTAL(3,NE), CG1, WN1 + REAL :: TRIA03, SIDT, CCOS, CSIN + REAL :: SPEC(NSPEC), DEPTH, CCOSA(NTH), CSINA(NTH) + INTEGER :: IOBPTH1(NTH), IOBPTH2(NTH) -#ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 1' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) -#endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'sum(VA)=', sum(VA) - CALL PrintTotalOffContrib("Offdiag after the geo advection") -#endif -!/ -!/ End of W3XYPFSN ----------------------------------------------------- / -!/ - END SUBROUTINE calcARRAY_JACOBI_VEC -!/ ------------------------------------------------------------------- / - SUBROUTINE calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute matrix coefficients for advection part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - - USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3GDATMD, only: NSEAL, CLATS - USE W3GDATMD, only: MAPSTA - USE W3WDATMD, only: VA, VAOLD - USE W3ADATMD, only: CG, DW, WN, CX, CY -#ifdef W3_MEMCHECK - USE MallocInfo_m - USE W3ADATMD, only: MALLINFOS -#endif - USE W3IDATMD, only: FLCUR, FLLEV - USE W3GDATMD, only: ECOS, ESIN, MAPFS - USE W3PARALL, only : ONESIXTH, ZERO, THR, IMEM - use yowElementpool, only: ne, INE - USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & - PDLIB_CCON, PDLIB_POS_CELL2, PDLIB_IE_CELL2, NP, NPA, & - PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & - PDLIB_I_DIAG, PDLIB_JA - USE W3ODATMD, only : IAPROC -#ifdef W3_DB1 - USE W3SDB1MD - USE W3GDATMD, only: SDBSC -#endif -#ifdef W3_BT1 - USE W3SBT1MD -#endif -#ifdef W3_BT4 - USE W3SBT4MD -#endif -#ifdef W3_BT8 - USE W3SBT8MD -#endif -#ifdef W3_BT9 - USE W3SBT9MD -#endif -#ifdef W3_IC1 - USE W3SIC1MD -#endif -#ifdef W3_IC2 - USE W3SIC2MD -#endif -#ifdef W3_IC3 - USE W3SIC3MD + WRITE(740+IAPROC,*) 'calcARRAY_JACOBI, begin' + FLUSH(740+IAPROC) #endif -#ifdef W3_TR1 - USE W3STR1MD -#endif - implicit none - REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY - INTEGER :: IP, ISP, ISEA, IP_glob - INTEGER :: idx, IS - INTEGER :: I, J, ITH, IK, J2 - INTEGER :: IE, POS, JSEA - INTEGER :: I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) - INTEGER :: counter -#ifdef W3_REF1 - INTEGER :: eIOBPDR -#endif - INTEGER :: IP1, IP2, IPP1, IPP2 - REAL :: DTK, TMP3 - REAL :: LAMBDA(2) - REAL :: FL11, FL12 - REAL :: FL21, FL22 - REAL :: FL31, FL32 - REAL :: CRFS(3), K(3) - REAL :: KP(3) - REAL :: KM(3), CXY(3,2) - REAL :: K1, eSI, eVS, eVD - REAL :: eVal1, eVal2, eVal3 - REAL :: DELTAL(3) - REAL :: NM - REAL :: IEN_LOCAL(6), CG2(NK,NTH) - REAL :: TRIA03, SIDT, CCOS, CSIN - REAL :: SPEC(NSPEC), DEPTH + + I = 0 + IE = 0 + POS = 0 + I1 = 0 + I2 = 0 + I3 = 0 + DTK = 0 + TMP3 = 0 + + CCOSA = FACX * ECOS + CSINA = FACX * ESIN #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 0' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 0' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) #endif + DO ISP = 1, NSPEC - J = 0 - DO IP = 1, npa - IP_glob=iplg(IP) - ISEA=MAPFS(1,IP_glob) - DO I = 1, PDLIB_CCON(IP) - J = J + 1 - IE = PDLIB_IE_CELL2(I,IP) - IEN_LOCAL = PDLIB_IEN(:,IE) - POS = PDLIB_POS_CELL2(I,IP) - I1 = PDLIB_POSI(1,J) - I2 = PDLIB_POSI(2,J) - I3 = PDLIB_POSI(3,J) - IP1 = INE(POS_TRICK(POS,1),IE) - IP2 = INE(POS_TRICK(POS,2),IE) - IPP1 = POS_TRICK(POS,1) - IPP2 = POS_TRICK(POS,2) - NI = INE(:,IE) - NI_GLOB = iplg(NI) - NI_ISEA = MAPFS(1,NI_GLOB) - DO ISP=1,NSPEC - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - CCOS = FACX * ECOS(ITH) - CSIN = FACY * ESIN(ITH) - CXY(:,1) = CCOS * CG(IK,NI_ISEA) / CLATS(NI_ISEA) - CXY(:,2) = CSIN * CG(IK,NI_ISEA) - IF (FLCUR) THEN - CXY(:,1) = CXY(:,1) + FACX * CX(NI_ISEA)/CLATS(NI_ISEA) - CXY(:,2) = CXY(:,2) + FACY * CY(NI_ISEA) - ENDIF + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + CCOS = CCOSA(ITH) + CSIN = CSINA(ITH) + + DO IP = 1, NPA + + IP_GLOB = IPLG(IP) +#ifdef NOCGTABLE + CALL WAVNU_LOCAL(SIG(IK),DW(IP_GLOB),WN1,CG1) +#else + CG1 = CG(IK,IP_GLOB) +#endif + CXY(1,IP) = CCOS * CG1/CLATS(IP_GLOB) + CXY(2,IP) = CSIN * CG1 + IF (FLCUR) THEN + CXY(1,IP) = CXY(1,IP) + FACX * CX(IP_GLOB)/CLATS(IP_GLOB) + CXY(2,IP) = CXY(2,IP) + FACY * CY(IP_GLOB) + ENDIF #ifdef W3_MGP - CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) - CXY(:,2) = CXY(:,2) - CCURY*VGY + CXY(1,IP) = CXY(1,IP) - CCURX*VGX/CLATS(ISEA) + CXY(2,IP) = CXY(2,IP) - CCURY*VGY +#endif + ENDDO + + DO IE = 1, NE + NI = INE(:,IE) + CXYY(1,:) = CXY(1,NI) + CXYY(2,:) = CXY(2,NI) + FL11 = CXYY(1,2)*PDLIB_IEN(1,IE)+CXYY(2,2)*PDLIB_IEN(2,IE) + FL12 = CXYY(1,3)*PDLIB_IEN(1,IE)+CXYY(2,3)*PDLIB_IEN(2,IE) + FL21 = CXYY(1,3)*PDLIB_IEN(3,IE)+CXYY(2,3)*PDLIB_IEN(4,IE) + FL22 = CXYY(1,1)*PDLIB_IEN(3,IE)+CXYY(2,1)*PDLIB_IEN(4,IE) + FL31 = CXYY(1,1)*PDLIB_IEN(5,IE)+CXYY(2,1)*PDLIB_IEN(6,IE) + FL32 = CXYY(1,2)*PDLIB_IEN(5,IE)+CXYY(2,2)*PDLIB_IEN(6,IE) + CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) + CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) + CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) + LAMBDA(1) = ONESIXTH * SUM(CXYY(1,:)) + LAMBDA(2) = ONESIXTH * SUM(CXYY(2,:)) + K(1) = LAMBDA(1) * PDLIB_IEN(1,IE) + LAMBDA(2) * PDLIB_IEN(2,IE) + K(2) = LAMBDA(1) * PDLIB_IEN(3,IE) + LAMBDA(2) * PDLIB_IEN(4,IE) + K(3) = LAMBDA(1) * PDLIB_IEN(5,IE) + LAMBDA(2) * PDLIB_IEN(6,IE) + KP(1:3,IE) = MAX(ZERO,K(1:3)) + DELTAL(1:3,IE) = (CRFS(1:3) - KP(1:3,IE)) * 1.d0/MIN(-THR,SUM(MIN(ZERO,K(1:3)))) + ENDDO + + J = 0 + DO IP = 1, np + IB1 = (1-IOBPA_LOC(IP)) * IOBPD_LOC(ITH,IP) + IB2 = IOBPD_LOC(ITH,IP) + IF (IOBDP_LOC(IP) .eq. 1) THEN + DO I = 1, PDLIB_CCON(IP) + J = J + 1 + IE = PDLIB_IE_CELL2(I,IP) + POS = PDLIB_POS_CELL2(I,IP) +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'I1=', I1, ' PDLIB_I_DIAG=', PDLIB_I_DIAG(IP) #endif - FL11 = CXY(2,1)*IEN_LOCAL(1)+CXY(2,2)*IEN_LOCAL(2) - FL12 = CXY(3,1)*IEN_LOCAL(1)+CXY(3,2)*IEN_LOCAL(2) - FL21 = CXY(3,1)*IEN_LOCAL(3)+CXY(3,2)*IEN_LOCAL(4) - FL22 = CXY(1,1)*IEN_LOCAL(3)+CXY(1,2)*IEN_LOCAL(4) - FL31 = CXY(1,1)*IEN_LOCAL(5)+CXY(1,2)*IEN_LOCAL(6) - FL32 = CXY(2,1)*IEN_LOCAL(5)+CXY(2,2)*IEN_LOCAL(6) - CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) - CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) - CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) - LAMBDA(1) = ONESIXTH * SUM(CXY(:,1)) - LAMBDA(2) = ONESIXTH * SUM(CXY(:,2)) - K(1) = LAMBDA(1) * IEN_LOCAL(1) + LAMBDA(2) * IEN_LOCAL(2) - K(2) = LAMBDA(1) * IEN_LOCAL(3) + LAMBDA(2) * IEN_LOCAL(4) - K(3) = LAMBDA(1) * IEN_LOCAL(5) + LAMBDA(2) * IEN_LOCAL(6) - KP(:) = MAX(ZERO,K(:)) - DELTAL(:) = CRFS(:) - KP(:) - KM(:) = MIN(ZERO,K(:)) - NM = 1.d0/MIN(-THR,SUM(KM)) - K1 = KP(POS) #ifdef W3_REF1 eIOBPDR=(1-IOBP_LOC(IP))*(1-IOBPD_LOC(ITH,IP)) IF (eIOBPDR .eq. 1) THEN K1=ZERO END IF #endif - TRIA03 = 1./3. * PDLIB_TRIA(IE) - DTK = K1 * DTG * IOBDP_LOC(IP) * IOBPD_LOC(ITH,IP) * (1-IOBPA_LOC(IP)) - TMP3 = DTK * NM + DTK = KP(POS,IE) * DTG * IB1 + + I1 = PDLIB_POSI(1,J) + I2 = PDLIB_POSI(2,J) + I3 = PDLIB_POSI(3,J) + + B_JAC(ISP,IP) = B_JAC(ISP,IP) + PDLIB_TRIA03(IE) * VA(ISP,IP) * IB2 + IF (FSGEOADVECT) THEN - ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + TRIA03 + DTK - TMP3*DELTAL(POS) - ASPAR_JAC(ISP,I2) = ASPAR_JAC(ISP,I2) - TMP3*DELTAL(IPP1) - ASPAR_JAC(ISP,I3) = ASPAR_JAC(ISP,I3) - TMP3*DELTAL(IPP2) + ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + PDLIB_TRIA03(IE) + DTK - DTK * DELTAL(POS,IE) + ASPAR_JAC(ISP,I2) = ASPAR_JAC(ISP,I2) - DTK * DELTAL(POS_TRICK(POS,1),IE) + ASPAR_JAC(ISP,I3) = ASPAR_JAC(ISP,I3) - DTK * DELTAL(POS_TRICK(POS,2),IE) ELSE - ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + TRIA03 - END IF - B_JAC(ISP,IP) = B_JAC(ISP,IP) + TRIA03 * VA(ISP,IP) * IOBDP_LOC(IP) * IOBPD_LOC(ITH,IP) + ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + PDLIB_TRIA03(IE) + ENDIF END DO - END DO + ELSE + DO I = 1, PDLIB_CCON(IP) + J = J + 1 + I1 = PDLIB_POSI(1,J) + IE = PDLIB_IE_CELL2(I,IP) + ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + PDLIB_TRIA03(IE) + END DO + B_JAC(ISP,IP) = 0. + ENDIF END DO + END DO ! ISP #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 1' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) #endif -!/ -!/ End of W3XYPFSN ----------------------------------------------------- / -!/ - END SUBROUTINE calcARRAY_JACOBI2 -!/ ------------------------------------------------------------------- / - SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute matrix coefficients for advection part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'sum(VA)=', sum(VA) + CALL PrintTotalOffContrib("Offdiag after the geo advection") +#endif + !/ + !/ End of W3XYPFSN ----------------------------------------------------- / + !/ + END SUBROUTINE calcARRAY_JACOBI_VEC + !/ ------------------------------------------------------------------- / + SUBROUTINE calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute matrix coefficients for advection part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3GDATMD, only: NSEAL, CLATS - USE W3GDATMD, only: MAPSTA - USE W3WDATMD, only: VA, VAOLD - USE W3ADATMD, only: CG, DW, WN, CX, CY -#ifdef W3_MEMCHECK - USE W3ADATMD, only: MALLINFOS -#endif - USE W3IDATMD, only: FLCUR, FLLEV - USE W3GDATMD, only: ECOS, ESIN, MAPFS - USE W3PARALL, only : ONESIXTH, ZERO, THR, ONETHIRD - use yowElementpool, only: ne, INE - USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & - PDLIB_CCON, NP, NPA, PDLIB_POS_CELL2, PDLIB_IE_CELL2, & - PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & - PDLIB_I_DIAG, PDLIB_JA - USE W3GDATMD, only: IOBP - USE W3ODATMD, only : IAPROC -#ifdef W3_MEMCHECK - USE MallocInfo_m + USE W3SERVMD, only: STRACE #endif + ! + + USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3GDATMD, only: NSEAL, CLATS + USE W3GDATMD, only: MAPSTA + USE W3WDATMD, only: VA, VAOLD + USE W3ADATMD, only: CG, DW, WN, CX, CY +#ifdef W3_MEMCHECK + USE MallocInfo_m + USE W3ADATMD, only: MALLINFOS +#endif + USE W3IDATMD, only: FLCUR, FLLEV + USE W3GDATMD, only: ECOS, ESIN, MAPFS + USE W3PARALL, only : ONESIXTH, ZERO, THR, IMEM + use yowElementpool, only: ne, INE + USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & + PDLIB_CCON, PDLIB_POS_CELL2, PDLIB_IE_CELL2, NP, NPA, & + PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & + PDLIB_I_DIAG, PDLIB_JA + USE W3ODATMD, only : IAPROC #ifdef W3_DB1 - USE W3SDB1MD - USE W3GDATMD, only: SDBSC + USE W3SDB1MD + USE W3GDATMD, only: SDBSC #endif #ifdef W3_BT1 - USE W3SBT1MD + USE W3SBT1MD #endif #ifdef W3_BT4 - USE W3SBT4MD + USE W3SBT4MD #endif #ifdef W3_BT8 - USE W3SBT8MD + USE W3SBT8MD #endif #ifdef W3_BT9 - USE W3SBT9MD + USE W3SBT9MD #endif #ifdef W3_IC1 - USE W3SIC1MD + USE W3SIC1MD #endif #ifdef W3_IC2 - USE W3SIC2MD + USE W3SIC2MD #endif #ifdef W3_IC3 - USE W3SIC3MD + USE W3SIC3MD #endif #ifdef W3_TR1 - USE W3STR1MD -#endif - implicit none - INTEGER, INTENT(IN) :: IP - INTEGER, INTENT(INOUT) :: J - REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY - REAL, INTENT(out) :: ASPAR_DIAG_LOCAL(NSPEC), B_JAC_LOCAL(NSPEC), ASPAR_OFF_DIAG_LOCAL(NSPEC) - INTEGER :: ISP, ISEA, IP_glob, IPP1, IPP2 - INTEGER :: idx, IS, IP1, IP2 - INTEGER :: I, ITH, IK, J2 - INTEGER :: IE, POS, JSEA - INTEGER :: I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) - INTEGER :: counter + USE W3STR1MD +#endif + implicit none + REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY + INTEGER :: IP, ISP, ISEA, IP_glob + INTEGER :: idx, IS + INTEGER :: I, J, ITH, IK, J2 + INTEGER :: IE, POS, JSEA + INTEGER :: I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) + INTEGER :: counter #ifdef W3_REF1 - INTEGER :: eIOBPDR -#endif - REAL*8 :: DTK, TMP3 - REAL*8 :: LAMBDA(2) - REAL*8 :: FL11, FL12 - REAL*8 :: FL21, FL22 - REAL*8 :: FL31, FL32 - REAL*8 :: CRFS(3), K(3) - REAL*8 :: KP(3) - REAL*8 :: KM(3), CXY(3,2) - REAL*8 :: K1, eSI, eVS, eVD - REAL*8 :: eVal1, eVal2, eVal3 - REAL*8 :: ien_local(6) - REAL*8 :: DELTAL(3) - REAL*8 :: NM - REAL*8 :: TRIA03, SIDT, CCOS, CSIN - REAL*8 :: DEPTH - - ASPAR_DIAG_LOCAL = 0.d0 - B_JAC_LOCAL = 0.d0 - ASPAR_OFF_DIAG_LOCAL = 0.d0 + INTEGER :: eIOBPDR +#endif + INTEGER :: IP1, IP2, IPP1, IPP2 + REAL :: DTK, TMP3 + REAL :: LAMBDA(2) + REAL :: FL11, FL12 + REAL :: FL21, FL22 + REAL :: FL31, FL32 + REAL :: CRFS(3), K(3) + REAL :: KP(3) + REAL :: KM(3), CXY(3,2) + REAL :: K1, eSI, eVS, eVD + REAL :: eVal1, eVal2, eVal3 + REAL :: DELTAL(3) + REAL :: NM + REAL :: IEN_LOCAL(6), CG2(NK,NTH) + REAL :: TRIA03, SIDT, CCOS, CSIN + REAL :: SPEC(NSPEC), DEPTH + +#ifdef W3_MEMCHECK + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 0' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) +#endif + J = 0 + DO IP = 1, npa IP_glob=iplg(IP) + ISEA=MAPFS(1,IP_glob) DO I = 1, PDLIB_CCON(IP) - J = J + 1 + J = J + 1 IE = PDLIB_IE_CELL2(I,IP) IEN_LOCAL = PDLIB_IEN(:,IE) POS = PDLIB_POS_CELL2(I,IP) @@ -3988,10 +3768,9 @@ SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O IP2 = INE(POS_TRICK(POS,2),IE) IPP1 = POS_TRICK(POS,1) IPP2 = POS_TRICK(POS,2) - NI = INE(:,IE) + NI = INE(:,IE) NI_GLOB = iplg(NI) NI_ISEA = MAPFS(1,NI_GLOB) - DO ISP=1,NSPEC ITH = 1 + MOD(ISP-1,NTH) IK = 1 + (ISP-1)/NTH @@ -4003,10 +3782,9 @@ SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O CXY(:,1) = CXY(:,1) + FACX * CX(NI_ISEA)/CLATS(NI_ISEA) CXY(:,2) = CXY(:,2) + FACY * CY(NI_ISEA) ENDIF - #ifdef W3_MGP - CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) - CXY(:,2) = CXY(:,2) - CCURY*VGY + CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) + CXY(:,2) = CXY(:,2) - CCURY*VGY #endif FL11 = CXY(2,1)*IEN_LOCAL(1)+CXY(2,2)*IEN_LOCAL(2) FL12 = CXY(3,1)*IEN_LOCAL(1)+CXY(3,2)*IEN_LOCAL(2) @@ -4014,9 +3792,9 @@ SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O FL22 = CXY(1,1)*IEN_LOCAL(3)+CXY(1,2)*IEN_LOCAL(4) FL31 = CXY(1,1)*IEN_LOCAL(5)+CXY(1,2)*IEN_LOCAL(6) FL32 = CXY(2,1)*IEN_LOCAL(5)+CXY(2,2)*IEN_LOCAL(6) - CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) - CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) - CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) + CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) + CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) + CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) LAMBDA(1) = ONESIXTH * SUM(CXY(:,1)) LAMBDA(2) = ONESIXTH * SUM(CXY(:,2)) K(1) = LAMBDA(1) * IEN_LOCAL(1) + LAMBDA(2) * IEN_LOCAL(2) @@ -4026,426 +3804,426 @@ SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O DELTAL(:) = CRFS(:) - KP(:) KM(:) = MIN(ZERO,K(:)) NM = 1.d0/MIN(-THR,SUM(KM)) + K1 = KP(POS) #ifdef W3_REF1 eIOBPDR=(1-IOBP_LOC(IP))*(1-IOBPD_LOC(ITH,IP)) IF (eIOBPDR .eq. 1) THEN K1=ZERO END IF #endif - TRIA03 = ONETHIRD * PDLIB_TRIA(IE) - DTK = KP(POS) * DBLE(DTG) * IOBDP_LOC(IP) * IOBPD_LOC(ITH,IP) * (1-IOBPA_LOC(IP)) + TRIA03 = 1./3. * PDLIB_TRIA(IE) + DTK = K1 * DTG * IOBDP_LOC(IP) * IOBPD_LOC(ITH,IP) * (1-IOBPA_LOC(IP)) TMP3 = DTK * NM -! IF (IP == 224 .AND. ISP == 121) WRITE(10006,'(I10,20F20.15)') ISP, KP(POS), DTK, TMP3, DELTAL(POS) IF (FSGEOADVECT) THEN - ASPAR_DIAG_LOCAL(ISP) = ASPAR_DIAG_LOCAL(ISP) + TRIA03 + DTK - TMP3*DELTAL(POS) - ASPAR_OFF_DIAG_LOCAL(ISP) = ASPAR_OFF_DIAG_LOCAL(ISP) - TMP3*DELTAL(IPP1)*VA(ISP,IP1) - ASPAR_OFF_DIAG_LOCAL(ISP) = ASPAR_OFF_DIAG_LOCAL(ISP) - TMP3*DELTAL(IPP2)*VA(ISP,IP2) + ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + TRIA03 + DTK - TMP3*DELTAL(POS) + ASPAR_JAC(ISP,I2) = ASPAR_JAC(ISP,I2) - TMP3*DELTAL(IPP1) + ASPAR_JAC(ISP,I3) = ASPAR_JAC(ISP,I3) - TMP3*DELTAL(IPP2) ELSE - ASPAR_DIAG_LOCAL(ISP) = ASPAR_DIAG_LOCAL(ISP) + TRIA03 + ASPAR_JAC(ISP,I1) = ASPAR_JAC(ISP,I1) + TRIA03 END IF - !IF (IP == 2) WRITE(10005,'(2I10,10G20.10)') ISP, IP, VAOLD(ISP,IP) - B_JAC_LOCAL(ISP) = B_JAC_LOCAL(ISP) + TRIA03 * VAOLD(ISP,IP) * IOBDP_LOC(IP) * IOBPD_LOC(ITH,IP) + B_JAC(ISP,IP) = B_JAC(ISP,IP) + TRIA03 * VA(ISP,IP) * IOBDP_LOC(IP) * IOBPD_LOC(ITH,IP) END DO END DO -!/ -!/ End of W3XYPFSN --------------------------------------------------- / -!/ - END SUBROUTINE calcARRAY_JACOBI3 -!/ ------------------------------------------------------------------- / - SUBROUTINE calcARRAY_JACOBI4(IP,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute matrix coefficients for advection part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END DO + +#ifdef W3_MEMCHECK + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) +#endif + !/ + !/ End of W3XYPFSN ----------------------------------------------------- / + !/ + END SUBROUTINE calcARRAY_JACOBI2 + !/ ------------------------------------------------------------------- / + SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute matrix coefficients for advection part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3GDATMD, only: NSEAL,CLATS - USE W3GDATMD, only: MAPSTA, NK - USE W3WDATMD, only: VA, VAOLD - USE W3ADATMD, only: CG, DW, WN, CX, CY + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3GDATMD, only: NSEAL, CLATS + USE W3GDATMD, only: MAPSTA + USE W3WDATMD, only: VA, VAOLD + USE W3ADATMD, only: CG, DW, WN, CX, CY #ifdef W3_MEMCHECK - USE W3ADATMD, only: MALLINFOS -#endif - USE W3IDATMD, only: FLCUR, FLLEV - USE W3GDATMD, only: ECOS, ESIN, MAPFS - USE W3PARALL, only : ONESIXTH, ZERO, THR, ONETHIRD - use yowElementpool, only: ne, INE - USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & - PDLIB_IE_CELL2, PDLIB_POS_CELL2, PDLIB_CCON, NP, NPA, & - PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & - PDLIB_I_DIAG, PDLIB_JA - USE W3ODATMD, only : IAPROC + USE W3ADATMD, only: MALLINFOS +#endif + USE W3IDATMD, only: FLCUR, FLLEV + USE W3GDATMD, only: ECOS, ESIN, MAPFS + USE W3PARALL, only : ONESIXTH, ZERO, THR, ONETHIRD + use yowElementpool, only: ne, INE + USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & + PDLIB_CCON, NP, NPA, PDLIB_POS_CELL2, PDLIB_IE_CELL2, & + PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & + PDLIB_I_DIAG, PDLIB_JA + USE W3GDATMD, only: IOBP + USE W3ODATMD, only : IAPROC #ifdef W3_MEMCHECK - USE MallocInfo_m + USE MallocInfo_m #endif #ifdef W3_DB1 - USE W3SDB1MD - USE W3GDATMD, only: SDBSC + USE W3SDB1MD + USE W3GDATMD, only: SDBSC #endif #ifdef W3_BT1 - USE W3SBT1MD + USE W3SBT1MD #endif #ifdef W3_BT4 - USE W3SBT4MD + USE W3SBT4MD #endif #ifdef W3_BT8 - USE W3SBT8MD + USE W3SBT8MD #endif #ifdef W3_BT9 - USE W3SBT9MD + USE W3SBT9MD #endif #ifdef W3_IC1 - USE W3SIC1MD + USE W3SIC1MD #endif #ifdef W3_IC2 - USE W3SIC2MD + USE W3SIC2MD #endif #ifdef W3_IC3 - USE W3SIC3MD + USE W3SIC3MD #endif #ifdef W3_TR1 - USE W3STR1MD -#endif - implicit none - INTEGER, INTENT(IN) :: IP - REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY - REAL, INTENT(out) :: ASPAR_DIAG_LOCAL(NSPEC), B_JAC_LOCAL(NSPEC), ASPAR_OFF_DIAG_LOCAL(NSPEC) -! - INTEGER :: IP1, IP2 - INTEGER :: ITH, IK - INTEGER :: IE, POS, JSEA - INTEGER :: I, I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) - INTEGER :: ISP, IP_glob, IPP1, IPP2, IOBPTH1(NTH), IOBPTH2(NTH) - INTEGER :: counter + USE W3STR1MD +#endif + implicit none + INTEGER, INTENT(IN) :: IP + INTEGER, INTENT(INOUT) :: J + REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY + REAL, INTENT(out) :: ASPAR_DIAG_LOCAL(NSPEC), B_JAC_LOCAL(NSPEC), ASPAR_OFF_DIAG_LOCAL(NSPEC) + INTEGER :: ISP, ISEA, IP_glob, IPP1, IPP2 + INTEGER :: idx, IS, IP1, IP2 + INTEGER :: I, ITH, IK, J2 + INTEGER :: IE, POS, JSEA + INTEGER :: I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) + INTEGER :: counter #ifdef W3_REF1 - INTEGER :: eIOBPDR -#endif - REAL*8 :: DTK, TMP3, D1, D2 - REAL*8 :: LAMBDA(2) - REAL*8 :: CRFS(3), K(3) - REAL*8 :: KP(3), UV_CUR(3,2) - REAL*8 :: KM(3), CSX(3), CSY(3) - REAL*8 :: K1, eSI, eVS, eVD - REAL*8 :: eVal1, eVal2, eVal3 - REAL*8 :: ien_local(6) - REAL*8 :: DELTAL(3), K_X(3,NK), K_Y(3,NK), K_U(3) - REAL*8 :: CRFS_X(3,NK), CRFS_Y(3,NK), CRFS_U(3) - REAL*8 :: NM, CGFAK(3,NK), CSINA(NTH), CCOSA(NTH) - REAL*8 :: TRIA03, SIDT, CCOS, CSIN - REAL*8 :: FL11_X, FL12_X, FL21_X, FL22_X, FL31_X, FL32_X - REAL*8 :: FL11_Y, FL12_Y, FL21_Y, FL22_Y, FL31_Y, FL32_Y - REAL*8 :: FL11_U, FL12_U, FL21_U, FL22_U, FL31_U, FL32_U - - IP_glob = iplg(IP) - ASPAR_DIAG_LOCAL = ZERO - B_JAC_LOCAL = ZERO - ASPAR_OFF_DIAG_LOCAL = ZERO - - DO ITH = 1, NTH - CCOSA(ITH) = FACX * ECOS(ITH) - CSINA(ITH) = FACX * ESIN(ITH) - IOBPTH1(ITH) = IOBDP_LOC(IP) * (1-IOBPA_LOC(IP)) * IOBPD_LOC(ITH,IP) - IOBPTH2(ITH) = IOBDP_LOC(IP) * IOBPD_LOC(ITH,IP) - ENDDO - - DO I = 1, PDLIB_CCON(IP) - - IE = PDLIB_IE_CELL2(I,IP) - TRIA03 = ONETHIRD * PDLIB_TRIA(IE) - IEN_LOCAL = PDLIB_IEN(1:6,IE) - POS = PDLIB_POS_CELL2(I,IP) - IP1 = INE(POS_TRICK(POS,1),IE) - IP2 = INE(POS_TRICK(POS,2),IE) - IPP1 = POS_TRICK(POS,1) - IPP2 = POS_TRICK(POS,2) - NI = INE(1:3,IE) - NI_GLOB = IPLG(NI) - NI_ISEA = MAPFS(1,NI_GLOB) - CRFS_U = ZERO + INTEGER :: eIOBPDR +#endif + REAL*8 :: DTK, TMP3 + REAL*8 :: LAMBDA(2) + REAL*8 :: FL11, FL12 + REAL*8 :: FL21, FL22 + REAL*8 :: FL31, FL32 + REAL*8 :: CRFS(3), K(3) + REAL*8 :: KP(3) + REAL*8 :: KM(3), CXY(3,2) + REAL*8 :: K1, eSI, eVS, eVD + REAL*8 :: eVal1, eVal2, eVal3 + REAL*8 :: ien_local(6) + REAL*8 :: DELTAL(3) + REAL*8 :: NM + REAL*8 :: TRIA03, SIDT, CCOS, CSIN + REAL*8 :: DEPTH + + ASPAR_DIAG_LOCAL = 0.d0 + B_JAC_LOCAL = 0.d0 + ASPAR_OFF_DIAG_LOCAL = 0.d0 + + IP_glob=iplg(IP) + DO I = 1, PDLIB_CCON(IP) + J = J + 1 + IE = PDLIB_IE_CELL2(I,IP) + IEN_LOCAL = PDLIB_IEN(:,IE) + POS = PDLIB_POS_CELL2(I,IP) + I1 = PDLIB_POSI(1,J) + I2 = PDLIB_POSI(2,J) + I3 = PDLIB_POSI(3,J) + IP1 = INE(POS_TRICK(POS,1),IE) + IP2 = INE(POS_TRICK(POS,2),IE) + IPP1 = POS_TRICK(POS,1) + IPP2 = POS_TRICK(POS,2) + NI = INE(:,IE) + NI_GLOB = iplg(NI) + NI_ISEA = MAPFS(1,NI_GLOB) + DO ISP=1,NSPEC + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + CCOS = FACX * ECOS(ITH) + CSIN = FACY * ESIN(ITH) + CXY(:,1) = CCOS * CG(IK,NI_ISEA) / CLATS(NI_ISEA) + CXY(:,2) = CSIN * CG(IK,NI_ISEA) IF (FLCUR) THEN - - UV_CUR(1:3,1) = FACX * CX(NI_ISEA) / CLATS(NI_ISEA) - UV_CUR(1:3,2) = FACY * CY(NI_ISEA) - - LAMBDA(1) = ONESIXTH*(UV_CUR(1,1)+UV_CUR(2,1)+UV_CUR(3,1)) - LAMBDA(2) = ONESIXTH*(UV_CUR(1,2)+UV_CUR(2,2)+UV_CUR(3,2)) - - K_U(1) = LAMBDA(1) * IEN_LOCAL(1) + LAMBDA(2) * IEN_LOCAL(2) - K_U(2) = LAMBDA(1) * IEN_LOCAL(3) + LAMBDA(2) * IEN_LOCAL(4) - K_U(3) = LAMBDA(1) * IEN_LOCAL(5) + LAMBDA(2) * IEN_LOCAL(6) - - FL11_U = UV_CUR(2,1)*IEN_LOCAL(1)+UV_CUR(2,2)*IEN_LOCAL(2) - FL12_U = UV_CUR(3,1)*IEN_LOCAL(1)+UV_CUR(3,2)*IEN_LOCAL(2) - FL21_U = UV_CUR(3,1)*IEN_LOCAL(3)+UV_CUR(3,2)*IEN_LOCAL(4) - FL22_U = UV_CUR(1,1)*IEN_LOCAL(3)+UV_CUR(1,2)*IEN_LOCAL(4) - FL31_U = UV_CUR(1,1)*IEN_LOCAL(5)+UV_CUR(1,2)*IEN_LOCAL(6) - FL32_U = UV_CUR(2,1)*IEN_LOCAL(5)+UV_CUR(2,2)*IEN_LOCAL(6) - - CRFS_U(1) = - ONESIXTH*(2.d0 *FL31_U + FL32_U + FL21_U + 2.d0 * FL22_U) - CRFS_U(2) = - ONESIXTH*(2.d0 *FL32_U + 2.d0 * FL11_U + FL12_U + FL31_U) - CRFS_U(3) = - ONESIXTH*(2.d0 *FL12_U + 2.d0 * FL21_U + FL22_U + FL11_U) - + CXY(:,1) = CXY(:,1) + FACX * CX(NI_ISEA)/CLATS(NI_ISEA) + CXY(:,2) = CXY(:,2) + FACY * CY(NI_ISEA) ENDIF - DO IK = 1, NK - CSX = CG(IK,NI_ISEA) / CLATS(NI_ISEA) - CSY = CG(IK,NI_ISEA) - LAMBDA(1) = ONESIXTH * (CSX(1) + CSX(2) + CSX(3)) - LAMBDA(2) = ONESIXTH * (CSY(1) + CSY(2) + CSY(3)) - K_X(1,IK) = LAMBDA(1) * IEN_LOCAL(1) - K_X(2,IK) = LAMBDA(1) * IEN_LOCAL(3) - K_X(3,IK) = LAMBDA(1) * IEN_LOCAL(5) - K_Y(1,IK) = LAMBDA(2) * IEN_LOCAL(2) - K_Y(2,IK) = LAMBDA(2) * IEN_LOCAL(4) - K_Y(3,IK) = LAMBDA(2) * IEN_LOCAL(6) - FL11_X = CSX(2) * IEN_LOCAL(1) - FL12_X = CSX(3) * IEN_LOCAL(1) - FL21_X = CSX(3) * IEN_LOCAL(3) - FL22_X = CSX(1) * IEN_LOCAL(3) - FL31_X = CSX(1) * IEN_LOCAL(5) - FL32_X = CSX(2) * IEN_LOCAL(5) - FL11_Y = CSY(2) * IEN_LOCAL(2) - FL12_Y = CSY(3) * IEN_LOCAL(2) - FL21_Y = CSY(3) * IEN_LOCAL(4) - FL22_Y = CSY(1) * IEN_LOCAL(4) - FL31_Y = CSY(1) * IEN_LOCAL(6) - FL32_Y = CSY(2) * IEN_LOCAL(6) - CRFS_X(1,IK) = - ONESIXTH*(2.d0*FL31_X + FL32_X + FL21_X + 2.d0 * FL22_X) - CRFS_X(2,IK) = - ONESIXTH*(2.d0*FL32_X + 2.d0 * FL11_X + FL12_X + FL31_X) - CRFS_X(3,IK) = - ONESIXTH*(2.d0*FL12_X + 2.d0 * FL21_X + FL22_X + FL11_X) - CRFS_Y(1,IK) = - ONESIXTH*(2.d0*FL31_Y + FL32_Y + FL21_Y + 2.d0 * FL22_Y) - CRFS_Y(2,IK) = - ONESIXTH*(2.d0*FL32_Y + 2.d0 * FL11_Y + FL12_Y + FL31_Y) - CRFS_Y(3,IK) = - ONESIXTH*(2.d0*FL12_Y + 2.d0 * FL21_Y + FL22_Y + FL11_Y) - ENDDO - - DO ISP = 1, NSPEC - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - K(1) = K_X(1,IK) * CCOSA(ITH) + K_Y(1,IK) * CSINA(ITH) + K_U(1) - K(2) = K_X(2,IK) * CCOSA(ITH) + K_Y(2,IK) * CSINA(ITH) + K_U(2) - K(3) = K_X(3,IK) * CCOSA(ITH) + K_Y(3,IK) * CSINA(ITH) + K_U(3) - CRFS(1) = CRFS_X(1,IK) * CCOSA(ITH) + CRFS_Y(1,IK) * CSINA(ITH) + CRFS_U(1) - CRFS(2) = CRFS_X(2,IK) * CCOSA(ITH) + CRFS_Y(2,IK) * CSINA(ITH) + CRFS_U(2) - CRFS(3) = CRFS_X(3,IK) * CCOSA(ITH) + CRFS_Y(3,IK) * CSINA(ITH) + CRFS_U(3) - !KM = MIN(ZERO,K) - KP(1:3) = MAX(ZERO,K(1:3)) - DELTAL(1:3) = CRFS(1:3) - KP(1:3) - !NM = 1.d0/MIN(-THR,SUM(MIN(ZERO,K))) - DTK = KP(POS) * DTG * IOBPTH1(ITH)!IOBDP(IP_glob) * (1-IOBPA(IP_glob)) * IOBPD(ITH,IP_glob) - !write(*,*) IOBDP(IP_glob) , (1-IOBPA(IP_glob)), IOBPD(ITH,IP_glob) - TMP3 = DTK * 1.d0/MIN(-THR,SUM(MIN(ZERO,K(1:3)))) - IF (FSGEOADVECT) THEN - ASPAR_DIAG_LOCAL(ISP) = ASPAR_DIAG_LOCAL(ISP) + TRIA03 + DTK - TMP3*DELTAL(POS) - D1 = DELTAL(IPP1)*VA(ISP,IP1) - D2 = DELTAL(IPP2)*VA(ISP,IP2) - ASPAR_OFF_DIAG_LOCAL(ISP) = ASPAR_OFF_DIAG_LOCAL(ISP) - ( TMP3 * ( D1 + D2 ) ) - !ASPAR_OFF_DIAG_LOCAL(ISP) = ASPAR_OFF_DIAG_LOCAL(ISP) - D2 - ELSE - ASPAR_DIAG_LOCAL(ISP) = ASPAR_DIAG_LOCAL(ISP) + TRIA03 - END IF - B_JAC_LOCAL(ISP) = B_JAC_LOCAL(ISP) + TRIA03 * VAOLD(ISP,IP) * IOBPTH2(ITH)!IOBDP(IP_glob) * IOBPD(ITH,IP_glob) - END DO +#ifdef W3_MGP + CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) + CXY(:,2) = CXY(:,2) - CCURY*VGY +#endif + FL11 = CXY(2,1)*IEN_LOCAL(1)+CXY(2,2)*IEN_LOCAL(2) + FL12 = CXY(3,1)*IEN_LOCAL(1)+CXY(3,2)*IEN_LOCAL(2) + FL21 = CXY(3,1)*IEN_LOCAL(3)+CXY(3,2)*IEN_LOCAL(4) + FL22 = CXY(1,1)*IEN_LOCAL(3)+CXY(1,2)*IEN_LOCAL(4) + FL31 = CXY(1,1)*IEN_LOCAL(5)+CXY(1,2)*IEN_LOCAL(6) + FL32 = CXY(2,1)*IEN_LOCAL(5)+CXY(2,2)*IEN_LOCAL(6) + CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) + CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) + CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) + LAMBDA(1) = ONESIXTH * SUM(CXY(:,1)) + LAMBDA(2) = ONESIXTH * SUM(CXY(:,2)) + K(1) = LAMBDA(1) * IEN_LOCAL(1) + LAMBDA(2) * IEN_LOCAL(2) + K(2) = LAMBDA(1) * IEN_LOCAL(3) + LAMBDA(2) * IEN_LOCAL(4) + K(3) = LAMBDA(1) * IEN_LOCAL(5) + LAMBDA(2) * IEN_LOCAL(6) + KP(:) = MAX(ZERO,K(:)) + DELTAL(:) = CRFS(:) - KP(:) + KM(:) = MIN(ZERO,K(:)) + NM = 1.d0/MIN(-THR,SUM(KM)) +#ifdef W3_REF1 + eIOBPDR=(1-IOBP_LOC(IP))*(1-IOBPD_LOC(ITH,IP)) + IF (eIOBPDR .eq. 1) THEN + K1=ZERO + END IF +#endif + TRIA03 = ONETHIRD * PDLIB_TRIA(IE) + DTK = KP(POS) * DBLE(DTG) * IOBDP_LOC(IP) * IOBPD_LOC(ITH,IP) * (1-IOBPA_LOC(IP)) + TMP3 = DTK * NM + ! IF (IP == 224 .AND. ISP == 121) WRITE(10006,'(I10,20F20.15)') ISP, KP(POS), DTK, TMP3, DELTAL(POS) + IF (FSGEOADVECT) THEN + ASPAR_DIAG_LOCAL(ISP) = ASPAR_DIAG_LOCAL(ISP) + TRIA03 + DTK - TMP3*DELTAL(POS) + ASPAR_OFF_DIAG_LOCAL(ISP) = ASPAR_OFF_DIAG_LOCAL(ISP) - TMP3*DELTAL(IPP1)*VA(ISP,IP1) + ASPAR_OFF_DIAG_LOCAL(ISP) = ASPAR_OFF_DIAG_LOCAL(ISP) - TMP3*DELTAL(IPP2)*VA(ISP,IP2) + ELSE + ASPAR_DIAG_LOCAL(ISP) = ASPAR_DIAG_LOCAL(ISP) + TRIA03 + END IF + !IF (IP == 2) WRITE(10005,'(2I10,10G20.10)') ISP, IP, VAOLD(ISP,IP) + B_JAC_LOCAL(ISP) = B_JAC_LOCAL(ISP) + TRIA03 * VAOLD(ISP,IP) * IOBDP_LOC(IP) * IOBPD_LOC(ITH,IP) END DO - END SUBROUTINE calcARRAY_JACOBI4 -!/ ------------------------------------------------------------------- / - SUBROUTINE calcARRAY_JACOBI5(IE,DTG,FACX,FACY,VGX,VGY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute matrix coefficients for advection part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END DO + !/ + !/ End of W3XYPFSN --------------------------------------------------- / + !/ + END SUBROUTINE calcARRAY_JACOBI3 + !/ ------------------------------------------------------------------- / + SUBROUTINE calcARRAY_JACOBI4(IP,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute matrix coefficients for advection part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - - USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3GDATMD, only: NSEAL, CLATS - USE W3GDATMD, only: MAPSTA, NK - USE W3WDATMD, only: VA, VAOLD - USE W3ADATMD, only: CG, DW, WN, CX, CY + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3GDATMD, only: NSEAL,CLATS + USE W3GDATMD, only: MAPSTA, NK + USE W3WDATMD, only: VA, VAOLD + USE W3ADATMD, only: CG, DW, WN, CX, CY #ifdef W3_MEMCHECK - USE W3ADATMD, only: MALLINFOS -#endif - USE W3IDATMD, only: FLCUR, FLLEV - USE W3GDATMD, only: ECOS, ESIN, MAPFS - USE W3PARALL, only : ONESIXTH, ZERO, THR, ONETHIRD - use yowElementpool, only: ne, INE - USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & - PDLIB_CCON, NP, NPA, & - PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & - PDLIB_I_DIAG, PDLIB_JA - USE W3ODATMD, only : IAPROC + USE W3ADATMD, only: MALLINFOS +#endif + USE W3IDATMD, only: FLCUR, FLLEV + USE W3GDATMD, only: ECOS, ESIN, MAPFS + USE W3PARALL, only : ONESIXTH, ZERO, THR, ONETHIRD + use yowElementpool, only: ne, INE + USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & + PDLIB_IE_CELL2, PDLIB_POS_CELL2, PDLIB_CCON, NP, NPA, & + PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & + PDLIB_I_DIAG, PDLIB_JA + USE W3ODATMD, only : IAPROC #ifdef W3_MEMCHECK - USE MallocInfo_m + USE MallocInfo_m #endif #ifdef W3_DB1 - USE W3SDB1MD - USE W3GDATMD, only: SDBSC + USE W3SDB1MD + USE W3GDATMD, only: SDBSC #endif #ifdef W3_BT1 - USE W3SBT1MD + USE W3SBT1MD #endif #ifdef W3_BT4 - USE W3SBT4MD + USE W3SBT4MD #endif #ifdef W3_BT8 - USE W3SBT8MD + USE W3SBT8MD #endif #ifdef W3_BT9 - USE W3SBT9MD + USE W3SBT9MD #endif #ifdef W3_IC1 - USE W3SIC1MD + USE W3SIC1MD #endif #ifdef W3_IC2 - USE W3SIC2MD + USE W3SIC2MD #endif #ifdef W3_IC3 - USE W3SIC3MD + USE W3SIC3MD #endif #ifdef W3_TR1 - USE W3STR1MD -#endif - implicit none - INTEGER, INTENT(IN) :: IE - REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY -! - INTEGER :: IP, IP1, IP2 - INTEGER :: ITH, IK - INTEGER :: POS, JSEA - INTEGER :: I, I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) - INTEGER :: ISP, IP_glob, IPP1, IPP2 - INTEGER :: counter + USE W3STR1MD +#endif + implicit none + INTEGER, INTENT(IN) :: IP + REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY + REAL, INTENT(out) :: ASPAR_DIAG_LOCAL(NSPEC), B_JAC_LOCAL(NSPEC), ASPAR_OFF_DIAG_LOCAL(NSPEC) + ! + INTEGER :: IP1, IP2 + INTEGER :: ITH, IK + INTEGER :: IE, POS, JSEA + INTEGER :: I, I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) + INTEGER :: ISP, IP_glob, IPP1, IPP2, IOBPTH1(NTH), IOBPTH2(NTH) + INTEGER :: counter #ifdef W3_REF1 - INTEGER :: eIOBPDR -#endif - REAL :: DTK(3), TMP3(NSPEC,3) - REAL :: LAMBDA(2) - REAL :: CRFS(3), K(3) - REAL :: KP(3), UV_CUR(3,2) - REAL :: KM(3), CSX(3), CSY(3) - REAL :: K1, eSI, eVS, eVD - REAL :: eVal1, eVal2, eVal3 - REAL :: ien_local(6) - REAL :: DELTAL(NSPEC,3), K_X(3,NK), K_Y(3,NK), K_U(3) - REAL :: CRFS_X(3,NK), CRFS_Y(3,NK), CRFS_U(3) - REAL :: NM, CGFAK(3,NK) - REAL :: TRIA03, SIDT, CCOS, CSIN - REAL :: FL11_X, FL12_X, FL21_X, FL22_X, FL31_X, FL32_X - REAL :: FL11_Y, FL12_Y, FL21_Y, FL22_Y, FL31_Y, FL32_Y - REAL :: FL11_U, FL12_U, FL21_U, FL22_U, FL31_U, FL32_U - + INTEGER :: eIOBPDR +#endif + REAL*8 :: DTK, TMP3, D1, D2 + REAL*8 :: LAMBDA(2) + REAL*8 :: CRFS(3), K(3) + REAL*8 :: KP(3), UV_CUR(3,2) + REAL*8 :: KM(3), CSX(3), CSY(3) + REAL*8 :: K1, eSI, eVS, eVD + REAL*8 :: eVal1, eVal2, eVal3 + REAL*8 :: ien_local(6) + REAL*8 :: DELTAL(3), K_X(3,NK), K_Y(3,NK), K_U(3) + REAL*8 :: CRFS_X(3,NK), CRFS_Y(3,NK), CRFS_U(3) + REAL*8 :: NM, CGFAK(3,NK), CSINA(NTH), CCOSA(NTH) + REAL*8 :: TRIA03, SIDT, CCOS, CSIN + REAL*8 :: FL11_X, FL12_X, FL21_X, FL22_X, FL31_X, FL32_X + REAL*8 :: FL11_Y, FL12_Y, FL21_Y, FL22_Y, FL31_Y, FL32_Y + REAL*8 :: FL11_U, FL12_U, FL21_U, FL22_U, FL31_U, FL32_U + + IP_glob = iplg(IP) + ASPAR_DIAG_LOCAL = ZERO + B_JAC_LOCAL = ZERO + ASPAR_OFF_DIAG_LOCAL = ZERO + + DO ITH = 1, NTH + CCOSA(ITH) = FACX * ECOS(ITH) + CSINA(ITH) = FACX * ESIN(ITH) + IOBPTH1(ITH) = IOBDP_LOC(IP) * (1-IOBPA_LOC(IP)) * IOBPD_LOC(ITH,IP) + IOBPTH2(ITH) = IOBDP_LOC(IP) * IOBPD_LOC(ITH,IP) + ENDDO + + DO I = 1, PDLIB_CCON(IP) + + IE = PDLIB_IE_CELL2(I,IP) TRIA03 = ONETHIRD * PDLIB_TRIA(IE) - IEN_LOCAL = PDLIB_IEN(:,IE) - NI = INE(:,IE) - NI_GLOB = iplg(NI) + IEN_LOCAL = PDLIB_IEN(1:6,IE) + POS = PDLIB_POS_CELL2(I,IP) + IP1 = INE(POS_TRICK(POS,1),IE) + IP2 = INE(POS_TRICK(POS,2),IE) + IPP1 = POS_TRICK(POS,1) + IPP2 = POS_TRICK(POS,2) + NI = INE(1:3,IE) + NI_GLOB = IPLG(NI) NI_ISEA = MAPFS(1,NI_GLOB) CRFS_U = ZERO - K_U = ZERO IF (FLCUR) THEN - UV_CUR(:,1) = CX(NI_ISEA) / CLATS(NI_ISEA) - UV_CUR(:,2) = CY(NI_ISEA) - LAMBDA(1)=ONESIXTH*(UV_CUR(1,1)+UV_CUR(2,1)+UV_CUR(3,1)) - LAMBDA(2)=ONESIXTH*(UV_CUR(1,2)+UV_CUR(2,2)+UV_CUR(3,2)) + + UV_CUR(1:3,1) = FACX * CX(NI_ISEA) / CLATS(NI_ISEA) + UV_CUR(1:3,2) = FACY * CY(NI_ISEA) + + LAMBDA(1) = ONESIXTH*(UV_CUR(1,1)+UV_CUR(2,1)+UV_CUR(3,1)) + LAMBDA(2) = ONESIXTH*(UV_CUR(1,2)+UV_CUR(2,2)+UV_CUR(3,2)) + K_U(1) = LAMBDA(1) * IEN_LOCAL(1) + LAMBDA(2) * IEN_LOCAL(2) K_U(2) = LAMBDA(1) * IEN_LOCAL(3) + LAMBDA(2) * IEN_LOCAL(4) K_U(3) = LAMBDA(1) * IEN_LOCAL(5) + LAMBDA(2) * IEN_LOCAL(6) - FL11_U = UV_CUR(2,1)*IEN_LOCAL(1)+UV_CUR(2,2)*IEN_LOCAL(2) - FL12_U = UV_CUR(3,1)*IEN_LOCAL(1)+UV_CUR(3,2)*IEN_LOCAL(2) - FL21_U = UV_CUR(3,1)*IEN_LOCAL(3)+UV_CUR(3,2)*IEN_LOCAL(4) - FL22_U = UV_CUR(1,1)*IEN_LOCAL(3)+UV_CUR(1,2)*IEN_LOCAL(4) - FL31_U = UV_CUR(1,1)*IEN_LOCAL(5)+UV_CUR(1,2)*IEN_LOCAL(6) - FL32_U = UV_CUR(2,1)*IEN_LOCAL(5)+UV_CUR(2,2)*IEN_LOCAL(6) + + FL11_U = UV_CUR(2,1)*IEN_LOCAL(1)+UV_CUR(2,2)*IEN_LOCAL(2) + FL12_U = UV_CUR(3,1)*IEN_LOCAL(1)+UV_CUR(3,2)*IEN_LOCAL(2) + FL21_U = UV_CUR(3,1)*IEN_LOCAL(3)+UV_CUR(3,2)*IEN_LOCAL(4) + FL22_U = UV_CUR(1,1)*IEN_LOCAL(3)+UV_CUR(1,2)*IEN_LOCAL(4) + FL31_U = UV_CUR(1,1)*IEN_LOCAL(5)+UV_CUR(1,2)*IEN_LOCAL(6) + FL32_U = UV_CUR(2,1)*IEN_LOCAL(5)+UV_CUR(2,2)*IEN_LOCAL(6) + CRFS_U(1) = - ONESIXTH*(2.d0 *FL31_U + FL32_U + FL21_U + 2.d0 * FL22_U) CRFS_U(2) = - ONESIXTH*(2.d0 *FL32_U + 2.d0 * FL11_U + FL12_U + FL31_U) CRFS_U(3) = - ONESIXTH*(2.d0 *FL12_U + 2.d0 * FL21_U + FL22_U + FL11_U) + ENDIF DO IK = 1, NK @@ -4471,503 +4249,719 @@ SUBROUTINE calcARRAY_JACOBI5(IE,DTG,FACX,FACY,VGX,VGY) FL22_Y = CSY(1) * IEN_LOCAL(4) FL31_Y = CSY(1) * IEN_LOCAL(6) FL32_Y = CSY(2) * IEN_LOCAL(6) - CRFS_X(1,IK) = - ONESIXTH * (2.d0*FL31_X + FL32_X + FL21_X + 2.d0 * FL22_X) - CRFS_X(2,IK) = - ONESIXTH * (2.d0*FL32_X + 2.d0 * FL11_X + FL12_X + FL31_X) - CRFS_X(3,IK) = - ONESIXTH * (2.d0*FL12_X + 2.d0 * FL21_X + FL22_X + FL11_X) - CRFS_Y(1,IK) = - ONESIXTH * (2.d0*FL31_Y + FL32_Y + FL21_Y + 2.d0 * FL22_Y) - CRFS_Y(2,IK) = - ONESIXTH * (2.d0*FL32_Y + 2.d0 * FL11_Y + FL12_Y + FL31_Y) - CRFS_Y(3,IK) = - ONESIXTH * (2.d0*FL12_Y + 2.d0 * FL21_Y + FL22_Y + FL11_Y) + CRFS_X(1,IK) = - ONESIXTH*(2.d0*FL31_X + FL32_X + FL21_X + 2.d0 * FL22_X) + CRFS_X(2,IK) = - ONESIXTH*(2.d0*FL32_X + 2.d0 * FL11_X + FL12_X + FL31_X) + CRFS_X(3,IK) = - ONESIXTH*(2.d0*FL12_X + 2.d0 * FL21_X + FL22_X + FL11_X) + CRFS_Y(1,IK) = - ONESIXTH*(2.d0*FL31_Y + FL32_Y + FL21_Y + 2.d0 * FL22_Y) + CRFS_Y(2,IK) = - ONESIXTH*(2.d0*FL32_Y + 2.d0 * FL11_Y + FL12_Y + FL31_Y) + CRFS_Y(3,IK) = - ONESIXTH*(2.d0*FL12_Y + 2.d0 * FL21_Y + FL22_Y + FL11_Y) ENDDO - DO ISP=1,NSPEC + DO ISP = 1, NSPEC ITH = 1 + MOD(ISP-1,NTH) IK = 1 + (ISP-1)/NTH - CCOS = FACX * ECOS(ITH) - CSIN = FACY * ESIN(ITH) - K = K_X(:,IK) * CCOS + K_Y(:,IK) * CSIN + K_U - CRFS = CRFS_X(:,IK) * CCOS + CRFS_Y(:,IK) * CSIN + CRFS_U - KM = MIN(ZERO,K) - KP = MAX(ZERO,K) - DELTAL(ISP,:) = CRFS - KP - NM = 1.d0/MIN(-THR,SUM(KM)) - DTK = KP * DTG * IOBDP_LOC(NI) * IOBPD_LOC(ITH,NI) * (1-IOBPA_LOC(NI)) - TMP3(ISP,:) = DTK * NM - ENDDO - - DO I = 1, 3 - IP = NI(I) - IP1 = INE(POS_TRICK(I,1),IE) - IP2 = INE(POS_TRICK(I,2),IE) - IPP1 = POS_TRICK(I,1) - IPP2 = POS_TRICK(I,2) - !ASPAR_DIAG(:,IP) = ASPAR_DIAG(:,IP) + TRIA03 + DTK(I) - TMP3(:,I) * DELTAL - !ASPAR_OFF_DIAG(:,IP1) = ASPAR_OFF_DIAG(:,IP1) - TMP3(:,IPP1) * DELTAL(:,IPP1) * VA(:,IP1) - !ASPAR_OFF_DIAG(:,IP2) = ASPAR_OFF_DIAG(:,IP2) - TMP3(:,IPP2) * DELTAL(:,IPP2) * VA(:,IP2) - ENDDO - END SUBROUTINE calcARRAY_JACOBI5 -!/ ------------------------------------------------------------------- / - SUBROUTINE calcARRAY_JACOBI_SPECTRAL_1(DTG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute matrix coefficients for spectral part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + K(1) = K_X(1,IK) * CCOSA(ITH) + K_Y(1,IK) * CSINA(ITH) + K_U(1) + K(2) = K_X(2,IK) * CCOSA(ITH) + K_Y(2,IK) * CSINA(ITH) + K_U(2) + K(3) = K_X(3,IK) * CCOSA(ITH) + K_Y(3,IK) * CSINA(ITH) + K_U(3) + CRFS(1) = CRFS_X(1,IK) * CCOSA(ITH) + CRFS_Y(1,IK) * CSINA(ITH) + CRFS_U(1) + CRFS(2) = CRFS_X(2,IK) * CCOSA(ITH) + CRFS_Y(2,IK) * CSINA(ITH) + CRFS_U(2) + CRFS(3) = CRFS_X(3,IK) * CCOSA(ITH) + CRFS_Y(3,IK) * CSINA(ITH) + CRFS_U(3) + !KM = MIN(ZERO,K) + KP(1:3) = MAX(ZERO,K(1:3)) + DELTAL(1:3) = CRFS(1:3) - KP(1:3) + !NM = 1.d0/MIN(-THR,SUM(MIN(ZERO,K))) + DTK = KP(POS) * DTG * IOBPTH1(ITH)!IOBDP(IP_glob) * (1-IOBPA(IP_glob)) * IOBPD(ITH,IP_glob) + !write(*,*) IOBDP(IP_glob) , (1-IOBPA(IP_glob)), IOBPD(ITH,IP_glob) + TMP3 = DTK * 1.d0/MIN(-THR,SUM(MIN(ZERO,K(1:3)))) + IF (FSGEOADVECT) THEN + ASPAR_DIAG_LOCAL(ISP) = ASPAR_DIAG_LOCAL(ISP) + TRIA03 + DTK - TMP3*DELTAL(POS) + D1 = DELTAL(IPP1)*VA(ISP,IP1) + D2 = DELTAL(IPP2)*VA(ISP,IP2) + ASPAR_OFF_DIAG_LOCAL(ISP) = ASPAR_OFF_DIAG_LOCAL(ISP) - ( TMP3 * ( D1 + D2 ) ) + !ASPAR_OFF_DIAG_LOCAL(ISP) = ASPAR_OFF_DIAG_LOCAL(ISP) - D2 + ELSE + ASPAR_DIAG_LOCAL(ISP) = ASPAR_DIAG_LOCAL(ISP) + TRIA03 + END IF + B_JAC_LOCAL(ISP) = B_JAC_LOCAL(ISP) + TRIA03 * VAOLD(ISP,IP) * IOBPTH2(ITH)!IOBDP(IP_glob) * IOBPD(ITH,IP_glob) + END DO + END DO + END SUBROUTINE calcARRAY_JACOBI4 + !/ ------------------------------------------------------------------- / + SUBROUTINE calcARRAY_JACOBI5(IE,DTG,FACX,FACY,VGX,VGY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute matrix coefficients for advection part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only: FSREFRACTION, FSFREQSHIFT, FACHFA - USE W3ODATMD, only : IAPROC - USE YOWNODEPOOL, only: np, iplg, PDLIB_SI, PDLIB_I_DIAG - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3IDATMD, only: FLLEV, FLCUR - USE W3GDATMD, only: NK, NK2, NTH, NSPEC, MAPFS, DMIN, DSIP, NSEAL - USE W3PARALL, only : PROP_REFRACTION_PR3, PROP_REFRACTION_PR1, PROP_FREQ_SHIFT, PROP_FREQ_SHIFT_M2, ZERO, IMEM - USE W3ADATMD, only: CG, DW - IMPLICIT NONE - REAL, INTENT(in) :: DTG - INTEGER IP, IP_glob, ITH, IK - INTEGER ISEA, ISP - REAL :: eSI - REAL :: B_SIG(NSPEC), B_THE(NSPEC) - REAL :: CP_SIG(NSPEC), CM_SIG(NSPEC) - REAL :: CP_THE(NSPEC), CM_THE(NSPEC) - REAL :: CAD(NSPEC), CAS(NSPEC) - REAL :: DMM(0:NK2), eVal - REAL :: DWNI_M2(NK), CWNB_M2(1-NTH:NSPEC) - LOGICAL :: DoLimiterRefraction = .FALSE. - LOGICAL :: DoLimiterFreqShit = .FALSE. !AR: This one is missing ... - INTEGER :: ITH0 - - LOGICAL :: LSIG = .FALSE. - -!AR: this is missing in init ... but there is a design error in ww3_grid with FLCUR and FLLEV - LSIG = FLCUR .OR. FLLEV + USE W3SERVMD, only: STRACE +#endif + ! - DO IP = 1, np - IP_glob=iplg(IP) - ISEA=MAPFS(1,IP_glob) - eSI=PDLIB_SI(IP) - IF (FSFREQSHIFT .AND. LSIG) THEN - IF (FreqShiftMethod .eq. 1) THEN - IF (IOBP_LOC(IP).eq.1.and.IOBDP_LOC(IP).eq.1.and.IOBPA_LOC(IP).eq.0) THEN - CALL PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) - CP_SIG = MAX(ZERO,CAS) - CM_SIG = MIN(ZERO,CAS) - B_SIG=0 - DO ITH=1,NTH - DO IK=1,NK - ISP=ITH + (IK-1)*NTH - B_SIG(ISP)= CP_SIG(ISP)/DMM(IK-1) - CM_SIG(ISP)/DMM(IK) - END DO - ISP = ITH + (NK-1)*NTH - B_SIG(ISP)= B_SIG(ISP) + CM_SIG(ISP)/DMM(NK) * FACHFA + USE W3GDATMD, only: NK, NK2, NTH, NSPEC, FACHFA, DMIN + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3GDATMD, only: NSEAL, CLATS + USE W3GDATMD, only: MAPSTA, NK + USE W3WDATMD, only: VA, VAOLD + USE W3ADATMD, only: CG, DW, WN, CX, CY +#ifdef W3_MEMCHECK + USE W3ADATMD, only: MALLINFOS +#endif + USE W3IDATMD, only: FLCUR, FLLEV + USE W3GDATMD, only: ECOS, ESIN, MAPFS + USE W3PARALL, only : ONESIXTH, ZERO, THR, ONETHIRD + use yowElementpool, only: ne, INE + USE YOWNODEPOOL, only: PDLIB_IEN, PDLIB_TRIA, & + PDLIB_CCON, NP, NPA, & + PDLIB_IA_P, PDLIB_POSI, PDLIB_IA, PDLIB_NNZ, iplg, & + PDLIB_I_DIAG, PDLIB_JA + USE W3ODATMD, only : IAPROC +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif +#ifdef W3_DB1 + USE W3SDB1MD + USE W3GDATMD, only: SDBSC +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_BT9 + USE W3SBT9MD +#endif +#ifdef W3_IC1 + USE W3SIC1MD +#endif +#ifdef W3_IC2 + USE W3SIC2MD +#endif +#ifdef W3_IC3 + USE W3SIC3MD +#endif +#ifdef W3_TR1 + USE W3STR1MD +#endif + implicit none + INTEGER, INTENT(IN) :: IE + REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY + ! + INTEGER :: IP, IP1, IP2 + INTEGER :: ITH, IK + INTEGER :: POS, JSEA + INTEGER :: I, I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) + INTEGER :: ISP, IP_glob, IPP1, IPP2 + INTEGER :: counter +#ifdef W3_REF1 + INTEGER :: eIOBPDR +#endif + REAL :: DTK(3), TMP3(NSPEC,3) + REAL :: LAMBDA(2) + REAL :: CRFS(3), K(3) + REAL :: KP(3), UV_CUR(3,2) + REAL :: KM(3), CSX(3), CSY(3) + REAL :: K1, eSI, eVS, eVD + REAL :: eVal1, eVal2, eVal3 + REAL :: ien_local(6) + REAL :: DELTAL(NSPEC,3), K_X(3,NK), K_Y(3,NK), K_U(3) + REAL :: CRFS_X(3,NK), CRFS_Y(3,NK), CRFS_U(3) + REAL :: NM, CGFAK(3,NK) + REAL :: TRIA03, SIDT, CCOS, CSIN + REAL :: FL11_X, FL12_X, FL21_X, FL22_X, FL31_X, FL32_X + REAL :: FL11_Y, FL12_Y, FL21_Y, FL22_Y, FL31_Y, FL32_Y + REAL :: FL11_U, FL12_U, FL21_U, FL22_U, FL31_U, FL32_U + + TRIA03 = ONETHIRD * PDLIB_TRIA(IE) + IEN_LOCAL = PDLIB_IEN(:,IE) + NI = INE(:,IE) + NI_GLOB = iplg(NI) + NI_ISEA = MAPFS(1,NI_GLOB) + CRFS_U = ZERO + K_U = ZERO + + IF (FLCUR) THEN + UV_CUR(:,1) = CX(NI_ISEA) / CLATS(NI_ISEA) + UV_CUR(:,2) = CY(NI_ISEA) + LAMBDA(1)=ONESIXTH*(UV_CUR(1,1)+UV_CUR(2,1)+UV_CUR(3,1)) + LAMBDA(2)=ONESIXTH*(UV_CUR(1,2)+UV_CUR(2,2)+UV_CUR(3,2)) + K_U(1) = LAMBDA(1) * IEN_LOCAL(1) + LAMBDA(2) * IEN_LOCAL(2) + K_U(2) = LAMBDA(1) * IEN_LOCAL(3) + LAMBDA(2) * IEN_LOCAL(4) + K_U(3) = LAMBDA(1) * IEN_LOCAL(5) + LAMBDA(2) * IEN_LOCAL(6) + FL11_U = UV_CUR(2,1)*IEN_LOCAL(1)+UV_CUR(2,2)*IEN_LOCAL(2) + FL12_U = UV_CUR(3,1)*IEN_LOCAL(1)+UV_CUR(3,2)*IEN_LOCAL(2) + FL21_U = UV_CUR(3,1)*IEN_LOCAL(3)+UV_CUR(3,2)*IEN_LOCAL(4) + FL22_U = UV_CUR(1,1)*IEN_LOCAL(3)+UV_CUR(1,2)*IEN_LOCAL(4) + FL31_U = UV_CUR(1,1)*IEN_LOCAL(5)+UV_CUR(1,2)*IEN_LOCAL(6) + FL32_U = UV_CUR(2,1)*IEN_LOCAL(5)+UV_CUR(2,2)*IEN_LOCAL(6) + CRFS_U(1) = - ONESIXTH*(2.d0 *FL31_U + FL32_U + FL21_U + 2.d0 * FL22_U) + CRFS_U(2) = - ONESIXTH*(2.d0 *FL32_U + 2.d0 * FL11_U + FL12_U + FL31_U) + CRFS_U(3) = - ONESIXTH*(2.d0 *FL12_U + 2.d0 * FL21_U + FL22_U + FL11_U) + ENDIF + + DO IK = 1, NK + CSX = CG(IK,NI_ISEA) / CLATS(NI_ISEA) + CSY = CG(IK,NI_ISEA) + LAMBDA(1) = ONESIXTH * (CSX(1) + CSX(2) + CSX(3)) + LAMBDA(2) = ONESIXTH * (CSY(1) + CSY(2) + CSY(3)) + K_X(1,IK) = LAMBDA(1) * IEN_LOCAL(1) + K_X(2,IK) = LAMBDA(1) * IEN_LOCAL(3) + K_X(3,IK) = LAMBDA(1) * IEN_LOCAL(5) + K_Y(1,IK) = LAMBDA(2) * IEN_LOCAL(2) + K_Y(2,IK) = LAMBDA(2) * IEN_LOCAL(4) + K_Y(3,IK) = LAMBDA(2) * IEN_LOCAL(6) + FL11_X = CSX(2) * IEN_LOCAL(1) + FL12_X = CSX(3) * IEN_LOCAL(1) + FL21_X = CSX(3) * IEN_LOCAL(3) + FL22_X = CSX(1) * IEN_LOCAL(3) + FL31_X = CSX(1) * IEN_LOCAL(5) + FL32_X = CSX(2) * IEN_LOCAL(5) + FL11_Y = CSY(2) * IEN_LOCAL(2) + FL12_Y = CSY(3) * IEN_LOCAL(2) + FL21_Y = CSY(3) * IEN_LOCAL(4) + FL22_Y = CSY(1) * IEN_LOCAL(4) + FL31_Y = CSY(1) * IEN_LOCAL(6) + FL32_Y = CSY(2) * IEN_LOCAL(6) + CRFS_X(1,IK) = - ONESIXTH * (2.d0*FL31_X + FL32_X + FL21_X + 2.d0 * FL22_X) + CRFS_X(2,IK) = - ONESIXTH * (2.d0*FL32_X + 2.d0 * FL11_X + FL12_X + FL31_X) + CRFS_X(3,IK) = - ONESIXTH * (2.d0*FL12_X + 2.d0 * FL21_X + FL22_X + FL11_X) + CRFS_Y(1,IK) = - ONESIXTH * (2.d0*FL31_Y + FL32_Y + FL21_Y + 2.d0 * FL22_Y) + CRFS_Y(2,IK) = - ONESIXTH * (2.d0*FL32_Y + 2.d0 * FL11_Y + FL12_Y + FL31_Y) + CRFS_Y(3,IK) = - ONESIXTH * (2.d0*FL12_Y + 2.d0 * FL21_Y + FL22_Y + FL11_Y) + ENDDO + + DO ISP=1,NSPEC + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + CCOS = FACX * ECOS(ITH) + CSIN = FACY * ESIN(ITH) + K = K_X(:,IK) * CCOS + K_Y(:,IK) * CSIN + K_U + CRFS = CRFS_X(:,IK) * CCOS + CRFS_Y(:,IK) * CSIN + CRFS_U + KM = MIN(ZERO,K) + KP = MAX(ZERO,K) + DELTAL(ISP,:) = CRFS - KP + NM = 1.d0/MIN(-THR,SUM(KM)) + DTK = KP * DTG * IOBDP_LOC(NI) * IOBPD_LOC(ITH,NI) * (1-IOBPA_LOC(NI)) + TMP3(ISP,:) = DTK * NM + ENDDO + + DO I = 1, 3 + IP = NI(I) + IP1 = INE(POS_TRICK(I,1),IE) + IP2 = INE(POS_TRICK(I,2),IE) + IPP1 = POS_TRICK(I,1) + IPP2 = POS_TRICK(I,2) + !ASPAR_DIAG(:,IP) = ASPAR_DIAG(:,IP) + TRIA03 + DTK(I) - TMP3(:,I) * DELTAL + !ASPAR_OFF_DIAG(:,IP1) = ASPAR_OFF_DIAG(:,IP1) - TMP3(:,IPP1) * DELTAL(:,IPP1) * VA(:,IP1) + !ASPAR_OFF_DIAG(:,IP2) = ASPAR_OFF_DIAG(:,IP2) - TMP3(:,IPP2) * DELTAL(:,IPP2) * VA(:,IP2) + ENDDO + END SUBROUTINE calcARRAY_JACOBI5 + !/ ------------------------------------------------------------------- / + SUBROUTINE calcARRAY_JACOBI_SPECTRAL_1(DTG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute matrix coefficients for spectral part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only: FSREFRACTION, FSFREQSHIFT, FACHFA + USE W3ODATMD, only : IAPROC + USE YOWNODEPOOL, only: np, iplg, PDLIB_SI, PDLIB_I_DIAG + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3IDATMD, only: FLLEV, FLCUR + USE W3GDATMD, only: NK, NK2, NTH, NSPEC, MAPFS, DMIN, DSIP, NSEAL + USE W3PARALL, only : PROP_REFRACTION_PR3, PROP_REFRACTION_PR1, PROP_FREQ_SHIFT, PROP_FREQ_SHIFT_M2, ZERO, IMEM + USE W3ADATMD, only: CG, DW + IMPLICIT NONE + REAL, INTENT(in) :: DTG + INTEGER IP, IP_glob, ITH, IK + INTEGER ISEA, ISP + REAL :: eSI + REAL :: B_SIG(NSPEC), B_THE(NSPEC) + REAL :: CP_SIG(NSPEC), CM_SIG(NSPEC) + REAL :: CP_THE(NSPEC), CM_THE(NSPEC) + REAL :: CAD(NSPEC), CAS(NSPEC) + REAL :: DMM(0:NK2), eVal + REAL :: DWNI_M2(NK), CWNB_M2(1-NTH:NSPEC) + LOGICAL :: DoLimiterRefraction = .FALSE. + LOGICAL :: DoLimiterFreqShit = .FALSE. !AR: This one is missing ... + INTEGER :: ITH0 + + LOGICAL :: LSIG = .FALSE. + + !AR: this is missing in init ... but there is a design error in ww3_grid with FLCUR and FLLEV + LSIG = FLCUR .OR. FLLEV + + DO IP = 1, np + IP_glob=iplg(IP) + ISEA=MAPFS(1,IP_glob) + eSI=PDLIB_SI(IP) + IF (FSFREQSHIFT .AND. LSIG) THEN + IF (FreqShiftMethod .eq. 1) THEN + IF (IOBP_LOC(IP).eq.1.and.IOBDP_LOC(IP).eq.1.and.IOBPA_LOC(IP).eq.0) THEN + CALL PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) + CP_SIG = MAX(ZERO,CAS) + CM_SIG = MIN(ZERO,CAS) + B_SIG=0 + DO ITH=1,NTH + DO IK=1,NK + ISP=ITH + (IK-1)*NTH + B_SIG(ISP)= CP_SIG(ISP)/DMM(IK-1) - CM_SIG(ISP)/DMM(IK) END DO - ASPAR_JAC(:,PDLIB_I_DIAG(IP))=ASPAR_JAC(:,PDLIB_I_DIAG(IP)) + B_SIG(:)*eSI - ELSE - CAS=0 - END IF - CAS_SIG(:,IP) = CAS - ELSE IF (FreqShiftMethod .eq. 2) THEN - IF (IOBP_LOC(IP).eq.1) THEN - CALL PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) + ISP = ITH + (NK-1)*NTH + B_SIG(ISP)= B_SIG(ISP) + CM_SIG(ISP)/DMM(NK) * FACHFA + END DO + ASPAR_JAC(:,PDLIB_I_DIAG(IP))=ASPAR_JAC(:,PDLIB_I_DIAG(IP)) + B_SIG(:)*eSI + ELSE + CAS=0 + END IF + CAS_SIG(:,IP) = CAS + ELSE IF (FreqShiftMethod .eq. 2) THEN + IF (IOBP_LOC(IP).eq.1) THEN + CALL PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) 'sum(CWNB_M2)=', sum(CWNB_M2) + WRITE(740+IAPROC,*) 'sum(CWNB_M2)=', sum(CWNB_M2) #endif - DO ITH=1,NTH - DO IK=1,NK - ISP = ITH + (IK-1)*NTH - eVal = DWNI_M2(IK) * ( MIN(CWNB_M2(ISP - NTH), ZERO) - MAX(CWNB_M2(ISP),ZERO) ) - ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - eSI * eVal - END DO - eVal = DWNI_M2(NK) * MIN(CWNB_M2(ITH + (NK-1)*NTH), ZERO) * FACHFA - ITH0 = NSPEC - NTH - ASPAR_JAC(ITH0 + ITH,PDLIB_I_DIAG(IP)) = ASPAR_JAC(ITH0 + ITH,PDLIB_I_DIAG(IP)) + eSI * eVal + DO ITH=1,NTH + DO IK=1,NK + ISP = ITH + (IK-1)*NTH + eVal = DWNI_M2(IK) * ( MIN(CWNB_M2(ISP - NTH), ZERO) - MAX(CWNB_M2(ISP),ZERO) ) + ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - eSI * eVal END DO - ELSE - CWNB_M2 = 0 - END IF - CWNB_SIG_M2(:,IP)=CWNB_M2 + eVal = DWNI_M2(NK) * MIN(CWNB_M2(ITH + (NK-1)*NTH), ZERO) * FACHFA + ITH0 = NSPEC - NTH + ASPAR_JAC(ITH0 + ITH,PDLIB_I_DIAG(IP)) = ASPAR_JAC(ITH0 + ITH,PDLIB_I_DIAG(IP)) + eSI * eVal + END DO + ELSE + CWNB_M2 = 0 END IF + CWNB_SIG_M2(:,IP)=CWNB_M2 END IF + END IF + ! + ! The refraction + ! + IF (FSREFRACTION) THEN ! - ! The refraction - ! - IF (FSREFRACTION) THEN -! - !IF ((MAPSTA(1,IP_glob) .eq. 1).and.(SUM(IOBPD(:,IP_glob)) .EQ. NTH)) THEN - !IF (MAPSTA(1,IP_glob) .eq. 1) THEN - !IF (IOBP(IP_glob) .eq. 1) THEN - IF (IOBP_LOC(IP) .eq. 1 .and. IOBDP_LOC(IP).eq.1.and.IOBPA_LOC(IP).eq.0) THEN -! CALL PROP_REFRACTION_PR1(ISEA,DTG,CAD) !AR: Is this working? -! CALL PROP_REFRACTION_PR3(ISEA,DTG,CAD, DoLimiterRefraction) - CALL PROP_REFRACTION_PR3(IP,ISEA,DTG,CAD,DoLimiterRefraction) - ELSE - CAD=ZERO - END IF -#ifdef W3_DEBUGREFRACTION - WRITE(740+IAPROC,*) 'refraction IP=', IP, ' ISEA=', ISEA - WRITE(740+IAPROC,*) 'sum(abs(CAD))=', sum(abs(CAD)) -#endif - CAD_THE(:,IP)=CAD - CP_THE = DTG*MAX(ZERO,CAD) - CM_THE = DTG*MIN(ZERO,CAD) - B_THE(:) = CP_THE(:) - CM_THE(:) - ASPAR_JAC(:,PDLIB_I_DIAG(IP))=ASPAR_JAC(:,PDLIB_I_DIAG(IP)) + B_THE(:)*eSI + !IF ((MAPSTA(1,IP_glob) .eq. 1).and.(SUM(IOBPD(:,IP_glob)) .EQ. NTH)) THEN + !IF (MAPSTA(1,IP_glob) .eq. 1) THEN + !IF (IOBP(IP_glob) .eq. 1) THEN + IF (IOBP_LOC(IP) .eq. 1 .and. IOBDP_LOC(IP).eq.1.and.IOBPA_LOC(IP).eq.0) THEN + ! CALL PROP_REFRACTION_PR1(ISEA,DTG,CAD) !AR: Is this working? + ! CALL PROP_REFRACTION_PR3(ISEA,DTG,CAD, DoLimiterRefraction) + CALL PROP_REFRACTION_PR3(IP,ISEA,DTG,CAD,DoLimiterRefraction) + ELSE + CAD=ZERO END IF - END DO - END SUBROUTINE calcARRAY_JACOBI_SPECTRAL_1 -!/ ------------------------------------------------------------------- / - SUBROUTINE calcARRAY_JACOBI_SPECTRAL_2(DTG,ASPAR_DIAG_LOCAL) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute matrix coefficients for spectral part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -! -!/ ------------------------------------------------------------------- / +#ifdef W3_DEBUGREFRACTION + WRITE(740+IAPROC,*) 'refraction IP=', IP, ' ISEA=', ISEA + WRITE(740+IAPROC,*) 'sum(abs(CAD))=', sum(abs(CAD)) +#endif + CAD_THE(:,IP)=CAD + CP_THE = DTG*MAX(ZERO,CAD) + CM_THE = DTG*MIN(ZERO,CAD) + B_THE(:) = CP_THE(:) - CM_THE(:) + ASPAR_JAC(:,PDLIB_I_DIAG(IP))=ASPAR_JAC(:,PDLIB_I_DIAG(IP)) + B_THE(:)*eSI + END IF + END DO + END SUBROUTINE calcARRAY_JACOBI_SPECTRAL_1 + !/ ------------------------------------------------------------------- / + SUBROUTINE calcARRAY_JACOBI_SPECTRAL_2(DTG,ASPAR_DIAG_LOCAL) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute matrix coefficients for spectral part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3GDATMD, only: FSREFRACTION, FSFREQSHIFT, FACHFA - USE W3ODATMD, only : IAPROC - USE YOWNODEPOOL, only: np, iplg, PDLIB_SI, PDLIB_I_DIAG - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3IDATMD, only: FLLEV, FLCUR - USE W3GDATMD, only: NK, NK2, NTH, NSPEC, MAPFS, DMIN, DSIP, NSEAL, MAPSTA - USE W3PARALL, only : PROP_REFRACTION_PR3, PROP_REFRACTION_PR1, PROP_FREQ_SHIFT, PROP_FREQ_SHIFT_M2, ZERO, IMEM - USE W3ADATMD, only: CG, DW - IMPLICIT NONE - REAL, INTENT(in) :: DTG - REAL, INTENT(inout) :: ASPAR_DIAG_LOCAL(nspec,NSEAL) - INTEGER IP, IP_glob, ITH, IK - INTEGER ISEA, ISP - REAL :: eSI - REAL :: B_SIG(NSPEC), B_THE(NSPEC) - REAL :: CP_SIG(NSPEC), CM_SIG(NSPEC) - REAL :: CP_THE(NSPEC), CM_THE(NSPEC) - REAL :: CAD(NSPEC), CAS(NSPEC) - REAL :: DMM(0:NK2), eVal - REAL :: DWNI_M2(NK), CWNB_M2(1-NTH:NSPEC) - LOGICAL :: DoLimiterRefraction = .FALSE. - LOGICAL :: DoLimiterFreqShit = .FALSE. !AR: This one is missing ... - INTEGER :: ITH0 - - LOGICAL :: LSIG = .FALSE. - -!AR: this is missing in init ... but there is a design error in ww3_grid with FLCUR and FLLEV - LSIG = FLCUR .OR. FLLEV - - DO IP = 1, np + USE W3SERVMD, only: STRACE +#endif + ! + USE W3GDATMD, only: FSREFRACTION, FSFREQSHIFT, FACHFA + USE W3ODATMD, only : IAPROC + USE YOWNODEPOOL, only: np, iplg, PDLIB_SI, PDLIB_I_DIAG + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3IDATMD, only: FLLEV, FLCUR + USE W3GDATMD, only: NK, NK2, NTH, NSPEC, MAPFS, DMIN, DSIP, NSEAL, MAPSTA + USE W3PARALL, only : PROP_REFRACTION_PR3, PROP_REFRACTION_PR1, PROP_FREQ_SHIFT, PROP_FREQ_SHIFT_M2, ZERO, IMEM + USE W3ADATMD, only: CG, DW + IMPLICIT NONE + REAL, INTENT(in) :: DTG + REAL, INTENT(inout) :: ASPAR_DIAG_LOCAL(nspec,NSEAL) + INTEGER IP, IP_glob, ITH, IK + INTEGER ISEA, ISP + REAL :: eSI + REAL :: B_SIG(NSPEC), B_THE(NSPEC) + REAL :: CP_SIG(NSPEC), CM_SIG(NSPEC) + REAL :: CP_THE(NSPEC), CM_THE(NSPEC) + REAL :: CAD(NSPEC), CAS(NSPEC) + REAL :: DMM(0:NK2), eVal + REAL :: DWNI_M2(NK), CWNB_M2(1-NTH:NSPEC) + LOGICAL :: DoLimiterRefraction = .FALSE. + LOGICAL :: DoLimiterFreqShit = .FALSE. !AR: This one is missing ... + INTEGER :: ITH0 + + LOGICAL :: LSIG = .FALSE. + + !AR: this is missing in init ... but there is a design error in ww3_grid with FLCUR and FLLEV + LSIG = FLCUR .OR. FLLEV + + DO IP = 1, np - IP_glob=iplg(IP) - ISEA=MAPFS(1,IP_glob) - eSI=PDLIB_SI(IP) - ! - ! The frequency shifting - ! - IF (FSFREQSHIFT .AND. LSIG) THEN - IF (FreqShiftMethod .eq. 1) THEN - IF (IOBP_LOC(IP).eq.1.and.IOBDP_LOC(IP).eq.1.and.IOBPA_LOC(IP).eq.0) THEN - CALL PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) - CP_SIG = MAX(ZERO,CAS) - CM_SIG = MIN(ZERO,CAS) - B_SIG=0 - DO ITH=1,NTH - DO IK=1,NK - ISP=ITH + (IK-1)*NTH - B_SIG(ISP)= CP_SIG(ISP)/DMM(IK-1) - CM_SIG(ISP)/DMM(IK) - END DO - ISP = ITH + (NK-1)*NTH - B_SIG(ISP)= B_SIG(ISP) + CM_SIG(ISP)/DMM(NK) * FACHFA + IP_glob=iplg(IP) + ISEA=MAPFS(1,IP_glob) + eSI=PDLIB_SI(IP) + ! + ! The frequency shifting + ! + IF (FSFREQSHIFT .AND. LSIG) THEN + IF (FreqShiftMethod .eq. 1) THEN + IF (IOBP_LOC(IP).eq.1.and.IOBDP_LOC(IP).eq.1.and.IOBPA_LOC(IP).eq.0) THEN + CALL PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) + CP_SIG = MAX(ZERO,CAS) + CM_SIG = MIN(ZERO,CAS) + B_SIG=0 + DO ITH=1,NTH + DO IK=1,NK + ISP=ITH + (IK-1)*NTH + B_SIG(ISP)= CP_SIG(ISP)/DMM(IK-1) - CM_SIG(ISP)/DMM(IK) END DO - ASPAR_DIAG_LOCAL(:,IP) = ASPAR_DIAG_LOCAL(:,IP) + B_SIG * eSI - ELSE - CAS=0 - END IF - CAS_SIG(:,IP) = CAS + ISP = ITH + (NK-1)*NTH + B_SIG(ISP)= B_SIG(ISP) + CM_SIG(ISP)/DMM(NK) * FACHFA + END DO + ASPAR_DIAG_LOCAL(:,IP) = ASPAR_DIAG_LOCAL(:,IP) + B_SIG * eSI + ELSE + CAS=0 END IF + CAS_SIG(:,IP) = CAS + END IF - IF (FreqShiftMethod .eq. 2) THEN - IF (IOBP_LOC(IP).eq.1) THEN - CALL PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) + IF (FreqShiftMethod .eq. 2) THEN + IF (IOBP_LOC(IP).eq.1) THEN + CALL PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) 'sum(CWNB_M2)=', sum(CWNB_M2) + WRITE(740+IAPROC,*) 'sum(CWNB_M2)=', sum(CWNB_M2) #endif - DO ITH=1,NTH - DO IK=1,NK - ISP = ITH + (IK-1)*NTH - eVal = DWNI_M2(IK) * ( MIN(CWNB_M2(ISP - NTH), ZERO) - MAX(CWNB_M2(ISP),ZERO) ) - IF (IMEM == 1) THEN - ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - eSI * eVal - ELSE IF (IMEM == 2) THEN - ASPAR_DIAG_LOCAL(ISP,IP) = ASPAR_DIAG_LOCAL(ISP,IP) - eSI * eVal - ENDIF - END DO - eVal = DWNI_M2(NK) * MIN(CWNB_M2(ITH + (NK-1)*NTH), ZERO) * FACHFA - ITH0 = NSPEC - NTH - ASPAR_DIAG_LOCAL(ITH0 + ITH,IP) = ASPAR_DIAG_LOCAL(ITH0 + ITH,IP) + eSI * eVal + DO ITH=1,NTH + DO IK=1,NK + ISP = ITH + (IK-1)*NTH + eVal = DWNI_M2(IK) * ( MIN(CWNB_M2(ISP - NTH), ZERO) - MAX(CWNB_M2(ISP),ZERO) ) + IF (IMEM == 1) THEN + ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - eSI * eVal + ELSE IF (IMEM == 2) THEN + ASPAR_DIAG_LOCAL(ISP,IP) = ASPAR_DIAG_LOCAL(ISP,IP) - eSI * eVal + ENDIF END DO - ELSE - CWNB_M2=0 - END IF - CWNB_SIG_M2(:,IP)=CWNB_M2 - END IF - END IF - ! - IF (FSREFRACTION) THEN - !IF ((MAPSTA(1,IP_glob) .eq. 1).and.(SUM(IOBPD(:,IP_glob)) .EQ. NTH)) THEN - !IF (MAPSTA(1,IP_glob) .eq. 1) THEN - !IF (IOBP(IP_glob) .eq. 1) THEN - IF (IOBP_LOC(IP) .eq. 1.and.IOBDP_LOC(IP).eq.1.and.IOBPA_LOC(IP).eq.0) THEN -! CALL PROP_REFRACTION_PR1(ISEA,DTG,CAD) !AR: Is this working? -! CALL PROP_REFRACTION_PR3(ISEA,DTG,CAD, DoLimiterRefraction) - CALL PROP_REFRACTION_PR3(IP,ISEA,DTG,CAD,DoLimiterRefraction) + eVal = DWNI_M2(NK) * MIN(CWNB_M2(ITH + (NK-1)*NTH), ZERO) * FACHFA + ITH0 = NSPEC - NTH + ASPAR_DIAG_LOCAL(ITH0 + ITH,IP) = ASPAR_DIAG_LOCAL(ITH0 + ITH,IP) + eSI * eVal + END DO ELSE - CAD=ZERO + CWNB_M2=0 END IF -#ifdef W3_DEBUGREFRACTION - WRITE(740+IAPROC,*) 'refraction IP=', IP, ' ISEA=', ISEA - WRITE(740+IAPROC,*) 'sum(abs(CAD))=', sum(abs(CAD)) -#endif - CAD_THE(:,IP)=CAD - CP_THE = DTG*MAX(ZERO,CAD) - CM_THE = DTG*MIN(ZERO,CAD) - B_THE(:) = CP_THE(:) - CM_THE(:) - ASPAR_DIAG_LOCAL(:,IP) = ASPAR_DIAG_LOCAL(:,IP) + B_THE(:)*eSI + CWNB_SIG_M2(:,IP)=CWNB_M2 + END IF + END IF + ! + IF (FSREFRACTION) THEN + !IF ((MAPSTA(1,IP_glob) .eq. 1).and.(SUM(IOBPD(:,IP_glob)) .EQ. NTH)) THEN + !IF (MAPSTA(1,IP_glob) .eq. 1) THEN + !IF (IOBP(IP_glob) .eq. 1) THEN + IF (IOBP_LOC(IP) .eq. 1.and.IOBDP_LOC(IP).eq.1.and.IOBPA_LOC(IP).eq.0) THEN + ! CALL PROP_REFRACTION_PR1(ISEA,DTG,CAD) !AR: Is this working? + ! CALL PROP_REFRACTION_PR3(ISEA,DTG,CAD, DoLimiterRefraction) + CALL PROP_REFRACTION_PR3(IP,ISEA,DTG,CAD,DoLimiterRefraction) + ELSE + CAD=ZERO END IF +#ifdef W3_DEBUGREFRACTION + WRITE(740+IAPROC,*) 'refraction IP=', IP, ' ISEA=', ISEA + WRITE(740+IAPROC,*) 'sum(abs(CAD))=', sum(abs(CAD)) +#endif + CAD_THE(:,IP)=CAD + CP_THE = DTG*MAX(ZERO,CAD) + CM_THE = DTG*MIN(ZERO,CAD) + B_THE(:) = CP_THE(:) - CM_THE(:) + ASPAR_DIAG_LOCAL(:,IP) = ASPAR_DIAG_LOCAL(:,IP) + B_THE(:)*eSI + END IF - END DO - END SUBROUTINE calcARRAY_JACOBI_SPECTRAL_2 -!/ ------------------------------------------------------------------- / - SUBROUTINE CALCARRAY_JACOBI_SOURCE_1(DTG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute matrix coefficients for source part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END DO + END SUBROUTINE calcARRAY_JACOBI_SPECTRAL_2 + !/ ------------------------------------------------------------------- / + SUBROUTINE CALCARRAY_JACOBI_SOURCE_1(DTG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute matrix coefficients for source part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3ODATMD, only : IAPROC - USE YOWNODEPOOL, only: iplg, PDLIB_SI, PDLIB_I_DIAG, NPA, NP - USE W3ADATMD, only: CG, DW, WN - USE W3WDATMD, only: UST, USTDIR - USE W3GDATMD, only: NK, NTH, NSPEC, MAPFS, optionCall, DMIN - USE W3GDATMD, only: MAPSTA, FACP, SIG - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3PARALL, only: IMEM - USE W3GDATMD, only: NSEAL, CLATS + USE W3SERVMD, only: STRACE +#endif + ! + USE W3ODATMD, only : IAPROC + USE YOWNODEPOOL, only: iplg, PDLIB_SI, PDLIB_I_DIAG, NPA, NP + USE W3ADATMD, only: CG, DW, WN + USE W3WDATMD, only: UST, USTDIR + USE W3GDATMD, only: NK, NTH, NSPEC, MAPFS, optionCall, DMIN + USE W3GDATMD, only: MAPSTA, FACP, SIG + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3PARALL, only: IMEM + USE W3GDATMD, only: NSEAL, CLATS #ifdef W3_DB1 - USE W3SDB1MD - USE W3GDATMD, only: SDBSC + USE W3SDB1MD + USE W3GDATMD, only: SDBSC #endif #ifdef W3_DB2 - USE W3SDB2MD -#endif - USE W3WDATMD, only: VA, VSTOT, VDTOT, SHAVETOT - USE constants, only : TPI, TPIINV, GRAV - IMPLICIT NONE - REAL, INTENT(in) :: DTG - REAL, PARAMETER :: COEF4 = 5.0E-07 - REAL, PARAMETER :: FACDAM = 1 - INTEGER JSEA, IP, IP_glob, ISEA - INTEGER IK, ITH, ISP, IS0 - LOGICAL :: LBREAK - REAL :: eSI, eVS, eVD, SIDT - REAL :: DEPTH, DAM(NSPEC), RATIO, MAXDAC, VSDB(NSPEC), VDDB(NSPEC) - REAL :: PreVS, eDam, DVS, FREQ, EMEAN, FMEAN, WNMEAN, AMAX, CG1(NK),WN1(NK),SPEC_VA(NSPEC) - REAL TheFactor - - DO JSEA = 1, NP - - IP = JSEA - IP_glob = iplg(IP) - ISEA = MAPFS(1,IP_glob) - - IF ((IOBP_LOC(IP).eq.1..or.IOBP_LOC(JSEA).eq. 3).and.IOBDP_LOC(IP).eq.1.and.IOBPA_LOC(IP).eq.0) THEN - - DO IK=1, NK - DAM(1+(IK-1)*NTH) = FACP / ( SIG(IK) * WN(IK,ISEA)**3 ) - END DO - DO IK=1, NK - IS0 = (IK-1)*NTH - DO ITH=2, NTH - DAM(ITH+IS0) = DAM(1+IS0) - END DO + USE W3SDB2MD +#endif + USE W3WDATMD, only: VA, VSTOT, VDTOT, SHAVETOT + USE constants, only : TPI, TPIINV, GRAV + IMPLICIT NONE + REAL, INTENT(in) :: DTG + REAL, PARAMETER :: COEF4 = 5.0E-07 + REAL, PARAMETER :: FACDAM = 1 + INTEGER JSEA, IP, IP_glob, ISEA + INTEGER IK, ITH, ISP, IS0 + LOGICAL :: LBREAK + REAL :: eSI, eVS, eVD, SIDT + REAL :: DEPTH, DAM(NSPEC), RATIO, MAXDAC, VSDB(NSPEC), VDDB(NSPEC) + REAL :: PreVS, eDam, DVS, FREQ, EMEAN, FMEAN, WNMEAN, AMAX, CG1(NK),WN1(NK),SPEC_VA(NSPEC) + REAL TheFactor + + DO JSEA = 1, NP + + IP = JSEA + IP_glob = iplg(IP) + ISEA = MAPFS(1,IP_glob) + + IF ((IOBP_LOC(IP).eq.1..or.IOBP_LOC(JSEA).eq. 3).and.IOBDP_LOC(IP).eq.1.and.IOBPA_LOC(IP).eq.0) THEN + + DO IK=1, NK + DAM(1+(IK-1)*NTH) = FACP / ( SIG(IK) * WN(IK,ISEA)**3 ) + END DO + DO IK=1, NK + IS0 = (IK-1)*NTH + DO ITH=2, NTH + DAM(ITH+IS0) = DAM(1+IS0) END DO + END DO - eSI = PDLIB_SI(IP) - SIDT = eSI * DTG - DEPTH = DW(ISEA) + eSI = PDLIB_SI(IP) + SIDT = eSI * DTG + DEPTH = DW(ISEA) #ifdef W3_DB1 - VSDB = 0. - VDDB = 0. - CG1 = CG(1:NK,ISEA) - WN1 = WN(1:NK,ISEA) - DO IK=1,NK - DO ITH=1,NTH - ISP=ITH + (IK-1)*NTH - SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) - ENDDO + VSDB = 0. + VDDB = 0. + CG1 = CG(1:NK,ISEA) + WN1 = WN(1:NK,ISEA) + DO IK=1,NK + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) ENDDO - CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) - SELECT CASE (NINT(SDBSC)) - CASE(1) - CALL W3SDB1 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, LBREAK, VSDB, VDDB ) - CASE(2) - !CALL W3SDB2 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, CG1, LBREAK, VSDB, VDDB ) - END SELECT + ENDDO + CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + SELECT CASE (NINT(SDBSC)) + CASE(1) + CALL W3SDB1 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, LBREAK, VSDB, VDDB ) + CASE(2) + !CALL W3SDB2 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, CG1, LBREAK, VSDB, VDDB ) + END SELECT #endif #ifdef W3_DB2 - VSDB = 0. - VDDB = 0. - CG1 = CG(1:NK,ISEA) - WN1 = WN(1:NK,ISEA) - DO IK=1,NK - DO ITH=1,NTH - ISP=ITH + (IK-1)*NTH - SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) - ENDDO + VSDB = 0. + VDDB = 0. + CG1 = CG(1:NK,ISEA) + WN1 = WN(1:NK,ISEA) + DO IK=1,NK + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) ENDDO - CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) - CALL W3SDB2 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, CG1, LBREAK, VSDB, VDDB ) + ENDDO + CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + CALL W3SDB2 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, CG1, LBREAK, VSDB, VDDB ) #endif -! IF (JSEA == 10000) WRITE(*,'(2I20,10F20.10)') JSEA, ISEA, SUM(VSTOT(:,JSEA)), SUM(VDTOT(:,JSEA)), SUM(VSDB),SUM(VDDB), DEPTH, EMEAN, FMEAN, WNMEAN - DO IK=1,NK - DO ITH=1,NTH - ISP=ITH + (IK-1)*NTH - IF (SHAVETOT(JSEA)) THEN ! Limit only the source term part ... - MAXDAC = FACDAM * DAM(ISP) - TheFactor = DTG / MAX ( 1. , (1.-DTG*VDTOT(ISP,JSEA))) - DVS = VSTOT(ISP,JSEA) * TheFactor - DVS = SIGN(MIN(MAXDAC,ABS(DVS)),DVS) - PreVS = DVS / TheFactor - ELSE - PreVS = VSTOT(ISP,JSEA) - END IF - eVS = PreVS * CLATS(ISEA) / CG(IK,ISEA) - eVD = DBLE(VDTOT(ISP,JSEA)) + ! IF (JSEA == 10000) WRITE(*,'(2I20,10F20.10)') JSEA, ISEA, SUM(VSTOT(:,JSEA)), SUM(VDTOT(:,JSEA)), SUM(VSDB),SUM(VDDB), DEPTH, EMEAN, FMEAN, WNMEAN + DO IK=1,NK + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + IF (SHAVETOT(JSEA)) THEN ! Limit only the source term part ... + MAXDAC = FACDAM * DAM(ISP) + TheFactor = DTG / MAX ( 1. , (1.-DTG*VDTOT(ISP,JSEA))) + DVS = VSTOT(ISP,JSEA) * TheFactor + DVS = SIGN(MIN(MAXDAC,ABS(DVS)),DVS) + PreVS = DVS / TheFactor + ELSE + PreVS = VSTOT(ISP,JSEA) + END IF + eVS = PreVS * CLATS(ISEA) / CG(IK,ISEA) + eVD = DBLE(VDTOT(ISP,JSEA)) #ifdef W3_DB1 eVS = eVS + DBLE(VSDB(ISP)) / CG(IK,ISEA) * CLATS(ISEA) eVD = evD + DBLE(VDDB(ISP)) @@ -4976,164 +4970,164 @@ SUBROUTINE CALCARRAY_JACOBI_SOURCE_1(DTG) eVS = eVS + DBLE(VSDB(ISP)) / CG(IK,ISEA) * CLATS(ISEA) eVD = evD + DBLE(VDDB(ISP)) #endif - B_JAC(ISP,IP) = B_JAC(ISP,IP) + SIDT * (eVS - eVD*VA(ISP,JSEA)) - ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - SIDT * eVD - !IF (ISEA .eq. 100) THEN - ! WRITE(*,*) ' A and B', ISP, eVS, eVD, VA(ISP,JSEA), B_JAC(ISP,IP), ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - !ENDIF - END DO + B_JAC(ISP,IP) = B_JAC(ISP,IP) + SIDT * (eVS - eVD*VA(ISP,JSEA)) + ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - SIDT * eVD + !IF (ISEA .eq. 100) THEN + ! WRITE(*,*) ' A and B', ISP, eVS, eVD, VA(ISP,JSEA), B_JAC(ISP,IP), ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) + !ENDIF END DO - !IF (IP .eq. 100) WRITE(*,*) 'SUM A and B', IP, SUM(B_JAC(:,IP)), SUM(ASPAR_JAC(:,PDLIB_I_DIAG(IP))) - END IF - END DO - END SUBROUTINE CALCARRAY_JACOBI_SOURCE_1 -!/ ------------------------------------------------------------------- / - SUBROUTINE CALCARRAY_JACOBI_SOURCE_2(DTG,ASPAR_DIAG_LOCAL) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute matrix coefficients for source part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END DO + !IF (IP .eq. 100) WRITE(*,*) 'SUM A and B', IP, SUM(B_JAC(:,IP)), SUM(ASPAR_JAC(:,PDLIB_I_DIAG(IP))) + END IF + END DO + END SUBROUTINE CALCARRAY_JACOBI_SOURCE_1 + !/ ------------------------------------------------------------------- / + SUBROUTINE CALCARRAY_JACOBI_SOURCE_2(DTG,ASPAR_DIAG_LOCAL) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute matrix coefficients for source part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE W3ODATMD, only : IAPROC - USE YOWNODEPOOL, only: iplg, PDLIB_SI, PDLIB_I_DIAG, NPA, NP - USE W3ADATMD, only: CG, DW, WN - USE W3WDATMD, only: UST, USTDIR - USE W3GDATMD, only: NK, NTH, NSPEC, MAPFS, optionCall, DMIN - USE W3GDATMD, only: IOBP, MAPSTA, FACP, SIG, IOBPD, IOBPA, IOBDP - USE W3PARALL, only: IMEM - USE W3GDATMD, only: NSEAL, CLATS + USE W3SERVMD, only: STRACE +#endif + ! + USE W3ODATMD, only : IAPROC + USE YOWNODEPOOL, only: iplg, PDLIB_SI, PDLIB_I_DIAG, NPA, NP + USE W3ADATMD, only: CG, DW, WN + USE W3WDATMD, only: UST, USTDIR + USE W3GDATMD, only: NK, NTH, NSPEC, MAPFS, optionCall, DMIN + USE W3GDATMD, only: IOBP, MAPSTA, FACP, SIG, IOBPD, IOBPA, IOBDP + USE W3PARALL, only: IMEM + USE W3GDATMD, only: NSEAL, CLATS #ifdef W3_DB1 - USE W3SDB1MD - USE W3GDATMD, only: SDBSC + USE W3SDB1MD + USE W3GDATMD, only: SDBSC #endif #ifdef W3_DB2 - USE W3SDB2MD -#endif - USE W3WDATMD, only: VA, VSTOT, VDTOT, SHAVETOT - USE constants, only : TPI, TPIINV, GRAV - IMPLICIT NONE - REAL, INTENT(in) :: DTG - REAL, INTENT(inout) :: ASPAR_DIAG_LOCAL(:,:) - REAL, PARAMETER :: COEF4 = 5.0E-07 - REAL, PARAMETER :: FACDAM = 1 - INTEGER JSEA, IP, IP_glob, ISEA - INTEGER IK, ITH, ISP, IS0 - LOGICAL :: LBREAK - REAL :: eSI, eVS, eVD, SIDT - REAL :: DEPTH, DAM(NSPEC), RATIO, MAXDAC, VSDB(NSPEC), VDDB(NSPEC) - REAL :: PreVS, eDam, DVS, FREQ, EMEAN, FMEAN, WNMEAN, AMAX, CG1(NK),WN1(NK),SPEC_VA(NSPEC) - REAL TheFactor - - DO JSEA = 1, NP - - IP = JSEA - IP_glob = iplg(IP) - ISEA = MAPFS(1,IP_glob) - - IF (IOBP(IP_glob).eq.1..and.IOBDP(IP_glob).eq.1.and.IOBPA(IP_glob).eq.0) THEN - DO IK=1, NK - DAM(1+(IK-1)*NTH) = FACP / ( SIG(IK) * WN(IK,ISEA)**3 ) - END DO - DO IK=1, NK - IS0 = (IK-1)*NTH - DO ITH=2, NTH - DAM(ITH+IS0) = DAM(1+IS0) - END DO + USE W3SDB2MD +#endif + USE W3WDATMD, only: VA, VSTOT, VDTOT, SHAVETOT + USE constants, only : TPI, TPIINV, GRAV + IMPLICIT NONE + REAL, INTENT(in) :: DTG + REAL, INTENT(inout) :: ASPAR_DIAG_LOCAL(:,:) + REAL, PARAMETER :: COEF4 = 5.0E-07 + REAL, PARAMETER :: FACDAM = 1 + INTEGER JSEA, IP, IP_glob, ISEA + INTEGER IK, ITH, ISP, IS0 + LOGICAL :: LBREAK + REAL :: eSI, eVS, eVD, SIDT + REAL :: DEPTH, DAM(NSPEC), RATIO, MAXDAC, VSDB(NSPEC), VDDB(NSPEC) + REAL :: PreVS, eDam, DVS, FREQ, EMEAN, FMEAN, WNMEAN, AMAX, CG1(NK),WN1(NK),SPEC_VA(NSPEC) + REAL TheFactor + + DO JSEA = 1, NP + + IP = JSEA + IP_glob = iplg(IP) + ISEA = MAPFS(1,IP_glob) + + IF (IOBP(IP_glob).eq.1..and.IOBDP(IP_glob).eq.1.and.IOBPA(IP_glob).eq.0) THEN + DO IK=1, NK + DAM(1+(IK-1)*NTH) = FACP / ( SIG(IK) * WN(IK,ISEA)**3 ) + END DO + DO IK=1, NK + IS0 = (IK-1)*NTH + DO ITH=2, NTH + DAM(ITH+IS0) = DAM(1+IS0) END DO - eSI = PDLIB_SI(IP) - SIDT = eSI * DTG - DEPTH = DW(ISEA) + END DO + eSI = PDLIB_SI(IP) + SIDT = eSI * DTG + DEPTH = DW(ISEA) #ifdef W3_DB1 - VSDB = 0. - VDDB = 0. - CG1 = CG(1:NK,ISEA) - WN1 = WN(1:NK,ISEA) - DO IK=1,NK - DO ITH=1,NTH - ISP=ITH + (IK-1)*NTH - SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) - ENDDO + VSDB = 0. + VDDB = 0. + CG1 = CG(1:NK,ISEA) + WN1 = WN(1:NK,ISEA) + DO IK=1,NK + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) ENDDO - CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) - SELECT CASE (NINT(SDBSC)) - CASE(1) - CALL W3SDB1 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, LBREAK, VSDB, VDDB ) - CASE(2) - !CALL W3SDB2 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, CG1, LBREAK, VSDB, VDDB ) - END SELECT + ENDDO + CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + SELECT CASE (NINT(SDBSC)) + CASE(1) + CALL W3SDB1 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, LBREAK, VSDB, VDDB ) + CASE(2) + !CALL W3SDB2 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, CG1, LBREAK, VSDB, VDDB ) + END SELECT #endif #ifdef W3_DB2 - VSDB = 0. - VDDB = 0. - CG1 = CG(1:NK,ISEA) - WN1 = WN(1:NK,ISEA) - DO IK=1,NK - DO ITH=1,NTH - ISP=ITH + (IK-1)*NTH - SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) - ENDDO + VSDB = 0. + VDDB = 0. + CG1 = CG(1:NK,ISEA) + WN1 = WN(1:NK,ISEA) + DO IK=1,NK + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) ENDDO - CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) - CALL W3SDB2 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, CG1, LBREAK, VSDB, VDDB ) + ENDDO + CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + CALL W3SDB2 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, CG1, LBREAK, VSDB, VDDB ) #endif -! IF (JSEA == 10000) WRITE(*,'(2I20,10F20.10)') JSEA, ISEA, SUM(VSTOT(:,JSEA)), SUM(VDTOT(:,JSEA)), SUM(VSDB),SUM(VDDB), DEPTH, EMEAN, FMEAN, WNMEAN - DO IK=1,NK - DO ITH=1,NTH - ISP=ITH + (IK-1)*NTH - IF (SHAVETOT(JSEA)) THEN ! Limit only the source term part ... - MAXDAC = FACDAM * DAM(ISP) - TheFactor = DTG / MAX ( 1. , (1.-DTG*VDTOT(ISP,JSEA))) - DVS = VSTOT(ISP,JSEA) * TheFactor - DVS = SIGN(MIN(MAXDAC,ABS(DVS)),DVS) - PreVS = DVS / TheFactor - ELSE - PreVS = VSTOT(ISP,JSEA) - END IF - eVS = PreVS / CG(IK,ISEA) * CLATS(ISEA) - eVD = DBLE(VDTOT(ISP,JSEA)) + ! IF (JSEA == 10000) WRITE(*,'(2I20,10F20.10)') JSEA, ISEA, SUM(VSTOT(:,JSEA)), SUM(VDTOT(:,JSEA)), SUM(VSDB),SUM(VDDB), DEPTH, EMEAN, FMEAN, WNMEAN + DO IK=1,NK + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + IF (SHAVETOT(JSEA)) THEN ! Limit only the source term part ... + MAXDAC = FACDAM * DAM(ISP) + TheFactor = DTG / MAX ( 1. , (1.-DTG*VDTOT(ISP,JSEA))) + DVS = VSTOT(ISP,JSEA) * TheFactor + DVS = SIGN(MIN(MAXDAC,ABS(DVS)),DVS) + PreVS = DVS / TheFactor + ELSE + PreVS = VSTOT(ISP,JSEA) + END IF + eVS = PreVS / CG(IK,ISEA) * CLATS(ISEA) + eVD = DBLE(VDTOT(ISP,JSEA)) #ifdef W3_DB1 eVS = eVS + DBLE(VSDB(ISP)) / CG(IK,ISEA) * CLATS(ISEA) eVD = evD + DBLE(VDDB(ISP)) @@ -5142,224 +5136,94 @@ SUBROUTINE CALCARRAY_JACOBI_SOURCE_2(DTG,ASPAR_DIAG_LOCAL) eVS = eVS + DBLE(VSDB(ISP)) / CG(IK,ISEA) * CLATS(ISEA) eVD = evD + DBLE(VDDB(ISP)) #endif - B_JAC(ISP,IP) = B_JAC(ISP,IP) + SIDT * (eVS - eVD*VA(ISP,JSEA)) - ASPAR_DIAG_LOCAL(ISP,IP) = ASPAR_DIAG_LOCAL(ISP,IP) - SIDT * eVD - END DO - END DO - END IF - END DO - END SUBROUTINE CALCARRAY_JACOBI_SOURCE_2 -!/ ------------------------------------------------------------------- / - SUBROUTINE APPLY_BOUNDARY_CONDITION_VA -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Boudary conditions on VA -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, only: STRACE -#endif - USE yowRankModule, only : IPGL_npa - USE W3GDATMD, only: NSEAL, CLATS, GTYPE, UNGTYPE - USE W3WDATMD, only: TIME - USE W3TIMEMD, only: DSEC21 - USE W3ADATMD, only: CG, CX, CY - USE W3WDATMD, only: VA - USE W3GDATMD, only: NK, NK2, NTH, ECOS, ESIN, NSPEC - USE W3ODATMD, only: TBPI0, TBPIN, FLBPI, IAPROC, NAPROC, BBPI0, BBPIN, ISBPI, NBI - USE W3PARALL, only : ISEA_TO_JSEA -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ - REAL :: RD1, RD2, RD10, RD20 - REAL :: eVA, eAC - INTEGER :: IK, ITH, ISEA, JSEA - INTEGER :: IBI, ISP -#ifdef W3_S - CALL STRACE (IENT, 'APPLY_BOUNDARY_CONDITION_VA') -#endif - IF (GTYPE .eq. UNGTYPE) THEN - IF ( FLBPI ) THEN - RD10 = DSEC21 ( TBPI0, TIME ) - RD20 = DSEC21 ( TBPI0, TBPIN ) - ELSE - RD10=1. - RD20=0. - END IF - IF (FLBPI .and. (IAPROC .le. NAPROC)) THEN - RD1=RD10 ! I am not completely sure about that - RD2=RD20 - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF - DO IBI=1, NBI - ISEA=ISBPI(IBI) - JSEA=ISEA_TO_JSEA(ISEA) - IF (JSEA .gt. 0) THEN - DO ITH=1,NTH - DO IK=1,NK - ISP=ITH + (IK-1)*NTH - eAC = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) - eVA = MAX(0., CG(IK,ISEA)/CLATS(ISEA)*eAC) - VA(ISP,JSEA) = eVA - END DO - END DO - END IF + B_JAC(ISP,IP) = B_JAC(ISP,IP) + SIDT * (eVS - eVD*VA(ISP,JSEA)) + ASPAR_DIAG_LOCAL(ISP,IP) = ASPAR_DIAG_LOCAL(ISP,IP) - SIDT * eVD END DO - END IF + END DO END IF - END SUBROUTINE APPLY_BOUNDARY_CONDITION_VA -!/ ------------------------------------------------------------------- / - SUBROUTINE APPLY_BOUNDARY_CONDITION(IMOD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Apply boundary conditions -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END DO + END SUBROUTINE CALCARRAY_JACOBI_SOURCE_2 + !/ ------------------------------------------------------------------- / + SUBROUTINE APPLY_BOUNDARY_CONDITION_VA + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Boudary conditions on VA + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif - USE YOWNODEPOOL, only: npa, np - USE yowRankModule, only : IPGL_npa - USE W3GDATMD, only: NSEAL, CLATS, MAPSF - USE W3WDATMD, only: TIME - USE W3TIMEMD, only: DSEC21 - USE W3WDATMD, only : VA - USE W3ADATMD, only: CG, CX, CY - USE W3GDATMD, only: NK, NK2, NTH, NSPEC - USE W3ODATMD, only: TBPI0, TBPIN, FLBPI, IAPROC, BBPI0, BBPIN, ISBPI, NBI - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBDP_LOC, IOBPA_LOC -#ifdef W3_DEBUGIOBC - USE W3GDATMD, only: DDEN -#endif -!/ - IMPLICIT NONE - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3SERVMD, only: STRACE +#endif + USE yowRankModule, only : IPGL_npa + USE W3GDATMD, only: NSEAL, CLATS, GTYPE, UNGTYPE + USE W3WDATMD, only: TIME + USE W3TIMEMD, only: DSEC21 + USE W3ADATMD, only: CG, CX, CY + USE W3WDATMD, only: VA + USE W3GDATMD, only: NK, NK2, NTH, ECOS, ESIN, NSPEC + USE W3ODATMD, only: TBPI0, TBPIN, FLBPI, IAPROC, NAPROC, BBPI0, BBPIN, ISBPI, NBI + USE W3PARALL, only : ISEA_TO_JSEA + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_DEBUGSOLVER - REAL*8 :: sumAC(NSPEC) - REAL :: sumBPI0(NSPEC), sumBPIN(NSPEC), sumCG, sumCLATS -#endif -#ifdef W3_DEBUGIOBC - REAL :: ETOT, HSIG_bound, eVA, eAC, FACTOR -#endif - REAL :: RD1, RD2, RD10, RD20 - INTEGER :: IK, ITH, ISEA - INTEGER :: IBI, IP_glob, ISP, JX + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + REAL :: RD1, RD2, RD10, RD20 + REAL :: eVA, eAC + INTEGER :: IK, ITH, ISEA, JSEA + INTEGER :: IBI, ISP #ifdef W3_S - CALL STRACE (IENT, 'APPLY_BOUNDARY_CONDITION') -#endif -#ifdef W3_DEBUGSOLVERCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(np) before boundary", 0) - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) before boundary", 1) + CALL STRACE (IENT, 'APPLY_BOUNDARY_CONDITION_VA') #endif + IF (GTYPE .eq. UNGTYPE) THEN IF ( FLBPI ) THEN RD10 = DSEC21 ( TBPI0, TIME ) RD20 = DSEC21 ( TBPI0, TBPIN ) @@ -5367,7 +5231,7 @@ SUBROUTINE APPLY_BOUNDARY_CONDITION(IMOD) RD10=1. RD20=0. END IF - IF ( FLBPI ) THEN + IF (FLBPI .and. (IAPROC .le. NAPROC)) THEN RD1=RD10 ! I am not completely sure about that RD2=RD20 IF ( RD2 .GT. 0.001 ) THEN @@ -5377,651 +5241,781 @@ SUBROUTINE APPLY_BOUNDARY_CONDITION(IMOD) RD1 = 0. RD2 = 1. END IF -#ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'Begin of APPLY_BOUNDARY_CONDITION' - WRITE(740+IAPROC,*) 'NBI=', NBI - FLUSH(740+IAPROC) - sumAC=0 - sumBPI0=0 - sumBPIN=0 - sumCG=0 - sumCLATS=0 -#endif DO IBI=1, NBI - ISEA = ISBPI(IBI) - IP_glob = MAPSF(ISEA,1) - JX = IPGL_npa(IP_glob) - IF (JX .gt. 0) THEN + ISEA=ISBPI(IBI) + JSEA=ISEA_TO_JSEA(ISEA) + IF (JSEA .gt. 0) THEN DO ITH=1,NTH DO IK=1,NK ISP=ITH + (IK-1)*NTH - VA(ISP,JX) = (( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & - / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI))) * IOBDP_LOC(JX) + eAC = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) + eVA = MAX(0., CG(IK,ISEA)/CLATS(ISEA)*eAC) + VA(ISP,JSEA) = eVA END DO END DO + END IF + END DO + END IF + END IF + END SUBROUTINE APPLY_BOUNDARY_CONDITION_VA + !/ ------------------------------------------------------------------- / + SUBROUTINE APPLY_BOUNDARY_CONDITION(IMOD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Apply boundary conditions + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, only: STRACE +#endif + USE YOWNODEPOOL, only: npa, np + USE yowRankModule, only : IPGL_npa + USE W3GDATMD, only: NSEAL, CLATS, MAPSF + USE W3WDATMD, only: TIME + USE W3TIMEMD, only: DSEC21 + USE W3WDATMD, only : VA + USE W3ADATMD, only: CG, CX, CY + USE W3GDATMD, only: NK, NK2, NTH, NSPEC + USE W3ODATMD, only: TBPI0, TBPIN, FLBPI, IAPROC, BBPI0, BBPIN, ISBPI, NBI + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBDP_LOC, IOBPA_LOC +#ifdef W3_DEBUGIOBC + USE W3GDATMD, only: DDEN +#endif + !/ + IMPLICIT NONE + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_DEBUGSOLVER + REAL*8 :: sumAC(NSPEC) + REAL :: sumBPI0(NSPEC), sumBPIN(NSPEC), sumCG, sumCLATS +#endif +#ifdef W3_DEBUGIOBC + REAL :: ETOT, HSIG_bound, eVA, eAC, FACTOR +#endif + REAL :: RD1, RD2, RD10, RD20 + INTEGER :: IK, ITH, ISEA + INTEGER :: IBI, IP_glob, ISP, JX +#ifdef W3_S + CALL STRACE (IENT, 'APPLY_BOUNDARY_CONDITION') +#endif +#ifdef W3_DEBUGSOLVERCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(np) before boundary", 0) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) before boundary", 1) +#endif + IF ( FLBPI ) THEN + RD10 = DSEC21 ( TBPI0, TIME ) + RD20 = DSEC21 ( TBPI0, TBPIN ) + ELSE + RD10=1. + RD20=0. + END IF + IF ( FLBPI ) THEN + RD1=RD10 ! I am not completely sure about that + RD2=RD20 + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. + END IF +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'Begin of APPLY_BOUNDARY_CONDITION' + WRITE(740+IAPROC,*) 'NBI=', NBI + FLUSH(740+IAPROC) + sumAC=0 + sumBPI0=0 + sumBPIN=0 + sumCG=0 + sumCLATS=0 +#endif + DO IBI=1, NBI + ISEA = ISBPI(IBI) + IP_glob = MAPSF(ISEA,1) + JX = IPGL_npa(IP_glob) + IF (JX .gt. 0) THEN + DO ITH=1,NTH + DO IK=1,NK + ISP=ITH + (IK-1)*NTH + VA(ISP,JX) = (( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & + / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI))) * IOBDP_LOC(JX) + END DO + END DO #ifdef W3_DEBUGIOBC - ETOT=0 - DO ITH=1,NTH - DO IK=1,NK - FACTOR = DDEN(IK)/CG(IK,ISEA) - ISP=ITH + (IK-1)*NTH - eAC=REAL(VA(ISP,JX)) - eVA=CG(IK,ISEA)/CLATS(ISEA)*eAC - ETOT = ETOT + eVA*FACTOR - END DO - END DO - HSIG_bound=4.*SQRT(ETOT) - WRITE(740+IAPROC,*) 'IBI=', IBI, ' HSIG=', HSIG_bound + ETOT=0 + DO ITH=1,NTH + DO IK=1,NK + FACTOR = DDEN(IK)/CG(IK,ISEA) + ISP=ITH + (IK-1)*NTH + eAC=REAL(VA(ISP,JX)) + eVA=CG(IK,ISEA)/CLATS(ISEA)*eAC + ETOT = ETOT + eVA*FACTOR + END DO + END DO + HSIG_bound=4.*SQRT(ETOT) + WRITE(740+IAPROC,*) 'IBI=', IBI, ' HSIG=', HSIG_bound #endif #ifdef W3_DEBUGSOLVER - sumAC=sumAC + VA(:,JX) - sumBPI0=sumBPI0 + BBPI0(:,IBI) - sumBPIN=sumBPIN + BBPIN(:,IBI) - sumCG=sumCG + CG(IK,ISBPI(IBI)) - sumCLATS=sumCLATS + CLATS(ISBPI(IBI)) + sumAC=sumAC + VA(:,JX) + sumBPI0=sumBPI0 + BBPI0(:,IBI) + sumBPIN=sumBPIN + BBPIN(:,IBI) + sumCG=sumCG + CG(IK,ISBPI(IBI)) + sumCLATS=sumCLATS + CLATS(ISBPI(IBI)) #endif - END IF - ENDDO + END IF + ENDDO #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 + WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 #endif #ifdef W3_DEBUGSOLVERALL - DO ISP=1,NSPEC - WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 - WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumAC=', sumAC(ISP) - WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPI0=', sumBPI0(ISP) - WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPIN=', sumBPIN(ISP) - WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCG=', sumCG - WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCLATS=', sumCLATS - END DO + DO ISP=1,NSPEC + WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumAC=', sumAC(ISP) + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPI0=', sumBPI0(ISP) + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPIN=', sumBPIN(ISP) + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCG=', sumCG + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCLATS=', sumCLATS + END DO #endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'Begin of APPLY_BOUNDARY_CONDITION' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Begin of APPLY_BOUNDARY_CONDITION' + FLUSH(740+IAPROC) #endif #ifdef W3_DEBUGSOLVERCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(np) after boundary", 0) CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) after boundary", 1) #endif - END IF - END SUBROUTINE APPLY_BOUNDARY_CONDITION -!/ ------------------------------------------------------------------- / - SUBROUTINE ACTION_LIMITER_LOCAL(IP,ACLOC,ACOLD, DTG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Computation of the limiter function -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END IF + END SUBROUTINE APPLY_BOUNDARY_CONDITION + !/ ------------------------------------------------------------------- / + SUBROUTINE ACTION_LIMITER_LOCAL(IP,ACLOC,ACOLD, DTG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Computation of the limiter function + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif - use YOWNODEPOOL, only: iplg - USE CONSTANTS, only : GRAV, TPI - USE W3ADATMD, only : WN, CG - USE W3GDATMD, only : NTH, NK, NSPEC, MAPFS, SIG, FACP -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3SERVMD, only: STRACE +#endif + use YOWNODEPOOL, only: iplg + USE CONSTANTS, only : GRAV, TPI + USE W3ADATMD, only : WN, CG + USE W3GDATMD, only : NTH, NK, NSPEC, MAPFS, SIG, FACP + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER, INTENT(in) :: IP - REAL, INTENT(in) :: ACOLD(NSPEC) - REAL, INTENT(inout) :: ACLOC(NSPEC) - REAL, INTENT(in) :: DTG - INTEGER :: MELIM = 1 - REAL :: LIMFAK = 0.1 - REAL :: CONST, SND, eWN, eWK, eWKpow - REAL :: eFact, eSPSIG - REAL :: NewVAL - REAL :: OLDAC, NEWAC, NEWDAC - REAL :: MAXDAC - REAL :: dac, limac, eDam - INTEGER IP_glob, ISEA - INTEGER :: IK, ITH, ISP - LOGICAL :: LLIMITER_WWM + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER, INTENT(in) :: IP + REAL, INTENT(in) :: ACOLD(NSPEC) + REAL, INTENT(inout) :: ACLOC(NSPEC) + REAL, INTENT(in) :: DTG + INTEGER :: MELIM = 1 + REAL :: LIMFAK = 0.1 + REAL :: CONST, SND, eWN, eWK, eWKpow + REAL :: eFact, eSPSIG + REAL :: NewVAL + REAL :: OLDAC, NEWAC, NEWDAC + REAL :: MAXDAC + REAL :: dac, limac, eDam + INTEGER IP_glob, ISEA + INTEGER :: IK, ITH, ISP + LOGICAL :: LLIMITER_WWM #ifdef W3_S - CALL STRACE (IENT, 'ACTION_LIMITER_LOCAL')! + CALL STRACE (IENT, 'ACTION_LIMITER_LOCAL')! #endif - IP_glob=iplg(IP) - ISEA=MAPFS(1,IP_glob) - eSPSIG=SIG(NK) - CONST = TPI**2*3.0*1.0E-7*DTG*eSPSIG - SND = TPI*5.6*1.0E-3 + IP_glob=iplg(IP) + ISEA=MAPFS(1,IP_glob) + eSPSIG=SIG(NK) + CONST = TPI**2*3.0*1.0E-7*DTG*eSPSIG + SND = TPI*5.6*1.0E-3 - LLIMITER_WWM = .false. + LLIMITER_WWM = .false. - IF (LLIMITER_WWM) THEN - MAXDAC = 0 - DO IK=1,NK - IF (MELIM .eq. 1) THEN - eFact=2.*SIG(IK) - eWN=WN(IK,ISEA) - eWK=eWN - eWKpow=eWK**3 - MAXDAC = DBLE(0.0081*LIMFAK/(eFact*eWKpow*CG(IK,ISEA))) - END IF - DO ITH=1,NTH - ISP=ITH + (IK-1)*NTH - NEWAC = ACLOC(ISP) - OLDAC = ACOLD(ISP) - NEWDAC = NEWAC - OLDAC - NEWDAC = SIGN(MIN(MAXDAC,ABS(NEWDAC)), NEWDAC) - NewVAL = MAX(0., OLDAC + NEWDAC ) - ACLOC(ISP) = NewVAL - END DO + IF (LLIMITER_WWM) THEN + MAXDAC = 0 + DO IK=1,NK + IF (MELIM .eq. 1) THEN + eFact=2.*SIG(IK) + eWN=WN(IK,ISEA) + eWK=eWN + eWKpow=eWK**3 + MAXDAC = DBLE(0.0081*LIMFAK/(eFact*eWKpow*CG(IK,ISEA))) + END IF + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + NEWAC = ACLOC(ISP) + OLDAC = ACOLD(ISP) + NEWDAC = NEWAC - OLDAC + NEWDAC = SIGN(MIN(MAXDAC,ABS(NEWDAC)), NEWDAC) + NewVAL = MAX(0., OLDAC + NEWDAC ) + ACLOC(ISP) = NewVAL END DO - ELSE - DO IK = 1, NK - eDam=DBLE(FACP / (SIG(IK) * WN(IK,ISEA)**3)) - DO ITH=1,NTH - isp = ITH + (IK-1)*NTH - dac = ACLOC(isp) - ACOLD(isp) - limac = SIGN (MIN(eDam,ABS(dac)),dac) - ACLOC(isp) = MAX(0., ACLOC(isp) + limac) - END DO + END DO + ELSE + DO IK = 1, NK + eDam=DBLE(FACP / (SIG(IK) * WN(IK,ISEA)**3)) + DO ITH=1,NTH + isp = ITH + (IK-1)*NTH + dac = ACLOC(isp) - ACOLD(isp) + limac = SIGN (MIN(eDam,ABS(dac)),dac) + ACLOC(isp) = MAX(0., ACLOC(isp) + limac) END DO - ENDIF - END SUBROUTINE ACTION_LIMITER_LOCAL -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(IMOD, FACX, FACY, DTG, VGX, VGY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Block Gauss Seidel and Jacobi solver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! + END DO + ENDIF + END SUBROUTINE ACTION_LIMITER_LOCAL + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(IMOD, FACX, FACY, DTG, VGX, VGY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Block Gauss Seidel and Jacobi solver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -!/ - USE W3GDATMD, only: MAPSTA - USE W3GDATMD, only: FSREFRACTION, FSFREQSHIFT, FSSOURCE, NX, DSIP - USE W3GDATMD, only: B_JGS_NORM_THR, B_JGS_TERMINATE_NORM, B_JGS_PMIN - USE W3GDATMD, only: B_JGS_TERMINATE_DIFFERENCE, B_JGS_MAXITER, B_JGS_LIMITER - USE W3GDATMD, only: B_JGS_TERMINATE_MAXITER, B_JGS_BLOCK_GAUSS_SEIDEL, B_JGS_DIFF_THR - USE W3GDATMD, only: MAPWN + USE W3SERVMD, only: STRACE +#endif + !/ + USE W3GDATMD, only: MAPSTA + USE W3GDATMD, only: FSREFRACTION, FSFREQSHIFT, FSSOURCE, NX, DSIP + USE W3GDATMD, only: B_JGS_NORM_THR, B_JGS_TERMINATE_NORM, B_JGS_PMIN + USE W3GDATMD, only: B_JGS_TERMINATE_DIFFERENCE, B_JGS_MAXITER, B_JGS_LIMITER + USE W3GDATMD, only: B_JGS_TERMINATE_MAXITER, B_JGS_BLOCK_GAUSS_SEIDEL, B_JGS_DIFF_THR + USE W3GDATMD, only: MAPWN #ifdef W3_DEBUGSRC - USE W3GDATMD, only: optionCall - USE W3WDATMD, only: SHAVETOT -#endif - USE YOWNODEPOOL, only: PDLIB_I_DIAG, PDLIB_IA_P, PDLIB_JA, np - USE YOWNODEPOOL, only: PDLIB_SI, PDLIB_NNZ, PDLIB_CCON - use yowDatapool, only: rtype - use YOWNODEPOOL, only: npa, iplg - use yowExchangeModule, only : PDLIB_exchange2Dreal_zero, PDLIB_exchange2Dreal - USE MPI, only : MPI_SUM, MPI_INT - USE W3ADATMD, only: MPI_COMM_WCMP + USE W3GDATMD, only: optionCall + USE W3WDATMD, only: SHAVETOT +#endif + USE YOWNODEPOOL, only: PDLIB_I_DIAG, PDLIB_IA_P, PDLIB_JA, np + USE YOWNODEPOOL, only: PDLIB_SI, PDLIB_NNZ, PDLIB_CCON + use yowDatapool, only: rtype + use YOWNODEPOOL, only: npa, iplg + use yowExchangeModule, only : PDLIB_exchange2Dreal_zero, PDLIB_exchange2Dreal + USE MPI, only : MPI_SUM, MPI_INT + USE W3ADATMD, only: MPI_COMM_WCMP #ifdef W3_MEMCHECK - USE W3ADATMD, only: MALLINFOS -#endif - USE W3GDATMD, only: NSEA, SIG - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBDP_LOC, IOBPA_LOC - USE W3GDATMD, only: NK, NK2, NTH, ECOS, ESIN, NSPEC, MAPFS, NSEA, SIG - USE W3WDATMD, only: TIME - USE W3ODATMD, only: NBI - USE W3TIMEMD, only: DSEC21 - USE W3GDATMD, only: NSEAL, CLATS, FACHFA - USE W3IDATMD, only: FLCUR, FLLEV - USE W3WDATMD, only: VA, VAOLD, VSTOT, VDTOT - USE W3ADATMD, only: CG, CX, CY, WN, DW - USE W3ODATMD, only: TBPIN, FLBPI, IAPROC - USE W3PARALL, only : IMEM - USE W3PARALL, only : INIT_GET_JSEA_ISPROC, ZERO, THR8, LSLOC - USE W3PARALL, only : ListISPprevDir, ListISPnextDir - USE W3PARALL, only : JX_TO_JSEA - USE W3GDATMD, only: B_JGS_NLEVEL, B_JGS_SOURCE_NONLINEAR - USE yowfunction, only : pdlib_abort - USE yowNodepool, only: np_global - USE W3DISPMD, only : WAVNU_LOCAL + USE W3ADATMD, only: MALLINFOS +#endif + USE W3GDATMD, only: NSEA, SIG + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBDP_LOC, IOBPA_LOC + USE W3GDATMD, only: NK, NK2, NTH, ECOS, ESIN, NSPEC, MAPFS, NSEA, SIG + USE W3WDATMD, only: TIME + USE W3ODATMD, only: NBI + USE W3TIMEMD, only: DSEC21 + USE W3GDATMD, only: NSEAL, CLATS, FACHFA + USE W3IDATMD, only: FLCUR, FLLEV + USE W3WDATMD, only: VA, VAOLD, VSTOT, VDTOT + USE W3ADATMD, only: CG, CX, CY, WN, DW + USE W3ODATMD, only: TBPIN, FLBPI, IAPROC + USE W3PARALL, only : IMEM + USE W3PARALL, only : INIT_GET_JSEA_ISPROC, ZERO, THR8, LSLOC + USE W3PARALL, only : ListISPprevDir, ListISPnextDir + USE W3PARALL, only : JX_TO_JSEA + USE W3GDATMD, only: B_JGS_NLEVEL, B_JGS_SOURCE_NONLINEAR + USE yowfunction, only : pdlib_abort + USE yowNodepool, only: np_global + USE W3DISPMD, only : WAVNU_LOCAL #ifdef W3_MEMCHECK - USE MallocInfo_m -#endif - implicit none - INTEGER, INTENT(IN) :: IMOD - REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY - ! - INTEGER :: IP, ISP, ITH, IK, JSEA, ISEA, IP_glob - INTEGER :: myrank - INTEGER :: nbIter, ISPnextDir, ISPprevDir - INTEGER :: ISPp1, ISPm1, JP, ICOUNT1, ICOUNT2 - ! for the exchange - REAL :: CCOS, CSIN, CCURX, CCURY - REAL :: eSum(NSPEC) - REAL :: eA_THE, eC_THE, eA_SIG, eC_SIG, eSI - REAL :: CAD(NSPEC), CAS(NSPEC), ACLOC(NSPEC) - REAL :: CP_SIG(NSPEC), CM_SIG(NSPEC) - REAL :: eFactM1, eFactP1 - REAL*8 :: Sum_Prev, Sum_New, p_is_converged, DiffNew, prop_conv - REAL :: Sum_L2, Sum_L2_GL - REAL :: DMM(0:NK2) - REAL :: eDiff(NSPEC), eProd(NSPEC) - REAL :: DWNI_M2(NK), CWNB_M2(1-NTH:NSPEC) - REAL :: VAnew(NSPEC), VFLWN(1-NTH:NSPEC) - REAL :: VAAnew(1-NTH:NSPEC+NTH), VAAacloc(1-NTH:NSPEC+NTH) - REAL :: VAinput(NSPEC), VAacloc(NSPEC), eDiffB(NSPEC),ASPAR_DIAG(NSPEC) - REAL :: aspar_diag_local(nspec), aspar_off_diag_local(nspec), b_jac_local(nspec) - REAL :: eDiffSing, eSumPart - REAL :: eVal1, eVal2!, extmp(nspec,nseal) - REAL :: eVA, CG2 - REAL :: CG1(0:NK+1), WN1(0:NK+1) - LOGICAL :: LCONVERGED(NSEAL), lexist -#ifdef WEIGHTS - INTEGER :: ipiter(nseal), ipitergl(np_global), ipiterout(np_global) + USE MallocInfo_m +#endif + implicit none + INTEGER, INTENT(IN) :: IMOD + REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY + ! + INTEGER :: IP, ISP, ITH, IK, JSEA, ISEA, IP_glob + INTEGER :: myrank + INTEGER :: nbIter, ISPnextDir, ISPprevDir + INTEGER :: ISPp1, ISPm1, JP, ICOUNT1, ICOUNT2 + ! for the exchange + REAL :: CCOS, CSIN, CCURX, CCURY + REAL :: eSum(NSPEC) + REAL :: eA_THE, eC_THE, eA_SIG, eC_SIG, eSI + REAL :: CAD(NSPEC), CAS(NSPEC), ACLOC(NSPEC) + REAL :: CP_SIG(NSPEC), CM_SIG(NSPEC) + REAL :: eFactM1, eFactP1 + REAL*8 :: Sum_Prev, Sum_New, p_is_converged, DiffNew, prop_conv + REAL :: Sum_L2, Sum_L2_GL + REAL :: DMM(0:NK2) + REAL :: eDiff(NSPEC), eProd(NSPEC) + REAL :: DWNI_M2(NK), CWNB_M2(1-NTH:NSPEC) + REAL :: VAnew(NSPEC), VFLWN(1-NTH:NSPEC) + REAL :: VAAnew(1-NTH:NSPEC+NTH), VAAacloc(1-NTH:NSPEC+NTH) + REAL :: VAinput(NSPEC), VAacloc(NSPEC), eDiffB(NSPEC),ASPAR_DIAG(NSPEC) + REAL :: aspar_diag_local(nspec), aspar_off_diag_local(nspec), b_jac_local(nspec) + REAL :: eDiffSing, eSumPart + REAL :: eVal1, eVal2!, extmp(nspec,nseal) + REAL :: eVA, CG2 + REAL :: CG1(0:NK+1), WN1(0:NK+1) + LOGICAL :: LCONVERGED(NSEAL), lexist +#ifdef WEIGHTS + INTEGER :: ipiter(nseal), ipitergl(np_global), ipiterout(np_global) #endif #ifdef W3_DEBUGSRC - REAL :: IntDiff, eVA_w3srce, eVAsolve, SumACout - REAL :: SumVAin, SumVAout, SumVAw3srce, SumVS, SumVD, VS_w3srce - REAL :: VAsolve(NSPEC) - REAL*8 :: ACsolve - REAL :: eB + REAL :: IntDiff, eVA_w3srce, eVAsolve, SumACout + REAL :: SumVAin, SumVAout, SumVAw3srce, SumVS, SumVD, VS_w3srce + REAL :: VAsolve(NSPEC) + REAL*8 :: ACsolve + REAL :: eB #endif #ifdef W3_DEBUGSOLVERCOH - REAL :: TheARR(NSPEC, npa) - REAL :: PRE_VA(NSPEC, npa) - REAL :: OffDIAG(NSPEC, npa) - REAL*8 :: eOff(NSPEC) - REAL*8 :: eSum1(NSPEC), eSum2(NSPEC) + REAL :: TheARR(NSPEC, npa) + REAL :: PRE_VA(NSPEC, npa) + REAL :: OffDIAG(NSPEC, npa) + REAL*8 :: eOff(NSPEC) + REAL*8 :: eSum1(NSPEC), eSum2(NSPEC) #endif - CHARACTER(len=128) eFile - INTEGER ierr, i - INTEGER JP_glob - INTEGER is_converged, itmp + CHARACTER(len=128) eFile + INTEGER ierr, i + INTEGER JP_glob + INTEGER is_converged, itmp - integer :: testknoten = 923 + integer :: testknoten = 923 - LOGICAL :: LSIG = .FALSE. + LOGICAL :: LSIG = .FALSE. -!AR: this is missing in init ... but there is a design error in ww3_grid with FLCUR and FLLEV - LSIG = FLCUR .OR. FLLEV + !AR: this is missing in init ... but there is a design error in ww3_grid with FLCUR and FLLEV + LSIG = FLCUR .OR. FLLEV #ifdef W3_DEBUGSOLVERCOH - OffDIAG = ZERO + OffDIAG = ZERO #endif #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 0' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 0' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) #endif - !DO JSEA = 1, NSEAL - ! WRITE(70000+IAPROC,*) 'SUM VA ENTRY SOLVER', JSEA, SUM(VA(:,JSEA)) - !ENDDO + !DO JSEA = 1, NSEAL + ! WRITE(70000+IAPROC,*) 'SUM VA ENTRY SOLVER', JSEA, SUM(VA(:,JSEA)) + !ENDDO - CCURX = FACX - CCURY = FACY - CALL MPI_COMM_RANK(MPI_COMM_WCMP, myrank, ierr) -! + CCURX = FACX + CCURY = FACY + CALL MPI_COMM_RANK(MPI_COMM_WCMP, myrank, ierr) + ! #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, begin' - WRITE(740+IAPROC,*) 'NX=', NX - WRITE(740+IAPROC,*) 'NP=', NP - WRITE(740+IAPROC,*) 'NPA=', NPA - WRITE(740+IAPROC,*) 'NSEA=', NSEA - WRITE(740+IAPROC,*) 'NSEAL=', NSEAL - WRITE(740+IAPROC,*) 'NBI=', NBI - WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_NORM=', B_JGS_TERMINATE_NORM - WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_DIFFERENCE=', B_JGS_TERMINATE_DIFFERENCE - WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_MAXITER=', B_JGS_TERMINATE_MAXITER - WRITE(740+IAPROC,*) 'B_JGS_MAXITER=', B_JGS_MAXITER - WRITE(740+IAPROC,*) 'B_JGS_BLOCK_GAUSS_SEIDEL=', B_JGS_BLOCK_GAUSS_SEIDEL - WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION - WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT - WRITE(740+IAPROC,*) 'B_JGS_LIMITER=', B_JGS_LIMITER - WRITE(740+IAPROC,*) 'B_JGS_BLOCK_GAUSS_SEIDEL=', B_JGS_BLOCK_GAUSS_SEIDEL - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, begin' + WRITE(740+IAPROC,*) 'NX=', NX + WRITE(740+IAPROC,*) 'NP=', NP + WRITE(740+IAPROC,*) 'NPA=', NPA + WRITE(740+IAPROC,*) 'NSEA=', NSEA + WRITE(740+IAPROC,*) 'NSEAL=', NSEAL + WRITE(740+IAPROC,*) 'NBI=', NBI + WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_NORM=', B_JGS_TERMINATE_NORM + WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_DIFFERENCE=', B_JGS_TERMINATE_DIFFERENCE + WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_MAXITER=', B_JGS_TERMINATE_MAXITER + WRITE(740+IAPROC,*) 'B_JGS_MAXITER=', B_JGS_MAXITER + WRITE(740+IAPROC,*) 'B_JGS_BLOCK_GAUSS_SEIDEL=', B_JGS_BLOCK_GAUSS_SEIDEL + WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION + WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT + WRITE(740+IAPROC,*) 'B_JGS_LIMITER=', B_JGS_LIMITER + WRITE(740+IAPROC,*) 'B_JGS_BLOCK_GAUSS_SEIDEL=', B_JGS_BLOCK_GAUSS_SEIDEL + FLUSH(740+IAPROC) #endif #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'optionCall=', optionCall - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'optionCall=', optionCall + FLUSH(740+IAPROC) #endif #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 1' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) #endif -! -! 2. Convert to Wave Action ---------------- * -! + ! + ! 2. Convert to Wave Action ---------------- * + ! #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'NSEAL =', NSEAL, 'NP =', NP, 'NPA =', NPA + WRITE(740+IAPROC,*) 'NSEAL =', NSEAL, 'NP =', NP, 'NPA =', NPA #endif #ifdef W3_DEBUGSOLVERCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(np) before transform", 0) - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) before transform", 1) -#endif -! We have NSEAL = NPA so the whole field is assigned - DO JSEA=1,NSEAL - IP = JSEA - IP_glob = iplg(IP) - ISEA = MAPFS(1,IP_glob) - DO ISP=1,NSPEC - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(np) before transform", 0) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) before transform", 1) +#endif + ! We have NSEAL = NPA so the whole field is assigned + DO JSEA=1,NSEAL + IP = JSEA + IP_glob = iplg(IP) + ISEA = MAPFS(1,IP_glob) + DO ISP=1,NSPEC + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH #ifdef NOCGTABLE - CALL WAVNU_LOCAL(SIG(IK),DW(ISEA),WN1(IK),CG1(IK)) + CALL WAVNU_LOCAL(SIG(IK),DW(ISEA),WN1(IK),CG1(IK)) #else - CG1(IK) = CG(IK,ISEA) + CG1(IK) = CG(IK,ISEA) #endif - VA(ISP,JSEA) = VA(ISP,JSEA) / CG1(IK) * CLATS(ISEA) - END DO + VA(ISP,JSEA) = VA(ISP,JSEA) / CG1(IK) * CLATS(ISEA) END DO - VAOLD = VA(1:NSPEC,1:NSEAL) + END DO + VAOLD = VA(1:NSPEC,1:NSEAL) #ifdef W3_DEBUGSRC - DO JSEA=1,NSEAL - WRITE(740+IAPROC,*) 'JSEA=', JSEA - WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) - END DO + DO JSEA=1,NSEAL + WRITE(740+IAPROC,*) 'JSEA=', JSEA + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) + END DO #endif #ifdef W3_DEBUGSOLVERCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(np) just defined", 0) - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) just defined", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(np) just defined", 0) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) just defined", 1) #endif #ifdef W3_DEBUGSOLVER - FLUSH(740+IAPROC) - WRITE(740+IAPROC,*) 'JACOBI_SOLVER, step 4' - WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE - WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION - WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT - WRITE(740+IAPROC,*) 'FSGEOADVECT=', FSGEOADVECT - WRITE(740+IAPROC,*) 'DTG=', DTG -#endif -! -! init matrix and right hand side -! + FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'JACOBI_SOLVER, step 4' + WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE + WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION + WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT + WRITE(740+IAPROC,*) 'FSGEOADVECT=', FSGEOADVECT + WRITE(740+IAPROC,*) 'DTG=', DTG +#endif + ! + ! init matrix and right hand side + ! #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 2' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) #endif -! - IF (.not. LSLOC) THEN - IF (IMEM == 1) THEN - ASPAR_JAC = ZERO - ELSE IF (IMEM == 2) THEN - ASPAR_DIAG_ALL = ZERO - ENDIF - B_JAC = ZERO + ! + IF (.not. LSLOC) THEN + IF (IMEM == 1) THEN + ASPAR_JAC = ZERO + ELSE IF (IMEM == 2) THEN + ASPAR_DIAG_ALL = ZERO ENDIF + B_JAC = ZERO + ENDIF #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 3' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) -#endif -! -! source terms -! - IF (FSSOURCE) THEN - IF (.not. LSLOC) THEN - IF (IMEM == 1) THEN - call CALCARRAY_JACOBI_SOURCE_1(DTG) - ELSE IF (IMEM == 2) THEN - call CALCARRAY_JACOBI_SOURCE_2(DTG,ASPAR_DIAG_ALL) - ENDIF + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) +#endif + ! + ! source terms + ! + IF (FSSOURCE) THEN + IF (.not. LSLOC) THEN + IF (IMEM == 1) THEN + call CALCARRAY_JACOBI_SOURCE_1(DTG) + ELSE IF (IMEM == 2) THEN + call CALCARRAY_JACOBI_SOURCE_2(DTG,ASPAR_DIAG_ALL) ENDIF - END IF + ENDIF + END IF #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 4' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) #endif -! -! geographical advection -! - IF (IMEM == 1) call calcARRAY_JACOBI_VEC(DTG,FACX,FACY,VGX,VGY) + ! + ! geographical advection + ! + IF (IMEM == 1) call calcARRAY_JACOBI_VEC(DTG,FACX,FACY,VGX,VGY) - do ip = 1, np - IP_glob =iplg(IP) - ISEA = MAPFS(1,IP_glob) - JSEA = JX_TO_JSEA(IP) -! IF (ISEA == 28447) write(740+IAPROC,*) 'SOLVER ENTRY', ISEA, JSEA, SUM(B_JAC(:,JSEA)), & -! SUM(ASPAR_JAC(:,PDLIB_I_DIAG(JSEA))), PDLIB_I_DIAG(JSEA) - enddo + do ip = 1, np + IP_glob =iplg(IP) + ISEA = MAPFS(1,IP_glob) + JSEA = JX_TO_JSEA(IP) + ! IF (ISEA == 28447) write(740+IAPROC,*) 'SOLVER ENTRY', ISEA, JSEA, SUM(B_JAC(:,JSEA)), & + ! SUM(ASPAR_JAC(:,PDLIB_I_DIAG(JSEA))), PDLIB_I_DIAG(JSEA) + enddo #ifdef W3_DEBUGSOLVER - !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 1', sum(B_JAC), SUM(ASPAR_JAC) + !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 1', sum(B_JAC), SUM(ASPAR_JAC) #endif #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 5' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) #endif -! + ! #ifdef W3_DEBUGSOLVER - !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 1', sum(B_JAC), SUM(ASPAR_JAC) + !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 1', sum(B_JAC), SUM(ASPAR_JAC) #endif -! -! spectral advection -! - IF (FSFREQSHIFT .or. FSREFRACTION) THEN - IF (IMEM == 1) THEN - call calcARRAY_JACOBI_SPECTRAL_1(DTG) - ELSE IF (IMEM == 2) THEN - call calcARRAY_JACOBI_SPECTRAL_2(DTG,ASPAR_DIAG_ALL) - ENDIF - END IF - CALL APPLY_BOUNDARY_CONDITION(IMOD) + ! + ! spectral advection + ! + IF (FSFREQSHIFT .or. FSREFRACTION) THEN + IF (IMEM == 1) THEN + call calcARRAY_JACOBI_SPECTRAL_1(DTG) + ELSE IF (IMEM == 2) THEN + call calcARRAY_JACOBI_SPECTRAL_2(DTG,ASPAR_DIAG_ALL) + ENDIF + END IF + CALL APPLY_BOUNDARY_CONDITION(IMOD) #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 6' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) #endif -! + ! #ifdef W3_DEBUGSOLVERCOH - CALL CHECK_ARRAY_INTEGRAL_NX_R8(B_JAC, "B_JAC after calcARRAY", np) - DO IP=1,npa - TheArr(:, IP)=REAL(ASPAR_JAC(:, PDLIB_I_DIAG(IP))) - END DO - CALL CHECK_ARRAY_INTEGRAL_NX_R8(TheArr, "ASPAR diag after calArr", np) -#endif - nbIter=0 - do ip = 1, np - Lconverged(ip) = .false. + CALL CHECK_ARRAY_INTEGRAL_NX_R8(B_JAC, "B_JAC after calcARRAY", np) + DO IP=1,npa + TheArr(:, IP)=REAL(ASPAR_JAC(:, PDLIB_I_DIAG(IP))) + END DO + CALL CHECK_ARRAY_INTEGRAL_NX_R8(TheArr, "ASPAR diag after calArr", np) +#endif + nbIter=0 + do ip = 1, np + Lconverged(ip) = .false. #ifdef WEIGHTS - ipiter(ip) = 0 + ipiter(ip) = 0 #endif - enddo -! - DO + enddo + ! + DO - is_converged = 0 + is_converged = 0 -! WRITE(740+IAPROC,*) myrank, 'start solver', nbiter + ! WRITE(740+IAPROC,*) myrank, 'start solver', nbiter #ifdef W3_MEMCHECK write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 1' call getMallocInfo(mallinfos) call printMallInfo(IAPROC+50000,mallInfos) #endif - DO IP = 1, np + DO IP = 1, np - IP_glob = iplg(IP) - ISEA = MAPFS(1,IP_glob) + IP_glob = iplg(IP) + ISEA = MAPFS(1,IP_glob) - !WRITE(*,*) 'TEST VA 1', IP, SUM(VA(:,IP)), lconverged(ip) + !WRITE(*,*) 'TEST VA 1', IP, SUM(VA(:,IP)), lconverged(ip) - IF (IOBDP_LOC(IP) .eq. 0) THEN - is_converged = is_converged + 1 - lconverged(ip) = .true. - CYCLE - ENDIF + IF (IOBDP_LOC(IP) .eq. 0) THEN + is_converged = is_converged + 1 + lconverged(ip) = .true. + CYCLE + ENDIF - DO IK = 0, NK + 1 + DO IK = 0, NK + 1 #ifdef NOCGTABLE - CALL WAVNU_LOCAL(SIG(IK),DW(ISEA),WN1(IK),CG1(IK)) + CALL WAVNU_LOCAL(SIG(IK),DW(ISEA),WN1(IK),CG1(IK)) #else - CG1(IK) = CG(IK,ISEA) - WN1(IK) = WN(IK,ISEA) + CG1(IK) = CG(IK,ISEA) + WN1(IK) = WN(IK,ISEA) #endif - ENDDO + ENDDO - JSEA = JX_TO_JSEA(IP) - ISEA = MAPFS(1,IP_glob) - eSI = PDLIB_SI(IP) - ACLOC = VA(:,JSEA) + JSEA = JX_TO_JSEA(IP) + ISEA = MAPFS(1,IP_glob) + eSI = PDLIB_SI(IP) + ACLOC = VA(:,JSEA) - IF (.NOT. LCONVERGED(IP)) THEN + IF (.NOT. LCONVERGED(IP)) THEN #ifdef WEIGHTS - ipiter(ip) = ipiter(ip) + 1 + ipiter(ip) = ipiter(ip) + 1 #endif #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) 'Begin loop' - WRITE(740+IAPROC,*) 'IP/IP_glob/ISEA/JSEA=', IP, IP_glob, ISEA, JSEA + WRITE(740+IAPROC,*) 'Begin loop' + WRITE(740+IAPROC,*) 'IP/IP_glob/ISEA/JSEA=', IP, IP_glob, ISEA, JSEA #endif #ifdef W3_DEBUGSRC WRITE(740+IAPROC,*) 'IP=', IP, ' IP_glob=', IP_glob WRITE(740+IAPROC,*) 'sum(VA)in=', sum(VA(:,IP)) #endif #ifdef W3_DEBUGFREQSHIFT - DO ISP=1,NSPEC - VAold(ISP) = VA(ISP,JSEA) - IK=MAPWN(ISP) - VAinput(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * VA(ISP, IP) - VAacloc(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * ACLOC(ISP) - END DO - WRITE(740+IAPROC,*) 'sum(VAold/VAinput/VAacloc)=', sum(VAold), sum(VAinput), sum(VAacloc) -#endif - - Sum_Prev = sum(ACLOC) - - IF (IMEM == 2) THEN - CALL calcARRAY_JACOBI4(IP,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) - !WRITE(*,'(A10,10F20.10)') 'JAC4', SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_OFF_DIAG_LOCAL), SUM(B_JAC_LOCAL) - !CALL calcARRAY_JACOBI3(IP,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) - !WRITE(*,'(A10,10F20.10)') 'JAC3', SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_OFF_DIAG_LOCAL), SUM(B_JAC_LOCAL) - ASPAR_DIAG(1:NSPEC) = ASPAR_DIAG_LOCAL(1:NSPEC) + ASPAR_DIAG_ALL(1:NSPEC,IP) - !IF (ANY(ABS(ASPAR_DIAG) .LT. TINY(1.))) THEN - ! WRITE(*,'(8I10,4F20.10)') IP, JSEA, ISEA, NSEA, NSEAL, np, npa, IP_glob, SUM(ASPAR_DIAG), SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_DIAG_ALL(:,IP)), SUM(B_JAC(:,IP)) - ! CALL PDLIB_ABORT(25) - !ENDIF - esum = B_JAC_LOCAL - ASPAR_OFF_DIAG_LOCAL + B_JAC(1:NSPEC,IP) - ELSEIF (IMEM == 1) THEN - !CALL calcARRAY_JACOBI4(IP,ICOUNT2,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) - !WRITE(*,'(A10,10F20.10)') 'JAC4', SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_OFF_DIAG_LOCAL), SUM(B_JAC_LOCAL) - !CALL calcARRAY_JACOBI3(IP,ICOUNT1,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) - !WRITE(*,'(A10,10F20.10)') 'JAC3', SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_OFF_DIAG_LOCAL), SUM(B_JAC_LOCAL) - eSum(1:NSPEC) = B_JAC(1:NSPEC,IP) - ASPAR_DIAG(1:NSPEC) = ASPAR_JAC(1:NSPEC,PDLIB_I_DIAG(IP)) - !IF (IP_glob == 64058) WRITE(740+IAPROC,*) 'TEST ASPAR B_JAC', IP, SUM(B_JAC(1:NSPEC,IP)), SUM(ASPAR_DIAG) + DO ISP=1,NSPEC + VAold(ISP) = VA(ISP,JSEA) + IK=MAPWN(ISP) + VAinput(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * VA(ISP, IP) + VAacloc(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * ACLOC(ISP) + END DO + WRITE(740+IAPROC,*) 'sum(VAold/VAinput/VAacloc)=', sum(VAold), sum(VAinput), sum(VAacloc) +#endif + + Sum_Prev = sum(ACLOC) + + IF (IMEM == 2) THEN + CALL calcARRAY_JACOBI4(IP,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) + !WRITE(*,'(A10,10F20.10)') 'JAC4', SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_OFF_DIAG_LOCAL), SUM(B_JAC_LOCAL) + !CALL calcARRAY_JACOBI3(IP,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) + !WRITE(*,'(A10,10F20.10)') 'JAC3', SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_OFF_DIAG_LOCAL), SUM(B_JAC_LOCAL) + ASPAR_DIAG(1:NSPEC) = ASPAR_DIAG_LOCAL(1:NSPEC) + ASPAR_DIAG_ALL(1:NSPEC,IP) + !IF (ANY(ABS(ASPAR_DIAG) .LT. TINY(1.))) THEN + ! WRITE(*,'(8I10,4F20.10)') IP, JSEA, ISEA, NSEA, NSEAL, np, npa, IP_glob, SUM(ASPAR_DIAG), SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_DIAG_ALL(:,IP)), SUM(B_JAC(:,IP)) + ! CALL PDLIB_ABORT(25) + !ENDIF + esum = B_JAC_LOCAL - ASPAR_OFF_DIAG_LOCAL + B_JAC(1:NSPEC,IP) + ELSEIF (IMEM == 1) THEN + !CALL calcARRAY_JACOBI4(IP,ICOUNT2,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) + !WRITE(*,'(A10,10F20.10)') 'JAC4', SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_OFF_DIAG_LOCAL), SUM(B_JAC_LOCAL) + !CALL calcARRAY_JACOBI3(IP,ICOUNT1,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL) + !WRITE(*,'(A10,10F20.10)') 'JAC3', SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_OFF_DIAG_LOCAL), SUM(B_JAC_LOCAL) + eSum(1:NSPEC) = B_JAC(1:NSPEC,IP) + ASPAR_DIAG(1:NSPEC) = ASPAR_JAC(1:NSPEC,PDLIB_I_DIAG(IP)) + !IF (IP_glob == 64058) WRITE(740+IAPROC,*) 'TEST ASPAR B_JAC', IP, SUM(B_JAC(1:NSPEC,IP)), SUM(ASPAR_DIAG) #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) 'eSI=', eSI - WRITE(740+IAPROC,*) 'sum(ASPAR_DIAG)=', sum(ASPAR_DIAG) + WRITE(740+IAPROC,*) 'eSI=', eSI + WRITE(740+IAPROC,*) 'sum(ASPAR_DIAG)=', sum(ASPAR_DIAG) #endif #ifdef W3_DEBUGSRC WRITE(740+IAPROC,*) 'Step 1: sum(eSum)=', sum(eSum) #endif #ifdef W3_DEBUGSOLVERCOH - eOff=ZERO + eOff=ZERO #endif - DO i = PDLIB_IA_P(IP)+1, PDLIB_IA_P(IP+1) - JP = PDLIB_JA(I) - IF (JP .ne. IP) THEN - eProd = ASPAR_JAC(1:NSPEC,i) * VA(1:NSPEC,JP) - eSum = eSum - eProd + DO i = PDLIB_IA_P(IP)+1, PDLIB_IA_P(IP+1) + JP = PDLIB_JA(I) + IF (JP .ne. IP) THEN + eProd = ASPAR_JAC(1:NSPEC,i) * VA(1:NSPEC,JP) + eSum = eSum - eProd #ifdef W3_DEBUGSOLVERALL - WRITE(740+IAPROC,'(A20,3I10,20E20.10)') 'OFF DIAGONAL', IP, i, jp, sum(B_JAC(:,IP)), sum(eSum), SUM(ASPAR_JAC(:,i)), SUM(VA(:,JP)) + WRITE(740+IAPROC,'(A20,3I10,20E20.10)') 'OFF DIAGONAL', IP, i, jp, sum(B_JAC(:,IP)), sum(eSum), SUM(ASPAR_JAC(:,i)), SUM(VA(:,JP)) #endif #ifdef W3_DEBUGSOLVERCOH - eOff=eOff + abs(ASPAR_JAC(:,i)) + eOff=eOff + abs(ASPAR_JAC(:,i)) #endif - END IF - END DO - ENDIF ! IMEM + END IF + END DO + ENDIF ! IMEM #ifdef W3_DEBUGSOLVERCOH OffDiag(:, IP)=REAL(eOff) @@ -6029,178 +6023,178 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(IMOD, FACX, FACY, DTG, VGX, VGY) #ifdef W3_DEBUGSOLVERCOHALL WRITE(740+IAPROC,*) 'Step 2: sum(eSum)=', sum(eSum), ' eOff=', sum(eOff) #endif - IF (FSREFRACTION) THEN + IF (FSREFRACTION) THEN #ifdef W3_DEBUGREFRACTION - WRITE(740+IAPROC,*) 'Adding refraction terms to eSum' + WRITE(740+IAPROC,*) 'Adding refraction terms to eSum' #endif - CAD = CAD_THE(:,IP) - DO ISP=1,NSPEC - ISPprevDir=ListISPprevDir(ISP) - ISPnextDir=ListISPnextDir(ISP) - eA_THE = - DTG*eSI*MAX(ZERO,CAD(ISPprevDir)) - eC_THE = DTG*eSI*MIN(ZERO,CAD(ISPnextDir)) - eSum(ISP) = eSum(ISP) - eA_THE * VA(ISPprevDir,IP) - eSum(ISP) = eSum(ISP) - eC_THE * VA(ISPnextDir,IP) - END DO - END IF + CAD = CAD_THE(:,IP) + DO ISP=1,NSPEC + ISPprevDir=ListISPprevDir(ISP) + ISPnextDir=ListISPnextDir(ISP) + eA_THE = - DTG*eSI*MAX(ZERO,CAD(ISPprevDir)) + eC_THE = DTG*eSI*MIN(ZERO,CAD(ISPnextDir)) + eSum(ISP) = eSum(ISP) - eA_THE * VA(ISPprevDir,IP) + eSum(ISP) = eSum(ISP) - eC_THE * VA(ISPnextDir,IP) + END DO + END IF #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'Step 3: sum(eSum)=', sum(eSum) -#endif - IF (FSFREQSHIFT .and. LSIG) THEN - IF (FreqShiftMethod .eq. 1) THEN - CAS = CAS_SIG(:,IP) - CP_SIG = MAX(ZERO,CAS) - CM_SIG = MIN(ZERO,CAS) - DO IK=0, NK - DMM(IK+1) = DBLE(WN1(IK+1) - WN1(IK)) - END DO - DMM(NK+2) = ZERO - DMM(0)=DMM(1) - DO ITH=1,NTH - DO IK=2,NK - ISP = ITH + (IK -1)*NTH - ISPm1 = ITH + (IK-1 -1)*NTH - eFactM1 = CG1(IK-1) / CG1(IK) - eA_SIG = - eSI * CP_SIG(ISPm1)/DMM(IK-1) * eFactM1 - eSum(ISP) = eSum(ISP) - eA_SIG*VA(ISPm1,IP) - END DO - DO IK=1,NK-1 - ISP = ITH + (IK -1)*NTH - ISPp1 = ITH + (IK+1 -1)*NTH - eFactP1 = CG1(IK+1) / CG1(IK) - eC_SIG = eSI * CM_SIG(ISPp1)/DMM(IK) * eFactP1 - eSum(ISP) = eSum(ISP) - eC_SIG*VA(ISPp1,IP) - END DO + WRITE(740+IAPROC,*) 'Step 3: sum(eSum)=', sum(eSum) +#endif + IF (FSFREQSHIFT .and. LSIG) THEN + IF (FreqShiftMethod .eq. 1) THEN + CAS = CAS_SIG(:,IP) + CP_SIG = MAX(ZERO,CAS) + CM_SIG = MIN(ZERO,CAS) + DO IK=0, NK + DMM(IK+1) = DBLE(WN1(IK+1) - WN1(IK)) + END DO + DMM(NK+2) = ZERO + DMM(0)=DMM(1) + DO ITH=1,NTH + DO IK=2,NK + ISP = ITH + (IK -1)*NTH + ISPm1 = ITH + (IK-1 -1)*NTH + eFactM1 = CG1(IK-1) / CG1(IK) + eA_SIG = - eSI * CP_SIG(ISPm1)/DMM(IK-1) * eFactM1 + eSum(ISP) = eSum(ISP) - eA_SIG*VA(ISPm1,IP) END DO - ELSE IF (FreqShiftMethod .eq. 2) THEN - CWNB_M2=CWNB_SIG_M2(:,IP) - DO IK=1, NK - DWNI_M2(IK) = DBLE( CG1(IK) / DSIP(IK) ) + DO IK=1,NK-1 + ISP = ITH + (IK -1)*NTH + ISPp1 = ITH + (IK+1 -1)*NTH + eFactP1 = CG1(IK+1) / CG1(IK) + eC_SIG = eSI * CM_SIG(ISPp1)/DMM(IK) * eFactP1 + eSum(ISP) = eSum(ISP) - eC_SIG*VA(ISPp1,IP) END DO + END DO + ELSE IF (FreqShiftMethod .eq. 2) THEN + CWNB_M2=CWNB_SIG_M2(:,IP) + DO IK=1, NK + DWNI_M2(IK) = DBLE( CG1(IK) / DSIP(IK) ) + END DO #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) 'Before FreqShift oper eSum=', sum(abs(eSum)) + WRITE(740+IAPROC,*) 'Before FreqShift oper eSum=', sum(abs(eSum)) #endif - DO ITH=1,NTH - DO IK=2,NK - ISP = ITH + (IK -1)*NTH - ISPm1 = ITH + (IK-1 -1)*NTH - eFactM1 = DBLE( CG1(IK-1) / CG1(IK) ) - eA_SIG = - eSI * DWNI_M2(IK) * MAX(CWNB_M2(ISPm1),ZERO) *eFactM1 - eSum(ISP) = eSum(ISP) - eA_SIG*VA(ISPm1,IP) - END DO - DO IK=1,NK-1 - ISP = ITH + (IK -1)*NTH - ISPp1 = ITH + (IK+1 -1)*NTH - eFactP1 = DBLE( CG1(IK+1) / CG1(IK) ) - eC_SIG = eSI * DWNI_M2(IK) * MIN(CWNB_M2(ISP),ZERO) * eFactP1 - eSum(ISP) = eSum(ISP) - eC_SIG*VA(ISPp1,IP) - END DO + DO ITH=1,NTH + DO IK=2,NK + ISP = ITH + (IK -1)*NTH + ISPm1 = ITH + (IK-1 -1)*NTH + eFactM1 = DBLE( CG1(IK-1) / CG1(IK) ) + eA_SIG = - eSI * DWNI_M2(IK) * MAX(CWNB_M2(ISPm1),ZERO) *eFactM1 + eSum(ISP) = eSum(ISP) - eA_SIG*VA(ISPm1,IP) END DO + DO IK=1,NK-1 + ISP = ITH + (IK -1)*NTH + ISPp1 = ITH + (IK+1 -1)*NTH + eFactP1 = DBLE( CG1(IK+1) / CG1(IK) ) + eC_SIG = eSI * DWNI_M2(IK) * MIN(CWNB_M2(ISP),ZERO) * eFactP1 + eSum(ISP) = eSum(ISP) - eC_SIG*VA(ISPp1,IP) + END DO + END DO #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) ' after FreqShift oper eSum=', sum(abs(eSum)) + WRITE(740+IAPROC,*) ' after FreqShift oper eSum=', sum(abs(eSum)) #endif - END IF END IF + END IF #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'Step 4: sum(eSum)=', sum(eSum) + WRITE(740+IAPROC,*) 'Step 4: sum(eSum)=', sum(eSum) #endif #ifdef W3_DEBUGSOLVERCOH PRE_VA(:, IP)=REAL(eSum) #endif - eSum(1:NSPEC) = eSum(1:NSPEC) / ASPAR_DIAG(1:NSPEC) + eSum(1:NSPEC) = eSum(1:NSPEC) / ASPAR_DIAG(1:NSPEC) #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) 'JSEA=', JSEA, ' nbIter=', nbIter - DO ISP=1,NSPEC - IK=MAPWN(ISP) - VAnew(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * eSum(ISP) - END DO - DO ISP=1,NSPEC - VAAnew(ISP) = VAnew(ISP) - VAAacloc(ISP) = VAacloc(ISP) - END DO - DO ITH=1,NTH - VAAnew(ITH + NSPEC) = FACHFA * VAAnew(ITH + NSPEC - NTH) - VAAnew(ITH - NTH ) = 0. - VAAacloc(ITH + NSPEC) = FACHFA * VAAacloc(ITH + NSPEC - NTH) - VAAacloc(ITH - NTH ) = 0. - END DO - DO ISP=1-NTH,NSPEC - VFLWN(ISP) = MAX(CWNB_M2(ISP),0.) * VAAnew(ISP) + MIN(CWNB_M2(ISP),0.) * VAAnew(ISP + NTH) - END DO - DO ISP=1,NSPEC - eDiff(ISP) = VAnew(ISP) - VAold(ISP) - DWNI_M2(MAPWN(ISP)) * (VFLWN(ISP-NTH) - VFLWN(ISP) ) - eVal1=MAX(CWNB_M2(ISP-NTH),0.) * VAAacloc(ISP-NTH) + MIN(CWNB_M2(ISP-NTH),0.) * VAAnew(ISP) - eVal2=MAX(CWNB_M2(ISP),0.) * VAAnew(ISP) + MIN(CWNB_M2(ISP),0.) * VAAacloc(ISP + NTH) - eDiffB(ISP) = VAnew(ISP) - VAold(ISP) - DWNI_M2(MAPWN(ISP)) * (eVal1 - eVal2) - END DO - IF (ISEA .eq. 190) THEN - DO IK=1,NK - DO ITH=1,NTH - ISP = ITH + (IK-1)*NTH - WRITE(740+IAPROC,*) 'ISP/ITH/IK=', ISP, ITH, IK - WRITE(740+IAPROC,*) 'eDiff(A/B)=', eDiff(ISP), eDiffB(ISP) - END DO + WRITE(740+IAPROC,*) 'JSEA=', JSEA, ' nbIter=', nbIter + DO ISP=1,NSPEC + IK=MAPWN(ISP) + VAnew(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * eSum(ISP) + END DO + DO ISP=1,NSPEC + VAAnew(ISP) = VAnew(ISP) + VAAacloc(ISP) = VAacloc(ISP) END DO - END IF - WRITE(740+IAPROC,*) 'NK=', NK, ' NTH=', NTH - eSumPart=0 - DO IK=1,NK DO ITH=1,NTH - ISP = ITH + (IK-1)*NTH - eSumPart = eSumPart + abs(eDiff(ISP)) + VAAnew(ITH + NSPEC) = FACHFA * VAAnew(ITH + NSPEC - NTH) + VAAnew(ITH - NTH ) = 0. + VAAacloc(ITH + NSPEC) = FACHFA * VAAacloc(ITH + NSPEC - NTH) + VAAacloc(ITH - NTH ) = 0. + END DO + DO ISP=1-NTH,NSPEC + VFLWN(ISP) = MAX(CWNB_M2(ISP),0.) * VAAnew(ISP) + MIN(CWNB_M2(ISP),0.) * VAAnew(ISP + NTH) + END DO + DO ISP=1,NSPEC + eDiff(ISP) = VAnew(ISP) - VAold(ISP) - DWNI_M2(MAPWN(ISP)) * (VFLWN(ISP-NTH) - VFLWN(ISP) ) + eVal1=MAX(CWNB_M2(ISP-NTH),0.) * VAAacloc(ISP-NTH) + MIN(CWNB_M2(ISP-NTH),0.) * VAAnew(ISP) + eVal2=MAX(CWNB_M2(ISP),0.) * VAAnew(ISP) + MIN(CWNB_M2(ISP),0.) * VAAacloc(ISP + NTH) + eDiffB(ISP) = VAnew(ISP) - VAold(ISP) - DWNI_M2(MAPWN(ISP)) * (eVal1 - eVal2) END DO IF (ISEA .eq. 190) THEN - WRITE(740+IAPROC,*) 'IK=', IK, ' eSumDiff=', eSumPart + DO IK=1,NK + DO ITH=1,NTH + ISP = ITH + (IK-1)*NTH + WRITE(740+IAPROC,*) 'ISP/ITH/IK=', ISP, ITH, IK + WRITE(740+IAPROC,*) 'eDiff(A/B)=', eDiff(ISP), eDiffB(ISP) + END DO + END DO END IF - END DO - WRITE(740+IAPROC,*) 'sum(eDiff/VAnew/VAold)=', sum(abs(eDiff)), sum(abs(VAnew)), sum(abs(VAold)) + WRITE(740+IAPROC,*) 'NK=', NK, ' NTH=', NTH + eSumPart=0 + DO IK=1,NK + DO ITH=1,NTH + ISP = ITH + (IK-1)*NTH + eSumPart = eSumPart + abs(eDiff(ISP)) + END DO + IF (ISEA .eq. 190) THEN + WRITE(740+IAPROC,*) 'IK=', IK, ' eSumDiff=', eSumPart + END IF + END DO + WRITE(740+IAPROC,*) 'sum(eDiff/VAnew/VAold)=', sum(abs(eDiff)), sum(abs(VAnew)), sum(abs(VAold)) #endif -!AR: Must go outside of the iterative loop ... - !IF (B_JGS_LIMITER) THEN - ! CALL ACTION_LIMITER_LOCAL(IP, eSum, ACLOC, DTG) - !END IF + !AR: Must go outside of the iterative loop ... + !IF (B_JGS_LIMITER) THEN + ! CALL ACTION_LIMITER_LOCAL(IP, eSum, ACLOC, DTG) + !END IF - IF (B_JGS_BLOCK_GAUSS_SEIDEL) THEN - VA(1:NSPEC,IP) = eSum !* IOBDP_LOC(IP)*DBLE(IOBPD_LOC(ITH,IP)) - !IF (IP_glob == 64058) WRITE(740+IAPROC,*) 'TEST SUM VA', IP, SUM(VA(1:NSPEC,IP)), DW(ISEA) - ELSE - U_JAC(1:NSPEC,IP) = eSum - END IF - ELSE - esum = VA(1:NSPEC,IP) - ENDIF ! LCONVERGED - - IF (B_JGS_TERMINATE_DIFFERENCE) THEN - Sum_New = sum(eSum) - if (Sum_new .gt. 0.d0) then - DiffNew = abs(sum(ACLOC-eSum))/Sum_new + IF (B_JGS_BLOCK_GAUSS_SEIDEL) THEN + VA(1:NSPEC,IP) = eSum !* IOBDP_LOC(IP)*DBLE(IOBPD_LOC(ITH,IP)) + !IF (IP_glob == 64058) WRITE(740+IAPROC,*) 'TEST SUM VA', IP, SUM(VA(1:NSPEC,IP)), DW(ISEA) + ELSE + U_JAC(1:NSPEC,IP) = eSum + END IF + ELSE + esum = VA(1:NSPEC,IP) + ENDIF ! LCONVERGED + + IF (B_JGS_TERMINATE_DIFFERENCE) THEN + Sum_New = sum(eSum) + if (Sum_new .gt. 0.d0) then + DiffNew = abs(sum(ACLOC-eSum))/Sum_new #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) 'DiffNew=', DiffNew, ' Sum_new=', Sum_new + WRITE(740+IAPROC,*) 'DiffNew=', DiffNew, ' Sum_new=', Sum_new #endif - p_is_converged = DiffNew - else - p_is_converged = zero - endif + p_is_converged = DiffNew + else + p_is_converged = zero + endif #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) 'p_is_converged=', p_is_converged + WRITE(740+IAPROC,*) 'p_is_converged=', p_is_converged #endif - IF (p_is_converged .lt. B_JGS_DIFF_THR .and. nbiter .gt. 1) then - is_converged = is_converged + 1 - lconverged(ip) = .true. - ELSE - lconverged(ip) = .false. - !write(*,*) ip, is_converged, p_is_converged, iobp_loc(ip), iobdp_loc(ip) - ENDIF - END IF - !IF (IP == 2) STOP + IF (p_is_converged .lt. B_JGS_DIFF_THR .and. nbiter .gt. 1) then + is_converged = is_converged + 1 + lconverged(ip) = .true. + ELSE + lconverged(ip) = .false. + !write(*,*) ip, is_converged, p_is_converged, iobp_loc(ip), iobdp_loc(ip) + ENDIF + END IF + !IF (IP == 2) STOP #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'sum(VA)out=', sum(VA(:,IP)) + WRITE(740+IAPROC,*) 'sum(VA)out=', sum(VA(:,IP)) #endif - !WRITE(*,*) 'TEST VA 2', IP, SUM(VA(:,IP)), IOBDP_LOC(IP), IOBPA_LOC(IP) - END DO ! IP + !WRITE(*,*) 'TEST VA 2', IP, SUM(VA(:,IP)), IOBDP_LOC(IP), IOBPA_LOC(IP) + END DO ! IP -! WRITE(740+IAPROC,*) myrank, 'afer vertex loop', nbiter + ! WRITE(740+IAPROC,*) myrank, 'afer vertex loop', nbiter #ifdef W3_MEMCHECK write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 2' @@ -6209,1562 +6203,1562 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(IMOD, FACX, FACY, DTG, VGX, VGY) #endif #ifdef W3_DEBUGSOLVERCOH - WRITE (eFile,40) nbIter - 40 FORMAT ('PRE_VA_',i4.4,'.txt') + WRITE (eFile,40) nbIter +40 FORMAT ('PRE_VA_',i4.4,'.txt') CALL CHECK_ARRAY_INTEGRAL_NX_R8(OffDiag, "OffDiag(np) just check", np) - ! CALL WRITE_VAR_TO_TEXT_FILE(PRE_VA, eFile) + ! CALL WRITE_VAR_TO_TEXT_FILE(PRE_VA, eFile) CALL CHECK_ARRAY_INTEGRAL_NX_R8(PRE_VA, "PRE_VA(np) just check", np) CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(np) before exchanges", 0) #endif - IF (B_JGS_BLOCK_GAUSS_SEIDEL) THEN - CALL PDLIB_exchange2DREAL_zero(VA) - ELSE - CALL PDLIB_exchange2DREAL(U_JAC) - VA(:,1:NPA) = U_JAC - END IF + IF (B_JGS_BLOCK_GAUSS_SEIDEL) THEN + CALL PDLIB_exchange2DREAL_zero(VA) + ELSE + CALL PDLIB_exchange2DREAL(U_JAC) + VA(:,1:NPA) = U_JAC + END IF #ifdef W3_MEMCHECK write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 3' call getMallocInfo(mallinfos) call printMallInfo(IAPROC+50000,mallInfos) #endif - ! - ! Terminate via number of iteration - ! - IF (B_JGS_TERMINATE_MAXITER) THEN - IF (nbIter .gt. B_JGS_MAXITER) THEN + ! + ! Terminate via number of iteration + ! + IF (B_JGS_TERMINATE_MAXITER) THEN + IF (nbIter .gt. B_JGS_MAXITER) THEN #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'Exiting by TERMINATE_MAXITER' + WRITE(740+IAPROC,*) 'Exiting by TERMINATE_MAXITER' #endif - EXIT - END IF + EXIT END IF + END IF #ifdef W3_MEMCHECK write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 4' call getMallocInfo(mallinfos) call printMallInfo(IAPROC+50000,mallInfos) #endif - ! - ! Terminate via differences - ! - IF (B_JGS_TERMINATE_DIFFERENCE) THEN - !WRITE(740+IAPROC,*) myrank, 'solver before', nbiter, is_converged, prop_conv, B_JGS_PMIN - CALL MPI_ALLREDUCE(is_converged, itmp, 1, MPI_INT, MPI_SUM, MPI_COMM_WCMP, ierr) - is_converged = itmp - prop_conv = (DBLE(NX) - DBLE(is_converged))/DBLE(NX) * 100. - !write(*,*) prop_conv, nbIter, is_converged - !WRITE(740+IAPROC,*) myrank, 'solver', nbiter, is_converged, prop_conv, B_JGS_PMIN + ! + ! Terminate via differences + ! + IF (B_JGS_TERMINATE_DIFFERENCE) THEN + !WRITE(740+IAPROC,*) myrank, 'solver before', nbiter, is_converged, prop_conv, B_JGS_PMIN + CALL MPI_ALLREDUCE(is_converged, itmp, 1, MPI_INT, MPI_SUM, MPI_COMM_WCMP, ierr) + is_converged = itmp + prop_conv = (DBLE(NX) - DBLE(is_converged))/DBLE(NX) * 100. + !write(*,*) prop_conv, nbIter, is_converged + !WRITE(740+IAPROC,*) myrank, 'solver', nbiter, is_converged, prop_conv, B_JGS_PMIN #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'solver', nbiter, is_converged, prop_conv, B_JGS_PMIN - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'solver', nbiter, is_converged, prop_conv, B_JGS_PMIN + FLUSH(740+IAPROC) #endif - IF (myrank == 0) WRITE(*,*) 'No. of solver iterations', nbiter, is_converged, prop_conv, B_JGS_PMIN - IF (prop_conv .le. B_JGS_PMIN + TINY(1.)) THEN + IF (myrank == 0) WRITE(*,*) 'No. of solver iterations', nbiter, is_converged, prop_conv, B_JGS_PMIN + IF (prop_conv .le. B_JGS_PMIN + TINY(1.)) THEN #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) 'prop_conv=', prop_conv - WRITE(740+IAPROC,*) 'NX=', NX - WRITE(740+IAPROC,*) 'is_converged=', is_converged - WRITE(740+IAPROC,*) 'Exiting by TERMINATE_DIFFERENCE' + WRITE(740+IAPROC,*) 'prop_conv=', prop_conv + WRITE(740+IAPROC,*) 'NX=', NX + WRITE(740+IAPROC,*) 'is_converged=', is_converged + WRITE(740+IAPROC,*) 'Exiting by TERMINATE_DIFFERENCE' #endif - EXIT - END IF + EXIT END IF + END IF #ifdef W3_MEMCHECK write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 5' call getMallocInfo(mallinfos) call printMallInfo(IAPROC+50000,mallInfos) #endif - ! - ! Terminate via norm - ! - IF (B_JGS_TERMINATE_NORM) THEN - Sum_L2 =0 - DO IP = 1, np - IP_glob=iplg(IP) - IF (IOBP_LOC(IP).eq.1) THEN - JSEA=JX_TO_JSEA(IP) - eSI=PDLIB_SI(IP) - eSum=B_JAC(:,IP) - ACLOC=VA(:,IP) - ISEA= MAPFS(1,IP_glob) - eSum(:) = eSum(:) - ASPAR_DIAG(:)*ACLOC - DO I = PDLIB_IA_P(IP)+1, PDLIB_IA_P(IP+1) - JP=PDLIB_JA(I) - eSum(:) = eSum(:) - ASPAR_JAC(:,i)*VA(:,JP) + ! + ! Terminate via norm + ! + IF (B_JGS_TERMINATE_NORM) THEN + Sum_L2 =0 + DO IP = 1, np + IP_glob=iplg(IP) + IF (IOBP_LOC(IP).eq.1) THEN + JSEA=JX_TO_JSEA(IP) + eSI=PDLIB_SI(IP) + eSum=B_JAC(:,IP) + ACLOC=VA(:,IP) + ISEA= MAPFS(1,IP_glob) + eSum(:) = eSum(:) - ASPAR_DIAG(:)*ACLOC + DO I = PDLIB_IA_P(IP)+1, PDLIB_IA_P(IP+1) + JP=PDLIB_JA(I) + eSum(:) = eSum(:) - ASPAR_JAC(:,i)*VA(:,JP) + END DO + IF (FSREFRACTION) THEN + CAD=CAD_THE(:,IP) + DO ISP=1,NSPEC + ISPprevDir=ListISPprevDir(ISP) + ISPnextDir=ListISPnextDir(ISP) + eA_THE = - DTG*eSI*MAX(ZERO,CAD(ISPprevDir)) + eC_THE = DTG*eSI*MIN(ZERO,CAD(ISPnextDir)) + eSum(ISP) = eSum(ISP) - eA_THE*VA(ISPprevDir,IP) + eSum(ISP) = eSum(ISP) - eC_THE*VA(ISPnextDir,IP) END DO - IF (FSREFRACTION) THEN - CAD=CAD_THE(:,IP) - DO ISP=1,NSPEC - ISPprevDir=ListISPprevDir(ISP) - ISPnextDir=ListISPnextDir(ISP) - eA_THE = - DTG*eSI*MAX(ZERO,CAD(ISPprevDir)) - eC_THE = DTG*eSI*MIN(ZERO,CAD(ISPnextDir)) - eSum(ISP) = eSum(ISP) - eA_THE*VA(ISPprevDir,IP) - eSum(ISP) = eSum(ISP) - eC_THE*VA(ISPnextDir,IP) - END DO - END IF - IF (FSFREQSHIFT) THEN - CAS=CAS_SIG(:,IP) - CP_SIG = MAX(ZERO,CAS) - CM_SIG = MIN(ZERO,CAS) - DO IK = 0, NK + 1 + END IF + IF (FSFREQSHIFT) THEN + CAS=CAS_SIG(:,IP) + CP_SIG = MAX(ZERO,CAS) + CM_SIG = MIN(ZERO,CAS) + DO IK = 0, NK + 1 #ifdef NOCGTABLE - CALL WAVNU_LOCAL(SIG(IK),DW(ISEA),WN1(IK),CG1(IK)) + CALL WAVNU_LOCAL(SIG(IK),DW(ISEA),WN1(IK),CG1(IK)) #else - CG1(IK) = CG(IK,ISEA) - WN1(IK) = WN(IK,ISEA) -#endif - ENDDO - DO ITH=1,NTH - IF (IOBPD_LOC(ITH,IP) .NE. 0) THEN - DO IK=2,NK - ISP =ITH + (IK -1)*NTH - ISPm1=ITH + (IK-1-1)*NTH - eFactM1=CG(IK-1,ISEA) / CG1(IK) - eA_SIG= - eSI*CP_SIG(ISPm1)/DMM(IK-1) * eFactM1 - eSum(ISP) = eSum(ISP) - eA_SIG*VA(ISPm1,IP) - END DO - DO IK=1,NK-1 - ISP =ITH + (IK -1)*NTH - ISPp1=ITH + (IK+1-1)*NTH - eFactP1=CG(IK+1,ISEA) / CG1(IK) - eC_SIG= eSI*CM_SIG(ISPp1)/DMM(IK) * eFactP1 - eSum(ISP) = eSum(ISP) - eC_SIG*VA(ISPp1,IP) - END DO - END IF - END DO - END IF - Sum_L2 = Sum_L2 + sum(eSum*eSum) + CG1(IK) = CG(IK,ISEA) + WN1(IK) = WN(IK,ISEA) +#endif + ENDDO + DO ITH=1,NTH + IF (IOBPD_LOC(ITH,IP) .NE. 0) THEN + DO IK=2,NK + ISP =ITH + (IK -1)*NTH + ISPm1=ITH + (IK-1-1)*NTH + eFactM1=CG(IK-1,ISEA) / CG1(IK) + eA_SIG= - eSI*CP_SIG(ISPm1)/DMM(IK-1) * eFactM1 + eSum(ISP) = eSum(ISP) - eA_SIG*VA(ISPm1,IP) + END DO + DO IK=1,NK-1 + ISP =ITH + (IK -1)*NTH + ISPp1=ITH + (IK+1-1)*NTH + eFactP1=CG(IK+1,ISEA) / CG1(IK) + eC_SIG= eSI*CM_SIG(ISPp1)/DMM(IK) * eFactP1 + eSum(ISP) = eSum(ISP) - eC_SIG*VA(ISPp1,IP) + END DO + END IF + END DO END IF - END DO - CALL MPI_ALLREDUCE(Sum_L2, Sum_L2_GL, 1, rtype, MPI_SUM, MPI_COMM_WCMP, ierr) - !WRITE(*,*) 'Sum_L2_gl=', Sum_L2_gl + Sum_L2 = Sum_L2 + sum(eSum*eSum) + END IF + END DO + CALL MPI_ALLREDUCE(Sum_L2, Sum_L2_GL, 1, rtype, MPI_SUM, MPI_COMM_WCMP, ierr) + !WRITE(*,*) 'Sum_L2_gl=', Sum_L2_gl #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'Sum_L2_gl=', Sum_L2_gl - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Sum_L2_gl=', Sum_L2_gl + FLUSH(740+IAPROC) #endif - IF (Sum_L2_gl .le. B_JGS_NORM_THR) THEN + IF (Sum_L2_gl .le. B_JGS_NORM_THR) THEN #ifdef W3_DEBUGFREQSHIFT - WRITE(740+IAPROC,*) 'Exiting by TERMINATE_NORM' + WRITE(740+IAPROC,*) 'Exiting by TERMINATE_NORM' #endif - EXIT - END IF + EXIT END IF + END IF #ifdef W3_MEMCHECK write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 6' call getMallocInfo(mallinfos) call printMallInfo(IAPROC+50000,mallInfos) #endif - nbiter = nbiter + 1 - - END DO ! Open Do Loop ... End of Time Interval + nbiter = nbiter + 1 + + END DO ! Open Do Loop ... End of Time Interval #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'nbIter=', nbIter, ' B_JGS_MAXITER=', B_JGS_MAXITER - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'nbIter=', nbIter, ' B_JGS_MAXITER=', B_JGS_MAXITER + FLUSH(740+IAPROC) #endif -! Tihs is below also goes into the matrix ... like the wave boundary ... - DO IP = 1, npa + ! Tihs is below also goes into the matrix ... like the wave boundary ... + DO IP = 1, npa #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'IOBPD loop, Before, sum(VA)=', sum(VA(:,IP)) + WRITE(740+IAPROC,*) 'IOBPD loop, Before, sum(VA)=', sum(VA(:,IP)) #endif - DO ISP=1,NSPEC - ITH = 1 + MOD(ISP-1,NTH) - !IF (IOBPD_LOC(ITH,IP) .ne. IOBPD(ITH,IP_glob)) STOP 'ERROR IN BOUNDARY' - VA(ISP,IP)=MAX(ZERO, VA(ISP,IP))*IOBDP_LOC(IP)*DBLE(IOBPD_LOC(ITH,IP)) - END DO - !WRITE(*,'(4I10,A20)') IP, IOBDP_LOC(IP), IOBP_LOC(IP), IOBPA_LOC(IP), 'IOBP TEST' + DO ISP=1,NSPEC + ITH = 1 + MOD(ISP-1,NTH) + !IF (IOBPD_LOC(ITH,IP) .ne. IOBPD(ITH,IP_glob)) STOP 'ERROR IN BOUNDARY' + VA(ISP,IP)=MAX(ZERO, VA(ISP,IP))*IOBDP_LOC(IP)*DBLE(IOBPD_LOC(ITH,IP)) + END DO + !WRITE(*,'(4I10,A20)') IP, IOBDP_LOC(IP), IOBP_LOC(IP), IOBPA_LOC(IP), 'IOBP TEST' #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'IOBPD loop, After, sum(VA)=', sum(VA(:,IP)) + WRITE(740+IAPROC,*) 'IOBPD loop, After, sum(VA)=', sum(VA(:,IP)) #endif - END DO + END DO #ifdef W3_DEBUGSOLVERCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) after loop", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) after loop", 1) #endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'FLBPI=', FLBPI - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'FLBPI=', FLBPI + FLUSH(740+IAPROC) #endif - DO JSEA=1, NSEAL + DO JSEA=1, NSEAL - IP = JSEA - IP_glob = iplg(IP) - ISEA = MAPFS(1,IP_glob) -! + IP = JSEA + IP_glob = iplg(IP) + ISEA = MAPFS(1,IP_glob) + ! #ifdef W3_DEBUGSRC - IntDiff=0 - SumVS=0 - SumVD=0 - SumVAin=0 - SumVAout=0 - SumVAw3srce=0 - SumACout=0 -#endif -! - DO ISP=1,NSPEC + IntDiff=0 + SumVS=0 + SumVD=0 + SumVAin=0 + SumVAout=0 + SumVAw3srce=0 + SumACout=0 +#endif + ! + DO ISP=1,NSPEC - IK = 1 + (ISP-1)/NTH + IK = 1 + (ISP-1)/NTH #ifdef NOCGTABLE - CALL WAVNU_LOCAL(SIG(IK),DW(ISEA),WN1(IK),CG1(IK)) + CALL WAVNU_LOCAL(SIG(IK),DW(ISEA),WN1(IK),CG1(IK)) #else - CG1(IK) = CG(IK,ISEA) + CG1(IK) = CG(IK,ISEA) #endif - eVA = MAX ( ZERO ,CG1(IK)/CLATS(ISEA)*REAL(VA(ISP,IP)) ) + eVA = MAX ( ZERO ,CG1(IK)/CLATS(ISEA)*REAL(VA(ISP,IP)) ) #ifdef W3_DEBUGSRC - SumACout=SumACout + REAL(VA(ISP,IP)) - VS_w3srce = VSTOT(ISP,JSEA) * DTG / MAX(1., (1. - DTG*VDTOT(ISP,JSEA))) - eVA_w3srce = MAX(0., VA(ISP,JSEA) + VS_w3srce) - IntDiff = IntDiff + abs(eVA - eVA_w3srce) - ACsolve=B_JAC(ISP,IP)/ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - eB=VA(ISP,JSEA) + DTG*(VSTOT(ISP,JSEA) - VDTOT(ISP,JSEA)*VA(ISP,JSEA)) - eVAsolve=MAX(0., CG(IK,ISEA)/CLATS(ISEA)*ACsolve) - VAsolve(ISP)=eVAsolve - SumVS = SumVS + abs(VSTOT(ISP,JSEA)) - SumVD = SumVD + abs(VDTOT(ISP,JSEA)) - SumVAin = SumVAin + abs(VA(ISP,JSEA)) - SumVAout = SumVAout + abs(eVA) - SumVAw3srce = SumVAw3srce + abs(eVA_w3srce) -#endif - VA(ISP,JSEA) = eVA - END DO + SumACout=SumACout + REAL(VA(ISP,IP)) + VS_w3srce = VSTOT(ISP,JSEA) * DTG / MAX(1., (1. - DTG*VDTOT(ISP,JSEA))) + eVA_w3srce = MAX(0., VA(ISP,JSEA) + VS_w3srce) + IntDiff = IntDiff + abs(eVA - eVA_w3srce) + ACsolve=B_JAC(ISP,IP)/ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) + eB=VA(ISP,JSEA) + DTG*(VSTOT(ISP,JSEA) - VDTOT(ISP,JSEA)*VA(ISP,JSEA)) + eVAsolve=MAX(0., CG(IK,ISEA)/CLATS(ISEA)*ACsolve) + VAsolve(ISP)=eVAsolve + SumVS = SumVS + abs(VSTOT(ISP,JSEA)) + SumVD = SumVD + abs(VDTOT(ISP,JSEA)) + SumVAin = SumVAin + abs(VA(ISP,JSEA)) + SumVAout = SumVAout + abs(eVA) + SumVAw3srce = SumVAw3srce + abs(eVA_w3srce) +#endif + VA(ISP,JSEA) = eVA + END DO #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' IntDiff=', IntDiff, ' DTG=', DTG - IF (ISEA .eq. TESTNODE) THEN - DO ISP=1,NSPEC - WRITE(740+IAPROC,*) 'ISP=', ISP, 'VA/VAsolve=', VA(ISP,JSEA), VAsolve(ISP) - END DO - END IF - WRITE(740+IAPROC,*) 'SHAVE=', SHAVETOT(JSEA) - WRITE(740+IAPROC,*) 'Sum(VS/VD)=', SumVS, SumVD - WRITE(740+IAPROC,*) 'min/max/sum(VS)=', minval(VSTOT(:,JSEA)), maxval(VSTOT(:,JSEA)), sum(VSTOT(:,JSEA)) - WRITE(740+IAPROC,*) 'min/max/sum(VD)=', minval(VDTOT(:,JSEA)), maxval(VDTOT(:,JSEA)), sum(VDTOT(:,JSEA)) - WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) - WRITE(740+IAPROC,*) 'min/max/sum(VAsolve)=', minval(VAsolve), maxval(VAsolve), sum(VAsolve) - WRITE(740+IAPROC,*) 'SumVA(in/out/w3srce)=', SumVAin, SumVAout, SumVAw3srce - WRITE(740+IAPROC,*) 'SumACout=', SumACout -#endif - END DO ! JSEA - -#ifdef WEIGHTS - INQUIRE ( FILE='weights.ww3', EXIST = lexist ) - if (.not. lexist) then - ipitergl = 0 - ipiterout = 0 - DO IP = 1, np - ipitergl(iplg(IP)) = ipiter(ip) + WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' IntDiff=', IntDiff, ' DTG=', DTG + IF (ISEA .eq. TESTNODE) THEN + DO ISP=1,NSPEC + WRITE(740+IAPROC,*) 'ISP=', ISP, 'VA/VAsolve=', VA(ISP,JSEA), VAsolve(ISP) END DO - call mpi_reduce(ipitergl,ipiterout,NP_GLOBAL,MPI_INT,MPI_SUM,0,MPI_COMM_WCMP,ierr) - if (myrank == 0) tHEN - OPEN(100001,FILE='weights.ww3',FORM='FORMATTED',STATUS='unknown') - do ip = 1, np_global - write(100001,*) ipiterout(ip) - enddo - CLOSE(100001) - endif + END IF + WRITE(740+IAPROC,*) 'SHAVE=', SHAVETOT(JSEA) + WRITE(740+IAPROC,*) 'Sum(VS/VD)=', SumVS, SumVD + WRITE(740+IAPROC,*) 'min/max/sum(VS)=', minval(VSTOT(:,JSEA)), maxval(VSTOT(:,JSEA)), sum(VSTOT(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VD)=', minval(VDTOT(:,JSEA)), maxval(VDTOT(:,JSEA)), sum(VDTOT(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VAsolve)=', minval(VAsolve), maxval(VAsolve), sum(VAsolve) + WRITE(740+IAPROC,*) 'SumVA(in/out/w3srce)=', SumVAin, SumVAout, SumVAw3srce + WRITE(740+IAPROC,*) 'SumACout=', SumACout +#endif + END DO ! JSEA + +#ifdef WEIGHTS + INQUIRE ( FILE='weights.ww3', EXIST = lexist ) + if (.not. lexist) then + ipitergl = 0 + ipiterout = 0 + DO IP = 1, np + ipitergl(iplg(IP)) = ipiter(ip) + END DO + call mpi_reduce(ipitergl,ipiterout,NP_GLOBAL,MPI_INT,MPI_SUM,0,MPI_COMM_WCMP,ierr) + if (myrank == 0) tHEN + OPEN(100001,FILE='weights.ww3',FORM='FORMATTED',STATUS='unknown') + do ip = 1, np_global + write(100001,*) ipiterout(ip) + enddo + CLOSE(100001) endif + endif #endif - !B_JAC = 0. - !ASPAR_JAC = 0. + !B_JAC = 0. + !ASPAR_JAC = 0. - !DO JSEA = 1, NP - ! WRITE(70000+IAPROC,*) 'SUM VA EXIT SOLVER', JSEA, SUM(VA(:,JSEA)) - !ENDDO + !DO JSEA = 1, NP + ! WRITE(70000+IAPROC,*) 'SUM VA EXIT SOLVER', JSEA, SUM(VA(:,JSEA)) + !ENDDO -! + ! #ifdef W3_MEMCHECK - write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 7' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+50000,mallInfos) + write(50000+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+50000,mallInfos) #endif -! + ! #ifdef W3_DEBUGSRC - DO JSEA=1,NSEAL - WRITE(740+IAPROC,*) 'JSEA=', JSEA - WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) - END DO - WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) + DO JSEA=1,NSEAL + WRITE(740+IAPROC,*) 'JSEA=', JSEA + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) + END DO + WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) #endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, end' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, end' + FLUSH(740+IAPROC) #endif - END SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK -!/ ------------------------------------------------------------------- / - SUBROUTINE PDLIB_EXPLICIT_BLOCK(IMOD, FACX, FACY, DTG, VGX, VGY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Explicit block solver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! + END SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK + !/ ------------------------------------------------------------------- / + SUBROUTINE PDLIB_EXPLICIT_BLOCK(IMOD, FACX, FACY, DTG, VGX, VGY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Explicit block solver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -!/ - !USE W3GDATMD, only: MAPSTA - USE W3GDATMD, only: FSREFRACTION, FSFREQSHIFT, FSSOURCE, NX, DSIP - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3GDATMD, only: B_JGS_NORM_THR, B_JGS_TERMINATE_NORM, B_JGS_PMIN, NTRI - USE W3GDATMD, only: B_JGS_TERMINATE_DIFFERENCE, B_JGS_MAXITER, B_JGS_LIMITER - USE W3GDATMD, only: B_JGS_TERMINATE_MAXITER, B_JGS_BLOCK_GAUSS_SEIDEL, B_JGS_DIFF_THR - USE W3GDATMD, only: MAPWN - USE MPI, only : MPI_MIN - use yowElementpool, only: ne, INE - USE YOWNODEPOOL, only: PDLIB_I_DIAG, PDLIB_IA_P, PDLIB_JA, np - USE YOWNODEPOOL, only: PDLIB_SI, PDLIB_IEN, PDLIB_CCON, NPA, PDLIB_IE_CELL2, PDLIB_POS_CELL2 - use yowDatapool, only: rtype - use YOWNODEPOOL, only: npa, iplg - use yowExchangeModule, only : PDLIB_exchange2Dreal_zero - USE W3ADATMD, only: WN - USE MPI, only : MPI_SUM, MPI_INT - USE W3ADATMD, only: MPI_COMM_WCMP, CFLXYMAX - USE W3GDATMD, only: IOBP, IOBPD, NSEA, SIG, IOBDP - USE W3GDATMD, only: NK, NK2, NTH, ECOS, ESIN, NSPEC, MAPFS - USE W3WDATMD, only: TIME - USE W3TIMEMD, only: DSEC21 - USE W3GDATMD, only: NSEAL, CLATS, FACHFA - USE W3IDATMD, only: FLCUR + USE W3SERVMD, only: STRACE +#endif + !/ + !USE W3GDATMD, only: MAPSTA + USE W3GDATMD, only: FSREFRACTION, FSFREQSHIFT, FSSOURCE, NX, DSIP + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3GDATMD, only: B_JGS_NORM_THR, B_JGS_TERMINATE_NORM, B_JGS_PMIN, NTRI + USE W3GDATMD, only: B_JGS_TERMINATE_DIFFERENCE, B_JGS_MAXITER, B_JGS_LIMITER + USE W3GDATMD, only: B_JGS_TERMINATE_MAXITER, B_JGS_BLOCK_GAUSS_SEIDEL, B_JGS_DIFF_THR + USE W3GDATMD, only: MAPWN + USE MPI, only : MPI_MIN + use yowElementpool, only: ne, INE + USE YOWNODEPOOL, only: PDLIB_I_DIAG, PDLIB_IA_P, PDLIB_JA, np + USE YOWNODEPOOL, only: PDLIB_SI, PDLIB_IEN, PDLIB_CCON, NPA, PDLIB_IE_CELL2, PDLIB_POS_CELL2 + use yowDatapool, only: rtype + use YOWNODEPOOL, only: npa, iplg + use yowExchangeModule, only : PDLIB_exchange2Dreal_zero + USE W3ADATMD, only: WN + USE MPI, only : MPI_SUM, MPI_INT + USE W3ADATMD, only: MPI_COMM_WCMP, CFLXYMAX + USE W3GDATMD, only: IOBP, IOBPD, NSEA, SIG, IOBDP + USE W3GDATMD, only: NK, NK2, NTH, ECOS, ESIN, NSPEC, MAPFS + USE W3WDATMD, only: TIME + USE W3TIMEMD, only: DSEC21 + USE W3GDATMD, only: NSEAL, CLATS, FACHFA + USE W3IDATMD, only: FLCUR #ifdef W3_DEBUGSRC - USE W3WDATMD, only: SHAVETOT -#endif - USE W3WDATMD, only: VA, VSTOT, VDTOT - USE W3ADATMD, only: CG, CX, CY, MPI_COMM_WCMP - USE W3ODATMD, only: TBPIN, FLBPI, IAPROC - USE W3PARALL, only : INIT_GET_JSEA_ISPROC, ZERO, THR8 - USE W3PARALL, only : ListISPprevDir, ListISPnextDir - USE W3PARALL, only : JX_TO_JSEA - USE W3GDATMD, only: B_JGS_NLEVEL -! - implicit none - INTEGER, INTENT(IN) :: IMOD - REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY - ! - INTEGER :: IP, ISP, ITH, IK, JSEA, ISEA, IP_glob, IE, IPOS - ! for the exchange - REAL :: CCOS, CSIN, CCURX, CCURY - REAL :: eSum(NSPEC) - INTEGER :: ITER_EXP(nspec) - INTEGER :: ISPp1, ISPm1, JP, I1, I2, I3, NI(3), IT - INTEGER, SAVE :: ITER_MAX - REAL :: eFactM1, eFactP1 - REAL :: Sum_Prev, Sum_New - REAL :: prop_conv, eSI, p_is_converged - REAL :: Sum_L2, Sum_L2_GL - REAL :: DMM(0:NK2) - REAL :: DiffNew, DTMAX_GLOBAL_EXP, DTMAX_EXP - REAL :: eDiff(NSPEC), eProd(NSPEC), u33(nspec,3) - REAL :: DWNI_M2(NK), CWNB_M2(1-NTH:NSPEC), LAMBDA(NSPEC,3) - REAL :: VAnew(NSPEC), VAold(NSPEC), REST, CFLXY, DT4AI - REAL :: VAinput(NSPEC), VAacloc(NSPEC), eDiffB(NSPEC), KTMP(nspec,3), TMP(nspec) - REAL :: eDiffSing, eSumPart, N(nspec,ntri), kksum(nspec,npa), ST3(nspec), utilde33(nspec) - REAL :: FL11(NSPEC),FL12(NSPEC),FL21(NSPEC),FL22(NSPEC),FL31(NSPEC),FL32(NSPEC) - REAL :: FL111(NSPEC), FL112(NSPEC), FL211(NSPEC), FL212(NSPEC), FL311(NSPEC), FL312(NSPEC) - REAL :: KELEMGL(NSPEC,3,NTRI), FLALLGL(NSPEC,3,NTRI) - REAL :: eVal1, eVal2,thr - REAL :: eVA + USE W3WDATMD, only: SHAVETOT +#endif + USE W3WDATMD, only: VA, VSTOT, VDTOT + USE W3ADATMD, only: CG, CX, CY, MPI_COMM_WCMP + USE W3ODATMD, only: TBPIN, FLBPI, IAPROC + USE W3PARALL, only : INIT_GET_JSEA_ISPROC, ZERO, THR8 + USE W3PARALL, only : ListISPprevDir, ListISPnextDir + USE W3PARALL, only : JX_TO_JSEA + USE W3GDATMD, only: B_JGS_NLEVEL + ! + implicit none + INTEGER, INTENT(IN) :: IMOD + REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY + ! + INTEGER :: IP, ISP, ITH, IK, JSEA, ISEA, IP_glob, IE, IPOS + ! for the exchange + REAL :: CCOS, CSIN, CCURX, CCURY + REAL :: eSum(NSPEC) + INTEGER :: ITER_EXP(nspec) + INTEGER :: ISPp1, ISPm1, JP, I1, I2, I3, NI(3), IT + INTEGER, SAVE :: ITER_MAX + REAL :: eFactM1, eFactP1 + REAL :: Sum_Prev, Sum_New + REAL :: prop_conv, eSI, p_is_converged + REAL :: Sum_L2, Sum_L2_GL + REAL :: DMM(0:NK2) + REAL :: DiffNew, DTMAX_GLOBAL_EXP, DTMAX_EXP + REAL :: eDiff(NSPEC), eProd(NSPEC), u33(nspec,3) + REAL :: DWNI_M2(NK), CWNB_M2(1-NTH:NSPEC), LAMBDA(NSPEC,3) + REAL :: VAnew(NSPEC), VAold(NSPEC), REST, CFLXY, DT4AI + REAL :: VAinput(NSPEC), VAacloc(NSPEC), eDiffB(NSPEC), KTMP(nspec,3), TMP(nspec) + REAL :: eDiffSing, eSumPart, N(nspec,ntri), kksum(nspec,npa), ST3(nspec), utilde33(nspec) + REAL :: FL11(NSPEC),FL12(NSPEC),FL21(NSPEC),FL22(NSPEC),FL31(NSPEC),FL32(NSPEC) + REAL :: FL111(NSPEC), FL112(NSPEC), FL211(NSPEC), FL212(NSPEC), FL311(NSPEC), FL312(NSPEC) + REAL :: KELEMGL(NSPEC,3,NTRI), FLALLGL(NSPEC,3,NTRI) + REAL :: eVal1, eVal2,thr + REAL :: eVA #ifdef W3_DEBUGSRC - REAL :: IntDiff, eVA_w3srce, eVAsolve, SumACout - REAL :: SumVAin, SumVAout, SumVAw3srce, SumVS, SumVD, VS_w3srce - REAL :: VAsolve(NSPEC) - REAL*8 :: ACsolve - REAL :: eB + REAL :: IntDiff, eVA_w3srce, eVAsolve, SumACout + REAL :: SumVAin, SumVAout, SumVAw3srce, SumVS, SumVD, VS_w3srce + REAL :: VAsolve(NSPEC) + REAL*8 :: ACsolve + REAL :: eB #endif - REAL :: ASPAR_DIAG(NSPEC) + REAL :: ASPAR_DIAG(NSPEC) #ifdef W3_DEBUGSOLVERCOH - REAL*8 :: PRE_VA(NSPEC, npa) - REAL*8 :: OffDIAG(NSPEC, npa) - REAL*8 :: eOff(NSPEC) - REAL*8 :: eSum1(NSPEC), eSum2(NSPEC) -#endif - CHARACTER(len=128) eFile - INTEGER ierr, i - INTEGER JP_glob - INTEGER is_converged, itmp - thr = dble(tiny(1.)) - CCURX = FACX - CCURY = FACY + REAL*8 :: PRE_VA(NSPEC, npa) + REAL*8 :: OffDIAG(NSPEC, npa) + REAL*8 :: eOff(NSPEC) + REAL*8 :: eSum1(NSPEC), eSum2(NSPEC) +#endif + CHARACTER(len=128) eFile + INTEGER ierr, i + INTEGER JP_glob + INTEGER is_converged, itmp + thr = dble(tiny(1.)) + CCURX = FACX + CCURY = FACY #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'EXPLICIT BLOCK SOLVER, begin' - WRITE(740+IAPROC,*) 'NX=', NX - WRITE(740+IAPROC,*) 'NP=', NP - WRITE(740+IAPROC,*) 'NPA=', NPA - WRITE(740+IAPROC,*) 'NSEA=', NSEA - WRITE(740+IAPROC,*) 'NSEAL=', NSEAL - FLUSH(740+IAPROC) -#endif -! -! 1.b Initialize arrays -! -! 2. Calculate velocities ---------------- * -! -#ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'NSEAL =', NSEAL - WRITE(740+IAPROC,*) 'NP =', NP - WRITE(740+IAPROC,*) 'NPA =', NPA -#endif - DO JSEA=1,NSEAL - IP = JSEA - IP_glob=iplg(IP) - ISEA=MAPFS(1,IP_glob) - DO ISP=1,NSPEC - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - CCOS = FACX * ECOS(ITH) - CSIN = FACY * ESIN(ITH) - VA(ISP,IP) = DBLE(VA(ISP,JSEA) / CG(IK,ISEA) * CLATS(ISEA)) -#ifdef W3_MGP - VLCFLX(ISP,IP) = VLCFLX(ISP,IP) - CCURX*VGX/CLATS(ISEA) - VLCFLY(ISP,IP) = VLCFLY(ISP,IP) - CCURY*VGY + WRITE(740+IAPROC,*) 'EXPLICIT BLOCK SOLVER, begin' + WRITE(740+IAPROC,*) 'NX=', NX + WRITE(740+IAPROC,*) 'NP=', NP + WRITE(740+IAPROC,*) 'NPA=', NPA + WRITE(740+IAPROC,*) 'NSEA=', NSEA + WRITE(740+IAPROC,*) 'NSEAL=', NSEAL + FLUSH(740+IAPROC) #endif - END DO - END DO + ! + ! 1.b Initialize arrays + ! + ! 2. Calculate velocities ---------------- * + ! #ifdef W3_DEBUGSRC - DO IP=1,NP - WRITE(740+IAPROC,*) 'IP=', IP - WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,IP)), maxval(VA(:,IP)), sum(VA(:,IP)) - END DO -#endif - -#ifdef W3_DEBUGSOLVERCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(np) just defined", 0) - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) just defined", 1) + WRITE(740+IAPROC,*) 'NSEAL =', NSEAL + WRITE(740+IAPROC,*) 'NP =', NP + WRITE(740+IAPROC,*) 'NPA =', NPA #endif -#ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'JACOBI_SOLVER, step 3' - WRITE(740+IAPROC,*) 'FLCUR=', FLCUR - FLUSH(740+IAPROC) - WRITE(740+IAPROC,*) 'EXPLICIT BLOCK SOLVER, step 4' - WRITE(740+IAPROC,*) 'min,max(0)=', 0 - WRITE(740+IAPROC,*) 'min,max(0)=', 0 - FLUSH(740+IAPROC) -#endif - - DO IE = 1, NE - I1 = INE(1,IE) - I2 = INE(2,IE) - I3 = INE(3,IE) - !LAMBDA(:,1) = 1./6. *(C(:,I1,1)+C(:,I2,1)+C(:,I3,1)) - !LAMBDA(:,2) = 1./6. *(C(:,I1,2)+C(:,I2,2)+C(:,I3,2)) - KELEMGL(:,1,IE) = LAMBDA(:,1) * PDLIB_IEN(1,IE) + LAMBDA(:,2) * PDLIB_IEN(2,IE) - KELEMGL(:,2,IE) = LAMBDA(:,1) * PDLIB_IEN(3,IE) + LAMBDA(:,2) * PDLIB_IEN(4,IE) - KELEMGL(:,3,IE) = LAMBDA(:,1) * PDLIB_IEN(5,IE) + LAMBDA(:,2) * PDLIB_IEN(6,IE) - KTMP(:,1) = KELEMGL(:,1,IE) - KTMP(:,2) = KELEMGL(:,2,IE) - KTMP(:,3) = KELEMGL(:,3,IE) - TMP(:) = SUM(MIN(ZERO,KTMP(:,:)),DIM=2) - N(:,IE) = -1.d0/MIN(-THR,TMP(:)) - KELEMGL(:,1,IE) = MAX(ZERO,KTMP(:,1)) - KELEMGL(:,2,IE) = MAX(ZERO,KTMP(:,2)) - KELEMGL(:,3,IE) = MAX(ZERO,KTMP(:,3)) -! FL11 = C(:,I2,1) * PDLIB_IEN(1,IE) + C(:,I2,2) * PDLIB_IEN(2,IE) -! FL12 = C(:,I3,1) * PDLIB_IEN(1,IE) + C(:,I3,2) * PDLIB_IEN(2,IE) -! FL21 = C(:,I3,1) * PDLIB_IEN(3,IE) + C(:,I3,2) * PDLIB_IEN(4,IE) -! FL22 = C(:,I1,1) * PDLIB_IEN(3,IE) + C(:,I1,2) * PDLIB_IEN(4,IE) -! FL31 = C(:,I1,1) * PDLIB_IEN(5,IE) + C(:,I1,2) * PDLIB_IEN(6,IE) -! FL32 = C(:,I2,1) * PDLIB_IEN(5,IE) + C(:,I2,2) * PDLIB_IEN(6,IE) - FL111 = 2*FL11+FL12 - FL112 = 2*FL12+FL11 - FL211 = 2*FL21+FL22 - FL212 = 2*FL22+FL21 - FL311 = 2*FL31+FL32 - FL312 = 2*FL32+FL31 - FLALLGL(:,1,IE) = (FL311 + FL212) * 1./6. + KELEMGL(:,1,IE) - FLALLGL(:,2,IE) = (FL111 + FL312) * 1./6. + KELEMGL(:,2,IE) - FLALLGL(:,3,IE) = (FL211 + FL112) * 1./6. + KELEMGL(:,3,IE) - END DO - - KKSUM = 0.d0 - DO IE = 1, NE - NI = INE(:,IE) - KKSUM(:,NI) = KKSUM(:,NI) + KELEMGL(:,:,IE) - END DO - DTMAX_GLOBAL_EXP = 1.d0/THR - DO IP = 1, NP - DTMAX_EXP = PDLIB_SI(IP)/MAX(THR,MAXVAL(KKSUM(:,IP))) - DTMAX_GLOBAL_EXP = MIN ( DTMAX_GLOBAL_EXP, DTMAX_EXP) - CFLXYMAX(IP) = DBLE(DTG)/DTMAX_EXP - END DO - rest = CFLXYMAX(1) - DO IP = 2, NP - if (rest .lt. CFLXYMAX(IP)) then - rest = CFLXYMAX(IP) - iter_max = ip - endif - END DO - - DTMAX_EXP=DTMAX_GLOBAL_EXP - call mpi_allreduce(DTMAX_EXP,DTMAX_GLOBAL_EXP,1,rtype,MPI_MIN,MPI_COMM_WCMP,ierr) - CFLXY = DTG/DTMAX_GLOBAL_EXP - REST = ABS(MOD(CFLXY,1.d0)) - IF (REST .LT. THR) THEN - ITER_MAX = ABS(NINT(CFLXY)) - ELSE IF (REST .GT. THR .AND. REST .LT. 0.5d0) THEN - ITER_MAX = ABS(NINT(CFLXY)) + 1 - ELSE - ITER_MAX = ABS(NINT(CFLXY)) - END IF - - DT4AI = DTG/ITER_MAX - DO IT = 1, ITER_MAX - DO IP = 1, NPA - ST3 = ZERO - DO I = 1, PDLIB_CCON(IP) - IE = PDLIB_IE_CELL2(IP,I) - U33 = VA(:,INE(:,IE)) - UTILDE33 = N(:,IE)*(FLALLGL(:,1,IE)*U33(:,1)+FLALLGL(:,2,IE)*U33(:,2)+FLALLGL(:,3,IE)*U33(:,3)) - IPOS = PDLIB_POS_CELL2(I,IP) - ST3 = ST3 + KELEMGL(:,IPOS,IE)*(U33(:,IPOS)-UTILDE33) - END DO - VA(:,IP) = MAX(ZERO,VA(:,IP)-DT4AI/PDLIB_SI(IP)*ST3) - END DO !IP - CALL PDLIB_exchange2DREAL_ZERO(VA) - END DO !IT - - DO IP = 1, npa - IP_glob=iplg(IP) + DO JSEA=1,NSEAL + IP = JSEA + IP_glob=iplg(IP) + ISEA=MAPFS(1,IP_glob) + DO ISP=1,NSPEC + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + CCOS = FACX * ECOS(ITH) + CSIN = FACY * ESIN(ITH) + VA(ISP,IP) = DBLE(VA(ISP,JSEA) / CG(IK,ISEA) * CLATS(ISEA)) +#ifdef W3_MGP + VLCFLX(ISP,IP) = VLCFLX(ISP,IP) - CCURX*VGX/CLATS(ISEA) + VLCFLY(ISP,IP) = VLCFLY(ISP,IP) - CCURY*VGY +#endif + END DO + END DO #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'IOBPD loop, Before, sum(VA)=', sum(VA(:,IP)) + DO IP=1,NP + WRITE(740+IAPROC,*) 'IP=', IP + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,IP)), maxval(VA(:,IP)), sum(VA(:,IP)) + END DO #endif - DO ISP=1,NSPEC - ITH = 1 + MOD(ISP-1,NTH) - VA(ISP,IP)=MAX(ZERO, VA(ISP,IP))*IOBDP(IP_glob)*DBLE(IOBPD(ITH,IP_glob)) + +#ifdef W3_DEBUGSOLVERCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(np) just defined", 0) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) just defined", 1) +#endif +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'JACOBI_SOLVER, step 3' + WRITE(740+IAPROC,*) 'FLCUR=', FLCUR + FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'EXPLICIT BLOCK SOLVER, step 4' + WRITE(740+IAPROC,*) 'min,max(0)=', 0 + WRITE(740+IAPROC,*) 'min,max(0)=', 0 + FLUSH(740+IAPROC) +#endif + + DO IE = 1, NE + I1 = INE(1,IE) + I2 = INE(2,IE) + I3 = INE(3,IE) + !LAMBDA(:,1) = 1./6. *(C(:,I1,1)+C(:,I2,1)+C(:,I3,1)) + !LAMBDA(:,2) = 1./6. *(C(:,I1,2)+C(:,I2,2)+C(:,I3,2)) + KELEMGL(:,1,IE) = LAMBDA(:,1) * PDLIB_IEN(1,IE) + LAMBDA(:,2) * PDLIB_IEN(2,IE) + KELEMGL(:,2,IE) = LAMBDA(:,1) * PDLIB_IEN(3,IE) + LAMBDA(:,2) * PDLIB_IEN(4,IE) + KELEMGL(:,3,IE) = LAMBDA(:,1) * PDLIB_IEN(5,IE) + LAMBDA(:,2) * PDLIB_IEN(6,IE) + KTMP(:,1) = KELEMGL(:,1,IE) + KTMP(:,2) = KELEMGL(:,2,IE) + KTMP(:,3) = KELEMGL(:,3,IE) + TMP(:) = SUM(MIN(ZERO,KTMP(:,:)),DIM=2) + N(:,IE) = -1.d0/MIN(-THR,TMP(:)) + KELEMGL(:,1,IE) = MAX(ZERO,KTMP(:,1)) + KELEMGL(:,2,IE) = MAX(ZERO,KTMP(:,2)) + KELEMGL(:,3,IE) = MAX(ZERO,KTMP(:,3)) + ! FL11 = C(:,I2,1) * PDLIB_IEN(1,IE) + C(:,I2,2) * PDLIB_IEN(2,IE) + ! FL12 = C(:,I3,1) * PDLIB_IEN(1,IE) + C(:,I3,2) * PDLIB_IEN(2,IE) + ! FL21 = C(:,I3,1) * PDLIB_IEN(3,IE) + C(:,I3,2) * PDLIB_IEN(4,IE) + ! FL22 = C(:,I1,1) * PDLIB_IEN(3,IE) + C(:,I1,2) * PDLIB_IEN(4,IE) + ! FL31 = C(:,I1,1) * PDLIB_IEN(5,IE) + C(:,I1,2) * PDLIB_IEN(6,IE) + ! FL32 = C(:,I2,1) * PDLIB_IEN(5,IE) + C(:,I2,2) * PDLIB_IEN(6,IE) + FL111 = 2*FL11+FL12 + FL112 = 2*FL12+FL11 + FL211 = 2*FL21+FL22 + FL212 = 2*FL22+FL21 + FL311 = 2*FL31+FL32 + FL312 = 2*FL32+FL31 + FLALLGL(:,1,IE) = (FL311 + FL212) * 1./6. + KELEMGL(:,1,IE) + FLALLGL(:,2,IE) = (FL111 + FL312) * 1./6. + KELEMGL(:,2,IE) + FLALLGL(:,3,IE) = (FL211 + FL112) * 1./6. + KELEMGL(:,3,IE) + END DO + + KKSUM = 0.d0 + DO IE = 1, NE + NI = INE(:,IE) + KKSUM(:,NI) = KKSUM(:,NI) + KELEMGL(:,:,IE) + END DO + DTMAX_GLOBAL_EXP = 1.d0/THR + DO IP = 1, NP + DTMAX_EXP = PDLIB_SI(IP)/MAX(THR,MAXVAL(KKSUM(:,IP))) + DTMAX_GLOBAL_EXP = MIN ( DTMAX_GLOBAL_EXP, DTMAX_EXP) + CFLXYMAX(IP) = DBLE(DTG)/DTMAX_EXP + END DO + rest = CFLXYMAX(1) + DO IP = 2, NP + if (rest .lt. CFLXYMAX(IP)) then + rest = CFLXYMAX(IP) + iter_max = ip + endif + END DO + + DTMAX_EXP=DTMAX_GLOBAL_EXP + call mpi_allreduce(DTMAX_EXP,DTMAX_GLOBAL_EXP,1,rtype,MPI_MIN,MPI_COMM_WCMP,ierr) + CFLXY = DTG/DTMAX_GLOBAL_EXP + REST = ABS(MOD(CFLXY,1.d0)) + IF (REST .LT. THR) THEN + ITER_MAX = ABS(NINT(CFLXY)) + ELSE IF (REST .GT. THR .AND. REST .LT. 0.5d0) THEN + ITER_MAX = ABS(NINT(CFLXY)) + 1 + ELSE + ITER_MAX = ABS(NINT(CFLXY)) + END IF + + DT4AI = DTG/ITER_MAX + DO IT = 1, ITER_MAX + DO IP = 1, NPA + ST3 = ZERO + DO I = 1, PDLIB_CCON(IP) + IE = PDLIB_IE_CELL2(IP,I) + U33 = VA(:,INE(:,IE)) + UTILDE33 = N(:,IE)*(FLALLGL(:,1,IE)*U33(:,1)+FLALLGL(:,2,IE)*U33(:,2)+FLALLGL(:,3,IE)*U33(:,3)) + IPOS = PDLIB_POS_CELL2(I,IP) + ST3 = ST3 + KELEMGL(:,IPOS,IE)*(U33(:,IPOS)-UTILDE33) END DO + VA(:,IP) = MAX(ZERO,VA(:,IP)-DT4AI/PDLIB_SI(IP)*ST3) + END DO !IP + CALL PDLIB_exchange2DREAL_ZERO(VA) + END DO !IT + + DO IP = 1, npa + IP_glob=iplg(IP) #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'IOBPD loop, After, sum(VA)=', sum(VA(:,IP)) + WRITE(740+IAPROC,*) 'IOBPD loop, Before, sum(VA)=', sum(VA(:,IP)) #endif + DO ISP=1,NSPEC + ITH = 1 + MOD(ISP-1,NTH) + VA(ISP,IP)=MAX(ZERO, VA(ISP,IP))*IOBDP(IP_glob)*DBLE(IOBPD(ITH,IP_glob)) END DO - +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'IOBPD loop, After, sum(VA)=', sum(VA(:,IP)) +#endif + END DO + #ifdef W3_DEBUGSOLVERCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) after loop", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA(npa) after loop", 1) #endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'FLBPI=', FLBPI - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'FLBPI=', FLBPI + FLUSH(740+IAPROC) #endif - DO JSEA=1, NSEAL - IP=JSEA - IP_glob=iplg(IP) - ISEA=MAPFS(1,IP_glob) -! + DO JSEA=1, NSEAL + IP=JSEA + IP_glob=iplg(IP) + ISEA=MAPFS(1,IP_glob) + ! #ifdef W3_DEBUGSRC - IntDiff=0 - SumVS=0 - SumVD=0 - SumVAin=0 - SumVAout=0 - SumVAw3srce=0 - SumACout=0 -#endif -! - DO ISP=1,NSPEC - IK = 1 + (ISP-1)/NTH - eVA = MAX ( 0. ,CG(IK,ISEA)/CLATS(ISEA)*REAL(VA(ISP,IP)) ) + IntDiff=0 + SumVS=0 + SumVD=0 + SumVAin=0 + SumVAout=0 + SumVAw3srce=0 + SumACout=0 +#endif + ! + DO ISP=1,NSPEC + IK = 1 + (ISP-1)/NTH + eVA = MAX ( 0. ,CG(IK,ISEA)/CLATS(ISEA)*REAL(VA(ISP,IP)) ) #ifdef W3_DEBUGSRC - SumACout=SumACout + REAL(VA(ISP,IP)) - VS_w3srce = VSTOT(ISP,JSEA) * DTG / MAX(1., (1. - DTG*VDTOT(ISP,JSEA))) - eVA_w3srce = MAX(0., VA(ISP,JSEA) + VS_w3srce) - IntDiff = IntDiff + abs(eVA - eVA_w3srce) - ACsolve=B_JAC(ISP,IP)/ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - eB=VA(ISP,JSEA) + DTG*(VSTOT(ISP,JSEA) - VDTOT(ISP,JSEA)*VA(ISP,JSEA)) - eVAsolve=MAX(0., CG(IK,ISEA)/CLATS(ISEA)*ACsolve) - VAsolve(ISP)=eVAsolve - SumVS = SumVS + abs(VSTOT(ISP,JSEA)) - SumVD = SumVD + abs(VDTOT(ISP,JSEA)) - SumVAin = SumVAin + abs(VA(ISP,JSEA)) - SumVAout = SumVAout + abs(eVA) - SumVAw3srce = SumVAw3srce + abs(eVA_w3srce) -#endif - VA(ISP,JSEA) = eVA - END DO + SumACout=SumACout + REAL(VA(ISP,IP)) + VS_w3srce = VSTOT(ISP,JSEA) * DTG / MAX(1., (1. - DTG*VDTOT(ISP,JSEA))) + eVA_w3srce = MAX(0., VA(ISP,JSEA) + VS_w3srce) + IntDiff = IntDiff + abs(eVA - eVA_w3srce) + ACsolve=B_JAC(ISP,IP)/ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) + eB=VA(ISP,JSEA) + DTG*(VSTOT(ISP,JSEA) - VDTOT(ISP,JSEA)*VA(ISP,JSEA)) + eVAsolve=MAX(0., CG(IK,ISEA)/CLATS(ISEA)*ACsolve) + VAsolve(ISP)=eVAsolve + SumVS = SumVS + abs(VSTOT(ISP,JSEA)) + SumVD = SumVD + abs(VDTOT(ISP,JSEA)) + SumVAin = SumVAin + abs(VA(ISP,JSEA)) + SumVAout = SumVAout + abs(eVA) + SumVAw3srce = SumVAw3srce + abs(eVA_w3srce) +#endif + VA(ISP,JSEA) = eVA + END DO #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' IntDiff=', IntDiff, ' DTG=', DTG - IF (ISEA .eq. TESTNODE) THEN - DO ISP=1,NSPEC - WRITE(740+IAPROC,*) 'ISP=', ISP, 'VA/VAsolve=', VA(ISP,JSEA), VAsolve(ISP) - END DO - END IF - WRITE(740+IAPROC,*) 'SHAVE=', SHAVETOT(JSEA) - WRITE(740+IAPROC,*) 'Sum(VS/VD)=', SumVS, SumVD - WRITE(740+IAPROC,*) 'min/max/sum(VS)=', minval(VSTOT(:,JSEA)), maxval(VSTOT(:,JSEA)), sum(VSTOT(:,JSEA)) - WRITE(740+IAPROC,*) 'min/max/sum(VD)=', minval(VDTOT(:,JSEA)), maxval(VDTOT(:,JSEA)), sum(VDTOT(:,JSEA)) - WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) - WRITE(740+IAPROC,*) 'min/max/sum(VAsolve)=', minval(VAsolve), maxval(VAsolve), sum(VAsolve) - WRITE(740+IAPROC,*) 'SumVA(in/out/w3srce)=', SumVAin, SumVAout, SumVAw3srce - WRITE(740+IAPROC,*) 'SumACout=', SumACout -#endif - END DO + WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' IntDiff=', IntDiff, ' DTG=', DTG + IF (ISEA .eq. TESTNODE) THEN + DO ISP=1,NSPEC + WRITE(740+IAPROC,*) 'ISP=', ISP, 'VA/VAsolve=', VA(ISP,JSEA), VAsolve(ISP) + END DO + END IF + WRITE(740+IAPROC,*) 'SHAVE=', SHAVETOT(JSEA) + WRITE(740+IAPROC,*) 'Sum(VS/VD)=', SumVS, SumVD + WRITE(740+IAPROC,*) 'min/max/sum(VS)=', minval(VSTOT(:,JSEA)), maxval(VSTOT(:,JSEA)), sum(VSTOT(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VD)=', minval(VDTOT(:,JSEA)), maxval(VDTOT(:,JSEA)), sum(VDTOT(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VAsolve)=', minval(VAsolve), maxval(VAsolve), sum(VAsolve) + WRITE(740+IAPROC,*) 'SumVA(in/out/w3srce)=', SumVAin, SumVAout, SumVAw3srce + WRITE(740+IAPROC,*) 'SumACout=', SumACout +#endif + END DO #ifdef W3_DEBUGSRC - DO IP=1,NP - WRITE(740+IAPROC,*) 'IP=', IP - WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,IP)), maxval(VA(:,IP)), sum(VA(:,IP)) - END DO - WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) + DO IP=1,NP + WRITE(740+IAPROC,*) 'IP=', IP + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,IP)), maxval(VA(:,IP)), sum(VA(:,IP)) + END DO + WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) #endif #ifdef W3_DEBUGSOLVER - WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, end' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, end' + FLUSH(740+IAPROC) #endif - END SUBROUTINE PDLIB_EXPLICIT_BLOCK -!/ ------------------------------------------------------------------- / - SUBROUTINE BLOCK_SOLVER_INIT(IMOD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Initialization of the block solver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END SUBROUTINE PDLIB_EXPLICIT_BLOCK + !/ ------------------------------------------------------------------- / + SUBROUTINE BLOCK_SOLVER_INIT(IMOD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Initialization of the block solver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif -! - USE CONSTANTS, only : LPDLIB - USE W3GDATMD, only: MAPSF, NSEAL, DMIN, IOBDP, MAPSTA, IOBP, MAPFS, NX - USE W3ADATMD, only: DW - USE W3PARALL, only: INIT_GET_ISEA - USE YOWNODEPOOL, only: iplg, np - USE yowfunction, only: pdlib_abort - use YOWNODEPOOL, only: npa - USE W3GDATMD, only: B_JGS_USE_JACOBI - USE W3PARALL, only : ListISPprevDir, ListISPnextDir - USE W3PARALL, only : ListISPprevFreq, ListISPnextFreq - USE W3GDATMD, only: NSPEC, NTH, NK - USE W3GDATMD, only: FSTOTALIMP - USE W3ODATMD, only: IAPROC -!/ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IMOD -! -!/ ------------------------------------------------------------------- / -!/ - INTEGER ISP, ITH, IK, ISPprevFreq, ISPnextFreq - INTEGER NewISP, JTH, istat - - POS_TRICK(1,1) = 2 - POS_TRICK(1,2) = 3 - POS_TRICK(2,1) = 3 - POS_TRICK(2,2) = 1 - POS_TRICK(3,1) = 1 - POS_TRICK(3,2) = 2 + USE W3SERVMD, only: STRACE +#endif + ! + USE CONSTANTS, only : LPDLIB + USE W3GDATMD, only: MAPSF, NSEAL, DMIN, IOBDP, MAPSTA, IOBP, MAPFS, NX + USE W3ADATMD, only: DW + USE W3PARALL, only: INIT_GET_ISEA + USE YOWNODEPOOL, only: iplg, np + USE yowfunction, only: pdlib_abort + use YOWNODEPOOL, only: npa + USE W3GDATMD, only: B_JGS_USE_JACOBI + USE W3PARALL, only : ListISPprevDir, ListISPnextDir + USE W3PARALL, only : ListISPprevFreq, ListISPnextFreq + USE W3GDATMD, only: NSPEC, NTH, NK + USE W3GDATMD, only: FSTOTALIMP + USE W3ODATMD, only: IAPROC + !/ + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IMOD + ! + !/ ------------------------------------------------------------------- / + !/ + INTEGER ISP, ITH, IK, ISPprevFreq, ISPnextFreq + INTEGER NewISP, JTH, istat + + POS_TRICK(1,1) = 2 + POS_TRICK(1,2) = 3 + POS_TRICK(2,1) = 3 + POS_TRICK(2,2) = 1 + POS_TRICK(3,1) = 1 + POS_TRICK(3,2) = 2 #ifdef W3_DEBUGINIT WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 1' FLUSH(740+IAPROC) #endif - ALLOCATE(ListISPnextDir(NSPEC), ListISPprevDir(NSPEC), ListISPnextFreq(NSPEC), ListISPprevFreq(NSPEC),stat=istat) - IF (istat /= 0) CALL PDLIB_ABORT(8) + ALLOCATE(ListISPnextDir(NSPEC), ListISPprevDir(NSPEC), ListISPnextFreq(NSPEC), ListISPprevFreq(NSPEC),stat=istat) + IF (istat /= 0) CALL PDLIB_ABORT(8) #ifdef W3_DEBUGINIT WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 2' FLUSH(740+IAPROC) #endif - DO ISP=1,NSPEC - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - IF (IK .eq. 1) THEN - ISPprevFreq=-1 - ELSE - ISPprevFreq=iTH + (IK-1 -1)*NTH - END IF - ListISPprevFreq(ISP)=ISPprevFreq - IF (IK .eq. NK) THEN - ISPnextFreq=-1 - ELSE - ISPnextFreq=iTH + (IK+1 -1)*NTH - END IF - ListISPnextFreq(ISP)=ISPnextFreq - ! - IF (ITH .eq. 1) THEN - JTH=NTH - ELSE - JTH=ITH-1 - ENDIF - NewISP=JTH + (IK-1)*NTH - ListISPprevDir(ISP)=NewISP - IF (ITH .eq. NTH) THEN - JTH=1 - ELSE - JTH=ITH+1 - ENDIF - NewISP=JTH + (IK-1)*NTH - ListISPnextDir(ISP)=NewISP - END DO + DO ISP=1,NSPEC + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + IF (IK .eq. 1) THEN + ISPprevFreq=-1 + ELSE + ISPprevFreq=iTH + (IK-1 -1)*NTH + END IF + ListISPprevFreq(ISP)=ISPprevFreq + IF (IK .eq. NK) THEN + ISPnextFreq=-1 + ELSE + ISPnextFreq=iTH + (IK+1 -1)*NTH + END IF + ListISPnextFreq(ISP)=ISPnextFreq + ! + IF (ITH .eq. 1) THEN + JTH=NTH + ELSE + JTH=ITH-1 + ENDIF + NewISP=JTH + (IK-1)*NTH + ListISPprevDir(ISP)=NewISP + IF (ITH .eq. NTH) THEN + JTH=1 + ELSE + JTH=ITH+1 + ENDIF + NewISP=JTH + (IK-1)*NTH + ListISPnextDir(ISP)=NewISP + END DO #ifdef W3_DEBUGINIT WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 3' FLUSH(740+IAPROC) #endif - IF (FSTOTALIMP .and. B_JGS_USE_JACOBI) THEN + IF (FSTOTALIMP .and. B_JGS_USE_JACOBI) THEN #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 4' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 4' + FLUSH(740+IAPROC) #endif - CALL JACOBI_INIT(IMOD) + CALL JACOBI_INIT(IMOD) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 5' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 5' + FLUSH(740+IAPROC) #endif - END IF + END IF #ifdef W3_DEBUGINIT WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 6' FLUSH(740+IAPROC) #endif - END SUBROUTINE BLOCK_SOLVER_INIT -!/ ------------------------------------------------------------------ / - SUBROUTINE SET_IOBDP_PDLIB -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Set depth pointer -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END SUBROUTINE BLOCK_SOLVER_INIT + !/ ------------------------------------------------------------------ / + SUBROUTINE SET_IOBDP_PDLIB + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Set depth pointer + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif - USE CONSTANTS, only : LPDLIB - USE W3GDATMD, only: MAPSF, NSEAL, DMIN, MAPSTA, NX - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3ADATMD, only: DW - USE W3PARALL, only: INIT_GET_ISEA - USE YOWNODEPOOL, only: iplg, np, npa -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3SERVMD, only: STRACE +#endif + USE CONSTANTS, only : LPDLIB + USE W3GDATMD, only: MAPSF, NSEAL, DMIN, MAPSTA, NX + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3ADATMD, only: DW + USE W3PARALL, only: INIT_GET_ISEA + USE YOWNODEPOOL, only: iplg, np, npa + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -! - INTEGER :: JSEA, ISEA, IX, IP, IP_glob - REAL*8, PARAMETER :: DTHR = 10E-6 + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + INTEGER :: JSEA, ISEA, IX, IP, IP_glob + REAL*8, PARAMETER :: DTHR = 10E-6 #ifdef W3_S - CALL STRACE (IENT, 'SETDEPTH_PDLIB') + CALL STRACE (IENT, 'SETDEPTH_PDLIB') #endif - DO JSEA=1,NPA - IP = JSEA - IP_glob = iplg(IP) - IF (DW(IP_glob) .LT. DMIN + DTHR) THEN - IOBDP_LOC(IP) = 0 - ELSE - IOBDP_LOC(IP) = 1 - ENDIF - !WRITE(*,*) ip, ip_glob, IOBDP_LOC(IP), DW(IP_glob), DMIN - END DO -!/ -!/ End of SETDEPTH_PDLIB --------------------------------------------- / -!/ - END SUBROUTINE SET_IOBDP_PDLIB - - - SUBROUTINE SET_IOBPA_PDLIB -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Set depth pointer -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + DO JSEA=1,NPA + IP = JSEA + IP_glob = iplg(IP) + IF (DW(IP_glob) .LT. DMIN + DTHR) THEN + IOBDP_LOC(IP) = 0 + ELSE + IOBDP_LOC(IP) = 1 + ENDIF + !WRITE(*,*) ip, ip_glob, IOBDP_LOC(IP), DW(IP_glob), DMIN + END DO + !/ + !/ End of SETDEPTH_PDLIB --------------------------------------------- / + !/ + END SUBROUTINE SET_IOBDP_PDLIB + + + SUBROUTINE SET_IOBPA_PDLIB + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Set depth pointer + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif - USE CONSTANTS, only : LPDLIB - USE W3GDATMD, only: MAPSF, NSEAL, DMIN, MAPSTA, NX - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3ADATMD, only: DW - USE W3PARALL, only: INIT_GET_ISEA - USE YOWNODEPOOL, only: iplg, np -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3SERVMD, only: STRACE +#endif + USE CONSTANTS, only : LPDLIB + USE W3GDATMD, only: MAPSF, NSEAL, DMIN, MAPSTA, NX + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3ADATMD, only: DW + USE W3PARALL, only: INIT_GET_ISEA + USE YOWNODEPOOL, only: iplg, np + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -! - INTEGER :: JSEA, ISEA, IX, IP, IP_glob - REAL*8, PARAMETER :: DTHR = 10E-6 + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + INTEGER :: JSEA, ISEA, IX, IP, IP_glob + REAL*8, PARAMETER :: DTHR = 10E-6 #ifdef W3_S - CALL STRACE (IENT, 'SETDEPTH_PDLIB') + CALL STRACE (IENT, 'SETDEPTH_PDLIB') #endif - DO JSEA=1,NSEAL - IP_glob = iplg(JSEA) - IF (MAPSTA(1,IP_glob).EQ.2) THEN - IOBPA_LOC(JSEA) = 1 - ELSE - IOBPA_LOC(JSEA) = 0 - ENDIF - END DO -!/ -!/ End of SETDEPTH_PDLIB --------------------------------------------- / -!/ - END SUBROUTINE SET_IOBPA_PDLIB - - - SUBROUTINE SET_UG_IOBP_PDLIB_INIT() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Fabrice Ardhuin | -!/ | Aron Roland | -!/ | FORTRAN 90 | -!/ | Last update : 17-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 23-Aug-2011 : Origination. ( version 4.04 ) -!/ 17-Apr-2016 : Uses optimized boundary detection ( version 5.10 ) -!/ -! 1. Purpose : -! -! Redefines the values of the boundary points and angle pointers -! based on the MAPSTA array -! -! 2. Method : -! -! Adapted boundary detection from A. Roland and M. Dutour (WWM code) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! - -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_GRID Prog. WW3_GRID Grid preprocessor -! W3ULEV Subr. W3UPDTMD Water level update -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! -! 10. Source code : -!/ ------------------------------------------------------------------- / -!/ -! - USE CONSTANTS -! -! - USE W3GDATMD, only: NX, NY, NSEA, MAPFS, & - NK, NTH, DTH, XFR, MAPSTA, COUNTRI, & - ECOS, ESIN, IEN, NTRI, TRIGP, & - IOBP,IOBPD, IOBPA, & + DO JSEA=1,NSEAL + IP_glob = iplg(JSEA) + IF (MAPSTA(1,IP_glob).EQ.2) THEN + IOBPA_LOC(JSEA) = 1 + ELSE + IOBPA_LOC(JSEA) = 0 + ENDIF + END DO + !/ + !/ End of SETDEPTH_PDLIB --------------------------------------------- / + !/ + END SUBROUTINE SET_IOBPA_PDLIB + + + SUBROUTINE SET_UG_IOBP_PDLIB_INIT() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Fabrice Ardhuin | + !/ | Aron Roland | + !/ | FORTRAN 90 | + !/ | Last update : 17-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 23-Aug-2011 : Origination. ( version 4.04 ) + !/ 17-Apr-2016 : Uses optimized boundary detection ( version 5.10 ) + !/ + ! 1. Purpose : + ! + ! Redefines the values of the boundary points and angle pointers + ! based on the MAPSTA array + ! + ! 2. Method : + ! + ! Adapted boundary detection from A. Roland and M. Dutour (WWM code) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_GRID Prog. WW3_GRID Grid preprocessor + ! W3ULEV Subr. W3UPDTMD Water level update + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + !/ + ! + USE CONSTANTS + ! + ! + USE W3GDATMD, only: NX, NY, NSEA, MAPFS, & + NK, NTH, DTH, XFR, MAPSTA, COUNTRI, & + ECOS, ESIN, IEN, NTRI, TRIGP, & + IOBP,IOBPD, IOBPA, & #ifdef W3_REF1 - REFPARS, REFLC, REFLD, & -#endif - ANGLE0, ANGLE, NSEAL - - USE W3ODATMD, only: TBPI0, TBPIN, FLBPI - USE W3ADATMD, only: CG, CX, CY, ATRNX, ATRNY, ITIME, CFLXYMAX - USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC - USE W3IDATMD, only: FLCUR - USE W3ODATMD, only : IAPROC - USE YOWNODEPOOL, only: PDLIB_SI, PDLIB_IEN, PDLIB_TRIA, ipgl, iplg, npa, np - use yowElementpool, only: NE, INE - use yowExchangeModule, only : PDLIB_exchange1DREAL -#ifdef W3_S - USE W3SERVMD, only: STRACE + REFPARS, REFLC, REFLD, & #endif - - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IX, I, J, IP, IE, NDIRSUM - REAL (KIND = 8) :: COSSUM, SINSUM - REAL (KIND = 8) :: DIRMIN, DIRMAX, SHIFT, TEMPO, DIRCOAST - REAL (KIND = 8) :: X1, X2, Y1, Y2, DXP1, DXP2, DXP3 - REAL (KIND = 8) :: DYP1, DYP2, DYP3, eDet1, eDet2, EVX, EVY - REAL(KIND=8), PARAMETER :: THR = TINY(1.) - INTEGER :: I1, I2, I3 - INTEGER :: ITMP(NX), NEXTVERT(NX), PREVVERT(NX) - INTEGER :: MAX_IOBPD, MIN_IOBPD - REAL :: rtmp(NPA) - CHARACTER(60) :: FNAME + ANGLE0, ANGLE, NSEAL + + USE W3ODATMD, only: TBPI0, TBPIN, FLBPI + USE W3ADATMD, only: CG, CX, CY, ATRNX, ATRNY, ITIME, CFLXYMAX + USE W3GDATMD, only: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE W3IDATMD, only: FLCUR + USE W3ODATMD, only : IAPROC + USE YOWNODEPOOL, only: PDLIB_SI, PDLIB_IEN, PDLIB_TRIA, ipgl, iplg, npa, np + use yowElementpool, only: NE, INE + use yowExchangeModule, only : PDLIB_exchange1DREAL #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ ------------------------------------------------------------------- / -! -! - DO IE = 1, NE - I1 = INE(1,IE) - I2 = INE(2,IE) - I3 = INE(3,IE) - DXP1 = PDLIB_IEN(6,IE) - DYP1 = - PDLIB_IEN(5,IE) - DXP2 = PDLIB_IEN(2,IE) - DYP2 = - PDLIB_IEN(1,IE) - DXP3 = PDLIB_IEN(4,IE) - DYP3 = - PDLIB_IEN(3,IE) - DO ITH = 1, NTH - EVX = ECOS(ITH) - EVY = ESIN(ITH) - DO I = 1, 3 - IF (I .eq. 1) THEN - x1 = DXP1 - y1 = DYP1 - x2 = - DXP3 - y2 = - DYP3 - IP = I1 - ELSE IF (I.eq.2) THEN - x1 = DXP2 - y1 = DYP2 - x2 = - DXP1 - y2 = - DYP1 - IP = I2 - ELSE IF (I.eq.3) THEN - x1 = DXP3 - y1 = DYP3 - x2 = - DXP2 - y2 = - DYP2 - IP = I3 - END IF - IF (IOBP_LOC(IP) .eq. 0) THEN ! physical boundary - eDet1 = THR-x1*EVY+y1*EVX - eDet2 = THR+x2*EVY-y2*EVX - IF ((eDet1.gt.0.).and.(eDet2.gt.0.)) THEN -! this is the case of waves going towards the boundary ... - IOBPD_LOC(ITH,IP) = 1 - ENDIF - ELSE ! water ... + USE W3SERVMD, only: STRACE +#endif + + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IX, I, J, IP, IE, NDIRSUM + REAL (KIND = 8) :: COSSUM, SINSUM + REAL (KIND = 8) :: DIRMIN, DIRMAX, SHIFT, TEMPO, DIRCOAST + REAL (KIND = 8) :: X1, X2, Y1, Y2, DXP1, DXP2, DXP3 + REAL (KIND = 8) :: DYP1, DYP2, DYP3, eDet1, eDet2, EVX, EVY + REAL(KIND=8), PARAMETER :: THR = TINY(1.) + INTEGER :: I1, I2, I3 + INTEGER :: ITMP(NX), NEXTVERT(NX), PREVVERT(NX) + INTEGER :: MAX_IOBPD, MIN_IOBPD + REAL :: rtmp(NPA) + CHARACTER(60) :: FNAME +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ ------------------------------------------------------------------- / + ! + ! + DO IE = 1, NE + I1 = INE(1,IE) + I2 = INE(2,IE) + I3 = INE(3,IE) + DXP1 = PDLIB_IEN(6,IE) + DYP1 = - PDLIB_IEN(5,IE) + DXP2 = PDLIB_IEN(2,IE) + DYP2 = - PDLIB_IEN(1,IE) + DXP3 = PDLIB_IEN(4,IE) + DYP3 = - PDLIB_IEN(3,IE) + DO ITH = 1, NTH + EVX = ECOS(ITH) + EVY = ESIN(ITH) + DO I = 1, 3 + IF (I .eq. 1) THEN + x1 = DXP1 + y1 = DYP1 + x2 = - DXP3 + y2 = - DYP3 + IP = I1 + ELSE IF (I.eq.2) THEN + x1 = DXP2 + y1 = DYP2 + x2 = - DXP1 + y2 = - DYP1 + IP = I2 + ELSE IF (I.eq.3) THEN + x1 = DXP3 + y1 = DYP3 + x2 = - DXP2 + y2 = - DYP2 + IP = I3 + END IF + IF (IOBP_LOC(IP) .eq. 0) THEN ! physical boundary + eDet1 = THR-x1*EVY+y1*EVX + eDet2 = THR+x2*EVY-y2*EVX + IF ((eDet1.gt.0.).and.(eDet2.gt.0.)) THEN + ! this is the case of waves going towards the boundary ... IOBPD_LOC(ITH,IP) = 1 - END IF - END DO + ENDIF + ELSE ! water ... + IOBPD_LOC(ITH,IP) = 1 + END IF END DO END DO + END DO + + DO ITH = 1, NTH + rtmp = REAL(IOBPD_LOC(ITH,1:NPA)) + CALL PDLIB_exchange1Dreal(rtmp) + IOBPD_LOC(ITH,1:NPA) = INT(rtmp) + ENDDO + MAX_IOBPD = MAXVAL(IOBPD_LOC) + MIN_IOBPD = MINVAL(IOBPD_LOC) + + IF (MAX_IOBPD .gt. 1 .OR. MIN_IOBPD .lt. 0) THEN + WRITE(*,*) 'MAX_IOBPD - MIN_IOBPD', MAX_IOBPD, MIN_IOBPD + STOP 'MAX_IOBPD ERRROR' + ENDIF - DO ITH = 1, NTH - rtmp = REAL(IOBPD_LOC(ITH,1:NPA)) - CALL PDLIB_exchange1Dreal(rtmp) - IOBPD_LOC(ITH,1:NPA) = INT(rtmp) - ENDDO - MAX_IOBPD = MAXVAL(IOBPD_LOC) - MIN_IOBPD = MINVAL(IOBPD_LOC) - - IF (MAX_IOBPD .gt. 1 .OR. MIN_IOBPD .lt. 0) THEN - WRITE(*,*) 'MAX_IOBPD - MIN_IOBPD', MAX_IOBPD, MIN_IOBPD - STOP 'MAX_IOBPD ERRROR' - ENDIF - #ifdef W3_DEBUGSETUGIOBP - WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 5' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 5' + FLUSH(740+IAPROC) #endif - DO IP = 1, NPA - IF ( IOBPA_LOC(IP) .eq. 1 .OR. IOBP_LOC(IP) .eq. 3 .OR. IOBP_LOC(IP) .eq. 4) IOBPD_LOC(:,IP) = 1 - END DO -!2do: recode for mpi -! IF (LBCWA .OR. LBCSP) THEN -! IF (.NOT. ANY(IOBP .EQ. 2)) THEN -! CALL WWM_ABORT('YOU IMPOSED BOUNDARY CONDITIONS BUT IN THE BOUNDARY FILE ARE NO NODES WITH FLAG = 2') -! ENDIF -! ENDIF -!#ifdef MPI_PARALL_GRID -! CALL exchange_p2di(IOBWB) -! DO ID = 1, MDC -! iwild = IOBPD(ID,:) -! CALL exchange_p2di(iwild) -! IOBPD(ID,:) = iwild -! ENDDO -!#endif + DO IP = 1, NPA + IF ( IOBPA_LOC(IP) .eq. 1 .OR. IOBP_LOC(IP) .eq. 3 .OR. IOBP_LOC(IP) .eq. 4) IOBPD_LOC(:,IP) = 1 + END DO + !2do: recode for mpi + ! IF (LBCWA .OR. LBCSP) THEN + ! IF (.NOT. ANY(IOBP .EQ. 2)) THEN + ! CALL WWM_ABORT('YOU IMPOSED BOUNDARY CONDITIONS BUT IN THE BOUNDARY FILE ARE NO NODES WITH FLAG = 2') + ! ENDIF + ! ENDIF + !#ifdef MPI_PARALL_GRID + ! CALL exchange_p2di(IOBWB) + ! DO ID = 1, MDC + ! iwild = IOBPD(ID,:) + ! CALL exchange_p2di(iwild) + ! IOBPD(ID,:) = iwild + ! ENDDO + !#endif #ifdef W3_DEBUGSETUGIOBP - WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 7' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 7' + FLUSH(740+IAPROC) #endif -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Updates the reflection direction and sharp / flat shoreline angle + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Updates the reflection direction and sharp / flat shoreline angle #ifdef W3_REF1 - ! - ! Finds the shoreline direction from IOBPD - ! - REFLC(1,:)= 0. - REFLD(:,:)= 1 - DO IP=1,NX - IF (IOBP(IP).EQ.0.AND.MAPSTA(1,IP).EQ.1) THEN - COSSUM=0. - SINSUM=0. - NDIRSUM=0. - DO ITH=1,NTH - COSSUM=COSSUM+IOBPD(ITH,IP)*ECOS(ITH) - SINSUM=SINSUM+IOBPD(ITH,IP)*ESIN(ITH) - NDIRSUM=NDIRSUM+IOBPD(ITH,IP) - END DO - DIRCOAST=ATAN2(SINSUM, COSSUM) - REFLD(1,MAPFS(1,IP)) = 1+MOD(NTH+NINT(DIRCOAST/DTH),NTH) - REFLD(2,MAPFS(1,IP)) = 4-MAX(2,NINT(4.*REAL(NDIRSUM)/REAL(NTH))) - REFLC(1,MAPFS(1,IP))= REFPARS(1) - END IF - END DO + ! + ! Finds the shoreline direction from IOBPD + ! + REFLC(1,:)= 0. + REFLD(:,:)= 1 + DO IP=1,NX + IF (IOBP(IP).EQ.0.AND.MAPSTA(1,IP).EQ.1) THEN + COSSUM=0. + SINSUM=0. + NDIRSUM=0. + DO ITH=1,NTH + COSSUM=COSSUM+IOBPD(ITH,IP)*ECOS(ITH) + SINSUM=SINSUM+IOBPD(ITH,IP)*ESIN(ITH) + NDIRSUM=NDIRSUM+IOBPD(ITH,IP) + END DO + DIRCOAST=ATAN2(SINSUM, COSSUM) + REFLD(1,MAPFS(1,IP)) = 1+MOD(NTH+NINT(DIRCOAST/DTH),NTH) + REFLD(2,MAPFS(1,IP)) = 4-MAX(2,NINT(4.*REAL(NDIRSUM)/REAL(NTH))) + REFLC(1,MAPFS(1,IP))= REFPARS(1) + END IF + END DO #endif #ifdef W3_DEBUGSETUGIOBP - WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 8' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 8' + FLUSH(740+IAPROC) #endif - END SUBROUTINE SET_UG_IOBP_PDLIB_INIT -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / - SUBROUTINE BLOCK_SOLVER_FINALIZE -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Finalize Solver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END SUBROUTINE SET_UG_IOBP_PDLIB_INIT + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE BLOCK_SOLVER_FINALIZE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Finalize Solver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE -#endif - USE W3GDATMD, only: B_JGS_USE_JACOBI -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3SERVMD, only: STRACE +#endif + USE W3GDATMD, only: B_JGS_USE_JACOBI + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -! + !/ + !/ ------------------------------------------------------------------- / + !/ + ! #ifdef W3_S - CALL STRACE (IENT, 'BLOCK_SOLVER_FINALIZE') -#endif - IF (B_JGS_USE_JACOBI) THEN - CALL JACOBI_FINALIZE - END IF -!/ -!/ End of SETDEPTH_PDLIB --------------------------------------------- / -!/ - END SUBROUTINE BLOCK_SOLVER_FINALIZE -!/ ------------------------------------------------------------------- / - SUBROUTINE DEALLOCATE_PDLIB_GLOBAL(IMOD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init jacobi solver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + CALL STRACE (IENT, 'BLOCK_SOLVER_FINALIZE') +#endif + IF (B_JGS_USE_JACOBI) THEN + CALL JACOBI_FINALIZE + END IF + !/ + !/ End of SETDEPTH_PDLIB --------------------------------------------- / + !/ + END SUBROUTINE BLOCK_SOLVER_FINALIZE + !/ ------------------------------------------------------------------- / + SUBROUTINE DEALLOCATE_PDLIB_GLOBAL(IMOD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init jacobi solver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE + USE W3SERVMD, only: STRACE #endif - USE W3GDATMD, only: NSPEC, B_JGS_BLOCK_GAUSS_SEIDEL, GRIDS - use YOWNODEPOOL, only: PDLIB_NNZ, npa, np - USE yowfunction, only: pdlib_abort - USE W3GDATMD, only: NTH, NK, NSEAL - USE W3PARALL, only: IMEM + USE W3GDATMD, only: NSPEC, B_JGS_BLOCK_GAUSS_SEIDEL, GRIDS + use YOWNODEPOOL, only: PDLIB_NNZ, npa, np + USE yowfunction, only: pdlib_abort + USE W3GDATMD, only: NTH, NK, NSEAL + USE W3PARALL, only: IMEM #ifdef W3_DEBUGINIT USE W3ODATMD, only : IAPROC #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER, INTENT(IN) :: IMOD - - DEALLOCATE ( & -! GRIDS(IMOD)%TRIGP, & - GRIDS(IMOD)%SI, & - GRIDS(IMOD)%TRIA, & - GRIDS(IMOD)%CROSSDIFF, & - GRIDS(IMOD)%IEN, & - GRIDS(IMOD)%LEN, & - GRIDS(IMOD)%ANGLE, & - GRIDS(IMOD)%ANGLE0, & - GRIDS(IMOD)%CCON, & - GRIDS(IMOD)%COUNTCON, & - GRIDS(IMOD)%INDEX_CELL, & - GRIDS(IMOD)%IE_CELL, & - GRIDS(IMOD)%POS_CELL, & - GRIDS(IMOD)%IAA, & - GRIDS(IMOD)%JAA, & - GRIDS(IMOD)%POSI, & - GRIDS(IMOD)%I_DIAG, & - GRIDS(IMOD)%JA_IE, & - !GRIDS(IMOD)%IOBP, & - !GRIDS(IMOD)%IOBPD, & - GRIDS(IMOD)%IOBDP, & - GRIDS(IMOD)%IOBPA ) -!/ -!/ End of DEALLOCATE_PDLIB_GLOBAL ------------------------------------------------ / -!/ - END SUBROUTINE DEALLOCATE_PDLIB_GLOBAL - - SUBROUTINE JACOBI_INIT(IMOD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Init jacobi solver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER, INTENT(IN) :: IMOD + + DEALLOCATE ( & + ! GRIDS(IMOD)%TRIGP, & + GRIDS(IMOD)%SI, & + GRIDS(IMOD)%TRIA, & + GRIDS(IMOD)%CROSSDIFF, & + GRIDS(IMOD)%IEN, & + GRIDS(IMOD)%LEN, & + GRIDS(IMOD)%ANGLE, & + GRIDS(IMOD)%ANGLE0, & + GRIDS(IMOD)%CCON, & + GRIDS(IMOD)%COUNTCON, & + GRIDS(IMOD)%INDEX_CELL, & + GRIDS(IMOD)%IE_CELL, & + GRIDS(IMOD)%POS_CELL, & + GRIDS(IMOD)%IAA, & + GRIDS(IMOD)%JAA, & + GRIDS(IMOD)%POSI, & + GRIDS(IMOD)%I_DIAG, & + GRIDS(IMOD)%JA_IE, & + !GRIDS(IMOD)%IOBP, & + !GRIDS(IMOD)%IOBPD, & + GRIDS(IMOD)%IOBDP, & + GRIDS(IMOD)%IOBPA ) + !/ + !/ End of DEALLOCATE_PDLIB_GLOBAL ------------------------------------------------ / + !/ + END SUBROUTINE DEALLOCATE_PDLIB_GLOBAL + + SUBROUTINE JACOBI_INIT(IMOD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Init jacobi solver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, only: STRACE + USE W3SERVMD, only: STRACE #endif - USE W3GDATMD, only: NSPEC, B_JGS_BLOCK_GAUSS_SEIDEL, GRIDS - use YOWNODEPOOL, only: PDLIB_NNZ, npa, np - USE yowfunction, only: pdlib_abort - USE W3GDATMD, only: NTH, NK, NSEAL - USE W3PARALL, only: IMEM + USE W3GDATMD, only: NSPEC, B_JGS_BLOCK_GAUSS_SEIDEL, GRIDS + use YOWNODEPOOL, only: PDLIB_NNZ, npa, np + USE yowfunction, only: pdlib_abort + USE W3GDATMD, only: NTH, NK, NSEAL + USE W3PARALL, only: IMEM #ifdef W3_DEBUGINIT USE W3ODATMD, only : IAPROC #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER, INTENT(IN) :: IMOD - INTEGER istat - IF (IMEM == 1) THEN - ALLOCATE(ASPAR_JAC(NSPEC, PDLIB_NNZ), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(9) - ELSE IF (IMEM == 2) THEN - ALLOCATE(ASPAR_DIAG_ALL(NSPEC, npa), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(9) - ENDIF - ALLOCATE(B_JAC(NSPEC,NSEAL), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(10) - ALLOCATE(CAD_THE(NSPEC,NSEAL), stat=istat) + INTEGER istat + IF (IMEM == 1) THEN + ALLOCATE(ASPAR_JAC(NSPEC, PDLIB_NNZ), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(9) + ELSE IF (IMEM == 2) THEN + ALLOCATE(ASPAR_DIAG_ALL(NSPEC, npa), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(9) + ENDIF + ALLOCATE(B_JAC(NSPEC,NSEAL), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(10) + ALLOCATE(CAD_THE(NSPEC,NSEAL), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(11) + IF (FreqShiftMethod .eq. 1) THEN + ALLOCATE(CAS_SIG(NSPEC,NSEAL), stat=istat) if(istat /= 0) CALL PDLIB_ABORT(11) - IF (FreqShiftMethod .eq. 1) THEN - ALLOCATE(CAS_SIG(NSPEC,NSEAL), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(11) - ELSE IF (FreqShiftMethod .eq. 2) THEN - ALLOCATE(CWNB_SIG_M2(1-NTH:NSPEC,NSEAL), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(11) - END IF - IF (.NOT. B_JGS_BLOCK_GAUSS_SEIDEL) THEN - ALLOCATE(U_JAC(NSPEC,npa), stat=istat) - if(istat /= 0) CALL PDLIB_ABORT(12) - END IF -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE JACOBI_INIT -!/ ------------------------------------------------------------------- / - SUBROUTINE JACOBI_FINALIZE -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Finalize jacobi solver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, only: B_JGS_BLOCK_GAUSS_SEIDEL - USE W3PARALL, only: IMEM -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETER -!/ + ELSE IF (FreqShiftMethod .eq. 2) THEN + ALLOCATE(CWNB_SIG_M2(1-NTH:NSPEC,NSEAL), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(11) + END IF + IF (.NOT. B_JGS_BLOCK_GAUSS_SEIDEL) THEN + ALLOCATE(U_JAC(NSPEC,npa), stat=istat) + if(istat /= 0) CALL PDLIB_ABORT(12) + END IF + !/ + !/ End of JACOBI_INIT ------------------------------------------------ / + !/ + END SUBROUTINE JACOBI_INIT + !/ ------------------------------------------------------------------- / + SUBROUTINE JACOBI_FINALIZE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Finalize jacobi solver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, only: B_JGS_BLOCK_GAUSS_SEIDEL + USE W3PARALL, only: IMEM + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETER + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'JACOBI_FINALIZE') -#endif - IF (IMEM == 1) THEN - DEALLOCATE(ASPAR_JAC) - ELSE IF (IMEM == 2) THEN - DEALLOCATE(ASPAR_DIAG_ALL) - ENDIF - DEALLOCATE(B_JAC) - DEALLOCATE(CAD_THE) - IF (FreqShiftMethod .eq. 1) THEN - DEALLOCATE(CAS_SIG) - ELSE IF (FreqShiftMethod .eq. 2) THEN - DEALLOCATE(CWNB_SIG_M2) - END IF - IF (.NOT. B_JGS_BLOCK_GAUSS_SEIDEL) THEN - DEALLOCATE(U_JAC) - END IF -!/ -!/ End of JACOBI_FINALIZE -------------------------------------------- / -!/ - END SUBROUTINE JACOBI_FINALIZE -!/ ------------------------------------------------------------------- / + CALL STRACE (IENT, 'JACOBI_FINALIZE') +#endif + IF (IMEM == 1) THEN + DEALLOCATE(ASPAR_JAC) + ELSE IF (IMEM == 2) THEN + DEALLOCATE(ASPAR_DIAG_ALL) + ENDIF + DEALLOCATE(B_JAC) + DEALLOCATE(CAD_THE) + IF (FreqShiftMethod .eq. 1) THEN + DEALLOCATE(CAS_SIG) + ELSE IF (FreqShiftMethod .eq. 2) THEN + DEALLOCATE(CWNB_SIG_M2) + END IF + IF (.NOT. B_JGS_BLOCK_GAUSS_SEIDEL) THEN + DEALLOCATE(U_JAC) + END IF + !/ + !/ End of JACOBI_FINALIZE -------------------------------------------- / + !/ + END SUBROUTINE JACOBI_FINALIZE + !/ ------------------------------------------------------------------- / END MODULE PDLIB_W3PROFSMD diff --git a/model/src/w3psmcmd.F90 b/model/src/w3psmcmd.F90 index 419e9ef9f..6083a7822 100644 --- a/model/src/w3psmcmd.F90 +++ b/model/src/w3psmcmd.F90 @@ -15,4063 +15,3917 @@ !> @author Jian-Guo Li !> @date 23 Mar 2020 !> - MODULE W3PSMCMD -!/ -!/ +------------------------------------+ -!/ | Spherical Multiple-Cell (SMC) grid | -!/ | Adv, GCT, Rfr, Dif subroutines. | -!/ | Jian-Guo Li | -!/ | First created: 8 Nov 2010 | -!/ | Last modified: 23 Mar 2020 | -!/ +------------------------------------+ -!/ -!/ 08-Nov-2010 : Coding started by adapting w3pro2md.ftn. -!/ 18-Nov-2010 : Refraction and GCT by rotation and k-shift. -!/ 12-Apr-2011 : Restore x-advective flux for intermediate update. -!/ 3-Jun-2011 : New refraction formulation using Cg only. -!/ 8-Jun-2011 : Optimise classic refraction formulation. -!/ 16-Jun-2011 : Add refraction limter to gradient direction. -!/ 1-Jul-2011 : New refraction using Cg and gradient limiter. -!/ 28-Jul-2011 : Finalise with old refraction scheme and gradient limiter. -!/ 4-Nov-2011 : Separate x and y obstruction coefficients. -!/ 5-Jan-2012 : Update to multi-resolution SMC grid with sub-time-steps. -!/ 2-Feb-2012 : Separate single- and multi-resolution advection. -!/ 6-Mar-2012 : Tidy up code and minor adjustments, CLATF. -!/ 12-Mar-2012 : Remove net flux bug and optimise upstream code. -!/ 16-Jan-2013 : Adapted for Version 4.08, removing FACX/Y. -!/ 16-Sep-2013 : Add Arctic part for SMC grid in WW3 V4.11 -!/ 3-Jan-2014 : Remove bug in SMCDHXY for AU/V as cell size. -!/ 7-Jan-2014 : Remove bug in SMCGtCrfr for K definition. -!/ 28-Jan-2014 : Move Arctic boundary condition update out. -!/ 18-Aug-2015 : New gradient, average and 3rd order advection subs. -!/ 3-Sep-2015 : UNO3 advection scheme by logical option FUNO3. -!/ 14-Sep-2015 : Modify DHDX/Y for Arctic part refraction term. -!/ 8-Aug-2017 : Update SMCGradn for 0 or 1 boundary conditions. -!/ 9-Jan-2018 : Parallelization by adding OpenMP directives. -!/ 19-Feb-2020 : Additions for OMP bit-reproducability (C.Bunney) -!/ 23-Mar-2020 : Add extra parenthese for single ATOMIC line update. -!/ 22-Oct-2020 : Two new subs for lat-lon points mapping to cells. -!/ -! 1. Purpose : -! -! Bundles routines for SMC advection (UNO2) and diffusion schemes in -! single module, including GCT and refraction rotation schemes. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! TRNMIN R.P. Private Minimum transparancy for local -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3PSMC Subr. Public Spatial propagation on SMC grid. -! W3KRTN Subr. Public Spectral modification by GCT and refraction. -! SMCxUNO2 Subr. Public Irregular grid mid-flux on U-faces by UNO2. -! SMCyUNO2 Subr. Public Irregular grid mid-flux on V-faces by UNO2. -! SMCxUNO2r Subr. Public Regular grid mid-flux on U-faces by UNO2. -! SMCyUNO2r Subr. Public Regular grid mid-flux on V-faces by UNO2. -! SMCkUNO2 Subr. Public Shift in k-space due to refraction by UNO2. -! SMCxUNO3 Subr. Public Irregular grid mid-flux on U-faces by UNO3. -! SMCyUNO3 Subr. Public Irregular grid mid-flux on V-faces by UNO3. -! SMCxUNO3r Subr. Public Regular grid 3rd order U-mid-flux by UNO3. -! SMCyUNO3r Subr. Public Regular grid 3rd order V-mid-flux by UNO3. -! SMCGtCrfr Subr. Public Refraction and GCT rotation in theta. -! SMCDHXY Subr. Public Evaluate depth gradient and refraction limiter. -! SMCGradn Subr. Public Evaluate local gradient for sea points. -! SMCAverg Subr. Public Numerical 1-2-1 average of sea point field. -! W3GATHSMC W3SCATSMC Gather and scatter spectral components. -! W3SMCELL Subr. Public Calculate cell centre lat-lon for given ids. -! W3SMCGMP Subr. Public Map lat-lon points to SMC grid cells. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! W3ACTURN Subr. W3SERVMD Subroutine rotating action spectrum. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/MGP Correct for motion of grid. -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ Use omp_lib for OpenMP functions if switched on. JGLi10Jan2018 -!$ USE omp_lib -!/ -!/ Public variables -!/ - PUBLIC -!/ -!/ Private data !/ - REAL, PRIVATE, PARAMETER:: TRNMIN = 0.95 !< Minimum transparancy for local -!/ - CONTAINS - -!/ ------------------------------------------------------------------- / -!> @brief Propagation in phyiscal space for a given spectral component -!> -!> @details Unstructured SMC grid, point-oriented face and cell loops. -!> UNO2 advection scheme and isotropic FTCS diffusion scheme -!> -!> @param[in] ISP Number of spectral bin (IK-1)*NTH+ITH -!> @param[in] DTG Total time step. -!> @param[inout] VQ Field to propagate. -!> -!> @author Jian-Guo Li -!> @date 18 Apr 2018 -!> - SUBROUTINE W3PSMC ( ISP, DTG, VQ ) -!/ -!/ +------------------------------------+ -!/ | Spherical Multiple-Cell (SMC) grid | -!/ | Advection and diffusion sub. | -!/ | First created: JG Li 8 Nov 2010 | -!/ | Last modified: JG Li 18 Apr 2018 | -!/ +------------------------------------+ -!/ -!/ 08-Nov-2010 : Origination. JGLi ( version 1.00 ) -!/ 16-Dec-2010 : Check U/V CFL values. JGLi ( version 1.10 ) -!/ 18-Mar-2011 : Check MPI communication. JGLi ( version 1.20 ) -!/ 16-May-2011 : Tidy up diagnosis lines. JGLi ( version 1.30 ) -!/ 4 Nov-2011 : Separate x and y obstruc. JGLi ( version 1.40 ) -!/ 5 Jan-2012 : Multi-resolution SMC grid. JGLi ( version 1.50 ) -!/ 2 Feb-2012 : Separate single multi adv. JGLi ( version 1.60 ) -!/ 6 Mar-2012 : Minor adjustments of CLATF. JGLi ( version 1.70 ) -!/ 12 Feb-2012 : Remove net flux bug. JGLi ( version 1.80 ) -!/ 16 Sep-2013 : Add Arctic part. JGLi ( version 2.00 ) -!/ 3 Sep-2015 : Gradient, UNO3 and Average. JGLi ( version 2.10 ) -!/ 26 Feb-2016 : Update boundary spectra. JGLi ( version 2.20 ) -!/ 23 Mar-2016 : Add current option. JGLi ( version 2.30 ) -!/ 18 Apr-2018 : Refined sub-grid blocking. JGLi ( version 2.40 ) -!/ -! 1. Purpose : -! -! Propagation in phyiscal space for a given spectral component. -! -! 2. Method : -! -! Unstructured SMC grid, point-oriented face and cell loops. -! UNO2 advection scheme and isotropic FTCS diffusion scheme. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH -! FACX/Y Real I Factor in propagation velocity (1 or 0 *DT/DX) -! DTG Real I Total time step. -! MAPSTA I.A. I Grid point status map. -! MAPFS I.A. I Storage map. -! VQ R.A. I/O Field to propagate. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! NTLOC Int Number of local time steps. -! DTLOC Real Local propagation time step. -! CGD Real Deep water group velocity. -! DSSD, DNND Deep water diffusion coefficients. -! ULCFLX R.A. Local courant numbers in 'x' (norm. velocities) -! VLCFLY R.A. Id. in 'y'. -! CXTOT R.A. Propagation velocities in physical space. -! CYTOT R.A. -! DFRR Real Relative frequency increment. -! DX0I Real Inverted grid incremenent in meters (longitude, eq.). -! DY0I Real Inverted grid incremenent in meters (latitude). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Wave model routine. -! --------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! --------------------------------------------- -! 1. Preparations -! a Set constants -! b Initialize arrays -! 2. Prepare arrays -! a Velocities and 'Q' -! b diffusion coefficients -! 3. Loop over sub-steps -! ---------------------------------------- -! a Propagate -! b Update boundary conditions -! c Diffusion correction -! ---------------------------------------- -! 4. Store Q field in spectra -! --------------------------------------------- -! -! 9. Switches : -! -! !/MGP Correct for motion of grid. -! -! !/TDYN Dynamic increase of DTME -! !/DSS0 Disable diffusion in propagation direction -! !/XW0 Propagation diffusion only. -! !/XW1 Growth diffusion only. -! -! !/S Enable subroutine tracing. -! -! !/T Enable general test output. -! !/T1 Dump of input field and fluxes. -! !/T2 Dump of output field. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -! - USE W3TIMEMD, ONLY: DSEC21 -! - USE W3GDATMD, ONLY: NK, NTH, DTH, XFR, ESIN, ECOS, SIG, NX, NY, & - NSEA, SX, SY, MAPSF, FUNO3, FVERG, & - IJKCel, IJKUFc, IJKVFc, NCel, NUFc, NVFc, & - IJKCel3, IJKCel4, & - IJKVFc5, IJKVFc6,IJKUFc5,IJKUFc6, & - NLvCel, NLvUFc, NLvVFc, NRLv, MRFct, & - DTCFL, CLATS, DTMS, CTRNX, CTRNY - USE W3GDATMD, ONLY: NGLO, ANGARC, ARCTC - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: CG, WN, U10, CX, CY, ATRNX, ATRNY, ITIME -! - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & - ISBPI, BBPI0, BBPIN -! +MODULE W3PSMCMD + !/ + !/ +------------------------------------+ + !/ | Spherical Multiple-Cell (SMC) grid | + !/ | Adv, GCT, Rfr, Dif subroutines. | + !/ | Jian-Guo Li | + !/ | First created: 8 Nov 2010 | + !/ | Last modified: 23 Mar 2020 | + !/ +------------------------------------+ + !/ + !/ 08-Nov-2010 : Coding started by adapting w3pro2md.ftn. + !/ 18-Nov-2010 : Refraction and GCT by rotation and k-shift. + !/ 12-Apr-2011 : Restore x-advective flux for intermediate update. + !/ 3-Jun-2011 : New refraction formulation using Cg only. + !/ 8-Jun-2011 : Optimise classic refraction formulation. + !/ 16-Jun-2011 : Add refraction limter to gradient direction. + !/ 1-Jul-2011 : New refraction using Cg and gradient limiter. + !/ 28-Jul-2011 : Finalise with old refraction scheme and gradient limiter. + !/ 4-Nov-2011 : Separate x and y obstruction coefficients. + !/ 5-Jan-2012 : Update to multi-resolution SMC grid with sub-time-steps. + !/ 2-Feb-2012 : Separate single- and multi-resolution advection. + !/ 6-Mar-2012 : Tidy up code and minor adjustments, CLATF. + !/ 12-Mar-2012 : Remove net flux bug and optimise upstream code. + !/ 16-Jan-2013 : Adapted for Version 4.08, removing FACX/Y. + !/ 16-Sep-2013 : Add Arctic part for SMC grid in WW3 V4.11 + !/ 3-Jan-2014 : Remove bug in SMCDHXY for AU/V as cell size. + !/ 7-Jan-2014 : Remove bug in SMCGtCrfr for K definition. + !/ 28-Jan-2014 : Move Arctic boundary condition update out. + !/ 18-Aug-2015 : New gradient, average and 3rd order advection subs. + !/ 3-Sep-2015 : UNO3 advection scheme by logical option FUNO3. + !/ 14-Sep-2015 : Modify DHDX/Y for Arctic part refraction term. + !/ 8-Aug-2017 : Update SMCGradn for 0 or 1 boundary conditions. + !/ 9-Jan-2018 : Parallelization by adding OpenMP directives. + !/ 19-Feb-2020 : Additions for OMP bit-reproducability (C.Bunney) + !/ 23-Mar-2020 : Add extra parenthese for single ATOMIC line update. + !/ 22-Oct-2020 : Two new subs for lat-lon points mapping to cells. + !/ + ! 1. Purpose : + ! + ! Bundles routines for SMC advection (UNO2) and diffusion schemes in + ! single module, including GCT and refraction rotation schemes. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! TRNMIN R.P. Private Minimum transparancy for local + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3PSMC Subr. Public Spatial propagation on SMC grid. + ! W3KRTN Subr. Public Spectral modification by GCT and refraction. + ! SMCxUNO2 Subr. Public Irregular grid mid-flux on U-faces by UNO2. + ! SMCyUNO2 Subr. Public Irregular grid mid-flux on V-faces by UNO2. + ! SMCxUNO2r Subr. Public Regular grid mid-flux on U-faces by UNO2. + ! SMCyUNO2r Subr. Public Regular grid mid-flux on V-faces by UNO2. + ! SMCkUNO2 Subr. Public Shift in k-space due to refraction by UNO2. + ! SMCxUNO3 Subr. Public Irregular grid mid-flux on U-faces by UNO3. + ! SMCyUNO3 Subr. Public Irregular grid mid-flux on V-faces by UNO3. + ! SMCxUNO3r Subr. Public Regular grid 3rd order U-mid-flux by UNO3. + ! SMCyUNO3r Subr. Public Regular grid 3rd order V-mid-flux by UNO3. + ! SMCGtCrfr Subr. Public Refraction and GCT rotation in theta. + ! SMCDHXY Subr. Public Evaluate depth gradient and refraction limiter. + ! SMCGradn Subr. Public Evaluate local gradient for sea points. + ! SMCAverg Subr. Public Numerical 1-2-1 average of sea point field. + ! W3GATHSMC W3SCATSMC Gather and scatter spectral components. + ! W3SMCELL Subr. Public Calculate cell centre lat-lon for given ids. + ! W3SMCGMP Subr. Public Map lat-lon points to SMC grid cells. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! W3ACTURN Subr. W3SERVMD Subroutine rotating action spectrum. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/MGP Correct for motion of grid. + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ Use omp_lib for OpenMP functions if switched on. JGLi10Jan2018 + !$ USE omp_lib + !/ + !/ Public variables + !/ + PUBLIC + !/ + !/ Private data !/ + REAL, PRIVATE, PARAMETER:: TRNMIN = 0.95 !< Minimum transparancy for local + !/ +CONTAINS + + !/ ------------------------------------------------------------------- / + !> @brief Propagation in phyiscal space for a given spectral component + !> + !> @details Unstructured SMC grid, point-oriented face and cell loops. + !> UNO2 advection scheme and isotropic FTCS diffusion scheme + !> + !> @param[in] ISP Number of spectral bin (IK-1)*NTH+ITH + !> @param[in] DTG Total time step. + !> @param[inout] VQ Field to propagate. + !> + !> @author Jian-Guo Li + !> @date 18 Apr 2018 + !> + SUBROUTINE W3PSMC ( ISP, DTG, VQ ) + !/ + !/ +------------------------------------+ + !/ | Spherical Multiple-Cell (SMC) grid | + !/ | Advection and diffusion sub. | + !/ | First created: JG Li 8 Nov 2010 | + !/ | Last modified: JG Li 18 Apr 2018 | + !/ +------------------------------------+ + !/ + !/ 08-Nov-2010 : Origination. JGLi ( version 1.00 ) + !/ 16-Dec-2010 : Check U/V CFL values. JGLi ( version 1.10 ) + !/ 18-Mar-2011 : Check MPI communication. JGLi ( version 1.20 ) + !/ 16-May-2011 : Tidy up diagnosis lines. JGLi ( version 1.30 ) + !/ 4 Nov-2011 : Separate x and y obstruc. JGLi ( version 1.40 ) + !/ 5 Jan-2012 : Multi-resolution SMC grid. JGLi ( version 1.50 ) + !/ 2 Feb-2012 : Separate single multi adv. JGLi ( version 1.60 ) + !/ 6 Mar-2012 : Minor adjustments of CLATF. JGLi ( version 1.70 ) + !/ 12 Feb-2012 : Remove net flux bug. JGLi ( version 1.80 ) + !/ 16 Sep-2013 : Add Arctic part. JGLi ( version 2.00 ) + !/ 3 Sep-2015 : Gradient, UNO3 and Average. JGLi ( version 2.10 ) + !/ 26 Feb-2016 : Update boundary spectra. JGLi ( version 2.20 ) + !/ 23 Mar-2016 : Add current option. JGLi ( version 2.30 ) + !/ 18 Apr-2018 : Refined sub-grid blocking. JGLi ( version 2.40 ) + !/ + ! 1. Purpose : + ! + ! Propagation in phyiscal space for a given spectral component. + ! + ! 2. Method : + ! + ! Unstructured SMC grid, point-oriented face and cell loops. + ! UNO2 advection scheme and isotropic FTCS diffusion scheme. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH + ! FACX/Y Real I Factor in propagation velocity (1 or 0 *DT/DX) + ! DTG Real I Total time step. + ! MAPSTA I.A. I Grid point status map. + ! MAPFS I.A. I Storage map. + ! VQ R.A. I/O Field to propagate. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! NTLOC Int Number of local time steps. + ! DTLOC Real Local propagation time step. + ! CGD Real Deep water group velocity. + ! DSSD, DNND Deep water diffusion coefficients. + ! ULCFLX R.A. Local courant numbers in 'x' (norm. velocities) + ! VLCFLY R.A. Id. in 'y'. + ! CXTOT R.A. Propagation velocities in physical space. + ! CYTOT R.A. + ! DFRR Real Relative frequency increment. + ! DX0I Real Inverted grid incremenent in meters (longitude, eq.). + ! DY0I Real Inverted grid incremenent in meters (latitude). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Wave model routine. + ! --------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! --------------------------------------------- + ! 1. Preparations + ! a Set constants + ! b Initialize arrays + ! 2. Prepare arrays + ! a Velocities and 'Q' + ! b diffusion coefficients + ! 3. Loop over sub-steps + ! ---------------------------------------- + ! a Propagate + ! b Update boundary conditions + ! c Diffusion correction + ! ---------------------------------------- + ! 4. Store Q field in spectra + ! --------------------------------------------- + ! + ! 9. Switches : + ! + ! !/MGP Correct for motion of grid. + ! + ! !/TDYN Dynamic increase of DTME + ! !/DSS0 Disable diffusion in propagation direction + ! !/XW0 Propagation diffusion only. + ! !/XW1 Growth diffusion only. + ! + ! !/S Enable subroutine tracing. + ! + ! !/T Enable general test output. + ! !/T1 Dump of input field and fluxes. + ! !/T2 Dump of output field. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + ! + USE W3TIMEMD, ONLY: DSEC21 + ! + USE W3GDATMD, ONLY: NK, NTH, DTH, XFR, ESIN, ECOS, SIG, NX, NY, & + NSEA, SX, SY, MAPSF, FUNO3, FVERG, & + IJKCel, IJKUFc, IJKVFc, NCel, NUFc, NVFc, & + IJKCel3, IJKCel4, & + IJKVFc5, IJKVFc6,IJKUFc5,IJKUFc6, & + NLvCel, NLvUFc, NLvVFc, NRLv, MRFct, & + DTCFL, CLATS, DTMS, CTRNX, CTRNY + USE W3GDATMD, ONLY: NGLO, ANGARC, ARCTC + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: CG, WN, U10, CX, CY, ATRNX, ATRNY, ITIME + ! + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & + ISBPI, BBPI0, BBPIN + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISP - REAL, INTENT(IN) :: DTG - REAL, INTENT(INOUT) :: VQ(NSEA) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK, NTLOC, ITLOC, ISEA, IXY, & - IY, IY0, IP, IBI, LvR - INTEGER :: i, j, k, L, M, N, LL, MM, NN, LMN, & - iuf, juf, ivf, jvf, icl, jcl + USE W3SERVMD, ONLY: STRACE +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISP + REAL, INTENT(IN) :: DTG + REAL, INTENT(INOUT) :: VQ(NSEA) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK, NTLOC, ITLOC, ISEA, IXY, & + IY, IY0, IP, IBI, LvR + INTEGER :: i, j, k, L, M, N, LL, MM, NN, LMN, & + iuf, juf, ivf, jvf, icl, jcl #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: CG0, CGA, CGN, CGX, CGY, FMR, RD1, & - RD2, CXMIN, CXMAX, CYMIN, CYMAX, & - CXC, CYC, DTLDX, DTLDY - REAL :: DTLOC, CGCOS, CGSIN, FUTRN, FVTRN, & - DFRR, DX0I, DY0I, CGD, DSSD, & - DNND, DCELL, XWIND, TFAC, DSS, DNN - REAL :: PCArea, ARCTH - LOGICAL :: YFIRST -!/ -!/ Automatic work arrays -! - REAL, Dimension(-9:NCel) :: FCNt, AFCN, BCNt, UCFL, VCFL, CQ, & - CQA, CXTOT, CYTOT - REAL, Dimension( NUFc) :: FUMD, FUDIFX, ULCFLX - REAL, Dimension( NVFc) :: FVMD, FVDIFY, VLCFLY -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: CG0, CGA, CGN, CGX, CGY, FMR, RD1, & + RD2, CXMIN, CXMAX, CYMIN, CYMAX, & + CXC, CYC, DTLDX, DTLDY + REAL :: DTLOC, CGCOS, CGSIN, FUTRN, FVTRN, & + DFRR, DX0I, DY0I, CGD, DSSD, & + DNND, DCELL, XWIND, TFAC, DSS, DNN + REAL :: PCArea, ARCTH + LOGICAL :: YFIRST + !/ + !/ Automatic work arrays + ! + REAL, Dimension(-9:NCel) :: FCNt, AFCN, BCNt, UCFL, VCFL, CQ, & + CQA, CXTOT, CYTOT + REAL, Dimension( NUFc) :: FUMD, FUDIFX, ULCFLX + REAL, Dimension( NVFc) :: FVMD, FVDIFY, VLCFLY + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3PSMC') -#endif -! -! 1. Preparations --------------------------------------------------- * - -!!Li Spectral bin direction and frequency indices - ITH = 1 + MOD(ISP-1,NTH) - IK = 1 + (ISP-1)/NTH - -!!Li Maximum group speed for 1st and the transported frequency bin -!!Li A factor of 1.2 is added to account for the shallow water peak. - CG0 = 0.6 * GRAV / SIG(1) - CGA = 0.6 * GRAV / SIG(IK) - -!!Li Maximum group speed for given spectral bin. First bin speed is -!!Li used to avoid zero speed component. -! CGX = ABS( CGA * ECOS(ITH) ) -! CGY = ABS( CGA * ESIN(ITH) ) - CGX = CGA * ECOS(ITH) - CGY = CGA * ESIN(ITH) - -!!Li Add maximum current components to maximum group components. - IF ( FLCUR ) THEN - CXMIN = MINVAL ( CX(1:NSEA) ) - CXMAX = MAXVAL ( CX(1:NSEA) ) - CYMIN = MINVAL ( CY(1:NSEA) ) - CYMAX = MAXVAL ( CY(1:NSEA) ) - IF ( ABS(CGX+CXMIN) .GT. ABS(CGX+CXMAX) ) THEN - CGX = CGX + CXMIN - ELSE - CGX = CGX + CXMAX - END IF - IF ( ABS(CGY+CYMIN) .GT. ABS(CGY+CYMAX) ) THEN - CGY = CGY + CYMIN - ELSE - CGY = CGY + CYMAX - END IF - CXC = MAX ( ABS(CXMIN) , ABS(CXMAX) ) - CYC = MAX ( ABS(CYMIN) , ABS(CYMAX) ) - ELSE - CXC = 0. - CYC = 0. - END IF - -!!Li Base-cell grid lenth at Equator (size-4 on SMC625 grid). - DX0I = 1.0/(SX * DERA * RADIUS) - DY0I = 1.0/(SY * DERA * RADIUS) - -!!Li Miminum time step determined by Courant number < 0.8 -!!Li Note, minimum x grid length is half the Equator value. -!!Li Minimum time step should not be less than sub w3init requirement, -!!Li where IAPPRO array is initialised for propagation parallization. - CGN = 0.9999 * MAX( ABS(CGX), ABS(CGY), CXC, CYC, 0.001*CG0 ) - DTLOC = DTCFL*CG0/CGN - NTLOC = 1 + INT(DTG/DTLOC - 0.001) - DTLOC = DTG / REAL(NTLOC) - -!!Li Group speed component common factors, FACX=DTG*DX0I -!!Li FACX and FACY are evaluated here directly. JGLi16Jan2013 -! CGCOS = FACX * ECOS(ITH) / REAL(NTLOC) -! CGSIN = FACY * ESIN(ITH) / REAL(NTLOC) - CGCOS = ECOS(ITH) - CGSIN = ESIN(ITH) - DTLDX = DTLOC * DX0I - DTLDY = DTLOC * DY0I -! - YFIRST = MOD(ITIME,2) .EQ. 0 -! -!Li Homogenous diffusion Fourier number DNND and DSSD will be used. -!Li They have to be divided by base-cell size for size-1 stability. -!Li So they are equivalent to the Fourier number in size-1 cell at -!Li the sub-time step DTLOC/MRFct. - IF ( DTMS .GT. 0. ) THEN - DFRR = XFR - 1. - CGD = 0.5 * GRAV / SIG(IK) - DNN = ((DTH*CGD)**2)*DTMS / 12. - DNND = DNN*DTLOC*(DX0I*DX0I) - DSSD = DNN*DTLOC*(DY0I*DY0I) + CALL STRACE (IENT, 'W3PSMC') +#endif + ! + ! 1. Preparations --------------------------------------------------- * + + !!Li Spectral bin direction and frequency indices + ITH = 1 + MOD(ISP-1,NTH) + IK = 1 + (ISP-1)/NTH + + !!Li Maximum group speed for 1st and the transported frequency bin + !!Li A factor of 1.2 is added to account for the shallow water peak. + CG0 = 0.6 * GRAV / SIG(1) + CGA = 0.6 * GRAV / SIG(IK) + + !!Li Maximum group speed for given spectral bin. First bin speed is + !!Li used to avoid zero speed component. + ! CGX = ABS( CGA * ECOS(ITH) ) + ! CGY = ABS( CGA * ESIN(ITH) ) + CGX = CGA * ECOS(ITH) + CGY = CGA * ESIN(ITH) + + !!Li Add maximum current components to maximum group components. + IF ( FLCUR ) THEN + CXMIN = MINVAL ( CX(1:NSEA) ) + CXMAX = MAXVAL ( CX(1:NSEA) ) + CYMIN = MINVAL ( CY(1:NSEA) ) + CYMAX = MAXVAL ( CY(1:NSEA) ) + IF ( ABS(CGX+CXMIN) .GT. ABS(CGX+CXMAX) ) THEN + CGX = CGX + CXMIN ELSE - DSSD = 0.0 - DNND = 0.0 + CGX = CGX + CXMAX END IF -! -! 1.b Initialize arrays -! + IF ( ABS(CGY+CYMIN) .GT. ABS(CGY+CYMAX) ) THEN + CGY = CGY + CYMIN + ELSE + CGY = CGY + CYMAX + END IF + CXC = MAX ( ABS(CXMIN) , ABS(CXMAX) ) + CYC = MAX ( ABS(CYMIN) , ABS(CYMAX) ) + ELSE + CXC = 0. + CYC = 0. + END IF + + !!Li Base-cell grid lenth at Equator (size-4 on SMC625 grid). + DX0I = 1.0/(SX * DERA * RADIUS) + DY0I = 1.0/(SY * DERA * RADIUS) + + !!Li Miminum time step determined by Courant number < 0.8 + !!Li Note, minimum x grid length is half the Equator value. + !!Li Minimum time step should not be less than sub w3init requirement, + !!Li where IAPPRO array is initialised for propagation parallization. + CGN = 0.9999 * MAX( ABS(CGX), ABS(CGY), CXC, CYC, 0.001*CG0 ) + DTLOC = DTCFL*CG0/CGN + NTLOC = 1 + INT(DTG/DTLOC - 0.001) + DTLOC = DTG / REAL(NTLOC) + + !!Li Group speed component common factors, FACX=DTG*DX0I + !!Li FACX and FACY are evaluated here directly. JGLi16Jan2013 + ! CGCOS = FACX * ECOS(ITH) / REAL(NTLOC) + ! CGSIN = FACY * ESIN(ITH) / REAL(NTLOC) + CGCOS = ECOS(ITH) + CGSIN = ESIN(ITH) + DTLDX = DTLOC * DX0I + DTLDY = DTLOC * DY0I + ! + YFIRST = MOD(ITIME,2) .EQ. 0 + ! + !Li Homogenous diffusion Fourier number DNND and DSSD will be used. + !Li They have to be divided by base-cell size for size-1 stability. + !Li So they are equivalent to the Fourier number in size-1 cell at + !Li the sub-time step DTLOC/MRFct. + IF ( DTMS .GT. 0. ) THEN + DFRR = XFR - 1. + CGD = 0.5 * GRAV / SIG(IK) + DNN = ((DTH*CGD)**2)*DTMS / 12. + DNND = DNN*DTLOC*(DX0I*DX0I) + DSSD = DNN*DTLOC*(DY0I*DY0I) + ELSE + DSSD = 0.0 + DNND = 0.0 + END IF + ! + ! 1.b Initialize arrays + ! #ifdef W3_T - WRITE (NDST,9010) + WRITE (NDST,9010) #endif -! - ULCFLX = 0. - VLCFLY = 0. + ! + ULCFLX = 0. + VLCFLY = 0. -!Li Pass spectral element VQ to CQ and define size-1 cell CFL + !Li Pass spectral element VQ to CQ and define size-1 cell CFL #ifdef W3_OMPG -!$OMP Parallel DO Private(ISEA) + !$OMP Parallel DO Private(ISEA) #endif - DO ISEA=1, NSEA -!Li Transported variable is divided by CG as in WW3. - CQ(ISEA) = VQ(ISEA)/CG(IK,ISEA) -!Li Resetting NaNQ VQ to zero if any. JGLi18Mar2013 - IF( .NOT. (CQ(ISEA) .EQ. CQ(ISEA)) ) CQ(ISEA) = 0.0 - END DO + DO ISEA=1, NSEA + !Li Transported variable is divided by CG as in WW3. + CQ(ISEA) = VQ(ISEA)/CG(IK,ISEA) + !Li Resetting NaNQ VQ to zero if any. JGLi18Mar2013 + IF( .NOT. (CQ(ISEA) .EQ. CQ(ISEA)) ) CQ(ISEA) = 0.0 + END DO #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP END Parallel DO #endif -!Li Add current components if any to wave velocity. - IF ( FLCUR ) THEN + !Li Add current components if any to wave velocity. + IF ( FLCUR ) THEN #ifdef W3_OMPG -!$OMP Parallel DO Private(ISEA) + !$OMP Parallel DO Private(ISEA) #endif - DO ISEA=1, NSEA - CXTOT(ISEA) = (CGCOS * CG(IK,ISEA) + CX(ISEA)) - CYTOT(ISEA) = (CGSIN * CG(IK,ISEA) + CY(ISEA)) - ENDDO + DO ISEA=1, NSEA + CXTOT(ISEA) = (CGCOS * CG(IK,ISEA) + CX(ISEA)) + CYTOT(ISEA) = (CGSIN * CG(IK,ISEA) + CY(ISEA)) + ENDDO #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP END Parallel DO #endif - ELSE -!Li No current case use group speed only. + ELSE + !Li No current case use group speed only. #ifdef W3_OMPG -!$OMP Parallel DO Private(ISEA) + !$OMP Parallel DO Private(ISEA) #endif - DO ISEA=1, NSEA - CXTOT(ISEA) = CGCOS * CG(IK,ISEA) - CYTOT(ISEA) = CGSIN * CG(IK,ISEA) - END DO + DO ISEA=1, NSEA + CXTOT(ISEA) = CGCOS * CG(IK,ISEA) + CYTOT(ISEA) = CGSIN * CG(IK,ISEA) + END DO #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP END Parallel DO #endif -!Li End of IF( FLCUR ) block. - ENDIF + !Li End of IF( FLCUR ) block. + ENDIF -!Li Arctic cell velocity components need to be rotated -!Li back to local east referenence system for propagation. - IF( ARCTC ) THEN - DO ISEA=NGLO+1, NSEA - ARCTH = ANGARC(ISEA-NGLO)*DERA - CXC = CXTOT(ISEA)*COS(ARCTH) + CYTOT(ISEA)*SIN(ARCTH) - CYC = CYTOT(ISEA)*COS(ARCTH) - CXTOT(ISEA)*SIN(ARCTH) - CXTOT(ISEA) = CXC - CYTOT(ISEA) = CYC - END DO -!Li Polar cell area factor for V-flux update - PCArea = DY0I/(MRFct*PI*DX0I*FLOAT(IJKCel(4,NSEA))) -!Li V-component is reset to zero for Polar cell as direction -!Li is undefined there. - CYTOT(NSEA) = 0.0 - ENDIF - - -!Li Convert velocity components into CFL factors. -#ifdef W3_OMPG -!$OMP Parallel DO Private(ISEA) -#endif - DO ISEA=1, NSEA - UCFL(ISEA) = DTLDX*CXTOT(ISEA)/CLATS(ISEA) - VCFL(ISEA) = DTLDY*CYTOT(ISEA) - ENDDO -#ifdef W3_OMPG -!$OMP END Parallel DO -#endif - -!Li Initialise boundary cell CQ and Velocity values. - CQ(-9:0)=0.0 - UCFL(-9:0)=0.0 - VCFL(-9:0)=0.0 -! -! 3. Loop over frequency-dependent sub-steps -------------------------* -! - DO ITLOC=1, NTLOC -! -! Initialise net flux arrays. - FCNt(-9:NCel) = 0.0 - AFCN(-9:NCel) = 0.0 - BCNt(-9:NCel) = 0.0 -! -! Single-resolution SMC grid uses regular grid advection with -! partial blocking enabled when NRLv = 1 - IF ( NRLv .EQ. 1 ) THEN - IF( FUNO3 ) THEN -! Use 3rd order UNO3 scheme. JGLi20Aug2015 - CALL SMCxUNO3r(1, NUFc, CQ, UCFL, ULCFLX, DNND, FUMD, FUDIFX) - ELSE -! Call SMCxUNO2 to calculate MFx value - CALL SMCxUNO2r(1, NUFc, CQ, UCFL, ULCFLX, DNND, FUMD, FUDIFX) - ENDIF - -! Store conservative flux in FCNt advective one in AFCN -#ifdef W3_OMPG -!$OMP Parallel DO Private(i, M, N, FUTRN) -#endif - DO i=1, NUFc - M=IJKUFc5(i) - N=IJKUFc6(i) - FUTRN = FUMD(i)*ULCFLX(i) - FUDIFX(i) - -!! Add sub-grid transparency for input flux update. JGLi16May2011 -!! Transparency is also applied on diffusion flux. JGLi12Mar2012 -!! Replace CRITICAL with ATOMIC. JGLi15Jan2019 -!! !$OMP CRITICAL -!! Remove boundary cell flux update or M N > 0. JGLi28Mar2019 - IF( M > 0 ) THEN - IF( (CTRNX(M)+CTRNX(N)) .GE. 1.96 ) THEN -#ifdef W3_OMPG -!$OMP ATOMIC -#endif - FCNt(M) = FCNt(M) - FUTRN - ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN -#ifdef W3_OMPG -!$OMP ATOMIC -#endif - FCNt(M) = FCNt(M) - FUTRN*CTRNX(M) - ELSE + !Li Arctic cell velocity components need to be rotated + !Li back to local east referenence system for propagation. + IF( ARCTC ) THEN + DO ISEA=NGLO+1, NSEA + ARCTH = ANGARC(ISEA-NGLO)*DERA + CXC = CXTOT(ISEA)*COS(ARCTH) + CYTOT(ISEA)*SIN(ARCTH) + CYC = CYTOT(ISEA)*COS(ARCTH) - CXTOT(ISEA)*SIN(ARCTH) + CXTOT(ISEA) = CXC + CYTOT(ISEA) = CYC + END DO + !Li Polar cell area factor for V-flux update + PCArea = DY0I/(MRFct*PI*DX0I*FLOAT(IJKCel(4,NSEA))) + !Li V-component is reset to zero for Polar cell as direction + !Li is undefined there. + CYTOT(NSEA) = 0.0 + ENDIF + + + !Li Convert velocity components into CFL factors. +#ifdef W3_OMPG + !$OMP Parallel DO Private(ISEA) +#endif + DO ISEA=1, NSEA + UCFL(ISEA) = DTLDX*CXTOT(ISEA)/CLATS(ISEA) + VCFL(ISEA) = DTLDY*CYTOT(ISEA) + ENDDO +#ifdef W3_OMPG + !$OMP END Parallel DO +#endif + + !Li Initialise boundary cell CQ and Velocity values. + CQ(-9:0)=0.0 + UCFL(-9:0)=0.0 + VCFL(-9:0)=0.0 + ! + ! 3. Loop over frequency-dependent sub-steps -------------------------* + ! + DO ITLOC=1, NTLOC + ! + ! Initialise net flux arrays. + FCNt(-9:NCel) = 0.0 + AFCN(-9:NCel) = 0.0 + BCNt(-9:NCel) = 0.0 + ! + ! Single-resolution SMC grid uses regular grid advection with + ! partial blocking enabled when NRLv = 1 + IF ( NRLv .EQ. 1 ) THEN + IF( FUNO3 ) THEN + ! Use 3rd order UNO3 scheme. JGLi20Aug2015 + CALL SMCxUNO3r(1, NUFc, CQ, UCFL, ULCFLX, DNND, FUMD, FUDIFX) + ELSE + ! Call SMCxUNO2 to calculate MFx value + CALL SMCxUNO2r(1, NUFc, CQ, UCFL, ULCFLX, DNND, FUMD, FUDIFX) + ENDIF + + ! Store conservative flux in FCNt advective one in AFCN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP Parallel DO Private(i, M, N, FUTRN) #endif - FCNt(M) = FCNt(M) - FUTRN*CTRNX(N)*CTRNX(M) - ENDIF -! Also divided by another cell length as UCFL is in basic unit. + DO i=1, NUFc + M=IJKUFc5(i) + N=IJKUFc6(i) + FUTRN = FUMD(i)*ULCFLX(i) - FUDIFX(i) + + !! Add sub-grid transparency for input flux update. JGLi16May2011 + !! Transparency is also applied on diffusion flux. JGLi12Mar2012 + !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 + !! !$OMP CRITICAL + !! Remove boundary cell flux update or M N > 0. JGLi28Mar2019 + IF( M > 0 ) THEN + IF( (CTRNX(M)+CTRNX(N)) .GE. 1.96 ) THEN +#ifdef W3_OMPG + !$OMP ATOMIC +#endif + FCNt(M) = FCNt(M) - FUTRN + ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN +#ifdef W3_OMPG + !$OMP ATOMIC +#endif + FCNt(M) = FCNt(M) - FUTRN*CTRNX(M) + ELSE #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - ! ChrisB: Re-arranged the RHS term below to make it - ! valid for OMP ATMOIC directive. - AFCN(M) = AFCN(M) - (FUMD(i)*UCFL(M) - FUDIFX(i)) - ENDIF + FCNt(M) = FCNt(M) - FUTRN*CTRNX(N)*CTRNX(M) + ENDIF + ! Also divided by another cell length as UCFL is in basic unit. +#ifdef W3_OMPG + !$OMP ATOMIC +#endif + ! ChrisB: Re-arranged the RHS term below to make it + ! valid for OMP ATMOIC directive. + AFCN(M) = AFCN(M) - (FUMD(i)*UCFL(M) - FUDIFX(i)) + ENDIF - IF( N > 0 ) THEN - IF( (CTRNX(M)+CTRNX(N)) .GE. 1.96 ) THEN + IF( N > 0 ) THEN + IF( (CTRNX(M)+CTRNX(N)) .GE. 1.96 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - FCNt(N) = FCNt(N) + FUTRN - ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN + FCNt(N) = FCNt(N) + FUTRN + ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - FCNt(N) = FCNt(N) + FUTRN*CTRNX(M)*CTRNX(N) - ELSE + FCNt(N) = FCNt(N) + FUTRN*CTRNX(M)*CTRNX(N) + ELSE #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - FCNt(N) = FCNt(N) + FUTRN*CTRNX(N) - ENDIF -! Also divided by another cell length as UCFL is in basic unit. + FCNt(N) = FCNt(N) + FUTRN*CTRNX(N) + ENDIF + ! Also divided by another cell length as UCFL is in basic unit. #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - AFCN(N) = AFCN(N) + (FUMD(i)*UCFL(N) - FUDIFX(i)) - ENDIF -!! !$OMP END CRITICAL + AFCN(N) = AFCN(N) + (FUMD(i)*UCFL(N) - FUDIFX(i)) + ENDIF + !! !$OMP END CRITICAL - ENDDO + ENDDO #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP END Parallel DO #endif -! Store conservative update in CQA and advective update in CQ -! The side length in MF value has to be cancelled with cell length -! Note ULCFLX has been divided by the cell size inside SMCxUNO2. + ! Store conservative update in CQA and advective update in CQ + ! The side length in MF value has to be cancelled with cell length + ! Note ULCFLX has been divided by the cell size inside SMCxUNO2. #ifdef W3_OMPG -!$OMP Parallel DO Private(n) + !$OMP Parallel DO Private(n) #endif - DO n=1, NSEA - CQA(n)=CQ(n) + FCNt(n)/FLOAT(IJKCel3(n)) - CQ (n)=CQ(n) + AFCN(n)/FLOAT(IJKCel3(n)) - ENDDO + DO n=1, NSEA + CQA(n)=CQ(n) + FCNt(n)/FLOAT(IJKCel3(n)) + CQ (n)=CQ(n) + AFCN(n)/FLOAT(IJKCel3(n)) + ENDDO #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP END Parallel DO #endif -! Call advection subs. - IF( FUNO3 ) THEN -! Use 3rd order UNO3 scheme. JGLi20Aug2015 - CALL SMCyUNO3r(1, NVFc, CQ, VCFL, VLCFLY, DSSD, FVMD, FVDIFY) - ELSE -! Call SMCyUNO2 to calculate MFy value - CALL SMCyUNO2r(1, NVFc, CQ, VCFL, VLCFLY, DSSD, FVMD, FVDIFY) - ENDIF + ! Call advection subs. + IF( FUNO3 ) THEN + ! Use 3rd order UNO3 scheme. JGLi20Aug2015 + CALL SMCyUNO3r(1, NVFc, CQ, VCFL, VLCFLY, DSSD, FVMD, FVDIFY) + ELSE + ! Call SMCyUNO2 to calculate MFy value + CALL SMCyUNO2r(1, NVFc, CQ, VCFL, VLCFLY, DSSD, FVMD, FVDIFY) + ENDIF #ifdef W3_OMPG -!$OMP Parallel DO Private(j, M, N, FVTRN) + !$OMP Parallel DO Private(j, M, N, FVTRN) #endif - DO j=1, NVFc - M=IJKVFc5(j) - N=IJKVFc6(j) - FVTRN = FVMD(j)*VLCFLY(j) - FVDIFY(j) + DO j=1, NVFc + M=IJKVFc5(j) + N=IJKVFc6(j) + FVTRN = FVMD(j)*VLCFLY(j) - FVDIFY(j) -!! Add sub-grid transparency for input flux update. JGLi16May2011 -!! Transparency is also applied on diffusion flux. JGLi12Mar2012 -!! Replace CRITICAL with ATOMIC. JGLi15Jan2019 -!! !$OMP CRITICAL -!! Remove boundary cell flux update or M N > 0. JGLi28Mar2019 - IF( M > 0 ) THEN - IF( (CTRNY(M)+CTRNY(N)) .GE. 1.96 ) THEN -#ifdef W3_OMPG -!$OMP ATOMIC -#endif - BCNt(M) = BCNt(M) - FVTRN - ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN + !! Add sub-grid transparency for input flux update. JGLi16May2011 + !! Transparency is also applied on diffusion flux. JGLi12Mar2012 + !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 + !! !$OMP CRITICAL + !! Remove boundary cell flux update or M N > 0. JGLi28Mar2019 + IF( M > 0 ) THEN + IF( (CTRNY(M)+CTRNY(N)) .GE. 1.96 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - BCNt(M) = BCNt(M) - FVTRN*CTRNY(M) - ELSE + BCNt(M) = BCNt(M) - FVTRN + ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - BCNt(M) = BCNt(M) - FVTRN*CTRNY(N)*CTRNY(M) - ENDIF - ENDIF - IF( N > 0 ) THEN - IF( (CTRNY(M)+CTRNY(N)) .GE. 1.96 ) THEN + BCNt(M) = BCNt(M) - FVTRN*CTRNY(M) + ELSE #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - BCNt(N) = BCNt(N) + FVTRN - ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN + BCNt(M) = BCNt(M) - FVTRN*CTRNY(N)*CTRNY(M) + ENDIF + ENDIF + IF( N > 0 ) THEN + IF( (CTRNY(M)+CTRNY(N)) .GE. 1.96 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - BCNt(N) = BCNt(N) + FVTRN*CTRNY(M)*CTRNY(N) - ELSE + BCNt(N) = BCNt(N) + FVTRN + ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - BCNt(N) = BCNt(N) + FVTRN*CTRNY(N) - ENDIF - ENDIF -!! !$OMP END CRITICAL - ENDDO -#ifdef W3_OMPG -!$OMP END Parallel DO -#endif - -! Store conservative update of CQA in CQ -! The v side length in MF value has to be cancelled with cell length -!! One cosine factor is also needed to be divided for SMC grid -#ifdef W3_OMPG -!$OMP Parallel DO Private(n) -#endif - DO n=1, NSEA - CQ(n)=CQA(n) + BCNt(n)/( CLATS(n)*FLOAT(IJKCel3(n)) ) - ENDDO -#ifdef W3_OMPG -!$OMP END Parallel DO -#endif -! Polar cell needs a special area factor, one-level case. - IF( ARCTC ) CQ(NSEA) = CQA(NSEA) + BCNt(NSEA)*PCArea - -! End of single-resolution advection and diffusion. - ELSE - -! Multi-resolution SMC grid uses irregular grid advection scheme -! without partial blocking when NRLv > 1 -! -! 3.a Multiresolution sub-steps depend on refined levels MRFct - DO LMN = 1, MRFct -! -! 3.b Loop over all levels, starting from the finest level. - DO LL= 1, NRLv - -! Cell size of this level - LvR=2**(LL - 1) - FMR=FLOAT( LvR ) -! -! 3.c Calculate this level only if size is factor of LMN - IF( MOD(LMN, LvR) .EQ. 0 ) THEN -! -! 3.d Select cell and face ranges - icl=NLvCel(LL-1)+1 - iuf=NLvUFc(LL-1)+1 - ivf=NLvVFc(LL-1)+1 - jcl=NLvCel(LL) - juf=NLvUFc(LL) - jvf=NLvVFc(LL) -! -! Use 3rd order UNO3 scheme. JGLi03Sep2015 - IF( FUNO3 ) THEN - CALL SMCxUNO3(iuf, juf, CQ, UCFL, ULCFLX, DNND, FUMD, FUDIFX, FMR) - ELSE -! Call SMCxUNO2 to calculate finest level (size-1) MFx value - CALL SMCxUNO2(iuf, juf, CQ, UCFL, ULCFLX, DNND, FUMD, FUDIFX, FMR) - ENDIF - -! Store fineset level conservative flux in FCNt advective one in AFCN -#ifdef W3_OMPG -!$OMP Parallel DO Private(i, L, M, FUTRN) -#endif - DO i=iuf, juf - L=IJKUFc5(i) - M=IJKUFc6(i) - FUTRN = FUMD(i)*ULCFLX(i) - FUDIFX(i) -!! Replace CRITICAL with ATOMIC. JGLi15Jan2019 -!! !$OMP CRITICAL -!! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 - IF( L > 0 ) THEN -!! Add sub-grid blocking for refined cells. JGLi18Apr2018 - IF( (CTRNX(M)+CTRNX(L)) .GE. 1.96 ) THEN -#ifdef W3_OMPG -!$OMP ATOMIC -#endif - FCNt(L) = FCNt(L) - FUTRN - ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN -#ifdef W3_OMPG -!$OMP ATOMIC -#endif - FCNt(L) = FCNt(L) - FUTRN*CTRNX(L) - ELSE + BCNt(N) = BCNt(N) + FVTRN*CTRNY(M)*CTRNY(N) + ELSE #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - FCNt(L) = FCNt(L) - FUTRN*CTRNX(L)*CTRNX(M) - ENDIF + BCNt(N) = BCNt(N) + FVTRN*CTRNY(N) + ENDIF + ENDIF + !! !$OMP END CRITICAL + ENDDO #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP END Parallel DO #endif - ! ChrisB: Re-arranged the RHS term below to make it - ! valid for OMP ATMOIC directive. - AFCN(L) = AFCN(L) - (FUMD(i)*UCFL(L)*FMR - FUDIFX(i)) - ENDIF - IF( M > 0 ) THEN -!! Add sub-grid blocking for refined cells. JGLi18Apr2018 - IF( (CTRNX(M)+CTRNX(L)) .GE. 1.96 ) THEN + + ! Store conservative update of CQA in CQ + ! The v side length in MF value has to be cancelled with cell length + !! One cosine factor is also needed to be divided for SMC grid #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP Parallel DO Private(n) #endif - FCNt(M) = FCNt(M) + FUTRN - ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN + DO n=1, NSEA + CQ(n)=CQA(n) + BCNt(n)/( CLATS(n)*FLOAT(IJKCel3(n)) ) + ENDDO #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP END Parallel DO #endif - FCNt(M) = FCNt(M) + FUTRN*CTRNX(M)*CTRNX(L) + ! Polar cell needs a special area factor, one-level case. + IF( ARCTC ) CQ(NSEA) = CQA(NSEA) + BCNt(NSEA)*PCArea + + ! End of single-resolution advection and diffusion. + ELSE + + ! Multi-resolution SMC grid uses irregular grid advection scheme + ! without partial blocking when NRLv > 1 + ! + ! 3.a Multiresolution sub-steps depend on refined levels MRFct + DO LMN = 1, MRFct + ! + ! 3.b Loop over all levels, starting from the finest level. + DO LL= 1, NRLv + + ! Cell size of this level + LvR=2**(LL - 1) + FMR=FLOAT( LvR ) + ! + ! 3.c Calculate this level only if size is factor of LMN + IF( MOD(LMN, LvR) .EQ. 0 ) THEN + ! + ! 3.d Select cell and face ranges + icl=NLvCel(LL-1)+1 + iuf=NLvUFc(LL-1)+1 + ivf=NLvVFc(LL-1)+1 + jcl=NLvCel(LL) + juf=NLvUFc(LL) + jvf=NLvVFc(LL) + ! + ! Use 3rd order UNO3 scheme. JGLi03Sep2015 + IF( FUNO3 ) THEN + CALL SMCxUNO3(iuf, juf, CQ, UCFL, ULCFLX, DNND, FUMD, FUDIFX, FMR) ELSE + ! Call SMCxUNO2 to calculate finest level (size-1) MFx value + CALL SMCxUNO2(iuf, juf, CQ, UCFL, ULCFLX, DNND, FUMD, FUDIFX, FMR) + ENDIF + + ! Store fineset level conservative flux in FCNt advective one in AFCN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP Parallel DO Private(i, L, M, FUTRN) #endif - FCNt(M) = FCNt(M) + FUTRN*CTRNX(M) - ENDIF + DO i=iuf, juf + L=IJKUFc5(i) + M=IJKUFc6(i) + FUTRN = FUMD(i)*ULCFLX(i) - FUDIFX(i) + !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 + !! !$OMP CRITICAL + !! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 + IF( L > 0 ) THEN + !! Add sub-grid blocking for refined cells. JGLi18Apr2018 + IF( (CTRNX(M)+CTRNX(L)) .GE. 1.96 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - AFCN(M) = AFCN(M) + (FUMD(i)*UCFL(M)*FMR - FUDIFX(i)) - ENDIF -!! !$OMP END CRITICAL - ENDDO + FCNt(L) = FCNt(L) - FUTRN + ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP ATOMIC #endif - -! Store conservative update in CQA and advective update in CQ -! The side length in MF value has to be cancelled with cell y-length. -! Also divided by another cell x-size as UCFL is in size-1 unit. + FCNt(L) = FCNt(L) - FUTRN*CTRNX(L) + ELSE #ifdef W3_OMPG -!$OMP Parallel DO Private(n) + !$OMP ATOMIC #endif - DO n=icl, jcl - CQA(n)=CQ(n) + FCNt(n)/FLOAT( IJKCel3(n)*IJKCel4(n) ) - CQ (n)=CQ(n) + AFCN(n)/FLOAT( IJKCel3(n)*IJKCel4(n) ) - FCNt(n)=0.0 - AFCN(n)=0.0 - ENDDO + FCNt(L) = FCNt(L) - FUTRN*CTRNX(L)*CTRNX(M) + ENDIF #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP ATOMIC #endif -! -! Use 3rd order UNO3 scheme. JGLi03Sep2015 - IF( FUNO3 ) THEN - CALL SMCyUNO3(ivf, jvf, CQ, VCFL, VLCFLY, DSSD, FVMD, FVDIFY, FMR) - ELSE -! Call SMCyUNO2 to calculate MFy value - CALL SMCyUNO2(ivf, jvf, CQ, VCFL, VLCFLY, DSSD, FVMD, FVDIFY, FMR) - ENDIF -! -! Store conservative flux in BCNt + ! ChrisB: Re-arranged the RHS term below to make it + ! valid for OMP ATMOIC directive. + AFCN(L) = AFCN(L) - (FUMD(i)*UCFL(L)*FMR - FUDIFX(i)) + ENDIF + IF( M > 0 ) THEN + !! Add sub-grid blocking for refined cells. JGLi18Apr2018 + IF( (CTRNX(M)+CTRNX(L)) .GE. 1.96 ) THEN #ifdef W3_OMPG -!$OMP Parallel DO Private(j, L, M, FVTRN) + !$OMP ATOMIC #endif - DO j=ivf, jvf - L=IJKVFc5(j) - M=IJKVFc6(j) - FVTRN = FVMD(j)*VLCFLY(j) - FVDIFY(j) -!! Replace CRITICAL with ATOMIC. JGLi15Jan2019 -!! !$OMP CRITICAL -!! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 - IF( L > 0 ) THEN -!! Add sub-grid blocking for refined cells. JGLi18Apr2018 - IF( (CTRNY(M)+CTRNY(L)) .GE. 1.96 ) THEN + FCNt(M) = FCNt(M) + FUTRN + ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - BCNt(L) = BCNt(L) - FVTRN - ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN + FCNt(M) = FCNt(M) + FUTRN*CTRNX(M)*CTRNX(L) + ELSE #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - BCNt(L) = BCNt(L) - FVTRN*CTRNY(L) - ELSE + FCNt(M) = FCNt(M) + FUTRN*CTRNX(M) + ENDIF #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - BCNt(L) = BCNt(L) - FVTRN*CTRNY(L)*CTRNY(M) - ENDIF - ENDIF - IF( M > 0 ) THEN -!! Add sub-grid blocking for refined cells. JGLi18Apr2018 - IF( (CTRNY(M)+CTRNY(L)) .GE. 1.96 ) THEN + AFCN(M) = AFCN(M) + (FUMD(i)*UCFL(M)*FMR - FUDIFX(i)) + ENDIF + !! !$OMP END CRITICAL + ENDDO #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP END Parallel DO #endif - BCNt(M) = BCNt(M) + FVTRN - ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN + + ! Store conservative update in CQA and advective update in CQ + ! The side length in MF value has to be cancelled with cell y-length. + ! Also divided by another cell x-size as UCFL is in size-1 unit. #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP Parallel DO Private(n) #endif - BCNt(M) = BCNt(M) + FVTRN*CTRNY(M)*CTRNY(L) - ELSE + DO n=icl, jcl + CQA(n)=CQ(n) + FCNt(n)/FLOAT( IJKCel3(n)*IJKCel4(n) ) + CQ (n)=CQ(n) + AFCN(n)/FLOAT( IJKCel3(n)*IJKCel4(n) ) + FCNt(n)=0.0 + AFCN(n)=0.0 + ENDDO #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP END Parallel DO #endif - BCNt(M) = BCNt(M) + FVTRN*CTRNY(M) + ! + ! Use 3rd order UNO3 scheme. JGLi03Sep2015 + IF( FUNO3 ) THEN + CALL SMCyUNO3(ivf, jvf, CQ, VCFL, VLCFLY, DSSD, FVMD, FVDIFY, FMR) + ELSE + ! Call SMCyUNO2 to calculate MFy value + CALL SMCyUNO2(ivf, jvf, CQ, VCFL, VLCFLY, DSSD, FVMD, FVDIFY, FMR) ENDIF - ENDIF -!! !$OMP END CRITICAL - ENDDO -#ifdef W3_OMPG -!$OMP END Parallel DO -#endif - -! Store conservative update of CQA in CQ -! The v side length in MF value has to be cancelled with x-size. -! Also divided by cell y-size as VCFL is in size-1 unit. -!! One cosine factor is also needed to be divided for SMC grid. -#ifdef W3_OMPG -!$OMP Parallel DO Private(n) -#endif - DO n=icl, jcl - CQ(n)=CQA(n) + BCNt(n)/( CLATS(n)* & - & FLOAT( IJKCel3(n)*IJKCel4(n) ) ) - BCNt(n)=0.0 - ENDDO -#ifdef W3_OMPG -!$OMP END Parallel DO -#endif -!Li Polar cell needs a special area factor, multi-level case. - IF( ARCTC .AND. jcl .EQ. NSEA ) THEN - CQ(NSEA) = CQA(NSEA) + BCNt(NSEA)*PCArea - ENDIF -! -! End of refine level if block MOD(LMN, LvR) .EQ. 0 - ENDIF - -! End of refine level loop LL=1, NRLv - ENDDO -!! -!! END of multi-resolution sub-step loop LMN = 1, MRFct - ENDDO - -! End of multi-resolution advection ELSE block of NRLv > 1 - ENDIF - -!! Update boundary spectra if any. JGLi26Feb2016 -! - IF ( FLBPI ) THEN - RD1 = DSEC21(TBPI0, TIME)-DTG*REAL(NTLOC-ITLOC)/REAL(NTLOC) - RD2 = DSEC21(TBPI0, TBPIN) - IF ( RD2 .GT. 0.001 ) THEN - RD2 = MIN(1.,MAX(0.,RD1/RD2)) - RD1 = 1. - RD2 - ELSE - RD1 = 0. - RD2 = 1. - END IF - DO IBI=1, NBI - ISEA = ISBPI(IBI) - CQ(ISEA) = (RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI)) & - /CG(IK,ISEA) - END DO - ENDIF -! -!! End of ITLOC DO - ENDDO - -! Average with 1-2-1 scheme. JGLi20Aug2015 - IF(FVERG) CALL SMCAverg(CQ) - -! -! 4. Store results in VQ in proper format --------------------------- * -! -#ifdef W3_OMPG -!$OMP Parallel DO Private(ISEA) + ! + ! Store conservative flux in BCNt +#ifdef W3_OMPG + !$OMP Parallel DO Private(j, L, M, FVTRN) #endif - DO ISEA=1, NSEA - VQ(ISEA) = MAX ( 0. , CQ(ISEA)*CG(IK,ISEA) ) - END DO + DO j=ivf, jvf + L=IJKVFc5(j) + M=IJKVFc6(j) + FVTRN = FVMD(j)*VLCFLY(j) - FVDIFY(j) + !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 + !! !$OMP CRITICAL + !! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 + IF( L > 0 ) THEN + !! Add sub-grid blocking for refined cells. JGLi18Apr2018 + IF( (CTRNY(M)+CTRNY(L)) .GE. 1.96 ) THEN #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP ATOMIC #endif -! - RETURN -! -! Formats -! -#ifdef W3_T - 9001 FORMAT (' TEST W3PSMC : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) - 9003 FORMAT (' TEST W3PSMC : NO DISPERSION CORRECTION ') + BCNt(L) = BCNt(L) - FVTRN + ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN +#ifdef W3_OMPG + !$OMP ATOMIC #endif -! -#ifdef W3_T - 9010 FORMAT (' TEST W3PSMC : INITIALIZE ARRAYS') + BCNt(L) = BCNt(L) - FVTRN*CTRNY(L) + ELSE +#ifdef W3_OMPG + !$OMP ATOMIC #endif -! -#ifdef W3_T - 9020 FORMAT (' TEST W3PSMC : CALCULATING LCFLX/Y AND DSS/NN (NSEA=', & - I6,')') + BCNt(L) = BCNt(L) - FVTRN*CTRNY(L)*CTRNY(M) + ENDIF + ENDIF + IF( M > 0 ) THEN + !! Add sub-grid blocking for refined cells. JGLi18Apr2018 + IF( (CTRNY(M)+CTRNY(L)) .GE. 1.96 ) THEN +#ifdef W3_OMPG + !$OMP ATOMIC #endif -#ifdef W3_T1 - 9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) + BCNt(M) = BCNt(M) + FVTRN + ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN +#ifdef W3_OMPG + !$OMP ATOMIC #endif -#ifdef W3_T - 9022 FORMAT (' TEST W3PSMC : CORRECTING FOR CURRENT') + BCNt(M) = BCNt(M) + FVTRN*CTRNY(M)*CTRNY(L) + ELSE +#ifdef W3_OMPG + !$OMP ATOMIC #endif -! -#ifdef W3_T - 9040 FORMAT (' TEST W3PSMC : FIELD AFTER PROP. (NSEA=',I6,')') + BCNt(M) = BCNt(M) + FVTRN*CTRNY(M) + ENDIF + ENDIF + !! !$OMP END CRITICAL + ENDDO +#ifdef W3_OMPG + !$OMP END Parallel DO #endif -#ifdef W3_T2 - 9041 FORMAT (1X,I6,2I5,E12.4) + + ! Store conservative update of CQA in CQ + ! The v side length in MF value has to be cancelled with x-size. + ! Also divided by cell y-size as VCFL is in size-1 unit. + !! One cosine factor is also needed to be divided for SMC grid. +#ifdef W3_OMPG + !$OMP Parallel DO Private(n) #endif -!/ -!/ End of W3PSMC ----------------------------------------------------- / -!/ - END SUBROUTINE W3PSMC -!/ -!/ ------------------------------------------------------------------- / -!> @brief Refraction and great-circle turning by spectral rotation -!> -!> @details Linear interpolation equivalent to 1st order upstream scheme -!> but without restriction on rotation angle. However, refraction -!> is limited towards the depth gradient direction (< 90 degree). -!> Refraction induced spectral shift in the k-space will remain -!> to be advected using the UNO2 scheme. -!> -!> @param[in] ISEA Number of sea point -!> @param[in] FACTH Factor in propagation velocity (th) -!> @param[in] FACK Factor in propagation velocity (k) -!> @param[in] CTHG0 Factor in great circle refraction term -!> @param[in] CG Local group velocities -!> @param[in] WN Local wavenumbers -!> @param[in] DEPTH Depth -!> @param[in] DDDX Depth x-gradient -!> @param[in] DDDY Depth y-gradient -!> @param[in] ALFLMT Refraction limiter -!> @param[in] CX Current x-component -!> @param[in] CY Current y-component -!> @param[in] DCXDX Current gradient (dCX/dX) -!> @param[in] DCXDY Current gradient (dCX/dY) -!> @param[in] DCYDX Current gradient (dCY/dX) -!> @param[in] DCYDY Current gradient (dCY/dY) -!> @param[in] DCDX Phase speed x-gradient -!> @param[in] DCDY Phase speed y-gradient -!> @param[inout] VA Spectrum -!> -!> @author Jian-Guo Li -!> @date 06-Jun-2018 -!> - SUBROUTINE W3KRTN ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & - DDDX, DDDY, ALFLMT, CX, CY, DCXDX, DCXDY, & - DCYDX, DCYDY, DCDX, DCDY, VA ) -!/ -!/ +------------------------------------+ -!/ | Spherical Multiple-Cell (SMC) grid | -!/ | Refraction and great-cirle turning | -!/ | Jian-Guo Li | -!/ | First created: 8 Nov 2010 | -!/ | Last modified: 06-Jun-2018 | -!/ +------------------------------------+ -!/ -!/ 08-Nov-2010 : Origination. ( version 1.00 ) -!/ 10-Jun-2011 : New refraction formulation. ( version 1.10 ) -!/ 16-Jun-2011 : Add refraction limiter to gradient. ( version 1.20 ) -!/ 21-Jul-2011 : Old refraction formula + limiter. ( version 1.30 ) -!/ 26-Jul-2011 : Tidy up refraction schemes. ( version 1.40 ) -!/ 28-Jul-2011 : Finalise with old refraction. ( version 1.50 ) -!/ 23-Mar-2016 : Add current option in refraction. ( version 2.30 ) -!/ 06-Jun-2018 : Add DEBUGDCXDX ( version 6.04 ) -!/ -!/ -! 1. Purpose : -! -! Refraction and great-circle turning by spectral rotation. -! -! 2. Method : -! -! Linear interpolation equivalent to 1st order upstream scheme -! but without restriction on rotation angle. However, refraction -! is limited towards the depth gradient direction (< 90 degree). -! Refraction induced spectral shift in the k-space will remain -! to be advected using the UNO2 scheme. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISEA Int. I Number of sea point. -! FACTH/K Real I Factor in propagation velocity. -! CTHG0 Real I Factor in great circle refracftion term. -! MAPxx2 I.A. I Propagation and storage maps. -! CG R.A. I Local group velocities. -! WN R.A. I Local wavenumbers. -! DEPTH R.A. I Depth. -! DDDx Real I Depth gradients. -! CX/Y Real I Current components. -! DCxDx Real I Current gradients. -! DCDx Real I Phase speed gradients. -! VA R.A. I/O Spectrum. -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! DPH2K R.A. 2*Depth*Wave_number_K -! SNH2K R.A. SINH(2*Depth*Wave_number_K) -! FDD, FDU, FGC, FCD, FCU -! R.A. Directionally varying part of depth, current and -! great-circle refraction terms and of consit. -! of Ck term. -! CFLT-K R.A. Propagation velocities of local fluxes. -! DB R.A. Wavenumber band widths at cell centers. -! DM R.A. Wavenumber band widths between cell centers and -! next cell center. -! Q R.A. Extracted spectrum -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! SMCGtCrfr Refraction and GCT rotation in theta. -! SMCkUNO2 Refraction shift in k-space by UNO2. -! STRACE Service routine. -! -! 5. Called by : -! -! W3WAVE Wave model routine. -! -! 6. Error messages : -! -! None. -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Preparations -! a Initialize arrays -! b Set constants and counters -! 2. Point preparations -! a Calculate SNH2K -! b Extract spectrum -! 3. Refraction velocities -! a Filter level depth reffraction. -! b Depth refratcion velocity. -! c Current refraction velocity. -! 4. Wavenumber shift velocities -! a Prepare directional arrays -! b Calcuate velocity. -! 5. Propagate. -! 6. Store results. -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FLCTH, FLCK, CTMAX, DTH - USE W3ADATMD, ONLY: ITIME - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, ONLY: NDSE, NDST -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + DO n=icl, jcl + CQ(n)=CQA(n) + BCNt(n)/( CLATS(n)* & + & FLOAT( IJKCel3(n)*IJKCel4(n) ) ) + BCNt(n)=0.0 + ENDDO +#ifdef W3_OMPG + !$OMP END Parallel DO #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISEA -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL, INTENT(IN) :: FACTH, FACK, CTHG0, CG(0:NK+1), & - WN(0:NK+1), DEPTH, DDDX, DDDY, & - ALFLMT(NTH), CX, CY, DCXDX, DCXDY, & - DCYDX, DCYDY, DCDX(0:NK+1), DCDY(0:NK+1) - REAL, INTENT(INOUT) :: VA(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK, ISP - REAL :: FGC, FKD, FKS, FRK(NK), FRG(NK), DDNorm(NTH), & - FKC(NTH), VQ(NSPEC), VCFLT(NSPEC), DEPTH30, & - DB(0:NK+1), DM(-1:NK+1), CFLK(NTH,0:NK), & -!Li For new refraction scheme using Cg. JGLi26Jul2011 -! DPH2K(0:NK+1), SNH2K(0:NK+1) -!Li For old refraction scheme using phase speed. JGLi26Jul2011 - SIGSNH(0:NK+1) -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3KRTN') -#endif -! -! 1. Preparation for point ------------------------------------------ * -! Array with partial derivative of sigma versus depth -!Li Use of minimum depth 30 m for refraction factor. JGLi12Feb2014 - DEPTH30=MAX(30.0, DEPTH) - - DO IK=0, NK+1 -!Li For old refraction scheme using phase speed. JGLi8Jun2011 -! DPH2K(IK) = 2.0*WN(IK)*DEPTH -! SNH2K(IK) = SINH( DPH2K(IK) ) -!Li For new refraction scheme using Cg. JGLi3Jun2011 -!! SIGSNH(IK) = SIG(IK)/SINH(2.0*WN(IK)*DEPTH) -!!AC Replacing SIGSINH with a delimiter to prevent the SINH value from -!!AC becoming significantly large. Right now set to a max around 1E21 -! SIGSNH(IK) = SIG(IK)/SINH(MIN(2.0*WN(IK)*DEPTH,50.0)) -!Li Refraction factor uses minimum depth of 30 m. JGLi12Feb2014 - SIGSNH(IK) = SIG(IK)/SINH(MIN(2.0*WN(IK)*DEPTH30,50.0)) - END DO -! -! 2. Extract spectrum without mapping -! - VQ = VA - -! 3. Refraction velocities ------------------------------------------ * -! -! - IF ( FLCTH ) THEN -! -! 3.a Set slope filter for depth refraction -! -!Li Lift theta-refraction limit and use new formulation. 25 Nov 2010 -!Li FACTH = DTG / DTH / REAL(NTLOC), CTHG0 = - TAN(DERA*Y) / RADIUS - FGC = FACTH * CTHG0 -! - DO IK=1, NK -!Li New refraction formulation using Cg only. JGLi3Jun2011 -! FRK(IK) = FACTH*2.0*SIG(IK)*(1.-DEPTH*SIG(IK)*SIG(IK)/GRAV) & -! & /(DPH2K(IK)+SNH2K(IK)) -!Li Old refraction formulation using phase speed. JGLi8Jun2011 - FRK(IK) = FACTH * SIGSNH(IK) -!Li - FRG(IK) = FGC * CG(IK) - END DO -! -!Li Current induced refraction stored in FKC. JGLi30Mar2016 - IF ( FLCUR ) THEN - DO ITH=1, NTH -!Li Put a CTMAX limit on current theta rotation. JGLi02Mar2017 -! FKC(ITH) = FACTH*( DCYDX*ES2(ITH) - DCXDY*EC2(ITH) + & - FGC = FACTH*( DCYDX*ES2(ITH) - DCXDY*EC2(ITH) + & - (DCXDX - DCYDY)*ESC(ITH) ) - FKC(ITH) = SIGN( MIN(ABS(FGC), CTMAX), FGC ) - END DO - ELSE - FKC(:)=0.0 - END IF -! -! 3.b Depth refraction and great-circle turning. -! - DO ITH=1, NTH - DDNorm(ITH)=ESIN(ITH)*DDDX-ECOS(ITH)*DDDY - DO IK=1, NK - ISP = (IK-1)*NTH + ITH -!Li Apply depth gradient limited refraction, current and GCT term - VCFLT(ISP)=FRG(IK)*ECOS(ITH) + FKC(ITH) + & - SIGN( MIN(ABS(FRK(IK)*DDNorm(ITH)), ALFLMT(ITH)), & -!Li For new refraction scheme using Cg. JGLi26Jul2011 -! FRK(IK)*DDNorm(ITH) ) -!Li For old refraction scheme using phase speed. JGLi26Jul2011 - DDNorm(ITH) ) - END DO - END DO - - END IF -! -! 4. Wavenumber shift velocities due to current refraction ---------- * -! - IF ( FLCK ) THEN -! -! 4.a Directionally dependent part -! - DO ITH=1, NTH -!Li Depth induced refraction is suspended as it is absorbed in -!Li the fixed frequency bin used for wave spectrum. JGLi30Mar2016 -! FKC(ITH) = ( ECOS(ITH)*DDDX + ESIN(ITH)*DDDY ) - FKC(ITH) = -DCXDX*EC2(ITH) -DCYDY*ES2(ITH) & - -(DCXDY + DCYDX)*ESC(ITH) - END DO - FKD = CX*DDDX + CY*DDDY -! -! 4.b Band widths -! -!Li Cell and side indices for k-dimension are arranged as -! Cell: | -1 | 0 | 1 | 2 | ... | NK | NK+1 | NK+2 | -! Side: -1 0 1 2 ... NK NK+1 -!Li DSIP = SIG(K+1) - SIG(K), radian frequency increment -! - DO IK=0, NK - DB(IK) = DSIP(IK) / CG(IK) - DM(IK) = WN(IK+1) - WN(IK) - END DO - DB(NK+1) = DSIP(NK+1) / CG(NK+1) - DM(NK+1) = DM(NK) - DM( -1) = DM( 0) - -! 4.c Courant number of k-velocity without dividing by dk -!!Li FACK = DTG / REAL(NTLOC) -! - DO IK=0, NK -!Li For new refraction scheme using Cg. JGLi3Jun2011 -! FKS = - FACK*WN(IK)*SIG(IK)/SNH2K(IK) -!Li Old refraction formulation using phase speed. JGLi8Jun2011 -! FKS = - FACK*WN(IK)*SIGSNH(IK) -!Li Current induced k-shift. JGLi30Mar2016 - FKS = MAX( 0.0, CG(IK)*WN(IK)-0.5*SIG(IK) )*FKD / & - ( DEPTH30*CG(IK) ) - DO ITH=1, NTH - CFLK(ITH,IK) = FACK*( FKS + FKC(ITH)*WN(IK) ) - END DO - END DO -!Li No CFL limiter is required here as it is applied in SMCkUNO2. -! - END IF -! -! 5. Propagate ------------------------------------------------------ * -! - IF ( MOD(ITIME,2) .EQ. 0 ) THEN - IF ( FLCK ) THEN -!!Li Refraction caused k-space shift. - CALL SMCkUNO2(CFLK, VQ, DB, DM) - END IF - IF ( FLCTH ) THEN -!!Li GCT and refraction by rotation in theta direction. - CALL SMCGtCrfr(VCFLT, VQ) - END IF - ELSE - IF ( FLCTH ) THEN -!!Li GCT and refraction by rotation in theta direction. - CALL SMCGtCrfr(VCFLT, VQ) - END IF - IF ( FLCK ) THEN -!!Li Refraction caused k-space shift. - CALL SMCkUNO2(CFLK, VQ, DB, DM) - END IF - END IF -! -! 6. Store reults --------------------------------------------------- * -! - VA = VQ -! - RETURN -! -!/ End of W3KRTN ----------------------------------------------------- / -!/ - END SUBROUTINE W3KRTN - - -!> @brief Calculate mid-flux values for x dimension -!> -!> @param[in] NUA Start number of U-face list. -!> @param[in] NUB End number of U-face list. -!> @param[in] CF Transported variable. -!> @param[in] UC Veclocity U-component at cell centre. -!> @param[out] UFLX Mid-flux U-component on U-face. -!> @param[in] AKDif Diffusion coefficient. -!> @param[out] FU Advection Mid-flux on U-face. -!> @param[out] FX Diffusion Mid-flux on U-face. -!> @param[in] FTS Timestep fraction for sub-timestep. -!> -!> @author Jian-Guo Li -!> @date 03-Mar-2022 -!> -! Subroutine that calculate mid-flux values for x dimension - SUBROUTINE SMCxUNO2(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX, FTS) + !Li Polar cell needs a special area factor, multi-level case. + IF( ARCTC .AND. jcl .EQ. NSEA ) THEN + CQ(NSEA) = CQA(NSEA) + BCNt(NSEA)*PCArea + ENDIF + ! + ! End of refine level if block MOD(LMN, LvR) .EQ. 0 + ENDIF - USE CONSTANTS - USE W3GDATMD, ONLY: NCel, MRFct, NUFc, IJKCel, IJKUFc, CLATS, & - IJKCel3, IJKCel4 - USE W3ODATMD, ONLY: NDSE, NDST + ! End of refine level loop LL=1, NRLv + ENDDO + !! + !! END of multi-resolution sub-step loop LMN = 1, MRFct + ENDDO - IMPLICIT NONE - INTEGER, INTENT( IN):: NUA, NUB - REAL, INTENT( IN):: CF(-9:NCel), UC(-9:NCel), AKDif, FTS - REAL, INTENT(Out):: UFLX(NUFc), FU(NUFc), FX(NUFc) -! - INTEGER :: i, j, k, L, M, N, ij - REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, CNST8, CNST9 + ! End of multi-resolution advection ELSE block of NRLv > 1 + ENDIF -! Two layer of boundary cells are added to each boundary cell face -! with all boundary cell values CF(-9:0)=0.0. + !! Update boundary spectra if any. JGLi26Feb2016 + ! + IF ( FLBPI ) THEN + RD1 = DSEC21(TBPI0, TIME)-DTG*REAL(NTLOC-ITLOC)/REAL(NTLOC) + RD2 = DSEC21(TBPI0, TBPIN) + IF ( RD2 .GT. 0.001 ) THEN + RD2 = MIN(1.,MAX(0.,RD1/RD2)) + RD1 = 1. - RD2 + ELSE + RD1 = 0. + RD2 = 1. + END IF + DO IBI=1, NBI + ISEA = ISBPI(IBI) + CQ(ISEA) = (RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI)) & + /CG(IK,ISEA) + END DO + ENDIF + ! + !! End of ITLOC DO + ENDDO -! Diffusion Fourier no. at sub-time-step, proportional to face size, -! which is also equal to the sub-time-step factor FTS. - CNST0=AKDif*FTS*FTS -! Uniform diffusion coefficient for all sizes. JGLi24Feb2012 -! CNST0=AKDif*MRFct*FTS + ! Average with 1-2-1 scheme. JGLi20Aug2015 + IF(FVERG) CALL SMCAverg(CQ) + ! + ! 4. Store results in VQ in proper format --------------------------- * + ! #ifdef W3_OMPG -!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & -!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST8,CNST9) + !$OMP Parallel DO Private(ISEA) #endif - -! Notice an extra side length L is multiplied to mid-flux to give correct -! proportion of flux into the cells. This length will be removed by the -! cell length when the tracer concentration is updated. - + DO ISEA=1, NSEA + VQ(ISEA) = MAX ( 0. , CQ(ISEA)*CG(IK,ISEA) ) + END DO #ifdef W3_OMPG -!$OMP DO + !$OMP END Parallel DO #endif + ! + RETURN + ! + ! Formats + ! +#ifdef W3_T +9001 FORMAT (' TEST W3PSMC : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) +9003 FORMAT (' TEST W3PSMC : NO DISPERSION CORRECTION ') +9010 FORMAT (' TEST W3PSMC : INITIALIZE ARRAYS') +9020 FORMAT (' TEST W3PSMC : CALCULATING LCFLX/Y AND DSS/NN (NSEA=', & + I6,')') +#endif +#ifdef W3_T1 +9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) +#endif +#ifdef W3_T +9022 FORMAT (' TEST W3PSMC : CORRECTING FOR CURRENT') +9040 FORMAT (' TEST W3PSMC : FIELD AFTER PROP. (NSEA=',I6,')') +#endif +#ifdef W3_T2 +9041 FORMAT (1X,I6,2I5,E12.4) +#endif + !/ + !/ End of W3PSMC ----------------------------------------------------- / + !/ + END SUBROUTINE W3PSMC + !/ + !/ ------------------------------------------------------------------- / + !> @brief Refraction and great-circle turning by spectral rotation + !> + !> @details Linear interpolation equivalent to 1st order upstream scheme + !> but without restriction on rotation angle. However, refraction + !> is limited towards the depth gradient direction (< 90 degree). + !> Refraction induced spectral shift in the k-space will remain + !> to be advected using the UNO2 scheme. + !> + !> @param[in] ISEA Number of sea point + !> @param[in] FACTH Factor in propagation velocity (th) + !> @param[in] FACK Factor in propagation velocity (k) + !> @param[in] CTHG0 Factor in great circle refraction term + !> @param[in] CG Local group velocities + !> @param[in] WN Local wavenumbers + !> @param[in] DEPTH Depth + !> @param[in] DDDX Depth x-gradient + !> @param[in] DDDY Depth y-gradient + !> @param[in] ALFLMT Refraction limiter + !> @param[in] CX Current x-component + !> @param[in] CY Current y-component + !> @param[in] DCXDX Current gradient (dCX/dX) + !> @param[in] DCXDY Current gradient (dCX/dY) + !> @param[in] DCYDX Current gradient (dCY/dX) + !> @param[in] DCYDY Current gradient (dCY/dY) + !> @param[in] DCDX Phase speed x-gradient + !> @param[in] DCDY Phase speed y-gradient + !> @param[inout] VA Spectrum + !> + !> @author Jian-Guo Li + !> @date 06-Jun-2018 + !> + SUBROUTINE W3KRTN ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & + DDDX, DDDY, ALFLMT, CX, CY, DCXDX, DCXDY, & + DCYDX, DCYDY, DCDX, DCDY, VA ) + !/ + !/ +------------------------------------+ + !/ | Spherical Multiple-Cell (SMC) grid | + !/ | Refraction and great-cirle turning | + !/ | Jian-Guo Li | + !/ | First created: 8 Nov 2010 | + !/ | Last modified: 06-Jun-2018 | + !/ +------------------------------------+ + !/ + !/ 08-Nov-2010 : Origination. ( version 1.00 ) + !/ 10-Jun-2011 : New refraction formulation. ( version 1.10 ) + !/ 16-Jun-2011 : Add refraction limiter to gradient. ( version 1.20 ) + !/ 21-Jul-2011 : Old refraction formula + limiter. ( version 1.30 ) + !/ 26-Jul-2011 : Tidy up refraction schemes. ( version 1.40 ) + !/ 28-Jul-2011 : Finalise with old refraction. ( version 1.50 ) + !/ 23-Mar-2016 : Add current option in refraction. ( version 2.30 ) + !/ 06-Jun-2018 : Add DEBUGDCXDX ( version 6.04 ) + !/ + !/ + ! 1. Purpose : + ! + ! Refraction and great-circle turning by spectral rotation. + ! + ! 2. Method : + ! + ! Linear interpolation equivalent to 1st order upstream scheme + ! but without restriction on rotation angle. However, refraction + ! is limited towards the depth gradient direction (< 90 degree). + ! Refraction induced spectral shift in the k-space will remain + ! to be advected using the UNO2 scheme. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISEA Int. I Number of sea point. + ! FACTH/K Real I Factor in propagation velocity. + ! CTHG0 Real I Factor in great circle refracftion term. + ! MAPxx2 I.A. I Propagation and storage maps. + ! CG R.A. I Local group velocities. + ! WN R.A. I Local wavenumbers. + ! DEPTH R.A. I Depth. + ! DDDx Real I Depth gradients. + ! CX/Y Real I Current components. + ! DCxDx Real I Current gradients. + ! DCDx Real I Phase speed gradients. + ! VA R.A. I/O Spectrum. + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! DPH2K R.A. 2*Depth*Wave_number_K + ! SNH2K R.A. SINH(2*Depth*Wave_number_K) + ! FDD, FDU, FGC, FCD, FCU + ! R.A. Directionally varying part of depth, current and + ! great-circle refraction terms and of consit. + ! of Ck term. + ! CFLT-K R.A. Propagation velocities of local fluxes. + ! DB R.A. Wavenumber band widths at cell centers. + ! DM R.A. Wavenumber band widths between cell centers and + ! next cell center. + ! Q R.A. Extracted spectrum + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! SMCGtCrfr Refraction and GCT rotation in theta. + ! SMCkUNO2 Refraction shift in k-space by UNO2. + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3WAVE Wave model routine. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Preparations + ! a Initialize arrays + ! b Set constants and counters + ! 2. Point preparations + ! a Calculate SNH2K + ! b Extract spectrum + ! 3. Refraction velocities + ! a Filter level depth reffraction. + ! b Depth refratcion velocity. + ! c Current refraction velocity. + ! 4. Wavenumber shift velocities + ! a Prepare directional arrays + ! b Calcuate velocity. + ! 5. Propagate. + ! 6. Store results. + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & + EC2, ESC, ES2, FLCTH, FLCK, CTMAX, DTH + USE W3ADATMD, ONLY: ITIME + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, ONLY: NDSE, NDST +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISEA +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + REAL, INTENT(IN) :: FACTH, FACK, CTHG0, CG(0:NK+1), & + WN(0:NK+1), DEPTH, DDDX, DDDY, & + ALFLMT(NTH), CX, CY, DCXDX, DCXDY, & + DCYDX, DCYDY, DCDX(0:NK+1), DCDY(0:NK+1) + REAL, INTENT(INOUT) :: VA(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK, ISP + REAL :: FGC, FKD, FKS, FRK(NK), FRG(NK), DDNorm(NTH), & + FKC(NTH), VQ(NSPEC), VCFLT(NSPEC), DEPTH30, & + DB(0:NK+1), DM(-1:NK+1), CFLK(NTH,0:NK), & + !Li For new refraction scheme using Cg. JGLi26Jul2011 + ! DPH2K(0:NK+1), SNH2K(0:NK+1) + !Li For old refraction scheme using phase speed. JGLi26Jul2011 + SIGSNH(0:NK+1) + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'W3KRTN') +#endif + ! + ! 1. Preparation for point ------------------------------------------ * + ! Array with partial derivative of sigma versus depth + !Li Use of minimum depth 30 m for refraction factor. JGLi12Feb2014 + DEPTH30=MAX(30.0, DEPTH) + + DO IK=0, NK+1 + !Li For old refraction scheme using phase speed. JGLi8Jun2011 + ! DPH2K(IK) = 2.0*WN(IK)*DEPTH + ! SNH2K(IK) = SINH( DPH2K(IK) ) + !Li For new refraction scheme using Cg. JGLi3Jun2011 + !! SIGSNH(IK) = SIG(IK)/SINH(2.0*WN(IK)*DEPTH) + !!AC Replacing SIGSINH with a delimiter to prevent the SINH value from + !!AC becoming significantly large. Right now set to a max around 1E21 + ! SIGSNH(IK) = SIG(IK)/SINH(MIN(2.0*WN(IK)*DEPTH,50.0)) + !Li Refraction factor uses minimum depth of 30 m. JGLi12Feb2014 + SIGSNH(IK) = SIG(IK)/SINH(MIN(2.0*WN(IK)*DEPTH30,50.0)) + END DO + ! + ! 2. Extract spectrum without mapping + ! + VQ = VA + + ! 3. Refraction velocities ------------------------------------------ * + ! + ! + IF ( FLCTH ) THEN + ! + ! 3.a Set slope filter for depth refraction + ! + !Li Lift theta-refraction limit and use new formulation. 25 Nov 2010 + !Li FACTH = DTG / DTH / REAL(NTLOC), CTHG0 = - TAN(DERA*Y) / RADIUS + FGC = FACTH * CTHG0 + ! + DO IK=1, NK + !Li New refraction formulation using Cg only. JGLi3Jun2011 + ! FRK(IK) = FACTH*2.0*SIG(IK)*(1.-DEPTH*SIG(IK)*SIG(IK)/GRAV) & + ! & /(DPH2K(IK)+SNH2K(IK)) + !Li Old refraction formulation using phase speed. JGLi8Jun2011 + FRK(IK) = FACTH * SIGSNH(IK) + !Li + FRG(IK) = FGC * CG(IK) + END DO + ! + !Li Current induced refraction stored in FKC. JGLi30Mar2016 + IF ( FLCUR ) THEN + DO ITH=1, NTH + !Li Put a CTMAX limit on current theta rotation. JGLi02Mar2017 + ! FKC(ITH) = FACTH*( DCYDX*ES2(ITH) - DCXDY*EC2(ITH) + & + FGC = FACTH*( DCYDX*ES2(ITH) - DCXDY*EC2(ITH) + & + (DCXDX - DCYDY)*ESC(ITH) ) + FKC(ITH) = SIGN( MIN(ABS(FGC), CTMAX), FGC ) + END DO + ELSE + FKC(:)=0.0 + END IF + ! + ! 3.b Depth refraction and great-circle turning. + ! + DO ITH=1, NTH + DDNorm(ITH)=ESIN(ITH)*DDDX-ECOS(ITH)*DDDY + DO IK=1, NK + ISP = (IK-1)*NTH + ITH + !Li Apply depth gradient limited refraction, current and GCT term + VCFLT(ISP)=FRG(IK)*ECOS(ITH) + FKC(ITH) + & + SIGN( MIN(ABS(FRK(IK)*DDNorm(ITH)), ALFLMT(ITH)), & + !Li For new refraction scheme using Cg. JGLi26Jul2011 + ! FRK(IK)*DDNorm(ITH) ) + !Li For old refraction scheme using phase speed. JGLi26Jul2011 + DDNorm(ITH) ) + END DO + END DO - DO i=NUA, NUB - -! Select Upstream, Central and Downstream cells - K=IJKUFc(4,i) - L=IJKUFc(5,i) - M=IJKUFc(6,i) - N=IJKUFc(7,i) + END IF + ! + ! 4. Wavenumber shift velocities due to current refraction ---------- * + ! + IF ( FLCK ) THEN + ! + ! 4.a Directionally dependent part + ! + DO ITH=1, NTH + !Li Depth induced refraction is suspended as it is absorbed in + !Li the fixed frequency bin used for wave spectrum. JGLi30Mar2016 + ! FKC(ITH) = ( ECOS(ITH)*DDDX + ESIN(ITH)*DDDY ) + FKC(ITH) = -DCXDX*EC2(ITH) -DCYDY*ES2(ITH) & + -(DCXDY + DCYDX)*ESC(ITH) + END DO + FKD = CX*DDDX + CY*DDDY + ! + ! 4.b Band widths + ! + !Li Cell and side indices for k-dimension are arranged as + ! Cell: | -1 | 0 | 1 | 2 | ... | NK | NK+1 | NK+2 | + ! Side: -1 0 1 2 ... NK NK+1 + !Li DSIP = SIG(K+1) - SIG(K), radian frequency increment + ! + DO IK=0, NK + DB(IK) = DSIP(IK) / CG(IK) + DM(IK) = WN(IK+1) - WN(IK) + END DO + DB(NK+1) = DSIP(NK+1) / CG(NK+1) + DM(NK+1) = DM(NK) + DM( -1) = DM( 0) + + ! 4.c Courant number of k-velocity without dividing by dk + !!Li FACK = DTG / REAL(NTLOC) + ! + DO IK=0, NK + !Li For new refraction scheme using Cg. JGLi3Jun2011 + ! FKS = - FACK*WN(IK)*SIG(IK)/SNH2K(IK) + !Li Old refraction formulation using phase speed. JGLi8Jun2011 + ! FKS = - FACK*WN(IK)*SIGSNH(IK) + !Li Current induced k-shift. JGLi30Mar2016 + FKS = MAX( 0.0, CG(IK)*WN(IK)-0.5*SIG(IK) )*FKD / & + ( DEPTH30*CG(IK) ) + DO ITH=1, NTH + CFLK(ITH,IK) = FACK*( FKS + FKC(ITH)*WN(IK) ) + END DO + END DO + !Li No CFL limiter is required here as it is applied in SMCkUNO2. + ! + END IF + ! + ! 5. Propagate ------------------------------------------------------ * + ! + IF ( MOD(ITIME,2) .EQ. 0 ) THEN + IF ( FLCK ) THEN + !!Li Refraction caused k-space shift. + CALL SMCkUNO2(CFLK, VQ, DB, DM) + END IF + IF ( FLCTH ) THEN + !!Li GCT and refraction by rotation in theta direction. + CALL SMCGtCrfr(VCFLT, VQ) + END IF + ELSE + IF ( FLCTH ) THEN + !!Li GCT and refraction by rotation in theta direction. + CALL SMCGtCrfr(VCFLT, VQ) + END IF + IF ( FLCK ) THEN + !!Li Refraction caused k-space shift. + CALL SMCkUNO2(CFLK, VQ, DB, DM) + END IF + END IF + ! + ! 6. Store reults --------------------------------------------------- * + ! + VA = VQ + ! + RETURN + ! + !/ End of W3KRTN ----------------------------------------------------- / + !/ + END SUBROUTINE W3KRTN + + + !> @brief Calculate mid-flux values for x dimension + !> + !> @param[in] NUA Start number of U-face list. + !> @param[in] NUB End number of U-face list. + !> @param[in] CF Transported variable. + !> @param[in] UC Veclocity U-component at cell centre. + !> @param[out] UFLX Mid-flux U-component on U-face. + !> @param[in] AKDif Diffusion coefficient. + !> @param[out] FU Advection Mid-flux on U-face. + !> @param[out] FX Diffusion Mid-flux on U-face. + !> @param[in] FTS Timestep fraction for sub-timestep. + !> + !> @author Jian-Guo Li + !> @date 03-Mar-2022 + !> + ! Subroutine that calculate mid-flux values for x dimension + SUBROUTINE SMCxUNO2(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX, FTS) + + USE CONSTANTS + USE W3GDATMD, ONLY: NCel, MRFct, NUFc, IJKCel, IJKUFc, CLATS, & + IJKCel3, IJKCel4 + USE W3ODATMD, ONLY: NDSE, NDST + + IMPLICIT NONE + INTEGER, INTENT( IN):: NUA, NUB + REAL, INTENT( IN):: CF(-9:NCel), UC(-9:NCel), AKDif, FTS + REAL, INTENT(Out):: UFLX(NUFc), FU(NUFc), FX(NUFc) + ! + INTEGER :: i, j, k, L, M, N, ij + REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, CNST8, CNST9 + + ! Two layer of boundary cells are added to each boundary cell face + ! with all boundary cell values CF(-9:0)=0.0. + + ! Diffusion Fourier no. at sub-time-step, proportional to face size, + ! which is also equal to the sub-time-step factor FTS. + CNST0=AKDif*FTS*FTS + ! Uniform diffusion coefficient for all sizes. JGLi24Feb2012 + ! CNST0=AKDif*MRFct*FTS + +#ifdef W3_OMPG + !$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & + !$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST8,CNST9) +#endif + + ! Notice an extra side length L is multiplied to mid-flux to give correct + ! proportion of flux into the cells. This length will be removed by the + ! cell length when the tracer concentration is updated. + +#ifdef W3_OMPG + !$OMP DO +#endif + + DO i=NUA, NUB + + ! Select Upstream, Central and Downstream cells + K=IJKUFc(4,i) + L=IJKUFc(5,i) + M=IJKUFc(6,i) + N=IJKUFc(7,i) + + ! Face bounding cell lengths and central gradient + CNST2=FLOAT( IJKCel3(L) ) + CNST3=FLOAT( IJKCel3(M) ) + CNST5=(CF(M)-CF(L))/( CNST2 + CNST3 ) + + ! Courant number in local size-1 cell, arithmetic average. + CNST6=0.5*( UC(L)+UC(M) )*FTS + UFLX(i) = CNST6 + + ! Multi-resolution SMC grid requires flux multiplied by face factor. + CNST8 = FLOAT( IJKUFc(3,i) ) + + ! Diffusion factor in local size-1 cell, plus the cosine factors. + ! 2.0 factor to cancel that in gradient CNST5. JGLi08Mar2012 + ! The maximum cell number is used to avoid the boundary cell number + ! in selection of the cosine factor. + ij= MAX(L, M) + CNST9 = 2.0/( CLATS( ij )*CLATS( ij ) ) + + ! For positive velocity case + IF(CNST6 >= 0.0) THEN + + ! Use central cell velocity for boundary flux. JGLi06Apr2011 + IF( M .LE. 0) UFLX(i) = UC(L)*FTS + + ! Upstream cell length and gradient, depending on UFLX sign. + CNST1=FLOAT( IJKCel3(K) ) + CNST4=(CF(L)-CF(K))/( CNST2 + CNST1 ) + + ! Use minimum gradient all region. + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + + ! Mid-flux value inside central cell + FU(i)=(CF(L) + CNST*(CNST2 - UFLX(i)))*CNST8 -! Face bounding cell lengths and central gradient - CNST2=FLOAT( IJKCel3(L) ) - CNST3=FLOAT( IJKCel3(M) ) - CNST5=(CF(M)-CF(L))/( CNST2 + CNST3 ) + ! For negative velocity case + ELSE -! Courant number in local size-1 cell, arithmetic average. - CNST6=0.5*( UC(L)+UC(M) )*FTS - UFLX(i) = CNST6 + ! Use central cell velocity for boundary flux. JGLi06Apr2011 + IF( L .LE. 0) UFLX(i) = UC(M)*FTS -! Multi-resolution SMC grid requires flux multiplied by face factor. - CNST8 = FLOAT( IJKUFc(3,i) ) + ! Upstream cell length and gradient, depending on UFLX sign. + CNST1=FLOAT( IJKCel3(N) ) + CNST4=(CF(N)-CF(M))/( CNST1 + CNST3 ) -! Diffusion factor in local size-1 cell, plus the cosine factors. -! 2.0 factor to cancel that in gradient CNST5. JGLi08Mar2012 -! The maximum cell number is used to avoid the boundary cell number -! in selection of the cosine factor. - ij= MAX(L, M) - CNST9 = 2.0/( CLATS( ij )*CLATS( ij ) ) + ! Use minimum gradient outside monotonic region. + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! For positive velocity case - IF(CNST6 >= 0.0) THEN + ! Mid-flux value inside central cell M + FU(i)=(CF(M) - CNST*(CNST3+UFLX(i)))*CNST8 -! Use central cell velocity for boundary flux. JGLi06Apr2011 - IF( M .LE. 0) UFLX(i) = UC(L)*FTS + ENDIF -! Upstream cell length and gradient, depending on UFLX sign. - CNST1=FLOAT( IJKCel3(K) ) - CNST4=(CF(L)-CF(K))/( CNST2 + CNST1 ) + ! Diffusion flux by face gradient x DT + FX(i)=CNST0*CNST5*CNST8*CNST9 + + END DO + +#ifdef W3_OMPG + !$OMP END DO + !$OMP END Parallel +#endif + + RETURN + END SUBROUTINE SMCxUNO2 + + + !> @brief Calculate mid-flux values for y dimension + !> + !> @param[in] NVA Start number of V-face list. + !> @param[in] NVB End number of V-face list. + !> @param[in] CF Transported variable. + !> @param[in] VC Veclocity V-component at cell centre. + !> @param[out] VFLY Mid-flux V-component on V-face. + !> @param[in] AKDif Diffusion coefficient. + !> @param[out] FV Advection Mid-flux on V-face. + !> @param[out] FY Diffusion Mid-flux on V-face. + !> @param[in] FTS Timestep fraction for sub-timestep. + !> + !> @author Jian-Guo Li + !> @date 03-Mar-2022 + !> + SUBROUTINE SMCyUNO2(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY, FTS) + + USE CONSTANTS + USE W3GDATMD, ONLY: NCel, MRFct, NVFc, IJKCel, IJKVFc, CLATF, IJKCel4 + USE W3ODATMD, ONLY: NDSE, NDST + + IMPLICIT NONE + INTEGER, INTENT( IN):: NVA, NVB + REAL, INTENT( IN):: CF(-9:NCel), VC(-9:NCel), AKDif, FTS + REAL, INTENT(Out):: VFLY(NVFc), FV(NVFc), FY(NVFc) + INTEGER :: i, j, k, L, M, N, ij + REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, CNST8 + + ! Notice an extra side length L is multiplied to mid-flux to give correct + ! proportion of flux into the cells. This length will be removed by the + ! cell length when the tracer concentration is updated. + + ! Diffusion Fourier no. at sub-time-step, proportional to face size, + ! which is also equal to the sub-time-step factor FTS. + ! CNST0=AKDif*FTS*FTS + ! 2.0 factor to cancel that in gradient CNST5. JGLi08Mar2012 + CNST0=AKDif*FTS*FTS*2.0 + ! Uniform diffusion coefficient for all sizes. JGLi24Feb2012 + ! CNST0=AKDif*MRFct*FTS + +#ifdef W3_OMPG + !$OMP Parallel Default(Shared), Private(j, K, L, M, N), & + !$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST8) + !$OMP DO +#endif + + DO j=NVA, NVB + + ! Select Upstream, Central and Downstream cells + K=IJKVFc(4,j) + L=IJKVFc(5,j) + M=IJKVFc(6,j) + N=IJKVFc(7,j) + + ! Face bounding cell lengths and gradient + CNST2=FLOAT( IJKCel4(L) ) + CNST3=FLOAT( IJKCel4(M) ) + CNST5=(CF(M)-CF(L))/( CNST2 + CNST3 ) + + ! Courant number in local size-1 cell unit + ! Multiply by multi-resolution time step factor FTS + CNST6=0.5*( VC(L)+VC(M) )*FTS + VFLY(j) = CNST6 + + ! Face size integer and cosine factor. + ! CLATF is defined on V-face for SMC grid. JGLi28Feb2012 + CNST8=CLATF(j)*FLOAT( IJKVFc(3,j) ) + + ! For positive velocity case + IF(CNST6 >= 0.0) THEN + + ! Boundary cell y-size is set equal to central cell y-size + ! as y-boundary cell sizes are not proportional to refined + ! inner cells but constant of the base cell y-size, and + ! Use central cell speed for face speed. JGLi06Apr2011 + IF( M .LE. 0 ) THEN + VFLY(j) = VC(L)*FTS + CNST3 = CNST2 + ENDIF -! Use minimum gradient all region. - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! Upstream cell size and irregular grid gradient, depending on VFLY. + CNST1=FLOAT( IJKCel4(K) ) + CNST4=(CF(L)-CF(K))/( CNST2 + CNST1 ) -! Mid-flux value inside central cell - FU(i)=(CF(L) + CNST*(CNST2 - UFLX(i)))*CNST8 + ! Use minimum gradient outside monotonic region + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! For negative velocity case - ELSE + ! Mid-flux value multiplied by face width and cosine factor + FV(j)=( CF(L) + CNST*(CNST2 - VFLY(j)) )*CNST8 -! Use central cell velocity for boundary flux. JGLi06Apr2011 - IF( L .LE. 0) UFLX(i) = UC(M)*FTS + ! For negative velocity case + ELSE -! Upstream cell length and gradient, depending on UFLX sign. - CNST1=FLOAT( IJKCel3(N) ) - CNST4=(CF(N)-CF(M))/( CNST1 + CNST3 ) + ! Set boundary cell y-size equal to central cell y-size and + ! Use central cell speed for flux face speed. JGLi06Apr2011 + IF( L .LE. 0 ) THEN + VFLY(j) = VC(M)*FTS + CNST2 = CNST3 + ENDIF -! Use minimum gradient outside monotonic region. - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! Upstream cell size and gradient, depending on VFLY sign. + ! Side gradients for central cell includs 0.5 factor. + CNST1=FLOAT( IJKCel4(N) ) + CNST4=(CF(N)-CF(M))/( CNST1 + CNST3 ) -! Mid-flux value inside central cell M - FU(i)=(CF(M) - CNST*(CNST3+UFLX(i)))*CNST8 + ! Use minimum gradient outside monotonic region + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) - ENDIF + ! Mid-flux value multiplied by face width and cosine factor + FV(j)=( CF(M) - CNST*(CNST3 + VFLY(j)) )*CNST8 -! Diffusion flux by face gradient x DT - FX(i)=CNST0*CNST5*CNST8*CNST9 + ENDIF - END DO + ! Diffusion flux by face gradient x DT x face_width x cos(lat) + ! Multiply by multi-resolution time step factor FTS + FY(j)=CNST0*CNST5*CNST8 -#ifdef W3_OMPG -!$OMP END DO -#endif + END DO #ifdef W3_OMPG -!$OMP END Parallel + !$OMP END DO + !$OMP END Parallel #endif -! 999 PRINT*, ' Sub SMCxUNO2 ended.' - - RETURN - END SUBROUTINE SMCxUNO2 - + RETURN + END SUBROUTINE SMCyUNO2 -!> @brief Calculate mid-flux values for y dimension -!> -!> @param[in] NVA Start number of V-face list. -!> @param[in] NVB End number of V-face list. -!> @param[in] CF Transported variable. -!> @param[in] VC Veclocity V-component at cell centre. -!> @param[out] VFLY Mid-flux V-component on V-face. -!> @param[in] AKDif Diffusion coefficient. -!> @param[out] FV Advection Mid-flux on V-face. -!> @param[out] FY Diffusion Mid-flux on V-face. -!> @param[in] FTS Timestep fraction for sub-timestep. -!> -!> @author Jian-Guo Li -!> @date 03-Mar-2022 -!> - SUBROUTINE SMCyUNO2(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY, FTS) - USE CONSTANTS - USE W3GDATMD, ONLY: NCel, MRFct, NVFc, IJKCel, IJKVFc, CLATF, IJKCel4 - USE W3ODATMD, ONLY: NDSE, NDST + !> @brief Calculate mid-flux values for x dimension + !> + !> @param[in] NUA Start number of U-face list. + !> @param[in] NUB End number of U-face list. + !> @param[in] CF Transported variable. + !> @param[in] UC Veclocity U-component at cell centre. + !> @param[out] UFLX Mid-flux U-component on U-face. + !> @param[in] AKDif Diffusion coefficient. + !> @param[out] FU Advection Mid-flux on U-face. + !> @param[out] FX Diffusion Mid-flux on U-face. + !> + !> @author Jian-Guo Li + !> @date 03-Mar-2022 + !> + SUBROUTINE SMCxUNO2r(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX) - IMPLICIT NONE - INTEGER, INTENT( IN):: NVA, NVB - REAL, INTENT( IN):: CF(-9:NCel), VC(-9:NCel), AKDif, FTS - REAL, INTENT(Out):: VFLY(NVFc), FV(NVFc), FY(NVFc) - INTEGER :: i, j, k, L, M, N, ij - REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, CNST8 + USE CONSTANTS + USE W3GDATMD, ONLY: NSEA, NY, NCel, NUFc, IJKCel, IJKUFc, CLATS + USE W3GDATMD, ONLY: IJKCel3 + USE W3ODATMD, ONLY: NDSE, NDST -! Notice an extra side length L is multiplied to mid-flux to give correct -! proportion of flux into the cells. This length will be removed by the -! cell length when the tracer concentration is updated. + IMPLICIT NONE + INTEGER, INTENT( IN):: NUA, NUB + REAL, INTENT( IN):: CF(-9:NCel), UC(-9:NCel), AKDif + REAL, INTENT(Out):: UFLX(NUFc), FU(NUFc), FX(NUFc) + ! + INTEGER :: i, j, k, L, M, N, ij + REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 -! Diffusion Fourier no. at sub-time-step, proportional to face size, -! which is also equal to the sub-time-step factor FTS. -! CNST0=AKDif*FTS*FTS -! 2.0 factor to cancel that in gradient CNST5. JGLi08Mar2012 - CNST0=AKDif*FTS*FTS*2.0 -! Uniform diffusion coefficient for all sizes. JGLi24Feb2012 -! CNST0=AKDif*MRFct*FTS + ! Two layer of boundary cells are added to each boundary cell face + ! with all boundary cell values CF(-9:0)=0.0. -#ifdef W3_OMPG -!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & -!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST8) -#endif + ! Notice an extra side length L is multiplied to mid-flux to give correct + ! proportion of flux into the cells. This length will be removed by the + ! cell length when the tracer concentration is updated. #ifdef W3_OMPG -!$OMP DO + !$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & + !$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6) + !$OMP DO #endif - DO j=NVA, NVB + DO i=NUA, NUB -! Select Upstream, Central and Downstream cells - K=IJKVFc(4,j) - L=IJKVFc(5,j) - M=IJKVFc(6,j) - N=IJKVFc(7,j) + ! Select Upstream, Central and Downstream cells + K=IJKUFc(4,i) + L=IJKUFc(5,i) + M=IJKUFc(6,i) + N=IJKUFc(7,i) -! Face bounding cell lengths and gradient - CNST2=FLOAT( IJKCel4(L) ) - CNST3=FLOAT( IJKCel4(M) ) - CNST5=(CF(M)-CF(L))/( CNST2 + CNST3 ) + ! Face bounding cell lengths and gradient + CNST2=FLOAT( IJKCel3(L) ) + CNST3=FLOAT( IJKCel3(M) ) + CNST5=(CF(M)-CF(L)) -! Courant number in local size-1 cell unit -! Multiply by multi-resolution time step factor FTS - CNST6=0.5*( VC(L)+VC(M) )*FTS - VFLY(j) = CNST6 + ! Averaged Courant number for base-level cell face + CNST6= 0.5*( UC(L)+UC(M) ) + UFLX(i) = CNST6 -! Face size integer and cosine factor. -! CLATF is defined on V-face for SMC grid. JGLi28Feb2012 - CNST8=CLATF(j)*FLOAT( IJKVFc(3,j) ) + ! Diffusion Fourier number in local cell size + ! To avoid boundary cell number, use maximum of L and M. + ij= MAX(L, M) + CNST0 = 2.0/( CLATS(ij)*CLATS(ij) ) -! For positive velocity case - IF(CNST6 >= 0.0) THEN + ! For positive velocity case + IF(CNST6 >= 0.0) THEN -! Boundary cell y-size is set equal to central cell y-size -! as y-boundary cell sizes are not proportional to refined -! inner cells but constant of the base cell y-size, and -! Use central cell speed for face speed. JGLi06Apr2011 - IF( M .LE. 0 ) THEN - VFLY(j) = VC(L)*FTS - CNST3 = CNST2 - ENDIF + ! Use central cell velocity for boundary flux. JGLi06Apr2011 + IF( M .LE. 0) UFLX(i) = UC(L) -! Upstream cell size and irregular grid gradient, depending on VFLY. - CNST1=FLOAT( IJKCel4(K) ) - CNST4=(CF(L)-CF(K))/( CNST2 + CNST1 ) + ! Side gradient for upstream cell as regular grid. + CNST4=(CF(L)-CF(K)) -! Use minimum gradient outside monotonic region - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! Use minimum gradient all region with 0.5 factor + CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! Mid-flux value multiplied by face width and cosine factor - FV(j)=( CF(L) + CNST*(CNST2 - VFLY(j)) )*CNST8 + ! Mid-flux value inside central cell + FU(i)=(CF(L) + CNST*(1.0-UFLX(i)/CNST2)) -! For negative velocity case - ELSE - -! Set boundary cell y-size equal to central cell y-size and -! Use central cell speed for flux face speed. JGLi06Apr2011 - IF( L .LE. 0 ) THEN - VFLY(j) = VC(M)*FTS - CNST2 = CNST3 - ENDIF + ! For negative velocity case + ELSE -! Upstream cell size and gradient, depending on VFLY sign. -! Side gradients for central cell includs 0.5 factor. - CNST1=FLOAT( IJKCel4(N) ) - CNST4=(CF(N)-CF(M))/( CNST1 + CNST3 ) + ! Use central cell velocity for boundary flux. JGLi06Apr2011 + IF( L .LE. 0) UFLX(i) = UC(M) -! Use minimum gradient outside monotonic region - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! Side gradient for upstream cell, depneding on UFLX sign. + CNST4=(CF(N)-CF(M)) -! Mid-flux value multiplied by face width and cosine factor - FV(j)=( CF(M) - CNST*(CNST3 + VFLY(j)) )*CNST8 + ! Use minimum gradient outside monotonic region, include 0.5 factor + CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) - ENDIF + ! Mid-flux value inside central cell M + FU(i)=(CF(M) - CNST*(1.0+UFLX(i)/CNST3)) -! Diffusion flux by face gradient x DT x face_width x cos(lat) -! Multiply by multi-resolution time step factor FTS - FY(j)=CNST0*CNST5*CNST8 + ENDIF - END DO + ! Diffusion flux by face gradient x DT + FX(i)=AKDif*CNST0*CNST5/(CNST2 + CNST3) -#ifdef W3_OMPG -!$OMP END DO -#endif + END DO #ifdef W3_OMPG -!$OMP END Parallel + !$OMP END DO + !$OMP END Parallel #endif -! 999 PRINT*, ' Sub SMCyUNO2 ended.' + RETURN + END SUBROUTINE SMCxUNO2r - RETURN - END SUBROUTINE SMCyUNO2 - - -!> @brief Calculate mid-flux values for x dimension -!> -!> @param[in] NUA Start number of U-face list. -!> @param[in] NUB End number of U-face list. -!> @param[in] CF Transported variable. -!> @param[in] UC Veclocity U-component at cell centre. -!> @param[out] UFLX Mid-flux U-component on U-face. -!> @param[in] AKDif Diffusion coefficient. -!> @param[out] FU Advection Mid-flux on U-face. -!> @param[out] FX Diffusion Mid-flux on U-face. -!> -!> @author Jian-Guo Li -!> @date 03-Mar-2022 -!> - SUBROUTINE SMCxUNO2r(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX) - USE CONSTANTS - USE W3GDATMD, ONLY: NSEA, NY, NCel, NUFc, IJKCel, IJKUFc, CLATS - USE W3GDATMD, ONLY: IJKCel3 - USE W3ODATMD, ONLY: NDSE, NDST + !> @brief Calculate mid-flux values for y dimension + !> + !> @param[in] NVA Start number of V-face list. + !> @param[in] NVB End number of V-face list. + !> @param[in] CF Transported variable. + !> @param[in] VC Veclocity V-component at cell centre. + !> @param[out] VFLY Mid-flux V-component on V-face. + !> @param[in] AKDif Diffusion coefficient. + !> @param[out] FV Advection Mid-flux on V-face. + !> @param[out] FY Diffusion Mid-flux on V-face. + !> + !> @author Jian-Guo Li + !> @date 03-Mar-2022 + !> + SUBROUTINE SMCyUNO2r(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY) - IMPLICIT NONE - INTEGER, INTENT( IN):: NUA, NUB - REAL, INTENT( IN):: CF(-9:NCel), UC(-9:NCel), AKDif - REAL, INTENT(Out):: UFLX(NUFc), FU(NUFc), FX(NUFc) -! - INTEGER :: i, j, k, L, M, N, ij - REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 + USE CONSTANTS + USE W3GDATMD, ONLY: NSEA, NY, NCel, NVFc, IJKCel, IJKVFc, CLATF + USE W3ODATMD, ONLY: NDSE, NDST -! Two layer of boundary cells are added to each boundary cell face -! with all boundary cell values CF(-9:0)=0.0. + IMPLICIT NONE + INTEGER, INTENT( IN):: NVA, NVB + REAL, INTENT( IN):: CF(-9:NCel), VC(-9:NCel), AKDif + REAL, INTENT(Out):: VFLY(NVFc), FV(NVFc), FY(NVFc) + INTEGER :: i, j, k, L, M, N, ij + REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, CNST8 -! Notice an extra side length L is multiplied to mid-flux to give correct -! proportion of flux into the cells. This length will be removed by the -! cell length when the tracer concentration is updated. + ! Notice an extra side length L is multiplied to mid-flux to give correct + ! proportion of flux into the cells. This length will be removed by the + ! cell length when the tracer concentration is updated. #ifdef W3_OMPG -!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & -!$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6) + !$OMP Parallel Default(Shared), Private(j, K, L, M, N), & + !$OMP& Private(CNST,CNST4,CNST5,CNST6,CNST8) + !$OMP DO #endif -#ifdef W3_OMPG -!$OMP DO -#endif + DO j=NVA, NVB - DO i=NUA, NUB + ! Select Upstream, Central and Downstream cells + K=IJKVFc(4,j) + L=IJKVFc(5,j) + M=IJKVFc(6,j) + N=IJKVFc(7,j) -! Select Upstream, Central and Downstream cells - K=IJKUFc(4,i) - L=IJKUFc(5,i) - M=IJKUFc(6,i) - N=IJKUFc(7,i) + ! Central face gradient. + CNST5=(CF(M)-CF(L)) -! Face bounding cell lengths and gradient - CNST2=FLOAT( IJKCel3(L) ) - CNST3=FLOAT( IJKCel3(M) ) - CNST5=(CF(M)-CF(L)) + ! Courant number in basic cell unit as dy is constant + CNST6=0.5*( VC(L)+VC(M) ) + VFLY(j) = CNST6 -! Averaged Courant number for base-level cell face - CNST6= 0.5*( UC(L)+UC(M) ) - UFLX(i) = CNST6 + ! Face size integer and cosine factor + ! CLATF is defined on V-face for SMC grid. JGLi28Feb2012 + CNST8=CLatF(j)*FLOAT( IJKVFc(3,j) ) -! Diffusion Fourier number in local cell size -! To avoid boundary cell number, use maximum of L and M. - ij= MAX(L, M) - CNST0 = 2.0/( CLATS(ij)*CLATS(ij) ) + ! For positive velocity case + IF(CNST6 >= 0.0) THEN -! For positive velocity case - IF(CNST6 >= 0.0) THEN + ! Use central cell speed for flux face speed. JGLi06Apr2011 + IF( M .LE. 0 ) VFLY(j) = VC(L) -! Use central cell velocity for boundary flux. JGLi06Apr2011 - IF( M .LE. 0) UFLX(i) = UC(L) + ! Upstream face gradient, depending on VFLY sign. + CNST4=(CF(L)-CF(K)) -! Side gradient for upstream cell as regular grid. - CNST4=(CF(L)-CF(K)) + ! Use minimum gradient, including 0.5 factor and central sign. + CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! Use minimum gradient all region with 0.5 factor - CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! Mid-flux value multiplied by face width and cosine factor + FV(j)=( CF(L) + CNST*(1.0-VFLY(j)) )*CNST8 -! Mid-flux value inside central cell - FU(i)=(CF(L) + CNST*(1.0-UFLX(i)/CNST2)) - -! For negative velocity case - ELSE + ! For negative velocity case + ELSE -! Use central cell velocity for boundary flux. JGLi06Apr2011 - IF( L .LE. 0) UFLX(i) = UC(M) + ! Use central cell speed for flux face speed. JGLi06Apr2011 + IF( L .LE. 0 ) VFLY(j) = VC(M) -! Side gradient for upstream cell, depneding on UFLX sign. - CNST4=(CF(N)-CF(M)) + ! Side gradients for upstream face, depending on VFLY sign. + CNST4=(CF(N)-CF(M)) -! Use minimum gradient outside monotonic region, include 0.5 factor - CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! Use minimum gradient, including 0.5 factor and central sign. + CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! Mid-flux value inside central cell M - FU(i)=(CF(M) - CNST*(1.0+UFLX(i)/CNST3)) + ! Mid-flux value multiplied by face width and cosine factor + FV(j)=( CF(M) - CNST*(1.0+VFLY(j)) )*CNST8 - ENDIF + ENDIF -! Diffusion flux by face gradient x DT - FX(i)=AKDif*CNST0*CNST5/(CNST2 + CNST3) + ! Diffusion flux by face gradient x DT x face_width x cos(lat) + FY(j)=AKDif*CNST5*CNST8 - END DO + END DO #ifdef W3_OMPG -!$OMP END DO + !$OMP END DO + !$OMP END Parallel #endif -#ifdef W3_OMPG -!$OMP END Parallel -#endif + RETURN + END SUBROUTINE SMCyUNO2r -! 999 PRINT*, ' Sub SMCxUNO2r ended.' - RETURN - END SUBROUTINE SMCxUNO2r + !> @brief Calculate mid-flux values for x dimension with UNO3 scheme + !> + !> @param[in] NUA Start number of U-face list. + !> @param[in] NUB End number of U-face list. + !> @param[in] CF Transported variable. + !> @param[in] UC Veclocity U-component at cell centre. + !> @param[out] UFLX Mid-flux U-component on U-face. + !> @param[in] AKDif Diffusion coefficient. + !> @param[out] FU Advection Mid-flux on U-face. + !> @param[out] FX Diffusion Mid-flux on U-face. + !> @param[in] FTS Timestep fraction for sub-timestep. + !> + !> @author Jian-Guo Li + !> @date 03-Mar-2022 + !> + SUBROUTINE SMCxUNO3(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX, FTS) + USE CONSTANTS + USE W3GDATMD, ONLY: NCel, MRFct, NUFc, IJKCel, IJKUFc, CLATS + USE W3GDATMD, ONLY: IJKCel3 + USE W3ODATMD, ONLY: NDSE, NDST -!> @brief Calculate mid-flux values for y dimension -!> -!> @param[in] NVA Start number of V-face list. -!> @param[in] NVB End number of V-face list. -!> @param[in] CF Transported variable. -!> @param[in] VC Veclocity V-component at cell centre. -!> @param[out] VFLY Mid-flux V-component on V-face. -!> @param[in] AKDif Diffusion coefficient. -!> @param[out] FV Advection Mid-flux on V-face. -!> @param[out] FY Diffusion Mid-flux on V-face. -!> -!> @author Jian-Guo Li -!> @date 03-Mar-2022 -!> - SUBROUTINE SMCyUNO2r(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY) + IMPLICIT NONE + INTEGER, INTENT( IN):: NUA, NUB + REAL, INTENT( IN):: CF(-9:NCel), UC(-9:NCel), AKDif, FTS + REAL, INTENT(Out):: UFLX(NUFc), FU(NUFc), FX(NUFc) + ! + INTEGER :: i, j, k, L, M, N, ij + REAL :: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, & + CNST7, CNST8, CNST9 - USE CONSTANTS - USE W3GDATMD, ONLY: NSEA, NY, NCel, NVFc, IJKCel, IJKVFc, CLATF - USE W3ODATMD, ONLY: NDSE, NDST + ! Two layer of boundary cells are added to each boundary cell face + ! with all boundary cell values CF(-9:0)=0.0. - IMPLICIT NONE - INTEGER, INTENT( IN):: NVA, NVB - REAL, INTENT( IN):: CF(-9:NCel), VC(-9:NCel), AKDif - REAL, INTENT(Out):: VFLY(NVFc), FV(NVFc), FY(NVFc) - INTEGER :: i, j, k, L, M, N, ij - REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, CNST8 + ! Diffusion Fourier no. at sub-time-step, proportional to face size, + ! which is also equal to the sub-time-step factor FTS. + ! CNST0=AKDif*FTS*FTS + ! 2.0 factor to cancel that in gradient CNST5. JGLi03Sep2015 + CNST0=AKDif*FTS*FTS*2.0 -! Notice an extra side length L is multiplied to mid-flux to give correct -! proportion of flux into the cells. This length will be removed by the -! cell length when the tracer concentration is updated. + ! Notice an extra side length L is multiplied to mid-flux to give correct + ! proportion of flux into the cells. This length will be removed by the + ! cell length when the tracer concentration is updated. #ifdef W3_OMPG -!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & -!$OMP& Private(CNST,CNST4,CNST5,CNST6,CNST8) + !$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & + !$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) + !$OMP DO #endif -#ifdef W3_OMPG -!$OMP DO -#endif + DO i=NUA, NUB - DO j=NVA, NVB + ! Select Upstream, Central and Downstream cells + K=IJKUFc(4,i) + L=IJKUFc(5,i) + M=IJKUFc(6,i) + N=IJKUFc(7,i) -! Select Upstream, Central and Downstream cells - K=IJKVFc(4,j) - L=IJKVFc(5,j) - M=IJKVFc(6,j) - N=IJKVFc(7,j) + ! Face bounding cell lengths and central gradient + CNST2=FLOAT( IJKCel3(L) ) + CNST3=FLOAT( IJKCel3(M) ) + CNST5=(CF(M)-CF(L))/( CNST2 + CNST3 ) -! Central face gradient. - CNST5=(CF(M)-CF(L)) + ! Courant number in local size-1 cell, arithmetic average. + CNST6=0.5*( UC(L)+UC(M) )*FTS + UFLX(i) = CNST6 -! Courant number in basic cell unit as dy is constant - CNST6=0.5*( VC(L)+VC(M) ) - VFLY(j) = CNST6 + ! Multi-resolution SMC grid requires flux multiplied by face factor. + CNST8 = FLOAT( IJKUFc(3,i) ) -! Face size integer and cosine factor -! CLATF is defined on V-face for SMC grid. JGLi28Feb2012 - CNST8=CLatF(j)*FLOAT( IJKVFc(3,j) ) + ! Diffusion factor in local size-1 cell, plus the cosine factors. + ! 2.0 factor to cancel that in gradient CNST5. JGLi08Mar2012 + ! The maximum cell number is used to avoid the boundary cell number + ! in selection of the cosine factor. + ij= MAX(L, M) -! For positive velocity case - IF(CNST6 >= 0.0) THEN + ! For positive velocity case + IF(CNST6 >= 0.0) THEN -! Use central cell speed for flux face speed. JGLi06Apr2011 - IF( M .LE. 0 ) VFLY(j) = VC(L) + ! Use central cell velocity for boundary flux. JGLi06Apr2011 + IF( M .LE. 0) UFLX(i) = UC(L)*FTS -! Upstream face gradient, depending on VFLY sign. - CNST4=(CF(L)-CF(K)) + ! Upstream cell length and gradient, depending on UFLX sign. + CNST1=FLOAT( IJKCel3(K) ) + CNST4=(CF(L)-CF(K))/( CNST2 + CNST1 ) -! Use minimum gradient, including 0.5 factor and central sign. - CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! Second order gradient + CNST7 = CNST5 - CNST4 + CNST9 = 2.0/( CNST3+CNST2+CNST2+CNST1 ) -! Mid-flux value multiplied by face width and cosine factor - FV(j)=( CF(L) + CNST*(1.0-VFLY(j)) )*CNST8 + ! Use 3rd order scheme + IF( Abs(CNST7) .LT. 0.6*CNST9*Abs(CF(M)-CF(K)) ) THEN + CNST= CNST5 - ( CNST3+UFLX(i) )*CNST7*CNST9/1.5 + + ! Use doubled UNO2 scheme + ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN + CNST=Sign(2.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! For negative velocity case - ELSE + ELSE + ! Use minimum gradient UNO2 scheme + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! Use central cell speed for flux face speed. JGLi06Apr2011 - IF( L .LE. 0 ) VFLY(j) = VC(M) + ENDIF -! Side gradients for upstream face, depending on VFLY sign. - CNST4=(CF(N)-CF(M)) + ! Mid-flux value inside central cell + FU(i)=(CF(L) + CNST*(CNST2 - UFLX(i)))*CNST8 -! Use minimum gradient, including 0.5 factor and central sign. - CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! For negative velocity case + ELSE -! Mid-flux value multiplied by face width and cosine factor - FV(j)=( CF(M) - CNST*(1.0+VFLY(j)) )*CNST8 + ! Use central cell velocity for boundary flux. JGLi06Apr2011 + IF( L .LE. 0) UFLX(i) = UC(M)*FTS - ENDIF + ! Upstream cell length and gradient, depending on UFLX sign. + CNST1=FLOAT( IJKCel3(N) ) + CNST4=(CF(N)-CF(M))/( CNST1 + CNST3 ) -! Diffusion flux by face gradient x DT x face_width x cos(lat) - FY(j)=AKDif*CNST5*CNST8 + ! Second order gradient + CNST7 = CNST4 - CNST5 + CNST9 = 2.0/( CNST2+CNST3+CNST3+CNST1 ) - END DO + ! Use 3rd order scheme + IF( Abs(CNST7) .LT. 0.6*CNST9*Abs(CF(N)-CF(L)) ) THEN + CNST= CNST5 + ( CNST2-UFLX(i) )*CNST7*CNST9/1.5 -#ifdef W3_OMPG -!$OMP END DO -#endif + ! Use doubled UNO2 scheme + ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN + CNST=Sign(2.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -#ifdef W3_OMPG -!$OMP END Parallel -#endif + ELSE + ! Use minimum gradient UNO2 scheme. + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! 999 PRINT*, ' Sub SMCyUNO2r ended.' + ENDIF - RETURN - END SUBROUTINE SMCyUNO2r + ! Mid-flux value inside central cell M + FU(i)=(CF(M) - CNST*(CNST3+UFLX(i)))*CNST8 + ENDIF -!> @brief Calculate mid-flux values for x dimension with UNO3 scheme -!> -!> @param[in] NUA Start number of U-face list. -!> @param[in] NUB End number of U-face list. -!> @param[in] CF Transported variable. -!> @param[in] UC Veclocity U-component at cell centre. -!> @param[out] UFLX Mid-flux U-component on U-face. -!> @param[in] AKDif Diffusion coefficient. -!> @param[out] FU Advection Mid-flux on U-face. -!> @param[out] FX Diffusion Mid-flux on U-face. -!> @param[in] FTS Timestep fraction for sub-timestep. -!> -!> @author Jian-Guo Li -!> @date 03-Mar-2022 -!> - SUBROUTINE SMCxUNO3(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX, FTS) + ! Diffusion flux by face gradient x DT + FX(i)=CNST0*CNST5*CNST8/( CLATS( ij )*CLATS( ij ) ) + + END DO + +#ifdef W3_OMPG + !$OMP END DO + !$OMP END Parallel +#endif + + RETURN + END SUBROUTINE SMCxUNO3 + + + !> @brief Calculate mid-flux values for y dimension with UNO3 scheme + !> + !> + !> @param[in] NVA Start number of V-face list. + !> @param[in] NVB End number of V-face list. + !> @param[in] CF Transported variable. + !> @param[in] VC Veclocity V-component at cell centre. + !> @param[out] VFLY Mid-flux V-component on V-face. + !> @param[in] AKDif Diffusion coefficient. + !> @param[out] FV Advection Mid-flux on V-face. + !> @param[out] FY Diffusion Mid-flux on V-face. + !> @param[in] FTS Timestep fraction for sub-timestep. + !> + !> @author Jian-Guo Li + !> @date 03-Mar-2022 + !> + SUBROUTINE SMCyUNO3(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY, FTS) + + USE CONSTANTS + USE W3GDATMD, ONLY: NCel, MRFct, NVFc, IJKCel, IJKVFc, CLATF + USE W3GDATMD, ONLY: IJKCel4 + USE W3ODATMD, ONLY: NDSE, NDST + + IMPLICIT NONE + INTEGER, INTENT( IN):: NVA, NVB + REAL, INTENT( IN):: CF(-9:NCel), VC(-9:NCel), AKDif, FTS + REAL, INTENT(Out):: VFLY(NVFc), FV(NVFc), FY(NVFc) + INTEGER :: i, j, k, L, M, N, ij + REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, & + CNST7, CNST8, CNST9 + + ! Notice an extra side length L is multiplied to mid-flux to give correct + ! proportion of flux into the cells. This length will be removed by the + ! cell length when the tracer concentration is updated. + + ! Diffusion Fourier no. at sub-time-step, proportional to face size, + ! which is also equal to the sub-time-step factor FTS. + ! CNST0=AKDif*FTS*FTS + ! 2.0 factor to cancel that in gradient CNST5. JGLi08Mar2012 + CNST0=AKDif*FTS*FTS*2.0 + ! Uniform diffusion coefficient for all sizes. JGLi24Feb2012 + ! CNST0=AKDif*MRFct*FTS + +#ifdef W3_OMPG + !$OMP Parallel Default(Shared), Private(j, K, L, M, N), & + !$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) + !$OMP DO +#endif + + DO j=NVA, NVB + + ! Select Upstream, Central and Downstream cells + K=IJKVFc(4,j) + L=IJKVFc(5,j) + M=IJKVFc(6,j) + N=IJKVFc(7,j) + + ! Face bounding cell lengths and gradient + CNST2=FLOAT( IJKCel4(L) ) + CNST3=FLOAT( IJKCel4(M) ) + CNST5=(CF(M)-CF(L))/( CNST2 + CNST3 ) + + ! Courant number in local size-1 cell unit + ! Multiply by multi-resolution time step factor FTS + CNST6=0.5*( VC(L)+VC(M) )*FTS + VFLY(j) = CNST6 + + ! Face size integer and cosine factor. + ! CLATF is defined on V-face for SMC grid. JGLi28Feb2012 + CNST8=CLATF(j)*FLOAT( IJKVFc(3,j) ) + + ! For positive velocity case + IF(CNST6 >= 0.0) THEN + + ! Boundary cell y-size is set equal to central cell y-size + ! as y-boundary cell sizes are not proportional to refined + ! inner cells but constant of the base cell y-size, and + ! Use central cell speed for face speed. JGLi06Apr2011 + IF( M .LE. 0 ) THEN + VFLY(j) = VC(L)*FTS + CNST3 = CNST2 + ENDIF + + ! Upstream cell size and irregular grid gradient, depending on VFLY. + CNST1=FLOAT( IJKCel4(K) ) + CNST4=(CF(L)-CF(K))/( CNST2 + CNST1 ) - USE CONSTANTS - USE W3GDATMD, ONLY: NCel, MRFct, NUFc, IJKCel, IJKUFc, CLATS - USE W3GDATMD, ONLY: IJKCel3 - USE W3ODATMD, ONLY: NDSE, NDST + ! Second order gradient + CNST7 = CNST5 - CNST4 + CNST9 = 2.0/( CNST3+CNST2+CNST2+CNST1 ) - IMPLICIT NONE - INTEGER, INTENT( IN):: NUA, NUB - REAL, INTENT( IN):: CF(-9:NCel), UC(-9:NCel), AKDif, FTS - REAL, INTENT(Out):: UFLX(NUFc), FU(NUFc), FX(NUFc) -! - INTEGER :: i, j, k, L, M, N, ij - REAL :: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, & - CNST7, CNST8, CNST9 + ! Use 3rd order scheme + IF( Abs(CNST7) .LT. 0.6*CNST9*Abs(CF(M)-CF(K)) ) THEN + CNST= CNST5 - ( CNST3+VFLY(j) )*CNST7*CNST9/1.5 -! Two layer of boundary cells are added to each boundary cell face -! with all boundary cell values CF(-9:0)=0.0. + ! Use doubled UNO2 scheme + ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN + CNST=Sign(2.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! Diffusion Fourier no. at sub-time-step, proportional to face size, -! which is also equal to the sub-time-step factor FTS. -! CNST0=AKDif*FTS*FTS -! 2.0 factor to cancel that in gradient CNST5. JGLi03Sep2015 - CNST0=AKDif*FTS*FTS*2.0 + ELSE -! Notice an extra side length L is multiplied to mid-flux to give correct -! proportion of flux into the cells. This length will be removed by the -! cell length when the tracer concentration is updated. + ! Use minimum gradient outside monotonic region + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -#ifdef W3_OMPG -!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & -!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) -#endif + ENDIF -#ifdef W3_OMPG -!$OMP DO -#endif + ! Mid-flux value multiplied by face width and cosine factor + FV(j)=( CF(L) + CNST*(CNST2 - VFLY(j)) )*CNST8 - DO i=NUA, NUB + ! For negative velocity case + ELSE -! Select Upstream, Central and Downstream cells - K=IJKUFc(4,i) - L=IJKUFc(5,i) - M=IJKUFc(6,i) - N=IJKUFc(7,i) + ! Set boundary cell y-size equal to central cell y-size and + ! Use central cell speed for flux face speed. JGLi06Apr2011 + IF( L .LE. 0 ) THEN + VFLY(j) = VC(M)*FTS + CNST2 = CNST3 + ENDIF -! Face bounding cell lengths and central gradient - CNST2=FLOAT( IJKCel3(L) ) - CNST3=FLOAT( IJKCel3(M) ) - CNST5=(CF(M)-CF(L))/( CNST2 + CNST3 ) + ! Upstream cell size and gradient, depending on VFLY sign. + ! Side gradients for central cell includs 0.5 factor. + CNST1=FLOAT( IJKCel4(N) ) + CNST4=(CF(N)-CF(M))/( CNST1 + CNST3 ) -! Courant number in local size-1 cell, arithmetic average. - CNST6=0.5*( UC(L)+UC(M) )*FTS - UFLX(i) = CNST6 + ! Second order gradient + CNST7 = CNST4 - CNST5 + CNST9 = 2.0/( CNST2+CNST3+CNST3+CNST1 ) -! Multi-resolution SMC grid requires flux multiplied by face factor. - CNST8 = FLOAT( IJKUFc(3,i) ) + ! Use 3rd order scheme + IF( Abs(CNST7) .LT. 0.6*CNST9*Abs(CF(N)-CF(L)) ) THEN + CNST= CNST5 + ( CNST2-VFLY(j) )*CNST7*CNST9/1.5 -! Diffusion factor in local size-1 cell, plus the cosine factors. -! 2.0 factor to cancel that in gradient CNST5. JGLi08Mar2012 -! The maximum cell number is used to avoid the boundary cell number -! in selection of the cosine factor. - ij= MAX(L, M) + ! Use doubled UNO2 scheme + ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN + CNST=Sign(2.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! For positive velocity case - IF(CNST6 >= 0.0) THEN + ELSE -! Use central cell velocity for boundary flux. JGLi06Apr2011 - IF( M .LE. 0) UFLX(i) = UC(L)*FTS + ! Use minimum gradient outside monotonic region + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) -! Upstream cell length and gradient, depending on UFLX sign. - CNST1=FLOAT( IJKCel3(K) ) - CNST4=(CF(L)-CF(K))/( CNST2 + CNST1 ) + ENDIF -! Second order gradient - CNST7 = CNST5 - CNST4 - CNST9 = 2.0/( CNST3+CNST2+CNST2+CNST1 ) + ! Mid-flux value multiplied by face width and cosine factor + FV(j)=( CF(M) - CNST*(CNST3 + VFLY(j)) )*CNST8 -! Use 3rd order scheme - IF( Abs(CNST7) .LT. 0.6*CNST9*Abs(CF(M)-CF(K)) ) THEN - CNST= CNST5 - ( CNST3+UFLX(i) )*CNST7*CNST9/1.5 + ENDIF -! Use doubled UNO2 scheme - ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN - CNST=Sign(2.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! Diffusion flux by face gradient x DT x face_width x cos(lat) + ! Multiply by multi-resolution time step factor FTS + FY(j)=CNST0*CNST5*CNST8 + + END DO + +#ifdef W3_OMPG + !$OMP END DO + !$OMP END Parallel +#endif + + RETURN + END SUBROUTINE SMCyUNO3 + + + !> @brief Calculate mid-flux values for x dimension with UNO3 + !> + !> @param[in] NUA Start number of U-face list. + !> @param[in] NUB End number of U-face list. + !> @param[in] CF Transported variable. + !> @param[in] UC Veclocity U-component at cell centre. + !> @param[out] UFLX Mid-flux U-component on U-face. + !> @param[in] AKDif Diffusion coefficient. + !> @param[out] FU Advection Mid-flux on U-face. + !> @param[out] FX Diffusion Mid-flux on U-face. + !> + !> @author Jian-Guo Li + !> @date 03-Mar-2022 + !> + SUBROUTINE SMCxUNO3r(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX) + + USE CONSTANTS + USE W3GDATMD, ONLY: NSEA, NY, NCel, NUFc, IJKCel, IJKUFc, CLATS + USE W3GDATMD, ONLY: IJKCel3 + USE W3ODATMD, ONLY: NDSE, NDST + + IMPLICIT NONE + INTEGER, INTENT( IN):: NUA, NUB + REAL, INTENT( IN):: CF(-9:NCel), UC(-9:NCel), AKDif + REAL, INTENT(Out):: UFLX(NUFc), FU(NUFc), FX(NUFc) + ! + INTEGER :: i, j, k, L, M, N, ij + REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, & + CNST7, CNST8, CNST9 + ! Two layer of boundary cells are added to each boundary cell face + ! with all boundary cell values CF(-9:0)=0.0. + + ! Notice an extra side length L is multiplied to mid-flux to give correct + ! proportion of flux into the cells. This length will be removed by the + ! cell length when the tracer concentration is updated. + +#ifdef W3_OMPG + !$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & + !$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) + !$OMP DO +#endif + + DO i=NUA, NUB + + ! Select Upstream, Central and Downstream cells + K=IJKUFc(4,i) + L=IJKUFc(5,i) + M=IJKUFc(6,i) + N=IJKUFc(7,i) + + ! Face bounding cell lengths and gradient + CNST2=FLOAT( IJKCel3(L) ) + CNST3=FLOAT( IJKCel3(M) ) + CNST5=(CF(M)-CF(L)) + + ! Averaged Courant number for base-level cell face + CNST6= 0.5*( UC(L)+UC(M) ) + UFLX(i) = CNST6 + + ! Diffusion Fourier number in local cell size + ! To avoid boundary cell number, use maximum of L and M. + ij= MAX(L, M) + CNST0 = 2.0/( CLATS(ij)*CLATS(ij) ) + + ! For positive velocity case + IF(CNST6 >= 0.0) THEN + + ! Use central cell velocity for boundary flux. JGLi06Apr2011 + IF( M .LE. 0) UFLX(i) = UC(L) + + ! Side gradient for upstream cell as regular grid. + CNST4=(CF(L)-CF(K)) + CNST8=(CF(M)-CF(K)) + CNST9=(CNST5-CNST4) + + IF( Abs(CNST9) <= 0.6*Abs(CNST8) ) THEN + ! Use 3rd order scheme in limited zone, note division by 2 grid sizes + CNST=0.5*CNST5 - (1.0+UFLX(i)/CNST2)*CNST9/6.0 + ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN + ! Use doubled minimum gradient in rest of monotonic region + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ELSE + ! Use minimum gradient all region with 0.5 factor + CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ENDIF + ! Mid-flux value inside central cell + FU(i)=(CF(L) + CNST*(1.0-UFLX(i)/CNST2)) - ELSE -! Use minimum gradient UNO2 scheme - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! For negative velocity case + ELSE - ENDIF + ! Use central cell velocity for boundary flux. JGLi06Apr2011 + IF( L .LE. 0) UFLX(i) = UC(M) -! Mid-flux value inside central cell - FU(i)=(CF(L) + CNST*(CNST2 - UFLX(i)))*CNST8 + ! Side gradient for upstream cell, depneding on UFLX sign. + CNST4=(CF(N)-CF(M)) + CNST8=(CF(N)-CF(L)) + CNST9=(CNST4-CNST5) -! For negative velocity case - ELSE + IF( Abs(CNST9) <= 0.6*Abs(CNST8) ) THEN + ! Use 3rd order scheme in limited zone, note division by 2 grid sizes + CNST=0.5*CNST5 + (1.0-UFLX(i)/CNST3)*CNST9/6.0 + ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN + ! Use doubled minimum gradient in rest of monotonic region + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ELSE + ! Use minimum gradient outside monotonic region, include 0.5 factor + CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ENDIF -! Use central cell velocity for boundary flux. JGLi06Apr2011 - IF( L .LE. 0) UFLX(i) = UC(M)*FTS + ! Mid-flux value inside central cell M + FU(i)=(CF(M) - CNST*(1.0+UFLX(i)/CNST3)) -! Upstream cell length and gradient, depending on UFLX sign. - CNST1=FLOAT( IJKCel3(N) ) - CNST4=(CF(N)-CF(M))/( CNST1 + CNST3 ) + ENDIF -! Second order gradient - CNST7 = CNST4 - CNST5 - CNST9 = 2.0/( CNST2+CNST3+CNST3+CNST1 ) + ! Diffusion flux by face gradient x DT + FX(i)=AKDif*CNST0*CNST5/(CNST2 + CNST3) -! Use 3rd order scheme - IF( Abs(CNST7) .LT. 0.6*CNST9*Abs(CF(N)-CF(L)) ) THEN - CNST= CNST5 + ( CNST2-UFLX(i) )*CNST7*CNST9/1.5 + END DO -! Use doubled UNO2 scheme - ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN - CNST=Sign(2.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) +#ifdef W3_OMPG + !$OMP END DO + !$OMP END Parallel +#endif - ELSE -! Use minimum gradient UNO2 scheme. - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! 999 PRINT*, ' Sub SMCxUNO3r ended.' - ENDIF + RETURN + END SUBROUTINE SMCxUNO3r -! Mid-flux value inside central cell M - FU(i)=(CF(M) - CNST*(CNST3+UFLX(i)))*CNST8 - ENDIF + !> @brief Calculate mid-flux values for y dimension with UNO3 + !> + !> @param[in] NVA Start number of V-face list. + !> @param[in] NVB End number of V-face list. + !> @param[in] CF Transported variable. + !> @param[in] VC Veclocity V-component at cell centre. + !> @param[out] VFLY Mid-flux V-component on V-face. + !> @param[in] AKDif Diffusion coefficient. + !> @param[out] FV Advection Mid-flux on V-face. + !> @param[out] FY Diffusion Mid-flux on V-face. + !> + !> @author Jian-Guo Li + !> @date 03-Mar-2022 + !> + SUBROUTINE SMCyUNO3r(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY) -! Diffusion flux by face gradient x DT - FX(i)=CNST0*CNST5*CNST8/( CLATS( ij )*CLATS( ij ) ) + USE CONSTANTS + USE W3GDATMD, ONLY: NSEA, NY, NCel, NVFc, IJKCel, IJKVFc, CLATF + USE W3ODATMD, ONLY: NDSE, NDST - END DO + IMPLICIT NONE + INTEGER, INTENT( IN):: NVA, NVB + REAL, INTENT( IN):: CF(-9:NCel), VC(-9:NCel), AKDif + REAL, INTENT(Out):: VFLY(NVFc), FV(NVFc), FY(NVFc) + INTEGER :: i, j, k, L, M, N, ij + REAL :: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, & + CNST7, CNST8, CNST9 -#ifdef W3_OMPG -!$OMP END DO -#endif + ! Notice an extra side length L is multiplied to mid-flux to give correct + ! proportion of flux into the cells. This length will be removed by the + ! cell length when the tracer concentration is updated. #ifdef W3_OMPG -!$OMP END Parallel + !$OMP Parallel Default(Shared), Private(j, K, L, M, N), & + !$OMP& Private(CNST,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) + !$OMP DO #endif -! 999 PRINT*, ' Sub SMCxUNO3 ended.' + DO j=NVA, NVB - RETURN - END SUBROUTINE SMCxUNO3 + ! Select Upstream, Central and Downstream cells + K=IJKVFc(4,j) + L=IJKVFc(5,j) + M=IJKVFc(6,j) + N=IJKVFc(7,j) + ! Central face gradient. + CNST5=(CF(M)-CF(L)) -!> @brief Calculate mid-flux values for y dimension with UNO3 scheme -!> -!> -!> @param[in] NVA Start number of V-face list. -!> @param[in] NVB End number of V-face list. -!> @param[in] CF Transported variable. -!> @param[in] VC Veclocity V-component at cell centre. -!> @param[out] VFLY Mid-flux V-component on V-face. -!> @param[in] AKDif Diffusion coefficient. -!> @param[out] FV Advection Mid-flux on V-face. -!> @param[out] FY Diffusion Mid-flux on V-face. -!> @param[in] FTS Timestep fraction for sub-timestep. -!> -!> @author Jian-Guo Li -!> @date 03-Mar-2022 -!> - SUBROUTINE SMCyUNO3(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY, FTS) - - USE CONSTANTS - USE W3GDATMD, ONLY: NCel, MRFct, NVFc, IJKCel, IJKVFc, CLATF - USE W3GDATMD, ONLY: IJKCel4 - USE W3ODATMD, ONLY: NDSE, NDST - - IMPLICIT NONE - INTEGER, INTENT( IN):: NVA, NVB - REAL, INTENT( IN):: CF(-9:NCel), VC(-9:NCel), AKDif, FTS - REAL, INTENT(Out):: VFLY(NVFc), FV(NVFc), FY(NVFc) - INTEGER :: i, j, k, L, M, N, ij - REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, & - CNST7, CNST8, CNST9 - -! Notice an extra side length L is multiplied to mid-flux to give correct -! proportion of flux into the cells. This length will be removed by the -! cell length when the tracer concentration is updated. - -! Diffusion Fourier no. at sub-time-step, proportional to face size, -! which is also equal to the sub-time-step factor FTS. -! CNST0=AKDif*FTS*FTS -! 2.0 factor to cancel that in gradient CNST5. JGLi08Mar2012 - CNST0=AKDif*FTS*FTS*2.0 -! Uniform diffusion coefficient for all sizes. JGLi24Feb2012 -! CNST0=AKDif*MRFct*FTS - -#ifdef W3_OMPG -!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & -!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) -#endif - -#ifdef W3_OMPG -!$OMP DO -#endif - - DO j=NVA, NVB - -! Select Upstream, Central and Downstream cells - K=IJKVFc(4,j) - L=IJKVFc(5,j) - M=IJKVFc(6,j) - N=IJKVFc(7,j) - -! Face bounding cell lengths and gradient - CNST2=FLOAT( IJKCel4(L) ) - CNST3=FLOAT( IJKCel4(M) ) - CNST5=(CF(M)-CF(L))/( CNST2 + CNST3 ) - -! Courant number in local size-1 cell unit -! Multiply by multi-resolution time step factor FTS - CNST6=0.5*( VC(L)+VC(M) )*FTS - VFLY(j) = CNST6 - -! Face size integer and cosine factor. -! CLATF is defined on V-face for SMC grid. JGLi28Feb2012 - CNST8=CLATF(j)*FLOAT( IJKVFc(3,j) ) - -! For positive velocity case - IF(CNST6 >= 0.0) THEN - -! Boundary cell y-size is set equal to central cell y-size -! as y-boundary cell sizes are not proportional to refined -! inner cells but constant of the base cell y-size, and -! Use central cell speed for face speed. JGLi06Apr2011 - IF( M .LE. 0 ) THEN - VFLY(j) = VC(L)*FTS - CNST3 = CNST2 - ENDIF - -! Upstream cell size and irregular grid gradient, depending on VFLY. - CNST1=FLOAT( IJKCel4(K) ) - CNST4=(CF(L)-CF(K))/( CNST2 + CNST1 ) - -! Second order gradient - CNST7 = CNST5 - CNST4 - CNST9 = 2.0/( CNST3+CNST2+CNST2+CNST1 ) - -! Use 3rd order scheme - IF( Abs(CNST7) .LT. 0.6*CNST9*Abs(CF(M)-CF(K)) ) THEN - CNST= CNST5 - ( CNST3+VFLY(j) )*CNST7*CNST9/1.5 - -! Use doubled UNO2 scheme - ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN - CNST=Sign(2.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! Courant number in basic cell unit as dy is constant + CNST6=0.5*( VC(L)+VC(M) ) + VFLY(j) = CNST6 - ELSE + ! Face size integer and cosine factor + ! CLATF is defined on V-face for SMC grid. JGLi28Feb2012 + CNST7=CLatF(j)*FLOAT( IJKVFc(3,j) ) -! Use minimum gradient outside monotonic region - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! For positive velocity case + IF(CNST6 >= 0.0) THEN - ENDIF + ! Use central cell speed for flux face speed. JGLi06Apr2011 + IF( M .LE. 0 ) VFLY(j) = VC(L) -! Mid-flux value multiplied by face width and cosine factor - FV(j)=( CF(L) + CNST*(CNST2 - VFLY(j)) )*CNST8 + ! Upstream face gradient, depending on VFLY sign. + CNST4=(CF(L)-CF(K)) -! For negative velocity case - ELSE + ! Second gradient for 3rd scheme + CNST8=(CF(M)-CF(K)) + CNST9=(CNST5-CNST4) -! Set boundary cell y-size equal to central cell y-size and -! Use central cell speed for flux face speed. JGLi06Apr2011 - IF( L .LE. 0 ) THEN - VFLY(j) = VC(M)*FTS - CNST2 = CNST3 - ENDIF - -! Upstream cell size and gradient, depending on VFLY sign. -! Side gradients for central cell includs 0.5 factor. - CNST1=FLOAT( IJKCel4(N) ) - CNST4=(CF(N)-CF(M))/( CNST1 + CNST3 ) - -! Second order gradient - CNST7 = CNST4 - CNST5 - CNST9 = 2.0/( CNST2+CNST3+CNST3+CNST1 ) - -! Use 3rd order scheme - IF( Abs(CNST7) .LT. 0.6*CNST9*Abs(CF(N)-CF(L)) ) THEN - CNST= CNST5 + ( CNST2-VFLY(j) )*CNST7*CNST9/1.5 - -! Use doubled UNO2 scheme - ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN - CNST=Sign(2.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + IF( Abs(CNST9) <= 0.6*Abs(CNST8) ) THEN + ! Use 3rd order scheme in limited zone, note division by 2 grid sizes + CNST=0.5*CNST5-(1.0+VFLY(j))*CNST9/6.0 + ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN + ! Use doubled minimum gradient in rest of monotonic region + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ELSE + ! Use minimum gradient, including 0.5 factor and central sign. + CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ENDIF - ELSE + ! Mid-flux value multiplied by face width and cosine factor + FV(j)=( CF(L) + CNST*(1.0-VFLY(j)) )*CNST7 -! Use minimum gradient outside monotonic region - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ! For negative velocity case + ELSE - ENDIF + ! Use central cell speed for flux face speed. JGLi06Apr2011 + IF( L .LE. 0 ) VFLY(j) = VC(M) -! Mid-flux value multiplied by face width and cosine factor - FV(j)=( CF(M) - CNST*(CNST3 + VFLY(j)) )*CNST8 + ! Side gradients for upstream face, depending on VFLY sign. + CNST4=(CF(N)-CF(M)) - ENDIF + ! Second gradient for 3rd scheme + CNST8=(CF(N)-CF(L)) + CNST9=(CNST4-CNST5) -! Diffusion flux by face gradient x DT x face_width x cos(lat) -! Multiply by multi-resolution time step factor FTS - FY(j)=CNST0*CNST5*CNST8 + IF( Abs(CNST9) <= 0.6*Abs(CNST8) ) THEN + ! Use 3rd order scheme in limited zone, note division by 2 grid sizes + CNST=0.5*CNST5+(1.0-VFLY(j))*CNST9/6.0 + ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN + ! Use doubled minimum gradient in rest of monotonic region + CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ELSE + ! Use minimum gradient, including 0.5 factor and central sign. + CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) + ENDIF + ! Mid-flux value multiplied by face width and cosine factor + FV(j)=( CF(M) - CNST*(1.0+VFLY(j)) )*CNST7 - END DO + ENDIF + ! Diffusion flux by face gradient x DT x face_width x cos(lat) + FY(j)=AKDif*CNST5*CNST7 + + END DO + +#ifdef W3_OMPG + !$OMP END DO + !$OMP END Parallel +#endif + + RETURN + END SUBROUTINE SMCyUNO3r + + ! + !> @brief Evaluate local gradient for sea points. + !> + !> @details + !> Calculate cell centre gradient for any input variable. + !> Nemerical average is applied to size-changing faces and the gradients + !> are along the lat-lon local east-north directions. + !> + !> + !> @param[in] CVQ Input cell values. + !> @param[out] GrdX Gradient along x-axis. + !> @param[out] GrdY Gradient along y-axis. + !> @param[in] L0r1 Zero or 1st-order boundary condiiton. + !> + !> @author Jian-Guo Li + !> @date 08 Aug 2017 + !> + ! Add optional zero-gradient bounday conditions. JGLi08Aug2017 + ! + SUBROUTINE SMCGradn(CVQ, GrdX, GrdY, L0r1) + + USE CONSTANTS + USE W3GDATMD, ONLY: NSEA, NUFc, NVFc, MRFct, & + IJKCel, IJKUFc, IJKVFC, CLATS, SX, SY + USE W3GDATMD, ONLY: ARCTC + USE W3ODATMD, ONLY: NDSE, NDST + + IMPLICIT NONE + !! New boundary conditions depending on user defined L0r1. + !! L0r1 = 0 will set zero at land points while L0r1 > 0 invokes + !! the zero-gradient boundary condition. JGLi08Aug2017 + REAL, INTENT( IN):: CVQ(NSEA) + REAL, INTENT(Out):: GrdX(NSEA), GrdY(NSEA) + INTEGER, INTENT( IN):: L0r1 + ! + INTEGER :: I, J, K, L, M, N + REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 + REAL :: DX0I, DY0I + + ! Use a few working arrays + REAL, Dimension(-9:NSEA):: CVF, AUN, AVN + + ! Two layer of boundary cells are added to each boundary cell face + ! with all boundary cell default values CVF(-9:0)= 0.0. + CVF(-9:0) = 0.0 + CVF(1:NSEA)=CVQ(1:NSEA) + + !! Initialize arrays + AUN = 0. + AVN = 0. + GrdX = 0. + GrdY = 0. + + !! Multi-resolution base-cell size defined by refined levels. + !! So the MRFct converts the base cell SX, SY into size-1 cell lenth. + !! Constant size-1 dy=DY0 and dx on Equator DX0, inverted. + DX0I = MRFct/ ( SX * DERA * RADIUS ) + DY0I = MRFct/ ( SY * DERA * RADIUS ) + +#ifdef W3_OMPG + !$OMP Parallel Default(Shared), Private(i, j, K, L, M, N), & + !$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6) + !$OMP DO +#endif + + !! Calculate x-gradient by averaging U-face gradients. + DO i=1, NUFc + + ! Select Upstream, Central and Downstream cells + L=IJKUFc(5,i) + M=IJKUFc(6,i) + + !! For zero-gradient boundary conditions, simply skip boundary faces. + IF( L0r1 .EQ. 0 .OR. (L > 0 .AND. M > 0) ) THEN + + ! Multi-resolution SMC grid requires flux multiplied by face factor. + CNST1=FLOAT( IJKUFc(3,i) ) + + ! Face bounding cell lengths and central gradient + CNST2=FLOAT( IJKCel(3,L) ) + CNST3=FLOAT( IJKCel(3,M) ) + + ! Side gradients over 2 cell lengths for central cell. + ! Face size factor is also included for average. + CNST5=CNST1*(CVF(M)-CVF(L))/(CNST2+CNST3) +#if defined W3_B4B && defined W3_OMPG + CNST5=INT(CNST5 * 1.0e6) ! CB: B4B +#endif + + !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 + !! !$OMP CRITICAL + ! Store side gradient in two neighbouring cells + !! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 + IF( L > 0 ) THEN #ifdef W3_OMPG -!$OMP END DO + !$OMP ATOMIC #endif - + AUN(L) = AUN(L) + CNST5 + ENDIF + IF( M > 0 ) THEN #ifdef W3_OMPG -!$OMP END Parallel + !$OMP ATOMIC #endif + AUN(M) = AUN(M) + CNST5 + ENDIF + !! !$OMP END CRITICAL -! 999 PRINT*, ' Sub SMCyUNO3 ended.' - - RETURN - END SUBROUTINE SMCyUNO3 - - -!> @brief Calculate mid-flux values for x dimension with UNO3 -!> -!> @param[in] NUA Start number of U-face list. -!> @param[in] NUB End number of U-face list. -!> @param[in] CF Transported variable. -!> @param[in] UC Veclocity U-component at cell centre. -!> @param[out] UFLX Mid-flux U-component on U-face. -!> @param[in] AKDif Diffusion coefficient. -!> @param[out] FU Advection Mid-flux on U-face. -!> @param[out] FX Diffusion Mid-flux on U-face. -!> -!> @author Jian-Guo Li -!> @date 03-Mar-2022 -!> - SUBROUTINE SMCxUNO3r(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX) - - USE CONSTANTS - USE W3GDATMD, ONLY: NSEA, NY, NCel, NUFc, IJKCel, IJKUFc, CLATS - USE W3GDATMD, ONLY: IJKCel3 - USE W3ODATMD, ONLY: NDSE, NDST - - IMPLICIT NONE - INTEGER, INTENT( IN):: NUA, NUB - REAL, INTENT( IN):: CF(-9:NCel), UC(-9:NCel), AKDif - REAL, INTENT(Out):: UFLX(NUFc), FU(NUFc), FX(NUFc) -! - INTEGER :: i, j, k, L, M, N, ij - REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, & - CNST7, CNST8, CNST9 -! Two layer of boundary cells are added to each boundary cell face -! with all boundary cell values CF(-9:0)=0.0. - -! Notice an extra side length L is multiplied to mid-flux to give correct -! proportion of flux into the cells. This length will be removed by the -! cell length when the tracer concentration is updated. - -#ifdef W3_OMPG -!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & -!$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) -#endif - -#ifdef W3_OMPG -!$OMP DO -#endif - - DO i=NUA, NUB - -! Select Upstream, Central and Downstream cells - K=IJKUFc(4,i) - L=IJKUFc(5,i) - M=IJKUFc(6,i) - N=IJKUFc(7,i) - -! Face bounding cell lengths and gradient - CNST2=FLOAT( IJKCel3(L) ) - CNST3=FLOAT( IJKCel3(M) ) - CNST5=(CF(M)-CF(L)) - -! Averaged Courant number for base-level cell face - CNST6= 0.5*( UC(L)+UC(M) ) - UFLX(i) = CNST6 - -! Diffusion Fourier number in local cell size -! To avoid boundary cell number, use maximum of L and M. - ij= MAX(L, M) - CNST0 = 2.0/( CLATS(ij)*CLATS(ij) ) - -! For positive velocity case - IF(CNST6 >= 0.0) THEN - -! Use central cell velocity for boundary flux. JGLi06Apr2011 - IF( M .LE. 0) UFLX(i) = UC(L) - -! Side gradient for upstream cell as regular grid. - CNST4=(CF(L)-CF(K)) - CNST8=(CF(M)-CF(K)) - CNST9=(CNST5-CNST4) - - IF( Abs(CNST9) <= 0.6*Abs(CNST8) ) THEN -! Use 3rd order scheme in limited zone, note division by 2 grid sizes - CNST=0.5*CNST5 - (1.0+UFLX(i)/CNST2)*CNST9/6.0 - ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN -! Use doubled minimum gradient in rest of monotonic region - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) - ELSE -! Use minimum gradient all region with 0.5 factor - CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) - ENDIF -! Mid-flux value inside central cell - FU(i)=(CF(L) + CNST*(1.0-UFLX(i)/CNST2)) - -! For negative velocity case - ELSE - -! Use central cell velocity for boundary flux. JGLi06Apr2011 - IF( L .LE. 0) UFLX(i) = UC(M) - -! Side gradient for upstream cell, depneding on UFLX sign. - CNST4=(CF(N)-CF(M)) - CNST8=(CF(N)-CF(L)) - CNST9=(CNST4-CNST5) - - IF( Abs(CNST9) <= 0.6*Abs(CNST8) ) THEN -! Use 3rd order scheme in limited zone, note division by 2 grid sizes - CNST=0.5*CNST5 + (1.0-UFLX(i)/CNST3)*CNST9/6.0 - ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN -! Use doubled minimum gradient in rest of monotonic region - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) - ELSE -! Use minimum gradient outside monotonic region, include 0.5 factor - CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) - ENDIF - -! Mid-flux value inside central cell M - FU(i)=(CF(M) - CNST*(1.0+UFLX(i)/CNST3)) - - ENDIF - -! Diffusion flux by face gradient x DT - FX(i)=AKDif*CNST0*CNST5/(CNST2 + CNST3) - - END DO + ENDIF + END DO #ifdef W3_OMPG -!$OMP END DO + !$OMP END DO #endif -#ifdef W3_OMPG -!$OMP END Parallel +#if defined W3_B4B && defined W3_OMPG + !$OMP SINGLE + AUN = AUN / 1.0e6 ! CB B4B + !$OMP END SINGLE #endif -! 999 PRINT*, ' Sub SMCxUNO3r ended.' - - RETURN - END SUBROUTINE SMCxUNO3r - - -!> @brief Calculate mid-flux values for y dimension with UNO3 -!> -!> @param[in] NVA Start number of V-face list. -!> @param[in] NVB End number of V-face list. -!> @param[in] CF Transported variable. -!> @param[in] VC Veclocity V-component at cell centre. -!> @param[out] VFLY Mid-flux V-component on V-face. -!> @param[in] AKDif Diffusion coefficient. -!> @param[out] FV Advection Mid-flux on V-face. -!> @param[out] FY Diffusion Mid-flux on V-face. -!> -!> @author Jian-Guo Li -!> @date 03-Mar-2022 -!> - SUBROUTINE SMCyUNO3r(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY) - - USE CONSTANTS - USE W3GDATMD, ONLY: NSEA, NY, NCel, NVFc, IJKCel, IJKVFc, CLATF - USE W3ODATMD, ONLY: NDSE, NDST - - IMPLICIT NONE - INTEGER, INTENT( IN):: NVA, NVB - REAL, INTENT( IN):: CF(-9:NCel), VC(-9:NCel), AKDif - REAL, INTENT(Out):: VFLY(NVFc), FV(NVFc), FY(NVFc) - INTEGER :: i, j, k, L, M, N, ij - REAL :: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6, & - CNST7, CNST8, CNST9 - -! Notice an extra side length L is multiplied to mid-flux to give correct -! proportion of flux into the cells. This length will be removed by the -! cell length when the tracer concentration is updated. - -#ifdef W3_OMPG -!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & -!$OMP& Private(CNST,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) -#endif + ! Assign averaged side-gradient to GrdX, plus latitude factor + ! Note averaging over 2 times of cell y-width factor but AUN + ! has already been divied by two cell lengths. #ifdef W3_OMPG -!$OMP DO + !$OMP DO #endif - DO j=NVA, NVB - -! Select Upstream, Central and Downstream cells - K=IJKVFc(4,j) - L=IJKVFc(5,j) - M=IJKVFc(6,j) - N=IJKVFc(7,j) - -! Central face gradient. - CNST5=(CF(M)-CF(L)) - -! Courant number in basic cell unit as dy is constant - CNST6=0.5*( VC(L)+VC(M) ) - VFLY(j) = CNST6 - -! Face size integer and cosine factor -! CLATF is defined on V-face for SMC grid. JGLi28Feb2012 - CNST7=CLatF(j)*FLOAT( IJKVFc(3,j) ) - -! For positive velocity case - IF(CNST6 >= 0.0) THEN - -! Use central cell speed for flux face speed. JGLi06Apr2011 - IF( M .LE. 0 ) VFLY(j) = VC(L) - -! Upstream face gradient, depending on VFLY sign. - CNST4=(CF(L)-CF(K)) + DO n=1, NSEA + ! Cell y-size IJKCel(4,i) is used to cancel the face size-factor in AUN. + ! Plus the actual physical length scale for size-1 cell. + ! Note polar cell (if any) AUN = 0.0 as it has no U-face. + GrdX(n)=DX0I*AUN(n)/( CLats(n)*IJKCel(4,n) ) -! Second gradient for 3rd scheme - CNST8=(CF(M)-CF(K)) - CNST9=(CNST5-CNST4) - - IF( Abs(CNST9) <= 0.6*Abs(CNST8) ) THEN -! Use 3rd order scheme in limited zone, note division by 2 grid sizes - CNST=0.5*CNST5-(1.0+VFLY(j))*CNST9/6.0 - ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN -! Use doubled minimum gradient in rest of monotonic region - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) - ELSE -! Use minimum gradient, including 0.5 factor and central sign. - CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) - ENDIF - -! Mid-flux value multiplied by face width and cosine factor - FV(j)=( CF(L) + CNST*(1.0-VFLY(j)) )*CNST7 - -! For negative velocity case - ELSE - -! Use central cell speed for flux face speed. JGLi06Apr2011 - IF( L .LE. 0 ) VFLY(j) = VC(M) - -! Side gradients for upstream face, depending on VFLY sign. - CNST4=(CF(N)-CF(M)) - -! Second gradient for 3rd scheme - CNST8=(CF(N)-CF(L)) - CNST9=(CNST4-CNST5) - - IF( Abs(CNST9) <= 0.6*Abs(CNST8) ) THEN -! Use 3rd order scheme in limited zone, note division by 2 grid sizes - CNST=0.5*CNST5+(1.0-VFLY(j))*CNST9/6.0 - ELSE IF( DBLE(CNST4)*DBLE(CNST5) .GT. 0.d0 ) THEN -! Use doubled minimum gradient in rest of monotonic region - CNST=Sign(1.0, CNST5)*min( Abs(CNST4), Abs(CNST5) ) - ELSE -! Use minimum gradient, including 0.5 factor and central sign. - CNST=Sign(0.5, CNST5)*min( Abs(CNST4), Abs(CNST5) ) - ENDIF -! Mid-flux value multiplied by face width and cosine factor - FV(j)=( CF(M) - CNST*(1.0+VFLY(j)) )*CNST7 - - ENDIF - -! Diffusion flux by face gradient x DT x face_width x cos(lat) - FY(j)=AKDif*CNST5*CNST7 - - END DO + ENDDO #ifdef W3_OMPG -!$OMP END DO + !$OMP END DO + !$OMP DO #endif -#ifdef W3_OMPG -!$OMP END Parallel -#endif - -! 999 PRINT*, ' Sub SMCyUNO3r ended.' - - RETURN - END SUBROUTINE SMCyUNO3r - -! -!> @brief Evaluate local gradient for sea points. -!> -!> @details -!> Calculate cell centre gradient for any input variable. -!> Nemerical average is applied to size-changing faces and the gradients -!> are along the lat-lon local east-north directions. -!> -!> -!> @param[in] CVQ Input cell values. -!> @param[out] GrdX Gradient along x-axis. -!> @param[out] GrdY Gradient along y-axis. -!> @param[in] L0r1 Zero or 1st-order boundary condiiton. -!> -!> @author Jian-Guo Li -!> @date 08 Aug 2017 -!> -! Add optional zero-gradient bounday conditions. JGLi08Aug2017 -! - SUBROUTINE SMCGradn(CVQ, GrdX, GrdY, L0r1) - - USE CONSTANTS - USE W3GDATMD, ONLY: NSEA, NUFc, NVFc, MRFct, & - IJKCel, IJKUFc, IJKVFC, CLATS, SX, SY - USE W3GDATMD, ONLY: ARCTC - USE W3ODATMD, ONLY: NDSE, NDST + !! Calculate y-gradient by averaging V-face gradients. + DO j=1, NVFc - IMPLICIT NONE -!! New boundary conditions depending on user defined L0r1. -!! L0r1 = 0 will set zero at land points while L0r1 > 0 invokes -!! the zero-gradient boundary condition. JGLi08Aug2017 - REAL, INTENT( IN):: CVQ(NSEA) - REAL, INTENT(Out):: GrdX(NSEA), GrdY(NSEA) - INTEGER, INTENT( IN):: L0r1 -! - INTEGER :: I, J, K, L, M, N - REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 - REAL :: DX0I, DY0I + ! Select Central and Downstream cells + L=IJKVFc(5,j) + M=IJKVFc(6,j) -! Use a few working arrays - REAL, Dimension(-9:NSEA):: CVF, AUN, AVN + !! For zero-gradient boundary conditions, simply skip boundary faces. + IF( L0r1 .EQ. 0 .OR. (L > 0 .AND. M > 0) ) THEN -! Two layer of boundary cells are added to each boundary cell face -! with all boundary cell default values CVF(-9:0)= 0.0. - CVF(-9:0) = 0.0 - CVF(1:NSEA)=CVQ(1:NSEA) + ! Face size is required for multi-resolution grid. + CNST1=Real( IJKVFc(3,j) ) -!! Initialize arrays - AUN = 0. - AVN = 0. - GrdX = 0. - GrdY = 0. + ! Cell y-length of UCD cells + CNST2=Real( IJKCel(4,L) ) + CNST3=Real( IJKCel(4,M) ) -!! Multi-resolution base-cell size defined by refined levels. -!! So the MRFct converts the base cell SX, SY into size-1 cell lenth. -!! Constant size-1 dy=DY0 and dx on Equator DX0, inverted. - DX0I = MRFct/ ( SX * DERA * RADIUS ) - DY0I = MRFct/ ( SY * DERA * RADIUS ) + ! Side gradients over 2 cell lengths for central cell. + ! Face size factor is also included for average. + CNST6=CNST1*(CVF(M)-CVF(L))/(CNST2+CNST3) +#if defined W3_B4B && defined W3_OMPG + CNST6 = int(CNST6 * 1.0e6) ! CB B4B +#endif + !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 + !! !$OMP CRITICAL + !! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 + IF( L > 0 ) THEN + ! Store side gradient in two neighbouring cells #ifdef W3_OMPG -!$OMP Parallel Default(Shared), Private(i, j, K, L, M, N), & -!$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6) + !$OMP ATOMIC #endif - + AVN(L) = AVN(L) + CNST6 + ENDIF + IF( M > 0 ) THEN #ifdef W3_OMPG -!$OMP DO + !$OMP ATOMIC #endif + AVN(M) = AVN(M) + CNST6 + ENDIF + !! !$OMP END CRITICAL -!! Calculate x-gradient by averaging U-face gradients. - DO i=1, NUFc - -! Select Upstream, Central and Downstream cells - L=IJKUFc(5,i) - M=IJKUFc(6,i) - -!! For zero-gradient boundary conditions, simply skip boundary faces. - IF( L0r1 .EQ. 0 .OR. (L > 0 .AND. M > 0) ) THEN - -! Multi-resolution SMC grid requires flux multiplied by face factor. - CNST1=FLOAT( IJKUFc(3,i) ) - -! Face bounding cell lengths and central gradient - CNST2=FLOAT( IJKCel(3,L) ) - CNST3=FLOAT( IJKCel(3,M) ) + ENDIF + END DO -! Side gradients over 2 cell lengths for central cell. -! Face size factor is also included for average. - CNST5=CNST1*(CVF(M)-CVF(L))/(CNST2+CNST3) -#ifdef W3_B4B #ifdef W3_OMPG - CNST5=INT(CNST5 * 1.0e6) ! CB: B4B -#endif + !$OMP END DO #endif -!! Replace CRITICAL with ATOMIC. JGLi15Jan2019 -!! !$OMP CRITICAL -! Store side gradient in two neighbouring cells -!! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 - IF( L > 0 ) THEN -#ifdef W3_OMPG -!$OMP ATOMIC -#endif - AUN(L) = AUN(L) + CNST5 - ENDIF - IF( M > 0 ) THEN -#ifdef W3_OMPG -!$OMP ATOMIC +#if defined W3_B4B && defined W3_OMPG + !$OMP SINGLE + AVN = AVN / 1.0e6 !CB B4B + !$OMP END SINGLE #endif - AUN(M) = AUN(M) + CNST5 - ENDIF -!! !$OMP END CRITICAL - - ENDIF - END DO #ifdef W3_OMPG -!$OMP END DO + !$OMP DO #endif -#ifdef W3_B4B -#ifdef W3_OMPG -!$OMP SINGLE - AUN = AUN / 1.0e6 ! CB B4B -!$OMP END SINGLE -#endif -#endif + ! Assign averaged side-gradient to GrdY. + DO n=1, NSEA + ! AV is divided by the cell x-size IJKCel(3,i) to cancel face + ! size-factor, and physical y-distance of size-1 cell. + GrdY(n)=DY0I*AVN(n)/Real( IJKCel(3,n) ) -! Assign averaged side-gradient to GrdX, plus latitude factor -! Note averaging over 2 times of cell y-width factor but AUN -! has already been divied by two cell lengths. + END DO #ifdef W3_OMPG -!$OMP DO + !$OMP END DO + !$OMP END Parallel #endif - DO n=1, NSEA -! Cell y-size IJKCel(4,i) is used to cancel the face size-factor in AUN. -! Plus the actual physical length scale for size-1 cell. -! Note polar cell (if any) AUN = 0.0 as it has no U-face. - GrdX(n)=DX0I*AUN(n)/( CLats(n)*IJKCel(4,n) ) + !!Li Y-gradient for polar cell in Arctic part is set to zero. + IF( ARCTC ) GrdY(NSEA) = 0.0 - ENDDO + RETURN + END SUBROUTINE SMCGradn -#ifdef W3_OMPG -!$OMP END DO -#endif -#ifdef W3_OMPG -!$OMP DO -#endif + !> @brief Average sea point values with a 1-2-1 scheme. + !> + !> @param[inout] CVQ Input field. + !> + !> @author Jian-Guo Li + !> @date 15-Jan-2019 + !> + SUBROUTINE SMCAverg(CVQ) -!! Calculate y-gradient by averaging V-face gradients. - DO j=1, NVFc + USE CONSTANTS + USE W3GDATMD, ONLY: NSEA, NUFc, NVFc, & + IJKCel, IJKUFc, IJKVFC, & + IJKUFc5, IJKUFc6 + USE W3GDATMD, ONLY: ARCTC + USE W3ODATMD, ONLY: NDSE, NDST -! Select Central and Downstream cells - L=IJKVFc(5,j) - M=IJKVFc(6,j) + IMPLICIT NONE + REAL, INTENT(INOUT) :: CVQ(-9:NSEA) + ! + INTEGER :: I, J, K, L, M, N + REAL :: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 -!! For zero-gradient boundary conditions, simply skip boundary faces. - IF( L0r1 .EQ. 0 .OR. (L > 0 .AND. M > 0) ) THEN + ! Use a few working arrays + REAL, Dimension(-9:NSEA) :: CVF, AUN, AVN -! Face size is required for multi-resolution grid. - CNST1=Real( IJKVFc(3,j) ) + ! Two layer of boundary cells are added to each boundary cell face + ! with all boundary cell values stored in CVF(-9:0). + CVF=CVQ -! Cell y-length of UCD cells - CNST2=Real( IJKCel(4,L) ) - CNST3=Real( IJKCel(4,M) ) + !! Initialize arrays + AUN = 0. + AVN = 0. -! Side gradients over 2 cell lengths for central cell. -! Face size factor is also included for average. - CNST6=CNST1*(CVF(M)-CVF(L))/(CNST2+CNST3) -#ifdef W3_B4B -#ifdef W3_OMPG - CNST6 = int(CNST6 * 1.0e6) ! CB B4B -#endif -#endif + !!Li Save polar cell value if any. + CNST0 = CVQ(NSEA) -!! Replace CRITICAL with ATOMIC. JGLi15Jan2019 -!! !$OMP CRITICAL -!! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 - IF( L > 0 ) THEN -! Store side gradient in two neighbouring cells #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP Parallel Default(Shared), Private(i, j, L, M, n), & + !$OMP& Private(CNST3,CNST4,CNST5,CNST6) + !$OMP DO #endif - AVN(L) = AVN(L) + CNST6 - ENDIF - IF( M > 0 ) THEN -#ifdef W3_OMPG -!$OMP ATOMIC -#endif - AVN(M) = AVN(M) + CNST6 - ENDIF -!! !$OMP END CRITICAL - ENDIF - END DO + !! Calculate x-gradient by averaging U-face gradients. + DO i=1, NUFc -#ifdef W3_OMPG -!$OMP END DO -#endif + ! Select Upstream, Central and Downstream cells + L=IJKUFc5(i) + M=IJKUFc6(i) + ! Multi-resolution SMC grid requires flux multiplied by face factor. + CNST5=Real( IJKUFc(3,i) )*(CVF(M)+CVF(L)) #ifdef W3_B4B -#ifdef W3_OMPG -!$OMP SINGLE - AVN = AVN / 1.0e6 !CB B4B -!$OMP END SINGLE -#endif + !OMPG CNST5=int(CNST5 * 1.0e6) #endif + !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 + !! !$OMP CRITICAL + ! Store side gradient in two neighbouring cells + !! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 + IF( L > 0 ) THEN #ifdef W3_OMPG -!$OMP DO + !$OMP ATOMIC #endif - -! Assign averaged side-gradient to GrdY. - DO n=1, NSEA -! AV is divided by the cell x-size IJKCel(3,i) to cancel face -! size-factor, and physical y-distance of size-1 cell. - GrdY(n)=DY0I*AVN(n)/Real( IJKCel(3,n) ) - - END DO - + AUN(L) = AUN(L) + CNST5 + ENDIF + IF( M > 0 ) THEN #ifdef W3_OMPG -!$OMP END DO + !$OMP ATOMIC #endif + AUN(M) = AUN(M) + CNST5 + ENDIF + !! !$OMP END CRITICAL + + END DO #ifdef W3_OMPG -!$OMP END Parallel + !$OMP END DO #endif -!!Li Y-gradient for polar cell in Arctic part is set to zero. - IF( ARCTC ) GrdY(NSEA) = 0.0 - -! 999 PRINT*, ' Sub SMCGradn ended.' - - RETURN - END SUBROUTINE SMCGradn - - -!> @brief Average sea point values with a 1-2-1 scheme. -!> -!> @param[inout] CVQ Input field. -!> -!> @author Jian-Guo Li -!> @date 15-Jan-2019 -!> - SUBROUTINE SMCAverg(CVQ) - - USE CONSTANTS - USE W3GDATMD, ONLY: NSEA, NUFc, NVFc, & - IJKCel, IJKUFc, IJKVFC, & - IJKUFc5, IJKUFc6 - USE W3GDATMD, ONLY: ARCTC - USE W3ODATMD, ONLY: NDSE, NDST - - IMPLICIT NONE - REAL, INTENT(INOUT) :: CVQ(-9:NSEA) -! - INTEGER :: I, J, K, L, M, N - REAL :: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 - -! Use a few working arrays - REAL, Dimension(-9:NSEA) :: CVF, AUN, AVN - -! Two layer of boundary cells are added to each boundary cell face -! with all boundary cell values stored in CVF(-9:0). - CVF=CVQ - -!! Initialize arrays - AUN = 0. - AVN = 0. - -!!Li Save polar cell value if any. - CNST0 = CVQ(NSEA) - -#ifdef W3_OMPG -!$OMP Parallel Default(Shared), Private(i, j, L, M, n), & -!$OMP& Private(CNST3,CNST4,CNST5,CNST6) +#if defined W3_B4B && defined W3_OMPG + !$OMP SINGLE + AUN = AUN / 1.0e6 !CB B4B + !$OMP END SINGLE #endif #ifdef W3_OMPG -!$OMP DO + !$OMP DO #endif -!! Calculate x-gradient by averaging U-face gradients. - DO i=1, NUFc + !! Calculate y-gradient by averaging V-face gradients. + DO j=1, NVFc -! Select Upstream, Central and Downstream cells - L=IJKUFc5(i) - M=IJKUFc6(i) + ! Select Central and Downstream cells + L=IJKVFc(5,j) + M=IJKVFc(6,j) -! Multi-resolution SMC grid requires flux multiplied by face factor. - CNST5=Real( IJKUFc(3,i) )*(CVF(M)+CVF(L)) -#ifdef W3_B4B -!OMPG CNST5=int(CNST5 * 1.0e6) + ! Face size is required for multi-resolution grid. + CNST6=Real( IJKVfc(3,j) )*(CVF(M)+CVF(L)) +#if defined W3_B4B && defined W3_OMPG + CNST6=INT(CNST6 * 1e6) #endif -!! Replace CRITICAL with ATOMIC. JGLi15Jan2019 -!! !$OMP CRITICAL -! Store side gradient in two neighbouring cells -!! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 - IF( L > 0 ) THEN + !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 + !! !$OMP CRITICAL + ! Store side gradient in two neighbouring cells + !! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 + IF( L > 0 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - AUN(L) = AUN(L) + CNST5 - ENDIF - IF( M > 0 ) THEN + AVN(L) = AVN(L) + CNST6 + ENDIF + IF( M > 0 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP ATOMIC #endif - AUN(M) = AUN(M) + CNST5 - ENDIF -!! !$OMP END CRITICAL + AVN(M) = AVN(M) + CNST6 + ENDIF + !! !$OMP END CRITICAL - END DO + END DO #ifdef W3_OMPG -!$OMP END DO + !$OMP END DO #endif -#ifdef W3_B4B -#ifdef W3_OMPG -!$OMP SINGLE - AUN = AUN / 1.0e6 !CB B4B -!$OMP END SINGLE -#endif +#if defined W3_B4B && defined W3_OMPG + !$OMP SINGLE + AVN = AVN / 1.0e6 !CB B4B + !$OMP END SINGLE #endif #ifdef W3_OMPG -!$OMP DO + !$OMP DO #endif -!! Calculate y-gradient by averaging V-face gradients. - DO j=1, NVFc + ! Assign averaged value back to CVQ. + DO n=1, NSEA -! Select Central and Downstream cells - L=IJKVFc(5,j) - M=IJKVFc(6,j) + CNST3=0.125/Real( IJKCel(3,n) ) + CNST4=0.125/Real( IJKCel(4,n) ) + ! AUN is divided by the cell y-size IJKCel(4,n) and AVN by + ! the cell x-size IJKCel(3,n) to cancel face size factors. + CVQ(n)= AUN(n)*CNST4 + AVN(n)*CNST3 -! Face size is required for multi-resolution grid. - CNST6=Real( IJKVfc(3,j) )*(CVF(M)+CVF(L)) -#ifdef W3_B4B -#ifdef W3_OMPG - CNST6=INT(CNST6 * 1e6) -#endif -#endif + END DO -!! Replace CRITICAL with ATOMIC. JGLi15Jan2019 -!! !$OMP CRITICAL -! Store side gradient in two neighbouring cells -!! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 - IF( L > 0 ) THEN -#ifdef W3_OMPG -!$OMP ATOMIC -#endif - AVN(L) = AVN(L) + CNST6 - ENDIF - IF( M > 0 ) THEN #ifdef W3_OMPG -!$OMP ATOMIC + !$OMP END DO + !$OMP END Parallel #endif - AVN(M) = AVN(M) + CNST6 - ENDIF -!! !$OMP END CRITICAL - END DO + !!Li Polar cell (if any) keep original value. + IF( ARCTC ) CVQ(NSEA) = CNST0 -#ifdef W3_OMPG -!$OMP END DO -#endif + ! 999 PRINT*, ' Sub SMCAverg ended.' -#ifdef W3_B4B -#ifdef W3_OMPG -!$OMP SINGLE - AVN = AVN / 1.0e6 !CB B4B -!$OMP END SINGLE -#endif -#endif - -#ifdef W3_OMPG -!$OMP DO -#endif + RETURN + END SUBROUTINE SMCAverg -! Assign averaged value back to CVQ. - DO n=1, NSEA - CNST3=0.125/Real( IJKCel(3,n) ) - CNST4=0.125/Real( IJKCel(4,n) ) -! AUN is divided by the cell y-size IJKCel(4,n) and AVN by -! the cell x-size IJKCel(3,n) to cancel face size factors. - CVQ(n)= AUN(n)*CNST4 + AVN(n)*CNST3 + !> @brief Calculate great circle turning (GCT) and refraction. + !> + !> @details + !> The refraction and GCT terms are equivalent to a single rotation by each + !> element and does not need to be calculated as advection. A simple rotation + !> scheme similar to the 1st order upstream scheme but without any restriction + !> on the rotation angle or the CFL limit by an Eulerian advection scheme. + !> + !> @param[in] CoRfr Courant number for refraction and GCT rotation. + !> @param[in] SpeTHK Wave spectrum to be rotated and output. + !> + !> @author Jian-Guo Li + !> @date 12 Nov 2010 + !> + SUBROUTINE SMCGtCrfr(CoRfr, SpeTHK) + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, DTH, CTMAX - END DO + IMPLICIT NONE + REAL, INTENT(IN) :: CoRfr(NTH, NK) + REAL, INTENT(INOUT):: SpeTHK(NTH, NK) + INTEGER :: I, J, K, L, M, N + REAL, Dimension(NTH):: SpeGCT, Spectr + REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 -#ifdef W3_OMPG -!$OMP END DO -#endif + ! Loop through NK spectral bins. + DO n=1, NK -#ifdef W3_OMPG -!$OMP END Parallel -#endif + !! Asign cell spectrum to temporary variable Spcetr + Spectr=SpeTHK(1:NTH,n) + SpeGCT=0.0 -!!Li Polar cell (if any) keep original value. - IF( ARCTC ) CVQ(NSEA) = CNST0 + !! Loop through NTH directional bins for each cell spectrum + DO j=1, NTH -! 999 PRINT*, ' Sub SMCAverg ended.' + ! GCT + refraction Courant number for this dirctional bin + CNST6=CoRfr(j,n) - RETURN - END SUBROUTINE SMCAverg + ! Work out integer number of bins to be skipped. + ! If K is great than NTH, full circle turning is removed. + CNST5=ABS( CNST6 ) + K= MOD( INT(CNST5), NTH ) + ! Partitioning faraction of the spectral component + CNST1=CNST5 - FLOAT( INT(CNST5) ) + CNST2=1.0 - CNST1 -!> @brief Calculate great circle turning (GCT) and refraction. -!> -!> @details -!> The refraction and GCT terms are equivalent to a single rotation by each -!> element and does not need to be calculated as advection. A simple rotation -!> scheme similar to the 1st order upstream scheme but without any restriction -!> on the rotation angle or the CFL limit by an Eulerian advection scheme. -!> -!> @param[in] CoRfr Courant number for refraction and GCT rotation. -!> @param[in] SpeTHK Wave spectrum to be rotated and output. -!> -!> @author Jian-Guo Li -!> @date 12 Nov 2010 -!> - SUBROUTINE SMCGtCrfr(CoRfr, SpeTHK) - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, DTH, CTMAX - - IMPLICIT NONE - REAL, INTENT(IN) :: CoRfr(NTH, NK) - REAL, INTENT(INOUT):: SpeTHK(NTH, NK) - INTEGER :: I, J, K, L, M, N - REAL, Dimension(NTH):: SpeGCT, Spectr - REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 - -! Loop through NK spectral bins. - DO n=1, NK - -!! Asign cell spectrum to temporary variable Spcetr - Spectr=SpeTHK(1:NTH,n) - SpeGCT=0.0 - -!! Loop through NTH directional bins for each cell spectrum - DO j=1, NTH - -! GCT + refraction Courant number for this dirctional bin - CNST6=CoRfr(j,n) - -! Work out integer number of bins to be skipped. -! If K is great than NTH, full circle turning is removed. - CNST5=ABS( CNST6 ) - K= MOD( INT(CNST5), NTH ) - -! Partitioning faraction of the spectral component - CNST1=CNST5 - FLOAT( INT(CNST5) ) - CNST2=1.0 - CNST1 - -! For positive turning case - IF(CNST6 > 0.0) THEN - -! Select the upstream and downstream bins to rotate in, wrap at end - L=j+K - M=j+K+1 - IF( L .GT. NTH ) L = L - NTH - IF( M .GT. NTH ) M = M - NTH - -!! Divide the j bin energy by fraction of CNST6 and store in SpeGCT - SpeGCT(L)=SpeGCT(L)+Spectr(j)*CNST2 - SpeGCT(M)=SpeGCT(M)+Spectr(j)*CNST1 - -! For negative or no turning case - ELSE - -! Select the upstream and downstream bins to rotate in, wrap at end - L=j-K - M=j-K-1 - IF( L .LT. 1 ) L = L + NTH - IF( M .LT. 1 ) M = M + NTH - -!! Divide the bin energy by fraction of CNST6 and store in SpeGCT - SpeGCT(L)=SpeGCT(L)+Spectr(j)*CNST2 - SpeGCT(M)=SpeGCT(M)+Spectr(j)*CNST1 + ! For positive turning case + IF(CNST6 > 0.0) THEN - ENDIF + ! Select the upstream and downstream bins to rotate in, wrap at end + L=j+K + M=j+K+1 + IF( L .GT. NTH ) L = L - NTH + IF( M .GT. NTH ) M = M - NTH -!! End of directional loop j - END DO + !! Divide the j bin energy by fraction of CNST6 and store in SpeGCT + SpeGCT(L)=SpeGCT(L)+Spectr(j)*CNST2 + SpeGCT(M)=SpeGCT(M)+Spectr(j)*CNST1 -!! Store GCT spectrum - SpeTHK(1:NTH,n) = SpeGCT + ! For negative or no turning case + ELSE -!! End of cell loop n - END DO + ! Select the upstream and downstream bins to rotate in, wrap at end + L=j-K + M=j-K-1 + IF( L .LT. 1 ) L = L + NTH + IF( M .LT. 1 ) M = M + NTH -! 999 PRINT*, ' Sub SMCGtCrfr ended.' + !! Divide the bin energy by fraction of CNST6 and store in SpeGCT + SpeGCT(L)=SpeGCT(L)+Spectr(j)*CNST2 + SpeGCT(M)=SpeGCT(M)+Spectr(j)*CNST1 - RETURN - END SUBROUTINE SMCGtCrfr + ENDIF + !! End of directional loop j + END DO -!> -!> @brief Calculates refraction induced shift in k-space. -!> -!> @details -!> The term is equivalent to advection on an irregular k-space grid. -!> The UNO2 scheme on irregular grid is used for this term. -!> -!> Cell and side indices for k-dimension are arranged as: -!> @verbatim -!> Cell: | -1 | 0 | 1 | 2 | ... | NK | NK+1 | NK+2 | -!> Side: -1 0 1 2 ... NK NK+1 -!> @endverbatim -!> The wave action in k-space is extended at the high-wavenumber -!> (frequency) end by the (m+2)th negative power of frequency for -!> boundary conditions. Outside low-wavenumber (frequncy) end, wave -!> action is assumed to be zero. -!> -!> @param[in] CoRfr Courant number for refraction k-shift. -!> @param[inout] SpeTHK Spectrum to be shifted and output. -!> @param[in] DKC Wave number increment at k-bin centre. -!> @param[in] DKS Wave number increment at k-bin edges. -!> -!> -!> @author Jian-Guo Li -!> @date 15 Nov 2010 -! -! Fix bug on CFL limiter and add positive filter. JGLi28Jun2017 -! - SUBROUTINE SMCkUNO2(CoRfr, SpeTHK, DKC, DKS) - - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NK2, NTH, DTH, XFR, CTMAX - - IMPLICIT NONE - REAL, INTENT(IN) :: CoRfr(NTH, 0:NK), DKC(0:NK+1), DKS(-1:NK+1) - REAL, INTENT(INOUT):: SpeTHK(NTH, NK) - INTEGER :: I, J, K, L, M, N - REAL, Dimension(-1:NK+2):: SpeRfr, Spectr, SpeFlx - REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 - - CNST=XFR**(-7) - - DO n=1, NTH - -!! Asign cell spectrum to temporary variable Spcetr - Spectr(-1) =0.0 - Spectr( 0) =0.0 - Spectr(1:NK)=SpeTHK(n,1:NK) - Spectr(NK+1)=Spectr(NK )*CNST - Spectr(NK+2)=Spectr(NK+1)*CNST - -!! Calculate k-space gradient for NK+2 faces by UNO2 scheme - SpeRfr(-1)= 0.0 - DO j=-1, NK+1 - SpeRfr(j)=(Spectr(j+1)-Spectr(j))/DKS(j) - ENDDO + !! Store GCT spectrum + SpeTHK(1:NTH,n) = SpeGCT + + !! End of cell loop n + END DO + + ! 999 PRINT*, ' Sub SMCGtCrfr ended.' + + RETURN + END SUBROUTINE SMCGtCrfr + + + !> + !> @brief Calculates refraction induced shift in k-space. + !> + !> @details + !> The term is equivalent to advection on an irregular k-space grid. + !> The UNO2 scheme on irregular grid is used for this term. + !> + !> Cell and side indices for k-dimension are arranged as: + !> @verbatim + !> Cell: | -1 | 0 | 1 | 2 | ... | NK | NK+1 | NK+2 | + !> Side: -1 0 1 2 ... NK NK+1 + !> @endverbatim + !> The wave action in k-space is extended at the high-wavenumber + !> (frequency) end by the (m+2)th negative power of frequency for + !> boundary conditions. Outside low-wavenumber (frequncy) end, wave + !> action is assumed to be zero. + !> + !> @param[in] CoRfr Courant number for refraction k-shift. + !> @param[inout] SpeTHK Spectrum to be shifted and output. + !> @param[in] DKC Wave number increment at k-bin centre. + !> @param[in] DKS Wave number increment at k-bin edges. + !> + !> + !> @author Jian-Guo Li + !> @date 15 Nov 2010 + ! + ! Fix bug on CFL limiter and add positive filter. JGLi28Jun2017 + ! + SUBROUTINE SMCkUNO2(CoRfr, SpeTHK, DKC, DKS) + + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NK2, NTH, DTH, XFR, CTMAX + + IMPLICIT NONE + REAL, INTENT(IN) :: CoRfr(NTH, 0:NK), DKC(0:NK+1), DKS(-1:NK+1) + REAL, INTENT(INOUT):: SpeTHK(NTH, NK) + INTEGER :: I, J, K, L, M, N + REAL, Dimension(-1:NK+2):: SpeRfr, Spectr, SpeFlx + REAL:: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 + + CNST=XFR**(-7) + + DO n=1, NTH + + !! Asign cell spectrum to temporary variable Spcetr + Spectr(-1) =0.0 + Spectr( 0) =0.0 + Spectr(1:NK)=SpeTHK(n,1:NK) + Spectr(NK+1)=Spectr(NK )*CNST + Spectr(NK+2)=Spectr(NK+1)*CNST + + !! Calculate k-space gradient for NK+2 faces by UNO2 scheme + SpeRfr(-1)= 0.0 + DO j=-1, NK+1 + SpeRfr(j)=(Spectr(j+1)-Spectr(j))/DKS(j) + ENDDO -!! Calculate k-space fluxes for NK+1 faces by UNO2 scheme - DO j=0, NK + !! Calculate k-space fluxes for NK+1 faces by UNO2 scheme + DO j=0, NK -! Final refraction Courant number for this k-space face - CNST6=CoRfr(n,j) -!! Note CoRfr is CFL for k but without dividing dk. + ! Final refraction Courant number for this k-space face + CNST6=CoRfr(n,j) + !! Note CoRfr is CFL for k but without dividing dk. -! For positive case - IF(CNST6 > 0.0) THEN + ! For positive case + IF(CNST6 > 0.0) THEN - CNST0 = MIN( CTMAX*DKC(j), CNST6 ) - SpeFlx(j) = CNST0*( Spectr(j) + SIGN(0.5, SpeRfr(j))*(DKC(j)-CNST0) & - *MIN( ABS(SpeRfr(j-1)), ABS(SpeRfr(j)) ) ) - -! For negative or no turning case - ELSE + CNST0 = MIN( CTMAX*DKC(j), CNST6 ) + SpeFlx(j) = CNST0*( Spectr(j) + SIGN(0.5, SpeRfr(j))*(DKC(j)-CNST0) & + *MIN( ABS(SpeRfr(j-1)), ABS(SpeRfr(j)) ) ) - CNST0 = MIN( CTMAX*DKC(j+1), -CNST6 ) - SpeFlx(j) = -CNST0*( Spectr(j+1) - SIGN(0.5, SpeRfr(j))*(DKC(j+1)-CNST0) & - *MIN( ABS(SpeRfr(j+1)), ABS(SpeRfr(j)) ) ) + ! For negative or no turning case + ELSE - ENDIF + CNST0 = MIN( CTMAX*DKC(j+1), -CNST6 ) + SpeFlx(j) = -CNST0*( Spectr(j+1) - SIGN(0.5, SpeRfr(j))*(DKC(j+1)-CNST0) & + *MIN( ABS(SpeRfr(j+1)), ABS(SpeRfr(j)) ) ) -!! End of flux loop j - END DO + ENDIF -!! Update spectrum for the given direction - DO j=1, NK -! Final refraction Courant number for this k-space face -! SpeTHK(n, j) = Spectr(j) + (SpeFlx(j-1) - SpeFlx(j))/DKC(j) -! Add positive filter in case negative values. JGLi27Jun2017 - SpeTHK(n, j) = MAX( 0.0, Spectr(j)+(SpeFlx(j-1)-SpeFlx(j))/DKC(j) ) - END DO + !! End of flux loop j + END DO -!! End of directional loop n + !! Update spectrum for the given direction + DO j=1, NK + ! Final refraction Courant number for this k-space face + ! SpeTHK(n, j) = Spectr(j) + (SpeFlx(j-1) - SpeFlx(j))/DKC(j) + ! Add positive filter in case negative values. JGLi27Jun2017 + SpeTHK(n, j) = MAX( 0.0, Spectr(j)+(SpeFlx(j-1)-SpeFlx(j))/DKC(j) ) END DO -! 999 PRINT*, ' Sub SMCkUNO2 ended.' + !! End of directional loop n + END DO - RETURN - END SUBROUTINE SMCkUNO2 + ! 999 PRINT*, ' Sub SMCkUNO2 ended.' + RETURN + END SUBROUTINE SMCkUNO2 -!> @brief Calculates water-depth gradient for refraction. -!> -!> @details -!> For consistency with the lat-lon grid, full grid DDDX, DDDY are -!> also assigned here. DHDX, DHDY are used for refraction at present. -!> It has to be rotated to map-east system in the Arctic part. -!> -!> @author Jian-Guo Li -!> @date 03-Mar-2022 -!> - SUBROUTINE SMCDHXY - USE CONSTANTS - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSTA, MAPFS, MRFct, IJKCel, & - CLATS, NTH, DTH, ESIN, ECOS, Refran, DMIN - USE W3GDATMD, ONLY: NGLO, ANGARC, ARCTC - USE W3ADATMD, ONLY: DW, DDDX, DDDY, DHDX, DHDY, DHLMT - USE W3ODATMD, ONLY: NDSE, NDST - IMPLICIT NONE + !> @brief Calculates water-depth gradient for refraction. + !> + !> @details + !> For consistency with the lat-lon grid, full grid DDDX, DDDY are + !> also assigned here. DHDX, DHDY are used for refraction at present. + !> It has to be rotated to map-east system in the Arctic part. + !> + !> @author Jian-Guo Li + !> @date 03-Mar-2022 + !> + SUBROUTINE SMCDHXY + USE CONSTANTS + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSTA, MAPFS, MRFct, IJKCel, & + CLATS, NTH, DTH, ESIN, ECOS, Refran, DMIN + USE W3GDATMD, ONLY: NGLO, ANGARC, ARCTC + USE W3ADATMD, ONLY: DW, DDDX, DDDY, DHDX, DHDY, DHLMT + USE W3ODATMD, ONLY: NDSE, NDST + + IMPLICIT NONE - INTEGER :: I, J, K, L, M, N - REAL :: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 - REAL, Dimension(NSEA) :: HCel, GrHx, GrHy -! REAL, Dimension(-9:NSEA) :: HCel + INTEGER :: I, J, K, L, M, N + REAL :: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 + REAL, Dimension(NSEA) :: HCel, GrHx, GrHy + ! REAL, Dimension(-9:NSEA) :: HCel -!! Assign water depth to HCel from DW integer values. -!! set half the minimum depth DMIN for negative cells. -! HCel(-9:0) = 0.5*DMIN - HCel(1:NSEA)= DW(1:NSEA) + !! Assign water depth to HCel from DW integer values. + !! set half the minimum depth DMIN for negative cells. + ! HCel(-9:0) = 0.5*DMIN + HCel(1:NSEA)= DW(1:NSEA) -!! Reset shallow water depth with minimum depth + !! Reset shallow water depth with minimum depth #ifdef W3_OMPG -!$OMP Parallel DO Private(k) + !$OMP Parallel DO Private(k) #endif - DO k=1, NSEA - IF(DW(k) .LT. DMIN) HCel(k)=DMIN - ENDDO + DO k=1, NSEA + IF(DW(k) .LT. DMIN) HCel(k)=DMIN + ENDDO #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP END Parallel DO #endif -!! Initialize full grid gradient arrays - DDDX = 0. - DDDY = 0. + !! Initialize full grid gradient arrays + DDDX = 0. + DDDY = 0. -!! Use zero-gradient boundary condition or L0r1 > 0 - L = 1 + !! Use zero-gradient boundary condition or L0r1 > 0 + L = 1 -!! Calculate sea point water depth gradient - CALL SMCGradn(HCel, GrHx, GrHy, L) + !! Calculate sea point water depth gradient + CALL SMCGradn(HCel, GrHx, GrHy, L) -!! Pass gradient values to DHDX, DHDY - DHDX(1:NSEA) = GrHx - DHDY(1:NSEA) = GrHy + !! Pass gradient values to DHDX, DHDY + DHDX(1:NSEA) = GrHx + DHDY(1:NSEA) = GrHy -!! Apply limiter to depth-gradient and copy to full grid. + !! Apply limiter to depth-gradient and copy to full grid. #ifdef W3_OMPG -!$OMP Parallel DO Private(i,j,k,m,n, CNST0, CNST1, CNST2) + !$OMP Parallel DO Private(i,j,k,m,n, CNST0, CNST1, CNST2) #endif - DO n=1,NSEA + DO n=1,NSEA -! A limiter of gradient <= 0.1 is applied. - IF( ABS( DHDX(n) ) .GT. 0.1) DHDX(n)=SIGN( 0.1, DHDX(n) ) - IF( ABS( DHDY(n) ) .GT. 0.1) DHDY(n)=SIGN( 0.1, DHDY(n) ) + ! A limiter of gradient <= 0.1 is applied. + IF( ABS( DHDX(n) ) .GT. 0.1) DHDX(n)=SIGN( 0.1, DHDX(n) ) + IF( ABS( DHDY(n) ) .GT. 0.1) DHDY(n)=SIGN( 0.1, DHDY(n) ) -!! Asign DHDX value to full grid variable DDDX - i= IJKCel(1,n)/MRFct + 1 - j= IJKCel(2,n)/MRFct + 1 - k= MAX(1, IJKCel(3,n)/MRFct) - m= MAX(1, IJKCel(4,n)/MRFct) - DDDX(j:j+m-1,i:i+k-1) = DHDX(n) - DDDY(j:j+m-1,i:i+k-1) = DHDY(n) + !! Asign DHDX value to full grid variable DDDX + i= IJKCel(1,n)/MRFct + 1 + j= IJKCel(2,n)/MRFct + 1 + k= MAX(1, IJKCel(3,n)/MRFct) + m= MAX(1, IJKCel(4,n)/MRFct) + DDDX(j:j+m-1,i:i+k-1) = DHDX(n) + DDDY(j:j+m-1,i:i+k-1) = DHDY(n) -!Li Depth gradient in the Arctic part has to be rotated into -!Li the map-east system for calculation of refraction. - IF( ARCTC .AND. n .GT. NGLO ) THEN - CNST0 = ANGARC(n - NGLO)*DERA - CNST1 = DHDX(n)*COS(CNST0) - DHDY(n)*SIN(CNST0) - CNST2 = DHDX(n)*SIN(CNST0) + DHDY(n)*COS(CNST0) - DHDX(n) = CNST1 - DHDY(n) = CNST2 - ENDIF + !Li Depth gradient in the Arctic part has to be rotated into + !Li the map-east system for calculation of refraction. + IF( ARCTC .AND. n .GT. NGLO ) THEN + CNST0 = ANGARC(n - NGLO)*DERA + CNST1 = DHDX(n)*COS(CNST0) - DHDY(n)*SIN(CNST0) + CNST2 = DHDX(n)*SIN(CNST0) + DHDY(n)*COS(CNST0) + DHDX(n) = CNST1 + DHDY(n) = CNST2 + ENDIF - END DO + END DO #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP END Parallel DO #endif -!! Calculate the depth gradient limiter for refraction. + !! Calculate the depth gradient limiter for refraction. #ifdef W3_T - L = 0 !CB - added T switch + L = 0 !CB - added T switch #endif #ifdef W3_OMPG -!$OMP Parallel DO Private(i, n, CNST4, CNST6) + !$OMP Parallel DO Private(i, n, CNST4, CNST6) #endif - DO n=1,NSEA + DO n=1,NSEA -!Li Work out magnitude of depth gradient - CNST4 = 1.0001*SQRT(DHDX(n)*DHDX(n) + DHDY(n)*DHDY(n)) -! -!Li Directional depedent depth gradient limiter. JGLi16Jun2011 - IF ( CNST4 .GT. 1.0E-5 ) THEN + !Li Work out magnitude of depth gradient + CNST4 = 1.0001*SQRT(DHDX(n)*DHDX(n) + DHDY(n)*DHDY(n)) + ! + !Li Directional depedent depth gradient limiter. JGLi16Jun2011 + IF ( CNST4 .GT. 1.0E-5 ) THEN -#ifdef W3_T -#ifdef W3_OMPG -!$OMP ATOMIC Update !CB - added T switch +#if defined W3_T && defined W3_OMPG + !$OMP ATOMIC Update !CB - added T switch #endif L = L + 1 !CB - added T switch -#ifdef W3_OMPG -!$OMP END ATOMIC !CB - added T switch -#endif +#if defined W3_T && defined W3_OMPG + !$OMP END ATOMIC !CB - added T switch #endif DO i=1, NTH -!Li Refraction is done only when depth gradient is non-zero. -!Li Note ACOS returns value between [0, Pi), always positive. + !Li Refraction is done only when depth gradient is non-zero. + !Li Note ACOS returns value between [0, Pi), always positive. CNST6 = ACOS(-(DHDX(n)*ECOS(i)+DHDY(n)*ESIN(i))/CNST4 ) -!Li User-defined refraction limiter added. JGLi09Jan2012 + !Li User-defined refraction limiter added. JGLi09Jan2012 DHLMT(i,n)=MIN(Refran, 0.75*MIN(CNST6,ABS(PI-CNST6)))/DTH END DO -!Li Output some values for inspection. JGLi22Jul2011 + !Li Output some values for inspection. JGLi22Jul2011 #ifdef W3_T IF( MOD(n, 1000) .EQ. 0 ) & - WRITE(NDST,'(i8,18F5.1)' ) n, (DHLMT(i,n), i=1,18) + WRITE(NDST,'(i8,18F5.1)' ) n, (DHLMT(i,n), i=1,18) #endif - ELSE - DHLMT(:,n) = 0.0 - ENDIF + ELSE + DHLMT(:,n) = 0.0 + ENDIF - ENDDO + ENDDO #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP END Parallel DO #endif #ifdef W3_T - WRITE(NDST,*) ' No. Refraction points =', L + WRITE(NDST,*) ' No. Refraction points =', L #endif #ifdef W3_T - 999 PRINT*, ' Sub SMCDHXY ended.' -#endif - - RETURN - END SUBROUTINE SMCDHXY - - -!> @brief Calculates current velocity gradient for refraction. -!> -!> @details -!> For consistency with the lat-lon grid, full grid DCXDXY, DCYDXY are -!> assigned here. They are rotated to map-east system in the Arctic part. -!> -!> @author Jian-Guo Li -!> @date 23 Mar 2016 -!> - SUBROUTINE SMCDCXY - USE CONSTANTS - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSTA, MAPFS, MRFct, IJKCel - USE W3GDATMD, ONLY: NGLO, ANGARC, ARCTC - USE W3ADATMD, ONLY: CX, CY, DCXDX, DCXDY, DCYDX, DCYDY - USE W3ODATMD, ONLY: NDSE, NDST - - IMPLICIT NONE - - INTEGER :: I, J, K, L, M, N - REAL :: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 - REAL, Dimension(NSEA) :: CXCY, GrHx, GrHy -! REAL, Dimension(-9:NSEA) :: CXCY - -!! Assign current CX speed to CXCY and set negative cells. -! CXCY(-9:0) = 0.0 -!! Use zero-gradient boundary condition or L0r1 > 0 - L = 1 - CXCY(1:NSEA)= CX(1:NSEA) - -!! Initialize full grid gradient arrays - DCXDX = 0.0 - DCXDY = 0.0 - -!! Calculate sea point water depth gradient - CALL SMCGradn(CXCY, GrHx, GrHy, L) - -!! Apply limiter to CX-gradient and copy to full grid. -#ifdef W3_OMPG -!$OMP Parallel DO Private(i, j, k, m, n, CNST0, CNST1, CNST2) -#endif - DO n=1,NSEA - -! A limiter of gradient <= 0.01 is applied. - IF( ABS( GrHx(n) ) .GT. 0.01) GrHx(n)=SIGN( 0.01, GrHx(n) ) - IF( ABS( GrHy(n) ) .GT. 0.01) GrHy(n)=SIGN( 0.01, GrHy(n) ) - -!Li Current gradient in the Arctic part has to be rotated into -!Li the map-east system for calculation of refraction. - IF( ARCTC .AND. n .GT. NGLO ) THEN - CNST0 = ANGARC(n - NGLO)*DERA - CNST1 = GrHx(n)*COS(CNST0) - GrHy(n)*SIN(CNST0) - CNST2 = GrHx(n)*SIN(CNST0) + GrHy(n)*COS(CNST0) - GrHx(n) = CNST1 - GrHy(n) = CNST2 - ENDIF +999 PRINT*, ' Sub SMCDHXY ended.' +#endif + + RETURN + END SUBROUTINE SMCDHXY + + + !> @brief Calculates current velocity gradient for refraction. + !> + !> @details + !> For consistency with the lat-lon grid, full grid DCXDXY, DCYDXY are + !> assigned here. They are rotated to map-east system in the Arctic part. + !> + !> @author Jian-Guo Li + !> @date 23 Mar 2016 + !> + SUBROUTINE SMCDCXY + USE CONSTANTS + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSTA, MAPFS, MRFct, IJKCel + USE W3GDATMD, ONLY: NGLO, ANGARC, ARCTC + USE W3ADATMD, ONLY: CX, CY, DCXDX, DCXDY, DCYDX, DCYDY + USE W3ODATMD, ONLY: NDSE, NDST + + IMPLICIT NONE + + INTEGER :: I, J, K, L, M, N + REAL :: CNST, CNST0, CNST1, CNST2, CNST3, CNST4, CNST5, CNST6 + REAL, Dimension(NSEA) :: CXCY, GrHx, GrHy + ! REAL, Dimension(-9:NSEA) :: CXCY + + !! Assign current CX speed to CXCY and set negative cells. + ! CXCY(-9:0) = 0.0 + !! Use zero-gradient boundary condition or L0r1 > 0 + L = 1 + CXCY(1:NSEA)= CX(1:NSEA) + + !! Initialize full grid gradient arrays + DCXDX = 0.0 + DCXDY = 0.0 + + !! Calculate sea point water depth gradient + CALL SMCGradn(CXCY, GrHx, GrHy, L) + + !! Apply limiter to CX-gradient and copy to full grid. +#ifdef W3_OMPG + !$OMP Parallel DO Private(i, j, k, m, n, CNST0, CNST1, CNST2) +#endif + DO n=1,NSEA + + ! A limiter of gradient <= 0.01 is applied. + IF( ABS( GrHx(n) ) .GT. 0.01) GrHx(n)=SIGN( 0.01, GrHx(n) ) + IF( ABS( GrHy(n) ) .GT. 0.01) GrHy(n)=SIGN( 0.01, GrHy(n) ) + + !Li Current gradient in the Arctic part has to be rotated into + !Li the map-east system for calculation of refraction. + IF( ARCTC .AND. n .GT. NGLO ) THEN + CNST0 = ANGARC(n - NGLO)*DERA + CNST1 = GrHx(n)*COS(CNST0) - GrHy(n)*SIN(CNST0) + CNST2 = GrHx(n)*SIN(CNST0) + GrHy(n)*COS(CNST0) + GrHx(n) = CNST1 + GrHy(n) = CNST2 + ENDIF -!! Asign CX gradients to full grid variable DCXDX/Y - i= IJKCel(1,n)/MRFct + 1 - j= IJKCel(2,n)/MRFct + 1 - k= MAX(1, IJKCel(3,n)/MRFct) - m= MAX(1, IJKCel(4,n)/MRFct) - DCXDX(j:j+m-1,i:i+k-1) = GrHx(n) - DCXDY(j:j+m-1,i:i+k-1) = GrHy(n) + !! Asign CX gradients to full grid variable DCXDX/Y + i= IJKCel(1,n)/MRFct + 1 + j= IJKCel(2,n)/MRFct + 1 + k= MAX(1, IJKCel(3,n)/MRFct) + m= MAX(1, IJKCel(4,n)/MRFct) + DCXDX(j:j+m-1,i:i+k-1) = GrHx(n) + DCXDY(j:j+m-1,i:i+k-1) = GrHy(n) - END DO + END DO #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP END Parallel DO #endif -!! Assign current CY speed to CXCY and set negative cells. -! CXCY(-9:0) = 0.0 -!! Use zero-gradient boundary condition or L0r1 > 0 - L = 1 - CXCY(1:NSEA)= CY(1:NSEA) + !! Assign current CY speed to CXCY and set negative cells. + ! CXCY(-9:0) = 0.0 + !! Use zero-gradient boundary condition or L0r1 > 0 + L = 1 + CXCY(1:NSEA)= CY(1:NSEA) -!! Initialize full grid gradient arrays - DCYDX = 0.0 - DCYDY = 0.0 + !! Initialize full grid gradient arrays + DCYDX = 0.0 + DCYDY = 0.0 -!! Calculate sea point water depth gradient - CALL SMCGradn(CXCY, GrHx, GrHy, L) + !! Calculate sea point water depth gradient + CALL SMCGradn(CXCY, GrHx, GrHy, L) -!! Apply limiter to CX-gradient and copy to full grid. + !! Apply limiter to CX-gradient and copy to full grid. #ifdef W3_OMPG -!$OMP Parallel DO Private(i, j, k, m, n, CNST0, CNST1, CNST2) + !$OMP Parallel DO Private(i, j, k, m, n, CNST0, CNST1, CNST2) #endif - DO n=1,NSEA + DO n=1,NSEA -!! A limiter of gradient <= 0.1 is applied. - IF( ABS( GrHx(n) ) .GT. 0.01) GrHx(n)=SIGN( 0.01, GrHx(n) ) - IF( ABS( GrHy(n) ) .GT. 0.01) GrHy(n)=SIGN( 0.01, GrHy(n) ) + !! A limiter of gradient <= 0.1 is applied. + IF( ABS( GrHx(n) ) .GT. 0.01) GrHx(n)=SIGN( 0.01, GrHx(n) ) + IF( ABS( GrHy(n) ) .GT. 0.01) GrHy(n)=SIGN( 0.01, GrHy(n) ) -!! Current gradient in the Arctic part has to be rotated into -!! the map-east system for calculation of refraction. - IF( ARCTC .AND. n .GT. NGLO ) THEN - CNST0 = ANGARC(n - NGLO)*DERA - CNST1 = GrHx(n)*COS(CNST0) - GrHy(n)*SIN(CNST0) - CNST2 = GrHx(n)*SIN(CNST0) + GrHy(n)*COS(CNST0) - GrHx(n) = CNST1 - GrHy(n) = CNST2 - ENDIF + !! Current gradient in the Arctic part has to be rotated into + !! the map-east system for calculation of refraction. + IF( ARCTC .AND. n .GT. NGLO ) THEN + CNST0 = ANGARC(n - NGLO)*DERA + CNST1 = GrHx(n)*COS(CNST0) - GrHy(n)*SIN(CNST0) + CNST2 = GrHx(n)*SIN(CNST0) + GrHy(n)*COS(CNST0) + GrHx(n) = CNST1 + GrHy(n) = CNST2 + ENDIF -!! Asign CX gradients to full grid variable DCXDX/Y - i= IJKCel(1,n)/MRFct + 1 - j= IJKCel(2,n)/MRFct + 1 - k= MAX(1, IJKCel(3,n)/MRFct) - m= MAX(1, IJKCel(4,n)/MRFct) - DCYDX(j:j+m-1,i:i+k-1) = GrHx(n) - DCYDY(j:j+m-1,i:i+k-1) = GrHy(n) + !! Asign CX gradients to full grid variable DCXDX/Y + i= IJKCel(1,n)/MRFct + 1 + j= IJKCel(2,n)/MRFct + 1 + k= MAX(1, IJKCel(3,n)/MRFct) + m= MAX(1, IJKCel(4,n)/MRFct) + DCYDX(j:j+m-1,i:i+k-1) = GrHx(n) + DCYDY(j:j+m-1,i:i+k-1) = GrHy(n) - END DO + END DO #ifdef W3_OMPG -!$OMP END Parallel DO + !$OMP END Parallel DO #endif #ifdef W3_T - 999 PRINT*, ' Sub SMCDCXY ended.' -#endif - - RETURN - END SUBROUTINE SMCDCXY - -!/ -!/ ------------------------------------------------------------------- / -!> @brief SMC version of W3GATH -!> -!> @details -!> Gather spectral bin information into a propagation field array. -!> Direct copy or communication calls (MPP version). -!> -!> @remarks -!> - The field is extracted but not converted. -!> - Array FIELD is not initialized. -!> - MPI version requires posing of send and receive calls in -!> W3WAVE to match local calls. -!> - MPI version does not require an MPI_TESTALL call for the -!> posted gather operation as MPI_WAITALL is mandatory to -!> reset persistent communication for next time step. -!> - MPI version allows only two new pre-fetch postings per -!> call to minimize chances to be slowed down by gathers that -!> are not yet needed, while maximizing the pre-loading -!> during the early (low-frequency) calls to the routine -!> where the amount of calculation needed for proagation is -!> the largest. -!> -!> @param[in] ISPEC Spectral bin considered -!> @param[out] FIELD Full field to be propagated -!> -!> @author Jian-Guo Li -!> @date 15 Mar 2011 -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3GATHSMC ( ISPEC, FIELD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jun-2006 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ 9-Dec-2010 : Adapted for SMC grid propagtion. JGLi -!/ -! 1. Purpose : -! -! Gather spectral bin information into a propagation field array. -! -! 2. Method : -! -! Direct copy or communication calls (MPP version). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISPEC Int. I Spectral bin considered. -! FIELD R.A. O Full field to be propagated. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_STARTALL, MPI_WAITALL -! Subr. mpif.h MPI persistent comm. routines (!/MPI). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The field is extracted but not converted. -! - Array FIELD is not initialized. -! - MPI version requires posing of send and receive calls in -! W3WAVE to match local calls. -! - MPI version does not require an MPI_TESTALL call for the -! posted gather operation as MPI_WAITALL is mandatory to -! reset persistent communication for next time step. -! - MPI version allows only two new pre-fetch postings per -! call to minimize chances to be slowed down by gathers that -! are not yet needed, while maximizing the pre-loading -! during the early (low-frequency) calls to the routine -! where the amount of calculation needed for proagation is -! the largest. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/MPIT MPI test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +999 PRINT*, ' Sub SMCDCXY ended.' +#endif + + RETURN + END SUBROUTINE SMCDCXY + + !/ + !/ ------------------------------------------------------------------- / + !> @brief SMC version of W3GATH + !> + !> @details + !> Gather spectral bin information into a propagation field array. + !> Direct copy or communication calls (MPP version). + !> + !> @remarks + !> - The field is extracted but not converted. + !> - Array FIELD is not initialized. + !> - MPI version requires posing of send and receive calls in + !> W3WAVE to match local calls. + !> - MPI version does not require an MPI_TESTALL call for the + !> posted gather operation as MPI_WAITALL is mandatory to + !> reset persistent communication for next time step. + !> - MPI version allows only two new pre-fetch postings per + !> call to minimize chances to be slowed down by gathers that + !> are not yet needed, while maximizing the pre-loading + !> during the early (low-frequency) calls to the routine + !> where the amount of calculation needed for proagation is + !> the largest. + !> + !> @param[in] ISPEC Spectral bin considered + !> @param[out] FIELD Full field to be propagated + !> + !> @author Jian-Guo Li + !> @date 15 Mar 2011 + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3GATHSMC ( ISPEC, FIELD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jun-2006 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) + !/ 9-Dec-2010 : Adapted for SMC grid propagtion. JGLi + !/ + ! 1. Purpose : + ! + ! Gather spectral bin information into a propagation field array. + ! + ! 2. Method : + ! + ! Direct copy or communication calls (MPP version). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISPEC Int. I Spectral bin considered. + ! FIELD R.A. O Full field to be propagated. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_STARTALL, MPI_WAITALL + ! Subr. mpif.h MPI persistent comm. routines (!/MPI). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - The field is extracted but not converted. + ! - Array FIELD is not initialized. + ! - MPI version requires posing of send and receive calls in + ! W3WAVE to match local calls. + ! - MPI version does not require an MPI_TESTALL call for the + ! posted gather operation as MPI_WAITALL is mandatory to + ! reset persistent communication for next time step. + ! - MPI version allows only two new pre-fetch postings per + ! call to minimize chances to be slowed down by gathers that + ! are not yet needed, while maximizing the pre-loading + ! during the early (low-frequency) calls to the routine + ! where the amount of calculation needed for proagation is + ! the largest. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for message passing method. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/MPIT MPI test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, NCel, MAPSF - USE W3WDATMD, ONLY: A => VA + !/ + USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, NCel, MAPSF + USE W3WDATMD, ONLY: A => VA #ifdef W3_MPI - USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & - NSPLOC, NRQSG2, IRQSG2, GSTORE - USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC + USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & + NSPLOC, NRQSG2, IRQSG2, GSTORE + USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC #endif -!/ - IMPLICIT NONE -! + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISPEC - REAL, INTENT(OUT) :: FIELD(NCel) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISPEC + REAL, INTENT(OUT) :: FIELD(NCel) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_SHRD - INTEGER :: ISEA, IXY + INTEGER :: ISEA, IXY #endif #ifdef W3_MPI - INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC), & - IOFF, IERR_MPI, JSEA, ISEA, & - IXY, IS0, IB0, NPST, J + INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC), & + IOFF, IERR_MPI, JSEA, ISEA, & + IXY, IS0, IB0, NPST, J #endif #ifdef W3_S - INTEGER, SAVE :: IENT + INTEGER, SAVE :: IENT #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3GATH') -#endif -! -! FIELD = 0. -! -! 1. Shared memory version ------------------------------------------ / -! -#ifdef W3_SHRD - DO ISEA=1, NSEA - FIELD(ISEA) = A(ISPEC,ISEA) - END DO + CALL STRACE (IENT, 'W3GATH') #endif -! + ! + ! FIELD = 0. + ! + ! 1. Shared memory version ------------------------------------------ / + ! #ifdef W3_SHRD - RETURN -#endif -! -! 2. Distributed memory version ( MPI ) ----------------------------- / -! 2.a Update counters -! -#ifdef W3_MPI - ISPLOC = ISPLOC + 1 - IBFLOC = IBFLOC + 1 - IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 -#endif -! -! 2.b Check status of present buffer -! 2.b.1 Scatter (send) still in progress, wait to end -! -#ifdef W3_MPI - IF ( BSTAT(IBFLOC) .EQ. 2 ) THEN - IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & - STATUS, IERR_MPI ) - BSTAT(IBFLOC) = 0 - END IF -#endif -! -! 2.b.2 Gather (recv) not yet posted, post now -! -#ifdef W3_MPI - IF ( BSTAT(IBFLOC) .EQ. 0 ) THEN - BSTAT(IBFLOC) = 1 - BISPL(IBFLOC) = ISPLOC - IOFF = 1 + (ISPLOC-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) - END IF -#endif -! -! 2.c Put local spectral densities in store -! -#ifdef W3_MPI - DO JSEA=1, NSEAL - GSTORE(IAPROC+(JSEA-1)*NAPROC,IBFLOC) = A(ISPEC,JSEA) - END DO -#endif -! -! 2.d Wait for remote spectral densities -! + DO ISEA=1, NSEA + FIELD(ISEA) = A(ISPEC,ISEA) + END DO + ! + RETURN +#endif + ! + ! 2. Distributed memory version ( MPI ) ----------------------------- / + ! 2.a Update counters + ! #ifdef W3_MPI + ISPLOC = ISPLOC + 1 + IBFLOC = IBFLOC + 1 + IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 + ! + ! 2.b Check status of present buffer + ! 2.b.1 Scatter (send) still in progress, wait to end + ! + IF ( BSTAT(IBFLOC) .EQ. 2 ) THEN IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI ) -#endif -! -! 2.e Convert storage array to field. -! -#ifdef W3_MPI - DO ISEA=1, NSEA - FIELD(ISEA) = GSTORE(ISEA,IBFLOC) - END DO -#endif -! -! 2.f Pre-fetch data in available buffers -! -#ifdef W3_MPI - IS0 = ISPLOC - IB0 = IBFLOC - NPST = 0 -#endif -! -#ifdef W3_MPI - DO J=1, MPIBUF-1 - IS0 = IS0 + 1 - IF ( IS0 .GT. NSPLOC ) EXIT - IB0 = 1 + MOD(IB0,MPIBUF) - IF ( BSTAT(IB0) .EQ. 0 ) THEN - BSTAT(IB0) = 1 - BISPL(IB0) = IS0 - IOFF = 1 + (IS0-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) - NPST = NPST + 1 - END IF - IF ( NPST .GE. 2 ) EXIT - END DO -#endif -! -#ifdef W3_MPI - RETURN -#endif -! -!/ End of W3GATHSMC ----------------------------------------------------- / -!/ - END SUBROUTINE W3GATHSMC -! -!/ ------------------------------------------------------------------- / -!> @brief SMC version of W3GATH -!> -!> @details -!> 'Scatter' data back to spectral storage after propagation. -!> Direct copy or communication calls (MPP version). -!> See also W3GATH. -!> -!> @param[in] ISPEC Spectral bin considered -!> @param[in] MAPSTA Status map for spatial grid -!> @param[in] FIELD SMC grid field to be propagated -!> -!> @remarks -!> - The field is put back but not converted ! -!> - MPI persistent communication calls initialize in W3MPII. -!> - See W3GATH and W3MPII for additional comments on data -!> buffering. -!> -!> @author Jian-Guo Li -!> @date 16 Jan 2012 -!> - SUBROUTINE W3SCATSMC ( ISPEC, MAPSTA, FIELD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jun-2006 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ 9-Dec-2010 : Adapted for SMC grid propagtion. JGLi09Dec2010 -!/ 16-Jan-2012 : Remove MAPSTA checking for SMC grid. JGLi16Jan2012 -!/ -!/ -! 1. Purpose : -! -! 'Scatter' data back to spectral storage after propagation. -! -! 2. Method : -! -! Direct copy or communication calls (MPP version). -! See also W3GATH. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISPEC Int. I Spectral bin considered. -! MAPSTA I.A. I Status map for spatial grid. -! FIELD R.A. I SMC grid field to be propagated. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_STARTALL, MPI_WAITALL, MPI_TESTALL -! Subr. mpif.h MPI persistent comm. routines (!/MPI). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The field is put back but not converted ! -! - MPI persistent communication calls initialize in W3MPII. -! - See W3GATH and W3MPII for additional comments on data -! buffering. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + BSTAT(IBFLOC) = 0 + END IF + ! + ! 2.b.2 Gather (recv) not yet posted, post now + ! + IF ( BSTAT(IBFLOC) .EQ. 0 ) THEN + BSTAT(IBFLOC) = 1 + BISPL(IBFLOC) = ISPLOC + IOFF = 1 + (ISPLOC-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) + END IF + ! + ! 2.c Put local spectral densities in store + ! + DO JSEA=1, NSEAL + GSTORE(IAPROC+(JSEA-1)*NAPROC,IBFLOC) = A(ISPEC,JSEA) + END DO + ! + ! 2.d Wait for remote spectral densities + ! + IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI ) + ! + ! 2.e Convert storage array to field. + ! + DO ISEA=1, NSEA + FIELD(ISEA) = GSTORE(ISEA,IBFLOC) + END DO + ! + ! 2.f Pre-fetch data in available buffers + ! + IS0 = ISPLOC + IB0 = IBFLOC + NPST = 0 + DO J=1, MPIBUF-1 + IS0 = IS0 + 1 + IF ( IS0 .GT. NSPLOC ) EXIT + IB0 = 1 + MOD(IB0,MPIBUF) + IF ( BSTAT(IB0) .EQ. 0 ) THEN + BSTAT(IB0) = 1 + BISPL(IB0) = IS0 + IOFF = 1 + (IS0-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) + NPST = NPST + 1 + END IF + IF ( NPST .GE. 2 ) EXIT + END DO + RETURN +#endif + ! + !/ End of W3GATHSMC ----------------------------------------------------- / + !/ + END SUBROUTINE W3GATHSMC + ! + !/ ------------------------------------------------------------------- / + !> @brief SMC version of W3GATH + !> + !> @details + !> 'Scatter' data back to spectral storage after propagation. + !> Direct copy or communication calls (MPP version). + !> See also W3GATH. + !> + !> @param[in] ISPEC Spectral bin considered + !> @param[in] MAPSTA Status map for spatial grid + !> @param[in] FIELD SMC grid field to be propagated + !> + !> @remarks + !> - The field is put back but not converted ! + !> - MPI persistent communication calls initialize in W3MPII. + !> - See W3GATH and W3MPII for additional comments on data + !> buffering. + !> + !> @author Jian-Guo Li + !> @date 16 Jan 2012 + !> + SUBROUTINE W3SCATSMC ( ISPEC, MAPSTA, FIELD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jun-2006 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) + !/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) + !/ 9-Dec-2010 : Adapted for SMC grid propagtion. JGLi09Dec2010 + !/ 16-Jan-2012 : Remove MAPSTA checking for SMC grid. JGLi16Jan2012 + !/ + !/ + ! 1. Purpose : + ! + ! 'Scatter' data back to spectral storage after propagation. + ! + ! 2. Method : + ! + ! Direct copy or communication calls (MPP version). + ! See also W3GATH. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISPEC Int. I Spectral bin considered. + ! MAPSTA I.A. I Status map for spatial grid. + ! FIELD R.A. I SMC grid field to be propagated. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_STARTALL, MPI_WAITALL, MPI_TESTALL + ! Subr. mpif.h MPI persistent comm. routines (!/MPI). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - The field is put back but not converted ! + ! - MPI persistent communication calls initialize in W3MPII. + ! - See W3GATH and W3MPII for additional comments on data + ! buffering. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for message passing method. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NCel, NSEAL, MAPSF - USE W3WDATMD, ONLY: A => VA -#ifdef W3_MPI - USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & - NSPLOC, NRQSG2, IRQSG2, SSTORE + USE W3SERVMD, ONLY: STRACE #endif - USE W3ODATMD, ONLY: NDST + !/ + USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NCel, NSEAL, MAPSF + USE W3WDATMD, ONLY: A => VA #ifdef W3_MPI - USE W3ODATMD, ONLY: IAPROC, NAPROC -#endif -!/ - IMPLICIT NONE -! + USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & + NSPLOC, NRQSG2, IRQSG2, SSTORE + USE W3ODATMD, ONLY: IAPROC, NAPROC +#endif + USE W3ODATMD, ONLY: NDST + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISPEC, MAPSTA(NY*NX) - REAL, INTENT(IN) :: FIELD(NCel) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISPEC, MAPSTA(NY*NX) + REAL, INTENT(IN) :: FIELD(NCel) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_SHRD - INTEGER :: ISEA, IXY + INTEGER :: ISEA, IXY #endif #ifdef W3_MPI - INTEGER :: ISEA, IXY, IOFF, IERR_MPI, J, & - STATUS(MPI_STATUS_SIZE,NSPEC), & - JSEA, IB0 + INTEGER :: ISEA, IXY, IOFF, IERR_MPI, J, & + STATUS(MPI_STATUS_SIZE,NSPEC), & + JSEA, IB0 #endif #ifdef W3_S - INTEGER, SAVE :: IENT + INTEGER, SAVE :: IENT #endif #ifdef W3_MPI - LOGICAL :: DONE + LOGICAL :: DONE #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SCAT') + CALL STRACE (IENT, 'W3SCAT') #endif -! -! 1. Shared memory version ------------------------------------------ * -! + ! + ! 1. Shared memory version ------------------------------------------ * + ! #ifdef W3_SHRD - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .GE. 1 ) A(ISPEC,ISEA) = FIELD(ISEA) - END DO -#endif -! -#ifdef W3_SHRD - RETURN -#endif -! -! 2. Distributed memory version ( MPI ) ----------------------------- * -! 2.a Initializations -! -! 2.b Convert full grid to sea grid, active points only -! -#ifdef W3_MPI - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .GE. 1 ) SSTORE(ISEA,IBFLOC) = FIELD(ISEA) - END DO -#endif -! -! 2.c Send spectral densities to appropriate remote -! -#ifdef W3_MPI - IOFF = 1 + (ISPLOC-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI ) - BSTAT(IBFLOC) = 2 -#endif -! -! 2.d Save locally stored results -! + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .GE. 1 ) A(ISPEC,ISEA) = FIELD(ISEA) + END DO + ! + RETURN +#endif + ! + ! 2. Distributed memory version ( MPI ) ----------------------------- * + ! 2.a Initializations + ! + ! 2.b Convert full grid to sea grid, active points only + ! #ifdef W3_MPI - DO JSEA=1, NSEAL - !!Li ISEA = IAPROC+(JSEA-1)*NAPROC - ISEA = MIN( IAPROC+(JSEA-1)*NAPROC, NSEA ) - A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC) - END DO -#endif -! -! 2.e Check if any sends have finished -! -#ifdef W3_MPI - IB0 = IBFLOC + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .GE. 1 ) SSTORE(ISEA,IBFLOC) = FIELD(ISEA) + END DO + ! + ! 2.c Send spectral densities to appropriate remote + ! + IOFF = 1 + (ISPLOC-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI ) + BSTAT(IBFLOC) = 2 + ! + ! 2.d Save locally stored results + ! + DO JSEA=1, NSEAL + !!Li ISEA = IAPROC+(JSEA-1)*NAPROC + ISEA = MIN( IAPROC+(JSEA-1)*NAPROC, NSEA ) + A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC) + END DO + ! + ! 2.e Check if any sends have finished + ! + IB0 = IBFLOC + ! + DO J=1, MPIBUF + IB0 = 1 + MOD(IB0,MPIBUF) + IF ( BSTAT(IB0) .EQ. 2 ) THEN + IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) THEN + CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, & + STATUS, IERR_MPI ) + ELSE + DONE = .TRUE. + END IF + IF ( DONE .AND. NRQSG2.GT.0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + IF ( DONE ) THEN + BSTAT(IB0) = 0 + END IF + END IF + END DO #endif -! + ! + ! 2.f Last component, finish message passing, reset buffer control + ! #ifdef W3_MPI - DO J=1, MPIBUF - IB0 = 1 + MOD(IB0,MPIBUF) + IF ( ISPLOC .EQ. NSPLOC ) THEN + DO IB0=1, MPIBUF IF ( BSTAT(IB0) .EQ. 2 ) THEN - IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) THEN - CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, & - STATUS, IERR_MPI ) - ELSE - DONE = .TRUE. - END IF - IF ( DONE .AND. NRQSG2.GT.0 ) CALL & - MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & - STATUS, IERR_MPI ) - IF ( DONE ) THEN - BSTAT(IB0) = 0 - END IF - END IF - END DO -#endif -! -! 2.f Last component, finish message passing, reset buffer control -! -#ifdef W3_MPI - IF ( ISPLOC .EQ. NSPLOC ) THEN -#endif -! -#ifdef W3_MPI - DO IB0=1, MPIBUF - IF ( BSTAT(IB0) .EQ. 2 ) THEN - IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & - STATUS, IERR_MPI ) - BSTAT(IB0) = 0 - END IF - END DO -#endif -! -#ifdef W3_MPI - ISPLOC = 0 - IBFLOC = 0 -#endif -! -#ifdef W3_MPI + IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + BSTAT(IB0) = 0 END IF -#endif -! -#ifdef W3_MPI - RETURN -#endif -! -! Formats -! -!/ -!/ End of W3SCATSMC ----------------------------------------------------- / -!/ - END SUBROUTINE W3SCATSMC -!/ -!/ End of two new subs for SMC grid. JGLi 15Mar2011 -!/ - -!> @brief Calculate cell centre lat-lon for given ids. -!> -!> @details -!> Calculate the cell centre longitude and latitude in degree for a given -!> list of cell identity or sequential numbers in the IMOD sub-grid. -!> -!> Regular grid SX, SY, X0, Y0 and SMC grid MRFct and IJKCel arrays -!> in W3GDATMD are used to work out SMC grid origin and increments. -!> Then given cell centre coordinates are calculated. Longitude is -!> wrapped into [0, 360) range, latitude in in (-90, 90) range. -!> The polar cell centre is off the N-Pole to avoid singularity but -!> its centre values are not used for propagation schemes. -!> -!> @param[in] IMOD Model number to point to -!> @param[in] NC Numcer of cells to be calculated -!> @param[in] IDCl List of cell id or sequential numbers -!> @param[out] XLon X-Longitude in degree of listed cells -!> @param[out] YLat Y-Latitude in degree of listed cells -!> -!> @author Jian-Guo Li -!> @date 19 Oct 2020 -!> - SUBROUTINE W3SMCELL( IMOD, NC, IDCl, XLon, YLat ) -!! ------------------------------------------------------------------- -!! -!! Generated for WW3 Multi-grid boundary matching. JGLi19Oct2020 -!! -!! 1. Purpose: -! -! Calculate the cell centre longitude and latitude in degree for a given -! list of cell identity or sequential numbers in the IMOD sub-grid. -! -!! 2. Method: -! -! Regular grid SX, SY, X0, Y0 and SMC grid MRFct and IJKCel arrays -! in W3GDATMD are used to work out SMC grid origin and increments. -! Then given cell centre coordinates are calculated. Longitude is -! wrapped into [0, 360) range, latitude in in (-90, 90) range. -! The polar cell centre is off the N-Pole to avoid singularity but -! its centre values are not used for propagation schemes. -! -!! 3. Parameters: -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NC Int. I Numcer of cells to be calculated. -! IDCl Int. I List of cell id or sequential numbers. -! XLon Real O X-Longitude in degree of listed cells. -! YLat Real O Y-Latitude in degree of listed cells. -! ---------------------------------------------------------------- -! -!! 4. Subroutines used: -! -! None -! -!! 5. Called by: -! -! WMGLOW, W3IOPP, WMIOPP, WW3_GINT -! -!! 6. Error messages: -! -! - Error checks on previous setting of variable. -! -!! 7. Remarks: -! -!! 8. Structure: -! -!! 9. Switches: -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code: -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE, NDST + END DO + ISPLOC = 0 + IBFLOC = 0 + END IF + RETURN +#endif + ! + ! Formats + ! + !/ + !/ End of W3SCATSMC ----------------------------------------------------- / + !/ + END SUBROUTINE W3SCATSMC + !/ + !/ End of two new subs for SMC grid. JGLi 15Mar2011 + !/ + + !> @brief Calculate cell centre lat-lon for given ids. + !> + !> @details + !> Calculate the cell centre longitude and latitude in degree for a given + !> list of cell identity or sequential numbers in the IMOD sub-grid. + !> + !> Regular grid SX, SY, X0, Y0 and SMC grid MRFct and IJKCel arrays + !> in W3GDATMD are used to work out SMC grid origin and increments. + !> Then given cell centre coordinates are calculated. Longitude is + !> wrapped into [0, 360) range, latitude in in (-90, 90) range. + !> The polar cell centre is off the N-Pole to avoid singularity but + !> its centre values are not used for propagation schemes. + !> + !> @param[in] IMOD Model number to point to + !> @param[in] NC Numcer of cells to be calculated + !> @param[in] IDCl List of cell id or sequential numbers + !> @param[out] XLon X-Longitude in degree of listed cells + !> @param[out] YLat Y-Latitude in degree of listed cells + !> + !> @author Jian-Guo Li + !> @date 19 Oct 2020 + !> + SUBROUTINE W3SMCELL( IMOD, NC, IDCl, XLon, YLat ) + !! ------------------------------------------------------------------- + !! + !! Generated for WW3 Multi-grid boundary matching. JGLi19Oct2020 + !! + !! 1. Purpose: + ! + ! Calculate the cell centre longitude and latitude in degree for a given + ! list of cell identity or sequential numbers in the IMOD sub-grid. + ! + !! 2. Method: + ! + ! Regular grid SX, SY, X0, Y0 and SMC grid MRFct and IJKCel arrays + ! in W3GDATMD are used to work out SMC grid origin and increments. + ! Then given cell centre coordinates are calculated. Longitude is + ! wrapped into [0, 360) range, latitude in in (-90, 90) range. + ! The polar cell centre is off the N-Pole to avoid singularity but + ! its centre values are not used for propagation schemes. + ! + !! 3. Parameters: + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NC Int. I Numcer of cells to be calculated. + ! IDCl Int. I List of cell id or sequential numbers. + ! XLon Real O X-Longitude in degree of listed cells. + ! YLat Real O Y-Latitude in degree of listed cells. + ! ---------------------------------------------------------------- + ! + !! 4. Subroutines used: + ! + ! None + ! + !! 5. Called by: + ! + ! WMGLOW, W3IOPP, WMIOPP, WW3_GINT + ! + !! 6. Error messages: + ! + ! - Error checks on previous setting of variable. + ! + !! 7. Remarks: + ! + !! 8. Structure: + ! + !! 9. Switches: + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code: + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE, NDST #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE + IMPLICIT NONE -!/ ------------------------------------------------------------------- / -! Input/Output variables + !/ ------------------------------------------------------------------- / + ! Input/Output variables - INTEGER, INTENT(IN) :: IMOD, NC - INTEGER, INTENT(in), Dimension(NC):: IDCl ! Automatic array - REAL , INTENT(out),Dimension(NC):: XLon, YLat -!/ ------------------------------------------------------------------- / -! Local variables. + INTEGER, INTENT(IN) :: IMOD, NC + INTEGER, INTENT(in), Dimension(NC):: IDCl ! Automatic array + REAL , INTENT(out),Dimension(NC):: XLon, YLat + !/ ------------------------------------------------------------------- / + ! Local variables. - REAL :: XI0, YJ0, DXG, DYG, DX1, DY1 - INTEGER :: I1, I3, J2, J4, MRF, ij, ijp, NSEM + REAL :: XI0, YJ0, DXG, DYG, DX1, DY1 + INTEGER :: I1, I3, J2, J4, MRF, ij, ijp, NSEM #ifdef W3_S - INTEGER :: IENT = 0 - CALL STRACE (IENT, 'W3SMCELL') -#endif - -!! 1. Convert regular grid parameters into SMC grid origin and increments. - DXG = GRIDS(IMOD)%SX - DYG = GRIDS(IMOD)%SY - XI0 = GRIDS(IMOD)%X0 - 0.5*DXG - YJ0 = GRIDS(IMOD)%Y0 - 0.5*DYG - MRF = GRIDS(IMOD)%MRFct - DX1 = DXG/Real(MRF) - DY1 = DYG/Real(MRF) - NSEM = GRIDS(IMOD)%NSEA - -!! 2. Loop over listed cells and work out their centre coordinates. - -#ifdef W3_OMPG -!$OMP Parallel DO Private(ij, ijp, I1, J2, I3, J4 ) -#endif - DO ij = 1, NC - ijp = IDCL(ij) -!!Li Return South Pole lon-lat values for any ids < 1 or > NSEA -!! so these out of range points will not be matched to any cell. - IF( ijp < 1 .OR. ijp > NSEM ) THEN - XLon(ij) = 0.0 - YLat(ij) = -90.0 - ELSE -!! Fetch cell array indexes from given sub-grid. - I1=GRIDS(IMOD)%IJKCel(1, ijp) - J2=GRIDS(IMOD)%IJKCel(2, ijp) - I3=GRIDS(IMOD)%IJKCel(3, ijp) - J4=GRIDS(IMOD)%IJKCel(4, ijp) - -!! Calculate its cell centre lon-lat values. - XLon(ij) = XI0 + ( FLOAT(I1) + 0.5*FLOAT(I3) )*DX1 - YLat(ij) = YJ0 + ( FLOAT(J2) + 0.5*FLOAT(J4) )*DY1 - ENDIF - END DO -#ifdef W3_OMPG -!$OMP END Parallel DO + INTEGER :: IENT = 0 + CALL STRACE (IENT, 'W3SMCELL') #endif -!! 3. Wrap negative logitudes into [0, 360) range. - WHERE( XLon < 0.0 ) XLon = XLon + 360.0 -! - RETURN - END SUBROUTINE W3SMCELL -!! - -!! -!> @brief Map lat-lon points to SMC grid cells -!> -!> @details -!> Determine whether a list of points are inside the IMOD SMC sub-grid -!> and return the IMOD sub-grid cell indexes, if any. -!> -!> Convert point XLon and YLat values into cell indices i, j. -!> Match with cell ranges (i,i+di) and (j,j+dj) to see i,j in -!> which cell. Return the matched cell number. Otherwise, -!> return an index of 0, or no matching cell found. -!> -!> @param[in] IMOD Model number to point to -!> @param[in] XLon X-Longitude in degree of search points -!> @param[in] YLat Y-Latitude in degree of search points -!> @param[in] NC Number of points to be searched -!> @param[out] IDCl Model number to point to -!> -!> @author Jian-Guo Li -!> @date 20 Oct 2020 -!> - SUBROUTINE W3SMCGMP( IMOD, NC, XLon, YLat, IDCl ) -!! ------------------------------------------------------------------- -!! -!! Generated for WW3 Multi-grid boundary matching. JGLi22Oct2020 -!! -!! 1. Purpose: -! -! Determine whether a list of points are inside the IMOD SMC sub-grid -! and return the IMOD sub-grid cell indexes, if any. -! -!! 2. Method: -! -! Convert point XLon and YLat values into cell indices i, j. -! Match with cell ranges (i,i+di) and (j,j+dj) to see i,j in -! which cell. Return the matched cell number. Otherwide, -! return an index of 0, or no matching cell found. -! -!! 3. Parameters: -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! XLon Real I X-Longitude in degree of search points. -! YLat Real I Y-Latitude in degree of search points. -! NC Int. I Number of points to be searched. -! IDCl Int. O Model number to point to. -! ---------------------------------------------------------------- -! -!! 4. Subroutines used: -! -! None -! -!! 5. Called by: -! -! WMGLOW, W3IOPP, WMIOPP, WW3_GINT -! -!! 6. Error messages: -! -! - Error checks on previous setting of variable. -! -!! 7. Remarks: -! -!! 8. Structure: -! -!! 9. Switches: -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code: -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE, NDST + !! 1. Convert regular grid parameters into SMC grid origin and increments. + DXG = GRIDS(IMOD)%SX + DYG = GRIDS(IMOD)%SY + XI0 = GRIDS(IMOD)%X0 - 0.5*DXG + YJ0 = GRIDS(IMOD)%Y0 - 0.5*DYG + MRF = GRIDS(IMOD)%MRFct + DX1 = DXG/Real(MRF) + DY1 = DYG/Real(MRF) + NSEM = GRIDS(IMOD)%NSEA + + !! 2. Loop over listed cells and work out their centre coordinates. + +#ifdef W3_OMPG + !$OMP Parallel DO Private(ij, ijp, I1, J2, I3, J4 ) +#endif + DO ij = 1, NC + ijp = IDCL(ij) + !!Li Return South Pole lon-lat values for any ids < 1 or > NSEA + !! so these out of range points will not be matched to any cell. + IF( ijp < 1 .OR. ijp > NSEM ) THEN + XLon(ij) = 0.0 + YLat(ij) = -90.0 + ELSE + !! Fetch cell array indexes from given sub-grid. + I1=GRIDS(IMOD)%IJKCel(1, ijp) + J2=GRIDS(IMOD)%IJKCel(2, ijp) + I3=GRIDS(IMOD)%IJKCel(3, ijp) + J4=GRIDS(IMOD)%IJKCel(4, ijp) + + !! Calculate its cell centre lon-lat values. + XLon(ij) = XI0 + ( FLOAT(I1) + 0.5*FLOAT(I3) )*DX1 + YLat(ij) = YJ0 + ( FLOAT(J2) + 0.5*FLOAT(J4) )*DY1 + ENDIF + END DO +#ifdef W3_OMPG + !$OMP END Parallel DO +#endif + + !! 3. Wrap negative logitudes into [0, 360) range. + WHERE( XLon < 0.0 ) XLon = XLon + 360.0 + ! + RETURN + END SUBROUTINE W3SMCELL + !! + + !! + !> @brief Map lat-lon points to SMC grid cells + !> + !> @details + !> Determine whether a list of points are inside the IMOD SMC sub-grid + !> and return the IMOD sub-grid cell indexes, if any. + !> + !> Convert point XLon and YLat values into cell indices i, j. + !> Match with cell ranges (i,i+di) and (j,j+dj) to see i,j in + !> which cell. Return the matched cell number. Otherwise, + !> return an index of 0, or no matching cell found. + !> + !> @param[in] IMOD Model number to point to + !> @param[in] XLon X-Longitude in degree of search points + !> @param[in] YLat Y-Latitude in degree of search points + !> @param[in] NC Number of points to be searched + !> @param[out] IDCl Model number to point to + !> + !> @author Jian-Guo Li + !> @date 20 Oct 2020 + !> + SUBROUTINE W3SMCGMP( IMOD, NC, XLon, YLat, IDCl ) + !! ------------------------------------------------------------------- + !! + !! Generated for WW3 Multi-grid boundary matching. JGLi22Oct2020 + !! + !! 1. Purpose: + ! + ! Determine whether a list of points are inside the IMOD SMC sub-grid + ! and return the IMOD sub-grid cell indexes, if any. + ! + !! 2. Method: + ! + ! Convert point XLon and YLat values into cell indices i, j. + ! Match with cell ranges (i,i+di) and (j,j+dj) to see i,j in + ! which cell. Return the matched cell number. Otherwide, + ! return an index of 0, or no matching cell found. + ! + !! 3. Parameters: + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! XLon Real I X-Longitude in degree of search points. + ! YLat Real I Y-Latitude in degree of search points. + ! NC Int. I Number of points to be searched. + ! IDCl Int. O Model number to point to. + ! ---------------------------------------------------------------- + ! + !! 4. Subroutines used: + ! + ! None + ! + !! 5. Called by: + ! + ! WMGLOW, W3IOPP, WMIOPP, WW3_GINT + ! + !! 6. Error messages: + ! + ! - Error checks on previous setting of variable. + ! + !! 7. Remarks: + ! + !! 8. Structure: + ! + !! 9. Switches: + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code: + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE, NDST #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE + IMPLICIT NONE -!/ ------------------------------------------------------------------- / -! Iuput/Output variables - INTEGER, INTENT(IN) :: IMOD, NC - REAL , INTENT(in), Dimension(NC):: XLon, YLat - INTEGER, INTENT(out), Dimension(NC):: IDCl -!/ ------------------------------------------------------------------- / -! Local variables - INTEGER, Dimension(NC) :: IX1, JY1 - REAL :: XI0, YJ0, DXG, DYG, DX1, DY1, XLow(NC) - INTEGER :: I1, I3, J2, J4, ij, ijp, MRF, NSEM, NFund + !/ ------------------------------------------------------------------- / + ! Iuput/Output variables + INTEGER, INTENT(IN) :: IMOD, NC + REAL , INTENT(in), Dimension(NC):: XLon, YLat + INTEGER, INTENT(out), Dimension(NC):: IDCl + !/ ------------------------------------------------------------------- / + ! Local variables + INTEGER, Dimension(NC) :: IX1, JY1 + REAL :: XI0, YJ0, DXG, DYG, DX1, DY1, XLow(NC) + INTEGER :: I1, I3, J2, J4, ij, ijp, MRF, NSEM, NFund #ifdef W3_S - INTEGER :: IENT = 0 - CALL STRACE (IENT, 'W3SMCGMP') -#endif - -!! 1. Convert XLon YLat into SMC grid indexes in present SMC grid. - DXG = GRIDS(IMOD)%SX - DYG = GRIDS(IMOD)%SY - XI0 = GRIDS(IMOD)%X0 - 0.5*DXG - YJ0 = GRIDS(IMOD)%Y0 - 0.5*DYG - MRF = GRIDS(IMOD)%MRFct - DX1 = DXG/Real(MRF) - DY1 = DYG/Real(MRF) - NSEM = GRIDS(IMOD)%NSEA - -!! Wrap longitude so they are great than XI0. - XLow = XLon - WHERE( XLow < XI0 ) XLow = XLow + 360.0 - -!! Convert XLon and YLat into SMC indexes. - IX1 = FLOOR( (XLow - XI0)/DX1 ) - JY1 = FLOOR( (YLat - YJ0)/DY1 ) - -!! Initialise IDCl to be all 0 - IDCl = 0 - -!! 2. Loop over all cells until all input points are found. - NFund = 0 - ij = 0 - DO WHILE( ij < NSEM .AND. NFund < NC ) - ij = ij + 1 - I1=GRIDS(IMOD)%IJKCel(1, ij) - J2=GRIDS(IMOD)%IJKCel(2, ij) - I3=GRIDS(IMOD)%IJKCel(3, ij) - J4=GRIDS(IMOD)%IJKCel(4, ij) - LPNBIS: DO ijp = 1, NC - IF( IDCl(ijp) .EQ. 0 ) THEN -!! Check if IX1 and JY1 fall inside the cell i,j range. - IF((IX1(ijp) .GE. I1) .AND. (IX1(ijp) .LT. I1+I3) .AND. & - (JY1(ijp) .GE. J2) .AND. (JY1(ijp) .LT. J2+J4)) THEN - NFund = NFund + 1 - IDCl(ijp) = ij - EXIT LPNBIS - ENDIF - ENDIF - END DO LPNBIS - END DO - -!! If any IDCl element remians to be 0, it means no cell is found -!! covering this point. So check IDCl(ij) > 0 to ensure in grid. + INTEGER :: IENT = 0 + CALL STRACE (IENT, 'W3SMCGMP') +#endif + + !! 1. Convert XLon YLat into SMC grid indexes in present SMC grid. + DXG = GRIDS(IMOD)%SX + DYG = GRIDS(IMOD)%SY + XI0 = GRIDS(IMOD)%X0 - 0.5*DXG + YJ0 = GRIDS(IMOD)%Y0 - 0.5*DYG + MRF = GRIDS(IMOD)%MRFct + DX1 = DXG/Real(MRF) + DY1 = DYG/Real(MRF) + NSEM = GRIDS(IMOD)%NSEA + + !! Wrap longitude so they are great than XI0. + XLow = XLon + WHERE( XLow < XI0 ) XLow = XLow + 360.0 + + !! Convert XLon and YLat into SMC indexes. + IX1 = FLOOR( (XLow - XI0)/DX1 ) + JY1 = FLOOR( (YLat - YJ0)/DY1 ) + + !! Initialise IDCl to be all 0 + IDCl = 0 + + !! 2. Loop over all cells until all input points are found. + NFund = 0 + ij = 0 + DO WHILE( ij < NSEM .AND. NFund < NC ) + ij = ij + 1 + I1=GRIDS(IMOD)%IJKCel(1, ij) + J2=GRIDS(IMOD)%IJKCel(2, ij) + I3=GRIDS(IMOD)%IJKCel(3, ij) + J4=GRIDS(IMOD)%IJKCel(4, ij) + LPNBIS: DO ijp = 1, NC + IF( IDCl(ijp) .EQ. 0 ) THEN + !! Check if IX1 and JY1 fall inside the cell i,j range. + IF((IX1(ijp) .GE. I1) .AND. (IX1(ijp) .LT. I1+I3) .AND. & + (JY1(ijp) .GE. J2) .AND. (JY1(ijp) .LT. J2+J4)) THEN + NFund = NFund + 1 + IDCl(ijp) = ij + EXIT LPNBIS + ENDIF + ENDIF + END DO LPNBIS + END DO - RETURN + !! If any IDCl element remians to be 0, it means no cell is found + !! covering this point. So check IDCl(ij) > 0 to ensure in grid. - END SUBROUTINE W3SMCGMP -!! + RETURN -!/ End of module W3PSMCMD -------------------------------------------- / -!/ - END MODULE W3PSMCMD + END SUBROUTINE W3SMCGMP + !! + !/ End of module W3PSMCMD -------------------------------------------- / + !/ +END MODULE W3PSMCMD diff --git a/model/src/w3ref1md.F90 b/model/src/w3ref1md.F90 index b29ceb56a..11f4f8961 100644 --- a/model/src/w3ref1md.F90 +++ b/model/src/w3ref1md.F90 @@ -1,437 +1,430 @@ !/ ------------------------------------------------------------------- / - MODULE W3REF1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 27-Jun-2014 | -!/ +-----------------------------------+ -!/ -!/ 31-Mar-2010 : Origination. ( version 3.14.IFREMER ) -!/ 03-Sep-2010 : Clean up ( version 3.14.IFREMER ) -!/ 31-May-2011 : Adding variable reflections ( version 4.01 ) -!/ 02-Nov-2011 : Compatibility with unst. grids ( version 4.04 ) -!/ 24-Fev-2012 : Correction of angle in fluxes ( version 4.05 ) -!/ 27-Jul-2013 : Adding free infragravity waves ( version 4.11 ) -!/ 11-Nov-2013 : Extends IG energy into main band ( version 4.13 ) -!/ 11-Jun-2014 : Put reflection by subgrids back ( version 5.01 ) -!/ 27-Jun-2014 : Modifies subgrid reflection of IG ( version 5.01 ) -!/ -! 1. Purpose : -! -! This module computes : -! - shoreline reflection -! - unresolved islands and iceberg reflections -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SREF Subr. Public Reflection of waves (shorline, islands...) -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! - PUBLIC -!/ -!/ Public variables -!/ -! -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SREF(A, CG, WN, EMEAN, FMEAN, DEPTH, CX1, CY1, REFLC, REFLD, & - TRNX, TRNY, BERG, DT, IX, IY,S) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 11-Jun-2014 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2010 : Origination. ( version 3.14-Ifremer ) -!/ 31-May-2011 : Introduction of amplitude-dependent R ( version 4.05 ) -!/ 27-Jul-2013 : Adding free infragravity waves ( version 4.11 ) -!/ 11-Nov-2013 : Expands IG energy frequency range ( version 4.13 ) -!/ 05-Mar-2014 : Fixing bug with ICALC = 1 and IG1 ( version 4.18 ) -!/ 11-Jun-2014 : Put reflection by subgrids back ( version 5.01 ) -!/ -! 1. Purpose : -! -! Computes coastal and iceberg/island reflections and adds free IG energy -! -! 2. Method : -! -! Adds the reflected components from 2 types of sources: -! shoreline reflection, subgrid obstruction and icebergs -! -! In the case where the IG switch is present, there are two passes: -! - ICALC = 1, only the wind sea and swell are reflected (no IG added) -! - ICALC = 2, IG energy is added into all frequency bands -! -! -! When IG energy is put in the entire spectrum ( NINT(IGPARS(4)).EQ.2 ) -! two passes are done: the first for the reflection of windsea and swell -! the second for the addition of IG and IG reflection alone -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! DEPTH Real I Mean water depth. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, SMCTYPE, & - REFPARS, ECOS, ESIN, EC2, MAPTH, MAPWN, FLAGLL, & - SIG2, DSII, IOBPD, GTYPE, UNGTYPE, MAPFS, CLGTYPE, RLGTYPE - USE W3GDATMD, ONLY : CLATS, HPFAC, HQFAC, SX, SY, SI +MODULE W3REF1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 27-Jun-2014 | + !/ +-----------------------------------+ + !/ + !/ 31-Mar-2010 : Origination. ( version 3.14.IFREMER ) + !/ 03-Sep-2010 : Clean up ( version 3.14.IFREMER ) + !/ 31-May-2011 : Adding variable reflections ( version 4.01 ) + !/ 02-Nov-2011 : Compatibility with unst. grids ( version 4.04 ) + !/ 24-Fev-2012 : Correction of angle in fluxes ( version 4.05 ) + !/ 27-Jul-2013 : Adding free infragravity waves ( version 4.11 ) + !/ 11-Nov-2013 : Extends IG energy into main band ( version 4.13 ) + !/ 11-Jun-2014 : Put reflection by subgrids back ( version 5.01 ) + !/ 27-Jun-2014 : Modifies subgrid reflection of IG ( version 5.01 ) + !/ + ! 1. Purpose : + ! + ! This module computes : + ! - shoreline reflection + ! - unresolved islands and iceberg reflections + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SREF Subr. Public Reflection of waves (shorline, islands...) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + PUBLIC + !/ + !/ Public variables + !/ + ! + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SREF(A, CG, WN, EMEAN, FMEAN, DEPTH, CX1, CY1, REFLC, REFLD, & + TRNX, TRNY, BERG, DT, IX, IY,S) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 11-Jun-2014 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2010 : Origination. ( version 3.14-Ifremer ) + !/ 31-May-2011 : Introduction of amplitude-dependent R ( version 4.05 ) + !/ 27-Jul-2013 : Adding free infragravity waves ( version 4.11 ) + !/ 11-Nov-2013 : Expands IG energy frequency range ( version 4.13 ) + !/ 05-Mar-2014 : Fixing bug with ICALC = 1 and IG1 ( version 4.18 ) + !/ 11-Jun-2014 : Put reflection by subgrids back ( version 5.01 ) + !/ + ! 1. Purpose : + ! + ! Computes coastal and iceberg/island reflections and adds free IG energy + ! + ! 2. Method : + ! + ! Adds the reflected components from 2 types of sources: + ! shoreline reflection, subgrid obstruction and icebergs + ! + ! In the case where the IG switch is present, there are two passes: + ! - ICALC = 1, only the wind sea and swell are reflected (no IG added) + ! - ICALC = 2, IG energy is added into all frequency bands + ! + ! + ! When IG energy is put in the entire spectrum ( NINT(IGPARS(4)).EQ.2 ) + ! two passes are done: the first for the reflection of windsea and swell + ! the second for the addition of IG and IG reflection alone + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! DEPTH Real I Mean water depth. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, SMCTYPE, & + REFPARS, ECOS, ESIN, EC2, MAPTH, MAPWN, FLAGLL, & + SIG2, DSII, IOBPD, GTYPE, UNGTYPE, MAPFS, CLGTYPE, RLGTYPE + USE W3GDATMD, ONLY : CLATS, HPFAC, HQFAC, SX, SY, SI #ifdef W3_PDLIB - USE YOWNODEPOOL, ONLY: PDLIB_SI - USE W3GDATMD, ONLY: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE YOWNODEPOOL, ONLY: PDLIB_SI + USE W3GDATMD, ONLY: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC #endif #ifdef W3_IG1 - USE W3GDATMD, ONLY : IGPARS - USE W3GIG1MD - USE W3CANOMD, ONLY : W3ADD2NDORDER - USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE + USE W3GDATMD, ONLY : IGPARS + USE W3GIG1MD + USE W3CANOMD, ONLY : W3ADD2NDORDER + USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, EMEAN, FMEAN - REAL, INTENT(INOUT) :: A(NSPEC) - REAL, INTENT(IN) :: CX1, CY1, DT - INTEGER, INTENT(IN) :: REFLD(6), IX, IY - REAL, INTENT(IN) :: REFLC(4), TRNX, & - TRNY, BERG - REAL, INTENT(OUT) :: S(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISPECI, ISPEC, IK, ITH, ITH2, ITH3, ITH2X, ITH2Y, & - NRS, IK1 - INTEGER :: ISEA, ICALC, IOBPDIP(NTH) -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - LOGICAL :: IGBCOVERWRITE, IGSWELLMAX - REAL :: R1, R2, R3, R4, R2X, R2Y, DEPTHIG - REAL :: DELA, DELX, DELY, FACX - REAL :: FAC1, FAC2, FAC3, FAC4, RAMP0, RAMP, & - RAMP1, RAMP2, RAMP4, MICHEFAC, SLOPE - REAL :: HS, HIG, HIG1, HIG2, EB, SB, EMEANA, FMEAN2, & - FMEANA, FREQIG, EFIG, EFIG1, SQRTH, SMEANA + !/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, EMEAN, FMEAN + REAL, INTENT(INOUT) :: A(NSPEC) + REAL, INTENT(IN) :: CX1, CY1, DT + INTEGER, INTENT(IN) :: REFLD(6), IX, IY + REAL, INTENT(IN) :: REFLC(4), TRNX, & + TRNY, BERG + REAL, INTENT(OUT) :: S(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISPECI, ISPEC, IK, ITH, ITH2, ITH3, ITH2X, ITH2Y, & + NRS, IK1 + INTEGER :: ISEA, ICALC, IOBPDIP(NTH) + LOGICAL :: IGBCOVERWRITE, IGSWELLMAX + REAL :: R1, R2, R3, R4, R2X, R2Y, DEPTHIG + REAL :: DELA, DELX, DELY, FACX + REAL :: FAC1, FAC2, FAC3, FAC4, RAMP0, RAMP, & + RAMP1, RAMP2, RAMP4, MICHEFAC, SLOPE + REAL :: HS, HIG, HIG1, HIG2, EB, SB, EMEANA, FMEAN2, & + FMEANA, FREQIG, EFIG, EFIG1, SQRTH, SMEANA #ifdef W3_IG1 INTEGER :: NKIG,NSPECIG,NSPECIGSTART, I1, I2 REAL :: ATMP(NSPEC),ATMP2(NSPEC), STMP1(NSPEC), & - STMP2(NSPEC), WNB(NK), CGB(NK), SIX, IGFAC1, IGFAC2 + STMP2(NSPEC), WNB(NK), CGB(NK), SIX, IGFAC1, IGFAC2 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ #ifdef W3_S - CALL STRACE (IENT, 'W3SREF') -#endif -! -! 0. Initializations ------------------------------------------------ * -! -#ifdef W3_IG1 - IGBCOVERWRITE =(MOD( NINT(IGPARS(4)),2).EQ.1) - IGSWELLMAX =( NINT(IGPARS(4)).GE.2) + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SREF') #endif -! This following line is a quick fix before the bug is understood .... + ! + ! 0. Initializations ------------------------------------------------ * + ! #ifdef W3_IG1 - IF (GTYPE.EQ.UNGTYPE) IGSWELLMAX =.FALSE. - IGFAC1 = 0.25 - IGFAC2 = 0.25 + IGBCOVERWRITE =(MOD( NINT(IGPARS(4)),2).EQ.1) + IGSWELLMAX =( NINT(IGPARS(4)).GE.2) + ! This following line is a quick fix before the bug is understood .... + IF (GTYPE.EQ.UNGTYPE) IGSWELLMAX =.FALSE. + IGFAC1 = 0.25 + IGFAC2 = 0.25 #endif - EMEANA = 0. - FMEANA = 0. - FMEAN2 = 0. + EMEANA = 0. + FMEANA = 0. + FMEAN2 = 0. - DELX=1. - DELY=1. - ! set FACx for all grid types - IF (FLAGLL) THEN - FACX = 1./(DERA * RADIUS) - ELSE - FACX = 1. - END IF + DELX=1. + DELY=1. + ! set FACx for all grid types + IF (FLAGLL) THEN + FACX = 1./(DERA * RADIUS) + ELSE + FACX = 1. + END IF - ISEA = MAPFS (IY,IX) -!!Li SMCTYPE shares info with RLGTYPE. JGLi12Oct2020 - IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN - DELX=SX*CLATS(ISEA)/FACX - DELY=SY/FACX - END IF + ISEA = MAPFS (IY,IX) + !!Li SMCTYPE shares info with RLGTYPE. JGLi12Oct2020 + IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN + DELX=SX*CLATS(ISEA)/FACX + DELY=SY/FACX + END IF - IF (GTYPE.EQ.CLGTYPE) THEN + IF (GTYPE.EQ.CLGTYPE) THEN ! Maybe what follows works also for RLGTYPE ... to be verified - DELX=HPFAC(IY,IX)/ FACX - DELY=HQFAC(IY,IX)/ FACX - END IF + DELX=HPFAC(IY,IX)/ FACX + DELY=HQFAC(IY,IX)/ FACX + END IF - IF (GTYPE.EQ.UNGTYPE) THEN - IF (LPDLIB) THEN + IF (GTYPE.EQ.UNGTYPE) THEN + IF (LPDLIB) THEN #ifdef W3_PDLIB - DELX=5.*SQRT(PDLIB_SI(IX))*(DERA * RADIUS) ! first approximation ... - DELY=5.*SQRT(PDLIB_SI(IX))*(DERA * RADIUS) ! first approximation ... + DELX=5.*SQRT(PDLIB_SI(IX))*(DERA * RADIUS) ! first approximation ... + DELY=5.*SQRT(PDLIB_SI(IX))*(DERA * RADIUS) ! first approximation ... #endif - ELSE - DELX=5.*SQRT(SI(IX))*(DERA * RADIUS) ! first approximation ... - DELY=5.*SQRT(SI(IX))*(DERA * RADIUS) ! first approximation ... - ENDIF - END IF + ELSE + DELX=5.*SQRT(SI(IX))*(DERA * RADIUS) ! first approximation ... + DELY=5.*SQRT(SI(IX))*(DERA * RADIUS) ! first approximation ... + ENDIF + END IF - IK1=1 + IK1=1 #ifdef W3_IG1 - IK1=NINT(IGPARS(5))+1 - NSPECIGSTART = NINT(IGPARS(5))*NTH + IK1=NINT(IGPARS(5))+1 + NSPECIGSTART = NINT(IGPARS(5))*NTH #endif - DO IK=IK1, NK - EB = 0. - DO ITH=1, NTH - EB = EB + A(ITH+(IK-1)*NTH) - END DO - EB = EB * DDEN(IK) / CG(IK) - EMEANA = EMEANA + EB - FMEAN2 = FMEAN2 + EB /SIG(IK)**2 - FMEANA = FMEANA + EB /SIG(IK) - END DO - FMEANA = TPIINV * (EMEANA / MAX ( 1.E-7 , FMEANA )) - FMEAN2 = TPIINV * SQRT(EMEANA / MAX ( 1.E-7 , FMEAN2 )) - FMEANA = MAX(FMEANA,SIG(1)) -! -! 1. Sets reflection term to zero -! - ICALC=1 + DO IK=IK1, NK + EB = 0. + DO ITH=1, NTH + EB = EB + A(ITH+(IK-1)*NTH) + END DO + EB = EB * DDEN(IK) / CG(IK) + EMEANA = EMEANA + EB + FMEAN2 = FMEAN2 + EB /SIG(IK)**2 + FMEANA = FMEANA + EB /SIG(IK) + END DO + FMEANA = TPIINV * (EMEANA / MAX ( 1.E-7 , FMEANA )) + FMEAN2 = TPIINV * SQRT(EMEANA / MAX ( 1.E-7 , FMEAN2 )) + FMEANA = MAX(FMEANA,SIG(1)) + ! + ! 1. Sets reflection term to zero + ! + ICALC=1 #ifdef W3_IG1 - STMP1 = 0. - STMP2 = 0. + STMP1 = 0. + STMP2 = 0. #endif - HS=4.*SQRT(EMEANA) + HS=4.*SQRT(EMEANA) #ifdef W3_IG1 - ATMP(:)=A(:) ! the IG energy will be added to this ATMP - ATMP2(:)=A(:) ! this is really to keep in memory the original spectrum - IF (IGBCOVERWRITE.AND.REFLC(1).GT.0) THEN - IGFAC1 = 1. - ATMP2(1:NSPECIGSTART)=0. - END IF -! -! resets IG band energy to zero -! - DO ICALC=1,2 + ATMP(:)=A(:) ! the IG energy will be added to this ATMP + ATMP2(:)=A(:) ! this is really to keep in memory the original spectrum + IF (IGBCOVERWRITE.AND.REFLC(1).GT.0) THEN + IGFAC1 = 1. + ATMP2(1:NSPECIGSTART)=0. + END IF + ! + ! resets IG band energy to zero + ! + DO ICALC=1,2 #endif S = 0. #ifdef W3_IG1 - IF (IGBCOVERWRITE) A(1:NSPECIGSTART)=0. - IF (ICALC.EQ.1) A=ATMP2 - IF (ICALC.EQ.2) THEN -! -! 1.1 Replaces IG part by forced IG -! -! determines highest IG frequency -! - IF (IGSWELLMAX) THEN - NKIG=NK - ELSE - NKIG=NINT(IGPARS(5)) - ENDIF - FREQIG=SIG(NINT(IGPARS(5)))*TPIINV -! - NSPECIG=NKIG*NTH - ATMP(1:NSPECIGSTART)=0. ! flat bottom approximation (Hasselmann 1962) - ! is not valid for long waves - IF (NINT(IGPARS(3)).EQ.1) THEN ! IGPARS(3) = IGSOURCE - IF (NINT(IGPARS(8)).EQ.1) THEN ! in this case, uses depth at break point - DEPTHIG=MAX(1.,HS/0.3) ! to be modified later with a proper gamma - ELSE - DEPTHIG=DEPTH - END IF - IF (IGPARS(10).GT.0.) DEPTHIG = IGPARS(10) ! fixed depth for 2nd order calculation -! -!/ --- INLINED WAVNU1 (START) ---------------------------------------- / -! - DO IK=1, NK - SQRTH = SQRT(DEPTHIG) - SIX = SIG(IK) * SQRTH - I1 = INT(SIX/DSIE) - IF (I1.LE.N1MAX) THEN - I2 = I1 + 1 - R1 = SIX/DSIE - REAL(I1) - R2 = 1. - R1 - WNB(IK) = ( R2*EWN1(I1) + R1*EWN1(I2) ) / DEPTH - CGB(IK) = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH + IF (IGBCOVERWRITE) A(1:NSPECIGSTART)=0. + IF (ICALC.EQ.1) A=ATMP2 + IF (ICALC.EQ.2) THEN + ! + ! 1.1 Replaces IG part by forced IG + ! + ! determines highest IG frequency + ! + IF (IGSWELLMAX) THEN + NKIG=NK ELSE - WNB(IK) = SIG(IK)*SIG(IK)/GRAV - CGB(IK) = 0.5 * GRAV / SIG(IK) + NKIG=NINT(IGPARS(5)) + ENDIF + FREQIG=SIG(NINT(IGPARS(5)))*TPIINV + ! + NSPECIG=NKIG*NTH + ATMP(1:NSPECIGSTART)=0. ! flat bottom approximation (Hasselmann 1962) + ! is not valid for long waves + IF (NINT(IGPARS(3)).EQ.1) THEN ! IGPARS(3) = IGSOURCE + IF (NINT(IGPARS(8)).EQ.1) THEN ! in this case, uses depth at break point + DEPTHIG=MAX(1.,HS/0.3) ! to be modified later with a proper gamma + ELSE + DEPTHIG=DEPTH END IF - END DO -! -!/ --- INLINED WAVNU1 (END) ------------------------------------------ / -! - IF (NINT(IGPARS(1)).EQ.1) THEN ! IGPARS(1) = IGMETHOD - CALL W3ADDIG(ATMP,DEPTHIG,WNB,CGB,1) + IF (IGPARS(10).GT.0.) DEPTHIG = IGPARS(10) ! fixed depth for 2nd order calculation + ! + !/ --- INLINED WAVNU1 (START) ---------------------------------------- / + ! + DO IK=1, NK + SQRTH = SQRT(DEPTHIG) + SIX = SIG(IK) * SQRTH + I1 = INT(SIX/DSIE) + IF (I1.LE.N1MAX) THEN + I2 = I1 + 1 + R1 = SIX/DSIE - REAL(I1) + R2 = 1. - R1 + WNB(IK) = ( R2*EWN1(I1) + R1*EWN1(I2) ) / DEPTH + CGB(IK) = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH ELSE - CALL W3ADD2NDORDER(ATMP,DEPTHIG,WNB,CGB,1) - END IF -! Transforms energy back to proper depth - DO IK=1,NKIG - ATMP(1+(IK-1)*NTH:IK*NTH)=ATMP(1+(IK-1)*NTH:IK*NTH)*(CGB(IK)*WN(IK))/(CG(IK)*WNB(IK)) - END DO - A(1:NSPECIG)=ATMP(1:NSPECIG) - IF (IGSWELLMAX) THEN - DO ISPEC=1,NSPECIG - A(ISPEC)=MAX(ATMP(ISPEC)-A(ISPEC),0.) - END DO - ELSE - A(1:NSPECIG)=ATMP(1:NSPECIG) - ENDIF -! - ELSEIF (NINT(IGPARS(3)).EQ.2) THEN ! Empirical source of IG energy -! -! This empirical source was adjusted to Waimea and Duck data -! When applied to deep water the 1/Depth must be replaced with k/Cg -! Hence the proper coefficient is WN(IK)/CG(IK)*GRAV**2/SIG(IK) -! -! The empirical form is HIG = IGEMPIRICAL * ... -! this is not quite yet a wave height: multiplied below by MIN(0.0036, ... -! - HIG= HS/(MAX(FMEAN2,FREQIG)**2) - EFIG=(HIG*0.25)**2/0.0279 ! this is (HsIG/4)^2 / df - HIG2 = 0. - DO IK=1,NKIG -! -! First approximation: constant IG spectrum with frequency -! - EFIG1=EFIG*MIN(0.0036,IGPARS(11)*WN(IK)/CG(IK)*GRAV**2/SIG(IK)) -! -! Correction: gives a frequency shape ... -! - IF (IK.LT.IK1) THEN - ! The 1.5 exponent of Ardhuin et al. 2014 (see figure 8.a) was probably too high ... now reduced to 1.0 - EFIG1=EFIG1*IGFAC1*1.2*MIN(1.,0.013/(SIG(IK)*TPIINV))**1.0 - ELSE - EFIG1=EFIG1*IGFAC2*1.2*MIN(1.,0.013/(SIG(IK)*TPIINV))**1.0 - END IF -! -! Conversion to action spectral density A(k,theta), assuming isotropic dir. -! - A(1+(IK-1)*NTH:IK*NTH)=EFIG1*CG(IK)/((SIG(IK)*TPI)*TPI) - HIG2 = HIG2 + EFIG1*DSII(IK)*TPIINV - END DO + WNB(IK) = SIG(IK)*SIG(IK)/GRAV + CGB(IK) = 0.5 * GRAV / SIG(IK) + END IF + END DO + ! + !/ --- INLINED WAVNU1 (END) ------------------------------------------ / + ! + IF (NINT(IGPARS(1)).EQ.1) THEN ! IGPARS(1) = IGMETHOD + CALL W3ADDIG(ATMP,DEPTHIG,WNB,CGB,1) ELSE - NSPECIG=0 + CALL W3ADD2NDORDER(ATMP,DEPTHIG,WNB,CGB,1) + END IF + ! Transforms energy back to proper depth + DO IK=1,NKIG + ATMP(1+(IK-1)*NTH:IK*NTH)=ATMP(1+(IK-1)*NTH:IK*NTH)*(CGB(IK)*WN(IK))/(CG(IK)*WNB(IK)) + END DO + A(1:NSPECIG)=ATMP(1:NSPECIG) + IF (IGSWELLMAX) THEN + DO ISPEC=1,NSPECIG + A(ISPEC)=MAX(ATMP(ISPEC)-A(ISPEC),0.) + END DO + ELSE + A(1:NSPECIG)=ATMP(1:NSPECIG) + ENDIF + ! + ELSEIF (NINT(IGPARS(3)).EQ.2) THEN ! Empirical source of IG energy + ! + ! This empirical source was adjusted to Waimea and Duck data + ! When applied to deep water the 1/Depth must be replaced with k/Cg + ! Hence the proper coefficient is WN(IK)/CG(IK)*GRAV**2/SIG(IK) + ! + ! The empirical form is HIG = IGEMPIRICAL * ... + ! this is not quite yet a wave height: multiplied below by MIN(0.0036, ... + ! + HIG= HS/(MAX(FMEAN2,FREQIG)**2) + EFIG=(HIG*0.25)**2/0.0279 ! this is (HsIG/4)^2 / df + HIG2 = 0. + DO IK=1,NKIG + ! + ! First approximation: constant IG spectrum with frequency + ! + EFIG1=EFIG*MIN(0.0036,IGPARS(11)*WN(IK)/CG(IK)*GRAV**2/SIG(IK)) + ! + ! Correction: gives a frequency shape ... + ! + IF (IK.LT.IK1) THEN + ! The 1.5 exponent of Ardhuin et al. 2014 (see figure 8.a) was probably too high ... now reduced to 1.0 + EFIG1=EFIG1*IGFAC1*1.2*MIN(1.,0.013/(SIG(IK)*TPIINV))**1.0 + ELSE + EFIG1=EFIG1*IGFAC2*1.2*MIN(1.,0.013/(SIG(IK)*TPIINV))**1.0 END IF -! - END IF ! ICALC EQ 2 + ! + ! Conversion to action spectral density A(k,theta), assuming isotropic dir. + ! + A(1+(IK-1)*NTH:IK*NTH)=EFIG1*CG(IK)/((SIG(IK)*TPI)*TPI) + HIG2 = HIG2 + EFIG1*DSII(IK)*TPIINV + END DO + ELSE + NSPECIG=0 + END IF + ! + END IF ! ICALC EQ 2 #endif -! + ! NRS=NINT(REFPARS(8)) IF (REFPARS(6).GT.0) THEN -! -! This is the Miche parameter for a beach slope of REFLC(3) -! + ! + ! This is the Miche parameter for a beach slope of REFLC(3) + ! IF(REFLC(3)/=REFLC(3)) THEN ! isnan test SLOPE=0.001 ELSE SLOPE=MAX(0.001,REFLC(3)) END IF MICHEFAC=0.0001*GRAV**2*(SLOPE**5) & - /(MAX(EMEANA,1E-4)*MAX(FMEANA,0.001)**4) + /(MAX(EMEANA,1E-4)*MAX(FMEANA,0.001)**4) RAMP0=MAX(0.07*(ALOG10(MICHEFAC)+4.5)+1.5*MICHEFAC,0.005) ! IF REFLC(1)=1, 0.07 should be 0.007 -! NB: these constants are adjusted for REFLC(1) = 0.1. If REFLC(1)=1, 0.07 should be 0.007 + ! NB: these constants are adjusted for REFLC(1) = 0.1. If REFLC(1)=1, 0.07 should be 0.007 ELSE RAMP0=1. - ENDIF + ENDIF -! -! 2. Shoreline reflection =============================================== * -! - IF (REFLC(1).GT.0) THEN + ! + ! 2. Shoreline reflection =============================================== * + ! + IF (REFLC(1).GT.0) THEN FAC1=1/(0.5*REAL(NTH)) FAC2=1.57/(0.5*REAL(NTH)) -! FAC3=2.6/(0.5*REAL(NTH)) ! this is for NRS=4 + ! FAC3=2.6/(0.5*REAL(NTH)) ! this is for NRS=4 FAC3=2./SUM(ABS(ECOS(1:NTH))**NRS) FAC4=1. -! + ! DO IK=1, NK -! -! Includes frequency dependence (see Elgar et al. JPO 1994) -! + ! + ! Includes frequency dependence (see Elgar et al. JPO 1994) + ! IF (REFPARS(6).GT.0) THEN RAMP=(MAX((0.75*TPI*FMEANA/SIG(IK)),1.)**REFPARS(10))*RAMP0 RAMP1=MIN(REFPARS(9),REFLC(1)*RAMP) @@ -439,11 +432,11 @@ SUBROUTINE W3SREF(A, CG, WN, EMEAN, FMEAN, DEPTH, CX1, CY1, REFLC, REFLD, & ELSE RAMP1=RAMP0*REFLC(1) RAMP2=RAMP0*REFLC(2) - END IF -! -! Special treatment for unstructured grids when not using source term -! - IF (GTYPE.EQ.UNGTYPE.AND.REFPARS(3).LT.0.5) THEN + END IF + ! + ! Special treatment for unstructured grids when not using source term + ! + IF (GTYPE.EQ.UNGTYPE.AND.REFPARS(3).LT.0.5) THEN IF (LPDLIB) THEN #ifdef W3_PDLIB IOBPDIP = IOBPD_LOC(:,IX) @@ -454,187 +447,185 @@ SUBROUTINE W3SREF(A, CG, WN, EMEAN, FMEAN, DEPTH, CX1, CY1, REFLC, REFLD, & DO ITH=1, NTH ISPECI=ITH+(IK-1)*NTH A(ISPECI)=A(ISPECI)*IOBPDIP(ITH) !puts to zero the energy not going to coast - END DO -! + END DO + ! DO ITH=1, NTH R1=ECOS(1+MOD(ABS(ITH-REFLD(1)),NTH)) R1=IOBPDIP(ITH) ISPECI=ITH+(IK-1)*NTH R2=RAMP1*A(ISPECI) - IF (R1.GT.0.AND.R2.GT.0) THEN -! -! Determines direction of specular reflection: th3=pi+2*n-th1 -! + IF (R1.GT.0.AND.R2.GT.0) THEN + ! + ! Determines direction of specular reflection: th3=pi+2*n-th1 + ! ITH3=1+MOD(NTH/2+NTH+2*REFLD(1)-ITH-1,NTH) DO ITH2=1,NTH -! -! Adds energy into reflected directions (ITH2) -! + ! + ! Adds energy into reflected directions (ITH2) + ! ISPEC=ITH2+(IK-1)*NTH R3=ECOS(1+MOD(ABS(ITH2-REFLD(1)),NTH)) - IF (R3.LT.0) THEN + IF (R3.LT.0) THEN R4=ECOS(1+MOD(ABS(ITH2-ITH3),NTH))*(1-IOBPDIP(ITH2)) - IF (R4.GT.0.) THEN -! -! Tests the type of shoreline geometry -! - SELECT CASE (REFLD(2)) + IF (R4.GT.0.) THEN + ! + ! Tests the type of shoreline geometry + ! + SELECT CASE (REFLD(2)) CASE (0) - ! Sharp corner: broad reflection + ! Sharp corner: broad reflection S(ISPEC)=S(ISPEC)+R2*FAC1/DT -! FA: analog to following lines to be swapped in if reflection method changed - ! RECT CASE: + ! FA: analog to following lines to be swapped in if reflection method changed + ! RECT CASE: ! S(ISPEC)=S(ISPEC)+ & ! REAL(REFLD(3))*R2*CG(IK)*ABS(ECOS(ITH2X)/DELX)*FAC1 & ! +REAL(REFLD(4))*R2*CG(IK)*ABS(ESIN(ITH2Y)/DELY)*FAC1 CASE (1) - ! mild corner: average reflection + ! mild corner: average reflection S(ISPEC)=S(ISPEC)+R2*ABS(R4)*FAC2/DT CASE (2) - ! straight coast: narrow reflection - ! IF(ITH3.EQ.ITH2) S(ISPEC)=S(ISPEC)+R2/DT ! THIS IS FOR SPECULAR REF. - S(ISPEC)=S(ISPEC)+R2*(R4**NRS) *FAC3/DT + ! straight coast: narrow reflection + ! IF(ITH3.EQ.ITH2) S(ISPEC)=S(ISPEC)+R2/DT ! THIS IS FOR SPECULAR REF. + S(ISPEC)=S(ISPEC)+R2*(R4**NRS) *FAC3/DT END SELECT END IF ! (R4.GT.0.) - END IF ! (R3.LT.0) + END IF ! (R3.LT.0) END DO ! ITH2=1,NTH END IF ! (R1.GT.0.AND.R2.GT.0) - END DO ! ITH=1, NTH + END DO ! ITH=1, NTH ELSE ! (GTYPE.NE.UNGTYPE) -! -! This is for structured grids .... -! -! -! Loop on incident wave direction (ITH) -! + ! + ! This is for structured grids .... + ! + ! + ! Loop on incident wave direction (ITH) + ! DO ITH=1, NTH R1=ECOS(1+MOD(ABS(ITH-REFLD(1)),NTH)) R2=RAMP1*A(ITH+(IK-1)*NTH) - IF (R1.GT.0.AND.R2.GT.0) THEN + IF (R1.GT.0.AND.R2.GT.0) THEN DO ITH2=1,NTH -! -! Adds energy into reflected directions (ITH2) -! + ! + ! Adds energy into reflected directions (ITH2) + ! ISPEC=ITH2+(IK-1)*NTH ITH2X=1+MOD(NTH+ITH2-REFLD(5)-1,NTH) ITH2Y=1+MOD(NTH+ITH2-REFLD(6)-1,NTH) R3=ECOS(1+MOD(ABS(ITH2-REFLD(1)),NTH)) - IF (R3.LT.0) THEN -! -! Determines direction of specular reflection: th3=pi+2*n-th1 -! + IF (R3.LT.0) THEN + ! + ! Determines direction of specular reflection: th3=pi+2*n-th1 + ! ITH3=1+MOD(NTH/2+NTH+2*REFLD(1)-ITH-1,NTH) R4=ECOS(1+MOD(ABS(ITH2-ITH3),NTH)) - IF (R4.GT.0.) THEN -! -! Tests the type of shoreline geometry -! NB: REFLD(3) or REFLD(4) is equal to 1 if the reflection is applied (real land neighbor) + IF (R4.GT.0.) THEN + ! + ! Tests the type of shoreline geometry + ! NB: REFLD(3) or REFLD(4) is equal to 1 if the reflection is applied (real land neighbor) SELECT CASE (REFLD(2)) CASE (0) - ! Sharp corner: broad reflection - S(ISPEC)=S(ISPEC)+ & - REAL(REFLD(3))*R2*CG(IK)*ABS(ECOS(ITH2X)/DELX)*FAC1 & - +REAL(REFLD(4))*R2*CG(IK)*ABS(ESIN(ITH2Y)/DELY)*FAC1 + ! Sharp corner: broad reflection + S(ISPEC)=S(ISPEC)+ & + REAL(REFLD(3))*R2*CG(IK)*ABS(ECOS(ITH2X)/DELX)*FAC1 & + +REAL(REFLD(4))*R2*CG(IK)*ABS(ESIN(ITH2Y)/DELY)*FAC1 CASE (1) - ! mild corner: average reflection -! - S(ISPEC)=S(ISPEC)+ & - REAL(REFLD(3))*R2*CG(IK)*ABS(ECOS(ITH2X)/DELX)*ABS(R4)*FAC2 & - + REAL(REFLD(4))*R2*CG(IK)*ABS(ESIN(ITH2Y)/DELY)*ABS(R4)*FAC2 + ! mild corner: average reflection + ! + S(ISPEC)=S(ISPEC)+ & + REAL(REFLD(3))*R2*CG(IK)*ABS(ECOS(ITH2X)/DELX)*ABS(R4)*FAC2 & + + REAL(REFLD(4))*R2*CG(IK)*ABS(ESIN(ITH2Y)/DELY)*ABS(R4)*FAC2 CASE (2) - ! straight coast: narrow reflection -! Specular for tests -! S(ISPEC)=S(ISPEC)+REAL(REFLD(3))*R2*CG(IK)*ABS(ECOS(ITH2)/DELX) & -! +REAL(REFLD(4))*R2*CG(IK)*ABS(ESIN(ITH2)/DELY) -! - S(ISPEC)=S(ISPEC)+REAL(REFLD(3))*R2*CG(IK)*ABS(ECOS(ITH2X)/DELX) & - *(R4**NRS) *FAC3 & - +REAL(REFLD(4))*R2*CG(IK)*ABS(ESIN(ITH2Y)/DELY) & - *(R4**NRS) *FAC3 - END SELECT - END IF ! (R4.GT.0.) - END IF ! (R3.LT.0) - END DO ! ITH2=1,NTH - END IF ! (R1.GT.0.AND.R2.GT.0) - END DO ! ITH=1,NTH - END IF ! UNGTYPE + ! straight coast: narrow reflection + ! Specular for tests + ! S(ISPEC)=S(ISPEC)+REAL(REFLD(3))*R2*CG(IK)*ABS(ECOS(ITH2)/DELX) & + ! +REAL(REFLD(4))*R2*CG(IK)*ABS(ESIN(ITH2)/DELY) + ! + S(ISPEC)=S(ISPEC)+REAL(REFLD(3))*R2*CG(IK)*ABS(ECOS(ITH2X)/DELX) & + *(R4**NRS) *FAC3 & + +REAL(REFLD(4))*R2*CG(IK)*ABS(ESIN(ITH2Y)/DELY) & + *(R4**NRS) *FAC3 + END SELECT + END IF ! (R4.GT.0.) + END IF ! (R3.LT.0) + END DO ! ITH2=1,NTH + END IF ! (R1.GT.0.AND.R2.GT.0) + END DO ! ITH=1,NTH + END IF ! UNGTYPE - END DO ! loop on IK - END IF ! end of test on REFLC(1) -! -! Add diffuse reflection due to subgrid islands and icebergs -! At present this feature is not supported for unstructured grids. -! + END DO ! loop on IK + END IF ! end of test on REFLC(1) + ! + ! Add diffuse reflection due to subgrid islands and icebergs + ! At present this feature is not supported for unstructured grids. + ! IF ( ((REFPARS(2).GT.0.).AND.((TRNX+TRNY).LT.2)) & - .OR.((REFPARS(4).GT.0.).AND.(BERG.GT.0) ) ) THEN -! -! Includes frequency dependence (see Elgar et al. JPO 1994) -! - IF (REFPARS(6).GT.0) THEN - RAMP=(MAX((0.75*TPI*FMEANA/SIG(IK)),1.)**REFPARS(10))*RAMP0 - RAMP2=MIN(REFPARS(9),REFLC(2)*RAMP) -! -! recomputes coefficients for iceberg slope given by REFLC(4) -! - SLOPE=MAX(0.001,REFLC(4)) - MICHEFAC=0.0001*GRAV**2*(SLOPE**5) & - /(MAX(EMEANA,1E-4)*MAX(FMEANA,0.001)**4) - RAMP0=MAX(0.007*(ALOG10(MICHEFAC)+4.5)+1.5*MICHEFAC,0.005) ! IF REFLC(1)=1, 0.07 should be 0.007 - RAMP=(MAX((0.75*TPI*FMEANA/SIG(IK)),1.)**REFPARS(10))*RAMP0 - RAMP4=MIN(REFPARS(9),RAMP) - ELSE - RAMP2=RAMP0*REFLC(2) - RAMP4=RAMP0*REFLC(4) - END IF -! -! + .OR.((REFPARS(4).GT.0.).AND.(BERG.GT.0) ) ) THEN + ! + ! Includes frequency dependence (see Elgar et al. JPO 1994) + ! + IF (REFPARS(6).GT.0) THEN + RAMP=(MAX((0.75*TPI*FMEANA/SIG(IK)),1.)**REFPARS(10))*RAMP0 + RAMP2=MIN(REFPARS(9),REFLC(2)*RAMP) + ! + ! recomputes coefficients for iceberg slope given by REFLC(4) + ! + SLOPE=MAX(0.001,REFLC(4)) + MICHEFAC=0.0001*GRAV**2*(SLOPE**5) & + /(MAX(EMEANA,1E-4)*MAX(FMEANA,0.001)**4) + RAMP0=MAX(0.007*(ALOG10(MICHEFAC)+4.5)+1.5*MICHEFAC,0.005) ! IF REFLC(1)=1, 0.07 should be 0.007 + RAMP=(MAX((0.75*TPI*FMEANA/SIG(IK)),1.)**REFPARS(10))*RAMP0 + RAMP4=MIN(REFPARS(9),RAMP) + ELSE + RAMP2=RAMP0*REFLC(2) + RAMP4=RAMP0*REFLC(4) + END IF + ! + ! R2X= RAMP2*REFPARS(2)*MAX(0.,MIN(1.,(1-TRNX))) & - + RAMP4*REFPARS(4)*MAX(0.,MIN(1.,(1-EXP(-BERG*DELX*0.0001)))) + + RAMP4*REFPARS(4)*MAX(0.,MIN(1.,(1-EXP(-BERG*DELX*0.0001)))) R2Y= RAMP2*REFPARS(2)*MAX(0.,MIN(1.,(1-TRNY))) & - + RAMP4*REFPARS(4)*MAX(0.,MIN(1.,(1-EXP(-BERG*DELY*0.0001)))) + + RAMP4*REFPARS(4)*MAX(0.,MIN(1.,(1-EXP(-BERG*DELY*0.0001)))) FAC1=1/(0.5*REAL(NTH)) DO IK=1, NK DO ITH=1, NTH R2=A(ITH+(IK-1)*NTH) - IF (R2.GT.0.) THEN - + IF (R2.GT.0.) THEN + DO ITH2=1,NTH ISPEC=ITH2+(IK-1)*NTH R3=ECOS(1+MOD(NTH+ITH2-ITH,NTH)) - IF (R3.LT.0) THEN - S(ISPEC)=S(ISPEC)+ & - CG(IK)*R2X*R2*ABS(ECOS(ITH2)/DELX)*FAC1 & - + CG(IK)*R2Y*R2*ABS(ESIN(ITH2)/DELY)*FAC1 - END IF - END DO - END IF - END DO + IF (R3.LT.0) THEN + S(ISPEC)=S(ISPEC)+ & + CG(IK)*R2X*R2*ABS(ECOS(ITH2)/DELX)*FAC1 & + + CG(IK)*R2Y*R2*ABS(ESIN(ITH2)/DELY)*FAC1 + END IF + END DO + END IF END DO - END IF + END DO + END IF #ifdef W3_IG1 - IF (ICALC.EQ.1) THEN + IF (ICALC.EQ.1) THEN STMP1(NSPECIGSTART+1:NSPEC) = S(NSPECIGSTART+1:NSPEC) - ELSE + ELSE STMP2 = S - DO ISPEC = 1, NSPEC + DO ISPEC = 1, NSPEC S(ISPEC) = MAX(STMP2(ISPEC),STMP1(ISPEC)) - END DO - END IF - ENDDO ! ICALC = 1,2 - A(1:NSPECIG)=ATMP2(1:NSPECIG) ! removes bound IG components ... + END DO + END IF + ENDDO ! ICALC = 1,2 + A(1:NSPECIG)=ATMP2(1:NSPECIG) ! removes bound IG components ... #endif -!/ -!/ End of W3SREF ----------------------------------------------------- / -!/ - END SUBROUTINE W3SREF!/ ------------------------------------------------------------------- / - -!/ -!/ End of module W3REF1MD -------------------------------------------- / -!/ - END MODULE W3REF1MD - + !/ + !/ End of W3SREF ----------------------------------------------------- / + !/ + END SUBROUTINE W3SREF!/ ------------------------------------------------------------------- / + !/ + !/ End of module W3REF1MD -------------------------------------------- / + !/ +END MODULE W3REF1MD diff --git a/model/src/w3sbs1md.F90 b/model/src/w3sbs1md.F90 index 2e72fdb46..6a0c11bf6 100644 --- a/model/src/w3sbs1md.F90 +++ b/model/src/w3sbs1md.F90 @@ -1,15 +1,15 @@ -!> @file +!> @file !> @brief Computes scattering term. -!> +!> !> @author F. Ardhuin !> @date 14-Nov-2010 -!> +!> #include "w3macros.h" !> -!> @brief This module computes a scattering term +!> @brief This module computes a scattering term !> based on the theory by Ardhuin and Magne (JFM 2007). -!> +!> !> @author F. Ardhuin !> @date 14-Nov-2010 !> @@ -19,655 +19,652 @@ !> No unauthorized use without permission. !> !/ ------------------------------------------------------------------- / - MODULE W3SBS1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III SHOM | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 14-Nov-2010 | -!/ +-----------------------------------+ -!/ -!/ 15-Jul-2005 : Origination. ( version 3.07 ) -!/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) -!/ inclusion in WAVEWATCH III. -!/ 10-May-2007 : adapt from version 2.22.SHOM ( version 3.10.SHOM ) -!/ 14-Nov-2010 : include scaling factor and clean up ( version 3.14 ) -!/ -! 1. Purpose : -! -! This module computes a scattering term -! based on the theory by Ardhuin and Magne (JFM 2007) -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SBS1 Subr. Public bottom scattering -! INSBS1 Subr. Public Corresponding initialization routine. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! - PUBLIC -!/ -!/ Public variables -!/ - REAL, DIMENSION(:,:), ALLOCATABLE :: BOTSPEC - INTEGER, PARAMETER :: NKSCAT = 30 !number of wavenumbers - DOUBLE PRECISION ,DIMENSION(:,:,:) , ALLOCATABLE :: SCATMATV !scattering matrices - DOUBLE PRECISION ,DIMENSION(:,:,:) , ALLOCATABLE :: SCATMATA !original matrix - DOUBLE PRECISION ,DIMENSION(:,:) , ALLOCATABLE :: SCATMATD - CHARACTER(len=10) :: botspec_indicator - INTEGER :: nkbx, nkby - REAL :: dkbx, dkby, kwmin, kwmax - REAL, PARAMETER :: scattcutoff=0. - REAL :: CURTX, CURTY -!/ - CONTAINS -! -!> -!> @brief Bottom scattering source term. -!> -!> @details Without current, goes through a diagonalization of the matrix -!> problem S(f,:) = M(f,:,:)**E(f,:). -!> With current, integrates the source term along the resonant locus. - -!> @param[in] A Action density spectrum (1-D) -!> @param[in] CG Group velocities -!> @param[in] WN Wavenumbers -!> @param[in] DEPTH Mean water depth -!> @param[in] CX1 Current components at ISEA -!> @param[in] CY1 Current components at ISEA -!> @param[out] TAUSCX Change of wave momentum due to scattering -!> @param[out] TAUSCY Change of wave momentum due to scattering -!> @param[out] S Source term (1-D version) -!> @param[out] D Diagonal term of derivative (1-D version) -!> -!> @author F. Ardhuin -!> @date 23-Jun-2006 -!> - SUBROUTINE W3SBS1(A, CG, WN, DEPTH, CX1, CY1, & - TAUSCX, TAUSCY, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 23-Jun-2006 | -!/ +-----------------------------------+ -!/ -!/ 15-Jul-2005 : Origination. ( version 3.07 ) -!/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) -!/ inclusion in WAVEWATCH III. -!/ -! 1. Purpose : -! -! Bottom scattering source term -! -! 2. Method : -! -! Without current, goes through a diagonalization of the matrix -! problem S(f,:) = M(f,:,:)**E(f,:) -! With current, integrates the source term along the resonant locus -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! DEPTH Real I Mean water depth. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! CX1-Y1 R.A. I Current components at ISEA. -! TAUSCX-Y R.A. I Change of wave momentum due to scattering -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, & - ECOS, ESIN, EC2, MAPTH, MAPWN, & - SIG2, DSII +MODULE W3SBS1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III SHOM | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 14-Nov-2010 | + !/ +-----------------------------------+ + !/ + !/ 15-Jul-2005 : Origination. ( version 3.07 ) + !/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) + !/ inclusion in WAVEWATCH III. + !/ 10-May-2007 : adapt from version 2.22.SHOM ( version 3.10.SHOM ) + !/ 14-Nov-2010 : include scaling factor and clean up ( version 3.14 ) + !/ + ! 1. Purpose : + ! + ! This module computes a scattering term + ! based on the theory by Ardhuin and Magne (JFM 2007) + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SBS1 Subr. Public bottom scattering + ! INSBS1 Subr. Public Corresponding initialization routine. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + PUBLIC + !/ + !/ Public variables + !/ + REAL, DIMENSION(:,:), ALLOCATABLE :: BOTSPEC + INTEGER, PARAMETER :: NKSCAT = 30 !number of wavenumbers + DOUBLE PRECISION ,DIMENSION(:,:,:) , ALLOCATABLE :: SCATMATV !scattering matrices + DOUBLE PRECISION ,DIMENSION(:,:,:) , ALLOCATABLE :: SCATMATA !original matrix + DOUBLE PRECISION ,DIMENSION(:,:) , ALLOCATABLE :: SCATMATD + CHARACTER(len=10) :: botspec_indicator + INTEGER :: nkbx, nkby + REAL :: dkbx, dkby, kwmin, kwmax + REAL, PARAMETER :: scattcutoff=0. + REAL :: CURTX, CURTY + !/ +CONTAINS + !> + !> @brief Bottom scattering source term. + !> + !> @details Without current, goes through a diagonalization of the matrix + !> problem S(f,:) = M(f,:,:)**E(f,:). + !> With current, integrates the source term along the resonant locus. + + !> @param[in] A Action density spectrum (1-D) + !> @param[in] CG Group velocities + !> @param[in] WN Wavenumbers + !> @param[in] DEPTH Mean water depth + !> @param[in] CX1 Current components at ISEA + !> @param[in] CY1 Current components at ISEA + !> @param[out] TAUSCX Change of wave momentum due to scattering + !> @param[out] TAUSCY Change of wave momentum due to scattering + !> @param[out] S Source term (1-D version) + !> @param[out] D Diagonal term of derivative (1-D version) + !> + !> @author F. Ardhuin + !> @date 23-Jun-2006 + !> + SUBROUTINE W3SBS1(A, CG, WN, DEPTH, CX1, CY1, & + TAUSCX, TAUSCY, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 23-Jun-2006 | + !/ +-----------------------------------+ + !/ + !/ 15-Jul-2005 : Origination. ( version 3.07 ) + !/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) + !/ inclusion in WAVEWATCH III. + !/ + ! 1. Purpose : + ! + ! Bottom scattering source term + ! + ! 2. Method : + ! + ! Without current, goes through a diagonalization of the matrix + ! problem S(f,:) = M(f,:,:)**E(f,:) + ! With current, integrates the source term along the resonant locus + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! DEPTH Real I Mean water depth. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! CX1-Y1 R.A. I Current components at ISEA. + ! TAUSCX-Y R.A. I Change of wave momentum due to scattering + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, & + ECOS, ESIN, EC2, MAPTH, MAPWN, & + SIG2, DSII #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH - REAL, INTENT(IN) :: A(NTH,NK) - REAL, INTENT(IN) :: CX1, CY1 - REAL, INTENT(OUT) :: TAUSCX, TAUSCY - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISPEC, IK, NSCUT, ITH, ITH2, i, j,iajust,iajust2 + !/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH + REAL, INTENT(IN) :: A(NTH,NK) + REAL, INTENT(IN) :: CX1, CY1 + REAL, INTENT(OUT) :: TAUSCX, TAUSCY + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISPEC, IK, NSCUT, ITH, ITH2, i, j,iajust,iajust2 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - LOGICAL, SAVE :: FIRST = .TRUE. - INTEGER :: MATRICES = 0 - - REAL :: R1, R2, R3 - - REAL :: WN2(NSPEC, NTH), Ka(NSPEC), & - Kb(NSPEC, NTH), WNBOT(NSPEC, NTH), & - B(NSPEC, NTH) - REAL :: kbotxi, kbotyi, xbk, & - ybk,integral, kbotx, kboty, count,count2 - - INTEGER :: ibk, jbk, ik2 - REAL :: SIGP,KU, KPU, CGK, CGPK, WN2i, xk2, Ap, kcutoff, ECC2, & - variance , integral1,integral1b,integral2, SB(NK,NTH), integral3,& - ajust,absajust,aa,bb,LNORM,UdotL,KdotKP,MBANDC - REAL :: KD, Kfactor, kscaled, kmod , CHECKSUM, ETOT - REAL :: SMATRIX(NTH,NTH),SMATRIX2(NTH,NTH) - DOUBLE PRECISION :: AVECT(NTH) + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: MATRICES = 0 - CURTX=CX1 - CURTY=CY1 - - count=0 -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: R1, R2, R3 + + REAL :: WN2(NSPEC, NTH), Ka(NSPEC), & + Kb(NSPEC, NTH), WNBOT(NSPEC, NTH), & + B(NSPEC, NTH) + REAL :: kbotxi, kbotyi, xbk, & + ybk,integral, kbotx, kboty, count,count2 + + INTEGER :: ibk, jbk, ik2 + REAL :: SIGP,KU, KPU, CGK, CGPK, WN2i, xk2, Ap, kcutoff, ECC2, & + variance , integral1,integral1b,integral2, SB(NK,NTH), integral3,& + ajust,absajust,aa,bb,LNORM,UdotL,KdotKP,MBANDC + REAL :: KD, Kfactor, kscaled, kmod , CHECKSUM, ETOT + REAL :: SMATRIX(NTH,NTH),SMATRIX2(NTH,NTH) + DOUBLE PRECISION :: AVECT(NTH) + + CURTX=CX1 + CURTY=CY1 + + count=0 + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SBS1') + CALL STRACE (IENT, 'W3SBS1') #endif -! -! 0. Initializations ------------------------------------------------ * -! -! ********************************************************** -! *** The initialization routine should include all *** -! *** initialization, including reading data from files. *** -! ********************************************************** -! - IF ( FIRST ) THEN - CALL INSBS1( 1 ) - FIRST = .FALSE. - END IF - IF (( (ABS(CX1)+ABS(CY1)).EQ.0.).AND.(MATRICES.EQ.0) ) THEN - kwmin=MAX(MAX(dkbx,dkby),SIG(1)**2/GRAV) - kwmax=MIN(nkbx*dkbx,nkby*dkby)*0.25 - WRITE(*,*) 'k range:',kwmin,kwmax,SIG(1)**2/GRAV - CALL INSBS1( 2 ) - MATRICES = 1 - END IF -! -! 1. Sets scattering term to zero -! - D = 0. - S = 0. - TAUSCX=0. - TAUSCY=0. -! -! 3. Bottom scattering ================================================== * -! - IF ( DEPTH*WN(1) .LE. 6 ) THEN -! -! 3.a Ardhuin and Herbers JFM 2000: no current -! - IF ((ABS(CX1)+ABS(CY1).EQ.0.).AND.(MATRICES.EQ.1)) THEN - DO IK=1,NK - KD=WN(IK)*DEPTH - IF ( KD .LE. 6 .AND.WN(IK).LT.kwmax ) THEN -! Test on kwmax means that scattering is not computed if interaction goes beyond the shortest resolved -! bottom component. This should probably be replaced by a warning... - Kfactor=(WN(IK)**4)*SIG(IK)*pi*4. & - /(SINH(2*KD)*(2*KD+SINH(2*KD))) - kscaled=(nkscat-2)*(WN(IK)-kwmin)/(kwmax-kwmin) - AVECT=DBLE(A(:,IK)) - IF (kscaled.LT.0) THEN - ibk=0 - kmod=0. - ELSE - ibk=INT(kscaled) - kmod=mod(kscaled,1.0) - END IF - S((IK-1)*NTH+1:IK*NTH) & - =REAL(MATMUL(SCATMATV(IBK,:,:),Kfactor*SCATMATD(IBK,:) & - *MATMUL(TRANSPOSE(SCATMATV(IBK,:,:)),AVECT))*(1.-kmod)) - S((IK-1)*NTH+1:IK*NTH) & - =S((IK-1)*NTH+1:IK*NTH) & - +REAL(MATMUL(SCATMATV(IBK+1,:,:),Kfactor*SCATMATD(IBK+1,:) & - *MATMUL(TRANSPOSE(SCATMATV(IBK+1,:,:)),AVECT))*kmod) - CHECKSUM=ABS(SUM(S((IK-1)*NTH+1:IK*NTH) )) - ETOT=SUM(A(:,IK)) - IF (CHECKSUM.GT.0.01*ETOT) WRITE(*,*) & - 'Energy not conserved:',IK,DEPTH,CHECKSUM,ETOT + ! + ! 0. Initializations ------------------------------------------------ * + ! + ! ********************************************************** + ! *** The initialization routine should include all *** + ! *** initialization, including reading data from files. *** + ! ********************************************************** + ! + IF ( FIRST ) THEN + CALL INSBS1( 1 ) + FIRST = .FALSE. + END IF + IF (( (ABS(CX1)+ABS(CY1)).EQ.0.).AND.(MATRICES.EQ.0) ) THEN + kwmin=MAX(MAX(dkbx,dkby),SIG(1)**2/GRAV) + kwmax=MIN(nkbx*dkbx,nkby*dkby)*0.25 + WRITE(*,*) 'k range:',kwmin,kwmax,SIG(1)**2/GRAV + CALL INSBS1( 2 ) + MATRICES = 1 + END IF + ! + ! 1. Sets scattering term to zero + ! + D = 0. + S = 0. + TAUSCX=0. + TAUSCY=0. + ! + ! 3. Bottom scattering ================================================== * + ! + IF ( DEPTH*WN(1) .LE. 6 ) THEN + ! + ! 3.a Ardhuin and Herbers JFM 2000: no current + ! + IF ((ABS(CX1)+ABS(CY1).EQ.0.).AND.(MATRICES.EQ.1)) THEN + DO IK=1,NK + KD=WN(IK)*DEPTH + IF ( KD .LE. 6 .AND.WN(IK).LT.kwmax ) THEN + ! Test on kwmax means that scattering is not computed if interaction goes beyond the shortest resolved + ! bottom component. This should probably be replaced by a warning... + Kfactor=(WN(IK)**4)*SIG(IK)*pi*4. & + /(SINH(2*KD)*(2*KD+SINH(2*KD))) + kscaled=(nkscat-2)*(WN(IK)-kwmin)/(kwmax-kwmin) + AVECT=DBLE(A(:,IK)) + IF (kscaled.LT.0) THEN + ibk=0 + kmod=0. ELSE - S((IK-1)*NTH+1:IK*NTH)=0. - END IF - END DO - ELSE -! 3.b -! Case with current (Ardhuin and Magne JFM 2007) -! Compute k' (WN2) from k (WN) and U (CX1, CY1) -! using : k'=(Cg+k.U/k)/(Cg+k'.U/k') -! - DO ITH2=1, NTH - - DO ISPEC=1, NSPEC - - KU=CX1 * ECOS(MAPTH(ISPEC))+CY1 * ESIN(MAPTH(ISPEC)) - KPU=CX1 * ECOS(ITH2)+ CY1 * ESIN(ITH2) - CGK=CG(MAPWN(ISPEC)) - IF ((CGK+KPU).LT.0.1*CGK) KPU=-0.9*CGK - IF ((CGK+KU).LT.0.1*CGK) KU=-0.9*CG(MAPWN(ISPEC)) - WN2(ISPEC,ITH2)= WN(MAPWN(ISPEC))*(CGK+KU)/(CGK+KPU) - END DO + ibk=INT(kscaled) + kmod=mod(kscaled,1.0) + END IF + S((IK-1)*NTH+1:IK*NTH) & + =REAL(MATMUL(SCATMATV(IBK,:,:),Kfactor*SCATMATD(IBK,:) & + *MATMUL(TRANSPOSE(SCATMATV(IBK,:,:)),AVECT))*(1.-kmod)) + S((IK-1)*NTH+1:IK*NTH) & + =S((IK-1)*NTH+1:IK*NTH) & + +REAL(MATMUL(SCATMATV(IBK+1,:,:),Kfactor*SCATMATD(IBK+1,:) & + *MATMUL(TRANSPOSE(SCATMATV(IBK+1,:,:)),AVECT))*kmod) + CHECKSUM=ABS(SUM(S((IK-1)*NTH+1:IK*NTH) )) + ETOT=SUM(A(:,IK)) + IF (CHECKSUM.GT.0.01*ETOT) WRITE(*,*) & + 'Energy not conserved:',IK,DEPTH,CHECKSUM,ETOT + ELSE + S((IK-1)*NTH+1:IK*NTH)=0. + END IF + END DO + ELSE + ! 3.b + ! Case with current (Ardhuin and Magne JFM 2007) + ! Compute k' (WN2) from k (WN) and U (CX1, CY1) + ! using : k'=(Cg+k.U/k)/(Cg+k'.U/k') + ! + DO ITH2=1, NTH - END DO -! -! 3.c Compute the coupling coefficient as a product of two terms -! -! K=0.5*pi k'^2 * M(k,k')^2 / [sig*sig' *(k'*Cg'+k'.U)] -! (Magne and Ardhuin JFM 2007) -! -! K=Ka(k)*Kb(k,k',theta') -! -! Ka = ... -! here Mc is neglected -! - DO ISPEC=1, NSPEC - Ka(ISPEC)= 4*PI*SIG2(ISPEC) * WN(MAPWN(ISPEC)) / & - SINH(MIN(2*WN(MAPWN(ISPEC))*DEPTH,20.)) + DO ISPEC=1, NSPEC - DO ITH2=1, NTH - KU=CX1 * ECOS(MAPTH(ISPEC))+CY1 * ESIN(MAPTH(ISPEC)) - KPU=CX1 * ECOS(ITH2)+ CY1 * ESIN(ITH2) - SIGP=SQRT(GRAV*WN2(ISPEC,ITH2)*TANH(WN2(ISPEC,ITH2)*DEPTH)) - CGPK=SIGP*(0.5+WN2(ISPEC,ITH2)*DEPTH & - /SINH(MIN(2*WN2(ISPEC,ITH2)*DEPTH,20.)))/WN2(ISPEC, ITH2) - - Kb(ISPEC, ITH2)= WN2(ISPEC, ITH2)**3 & - *EC2(1+ABS(MAPTH(ISPEC)-ITH2)) / & - ( & - 2*WN2(ISPEC, ITH2)*DEPTH + & - SINH(MIN(2*WN2(ISPEC,ITH2)*DEPTH,20.)) & - *(1+WN2(ISPEC,ITH2)*KPU*2/SIGP) & - ) + KU=CX1 * ECOS(MAPTH(ISPEC))+CY1 * ESIN(MAPTH(ISPEC)) + KPU=CX1 * ECOS(ITH2)+ CY1 * ESIN(ITH2) + CGK=CG(MAPWN(ISPEC)) + IF ((CGK+KPU).LT.0.1*CGK) KPU=-0.9*CGK + IF ((CGK+KU).LT.0.1*CGK) KU=-0.9*CG(MAPWN(ISPEC)) + WN2(ISPEC,ITH2)= WN(MAPWN(ISPEC))*(CGK+KU)/(CGK+KPU) + END DO -! -! Other option for computing also Mc -! -! UdotL=WN(MAPWN(ISPEC))*KU-KPU*WN2(ISPEC,ITH2) -! KdotKP=EC(1+ABS(MAPTH(ISPEC)-ITH2))*WN2(ISPEC,ITH2)*WN(MAPWN(ISPEC)) -! LNORM=sqrt(WN(MAPWN(ISPEC))**2+WN2(ISPEC, ITH2)**2-2*KdotKP) -! MBANDC=grav*KdotKP & -! /(COSH(MIN(WN2(ISPEC,ITH2)*DEPTH,20.))*COSH(MIN(WN(MAPWN(ISPEC))*DEPTH,20.) -! +(UdotL*(SIGP*(WN(MAPWN(ISPEC))**2-KdotKP)+SIG2(ISPEC)*(KdotKP-WN2(ISPEC, ITH2)**2)) & -! - UdotL**2*(KdotKP-SIGP*SIG2(ISPEC)*(SIGP*SIG2(ISPEC)+UdotL**2)/GRAV**2)) & -! /(LNORM*(UdotL**2/(GRAV*LNORM)-TANH(MIN(LNORM*DEPTH,20.)))*COSH(MIN(LNORM*DEPTH,20.))) -! Kb(ISPEC,ITH2)= WN2(ISPEC, ITH2)**2 -! /((SIG2(ISPEC)*SIGP*WN2(ISPEC, ITH2)*(CGPK+KPU)) & -! *MBANDC**2 -! - END DO - END DO -! -! 3.a Bilinear interpolation of the bottom spectrum BOTSPEC -! along the locus -> B(ISPEC,ITH2) -! - B(:,:)=0 - DO ISPEC=1, NSPEC - kcutoff=scattcutoff*WN(MAPWN(ISPEC)) - DO ITH2=1,NTH - kbotx=WN(MAPWN(ISPEC))*ECOS(MAPTH(ISPEC)) - & - WN2(ISPEC, ITH2) * ECOS(ITH2) - kboty=WN(MAPWN(ISPEC))*ESIN(MAPTH(ISPEC)) - & - WN2(ISPEC, ITH2) * ESIN(ITH2) -! -! 3.a.1 test if the bottom wavenumber is larger than the cutoff -! otherwise the interaction is set to zero - - IF ((kbotx**2+kboty**2)>(kcutoff**2)) THEN - - kbotxi=REAL(nkbx-MOD(nkbx,2))/2.+1.+kbotx/dkbx ! The MOD(nkbx,2) is either 1 or 0 - kbotyi=REAL(nkby-MOD(nkby,2))/2.+1.+kboty/dkby ! k=0 is at ik=(nkbx-1)/2+1 if kkbx is odd + END DO + ! + ! 3.c Compute the coupling coefficient as a product of two terms + ! + ! K=0.5*pi k'^2 * M(k,k')^2 / [sig*sig' *(k'*Cg'+k'.U)] + ! (Magne and Ardhuin JFM 2007) + ! + ! K=Ka(k)*Kb(k,k',theta') + ! + ! Ka = ... + ! here Mc is neglected + ! + DO ISPEC=1, NSPEC + Ka(ISPEC)= 4*PI*SIG2(ISPEC) * WN(MAPWN(ISPEC)) / & + SINH(MIN(2*WN(MAPWN(ISPEC))*DEPTH,20.)) - ibk=MAX(MIN(INT(kbotxi),nkbx-1),1) - xbk=mod(kbotxi,1.0) - jbk=MAX(MIN(INT(kbotyi),nkby-1),1) - ybk=mod(kbotyi,1.0) + DO ITH2=1, NTH + KU=CX1 * ECOS(MAPTH(ISPEC))+CY1 * ESIN(MAPTH(ISPEC)) + KPU=CX1 * ECOS(ITH2)+ CY1 * ESIN(ITH2) + SIGP=SQRT(GRAV*WN2(ISPEC,ITH2)*TANH(WN2(ISPEC,ITH2)*DEPTH)) + CGPK=SIGP*(0.5+WN2(ISPEC,ITH2)*DEPTH & + /SINH(MIN(2*WN2(ISPEC,ITH2)*DEPTH,20.)))/WN2(ISPEC, ITH2) - B(ISPEC,ITH2)=( & - (BOTSPEC(ibk,jbk)*(1-ybk)+ & - BOTSPEC(ibk,jbk+1)*ybk)*(1-xbk) & - + & - (BOTSPEC(ibk+1,jbk)*(1-ybk)+ & - BOTSPEC(ibk+1,jbk+1)*ybk)*xbk & - ) + Kb(ISPEC, ITH2)= WN2(ISPEC, ITH2)**3 & + *EC2(1+ABS(MAPTH(ISPEC)-ITH2)) / & + ( & + 2*WN2(ISPEC, ITH2)*DEPTH + & + SINH(MIN(2*WN2(ISPEC,ITH2)*DEPTH,20.)) & + *(1+WN2(ISPEC,ITH2)*KPU*2/SIGP) & + ) + + ! + ! Other option for computing also Mc + ! + ! UdotL=WN(MAPWN(ISPEC))*KU-KPU*WN2(ISPEC,ITH2) + ! KdotKP=EC(1+ABS(MAPTH(ISPEC)-ITH2))*WN2(ISPEC,ITH2)*WN(MAPWN(ISPEC)) + ! LNORM=sqrt(WN(MAPWN(ISPEC))**2+WN2(ISPEC, ITH2)**2-2*KdotKP) + ! MBANDC=grav*KdotKP & + ! /(COSH(MIN(WN2(ISPEC,ITH2)*DEPTH,20.))*COSH(MIN(WN(MAPWN(ISPEC))*DEPTH,20.) + ! +(UdotL*(SIGP*(WN(MAPWN(ISPEC))**2-KdotKP)+SIG2(ISPEC)*(KdotKP-WN2(ISPEC, ITH2)**2)) & + ! - UdotL**2*(KdotKP-SIGP*SIG2(ISPEC)*(SIGP*SIG2(ISPEC)+UdotL**2)/GRAV**2)) & + ! /(LNORM*(UdotL**2/(GRAV*LNORM)-TANH(MIN(LNORM*DEPTH,20.)))*COSH(MIN(LNORM*DEPTH,20.))) + ! Kb(ISPEC,ITH2)= WN2(ISPEC, ITH2)**2 + ! /((SIG2(ISPEC)*SIGP*WN2(ISPEC, ITH2)*(CGPK+KPU)) & + ! *MBANDC**2 + ! + END DO + END DO + ! + ! 3.a Bilinear interpolation of the bottom spectrum BOTSPEC + ! along the locus -> B(ISPEC,ITH2) + ! + B(:,:)=0 + DO ISPEC=1, NSPEC + kcutoff=scattcutoff*WN(MAPWN(ISPEC)) + DO ITH2=1,NTH + kbotx=WN(MAPWN(ISPEC))*ECOS(MAPTH(ISPEC)) - & + WN2(ISPEC, ITH2) * ECOS(ITH2) + kboty=WN(MAPWN(ISPEC))*ESIN(MAPTH(ISPEC)) - & + WN2(ISPEC, ITH2) * ESIN(ITH2) + ! + ! 3.a.1 test if the bottom wavenumber is larger than the cutoff + ! otherwise the interaction is set to zero + + IF ((kbotx**2+kboty**2)>(kcutoff**2)) THEN + + kbotxi=REAL(nkbx-MOD(nkbx,2))/2.+1.+kbotx/dkbx ! The MOD(nkbx,2) is either 1 or 0 + kbotyi=REAL(nkby-MOD(nkby,2))/2.+1.+kboty/dkby ! k=0 is at ik=(nkbx-1)/2+1 if kkbx is odd + + ibk=MAX(MIN(INT(kbotxi),nkbx-1),1) + xbk=mod(kbotxi,1.0) + jbk=MAX(MIN(INT(kbotyi),nkby-1),1) + ybk=mod(kbotyi,1.0) + + B(ISPEC,ITH2)=( & + (BOTSPEC(ibk,jbk)*(1-ybk)+ & + BOTSPEC(ibk,jbk+1)*ybk)*(1-xbk) & + + & + (BOTSPEC(ibk+1,jbk)*(1-ybk)+ & + BOTSPEC(ibk+1,jbk+1)*ybk)*xbk & + ) END IF + END DO + END DO + ! + ! 4. compute Sbscat + ! 4.a linear interpolation of A(k', theta') -> Ap + ! + + ! 4.b computation of the source term + integral2=0. + integral3=0. + SMATRIX(:,:)=0. + DO ISPEC=1, NSPEC + integral=0 + DO ITH2=1, NTH + iajust=1 + DO I=2,NK + if(WN2(ISPEC,ITH2).GE.WN(I)) iajust=I END DO - END DO -! -! 4. compute Sbscat -! 4.a linear interpolation of A(k', theta') -> Ap -! - -! 4.b computation of the source term - integral2=0. - integral3=0. - SMATRIX(:,:)=0. - DO ISPEC=1, NSPEC - integral=0 - DO ITH2=1, NTH - iajust=1 - DO I=2,NK - if(WN2(ISPEC,ITH2).GE.WN(I)) iajust=I - END DO - iajust=MAX(iajust,1) - iajust2=MIN(iajust+1,NK) - IF (iajust.EQ.iajust2) THEN - Ap=A(ITH2,iajust) - ELSE - bb=(WN2(ISPEC,ITH2)-WN(iajust))/(WN(iajust2)-WN(iajust)) - aa=(WN(iajust2)-WN2(ISPEC,ITH2))/(WN(iajust2)-WN(iajust)) - Ap=(A(ITH2,iajust)*aa+A(ITH2,iajust2)*bb) - END IF - - integral=integral + Ka(ISPEC)*Kb(ISPEC, ITH2)*B(ISPEC,ITH2)* & - ( Ap*WN(MAPWN(ISPEC))/WN2(ISPEC,ITH2)- A(MAPTH(ISPEC),MAPWN(ISPEC))) *DTH - ! the factor WN/WN2 accounts for the fact that N(K) and N(K') - ! have different Jacobian transforms from kx,ky to k,theta + iajust=MAX(iajust,1) + iajust2=MIN(iajust+1,NK) + IF (iajust.EQ.iajust2) THEN + Ap=A(ITH2,iajust) + ELSE + bb=(WN2(ISPEC,ITH2)-WN(iajust))/(WN(iajust2)-WN(iajust)) + aa=(WN(iajust2)-WN2(ISPEC,ITH2))/(WN(iajust2)-WN(iajust)) + Ap=(A(ITH2,iajust)*aa+A(ITH2,iajust2)*bb) + END IF - integral1=integral1+Kb(ISPEC, ITH2)*B(ISPEC,ITH2)*Ap*WN(MAPWN(ISPEC))/WN2(ISPEC,ITH2)*DTH & - *DTH*DSII(MAPWN(ISPEC))/CG(MAPWN(ISPEC)) - integral1b=integral1b+Kb(ISPEC, ITH2)*B(ISPEC,ITH2)*A(MAPTH(ISPEC),MAPWN(ISPEC))*DTH & - *DTH*DSII(MAPWN(ISPEC))/CG(MAPWN(ISPEC)) - END DO - S(ISPEC)=S(ISPEC)+integral + integral=integral + Ka(ISPEC)*Kb(ISPEC, ITH2)*B(ISPEC,ITH2)* & + ( Ap*WN(MAPWN(ISPEC))/WN2(ISPEC,ITH2)- A(MAPTH(ISPEC),MAPWN(ISPEC))) *DTH + ! the factor WN/WN2 accounts for the fact that N(K) and N(K') + ! have different Jacobian transforms from kx,ky to k,theta - integral2=integral2+S(ISPEC)*DTH*DSII(MAPWN(ISPEC))/CG(MAPWN(ISPEC)) - integral3=integral3+ABS(S(ISPEC))*DTH*DSII(MAPWN(ISPEC))/CG(MAPWN(ISPEC)) - END DO - END IF + integral1=integral1+Kb(ISPEC, ITH2)*B(ISPEC,ITH2)*Ap*WN(MAPWN(ISPEC))/WN2(ISPEC,ITH2)*DTH & + *DTH*DSII(MAPWN(ISPEC))/CG(MAPWN(ISPEC)) + integral1b=integral1b+Kb(ISPEC, ITH2)*B(ISPEC,ITH2)*A(MAPTH(ISPEC),MAPWN(ISPEC))*DTH & + *DTH*DSII(MAPWN(ISPEC))/CG(MAPWN(ISPEC)) + END DO + S(ISPEC)=S(ISPEC)+integral + + integral2=integral2+S(ISPEC)*DTH*DSII(MAPWN(ISPEC))/CG(MAPWN(ISPEC)) + integral3=integral3+ABS(S(ISPEC))*DTH*DSII(MAPWN(ISPEC))/CG(MAPWN(ISPEC)) + END DO + END IF #ifdef W3_T - print*,'BOTTOM SCAT CHECKSUM:',integral2,integral3,integral1,integral1b + print*,'BOTTOM SCAT CHECKSUM:',integral2,integral3,integral1,integral1b #endif - + #ifdef W3_T - DO ITH=1,120 - WRITE(6,'(120G15.7)') SMATRIX(ITH,:) + DO ITH=1,120 + WRITE(6,'(120G15.7)') SMATRIX(ITH,:) END DO #endif - END IF + END IF -!/ -!/ End of W3SBS1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SBS1 -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialization for bottom scattering source term routine. -!> -!> @param[in] inistep -!> -!> @author F. Ardhuin -!> @date 23-Jun-2006 -!> - - SUBROUTINE INSBS1( inistep ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 23-Jun-2006 | -!/ +-----------------------------------+ -!/ -!/ 23-Jun-2006 : Origination. ( version 3.09 ) -!/ -! 1. Purpose : -! -! Initialization for bottom scattering source term routine. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SBS1 Subr. W3SBS1MD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, ECOS, ESIN - USE W3SERVMD, ONLY: DIAGONALIZE + !/ + !/ End of W3SBS1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SBS1 + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialization for bottom scattering source term routine. + !> + !> @param[in] inistep + !> + !> @author F. Ardhuin + !> @date 23-Jun-2006 + !> + + SUBROUTINE INSBS1( inistep ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 23-Jun-2006 | + !/ +-----------------------------------+ + !/ + !/ 23-Jun-2006 : Origination. ( version 3.09 ) + !/ + ! 1. Purpose : + ! + ! Initialization for bottom scattering source term routine. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SBS1 Subr. W3SBS1MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, ECOS, ESIN + USE W3SERVMD, ONLY: DIAGONALIZE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: inistep -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: inistep + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: I, J, K1, K2, IK, JK, NROT - REAL :: kbotx, kboty, kcurr, kcutoff, variance - REAL :: kbotxi, kbotyi, xk, yk - DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: AMAT, V - DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:) :: D -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: I, J, K1, K2, IK, JK, NROT + REAL :: kbotx, kboty, kcurr, kcutoff, variance + REAL :: kbotxi, kbotyi, xk, yk + DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: AMAT, V + DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:) :: D + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INSBS1') + CALL STRACE (IENT, 'INSBS1') #endif -! - IF (inistep.EQ.1) THEN -! -! 1. Reads bottom spectrum -! - OPEN(183,FILE= 'bottomspectrum.inp', status='old') - READ(183,*) nkbx, nkby - READ(183,*) dkbx, dkby - WRITE(*,*) 'Bottom spec. dim.:', nkbx, nkby, dkbx, dkby - ALLOCATE(BOTSPEC(nkbx, nkby)) - DO I=1, nkbx - READ(183,*) BOTSPEC(I,:) - END DO - CLOSE(183) - variance=0 - DO i=1,nkbx - DO j=1,nkby - variance=variance+BOTSPEC(i,j)*dkbx*dkby - END DO - END DO - WRITE(*,*) 'Bottom variance:', variance -! - ELSE -! -! 2. Precomputed the scatering matrices for zero current -! -! The Scattering source term is expressed as a matrix problem for -! a list of wavenumbers k0 -! in the range of wavenumbers used in the model. -! i.e. S(k0,theta)=Kfactor*SCATMATA ** TRANSPOSE (E(k0,theta)) -! -! in which -! -! Kfactor is a scalar computed in CALCSOURCE as -! Kfactor=tailfactor*(Kp(I,J)**4)*2.*pi*FREQ(J)*pi*4./(SINH(HND)*(HND+SINH(HND))) -! -! SCATMATA is a square matrix of size NTH*NTH -! -! S(k0,theta) and E(k0,theta) are the vectors giving the directional source term -! and spectrum at a fixed wavenumber -! - ALLOCATE(SCATMATA(0:nkscat-1,1:NTH,1:NTH)) - ALLOCATE(AMAT(NTH,NTH)) - DO I=0,nkscat-1 - ! kcurr is the current surface wavenumber for which - ! the scattering matrices are evaluated - kcurr=kwmin+I*(kwmax-kwmin)/(nkscat-2) - kcutoff=scattcutoff*kcurr - DO K1=1,NTH - DO K2=1,NTH - kbotx=-kcurr*(ECOS(K2)-ECOS(K1)) - kboty=-kcurr*(ESIN(K2)-ESIN(K1)) - AMAT(K1,K2)=0. - ! Tests if the bottom wavenumber is larger than the cutoff - ! Otherwise the interaction is set to zero - IF ((kbotx**2+kboty**2) > (kcutoff**2)) THEN - !WARNING : THERE MAY BE A BUG : spectrum not symmetric when - ! nkbx is odd !! - - kbotxi=REAL(nkbx)/2.+1.+kbotx/dkbx - kbotyi=REAL(nkby)/2.+1.+kboty/dkby - !WRITE(6,*) 'Bottom wavenumber i:',kbotxi,kbotyi - ik=INT(kbotxi) - xk=mod(kbotxi,1.0) - jk=INT(kbotyi) - yk=mod(kbotyi,1.0) - IF (ik.GE.nkbx) ik=nkbx-1 - IF (jk.GE.nkby) jk=nkby-1 - IF (ik.LT.1) ik=1 - IF (jk.LT.1) jk=1 - ! Bilinear interpolation of the bottom spectrum - AMAT(K1,K2)=((BOTSPEC(ik,jk ) *(1-yk) & - +BOTSPEC(ik,jk+1) *yk )*(1-xk) & - +(BOTSPEC(ik+1,jk) *(1-yk) & - +BOTSPEC(ik+1,jk+1)*yk) *xk) & - *(ECOS(K1)*ECOS(K2)+ESIN(K1)*ESIN(K2))**2 - END IF - END DO - AMAT(K1,K1)=AMAT(K1,K1)-SUM(AMAT(K1,:)) - END DO - AMAT(:,:)=DTH*(AMAT(:,:)+TRANSPOSE(AMAT(:,:)))*0.5 - !makes sure the matrix is exactly symmetric - !which should already be the case if the bottom - ! spectrum is really symmetric - SCATMATA(I,:,:)=AMAT(:,:) - END DO - ALLOCATE(SCATMATD(0:nkscat-1,NTH)) - ALLOCATE(SCATMATV(0:nkscat-1,NTH,NTH)) - ALLOCATE(V(NTH,NTH)) - ALLOCATE(D(NTH)) - DO I=0,nkscat-1 - AMAT(:,:)=SCATMATA(I,:,:) -! -!diagonalizes the matrix A -!D is a vector with the eigenvalues, V is the matrix made of the -!eigenvectors so that VD2Vt=A with D2(i,j)=delta(i,j)D(i) -!and VVt=Id, so that exp(A)=Vexp(D2)Vt -! - CALL DIAGONALIZE(AMAT,D,V,nrot) - SCATMATD(I,:)=D(:) !eigen values - SCATMATV(I,:,:)=V(:,:) !eigen vectors - kcurr=kwmin+I*(kwmax-kwmin)/(nkscat-2) - WRITE(*,*) 'Scattering matrix diagonalized for k= ',kcurr,',',I+1,'out of ',nkscat - END DO - END IF - -!/ -!/ End of INSBS1 ----------------------------------------------------- / -!/ - END SUBROUTINE INSBS1 -!/ -!/ End of module INSBS1MD -------------------------------------------- / -!/ - END MODULE W3SBS1MD + ! + IF (inistep.EQ.1) THEN + ! + ! 1. Reads bottom spectrum + ! + OPEN(183,FILE= 'bottomspectrum.inp', status='old') + READ(183,*) nkbx, nkby + READ(183,*) dkbx, dkby + WRITE(*,*) 'Bottom spec. dim.:', nkbx, nkby, dkbx, dkby + ALLOCATE(BOTSPEC(nkbx, nkby)) + DO I=1, nkbx + READ(183,*) BOTSPEC(I,:) + END DO + CLOSE(183) + variance=0 + DO i=1,nkbx + DO j=1,nkby + variance=variance+BOTSPEC(i,j)*dkbx*dkby + END DO + END DO + WRITE(*,*) 'Bottom variance:', variance + ! + ELSE + ! + ! 2. Precomputed the scatering matrices for zero current + ! + ! The Scattering source term is expressed as a matrix problem for + ! a list of wavenumbers k0 + ! in the range of wavenumbers used in the model. + ! i.e. S(k0,theta)=Kfactor*SCATMATA ** TRANSPOSE (E(k0,theta)) + ! + ! in which + ! + ! Kfactor is a scalar computed in CALCSOURCE as + ! Kfactor=tailfactor*(Kp(I,J)**4)*2.*pi*FREQ(J)*pi*4./(SINH(HND)*(HND+SINH(HND))) + ! + ! SCATMATA is a square matrix of size NTH*NTH + ! + ! S(k0,theta) and E(k0,theta) are the vectors giving the directional source term + ! and spectrum at a fixed wavenumber + ! + ALLOCATE(SCATMATA(0:nkscat-1,1:NTH,1:NTH)) + ALLOCATE(AMAT(NTH,NTH)) + DO I=0,nkscat-1 + ! kcurr is the current surface wavenumber for which + ! the scattering matrices are evaluated + kcurr=kwmin+I*(kwmax-kwmin)/(nkscat-2) + kcutoff=scattcutoff*kcurr + DO K1=1,NTH + DO K2=1,NTH + kbotx=-kcurr*(ECOS(K2)-ECOS(K1)) + kboty=-kcurr*(ESIN(K2)-ESIN(K1)) + AMAT(K1,K2)=0. + ! Tests if the bottom wavenumber is larger than the cutoff + ! Otherwise the interaction is set to zero + IF ((kbotx**2+kboty**2) > (kcutoff**2)) THEN + !WARNING : THERE MAY BE A BUG : spectrum not symmetric when + ! nkbx is odd !! + kbotxi=REAL(nkbx)/2.+1.+kbotx/dkbx + kbotyi=REAL(nkby)/2.+1.+kboty/dkby + !WRITE(6,*) 'Bottom wavenumber i:',kbotxi,kbotyi + ik=INT(kbotxi) + xk=mod(kbotxi,1.0) + jk=INT(kbotyi) + yk=mod(kbotyi,1.0) + IF (ik.GE.nkbx) ik=nkbx-1 + IF (jk.GE.nkby) jk=nkby-1 + IF (ik.LT.1) ik=1 + IF (jk.LT.1) jk=1 + ! Bilinear interpolation of the bottom spectrum + AMAT(K1,K2)=((BOTSPEC(ik,jk ) *(1-yk) & + +BOTSPEC(ik,jk+1) *yk )*(1-xk) & + +(BOTSPEC(ik+1,jk) *(1-yk) & + +BOTSPEC(ik+1,jk+1)*yk) *xk) & + *(ECOS(K1)*ECOS(K2)+ESIN(K1)*ESIN(K2))**2 + END IF + END DO + AMAT(K1,K1)=AMAT(K1,K1)-SUM(AMAT(K1,:)) + END DO + AMAT(:,:)=DTH*(AMAT(:,:)+TRANSPOSE(AMAT(:,:)))*0.5 + !makes sure the matrix is exactly symmetric + !which should already be the case if the bottom + ! spectrum is really symmetric + SCATMATA(I,:,:)=AMAT(:,:) + END DO + ALLOCATE(SCATMATD(0:nkscat-1,NTH)) + ALLOCATE(SCATMATV(0:nkscat-1,NTH,NTH)) + ALLOCATE(V(NTH,NTH)) + ALLOCATE(D(NTH)) + DO I=0,nkscat-1 + AMAT(:,:)=SCATMATA(I,:,:) + ! + !diagonalizes the matrix A + !D is a vector with the eigenvalues, V is the matrix made of the + !eigenvectors so that VD2Vt=A with D2(i,j)=delta(i,j)D(i) + !and VVt=Id, so that exp(A)=Vexp(D2)Vt + ! + CALL DIAGONALIZE(AMAT,D,V,nrot) + SCATMATD(I,:)=D(:) !eigen values + SCATMATV(I,:,:)=V(:,:) !eigen vectors + kcurr=kwmin+I*(kwmax-kwmin)/(nkscat-2) + WRITE(*,*) 'Scattering matrix diagonalized for k= ',kcurr,',',I+1,'out of ',nkscat + END DO + END IF + !/ + !/ End of INSBS1 ----------------------------------------------------- / + !/ + END SUBROUTINE INSBS1 + !/ + !/ End of module INSBS1MD -------------------------------------------- / + !/ +END MODULE W3SBS1MD diff --git a/model/src/w3sbt1md.F90 b/model/src/w3sbt1md.F90 index 385fae9eb..fdc675ff3 100644 --- a/model/src/w3sbt1md.F90 +++ b/model/src/w3sbt1md.F90 @@ -1,249 +1,246 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SBT1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ For updates see W3SBT1 documentation. -!/ -! 1. Purpose : -! -! JONSWAP bottom friction routine. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SBT1 Subr. Public JONSWAP source term. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SBT1 (A, CG, WN, DEPTH, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 05-Dec-1996 : Final FORTRAN 77. ( version 1.18 ) -!/ 08-Dec-1999 : Upgrade to FORTRAN 90. ( version 2.00 ) -!/ 20-Dec-2004 : Multiple model version. ( version 3.06 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Bottom friction source term according to the empirical JONSWAP -! formulation. -! -! 2. Method : -! -! 2 GAMMA / CG \ SBTC1 / \ . -! Sbt = ---------- | ------- - 0.5 | E = ----- | ... | E (1) -! GRAV DEPTH \ SI/WN / DEPTH \ / -! -! Where GAMMA = -0.038 m2/s3 (JONSWAP) -! = -0.067 m2/s3 (Bouws and Komen 1983) -! -! In the routine, the constant 2 GAMMA / GRAV = SBTC1. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! DEPTH Real I Mean water depth. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). -! PRT2DS Subr. W3ARRYMD Print plot output (!/T1 switch). -! OUTMAT Subr. W3ARRYMD Matrix output (!/T2 switch). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, SBTC1 +MODULE W3SBT1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ For updates see W3SBT1 documentation. + !/ + ! 1. Purpose : + ! + ! JONSWAP bottom friction routine. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SBT1 Subr. Public JONSWAP source term. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SBT1 (A, CG, WN, DEPTH, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 05-Dec-1996 : Final FORTRAN 77. ( version 1.18 ) + !/ 08-Dec-1999 : Upgrade to FORTRAN 90. ( version 2.00 ) + !/ 20-Dec-2004 : Multiple model version. ( version 3.06 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Bottom friction source term according to the empirical JONSWAP + ! formulation. + ! + ! 2. Method : + ! + ! 2 GAMMA / CG \ SBTC1 / \ . + ! Sbt = ---------- | ------- - 0.5 | E = ----- | ... | E (1) + ! GRAV DEPTH \ SI/WN / DEPTH \ / + ! + ! Where GAMMA = -0.038 m2/s3 (JONSWAP) + ! = -0.067 m2/s3 (Bouws and Komen 1983) + ! + ! In the routine, the constant 2 GAMMA / GRAV = SBTC1. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! DEPTH Real I Mean water depth. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). + ! PRT2DS Subr. W3ARRYMD Print plot output (!/T1 switch). + ! OUTMAT Subr. W3ARRYMD Matrix output (!/T2 switch). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, SBTC1 #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, A(NSPEC) - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS, IK, NSCUT + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, A(NSPEC) + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS, IK, NSCUT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T0 - INTEGER :: ITH + INTEGER :: ITH #endif - REAL :: FACTOR, CBETA(NK) + REAL :: FACTOR, CBETA(NK) #ifdef W3_T0 - REAL :: DOUT(NK,NTH) + REAL :: DOUT(NK,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SBT1') + CALL STRACE (IENT, 'W3SBT1') #endif -! -! 1. Deep water ===================================================== * -! - IF ( DEPTH*WN(1) .GT. 6 ) THEN -! - D = 0. - S = 0. -! -! 2. Shallow water ================================================== * -! - ELSE -! -! 2.a Set constant -! - FACTOR = SBTC1 / DEPTH -! + ! + ! 1. Deep water ===================================================== * + ! + IF ( DEPTH*WN(1) .GT. 6 ) THEN + ! + D = 0. + S = 0. + ! + ! 2. Shallow water ================================================== * + ! + ELSE + ! + ! 2.a Set constant + ! + FACTOR = SBTC1 / DEPTH + ! #ifdef W3_T - WRITE (NDST,9000) FACTOR, DEPTH + WRITE (NDST,9000) FACTOR, DEPTH #endif -! -! 2.b Wavenumber dependent part. -! - DO IK=1, NK - IF ( WN(IK)*DEPTH .GT. 6. ) EXIT - CBETA(IK) = FACTOR * & - MAX(0., (CG(IK)*WN(IK)/SIG(IK)-0.5) ) - END DO -! -! 2.c Fill diagional matrix -! - NSCUT = (IK-1)*NTH -! - DO IS=1, NSCUT - D(IS) = CBETA(MAPWN(IS)) - END DO -! - DO IS=NSCUT+1, NSPEC - D(IS) = 0. - END DO -! - S = D * A -! - END IF -! -! ... Test output of arrays -! -#ifdef W3_T0 + ! + ! 2.b Wavenumber dependent part. + ! DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO -#endif -! + IF ( WN(IK)*DEPTH .GT. 6. ) EXIT + CBETA(IK) = FACTOR * & + MAX(0., (CG(IK)*WN(IK)/SIG(IK)-0.5) ) + END DO + ! + ! 2.c Fill diagional matrix + ! + NSCUT = (IK-1)*NTH + ! + DO IS=1, NSCUT + D(IS) = CBETA(MAPWN(IS)) + END DO + ! + DO IS=NSCUT+1, NSPEC + D(IS) = 0. + END DO + ! + S = D * A + ! + END IF + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Sbt', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sbt', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sbt') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sbt') #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SBT1 : FACTOR, DEPTH : ',2E10.3) +9000 FORMAT (' TEST W3SBT1 : FACTOR, DEPTH : ',2E10.3) #endif -!/ -!/ End of W3SBT1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SBT1 -!/ -!/ End of module W3SBT1MD -------------------------------------------- / -!/ - END MODULE W3SBT1MD + !/ + !/ End of W3SBT1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SBT1 + !/ + !/ End of module W3SBT1MD -------------------------------------------- / + !/ +END MODULE W3SBT1MD diff --git a/model/src/w3sbt4md.F90 b/model/src/w3sbt4md.F90 index b239ae07c..3291930f1 100644 --- a/model/src/w3sbt4md.F90 +++ b/model/src/w3sbt4md.F90 @@ -1,581 +1,581 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SBT4MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin and J. Lepesqueur | -!/ | FORTRAN 90 | -!/ | Last update : 14-Mar-2012 | -!/ +-----------------------------------+ -!/ -!/ 20-Dec-2004 : Origination. ( version 3.06 ) -!/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) -!/ inclusion in WAVEWATCH III. -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 14-Mar-2012 : Preparing distribution version. ( version 4.05 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! SHOWEX bottom friction source term (Ardhuin et al. 2003), -! using a subgrid depth parameterization based on Tolman (CE 1995). -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SBT4 Subr. Public SHOWEX bottom friction (movable bed) -! INSBT4 Subr. Public Corresponding initialization routine. -! TABU_ERF Subr. Public Tabulation of ERF function -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! WAVEWATCH III is designed as a highly plug-compatible code. -! Source term modules can be included as self-contained modules, -! with limited changes needed to the interface of routine calls -! in W3SRCE, and in the point postprocessing programs only. -! Codes submitted for inclusion in WAVEWATCH III should be -! self-contained in the way described below, and might be -! provided with distributions fully integrated in the data -! structure, or as an optional version of this module to be -! included by the user. -! -! Rules for preparing a module to be included in or distributed -! with WAVEWATCH III : -! -! - Fully document the code following the outline given in this -! file, and according to all other WAVEWATCH III routines. -! - Provide a file with necessary modifications to W3SRCE and -! all other routines that require modification. -! - Provide a test case with expected results. -! - It is strongly recommended that the programming style used -! in WAVEWATCH III is followed, in particular -! a) for readability, write as if in fixed FORTRAN format -! regarding column use, even though all files are F90 -! free format. -! b) I prefer upper case programming for permanent code, -! as I use lower case in debugging and temporary code. -! -! This module needs to be self-contained in the following way. -! -! a) All saved variables connected with this source term need -! to be declared in the module header. Upon acceptance as -! permanent code, they will be converted to the WAVEWATCH III -! dynamic data structure. -! b) Provide a separate computation and initialization routine. -! In the submission, the initialization should be called -! from the computation routine upon the first call to the -! routine. Upon acceptance as permanent code, the -! initialization routine will be moved to a more appropriate -! location in the code (i.e., being absorbed in ww3_grid or -! being moved to W3IOGR). -! -! See notes in the file below where to add these elements. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! - - PUBLIC -! -! Parameters for ERF function -! - INTEGER, PARAMETER :: SIZEERFTABLE=300 - REAL :: ERFTABLE(0:SIZEERFTABLE) - REAL :: DELXERF - REAL, PARAMETER :: XERFMAX = 4. ! number of stdev -!/ - CONTAINS +MODULE W3SBT4MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin and J. Lepesqueur | + !/ | FORTRAN 90 | + !/ | Last update : 14-Mar-2012 | + !/ +-----------------------------------+ + !/ + !/ 20-Dec-2004 : Origination. ( version 3.06 ) + !/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) + !/ inclusion in WAVEWATCH III. + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 14-Mar-2012 : Preparing distribution version. ( version 4.05 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! SHOWEX bottom friction source term (Ardhuin et al. 2003), + ! using a subgrid depth parameterization based on Tolman (CE 1995). + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SBT4 Subr. Public SHOWEX bottom friction (movable bed) + ! INSBT4 Subr. Public Corresponding initialization routine. + ! TABU_ERF Subr. Public Tabulation of ERF function + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! WAVEWATCH III is designed as a highly plug-compatible code. + ! Source term modules can be included as self-contained modules, + ! with limited changes needed to the interface of routine calls + ! in W3SRCE, and in the point postprocessing programs only. + ! Codes submitted for inclusion in WAVEWATCH III should be + ! self-contained in the way described below, and might be + ! provided with distributions fully integrated in the data + ! structure, or as an optional version of this module to be + ! included by the user. + ! + ! Rules for preparing a module to be included in or distributed + ! with WAVEWATCH III : + ! + ! - Fully document the code following the outline given in this + ! file, and according to all other WAVEWATCH III routines. + ! - Provide a file with necessary modifications to W3SRCE and + ! all other routines that require modification. + ! - Provide a test case with expected results. + ! - It is strongly recommended that the programming style used + ! in WAVEWATCH III is followed, in particular + ! a) for readability, write as if in fixed FORTRAN format + ! regarding column use, even though all files are F90 + ! free format. + ! b) I prefer upper case programming for permanent code, + ! as I use lower case in debugging and temporary code. + ! + ! This module needs to be self-contained in the following way. + ! + ! a) All saved variables connected with this source term need + ! to be declared in the module header. Upon acceptance as + ! permanent code, they will be converted to the WAVEWATCH III + ! dynamic data structure. + ! b) Provide a separate computation and initialization routine. + ! In the submission, the initialization should be called + ! from the computation routine upon the first call to the + ! routine. Upon acceptance as permanent code, the + ! initialization routine will be moved to a more appropriate + ! location in the code (i.e., being absorbed in ww3_grid or + ! being moved to W3IOGR). + ! + ! See notes in the file below where to add these elements. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + PUBLIC + ! + ! Parameters for ERF function + ! + INTEGER, PARAMETER :: SIZEERFTABLE=300 + REAL :: ERFTABLE(0:SIZEERFTABLE) + REAL :: DELXERF + REAL, PARAMETER :: XERFMAX = 4. ! number of stdev + !/ +CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE INSBT4 -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | SHOM | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 14-Mar-2012 | -!/ +-----------------------------------+ -!/ -!/ 14-Mar-2012 : Origination. ( version 4.05 ) -! -! 1. Purpose : -! -! Initialization for bottom friction source term routine. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SBT4 Subr. W3SRC3MD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! + + !/ ------------------------------------------------------------------- / + SUBROUTINE INSBT4 + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | SHOM | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 14-Mar-2012 | + !/ +-----------------------------------+ + !/ + !/ 14-Mar-2012 : Origination. ( version 4.05 ) + ! + ! 1. Purpose : + ! + ! Initialization for bottom friction source term routine. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SBT4 Subr. W3SRC3MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -! NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + ! NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INSIN3') + CALL STRACE (IENT, 'INSIN3') #endif -! -! 1. .... ----------------------------------------------------------- * -! - CALL TABU_ERF !tabulates ERF function -!/ -!/ End of INSBT4 ----------------------------------------------------- / -!/ - END SUBROUTINE INSBT4 -! ---------------------------------------------------------------------- - SUBROUTINE TABU_ERF -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | J. Lepesqueur | -!/ | FORTRAN 90 | -!/ | Last update : 14-Mar-2012 | -!/ +-----------------------------------+ -!/ -!/ 14-Mar-2012 : Origination. ( version 3.13 ) -!/ -! 1. Purpose : -! Tabulation of ERF function, which is used in bottom friction subgrid modelling -! -! Initialization for source term routine. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SIN3 Subr. W3SRC3MD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! - IMPLICIT NONE - INTEGER :: I - REAL :: x,y - - DELXERF = (2*XERFMAX)/REAL(SIZEERFTABLE) - DO I=0,SIZEERFTABLE - x=-1.*XERFMAX+I*DELXERF - if(x.lt.0.)then - y=2**(1/2)*(1-abs(erf(x)))/2 - else - y=2**(1/2)*(1+erf(x))/2 - end if - ERFTABLE(I)=y - END DO - RETURN -!/ ------------------------------------------------------------------- / - END SUBROUTINE TABU_ERF -!/ ------------------------------------------------------------------- / + ! + ! 1. .... ----------------------------------------------------------- * + ! + CALL TABU_ERF !tabulates ERF function + !/ + !/ End of INSBT4 ----------------------------------------------------- / + !/ + END SUBROUTINE INSBT4 + ! ---------------------------------------------------------------------- + SUBROUTINE TABU_ERF + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | J. Lepesqueur | + !/ | FORTRAN 90 | + !/ | Last update : 14-Mar-2012 | + !/ +-----------------------------------+ + !/ + !/ 14-Mar-2012 : Origination. ( version 3.13 ) + !/ + ! 1. Purpose : + ! Tabulation of ERF function, which is used in bottom friction subgrid modelling + ! + ! Initialization for source term routine. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SIN3 Subr. W3SRC3MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + IMPLICIT NONE + INTEGER :: I + REAL :: x,y + + DELXERF = (2*XERFMAX)/REAL(SIZEERFTABLE) + DO I=0,SIZEERFTABLE + x=-1.*XERFMAX+I*DELXERF + if(x.lt.0.)then + y=2**(1/2)*(1-abs(erf(x)))/2 + else + y=2**(1/2)*(1+erf(x))/2 + end if + ERFTABLE(I)=y + END DO + RETURN + !/ ------------------------------------------------------------------- / + END SUBROUTINE TABU_ERF + !/ ------------------------------------------------------------------- / + + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SBT4 (A, CG, WN, DEPTH, D50, PSIC, TAUBBL, BEDFORM, S, D, IX, IY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ ! J. Lepesqueur ! + !/ | FORTRAN 90 | + !/ | Last update : 15-Mar-2012 | + !/ +-----------------------------------+ + !/ + !/ 23-Jun-2011 : Origination. ( version 4.04 ) + !/ 04-Jul-2011 : Adding momentum flux TAUBBL ( version 4.05 ) + !/ 15-Mar-2012 : Adding subgrid treatment for depth ( version 4.05 ) + !/ + ! 1. Purpose : + ! + ! Computes the SHOWEX bottom friction with movable bed effects + ! + ! 2. Method : + ! Uses a Gaussian distribution for friction factors, and estimates + ! the contribution of rippled and non-rippled fractions based on + ! the bayesian approach of Tolman (1995). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum. + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! DEPTH Real I Water depth. + ! D50 Real I Median grain size. + ! PSIC Real I Critical Shields parameter + ! BEFORMS Real I/O Ripple parameters (roughness and wavelength). + ! TAUBBL Real O Components of stress leaking to the bottom. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative. *) + ! IX,IY Int. I Spatial grid indices + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE CONSTANTS + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DDEN, & + SBTCX, ECOS, ESIN, DTH -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SBT4 (A, CG, WN, DEPTH, D50, PSIC, TAUBBL, BEDFORM, S, D, IX, IY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ ! J. Lepesqueur ! -!/ | FORTRAN 90 | -!/ | Last update : 15-Mar-2012 | -!/ +-----------------------------------+ -!/ -!/ 23-Jun-2011 : Origination. ( version 4.04 ) -!/ 04-Jul-2011 : Adding momentum flux TAUBBL ( version 4.05 ) -!/ 15-Mar-2012 : Adding subgrid treatment for depth ( version 4.05 ) -!/ -! 1. Purpose : -! -! Computes the SHOWEX bottom friction with movable bed effects -! -! 2. Method : -! Uses a Gaussian distribution for friction factors, and estimates -! the contribution of rippled and non-rippled fractions based on -! the bayesian approach of Tolman (1995). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum. -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! DEPTH Real I Water depth. -! D50 Real I Median grain size. -! PSIC Real I Critical Shields parameter -! BEFORMS Real I/O Ripple parameters (roughness and wavelength). -! TAUBBL Real O Components of stress leaking to the bottom. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative. *) -! IX,IY Int. I Spatial grid indices -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE CONSTANTS - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DDEN, & - SBTCX, ECOS, ESIN, DTH - #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ - LOGICAL, SAVE :: FIRST = .TRUE. - REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, A(NSPEC), D50 - REAL, INTENT(IN) :: PSIC - INTEGER, INTENT(IN) :: IX, IY - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC), TAUBBL(2) - REAL, INTENT(INOUT) :: BEDFORM(3) - REAL :: CBETA(NK) - REAL :: UORB2,UORB,AORB, EBX, EBY, AX, AY, LX, LY - REAL :: CONST2, TEMP2 - REAL :: FW, KSUBN, KSUBS, KSUBR, MINADIM - REAL :: SHIELDS(3), PSI, DELI1, DELI2, EB, XI, VARU, DD50 - INTEGER :: IK, ITH, IS, IND, INDE, ISUB + !/ + LOGICAL, SAVE :: FIRST = .TRUE. + REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, A(NSPEC), D50 + REAL, INTENT(IN) :: PSIC + INTEGER, INTENT(IN) :: IX, IY + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC), TAUBBL(2) + REAL, INTENT(INOUT) :: BEDFORM(3) + REAL :: CBETA(NK) + REAL :: UORB2,UORB,AORB, EBX, EBY, AX, AY, LX, LY + REAL :: CONST2, TEMP2 + REAL :: FW, KSUBN, KSUBS, KSUBR, MINADIM + REAL :: SHIELDS(3), PSI, DELI1, DELI2, EB, XI, VARU, DD50 + INTEGER :: IK, ITH, IS, IND, INDE, ISUB - REAL :: KRR, DSUB - REAL DSUM(NK) -! These are the 3-point Gauss-Hermitte quadrature coefficients - REAL, PARAMETER :: WSUB(3) = (/ 0.1666667, 0.1666666 , 0.6666667/) - REAL, PARAMETER :: XSUB(3) = (/ -0.001, 0.001 , 0. /) + REAL :: KRR, DSUB + REAL DSUM(NK) + ! These are the 3-point Gauss-Hermitte quadrature coefficients + REAL, PARAMETER :: WSUB(3) = (/ 0.1666667, 0.1666666 , 0.6666667/) + REAL, PARAMETER :: XSUB(3) = (/ -0.001, 0.001 , 0. /) - REAL :: PROBA1, PROBA2, PSIX, PSIXT, PSIN2, DPSI , FACTOR - REAL :: BACKGROUND + REAL :: PROBA1, PROBA2, PSIX, PSIXT, PSIN2, DPSI , FACTOR + REAL :: BACKGROUND -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SBT4') + CALL STRACE (IENT, 'W3SBT4') #endif -! -! 0. Initializations ------------------------------------------------ * - IF ( FIRST ) THEN - CALL INSBT4 - FIRST = .FALSE. - END IF + ! + ! 0. Initializations ------------------------------------------------ * + IF ( FIRST ) THEN + CALL INSBT4 + FIRST = .FALSE. + END IF -! -! 1. Min / Max settings for grain size D50---------------------------- * -! - DD50=MAX(D50,1E-5) - DD50=MIN(DD50,1.) -! -! 1.1 Set background roughness when ripples are not active -! - BACKGROUND=MAX(SBTCX(6),SBTCX(7)*DD50) -! -! 2. Subgrid loop -! - DSUM(:)=0. - TAUBBL(:)=0. -! - DO ISUB=1,3 -! -! 2.a Computes bulk parameters : E, Uorb, Aorb------------------------- * -! - DSUB=DEPTH*(1.+XSUB(ISUB)) - UORB=0. - AORB=0. - AX =0. - AY =0. + ! + ! 1. Min / Max settings for grain size D50---------------------------- * + ! + DD50=MAX(D50,1E-5) + DD50=MIN(DD50,1.) + ! + ! 1.1 Set background roughness when ripples are not active + ! + BACKGROUND=MAX(SBTCX(6),SBTCX(7)*DD50) + ! + ! 2. Subgrid loop + ! + DSUM(:)=0. + TAUBBL(:)=0. + ! + DO ISUB=1,3 + ! + ! 2.a Computes bulk parameters : E, Uorb, Aorb------------------------- * + ! + DSUB=DEPTH*(1.+XSUB(ISUB)) + UORB=0. + AORB=0. + AX =0. + AY =0. - DO IK=1, NK - IF ( WN(IK)*DSUB .LT. 6. ) THEN - EB = 0. - EBX = 0. - EBY = 0. - DO ITH=1, NTH - IS=ITH+(IK-1)*NTH - EB = EB + A(IS) - EBX = EBX +A(IS)*ECOS(ITH) - EBY = EBY +A(IS)*ESIN(ITH) - END DO -! -! U_bot=sigma * Zeta / sinh(KD) and CBETA = 0.5*sigma^2 /(g*sinh^(kD)) -! therefore variance(u_bot)= variance(elevation)*2*CBETA/D -! -! CBETA(IK) = MAX(0., (CG(IK)*WN(IK)/SIG(IK)-0.5) )/DSUB - CBETA(IK) = 0.5*SIG(IK)**2 /(GRAV*(SINH(WN(IK)*DSUB))**2) -! N.B.: could also include shoaling effect on EB ... - FACTOR= (DDEN(IK) / CG(IK))*2*CBETA(IK)*GRAV - VARU= EB * FACTOR - UORB = UORB + VARU - AORB = AORB + VARU/(SIG(IK)**2) - AX = AX + (EBX * FACTOR) - AY = AY + (EBY * FACTOR) - ELSE - CBETA(IK) = 0. - END IF + DO IK=1, NK + IF ( WN(IK)*DSUB .LT. 6. ) THEN + EB = 0. + EBX = 0. + EBY = 0. + DO ITH=1, NTH + IS=ITH+(IK-1)*NTH + EB = EB + A(IS) + EBX = EBX +A(IS)*ECOS(ITH) + EBY = EBY +A(IS)*ESIN(ITH) END DO -! -! Computes RMS orbital amplitudes -! - UORB2 = 2*UORB - UORB = SQRT(MAX(1.0E-7,UORB2)) - AORB = SQRT(MAX(1.0E-7,2*AORB)) -! -! Computes potential ripple wavelength, 1.7 = 2 * sqrt(2) * 0.6 -! Based on Ardhuin et al. (JGR 2002): lambda = 0.6 * d_1/3 -! - LX = AORB*1.7*AX/SQRT(AX**2+AY**2+1E-12) - LY = AORB*1.7*AY/SQRT(AX**2+AY**2+1E-12) -! -! 2.b First use of FWTABLE to get skin roughness and estimate Shields parameter -! - XI=MAX((ALOG10(MAX(AORB/DD50,0.3))-ABMIN)/DELAB,1.) - IND = MIN (SIZEFWTABLE-1, INT(XI)) - DELI1= MIN (1. ,XI-FLOAT(IND)) - DELI2= 1. - DELI1 - FW =FWTABLE(IND)*DELI2+FWTABLE(IND+1)*DELI1 - - PSI=FW*UORB2/(2.*GRAV*(SED_SG-1)*DD50) -! -! Normalized Shields parameter -! - SHIELDS(ISUB)=PSI/PSIC -! - END DO ! end of loop on ISUB - DPSI=(SHIELDS(2)-SHIELDS(1))/(XSUB(2)-XSUB(1))*SBTCX(5) -! -! Tests if the variation in psi is large enough to use subgrid -! - IF (ABS(DPSI).LT.0.0001*SHIELDS(3).OR.ABS(DPSI).LT.1.E-8) THEN -! -! no subgrid in this case -! - IF(SHIELDS(3).GT.SBTCX(3)) THEN + ! + ! U_bot=sigma * Zeta / sinh(KD) and CBETA = 0.5*sigma^2 /(g*sinh^(kD)) + ! therefore variance(u_bot)= variance(elevation)*2*CBETA/D + ! + ! CBETA(IK) = MAX(0., (CG(IK)*WN(IK)/SIG(IK)-0.5) )/DSUB + CBETA(IK) = 0.5*SIG(IK)**2 /(GRAV*(SINH(WN(IK)*DSUB))**2) + ! N.B.: could also include shoaling effect on EB ... + FACTOR= (DDEN(IK) / CG(IK))*2*CBETA(IK)*GRAV + VARU= EB * FACTOR + UORB = UORB + VARU + AORB = AORB + VARU/(SIG(IK)**2) + AX = AX + (EBX * FACTOR) + AY = AY + (EBY * FACTOR) + ELSE + CBETA(IK) = 0. + END IF + END DO + ! + ! Computes RMS orbital amplitudes + ! + UORB2 = 2*UORB + UORB = SQRT(MAX(1.0E-7,UORB2)) + AORB = SQRT(MAX(1.0E-7,2*AORB)) + ! + ! Computes potential ripple wavelength, 1.7 = 2 * sqrt(2) * 0.6 + ! Based on Ardhuin et al. (JGR 2002): lambda = 0.6 * d_1/3 + ! + LX = AORB*1.7*AX/SQRT(AX**2+AY**2+1E-12) + LY = AORB*1.7*AY/SQRT(AX**2+AY**2+1E-12) + ! + ! 2.b First use of FWTABLE to get skin roughness and estimate Shields parameter + ! + XI=MAX((ALOG10(MAX(AORB/DD50,0.3))-ABMIN)/DELAB,1.) + IND = MIN (SIZEFWTABLE-1, INT(XI)) + DELI1= MIN (1. ,XI-FLOAT(IND)) + DELI2= 1. - DELI1 + FW =FWTABLE(IND)*DELI2+FWTABLE(IND+1)*DELI1 -! ripple roughness, see Ardhuin et al. (2003) - KSUBR=AORB*SBTCX(1)*SHIELDS(3)**SBTCX(2) -! Sheet flow roughness, see Wilson (1989) - KSUBS=AORB*0.0655*(UORB2/((SED_SG-1)*GRAV*AORB))**1.4 - KSUBN = KSUBR + KSUBS - BEDFORM(2)=LX - BEDFORM(3)=LY - ELSE -! relict roughness, see Ardhuin et al. (2003) - KSUBN=MAX(BACKGROUND,AORB*SBTCX(4)) - BEDFORM(2)=-LX - BEDFORM(3)=-LY - END IF + PSI=FW*UORB2/(2.*GRAV*(SED_SG-1)*DD50) + ! + ! Normalized Shields parameter + ! + SHIELDS(ISUB)=PSI/PSIC + ! + END DO ! end of loop on ISUB + DPSI=(SHIELDS(2)-SHIELDS(1))/(XSUB(2)-XSUB(1))*SBTCX(5) + ! + ! Tests if the variation in psi is large enough to use subgrid + ! + IF (ABS(DPSI).LT.0.0001*SHIELDS(3).OR.ABS(DPSI).LT.1.E-8) THEN + ! + ! no subgrid in this case + ! + IF(SHIELDS(3).GT.SBTCX(3)) THEN - BEDFORM(1)=KSUBN + ! ripple roughness, see Ardhuin et al. (2003) + KSUBR=AORB*SBTCX(1)*SHIELDS(3)**SBTCX(2) + ! Sheet flow roughness, see Wilson (1989) + KSUBS=AORB*0.0655*(UORB2/((SED_SG-1)*GRAV*AORB))**1.4 + KSUBN = KSUBR + KSUBS + BEDFORM(2)=LX + BEDFORM(3)=LY + ELSE + ! relict roughness, see Ardhuin et al. (2003) + KSUBN=MAX(BACKGROUND,AORB*SBTCX(4)) + BEDFORM(2)=-LX + BEDFORM(3)=-LY + END IF - ELSE -! -! subgrid in this case -! - PSIX=(SBTCX(3)-SHIELDS(3))/DPSI + BEDFORM(1)=KSUBN - PSIXT=MAX((PSIX + XERFMAX)/DELXERF,0.) - INDE = MAX(MIN (SIZEERFTABLE-1, INT(PSIXT)),0) - DELI1 = MIN (1. ,PSIXT-FLOAT(INDE)) - DELI2 = 1. - DELI1 - PROBA2=MAX(MIN(ERFTABLE(INDE)*DELI2+ERFTABLE(INDE+1)*DELI1,1.),0.) - PROBA1 = 1. - PROBA2 -! Mean psi with ripples (Tolman 1995, eq. XX) - PSIN2=MAX(SHIELDS(3)+EXP(-(0.5*PSIX**2))/SQRT(TPI)*DPSI/(PROBA2+0.0001),SBTCX(3)) -! Sum of relict, ripple and sheet flow roughnesses - KSUBN = PROBA1*MAX(BACKGROUND,AORB*SBTCX(4)) & - +PROBA2*AORB*(SBTCX(1)*PSIN2**SBTCX(2)+ & - 0.0655*(UORB2/((SED_SG-1)*GRAV*AORB))**1.4) -! - IF (PROBA2.GT.0.5) THEN - BEDFORM(2)=LX - BEDFORM(3)=LY - ELSE - BEDFORM(2)=-LX - BEDFORM(3)=-LY - END IF -! - END IF - BEDFORM(1)=KSUBN + ELSE + ! + ! subgrid in this case + ! + PSIX=(SBTCX(3)-SHIELDS(3))/DPSI -! -! 2.c second use of FWTABLE to get FW from the full roughness -! - XI=MAX((ALOG10(MAX(AORB/KSUBN,0.3))-ABMIN)/DELAB,1.) - IND = MIN (SIZEFWTABLE-1, INT(XI)) - DELI1= MIN (1. ,XI-FLOAT(IND)) - DELI2= 1. - DELI1 - FW =FWTABLE(IND)*DELI2+FWTABLE(IND+1)*DELI1 -! -! 5. Fills output arrays and estimates the energy and momentum loss -! - DO IK=1, NK - CONST2=DDEN(IK)/CG(IK) & !Jacobian to get energy in band - *GRAV/(SIG(IK)/WN(IK)) ! coefficient to get momentum - DSUM(IK)=-FW*UORB*CBETA(IK) !*WSUB(ISUB) - DO ITH=1,NTH - IS=ITH+(IK-1)*NTH - D(IS)=DSUM(IK) - TEMP2=CONST2*D(IS)*A(IS) - TAUBBL(1) = TAUBBL(1) - TEMP2*ECOS(IS) - TAUBBL(2) = TAUBBL(2) - TEMP2*ESIN(IS) - S(IS)=D(IS)*A(IS) - END DO - END DO -! + PSIXT=MAX((PSIX + XERFMAX)/DELXERF,0.) + INDE = MAX(MIN (SIZEERFTABLE-1, INT(PSIXT)),0) + DELI1 = MIN (1. ,PSIXT-FLOAT(INDE)) + DELI2 = 1. - DELI1 + PROBA2=MAX(MIN(ERFTABLE(INDE)*DELI2+ERFTABLE(INDE+1)*DELI1,1.),0.) + PROBA1 = 1. - PROBA2 + ! Mean psi with ripples (Tolman 1995, eq. XX) + PSIN2=MAX(SHIELDS(3)+EXP(-(0.5*PSIX**2))/SQRT(TPI)*DPSI/(PROBA2+0.0001),SBTCX(3)) + ! Sum of relict, ripple and sheet flow roughnesses + KSUBN = PROBA1*MAX(BACKGROUND,AORB*SBTCX(4)) & + +PROBA2*AORB*(SBTCX(1)*PSIN2**SBTCX(2)+ & + 0.0655*(UORB2/((SED_SG-1)*GRAV*AORB))**1.4) + ! + IF (PROBA2.GT.0.5) THEN + BEDFORM(2)=LX + BEDFORM(3)=LY + ELSE + BEDFORM(2)=-LX + BEDFORM(3)=-LY + END IF + ! + END IF + BEDFORM(1)=KSUBN + + ! + ! 2.c second use of FWTABLE to get FW from the full roughness + ! + XI=MAX((ALOG10(MAX(AORB/KSUBN,0.3))-ABMIN)/DELAB,1.) + IND = MIN (SIZEFWTABLE-1, INT(XI)) + DELI1= MIN (1. ,XI-FLOAT(IND)) + DELI2= 1. - DELI1 + FW =FWTABLE(IND)*DELI2+FWTABLE(IND+1)*DELI1 + ! + ! 5. Fills output arrays and estimates the energy and momentum loss + ! + DO IK=1, NK + CONST2=DDEN(IK)/CG(IK) & !Jacobian to get energy in band + *GRAV/(SIG(IK)/WN(IK)) ! coefficient to get momentum + DSUM(IK)=-FW*UORB*CBETA(IK) !*WSUB(ISUB) + DO ITH=1,NTH + IS=ITH+(IK-1)*NTH + D(IS)=DSUM(IK) + TEMP2=CONST2*D(IS)*A(IS) + TAUBBL(1) = TAUBBL(1) - TEMP2*ECOS(IS) + TAUBBL(2) = TAUBBL(2) - TEMP2*ESIN(IS) + S(IS)=D(IS)*A(IS) + END DO + END DO + ! RETURN -!/ -!/ End of W3SBT4 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SBT4 + !/ + !/ End of W3SBT4 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SBT4 -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / - END MODULE W3SBT4MD +END MODULE W3SBT4MD diff --git a/model/src/w3sbt8md.F90 b/model/src/w3sbt8md.F90 index 94d855ca1..f598c2fbe 100644 --- a/model/src/w3sbt8md.F90 +++ b/model/src/w3sbt8md.F90 @@ -1,294 +1,294 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SBT8MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA | -!/ | M. Orzech NRL | -!/ | W. E. Rogers NRL | -!/ | FORTRAN 90 | -!/ | Last update : 21-Nov-2013 | -!/ +-----------------------------------+ -!/ -!/ 28-Jul-2011 : Origination. ( version 4.01 ) -!/ 21-Nov-2013 : Preparing distribution version. ( version 4.11 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Contains routines for computing dissipation by viscous fluid mud using -! Dalrymple and Liu (1978) "Thin Model". -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SBT8 Subr. Public Fluid mud dissipation (Dalrymple & Liu, 1978) -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! CSINH Subr. ?? Complex sinh function -! CCOSH Subr. ?? Complex cosh function -! ---------------------------------------------------------------- -! -! 5. Remarks : -! Historical information: -! This started as a matlab script provided to Erick Rogers by Tony -! Dalrympyle Sep 2006. Erick Rogers converted to Fortran and put -! it into the SWAN model May 2007. Mark Orzech adapted the code for -! WW3 and added it to NRL code repository July-Dec 2011. -! Erick Rogers brought it over to the NCEP repository May 2013 -! and has been updating and maintaining it there. -! -! Reference: Dalrymple, R.A., Liu,P.L.-F.,1978: -! Waves over soft muds :a 2-layer fluid model. -! Journal of Physical Oceanography, 8, 1121–1131. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SBT8(AC,H_WDEPTH,S,D,IX,IY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA | -!/ | M. Orzech NRL | -!/ | W. E. Rogers NRL | -!/ | FORTRAN 90 | -!/ | Last update : 21-Nov-2013 | -!/ +-----------------------------------+ -!/ -!/ 20-Dec-2004 : Origination. ( version 3.06 -!/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) -!/ inclusion in WAVEWATCH III. -!/ -! 1. Purpose : -! -! Compute dissipation by viscous fluid mud using Dalrymple and Liu (1978) -! "Thin Model" (adapted from Erick Rogers code by Mark Orzech, NRL). -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! AC R.A. I Action density spectrum (1-D) -! H_WDEPTH Real I Mean water depth. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! Cg_mud calculation could be improved by using dsigma/dk instead -! of n*C. The latter is a "naive" method and its accuracy has -! not been confirmed. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NK,SIG,NSPEC,MAPWN - USE W3IDATMD, ONLY: MUDT, MUDV, MUDD, INFLAGS1 - USE CONSTANTS, ONLY: PI,GRAV,DWAT,NU_WATER - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE W3DISPMD, ONLY: WAVNU1 +MODULE W3SBT8MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA | + !/ | M. Orzech NRL | + !/ | W. E. Rogers NRL | + !/ | FORTRAN 90 | + !/ | Last update : 21-Nov-2013 | + !/ +-----------------------------------+ + !/ + !/ 28-Jul-2011 : Origination. ( version 4.01 ) + !/ 21-Nov-2013 : Preparing distribution version. ( version 4.11 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Contains routines for computing dissipation by viscous fluid mud using + ! Dalrymple and Liu (1978) "Thin Model". + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SBT8 Subr. Public Fluid mud dissipation (Dalrymple & Liu, 1978) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! CSINH Subr. ?? Complex sinh function + ! CCOSH Subr. ?? Complex cosh function + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! Historical information: + ! This started as a matlab script provided to Erick Rogers by Tony + ! Dalrympyle Sep 2006. Erick Rogers converted to Fortran and put + ! it into the SWAN model May 2007. Mark Orzech adapted the code for + ! WW3 and added it to NRL code repository July-Dec 2011. + ! Erick Rogers brought it over to the NCEP repository May 2013 + ! and has been updating and maintaining it there. + ! + ! Reference: Dalrymple, R.A., Liu,P.L.-F.,1978: + ! Waves over soft muds :a 2-layer fluid model. + ! Journal of Physical Oceanography, 8, 1121–1131. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SBT8(AC,H_WDEPTH,S,D,IX,IY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA | + !/ | M. Orzech NRL | + !/ | W. E. Rogers NRL | + !/ | FORTRAN 90 | + !/ | Last update : 21-Nov-2013 | + !/ +-----------------------------------+ + !/ + !/ 20-Dec-2004 : Origination. ( version 3.06 + !/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) + !/ inclusion in WAVEWATCH III. + !/ + ! 1. Purpose : + ! + ! Compute dissipation by viscous fluid mud using Dalrymple and Liu (1978) + ! "Thin Model" (adapted from Erick Rogers code by Mark Orzech, NRL). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! AC R.A. I Action density spectrum (1-D) + ! H_WDEPTH Real I Mean water depth. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! Cg_mud calculation could be improved by using dsigma/dk instead + ! of n*C. The latter is a "naive" method and its accuracy has + ! not been confirmed. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NK,SIG,NSPEC,MAPWN + USE W3IDATMD, ONLY: MUDT, MUDV, MUDD, INFLAGS1 + USE CONSTANTS, ONLY: PI,GRAV,DWAT,NU_WATER + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE W3DISPMD, ONLY: WAVNU1 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: H_WDEPTH ! water depth - REAL, INTENT(IN) :: AC(NSPEC) ! action density - INTEGER, INTENT(IN) :: IX, IY - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: H_WDEPTH ! water depth + REAL, INTENT(IN) :: AC(NSPEC) ! action density + INTEGER, INTENT(IN) :: IX, IY + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - - COMPLEX :: K - COMPLEX :: SHH - COMPLEX :: CHH - COMPLEX :: SHD - COMPLEX :: CHD - COMPLEX :: LAM1 - COMPLEX :: LAM2 - COMPLEX :: CHLAM2 - COMPLEX :: SHLAM2 - COMPLEX :: A1 - COMPLEX :: A2 - COMPLEX :: A3 - COMPLEX :: B1 - COMPLEX :: B2 - COMPLEX :: B3 - COMPLEX :: B4 - COMPLEX :: C0 - COMPLEX :: TESTALF1 - COMPLEX :: TESTALF2 - COMPLEX :: ALF1 - COMPLEX :: ALF2 - COMPLEX :: PSI1 - COMPLEX :: PSI2 - COMPLEX :: M1 - COMPLEX :: M0 - COMPLEX :: C(4,3) - COMPLEX :: C41A - COMPLEX :: C42A - COMPLEX :: C43A - COMPLEX :: B(4) - COMPLEX :: CD - COMPLEX :: HH - COMPLEX :: DD - COMPLEX :: GG - COMPLEX :: FM1 - COMPLEX :: KM1 - COMPLEX :: FP - COMPLEX :: I - COMPLEX :: F - COMPLEX :: KMUD - - REAL :: BET0 - REAL :: KINVISW - REAL :: RHOW - REAL :: EXPH - REAL :: A - REAL :: K_UNMUD - REAL :: SIGMA ! radian frequency (rad) - REAL :: SMUDWD(NK) ! dissipation due to mud - REAL :: KMIMAG(NK) ! imag part of kmud - REAL :: KD - REAL :: KDCUTOFF - REAL :: CWAVE - REAL :: ZTMP - REAL :: NWAVE_MUD - REAL :: CG_MUD - REAL :: KCHECK - REAL :: KTHRESHOLD - REAL :: RHOM - REAL :: KINVISM - REAL :: THICKM - REAL :: CG_UNMUD - - INTEGER :: ICOUNT - INTEGER :: IK - INTEGER :: IS - - PARAMETER (I=(0.,1.)) - -!/ -!/ ------------------------------------------------------------------- / -!/ + + COMPLEX :: K + COMPLEX :: SHH + COMPLEX :: CHH + COMPLEX :: SHD + COMPLEX :: CHD + COMPLEX :: LAM1 + COMPLEX :: LAM2 + COMPLEX :: CHLAM2 + COMPLEX :: SHLAM2 + COMPLEX :: A1 + COMPLEX :: A2 + COMPLEX :: A3 + COMPLEX :: B1 + COMPLEX :: B2 + COMPLEX :: B3 + COMPLEX :: B4 + COMPLEX :: C0 + COMPLEX :: TESTALF1 + COMPLEX :: TESTALF2 + COMPLEX :: ALF1 + COMPLEX :: ALF2 + COMPLEX :: PSI1 + COMPLEX :: PSI2 + COMPLEX :: M1 + COMPLEX :: M0 + COMPLEX :: C(4,3) + COMPLEX :: C41A + COMPLEX :: C42A + COMPLEX :: C43A + COMPLEX :: B(4) + COMPLEX :: CD + COMPLEX :: HH + COMPLEX :: DD + COMPLEX :: GG + COMPLEX :: FM1 + COMPLEX :: KM1 + COMPLEX :: FP + COMPLEX :: I + COMPLEX :: F + COMPLEX :: KMUD + + REAL :: BET0 + REAL :: KINVISW + REAL :: RHOW + REAL :: EXPH + REAL :: A + REAL :: K_UNMUD + REAL :: SIGMA ! radian frequency (rad) + REAL :: SMUDWD(NK) ! dissipation due to mud + REAL :: KMIMAG(NK) ! imag part of kmud + REAL :: KD + REAL :: KDCUTOFF + REAL :: CWAVE + REAL :: ZTMP + REAL :: NWAVE_MUD + REAL :: CG_MUD + REAL :: KCHECK + REAL :: KTHRESHOLD + REAL :: RHOM + REAL :: KINVISM + REAL :: THICKM + REAL :: CG_UNMUD + + INTEGER :: ICOUNT + INTEGER :: IK + INTEGER :: IS + + PARAMETER (I=(0.,1.)) + + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SBT8') + CALL STRACE (IENT, 'W3SBT8') #endif -! -! 0. Initializations ------------------------------------------------ * -! - ! Dalrymple and Liu, Waves over soft muds: 1978. - ! Thin layer solution. - ! Matlab code provided by Tony Dalrymple - ! Converted to Fortran by Erick Rogers - - ! Initialize properties from mud fields if available - IF (INFLAGS1(-2))THEN - RHOM = MUDD(IX,IY) - ELSE - WRITE(NDSE,*)'RHOM NOT SET' - CALL EXTCDE ( 1 ) - ENDIF - IF (INFLAGS1(-1)) THEN - THICKM = MUDT(IX,IY) - ELSE - WRITE(NDSE,*)'THICKM NOT SET' - CALL EXTCDE ( 2 ) - ENDIF - IF (INFLAGS1(0)) THEN - KINVISM = MUDV(IX,IY) - ELSE - WRITE(NDSE,*)'KINVISM NOT SET' - CALL EXTCDE ( 3 ) - ENDIF - - RHOW=DWAT ! Density of seawater - KINVISW=NU_WATER - KDCUTOFF = 10.0 - KTHRESHOLD=1.0E-9 - - A=1.0 - -! initialize matrix diagonal contributions - D = 0.0 - S = 0.0 - - IF ( THICKM>0.0 .AND. RHOM>0.0 .AND. KINVISM>0.0 ) THEN + ! + ! 0. Initializations ------------------------------------------------ * + ! + ! Dalrymple and Liu, Waves over soft muds: 1978. + ! Thin layer solution. + ! Matlab code provided by Tony Dalrymple + ! Converted to Fortran by Erick Rogers + + ! Initialize properties from mud fields if available + IF (INFLAGS1(-2))THEN + RHOM = MUDD(IX,IY) + ELSE + WRITE(NDSE,*)'RHOM NOT SET' + CALL EXTCDE ( 1 ) + ENDIF + IF (INFLAGS1(-1)) THEN + THICKM = MUDT(IX,IY) + ELSE + WRITE(NDSE,*)'THICKM NOT SET' + CALL EXTCDE ( 2 ) + ENDIF + IF (INFLAGS1(0)) THEN + KINVISM = MUDV(IX,IY) + ELSE + WRITE(NDSE,*)'KINVISM NOT SET' + CALL EXTCDE ( 3 ) + ENDIF + + RHOW=DWAT ! Density of seawater + KINVISW=NU_WATER + KDCUTOFF = 10.0 + KTHRESHOLD=1.0E-9 + + A=1.0 + + ! initialize matrix diagonal contributions + D = 0.0 + S = 0.0 + + IF ( THICKM>0.0 .AND. RHOM>0.0 .AND. KINVISM>0.0 ) THEN SMUDWD = 0.0 -! *** loop over frequencies + ! *** loop over frequencies DO IK = 1,NK - + SIGMA = SIG(IK) - ! un-muddy wave number, to start things off + ! un-muddy wave number, to start things off CALL WAVNU1(SIGMA,H_WDEPTH,K_UNMUD,CG_UNMUD) K=K_UNMUD @@ -296,185 +296,185 @@ SUBROUTINE W3SBT8(AC,H_WDEPTH,S,D,IX,IY) DO ICOUNT=1,20 ! *** May need more *** - CALL CSINH(K*H_WDEPTH,SHH) - CALL CCOSH(K*H_WDEPTH,CHH) - CALL CSINH(K*THICKM,SHD) - CALL CCOSH(K*THICKM,CHD) - - ! define lambdas - LAM1=SQRT(K*K-I*SIGMA/KINVISW) - LAM2=SQRT(K*K-I*SIGMA/KINVISM) - - ! define hyperbolics on lamda2, lamda1 - CALL CCOSH(LAM2*THICKM,CHLAM2) - CALL CSINH(LAM2*THICKM,SHLAM2) - - ! define exp decay - EXPH=EXP(-LAM1*H_WDEPTH) - - ! define a1, a2, a3 - A1=-LAM2*SHD/K+SHLAM2 - A2=-CHD+CHLAM2 - A3=SHD-LAM2*SHLAM2/K - - ! define b1, b2, b3, b4 - B1=LAM1*SHH/K-CHH - B2=LAM2*A2*SHH/K+A1*CHH - B3=-A3*SHH+A2*CHH - B4=LAM1*SHH/K+CHH - - ! define c0 - C0=B4*EXPH-(LAM1*LAM1+K*K)/(2*K*K) - - ! define beta0 - BET0=-EXPH/C0 - - ! define alfa1, alfa2 - TESTALF1=-RHOM*KINVISM*(LAM2*LAM2+K*K)*(-LAM2/K)*CHD/K & - -2*RHOM*KINVISM*LAM2*CHLAM2-(RHOM-RHOW)*GRAV*(I*(A1)/SIGMA) - TESTALF2=-RHOM*KINVISM*(LAM2*LAM2+K*K)*(-1)*SHD/K & - -2*RHOM*KINVISM*LAM2*SHLAM2-(RHOM-RHOW)*GRAV*(I*(A2)/SIGMA) - ALF1=-TESTALF1 - ALF2=-TESTALF2 - - ! define psi1, psi2 - PSI1=2*K*(-LAM2/K)*SHD+(LAM2*LAM2+K*K)*SHLAM2/K - PSI2=2*K*(-1)*CHD+(LAM2*LAM2+K*K)*CHLAM2/K - - ! define M1, MO - M1=I*RHOW*SIGMA/K-2*RHOW*KINVISW*K - M0=B1+(LAM1*LAM1+K*K)*EXPH/(K*K) - - ! matrix coefficients (eq. 22) - C(1,1)=LAM1*(BET0*M0+1)*SHH/K+(BET0*M0-1)*CHH+M0/C0+EXPH - C(1,2)=(LAM1*BET0*B2+LAM2*A2)*SHH/K+(BET0*B2+A1)*CHH+B2/C0 - C(1,3)=(LAM1*BET0*B3/K-A3)*SHH+(BET0*B3+A2)*CHH+B3/C0 - - ! matrix coefficients (eq. 23) - C(2,1)=LAM1*(BET0*M0+1)*M1*CHH/K+(BET0*M0-1)*M1*SHH & - -2*RHOW*KINVISW*LAM1*M0/C0+2*RHOW*KINVISW*LAM1*EXPH - C(2,2)=(LAM1*BET0*B2+LAM2*A2)*M1*CHH/K+(BET0*B2+A1)*M1*SHH & - -2*RHOW*KINVISW*LAM1*B2/C0 - C(2,3)=(LAM1*BET0*B3/K-A3)*M1*CHH+(BET0*B3+A2)*M1*SHH & - -2*RHOW*KINVISW*LAM1*B3/C0 - - ! matrix coefficients (eq. 21) - C(3,1)=2*K*RHOW*KINVISW*(BET0*M0-1)+RHOW*KINVISW & - *(LAM1*LAM1+K*K)*(1-BET0*M0)/K - C(3,2)=2*K*RHOW*KINVISW*(BET0*B2+A1)-RHOW*KINVISW & - *(LAM1*LAM1+K*K)*BET0*B2/K-I*RHOM*KINVISM*PSI1 - C(3,3)=2*K*RHOW*KINVISW*(BET0*B3+A2)-RHOW*KINVISW & - *(LAM1*LAM1+K*K)*BET0*B3/K-I*RHOM*KINVISM*PSI2 - - ! matrix coefficients (eq.19) - C41A=LAM1*M1*(BET0*M0+1)/K+2*RHOW*KINVISW*LAM1 & - +2*RHOW*KINVISW*LAM1*BET0*M0 - C42A=M1*(LAM1*BET0*B2+LAM2*A2)/K & - +2*RHOW*KINVISW*LAM1*BET0*B2+ALF1 - C43A=M1*(LAM1*BET0*B3/K-A3)+2*RHOW*KINVISW*LAM1*BET0*B3+ALF2 - - ! method 1 - C(4,1)=C41A*C(3,1)/C41A-C(3,1) - C(4,2)=C42A*C(3,1)/C41A-C(3,2) - C(4,3)=C43A*C(3,1)/C41A-C(3,3) - - ! force terms......righthand side - B(1)=-I*SIGMA*A - B(2)=RHOW*GRAV*A - B(3)=0 - B(4)=0 - ! coefficients - CD=-(C(3,3)-C(3,2)*C(4,3)/C(4,2))/C(3,1) - HH=B(2)/(C(2,1)*CD -C(2,2)*(C(4,3)/C(4,2))+C(2,3)) - DD=CD*HH - GG=-C(4,3)*HH/C(4,2) - - ! find k - F=C(1,1)*DD+C(1,2)*GG+C(1,3)*HH-B(1) - - IF(ICOUNT.EQ.1)THEN - FM1=F - KM1=K - K=K*(.995)+.001*I - KCHECK=100.0 - ELSE - KCHECK=ABS(IMAG(K)-IMAG(KM1)) - IF((F.EQ.FM1).OR.(K.EQ.KM1).OR.(KCHECK0.0 & RHOM>0.0 & KINVISM>0.0 ) THEN - - S = D * AC - - RETURN -!/ -!/ End of W3SBT8 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SBT8 - -!/ ------------------------------------------------------------------- / - - SUBROUTINE CSINH(C,CS) - COMPLEX, INTENT(IN) :: C - COMPLEX, INTENT(OUT) :: CS - X = REAL(C) - Y = AIMAG(C) - CS = CMPLX(SINH(X) * COS(Y), SIN(Y) * COSH(X)) - RETURN - END SUBROUTINE CSINH - -!/ ------------------------------------------------------------------- / - - SUBROUTINE CCOSH(C,CC) - COMPLEX, INTENT(IN) :: C - COMPLEX, INTENT(OUT) :: CC - X = REAL(C) - Y = AIMAG(C) - CC = CMPLX(COSH(X) * COS(Y), SIN(Y) * SINH(X)) - RETURN - END SUBROUTINE CCOSH - -!/ ------------------------------------------------------------------- / -!/ - END MODULE W3SBT8MD + END IF ! IF ( THICKM>0.0 & RHOM>0.0 & KINVISM>0.0 ) THEN + + S = D * AC + + RETURN + !/ + !/ End of W3SBT8 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SBT8 + + !/ ------------------------------------------------------------------- / + + SUBROUTINE CSINH(C,CS) + COMPLEX, INTENT(IN) :: C + COMPLEX, INTENT(OUT) :: CS + X = REAL(C) + Y = AIMAG(C) + CS = CMPLX(SINH(X) * COS(Y), SIN(Y) * COSH(X)) + RETURN + END SUBROUTINE CSINH + + !/ ------------------------------------------------------------------- / + + SUBROUTINE CCOSH(C,CC) + COMPLEX, INTENT(IN) :: C + COMPLEX, INTENT(OUT) :: CC + X = REAL(C) + Y = AIMAG(C) + CC = CMPLX(COSH(X) * COS(Y), SIN(Y) * SINH(X)) + RETURN + END SUBROUTINE CCOSH + + !/ ------------------------------------------------------------------- / + !/ +END MODULE W3SBT8MD diff --git a/model/src/w3sbt9md.F90 b/model/src/w3sbt9md.F90 index cd4da206e..217a54977 100644 --- a/model/src/w3sbt9md.F90 +++ b/model/src/w3sbt9md.F90 @@ -1,527 +1,526 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SBT9MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA | -!/ | M. Orzech NRL | -!/ | W. E. Rogers NRL | -!/ | FORTRAN 90 | -!/ | Last update : 21-Nov-2013 | -!/ +-----------------------------------+ -!/ -!/ 28-Jul-2011 : Origination. ( version 4.01 ) -!/ 21-Nov-2013 : Preparing distribution version. ( version 4.11 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Contains routines for computing dissipation by viscous fluid mud using -! Ng (2000) -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SBT9 Subr. Public Fluid mud dissipation (Ng 2000) -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! CSINH Subr. ?? Complex sinh function -! CCOSH Subr. ?? Complex cosh function -! Z_WNUMB Subr. ?? Compute wave number from freq & depth -! ---------------------------------------------------------------- -! -! 5. Remarks : -! Historical information: -! This started as some equations (the "B" parameter equations -! in subroutine "Ng" below) in a standalone Fortran -! code written by Jim Kaihatu, December 2004. These were adapted by -! Erick Rogers for a simple model based on governing equation -! similar to SWAN, and installed in a full version of SWAN in -! March 2005 with an informal report in May 2005. Kaihatu provided -! a "patch" for the B equations May 2006. Mud code in SWAN v40.41A was -! finalized June 2006, and v40.51 August 2007. The code was applied -! to Cassino Beach ~Sep 2006. This work was presented at a conference -! in Brazil Nov 2006, and later published in Rogers and Holland -! (CSR 2009). The code was adapted for WW3 by Mark Orzech in Nov 2012 -! (he had installed the D&L routines as BT8 in July 2011). -! -! Reference: Ng, C.O.,2000. Water waves over a muddy bed: -! a two-layer Stokes’ boundary layer model. -! Coastal Engineering 40(3),221–242. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SBT9(AC,H_WDEPTH,S,D,IX,IY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA | -!/ | M. Orzech NRL | -!/ | W. E. Rogers NRL | -!/ | FORTRAN 90 | -!/ | Last update : 21-Nov-2013 | -!/ +-----------------------------------+ - -!/ 28-Jul-2011 : Origination. ( version 4.01 ) -!/ 21-Nov-2013 : Preparing distribution version. ( version 4.11 ) -!/ -! 1. Purpose : -! -! Compute dissipation by viscous fluid mud using Ng (2000) -! (adapted from Erick Rogers code by Mark Orzech, NRL). -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! H_WDEPTH Real I Mean water depth. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! CALC_ND -! NG -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! Cg_mud calculation could be improved by using dsigma/dk instead -! of n*C. The latter is a "naive" method and its accuracy has -! not been confirmed. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NK,SIG,NSPEC,MAPWN - USE W3IDATMD, ONLY: MUDT, MUDV, MUDD, INFLAGS1 - USE CONSTANTS, ONLY: PI,GRAV,DWAT,NU_WATER - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE +MODULE W3SBT9MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA | + !/ | M. Orzech NRL | + !/ | W. E. Rogers NRL | + !/ | FORTRAN 90 | + !/ | Last update : 21-Nov-2013 | + !/ +-----------------------------------+ + !/ + !/ 28-Jul-2011 : Origination. ( version 4.01 ) + !/ 21-Nov-2013 : Preparing distribution version. ( version 4.11 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Contains routines for computing dissipation by viscous fluid mud using + ! Ng (2000) + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SBT9 Subr. Public Fluid mud dissipation (Ng 2000) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! CSINH Subr. ?? Complex sinh function + ! CCOSH Subr. ?? Complex cosh function + ! Z_WNUMB Subr. ?? Compute wave number from freq & depth + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! Historical information: + ! This started as some equations (the "B" parameter equations + ! in subroutine "Ng" below) in a standalone Fortran + ! code written by Jim Kaihatu, December 2004. These were adapted by + ! Erick Rogers for a simple model based on governing equation + ! similar to SWAN, and installed in a full version of SWAN in + ! March 2005 with an informal report in May 2005. Kaihatu provided + ! a "patch" for the B equations May 2006. Mud code in SWAN v40.41A was + ! finalized June 2006, and v40.51 August 2007. The code was applied + ! to Cassino Beach ~Sep 2006. This work was presented at a conference + ! in Brazil Nov 2006, and later published in Rogers and Holland + ! (CSR 2009). The code was adapted for WW3 by Mark Orzech in Nov 2012 + ! (he had installed the D&L routines as BT8 in July 2011). + ! + ! Reference: Ng, C.O.,2000. Water waves over a muddy bed: + ! a two-layer Stokes’ boundary layer model. + ! Coastal Engineering 40(3),221–242. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SBT9(AC,H_WDEPTH,S,D,IX,IY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA | + !/ | M. Orzech NRL | + !/ | W. E. Rogers NRL | + !/ | FORTRAN 90 | + !/ | Last update : 21-Nov-2013 | + !/ +-----------------------------------+ + + !/ 28-Jul-2011 : Origination. ( version 4.01 ) + !/ 21-Nov-2013 : Preparing distribution version. ( version 4.11 ) + !/ + ! 1. Purpose : + ! + ! Compute dissipation by viscous fluid mud using Ng (2000) + ! (adapted from Erick Rogers code by Mark Orzech, NRL). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! H_WDEPTH Real I Mean water depth. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! CALC_ND + ! NG + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! Cg_mud calculation could be improved by using dsigma/dk instead + ! of n*C. The latter is a "naive" method and its accuracy has + ! not been confirmed. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NK,SIG,NSPEC,MAPWN + USE W3IDATMD, ONLY: MUDT, MUDV, MUDD, INFLAGS1 + USE CONSTANTS, ONLY: PI,GRAV,DWAT,NU_WATER + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: H_WDEPTH ! WATER DEPTH, DENOTED "H" IN NG (M) - REAL, INTENT(IN) :: AC(NSPEC) ! ACTION DENSITY - INTEGER, INTENT(IN) :: IX, IY - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: H_WDEPTH ! WATER DEPTH, DENOTED "H" IN NG (M) + REAL, INTENT(IN) :: AC(NSPEC) ! ACTION DENSITY + INTEGER, INTENT(IN) :: IX, IY + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - - ! LOCAL VARIABLES - REAL :: DMW(NK) - REAL :: ROOTDG - REAL :: SND - REAL :: SND2 - REAL :: WGD - REAL :: CWAVE - REAL :: KD_ROCK - REAL :: CG_MUD - REAL :: K_MUD - REAL :: NWAVE_MUD - REAL :: ND_MUD - REAL :: SMUDWD(NK) ! DISSIPATION DUE TO MUD - REAL :: CG_ROCK - REAL :: K_ROCK - REAL :: NWAVE_ROCK - REAL :: ND_ROCK - REAL :: KINVISM ! := THE KINEMATIC VISCOSITY OF THE MUD - REAL :: KINVISW ! := KINEMATIC VISCOSITY OF WATER - REAL :: RHOW ! := DENSITY OF WATER - REAL :: RHOM ! := DENSITY OF MUD - REAL :: DM ! := DEPTH OF MUD LAYER - REAL :: ZETA ! := THIS IS ZETA AS USED IN NG PG. 238. IT IS THE - ! RATIO OF STOKES' BOUNDARY LAYER THICKNESSES, - ! OR DELTA_M/DELTA_W - REAL :: GAMMA ! := THIS IS THE GAMMA USED IN NG PG. 238. THIS IS - ! DENSITY(WATER)/DENSITY(MUD) - REAL :: SBLTW ! := A FUNCTION OF VISCOSITY AND FREQ - REAL :: SBLTM ! := A FUNCTION OF VISCOSITY AND FREQ - REAL :: DTILDE ! := NORMALIZED MUD DEPTH = MUD DEPTH / DELTA_M, - ! DELTA IS THE SBLT= SQRT(2*VISC/SIGMA) - REAL :: ZTMP - REAL :: KDCUTOFF - REAL :: KD - - INTEGER :: IS - - LOGICAL :: INAN - -!/ ------------------------------------------------------------------- / -!/ + + ! LOCAL VARIABLES + REAL :: DMW(NK) + REAL :: ROOTDG + REAL :: SND + REAL :: SND2 + REAL :: WGD + REAL :: CWAVE + REAL :: KD_ROCK + REAL :: CG_MUD + REAL :: K_MUD + REAL :: NWAVE_MUD + REAL :: ND_MUD + REAL :: SMUDWD(NK) ! DISSIPATION DUE TO MUD + REAL :: CG_ROCK + REAL :: K_ROCK + REAL :: NWAVE_ROCK + REAL :: ND_ROCK + REAL :: KINVISM ! := THE KINEMATIC VISCOSITY OF THE MUD + REAL :: KINVISW ! := KINEMATIC VISCOSITY OF WATER + REAL :: RHOW ! := DENSITY OF WATER + REAL :: RHOM ! := DENSITY OF MUD + REAL :: DM ! := DEPTH OF MUD LAYER + REAL :: ZETA ! := THIS IS ZETA AS USED IN NG PG. 238. IT IS THE + ! RATIO OF STOKES' BOUNDARY LAYER THICKNESSES, + ! OR DELTA_M/DELTA_W + REAL :: GAMMA ! := THIS IS THE GAMMA USED IN NG PG. 238. THIS IS + ! DENSITY(WATER)/DENSITY(MUD) + REAL :: SBLTW ! := A FUNCTION OF VISCOSITY AND FREQ + REAL :: SBLTM ! := A FUNCTION OF VISCOSITY AND FREQ + REAL :: DTILDE ! := NORMALIZED MUD DEPTH = MUD DEPTH / DELTA_M, + ! DELTA IS THE SBLT= SQRT(2*VISC/SIGMA) + REAL :: ZTMP + REAL :: KDCUTOFF + REAL :: KD + + INTEGER :: IS + + LOGICAL :: INAN + + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SBT9') + CALL STRACE (IENT, 'W3SBT9') #endif -! -! 0. Initializations ------------------------------------------------ * -! - ! Ng (2000), Waves over soft muds. - ! Based on code for SWAN created by Erick Rogers. - ! Adapted for WW3 by Mark Orzech, Nov 2012. - - ! Initialize properties from mud fields if available - IF (INFLAGS1(-2))THEN - RHOM = MUDD(IX,IY) + ! + ! 0. Initializations ------------------------------------------------ * + ! + ! Ng (2000), Waves over soft muds. + ! Based on code for SWAN created by Erick Rogers. + ! Adapted for WW3 by Mark Orzech, Nov 2012. + + ! Initialize properties from mud fields if available + IF (INFLAGS1(-2))THEN + RHOM = MUDD(IX,IY) + ELSE + WRITE(NDSE,*)'RHOM NOT SET' + CALL EXTCDE ( 1 ) + ENDIF + IF (INFLAGS1(-1)) THEN + DM = MUDT(IX,IY) + ELSE + WRITE(NDSE,*)'DM NOT SET' + CALL EXTCDE ( 2 ) + ENDIF + IF (INFLAGS1(0)) THEN + KINVISM = MUDV(IX,IY) + ELSE + WRITE(NDSE,*)'KINVISM NOT SET' + CALL EXTCDE ( 3 ) + ENDIF + + ROOTDG = SQRT(H_WDEPTH/GRAV) + WGD = ROOTDG*GRAV + DO IS = 1, NK + ! SND is dimensionless frequency + SND = SIG(IS) * ROOTDG + IF (SND .GE. 2.5) THEN + ! ******* DEEP WATER ******* + K_ROCK = SIG(IS) * SIG(IS) / GRAV + CG_ROCK = 0.5 * GRAV / SIG(IS) + NWAVE_ROCK = 0.5 + ND_ROCK = 0. + ELSE IF (SND.LT.1.E-6) THEN + ! *** VERY SHALLOW WATER *** + K_ROCK = SND/H_WDEPTH + CG_ROCK = WGD + NWAVE_ROCK = 1. + ND_ROCK = 0. ELSE - WRITE(NDSE,*)'RHOM NOT SET' - CALL EXTCDE ( 1 ) - ENDIF - IF (INFLAGS1(-1)) THEN - DM = MUDT(IX,IY) - ELSE - WRITE(NDSE,*)'DM NOT SET' - CALL EXTCDE ( 2 ) + + SND2 = SND*SND + CWAVE = SQRT(GRAV*H_WDEPTH/(SND2+1./(1.+0.666*SND2 & + +0.445*SND2**2 -0.105*SND2**3+0.272*SND2**4))) + K_ROCK = SIG(IS)/CWAVE + + CALL CALC_ND(K_ROCK,H_WDEPTH,SND2,ND_ROCK) + + NWAVE_ROCK = 0.5*(1.0+2.0*K_ROCK*H_WDEPTH/SINH(2.0*K_ROCK*H_WDEPTH)) + CG_ROCK= NWAVE_ROCK*CWAVE + + SND2=0 + CWAVE=0 + ENDIF - IF (INFLAGS1(0)) THEN - KINVISM = MUDV(IX,IY) + + KDCUTOFF = 10.0 ! hardwired (same as w3sbt8md) + + ! now that kh is known, we can use a definition of "deep" that is + ! consistent with the definition used in sbot + K_MUD=0.0 + DMW(IS)=0.0 + KD_ROCK = K_ROCK * H_WDEPTH + ! KD_ROCK is used to determine whether we make the mud calculation + IF((KD_ROCK.LT.KDCUTOFF).AND.(DM.GT.1.0E-5))THEN + KINVISW=NU_WATER + RHOW=DWAT + ZETA=SQRT(KINVISM/KINVISW) + GAMMA=RHOW/RHOM + SBLTW=SQRT(2.0*KINVISW/SIG(IS)) + SBLTM=SQRT(2.0*KINVISM/SIG(IS)) + + DTILDE=DM/SBLTM + CALL NG(SIG(IS),H_WDEPTH,DTILDE,ZETA,SBLTM,GAMMA,K_ROCK,K_MUD, & + DMW(IS)) + + ELSE ! IF ( KD_ROCK .LT. KDCUTOFF ) THEN + K_MUD=K_ROCK + END IF ! IF ( KD_ROCK .LT. KDCUTOFF ) THEN + + ! calculate cg_mud, nwave_mud here + CWAVE=SIG(IS)/K_MUD + + ZTMP=2.0*K_MUD*H_WDEPTH + IF(ZTMP.LT.70)THEN + ZTMP=SINH(ZTMP) ELSE - WRITE(NDSE,*)'KINVISM NOT SET' - CALL EXTCDE ( 3 ) + ZTMP=1.0E+30 ENDIF - - ROOTDG = SQRT(H_WDEPTH/GRAV) - WGD = ROOTDG*GRAV - DO IS = 1, NK - ! SND is dimensionless frequency - SND = SIG(IS) * ROOTDG - IF (SND .GE. 2.5) THEN - ! ******* DEEP WATER ******* - K_ROCK = SIG(IS) * SIG(IS) / GRAV - CG_ROCK = 0.5 * GRAV / SIG(IS) - NWAVE_ROCK = 0.5 - ND_ROCK = 0. - ELSE IF (SND.LT.1.E-6) THEN - ! *** VERY SHALLOW WATER *** - K_ROCK = SND/H_WDEPTH - CG_ROCK = WGD - NWAVE_ROCK = 1. - ND_ROCK = 0. - ELSE - - SND2 = SND*SND - CWAVE = SQRT(GRAV*H_WDEPTH/(SND2+1./(1.+0.666*SND2 & - +0.445*SND2**2 -0.105*SND2**3+0.272*SND2**4))) - K_ROCK = SIG(IS)/CWAVE - - CALL CALC_ND(K_ROCK,H_WDEPTH,SND2,ND_ROCK) - - NWAVE_ROCK = 0.5*(1.0+2.0*K_ROCK*H_WDEPTH/SINH(2.0*K_ROCK*H_WDEPTH)) - CG_ROCK= NWAVE_ROCK*CWAVE - - SND2=0 - CWAVE=0 - - ENDIF - - KDCUTOFF = 10.0 ! hardwired (same as w3sbt8md) - - ! now that kh is known, we can use a definition of "deep" that is - ! consistent with the definition used in sbot - K_MUD=0.0 - DMW(IS)=0.0 - KD_ROCK = K_ROCK * H_WDEPTH - ! KD_ROCK is used to determine whether we make the mud calculation - IF((KD_ROCK.LT.KDCUTOFF).AND.(DM.GT.1.0E-5))THEN - KINVISW=NU_WATER - RHOW=DWAT - ZETA=SQRT(KINVISM/KINVISW) - GAMMA=RHOW/RHOM - SBLTW=SQRT(2.0*KINVISW/SIG(IS)) - SBLTM=SQRT(2.0*KINVISM/SIG(IS)) - - DTILDE=DM/SBLTM - CALL NG(SIG(IS),H_WDEPTH,DTILDE,ZETA,SBLTM,GAMMA,K_ROCK,K_MUD, & - DMW(IS)) - - ELSE ! IF ( KD_ROCK .LT. KDCUTOFF ) THEN - K_MUD=K_ROCK - END IF ! IF ( KD_ROCK .LT. KDCUTOFF ) THEN - - ! calculate cg_mud, nwave_mud here - CWAVE=SIG(IS)/K_MUD - - ZTMP=2.0*K_MUD*H_WDEPTH - IF(ZTMP.LT.70)THEN - ZTMP=SINH(ZTMP) - ELSE - ZTMP=1.0E+30 - ENDIF - NWAVE_MUD=0.5*(1.0+2.0*K_MUD*H_WDEPTH/ZTMP) - - CG_MUD=NWAVE_MUD*CWAVE - SND2 = SND*SND - - CALL CALC_ND(K_MUD,H_WDEPTH,SND2,ND_MUD) - - SND2=0 - CWAVE=0 - - ! If we wanted to include the effects of mud on the real part of the - ! wavnumber (as we do in SWAN), this is where we would do it. - ! Set output variables k_out, cg_out, nwave_out, nd_out, dmw. -!kinematics IF(MUD)THEN ! -!kinematics K_OUT(IS) =K_MUD -!kinematics CG_OUT(IS) =CG_MUD -!kinematics NWAVE_OUT(IS)=NWAVE_MUD -!kinematics ND_OUT(IS) =ND_MUD -!kinematics ELSE ! USE ROCKY WAVENUMBER,ETC. -!kinematics K_OUT(IS) =K_ROCK -!kinematics CG_OUT(IS) =CG_ROCK -!kinematics NWAVE_OUT(IS)=NWAVE_ROCK -!kinematics ND_OUT(IS) =ND_ROCK -!kinematics DMW(IS)=0.0 -!kinematics ENDIF - - KD = K_MUD * H_WDEPTH - IF ( KD .LT. KDCUTOFF ) THEN - ! note that "IS" here is for the 1d spectrum - SMUDWD(IS)=2.0*DMW(IS)*CG_MUD - END IF - -! NaN check: - INAN = .NOT. ( DMW(IS) .GE. -HUGE(DMW(IS)) .AND. DMW(IS) & - .LE. HUGE(DMW(IS)) ) - IF (INAN) THEN - WRITE(*,'(/1A/)') 'W3SBT9 ERROR -- DMW(IS) IS NAN' - WRITE(*,*)'W3SBT9: RHOM, DM, KINVISM = ',RHOM, DM, KINVISM - WRITE(*,*)'W3SBT9: IS,NK = ',IS,NK - WRITE(*,*)'W3SBT9: H_WDEPTH,KD,KDCUTOFF = ',H_WDEPTH,KD, KDCUTOFF - WRITE(*,*)'W3SBT9: K_MUD,CG_MUD,NWAVE_MUD = ',K_MUD,CG_MUD,NWAVE_MUD - CALL EXTCDE (1) - END IF - - END DO ! DO IS = 1, NK - -! *** store the results in the DIAGONAL arrays D and S *** - DO IS = 1,NSPEC - ! note that "IS" here is for the directional spectrum (2d) - D(IS) = -SMUDWD(MAPWN(IS)) - END DO - - S = D * AC - - RETURN - - END SUBROUTINE W3SBT9 - -!/ ------------------------------------------------------------------- / - SUBROUTINE NG(SIGMA,H_WDEPTH,DTILDE,ZETA,SBLTM,GAMMA,WK,WKDR,DISS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers and M. Orzech | -!/ | FORTRAN 90 | -!/ | Last update : 21-Nov-2013 | -!/ +-----------------------------------+ -! -!/ 28-Jul-2011 : Origination. ( version 4.01 ) -!/ 21-Nov-2013 : Preparing distribution version. ( version 4.11 ) -!/ -! 1. Purpose : -! -! Compute dissipation by viscous fluid mud using Ng (2000) -! (adapted from Erick Rogers code by Mark Orzech, NRL). -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! SIGMA Real I radian frequency (rad) -! H_WDEPTH Real I water depth -! DTILDE Real I normalized mud depth -! ZETA Real I zeta as used in Ng -! SBLTM Real I mud Stokes boundary layer thickness -! GAMMA Real I gamma as used in Ng -! WK Real I wavenumber w/out mud -! WKDR Real O wavenumber w/mud -! DISS Real O dissipation rate -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SBT9 Subr. W3SBT9MD Main routine (all freqs) -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! Calculations for the "B coefficients" came from a code by Jim Kaihatu -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! None. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / -!/ - - ! - IMPLICIT NONE + NWAVE_MUD=0.5*(1.0+2.0*K_MUD*H_WDEPTH/ZTMP) + + CG_MUD=NWAVE_MUD*CWAVE + SND2 = SND*SND + + CALL CALC_ND(K_MUD,H_WDEPTH,SND2,ND_MUD) + + SND2=0 + CWAVE=0 + + ! If we wanted to include the effects of mud on the real part of the + ! wavnumber (as we do in SWAN), this is where we would do it. + ! Set output variables k_out, cg_out, nwave_out, nd_out, dmw. + !kinematics IF(MUD)THEN ! + !kinematics K_OUT(IS) =K_MUD + !kinematics CG_OUT(IS) =CG_MUD + !kinematics NWAVE_OUT(IS)=NWAVE_MUD + !kinematics ND_OUT(IS) =ND_MUD + !kinematics ELSE ! USE ROCKY WAVENUMBER,ETC. + !kinematics K_OUT(IS) =K_ROCK + !kinematics CG_OUT(IS) =CG_ROCK + !kinematics NWAVE_OUT(IS)=NWAVE_ROCK + !kinematics ND_OUT(IS) =ND_ROCK + !kinematics DMW(IS)=0.0 + !kinematics ENDIF + + KD = K_MUD * H_WDEPTH + IF ( KD .LT. KDCUTOFF ) THEN + ! note that "IS" here is for the 1d spectrum + SMUDWD(IS)=2.0*DMW(IS)*CG_MUD + END IF + + ! NaN check: + INAN = .NOT. ( DMW(IS) .GE. -HUGE(DMW(IS)) .AND. DMW(IS) & + .LE. HUGE(DMW(IS)) ) + IF (INAN) THEN + WRITE(*,'(/1A/)') 'W3SBT9 ERROR -- DMW(IS) IS NAN' + WRITE(*,*)'W3SBT9: RHOM, DM, KINVISM = ',RHOM, DM, KINVISM + WRITE(*,*)'W3SBT9: IS,NK = ',IS,NK + WRITE(*,*)'W3SBT9: H_WDEPTH,KD,KDCUTOFF = ',H_WDEPTH,KD, KDCUTOFF + WRITE(*,*)'W3SBT9: K_MUD,CG_MUD,NWAVE_MUD = ',K_MUD,CG_MUD,NWAVE_MUD + CALL EXTCDE (1) + END IF + + END DO ! DO IS = 1, NK + + ! *** store the results in the DIAGONAL arrays D and S *** + DO IS = 1,NSPEC + ! note that "IS" here is for the directional spectrum (2d) + D(IS) = -SMUDWD(MAPWN(IS)) + END DO + + S = D * AC + + RETURN + + END SUBROUTINE W3SBT9 + + !/ ------------------------------------------------------------------- / + SUBROUTINE NG(SIGMA,H_WDEPTH,DTILDE,ZETA,SBLTM,GAMMA,WK,WKDR,DISS) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers and M. Orzech | + !/ | FORTRAN 90 | + !/ | Last update : 21-Nov-2013 | + !/ +-----------------------------------+ + ! + !/ 28-Jul-2011 : Origination. ( version 4.01 ) + !/ 21-Nov-2013 : Preparing distribution version. ( version 4.11 ) + !/ + ! 1. Purpose : + ! + ! Compute dissipation by viscous fluid mud using Ng (2000) + ! (adapted from Erick Rogers code by Mark Orzech, NRL). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! SIGMA Real I radian frequency (rad) + ! H_WDEPTH Real I water depth + ! DTILDE Real I normalized mud depth + ! ZETA Real I zeta as used in Ng + ! SBLTM Real I mud Stokes boundary layer thickness + ! GAMMA Real I gamma as used in Ng + ! WK Real I wavenumber w/out mud + ! WKDR Real O wavenumber w/mud + ! DISS Real O dissipation rate + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SBT9 Subr. W3SBT9MD Main routine (all freqs) + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! Calculations for the "B coefficients" came from a code by Jim Kaihatu + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! None. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + !/ + + ! + IMPLICIT NONE ! INPUT VARIABLES : - REAL, INTENT(IN) :: SIGMA ! radian frequency (rad) - REAL, INTENT(IN) :: H_WDEPTH! water depth, denoted "h" in Ng (m) - REAL, INTENT(IN) :: DTILDE ! normalized mud depth = mud depth / sbltm, - ! delta is the sblt= sqrt(2*visc/sigma) - REAL, INTENT(IN) :: ZETA ! this is zeta as used in Ng pg. 238. it is - ! the ratio of stokes' boundary layer - ! thicknesses, or sbltm/delta_w - REAL, INTENT(IN) :: GAMMA ! this is the gamma used in Ng pg. 238. - ! this is density(water)/density(mud) - REAL, INTENT(IN) :: SBLTM ! sbltm is what you get if you calculate - ! sblt using the viscosity of the mud, - ! sbltm=sqrt(2*visc_m/sigma) - ! .....also delta_m - REAL, INTENT(IN) :: WK ! unmuddy wavenumber + REAL, INTENT(IN) :: SIGMA ! radian frequency (rad) + REAL, INTENT(IN) :: H_WDEPTH! water depth, denoted "h" in Ng (m) + REAL, INTENT(IN) :: DTILDE ! normalized mud depth = mud depth / sbltm, + ! delta is the sblt= sqrt(2*visc/sigma) + REAL, INTENT(IN) :: ZETA ! this is zeta as used in Ng pg. 238. it is + ! the ratio of stokes' boundary layer + ! thicknesses, or sbltm/delta_w + REAL, INTENT(IN) :: GAMMA ! this is the gamma used in Ng pg. 238. + ! this is density(water)/density(mud) + REAL, INTENT(IN) :: SBLTM ! sbltm is what you get if you calculate + ! sblt using the viscosity of the mud, + ! sbltm=sqrt(2*visc_m/sigma) + ! .....also delta_m + REAL, INTENT(IN) :: WK ! unmuddy wavenumber ! OUTPUT VARIABLES : - REAL, INTENT(OUT) :: WKDR ! muddy wavenumber - REAL, INTENT(OUT) :: DISS ! dissipation rate + REAL, INTENT(OUT) :: WKDR ! muddy wavenumber + REAL, INTENT(OUT) :: DISS ! dissipation rate ! LOCAL VARIABLES : - REAL :: B1 ! an Ng coefficient - REAL :: B2 ! an Ng coefficient - REAL :: B3 ! an Ng coefficient - REAL :: BR ! an Ng coefficient - REAL :: BI ! an Ng coefficient - REAL :: BRP ! an Ng coefficient - REAL :: BIP ! an Ng coefficient - REAL :: DM ! MUD DEPTH, ADDED JUNE 2 2006 - - - DM=DTILDE*SBLTM ! DTILDE=DM/SBLTM - ! NOW CALCULATE Ng's B coefficients : see Ng pg 238 - B1=GAMMA*(-2.0*GAMMA**2+2.0*GAMMA-1.-ZETA**2)*SINH(DTILDE)* & + REAL :: B1 ! an Ng coefficient + REAL :: B2 ! an Ng coefficient + REAL :: B3 ! an Ng coefficient + REAL :: BR ! an Ng coefficient + REAL :: BI ! an Ng coefficient + REAL :: BRP ! an Ng coefficient + REAL :: BIP ! an Ng coefficient + REAL :: DM ! MUD DEPTH, ADDED JUNE 2 2006 + + + DM=DTILDE*SBLTM ! DTILDE=DM/SBLTM + ! NOW CALCULATE Ng's B coefficients : see Ng pg 238 + B1=GAMMA*(-2.0*GAMMA**2+2.0*GAMMA-1.-ZETA**2)*SINH(DTILDE)* & COSH(DTILDE)-GAMMA**2*ZETA*((COSH(DTILDE))**2+ & - (SINH(DTILDE))**2)-(GAMMA-1.)**2*ZETA*((COSH(DTILDE))**2 & + (SINH(DTILDE))**2)-(GAMMA-1.)**2*ZETA*((COSH(DTILDE))**2 & *(COS(DTILDE))**2+(SINH(DTILDE))**2*(SIN(DTILDE))**2)-2.0 & - *GAMMA*(1.-GAMMA)*(ZETA*COSH(DTILDE)+GAMMA*SINH(DTILDE)) & + *GAMMA*(1.-GAMMA)*(ZETA*COSH(DTILDE)+GAMMA*SINH(DTILDE)) & *COS(DTILDE) - B2=GAMMA*(-2.0*GAMMA**2+2.0*GAMMA-1.+ZETA**2)*SIN(DTILDE)* & + B2=GAMMA*(-2.0*GAMMA**2+2.0*GAMMA-1.+ZETA**2)*SIN(DTILDE)* & COS(DTILDE) -2.0*GAMMA*(1.-GAMMA)*(ZETA*SINH(DTILDE)+GAMMA & *COSH(DTILDE))*SIN(DTILDE) - B3=(ZETA*COSH(DTILDE)+GAMMA*SINH(DTILDE))**2*(COS(DTILDE))**2 & - +(ZETA*SINH(DTILDE)+GAMMA*COSH(DTILDE))**2*(SIN(DTILDE))**2 + B3=(ZETA*COSH(DTILDE)+GAMMA*SINH(DTILDE))**2*(COS(DTILDE))**2 & + +(ZETA*SINH(DTILDE)+GAMMA*COSH(DTILDE))**2*(SIN(DTILDE))**2 - BR=WK*SBLTM*(B1-B2)/(2.0*B3)+GAMMA*WK*DM + BR=WK*SBLTM*(B1-B2)/(2.0*B3)+GAMMA*WK*DM - BI=WK*SBLTM*(B1+B2)/(2.0*B3) - BRP=B1/B3 ! "B_R PRIME" - BIP=B2/B3 ! "B_I PRIME" + BI=WK*SBLTM*(B1+B2)/(2.0*B3) + BRP=B1/B3 ! "B_R PRIME" + BIP=B2/B3 ! "B_I PRIME" - ! now calculate dissipation rate and wavenumber - DISS=-SBLTM*(BRP+BIP)*WK**2/(SINH(2.0*WK*H_WDEPTH)+2.0*WK*H_WDEPTH) - WKDR=WK-BR*WK/(SINH(WK*H_WDEPTH)*COSH(WK*H_WDEPTH)+WK*H_WDEPTH) + ! now calculate dissipation rate and wavenumber + DISS=-SBLTM*(BRP+BIP)*WK**2/(SINH(2.0*WK*H_WDEPTH)+2.0*WK*H_WDEPTH) + WKDR=WK-BR*WK/(SINH(WK*H_WDEPTH)*COSH(WK*H_WDEPTH)+WK*H_WDEPTH) - RETURN + RETURN - END SUBROUTINE NG - -!/ ------------------------------------------------------------------- / - SUBROUTINE CALC_ND(KWAVE,H_WDEPTH,SND2,ND) -!/ ------------------------------------------------------------------- / + END SUBROUTINE NG - IMPLICIT NONE - REAL, INTENT(IN) :: KWAVE - REAL, INTENT(IN) :: H_WDEPTH - REAL, INTENT(IN) :: SND2 - REAL, INTENT(OUT) :: ND - REAL :: FAC1 ! LOCAL - REAL :: FAC2 ! LOCAL - REAL :: FAC3 ! LOCAL - REAL :: KND ! LOCAL - - KND = KWAVE*H_WDEPTH - FAC1 = 2.*KND/SINH(2.*KND) - FAC2 = SND2/KND - FAC3 = 2.*FAC2/(1.+FAC2*FAC2) - ND= FAC1*(0.5/H_WDEPTH - KWAVE/FAC3) - - END SUBROUTINE CALC_ND - -!/ ------------------------------------------------------------------- / -!/ - END MODULE W3SBT9MD - + !/ ------------------------------------------------------------------- / + SUBROUTINE CALC_ND(KWAVE,H_WDEPTH,SND2,ND) + !/ ------------------------------------------------------------------- / + + IMPLICIT NONE + REAL, INTENT(IN) :: KWAVE + REAL, INTENT(IN) :: H_WDEPTH + REAL, INTENT(IN) :: SND2 + REAL, INTENT(OUT) :: ND + REAL :: FAC1 ! LOCAL + REAL :: FAC2 ! LOCAL + REAL :: FAC3 ! LOCAL + REAL :: KND ! LOCAL + + KND = KWAVE*H_WDEPTH + FAC1 = 2.*KND/SINH(2.*KND) + FAC2 = SND2/KND + FAC3 = 2.*FAC2/(1.+FAC2*FAC2) + ND= FAC1*(0.5/H_WDEPTH - KWAVE/FAC3) + + END SUBROUTINE CALC_ND + + !/ ------------------------------------------------------------------- / + !/ +END MODULE W3SBT9MD diff --git a/model/src/w3sdb1md.F90 b/model/src/w3sdb1md.F90 index 1ad971fc4..af3e65c7a 100644 --- a/model/src/w3sdb1md.F90 +++ b/model/src/w3sdb1md.F90 @@ -1,349 +1,343 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SDB1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | J. H. Alves | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 25-Apr-2007 : Origination of module. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Dummy slot for bottom friction source term. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SDB1 Subr. Public Battjes and Janssen depth-induced -! breaking. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SDB1 (IX, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, LBREAK, S, D ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | FORTRAN 90 | -!/ | J. H. Alves | -!/ | H. L. Tolman | -!/ ! A. Roland | -!/ | Last update : 08-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 25-Apr-2007 : Origination of module. ( version 3.11 ) -!/ 08-Jun-2018 : Add DEBUGDB1. ( version 6.04 ) -!/ 03-Apr-2019 : Rewrite in terms of energy density (A. Roland,version 6.07) -!/ 03-Apr-2019 : Add Thornton & Guza, 1983 (A. Roland,version 6.07) -!/ -! 1. Purpose : -! -! Compute depth-induced breaking using Battjes and Janssen bore -! model approach -! -! 2. Method : Battjes & Janssen (1978), -! -! Sbr = Dtot/Etot*WA = D * WA -! Dtot = 0.25*alpha*Qb*fm*Hmax² -! fm = sigma/2Pi -! BB = Hrms²/Hmax² = 8Etot/Hmax² -! D = Dtot/Etot = BJALFA * sigma / pi * Qb/BB = 2 * BJALFA * fm * Qb/BB -! -! AR: only valid for Hrms .le. Hm, Qb .le. 1, otherwise, in the degenrative regime it is -! due to Qb > 1 that all wave are broken and Hrms .le. Hmax -! MLIM can be used to enforce this conditions, source term will smoothly converge to this limit. -! -! Where CDB = SDBC1 = BJALFA (defaults to BJALFA = 1) -! modified via ww3_grid namelist parameter BJALFA -! HM = GAMMA * DEP -! GAMMA = SDBC2 defaults to 0.73 (mean Battjes/Janssen value) -! modified via ww3_grid namelist parameter BJGAM -! -! And QB is estimated by iterations using the nonlinear expression -! -! 1 - QB = HRMS**2 -! ------ ------- -! ln QB HM**2 -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! EMEAN Real I Mean wave energy. -! FMEAN Real I Mean wave frequency. -! WNMEAN Real I Mean wave number. -! DEPTH Real I Mean water depth. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Subroutine tracing (!/S switch). -! -! 5. Called by : -! -! W3SRCE Source term integration. -! W3EXPO Point output post-processor. -! GXEXPO GrADS point output post-processor. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Note that the Miche criterion con influence wave growth. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SDBC1, SDBC2, FDONLY, FSSOURCE, DDEN - USE W3ODATMD, ONLY: NDST - USE W3GDATMD, ONLY: SIG - USE W3ODATMD, only : IAPROC +MODULE W3SDB1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | J. H. Alves | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 25-Apr-2007 : Origination of module. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Dummy slot for bottom friction source term. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SDB1 Subr. Public Battjes and Janssen depth-induced + ! breaking. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SDB1 (IX, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, LBREAK, S, D ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | FORTRAN 90 | + !/ | J. H. Alves | + !/ | H. L. Tolman | + !/ ! A. Roland | + !/ | Last update : 08-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 25-Apr-2007 : Origination of module. ( version 3.11 ) + !/ 08-Jun-2018 : Add DEBUGDB1. ( version 6.04 ) + !/ 03-Apr-2019 : Rewrite in terms of energy density (A. Roland,version 6.07) + !/ 03-Apr-2019 : Add Thornton & Guza, 1983 (A. Roland,version 6.07) + !/ + ! 1. Purpose : + ! + ! Compute depth-induced breaking using Battjes and Janssen bore + ! model approach + ! + ! 2. Method : Battjes & Janssen (1978), + ! + ! Sbr = Dtot/Etot*WA = D * WA + ! Dtot = 0.25*alpha*Qb*fm*Hmax² + ! fm = sigma/2Pi + ! BB = Hrms²/Hmax² = 8Etot/Hmax² + ! D = Dtot/Etot = BJALFA * sigma / pi * Qb/BB = 2 * BJALFA * fm * Qb/BB + ! + ! AR: only valid for Hrms .le. Hm, Qb .le. 1, otherwise, in the degenrative regime it is + ! due to Qb > 1 that all wave are broken and Hrms .le. Hmax + ! MLIM can be used to enforce this conditions, source term will smoothly converge to this limit. + ! + ! Where CDB = SDBC1 = BJALFA (defaults to BJALFA = 1) + ! modified via ww3_grid namelist parameter BJALFA + ! HM = GAMMA * DEP + ! GAMMA = SDBC2 defaults to 0.73 (mean Battjes/Janssen value) + ! modified via ww3_grid namelist parameter BJGAM + ! + ! And QB is estimated by iterations using the nonlinear expression + ! + ! 1 - QB = HRMS**2 + ! ------ ------- + ! ln QB HM**2 + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! EMEAN Real I Mean wave energy. + ! FMEAN Real I Mean wave frequency. + ! WNMEAN Real I Mean wave number. + ! DEPTH Real I Mean water depth. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Subroutine tracing (!/S switch). + ! + ! 5. Called by : + ! + ! W3SRCE Source term integration. + ! W3EXPO Point output post-processor. + ! GXEXPO GrADS point output post-processor. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Note that the Miche criterion con influence wave growth. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SDBC1, SDBC2, FDONLY, FSSOURCE, DDEN + USE W3ODATMD, ONLY: NDST + USE W3GDATMD, ONLY: SIG + USE W3ODATMD, only : IAPROC #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IX ! Local grid number - REAL, INTENT(IN) :: A(NSPEC) - REAL, INTENT(INOUT) :: EMEAN, FMEAN, WNMEAN, DEPTH - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) - REAL, INTENT(IN) :: CG(NK) - LOGICAL, INTENT(OUT) :: LBREAK - INTEGER :: ITH, IK, IWB -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IX ! Local grid number + REAL, INTENT(IN) :: A(NSPEC) + REAL, INTENT(INOUT) :: EMEAN, FMEAN, WNMEAN, DEPTH + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + REAL, INTENT(IN) :: CG(NK) + LOGICAL, INTENT(OUT) :: LBREAK + INTEGER :: ITH, IK, IWB + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif + REAL*8 :: HM, BB, ARG, Q0, QB, B, CBJ, HRMS, EB(NK) + REAL*8 :: AUX, CBJ2, RATIO, S0, S1, THR, BR1, BR2, FAK + REAL :: ETOT, FMEAN2 #ifdef W3_T0 - INTEGER :: IK, ITH + REAL :: DOUT(NK,NTH) #endif - REAL*8 :: HM, BB, ARG, Q0, QB, B, CBJ, HRMS, EB(NK) - REAL*8 :: AUX, CBJ2, RATIO, S0, S1, THR, BR1, BR2, FAK - REAL :: ETOT, FMEAN2 -#ifdef W3_T0 - REAL :: DOUT(NK,NTH) -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SDB1') + CALL STRACE (IENT, 'W3SDB1') #endif -! -! 0. Initialzations ------------------------------------------------- / -! Never touch this 4 lines below ... otherwise my exceptionhandling will not work. + ! + ! 0. Initialzations ------------------------------------------------- / + ! Never touch this 4 lines below ... otherwise my exceptionhandling will not work. - THR = DBLE(1.E-15) - IF (SUM(A) .LT. THR) RETURN + THR = DBLE(1.E-15) + IF (SUM(A) .LT. THR) RETURN - S = 0. - D = 0. - IWB = 1 -! + S = 0. + D = 0. + IWB = 1 + ! #ifdef W3_T - WRITE (NDST,9000) SDBC1, SDBC2, FDONLY + WRITE (NDST,9000) SDBC1, SDBC2, FDONLY #endif -! -! 1. Integral quantities. AR: make sure mean quantities are computed, need to move upward -! - ETOT = 0. - FMEAN2 = 0. - DO IK=1, NK - EB(IK) = 0. - DO ITH=1, NTH - EB(IK) = EB(IK) + A(ITH+(IK-1)*NTH) - END DO + ! + ! 1. Integral quantities. AR: make sure mean quantities are computed, need to move upward + ! + ETOT = 0. + FMEAN2 = 0. + DO IK=1, NK + EB(IK) = 0. + DO ITH=1, NTH + EB(IK) = EB(IK) + A(ITH+(IK-1)*NTH) END DO - DO IK=1, NK - EB(IK) = EB(IK) * DDEN(IK) / CG(IK) - ETOT = ETOT + EB(IK) + END DO + DO IK=1, NK + EB(IK) = EB(IK) * DDEN(IK) / CG(IK) + ETOT = ETOT + EB(IK) + END DO + DO IK=1, NK + FMEAN2 = FMEAN2 + EB(IK) * SIG(IK) + END DO + FMEAN2 = FMEAN2 / ETOT * TPIINV + ! + ! 2do compute wlmean + ! + ! 1.a. Maximum wave height + ! 1.a.1. Simple limit + ! + IF ( FDONLY ) THEN + HM = DBLE(SDBC2) * DBLE(DEPTH) + ELSE + ! + ! 1.a.2. Miche style criterion + ! + HM = DBLE(SDBC2) / DBLE(WNMEAN) * TANH ( DBLE(WNMEAN) * MAX(DEPTH,0.) ) + END IF + ! + !AR: Add Dingemans ... + ! 1.b. Hrms and ratio Hrms / Hmax + ! + HRMS = DSQRT (8.d0 * DBLE(EMEAN)) + IF ( HM .GT. THR) THEN + BB = HRMS * HRMS / ( HM * HM ) + B = DSQRT(BB) + ELSE + BB = 0.d0 + B = 0.d0 + END IF + ! + ! 2. Fraction of breaking waves -------------------------------------- / + ! 2.a. First guess breaking fraction + ! + IF ( B .LE. 0.5d0 ) THEN + Q0 = 0.d0 + ELSE IF ( B .LE. 1.d0 ) THEN + Q0 = ( 2.d0 * B - 1.d0 ) ** 2 + END IF + ! + ! 2.b. Iterate to obtain actual breaking fraction + ! + IF ( B .LE. 0.2d0 ) THEN + QB = 0.d0 + ELSE IF ( B .LT. 1.d0 ) THEN + ARG = EXP (( Q0 - 1.d0 ) / BB ) + QB = Q0 - BB * ( Q0 - ARG ) / ( BB - ARG ) + DO IS=1, 3 + QB = EXP((QB-1.)/BB) END DO - DO IK=1, NK - FMEAN2 = FMEAN2 + EB(IK) * SIG(IK) - END DO - FMEAN2 = FMEAN2 / ETOT * TPIINV -! -! 2do compute wlmean -! -! 1.a. Maximum wave height -! 1.a.1. Simple limit -! - IF ( FDONLY ) THEN - HM = DBLE(SDBC2) * DBLE(DEPTH) - ELSE -! -! 1.a.2. Miche style criterion -! - HM = DBLE(SDBC2) / DBLE(WNMEAN) * TANH ( DBLE(WNMEAN) * MAX(DEPTH,0.) ) - END IF -! -!AR: Add Dingemans ... -! 1.b. Hrms and ratio Hrms / Hmax -! - HRMS = DSQRT (8.d0 * DBLE(EMEAN)) - IF ( HM .GT. THR) THEN - BB = HRMS * HRMS / ( HM * HM ) - B = DSQRT(BB) - ELSE - BB = 0.d0 - B = 0.d0 - END IF -! -! 2. Fraction of breaking waves -------------------------------------- / -! 2.a. First guess breaking fraction -! - IF ( B .LE. 0.5d0 ) THEN - Q0 = 0.d0 - ELSE IF ( B .LE. 1.d0 ) THEN - Q0 = ( 2.d0 * B - 1.d0 ) ** 2 - END IF -! -! 2.b. Iterate to obtain actual breaking fraction -! - IF ( B .LE. 0.2d0 ) THEN - QB = 0.d0 - ELSE IF ( B .LT. 1.d0 ) THEN - ARG = EXP (( Q0 - 1.d0 ) / BB ) - QB = Q0 - BB * ( Q0 - ARG ) / ( BB - ARG ) - DO IS=1, 3 - QB = EXP((QB-1.)/BB) - END DO - ELSE - QB = 1.0 - THR - END IF -! -! 3. Estimate the breaking coefficient ------------------------------- / -! - CBJ = 0 - IF (IWB == 1) THEN - IF ( ( BB .GT. THR) .AND. ( ABS ( BB - QB ) .GT. THR) ) THEN - IF ( BB .LT. 1.0) THEN - CBJ = 2 * DBLE(SDBC1) * QB * DBLE(FMEAN) / BB - ELSE - CBJ = 2 * DBLE(SDBC1) * DBLE(FMEAN) * BB ! AR: degenerative regime, all waves must be .le. Hmax, we just smoothly let the excessive energy vanish by * BB. - END IF - ELSE - CBJ = 0.d0 - ENDIF - D = - CBJ - S = D * A - ELSE IF (IWB == 2) THEN - IF (ETOT .GT. THR) THEN - HRMS = SQRT(8*EMEAN) - FAK = (1+4./SQRT(PI)*(B*BB+1.5*B)*exp(-BB)-ERF(B)) - CBJ = -SDBC1*SQRT(PI)/16.*FMEAN*HRMS**3/DEPTH/ETOT + ELSE + QB = 1.0 - THR + END IF + ! + ! 3. Estimate the breaking coefficient ------------------------------- / + ! + CBJ = 0 + IF (IWB == 1) THEN + IF ( ( BB .GT. THR) .AND. ( ABS ( BB - QB ) .GT. THR) ) THEN + IF ( BB .LT. 1.0) THEN + CBJ = 2 * DBLE(SDBC1) * QB * DBLE(FMEAN) / BB ELSE - CBJ = 0. - ENDIF - D = - CBJ - S = D * A + CBJ = 2 * DBLE(SDBC1) * DBLE(FMEAN) * BB ! AR: degenerative regime, all waves must be .le. Hmax, we just smoothly let the excessive energy vanish by * BB. + END IF + ELSE + CBJ = 0.d0 ENDIF - - IF (CBJ .GT. 0.) THEN - LBREAK = .TRUE. + D = - CBJ + S = D * A + ELSE IF (IWB == 2) THEN + IF (ETOT .GT. THR) THEN + HRMS = SQRT(8*EMEAN) + FAK = (1+4./SQRT(PI)*(B*BB+1.5*B)*exp(-BB)-ERF(B)) + CBJ = -SDBC1*SQRT(PI)/16.*FMEAN*HRMS**3/DEPTH/ETOT ELSE - LBREAK = .FALSE. + CBJ = 0. ENDIF + D = - CBJ + S = D * A + ENDIF + + IF (CBJ .GT. 0.) THEN + LBREAK = .TRUE. + ELSE + LBREAK = .FALSE. + ENDIF #ifdef W3_DEBUGRUN - IF (IX == DEBUG_NODE) THEN - WRITE(*,'(A200)') 'IX, DEPTH, CBJ, BB, QB, SDBC1, SDBC2, FMEAN, FMEAN2, HS' - WRITE(*,'(I10,20F20.10)') IX, DEPTH, CBJ, BB, QB, SDBC1, SDBC2, FMEAN, FMEAN2, 4*SQRT(ETOT) - ENDIF + IF (IX == DEBUG_NODE) THEN + WRITE(*,'(A200)') 'IX, DEPTH, CBJ, BB, QB, SDBC1, SDBC2, FMEAN, FMEAN2, HS' + WRITE(*,'(I10,20F20.10)') IX, DEPTH, CBJ, BB, QB, SDBC1, SDBC2, FMEAN, FMEAN2, 4*SQRT(ETOT) + ENDIF #endif -! -! ... Test output of arrays -! + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO -#endif -! -#ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG, ' ', 1., & - 0.0, 0.001, 'Diag Sdb', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG, ' ', 1., & + 0.0, 0.001, 'Diag Sdb', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sdb') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sdb') #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SDB1 : PARAMETERS :',2F7.3,L4) +9000 FORMAT (' TEST W3SDB1 : PARAMETERS :',2F7.3,L4) #endif -!/ -!/ End of W3SDB1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SDB1 -!/ -!/ -!/ End of module W3SDB1MD -------------------------------------------- / -!/ - END MODULE W3SDB1MD + !/ + !/ End of W3SDB1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SDB1 + !/ + !/ + !/ End of module W3SDB1MD -------------------------------------------- / + !/ +END MODULE W3SDB1MD diff --git a/model/src/w3servmd.F90 b/model/src/w3servmd.F90 index 170ada657..4119356a4 100644 --- a/model/src/w3servmd.F90 +++ b/model/src/w3servmd.F90 @@ -1,2051 +1,2051 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SERVMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 15-Jan-2021 | -!/ +-----------------------------------+ -!/ -!/ For update log see individual subroutines. -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 18-Aug-2016 : Add dist_sphere: angular distance ( version 5.11 ) -!/ 01-Mar-2016 : Added W3THRTN and W3XYRTN for post ( version 6.02 ) -!/ processing rotated grid data -!/ 15-Jan-2021 : Added UV_TO_MAG_DIR routine ( version 7.12 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! In this module all WAVEWATCH specific service routines have -! been gathered. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NDSTRC Int. Private Data set number for output of STRACE -! (set in ITRACE). -! NTRACE Int. Private Maximum number of trace prints in -! strace (set in ITRACE). -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ITRACE Subr. Public (Re-) Initialization for STRACE. -! STRACE Subr. Public Enable subroutine tracing, usually -! activated with the !/S switch. -! NEXTLN Subr. Public Get to next line in input command file. -! W3S2XY Subr. Public Grid conversion routine. -! EJ5P R.F. Public Five parameter JONSWAP spectrum. -! WWDATE Subr. Public Get system date. -! WWTIME Subr. Public Get system time. -! EXTCDE Subr. Public Abort program with exit code. -! Four subs for rotated grid are appended to this module. As they -! are shared with SMC grid, they are not quoted by option /RTD but -! are available for general use. JGLi12Jun2012 -! W3SPECTN turns wave spectrum anti-clockwise by AnglD -! W3ACTURN turns wave action(k,nth) anti-clockwise by AnglD. -! W3LLTOEQ convert standard into rotated lat/lon, plus AnglD -! W3EQTOLL revers of the LLTOEQ, but AnglD unchanged. -! W3THTRN turns direction value anti-clockwise by AnglD -! W3XYTRN turns 2D vectors anti-clockwise by AnglD -! -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! None. -! -! 5. Remarks : -! -! 6. Switches -! -! !/S Enable subroutine tracing using STRACE in this module. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -! - INTEGER, PRIVATE :: NDSTRC = 6, NTRACE = 0 -! - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE ITRACE (NDS, NMAX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 23-Nov-1999 : First version of routine. ( version 2.00 ) -!/ -! 1. Purpose : -! -! (Re-) initialization for module version of STRACE. -! -! 3. Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Data set number ofr trace file. -! NMAX Int. I Maximum number of traces per routine. -! ---------------------------------------------------------------- -! -! Private to module : -! ---------------------------------------------------------------- -! NDSTRC Int. Output unit number for trace. ( from NDS ) -! NTRACE Int. Maximum number of trace prints. ( from NMAX ) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Any program, multiple calls allowed. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NMAX -!/ -!/ ------------------------------------------------------------------- / -!/ - NTRACE = MAX ( 0 , NMAX ) - NDSTRC = NDS -! - RETURN -!/ -!/ End of ITRACE ----------------------------------------------------- / -!/ - END SUBROUTINE ITRACE -!/ ------------------------------------------------------------------- / - SUBROUTINE STRACE (IENT, SNAME) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-Jan-2000 | -!/ +-----------------------------------+ -!/ Original version by N. Booij, DUT -!/ -!/ 30-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 25-Jan-2000 : Force flushing of uniit. ( version 2.00 ) -!/ This was taken out around version 3.01. -!/ -! 1. Purpose : -! -! Keep track of entered subroutines. -! -! 3. Parameter list -! ---------------------------------------------------------------- -! IENT Int. I/O Number of times that STRACE has been -! called by the routine. -! SNAME Char. I Name of the subroutine (max. 6 characters) -! ---------------------------------------------------------------- -! -! Private to module : -! ---------------------------------------------------------------- -! NDSTRC Int. Output unit number for trace. -! NTRACE Int. Maximum number of trace prints. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Any program, after private variables have been set by NTRACE. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(INOUT) :: IENT - CHARACTER, INTENT(IN) :: SNAME*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ - IF (NTRACE.EQ.0 .OR. IENT.GE.NTRACE) RETURN -! - IENT = IENT + 1 - IF (IENT.EQ.1) THEN - WRITE (NDSTRC,10) SNAME - ELSE - WRITE (NDSTRC,11) SNAME, IENT - END IF -! - RETURN -! -! Formats -! - 10 FORMAT (' ---> TRACE SUBR : ',A6) - 11 FORMAT (' ---> TRACE SUBR : ',A6,' ENTRY: ',I6) -!/ -!/ End of STRACE ----------------------------------------------------- / -!/ - END SUBROUTINE STRACE -!/ ------------------------------------------------------------------- / - SUBROUTINE NEXTLN ( CHCKC , NDSI , NDSE ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 18-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 10-Dec-2014 : Skip blank lines and leading blanks ( version 5.04 ) -!/ -! 1. Purpose : -! -! Sets file pointer to next active line of input file, by skipping -! blank lines and lines starting with the character CHCKC. Leading -! white space is allowed before the character CHCKC. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! CHCKC C*1 I Check character for defining comment line. -! NDSI Int. I Input dataset number. -! NDSE Int. I Error output dataset number. -! (No output if NDSE < 0). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE ( !/S switch ) -! -! 5. Called by : -! -! Any routine. -! -! 6. Error messages : -! -! - On EOF or error in input file. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSI, NDSE - CHARACTER, INTENT(IN) :: CHCKC*1 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ +MODULE W3SERVMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 15-Jan-2021 | + !/ +-----------------------------------+ + !/ + !/ For update log see individual subroutines. + !/ 12-Jun-2012 : Add /RTD option or rotated grid option. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 18-Aug-2016 : Add dist_sphere: angular distance ( version 5.11 ) + !/ 01-Mar-2016 : Added W3THRTN and W3XYRTN for post ( version 6.02 ) + !/ processing rotated grid data + !/ 15-Jan-2021 : Added UV_TO_MAG_DIR routine ( version 7.12 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! In this module all WAVEWATCH specific service routines have + ! been gathered. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NDSTRC Int. Private Data set number for output of STRACE + ! (set in ITRACE). + ! NTRACE Int. Private Maximum number of trace prints in + ! strace (set in ITRACE). + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ITRACE Subr. Public (Re-) Initialization for STRACE. + ! STRACE Subr. Public Enable subroutine tracing, usually + ! activated with the !/S switch. + ! NEXTLN Subr. Public Get to next line in input command file. + ! W3S2XY Subr. Public Grid conversion routine. + ! EJ5P R.F. Public Five parameter JONSWAP spectrum. + ! WWDATE Subr. Public Get system date. + ! WWTIME Subr. Public Get system time. + ! EXTCDE Subr. Public Abort program with exit code. + ! Four subs for rotated grid are appended to this module. As they + ! are shared with SMC grid, they are not quoted by option /RTD but + ! are available for general use. JGLi12Jun2012 + ! W3SPECTN turns wave spectrum anti-clockwise by AnglD + ! W3ACTURN turns wave action(k,nth) anti-clockwise by AnglD. + ! W3LLTOEQ convert standard into rotated lat/lon, plus AnglD + ! W3EQTOLL revers of the LLTOEQ, but AnglD unchanged. + ! W3THTRN turns direction value anti-clockwise by AnglD + ! W3XYTRN turns 2D vectors anti-clockwise by AnglD + ! + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! None. + ! + ! 5. Remarks : + ! + ! 6. Switches + ! + ! !/S Enable subroutine tracing using STRACE in this module. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + ! + INTEGER, PRIVATE :: NDSTRC = 6, NTRACE = 0 + ! +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE ITRACE (NDS, NMAX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 23-Nov-1999 : First version of routine. ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! (Re-) initialization for module version of STRACE. + ! + ! 3. Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Data set number ofr trace file. + ! NMAX Int. I Maximum number of traces per routine. + ! ---------------------------------------------------------------- + ! + ! Private to module : + ! ---------------------------------------------------------------- + ! NDSTRC Int. Output unit number for trace. ( from NDS ) + ! NTRACE Int. Maximum number of trace prints. ( from NMAX ) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Any program, multiple calls allowed. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NMAX + !/ + !/ ------------------------------------------------------------------- / + !/ + NTRACE = MAX ( 0 , NMAX ) + NDSTRC = NDS + ! + RETURN + !/ + !/ End of ITRACE ----------------------------------------------------- / + !/ + END SUBROUTINE ITRACE + !/ ------------------------------------------------------------------- / + SUBROUTINE STRACE (IENT, SNAME) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-Jan-2000 | + !/ +-----------------------------------+ + !/ Original version by N. Booij, DUT + !/ + !/ 30-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 25-Jan-2000 : Force flushing of uniit. ( version 2.00 ) + !/ This was taken out around version 3.01. + !/ + ! 1. Purpose : + ! + ! Keep track of entered subroutines. + ! + ! 3. Parameter list + ! ---------------------------------------------------------------- + ! IENT Int. I/O Number of times that STRACE has been + ! called by the routine. + ! SNAME Char. I Name of the subroutine (max. 6 characters) + ! ---------------------------------------------------------------- + ! + ! Private to module : + ! ---------------------------------------------------------------- + ! NDSTRC Int. Output unit number for trace. + ! NTRACE Int. Maximum number of trace prints. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Any program, after private variables have been set by NTRACE. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(INOUT) :: IENT + CHARACTER, INTENT(IN) :: SNAME*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ + IF (NTRACE.EQ.0 .OR. IENT.GE.NTRACE) RETURN + ! + IENT = IENT + 1 + IF (IENT.EQ.1) THEN + WRITE (NDSTRC,10) SNAME + ELSE + WRITE (NDSTRC,11) SNAME, IENT + END IF + ! + RETURN + ! + ! Formats + ! +10 FORMAT (' ---> TRACE SUBR : ',A6) +11 FORMAT (' ---> TRACE SUBR : ',A6,' ENTRY: ',I6) + !/ + !/ End of STRACE ----------------------------------------------------- / + !/ + END SUBROUTINE STRACE + !/ ------------------------------------------------------------------- / + SUBROUTINE NEXTLN ( CHCKC , NDSI , NDSE ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 18-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 10-Dec-2014 : Skip blank lines and leading blanks ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Sets file pointer to next active line of input file, by skipping + ! blank lines and lines starting with the character CHCKC. Leading + ! white space is allowed before the character CHCKC. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! CHCKC C*1 I Check character for defining comment line. + ! NDSI Int. I Input dataset number. + ! NDSE Int. I Error output dataset number. + ! (No output if NDSE < 0). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE ( !/S switch ) + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 6. Error messages : + ! + ! - On EOF or error in input file. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSI, NDSE + CHARACTER, INTENT(IN) :: CHCKC*1 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IERR - CHARACTER(128) :: MSG - CHARACTER(256) :: LINE, TEST -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: IERR + CHARACTER(128) :: MSG + CHARACTER(256) :: LINE, TEST + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'NEXTLN') + CALL STRACE (IENT, 'NEXTLN') #endif -! - 100 CONTINUE - ! read line - READ ( NDSI, 900, END=800, ERR=801, IOSTAT=IERR, IOMSG=MSG ) LINE - ! leading blanks removed and placed on the right - TEST = ADJUSTL ( LINE ) - IF ( TEST(1:1).EQ.CHCKC .OR. LEN_TRIM(TEST).EQ.0 ) THEN - ! if comment or blank line, then skip - GOTO 100 - ELSE - ! otherwise, backup to beginning of line - BACKSPACE ( NDSI, ERR=802, IOSTAT=IERR, IOMSG=MSG ) - ENDIF - RETURN -! - 800 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,910) - CALL EXTCDE ( 1 ) -! - 801 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,911) IERR, TRIM(MSG) - CALL EXTCDE ( 2 ) -! - 802 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,912) IERR, TRIM(MSG) - CALL EXTCDE ( 3 ) -! -! Formats -! - 900 FORMAT (A) - 910 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & - ' PREMATURE END OF INPUT FILE'/) - 911 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & - ' ERROR IN READING FROM FILE'/ & - ' IOSTAT =',I5,/ & - ' IOMSG = ',A/) - 912 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & - ' ERROR ON BACKSPACE'/ & - ' IOSTAT =',I5,/ & - ' IOMSG = ',A/) -!/ -!/ End of NEXTLN ----------------------------------------------------- / -!/ - END SUBROUTINE NEXTLN -!/ ------------------------------------------------------------------- / - SUBROUTINE W3S2XY ( NSEA, MSEA, MX, MY, S, MAPSF, XY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NMC | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 11-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Convert a data array on the storage grid to a data array on the -! full spatial grid. Land and ice points in the full grid are -! not touched. Output array of conventional type XY(IX,IY). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NSEA Int. I Number of sea points. -! MSEA, MX, MY -! Int. I Array dimensions. -! S R.A. I Data on storage grid. -! MAPSF I.A. I Storage map for IX and IY, resp. -! XY R.A. O Data on XY grid. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Any WAVEWATCH III routine. -! -! 9. Switches : -! -! None. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MSEA, NSEA, MX, MY, MAPSF(MSEA,2) - REAL, INTENT(IN) :: S(MSEA) - REAL, INTENT(OUT) :: XY(MX,MY) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISEA, IX, IY -!/ -!/ ------------------------------------------------------------------- / -!/ + ! +100 CONTINUE + ! read line + READ ( NDSI, 900, END=800, ERR=801, IOSTAT=IERR, IOMSG=MSG ) LINE + ! leading blanks removed and placed on the right + TEST = ADJUSTL ( LINE ) + IF ( TEST(1:1).EQ.CHCKC .OR. LEN_TRIM(TEST).EQ.0 ) THEN + ! if comment or blank line, then skip + GOTO 100 + ELSE + ! otherwise, backup to beginning of line + BACKSPACE ( NDSI, ERR=802, IOSTAT=IERR, IOMSG=MSG ) + ENDIF + RETURN + ! +800 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,910) + CALL EXTCDE ( 1 ) + ! +801 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,911) IERR, TRIM(MSG) + CALL EXTCDE ( 2 ) + ! +802 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,912) IERR, TRIM(MSG) + CALL EXTCDE ( 3 ) + ! + ! Formats + ! +900 FORMAT (A) +910 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & + ' PREMATURE END OF INPUT FILE'/) +911 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & + ' ERROR IN READING FROM FILE'/ & + ' IOSTAT =',I5,/ & + ' IOMSG = ',A/) +912 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & + ' ERROR ON BACKSPACE'/ & + ' IOSTAT =',I5,/ & + ' IOMSG = ',A/) + !/ + !/ End of NEXTLN ----------------------------------------------------- / + !/ + END SUBROUTINE NEXTLN + !/ ------------------------------------------------------------------- / + SUBROUTINE W3S2XY ( NSEA, MSEA, MX, MY, S, MAPSF, XY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NMC | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 11-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Convert a data array on the storage grid to a data array on the + ! full spatial grid. Land and ice points in the full grid are + ! not touched. Output array of conventional type XY(IX,IY). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NSEA Int. I Number of sea points. + ! MSEA, MX, MY + ! Int. I Array dimensions. + ! S R.A. I Data on storage grid. + ! MAPSF I.A. I Storage map for IX and IY, resp. + ! XY R.A. O Data on XY grid. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Any WAVEWATCH III routine. + ! + ! 9. Switches : + ! + ! None. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MSEA, NSEA, MX, MY, MAPSF(MSEA,2) + REAL, INTENT(IN) :: S(MSEA) + REAL, INTENT(OUT) :: XY(MX,MY) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISEA, IX, IY + !/ + !/ ------------------------------------------------------------------- / + !/ DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - XY(IX,IY) = S(ISEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + XY(IX,IY) = S(ISEA) end do -!/ -!/ End of W3S2XY ----------------------------------------------------- / -!/ - END SUBROUTINE W3S2XY -!/ ------------------------------------------------------------------- / - REAL FUNCTION EJ5P ( F, ALFA, FP, YLN, SIGA, SIGB ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 23-AMy-1985 : Original by G. Ph. van Vledder. -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Computation of spectral density using a 5-parameter -! JONSWAP-spectrum -! -! 2. Method -! -! EJ5P(F) = A.EXP(B + LN(Y).EXP(C)) -! -! where: A = ALFA * 0.06175 * F**(-5) -! B = -1.25*(FP/F)**4 -! C = -0.5 * ((F - FP)/(SIG * FP))**2 -! and -! GRAV**2/(2.PI)**4 = 0.06175 -! -! 3. Parameters : -! -! Parameter list -! -! ---------------------------------------------------------------- -! F Real I Frequency in Hz -! ALFA Real I Energy scaling factor -! FP Real I Peak frequency in Hz -! YLN Real I Peak overshoot factor, given by LN-value -! SIGA Real I Spectral width, for F < FP -! SIGB Real I Spectral width, FOR F > FP -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Any. -! -! 6. Error messages : -! -! 7. Remarks : -! -! EXPMIN is a machine dependant constant such that -! EXP(EXPMIN) can be successfully evaluated without -! underflow by the compiler supllied EXP routine. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! None. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: F, ALFA, FP, YLN, SIGA, SIGB -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - REAL :: SIG, A, B, C - REAL, SAVE :: EPS=1.E-4, EXPMIN=-180. -!/ -!/ ------------------------------------------------------------------- / -!/ - IF(F.LT.EPS) THEN - EJ5P = 0.0 - RETURN - END IF -! - A = ALFA * 0.06175 / F**5 - B = -1.25 * (FP/F)**4 - B = MAX(B,EXPMIN) -! - IF (YLN.LT.EPS) THEN - EJ5P = A * EXP(B) + !/ + !/ End of W3S2XY ----------------------------------------------------- / + !/ + END SUBROUTINE W3S2XY + !/ ------------------------------------------------------------------- / + REAL FUNCTION EJ5P ( F, ALFA, FP, YLN, SIGA, SIGB ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 23-AMy-1985 : Original by G. Ph. van Vledder. + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Computation of spectral density using a 5-parameter + ! JONSWAP-spectrum + ! + ! 2. Method + ! + ! EJ5P(F) = A.EXP(B + LN(Y).EXP(C)) + ! + ! where: A = ALFA * 0.06175 * F**(-5) + ! B = -1.25*(FP/F)**4 + ! C = -0.5 * ((F - FP)/(SIG * FP))**2 + ! and + ! GRAV**2/(2.PI)**4 = 0.06175 + ! + ! 3. Parameters : + ! + ! Parameter list + ! + ! ---------------------------------------------------------------- + ! F Real I Frequency in Hz + ! ALFA Real I Energy scaling factor + ! FP Real I Peak frequency in Hz + ! YLN Real I Peak overshoot factor, given by LN-value + ! SIGA Real I Spectral width, for F < FP + ! SIGB Real I Spectral width, FOR F > FP + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Any. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! EXPMIN is a machine dependant constant such that + ! EXP(EXPMIN) can be successfully evaluated without + ! underflow by the compiler supllied EXP routine. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! None. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: F, ALFA, FP, YLN, SIGA, SIGB + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL :: SIG, A, B, C + REAL, SAVE :: EPS=1.E-4, EXPMIN=-180. + !/ + !/ ------------------------------------------------------------------- / + !/ + IF(F.LT.EPS) THEN + EJ5P = 0.0 + RETURN + END IF + ! + A = ALFA * 0.06175 / F**5 + B = -1.25 * (FP/F)**4 + B = MAX(B,EXPMIN) + ! + IF (YLN.LT.EPS) THEN + EJ5P = A * EXP(B) + ELSE + IF( F.LE.FP) THEN + SIG = SIGA ELSE - IF( F.LE.FP) THEN - SIG = SIGA - ELSE - SIG = SIGB - END IF - C = -0.5 * ((F - FP)/(SIG * FP))**2 - C = MAX(C,EXPMIN) - EJ5P = A * EXP(B + EXP(C) * YLN) + SIG = SIGB END IF -! - RETURN -!/ -!/ End of NEXTLN ----------------------------------------------------- / -!/ + C = -0.5 * ((F - FP)/(SIG * FP))**2 + C = MAX(C,EXPMIN) + EJ5P = A * EXP(B + EXP(C) * YLN) + END IF + ! + RETURN + !/ + !/ End of NEXTLN ----------------------------------------------------- / + !/ END FUNCTION EJ5P -!/ ------------------------------------------------------------------- / - REAL FUNCTION DIST_SPHERE ( lo1,la1,lo2,la2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 18-Aug-2016 | -!/ +-----------------------------------+ -!/ -!/ 18-Aug-2016 : Creation ( version 5.11 ) -!/ -! 1. Purpose : -! -! Computes distance between two points on a sphere -! -! 2. Method -! -! -! 3. Parameters : -! -! Parameter list -! -! ---------------------------------------------------------------- -! LO1 Real I Longitude of 1st point -! LA1 Real I Latitude of 1st point -! LO2 Real I Longitude of 2nd point -! LA2 Real I Latitude of 2nd point -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! WW3_BOUNC -! -! 6. Error messages : -! -! 7. Remarks : -! -! None. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! None. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: LO1, LA1, LO2, LA2 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -! None -!/ -!/ ------------------------------------------------------------------- / -!/ - DIST_SPHERE=acos(sin(la2*DERA)*sin(la1*DERA)+ & - cos(la2*DERA)*cos(la1*DERA)*cos((lo2-lo1)*DERA))*RADE -! - RETURN -!/ -!/ End of NEXTLN ----------------------------------------------------- / -!/ + !/ ------------------------------------------------------------------- / + REAL FUNCTION DIST_SPHERE ( lo1,la1,lo2,la2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 18-Aug-2016 | + !/ +-----------------------------------+ + !/ + !/ 18-Aug-2016 : Creation ( version 5.11 ) + !/ + ! 1. Purpose : + ! + ! Computes distance between two points on a sphere + ! + ! 2. Method + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! + ! ---------------------------------------------------------------- + ! LO1 Real I Longitude of 1st point + ! LA1 Real I Latitude of 1st point + ! LO2 Real I Longitude of 2nd point + ! LA2 Real I Latitude of 2nd point + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! WW3_BOUNC + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! None. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! None. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: LO1, LA1, LO2, LA2 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + ! None + !/ + !/ ------------------------------------------------------------------- / + !/ + DIST_SPHERE=acos(sin(la2*DERA)*sin(la1*DERA)+ & + cos(la2*DERA)*cos(la1*DERA)*cos((lo2-lo1)*DERA))*RADE + ! + RETURN + !/ + !/ End of NEXTLN ----------------------------------------------------- / + !/ END FUNCTION DIST_SPHERE -!/ ------------------------------------------------------------------- / - -!/ ------------------------------------------------------------------- / - SUBROUTINE WWDATE (STRNG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2012 | -!/ +-----------------------------------+ -!/ -!/ 23-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 18-Sep-2000 : PGI switch added ( version 2.04 ) -!/ 13-Mar-2001 : LF95 switch added ( version 2.09 ) -!/ 08-May-2002 : Replace obsolete switches with F90 ( version 2.21 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ -! 1. Purpose : -! -! Get date from machine dependent routine. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! STRNG C*10 O String with date in format YYYY/MM/DD -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Machine dependent. -! -! 5. Called by : -! -! Any routine. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - CHARACTER, INTENT(OUT) :: STRNG*10 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER(LEN=8) :: DATE - CHARACTER(LEN=10) :: TIME - CHARACTER(LEN=5) :: ZONE - INTEGER :: VALUES(8) -!/ -!/ ------------------------------------------------------------------- / -!/ - STRNG = '----/--/--' - CALL DATE_AND_TIME ( DATE, TIME, ZONE, VALUES ) - STRNG(1:4) = DATE(1:4) - STRNG(6:7) = DATE(5:6) - STRNG(9:10) = DATE(7:8) -! -! - RETURN -!/ -!/ End of WWDATE ----------------------------------------------------- / -!/ - END SUBROUTINE WWDATE -!/ ------------------------------------------------------------------- / - SUBROUTINE WWTIME (STRNG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2012 | -!/ +-----------------------------------+ -!/ -!/ 23-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 18-Sep-2000 : PGI switch added ( version 2.04 ) -!/ 13-Mar-2001 : LF95 switch added ( version 2.09 ) -!/ 08-May-2002 : Replace obsolete switches with F90 ( version 2.21 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ -! 1. Purpose : -! -! Get time from machine dependent routine. -! -! 2. Method : -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! STRNG C*8 O String with time in format hh:mm:ss -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Machine dependent. -! -! 5. Called by : -! -! Any routine. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - CHARACTER, INTENT(OUT) :: STRNG*8 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER(LEN=8) :: DATE - CHARACTER(LEN=10) :: TIME - CHARACTER(LEN=5) :: ZONE - INTEGER :: VALUES(8) -!/ -!/ ------------------------------------------------------------------- / -!/ -! - STRNG = '--:--:--' - CALL DATE_AND_TIME ( DATE, TIME, ZONE, VALUES ) - STRNG(1:2) = TIME(1:2) - STRNG(4:5) = TIME(3:4) - STRNG(7:8) = TIME(5:6) -! - RETURN -!/ -!/ End of WWTIME ----------------------------------------------------- / -!/ - END SUBROUTINE WWTIME -!/ ------------------------------------------------------------------- / - SUBROUTINE EXTCDE ( IEXIT, UNIT, MSG, FILE, LINE, COMM ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 06-Jan-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 11-Mar-2015 : Allow non-error exit (iexit=0) ( version 5.04 ) -!/ 20-Jan-2017 : Add optional MPI communicator arg ( version 6.02 ) -!/ 06-Jun-2018 : Add optional MPI ( version 6.04 ) -!/ -! 1. Purpose : -! -! Perform a program stop with an exit code. -! -! If exit code IEXIT=0, then it is not an error, but -! a stop has been requested by the calling routine: -! wait for other processes in communicator to catch up. -! -! If exit code IEXIT.ne.0, then abort program w/out -! waiting for other processes to catch up (important for example -! when not all processes are used by WW3). -! -! 2. Method : -! -! Machine dependent. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IEXIT Int. I Exit code to be used. -! UNIT Int. I (optional) file unit to write error message -! MSG Str. I (optional) error message -! FILE Str. I (optional) name of source code file -! LINE Int. I (optional) line number in source code file -! COMM Int. I (optional) MPI communicator -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Any. -! -! 9. Switches : -! -! !/MPI MPI finalize interface if active -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -! + !/ ------------------------------------------------------------------- / + + !/ ------------------------------------------------------------------- / + SUBROUTINE WWDATE (STRNG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Dec-2012 | + !/ +-----------------------------------+ + !/ + !/ 23-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 18-Sep-2000 : PGI switch added ( version 2.04 ) + !/ 13-Mar-2001 : LF95 switch added ( version 2.09 ) + !/ 08-May-2002 : Replace obsolete switches with F90 ( version 2.21 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ + ! 1. Purpose : + ! + ! Get date from machine dependent routine. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! STRNG C*10 O String with date in format YYYY/MM/DD + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Machine dependent. + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + CHARACTER, INTENT(OUT) :: STRNG*10 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER(LEN=8) :: DATE + CHARACTER(LEN=10) :: TIME + CHARACTER(LEN=5) :: ZONE + INTEGER :: VALUES(8) + !/ + !/ ------------------------------------------------------------------- / + !/ + STRNG = '----/--/--' + CALL DATE_AND_TIME ( DATE, TIME, ZONE, VALUES ) + STRNG(1:4) = DATE(1:4) + STRNG(6:7) = DATE(5:6) + STRNG(9:10) = DATE(7:8) + ! + ! + RETURN + !/ + !/ End of WWDATE ----------------------------------------------------- / + !/ + END SUBROUTINE WWDATE + !/ ------------------------------------------------------------------- / + SUBROUTINE WWTIME (STRNG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Dec-2012 | + !/ +-----------------------------------+ + !/ + !/ 23-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 18-Sep-2000 : PGI switch added ( version 2.04 ) + !/ 13-Mar-2001 : LF95 switch added ( version 2.09 ) + !/ 08-May-2002 : Replace obsolete switches with F90 ( version 2.21 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ + ! 1. Purpose : + ! + ! Get time from machine dependent routine. + ! + ! 2. Method : + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! STRNG C*8 O String with time in format hh:mm:ss + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Machine dependent. + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + CHARACTER, INTENT(OUT) :: STRNG*8 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER(LEN=8) :: DATE + CHARACTER(LEN=10) :: TIME + CHARACTER(LEN=5) :: ZONE + INTEGER :: VALUES(8) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + STRNG = '--:--:--' + CALL DATE_AND_TIME ( DATE, TIME, ZONE, VALUES ) + STRNG(1:2) = TIME(1:2) + STRNG(4:5) = TIME(3:4) + STRNG(7:8) = TIME(5:6) + ! + RETURN + !/ + !/ End of WWTIME ----------------------------------------------------- / + !/ + END SUBROUTINE WWTIME + !/ ------------------------------------------------------------------- / + SUBROUTINE EXTCDE ( IEXIT, UNIT, MSG, FILE, LINE, COMM ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 06-Jan-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 11-Mar-2015 : Allow non-error exit (iexit=0) ( version 5.04 ) + !/ 20-Jan-2017 : Add optional MPI communicator arg ( version 6.02 ) + !/ 06-Jun-2018 : Add optional MPI ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Perform a program stop with an exit code. + ! + ! If exit code IEXIT=0, then it is not an error, but + ! a stop has been requested by the calling routine: + ! wait for other processes in communicator to catch up. + ! + ! If exit code IEXIT.ne.0, then abort program w/out + ! waiting for other processes to catch up (important for example + ! when not all processes are used by WW3). + ! + ! 2. Method : + ! + ! Machine dependent. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IEXIT Int. I Exit code to be used. + ! UNIT Int. I (optional) file unit to write error message + ! MSG Str. I (optional) error message + ! FILE Str. I (optional) name of source code file + ! LINE Int. I (optional) line number in source code file + ! COMM Int. I (optional) MPI communicator + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Any. + ! + ! 9. Switches : + ! + ! !/MPI MPI finalize interface if active + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IEXIT - INTEGER, INTENT(IN), OPTIONAL :: UNIT - CHARACTER(*), INTENT(IN), OPTIONAL :: MSG - CHARACTER(*), INTENT(IN), OPTIONAL :: FILE - INTEGER, INTENT(IN), OPTIONAL :: LINE - INTEGER, INTENT(IN), OPTIONAL :: COMM -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IEXIT + INTEGER, INTENT(IN), OPTIONAL :: UNIT + CHARACTER(*), INTENT(IN), OPTIONAL :: MSG + CHARACTER(*), INTENT(IN), OPTIONAL :: FILE + INTEGER, INTENT(IN), OPTIONAL :: LINE + INTEGER, INTENT(IN), OPTIONAL :: COMM + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_MPI - INTEGER :: IERR_MPI - LOGICAL :: RUN + INTEGER :: IERR_MPI + LOGICAL :: RUN #endif - INTEGER :: IUN - CHARACTER(256) :: LMSG = "" - CHARACTER(6) :: LSTR - CHARACTER(10) :: PREFIX = "WW3 ERROR:" -!/ -!/ Set file unit for error output -!/ - IUN = 0 - IF (PRESENT(UNIT)) IUN = UNIT -!/ -!/ Report error message -!/ - IF (PRESENT(MSG)) THEN - WRITE (IUN,"(A)") PREFIX//" "//TRIM(MSG) + INTEGER :: IUN + CHARACTER(256) :: LMSG = "" + CHARACTER(6) :: LSTR + CHARACTER(10) :: PREFIX = "WW3 ERROR:" + !/ + !/ Set file unit for error output + !/ + IUN = 0 + IF (PRESENT(UNIT)) IUN = UNIT + !/ + !/ Report error message + !/ + IF (PRESENT(MSG)) THEN + WRITE (IUN,"(A)") PREFIX//" "//TRIM(MSG) + END IF + !/ + !/ Report context + !/ + IF ( PRESENT(FILE) ) THEN + LMSG = TRIM(LMSG)//" FILE="//TRIM(FILE) + END IF + IF ( PRESENT(LINE) ) THEN + WRITE (LSTR,'(I0)') LINE + LMSG = TRIM(LMSG)//" LINE="//TRIM(LSTR) + END IF + IF ( LEN_TRIM(LMSG).GT.0 ) THEN + WRITE (IUN,"(A)") PREFIX//TRIM(LMSG) + END IF + !/ + !/ Handle MPI exit + !/ +#ifdef W3_MPI + CALL MPI_INITIALIZED ( RUN, IERR_MPI ) + IF ( RUN ) THEN + IF ( IEXIT.EQ.0 ) THEN ! non-error state + IF ( PRESENT(COMM) ) CALL MPI_BARRIER ( COMM, IERR_MPI ) + CALL MPI_FINALIZE (IERR_MPI ) + ELSE ! error state + WRITE(*,'(/A,I6/)') 'EXTCDE MPI_ABORT, IEXIT=', IEXIT + IF (PRESENT(UNIT)) THEN + WRITE(*,'(/A,I6/)') 'EXTCDE UNIT=', UNIT END IF -!/ -!/ Report context -!/ - IF ( PRESENT(FILE) ) THEN - LMSG = TRIM(LMSG)//" FILE="//TRIM(FILE) + IF (PRESENT(MSG)) THEN + WRITE(*,'(/2A/)') 'EXTCDE MSG=', MSG END IF - IF ( PRESENT(LINE) ) THEN - WRITE (LSTR,'(I0)') LINE - LMSG = TRIM(LMSG)//" LINE="//TRIM(LSTR) + IF (PRESENT(FILE)) THEN + WRITE(*,'(/2A/)') 'EXTCDE FILE=', FILE END IF - IF ( LEN_TRIM(LMSG).GT.0 ) THEN - WRITE (IUN,"(A)") PREFIX//TRIM(LMSG) + IF (PRESENT(LINE)) THEN + WRITE(*,'(/A,I8/)') 'EXTCDE LINE=', LINE END IF -!/ -!/ Handle MPI exit -!/ -#ifdef W3_MPI - CALL MPI_INITIALIZED ( RUN, IERR_MPI ) - IF ( RUN ) THEN - IF ( IEXIT.EQ.0 ) THEN ! non-error state - IF ( PRESENT(COMM) ) CALL MPI_BARRIER ( COMM, IERR_MPI ) - CALL MPI_FINALIZE (IERR_MPI ) - ELSE ! error state - WRITE(*,'(/A,I6/)') 'EXTCDE MPI_ABORT, IEXIT=', IEXIT - IF (PRESENT(UNIT)) THEN - WRITE(*,'(/A,I6/)') 'EXTCDE UNIT=', UNIT - END IF - IF (PRESENT(MSG)) THEN - WRITE(*,'(/2A/)') 'EXTCDE MSG=', MSG - END IF - IF (PRESENT(FILE)) THEN - WRITE(*,'(/2A/)') 'EXTCDE FILE=', FILE - END IF - IF (PRESENT(LINE)) THEN - WRITE(*,'(/A,I8/)') 'EXTCDE LINE=', LINE - END IF - IF (PRESENT(COMM)) THEN - WRITE(*,'(/A,I6/)') 'EXTCDE COMM=', COMM - END IF - CALL MPI_ABORT ( MPI_COMM_WORLD, IEXIT, IERR_MPI ) + IF (PRESENT(COMM)) THEN + WRITE(*,'(/A,I6/)') 'EXTCDE COMM=', COMM END IF + CALL MPI_ABORT ( MPI_COMM_WORLD, IEXIT, IERR_MPI ) END IF + END IF #endif -!/ -!/ Handle non-MPI exit -!/ - CALL EXIT ( IEXIT ) -!/ -!/ End of EXTCDE ----------------------------------------------------- / -!/ - END SUBROUTINE EXTCDE -!/ ------------------------------------------------------------------- / -! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! This subroutine turn the wave spectrum by an fixed angle anti-clockwise -! so that it may be used in the rotated or stanadard system. -! First created: 26 Aug 2005 Jian-Guo Li -! Last modified: 21 Feb 2008 Jian-Guo Li -! -! Subroutine Interface: - - Subroutine W3SPECTN( NFreq, NDirc, Alpha, Spectr ) - -! Description: -! Rotates wave spectrum anticlockwise by angle alpha in degree -! This routine is distinct from W3ACTURN since orders spectrum as freq, dirn -! -! Subroutine arguments - IMPLICIT NONE - INTEGER, INTENT(IN) :: NFreq, NDirc ! No. freq and dirn bins - REAL, INTENT(IN) :: Alpha ! Turning angle (degrees) - REAL, INTENT(INOUT) :: Spectr(NFreq,NDirc) ! Wave spectrum in/out - -! Local variables - INTEGER :: ii, jj, kk, nsft - REAL :: Ddirc, frac, CNST - REAL, Dimension(NFreq) :: Wrkfrq, Tmpfrq - REAL, Dimension(NFreq,NDirc):: Wrkspc - -! Check input bin numbers - IF( (NFreq .LT. 0) .OR. (NDirc .LT. 0) ) THEN - PRINT*, " Invalid bin number NF or ND", NFreq, NDirc - RETURN - ELSE - Ddirc=360.0/FLOAT(NDirc) - ENDIF - -! Work out shift bin number and fraction - - CNST=Alpha/Ddirc - nsft=INT( CNST ) - frac= CNST - FLOAT( nsft ) -! PRINT*, ' nsft and frac =', nsft, frac - -! Shift nsft bins if >=1 - IF( ABS(nsft) .GE. 1 ) THEN - DO ii=1, NDirc - -! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST -! So shift nsft bins anticlockwise results in local bin number decreasing by nsft - jj=ii - nsft - -! As nsft may be either positive or negative depends on alpha, wrapping may -! happen in either ends of the bin number train - IF( jj > NDirc ) jj=jj - NDirc - IF( jj < 1 ) jj=jj + NDirc - -! Copy the selected bin to the loop bin number - Wrkspc(:,ii)=Spectr(:,jj) - - ENDDO - -! If nsft=0, no need to shift, simply copy - ELSE - Wrkspc = Spectr - ENDIF - -! Pass fraction of wave energy in frac direction -! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST -! So Positive frac or anticlock case, smaller bin upstream - IF( frac > 0.0 ) THEN - Tmpfrq=Wrkspc(:,NDirc)*frac - DO kk=1, NDirc - Wrkfrq=Wrkspc(:,kk)*frac - Spectr(:,kk)=Wrkspc(:,kk) - Wrkfrq + Tmpfrq - Tmpfrq=Wrkfrq - ENDDO - ELSE -! Negative or clockwise case, larger bin upstream - Tmpfrq=Wrkspc(:,1)*frac - DO kk=NDirc, 1, -1 - Wrkfrq=Wrkspc(:,kk)*frac - Spectr(:,kk)=Wrkspc(:,kk) + Wrkfrq - Tmpfrq - Tmpfrq=Wrkfrq - ENDDO - ENDIF - -! Spectral turning completed - - RETURN - END SUBROUTINE W3SPECTN -! -! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! This subroutine turn the wave action by an angle (deg) anti-clockwise -! so that it may be used in the rotated or stanadard system. -! First created: 26 Aug 2005 Jian-Guo Li -! Last modified: 9 Oct 2008 Jian-Guo Li -! -! Subroutine Interface: - - Subroutine W3ACTURN( NDirc, NFreq, Alpha, Spectr ) - -! Description: -! Rotates wave spectrum anticlockwise by angle alpha -! Routine is distinct from W3SPECTN since orders spectrum as dirn, freq -! -! Subroutine arguments - IMPLICIT NONE - INTEGER, INTENT(IN) :: NFreq, NDirc ! No. freq and dirn bins - REAL, INTENT(IN) :: Alpha ! Turning angle (degrees) - REAL, INTENT(INOUT) :: Spectr(NDirc, NFreq) ! Wave action in/out - -! Local variables - INTEGER :: ii, jj, kk, nsft - REAL :: Ddirc, frac, CNST - REAL, Dimension(NFreq) :: Wrkfrq, Tmpfrq - REAL, Dimension(NDirc,NFreq):: Wrkspc - -! Check input bin numbers - IF( (NFreq .LT. 0) .OR. (NDirc .LT. 0) ) THEN - PRINT*, " Invalid bin number NF or ND", NFreq, NDirc - RETURN - ELSE - Ddirc=360.0/FLOAT(NDirc) - ENDIF - -! Work out shift bin number and fraction - - CNST=Alpha/Ddirc - nsft=INT( CNST ) - frac= CNST - FLOAT( nsft ) -! PRINT*, ' nsft and frac =', nsft, frac - -! Shift nsft bins if >=1 - IF( ABS(nsft) .GE. 1 ) THEN - DO ii=1, NDirc - -! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST -! So shift nsft bins anticlockwise results in local bin number decreasing by nsft - jj=ii - nsft - -! As nsft may be either positive or negative depends on alpha, wrapping may -! happen in either ends of the bin number train - IF( jj > NDirc ) jj=jj - NDirc - IF( jj < 1 ) jj=jj + NDirc - -! Copy the selected bin to the loop bin number - Wrkspc(ii,:)=Spectr(jj,:) - - ENDDO - -! If nsft=0, no need to shift, simply copy - ELSE - Wrkspc = Spectr - ENDIF - -! Pass fraction of wave energy in frac direction -! Wave spectral direction bin number is assumed to increase anti-clockwise from EAST -! So positive frac or anticlock case, smaller bin upstream - IF( frac > 0.0 ) THEN - Tmpfrq=Wrkspc(NDirc,:)*frac - DO kk=1, NDirc - Wrkfrq=Wrkspc(kk,:)*frac - Spectr(kk,:)=Wrkspc(kk,:) - Wrkfrq + Tmpfrq - Tmpfrq=Wrkfrq - ENDDO - ELSE -! Negative or clockwise case, larger bin upstream - Tmpfrq=Wrkspc(1,:)*frac - DO kk=NDirc, 1, -1 - Wrkfrq=Wrkspc(kk,:)*frac - Spectr(kk,:)=Wrkspc(kk,:) + Wrkfrq - Tmpfrq - Tmpfrq=Wrkfrq - ENDDO - ENDIF - -! Spectral turning completed - - RETURN - END SUBROUTINE W3ACTURN -! -!Li +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!Li -!Li Merged UM source code for rotated grid, consisting the following -!Li original subroutines in UM 6.1 -!Li LLTOEQ1A WCOEFF1A and LBCROTWINDS1 -!Li The last subroutine is modified to process only one level winds -!Li cpp directives are removed and required header C_Pi.h inserted. -!Li Jian-Guo Li 26 May 2005 -!Li -!Li The WCOEFF1A subroutine is merged into LLTOEQ to reduce repetition -!Li of the same calculations. Subroutine interface changed to -!Li LLTOEQANGLE -!Li Jian-GUo Li 23 Aug 2005 -!Li -!Li Subroutine W3LLTOEQ -------------------------------------------- -!Li -!Li Purpose: Calculates latitude and longitude on equatorial -!Li latitude-longitude (eq) grid used in regional -!Li models from input arrays of latitude and -!Li longitude on standard grid. Both input and output -!Li latitudes and longitudes are in degrees. -!Li Also calculate rotation angle in degree to tranform -!Li standard wind velocity into equatorial wind. -!Li Valid for 0= 0.0) THEN - SIN_PHI_POLE = SIN(PI_OVER_180*PHI_POLE) - COS_PHI_POLE = COS(PI_OVER_180*PHI_POLE) - ELSE - SIN_PHI_POLE = -SIN(PI_OVER_180*PHI_POLE) - COS_PHI_POLE = -COS(PI_OVER_180*PHI_POLE) - ENDIF - -! 2. Transform from standard to equatorial latitude-longitude + !/ + !/ Handle non-MPI exit + !/ + CALL EXIT ( IEXIT ) + !/ + !/ End of EXTCDE ----------------------------------------------------- / + !/ + END SUBROUTINE EXTCDE + !/ ------------------------------------------------------------------- / + ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! This subroutine turn the wave spectrum by an fixed angle anti-clockwise + ! so that it may be used in the rotated or stanadard system. + ! First created: 26 Aug 2005 Jian-Guo Li + ! Last modified: 21 Feb 2008 Jian-Guo Li + ! + ! Subroutine Interface: + + Subroutine W3SPECTN( NFreq, NDirc, Alpha, Spectr ) + + ! Description: + ! Rotates wave spectrum anticlockwise by angle alpha in degree + ! This routine is distinct from W3ACTURN since orders spectrum as freq, dirn + ! + ! Subroutine arguments + IMPLICIT NONE + INTEGER, INTENT(IN) :: NFreq, NDirc ! No. freq and dirn bins + REAL, INTENT(IN) :: Alpha ! Turning angle (degrees) + REAL, INTENT(INOUT) :: Spectr(NFreq,NDirc) ! Wave spectrum in/out + + ! Local variables + INTEGER :: ii, jj, kk, nsft + REAL :: Ddirc, frac, CNST + REAL, Dimension(NFreq) :: Wrkfrq, Tmpfrq + REAL, Dimension(NFreq,NDirc):: Wrkspc + + ! Check input bin numbers + IF( (NFreq .LT. 0) .OR. (NDirc .LT. 0) ) THEN + PRINT*, " Invalid bin number NF or ND", NFreq, NDirc + RETURN + ELSE + Ddirc=360.0/FLOAT(NDirc) + ENDIF - DO I= 1, POINTS + ! Work out shift bin number and fraction -! Scale longitude to range -180 to +180 degs + CNST=Alpha/Ddirc + nsft=INT( CNST ) + frac= CNST - FLOAT( nsft ) + ! PRINT*, ' nsft and frac =', nsft, frac - A_LAMBDA=LAMBDA(I)-LAMBDA_ZERO - IF(A_LAMBDA.GT. 180.0) A_LAMBDA=A_LAMBDA-360.D0 - IF(A_LAMBDA.LE.-180.0) A_LAMBDA=A_LAMBDA+360.D0 + ! Shift nsft bins if >=1 + IF( ABS(nsft) .GE. 1 ) THEN + DO ii=1, NDirc -! Convert latitude & longitude to radians + ! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST + ! So shift nsft bins anticlockwise results in local bin number decreasing by nsft + jj=ii - nsft - A_LAMBDA=PI_OVER_180*A_LAMBDA - A_PHI=PI_OVER_180*PHI(I) + ! As nsft may be either positive or negative depends on alpha, wrapping may + ! happen in either ends of the bin number train + IF( jj > NDirc ) jj=jj - NDirc + IF( jj < 1 ) jj=jj + NDirc -! Compute eq latitude using equation (4.4) + ! Copy the selected bin to the loop bin number + Wrkspc(:,ii)=Spectr(:,jj) - ARG=-COS_PHI_POLE*COS(A_PHI)*COS(A_LAMBDA) & - & +SIN_PHI_POLE*SIN(A_PHI) - ARG=MIN(ARG, 1.D0) - ARG=MAX(ARG,-1.D0) - E_PHI=ASIN(ARG) - PHI_EQ(I)=RECIP_PI_OVER_180*E_PHI - -! Compute eq longitude using equation (4.6) + ENDDO - TERM1 = SIN_PHI_POLE*COS(A_PHI)*COS(A_LAMBDA) & - & +COS_PHI_POLE*SIN(A_PHI) - TERM2 = COS(E_PHI) - IF(TERM2 .LT. SMALL) THEN - E_LAMBDA=0.D0 - ELSE - ARG=TERM1/TERM2 - ARG=MIN(ARG, 1.D0) - ARG=MAX(ARG,-1.D0) - E_LAMBDA=RECIP_PI_OVER_180*ACOS(ARG) - E_LAMBDA=SIGN(E_LAMBDA,A_LAMBDA) - ENDIF + ! If nsft=0, no need to shift, simply copy + ELSE + Wrkspc = Spectr + ENDIF + + ! Pass fraction of wave energy in frac direction + ! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST + ! So Positive frac or anticlock case, smaller bin upstream + IF( frac > 0.0 ) THEN + Tmpfrq=Wrkspc(:,NDirc)*frac + DO kk=1, NDirc + Wrkfrq=Wrkspc(:,kk)*frac + Spectr(:,kk)=Wrkspc(:,kk) - Wrkfrq + Tmpfrq + Tmpfrq=Wrkfrq + ENDDO + ELSE + ! Negative or clockwise case, larger bin upstream + Tmpfrq=Wrkspc(:,1)*frac + DO kk=NDirc, 1, -1 + Wrkfrq=Wrkspc(:,kk)*frac + Spectr(:,kk)=Wrkspc(:,kk) + Wrkfrq - Tmpfrq + Tmpfrq=Wrkfrq + ENDDO + ENDIF + + ! Spectral turning completed + + RETURN + END SUBROUTINE W3SPECTN + ! + ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! This subroutine turn the wave action by an angle (deg) anti-clockwise + ! so that it may be used in the rotated or stanadard system. + ! First created: 26 Aug 2005 Jian-Guo Li + ! Last modified: 9 Oct 2008 Jian-Guo Li + ! + ! Subroutine Interface: + + Subroutine W3ACTURN( NDirc, NFreq, Alpha, Spectr ) + + ! Description: + ! Rotates wave spectrum anticlockwise by angle alpha + ! Routine is distinct from W3SPECTN since orders spectrum as dirn, freq + ! + ! Subroutine arguments + IMPLICIT NONE + INTEGER, INTENT(IN) :: NFreq, NDirc ! No. freq and dirn bins + REAL, INTENT(IN) :: Alpha ! Turning angle (degrees) + REAL, INTENT(INOUT) :: Spectr(NDirc, NFreq) ! Wave action in/out + + ! Local variables + INTEGER :: ii, jj, kk, nsft + REAL :: Ddirc, frac, CNST + REAL, Dimension(NFreq) :: Wrkfrq, Tmpfrq + REAL, Dimension(NDirc,NFreq):: Wrkspc + + ! Check input bin numbers + IF( (NFreq .LT. 0) .OR. (NDirc .LT. 0) ) THEN + PRINT*, " Invalid bin number NF or ND", NFreq, NDirc + RETURN + ELSE + Ddirc=360.0/FLOAT(NDirc) + ENDIF -! Scale longitude to range 0 to 360 degs + ! Work out shift bin number and fraction - IF(E_LAMBDA.GE.360.0) E_LAMBDA=E_LAMBDA-360.D0 - IF(E_LAMBDA.LT. 0.0) E_LAMBDA=E_LAMBDA+360.D0 - LAMBDA_EQ(I)=E_LAMBDA + CNST=Alpha/Ddirc + nsft=INT( CNST ) + frac= CNST - FLOAT( nsft ) + ! PRINT*, ' nsft and frac =', nsft, frac -!Li Calculate turning angle for standard wind velocity + ! Shift nsft bins if >=1 + IF( ABS(nsft) .GE. 1 ) THEN + DO ii=1, NDirc - E_LAMBDA=PI_OVER_180*LAMBDA_EQ(I) + ! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST + ! So shift nsft bins anticlockwise results in local bin number decreasing by nsft + jj=ii - nsft -! Formulae used are from eqs (4.19) and (4.21) + ! As nsft may be either positive or negative depends on alpha, wrapping may + ! happen in either ends of the bin number train + IF( jj > NDirc ) jj=jj - NDirc + IF( jj < 1 ) jj=jj + NDirc - TERM2=SIN(E_LAMBDA) - ARG= SIN(A_LAMBDA)*TERM2*SIN_PHI_POLE & - & +COS(A_LAMBDA)*COS(E_LAMBDA) - ARG=MIN(ARG, 1.D0) - ARG=MAX(ARG,-1.D0) - TERM1=RECIP_PI_OVER_180*ACOS(ARG) - ANGLED(I)=SIGN(TERM1,TERM2) -!Li + ! Copy the selected bin to the loop bin number + Wrkspc(ii,:)=Spectr(jj,:) ENDDO -! Reset Lambda pole to the setting on entry to subroutine - LAMBDA_POLE=LAMBDA_POLE_KEEP - - RETURN - END SUBROUTINE W3LLTOEQ -! -!Li +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!Li -!Li Merged UM source code for rotated grid, consiting the following -!Li original subroutines in UM 6.1 -!Li EQTOLL1A WCOEFF1A and LBCROTWINDS1 -!Li The last subroutine is modified to process only one level winds -!Li cpp directives are removed and required header C_Pi.h inserted. -!Li Jian-Guo Li 26 May 2005 -!Li -!Li The WCOEFF1A subroutine is merged into EQTOLL to reduce repetition -!Li of the same calculations. Subroutine interface changed to -!Li EQTOLLANGLE -!Li First created: Jian-GUo Li 23 Aug 2005 -!Li Last modified: Jian-GUo Li 25 Feb 2008 -!Li -!Li Subroutine W3EQTOLL -------------------------------------------- -!Li -!Li Purpose: Calculates latitude and longitude on standard grid -!Li from input arrays of latitude and longitude on -!Li equatorial latitude-longitude (eq) grid used -!Li in regional models. Both input and output latitudes -!Li and longitudes are in degrees. -!Li Also calculate rotation angle in degree to tranform -!Li standard wind velocity into equatorial wind. -!Li Valid for 0= 0.0) THEN - SIN_PHI_POLE = SIN(PI_OVER_180*PHI_POLE) - COS_PHI_POLE = COS(PI_OVER_180*PHI_POLE) + ! If nsft=0, no need to shift, simply copy + ELSE + Wrkspc = Spectr + ENDIF + + ! Pass fraction of wave energy in frac direction + ! Wave spectral direction bin number is assumed to increase anti-clockwise from EAST + ! So positive frac or anticlock case, smaller bin upstream + IF( frac > 0.0 ) THEN + Tmpfrq=Wrkspc(NDirc,:)*frac + DO kk=1, NDirc + Wrkfrq=Wrkspc(kk,:)*frac + Spectr(kk,:)=Wrkspc(kk,:) - Wrkfrq + Tmpfrq + Tmpfrq=Wrkfrq + ENDDO + ELSE + ! Negative or clockwise case, larger bin upstream + Tmpfrq=Wrkspc(1,:)*frac + DO kk=NDirc, 1, -1 + Wrkfrq=Wrkspc(kk,:)*frac + Spectr(kk,:)=Wrkspc(kk,:) + Wrkfrq - Tmpfrq + Tmpfrq=Wrkfrq + ENDDO + ENDIF + + ! Spectral turning completed + + RETURN + END SUBROUTINE W3ACTURN + ! + !Li +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !Li + !Li Merged UM source code for rotated grid, consisting the following + !Li original subroutines in UM 6.1 + !Li LLTOEQ1A WCOEFF1A and LBCROTWINDS1 + !Li The last subroutine is modified to process only one level winds + !Li cpp directives are removed and required header C_Pi.h inserted. + !Li Jian-Guo Li 26 May 2005 + !Li + !Li The WCOEFF1A subroutine is merged into LLTOEQ to reduce repetition + !Li of the same calculations. Subroutine interface changed to + !Li LLTOEQANGLE + !Li Jian-GUo Li 23 Aug 2005 + !Li + !Li Subroutine W3LLTOEQ -------------------------------------------- + !Li + !Li Purpose: Calculates latitude and longitude on equatorial + !Li latitude-longitude (eq) grid used in regional + !Li models from input arrays of latitude and + !Li longitude on standard grid. Both input and output + !Li latitudes and longitudes are in degrees. + !Li Also calculate rotation angle in degree to tranform + !Li standard wind velocity into equatorial wind. + !Li Valid for 0= 0.0) THEN + SIN_PHI_POLE = SIN(PI_OVER_180*PHI_POLE) + COS_PHI_POLE = COS(PI_OVER_180*PHI_POLE) + ELSE + SIN_PHI_POLE = -SIN(PI_OVER_180*PHI_POLE) + COS_PHI_POLE = -COS(PI_OVER_180*PHI_POLE) + ENDIF + + ! 2. Transform from standard to equatorial latitude-longitude + + DO I= 1, POINTS + + ! Scale longitude to range -180 to +180 degs + + A_LAMBDA=LAMBDA(I)-LAMBDA_ZERO + IF(A_LAMBDA.GT. 180.0) A_LAMBDA=A_LAMBDA-360.D0 + IF(A_LAMBDA.LE.-180.0) A_LAMBDA=A_LAMBDA+360.D0 + + ! Convert latitude & longitude to radians + + A_LAMBDA=PI_OVER_180*A_LAMBDA + A_PHI=PI_OVER_180*PHI(I) + + ! Compute eq latitude using equation (4.4) + + ARG=-COS_PHI_POLE*COS(A_PHI)*COS(A_LAMBDA) & + & +SIN_PHI_POLE*SIN(A_PHI) + ARG=MIN(ARG, 1.D0) + ARG=MAX(ARG,-1.D0) + E_PHI=ASIN(ARG) + PHI_EQ(I)=RECIP_PI_OVER_180*E_PHI + + ! Compute eq longitude using equation (4.6) + + TERM1 = SIN_PHI_POLE*COS(A_PHI)*COS(A_LAMBDA) & + & +COS_PHI_POLE*SIN(A_PHI) + TERM2 = COS(E_PHI) + IF(TERM2 .LT. SMALL) THEN + E_LAMBDA=0.D0 ELSE - SIN_PHI_POLE = -SIN(PI_OVER_180*PHI_POLE) - COS_PHI_POLE = -COS(PI_OVER_180*PHI_POLE) + ARG=TERM1/TERM2 + ARG=MIN(ARG, 1.D0) + ARG=MAX(ARG,-1.D0) + E_LAMBDA=RECIP_PI_OVER_180*ACOS(ARG) + E_LAMBDA=SIGN(E_LAMBDA,A_LAMBDA) ENDIF -! 2. Transform from equatorial to standard latitude-longitude - - DO I= 1, POINTS - -! Scale eq longitude to range -180 to +180 degs - - E_LAMBDA=LAMBDA_EQ(I) - IF(E_LAMBDA.GT. 180.0) E_LAMBDA=E_LAMBDA-360.D0 - IF(E_LAMBDA.LT.-180.0) E_LAMBDA=E_LAMBDA+360.D0 - -! Convert eq latitude & longitude to radians - - E_LAMBDA=PI_OVER_180*E_LAMBDA - E_PHI=PI_OVER_180*PHI_EQ(I) - -! Compute latitude using equation (4.7) - - ARG=COS_PHI_POLE*COS(E_PHI)*COS(E_LAMBDA) & - & +SIN_PHI_POLE*SIN(E_PHI) + ! Scale longitude to range 0 to 360 degs + + IF(E_LAMBDA.GE.360.0) E_LAMBDA=E_LAMBDA-360.D0 + IF(E_LAMBDA.LT. 0.0) E_LAMBDA=E_LAMBDA+360.D0 + LAMBDA_EQ(I)=E_LAMBDA + + !Li Calculate turning angle for standard wind velocity + + E_LAMBDA=PI_OVER_180*LAMBDA_EQ(I) + + ! Formulae used are from eqs (4.19) and (4.21) + + TERM2=SIN(E_LAMBDA) + ARG= SIN(A_LAMBDA)*TERM2*SIN_PHI_POLE & + & +COS(A_LAMBDA)*COS(E_LAMBDA) + ARG=MIN(ARG, 1.D0) + ARG=MAX(ARG,-1.D0) + TERM1=RECIP_PI_OVER_180*ACOS(ARG) + ANGLED(I)=SIGN(TERM1,TERM2) + !Li + + ENDDO + + ! Reset Lambda pole to the setting on entry to subroutine + LAMBDA_POLE=LAMBDA_POLE_KEEP + + RETURN + END SUBROUTINE W3LLTOEQ + ! + !Li +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !Li + !Li Merged UM source code for rotated grid, consiting the following + !Li original subroutines in UM 6.1 + !Li EQTOLL1A WCOEFF1A and LBCROTWINDS1 + !Li The last subroutine is modified to process only one level winds + !Li cpp directives are removed and required header C_Pi.h inserted. + !Li Jian-Guo Li 26 May 2005 + !Li + !Li The WCOEFF1A subroutine is merged into EQTOLL to reduce repetition + !Li of the same calculations. Subroutine interface changed to + !Li EQTOLLANGLE + !Li First created: Jian-GUo Li 23 Aug 2005 + !Li Last modified: Jian-GUo Li 25 Feb 2008 + !Li + !Li Subroutine W3EQTOLL -------------------------------------------- + !Li + !Li Purpose: Calculates latitude and longitude on standard grid + !Li from input arrays of latitude and longitude on + !Li equatorial latitude-longitude (eq) grid used + !Li in regional models. Both input and output latitudes + !Li and longitudes are in degrees. + !Li Also calculate rotation angle in degree to tranform + !Li standard wind velocity into equatorial wind. + !Li Valid for 0= 0.0) THEN + SIN_PHI_POLE = SIN(PI_OVER_180*PHI_POLE) + COS_PHI_POLE = COS(PI_OVER_180*PHI_POLE) + ELSE + SIN_PHI_POLE = -SIN(PI_OVER_180*PHI_POLE) + COS_PHI_POLE = -COS(PI_OVER_180*PHI_POLE) + ENDIF + + ! 2. Transform from equatorial to standard latitude-longitude + + DO I= 1, POINTS + + ! Scale eq longitude to range -180 to +180 degs + + E_LAMBDA=LAMBDA_EQ(I) + IF(E_LAMBDA.GT. 180.0) E_LAMBDA=E_LAMBDA-360.D0 + IF(E_LAMBDA.LT.-180.0) E_LAMBDA=E_LAMBDA+360.D0 + + ! Convert eq latitude & longitude to radians + + E_LAMBDA=PI_OVER_180*E_LAMBDA + E_PHI=PI_OVER_180*PHI_EQ(I) + + ! Compute latitude using equation (4.7) + + ARG=COS_PHI_POLE*COS(E_PHI)*COS(E_LAMBDA) & + & +SIN_PHI_POLE*SIN(E_PHI) + ARG=MIN(ARG, 1.D0) + ARG=MAX(ARG,-1.D0) + A_PHI=ASIN(ARG) + PHI(I)=RECIP_PI_OVER_180*A_PHI + + ! Compute longitude using equation (4.8) + + TERM1 = COS(E_PHI)*SIN_PHI_POLE*COS(E_LAMBDA) & + & -SIN(E_PHI)*COS_PHI_POLE + TERM2 = COS(A_PHI) + IF(TERM2.LT.SMALL) THEN + A_LAMBDA=0.D0 + ELSE + ARG=TERM1/TERM2 ARG=MIN(ARG, 1.D0) ARG=MAX(ARG,-1.D0) - A_PHI=ASIN(ARG) - PHI(I)=RECIP_PI_OVER_180*A_PHI - -! Compute longitude using equation (4.8) + A_LAMBDA=RECIP_PI_OVER_180*ACOS(ARG) + A_LAMBDA=SIGN(A_LAMBDA,E_LAMBDA) + A_LAMBDA=A_LAMBDA+LAMBDA_ZERO + END IF - TERM1 = COS(E_PHI)*SIN_PHI_POLE*COS(E_LAMBDA) & - & -SIN(E_PHI)*COS_PHI_POLE - TERM2 = COS(A_PHI) - IF(TERM2.LT.SMALL) THEN - A_LAMBDA=0.D0 + ! Scale longitude to range 0 to 360 degs + + IF(A_LAMBDA.GE.360.0) A_LAMBDA=A_LAMBDA-360.D0 + IF(A_LAMBDA.LT. 0.0) A_LAMBDA=A_LAMBDA+360.D0 + LAMBDA(I)=A_LAMBDA + + !Li Calculate turning angle for standard wind velocity + + A_LAMBDA=PI_OVER_180*(LAMBDA(I)-LAMBDA_ZERO) + + ! Formulae used are from eqs (4.19) and (4.21) + + TERM2=SIN(E_LAMBDA) + ARG=SIN(A_LAMBDA)*TERM2*SIN_PHI_POLE & + & +COS(A_LAMBDA)*COS(E_LAMBDA) + ARG=MIN(ARG, 1.D0) + ARG=MAX(ARG,-1.D0) + TERM1=RECIP_PI_OVER_180*ACOS(ARG) + ANGLED(I)=SIGN(TERM1,TERM2) + !Li + + ENDDO + + RETURN + END SUBROUTINE W3EQTOLL + + !Li + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE W3THRTN ( NSEA, THETA, AnglD, Degrees ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NMC | + !/ | A. Saulter | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mar-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2018 : Added subroutine ( version 6.02 ) + ! + ! 1. Purpose : + ! Subroutine to de-rotate directions from rotated to standard pole + ! reference system + ! + ! 2. Method: + ! Rotates x,y vectors anticlockwise by angle alpha in radians + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY : DERA, TPI, UNDEF + IMPLICIT NONE + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NSEA ! Number of sea points + REAL, INTENT(IN) :: AnglD(NSEA) ! Turning angle (degrees) + LOGICAL, INTENT(IN) :: Degrees ! Use degrees or radians + REAL, INTENT(INOUT) :: THETA(NSEA) ! Direction seapoint array + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISEA + ! + !/ ------------------------------------------------------------------- / + ! Apply the rotation + ! + DO ISEA=1, NSEA + IF ( THETA(ISEA) .NE. UNDEF ) THEN + IF ( Degrees ) THEN + THETA(ISEA) = THETA(ISEA) - AnglD(ISEA) + IF ( THETA(ISEA) .LT. 0 ) THETA(ISEA) = THETA(ISEA) + 360.0 ELSE - ARG=TERM1/TERM2 - ARG=MIN(ARG, 1.D0) - ARG=MAX(ARG,-1.D0) - A_LAMBDA=RECIP_PI_OVER_180*ACOS(ARG) - A_LAMBDA=SIGN(A_LAMBDA,E_LAMBDA) - A_LAMBDA=A_LAMBDA+LAMBDA_ZERO + THETA(ISEA) = THETA(ISEA) - AnglD(ISEA)*DERA + IF ( THETA(ISEA) .LT. 0 ) THETA(ISEA) = THETA(ISEA) + TPI END IF - -! Scale longitude to range 0 to 360 degs - - IF(A_LAMBDA.GE.360.0) A_LAMBDA=A_LAMBDA-360.D0 - IF(A_LAMBDA.LT. 0.0) A_LAMBDA=A_LAMBDA+360.D0 - LAMBDA(I)=A_LAMBDA - -!Li Calculate turning angle for standard wind velocity - - A_LAMBDA=PI_OVER_180*(LAMBDA(I)-LAMBDA_ZERO) - -! Formulae used are from eqs (4.19) and (4.21) - - TERM2=SIN(E_LAMBDA) - ARG=SIN(A_LAMBDA)*TERM2*SIN_PHI_POLE & - & +COS(A_LAMBDA)*COS(E_LAMBDA) - ARG=MIN(ARG, 1.D0) - ARG=MAX(ARG,-1.D0) - TERM1=RECIP_PI_OVER_180*ACOS(ARG) - ANGLED(I)=SIGN(TERM1,TERM2) -!Li - - ENDDO - + ENDIF + END DO + + RETURN + END SUBROUTINE W3THRTN + ! + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE W3XYRTN ( NSEA, XVEC, YVEC, AnglD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NMC | + !/ | A. Saulter | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mar-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2018 : Added subroutine ( version 6.02 ) + ! + ! 1. Purpose : + ! Subroutine to de-rotate x,y vectors from rotated to standard pole + ! reference system + ! + ! 2. Method: + ! Rotates x,y vectors anticlockwise by angle alpha in radians + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY : DERA, TPI, UNDEF + IMPLICIT NONE + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NSEA ! Number of sea points + REAL, INTENT(IN) :: AnglD(NSEA) ! Turning angle (degrees) + REAL, INTENT(INOUT) :: XVEC(NSEA), YVEC(NSEA) + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISEA + REAL :: XVTMP, YVTMP + ! + !/ ------------------------------------------------------------------- / + ! Apply the rotation + ! + DO ISEA=1, NSEA + IF (( XVEC(ISEA) .NE. UNDEF ) .AND. & + ( YVEC(ISEA) .NE. UNDEF )) THEN + XVTMP = XVEC(ISEA)*COS(AnglD(ISEA)*DERA) + & + YVEC(ISEA)*SIN(AnglD(ISEA)*DERA) + YVTMP = YVEC(ISEA)*COS(AnglD(ISEA)*DERA) - & + XVEC(ISEA)*SIN(AnglD(ISEA)*DERA) + XVEC(ISEA) = XVTMP + YVEC(ISEA) = YVTMP + END IF + END DO + + RETURN + END SUBROUTINE W3XYRTN + ! + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE STRSPLIT(STRING,TAB) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 29-Apr-2013 ! + !/ +-----------------------------------+ + !/ + !/ 29-Mar-2013 : Origination. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Splits string into words + ! + ! 2. Method : + ! + ! finds spaces and loops + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! STRING Str O String to be splitted + ! TAB Str O Array of strings + ! ---------------------------------------------------------------- + ! + + IMPLICIT NONE + + + + CHARACTER(LEN=*), intent(IN) :: STRING + CHARACTER(LEN=100), intent(INOUT) :: TAB(*) + INTEGER :: cnt, I + CHARACTER(LEN=1024) :: tmp_str, ori_str + + ! initializes arrays + ori_str=ADJUSTL(TRIM(STRING)) + tmp_str=ori_str + cnt=0 + + ! counts the number of substrings + DO WHILE ((INDEX(tmp_str,' ').NE.0) .AND. (len_trim(tmp_str).NE.0)) + tmp_str=ADJUSTL(tmp_str(INDEX(tmp_str,' ')+1:)) + cnt=cnt+1 + ENDDO + ! + ! reinitializes arrays + ! + tmp_str=ori_str + ! loops on each substring + DO I=1,cnt + TAB(I)=tmp_str(:INDEX(tmp_str,' ')) + tmp_str=ADJUSTL(tmp_str(INDEX(tmp_str,' ')+1:)) + END DO + + RETURN + !/ + !/ End of STRSPLIT ----------------------------------------------------- / + !/ + END SUBROUTINE STRSPLIT + !/ + + !/ ------------------------------------------------------------------- / + SUBROUTINE STR_TO_UPPER(STR) + character(*), intent(inout) :: str + integer :: i + + DO i = 1, len(str) + select case(str(i:i)) + case("a":"z") + str(i:i) = achar(iachar(str(i:i))-32) + end select + END DO + !/ End of STR_TO_UPPER + !/ ------------------------------------------------------------------- / + END SUBROUTINE STR_TO_UPPER + + !********************************************************************** + !* * +#ifdef W3_T + !********************************************************************** + SUBROUTINE SSORT1 (X, Y, N, KFLAG) + !***BEGIN PROLOGUE SSORT + !***PURPOSE Sort an array and optionally make the same interchanges in + ! an auxiliary array. The array may be sorted in increasing + ! or decreasing order. A slightly modified QUICKSORT + ! algorithm is used. + !***LIBRARY SLATEC + !***CATEGORY N6A2B + !***TYPE SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I) + !***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING + !***AUTHOR Jones, R. E., (SNLA) + ! Wisniewski, J. A., (SNLA) + !***DESCRIPTION + ! + ! SSORT sorts array X and optionally makes the same interchanges in + ! array Y. The array X may be sorted in increasing order or + ! decreasing order. A slightly modified quicksort algorithm is used. + ! + ! Description of Parameters + ! X - array of values to be sorted (usually abscissas) + ! Y - array to be (optionally) carried along + ! N - number of values in array X to be sorted + ! KFLAG - control parameter + ! = 2 means sort X in increasing order and carry Y along. + ! = 1 means sort X in increasing order (ignoring Y) + ! = -1 means sort X in decreasing order (ignoring Y) + ! = -2 means sort X in decreasing order and carry Y along. + ! + !***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm + ! for sorting with minimal storage, Communications of + ! the ACM, 12, 3 (1969), pp. 185-187. + !***REVISION HISTORY (YYMMDD) + ! 761101 DATE WRITTEN + ! 761118 Modified to use the Singleton quicksort algorithm. (JAW) + ! 890531 Changed all specific intrinsics to generic. (WRB) + ! 890831 Modified array declarations. (WRB) + ! 891009 Removed unreferenced statement labels. (WRB) + ! 891024 Changed category. (WRB) + ! 891024 REVISION DATE from Version 3.2 + ! 891214 Prologue converted to Version 4.0 format. (BAB) + ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) + ! 901012 Declared all variables; changed X,Y to SX,SY. (M. McClain) + ! 920501 Reformatted the REFERENCES section. (DWL, WRB) + ! 920519 Clarified error messages. (DWL) + ! 920801 Declarations section rebuilt and code restructured to use + ! IF-THEN-ELSE-ENDIF. (RWC, WRB) + !***END PROLOGUE SSORT + ! .. Scalar Arguments .. + INTEGER KFLAG, N + ! .. Array Arguments .. + REAL*4 X(*), Y(*) + ! .. Local Scalars .. + REAL*4 R, T, TT, TTY, TY + INTEGER I, IJ, J, K, KK, L, M, NN + ! .. Local Arrays .. + INTEGER IL(21), IU(21) + ! .. External Subroutines .. + ! None + ! .. Intrinsic Functions .. + INTRINSIC ABS, INT + !***FIRST EXECUTABLE STATEMENT SSORT + NN = N + IF (NN .LT. 1) THEN + WRITE (*,*) 'The number of values to be sorted is not positive.' RETURN - END SUBROUTINE W3EQTOLL - -!Li -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / - SUBROUTINE W3THRTN ( NSEA, THETA, AnglD, Degrees ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NMC | -!/ | A. Saulter | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mar-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2018 : Added subroutine ( version 6.02 ) -! -! 1. Purpose : -! Subroutine to de-rotate directions from rotated to standard pole -! reference system -! -! 2. Method: -! Rotates x,y vectors anticlockwise by angle alpha in radians -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY : DERA, TPI, UNDEF - IMPLICIT NONE -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NSEA ! Number of sea points - REAL, INTENT(IN) :: AnglD(NSEA) ! Turning angle (degrees) - LOGICAL, INTENT(IN) :: Degrees ! Use degrees or radians - REAL, INTENT(INOUT) :: THETA(NSEA) ! Direction seapoint array -! -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISEA -! -!/ ------------------------------------------------------------------- / -! Apply the rotation -! - DO ISEA=1, NSEA - IF ( THETA(ISEA) .NE. UNDEF ) THEN - IF ( Degrees ) THEN - THETA(ISEA) = THETA(ISEA) - AnglD(ISEA) - IF ( THETA(ISEA) .LT. 0 ) THETA(ISEA) = THETA(ISEA) + 360.0 - ELSE - THETA(ISEA) = THETA(ISEA) - AnglD(ISEA)*DERA - IF ( THETA(ISEA) .LT. 0 ) THETA(ISEA) = THETA(ISEA) + TPI - END IF - ENDIF - END DO - - RETURN - END SUBROUTINE W3THRTN -! -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / - SUBROUTINE W3XYRTN ( NSEA, XVEC, YVEC, AnglD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NMC | -!/ | A. Saulter | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mar-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2018 : Added subroutine ( version 6.02 ) -! -! 1. Purpose : -! Subroutine to de-rotate x,y vectors from rotated to standard pole -! reference system -! -! 2. Method: -! Rotates x,y vectors anticlockwise by angle alpha in radians -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY : DERA, TPI, UNDEF - IMPLICIT NONE -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NSEA ! Number of sea points - REAL, INTENT(IN) :: AnglD(NSEA) ! Turning angle (degrees) - REAL, INTENT(INOUT) :: XVEC(NSEA), YVEC(NSEA) -! -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISEA - REAL :: XVTMP, YVTMP -! -!/ ------------------------------------------------------------------- / -! Apply the rotation -! - DO ISEA=1, NSEA - IF (( XVEC(ISEA) .NE. UNDEF ) .AND. & - ( YVEC(ISEA) .NE. UNDEF )) THEN - XVTMP = XVEC(ISEA)*COS(AnglD(ISEA)*DERA) + & - YVEC(ISEA)*SIN(AnglD(ISEA)*DERA) - YVTMP = YVEC(ISEA)*COS(AnglD(ISEA)*DERA) - & - XVEC(ISEA)*SIN(AnglD(ISEA)*DERA) - XVEC(ISEA) = XVTMP - YVEC(ISEA) = YVTMP - END IF - END DO - - RETURN - END SUBROUTINE W3XYRTN -! -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE STRSPLIT(STRING,TAB) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 29-Apr-2013 ! -!/ +-----------------------------------+ -!/ -!/ 29-Mar-2013 : Origination. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Splits string into words -! -! 2. Method : -! -! finds spaces and loops -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! STRING Str O String to be splitted -! TAB Str O Array of strings -! ---------------------------------------------------------------- -! - - IMPLICIT NONE - - - - CHARACTER(LEN=*), intent(IN) :: STRING - CHARACTER(LEN=100), intent(INOUT) :: TAB(*) - INTEGER :: cnt, I - CHARACTER(LEN=1024) :: tmp_str, ori_str - -! initializes arrays - ori_str=ADJUSTL(TRIM(STRING)) - tmp_str=ori_str - cnt=0 - -! counts the number of substrings - DO WHILE ((INDEX(tmp_str,' ').NE.0) .AND. (len_trim(tmp_str).NE.0)) - tmp_str=ADJUSTL(tmp_str(INDEX(tmp_str,' ')+1:)) - cnt=cnt+1 - ENDDO -! -! reinitializes arrays -! - tmp_str=ori_str -! loops on each substring - DO I=1,cnt - TAB(I)=tmp_str(:INDEX(tmp_str,' ')) - tmp_str=ADJUSTL(tmp_str(INDEX(tmp_str,' ')+1:)) - END DO - + ENDIF + ! + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN + WRITE (*,*) 'The sort control parameter, K, is not 2, 1, -1, or -2.' RETURN -!/ -!/ End of STRSPLIT ----------------------------------------------------- / -!/ - END SUBROUTINE STRSPLIT -!/ - -!/ ------------------------------------------------------------------- / - SUBROUTINE STR_TO_UPPER(STR) - character(*), intent(inout) :: str - integer :: i - - DO i = 1, len(str) - select case(str(i:i)) - case("a":"z") - str(i:i) = achar(iachar(str(i:i))-32) - end select - END DO -!/ End of STR_TO_UPPER -!/ ------------------------------------------------------------------- / -END SUBROUTINE STR_TO_UPPER - -!********************************************************************** -!* * -#ifdef W3_T -!********************************************************************** - SUBROUTINE SSORT1 (X, Y, N, KFLAG) -!***BEGIN PROLOGUE SSORT -!***PURPOSE Sort an array and optionally make the same interchanges in -! an auxiliary array. The array may be sorted in increasing -! or decreasing order. A slightly modified QUICKSORT -! algorithm is used. -!***LIBRARY SLATEC -!***CATEGORY N6A2B -!***TYPE SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I) -!***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -!***AUTHOR Jones, R. E., (SNLA) -! Wisniewski, J. A., (SNLA) -!***DESCRIPTION -! -! SSORT sorts array X and optionally makes the same interchanges in -! array Y. The array X may be sorted in increasing order or -! decreasing order. A slightly modified quicksort algorithm is used. -! -! Description of Parameters -! X - array of values to be sorted (usually abscissas) -! Y - array to be (optionally) carried along -! N - number of values in array X to be sorted -! KFLAG - control parameter -! = 2 means sort X in increasing order and carry Y along. -! = 1 means sort X in increasing order (ignoring Y) -! = -1 means sort X in decreasing order (ignoring Y) -! = -2 means sort X in decreasing order and carry Y along. -! -!***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -! for sorting with minimal storage, Communications of -! the ACM, 12, 3 (1969), pp. 185-187. -!***REVISION HISTORY (YYMMDD) -! 761101 DATE WRITTEN -! 761118 Modified to use the Singleton quicksort algorithm. (JAW) -! 890531 Changed all specific intrinsics to generic. (WRB) -! 890831 Modified array declarations. (WRB) -! 891009 Removed unreferenced statement labels. (WRB) -! 891024 Changed category. (WRB) -! 891024 REVISION DATE from Version 3.2 -! 891214 Prologue converted to Version 4.0 format. (BAB) -! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -! 901012 Declared all variables; changed X,Y to SX,SY. (M. McClain) -! 920501 Reformatted the REFERENCES section. (DWL, WRB) -! 920519 Clarified error messages. (DWL) -! 920801 Declarations section rebuilt and code restructured to use -! IF-THEN-ELSE-ENDIF. (RWC, WRB) -!***END PROLOGUE SSORT -! .. Scalar Arguments .. - INTEGER KFLAG, N -! .. Array Arguments .. - REAL*4 X(*), Y(*) -! .. Local Scalars .. - REAL*4 R, T, TT, TTY, TY - INTEGER I, IJ, J, K, KK, L, M, NN -! .. Local Arrays .. - INTEGER IL(21), IU(21) -! .. External Subroutines .. -! None -! .. Intrinsic Functions .. - INTRINSIC ABS, INT -!***FIRST EXECUTABLE STATEMENT SSORT - NN = N - IF (NN .LT. 1) THEN - WRITE (*,*) 'The number of values to be sorted is not positive.' - RETURN - ENDIF -! - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN - WRITE (*,*) 'The sort control parameter, K, is not 2, 1, -1, or -2.' - RETURN - ENDIF -! -! Alter array X to get decreasing order if needed -! - IF (KFLAG .LE. -1) THEN - DO I=1,NN - X(I) = -X(I) - end do - ENDIF -! - IF (KK .EQ. 2) GO TO 100 -! -! Sort X only -! - M = 1 - I = 1 - J = NN - R = 0.375E0 -! - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -! - 30 K = I -! -! Select a central element of the array and save it in location T -! - IJ = I + INT((J-I)*R) + ENDIF + ! + ! Alter array X to get decreasing order if needed + ! + IF (KFLAG .LE. -1) THEN + DO I=1,NN + X(I) = -X(I) + end do + ENDIF + ! + IF (KK .EQ. 2) GO TO 100 + ! + ! Sort X only + ! + M = 1 + I = 1 + J = NN + R = 0.375E0 + ! +20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF + ! +30 K = I + ! + ! Select a central element of the array and save it in location T + ! + IJ = I + INT((J-I)*R) + T = X(IJ) + ! + ! If first element of array is greater than T, interchange with T + ! + IF (X(I) .GT. T) THEN + X(IJ) = X(I) + X(I) = T T = X(IJ) -! -! If first element of array is greater than T, interchange with T -! + ENDIF + L = J + ! + ! If last element of array is less than than T, interchange with T + ! + IF (X(J) .LT. T) THEN + X(IJ) = X(J) + X(J) = T + T = X(IJ) + ! + ! If first element of array is greater than T, interchange with T + ! IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - ENDIF - L = J -! -! If last element of array is less than than T, interchange with T -! - IF (X(J) .LT. T) THEN - X(IJ) = X(J) - X(J) = T - T = X(IJ) -! -! If first element of array is greater than T, interchange with T -! - IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - ENDIF - ENDIF -! -! Find an element in the second half of the array which is smaller -! than T -! - 40 L = L-1 - IF (X(L) .GT. T) GO TO 40 -! -! Find an element in the first half of the array which is greater -! than T -! - 50 K = K+1 - IF (X(K) .LT. T) GO TO 50 -! -! Interchange these elements -! - IF (K .LE. L) THEN - TT = X(L) - X(L) = X(K) - X(K) = TT - GO TO 40 + X(IJ) = X(I) + X(I) = T + T = X(IJ) ENDIF -! -! Save upper and lower subscripts of the array yet to be sorted -! - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -! -! Begin again on another portion of the unsorted array -! - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -! - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -! - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = X(I+1) - IF (X(I) .LE. T) GO TO 80 - K = I -! - 90 X(K+1) = X(K) - K = K-1 - IF (T .LT. X(K)) GO TO 90 - X(K+1) = T - GO TO 80 -! -! Sort X and carry Y along -! - 100 M = 1 - I = 1 - J = NN - R = 0.375E0 -! - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -! - 120 K = I -! -! Select a central element of the array and save it in location T -! - IJ = I + INT((J-I)*R) + ENDIF + ! + ! Find an element in the second half of the array which is smaller + ! than T + ! +40 L = L-1 + IF (X(L) .GT. T) GO TO 40 + ! + ! Find an element in the first half of the array which is greater + ! than T + ! +50 K = K+1 + IF (X(K) .LT. T) GO TO 50 + ! + ! Interchange these elements + ! + IF (K .LE. L) THEN + TT = X(L) + X(L) = X(K) + X(K) = TT + GO TO 40 + ENDIF + ! + ! Save upper and lower subscripts of the array yet to be sorted + ! + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 + ! + ! Begin again on another portion of the unsorted array + ! +60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) + ! +70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 + ! +80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = X(I+1) + IF (X(I) .LE. T) GO TO 80 + K = I + ! +90 X(K+1) = X(K) + K = K-1 + IF (T .LT. X(K)) GO TO 90 + X(K+1) = T + GO TO 80 + ! + ! Sort X and carry Y along + ! +100 M = 1 + I = 1 + J = NN + R = 0.375E0 + ! +110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF + ! +120 K = I + ! + ! Select a central element of the array and save it in location T + ! + IJ = I + INT((J-I)*R) + T = X(IJ) + TY = Y(IJ) + ! + ! If first element of array is greater than T, interchange with T + ! + IF (X(I) .GT. T) THEN + X(IJ) = X(I) + X(I) = T + T = X(IJ) + Y(IJ) = Y(I) + Y(I) = TY + TY = Y(IJ) + ENDIF + L = J + ! + ! If last element of array is less than T, interchange with T + ! + IF (X(J) .LT. T) THEN + X(IJ) = X(J) + X(J) = T T = X(IJ) + Y(IJ) = Y(J) + Y(J) = TY TY = Y(IJ) -! -! If first element of array is greater than T, interchange with T -! + ! + ! If first element of array is greater than T, interchange with T + ! IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - Y(IJ) = Y(I) - Y(I) = TY - TY = Y(IJ) - ENDIF - L = J -! -! If last element of array is less than T, interchange with T -! - IF (X(J) .LT. T) THEN - X(IJ) = X(J) - X(J) = T - T = X(IJ) - Y(IJ) = Y(J) - Y(J) = TY - TY = Y(IJ) -! -! If first element of array is greater than T, interchange with T -! - IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - Y(IJ) = Y(I) - Y(I) = TY - TY = Y(IJ) - ENDIF - ENDIF -! -! Find an element in the second half of the array which is smaller -! than T -! - 130 L = L-1 - IF (X(L) .GT. T) GO TO 130 -! -! Find an element in the first half of the array which is greater -! than T -! - 140 K = K+1 - IF (X(K) .LT. T) GO TO 140 -! -! Interchange these elements -! - IF (K .LE. L) THEN - TT = X(L) - X(L) = X(K) - X(K) = TT - TTY = Y(L) - Y(L) = Y(K) - Y(K) = TTY - GO TO 130 - ENDIF -! -! Save upper and lower subscripts of the array yet to be sorted -! - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -! -! Begin again on another portion of the unsorted array -! - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -! - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -! - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = X(I+1) - TY = Y(I+1) - IF (X(I) .LE. T) GO TO 170 - K = I -! - 180 X(K+1) = X(K) - Y(K+1) = Y(K) - K = K-1 - IF (T .LT. X(K)) GO TO 180 - X(K+1) = T - Y(K+1) = TY - GO TO 170 -! -! Clean up -! - 190 IF (KFLAG .LE. -1) THEN - DO I=1,NN - X(I) = -X(I) - end do + X(IJ) = X(I) + X(I) = T + T = X(IJ) + Y(IJ) = Y(I) + Y(I) = TY + TY = Y(IJ) ENDIF - RETURN - END SUBROUTINE SSORT1 + ENDIF + ! + ! Find an element in the second half of the array which is smaller + ! than T + ! +130 L = L-1 + IF (X(L) .GT. T) GO TO 130 + ! + ! Find an element in the first half of the array which is greater + ! than T + ! +140 K = K+1 + IF (X(K) .LT. T) GO TO 140 + ! + ! Interchange these elements + ! + IF (K .LE. L) THEN + TT = X(L) + X(L) = X(K) + X(K) = TT + TTY = Y(L) + Y(L) = Y(K) + Y(K) = TTY + GO TO 130 + ENDIF + ! + ! Save upper and lower subscripts of the array yet to be sorted + ! + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 + ! + ! Begin again on another portion of the unsorted array + ! +150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) + ! +160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 + ! +170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = X(I+1) + TY = Y(I+1) + IF (X(I) .LE. T) GO TO 170 + K = I + ! +180 X(K+1) = X(K) + Y(K+1) = Y(K) + K = K-1 + IF (T .LT. X(K)) GO TO 180 + X(K+1) = T + Y(K+1) = TY + GO TO 170 + ! + ! Clean up + ! +190 IF (KFLAG .LE. -1) THEN + DO I=1,NN + X(I) = -X(I) + end do + ENDIF + RETURN + END SUBROUTINE SSORT1 #endif -!********************************************************************* - SUBROUTINE DIAGONALIZE(a1,d,v,nrot) -!********************************************************************* - IMPLICIT NONE - INTEGER, INTENT(out) :: nrot - DOUBLE PRECISION, DIMENSION(:) , INTENT(OUT) ::d - DOUBLE PRECISION, DIMENSION(:,:), INTENT(IN) ::a1 ! Modified from INOUT to IN by F.A. on 2018/01/21 - DOUBLE PRECISION, DIMENSION(:,:), INTENT(OUT) ::v - - INTEGER i,j,ip,iq,n - DOUBLE PRECISION c,g,h,s,sm,t,tau,theta,tresh - DOUBLE PRECISION , DIMENSION(size(d)) ::b,z - DOUBLE PRECISION, DIMENSION(size(d),size(d)) :: a - LOGICAL, DIMENSION(size(d),size(d)) :: upper_triangle - - a=a1 - n=size(d) - v(:,:)=0. - upper_triangle(:,:)=.FALSE. - DO I=1,n + !********************************************************************* + SUBROUTINE DIAGONALIZE(a1,d,v,nrot) + !********************************************************************* + IMPLICIT NONE + INTEGER, INTENT(out) :: nrot + DOUBLE PRECISION, DIMENSION(:) , INTENT(OUT) ::d + DOUBLE PRECISION, DIMENSION(:,:), INTENT(IN) ::a1 ! Modified from INOUT to IN by F.A. on 2018/01/21 + DOUBLE PRECISION, DIMENSION(:,:), INTENT(OUT) ::v + + INTEGER i,j,ip,iq,n + DOUBLE PRECISION c,g,h,s,sm,t,tau,theta,tresh + DOUBLE PRECISION , DIMENSION(size(d)) ::b,z + DOUBLE PRECISION, DIMENSION(size(d),size(d)) :: a + LOGICAL, DIMENSION(size(d),size(d)) :: upper_triangle + + a=a1 + n=size(d) + v(:,:)=0. + upper_triangle(:,:)=.FALSE. + DO I=1,n v(I,I)=1. b(I)=a(I,I) DO J=I+1,n - upper_triangle(I,J)=.TRUE. + upper_triangle(I,J)=.TRUE. ENDDO - ENDDO - d(:)=b(:) - z(:)=0.0 - nrot=0 - DO I=1,50 + ENDDO + d(:)=b(:) + z(:)=0.0 + nrot=0 + DO I=1,50 sm=SUM(ABS(a),mask=upper_triangle) IF (sm.EQ.0.0) RETURN tresh=merge(0.2*sm/n**2,0.0D0,i<4) DO ip=1,n-1 - do iq=ip+1,n - g=100.0*abs(a(ip,iq)) - IF((i > 4).AND.(ABS(d(ip))+g.EQ.abs(d(ip))) & + do iq=ip+1,n + g=100.0*abs(a(ip,iq)) + IF((i > 4).AND.(ABS(d(ip))+g.EQ.abs(d(ip))) & .AND.(ABS(d(iq))+g.EQ.abs(d(iq)))) THEN - a(ip,iq)=0.0 - ELSE IF (abs(a(ip,iq)) > tresh) THEN - h=d(iq)-d(ip) - if (abs(h)+g == abs(h)) THEN - t=a(ip,iq)/h - ELSE - theta=0.5*h/a(ip,iq) - t=1.0/(abs(theta)+sqrt(1.0+theta**2)) - IF ( theta < 0.0) t=-t - ENDIF - c=1.0/sqrt(1+t**2) - s=t*c - tau=s/(1.0+c) - h=t*a(ip,iq) - z(ip)=z(ip)-h - z(iq)=z(iq)+h - d(ip)=d(ip)-h - d(iq)=d(iq)+h - a(ip,iq)=0.0 - IF (ip.GE.1) CALL ROTATE(a(1:ip-1,ip),a(1:ip-1,iq)) -!The IF test was added by F.A. (2005/04/04) because of the following error: -!Subscript out of range. Location: line 593 column 36 of 'cb_botsc.f90' -!Subscript number 1 has value 0 in array 'A' - CALL ROTATE(a(ip,ip+1:iq-1),a(ip+1:iq-1,iq)) - CALL ROTATE(a(ip,iq+1:n),a(iq,iq+1:n)) - CALL ROTATE(v(:,ip),v(:,iq)) - nrot=nrot+1 + a(ip,iq)=0.0 + ELSE IF (abs(a(ip,iq)) > tresh) THEN + h=d(iq)-d(ip) + if (abs(h)+g == abs(h)) THEN + t=a(ip,iq)/h + ELSE + theta=0.5*h/a(ip,iq) + t=1.0/(abs(theta)+sqrt(1.0+theta**2)) + IF ( theta < 0.0) t=-t ENDIF - ENDDO + c=1.0/sqrt(1+t**2) + s=t*c + tau=s/(1.0+c) + h=t*a(ip,iq) + z(ip)=z(ip)-h + z(iq)=z(iq)+h + d(ip)=d(ip)-h + d(iq)=d(iq)+h + a(ip,iq)=0.0 + IF (ip.GE.1) CALL ROTATE(a(1:ip-1,ip),a(1:ip-1,iq)) + !The IF test was added by F.A. (2005/04/04) because of the following error: + !Subscript out of range. Location: line 593 column 36 of 'cb_botsc.f90' + !Subscript number 1 has value 0 in array 'A' + CALL ROTATE(a(ip,ip+1:iq-1),a(ip+1:iq-1,iq)) + CALL ROTATE(a(ip,iq+1:n),a(iq,iq+1:n)) + CALL ROTATE(v(:,ip),v(:,iq)) + nrot=nrot+1 + ENDIF + ENDDO ENDDO b(:)=b(:)+z(:) d(:)=b(:) z(:)=0.0 - ENDDO - WRITE(6,*) 'Too many iterations in DIAGONALIZE' - CONTAINS - SUBROUTINE ROTATE(X1,X2) - DOUBLE PRECISION, DIMENSION(:), INTENT(INOUT) :: X1,X2 - DOUBLE PRECISION, DIMENSION(size(X1)) :: MEM - MEM(:)=X1(:) - X1(:)=X1(:)-s*(X2(:)+X1(:)*tau) - X2(:)=X2(:)+s*(MEM(:)-X2(:)*tau) - END SUBROUTINE ROTATE - END SUBROUTINE DIAGONALIZE - -!/ ------------------------------------------------------------------- / - SUBROUTINE UV_TO_MAG_DIR(U, V, NSEA, MAG, DIR, TOLERANCE, CONV) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | FORTRAN 90 | -!/ | Last update : 15-Jan-2021 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-2021 : Creation ( version 7.12 ) -!/ -! 1. Purpose : -! -! Converts seapoint arrays formulated as U/V vectors into magnitude -! and direction arrays. -! -! If MAG and DIR input parameters are not specificed then the -! conversion is performed in-place (U => MAG, v => DIR). -! -! 2. Parameters -! -! Parameter list -! ---------------------------------------------------------------- -! U/V R.Arr I Array of U/V components -! NSEA Int I Number of sea points -! MAG R.Arr O Magnitude array (Optional) -! DIR R.Arr O Direction array (degrees) (Optional) -! TOLERANCE Real I Minimum allowed magnitude (Optional) -! CONV Char I Ouput direciton convention (Optional) -! ---------------------------------------------------------------- -! -! 3. Remarks -! -! Optional CONV specifies direction convention. Must be one of: -! 'N'=Nautical : North=0, clockwise, direction-from (default) -! 'O'=Oceangraphic : North=0, clockwise, direction-to -! 'C'=Cartesian : North=90, counter-clockwise, direction-to -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: RADE, UNDEF - IMPLICIT NONE - - REAL, INTENT(INOUT) :: U(NSEA), V(NSEA) - INTEGER, INTENT(IN) :: NSEA - REAL, INTENT(OUT), OPTIONAL :: MAG(NSEA), DIR(NSEA) - REAL, INTENT(IN), OPTIONAL :: TOLERANCE - CHARACTER, INTENT(IN), OPTIONAL :: CONV -!/ ------------------------------------------------------------------- / -!/ Local parameters -! - REAL :: TOL, SGN, OFFSET, TMP - CHARACTER :: DIRCONV - INTEGER :: ISEA - LOGICAL :: INPLACE - - DIRCONV = 'N' - TOL = 1.0 - INPLACE = .TRUE. - IF(PRESENT(TOLERANCE)) TOL = TOLERANCE - IF(PRESENT(CONV)) DIRCONV = CONV - IF(PRESENT(MAG) .AND. PRESENT(DIR)) INPLACE = .FALSE. - - SELECT CASE (CONV) - CASE('N') - OFFSET = 630. - SGN = -1. - CASE('O') - OFFSET = 450. - SGN = -1. - CASE('C') - OFFSET = 360. - SGN = 1. - CASE DEFAULT - WRITE(*,*) "UV_TO_MAG_DIR: UNKNOWN DIR CONVENTION: ", DIRCONV - CALL EXTCDE(1) - END SELECT - - IF(INPLACE) THEN - DO ISEA=1, NSEA - TMP = SQRT(U(ISEA)**2 + V(ISEA)**2) - IF(TMP .GE. TOL) THEN - V(ISEA) = MOD(OFFSET + (SGN * RADE * ATAN2(V(ISEA), U(ISEA))), 360.) - U(ISEA) = TMP - ELSE - U(ISEA) = UNDEF - V(ISEA) = UNDEF - END IF - END DO - ELSE - DO ISEA=1, NSEA - MAG(ISEA) = SQRT(U(ISEA)**2 + V(ISEA)**2) - IF(MAG(ISEA) .GE. TOL) THEN - DIR(ISEA) = MOD(OFFSET + (SGN * RADE * ATAN2(V(ISEA), U(ISEA))), 360.) - ELSE - MAG(ISEA) = UNDEF - DIR(ISEA) = UNDEF - END IF - END DO - ENDIF + ENDDO + WRITE(6,*) 'Too many iterations in DIAGONALIZE' + CONTAINS + SUBROUTINE ROTATE(X1,X2) + DOUBLE PRECISION, DIMENSION(:), INTENT(INOUT) :: X1,X2 + DOUBLE PRECISION, DIMENSION(size(X1)) :: MEM + MEM(:)=X1(:) + X1(:)=X1(:)-s*(X2(:)+X1(:)*tau) + X2(:)=X2(:)+s*(MEM(:)-X2(:)*tau) + END SUBROUTINE ROTATE + END SUBROUTINE DIAGONALIZE + + !/ ------------------------------------------------------------------- / + SUBROUTINE UV_TO_MAG_DIR(U, V, NSEA, MAG, DIR, TOLERANCE, CONV) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | FORTRAN 90 | + !/ | Last update : 15-Jan-2021 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-2021 : Creation ( version 7.12 ) + !/ + ! 1. Purpose : + ! + ! Converts seapoint arrays formulated as U/V vectors into magnitude + ! and direction arrays. + ! + ! If MAG and DIR input parameters are not specificed then the + ! conversion is performed in-place (U => MAG, v => DIR). + ! + ! 2. Parameters + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! U/V R.Arr I Array of U/V components + ! NSEA Int I Number of sea points + ! MAG R.Arr O Magnitude array (Optional) + ! DIR R.Arr O Direction array (degrees) (Optional) + ! TOLERANCE Real I Minimum allowed magnitude (Optional) + ! CONV Char I Ouput direciton convention (Optional) + ! ---------------------------------------------------------------- + ! + ! 3. Remarks + ! + ! Optional CONV specifies direction convention. Must be one of: + ! 'N'=Nautical : North=0, clockwise, direction-from (default) + ! 'O'=Oceangraphic : North=0, clockwise, direction-to + ! 'C'=Cartesian : North=90, counter-clockwise, direction-to + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: RADE, UNDEF + IMPLICIT NONE + + REAL, INTENT(INOUT) :: U(NSEA), V(NSEA) + INTEGER, INTENT(IN) :: NSEA + REAL, INTENT(OUT), OPTIONAL :: MAG(NSEA), DIR(NSEA) + REAL, INTENT(IN), OPTIONAL :: TOLERANCE + CHARACTER, INTENT(IN), OPTIONAL :: CONV + !/ ------------------------------------------------------------------- / + !/ Local parameters + ! + REAL :: TOL, SGN, OFFSET, TMP + CHARACTER :: DIRCONV + INTEGER :: ISEA + LOGICAL :: INPLACE + + DIRCONV = 'N' + TOL = 1.0 + INPLACE = .TRUE. + IF(PRESENT(TOLERANCE)) TOL = TOLERANCE + IF(PRESENT(CONV)) DIRCONV = CONV + IF(PRESENT(MAG) .AND. PRESENT(DIR)) INPLACE = .FALSE. + + SELECT CASE (CONV) + CASE('N') + OFFSET = 630. + SGN = -1. + CASE('O') + OFFSET = 450. + SGN = -1. + CASE('C') + OFFSET = 360. + SGN = 1. + CASE DEFAULT + WRITE(*,*) "UV_TO_MAG_DIR: UNKNOWN DIR CONVENTION: ", DIRCONV + CALL EXTCDE(1) + END SELECT + + IF(INPLACE) THEN + DO ISEA=1, NSEA + TMP = SQRT(U(ISEA)**2 + V(ISEA)**2) + IF(TMP .GE. TOL) THEN + V(ISEA) = MOD(OFFSET + (SGN * RADE * ATAN2(V(ISEA), U(ISEA))), 360.) + U(ISEA) = TMP + ELSE + U(ISEA) = UNDEF + V(ISEA) = UNDEF + END IF + END DO + ELSE + DO ISEA=1, NSEA + MAG(ISEA) = SQRT(U(ISEA)**2 + V(ISEA)**2) + IF(MAG(ISEA) .GE. TOL) THEN + DIR(ISEA) = MOD(OFFSET + (SGN * RADE * ATAN2(V(ISEA), U(ISEA))), 360.) + ELSE + MAG(ISEA) = UNDEF + DIR(ISEA) = UNDEF + END IF + END DO + ENDIF - END SUBROUTINE UV_TO_MAG_DIR -!/ -!/ End of module W3SERVMD -------------------------------------------- / -!/ - END MODULE W3SERVMD + END SUBROUTINE UV_TO_MAG_DIR + !/ + !/ End of module W3SERVMD -------------------------------------------- / + !/ +END MODULE W3SERVMD diff --git a/model/src/w3sic1md.F90 b/model/src/w3sic1md.F90 index 5985aa6db..16f7b1693 100644 --- a/model/src/w3sic1md.F90 +++ b/model/src/w3sic1md.F90 @@ -1,341 +1,338 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SIC1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 11-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ For updates see W3SIC1 documentation. -!/ -! 1. Purpose : -! -! Calculate ice source term S_{ice} according to simple methods. -! Exponential decay rate is uniform in frequency, and -! specified directly by the user. This method is, in effect, -! not sustantially different from handling sea ice via the -! "sub-grid" blocking approach, after improvements by -! Fabrice Ardhuin (in v4.00). -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SIC1 Subr. Public ice source term. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! Reference:Rogers, W.E. and M.D. Orzech, 2013: Implementation and -! Testing of Ice and Mud Source Functions in WAVEWATCH III(R), -! NRL/MR/7320--13-9462, 31pp. -! available from http://www7320.nrlssc.navy.mil/pubs.php -! Direct link: -! http://www7320.nrlssc.navy.mil/pubs/2013/rogers2-2013.pdf -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC :: W3SIC1 -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SIC1 (A, DEPTH, CG, IX, IY, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 11-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 16-Oct-2012 : Origination. ( version 4.04 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : W3SIC1 SUBTYPE=2 outsourced to W3SIC2 (S. Zieger) -!/ -!/ FIXME : Move field input to W3SRCE and provide -!/ (S.Zieger) input parameter to W3SIC1 to make the subroutine -!/ : versatile for point output processors ww3_outp -!/ and ww3_ounp. -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! S_{ice} source term using 5 parameters read from input files. -! These parameters are allowed to vary in space and time. -! The parameters control the exponential decay rate k_i -! Since there are 5 parameters, this permits description of -! dependence of k_i on frequency or wavenumber. -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! -! Regarding i/o (general to all Sice modules): S_{ice} source term -! is calculated using up to 5 parameters read from input files. -! These parameters are allowed to vary in space and time. -! The parameters control the exponential decay rate k_i -! Since there are 5 parameters, this permits description of -! dependence of k_i on frequency or wavenumber. -! -! Sea ice affects the wavenumber k of wind-generated ocean waves. -! The ice-modified wavenumber can be expressed as a complex number -! k = k_r + i*k_i, with the real part k_r representing impact of -! the sea ice on the physical wavelength and propagation speeds, -! producing something analogous to shoaling and refraction by -! bathymetry, whereas the imaginary part of the complex -! wavenumber, k_i, is an exponential decay coefficient -! k_i(x,y,t,sigma) (depending on location, time and frequency, -! respectively), representing wave attenuation, and can be -! introduced in a wave model such as WW3 as S_ice/E=-2*Cg*k_i, -! where S_ice is one of several dissipation mechanisms, along -! with whitecapping, for example, S_ds=S_wc+S_ice+⋯. The k_r - -! modified by ice would enter the model via the C calculations -! on the left-hand side of the governing equation.The fundamentals -! are straightforward, e.g. Rogers and Holland (2009 and -! subsequent unpublished work) modified a similar model, SWAN -! (Booij et al. 1999) to include the effects of a viscous mud -! layer using the same approach (k = k_r + i*k_i) previously. -! -! General approach is analogous to Rogers and Holland (2009) -! approach for mud. -! See text near their eq. 1 : -! k = k_r + i * k_i -! eta(x,t) = Real( a * exp( i * ( k * x - sigma * t ) ) ) -! a = a0 * exp( -k_i * x ) -! S / E = -2 * Cg * k_i (see also Komen et al. (1994, pg. 170) -! -! Following W3SBT1 as a guide, equation 1 of W3SBT1 says: -! S = D * E -! However, the code of W3SBT1 has -! S = D * A -! This leads me to believe that the calling routine is -! expecting "S/sigma" not "S" -! Thus we will use D = S/E = -2 * Cg * k_i -! -! Notes regarding numerics: -! Experiments with constant k_i values suggest that : -! for dx=20.0 km, k_i should not exceed 3.5e-6 -! (assumes 2.7% Hs error in my particular test case is intolerable) -! for dx=5.0 km, k_i should not exceed 2.0e-5 -! for dx=2.5 km, k_i should not exceed 5.0e-5 -! for dx=1.0 km, k_i should not exceed 2.0e-4 -! for dx=0.35 km, error is less than 2.1% for all k_i tested -! for dx=0.10 km, error is less than 1.3% for all k_i tested -! "Ground truth" used for this is an exponential decay profile. -! -! For reference, ACNFS is 1/12th deg, so delta_latitude=9.25 km. -! -! {put more equations here} -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! DEPTH Real I Local water depth -! CG R.A. I Group velocities. -! IX,IY I.S. I Grid indices. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). -! PRT2DS Subr. W3ARRYMD Print plot output (!/T1 switch). -! OUTMAT Subr. W3ARRYMD Matrix output (!/T2 switch). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A ASCII Point output post-processor. -! W3EXNC Subr. N/A NetCDF Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! If ice parameter 1 is zero, no calculations are made. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPI - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN - USE W3IDATMD, ONLY: ICEP1, ICEP2, ICEP3, ICEP4, ICEP5, INFLAGS2 +MODULE W3SIC1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 11-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ For updates see W3SIC1 documentation. + !/ + ! 1. Purpose : + ! + ! Calculate ice source term S_{ice} according to simple methods. + ! Exponential decay rate is uniform in frequency, and + ! specified directly by the user. This method is, in effect, + ! not sustantially different from handling sea ice via the + ! "sub-grid" blocking approach, after improvements by + ! Fabrice Ardhuin (in v4.00). + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SIC1 Subr. Public ice source term. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! Reference:Rogers, W.E. and M.D. Orzech, 2013: Implementation and + ! Testing of Ice and Mud Source Functions in WAVEWATCH III(R), + ! NRL/MR/7320--13-9462, 31pp. + ! available from http://www7320.nrlssc.navy.mil/pubs.php + ! Direct link: + ! http://www7320.nrlssc.navy.mil/pubs/2013/rogers2-2013.pdf + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC :: W3SIC1 + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SIC1 (A, DEPTH, CG, IX, IY, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 11-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 16-Oct-2012 : Origination. ( version 4.04 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : W3SIC1 SUBTYPE=2 outsourced to W3SIC2 (S. Zieger) + !/ + !/ FIXME : Move field input to W3SRCE and provide + !/ (S.Zieger) input parameter to W3SIC1 to make the subroutine + !/ : versatile for point output processors ww3_outp + !/ and ww3_ounp. + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! S_{ice} source term using 5 parameters read from input files. + ! These parameters are allowed to vary in space and time. + ! The parameters control the exponential decay rate k_i + ! Since there are 5 parameters, this permits description of + ! dependence of k_i on frequency or wavenumber. + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! + ! Regarding i/o (general to all Sice modules): S_{ice} source term + ! is calculated using up to 5 parameters read from input files. + ! These parameters are allowed to vary in space and time. + ! The parameters control the exponential decay rate k_i + ! Since there are 5 parameters, this permits description of + ! dependence of k_i on frequency or wavenumber. + ! + ! Sea ice affects the wavenumber k of wind-generated ocean waves. + ! The ice-modified wavenumber can be expressed as a complex number + ! k = k_r + i*k_i, with the real part k_r representing impact of + ! the sea ice on the physical wavelength and propagation speeds, + ! producing something analogous to shoaling and refraction by + ! bathymetry, whereas the imaginary part of the complex + ! wavenumber, k_i, is an exponential decay coefficient + ! k_i(x,y,t,sigma) (depending on location, time and frequency, + ! respectively), representing wave attenuation, and can be + ! introduced in a wave model such as WW3 as S_ice/E=-2*Cg*k_i, + ! where S_ice is one of several dissipation mechanisms, along + ! with whitecapping, for example, S_ds=S_wc+S_ice+⋯. The k_r - + ! modified by ice would enter the model via the C calculations + ! on the left-hand side of the governing equation.The fundamentals + ! are straightforward, e.g. Rogers and Holland (2009 and + ! subsequent unpublished work) modified a similar model, SWAN + ! (Booij et al. 1999) to include the effects of a viscous mud + ! layer using the same approach (k = k_r + i*k_i) previously. + ! + ! General approach is analogous to Rogers and Holland (2009) + ! approach for mud. + ! See text near their eq. 1 : + ! k = k_r + i * k_i + ! eta(x,t) = Real( a * exp( i * ( k * x - sigma * t ) ) ) + ! a = a0 * exp( -k_i * x ) + ! S / E = -2 * Cg * k_i (see also Komen et al. (1994, pg. 170) + ! + ! Following W3SBT1 as a guide, equation 1 of W3SBT1 says: + ! S = D * E + ! However, the code of W3SBT1 has + ! S = D * A + ! This leads me to believe that the calling routine is + ! expecting "S/sigma" not "S" + ! Thus we will use D = S/E = -2 * Cg * k_i + ! + ! Notes regarding numerics: + ! Experiments with constant k_i values suggest that : + ! for dx=20.0 km, k_i should not exceed 3.5e-6 + ! (assumes 2.7% Hs error in my particular test case is intolerable) + ! for dx=5.0 km, k_i should not exceed 2.0e-5 + ! for dx=2.5 km, k_i should not exceed 5.0e-5 + ! for dx=1.0 km, k_i should not exceed 2.0e-4 + ! for dx=0.35 km, error is less than 2.1% for all k_i tested + ! for dx=0.10 km, error is less than 1.3% for all k_i tested + ! "Ground truth" used for this is an exponential decay profile. + ! + ! For reference, ACNFS is 1/12th deg, so delta_latitude=9.25 km. + ! + ! {put more equations here} + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! DEPTH Real I Local water depth + ! CG R.A. I Group velocities. + ! IX,IY I.S. I Grid indices. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). + ! PRT2DS Subr. W3ARRYMD Print plot output (!/T1 switch). + ! OUTMAT Subr. W3ARRYMD Matrix output (!/T2 switch). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A ASCII Point output post-processor. + ! W3EXNC Subr. N/A NetCDF Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! If ice parameter 1 is zero, no calculations are made. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPI + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN + USE W3IDATMD, ONLY: ICEP1, ICEP2, ICEP3, ICEP4, ICEP5, INFLAGS2 #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: CG(NK), A(NSPEC), DEPTH - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) - INTEGER, INTENT(IN) :: IX, IY -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: CG(NK), A(NSPEC), DEPTH + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + INTEGER, INTENT(IN) :: IX, IY + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T0 - INTEGER :: ITH - REAL :: DOUT(NK,NTH) + INTEGER :: ITH + REAL :: DOUT(NK,NTH) #endif - INTEGER :: IKTH, IK - REAL :: D1D(NK) !In SBT1: D1D was named "CBETA" - REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & - ICECOEF4, ICECOEF5 - REAL, ALLOCATABLE :: WN_I(:) ! exponential decay rate for amplitude -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: IKTH, IK + REAL :: D1D(NK) !In SBT1: D1D was named "CBETA" + REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & + ICECOEF4, ICECOEF5 + REAL, ALLOCATABLE :: WN_I(:) ! exponential decay rate for amplitude + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIC1') + CALL STRACE (IENT, 'W3SIC1') #endif -! -! 0. Initializations ------------------------------------------------ * -! - D = 0.0 -! - ALLOCATE(WN_I(NK)) - WN_I = 0.0 - ICECOEF1 = 0.0 - ICECOEF2 = 0.0 - ICECOEF3 = 0.0 - ICECOEF4 = 0.0 - ICECOEF5 = 0.0 -! - IF (.NOT.INFLAGS2(-7))THEN - WRITE (NDSE,1001) 'ICE PARAMETER 1' - CALL EXTCDE(2) - ENDIF -! - ICECOEF1 = ICEP1(IX,IY) + ! + ! 0. Initializations ------------------------------------------------ * + ! + D = 0.0 + ! + ALLOCATE(WN_I(NK)) + WN_I = 0.0 + ICECOEF1 = 0.0 + ICECOEF2 = 0.0 + ICECOEF3 = 0.0 + ICECOEF4 = 0.0 + ICECOEF5 = 0.0 + ! + IF (.NOT.INFLAGS2(-7))THEN + WRITE (NDSE,1001) 'ICE PARAMETER 1' + CALL EXTCDE(2) + ENDIF + ! + ICECOEF1 = ICEP1(IX,IY) -! -! 1. No ice --------------------------------------------------------- / -! - IF ( ICECOEF1==0. ) THEN - D = 0. -! -! 2. Ice ------------------------------------------------------------ / - ELSE -! -! 2.a Set constant(s) and write test output -------------------------- / -! -! (none) -! + ! + ! 1. No ice --------------------------------------------------------- / + ! + IF ( ICECOEF1==0. ) THEN + D = 0. + ! + ! 2. Ice ------------------------------------------------------------ / + ELSE + ! + ! 2.a Set constant(s) and write test output -------------------------- / + ! + ! (none) + ! #ifdef W3_T38 - WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 + WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 #endif -! -! 2.b Make calculations ---------------------------------------------- / - WN_I = ICECOEF1 ! uniform in k + ! + ! 2.b Make calculations ---------------------------------------------- / + WN_I = ICECOEF1 ! uniform in k - DO IK=1, NK -! SBT1 has: D1D(IK) = FACTOR * MAX(0., (CG(IK)*WN(IK)/SIG(IK)-0.5) ) -! recall that D=S/E=-2*Cg*k_i - D1D(IK) = -2. * CG(IK) * WN_I(IK) - END DO -! -! 2.c Fill diagional matrix -! - DO IKTH=1, NSPEC - D(IKTH) = D1D(MAPWN(IKTH)) - END DO -! - END IF -! - S = D * A -! -! ... Test output of arrays -! -#ifdef W3_T0 DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO -#endif -! + ! SBT1 has: D1D(IK) = FACTOR * MAX(0., (CG(IK)*WN(IK)/SIG(IK)-0.5) ) + ! recall that D=S/E=-2*Cg*k_i + D1D(IK) = -2. * CG(IK) * WN_I(IK) + END DO + ! + ! 2.c Fill diagional matrix + ! + DO IKTH=1, NSPEC + D(IKTH) = D1D(MAPWN(IKTH)) + END DO + ! + END IF + ! + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') #endif -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC1 : '/ & - ' ',A,' REQUIRED BUT NOT SELECTED'/) -! + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC1 : '/ & + ' ',A,' REQUIRED BUT NOT SELECTED'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SIC1 : DEPTH,ICECOEF1 : ',2E10.3) +9000 FORMAT (' TEST W3SIC1 : DEPTH,ICECOEF1 : ',2E10.3) #endif -!/ -!/ End of W3SIC1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SIC1 -!/ -!/ End of module W3SIC1MD -------------------------------------------- / -!/ - END MODULE W3SIC1MD + !/ + !/ End of W3SIC1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SIC1 + !/ + !/ End of module W3SIC1MD -------------------------------------------- / + !/ +END MODULE W3SIC1MD diff --git a/model/src/w3sic2md.F90 b/model/src/w3sic2md.F90 index 50c104c3b..d15ae7abf 100644 --- a/model/src/w3sic2md.F90 +++ b/model/src/w3sic2md.F90 @@ -1,474 +1,470 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SIC2MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | F. Ardhuin & G. Boutin | -!/ | FORTRAN 90 | -!/ | Last update : 05-Jan-2018 | -!/ +-----------------------------------+ -!/ -!/ 10-Mar-2014 : Generalization with turbulent BL ( version 5.01 ) -!/ 05-Jan-2018 : Addition of floe size effect ( version 6.04 ) -!/ -!/ For updates see W3SIC1 documentation. -!/ -! 1. Purpose : -! -! Calculate ice dissipation source term S_{ice}. -! Exponential decay rate according to Liu et al., which -! uses as input: 1) ice thickness, and 2) an eddy -! viscosity parameter. This method is non-uniform in -! frequency. This is discussed further below, in -! subroutine "LIU_REVERSE_DISPERSION". -! -! Includes generalization by F. Ardhuin with viscous and tubulent -! boundary layers. That part is activating by setting namelist -! parameters that define the under-ice roughness and a friction -! coefficient. For example: &IC2 IC2TURB = 1. , IC2ROUGH =0.0001 -! -! References for Subtype 2: -! Liu et al. 1991: JGR 96 (C3), 4605-4621 -! Liu and Mollo 1988: JPO 18 1720-1712 -! Stopa et al. 2016: The Cryosphere -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SIC2 Subr. Public Ice source term. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! Reference:Rogers, W.E. and M.D. Orzech, 2013: Implementation and -! Testing of Ice and Mud Source Functions in WAVEWATCH III(R), -! NRL/MR/7320--13-9462, 31pp. -! available from http://www7320.nrlssc.navy.mil/pubs.php -! Direct link: -! http://www7320.nrlssc.navy.mil/pubs/2013/rogers2-2013.pdf -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC :: W3SIC2 -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SIC2 (A, DEPTH, ICEH, ICEF, CG, WN, IX, IY, S, D, WN_R, & - CG_ICE, ALPHA, R) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | F. Ardhuin & G. Boutin | -!/ | FORTRAN 90 | -!/ | Last update : 04-Jan-2018 | -!/ +-----------------------------------+ -!/ -!/ 16-Oct-2012 : Origination. ( version 4.04 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : W3SIC1 SUBTYPE=2 outsourced to W3SIC2 (S. Zieger) -!/ 10-Mar-2014 : Generalization with turbulent BL ( version 5.01 ) -!/ 16-Feb-2016 : Passes ICEH as parameter ( version 5.10 ) -!/ 02-May-2016 : Call to Liu disp moved to w3srce ( version 5.10 ) -!/ 04-Jan-2018 : Includes floe size dependance ( version 6.02 ) -!/ FIXME : Move field input to W3SRCE and provide -!/ (S.Zieger) input parameter to W3SIC1 to make the subroutine -!/ : versatile for point output processors ww3_outp -!/ and ww3_ounp. -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! S_{ice} source term using 5 parameters read from input files. -! These parameters are allowed to vary in space and time. -! The parameters control the exponential decay rate k_i -! Since there are 5 parameters, this permits description of -! dependence of k_i on frequency or wavenumber. -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! -! Regarding i/o (general to all Sice modules): S_{ice} source term -! is calculated using up to 5 parameters read from input files. -! These parameters are allowed to vary in space and time. -! The parameters control the exponential decay rate k_i -! Since there are 5 parameters, this permits description of -! dependence of k_i on frequency or wavenumber. -! -! Sea ice affects the wavenumber k of wind-generated ocean waves. -! The ice-modified wavenumber can be expressed as a complex number -! k = k_r + i*k_i, with the real part k_r representing impact of -! the sea ice on the physical wavelength and propagation speeds, -! producing something analogous to shoaling and refraction by -! bathymetry, whereas the imaginary part of the complex -! wavenumber, k_i, is an exponential decay coefficient -! k_i(x,y,t,sigma) (depending on location, time and frequency, -! respectively), representing wave attenuation, and can be -! introduced in a wave model such as WW3 as S_ice/E=-2*Cg*k_i, -! where S_ice is one of several dissipation mechanisms, along -! with whitecapping, for example, S_ds=S_wc+S_ice+⋯. The k_r - -! modified by ice would enter the model via the C calculations -! on the left-hand side of the governing equation.The fundamentals -! are straightforward, e.g. Rogers and Holland (2009 and -! subsequent unpublished work) modified a similar model, SWAN -! (Booij et al. 1999) to include the effects of a viscous mud -! layer using the same approach (k = k_r + i*k_i) previously. -! -! General approach is analogous to Rogers and Holland (2009) -! approach for mud. -! See text near their eq. 1 : -! k = k_r + i * k_i -! eta(x,t) = Real( a * exp( i * ( k * x - sigma * t ) ) ) -! a = a0 * exp( -k_i * x ) -! S / E = -2 * Cg * k_i (see also Komen et al. (1994, pg. 170) -! -! Please note that S is source term for action. -! -! Notes regarding numerics: -! (Note by F. Ardhuin: these may not apply in version 5 thanks to splitting -! of ice source terms and implicit integration in W3SRCE) -! Experiments with constant k_i values suggest that : -! for dx=20.0 km, k_i should not exceed 3.5e-6 -! (assumes 2.7% Hs error in my particular test case is intolerable) -! for dx=5.0 km, k_i should not exceed 2.0e-5 -! for dx=2.5 km, k_i should not exceed 5.0e-5 -! for dx=1.0 km, k_i should not exceed 2.0e-4 -! for dx=0.35 km, error is less than 2.1% for all k_i tested -! for dx=0.10 km, error is less than 1.3% for all k_i tested -! "Ground truth" used for this is an exponential decay profile. -! -! For reference, ACNFS is 1/12th deg, so delta_latitude=9.25 km. -! -! {put more equations here} -! -! The laminar to turbulent transition is described in -! Stopa et al. (The Cryosphere, 2016). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! DEPTH Real I Local water depth -! ICEH Real I Ice thickness -! CG R.A. I Group velocities -! WN R.A. I Wavenumbers -! IX,IY I.S. I Grid indices -! S R.A. O Source term (1-D version) -! D R.A. O Diagonal term of derivative (1-D version) -! WN_R R.A. I Wavenumbers in ice -! CG_ICE R.A. I Group velocities in ice -! ALPHA R.A. I Exponential decay rate of energy -! R R.A. I Ratio of energy to wave energy without ice -! ICEF Real I Ice Floe diameter -! -! imported via module: -! ICEP2 R.A. I Eddy viscosity -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). -! PRT2DS Subr. W3ARRYMD Print plot output (!/T1 switch). -! OUTMAT Subr. W3ARRYMD Matrix output (!/T2 switch). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A ASCII Point output post-processor. -! W3EXNC Subr. N/A NetCDF Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! If ice parameter 1 is zero, no calculations are made. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE W3DISPMD - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, IC2PARS, DDEN, & - FLAGLL, YGRD, GTYPE, RLGTYPE - USE W3IDATMD, ONLY: INFLAGS2,ICEP1,ICEP2,ICEP3,ICEP4,ICEP5,ICEI +MODULE W3SIC2MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | F. Ardhuin & G. Boutin | + !/ | FORTRAN 90 | + !/ | Last update : 05-Jan-2018 | + !/ +-----------------------------------+ + !/ + !/ 10-Mar-2014 : Generalization with turbulent BL ( version 5.01 ) + !/ 05-Jan-2018 : Addition of floe size effect ( version 6.04 ) + !/ + !/ For updates see W3SIC1 documentation. + !/ + ! 1. Purpose : + ! + ! Calculate ice dissipation source term S_{ice}. + ! Exponential decay rate according to Liu et al., which + ! uses as input: 1) ice thickness, and 2) an eddy + ! viscosity parameter. This method is non-uniform in + ! frequency. This is discussed further below, in + ! subroutine "LIU_REVERSE_DISPERSION". + ! + ! Includes generalization by F. Ardhuin with viscous and tubulent + ! boundary layers. That part is activating by setting namelist + ! parameters that define the under-ice roughness and a friction + ! coefficient. For example: &IC2 IC2TURB = 1. , IC2ROUGH =0.0001 + ! + ! References for Subtype 2: + ! Liu et al. 1991: JGR 96 (C3), 4605-4621 + ! Liu and Mollo 1988: JPO 18 1720-1712 + ! Stopa et al. 2016: The Cryosphere + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SIC2 Subr. Public Ice source term. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! Reference:Rogers, W.E. and M.D. Orzech, 2013: Implementation and + ! Testing of Ice and Mud Source Functions in WAVEWATCH III(R), + ! NRL/MR/7320--13-9462, 31pp. + ! available from http://www7320.nrlssc.navy.mil/pubs.php + ! Direct link: + ! http://www7320.nrlssc.navy.mil/pubs/2013/rogers2-2013.pdf + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC :: W3SIC2 + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SIC2 (A, DEPTH, ICEH, ICEF, CG, WN, IX, IY, S, D, WN_R, & + CG_ICE, ALPHA, R) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | F. Ardhuin & G. Boutin | + !/ | FORTRAN 90 | + !/ | Last update : 04-Jan-2018 | + !/ +-----------------------------------+ + !/ + !/ 16-Oct-2012 : Origination. ( version 4.04 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : W3SIC1 SUBTYPE=2 outsourced to W3SIC2 (S. Zieger) + !/ 10-Mar-2014 : Generalization with turbulent BL ( version 5.01 ) + !/ 16-Feb-2016 : Passes ICEH as parameter ( version 5.10 ) + !/ 02-May-2016 : Call to Liu disp moved to w3srce ( version 5.10 ) + !/ 04-Jan-2018 : Includes floe size dependance ( version 6.02 ) + !/ FIXME : Move field input to W3SRCE and provide + !/ (S.Zieger) input parameter to W3SIC1 to make the subroutine + !/ : versatile for point output processors ww3_outp + !/ and ww3_ounp. + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! S_{ice} source term using 5 parameters read from input files. + ! These parameters are allowed to vary in space and time. + ! The parameters control the exponential decay rate k_i + ! Since there are 5 parameters, this permits description of + ! dependence of k_i on frequency or wavenumber. + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! + ! Regarding i/o (general to all Sice modules): S_{ice} source term + ! is calculated using up to 5 parameters read from input files. + ! These parameters are allowed to vary in space and time. + ! The parameters control the exponential decay rate k_i + ! Since there are 5 parameters, this permits description of + ! dependence of k_i on frequency or wavenumber. + ! + ! Sea ice affects the wavenumber k of wind-generated ocean waves. + ! The ice-modified wavenumber can be expressed as a complex number + ! k = k_r + i*k_i, with the real part k_r representing impact of + ! the sea ice on the physical wavelength and propagation speeds, + ! producing something analogous to shoaling and refraction by + ! bathymetry, whereas the imaginary part of the complex + ! wavenumber, k_i, is an exponential decay coefficient + ! k_i(x,y,t,sigma) (depending on location, time and frequency, + ! respectively), representing wave attenuation, and can be + ! introduced in a wave model such as WW3 as S_ice/E=-2*Cg*k_i, + ! where S_ice is one of several dissipation mechanisms, along + ! with whitecapping, for example, S_ds=S_wc+S_ice+⋯. The k_r - + ! modified by ice would enter the model via the C calculations + ! on the left-hand side of the governing equation.The fundamentals + ! are straightforward, e.g. Rogers and Holland (2009 and + ! subsequent unpublished work) modified a similar model, SWAN + ! (Booij et al. 1999) to include the effects of a viscous mud + ! layer using the same approach (k = k_r + i*k_i) previously. + ! + ! General approach is analogous to Rogers and Holland (2009) + ! approach for mud. + ! See text near their eq. 1 : + ! k = k_r + i * k_i + ! eta(x,t) = Real( a * exp( i * ( k * x - sigma * t ) ) ) + ! a = a0 * exp( -k_i * x ) + ! S / E = -2 * Cg * k_i (see also Komen et al. (1994, pg. 170) + ! + ! Please note that S is source term for action. + ! + ! Notes regarding numerics: + ! (Note by F. Ardhuin: these may not apply in version 5 thanks to splitting + ! of ice source terms and implicit integration in W3SRCE) + ! Experiments with constant k_i values suggest that : + ! for dx=20.0 km, k_i should not exceed 3.5e-6 + ! (assumes 2.7% Hs error in my particular test case is intolerable) + ! for dx=5.0 km, k_i should not exceed 2.0e-5 + ! for dx=2.5 km, k_i should not exceed 5.0e-5 + ! for dx=1.0 km, k_i should not exceed 2.0e-4 + ! for dx=0.35 km, error is less than 2.1% for all k_i tested + ! for dx=0.10 km, error is less than 1.3% for all k_i tested + ! "Ground truth" used for this is an exponential decay profile. + ! + ! For reference, ACNFS is 1/12th deg, so delta_latitude=9.25 km. + ! + ! {put more equations here} + ! + ! The laminar to turbulent transition is described in + ! Stopa et al. (The Cryosphere, 2016). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! DEPTH Real I Local water depth + ! ICEH Real I Ice thickness + ! CG R.A. I Group velocities + ! WN R.A. I Wavenumbers + ! IX,IY I.S. I Grid indices + ! S R.A. O Source term (1-D version) + ! D R.A. O Diagonal term of derivative (1-D version) + ! WN_R R.A. I Wavenumbers in ice + ! CG_ICE R.A. I Group velocities in ice + ! ALPHA R.A. I Exponential decay rate of energy + ! R R.A. I Ratio of energy to wave energy without ice + ! ICEF Real I Ice Floe diameter + ! + ! imported via module: + ! ICEP2 R.A. I Eddy viscosity + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). + ! PRT2DS Subr. W3ARRYMD Print plot output (!/T1 switch). + ! OUTMAT Subr. W3ARRYMD Matrix output (!/T2 switch). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A ASCII Point output post-processor. + ! W3EXNC Subr. N/A NetCDF Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! If ice parameter 1 is zero, no calculations are made. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE W3DISPMD + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, IC2PARS, DDEN, & + FLAGLL, YGRD, GTYPE, RLGTYPE + USE W3IDATMD, ONLY: INFLAGS2,ICEP1,ICEP2,ICEP3,ICEP4,ICEP5,ICEI #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: A(NSPEC), DEPTH, ICEH - REAL, INTENT(IN) :: CG(NK), WN(NK) - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) - REAL, INTENT(IN) :: ALPHA(NK) ! exponential (spatial) decay rate for energy (1/m) - INTEGER, INTENT(IN) :: IX, IY - REAL, INTENT(IN) :: WN_R(NK), CG_ICE(NK), R(NK) - REAL, INTENT(IN) :: ICEF ! Hypothesis: friction does not occur for broken ice + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: A(NSPEC), DEPTH, ICEH + REAL, INTENT(IN) :: CG(NK), WN(NK) + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + REAL, INTENT(IN) :: ALPHA(NK) ! exponential (spatial) decay rate for energy (1/m) + INTEGER, INTENT(IN) :: IX, IY + REAL, INTENT(IN) :: WN_R(NK), CG_ICE(NK), R(NK) + REAL, INTENT(IN) :: ICEF ! Hypothesis: friction does not occur for broken ice -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T0 - INTEGER :: ITH - REAL :: DOUT(NK,NTH) + REAL :: DOUT(NK,NTH) #endif - INTEGER :: IKTH, IK - REAL :: D1D(NK) !In SBT1: D1D was named "CBETA" - REAL :: ICECOEF1, ICECOEF2, ICECONC - REAL, ALLOCATABLE :: WN_I(:) ! exponential (spatial) decay rate for amplitude (1/m) - REAL :: VISCM=1.83E-6 ! molecular viscosity of water at freezing - REAL :: PTURB, PVISC, DTURB, DVISC, & - SMOOTH, RE, UORB, AORB, EB, & - DELI1, DELI2, FW, XI, FTURB, & - CG_EFF(NK), WLG_R(NK), SMOOTH_DMAX(NK) - INTEGER :: IND, ITH, IS - LOGICAL :: NOICE=.FALSE. - ! Warning, ALPHA = 2 * WN_I -> Makes WN_I useless, doesnt it ? -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: IKTH, IK + REAL :: D1D(NK) !In SBT1: D1D was named "CBETA" + REAL :: ICECOEF1, ICECOEF2, ICECONC + REAL, ALLOCATABLE :: WN_I(:) ! exponential (spatial) decay rate for amplitude (1/m) + REAL :: VISCM=1.83E-6 ! molecular viscosity of water at freezing + REAL :: PTURB, PVISC, DTURB, DVISC, & + SMOOTH, RE, UORB, AORB, EB, & + DELI1, DELI2, FW, XI, FTURB, & + CG_EFF(NK), WLG_R(NK), SMOOTH_DMAX(NK) + INTEGER :: IND, ITH, IS + LOGICAL :: NOICE=.FALSE. + ! Warning, ALPHA = 2 * WN_I -> Makes WN_I useless, doesnt it ? + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIC2') + CALL STRACE (IENT, 'W3SIC2') #endif -! -! 0. Initializations ------------------------------------------------ * -! - D = 0.0 -! - ALLOCATE(WN_I(NK)) - WN_I = 0.0 - ICECOEF1 = ICEH - ICECOEF2 = 0.0 - ICECONC = 0.0 - CG_EFF = 0. - SMOOTH_DMAX(:)=1. -! - IF (INFLAGS2(-7))ICECOEF1 = ICEH - IF (INFLAGS2(-6))ICECOEF2 = ICEP2(IX,IY) - IF (INFLAGS2(4)) ICECONC = ICEI(IX,IY) -! -! -! 1. No ice --------------------------------------------------------- / -! - NOICE=.FALSE. - IF (ICECOEF1==0.0) NOICE=.TRUE. - IF (INFLAGS2(4).AND.(ICECONC==0.0)) NOICE=.TRUE. + ! + ! 0. Initializations ------------------------------------------------ * + ! + D = 0.0 + ! + ALLOCATE(WN_I(NK)) + WN_I = 0.0 + ICECOEF1 = ICEH + ICECOEF2 = 0.0 + ICECONC = 0.0 + CG_EFF = 0. + SMOOTH_DMAX(:)=1. + ! + IF (INFLAGS2(-7))ICECOEF1 = ICEH + IF (INFLAGS2(-6))ICECOEF2 = ICEP2(IX,IY) + IF (INFLAGS2(4)) ICECONC = ICEI(IX,IY) + ! + ! + ! 1. No ice --------------------------------------------------------- / + ! + NOICE=.FALSE. + IF (ICECOEF1==0.0) NOICE=.TRUE. + IF (INFLAGS2(4).AND.(ICECONC==0.0)) NOICE=.TRUE. - IF ( NOICE ) THEN - D = 0.0 -! -! 2. Ice ------------------------------------------------------------ / - ELSE -! -! 2.a Set constant(s) and write test output -------------------------- / -! -! (none) -! + IF ( NOICE ) THEN + D = 0.0 + ! + ! 2. Ice ------------------------------------------------------------ / + ELSE + ! + ! 2.a Set constant(s) and write test output -------------------------- / + ! + ! (none) + ! #ifdef W3_T38 - WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2 + WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2 #endif -! -! 2.b Make calculations ---------------------------------------------- / + ! + ! 2.b Make calculations ---------------------------------------------- / - ! ICECOEF1 = H_ICE - ! ICECOEF2 = VISC -! -! Branches out depending on choice of dispersion relation... -! by default IC2PARS(1)=0, and attenuation computed as described in Stopa et al. 2016 -! - IF (IC2PARS(1).GT.0.5) THEN - IF (.NOT.INFLAGS2(-7))THEN - WRITE (NDSE,1001) 'ICE PARAMETER 1' - CALL EXTCDE(2) - ENDIF - IF (.NOT.INFLAGS2(-6))THEN - WRITE (NDSE,1001) 'ICE PARAMETER 2' - CALL EXTCDE(2) - ENDIF -! - WN_I(:) = 0.5 * ALPHA(:) ! ALPHA=2*WN_I - DO IK=1, NK -! recall that D=S/E=-2*Cg*k_i -! Note: We should not use CG_ICE here unless CG_ICE is also -! used for advection in w3wavemd.ftn (see lines for IC3 -! there). - D1D(IK)= -2.0 * CG(IK) * WN_I(IK) - END DO -! -! Alternative by F.A.: generalization to a turbulent boundary layer -! uses the ice-free dispersion, to be updated later -! - ELSE ! goes here if IC2PARS(1).LE.0.5 (this is the default behavior) - IF (IC2PARS(2).GT.0.) THEN - UORB=0. - AORB=0. - FTURB = IC2PARS(2) -! Special treatment in the southern ocean ... - IF (IC2PARS(7).GT.0) THEN - IF (YGRD(IY,IX).LT.0.AND.GTYPE.EQ.RLGTYPE.AND.FLAGLL) FTURB = IC2PARS(7) - END IF - DO IK=1, NK - EB = 0. - DO ITH=1, NTH - IS=ITH+(IK-1)*NTH - EB = EB + A(IS) - END DO -! -! UORB and AORB are the variances of the orbital velocity and surface elevation -! of the water relative to the ice ... this is only correct if the ice layer -! does not move. This should is changed by taking into account DMAX when IC2DMAX > 0: -! + ! ICECOEF1 = H_ICE + ! ICECOEF2 = VISC + ! + ! Branches out depending on choice of dispersion relation... + ! by default IC2PARS(1)=0, and attenuation computed as described in Stopa et al. 2016 + ! + IF (IC2PARS(1).GT.0.5) THEN + IF (.NOT.INFLAGS2(-7))THEN + WRITE (NDSE,1001) 'ICE PARAMETER 1' + CALL EXTCDE(2) + ENDIF + IF (.NOT.INFLAGS2(-6))THEN + WRITE (NDSE,1001) 'ICE PARAMETER 2' + CALL EXTCDE(2) + ENDIF + ! + WN_I(:) = 0.5 * ALPHA(:) ! ALPHA=2*WN_I + DO IK=1, NK + ! recall that D=S/E=-2*Cg*k_i + ! Note: We should not use CG_ICE here unless CG_ICE is also + ! used for advection in w3wavemd.ftn (see lines for IC3 + ! there). + D1D(IK)= -2.0 * CG(IK) * WN_I(IK) + END DO + ! + ! Alternative by F.A.: generalization to a turbulent boundary layer + ! uses the ice-free dispersion, to be updated later + ! + ELSE ! goes here if IC2PARS(1).LE.0.5 (this is the default behavior) + IF (IC2PARS(2).GT.0.) THEN + UORB=0. + AORB=0. + FTURB = IC2PARS(2) + ! Special treatment in the southern ocean ... + IF (IC2PARS(7).GT.0) THEN + IF (YGRD(IY,IX).LT.0.AND.GTYPE.EQ.RLGTYPE.AND.FLAGLL) FTURB = IC2PARS(7) + END IF + DO IK=1, NK + EB = 0. + DO ITH=1, NTH + IS=ITH+(IK-1)*NTH + EB = EB + A(IS) + END DO + ! + ! UORB and AORB are the variances of the orbital velocity and surface elevation + ! of the water relative to the ice ... this is only correct if the ice layer + ! does not move. This should is changed by taking into account DMAX when IC2DMAX > 0: + ! #ifdef W3_IS2 - IF (IC2PARS(8).GT.0) THEN - WLG_R(IK)=TPI/WN_R(IK) - SMOOTH_DMAX(IK)= (0.5*(1+TANH((ICEF-IC2PARS(8)*WLG_R(IK))/(ICEF*0.5))))**2 + IF (IC2PARS(8).GT.0) THEN + WLG_R(IK)=TPI/WN_R(IK) + SMOOTH_DMAX(IK)= (0.5*(1+TANH((ICEF-IC2PARS(8)*WLG_R(IK))/(ICEF*0.5))))**2 END IF #endif -! - IF (R(IK).GT.1.) THEN - UORB = UORB + EB * SMOOTH_DMAX(IK)* SIG(IK)**2 * DDEN(IK) / CG(IK) & - / (R(IK)*CG_ICE(IK)/CG(IK)) - AORB = AORB + EB * SMOOTH_DMAX(IK) * DDEN(IK) / CG(IK) & - / (R(IK)*CG_ICE(IK)/CG(IK)) !deep water only - ELSE - UORB = UORB + EB * SMOOTH_DMAX(IK) *SIG(IK)**2 * DDEN(IK) / CG(IK) - AORB = AORB + EB * SMOOTH_DMAX(IK) * DDEN(IK) / CG(IK) !deep water only - END IF - - END DO -! - AORB = 2*SQRT(AORB) ! significant amplitude - UORB = 2*SQRT(UORB) ! significant amplitude + ! + IF (R(IK).GT.1.) THEN + UORB = UORB + EB * SMOOTH_DMAX(IK)* SIG(IK)**2 * DDEN(IK) / CG(IK) & + / (R(IK)*CG_ICE(IK)/CG(IK)) + AORB = AORB + EB * SMOOTH_DMAX(IK) * DDEN(IK) / CG(IK) & + / (R(IK)*CG_ICE(IK)/CG(IK)) !deep water only + ELSE + UORB = UORB + EB * SMOOTH_DMAX(IK) *SIG(IK)**2 * DDEN(IK) / CG(IK) + AORB = AORB + EB * SMOOTH_DMAX(IK) * DDEN(IK) / CG(IK) !deep water only + END IF - RE = UORB*AORB / VISCM - SMOOTH = 0.5*TANH((RE-IC2PARS(4))/IC2PARS(5)) - PTURB=(0.5+SMOOTH) - PVISC=(0.5-SMOOTH) + END DO + ! + AORB = 2*SQRT(AORB) ! significant amplitude + UORB = 2*SQRT(UORB) ! significant amplitude - XI=(ALOG10(MAX(AORB/IC2PARS(3),3.))-ABMIN)/DELAB - IND = MIN (SIZEFWTABLE-1, INT(XI)) - DELI1= MIN (1. ,XI-FLOAT(IND)) - DELI2= 1. - DELI1 - FW =FWTABLE(IND)*DELI2+FWTABLE(IND+1)*DELI1 - DTURB= FTURB*FW*UORB/GRAV - ELSE ! so case of IC2PARS(2).LE.0. - DTURB = 0. - PTURB = 0. - PVISC = 1. - END IF ! IF (IC2PARS(2).GT.0.) -! - DO IK=1, NK -! WN_R is used here but warning, this is only OK for unbroken ice - DVISC = IC2PARS(6) * WN_R(IK) * SQRT(VISCM* SIG(IK) / 2.) - D1D(IK) = -1.*(PTURB*MAX(DTURB*SIG(IK)**2,DVISC) + PVISC*DVISC) & - *SMOOTH_DMAX(IK) - END DO - END IF ! IF (IC2PARS(1).GT.0.5) + RE = UORB*AORB / VISCM + SMOOTH = 0.5*TANH((RE-IC2PARS(4))/IC2PARS(5)) + PTURB=(0.5+SMOOTH) + PVISC=(0.5-SMOOTH) -! -! 2.c Fill diagional matrix -! - DO IKTH=1, NSPEC - D(IKTH) = D1D(MAPWN(IKTH)) - END DO -! - END IF ! IF ( NOICE ) THEN -! - S = D * A -! -! ... Test output of arrays -! -#ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO + XI=(ALOG10(MAX(AORB/IC2PARS(3),3.))-ABMIN)/DELAB + IND = MIN (SIZEFWTABLE-1, INT(XI)) + DELI1= MIN (1. ,XI-FLOAT(IND)) + DELI2= 1. - DELI1 + FW =FWTABLE(IND)*DELI2+FWTABLE(IND+1)*DELI1 + DTURB= FTURB*FW*UORB/GRAV + ELSE ! so case of IC2PARS(2).LE.0. + DTURB = 0. + PTURB = 0. + PVISC = 1. + END IF ! IF (IC2PARS(2).GT.0.) + ! + DO IK=1, NK + ! WN_R is used here but warning, this is only OK for unbroken ice + DVISC = IC2PARS(6) * WN_R(IK) * SQRT(VISCM* SIG(IK) / 2.) + D1D(IK) = -1.*(PTURB*MAX(DTURB*SIG(IK)**2,DVISC) + PVISC*DVISC) & + *SMOOTH_DMAX(IK) END DO -#endif -! + END IF ! IF (IC2PARS(1).GT.0.5) + + ! + ! 2.c Fill diagional matrix + ! + DO IKTH=1, NSPEC + D(IKTH) = D1D(MAPWN(IKTH)) + END DO + ! + END IF ! IF ( NOICE ) THEN + ! + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') #endif -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC2 : '/ & - ' ',A,' REQUIRED BUT NOT SELECTED'/) -! + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC2 : '/ & + ' ',A,' REQUIRED BUT NOT SELECTED'/) + ! #ifdef W3_T38 - 9000 FORMAT (' TEST W3SIC2 : DEPTH,ICECOEF1 : ',2E10.3) +9000 FORMAT (' TEST W3SIC2 : DEPTH,ICECOEF1 : ',2E10.3) #endif -!/ -!/ End of W3SIC2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SIC2 + !/ + !/ End of W3SIC2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SIC2 -!/ -!/ End of module W3SIC2MD -------------------------------------------- / -!/ - END MODULE W3SIC2MD + !/ + !/ End of module W3SIC2MD -------------------------------------------- / + !/ +END MODULE W3SIC2MD diff --git a/model/src/w3sic3md.F90 b/model/src/w3sic3md.F90 index b71419eda..75441ec53 100644 --- a/model/src/w3sic3md.F90 +++ b/model/src/w3sic3md.F90 @@ -1,3098 +1,3095 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SIC3MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | X. Zhao | -!/ | S. Cheng | -!/ | FORTRAN 90 | -!/ | Last update : 04-Jan-2016 | -!/ +-----------------------------------+ -!/ -!/ Updates: -!/ 29-May-2014 : Generalization with turbulent BL -!/ (F.A. method imported from IC2 by E.R.) ( version 5.01 ) -!/ 04-Jan-2016 : Importing code provided by S. Cheng -!/ (improved solution methods for Wang and Shen model) -!/ -! 1. Purpose : -! -! Calculate ice source term S_{ice} according to a viscoelastic sea -! ice model (Wang and Shen 2010). -! -! Reference: Wang, R., and H. H. Shen (2010), Gravity waves -! propagating into an ice‐covered ocean: A viscoelastic model, J. -! Geophys. Res., 115, C06024, doi:10.1029/2009JC005591 . -! -! 2. Variables and types : -! Name Type Scope Description -! ------------------------------------------------------------------ -! IC3TABLE_CHENG Int. Public Table of wave number k_r, -! attenuation k_i and group -! velocity cg -! IC3_DITK R.A. Private Ice thickness increment -! IC3_MAXITK R.A. Private Maximum ice thickness, the code -! may fail for situation with ice -! thickness larger than this value -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ------------------------------------------------------------------ -! W3SIC3 Subr. Public Ice source term. -! BSDET Func. Private Calculate the determinant for -! the dispersion relation. -! WN_CMPLX_V1 Func. Private Calculate complex wavenumber in -! ice -! WN_PRECALC_CHENG Subr. Private Calculate complex wavenumber in -! ice -! WN_CMPLX_HF Func. Private Like above, but for h-f waves -! CMPLX_ROOT_MULLER_CHENG Func. Private Find root for complex -! numbers -! FUN_ZHAO Func. Private Wrapper function for FUNC0/FUNC1 -! FUNC0_ZHAO Func. Private -! FUNC1_ZHAO Func. Private -! W3IC3WNCG Subr. Public Calculate kr,ki and cg for all -! frequency at each grid point -! IC3PRECALC_CHENG Subr. Private Calculate kr,ki and cg table for -! all frequencies and ice -! thickness from 0~IC3_MAXITK -! CGinIC3_CHENG func. Private Calculate group velocity -! related to IC3 model -! F_ZHAO Func. Private Wrapper function for double/ -! quadruple precision -! ------------------------------------------------------------------ -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC :: W3SIC3, W3IC3WNCG_V1, W3IC3WNCG_CHENG - PRIVATE :: WN_CMPLX_V1, WN_CMPLX_HF - PRIVATE :: CMPLX_ROOT_MULLER_V1, CMPLX_ROOT_MULLER_CHENG - PRIVATE :: F_ZHAO_V1, F_ZHAO_CHENG - PRIVATE :: FUNC1_ZHAO, FUNC0_ZHAO, BSDET - INTEGER,SAVE :: CALLEDIC3TABLE = 0 - REAL,PRIVATE,PARAMETER :: IC3_DITK = 0.01, IC3_MAXITK = 3. - PUBLIC :: IC3TABLE_CHENG - PRIVATE :: IC3PRECALC_CHENG, CGINIC3_CHENG - - CONTAINS -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SIC3 (A, DEPTH, CG, WN, IX, IY, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 11-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (copied from SICE1) ( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ -!/ FIXME : Move field input to W3SRCE and provide -!/ (S.Zieger) input parameter to W3SIC1 to make the subroutine -!/ : versatile for point output processors ww3_outp -!/ and ww3_ounp. -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Calculate ice source term S_{ice} according to a viscoelastic sea -! ice model (Wang and Shen 2010). -! -! Reference: Wang, R., and H. H. Shen (2010), Gravity waves -! propagating into an ice‐covered ocean: A viscoelastic model, J. -! Geophys. Res., 115, C06024, doi:10.1029/2009JC005591 . -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! -! Regarding i/o (general to all Sice modules): S_{ice} source term -! is calculated using up to 5 parameters read from input files. -! These parameters are allowed to vary in space and time. -! The parameters control the exponential decay rate k_i -! Since there are 5 parameters, this permits description of -! dependence of k_i on frequency or wavenumber. -! -! Sea ice affects the wavenumber k of wind-generated ocean waves. -! The ice-modified wavenumber can be expressed as a complex number -! k = k_r + i*k_i, with the real part k_r representing impact of -! the sea ice on the physical wavelength and propagation speeds, -! producing something analogous to shoaling and refraction by -! bathymetry, whereas the imaginary part of the complex -! wavenumber, k_i, is an exponential decay coefficient -! k_i(x,y,t,sigma) (depending on location, time and frequency, -! respectively), representing wave attenuation, and can be -! introduced in a wave model such as WW3 as S_ice/E=-2*Cg*k_i, -! where S_ice is one of several dissipation mechanisms, along -! with whitecapping, for example, S_ds=S_wc+S_ice+⋯. The k_r - -! modified by ice would enter the model via the C calculations -! on the left-hand side of the governing equation.The fundamentals -! are straightforward, e.g. Rogers and Holland (2009 and -! subsequent unpublished work) modified a similar model, SWAN -! (Booij et al. 1999) to include the effects of a viscous mud -! layer using the same approach (k = k_r + i*k_i) previously. -! -! General approach is analogous to Rogers and Holland (2009) -! approach for mud. -! See text near their eq. 1 : -! k = k_r + i * k_i -! eta(x,t) = Real( a * exp( i * ( k * x - sigma * t ) ) ) -! a = a0 * exp( -k_i * x ) -! S / E = -2 * Cg * k_i (see also Komen et al. (1994, pg. 170) -! -! Following W3SBT1 as a guide, equation 1 of W3SBT1 says: -! S = D * E -! However, the code of W3SBT1 has -! S = D * A -! This leads me to believe that the calling routine is -! expecting "S/sigma" not "S" -! Thus we will use D = S/E = -2 * Cg * k_i -! -! The calling routine is expecting "S/sigma" not "S" -! Thus we will use D = S/E = -2 * Cg * k_i -! (see also documentation of W3SIC1) -! -! Notes regarding numerics: -! -! Experiments with constant k_i values suggest that results may be -! dependent on resolution if insufficient resolution is used. -! For detailed information, see documentation of W3SIC1. -! -! Note regarding applicability/validity: -! -! The Wang and Shen model is intended as a generalized model for -! various types of ice cover. It is a "continuum" model for -! which the same model is used from the ice edge to the ice -! interior. Though the ice types are expected to be very different -! from the edge to the interior, this is accomodated by the relative -! importance of the "effective viscosity" and the "modulus of -! elasticity". At the ice edge, where one finds frazil ice, pancake -! ice, or ice floes much smaller than the wave length, the "viscous" -! component of the model is believed to be most appropriate. At the -! interior, where one finds a continuous ice sheet, the "elastic -! model" component of the generalized visco-elastic model is -! expected to be appropriate. In addition to the case of continuous -! ice, Wang and Shen argue that the elastic model is also applicable -! to ice floes when the floe sizes are large relative to the -! wavelength. So to summarize, -! * frazil ice, pancake ice, and floes smaller than wavelength : -! viscosity dominates -! * continuous ice, and floes larger than wavelength : -! elasticity dominates -! * intermediate conditions: neither dominates -! All this is accomodated in WW3 by using non-uniform specification -! of viscosity and elasticity. -! -! In the case where a user wishes to utilize only the "viscous -! model" aspect of Wang and Shen, and use an alternative scheme for -! continous ice and large ice floes, we allow this through the use -! of a user-defined namelist parameter "IC3MAXTHK". Floe size is -! not (at time of writing) an output available from ice model CICE, -! so we use the ice thickness as a way to anticipate the floe size. -! When ice thickness exceeds IC3MAXTHK, WW3 will use another model -! in place of the Wang and Shen formulation : -! -! S_ice by F.A., an estimation of dissipation by turbulence -! at the ice-water interface. It uses only namelists for input, and -! no space/time varying input (though of course ice concentration is -! space/time varying). Unlike Liu et al. (IC2), it does not use -! ice thickness and does not yield a new C|Cg|k (i.e. it is non- -! dispersive), but it has the very nice feature of not requiring -! an eddy viscosity, which is a major drawback of the Liu et al. -! model. That is why we use it here, vs. Liu et al. -! (S_ice by Liu et al. and S_ice by F.A. are the two options -! available in IC2, i.e. w3sic2md.ftn) -! -! At time of writing (March 23 2015), there may be some problems -! with the root-selection of IC3. For example with these settings: -! hice=1 ; rho_ice=917.0 ; emod=4.9e+12 ; visc=5e+7 ; -! h_water=deep (without using the IC3MAXTHK feature) the solution -! is rather irregular: -! T=11.11 k_i = 215.0e-5 -! T=10 k_i = 266.0e-5 -! T=9 k_i = 1.4e-5 -! T=8.1 k_i = 1.7e-5 -! With hice=0.1, ki is monotonically increasing in that range: -! T=11.11 k_i = 0.97e-5 -! T=10 k_i = 2.64e-5 -! T=9 k_i = 3.90e-5 -! T=8.1 k_i = 4.47e-5 -! Of course, when using IC3MAXTHK=0.1, the first example (hice=1) -! would switch to the "S_ice by F.A." model, and so this problem -! is circumvented. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D). -! DEPTH Real I Local water depth. -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! IX,IY I.S. I Grid indices. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). -! PRT2DS Subr. W3ARRYMD Print plot output (!/T1 switch). -! OUTMAT Subr. W3ARRYMD Matrix output (!/T2 switch). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A ASCII Point output post-processor. -! W3EXNC Subr. N/A NetCDF Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! If ice parameter 1 is zero, no calculations are made. -! -! Code by S. Cheng sets NOICE=.TRUE. if ISNAN(ICECOEF1). -! Comments are "maps may not be compatible" -! This feature is not understood by me (ER) and so omitted. -! -!/ ------------------------------------------------------------------- / -! On array size, S. Cheng says: -! Upon checking the origin of CG, I would say CG = CG_IC3, this is -! the topic ‘call W3IC3WNCG twice’. Recently I find they are not -! exactly the same due to calculation and smoothing of cg using -! several neighbor points. For different input array size, results -! are slightly different. In subr. w3wave, the size of input arrays -! is 0:NK+1, while in w3sic3, the size of all input arrays is 1:NK. -! This array size difference is reflected in the resulting cg. The -! small difference in cg between calling IC3 twice or just calling -! once produces small difference in SWH. To eliminate this small -! difference, I suggest to keep CG instead of CG_IC3, as well as WN, -! WN_I, because other source terms use CG. I confirmed this change -! would make results of ICE the same whether calling twice or once -! by defining dimension WN_R, WN_I, CG_IC3 as 0:NK+1 instead of -! 1:NK. Then CG_IC3 = CG. -!/ ------------------------------------------------------------------- / -! On optimization, S. Cheng says: -! For Wang and Shen’s model, D does not change in the loop -! corresponding to NSTEPS in subr. W3SRCE. I find the most efficient -! and easy way to speed up is that Add D and NSTEPS as inputs of -! W3SIC3 -! If NSTEPS==1 -! Current Wang and Shen’s model code above. -! ELSE -! S = D*A -! Endif -!/ ------------------------------------------------------------------- / -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPI, DWAT, ABMIN, DELAB, SIZEFWTABLE, & - FWTABLE, GRAV - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR -! USE WMMDATMD, ONLY: IMPROC, NMPERR ! WMMDATMD unavailable to outp - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, IC3PARS, DDEN, & - FLAGLL, YGRD, GTYPE, RLGTYPE - USE W3IDATMD, ONLY: ICEP1, ICEP2, ICEP3, ICEP4, ICEP5, ICEI, & - INFLAGS2 +MODULE W3SIC3MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | X. Zhao | + !/ | S. Cheng | + !/ | FORTRAN 90 | + !/ | Last update : 04-Jan-2016 | + !/ +-----------------------------------+ + !/ + !/ Updates: + !/ 29-May-2014 : Generalization with turbulent BL + !/ (F.A. method imported from IC2 by E.R.) ( version 5.01 ) + !/ 04-Jan-2016 : Importing code provided by S. Cheng + !/ (improved solution methods for Wang and Shen model) + !/ + ! 1. Purpose : + ! + ! Calculate ice source term S_{ice} according to a viscoelastic sea + ! ice model (Wang and Shen 2010). + ! + ! Reference: Wang, R., and H. H. Shen (2010), Gravity waves + ! propagating into an ice‐covered ocean: A viscoelastic model, J. + ! Geophys. Res., 115, C06024, doi:10.1029/2009JC005591 . + ! + ! 2. Variables and types : + ! Name Type Scope Description + ! ------------------------------------------------------------------ + ! IC3TABLE_CHENG Int. Public Table of wave number k_r, + ! attenuation k_i and group + ! velocity cg + ! IC3_DITK R.A. Private Ice thickness increment + ! IC3_MAXITK R.A. Private Maximum ice thickness, the code + ! may fail for situation with ice + ! thickness larger than this value + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ------------------------------------------------------------------ + ! W3SIC3 Subr. Public Ice source term. + ! BSDET Func. Private Calculate the determinant for + ! the dispersion relation. + ! WN_CMPLX_V1 Func. Private Calculate complex wavenumber in + ! ice + ! WN_PRECALC_CHENG Subr. Private Calculate complex wavenumber in + ! ice + ! WN_CMPLX_HF Func. Private Like above, but for h-f waves + ! CMPLX_ROOT_MULLER_CHENG Func. Private Find root for complex + ! numbers + ! FUN_ZHAO Func. Private Wrapper function for FUNC0/FUNC1 + ! FUNC0_ZHAO Func. Private + ! FUNC1_ZHAO Func. Private + ! W3IC3WNCG Subr. Public Calculate kr,ki and cg for all + ! frequency at each grid point + ! IC3PRECALC_CHENG Subr. Private Calculate kr,ki and cg table for + ! all frequencies and ice + ! thickness from 0~IC3_MAXITK + ! CGinIC3_CHENG func. Private Calculate group velocity + ! related to IC3 model + ! F_ZHAO Func. Private Wrapper function for double/ + ! quadruple precision + ! ------------------------------------------------------------------ + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC :: W3SIC3, W3IC3WNCG_V1, W3IC3WNCG_CHENG + PRIVATE :: WN_CMPLX_V1, WN_CMPLX_HF + PRIVATE :: CMPLX_ROOT_MULLER_V1, CMPLX_ROOT_MULLER_CHENG + PRIVATE :: F_ZHAO_V1, F_ZHAO_CHENG + PRIVATE :: FUNC1_ZHAO, FUNC0_ZHAO, BSDET + INTEGER,SAVE :: CALLEDIC3TABLE = 0 + REAL,PRIVATE,PARAMETER :: IC3_DITK = 0.01, IC3_MAXITK = 3. + PUBLIC :: IC3TABLE_CHENG + PRIVATE :: IC3PRECALC_CHENG, CGINIC3_CHENG + +CONTAINS + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SIC3 (A, DEPTH, CG, WN, IX, IY, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 11-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (copied from SICE1) ( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ + !/ FIXME : Move field input to W3SRCE and provide + !/ (S.Zieger) input parameter to W3SIC1 to make the subroutine + !/ : versatile for point output processors ww3_outp + !/ and ww3_ounp. + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Calculate ice source term S_{ice} according to a viscoelastic sea + ! ice model (Wang and Shen 2010). + ! + ! Reference: Wang, R., and H. H. Shen (2010), Gravity waves + ! propagating into an ice‐covered ocean: A viscoelastic model, J. + ! Geophys. Res., 115, C06024, doi:10.1029/2009JC005591 . + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! + ! Regarding i/o (general to all Sice modules): S_{ice} source term + ! is calculated using up to 5 parameters read from input files. + ! These parameters are allowed to vary in space and time. + ! The parameters control the exponential decay rate k_i + ! Since there are 5 parameters, this permits description of + ! dependence of k_i on frequency or wavenumber. + ! + ! Sea ice affects the wavenumber k of wind-generated ocean waves. + ! The ice-modified wavenumber can be expressed as a complex number + ! k = k_r + i*k_i, with the real part k_r representing impact of + ! the sea ice on the physical wavelength and propagation speeds, + ! producing something analogous to shoaling and refraction by + ! bathymetry, whereas the imaginary part of the complex + ! wavenumber, k_i, is an exponential decay coefficient + ! k_i(x,y,t,sigma) (depending on location, time and frequency, + ! respectively), representing wave attenuation, and can be + ! introduced in a wave model such as WW3 as S_ice/E=-2*Cg*k_i, + ! where S_ice is one of several dissipation mechanisms, along + ! with whitecapping, for example, S_ds=S_wc+S_ice+⋯. The k_r - + ! modified by ice would enter the model via the C calculations + ! on the left-hand side of the governing equation.The fundamentals + ! are straightforward, e.g. Rogers and Holland (2009 and + ! subsequent unpublished work) modified a similar model, SWAN + ! (Booij et al. 1999) to include the effects of a viscous mud + ! layer using the same approach (k = k_r + i*k_i) previously. + ! + ! General approach is analogous to Rogers and Holland (2009) + ! approach for mud. + ! See text near their eq. 1 : + ! k = k_r + i * k_i + ! eta(x,t) = Real( a * exp( i * ( k * x - sigma * t ) ) ) + ! a = a0 * exp( -k_i * x ) + ! S / E = -2 * Cg * k_i (see also Komen et al. (1994, pg. 170) + ! + ! Following W3SBT1 as a guide, equation 1 of W3SBT1 says: + ! S = D * E + ! However, the code of W3SBT1 has + ! S = D * A + ! This leads me to believe that the calling routine is + ! expecting "S/sigma" not "S" + ! Thus we will use D = S/E = -2 * Cg * k_i + ! + ! The calling routine is expecting "S/sigma" not "S" + ! Thus we will use D = S/E = -2 * Cg * k_i + ! (see also documentation of W3SIC1) + ! + ! Notes regarding numerics: + ! + ! Experiments with constant k_i values suggest that results may be + ! dependent on resolution if insufficient resolution is used. + ! For detailed information, see documentation of W3SIC1. + ! + ! Note regarding applicability/validity: + ! + ! The Wang and Shen model is intended as a generalized model for + ! various types of ice cover. It is a "continuum" model for + ! which the same model is used from the ice edge to the ice + ! interior. Though the ice types are expected to be very different + ! from the edge to the interior, this is accomodated by the relative + ! importance of the "effective viscosity" and the "modulus of + ! elasticity". At the ice edge, where one finds frazil ice, pancake + ! ice, or ice floes much smaller than the wave length, the "viscous" + ! component of the model is believed to be most appropriate. At the + ! interior, where one finds a continuous ice sheet, the "elastic + ! model" component of the generalized visco-elastic model is + ! expected to be appropriate. In addition to the case of continuous + ! ice, Wang and Shen argue that the elastic model is also applicable + ! to ice floes when the floe sizes are large relative to the + ! wavelength. So to summarize, + ! * frazil ice, pancake ice, and floes smaller than wavelength : + ! viscosity dominates + ! * continuous ice, and floes larger than wavelength : + ! elasticity dominates + ! * intermediate conditions: neither dominates + ! All this is accomodated in WW3 by using non-uniform specification + ! of viscosity and elasticity. + ! + ! In the case where a user wishes to utilize only the "viscous + ! model" aspect of Wang and Shen, and use an alternative scheme for + ! continous ice and large ice floes, we allow this through the use + ! of a user-defined namelist parameter "IC3MAXTHK". Floe size is + ! not (at time of writing) an output available from ice model CICE, + ! so we use the ice thickness as a way to anticipate the floe size. + ! When ice thickness exceeds IC3MAXTHK, WW3 will use another model + ! in place of the Wang and Shen formulation : + ! + ! S_ice by F.A., an estimation of dissipation by turbulence + ! at the ice-water interface. It uses only namelists for input, and + ! no space/time varying input (though of course ice concentration is + ! space/time varying). Unlike Liu et al. (IC2), it does not use + ! ice thickness and does not yield a new C|Cg|k (i.e. it is non- + ! dispersive), but it has the very nice feature of not requiring + ! an eddy viscosity, which is a major drawback of the Liu et al. + ! model. That is why we use it here, vs. Liu et al. + ! (S_ice by Liu et al. and S_ice by F.A. are the two options + ! available in IC2, i.e. w3sic2md.ftn) + ! + ! At time of writing (March 23 2015), there may be some problems + ! with the root-selection of IC3. For example with these settings: + ! hice=1 ; rho_ice=917.0 ; emod=4.9e+12 ; visc=5e+7 ; + ! h_water=deep (without using the IC3MAXTHK feature) the solution + ! is rather irregular: + ! T=11.11 k_i = 215.0e-5 + ! T=10 k_i = 266.0e-5 + ! T=9 k_i = 1.4e-5 + ! T=8.1 k_i = 1.7e-5 + ! With hice=0.1, ki is monotonically increasing in that range: + ! T=11.11 k_i = 0.97e-5 + ! T=10 k_i = 2.64e-5 + ! T=9 k_i = 3.90e-5 + ! T=8.1 k_i = 4.47e-5 + ! Of course, when using IC3MAXTHK=0.1, the first example (hice=1) + ! would switch to the "S_ice by F.A." model, and so this problem + ! is circumvented. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D). + ! DEPTH Real I Local water depth. + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! IX,IY I.S. I Grid indices. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). + ! PRT2DS Subr. W3ARRYMD Print plot output (!/T1 switch). + ! OUTMAT Subr. W3ARRYMD Matrix output (!/T2 switch). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A ASCII Point output post-processor. + ! W3EXNC Subr. N/A NetCDF Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! If ice parameter 1 is zero, no calculations are made. + ! + ! Code by S. Cheng sets NOICE=.TRUE. if ISNAN(ICECOEF1). + ! Comments are "maps may not be compatible" + ! This feature is not understood by me (ER) and so omitted. + ! + !/ ------------------------------------------------------------------- / + ! On array size, S. Cheng says: + ! Upon checking the origin of CG, I would say CG = CG_IC3, this is + ! the topic ‘call W3IC3WNCG twice’. Recently I find they are not + ! exactly the same due to calculation and smoothing of cg using + ! several neighbor points. For different input array size, results + ! are slightly different. In subr. w3wave, the size of input arrays + ! is 0:NK+1, while in w3sic3, the size of all input arrays is 1:NK. + ! This array size difference is reflected in the resulting cg. The + ! small difference in cg between calling IC3 twice or just calling + ! once produces small difference in SWH. To eliminate this small + ! difference, I suggest to keep CG instead of CG_IC3, as well as WN, + ! WN_I, because other source terms use CG. I confirmed this change + ! would make results of ICE the same whether calling twice or once + ! by defining dimension WN_R, WN_I, CG_IC3 as 0:NK+1 instead of + ! 1:NK. Then CG_IC3 = CG. + !/ ------------------------------------------------------------------- / + ! On optimization, S. Cheng says: + ! For Wang and Shen’s model, D does not change in the loop + ! corresponding to NSTEPS in subr. W3SRCE. I find the most efficient + ! and easy way to speed up is that Add D and NSTEPS as inputs of + ! W3SIC3 + ! If NSTEPS==1 + ! Current Wang and Shen’s model code above. + ! ELSE + ! S = D*A + ! Endif + !/ ------------------------------------------------------------------- / + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPI, DWAT, ABMIN, DELAB, SIZEFWTABLE, & + FWTABLE, GRAV + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR + ! USE WMMDATMD, ONLY: IMPROC, NMPERR ! WMMDATMD unavailable to outp + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, IC3PARS, DDEN, & + FLAGLL, YGRD, GTYPE, RLGTYPE + USE W3IDATMD, ONLY: ICEP1, ICEP2, ICEP3, ICEP4, ICEP5, ICEI, & + INFLAGS2 #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: CG(NK), WN(NK), A(NSPEC), DEPTH - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) - INTEGER, INTENT(IN) :: IX, IY -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: CG(NK), WN(NK), A(NSPEC), DEPTH + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + INTEGER, INTENT(IN) :: IX, IY + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: ITH + INTEGER :: ITH #ifdef W3_T0 - REAL :: DOUT(NK,NTH) + REAL :: DOUT(NK,NTH) #endif - INTEGER :: IKTH, IK - REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & - ICECOEF4, ICECOEF5, ICECONC - REAL, DIMENSION(NK) :: D1D, WN_I, WN_R, CG_IC3, CG_TMP - LOGICAL :: NOICE - REAL :: VISCM=1.83E-6 - REAL :: FREQ -! ............VISCM=1.83E-6 : molecular viscosity of water at freezing - REAL :: PTURB, PVISC, DTURB, DVISC, & - SMOOTH, RE, UORB, AORB, EB, & - DELI1, DELI2, FW, XI, FTURB, & - MAXTHK, MAXCNC, USE_CHENG, & - USE_CGICE, FIXEDHICE, & - FIXEDVISC,FIXEDDENS,FIXEDELAS - INTEGER :: IND, IS, NUMIN -! -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: IKTH, IK + REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & + ICECOEF4, ICECOEF5, ICECONC + REAL, DIMENSION(NK) :: D1D, WN_I, WN_R, CG_IC3, CG_TMP + LOGICAL :: NOICE + REAL :: VISCM=1.83E-6 + REAL :: FREQ + ! ............VISCM=1.83E-6 : molecular viscosity of water at freezing + REAL :: PTURB, PVISC, DTURB, DVISC, & + SMOOTH, RE, UORB, AORB, EB, & + DELI1, DELI2, FW, XI, FTURB, & + MAXTHK, MAXCNC, USE_CHENG, & + USE_CGICE, FIXEDHICE, & + FIXEDVISC,FIXEDDENS,FIXEDELAS + INTEGER :: IND, IS, NUMIN + ! + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIC3') + CALL STRACE (IENT, 'W3SIC3') #endif -! -! 0. Initializations ------------------------------------------------ / -! -! - D = 0.0 - D1D = 0.0 -! - WN_R = WN - WN_I = 0.0 - CG_IC3 = 0.0 - CG_TMP = 0.0 -! - ICECOEF1 = 0.0 - ICECOEF2 = 0.0 - ICECOEF3 = 0.0 - ICECOEF4 = 0.0 - ICECOEF5 = 0.0 - ICECONC = 0.0 -! -! Rename variables to make code easier to read. - MAXTHK=IC3PARS(1) - MAXCNC=IC3PARS(8) - USE_CHENG=IC3PARS(9) - USE_CGICE=IC3PARS(12) - FIXEDHICE=IC3PARS(13) - FIXEDVISC=IC3PARS(14) - FIXEDDENS=IC3PARS(15) - FIXEDELAS=IC3PARS(16) - -! --- Error checking for input ----------------------------------- / -! --- Allow one and only one input option for each variable ------ / - NUMIN=0 - IF (INFLAGS2(-7)) NUMIN=NUMIN+1 - IF (FIXEDHICE.GE.0.0) NUMIN=NUMIN+1 - IF (NUMIN.NE.1) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,1001) 'ICE PARAMETER 1 (HICE)',NUMIN - CALL EXTCDE(2) - ENDIF + ! + ! 0. Initializations ------------------------------------------------ / + ! + ! + D = 0.0 + D1D = 0.0 + ! + WN_R = WN + WN_I = 0.0 + CG_IC3 = 0.0 + CG_TMP = 0.0 + ! + ICECOEF1 = 0.0 + ICECOEF2 = 0.0 + ICECOEF3 = 0.0 + ICECOEF4 = 0.0 + ICECOEF5 = 0.0 + ICECONC = 0.0 + ! + ! Rename variables to make code easier to read. + MAXTHK=IC3PARS(1) + MAXCNC=IC3PARS(8) + USE_CHENG=IC3PARS(9) + USE_CGICE=IC3PARS(12) + FIXEDHICE=IC3PARS(13) + FIXEDVISC=IC3PARS(14) + FIXEDDENS=IC3PARS(15) + FIXEDELAS=IC3PARS(16) + + ! --- Error checking for input ----------------------------------- / + ! --- Allow one and only one input option for each variable ------ / + NUMIN=0 + IF (INFLAGS2(-7)) NUMIN=NUMIN+1 + IF (FIXEDHICE.GE.0.0) NUMIN=NUMIN+1 + IF (NUMIN.NE.1) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,1001) 'ICE PARAMETER 1 (HICE)',NUMIN + CALL EXTCDE(2) + ENDIF - NUMIN=0 - IF (INFLAGS2(-6)) NUMIN=NUMIN+1 - IF (FIXEDVISC.GE.0.0) NUMIN=NUMIN+1 - IF (NUMIN.NE.1) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,1001) 'ICE PARAMETER 2 (VISC)',NUMIN - CALL EXTCDE(2) - ENDIF + NUMIN=0 + IF (INFLAGS2(-6)) NUMIN=NUMIN+1 + IF (FIXEDVISC.GE.0.0) NUMIN=NUMIN+1 + IF (NUMIN.NE.1) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,1001) 'ICE PARAMETER 2 (VISC)',NUMIN + CALL EXTCDE(2) + ENDIF - NUMIN=0 - IF (INFLAGS2(-5)) NUMIN=NUMIN+1 - IF (FIXEDDENS.GE.0.0) NUMIN=NUMIN+1 - IF (NUMIN.NE.1) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,1001) 'ICE PARAMETER 3 (DENS)',NUMIN - CALL EXTCDE(2) - ENDIF + NUMIN=0 + IF (INFLAGS2(-5)) NUMIN=NUMIN+1 + IF (FIXEDDENS.GE.0.0) NUMIN=NUMIN+1 + IF (NUMIN.NE.1) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,1001) 'ICE PARAMETER 3 (DENS)',NUMIN + CALL EXTCDE(2) + ENDIF - NUMIN=0 - IF (INFLAGS2(-4)) NUMIN=NUMIN+1 - IF (FIXEDELAS.GE.0.0) NUMIN=NUMIN+1 - IF (NUMIN.NE.1) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,1001) 'ICE PARAMETER 4 (ELAS)',NUMIN - CALL EXTCDE(2) - ENDIF + NUMIN=0 + IF (INFLAGS2(-4)) NUMIN=NUMIN+1 + IF (FIXEDELAS.GE.0.0) NUMIN=NUMIN+1 + IF (NUMIN.NE.1) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,1001) 'ICE PARAMETER 4 (ELAS)',NUMIN + CALL EXTCDE(2) + ENDIF -! --- Set local value to be used subsequently (ICEPx variables -! are not used beyond this point). --------------------------- / - IF (INFLAGS2(-7)) THEN - ICECOEF1 = ICEP1(IX,IY) ! ice thickness - ELSE - ICECOEF1 = FIXEDHICE - ENDIF + ! --- Set local value to be used subsequently (ICEPx variables + ! are not used beyond this point). --------------------------- / + IF (INFLAGS2(-7)) THEN + ICECOEF1 = ICEP1(IX,IY) ! ice thickness + ELSE + ICECOEF1 = FIXEDHICE + ENDIF - IF (INFLAGS2(-6)) THEN - ICECOEF2 = ICEP2(IX,IY) ! effective viscosity of ice cover - ELSE - ICECOEF2 = FIXEDVISC - ENDIF + IF (INFLAGS2(-6)) THEN + ICECOEF2 = ICEP2(IX,IY) ! effective viscosity of ice cover + ELSE + ICECOEF2 = FIXEDVISC + ENDIF - IF (INFLAGS2(-5)) THEN - ICECOEF3 = ICEP3(IX,IY) ! density of ice - ELSE - ICECOEF3 = FIXEDDENS - ENDIF + IF (INFLAGS2(-5)) THEN + ICECOEF3 = ICEP3(IX,IY) ! density of ice + ELSE + ICECOEF3 = FIXEDDENS + ENDIF - IF (INFLAGS2(-4)) THEN - ICECOEF4 = ICEP4(IX,IY) ! effective shear modulus of ice - ELSE - ICECOEF4 = FIXEDELAS - ENDIF + IF (INFLAGS2(-4)) THEN + ICECOEF4 = ICEP4(IX,IY) ! effective shear modulus of ice + ELSE + ICECOEF4 = FIXEDELAS + ENDIF -! ICECOEF5 = ICEP5(IX,IY) ! ICEP5 is inactive in W3SIC3 + ! ICECOEF5 = ICEP5(IX,IY) ! ICEP5 is inactive in W3SIC3 - IF (INFLAGS2(4)) ICECONC = ICEI(IX,IY) + IF (INFLAGS2(4)) ICECONC = ICEI(IX,IY) -! -! 1. No ice --------------------------------------------------------- / -! - NOICE=.FALSE. - IF (ICECOEF1==0.0) NOICE=.TRUE. - IF (INFLAGS2(4).AND.(ICECONC==0.0)) NOICE=.TRUE. + ! + ! 1. No ice --------------------------------------------------------- / + ! + NOICE=.FALSE. + IF (ICECOEF1==0.0) NOICE=.TRUE. + IF (INFLAGS2(4).AND.(ICECONC==0.0)) NOICE=.TRUE. - IF ( NOICE ) THEN + IF ( NOICE ) THEN - D1D=0.0 -! -! 2. Ice ------------------------------------------------------------ / - ELSEIF ( USE_CHENG==1.0 .AND. & - ((ICECOEF1.LE.MAXTHK).OR.(ICECONC.LE.MAXCNC)) ) THEN + D1D=0.0 + ! + ! 2. Ice ------------------------------------------------------------ / + ELSEIF ( USE_CHENG==1.0 .AND. & + ((ICECOEF1.LE.MAXTHK).OR.(ICECONC.LE.MAXCNC)) ) THEN -! 2.a Write test output ---------------------------------------------- / + ! 2.a Write test output ---------------------------------------------- / #ifdef W3_T38 - WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 + WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 #endif -! 2.b Make calculations using Cheng routines ------------------------- / - -! --- Input to routine (part 1): 6 ice parameters from single -! precision variables. --------------------------------------- - - CALL W3IC3WNCG_CHENG(WN_R, WN_I, CG_IC3, ICECOEF1, ICECOEF2, & - ICECOEF3, ICECOEF4, DEPTH) -! -! --- calculate source term --------------------------------------- / -! --- see Remarks section re: array size -------------------------- / - IF ( USE_CGICE==1.0 ) THEN - CG_TMP=CG_IC3 - ELSE - CG_TMP=CG - ENDIF - DO IK=1, NK - ! recall that D=S/E=-2*Cg*k_i - D1D(IK)= -2.0 * CG_TMP(IK) * WN_I(IK) - - END DO - - ELSEIF ( (ICECOEF1 .LE. MAXTHK) .OR. (ICECONC .LE. MAXCNC) ) THEN -!.......... e.g. if ice thickness is .le. 10 cm -!...............or concentration is .le. 1.0 -! -! 2.a Write test output ---------------------------------------------- / + ! 2.b Make calculations using Cheng routines ------------------------- / + + ! --- Input to routine (part 1): 6 ice parameters from single + ! precision variables. --------------------------------------- + + CALL W3IC3WNCG_CHENG(WN_R, WN_I, CG_IC3, ICECOEF1, ICECOEF2, & + ICECOEF3, ICECOEF4, DEPTH) + ! + ! --- calculate source term --------------------------------------- / + ! --- see Remarks section re: array size -------------------------- / + IF ( USE_CGICE==1.0 ) THEN + CG_TMP=CG_IC3 + ELSE + CG_TMP=CG + ENDIF + DO IK=1, NK + ! recall that D=S/E=-2*Cg*k_i + D1D(IK)= -2.0 * CG_TMP(IK) * WN_I(IK) + + END DO + + ELSEIF ( (ICECOEF1 .LE. MAXTHK) .OR. (ICECONC .LE. MAXCNC) ) THEN + !.......... e.g. if ice thickness is .le. 10 cm + !...............or concentration is .le. 1.0 + ! + ! 2.a Write test output ---------------------------------------------- / #ifdef W3_T38 - WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 + WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 #endif -! -! 2.b Make calculations using original routines ---------------------- / -! --- Input to routine (part 1): 6 ice parameters from single -! precision variables. --------------------------------------- - - CALL W3IC3WNCG_V1(WN_R, WN_I, CG_IC3, ICECOEF1, ICECOEF2, & - ICECOEF3, ICECOEF4, DEPTH ) -! -! --- calculate source term --------------------------------------- / - IF ( USE_CGICE==1.0 ) THEN - CG_TMP=CG_IC3 - ELSE - CG_TMP=CG - ENDIF - DO IK=1, NK - ! recall that D=S/E=-2*Cg*k_i - D1D(IK)= -2.0 * CG_TMP(IK) * WN_I(IK) - END DO - ! - ELSE ! .. e.g. if ice thickness is .gt. 10 cm - ! Alternative by F.A., see Remarks section. - IF (IC3PARS(2).GT.0.) THEN - UORB=0. - AORB=0. - FTURB = IC3PARS(2) - IF (IC3PARS(7).GT.0) THEN - IF (YGRD(IY,IX).LT.0.AND.GTYPE.EQ.RLGTYPE.AND.FLAGLL) & - FTURB = IC3PARS(7) - END IF - DO IK=1, NK - EB = 0. - DO ITH=1, NTH - IS=ITH+(IK-1)*NTH - EB = EB + A(IS) - END DO - ! - ! UORB and AORB are the variances of the orbital - ! velocity and surface elevation - ! - UORB = UORB + EB *SIG(IK)**2 * DDEN(IK) / CG(IK) - AORB = AORB + EB * DDEN(IK) / CG(IK) - !deep water only - END DO - ! - AORB = 2*SQRT(AORB) ! significant amplitude - UORB = 2*SQRT(UORB) ! significant amplitude - - RE = UORB*AORB / VISCM - SMOOTH = 0.5*TANH((RE-IC3PARS(4))/IC3PARS(5)) - PTURB=(0.5+SMOOTH) - PVISC=(0.5-SMOOTH) - - XI=(ALOG10(MAX(AORB/IC3PARS(3),3.))-ABMIN)/DELAB - IND = MIN (SIZEFWTABLE-1, INT(XI)) - DELI1= MIN (1. ,XI-FLOAT(IND)) - DELI2= 1. - DELI1 - FW =FWTABLE(IND)*DELI2+FWTABLE(IND+1)*DELI1 - DTURB=-1.* FTURB*FW*UORB/GRAV - ELSE ! so case of IC3PARS(2).LE.0. - DTURB = 0. - END IF ! IF (IC3PARS(2).GT.0.) - - DO IK=1, NK - DVISC = -1. *IC3PARS(6) * WN(IK) * SQRT(VISCM* SIG(IK) / 2.) - D1D(IK) = PTURB*DTURB*SIG(IK)**2 + PVISC*DVISC - END DO - - END IF ! IF ( NOICE ) THEN - -! 2.c Fill diagional matrix ------------------------------------------ / -! - DO IKTH=1, NSPEC - D(IKTH) = D1D(MAPWN(IKTH)) - END DO + ! + ! 2.b Make calculations using original routines ---------------------- / + ! --- Input to routine (part 1): 6 ice parameters from single + ! precision variables. --------------------------------------- -! -! sign convention (example): -! S is from -10e-3 to 0 -! A is from 0 to 10 -! See Remarks section re: optimization - S = D * A -! -! ... Test output of arrays -! -#ifdef W3_T0 + CALL W3IC3WNCG_V1(WN_R, WN_I, CG_IC3, ICECOEF1, ICECOEF2, & + ICECOEF3, ICECOEF4, DEPTH ) + ! + ! --- calculate source term --------------------------------------- / + IF ( USE_CGICE==1.0 ) THEN + CG_TMP=CG_IC3 + ELSE + CG_TMP=CG + ENDIF DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + ! recall that D=S/E=-2*Cg*k_i + D1D(IK)= -2.0 * CG_TMP(IK) * WN_I(IK) + END DO + ! + ELSE ! .. e.g. if ice thickness is .gt. 10 cm + ! Alternative by F.A., see Remarks section. + IF (IC3PARS(2).GT.0.) THEN + UORB=0. + AORB=0. + FTURB = IC3PARS(2) + IF (IC3PARS(7).GT.0) THEN + IF (YGRD(IY,IX).LT.0.AND.GTYPE.EQ.RLGTYPE.AND.FLAGLL) & + FTURB = IC3PARS(7) + END IF + DO IK=1, NK + EB = 0. + DO ITH=1, NTH + IS=ITH+(IK-1)*NTH + EB = EB + A(IS) END DO + ! + ! UORB and AORB are the variances of the orbital + ! velocity and surface elevation + ! + UORB = UORB + EB *SIG(IK)**2 * DDEN(IK) / CG(IK) + AORB = AORB + EB * DDEN(IK) / CG(IK) + !deep water only END DO -#endif -! + ! + AORB = 2*SQRT(AORB) ! significant amplitude + UORB = 2*SQRT(UORB) ! significant amplitude + + RE = UORB*AORB / VISCM + SMOOTH = 0.5*TANH((RE-IC3PARS(4))/IC3PARS(5)) + PTURB=(0.5+SMOOTH) + PVISC=(0.5-SMOOTH) + + XI=(ALOG10(MAX(AORB/IC3PARS(3),3.))-ABMIN)/DELAB + IND = MIN (SIZEFWTABLE-1, INT(XI)) + DELI1= MIN (1. ,XI-FLOAT(IND)) + DELI2= 1. - DELI1 + FW =FWTABLE(IND)*DELI2+FWTABLE(IND+1)*DELI1 + DTURB=-1.* FTURB*FW*UORB/GRAV + ELSE ! so case of IC3PARS(2).LE.0. + DTURB = 0. + END IF ! IF (IC3PARS(2).GT.0.) + + DO IK=1, NK + DVISC = -1. *IC3PARS(6) * WN(IK) * SQRT(VISCM* SIG(IK) / 2.) + D1D(IK) = PTURB*DTURB*SIG(IK)**2 + PVISC*DVISC + END DO + + END IF ! IF ( NOICE ) THEN + + ! 2.c Fill diagional matrix ------------------------------------------ / + ! + DO IKTH=1, NSPEC + D(IKTH) = D1D(MAPWN(IKTH)) + END DO + + ! + ! sign convention (example): + ! S is from -10e-3 to 0 + ! A is from 0 to 10 + ! See Remarks section re: optimization + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') #endif -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC3 : '/ & - ' ',A,' REQUIRED ONCE, BUT WAS PROVIDED BY USER '/ & - ' ',I4,' TIMES.'/) -! + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC3 : '/ & + ' ',A,' REQUIRED ONCE, BUT WAS PROVIDED BY USER '/ & + ' ',I4,' TIMES.'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SIC3 : depth and 4 ice coef. : ',5E10.3) +9000 FORMAT (' TEST W3SIC3 : depth and 4 ice coef. : ',5E10.3) #endif -!/ -!/ End of W3SIC3 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SIC3 -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3IC3WNCG_V1(WN_R,WN_I,CG,ICE1,ICE2,ICE3,ICE4,DPT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 25-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ -! 1. Purpose : -! -! Calculation of complex wavenumber for waves in ice. Outsourced -! from W3SIC3 to allow update on wavenumbers and group -! velocities at each time step an ice parameter is updated. -! -! 2. Method : -! -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! WN_R R. A. I/O Wave number (real part) -! WN_I R. A. I/O Wave number (imag. part=wave attenuation) -! CG R. A. I/O Group velocity -! ICE1 REAL I Thickness of ice [in m] -! ICE2 REAL I Effective viscosity of ice [in m2/s] -! ICE3 REAL I Density of ice [in kg/m3] -! ICE4 REAL I Effective shear modulus of ice [in Pa] -! DPT REAL I Water depth [in m] -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WAVNU1 Subr. W3DISPMD Wavenumber for waves in open water. -! WN_CMPLX Func. W3SIC3MD Complex wavenumber for waves in ice. -! WN_CMPLX_HF Func. W3SIC3MD Like WN_CMPLX, but for h-f -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SIC3 Subr. W3SIC3MD Ice source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See FORMAT 900. -! -! 7. Remarks : -! -! Optional: Cap WN_I at 2.0E-4, since in simple tests with "normal -! resolution" (not finer than 1 km), WW3 has trouble resolving the -! dissipation if k_i>2e-4. Also, very large values of dissipation -! (e.g. k_i=100e-4) with IC3 occurs more in the higher frequencies -! which makes WW3 slow down quite a bit. This is done via ICEKILIM -! in the namelists. -! -! This function does not get used in update by S. Cheng. -! It should be removed if/when "V1" routines are removed. -! -! 8. Structure : -! -! See source code. -! -! 9. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - USE W3GDATMD, ONLY: NK, SIG, IC3PARS - USE W3DISPMD, ONLY: WAVNU1 - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE CONSTANTS, ONLY: TPI -!/ - IMPLICIT NONE -!/ - REAL, INTENT(INOUT):: WN_R(:),WN_I(:),CG(:) - REAL, INTENT(IN) :: ICE1, ICE2, ICE3, ICE4, DPT - - INTEGER :: IK, KL,KU - REAL, ALLOCATABLE :: SIGMA(:),CG_IC3(:) - REAL :: K_OCEAN, CG_OCEAN - DOUBLE PRECISION :: KH, K_NOICE, HWAT, HICE, NU, DICE, ES_MOD - DOUBLE PRECISION,PARAMETER :: KHMAX = 18.0D0 ! 18=OK, 19=fails - DOUBLE COMPLEX :: WNCOMPLEX,WNCOMPLEX_OLD - REAL :: STENSEC - REAL :: IC3HILIM,IC3KILIM -! - ALLOCATE( CG_IC3( SIZE(CG) ) ) - ALLOCATE( SIGMA( SIZE(CG) ) ) - CG_IC3 = 0. - SIGMA = 0. - STENSEC=TPI/10.0 ! sigma for T=10 sec - - IC3HILIM=IC3PARS(10) - IC3KILIM=IC3PARS(11) -! -! --- Input to routine (part 1): set 6 double precision variables -! using single precision variables. -------------------------- / - HWAT = DBLE(DPT) ! water depth - HICE = DBLE(ICE1) ! ice thickness - NU = DBLE(ICE2) ! "effective viscosity" parameter - DICE = DBLE(ICE3) ! density of ice - ES_MOD = DBLE(ICE4) ! effective shear modulus of ice - -! Optional: limit ice thickness - HICE=MIN(DBLE(IC3HILIM),HICE) - - IF (SIZE(WN_R,1).EQ.NK) THEN - KL = 1 - KU = NK - SIGMA = SIG(1:NK) - ELSE IF (SIZE(WN_R,1).EQ.NK+2) THEN - KL = 1 - KU = NK+2 - SIGMA = SIG(0:NK+1) - ELSE - WRITE(NDSE,900) - CALL EXTCDE(3) - END IF -! - WNCOMPLEX_OLD=CMPLX(0.0D0,0.0D0) - - DO IK = KL,KU -! --- Input to routine (part 2): set 2 double precision variables -! using single precision variable. --------------------------- / - CALL WAVNU1(SIGMA(IK),DPT,K_OCEAN,CG_OCEAN) - K_NOICE = DBLE(K_OCEAN) -! -! --- Muller Method fails for deep water: workaround follows ----- / - KH = K_NOICE * HWAT ! kh w/out ice - IF (KH.GT.KHMAX) THEN - HWAT = KHMAX / K_NOICE - ENDIF -! --- Calculate complex wavenumber ------------------------------- / - - IF((IK.GT.KL).AND.(SIGMA(IK).GT.STENSEC))THEN - - WNCOMPLEX = WN_CMPLX_HF(DBLE(SIGMA(IK)),K_NOICE,ES_MOD,NU, & - DICE,HICE,HWAT,DBLE(SIGMA(IK-1)),WNCOMPLEX_OLD) - WNCOMPLEX_OLD=WNCOMPLEX - - ELSE + !/ + !/ End of W3SIC3 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SIC3 + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3IC3WNCG_V1(WN_R,WN_I,CG,ICE1,ICE2,ICE3,ICE4,DPT) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 25-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Calculation of complex wavenumber for waves in ice. Outsourced + ! from W3SIC3 to allow update on wavenumbers and group + ! velocities at each time step an ice parameter is updated. + ! + ! 2. Method : + ! + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! WN_R R. A. I/O Wave number (real part) + ! WN_I R. A. I/O Wave number (imag. part=wave attenuation) + ! CG R. A. I/O Group velocity + ! ICE1 REAL I Thickness of ice [in m] + ! ICE2 REAL I Effective viscosity of ice [in m2/s] + ! ICE3 REAL I Density of ice [in kg/m3] + ! ICE4 REAL I Effective shear modulus of ice [in Pa] + ! DPT REAL I Water depth [in m] + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WAVNU1 Subr. W3DISPMD Wavenumber for waves in open water. + ! WN_CMPLX Func. W3SIC3MD Complex wavenumber for waves in ice. + ! WN_CMPLX_HF Func. W3SIC3MD Like WN_CMPLX, but for h-f + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SIC3 Subr. W3SIC3MD Ice source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See FORMAT 900. + ! + ! 7. Remarks : + ! + ! Optional: Cap WN_I at 2.0E-4, since in simple tests with "normal + ! resolution" (not finer than 1 km), WW3 has trouble resolving the + ! dissipation if k_i>2e-4. Also, very large values of dissipation + ! (e.g. k_i=100e-4) with IC3 occurs more in the higher frequencies + ! which makes WW3 slow down quite a bit. This is done via ICEKILIM + ! in the namelists. + ! + ! This function does not get used in update by S. Cheng. + ! It should be removed if/when "V1" routines are removed. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD, ONLY: NK, SIG, IC3PARS + USE W3DISPMD, ONLY: WAVNU1 + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE CONSTANTS, ONLY: TPI + !/ + IMPLICIT NONE + !/ + REAL, INTENT(INOUT):: WN_R(:),WN_I(:),CG(:) + REAL, INTENT(IN) :: ICE1, ICE2, ICE3, ICE4, DPT + + INTEGER :: IK, KL,KU + REAL, ALLOCATABLE :: SIGMA(:),CG_IC3(:) + REAL :: K_OCEAN, CG_OCEAN + DOUBLE PRECISION :: KH, K_NOICE, HWAT, HICE, NU, DICE, ES_MOD + DOUBLE PRECISION,PARAMETER :: KHMAX = 18.0D0 ! 18=OK, 19=fails + DOUBLE COMPLEX :: WNCOMPLEX,WNCOMPLEX_OLD + REAL :: STENSEC + REAL :: IC3HILIM,IC3KILIM + ! + ALLOCATE( CG_IC3( SIZE(CG) ) ) + ALLOCATE( SIGMA( SIZE(CG) ) ) + CG_IC3 = 0. + SIGMA = 0. + STENSEC=TPI/10.0 ! sigma for T=10 sec + + IC3HILIM=IC3PARS(10) + IC3KILIM=IC3PARS(11) + ! + ! --- Input to routine (part 1): set 6 double precision variables + ! using single precision variables. -------------------------- / + HWAT = DBLE(DPT) ! water depth + HICE = DBLE(ICE1) ! ice thickness + NU = DBLE(ICE2) ! "effective viscosity" parameter + DICE = DBLE(ICE3) ! density of ice + ES_MOD = DBLE(ICE4) ! effective shear modulus of ice + + ! Optional: limit ice thickness + HICE=MIN(DBLE(IC3HILIM),HICE) + + IF (SIZE(WN_R,1).EQ.NK) THEN + KL = 1 + KU = NK + SIGMA = SIG(1:NK) + ELSE IF (SIZE(WN_R,1).EQ.NK+2) THEN + KL = 1 + KU = NK+2 + SIGMA = SIG(0:NK+1) + ELSE + WRITE(NDSE,900) + CALL EXTCDE(3) + END IF + ! + WNCOMPLEX_OLD=CMPLX(0.0D0,0.0D0) + + DO IK = KL,KU + ! --- Input to routine (part 2): set 2 double precision variables + ! using single precision variable. --------------------------- / + CALL WAVNU1(SIGMA(IK),DPT,K_OCEAN,CG_OCEAN) + K_NOICE = DBLE(K_OCEAN) + ! + ! --- Muller Method fails for deep water: workaround follows ----- / + KH = K_NOICE * HWAT ! kh w/out ice + IF (KH.GT.KHMAX) THEN + HWAT = KHMAX / K_NOICE + ENDIF + ! --- Calculate complex wavenumber ------------------------------- / - WNCOMPLEX = WN_CMPLX_V1(DBLE(SIGMA(IK)),K_NOICE,ES_MOD,NU, & - DICE,HICE,HWAT) - WNCOMPLEX_OLD=WNCOMPLEX + IF((IK.GT.KL).AND.(SIGMA(IK).GT.STENSEC))THEN - ENDIF + WNCOMPLEX = WN_CMPLX_HF(DBLE(SIGMA(IK)),K_NOICE,ES_MOD,NU, & + DICE,HICE,HWAT,DBLE(SIGMA(IK-1)),WNCOMPLEX_OLD) + WNCOMPLEX_OLD=WNCOMPLEX -! --- Output from function is type of DOUBLE COMPLEX. Set -! precision of imaginary to single precision array element --- / - WN_I(IK) = REAL(AIMAG(WNCOMPLEX)) + ELSE -! Optional : limit ki - WN_I(IK) = MIN(WN_I(IK),IC3KILIM) ! see Remarks above - WN_R(IK) = REAL(WNCOMPLEX) + WNCOMPLEX = WN_CMPLX_V1(DBLE(SIGMA(IK)),K_NOICE,ES_MOD,NU, & + DICE,HICE,HWAT) + WNCOMPLEX_OLD=WNCOMPLEX - END DO -! --- Update group velocitiy ---- - CG_IC3 = DELTA(SIGMA) / DELTA(WN_R) - CG = CG_IC3 - - DEALLOCATE(CG_IC3) -! - 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC3_W3IC3WNCG : '/& - ' CANNOT DETERMINE BOUNDS OF WAVENUMBER ARRAY.') -! -!/ - END SUBROUTINE W3IC3WNCG_V1 -!/ ------------------------------------------------------------------- / -!/ - FUNCTION WN_CMPLX_V1(SIGMA,WN_O,ES,NU,DICE,HICE,DEPTH) RESULT(WN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) -!/ -! 1. Purpose : -! -! Calculate complex wavenumber for waves in ice. -! -! 2. Method : -! -! Wang and Shen (JGR 2010) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! WN CMPLX DBL O Wave number (imag. part=wave attenuation) -! SIGMA REAL DBL I Wave angular frequency [in rad] -! WN_O REAL DBL I Wave number (open water) -! ES REAL DBL I Effective shear modulus of ice [in Pa] -! NU REAL DBL I Effective viscosity of ice [in m2/s] -! DICE REAL DBL I Density of ice [in kg/m3] -! HICE REAL DBL I Thickness of ice [in m] -! DEPTH REAL DBL I Water depth [in m] -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! CMPLX_ROOT_MULLER_CHENG Func. W3SIC3MD Find root for complex -! wavenumbers for waves in ice. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IC3WNCG_V1 Subr. W3SIC3MD Ice source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! -! Hayley Shen says, -! We have determined that it may not be necessary to use curve -! fitting or lookup tables to get the group velocity and the -! attenuation coefficient. Attached is a short report with some -! sample numerical solutions. To implement the viscoelastic model, -! there are 4 fortran programs. According to Xin Zhao, the graduate -! student, it is very fast to find roots. I suggest that perhaps you -! try the pure viscous case by setting G=0 to start with. nu can be -! set at 0.05*ice concentration (m^2/s) to begin with, because for -! grease ice Newyear's data showed nu to be about 0.02-0.03 m^2/s. -! By setting G=0 in you get exactly the Keller model for pure -! viscous layer. -! -! This routine provides the initial guess according to the parameters -! of the present case. T>10s use open water, T<10s cases, calculate -! T=10s first using open water as the initial guess. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPI -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - DOUBLE PRECISION, INTENT(IN) :: SIGMA,WN_O,ES,NU,DICE,HICE,DEPTH - DOUBLE COMPLEX :: WN ! RESULT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, NSUB - DOUBLE PRECISION :: TT, TS, T - DOUBLE COMPLEX :: X0, X1, X2, WN0 -!/ -!/ ------------------------------------------------------------------- / - T = DBLE(TPI) / SIGMA - TS = 10. - NSUB = INT((TS-T) * 10.) -!/ - IF (HICE<0.001) THEN - WN = CMPLX(WN_O,0.) - ELSE IF (T.LT.TS) THEN - X0 = 0.01 - X1 = 0.1 - X2 = 1.0 - WN0 = CMPLX_ROOT_MULLER_V1(X0,X1,X2,0,DBLE(TPI)/TS, & - ES,NU,DICE,HICE,DEPTH ) - X0 = 0.90 * WN0 - X1 = WN0 - X2 = 1.1*WN0 - WN = CMPLX_ROOT_MULLER_V1(X0,X1,X2,1,DBLE(TPI)/TS, & - ES,NU,DICE,HICE,DEPTH ) - DO I=1,NSUB - X0 = 0.90 * WN - X1 = WN - X2 = 1.1 * WN - TT = TS - (TS-T) / REAL(NSUB) * REAL(I) - WN = CMPLX_ROOT_MULLER_V1(X0,X1,X2,1,DBLE(TPI)/TT, & - ES,NU,DICE,HICE,DEPTH ) - ENDDO - ELSE - X0 = 0.01 - X1 = 0.1 - X2 = 1.0 - WN0 = CMPLX_ROOT_MULLER_V1(X0,X1,X2,0,SIGMA, & - ES,NU,DICE,HICE,DEPTH ) - X0 = 0.8 * WN0 - X1 = WN0 - X2 = 1.2 * WN0 - WN = CMPLX_ROOT_MULLER_V1(X0,X1,X2,1,SIGMA, & - ES,NU,DICE,HICE,DEPTH ) - ENDIF -!/ - END FUNCTION WN_CMPLX_V1 -!/ ------------------------------------------------------------------- / -!/ - FUNCTION WN_CMPLX_HF(SIGMA,WN_O,ES,NU,DICE,HICE,DEPTH,SIGMA_LAST, & - WN_LAST) RESULT(WN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. Shen | -!/ | E. Rogers | -!/ | FORTRAN 90 | -!/ | Last update : 17-Apr-2014 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-2014 : Origination (from WN_CMPLXA.f90) (H. Shen) -!/ 17-Apr-2014 : Import to WW3 (E. Rogers) -!/ -! 1. Purpose : -! -! Calculate complex wavenumber for waves in ice. -! -! 2. Method : -! -! Wang and Shen (JGR 2010) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! WN CMPLX DBL O Wave number (imag. part=wave attenuation) -! SIGMA REAL DBL I Wave angular frequency [in rad] -! WN_O REAL DBL I Wave number (open water) -! ES REAL DBL I Effective shear modulus of ice [in Pa] -! NU REAL DBL I Effective viscosity of ice [in m2/s] -! DICE REAL DBL I Density of ice [in kg/m3] -! HICE REAL DBL I Thickness of ice [in m] -! DEPTH REAL DBL I Water depth [in m] -! SIGMA_LAST REAL DBL I : Like SIGMA, but of last IK -! WN_LAST REAL DBL I : WN_O of last IK -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! CMPLX_ROOT_MULLER_CHENG Func. W3SIC3MD Find root for complex -! wavenumbers for waves in ice. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IC3WNCG_V1 Subr. W3SIC3MD Ice source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Original authors: Zhao and Shen. -! See notes in FUNCTION WN_CMPLX, not repeated here. -! New in this function, Hayley Shen says (Jan 15 2014) : -! "To speed up the computation, we need to add a new function -! WN_CMPLXA (attached) into the earlier version of the MODULE -! W3SIC3MD. When wave period T>=10s, we call old function WN_CMPLX -! directly. When T<10s, call the new function WN_CMPLXA with last -! calculation step's information: last complex wave number, last -! angular wave frequency. The calculation should be from large T -! to small T." -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! - USE CONSTANTS, ONLY: TPI -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - DOUBLE PRECISION, INTENT(IN) :: SIGMA,WN_O,ES,NU,DICE,HICE,DEPTH - DOUBLE PRECISION, INTENT(IN) :: SIGMA_LAST - DOUBLE COMPLEX, INTENT(IN) :: WN_LAST - DOUBLE COMPLEX :: WN ! RESULT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, NSUB - DOUBLE PRECISION :: TT, TS, T - DOUBLE COMPLEX :: X0, X1, X2, WN0 -!/ -!/ ------------------------------------------------------------------- / - T = DBLE(TPI) / SIGMA - TS = DBLE(TPI) / SIGMA_LAST - NSUB = INT((TS-T) * 10.) -!/ - IF (HICE<0.001) THEN - WN = CMPLX(WN_O,0.) - ELSE - X0 = 0.90 * WN_LAST - X1 = WN_LAST - X2 = 1.1 * WN_LAST - WN = CMPLX_ROOT_MULLER_V1(X0,X1,X2,1,DBLE(TPI)/TS, & - ES,NU,DICE,HICE,DEPTH ) - DO I=1,NSUB - X0 = 0.90 * WN - X1 = WN - X2 = 1.1 * WN - TT = TS - (TS-T) / REAL(NSUB) * REAL(I) - WN = CMPLX_ROOT_MULLER_V1(X0,X1,X2,1,DBLE(TPI)/TT, & - ES,NU,DICE,HICE,DEPTH ) - ENDDO ENDIF -!/ - END FUNCTION WN_CMPLX_HF -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / -!/ - FUNCTION CMPLX_ROOT_MULLER_V1(X0, X1, X2, JUDGE, SIGMA, ES, NU, & - DICE, HICE, DEPTH) RESULT(P3) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) -!/ -! 1. Purpose : -! -! Find root. -! -! 2. Method : -! -! Muller method for complex equations is a recursive approximation -! with initial guess X0, X1, and X2. To the initial guesses a -! quadratic parabola is fitted. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! P3 CMPLX DBL O Approximation for the root problem -! X0 CMPLX DBL I Initial guess variable -! X1 CMPLX DBL I Initial guess variable -! X2 CMPLX DBL I Initial guess variable -! JUDGE INTEGER I "switch variable" for F_ZHAO -! SIGMA DOUBLE I Wave angular frequency -! ES DOUBLE I Effective shear modulus of ice -! NU DOUBLE I Effective viscosity of ice [in m2/s] -! DICE DOUBLE I Density of ice [in kg/m3] -! HICE DOUBLE I Thickness of ice [in m] -! DEPTH DOUBLE I Water depth [in m] -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! Name Type Module Description -! ---------------------------------------------------------------- -! F_ZHAO Func. W3SIC3MD Wrapper function for root finding. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WN_CMPLX_V1 Find root for complex wave- -! WN_CMPLX_HF numbers for waves in ice. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - DOUBLE COMPLEX :: P3 ! RESULT - DOUBLE COMPLEX, INTENT(IN) :: X0,X1,X2 - DOUBLE PRECISION, INTENT(IN) :: SIGMA,ES,NU,DICE,HICE,DEPTH - INTEGER, INTENT(IN) :: JUDGE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I - INTEGER, PARAMETER :: IMAX = 1000 - DOUBLE PRECISION :: DLTA,EPSI - DOUBLE COMPLEX :: P0,P1,P2 - DOUBLE COMPLEX :: Y0,Y1,Y2,Y3 - DOUBLE COMPLEX :: A,B,C,Q,DISC,DEN1,DEN2 -!/ -!/ ------------------------------------------------------------------- / - P0 = X0 - P1 = X1 - P2 = X2 - P3 = 0.0 -! - I = 0 - EPSI = 1.E-5 - DLTA = 1.E-5 - Y0 = F_ZHAO_V1(P0,JUDGE,SIGMA,ES,NU,DICE,HICE,DEPTH) - Y1 = F_ZHAO_V1(P1,JUDGE,SIGMA,ES,NU,DICE,HICE,DEPTH) - Y2 = F_ZHAO_V1(P2,JUDGE,SIGMA,ES,NU,DICE,HICE,DEPTH) -! - DO I = 1,IMAX - Q = (P2 - P1) / (P1 - P0) - A = Q * Y2 - Q * (1.+Q) * Y1 + Q**2. * Y0 - B = (2. * Q + 1.) * Y2 - (1 + Q)**2. * Y1 + Q**2. * Y0 - C = (1. + Q) * Y2 -! - IF ( ABS(A).NE.0. ) THEN - - DISC = B**2. - 4 * A * C; -! - DEN1 = ( B + SQRT ( DISC ) ) - DEN2 = ( B - SQRT ( DISC ) ) -! - IF ( ABS ( DEN1 ) .LT. ABS ( DEN2 ) )THEN - P3 = P2 - (P2 - P1) * (2 * C / DEN2) - ELSE - P3 = P2 - (P2 - P1) * (2 * C / DEN1) - ENDIF -! - ELSE -! - IF ( ABS(B) .NE. 0. )THEN - P3 = P2 - (P2 - P1) * (C / B) - ELSE - WRITE(NDSE,800) - WRITE(NDSE,801)X0,X1,X2 - WRITE(NDSE,802)SIGMA,ES,NU,DICE,HICE,DEPTH - WRITE(NDSE,803)JUDGE - CALL EXTCDE(2) - ENDIF - ENDIF - - Y3 = F_ZHAO_V1(P3,JUDGE,SIGMA,ES,NU,DICE,HICE,DEPTH); - - IF ( ABS(P3-P2).LT.DLTA .OR. ABS(Y3).LT.EPSI ) THEN - RETURN - ENDIF - - P0 = P1 - P1 = P2 - P2 = P3 - - Y0 = Y1 - Y1 = Y2 - Y2 = Y3 + ! --- Output from function is type of DOUBLE COMPLEX. Set + ! precision of imaginary to single precision array element --- / + WN_I(IK) = REAL(AIMAG(WNCOMPLEX)) + + ! Optional : limit ki + WN_I(IK) = MIN(WN_I(IK),IC3KILIM) ! see Remarks above + WN_R(IK) = REAL(WNCOMPLEX) + + END DO + ! --- Update group velocitiy ---- + CG_IC3 = DELTA(SIGMA) / DELTA(WN_R) + CG = CG_IC3 + + DEALLOCATE(CG_IC3) + ! +900 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC3_W3IC3WNCG : '/& + ' CANNOT DETERMINE BOUNDS OF WAVENUMBER ARRAY.') + ! + !/ + END SUBROUTINE W3IC3WNCG_V1 + !/ ------------------------------------------------------------------- / + !/ + FUNCTION WN_CMPLX_V1(SIGMA,WN_O,ES,NU,DICE,HICE,DEPTH) RESULT(WN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Calculate complex wavenumber for waves in ice. + ! + ! 2. Method : + ! + ! Wang and Shen (JGR 2010) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! WN CMPLX DBL O Wave number (imag. part=wave attenuation) + ! SIGMA REAL DBL I Wave angular frequency [in rad] + ! WN_O REAL DBL I Wave number (open water) + ! ES REAL DBL I Effective shear modulus of ice [in Pa] + ! NU REAL DBL I Effective viscosity of ice [in m2/s] + ! DICE REAL DBL I Density of ice [in kg/m3] + ! HICE REAL DBL I Thickness of ice [in m] + ! DEPTH REAL DBL I Water depth [in m] + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! CMPLX_ROOT_MULLER_CHENG Func. W3SIC3MD Find root for complex + ! wavenumbers for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IC3WNCG_V1 Subr. W3SIC3MD Ice source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Original authors: Zhao and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on April 19 2013. + ! + ! Hayley Shen says, + ! We have determined that it may not be necessary to use curve + ! fitting or lookup tables to get the group velocity and the + ! attenuation coefficient. Attached is a short report with some + ! sample numerical solutions. To implement the viscoelastic model, + ! there are 4 fortran programs. According to Xin Zhao, the graduate + ! student, it is very fast to find roots. I suggest that perhaps you + ! try the pure viscous case by setting G=0 to start with. nu can be + ! set at 0.05*ice concentration (m^2/s) to begin with, because for + ! grease ice Newyear's data showed nu to be about 0.02-0.03 m^2/s. + ! By setting G=0 in you get exactly the Keller model for pure + ! viscous layer. + ! + ! This routine provides the initial guess according to the parameters + ! of the present case. T>10s use open water, T<10s cases, calculate + ! T=10s first using open water as the initial guess. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPI + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + DOUBLE PRECISION, INTENT(IN) :: SIGMA,WN_O,ES,NU,DICE,HICE,DEPTH + DOUBLE COMPLEX :: WN ! RESULT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, NSUB + DOUBLE PRECISION :: TT, TS, T + DOUBLE COMPLEX :: X0, X1, X2, WN0 + !/ + !/ ------------------------------------------------------------------- / + T = DBLE(TPI) / SIGMA + TS = 10. + NSUB = INT((TS-T) * 10.) + !/ + IF (HICE<0.001) THEN + WN = CMPLX(WN_O,0.) + ELSE IF (T.LT.TS) THEN + X0 = 0.01 + X1 = 0.1 + X2 = 1.0 + WN0 = CMPLX_ROOT_MULLER_V1(X0,X1,X2,0,DBLE(TPI)/TS, & + ES,NU,DICE,HICE,DEPTH ) + X0 = 0.90 * WN0 + X1 = WN0 + X2 = 1.1*WN0 + WN = CMPLX_ROOT_MULLER_V1(X0,X1,X2,1,DBLE(TPI)/TS, & + ES,NU,DICE,HICE,DEPTH ) + DO I=1,NSUB + X0 = 0.90 * WN + X1 = WN + X2 = 1.1 * WN + TT = TS - (TS-T) / REAL(NSUB) * REAL(I) + WN = CMPLX_ROOT_MULLER_V1(X0,X1,X2,1,DBLE(TPI)/TT, & + ES,NU,DICE,HICE,DEPTH ) ENDDO -! - WRITE(NDSE,800) - WRITE(NDSE,801)X0,X1,X2 - WRITE(NDSE,802)SIGMA,ES,NU,DICE,HICE,DEPTH - WRITE(NDSE,803)JUDGE - CALL EXTCDE(2) -! - 800 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC3_CMPLX_ROOT_MULLER'/& - ' : MULLER METHOD FAILED TO FIND ROOT.' ) - 801 FORMAT (/'X0,X1,X2 = ',3(1X,'(',F10.5,',',F10.5,')')) - 802 FORMAT (/'SIGMA,ES,NU,DICE,HICE,DEPTH = ',6(1X,F10.5)) - 803 FORMAT (/'JUDGE = ',I5) -!/ - END FUNCTION CMPLX_ROOT_MULLER_V1 -!/ ------------------------------------------------------------------- / -!/ - FUNCTION F_ZHAO_V1(X,JUDGE,SIGMA,ES,NU,DICE,HICE,DEPTH) & - RESULT(FZHAO) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) -!/ -! 1. Purpose : -! -! Decide whether to call sub-function. -! -! 2. Method : -! -! Decide based on value of integer "JUDGE" -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FZHAO COMPL8 O Result (double complex) -! X CMPLX8 I Approximate result (double complex) -! JUDGE INTEGR I Switch variable -! SIGMA DOUBLE I Wave angular frequency -! ES DOUBLE I Effective shear modulus -! NU DOUBLE I Effective viscosity parameter -! DICE DOUBLE I Density of ice -! HICE DOUBLE I Thickness of ice -! DEPTH DOUBLE I Water depth -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! FUNC0_ZHAO Func. W3SIC3MD Function to find root. -! FUNC1_ZHAO Func. W3SIC3MD Function to find root. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! CMPLX_ROOT_MULLER_V1 Func. W3SIC3MD Find root for complex wave- -! numbers for waves in ice. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: JUDGE - DOUBLE PRECISION, INTENT(IN) :: SIGMA,ES,NU,DICE,HICE,DEPTH - DOUBLE COMPLEX, INTENT(IN) :: X - DOUBLE COMPLEX :: FZHAO ! RESULT -!/ -!/ ------------------------------------------------------------------- / - IF (JUDGE.EQ.0) THEN - FZHAO = FUNC0_ZHAO(X,SIGMA,DEPTH) + ELSE + X0 = 0.01 + X1 = 0.1 + X2 = 1.0 + WN0 = CMPLX_ROOT_MULLER_V1(X0,X1,X2,0,SIGMA, & + ES,NU,DICE,HICE,DEPTH ) + X0 = 0.8 * WN0 + X1 = WN0 + X2 = 1.2 * WN0 + WN = CMPLX_ROOT_MULLER_V1(X0,X1,X2,1,SIGMA, & + ES,NU,DICE,HICE,DEPTH ) + ENDIF + !/ + END FUNCTION WN_CMPLX_V1 + !/ ------------------------------------------------------------------- / + !/ + FUNCTION WN_CMPLX_HF(SIGMA,WN_O,ES,NU,DICE,HICE,DEPTH,SIGMA_LAST, & + WN_LAST) RESULT(WN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. Shen | + !/ | E. Rogers | + !/ | FORTRAN 90 | + !/ | Last update : 17-Apr-2014 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-2014 : Origination (from WN_CMPLXA.f90) (H. Shen) + !/ 17-Apr-2014 : Import to WW3 (E. Rogers) + !/ + ! 1. Purpose : + ! + ! Calculate complex wavenumber for waves in ice. + ! + ! 2. Method : + ! + ! Wang and Shen (JGR 2010) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! WN CMPLX DBL O Wave number (imag. part=wave attenuation) + ! SIGMA REAL DBL I Wave angular frequency [in rad] + ! WN_O REAL DBL I Wave number (open water) + ! ES REAL DBL I Effective shear modulus of ice [in Pa] + ! NU REAL DBL I Effective viscosity of ice [in m2/s] + ! DICE REAL DBL I Density of ice [in kg/m3] + ! HICE REAL DBL I Thickness of ice [in m] + ! DEPTH REAL DBL I Water depth [in m] + ! SIGMA_LAST REAL DBL I : Like SIGMA, but of last IK + ! WN_LAST REAL DBL I : WN_O of last IK + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! CMPLX_ROOT_MULLER_CHENG Func. W3SIC3MD Find root for complex + ! wavenumbers for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IC3WNCG_V1 Subr. W3SIC3MD Ice source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Original authors: Zhao and Shen. + ! See notes in FUNCTION WN_CMPLX, not repeated here. + ! New in this function, Hayley Shen says (Jan 15 2014) : + ! "To speed up the computation, we need to add a new function + ! WN_CMPLXA (attached) into the earlier version of the MODULE + ! W3SIC3MD. When wave period T>=10s, we call old function WN_CMPLX + ! directly. When T<10s, call the new function WN_CMPLXA with last + ! calculation step's information: last complex wave number, last + ! angular wave frequency. The calculation should be from large T + ! to small T." + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + USE CONSTANTS, ONLY: TPI + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + DOUBLE PRECISION, INTENT(IN) :: SIGMA,WN_O,ES,NU,DICE,HICE,DEPTH + DOUBLE PRECISION, INTENT(IN) :: SIGMA_LAST + DOUBLE COMPLEX, INTENT(IN) :: WN_LAST + DOUBLE COMPLEX :: WN ! RESULT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, NSUB + DOUBLE PRECISION :: TT, TS, T + DOUBLE COMPLEX :: X0, X1, X2, WN0 + !/ + !/ ------------------------------------------------------------------- / + T = DBLE(TPI) / SIGMA + TS = DBLE(TPI) / SIGMA_LAST + NSUB = INT((TS-T) * 10.) + !/ + IF (HICE<0.001) THEN + WN = CMPLX(WN_O,0.) + ELSE + X0 = 0.90 * WN_LAST + X1 = WN_LAST + X2 = 1.1 * WN_LAST + WN = CMPLX_ROOT_MULLER_V1(X0,X1,X2,1,DBLE(TPI)/TS, & + ES,NU,DICE,HICE,DEPTH ) + DO I=1,NSUB + X0 = 0.90 * WN + X1 = WN + X2 = 1.1 * WN + TT = TS - (TS-T) / REAL(NSUB) * REAL(I) + WN = CMPLX_ROOT_MULLER_V1(X0,X1,X2,1,DBLE(TPI)/TT, & + ES,NU,DICE,HICE,DEPTH ) + ENDDO + ENDIF + !/ + END FUNCTION WN_CMPLX_HF + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + !/ + FUNCTION CMPLX_ROOT_MULLER_V1(X0, X1, X2, JUDGE, SIGMA, ES, NU, & + DICE, HICE, DEPTH) RESULT(P3) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Find root. + ! + ! 2. Method : + ! + ! Muller method for complex equations is a recursive approximation + ! with initial guess X0, X1, and X2. To the initial guesses a + ! quadratic parabola is fitted. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! P3 CMPLX DBL O Approximation for the root problem + ! X0 CMPLX DBL I Initial guess variable + ! X1 CMPLX DBL I Initial guess variable + ! X2 CMPLX DBL I Initial guess variable + ! JUDGE INTEGER I "switch variable" for F_ZHAO + ! SIGMA DOUBLE I Wave angular frequency + ! ES DOUBLE I Effective shear modulus of ice + ! NU DOUBLE I Effective viscosity of ice [in m2/s] + ! DICE DOUBLE I Density of ice [in kg/m3] + ! HICE DOUBLE I Thickness of ice [in m] + ! DEPTH DOUBLE I Water depth [in m] + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! F_ZHAO Func. W3SIC3MD Wrapper function for root finding. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WN_CMPLX_V1 Find root for complex wave- + ! WN_CMPLX_HF numbers for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Original authors: Zhao and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on April 19 2013. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + DOUBLE COMPLEX :: P3 ! RESULT + DOUBLE COMPLEX, INTENT(IN) :: X0,X1,X2 + DOUBLE PRECISION, INTENT(IN) :: SIGMA,ES,NU,DICE,HICE,DEPTH + INTEGER, INTENT(IN) :: JUDGE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I + INTEGER, PARAMETER :: IMAX = 1000 + DOUBLE PRECISION :: DLTA,EPSI + DOUBLE COMPLEX :: P0,P1,P2 + DOUBLE COMPLEX :: Y0,Y1,Y2,Y3 + DOUBLE COMPLEX :: A,B,C,Q,DISC,DEN1,DEN2 + !/ + !/ ------------------------------------------------------------------- / + P0 = X0 + P1 = X1 + P2 = X2 + P3 = 0.0 + ! + I = 0 + EPSI = 1.E-5 + DLTA = 1.E-5 + Y0 = F_ZHAO_V1(P0,JUDGE,SIGMA,ES,NU,DICE,HICE,DEPTH) + Y1 = F_ZHAO_V1(P1,JUDGE,SIGMA,ES,NU,DICE,HICE,DEPTH) + Y2 = F_ZHAO_V1(P2,JUDGE,SIGMA,ES,NU,DICE,HICE,DEPTH) + ! + DO I = 1,IMAX + Q = (P2 - P1) / (P1 - P0) + A = Q * Y2 - Q * (1.+Q) * Y1 + Q**2. * Y0 + B = (2. * Q + 1.) * Y2 - (1 + Q)**2. * Y1 + Q**2. * Y0 + C = (1. + Q) * Y2 + ! + IF ( ABS(A).NE.0. ) THEN + + DISC = B**2. - 4 * A * C; + ! + DEN1 = ( B + SQRT ( DISC ) ) + DEN2 = ( B - SQRT ( DISC ) ) + ! + IF ( ABS ( DEN1 ) .LT. ABS ( DEN2 ) )THEN + P3 = P2 - (P2 - P1) * (2 * C / DEN2) + ELSE + P3 = P2 - (P2 - P1) * (2 * C / DEN1) + ENDIF + ! ELSE - FZHAO = FUNC1_ZHAO(X,SIGMA,ES,NU,DICE,HICE,DEPTH) + ! + IF ( ABS(B) .NE. 0. )THEN + P3 = P2 - (P2 - P1) * (C / B) + ELSE + WRITE(NDSE,800) + WRITE(NDSE,801)X0,X1,X2 + WRITE(NDSE,802)SIGMA,ES,NU,DICE,HICE,DEPTH + WRITE(NDSE,803)JUDGE + CALL EXTCDE(2) + ENDIF ENDIF -! - END FUNCTION F_ZHAO_V1 -!/ ------------------------------------------------------------------- / -!/ - FUNCTION FUNC0_ZHAO(WN, SIGMA, DEPTH) RESULT(FUNC0) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) -!/ -! 1. Purpose : -! -! Calculate the difference between the left and right side -! of the dispersion relation. It is called by the Muller method. -! -! 2. Method : -! -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FUNC0 COMPL DBL O Result (double complex) -! WN CMPLX DBL I Complex wavenumber -! SIGMA DOUBLE I Wave angular frequency -! DEPTH DOUBLE I Water depth [in m] -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! F_ZHAO_V1 Func. W3SIC3MD Function for computation of complex -! wavenumbers for waves in ice. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! -! This function does not get used in update by S. Cheng. -! It should be removed if/when "V1" routines are removed. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - DOUBLE COMPLEX, INTENT(IN) :: WN - DOUBLE PRECISION, INTENT(IN) :: SIGMA, DEPTH - DOUBLE COMPLEX :: FUNC0 ! RESULT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - DOUBLE COMPLEX :: TH -!/ -!/ ------------------------------------------------------------------- / - IF (REAL(WN*DEPTH).LE.4.) THEN - TH = (EXP(WN*DEPTH)-EXP(-WN*DEPTH)) & - / (EXP(WN*DEPTH)+EXP(-WN*DEPTH)) - FUNC0 = SIGMA**2. - TH * WN * DBLE(GRAV) - ELSE - FUNC0 = SIGMA**2. - WN * DBLE(GRAV) - END IF -!/ - END FUNCTION FUNC0_ZHAO -!/ ------------------------------------------------------------------- / -!/ - FUNCTION FUNC1_ZHAO(WN,SIGMA,ES,NU,DICE,HICE,DEPTH) RESULT(FUNC1) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 11-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) -!/ -! 1. Purpose : -! -! -! -! 2. Method : -! -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FUNC1 CMPLX DBL O Result (double complex) -! WN CMPLX DBL I Wavenumber (double complex) -! W REAL DBL I Wave angular frequency -! ES REAL DBL I Effective shear modulus on ice -! NU REAL DBL I Effective viscosity -! DICE REAL DBL I Density of ice -! HICE REAL DBL I Thickness of ice -! DEPTH REAL DBL I Water depth -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! BSDET Func. W3SIC3MD Calculates the determinant for the -! dispersion relation. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! F_ZHAO_V1 Func. W3SIC3MD Function for computation of complex -! wavenumbers for waves in ice. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! -! This function does not get used in update by S. Cheng. -! It should be removed if/when "V1" routines are removed. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, DWAT -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - DOUBLE COMPLEX, INTENT(IN) :: WN - DOUBLE PRECISION, INTENT(IN) :: SIGMA, ES, NU, DICE, HICE, DEPTH - DOUBLE COMPLEX :: FUNC1 ! RESULT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - DOUBLE COMPLEX :: VE,ALPHA,N,M,L,SK,CK,SA,CA,TH,THH - DOUBLE COMPLEX :: AA(4,4) -!/ -!/ ------------------------------------------------------------------- / - VE = CMPLX( NU, ES/DICE/SIGMA ) - ALPHA = SQRT ( WN**2. - SIGMA/VE * CMPLX(0.,1.) ) - N = SIGMA + 2. * VE * WN**2. * CMPLX(0.,1.) - L = 2 * WN * ALPHA * SIGMA * VE - SK = (EXP(WN*HICE)-EXP(-WN*HICE))/2. - CK = (EXP(WN*HICE)+EXP(-WN*HICE))/2. - SA = (EXP(ALPHA*HICE)-EXP(-ALPHA*HICE))/2. - CA = (EXP(ALPHA*HICE)+EXP(-ALPHA*HICE))/2. -! - IF (REAL(WN*DEPTH).LE.4.) THEN - TH = (EXP(WN*DEPTH)-EXP(-WN*DEPTH)) & - / (EXP(WN*DEPTH)+EXP(-WN*DEPTH)) - THH = ( EXP(WN*(DEPTH-HICE)) - EXP(-WN*(DEPTH-HICE)) ) & - / ( EXP(WN*(DEPTH-HICE)) + EXP(-WN*(DEPTH-HICE)) ) - ELSE - TH = 1.0 - THH = 1.0 - END IF -! - M = (DBLE(DWAT)/DICE - 1) * DBLE(GRAV) * WN & - - DBLE(DWAT) / DICE * SIGMA**2 / TH -! - IF (ES.GT.1.E7) THEN - AA(1,1) = 0. - AA(1,2) = 2 * CMPLX(0.,1.) * WN**2. - AA(1,3) = ALPHA**2. + WN**2. - AA(1,4) = 0. -! - AA(2,1) = N * SIGMA - AA(2,2) = -WN * DBLE(GRAV) - AA(2,3) = CMPLX(0.,1.) * WN * DBLE(GRAV) - AA(2,4) = L -! - AA(3,1) = -2. * CMPLX(0.,1.) * WN**2. * SK - AA(3,2) = 2. * CMPLX(0.,1.) * WN**2. * CK - AA(3,3) = (ALPHA**2. + WN**2.) * CA - AA(3,4) = -(ALPHA**2. + WN**2.) * SA -! - AA(4,1) = N * SIGMA * CK - M * SK - AA(4,2) = - N * SIGMA * SK + M * CK - AA(4,3) = -CMPLX(0.,1.) * M * CA - L * SA - AA(4,4) = CMPLX(0.,1.) * M * SA + L * CA -! - FUNC1 = BSDET(AA,4) - ELSE - FUNC1 = SIGMA**2. - TH*WN*DBLE(GRAV) - TH*DICE/DBLE(DWAT)* & - (WN**2.*DBLE(GRAV)**2.*SK*SA - (N**4. + 16.* & - VE**4.*WN**6.*ALPHA**2.)*SK*SA - 8. & - *WN**3.*ALPHA*VE**2.*N**2.*(CK*CA-1.))/(4.*WN**3. & - *ALPHA*VE**2.*SK*CA+N**2.*SA*CK-DBLE(GRAV)*WN*SK*SA) + + Y3 = F_ZHAO_V1(P3,JUDGE,SIGMA,ES,NU,DICE,HICE,DEPTH); + + IF ( ABS(P3-P2).LT.DLTA .OR. ABS(Y3).LT.EPSI ) THEN + RETURN ENDIF -!/ - END FUNCTION FUNC1_ZHAO -!/ ------------------------------------------------------------------- / -!/ - FUNCTION BSDET(AA, N) RESULT(DET) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 11-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ -! 1. Purpose : -! -! This subroutine calculates the determinant for the -! dispersion relation. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! AA R.A. I/O Square array type of REAL -! N INT I Size of array (number of rows/cols) -! DET CMPLX DBLE I/O Determinant (double complex) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! FUNC1_ZHAO Func. W3SIC3MD Function for computation of complex -! wavenumbers for waves in ice. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! -! This function does not get used in update by S. Cheng. -! It should be removed if/when "V1" routines are removed. -! -! 8. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: N - DOUBLE COMPLEX, INTENT(IN) :: AA(N,N) - DOUBLE COMPLEX :: DET ! RESULT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: K, I, J, IS, JS - DOUBLE COMPLEX :: F, D, MAT(N,N) - DOUBLE PRECISION :: Q -!/ -!/ ------------------------------------------------------------------- / - MAT = AA - F = 1.0 - DET = 1.0 - LOOP100: DO K = 1,N-1 - Q = 0.0 - LOOP10A: DO I = K,N - LOOP10B: DO J = K,N - IF (ABS(MAT(I,J)).GT.Q) THEN - Q = ABS(MAT(I,J)) - IS = I - JS = J - END IF - END DO LOOP10B - END DO LOOP10A - IF (Q+1.0.EQ.1.0) THEN - DET = 0.0 - RETURN - END IF - IF (IS.NE.K) THEN - F = -F - LOOP20: DO J = K,N - D = MAT(K,J) - MAT(K,J) = MAT(IS,J) - MAT(IS,J) = D - END DO LOOP20 - END IF - IF (JS.NE.K) THEN - F = -F - LOOP30: DO I = K,N - D = MAT(I,JS) - MAT(I,JS) = MAT(I,K) - MAT(I,K) = D - END DO LOOP30 - END IF - DET = DET * MAT(K,K) - LOOP50: DO I = K+1,N - D = MAT(I,K) / MAT(K,K) - LOOP40: DO J = K+1,N - MAT(I,J) = MAT(I,J) - D * MAT(K,J) - END DO LOOP40 - END DO LOOP50 - END DO LOOP100 -!/ - DET = F * DET * MAT(N,N) -!/ -!/ End of BSDET ------------------------------------------------------ / -!/ - END FUNCTION BSDET -!/ ------------------------------------------------------------------- / - FUNCTION DELTA(X) RESULT(DX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 22-Oct-2013 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.12 ) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ -! 1. Purpose : -! -! This function calculates bin withs for any discretized function. -! May be used for numerical integration and differentiation. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! X R.A. I Array type of REAL -! DX R.A O Bin widths if X -! ---------------------------------------------------------------- -! -! 4. Remarks : -! -! This function does not get used in update by S. Cheng. -! It should be removed if/when "V1" routines are removed. -! -! 5. Called by : -! W3IC3WNCG_V1 -! -! 6. Source code : -!/ - IMPLICIT NONE -!/ - REAL, INTENT(IN) :: X(:) - REAL, ALLOCATABLE :: DX(:) - INTEGER :: IX, NX -!/ - NX = SIZE(X,1) - ALLOCATE(DX(NX)) - DX = 0. -!/ - DO IX = 1,NX - IF (IX==1) THEN - DX(IX) = (X(IX+1)-X(IX )) - ELSE IF (IX==NX) THEN - DX(IX) = (X(IX )-X(IX-1)) - ELSE - DX(IX) = (X(IX+1)-X(IX-1)) / 2. - END IF - END DO -!/ - END FUNCTION DELTA -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / -! Start of new codes (or new variants) provided by S. Cheng -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + P0 = P1 + P1 = P2 + P2 = P3 - SUBROUTINE W3IC3WNCG_CHENG(WN_R,WN_I,CG,ICE1,ICE2,ICE3,ICE4,DPT) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | X. Zhao | -!/ | S. Cheng | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2016 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! Calculation of complex wavenumber for waves in ice. Outsourced -! from W3SIC3 to allow update on wavenumbers and group -! velocities at each time step an ice parameter is updated. -! -! 2. Method : -! -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! WN_R R. A. I/O Wave number (real part) -! WN_I R. A. I/O Wave number (imag. part=wave attenuation) -! CG R. A. I/O Group velocity -! ICE1 REAL I Thickness of ice [in m] -! ICE2 REAL I Effective viscosity of ice [in m2/s] -! ICE3 REAL I Density of ice [in kg/m3] -! ICE4 REAL I Effective shear modulus of ice [in Pa] -! DPT REAL I Water depth [in m] -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WAVNU1 Subr. W3DISPMD Wavenumber for waves in open water. -! WN_CMPLX Func. W3SIC3MD Complex wavenumber for waves in ice. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SIC3 Subr. W3SIC3MD Ice source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! On pre-calculation table, S. Cheng says: -! Instead of interpolation, WN_R of arbitrary HICE is approximated -! by IC3WN_R in the look up table. IC3WN_R is related to an ice -! thickness in the table, which is closest to HICE and less than -! HICE -! -! Fix submitted by Sukun March 2017: -! replace : -! I = MIN(INT(HICE/IC3_DITK)+1,ITKNUM) -! with : -! I = MIN(NINT(HICE/IC3_DITK),ITKNUM) -! -! 8. Structure : -! -! See source code. -! -! 9. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - USE W3GDATMD, ONLY: NK,SIG, IC3PARS - USE W3ADATMD, ONLY: IC3WN_R, IC3WN_I, IC3CG - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE W3DISPMD, ONLY: WAVNU1 - !/ - IMPLICIT NONE - !/ - REAL, INTENT(IN) :: ICE1, ICE2, ICE3, ICE4, DPT - REAL, INTENT(INOUT):: WN_R(:),WN_I(:),CG(:) - REAL, ALLOCATABLE :: SIGMA(:) + Y0 = Y1 + Y1 = Y2 + Y2 = Y3 + + ENDDO + ! + WRITE(NDSE,800) + WRITE(NDSE,801)X0,X1,X2 + WRITE(NDSE,802)SIGMA,ES,NU,DICE,HICE,DEPTH + WRITE(NDSE,803)JUDGE + CALL EXTCDE(2) + ! +800 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC3_CMPLX_ROOT_MULLER'/& + ' : MULLER METHOD FAILED TO FIND ROOT.' ) +801 FORMAT (/'X0,X1,X2 = ',3(1X,'(',F10.5,',',F10.5,')')) +802 FORMAT (/'SIGMA,ES,NU,DICE,HICE,DEPTH = ',6(1X,F10.5)) +803 FORMAT (/'JUDGE = ',I5) + !/ + END FUNCTION CMPLX_ROOT_MULLER_V1 + !/ ------------------------------------------------------------------- / + !/ + FUNCTION F_ZHAO_V1(X,JUDGE,SIGMA,ES,NU,DICE,HICE,DEPTH) & + RESULT(FZHAO) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Decide whether to call sub-function. + ! + ! 2. Method : + ! + ! Decide based on value of integer "JUDGE" + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FZHAO COMPL8 O Result (double complex) + ! X CMPLX8 I Approximate result (double complex) + ! JUDGE INTEGR I Switch variable + ! SIGMA DOUBLE I Wave angular frequency + ! ES DOUBLE I Effective shear modulus + ! NU DOUBLE I Effective viscosity parameter + ! DICE DOUBLE I Density of ice + ! HICE DOUBLE I Thickness of ice + ! DEPTH DOUBLE I Water depth + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! FUNC0_ZHAO Func. W3SIC3MD Function to find root. + ! FUNC1_ZHAO Func. W3SIC3MD Function to find root. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! CMPLX_ROOT_MULLER_V1 Func. W3SIC3MD Find root for complex wave- + ! numbers for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Original authors: Zhao and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on April 19 2013. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: JUDGE + DOUBLE PRECISION, INTENT(IN) :: SIGMA,ES,NU,DICE,HICE,DEPTH + DOUBLE COMPLEX, INTENT(IN) :: X + DOUBLE COMPLEX :: FZHAO ! RESULT + !/ + !/ ------------------------------------------------------------------- / + IF (JUDGE.EQ.0) THEN + FZHAO = FUNC0_ZHAO(X,SIGMA,DEPTH) + ELSE + FZHAO = FUNC1_ZHAO(X,SIGMA,ES,NU,DICE,HICE,DEPTH) + ENDIF + ! + END FUNCTION F_ZHAO_V1 + !/ ------------------------------------------------------------------- / + !/ + FUNCTION FUNC0_ZHAO(WN, SIGMA, DEPTH) RESULT(FUNC0) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Calculate the difference between the left and right side + ! of the dispersion relation. It is called by the Muller method. + ! + ! 2. Method : + ! + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FUNC0 COMPL DBL O Result (double complex) + ! WN CMPLX DBL I Complex wavenumber + ! SIGMA DOUBLE I Wave angular frequency + ! DEPTH DOUBLE I Water depth [in m] + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! F_ZHAO_V1 Func. W3SIC3MD Function for computation of complex + ! wavenumbers for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Original authors: Zhao and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on April 19 2013. + ! + ! This function does not get used in update by S. Cheng. + ! It should be removed if/when "V1" routines are removed. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + DOUBLE COMPLEX, INTENT(IN) :: WN + DOUBLE PRECISION, INTENT(IN) :: SIGMA, DEPTH + DOUBLE COMPLEX :: FUNC0 ! RESULT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + DOUBLE COMPLEX :: TH + !/ + !/ ------------------------------------------------------------------- / + IF (REAL(WN*DEPTH).LE.4.) THEN + TH = (EXP(WN*DEPTH)-EXP(-WN*DEPTH)) & + / (EXP(WN*DEPTH)+EXP(-WN*DEPTH)) + FUNC0 = SIGMA**2. - TH * WN * DBLE(GRAV) + ELSE + FUNC0 = SIGMA**2. - WN * DBLE(GRAV) + END IF + !/ + END FUNCTION FUNC0_ZHAO + !/ ------------------------------------------------------------------- / + !/ + FUNCTION FUNC1_ZHAO(WN,SIGMA,ES,NU,DICE,HICE,DEPTH) RESULT(FUNC1) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 11-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) + !/ + ! 1. Purpose : + ! + ! + ! + ! 2. Method : + ! + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FUNC1 CMPLX DBL O Result (double complex) + ! WN CMPLX DBL I Wavenumber (double complex) + ! W REAL DBL I Wave angular frequency + ! ES REAL DBL I Effective shear modulus on ice + ! NU REAL DBL I Effective viscosity + ! DICE REAL DBL I Density of ice + ! HICE REAL DBL I Thickness of ice + ! DEPTH REAL DBL I Water depth + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! BSDET Func. W3SIC3MD Calculates the determinant for the + ! dispersion relation. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! F_ZHAO_V1 Func. W3SIC3MD Function for computation of complex + ! wavenumbers for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Original authors: Zhao and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on April 19 2013. + ! + ! This function does not get used in update by S. Cheng. + ! It should be removed if/when "V1" routines are removed. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, DWAT + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + DOUBLE COMPLEX, INTENT(IN) :: WN + DOUBLE PRECISION, INTENT(IN) :: SIGMA, ES, NU, DICE, HICE, DEPTH + DOUBLE COMPLEX :: FUNC1 ! RESULT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + DOUBLE COMPLEX :: VE,ALPHA,N,M,L,SK,CK,SA,CA,TH,THH + DOUBLE COMPLEX :: AA(4,4) + !/ + !/ ------------------------------------------------------------------- / + VE = CMPLX( NU, ES/DICE/SIGMA ) + ALPHA = SQRT ( WN**2. - SIGMA/VE * CMPLX(0.,1.) ) + N = SIGMA + 2. * VE * WN**2. * CMPLX(0.,1.) + L = 2 * WN * ALPHA * SIGMA * VE + SK = (EXP(WN*HICE)-EXP(-WN*HICE))/2. + CK = (EXP(WN*HICE)+EXP(-WN*HICE))/2. + SA = (EXP(ALPHA*HICE)-EXP(-ALPHA*HICE))/2. + CA = (EXP(ALPHA*HICE)+EXP(-ALPHA*HICE))/2. + ! + IF (REAL(WN*DEPTH).LE.4.) THEN + TH = (EXP(WN*DEPTH)-EXP(-WN*DEPTH)) & + / (EXP(WN*DEPTH)+EXP(-WN*DEPTH)) + THH = ( EXP(WN*(DEPTH-HICE)) - EXP(-WN*(DEPTH-HICE)) ) & + / ( EXP(WN*(DEPTH-HICE)) + EXP(-WN*(DEPTH-HICE)) ) + ELSE + TH = 1.0 + THH = 1.0 + END IF + ! + M = (DBLE(DWAT)/DICE - 1) * DBLE(GRAV) * WN & + - DBLE(DWAT) / DICE * SIGMA**2 / TH + ! + IF (ES.GT.1.E7) THEN + AA(1,1) = 0. + AA(1,2) = 2 * CMPLX(0.,1.) * WN**2. + AA(1,3) = ALPHA**2. + WN**2. + AA(1,4) = 0. + ! + AA(2,1) = N * SIGMA + AA(2,2) = -WN * DBLE(GRAV) + AA(2,3) = CMPLX(0.,1.) * WN * DBLE(GRAV) + AA(2,4) = L + ! + AA(3,1) = -2. * CMPLX(0.,1.) * WN**2. * SK + AA(3,2) = 2. * CMPLX(0.,1.) * WN**2. * CK + AA(3,3) = (ALPHA**2. + WN**2.) * CA + AA(3,4) = -(ALPHA**2. + WN**2.) * SA + ! + AA(4,1) = N * SIGMA * CK - M * SK + AA(4,2) = - N * SIGMA * SK + M * CK + AA(4,3) = -CMPLX(0.,1.) * M * CA - L * SA + AA(4,4) = CMPLX(0.,1.) * M * SA + L * CA ! - INTEGER :: I, I1, I2, IK, KL,KU, ITKNUM - COMPLEX(8) :: WNCOMPLEX, X0,X1,X2, WNR, WNL - REAL(8) :: DEPTH, HICE, NU, DICE, ES_MOD, RR, K_OCEAN, & - CG_OCEAN - REAL :: IC3HILIM,IC3KILIM - - IC3HILIM=IC3PARS(10) - IC3KILIM=IC3PARS(11) - - ALLOCATE( SIGMA( SIZE(CG) ) ) - SIGMA = 0. - IF (SIZE(WN_R,1).EQ.NK) THEN - KL = 1 - KU = NK - I1 = 1 - I2 = NK - SIGMA = SIG(1:NK) - ELSE IF (SIZE(WN_R,1).EQ.NK+2) THEN - KL = 1 - KU = NK+2 - I1 = 0 - I2 = NK+1 - SIGMA = SIG(0:NK+1) + FUNC1 = BSDET(AA,4) + ELSE + FUNC1 = SIGMA**2. - TH*WN*DBLE(GRAV) - TH*DICE/DBLE(DWAT)* & + (WN**2.*DBLE(GRAV)**2.*SK*SA - (N**4. + 16.* & + VE**4.*WN**6.*ALPHA**2.)*SK*SA - 8. & + *WN**3.*ALPHA*VE**2.*N**2.*(CK*CA-1.))/(4.*WN**3. & + *ALPHA*VE**2.*SK*CA+N**2.*SA*CK-DBLE(GRAV)*WN*SK*SA) + ENDIF + !/ + END FUNCTION FUNC1_ZHAO + !/ ------------------------------------------------------------------- / + !/ + FUNCTION BSDET(AA, N) RESULT(DET) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 11-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ + ! 1. Purpose : + ! + ! This subroutine calculates the determinant for the + ! dispersion relation. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! AA R.A. I/O Square array type of REAL + ! N INT I Size of array (number of rows/cols) + ! DET CMPLX DBLE I/O Determinant (double complex) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! FUNC1_ZHAO Func. W3SIC3MD Function for computation of complex + ! wavenumbers for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Original authors: Zhao and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on April 19 2013. + ! + ! This function does not get used in update by S. Cheng. + ! It should be removed if/when "V1" routines are removed. + ! + ! 8. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: N + DOUBLE COMPLEX, INTENT(IN) :: AA(N,N) + DOUBLE COMPLEX :: DET ! RESULT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: K, I, J, IS, JS + DOUBLE COMPLEX :: F, D, MAT(N,N) + DOUBLE PRECISION :: Q + !/ + !/ ------------------------------------------------------------------- / + MAT = AA + F = 1.0 + DET = 1.0 + LOOP100: DO K = 1,N-1 + Q = 0.0 + LOOP10A: DO I = K,N + LOOP10B: DO J = K,N + IF (ABS(MAT(I,J)).GT.Q) THEN + Q = ABS(MAT(I,J)) + IS = I + JS = J + END IF + END DO LOOP10B + END DO LOOP10A + IF (Q+1.0.EQ.1.0) THEN + DET = 0.0 + RETURN + END IF + IF (IS.NE.K) THEN + F = -F + LOOP20: DO J = K,N + D = MAT(K,J) + MAT(K,J) = MAT(IS,J) + MAT(IS,J) = D + END DO LOOP20 + END IF + IF (JS.NE.K) THEN + F = -F + LOOP30: DO I = K,N + D = MAT(I,JS) + MAT(I,JS) = MAT(I,K) + MAT(I,K) = D + END DO LOOP30 + END IF + DET = DET * MAT(K,K) + LOOP50: DO I = K+1,N + D = MAT(I,K) / MAT(K,K) + LOOP40: DO J = K+1,N + MAT(I,J) = MAT(I,J) - D * MAT(K,J) + END DO LOOP40 + END DO LOOP50 + END DO LOOP100 + !/ + DET = F * DET * MAT(N,N) + !/ + !/ End of BSDET ------------------------------------------------------ / + !/ + END FUNCTION BSDET + !/ ------------------------------------------------------------------- / + FUNCTION DELTA(X) RESULT(DX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 22-Oct-2013 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.12 ) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ + ! 1. Purpose : + ! + ! This function calculates bin withs for any discretized function. + ! May be used for numerical integration and differentiation. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! X R.A. I Array type of REAL + ! DX R.A O Bin widths if X + ! ---------------------------------------------------------------- + ! + ! 4. Remarks : + ! + ! This function does not get used in update by S. Cheng. + ! It should be removed if/when "V1" routines are removed. + ! + ! 5. Called by : + ! W3IC3WNCG_V1 + ! + ! 6. Source code : + !/ + IMPLICIT NONE + !/ + REAL, INTENT(IN) :: X(:) + REAL, ALLOCATABLE :: DX(:) + INTEGER :: IX, NX + !/ + NX = SIZE(X,1) + ALLOCATE(DX(NX)) + DX = 0. + !/ + DO IX = 1,NX + IF (IX==1) THEN + DX(IX) = (X(IX+1)-X(IX )) + ELSE IF (IX==NX) THEN + DX(IX) = (X(IX )-X(IX-1)) ELSE - WRITE(NDSE,900) - CALL EXTCDE(3) + DX(IX) = (X(IX+1)-X(IX-1)) / 2. END IF - DEPTH = DPT ! water depth - HICE = ICE1 ! ice thickness - -! Optional: limit ice thickness - HICE=MIN(DBLE(IC3HILIM),HICE) - NU = ICE2 ! "effective viscosity" parameter - DICE = ICE3 ! density of ice - ES_MOD = ICE4 ! effective shear modulus of ice - ! - ITKNUM = CEILING(IC3_MAXITK/IC3_DITK) - I = MIN(NINT(HICE/IC3_DITK),ITKNUM) - -! Find values in pre-calculated look-up table -! See Remarks section. - WN_R = IC3WN_R(I1:I2, I) - WN_I = IC3WN_I(I1:I2, I) - CG = IC3CG(I1:I2, I) - RR = 0.01 -!/ --- CHECK If it's shallow water situation, then it needs recalculate -! kr,ki,cg - DO IK = KL,KU - IF (WN_R(IK)*DEPTH>4.0)THEN ! exit do-loop - EXIT ! assume kr is proportional to frequency - ELSE - X1 = CMPLX(WN_R(IK),WN_I(IK)) - x0 = X1*(1-RR) - x2 = X1*(1+RR) - WNCOMPLEX = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,1, & - DBLE(SIGMA(IK)),ES_MOD,NU,DICE,HICE,DEPTH) - WN_I(IK) = REAL(AIMAG(WNCOMPLEX)) ! ki - WN_R(IK) = REAL(WNCOMPLEX) ! kr - ENDIF - ENDDO + END DO + !/ + END FUNCTION DELTA + + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + ! Start of new codes (or new variants) provided by S. Cheng + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + + SUBROUTINE W3IC3WNCG_CHENG(WN_R,WN_I,CG,ICE1,ICE2,ICE3,ICE4,DPT) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | X. Zhao | + !/ | S. Cheng | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2016 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! Calculation of complex wavenumber for waves in ice. Outsourced + ! from W3SIC3 to allow update on wavenumbers and group + ! velocities at each time step an ice parameter is updated. + ! + ! 2. Method : + ! + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! WN_R R. A. I/O Wave number (real part) + ! WN_I R. A. I/O Wave number (imag. part=wave attenuation) + ! CG R. A. I/O Group velocity + ! ICE1 REAL I Thickness of ice [in m] + ! ICE2 REAL I Effective viscosity of ice [in m2/s] + ! ICE3 REAL I Density of ice [in kg/m3] + ! ICE4 REAL I Effective shear modulus of ice [in Pa] + ! DPT REAL I Water depth [in m] + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WAVNU1 Subr. W3DISPMD Wavenumber for waves in open water. + ! WN_CMPLX Func. W3SIC3MD Complex wavenumber for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SIC3 Subr. W3SIC3MD Ice source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! On pre-calculation table, S. Cheng says: + ! Instead of interpolation, WN_R of arbitrary HICE is approximated + ! by IC3WN_R in the look up table. IC3WN_R is related to an ice + ! thickness in the table, which is closest to HICE and less than + ! HICE + ! + ! Fix submitted by Sukun March 2017: + ! replace : + ! I = MIN(INT(HICE/IC3_DITK)+1,ITKNUM) + ! with : + ! I = MIN(NINT(HICE/IC3_DITK),ITKNUM) + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD, ONLY: NK,SIG, IC3PARS + USE W3ADATMD, ONLY: IC3WN_R, IC3WN_I, IC3CG + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE W3DISPMD, ONLY: WAVNU1 + !/ + IMPLICIT NONE + !/ + REAL, INTENT(IN) :: ICE1, ICE2, ICE3, ICE4, DPT + REAL, INTENT(INOUT):: WN_R(:),WN_I(:),CG(:) + REAL, ALLOCATABLE :: SIGMA(:) + ! + INTEGER :: I, I1, I2, IK, KL,KU, ITKNUM + COMPLEX(8) :: WNCOMPLEX, X0,X1,X2, WNR, WNL + REAL(8) :: DEPTH, HICE, NU, DICE, ES_MOD, RR, K_OCEAN, & + CG_OCEAN + REAL :: IC3HILIM,IC3KILIM + + IC3HILIM=IC3PARS(10) + IC3KILIM=IC3PARS(11) + + ALLOCATE( SIGMA( SIZE(CG) ) ) + SIGMA = 0. + IF (SIZE(WN_R,1).EQ.NK) THEN + KL = 1 + KU = NK + I1 = 1 + I2 = NK + SIGMA = SIG(1:NK) + ELSE IF (SIZE(WN_R,1).EQ.NK+2) THEN + KL = 1 + KU = NK+2 + I1 = 0 + I2 = NK+1 + SIGMA = SIG(0:NK+1) + ELSE + WRITE(NDSE,900) + CALL EXTCDE(3) + END IF + DEPTH = DPT ! water depth + HICE = ICE1 ! ice thickness + + ! Optional: limit ice thickness + HICE=MIN(DBLE(IC3HILIM),HICE) + NU = ICE2 ! "effective viscosity" parameter + DICE = ICE3 ! density of ice + ES_MOD = ICE4 ! effective shear modulus of ice + ! + ITKNUM = CEILING(IC3_MAXITK/IC3_DITK) + I = MIN(NINT(HICE/IC3_DITK),ITKNUM) + + ! Find values in pre-calculated look-up table + ! See Remarks section. + WN_R = IC3WN_R(I1:I2, I) + WN_I = IC3WN_I(I1:I2, I) + CG = IC3CG(I1:I2, I) + RR = 0.01 + !/ --- CHECK If it's shallow water situation, then it needs recalculate + ! kr,ki,cg + DO IK = KL,KU + IF (WN_R(IK)*DEPTH>4.0)THEN ! exit do-loop + EXIT ! assume kr is proportional to frequency + ELSE + X1 = CMPLX(WN_R(IK),WN_I(IK)) + x0 = X1*(1-RR) + x2 = X1*(1+RR) + WNCOMPLEX = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,1, & + DBLE(SIGMA(IK)),ES_MOD,NU,DICE,HICE,DEPTH) + WN_I(IK) = REAL(AIMAG(WNCOMPLEX)) ! ki + WN_R(IK) = REAL(WNCOMPLEX) ! kr + ENDIF + ENDDO CALL SMOOTH_K(WN_R,WN_I,SIGMA,KU-KL+ 1,0) -! Optional : limit ki - DO IK = KL,KU - WN_I(IK) = MIN(WN_I(IK),IC3KILIM) - ENDDO + ! Optional : limit ki + DO IK = KL,KU + WN_I(IK) = MIN(WN_I(IK),IC3KILIM) + ENDDO !!! --- Update group velocitiy ---- - CALL CGinIC3_CHENG(CG,SIGMA,WN_R,KU-KL+1) - - DEALLOCATE(SIGMA) - -900 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC3_W3IC3WNCG : '/& - ' CANNOT DETERMINE BOUNDS OF WAVENUMBER ARRAY.') - END SUBROUTINE W3IC3WNCG_CHENG -! -!/ ------------------------------------------------------------------- / - SUBROUTINE IC3TABLE_CHENG(ICE2,ICE3,ICE4) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | X. Zhao | -!/ | S. Cheng | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2016 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! It's a Preprocess part to create a table of wave nubmer, -! attenuation and group velocity -! for all ice thickness in deep water situation for main -! computation. -! -! 2. Method : -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! CMPLX_ROOT_MULLER_CHENG Func. W3SIC3MD Find root for complex -! wavenumbers for waves in ice. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Original authors: Cheng and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on Aug 25 2015 -! -! **UNRESOLVED BUG** This routine should be called again if ice -! rheology (visc., elast.) changes (either time or space). -! It doesn't. We need to set CALLEDIC3TABLE=0 if either parameter is -! changed. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NK,SIG - USE W3ADATMD, ONLY: IC3WN_R, IC3WN_I, IC3CG - USE W3IDATMD, ONLY: INFLAGS2 - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE CONSTANTS, ONLY: GRAV -! - IMPLICIT NONE - REAL :: ICE1, ICE2, ICE3, ICE4, DPT - INTEGER :: I1, I2, JITK, ITKNUM, IK - - DPT = 999. - - ITKNUM = CEILING(IC3_MAXITK/IC3_DITK) - IC3WN_R(:,0) = SIG**2/GRAV - IC3WN_I(:,0) = 0 - DO JITK = 1,ITKNUM - ICE1 = JITK*IC3_DITK !HICE - CALL IC3PRECALC_CHENG(IC3WN_R(:,JITK), IC3WN_I(:,JITK), & - IC3CG(:,JITK), ICE1, ICE2, ICE3, ICE4, DPT) - ENDDO + CALL CGinIC3_CHENG(CG,SIGMA,WN_R,KU-KL+1) + + DEALLOCATE(SIGMA) + +900 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC3_W3IC3WNCG : '/& + ' CANNOT DETERMINE BOUNDS OF WAVENUMBER ARRAY.') + END SUBROUTINE W3IC3WNCG_CHENG + ! + !/ ------------------------------------------------------------------- / + SUBROUTINE IC3TABLE_CHENG(ICE2,ICE3,ICE4) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | X. Zhao | + !/ | S. Cheng | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2016 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! It's a Preprocess part to create a table of wave nubmer, + ! attenuation and group velocity + ! for all ice thickness in deep water situation for main + ! computation. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! CMPLX_ROOT_MULLER_CHENG Func. W3SIC3MD Find root for complex + ! wavenumbers for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Original authors: Cheng and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on Aug 25 2015 + ! + ! **UNRESOLVED BUG** This routine should be called again if ice + ! rheology (visc., elast.) changes (either time or space). + ! It doesn't. We need to set CALLEDIC3TABLE=0 if either parameter is + ! changed. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NK,SIG + USE W3ADATMD, ONLY: IC3WN_R, IC3WN_I, IC3CG + USE W3IDATMD, ONLY: INFLAGS2 + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE CONSTANTS, ONLY: GRAV + ! + IMPLICIT NONE + REAL :: ICE1, ICE2, ICE3, ICE4, DPT + INTEGER :: I1, I2, JITK, ITKNUM, IK + + DPT = 999. + + ITKNUM = CEILING(IC3_MAXITK/IC3_DITK) + IC3WN_R(:,0) = SIG**2/GRAV + IC3WN_I(:,0) = 0 + DO JITK = 1,ITKNUM + ICE1 = JITK*IC3_DITK !HICE + CALL IC3PRECALC_CHENG(IC3WN_R(:,JITK), IC3WN_I(:,JITK), & + IC3CG(:,JITK), ICE1, ICE2, ICE3, ICE4, DPT) + ENDDO -RETURN -END SUBROUTINE IC3TABLE_CHENG + RETURN + END SUBROUTINE IC3TABLE_CHENG + + !/ ------------------------------------------------------------------- / + SUBROUTINE IC3PRECALC_CHENG(WN_R,WN_I,CG,ICE1,ICE2,ICE3,ICE4,DPT) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | X. Zhao | + !/ | S. Cheng | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2016 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! Preprocess part to create a table of wave nubmer, attenuation and + ! group velocity for all ice thickness in deep water situation for + ! main computation. + ! + ! 2. Method : + ! + ! Calculate them use Muller's method + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! CMPLX_ROOT_MULLER_CHENG Func. W3SIC3MD Find root for complex + ! wavenumbers for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! IC3TABLE_CHENG Subr. W3SIC3MD Create a table of kr,ki,cg + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Original authors: Cheng and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on Aug 25 2015 + ! + ! Sukun Cheng in reference to MIN(WN_I(IK),--): + ! "This artificial limitation reduces IC3 model’s effect, + ! though it saves some time. + ! ki > 2.e-4 is a common truth for angular frequency larger + ! than the value around 2 or 3 depending on other parameters." + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NK, SIG + USE W3DISPMD, ONLY: WAVNU1 + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + !/ + IMPLICIT NONE + !/ + REAL, INTENT(INOUT):: WN_R(0:NK+1),WN_I(0:NK+1), CG(0:NK+1) + REAL, INTENT(IN) :: ICE1, ICE2, ICE3, ICE4, DPT + + INTEGER :: IK, KL,KU,IX,NUM,SWITCHID + REAL :: K_OCEAN,CG_OCEAN + REAL(8) :: KH, K_NOICE, DEPTH, HICE, NU, DICE, & + ES_MOD,SIGMAM1 + COMPLEX(8) :: WNCOMPLEX, X0,X1,X2,WNM1,WNM2,WN_O + ! + ! --- Input to routine + DEPTH = DPT ! water depth + HICE = ICE1 ! ice thickness + NU = ICE2 ! "effective viscosity" parameter + DICE = ICE3 ! density of ice + ES_MOD = ICE4 ! effective shear modulus of ice + + KL = 0 + KU = NK+1 + SWITCHID = 0 + + DO IK = KL,KU + CALL WAVNU1(SIG(IK),DPT,K_OCEAN,CG_OCEAN) + K_NOICE = K_OCEAN + + ! --- Calculate complex wavenumber ------------------------------- / + IF(IK 2.e-4 is a common truth for angular frequency larger -! than the value around 2 or 3 depending on other parameters." -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NK, SIG - USE W3DISPMD, ONLY: WAVNU1 - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE -!/ - IMPLICIT NONE -!/ - REAL, INTENT(INOUT):: WN_R(0:NK+1),WN_I(0:NK+1), CG(0:NK+1) - REAL, INTENT(IN) :: ICE1, ICE2, ICE3, ICE4, DPT - - INTEGER :: IK, KL,KU,IX,NUM,SWITCHID - REAL :: K_OCEAN,CG_OCEAN - REAL(8) :: KH, K_NOICE, DEPTH, HICE, NU, DICE, & - ES_MOD,SIGMAM1 - COMPLEX(8) :: WNCOMPLEX, X0,X1,X2,WNM1,WNM2,WN_O -! -! --- Input to routine - DEPTH = DPT ! water depth - HICE = ICE1 ! ice thickness - NU = ICE2 ! "effective viscosity" parameter - DICE = ICE3 ! density of ice - ES_MOD = ICE4 ! effective shear modulus of ice - - KL = 0 - KU = NK+1 - SWITCHID = 0 - - DO IK = KL,KU - CALL WAVNU1(SIG(IK),DPT,K_OCEAN,CG_OCEAN) - K_NOICE = K_OCEAN - -! --- Calculate complex wavenumber ------------------------------- / - IF(IK10s use open water, T<10s cases, calculate + ! T=10s first using open water as the initial guess. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPI + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL(8) :: SIGMA,SIGMAM1,ES_MOD,NU,DICE,HICE,DEPTH + COMPLEX(8) :: WN_O, WNM1, WNM2, WN0, WN1,WN2 + COMPLEX(8),INTENT(OUT) :: WN ! RESULT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I,IX,NUM,SWITCHID,IK,KU + REAL(8) :: RR, R2, EPS, SIGMA0, KAPPA, DIS + COMPLEX(8) :: X0, X1, X2, kp, ks, Gv + !/ + !/ ------------------------------------------------------------------- / + ! compute shear wave and pressure wave modes + GV = CMPLX(ES_MOD,-SIGMA*NU*DICE) + KP = SIGMA/SQRT(4*GV/DICE) + KS = 2*KP + ! RR,R2 are empirical coefficients + RR = 0.2 + R2 = 4 + EPS = 1.D-10 ! assuming variable =0, if it is less than this value + ! compute root 1 + ! initial guesses from wave number of open water + ! + X1 = WN_O ! initial guess + X0 = X1*(1-RR) + X2 = X1*(1+RR) + + WN1 = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,1,SIGMA, & + ES_MOD,NU,DICE,HICE,DEPTH) + ! if root finder failed, or found shear wave mode, + ! redo searching using simplified dispersion relation form, index 2 + IF (REAL(WN1)<0.or.abs(wn1-ks)/abs(ks)<0.03 .or. & + abs(wn1-kp)/abs(kp)<0.03.and.Es_mod>1.e7*nu)THEN + WN1 = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,2,SIGMA, & + ES_MOD,NU,DICE,HICE,DEPTH) + ENDIF + ! similar as wn1, but search with opposite order of inital guesses + WN2 = CMPLX_ROOT_MULLER_CHENG(X2,X1,X0,1,SIGMA, & + ES_MOD,NU,DICE,HICE,DEPTH) + IF (REAL(WN2)<0.or.abs(wn2-ks)/abs(ks)<0.03)THEN + WN2 = CMPLX_ROOT_MULLER_CHENG(X2,X1,X0,2,SIGMA, & + ES_MOD,NU,DICE,HICE,DEPTH) + ENDIF + IF(ABS(REAL(WN1)-REAL(WN_O))4)THEN + CYCLE ENDIF + NUM = 2**(I-1) + RR = MIN(MAX(R2/REAL(NUM,8),0.001D0),0.5D0) + X1 = WNM1 + DO IX = 1,NUM + X0 = X1*(1-RR) + X2 = X1*(1+RR) + SIGMA0 = SIGMAM1 + (1.0*IX)/NUM*(SIGMA-SIGMAM1) + WN = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,1,SIGMA0, & + ES_MOD,NU,DICE,HICE,DEPTH) + IF(REAL(WN)<0)THEN ! try another searching direction + WN = CMPLX_ROOT_MULLER_CHENG(X2,X1,X0,1,SIGMA0, & + ES_MOD,NU,DICE,HICE,DEPTH) + ENDIF + IF(REAL(WN)<0)THEN ! try another dispersion relation form + WN = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,3,SIGMA0, & + ES_MOD,NU,DICE,HICE,DEPTH) + ENDIF + KP = SIGMA0/SQRT(4*GV/DICE) + KS = 2*KP + ! set 3 means simple dispersion relation form + IF(ABS(WN-KS)/ABS(KS)<0.03.OR.REAL(WN)<0)THEN + WN = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,2,SIGMA0, & + ES_MOD,NU,DICE,HICE,DEPTH) + ENDIF + X1 = WN + IF( REAL(WN)<0.99*REAL(WNM1).OR. ABS(WN-WN0)>EPS .AND. & + (ABS(X1-WN)/ABS(WN)>0.3 .OR. & + IMAG(WN)/(IMAG(X1)+EPS)>10.OR. REAL(WN)<0))THEN + EXIT ! redo with smaller intervals + ENDIF + X0 = X1 + X1 = WN + ENDDO ! DO IX = 1,NUM - WN_O = CMPLX(K_NOICE,0.0) - CALL WN_PRECALC_CHENG(WNCOMPLEX,dble(SIG(IK)),dble(SIGMAM1),WN_O, & - WNM1,WNM2,ES_MOD,NU,DICE,HICE,DEPTH,SWITCHID,IK,KU) - ! --- Output to routine - WN_R(IK) = REAL(WNCOMPLEX) ! kr - WN_I(IK) = IMAG(WNCOMPLEX) ! ki - ENDDO - CALL SMOOTH_K(WN_R,WN_I,SIG,KU-KL+1,SWITCHID) - CALL CGinIC3_CHENG(CG,SIG,WN_R,KU-KL+1) -!/ - END SUBROUTINE IC3PRECALC_CHENG - -!/ -------------------------------------------------------------------/ - - SUBROUTINE WN_PRECALC_CHENG(WN,SIGMA,SIGMAM1,WN_O,WNM1,WNM2,ES_MOD, & - NU,DICE,HICE,DEPTH,SWITCHID,IK,KU) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | S. Cheng | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | X. Zhao | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2016 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! Calculate complex wavenumber for waves in ice. -! -! 2. Method : -! -! Wang and Shen (JGR 2010) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! WN CMPLX O Wave number (imag. part=wave attenuation) -! SIGMA REAL I Wave angular frequency [in rad] -! WN_O REAL I Wave number (open water) -! ES REAL I Effective shear modulus of ice [in Pa] -! NU REAL I Effective viscosity of ice [in m2/s] -! DICE REAL I Density of ice [in kg/m3] -! HICE REAL I Thickness of ice [in m] -! DEPTH REAL I Water depth [in m] -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! CMPLX_ROOT_MULLER_CHENG Func. W3SIC3MD Find root for complex -! wavenumbers for waves in ice. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! IC3PRECALC_CHENG xxx xxx xxxx -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Updated authors: Cheng and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on Aug 25 2015 -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! -! Hayley Shen says, -! We have determined that it may not be necessary to use curve -! fitting or lookup tables to get the group velocity and the -! attenuation coefficient. Attached is a short report with some -! sample numerical solutions. To implement the viscoelastic model, -! there are 4 fortran programs. According to Xin Zhao, the graduate -! student, it is very fast to find roots. I suggest that perhaps you -! try the pure viscous case by setting G=0 to start with. nu can be -! set at 0.05*ice concentration (m^2/s) to begin with, because for -! grease ice Newyear’s data showed nu to be about 0.02-0.03 m^2/s. -! By setting G=0 in you get exactly the Keller model for pure -! viscous layer. -! -! This routine provides the initial guess according to the parameters -! of the present case. T>10s use open water, T<10s cases, calculate -! T=10s first using open water as the initial guess. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPI -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL(8) :: SIGMA,SIGMAM1,ES_MOD,NU,DICE,HICE,DEPTH - COMPLEX(8) :: WN_O, WNM1, WNM2, WN0, WN1,WN2 - COMPLEX(8),INTENT(OUT) :: WN ! RESULT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I,IX,NUM,SWITCHID,IK,KU - REAL(8) :: RR, R2, EPS, SIGMA0, KAPPA, DIS - COMPLEX(8) :: X0, X1, X2, kp, ks, Gv -!/ -!/ ------------------------------------------------------------------- / -! compute shear wave and pressure wave modes - GV = CMPLX(ES_MOD,-SIGMA*NU*DICE) + IF(IX==NUM+1)THEN + EXIT + ENDIF + WN = X1 !/ --- if exit of inner loop: give an approximate wn + ENDDO ! DO I = 1,7,2 + + ! part 2 + ! assume found two roots, choose from the two condidates. KP = SIGMA/SQRT(4*GV/DICE) - KS = 2*KP -! RR,R2 are empirical coefficients - RR = 0.2 - R2 = 4 - EPS = 1.D-10 ! assuming variable =0, if it is less than this value -! compute root 1 -! initial guesses from wave number of open water -! - X1 = WN_O ! initial guess - X0 = X1*(1-RR) - X2 = X1*(1+RR) - - WN1 = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,1,SIGMA, & - ES_MOD,NU,DICE,HICE,DEPTH) -! if root finder failed, or found shear wave mode, -! redo searching using simplified dispersion relation form, index 2 - IF (REAL(WN1)<0.or.abs(wn1-ks)/abs(ks)<0.03 .or. & - abs(wn1-kp)/abs(kp)<0.03.and.Es_mod>1.e7*nu)THEN - WN1 = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,2,SIGMA, & - ES_MOD,NU,DICE,HICE,DEPTH) - ENDIF -! similar as wn1, but search with opposite order of inital guesses - WN2 = CMPLX_ROOT_MULLER_CHENG(X2,X1,X0,1,SIGMA, & - ES_MOD,NU,DICE,HICE,DEPTH) - IF (REAL(WN2)<0.or.abs(wn2-ks)/abs(ks)<0.03)THEN - WN2 = CMPLX_ROOT_MULLER_CHENG(X2,X1,X0,2,SIGMA, & - ES_MOD,NU,DICE,HICE,DEPTH) - ENDIF - IF(ABS(REAL(WN1)-REAL(WN_O))0.AND.IMAG(WN0)>=0.AND.ABS(WN - WN0)>EPS)THEN + !do switch at last 3 points is not worth numerically. + !For v>5.e-2, it is low chance to be wrong at the last 3 points + ! we suppose to use two mode in the future + IF(NU>0.AND.IK>=KU-1.OR. & + NU>0.AND.SWITCHID/=0)THEN + ! assume one mode switch for general viscoelastic model + ELSE + DIS = ABS(REAL(WN)-REAL(WN_O))/ABS(REAL(WN0)-REAL(WN_O)) + KAPPA = (IMAG(WN)+ EPS)/(IMAG(WN0) + EPS) + ! wn0 has smaller attenuation and closer to k0 + IF ((DIS >= 1 .AND. KAPPA>=1 .AND. & + IMAG(WN0)>=0.1*IMAG(WNM1).AND. & + ABS(WN-KP)=1 .AND. KAPPA<1 .AND. & + ((KAPPA> 0.2 .AND. IMAG(WN0)/REAL(WN0)<0.5).or. & + ABS(REAL(WN)-REAL(KP))1 .and. dis<1 .and. dis> 0.8 ))then + ( KAPPA>1 .AND. DIS<1 .AND. & + ABS(REAL(WN)-REAL(WNM1))> & + ABS(REAL(WN0)-REAL(WNM1)) ))THEN + WN = WN0 + SWITCHID = IK + ! wn0 has lager attenuation and farther to k0 + ELSEIF(DIS<1 .AND. KAPPA<1) THEN + ! keep wn without change + ENDIF ! IF ((DIS >= 1 .AND. KAPPA>=1 .AND. & + ENDIF ! IF(NU>0.AND.IK>=KU-2.OR. & + + ! choose dominant mode is farther than pressure wave. + !but it doens't work for high viscosity. + if (abs(wn-kp)/abs(kp)<0.03) then + wn = wn0 + SWITCHID = IK + endif + !if (real(wn)<=real(wnm1))then + ! wn = wn0 + ! switchid = ik + !endif + + IF (REAL(WN0)>REAL(WNM1).AND.REAL(WN0)0.AND.IMAG(WN0)>=0.AND.ABS(WN - WN0).... + ENDIF ! IF(SIGMAM1==0.)THEN - IF(SIGMAM1==0.)THEN - WN = WN0 - ELSE - ! compute root 2 - ! Calculate the other wave number based on last frequency - ! in the frequency array - R2 = MAX(ABS(WNM1-WNM2)/ABS(WNM2), ABS((SIGMA-SIGMAM1)/SIGMA)) - DO I = 1,7,2 - IF(I<3.AND.SIGMA>4)THEN - CYCLE - ENDIF - NUM = 2**(I-1) - RR = MIN(MAX(R2/REAL(NUM,8),0.001D0),0.5D0) - X1 = WNM1 - DO IX = 1,NUM - X0 = X1*(1-RR) - X2 = X1*(1+RR) - SIGMA0 = SIGMAM1 + (1.0*IX)/NUM*(SIGMA-SIGMAM1) - WN = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,1,SIGMA0, & - ES_MOD,NU,DICE,HICE,DEPTH) - IF(REAL(WN)<0)THEN ! try another searching direction - WN = CMPLX_ROOT_MULLER_CHENG(X2,X1,X0,1,SIGMA0, & - ES_MOD,NU,DICE,HICE,DEPTH) - ENDIF - IF(REAL(WN)<0)THEN ! try another dispersion relation form - WN = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,3,SIGMA0, & - ES_MOD,NU,DICE,HICE,DEPTH) - ENDIF - KP = SIGMA0/SQRT(4*GV/DICE) - KS = 2*KP - ! set 3 means simple dispersion relation form - IF(ABS(WN-KS)/ABS(KS)<0.03.OR.REAL(WN)<0)THEN - WN = CMPLX_ROOT_MULLER_CHENG(X0,X1,X2,2,SIGMA0, & - ES_MOD,NU,DICE,HICE,DEPTH) - ENDIF - X1 = WN - IF( REAL(WN)<0.99*REAL(WNM1).OR. ABS(WN-WN0)>EPS .AND. & - (ABS(X1-WN)/ABS(WN)>0.3 .OR. & - IMAG(WN)/(IMAG(X1)+EPS)>10.OR. REAL(WN)<0))THEN - EXIT ! redo with smaller intervals - ENDIF - X0 = X1 - X1 = WN - ENDDO ! DO IX = 1,NUM - - IF(IX==NUM+1)THEN - EXIT - ENDIF - WN = X1 !/ --- if exit of inner loop: give an approximate wn - ENDDO ! DO I = 1,7,2 - -! part 2 -! assume found two roots, choose from the two condidates. - KP = SIGMA/SQRT(4*GV/DICE) - IF(REAL(WN0)>0.AND.IMAG(WN0)>=0.AND.ABS(WN - WN0)>EPS)THEN -!do switch at last 3 points is not worth numerically. -!For v>5.e-2, it is low chance to be wrong at the last 3 points -! we suppose to use two mode in the future - IF(NU>0.AND.IK>=KU-1.OR. & - NU>0.AND.SWITCHID/=0)THEN -! assume one mode switch for general viscoelastic model - ELSE - DIS = ABS(REAL(WN)-REAL(WN_O))/ABS(REAL(WN0)-REAL(WN_O)) - KAPPA = (IMAG(WN)+ EPS)/(IMAG(WN0) + EPS) -! wn0 has smaller attenuation and closer to k0 - IF ((DIS >= 1 .AND. KAPPA>=1 .AND. & - IMAG(WN0)>=0.1*IMAG(WNM1).AND. & - ABS(WN-KP)=1 .AND. KAPPA<1 .AND. & - ((KAPPA> 0.2 .AND. IMAG(WN0)/REAL(WN0)<0.5).or. & - ABS(REAL(WN)-REAL(KP))1 .and. dis<1 .and. dis> 0.8 ))then - ( KAPPA>1 .AND. DIS<1 .AND. & - ABS(REAL(WN)-REAL(WNM1))> & - ABS(REAL(WN0)-REAL(WNM1)) ))THEN - WN = WN0 - SWITCHID = IK -! wn0 has lager attenuation and farther to k0 - ELSEIF(DIS<1 .AND. KAPPA<1) THEN -! keep wn without change - ENDIF ! IF ((DIS >= 1 .AND. KAPPA>=1 .AND. & - ENDIF ! IF(NU>0.AND.IK>=KU-2.OR. & - -! choose dominant mode is farther than pressure wave. -!but it doens't work for high viscosity. - if (abs(wn-kp)/abs(kp)<0.03) then - wn = wn0 - SWITCHID = IK - endif - !if (real(wn)<=real(wnm1))then - ! wn = wn0 - ! switchid = ik - !endif - - IF (REAL(WN0)>REAL(WNM1).AND.REAL(WN0)0.AND.IMAG(WN0)>=0.AND.ABS(WN - WN0).... - ENDIF ! IF(SIGMAM1==0.)THEN - - IF(REAL(WN)<0)THEN - PRINT*, "MULLER METHOD FAILED, ES_MOD,NU,HICE:",ES_MOD,NU,HICE - ENDIF - RETURN - - END SUBROUTINE WN_PRECALC_CHENG -!/ ----------------------------------------------------------------- -!/ - SUBROUTINE CGINIC3_CHENG(CG,SIGMA,WN_R,N) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | X. Zhao | -!/ | S. Cheng | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2016 | -!/ +-----------------------------------+ -! 1. Purpose : -! -! Calculate group velocity in ic3 model -! -! 2. Method : -! -! finite differece -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! CG R. A. I/O Group velocity -! SIMGA R. A. angular frequency -! WN_R R. A. wave number -! N Int. array size -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! IC3PRECALC_CHENG Subr. W3SIC3MD Create table of kr,ki,cg for -! deep water -! W3IC3WNCG_CHENG Subr. W3SIC3MD Calculate kr,ki,cg -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! Smooth function is used due to jump problem when wave modes -! switch -! -! 8. Structure : -! -! See source code. -! -! 9. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - REAL, INTENT(IN) :: SIGMA(1:N),WN_R(1:N) - REAL, INTENT(OUT) :: CG(1:N) - INTEGER :: N -!/ LOCAL variables - INTEGER :: IK, M - REAL :: CG1,CG2,CG3,CG0(1:N) -!/ + IF(REAL(WN)<0)THEN + PRINT*, "MULLER METHOD FAILED, ES_MOD,NU,HICE:",ES_MOD,NU,HICE + ENDIF + RETURN + + END SUBROUTINE WN_PRECALC_CHENG + !/ ----------------------------------------------------------------- + !/ + SUBROUTINE CGINIC3_CHENG(CG,SIGMA,WN_R,N) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | X. Zhao | + !/ | S. Cheng | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2016 | + !/ +-----------------------------------+ + ! 1. Purpose : + ! + ! Calculate group velocity in ic3 model + ! + ! 2. Method : + ! + ! finite differece + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! CG R. A. I/O Group velocity + ! SIMGA R. A. angular frequency + ! WN_R R. A. wave number + ! N Int. array size + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! IC3PRECALC_CHENG Subr. W3SIC3MD Create table of kr,ki,cg for + ! deep water + ! W3IC3WNCG_CHENG Subr. W3SIC3MD Calculate kr,ki,cg + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! Smooth function is used due to jump problem when wave modes + ! switch + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + REAL, INTENT(IN) :: SIGMA(1:N),WN_R(1:N) + REAL, INTENT(OUT) :: CG(1:N) + INTEGER :: N + !/ LOCAL variables + INTEGER :: IK, M + REAL :: CG1,CG2,CG3,CG0(1:N) + !/ IK = 1 CG(IK)=(SIGMA(IK+1)-SIGMA(IK))/(WN_R(IK+1)-WN_R(IK)) IK = N CG(IK)=(SIGMA(IK)-SIGMA(IK-1))/(WN_R(IK)-WN_R(IK-1)) - DO IK = 2,N-1 - CG1 = (SIGMA(IK)-SIGMA(IK-1))/(WN_R(IK)-WN_R(IK-1)) - CG2 = (SIGMA(IK+1)-SIGMA(IK))/(WN_R(IK+1)-WN_R(IK)) - CG(IK) = 2.0/(1./CG1 + 1./CG2) - END DO - - RETURN - END SUBROUTINE CGINIC3_CHENG - -!/ ------------------------------------------------------------------- / -! numerically smooth WN_R and WN_I by linear interpolation - SUBROUTINE SMOOTH_K(WN_R,WN_I,SIGMA,N,SWITCHID) + DO IK = 2,N-1 + CG1 = (SIGMA(IK)-SIGMA(IK-1))/(WN_R(IK)-WN_R(IK-1)) + CG2 = (SIGMA(IK+1)-SIGMA(IK))/(WN_R(IK+1)-WN_R(IK)) + CG(IK) = 2.0/(1./CG1 + 1./CG2) + END DO + + RETURN + END SUBROUTINE CGINIC3_CHENG + + !/ ------------------------------------------------------------------- / + ! numerically smooth WN_R and WN_I by linear interpolation + SUBROUTINE SMOOTH_K(WN_R,WN_I,SIGMA,N,SWITCHID) REAL, INTENT(IN) :: SIGMA(N) REAL :: WN_R(N), WN_I(N),DIFF(N),REMOVEID(N) INTEGER :: N,I,J,SWITCHID -! + ! DIFF = 0 -! remove kr in mode switch zone, -! if it is a local extremum or suddenly increasing + ! remove kr in mode switch zone, + ! if it is a local extremum or suddenly increasing DO J = 1,3 ! 3 times to guarantee wavenumber increases monotonically - REMOVEID = 0 - DO I = 2,N - DIFF(I) = WN_R(I) - WN_R(I-1) + REMOVEID = 0 + DO I = 2,N + DIFF(I) = WN_R(I) - WN_R(I-1) + ENDDO + DO I = 3,N + IF(DIFF(I)<=0.OR.DIFF(I)>3*DIFF(I-1).OR.SWITCHID==I)THEN + REMOVEID(I) = 1 + REMOVEID(I-1) = 1 + ENDIF + ENDDO + ! fill removed location with kr,ki by interpolation + DO I = 2,N-1 + IF (REMOVEID(I) ==1) THEN + WN_R(I) = WN_R(I-1) + (WN_R(I+1)-WN_R(I-1))/ & + (SIGMA(I+1)-SIGMA(I-1))*(SIGMA(I)-SIGMA(I-1)) + WN_I(I) = WN_I(I-1) + (WN_I(I+1)-WN_I(I-1))/ & + (SIGMA(I+1)-SIGMA(I-1))*(SIGMA(I)-SIGMA(I-1)) + ENDIF + ENDDO ENDDO - DO I = 3,N - IF(DIFF(I)<=0.OR.DIFF(I)>3*DIFF(I-1).OR.SWITCHID==I)THEN - REMOVEID(I) = 1 - REMOVEID(I-1) = 1 - ENDIF - ENDDO -! fill removed location with kr,ki by interpolation - DO I = 2,N-1 - IF (REMOVEID(I) ==1) THEN - WN_R(I) = WN_R(I-1) + (WN_R(I+1)-WN_R(I-1))/ & - (SIGMA(I+1)-SIGMA(I-1))*(SIGMA(I)-SIGMA(I-1)) - WN_I(I) = WN_I(I-1) + (WN_I(I+1)-WN_I(I-1))/ & - (SIGMA(I+1)-SIGMA(I-1))*(SIGMA(I)-SIGMA(I-1)) - ENDIF - ENDDO - ENDDO -! mode switch upward at the last frequencies + ! mode switch upward at the last frequencies IF (DIFF(N)>3*DIFF(N-1))THEN - I = N - WN_R(I) = WN_R(I-1) + (WN_R(I-1)-WN_R(I-2))/ & - (SIGMA(I-1)-SIGMA(I-2))*(SIGMA(I)-SIGMA(I-1)) - WN_I(I) = WN_I(I-1) + (WN_I(I-1)-WN_I(I-2))/ & - (SIGMA(I-1)-SIGMA(I-2))*(SIGMA(I)-SIGMA(I-1)) + I = N + WN_R(I) = WN_R(I-1) + (WN_R(I-1)-WN_R(I-2))/ & + (SIGMA(I-1)-SIGMA(I-2))*(SIGMA(I)-SIGMA(I-1)) + WN_I(I) = WN_I(I-1) + (WN_I(I-1)-WN_I(I-2))/ & + (SIGMA(I-1)-SIGMA(I-2))*(SIGMA(I)-SIGMA(I-1)) ENDIF - RETURN + RETURN END SUBROUTINE SMOOTH_K -!/ ------------------------------------------------------------------- / - - FUNCTION CMPLX_ROOT_MULLER_CHENG(X0, X1, X2, JUDGE, & - SIGMA,ES,NU,DICE,HICE,DEPTH ) RESULT(P3) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | X. Zhao | -!/ | S. Cheng | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2016 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) -!/ -! 1. Purpose : -! -! Find root. -! -! 2. Method : -! -! Muller method for complex equations is a recursive approximation -! with initial guess X0, X1, and X2. To the initial guesses a -! quadratic parabola is fitted. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! P3 CMPLX DBL O Approximation for the root problem -! X0 CMPLX DBL I Initial guess variable -! X1 CMPLX DBL I Initial guess variable -! X2 CMPLX DBL I Initial guess variable -! SIGMA DOUBLE I Wave angular frequency -! ES DOUBLE I Effective shear modulus of ice -! NU DOUBLE I Effective viscosity of ice [in m2/s] -! DICE DOUBLE I Density of ice [in kg/m3] -! HICE DOUBLE I Thickness of ice [in m] -! DEPTH DOUBLE I Water depth [in m] -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! F_ZHAO_CHENG xxxxx xxxx xxxx -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WN_PRECALC_CHENG xxxxx xxxx -! W3IC3WNCG_CHENG xxxxx xxxx -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - COMPLEX(8) :: P3 ! RESULT - COMPLEX(8), INTENT(IN):: X0,X1,X2 - REAL(8), INTENT(IN) :: SIGMA,ES,NU,DICE,HICE,DEPTH - INTEGER, INTENT(IN) :: JUDGE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - - INTEGER :: I - INTEGER, PARAMETER :: IMAX = 200 - REAL(8) :: DLTA,EPSI - COMPLEX(8) :: P0,P1,P2 - COMPLEX(8) :: Y0,Y1,Y2,Y3 - COMPLEX(8) :: A,B,C,Q,DISC,DEN1,DEN2 -!/ -!/ ------------------------------------------------------------------- / - - P0 = X0 - P1 = X1 - P2 = X2 - P3 = 0.D0 - - EPSI = 1.D-8 - DLTA = 1.D-8 ! relax it may cause error, too rigorous is not good neither. - Y0 = F_ZHAO_CHENG(JUDGE,P0,SIGMA,ES,NU,DICE,HICE,DEPTH) - Y1 = F_ZHAO_CHENG(JUDGE,P1,SIGMA,ES,NU,DICE,HICE,DEPTH) - Y2 = F_ZHAO_CHENG(JUDGE,P2,SIGMA,ES,NU,DICE,HICE,DEPTH) - - DO I = 1,IMAX - Q = (P2 - P1) / (P1 - P0) - A = Q * Y2 - Q * (1.D0+Q) * Y1 + Q**2.D0 * Y0 - B = (2.D0 * Q + 1.D0) * Y2 - (1.D0 + Q)**2.D0 * Y1 & - + Q**2.D0 * Y0 - C = (1.D0 + Q) * Y2 - - IF ( ABS(A).NE.0.D0 ) THEN - - DISC = B**2.D0 - 4.D0 * A * C; - - DEN1 = ( B + SQRT ( DISC ) ) - DEN2 = ( B - SQRT ( DISC ) ) - - IF ( ABS ( DEN1 ) .LT. ABS ( DEN2 ) )THEN - P3 = P2 - (P2 - P1) * (2.D0 * C / DEN2) - ELSE - P3 = P2 - (P2 - P1) * (2.D0 * C / DEN1) - ENDIF - - ELSE - - IF ( ABS(B) .NE. 0.D0 )THEN - P3 = P2 - (P2 - P1) * (C / B) - ELSE - P3 = P2 - RETURN - ENDIF - ENDIF - - IF (IMAG(P3).LT.0)THEN - P3 = REAL(P3) - CMPLX(0.,1.)*IMAG(P3) - ENDIF - IF (REAL(P3).LT.0)THEN - P3 = -REAL(P3) + CMPLX(0.,1.)*IMAG(P3) - ENDIF - - IF(NU==0)THEN - P3 = CMPLX(REAL(P3),0) - ENDIF - Y3 = F_ZHAO_CHENG(JUDGE,P3,SIGMA,ES,NU,DICE,HICE,DEPTH); - IF ( ABS(P3-P2).LT.DLTA .AND. ABS(Y3).LT.EPSI ) THEN -! exit before finding a true root,Result may not be accurate - RETURN - ENDIF - - P0 = P1 - P1 = P2 - P2 = P3 - - Y0 = Y1 - Y1 = Y2 - Y2 = Y3 - ENDDO + !/ ------------------------------------------------------------------- / + + FUNCTION CMPLX_ROOT_MULLER_CHENG(X0, X1, X2, JUDGE, & + SIGMA,ES,NU,DICE,HICE,DEPTH ) RESULT(P3) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | X. Zhao | + !/ | S. Cheng | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2016 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Find root. + ! + ! 2. Method : + ! + ! Muller method for complex equations is a recursive approximation + ! with initial guess X0, X1, and X2. To the initial guesses a + ! quadratic parabola is fitted. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! P3 CMPLX DBL O Approximation for the root problem + ! X0 CMPLX DBL I Initial guess variable + ! X1 CMPLX DBL I Initial guess variable + ! X2 CMPLX DBL I Initial guess variable + ! SIGMA DOUBLE I Wave angular frequency + ! ES DOUBLE I Effective shear modulus of ice + ! NU DOUBLE I Effective viscosity of ice [in m2/s] + ! DICE DOUBLE I Density of ice [in kg/m3] + ! HICE DOUBLE I Thickness of ice [in m] + ! DEPTH DOUBLE I Water depth [in m] + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! F_ZHAO_CHENG xxxxx xxxx xxxx + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WN_PRECALC_CHENG xxxxx xxxx + ! W3IC3WNCG_CHENG xxxxx xxxx + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Original authors: Zhao and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on April 19 2013. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + COMPLEX(8) :: P3 ! RESULT + COMPLEX(8), INTENT(IN):: X0,X1,X2 + REAL(8), INTENT(IN) :: SIGMA,ES,NU,DICE,HICE,DEPTH + INTEGER, INTENT(IN) :: JUDGE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + + INTEGER :: I + INTEGER, PARAMETER :: IMAX = 200 + REAL(8) :: DLTA,EPSI + COMPLEX(8) :: P0,P1,P2 + COMPLEX(8) :: Y0,Y1,Y2,Y3 + COMPLEX(8) :: A,B,C,Q,DISC,DEN1,DEN2 + !/ + !/ ------------------------------------------------------------------- / + + P0 = X0 + P1 = X1 + P2 = X2 + P3 = 0.D0 + + EPSI = 1.D-8 + DLTA = 1.D-8 ! relax it may cause error, too rigorous is not good neither. + Y0 = F_ZHAO_CHENG(JUDGE,P0,SIGMA,ES,NU,DICE,HICE,DEPTH) + Y1 = F_ZHAO_CHENG(JUDGE,P1,SIGMA,ES,NU,DICE,HICE,DEPTH) + Y2 = F_ZHAO_CHENG(JUDGE,P2,SIGMA,ES,NU,DICE,HICE,DEPTH) + + DO I = 1,IMAX + Q = (P2 - P1) / (P1 - P0) + A = Q * Y2 - Q * (1.D0+Q) * Y1 + Q**2.D0 * Y0 + B = (2.D0 * Q + 1.D0) * Y2 - (1.D0 + Q)**2.D0 * Y1 & + + Q**2.D0 * Y0 + C = (1.D0 + Q) * Y2 + + IF ( ABS(A).NE.0.D0 ) THEN + + DISC = B**2.D0 - 4.D0 * A * C; + + DEN1 = ( B + SQRT ( DISC ) ) + DEN2 = ( B - SQRT ( DISC ) ) + + IF ( ABS ( DEN1 ) .LT. ABS ( DEN2 ) )THEN + P3 = P2 - (P2 - P1) * (2.D0 * C / DEN2) + ELSE + P3 = P2 - (P2 - P1) * (2.D0 * C / DEN1) + ENDIF - P3 = CMPLX(-100.,0) - RETURN + ELSE - END FUNCTION CMPLX_ROOT_MULLER_CHENG -!/ ------------------------------------------------------------------- / -!/ - FUNCTION F_ZHAO_CHENG(JUDGE,X,SIGMA,ES,NU,DICE,HICE,DEPTH) & - RESULT(FZHAO) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | X. Zhao | -!/ | S. Cheng | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2016 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) -!/ -! 1. Purpose : -! -! Decide whether to call sub-function. -! -! 2. Method : -! -! Decide based on value of integer "JUDGE" -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FZHAO COMPL8 O Result (double complex) -! X CMPLX8 I Approximate result (double complex) -! JUDGE INTEGR I Switch variable -! SIGMA DOUBLE I Wave angular frequency -! ES DOUBLE I Effective shear modulus -! NU DOUBLE I Effective viscosity parameter -! DICE DOUBLE I Density of ice -! HICE DOUBLE I Thickness of ice -! DEPTH DOUBLE I Water depth -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! DRFUN_dble Func. W3SIC3MD Function to find root with double -! precision. -! DRFUN_quad Func. W3SIC3MD Function to find root with quadruple -! precision. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! CMPLX_ROOT_MULLER_CHENG Func. W3SIC3MD Find root for complex -! wavenumbers for waves in ice. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Updated authors: Cheng and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on Aug 25 2015 -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER,INTENT(IN) :: JUDGE - DOUBLE PRECISION, INTENT(IN) :: SIGMA,ES,NU,DICE,HICE,DEPTH - DOUBLE COMPLEX, INTENT(IN) :: X - DOUBLE COMPLEX :: FZHAO ! RESULT -!/ -!/ ------------------------------------------------------------------- / - IF (JUDGE >0) THEN - FZHAO = DRFUN_dble_CHENG(X,SIGMA,ES,NU,DICE,HICE,DEPTH,JUDGE) - ELSEIF(JUDGE ==0)THEN - FZHAO = DRFUN_quad_CHENG(X,SIGMA,ES,NU,DICE,HICE,DEPTH) + IF ( ABS(B) .NE. 0.D0 )THEN + P3 = P2 - (P2 - P1) * (C / B) + ELSE + P3 = P2 + RETURN + ENDIF ENDIF -! - END FUNCTION F_ZHAO_CHENG -!/ ------------------------------------------------------------------- / -!/ - FUNCTION DRFUN_DBLE_CHENG(WN,SIGMA,ES,NU,DICE,HICE,DEPTH,JUDGE) & - RESULT(FUNC1) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | X. Zhao | -!/ | S. Cheng | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2016 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) -!/ -! 1. Purpose : -! -! Return dispersion relation function value for root finding -! -! 2. Method : -! -! function based on dispersion relation derived by Wang and Shen -! 2010 -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FUNC1 CMPLX DBL O Result (COMPLEX(8)) -! WN CMPLX DBL I Wavenumber (COMPLEX(8)) -! W REAL DBL I Wave angular frequency -! ES REAL DBL I Effective shear modulus on ice -! NU REAL DBL I Effective viscosity -! DICE REAL DBL I Density of ice -! HICE REAL DBL I Thickness of ice -! DEPTH REAL DBL I Water depth -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! None. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! F_ZHAO_CHENG xxx xxxx xxxxx -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Updated authors: Cheng and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on Aug 25 2015 -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, DWAT -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - COMPLEX(8), INTENT(IN) :: WN - REAL(8), INTENT(IN) :: SIGMA, ES, NU, DICE, HICE, DEPTH - COMPLEX(8) :: FUNC1,AA(4,4) ! RESULT - INTEGER :: JUDGE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - COMPLEX(8) :: VE,ALPHA,N,M,L,SK,CK,SA,CA,TH,THH,TEMP,J1,J2 -!/ -!/ ------------------------------------------------------------------- / - VE = CMPLX( NU, ES/DICE/SIGMA ) - ALPHA = SQRT ( WN**2. - SIGMA/VE * CMPLX(0.,1.D0) ) - N = SIGMA + 2. * VE * WN**2. * CMPLX(0.,1.D0) - - TEMP = EXP(WN*HICE) - SK = (TEMP - 1.D0/TEMP)/2.D0 - CK = (TEMP + 1.D0/TEMP)/2.D0 - - TEMP = EXP(ALPHA*HICE) - SA = (TEMP - 1.D0/TEMP)/2.D0 - CA = (TEMP + 1.D0/TEMP)/2.D0 -! - TEMP = (WN*DEPTH) - IF ( REAL(TEMP).LT.18.D0 ) THEN - TEMP = EXP(TEMP) - TH = (TEMP - 1./TEMP)/(TEMP + 1./TEMP) - ELSE - TH = 1.D0 + + IF (IMAG(P3).LT.0)THEN + P3 = REAL(P3) - CMPLX(0.,1.)*IMAG(P3) ENDIF -! JUDGE==3 is not used yet - IF ((ES>=1.E5.AND.JUDGE/=2).or.JUDGE==3) THEN - L = 2 * WN * ALPHA * SIGMA * VE - M = (DBLE(DWAT)/DICE - 1) * DBLE(GRAV) * WN & - - DBLE(DWAT) / DICE * SIGMA**2 / TH - AA(1,1) = 0. - AA(1,2) = 2 * CMPLX(0.,1.) * WN**2. - AA(1,3) = ALPHA**2. + WN**2. - AA(1,4) = 0. -! - AA(2,1) = N * SIGMA - AA(2,2) = -WN * DBLE(GRAV) - AA(2,3) = CMPLX(0.,1.) * WN * DBLE(GRAV) - AA(2,4) = L -! - AA(3,1) = -2. * CMPLX(0.,1.) * WN**2. * SK - AA(3,2) = 2. * CMPLX(0.,1.) * WN**2. * CK - AA(3,3) = (ALPHA**2. + WN**2.) * CA - AA(3,4) = -(ALPHA**2. + WN**2.) * SA -! - AA(4,1) = N * SIGMA * CK - M * SK - AA(4,2) = - N * SIGMA * SK + M * CK - AA(4,3) = -CMPLX(0.,1.) * M * CA - L * SA - AA(4,4) = CMPLX(0.,1.) * M * SA + L * CA -! - FUNC1 = BSDET(AA,4) - ELSE - J1 = DICE/DBLE(DWAT)*(WN**2.*DBLE(GRAV)**2.*SK*SA - (N**4. & - + 16.* VE**4.*WN**6.*ALPHA**2.)*SK*SA - 8. & - *WN**3.*ALPHA*VE**2.*N**2.*(CK*CA-1.)) - J2 = (4.*WN**3.*ALPHA*VE**2.*SK*CA+N**2.*SA*CK & - -DBLE(GRAV)*WN*SK*SA) - IF (JUDGE==2)THEN - FUNC1 = (SIGMA**2. - TH*WN*DBLE(GRAV)) - TH*J1/(J2+1.e-20) - ELSEIF (JUDGE==1)THEN - FUNC1 = (SIGMA**2. - TH*WN*DBLE(GRAV))*J2 - TH*J1 - ENDIF + IF (REAL(P3).LT.0)THEN + P3 = -REAL(P3) + CMPLX(0.,1.)*IMAG(P3) ENDIF -!/ - END FUNCTION DRFUN_DBLE_CHENG -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / -!/ - FUNCTION DRFUN_QUAD_CHENG(WN,SIGMA,ES,NU,DICE,HICE,DEPTH) & - RESULT(FUNC1) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | E. Rogers | -!/ | S. Zieger | -!/ | X. Zhao | -!/ | S. Cheng | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2016 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) -!/ (E. Rogers) -!/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) -!/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) -!/ -! 1. Purpose : -! -! Return dispersion relation function value for root finding -! -! 2. Method : -! -! Use quadruple precision for computation -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FUNC1 CMPLX DBL O Result (COMPLEX(8)) -! WN CMPLX DBL I Wavenumber (COMPLEX(8)) -! W REAL DBL I Wave angular frequency -! ES REAL DBL I Effective shear modulus on ice -! NU REAL DBL I Effective viscosity -! DICE REAL DBL I Density of ice -! HICE REAL DBL I Thickness of ice -! DEPTH REAL DBL I Water depth -! -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! None. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! F_ZHAO_CHENG xxx xxxx xxxxx -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! Updated authors: Cheng and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on Aug 25 2015 -! Original authors: Zhao and Shen. -! This code is based on Fortran code provided by Hayley Shen (Clarkson -! University) to Erick Rogers (NRL) on April 19 2013. -! ER: S. Cheng had "COMPLEX(16)" for the local parameters. This is not -! supported by my compiler (gfortran on linux machine), so I changed -! it to "COMPLEX(8)" -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -!/ -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, DWAT -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - COMPLEX(8), INTENT(IN) :: WN - REAL(8), INTENT(IN) :: SIGMA, ES, NU, DICE, HICE, DEPTH - COMPLEX(8) :: FUNC1 ! RESULT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - COMPLEX(8) :: VE,ALPHA,N,M,L,SK,CK,SA,CA,TH,THH,TEMP,J1,J2 -!/ -!/ ------------------------------------------------------------------- / - VE = CMPLX( NU, ES/DICE/SIGMA ) - ALPHA = SQRT ( WN**2. - SIGMA/VE * CMPLX(0.,1.D0) ) - N = SIGMA + 2. * VE * WN**2. * CMPLX(0.,1.D0) - - TEMP = EXP(WN*HICE) - SK = (TEMP - 1.D0/TEMP)/2.D0 - CK = (TEMP + 1.D0/TEMP)/2.D0 - - TEMP = EXP(ALPHA*HICE) - SA = (TEMP - 1.D0/TEMP)/2.D0 - CA = (TEMP + 1.D0/TEMP)/2.D0 -! - TEMP = (WN*DEPTH) - IF ( REAL(TEMP).LT.18.D0 ) THEN - TEMP = EXP(TEMP) - TH = (TEMP - 1./TEMP)/(TEMP + 1./TEMP) - ELSE - TH = 1.D0 + IF(NU==0)THEN + P3 = CMPLX(REAL(P3),0) ENDIF -! + Y3 = F_ZHAO_CHENG(JUDGE,P3,SIGMA,ES,NU,DICE,HICE,DEPTH); + IF ( ABS(P3-P2).LT.DLTA .AND. ABS(Y3).LT.EPSI ) THEN + ! exit before finding a true root,Result may not be accurate + RETURN + ENDIF + + P0 = P1 + P1 = P2 + P2 = P3 + + Y0 = Y1 + Y1 = Y2 + Y2 = Y3 + ENDDO + + P3 = CMPLX(-100.,0) + RETURN + + END FUNCTION CMPLX_ROOT_MULLER_CHENG + !/ ------------------------------------------------------------------- / + !/ + FUNCTION F_ZHAO_CHENG(JUDGE,X,SIGMA,ES,NU,DICE,HICE,DEPTH) & + RESULT(FZHAO) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | X. Zhao | + !/ | S. Cheng | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2016 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Decide whether to call sub-function. + ! + ! 2. Method : + ! + ! Decide based on value of integer "JUDGE" + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FZHAO COMPL8 O Result (double complex) + ! X CMPLX8 I Approximate result (double complex) + ! JUDGE INTEGR I Switch variable + ! SIGMA DOUBLE I Wave angular frequency + ! ES DOUBLE I Effective shear modulus + ! NU DOUBLE I Effective viscosity parameter + ! DICE DOUBLE I Density of ice + ! HICE DOUBLE I Thickness of ice + ! DEPTH DOUBLE I Water depth + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! DRFUN_dble Func. W3SIC3MD Function to find root with double + ! precision. + ! DRFUN_quad Func. W3SIC3MD Function to find root with quadruple + ! precision. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! CMPLX_ROOT_MULLER_CHENG Func. W3SIC3MD Find root for complex + ! wavenumbers for waves in ice. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Updated authors: Cheng and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on Aug 25 2015 + ! Original authors: Zhao and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on April 19 2013. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER,INTENT(IN) :: JUDGE + DOUBLE PRECISION, INTENT(IN) :: SIGMA,ES,NU,DICE,HICE,DEPTH + DOUBLE COMPLEX, INTENT(IN) :: X + DOUBLE COMPLEX :: FZHAO ! RESULT + !/ + !/ ------------------------------------------------------------------- / + IF (JUDGE >0) THEN + FZHAO = DRFUN_dble_CHENG(X,SIGMA,ES,NU,DICE,HICE,DEPTH,JUDGE) + ELSEIF(JUDGE ==0)THEN + FZHAO = DRFUN_quad_CHENG(X,SIGMA,ES,NU,DICE,HICE,DEPTH) + ENDIF + ! + END FUNCTION F_ZHAO_CHENG + !/ ------------------------------------------------------------------- / + !/ + FUNCTION DRFUN_DBLE_CHENG(WN,SIGMA,ES,NU,DICE,HICE,DEPTH,JUDGE) & + RESULT(FUNC1) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | X. Zhao | + !/ | S. Cheng | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2016 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Return dispersion relation function value for root finding + ! + ! 2. Method : + ! + ! function based on dispersion relation derived by Wang and Shen + ! 2010 + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FUNC1 CMPLX DBL O Result (COMPLEX(8)) + ! WN CMPLX DBL I Wavenumber (COMPLEX(8)) + ! W REAL DBL I Wave angular frequency + ! ES REAL DBL I Effective shear modulus on ice + ! NU REAL DBL I Effective viscosity + ! DICE REAL DBL I Density of ice + ! HICE REAL DBL I Thickness of ice + ! DEPTH REAL DBL I Water depth + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! None. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! F_ZHAO_CHENG xxx xxxx xxxxx + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Updated authors: Cheng and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on Aug 25 2015 + ! Original authors: Zhao and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on April 19 2013. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, DWAT + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + COMPLEX(8), INTENT(IN) :: WN + REAL(8), INTENT(IN) :: SIGMA, ES, NU, DICE, HICE, DEPTH + COMPLEX(8) :: FUNC1,AA(4,4) ! RESULT + INTEGER :: JUDGE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + COMPLEX(8) :: VE,ALPHA,N,M,L,SK,CK,SA,CA,TH,THH,TEMP,J1,J2 + !/ + !/ ------------------------------------------------------------------- / + VE = CMPLX( NU, ES/DICE/SIGMA ) + ALPHA = SQRT ( WN**2. - SIGMA/VE * CMPLX(0.,1.D0) ) + N = SIGMA + 2. * VE * WN**2. * CMPLX(0.,1.D0) + + TEMP = EXP(WN*HICE) + SK = (TEMP - 1.D0/TEMP)/2.D0 + CK = (TEMP + 1.D0/TEMP)/2.D0 + + TEMP = EXP(ALPHA*HICE) + SA = (TEMP - 1.D0/TEMP)/2.D0 + CA = (TEMP + 1.D0/TEMP)/2.D0 + ! + TEMP = (WN*DEPTH) + IF ( REAL(TEMP).LT.18.D0 ) THEN + TEMP = EXP(TEMP) + TH = (TEMP - 1./TEMP)/(TEMP + 1./TEMP) + ELSE + TH = 1.D0 + ENDIF + ! JUDGE==3 is not used yet + IF ((ES>=1.E5.AND.JUDGE/=2).or.JUDGE==3) THEN + L = 2 * WN * ALPHA * SIGMA * VE + M = (DBLE(DWAT)/DICE - 1) * DBLE(GRAV) * WN & + - DBLE(DWAT) / DICE * SIGMA**2 / TH + AA(1,1) = 0. + AA(1,2) = 2 * CMPLX(0.,1.) * WN**2. + AA(1,3) = ALPHA**2. + WN**2. + AA(1,4) = 0. + ! + AA(2,1) = N * SIGMA + AA(2,2) = -WN * DBLE(GRAV) + AA(2,3) = CMPLX(0.,1.) * WN * DBLE(GRAV) + AA(2,4) = L + ! + AA(3,1) = -2. * CMPLX(0.,1.) * WN**2. * SK + AA(3,2) = 2. * CMPLX(0.,1.) * WN**2. * CK + AA(3,3) = (ALPHA**2. + WN**2.) * CA + AA(3,4) = -(ALPHA**2. + WN**2.) * SA + ! + AA(4,1) = N * SIGMA * CK - M * SK + AA(4,2) = - N * SIGMA * SK + M * CK + AA(4,3) = -CMPLX(0.,1.) * M * CA - L * SA + AA(4,4) = CMPLX(0.,1.) * M * SA + L * CA + ! + FUNC1 = BSDET(AA,4) + ELSE J1 = DICE/DBLE(DWAT)*(WN**2.*DBLE(GRAV)**2.*SK*SA - (N**4. & - + 16.* VE**4.*WN**6.*ALPHA**2.)*SK*SA - 8. & - *WN**3.*ALPHA*VE**2.*N**2.*(CK*CA-1.)) + + 16.* VE**4.*WN**6.*ALPHA**2.)*SK*SA - 8. & + *WN**3.*ALPHA*VE**2.*N**2.*(CK*CA-1.)) J2 = (4.*WN**3.*ALPHA*VE**2.*SK*CA+N**2.*SA*CK & - -DBLE(GRAV)*WN*SK*SA) - FUNC1 = (SIGMA**2. - TH*WN*DBLE(GRAV))*J2 - TH*J1 -!/ - END FUNCTION DRFUN_quad_CHENG -!/ ------------------------------------------------------------------- / -! End of new codes (or new variants) provided by S. Cheng -!/ ------------------------------------------------------------------- / -!/ -!/ End of module W3SIC3MD -------------------------------------------- / -!/ - END MODULE W3SIC3MD + -DBLE(GRAV)*WN*SK*SA) + IF (JUDGE==2)THEN + FUNC1 = (SIGMA**2. - TH*WN*DBLE(GRAV)) - TH*J1/(J2+1.e-20) + ELSEIF (JUDGE==1)THEN + FUNC1 = (SIGMA**2. - TH*WN*DBLE(GRAV))*J2 - TH*J1 + ENDIF + ENDIF + !/ + END FUNCTION DRFUN_DBLE_CHENG + !/ ------------------------------------------------------------------- / + + !/ ------------------------------------------------------------------- / + !/ + FUNCTION DRFUN_QUAD_CHENG(WN,SIGMA,ES,NU,DICE,HICE,DEPTH) & + RESULT(FUNC1) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | E. Rogers | + !/ | S. Zieger | + !/ | X. Zhao | + !/ | S. Cheng | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2016 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2013 : Origination (port from Clarkson.f90)( version 4.10 ) + !/ (E. Rogers) + !/ 09-Oct-2013 : Update to meet WW3 coding standard (S. Zieger) + !/ 30-Oct-2013 : Clarkson.f90 update added (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Return dispersion relation function value for root finding + ! + ! 2. Method : + ! + ! Use quadruple precision for computation + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FUNC1 CMPLX DBL O Result (COMPLEX(8)) + ! WN CMPLX DBL I Wavenumber (COMPLEX(8)) + ! W REAL DBL I Wave angular frequency + ! ES REAL DBL I Effective shear modulus on ice + ! NU REAL DBL I Effective viscosity + ! DICE REAL DBL I Density of ice + ! HICE REAL DBL I Thickness of ice + ! DEPTH REAL DBL I Water depth + ! + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! None. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! F_ZHAO_CHENG xxx xxxx xxxxx + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Updated authors: Cheng and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on Aug 25 2015 + ! Original authors: Zhao and Shen. + ! This code is based on Fortran code provided by Hayley Shen (Clarkson + ! University) to Erick Rogers (NRL) on April 19 2013. + ! ER: S. Cheng had "COMPLEX(16)" for the local parameters. This is not + ! supported by my compiler (gfortran on linux machine), so I changed + ! it to "COMPLEX(8)" + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + !/ + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, DWAT + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + COMPLEX(8), INTENT(IN) :: WN + REAL(8), INTENT(IN) :: SIGMA, ES, NU, DICE, HICE, DEPTH + COMPLEX(8) :: FUNC1 ! RESULT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + COMPLEX(8) :: VE,ALPHA,N,M,L,SK,CK,SA,CA,TH,THH,TEMP,J1,J2 + !/ + !/ ------------------------------------------------------------------- / + VE = CMPLX( NU, ES/DICE/SIGMA ) + ALPHA = SQRT ( WN**2. - SIGMA/VE * CMPLX(0.,1.D0) ) + N = SIGMA + 2. * VE * WN**2. * CMPLX(0.,1.D0) + + TEMP = EXP(WN*HICE) + SK = (TEMP - 1.D0/TEMP)/2.D0 + CK = (TEMP + 1.D0/TEMP)/2.D0 + + TEMP = EXP(ALPHA*HICE) + SA = (TEMP - 1.D0/TEMP)/2.D0 + CA = (TEMP + 1.D0/TEMP)/2.D0 + ! + TEMP = (WN*DEPTH) + IF ( REAL(TEMP).LT.18.D0 ) THEN + TEMP = EXP(TEMP) + TH = (TEMP - 1./TEMP)/(TEMP + 1./TEMP) + ELSE + TH = 1.D0 + ENDIF + ! + J1 = DICE/DBLE(DWAT)*(WN**2.*DBLE(GRAV)**2.*SK*SA - (N**4. & + + 16.* VE**4.*WN**6.*ALPHA**2.)*SK*SA - 8. & + *WN**3.*ALPHA*VE**2.*N**2.*(CK*CA-1.)) + J2 = (4.*WN**3.*ALPHA*VE**2.*SK*CA+N**2.*SA*CK & + -DBLE(GRAV)*WN*SK*SA) + FUNC1 = (SIGMA**2. - TH*WN*DBLE(GRAV))*J2 - TH*J1 + !/ + END FUNCTION DRFUN_quad_CHENG + !/ ------------------------------------------------------------------- / + ! End of new codes (or new variants) provided by S. Cheng + !/ ------------------------------------------------------------------- / + !/ + !/ End of module W3SIC3MD -------------------------------------------- / + !/ +END MODULE W3SIC3MD diff --git a/model/src/w3sic4md.F90 b/model/src/w3sic4md.F90 index 632d71fa3..77950875d 100644 --- a/model/src/w3sic4md.F90 +++ b/model/src/w3sic4md.F90 @@ -1,386 +1,386 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SIC4MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Collins | -!/ | E. Rogers | -!/ | FORTRAN 90 | -!/ | Last update : 21-Jan-2015 | -!/ +-----------------------------------+ -!/ -!/ For updates see W3SIC4 documentation. -!/ -! 1. Purpose : -! -! Calculate ice source term S_{ice} according to simple methods. -! Attenuation is a function of frequency and specified directly -! by the user. Example: a function is based on an exponential fit to -! the empirical data of Wadhams et al. (1988). -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SIC4 Subr. Public ice source term. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! Source material : -! 1) Wadhams et al. JGR 1988 -! 2) Meylan et al. GRL 2014 -! 3) Kohout & Meylan JGR 2008 in Horvat & Tziperman Cryo. 2015 -! 4) Kohout et al. Nature 2014 -! 5) Doble et al. GRL 2015 -! 6) Rogers et al. JGR 2016 -! Documentation of IC4: -! 1) Collins and Rogers, NRL Memorandum report 2017 -! ---> "A Source Term for Wave Attenuation by Sea -! Ice in WAVEWATCH III® : IC4" -! ---> describes original IC4 methods, 1 to 6 -! 2) Rogers et al., NRL Memorandum report 2018a -! ---> "Forecasting and hindcasting waves in and near the -! marginal ice zone: wave modeling and the ONR “Sea -! State” Field Experiment" -! ---> IC4 method 7 added -! 2) Rogers et al., NRL Memorandum report 2018b -! ---> "Frequency Distribution of Dissipation of Energy of -! Ocean Waves by Sea Ice Using Data from Wave Array 3 of -! the ONR “Sea State” Field Experiment" -! ---> New recommendations for IC4 Method 2 (polynomial fit) -! and IC4 Method 6 (step function via namelist) -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC :: W3SIC4 -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Collins | -!/ | E. Rogers | -!/ | FORTRAN 90 | -!/ | Last update : 24-Feb-2017 | -!/ +-----------------------------------+ -!/ -!/ 03-Dec-2015 : Origination ( version 5.09 ) -!/ (starting from IC1) (C. Collins) -!/ 03-Dec-2015 : W3SIC4 created, Methods 1,2,3,4 (C. Collins) -!/ 21-Jan-2016 : IC4 added to NCEP repository (E. Rogers) -!/ 27-Jan-2016 : Method 5 added (step function) (E. Rogers) -!/ 08-Apr-2016 : Method 6 added (namelist step funct.) (E. Rogers) -!/ 24-Feb-2017 : Corrections to Methods 1,2,3,4 (E. Rogers) -!/ 13-Apr-2017 : Method 7 added (Doble et al. 2015) (E. Rogers) -!/ -!/ FIXME : Move field input to W3SRCE and provide -!/ (S.Zieger) input parameter to W3SIC1 to make the subroutine -!/ : versatile for point output processors ww3_outp -!/ and ww3_ounp. -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! S_{ice} source term using 5 parameters read from input files. -! These parameters are allowed to vary in space and time. -! The parameters control the exponential decay rate k_i -! Since there are 5 parameters, this permits description of -! dependence of k_i on frequency or wavenumber. -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! -! Apply parametric/empirical functions, e.g. from the literature. -! 1) Exponential fit to Wadhams et al. 1988, Table 2 -! 2) Polynomial fit, Eq. 3 from Meylan et al. 2014 -! 3) Quadratic fit to Kohout & Meylan'08 in Horvat & Tziperman'15 -! Here, note that their eqn is given as ln(alpha)=blah, so we -! have alpha=exp(blah) -! 4) Eq. 1 from Kohout et al. 2014 -! -! 5) Simple step function for ki as a function of frequency -! with up to 4 "steps". Controlling parameters KIx and FCx are -! read in as input fields, so they may be nonstationary and -! non-uniform in the same manner that ice concentration and -! water levels may be nonstationary and non-uniform. -! 444444444444 -! 33333333333 -! 222222222222 -! 1111111111111 -! ^ ^ ^ -! | | | -! 5 6 7 -! Here, 1 indicates ki=KI1=ICECOEF1 (ICEP1) -! 2 indicates ki=KI2=ICECOEF2 (ICEP2) -! 3 indicates ki=KI3=ICECOEF3 (ICEP3) -! 4 indicates ki=KI4=ICECOEF4 (ICEP4) -! 5 indicates freq cutoff #1 =FC5=ICECOEF5 (ICEP5) -! 6 indicates freq cutoff #2 =FC6=ICECOEF6 (MUDD) -! 7 indicates freq cutoff #3 =FC7=ICECOEF7 (MUDT) -! freq cutoff is given in Hz, freq=1/T (not sigma) -! Examples using hindcast, inversion with uniform ki: -! 5.1) Beaufort Sea, AWAC mooring, 2012, Aug 17 to 20 -! 0.0418 Hz to 0.15 Hz : ki=10e-6 -! 0.15 Hz to 0.175 Hz : ki=11e-6 -! 0.175 Hz to 0.25 Hz : ki=15e-6 -! 0.25 Hz to 0.5 Hz : ki=25e-6 -! 5.2) Beaufort Sea, AWAC mooring, 2012, Oct 27 to 30 -! 0.0418 Hz to 0.1 Hz : ki=5e-6 -! 0.1 Hz to 0.12 Hz : ki=7e-6 -! 0.12 Hz to 0.16 Hz : ki=15e-6 -! 0.16 Hz to 0.5 Hz : ki=100e-6 -! ICEP1=KI1=5.0e-6 -! ICEP2=KI2=7.0e-6 -! ICEP3=KI3=15.0e-6 -! ICEP4=KI4=100.0e-6 -! ICEP5=FC5=0.10 -! MUDD=FC6=0.12 -! MUDT=FC7=0.16 -! In terms of the 3-character IDs for "Homogeneous field -! data" in ww3_shel.inp, these are, respectively, IC1, IC2, -! IC3, IC4, IC5, MDN, MTH, and so this might look like: -! 'IC1' 19680606 000000 5.0e-6 -! 'IC2' 19680606 000000 7.0e-6 -! 'IC3' 19680606 000000 15.0e-6 -! 'IC4' 19680606 000000 100.0e-6 -! 'IC5' 19680606 000000 0.10 -! 'MDN' 19680606 000000 0.12 -! 'MTH' 19680606 000000 0.16 -! -! 6) Simple step function for ki as a function of frequency -! with up to 10 "steps". Controlling parameters KIx and FCx are -! read in as namelist parameters, so they are stationary and -! uniform. -! The last non-zero FCx value should be a large number, e.g. 99 Hz -! -! 4444444444 <--- ki=ic4_ki(4) -! 3333333333 <--- ki=ic4_ki(3) -! 2222222222 <--- ki=ic4_ki(2) -! 11111111111 <--- ki=ic4_ki(1) -! ^ ^ ^ ^ -! | | | | -! ic4_fc(1) ic4_fc(2) ic4_fc(3) ic4_fc(4)=large number -! Example: Beaufort Sea, AWAC mooring, 2012, Oct 27 to 30 -! &SIC4 IC4METHOD = 6, -! IC4KI = 0.50E-05, 0.70E-05, 0.15E-04, -! 0.10E+00, 0.00E+00, 0.00E+00, -! 0.00E+00, 0.00E+00, 0.00E+00, -! 0.00E+00, -! IC4FC = 0.100, 0.120, 0.160, -! 99.00, 0.000, 0.000, -! 0.000, 0.000, 0.000, -! 0.000 -! / -! -! 7) Doble et al. (GRL 2015), eq. 3. This is a function of ice -! thickness and wave period. -! ALPHA = 0.2*(T^(-2.13)*HICE or -! ALPHA = 0.2*(FREQ^2.13)*HICE -! -! More verbose description of implementation of Sice in WW3: -! See documentation for IC1 -! -! Notes regarding numerics: -! See documentation for IC1 -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! DEPTH Real I Local water depth -! CG R.A. I Group velocities. -! IX,IY I.S. I Grid indices. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). -! PRT2DS Subr. W3ARRYMD Print plot output (!/T1 switch). -! OUTMAT Subr. W3ARRYMD Matrix output (!/T2 switch). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A ASCII Point output post-processor. -! W3EXNC Subr. N/A NetCDF Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! If ice parameter 1 is zero, no calculations are made. -! For questions, comments and/or corrections, please refer to: -! Method 1 : C. Collins -! Method 2 : C. Collins -! Method 3 : C. Collins -! Method 4 : C. Collins -! Method 5 : E. Rogers -! Method 6 : E. Rogers -! Method 7 : E. Rogers -! -! ALPHA = 2 * WN_I -! Though it may seem redundant/unnecessary to have *both* in the -! code, we do it this way to make the code easier to read and -! relate to other codes and source material, and hopefully avoid -! mistakes. -!/ ------------------------------------------------------------------- / -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPI - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, IC4PARS, DDEN, & - IC4_KI, IC4_FC, NIC4 - USE W3IDATMD, ONLY: ICEP1, ICEP2, ICEP3, ICEP4, ICEP5, & - MUDT, MUDV, MUDD, INFLAGS2 +MODULE W3SIC4MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Collins | + !/ | E. Rogers | + !/ | FORTRAN 90 | + !/ | Last update : 21-Jan-2015 | + !/ +-----------------------------------+ + !/ + !/ For updates see W3SIC4 documentation. + !/ + ! 1. Purpose : + ! + ! Calculate ice source term S_{ice} according to simple methods. + ! Attenuation is a function of frequency and specified directly + ! by the user. Example: a function is based on an exponential fit to + ! the empirical data of Wadhams et al. (1988). + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SIC4 Subr. Public ice source term. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! Source material : + ! 1) Wadhams et al. JGR 1988 + ! 2) Meylan et al. GRL 2014 + ! 3) Kohout & Meylan JGR 2008 in Horvat & Tziperman Cryo. 2015 + ! 4) Kohout et al. Nature 2014 + ! 5) Doble et al. GRL 2015 + ! 6) Rogers et al. JGR 2016 + ! Documentation of IC4: + ! 1) Collins and Rogers, NRL Memorandum report 2017 + ! ---> "A Source Term for Wave Attenuation by Sea + ! Ice in WAVEWATCH III® : IC4" + ! ---> describes original IC4 methods, 1 to 6 + ! 2) Rogers et al., NRL Memorandum report 2018a + ! ---> "Forecasting and hindcasting waves in and near the + ! marginal ice zone: wave modeling and the ONR “Sea + ! State” Field Experiment" + ! ---> IC4 method 7 added + ! 2) Rogers et al., NRL Memorandum report 2018b + ! ---> "Frequency Distribution of Dissipation of Energy of + ! Ocean Waves by Sea Ice Using Data from Wave Array 3 of + ! the ONR “Sea State” Field Experiment" + ! ---> New recommendations for IC4 Method 2 (polynomial fit) + ! and IC4 Method 6 (step function via namelist) + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC :: W3SIC4 + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Collins | + !/ | E. Rogers | + !/ | FORTRAN 90 | + !/ | Last update : 24-Feb-2017 | + !/ +-----------------------------------+ + !/ + !/ 03-Dec-2015 : Origination ( version 5.09 ) + !/ (starting from IC1) (C. Collins) + !/ 03-Dec-2015 : W3SIC4 created, Methods 1,2,3,4 (C. Collins) + !/ 21-Jan-2016 : IC4 added to NCEP repository (E. Rogers) + !/ 27-Jan-2016 : Method 5 added (step function) (E. Rogers) + !/ 08-Apr-2016 : Method 6 added (namelist step funct.) (E. Rogers) + !/ 24-Feb-2017 : Corrections to Methods 1,2,3,4 (E. Rogers) + !/ 13-Apr-2017 : Method 7 added (Doble et al. 2015) (E. Rogers) + !/ + !/ FIXME : Move field input to W3SRCE and provide + !/ (S.Zieger) input parameter to W3SIC1 to make the subroutine + !/ : versatile for point output processors ww3_outp + !/ and ww3_ounp. + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! S_{ice} source term using 5 parameters read from input files. + ! These parameters are allowed to vary in space and time. + ! The parameters control the exponential decay rate k_i + ! Since there are 5 parameters, this permits description of + ! dependence of k_i on frequency or wavenumber. + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! + ! Apply parametric/empirical functions, e.g. from the literature. + ! 1) Exponential fit to Wadhams et al. 1988, Table 2 + ! 2) Polynomial fit, Eq. 3 from Meylan et al. 2014 + ! 3) Quadratic fit to Kohout & Meylan'08 in Horvat & Tziperman'15 + ! Here, note that their eqn is given as ln(alpha)=blah, so we + ! have alpha=exp(blah) + ! 4) Eq. 1 from Kohout et al. 2014 + ! + ! 5) Simple step function for ki as a function of frequency + ! with up to 4 "steps". Controlling parameters KIx and FCx are + ! read in as input fields, so they may be nonstationary and + ! non-uniform in the same manner that ice concentration and + ! water levels may be nonstationary and non-uniform. + ! 444444444444 + ! 33333333333 + ! 222222222222 + ! 1111111111111 + ! ^ ^ ^ + ! | | | + ! 5 6 7 + ! Here, 1 indicates ki=KI1=ICECOEF1 (ICEP1) + ! 2 indicates ki=KI2=ICECOEF2 (ICEP2) + ! 3 indicates ki=KI3=ICECOEF3 (ICEP3) + ! 4 indicates ki=KI4=ICECOEF4 (ICEP4) + ! 5 indicates freq cutoff #1 =FC5=ICECOEF5 (ICEP5) + ! 6 indicates freq cutoff #2 =FC6=ICECOEF6 (MUDD) + ! 7 indicates freq cutoff #3 =FC7=ICECOEF7 (MUDT) + ! freq cutoff is given in Hz, freq=1/T (not sigma) + ! Examples using hindcast, inversion with uniform ki: + ! 5.1) Beaufort Sea, AWAC mooring, 2012, Aug 17 to 20 + ! 0.0418 Hz to 0.15 Hz : ki=10e-6 + ! 0.15 Hz to 0.175 Hz : ki=11e-6 + ! 0.175 Hz to 0.25 Hz : ki=15e-6 + ! 0.25 Hz to 0.5 Hz : ki=25e-6 + ! 5.2) Beaufort Sea, AWAC mooring, 2012, Oct 27 to 30 + ! 0.0418 Hz to 0.1 Hz : ki=5e-6 + ! 0.1 Hz to 0.12 Hz : ki=7e-6 + ! 0.12 Hz to 0.16 Hz : ki=15e-6 + ! 0.16 Hz to 0.5 Hz : ki=100e-6 + ! ICEP1=KI1=5.0e-6 + ! ICEP2=KI2=7.0e-6 + ! ICEP3=KI3=15.0e-6 + ! ICEP4=KI4=100.0e-6 + ! ICEP5=FC5=0.10 + ! MUDD=FC6=0.12 + ! MUDT=FC7=0.16 + ! In terms of the 3-character IDs for "Homogeneous field + ! data" in ww3_shel.inp, these are, respectively, IC1, IC2, + ! IC3, IC4, IC5, MDN, MTH, and so this might look like: + ! 'IC1' 19680606 000000 5.0e-6 + ! 'IC2' 19680606 000000 7.0e-6 + ! 'IC3' 19680606 000000 15.0e-6 + ! 'IC4' 19680606 000000 100.0e-6 + ! 'IC5' 19680606 000000 0.10 + ! 'MDN' 19680606 000000 0.12 + ! 'MTH' 19680606 000000 0.16 + ! + ! 6) Simple step function for ki as a function of frequency + ! with up to 10 "steps". Controlling parameters KIx and FCx are + ! read in as namelist parameters, so they are stationary and + ! uniform. + ! The last non-zero FCx value should be a large number, e.g. 99 Hz + ! + ! 4444444444 <--- ki=ic4_ki(4) + ! 3333333333 <--- ki=ic4_ki(3) + ! 2222222222 <--- ki=ic4_ki(2) + ! 11111111111 <--- ki=ic4_ki(1) + ! ^ ^ ^ ^ + ! | | | | + ! ic4_fc(1) ic4_fc(2) ic4_fc(3) ic4_fc(4)=large number + ! Example: Beaufort Sea, AWAC mooring, 2012, Oct 27 to 30 + ! &SIC4 IC4METHOD = 6, + ! IC4KI = 0.50E-05, 0.70E-05, 0.15E-04, + ! 0.10E+00, 0.00E+00, 0.00E+00, + ! 0.00E+00, 0.00E+00, 0.00E+00, + ! 0.00E+00, + ! IC4FC = 0.100, 0.120, 0.160, + ! 99.00, 0.000, 0.000, + ! 0.000, 0.000, 0.000, + ! 0.000 + ! / + ! + ! 7) Doble et al. (GRL 2015), eq. 3. This is a function of ice + ! thickness and wave period. + ! ALPHA = 0.2*(T^(-2.13)*HICE or + ! ALPHA = 0.2*(FREQ^2.13)*HICE + ! + ! More verbose description of implementation of Sice in WW3: + ! See documentation for IC1 + ! + ! Notes regarding numerics: + ! See documentation for IC1 + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! DEPTH Real I Local water depth + ! CG R.A. I Group velocities. + ! IX,IY I.S. I Grid indices. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). + ! PRT2DS Subr. W3ARRYMD Print plot output (!/T1 switch). + ! OUTMAT Subr. W3ARRYMD Matrix output (!/T2 switch). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A ASCII Point output post-processor. + ! W3EXNC Subr. N/A NetCDF Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! If ice parameter 1 is zero, no calculations are made. + ! For questions, comments and/or corrections, please refer to: + ! Method 1 : C. Collins + ! Method 2 : C. Collins + ! Method 3 : C. Collins + ! Method 4 : C. Collins + ! Method 5 : E. Rogers + ! Method 6 : E. Rogers + ! Method 7 : E. Rogers + ! + ! ALPHA = 2 * WN_I + ! Though it may seem redundant/unnecessary to have *both* in the + ! code, we do it this way to make the code easier to read and + ! relate to other codes and source material, and hopefully avoid + ! mistakes. + !/ ------------------------------------------------------------------- / + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPI + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, IC4PARS, DDEN, & + IC4_KI, IC4_FC, NIC4 + USE W3IDATMD, ONLY: ICEP1, ICEP2, ICEP3, ICEP4, ICEP5, & + MUDT, MUDV, MUDD, INFLAGS2 #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: CG(NK), A(NSPEC), DEPTH - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) - INTEGER, INTENT(IN) :: IX, IY -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: CG(NK), A(NSPEC), DEPTH + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + INTEGER, INTENT(IN) :: IX, IY + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T0 - INTEGER :: ITH - REAL :: DOUT(NK,NTH) + INTEGER :: ITH + REAL :: DOUT(NK,NTH) #endif - INTEGER :: IKTH, IK, ITH, IC4METHOD, IFC - REAL :: D1D(NK), EB(NK) - REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & - ICECOEF4, ICECOEF5, ICECOEF6, & - ICECOEF7, ICECOEF8 + INTEGER :: IKTH, IK, ITH, IC4METHOD, IFC + REAL :: D1D(NK), EB(NK) + REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & + ICECOEF4, ICECOEF5, ICECOEF6, & + ICECOEF7, ICECOEF8 - REAL :: x1,x2,x3,x1sqr,x2sqr,x3sqr !case 8 - REAL :: perfour,amhb,bmhb !case 8 + REAL :: x1,x2,x3,x1sqr,x2sqr,x3sqr !case 8 + REAL :: perfour,amhb,bmhb !case 8 - REAL :: KI1,KI2,KI3,KI4,FC5,FC6,FC7,FREQ - REAL :: HS, EMEAN, HICE - REAL, ALLOCATABLE :: WN_I(:) ! exponential decay rate for amplitude - REAL, ALLOCATABLE :: ALPHA(:) ! exponential decay rate for energy - REAL, ALLOCATABLE :: MARG1(:), MARG2(:) ! Arguments for M2 - REAL, ALLOCATABLE :: KARG1(:), KARG2(:), KARG3(:) !Arguments for M3 + REAL :: KI1,KI2,KI3,KI4,FC5,FC6,FC7,FREQ + REAL :: HS, EMEAN, HICE + REAL, ALLOCATABLE :: WN_I(:) ! exponential decay rate for amplitude + REAL, ALLOCATABLE :: ALPHA(:) ! exponential decay rate for energy + REAL, ALLOCATABLE :: MARG1(:), MARG2(:) ! Arguments for M2 + REAL, ALLOCATABLE :: KARG1(:), KARG2(:), KARG3(:) !Arguments for M3 -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIC4') + CALL STRACE (IENT, 'W3SIC4') #endif -! -! 0. Initializations ------------------------------------------------ * -! - D = 0.0 -! - ALLOCATE(WN_I(0:NK+1)) - ALLOCATE(ALPHA(0:NK+1)) - ALLOCATE(MARG1(0:NK+1)) - ALLOCATE(MARG2(0:NK+1)) - ALLOCATE(KARG1(0:NK+1)) - ALLOCATE(KARG2(0:NK+1)) - ALLOCATE(KARG3(0:NK+1)) - MARG1 = 0.0 - MARG2 = 0.0 - KARG1 = 0.0 - KARG2 = 0.0 - KARG3 = 0.0 - WN_I = 0.0 - ALPHA = 0.0 - ICECOEF1 = 0.0 - ICECOEF2 = 0.0 - ICECOEF3 = 0.0 - ICECOEF4 = 0.0 - ICECOEF5 = 0.0 - ICECOEF6 = 0.0 - ICECOEF7 = 0.0 - ICECOEF8 = 0.0 - HS = 0.0 - HICE = 0.0 - EMEAN = 0.0 -! -! IF (.NOT.INFLAGS2(-7))THEN -! WRITE (NDSE,1001) 'ICE PARAMETER 1' -! CALL EXTCDE(201) -! ENDIF + ! + ! 0. Initializations ------------------------------------------------ * + ! + D = 0.0 + ! + ALLOCATE(WN_I(0:NK+1)) + ALLOCATE(ALPHA(0:NK+1)) + ALLOCATE(MARG1(0:NK+1)) + ALLOCATE(MARG2(0:NK+1)) + ALLOCATE(KARG1(0:NK+1)) + ALLOCATE(KARG2(0:NK+1)) + ALLOCATE(KARG3(0:NK+1)) + MARG1 = 0.0 + MARG2 = 0.0 + KARG1 = 0.0 + KARG2 = 0.0 + KARG3 = 0.0 + WN_I = 0.0 + ALPHA = 0.0 + ICECOEF1 = 0.0 + ICECOEF2 = 0.0 + ICECOEF3 = 0.0 + ICECOEF4 = 0.0 + ICECOEF5 = 0.0 + ICECOEF6 = 0.0 + ICECOEF7 = 0.0 + ICECOEF8 = 0.0 + HS = 0.0 + HICE = 0.0 + EMEAN = 0.0 + ! + ! IF (.NOT.INFLAGS2(-7))THEN + ! WRITE (NDSE,1001) 'ICE PARAMETER 1' + ! CALL EXTCDE(201) + ! ENDIF -! -! We cannot remove the other use of INFLAGS below, -! because we would get 'array not allocated' error for the methods -! that don't use MUDV, etc. and don't have MUDV allocated. + ! + ! We cannot remove the other use of INFLAGS below, + ! because we would get 'array not allocated' error for the methods + ! that don't use MUDV, etc. and don't have MUDV allocated. - IF (INFLAGS2(-7)) ICECOEF1 = ICEP1(IX,IY) ! a.k.a. IC1 - IF (INFLAGS2(-6)) ICECOEF2 = ICEP2(IX,IY) ! etc. - IF (INFLAGS2(-5)) ICECOEF3 = ICEP3(IX,IY) - IF (INFLAGS2(-4)) ICECOEF4 = ICEP4(IX,IY) - IF (INFLAGS2(-3)) ICECOEF5 = ICEP5(IX,IY) + IF (INFLAGS2(-7)) ICECOEF1 = ICEP1(IX,IY) ! a.k.a. IC1 + IF (INFLAGS2(-6)) ICECOEF2 = ICEP2(IX,IY) ! etc. + IF (INFLAGS2(-5)) ICECOEF3 = ICEP3(IX,IY) + IF (INFLAGS2(-4)) ICECOEF4 = ICEP4(IX,IY) + IF (INFLAGS2(-3)) ICECOEF5 = ICEP5(IX,IY) -! Borrow from Smud (error if BT8 or BT9) + ! Borrow from Smud (error if BT8 or BT9) #ifdef W3_BT8 WRITE (NDSE,*) 'DUPLICATE USE OF MUD PARAMETERS' CALL EXTCDE(202) @@ -389,227 +389,224 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) WRITE (NDSE,*) 'DUPLICATE USE OF MUD PARAMETERS' CALL EXTCDE(202) #endif - IF (INFLAGS2(-2)) ICECOEF6 = MUDD(IX,IY) ! a.k.a. MDN - IF (INFLAGS2(-1)) ICECOEF7 = MUDT(IX,IY) ! a.k.a. MTH - IF (INFLAGS2(0 )) ICECOEF8 = MUDV(IX,IY) ! a.k.a. MVS - IC4METHOD = IC4PARS(1) -! -! x. No ice --------------------------------------------------------- / -! -! IF ( ICECOEF1==0. ) THEN -! D = 0. -! WRITE(*,*) '!!!No Ice!!!' -! -! x. Ice ------------------------------------------------------------ / -! ELSE -! -! x.x Set constant(s) and write test output -------------------------- / -! -! (none) -! + IF (INFLAGS2(-2)) ICECOEF6 = MUDD(IX,IY) ! a.k.a. MDN + IF (INFLAGS2(-1)) ICECOEF7 = MUDT(IX,IY) ! a.k.a. MTH + IF (INFLAGS2(0 )) ICECOEF8 = MUDV(IX,IY) ! a.k.a. MVS + IC4METHOD = IC4PARS(1) + ! + ! x. No ice --------------------------------------------------------- / + ! + ! IF ( ICECOEF1==0. ) THEN + ! D = 0. + ! WRITE(*,*) '!!!No Ice!!!' + ! + ! x. Ice ------------------------------------------------------------ / + ! ELSE + ! + ! x.x Set constant(s) and write test output -------------------------- / + ! + ! (none) + ! #ifdef W3_T38 - WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 + WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 #endif -! -! 1. Make calculations ---------------------------------------------- / -! -! 1.a Calculate WN_I + ! + ! 1. Make calculations ---------------------------------------------- / + ! + ! 1.a Calculate WN_I - SELECT CASE (IC4METHOD) - - CASE (1) ! IC4M1 : Exponential fit to Wadhams et al. 1988 - ALPHA = EXP(-ICECOEF1 * TPI / SIG - ICECOEF2) - WN_I = 0.5 * ALPHA - - CASE (2) ! IC4M2 : Polynomial fit, Eq. 3 from Meylan et al. 2014 - !NB: Eq. 3 only includes T^2 and T^4 terms, - ! which correspond to ICECOEF3, ICECOEF5, so in - ! regtest: ICECOEF1=ICECOEF2=ICECOEF4=0 - MARG1 = ICECOEF1 + ICECOEF2*(SIG/TPI) + ICECOEF3*(SIG/TPI)**2 - MARG2 = ICECOEF4*(SIG/TPI)**3 + ICECOEF5*(SIG/TPI)**4 - ALPHA = MARG1 + MARG2 - WN_I = 0.5 * ALPHA - - CASE (3) ! IC4M3 : Quadratic fit to Kohout & Meylan'08 in Horvat & Tziperman'15 - HICE=ICECOEF1 ! For this method, ICECOEF1=ice thickness - KARG1 = -0.3203 + 2.058*HICE - 0.9375*(TPI/SIG) - KARG2 = -0.4269*HICE**2 + 0.1566*HICE*(TPI/SIG) - KARG3 = 0.0006 * (TPI/SIG)**2 - ALPHA = EXP(KARG1 + KARG2 + KARG3) - WN_I = 0.5 * ALPHA - - CASE (4) !Eq. 1 from Kohout et al. 2014 - !Calculate HS - DO IK=1, NK - EB(IK) = 0. - DO ITH=1, NTH - EB(IK) = EB(IK) + A(ITH+(IK-1)*NTH) - END DO - END DO - DO IK=1, NK - EB(IK) = EB(IK) * DDEN(IK) / CG(IK) - EMEAN = EMEAN + EB(IK) - END DO - HS = 4.*SQRT( MAX(0.,EMEAN) ) - ! If Hs < 3 m then do Hs dependent calc, otherwise dH/dx is a constant - IF (HS <= 3) THEN - WN_I=ICECOEF1 ! from: DHDX=ICECOEF1*HS and WN_I=DHDX/HS - ELSE IF (HS > 3) THEN - WN_I=ICECOEF2/HS ! from: DHDX=ICECOEF2 and WN_I=DHDX/HS - END IF + SELECT CASE (IC4METHOD) - CASE (5) ! Simple step function (time- and/or space-varying) - ! rename variables for clarity - KI1=ICECOEF1 - KI2=ICECOEF2 - KI3=ICECOEF3 - KI4=ICECOEF4 - FC5=ICECOEF5 - FC6=ICECOEF6 - FC7=ICECOEF7 - IF((KI1.EQ.0.0).OR.(KI2.EQ.0.0).OR.(KI3.EQ.0.0).OR. & - (KI4.EQ.0.0).OR.(FC5.EQ.0.0).OR.(FC6.EQ.0.0).OR. & - (FC7.EQ.0.0))THEN - WRITE (NDSE,1001)'ICE PARAMETERS' - CALL EXTCDE(201) - END IF - DO IK=1, NK - FREQ=SIG(IK)/TPI - ! select ki - IF(FREQ.LT.FC5)THEN - WN_I(IK)=KI1 - ELSEIF(FREQ.LT.FC6)THEN - WN_I(IK)=KI2 - ELSEIF(FREQ.LT.FC7)THEN - WN_I(IK)=KI3 - ELSE - WN_I(IK)=KI4 - ENDIF - END DO + CASE (1) ! IC4M1 : Exponential fit to Wadhams et al. 1988 + ALPHA = EXP(-ICECOEF1 * TPI / SIG - ICECOEF2) + WN_I = 0.5 * ALPHA - CASE (6) ! Simple step function (from namelist) + CASE (2) ! IC4M2 : Polynomial fit, Eq. 3 from Meylan et al. 2014 + !NB: Eq. 3 only includes T^2 and T^4 terms, + ! which correspond to ICECOEF3, ICECOEF5, so in + ! regtest: ICECOEF1=ICECOEF2=ICECOEF4=0 + MARG1 = ICECOEF1 + ICECOEF2*(SIG/TPI) + ICECOEF3*(SIG/TPI)**2 + MARG2 = ICECOEF4*(SIG/TPI)**3 + ICECOEF5*(SIG/TPI)**4 + ALPHA = MARG1 + MARG2 + WN_I = 0.5 * ALPHA - ! error checking: require at least 3 steps - IF((IC4_KI(1).EQ.0.0).OR.(IC4_KI(2).EQ.0.0).OR. & - (IC4_KI(3).EQ.0.0).OR.(IC4_FC(1).EQ.0.0).OR. & - (IC4_FC(2).EQ.0.0) )THEN - WRITE (NDSE,1001)'ICE PARAMETERS' - CALL EXTCDE(201) - END IF + CASE (3) ! IC4M3 : Quadratic fit to Kohout & Meylan'08 in Horvat & Tziperman'15 + HICE=ICECOEF1 ! For this method, ICECOEF1=ice thickness + KARG1 = -0.3203 + 2.058*HICE - 0.9375*(TPI/SIG) + KARG2 = -0.4269*HICE**2 + 0.1566*HICE*(TPI/SIG) + KARG3 = 0.0006 * (TPI/SIG)**2 + ALPHA = EXP(KARG1 + KARG2 + KARG3) + WN_I = 0.5 * ALPHA - DO IK=1, NK - FREQ=SIG(IK)/TPI - ! select ki - DO IFC=1,NIC4 - IF(FREQ.LT.IC4_FC(IFC))THEN - WN_I(IK)=IC4_KI(IFC) - EXIT - END IF - END DO - END DO + CASE (4) !Eq. 1 from Kohout et al. 2014 + !Calculate HS + DO IK=1, NK + EB(IK) = 0. + DO ITH=1, NTH + EB(IK) = EB(IK) + A(ITH+(IK-1)*NTH) + END DO + END DO + DO IK=1, NK + EB(IK) = EB(IK) * DDEN(IK) / CG(IK) + EMEAN = EMEAN + EB(IK) + END DO + HS = 4.*SQRT( MAX(0.,EMEAN) ) + ! If Hs < 3 m then do Hs dependent calc, otherwise dH/dx is a constant + IF (HS <= 3) THEN + WN_I=ICECOEF1 ! from: DHDX=ICECOEF1*HS and WN_I=DHDX/HS + ELSE IF (HS > 3) THEN + WN_I=ICECOEF2/HS ! from: DHDX=ICECOEF2 and WN_I=DHDX/HS + END IF - CASE (7) ! Doble et al. (GRL 2015) - - HICE=ICECOEF1 ! For this method, ICECOEF1=ice thickness - DO IK=1,NK - FREQ=SIG(IK)/TPI - ALPHA(IK) = 0.2*(FREQ**2.13)*HICE - END DO - WN_I= 0.5 * ALPHA + CASE (5) ! Simple step function (time- and/or space-varying) + ! rename variables for clarity + KI1=ICECOEF1 + KI2=ICECOEF2 + KI3=ICECOEF3 + KI4=ICECOEF4 + FC5=ICECOEF5 + FC6=ICECOEF6 + FC7=ICECOEF7 + IF((KI1.EQ.0.0).OR.(KI2.EQ.0.0).OR.(KI3.EQ.0.0).OR. & + (KI4.EQ.0.0).OR.(FC5.EQ.0.0).OR.(FC6.EQ.0.0).OR. & + (FC7.EQ.0.0))THEN + WRITE (NDSE,1001)'ICE PARAMETERS' + CALL EXTCDE(201) + END IF + DO IK=1, NK + FREQ=SIG(IK)/TPI + ! select ki + IF(FREQ.LT.FC5)THEN + WN_I(IK)=KI1 + ELSEIF(FREQ.LT.FC6)THEN + WN_I(IK)=KI2 + ELSEIF(FREQ.LT.FC7)THEN + WN_I(IK)=KI3 + ELSE + WN_I(IK)=KI4 + ENDIF + END DO - CASE (8) - !CMB added option of cubic fit to Meylan, Horvat & Bitz in prep - ! ICECOEF1 is thickness - ! ICECOEF5 is floe size - ! TPI/SIG is period - x3=min(ICECOEF1,3.5) ! limit thickness to 3.5 m - x3=max(x3,0.1) ! limit thickness >0.1 m since I make fit below - x2=min(ICECOEF5*0.5,100.0) ! convert dia to radius, limit to 100m - x2=max(2.5,x2) - x2sqr=x2*x2 - x3sqr=x3*x3 - amhb = 2.12e-3 - bmhb = 4.59e-2 + CASE (6) ! Simple step function (from namelist) - DO IK=1, NK - x1=TPI/SIG(IK) ! period - x1sqr=x1*x1 - KARG1(ik)=-0.26982 + 1.5043*x3 - 0.70112*x3sqr + 0.011037*x2 + & - (-0.0073178)*x2*x3 + 0.00036604*x2*x3sqr + & - (-0.00045789)*x2sqr + 1.8034e-05*x2sqr*x3 + & - (-0.7246)*x1 + 0.12068*x1*x3 + & - (-0.0051311)*x1*x3sqr + 0.0059241*x1*x2 + & - 0.00010771*x1*x2*x3 - 1.0171e-05*x1*x2sqr + & - 0.0035412*x1sqr - 0.0031893*x1sqr*x3 + & - (-0.00010791)*x1sqr*x2 + & - 0.00031073*x1**3 + 1.5996e-06*x2**3 + 0.090994*x3**3 - KARG1(ik)=min(karg1(ik),0.0) - WN_I(ik) = 10.0**KARG1(ik) - perfour=x1sqr*x1sqr - if ((x1.gt.5.0) .and. (x1.lt.20.0)) then - WN_I(IK) = WN_I(IK) + amhb/x1sqr+bmhb/perfour - else if (x1.gt.20.0) then - WN_I(IK) = amhb/x1sqr+bmhb/perfour - endif - end do - CASE DEFAULT - WN_I = ICECOEF1 !Default to IC1: Uniform in k - - END SELECT + ! error checking: require at least 3 steps + IF((IC4_KI(1).EQ.0.0).OR.(IC4_KI(2).EQ.0.0).OR. & + (IC4_KI(3).EQ.0.0).OR.(IC4_FC(1).EQ.0.0).OR. & + (IC4_FC(2).EQ.0.0) )THEN + WRITE (NDSE,1001)'ICE PARAMETERS' + CALL EXTCDE(201) + END IF -! -! 1.b Calculate DID -! - DO IK=1, NK -! SBT1 has: D1D(IK) = FACTOR * MAX(0., (CG(IK)*WN(IK)/SIG(IK)-0.5) ) -! recall that D=S/E=-2*Cg*k_i - D1D(IK) = -2. * CG(IK) * WN_I(IK) + DO IK=1, NK + FREQ=SIG(IK)/TPI + ! select ki + DO IFC=1,NIC4 + IF(FREQ.LT.IC4_FC(IFC))THEN + WN_I(IK)=IC4_KI(IFC) + EXIT + END IF + END DO + END DO - END DO + CASE (7) ! Doble et al. (GRL 2015) + + HICE=ICECOEF1 ! For this method, ICECOEF1=ice thickness + DO IK=1,NK + FREQ=SIG(IK)/TPI + ALPHA(IK) = 0.2*(FREQ**2.13)*HICE + END DO + WN_I= 0.5 * ALPHA + + CASE (8) + !CMB added option of cubic fit to Meylan, Horvat & Bitz in prep + ! ICECOEF1 is thickness + ! ICECOEF5 is floe size + ! TPI/SIG is period + x3=min(ICECOEF1,3.5) ! limit thickness to 3.5 m + x3=max(x3,0.1) ! limit thickness >0.1 m since I make fit below + x2=min(ICECOEF5*0.5,100.0) ! convert dia to radius, limit to 100m + x2=max(2.5,x2) + x2sqr=x2*x2 + x3sqr=x3*x3 + amhb = 2.12e-3 + bmhb = 4.59e-2 -! -! 1.c Fill diagional matrix -! - DO IKTH=1, NSPEC - D(IKTH) = D1D(MAPWN(IKTH)) - END DO -! -! END IF -! - S = D * A -! -! ... Test output of arrays -! -#ifdef W3_T0 DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO -#endif -! + x1=TPI/SIG(IK) ! period + x1sqr=x1*x1 + KARG1(ik)=-0.26982 + 1.5043*x3 - 0.70112*x3sqr + 0.011037*x2 + & + (-0.0073178)*x2*x3 + 0.00036604*x2*x3sqr + & + (-0.00045789)*x2sqr + 1.8034e-05*x2sqr*x3 + & + (-0.7246)*x1 + 0.12068*x1*x3 + & + (-0.0051311)*x1*x3sqr + 0.0059241*x1*x2 + & + 0.00010771*x1*x2*x3 - 1.0171e-05*x1*x2sqr + & + 0.0035412*x1sqr - 0.0031893*x1sqr*x3 + & + (-0.00010791)*x1sqr*x2 + & + 0.00031073*x1**3 + 1.5996e-06*x2**3 + 0.090994*x3**3 + KARG1(ik)=min(karg1(ik),0.0) + WN_I(ik) = 10.0**KARG1(ik) + perfour=x1sqr*x1sqr + if ((x1.gt.5.0) .and. (x1.lt.20.0)) then + WN_I(IK) = WN_I(IK) + amhb/x1sqr+bmhb/perfour + else if (x1.gt.20.0) then + WN_I(IK) = amhb/x1sqr+bmhb/perfour + endif + end do + CASE DEFAULT + WN_I = ICECOEF1 !Default to IC1: Uniform in k + + END SELECT + + ! + ! 1.b Calculate DID + ! + DO IK=1, NK + ! SBT1 has: D1D(IK) = FACTOR * MAX(0., (CG(IK)*WN(IK)/SIG(IK)-0.5) ) + ! recall that D=S/E=-2*Cg*k_i + D1D(IK) = -2. * CG(IK) * WN_I(IK) + + END DO + + ! + ! 1.c Fill diagional matrix + ! + DO IKTH=1, NSPEC + D(IKTH) = D1D(MAPWN(IKTH)) + END DO + ! + ! END IF + ! + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') #endif -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC4 : '/ & - ' ',A,' REQUIRED BUT NOT SELECTED'/) -! + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC4 : '/ & + ' ',A,' REQUIRED BUT NOT SELECTED'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SIC4 : DEPTH,ICECOEF1 : ',2E10.3) +9000 FORMAT (' TEST W3SIC4 : DEPTH,ICECOEF1 : ',2E10.3) #endif -!/ -!/ End of W3SIC4 --------------------------------------------------- / -!/ - END SUBROUTINE W3SIC4 -!/ -!/ End of module W3SIC4MD ------------------------------------------ / -!/ - END MODULE W3SIC4MD + !/ + !/ End of W3SIC4 --------------------------------------------------- / + !/ + END SUBROUTINE W3SIC4 + !/ + !/ End of module W3SIC4MD ------------------------------------------ / + !/ +END MODULE W3SIC4MD diff --git a/model/src/w3sic5md.F90 b/model/src/w3sic5md.F90 index bef13c519..2d7ad953f 100644 --- a/model/src/w3sic5md.F90 +++ b/model/src/w3sic5md.F90 @@ -1,2178 +1,2175 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SIC5MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | E. Rogers | -!/ | FORTRAN 90 | -!/ | Last update : 19-May-2021 | -!/ +-----------------------------------+ -!/ -!/ 15-Mar-2016 : Origination. ( version 5.10 ) -!/ ( Q. Liu ) -!/ 15-Mar-2016 : Started from w3sic1/2/3/4 module ( Q. Liu ) -!/ -!/ 24-Apr-2017 : Adding more filters ( Q. Liu ) -!/ -!/ 29-Apr-2017 : Introducing CMPLX_TANH2 ( Q. Liu ) -!/ -!/ 02-Jun-2017 : Update to version 5.16 ( Q. Liu ) -!/ -!/ 17-Jun-2017 : Remove some unnecessary lines ( Q. Liu ) -!/ (cg_ice, detla function, complx_tanh etc.) -!/ -!/ 20-Aug-2018 : Ready to be merged to master (v6.06)( Q. Liu) -!/ -!/ 19-May-2021 : Incl. the RP and M2 model ( Q. Liu) -!/ -!/ 1. Purpose : -! Calculate ice source term S_{ice} according to different ice -! models: -! * 'FS': the viscoelastic, extended Fox and Squire sea ice model -! (Mosig et al. 2015) -! * 'RP': the viscoelastic, Robinson and Palmer model (Mosig et al. -! 2015) -! * 'M2': the order 3 power law model proposed by Meylan et al. -! (2018) -! -! Reference: -! Mosig, J.E.M., F. Montiel, and V. A. Squire (2015): -! Comparison of viscoelastic-type models for ocean wave attenuation -! in ice-covered seas, J. Geophys. Res. Oceans, 120, 6072–6090, -! doi:10.1002/2015JC010881. -! -! Meylan, M.H., L. Bennetts, J. Mosig, W. Rogers, M. Doble, and -! M. Peter (2018): Dispersion relations, power laws, and energy loss -! for waves in the marginal ice zone. J. Geophys. Res. Oceans, 123, -! 3322–3335, https://doi.org/10.1002/2018JC013776. -! -! Liu, Q., W. E. Rogers, A. Babanin, J. Li, and C. Guan (2020): -! Spectral Modeling of Ice-Induced Wave Decay. J. Phys. Oceanogr., -! 50 (6), 1583–1604. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! KSP Int. Private the kind parameter for single precision -! real variables -! KDP Int. Private Same as KSP but for double precision -! KSPC Int. Private the kind parameter for single precision -! complex variables -! KDPC Int. Private Same as KSPC but for double precision -! ERRTOL Real Private A real parameter used for "==" test -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SIC5 Subr. Public Ice source term -! W3IC5WNCG Subr. Public Wavenumber and group velocity of ice- -! coupled waves -! FSDISP Subr. Public Solving the ice-coupled wave dispersion -! BALANCING_MATRIX -! Subr. Private Balancing the matrix before we try to -! find its eigenvalues -! EIG_HQR Subr. Private QR algorithm for real Hessenberg matrix -! (eigenvalues-finding algorithm) -! POLYROOTS Subr. Private Finding roots of a general polynomial -! NR_CORR Func. Private Get the Newton-Raphson correction term -! for iteration -! NR_ROOT Func. Private Newton-Raphson algorithm for solving -! the ice-coupled wave dispersion -! CMPLX_SINH, CMPLX_COSH, CMPLX_TANH2 -! Func. Private sinh, cosh, tanh for complex inputs -! INIT_RANDOM_SEED -! Subr. Private Initialize the random seed based on -! the system's time -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! See subroutine documentation -! -! 5. Remarks : -! -! 6. Switches : -! See subroutine documentation -! -! 7. Source code: -!/ -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ - PUBLIC :: W3SIC5, W3IC5WNCG, FSDISP - PRIVATE :: BALANCING_MATRIX, EIG_HQR, POLYROOTS - PRIVATE :: NR_CORR, NR_ROOT - PRIVATE :: CMPLX_SINH, CMPLX_COSH, CMPLX_TANH2 - PRIVATE :: INIT_RANDOM_SEED -!/ - PRIVATE :: KSP, KDP, KSPC, KDPC, ERRTOL -!/ ------------------------------------------------------------------- / -!/ Parameter list -! Kind for single- and double-precision real type - INTEGER, PARAMETER :: KSP = KIND(1.0) - INTEGER, PARAMETER :: KDP = KIND(1.0D0) -! -! Kind for single- and double-precision complex type - INTEGER, PARAMETER :: KSPC = KIND((1.0, 1.0)) - INTEGER, PARAMETER :: KDPC = KIND((1.0D0, 1.0D0)) - REAL, PARAMETER :: ERRTOL = 1.E-12 -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3SIC5 (A, DEPTH, CG, WN, IX, IY, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | E. Rogers | -!/ | FORTRAN 90 | -!/ | Last update : 19-May-2021 | -!/ +-----------------------------------+ -!/ -!/ 23-Mar-2016 : Origination ( version 5.10 ) -!/ ( Q. Liu) -!/ 23-Mar-2016 : Started from w3sic1/2/3/4 subr. ( Q. Liu) -!/ 05-Apr-2016 : Options for Cg_{ice} or Cg ( Q. Liu) -!/ 25-Apr-2017 : Add more filters ( Q. Liu) -!/ 20-Aug-2018 : Ready to be merged to master (v6.06)( Q. Liu) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -!/ 1. Purpose : -! Calculate ice source term S_{ice} according to 3 different sea ice -! models (Mosig et al. 2015, Meylan et al. 2018, Liu et al. 2020) -! -! 2. Method : -! Regarding i/o (general to all Sice modules): S_{ice} source term -! is calculated using up to 5 parameters read from input files. -! These parameters are allowed to vary in space and time. -! The parameters control the exponential decay rate k_i. -! Since there are 5 parameters, this permits description of -! dependence of k_i on frequency or wavenumber. -! -! Sea ice affects the wavenumber k of wind-generated ocean waves. -! The ice-modified wavenumber can be expressed as a complex number -! k = k_r + i * k_i, with the real part k_r representing impact of -! the sea ice on the physical wavelength and propagation speeds, -! producing something analogous to shoaling and refraction by -! bathymetry, whereas the imaginary part of the complex -! wavenumber, k_i, is an exponential decay coefficient -! k_i(x,y,t,sigma) (depending on location, time and frequency, -! respectively), representing wave attenuation, and can be -! introduced in a wave model such as WW3 as S_ice/E=-2*Cg*k_i, -! where S_ice is one of several dissipation mechanisms, along -! with whitecapping, for example, S_ds=S_wc+S_ice+⋯. The k_r - -! modified by ice would enter the model via the C calculations -! on the left-hand side of the governing equation.The fundamentals -! are straightforward, e.g. Rogers and Holland (2009 and -! subsequent unpublished work) modified a similar model, SWAN -! (Booij et al. 1999) to include the effects of a viscous mud -! layer using the same approach (k = k_r + i*k_i) previously. -! -! General approach is analogous to Rogers and Holland (2009) -! approach for mud. -! See text near their eq. 1 : -! k = k_r + i * k_i -! eta(x,t) = Real( a * exp( i * ( k * x - sigma * t ) ) ) -! a = a0 * exp( -k_i * x ) -! S / E = -2 * Cg * k_i (see also Komen et al. (1994, pg. 170) -! -! Following W3SBT1 as a guide, equation 1 of W3SBT1 says: -! S = D * E -! However, the code of W3SBT1 has -! S = D * A -! This leads me to believe that the calling routine is -! expecting "S/sigma" not "S" -! Thus we will use D = S/E = -2 * Cg * k_i -! (see also documentation of W3SIC1) -! -! Notes regarding numerics: -! ------------------------- -! Experiments with constant k_i values suggest that results may be -! dependent on resolution if insufficient resolution is used. -! For detailed information, see documentation of W3SIC1. -! -! Note regarding applicability/validity: -! -------------------------------------- -! Similar to the Wang and Shen model used in w3sic3md, the 3 models -! used here are empirical medium models as well which treat the sea -! ice cover as a continuum and use 1/2 empirical rheological para- -! meters, i.e., the effective shear modulus of ice G and the effec- -! tive viscosity η to characterize sea ices of various type. Please -! see the documentation of w3sic3md for a detailed discussion of -! this kind of model. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D). -! DEPTH Real I Local water depth. -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers -! IX,IY I.S. I Grid indices. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). -! PRT2DS Subr. W3ARRYMD Print plot output (!/T0 switch). -! OUTMAT Subr. W3ARRYMD Matrix output (!/T1 switch). -! W3IC5WNCG Subr. / Wavenumber and group velocity of ice- -! coupled waves -! ---------------------------------------------------------------- -! * / means this module -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A ASCII Point output post-processor. -! W3EXNC Subr. N/A NetCDF Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! If ice parameter 1 is zero, no calculations are made. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -!/ ------------------------------------------------------------------- / -!/ +MODULE W3SIC5MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | E. Rogers | + !/ | FORTRAN 90 | + !/ | Last update : 19-May-2021 | + !/ +-----------------------------------+ + !/ + !/ 15-Mar-2016 : Origination. ( version 5.10 ) + !/ ( Q. Liu ) + !/ 15-Mar-2016 : Started from w3sic1/2/3/4 module ( Q. Liu ) + !/ + !/ 24-Apr-2017 : Adding more filters ( Q. Liu ) + !/ + !/ 29-Apr-2017 : Introducing CMPLX_TANH2 ( Q. Liu ) + !/ + !/ 02-Jun-2017 : Update to version 5.16 ( Q. Liu ) + !/ + !/ 17-Jun-2017 : Remove some unnecessary lines ( Q. Liu ) + !/ (cg_ice, detla function, complx_tanh etc.) + !/ + !/ 20-Aug-2018 : Ready to be merged to master (v6.06)( Q. Liu) + !/ + !/ 19-May-2021 : Incl. the RP and M2 model ( Q. Liu) + !/ + !/ 1. Purpose : + ! Calculate ice source term S_{ice} according to different ice + ! models: + ! * 'FS': the viscoelastic, extended Fox and Squire sea ice model + ! (Mosig et al. 2015) + ! * 'RP': the viscoelastic, Robinson and Palmer model (Mosig et al. + ! 2015) + ! * 'M2': the order 3 power law model proposed by Meylan et al. + ! (2018) + ! + ! Reference: + ! Mosig, J.E.M., F. Montiel, and V. A. Squire (2015): + ! Comparison of viscoelastic-type models for ocean wave attenuation + ! in ice-covered seas, J. Geophys. Res. Oceans, 120, 6072–6090, + ! doi:10.1002/2015JC010881. + ! + ! Meylan, M.H., L. Bennetts, J. Mosig, W. Rogers, M. Doble, and + ! M. Peter (2018): Dispersion relations, power laws, and energy loss + ! for waves in the marginal ice zone. J. Geophys. Res. Oceans, 123, + ! 3322–3335, https://doi.org/10.1002/2018JC013776. + ! + ! Liu, Q., W. E. Rogers, A. Babanin, J. Li, and C. Guan (2020): + ! Spectral Modeling of Ice-Induced Wave Decay. J. Phys. Oceanogr., + ! 50 (6), 1583–1604. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! KSP Int. Private the kind parameter for single precision + ! real variables + ! KDP Int. Private Same as KSP but for double precision + ! KSPC Int. Private the kind parameter for single precision + ! complex variables + ! KDPC Int. Private Same as KSPC but for double precision + ! ERRTOL Real Private A real parameter used for "==" test + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SIC5 Subr. Public Ice source term + ! W3IC5WNCG Subr. Public Wavenumber and group velocity of ice- + ! coupled waves + ! FSDISP Subr. Public Solving the ice-coupled wave dispersion + ! BALANCING_MATRIX + ! Subr. Private Balancing the matrix before we try to + ! find its eigenvalues + ! EIG_HQR Subr. Private QR algorithm for real Hessenberg matrix + ! (eigenvalues-finding algorithm) + ! POLYROOTS Subr. Private Finding roots of a general polynomial + ! NR_CORR Func. Private Get the Newton-Raphson correction term + ! for iteration + ! NR_ROOT Func. Private Newton-Raphson algorithm for solving + ! the ice-coupled wave dispersion + ! CMPLX_SINH, CMPLX_COSH, CMPLX_TANH2 + ! Func. Private sinh, cosh, tanh for complex inputs + ! INIT_RANDOM_SEED + ! Subr. Private Initialize the random seed based on + ! the system's time + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! See subroutine documentation + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! See subroutine documentation + ! + ! 7. Source code: + !/ + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + PUBLIC :: W3SIC5, W3IC5WNCG, FSDISP + PRIVATE :: BALANCING_MATRIX, EIG_HQR, POLYROOTS + PRIVATE :: NR_CORR, NR_ROOT + PRIVATE :: CMPLX_SINH, CMPLX_COSH, CMPLX_TANH2 + PRIVATE :: INIT_RANDOM_SEED + !/ + PRIVATE :: KSP, KDP, KSPC, KDPC, ERRTOL + !/ ------------------------------------------------------------------- / + !/ Parameter list + ! Kind for single- and double-precision real type + INTEGER, PARAMETER :: KSP = KIND(1.0) + INTEGER, PARAMETER :: KDP = KIND(1.0D0) + ! + ! Kind for single- and double-precision complex type + INTEGER, PARAMETER :: KSPC = KIND((1.0, 1.0)) + INTEGER, PARAMETER :: KDPC = KIND((1.0D0, 1.0D0)) + REAL, PARAMETER :: ERRTOL = 1.E-12 + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3SIC5 (A, DEPTH, CG, WN, IX, IY, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | E. Rogers | + !/ | FORTRAN 90 | + !/ | Last update : 19-May-2021 | + !/ +-----------------------------------+ + !/ + !/ 23-Mar-2016 : Origination ( version 5.10 ) + !/ ( Q. Liu) + !/ 23-Mar-2016 : Started from w3sic1/2/3/4 subr. ( Q. Liu) + !/ 05-Apr-2016 : Options for Cg_{ice} or Cg ( Q. Liu) + !/ 25-Apr-2017 : Add more filters ( Q. Liu) + !/ 20-Aug-2018 : Ready to be merged to master (v6.06)( Q. Liu) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + !/ 1. Purpose : + ! Calculate ice source term S_{ice} according to 3 different sea ice + ! models (Mosig et al. 2015, Meylan et al. 2018, Liu et al. 2020) + ! + ! 2. Method : + ! Regarding i/o (general to all Sice modules): S_{ice} source term + ! is calculated using up to 5 parameters read from input files. + ! These parameters are allowed to vary in space and time. + ! The parameters control the exponential decay rate k_i. + ! Since there are 5 parameters, this permits description of + ! dependence of k_i on frequency or wavenumber. + ! + ! Sea ice affects the wavenumber k of wind-generated ocean waves. + ! The ice-modified wavenumber can be expressed as a complex number + ! k = k_r + i * k_i, with the real part k_r representing impact of + ! the sea ice on the physical wavelength and propagation speeds, + ! producing something analogous to shoaling and refraction by + ! bathymetry, whereas the imaginary part of the complex + ! wavenumber, k_i, is an exponential decay coefficient + ! k_i(x,y,t,sigma) (depending on location, time and frequency, + ! respectively), representing wave attenuation, and can be + ! introduced in a wave model such as WW3 as S_ice/E=-2*Cg*k_i, + ! where S_ice is one of several dissipation mechanisms, along + ! with whitecapping, for example, S_ds=S_wc+S_ice+⋯. The k_r - + ! modified by ice would enter the model via the C calculations + ! on the left-hand side of the governing equation.The fundamentals + ! are straightforward, e.g. Rogers and Holland (2009 and + ! subsequent unpublished work) modified a similar model, SWAN + ! (Booij et al. 1999) to include the effects of a viscous mud + ! layer using the same approach (k = k_r + i*k_i) previously. + ! + ! General approach is analogous to Rogers and Holland (2009) + ! approach for mud. + ! See text near their eq. 1 : + ! k = k_r + i * k_i + ! eta(x,t) = Real( a * exp( i * ( k * x - sigma * t ) ) ) + ! a = a0 * exp( -k_i * x ) + ! S / E = -2 * Cg * k_i (see also Komen et al. (1994, pg. 170) + ! + ! Following W3SBT1 as a guide, equation 1 of W3SBT1 says: + ! S = D * E + ! However, the code of W3SBT1 has + ! S = D * A + ! This leads me to believe that the calling routine is + ! expecting "S/sigma" not "S" + ! Thus we will use D = S/E = -2 * Cg * k_i + ! (see also documentation of W3SIC1) + ! + ! Notes regarding numerics: + ! ------------------------- + ! Experiments with constant k_i values suggest that results may be + ! dependent on resolution if insufficient resolution is used. + ! For detailed information, see documentation of W3SIC1. + ! + ! Note regarding applicability/validity: + ! -------------------------------------- + ! Similar to the Wang and Shen model used in w3sic3md, the 3 models + ! used here are empirical medium models as well which treat the sea + ! ice cover as a continuum and use 1/2 empirical rheological para- + ! meters, i.e., the effective shear modulus of ice G and the effec- + ! tive viscosity η to characterize sea ices of various type. Please + ! see the documentation of w3sic3md for a detailed discussion of + ! this kind of model. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D). + ! DEPTH Real I Local water depth. + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers + ! IX,IY I.S. I Grid indices. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). + ! PRT2DS Subr. W3ARRYMD Print plot output (!/T0 switch). + ! OUTMAT Subr. W3ARRYMD Matrix output (!/T1 switch). + ! W3IC5WNCG Subr. / Wavenumber and group velocity of ice- + ! coupled waves + ! ---------------------------------------------------------------- + ! * / means this module + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A ASCII Point output post-processor. + ! W3EXNC Subr. N/A NetCDF Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! If ice parameter 1 is zero, no calculations are made. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -!/ - USE CONSTANTS, ONLY: TPI - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, IC5PARS - USE W3IDATMD, ONLY: INFLAGS2, ICEP1, ICEP2, ICEP3, ICEP4, ICEI -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: CG(NK), WN(NK), A(NSPEC), DEPTH - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) - INTEGER, INTENT(IN) :: IX, IY -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + USE CONSTANTS, ONLY: TPI + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, IC5PARS + USE W3IDATMD, ONLY: INFLAGS2, ICEP1, ICEP2, ICEP3, ICEP4, ICEI + ! + IMPLICIT NONE + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: CG(NK), WN(NK), A(NSPEC), DEPTH + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + INTEGER, INTENT(IN) :: IX, IY + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T0 - INTEGER :: ITH - REAL :: DOUT(NK,NTH) + INTEGER :: ITH + REAL :: DOUT(NK,NTH) #endif -!/ - REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & - ICECOEF4, ICECONC - REAL, DIMENSION(NK) :: D1D, WN_R, WN_I -! REAL :: TWN_R, TWN_I - INTEGER :: IK, IKTH - LOGICAL :: NOICE -!/ ------------------------------------------------------------------- / -!/ + !/ + REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & + ICECOEF4, ICECONC + REAL, DIMENSION(NK) :: D1D, WN_R, WN_I + ! REAL :: TWN_R, TWN_I + INTEGER :: IK, IKTH + LOGICAL :: NOICE + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIC5') + CALL STRACE (IENT, 'W3SIC5') #endif -! -! 0. Initializations ------------------------------------------------ / - D = 0. - D1D = 0. - WN_R = 0. - WN_I = 0. -! - ICECOEF1 = 0. - ICECOEF2 = 0. - ICECOEF3 = 0. - ICECOEF4 = 0. - ICECONC = 0. -! -! Set the ice parameters from input - IF (INFLAGS2(-7)) THEN - ICECOEF1 = ICEP1(IX, IY) ! ice thickness h_i - ELSE - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,1001) 'ICE PARAMETER 1 (HICE)' - CALL EXTCDE(2) - ENDIF -! - IF (INFLAGS2(-6)) THEN - ICECOEF2 = ICEP2(IX, IY) ! effective viscosity of ice η - ELSE - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,1001) 'ICE PARAMETER 2 (VISC)' - CALL EXTCDE(2) - ENDIF -! - IF (INFLAGS2(-5)) THEN - ICECOEF3 = ICEP3(IX, IY) ! density of ice ρ_i - ELSE - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,1001) 'ICE PARAMETER 3 (DENS)' - CALL EXTCDE(2) - ENDIF -! - IF (INFLAGS2(-4)) THEN - ICECOEF4 = ICEP4(IX, IY) ! effective shear modulus of ice G - ELSE - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,1001) 'ICE PARAMETER 4 (ELAS)' - CALL EXTCDE(2) - ENDIF -! - IF (INFLAGS2(4)) ICECONC = ICEI(IX, IY) ! ice concentration -! -! 1. No ice --------------------------------------------------------- / - NOICE = .FALSE. -! Zero ice thickness -! Very small ice thickness may cause problems in POLYROOTS because -! the first coefficient C1 may be very close to zero. So we regard -! cases where hice is less than 0.0001 as no ice. -! IF (ICECOEF1 < ERRTOL) NOICE = .TRUE. - IF (ICECOEF1 < 0.0001) NOICE = .TRUE. -! zero ice concentration - IF (INFLAGS2(4) .AND. ICECONC < ERRTOL) NOICE = .TRUE. -! -! Calculate the decay rate k_i - IF ( NOICE ) THEN - D1D = 0. -! -! 2. Ice ------------------------------------------------------------- / - ELSE -! W3IC5WNCG(WN_R, WN_I, CG, HICE, IVISC, RHOI, ISMODG, HWAT) - CALL W3IC5WNCG(WN_R, WN_I, CG, ICECOEF1, ICECOEF2, & - ICECOEF3, ICECOEF4, DEPTH) -! recall that D=S/E=-2*Cg_{ice}*k_i -! In some cases, the FS model yields very large Cg_{ice}, which -! subquently may result in numerical failure due to the violation of CFL -! conditions, therefore we still use ice-free group velocity to advect -! wave packets. -! - DO IK = 1, NK - D1D(IK) = -2.0 * CG(IK) * WN_I(IK) - END DO - END IF -! -! 2.1 Fill diagonal matrix - DO IKTH = 1, NSPEC - D(IKTH) = D1D(MAPWN(IKTH)) + ! + ! 0. Initializations ------------------------------------------------ / + D = 0. + D1D = 0. + WN_R = 0. + WN_I = 0. + ! + ICECOEF1 = 0. + ICECOEF2 = 0. + ICECOEF3 = 0. + ICECOEF4 = 0. + ICECONC = 0. + ! + ! Set the ice parameters from input + IF (INFLAGS2(-7)) THEN + ICECOEF1 = ICEP1(IX, IY) ! ice thickness h_i + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,1001) 'ICE PARAMETER 1 (HICE)' + CALL EXTCDE(2) + ENDIF + ! + IF (INFLAGS2(-6)) THEN + ICECOEF2 = ICEP2(IX, IY) ! effective viscosity of ice η + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,1001) 'ICE PARAMETER 2 (VISC)' + CALL EXTCDE(2) + ENDIF + ! + IF (INFLAGS2(-5)) THEN + ICECOEF3 = ICEP3(IX, IY) ! density of ice ρ_i + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,1001) 'ICE PARAMETER 3 (DENS)' + CALL EXTCDE(2) + ENDIF + ! + IF (INFLAGS2(-4)) THEN + ICECOEF4 = ICEP4(IX, IY) ! effective shear modulus of ice G + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,1001) 'ICE PARAMETER 4 (ELAS)' + CALL EXTCDE(2) + ENDIF + ! + IF (INFLAGS2(4)) ICECONC = ICEI(IX, IY) ! ice concentration + ! + ! 1. No ice --------------------------------------------------------- / + NOICE = .FALSE. + ! Zero ice thickness + ! Very small ice thickness may cause problems in POLYROOTS because + ! the first coefficient C1 may be very close to zero. So we regard + ! cases where hice is less than 0.0001 as no ice. + ! IF (ICECOEF1 < ERRTOL) NOICE = .TRUE. + IF (ICECOEF1 < 0.0001) NOICE = .TRUE. + ! zero ice concentration + IF (INFLAGS2(4) .AND. ICECONC < ERRTOL) NOICE = .TRUE. + ! + ! Calculate the decay rate k_i + IF ( NOICE ) THEN + D1D = 0. + ! + ! 2. Ice ------------------------------------------------------------- / + ELSE + ! W3IC5WNCG(WN_R, WN_I, CG, HICE, IVISC, RHOI, ISMODG, HWAT) + CALL W3IC5WNCG(WN_R, WN_I, CG, ICECOEF1, ICECOEF2, & + ICECOEF3, ICECOEF4, DEPTH) + ! recall that D=S/E=-2*Cg_{ice}*k_i + ! In some cases, the FS model yields very large Cg_{ice}, which + ! subquently may result in numerical failure due to the violation of CFL + ! conditions, therefore we still use ice-free group velocity to advect + ! wave packets. + ! + DO IK = 1, NK + D1D(IK) = -2.0 * CG(IK) * WN_I(IK) END DO + END IF + ! + ! 2.1 Fill diagonal matrix + DO IKTH = 1, NSPEC + D(IKTH) = D1D(MAPWN(IKTH)) + END DO - S = D * A -! -! ... Test output of arrays -! + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO -#endif -! -#ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') #endif -! -! Formats -! - 1001 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & - ' ',A,' IS NOT DEFINED IN ww3_shel.inp.') + ! + ! Formats + ! +1001 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & + ' ',A,' IS NOT DEFINED IN ww3_shel.inp.') -!/ -!/ End of W3SIC5------------------------------------------------------ / -!/ - END SUBROUTINE W3SIC5 -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE W3IC5WNCG(WN_R, WN_I, CG, HICE, IVISC, RHOI, ISMODG, & - HWAT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | E. Rogers | -!/ | FORTRAN 90 | -!/ | Last update : 25-Apr-2017 | -!/ +-----------------------------------+ -!/ -!/ 17-Apr-2016 : Origination ( version 5.10) -!/ ( Q. Liu ) -!/ 17-Apr-2016 : Start from W3IC3WNCG_CHENG ( Q. Liu ) -!/ -!/ 1. Purpose: -! Calculation of complex wavenumber arrays for ice-coupled waves. -! -! This also allows us to use Cg_ice in the advection part of the -! radiative transfer energy equation (RTE). --- abandoned in the end -! -! 2. Method: -! Using the Fox-Squire dispersion relations to get (kr, ki) and -! then get cg by cg = dσ / dk (here dk uses kr) -! -! 3. Parameters: -! -! Parameter list: -! ---------------------------------------------------------------- -! Name Type Intent Description -! ---------------------------------------------------------------- -! WN_R R.A. I/O the real. part of the wave number -! WN_I R.A. I/O the imag. part of the wave number -! CG R.A. I group velocity (m s^{-1}) -! HICE Real. I thickness of ice (m) -! IVISC Real. I viscosity parameter of ice (m^2 s^{-1}) -! RHOI Real. I the density of ice (kg m^{-3}) -! ISMODG Real. I effecitive shear modulus G of ice (Pa) -! HWAT Real. I water depth -! ---------------------------------------------------------------- -! * the intent of WN_R/I must be inout -! * CG is unchanged but still kept here because some legacy reasons. -! -! 4. Subroutines used: -! -! Name Type Module Description -! ---------------------------------------------------------------- -! FSDISP Subr. / dispersion relations for ice-coupled waves -! CGINICE5 Subr. / group velocity for given (σ, kr) array -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SIC5 Subr. Public Ice source term -! W3WAVE Subr. W3WAVEMD WW3 integration -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ End of W3SIC5------------------------------------------------------ / + !/ + END SUBROUTINE W3SIC5 + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE W3IC5WNCG(WN_R, WN_I, CG, HICE, IVISC, RHOI, ISMODG, & + HWAT) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | E. Rogers | + !/ | FORTRAN 90 | + !/ | Last update : 25-Apr-2017 | + !/ +-----------------------------------+ + !/ + !/ 17-Apr-2016 : Origination ( version 5.10) + !/ ( Q. Liu ) + !/ 17-Apr-2016 : Start from W3IC3WNCG_CHENG ( Q. Liu ) + !/ + !/ 1. Purpose: + ! Calculation of complex wavenumber arrays for ice-coupled waves. + ! + ! This also allows us to use Cg_ice in the advection part of the + ! radiative transfer energy equation (RTE). --- abandoned in the end + ! + ! 2. Method: + ! Using the Fox-Squire dispersion relations to get (kr, ki) and + ! then get cg by cg = dσ / dk (here dk uses kr) + ! + ! 3. Parameters: + ! + ! Parameter list: + ! ---------------------------------------------------------------- + ! Name Type Intent Description + ! ---------------------------------------------------------------- + ! WN_R R.A. I/O the real. part of the wave number + ! WN_I R.A. I/O the imag. part of the wave number + ! CG R.A. I group velocity (m s^{-1}) + ! HICE Real. I thickness of ice (m) + ! IVISC Real. I viscosity parameter of ice (m^2 s^{-1}) + ! RHOI Real. I the density of ice (kg m^{-3}) + ! ISMODG Real. I effecitive shear modulus G of ice (Pa) + ! HWAT Real. I water depth + ! ---------------------------------------------------------------- + ! * the intent of WN_R/I must be inout + ! * CG is unchanged but still kept here because some legacy reasons. + ! + ! 4. Subroutines used: + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! FSDISP Subr. / dispersion relations for ice-coupled waves + ! CGINICE5 Subr. / group velocity for given (σ, kr) array + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SIC5 Subr. Public Ice source term + ! W3WAVE Subr. W3WAVEMD WW3 integration + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE CONSTANTS, ONLY: TPI - USE W3GDATMD, ONLY: NK, SIG - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(INOUT) :: WN_R(:), WN_I(:) - REAL, INTENT(IN) :: CG(:) - REAL, INTENT(IN) :: HICE, IVISC, RHOI, ISMODG, HWAT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters - REAL, ALLOCATABLE :: SIGMA(:) - INTEGER :: KL, KU, IK - REAL :: TWN_R, TWN_I -!/ + USE CONSTANTS, ONLY: TPI + USE W3GDATMD, ONLY: NK, SIG + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(INOUT) :: WN_R(:), WN_I(:) + REAL, INTENT(IN) :: CG(:) + REAL, INTENT(IN) :: HICE, IVISC, RHOI, ISMODG, HWAT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + REAL, ALLOCATABLE :: SIGMA(:) + INTEGER :: KL, KU, IK + REAL :: TWN_R, TWN_I + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3IC5WNCG') + CALL STRACE (IENT, 'W3IC5WNCG') #endif -!/ -! Initialize SIGMA {in w3gdatmd: SIG (0: NK+1)} - IF (ALLOCATED(SIGMA)) DEALLOCATE(SIGMA); ALLOCATE(SIGMA(SIZE(CG))) - SIGMA = 0. + !/ + ! Initialize SIGMA {in w3gdatmd: SIG (0: NK+1)} + IF (ALLOCATED(SIGMA)) DEALLOCATE(SIGMA); ALLOCATE(SIGMA(SIZE(CG))) + SIGMA = 0. - IF (SIZE(WN_R, 1) .EQ. NK) THEN - KL = 1 - KU = NK - SIGMA = SIG(1:NK) - ELSE IF (SIZE(WN_R,1) .EQ. NK+2) THEN - KL = 1 - KU = NK+2 - SIGMA = SIG(0:NK+1) - ELSE - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,900) 'W3IC5WNCG' - CALL EXTCDE(3) - END IF -! -! Fox-Squire dispersion - DO IK = KL, KU -! FSDISP(HICE, IVISC, RHOI, ISMODG, HWAT, WT, WNR, WNI) - CALL FSDISP(HICE, IVISC, RHOI, ISMODG, HWAT, TPI/SIGMA(IK), & - TWN_R, TWN_I) - WN_R(IK) = TWN_R - WN_I(IK) = TWN_I - END DO -! - DEALLOCATE(SIGMA) -! - 900 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & - ' Subr. ', A, ': Cannot determine bounds of& - & wavenumber array.'/) -!/ -!/ End of W3IC5WNCG -------------------------------------------------- / -!/ - END SUBROUTINE W3IC5WNCG -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE FSDISP(HICE, IVISC, RHOI, ISMODG, HWAT, WT, WNR, WNI) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 19-May-2021 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-2016 : Origination ( version 5.10) -!/ ( Q. Liu) -!/ 17-Mar-2016 : Start from the Matlab code `FoxSquire.m` (provided -!/ by Prof. Vernon Squire from University of Otago) -!/ ( Q. Liu) -!/ 25-Apr-2017 : Add more filters ( Q. Liu) -!/ -!/ 19-May-2021 : Incl. RP and M2 ice models ( Q. Liu) -!/ -! 1. Purpose : -! -! Calculate the complex wavenumber for waves in ice according to -! three different sea ice models, i.e., FS, RP and M2 (see Liu et -! al. 2020) -! -! 2. Method : -! Mainly solving the dispersion relations of FS and RP models ( -! Eqs. (20, 24, 25)) in Mosig et al. (2015)) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Name Type Intent Description -! ---------------------------------------------------------------- -! HICE Real. IN thickness of ice (m) -! IVISC Real. IN viscosity parameter of ice (m^2 s^{-1}) -! RHOI Real. IN the density of ice (kg m^{-3}) -! ISMODG Real. IN effecitive shear modulus G of ice (Pa) -! HWAT Real. IN water depth -! WT Real. IN wave period (s; 1/freq) -! WNR Real. Out the real. part of the wave number -! WNI Real. Out the imag. part of the wave number -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! POLYROOTS Subr. / Find the roots of a general polynomial -! NR_ROOT Func. / Newton-Raphson root finding -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IC5WNCG Subr. / Wavenumber and group velocity of ice- -! coupled waves -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See Format 1000, 1001, 1002 -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + IF (SIZE(WN_R, 1) .EQ. NK) THEN + KL = 1 + KU = NK + SIGMA = SIG(1:NK) + ELSE IF (SIZE(WN_R,1) .EQ. NK+2) THEN + KL = 1 + KU = NK+2 + SIGMA = SIG(0:NK+1) + ELSE + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,900) 'W3IC5WNCG' + CALL EXTCDE(3) + END IF + ! + ! Fox-Squire dispersion + DO IK = KL, KU + ! FSDISP(HICE, IVISC, RHOI, ISMODG, HWAT, WT, WNR, WNI) + CALL FSDISP(HICE, IVISC, RHOI, ISMODG, HWAT, TPI/SIGMA(IK), & + TWN_R, TWN_I) + WN_R(IK) = TWN_R + WN_I(IK) = TWN_I + END DO + ! + DEALLOCATE(SIGMA) + ! +900 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & + ' Subr. ', A, ': Cannot determine bounds of& + & wavenumber array.'/) + !/ + !/ End of W3IC5WNCG -------------------------------------------------- / + !/ + END SUBROUTINE W3IC5WNCG + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE FSDISP(HICE, IVISC, RHOI, ISMODG, HWAT, WT, WNR, WNI) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 19-May-2021 | + !/ +-----------------------------------+ + !/ + !/ 17-Mar-2016 : Origination ( version 5.10) + !/ ( Q. Liu) + !/ 17-Mar-2016 : Start from the Matlab code `FoxSquire.m` (provided + !/ by Prof. Vernon Squire from University of Otago) + !/ ( Q. Liu) + !/ 25-Apr-2017 : Add more filters ( Q. Liu) + !/ + !/ 19-May-2021 : Incl. RP and M2 ice models ( Q. Liu) + !/ + ! 1. Purpose : + ! + ! Calculate the complex wavenumber for waves in ice according to + ! three different sea ice models, i.e., FS, RP and M2 (see Liu et + ! al. 2020) + ! + ! 2. Method : + ! Mainly solving the dispersion relations of FS and RP models ( + ! Eqs. (20, 24, 25)) in Mosig et al. (2015)) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Name Type Intent Description + ! ---------------------------------------------------------------- + ! HICE Real. IN thickness of ice (m) + ! IVISC Real. IN viscosity parameter of ice (m^2 s^{-1}) + ! RHOI Real. IN the density of ice (kg m^{-3}) + ! ISMODG Real. IN effecitive shear modulus G of ice (Pa) + ! HWAT Real. IN water depth + ! WT Real. IN wave period (s; 1/freq) + ! WNR Real. Out the real. part of the wave number + ! WNI Real. Out the imag. part of the wave number + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! POLYROOTS Subr. / Find the roots of a general polynomial + ! NR_ROOT Func. / Newton-Raphson root finding + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IC5WNCG Subr. / Wavenumber and group velocity of ice- + ! coupled waves + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See Format 1000, 1001, 1002 + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE CONSTANTS, ONLY: GRAV, TPI - USE W3DISPMD, ONLY: WAVNU1 - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR - USE W3GDATMD, ONLY: IC5PARS - USE W3GSRUMD, ONLY: W3INAN -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: HICE, IVISC, RHOI, ISMODG, HWAT, WT - REAL, INTENT(OUT) :: WNR, WNI -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -! - REAL :: IC5MINIG, IC5MINWT, IC5MAXKRATIO, & - IC5MAXKI, IC5MINHW, IC5VEMOD - REAL :: TISMODG, TWT, TRATIO, THW - REAL, PARAMETER :: NU = 0.3, RHOW = 1025. -! COMPLEX :: GV, C1 -! REAL :: SIGMA, C2, WNO, CGO, THKH, & - COMPLEX :: GV, C1, C2 - REAL :: SIGMA, WNO, CGO, THKH, & - RTRL(5), RTIM(5), RTANG(5) - INTEGER :: IREAL -! COMPLEX(KDPC) :: GUESS, CROOT, C1D -! REAL(KDP) :: C2D, HWATD - COMPLEX(KDPC) :: GUESS, CROOT, C1D, C2D - REAL(KDP) :: HWATD -!/ + !/ + USE CONSTANTS, ONLY: GRAV, TPI + USE W3DISPMD, ONLY: WAVNU1 + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR + USE W3GDATMD, ONLY: IC5PARS + USE W3GSRUMD, ONLY: W3INAN + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: HICE, IVISC, RHOI, ISMODG, HWAT, WT + REAL, INTENT(OUT) :: WNR, WNI + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + ! + REAL :: IC5MINIG, IC5MINWT, IC5MAXKRATIO, & + IC5MAXKI, IC5MINHW, IC5VEMOD + REAL :: TISMODG, TWT, TRATIO, THW + REAL, PARAMETER :: NU = 0.3, RHOW = 1025. + ! COMPLEX :: GV, C1 + ! REAL :: SIGMA, C2, WNO, CGO, THKH, & + COMPLEX :: GV, C1, C2 + REAL :: SIGMA, WNO, CGO, THKH, & + RTRL(5), RTIM(5), RTANG(5) + INTEGER :: IREAL + ! COMPLEX(KDPC) :: GUESS, CROOT, C1D + ! REAL(KDP) :: C2D, HWATD + COMPLEX(KDPC) :: GUESS, CROOT, C1D, C2D + REAL(KDP) :: HWATD + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'FSDISP') + CALL STRACE (IENT, 'FSDISP') #endif -! Note, same as W3IC3WNCG_xx in w3sic3md : -! HICE → ICE1 -! IVISC → ICE2 -! RHOI → ICE3 -! ISMODG → ICE4 -! 0. Initializations ------------------------------------------------ * -! Set limiters -! -! When G = 0, the FS method does not provide a solution. It is not -! unexpected because the FS model is originally devised as a -! thin elastic plate model in which elasticity is necessary. -! -! The FS algorithm may also have issues for very short wave periods, -! shallow waters and low G (e.g., T~3 s, d~10 m, hi~0.5 m, G<10^6 Pa) -! - IC5MINIG = IC5PARS(1) ! Minimum G - IC5MINWT = IC5PARS(2) ! Minimum T - IC5MAXKRATIO = IC5PARS(3) ! Maximum k_{ow}/k_r - IC5MAXKI = IC5PARS(4) ! Maximum k_i - IC5MINHW = IC5PARS(5) ! Minimum d - IC5VEMOD = IC5PARS(9) ! Model selected 1: EFS, 2: RP, 3: M2 -! - TISMODG = MAX(IC5MINIG, ISMODG) - TWT = MAX(IC5MINWT, WT) - THW = MAX(IC5MINHW, HWAT) -! -! G <= 0. is not allowed - IF (ABS(TISMODG) < ERRTOL) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE, 1000) 'FSDISP' - CALL EXTCDE(1) - END IF -! -! σ = 2π / T - SIGMA = TPI / TWT -! - IF (ABS(IC5VEMOD - 1.) < ERRTOL) THEN -! Complex shear modulus Gv = G - i σ ρ η (EFS model) - GV = CMPLX(TISMODG, -1. * SIGMA * RHOI * IVISC) -! -! -------------------------------------------------------------------- * -! Note that Eq. (24) in Mosig et al. (2015) can be written like below: -! (c1 * k^5 + c2 * k) * tanh(HWAT*k) - 1 = 0 -! Most Important part of this module --------------------------------- * - C1 = GV * HICE**3. / (6. * RHOW * SIGMA**2.) -! -! To be divided by (1-NU) or multiplied by (1+NU) ?? -! Beam model: then multiplied by (1+ν) -! Plate model: then divided by (1-ν) -! The beam version is more theoretically (J.E.M. Mosig, personal -! communication, 2016), although there is only very marginal difference -! between this two version as (1+NU = 1.3 and 1/(1-NU) ~ 1.4) - C1 = C1 * (1+NU) -! C1 = C1 / (1-NU) -! -! C2 -! C2 = GRAV / SIGMA**2. - RHOI * HICE / RHOW - C2 = CMPLX(GRAV / SIGMA**2. - RHOI * HICE / RHOW, 0.) -! - ELSE IF (ABS(IC5VEMOD - 2.) < ERRTOL) THEN -! See Appendix of Liu et al. (2020) - RP model - C1 = CMPLX(TISMODG * HICE**3. * (1+NU) / (6. * RHOW * SIGMA**2.), 0.) - C2 = CMPLX(GRAV/SIGMA**2. - RHOI * HICE / RHOW, & - -1. * IVISC / (RHOW * SIGMA)) -! - ELSE IF (ABS(IC5VEMOD - 3.) > ERRTOL) THEN - WRITE(NDSE, 1003) 'FSDISP', IC5VEMOD - CALL EXTCDE(4) - END IF -! Use the dispersion in open water to get an approximation of -! tanh(HWAT * k). We can also roughly use the dispersion in deep -! water case, that is tanh(HWAT*k) ~ 1. -! Wavenumber in the open water -! WAVNU1(SI, H, K, CG) - CALL WAVNU1(SIGMA, THW, WNO, CGO) - THKH = TANH(WNO * THW) -! - IF (ABS(IC5VEMOD - 1.) < ERRTOL .OR. ABS(IC5VEMOD - 2.) < ERRTOL) THEN -! Get the first guess of the complex wavenumber - CALL POLYROOTS(6, & - (/REAL(REAL(C1))*THKH, 0., 0., 0., REAL(REAL(C2))*THKH, -1./),& - RTRL, RTIM) - RTANG = ATAN2(RTIM, RTRL) -! -! There should only be one real root in RTRL + i * RTIM because in -! this case (ivisc=0) the original viscoelastic-type model reduced to -! the thin elastic plate model which has only one real solution. -! Find its index ... -! - IREAL = MINLOC(ABS(RTANG), DIM=1) - IF (RTRL(IREAL) <= 0. .OR. ABS(RTIM(IREAL)) > ERRTOL) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE, 1001) 'FSDISP' - CALL EXTCDE(2) - END IF -! -! Get the first guess for iteration - GUESS = RTRL(IREAL) * EXP(CMPLX(0., 1E-6)) -! -! Newton-Raphson method -! Turn c1, c2, hwat to be double - C1D = C1; C2D = C2; HWATD = THW - CROOT = NR_ROOT(C1D, C2D, HWATD, GUESS) - WNR = REAL(REAL(CROOT)) - WNI = REAL(AIMAG(CROOT)) -! - ELSE IF (ABS(IC5VEMOD - 3.) < ERRTOL) THEN ! M2 -! Model with Order 3 Power Law (section 6.2 in Meylan et al. (2018, JGR-Ocean)) -! Based on my understanding, the wavelength does not change because -! the elasticity is not considered in this model - WNR = WNO ! Open-water wavenumber -! Eq. (53) in Meylan et al. (2018) - WNI = HICE * IVISC * SIGMA**3. / (RHOW * GRAV**2.) + ! Note, same as W3IC3WNCG_xx in w3sic3md : + ! HICE → ICE1 + ! IVISC → ICE2 + ! RHOI → ICE3 + ! ISMODG → ICE4 + ! 0. Initializations ------------------------------------------------ * + ! Set limiters + ! + ! When G = 0, the FS method does not provide a solution. It is not + ! unexpected because the FS model is originally devised as a + ! thin elastic plate model in which elasticity is necessary. + ! + ! The FS algorithm may also have issues for very short wave periods, + ! shallow waters and low G (e.g., T~3 s, d~10 m, hi~0.5 m, G<10^6 Pa) + ! + IC5MINIG = IC5PARS(1) ! Minimum G + IC5MINWT = IC5PARS(2) ! Minimum T + IC5MAXKRATIO = IC5PARS(3) ! Maximum k_{ow}/k_r + IC5MAXKI = IC5PARS(4) ! Maximum k_i + IC5MINHW = IC5PARS(5) ! Minimum d + IC5VEMOD = IC5PARS(9) ! Model selected 1: EFS, 2: RP, 3: M2 + ! + TISMODG = MAX(IC5MINIG, ISMODG) + TWT = MAX(IC5MINWT, WT) + THW = MAX(IC5MINHW, HWAT) + ! + ! G <= 0. is not allowed + IF (ABS(TISMODG) < ERRTOL) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE, 1000) 'FSDISP' + CALL EXTCDE(1) + END IF + ! + ! σ = 2π / T + SIGMA = TPI / TWT + ! + IF (ABS(IC5VEMOD - 1.) < ERRTOL) THEN + ! Complex shear modulus Gv = G - i σ ρ η (EFS model) + GV = CMPLX(TISMODG, -1. * SIGMA * RHOI * IVISC) + ! + ! -------------------------------------------------------------------- * + ! Note that Eq. (24) in Mosig et al. (2015) can be written like below: + ! (c1 * k^5 + c2 * k) * tanh(HWAT*k) - 1 = 0 + ! Most Important part of this module --------------------------------- * + C1 = GV * HICE**3. / (6. * RHOW * SIGMA**2.) + ! + ! To be divided by (1-NU) or multiplied by (1+NU) ?? + ! Beam model: then multiplied by (1+ν) + ! Plate model: then divided by (1-ν) + ! The beam version is more theoretically (J.E.M. Mosig, personal + ! communication, 2016), although there is only very marginal difference + ! between this two version as (1+NU = 1.3 and 1/(1-NU) ~ 1.4) + C1 = C1 * (1+NU) + ! C1 = C1 / (1-NU) + ! + ! C2 + ! C2 = GRAV / SIGMA**2. - RHOI * HICE / RHOW + C2 = CMPLX(GRAV / SIGMA**2. - RHOI * HICE / RHOW, 0.) + ! + ELSE IF (ABS(IC5VEMOD - 2.) < ERRTOL) THEN + ! See Appendix of Liu et al. (2020) - RP model + C1 = CMPLX(TISMODG * HICE**3. * (1+NU) / (6. * RHOW * SIGMA**2.), 0.) + C2 = CMPLX(GRAV/SIGMA**2. - RHOI * HICE / RHOW, & + -1. * IVISC / (RHOW * SIGMA)) + ! + ELSE IF (ABS(IC5VEMOD - 3.) > ERRTOL) THEN + WRITE(NDSE, 1003) 'FSDISP', IC5VEMOD + CALL EXTCDE(4) + END IF + ! Use the dispersion in open water to get an approximation of + ! tanh(HWAT * k). We can also roughly use the dispersion in deep + ! water case, that is tanh(HWAT*k) ~ 1. + ! Wavenumber in the open water + ! WAVNU1(SI, H, K, CG) + CALL WAVNU1(SIGMA, THW, WNO, CGO) + THKH = TANH(WNO * THW) + ! + IF (ABS(IC5VEMOD - 1.) < ERRTOL .OR. ABS(IC5VEMOD - 2.) < ERRTOL) THEN + ! Get the first guess of the complex wavenumber + CALL POLYROOTS(6, & + (/REAL(REAL(C1))*THKH, 0., 0., 0., REAL(REAL(C2))*THKH, -1./),& + RTRL, RTIM) + RTANG = ATAN2(RTIM, RTRL) + ! + ! There should only be one real root in RTRL + i * RTIM because in + ! this case (ivisc=0) the original viscoelastic-type model reduced to + ! the thin elastic plate model which has only one real solution. + ! Find its index ... + ! + IREAL = MINLOC(ABS(RTANG), DIM=1) + IF (RTRL(IREAL) <= 0. .OR. ABS(RTIM(IREAL)) > ERRTOL) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE, 1001) 'FSDISP' + CALL EXTCDE(2) END IF -! -! RATIO Check -! Using the ratio k0 / kr as a basic check for the reliability of -! FSDISP. The FS dispersion relation can give a very different kr from -! k0, especially for small wave periods (k0/kr is as high as 100). -! From my tests, using IC5MAXKRATIO = 1000. can basically detect most -! spurious solutions (although not all of them) -! -! ISNAN Check -! Common ways used are: -! NAN = SQRT(-1.) or -! a /= a then a is NaN or -! ISNAN func (supported by gfortran & ifort) -! --- ISNAN -> W3INAN because ISNAN is not supported by pgi -! For very few cases, we can get nan | negative ki | kr -! -! (N.B.) NaN problem solved by using CMPLX_TANH2 -! - TRATIO = WNO / WNR - IF (W3INAN(WNR) .OR. W3INAN(WNI) .OR. WNR <= 0 .OR. WNI <= 0. & - .OR. TRATIO >= IC5MAXKRATIO) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE(NDSE, 1002) 'FSDISP', HICE, IVISC, TISMODG, HWAT, TWT, & - WNO, WNR, WNI - CALL EXTCDE(3) - END IF -! -! Filter high ki - WNI = MIN(IC5MAXKI, WNI) -! -! FORMAT - 1000 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & - ' Subr. ', A, ': Zero shear modulus G is not allowed& - & in the FS viscoelastic model'/) -! - 1001 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & - ' Subr. ', A, ': get a bad first guess'/) -! - 1002 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & - ' -----------------------------------------------------'/& - ' Subr. ', A,' : get NaN/NeG/Huge kr or ki for' /& - ' -----------------------------------------------------'/& - ' Ice thickness : ', F9.1, ' m'/ & - ' Ice viscosity : ', E9.2, ' m2/s'/ & - ' Ice shear modulus : ', E9.2, ' Pa' / & - ' Water depth : ', F9.1, ' m'/ & - ' Wave period : ', F10.2, ' s'/ & - ' Wave number (Ko) : ', F11.3, ' rad/m'/ & - ' Wave number (Kr) : ', F11.3, ' rad/m'/ & - ' Attenu. Rate (Ki) : ', E9.2, ' /m'/) -! - 1003 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & - ' Subr. ', A, ': Unknown VE model (', F5.0, ')'/) -!/ -!/ End of FSDISP ----------------------------------------------------- / -!/ - END SUBROUTINE FSDISP -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE BALANCING_MATRIX(NMAT, MATRIX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 15-Mar-2016 | -!/ +-----------------------------------+ -!/ -!/ 15-Mar-2016 : Origination ( version 5.10) -!/ ( Q. Liu ) -!/ 15-Mar-2016 : Borrowed from Numerical Recipes in Fortran -!/ ( Q. Liu ) -! 1. Purpose : -! Reducing the sensitivity of eigenvalues to rounding errors during -! the execution of some algorithms. -! -! 2. Method : -! The errors in the eigensystem found by a numerical procedure are -! generally proportional to the Euclidean norm of the matrix, that -! is, to the square root of the sum of the squares of the elements -! (sqrt(sum(a_{i, j} ** 2.)). The idea of balancing is to use -! similarity transformations to make corresponding rows and columns -! of the matrix have comparable norms, thus reducing the overall -! norm of the matrix while leaving the eigenvalues unchanged. Note -! that the symmetric matrix is already balanced. -! -! The output is matrix that is balanced in the norm given by -! summing the absolute magnitudes of the matrix elements( -! sum(abs(a_{i, j})) ). This is more efficient than using the -! Euclidean norm, and equally effective: a large reduction in -! one norm implies a large reduction in the other. -! -! For the details of this method, please refer to -! 1) Numerical Recipes in Fortran 77 (Volume 1, 2nd Edition) -! [Chapter 11.5 / subroutine balanc] -! 2) Numerical Recipes in Fortran 90 (Volume 2) -! [Chapter B11 / subroutine balanc] -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Name Type Intent Description -! ---------------------------------------------------------------- -! NMAT Int. I The size of one dimension of MATRIX -! MATRIX R.A. I/O A matrix with the shape (NMAT, NMAT) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! POLYROOTS Subr. / Find the roots of polynomials -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks: -! Balancing only needs marginal computational efforts but can -! substantially improve the accuracy of the eigenvalues computed -! for a badly balanced matrix. It is therefore recommended that -! you always balance nonsymmetric matrices. -! -! Given a (NMAT, NMAT) MATRIX, this routine replaces it by a -! balanced matrix with identical eigenvalues. A symmetric matrix is -! already balanced and is unaffected by this procedure. -! -! 8. Structure : -! -! See the source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! + ! Get the first guess for iteration + GUESS = RTRL(IREAL) * EXP(CMPLX(0., 1E-6)) + ! + ! Newton-Raphson method + ! Turn c1, c2, hwat to be double + C1D = C1; C2D = C2; HWATD = THW + CROOT = NR_ROOT(C1D, C2D, HWATD, GUESS) + WNR = REAL(REAL(CROOT)) + WNI = REAL(AIMAG(CROOT)) + ! + ELSE IF (ABS(IC5VEMOD - 3.) < ERRTOL) THEN ! M2 + ! Model with Order 3 Power Law (section 6.2 in Meylan et al. (2018, JGR-Ocean)) + ! Based on my understanding, the wavelength does not change because + ! the elasticity is not considered in this model + WNR = WNO ! Open-water wavenumber + ! Eq. (53) in Meylan et al. (2018) + WNI = HICE * IVISC * SIGMA**3. / (RHOW * GRAV**2.) + END IF + ! + ! RATIO Check + ! Using the ratio k0 / kr as a basic check for the reliability of + ! FSDISP. The FS dispersion relation can give a very different kr from + ! k0, especially for small wave periods (k0/kr is as high as 100). + ! From my tests, using IC5MAXKRATIO = 1000. can basically detect most + ! spurious solutions (although not all of them) + ! + ! ISNAN Check + ! Common ways used are: + ! NAN = SQRT(-1.) or + ! a /= a then a is NaN or + ! ISNAN func (supported by gfortran & ifort) + ! --- ISNAN -> W3INAN because ISNAN is not supported by pgi + ! For very few cases, we can get nan | negative ki | kr + ! + ! (N.B.) NaN problem solved by using CMPLX_TANH2 + ! + TRATIO = WNO / WNR + IF (W3INAN(WNR) .OR. W3INAN(WNI) .OR. WNR <= 0 .OR. WNI <= 0. & + .OR. TRATIO >= IC5MAXKRATIO) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE(NDSE, 1002) 'FSDISP', HICE, IVISC, TISMODG, HWAT, TWT, & + WNO, WNR, WNI + CALL EXTCDE(3) + END IF + ! + ! Filter high ki + WNI = MIN(IC5MAXKI, WNI) + ! + ! FORMAT +1000 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & + ' Subr. ', A, ': Zero shear modulus G is not allowed& + & in the FS viscoelastic model'/) + ! +1001 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & + ' Subr. ', A, ': get a bad first guess'/) + ! +1002 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & + ' -----------------------------------------------------'/& + ' Subr. ', A,' : get NaN/NeG/Huge kr or ki for' /& + ' -----------------------------------------------------'/& + ' Ice thickness : ', F9.1, ' m'/ & + ' Ice viscosity : ', E9.2, ' m2/s'/ & + ' Ice shear modulus : ', E9.2, ' Pa' / & + ' Water depth : ', F9.1, ' m'/ & + ' Wave period : ', F10.2, ' s'/ & + ' Wave number (Ko) : ', F11.3, ' rad/m'/ & + ' Wave number (Kr) : ', F11.3, ' rad/m'/ & + ' Attenu. Rate (Ki) : ', E9.2, ' /m'/) + ! +1003 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & + ' Subr. ', A, ': Unknown VE model (', F5.0, ')'/) + !/ + !/ End of FSDISP ----------------------------------------------------- / + !/ + END SUBROUTINE FSDISP + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE BALANCING_MATRIX(NMAT, MATRIX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 15-Mar-2016 | + !/ +-----------------------------------+ + !/ + !/ 15-Mar-2016 : Origination ( version 5.10) + !/ ( Q. Liu ) + !/ 15-Mar-2016 : Borrowed from Numerical Recipes in Fortran + !/ ( Q. Liu ) + ! 1. Purpose : + ! Reducing the sensitivity of eigenvalues to rounding errors during + ! the execution of some algorithms. + ! + ! 2. Method : + ! The errors in the eigensystem found by a numerical procedure are + ! generally proportional to the Euclidean norm of the matrix, that + ! is, to the square root of the sum of the squares of the elements + ! (sqrt(sum(a_{i, j} ** 2.)). The idea of balancing is to use + ! similarity transformations to make corresponding rows and columns + ! of the matrix have comparable norms, thus reducing the overall + ! norm of the matrix while leaving the eigenvalues unchanged. Note + ! that the symmetric matrix is already balanced. + ! + ! The output is matrix that is balanced in the norm given by + ! summing the absolute magnitudes of the matrix elements( + ! sum(abs(a_{i, j})) ). This is more efficient than using the + ! Euclidean norm, and equally effective: a large reduction in + ! one norm implies a large reduction in the other. + ! + ! For the details of this method, please refer to + ! 1) Numerical Recipes in Fortran 77 (Volume 1, 2nd Edition) + ! [Chapter 11.5 / subroutine balanc] + ! 2) Numerical Recipes in Fortran 90 (Volume 2) + ! [Chapter B11 / subroutine balanc] + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Name Type Intent Description + ! ---------------------------------------------------------------- + ! NMAT Int. I The size of one dimension of MATRIX + ! MATRIX R.A. I/O A matrix with the shape (NMAT, NMAT) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing (!/S switch). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! POLYROOTS Subr. / Find the roots of polynomials + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks: + ! Balancing only needs marginal computational efforts but can + ! substantially improve the accuracy of the eigenvalues computed + ! for a badly balanced matrix. It is therefore recommended that + ! you always balance nonsymmetric matrices. + ! + ! Given a (NMAT, NMAT) MATRIX, this routine replaces it by a + ! balanced matrix with identical eigenvalues. A symmetric matrix is + ! already balanced and is unaffected by this procedure. + ! + ! 8. Structure : + ! + ! See the source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - INTEGER, INTENT(IN) :: NMAT - REAL, INTENT(INOUT) :: MATRIX(NMAT, NMAT) -!/ ------------------------------------------------------------------- / -!/ Local parameter + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + INTEGER, INTENT(IN) :: NMAT + REAL, INTENT(INOUT) :: MATRIX(NMAT, NMAT) + !/ ------------------------------------------------------------------- / + !/ Local parameter #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! the parameter radx is the machine's floating-point radix - REAL, PARAMETER :: RADX = RADIX(MATRIX), & - SQRADX = RADX ** 2 - INTEGER :: I, LAST - REAL :: C, F, G, R, S -!/ ------------------------------------------------------------------- / + ! the parameter radx is the machine's floating-point radix + REAL, PARAMETER :: RADX = RADIX(MATRIX), & + SQRADX = RADX ** 2 + INTEGER :: I, LAST + REAL :: C, F, G, R, S + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'BALANCING_MATRIX') + CALL STRACE (IENT, 'BALANCING_MATRIX') #endif -! - DO - LAST = 1 - DO I = 1, NMAT -! Calculate row and column norms - C = SUM( ABS(MATRIX(:, I)) ) - MATRIX(I, I) - R = SUM( ABS(MATRIX(I, :)) ) - MATRIX(I, I) -! If both are non-zero - IF (C /= 0.0 .AND. R /= 0.0) THEN -! Find the integer power of the machine radix that comes closest to -! balancing the matrix (get G, F from C, R) - G = R / RADX - F = 1.0 - S = C + R - DO - IF (C >= G) EXIT - F = F * RADX - C = C * SQRADX - END DO -! - G = R * RADX - DO - IF (C <= G) EXIT - F = F / RADX - C = C / SQRADX - END DO -! - IF ( (C+R)/F < 0.95*S) THEN - LAST = 0 - G = 1.0 / F -! Apply similarity tranformation - MATRIX(I, :) = MATRIX(I, :) * G - MATRIX(:, I) = MATRIX(:, I) * F - END IF - END IF + ! + DO + LAST = 1 + DO I = 1, NMAT + ! Calculate row and column norms + C = SUM( ABS(MATRIX(:, I)) ) - MATRIX(I, I) + R = SUM( ABS(MATRIX(I, :)) ) - MATRIX(I, I) + ! If both are non-zero + IF (C /= 0.0 .AND. R /= 0.0) THEN + ! Find the integer power of the machine radix that comes closest to + ! balancing the matrix (get G, F from C, R) + G = R / RADX + F = 1.0 + S = C + R + DO + IF (C >= G) EXIT + F = F * RADX + C = C * SQRADX END DO - IF (LAST /= 0) EXIT + ! + G = R * RADX + DO + IF (C <= G) EXIT + F = F / RADX + C = C / SQRADX + END DO + ! + IF ( (C+R)/F < 0.95*S) THEN + LAST = 0 + G = 1.0 / F + ! Apply similarity tranformation + MATRIX(I, :) = MATRIX(I, :) * G + MATRIX(:, I) = MATRIX(:, I) * F + END IF + END IF END DO -!/ -!/ End of subroutine BALANCING_MATRIX -------------------------------- / -!/ - END SUBROUTINE BALANCING_MATRIX -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE EIG_HQR (NMAT, HMAT, EIGR, EIGI) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 17-Mar-2016 | -!/ +-----------------------------------+ -!/ -!/ 16-Mar-2016 : Origination ( version 5.10) -!/ ( Q. Liu ) -!/ 16-Mar-2016 : Borrowed from Numerical Recipes in Fortran -!/ ( Q. Liu ) -!/ 17-Mar-2016 : Update the NR code v2.08 to v2.10 ( Q. Liu ) -!/ -! 1. Purpose : -! -! When we calculate the eigenvalues of a general matrix, we first -! reduce the matrix to a simpler form (e.g., Hessenberg form) and -! then we perform the iterative procedures. -! -! A upper Hessenberg matrix has zeros everywhere below the diagnal -! except for the first subdiagonal row. For example, in the 6x6 -! case, the non-zero elements are: -! |x x x x x x| -! |x x x x x x| -! | x x x x x| -! | x x x x| -! | x x x| -! | x x| -! -! This subroutine uses QR algorithm to get the eigenvalues of a -! Hessenberg matrix. So make sure the input array HMAT is a -! Hessenberg-type matrix. -! -! 2. Method : -! QR algorithm for real Hessenberg matrices. -! (I did not understand this algorithm well, so I could not give -! any detailed explanations) -! -! For the details of this HQR method, please refer to -! 1) Numerical Recipes in Fortran 77 (Volume 1, 2nd Edition) -! [Chapter 11.6 / subroutine hqr] -! 2) Numerical Recipes in Fortran 90 (Volume 2) -! [Chapter B11 / subroutine hqr] -! -! Note that there is a bug in the `hqr` subroutine in NR v2.08. -! See http://numerical.recipes/latest-known-bugs.html. Please use -! the updated code in NR v2.10. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Name Type Intent Description -! ---------------------------------------------------------------- -! NMAT Int. I the size of one dimension of HMAT -! HMAT R.A. I/O the Hessenberg-type matrix (NMAT, NMAT) -! EIGR R.A. O the real part of the N eigenvalues -! EIGI R.A. O the imag part of the N eigenvalues -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! POLYROOTS Subr. / Find the roots of polynomials -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See Format 1001 -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + IF (LAST /= 0) EXIT + END DO + !/ + !/ End of subroutine BALANCING_MATRIX -------------------------------- / + !/ + END SUBROUTINE BALANCING_MATRIX + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE EIG_HQR (NMAT, HMAT, EIGR, EIGI) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 17-Mar-2016 | + !/ +-----------------------------------+ + !/ + !/ 16-Mar-2016 : Origination ( version 5.10) + !/ ( Q. Liu ) + !/ 16-Mar-2016 : Borrowed from Numerical Recipes in Fortran + !/ ( Q. Liu ) + !/ 17-Mar-2016 : Update the NR code v2.08 to v2.10 ( Q. Liu ) + !/ + ! 1. Purpose : + ! + ! When we calculate the eigenvalues of a general matrix, we first + ! reduce the matrix to a simpler form (e.g., Hessenberg form) and + ! then we perform the iterative procedures. + ! + ! A upper Hessenberg matrix has zeros everywhere below the diagnal + ! except for the first subdiagonal row. For example, in the 6x6 + ! case, the non-zero elements are: + ! |x x x x x x| + ! |x x x x x x| + ! | x x x x x| + ! | x x x x| + ! | x x x| + ! | x x| + ! + ! This subroutine uses QR algorithm to get the eigenvalues of a + ! Hessenberg matrix. So make sure the input array HMAT is a + ! Hessenberg-type matrix. + ! + ! 2. Method : + ! QR algorithm for real Hessenberg matrices. + ! (I did not understand this algorithm well, so I could not give + ! any detailed explanations) + ! + ! For the details of this HQR method, please refer to + ! 1) Numerical Recipes in Fortran 77 (Volume 1, 2nd Edition) + ! [Chapter 11.6 / subroutine hqr] + ! 2) Numerical Recipes in Fortran 90 (Volume 2) + ! [Chapter B11 / subroutine hqr] + ! + ! Note that there is a bug in the `hqr` subroutine in NR v2.08. + ! See http://numerical.recipes/latest-known-bugs.html. Please use + ! the updated code in NR v2.10. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Name Type Intent Description + ! ---------------------------------------------------------------- + ! NMAT Int. I the size of one dimension of HMAT + ! HMAT R.A. I/O the Hessenberg-type matrix (NMAT, NMAT) + ! EIGR R.A. O the real part of the N eigenvalues + ! EIGI R.A. O the imag part of the N eigenvalues + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! POLYROOTS Subr. / Find the roots of polynomials + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See Format 1001 + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NMAT - REAL, INTENT(INOUT) :: HMAT(NMAT, NMAT) - REAL, INTENT(OUT) :: EIGR(NMAT), EIGI(NMAT) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NMAT + REAL, INTENT(INOUT) :: HMAT(NMAT, NMAT) + REAL, INTENT(OUT) :: EIGR(NMAT), EIGI(NMAT) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ - INTEGER :: I, ITS, K, L, M, NN, MNNK, IDIAG - REAL :: ANORM, P, Q, R, S, T, U, V, W, X, Y, Z - REAL :: PP(NMAT) -!/ ------------------------------------------------------------------- / -!/ + !/ + INTEGER :: I, ITS, K, L, M, NN, MNNK, IDIAG + REAL :: ANORM, P, Q, R, S, T, U, V, W, X, Y, Z + REAL :: PP(NMAT) + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'EIG_HQR') + CALL STRACE (IENT, 'EIG_HQR') #endif -! -! Compute matrix norm for possible use in locating single small -! subdiagonal element. -! -! Note the speciality of Hessenberg matrix : -! Elements below the diagonal are zeros except for the first -! subdiagonal row. It might be more accurate if we use a mask array -! to mask all zero elments. -! - ANORM = SUM(ABS(HMAT)) - NN = NMAT -! Gets changed only by an exceptional shift. - T = 0.0 -! Begin search for next eigenvalue: "do while nn >= 1" - DO - IF (NN < 1) EXIT - ITS=0 -! Begin iteration - ITERATE:DO -! Look for single small subdiagonal element. - SMALL: DO L=NN, 2, -1 - S = ABS( HMAT(L-1, L-1) ) + ABS( HMAT(L, L) ) -! IF (S == 0.0) S = ANORM - IF (ABS(S) < ERRTOL) S = ANORM -! IF ( ABS(HMAT(L, L-1)) + S == S ) THEN - IF ( ABS(HMAT(L, L-1)) < ERRTOL ) THEN - HMAT(L, L-1) = 0.0 - EXIT SMALL - END IF - END DO SMALL - X = HMAT(NN, NN) -! One root found - IF (L == NN) THEN - EIGR(NN) = X + T - EIGI(NN) = 0.0 - NN=NN-1 -! Go back for next eigenvalue - EXIT ITERATE - END IF - Y = HMAT(NN-1, NN-1) - W = HMAT(NN, NN-1) * HMAT(NN-1, NN) -! Two roots found . . . - IF (L == NN-1) THEN - P = 0.5 * (Y - X) - Q = P**2 + W - Z = SQRT( ABS(Q) ) - X = X + T -! . . . A real pair . . . - IF (Q >= 0.0) THEN - Z = P + SIGN(Z, P) - EIGR(NN) = X + Z - EIGR(NN-1) = EIGR(NN) - IF (Z /= 0.0) EIGR(NN) = X - W/Z - EIGI(NN) = 0.0 - EIGI(NN-1) = 0.0 -! . . . A complex pair - ELSE - EIGR(NN) = X + P - EIGR(NN-1) = EIGR(NN) - EIGI(NN) = Z - EIGI(NN-1) = -Z - END IF - NN=NN-2 -! GO BACK FOR NEXT EIGENVALUE. - EXIT ITERATE - END IF -! NO ROOTS FOUND. CONTINUE ITERATION. - IF (ITS == 30) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE, 1001) 'EIG_HQR' - CALL EXTCDE(2) - END IF -! FORM EXCEPTIONAL SHIFT. - IF (ITS == 10 .OR. ITS == 20) THEN - T = T + X -! Add -X to the diagonal of HMAT - DO IDIAG = 1, NN - HMAT(IDIAG, IDIAG) = HMAT(IDIAG, IDIAG) + (-X) - END DO - S = ABS(HMAT(NN, NN-1)) + ABS(HMAT(NN-1, NN-2)) - X = 0.75 * S - Y = X - W = -0.4375 * S**2 - END IF - ITS = ITS + 1 -! Form shift and then look for 2 consecutive small subdiagonal elements. - DO M = NN-2, L, -1 - Z = HMAT(M, M) - R = X - Z - S = Y - Z -! Equation (11.6.23). - P = (R * S - W) / HMAT(M+1, M) + HMAT(M, M+1) - Q = HMAT(M+1, M+1) - Z - R - S - R = HMAT(M+2, M+1) -! Scale to prevent overflow or underflow - S = ABS(P) + ABS(Q) + ABS(R) - P = P / S - Q = Q / S - R = R / S - IF (M == L) EXIT - U = ABS( HMAT(M, M-1) ) * ( ABS(Q) + ABS(R) ) - V = ABS(P) * ( ABS(HMAT(M-1, M-1)) + ABS(Z) + & - ABS( HMAT(M+1, M+1) )) -! Equation (11.6.26) - IF (U+V == V) EXIT - END DO - DO I= M+2, NN - HMAT(I, I-2) = 0.0 - IF (I /= M+2) HMAT(I, I-3)=0.0 - END DO -! Double QR step on rows L to NN and columns M to NN - DO K=M, NN-1 - IF (K /= M) THEN -! Begin setup of householder vector - P = HMAT(K, K-1) - Q = HMAT(K+1, K-1) - R = 0.0 - IF (K /= NN-1) R = HMAT(K+2, K-1) - X = ABS(P) + ABS(Q) + ABS(R) - IF (X /= 0.0) THEN -! Scale to prevent overflow or underflow - P = P / X - Q = Q / X - R = R / X - END IF - END IF - S = SIGN(SQRT(P**2 + Q**2 + R**2), P) - IF (S /= 0.0) THEN - IF (K == M) THEN - IF (L /= M) HMAT(K, K-1) = -HMAT(K, K-1) - ELSE - HMAT(K, K-1) = -S * X - END IF -! Equations (11.6.24). - P = P + S - X = P / S - Y = Q / S - Z = R / S - Q = Q / P -! READY FOR ROW MODIFICATION. - R = R / P - PP(K:NN) = HMAT(K, K:NN) + Q * HMAT(K+1, K:NN) - IF (K /= NN-1) THEN - PP(K:NN) = PP(K:NN) + R * HMAT(K+2, K:NN) - HMAT(K+2, K:NN) = HMAT(K+2, K:NN) - & - PP(K:NN)*Z - END IF - HMAT(K+1, K:NN) = HMAT(K+1, K:NN) - PP(K:NN) * Y - HMAT(K, K:NN) = HMAT(K, K:NN) - PP(K:NN) * X -! COLUMN MODIFICATION. - MNNK = MIN(NN, K+3) - PP(L:MNNK) = X * HMAT(L:MNNK, K) + Y * & - HMAT(L:MNNK, K+1) - IF (K /= NN-1) THEN - PP(L:MNNK) = PP(L:MNNK) + Z*HMAT(L:MNNK, K+2) - HMAT(L:MNNK, K+2) = HMAT(L:MNNK, K+2) - & - PP(L:MNNK) * R - END IF - HMAT(L:MNNK, K+1) = HMAT(L:MNNK, K+1) - & - PP(L:MNNK) * Q - HMAT(L:MNNK, K) = HMAT(L:MNNK, K) - PP(L:MNNK) - END IF - END DO -! GO BACK FOR NEXT ITERATION ON CURRENT EIGENEND DO VALUE. - END DO ITERATE - END DO -! -! Formats - 1001 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & - ' Subr. ', A, ': TOO MANY ITERATIONS'/) -!/ ------------------------------------------------------------------- / -!/ -!/ End of EIG_HQR ---------------------------------------------------- / -!/ - END SUBROUTINE EIG_HQR -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE POLYROOTS(NPC, PCVEC, RTRL, RTIM) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 16-Mar-2016 | -!/ +-----------------------------------+ -!/ -!/ 16-Mar-2016 : Origination ( version 5.10) -!/ ( Q. Liu ) -!/ 16-Mar-2016 : Started from Numerical Recipes in Fortran -!/ ( Q. Liu ) -!/ -! 1. Purpose : -! -! Find the roots of arbitrary polynomials through finding the -! eigenvalues of companion matrix. -! -! 2. Method : -! Suppose we have a general polynomial, which reads -! P(x) = c_n * x^n + c_{n-1} * x^{n-1} + ... + c_1 * x + c_0 -! -! Then finding the roots of P(x) is equivalent to find the eigen- -! values of the special n x n companion matrix A -! | -c_{n-1}/c_n -c_{n-2}/c_n ... -c_1/c_n -c_0/c_n | -! | 1 0 ... 0 0 | -! A = | 0 1 ... 0 0 | -! | : : : : | -! | 0 0 1 0 | -! -! In fact, P(x) is the characteristic polynomial of matrix A, i.e., -! P(x) = det|A-xI| and x is the eigenvalues of A (this is a -! Hessenberg matrix). -! -! In this subrountine, we will use the two subroutines above -! (BALANCING_MATRIX & EIG_HQR) to get the complex eigenvalues of -! an abitrary Hessenberg matrix -! -! For the details of this method, please refer to -! 1) Numerical Recipes in Fortran 77 (Volume 1, 2nd Edition) -! [Chapter 9.5 / Eigenvalue Methods / subroutine zrhqr] -! 2) Numerical Recipes in Fortran 90 (Volume 2) -! [Chapter B9 / subroutine zrhqr] -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Name Type Intent Description -! ---------------------------------------------------------------- -! NPC Int. I The # of the Polynomial coefficients -! (from c_n to c_0) -! PCVEC R.A. I The 1d vector for the Polynomial -! coefficients [c_n, c_{n-1}, ..., c_0] -! RTRL R.A. O The real part of all of the roots -! shape: [NPC-1] -! RTIM R.A. O The real part of all of the roots -! shape: [NPC-1] -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ------------------------------------- --------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! BALANCING_MATRIX Subr. / Balancing matrix -! EIG_HQR Subr. / Finding eigenvalues -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! FSDISP Subr. / Solving the dispersion relations -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See Format 1001 -! -! 7. Remarks : -! The built-in MATLAB function uses the same method to -! find roots of a general polynomial. But perhaps MATLAB uses -! different methods to find eigenvalues of the companion matrix. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! + ! Compute matrix norm for possible use in locating single small + ! subdiagonal element. + ! + ! Note the speciality of Hessenberg matrix : + ! Elements below the diagonal are zeros except for the first + ! subdiagonal row. It might be more accurate if we use a mask array + ! to mask all zero elments. + ! + ANORM = SUM(ABS(HMAT)) + NN = NMAT + ! Gets changed only by an exceptional shift. + T = 0.0 + ! Begin search for next eigenvalue: "do while nn >= 1" + DO + IF (NN < 1) EXIT + ITS=0 + ! Begin iteration + ITERATE:DO + ! Look for single small subdiagonal element. + SMALL: DO L=NN, 2, -1 + S = ABS( HMAT(L-1, L-1) ) + ABS( HMAT(L, L) ) + ! IF (S == 0.0) S = ANORM + IF (ABS(S) < ERRTOL) S = ANORM + ! IF ( ABS(HMAT(L, L-1)) + S == S ) THEN + IF ( ABS(HMAT(L, L-1)) < ERRTOL ) THEN + HMAT(L, L-1) = 0.0 + EXIT SMALL + END IF + END DO SMALL + X = HMAT(NN, NN) + ! One root found + IF (L == NN) THEN + EIGR(NN) = X + T + EIGI(NN) = 0.0 + NN=NN-1 + ! Go back for next eigenvalue + EXIT ITERATE + END IF + Y = HMAT(NN-1, NN-1) + W = HMAT(NN, NN-1) * HMAT(NN-1, NN) + ! Two roots found . . . + IF (L == NN-1) THEN + P = 0.5 * (Y - X) + Q = P**2 + W + Z = SQRT( ABS(Q) ) + X = X + T + ! . . . A real pair . . . + IF (Q >= 0.0) THEN + Z = P + SIGN(Z, P) + EIGR(NN) = X + Z + EIGR(NN-1) = EIGR(NN) + IF (Z /= 0.0) EIGR(NN) = X - W/Z + EIGI(NN) = 0.0 + EIGI(NN-1) = 0.0 + ! . . . A complex pair + ELSE + EIGR(NN) = X + P + EIGR(NN-1) = EIGR(NN) + EIGI(NN) = Z + EIGI(NN-1) = -Z + END IF + NN=NN-2 + ! GO BACK FOR NEXT EIGENVALUE. + EXIT ITERATE + END IF + ! NO ROOTS FOUND. CONTINUE ITERATION. + IF (ITS == 30) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE, 1001) 'EIG_HQR' + CALL EXTCDE(2) + END IF + ! FORM EXCEPTIONAL SHIFT. + IF (ITS == 10 .OR. ITS == 20) THEN + T = T + X + ! Add -X to the diagonal of HMAT + DO IDIAG = 1, NN + HMAT(IDIAG, IDIAG) = HMAT(IDIAG, IDIAG) + (-X) + END DO + S = ABS(HMAT(NN, NN-1)) + ABS(HMAT(NN-1, NN-2)) + X = 0.75 * S + Y = X + W = -0.4375 * S**2 + END IF + ITS = ITS + 1 + ! Form shift and then look for 2 consecutive small subdiagonal elements. + DO M = NN-2, L, -1 + Z = HMAT(M, M) + R = X - Z + S = Y - Z + ! Equation (11.6.23). + P = (R * S - W) / HMAT(M+1, M) + HMAT(M, M+1) + Q = HMAT(M+1, M+1) - Z - R - S + R = HMAT(M+2, M+1) + ! Scale to prevent overflow or underflow + S = ABS(P) + ABS(Q) + ABS(R) + P = P / S + Q = Q / S + R = R / S + IF (M == L) EXIT + U = ABS( HMAT(M, M-1) ) * ( ABS(Q) + ABS(R) ) + V = ABS(P) * ( ABS(HMAT(M-1, M-1)) + ABS(Z) + & + ABS( HMAT(M+1, M+1) )) + ! Equation (11.6.26) + IF (U+V == V) EXIT + END DO + DO I= M+2, NN + HMAT(I, I-2) = 0.0 + IF (I /= M+2) HMAT(I, I-3)=0.0 + END DO + ! Double QR step on rows L to NN and columns M to NN + DO K=M, NN-1 + IF (K /= M) THEN + ! Begin setup of householder vector + P = HMAT(K, K-1) + Q = HMAT(K+1, K-1) + R = 0.0 + IF (K /= NN-1) R = HMAT(K+2, K-1) + X = ABS(P) + ABS(Q) + ABS(R) + IF (X /= 0.0) THEN + ! Scale to prevent overflow or underflow + P = P / X + Q = Q / X + R = R / X + END IF + END IF + S = SIGN(SQRT(P**2 + Q**2 + R**2), P) + IF (S /= 0.0) THEN + IF (K == M) THEN + IF (L /= M) HMAT(K, K-1) = -HMAT(K, K-1) + ELSE + HMAT(K, K-1) = -S * X + END IF + ! Equations (11.6.24). + P = P + S + X = P / S + Y = Q / S + Z = R / S + Q = Q / P + ! READY FOR ROW MODIFICATION. + R = R / P + PP(K:NN) = HMAT(K, K:NN) + Q * HMAT(K+1, K:NN) + IF (K /= NN-1) THEN + PP(K:NN) = PP(K:NN) + R * HMAT(K+2, K:NN) + HMAT(K+2, K:NN) = HMAT(K+2, K:NN) - & + PP(K:NN)*Z + END IF + HMAT(K+1, K:NN) = HMAT(K+1, K:NN) - PP(K:NN) * Y + HMAT(K, K:NN) = HMAT(K, K:NN) - PP(K:NN) * X + ! COLUMN MODIFICATION. + MNNK = MIN(NN, K+3) + PP(L:MNNK) = X * HMAT(L:MNNK, K) + Y * & + HMAT(L:MNNK, K+1) + IF (K /= NN-1) THEN + PP(L:MNNK) = PP(L:MNNK) + Z*HMAT(L:MNNK, K+2) + HMAT(L:MNNK, K+2) = HMAT(L:MNNK, K+2) - & + PP(L:MNNK) * R + END IF + HMAT(L:MNNK, K+1) = HMAT(L:MNNK, K+1) - & + PP(L:MNNK) * Q + HMAT(L:MNNK, K) = HMAT(L:MNNK, K) - PP(L:MNNK) + END IF + END DO + ! GO BACK FOR NEXT ITERATION ON CURRENT EIGENEND DO VALUE. + END DO ITERATE + END DO + ! + ! Formats +1001 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & + ' Subr. ', A, ': TOO MANY ITERATIONS'/) + !/ ------------------------------------------------------------------- / + !/ + !/ End of EIG_HQR ---------------------------------------------------- / + !/ + END SUBROUTINE EIG_HQR + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE POLYROOTS(NPC, PCVEC, RTRL, RTIM) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 16-Mar-2016 | + !/ +-----------------------------------+ + !/ + !/ 16-Mar-2016 : Origination ( version 5.10) + !/ ( Q. Liu ) + !/ 16-Mar-2016 : Started from Numerical Recipes in Fortran + !/ ( Q. Liu ) + !/ + ! 1. Purpose : + ! + ! Find the roots of arbitrary polynomials through finding the + ! eigenvalues of companion matrix. + ! + ! 2. Method : + ! Suppose we have a general polynomial, which reads + ! P(x) = c_n * x^n + c_{n-1} * x^{n-1} + ... + c_1 * x + c_0 + ! + ! Then finding the roots of P(x) is equivalent to find the eigen- + ! values of the special n x n companion matrix A + ! | -c_{n-1}/c_n -c_{n-2}/c_n ... -c_1/c_n -c_0/c_n | + ! | 1 0 ... 0 0 | + ! A = | 0 1 ... 0 0 | + ! | : : : : | + ! | 0 0 1 0 | + ! + ! In fact, P(x) is the characteristic polynomial of matrix A, i.e., + ! P(x) = det|A-xI| and x is the eigenvalues of A (this is a + ! Hessenberg matrix). + ! + ! In this subrountine, we will use the two subroutines above + ! (BALANCING_MATRIX & EIG_HQR) to get the complex eigenvalues of + ! an abitrary Hessenberg matrix + ! + ! For the details of this method, please refer to + ! 1) Numerical Recipes in Fortran 77 (Volume 1, 2nd Edition) + ! [Chapter 9.5 / Eigenvalue Methods / subroutine zrhqr] + ! 2) Numerical Recipes in Fortran 90 (Volume 2) + ! [Chapter B9 / subroutine zrhqr] + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Name Type Intent Description + ! ---------------------------------------------------------------- + ! NPC Int. I The # of the Polynomial coefficients + ! (from c_n to c_0) + ! PCVEC R.A. I The 1d vector for the Polynomial + ! coefficients [c_n, c_{n-1}, ..., c_0] + ! RTRL R.A. O The real part of all of the roots + ! shape: [NPC-1] + ! RTIM R.A. O The real part of all of the roots + ! shape: [NPC-1] + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ------------------------------------- --------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! BALANCING_MATRIX Subr. / Balancing matrix + ! EIG_HQR Subr. / Finding eigenvalues + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! FSDISP Subr. / Solving the dispersion relations + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See Format 1001 + ! + ! 7. Remarks : + ! The built-in MATLAB function uses the same method to + ! find roots of a general polynomial. But perhaps MATLAB uses + ! different methods to find eigenvalues of the companion matrix. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - INTEGER, INTENT(IN) :: NPC - REAL, INTENT(IN) :: PCVEC(NPC) - REAL, INTENT(OUT) :: RTRL(NPC-1), RTIM(NPC-1) -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + INTEGER, INTENT(IN) :: NPC + REAL, INTENT(IN) :: PCVEC(NPC) + REAL, INTENT(OUT) :: RTRL(NPC-1), RTIM(NPC-1) + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: HESS(NPC-1, NPC-1) - INTEGER :: J -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: HESS(NPC-1, NPC-1) + INTEGER :: J + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'POLYROOTS') + CALL STRACE (IENT, 'POLYROOTS') #endif -! -! - IF (ABS(PCVEC(1)) < ERRTOL) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE, 1001) 'POLYROOTS' - CALL EXTCDE(2) - END IF -! -! Generate the Hessenberg matrix - HESS = 0. - HESS(1, :) = -1 * PCVEC(2:) / PCVEC(1) - DO J = 1, NPC-2 - HESS(J+1, J) = 1. - END DO + ! + ! + IF (ABS(PCVEC(1)) < ERRTOL) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE, 1001) 'POLYROOTS' + CALL EXTCDE(2) + END IF + ! + ! Generate the Hessenberg matrix + HESS = 0. + HESS(1, :) = -1 * PCVEC(2:) / PCVEC(1) + DO J = 1, NPC-2 + HESS(J+1, J) = 1. + END DO -! Balancing the matrix HESS - CALL BALANCING_MATRIX(NPC-1, HESS) -! Eigenvalues of the matrix HESS - CALL EIG_HQR(NPC-1, HESS, RTRL, RTIM) + ! Balancing the matrix HESS + CALL BALANCING_MATRIX(NPC-1, HESS) + ! Eigenvalues of the matrix HESS + CALL EIG_HQR(NPC-1, HESS, RTRL, RTIM) -! Formats - 1001 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & - ' Subr. ', A, ': the coeff. of x^n must not be 0'/) -!/ -!/ End of POLYROOTS -------------------------------------------------- / -!/ - END SUBROUTINE POLYROOTS -!/ ------------------------------------------------------------------- / -!/ - FUNCTION NR_CORR(K, C1, C2, H) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 19-May-2021 | -!/ +-----------------------------------+ -!/ -!/ 18-Mar-2016 : Origination. ( version 5.10 ) -!/ ( Q. Liu ) -!/ 18-Mar-2016 : Start from the Matlab code `FoxSquire.m` (provided -!/ by Prof. Vernon Squire from University of Otago) -!/ ( Q. Liu ) -!/ 24-Mar-2016 : Adding the cmplx_sinh/cosh/tanh ( Q. Liu ) -!/ -!/ 19-May-2021 : Change types of few input arguments ( Q. Liu ) -!/ -! 1. Purpose : -! -! Calculate the corrected term in the Newton-Raphson root-finding -! method (Must use double precision) -! -! 2. Method : -! Suppose we want to find the root of f(x) = 0, then according to -! the Newton-Raphson method, the root is iteratively updated by the -! formula below: -! -! x_{i+1} = x_{i} - f(x_{i}) / f'(x_{i}), -! -! where f'(x) denotes the derivative of f(x). In this function, -! our f(x) reads (see also subr. FSDISP) -! -! f(x) = (c1 * k**4 + c2) * k * tanh(kH) -1 -! -! we finally will get the Newton-Raphson correted term, i.e., -! -! dx = f(x_{i}) / f'(x_{i}) -! -! For the details of this method, please refer to -! 1) Numerical Recipes in Fortran 77 (Volume 1, 2nd Edition) -! Chapter 9.4 -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Name Type Intent Description -! ---------------------------------------------------------------- -! K CMPL.(D) I complex wave number -! C1 CMPL.(D) I C1 in FSDISP -! C2 Real.(D) I C2 in FSDISP -! H Real.(D) I water depth -! NR_CORR CMPL.(D) O Newton-Raphson corrected term (DK) -! ---------------------------------------------------------------- -! * (D) means double precision -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! CMPLX_SINH Func. / sinh for complex var. -! CMPLX_COSH Func. / cosh for complex var. -! CMPLX_TANH2 Func. / tanh for complex var. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NR_ROOT Func. / Newton-Raphson root finding. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! Formats +1001 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & + ' Subr. ', A, ': the coeff. of x^n must not be 0'/) + !/ + !/ End of POLYROOTS -------------------------------------------------- / + !/ + END SUBROUTINE POLYROOTS + !/ ------------------------------------------------------------------- / + !/ + FUNCTION NR_CORR(K, C1, C2, H) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 19-May-2021 | + !/ +-----------------------------------+ + !/ + !/ 18-Mar-2016 : Origination. ( version 5.10 ) + !/ ( Q. Liu ) + !/ 18-Mar-2016 : Start from the Matlab code `FoxSquire.m` (provided + !/ by Prof. Vernon Squire from University of Otago) + !/ ( Q. Liu ) + !/ 24-Mar-2016 : Adding the cmplx_sinh/cosh/tanh ( Q. Liu ) + !/ + !/ 19-May-2021 : Change types of few input arguments ( Q. Liu ) + !/ + ! 1. Purpose : + ! + ! Calculate the corrected term in the Newton-Raphson root-finding + ! method (Must use double precision) + ! + ! 2. Method : + ! Suppose we want to find the root of f(x) = 0, then according to + ! the Newton-Raphson method, the root is iteratively updated by the + ! formula below: + ! + ! x_{i+1} = x_{i} - f(x_{i}) / f'(x_{i}), + ! + ! where f'(x) denotes the derivative of f(x). In this function, + ! our f(x) reads (see also subr. FSDISP) + ! + ! f(x) = (c1 * k**4 + c2) * k * tanh(kH) -1 + ! + ! we finally will get the Newton-Raphson correted term, i.e., + ! + ! dx = f(x_{i}) / f'(x_{i}) + ! + ! For the details of this method, please refer to + ! 1) Numerical Recipes in Fortran 77 (Volume 1, 2nd Edition) + ! Chapter 9.4 + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Name Type Intent Description + ! ---------------------------------------------------------------- + ! K CMPL.(D) I complex wave number + ! C1 CMPL.(D) I C1 in FSDISP + ! C2 Real.(D) I C2 in FSDISP + ! H Real.(D) I water depth + ! NR_CORR CMPL.(D) O Newton-Raphson corrected term (DK) + ! ---------------------------------------------------------------- + ! * (D) means double precision + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! CMPLX_SINH Func. / sinh for complex var. + ! CMPLX_COSH Func. / cosh for complex var. + ! CMPLX_TANH2 Func. / tanh for complex var. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NR_ROOT Func. / Newton-Raphson root finding. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -! COMPLEX(KDPC), INTENT(IN) :: K, C1 -! REAL(KDP), INTENT(IN) :: C2, H - COMPLEX(KDPC), INTENT(IN) :: K, C1, C2 - REAL(KDP), INTENT(IN) :: H - COMPLEX(KDPC) :: NR_CORR -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + ! COMPLEX(KDPC), INTENT(IN) :: K, C1 + ! REAL(KDP), INTENT(IN) :: C2, H + COMPLEX(KDPC), INTENT(IN) :: K, C1, C2 + REAL(KDP), INTENT(IN) :: H + COMPLEX(KDPC) :: NR_CORR + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! A rough value to differentiate deep water case from finite water case - REAL(KDP), PARAMETER :: KH_LIM = 7.5 - COMPLEX(KDPC) :: LAM, LAMPR, FV, DF, TKH -!/ -!/ ------------------------------------------------------------------- / -!/ + ! A rough value to differentiate deep water case from finite water case + REAL(KDP), PARAMETER :: KH_LIM = 7.5 + COMPLEX(KDPC) :: LAM, LAMPR, FV, DF, TKH + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'NR_CORR') + CALL STRACE (IENT, 'NR_CORR') #endif -! f(k) = (c1 * k**4 + c2) * k * tanh(k*H) - 1 -! = lam * k * tanh(k*H) - 1 -! - TKH = K * H - LAM = C1 * K**4 + C2 -! the derivative of (lam * k) - LAMPR = 5 * C1 * K**4 + C2 -! - IF (REAL(REAL(TKH)) <= KH_LIM) THEN -! KH is small enough -! FV = LAM * K * SINH(K*H) - COSH(K*H) -! DF = LAM * (K*H) * COSH(K*H) + (LAMPR - H) * SINH(K*H) - FV = LAM * K * CMPLX_SINH(TKH) - CMPLX_COSH(TKH) - DF = LAM * TKH * CMPLX_COSH(TKH) + (LAMPR-H) * CMPLX_SINH(TKH) - ELSE -! FV = LAM * K * TANH(K*H) - 1 -! DF = LAM * K * H + (LAMPR - H) * TANH(K*H) -! DF = LAMPR * TANH(K*H) + LAM * K * H / (COSH(K*H) **2) - FV = LAM * K * CMPLX_TANH2(TKH) - 1 - DF = LAMPR * CMPLX_TANH2(TKH) + LAM * TKH * & - (1 - CMPLX_TANH2(TKH) ** 2.) - END IF -! - NR_CORR = FV / DF -!/ -!/ End of NR_CORR ---------------------------------------------------- / -!/ - END FUNCTION NR_CORR -!/ ------------------------------------------------------------------- / -!/ - FUNCTION NR_ROOT(C1, C2, H, GUESS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 19-May-2021 | -!/ +-----------------------------------+ -!/ -!/ 18-Mar-2016 : Origination. ( version 5.10 ) -!/ ( Q. Liu ) -!/ 18-Mar-2016 : Start from the Matlab code `FoxSquire.m` (provided -!/ by Prof. Vernon Squire from University of Otago) -!/ ( Q. Liu ) -!/ -!/ 19-May-2021 : Change types of few input arguments ( Q. Liu ) -!/ -! 1. Purpose : -! -! The iterative procedure of the Newton-Raphson method -! -! 2. Method : -! See the document of Subr. NR_CORR (Must use double precision) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Name Type Intent Description -! ---------------------------------------------------------------- -! C1 CMPL.(D) I C1 in FS dipsersion relations -! See the doc. of subr. NR_CORR -! C2 REAL (D) I C2 in FS dipsersion relations -! H REAL (D) I water depth -! GUESS CMPL.(D) I the first guess obtained from POLYROOTS -! NR_ROOT CMPL.(D) O the calculated complex wave number. -! ---------------------------------------------------------------- -! * (D) means double precision -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! NR_CORR Func. / Newton-Raphson correction term -! INIT_RANDOM_SEED -! Subr. / Initialize the random seed based on -! the system's time -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! FSDISP Subr. / Solve FS dispersion relations -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! f(k) = (c1 * k**4 + c2) * k * tanh(k*H) - 1 + ! = lam * k * tanh(k*H) - 1 + ! + TKH = K * H + LAM = C1 * K**4 + C2 + ! the derivative of (lam * k) + LAMPR = 5 * C1 * K**4 + C2 + ! + IF (REAL(REAL(TKH)) <= KH_LIM) THEN + ! KH is small enough + ! FV = LAM * K * SINH(K*H) - COSH(K*H) + ! DF = LAM * (K*H) * COSH(K*H) + (LAMPR - H) * SINH(K*H) + FV = LAM * K * CMPLX_SINH(TKH) - CMPLX_COSH(TKH) + DF = LAM * TKH * CMPLX_COSH(TKH) + (LAMPR-H) * CMPLX_SINH(TKH) + ELSE + ! FV = LAM * K * TANH(K*H) - 1 + ! DF = LAM * K * H + (LAMPR - H) * TANH(K*H) + ! DF = LAMPR * TANH(K*H) + LAM * K * H / (COSH(K*H) **2) + FV = LAM * K * CMPLX_TANH2(TKH) - 1 + DF = LAMPR * CMPLX_TANH2(TKH) + LAM * TKH * & + (1 - CMPLX_TANH2(TKH) ** 2.) + END IF + ! + NR_CORR = FV / DF + !/ + !/ End of NR_CORR ---------------------------------------------------- / + !/ + END FUNCTION NR_CORR + !/ ------------------------------------------------------------------- / + !/ + FUNCTION NR_ROOT(C1, C2, H, GUESS) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 19-May-2021 | + !/ +-----------------------------------+ + !/ + !/ 18-Mar-2016 : Origination. ( version 5.10 ) + !/ ( Q. Liu ) + !/ 18-Mar-2016 : Start from the Matlab code `FoxSquire.m` (provided + !/ by Prof. Vernon Squire from University of Otago) + !/ ( Q. Liu ) + !/ + !/ 19-May-2021 : Change types of few input arguments ( Q. Liu ) + !/ + ! 1. Purpose : + ! + ! The iterative procedure of the Newton-Raphson method + ! + ! 2. Method : + ! See the document of Subr. NR_CORR (Must use double precision) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Name Type Intent Description + ! ---------------------------------------------------------------- + ! C1 CMPL.(D) I C1 in FS dipsersion relations + ! See the doc. of subr. NR_CORR + ! C2 REAL (D) I C2 in FS dipsersion relations + ! H REAL (D) I water depth + ! GUESS CMPL.(D) I the first guess obtained from POLYROOTS + ! NR_ROOT CMPL.(D) O the calculated complex wave number. + ! ---------------------------------------------------------------- + ! * (D) means double precision + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! NR_CORR Func. / Newton-Raphson correction term + ! INIT_RANDOM_SEED + ! Subr. / Initialize the random seed based on + ! the system's time + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! FSDISP Subr. / Solve FS dispersion relations + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR - USE W3GDATMD, ONLY: IC5PARS -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -! COMPLEX(KDPC), INTENT(IN) :: C1, GUESS -! REAL(KDP), INTENT(IN) :: C2, H - COMPLEX(KDPC), INTENT(IN) :: C1, GUESS, C2 - REAL(KDP), INTENT(IN) :: H - COMPLEX(KDPC) :: NR_ROOT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR + USE W3GDATMD, ONLY: IC5PARS + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + ! COMPLEX(KDPC), INTENT(IN) :: C1, GUESS + ! REAL(KDP), INTENT(IN) :: C2, H + COMPLEX(KDPC), INTENT(IN) :: C1, GUESS, C2 + REAL(KDP), INTENT(IN) :: H + COMPLEX(KDPC) :: NR_ROOT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - COMPLEX(KDPC) :: K0, K1, DK - INTEGER :: ITER - REAL :: TRANVAL - REAL :: IC5MAXITER, IC5RKICK, IC5KFILTER -!/ -!/ ------------------------------------------------------------------- / -!/ + COMPLEX(KDPC) :: K0, K1, DK + INTEGER :: ITER + REAL :: TRANVAL + REAL :: IC5MAXITER, IC5RKICK, IC5KFILTER + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'NR_ROOT') + CALL STRACE (IENT, 'NR_ROOT') #endif -!/ Set parameters - IC5MAXITER = IC5PARS(6) - IC5RKICK = IC5PARS(7) ! 0: False, 1: True - IC5KFILTER = IC5PARS(8) -! - K0 = GUESS + !/ Set parameters + IC5MAXITER = IC5PARS(6) + IC5RKICK = IC5PARS(7) ! 0: False, 1: True + IC5KFILTER = IC5PARS(8) + ! + K0 = GUESS + DK = NR_CORR(K0, C1, C2, H) + K1 = K0 - DK + ITER = 0 + + IF (IC5RKICK > 0.5) CALL INIT_RANDOM_SEED() + ! + DO WHILE (ABS(DK) > ERRTOL) + K0 = K1 DK = NR_CORR(K0, C1, C2, H) K1 = K0 - DK - ITER = 0 - - IF (IC5RKICK > 0.5) CALL INIT_RANDOM_SEED() -! - DO WHILE (ABS(DK) > ERRTOL) - K0 = K1 - DK = NR_CORR(K0, C1, C2, H) - K1 = K0 - DK - ITER = ITER + 1 -! -! Random kick to avoid converging to evanescent modes -! Note: do not use RAND(1) because it alway gives a same random no. -! The built in function of RAND is not available in , use -! random_seed/number instead. -! -! Based on many tests, I found the random kick & the corridor excluded -! from imaginary axis are kind of helpful to avoid spurious solutions. -! However, it may also lead to no solutions returned, especially for -! high G and high T. -! - IF (IC5RKICK > 0.5 .AND. ABS(REAL(K1)) < IC5KFILTER) THEN -! K1 = K1 + 2*RAND(0) - CALL RANDOM_NUMBER(TRANVAL) - K1 = K1 + 2 * TRANVAL - END IF -! - IF (ITER >= IC5MAXITER) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE, 1001) 'NR_ROOT' - CALL EXTCDE(1) - END IF -! - END DO -! - NR_ROOT = K1 -! -! Formats - 1001 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & - ' Subr. ', A, ': TOO MANY ITERATIONS'/) -! -!/ -!/ End of NR_ROOT ---------------------------------------------------- / -!/ - END FUNCTION NR_ROOT -!/ ------------------------------------------------------------------- / -!/ - FUNCTION CMPLX_SINH(X) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 24-Mar-2016 | -!/ +-----------------------------------+ -!/ -!/ 24-Mar-2016 : Origination. ( version 5.10 ) -!/ ( Q. Liu ) -!/ -! 1. Purpose : -! -! For a number of compilers, the built-in function sinh, cosh and -! tanh do not support the complex inputs. So here I write an -! external one. -! -! 2. Method : -! -! sinh(x) = (e**x - e**(-x)) / 2 (The built in function exp supports -! complex input) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Name Type Intent Description -! ---------------------------------------------------------------- -! X CMPL(D) I a double-precision complex var. -! ---------------------------------------------------------------- -! * Note, this subr. will be only called by NR_CORR, -! so for simplicity, I only use double-precision complex var. -! as input. -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NR_CORR Subr. / Newton-Raphson correction term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ITER = ITER + 1 + ! + ! Random kick to avoid converging to evanescent modes + ! Note: do not use RAND(1) because it alway gives a same random no. + ! The built in function of RAND is not available in , use + ! random_seed/number instead. + ! + ! Based on many tests, I found the random kick & the corridor excluded + ! from imaginary axis are kind of helpful to avoid spurious solutions. + ! However, it may also lead to no solutions returned, especially for + ! high G and high T. + ! + IF (IC5RKICK > 0.5 .AND. ABS(REAL(K1)) < IC5KFILTER) THEN + ! K1 = K1 + 2*RAND(0) + CALL RANDOM_NUMBER(TRANVAL) + K1 = K1 + 2 * TRANVAL + END IF + ! + IF (ITER >= IC5MAXITER) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE, 1001) 'NR_ROOT' + CALL EXTCDE(1) + END IF + ! + END DO + ! + NR_ROOT = K1 + ! + ! Formats +1001 FORMAT(/' *** WAVEWATCH III ERROR IN W3SIC5MD : '/ & + ' Subr. ', A, ': TOO MANY ITERATIONS'/) + ! + !/ + !/ End of NR_ROOT ---------------------------------------------------- / + !/ + END FUNCTION NR_ROOT + !/ ------------------------------------------------------------------- / + !/ + FUNCTION CMPLX_SINH(X) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 24-Mar-2016 | + !/ +-----------------------------------+ + !/ + !/ 24-Mar-2016 : Origination. ( version 5.10 ) + !/ ( Q. Liu ) + !/ + ! 1. Purpose : + ! + ! For a number of compilers, the built-in function sinh, cosh and + ! tanh do not support the complex inputs. So here I write an + ! external one. + ! + ! 2. Method : + ! + ! sinh(x) = (e**x - e**(-x)) / 2 (The built in function exp supports + ! complex input) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Name Type Intent Description + ! ---------------------------------------------------------------- + ! X CMPL(D) I a double-precision complex var. + ! ---------------------------------------------------------------- + ! * Note, this subr. will be only called by NR_CORR, + ! so for simplicity, I only use double-precision complex var. + ! as input. + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NR_CORR Subr. / Newton-Raphson correction term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - COMPLEX(KDPC), INTENT(IN) :: X - COMPLEX(KDPC) :: CMPLX_SINH -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + COMPLEX(KDPC), INTENT(IN) :: X + COMPLEX(KDPC) :: CMPLX_SINH + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'CMPLX_SINH') + CALL STRACE (IENT, 'CMPLX_SINH') #endif -!/ - CMPLX_SINH = (EXP(X) - EXP(-X)) * 0.5 -!/ -!/ End of CMPLX_SINH ------------------------------------------------- / -!/ - END FUNCTION CMPLX_SINH -!/ ------------------------------------------------------------------- / -!/ - FUNCTION CMPLX_COSH(X) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 24-Mar-2016 | -!/ +-----------------------------------+ -!/ -!/ 24-Mar-2016 : Origination. ( version 5.10 ) -!/ ( Q. Liu ) -!/ -! 1. Purpose : -! -! For a number of compilers, the built-in function sinh, cosh and -! tanh do not support the complex inputs. So here I write an -! external one. -! -! 2. Method : -! -! cosh(x) = (e**x + e**(-x)) / 2 (The built in function exp supports -! complex input) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Name Type Intent Description -! ---------------------------------------------------------------- -! X CMPL(D) I a double-precision complex var. -! ---------------------------------------------------------------- -! * Note, this subr. will be only called by NR_CORR, -! so for simplicity, I only use double-precision complex var. -! as input. -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NR_CORR Subr. / Newton-Raphson correction term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + CMPLX_SINH = (EXP(X) - EXP(-X)) * 0.5 + !/ + !/ End of CMPLX_SINH ------------------------------------------------- / + !/ + END FUNCTION CMPLX_SINH + !/ ------------------------------------------------------------------- / + !/ + FUNCTION CMPLX_COSH(X) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 24-Mar-2016 | + !/ +-----------------------------------+ + !/ + !/ 24-Mar-2016 : Origination. ( version 5.10 ) + !/ ( Q. Liu ) + !/ + ! 1. Purpose : + ! + ! For a number of compilers, the built-in function sinh, cosh and + ! tanh do not support the complex inputs. So here I write an + ! external one. + ! + ! 2. Method : + ! + ! cosh(x) = (e**x + e**(-x)) / 2 (The built in function exp supports + ! complex input) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Name Type Intent Description + ! ---------------------------------------------------------------- + ! X CMPL(D) I a double-precision complex var. + ! ---------------------------------------------------------------- + ! * Note, this subr. will be only called by NR_CORR, + ! so for simplicity, I only use double-precision complex var. + ! as input. + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NR_CORR Subr. / Newton-Raphson correction term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - COMPLEX(KDPC), INTENT(IN) :: X - COMPLEX(KDPC) :: CMPLX_COSH -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + COMPLEX(KDPC), INTENT(IN) :: X + COMPLEX(KDPC) :: CMPLX_COSH + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'CMPLX_COSH') + CALL STRACE (IENT, 'CMPLX_COSH') #endif -!/ - CMPLX_COSH = (EXP(X) + EXP(-X)) * 0.5 -!/ -!/ End of CMPLX_COSH ------------------------------------------------- / -!/ - END FUNCTION CMPLX_COSH -!/ ------------------------------------------------------------------- / -!/ - FUNCTION CMPLX_TANH2(X) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 24-Mar-2016 | -!/ +-----------------------------------+ -!/ -!/ 24-Mar-2016 : Origination. ( version 5.10 ) -!/ ( Q. Liu ) -!/ -! 1. Purpose : -! We may encounter overflow error for the above tanh function as kh -! becomes huge. This is another version of tanh function -! -! 2. Method : -! -! See https://en.wikipedia.org/wiki/Hyperbolic_function -! tanh(x) = (exp(x) - exp(-x)) / (exp(x) + exp(-x)) -! = (1 - exp(-2x)) / (1 + exp(-2x)) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Name Type Intent Description -! ---------------------------------------------------------------- -! X CMPL(D) I a double-precision complex var. -! ---------------------------------------------------------------- -! * Note, this subr. will be only called by NR_CORR, so for -! simplicity, I only use double-precision complex var. as input. -! -! 4. Subroutines used : + !/ + CMPLX_COSH = (EXP(X) + EXP(-X)) * 0.5 + !/ + !/ End of CMPLX_COSH ------------------------------------------------- / + !/ + END FUNCTION CMPLX_COSH + !/ ------------------------------------------------------------------- / + !/ + FUNCTION CMPLX_TANH2(X) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 24-Mar-2016 | + !/ +-----------------------------------+ + !/ + !/ 24-Mar-2016 : Origination. ( version 5.10 ) + !/ ( Q. Liu ) + !/ + ! 1. Purpose : + ! We may encounter overflow error for the above tanh function as kh + ! becomes huge. This is another version of tanh function + ! + ! 2. Method : + ! + ! See https://en.wikipedia.org/wiki/Hyperbolic_function + ! tanh(x) = (exp(x) - exp(-x)) / (exp(x) + exp(-x)) + ! = (1 - exp(-2x)) / (1 + exp(-2x)) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Name Type Intent Description + ! ---------------------------------------------------------------- + ! X CMPL(D) I a double-precision complex var. + ! ---------------------------------------------------------------- + ! * Note, this subr. will be only called by NR_CORR, so for + ! simplicity, I only use double-precision complex var. as input. + ! + ! 4. Subroutines used : -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! CMPLX_SINH Func. / sinh for complex var. -! CMPLX_COSH Func. / cosh for complex var. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NR_CORR Subr. / Newton-Raphson correction term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! Calculating tanh in this way may have problems when x -> -! -inf. But in our cases x is alway >0. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! CMPLX_SINH Func. / sinh for complex var. + ! CMPLX_COSH Func. / cosh for complex var. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NR_CORR Subr. / Newton-Raphson correction term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! Calculating tanh in this way may have problems when x -> + ! -inf. But in our cases x is alway >0. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - COMPLEX(KDPC), INTENT(IN) :: X - COMPLEX(KDPC) :: CMPLX_TANH2 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + COMPLEX(KDPC), INTENT(IN) :: X + COMPLEX(KDPC) :: CMPLX_TANH2 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'CMPLX_TANH2') + CALL STRACE (IENT, 'CMPLX_TANH2') #endif -!/ - CMPLX_TANH2 = (1 - EXP(-2*X)) / (1 + EXP(-2*X)) -!/ -!/ End of CMPLX_TANH2 ------------------------------------------------ / -!/ - END FUNCTION CMPLX_TANH2 -!/ -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE INIT_RANDOM_SEED() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 24-Mar-2016 | -!/ +-----------------------------------+ -!/ -!/ 24-Mar-2016 : Origination. ( version 5.10 ) -!/ ( Q. Liu ) -!/ 24-Mar-2016 : Borrowed from Fortran Wiki ( Q. Liu ) -! -! 1. Purpose : -! -! Initialize the random seed based on the system's time. -! -! 2. Method : -! -! See http://fortranwiki.org/fortran/show/random_seed -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NR_ROOT Func. / Newton-Raphson root finding. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + CMPLX_TANH2 = (1 - EXP(-2*X)) / (1 + EXP(-2*X)) + !/ + !/ End of CMPLX_TANH2 ------------------------------------------------ / + !/ + END FUNCTION CMPLX_TANH2 + !/ + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE INIT_RANDOM_SEED() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 24-Mar-2016 | + !/ +-----------------------------------+ + !/ + !/ 24-Mar-2016 : Origination. ( version 5.10 ) + !/ ( Q. Liu ) + !/ 24-Mar-2016 : Borrowed from Fortran Wiki ( Q. Liu ) + ! + ! 1. Purpose : + ! + ! Initialize the random seed based on the system's time. + ! + ! 2. Method : + ! + ! See http://fortranwiki.org/fortran/show/random_seed + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NR_ROOT Func. / Newton-Raphson root finding. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ - INTEGER :: I, N, CLOCK - INTEGER, DIMENSION(:), ALLOCATABLE :: SEED -!/ ------------------------------------------------------------------- / + !/ + INTEGER :: I, N, CLOCK + INTEGER, DIMENSION(:), ALLOCATABLE :: SEED + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'INIT_RANDOM_SEED') + CALL STRACE (IENT, 'INIT_RANDOM_SEED') #endif -!/ - CALL RANDOM_SEED(SIZE = N) - ALLOCATE(SEED(N)) -! - CALL SYSTEM_CLOCK(COUNT=CLOCK) -! - SEED = CLOCK + 37 * (/ (I - 1, I = 1, N) /) - CALL RANDOM_SEED(PUT = SEED) -! - DEALLOCATE(SEED) -!/ -!/ End of INIT_RANDOM_SEED ------------------------------------------- / -!/ - END SUBROUTINE INIT_RANDOM_SEED -!/ -!/ ------------------------------------------------------------------- / -!/ -!/ End of module W3SIC5MD -------------------------------------------- / -!/ - END MODULE W3SIC5MD + !/ + CALL RANDOM_SEED(SIZE = N) + ALLOCATE(SEED(N)) + ! + CALL SYSTEM_CLOCK(COUNT=CLOCK) + ! + SEED = CLOCK + 37 * (/ (I - 1, I = 1, N) /) + CALL RANDOM_SEED(PUT = SEED) + ! + DEALLOCATE(SEED) + !/ + !/ End of INIT_RANDOM_SEED ------------------------------------------- / + !/ + END SUBROUTINE INIT_RANDOM_SEED + !/ + !/ ------------------------------------------------------------------- / + !/ + !/ End of module W3SIC5MD -------------------------------------------- / + !/ +END MODULE W3SIC5MD !/ ------------------------------------------------------------------- / diff --git a/model/src/w3sis1md.F90 b/model/src/w3sis1md.F90 index 263f6962d..54e1b87c0 100644 --- a/model/src/w3sis1md.F90 +++ b/model/src/w3sis1md.F90 @@ -1,207 +1,203 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SIS1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 20-Dec-2013 | -!/ +-----------------------------------+ -!/ -!/ For updates see W3SID1 documentation. -!/ -! 1. Purpose : -! -! Diffusion source term. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SIS1 Subr. Public Ice scattering term. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC :: W3SIS1 -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SIS1 (A, ICE, S) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 20-Dec-2013 | -!/ +-----------------------------------+ -!/ -!/ 16-Nov-2012 : Origination. ( version 4.14 ) -!/ (S. Zieger) -! 1. Purpose : -! Spectral reflection due to ice. -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! ICE Real I Sea ice concentration. -! S R.A. O Source term (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A ASCII Point output post-processor. -! W3EXNC Subr. N/A NetCDF Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! If ice parameter 1 is zero, no calculations are made. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! 2-D print plot of source term. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SIG2, DDEN2 - USE W3GDATMD, ONLY: DTMIN, TH, DTH, ECOS, DTMIN - USE W3GDATMD, ONLY: IS1C1, IS1C2 +MODULE W3SIS1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 20-Dec-2013 | + !/ +-----------------------------------+ + !/ + !/ For updates see W3SID1 documentation. + !/ + ! 1. Purpose : + ! + ! Diffusion source term. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SIS1 Subr. Public Ice scattering term. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC :: W3SIS1 + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SIS1 (A, ICE, S) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 20-Dec-2013 | + !/ +-----------------------------------+ + !/ + !/ 16-Nov-2012 : Origination. ( version 4.14 ) + !/ (S. Zieger) + ! 1. Purpose : + ! Spectral reflection due to ice. + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! ICE Real I Sea ice concentration. + ! S R.A. O Source term (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A ASCII Point output post-processor. + ! W3EXNC Subr. N/A NetCDF Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! If ice parameter 1 is zero, no calculations are made. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! 2-D print plot of source term. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SIG2, DDEN2 + USE W3GDATMD, ONLY: DTMIN, TH, DTH, ECOS, DTMIN + USE W3GDATMD, ONLY: IS1C1, IS1C2 #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: A(NSPEC), ICE - REAL, INTENT(OUT) :: S(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: A(NSPEC), ICE + REAL, INTENT(OUT) :: S(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IK, ITH, ITH2, IS, IS2 - REAL :: ALPHA + INTEGER :: IK, ITH, ITH2, IS, IS2 + REAL :: ALPHA #ifdef W3_T - REAL :: SOUT(NK,NTH) + REAL :: SOUT(NK,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIS1') + CALL STRACE (IENT, 'W3SIS1') #endif -! -! 0. Initializations ------------------------------------------------ * -! - S = 0. + ! + ! 0. Initializations ------------------------------------------------ * + ! + S = 0. #ifdef W3_T - SOUT = 0. + SOUT = 0. #endif -! -! Calculate scattering coefficient (linear transfer function) ---- * - ALPHA = MAX(0., IS1C1 * ICE + IS1C2) + ! + ! Calculate scattering coefficient (linear transfer function) ---- * + ALPHA = MAX(0., IS1C1 * ICE + IS1C2) #ifdef W3_T - WRITE(NDST,8000) ALPHA + WRITE(NDST,8000) ALPHA #endif -! - IF (ALPHA.GT.0. .AND. ICE.GT.0.) THEN -! 1. Calculate the derivative ---------------------------------------- * - DO IK = 1,NK - DO ITH = 1,NTH - IS = ITH+(IK-1)*NTH - IF (A(IS).GE.0.) THEN - S(IS) = S(IS) - ALPHA * A(IS) - DO ITH2 = 1,NTH - IS2 = ITH2+(IK-1)*NTH - IF (IS2.NE.IS) THEN - S(IS2) = S(IS2) + ALPHA * A(IS) / REAL(NTH-1) - END IF - END DO + ! + IF (ALPHA.GT.0. .AND. ICE.GT.0.) THEN + ! 1. Calculate the derivative ---------------------------------------- * + DO IK = 1,NK + DO ITH = 1,NTH + IS = ITH+(IK-1)*NTH + IF (A(IS).GE.0.) THEN + S(IS) = S(IS) - ALPHA * A(IS) + DO ITH2 = 1,NTH + IS2 = ITH2+(IK-1)*NTH + IF (IS2.NE.IS) THEN + S(IS2) = S(IS2) + ALPHA * A(IS) / REAL(NTH-1) END IF - END DO - END DO -! - S = S / DTMIN -! -#ifdef W3_T - DO IK = 1, NK - DO ITH = 1, NTH - IS = ITH+(IK-1)*NTH - SOUT(IK,ITH) = S(IS) - END DO - END DO -#endif -! + END DO + END IF + END DO + END DO + ! + S = S / DTMIN + ! #ifdef W3_T - CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & - 0.0, 0.001, 'Diag Sir1', ' ', 'NONAME') + DO IK = 1, NK + DO ITH = 1, NTH + IS = ITH+(IK-1)*NTH + SOUT(IK,ITH) = S(IS) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Diag Sir1', ' ', 'NONAME') #endif -! - END IF -! Formats - 8000 FORMAT (' TEST W3SIS1 : ALPHA :',E10.3) -! -!/ -!/ End of W3SIS1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SIS1 -!/ -!/ End of module W3SIS1MD -------------------------------------------- / -!/ - END MODULE W3SIS1MD - + ! + END IF + ! Formats +8000 FORMAT (' TEST W3SIS1 : ALPHA :',E10.3) + ! + !/ + !/ End of W3SIS1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SIS1 + !/ + !/ End of module W3SIS1MD -------------------------------------------- / + !/ +END MODULE W3SIS1MD diff --git a/model/src/w3sis2md.F90 b/model/src/w3sis2md.F90 index 66a5a6c79..0e01d36ca 100644 --- a/model/src/w3sis2md.F90 +++ b/model/src/w3sis2md.F90 @@ -1,1495 +1,1491 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SIS2MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | P. Nicot | -!/ | C. Sevigny | -!/ | G. Boutin | -!/ | FORTRAN 90 | -!/ | Last update : 21-Jan-2018 | -!/ +-----------------------------------+ -!/ -!/ For updates see W3SID1 documentation. -!/ -! 1. Purpose : -! -! Floe-size dependant scattering of waves in the marginal ice zone based on tabulated -! scattering coefficients for a semi-infinite ice sheet. See papers -! by Dumont et al. (JGR 2011) and Williams et al. (OM 2013) -! combined with flexural dissipation and ice break-up. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SIS2 Subr. Public Ice scattering term. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : +MODULE W3SIS2MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | P. Nicot | + !/ | C. Sevigny | + !/ | G. Boutin | + !/ | FORTRAN 90 | + !/ | Last update : 21-Jan-2018 | + !/ +-----------------------------------+ + !/ + !/ For updates see W3SID1 documentation. + !/ + ! 1. Purpose : + ! + ! Floe-size dependant scattering of waves in the marginal ice zone based on tabulated + ! scattering coefficients for a semi-infinite ice sheet. See papers + ! by Dumont et al. (JGR 2011) and Williams et al. (OM 2013) + ! combined with flexural dissipation and ice break-up. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SIS2 Subr. Public Ice scattering term. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER , PARAMETER :: NTHICK = 20, NICED = 500 - REAL, PARAMETER :: FRAGILITY = 0.9 - REAL :: THICK1 = 0.1, DTHICK = 0.25 - REAL :: ICEDMIN ! minimum floe diameter - REAL :: ICEDAVETAB(NICED) - REAL, DIMENSION(:) , ALLOCATABLE :: SIS2ALPHAS(:,:),SIS2ALPHA2(:,:) - DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: IS2EIGVEC, IS2SCATMAT - DOUBLE PRECISION , ALLOCATABLE,DIMENSION(:) :: IS2EIGVAL - PRIVATE :: SIS2ALPHAS, SIS2ALPHA2 - PUBLIC :: IS2EIGVEC, IS2EIGVAL -! - PUBLIC :: W3SIS2, INSIS2, W3RPWNICE - PRIVATE :: FINDROOTS_NR, W3FSD_DAVE, FUNCD_FVAL, FUNCD_FDERIV -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE INSIS2 -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | P. Nicot & F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 21-Jan-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Apr-2014 : Creation ( version 4.18 ) -!/ 13-Dec-2015 : Adds diagonalization of scat. matrix( version 5.10 ) -!/ 21-Jan-2018 : Implements non-isotropic example ( version 6.04 ) -!/ -! 1. Purpose : -! -! Fill tables used for scattering -! -! 2. Method : -! -! Linear interpolation -! -! 3. Parameters : -! -! See module documentation. -! -! 4. Error messages : -! -! - None. -! -! 5. Called by : -! -! - W3IOGR (initialization after reading mod_def.ww3) -! -! 6. Subroutines used : -! -! - None -! -! 7. Remarks : -! -! -! 8. Structure -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3GDATMD, ONLY: SIG, DSIP, NK, NTH, IS2PARS, & - EC2, ES2, ESC, ESIN, ECOS - USE CONSTANTS, ONLY: TPI, TPIINV - USE W3SERVMD, ONLY: DIAGONALIZE + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER , PARAMETER :: NTHICK = 20, NICED = 500 + REAL, PARAMETER :: FRAGILITY = 0.9 + REAL :: THICK1 = 0.1, DTHICK = 0.25 + REAL :: ICEDMIN ! minimum floe diameter + REAL :: ICEDAVETAB(NICED) + REAL, DIMENSION(:) , ALLOCATABLE :: SIS2ALPHAS(:,:),SIS2ALPHA2(:,:) + DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: IS2EIGVEC, IS2SCATMAT + DOUBLE PRECISION , ALLOCATABLE,DIMENSION(:) :: IS2EIGVAL + PRIVATE :: SIS2ALPHAS, SIS2ALPHA2 + PUBLIC :: IS2EIGVEC, IS2EIGVAL + ! + PUBLIC :: W3SIS2, INSIS2, W3RPWNICE + PRIVATE :: FINDROOTS_NR, W3FSD_DAVE, FUNCD_FVAL, FUNCD_FDERIV + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE INSIS2 + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | P. Nicot & F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 21-Jan-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Apr-2014 : Creation ( version 4.18 ) + !/ 13-Dec-2015 : Adds diagonalization of scat. matrix( version 5.10 ) + !/ 21-Jan-2018 : Implements non-isotropic example ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Fill tables used for scattering + ! + ! 2. Method : + ! + ! Linear interpolation + ! + ! 3. Parameters : + ! + ! See module documentation. + ! + ! 4. Error messages : + ! + ! - None. + ! + ! 5. Called by : + ! + ! - W3IOGR (initialization after reading mod_def.ww3) + ! + ! 6. Subroutines used : + ! + ! - None + ! + ! 7. Remarks : + ! + ! + ! 8. Structure + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD, ONLY: SIG, DSIP, NK, NTH, IS2PARS, & + EC2, ES2, ESC, ESIN, ECOS + USE CONSTANTS, ONLY: TPI, TPIINV + USE W3SERVMD, ONLY: DIAGONALIZE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, J, K, IND, NFTAB, NROT - REAL :: SIS1HTABLE(20), SIS1FTABLE(25) - REAL :: SIS1ALPHATABLE(NTHICK,25), X - REAL :: SIS1ALPHATABLE2(NTHICK,25) + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, J, K, IND, NFTAB, NROT + REAL :: SIS1HTABLE(20), SIS1FTABLE(25) + REAL :: SIS1ALPHATABLE(NTHICK,25), X + REAL :: SIS1ALPHATABLE2(NTHICK,25) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'SIS2ALPHATAB') + CALL STRACE (IENT, 'SIS2ALPHATAB') #endif -! -! -------------------------------------------------------------------- / -! 1. Fills array of reflection as a function of frequency and ice thickness -! - ALLOCATE(SIS2ALPHAS(NTHICK,NK)) - ALLOCATE(SIS2ALPHA2(NTHICK,NK)) -! -! Table of ice thickness for which the reflection was computed -! - SIS1HTABLE = (/ 0.1, 0.35, 0.6, 0.85, 1.1, 1.35, 1.6, 1.85, 2.1, 2.35, & - 2.6, 2.85, 3.1, 3.35, 3.6, 3.85, 4.1, 4.35, 4.6, 4.85 /) - NFTAB = 25 + ! + ! -------------------------------------------------------------------- / + ! 1. Fills array of reflection as a function of frequency and ice thickness + ! + ALLOCATE(SIS2ALPHAS(NTHICK,NK)) + ALLOCATE(SIS2ALPHA2(NTHICK,NK)) + ! + ! Table of ice thickness for which the reflection was computed + ! + SIS1HTABLE = (/ 0.1, 0.35, 0.6, 0.85, 1.1, 1.35, 1.6, 1.85, 2.1, 2.35, & + 2.6, 2.85, 3.1, 3.35, 3.6, 3.85, 4.1, 4.35, 4.6, 4.85 /) + NFTAB = 25 -! -! Table of frequencies for which the reflection was computed -! - SIS1FTABLE = (/ 0.0420, 0.04620, 0.050820, 0.0559020, 0.06149220, 0.06764142,0.0744055620000000, & - 0.0818461182, 0.09003073002, 0.099033803022, 0.1089371833242, 0.11983090, 0.13181399, & - 0.144995391, 0.15949493 , 0.175444423115458, 0.192988865427003, 0.212287751969704, & - 0.233516527, 0.256868, 0.28255499787, 0.310810497658843, 0.341891547424728, 0.376080702167200, 0.413688772383920 /) -IF (IS2PARS(18).LT.0.5) THEN + ! + ! Table of frequencies for which the reflection was computed + ! + SIS1FTABLE = (/ 0.0420, 0.04620, 0.050820, 0.0559020, 0.06149220, 0.06764142,0.0744055620000000, & + 0.0818461182, 0.09003073002, 0.099033803022, 0.1089371833242, 0.11983090, 0.13181399, & + 0.144995391, 0.15949493 , 0.175444423115458, 0.192988865427003, 0.212287751969704, & + 0.233516527, 0.256868, 0.28255499787, 0.310810497658843, 0.341891547424728, 0.376080702167200, 0.413688772383920 /) + IF (IS2PARS(18).LT.0.5) THEN SIS1ALPHATABLE = reshape((/ & - 1.78E-007, 2.21E-006, 6.57E-006, 1.31E-005, 2.28E-005, 3.60E-005, 5.23E-005, 7.19E-005, 9.60E-005, 0.0001260665, & - 0.0001621645, 0.0002032202, 0.0002483457, 0.0002987263, 0.0003571903, & - 0.0004247358, 0.00049714, 0.0005689017, 0.0006469729, 0.0007470985, & - 2.74E-007, 3.40E-006, 1.04E-005, 2.10E-005, 3.67E-005, 5.82E-005, & - 8.52E-005, 0.0001179843, 0.0001581719, 0.0002075378, & - 0.0002663323, 0.0003330095, 0.0004063158, 0.000487845, 0.0005815828, & - 0.0006893214, 0.0008061048, 0.0009252626, 0.0010565619, 0.0012218782, & - 4.16E-007, 5.21E-006, 1.62E-005, 3.32E-005, 5.91E-005, 9.56E-005, 0.0001423817, & - 0.0002001783, 0.0002716622, 0.0003599526, 0.0004656353, & - 0.0005861828, 0.0007194785, 0.0008683691, 0.0010401368, 0.0012386623, 0.0014562639, & - 0.0016819935, 0.0019335276, 0.0022507523, & - 6.25E-007, 7.95E-006, 2.50E-005, 5.28E-005, 9.71E-005, 0.0001615969, 0.0002467311, & - 0.0003540015, 0.0004891301, 0.0006588358, 0.0008648602, & - 0.0011024698, 0.0013675698, 0.0016664349, 0.0020150216, 0.0024225002, 0.0028732348, & - 0.0033437743, 0.0038725363, 0.0045480433, & - 9.32E-007, 1.21E-005, 3.91E-005, 8.60E-005, 0.000165062, 0.0002848805, 0.0004473356, & - 0.0006565411, 0.0009257279, 0.0012707025, 0.0016966237, & - 0.0021939892, 0.002754291, 0.0033926056, 0.0041466541, 0.0050385513, 0.0060311467, & - 0.0070669538, 0.0082363302, 0.0097527074, & - 1.38E-006, 1.86E-005, 6.30E-005, 0.0001464051, 0.0002950074, 0.0005287398, 0.0008535728, & - 0.0012801516, 0.0018391215, 0.0025674934, 0.0034790152,& - 0.0045539812, 0.0057742581, 0.0071757314, 0.0088467499, 0.0108382999, & - 0.0130588683, 0.0153657347, 0.0179697664, 0.0213785773, & - 2.05E-006, 2.91E-005, 0.0001064725, 0.0002646727, 0.0005601397, 0.0010380532, & - 0.0017148531, 0.0026159282, 0.0038087163, 0.0053744112, & - 0.0073439386, 0.0096752268, 0.0123295445, 0.0153861547, 0.0190373907, 0.0233881203, & - 0.0282220195, 0.0332084504, 0.0388053869, 0.0461221517, & - 3.03E-006, 4.71E-005, 0.0001918323, 0.000513363, 0.0011329164, & - 0.00214921, 0.0036015483, 0.0055437802, 0.0081104965, 0.0114597841, 0.0156453149, & - 0.0205751599, 0.0261681604, 0.0325784506, 0.040175062, 0.0491364185, & - 0.0589976693, 0.0690831851, 0.0802738154, 0.0946821772, & - 4.53E-006, 8.02E-005, 0.0003720589, 0.001067721, 0.0024215478, & - 0.0046335423, 0.0077820302, 0.0119609444, 0.0173982353, 0.0243482166, & - 0.0328666235, 0.0427569128, 0.0538584883, 0.0664227317, 0.0810452442, & - 0.0979544205, 0.1162816559, 0.1348568677, 0.1551243874, 0.1804646861, & - 6.84E-006, 0.0001465372, 0.0007768361, 0.0023492877, 0.0053624751, & - 0.0101694228, 0.0168827981, 0.0256087065, 0.0366354159, 0.0502611381, & - 0.0664627541, 0.0848577616, 0.1051596929, 0.1276991046, 0.1532607056, & - 0.1820303259, 0.2126339282, 0.2433779188, 0.276250064, 0.3157667291, & - 1.06E-005, 0.0002908265, 0.0017246725, 0.0053239059, 0.0119340853, & - 0.0220417832, 0.035687347, 0.0528302869, 0.073649217, 0.098327901, & - 0.1266340957, 0.1579155214, 0.1917144685, 0.2283923343, 0.2688390962, & - 0.3131039168, 0.359282913, 0.4052034867, 0.4533028057, 0.5090275342, & - 1.68E-005, 0.0006285069, 0.0039687874, 0.0119764661, 0.0257390989, & - 0.0456577018, 0.0713257381, 0.1021551099, 0.1379813612, 0.1787934975, & - 0.2240723105, 0.2727534775, 0.3241066558, 0.3786049119, 0.4374575502, & - 0.5006384418, 0.5653760852, 0.6286093824, 0.6937583927, 0.7684424911, & - 2.82E-005, 0.0014590465, 0.0091291531, 0.0257006983, 0.051998859, & - 0.0879406127, 0.1317806874, 0.181756664, 0.2375759087, 0.2995488732, & - 0.3668698493, 0.4374715634, 0.5099661328, 0.5855233305, 0.6668652222, & - 0.754201342, 0.8422038741, 0.925009729, 1.0096608603, 1.1112763605, & - 5.06E-005, 0.0035218608, 0.0201532593, 0.0509283911, 0.0962607638, & - 0.1553638291, 0.2233707746, 0.2967358894, 0.3765436929, 0.4650074273, & - 0.5607827923, 0.6590228472, 0.756685343, 0.8572097524, 0.9677298862,& - 1.0892101997, 1.2094355521, 1.3151711317, 1.4236588573, 1.5698199322, & - 9.99E-005, 0.0084186275, 0.0412091805, 0.0918067318, 0.1629311719, & - 0.2530998556, 0.3511295005, 0.4513397894, 0.5593550205, 0.6817564883, & - 0.815653431, 0.9499632903, 1.0782538468, 1.2090808019, 1.3588213156, & - 1.5298071338, 1.6953922745, 1.8273584757, 1.9646959304, 2.1824935098, & - 0.0002197702, 0.0188788997, 0.076522568, 0.1517352519, 0.2567566667, & - 0.3885311336, 0.5247441812, 0.6573850155, 0.8007012438, 0.9681737964, & - 1.1534672992, 1.3345908371, 1.4996817772, 1.666222509, 1.8655897771, & - 2.1018122262, 2.3245234997, 2.4819251275, 2.6492217053, 2.9647668115, & - 0.0005376597, 0.0381101752, 0.1293683129, 0.2359311434, 0.3874916537, & - 0.576671054, 0.7645781239, 0.9404856491, 1.1305780655, 1.356723506, & - 1.6068566622, 1.844140891, 2.0502598744, 2.2550088512, 2.5085040228, & - 2.815733869, 3.096422752, 3.2715199709, 3.462031842, 3.8799520309, & - 0.0014123358, 0.0685490628, 0.203577783, 0.354894301, 0.5714749709, & - 0.8380065625, 1.0957796855, 1.3307089678, 1.5810360789, 1.8762692254,& - 2.197628874, 2.4940515596, 2.7425260367, 2.9852393578, 3.2886471617, & - 3.6568112069, 3.9833963075, 4.1693103781, 4.3750188868, 4.868451483, & - 0.0037199175, 0.1126937266, 0.3066036571, 0.5225755275, 0.8226663225, & - 1.1819668289, 1.5247740065, 1.8332140124, 2.152798111, 2.5177593097, & - 2.9057350396, 3.2594397982, 3.5553142762, 3.8420910788, 4.1929464318,& - 4.6097641365, 4.975238806, 5.1850270882, 5.4153321104, 5.9516719058, & - 0.009037082, 0.1761561171, 0.4486599083, 0.747307698, 1.1406376531, & - 1.5966776005, 2.0299434584, 2.4186982894, 2.8096987013, 3.2399866752, & - 3.6899433755, 4.105747098, 4.4658248514, 4.8172532951, 5.2300901821, & - 5.7046450426, 6.1270633187, 6.3975380116, 6.6851833028, 7.2647998139, & - 0.0191118494, 0.2660897811, 0.6359174284, 1.0316197503, 1.5313672569, & - 2.0961171527, 2.6294074335, 3.1054178673, 3.5736395046, 4.0762156975, & - 4.5979660806, 5.0883063988, 5.5262800229, 5.9567260476, 6.4472029911, & - 6.9971641707, 7.4947435133, 7.841785986, 8.2023388524, 8.8466621683, & - 0.0352335589, 0.3840118688, 0.8727819679, 1.3979077636, 2.0496249898, & - 2.7683726012, 3.4325758193, 4.0133546648, 4.572769913, 5.1624475081, & - 5.7663362962, 6.3283500032, 6.8264493734, 7.3114532863, 7.8576036504, & - 8.4626783134, 9.0041860776, 9.378581111, 9.7670030485, 10.46036883, & - 0.0588123086, 0.5407217302, 1.1866725247, 1.8744101474, 2.7029832853, & - 3.586993579, 4.3802119773, 5.0573372156, 5.6991092734, 6.3694458919, & - 7.0521552001, 7.6857035561, 8.2469182713, 8.7926955021, 9.4042992778, & - 10.0780089999, 10.6798375161, 11.0993158393, 11.5359791079, 12.3054058274, & - 0.0912925253, 0.7587053794, 1.5933132286, 2.4467380656, 3.4467575836, & - 4.4845019618, 5.3910117536, 6.1520041613, 6.8749329856, 7.6395860278, & - 8.4275368684, 9.1660844666, 9.8268448897, 10.4746437466, 11.2031746957, & - 12.0078539018, 12.7326579385, 13.2484048884, 13.7868789237, 14.7164075718, & - 0.1320035456, 1.258347597, 2.2697363962, 2.8626691529, 3.4800285532, & - 4.1591450976, 4.8036627318, 5.4044338329, 6.0517560386, 6.8415021436, & - 7.8080659794, 8.9257124242, 10.1640694041, 11.5476843252, 13.1494718506, & - 14.9965430946, 16.972215146, 18.903468102, 20.9125176371, 23.3776351255 & - /) ,(/NTHICK,NFTAB/)) + 1.78E-007, 2.21E-006, 6.57E-006, 1.31E-005, 2.28E-005, 3.60E-005, 5.23E-005, 7.19E-005, 9.60E-005, 0.0001260665, & + 0.0001621645, 0.0002032202, 0.0002483457, 0.0002987263, 0.0003571903, & + 0.0004247358, 0.00049714, 0.0005689017, 0.0006469729, 0.0007470985, & + 2.74E-007, 3.40E-006, 1.04E-005, 2.10E-005, 3.67E-005, 5.82E-005, & + 8.52E-005, 0.0001179843, 0.0001581719, 0.0002075378, & + 0.0002663323, 0.0003330095, 0.0004063158, 0.000487845, 0.0005815828, & + 0.0006893214, 0.0008061048, 0.0009252626, 0.0010565619, 0.0012218782, & + 4.16E-007, 5.21E-006, 1.62E-005, 3.32E-005, 5.91E-005, 9.56E-005, 0.0001423817, & + 0.0002001783, 0.0002716622, 0.0003599526, 0.0004656353, & + 0.0005861828, 0.0007194785, 0.0008683691, 0.0010401368, 0.0012386623, 0.0014562639, & + 0.0016819935, 0.0019335276, 0.0022507523, & + 6.25E-007, 7.95E-006, 2.50E-005, 5.28E-005, 9.71E-005, 0.0001615969, 0.0002467311, & + 0.0003540015, 0.0004891301, 0.0006588358, 0.0008648602, & + 0.0011024698, 0.0013675698, 0.0016664349, 0.0020150216, 0.0024225002, 0.0028732348, & + 0.0033437743, 0.0038725363, 0.0045480433, & + 9.32E-007, 1.21E-005, 3.91E-005, 8.60E-005, 0.000165062, 0.0002848805, 0.0004473356, & + 0.0006565411, 0.0009257279, 0.0012707025, 0.0016966237, & + 0.0021939892, 0.002754291, 0.0033926056, 0.0041466541, 0.0050385513, 0.0060311467, & + 0.0070669538, 0.0082363302, 0.0097527074, & + 1.38E-006, 1.86E-005, 6.30E-005, 0.0001464051, 0.0002950074, 0.0005287398, 0.0008535728, & + 0.0012801516, 0.0018391215, 0.0025674934, 0.0034790152,& + 0.0045539812, 0.0057742581, 0.0071757314, 0.0088467499, 0.0108382999, & + 0.0130588683, 0.0153657347, 0.0179697664, 0.0213785773, & + 2.05E-006, 2.91E-005, 0.0001064725, 0.0002646727, 0.0005601397, 0.0010380532, & + 0.0017148531, 0.0026159282, 0.0038087163, 0.0053744112, & + 0.0073439386, 0.0096752268, 0.0123295445, 0.0153861547, 0.0190373907, 0.0233881203, & + 0.0282220195, 0.0332084504, 0.0388053869, 0.0461221517, & + 3.03E-006, 4.71E-005, 0.0001918323, 0.000513363, 0.0011329164, & + 0.00214921, 0.0036015483, 0.0055437802, 0.0081104965, 0.0114597841, 0.0156453149, & + 0.0205751599, 0.0261681604, 0.0325784506, 0.040175062, 0.0491364185, & + 0.0589976693, 0.0690831851, 0.0802738154, 0.0946821772, & + 4.53E-006, 8.02E-005, 0.0003720589, 0.001067721, 0.0024215478, & + 0.0046335423, 0.0077820302, 0.0119609444, 0.0173982353, 0.0243482166, & + 0.0328666235, 0.0427569128, 0.0538584883, 0.0664227317, 0.0810452442, & + 0.0979544205, 0.1162816559, 0.1348568677, 0.1551243874, 0.1804646861, & + 6.84E-006, 0.0001465372, 0.0007768361, 0.0023492877, 0.0053624751, & + 0.0101694228, 0.0168827981, 0.0256087065, 0.0366354159, 0.0502611381, & + 0.0664627541, 0.0848577616, 0.1051596929, 0.1276991046, 0.1532607056, & + 0.1820303259, 0.2126339282, 0.2433779188, 0.276250064, 0.3157667291, & + 1.06E-005, 0.0002908265, 0.0017246725, 0.0053239059, 0.0119340853, & + 0.0220417832, 0.035687347, 0.0528302869, 0.073649217, 0.098327901, & + 0.1266340957, 0.1579155214, 0.1917144685, 0.2283923343, 0.2688390962, & + 0.3131039168, 0.359282913, 0.4052034867, 0.4533028057, 0.5090275342, & + 1.68E-005, 0.0006285069, 0.0039687874, 0.0119764661, 0.0257390989, & + 0.0456577018, 0.0713257381, 0.1021551099, 0.1379813612, 0.1787934975, & + 0.2240723105, 0.2727534775, 0.3241066558, 0.3786049119, 0.4374575502, & + 0.5006384418, 0.5653760852, 0.6286093824, 0.6937583927, 0.7684424911, & + 2.82E-005, 0.0014590465, 0.0091291531, 0.0257006983, 0.051998859, & + 0.0879406127, 0.1317806874, 0.181756664, 0.2375759087, 0.2995488732, & + 0.3668698493, 0.4374715634, 0.5099661328, 0.5855233305, 0.6668652222, & + 0.754201342, 0.8422038741, 0.925009729, 1.0096608603, 1.1112763605, & + 5.06E-005, 0.0035218608, 0.0201532593, 0.0509283911, 0.0962607638, & + 0.1553638291, 0.2233707746, 0.2967358894, 0.3765436929, 0.4650074273, & + 0.5607827923, 0.6590228472, 0.756685343, 0.8572097524, 0.9677298862,& + 1.0892101997, 1.2094355521, 1.3151711317, 1.4236588573, 1.5698199322, & + 9.99E-005, 0.0084186275, 0.0412091805, 0.0918067318, 0.1629311719, & + 0.2530998556, 0.3511295005, 0.4513397894, 0.5593550205, 0.6817564883, & + 0.815653431, 0.9499632903, 1.0782538468, 1.2090808019, 1.3588213156, & + 1.5298071338, 1.6953922745, 1.8273584757, 1.9646959304, 2.1824935098, & + 0.0002197702, 0.0188788997, 0.076522568, 0.1517352519, 0.2567566667, & + 0.3885311336, 0.5247441812, 0.6573850155, 0.8007012438, 0.9681737964, & + 1.1534672992, 1.3345908371, 1.4996817772, 1.666222509, 1.8655897771, & + 2.1018122262, 2.3245234997, 2.4819251275, 2.6492217053, 2.9647668115, & + 0.0005376597, 0.0381101752, 0.1293683129, 0.2359311434, 0.3874916537, & + 0.576671054, 0.7645781239, 0.9404856491, 1.1305780655, 1.356723506, & + 1.6068566622, 1.844140891, 2.0502598744, 2.2550088512, 2.5085040228, & + 2.815733869, 3.096422752, 3.2715199709, 3.462031842, 3.8799520309, & + 0.0014123358, 0.0685490628, 0.203577783, 0.354894301, 0.5714749709, & + 0.8380065625, 1.0957796855, 1.3307089678, 1.5810360789, 1.8762692254,& + 2.197628874, 2.4940515596, 2.7425260367, 2.9852393578, 3.2886471617, & + 3.6568112069, 3.9833963075, 4.1693103781, 4.3750188868, 4.868451483, & + 0.0037199175, 0.1126937266, 0.3066036571, 0.5225755275, 0.8226663225, & + 1.1819668289, 1.5247740065, 1.8332140124, 2.152798111, 2.5177593097, & + 2.9057350396, 3.2594397982, 3.5553142762, 3.8420910788, 4.1929464318,& + 4.6097641365, 4.975238806, 5.1850270882, 5.4153321104, 5.9516719058, & + 0.009037082, 0.1761561171, 0.4486599083, 0.747307698, 1.1406376531, & + 1.5966776005, 2.0299434584, 2.4186982894, 2.8096987013, 3.2399866752, & + 3.6899433755, 4.105747098, 4.4658248514, 4.8172532951, 5.2300901821, & + 5.7046450426, 6.1270633187, 6.3975380116, 6.6851833028, 7.2647998139, & + 0.0191118494, 0.2660897811, 0.6359174284, 1.0316197503, 1.5313672569, & + 2.0961171527, 2.6294074335, 3.1054178673, 3.5736395046, 4.0762156975, & + 4.5979660806, 5.0883063988, 5.5262800229, 5.9567260476, 6.4472029911, & + 6.9971641707, 7.4947435133, 7.841785986, 8.2023388524, 8.8466621683, & + 0.0352335589, 0.3840118688, 0.8727819679, 1.3979077636, 2.0496249898, & + 2.7683726012, 3.4325758193, 4.0133546648, 4.572769913, 5.1624475081, & + 5.7663362962, 6.3283500032, 6.8264493734, 7.3114532863, 7.8576036504, & + 8.4626783134, 9.0041860776, 9.378581111, 9.7670030485, 10.46036883, & + 0.0588123086, 0.5407217302, 1.1866725247, 1.8744101474, 2.7029832853, & + 3.586993579, 4.3802119773, 5.0573372156, 5.6991092734, 6.3694458919, & + 7.0521552001, 7.6857035561, 8.2469182713, 8.7926955021, 9.4042992778, & + 10.0780089999, 10.6798375161, 11.0993158393, 11.5359791079, 12.3054058274, & + 0.0912925253, 0.7587053794, 1.5933132286, 2.4467380656, 3.4467575836, & + 4.4845019618, 5.3910117536, 6.1520041613, 6.8749329856, 7.6395860278, & + 8.4275368684, 9.1660844666, 9.8268448897, 10.4746437466, 11.2031746957, & + 12.0078539018, 12.7326579385, 13.2484048884, 13.7868789237, 14.7164075718, & + 0.1320035456, 1.258347597, 2.2697363962, 2.8626691529, 3.4800285532, & + 4.1591450976, 4.8036627318, 5.4044338329, 6.0517560386, 6.8415021436, & + 7.8080659794, 8.9257124242, 10.1640694041, 11.5476843252, 13.1494718506, & + 14.9965430946, 16.972215146, 18.903468102, 20.9125176371, 23.3776351255 & + /) ,(/NTHICK,NFTAB/)) -ELSE -! May be changed, but according to T. Williams, wim1 is okay from 0.25 only - SIS1HTABLE = (/ 0.25, 0.35, 0.6, 0.85, 1.1, 1.35, 1.6, 1.85, 2.1, 2.35, & - 2.6, 2.85, 3.1, 3.35, 3.6, 3.85, 4.1, 4.35, 4.6, 4.85 /) - SIS1ALPHATABLE = reshape((/ & - 3.80373e-06 , 6.02822e-06 , 1.12121e-05 , 2.24588e-05 , & -3.05165e-05 , 3.85142e-05 , 5.29712e-05 , 7.55453e-05 , & -1.05531e-04 , 1.38952e-04 , 1.73378e-04 , 2.09421e-04 , & -2.47299e-04 , 2.87669e-04 , 3.34304e-04 , 3.91094e-04 , & -4.57710e-04 , 5.31901e-04 , 6.14490e-04 , 7.08299e-04 , & -4.76980e-06 , 6.95433e-06 , 1.54179e-05 , 2.46138e-05 , & -3.79955e-05 , 5.96725e-05 , 8.81668e-05 , 1.20881e-04 , & -1.57364e-04 , 1.99666e-04 , 2.50723e-04 , 3.13346e-04 , & -3.89907e-04 , 4.81606e-04 , 5.88164e-04 , 7.08707e-04 , & -8.42536e-04 , 9.88622e-04 , 1.14498e-03 , 1.30931e-03 , & -5.84556e-06 , 8.58738e-06 , 2.00947e-05 , 3.18410e-05 , & -5.67385e-05 , 9.37456e-05 , 1.37304e-04 , 1.87832e-04 , & -2.49218e-04 , 3.28900e-04 , 4.31988e-04 , 5.59364e-04 , & -7.11302e-04 , 8.86736e-04 , 1.08074e-03 , 1.28808e-03 , & -1.50809e-03 , 1.74230e-03 , 1.98930e-03 , 2.24607e-03 , & -6.90305e-06 , 1.12155e-05 , 2.59514e-05 , 5.15063e-05 , & -9.18902e-05 , 1.45703e-04 , 2.18304e-04 , 3.18476e-04 , & -4.51992e-04 , 6.21037e-04 , 8.24428e-04 , 1.05881e-03 , & -1.32112e-03 , 1.60970e-03 , 1.92396e-03 , 2.26484e-03 , & -2.63577e-03 , 3.04238e-03 , 3.49116e-03 , 3.98911e-03 , & -8.46004e-06 , 1.46791e-05 , 3.69837e-05 , 8.32870e-05 , & -1.49151e-04 , 2.46175e-04 , 3.92165e-04 , 5.95871e-04 , & -8.57938e-04 , 1.17280e-03 , 1.53668e-03 , 1.95109e-03 , & -2.42048e-03 , 2.95341e-03 , 3.56468e-03 , 4.27150e-03 , & -5.08843e-03 , 6.02927e-03 , 7.11153e-03 , 8.35459e-03 , & -1.11513e-05 , 1.95090e-05 , 5.78215e-05 , 1.32267e-04 , & -2.57932e-04 , 4.61051e-04 , 7.55044e-04 , 1.14193e-03 , & -1.62478e-03 , 2.21208e-03 , 2.92101e-03 , 3.77684e-03 , & -4.80845e-03 , 6.04635e-03 , 7.52256e-03 , 9.26818e-03 , & -1.13101e-02 , 1.36712e-02 , 1.63732e-02 , 1.94360e-02 , & -1.52571e-05 , 2.78128e-05 , 9.43665e-05 , 2.30636e-04 , & -4.90057e-04 , 9.02105e-04 , 1.48012e-03 , 2.24822e-03 , & -3.24754e-03 , 4.53444e-03 , 6.16979e-03 , 8.21171e-03 , & -1.07145e-02 , 1.37253e-02 , 1.72805e-02 , 2.14091e-02 , & -2.61367e-02 , 3.14840e-02 , 3.74632e-02 , 4.40798e-02 , & -2.13731e-05 , 4.29771e-05 , 1.64050e-04 , 4.49510e-04 , & -9.84576e-04 , 1.82921e-03 , 3.06425e-03 , 4.79802e-03 , & -7.14520e-03 , 1.02139e-02 , 1.40940e-02 , 1.88529e-02 , & -2.45396e-02 , 3.11875e-02 , 3.88141e-02 , 4.74255e-02 , & -5.70233e-02 , 6.76049e-02 , 7.91611e-02 , 9.16776e-02 , & -3.17688e-05 , 7.05749e-05 , 3.13449e-04 , 9.26652e-04 , & -2.08059e-03 , 3.98338e-03 , 6.87070e-03 , 1.09528e-02 , & -1.63868e-02 , 2.32726e-02 , 3.16649e-02 , 4.15851e-02 , & -5.30293e-02 , 6.59789e-02 , 8.04085e-02 , 9.62863e-02 , & -1.13575e-01 , 1.32236e-01 , 1.52233e-01 , 1.73533e-01 , & -5.14019e-05 , 1.24975e-04 , 6.49063e-04 , 2.01553e-03 , & -4.70028e-03 , 9.17913e-03 , 1.58010e-02 , 2.47576e-02 , & -3.61186e-02 , 4.98708e-02 , 6.59568e-02 , 8.42994e-02 , & -1.04811e-01 , 1.27404e-01 , 1.51996e-01 , 1.78511e-01 , & -2.06873e-01 , 2.37011e-01 , 2.68862e-01 , 3.02365e-01 , & -9.05394e-05 , 2.44433e-04 , 1.43884e-03 , 4.66981e-03 , & -1.09558e-02 , 2.08947e-02 , 3.46681e-02 , 5.22109e-02 , & -7.33489e-02 , 9.78738e-02 , 1.25579e-01 , 1.56274e-01 , & -1.89790e-01 , 2.25973e-01 , 2.64687e-01 , 3.05808e-01 , & -3.49223e-01 , 3.94830e-01 , 4.42530e-01 , 4.92227e-01 , & -1.75074e-04 , 5.25080e-04 , 3.39573e-03 , 1.10036e-02 , & -2.46312e-02 , 4.44096e-02 , 6.99511e-02 , 1.00742e-01 , & -1.36302e-01 , 1.76219e-01 , 2.20147e-01 , 2.67802e-01 , & -3.18937e-01 , 3.73339e-01 , 4.30813e-01 , 4.91183e-01 , & -5.54282e-01 , 6.19954e-01 , 6.88048e-01 , 7.58418e-01 , & -3.74908e-04 , 1.22443e-03 , 8.17252e-03 , 2.46994e-02 , & -5.11207e-02 , 8.63422e-02 , 1.29173e-01 , 1.78641e-01 , & -2.34006e-01 , 2.94691e-01 , 3.60235e-01 , 4.30258e-01 , & -5.04426e-01 , 5.82438e-01 , 6.64019e-01 , 7.48914e-01 , & -8.36872e-01 , 9.27649e-01 , 1.02102e+00 , 1.11676e+00 , & -8.82800e-04 , 3.03043e-03 , 1.88248e-02 , 5.09125e-02 , & -9.68861e-02 , 1.54064e-01 , 2.20524e-01 , 2.94949e-01 , & -3.76394e-01 , 4.64138e-01 , 5.57588e-01 , 6.56231e-01 , & -7.59605e-01 , 8.67281e-01 , 9.78849e-01 , 1.09393e+00 , & -1.21214e+00 , 1.33315e+00 , 1.45662e+00 , 1.58224e+00 , & -2.22521e-03 , 7.51676e-03 , 3.98357e-02 , 9.57376e-02 , & -1.68983e-01 , 2.55527e-01 , 3.52939e-01 , 4.59644e-01 , & -5.74490e-01 , 6.96566e-01 , 8.25086e-01 , 9.59331e-01 , & -1.09864e+00 , 1.24238e+00 , 1.38997e+00 , 1.54085e+00 , & -1.69451e+00 , 1.85049e+00 , 2.00833e+00 , 2.16765e+00 , & -5.66833e-03 , 1.75464e-02 , 7.66453e-02 , 1.65727e-01 , & -2.74951e-01 , 3.99380e-01 , 5.36249e-01 , 6.83721e-01 , & -8.40370e-01 , 1.00497e+00 , 1.17642e+00 , 1.35368e+00 , & -1.53580e+00 , 1.72190e+00 , 1.91118e+00 , 2.10291e+00 , & -2.29645e+00 , 2.49123e+00 , 2.68675e+00 , 2.88259e+00 , & -1.36539e-02 , 3.72456e-02 , 1.35140e-01 , 2.67780e-01 , & -4.22901e-01 , 5.95111e-01 , 7.81333e-01 , 9.79307e-01 , & -1.18712e+00 , 1.40304e+00 , 1.62548e+00 , 1.85300e+00 , & -2.08433e+00 , 2.31832e+00 , 2.55400e+00 , 2.79055e+00 , & -3.02727e+00 , 3.26361e+00 , 3.49910e+00 , 3.73337e+00 , & -2.98722e-02 , 7.15314e-02 , 2.21423e-01 , 4.09271e-01 , & -6.21810e-01 , 8.53369e-01 , 1.10028e+00 , 1.35949e+00 , & -1.62829e+00 , 1.90425e+00 , 2.18522e+00 , 2.46937e+00 , & -2.75516e+00 , 3.04136e+00 , 3.32695e+00 , 3.61118e+00 , & -3.89345e+00 , 4.17331e+00 , 4.45047e+00 , 4.72471e+00 , & -5.88578e-02 , 1.25612e-01 , 3.41821e-01 , 5.98292e-01 , & -8.81793e-01 , 1.18598e+00 , 1.50596e+00 , 1.83748e+00 , & -2.17675e+00 , 2.52062e+00 , 2.86649e+00 , 3.21233e+00 , & -3.55662e+00 , 3.89823e+00 , 4.23636e+00 , 4.57049e+00 , & -4.90029e+00 , 5.22559e+00 , 5.54632e+00 , 5.86250e+00 , & -1.05468e-01 , 2.04724e-01 , 5.03158e-01 , 8.44026e-01 , & -1.21416e+00 , 1.60557e+00 , 2.01139e+00 , 2.42573e+00 , & -2.84383e+00 , 3.26205e+00 , 3.67776e+00 , 4.08914e+00 , & -4.49503e+00 , 4.89472e+00 , 5.28788e+00 , 5.67440e+00 , & -6.05432e+00 , 6.42782e+00 , 6.79514e+00 , 7.15656e+00 , & -1.74545e-01 , 3.14137e-01 , 7.13063e-01 , 1.15691e+00 , & -1.63126e+00 , 2.12499e+00 , 2.62866e+00 , 3.13493e+00 , & -3.63860e+00 , 4.13623e+00 , 4.62576e+00 , 5.10610e+00 , & -5.57680e+00 , 6.03787e+00 , 6.48955e+00 , 6.93227e+00 , & -7.36652e+00 , 7.79283e+00 , 8.21174e+00 , 8.62378e+00 , & -2.70834e-01 , 4.59350e-01 , 9.80330e-01 , 1.54856e+00 , & -2.14570e+00 , 2.75617e+00 , 3.36813e+00 , 3.97376e+00 , & -4.56847e+00 , 5.14997e+00 , 5.71743e+00 , 6.27093e+00 , & -6.81101e+00 , 7.33850e+00 , 7.85432e+00 , 8.35942e+00 , & -8.85471e+00 , 9.34106e+00 , 9.81925e+00 , 1.02900e+01 , & -3.99120e-01 , 6.46435e-01 , 1.31507e+00 , 2.03136e+00 , & -2.76957e+00 , 3.50946e+00 , 4.23832e+00 , 4.94958e+00 , & -5.64069e+00 , 6.31137e+00 , 6.96253e+00 , 7.59564e+00 , & -8.21234e+00 , 8.81426e+00 , 9.40295e+00 , 9.97983e+00 , & -1.05461e+01 , 1.11030e+01 , 1.16515e+01 , 1.21924e+01 , & -5.64538e-01 , 8.82405e-01 , 1.72870e+00 , 2.61770e+00 , & -3.51364e+00 , 4.39362e+00 , 5.24695e+00 , 6.07052e+00 , & -6.86499e+00 , 7.63269e+00 , 8.37647e+00 , 9.09919e+00 , & -9.80351e+00 , 1.04918e+01 , 1.11660e+01 , 1.18280e+01 , & -1.24792e+01 , 1.31209e+01 , 1.37543e+01 , 1.43803e+01 , & -7.72889e-01 , 1.17552e+00 , 2.23335e+00 , 3.31894e+00 , & -4.38704e+00 , 5.41672e+00 , 6.40295e+00 , 7.34788e+00 , & -8.25618e+00 , 9.13289e+00 , 9.98272e+00 , 1.08097e+01 , & -1.16174e+01 , 1.24086e+01 , 1.31857e+01 , 1.39506e+01 , & -1.47049e+01 , 1.54501e+01 , 1.61872e+01 , 1.69173e+01 & - /) ,(/NTHICK,NFTAB/)) - END IF - DO I=1,NK - DO J=1,NTHICK - IF (SIG(I)*TPIINV.LT.SIS1FTABLE(1)) THEN - SIS2ALPHAS(J,I) = SIS1ALPHATABLE(J,1) - ELSE IF (SIG(I)*TPIINV.GT. SIS1FTABLE(NFTAB)) THEN - SIS2ALPHAS(J,I) = SIS1ALPHATABLE(J,NFTAB) - ELSE - IND = 1 - DO K = 1, NFTAB-1 - IF (SIS1FTABLE(K).LT.SIG(I)*TPIINV) IND = K - END DO - X=(SIG(I)*TPIINV-SIS1FTABLE(IND))/(SIS1FTABLE(IND+1)-SIS1FTABLE(IND)) - SIS2ALPHAS(J,I)=SIS1ALPHATABLE(J,IND)*(1-X)+SIS1ALPHATABLE(J,IND+1)*X - END IF -! WRITE(998,*) I, J, SIG(I)*TPIINV,SIS1FTABLE(NFTAB), X, IND, SIS2ALPHAS(J,I),SIS1ALPHATABLE(J,NFTAB) + ELSE + ! May be changed, but according to T. Williams, wim1 is okay from 0.25 only + SIS1HTABLE = (/ 0.25, 0.35, 0.6, 0.85, 1.1, 1.35, 1.6, 1.85, 2.1, 2.35, & + 2.6, 2.85, 3.1, 3.35, 3.6, 3.85, 4.1, 4.35, 4.6, 4.85 /) + SIS1ALPHATABLE = reshape((/ & + 3.80373e-06 , 6.02822e-06 , 1.12121e-05 , 2.24588e-05 , & + 3.05165e-05 , 3.85142e-05 , 5.29712e-05 , 7.55453e-05 , & + 1.05531e-04 , 1.38952e-04 , 1.73378e-04 , 2.09421e-04 , & + 2.47299e-04 , 2.87669e-04 , 3.34304e-04 , 3.91094e-04 , & + 4.57710e-04 , 5.31901e-04 , 6.14490e-04 , 7.08299e-04 , & + 4.76980e-06 , 6.95433e-06 , 1.54179e-05 , 2.46138e-05 , & + 3.79955e-05 , 5.96725e-05 , 8.81668e-05 , 1.20881e-04 , & + 1.57364e-04 , 1.99666e-04 , 2.50723e-04 , 3.13346e-04 , & + 3.89907e-04 , 4.81606e-04 , 5.88164e-04 , 7.08707e-04 , & + 8.42536e-04 , 9.88622e-04 , 1.14498e-03 , 1.30931e-03 , & + 5.84556e-06 , 8.58738e-06 , 2.00947e-05 , 3.18410e-05 , & + 5.67385e-05 , 9.37456e-05 , 1.37304e-04 , 1.87832e-04 , & + 2.49218e-04 , 3.28900e-04 , 4.31988e-04 , 5.59364e-04 , & + 7.11302e-04 , 8.86736e-04 , 1.08074e-03 , 1.28808e-03 , & + 1.50809e-03 , 1.74230e-03 , 1.98930e-03 , 2.24607e-03 , & + 6.90305e-06 , 1.12155e-05 , 2.59514e-05 , 5.15063e-05 , & + 9.18902e-05 , 1.45703e-04 , 2.18304e-04 , 3.18476e-04 , & + 4.51992e-04 , 6.21037e-04 , 8.24428e-04 , 1.05881e-03 , & + 1.32112e-03 , 1.60970e-03 , 1.92396e-03 , 2.26484e-03 , & + 2.63577e-03 , 3.04238e-03 , 3.49116e-03 , 3.98911e-03 , & + 8.46004e-06 , 1.46791e-05 , 3.69837e-05 , 8.32870e-05 , & + 1.49151e-04 , 2.46175e-04 , 3.92165e-04 , 5.95871e-04 , & + 8.57938e-04 , 1.17280e-03 , 1.53668e-03 , 1.95109e-03 , & + 2.42048e-03 , 2.95341e-03 , 3.56468e-03 , 4.27150e-03 , & + 5.08843e-03 , 6.02927e-03 , 7.11153e-03 , 8.35459e-03 , & + 1.11513e-05 , 1.95090e-05 , 5.78215e-05 , 1.32267e-04 , & + 2.57932e-04 , 4.61051e-04 , 7.55044e-04 , 1.14193e-03 , & + 1.62478e-03 , 2.21208e-03 , 2.92101e-03 , 3.77684e-03 , & + 4.80845e-03 , 6.04635e-03 , 7.52256e-03 , 9.26818e-03 , & + 1.13101e-02 , 1.36712e-02 , 1.63732e-02 , 1.94360e-02 , & + 1.52571e-05 , 2.78128e-05 , 9.43665e-05 , 2.30636e-04 , & + 4.90057e-04 , 9.02105e-04 , 1.48012e-03 , 2.24822e-03 , & + 3.24754e-03 , 4.53444e-03 , 6.16979e-03 , 8.21171e-03 , & + 1.07145e-02 , 1.37253e-02 , 1.72805e-02 , 2.14091e-02 , & + 2.61367e-02 , 3.14840e-02 , 3.74632e-02 , 4.40798e-02 , & + 2.13731e-05 , 4.29771e-05 , 1.64050e-04 , 4.49510e-04 , & + 9.84576e-04 , 1.82921e-03 , 3.06425e-03 , 4.79802e-03 , & + 7.14520e-03 , 1.02139e-02 , 1.40940e-02 , 1.88529e-02 , & + 2.45396e-02 , 3.11875e-02 , 3.88141e-02 , 4.74255e-02 , & + 5.70233e-02 , 6.76049e-02 , 7.91611e-02 , 9.16776e-02 , & + 3.17688e-05 , 7.05749e-05 , 3.13449e-04 , 9.26652e-04 , & + 2.08059e-03 , 3.98338e-03 , 6.87070e-03 , 1.09528e-02 , & + 1.63868e-02 , 2.32726e-02 , 3.16649e-02 , 4.15851e-02 , & + 5.30293e-02 , 6.59789e-02 , 8.04085e-02 , 9.62863e-02 , & + 1.13575e-01 , 1.32236e-01 , 1.52233e-01 , 1.73533e-01 , & + 5.14019e-05 , 1.24975e-04 , 6.49063e-04 , 2.01553e-03 , & + 4.70028e-03 , 9.17913e-03 , 1.58010e-02 , 2.47576e-02 , & + 3.61186e-02 , 4.98708e-02 , 6.59568e-02 , 8.42994e-02 , & + 1.04811e-01 , 1.27404e-01 , 1.51996e-01 , 1.78511e-01 , & + 2.06873e-01 , 2.37011e-01 , 2.68862e-01 , 3.02365e-01 , & + 9.05394e-05 , 2.44433e-04 , 1.43884e-03 , 4.66981e-03 , & + 1.09558e-02 , 2.08947e-02 , 3.46681e-02 , 5.22109e-02 , & + 7.33489e-02 , 9.78738e-02 , 1.25579e-01 , 1.56274e-01 , & + 1.89790e-01 , 2.25973e-01 , 2.64687e-01 , 3.05808e-01 , & + 3.49223e-01 , 3.94830e-01 , 4.42530e-01 , 4.92227e-01 , & + 1.75074e-04 , 5.25080e-04 , 3.39573e-03 , 1.10036e-02 , & + 2.46312e-02 , 4.44096e-02 , 6.99511e-02 , 1.00742e-01 , & + 1.36302e-01 , 1.76219e-01 , 2.20147e-01 , 2.67802e-01 , & + 3.18937e-01 , 3.73339e-01 , 4.30813e-01 , 4.91183e-01 , & + 5.54282e-01 , 6.19954e-01 , 6.88048e-01 , 7.58418e-01 , & + 3.74908e-04 , 1.22443e-03 , 8.17252e-03 , 2.46994e-02 , & + 5.11207e-02 , 8.63422e-02 , 1.29173e-01 , 1.78641e-01 , & + 2.34006e-01 , 2.94691e-01 , 3.60235e-01 , 4.30258e-01 , & + 5.04426e-01 , 5.82438e-01 , 6.64019e-01 , 7.48914e-01 , & + 8.36872e-01 , 9.27649e-01 , 1.02102e+00 , 1.11676e+00 , & + 8.82800e-04 , 3.03043e-03 , 1.88248e-02 , 5.09125e-02 , & + 9.68861e-02 , 1.54064e-01 , 2.20524e-01 , 2.94949e-01 , & + 3.76394e-01 , 4.64138e-01 , 5.57588e-01 , 6.56231e-01 , & + 7.59605e-01 , 8.67281e-01 , 9.78849e-01 , 1.09393e+00 , & + 1.21214e+00 , 1.33315e+00 , 1.45662e+00 , 1.58224e+00 , & + 2.22521e-03 , 7.51676e-03 , 3.98357e-02 , 9.57376e-02 , & + 1.68983e-01 , 2.55527e-01 , 3.52939e-01 , 4.59644e-01 , & + 5.74490e-01 , 6.96566e-01 , 8.25086e-01 , 9.59331e-01 , & + 1.09864e+00 , 1.24238e+00 , 1.38997e+00 , 1.54085e+00 , & + 1.69451e+00 , 1.85049e+00 , 2.00833e+00 , 2.16765e+00 , & + 5.66833e-03 , 1.75464e-02 , 7.66453e-02 , 1.65727e-01 , & + 2.74951e-01 , 3.99380e-01 , 5.36249e-01 , 6.83721e-01 , & + 8.40370e-01 , 1.00497e+00 , 1.17642e+00 , 1.35368e+00 , & + 1.53580e+00 , 1.72190e+00 , 1.91118e+00 , 2.10291e+00 , & + 2.29645e+00 , 2.49123e+00 , 2.68675e+00 , 2.88259e+00 , & + 1.36539e-02 , 3.72456e-02 , 1.35140e-01 , 2.67780e-01 , & + 4.22901e-01 , 5.95111e-01 , 7.81333e-01 , 9.79307e-01 , & + 1.18712e+00 , 1.40304e+00 , 1.62548e+00 , 1.85300e+00 , & + 2.08433e+00 , 2.31832e+00 , 2.55400e+00 , 2.79055e+00 , & + 3.02727e+00 , 3.26361e+00 , 3.49910e+00 , 3.73337e+00 , & + 2.98722e-02 , 7.15314e-02 , 2.21423e-01 , 4.09271e-01 , & + 6.21810e-01 , 8.53369e-01 , 1.10028e+00 , 1.35949e+00 , & + 1.62829e+00 , 1.90425e+00 , 2.18522e+00 , 2.46937e+00 , & + 2.75516e+00 , 3.04136e+00 , 3.32695e+00 , 3.61118e+00 , & + 3.89345e+00 , 4.17331e+00 , 4.45047e+00 , 4.72471e+00 , & + 5.88578e-02 , 1.25612e-01 , 3.41821e-01 , 5.98292e-01 , & + 8.81793e-01 , 1.18598e+00 , 1.50596e+00 , 1.83748e+00 , & + 2.17675e+00 , 2.52062e+00 , 2.86649e+00 , 3.21233e+00 , & + 3.55662e+00 , 3.89823e+00 , 4.23636e+00 , 4.57049e+00 , & + 4.90029e+00 , 5.22559e+00 , 5.54632e+00 , 5.86250e+00 , & + 1.05468e-01 , 2.04724e-01 , 5.03158e-01 , 8.44026e-01 , & + 1.21416e+00 , 1.60557e+00 , 2.01139e+00 , 2.42573e+00 , & + 2.84383e+00 , 3.26205e+00 , 3.67776e+00 , 4.08914e+00 , & + 4.49503e+00 , 4.89472e+00 , 5.28788e+00 , 5.67440e+00 , & + 6.05432e+00 , 6.42782e+00 , 6.79514e+00 , 7.15656e+00 , & + 1.74545e-01 , 3.14137e-01 , 7.13063e-01 , 1.15691e+00 , & + 1.63126e+00 , 2.12499e+00 , 2.62866e+00 , 3.13493e+00 , & + 3.63860e+00 , 4.13623e+00 , 4.62576e+00 , 5.10610e+00 , & + 5.57680e+00 , 6.03787e+00 , 6.48955e+00 , 6.93227e+00 , & + 7.36652e+00 , 7.79283e+00 , 8.21174e+00 , 8.62378e+00 , & + 2.70834e-01 , 4.59350e-01 , 9.80330e-01 , 1.54856e+00 , & + 2.14570e+00 , 2.75617e+00 , 3.36813e+00 , 3.97376e+00 , & + 4.56847e+00 , 5.14997e+00 , 5.71743e+00 , 6.27093e+00 , & + 6.81101e+00 , 7.33850e+00 , 7.85432e+00 , 8.35942e+00 , & + 8.85471e+00 , 9.34106e+00 , 9.81925e+00 , 1.02900e+01 , & + 3.99120e-01 , 6.46435e-01 , 1.31507e+00 , 2.03136e+00 , & + 2.76957e+00 , 3.50946e+00 , 4.23832e+00 , 4.94958e+00 , & + 5.64069e+00 , 6.31137e+00 , 6.96253e+00 , 7.59564e+00 , & + 8.21234e+00 , 8.81426e+00 , 9.40295e+00 , 9.97983e+00 , & + 1.05461e+01 , 1.11030e+01 , 1.16515e+01 , 1.21924e+01 , & + 5.64538e-01 , 8.82405e-01 , 1.72870e+00 , 2.61770e+00 , & + 3.51364e+00 , 4.39362e+00 , 5.24695e+00 , 6.07052e+00 , & + 6.86499e+00 , 7.63269e+00 , 8.37647e+00 , 9.09919e+00 , & + 9.80351e+00 , 1.04918e+01 , 1.11660e+01 , 1.18280e+01 , & + 1.24792e+01 , 1.31209e+01 , 1.37543e+01 , 1.43803e+01 , & + 7.72889e-01 , 1.17552e+00 , 2.23335e+00 , 3.31894e+00 , & + 4.38704e+00 , 5.41672e+00 , 6.40295e+00 , 7.34788e+00 , & + 8.25618e+00 , 9.13289e+00 , 9.98272e+00 , 1.08097e+01 , & + 1.16174e+01 , 1.24086e+01 , 1.31857e+01 , 1.39506e+01 , & + 1.47049e+01 , 1.54501e+01 , 1.61872e+01 , 1.69173e+01 & + /) ,(/NTHICK,NFTAB/)) + END IF + DO I=1,NK + DO J=1,NTHICK + IF (SIG(I)*TPIINV.LT.SIS1FTABLE(1)) THEN + SIS2ALPHAS(J,I) = SIS1ALPHATABLE(J,1) + ELSE IF (SIG(I)*TPIINV.GT. SIS1FTABLE(NFTAB)) THEN + SIS2ALPHAS(J,I) = SIS1ALPHATABLE(J,NFTAB) + ELSE + IND = 1 + DO K = 1, NFTAB-1 + IF (SIS1FTABLE(K).LT.SIG(I)*TPIINV) IND = K END DO - END DO -! + X=(SIG(I)*TPIINV-SIS1FTABLE(IND))/(SIS1FTABLE(IND+1)-SIS1FTABLE(IND)) + SIS2ALPHAS(J,I)=SIS1ALPHATABLE(J,IND)*(1-X)+SIS1ALPHATABLE(J,IND+1)*X + END IF + ! WRITE(998,*) I, J, SIG(I)*TPIINV,SIS1FTABLE(NFTAB), X, IND, SIS2ALPHAS(J,I),SIS1ALPHATABLE(J,NFTAB) + END DO + END DO + ! -! - SIS1ALPHATABLE2 = reshape((/ & -0.000001693306, 0.000001694535, 0.000001709985, 0.000001718371, 0.000001718689, & -0.000001715291, 0.000001711765, 0.000001709562, 0.000001708573, 0.000001708047, & -0.000001707216, 0.000001705508, 0.000001702489, 0.000001697757, 0.000001690926, & -0.000001681715, 0.000001670039, 0.000001655970, 0.000001639540, 0.000001620666, & -0.000002345944, 0.000002373942, 0.000002352788, 0.000002336058, 0.000002340157, & -0.000002361578, 0.000002389818, 0.000002414910, 0.000002430787, 0.000002435510, & -0.000002429671, 0.000002414451, 0.000002390516, 0.000002358094, 0.000002317788, & -0.000002271221, 0.000002220674, 0.000002167641, 0.000002111561, 0.000002051905, & -0.000003223057, 0.000003267049, 0.000003224977, 0.000003204685, 0.000003222416, & -0.000003261346, 0.000003299552, 0.000003321243, 0.000003319410, 0.000003293875, & -0.000003247777, 0.000003184750, 0.000003107742, 0.000003019246, 0.000002922032, & -0.000002819435, 0.000002714739, 0.000002609966, 0.000002505271, 0.000002400993, & -0.000004390462, 0.000004433012, 0.000004403102, 0.000004405652, 0.000004433604, & -0.000004455373, 0.000004447247, 0.000004400212, 0.000004316137, 0.000004201667, & -0.000004064075, 0.000003909816, 0.000003744650, 0.000003573915, 0.000003402281, & -0.000003233187, 0.000003068613, 0.000002909686, 0.000002757781, 0.000002614371, & -0.000005932907, 0.000005957402, 0.000005982223, 0.000006017129, 0.000006011597, & -0.000005931834, 0.000005775734, 0.000005561133, 0.000005309860, 0.000005038831, & -0.000004758982, 0.000004477929, 0.000004202314, 0.000003938073, 0.000003689194, & -0.000003456677, 0.000003239230, 0.000003035853, 0.000002848219, 0.000002677864, & -0.000007962387, 0.000007965182, 0.000008068497, 0.000008081519, 0.000007918056, & -0.000007586175, 0.000007143591, 0.000006652694, 0.000006157274, 0.000005680186, & -0.000005230854, 0.000004813199, 0.000004429817, 0.000004082375, 0.000003770294, & -0.000003490093, 0.000003236746, 0.000003006720, 0.000002800108, 0.000002616762, & -0.000010630745, 0.000010631503, 0.000010754695, 0.000010555056, 0.000009993969, & -0.000009206201, 0.000008341755, 0.000007500204, 0.000006728370, 0.000006039825, & -0.000005432987, 0.000004901489, 0.000004438118, 0.000004035401, 0.000003685333, & -0.000003379621, 0.000003110711, 0.000002873062, 0.000002663457, 0.000002478682, & -0.000014147503, 0.000014179502, 0.000014068022, 0.000013255509, 0.000011955952, & -0.000010517681, 0.000009161184, 0.000007970672, 0.000006956434, 0.000006102184, & -0.000005386202, 0.000004787198, 0.000004285040, 0.000003861250, 0.000003500220, & -0.000003190247, 0.000002923212, 0.000002692594, 0.000002491216, 0.000002312444, & -0.000018803447, 0.000018843681, 0.000017888469, 0.000015846997, 0.000013469781, & -0.000011291688, 0.000009484334, 0.000008030183, 0.000006862685, 0.000005921675, & -0.000005161810, 0.000004546889, 0.000004045234, 0.000003629478, 0.000003278778, & -0.000002980118, 0.000002726294, 0.000002510734, 0.000002323048, 0.000002154027, & -0.000024999293, 0.000024767047, 0.000021866213, 0.000017907275, 0.000014286707, & -0.000011453674, 0.000009339677, 0.000007754652, 0.000006540404, 0.000005593636, & -0.000004848620, 0.000004258144, 0.000003783667, 0.000003393700, 0.000003065741, & -0.000002787091, 0.000002551635, 0.000002353114, 0.000002179924, 0.000002022176, & -0.000033276027, 0.000031812088, 0.000025413911, 0.000019081783, 0.000014360014, & -0.000011113013, 0.000008878307, 0.000007287536, 0.000006111165, 0.000005216269, & -0.000004523259, 0.000003978625, 0.000003542278, 0.000003183888, 0.000002882748, & -0.000002627060, 0.000002410531, 0.000002226889, 0.000002066156, 0.000001920400, & -0.000044336466, 0.000039340417, 0.000027862847, 0.000019248910, 0.000013854771, & -0.000010491793, 0.000008293280, 0.000006775936, 0.000005680752, 0.000004862822, & -0.000004234499, 0.000003739067, 0.000003338786, 0.000003008719, 0.000002732485, & -0.000002498817, 0.000002299071, 0.000002126144, 0.000001974716, 0.000001841606, & -0.000059030780, 0.000046157443, 0.000028771759, 0.000018580063, 0.000013047269, & -0.000009812168, 0.000007739586, 0.000006322672, 0.000005313968, 0.000004570787, & -0.000004001034, 0.000003546046, 0.000003172357, 0.000002862735, 0.000002606289, & -0.000002391441, 0.000002205202, 0.000002038837, 0.000001893870, 0.000001773775, & -0.000078242681, 0.000050872198, 0.000028192943, 0.000017445281, 0.000012194039, & -0.000009215299, 0.000007293336, 0.000005968851, 0.000005030058, 0.000004344187, & -0.000003817214, 0.000003389423, 0.000003031921, 0.000002735020, 0.000002492733, & -0.000002292508, 0.000002116550, 0.000001954358, 0.000001814339, 0.000001706341, & -0.000102553944, 0.000052628108, 0.000026654291, 0.000016235235, 0.000011448810, & -0.000008738110, 0.000006951009, 0.000005700488, 0.000004811678, 0.000004163305, & -0.000003662892, 0.000003251855, 0.000002905015, 0.000002617308, 0.000002385271, & -0.000002195475, 0.000002027393, 0.000001869747, 0.000001734845, 0.000001635748, & -0.000131528803, 0.000051648919, 0.000024847696, 0.000015214276, 0.000010847813, & -0.000008336757, 0.000006656766, 0.000005471182, 0.000004622914, 0.000003999733, & -0.000003516266, 0.000003119051, 0.000002785020, 0.000002508708, 0.000002285704, & -0.000002102851, 0.000001941273, 0.000001790864, 0.000001662390, 0.000001566768, & -0.000162640998, 0.000049040647, 0.000023269162, 0.000014460197, 0.000010345625, & -0.000007943173, 0.000006352063, 0.000005238097, 0.000004434583, 0.000003834908, & -0.000003367217, 0.000002987629, 0.000002673539, 0.000002414062, 0.000002200682, & -0.000002022244, 0.000001866432, 0.000001726382, 0.000001605605, 0.000001507441, & -0.000190593962, 0.000046018523, 0.000022036249, 0.000013884361, 0.000009879926, & -0.000007534440, 0.000006029990, 0.000004998037, 0.000004246561, 0.000003673278, & -0.000003223583, 0.000002865466, 0.000002575963, 0.000002336404, 0.000002132787, & -0.000001957123, 0.000001806342, 0.000001677844, 0.000001564855, 0.000001460377, & -0.000208777708, 0.000043254960, 0.000020953050, 0.000013327645, 0.000009433705, & -0.000007161759, 0.000005746018, 0.000004790209, 0.000004085598, 0.000003536085, & -0.000003102390, 0.000002762488, 0.000002493229, 0.000002269788, 0.000002073862, & -0.000001900259, 0.000001753553, 0.000001634519, 0.000001527844, 0.000001418102, & -0.000213643676, 0.000040801760, 0.000019820045, 0.000012719494, 0.000009042103, & -0.000006888517, 0.000005551025, 0.000004645394, 0.000003968666, 0.000003433279, & -0.000003008733, 0.000002677964, 0.000002418184, 0.000002202481, 0.000002011120, & -0.000001840100, 0.000001696853, 0.000001583290, 0.000001480832, 0.000001370962, & -0.000208202335, 0.000038538552, 0.000018774435, 0.000012168047, 0.000008723021, & -0.000006681551, 0.000005399851, 0.000004523630, 0.000003863808, 0.000003339344, & -0.000002922742, 0.000002598268, 0.000002343776, 0.000002132781, 0.000001945837, & -0.000001779030, 0.000001639702, 0.000001529688, 0.000001430567, 0.000001324016, & -0.000198860865, 0.000036596393, 0.000018094381, 0.000011782298, 0.000008423914, & -0.000006432368, 0.000005194822, 0.000004356699, 0.000003726655, 0.000003224518, & -0.000002825485, 0.000002515982, 0.000002274472, 0.000002073961, 0.000001894595, & -0.000001733161, 0.000001598541, 0.000001493403, 0.000001398055, 0.000001292778, & -0.000188086831, 0.000035005432, 0.000017449034, 0.000011378985, 0.000008128438, & -0.000006206255, 0.000005018705, 0.000004216819, 0.000003612753, 0.000003129463, & -0.000002744757, 0.000002446723, 0.000002214548, 0.000002021421, 0.000001847651, & -0.000001690537, 0.000001559668, 0.000001458051, 0.000001365539, 0.000001262003, & -0.000176803511, 0.000033479878, 0.000016713766, 0.000010962586, 0.000007891418, & -0.000006057305, 0.000004907363, 0.000004122061, 0.000003528516, 0.000003054204, & -0.000002676573, 0.000002382977, 0.000002153342, 0.000001962633, 0.000001792438, & -0.000001639642, 0.000001512208, 0.000001412404, 0.000001322051, 0.000001223019, & -0.000157501278, 0.000031061181, 0.000013781133, 0.000009601049, 0.000007947466, & -0.000006760411, 0.000005655833, 0.000004680347, 0.000003892156, 0.000003277589, & -0.000002790517, 0.000002392986, 0.000002067558, 0.000001808761, 0.000001609460, & -0.000001454171, 0.000001323348, 0.000001206327, 0.000001111024, 0.000001045460, & -0.000007782240, 0.000002755736, 0.000000005024, 0.000000101927, 0.000088216814, & -0.009792270789, 0.030135654570, 0.009293514348, 0.001549599316, 0.000298014001, & -0.000055965309, 0.000007063938, 0.000000637549, 0.000000072256, 0.000000017854, & -0.000000008901, 0.000000004238, 0.000000001169, 0.000000000492, 0.000000001113 /), & -(/NTHICK,NFTAB/)) + ! + SIS1ALPHATABLE2 = reshape((/ & + 0.000001693306, 0.000001694535, 0.000001709985, 0.000001718371, 0.000001718689, & + 0.000001715291, 0.000001711765, 0.000001709562, 0.000001708573, 0.000001708047, & + 0.000001707216, 0.000001705508, 0.000001702489, 0.000001697757, 0.000001690926, & + 0.000001681715, 0.000001670039, 0.000001655970, 0.000001639540, 0.000001620666, & + 0.000002345944, 0.000002373942, 0.000002352788, 0.000002336058, 0.000002340157, & + 0.000002361578, 0.000002389818, 0.000002414910, 0.000002430787, 0.000002435510, & + 0.000002429671, 0.000002414451, 0.000002390516, 0.000002358094, 0.000002317788, & + 0.000002271221, 0.000002220674, 0.000002167641, 0.000002111561, 0.000002051905, & + 0.000003223057, 0.000003267049, 0.000003224977, 0.000003204685, 0.000003222416, & + 0.000003261346, 0.000003299552, 0.000003321243, 0.000003319410, 0.000003293875, & + 0.000003247777, 0.000003184750, 0.000003107742, 0.000003019246, 0.000002922032, & + 0.000002819435, 0.000002714739, 0.000002609966, 0.000002505271, 0.000002400993, & + 0.000004390462, 0.000004433012, 0.000004403102, 0.000004405652, 0.000004433604, & + 0.000004455373, 0.000004447247, 0.000004400212, 0.000004316137, 0.000004201667, & + 0.000004064075, 0.000003909816, 0.000003744650, 0.000003573915, 0.000003402281, & + 0.000003233187, 0.000003068613, 0.000002909686, 0.000002757781, 0.000002614371, & + 0.000005932907, 0.000005957402, 0.000005982223, 0.000006017129, 0.000006011597, & + 0.000005931834, 0.000005775734, 0.000005561133, 0.000005309860, 0.000005038831, & + 0.000004758982, 0.000004477929, 0.000004202314, 0.000003938073, 0.000003689194, & + 0.000003456677, 0.000003239230, 0.000003035853, 0.000002848219, 0.000002677864, & + 0.000007962387, 0.000007965182, 0.000008068497, 0.000008081519, 0.000007918056, & + 0.000007586175, 0.000007143591, 0.000006652694, 0.000006157274, 0.000005680186, & + 0.000005230854, 0.000004813199, 0.000004429817, 0.000004082375, 0.000003770294, & + 0.000003490093, 0.000003236746, 0.000003006720, 0.000002800108, 0.000002616762, & + 0.000010630745, 0.000010631503, 0.000010754695, 0.000010555056, 0.000009993969, & + 0.000009206201, 0.000008341755, 0.000007500204, 0.000006728370, 0.000006039825, & + 0.000005432987, 0.000004901489, 0.000004438118, 0.000004035401, 0.000003685333, & + 0.000003379621, 0.000003110711, 0.000002873062, 0.000002663457, 0.000002478682, & + 0.000014147503, 0.000014179502, 0.000014068022, 0.000013255509, 0.000011955952, & + 0.000010517681, 0.000009161184, 0.000007970672, 0.000006956434, 0.000006102184, & + 0.000005386202, 0.000004787198, 0.000004285040, 0.000003861250, 0.000003500220, & + 0.000003190247, 0.000002923212, 0.000002692594, 0.000002491216, 0.000002312444, & + 0.000018803447, 0.000018843681, 0.000017888469, 0.000015846997, 0.000013469781, & + 0.000011291688, 0.000009484334, 0.000008030183, 0.000006862685, 0.000005921675, & + 0.000005161810, 0.000004546889, 0.000004045234, 0.000003629478, 0.000003278778, & + 0.000002980118, 0.000002726294, 0.000002510734, 0.000002323048, 0.000002154027, & + 0.000024999293, 0.000024767047, 0.000021866213, 0.000017907275, 0.000014286707, & + 0.000011453674, 0.000009339677, 0.000007754652, 0.000006540404, 0.000005593636, & + 0.000004848620, 0.000004258144, 0.000003783667, 0.000003393700, 0.000003065741, & + 0.000002787091, 0.000002551635, 0.000002353114, 0.000002179924, 0.000002022176, & + 0.000033276027, 0.000031812088, 0.000025413911, 0.000019081783, 0.000014360014, & + 0.000011113013, 0.000008878307, 0.000007287536, 0.000006111165, 0.000005216269, & + 0.000004523259, 0.000003978625, 0.000003542278, 0.000003183888, 0.000002882748, & + 0.000002627060, 0.000002410531, 0.000002226889, 0.000002066156, 0.000001920400, & + 0.000044336466, 0.000039340417, 0.000027862847, 0.000019248910, 0.000013854771, & + 0.000010491793, 0.000008293280, 0.000006775936, 0.000005680752, 0.000004862822, & + 0.000004234499, 0.000003739067, 0.000003338786, 0.000003008719, 0.000002732485, & + 0.000002498817, 0.000002299071, 0.000002126144, 0.000001974716, 0.000001841606, & + 0.000059030780, 0.000046157443, 0.000028771759, 0.000018580063, 0.000013047269, & + 0.000009812168, 0.000007739586, 0.000006322672, 0.000005313968, 0.000004570787, & + 0.000004001034, 0.000003546046, 0.000003172357, 0.000002862735, 0.000002606289, & + 0.000002391441, 0.000002205202, 0.000002038837, 0.000001893870, 0.000001773775, & + 0.000078242681, 0.000050872198, 0.000028192943, 0.000017445281, 0.000012194039, & + 0.000009215299, 0.000007293336, 0.000005968851, 0.000005030058, 0.000004344187, & + 0.000003817214, 0.000003389423, 0.000003031921, 0.000002735020, 0.000002492733, & + 0.000002292508, 0.000002116550, 0.000001954358, 0.000001814339, 0.000001706341, & + 0.000102553944, 0.000052628108, 0.000026654291, 0.000016235235, 0.000011448810, & + 0.000008738110, 0.000006951009, 0.000005700488, 0.000004811678, 0.000004163305, & + 0.000003662892, 0.000003251855, 0.000002905015, 0.000002617308, 0.000002385271, & + 0.000002195475, 0.000002027393, 0.000001869747, 0.000001734845, 0.000001635748, & + 0.000131528803, 0.000051648919, 0.000024847696, 0.000015214276, 0.000010847813, & + 0.000008336757, 0.000006656766, 0.000005471182, 0.000004622914, 0.000003999733, & + 0.000003516266, 0.000003119051, 0.000002785020, 0.000002508708, 0.000002285704, & + 0.000002102851, 0.000001941273, 0.000001790864, 0.000001662390, 0.000001566768, & + 0.000162640998, 0.000049040647, 0.000023269162, 0.000014460197, 0.000010345625, & + 0.000007943173, 0.000006352063, 0.000005238097, 0.000004434583, 0.000003834908, & + 0.000003367217, 0.000002987629, 0.000002673539, 0.000002414062, 0.000002200682, & + 0.000002022244, 0.000001866432, 0.000001726382, 0.000001605605, 0.000001507441, & + 0.000190593962, 0.000046018523, 0.000022036249, 0.000013884361, 0.000009879926, & + 0.000007534440, 0.000006029990, 0.000004998037, 0.000004246561, 0.000003673278, & + 0.000003223583, 0.000002865466, 0.000002575963, 0.000002336404, 0.000002132787, & + 0.000001957123, 0.000001806342, 0.000001677844, 0.000001564855, 0.000001460377, & + 0.000208777708, 0.000043254960, 0.000020953050, 0.000013327645, 0.000009433705, & + 0.000007161759, 0.000005746018, 0.000004790209, 0.000004085598, 0.000003536085, & + 0.000003102390, 0.000002762488, 0.000002493229, 0.000002269788, 0.000002073862, & + 0.000001900259, 0.000001753553, 0.000001634519, 0.000001527844, 0.000001418102, & + 0.000213643676, 0.000040801760, 0.000019820045, 0.000012719494, 0.000009042103, & + 0.000006888517, 0.000005551025, 0.000004645394, 0.000003968666, 0.000003433279, & + 0.000003008733, 0.000002677964, 0.000002418184, 0.000002202481, 0.000002011120, & + 0.000001840100, 0.000001696853, 0.000001583290, 0.000001480832, 0.000001370962, & + 0.000208202335, 0.000038538552, 0.000018774435, 0.000012168047, 0.000008723021, & + 0.000006681551, 0.000005399851, 0.000004523630, 0.000003863808, 0.000003339344, & + 0.000002922742, 0.000002598268, 0.000002343776, 0.000002132781, 0.000001945837, & + 0.000001779030, 0.000001639702, 0.000001529688, 0.000001430567, 0.000001324016, & + 0.000198860865, 0.000036596393, 0.000018094381, 0.000011782298, 0.000008423914, & + 0.000006432368, 0.000005194822, 0.000004356699, 0.000003726655, 0.000003224518, & + 0.000002825485, 0.000002515982, 0.000002274472, 0.000002073961, 0.000001894595, & + 0.000001733161, 0.000001598541, 0.000001493403, 0.000001398055, 0.000001292778, & + 0.000188086831, 0.000035005432, 0.000017449034, 0.000011378985, 0.000008128438, & + 0.000006206255, 0.000005018705, 0.000004216819, 0.000003612753, 0.000003129463, & + 0.000002744757, 0.000002446723, 0.000002214548, 0.000002021421, 0.000001847651, & + 0.000001690537, 0.000001559668, 0.000001458051, 0.000001365539, 0.000001262003, & + 0.000176803511, 0.000033479878, 0.000016713766, 0.000010962586, 0.000007891418, & + 0.000006057305, 0.000004907363, 0.000004122061, 0.000003528516, 0.000003054204, & + 0.000002676573, 0.000002382977, 0.000002153342, 0.000001962633, 0.000001792438, & + 0.000001639642, 0.000001512208, 0.000001412404, 0.000001322051, 0.000001223019, & + 0.000157501278, 0.000031061181, 0.000013781133, 0.000009601049, 0.000007947466, & + 0.000006760411, 0.000005655833, 0.000004680347, 0.000003892156, 0.000003277589, & + 0.000002790517, 0.000002392986, 0.000002067558, 0.000001808761, 0.000001609460, & + 0.000001454171, 0.000001323348, 0.000001206327, 0.000001111024, 0.000001045460, & + 0.000007782240, 0.000002755736, 0.000000005024, 0.000000101927, 0.000088216814, & + 0.009792270789, 0.030135654570, 0.009293514348, 0.001549599316, 0.000298014001, & + 0.000055965309, 0.000007063938, 0.000000637549, 0.000000072256, 0.000000017854, & + 0.000000008901, 0.000000004238, 0.000000001169, 0.000000000492, 0.000000001113 /), & + (/NTHICK,NFTAB/)) - DO I=1,NK - DO J=1,NTHICK - IF (SIG(I)*TPIINV.LT. SIS1FTABLE(1)) THEN - SIS2ALPHA2(J,I) = SIS1ALPHATABLE2(J,1) - ELSE IF (SIG(I)*TPIINV.GT. SIS1FTABLE(NFTAB)) THEN - SIS2ALPHA2(J,I) = SIS1ALPHATABLE2(J,NFTAB) - ELSE - IND = 1 - DO K = 1, NFTAB-1 - IF (SIS1FTABLE(K).LT.SIG(I)*TPIINV) IND = K - END DO - X=(SIG(I)*TPIINV-SIS1FTABLE(IND))/(SIS1FTABLE(IND+1)-SIS1FTABLE(IND)) - SIS2ALPHA2(J,I)=SIS1ALPHATABLE2(J,IND)*(1-X)+SIS1ALPHATABLE2(J,IND+1)*X - END IF - END DO - END DO -! -! -------------------------------------------------------------------- / -! 2. Fills array of ICEDMAX to ICEDAVE -! - DO I=1,NICED - ICEDAVETAB(I) = W3FSD_DAVE(IS2PARS(9),REAL(I),IS2PARS(8)) - ENDDO -! -! -------------------------------------------------------------------- / -! 2. Defines and diagonalizes the scattering matrix -! - ALLOCATE(IS2SCATMAT(NTH,NTH)) - ALLOCATE(IS2EIGVEC(NTH,NTH)) - ALLOCATE(IS2EIGVAL(NTH)) -! - DO I=1,NTH - DO J=1,NTH -! This is for isotropic back-scatter -! IS2SCATMAT(I,J)=-1./DBLE(NTH) -! Other example that looks like figure 12 in Masson & LeBlond - IS2SCATMAT(I,J)=-1./DBLE(NTH)*(2.*EC2(ABS(I-J)+1)**2+0.8*ECOS(ABS(I-J)+1)**3) - IF (ECOS(ABS(I-J)+1).LT.0.001) IS2SCATMAT(I,J)=IS2SCATMAT(I,J)-1./DBLE(NTH)*0.8*ES2(ABS(I-J)+1) + DO I=1,NK + DO J=1,NTHICK + IF (SIG(I)*TPIINV.LT. SIS1FTABLE(1)) THEN + SIS2ALPHA2(J,I) = SIS1ALPHATABLE2(J,1) + ELSE IF (SIG(I)*TPIINV.GT. SIS1FTABLE(NFTAB)) THEN + SIS2ALPHA2(J,I) = SIS1ALPHATABLE2(J,NFTAB) + ELSE + IND = 1 + DO K = 1, NFTAB-1 + IF (SIS1FTABLE(K).LT.SIG(I)*TPIINV) IND = K END DO -!WRITE(997,'(36G16.8)') IS2SCATMAT(I,:) -! Now removes sum from diagonal to enforce energy conservation ... - IS2SCATMAT(I,I)=IS2SCATMAT(I,I)-SUM(IS2SCATMAT(I,1:NTH)) - END DO - CALL DIAGONALIZE(IS2SCATMAT,IS2EIGVAL,IS2EIGVEC,nrot) - DO I=1,NTH - IS2EIGVAL(I)=MAX(0.d0,IS2EIGVAL(I)) -!WRITE(994,'(36G16.8)') I,IS2EIGVAL(I) -!WRITE(995,'(36G16.8)') IS2EIGVEC(I,:) -!WRITE(996,'(36G16.8)') IS2SCATMAT(I,:) - END DO -!CLOSE(994) -!CLOSE(995) -!CLOSE(996) -!CLOSE(997) + X=(SIG(I)*TPIINV-SIS1FTABLE(IND))/(SIS1FTABLE(IND+1)-SIS1FTABLE(IND)) + SIS2ALPHA2(J,I)=SIS1ALPHATABLE2(J,IND)*(1-X)+SIS1ALPHATABLE2(J,IND+1)*X + END IF + END DO + END DO + ! + ! -------------------------------------------------------------------- / + ! 2. Fills array of ICEDMAX to ICEDAVE + ! + DO I=1,NICED + ICEDAVETAB(I) = W3FSD_DAVE(IS2PARS(9),REAL(I),IS2PARS(8)) + ENDDO + ! + ! -------------------------------------------------------------------- / + ! 2. Defines and diagonalizes the scattering matrix + ! + ALLOCATE(IS2SCATMAT(NTH,NTH)) + ALLOCATE(IS2EIGVEC(NTH,NTH)) + ALLOCATE(IS2EIGVAL(NTH)) + ! + DO I=1,NTH + DO J=1,NTH + ! This is for isotropic back-scatter + ! IS2SCATMAT(I,J)=-1./DBLE(NTH) + ! Other example that looks like figure 12 in Masson & LeBlond + IS2SCATMAT(I,J)=-1./DBLE(NTH)*(2.*EC2(ABS(I-J)+1)**2+0.8*ECOS(ABS(I-J)+1)**3) + IF (ECOS(ABS(I-J)+1).LT.0.001) IS2SCATMAT(I,J)=IS2SCATMAT(I,J)-1./DBLE(NTH)*0.8*ES2(ABS(I-J)+1) + END DO + !WRITE(997,'(36G16.8)') IS2SCATMAT(I,:) + ! Now removes sum from diagonal to enforce energy conservation ... + IS2SCATMAT(I,I)=IS2SCATMAT(I,I)-SUM(IS2SCATMAT(I,1:NTH)) + END DO + CALL DIAGONALIZE(IS2SCATMAT,IS2EIGVAL,IS2EIGVEC,nrot) + DO I=1,NTH + IS2EIGVAL(I)=MAX(0.d0,IS2EIGVAL(I)) + !WRITE(994,'(36G16.8)') I,IS2EIGVAL(I) + !WRITE(995,'(36G16.8)') IS2EIGVEC(I,:) + !WRITE(996,'(36G16.8)') IS2SCATMAT(I,:) + END DO + !CLOSE(994) + !CLOSE(995) + !CLOSE(996) + !CLOSE(997) - RETURN -!/ -!/ End of INSIS2 ----------------------------------------------------- / -!/ - END SUBROUTINE INSIS2 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SIS2 (A, DEPTH, CICE, ICEH, ICEF, ICEDMAX, IX, IY, & - S, D, DISSIP, WN, CG, WN_R, CG_ICE, R) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | P. Nicot & F. Ardhuin & G. Boutin | -!/ | FORTRAN 90 | -!/ | Last update : 04-May-2016 | -!/ +-----------------------------------+ -!/ -!/ 16-Mar-2014 : Origination. ( version 4.18 ) -!/ 19-Sep-2014 : Correcting group speed factor ( version 5.03 ) -!/ 20-Sep-2014 : Adding back-scattered energy ( version 5.03 ) -!/ 27-Aug-2015 : Add breaking criterion, WIM1d ( version 5.05 ) -!/ (ref. Williams, 2012) -!/ 02-Nov-2015 : Integration of strain over bandwidth( version 5.05 ) -!/ 13-Jan-2016 : Changed initialization of ICEDMAX ( version 5.10 ) -!/ 06-Feb-2016 : Added IICEHMIN and creep dissipation( version 5.10 ) -!/ 10-Mar-2016 : Added depth and call to Liu disp. ( version 5.10 ) -!/ 02-May-2016 : Call to Liu disp moved to w3srce ( version 5.10 ) -! -! 1. Purpose : -! Wave scattering in the MIZ, adapted from Dumont et al. -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! This scattering routine allows the estimation of the maximum floe -! size and an estimate of the creep-induced dissipation. -! For the scattering, it is based on the normal incidence results of -! Kohout and Meylan which are provided in a table. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! DEPTH Real I Water depth -! CICE Real I Sea ice concentration -! ICEH Real I ice thickness -! ICEF Real I/O Maximum floe size (updated) -! ICEDMAX Real I Maximum floe size -! IX,IY Int I Not used -! S R.A. O Source term (1-D version) -! D R.A. O Diagonal part of scattering (1-D version) -! DISSIP R.A. O Diagonal dissipation term (1-D version) -! WN R.A. I Wave number -! CG R.A. I Group speed -! WN_R R.A. I Wave number in ice -! CG_ICE R.A. I Group speed in ice -! R R.A. O Ratio of energy to wave energy without ice -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A ASCII Point output post-processor. -! W3EXNC Subr. N/A NetCDF Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! If ice concentration is zero, no calculations are made. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! 2-D print plot of source term. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: NDSE - USE CONSTANTS, ONLY: TPIINV, PI, TPI, GRAV, DWAT - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SIG2, DDEN, IS2PARS, XFR, & - IICEHMIN,IICESMOOTH + RETURN + !/ + !/ End of INSIS2 ----------------------------------------------------- / + !/ + END SUBROUTINE INSIS2 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SIS2 (A, DEPTH, CICE, ICEH, ICEF, ICEDMAX, IX, IY, & + S, D, DISSIP, WN, CG, WN_R, CG_ICE, R) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | P. Nicot & F. Ardhuin & G. Boutin | + !/ | FORTRAN 90 | + !/ | Last update : 04-May-2016 | + !/ +-----------------------------------+ + !/ + !/ 16-Mar-2014 : Origination. ( version 4.18 ) + !/ 19-Sep-2014 : Correcting group speed factor ( version 5.03 ) + !/ 20-Sep-2014 : Adding back-scattered energy ( version 5.03 ) + !/ 27-Aug-2015 : Add breaking criterion, WIM1d ( version 5.05 ) + !/ (ref. Williams, 2012) + !/ 02-Nov-2015 : Integration of strain over bandwidth( version 5.05 ) + !/ 13-Jan-2016 : Changed initialization of ICEDMAX ( version 5.10 ) + !/ 06-Feb-2016 : Added IICEHMIN and creep dissipation( version 5.10 ) + !/ 10-Mar-2016 : Added depth and call to Liu disp. ( version 5.10 ) + !/ 02-May-2016 : Call to Liu disp moved to w3srce ( version 5.10 ) + ! + ! 1. Purpose : + ! Wave scattering in the MIZ, adapted from Dumont et al. + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! This scattering routine allows the estimation of the maximum floe + ! size and an estimate of the creep-induced dissipation. + ! For the scattering, it is based on the normal incidence results of + ! Kohout and Meylan which are provided in a table. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! DEPTH Real I Water depth + ! CICE Real I Sea ice concentration + ! ICEH Real I ice thickness + ! ICEF Real I/O Maximum floe size (updated) + ! ICEDMAX Real I Maximum floe size + ! IX,IY Int I Not used + ! S R.A. O Source term (1-D version) + ! D R.A. O Diagonal part of scattering (1-D version) + ! DISSIP R.A. O Diagonal dissipation term (1-D version) + ! WN R.A. I Wave number + ! CG R.A. I Group speed + ! WN_R R.A. I Wave number in ice + ! CG_ICE R.A. I Group speed in ice + ! R R.A. O Ratio of energy to wave energy without ice + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A ASCII Point output post-processor. + ! W3EXNC Subr. N/A NetCDF Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! If ice concentration is zero, no calculations are made. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! 2-D print plot of source term. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: NDSE + USE CONSTANTS, ONLY: TPIINV, PI, TPI, GRAV, DWAT + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SIG2, DDEN, IS2PARS, XFR, & + IICEHMIN,IICESMOOTH #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif - USE W3DISPMD -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: A(NSPEC), DEPTH, CICE, ICEH, ICEDMAX - INTEGER, INTENT(IN) :: IX, IY - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC), DISSIP(NSPEC), R(NK) - REAL, INTENT(INOUT) :: ICEF - REAL, INTENT(IN) :: WN(NK), CG(NK), WN_R(NK), CG_ICE(NK) + USE W3DISPMD + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: A(NSPEC), DEPTH, CICE, ICEH, ICEDMAX + INTEGER, INTENT(IN) :: IX, IY + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC), DISSIP(NSPEC), R(NK) + REAL, INTENT(INOUT) :: ICEF + REAL, INTENT(IN) :: WN(NK), CG(NK), WN_R(NK), CG_ICE(NK) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IK, IKP1, IKM1, ITH, ITH2, IS, IS2, IND1, IND2 - REAL :: W - INTEGER :: IKBREAK, NSUM - LOGICAL :: BRK_CRIT_W(NK), BRK_CRIT - REAL :: ALPHA, STRAIN_C, WAMP(NK), D_FLEX_FAIL, & - SMOOTHD, TAU_D, S_D(NK), ALPHA_D, DELTA_D,B_COLE, & - DMAX, S_ATT, FACTOR, BETA - REAL :: ICEDAVE(NK), CURVTOSTRAIN, CREEPFAC, MP2, B, ICEF_CREEP - REAL :: SUMALLDIR, SUMA, SUME, CURVSPEC(NK), ESPEC(NK),STRAIN - REAL, PARAMETER :: YOUNG = 5.49E+9 ! Young modulus - REAL, PARAMETER :: POISSON = 0.3 ! Poisson Ratio - REAL :: SIGMA_C - REAL, PARAMETER :: DENS = 1025.0 ! ice density - REAL :: GAMMA_TOY - REAL, DIMENSION(NK) :: WN_I, WN_RP, WSQ, WLG, WLG_I, CG_I, & - CURV, CGRATIO, CG_EFF, DUMMY, ALPHA_DISP + INTEGER :: IK, IKP1, IKM1, ITH, ITH2, IS, IS2, IND1, IND2 + REAL :: W + INTEGER :: IKBREAK, NSUM + LOGICAL :: BRK_CRIT_W(NK), BRK_CRIT + REAL :: ALPHA, STRAIN_C, WAMP(NK), D_FLEX_FAIL, & + SMOOTHD, TAU_D, S_D(NK), ALPHA_D, DELTA_D,B_COLE, & + DMAX, S_ATT, FACTOR, BETA + REAL :: ICEDAVE(NK), CURVTOSTRAIN, CREEPFAC, MP2, B, ICEF_CREEP + REAL :: SUMALLDIR, SUMA, SUME, CURVSPEC(NK), ESPEC(NK),STRAIN + REAL, PARAMETER :: YOUNG = 5.49E+9 ! Young modulus + REAL, PARAMETER :: POISSON = 0.3 ! Poisson Ratio + REAL :: SIGMA_C + REAL, PARAMETER :: DENS = 1025.0 ! ice density + REAL :: GAMMA_TOY + REAL, DIMENSION(NK) :: WN_I, WN_RP, WSQ, WLG, WLG_I, CG_I, & + CURV, CGRATIO, CG_EFF, DUMMY, ALPHA_DISP #ifdef W3_T - REAL :: SOUT(NK,NTH) + REAL :: SOUT(NK,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIS1') + CALL STRACE (IENT, 'W3SIS1') #endif -! -! 0. Initializations ------------------------------------------------ * -! - S = 0. - D = 0. - DISSIP = 0. - DUMMY = WN - WN_I = 0. - WN_RP = 0. - CG_I = 0. - CG_EFF = 0. - SIGMA_C = IS2PARS(19) - MP2=(1-POISSON**2) - GAMMA_TOY = 2 + log(0.9)/log(2.) - ! Variables from Cole et al. 1995 - ALPHA_D=0.54 - B_COLE=1.205E-9 * EXP(IS2PARS(24)*1.60218E-19/(1.38064852e-23*268.15)) - TAU_D=B_COLE/0.07 - S_D=LOG(SIG(1:NK)*TAU_D) - DELTA_D=IS2PARS(21) - IF (IS2PARS(9).GT.0) ICEDMIN = IS2PARS(9) - IF (IS2PARS(12).GT.0) THEN - B=IS2PARS(12) -! 2 is the ratio of to (Hrms/2)^4 for a Rayleigh distribution -! 0.375 is the average of cos^4 -! 0.4 is 2/5 - CREEPFAC = -2*(0.25/(IS2PARS(15)+2))*0.375*B*ICEH**(IS2PARS(15)+2) & - *(YOUNG/(2*B*MP2))**(IS2PARS(15)+1)/(DWAT*GRAV) - ELSE - CREEPFAC=1. - ENDIF + ! + ! 0. Initializations ------------------------------------------------ * + ! + S = 0. + D = 0. + DISSIP = 0. + DUMMY = WN + WN_I = 0. + WN_RP = 0. + CG_I = 0. + CG_EFF = 0. + SIGMA_C = IS2PARS(19) + MP2=(1-POISSON**2) + GAMMA_TOY = 2 + log(0.9)/log(2.) + ! Variables from Cole et al. 1995 + ALPHA_D=0.54 + B_COLE=1.205E-9 * EXP(IS2PARS(24)*1.60218E-19/(1.38064852e-23*268.15)) + TAU_D=B_COLE/0.07 + S_D=LOG(SIG(1:NK)*TAU_D) + DELTA_D=IS2PARS(21) + IF (IS2PARS(9).GT.0) ICEDMIN = IS2PARS(9) + IF (IS2PARS(12).GT.0) THEN + B=IS2PARS(12) + ! 2 is the ratio of to (Hrms/2)^4 for a Rayleigh distribution + ! 0.375 is the average of cos^4 + ! 0.4 is 2/5 + CREEPFAC = -2*(0.25/(IS2PARS(15)+2))*0.375*B*ICEH**(IS2PARS(15)+2) & + *(YOUNG/(2*B*MP2))**(IS2PARS(15)+1)/(DWAT*GRAV) + ELSE + CREEPFAC=1. + ENDIF - WLG = TPI/WN - ICEF_CREEP=ICEF - DMAX = ICEF - BRK_CRIT = .FALSE. - NSUM = NINT(0.3/(XFR-1.)) -! - STRAIN_C = SIGMA_C*MP2/YOUNG + WLG = TPI/WN + ICEF_CREEP=ICEF + DMAX = ICEF + BRK_CRIT = .FALSE. + NSUM = NINT(0.3/(XFR-1.)) + ! + STRAIN_C = SIGMA_C*MP2/YOUNG -! Minimum floe size that can break - D_FLEX_FAIL = 0.5* ( (PI**4*YOUNG*ICEH**3)/( 48*DENS*GRAV*MP2 ) )**.25 -! Estimates mean floe diameter from max floe diameter - IF (DMAX.GT.NICED) THEN - ICEDAVE=DMAX + ! Minimum floe size that can break + D_FLEX_FAIL = 0.5* ( (PI**4*YOUNG*ICEH**3)/( 48*DENS*GRAV*MP2 ) )**.25 + ! Estimates mean floe diameter from max floe diameter + IF (DMAX.GT.NICED) THEN + ICEDAVE=DMAX + ELSE + IF (IS2PARS(9).GT.0) THEN + ICEDAVE= ICEDAVETAB(MAX(1,NINT(DMAX))) ELSE - IF (IS2PARS(9).GT.0) THEN - ICEDAVE= ICEDAVETAB(MAX(1,NINT(DMAX))) - ELSE - DO IK=1,NK - IF (IS2PARS(14)*(TPI/WN_R(IK)).LT.DMAX) THEN - ICEDAVE(IK)=W3FSD_DAVE( (TPI/WN_R(IK))*IS2PARS(14),DMAX,IS2PARS(8)) - ELSE - ICEDAVE(IK)=DMAX - ENDIF - END DO + DO IK=1,NK + IF (IS2PARS(14)*(TPI/WN_R(IK)).LT.DMAX) THEN + ICEDAVE(IK)=W3FSD_DAVE( (TPI/WN_R(IK))*IS2PARS(14),DMAX,IS2PARS(8)) + ELSE + ICEDAVE(IK)=DMAX ENDIF - ENDIF -! + END DO + ENDIF + ENDIF + ! #ifdef W3_T - SOUT = 0. + SOUT = 0. #endif -! - IF (CICE .GT. 0) THEN -! -! 1. Calculate wavelength, Robinson-Palmer dispersion relation -! (should be tabulated ) -! Warning: it only applies to unbroken ice. -! - IF (IS2PARS(6).GT.0.5) THEN - CALL W3RPWNICE(ICEH,WN_I,WN_RP,CG_I) - ELSE - WN_I = WN_R - CG_I = CG_ICE - WN_RP=WN*0. - END IF -! - WLG_I = TPI/WN_I ! Ice wavelength - WSQ = (WLG/WLG_I) -! - IF (IS2PARS(16).GT.0.5) THEN - CGRATIO(:)=CG_I(:)/CG(:) - ELSE - CGRATIO(:)=1 - END IF -! -! 2. gets reflection coefficient from table -! - IND1 = 1+FLOOR((ICEH-THICK1)/DTHICK) - IND2 = IND1+1 -! defines weight for interpolation of ice thickness - W = (ICEH-THICK1)/DTHICK - (IND1-1) - IF (IND1.LT.1) THEN - IND1 = 1 - W = 0 - ELSE IF (IND2.GT.NTHICK) THEN - IND2 = NTHICK - IND1 = NTHICK - W = 0 + ! + IF (CICE .GT. 0) THEN + ! + ! 1. Calculate wavelength, Robinson-Palmer dispersion relation + ! (should be tabulated ) + ! Warning: it only applies to unbroken ice. + ! + IF (IS2PARS(6).GT.0.5) THEN + CALL W3RPWNICE(ICEH,WN_I,WN_RP,CG_I) + ELSE + WN_I = WN_R + CG_I = CG_ICE + WN_RP=WN*0. + END IF + ! + WLG_I = TPI/WN_I ! Ice wavelength + WSQ = (WLG/WLG_I) + ! + IF (IS2PARS(16).GT.0.5) THEN + CGRATIO(:)=CG_I(:)/CG(:) + ELSE + CGRATIO(:)=1 + END IF + ! + ! 2. gets reflection coefficient from table + ! + IND1 = 1+FLOOR((ICEH-THICK1)/DTHICK) + IND2 = IND1+1 + ! defines weight for interpolation of ice thickness + W = (ICEH-THICK1)/DTHICK - (IND1-1) + IF (IND1.LT.1) THEN + IND1 = 1 + W = 0 + ELSE IF (IND2.GT.NTHICK) THEN + IND2 = NTHICK + IND1 = NTHICK + W = 0 + END IF + ! + DO IK = 1,NK + ! + ! Spatial decay scale taken from table. This corresponds the the values shown + ! in Dumont et al. (JGR 2011, fig 3). + ! + CG_EFF(IK) = CICE*CG_I(IK) + (1-CICE)*CG(IK) + + ! Note by FA: dissipation should be done by ICx not by ISx + ! the RP damping is thus defined by an optional IS2PARS(7), which is 0 by default + ALPHA = -1.*( (SIS2ALPHAS(IND1,IK)*(1-W)+SIS2ALPHAS(IND2,IK)*W)/ICEDAVE(IK) & + +2.*IS2PARS(7)*WN_RP(IK) )*CICE + ! + ! Additional scattering for pack ice defined by IS2PARS(4:5) (see Squire et al. GRL 2009) + ! + ALPHA = IS2PARS(1) * ALPHA -2.*IS2PARS(4)*EXP(-1.*IS2PARS(5)/SIG(IK)) + IF (IS2PARS(11).GT.0) THEN + IF (CICE.LT.0.2) ALPHA = 0. + IF (CICE.GT.0.8) ALPHA = 0. + IF (CICE.GE.0.2.AND.CICE.LE.0.8) ALPHA = ALPHA*(CICE-0.2)*(0.8-CICE) + END IF + ! + ! time decay + ! + BETA = ALPHA * CICE * CG_EFF(IK) + ! + ! 3. attenuation due to scattering for all spectral components + ! with added backscattering for energy conservation ( if IS2PARS(2).EQ.1) + ! + SUMALLDIR= 0. + SUMA = 0. + CURVTOSTRAIN = (0.25*MAX(ICEH,IICEHMIN)**2) + DO ITH = 1,NTH + IS = ITH+(IK-1)*NTH + D(IS) = BETA + S(IS) = BETA * A(IS) + SUMALLDIR = SUMALLDIR + S(IS) + SUMA = SUMA + A(IS) + END DO ! loop over directions + ! + ! R is the ratio of energy (including bending of ice) to wave energy without ice + ! Wadhams 1973 eq. 34, warning, his ice thickness is 2*h + ! Warning : R uses DMAX=ICEF, even if IS2DUPDATE=F + ! + IF (IICESMOOTH) THEN + IF (IS2PARS(14)*WLG_I(IK).LT.DMAX) THEN + SMOOTHD=TANH((DMAX-IS2PARS(14)*WLG_I(IK))/(DMAX*IS2PARS(13))) + ELSE + SMOOTHD=0. END IF -! - DO IK = 1,NK -! -! Spatial decay scale taken from table. This corresponds the the values shown -! in Dumont et al. (JGR 2011, fig 3). -! - CG_EFF(IK) = CICE*CG_I(IK) + (1-CICE)*CG(IK) + ELSE + SMOOTHD=1. + END IF + ! + R(IK) =1+IS2PARS(16)*SMOOTHD*4*YOUNG*ICEH**3*(PI/WLG_I(IK))**4/(3*DWAT*GRAV*MP2) + ! + ! Converting action to surface elevation variance SUME with units m^2 + ! + SUME = SUMA*DDEN(IK) / CG(IK) / (R(IK)*CGRATIO(IK)) + ! + ! CURVSPEC is the curvature variance = elevation variance * k^4 + ! + CURVSPEC (IK) = SUME * (2*PI/ WLG_I(IK))**4 + ESPEC (IK) = SUME + SUMALLDIR = SUMALLDIR / REAL(NTH) + ! + ! Adds the scattered energy isotropically to conserve the energy + ! This may not be a very good scheme numerically. Another possible + ! approach is the matrix inversion used for bottom scattering (w3sbs1md.ftn) + ! + S(1+(IK-1)*NTH:IK*NTH)=S(1+(IK-1)*NTH:IK*NTH)-SUMALLDIR*IS2PARS(2) + END DO ! loop over wavenumbers IK + ! + ! 4. update of floe size + ! + IF (IS2PARS(10).LT.0.5) THEN ! resets max floe size to the last forcing or initial value + DMAX = ICEDMAX + ICEF = ICEDMAX + END IF + ! + DO IK = 1, NK + ! CURV is the variance of the curvature integrated over a finite bandwidth + CURV(IK) = SUM(CURVSPEC(MAX(1,IK-NSUM):MIN(NK,IK+NSUM))) + ! Now converts curvature variance to strain variance + END DO ! end of loop on IK + ! + ! If IS2PARS(3)=IS2BREAK is set to true in ww3_grid, then activates ice break-up + ! + IF (IS2PARS(3).GT.0.5) THEN + IKBREAK=0 + DO IK = 1, NK + STRAIN = CURV(IK)*CURVTOSTRAIN + IF (D_FLEX_FAIL .LT. DMAX) THEN + ! Note that Williams et al. used IS2PARS(17)=SQRT(2), Here our default is 3.6 + WAMP(IK)= IS2PARS(17)*SQRT(STRAIN) + ! + IF (IS2PARS(9).EQ.0) THEN + ICEDMIN=(TPI/WN_R(IK))*IS2PARS(14) + END IF + BRK_CRIT_W(IK) = WAMP(IK) .GT. STRAIN_C .AND. WLG_I(IK)/2 .GT. ICEDMIN .AND. WLG_I(IK)/2 .LT. DMAX & + .AND. WLG_I(IK)/2 .GT. D_FLEX_FAIL -! Note by FA: dissipation should be done by ICx not by ISx -! the RP damping is thus defined by an optional IS2PARS(7), which is 0 by default - ALPHA = -1.*( (SIS2ALPHAS(IND1,IK)*(1-W)+SIS2ALPHAS(IND2,IK)*W)/ICEDAVE(IK) & - +2.*IS2PARS(7)*WN_RP(IK) )*CICE -! -! Additional scattering for pack ice defined by IS2PARS(4:5) (see Squire et al. GRL 2009) -! - ALPHA = IS2PARS(1) * ALPHA -2.*IS2PARS(4)*EXP(-1.*IS2PARS(5)/SIG(IK)) - IF (IS2PARS(11).GT.0) THEN - IF (CICE.LT.0.2) ALPHA = 0. - IF (CICE.GT.0.8) ALPHA = 0. - IF (CICE.GE.0.2.AND.CICE.LE.0.8) ALPHA = ALPHA*(CICE-0.2)*(0.8-CICE) - END IF -! -! time decay -! - BETA = ALPHA * CICE * CG_EFF(IK) -! -! 3. attenuation due to scattering for all spectral components -! with added backscattering for energy conservation ( if IS2PARS(2).EQ.1) -! - SUMALLDIR= 0. - SUMA = 0. - CURVTOSTRAIN = (0.25*MAX(ICEH,IICEHMIN)**2) - DO ITH = 1,NTH - IS = ITH+(IK-1)*NTH - D(IS) = BETA - S(IS) = BETA * A(IS) - SUMALLDIR = SUMALLDIR + S(IS) - SUMA = SUMA + A(IS) - END DO ! loop over directions -! -! R is the ratio of energy (including bending of ice) to wave energy without ice -! Wadhams 1973 eq. 34, warning, his ice thickness is 2*h -! Warning : R uses DMAX=ICEF, even if IS2DUPDATE=F -! - IF (IICESMOOTH) THEN - IF (IS2PARS(14)*WLG_I(IK).LT.DMAX) THEN - SMOOTHD=TANH((DMAX-IS2PARS(14)*WLG_I(IK))/(DMAX*IS2PARS(13))) - ELSE - SMOOTHD=0. - END IF - ELSE - SMOOTHD=1. + ! + IF (BRK_CRIT_W(IK)) THEN + IKBREAK=IK + BRK_CRIT = .TRUE. END IF -! - R(IK) =1+IS2PARS(16)*SMOOTHD*4*YOUNG*ICEH**3*(PI/WLG_I(IK))**4/(3*DWAT*GRAV*MP2) -! -! Converting action to surface elevation variance SUME with units m^2 -! - SUME = SUMA*DDEN(IK) / CG(IK) / (R(IK)*CGRATIO(IK)) -! -! CURVSPEC is the curvature variance = elevation variance * k^4 -! - CURVSPEC (IK) = SUME * (2*PI/ WLG_I(IK))**4 - ESPEC (IK) = SUME - SUMALLDIR = SUMALLDIR / REAL(NTH) -! -! Adds the scattered energy isotropically to conserve the energy -! This may not be a very good scheme numerically. Another possible -! approach is the matrix inversion used for bottom scattering (w3sbs1md.ftn) -! - S(1+(IK-1)*NTH:IK*NTH)=S(1+(IK-1)*NTH:IK*NTH)-SUMALLDIR*IS2PARS(2) - END DO ! loop over wavenumbers IK -! -! 4. update of floe size -! - IF (IS2PARS(10).LT.0.5) THEN ! resets max floe size to the last forcing or initial value - DMAX = ICEDMAX - ICEF = ICEDMAX END IF -! - DO IK = 1, NK -! CURV is the variance of the curvature integrated over a finite bandwidth - CURV(IK) = SUM(CURVSPEC(MAX(1,IK-NSUM):MIN(NK,IK+NSUM))) -! Now converts curvature variance to strain variance - END DO ! end of loop on IK -! -! If IS2PARS(3)=IS2BREAK is set to true in ww3_grid, then activates ice break-up -! - IF (IS2PARS(3).GT.0.5) THEN - IKBREAK=0 - DO IK = 1, NK - STRAIN = CURV(IK)*CURVTOSTRAIN - IF (D_FLEX_FAIL .LT. DMAX) THEN -! Note that Williams et al. used IS2PARS(17)=SQRT(2), Here our default is 3.6 - WAMP(IK)= IS2PARS(17)*SQRT(STRAIN) -! - IF (IS2PARS(9).EQ.0) THEN - ICEDMIN=(TPI/WN_R(IK))*IS2PARS(14) - END IF - BRK_CRIT_W(IK) = WAMP(IK) .GT. STRAIN_C .AND. WLG_I(IK)/2 .GT. ICEDMIN .AND. WLG_I(IK)/2 .LT. DMAX & - .AND. WLG_I(IK)/2 .GT. D_FLEX_FAIL - -! - IF (BRK_CRIT_W(IK)) THEN - IKBREAK=IK - BRK_CRIT = .TRUE. - END IF - END IF - END DO ! end of loop on IK -! -! 4.b Correction for bias introduced by the finite bandwidth sum .. . -! - IF (BRK_CRIT) THEN - DO IK=MAX(IKBREAK-NSUM,1),IKBREAK,1 -! Modified by F.A. on Jan. 31, 2017: uses the maximum of CURVSPEC instead of CURV. -! this is better for very narrow spectra. - IF (CURVSPEC(IK).GE.CURVSPEC(IKBREAK).AND.DMAX.GE.(WLG_I(IK)/2)) THEN + END DO ! end of loop on IK + ! + ! 4.b Correction for bias introduced by the finite bandwidth sum .. . + ! + IF (BRK_CRIT) THEN + DO IK=MAX(IKBREAK-NSUM,1),IKBREAK,1 + ! Modified by F.A. on Jan. 31, 2017: uses the maximum of CURVSPEC instead of CURV. + ! this is better for very narrow spectra. + IF (CURVSPEC(IK).GE.CURVSPEC(IKBREAK).AND.DMAX.GE.(WLG_I(IK)/2)) THEN IKBREAK = IK - END IF - END DO -! - DMAX = WLG_I(IKBREAK)/2 -! -! Uses a weighting by CURVSPEC to have a continuous shift of DMAX .. -! - IKP1=MIN(IKBREAK+1,NK) - IKM1=MAX(IKBREAK-1,1) - IF (BRK_CRIT_W(IKP1).AND.BRK_CRIT_W(IKM1)) THEN - DMAX = (WLG_I(IKBREAK)*CURVSPEC(IKBREAK) & - +WLG_I(IKP1)*CURVSPEC(IKP1)+WLG_I(IKM1)*CURVSPEC(IKM1)) & - /(2.*(CURVSPEC(IKBREAK)+CURVSPEC(IKM1)+CURVSPEC(IKP1))) - END IF -! - ICEF = DMAX END IF - END IF !end of test (IS2PARS(3).GT.0.5) -! -! 5. inelastic or anelastic dissipation -! - IF (IS2PARS(12).GT.0) THEN - DO IK = 1, NK -! -! The TANH((DMAX-D*WLG_I(IK))/DMAX*C) -! is an ad hoc factor that goes to zero for WLG << DMAX and 1 for WLG >> DMAX -! this should probably be adjusted. -! - IF (IS2PARS(14)*WLG_I(IK).LT.DMAX) THEN - SMOOTHD=TANH((DMAX-IS2PARS(14)*WLG_I(IK))/(DMAX*IS2PARS(13))) - IF (IS2PARS(23).LE.0.5) THEN ! this is the inelastic option - DISSIP(1+(IK-1)*NTH:IK*NTH)=CREEPFAC*4*CURV(IK) & - *((2*PI)/WLG_I(IK))**(IS2PARS(15)+1) & - /(CGRATIO(IK)**1*R(IK)**2) & - *SMOOTHD - ELSE ! this is the inelastic option - DISSIP(1+(IK-1)*NTH:IK*NTH) =-4*4/3*SIG(IK)* DELTA_D*ALPHA_D *WN_I(IK)**4 * (YOUNG/MP2)**2 & - * (ICEH/2)**3/3 * 1/( EXP(ALPHA_D*S_D(IK)) + EXP(-ALPHA_D*S_D(IK))) & - * SMOOTHD /(R(IK)**2*CGRATIO(IK)) / (DWAT*GRAV) *TPIINV - END IF + END DO + ! + DMAX = WLG_I(IKBREAK)/2 + ! + ! Uses a weighting by CURVSPEC to have a continuous shift of DMAX .. + ! + IKP1=MIN(IKBREAK+1,NK) + IKM1=MAX(IKBREAK-1,1) + IF (BRK_CRIT_W(IKP1).AND.BRK_CRIT_W(IKM1)) THEN + DMAX = (WLG_I(IKBREAK)*CURVSPEC(IKBREAK) & + +WLG_I(IKP1)*CURVSPEC(IKP1)+WLG_I(IKM1)*CURVSPEC(IKM1)) & + /(2.*(CURVSPEC(IKBREAK)+CURVSPEC(IKM1)+CURVSPEC(IKP1))) + END IF + ! + ICEF = DMAX + END IF + END IF !end of test (IS2PARS(3).GT.0.5) + ! + ! 5. inelastic or anelastic dissipation + ! + IF (IS2PARS(12).GT.0) THEN + DO IK = 1, NK + ! + ! The TANH((DMAX-D*WLG_I(IK))/DMAX*C) + ! is an ad hoc factor that goes to zero for WLG << DMAX and 1 for WLG >> DMAX + ! this should probably be adjusted. + ! + IF (IS2PARS(14)*WLG_I(IK).LT.DMAX) THEN + SMOOTHD=TANH((DMAX-IS2PARS(14)*WLG_I(IK))/(DMAX*IS2PARS(13))) + IF (IS2PARS(23).LE.0.5) THEN ! this is the inelastic option + DISSIP(1+(IK-1)*NTH:IK*NTH)=CREEPFAC*4*CURV(IK) & + *((2*PI)/WLG_I(IK))**(IS2PARS(15)+1) & + /(CGRATIO(IK)**1*R(IK)**2) & + *SMOOTHD + ELSE ! this is the inelastic option + DISSIP(1+(IK-1)*NTH:IK*NTH) =-4*4/3*SIG(IK)* DELTA_D*ALPHA_D *WN_I(IK)**4 * (YOUNG/MP2)**2 & + * (ICEH/2)**3/3 * 1/( EXP(ALPHA_D*S_D(IK)) + EXP(-ALPHA_D*S_D(IK))) & + * SMOOTHD /(R(IK)**2*CGRATIO(IK)) / (DWAT*GRAV) *TPIINV END IF - S=S+DISSIP*CICE*A - END DO ! end of loop on IK - ENDIF ! end of test (IS2PARS(12).GT.0) -! -! 6. Case of no scattering nor dissipation -! - ELSE - DMAX = 0. - ICEF = 0. - END IF ! end of test (CICE .GT. 0 .AND. ICEDAVE .GT. 0) -! -#ifdef W3_T - DO IK = 1, NK - DO ITH = 1, NTH - IS = ITH+(IK-1)*NTH - SOUT(IK,ITH) = S(IS) - END DO - END DO -#endif -! + END IF + S=S+DISSIP*CICE*A + END DO ! end of loop on IK + ENDIF ! end of test (IS2PARS(12).GT.0) + ! + ! 6. Case of no scattering nor dissipation + ! + ELSE + DMAX = 0. + ICEF = 0. + END IF ! end of test (CICE .GT. 0 .AND. ICEDAVE .GT. 0) + ! #ifdef W3_T - CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & - 0.0, 0.001, 'Diag Sir1', ' ', 'NONAME') + DO IK = 1, NK + DO ITH = 1, NTH + IS = ITH+(IK-1)*NTH + SOUT(IK,ITH) = S(IS) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Diag Sir1', ' ', 'NONAME') #endif -! -! Formats - 8000 FORMAT (' TEST W3SIS2 : ALPHA :',E10.3) -! -!/ -!/ End of W3SIS2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SIS2 - - -!/ ------------------------------------------------------------------- / - SUBROUTINE W3RPWNICE(ICEH,WN_I,DAMPING,CG_I) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Sevigny | -!/ | FORTRAN 90 | -!/ | Last update : 27-Aug-2015 | -!/ +-----------------------------------+ -!/ -!/ 27-Aug-2015 : Origination. ( version 5.10 ) -! -! 1. Purpose : -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV - USE W3GDATMD, ONLY: NK, SIG + ! + ! Formats +8000 FORMAT (' TEST W3SIS2 : ALPHA :',E10.3) + ! + !/ + !/ End of W3SIS2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SIS2 - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: ICEH - REAL, INTENT(INOUT) :: WN_I(:), DAMPING(:), CG_I(:) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - DOUBLE COMPLEX :: WN_ROOT, GS1 - INTEGER :: IK - REAL :: FLEX_RIGID - REAL, PARAMETER :: VISC_RP = 10 - REAL, PARAMETER :: DENS = 1025.0 - REAL, PARAMETER :: DENS_ICE = 922.5 - REAL, PARAMETER :: POISSON = 0.3 - REAL, PARAMETER :: YOUNG = 5.49E+9 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3RPWNICE(ICEH,WN_I,DAMPING,CG_I) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Sevigny | + !/ | FORTRAN 90 | + !/ | Last update : 27-Aug-2015 | + !/ +-----------------------------------+ + !/ + !/ 27-Aug-2015 : Origination. ( version 5.10 ) + ! + ! 1. Purpose : + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV + USE W3GDATMD, ONLY: NK, SIG + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: ICEH + REAL, INTENT(INOUT) :: WN_I(:), DAMPING(:), CG_I(:) - FLEX_RIGID = YOUNG * ICEH**3 /(12 *(1-POISSON**2) ) - ! Guess value for roots - GS1 = CMPLX(SIG(1)**2/GRAV,0.) - - DO IK=1,NK - CALL FINDROOTS_NR(GS1,0.,WN_ROOT,ICEH,SIG(IK)) - WN_I(IK) = REAL(WN_ROOT) - CALL FINDROOTS_NR(GS1,VISC_RP,WN_ROOT,ICEH,SIG(IK)) - DAMPING(IK) = AIMAG(WN_ROOT) - GS1 = WN_I(IK) - CG_I(IK) = (5* FLEX_RIGID*WN_I(IK)**4 + DENS*GRAV - DENS_ICE*ICEH*SIG(IK)**2) & - /(2*SIG(IK)*(DENS+DENS_ICE*WN_I(IK)*ICEH)) - END DO + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + DOUBLE COMPLEX :: WN_ROOT, GS1 + INTEGER :: IK + REAL :: FLEX_RIGID + REAL, PARAMETER :: VISC_RP = 10 + REAL, PARAMETER :: DENS = 1025.0 + REAL, PARAMETER :: DENS_ICE = 922.5 + REAL, PARAMETER :: POISSON = 0.3 + REAL, PARAMETER :: YOUNG = 5.49E+9 -!/ - END SUBROUTINE W3RPWNICE - - -!/ ------------------------------------------------------------------- / -! SUBROUTINE FINDROOTS_NR(FUNCD,X0,VISC_RP,WN_ROOT) - SUBROUTINE FINDROOTS_NR(GUESS,VISC_RP,X,ICEH,SIGMA) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Sevigny | -!/ | FORTRAN 90 | -!/ | Last update : 27-Aug-2015 | -!/ +-----------------------------------+ -!/ -!/ 27-Aug-2015 : Origination. ( version 5.10 ) -! -! 1. Purpose : -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE -!/ -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: VISC_RP, ICEH, SIGMA - double COMPLEX, INTENT(IN) :: GUESS - double COMPLEX, intent(INOUT) :: X + FLEX_RIGID = YOUNG * ICEH**3 /(12 *(1-POISSON**2) ) + ! Guess value for roots + GS1 = CMPLX(SIG(1)**2/GRAV,0.) -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - double complex :: FVAL, FDERIV, DX, X0 - INTEGER, PARAMETER :: MAXIT = 300 - REAL, PARAMETER :: TOL = 1E-9 - INTEGER :: J - LOGICAL :: UNFINISHED_ROOTS - - X0 = GUESS - UNFINISHED_ROOTS = .TRUE. - J = 1 - DO WHILE (J .LT. MAXIT .AND. UNFINISHED_ROOTS) - FVAL = FUNCD_FVAL(X0,VISC_RP,ICEH,SIGMA) - FDERIV = FUNCD_FDERIV(X0,VISC_RP,ICEH,SIGMA) - DX = FVAL/FDERIV - X = X0-DX - X0 = X - IF (ABS(DX) .GT. TOL .OR. ABS(FVAL) .GT. 1) THEN - J = J+1 - ELSE - UNFINISHED_ROOTS = .FALSE. - END IF - - IF (J .GT. MAXIT) THEN - WRITE (NDSE,1000) - CALL EXTCDE ( 1 ) - END IF - END DO - -! -! Formats - 1000 FORMAT (/' *** ERROR FINDROOTS_NR *** '/ & - ' ROOT NOT CONVERGED'/) - - END SUBROUTINE FINDROOTS_NR - - -!/ ------------------------------------------------------------------- / - FUNCTION W3FSD_DAVE(ICEDMIN,ICEDMAX,FRAGILITY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Sevigny & F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 6-Nov-2015 | -!/ +-----------------------------------+ -!/ -!/ 27-Aug-2015 : Origination. ( version 5.10 ) -!/ 6-Nov-2015 : Uses a continuous DMAX->DAVE function(version 5.10 ) -! -! 1. Purpose : Computes the mean flow size from the max floe size -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ICEDMIN Real I Minimum floe diameter -! FRAGILITY Real I Parameter that gives the power in the FSD power law -! ICEDMAX R.A. I/O Maximum floe diameter -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! None -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! INSIS2 Proc. W3SIS2MD Initialisation of parameters for IS2 -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: ICEDMIN, ICEDMAX, FRAGILITY - REAL :: W3FSD_DAVE, W3FSD_DAVE2 - -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -! -! analytic solution, if the FSD is given by P(x) = x^(-1-gam) for icedmin <= x <= icedmax and 0 elsewhere -! - REAL :: GAM, MR, R, DENOM, ICEDMAXL - REAL, PARAMETER :: xi = 2 -! - ICEDMAXL=MAX(ICEDMIN*1.01,ICEDMAX) - GAM = 2 + log(FRAGILITY)/log(2.) - IF (ICEDMIN.EQ.0) THEN - W3FSD_DAVE =ICEDMAXL - ELSE - W3FSD_DAVE = GAM/(GAM-1) * ( (ICEDMAXL**(-GAM+1)-ICEDMIN**(-GAM+1))& - /(ICEDMAXL**(-GAM)-ICEDMIN**(-GAM)) ) + DO IK=1,NK + CALL FINDROOTS_NR(GS1,0.,WN_ROOT,ICEH,SIG(IK)) + WN_I(IK) = REAL(WN_ROOT) + CALL FINDROOTS_NR(GS1,VISC_RP,WN_ROOT,ICEH,SIG(IK)) + DAMPING(IK) = AIMAG(WN_ROOT) + GS1 = WN_I(IK) + CG_I(IK) = (5* FLEX_RIGID*WN_I(IK)**4 + DENS*GRAV - DENS_ICE*ICEH*SIG(IK)**2) & + /(2*SIG(IK)*(DENS+DENS_ICE*WN_I(IK)*ICEH)) + END DO + + !/ + END SUBROUTINE W3RPWNICE + + + !/ ------------------------------------------------------------------- / + ! SUBROUTINE FINDROOTS_NR(FUNCD,X0,VISC_RP,WN_ROOT) + SUBROUTINE FINDROOTS_NR(GUESS,VISC_RP,X,ICEH,SIGMA) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Sevigny | + !/ | FORTRAN 90 | + !/ | Last update : 27-Aug-2015 | + !/ +-----------------------------------+ + !/ + !/ 27-Aug-2015 : Origination. ( version 5.10 ) + ! + ! 1. Purpose : + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + !/ + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: VISC_RP, ICEH, SIGMA + double COMPLEX, INTENT(IN) :: GUESS + double COMPLEX, intent(INOUT) :: X + + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + double complex :: FVAL, FDERIV, DX, X0 + INTEGER, PARAMETER :: MAXIT = 300 + REAL, PARAMETER :: TOL = 1E-9 + INTEGER :: J + LOGICAL :: UNFINISHED_ROOTS + + X0 = GUESS + UNFINISHED_ROOTS = .TRUE. + J = 1 + DO WHILE (J .LT. MAXIT .AND. UNFINISHED_ROOTS) + FVAL = FUNCD_FVAL(X0,VISC_RP,ICEH,SIGMA) + FDERIV = FUNCD_FDERIV(X0,VISC_RP,ICEH,SIGMA) + DX = FVAL/FDERIV + X = X0-DX + X0 = X + IF (ABS(DX) .GT. TOL .OR. ABS(FVAL) .GT. 1) THEN + J = J+1 + ELSE + UNFINISHED_ROOTS = .FALSE. END IF -! -! Other possibility: analytical solution to Toyota algorithm (F. Arduin) -! MR=log(ICEDMAXL/ICEDMIN)/log(2.) -! R=(1-FRAGILITY*xi**2)/(1-FRAGILITY*xi) -! DENOM = (1-(FRAGILITY*xi**2)**(MR+1.)) -! W3FSD_DAVE2 = MAX(ICEDMAXL*R* (1-(FRAGILITY*xi)**(MR+1.))/DENOM,ICEDMIN) -! WRITE(991,*) ICEDMAX, GAM, W3FSD_DAVE, W3FSD_DAVE2 - END FUNCTION W3FSD_DAVE -! -!/ ------------------------------------------------------------------- / - FUNCTION FUNCD_FVAL(WN_GUESS, VISC_RP,ICEH,SIGMA) RESULT(FVAL) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Sevigny | -!/ | FORTRAN 90 | -!/ | Last update : 27-Aug-2015 | -!/ +-----------------------------------+ -!/ -!/ 27-Aug-2015 : Origination. ( version 5.10 ) -! -! 1. Purpose : -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV - - IMPLICIT NONE - - REAL, INTENT(IN) :: VISC_RP, ICEH, SIGMA - DOUBLE COMPLEX, INTENT(IN) :: WN_GUESS - -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - REAL :: ALP, FLEX_RIGID, GAMMA, C5, DRAFT, DENS_GRAV - double complex :: C1, FVAL - - REAL, PARAMETER :: DENS = 1025.0 - REAL, PARAMETER :: DENS_ICE = 922.5 - REAL, PARAMETER :: POISSON = 0.3 - ! Effective modulus or strain modulus [Pa], YOUNG - REAL, PARAMETER :: YOUNG = 5.49E+9 -!/ -!/ ------------------------------------------------------------------- / + IF (J .GT. MAXIT) THEN + WRITE (NDSE,1000) + CALL EXTCDE ( 1 ) + END IF + END DO - ! Length below which flexural felure cannot occur, flexural rigidity - FLEX_RIGID = YOUNG * ICEH**3 /(12 *(1-POISSON**2) ) - DRAFT = (DENS_ICE/DENS)*ICEH - DENS_GRAV = DENS*GRAV - - ALP = SIGMA**2/GRAV - ! Artificial viscosity (Robinson & Palmer, 1990) - GAMMA = SIGMA * VISC_RP/DENS_GRAV - C1 = CMPLX(1 - ALP*DRAFT, - 1.*GAMMA) - C5 = FLEX_RIGID/DENS_GRAV - - FVAL = C5*WN_GUESS**5 + C1*WN_GUESS - ALP - - END FUNCTION FUNCD_FVAL - - -!/ ------------------------------------------------------------------- / -! FUNCTION FUNCD(WN_GUESS, VISC_RP,ICEH) - FUNCTION FUNCD_FDERIV(WN_GUESS, VISC_RP,ICEH,SIGMA) RESULT(FDERIV) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Sevigny | -!/ | FORTRAN 90 | -!/ | Last update : 27-Aug-2015 | -!/ +-----------------------------------+ -!/ -!/ 27-Aug-2015 : Origination. ( version 5.10 ) -! -! 1. Purpose : -! -!/ ------------------------------------------------------------------- / -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV - - IMPLICIT NONE - - REAL, INTENT(IN) :: VISC_RP, ICEH, SIGMA - DOUBLE COMPLEX, INTENT(IN) :: WN_GUESS - -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - REAL :: ALP, FLEX_RIGID, GAMMA, C5, DRAFT, DENS_GRAV - double complex :: C1, FDERIV - - REAL, PARAMETER :: DENS = 1025.0 - REAL, PARAMETER :: DENS_ICE = 922.5 - REAL, PARAMETER :: POISSON = 0.3 - REAL, PARAMETER :: YOUNG = 5.49E+9 + ! + ! Formats +1000 FORMAT (/' *** ERROR FINDROOTS_NR *** '/ & + ' ROOT NOT CONVERGED'/) -!/ -!/ ------------------------------------------------------------------- / -! -! Length below which flexural felure cannot occur, flexural rigidity -! - FLEX_RIGID = YOUNG * ICEH**3 /(12 * (1-POISSON**2)) - DRAFT = (DENS_ICE/DENS)*ICEH - DENS_GRAV = DENS*GRAV - - ALP = SIGMA**2/GRAV -! -! Artificial viscosity (Robinson & Palmer, 1990) -! - GAMMA = SIGMA * VISC_RP/DENS_GRAV - C1 = CMPLX(1 - ALP*DRAFT, -1.*GAMMA) - C5 = FLEX_RIGID/DENS_GRAV -! - FDERIV = 5*C5*WN_GUESS**4 +C1 -! - END FUNCTION FUNCD_FDERIV -!/ -!/ End of module W3SIS1MD -------------------------------------------- / -!/ - END MODULE W3SIS2MD + END SUBROUTINE FINDROOTS_NR + + + !/ ------------------------------------------------------------------- / + FUNCTION W3FSD_DAVE(ICEDMIN,ICEDMAX,FRAGILITY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Sevigny & F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 6-Nov-2015 | + !/ +-----------------------------------+ + !/ + !/ 27-Aug-2015 : Origination. ( version 5.10 ) + !/ 6-Nov-2015 : Uses a continuous DMAX->DAVE function(version 5.10 ) + ! + ! 1. Purpose : Computes the mean flow size from the max floe size + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ICEDMIN Real I Minimum floe diameter + ! FRAGILITY Real I Parameter that gives the power in the FSD power law + ! ICEDMAX R.A. I/O Maximum floe diameter + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! None + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! INSIS2 Proc. W3SIS2MD Initialisation of parameters for IS2 + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: ICEDMIN, ICEDMAX, FRAGILITY + REAL :: W3FSD_DAVE, W3FSD_DAVE2 + + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + ! + ! analytic solution, if the FSD is given by P(x) = x^(-1-gam) for icedmin <= x <= icedmax and 0 elsewhere + ! + REAL :: GAM, MR, R, DENOM, ICEDMAXL + REAL, PARAMETER :: xi = 2 + ! + ICEDMAXL=MAX(ICEDMIN*1.01,ICEDMAX) + GAM = 2 + log(FRAGILITY)/log(2.) + IF (ICEDMIN.EQ.0) THEN + W3FSD_DAVE =ICEDMAXL + ELSE + W3FSD_DAVE = GAM/(GAM-1) * ( (ICEDMAXL**(-GAM+1)-ICEDMIN**(-GAM+1))& + /(ICEDMAXL**(-GAM)-ICEDMIN**(-GAM)) ) + END IF + ! + ! Other possibility: analytical solution to Toyota algorithm (F. Arduin) + ! MR=log(ICEDMAXL/ICEDMIN)/log(2.) + ! R=(1-FRAGILITY*xi**2)/(1-FRAGILITY*xi) + ! DENOM = (1-(FRAGILITY*xi**2)**(MR+1.)) + ! W3FSD_DAVE2 = MAX(ICEDMAXL*R* (1-(FRAGILITY*xi)**(MR+1.))/DENOM,ICEDMIN) + ! WRITE(991,*) ICEDMAX, GAM, W3FSD_DAVE, W3FSD_DAVE2 + END FUNCTION W3FSD_DAVE + ! + !/ ------------------------------------------------------------------- / + FUNCTION FUNCD_FVAL(WN_GUESS, VISC_RP,ICEH,SIGMA) RESULT(FVAL) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Sevigny | + !/ | FORTRAN 90 | + !/ | Last update : 27-Aug-2015 | + !/ +-----------------------------------+ + !/ + !/ 27-Aug-2015 : Origination. ( version 5.10 ) + ! + ! 1. Purpose : + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV + + IMPLICIT NONE + + REAL, INTENT(IN) :: VISC_RP, ICEH, SIGMA + DOUBLE COMPLEX, INTENT(IN) :: WN_GUESS + + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL :: ALP, FLEX_RIGID, GAMMA, C5, DRAFT, DENS_GRAV + double complex :: C1, FVAL + + REAL, PARAMETER :: DENS = 1025.0 + REAL, PARAMETER :: DENS_ICE = 922.5 + REAL, PARAMETER :: POISSON = 0.3 + ! Effective modulus or strain modulus [Pa], YOUNG + REAL, PARAMETER :: YOUNG = 5.49E+9 + + !/ + !/ ------------------------------------------------------------------- / + + ! Length below which flexural felure cannot occur, flexural rigidity + FLEX_RIGID = YOUNG * ICEH**3 /(12 *(1-POISSON**2) ) + DRAFT = (DENS_ICE/DENS)*ICEH + DENS_GRAV = DENS*GRAV + + ALP = SIGMA**2/GRAV + ! Artificial viscosity (Robinson & Palmer, 1990) + GAMMA = SIGMA * VISC_RP/DENS_GRAV + C1 = CMPLX(1 - ALP*DRAFT, - 1.*GAMMA) + C5 = FLEX_RIGID/DENS_GRAV + + FVAL = C5*WN_GUESS**5 + C1*WN_GUESS - ALP + + END FUNCTION FUNCD_FVAL + + + !/ ------------------------------------------------------------------- / + ! FUNCTION FUNCD(WN_GUESS, VISC_RP,ICEH) + FUNCTION FUNCD_FDERIV(WN_GUESS, VISC_RP,ICEH,SIGMA) RESULT(FDERIV) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Sevigny | + !/ | FORTRAN 90 | + !/ | Last update : 27-Aug-2015 | + !/ +-----------------------------------+ + !/ + !/ 27-Aug-2015 : Origination. ( version 5.10 ) + ! + ! 1. Purpose : + ! + !/ ------------------------------------------------------------------- / + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV + + IMPLICIT NONE + + REAL, INTENT(IN) :: VISC_RP, ICEH, SIGMA + DOUBLE COMPLEX, INTENT(IN) :: WN_GUESS + + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL :: ALP, FLEX_RIGID, GAMMA, C5, DRAFT, DENS_GRAV + double complex :: C1, FDERIV + + REAL, PARAMETER :: DENS = 1025.0 + REAL, PARAMETER :: DENS_ICE = 922.5 + REAL, PARAMETER :: POISSON = 0.3 + REAL, PARAMETER :: YOUNG = 5.49E+9 + + !/ + !/ ------------------------------------------------------------------- / + ! + ! Length below which flexural felure cannot occur, flexural rigidity + ! + FLEX_RIGID = YOUNG * ICEH**3 /(12 * (1-POISSON**2)) + DRAFT = (DENS_ICE/DENS)*ICEH + DENS_GRAV = DENS*GRAV + ALP = SIGMA**2/GRAV + ! + ! Artificial viscosity (Robinson & Palmer, 1990) + ! + GAMMA = SIGMA * VISC_RP/DENS_GRAV + C1 = CMPLX(1 - ALP*DRAFT, -1.*GAMMA) + C5 = FLEX_RIGID/DENS_GRAV + ! + FDERIV = 5*C5*WN_GUESS**4 +C1 + ! + END FUNCTION FUNCD_FDERIV + !/ + !/ End of module W3SIS1MD -------------------------------------------- / + !/ +END MODULE W3SIS2MD diff --git a/model/src/w3sln1md.F90 b/model/src/w3sln1md.F90 index 266539262..15b8b6228 100644 --- a/model/src/w3sln1md.F90 +++ b/model/src/w3sln1md.F90 @@ -1,216 +1,216 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SLN1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 23-Jun-2006 : Origination. ( version 3.09 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Linear wind input according to Cavaleri and Melanotte-Rizzoli -! (1982) filtered for low frequencies according to Tolman (1992). -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SLN1 Subr. Public User supplied linear input. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SLN1 (K, FHIGH, USTAR, USDIR, S) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Jun-2006 | -!/ +-----------------------------------+ -!/ -!/ 23-Jun-2006 : Origination. ( version 3.09 ) -!/ -! 1. Purpose : -! -! Linear wind input according to Cavaleri and Melanotte-Rizzoli -! (1982) filtered for low frequencies according to Tolman (1992). -! -! 2. Method : -! -! The expression of Cavaleri and Melanotte-Rizzoli, converted to -! action spectra defined in terms of wavenumber and direction -! becomes -! -! -1 / / \ \ 4 -! Sln = SLNC1 * k * max | 0., | U* cos(Dtheta) | | (1) -! \ \ / / -! -! 2 -2 -! SLNC1 = 80 RHOr GRAV FILT (2) -! -! Where : -! -! RHOr Density of air dev. by density of water. -! U* Wind friction velocity. -! Dtheta Difference in wind and wave direction. -! FILT Filter based on PM and cut-off frequencies. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! K R.A. I Wavenumber for entire spectrum. -! FHIGH R.A. I Cut-off frequency in integration (rad/s) -! USTAR Real I Friction velocity. -! USDIR Real I Direction of USTAR. -! S R.A. O Source term. -! ---------------------------------------------------------------- -! *) Stored as 1-D array with dimension NTH*NK -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NTH, NK, ECOS, ESIN, SIG, SLNC1, FSPM, FSHF - USE W3ODATMD, ONLY: NDSE, NDST - USE W3SERVMD, ONLY: EXTCDE +MODULE W3SLN1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 23-Jun-2006 : Origination. ( version 3.09 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Linear wind input according to Cavaleri and Melanotte-Rizzoli + ! (1982) filtered for low frequencies according to Tolman (1992). + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SLN1 Subr. Public User supplied linear input. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SLN1 (K, FHIGH, USTAR, USDIR, S) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Jun-2006 | + !/ +-----------------------------------+ + !/ + !/ 23-Jun-2006 : Origination. ( version 3.09 ) + !/ + ! 1. Purpose : + ! + ! Linear wind input according to Cavaleri and Melanotte-Rizzoli + ! (1982) filtered for low frequencies according to Tolman (1992). + ! + ! 2. Method : + ! + ! The expression of Cavaleri and Melanotte-Rizzoli, converted to + ! action spectra defined in terms of wavenumber and direction + ! becomes + ! + ! -1 / / \ \ 4 + ! Sln = SLNC1 * k * max | 0., | U* cos(Dtheta) | | (1) + ! \ \ / / + ! + ! 2 -2 + ! SLNC1 = 80 RHOr GRAV FILT (2) + ! + ! Where : + ! + ! RHOr Density of air dev. by density of water. + ! U* Wind friction velocity. + ! Dtheta Difference in wind and wave direction. + ! FILT Filter based on PM and cut-off frequencies. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! K R.A. I Wavenumber for entire spectrum. + ! FHIGH R.A. I Cut-off frequency in integration (rad/s) + ! USTAR Real I Friction velocity. + ! USDIR Real I Direction of USTAR. + ! S R.A. O Source term. + ! ---------------------------------------------------------------- + ! *) Stored as 1-D array with dimension NTH*NK + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NTH, NK, ECOS, ESIN, SIG, SLNC1, FSPM, FSHF + USE W3ODATMD, ONLY: NDSE, NDST + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: K(NK), FHIGH, USTAR, USDIR - REAL, INTENT(OUT) :: S(NTH,NK) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IK + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: K(NK), FHIGH, USTAR, USDIR + REAL, INTENT(OUT) :: S(NTH,NK) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IK #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: COSU, SINU, DIRF(NTH), FAC, FF1, FF2, & - FFILT, RFR, WNF(NK) -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: COSU, SINU, DIRF(NTH), FAC, FF1, FF2, & + FFILT, RFR, WNF(NK) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SLN1') + CALL STRACE (IENT, 'W3SLN1') #endif -! -! 1. Set up factors ------------------------------------------------- * -! + ! + ! 1. Set up factors ------------------------------------------------- * + ! #ifdef W3_T - WRITE (NDST,900) USTAR, USDIR*RADE + WRITE (NDST,900) USTAR, USDIR*RADE #endif -! - COSU = COS(USDIR) - SINU = SIN(USDIR) -! - DO ITH=1, NTH - DIRF(ITH) = MAX ( 0. , (ECOS(ITH)*COSU+ESIN(ITH)*SINU) )**4 - END DO -! - FAC = SLNC1 * USTAR**4 - FF1 = FSPM * GRAV/(28.*USTAR) - FF2 = FSHF * MIN(SIG(NK),FHIGH) - FFILT = MIN ( MAX(FF1,FF2) , 2.*SIG(NK) ) - DO IK=1, NK - RFR = SIG(IK) / FFILT - IF ( RFR .LT. 0.5 ) THEN - WNF(IK) = 0. - ELSE - WNF(IK) = FAC / K(IK) * EXP(-RFR**(-4)) - END IF - END DO -! -! 2. Compose source term -------------------------------------------- * -! - DO IK=1, NK - S(:,IK) = WNF(IK) * DIRF(:) - END DO -! - RETURN -! -! Formats -! + ! + COSU = COS(USDIR) + SINU = SIN(USDIR) + ! + DO ITH=1, NTH + DIRF(ITH) = MAX ( 0. , (ECOS(ITH)*COSU+ESIN(ITH)*SINU) )**4 + END DO + ! + FAC = SLNC1 * USTAR**4 + FF1 = FSPM * GRAV/(28.*USTAR) + FF2 = FSHF * MIN(SIG(NK),FHIGH) + FFILT = MIN ( MAX(FF1,FF2) , 2.*SIG(NK) ) + DO IK=1, NK + RFR = SIG(IK) / FFILT + IF ( RFR .LT. 0.5 ) THEN + WNF(IK) = 0. + ELSE + WNF(IK) = FAC / K(IK) * EXP(-RFR**(-4)) + END IF + END DO + ! + ! 2. Compose source term -------------------------------------------- * + ! + DO IK=1, NK + S(:,IK) = WNF(IK) * DIRF(:) + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 900 FORMAT ( ' TEST W3SLN1 : USTAR, DIR :',F6.3, F6.1) +900 FORMAT ( ' TEST W3SLN1 : USTAR, DIR :',F6.3, F6.1) #endif -!/ -!/ End of W3SLN1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SLN1 -!/ -!/ End of module INSLN1MD -------------------------------------------- / -!/ - END MODULE W3SLN1MD + !/ + !/ End of W3SLN1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SLN1 + !/ + !/ End of module INSLN1MD -------------------------------------------- / + !/ +END MODULE W3SLN1MD diff --git a/model/src/w3smcomd.F90 b/model/src/w3smcomd.F90 index 02f9d2098..3db567830 100644 --- a/model/src/w3smcomd.F90 +++ b/model/src/w3smcomd.F90 @@ -53,814 +53,814 @@ !> 20-Jul-2021 | 7.12 | Fix bug where edge cells in design grid may not be matched due where SMC cell > base grid size. !> 21-Jul-2021 | 7.12 | Elevated some grid variables to DOUBLE PRECISION, fixed EXO/EYO bug !> - MODULE W3SMCOMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Chris Bunney, UKMO | -!/ | FORTRAN 90 | -!/ | Last update : 21-Jul-2021 | -!/ +-----------------------------------+ -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - USE W3GDATMD - USE CONSTANTS - USE W3ODATMD, ONLY: UNDEF - - PUBLIC - - ! Output grid definition - DOUBLE PRECISION :: SXO !< Output grid longitude origin - DOUBLE PRECISION :: SYO !< Output grid latitude origin - DOUBLE PRECISION :: EXO !< Output grid final longitude - DOUBLE PRECISION :: EYO !< Output grid final latitude - DOUBLE PRECISION :: DXO !< Output grid cell longitude size - DOUBLE PRECISION :: DYO !< Output grid cell latitude size - INTEGER :: NXO !< Output grid number of longitude cells - INTEGER :: NYO !< Output grid number of latitude cells - - ! Variables for SMC regridding (type 2 output): - !> Type of SMC output: 1=seapoint grid of SMC cells; 2=regridding to regular grid; - !> 3=interpolation to arbtrary grid; 4=nearest neighbour interpolation to - !> arbitrary grid. - INTEGER :: SMCOTYPE - !> Output grid cell scaling factor; should be an integer power of 2. - INTEGER :: CELFAC - INTEGER, ALLOCATABLE :: XIDX(:) !< X-indices of SMC cells in regular grid - INTEGER, ALLOCATABLE :: YIDX(:) !< Y-Indices of SMC cells in regular grid - INTEGER, ALLOCATABLE :: XSPAN(:) !< Number of longitude cells SMC cell spans - INTEGER, ALLOCATABLE :: YSPAN(:) !< Number of longitude cells SMC cell spans - REAL, ALLOCATABLE :: WTS(:) !< Regridding weights - REAL, ALLOCATABLE :: COV(:,:) !< Wet fraction (coverage) of cell - INTEGER, ALLOCATABLE :: MAPSMC(:,:) !< Regridded MAPSTA - LOGICAL, ALLOCATABLE :: SMCMASK(:) !< Mask for type 1 output (flat array) - INTEGER, ALLOCATABLE :: SMCIDX(:) !< Indices of SMC cells within output grid domain - - !> SMC grid definition - INTEGER, ALLOCATABLE :: SMCCX(:) !< Longitude cell size factors - INTEGER, ALLOCATABLE :: SMCCY(:) !< Latitude cell size factors - REAL :: DLAT !< Base longitude cell size - REAL :: DLON !< Base latitude cell size - INTEGER :: CFAC !< SMC scaling factor (number of levels) - - REAL :: NOVAL !< Fill value for seapoints with no value - - ! Variables for SMC nearest neighbour interpolation (type 3/4 output) - INTEGER, ALLOCATABLE :: NNIDX(:,:) !< Nearest neighbour SMC point to regular grid - REAL, ALLOCATABLE :: XDIST(:,:) !< Lng. distance to nearest neighbour - REAL, ALLOCATABLE :: YDIST(:,:) !< Lat. distance to nearest neighbour - INTEGER :: NDSMC !< ww3_smcint file unit number - - ! Counters: - INTEGER :: SMCNOUT !< Number of SMC output cells - INTEGER :: NSMC !< Number of SMC cells used in regridding - - CONTAINS - -!-------------------------------------------------------------------------- -!> @brief Generate SMC interpolation/output information -!> -!> @details -!> This subroutine generates index or mask values for extraction -!> of SMC data to either a flat grid or regular lat/lon grid, -!> depending on the type of SMC output grid selected: -!> -!> Type 1: Generates a mask for extracting only points from -!> the user requested region. -!> -!> Type 2: Calculate interpolation indices and weights for -!> regridding the irregular SMC grid onto a regular, -!> uniformly spaced lat/lon grid. -!> -!> @author Chris Bunney -!> @date 22-Oct-2015 -!> - SUBROUTINE SMC_INTERP() - - IMPLICIT NONE - - ! Locals - REAL :: CX0, CY0 ! SW corner of origin of grid - REAL :: S0CHK, XSNAP, YSNAP - - INTEGER :: ISEA, mx, my, ixx, iyy, J - REAL :: lat, lon - - J = 1 - NSMC = 0 - - ! Determine smallest cell size factor: - cfac = 2**(NRLv - 1) - - ! Get smallest SMC grid cells step size: - dlat = SY / cfac - dlon = SX / cfac - ! SW Corner of grid origin cell: - CX0 = X0 - SX / 2. - CY0 = Y0 - SY / 2. - - ! Grid cell size to snap design grid to. Will be regular grid - ! resolution for cellsize <= cfac, or cellsize for cellsize > cfac - XSNAP = SX - YSNAP = SY - IF(CELFAC .gt. CFAC) XSNAP = CELFAC * dlon - IF(CELFAC .gt. CFAC) YSNAP = CELFAC * dlat - - ! Get start lat,lon (must be aligned with SMC grid edges). Use - ! regular grid origins if SXO or SYO is -999.9 (use full grid): - IF(ABS(SXO + 999.9) .LT. 1E-4) THEN - SXO = CX0 +MODULE W3SMCOMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Chris Bunney, UKMO | + !/ | FORTRAN 90 | + !/ | Last update : 21-Jul-2021 | + !/ +-----------------------------------+ + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + USE W3GDATMD + USE CONSTANTS + USE W3ODATMD, ONLY: UNDEF + + PUBLIC + + ! Output grid definition + DOUBLE PRECISION :: SXO !< Output grid longitude origin + DOUBLE PRECISION :: SYO !< Output grid latitude origin + DOUBLE PRECISION :: EXO !< Output grid final longitude + DOUBLE PRECISION :: EYO !< Output grid final latitude + DOUBLE PRECISION :: DXO !< Output grid cell longitude size + DOUBLE PRECISION :: DYO !< Output grid cell latitude size + INTEGER :: NXO !< Output grid number of longitude cells + INTEGER :: NYO !< Output grid number of latitude cells + + ! Variables for SMC regridding (type 2 output): + !> Type of SMC output: 1=seapoint grid of SMC cells; 2=regridding to regular grid; + !> 3=interpolation to arbtrary grid; 4=nearest neighbour interpolation to + !> arbitrary grid. + INTEGER :: SMCOTYPE + !> Output grid cell scaling factor; should be an integer power of 2. + INTEGER :: CELFAC + INTEGER, ALLOCATABLE :: XIDX(:) !< X-indices of SMC cells in regular grid + INTEGER, ALLOCATABLE :: YIDX(:) !< Y-Indices of SMC cells in regular grid + INTEGER, ALLOCATABLE :: XSPAN(:) !< Number of longitude cells SMC cell spans + INTEGER, ALLOCATABLE :: YSPAN(:) !< Number of longitude cells SMC cell spans + REAL, ALLOCATABLE :: WTS(:) !< Regridding weights + REAL, ALLOCATABLE :: COV(:,:) !< Wet fraction (coverage) of cell + INTEGER, ALLOCATABLE :: MAPSMC(:,:) !< Regridded MAPSTA + LOGICAL, ALLOCATABLE :: SMCMASK(:) !< Mask for type 1 output (flat array) + INTEGER, ALLOCATABLE :: SMCIDX(:) !< Indices of SMC cells within output grid domain + + !> SMC grid definition + INTEGER, ALLOCATABLE :: SMCCX(:) !< Longitude cell size factors + INTEGER, ALLOCATABLE :: SMCCY(:) !< Latitude cell size factors + REAL :: DLAT !< Base longitude cell size + REAL :: DLON !< Base latitude cell size + INTEGER :: CFAC !< SMC scaling factor (number of levels) + + REAL :: NOVAL !< Fill value for seapoints with no value + + ! Variables for SMC nearest neighbour interpolation (type 3/4 output) + INTEGER, ALLOCATABLE :: NNIDX(:,:) !< Nearest neighbour SMC point to regular grid + REAL, ALLOCATABLE :: XDIST(:,:) !< Lng. distance to nearest neighbour + REAL, ALLOCATABLE :: YDIST(:,:) !< Lat. distance to nearest neighbour + INTEGER :: NDSMC !< ww3_smcint file unit number + + ! Counters: + INTEGER :: SMCNOUT !< Number of SMC output cells + INTEGER :: NSMC !< Number of SMC cells used in regridding + +CONTAINS + + !-------------------------------------------------------------------------- + !> @brief Generate SMC interpolation/output information + !> + !> @details + !> This subroutine generates index or mask values for extraction + !> of SMC data to either a flat grid or regular lat/lon grid, + !> depending on the type of SMC output grid selected: + !> + !> Type 1: Generates a mask for extracting only points from + !> the user requested region. + !> + !> Type 2: Calculate interpolation indices and weights for + !> regridding the irregular SMC grid onto a regular, + !> uniformly spaced lat/lon grid. + !> + !> @author Chris Bunney + !> @date 22-Oct-2015 + !> + SUBROUTINE SMC_INTERP() + + IMPLICIT NONE + + ! Locals + REAL :: CX0, CY0 ! SW corner of origin of grid + REAL :: S0CHK, XSNAP, YSNAP + + INTEGER :: ISEA, mx, my, ixx, iyy, J + REAL :: lat, lon + + J = 1 + NSMC = 0 + + ! Determine smallest cell size factor: + cfac = 2**(NRLv - 1) + + ! Get smallest SMC grid cells step size: + dlat = SY / cfac + dlon = SX / cfac + ! SW Corner of grid origin cell: + CX0 = X0 - SX / 2. + CY0 = Y0 - SY / 2. + + ! Grid cell size to snap design grid to. Will be regular grid + ! resolution for cellsize <= cfac, or cellsize for cellsize > cfac + XSNAP = SX + YSNAP = SY + IF(CELFAC .gt. CFAC) XSNAP = CELFAC * dlon + IF(CELFAC .gt. CFAC) YSNAP = CELFAC * dlat + + ! Get start lat,lon (must be aligned with SMC grid edges). Use + ! regular grid origins if SXO or SYO is -999.9 (use full grid): + IF(ABS(SXO + 999.9) .LT. 1E-4) THEN + SXO = CX0 + ELSE + S0CHK = CX0 + FLOOR((SXO - CX0) / XSNAP) * XSNAP + ! Ensure first grid value falls within specified range + IF (S0CHK .LT. SXO) THEN + SXO = S0CHK + XSNAP ELSE - S0CHK = CX0 + FLOOR((SXO - CX0) / XSNAP) * XSNAP - ! Ensure first grid value falls within specified range - IF (S0CHK .LT. SXO) THEN - SXO = S0CHK + XSNAP - ELSE - SXO = S0CHK - ENDIF + SXO = S0CHK ENDIF - IF(ABS(SYO + 999.9) .LT. 1E-4) THEN - SYO = CY0 + ENDIF + IF(ABS(SYO + 999.9) .LT. 1E-4) THEN + SYO = CY0 + ELSE + S0CHK = CY0 + FLOOR((SYO - CY0) / YSNAP) * YSNAP + ! Ensure first grid value falls within specified range + IF (S0CHK .LT. SYO) THEN + SYO = S0CHK + YSNAP ELSE - S0CHK = CY0 + FLOOR((SYO - CY0) / YSNAP) * YSNAP - ! Ensure first grid value falls within specified range - IF (S0CHK .LT. SYO) THEN - SYO = S0CHK + YSNAP - ELSE - SYO = S0CHK - ENDIF + SYO = S0CHK ENDIF - - ! Use regular grid extents for last lat/lon if user - ! specifies -999.9 for EXO/EYO (use full grid): - IF(ABS(EXO + 999.9) .LT. 1E-4) THEN - EXO = CX0 + SX * NX ! TRHC of last cell + ENDIF + + ! Use regular grid extents for last lat/lon if user + ! specifies -999.9 for EXO/EYO (use full grid): + IF(ABS(EXO + 999.9) .LT. 1E-4) THEN + EXO = CX0 + SX * NX ! TRHC of last cell + ENDIF + IF(ABS(EYO + 999.9) .LT. 1E-4) THEN + EYO = CY0 + SY * NY ! TRHC of last cell + ENDIF + + ! Ouput grid cell dx/dy will be integer factor of smallest + ! SMC grid cell size: + DXO = dlon * celfac + DYO = dlat * celfac + + ! Determine number of cells in grid: + NXO = NINT((EXO - SXO) / DXO) + NYO = NINT((EYO - SYO) / DYO) + + IF(SMCOTYPE .EQ. 2) THEN + ! Initialise all indices to "missing": + XIDX(:) = -1 + YIDX(:) = -1 + ENDIF + + ! Loop over cell array and calculate regidding factors: + DO ISEA=1, NSEA + ! ! For grids with Arctic region: make sure we don't double count + ! ! the overlapping boundary cells. Also, don't process the arctic + ! ! cell (which is always the last cell). + ! ! Note: NARC contains ALL the boundary cells (global + arctic). + ! ! whereas NGLO contains only the global boundary cells. + ! IF(ISEA .GT. NGLO-NBAC .AND. ISEA .LT. NSEA-NARC+1) CYCLE + IF( ARCTC .AND. & + ISEA .GT. NGLO-NBAC .AND. ISEA .LT. NSEA-NARC+1) CYCLE + + ! Get grid cell size: + mx = IJKCel(3,ISEA) + my = IJKCel(4,ISEA) + + ! Determine cell lat/lon (bottom left corner of cell) + lon = CX0 + IJKCel(1,ISEA) * dlon + lat = CY0 + IJKCel(2,ISEA) * dlat + + ! For output type 1 (seapoint array), just check whether + ! cell centre is within specified domain range, and update + ! output mask accordingly: + IF( SMCOTYPE .EQ. 1 ) THEN + ! Ensure longitude ranges are aligned + lon = lon + 0.5 * mx * dlon + lat = lat + 0.5 * my * dlat + IF(lon .LT. SXO) lon = lon + 360.0 + IF(lon .GT. EXO) lon = lon - 360.0 + + ! Now check if it is within range of requested domain: + IF(lon .GE. SXO .AND. lon .LE. EXO .AND. & + lat .GE. SYO .AND. lat .LE. EYO ) THEN + SMCMASK(ISEA) = .TRUE. + SMCIDX(J) = ISEA + J = J + 1 + ENDIF + CYCLE + ENDIF ! SMCOTYPE == 1 + + ! For output type 2 (area averaged regular grid), determine + ! SMC grid cell location and coverage in output grid: + + ! Align lons + IF(lon .LT. SXO) THEN + lon = lon + 360. ENDIF - IF(ABS(EYO + 999.9) .LT. 1E-4) THEN - EYO = CY0 + SY * NY ! TRHC of last cell - ENDIF - - ! Ouput grid cell dx/dy will be integer factor of smallest - ! SMC grid cell size: - DXO = dlon * celfac - DYO = dlat * celfac - - ! Determine number of cells in grid: - NXO = NINT((EXO - SXO) / DXO) - NYO = NINT((EYO - SYO) / DYO) - - IF(SMCOTYPE .EQ. 2) THEN - ! Initialise all indices to "missing": - XIDX(:) = -1 - YIDX(:) = -1 + IF(lon .GT. EXO) THEN + lon = lon - 360. ENDIF - ! Loop over cell array and calculate regidding factors: - DO ISEA=1, NSEA -! ! For grids with Arctic region: make sure we don't double count -! ! the overlapping boundary cells. Also, don't process the arctic -! ! cell (which is always the last cell). -! ! Note: NARC contains ALL the boundary cells (global + arctic). -! ! whereas NGLO contains only the global boundary cells. -! IF(ISEA .GT. NGLO-NBAC .AND. ISEA .LT. NSEA-NARC+1) CYCLE - IF( ARCTC .AND. & - ISEA .GT. NGLO-NBAC .AND. ISEA .LT. NSEA-NARC+1) CYCLE - - ! Get grid cell size: - mx = IJKCel(3,ISEA) - my = IJKCel(4,ISEA) - - ! Determine cell lat/lon (bottom left corner of cell) - lon = CX0 + IJKCel(1,ISEA) * dlon - lat = CY0 + IJKCel(2,ISEA) * dlat - - ! For output type 1 (seapoint array), just check whether - ! cell centre is within specified domain range, and update - ! output mask accordingly: - IF( SMCOTYPE .EQ. 1 ) THEN - ! Ensure longitude ranges are aligned - lon = lon + 0.5 * mx * dlon - lat = lat + 0.5 * my * dlat - IF(lon .LT. SXO) lon = lon + 360.0 - IF(lon .GT. EXO) lon = lon - 360.0 - - ! Now check if it is within range of requested domain: - IF(lon .GE. SXO .AND. lon .LE. EXO .AND. & - lat .GE. SYO .AND. lat .LE. EYO ) THEN - SMCMASK(ISEA) = .TRUE. - SMCIDX(J) = ISEA - J = J + 1 - ENDIF - CYCLE - ENDIF ! SMCOTYPE == 1 - - ! For output type 2 (area averaged regular grid), determine - ! SMC grid cell location and coverage in output grid: - - ! Align lons - IF(lon .LT. SXO) THEN - lon = lon + 360. - ENDIF - IF(lon .GT. EXO) THEN - lon = lon - 360. - ENDIF - - ! Find first SW cell in design grid: - ! We add on 1/2 of the smallest SMC cell dlon/dlat values to ensure - ! source grid cell ends up in the correct target grid cell (after - ! integer trunction): + ! Find first SW cell in design grid: + ! We add on 1/2 of the smallest SMC cell dlon/dlat values to ensure + ! source grid cell ends up in the correct target grid cell (after + ! integer trunction): + ixx = FLOOR((lon + 0.5*dlon - SXO) / DXO) + 1 + iyy = FLOOR((lat + 0.5*dlat - SYO) / DYO) + 1 + + ! If we fall outside the left/bottom edge of the design grid, + ! check for cases where the SMC cell has a lon or lat + ! scaling factor > cfac (design grid is assumed to align + ! its origin with cells of size cfac). For such cells, + ! keep moving the left/bottom edge up by cfac until + ! the SW corner (possibly) matches a design grid cell. + IF(ixx .LE. 0 .AND. ixx + mx / celfac .GT. 0) THEN + DO WHILE(mx .GT. cfac) + mx = mx - cfac + lon = lon + dlon * cfac ixx = FLOOR((lon + 0.5*dlon - SXO) / DXO) + 1 + IF(ixx .GT. 0) EXIT ! Found cell lon-edge in design grid + ENDDO + ENDIF + IF(iyy .LE. 0 .AND. iyy + my / celfac .GT. 0) THEN + DO WHILE(my .GT. cfac) + my = my - cfac + lat = lat + dlat * cfac iyy = FLOOR((lat + 0.5*dlat - SYO) / DYO) + 1 + IF(iyy .GT. 0) EXIT ! Found cell lat-edge in design grid + ENDDO + ENDIF - ! If we fall outside the left/bottom edge of the design grid, - ! check for cases where the SMC cell has a lon or lat - ! scaling factor > cfac (design grid is assumed to align - ! its origin with cells of size cfac). For such cells, - ! keep moving the left/bottom edge up by cfac until - ! the SW corner (possibly) matches a design grid cell. - IF(ixx .LE. 0 .AND. ixx + mx / celfac .GT. 0) THEN - DO WHILE(mx .GT. cfac) - mx = mx - cfac - lon = lon + dlon * cfac - ixx = FLOOR((lon + 0.5*dlon - SXO) / DXO) + 1 - IF(ixx .GT. 0) EXIT ! Found cell lon-edge in design grid - ENDDO - ENDIF - IF(iyy .LE. 0 .AND. iyy + my / celfac .GT. 0) THEN - DO WHILE(my .GT. cfac) - my = my - cfac - lat = lat + dlat * cfac - iyy = FLOOR((lat + 0.5*dlat - SYO) / DYO) + 1 - IF(iyy .GT. 0) EXIT ! Found cell lat-edge in design grid - ENDDO - ENDIF - - ! If SMC cell definitely out of design grid domain, then cycle. - IF(ixx .LE. 0 .OR. ixx .GT. NXO .OR. & - iyy .LE. 0 .OR. iyy .GT. NYO) THEN - xidx(ISEA) = -1 - yidx(ISEA) = -1 - CYCLE - ENDIF - - XIDX(ISEA) = ixx - YIDX(ISEA) = iyy - NSMC = NSMC + 1 - SMCIDX(NSMC) = ISEA - - ! find out how many cells it covers in the x/y directions: - XSPAN(ISEA) = MAX(1, INT(mx / CELFAC)) - YSPAN(ISEA) = MAX(1, INT(my / CELFAC)) - - ! Do a bit of error checking (non fatal - just produced warning): - IF(XSPAN(ISEA) .GT. 1) THEN - IF(ABS((sxo+(ixx-1)*dxo) - lon) .GT. dxo/100.0) THEN - PRINT*, 'Potential problem with SMC grid cell span:' - PRINT*, xspan(ISEA), FLOAT(mx) / celfac - PRINT*, lon,lat - PRINT*, sxo+(ixx-1)*dxo,syo+iyy*dyo,dxo,dyo - PRINT*, "diff:", (sxo+(ixx-1)*dxo) - lon - ENDIF - ENDIF - - ! calc cell weight in relation to output grid: - WTS(ISEA) = MIN(1., DBLE(MIN(CELFAC, mx) * MIN(CELFAC, my)) / & - (CELFAC**2)) - - ENDDO - - ! Reset SXO and SYO to be the cell-centre (currently cell SW edge): - SXO = SXO + 0.5 * DXO - SYO = SYO + 0.5 * DYO - - END SUBROUTINE SMC_INTERP - -!-------------------------------------------------------------------------- -!> @brief Regrid SMC data onto a regular grid -!> -!> @details Regrids scalar data from the SMC grid onto a regular grid. -!> Uses pre-calculated grid indices and weights generated from the -!> smc_interp() subroutine. -!> -!> @remark If source field is directional data, use the w3s2xy_smcrg_dir() -!> subroutine instead. -!> -!> @param[in] S Source field, on SMC grid. -!> @param[out] XY Storage for regridded field; must be 2D array with -!> dimensions of (NXO,NYO). -!> -!> @author Chris Bunney -!> @date 02-Jul-2013 -!> - SUBROUTINE W3S2XY_SMCRG(S, XY) - - IMPLICIT NONE - - ! Input parameters: - REAL, INTENT(IN) :: S(:) - REAL, INTENT(OUT) :: XY(NXO,NYO) - - ! Local parameters - INTEGER :: I, J, IX, IY, ISEA, ISMC - - ! Initialise coverage and output arrays: - COV(:,:) = 0.0 - XY(:,:) = 0.0 - - DO ISMC=1,NSMC - ISEA = SMCIDX(ISMC) - - IF(S(ISEA) .EQ. UNDEF) CYCLE ! MDI - - ! Loop over number of spanned cells: - DO I=0, XSPAN(ISEA) - 1 - DO J=0, YSPAN(ISEA) - 1 - IX = XIDX(ISEA) + I - IY = YIDX(ISEA) + J - - ! Spans outside of grid? - IF(IX .GT. NXO .OR. IY .GT. NYO) CYCLE - - ! Interpolate: - XY(IX, IY) = XY(IX, IY) + S(ISEA) * WTS(ISEA) + ! If SMC cell definitely out of design grid domain, then cycle. + IF(ixx .LE. 0 .OR. ixx .GT. NXO .OR. & + iyy .LE. 0 .OR. iyy .GT. NYO) THEN + xidx(ISEA) = -1 + yidx(ISEA) = -1 + CYCLE + ENDIF - ! Keep track of how much of cell is (wet) covered: - COV(IX, IY) = COV(IX, IY) + WTS(ISEA) - ENDDO - ENDDO + XIDX(ISEA) = ixx + YIDX(ISEA) = iyy + NSMC = NSMC + 1 + SMCIDX(NSMC) = ISEA + + ! find out how many cells it covers in the x/y directions: + XSPAN(ISEA) = MAX(1, INT(mx / CELFAC)) + YSPAN(ISEA) = MAX(1, INT(my / CELFAC)) + + ! Do a bit of error checking (non fatal - just produced warning): + IF(XSPAN(ISEA) .GT. 1) THEN + IF(ABS((sxo+(ixx-1)*dxo) - lon) .GT. dxo/100.0) THEN + PRINT*, 'Potential problem with SMC grid cell span:' + PRINT*, xspan(ISEA), FLOAT(mx) / celfac + PRINT*, lon,lat + PRINT*, sxo+(ixx-1)*dxo,syo+iyy*dyo,dxo,dyo + PRINT*, "diff:", (sxo+(ixx-1)*dxo) - lon + ENDIF + ENDIF + ! calc cell weight in relation to output grid: + WTS(ISEA) = MIN(1., DBLE(MIN(CELFAC, mx) * MIN(CELFAC, my)) / & + (CELFAC**2)) + + ENDDO + + ! Reset SXO and SYO to be the cell-centre (currently cell SW edge): + SXO = SXO + 0.5 * DXO + SYO = SYO + 0.5 * DYO + + END SUBROUTINE SMC_INTERP + + !-------------------------------------------------------------------------- + !> @brief Regrid SMC data onto a regular grid + !> + !> @details Regrids scalar data from the SMC grid onto a regular grid. + !> Uses pre-calculated grid indices and weights generated from the + !> smc_interp() subroutine. + !> + !> @remark If source field is directional data, use the w3s2xy_smcrg_dir() + !> subroutine instead. + !> + !> @param[in] S Source field, on SMC grid. + !> @param[out] XY Storage for regridded field; must be 2D array with + !> dimensions of (NXO,NYO). + !> + !> @author Chris Bunney + !> @date 02-Jul-2013 + !> + SUBROUTINE W3S2XY_SMCRG(S, XY) + + IMPLICIT NONE + + ! Input parameters: + REAL, INTENT(IN) :: S(:) + REAL, INTENT(OUT) :: XY(NXO,NYO) + + ! Local parameters + INTEGER :: I, J, IX, IY, ISEA, ISMC + + ! Initialise coverage and output arrays: + COV(:,:) = 0.0 + XY(:,:) = 0.0 + + DO ISMC=1,NSMC + ISEA = SMCIDX(ISMC) + + IF(S(ISEA) .EQ. UNDEF) CYCLE ! MDI + + ! Loop over number of spanned cells: + DO I=0, XSPAN(ISEA) - 1 + DO J=0, YSPAN(ISEA) - 1 + IX = XIDX(ISEA) + I + IY = YIDX(ISEA) + J + + ! Spans outside of grid? + IF(IX .GT. NXO .OR. IY .GT. NYO) CYCLE + + ! Interpolate: + XY(IX, IY) = XY(IX, IY) + S(ISEA) * WTS(ISEA) + + ! Keep track of how much of cell is (wet) covered: + COV(IX, IY) = COV(IX, IY) + WTS(ISEA) + ENDDO ENDDO - ! Create coastline by masking out areas with < 50% coverage: - DO IX=1,NXO - DO IY=1,NYO - IF(MAPSMC(IX,IY) .EQ. 0) THEN - ! Make land point - XY(IX,IY) = UNDEF - ELSE IF(COV(IX,IY) .LT. 0.5) THEN - ! More than half of cell has UNDEF values - set to NOVAL: - XY(IX,IY) = NOVAL - ELSE IF(COV(IX,IY) .LT. 1.0) THEN - ! If coverage < 1.0, scale values back to full cell coverage. - ! Without this step, points around coast could end up with lower - ! waveheights due to weights not summing to 1.0: - XY(IX,IY) = XY(IX,IY) * ( 1.0 / COV(IX,IY) ) - ENDIF - ENDDO + ENDDO + + ! Create coastline by masking out areas with < 50% coverage: + DO IX=1,NXO + DO IY=1,NYO + IF(MAPSMC(IX,IY) .EQ. 0) THEN + ! Make land point + XY(IX,IY) = UNDEF + ELSE IF(COV(IX,IY) .LT. 0.5) THEN + ! More than half of cell has UNDEF values - set to NOVAL: + XY(IX,IY) = NOVAL + ELSE IF(COV(IX,IY) .LT. 1.0) THEN + ! If coverage < 1.0, scale values back to full cell coverage. + ! Without this step, points around coast could end up with lower + ! waveheights due to weights not summing to 1.0: + XY(IX,IY) = XY(IX,IY) * ( 1.0 / COV(IX,IY) ) + ENDIF ENDDO - - RETURN - - END SUBROUTINE W3S2XY_SMCRG - -!-------------------------------------------------------------------------- -!> @brief Regrid directional SMC data onto a regular grid -!> -!> @details Regrids directioanl scalar data from the SMC grid onto -!> a regular grid. Uses pre-calculated grid indices and weights -!> generated from the smc_interp() subroutine. -!> -!> @remark Functionality as per w3s2xy_smc(), but decomposes the field -!> into u/v components first to ensure proper area averaging of -!> directional data (handles cyclic transition between 359 -> 0 degrees). -!> -!> @param[in] S Directional source field, on SMC grid. -!> @param[out] XY Storage for regridded field; must be 2D array with -!> dimensions of (NXO,NYO). -!> -!> @author Chris Bunney -!> @date 02-Jul-2013 -!> - SUBROUTINE W3S2XY_SMCRG_DIR(S, XY) - - IMPLICIT NONE - - ! Input parameters: - REAL, INTENT(IN) :: S(:) - REAL, INTENT(OUT) :: XY(NXO,NYO) - - ! Local parameters - INTEGER :: I, J, IX, IY, ISEA, ISMC - REAL, ALLOCATABLE :: AUX1(:,:), AUX2(:,:) - REAL :: COSS, SINS - - ! Initialise coverage and output arrays: - ALLOCATE(AUX1(NXO,NYO),AUX2(NXO,NYO)) - COV(:,:) = 0.0 - XY(:,:) = 0.0 - AUX1(:,:) = 0.0 - AUX2(:,:) = 0.0 - - DO ISMC=1,NSMC - ISEA = SMCIDX(ISMC) - - IF(S(ISEA) .EQ. UNDEF) CYCLE ! MDI - COSS = COS(S(ISEA)) - SINS = SIN(S(ISEA)) - - ! Loop over number of spanned cells: - DO I=0, XSPAN(ISEA) - 1 - DO J=0, YSPAN(ISEA) - 1 - IX = XIDX(ISEA) + I - IY = YIDX(ISEA) + J - - ! Spans outside of grid? - IF(IX .GT. NXO .OR. IY .GT. NYO) CYCLE - - ! Interpolate: - !XY(IX, IY) = XY(IX, IY) + S(ISEA) * WTS(ISEA) - AUX1(IX, IY) = AUX1(IX, IY) + COSS * WTS(ISEA) - AUX2(IX, IY) = AUX2(IX, IY) + SINS * WTS(ISEA) - - ! Keep track of how much of cell is (wet) covered: - COV(IX, IY) = COV(IX, IY) + WTS(ISEA) - ENDDO - ENDDO - + ENDDO + + RETURN + + END SUBROUTINE W3S2XY_SMCRG + + !-------------------------------------------------------------------------- + !> @brief Regrid directional SMC data onto a regular grid + !> + !> @details Regrids directioanl scalar data from the SMC grid onto + !> a regular grid. Uses pre-calculated grid indices and weights + !> generated from the smc_interp() subroutine. + !> + !> @remark Functionality as per w3s2xy_smc(), but decomposes the field + !> into u/v components first to ensure proper area averaging of + !> directional data (handles cyclic transition between 359 -> 0 degrees). + !> + !> @param[in] S Directional source field, on SMC grid. + !> @param[out] XY Storage for regridded field; must be 2D array with + !> dimensions of (NXO,NYO). + !> + !> @author Chris Bunney + !> @date 02-Jul-2013 + !> + SUBROUTINE W3S2XY_SMCRG_DIR(S, XY) + + IMPLICIT NONE + + ! Input parameters: + REAL, INTENT(IN) :: S(:) + REAL, INTENT(OUT) :: XY(NXO,NYO) + + ! Local parameters + INTEGER :: I, J, IX, IY, ISEA, ISMC + REAL, ALLOCATABLE :: AUX1(:,:), AUX2(:,:) + REAL :: COSS, SINS + + ! Initialise coverage and output arrays: + ALLOCATE(AUX1(NXO,NYO),AUX2(NXO,NYO)) + COV(:,:) = 0.0 + XY(:,:) = 0.0 + AUX1(:,:) = 0.0 + AUX2(:,:) = 0.0 + + DO ISMC=1,NSMC + ISEA = SMCIDX(ISMC) + + IF(S(ISEA) .EQ. UNDEF) CYCLE ! MDI + COSS = COS(S(ISEA)) + SINS = SIN(S(ISEA)) + + ! Loop over number of spanned cells: + DO I=0, XSPAN(ISEA) - 1 + DO J=0, YSPAN(ISEA) - 1 + IX = XIDX(ISEA) + I + IY = YIDX(ISEA) + J + + ! Spans outside of grid? + IF(IX .GT. NXO .OR. IY .GT. NYO) CYCLE + + ! Interpolate: + !XY(IX, IY) = XY(IX, IY) + S(ISEA) * WTS(ISEA) + AUX1(IX, IY) = AUX1(IX, IY) + COSS * WTS(ISEA) + AUX2(IX, IY) = AUX2(IX, IY) + SINS * WTS(ISEA) + + ! Keep track of how much of cell is (wet) covered: + COV(IX, IY) = COV(IX, IY) + WTS(ISEA) + ENDDO ENDDO - ! Create coastline by masking out areas with < 50% coverage: - DO IX=1,NXO - DO IY=1,NYO - IF(MAPSMC(IX,IY) .EQ. 0) THEN - ! Make land point - XY(IX,IY) = UNDEF - ELSE IF(COV(IX,IY) .LT. 0.5) THEN - ! More than half of cell has UNDEF values - set to NOVAL - XY(IX,IY) = NOVAL - ELSE IF(COV(IX,IY) .LT. 1.0) THEN - ! If coverage < 1.0, scale values back to full cell coverage. - ! Without this step, points around coast could end up with lower - ! waveheights due to weights not summing to 1.0: - XY(IX,IY) = ATAN2(AUX2(IX,IY), AUX1(IX,IY)) - XY(IX,IY) = MOD(630. - RADE * XY(IX,IY), 360. ) - ELSE - XY(IX,IY) = ATAN2(AUX2(IX,IY), AUX1(IX,IY)) - XY(IX,IY) = MOD(630. - RADE * XY(IX,IY), 360. ) - ENDIF - ENDDO + ENDDO + + ! Create coastline by masking out areas with < 50% coverage: + DO IX=1,NXO + DO IY=1,NYO + IF(MAPSMC(IX,IY) .EQ. 0) THEN + ! Make land point + XY(IX,IY) = UNDEF + ELSE IF(COV(IX,IY) .LT. 0.5) THEN + ! More than half of cell has UNDEF values - set to NOVAL + XY(IX,IY) = NOVAL + ELSE IF(COV(IX,IY) .LT. 1.0) THEN + ! If coverage < 1.0, scale values back to full cell coverage. + ! Without this step, points around coast could end up with lower + ! waveheights due to weights not summing to 1.0: + XY(IX,IY) = ATAN2(AUX2(IX,IY), AUX1(IX,IY)) + XY(IX,IY) = MOD(630. - RADE * XY(IX,IY), 360. ) + ELSE + XY(IX,IY) = ATAN2(AUX2(IX,IY), AUX1(IX,IY)) + XY(IX,IY) = MOD(630. - RADE * XY(IX,IY), 360. ) + ENDIF ENDDO + ENDDO - RETURN - - END SUBROUTINE W3S2XY_SMCRG_DIR - -!-------------------------------------------------------------------------- -!> @brief Calculates a new MAPSTA using SMC grid cell averaging. -!> -!> @author Chris Bunney -!> @date 02-Jul-2013 -!> - SUBROUTINE MAPSTA_SMC() + RETURN - IMPLICIT NONE + END SUBROUTINE W3S2XY_SMCRG_DIR - ! Local parameters - INTEGER :: I, J, IX, IY, IMX, IMY, ISEA + !-------------------------------------------------------------------------- + !> @brief Calculates a new MAPSTA using SMC grid cell averaging. + !> + !> @author Chris Bunney + !> @date 02-Jul-2013 + !> + SUBROUTINE MAPSTA_SMC() - ! Initialise coverage and output arrays: - COV(:,:) = 0.0 - MAPSMC(:,:) = 0 + IMPLICIT NONE - DO ISEA=1,NSEA - IMX = MAPSF(ISEA,1) - IMY = MAPSF(ISEA,2) + ! Local parameters + INTEGER :: I, J, IX, IY, IMX, IMY, ISEA - IF(XIDX(ISEA) .EQ. -1) CYCLE ! Out of grid + ! Initialise coverage and output arrays: + COV(:,:) = 0.0 + MAPSMC(:,:) = 0 - ! Loop over number of spanned cells: - DO I=0, XSPAN(ISEA) - 1 - DO J=0, YSPAN(ISEA) - 1 - IX = XIDX(ISEA) + I - IY = YIDX(ISEA) + J + DO ISEA=1,NSEA + IMX = MAPSF(ISEA,1) + IMY = MAPSF(ISEA,2) - ! Spans outside of grid? - IF(IX .GT. NXO .OR. IY .GT. NYO) CYCLE + IF(XIDX(ISEA) .EQ. -1) CYCLE ! Out of grid - ! MAPSTA values: 0=Excluded, (+-)1=Sea, (+-2)=Input boundary - ! We will just keep track of sea and non-sea points: - IF(MAPSTA(IMY, IMX) .NE. 0) THEN - ! Keep track of how much of cell is (wet) covered: - COV(IX, IY) = COV(IX, IY) + WTS(ISEA) - ENDIF - ENDDO - ENDDO + ! Loop over number of spanned cells: + DO I=0, XSPAN(ISEA) - 1 + DO J=0, YSPAN(ISEA) - 1 + IX = XIDX(ISEA) + I + IY = YIDX(ISEA) + J - ENDDO + ! Spans outside of grid? + IF(IX .GT. NXO .OR. IY .GT. NYO) CYCLE - ! Create coastline by masking out areas with < 50% coverage: - DO IX=1,NXO - DO IY=1,NYO - IF(COV(IX,IY) .LT. 0.5) THEN - MAPSMC(IX, IY) = 0 - ELSE - MAPSMC(IX, IY) = 1 - ENDIF - ENDDO + ! MAPSTA values: 0=Excluded, (+-)1=Sea, (+-2)=Input boundary + ! We will just keep track of sea and non-sea points: + IF(MAPSTA(IMY, IMX) .NE. 0) THEN + ! Keep track of how much of cell is (wet) covered: + COV(IX, IY) = COV(IX, IY) + WTS(ISEA) + ENDIF + ENDDO ENDDO - RETURN - - END SUBROUTINE MAPSTA_SMC - -!-------------------------------------------------------------------------- -!> @brief Read interpolation information from smcint.ww3 -!> -!> @details Reads the interpolation indices and distance weights from the -!> smcint.ww3 file generated by ww3_smcint program. -!> -!> @author Chris Bunney -!> @date 18-Apr-2018 -!> - SUBROUTINE READ_SMCINT() - - USE W3SERVMD, ONLY: EXTCDE - IMPLICIT NONE - - ! Locals - INTEGER :: IERR, I, J - REAL :: PLATO, PLONO ! Not used yet....future version might allow - ! output to a rotated pole grid... - - NDSMC = 50 - OPEN(NDSMC, file='smcint.ww3', status='old', form='unformatted', convert=file_endian, iostat=ierr) - IF(ierr .NE. 0) THEN - WRITE(*,*) "ERROR! Failed to open smcint.ww3 for reading" - CALL EXTCDE(1) - ENDIF - - ! Header - READ(NDSMC) NXO, NYO, SXO, SYO, DXO, DYO, PLONO, PLATO - ALLOCATE(NNIDX(NXO,NYO), XDIST(NXO,NYO), YDIST(NXO,NYO)) - - ! Indices and weights: - READ(NDSMC)((NNIDX(I,J), XDIST(I,J), YDIST(I,J),I=1,NXO),J=1,NYO) - - CLOSE(NDSMC) - - END SUBROUTINE READ_SMCINT + ENDDO -!-------------------------------------------------------------------------- -!> @brief Calculates weights for SMC to arbitrary grid intepolation. -!> -!> @details -!> Calculates the interpolation indices and weights for regridding -!> an SMC grid to an arbitrary regular grid. Calculated index is that of -!> the SMC cell that contains output cell centre. Weights are the distance -!> in metres between the output and SMC cell centres. -!> -!> A future version may allow for output grids to be on a -!> rotated pole. -!> -!> @author Chris Bunney -!> @date 18-Apr-2018 -!> - SUBROUTINE CALC_INTERP() - - USE W3GDATMD, ONLY: CLATS - USE CONSTANTS, ONLY : DERA, RADIUS + ! Create coastline by masking out areas with < 50% coverage: + DO IX=1,NXO + DO IY=1,NYO + IF(COV(IX,IY) .LT. 0.5) THEN + MAPSMC(IX, IY) = 0 + ELSE + MAPSMC(IX, IY) = 1 + ENDIF + ENDDO + ENDDO + + RETURN + + END SUBROUTINE MAPSTA_SMC + + !-------------------------------------------------------------------------- + !> @brief Read interpolation information from smcint.ww3 + !> + !> @details Reads the interpolation indices and distance weights from the + !> smcint.ww3 file generated by ww3_smcint program. + !> + !> @author Chris Bunney + !> @date 18-Apr-2018 + !> + SUBROUTINE READ_SMCINT() + + USE W3SERVMD, ONLY: EXTCDE + IMPLICIT NONE + + ! Locals + INTEGER :: IERR, I, J + REAL :: PLATO, PLONO ! Not used yet....future version might allow + ! output to a rotated pole grid... + + NDSMC = 50 + OPEN(NDSMC, file='smcint.ww3', status='old', form='unformatted', convert=file_endian, iostat=ierr) + IF(ierr .NE. 0) THEN + WRITE(*,*) "ERROR! Failed to open smcint.ww3 for reading" + CALL EXTCDE(1) + ENDIF + + ! Header + READ(NDSMC) NXO, NYO, SXO, SYO, DXO, DYO, PLONO, PLATO + ALLOCATE(NNIDX(NXO,NYO), XDIST(NXO,NYO), YDIST(NXO,NYO)) + + ! Indices and weights: + READ(NDSMC)((NNIDX(I,J), XDIST(I,J), YDIST(I,J),I=1,NXO),J=1,NYO) + + CLOSE(NDSMC) + + END SUBROUTINE READ_SMCINT + + !-------------------------------------------------------------------------- + !> @brief Calculates weights for SMC to arbitrary grid intepolation. + !> + !> @details + !> Calculates the interpolation indices and weights for regridding + !> an SMC grid to an arbitrary regular grid. Calculated index is that of + !> the SMC cell that contains output cell centre. Weights are the distance + !> in metres between the output and SMC cell centres. + !> + !> A future version may allow for output grids to be on a + !> rotated pole. + !> + !> @author Chris Bunney + !> @date 18-Apr-2018 + !> + SUBROUTINE CALC_INTERP() + + USE W3GDATMD, ONLY: CLATS + USE CONSTANTS, ONLY : DERA, RADIUS #ifdef W3_RTD - USE W3SERVMD, ONLY: W3LLTOEQ - USE W3GDATMD, ONLY: POLON, POLAT + USE W3SERVMD, ONLY: W3LLTOEQ + USE W3GDATMD, ONLY: POLON, POLAT #endif - IMPLICIT NONE - INTEGER :: IERR, I, J, ISEA, N, CFAC - REAL :: mlon(NSEA), mlat(NSEA), olon(nxo,nyo), olat(nxo,nyo), & - ang(nxo,nyo), lon, lat + IMPLICIT NONE + INTEGER :: IERR, I, J, ISEA, N, CFAC + REAL :: mlon(NSEA), mlat(NSEA), olon(nxo,nyo), olat(nxo,nyo), & + ang(nxo,nyo), lon, lat #ifdef W3_RTD - REAL :: tmplon(nxo,nyo), tmplat(nxo,nyo) + REAL :: tmplon(nxo,nyo), tmplat(nxo,nyo) #endif - ! Determine smallest cell size factor: - cfac = 2**(NRLv - 1) + ! Determine smallest cell size factor: + cfac = 2**(NRLv - 1) - ! Get smallest SMC grid cells step size: - dlat = SY / cfac - dlon = SX / cfac + ! Get smallest SMC grid cells step size: + dlat = SY / cfac + dlon = SX / cfac - ALLOCATE(xdist(nx,ny), ydist(ny,nx)) + ALLOCATE(xdist(nx,ny), ydist(ny,nx)) - ! Model lat/lons: - DO ISEA = 1,NSEA - mlon(isea) = (X0-0.5*SX) + (IJKCel(1,ISEA) + 0.5 * IJKCel(3,ISEA)) * dlon - mlat(isea) = (Y0-0.5*SY) + (IJKCel(2,ISEA) + 0.5 * IJKCel(4,ISEA)) * dlat - ENDDO + ! Model lat/lons: + DO ISEA = 1,NSEA + mlon(isea) = (X0-0.5*SX) + (IJKCel(1,ISEA) + 0.5 * IJKCel(3,ISEA)) * dlon + mlat(isea) = (Y0-0.5*SY) + (IJKCel(2,ISEA) + 0.5 * IJKCel(4,ISEA)) * dlat + ENDDO - ! Generate output grid cell centres: - DO I=1,NXO - DO J=1,NYO - olon(i,J) = SXO + (I-1) * DXO - olat(i,J) = SYO + (J-1) * DYO - ENDDO + ! Generate output grid cell centres: + DO I=1,NXO + DO J=1,NYO + olon(i,J) = SXO + (I-1) * DXO + olat(i,J) = SYO + (J-1) * DYO ENDDO + ENDDO #ifdef W3_RTD - tmplat = olat - tmplon = olon - PRINT*,'Rotating coordinates' - CALL W3LLTOEQ ( tmplat, tmplon, olat, olon, & - ang, POLAT, POLON, NXO*NYO ) - PRINT*,'Rotating coordinates complete' + tmplat = olat + tmplon = olon + PRINT*,'Rotating coordinates' + CALL W3LLTOEQ ( tmplat, tmplon, olat, olon, & + ang, POLAT, POLON, NXO*NYO ) + PRINT*,'Rotating coordinates complete' #endif - ! Cycle over output grid points and find containing SMC cell: - ! NOTE : BRUTE FORCE! - NNIDX(:,:) = -1 - DO I=1,NXO - PRINT*,I,' of ',NXO - DO J=1,NYO - lon = olon(i,j) - lat = olat(i,j) - IF(lon .LT. X0 - SX / 2) lon = lon + 360.0 - IF(lon .GT. (X0 + (NX-1) * SX) + 0.5 * SX) lon = lon - 360.0 - DO ISEA=1,NSEA - IF(mlon(ISEA) - 0.5 * IJKCel(3,ISEA) * dlon .LE. lon .AND. & - mlon(ISEA) + 0.5 * IJKCel(3,ISEA) * dlon .GE. lon .AND. & - mlat(ISEA) - 0.5 * IJKCel(4,ISEA) * dlat .LE. lat .AND. & - mlat(ISEA) + 0.5 * IJKCel(4,ISEA) * dlat .GE. lat ) THEN - ! Match! - NNIDX(I,J) = ISEA - xdist(I,J) = (lon - mlon(ISEA)) * DERA * RADIUS * CLats(ISEA) - ydist(I,J) = (lat - mlat(ISEA)) * DERA * RADIUS - EXIT - ENDIF - ENDDO + ! Cycle over output grid points and find containing SMC cell: + ! NOTE : BRUTE FORCE! + NNIDX(:,:) = -1 + DO I=1,NXO + PRINT*,I,' of ',NXO + DO J=1,NYO + lon = olon(i,j) + lat = olat(i,j) + IF(lon .LT. X0 - SX / 2) lon = lon + 360.0 + IF(lon .GT. (X0 + (NX-1) * SX) + 0.5 * SX) lon = lon - 360.0 + DO ISEA=1,NSEA + IF(mlon(ISEA) - 0.5 * IJKCel(3,ISEA) * dlon .LE. lon .AND. & + mlon(ISEA) + 0.5 * IJKCel(3,ISEA) * dlon .GE. lon .AND. & + mlat(ISEA) - 0.5 * IJKCel(4,ISEA) * dlat .LE. lat .AND. & + mlat(ISEA) + 0.5 * IJKCel(4,ISEA) * dlat .GE. lat ) THEN + ! Match! + NNIDX(I,J) = ISEA + xdist(I,J) = (lon - mlon(ISEA)) * DERA * RADIUS * CLats(ISEA) + ydist(I,J) = (lat - mlat(ISEA)) * DERA * RADIUS + EXIT + ENDIF ENDDO ENDDO - - END SUBROUTINE CALC_INTERP - -!-------------------------------------------------------------------------- -!> @brief Fill regular grid using nearest SMC point data -!> -!> @details Directional fields (DIRN=True) will be assumed to be in radians -!> and will be converted to degrees in nautical convention. -!> -!> @param[in] S Input array on SMC grid -!> @param[out] XY Output array to store interpolated 2D field -!> @param[in] DIRN Set to .TRUE. if S is a directional field -!> -!> @author Chris Bunney -!> @date 18-Apr-2018 -!> - SUBROUTINE W3S2XY_SMCNN(S, XY, DIRN) - - IMPLICIT NONE - - ! Input parameters: - REAL, INTENT(IN) :: S(:) ! Inupt array - REAL, INTENT(OUT) :: XY(NXO,NYO) ! Output data - LOGICAL, INTENT(IN) :: DIRN ! Directional field? - - ! Local parameters - INTEGER :: I, J, IX, IY, ISEA, ISMC - DO IX = 1,NXO - DO IY = 1,NYO - ISEA = NNIDX(IX,IY) ! Nearest neighbour SMC point - IF(ISEA .EQ. -1) THEN - ! Land - XY(IX,IY) = UNDEF - ELSE - IF(S(ISEA) .EQ. UNDEF) THEN - ! Set undefined sea points to NOVAL - XY(IX,IY) = NOVAL - ELSE - XY(IX,IY) = S(ISEA) - IF(DIRN) THEN - ! Convert direction fields to degrees nautical - XY(IX,IY) = MOD(630. - RADE * XY(IX,IY), 360.0) - ENDIF - ENDIF - ENDIF - ENDDO + ENDDO + + END SUBROUTINE CALC_INTERP + + !-------------------------------------------------------------------------- + !> @brief Fill regular grid using nearest SMC point data + !> + !> @details Directional fields (DIRN=True) will be assumed to be in radians + !> and will be converted to degrees in nautical convention. + !> + !> @param[in] S Input array on SMC grid + !> @param[out] XY Output array to store interpolated 2D field + !> @param[in] DIRN Set to .TRUE. if S is a directional field + !> + !> @author Chris Bunney + !> @date 18-Apr-2018 + !> + SUBROUTINE W3S2XY_SMCNN(S, XY, DIRN) + + IMPLICIT NONE + + ! Input parameters: + REAL, INTENT(IN) :: S(:) ! Inupt array + REAL, INTENT(OUT) :: XY(NXO,NYO) ! Output data + LOGICAL, INTENT(IN) :: DIRN ! Directional field? + + ! Local parameters + INTEGER :: I, J, IX, IY, ISEA, ISMC + DO IX = 1,NXO + DO IY = 1,NYO + ISEA = NNIDX(IX,IY) ! Nearest neighbour SMC point + IF(ISEA .EQ. -1) THEN + ! Land + XY(IX,IY) = UNDEF + ELSE + IF(S(ISEA) .EQ. UNDEF) THEN + ! Set undefined sea points to NOVAL + XY(IX,IY) = NOVAL + ELSE + XY(IX,IY) = S(ISEA) + IF(DIRN) THEN + ! Convert direction fields to degrees nautical + XY(IX,IY) = MOD(630. - RADE * XY(IX,IY), 360.0) + ENDIF + ENDIF + ENDIF ENDDO - - END SUBROUTINE W3S2XY_SMCNN - -!-------------------------------------------------------------------------- -!> @brief Nearest neighbour interpolation -!> -!> @details Fill regular grid using nearest SMC point data and interpolate -!> output value based on local gradient and distance between grid -!> cell centres. -!> -!> Directional fields (DIRN=True) will be assumed to be in radians -!> and will be converted to degrees in nautical convention. -!> -!> @param[in] S Input array on SMC grid -!> @param[out] XY Output array to store interpolated 2D field -!> @param[in] DIRN Set to .TRUE. if S is a directional field -!> -!> @author Chris Bunney -!> @date 18-Apr-2018 -!> - SUBROUTINE W3S2XY_SMCNN_INT(S, XY, DIRN) - - USE W3PSMCMD, ONLY: SMCGradn - IMPLICIT NONE - - ! Input parameters: - REAL, INTENT(IN) :: S(:) ! Input array - REAL, INTENT(OUT) :: XY(NXO,NYO) ! Output array - LOGICAL, INTENT(IN) :: DIRN ! Directional field? - - ! Locals - INTEGER :: I, J, IX, IY, ISEA, ISMC - REAL :: CVQ(-9:NSEA) - REAL :: GrdX(NSEA), GrdY(NSEA) - - ! Calculate local gradients: - CVQ(1:NSEA) = S ! Need to copy S into array with bounds starting at -9 - CALL SMCGradn(CVQ, GrdX, GrdY, 0) - - ! Interpolate: - DO IX = 1,NXO - DO IY = 1,NYO - ISEA = NNIDX(IX,IY) ! Nearest neighbour SMC point - IF(ISEA .EQ. -1) THEN - XY(IX,IY) = UNDEF - ELSE - ! Interpolate using local gradient and distance from cell centre: - XY(IX,IY) = S(ISEA) + grdx(isea) * xdist(ix,iy) + grdy(isea) * ydist(ix,iy) - IF(DIRN) THEN - ! Convert direction fields to degrees nautical - XY(IX,IY) = MOD(630. - RADE * XY(IX,IY), 360.0) - ENDIF - ENDIF - ENDDO + ENDDO + + END SUBROUTINE W3S2XY_SMCNN + + !-------------------------------------------------------------------------- + !> @brief Nearest neighbour interpolation + !> + !> @details Fill regular grid using nearest SMC point data and interpolate + !> output value based on local gradient and distance between grid + !> cell centres. + !> + !> Directional fields (DIRN=True) will be assumed to be in radians + !> and will be converted to degrees in nautical convention. + !> + !> @param[in] S Input array on SMC grid + !> @param[out] XY Output array to store interpolated 2D field + !> @param[in] DIRN Set to .TRUE. if S is a directional field + !> + !> @author Chris Bunney + !> @date 18-Apr-2018 + !> + SUBROUTINE W3S2XY_SMCNN_INT(S, XY, DIRN) + + USE W3PSMCMD, ONLY: SMCGradn + IMPLICIT NONE + + ! Input parameters: + REAL, INTENT(IN) :: S(:) ! Input array + REAL, INTENT(OUT) :: XY(NXO,NYO) ! Output array + LOGICAL, INTENT(IN) :: DIRN ! Directional field? + + ! Locals + INTEGER :: I, J, IX, IY, ISEA, ISMC + REAL :: CVQ(-9:NSEA) + REAL :: GrdX(NSEA), GrdY(NSEA) + + ! Calculate local gradients: + CVQ(1:NSEA) = S ! Need to copy S into array with bounds starting at -9 + CALL SMCGradn(CVQ, GrdX, GrdY, 0) + + ! Interpolate: + DO IX = 1,NXO + DO IY = 1,NYO + ISEA = NNIDX(IX,IY) ! Nearest neighbour SMC point + IF(ISEA .EQ. -1) THEN + XY(IX,IY) = UNDEF + ELSE + ! Interpolate using local gradient and distance from cell centre: + XY(IX,IY) = S(ISEA) + grdx(isea) * xdist(ix,iy) + grdy(isea) * ydist(ix,iy) + IF(DIRN) THEN + ! Convert direction fields to degrees nautical + XY(IX,IY) = MOD(630. - RADE * XY(IX,IY), 360.0) + ENDIF + ENDIF ENDDO - - END SUBROUTINE W3S2XY_SMCNN_INT -!-------------------------------------------------------------------------- - -!-------------------------------------------------------------------------- -!> @brief Entry point for SMC version of W3S2XY. -!> -!> @details Dispatches to regridding subroutine based on SMCOTYPE. -!> Optional DIR logical specifies whether field is a directional -!> value; in which case it will be decomposed into u/v components -!> prior to any interpolation. -!> -!> @param[in] S Input array on SMC grid -!> @param[out] XY Output array to store interpolated 2D field -!> @param[in] DIR (Optional) Set to .TRUE. if S is a directional field -!> -!> @author Chris Bunney -!> @date 18-Apr-2018 -!> - SUBROUTINE W3S2XY_SMC(S, XY, DIR) - - IMPLICIT NONE - - REAL, INTENT(IN) :: S(:) - REAL, INTENT(OUT) :: XY(NXO,NYO) - LOGICAL, OPTIONAL :: DIR - - LOGICAL :: DIRN - INTEGER :: ISEA - - IF(PRESENT(DIR)) THEN - DIRN = DIR - ELSE - DIRN = .false. + ENDDO + + END SUBROUTINE W3S2XY_SMCNN_INT + !-------------------------------------------------------------------------- + + !-------------------------------------------------------------------------- + !> @brief Entry point for SMC version of W3S2XY. + !> + !> @details Dispatches to regridding subroutine based on SMCOTYPE. + !> Optional DIR logical specifies whether field is a directional + !> value; in which case it will be decomposed into u/v components + !> prior to any interpolation. + !> + !> @param[in] S Input array on SMC grid + !> @param[out] XY Output array to store interpolated 2D field + !> @param[in] DIR (Optional) Set to .TRUE. if S is a directional field + !> + !> @author Chris Bunney + !> @date 18-Apr-2018 + !> + SUBROUTINE W3S2XY_SMC(S, XY, DIR) + + IMPLICIT NONE + + REAL, INTENT(IN) :: S(:) + REAL, INTENT(OUT) :: XY(NXO,NYO) + LOGICAL, OPTIONAL :: DIR + + LOGICAL :: DIRN + INTEGER :: ISEA + + IF(PRESENT(DIR)) THEN + DIRN = DIR + ELSE + DIRN = .false. + ENDIF + + IF(SMCOTYPE .EQ. 1) THEN + ! Flat sea point array + XY(:,1) = PACK(S, SMCMASK) + IF(DIRN) THEN + ! Convert to nautical convention in degrees + DO ISEA=1,NXO + IF(XY(ISEA,1) .NE. UNDEF) THEN + XY(ISEA,1) = MOD(630. - RADE * XY(ISEA,1), 360.) + ENDIF + ENDDO ENDIF - - IF(SMCOTYPE .EQ. 1) THEN - ! Flat sea point array - XY(:,1) = PACK(S, SMCMASK) - IF(DIRN) THEN - ! Convert to nautical convention in degrees - DO ISEA=1,NXO - IF(XY(ISEA,1) .NE. UNDEF) THEN - XY(ISEA,1) = MOD(630. - RADE * XY(ISEA,1), 360.) - ENDIF - ENDDO - ENDIF - ELSEIF(SMCOTYPE .EQ. 2) THEN - ! Regular gridded SMC cells - IF(DIRN) THEN - CALL W3S2XY_SMCRG_DIR(S, XY) - ELSE - CALL W3S2XY_SMCRG(S, XY) - ENDIF - ELSEIF(SMCOTYPE .EQ. 3) THEN - ! Regridded to arbitrary regular grid with interpolation - CALL W3S2XY_SMCNN_INT(S, XY, DIRN) - ELSEIF(SMCOTYPE .EQ. 4) THEN - ! Regridded to arbitrary regular grid - no interpolation - CALL W3S2XY_SMCNN(S, XY, DIRN) + ELSEIF(SMCOTYPE .EQ. 2) THEN + ! Regular gridded SMC cells + IF(DIRN) THEN + CALL W3S2XY_SMCRG_DIR(S, XY) ELSE - WRITE(*,*) "Uknonwn SMC type!", SMCOTYPE - ! Unknown SMC type! - STOP + CALL W3S2XY_SMCRG(S, XY) ENDIF - - END SUBROUTINE W3S2XY_SMC -!-------------------------------------------------------------------------- - - END MODULE W3SMCOMD + ELSEIF(SMCOTYPE .EQ. 3) THEN + ! Regridded to arbitrary regular grid with interpolation + CALL W3S2XY_SMCNN_INT(S, XY, DIRN) + ELSEIF(SMCOTYPE .EQ. 4) THEN + ! Regridded to arbitrary regular grid - no interpolation + CALL W3S2XY_SMCNN(S, XY, DIRN) + ELSE + WRITE(*,*) "Uknonwn SMC type!", SMCOTYPE + ! Unknown SMC type! + STOP + ENDIF + + END SUBROUTINE W3S2XY_SMC + !-------------------------------------------------------------------------- + +END MODULE W3SMCOMD diff --git a/model/src/w3snl1md.F90 b/model/src/w3snl1md.F90 index b1071f68a..20ba8f5fa 100644 --- a/model/src/w3snl1md.F90 +++ b/model/src/w3snl1md.F90 @@ -1,732 +1,729 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SNL1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 03-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 04-Feb-2000 : Origination. ( version 2.00 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 03-Sep-2012 : Clean up of test output T0, T1 ( version 4.07 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Bundles routines calculate nonlinear wave-wave interactions -! according to the Discrete Interaction Approximation (DIA) of -! Hasselmann et al. (JPO, 1985). -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SNL1 Subr. Public Calculate interactions. -! INSNL1 Subr. Public Initialization routine. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T(n) Test output, see subroutines. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SNL1 (A, CG, KDMEAN, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 12-Jun-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 03-Sep-2012 : Clean up of test output T0, T1 ( version 4.07 ) -!/ 06-Jun-2018 : Add optional DEBUGSRC ( version 6.04 ) -!/ -! 1. Purpose : -! -! Calculate nonlinear interactions and the diagonal term of -! its derivative. -! -! 2. Method : -! -! Discrete interaction approximation. (Hasselmann and Hasselmann -! 1985; WAMDI group 1988) -! -! The DIA is applied to the energy spectrum (instead of the action -! spectrum), for which is was originally developped. Because the -! frequency grid is invariant, the nonlinear interactions are -! calculated for the frequency spectrum, as in WAM. This requires -! only a single set of interpolation data which can be applied -! throughout the spatial domain. For deep water this is idenitical -! to a direct application to the wavenumber spectrum, for shallow -! water it is not. As the shallow water correction is nothing but -! a crude approximation, the choice between spectra is expected to -! be irrelevant. -! -! The nonlinear interactions are calculated for two "mirror image" -! quadruplets as described in the manual. The central bin of these -! quadruples is placed on the discrete complonents of the spectrum, -! which requires interpolation to obtain other eneregy densities. -! The figure below defines the diferent basic counters and weights -! necessary for this interpolation. -! -! -! IFRM1 IFRM -! 5 7 T | -! ITHM1 +------+ H + -! | | E | IFRP IFRP1 -! | \ | T | 3 1 -! ITHM +------+ A + +---------+ ITHP1 -! 6 \8 | | | -! | | / | -! \ + +---------+ ITHP -! | /4 2 -! \ | / -! -+-----+------+-------#--------+---------+----------+ -! / | \ FREQ. -! | \4 2 -! / + +---------+ ITHP -! | | \ | -! 6 /8 | | | -! ITHM +------+ + +---------+ ITHP1 -! | \ | | 3 1 -! | | | IFRP IFRP1 -! ITHM1 +------+ + -! 5 7 | -! -! To create long vector loops and to efficiently deal with the -! closed nature of the directional space, the relative counters -! above are replaced by complete addresses stored in 32 arrays -! (see section 3 and INSNL1). The interaction are furthermore -! calucated for an extended spectrum, making it unnecessary to -! introduce extra weight factors for low and high frequencies. -! Therefore low and high frequencies are added to the local -! (auxiliary) spectrum as illustraed below. -! -! -! ^ +---+---------------------+---------+- NTH -! | | : : | -! | : : | -! d | 2 : original spectrum : 1 | -! i | : : | -! r | : : | -! +---+---------------------+---------+- 1 -! Frequencies --> ^ -! IFR = 0 1 NFR | NFRHGH -! | -! NFRCHG -! -! where : 1 : Extra tail added beyond NFR -! 2 : Empty bins at low frequencies -! -! NFRHGH = NFR + IFRP1 - IFRM1 -! NFRCHG = NFR - IFRM1 -! -! All counters and arrays are set in INSNL1. See also section 3 -! and section 8. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action spectrum A(ISP) as a function of -! direction (rad) and wavenumber. -! CG R.A. I Group velocities (dimension NK). -! KDMEAN Real I Mean relative depth. -! S R.A. O Source term. *) -! D R.A. O Diagonal term of derivative. *) -! ---------------------------------------------------------------- -! *) 1-D array with dimension NTH*NK -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! PRT2DS Subr. W3ARRYMD Print plot of spectra. -! OUTMAT Subr. W3WRRYMD Print out 2D matrix. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! None. -! -! 8. Structure : -! -! ------------------------------------------- -! 1. Calculate proportionality constant. -! 2. Prepare auxiliary spectrum -! 3. Calculate (unfolded) interactions -! a Energy at interacting bins -! b Contribution to interactions -! c Fold interactions to side angles -! 4. Put source and diagonal term together -! ------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, FACHFE, & - KDCON, KDMN, SNLC1, SNLS1, SNLS2, SNLS3 - USE W3ADATMD, ONLY: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY, & - IP11, IP12, IP13, IP14, IM11, IM12, IM13, IM14, & - IP21, IP22, IP23, IP24, IM21, IM22, IM23, IM24, & - IC11, IC12, IC21, IC22, IC31, IC32, IC41, IC42, & - IC51, IC52, IC61, IC62, IC71, IC72, IC81, IC82, & - DAL1, DAL2, DAL3, AF11, & - AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, AWG7, AWG8, & - SWG1, SWG2, SWG3, SWG4, SWG5, SWG6, SWG7, SWG8 +MODULE W3SNL1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 03-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 04-Feb-2000 : Origination. ( version 2.00 ) + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 03-Sep-2012 : Clean up of test output T0, T1 ( version 4.07 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Bundles routines calculate nonlinear wave-wave interactions + ! according to the Discrete Interaction Approximation (DIA) of + ! Hasselmann et al. (JPO, 1985). + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SNL1 Subr. Public Calculate interactions. + ! INSNL1 Subr. Public Initialization routine. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T(n) Test output, see subroutines. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SNL1 (A, CG, KDMEAN, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 12-Jun-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 03-Sep-2012 : Clean up of test output T0, T1 ( version 4.07 ) + !/ 06-Jun-2018 : Add optional DEBUGSRC ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Calculate nonlinear interactions and the diagonal term of + ! its derivative. + ! + ! 2. Method : + ! + ! Discrete interaction approximation. (Hasselmann and Hasselmann + ! 1985; WAMDI group 1988) + ! + ! The DIA is applied to the energy spectrum (instead of the action + ! spectrum), for which is was originally developped. Because the + ! frequency grid is invariant, the nonlinear interactions are + ! calculated for the frequency spectrum, as in WAM. This requires + ! only a single set of interpolation data which can be applied + ! throughout the spatial domain. For deep water this is idenitical + ! to a direct application to the wavenumber spectrum, for shallow + ! water it is not. As the shallow water correction is nothing but + ! a crude approximation, the choice between spectra is expected to + ! be irrelevant. + ! + ! The nonlinear interactions are calculated for two "mirror image" + ! quadruplets as described in the manual. The central bin of these + ! quadruples is placed on the discrete complonents of the spectrum, + ! which requires interpolation to obtain other eneregy densities. + ! The figure below defines the diferent basic counters and weights + ! necessary for this interpolation. + ! + ! + ! IFRM1 IFRM + ! 5 7 T | + ! ITHM1 +------+ H + + ! | | E | IFRP IFRP1 + ! | \ | T | 3 1 + ! ITHM +------+ A + +---------+ ITHP1 + ! 6 \8 | | | + ! | | / | + ! \ + +---------+ ITHP + ! | /4 2 + ! \ | / + ! -+-----+------+-------#--------+---------+----------+ + ! / | \ FREQ. + ! | \4 2 + ! / + +---------+ ITHP + ! | | \ | + ! 6 /8 | | | + ! ITHM +------+ + +---------+ ITHP1 + ! | \ | | 3 1 + ! | | | IFRP IFRP1 + ! ITHM1 +------+ + + ! 5 7 | + ! + ! To create long vector loops and to efficiently deal with the + ! closed nature of the directional space, the relative counters + ! above are replaced by complete addresses stored in 32 arrays + ! (see section 3 and INSNL1). The interaction are furthermore + ! calucated for an extended spectrum, making it unnecessary to + ! introduce extra weight factors for low and high frequencies. + ! Therefore low and high frequencies are added to the local + ! (auxiliary) spectrum as illustraed below. + ! + ! + ! ^ +---+---------------------+---------+- NTH + ! | | : : | + ! | : : | + ! d | 2 : original spectrum : 1 | + ! i | : : | + ! r | : : | + ! +---+---------------------+---------+- 1 + ! Frequencies --> ^ + ! IFR = 0 1 NFR | NFRHGH + ! | + ! NFRCHG + ! + ! where : 1 : Extra tail added beyond NFR + ! 2 : Empty bins at low frequencies + ! + ! NFRHGH = NFR + IFRP1 - IFRM1 + ! NFRCHG = NFR - IFRM1 + ! + ! All counters and arrays are set in INSNL1. See also section 3 + ! and section 8. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action spectrum A(ISP) as a function of + ! direction (rad) and wavenumber. + ! CG R.A. I Group velocities (dimension NK). + ! KDMEAN Real I Mean relative depth. + ! S R.A. O Source term. *) + ! D R.A. O Diagonal term of derivative. *) + ! ---------------------------------------------------------------- + ! *) 1-D array with dimension NTH*NK + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! PRT2DS Subr. W3ARRYMD Print plot of spectra. + ! OUTMAT Subr. W3WRRYMD Print out 2D matrix. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! None. + ! + ! 8. Structure : + ! + ! ------------------------------------------- + ! 1. Calculate proportionality constant. + ! 2. Prepare auxiliary spectrum + ! 3. Calculate (unfolded) interactions + ! a Energy at interacting bins + ! b Contribution to interactions + ! c Fold interactions to side angles + ! 4. Put source and diagonal term together + ! ------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, FACHFE, & + KDCON, KDMN, SNLC1, SNLS1, SNLS2, SNLS3 + USE W3ADATMD, ONLY: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY, & + IP11, IP12, IP13, IP14, IM11, IM12, IM13, IM14, & + IP21, IP22, IP23, IP24, IM21, IM22, IM23, IM24, & + IC11, IC12, IC21, IC22, IC31, IC32, IC41, IC42, & + IC51, IC52, IC61, IC62, IC71, IC72, IC81, IC82, & + DAL1, DAL2, DAL3, AF11, & + AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, AWG7, AWG8, & + SWG1, SWG2, SWG3, SWG4, SWG5, SWG6, SWG7, SWG8 #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_T1 - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NSPEC), CG(NK), KDMEAN - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IFR, ISP + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NSPEC), CG(NK), KDMEAN + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IFR, ISP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: X, X2, CONS, CONX, FACTOR, & - E00, EP1, EM1, EP2, EM2, & - SA1A, SA1B, SA2A, SA2B + REAL :: X, X2, CONS, CONX, FACTOR, & + E00, EP1, EM1, EP2, EM2, & + SA1A, SA1B, SA2A, SA2B #ifdef W3_T0 - REAL :: SOUT(NK,NFR), DOUT(NK,NFR) + REAL :: SOUT(NK,NFR), DOUT(NK,NFR) #endif - REAL :: UE (1-NTH:NSPECY), SA1 (1-NTH:NSPECX), & - SA2 (1-NTH:NSPECX), DA1C(1-NTH:NSPECX), & - DA1P(1-NTH:NSPECX), DA1M(1-NTH:NSPECX), & - DA2C(1-NTH:NSPECX), DA2P(1-NTH:NSPECX), & - DA2M(1-NTH:NSPECX), CON ( NSPEC ) -!/ -!/ ------------------------------------------------------------------- / -!/ -! initialisations -! + REAL :: UE (1-NTH:NSPECY), SA1 (1-NTH:NSPECX), & + SA2 (1-NTH:NSPECX), DA1C(1-NTH:NSPECX), & + DA1P(1-NTH:NSPECX), DA1M(1-NTH:NSPECX), & + DA2C(1-NTH:NSPECX), DA2P(1-NTH:NSPECX), & + DA2M(1-NTH:NSPECX), CON ( NSPEC ) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! initialisations + ! #ifdef W3_S - CALL STRACE (IENT, 'W3SNL1') + CALL STRACE (IENT, 'W3SNL1') #endif -! -! 1. Calculate prop. constant --------------------------------------- * -! - X = MAX ( KDCON*KDMEAN , KDMN ) - X2 = MAX ( -1.E15, SNLS3*X) - CONS = SNLC1 * ( 1. + SNLS1/X * (1.-SNLS2*X) * EXP(X2) ) -! + ! + ! 1. Calculate prop. constant --------------------------------------- * + ! + X = MAX ( KDCON*KDMEAN , KDMN ) + X2 = MAX ( -1.E15, SNLS3*X) + CONS = SNLC1 * ( 1. + SNLS1/X * (1.-SNLS2*X) * EXP(X2) ) + ! #ifdef W3_T - WRITE (NDST,9000) KDMEAN, CONS -#endif -! -! 2. Prepare auxiliary spectrum and arrays -------------------------- * -! - DO IFR=1, NFR - CONX = TPIINV / SIG(IFR) * CG(IFR) - DO ITH=1, NTH - ISP = ITH + (IFR-1)*NTH - UE (ISP) = A(ISP) / CONX - CON(ISP) = CONX - END DO - END DO -! - DO IFR=NFR+1, NFRHGH - DO ITH=1, NTH - ISP = ITH + (IFR-1)*NTH - UE(ISP) = UE(ISP-NTH) * FACHFE - END DO - END DO -! - DO ISP=1-NTH, 0 - UE (ISP) = 0. - SA1 (ISP) = 0. - SA2 (ISP) = 0. - DA1C(ISP) = 0. - DA1P(ISP) = 0. - DA1M(ISP) = 0. - DA2C(ISP) = 0. - DA2P(ISP) = 0. - DA2M(ISP) = 0. - END DO -! -! 3. Calculate interactions for extended spectrum ------------------- * -! - DO ISP=1, NSPECX -! -! 3.a Energy at interacting bins -! - E00 = UE(ISP) - EP1 = AWG1 * UE(IP11(ISP)) + AWG2 * UE(IP12(ISP)) & - + AWG3 * UE(IP13(ISP)) + AWG4 * UE(IP14(ISP)) - EM1 = AWG5 * UE(IM11(ISP)) + AWG6 * UE(IM12(ISP)) & - + AWG7 * UE(IM13(ISP)) + AWG8 * UE(IM14(ISP)) - EP2 = AWG1 * UE(IP21(ISP)) + AWG2 * UE(IP22(ISP)) & - + AWG3 * UE(IP23(ISP)) + AWG4 * UE(IP24(ISP)) - EM2 = AWG5 * UE(IM21(ISP)) + AWG6 * UE(IM22(ISP)) & - + AWG7 * UE(IM23(ISP)) + AWG8 * UE(IM24(ISP)) -! -! 3.b Contribution to interactions -! - FACTOR = CONS * AF11(ISP) * E00 -! - SA1A = E00 * ( EP1*DAL1 + EM1*DAL2 ) - SA1B = SA1A - EP1*EM1*DAL3 - SA2A = E00 * ( EP2*DAL1 + EM2*DAL2 ) - SA2B = SA2A - EP2*EM2*DAL3 -! - SA1 (ISP) = FACTOR * SA1B - SA2 (ISP) = FACTOR * SA2B -! - DA1C(ISP) = CONS * AF11(ISP) * ( SA1A + SA1B ) - DA1P(ISP) = FACTOR * ( DAL1*E00 - DAL3*EM1 ) - DA1M(ISP) = FACTOR * ( DAL2*E00 - DAL3*EP1 ) -! - DA2C(ISP) = CONS * AF11(ISP) * ( SA2A + SA2B ) - DA2P(ISP) = FACTOR * ( DAL1*E00 - DAL3*EM2 ) - DA2M(ISP) = FACTOR * ( DAL2*E00 - DAL3*EP2 ) -! - END DO -! -! 4. Put source and diagonal term together -------------------------- * -! - DO ISP=1, NSPEC -! - S(ISP) = CON(ISP) * ( - 2. * ( SA1(ISP) + SA2(ISP) ) & - + AWG1 * ( SA1(IC11(ISP)) + SA2(IC12(ISP)) ) & - + AWG2 * ( SA1(IC21(ISP)) + SA2(IC22(ISP)) ) & - + AWG3 * ( SA1(IC31(ISP)) + SA2(IC32(ISP)) ) & - + AWG4 * ( SA1(IC41(ISP)) + SA2(IC42(ISP)) ) & - + AWG5 * ( SA1(IC51(ISP)) + SA2(IC52(ISP)) ) & - + AWG6 * ( SA1(IC61(ISP)) + SA2(IC62(ISP)) ) & - + AWG7 * ( SA1(IC71(ISP)) + SA2(IC72(ISP)) ) & - + AWG8 * ( SA1(IC81(ISP)) + SA2(IC82(ISP)) ) ) -! - D(ISP) = - 2. * ( DA1C(ISP) + DA2C(ISP) ) & - + SWG1 * ( DA1P(IC11(ISP)) + DA2P(IC12(ISP)) ) & - + SWG2 * ( DA1P(IC21(ISP)) + DA2P(IC22(ISP)) ) & - + SWG3 * ( DA1P(IC31(ISP)) + DA2P(IC32(ISP)) ) & - + SWG4 * ( DA1P(IC41(ISP)) + DA2P(IC42(ISP)) ) & - + SWG5 * ( DA1M(IC51(ISP)) + DA2M(IC52(ISP)) ) & - + SWG6 * ( DA1M(IC61(ISP)) + DA2M(IC62(ISP)) ) & - + SWG7 * ( DA1M(IC71(ISP)) + DA2M(IC72(ISP)) ) & - + SWG8 * ( DA1M(IC81(ISP)) + DA2M(IC82(ISP)) ) -! - END DO -! -! ... Test output : -! -#ifdef W3_T0 - DO IFR=1, NFR - DO ITH=1, NTH - ISP = ITH + (IFR-1)*NTH - SOUT(IFR,ITH) = S(ISP) * TPI * SIG(IFR) / CG(IFR) - DOUT(IFR,ITH) = D(ISP) - END DO - END DO + WRITE (NDST,9000) KDMEAN, CONS #endif -! + ! + ! 2. Prepare auxiliary spectrum and arrays -------------------------- * + ! + DO IFR=1, NFR + CONX = TPIINV / SIG(IFR) * CG(IFR) + DO ITH=1, NTH + ISP = ITH + (IFR-1)*NTH + UE (ISP) = A(ISP) / CONX + CON(ISP) = CONX + END DO + END DO + ! + DO IFR=NFR+1, NFRHGH + DO ITH=1, NTH + ISP = ITH + (IFR-1)*NTH + UE(ISP) = UE(ISP-NTH) * FACHFE + END DO + END DO + ! + DO ISP=1-NTH, 0 + UE (ISP) = 0. + SA1 (ISP) = 0. + SA2 (ISP) = 0. + DA1C(ISP) = 0. + DA1P(ISP) = 0. + DA1M(ISP) = 0. + DA2C(ISP) = 0. + DA2P(ISP) = 0. + DA2M(ISP) = 0. + END DO + ! + ! 3. Calculate interactions for extended spectrum ------------------- * + ! + DO ISP=1, NSPECX + ! + ! 3.a Energy at interacting bins + ! + E00 = UE(ISP) + EP1 = AWG1 * UE(IP11(ISP)) + AWG2 * UE(IP12(ISP)) & + + AWG3 * UE(IP13(ISP)) + AWG4 * UE(IP14(ISP)) + EM1 = AWG5 * UE(IM11(ISP)) + AWG6 * UE(IM12(ISP)) & + + AWG7 * UE(IM13(ISP)) + AWG8 * UE(IM14(ISP)) + EP2 = AWG1 * UE(IP21(ISP)) + AWG2 * UE(IP22(ISP)) & + + AWG3 * UE(IP23(ISP)) + AWG4 * UE(IP24(ISP)) + EM2 = AWG5 * UE(IM21(ISP)) + AWG6 * UE(IM22(ISP)) & + + AWG7 * UE(IM23(ISP)) + AWG8 * UE(IM24(ISP)) + ! + ! 3.b Contribution to interactions + ! + FACTOR = CONS * AF11(ISP) * E00 + ! + SA1A = E00 * ( EP1*DAL1 + EM1*DAL2 ) + SA1B = SA1A - EP1*EM1*DAL3 + SA2A = E00 * ( EP2*DAL1 + EM2*DAL2 ) + SA2B = SA2A - EP2*EM2*DAL3 + ! + SA1 (ISP) = FACTOR * SA1B + SA2 (ISP) = FACTOR * SA2B + ! + DA1C(ISP) = CONS * AF11(ISP) * ( SA1A + SA1B ) + DA1P(ISP) = FACTOR * ( DAL1*E00 - DAL3*EM1 ) + DA1M(ISP) = FACTOR * ( DAL2*E00 - DAL3*EP1 ) + ! + DA2C(ISP) = CONS * AF11(ISP) * ( SA2A + SA2B ) + DA2P(ISP) = FACTOR * ( DAL1*E00 - DAL3*EM2 ) + DA2M(ISP) = FACTOR * ( DAL2*E00 - DAL3*EP2 ) + ! + END DO + ! + ! 4. Put source and diagonal term together -------------------------- * + ! + DO ISP=1, NSPEC + ! + S(ISP) = CON(ISP) * ( - 2. * ( SA1(ISP) + SA2(ISP) ) & + + AWG1 * ( SA1(IC11(ISP)) + SA2(IC12(ISP)) ) & + + AWG2 * ( SA1(IC21(ISP)) + SA2(IC22(ISP)) ) & + + AWG3 * ( SA1(IC31(ISP)) + SA2(IC32(ISP)) ) & + + AWG4 * ( SA1(IC41(ISP)) + SA2(IC42(ISP)) ) & + + AWG5 * ( SA1(IC51(ISP)) + SA2(IC52(ISP)) ) & + + AWG6 * ( SA1(IC61(ISP)) + SA2(IC62(ISP)) ) & + + AWG7 * ( SA1(IC71(ISP)) + SA2(IC72(ISP)) ) & + + AWG8 * ( SA1(IC81(ISP)) + SA2(IC82(ISP)) ) ) + ! + D(ISP) = - 2. * ( DA1C(ISP) + DA2C(ISP) ) & + + SWG1 * ( DA1P(IC11(ISP)) + DA2P(IC12(ISP)) ) & + + SWG2 * ( DA1P(IC21(ISP)) + DA2P(IC22(ISP)) ) & + + SWG3 * ( DA1P(IC31(ISP)) + DA2P(IC32(ISP)) ) & + + SWG4 * ( DA1P(IC41(ISP)) + DA2P(IC42(ISP)) ) & + + SWG5 * ( DA1M(IC51(ISP)) + DA2M(IC52(ISP)) ) & + + SWG6 * ( DA1M(IC61(ISP)) + DA2M(IC62(ISP)) ) & + + SWG7 * ( DA1M(IC71(ISP)) + DA2M(IC72(ISP)) ) & + + SWG8 * ( DA1M(IC81(ISP)) + DA2M(IC82(ISP)) ) + ! + END DO + ! + ! ... Test output : + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Snl(f,t)', ' ', 'NONAME') - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Snl', ' ', 'NONAME') + DO IFR=1, NFR + DO ITH=1, NTH + ISP = ITH + (IFR-1)*NTH + SOUT(IFR,ITH) = S(ISP) * TPI * SIG(IFR) / CG(IFR) + DOUT(IFR,ITH) = D(ISP) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Snl(f,t)', ' ', 'NONAME') + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Snl', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, S, NTH, NTH, NK, 'Snl') - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'Diag Snl') + CALL OUTMAT (NDST, S, NTH, NTH, NK, 'Snl') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'Diag Snl') #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SNL1 : KDMEAN, CONS :',F8.2,F8.1) +9000 FORMAT (' TEST W3SNL1 : KDMEAN, CONS :',F8.2,F8.1) #endif -!/ -!/ End of W3SNL1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SNL1 -!/ ------------------------------------------------------------------- / - SUBROUTINE INSNL1 ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 24-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Preprocessing for nonlinear interactions (weights). -! -! 2. Method : -! -! See W3SNL1. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! ---------------------------------------------------------------- -! -! Local variables -! ---------------------------------------------------------------- -! ITHxn Real Directional indices. (relative) -! IFRxn Real Frequency indices. (relative) -! IT1 R.A. Directional indices. (1-D) -! IFn R.A. Frequency indices. (1-D) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Model definition file processing. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on array dimensions for local arrays in W3SNL. -! -! 7. Remarks : -! -! - Test output is generated through W3IOGR. -! - No testing of IMOD ir resetting of pointers. -! -! 8. Structure : -! -! - See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, XFR, SIG, LAM - USE W3ADATMD, ONLY: W3DMNL - USE W3ADATMD, ONLY: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY, & - IP11, IP12, IP13, IP14, IM11, IM12, IM13, IM14, & - IP21, IP22, IP23, IP24, IM21, IM22, IM23, IM24, & - IC11, IC12, IC21, IC22, IC31, IC32, IC41, IC42, & - IC51, IC52, IC61, IC62, IC71, IC72, IC81, IC82, & - DAL1, DAL2, DAL3, AF11, & - AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, AWG7, AWG8, & - SWG1, SWG2, SWG3, SWG4, SWG5, SWG6, SWG7, SWG8 - USE W3ODATMD, ONLY: NDST, NDSE + !/ + !/ End of W3SNL1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SNL1 + !/ ------------------------------------------------------------------- / + SUBROUTINE INSNL1 ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 24-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Preprocessing for nonlinear interactions (weights). + ! + ! 2. Method : + ! + ! See W3SNL1. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! ---------------------------------------------------------------- + ! + ! Local variables + ! ---------------------------------------------------------------- + ! ITHxn Real Directional indices. (relative) + ! IFRxn Real Frequency indices. (relative) + ! IT1 R.A. Directional indices. (1-D) + ! IFn R.A. Frequency indices. (1-D) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Model definition file processing. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on array dimensions for local arrays in W3SNL. + ! + ! 7. Remarks : + ! + ! - Test output is generated through W3IOGR. + ! - No testing of IMOD ir resetting of pointers. + ! + ! 8. Structure : + ! + ! - See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, XFR, SIG, LAM + USE W3ADATMD, ONLY: W3DMNL + USE W3ADATMD, ONLY: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY, & + IP11, IP12, IP13, IP14, IM11, IM12, IM13, IM14, & + IP21, IP22, IP23, IP24, IM21, IM22, IM23, IM24, & + IC11, IC12, IC21, IC22, IC31, IC32, IC41, IC42, & + IC51, IC52, IC61, IC62, IC71, IC72, IC81, IC82, & + DAL1, DAL2, DAL3, AF11, & + AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, AWG7, AWG8, & + SWG1, SWG2, SWG3, SWG4, SWG5, SWG6, SWG7, SWG8 + USE W3ODATMD, ONLY: NDST, NDSE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ Local parameters -!/ - INTEGER :: IFR, ITH, ISP, ITHP, ITHP1, ITHM, & - ITHM1,IFRP, IFRP1, IFRM, IFRM1 - INTEGER, ALLOCATABLE :: IF1(:), IF2(:), IF3(:), IF4(:), & - IF5(:), IF6(:), IF7(:), IF8(:), & - IT1(:), IT2(:), IT3(:), IT4(:), & - IT5(:), IT6(:), IT7(:), IT8(:) + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ Local parameters + !/ + INTEGER :: IFR, ITH, ISP, ITHP, ITHP1, ITHM, & + ITHM1,IFRP, IFRP1, IFRM, IFRM1 + INTEGER, ALLOCATABLE :: IF1(:), IF2(:), IF3(:), IF4(:), & + IF5(:), IF6(:), IF7(:), IF8(:), & + IT1(:), IT2(:), IT3(:), IT4(:), & + IT5(:), IT6(:), IT7(:), IT8(:) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: DELTH3, DELTH4, LAMM2, LAMP2, CTHP, & - WTHP, WTHP1, CTHM, WTHM, WTHM1, & - XFRLN, WFRP, WFRP1, WFRM, WFRM1, FR, & - AF11A -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: DELTH3, DELTH4, LAMM2, LAMP2, CTHP, & + WTHP, WTHP1, CTHM, WTHM, WTHM1, & + XFRLN, WFRP, WFRP1, WFRM, WFRM1, FR, & + AF11A + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INSNL1') + CALL STRACE (IENT, 'INSNL1') #endif #ifdef W3_T - WRITE (NDST,9000) IMOD + WRITE (NDST,9000) IMOD #endif -! - NFR = NK -! -! 1. Internal angles of quadruplet. -! - LAMM2 = (1.-LAM)**2 - LAMP2 = (1.+LAM)**2 - DELTH3 = ACOS( (LAMM2**2+4.-LAMP2**2) / (4.*LAMM2) ) - DELTH4 = ASIN(-SIN(DELTH3)*LAMM2/LAMP2) -! -! 2. Lambda dependend weight factors. -! - DAL1 = 1. / (1.+LAM)**4 - DAL2 = 1. / (1.-LAM)**4 - DAL3 = 2. * DAL1 * DAL2 -! -! 3. Directional indices. -! - CTHP = ABS(DELTH4/DTH) - ITHP = INT(CTHP) - ITHP1 = ITHP + 1 - WTHP = CTHP - REAL(ITHP) - WTHP1 = 1.- WTHP -! - CTHM = ABS(DELTH3/DTH) - ITHM = INT(CTHM) - ITHM1 = ITHM + 1 - WTHM = CTHM - REAL(ITHM) - WTHM1 = 1.- WTHM -! -! 4. Frequency indices. -! - XFRLN = LOG(XFR) -! - IFRP = INT( LOG(1.+LAM) / XFRLN ) - IFRP1 = IFRP + 1 - WFRP = (1.+LAM - XFR**IFRP) / (XFR**IFRP1 - XFR**IFRP) - WFRP1 = 1. - WFRP -! - IFRM = INT( LOG(1.-LAM) / XFRLN ) - IFRM1 = IFRM - 1 - WFRM = (XFR**IFRM -(1.-LAM)) / (XFR**IFRM - XFR**IFRM1) - WFRM1 = 1. - WFRM -! -! 5. Range of calculations -! - NFRHGH = NFR + IFRP1 - IFRM1 - NFRCHG = NFR - IFRM1 - NSPECY = NFRHGH * NTH - NSPECX = NFRCHG * NTH -! -! 6. Allocate arrays or check array sizes -! - CALL W3DMNL ( IMOD, NDSE, NDST, NSPEC, NSPECX ) -! - ALLOCATE ( IF1(NFRCHG), IF2(NFRCHG), IF3(NFRCHG), IF4(NFRCHG), & - IF5(NFRCHG), IF6(NFRCHG), IF7(NFRCHG), IF8(NFRCHG), & - IT1(NTH), IT2(NTH), IT3(NTH), IT4(NTH), & - IT5(NTH), IT6(NTH), IT7(NTH), IT8(NTH) ) -! -! 7. Spectral addresses -! - DO IFR=1, NFRCHG - IF1(IFR) = IFR+IFRP - IF2(IFR) = IFR+IFRP1 - IF3(IFR) = MAX ( 0 , IFR+IFRM ) - IF4(IFR) = MAX ( 0 , IFR+IFRM1 ) - IF5(IFR) = MAX ( 0 , IFR-IFRP ) - IF6(IFR) = MAX ( 0 , IFR-IFRP1 ) - IF7(IFR) = IFR-IFRM - IF8(IFR) = IFR-IFRM1 - END DO -! + ! + NFR = NK + ! + ! 1. Internal angles of quadruplet. + ! + LAMM2 = (1.-LAM)**2 + LAMP2 = (1.+LAM)**2 + DELTH3 = ACOS( (LAMM2**2+4.-LAMP2**2) / (4.*LAMM2) ) + DELTH4 = ASIN(-SIN(DELTH3)*LAMM2/LAMP2) + ! + ! 2. Lambda dependend weight factors. + ! + DAL1 = 1. / (1.+LAM)**4 + DAL2 = 1. / (1.-LAM)**4 + DAL3 = 2. * DAL1 * DAL2 + ! + ! 3. Directional indices. + ! + CTHP = ABS(DELTH4/DTH) + ITHP = INT(CTHP) + ITHP1 = ITHP + 1 + WTHP = CTHP - REAL(ITHP) + WTHP1 = 1.- WTHP + ! + CTHM = ABS(DELTH3/DTH) + ITHM = INT(CTHM) + ITHM1 = ITHM + 1 + WTHM = CTHM - REAL(ITHM) + WTHM1 = 1.- WTHM + ! + ! 4. Frequency indices. + ! + XFRLN = LOG(XFR) + ! + IFRP = INT( LOG(1.+LAM) / XFRLN ) + IFRP1 = IFRP + 1 + WFRP = (1.+LAM - XFR**IFRP) / (XFR**IFRP1 - XFR**IFRP) + WFRP1 = 1. - WFRP + ! + IFRM = INT( LOG(1.-LAM) / XFRLN ) + IFRM1 = IFRM - 1 + WFRM = (XFR**IFRM -(1.-LAM)) / (XFR**IFRM - XFR**IFRM1) + WFRM1 = 1. - WFRM + ! + ! 5. Range of calculations + ! + NFRHGH = NFR + IFRP1 - IFRM1 + NFRCHG = NFR - IFRM1 + NSPECY = NFRHGH * NTH + NSPECX = NFRCHG * NTH + ! + ! 6. Allocate arrays or check array sizes + ! + CALL W3DMNL ( IMOD, NDSE, NDST, NSPEC, NSPECX ) + ! + ALLOCATE ( IF1(NFRCHG), IF2(NFRCHG), IF3(NFRCHG), IF4(NFRCHG), & + IF5(NFRCHG), IF6(NFRCHG), IF7(NFRCHG), IF8(NFRCHG), & + IT1(NTH), IT2(NTH), IT3(NTH), IT4(NTH), & + IT5(NTH), IT6(NTH), IT7(NTH), IT8(NTH) ) + ! + ! 7. Spectral addresses + ! + DO IFR=1, NFRCHG + IF1(IFR) = IFR+IFRP + IF2(IFR) = IFR+IFRP1 + IF3(IFR) = MAX ( 0 , IFR+IFRM ) + IF4(IFR) = MAX ( 0 , IFR+IFRM1 ) + IF5(IFR) = MAX ( 0 , IFR-IFRP ) + IF6(IFR) = MAX ( 0 , IFR-IFRP1 ) + IF7(IFR) = IFR-IFRM + IF8(IFR) = IFR-IFRM1 + END DO + ! + DO ITH=1, NTH + IT1(ITH) = ITH + ITHP + IT2(ITH) = ITH + ITHP1 + IT3(ITH) = ITH + ITHM + IT4(ITH) = ITH + ITHM1 + IT5(ITH) = ITH - ITHP + IT6(ITH) = ITH - ITHP1 + IT7(ITH) = ITH - ITHM + IT8(ITH) = ITH - ITHM1 + IF ( IT1(ITH).GT.NTH) IT1(ITH) = IT1(ITH) - NTH + IF ( IT2(ITH).GT.NTH) IT2(ITH) = IT2(ITH) - NTH + IF ( IT3(ITH).GT.NTH) IT3(ITH) = IT3(ITH) - NTH + IF ( IT4(ITH).GT.NTH) IT4(ITH) = IT4(ITH) - NTH + IF ( IT5(ITH).LT. 1 ) IT5(ITH) = IT5(ITH) + NTH + IF ( IT6(ITH).LT. 1 ) IT6(ITH) = IT6(ITH) + NTH + IF ( IT7(ITH).LT. 1 ) IT7(ITH) = IT7(ITH) + NTH + IF ( IT8(ITH).LT. 1 ) IT8(ITH) = IT8(ITH) + NTH + END DO + ! + DO ISP=1, NSPECX + IFR = 1 + (ISP-1)/NTH + ITH = 1 + MOD(ISP-1,NTH) + IP11(ISP) = IT2(ITH) + (IF2(IFR)-1)*NTH + IP12(ISP) = IT1(ITH) + (IF2(IFR)-1)*NTH + IP13(ISP) = IT2(ITH) + (IF1(IFR)-1)*NTH + IP14(ISP) = IT1(ITH) + (IF1(IFR)-1)*NTH + IM11(ISP) = IT8(ITH) + (IF4(IFR)-1)*NTH + IM12(ISP) = IT7(ITH) + (IF4(IFR)-1)*NTH + IM13(ISP) = IT8(ITH) + (IF3(IFR)-1)*NTH + IM14(ISP) = IT7(ITH) + (IF3(IFR)-1)*NTH + IP21(ISP) = IT6(ITH) + (IF2(IFR)-1)*NTH + IP22(ISP) = IT5(ITH) + (IF2(IFR)-1)*NTH + IP23(ISP) = IT6(ITH) + (IF1(IFR)-1)*NTH + IP24(ISP) = IT5(ITH) + (IF1(IFR)-1)*NTH + IM21(ISP) = IT4(ITH) + (IF4(IFR)-1)*NTH + IM22(ISP) = IT3(ITH) + (IF4(IFR)-1)*NTH + IM23(ISP) = IT4(ITH) + (IF3(IFR)-1)*NTH + IM24(ISP) = IT3(ITH) + (IF3(IFR)-1)*NTH + END DO + ! + DO ISP=1, NSPEC + IFR = 1 + (ISP-1)/NTH + ITH = 1 + MOD(ISP-1,NTH) + IC11(ISP) = IT6(ITH) + (IF6(IFR)-1)*NTH + IC21(ISP) = IT5(ITH) + (IF6(IFR)-1)*NTH + IC31(ISP) = IT6(ITH) + (IF5(IFR)-1)*NTH + IC41(ISP) = IT5(ITH) + (IF5(IFR)-1)*NTH + IC51(ISP) = IT4(ITH) + (IF8(IFR)-1)*NTH + IC61(ISP) = IT3(ITH) + (IF8(IFR)-1)*NTH + IC71(ISP) = IT4(ITH) + (IF7(IFR)-1)*NTH + IC81(ISP) = IT3(ITH) + (IF7(IFR)-1)*NTH + IC12(ISP) = IT2(ITH) + (IF6(IFR)-1)*NTH + IC22(ISP) = IT1(ITH) + (IF6(IFR)-1)*NTH + IC32(ISP) = IT2(ITH) + (IF5(IFR)-1)*NTH + IC42(ISP) = IT1(ITH) + (IF5(IFR)-1)*NTH + IC52(ISP) = IT8(ITH) + (IF8(IFR)-1)*NTH + IC62(ISP) = IT7(ITH) + (IF8(IFR)-1)*NTH + IC72(ISP) = IT8(ITH) + (IF7(IFR)-1)*NTH + IC82(ISP) = IT7(ITH) + (IF7(IFR)-1)*NTH + END DO + ! + DEALLOCATE ( IF1, IF2, IF3, IF4, IF5, IF6, IF7, IF8, & + IT1, IT2, IT3, IT4, IT5, IT6, IT7, IT8 ) + ! + ! 8. Fill scaling array (f**11) + ! + DO IFR=1, NFR + AF11A = (SIG(IFR)*TPIINV)**11 + DO ITH=1, NTH + AF11(ITH+(IFR-1)*NTH) = AF11A + END DO + END DO + ! + FR = SIG(NFR)*TPIINV + DO IFR=NFR+1, NFRCHG + FR = FR * XFR + AF11A = FR**11 DO ITH=1, NTH - IT1(ITH) = ITH + ITHP - IT2(ITH) = ITH + ITHP1 - IT3(ITH) = ITH + ITHM - IT4(ITH) = ITH + ITHM1 - IT5(ITH) = ITH - ITHP - IT6(ITH) = ITH - ITHP1 - IT7(ITH) = ITH - ITHM - IT8(ITH) = ITH - ITHM1 - IF ( IT1(ITH).GT.NTH) IT1(ITH) = IT1(ITH) - NTH - IF ( IT2(ITH).GT.NTH) IT2(ITH) = IT2(ITH) - NTH - IF ( IT3(ITH).GT.NTH) IT3(ITH) = IT3(ITH) - NTH - IF ( IT4(ITH).GT.NTH) IT4(ITH) = IT4(ITH) - NTH - IF ( IT5(ITH).LT. 1 ) IT5(ITH) = IT5(ITH) + NTH - IF ( IT6(ITH).LT. 1 ) IT6(ITH) = IT6(ITH) + NTH - IF ( IT7(ITH).LT. 1 ) IT7(ITH) = IT7(ITH) + NTH - IF ( IT8(ITH).LT. 1 ) IT8(ITH) = IT8(ITH) + NTH - END DO -! - DO ISP=1, NSPECX - IFR = 1 + (ISP-1)/NTH - ITH = 1 + MOD(ISP-1,NTH) - IP11(ISP) = IT2(ITH) + (IF2(IFR)-1)*NTH - IP12(ISP) = IT1(ITH) + (IF2(IFR)-1)*NTH - IP13(ISP) = IT2(ITH) + (IF1(IFR)-1)*NTH - IP14(ISP) = IT1(ITH) + (IF1(IFR)-1)*NTH - IM11(ISP) = IT8(ITH) + (IF4(IFR)-1)*NTH - IM12(ISP) = IT7(ITH) + (IF4(IFR)-1)*NTH - IM13(ISP) = IT8(ITH) + (IF3(IFR)-1)*NTH - IM14(ISP) = IT7(ITH) + (IF3(IFR)-1)*NTH - IP21(ISP) = IT6(ITH) + (IF2(IFR)-1)*NTH - IP22(ISP) = IT5(ITH) + (IF2(IFR)-1)*NTH - IP23(ISP) = IT6(ITH) + (IF1(IFR)-1)*NTH - IP24(ISP) = IT5(ITH) + (IF1(IFR)-1)*NTH - IM21(ISP) = IT4(ITH) + (IF4(IFR)-1)*NTH - IM22(ISP) = IT3(ITH) + (IF4(IFR)-1)*NTH - IM23(ISP) = IT4(ITH) + (IF3(IFR)-1)*NTH - IM24(ISP) = IT3(ITH) + (IF3(IFR)-1)*NTH - END DO -! - DO ISP=1, NSPEC - IFR = 1 + (ISP-1)/NTH - ITH = 1 + MOD(ISP-1,NTH) - IC11(ISP) = IT6(ITH) + (IF6(IFR)-1)*NTH - IC21(ISP) = IT5(ITH) + (IF6(IFR)-1)*NTH - IC31(ISP) = IT6(ITH) + (IF5(IFR)-1)*NTH - IC41(ISP) = IT5(ITH) + (IF5(IFR)-1)*NTH - IC51(ISP) = IT4(ITH) + (IF8(IFR)-1)*NTH - IC61(ISP) = IT3(ITH) + (IF8(IFR)-1)*NTH - IC71(ISP) = IT4(ITH) + (IF7(IFR)-1)*NTH - IC81(ISP) = IT3(ITH) + (IF7(IFR)-1)*NTH - IC12(ISP) = IT2(ITH) + (IF6(IFR)-1)*NTH - IC22(ISP) = IT1(ITH) + (IF6(IFR)-1)*NTH - IC32(ISP) = IT2(ITH) + (IF5(IFR)-1)*NTH - IC42(ISP) = IT1(ITH) + (IF5(IFR)-1)*NTH - IC52(ISP) = IT8(ITH) + (IF8(IFR)-1)*NTH - IC62(ISP) = IT7(ITH) + (IF8(IFR)-1)*NTH - IC72(ISP) = IT8(ITH) + (IF7(IFR)-1)*NTH - IC82(ISP) = IT7(ITH) + (IF7(IFR)-1)*NTH - END DO -! - DEALLOCATE ( IF1, IF2, IF3, IF4, IF5, IF6, IF7, IF8, & - IT1, IT2, IT3, IT4, IT5, IT6, IT7, IT8 ) -! -! 8. Fill scaling array (f**11) -! - DO IFR=1, NFR - AF11A = (SIG(IFR)*TPIINV)**11 - DO ITH=1, NTH - AF11(ITH+(IFR-1)*NTH) = AF11A - END DO - END DO -! - FR = SIG(NFR)*TPIINV - DO IFR=NFR+1, NFRCHG - FR = FR * XFR - AF11A = FR**11 - DO ITH=1, NTH - AF11(ITH+(IFR-1)*NTH) = AF11A - END DO - END DO -! -! 9. Interpolation weights -! - AWG1 = WTHP * WFRP - AWG2 = WTHP1 * WFRP - AWG3 = WTHP * WFRP1 - AWG4 = WTHP1 * WFRP1 - AWG5 = WTHM * WFRM - AWG6 = WTHM1 * WFRM - AWG7 = WTHM * WFRM1 - AWG8 = WTHM1 * WFRM1 -! - SWG1 = AWG1**2 - SWG2 = AWG2**2 - SWG3 = AWG3**2 - SWG4 = AWG4**2 - SWG5 = AWG5**2 - SWG6 = AWG6**2 - SWG7 = AWG7**2 - SWG8 = AWG8**2 -! - RETURN -! -! Formats -! + AF11(ITH+(IFR-1)*NTH) = AF11A + END DO + END DO + ! + ! 9. Interpolation weights + ! + AWG1 = WTHP * WFRP + AWG2 = WTHP1 * WFRP + AWG3 = WTHP * WFRP1 + AWG4 = WTHP1 * WFRP1 + AWG5 = WTHM * WFRM + AWG6 = WTHM1 * WFRM + AWG7 = WTHM * WFRM1 + AWG8 = WTHM1 * WFRM1 + ! + SWG1 = AWG1**2 + SWG2 = AWG2**2 + SWG3 = AWG3**2 + SWG4 = AWG4**2 + SWG5 = AWG5**2 + SWG6 = AWG6**2 + SWG7 = AWG7**2 + SWG8 = AWG8**2 + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST INSNL1 : IMOD :',I4) +9000 FORMAT (' TEST INSNL1 : IMOD :',I4) #endif -!/ -!/ End of INSNL1 ----------------------------------------------------- / -!/ - END SUBROUTINE INSNL1 -!/ -!/ End of module W3SNL1MD -------------------------------------------- / -!/ - END MODULE W3SNL1MD + !/ + !/ End of INSNL1 ----------------------------------------------------- / + !/ + END SUBROUTINE INSNL1 + !/ + !/ End of module W3SNL1MD -------------------------------------------- / + !/ +END MODULE W3SNL1MD diff --git a/model/src/w3snl2md.F90 b/model/src/w3snl2md.F90 index f2eb0c3d4..946851927 100644 --- a/model/src/w3snl2md.F90 +++ b/model/src/w3snl2md.F90 @@ -1,390 +1,387 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SNL2MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | G. Ph. van Vledder | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 14-Feb-2000 : Origination. ( version 2.01 ) -!/ 02-Feb-2001 : Exact-NL version 3.0 ( version 2.07 ) -!/ 26-Aug-2002 : Exact-NL version 4.0 ( version 2.22 ) -!/ 11-Nov-2002 : Interface fix. ( version 3.00 ) -!/ 25-Sep-2003 : Exact-NL version 5.0 ( version 3.05 ) -!/ 24-Dec-2004 : Multiple model version. ( version 3.06 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Interface module to exact nonlinear interactions. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SNL2 Subr. Public Interface to Xnl calculation routines. -! INSNL2 Subr. Public Initialization of Xnl routines. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine. -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SNL2 ( A, CG, DEPTH, S, D ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | G. Ph. van Vledder | -!/ | FORTRAN 90 | -!/ | Last update : 24-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 14-Feb-2000 : Origination ( version 2.01 ) -!/ 02-Feb-2001 : Exact-NL version 3.0 ( version 2.07 ) -!/ 26-Aug-2002 : Exact-NL version 4.0 ( version 2.22 ) -!/ 11-Nov-2002 : Interface fix ( version 3.00 ) -!/ 25-Sep-2003 : Exact-NL version 5.0 ( version 3.05 ) -!/ 24-Dec-2004 : Multiple model version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Interface to exact interactions -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action spectrum A(ITH,IK) as a function of -! direction (rad) and wavenumber. -! CG R.A. I Group velocities (dimension NK). -! DEPTH Real I Water depth in meters. -! S R.A. O Source term. -! D R.A. O Diagonal term of derivative. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! xnl_main Subr. m_xnldata Main Xnl routine. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The following settings are hardwired into the xnl_init routine -! of Gerbrant van Vledder. -! -! iufind = 0 -! iq_prt = 0 -! iq_test = 0 -! iq_trace = 0 -! iq_log = 0 -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, SIG, TH, IQTPE - USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE +MODULE W3SNL2MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | G. Ph. van Vledder | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 14-Feb-2000 : Origination. ( version 2.01 ) + !/ 02-Feb-2001 : Exact-NL version 3.0 ( version 2.07 ) + !/ 26-Aug-2002 : Exact-NL version 4.0 ( version 2.22 ) + !/ 11-Nov-2002 : Interface fix. ( version 3.00 ) + !/ 25-Sep-2003 : Exact-NL version 5.0 ( version 3.05 ) + !/ 24-Dec-2004 : Multiple model version. ( version 3.06 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Interface module to exact nonlinear interactions. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SNL2 Subr. Public Interface to Xnl calculation routines. + ! INSNL2 Subr. Public Initialization of Xnl routines. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SNL2 ( A, CG, DEPTH, S, D ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | G. Ph. van Vledder | + !/ | FORTRAN 90 | + !/ | Last update : 24-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 14-Feb-2000 : Origination ( version 2.01 ) + !/ 02-Feb-2001 : Exact-NL version 3.0 ( version 2.07 ) + !/ 26-Aug-2002 : Exact-NL version 4.0 ( version 2.22 ) + !/ 11-Nov-2002 : Interface fix ( version 3.00 ) + !/ 25-Sep-2003 : Exact-NL version 5.0 ( version 3.05 ) + !/ 24-Dec-2004 : Multiple model version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Interface to exact interactions + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action spectrum A(ITH,IK) as a function of + ! direction (rad) and wavenumber. + ! CG R.A. I Group velocities (dimension NK). + ! DEPTH Real I Water depth in meters. + ! S R.A. O Source term. + ! D R.A. O Diagonal term of derivative. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! xnl_main Subr. m_xnldata Main Xnl routine. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - The following settings are hardwired into the xnl_init routine + ! of Gerbrant van Vledder. + ! + ! iufind = 0 + ! iq_prt = 0 + ! iq_test = 0 + ! iq_trace = 0 + ! iq_log = 0 + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, SIG, TH, IQTPE + USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif - USE m_xnldata, ONLY: xnl_main -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK), CG(NK), DEPTH - REAL, INTENT(OUT) :: S(NTH,NK), D(NTH,NK) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IK, ITH, IERR = 0 + USE m_xnldata, ONLY: xnl_main + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK), CG(NK), DEPTH + REAL, INTENT(OUT) :: S(NTH,NK), D(NTH,NK) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IK, ITH, IERR = 0 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: A2(NK,NTH), S2(NK,NTH), D2(NK,NTH) + REAL :: A2(NK,NTH), S2(NK,NTH), D2(NK,NTH) #ifdef W3_T0 - REAL :: SOUT(NK,NK), DOUT(NK,NK) + REAL :: SOUT(NK,NK), DOUT(NK,NK) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SNL2') + CALL STRACE (IENT, 'W3SNL2') #endif #ifdef W3_T - WRITE (NDST,9000) IQTPE + WRITE (NDST,9000) IQTPE #endif -! -! 1. Convert input spectrum ----------------------------------------- * -! (Action sigma spectrum, reversed indices) -! - DO IK=1, NK - DO ITH=1, NTH - A2(IK,ITH) = A(ITH,IK) / CG(IK) - END DO - END DO -! -! 2. Call exact interaction routines -------------------------------- * -! - CALL xnl_main ( A2, SIG(1:NK), TH, NK, NTH, DEPTH, IQTPE, & - S2, D2, IAPROC, IERR ) -! - IF ( IERR .NE. 0 ) GOTO 800 -! -! 3. Pack results in proper format ---------------------------------- * -! - DO IK=1, NK - DO ITH=1, NTH - S(ITH,IK) = S2(IK,ITH) * CG(IK) - D(ITH,IK) = D2(IK,ITH) - END DO - END DO -! -! ... Test output : -! + ! + ! 1. Convert input spectrum ----------------------------------------- * + ! (Action sigma spectrum, reversed indices) + ! + DO IK=1, NK + DO ITH=1, NTH + A2(IK,ITH) = A(ITH,IK) / CG(IK) + END DO + END DO + ! + ! 2. Call exact interaction routines -------------------------------- * + ! + CALL xnl_main ( A2, SIG(1:NK), TH, NK, NTH, DEPTH, IQTPE, & + S2, D2, IAPROC, IERR ) + ! + IF ( IERR .NE. 0 ) GOTO 800 + ! + ! 3. Pack results in proper format ---------------------------------- * + ! + DO IK=1, NK + DO ITH=1, NTH + S(ITH,IK) = S2(IK,ITH) * CG(IK) + D(ITH,IK) = D2(IK,ITH) + END DO + END DO + ! + ! ... Test output : + ! #ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - SOUT(IK,ITH) = S(IK,ITH) * TPI * SIG(IK) / CG(IK) - DOUT(IK,ITH) = D(IK,ITH) - END DO - END DO + DO IK=1, NK + DO ITH=1, NTH + SOUT(IK,ITH) = S(IK,ITH) * TPI * SIG(IK) / CG(IK) + DOUT(IK,ITH) = D(IK,ITH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Snl(f,t)', ' ', 'NONAME') + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Diag Snl', ' ', 'NONAME') #endif -! -#ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & - 0.0, 0.001, 'Snl(f,t)', ' ', 'NONAME') - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:NK), ' ', 1., & - 0.0, 0.001, 'Diag Snl', ' ', 'NONAME') -#endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, S, NTH, NTH, NK, 'Snl') - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'Diag Snl') + CALL OUTMAT (NDST, S, NTH, NTH, NK, 'Snl') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'Diag Snl') #endif -! - RETURN -! -! Error escape locations -! - 800 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) IERR - CALL EXTCDE ( 1 ) -! -! Format statements -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3SNL2 :'/ & - ' xnl_main RETURN CODE NON ZERO : ',I4,' ***'/) -! + ! + RETURN + ! + ! Error escape locations + ! +800 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) IERR + CALL EXTCDE ( 1 ) + ! + ! Format statements + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3SNL2 :'/ & + ' xnl_main RETURN CODE NON ZERO : ',I4,' ***'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SNL2 : IQTPE :',I4) +9000 FORMAT (' TEST W3SNL2 : IQTPE :',I4) #endif -!/ -!/ End of W3SNL2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SNL2 -!/ ------------------------------------------------------------------- / - SUBROUTINE INSNL2 -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | G. Ph. van Vledder | -!/ | FORTRAN 90 | -!/ | Last update : 24-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 02-Feb-2001 : Origination. ( version 2.07 ) -!/ 25-Sep-2003 : Exact-NL version 5.0 ( version 3.05 ) -!/ 24-Dec-2004 : Multiple model version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Preprocessing for nonlinear interactions (Xnl). -! -! 2. Method : -! -! See Xnl documentation. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! init_constants -! Subr. m_xnldata Xnl initialization routine. -! xnl_init Subr. m_constants Xnl initialization routine. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Model definition file management. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, SIG, TH, & - NLTAIL, DPTHNL, NDPTHS, IQTPE - USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPERR - USE W3SERVMD, ONLY: EXTCDE + !/ + !/ End of W3SNL2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SNL2 + !/ ------------------------------------------------------------------- / + SUBROUTINE INSNL2 + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | G. Ph. van Vledder | + !/ | FORTRAN 90 | + !/ | Last update : 24-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 02-Feb-2001 : Origination. ( version 2.07 ) + !/ 25-Sep-2003 : Exact-NL version 5.0 ( version 3.05 ) + !/ 24-Dec-2004 : Multiple model version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Preprocessing for nonlinear interactions (Xnl). + ! + ! 2. Method : + ! + ! See Xnl documentation. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! init_constants + ! Subr. m_xnldata Xnl initialization routine. + ! xnl_init Subr. m_constants Xnl initialization routine. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Model definition file management. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, SIG, TH, & + NLTAIL, DPTHNL, NDPTHS, IQTPE + USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPERR + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE m_xnldata - USE m_constants, ONLY: init_constants -!/ - IMPLICIT NONE -!/ -!/ Local parameters -!/ - INTEGER :: IGRD, IERR + USE m_xnldata + USE m_constants, ONLY: init_constants + !/ + IMPLICIT NONE + !/ + !/ Local parameters + !/ + INTEGER :: IGRD, IERR #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: XGRAV -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: XGRAV + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INSNL2') + CALL STRACE (IENT, 'INSNL2') #endif -! -! 1. Set necessary values : ----------------------------------------- * -! - XGRAV = GRAV - IGRD = 3 -! + ! + ! 1. Set necessary values : ----------------------------------------- * + ! + XGRAV = GRAV + IGRD = 3 + ! #ifdef W3_T - WRITE (NDST,9000) NLTAIL, XGRAV, IQTPE, IGRD, NDPTHS - WRITE (NDST,9001) DPTHNL - WRITE (NDST,9002) SIG(1)*TPIINV, SIG(NK)*TPIINV, & - TH(1)*RADE, TH(NTH)*RADE + WRITE (NDST,9000) NLTAIL, XGRAV, IQTPE, IGRD, NDPTHS + WRITE (NDST,9001) DPTHNL + WRITE (NDST,9002) SIG(1)*TPIINV, SIG(NK)*TPIINV, & + TH(1)*RADE, TH(NTH)*RADE #endif -! -! 2. Call initialization routines : --------------------------------- * -! - CALL init_constants -! - CALL xnl_init ( SIG(1:NK), TH, NK, NTH, NLTAIL, XGRAV, & - DPTHNL, NDPTHS, IQTPE, IGRD, IAPROC, IERR ) -! - IF ( IERR .NE. 0 ) GOTO 800 -! - RETURN -! -! Error escape locations -! - 800 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) IERR - CALL EXTCDE ( 1 ) -! -! Format statements -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN INSNL2 :'/ & - ' xnl_init RETURN CODE NON ZERO : ',I8/) -! + ! + ! 2. Call initialization routines : --------------------------------- * + ! + CALL init_constants + ! + CALL xnl_init ( SIG(1:NK), TH, NK, NTH, NLTAIL, XGRAV, & + DPTHNL, NDPTHS, IQTPE, IGRD, IAPROC, IERR ) + ! + IF ( IERR .NE. 0 ) GOTO 800 + ! + RETURN + ! + ! Error escape locations + ! +800 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) IERR + CALL EXTCDE ( 1 ) + ! + ! Format statements + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN INSNL2 :'/ & + ' xnl_init RETURN CODE NON ZERO : ',I8/) + ! #ifdef W3_T - 9000 FORMAT (' TEST INSNL2 : NLTAIL :',F6.1/ & - ' XGRAV :',F8.3/ & - ' IQTPE :',I4/ & - ' IGRD :',I4/ & - ' NDPTHS :',I4,' (depths follow)') - 9001 FORMAT (' ',5E10.3) - 9002 FORMAT (' FREQS :',2F8.3/ & - ' DIRS :',2F6.1) +9000 FORMAT (' TEST INSNL2 : NLTAIL :',F6.1/ & + ' XGRAV :',F8.3/ & + ' IQTPE :',I4/ & + ' IGRD :',I4/ & + ' NDPTHS :',I4,' (depths follow)') +9001 FORMAT (' ',5E10.3) +9002 FORMAT (' FREQS :',2F8.3/ & + ' DIRS :',2F6.1) #endif -!/ -!/ End of INSNL2 ----------------------------------------------------- / -!/ - END SUBROUTINE INSNL2 -!/ -!/ End of module W3SNL2MD -------------------------------------------- / -!/ - END MODULE W3SNL2MD + !/ + !/ End of INSNL2 ----------------------------------------------------- / + !/ + END SUBROUTINE INSNL2 + !/ + !/ End of module W3SNL2MD -------------------------------------------- / + !/ +END MODULE W3SNL2MD diff --git a/model/src/w3snl3md.F90 b/model/src/w3snl3md.F90 index 692fc35d6..69eec9718 100644 --- a/model/src/w3snl3md.F90 +++ b/model/src/w3snl3md.F90 @@ -1,918 +1,1227 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SNL3MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jul-2012 | -!/ +-----------------------------------+ -!/ -!/ 21-Jul-2008 : Origination as NLX option. ( version 3.13 ) -!/ 03-Jan-2009 : Bug fixes INSNLX. ( version 3.13 ) -!/ See remarks section for module. -!/ 25-Aug-2009 : Conversion to F(f,theta) form. ( version 3.13 ) -!/ 13-Nov-2009 : Bug fix DELTH in initialization. ( version 3.13 ) -!/ 01-Dec-2009 : Bug fix frequency filtering. ( version 3.13 ) -!/ 13-Aug-2010 : Move to NL3. ( version 3.15 ) -!/ 13-Jul-2012 : Moved from version 3.15 to 4.08. ( version 4.08 ) -!/ -!/ Copyright 2008-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! -! 1. Purpose : -! -! Generalized and optimized multiple DIA implementation. -! Expressions in terms of original F(f,theta) spectrum. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NKD I.P. Private Number of nondimensional depths in -! storage array. -! KDMIN R.P. Private Minimum relative depth in table. -! KDMAX R.P. Private Maximum relative depth in table. -! LAMMAX R.P. Public Maximum value for lambda or mu. -! DELTHM R.P. Public Maximum angle gap (degree). -! SITMIN Real Private Minimum nondimensional radian -! frequency in table. -! XSIT Real Private Corresponding increment factor. -! ---------------------------------------------------------------- -! -! See W3SNL3 and INSNL3 for documentation of variables in W3GDATMD -! as used here. -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SNL3 Subr. Public Multiple DIA for arbitrary depth. -! EXPAND Subr. W3SNL3 Expand spectrum for indirect address. -! EXPND2 Subr. W3SNL3 Expand Snl and D contributions. -! INSNL3 Subr. Public Corresponding initialization routine. -! MINLAM R.F. INSNL3 Minimum lambda for quadruplet. -! MAXLAM R.F. INSNL3 Maximum lambda for quadruplet. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W2SERVMD Program abort. -! WAVNU1 Subr. W3DISPMD Solve dispersion relation. -! WAVNU2 Subr. W3DISPMD Solve dispersion relation. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - Filtering techniques for computation of quadruplet spectral -! values and distribution in spectral space have been tested -! but were not found worth the large coding effort involved. -! - WAVNU1 is used in W3SNL3 for consistency with spectral grid -! description. -! - WAVNU2 is used in INSNL3 for accuracy in the computation of -! the layout of the quadruplets (higher computational cost is -! not an issue with initialization routine). -! - For large lambda or mu the original maximum kd = 10. still -! leads to significantly different quadruplet layout in -! secion 3. To remedy this, the orriginal settings of the -! lookup tables -! -! INTEGER, PRIVATE, PARAMETER :: NKD = 250 -! REAL, PRIVATE, PARAMETER :: KDMIN = 0.025 , KDMAX = 10. -! -! was reset to -! -! INTEGER, PRIVATE, PARAMETER :: NKD = 275 -! REAL, PRIVATE, PARAMETER :: KDMIN = 0.025 , KDMAX = 20. -! -! for the bug fix of 03-Jan-2009. Note that with this, the -! estimate of NTHMAX in INSNL3 also is needed to guarantee -! consistent NTHMAX and NTHM2 for any lambda and mu. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/Tn Test output (see main subroutines). -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER, PRIVATE, PARAMETER :: NKD = 275 - REAL, PRIVATE, PARAMETER :: KDMIN = 0.025 , KDMAX = 20. - REAL, PUBLIC, PARAMETER :: LAMMAX = 0.49999 - REAL, PUBLIC, PARAMETER :: DELTHM = 90. -! - REAL, PRIVATE :: SITMIN, XSIT -! - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SNL3 ( A, CG, WN, DEPTH, S, D ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Dec-2009 | -!/ +-----------------------------------+ -!/ -!/ 21-Jul-2008 : Origination as NLX option. ( version 3.13 ) -!/ 25-Aug-2009 : Conversion to F(f,theta) form. ( version 3.13 ) -!/ 01-Dec-2009 : Bug fix frequency filtering. ( version 3.13 ) -!/ -! 1. Purpose : -! -! Multiple Discrete Interaction Parameterization for arbitrary -! depths with generalized quadruplet layout. -! -! 2. Method : -! -! This is a direct implementation of the Discrete Interaction -! Paramterization (DIA) with multiple representative quadruplets -! (MDIA) for arbitrary water depths. -! -! The outer loop of the code is over quadruplet realizations, -! which implies two realizations for a conventional quadruplet -! definitions and four for extended definitions (with rescaling -! of the contants for consistency). Within this loop the compu- -! tations are performed in two stages. First, interactions -! contributions are computed for the entire spectral space, -! second all contributions are combined into the actual inter- -! actions and diagonal contributions. -! -! Arbitrary depths are addressed by generating a lookup table -! for the relative depth. These tables are used for each discrete -! frequency separately. Efficient memory usages requires relative -! addressing to reduce the size of the lookup tables. To use this -! the spectral space is expanded to higher and lower frequencies -! as well as directional space is expanded/volded. This is done -! for the input (pseudo-) spectrum (action spectrum devided by the -! wavenumber) to determine spectral densities at the quadruplet -! components, and the spectral space describing individual contri- -! butions before they are combined into the actual interactions. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action spectrum A(ITH,IK) as a function of -! direction (rad) and wavenumber. -! CG R.A. I Group velocities (dimension NK). -! WN R.A. I Wavenumbers (dimension NK). -! DEPTH Real I Water depth in meters. -! S R.A. O Source term. -! D R.A. O Diagonal term of derivative. -! ---------------------------------------------------------------- -! -! Variables describing the expanded frequency space from the -! dynamic storage in w3gdatmd. -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NFR Int. Public Number of frequencies or wavenumbers -! in discrete spectral space (NFR=>NK). -! NFRMIN Int. Public Minimum discrete frequency in the -! expanded frequency space. -! NFRMAX Int. Public Idem maximum for first part. -! NFRCUT Int. Public Idem maximum for second part. -! NTHMAX Int. Public Extension of directional space. -! NTHEXP Int Public Number of bins in extended dir. space. -! NSPMIN, NSPMAX, NSPMX2 -! Int. Public 1D spectral space range. -! FRQ R.A. Public Expanded frequency range (Hz). -! XSI R.A. Public Expanded frequency range (rad/s). -! ---------------------------------------------------------------- -! -! Variables describing lookup tables. -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NQA Int. Public Number of actual quadruplets. -! QST1 I.A. Public Spectral offsets for compuation of -! quadruplet spectral desnities. -! QST2 R.A. Public Idem weights. -! QST3 R.A. Public Norm. factors in product term and -! in diagonal strength. -! QST4 I.A. Public Spectral offsets for combining of -! interactions and diagonal. -! QST5 R.A. Public Idem weights for interactions. -! QST6 R.A. Public Idem weights for diagonal. -! ---------------------------------------------------------------- -! -! Variables describing model setup. -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! SNLMSC Real Public Tuning power 'deep' scaling. -! SNLNSC Real Public Tuning power 'shallow' scaling. -! SNLSFD Real Public 'Deep' nondimensional filer freq. -! SNLSFS Real Public 'Shallow' nondimensional filer freq. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Note that this code uses explicit unroling of potential loop -! structures for optimization purposes. -! - Normalization with respect to the number of quadruplets is -! included in the proportionality constant. -! - Note that the outer loop in the routine considers one actual -! quadruplet realization per loop cycle. For the traditional -! quadruplet layout two realizations occure, for the expanded -! four realizations occur. For consistency, strength of a -! traditional layout is therefore doubled. -! - 1D representation is used of 2D spectral space for optimization -! purposes. -! - Contributions are first computed in the convetional spectral -! space and are then expancded "in place" into the expanded -! spectral space in EXPND2. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NFR => NK, NTH, SIG, FACHFE, FACTI1, FACTI2,& - NFRMIN, NFRMAX, NFRCUT, NTHMAX, NTHEXP, & - NSPMIN, NSPMAX, NSPMX2, FRQ, XSI, NQA, & - QST1, QST2, QST3, QST4, QST5, QST6, SNLMSC, & - SNLNSC, SNLSFD, SNLSFS - USE W3ODATMD, ONLY: NDSE, NDST -! - USE W3SERVMD, ONLY: EXTCDE - USE W3DISPMD, ONLY: WAVNU1 +MODULE W3SNL3MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jul-2012 | + !/ +-----------------------------------+ + !/ + !/ 21-Jul-2008 : Origination as NLX option. ( version 3.13 ) + !/ 03-Jan-2009 : Bug fixes INSNLX. ( version 3.13 ) + !/ See remarks section for module. + !/ 25-Aug-2009 : Conversion to F(f,theta) form. ( version 3.13 ) + !/ 13-Nov-2009 : Bug fix DELTH in initialization. ( version 3.13 ) + !/ 01-Dec-2009 : Bug fix frequency filtering. ( version 3.13 ) + !/ 13-Aug-2010 : Move to NL3. ( version 3.15 ) + !/ 13-Jul-2012 : Moved from version 3.15 to 4.08. ( version 4.08 ) + !/ + !/ Copyright 2008-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! + ! 1. Purpose : + ! + ! Generalized and optimized multiple DIA implementation. + ! Expressions in terms of original F(f,theta) spectrum. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NKD I.P. Private Number of nondimensional depths in + ! storage array. + ! KDMIN R.P. Private Minimum relative depth in table. + ! KDMAX R.P. Private Maximum relative depth in table. + ! LAMMAX R.P. Public Maximum value for lambda or mu. + ! DELTHM R.P. Public Maximum angle gap (degree). + ! SITMIN Real Private Minimum nondimensional radian + ! frequency in table. + ! XSIT Real Private Corresponding increment factor. + ! ---------------------------------------------------------------- + ! + ! See W3SNL3 and INSNL3 for documentation of variables in W3GDATMD + ! as used here. + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SNL3 Subr. Public Multiple DIA for arbitrary depth. + ! EXPAND Subr. W3SNL3 Expand spectrum for indirect address. + ! EXPND2 Subr. W3SNL3 Expand Snl and D contributions. + ! INSNL3 Subr. Public Corresponding initialization routine. + ! MINLAM R.F. INSNL3 Minimum lambda for quadruplet. + ! MAXLAM R.F. INSNL3 Maximum lambda for quadruplet. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W2SERVMD Program abort. + ! WAVNU1 Subr. W3DISPMD Solve dispersion relation. + ! WAVNU2 Subr. W3DISPMD Solve dispersion relation. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - Filtering techniques for computation of quadruplet spectral + ! values and distribution in spectral space have been tested + ! but were not found worth the large coding effort involved. + ! - WAVNU1 is used in W3SNL3 for consistency with spectral grid + ! description. + ! - WAVNU2 is used in INSNL3 for accuracy in the computation of + ! the layout of the quadruplets (higher computational cost is + ! not an issue with initialization routine). + ! - For large lambda or mu the original maximum kd = 10. still + ! leads to significantly different quadruplet layout in + ! secion 3. To remedy this, the orriginal settings of the + ! lookup tables + ! + ! INTEGER, PRIVATE, PARAMETER :: NKD = 250 + ! REAL, PRIVATE, PARAMETER :: KDMIN = 0.025 , KDMAX = 10. + ! + ! was reset to + ! + ! INTEGER, PRIVATE, PARAMETER :: NKD = 275 + ! REAL, PRIVATE, PARAMETER :: KDMIN = 0.025 , KDMAX = 20. + ! + ! for the bug fix of 03-Jan-2009. Note that with this, the + ! estimate of NTHMAX in INSNL3 also is needed to guarantee + ! consistent NTHMAX and NTHM2 for any lambda and mu. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/Tn Test output (see main subroutines). + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER, PRIVATE, PARAMETER :: NKD = 275 + REAL, PRIVATE, PARAMETER :: KDMIN = 0.025 , KDMAX = 20. + REAL, PUBLIC, PARAMETER :: LAMMAX = 0.49999 + REAL, PUBLIC, PARAMETER :: DELTHM = 90. + ! + REAL, PRIVATE :: SITMIN, XSIT + ! + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SNL3 ( A, CG, WN, DEPTH, S, D ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Dec-2009 | + !/ +-----------------------------------+ + !/ + !/ 21-Jul-2008 : Origination as NLX option. ( version 3.13 ) + !/ 25-Aug-2009 : Conversion to F(f,theta) form. ( version 3.13 ) + !/ 01-Dec-2009 : Bug fix frequency filtering. ( version 3.13 ) + !/ + ! 1. Purpose : + ! + ! Multiple Discrete Interaction Parameterization for arbitrary + ! depths with generalized quadruplet layout. + ! + ! 2. Method : + ! + ! This is a direct implementation of the Discrete Interaction + ! Paramterization (DIA) with multiple representative quadruplets + ! (MDIA) for arbitrary water depths. + ! + ! The outer loop of the code is over quadruplet realizations, + ! which implies two realizations for a conventional quadruplet + ! definitions and four for extended definitions (with rescaling + ! of the contants for consistency). Within this loop the compu- + ! tations are performed in two stages. First, interactions + ! contributions are computed for the entire spectral space, + ! second all contributions are combined into the actual inter- + ! actions and diagonal contributions. + ! + ! Arbitrary depths are addressed by generating a lookup table + ! for the relative depth. These tables are used for each discrete + ! frequency separately. Efficient memory usages requires relative + ! addressing to reduce the size of the lookup tables. To use this + ! the spectral space is expanded to higher and lower frequencies + ! as well as directional space is expanded/volded. This is done + ! for the input (pseudo-) spectrum (action spectrum devided by the + ! wavenumber) to determine spectral densities at the quadruplet + ! components, and the spectral space describing individual contri- + ! butions before they are combined into the actual interactions. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action spectrum A(ITH,IK) as a function of + ! direction (rad) and wavenumber. + ! CG R.A. I Group velocities (dimension NK). + ! WN R.A. I Wavenumbers (dimension NK). + ! DEPTH Real I Water depth in meters. + ! S R.A. O Source term. + ! D R.A. O Diagonal term of derivative. + ! ---------------------------------------------------------------- + ! + ! Variables describing the expanded frequency space from the + ! dynamic storage in w3gdatmd. + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NFR Int. Public Number of frequencies or wavenumbers + ! in discrete spectral space (NFR=>NK). + ! NFRMIN Int. Public Minimum discrete frequency in the + ! expanded frequency space. + ! NFRMAX Int. Public Idem maximum for first part. + ! NFRCUT Int. Public Idem maximum for second part. + ! NTHMAX Int. Public Extension of directional space. + ! NTHEXP Int Public Number of bins in extended dir. space. + ! NSPMIN, NSPMAX, NSPMX2 + ! Int. Public 1D spectral space range. + ! FRQ R.A. Public Expanded frequency range (Hz). + ! XSI R.A. Public Expanded frequency range (rad/s). + ! ---------------------------------------------------------------- + ! + ! Variables describing lookup tables. + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NQA Int. Public Number of actual quadruplets. + ! QST1 I.A. Public Spectral offsets for compuation of + ! quadruplet spectral desnities. + ! QST2 R.A. Public Idem weights. + ! QST3 R.A. Public Norm. factors in product term and + ! in diagonal strength. + ! QST4 I.A. Public Spectral offsets for combining of + ! interactions and diagonal. + ! QST5 R.A. Public Idem weights for interactions. + ! QST6 R.A. Public Idem weights for diagonal. + ! ---------------------------------------------------------------- + ! + ! Variables describing model setup. + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! SNLMSC Real Public Tuning power 'deep' scaling. + ! SNLNSC Real Public Tuning power 'shallow' scaling. + ! SNLSFD Real Public 'Deep' nondimensional filer freq. + ! SNLSFS Real Public 'Shallow' nondimensional filer freq. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Note that this code uses explicit unroling of potential loop + ! structures for optimization purposes. + ! - Normalization with respect to the number of quadruplets is + ! included in the proportionality constant. + ! - Note that the outer loop in the routine considers one actual + ! quadruplet realization per loop cycle. For the traditional + ! quadruplet layout two realizations occure, for the expanded + ! four realizations occur. For consistency, strength of a + ! traditional layout is therefore doubled. + ! - 1D representation is used of 2D spectral space for optimization + ! purposes. + ! - Contributions are first computed in the convetional spectral + ! space and are then expancded "in place" into the expanded + ! spectral space in EXPND2. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NFR => NK, NTH, SIG, FACHFE, FACTI1, FACTI2,& + NFRMIN, NFRMAX, NFRCUT, NTHMAX, NTHEXP, & + NSPMIN, NSPMAX, NSPMX2, FRQ, XSI, NQA, & + QST1, QST2, QST3, QST4, QST5, QST6, SNLMSC, & + SNLNSC, SNLSFD, SNLSFS + USE W3ODATMD, ONLY: NDSE, NDST + ! + USE W3SERVMD, ONLY: EXTCDE + USE W3DISPMD, ONLY: WAVNU1 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NFR), CG(NFR), WN(NFR), DEPTH - REAL, INTENT(OUT) :: S(NTH,NFR), D(NTH,NFR) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IFR, IERR, IKD, JKD(NFRCUT), IQA, IF1MIN, & - IF1MAX, IF2MIN, IF2MAX, ISP0, ISPX0, ITH, & - ISP, ISPX + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NFR), CG(NFR), WN(NFR), DEPTH + REAL, INTENT(OUT) :: S(NTH,NFR), D(NTH,NFR) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IFR, IERR, IKD, JKD(NFRCUT), IQA, IF1MIN, & + IF1MAX, IF2MIN, IF2MAX, ISP0, ISPX0, ITH, & + ISP, ISPX #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: LQST1(16), LQST4(16) - REAL :: XSITLN, SIT, FPROP, FQ1, FQ2, FQ3, FQ4, & - AUX1, AUX2 - REAL :: XWN(NFRMAX), XCG(NFRMAX), SCALE1(NFRCUT), & - SCALE2(NFRCUT), LQST2(16), FACT(6), & - LQST5(16), LQST6(16) - REAL :: UE(NSPMIN:NSPMAX), DSB(NSPMIN:NSPMX2), & - DD1(NSPMIN:NSPMX2), DD2(NSPMIN:NSPMX2), & - DD3(NSPMIN:NSPMX2), DD4(NSPMIN:NSPMX2) -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: LQST1(16), LQST4(16) + REAL :: XSITLN, SIT, FPROP, FQ1, FQ2, FQ3, FQ4, & + AUX1, AUX2 + REAL :: XWN(NFRMAX), XCG(NFRMAX), SCALE1(NFRCUT), & + SCALE2(NFRCUT), LQST2(16), FACT(6), & + LQST5(16), LQST6(16) + REAL :: UE(NSPMIN:NSPMAX), DSB(NSPMIN:NSPMX2), & + DD1(NSPMIN:NSPMX2), DD2(NSPMIN:NSPMX2), & + DD3(NSPMIN:NSPMX2), DD4(NSPMIN:NSPMX2) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SNL3') + CALL STRACE (IENT, 'W3SNL3') #endif -! -! 1. Initialization ------------------------------------------------- * -! 1.a Constants and arrays -! - XSITLN = LOG(XSIT) -! - S = 0. - D = 0. -! DSB = 0. -! DD1 = 0. -! DD2 = 0. -! DD3 = 0. -! DD4 = 0. -! -! 1.a Extended frequency range -! - XWN(1:NFR) = WN - XCG(1:NFR) = CG -! - DO IFR = NFR+1, NFRMAX - CALL WAVNU1 ( XSI(IFR), DEPTH, XWN(IFR), XCG(IFR) ) - END DO -! -! 1.b Expanded pseudo spetrum -! - CALL EXPAND ( UE ) -! -! 1.c Set up scaling functions -! - AUX1 = 1. / ( TPI**11 * GRAV**(4.-SNLMSC) ) - AUX2 = GRAV**2 / TPI**11 -! - DO IFR=1, NFRCUT - SCALE1(IFR) = AUX1 * XWN(IFR)**(4.+SNLMSC) * & - XSI(IFR)**(13.-2.*SNLMSC) / XCG(IFR)**2 - SCALE2(IFR) = AUX2 * XWN(IFR)**11 * & - (XWN(IFR)*DEPTH)**SNLNSC / XCG(IFR) - END DO -! -! 1.d Set up depth scaling counters -! - DO IFR=1, NFRCUT - SIT = XSI(IFR) * SQRT(DEPTH/GRAV) - IKD = 1 + NINT ( ( LOG(SIT) - LOG(SITMIN) ) / XSITLN ) - JKD(IFR) = MAX ( 1 , MIN(IKD,NKD) ) - END DO -! -! 2. Base loop over quadruplet realizations ------------------------- * -! - DO IQA=1 , NQA -! -! 3. Obtain quadruplet energies for all spectral bins --------------- * -! 3.a Set frequency ranges -! - AUX1 = QST3(5,IQA,1) - AUX2 = QST3(6,IQA,1) -! - IF1MIN = 1 - IF1MAX = NFRCUT - IF2MIN = 1 - IF2MAX = NFR -! - IF ( AUX1 .LE. 0. .AND. AUX2 .LE. 0. ) THEN -! - CYCLE -! - ELSE IF ( AUX2 .LE. 0. ) THEN -! - SIT = SNLSFD * SQRT(GRAV/DEPTH) - IFR = NINT ( FACTI2 + FACTI1*LOG(SIT) ) - IF ( IFR .GT. NFR ) CYCLE -! - IF ( IFR .GT. 1 ) THEN - IF1MIN = MAX ( 1 , IFR ) - IF2MIN = MAX ( 1 , IF1MIN + NFRMIN ) - DSB(1:(IF1MIN-1)*NTH) = 0. - DD1(1:(IF1MIN-1)*NTH) = 0. - DD2(1:(IF1MIN-1)*NTH) = 0. - DD3(1:(IF1MIN-1)*NTH) = 0. - DD4(1:(IF1MIN-1)*NTH) = 0. - END IF -! - ELSE IF ( AUX1 .LE. 0. ) THEN -! - SIT = SNLSFS * SQRT(GRAV/DEPTH) - IFR = NINT ( FACTI2 + FACTI1*LOG(SIT) ) - IF ( IFR .LT. 1 ) CYCLE -! - IF ( IFR .LT. NFRCUT ) THEN - IF1MAX = MIN ( NFRCUT, IFR ) -! IF2MAX = NFR - DSB(IF1MAX*NTH+1:NFRCUT*NTH) = 0. - DD1(IF1MAX*NTH+1:NFRCUT*NTH) = 0. - DD2(IF1MAX*NTH+1:NFRCUT*NTH) = 0. - DD3(IF1MAX*NTH+1:NFRCUT*NTH) = 0. - DD4(IF1MAX*NTH+1:NFRCUT*NTH) = 0. - END IF -! - END IF -! -! 3.b Loop over frequencies -! - DO IFR=IF1MIN, IF1MAX -! -! 3.c Find discrete depths -! - IKD = JKD(IFR) -! -! 3.d Get offsets and weights -! - LQST1 = QST1(:,IQA,IKD) - LQST2 = QST2(:,IQA,IKD) - FACT = QST3(:,IQA,IKD) - FACT(1:4) = FACT(1:4) * XCG(IFR) / ( XWN(IFR) *XSI(IFR) ) - FPROP = SCALE1(IFR)*FACT(5) + SCALE2(IFR)*FACT(6) -! -! 3.e Loop over directions -! - ISP0 = (IFR-1)*NTH - ISPX0 = (IFR-1)*NTHEXP -! - DO ITH=1, NTH -! - ISP = ISP0 + ITH - ISPX = ISPX0 + ITH -! - FQ1 = ( UE(ISPX+LQST1( 1)) * LQST2( 1) + & - UE(ISPX+LQST1( 2)) * LQST2( 2) + & - UE(ISPX+LQST1( 3)) * LQST2( 3) + & - UE(ISPX+LQST1( 4)) * LQST2( 4) ) * FACT(1) - FQ2 = ( UE(ISPX+LQST1( 5)) * LQST2( 5) + & - UE(ISPX+LQST1( 6)) * LQST2( 6) + & - UE(ISPX+LQST1( 7)) * LQST2( 7) + & - UE(ISPX+LQST1( 8)) * LQST2( 8) ) * FACT(2) - FQ3 = ( UE(ISPX+LQST1( 9)) * LQST2( 9) + & - UE(ISPX+LQST1(10)) * LQST2(10) + & - UE(ISPX+LQST1(11)) * LQST2(11) + & - UE(ISPX+LQST1(12)) * LQST2(12) ) * FACT(3) - FQ4 = ( UE(ISPX+LQST1(13)) * LQST2(13) + & - UE(ISPX+LQST1(14)) * LQST2(14) + & - UE(ISPX+LQST1(15)) * LQST2(15) + & - UE(ISPX+LQST1(16)) * LQST2(16) ) * FACT(4) -! - AUX1 = FQ1 * FQ2 * ( FQ3 + FQ4 ) - AUX2 = FQ3 * FQ4 * ( FQ1 + FQ2 ) - DSB(ISP) = FPROP * ( AUX1 - AUX2 ) -! - AUX1 = FQ3 + FQ4 - AUX2 = FQ3 * FQ4 - DD1(ISP) = FPROP * FACT(1) * ( FQ2 * AUX1 - AUX2 ) - DD2(ISP) = FPROP * FACT(2) * ( FQ1 * AUX1 - AUX2 ) -! - AUX1 = FQ1 + FQ2 - AUX2 = FQ1 * FQ2 - DD3(ISP) = FPROP * FACT(3) * ( AUX2 - FQ4*AUX1 ) - DD4(ISP) = FPROP * FACT(4) * ( AUX2 - FQ3*AUX1 ) -! -! ... End loop 3.e -! - END DO -! -! ... End loop 3.b -! - END DO -! -! 3.e Expand arrays -! - CALL EXPND2 ( DSB(1:NTH*NFRCUT), DSB ) - CALL EXPND2 ( DD1(1:NTH*NFRCUT), DD1 ) - CALL EXPND2 ( DD2(1:NTH*NFRCUT), DD2 ) - CALL EXPND2 ( DD3(1:NTH*NFRCUT), DD3 ) - CALL EXPND2 ( DD4(1:NTH*NFRCUT), DD4 ) -! -! 4. Put it all together -------------------------------------------- * -! 4.a Loop over frequencies -! - DO IFR=IF2MIN, IF2MAX -! -! 4.b Find discrete depths and storage -! - IKD = JKD(IFR) -! -! 4.c Get offsets and weights -! - LQST4 = QST4(:,IQA,IKD) - LQST5 = QST5(:,IQA,IKD) - LQST6 = QST6(:,IQA,IKD) -! -! 4.d Loop over directions -! - ISPX0 = (IFR-1)*NTHEXP -! - DO ITH=1, NTH -! - ISPX = ISPX0 + ITH -! - S(ITH,IFR) = S(ITH,IFR) + DSB(ISPX+LQST4( 1)) * LQST5( 1) & - + DSB(ISPX+LQST4( 2)) * LQST5( 2) & - + DSB(ISPX+LQST4( 3)) * LQST5( 3) & - + DSB(ISPX+LQST4( 4)) * LQST5( 4) & - + DSB(ISPX+LQST4( 5)) * LQST5( 5) & - + DSB(ISPX+LQST4( 6)) * LQST5( 6) & - + DSB(ISPX+LQST4( 7)) * LQST5( 7) & - + DSB(ISPX+LQST4( 8)) * LQST5( 8) & - + DSB(ISPX+LQST4( 9)) * LQST5( 9) & - + DSB(ISPX+LQST4(10)) * LQST5(10) & - + DSB(ISPX+LQST4(11)) * LQST5(11) & - + DSB(ISPX+LQST4(12)) * LQST5(12) & - + DSB(ISPX+LQST4(13)) * LQST5(13) & - + DSB(ISPX+LQST4(14)) * LQST5(14) & - + DSB(ISPX+LQST4(15)) * LQST5(15) & - + DSB(ISPX+LQST4(16)) * LQST5(16) -! - D(ITH,IFR) = D(ITH,IFR) + DD1(ISPX+LQST4( 1)) * LQST6( 1) & - + DD1(ISPX+LQST4( 2)) * LQST6( 2) & - + DD1(ISPX+LQST4( 3)) * LQST6( 3) & - + DD1(ISPX+LQST4( 4)) * LQST6( 4) & - + DD2(ISPX+LQST4( 5)) * LQST6( 5) & - + DD2(ISPX+LQST4( 6)) * LQST6( 6) & - + DD2(ISPX+LQST4( 7)) * LQST6( 7) & - + DD2(ISPX+LQST4( 8)) * LQST6( 8) & - + DD3(ISPX+LQST4( 9)) * LQST6( 9) & - + DD3(ISPX+LQST4(10)) * LQST6(10) & - + DD3(ISPX+LQST4(11)) * LQST6(11) & - + DD3(ISPX+LQST4(12)) * LQST6(12) & - + DD4(ISPX+LQST4(13)) * LQST6(13) & - + DD4(ISPX+LQST4(14)) * LQST6(14) & - + DD4(ISPX+LQST4(15)) * LQST6(15) & - + DD4(ISPX+LQST4(16)) * LQST6(16) -! -! ... End loop 4.d -! - END DO -! -! ... End loop 4.a -! - END DO -! -! ... End of loop 2. -! + ! + ! 1. Initialization ------------------------------------------------- * + ! 1.a Constants and arrays + ! + XSITLN = LOG(XSIT) + ! + S = 0. + D = 0. + ! DSB = 0. + ! DD1 = 0. + ! DD2 = 0. + ! DD3 = 0. + ! DD4 = 0. + ! + ! 1.a Extended frequency range + ! + XWN(1:NFR) = WN + XCG(1:NFR) = CG + ! + DO IFR = NFR+1, NFRMAX + CALL WAVNU1 ( XSI(IFR), DEPTH, XWN(IFR), XCG(IFR) ) + END DO + ! + ! 1.b Expanded pseudo spetrum + ! + CALL EXPAND ( UE ) + ! + ! 1.c Set up scaling functions + ! + AUX1 = 1. / ( TPI**11 * GRAV**(4.-SNLMSC) ) + AUX2 = GRAV**2 / TPI**11 + ! + DO IFR=1, NFRCUT + SCALE1(IFR) = AUX1 * XWN(IFR)**(4.+SNLMSC) * & + XSI(IFR)**(13.-2.*SNLMSC) / XCG(IFR)**2 + SCALE2(IFR) = AUX2 * XWN(IFR)**11 * & + (XWN(IFR)*DEPTH)**SNLNSC / XCG(IFR) + END DO + ! + ! 1.d Set up depth scaling counters + ! + DO IFR=1, NFRCUT + SIT = XSI(IFR) * SQRT(DEPTH/GRAV) + IKD = 1 + NINT ( ( LOG(SIT) - LOG(SITMIN) ) / XSITLN ) + JKD(IFR) = MAX ( 1 , MIN(IKD,NKD) ) + END DO + ! + ! 2. Base loop over quadruplet realizations ------------------------- * + ! + DO IQA=1 , NQA + ! + ! 3. Obtain quadruplet energies for all spectral bins --------------- * + ! 3.a Set frequency ranges + ! + AUX1 = QST3(5,IQA,1) + AUX2 = QST3(6,IQA,1) + ! + IF1MIN = 1 + IF1MAX = NFRCUT + IF2MIN = 1 + IF2MAX = NFR + ! + IF ( AUX1 .LE. 0. .AND. AUX2 .LE. 0. ) THEN + ! + CYCLE + ! + ELSE IF ( AUX2 .LE. 0. ) THEN + ! + SIT = SNLSFD * SQRT(GRAV/DEPTH) + IFR = NINT ( FACTI2 + FACTI1*LOG(SIT) ) + IF ( IFR .GT. NFR ) CYCLE + ! + IF ( IFR .GT. 1 ) THEN + IF1MIN = MAX ( 1 , IFR ) + IF2MIN = MAX ( 1 , IF1MIN + NFRMIN ) + DSB(1:(IF1MIN-1)*NTH) = 0. + DD1(1:(IF1MIN-1)*NTH) = 0. + DD2(1:(IF1MIN-1)*NTH) = 0. + DD3(1:(IF1MIN-1)*NTH) = 0. + DD4(1:(IF1MIN-1)*NTH) = 0. + END IF + ! + ELSE IF ( AUX1 .LE. 0. ) THEN + ! + SIT = SNLSFS * SQRT(GRAV/DEPTH) + IFR = NINT ( FACTI2 + FACTI1*LOG(SIT) ) + IF ( IFR .LT. 1 ) CYCLE + ! + IF ( IFR .LT. NFRCUT ) THEN + IF1MAX = MIN ( NFRCUT, IFR ) + ! IF2MAX = NFR + DSB(IF1MAX*NTH+1:NFRCUT*NTH) = 0. + DD1(IF1MAX*NTH+1:NFRCUT*NTH) = 0. + DD2(IF1MAX*NTH+1:NFRCUT*NTH) = 0. + DD3(IF1MAX*NTH+1:NFRCUT*NTH) = 0. + DD4(IF1MAX*NTH+1:NFRCUT*NTH) = 0. + END IF + ! + END IF + ! + ! 3.b Loop over frequencies + ! + DO IFR=IF1MIN, IF1MAX + ! + ! 3.c Find discrete depths + ! + IKD = JKD(IFR) + ! + ! 3.d Get offsets and weights + ! + LQST1 = QST1(:,IQA,IKD) + LQST2 = QST2(:,IQA,IKD) + FACT = QST3(:,IQA,IKD) + FACT(1:4) = FACT(1:4) * XCG(IFR) / ( XWN(IFR) *XSI(IFR) ) + FPROP = SCALE1(IFR)*FACT(5) + SCALE2(IFR)*FACT(6) + ! + ! 3.e Loop over directions + ! + ISP0 = (IFR-1)*NTH + ISPX0 = (IFR-1)*NTHEXP + ! + DO ITH=1, NTH + ! + ISP = ISP0 + ITH + ISPX = ISPX0 + ITH + ! + FQ1 = ( UE(ISPX+LQST1( 1)) * LQST2( 1) + & + UE(ISPX+LQST1( 2)) * LQST2( 2) + & + UE(ISPX+LQST1( 3)) * LQST2( 3) + & + UE(ISPX+LQST1( 4)) * LQST2( 4) ) * FACT(1) + FQ2 = ( UE(ISPX+LQST1( 5)) * LQST2( 5) + & + UE(ISPX+LQST1( 6)) * LQST2( 6) + & + UE(ISPX+LQST1( 7)) * LQST2( 7) + & + UE(ISPX+LQST1( 8)) * LQST2( 8) ) * FACT(2) + FQ3 = ( UE(ISPX+LQST1( 9)) * LQST2( 9) + & + UE(ISPX+LQST1(10)) * LQST2(10) + & + UE(ISPX+LQST1(11)) * LQST2(11) + & + UE(ISPX+LQST1(12)) * LQST2(12) ) * FACT(3) + FQ4 = ( UE(ISPX+LQST1(13)) * LQST2(13) + & + UE(ISPX+LQST1(14)) * LQST2(14) + & + UE(ISPX+LQST1(15)) * LQST2(15) + & + UE(ISPX+LQST1(16)) * LQST2(16) ) * FACT(4) + ! + AUX1 = FQ1 * FQ2 * ( FQ3 + FQ4 ) + AUX2 = FQ3 * FQ4 * ( FQ1 + FQ2 ) + DSB(ISP) = FPROP * ( AUX1 - AUX2 ) + ! + AUX1 = FQ3 + FQ4 + AUX2 = FQ3 * FQ4 + DD1(ISP) = FPROP * FACT(1) * ( FQ2 * AUX1 - AUX2 ) + DD2(ISP) = FPROP * FACT(2) * ( FQ1 * AUX1 - AUX2 ) + ! + AUX1 = FQ1 + FQ2 + AUX2 = FQ1 * FQ2 + DD3(ISP) = FPROP * FACT(3) * ( AUX2 - FQ4*AUX1 ) + DD4(ISP) = FPROP * FACT(4) * ( AUX2 - FQ3*AUX1 ) + ! + ! ... End loop 3.e + ! END DO -! -! 5. Convert back to wave action ------------------------------------ * -! + ! + ! ... End loop 3.b + ! + END DO + ! + ! 3.e Expand arrays + ! + CALL EXPND2 ( DSB(1:NTH*NFRCUT), DSB ) + CALL EXPND2 ( DD1(1:NTH*NFRCUT), DD1 ) + CALL EXPND2 ( DD2(1:NTH*NFRCUT), DD2 ) + CALL EXPND2 ( DD3(1:NTH*NFRCUT), DD3 ) + CALL EXPND2 ( DD4(1:NTH*NFRCUT), DD4 ) + ! + ! 4. Put it all together -------------------------------------------- * + ! 4.a Loop over frequencies + ! DO IFR=IF2MIN, IF2MAX - S(:,IFR) = S(:,IFR) / XSI(IFR) * XCG(IFR) * TPIINV + ! + ! 4.b Find discrete depths and storage + ! + IKD = JKD(IFR) + ! + ! 4.c Get offsets and weights + ! + LQST4 = QST4(:,IQA,IKD) + LQST5 = QST5(:,IQA,IKD) + LQST6 = QST6(:,IQA,IKD) + ! + ! 4.d Loop over directions + ! + ISPX0 = (IFR-1)*NTHEXP + ! + DO ITH=1, NTH + ! + ISPX = ISPX0 + ITH + ! + S(ITH,IFR) = S(ITH,IFR) + DSB(ISPX+LQST4( 1)) * LQST5( 1) & + + DSB(ISPX+LQST4( 2)) * LQST5( 2) & + + DSB(ISPX+LQST4( 3)) * LQST5( 3) & + + DSB(ISPX+LQST4( 4)) * LQST5( 4) & + + DSB(ISPX+LQST4( 5)) * LQST5( 5) & + + DSB(ISPX+LQST4( 6)) * LQST5( 6) & + + DSB(ISPX+LQST4( 7)) * LQST5( 7) & + + DSB(ISPX+LQST4( 8)) * LQST5( 8) & + + DSB(ISPX+LQST4( 9)) * LQST5( 9) & + + DSB(ISPX+LQST4(10)) * LQST5(10) & + + DSB(ISPX+LQST4(11)) * LQST5(11) & + + DSB(ISPX+LQST4(12)) * LQST5(12) & + + DSB(ISPX+LQST4(13)) * LQST5(13) & + + DSB(ISPX+LQST4(14)) * LQST5(14) & + + DSB(ISPX+LQST4(15)) * LQST5(15) & + + DSB(ISPX+LQST4(16)) * LQST5(16) + ! + D(ITH,IFR) = D(ITH,IFR) + DD1(ISPX+LQST4( 1)) * LQST6( 1) & + + DD1(ISPX+LQST4( 2)) * LQST6( 2) & + + DD1(ISPX+LQST4( 3)) * LQST6( 3) & + + DD1(ISPX+LQST4( 4)) * LQST6( 4) & + + DD2(ISPX+LQST4( 5)) * LQST6( 5) & + + DD2(ISPX+LQST4( 6)) * LQST6( 6) & + + DD2(ISPX+LQST4( 7)) * LQST6( 7) & + + DD2(ISPX+LQST4( 8)) * LQST6( 8) & + + DD3(ISPX+LQST4( 9)) * LQST6( 9) & + + DD3(ISPX+LQST4(10)) * LQST6(10) & + + DD3(ISPX+LQST4(11)) * LQST6(11) & + + DD3(ISPX+LQST4(12)) * LQST6(12) & + + DD4(ISPX+LQST4(13)) * LQST6(13) & + + DD4(ISPX+LQST4(14)) * LQST6(14) & + + DD4(ISPX+LQST4(15)) * LQST6(15) & + + DD4(ISPX+LQST4(16)) * LQST6(16) + ! + ! ... End loop 4.d + ! END DO -! - RETURN -!/ -!/ Embedded subroutines -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE EXPAND ( SPEC ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 21-Aug-2009 | -!/ +-----------------------------------+ -!/ -!/ 03-Jul-2008 : Origination. ( version 3.13 ) -!/ 21-Aug-2009 : Conversion to F(f,theta) form. ( version 3.13 ) -!/ -! 1. Purpose : -! -! Expand spectrum, subroutine used to simplify addressing. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! SPEC R.A. O Expanded spectrum. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! + ! ... End loop 4.a + ! + END DO + ! + ! ... End of loop 2. + ! + END DO + ! + ! 5. Convert back to wave action ------------------------------------ * + ! + DO IFR=IF2MIN, IF2MAX + S(:,IFR) = S(:,IFR) / XSI(IFR) * XCG(IFR) * TPIINV + END DO + ! + RETURN + !/ + !/ Embedded subroutines + !/ + CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE EXPAND ( SPEC ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 21-Aug-2009 | + !/ +-----------------------------------+ + !/ + !/ 03-Jul-2008 : Origination. ( version 3.13 ) + !/ 21-Aug-2009 : Conversion to F(f,theta) form. ( version 3.13 ) + !/ + ! 1. Purpose : + ! + ! Expand spectrum, subroutine used to simplify addressing. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! SPEC R.A. O Expanded spectrum. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / IMPLICIT NONE -!/ -!/ Parameter list -!/ + !/ + !/ Parameter list + !/ REAL, INTENT(OUT) :: SPEC(1-NTHMAX:NTH+NTHMAX,NFRMIN:NFRMAX) -!/ -!/ Local parameters -!/ + !/ + !/ Local parameters + !/ INTEGER :: IFR, ITH -!/ -!/ ------------------------------------------------------------------- / -! + !/ + !/ ------------------------------------------------------------------- / + ! SPEC(:,NFRMIN:0) = 0. -! + ! SPEC(1:NTH,1:NFR) = A * TPI -! + ! DO IFR=1, NFR SPEC(1:NTH,IFR) = SPEC(1:NTH,IFR) * XSI(IFR) / XCG(IFR) - END DO -! + END DO + ! DO IFR=NFR+1, NFRMAX SPEC(1:NTH,IFR) = SPEC(1:NTH,IFR-1) * FACHFE - END DO -! + END DO + ! DO ITH=1, NTHMAX SPEC(NTH+ITH,1:NFRMAX) = SPEC( ITH ,1:NFRMAX) SPEC( 1 -ITH,1:NFRMAX) = SPEC(NTH+1-ITH,1:NFRMAX) - END DO -! + END DO + ! RETURN -!/ -!/ End of EXPAND ----------------------------------------------------- / -!/ - END SUBROUTINE EXPAND -!/ ------------------------------------------------------------------- / - SUBROUTINE EXPND2 ( ARIN, AROUT ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 16-Jul-2008 | -!/ +-----------------------------------+ -!/ -!/ 16-Jul-2008 : Origination. ( version 3.13 ) -!/ -! 1. Purpose : -! -! Expand spectrum to simplify indirect addressing. -! Done 'in place' with temporary array ( ARIN = AROUT ) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! SPIN R.A. I Input array. -! SPOUT R.A. I Output array. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ End of EXPAND ----------------------------------------------------- / + !/ + END SUBROUTINE EXPAND + !/ ------------------------------------------------------------------- / + SUBROUTINE EXPND2 ( ARIN, AROUT ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 16-Jul-2008 | + !/ +-----------------------------------+ + !/ + !/ 16-Jul-2008 : Origination. ( version 3.13 ) + !/ + ! 1. Purpose : + ! + ! Expand spectrum to simplify indirect addressing. + ! Done 'in place' with temporary array ( ARIN = AROUT ) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! SPIN R.A. I Input array. + ! SPOUT R.A. I Output array. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / IMPLICIT NONE -!/ -!/ Parameter list -!/ + !/ + !/ Parameter list + !/ REAL, INTENT(IN) :: ARIN(NTH,NFRCUT) REAL, INTENT(OUT) :: AROUT(1-NTHMAX:NTH+NTHMAX,NFRMIN:NFRCUT) -!/ -!/ Local parameters -!/ + !/ + !/ Local parameters + !/ INTEGER :: IFR, ITH REAL :: TEMP(NTH,NFRCUT) -!/ -!/ ------------------------------------------------------------------- / -! + !/ + !/ ------------------------------------------------------------------- / + ! TEMP = ARIN -! + ! AROUT(:,NFRMIN:0) = 0. -! + ! AROUT(1:NTH,1:NFRCUT) = TEMP -! + ! DO ITH=1, NTHMAX AROUT(NTH+ITH,1:NFRCUT) = AROUT( ITH ,1:NFRCUT) AROUT( 1 -ITH,1:NFRCUT) = AROUT(NTH+1-ITH,1:NFRCUT) - END DO -! + END DO + ! RETURN -!/ -!/ End of EXPND2 ----------------------------------------------------- / -!/ - END SUBROUTINE EXPND2 -!/ -!/ End of W3SNL3 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SNL3 -!/ ------------------------------------------------------------------- / - SUBROUTINE INSNL3 -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Nov-2009 | -!/ +-----------------------------------+ -!/ -!/ 21-Jul-2008 : Origination as NLX option. ( version 3.13 ) -!/ 03-Jan-2009 : Bug fixes NTHMAX and NTHMX2. ( version 3.13 ) -!/ 21-Aug-2009 : Conversion to F(f,theta) form. ( version 3.13 ) -!/ 13-Nov-2009 : Harden DELTH computation. ( version 3.13 ) -!/ -! 1. Purpose : -! -! Initialization for generalized multiple DIA routine. -! -! 2. Method : -! -! Fill storage aryays as described in the main subroutine with -! interpolation, model and distribution data. -! -! 3. Parameters : -! -! Variables in W3GDATMD describing model setup. -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! SNLNQ Int. Public Number of quadruplet definitions. -! SNLL R.A. Public Array with lambda for quadruplet. -! SNLM R.A. Public Array with mu for quadruplet. -! SNLT R.A. Public Array with Dtheta for quadruplet. -! SNLCD R.A. Public Array with Cd for quadruplet. -! SNLCS R.A. Public Array with Cs for quadruplet. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Program abort. -! WAVNU2 Subr. W3DISPMD Solve dispersion relation. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Process model definiton file. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See error escape location. -! -! 8. Remarks : -! -! - Allocation of arrays directly done in data structure, using -! IGRID and resetting pointer of aliaases. -! - In the 03-Jan-2009 bug fix !/T3 error output was fixed, and -! NTHMAX is increased by 1 to assure that NTHMX2 .LE. NTHMAX -! for any lambda and mu. With this, the label 810 test is -! changed from equality testing to .LE. testing. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T General test output. -! !/T1 Filling of lookup table for quadruplet and interaction -! strength. -! !/T2 Filling of lookup table for combining interactions. -! !/T3 Display raw lookup table of second type. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3ODATMD, ONLY: NDSE, NDST - USE W3GDATMD, NFR => NK -! - USE W3DISPMD, ONLY: WAVNU2 - USE W3SERVMD, ONLY: EXTCDE + !/ + !/ End of EXPND2 ----------------------------------------------------- / + !/ + END SUBROUTINE EXPND2 + !/ + !/ End of W3SNL3 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SNL3 + !/ ------------------------------------------------------------------- / + SUBROUTINE INSNL3 + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Nov-2009 | + !/ +-----------------------------------+ + !/ + !/ 21-Jul-2008 : Origination as NLX option. ( version 3.13 ) + !/ 03-Jan-2009 : Bug fixes NTHMAX and NTHMX2. ( version 3.13 ) + !/ 21-Aug-2009 : Conversion to F(f,theta) form. ( version 3.13 ) + !/ 13-Nov-2009 : Harden DELTH computation. ( version 3.13 ) + !/ + ! 1. Purpose : + ! + ! Initialization for generalized multiple DIA routine. + ! + ! 2. Method : + ! + ! Fill storage aryays as described in the main subroutine with + ! interpolation, model and distribution data. + ! + ! 3. Parameters : + ! + ! Variables in W3GDATMD describing model setup. + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! SNLNQ Int. Public Number of quadruplet definitions. + ! SNLL R.A. Public Array with lambda for quadruplet. + ! SNLM R.A. Public Array with mu for quadruplet. + ! SNLT R.A. Public Array with Dtheta for quadruplet. + ! SNLCD R.A. Public Array with Cd for quadruplet. + ! SNLCS R.A. Public Array with Cs for quadruplet. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Program abort. + ! WAVNU2 Subr. W3DISPMD Solve dispersion relation. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Process model definiton file. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See error escape location. + ! + ! 8. Remarks : + ! + ! - Allocation of arrays directly done in data structure, using + ! IGRID and resetting pointer of aliaases. + ! - In the 03-Jan-2009 bug fix !/T3 error output was fixed, and + ! NTHMAX is increased by 1 to assure that NTHMX2 .LE. NTHMAX + ! for any lambda and mu. With this, the label 810 test is + ! changed from equality testing to .LE. testing. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T General test output. + ! !/T1 Filling of lookup table for quadruplet and interaction + ! strength. + ! !/T2 Filling of lookup table for combining interactions. + ! !/T3 Display raw lookup table of second type. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3ODATMD, ONLY: NDSE, NDST + USE W3GDATMD, NFR => NK + ! + USE W3DISPMD, ONLY: WAVNU2 + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IFRMIN, IFRMAX, IKD, IERR, IQ, NQD, & - NQS, J, IFR, IQA, JJ, JF, NTHMX2, & - JIQ, JOF, JQR, IST - INTEGER :: JFR(4), JFR1(4), JTH(4), JTH1(4) + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IFRMIN, IFRMAX, IKD, IERR, IQ, NQD, & + NQS, J, IFR, IQA, JJ, JF, NTHMX2, & + JIQ, JOF, JQR, IST + INTEGER :: JFR(4), JFR1(4), JTH(4), JTH1(4) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, ALLOCATABLE :: AST1(:,:,:), AST2(:,:,:) - REAL :: SITMAX, XFRLN - REAL :: OFF12, OFF34, TH12, DEPTH, & - S0, S1, S2, S3, S4, AUXFR(4), & - WN0, WN1, WN2, WN3, WN4, & - CG0, CG1, CG2, CG3, CG4, AUXF, & - AA, BB, CC, DELTH(4), AUX1, AUX2, & - WFR(4), WFR1(4), WTH(4), WTH1(4), & - WFROFF, SIOFF, WF -! - TYPE QST - INTEGER :: OFR(4), OFR1(4), OTH(4), OTH1(4) - REAL :: HFR(4), HFR1(4), HTH(4), HTH1(4) - REAL :: F1, F2, F3, F4, CQD, CQS - END TYPE QST -! - TYPE(QST), ALLOCATABLE :: TSTORE(:,:) -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, ALLOCATABLE :: AST1(:,:,:), AST2(:,:,:) + REAL :: SITMAX, XFRLN + REAL :: OFF12, OFF34, TH12, DEPTH, & + S0, S1, S2, S3, S4, AUXFR(4), & + WN0, WN1, WN2, WN3, WN4, & + CG0, CG1, CG2, CG3, CG4, AUXF, & + AA, BB, CC, DELTH(4), AUX1, AUX2, & + WFR(4), WFR1(4), WTH(4), WTH1(4), & + WFROFF, SIOFF, WF + ! + TYPE QST + INTEGER :: OFR(4), OFR1(4), OTH(4), OTH1(4) + REAL :: HFR(4), HFR1(4), HTH(4), HTH1(4) + REAL :: F1, F2, F3, F4, CQD, CQS + END TYPE QST + ! + TYPE(QST), ALLOCATABLE :: TSTORE(:,:) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INSNL3') + CALL STRACE (IENT, 'INSNL3') #endif -! -! 1. Initialization ------------------------------------------------- * -! 1.a Checks -! - XFRLN = LOG(XFR) -! - IF ( LAMMAX.LE.0. .OR. LAMMAX.GT.0.5 .OR. DELTHM.LT.0. ) GOTO 800 -! -! 1.b Set up relative depths -! - ALLOCATE ( TSTORE(SNLNQ*4,1:NKD) ) -! - DEPTH = 1. - SITMIN = SQRT ( KDMIN * TANH(KDMIN) ) - SITMAX = SQRT ( KDMAX * TANH(KDMAX) ) - XSIT = (SITMAX/SITMIN)**(1./REAL(NKD-1)) -! + ! + ! 1. Initialization ------------------------------------------------- * + ! 1.a Checks + ! + XFRLN = LOG(XFR) + ! + IF ( LAMMAX.LE.0. .OR. LAMMAX.GT.0.5 .OR. DELTHM.LT.0. ) GOTO 800 + ! + ! 1.b Set up relative depths + ! + ALLOCATE ( TSTORE(SNLNQ*4,1:NKD) ) + ! + DEPTH = 1. + SITMIN = SQRT ( KDMIN * TANH(KDMIN) ) + SITMAX = SQRT ( KDMAX * TANH(KDMAX) ) + XSIT = (SITMAX/SITMIN)**(1./REAL(NKD-1)) + ! #ifdef W3_T - WRITE (NDST,9010) NKD, KDMIN, KDMAX, XSIT + WRITE (NDST,9010) NKD, KDMIN, KDMAX, XSIT +#endif + ! + ! 2. Building quadruplet data base ---------------------------------- * + ! For quadruplet and interaction strength evaluation + ! + IFRMIN = 0 + IFRMAX = 0 + NTHMAX = 0 + ! + ! 2.a Loop over relative depths + ! + S0 = SITMIN * SQRT ( GRAV / DEPTH ) / XSIT + ! + DO IKD=1, NKD + ! + S0 = S0 * XSIT + CALL WAVNU2 ( S0, DEPTH, WN0, CG0, 1.E-6, 25, IERR) + ! + ! 2.b Loop over representative quadruplets + ! + NQA = 0 + NQD = 0 + NQS = 0 + ! + DO IQ=1, SNLNQ + ! +#ifdef W3_T1 + WRITE (NDST,9020) IKD, IQ, WN0*DEPTH, S0*TPIINV, DEPTH +#endif + ! + OFF12 = SNLM(IQ) + OFF34 = SNLL(IQ) + TH12 = SNLT(IQ) * DERA + IF ( SNLCD(IQ) .GT. 0. ) NQD = NQD + 1 + IF ( SNLCS(IQ) .GT. 0. ) NQS = NQS + 1 + ! + IF ( TH12 .LT. 0. ) THEN + IF ( OFF12.LT.0. .OR. OFF12.GT.0.5 .OR. & + OFF34.LT.0. .OR. OFF34.GT.0.5 ) GOTO 801 + ELSE + IF ( SNLT(IQ).GT.DELTHM .OR. OFF12.LT.0. .OR. & + OFF12.GE.1. & + .OR. OFF34.LT.MINLAM(OFF12,SNLT(IQ)) .OR. & + OFF34.GT.MAXLAM(OFF12,SNLT(IQ)) ) GOTO 802 + END IF + ! +#ifdef W3_T1 + WRITE (NDST,9021) SNLT(IQ), OFF12, OFF34, & + SNLCD(IQ), SNLCS(IQ) +#endif + ! + ! 2.c Offset angles + ! + S1 = S0 * ( 1. + OFF12 ) + CALL WAVNU2 ( S1, DEPTH, WN1, CG1, 1.E-6, 25, IERR) + S2 = S0 * ( 1. - OFF12 ) + CALL WAVNU2 ( S2, DEPTH, WN2, CG2, 1.E-6, 25, IERR) + S3 = S0 * ( 1. + OFF34 ) + CALL WAVNU2 ( S3, DEPTH, WN3, CG3, 1.E-6, 25, IERR) + S4 = S0 * ( 1. - OFF34 ) + CALL WAVNU2 ( S4, DEPTH, WN4, CG4, 1.E-6, 25, IERR) + ! + AUXFR(1) = S1 / S0 + AUXFR(2) = S2 / S0 + AUXFR(3) = S3 / S0 + AUXFR(4) = S4 / S0 + ! + IF ( TH12 .LT. 0. ) THEN + BB = 2. * WN0 + ELSE + BB = WN1**2 + WN2**2 + 2.*WN1*WN2*COS(TH12) + BB = SQRT ( MAX ( BB , 0. ) ) + END IF + ! + IF ( TH12.LT.0. .AND. ABS(OFF12).LE.1.E-4 ) THEN + DELTH(1) = 0. + DELTH(2) = 0. + ELSE + CC = WN1 + AA = WN2 + AUX1 = (CC**2+BB**2-AA**2) / (2.*BB*CC) + AUX2 = (AA**2+BB**2-CC**2) / (2.*BB*AA) + DELTH(1) = - ACOS( MAX ( 0. , MIN ( 1. , AUX1 ) ) ) + DELTH(2) = ACOS( MAX ( 0. , MIN ( 1. , AUX2 ) ) ) + END IF + CC = WN3 + AA = WN4 + AUX1 = (CC**2+BB**2-AA**2) / (2.*BB*CC) + AUX2 = (AA**2+BB**2-CC**2) / (2.*BB*AA) + DELTH(3) = - ACOS( MAX ( 0. , MIN ( 1. , AUX1 ) ) ) + DELTH(4) = ACOS( MAX ( 0. , MIN ( 1. , AUX2 ) ) ) + ! +#ifdef W3_T1 + WRITE (NDST,9022) DELTH(:) * RADE +#endif + ! + ! 2.d Frequency indices + ! + DO J=1, 4 + JFR (J) = INT( LOG(AUXFR(J)) / XFRLN ) + JFR1(J) = JFR(J) + 1 * SIGN(1.,AUXFR(J)-1.) + WFR (J) = (XFR**JFR1(J)-AUXFR(J))/(XFR**JFR1(J)-XFR**JFR(J)) + WFR1(J) = 1. - WFR(J) + END DO + ! + IFRMIN = MIN ( IFRMIN , MINVAL(JFR1) ) + IFRMAX = MAX ( IFRMAX , MAXVAL(JFR1) ) + ! +#ifdef W3_T1 + WRITE (NDST,9023) 1, JFR(1), JFR1(1), WFR(1), WFR1(1) + DO, J=2, 4 + WRITE (NDST,9024) J, JFR(J), JFR1(J), WFR(J), WFR1(J) + END DO +#endif + ! + ! 2.e Directional indices + ! + DO J=1, 4 + AUX1 = DELTH(J) / DTH + JTH (J) = INT(AUX1) + JTH1(J) = JTH(J) + 1 * SIGN(1.,DELTH(J)) + WTH1(J) = ABS(AUX1) - REAL(ABS(JTH(J))) + WTH (J) = 1. - WTH1(J) + END DO + ! + NTHMAX = MAX ( NTHMAX , MAXVAL(ABS(JTH1)) ) + ! +#ifdef W3_T1 + WRITE (NDST,9025) 1, JTH(1), JTH1(1), WTH(1), WTH1(1) + DO, J=2, 4 + WRITE (NDST,9024) J, JTH(J), JTH1(J), WTH(J), WTH1(J) + END DO #endif -! -! 2. Building quadruplet data base ---------------------------------- * -! For quadruplet and interaction strength evaluation -! - IFRMIN = 0 - IFRMAX = 0 - NTHMAX = 0 -! -! 2.a Loop over relative depths -! - S0 = SITMIN * SQRT ( GRAV / DEPTH ) / XSIT -! - DO IKD=1, NKD -! - S0 = S0 * XSIT - CALL WAVNU2 ( S0, DEPTH, WN0, CG0, 1.E-6, 25, IERR) -! -! 2.b Loop over representative quadruplets -! - NQA = 0 - NQD = 0 - NQS = 0 -! - DO IQ=1, SNLNQ -! + ! + ! 2.f Temp storage of data + ! + IF ( SNLM(IQ).EQ.0. .AND. SNLT(IQ).LT.0. ) THEN + JJ = 2 + ELSE + JJ = 4 + END IF + ! + DO J=1, JJ + SELECT CASE (J) + CASE (2) + JTH (3) = -JTH (3) + JTH (4) = -JTH (4) + JTH1(3) = -JTH1(3) + JTH1(4) = -JTH1(4) + CASE (3) + JTH = -JTH + JTH1 = -JTH1 + CASE (4) + JTH (3) = -JTH (3) + JTH (4) = -JTH (4) + JTH1(3) = -JTH1(3) + JTH1(4) = -JTH1(4) + CASE DEFAULT + END SELECT + ! + NQA = NQA + 1 + TSTORE(NQA,IKD)%OFR = JFR + TSTORE(NQA,IKD)%OFR1 = JFR1 + TSTORE(NQA,IKD)%HFR = WFR + TSTORE(NQA,IKD)%HFR1 = WFR1 + TSTORE(NQA,IKD)%OTH = JTH + TSTORE(NQA,IKD)%OTH1 = JTH1 + TSTORE(NQA,IKD)%HTH = WTH + TSTORE(NQA,IKD)%HTH1 = WTH1 + IF ( JJ .EQ. 2 ) THEN + TSTORE(NQA,IKD)%CQD = SNLCD(IQ) * 2. + TSTORE(NQA,IKD)%CQS = SNLCS(IQ) * 2. + ELSE + TSTORE(NQA,IKD)%CQD = SNLCD(IQ) + TSTORE(NQA,IKD)%CQS = SNLCS(IQ) + END IF + AUXF = ( WN0 * S0 ) / CG0 + TSTORE(NQA,IKD)%F1 = AUXF * CG1 / ( WN1 * S1 ) + TSTORE(NQA,IKD)%F2 = AUXF * CG2 / ( WN2 * S2 ) + TSTORE(NQA,IKD)%F3 = AUXF * CG3 / ( WN3 * S3 ) + TSTORE(NQA,IKD)%F4 = AUXF * CG4 / ( WN4 * S4 ) + ! + END DO + ! + ! ... End loop 2.b + ! + END DO + ! + ! ... End loop 2.a + ! + END DO + ! #ifdef W3_T1 - WRITE (NDST,9020) IKD, IQ, WN0*DEPTH, S0*TPIINV, DEPTH + WRITE (NDST,*) +#endif +#ifdef W3_T + WRITE (NDST,9026) NQA, SNLNQ*4, NQD, NQS +#endif + ! + ! 2.g Expanded spectral range + ! + NTHMAX = NTHMAX + 1 + ! + NFRMIN = 1 + IFRMIN + NFRMAX = NFR + IFRMAX - IFRMIN + NFRCUT = NFR - IFRMIN + NTHEXP = NTH + 2*NTHMAX + ! + NSPMIN = 1 + (NFRMIN-1)*NTHEXP - NTHMAX + NSPMAX = NFRMAX * NTHEXP - NTHMAX + NSPMX2 = NFRCUT * NTHEXP - NTHMAX + ! +#ifdef W3_T + WRITE (NDST,9027) NFR, NFRMIN, NFRMAX, NFRCUT, NTH, & + 1-NTHMAX, NTH+NTHMAX, NTHEXP +#endif + ! + ALLOCATE ( MPARS(IGRID)%SNLPS%FRQ(NFRMAX), & + MPARS(IGRID)%SNLPS%XSI(NFRMAX) ) + FRQ => MPARS(IGRID)%SNLPS%FRQ + XSI => MPARS(IGRID)%SNLPS%XSI + ! + XSI(1:NFR) = SIG(1:NFR) + DO IFR=NFR+1, NFRMAX + XSI(IFR) = XSI(IFR-1) * XFR + END DO + FRQ = XSI * TPIINV + ! + ! 2.h Final storage + ! + ALLOCATE ( MPARS(IGRID)%SNLPS%QST1(16,NQA,NKD), & + MPARS(IGRID)%SNLPS%QST3(6,NQA,NKD), & + MPARS(IGRID)%SNLPS%QST2(16,NQA,NKD) ) + QST1 => MPARS(IGRID)%SNLPS%QST1 + QST2 => MPARS(IGRID)%SNLPS%QST2 + QST3 => MPARS(IGRID)%SNLPS%QST3 + ! + ! 2.h.1 Basic data + ! + DO IKD=1, NKD + DO IQA=1, NQA + ! + DO J=1, 4 + ! + QST1((J-1)*4+1,IQA,IKD) = TSTORE(IQA,IKD)%OTH (J) + & + TSTORE(IQA,IKD)%OFR (J) * NTHEXP + QST1((J-1)*4+2,IQA,IKD) = TSTORE(IQA,IKD)%OTH1(J) + & + TSTORE(IQA,IKD)%OFR (J) * NTHEXP + QST1((J-1)*4+3,IQA,IKD) = TSTORE(IQA,IKD)%OTH (J) + & + TSTORE(IQA,IKD)%OFR1(J) * NTHEXP + QST1((J-1)*4+4,IQA,IKD) = TSTORE(IQA,IKD)%OTH1(J) + & + TSTORE(IQA,IKD)%OFR1(J) * NTHEXP + ! + QST2((J-1)*4+1,IQA,IKD) = TSTORE(IQA,IKD)%HFR (J) * & + TSTORE(IQA,IKD)%HTH (J) + QST2((J-1)*4+2,IQA,IKD) = TSTORE(IQA,IKD)%HFR (J) * & + TSTORE(IQA,IKD)%HTH1(J) + QST2((J-1)*4+3,IQA,IKD) = TSTORE(IQA,IKD)%HFR1(J) * & + TSTORE(IQA,IKD)%HTH (J) + QST2((J-1)*4+4,IQA,IKD) = TSTORE(IQA,IKD)%HFR1(J) * & + TSTORE(IQA,IKD)%HTH1(J) + ! + END DO + ! + QST3(1,IQA,IKD) = TSTORE(IQA,IKD)%F1 + QST3(2,IQA,IKD) = TSTORE(IQA,IKD)%F2 + QST3(3,IQA,IKD) = TSTORE(IQA,IKD)%F3 + QST3(4,IQA,IKD) = TSTORE(IQA,IKD)%F4 + QST3(5,IQA,IKD) = TSTORE(IQA,IKD)%CQD + QST3(6,IQA,IKD) = TSTORE(IQA,IKD)%CQS + ! + END DO + END DO + ! + IF ( NQD .GT. 0 ) QST3(5,:,:) = QST3(5,:,:) / REAL(NQD) + IF ( NQS .GT. 0 ) QST3(6,:,:) = QST3(6,:,:) / REAL(NQS) + ! + DEALLOCATE ( TSTORE ) + ! + ! 3. Building quadruplet data base ---------------------------------- * + ! For constructing interactions and diagonal from contributions + ! + NTHMX2 = 0 + ALLOCATE ( MPARS(IGRID)%SNLPS%QST4(16,NQA,NKD), & + MPARS(IGRID)%SNLPS%QST5(16,NQA,NKD), & + MPARS(IGRID)%SNLPS%QST6(16,NQA,NKD) ) + QST4 => MPARS(IGRID)%SNLPS%QST4 + QST5 => MPARS(IGRID)%SNLPS%QST5 + QST6 => MPARS(IGRID)%SNLPS%QST6 + ALLOCATE ( AST1(16,NQA,NKD), AST2(16,NQA,NKD) ) + ! + ! 3.a Loop over relative depths + ! + S0 = SITMIN * SQRT ( GRAV / DEPTH ) / XSIT + ! + DO IKD=1, NKD + ! + S0 = S0 * XSIT + CALL WAVNU2 ( S0, DEPTH, WN0, CG0, 1.E-6, 25, IERR) + ! + ! 3.b Loop over representative quadruplets + ! + NQA = 0 + ! + DO IQ=1, SNLNQ + ! +#ifdef W3_T2 + WRITE (NDST,9030) IKD, IQ, WN0*DEPTH, S0*TPIINV, DEPTH #endif -! - OFF12 = SNLM(IQ) - OFF34 = SNLL(IQ) - TH12 = SNLT(IQ) * DERA - IF ( SNLCD(IQ) .GT. 0. ) NQD = NQD + 1 - IF ( SNLCS(IQ) .GT. 0. ) NQS = NQS + 1 -! - IF ( TH12 .LT. 0. ) THEN - IF ( OFF12.LT.0. .OR. OFF12.GT.0.5 .OR. & - OFF34.LT.0. .OR. OFF34.GT.0.5 ) GOTO 801 + ! + OFF12 = SNLM(IQ) + OFF34 = SNLL(IQ) + TH12 = SNLT(IQ) * DERA + ! +#ifdef W3_T2 + WRITE (NDST,9031) SNLT(IQ), OFF12, OFF34 +#endif + ! + ! 3.c Frequency indices + ! + AUXFR(1) = ( 1. + OFF12 ) + AUXFR(2) = ( 1. - OFF12 ) + AUXFR(3) = ( 1. + OFF34 ) + AUXFR(4) = ( 1. - OFF34 ) + ! + DO J=1, 4 + JFR (J) = INT( LOG(AUXFR(J)) / XFRLN ) + JFR1(J) = JFR(J) + 1 * SIGN(1.,AUXFR(J)-1.) + WFR (J) = (XFR**JFR1(J)-AUXFR(J))/(XFR**JFR1(J)-XFR**JFR(J)) + WFR1(J) = 1. - WFR(J) + END DO + ! +#ifdef W3_T2 + WRITE (NDST,9032) 1, JFR(1), JFR1(1), WFR(1), WFR1(1) + DO, J=2, 4 + WRITE (NDST,9033) J, JFR(J), JFR1(J), WFR(J), WFR1(J) + END DO +#endif + ! + ! 3.d Loop over quadruplet components + ! + DO JIQ=1, 4 + ! + IF ( JIQ .LE. 2 ) THEN + WF = -1. + ELSE + WF = 1. + END IF + ! + ! 3.e Loop over frequency offsets, get directional offsets + ! + DO JOF=1, 2 + ! + IF ( JOF .EQ. 1 ) THEN + IFR = -JFR(JIQ) + WFROFF = WFR(JIQ) ELSE - IF ( SNLT(IQ).GT.DELTHM .OR. OFF12.LT.0. .OR. & - OFF12.GE.1. & - .OR. OFF34.LT.MINLAM(OFF12,SNLT(IQ)) .OR. & - OFF34.GT.MAXLAM(OFF12,SNLT(IQ)) ) GOTO 802 + IFR = -JFR1(JIQ) + WFROFF = WFR1(JIQ) END IF -! -#ifdef W3_T1 - WRITE (NDST,9021) SNLT(IQ), OFF12, OFF34, & - SNLCD(IQ), SNLCS(IQ) + ! + SIOFF = S0 * XFR**IFR + CALL WAVNU2 ( SIOFF, DEPTH, WN0, CG0, 1.E-6, 25, IERR) + S1 = SIOFF * ( 1. + OFF12 ) + CALL WAVNU2 ( S1, DEPTH, WN1, CG1, 1.E-6, 25, IERR) + S2 = SIOFF * ( 1. - OFF12 ) + CALL WAVNU2 ( S2, DEPTH, WN2, CG2, 1.E-6, 25, IERR) + S3 = SIOFF * ( 1. + OFF34 ) + CALL WAVNU2 ( S3, DEPTH, WN3, CG3, 1.E-6, 25, IERR) + S4 = SIOFF * ( 1. - OFF34 ) + CALL WAVNU2 ( S4, DEPTH, WN4, CG4, 1.E-6, 25, IERR) + ! +#ifdef W3_T2 + WRITE (NDST,9034) JIQ, JOF, IFR, WFROFF, SIOFF/S0 #endif -! -! 2.c Offset angles -! - S1 = S0 * ( 1. + OFF12 ) - CALL WAVNU2 ( S1, DEPTH, WN1, CG1, 1.E-6, 25, IERR) - S2 = S0 * ( 1. - OFF12 ) - CALL WAVNU2 ( S2, DEPTH, WN2, CG2, 1.E-6, 25, IERR) - S3 = S0 * ( 1. + OFF34 ) - CALL WAVNU2 ( S3, DEPTH, WN3, CG3, 1.E-6, 25, IERR) - S4 = S0 * ( 1. - OFF34 ) - CALL WAVNU2 ( S4, DEPTH, WN4, CG4, 1.E-6, 25, IERR) -! - AUXFR(1) = S1 / S0 - AUXFR(2) = S2 / S0 - AUXFR(3) = S3 / S0 - AUXFR(4) = S4 / S0 -! - IF ( TH12 .LT. 0. ) THEN + ! + IF ( TH12 .LT. 0. ) THEN BB = 2. * WN0 ELSE BB = WN1**2 + WN2**2 + 2.*WN1*WN2*COS(TH12) BB = SQRT ( MAX ( BB , 0. ) ) END IF -! - IF ( TH12.LT.0. .AND. ABS(OFF12).LE.1.E-4 ) THEN + ! + IF ( TH12.LT.0. .AND. ABS(OFF12).LE.1.E-4 ) THEN DELTH(1) = 0. DELTH(2) = 0. ELSE @@ -923,65 +1232,41 @@ SUBROUTINE INSNL3 DELTH(1) = - ACOS( MAX ( 0. , MIN ( 1. , AUX1 ) ) ) DELTH(2) = ACOS( MAX ( 0. , MIN ( 1. , AUX2 ) ) ) END IF - CC = WN3 - AA = WN4 - AUX1 = (CC**2+BB**2-AA**2) / (2.*BB*CC) - AUX2 = (AA**2+BB**2-CC**2) / (2.*BB*AA) - DELTH(3) = - ACOS( MAX ( 0. , MIN ( 1. , AUX1 ) ) ) - DELTH(4) = ACOS( MAX ( 0. , MIN ( 1. , AUX2 ) ) ) -! -#ifdef W3_T1 - WRITE (NDST,9022) DELTH(:) * RADE -#endif -! -! 2.d Frequency indices -! - DO J=1, 4 - JFR (J) = INT( LOG(AUXFR(J)) / XFRLN ) - JFR1(J) = JFR(J) + 1 * SIGN(1.,AUXFR(J)-1.) - WFR (J) = (XFR**JFR1(J)-AUXFR(J))/(XFR**JFR1(J)-XFR**JFR(J)) - WFR1(J) = 1. - WFR(J) - END DO -! - IFRMIN = MIN ( IFRMIN , MINVAL(JFR1) ) - IFRMAX = MAX ( IFRMAX , MAXVAL(JFR1) ) -! -#ifdef W3_T1 - WRITE (NDST,9023) 1, JFR(1), JFR1(1), WFR(1), WFR1(1) - DO, J=2, 4 - WRITE (NDST,9024) J, JFR(J), JFR1(J), WFR(J), WFR1(J) - END DO + CC = WN3 + AA = WN4 + AUX1 = (CC**2+BB**2-AA**2) / (2.*BB*CC) + AUX2 = (AA**2+BB**2-CC**2) / (2.*BB*AA) + DELTH(3) = - ACOS( MAX ( 0. , MIN ( 1. , AUX1 ) ) ) + DELTH(4) = ACOS( MAX ( 0. , MIN ( 1. , AUX2 ) ) ) + ! +#ifdef W3_T2 + WRITE (NDST,9035) DELTH(:) * RADE #endif -! -! 2.e Directional indices -! - DO J=1, 4 - AUX1 = DELTH(J) / DTH - JTH (J) = INT(AUX1) - JTH1(J) = JTH(J) + 1 * SIGN(1.,DELTH(J)) - WTH1(J) = ABS(AUX1) - REAL(ABS(JTH(J))) - WTH (J) = 1. - WTH1(J) - END DO -! - NTHMAX = MAX ( NTHMAX , MAXVAL(ABS(JTH1)) ) -! -#ifdef W3_T1 - WRITE (NDST,9025) 1, JTH(1), JTH1(1), WTH(1), WTH1(1) - DO, J=2, 4 - WRITE (NDST,9024) J, JTH(J), JTH1(J), WTH(J), WTH1(J) - END DO + ! + AUX1 = DELTH(JIQ) / DTH + JTH (JIQ) = INT(AUX1) + JTH1(JIQ) = JTH(JIQ) + 1 * SIGN(1.,DELTH(JIQ)) + WTH1(JIQ) = ABS(AUX1) - REAL(ABS(JTH(JIQ))) + WTH (JIQ) = 1. - WTH1(JIQ) + ! + NTHMX2 = MAX ( NTHMX2 , ABS(JTH1(JIQ)) ) + ! +#ifdef W3_T2 + WRITE (NDST,9036) JIQ, JTH(JIQ), JTH1(JIQ), & + WTH(JIQ), WTH1(JIQ) #endif -! -! 2.f Temp storage of data -! - IF ( SNLM(IQ).EQ.0. .AND. SNLT(IQ).LT.0. ) THEN + ! + ! 3.f Loop over quadruplet realizations + ! + IF ( SNLM(IQ).EQ.0. .AND. SNLT(IQ).LT.0. ) THEN JJ = 2 ELSE JJ = 4 END IF -! - DO J=1, JJ - SELECT CASE (J) + ! + DO JQR=1, JJ + ! + SELECT CASE (JQR) CASE (2) JTH (3) = -JTH (3) JTH (4) = -JTH (4) @@ -996,547 +1281,262 @@ SUBROUTINE INSNL3 JTH1(3) = -JTH1(3) JTH1(4) = -JTH1(4) CASE DEFAULT - END SELECT -! - NQA = NQA + 1 - TSTORE(NQA,IKD)%OFR = JFR - TSTORE(NQA,IKD)%OFR1 = JFR1 - TSTORE(NQA,IKD)%HFR = WFR - TSTORE(NQA,IKD)%HFR1 = WFR1 - TSTORE(NQA,IKD)%OTH = JTH - TSTORE(NQA,IKD)%OTH1 = JTH1 - TSTORE(NQA,IKD)%HTH = WTH - TSTORE(NQA,IKD)%HTH1 = WTH1 - IF ( JJ .EQ. 2 ) THEN - TSTORE(NQA,IKD)%CQD = SNLCD(IQ) * 2. - TSTORE(NQA,IKD)%CQS = SNLCS(IQ) * 2. - ELSE - TSTORE(NQA,IKD)%CQD = SNLCD(IQ) - TSTORE(NQA,IKD)%CQS = SNLCS(IQ) - END IF - AUXF = ( WN0 * S0 ) / CG0 - TSTORE(NQA,IKD)%F1 = AUXF * CG1 / ( WN1 * S1 ) - TSTORE(NQA,IKD)%F2 = AUXF * CG2 / ( WN2 * S2 ) - TSTORE(NQA,IKD)%F3 = AUXF * CG3 / ( WN3 * S3 ) - TSTORE(NQA,IKD)%F4 = AUXF * CG4 / ( WN4 * S4 ) -! - END DO -! -! ... End loop 2.b -! - END DO -! -! ... End loop 2.a -! - END DO -! -#ifdef W3_T1 - WRITE (NDST,*) -#endif -#ifdef W3_T - WRITE (NDST,9026) NQA, SNLNQ*4, NQD, NQS -#endif -! -! 2.g Expanded spectral range -! - NTHMAX = NTHMAX + 1 -! - NFRMIN = 1 + IFRMIN - NFRMAX = NFR + IFRMAX - IFRMIN - NFRCUT = NFR - IFRMIN - NTHEXP = NTH + 2*NTHMAX -! - NSPMIN = 1 + (NFRMIN-1)*NTHEXP - NTHMAX - NSPMAX = NFRMAX * NTHEXP - NTHMAX - NSPMX2 = NFRCUT * NTHEXP - NTHMAX -! -#ifdef W3_T - WRITE (NDST,9027) NFR, NFRMIN, NFRMAX, NFRCUT, NTH, & - 1-NTHMAX, NTH+NTHMAX, NTHEXP -#endif -! - ALLOCATE ( MPARS(IGRID)%SNLPS%FRQ(NFRMAX), & - MPARS(IGRID)%SNLPS%XSI(NFRMAX) ) - FRQ => MPARS(IGRID)%SNLPS%FRQ - XSI => MPARS(IGRID)%SNLPS%XSI -! - XSI(1:NFR) = SIG(1:NFR) - DO IFR=NFR+1, NFRMAX - XSI(IFR) = XSI(IFR-1) * XFR - END DO - FRQ = XSI * TPIINV -! -! 2.h Final storage -! - ALLOCATE ( MPARS(IGRID)%SNLPS%QST1(16,NQA,NKD), & - MPARS(IGRID)%SNLPS%QST3(6,NQA,NKD), & - MPARS(IGRID)%SNLPS%QST2(16,NQA,NKD) ) - QST1 => MPARS(IGRID)%SNLPS%QST1 - QST2 => MPARS(IGRID)%SNLPS%QST2 - QST3 => MPARS(IGRID)%SNLPS%QST3 -! -! 2.h.1 Basic data -! - DO IKD=1, NKD - DO IQA=1, NQA -! - DO J=1, 4 -! - QST1((J-1)*4+1,IQA,IKD) = TSTORE(IQA,IKD)%OTH (J) + & - TSTORE(IQA,IKD)%OFR (J) * NTHEXP - QST1((J-1)*4+2,IQA,IKD) = TSTORE(IQA,IKD)%OTH1(J) + & - TSTORE(IQA,IKD)%OFR (J) * NTHEXP - QST1((J-1)*4+3,IQA,IKD) = TSTORE(IQA,IKD)%OTH (J) + & - TSTORE(IQA,IKD)%OFR1(J) * NTHEXP - QST1((J-1)*4+4,IQA,IKD) = TSTORE(IQA,IKD)%OTH1(J) + & - TSTORE(IQA,IKD)%OFR1(J) * NTHEXP -! - QST2((J-1)*4+1,IQA,IKD) = TSTORE(IQA,IKD)%HFR (J) * & - TSTORE(IQA,IKD)%HTH (J) - QST2((J-1)*4+2,IQA,IKD) = TSTORE(IQA,IKD)%HFR (J) * & - TSTORE(IQA,IKD)%HTH1(J) - QST2((J-1)*4+3,IQA,IKD) = TSTORE(IQA,IKD)%HFR1(J) * & - TSTORE(IQA,IKD)%HTH (J) - QST2((J-1)*4+4,IQA,IKD) = TSTORE(IQA,IKD)%HFR1(J) * & - TSTORE(IQA,IKD)%HTH1(J) -! + JTH = -JTH + JTH1 = -JTH1 + END SELECT + ! + IST = (JIQ-1)*4 + (JOF-1)*2 + 1 + AST1(IST,NQA+JQR,IKD) = IFR + AST2(IST,NQA+JQR,IKD) = JTH(JIQ) + QST5(IST,NQA+JQR,IKD) = WF * ( WFROFF * WTH(JIQ) ) + QST6(IST,NQA+JQR,IKD) = WF * ( WFROFF * WTH(JIQ) )**2 + IST = IST + 1 + AST1(IST,NQA+JQR,IKD) = IFR + AST2(IST,NQA+JQR,IKD) = JTH1(JIQ) + QST5(IST,NQA+JQR,IKD) = WF * ( WFROFF * WTH1(JIQ) ) + QST6(IST,NQA+JQR,IKD) = WF * ( WFROFF * WTH1(JIQ) )**2 + ! + ! ... End loop 3.f + ! END DO -! - QST3(1,IQA,IKD) = TSTORE(IQA,IKD)%F1 - QST3(2,IQA,IKD) = TSTORE(IQA,IKD)%F2 - QST3(3,IQA,IKD) = TSTORE(IQA,IKD)%F3 - QST3(4,IQA,IKD) = TSTORE(IQA,IKD)%F4 - QST3(5,IQA,IKD) = TSTORE(IQA,IKD)%CQD - QST3(6,IQA,IKD) = TSTORE(IQA,IKD)%CQS -! + ! + ! ... End loop 3.e + ! END DO + ! + ! ... End loop 3.d + ! END DO -! - IF ( NQD .GT. 0 ) QST3(5,:,:) = QST3(5,:,:) / REAL(NQD) - IF ( NQS .GT. 0 ) QST3(6,:,:) = QST3(6,:,:) / REAL(NQS) -! - DEALLOCATE ( TSTORE ) -! -! 3. Building quadruplet data base ---------------------------------- * -! For constructing interactions and diagonal from contributions -! - NTHMX2 = 0 - ALLOCATE ( MPARS(IGRID)%SNLPS%QST4(16,NQA,NKD), & - MPARS(IGRID)%SNLPS%QST5(16,NQA,NKD), & - MPARS(IGRID)%SNLPS%QST6(16,NQA,NKD) ) - QST4 => MPARS(IGRID)%SNLPS%QST4 - QST5 => MPARS(IGRID)%SNLPS%QST5 - QST6 => MPARS(IGRID)%SNLPS%QST6 - ALLOCATE ( AST1(16,NQA,NKD), AST2(16,NQA,NKD) ) -! -! 3.a Loop over relative depths -! - S0 = SITMIN * SQRT ( GRAV / DEPTH ) / XSIT -! - DO IKD=1, NKD -! - S0 = S0 * XSIT - CALL WAVNU2 ( S0, DEPTH, WN0, CG0, 1.E-6, 25, IERR) -! -! 3.b Loop over representative quadruplets -! - NQA = 0 -! - DO IQ=1, SNLNQ -! -#ifdef W3_T2 - WRITE (NDST,9030) IKD, IQ, WN0*DEPTH, S0*TPIINV, DEPTH -#endif -! - OFF12 = SNLM(IQ) - OFF34 = SNLL(IQ) - TH12 = SNLT(IQ) * DERA -! -#ifdef W3_T2 - WRITE (NDST,9031) SNLT(IQ), OFF12, OFF34 -#endif -! -! 3.c Frequency indices -! - AUXFR(1) = ( 1. + OFF12 ) - AUXFR(2) = ( 1. - OFF12 ) - AUXFR(3) = ( 1. + OFF34 ) - AUXFR(4) = ( 1. - OFF34 ) -! - DO J=1, 4 - JFR (J) = INT( LOG(AUXFR(J)) / XFRLN ) - JFR1(J) = JFR(J) + 1 * SIGN(1.,AUXFR(J)-1.) - WFR (J) = (XFR**JFR1(J)-AUXFR(J))/(XFR**JFR1(J)-XFR**JFR(J)) - WFR1(J) = 1. - WFR(J) - END DO -! -#ifdef W3_T2 - WRITE (NDST,9032) 1, JFR(1), JFR1(1), WFR(1), WFR1(1) - DO, J=2, 4 - WRITE (NDST,9033) J, JFR(J), JFR1(J), WFR(J), WFR1(J) - END DO -#endif -! -! 3.d Loop over quadruplet components -! - DO JIQ=1, 4 -! - IF ( JIQ .LE. 2 ) THEN - WF = -1. - ELSE - WF = 1. - END IF -! -! 3.e Loop over frequency offsets, get directional offsets -! - DO JOF=1, 2 -! - IF ( JOF .EQ. 1 ) THEN - IFR = -JFR(JIQ) - WFROFF = WFR(JIQ) - ELSE - IFR = -JFR1(JIQ) - WFROFF = WFR1(JIQ) - END IF -! - SIOFF = S0 * XFR**IFR - CALL WAVNU2 ( SIOFF, DEPTH, WN0, CG0, 1.E-6, 25, IERR) - S1 = SIOFF * ( 1. + OFF12 ) - CALL WAVNU2 ( S1, DEPTH, WN1, CG1, 1.E-6, 25, IERR) - S2 = SIOFF * ( 1. - OFF12 ) - CALL WAVNU2 ( S2, DEPTH, WN2, CG2, 1.E-6, 25, IERR) - S3 = SIOFF * ( 1. + OFF34 ) - CALL WAVNU2 ( S3, DEPTH, WN3, CG3, 1.E-6, 25, IERR) - S4 = SIOFF * ( 1. - OFF34 ) - CALL WAVNU2 ( S4, DEPTH, WN4, CG4, 1.E-6, 25, IERR) -! -#ifdef W3_T2 - WRITE (NDST,9034) JIQ, JOF, IFR, WFROFF, SIOFF/S0 -#endif -! - IF ( TH12 .LT. 0. ) THEN - BB = 2. * WN0 - ELSE - BB = WN1**2 + WN2**2 + 2.*WN1*WN2*COS(TH12) - BB = SQRT ( MAX ( BB , 0. ) ) - END IF -! - IF ( TH12.LT.0. .AND. ABS(OFF12).LE.1.E-4 ) THEN - DELTH(1) = 0. - DELTH(2) = 0. - ELSE - CC = WN1 - AA = WN2 - AUX1 = (CC**2+BB**2-AA**2) / (2.*BB*CC) - AUX2 = (AA**2+BB**2-CC**2) / (2.*BB*AA) - DELTH(1) = - ACOS( MAX ( 0. , MIN ( 1. , AUX1 ) ) ) - DELTH(2) = ACOS( MAX ( 0. , MIN ( 1. , AUX2 ) ) ) - END IF - CC = WN3 - AA = WN4 - AUX1 = (CC**2+BB**2-AA**2) / (2.*BB*CC) - AUX2 = (AA**2+BB**2-CC**2) / (2.*BB*AA) - DELTH(3) = - ACOS( MAX ( 0. , MIN ( 1. , AUX1 ) ) ) - DELTH(4) = ACOS( MAX ( 0. , MIN ( 1. , AUX2 ) ) ) -! -#ifdef W3_T2 - WRITE (NDST,9035) DELTH(:) * RADE -#endif -! - AUX1 = DELTH(JIQ) / DTH - JTH (JIQ) = INT(AUX1) - JTH1(JIQ) = JTH(JIQ) + 1 * SIGN(1.,DELTH(JIQ)) - WTH1(JIQ) = ABS(AUX1) - REAL(ABS(JTH(JIQ))) - WTH (JIQ) = 1. - WTH1(JIQ) -! - NTHMX2 = MAX ( NTHMX2 , ABS(JTH1(JIQ)) ) -! -#ifdef W3_T2 - WRITE (NDST,9036) JIQ, JTH(JIQ), JTH1(JIQ), & - WTH(JIQ), WTH1(JIQ) -#endif -! -! 3.f Loop over quadruplet realizations -! - IF ( SNLM(IQ).EQ.0. .AND. SNLT(IQ).LT.0. ) THEN - JJ = 2 - ELSE - JJ = 4 - END IF -! - DO JQR=1, JJ -! - SELECT CASE (JQR) - CASE (2) - JTH (3) = -JTH (3) - JTH (4) = -JTH (4) - JTH1(3) = -JTH1(3) - JTH1(4) = -JTH1(4) - CASE (3) - JTH = -JTH - JTH1 = -JTH1 - CASE (4) - JTH (3) = -JTH (3) - JTH (4) = -JTH (4) - JTH1(3) = -JTH1(3) - JTH1(4) = -JTH1(4) - CASE DEFAULT - JTH = -JTH - JTH1 = -JTH1 - END SELECT -! - IST = (JIQ-1)*4 + (JOF-1)*2 + 1 - AST1(IST,NQA+JQR,IKD) = IFR - AST2(IST,NQA+JQR,IKD) = JTH(JIQ) - QST5(IST,NQA+JQR,IKD) = WF * ( WFROFF * WTH(JIQ) ) - QST6(IST,NQA+JQR,IKD) = WF * ( WFROFF * WTH(JIQ) )**2 - IST = IST + 1 - AST1(IST,NQA+JQR,IKD) = IFR - AST2(IST,NQA+JQR,IKD) = JTH1(JIQ) - QST5(IST,NQA+JQR,IKD) = WF * ( WFROFF * WTH1(JIQ) ) - QST6(IST,NQA+JQR,IKD) = WF * ( WFROFF * WTH1(JIQ) )**2 -! -! ... End loop 3.f -! - END DO -! -! ... End loop 3.e -! - END DO -! -! ... End loop 3.d -! - END DO -! + ! #ifdef W3_T3 - DO JQR=1, JJ - WRITE (NDST,9037) IKD, NQA+JQR - DO IST=1, 16 - WRITE (NDST,9038) IST, AST1(IST,NQA+JQR,IKD), & - AST2(IST,NQA+JQR,IKD), & - QST5(IST,NQA+JQR,IKD), & - QST6(IST,NQA+JQR,IKD) - END DO - END DO -#endif -! -! ... End loop 3.b -! - NQA = NQA + JJ -! + DO JQR=1, JJ + WRITE (NDST,9037) IKD, NQA+JQR + DO IST=1, 16 + WRITE (NDST,9038) IST, AST1(IST,NQA+JQR,IKD), & + AST2(IST,NQA+JQR,IKD), & + QST5(IST,NQA+JQR,IKD), & + QST6(IST,NQA+JQR,IKD) END DO -! -! ... End loop 3.a -! END DO -! -! 3.g Finalize storage -! - QST4 = AST1*NTHEXP + AST2 -! - IF ( NTHMAX .LT. NTHMX2 ) GOTO 810 - IF ( NQA .NE. SIZE(AST1(1,:,1)) ) GOTO 811 -! - DEALLOCATE ( AST1, AST2 ) -! - RETURN -! -! Error escape locations -! - 800 CONTINUE - WRITE (NDSE,1000) LAMMAX, DELTHM - CALL EXTCDE ( 1000 ) -! - 801 CONTINUE - WRITE (NDSE,1001) OFF12, OFF34 - CALL EXTCDE ( 1001 ) -! - 802 CONTINUE - WRITE (NDSE,1002) OFF12, OFF34, SNLT(IQ), & - MINLAM(OFF12,SNLT(IQ)), MAXLAM(OFF12,SNLT(IQ)) - CALL EXTCDE ( 1002 ) -! - 810 CONTINUE - WRITE (NDSE,1010) NTHMAX, NTHMX2 - CALL EXTCDE ( 1010 ) -! - 811 CONTINUE - WRITE (NDSE,1011) NQA, SIZE(AST1(1,:,1)) - CALL EXTCDE ( 1011 ) -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & - ' PARAMETER OUT OF RANGE '/ & - ' LAMMAX, DELTHM :', 2E12.4/) - 1001 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & - ' PARAMETER OUT OF RANGE '/ & - ' MU, LAMBDA :', 2E12.4/) - 1002 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & - ' PARAMETER OUT OF RANGE '/ & - ' MU, LAMBDA, TH12 :',3E12.4/ & - ' LAMBDA RANGE :',2E12.4) - 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & - ' NTHMAX LESS THAN NTHMX2 :', 2I8/) - 1011 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & - ' NQA INCONSISTENT :', 2I8/) -! +#endif + ! + ! ... End loop 3.b + ! + NQA = NQA + JJ + ! + END DO + ! + ! ... End loop 3.a + ! + END DO + ! + ! 3.g Finalize storage + ! + QST4 = AST1*NTHEXP + AST2 + ! + IF ( NTHMAX .LT. NTHMX2 ) GOTO 810 + IF ( NQA .NE. SIZE(AST1(1,:,1)) ) GOTO 811 + ! + DEALLOCATE ( AST1, AST2 ) + ! + RETURN + ! + ! Error escape locations + ! +800 CONTINUE + WRITE (NDSE,1000) LAMMAX, DELTHM + CALL EXTCDE ( 1000 ) + ! +801 CONTINUE + WRITE (NDSE,1001) OFF12, OFF34 + CALL EXTCDE ( 1001 ) + ! +802 CONTINUE + WRITE (NDSE,1002) OFF12, OFF34, SNLT(IQ), & + MINLAM(OFF12,SNLT(IQ)), MAXLAM(OFF12,SNLT(IQ)) + CALL EXTCDE ( 1002 ) + ! +810 CONTINUE + WRITE (NDSE,1010) NTHMAX, NTHMX2 + CALL EXTCDE ( 1010 ) + ! +811 CONTINUE + WRITE (NDSE,1011) NQA, SIZE(AST1(1,:,1)) + CALL EXTCDE ( 1011 ) + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & + ' PARAMETER OUT OF RANGE '/ & + ' LAMMAX, DELTHM :', 2E12.4/) +1001 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & + ' PARAMETER OUT OF RANGE '/ & + ' MU, LAMBDA :', 2E12.4/) +1002 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & + ' PARAMETER OUT OF RANGE '/ & + ' MU, LAMBDA, TH12 :',3E12.4/ & + ' LAMBDA RANGE :',2E12.4) +1010 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & + ' NTHMAX LESS THAN NTHMX2 :', 2I8/) +1011 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & + ' NQA INCONSISTENT :', 2I8/) + ! #ifdef W3_T - 9010 FORMAT (/' TEST INSNL3: NKD, KDMIN/MAX/X : ',I8,3F10.4) +9010 FORMAT (/' TEST INSNL3: NKD, KDMIN/MAX/X : ',I8,3F10.4) #endif -! + ! #ifdef W3_T1 - 9020 FORMAT (/' TEST INSNL3: IKD, IQ, KD, F, D: ',2I8,2F10.4,F10.2) - 9021 FORMAT (/' TEST INSNL3: TH12 : ',3X,F8.2/ & - ' OFF12, OFF34 : ',3X,2F8.2/ & - ' CD, CS : ',3X,2E10.2) - 9022 FORMAT ( ' ANGLES (DEGR) : ',1X,4F8.2) - 9023 FORMAT ( ' FREQUENCY IND. : ',1X,3I4,2F6.2) - 9024 FORMAT ( ' : ',1X,3I4,2F6.2) - 9025 FORMAT ( ' DIRECTIONAL IND. : ',1X,3I4,2F6.2) +9020 FORMAT (/' TEST INSNL3: IKD, IQ, KD, F, D: ',2I8,2F10.4,F10.2) +9021 FORMAT (/' TEST INSNL3: TH12 : ',3X,F8.2/ & + ' OFF12, OFF34 : ',3X,2F8.2/ & + ' CD, CS : ',3X,2E10.2) +9022 FORMAT ( ' ANGLES (DEGR) : ',1X,4F8.2) +9023 FORMAT ( ' FREQUENCY IND. : ',1X,3I4,2F6.2) +9024 FORMAT ( ' : ',1X,3I4,2F6.2) +9025 FORMAT ( ' DIRECTIONAL IND. : ',1X,3I4,2F6.2) #endif #ifdef W3_T - 9026 FORMAT ( ' TEST INSNL3: FILLING FIRST DATA TABLES :'/ & - ' NQA AND MAXIMUM : ',2I8/ & - ' NQD AND NQS : ',2I8) - 9027 FORMAT ( ' NFR, MIN/MAX/CUT : ',4I8/ & - ' NTH, MIN/MAX/EXP : ',4I8) +9026 FORMAT ( ' TEST INSNL3: FILLING FIRST DATA TABLES :'/ & + ' NQA AND MAXIMUM : ',2I8/ & + ' NQD AND NQS : ',2I8) +9027 FORMAT ( ' NFR, MIN/MAX/CUT : ',4I8/ & + ' NTH, MIN/MAX/EXP : ',4I8) #endif -! + ! #ifdef W3_T2 - 9030 FORMAT (/' TEST INSNL3: IKD, IQ, KD, F, D: ',2I8,2F10.4,F10.2) - 9031 FORMAT (/' TEST INSNL3: TH12 : ',3X,F8.2/ & - ' OFF12, OFF34 : ',3X,2F8.2) - 9032 FORMAT ( ' FREQUENCY IND. : ',1X,3I4,2F6.2) - 9033 FORMAT ( ' : ',1X,3I4,2F6.2) - 9034 FORMAT ( ' J,J,J, W, SIn : ',1X,3I4,2F6.2) - 9035 FORMAT ( ' ANGLES (DEGR) : ',3X,4F8.2) - 9036 FORMAT ( ' DIRECTIONAL IND. : ',1X,3I4,2F6.2) +9030 FORMAT (/' TEST INSNL3: IKD, IQ, KD, F, D: ',2I8,2F10.4,F10.2) +9031 FORMAT (/' TEST INSNL3: TH12 : ',3X,F8.2/ & + ' OFF12, OFF34 : ',3X,2F8.2) +9032 FORMAT ( ' FREQUENCY IND. : ',1X,3I4,2F6.2) +9033 FORMAT ( ' : ',1X,3I4,2F6.2) +9034 FORMAT ( ' J,J,J, W, SIn : ',1X,3I4,2F6.2) +9035 FORMAT ( ' ANGLES (DEGR) : ',3X,4F8.2) +9036 FORMAT ( ' DIRECTIONAL IND. : ',1X,3I4,2F6.2) #endif #ifdef W3_T3 - 9037 FORMAT (/' TEST INSNL3: STORAGE ARRAYS FOR IKD, IQA =',2I6) - 9038 FORMAT (23X,3I4,3F8.3) +9037 FORMAT (/' TEST INSNL3: STORAGE ARRAYS FOR IKD, IQA =',2I6) +9038 FORMAT (23X,3I4,3F8.3) #endif -!/ -!/ Embedded subroutines -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - REAL FUNCTION MINLAM ( MU, THETA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 28-Jan-2004 | -!/ +-----------------------------------+ -!/ -!/ 28-Jan-2009 : Origination. -!/ -! 1. Purpose : -! -! Calculate minimum allowed lambda for quadruplet configuration. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MU, THETA Real Quadruplet parameters, theta in degree. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ Embedded subroutines + !/ + CONTAINS + !/ ------------------------------------------------------------------- / + REAL FUNCTION MINLAM ( MU, THETA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 28-Jan-2004 | + !/ +-----------------------------------+ + !/ + !/ 28-Jan-2009 : Origination. + !/ + ! 1. Purpose : + ! + ! Calculate minimum allowed lambda for quadruplet configuration. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MU, THETA Real Quadruplet parameters, theta in degree. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / IMPLICIT NONE -!/ -!/ Parameter list -!/ + !/ + !/ Parameter list + !/ REAL, INTENT(IN) :: MU, THETA -!/ -!/ Local parameters -!/ + !/ + !/ Local parameters + !/ REAL :: MULOC, THETAR, BB, AUX -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ IF ( THETA .LT. 0. ) THEN - MINLAM = 0. - ELSE - MULOC = MAX ( 0. , MIN ( 1., MU ) ) - THETAR = THETA * ATAN(1.) / 45. - BB = (1.+MULOC)**4 + (1.-MULOC)**4 + & - 2. * (1.+MULOC)**2 * (1.-MULOC)**2 * COS(THETAR) - BB = SQRT ( MAX ( BB , 0. ) ) - AUX = MAX ( 0. , 0.5*BB-1. ) - MINLAM = SQRT ( AUX ) - END IF -! + MINLAM = 0. + ELSE + MULOC = MAX ( 0. , MIN ( 1., MU ) ) + THETAR = THETA * ATAN(1.) / 45. + BB = (1.+MULOC)**4 + (1.-MULOC)**4 + & + 2. * (1.+MULOC)**2 * (1.-MULOC)**2 * COS(THETAR) + BB = SQRT ( MAX ( BB , 0. ) ) + AUX = MAX ( 0. , 0.5*BB-1. ) + MINLAM = SQRT ( AUX ) + END IF + ! RETURN -!/ -!/ End of MINLAM ----------------------------------------------------- / -!/ - END FUNCTION MINLAM -!/ ------------------------------------------------------------------- / - REAL FUNCTION MAXLAM ( MU, THETA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 28-Jan-2004 | -!/ +-----------------------------------+ -!/ -!/ 28-Jan-2009 : Origination. -!/ -! 1. Purpose : -! -! Calculate minimum allowed lambda for quadruplet configuration. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MU, THETA Real Quadruplet parameters, theta in degree. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ End of MINLAM ----------------------------------------------------- / + !/ + END FUNCTION MINLAM + !/ ------------------------------------------------------------------- / + REAL FUNCTION MAXLAM ( MU, THETA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 28-Jan-2004 | + !/ +-----------------------------------+ + !/ + !/ 28-Jan-2009 : Origination. + !/ + ! 1. Purpose : + ! + ! Calculate minimum allowed lambda for quadruplet configuration. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MU, THETA Real Quadruplet parameters, theta in degree. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / IMPLICIT NONE -!/ -!/ Parameter list -!/ + !/ + !/ Parameter list + !/ REAL, INTENT(IN) :: MU, THETA -!/ -!/ Local parameters -!/ + !/ + !/ Local parameters + !/ REAL :: MULOC, THETAR, BB, AUX -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ IF ( THETA .LT. 0. ) THEN - MAXLAM = 0.5 - ELSE - MULOC = MAX ( 0. , MIN ( 1., MU ) ) - THETAR = THETA * ATAN(1.) / 45. - BB = (1.+MULOC)**4 + (1.-MULOC)**4 + & - 2. * (1.+MULOC)**2 * (1.-MULOC)**2 * COS(THETAR) - BB = SQRT ( MAX ( BB , 0. ) ) - MAXLAM = 0.25 * BB - END IF -! + MAXLAM = 0.5 + ELSE + MULOC = MAX ( 0. , MIN ( 1., MU ) ) + THETAR = THETA * ATAN(1.) / 45. + BB = (1.+MULOC)**4 + (1.-MULOC)**4 + & + 2. * (1.+MULOC)**2 * (1.-MULOC)**2 * COS(THETAR) + BB = SQRT ( MAX ( BB , 0. ) ) + MAXLAM = 0.25 * BB + END IF + ! RETURN -!/ -!/ End of MAXLAM ----------------------------------------------------- / -!/ - END FUNCTION MAXLAM -!/ -!/ End of INSNL3 ----------------------------------------------------- / -!/ - END SUBROUTINE INSNL3 -!/ -!/ End of module W3SNL3MD -------------------------------------------- / -!/ - END MODULE W3SNL3MD + !/ + !/ End of MAXLAM ----------------------------------------------------- / + !/ + END FUNCTION MAXLAM + !/ + !/ End of INSNL3 ----------------------------------------------------- / + !/ + END SUBROUTINE INSNL3 + !/ + !/ End of module W3SNL3MD -------------------------------------------- / + !/ +END MODULE W3SNL3MD diff --git a/model/src/w3snl4md.F90 b/model/src/w3snl4md.F90 index a19dca515..2c75b259c 100644 --- a/model/src/w3snl4md.F90 +++ b/model/src/w3snl4md.F90 @@ -1,2456 +1,2478 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / !/ - MODULE W3SNL4MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -!! -!! -----------------------------------------------------------------# -!! ! -!! Generic shallow-water Boltzmann integral (FBI or TSA) ! -!! ! -!! -----------------------------------------------------------------# -!! -!! -!! 1. Purpose : -!! -!! Interface module for TSA type nonlinear interactions. -!! Based on Resio and Perrie (2008) and Perrie and Resio (2009) -!! -!! 2. Variables and types : -!! -!! Name Type Scope Description -!! ------------------------------------------------------------------ -!! ------------------------------------------------------------------ -!! -!! 3. Subroutines and functions : -!! -!! Name Type Scope Description -!! ------------------------------------------------------------------ -!! INSNL4 Subr. W3SNL4MD Corresponding initialization routine. -!! ------ -!! W3SNL4 Subr. W3SNL4MD Main interface for TSA subroutines. -!! ------ Replaces main program "sboltz" in -!! "sbtsa-0-norm-Dec15-08.f" with -!! initialization done in subr. INSNL4 -!! gridsetr Subr. W3SNL4MD Setup geometric integration grid -!! shloxr Subr. W3SNL4MD General locus solution -!! shlocr Subr. W3SNL4MD Locus solving routine - must converges -!! cplshr Subr. W3SNL4MD Computes Boltzmann coupling coefficient -!! ------ -!!op2 -!! Bash; Sections starting & ending with !!op2 are related to subr. optsa2 -!! optsa2 Subr. W3SNL4MD Converts the 2D Energy Density (f,theta) -!! ------ to Polar Action Density (k,theta) Norm. (in k) -!! then splits it into large and small scale -!! --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - !!op2 -!! snlr_tsa Subr. W3SNL4MD Computes dN(k,theta)/dt for TSA -!! -------- due to wave-wave inter. (set itsa = 1) -!! snlr_fbi Subr. W3SNL4MD Computes dN(k,theta)/dt for FBI -!! -------- due to wave-wave inter. (set itsa = 0) -!! -!! wkfnc fnc. W3SNL4MD Compute wave number "k" for given -!! freq "f" (Hz) and water depth "d" (m) -!! or can use subr. WAVNU2 -!! cgfnc fnc. W3SNL4MD Compute group velocity "cg" for given -!! freq "f" (Hz), water depth "d" (m) -!! and phase speed "cvel" (m/s) -!! ------------------------------------------------------------------ -!! -!! 4. Subroutines and functions used : -!! -!! See subroutine documentation. -!! -!! 5. Remarks : -!! -!! 6. Switches : -!! -!! !/S Enable subroutine tracing. -!! !/T(n) Test output, see subroutines. -!! -!! 7. Source code : -!/ -!! --------------------------------------------------------------- & -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! - PUBLIC -!! -!! -!! ------------------------------------------------------------------ -!! -!! -!!-0 Set these important run parameters here and declare them as PUBLIC -!! AC itsa, ialt are set in mod_def and read here -!! integer, parameter :: itsa = 1 !* = 1 for "snlr_tsa" or TSA -!! **** !* = 0 for "snlr_fbi" or FBI -!! integer, parameter :: ialt = 2 !* = 2 do alternate in snlr's -!! **** !* = 1 don't alternate in snlr's - integer, parameter :: ismo = 1 !* = 1 do smooth in interp2 -!! **** !* = 0 don't smooth in interp2 -!! !* interp2 is called only if ialt=2 - integer, parameter :: npts = 30 !* # of points on the locus -!! **** !* can reduce npts for speed - integer, parameter :: ndep = 37 !* # of depths in look-up tables -!! **** !* can reduce ndep for speed -!! ------------------------------------------------------------------ -!! -!! -!!-1 Declare freq. related arrays & variables dim (nrng) and -!! angle related arrays & variables dim (nang) as PUBLIC - integer :: nrng, nzz, kzone, nb2fp - integer :: nang, na2p1 - integer :: np2p1 - real :: dfrq, f0 - real :: ainc, twopi - real, allocatable, dimension(:) :: frqa, oma - real, allocatable, dimension(:) :: angl, sinan, cosan - real, allocatable, dimension(:) :: dep_tbl -!! ------------------------------------------------------------------ -!! -!! -!!-2 Declare gridsetr 11 look-up tables arrays dim (npts,nang,nzz,ndep) -!! plus pha_tbl array dim=(nrng,ndep) as PUBLIC - integer, allocatable, dimension(:,:,:,:) :: kref2_tbl, kref4_tbl - integer, allocatable, dimension(:,:,:,:) :: jref2_tbl, jref4_tbl - real, allocatable, dimension(:,:,:,:) :: wtk2_tbl, wtk4_tbl - real, allocatable, dimension(:,:,:,:) :: wta2_tbl, wta4_tbl - real, allocatable, dimension(:,:,:,:) :: tfac2_tbl, tfac4_tbl - real, allocatable, dimension(:,:,:,:) :: grad_tbl - real, allocatable, dimension(:,:) :: pha_tbl -!! ------------------------------------------------------------------ -!! -!! -!!-3 Declare gridsetr 11 returned arrays dim (npts,nang,nzz) as PUBLIC - integer, allocatable, dimension(:,:,:) :: kref2, kref4 - integer, allocatable, dimension(:,:,:) :: jref2, jref4 - real, allocatable, dimension(:,:,:) :: wtk2, wtk4 - real, allocatable, dimension(:,:,:) :: wta2, wta4 - real, allocatable, dimension(:,:,:) :: tfac2, tfac4 - real, allocatable, dimension(:,:,:) :: grad -!! ------------------------------------------------------------------ -!! -!! -!!-4 Declare shloxr/shlocr 5 returned arrays dim (npts) as PUBLIC - real, allocatable, dimension(:) :: wk2x, wk2y - real, allocatable, dimension(:) :: wk4x, wk4y, ds -!! ------------------------------------------------------------------ -!! -!! -!!-5 Declare w3snl4/optsa2 2 shared arrays dim (nrng,nang) & (nrng) as PUBLIC -!! - ef2(nrng,nang) 'ww3' 2D Energy -!! - ef1(nrng) 'ww3' 1D Energy from ef2() - real, allocatable, dimension(:,:) :: ef2 - real, allocatable, dimension(:) :: ef1 -!! ------------------------------------------------------------------ -!! -!! -!!-6 Declare optsa2 2 returned arrays dim (nrng,nang) as PUBLIC -!! - dens1(nrng,nang) 'ww3' 2D Broad Scale Action -!! - dens2(nrng,nang) 'ww3' 2D Small Scale Action - real, allocatable, dimension(:,:) :: dens1, dens2 -!! ------------------------------------------------------------------ -!! -!! -!!-7 Declare snlr's 4 returned arrays dim (nrng,nang) as PUBLIC -!! tsa, diag used for -tsa -!! fbi, diag2 used for -fbi - real, allocatable, dimension(:,:) :: tsa, diag - real, allocatable, dimension(:,:) :: fbi, diag2 -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! - CONTAINS -!! -!! -!!============================================================================== -!! -!! ------------------------------------------------------------------ -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE INSNL4 -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! -!! it returns: 11 look-up tables arrays dim=(npts,nang,nzz,ndep) -!! kref2_tbl, kref4_tbl, jref2_tbl, jref4_tbl, -!! wtk2_tbl, wtk4_tbl, wta2_tbl, wta4_tbl, -!! tfac2_tbl, tfac4_tbl & grad_tbl -!! plus pha_tbl dim=(nrng,ndep) -!! and dep_tbl dim=(ndep) -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! 1. Purpose : -!! It reads look-up tables (generated by gridsetr) if file exists -!! otherwise it must generate the look-up tables file -!! -!! 2. Method : -!! See subr gridsetr and subr W3SNL4 (or subr. W3IOGR) -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! nrng int. Public I # of freq. or rings -!! nang int. Public I # of angles -!! npts int. Public I # of points on the locus -!! ndep int. Public I # of depths in look-up tables -!! dfrq Real Public I frequency multiplier for log freq. spacing -!! dep_tbl R.A. Public O depthes in Look-up tables arrays dim=(ndep) -!! grdfname chr. Local - Look-up tables filename (C*80) -!! ------------------------------------------------------------------ -!! -!! *** The 11 look-up tables for grid integration geometry arrays -!! *** at all selected 'ndep' depths defined in dep_tbl(ndep)' array -!! *** from gridsetr. dim=(npts,nang,nzz,ndep) -!! kref2_tbl I.A. Public O Index of reference wavenumber for k2 -!! kref4_tbl I.A. Public O Idem for k4 -!! jref2_tbl I.A. Public O Index of reference angle for k2 -!! jref4_tbl I.A. Public O Idem for k4 -!! wtk2_tbl R.A. Public O k2 Interpolation weigth along wavenumbers -!! wtk4_tbl R.A. Public O Idem for k4 -!! wta2_tbl R.A. Public O k2 Interpolation weigth along angles -!! wta4_tbl R.A. Public O Idem for k4 -!! tfac2_tbl R.A. Public O Norm. for interp Action Density at k2 -!! tfac4_tbl R.A. Public O Idem for k4 -!! grad_tbl R.A. Public O Coupling and gradient term in integral -!! grad = C * H * g**2 * ds / |dW/dn| -!! ------------------------------------------------------------------ -!! -!! *** The 11 grid integration geometry arrays at one given depth -!! *** from gridsetr. dim=(npts,nang,nzz,ndep) -!! kref2 I.A. Public O Index of reference wavenumber for k2 -!! kref4 I.A. Public O Idem for k4 -!! jref2 I.A. Public O Index of reference angle for k2 -!! jref4 I.A. Public O Idem for k4 -!! wtk2 R.A. Public O k2 Interpolation weigth along wavenumbers -!! wtk4 R.A. Public O Idem for k4 -!! wta2 R.A. Public O k2 Interpolation weigth along angles -!! wta4 R.A. Public O Idem for k4 -!! tfac2 R.A. Public O Norm. for interp Action Density at k2 -!! tfac4 R.A. Public O Idem for k4 -!! grad R.A. Public O Coupling and gradient term in integral -!! grad = C * H * g**2 * ds / |dW/dn| -!! ------------------------------------------------------------------ -!! -!! 4. Subroutines used : -!! -!! Name Type Module Description -!! ------------------------------------------------------------------ -!! gridsetr Subr. W3SERVMD Calc. the 11 grid geometry arrays for one depth -!! ------------------------------------------------------------------ -!! -!! 5. Called by : -!! -!! Name Type Module Description -!! ------------------------------------------------------------------ -!! STRACE Subr. W3SERVMD Subroutine tracing. -!! W3SNL4 Subr. W3SNL4MD Interface for TSA nonlinear interactions -!! - or - the option below was not used -!! W3IOGR Subr. W3INITMD Initialization (called by W3SHEL or WMINIT) -!! ------------------------------------------------------------------ -!! -!! 6. Error messages : -!! None. -!! -!! 7. Remarks : -!! -!! 8. Structure : -!! -!! See source code. -!! -!! 9. Switches : -!! !/S Enable subroutine tracing. -!! -!!10. Source code : -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! +MODULE W3SNL4MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + !! + !! -----------------------------------------------------------------# + !! ! + !! Generic shallow-water Boltzmann integral (FBI or TSA) ! + !! ! + !! -----------------------------------------------------------------# + !! + !! + !! 1. Purpose : + !! + !! Interface module for TSA type nonlinear interactions. + !! Based on Resio and Perrie (2008) and Perrie and Resio (2009) + !! + !! 2. Variables and types : + !! + !! Name Type Scope Description + !! ------------------------------------------------------------------ + !! ------------------------------------------------------------------ + !! + !! 3. Subroutines and functions : + !! + !! Name Type Scope Description + !! ------------------------------------------------------------------ + !! INSNL4 Subr. W3SNL4MD Corresponding initialization routine. + !! ------ + !! W3SNL4 Subr. W3SNL4MD Main interface for TSA subroutines. + !! ------ Replaces main program "sboltz" in + !! "sbtsa-0-norm-Dec15-08.f" with + !! initialization done in subr. INSNL4 + !! gridsetr Subr. W3SNL4MD Setup geometric integration grid + !! shloxr Subr. W3SNL4MD General locus solution + !! shlocr Subr. W3SNL4MD Locus solving routine - must converges + !! cplshr Subr. W3SNL4MD Computes Boltzmann coupling coefficient + !! ------ + !!op2 + !! Bash; Sections starting & ending with !!op2 are related to subr. optsa2 + !! optsa2 Subr. W3SNL4MD Converts the 2D Energy Density (f,theta) + !! ------ to Polar Action Density (k,theta) Norm. (in k) + !! then splits it into large and small scale + !! --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - !!op2 + !! snlr_tsa Subr. W3SNL4MD Computes dN(k,theta)/dt for TSA + !! -------- due to wave-wave inter. (set itsa = 1) + !! snlr_fbi Subr. W3SNL4MD Computes dN(k,theta)/dt for FBI + !! -------- due to wave-wave inter. (set itsa = 0) + !! + !! wkfnc fnc. W3SNL4MD Compute wave number "k" for given + !! freq "f" (Hz) and water depth "d" (m) + !! or can use subr. WAVNU2 + !! cgfnc fnc. W3SNL4MD Compute group velocity "cg" for given + !! freq "f" (Hz), water depth "d" (m) + !! and phase speed "cvel" (m/s) + !! ------------------------------------------------------------------ + !! + !! 4. Subroutines and functions used : + !! + !! See subroutine documentation. + !! + !! 5. Remarks : + !! + !! 6. Switches : + !! + !! !/S Enable subroutine tracing. + !! !/T(n) Test output, see subroutines. + !! + !! 7. Source code : + !/ + !! --------------------------------------------------------------- & + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + PUBLIC + !! + !! + !! ------------------------------------------------------------------ + !! + !! + !!-0 Set these important run parameters here and declare them as PUBLIC + !! AC itsa, ialt are set in mod_def and read here + !! integer, parameter :: itsa = 1 !* = 1 for "snlr_tsa" or TSA + !! **** !* = 0 for "snlr_fbi" or FBI + !! integer, parameter :: ialt = 2 !* = 2 do alternate in snlr's + !! **** !* = 1 don't alternate in snlr's + integer, parameter :: ismo = 1 !* = 1 do smooth in interp2 + !! **** !* = 0 don't smooth in interp2 + !! !* interp2 is called only if ialt=2 + integer, parameter :: npts = 30 !* # of points on the locus + !! **** !* can reduce npts for speed + integer, parameter :: ndep = 37 !* # of depths in look-up tables + !! **** !* can reduce ndep for speed + !! ------------------------------------------------------------------ + !! + !! + !!-1 Declare freq. related arrays & variables dim (nrng) and + !! angle related arrays & variables dim (nang) as PUBLIC + integer :: nrng, nzz, kzone, nb2fp + integer :: nang, na2p1 + integer :: np2p1 + real :: dfrq, f0 + real :: ainc, twopi + real, allocatable, dimension(:) :: frqa, oma + real, allocatable, dimension(:) :: angl, sinan, cosan + real, allocatable, dimension(:) :: dep_tbl + !! ------------------------------------------------------------------ + !! + !! + !!-2 Declare gridsetr 11 look-up tables arrays dim (npts,nang,nzz,ndep) + !! plus pha_tbl array dim=(nrng,ndep) as PUBLIC + integer, allocatable, dimension(:,:,:,:) :: kref2_tbl, kref4_tbl + integer, allocatable, dimension(:,:,:,:) :: jref2_tbl, jref4_tbl + real, allocatable, dimension(:,:,:,:) :: wtk2_tbl, wtk4_tbl + real, allocatable, dimension(:,:,:,:) :: wta2_tbl, wta4_tbl + real, allocatable, dimension(:,:,:,:) :: tfac2_tbl, tfac4_tbl + real, allocatable, dimension(:,:,:,:) :: grad_tbl + real, allocatable, dimension(:,:) :: pha_tbl + !! ------------------------------------------------------------------ + !! + !! + !!-3 Declare gridsetr 11 returned arrays dim (npts,nang,nzz) as PUBLIC + integer, allocatable, dimension(:,:,:) :: kref2, kref4 + integer, allocatable, dimension(:,:,:) :: jref2, jref4 + real, allocatable, dimension(:,:,:) :: wtk2, wtk4 + real, allocatable, dimension(:,:,:) :: wta2, wta4 + real, allocatable, dimension(:,:,:) :: tfac2, tfac4 + real, allocatable, dimension(:,:,:) :: grad + !! ------------------------------------------------------------------ + !! + !! + !!-4 Declare shloxr/shlocr 5 returned arrays dim (npts) as PUBLIC + real, allocatable, dimension(:) :: wk2x, wk2y + real, allocatable, dimension(:) :: wk4x, wk4y, ds + !! ------------------------------------------------------------------ + !! + !! + !!-5 Declare w3snl4/optsa2 2 shared arrays dim (nrng,nang) & (nrng) as PUBLIC + !! - ef2(nrng,nang) 'ww3' 2D Energy + !! - ef1(nrng) 'ww3' 1D Energy from ef2() + real, allocatable, dimension(:,:) :: ef2 + real, allocatable, dimension(:) :: ef1 + !! ------------------------------------------------------------------ + !! + !! + !!-6 Declare optsa2 2 returned arrays dim (nrng,nang) as PUBLIC + !! - dens1(nrng,nang) 'ww3' 2D Broad Scale Action + !! - dens2(nrng,nang) 'ww3' 2D Small Scale Action + real, allocatable, dimension(:,:) :: dens1, dens2 + !! ------------------------------------------------------------------ + !! + !! + !!-7 Declare snlr's 4 returned arrays dim (nrng,nang) as PUBLIC + !! tsa, diag used for -tsa + !! fbi, diag2 used for -fbi + real, allocatable, dimension(:,:) :: tsa, diag + real, allocatable, dimension(:,:) :: fbi, diag2 + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! +CONTAINS + !! + !! + !!============================================================================== + !! + !! ------------------------------------------------------------------ + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + SUBROUTINE INSNL4 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! + !! it returns: 11 look-up tables arrays dim=(npts,nang,nzz,ndep) + !! kref2_tbl, kref4_tbl, jref2_tbl, jref4_tbl, + !! wtk2_tbl, wtk4_tbl, wta2_tbl, wta4_tbl, + !! tfac2_tbl, tfac4_tbl & grad_tbl + !! plus pha_tbl dim=(nrng,ndep) + !! and dep_tbl dim=(ndep) + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! 1. Purpose : + !! It reads look-up tables (generated by gridsetr) if file exists + !! otherwise it must generate the look-up tables file + !! + !! 2. Method : + !! See subr gridsetr and subr W3SNL4 (or subr. W3IOGR) + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! nrng int. Public I # of freq. or rings + !! nang int. Public I # of angles + !! npts int. Public I # of points on the locus + !! ndep int. Public I # of depths in look-up tables + !! dfrq Real Public I frequency multiplier for log freq. spacing + !! dep_tbl R.A. Public O depthes in Look-up tables arrays dim=(ndep) + !! grdfname chr. Local - Look-up tables filename (C*80) + !! ------------------------------------------------------------------ + !! + !! *** The 11 look-up tables for grid integration geometry arrays + !! *** at all selected 'ndep' depths defined in dep_tbl(ndep)' array + !! *** from gridsetr. dim=(npts,nang,nzz,ndep) + !! kref2_tbl I.A. Public O Index of reference wavenumber for k2 + !! kref4_tbl I.A. Public O Idem for k4 + !! jref2_tbl I.A. Public O Index of reference angle for k2 + !! jref4_tbl I.A. Public O Idem for k4 + !! wtk2_tbl R.A. Public O k2 Interpolation weigth along wavenumbers + !! wtk4_tbl R.A. Public O Idem for k4 + !! wta2_tbl R.A. Public O k2 Interpolation weigth along angles + !! wta4_tbl R.A. Public O Idem for k4 + !! tfac2_tbl R.A. Public O Norm. for interp Action Density at k2 + !! tfac4_tbl R.A. Public O Idem for k4 + !! grad_tbl R.A. Public O Coupling and gradient term in integral + !! grad = C * H * g**2 * ds / |dW/dn| + !! ------------------------------------------------------------------ + !! + !! *** The 11 grid integration geometry arrays at one given depth + !! *** from gridsetr. dim=(npts,nang,nzz,ndep) + !! kref2 I.A. Public O Index of reference wavenumber for k2 + !! kref4 I.A. Public O Idem for k4 + !! jref2 I.A. Public O Index of reference angle for k2 + !! jref4 I.A. Public O Idem for k4 + !! wtk2 R.A. Public O k2 Interpolation weigth along wavenumbers + !! wtk4 R.A. Public O Idem for k4 + !! wta2 R.A. Public O k2 Interpolation weigth along angles + !! wta4 R.A. Public O Idem for k4 + !! tfac2 R.A. Public O Norm. for interp Action Density at k2 + !! tfac4 R.A. Public O Idem for k4 + !! grad R.A. Public O Coupling and gradient term in integral + !! grad = C * H * g**2 * ds / |dW/dn| + !! ------------------------------------------------------------------ + !! + !! 4. Subroutines used : + !! + !! Name Type Module Description + !! ------------------------------------------------------------------ + !! gridsetr Subr. W3SERVMD Calc. the 11 grid geometry arrays for one depth + !! ------------------------------------------------------------------ + !! + !! 5. Called by : + !! + !! Name Type Module Description + !! ------------------------------------------------------------------ + !! STRACE Subr. W3SERVMD Subroutine tracing. + !! W3SNL4 Subr. W3SNL4MD Interface for TSA nonlinear interactions + !! - or - the option below was not used + !! W3IOGR Subr. W3INITMD Initialization (called by W3SHEL or WMINIT) + !! ------------------------------------------------------------------ + !! + !! 6. Error messages : + !! None. + !! + !! 7. Remarks : + !! + !! 8. Structure : + !! + !! See source code. + !! + !! 9. Switches : + !! !/S Enable subroutine tracing. + !! + !!10. Source code : + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3ODATMD, ONLY: NDSE, NDST, NDSO + USE W3ODATMD, ONLY: NDSE, NDST, NDSO #ifdef W3_MPI - USE WMMDATMD, ONLY: NMPSCR, IMPROC + USE WMMDATMD, ONLY: NMPSCR, IMPROC #endif - USE CONSTANTS, ONLY: file_endian -!! ------------------------------------------------------------------ -!! ================================================================== -!! - IMPLICIT NONE -!! -!! ================================================================== -!! -!! Local variables & Parameters -!! ---------------------------- + USE CONSTANTS, ONLY: file_endian + !! ------------------------------------------------------------------ + !! ================================================================== + !! + IMPLICIT NONE + !! + !! ================================================================== + !! + !! Local variables & Parameters + !! ---------------------------- #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!! - integer :: irng !* dummy integer - integer :: nd !* dummy integer -!! - logical :: unavail = .TRUE. - logical :: file_exists - character :: grdfname*80 - integer :: io_unit -!! -!! -!! Dimension wv# array and -!! declare local var. dep2, cvel & cgnrng at nrng & depth 'nd' - real :: wka2(nrng) !* wv# array at depth nd (local) - real :: pha2(nrng) !* pha array at depth nd (local) - real :: dep2 !* = dep_tbl(nd) depth at nd - real :: cvel !* Phase Velocity at (nrng,nd) - real :: cgnrng !* Group Velocity at (nrng,nd) - real :: dwka !* dummy storage for dk -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! + !! + integer :: irng !* dummy integer + integer :: nd !* dummy integer + !! + logical :: unavail = .TRUE. + logical :: file_exists + character :: grdfname*80 + integer :: io_unit + !! + !! + !! Dimension wv# array and + !! declare local var. dep2, cvel & cgnrng at nrng & depth 'nd' + real :: wka2(nrng) !* wv# array at depth nd (local) + real :: pha2(nrng) !* pha array at depth nd (local) + real :: dep2 !* = dep_tbl(nd) depth at nd + real :: cvel !* Phase Velocity at (nrng,nd) + real :: cgnrng !* Group Velocity at (nrng,nd) + real :: dwka !* dummy storage for dk + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! #ifdef W3_S - CALL STRACE (IENT, 'W3SNL4') + CALL STRACE (IENT, 'W3SNL4') #endif -!! -!! ================================================================== -!! -!! -!!-1 Make-up the filename from the main parameters -!! ------------------------------------------------------------------ -!b example filename; grdfname = 'grd_1.1025_35_36_30_37.dat' -!! grdfname = 'grd_dfrq_nr_na_np_nd.dat' -!! where fm = freq. mult. (dfrq) ex. dfrq = 1.1025 (F6.4) -!! nr = # of rings (nrng) ex. nrng = 35 (I2.2) -!! na = # of angles (nang) ex. nang = 36 (I2.2) -!! np = # of points (npts) ex. npts = 30 (I2.2) -!! nd = # of depths (ndep) ex. nd = 37 (I2.2) - write(grdfname,'(A,F6.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A)') & - 'grd_', dfrq,'_', nrng,'_', nang,'_', npts,'_', ndep, '.dat' -!! ================================================================== -!! -!! -!!-2 Check if the propre gridsetr Look-up tables file is available. -!! if available read it and if not must generate it (by calling gridsetr) -!! ------------------------------------------------------------------ - INQUIRE ( FILE=grdfname, EXIST=file_exists ) -!! Assign an unused UNIT number to io_unit. -!! Note; It's important to look for an available unused number - io_unit = 60 - do while (unavail) - io_unit = io_unit + 1 - INQUIRE ( io_unit, opened=unavail ) - enddo -!prt print *, 'io_unit = ', io_unit -!! ================================================================== -!! -!! -!! -!! - IF ( file_exists ) THEN -!! -!!-3 File exists open it and read it -!! + !! + !! ================================================================== + !! + !! + !!-1 Make-up the filename from the main parameters + !! ------------------------------------------------------------------ + !b example filename; grdfname = 'grd_1.1025_35_36_30_37.dat' + !! grdfname = 'grd_dfrq_nr_na_np_nd.dat' + !! where fm = freq. mult. (dfrq) ex. dfrq = 1.1025 (F6.4) + !! nr = # of rings (nrng) ex. nrng = 35 (I2.2) + !! na = # of angles (nang) ex. nang = 36 (I2.2) + !! np = # of points (npts) ex. npts = 30 (I2.2) + !! nd = # of depths (ndep) ex. nd = 37 (I2.2) + write(grdfname,'(A,F6.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A)') & + 'grd_', dfrq,'_', nrng,'_', nang,'_', npts,'_', ndep, '.dat' + !! ================================================================== + !! + !! + !!-2 Check if the propre gridsetr Look-up tables file is available. + !! if available read it and if not must generate it (by calling gridsetr) + !! ------------------------------------------------------------------ + INQUIRE ( FILE=grdfname, EXIST=file_exists ) + !! Assign an unused UNIT number to io_unit. + !! Note; It's important to look for an available unused number + io_unit = 60 + do while (unavail) + io_unit = io_unit + 1 + INQUIRE ( io_unit, opened=unavail ) + enddo + !prt print *, 'io_unit = ', io_unit + !! ================================================================== + !! + !! + !! + !! + IF ( file_exists ) THEN + !! + !!-3 File exists open it and read it + !! #ifdef W3_MPI - if ( improc .eq. nmpscr ) then + if ( improc .eq. nmpscr ) then #endif write ( ndso, 900 ) grdfname #ifdef W3_MPI - end if + end if #endif -!! - open (UNIT=io_unit, FILE=grdfname, STATUS='old', & - ACCESS='sequential', ACTION='read', form='unformatted', convert=file_endian) - read (io_unit) kref2_tbl, kref4_tbl, jref2_tbl, jref4_tbl, & - wtk2_tbl, wtk4_tbl, wta2_tbl, wta4_tbl, & - tfac2_tbl, tfac4_tbl, grad_tbl, & - pha_tbl, dep_tbl - close (io_unit) -!! ---------------------------------------------------------------- -!! - ELSE !* ELSE IF ( file_exists ) -!! -!! -!!-4 File does not exist, create it here -!! + !! + open (UNIT=io_unit, FILE=grdfname, STATUS='old', & + ACCESS='sequential', ACTION='read', form='unformatted', convert=file_endian) + read (io_unit) kref2_tbl, kref4_tbl, jref2_tbl, jref4_tbl, & + wtk2_tbl, wtk4_tbl, wta2_tbl, wta4_tbl, & + tfac2_tbl, tfac4_tbl, grad_tbl, & + pha_tbl, dep_tbl + close (io_unit) + !! ---------------------------------------------------------------- + !! + ELSE !* ELSE IF ( file_exists ) + !! + !! + !!-4 File does not exist, create it here + !! #ifdef W3_MPI - if ( improc .eq. nmpscr ) then + if ( improc .eq. nmpscr ) then #endif write ( ndso, 901 ) grdfname #ifdef W3_MPI - end if + end if #endif -!! ---------------------------------------------------------------- -!! -!!-4a Define Look-up tables depth array 'dep_tbl(ndep)' for ndep=37 -!! with depths are +ve values -!! ---------------------------------------------------------------- - dep_tbl(1:ndep) = & - (/ 2., 4., 6., 8., 10., 12., 14., 16., 18., 20., & - 25., 30., 35., 40., 45., 50., 55., 60., 65., 70., & - 80., 90.,100.,110.,120.,130.,140.,150.,160.,170., & - 220.,270.,320.,370.,420.,470.,520. /) -!prt print *, ' ndep = ', ndep -!prt print *, ' dep_tbl(1:ndep) = ', dep_tbl -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! - do nd = 1,ndep -!! -!! -!!-4b For given new depth dep2 = dep_tbl(nd) calculate -!! a new array wka2(:) & new cgnrng corresp. to this depth - dep2 = dep_tbl(nd) - do irng=1,nrng - wka2(irng) = wkfnc(frqa(irng),dep2) - end do - cvel = oma(nrng)/wka2(nrng) !* Phase Vel. at (nrng,nd) - cgnrng = cgfnc(frqa(nrng),dep2,cvel) !* Group Vel. at (nrng,nd) -!! -------------------------------------------------------------- -!! ============================================================== -!! -!! -!!-4c Call gridsetr for this depth at nd -!! -------------------------------------------------------------- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call gridsetr ( dep2, wka2, cgnrng ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! it returns: 11 gridsetr arrays which are declared PUBLIC -!! kref2,kref4, jref2,jref4, wtk2,wtk4, wta2,wta4, -!! tfac2,tfac4 and grad all dim=(npts,nang,nzz) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -------------------------------------------------------------- -!! ============================================================== -!! -!!-4d Store in Look-up tables arrays at depth bin # 'nd' - kref2_tbl(:,:,:,nd) = kref2(:,:,:) - kref4_tbl(:,:,:,nd) = kref4(:,:,:) - jref2_tbl(:,:,:,nd) = jref2(:,:,:) - jref4_tbl(:,:,:,nd) = jref4(:,:,:) - wtk2_tbl(:,:,:,nd) = wtk2(:,:,:) - wtk4_tbl(:,:,:,nd) = wtk4(:,:,:) - wta2_tbl(:,:,:,nd) = wta2(:,:,:) - wta4_tbl(:,:,:,nd) = wta4(:,:,:) - tfac2_tbl(:,:,:,nd) = tfac2(:,:,:) - tfac4_tbl(:,:,:,nd) = tfac4(:,:,:) - grad_tbl(:,:,:,nd) = grad(:,:,:) -!! -------------------------------------------------------------- -!! ============================================================== -!! -!! -!!-4e Calculate pha2(:) at nd depth and store it in pha_tbl(:,:) -!! pha2()=k*dk*dtheta, the base area at a grid intersection -!! for use in integration of 2-D Density functions. -!! -------------------------------------------------------------- -!! Below: variable dwka = dk centered at ring 1 (between 0 & 2) -!! and computed pha2(1) = k*dk*dtheta at ring 1 -!! with wkfnc(frqa(1)/dfrq,dep2) is like wka2(0) -!! --assuming frqa(1)/dfrq is like frqa(0) - dwka = ( wka2(2) - wkfnc(frqa(1)/dfrq,dep2) ) / 2. - pha2(1) = wka2(1)*dwka*ainc -!! - do irng=2,nrng-1 -!! Below: variable dwka = dk centered at irng (between irng-1 & irng+1) -!! and computed pha2(irng) = k*dk*dtheta at irng - dwka = ( wka2(irng+1) - wka2(irng-1) ) / 2. - pha2(irng) = wka2(irng)*dwka*ainc - end do -!! -!! Below: variable dwka = dk centered at nrng (between nrng-1 & nrng+1) -!! and computed pha2(nrng) = k*dk*dtheta at nrng -!! with wkfnc(dfrq*frqa(nrng),dep2) is like wka2(nrng+1) -!! --assuming dfrq*frqa(nrng) is like frqa(nrng+1) - dwka = ( wkfnc(dfrq*frqa(nrng),dep2) - wka2(nrng-1) ) / 2. - pha2(nrng) = wka2(nrng)*dwka*ainc -!! -------------------------------------------------------------- -!! ============================================================== -!! -!! -!!-4f Store pha2(:) at nd in pha_tbl(:,nd) to be added to Look-up tables - pha_tbl(1:nrng, nd) = pha2(1:nrng) -!! -------------------------------------------------------------- -!! ============================================================== -!! -!! - end do ! nd = 1,ndep -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! -!!-5 Ounce the Look-up tables arrays are full write it out to 'io_unit' -!! + !! ---------------------------------------------------------------- + !! + !!-4a Define Look-up tables depth array 'dep_tbl(ndep)' for ndep=37 + !! with depths are +ve values + !! ---------------------------------------------------------------- + dep_tbl(1:ndep) = & + (/ 2., 4., 6., 8., 10., 12., 14., 16., 18., 20., & + 25., 30., 35., 40., 45., 50., 55., 60., 65., 70., & + 80., 90.,100.,110.,120.,130.,140.,150.,160.,170., & + 220.,270.,320.,370.,420.,470.,520. /) + !prt print *, ' ndep = ', ndep + !prt print *, ' dep_tbl(1:ndep) = ', dep_tbl + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + do nd = 1,ndep + !! + !! + !!-4b For given new depth dep2 = dep_tbl(nd) calculate + !! a new array wka2(:) & new cgnrng corresp. to this depth + dep2 = dep_tbl(nd) + do irng=1,nrng + wka2(irng) = wkfnc(frqa(irng),dep2) + end do + cvel = oma(nrng)/wka2(nrng) !* Phase Vel. at (nrng,nd) + cgnrng = cgfnc(frqa(nrng),dep2,cvel) !* Group Vel. at (nrng,nd) + !! -------------------------------------------------------------- + !! ============================================================== + !! + !! + !!-4c Call gridsetr for this depth at nd + !! -------------------------------------------------------------- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call gridsetr ( dep2, wka2, cgnrng ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! it returns: 11 gridsetr arrays which are declared PUBLIC + !! kref2,kref4, jref2,jref4, wtk2,wtk4, wta2,wta4, + !! tfac2,tfac4 and grad all dim=(npts,nang,nzz) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! -------------------------------------------------------------- + !! ============================================================== + !! + !!-4d Store in Look-up tables arrays at depth bin # 'nd' + kref2_tbl(:,:,:,nd) = kref2(:,:,:) + kref4_tbl(:,:,:,nd) = kref4(:,:,:) + jref2_tbl(:,:,:,nd) = jref2(:,:,:) + jref4_tbl(:,:,:,nd) = jref4(:,:,:) + wtk2_tbl(:,:,:,nd) = wtk2(:,:,:) + wtk4_tbl(:,:,:,nd) = wtk4(:,:,:) + wta2_tbl(:,:,:,nd) = wta2(:,:,:) + wta4_tbl(:,:,:,nd) = wta4(:,:,:) + tfac2_tbl(:,:,:,nd) = tfac2(:,:,:) + tfac4_tbl(:,:,:,nd) = tfac4(:,:,:) + grad_tbl(:,:,:,nd) = grad(:,:,:) + !! -------------------------------------------------------------- + !! ============================================================== + !! + !! + !!-4e Calculate pha2(:) at nd depth and store it in pha_tbl(:,:) + !! pha2()=k*dk*dtheta, the base area at a grid intersection + !! for use in integration of 2-D Density functions. + !! -------------------------------------------------------------- + !! Below: variable dwka = dk centered at ring 1 (between 0 & 2) + !! and computed pha2(1) = k*dk*dtheta at ring 1 + !! with wkfnc(frqa(1)/dfrq,dep2) is like wka2(0) + !! --assuming frqa(1)/dfrq is like frqa(0) + dwka = ( wka2(2) - wkfnc(frqa(1)/dfrq,dep2) ) / 2. + pha2(1) = wka2(1)*dwka*ainc + !! + do irng=2,nrng-1 + !! Below: variable dwka = dk centered at irng (between irng-1 & irng+1) + !! and computed pha2(irng) = k*dk*dtheta at irng + dwka = ( wka2(irng+1) - wka2(irng-1) ) / 2. + pha2(irng) = wka2(irng)*dwka*ainc + end do + !! + !! Below: variable dwka = dk centered at nrng (between nrng-1 & nrng+1) + !! and computed pha2(nrng) = k*dk*dtheta at nrng + !! with wkfnc(dfrq*frqa(nrng),dep2) is like wka2(nrng+1) + !! --assuming dfrq*frqa(nrng) is like frqa(nrng+1) + dwka = ( wkfnc(dfrq*frqa(nrng),dep2) - wka2(nrng-1) ) / 2. + pha2(nrng) = wka2(nrng)*dwka*ainc + !! -------------------------------------------------------------- + !! ============================================================== + !! + !! + !!-4f Store pha2(:) at nd in pha_tbl(:,nd) to be added to Look-up tables + pha_tbl(1:nrng, nd) = pha2(1:nrng) + !! -------------------------------------------------------------- + !! ============================================================== + !! + !! + end do ! nd = 1,ndep + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + !!-5 Ounce the Look-up tables arrays are full write it out to 'io_unit' + !! #ifdef W3_MPI - if ( improc .eq. nmpscr ) then + if ( improc .eq. nmpscr ) then #endif write( ndso,902 ) open (UNIT=io_unit, FILE=grdfname, STATUS='new', & ACCESS='sequential', ACTION='write', form='unformatted', convert=file_endian) write (io_unit) kref2_tbl, kref4_tbl, jref2_tbl, jref4_tbl, & - wtk2_tbl, wtk4_tbl, wta2_tbl, wta4_tbl, & - tfac2_tbl, tfac4_tbl, grad_tbl, & - pha_tbl, dep_tbl + wtk2_tbl, wtk4_tbl, wta2_tbl, wta4_tbl, & + tfac2_tbl, tfac4_tbl, grad_tbl, & + pha_tbl, dep_tbl close (io_unit) write( ndso,903 ) grdfname #ifdef W3_MPI - end if + end if #endif -!! ---------------------------------------------------------------- -!! ================================================================ -!! - ENDIF !* End IF ( file_exists ) -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! - RETURN -!! - 900 format ( ' grdfname does exist = ',A/ & - ' open, read & close file ' ) -!! - 901 format ( ' grdfname does not exist = ',A/ & - ' Generate look-up table arrays ' ) -!! - 902 format ( ' Done generating look-up table arrays ----------- ' ) -!! - 903 format ( ' Done writing & closing grdfname ', A ) -!! - END SUBROUTINE INSNL4 -!! -!!============================================================================== -!! -!! ------------------------------------------------------------------ -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! ------------------------------------------------------------------ -!! -!! it returns: S & D dim = (NTH,NK) = (nang,nrng) -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! 1. Purpose : -!! -!! Interface module for TSA type nonlinear interactions. -!! Based on Resio and Perrie (2008) and Perrie and Resio (2009) -!! -!! 2. Method : -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! A R.A. I 2D Action Density A(NTH,NK) as function of -!! direction (rad) and wavenumber (theta,k) -!! CG R.A. I Group velocities dim=NK -!! WN R.A. I Wavenumbers dim=NK -!! DEPTH Real I Water depth (m) -!! S R.A. O Source term. dim=(NTH,NK) -!! D R.A. O Diagonal term of derivative. dim=(NTH,NK) -!! ------------------------------------------------------------------ -!! -!! nrng int. Public O # of freq. or rings -!! nang int. Public O # of angles -!! npts int. Public I # of points on the locus -!! ndep int. Public I # of depths in look-up tables -!! nzz int. Public O linear irngxkrng = (NK*(NK+1))/2 -!! kzone int. Public O zone of influence = INT(alog(4.0)/alog(dfrq)) -!! nb2fp int. Public O # of bins over fp => dfrq**nb2fp)*fp ~ 2.*fp -!! = INT(alog(2.0)/alog(dfrq)) -!! na2p1 int. Public O = nang/2 + 1 -!! np2p1 int. Public O = npts/2 + 1 -!! dfrq Real Public O frequency multiplier for log freq. spacing -!! f0 Real Public O = frqa(1); first freq. (Hz) -!! ainc Real Public O = DTH; WW3 angle increment (radians) -!! twopi Real Public O = TPI; WW3i 2*pi = 8.*atan(1.) (radians) -!! oma R.A. Public O = SIG(1:NK) WW3 waveumber array dim=(nrng) -!! frqa R.A. Public O = oma(:)/twopi WW3 frequency array dim=(nrng) -!! angl R.A. Public O = TH(1:NTH); WW3 angles array dim=(nang) -!! sinan R.A. Public O = ESIN(1:NTH); WW3 sin(angl(:)) array dim=(nang) -!! cosan R.A. Public O = ECOS(1:NTH); WW3 cos(angl(:)) array dim=(nang) -!! dep_tbl R.A. Public I depthes in Look-up tables arrays dim=(ndep) -!! ------------------------------------------------------------------ -!! -!! *** The 11 look-up tables for grid integration geometry arrays -!! *** at all selected 'ndep' depths defined in dep_tbl(ndep)' array -!! *** from gridsetr. dim=(npts,nang,nzz,ndep) -!! kref2_tbl I.A. Public I Index of reference wavenumber for k2 -!! kref4_tbl I.A. Public I Idem for k4 -!! jref2_tbl I.A. Public I Index of reference angle for k2 -!! jref4_tbl I.A. Public I Idem for k4 -!! wtk2_tbl R.A. Public I k2 Interpolation weigth along wavenumbers -!! wtk4_tbl R.A. Public I Idem for k4 -!! wta2_tbl R.A. Public I k2 Interpolation weigth along angles -!! wta4_tbl R.A. Public I Idem for k4 -!! tfac2_tbl R.A. Public I Norm. for interp Action Density at k2 -!! tfac4_tbl R.A. Public I Idem for k4 -!! grad_tbl R.A. Public I Coupling and gradient term in integral -!! grad = C * H * g**2 * ds / |dW/dn| -!! ------------------------------------------------------------------ -!! -!! *** The 11 grid integration geometry arrays at one given depth -!! *** from gridsetr. dim=(npts,nang,nzz,ndep) -!! kref2 I.A. Public O Index of reference wavenumber for k2 -!! kref4 I.A. Public O Idem for k4 -!! jref2 I.A. Public O Index of reference angle for k2 -!! jref4 I.A. Public O Idem for k4 -!! wtk2 R.A. Public O k2 Interpolation weigth along wavenumbers -!! wtk4 R.A. Public O Idem for k4 -!! wta2 R.A. Public O k2 Interpolation weigth along angles -!! wta4 R.A. Public O Idem for k4 -!! tfac2 R.A. Public O Norm. for interp Action Density at k2 -!! tfac4 R.A. Public O Idem for k4 -!! grad R.A. Public O Coupling and gradient term in integral -!! grad = C * H * g**2 * ds / |dW/dn| -!! ------------------------------------------------------------------ -!! -!! ef2 R.A. Public O 2D Energy Density spectrum ef2(theta,f) -!! = A(theta,k) * 2*pi*oma(f)/cga(f) -!! dim=(nrng,nang) -!! ef1 R.A. Public O 1D Energy Density spectrum ef1(f) -!! dim=(nrng) -!! -!! dens1 R.A. Public O large-scale Action Density (k,theta) -!! dim=(nrng,nang) -!! dens2 R.A. Public O Small-scale Action Density (k,theta) -!! dim=(nrng,nang) -!! ------------------------------------------------------------------ -!! -!! for -tsa; The 2 returned arrays tsa & diag dim=(nrng,nang) -!! tsa R.A. Public O Snl-tsa = sumint + sumintsa -!! diag R.A. Public O Snl-tsa diagonal term = [dN/dn1] -!! ------------------------------------------------------------------ -!! -!! for -fbi; The 2 returned arrays fbi & diag2 dim=(nrng,nang) -!! fbi R.A. Public O Snl-fbi = sumint + sumintp + sumintx -!! diag2 R.A. Public O Snl-fbi diagonal term = [dN/dn1] -!! ------------------------------------------------------------------ -!! -!! 4. Subroutines used : -!! -!! Name Type Module Description -!! ------------------------------------------------------------------ -!! STRACE Subr. W3SERVMD Subroutine tracing. -!! optsa2 Subr. W3SERVMD Converts the 2D Energy Density (f,theta) -!! ------ to Polar Action Density (k,theta) Norm. (in k) -!! then splits it into large and small scale -!! snlr_tsa Subr. W3SERVMD Computes dN(k,theta)/dt for TSA -!! -------- due to wave-wave inter. (set itsa = 1) -!! snlr_fbi Subr. W3SERVMD Computes dN(k,theta)/dt for FBI -!! -------- due to wave-wave inter. (set itsa = 0) -!! ------------------------------------------------------------------ -!! -!! 5. Called by : -!! -!! Name Type Module Description -!! ------------------------------------------------------------------ -!! W3SRCE Subr. w3srcemd Source term integration. -!! W3EXPO Subr. ww3_outp Point output post-processor. -!! W3EXNC Subr. ww3_ounp NetCDF Point output post-processor. -!! GXEXPO Subr. gx_outp GrADS Point output post-processor. -!! ------------------------------------------------------------------ -!! -!! 6. Error messages : -!! -!! None. -!! -!! 7. Remarks : -!! -!! 8. Structure : -!! -!! See source code. -!! -!! 9. Switches : -!! -!! !/S Enable subroutine tracing. -!! -!!10. Source code : -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! - USE CONSTANTS, ONLY: TPI - USE W3GDATMD, ONLY: NK, NTH, XFR, DTH, SIG, TH, ECOS, ESIN, & - ITSA, IALT -!! dimension: SIG(0:NK+1),TH(NTH), ECOS(NSPEC+NTH), ESIN(NSPEC+NTH) -!! - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE, NDST, NDSO + !! ---------------------------------------------------------------- + !! ================================================================ + !! + ENDIF !* End IF ( file_exists ) + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + RETURN + !! +900 format ( ' grdfname does exist = ',A/ & + ' open, read & close file ' ) + !! +901 format ( ' grdfname does not exist = ',A/ & + ' Generate look-up table arrays ' ) + !! +902 format ( ' Done generating look-up table arrays ----------- ' ) + !! +903 format ( ' Done writing & closing grdfname ', A ) + !! + END SUBROUTINE INSNL4 + !! + !!============================================================================== + !! + !! ------------------------------------------------------------------ + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! ------------------------------------------------------------------ + !! + !! it returns: S & D dim = (NTH,NK) = (nang,nrng) + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! 1. Purpose : + !! + !! Interface module for TSA type nonlinear interactions. + !! Based on Resio and Perrie (2008) and Perrie and Resio (2009) + !! + !! 2. Method : + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! A R.A. I 2D Action Density A(NTH,NK) as function of + !! direction (rad) and wavenumber (theta,k) + !! CG R.A. I Group velocities dim=NK + !! WN R.A. I Wavenumbers dim=NK + !! DEPTH Real I Water depth (m) + !! S R.A. O Source term. dim=(NTH,NK) + !! D R.A. O Diagonal term of derivative. dim=(NTH,NK) + !! ------------------------------------------------------------------ + !! + !! nrng int. Public O # of freq. or rings + !! nang int. Public O # of angles + !! npts int. Public I # of points on the locus + !! ndep int. Public I # of depths in look-up tables + !! nzz int. Public O linear irngxkrng = (NK*(NK+1))/2 + !! kzone int. Public O zone of influence = INT(alog(4.0)/alog(dfrq)) + !! nb2fp int. Public O # of bins over fp => dfrq**nb2fp)*fp ~ 2.*fp + !! = INT(alog(2.0)/alog(dfrq)) + !! na2p1 int. Public O = nang/2 + 1 + !! np2p1 int. Public O = npts/2 + 1 + !! dfrq Real Public O frequency multiplier for log freq. spacing + !! f0 Real Public O = frqa(1); first freq. (Hz) + !! ainc Real Public O = DTH; WW3 angle increment (radians) + !! twopi Real Public O = TPI; WW3i 2*pi = 8.*atan(1.) (radians) + !! oma R.A. Public O = SIG(1:NK) WW3 waveumber array dim=(nrng) + !! frqa R.A. Public O = oma(:)/twopi WW3 frequency array dim=(nrng) + !! angl R.A. Public O = TH(1:NTH); WW3 angles array dim=(nang) + !! sinan R.A. Public O = ESIN(1:NTH); WW3 sin(angl(:)) array dim=(nang) + !! cosan R.A. Public O = ECOS(1:NTH); WW3 cos(angl(:)) array dim=(nang) + !! dep_tbl R.A. Public I depthes in Look-up tables arrays dim=(ndep) + !! ------------------------------------------------------------------ + !! + !! *** The 11 look-up tables for grid integration geometry arrays + !! *** at all selected 'ndep' depths defined in dep_tbl(ndep)' array + !! *** from gridsetr. dim=(npts,nang,nzz,ndep) + !! kref2_tbl I.A. Public I Index of reference wavenumber for k2 + !! kref4_tbl I.A. Public I Idem for k4 + !! jref2_tbl I.A. Public I Index of reference angle for k2 + !! jref4_tbl I.A. Public I Idem for k4 + !! wtk2_tbl R.A. Public I k2 Interpolation weigth along wavenumbers + !! wtk4_tbl R.A. Public I Idem for k4 + !! wta2_tbl R.A. Public I k2 Interpolation weigth along angles + !! wta4_tbl R.A. Public I Idem for k4 + !! tfac2_tbl R.A. Public I Norm. for interp Action Density at k2 + !! tfac4_tbl R.A. Public I Idem for k4 + !! grad_tbl R.A. Public I Coupling and gradient term in integral + !! grad = C * H * g**2 * ds / |dW/dn| + !! ------------------------------------------------------------------ + !! + !! *** The 11 grid integration geometry arrays at one given depth + !! *** from gridsetr. dim=(npts,nang,nzz,ndep) + !! kref2 I.A. Public O Index of reference wavenumber for k2 + !! kref4 I.A. Public O Idem for k4 + !! jref2 I.A. Public O Index of reference angle for k2 + !! jref4 I.A. Public O Idem for k4 + !! wtk2 R.A. Public O k2 Interpolation weigth along wavenumbers + !! wtk4 R.A. Public O Idem for k4 + !! wta2 R.A. Public O k2 Interpolation weigth along angles + !! wta4 R.A. Public O Idem for k4 + !! tfac2 R.A. Public O Norm. for interp Action Density at k2 + !! tfac4 R.A. Public O Idem for k4 + !! grad R.A. Public O Coupling and gradient term in integral + !! grad = C * H * g**2 * ds / |dW/dn| + !! ------------------------------------------------------------------ + !! + !! ef2 R.A. Public O 2D Energy Density spectrum ef2(theta,f) + !! = A(theta,k) * 2*pi*oma(f)/cga(f) + !! dim=(nrng,nang) + !! ef1 R.A. Public O 1D Energy Density spectrum ef1(f) + !! dim=(nrng) + !! + !! dens1 R.A. Public O large-scale Action Density (k,theta) + !! dim=(nrng,nang) + !! dens2 R.A. Public O Small-scale Action Density (k,theta) + !! dim=(nrng,nang) + !! ------------------------------------------------------------------ + !! + !! for -tsa; The 2 returned arrays tsa & diag dim=(nrng,nang) + !! tsa R.A. Public O Snl-tsa = sumint + sumintsa + !! diag R.A. Public O Snl-tsa diagonal term = [dN/dn1] + !! ------------------------------------------------------------------ + !! + !! for -fbi; The 2 returned arrays fbi & diag2 dim=(nrng,nang) + !! fbi R.A. Public O Snl-fbi = sumint + sumintp + sumintx + !! diag2 R.A. Public O Snl-fbi diagonal term = [dN/dn1] + !! ------------------------------------------------------------------ + !! + !! 4. Subroutines used : + !! + !! Name Type Module Description + !! ------------------------------------------------------------------ + !! STRACE Subr. W3SERVMD Subroutine tracing. + !! optsa2 Subr. W3SERVMD Converts the 2D Energy Density (f,theta) + !! ------ to Polar Action Density (k,theta) Norm. (in k) + !! then splits it into large and small scale + !! snlr_tsa Subr. W3SERVMD Computes dN(k,theta)/dt for TSA + !! -------- due to wave-wave inter. (set itsa = 1) + !! snlr_fbi Subr. W3SERVMD Computes dN(k,theta)/dt for FBI + !! -------- due to wave-wave inter. (set itsa = 0) + !! ------------------------------------------------------------------ + !! + !! 5. Called by : + !! + !! Name Type Module Description + !! ------------------------------------------------------------------ + !! W3SRCE Subr. w3srcemd Source term integration. + !! W3EXPO Subr. ww3_outp Point output post-processor. + !! W3EXNC Subr. ww3_ounp NetCDF Point output post-processor. + !! GXEXPO Subr. gx_outp GrADS Point output post-processor. + !! ------------------------------------------------------------------ + !! + !! 6. Error messages : + !! + !! None. + !! + !! 7. Remarks : + !! + !! 8. Structure : + !! + !! See source code. + !! + !! 9. Switches : + !! + !! !/S Enable subroutine tracing. + !! + !!10. Source code : + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + USE CONSTANTS, ONLY: TPI + USE W3GDATMD, ONLY: NK, NTH, XFR, DTH, SIG, TH, ECOS, ESIN, & + ITSA, IALT + !! dimension: SIG(0:NK+1),TH(NTH), ECOS(NSPEC+NTH), ESIN(NSPEC+NTH) + !! + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE, NDST, NDSO #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!! ================================================================== -!! - IMPLICIT NONE -!! -!! Parameter list -!! -------------- - REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK), DEPTH - REAL, INTENT(OUT) :: S(NTH,NK), D(NTH,NK) -!! - LOGICAL, SAVE :: FIRST_TSA = .TRUE. -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! -!! Local Parameters & variables -!! ----------------------------- + !! ================================================================== + !! + IMPLICIT NONE + !! + !! Parameter list + !! -------------- + REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK), DEPTH + REAL, INTENT(OUT) :: S(NTH,NK), D(NTH,NK) + !! + LOGICAL, SAVE :: FIRST_TSA = .TRUE. + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! + !! Local Parameters & variables + !! ----------------------------- #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - integer :: irng, iang - integer :: nd3 !* bin # corresp. to ww3 dep - real :: dep !* depth (m), get it from WW3 DEPTH - real :: wka(NK) !* from WW3 WN(1:NK) corresp. to "DEPTH" - real :: cga(NK) !* from WW3 CG(1:NK) corresp. to "DEPTH" - real :: pha(NK) !* k*dk*dtheta array corresp. to "DEPTH" - real :: fac !* twopi*oma()/cga() - real :: sum1 !* dummy variable -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! - integer :: npk !* bin# at peak frequency fpk - integer :: npk2 !* bin# of second peak frequency - integer :: npk0 !* dummy int. used in the shuffle of npk's - integer :: nsep !* min # of bins that separates npk & npk2 - !* set nsep = 2 - integer :: npeaks !* # of peaks (=0, 1, or 2) - integer :: nfs !* bin# of freq. separation -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! - integer :: nbins !* actual # of bins > npk (incl. nfs) or -!! !* actual # of bins > npk2 (incl. nrng) -!! !* to guarantee a min 1 bin in equi. range - real :: fpk !* peak frequency (Hz) - real :: fpk2 !* second peak frequency (Hz) - real :: e1max !* 1D energy at 1st peak 'fpk' - real :: e1max2 !* 1D energy at 2nd peak 'fpk2' - real :: sumd1 !* sum dens1+dens2 at nfs - real :: sumd2 !* sum dens1+dens2 at nfs+1 - real :: densat1 !* averaged dens1 at nfs - real :: densat2 !* averaged dens1 at nfs+1 -!! --------------------------------------------------------------- & -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! + integer :: irng, iang + integer :: nd3 !* bin # corresp. to ww3 dep + real :: dep !* depth (m), get it from WW3 DEPTH + real :: wka(NK) !* from WW3 WN(1:NK) corresp. to "DEPTH" + real :: cga(NK) !* from WW3 CG(1:NK) corresp. to "DEPTH" + real :: pha(NK) !* k*dk*dtheta array corresp. to "DEPTH" + real :: fac !* twopi*oma()/cga() + real :: sum1 !* dummy variable + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + integer :: npk !* bin# at peak frequency fpk + integer :: npk2 !* bin# of second peak frequency + integer :: npk0 !* dummy int. used in the shuffle of npk's + integer :: nsep !* min # of bins that separates npk & npk2 + !* set nsep = 2 + integer :: npeaks !* # of peaks (=0, 1, or 2) + integer :: nfs !* bin# of freq. separation + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + integer :: nbins !* actual # of bins > npk (incl. nfs) or + !! !* actual # of bins > npk2 (incl. nrng) + !! !* to guarantee a min 1 bin in equi. range + real :: fpk !* peak frequency (Hz) + real :: fpk2 !* second peak frequency (Hz) + real :: e1max !* 1D energy at 1st peak 'fpk' + real :: e1max2 !* 1D energy at 2nd peak 'fpk2' + real :: sumd1 !* sum dens1+dens2 at nfs + real :: sumd2 !* sum dens1+dens2 at nfs+1 + real :: densat1 !* averaged dens1 at nfs + real :: densat2 !* averaged dens1 at nfs+1 + !! --------------------------------------------------------------- & + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! #ifdef W3_S - CALL STRACE (IENT, 'W3SNL4') + CALL STRACE (IENT, 'W3SNL4') #endif -!! -!!ini -!! Initialization of the output arrays -!! before calling TSA subroutines. -!! ----------------------------------- - S(:,:) = 0.0 - D(:,:) = 0.0 -!!ini--- -!! ------------------------------------------------------------------ -!! ================================================================== -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!! - IF ( FIRST_TSA ) THEN -!! -!! -!!-0 Set parameters & constants -!! --------------------------- - nrng = NK !* nrng = NK must be odd <--- - nzz = (NK * (NK+1)) / 2 !* linear irng, krng - nang = NTH !* nang = NTH must be even <--- - na2p1 = nang/2 + 1 !* mid-angle or angle opposite to 1 - np2p1 = npts/2 + 1 !* mid-index of locus array - twopi = TPI !* twopi = 8.*atan(1.) - !* get it from WW3 TPI -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! -!!-1 Allocate freq & angle related array declared as PUBLIC - if ( allocated (frqa) ) deallocate (frqa) - if ( allocated (oma) ) deallocate (oma) - if ( allocated (angl) ) deallocate (angl) - if ( allocated (sinan) ) deallocate (sinan) - if ( allocated (cosan) ) deallocate (cosan) - if ( allocated (dep_tbl) ) deallocate (dep_tbl) - allocate(frqa(nrng)) - allocate(oma(nrng)) - allocate(angl(nang)) - allocate(sinan(nang)) - allocate(cosan(nang)) - allocate(dep_tbl(ndep)) -!! ---------------------------------------------------------------- -!! -!!-1a Initialize frequency arrays and related parameters -!! -------------------------------------------------- - oma(:) = SIG(1:NK) !* get it from WW3 SIG(1:NK) - frqa(:) = oma(:) / twopi - f0 = frqa(1) - dfrq = XFR !* WW3 freq mult. for log freq - !* get it from WW3 XFR -!! ---------------------------------------------------------------- -!! -!!-1b Initialize direction arrays and related parameters -!! -------------------------------------------------- - angl(:) = TH(1:NTH) !* get it from WW3 TH(1:NTH) - cosan(:) = ECOS(1:NTH) !* get it from WW3 ECOS(1:NTH) - sinan(:) = ESIN(1:NTH) !* get it from WW3 ESIN(1:NTH) - ainc = DTH !* WW3 angle increment (radians) - !* get it from WW3 DTH -!! ---------------------------------------------------------------- -!! -!!-1c Define kzone & nb2fp -!!kz -!! kzone = zone of freq influence, function of dfrq -!! for different values of x = 2,3,4 & 5 -!! So, kzone(x) = INT( alog(x)/alog(dfrq) ) -!! +--------+----------+----------+----------+----------+ -!! | dfrq | kzone(2) | kzone(3) | kzone(4) | kzone(5) | -!! +--------+----------+----------+----------+----------+ -!! | 1.05 | 14 | 22 | 28 | 33 | -!! +--------+----------+----------+----------+----------+ -!! | 1.07 | 10 | 16 | 20 | 24 | -!! +--------+----------+----------+----------+----------+ -!! | 1.10 | 7 | 11 | 14 | 17 | -!! +--------+----------+----------+----------+----------+ - kzone = INT( alog(2.0)/alog(dfrq) ) !* Bash; faster without loss of accuracy -!kz kzone = INT( alog(3.0)/alog(dfrq) ) !* as in gridsetr & snlr_'s -!kz kzone = INT( alog(4.0)/alog(dfrq) ) !* as in gridsetr & snlr_'s -!kz kzone = INT( alog(5.0)/alog(dfrq) ) !* as in gridsetr & snlr_'s -!!kz--- -!! -!!op2 -!! nb2fp = # of bins over fp (not incl. fp) - this depends on dfrq -!! so that (dfrq**nb2fp)*fp ~ 2.*fp (like kzone(2)) -!! used in 1 bin equi. range - nb2fp = INT( alog(2.0)/alog(dfrq) ) !* for equi. range near 2*fp -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - !!op2 -!! ================================================================ -!! -!! -!!-2 Allocate gridsetr 11 look-up tables arrays -!! plus pha_tbl array dim=(nrng,ndep) declared as PUBLIC - if ( allocated (kref2_tbl) ) deallocate (kref2_tbl) - if ( allocated (kref4_tbl) ) deallocate (kref4_tbl) - allocate(kref2_tbl(npts,nang,nzz,ndep)) - allocate(kref4_tbl(npts,nang,nzz,ndep)) -!! - if ( allocated (jref2_tbl) ) deallocate (jref2_tbl) - if ( allocated (jref4_tbl) ) deallocate (jref4_tbl) - allocate(jref2_tbl(npts,nang,nzz,ndep)) - allocate(jref4_tbl(npts,nang,nzz,ndep)) -!! - if ( allocated (wtk2_tbl) ) deallocate (wtk2_tbl) - if ( allocated (wtk4_tbl) ) deallocate (wtk4_tbl) - allocate(wtk2_tbl(npts,nang,nzz,ndep)) - allocate(wtk4_tbl(npts,nang,nzz,ndep)) -!! - if ( allocated (wta2_tbl) ) deallocate (wta2_tbl) - if ( allocated (wta4_tbl) ) deallocate (wta4_tbl) - allocate(wta2_tbl(npts,nang,nzz,ndep)) - allocate(wta4_tbl(npts,nang,nzz,ndep)) -!! - if ( allocated (tfac2_tbl) ) deallocate (tfac2_tbl) - if ( allocated (tfac4_tbl) ) deallocate (tfac4_tbl) - allocate(tfac2_tbl(npts,nang,nzz,ndep)) - allocate(tfac4_tbl(npts,nang,nzz,ndep)) -!! - if ( allocated (grad_tbl) ) deallocate (grad_tbl) - allocate(grad_tbl(npts,nang,nzz,ndep)) -!! - if ( allocated (pha_tbl) ) deallocate (pha_tbl) - allocate(pha_tbl(nrng,ndep)) -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! -!!-3 Allocate gridsetr 11 returned arrays declared as PUBLIC - if ( allocated (kref2) ) deallocate (kref2) - if ( allocated (kref4) ) deallocate (kref4) - allocate(kref2(npts,nang,nzz)) - allocate(kref4(npts,nang,nzz)) -!! - if ( allocated (jref2) ) deallocate (jref2) - if ( allocated (jref4) ) deallocate (jref4) - allocate(jref2(npts,nang,nzz)) - allocate(jref4(npts,nang,nzz)) -!! - if ( allocated (wtk2) ) deallocate (wtk2) - if ( allocated (wtk4) ) deallocate (wtk4) - allocate(wtk2(npts,nang,nzz)) - allocate(wtk4(npts,nang,nzz)) -!! - if ( allocated (wta2) ) deallocate (wta2) - if ( allocated (wta4) ) deallocate (wta4) - allocate(wta2(npts,nang,nzz)) - allocate(wta4(npts,nang,nzz)) -!! - if ( allocated (tfac2) ) deallocate (tfac2) - if ( allocated (tfac4) ) deallocate (tfac4) - allocate(tfac2(npts,nang,nzz)) - allocate(tfac4(npts,nang,nzz)) -!! - if ( allocated (grad) ) deallocate (grad) - allocate(grad(npts,nang,nzz)) -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! -!!-4 Allocate shloxr/shlocr 5 returned arrays declared as PUBLIC - if ( allocated (wk2x) ) deallocate (wk2x) - if ( allocated (wk2y) ) deallocate (wk2y) - allocate(wk2x(npts)) - allocate(wk2y(npts)) -!! - if ( allocated (wk4x) ) deallocate (wk4x) - if ( allocated (wk4y) ) deallocate (wk4y) - allocate(wk4x(npts)) - allocate(wk4y(npts)) -!! - if ( allocated (ds) ) deallocate (ds) - allocate(ds(npts)) -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! -!!-5 Allocate w3snlx/optsa2 2 shared arrays declared as PUBLIC - if ( allocated (ef2) ) deallocate (ef2) - if ( allocated (ef1) ) deallocate (ef1) - allocate(ef2(nrng,nang)) - allocate(ef1(nrng)) -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! -!!-6 Allocate optsa2 2 returned arrays declared as PUBLIC - if ( allocated (dens1) ) deallocate (dens1) - if ( allocated (dens2) ) deallocate (dens2) - allocate(dens1(nrng,nang)) - allocate(dens2(nrng,nang)) -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! -!!-7 Allocate snlr_??? 2 returned arrays declared as PUBLIC - if ( itsa .eq. 1) then -!! allocate tsa, diag used for -tsa - if ( allocated (tsa) ) deallocate (tsa) - if ( allocated (diag) ) deallocate (diag) - allocate(tsa(nrng,nang)) - allocate(diag(nrng,nang)) - elseif ( itsa .eq. 0) then -!! allocate fbi, diag2 used for -fbi - if ( allocated (fbi) ) deallocate (fbi) - if ( allocated (diag2) ) deallocate (diag2) - allocate(fbi(nrng,nang)) - allocate(diag2(nrng,nang)) - else - write ( ndse,1000 ) itsa - CALL EXTCDE ( 115 ) - endif -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! -!!-8 Get the 11 look-up table arrays by calling INSNL4 -!! ---------------------------------------------------------------- -!! -!! ---------------------------------------------------------------- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call INSNL4 -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! it returns: 11 look-up tables arrays dim=(npts,nang,nzz,ndep) -!! kref2_tbl, kref4_tbl, jref2_tbl, jref4_tbl, -!! wtk2_tbl, wtk4_tbl, wta2_tbl, wta4_tbl, -!! tfac2_tbl, tfac4_tbl & grad_tbl -!! plus pha_tbl dim=(nrng,ndep) -!! and dep_tbl dim=(ndep) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! - FIRST_TSA = .FALSE. -!! -!! - ENDIF !! IF ( FIRST_TSA ) THEN -!! ------------------------------------------------------------------ -!! ================================================================== -!! ################################################################## -!! -!! -!! -!!*i1 Map input ww3 "DEPTH" to "dep" and find corresp. depth bin # "nd3" -!! ------------------------------------------------------------------ - dep = DEPTH !* ww3 depth at a given time & loc. - nd3 = MINLOC( abs(dep - dep_tbl(:)), dim=1 ) -!prt print *, 'DEPTH, corresp depth bin # (nd3) = ', DEPTH, nd3 -!! ------------------------------------------------------------------ -!! -!! -!!*i2 Map from Look-up tables the 11 gridsetr arrays corresp. to "nd3" -!! kref2(:,:,:) -> grad(:,:,:) are used in subrs. "snlr_*" -!! ------------------------------------------------------------------ - kref2(:,:,:) = kref2_tbl(:,:,:,nd3) - kref4(:,:,:) = kref4_tbl(:,:,:,nd3) - jref2(:,:,:) = jref2_tbl(:,:,:,nd3) - jref4(:,:,:) = jref4_tbl(:,:,:,nd3) - wtk2(:,:,:) = wtk2_tbl(:,:,:,nd3) - wtk4(:,:,:) = wtk4_tbl(:,:,:,nd3) - wta2(:,:,:) = wta2_tbl(:,:,:,nd3) - wta4(:,:,:) = wta4_tbl(:,:,:,nd3) - tfac2(:,:,:) = tfac2_tbl(:,:,:,nd3) - tfac4(:,:,:) = tfac4_tbl(:,:,:,nd3) - grad(:,:,:) = grad_tbl(:,:,:,nd3) - pha(:) = pha_tbl(:,nd3) -!! ------------------------------------------------------------------ -!! -!! -!!*i3 Map input ww3 arrays "WN(:)" & "CG(:)" to "wka(:)" & "cga(:)" -!! Note; Arrays wka(:) & cga(:) corresp to ww3 "DEPTH" & to be used in "optsa2" -!! ------------------------------------------------------------------ - wka(:) = WN(1:NK) !* Wavenumber array at ww3 "DEPTH" - cga(:) = CG(1:NK) !* Group velocity array at ww3 "DEPTH" -!! ------------------------------------------------------------------ -!! -!! -!!*i4 Convert input WW3 2D Action Density spectrum "A(theta,k)" -!! to 2D Energy Density spectrum "ef2(theta,f)" & reverse indices -!! ==> ef2(f,theta) = A(theta,k) * 2*pi*oma(f)/cga(f) -!! ------------------------------------------------------------------ + !! + !!ini + !! Initialization of the output arrays + !! before calling TSA subroutines. + !! ----------------------------------- + S(:,:) = 0.0 + D(:,:) = 0.0 + !!ini--- + !! ------------------------------------------------------------------ + !! ================================================================== + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !! + IF ( FIRST_TSA ) THEN + !! + !! + !!-0 Set parameters & constants + !! --------------------------- + nrng = NK !* nrng = NK must be odd <--- + nzz = (NK * (NK+1)) / 2 !* linear irng, krng + nang = NTH !* nang = NTH must be even <--- + na2p1 = nang/2 + 1 !* mid-angle or angle opposite to 1 + np2p1 = npts/2 + 1 !* mid-index of locus array + twopi = TPI !* twopi = 8.*atan(1.) + !* get it from WW3 TPI + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + !!-1 Allocate freq & angle related array declared as PUBLIC + if ( allocated (frqa) ) deallocate (frqa) + if ( allocated (oma) ) deallocate (oma) + if ( allocated (angl) ) deallocate (angl) + if ( allocated (sinan) ) deallocate (sinan) + if ( allocated (cosan) ) deallocate (cosan) + if ( allocated (dep_tbl) ) deallocate (dep_tbl) + allocate(frqa(nrng)) + allocate(oma(nrng)) + allocate(angl(nang)) + allocate(sinan(nang)) + allocate(cosan(nang)) + allocate(dep_tbl(ndep)) + !! ---------------------------------------------------------------- + !! + !!-1a Initialize frequency arrays and related parameters + !! -------------------------------------------------- + oma(:) = SIG(1:NK) !* get it from WW3 SIG(1:NK) + frqa(:) = oma(:) / twopi + f0 = frqa(1) + dfrq = XFR !* WW3 freq mult. for log freq + !* get it from WW3 XFR + !! ---------------------------------------------------------------- + !! + !!-1b Initialize direction arrays and related parameters + !! -------------------------------------------------- + angl(:) = TH(1:NTH) !* get it from WW3 TH(1:NTH) + cosan(:) = ECOS(1:NTH) !* get it from WW3 ECOS(1:NTH) + sinan(:) = ESIN(1:NTH) !* get it from WW3 ESIN(1:NTH) + ainc = DTH !* WW3 angle increment (radians) + !* get it from WW3 DTH + !! ---------------------------------------------------------------- + !! + !!-1c Define kzone & nb2fp + !!kz + !! kzone = zone of freq influence, function of dfrq + !! for different values of x = 2,3,4 & 5 + !! So, kzone(x) = INT( alog(x)/alog(dfrq) ) + !! +--------+----------+----------+----------+----------+ + !! | dfrq | kzone(2) | kzone(3) | kzone(4) | kzone(5) | + !! +--------+----------+----------+----------+----------+ + !! | 1.05 | 14 | 22 | 28 | 33 | + !! +--------+----------+----------+----------+----------+ + !! | 1.07 | 10 | 16 | 20 | 24 | + !! +--------+----------+----------+----------+----------+ + !! | 1.10 | 7 | 11 | 14 | 17 | + !! +--------+----------+----------+----------+----------+ + kzone = INT( alog(2.0)/alog(dfrq) ) !* Bash; faster without loss of accuracy + !kz kzone = INT( alog(3.0)/alog(dfrq) ) !* as in gridsetr & snlr_'s + !kz kzone = INT( alog(4.0)/alog(dfrq) ) !* as in gridsetr & snlr_'s + !kz kzone = INT( alog(5.0)/alog(dfrq) ) !* as in gridsetr & snlr_'s + !!kz--- + !! + !!op2 + !! nb2fp = # of bins over fp (not incl. fp) - this depends on dfrq + !! so that (dfrq**nb2fp)*fp ~ 2.*fp (like kzone(2)) + !! used in 1 bin equi. range + nb2fp = INT( alog(2.0)/alog(dfrq) ) !* for equi. range near 2*fp + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - !!op2 + !! ================================================================ + !! + !! + !!-2 Allocate gridsetr 11 look-up tables arrays + !! plus pha_tbl array dim=(nrng,ndep) declared as PUBLIC + if ( allocated (kref2_tbl) ) deallocate (kref2_tbl) + if ( allocated (kref4_tbl) ) deallocate (kref4_tbl) + allocate(kref2_tbl(npts,nang,nzz,ndep)) + allocate(kref4_tbl(npts,nang,nzz,ndep)) + !! + if ( allocated (jref2_tbl) ) deallocate (jref2_tbl) + if ( allocated (jref4_tbl) ) deallocate (jref4_tbl) + allocate(jref2_tbl(npts,nang,nzz,ndep)) + allocate(jref4_tbl(npts,nang,nzz,ndep)) + !! + if ( allocated (wtk2_tbl) ) deallocate (wtk2_tbl) + if ( allocated (wtk4_tbl) ) deallocate (wtk4_tbl) + allocate(wtk2_tbl(npts,nang,nzz,ndep)) + allocate(wtk4_tbl(npts,nang,nzz,ndep)) + !! + if ( allocated (wta2_tbl) ) deallocate (wta2_tbl) + if ( allocated (wta4_tbl) ) deallocate (wta4_tbl) + allocate(wta2_tbl(npts,nang,nzz,ndep)) + allocate(wta4_tbl(npts,nang,nzz,ndep)) + !! + if ( allocated (tfac2_tbl) ) deallocate (tfac2_tbl) + if ( allocated (tfac4_tbl) ) deallocate (tfac4_tbl) + allocate(tfac2_tbl(npts,nang,nzz,ndep)) + allocate(tfac4_tbl(npts,nang,nzz,ndep)) + !! + if ( allocated (grad_tbl) ) deallocate (grad_tbl) + allocate(grad_tbl(npts,nang,nzz,ndep)) + !! + if ( allocated (pha_tbl) ) deallocate (pha_tbl) + allocate(pha_tbl(nrng,ndep)) + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + !!-3 Allocate gridsetr 11 returned arrays declared as PUBLIC + if ( allocated (kref2) ) deallocate (kref2) + if ( allocated (kref4) ) deallocate (kref4) + allocate(kref2(npts,nang,nzz)) + allocate(kref4(npts,nang,nzz)) + !! + if ( allocated (jref2) ) deallocate (jref2) + if ( allocated (jref4) ) deallocate (jref4) + allocate(jref2(npts,nang,nzz)) + allocate(jref4(npts,nang,nzz)) + !! + if ( allocated (wtk2) ) deallocate (wtk2) + if ( allocated (wtk4) ) deallocate (wtk4) + allocate(wtk2(npts,nang,nzz)) + allocate(wtk4(npts,nang,nzz)) + !! + if ( allocated (wta2) ) deallocate (wta2) + if ( allocated (wta4) ) deallocate (wta4) + allocate(wta2(npts,nang,nzz)) + allocate(wta4(npts,nang,nzz)) + !! + if ( allocated (tfac2) ) deallocate (tfac2) + if ( allocated (tfac4) ) deallocate (tfac4) + allocate(tfac2(npts,nang,nzz)) + allocate(tfac4(npts,nang,nzz)) + !! + if ( allocated (grad) ) deallocate (grad) + allocate(grad(npts,nang,nzz)) + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + !!-4 Allocate shloxr/shlocr 5 returned arrays declared as PUBLIC + if ( allocated (wk2x) ) deallocate (wk2x) + if ( allocated (wk2y) ) deallocate (wk2y) + allocate(wk2x(npts)) + allocate(wk2y(npts)) + !! + if ( allocated (wk4x) ) deallocate (wk4x) + if ( allocated (wk4y) ) deallocate (wk4y) + allocate(wk4x(npts)) + allocate(wk4y(npts)) + !! + if ( allocated (ds) ) deallocate (ds) + allocate(ds(npts)) + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + !!-5 Allocate w3snlx/optsa2 2 shared arrays declared as PUBLIC + if ( allocated (ef2) ) deallocate (ef2) + if ( allocated (ef1) ) deallocate (ef1) + allocate(ef2(nrng,nang)) + allocate(ef1(nrng)) + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + !!-6 Allocate optsa2 2 returned arrays declared as PUBLIC + if ( allocated (dens1) ) deallocate (dens1) + if ( allocated (dens2) ) deallocate (dens2) + allocate(dens1(nrng,nang)) + allocate(dens2(nrng,nang)) + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + !!-7 Allocate snlr_??? 2 returned arrays declared as PUBLIC + if ( itsa .eq. 1) then + !! allocate tsa, diag used for -tsa + if ( allocated (tsa) ) deallocate (tsa) + if ( allocated (diag) ) deallocate (diag) + allocate(tsa(nrng,nang)) + allocate(diag(nrng,nang)) + elseif ( itsa .eq. 0) then + !! allocate fbi, diag2 used for -fbi + if ( allocated (fbi) ) deallocate (fbi) + if ( allocated (diag2) ) deallocate (diag2) + allocate(fbi(nrng,nang)) + allocate(diag2(nrng,nang)) + else + write ( ndse,1000 ) itsa + CALL EXTCDE ( 115 ) + endif + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + !!-8 Get the 11 look-up table arrays by calling INSNL4 + !! ---------------------------------------------------------------- + !! + !! ---------------------------------------------------------------- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call INSNL4 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! it returns: 11 look-up tables arrays dim=(npts,nang,nzz,ndep) + !! kref2_tbl, kref4_tbl, jref2_tbl, jref4_tbl, + !! wtk2_tbl, wtk4_tbl, wta2_tbl, wta4_tbl, + !! tfac2_tbl, tfac4_tbl & grad_tbl + !! plus pha_tbl dim=(nrng,ndep) + !! and dep_tbl dim=(ndep) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + FIRST_TSA = .FALSE. + !! + !! + ENDIF !! IF ( FIRST_TSA ) THEN + !! ------------------------------------------------------------------ + !! ================================================================== + !! ################################################################## + !! + !! + !! + !!*i1 Map input ww3 "DEPTH" to "dep" and find corresp. depth bin # "nd3" + !! ------------------------------------------------------------------ + dep = DEPTH !* ww3 depth at a given time & loc. + nd3 = MINLOC( abs(dep - dep_tbl(:)), dim=1 ) + !prt print *, 'DEPTH, corresp depth bin # (nd3) = ', DEPTH, nd3 + !! ------------------------------------------------------------------ + !! + !! + !!*i2 Map from Look-up tables the 11 gridsetr arrays corresp. to "nd3" + !! kref2(:,:,:) -> grad(:,:,:) are used in subrs. "snlr_*" + !! ------------------------------------------------------------------ + kref2(:,:,:) = kref2_tbl(:,:,:,nd3) + kref4(:,:,:) = kref4_tbl(:,:,:,nd3) + jref2(:,:,:) = jref2_tbl(:,:,:,nd3) + jref4(:,:,:) = jref4_tbl(:,:,:,nd3) + wtk2(:,:,:) = wtk2_tbl(:,:,:,nd3) + wtk4(:,:,:) = wtk4_tbl(:,:,:,nd3) + wta2(:,:,:) = wta2_tbl(:,:,:,nd3) + wta4(:,:,:) = wta4_tbl(:,:,:,nd3) + tfac2(:,:,:) = tfac2_tbl(:,:,:,nd3) + tfac4(:,:,:) = tfac4_tbl(:,:,:,nd3) + grad(:,:,:) = grad_tbl(:,:,:,nd3) + pha(:) = pha_tbl(:,nd3) + !! ------------------------------------------------------------------ + !! + !! + !!*i3 Map input ww3 arrays "WN(:)" & "CG(:)" to "wka(:)" & "cga(:)" + !! Note; Arrays wka(:) & cga(:) corresp to ww3 "DEPTH" & to be used in "optsa2" + !! ------------------------------------------------------------------ + wka(:) = WN(1:NK) !* Wavenumber array at ww3 "DEPTH" + cga(:) = CG(1:NK) !* Group velocity array at ww3 "DEPTH" + !! ------------------------------------------------------------------ + !! + !! + !!*i4 Convert input WW3 2D Action Density spectrum "A(theta,k)" + !! to 2D Energy Density spectrum "ef2(theta,f)" & reverse indices + !! ==> ef2(f,theta) = A(theta,k) * 2*pi*oma(f)/cga(f) + !! ------------------------------------------------------------------ do irng=1,nrng - fac = twopi*oma(irng)/cga(irng) - do iang=1,nang - ef2(irng,iang) = A(iang,irng) * fac - end do + fac = twopi*oma(irng)/cga(irng) + do iang=1,nang + ef2(irng,iang) = A(iang,irng) * fac + end do end do -!! ------------------------------------------------------------------ -!! -!! -!!*i5 Calculte the 1D Energy Density "ef1(f)" -!! ------------------------------------------------------------------ + !! ------------------------------------------------------------------ + !! + !! + !!*i5 Calculte the 1D Energy Density "ef1(f)" + !! ------------------------------------------------------------------ do irng=1,nrng - sum1 = 0.0 - do iang=1,nang - sum1 = sum1 + ef2(irng,iang) - end do - ef1(irng) = sum1 * ainc + sum1 = 0.0 + do iang=1,nang + sum1 = sum1 + ef2(irng,iang) + end do + ef1(irng) = sum1 * ainc end do -!! ------------------------------------------------------------------ -!! ================================================================== -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!!op2 -!!* Bash; -!!* Find 1 or 2 peaks that satisfy TSA min condition (below) ------- * -!!* before calling TSA subrs. otherwise bailout (return) ----------- * -!!* Bailout & return with init. values of S & D = 0.0 -------------- * -!!* nsep = min # of bins that separates between npk & npk2 (set=2) * -!!* nbins = actual # of bins > npk (incl. nfs) -- or -- * -!!* actual # of bins > npk2 (incl. nrng) * -!!* to guarantee a min 1 bin in equi. range * -!!* * -!!* ===> In case of just 1 peak the TSA min condition ------------- * ***** -!!* ===> is relative to nrng and is satisfied when ---------------- * <<<<< -!!* ===> npk.le.nrng-1, to guarantee min 1 bin (incl nrng) > npk -- * <<<<< -!!* ===> we only need 1 bin in optsa2 to be in the equi. range ---- * <<<<< -!!* ===> skip if condition is not met ie if npk.gt.nrng-1 ------- * <<<<< -!!* ---------------------------------------------------------------- * -!!* * -!!* ===> In case of 2 peaks the TSA min condition is applied twice: * ***** -!!* ===> *1) at low freq peak (npk), *2) at high freq peak (npk2) * ***** -!!* ===> *1) TSA min condition for the low freq peak (npk) --------- * ***** -!!* ===> is relative to nfs and is satisfied when ----------------- * <<<<< -!!* ===> npk.le.nfs-1, to guarantee min 1 bin (incl nfs) > npk2 --- * <<<<< -!!* ===> we only need 1 bin in optsa2 to be in the equi. range ---- * <<<<< -!!* ===> skip if condition is not met ie if npk.gt.nfs-1 -------- * <<<<< -!!* * -!!* ===> *2) TSA min condition for the high freq peak (npk2) ------- * ***** -!!* ===> is relative to nrng and is satisfied when ---------------- * <<<<< -!!* ===> npk2.le.nrng-1 to guarantee min 1 bin (incl nrng) > npk2 * <<<<< -!!* ===> we only need 1 bin in optsa2 to be in the equi. range ---- * <<<<< -!!* ===> skip if condition is not met ie if npk2.gt.nrng-1 ------- * <<<<< -!!* ---------------------------------------------------------------- * -!! ------------------------------------------------------------ !!op2 -!! ================================================================== -!! -!!op2 ctd -!! First find the overall peak in ef1(:) with e1max must be > 0.000001 -!! Starting from low freq. find the Energy max "e1max" and -!! corresp. peak freq. "fpk" and its freq. number "npk". -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - npk = 0 - fpk = 0.0 - e1max = 0.0 - npeaks = 0 -!! Look in the freq range that works for TSA call (see condition below) + !! ------------------------------------------------------------------ + !! ================================================================== + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !!op2 + !!* Bash; + !!* Find 1 or 2 peaks that satisfy TSA min condition (below) ------- * + !!* before calling TSA subrs. otherwise bailout (return) ----------- * + !!* Bailout & return with init. values of S & D = 0.0 -------------- * + !!* nsep = min # of bins that separates between npk & npk2 (set=2) * + !!* nbins = actual # of bins > npk (incl. nfs) -- or -- * + !!* actual # of bins > npk2 (incl. nrng) * + !!* to guarantee a min 1 bin in equi. range * + !!* * + !!* ===> In case of just 1 peak the TSA min condition ------------- * ***** + !!* ===> is relative to nrng and is satisfied when ---------------- * <<<<< + !!* ===> npk.le.nrng-1, to guarantee min 1 bin (incl nrng) > npk -- * <<<<< + !!* ===> we only need 1 bin in optsa2 to be in the equi. range ---- * <<<<< + !!* ===> skip if condition is not met ie if npk.gt.nrng-1 ------- * <<<<< + !!* ---------------------------------------------------------------- * + !!* * + !!* ===> In case of 2 peaks the TSA min condition is applied twice: * ***** + !!* ===> *1) at low freq peak (npk), *2) at high freq peak (npk2) * ***** + !!* ===> *1) TSA min condition for the low freq peak (npk) --------- * ***** + !!* ===> is relative to nfs and is satisfied when ----------------- * <<<<< + !!* ===> npk.le.nfs-1, to guarantee min 1 bin (incl nfs) > npk2 --- * <<<<< + !!* ===> we only need 1 bin in optsa2 to be in the equi. range ---- * <<<<< + !!* ===> skip if condition is not met ie if npk.gt.nfs-1 -------- * <<<<< + !!* * + !!* ===> *2) TSA min condition for the high freq peak (npk2) ------- * ***** + !!* ===> is relative to nrng and is satisfied when ---------------- * <<<<< + !!* ===> npk2.le.nrng-1 to guarantee min 1 bin (incl nrng) > npk2 * <<<<< + !!* ===> we only need 1 bin in optsa2 to be in the equi. range ---- * <<<<< + !!* ===> skip if condition is not met ie if npk2.gt.nrng-1 ------- * <<<<< + !!* ---------------------------------------------------------------- * + !! ------------------------------------------------------------ !!op2 + !! ================================================================== + !! + !!op2 ctd + !! First find the overall peak in ef1(:) with e1max must be > 0.000001 + !! Starting from low freq. find the Energy max "e1max" and + !! corresp. peak freq. "fpk" and its freq. number "npk". + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + npk = 0 + fpk = 0.0 + e1max = 0.0 + npeaks = 0 + !! Look in the freq range that works for TSA call (see condition below) do irng=2,nrng-1 !* last peak loc. is at nrng-1 <<<<< -!! Pick the 1st local abs. max in [2,nrng-1] using (ef1(irng).gt.e1max) -!! so that if 2 equal adj. peaks are found it will pick the 1st e1max -!! encountered (i.e. the lower freq. one) -!! --------------------------------------------------------------!* <<<<< - if ( ef1(irng).gt.ef1(irng-1) .and. ef1(irng).gt.ef1(irng+1) & - .and. ef1(irng).gt.e1max ) then -!! --------------------------------------------------------------!* <<<<< - npk = irng !* update npk - fpk = frqa(npk) !* update fpk - e1max = ef1(npk) !* update e1max - npeaks = 1 - endif + !! Pick the 1st local abs. max in [2,nrng-1] using (ef1(irng).gt.e1max) + !! so that if 2 equal adj. peaks are found it will pick the 1st e1max + !! encountered (i.e. the lower freq. one) + !! --------------------------------------------------------------!* <<<<< + if ( ef1(irng).gt.ef1(irng-1) .and. ef1(irng).gt.ef1(irng+1) & + .and. ef1(irng).gt.e1max ) then + !! --------------------------------------------------------------!* <<<<< + npk = irng !* update npk + fpk = frqa(npk) !* update fpk + e1max = ef1(npk) !* update e1max + npeaks = 1 + endif end do -!! ------------------------------------------------------------------ -!! -!!B if a 1st peak is not found (npeaks=0 & e1max=0.0 < eps) or -!!B if a 1st peak is found with a tiny peak energy (e1max < eps) or -!!B if TSA min condition is not met rel. to nrng (npk.gt.nrng-1) <<<<< -!!B this spectrum is Not suitable for tsa, so don't call tsa -!!B just return (don't stop) with init. values of S(:,:) and D(:,:)=0.0 -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if ( e1max.lt.0.000001 ) return -!! ------------------------------------------------------------ !!op2 -!! ================================================================== -!! -!! -!!op2 ctd -!! Bash; if we are here (i.e. we did not return) then we must -!! have found the 1st good peak (= overall peak) with e1max > eps -!! -!! Now we look for a new 2nd peak that is at least 'nsep' bins away from -!! the 1st peak (nsep=2) (i.e. iabs(irng-npk).gt.nsep) before -!! calling new "optsa2" (the 2nd peak will have e1max2 < e1max) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nsep = 2 - npk2 = 0 - fpk2 = 0.0 - e1max2 = 0.0 -!! Again look in the freq range that is in line with TSA min condition -!! and find the 2nd highest peak with eps < e1max2 < e1max + !! ------------------------------------------------------------------ + !! + !!B if a 1st peak is not found (npeaks=0 & e1max=0.0 < eps) or + !!B if a 1st peak is found with a tiny peak energy (e1max < eps) or + !!B if TSA min condition is not met rel. to nrng (npk.gt.nrng-1) <<<<< + !!B this spectrum is Not suitable for tsa, so don't call tsa + !!B just return (don't stop) with init. values of S(:,:) and D(:,:)=0.0 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if ( e1max.lt.0.000001 ) return + !! ------------------------------------------------------------ !!op2 + !! ================================================================== + !! + !! + !!op2 ctd + !! Bash; if we are here (i.e. we did not return) then we must + !! have found the 1st good peak (= overall peak) with e1max > eps + !! + !! Now we look for a new 2nd peak that is at least 'nsep' bins away from + !! the 1st peak (nsep=2) (i.e. iabs(irng-npk).gt.nsep) before + !! calling new "optsa2" (the 2nd peak will have e1max2 < e1max) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + nsep = 2 + npk2 = 0 + fpk2 = 0.0 + e1max2 = 0.0 + !! Again look in the freq range that is in line with TSA min condition + !! and find the 2nd highest peak with eps < e1max2 < e1max do irng=2,nrng-1 !* last peak loc. is at nrng-1 <<<<< -!! Pick the 2nd local abs. max in [2,nrng-1] that is at least 'nsep' -!! bins away from the 1st peak using (ef1(irng).ge.e1max2) so that -!! if 2 equal adj. peaks are found it will pick the 2nd e1max2 -!! encountered (i.e. the higher freq. one) -!! --------------------------------------------------------------!* <<<<< - if ( ef1(irng).gt.ef1(irng-1) .and. ef1(irng).gt.ef1(irng+1) & - .and. ef1(irng).ge.e1max2 .and. iabs(irng-npk).gt.nsep ) then -!! --------------------------------------------------------------!* <<<<< - npk2 = irng !* update npk2 - fpk2 = frqa(npk2) !* update fpk2 - e1max2 = ef1(npk2) !* update e1max2 - npeaks = 2 - endif + !! Pick the 2nd local abs. max in [2,nrng-1] that is at least 'nsep' + !! bins away from the 1st peak using (ef1(irng).ge.e1max2) so that + !! if 2 equal adj. peaks are found it will pick the 2nd e1max2 + !! encountered (i.e. the higher freq. one) + !! --------------------------------------------------------------!* <<<<< + if ( ef1(irng).gt.ef1(irng-1) .and. ef1(irng).gt.ef1(irng+1) & + .and. ef1(irng).ge.e1max2 .and. iabs(irng-npk).gt.nsep ) then + !! --------------------------------------------------------------!* <<<<< + npk2 = irng !* update npk2 + fpk2 = frqa(npk2) !* update fpk2 + e1max2 = ef1(npk2) !* update e1max2 + npeaks = 2 + endif end do -!! ------------------------------------------------------------------ -!! -!!B if a 2nd peak is not found (npeaks=1 & e1max2=0.0 < eps) -!!B if a 2nd peak is found with a tiny peak energy (e1max2 < eps) or -!!B if TSA min condition is not met rel. to nrng (npk2.gt.nrng-1) <<<<< -!!B This 2nd peak is not suitable for tsa, drop it and stay with just 1st peak. - if ( e1max2.lt.0.000001 ) then - npeaks = 1 - goto 200 !* skip the remaings tests goto 200 + !! ------------------------------------------------------------------ + !! + !!B if a 2nd peak is not found (npeaks=1 & e1max2=0.0 < eps) + !!B if a 2nd peak is found with a tiny peak energy (e1max2 < eps) or + !!B if TSA min condition is not met rel. to nrng (npk2.gt.nrng-1) <<<<< + !!B This 2nd peak is not suitable for tsa, drop it and stay with just 1st peak. + if ( e1max2.lt.0.000001 ) then + npeaks = 1 + goto 200 !* skip the remaings tests goto 200 + endif + !! ------------------------------------------------------------ !!op2 + !! ================================================================== + !! + !! + !! + !! + !!op2 ctd + if ( npeaks.eq.2 ) then + !!-1 Shuffle the 2 peaks (if necessary) to keep npk to be always < npk2 + !! This says nothing about which peak is the dominant peak + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if ( npk2.lt.npk ) then + npk0 = npk2 + npk2 = npk + npk = npk0 !* this way npk < npk2 always + fpk = frqa(npk) + fpk2 = frqa(npk2) endif -!! ------------------------------------------------------------ !!op2 -!! ================================================================== -!! -!! -!! -!! -!!op2 ctd - if ( npeaks.eq.2 ) then -!!-1 Shuffle the 2 peaks (if necessary) to keep npk to be always < npk2 -!! This says nothing about which peak is the dominant peak -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if ( npk2.lt.npk ) then - npk0 = npk2 - npk2 = npk - npk = npk0 !* this way npk < npk2 always - fpk = frqa(npk) - fpk2 = frqa(npk2) - endif -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!!-2 here we have 2 peaks (npeaks=2) with npk < npk2 -!! find the freq. separation "nfs" (that divide the freq. regime into 2) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nfs = INT ( (npk+npk2) / 2.0 ) !* take the lower bin # to be nfs -!b nfs = INT ( (npk+npk2+1) / 2.0 ) !* take the higher bin # to be nfs -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - endif !! if ( npeaks.eq.2 ) -!! - 200 continue -!! ------------------------------------------------------------ !!op2 -!! ================================================================== -!! -!! -!! Bash; With the new "optsa2" you are allowed one call (if 1 peak) -!! or 2 calls (if 2 peaks) o account for spectra with double peaks. -!! Note; when nrmn=1 & nrmx=nrng ==> optsa2 = the old optsa -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! - if ( npeaks.eq.1 ) then -!!-1 one call to optsa2 for the whole freq. regime ( 1 --> nrng ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nbins = nrng - npk !* # of bins in (npk, nrng] not incl. npk - if ( nbins.gt.nb2fp ) nbins=nb2fp !* limit equi. range to ~2.0*fp -!! ---------------------------------------------------------------- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call optsa2 ( 1,nrng, npk, fpk, nbins, wka, cga ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! It returns variables dens1(nrng,nang) and dens2(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------------------------------------------------- - endif !! if ( npeaks.eq.1 ) -!! ================================================================== -!! -!! - if ( npeaks.eq.2 ) then -!! -!!-2 Now make two calls to new "optsa2" one for each freq regime. -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nbins = nfs - npk !* # of bins in (npk, nfs] not incl. npk - if ( nbins.gt.nb2fp ) nbins=nb2fp !* limit equi. range to ~2.0*fp -!! --------------------------------------------------------------- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call optsa2 ( 1,nfs, npk, fpk, nbins, wka, cga ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! It returns variables dens1(nrng,nang) and dens2(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------------------------------------------------- -!! - nbins = nrng - npk2 !* # of bins in (npk2, nrng] not incl. npk2 - if ( nbins.gt.nb2fp ) nbins=nb2fp !* limit equi. range to ~2.0*fp -!! ---------------------------------------------------------------- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call optsa2 ( nfs+1,nrng, npk2,fpk2, nbins, wka, cga ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! It returns variables dens1(nrng,nang) and dens2(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!!-3 Remove the step like jump (if exists) in dens1() between nfs & nfs+1 - do iang=1,nang - sumd1 = dens1(nfs,iang) + dens2(nfs,iang) !* sum at nfs - sumd2 = dens1(nfs+1,iang) + dens2(nfs+1,iang) !* sum at nfs+1 -!! -!! do 3 bin average for dens1() at nfs and store in densat1 - densat1 = ( dens1(nfs-1,iang) + dens1(nfs,iang) + & - dens1(nfs+1,iang) ) / 3. -!! do 3 bin average for dens1() at nfs+1 and store in densat2 - densat2 = ( dens1(nfs,iang) + dens1(nfs+1,iang) + & - dens1(nfs+2,iang) ) / 3. -!! -!! subtitute back into dens1(nfs,iang) & dens1(nfs+1,iang) - dens1(nfs,iang) = densat1 ! dens1 at nfs - dens1(nfs+1,iang) = densat2 ! dens1 at nfs+1 -!! -!! recalculate dens2(nfs,iang) & dens2(nfs+1,iang) - dens2(nfs,iang) = sumd1 - densat1 ! dens2 at nfs - dens2(nfs+1,iang) = sumd2 - densat2 ! dens2 at nfs+1 - end do -!! - endif !! if ( npeaks.eq.2 ) -!! ================================================================== -!! -!! -!! -!! -----------------------------------------------------------------# -!! ! -!! Get Snl source term and its diagonal term from "snlr" ! -!! for -tsa only use "snlr_tsa" itsa = 1 ! -!! for -fbi only use "snlr_fbi" itsa = 0 ! -!! ! -!! -----------------------------------------------------------------# -!! -!! - if ( itsa .eq. 1) then -!! -!! ---------------------------------------------------------------- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call snlr_tsa ( pha, ialt ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! It returns tsa(nrng,nang) & diag(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------------------------------------------------- -!! -!! Pack results in proper format ---------------------------------- * -!! S() & D() arrays are to be returned to WW3 in (k,theta) space - do irng=1,nrng - do iang=1,nang -!! Convert the Norm. (in k) Polar tsa(k,theta) to Polar S(theta,k) -!! and reverse indices back to (iang,irng) as in WW3 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !!-2 here we have 2 peaks (npeaks=2) with npk < npk2 + !! find the freq. separation "nfs" (that divide the freq. regime into 2) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + nfs = INT ( (npk+npk2) / 2.0 ) !* take the lower bin # to be nfs + !b nfs = INT ( (npk+npk2+1) / 2.0 ) !* take the higher bin # to be nfs + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + endif !! if ( npeaks.eq.2 ) + !! +200 continue + !! ------------------------------------------------------------ !!op2 + !! ================================================================== + !! + !! + !! Bash; With the new "optsa2" you are allowed one call (if 1 peak) + !! or 2 calls (if 2 peaks) o account for spectra with double peaks. + !! Note; when nrmn=1 & nrmx=nrng ==> optsa2 = the old optsa + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + if ( npeaks.eq.1 ) then + !!-1 one call to optsa2 for the whole freq. regime ( 1 --> nrng ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + nbins = nrng - npk !* # of bins in (npk, nrng] not incl. npk + if ( nbins.gt.nb2fp ) nbins=nb2fp !* limit equi. range to ~2.0*fp + !! ---------------------------------------------------------------- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call optsa2 ( 1,nrng, npk, fpk, nbins, wka, cga ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! It returns variables dens1(nrng,nang) and dens2(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------------------------------------------------- + endif !! if ( npeaks.eq.1 ) + !! ================================================================== + !! + !! + if ( npeaks.eq.2 ) then + !! + !!-2 Now make two calls to new "optsa2" one for each freq regime. + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + nbins = nfs - npk !* # of bins in (npk, nfs] not incl. npk + if ( nbins.gt.nb2fp ) nbins=nb2fp !* limit equi. range to ~2.0*fp + !! --------------------------------------------------------------- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call optsa2 ( 1,nfs, npk, fpk, nbins, wka, cga ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! It returns variables dens1(nrng,nang) and dens2(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------------------------------------------------- + !! + nbins = nrng - npk2 !* # of bins in (npk2, nrng] not incl. npk2 + if ( nbins.gt.nb2fp ) nbins=nb2fp !* limit equi. range to ~2.0*fp + !! ---------------------------------------------------------------- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call optsa2 ( nfs+1,nrng, npk2,fpk2, nbins, wka, cga ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! It returns variables dens1(nrng,nang) and dens2(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !!-3 Remove the step like jump (if exists) in dens1() between nfs & nfs+1 + do iang=1,nang + sumd1 = dens1(nfs,iang) + dens2(nfs,iang) !* sum at nfs + sumd2 = dens1(nfs+1,iang) + dens2(nfs+1,iang) !* sum at nfs+1 + !! + !! do 3 bin average for dens1() at nfs and store in densat1 + densat1 = ( dens1(nfs-1,iang) + dens1(nfs,iang) + & + dens1(nfs+1,iang) ) / 3. + !! do 3 bin average for dens1() at nfs+1 and store in densat2 + densat2 = ( dens1(nfs,iang) + dens1(nfs+1,iang) + & + dens1(nfs+2,iang) ) / 3. + !! + !! subtitute back into dens1(nfs,iang) & dens1(nfs+1,iang) + dens1(nfs,iang) = densat1 ! dens1 at nfs + dens1(nfs+1,iang) = densat2 ! dens1 at nfs+1 + !! + !! recalculate dens2(nfs,iang) & dens2(nfs+1,iang) + dens2(nfs,iang) = sumd1 - densat1 ! dens2 at nfs + dens2(nfs+1,iang) = sumd2 - densat2 ! dens2 at nfs+1 + end do + !! + endif !! if ( npeaks.eq.2 ) + !! ================================================================== + !! + !! + !! + !! -----------------------------------------------------------------# + !! ! + !! Get Snl source term and its diagonal term from "snlr" ! + !! for -tsa only use "snlr_tsa" itsa = 1 ! + !! for -fbi only use "snlr_fbi" itsa = 0 ! + !! ! + !! -----------------------------------------------------------------# + !! + !! + if ( itsa .eq. 1) then + !! + !! ---------------------------------------------------------------- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call snlr_tsa ( pha, ialt ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! It returns tsa(nrng,nang) & diag(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------------------------------------------------- + !! + !! Pack results in proper format ---------------------------------- * + !! S() & D() arrays are to be returned to WW3 in (k,theta) space + do irng=1,nrng + do iang=1,nang + !! Convert the Norm. (in k) Polar tsa(k,theta) to Polar S(theta,k) + !! and reverse indices back to (iang,irng) as in WW3 S(iang,irng) = tsa(irng,iang) * wka(irng) !* <============= D(iang,irng) = diag(irng,iang) -!! --------------------------- - end do - end do -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! - elseif ( itsa .eq. 0) then -!! -!! -!! ---------------------------------------------------------------- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call snlr_fbi ( pha, ialt ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! It returns fbi(nrng,nang) & diag2(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------------------------------------------------- -!! -!! Pack results in proper format ---------------------------------- * -!! S() & D() arrays are to be returned to WW3 in (k,theta) space - do irng=1,nrng - do iang=1,nang -!! Convert the Norm. (in k) Polar fbi(k,theta) to Polar S(theta,k) -!! and reverse indices back to (iang,irng) as in WW3 + !! --------------------------- + end do + end do + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! + elseif ( itsa .eq. 0) then + !! + !! + !! ---------------------------------------------------------------- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call snlr_fbi ( pha, ialt ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! It returns fbi(nrng,nang) & diag2(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------------------------------------------------- + !! + !! Pack results in proper format ---------------------------------- * + !! S() & D() arrays are to be returned to WW3 in (k,theta) space + do irng=1,nrng + do iang=1,nang + !! Convert the Norm. (in k) Polar fbi(k,theta) to Polar S(theta,k) + !! and reverse indices back to (iang,irng) as in WW3 S(iang,irng) = fbi(irng,iang) * wka(irng) !* <============= D(iang,irng) = diag2(irng,iang) -!! -------------------------------- - end do - end do -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! - else -!! - write( ndse,1000 ) itsa - CALL EXTCDE ( 130 ) -!! --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! - endif -!! ------------------------------------------------------------------ -!! ================================================================== -!! - RETURN -!! - 1000 format ( ' W3SNL4 Error : Bad itsa value ',i4) -!! - END SUBROUTINE W3SNL4 -!! -!!============================================================================== -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE gridsetr ( dep, wka1, cgnrng1 ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! ------------------------------------------------------------------ -!! -!! it returns: kref2,kref4, jref2,jref4, wtk2,wtk4, wta2,wta4, -!! tfac2,tfac4 and grad all dim=(npts,nang,nzz) -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!! 1. Purpose : -!! -!! -------------------------------------------------------------------------# -!! ! -!! This routine sets up the geometric part of the Boltzmann integral ! -!! based on a grid of wave frequencies and directions, with wave- ! -!! numbers related to frequency and depth by linear dispersion. It ! -!! is adapted from Don's original code with changes to modify the ! -!! indexing so there are fewer unused elements, and a number of algo- ! -!! rithmic changes that are mathematically equivalent to Don's but ! -!! take advantage of intrinsic functions to form smooth results with ! -!! less reliance on if statements. ! -!! ! -!! It calls locus-solving routines shloxr and shlocr and coupling ! -!! coefficient routine cplshr. If shlocr does not converge, ierr_gr ! -!! will be something other than 0 and the routine will terminate, ! -!! returning ierr_gr to the calling program (see shlocr). ! -!! ! -!! It returns array grad(,,), which is an estimate of the product ! -!! C(k1,k2,k3,k4)*H(k1,k3,k4)*ds/|dW/dn| (where n and the k's are all ! -!! vectors) as given, for example, by Eq.(7) of 'Nonlinear energy ! -!! fluxes and the finite depth equilibrium range in wave spectra,' ! -!! by Resio, Pihl, Tracy and Vincent (2001, JGR, 106(C4), p. 6985), ! -!! as well as arrays for indexing, interpolating and weighting locus- ! -!! based wavenumber vectors within the discrete solution grid. ! -!! -------------------------------------------------------------------------# -!! -!! -!! 2. Method : -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! nrng int. Public I # of freq. or rings -!! nang int. Public I # of angles -!! npts int. Public I # of points on the locus -!! nzz int. Public I linear irngxkrng = (NK*(NK+1))/2 -!! kzone int. Public I zone of influence = INT(alog(4.0)/alog(dfrq)) -!! na2p1 int. Public I = nang/2 + 1 -!! np2p1 int. Public I = npts/2 + 1 -!! ------------------------------------------------------------------ -!! -!! dfrq Real Public I frequency multiplier for log freq. spacing -!! f0 Real Public I = frqa(1); first freq. (Hz) -!! twopi Real Public I = TPI; WW3i 2*pi = 8.*atan(1.) (radians) -!! ainc Real Public I = DTH; WW3 angle increment (radians) -!! dep Real local I = depth (m) -!! frqa R.A. Public I = oma(:)/twopi WW3 frequency array dim=(nrng) -!! angl R.A. Public I = TH(1:NTH); WW3 angles array dim=(nang) -!! sinan R.A. Public I = ESIN(1:NTH); WW3 sin(angl(:)) array dim=(nang) -!! cosan R.A. Public I = ECOS(1:NTH); WW3 cos(angl(:)) array dim=(nang) -!! wka1 R.A. local I = wavenumber array at one depth dim=(nrng) -!! cgnrng1 Real local I = Group Vel. at nrng at one depth -!! ------------------------------------------------------------------ -!! -!! *** The 11 grid integration geometry arrays at one given depth -!! *** from gridsetr. dim=(npts,nang,nzz,ndep) -!! kref2 I.A. Public O Index of reference wavenumber for k2 -!! kref4 I.A. Public O Idem for k4 -!! jref2 I.A. Public O Index of reference angle for k2 -!! jref4 I.A. Public O Idem for k4 -!! wtk2 R.A. Public O k2 Interpolation weigth along wavenumbers -!! wtk4 R.A. Public O Idem for k4 -!! wta2 R.A. Public O k2 Interpolation weigth along angles -!! wta4 R.A. Public O Idem for k4 -!! tfac2 R.A. Public O Norm. for interp Action Density at k2 -!! tfac4 R.A. Public O Idem for k4 -!! grad R.A. Public O Coupling and gradient term in integral -!! grad = C * H * g**2 * ds / |dW/dn| -!! ------------------------------------------------------------------ -!! -!! 4. Subroutines used : -!! -!! Name Type Module Description -!! ------------------------------------------------------------------ -!! shloxr Subr. W3SERVMD General locus solution for input vectors -!! k1 & k3 when |k1| .eq. |k3| -!! shlocr Subr. W3SERVMD General locus solution for input vectors -!! k1 & k3 when |k1| .ne. |k3| -!! cplshr Subr. W3SERVMD Calculates Boltzmann coupling coefficient -!! in shallow water -!! ------------------------------------------------------------------ -!! -!! 5. Called by : -!! -!! Name Type Module Description -!! ------------------------------------------------------------------ -!! insnl4 Subr. W3SNL4MD initialize the grid geometry -!! ------------------------------------------------------------------ -!! -!! 6. Error messages : -!! -!! None. -!! -!! 7. Remarks : -!! -!! 8. Structure : -!! -!! See source code. -!! -!! 9. Switches : -!! -!! !/S Enable subroutine tracing. -!! -!!10. Source code : -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! - IMPLICIT NONE -!! -!! Parameter list -!! -------------- - real, intent(in) :: dep - real, intent(in) :: wka1(nrng), cgnrng1 !* Use new names locally -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! -!! -!! Local Parameters & variables -!! ----------------------------- - integer :: irng,krng, iang,kang, ipt - integer :: iizz, izz, ir, i - integer :: kmax !* = min(irng+kzone, nrng) -!! - real :: g, gsq - real :: alf0,aldfrq, wk1x,wk1y, wk3x,wk3y -!! - real :: wn2,th2, wn2d,tnh2, om2,f2,cg2, tt2,w2 - real :: wn4,th4, wn4d,tnh4, om4,f4,cg4, tt4,w4 - real :: dWdnsq,dWdn, dif13,dif14, er -!! -!!hv Bash; with !hv ON, move Heaviside section up & don't use var Heaviside -!hv real :: Heaviside -!!hv--- -!! - real :: csq -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!! initial constants -!! ------------------ - g = 9.806 !* set = GRAV as in CONSTANTS - gsq = 96.157636 !* set = GRAV**2 -!! - alf0 = alog(frqa(1)) !* ln(f0) for ir calc. below - aldfrq = alog(dfrq) !* ln(dfrq) " -!! -!!ini -!! initialize array grad -!! ---------------------- - grad(:,:,:) = 0.0 - kref2(:,:,:) = 0 - kref4(:,:,:) = 0 - jref2(:,:,:) = 0 - jref4(:,:,:) = 0 - wtk2(:,:,:) = 0.0 - wtk4(:,:,:) = 0.0 - wta2(:,:,:) = 0.0 - wta4(:,:,:) = 0.0 - tfac2(:,:,:) = 0.0 - tfac4(:,:,:) = 0.0 -!!ini--- -!!------------------------------------------------------------------------------ -!! -!! -!! irng and iang are k1 parameters; krng and kang are k3 parameters - iang = 1 !* set = 1 and will remain = 1 -!! -!!20 - do 20 irng=1,nrng -!!kz - kmax = min(irng+kzone, nrng) !* Bash; Sometimes a locus pt is outside nrng -!kz kmax = min(irng+kzone, nrng-1) !* Bash; Taking 1 out will not affect kzone, try it -!!kz--- -!!kz--- -!! - wk1x = wka1(irng) - wk1y = 0.0 !* set = 0.0 and will remain = 0.0 - iizz = (nrng-1)*(irng-1)-((irng-2)*(irng-1))/2 -!!30 -!!kz - do 30 krng=irng,kmax -!!kz--- -!kz do 30 krng=irng,nrng -!! -!! Bash; check1 - change this ratio from > 4 to > 3 and -!! make it consistent with similar test done in subr. snlr_'s -!kz if ( frqa(krng)/frqa(irng) .gt. 2. ) go to 30 !* Bash; use .gt. 2 for speed -!kz if ( frqa(krng)/frqa(irng) .gt. 3. ) go to 30 !* original snlr_'s -!kz if ( frqa(krng)/frqa(irng) .gt. 4. ) go to 30 !* original gridsetr -!!kz--- - izz = krng+iizz -!!40 - do 40 kang=1,nang -!! - wk3x = wka1(krng)*cosan(kang) - wk3y = wka1(krng)*sinan(kang) -!! - if ( krng.eq.irng ) then !* wn3 = wn1 -!! -!!ba1 Bash; skip k1 but keep the opposite angle to k1 - orig setting -!!ba1 remember here iang = 1 - if ( kang .eq. 1 ) go to 40 !* th3 = th1 -!!ba1--- -!! ---------------------------------------------------------- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call shloxr ( dep, wk1x,wk1y,wk3x,wk3y ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! it returns: wk2x, wk2y, wk4x, wk4y & ds all dim=(npts) -!! and all are PUBLIC -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------------------------------------------- -!! - else !* wn3 > wn1 -!! -!! ---------------------------------------------------------- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call shlocr ( dep, wk1x,wk1y,wk3x,wk3y ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! it returns: wk2x, wk2y, wk4x, wk4y & ds all dim=(npts) -!! and all are PUBLIC -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------------------------------------------- -!! - end if !! if ( krng.eq.irng ) -!! -!! set the Heaviside coefficient -!b dif13 = (wk1x-wk3x)**2 + (wk1y-wk3y)**2 !* wk1y = 0.0 -!b dif13 = (wk1x-wk3x)**2 + (wk3y)**2 - dif13 = (wk1x-wk3x)*(wk1x-wk3x) + wk3y*wk3y -!!50 - do 50 ipt=1,npts -!! -!!xlc1 Bash; skip k1 but keep the opposite angle to k1 - original setting - if ( kang.eq.1 ) then !* th3=+th1, iang=1 - if (ipt.eq.1 .or. ipt.eq.np2p1) go to 50 !* skip x-axis loci - end if -!!xlc1--- -!! ---------------------------------------------------------- -!! -!!hv Bash; with !hv ON, move Heaviside section from below to here -!! Bash moved this section here. *** Check first compute after *** -!! Skip first then compute only if Heaviside=1, without using it -!! i.e. compute only if dif13.le.dif14 with Heaviside=1 omitted. -!! Note; with !hv option is ON, you don't need to turn options -!! ---- !k19p1 nor !cp4 ON.aYou only need one of the three. -!! ---------------------------------------------------------- -!! set the Heaviside coefficient -!b dif14 = (wk1x-wk4x(ipt))**2 + (wk1y-wk4y(ipt))**2 !* wk1y=0.0 -!b dif14 = (wk1x-wk4x(ipt))**2 + (wk4y(ipt))**2 - dif14 = (wk1x-wk4x(ipt))*(wk1x-wk4x(ipt)) + & - wk4y(ipt)*wk4y(ipt) -!! - if ( dif13 .gt. dif14 ) go to 50 !* skip, don't compute -!! -!b if ( dif13 .gt. dif14 ) then -!b Heaviside = 0. !* Eq(12) of RPTV -!b go to 50 -!b else -!b Heaviside = 1. !* Eq(11) of RPTV -!b end if -!!hv--- -!! ---------------------------------------------------------- -!! -!! Set the coupling coefficient for ipt'th locus position -!! ---------------------------------------------------------- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call cplshr ( wk4x(ipt),wk4y(ipt), wk3x,wk3y, & - wk2x(ipt),wk2y(ipt), dep, csq, & - irng,krng,kang,ipt ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! it returns: the coupling coefficient csq -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------------------------------------------- -!! -!!wn2 Set parameters related to ipt'th locus wavenumber vector k2 -!! ---------------------------------------------------------- -!b wn2 = sqrt(wk2x(ipt)**2 + wk2y(ipt)**2) !* k2 - wn2 = sqrt(wk2x(ipt)*wk2x(ipt) + wk2y(ipt)*wk2y(ipt)) !* k2 - th2 = atan2(wk2y(ipt),wk2x(ipt)) !* k2 direction - if ( th2 .lt. 0. ) th2 = th2 + twopi !* +ve in radians - wn2d = wn2*dep !* k2*depth - tnh2 = tanh(wn2d) !* tanh(k2*depth) - om2 = sqrt(g*wn2*tnh2) !* omega2 (rad) -!b cg2 = 0.5*(om2/wn2)*(1.+wn2d*(1.-tnh2**2)/tnh2) !* group velocity - cg2 = 0.5*(om2/wn2)*(1.+wn2d*((1./tnh2)-tnh2)) !* group velocity - f2 = om2/twopi !* f2 (Hz) -!! ---------------------------------------------------------- -!! -!!wn4 Set parameters related to ipt'th locus wavenumber vector k4 -!! ---------------------------------------------------------- -!b wn4 = sqrt(wk4x(ipt)**2 + wk4y(ipt)**2) - wn4 = sqrt(wk4x(ipt)*wk4x(ipt) + wk4y(ipt)*wk4y(ipt)) - th4 = atan2(wk4y(ipt),wk4x(ipt)) - if ( th4 .lt. 0. ) th4 = th4 + twopi - wn4d = wn4*dep - tnh4 = tanh(wn4d) - om4 = sqrt(g*wn4*tnh4) -!b cg4 = 0.5*(om4/wn4)*(1.+wn4d*(1.-tnh4**2)/tnh4) - cg4 = 0.5*(om4/wn4)*(1.+wn4d*((1./tnh4)-tnh4)) - f4 = om4/twopi -!! ---------------------------------------------------------- -!! -!! -!!hv Bash; with !hv ON, move Heaviside section up -!! Bash moved this section up. Check first compute after. -!! ---------------------------------------------------------- -!! set the Heaviside coefficient -!b dif14 = (wk1x-wk4x(ipt))**2 + (wk1y-wk4y(ipt))**2 !* wk1y=0.0 -!b dif14 = (wk1x-wk4x(ipt))**2 + (wk4y(ipt))**2 -!hv dif14 = (wk1x-wk4x(ipt))*(wk1x-wk4x(ipt)) + & -!hv wk4y(ipt)*wk4y(ipt) -!hv if ( dif13 .gt. dif14 ) then -!hv Heaviside = 0. !* Eq(12) of RPTV -!hv else -!hv Heaviside = 1. !* Eq(11) of RPTV -!hv end if -!!hv--- -!! ---------------------------------------------------------- -!! -!! -!! dWdn is the same as sqrt(zzsum) in Don's code, here reduced to a -!! simpler but mathematically equivalent form that should vary -!! smoothly between deep and intermediate water owing to identities -!! using the computer's tanh() function -!! ---------------------------------------------------------- -!! -!! set grad(,,); -!! looks like the g^2 goes with csq (Webb'1978, eq. A2) -!! ---------------------------------------------------------- -!! -!b dWdnsq = cg2**2 - 2.*cg2*cg4 * cos(th2-th4) + cg4**2 - dWdnsq = cg2*cg2 - 2.*cg2*cg4 * cos(th2-th4) + cg4*cg4 -!! ---------------------------------------------------------- -!! - dWdn = sqrt(dWdnsq) -!! ---------------------------------------------------------- -!! -!!hv Bash; with !hv ON, don't use var Heaviside (by here it's = 1.0) - grad(ipt,kang,izz) = ds(ipt)*csq*gsq/dWdn -!!hv--- -!hv grad(ipt,kang,izz) = Heaviside*ds(ipt)*csq*gsq/dWdn -!!hv--- -!! ---------------------------------------------------------- -!! ========================================================== -!! -!! -!! Set interpolation, indexing and weight parameters for -!! computations along wavenumber radials -!! ---------------------------------------------------------- -!! -!!f2 -------------------- - if ( f2 .lt. f0 ) then - wtk2(ipt,kang,izz) = 1. - tfac2(ipt,kang,izz) = 0. - kref2(ipt,kang,izz) = 1 + !! -------------------------------- + end do + end do + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + else + !! + write( ndse,1000 ) itsa + CALL EXTCDE ( 130 ) + !! --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + endif + !! ------------------------------------------------------------------ + !! ================================================================== + !! + RETURN + !! +1000 format ( ' W3SNL4 Error : Bad itsa value ',i4) + !! + END SUBROUTINE W3SNL4 + !! + !!============================================================================== + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + SUBROUTINE gridsetr ( dep, wka1, cgnrng1 ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! ------------------------------------------------------------------ + !! + !! it returns: kref2,kref4, jref2,jref4, wtk2,wtk4, wta2,wta4, + !! tfac2,tfac4 and grad all dim=(npts,nang,nzz) + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !! 1. Purpose : + !! + !! -------------------------------------------------------------------------# + !! ! + !! This routine sets up the geometric part of the Boltzmann integral ! + !! based on a grid of wave frequencies and directions, with wave- ! + !! numbers related to frequency and depth by linear dispersion. It ! + !! is adapted from Don's original code with changes to modify the ! + !! indexing so there are fewer unused elements, and a number of algo- ! + !! rithmic changes that are mathematically equivalent to Don's but ! + !! take advantage of intrinsic functions to form smooth results with ! + !! less reliance on if statements. ! + !! ! + !! It calls locus-solving routines shloxr and shlocr and coupling ! + !! coefficient routine cplshr. If shlocr does not converge, ierr_gr ! + !! will be something other than 0 and the routine will terminate, ! + !! returning ierr_gr to the calling program (see shlocr). ! + !! ! + !! It returns array grad(,,), which is an estimate of the product ! + !! C(k1,k2,k3,k4)*H(k1,k3,k4)*ds/|dW/dn| (where n and the k's are all ! + !! vectors) as given, for example, by Eq.(7) of 'Nonlinear energy ! + !! fluxes and the finite depth equilibrium range in wave spectra,' ! + !! by Resio, Pihl, Tracy and Vincent (2001, JGR, 106(C4), p. 6985), ! + !! as well as arrays for indexing, interpolating and weighting locus- ! + !! based wavenumber vectors within the discrete solution grid. ! + !! -------------------------------------------------------------------------# + !! + !! + !! 2. Method : + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! nrng int. Public I # of freq. or rings + !! nang int. Public I # of angles + !! npts int. Public I # of points on the locus + !! nzz int. Public I linear irngxkrng = (NK*(NK+1))/2 + !! kzone int. Public I zone of influence = INT(alog(4.0)/alog(dfrq)) + !! na2p1 int. Public I = nang/2 + 1 + !! np2p1 int. Public I = npts/2 + 1 + !! ------------------------------------------------------------------ + !! + !! dfrq Real Public I frequency multiplier for log freq. spacing + !! f0 Real Public I = frqa(1); first freq. (Hz) + !! twopi Real Public I = TPI; WW3i 2*pi = 8.*atan(1.) (radians) + !! ainc Real Public I = DTH; WW3 angle increment (radians) + !! dep Real local I = depth (m) + !! frqa R.A. Public I = oma(:)/twopi WW3 frequency array dim=(nrng) + !! angl R.A. Public I = TH(1:NTH); WW3 angles array dim=(nang) + !! sinan R.A. Public I = ESIN(1:NTH); WW3 sin(angl(:)) array dim=(nang) + !! cosan R.A. Public I = ECOS(1:NTH); WW3 cos(angl(:)) array dim=(nang) + !! wka1 R.A. local I = wavenumber array at one depth dim=(nrng) + !! cgnrng1 Real local I = Group Vel. at nrng at one depth + !! ------------------------------------------------------------------ + !! + !! *** The 11 grid integration geometry arrays at one given depth + !! *** from gridsetr. dim=(npts,nang,nzz,ndep) + !! kref2 I.A. Public O Index of reference wavenumber for k2 + !! kref4 I.A. Public O Idem for k4 + !! jref2 I.A. Public O Index of reference angle for k2 + !! jref4 I.A. Public O Idem for k4 + !! wtk2 R.A. Public O k2 Interpolation weigth along wavenumbers + !! wtk4 R.A. Public O Idem for k4 + !! wta2 R.A. Public O k2 Interpolation weigth along angles + !! wta4 R.A. Public O Idem for k4 + !! tfac2 R.A. Public O Norm. for interp Action Density at k2 + !! tfac4 R.A. Public O Idem for k4 + !! grad R.A. Public O Coupling and gradient term in integral + !! grad = C * H * g**2 * ds / |dW/dn| + !! ------------------------------------------------------------------ + !! + !! 4. Subroutines used : + !! + !! Name Type Module Description + !! ------------------------------------------------------------------ + !! shloxr Subr. W3SERVMD General locus solution for input vectors + !! k1 & k3 when |k1| .eq. |k3| + !! shlocr Subr. W3SERVMD General locus solution for input vectors + !! k1 & k3 when |k1| .ne. |k3| + !! cplshr Subr. W3SERVMD Calculates Boltzmann coupling coefficient + !! in shallow water + !! ------------------------------------------------------------------ + !! + !! 5. Called by : + !! + !! Name Type Module Description + !! ------------------------------------------------------------------ + !! insnl4 Subr. W3SNL4MD initialize the grid geometry + !! ------------------------------------------------------------------ + !! + !! 6. Error messages : + !! + !! None. + !! + !! 7. Remarks : + !! + !! 8. Structure : + !! + !! See source code. + !! + !! 9. Switches : + !! + !! !/S Enable subroutine tracing. + !! + !!10. Source code : + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + IMPLICIT NONE + !! + !! Parameter list + !! -------------- + real, intent(in) :: dep + real, intent(in) :: wka1(nrng), cgnrng1 !* Use new names locally + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! + !! + !! Local Parameters & variables + !! ----------------------------- + integer :: irng,krng, iang,kang, ipt + integer :: iizz, izz, ir, i + integer :: kmax !* = min(irng+kzone, nrng) + !! + real :: g, gsq + real :: alf0,aldfrq, wk1x,wk1y, wk3x,wk3y + !! + real :: wn2,th2, wn2d,tnh2, om2,f2,cg2, tt2,w2 + real :: wn4,th4, wn4d,tnh4, om4,f4,cg4, tt4,w4 + real :: dWdnsq,dWdn, dif13,dif14, er + !! + !!hv Bash; with !hv ON, move Heaviside section up & don't use var Heaviside + !hv real :: Heaviside + !!hv--- + !! + real :: csq + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !! initial constants + !! ------------------ + g = 9.806 !* set = GRAV as in CONSTANTS + gsq = 96.157636 !* set = GRAV**2 + !! + alf0 = alog(frqa(1)) !* ln(f0) for ir calc. below + aldfrq = alog(dfrq) !* ln(dfrq) " + !! + !!ini + !! initialize array grad + !! ---------------------- + grad(:,:,:) = 0.0 + kref2(:,:,:) = 0 + kref4(:,:,:) = 0 + jref2(:,:,:) = 0 + jref4(:,:,:) = 0 + wtk2(:,:,:) = 0.0 + wtk4(:,:,:) = 0.0 + wta2(:,:,:) = 0.0 + wta4(:,:,:) = 0.0 + tfac2(:,:,:) = 0.0 + tfac4(:,:,:) = 0.0 + !!ini--- + !!------------------------------------------------------------------------------ + !! + !! + !! irng and iang are k1 parameters; krng and kang are k3 parameters + iang = 1 !* set = 1 and will remain = 1 + !! + !!20 + do 20 irng=1,nrng + !!kz + kmax = min(irng+kzone, nrng) !* Bash; Sometimes a locus pt is outside nrng + !kz kmax = min(irng+kzone, nrng-1) !* Bash; Taking 1 out will not affect kzone, try it + !!kz--- + !!kz--- + !! + wk1x = wka1(irng) + wk1y = 0.0 !* set = 0.0 and will remain = 0.0 + iizz = (nrng-1)*(irng-1)-((irng-2)*(irng-1))/2 + !!30 + !!kz + do 30 krng=irng,kmax + !!kz--- + !kz do 30 krng=irng,nrng + !! + !! Bash; check1 - change this ratio from > 4 to > 3 and + !! make it consistent with similar test done in subr. snlr_'s + !kz if ( frqa(krng)/frqa(irng) .gt. 2. ) go to 30 !* Bash; use .gt. 2 for speed + !kz if ( frqa(krng)/frqa(irng) .gt. 3. ) go to 30 !* original snlr_'s + !kz if ( frqa(krng)/frqa(irng) .gt. 4. ) go to 30 !* original gridsetr + !!kz--- + izz = krng+iizz + !!40 + do 40 kang=1,nang + !! + wk3x = wka1(krng)*cosan(kang) + wk3y = wka1(krng)*sinan(kang) + !! + if ( krng.eq.irng ) then !* wn3 = wn1 + !! + !!ba1 Bash; skip k1 but keep the opposite angle to k1 - orig setting + !!ba1 remember here iang = 1 + if ( kang .eq. 1 ) go to 40 !* th3 = th1 + !!ba1--- + !! ---------------------------------------------------------- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call shloxr ( dep, wk1x,wk1y,wk3x,wk3y ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! it returns: wk2x, wk2y, wk4x, wk4y & ds all dim=(npts) + !! and all are PUBLIC + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------------------------------------------- + !! + else !* wn3 > wn1 + !! + !! ---------------------------------------------------------- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call shlocr ( dep, wk1x,wk1y,wk3x,wk3y ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! it returns: wk2x, wk2y, wk4x, wk4y & ds all dim=(npts) + !! and all are PUBLIC + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------------------------------------------- + !! + end if !! if ( krng.eq.irng ) + !! + !! set the Heaviside coefficient + !b dif13 = (wk1x-wk3x)**2 + (wk1y-wk3y)**2 !* wk1y = 0.0 + !b dif13 = (wk1x-wk3x)**2 + (wk3y)**2 + dif13 = (wk1x-wk3x)*(wk1x-wk3x) + wk3y*wk3y + !!50 + do 50 ipt=1,npts + !! + !!xlc1 Bash; skip k1 but keep the opposite angle to k1 - original setting + if ( kang.eq.1 ) then !* th3=+th1, iang=1 + if (ipt.eq.1 .or. ipt.eq.np2p1) go to 50 !* skip x-axis loci + end if + !!xlc1--- + !! ---------------------------------------------------------- + !! + !!hv Bash; with !hv ON, move Heaviside section from below to here + !! Bash moved this section here. *** Check first compute after *** + !! Skip first then compute only if Heaviside=1, without using it + !! i.e. compute only if dif13.le.dif14 with Heaviside=1 omitted. + !! Note; with !hv option is ON, you don't need to turn options + !! ---- !k19p1 nor !cp4 ON.aYou only need one of the three. + !! ---------------------------------------------------------- + !! set the Heaviside coefficient + !b dif14 = (wk1x-wk4x(ipt))**2 + (wk1y-wk4y(ipt))**2 !* wk1y=0.0 + !b dif14 = (wk1x-wk4x(ipt))**2 + (wk4y(ipt))**2 + dif14 = (wk1x-wk4x(ipt))*(wk1x-wk4x(ipt)) + & + wk4y(ipt)*wk4y(ipt) + !! + if ( dif13 .gt. dif14 ) go to 50 !* skip, don't compute + !! + !b if ( dif13 .gt. dif14 ) then + !b Heaviside = 0. !* Eq(12) of RPTV + !b go to 50 + !b else + !b Heaviside = 1. !* Eq(11) of RPTV + !b end if + !!hv--- + !! ---------------------------------------------------------- + !! + !! Set the coupling coefficient for ipt'th locus position + !! ---------------------------------------------------------- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call cplshr ( wk4x(ipt),wk4y(ipt), wk3x,wk3y, & + wk2x(ipt),wk2y(ipt), dep, csq, & + irng,krng,kang,ipt ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! it returns: the coupling coefficient csq + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------------------------------------------- + !! + !!wn2 Set parameters related to ipt'th locus wavenumber vector k2 + !! ---------------------------------------------------------- + !b wn2 = sqrt(wk2x(ipt)**2 + wk2y(ipt)**2) !* k2 + wn2 = sqrt(wk2x(ipt)*wk2x(ipt) + wk2y(ipt)*wk2y(ipt)) !* k2 + th2 = atan2(wk2y(ipt),wk2x(ipt)) !* k2 direction + if ( th2 .lt. 0. ) th2 = th2 + twopi !* +ve in radians + wn2d = wn2*dep !* k2*depth + tnh2 = tanh(wn2d) !* tanh(k2*depth) + om2 = sqrt(g*wn2*tnh2) !* omega2 (rad) + !b cg2 = 0.5*(om2/wn2)*(1.+wn2d*(1.-tnh2**2)/tnh2) !* group velocity + cg2 = 0.5*(om2/wn2)*(1.+wn2d*((1./tnh2)-tnh2)) !* group velocity + f2 = om2/twopi !* f2 (Hz) + !! ---------------------------------------------------------- + !! + !!wn4 Set parameters related to ipt'th locus wavenumber vector k4 + !! ---------------------------------------------------------- + !b wn4 = sqrt(wk4x(ipt)**2 + wk4y(ipt)**2) + wn4 = sqrt(wk4x(ipt)*wk4x(ipt) + wk4y(ipt)*wk4y(ipt)) + th4 = atan2(wk4y(ipt),wk4x(ipt)) + if ( th4 .lt. 0. ) th4 = th4 + twopi + wn4d = wn4*dep + tnh4 = tanh(wn4d) + om4 = sqrt(g*wn4*tnh4) + !b cg4 = 0.5*(om4/wn4)*(1.+wn4d*(1.-tnh4**2)/tnh4) + cg4 = 0.5*(om4/wn4)*(1.+wn4d*((1./tnh4)-tnh4)) + f4 = om4/twopi + !! ---------------------------------------------------------- + !! + !! + !!hv Bash; with !hv ON, move Heaviside section up + !! Bash moved this section up. Check first compute after. + !! ---------------------------------------------------------- + !! set the Heaviside coefficient + !b dif14 = (wk1x-wk4x(ipt))**2 + (wk1y-wk4y(ipt))**2 !* wk1y=0.0 + !b dif14 = (wk1x-wk4x(ipt))**2 + (wk4y(ipt))**2 + !hv dif14 = (wk1x-wk4x(ipt))*(wk1x-wk4x(ipt)) + & + !hv wk4y(ipt)*wk4y(ipt) + !hv if ( dif13 .gt. dif14 ) then + !hv Heaviside = 0. !* Eq(12) of RPTV + !hv else + !hv Heaviside = 1. !* Eq(11) of RPTV + !hv end if + !!hv--- + !! ---------------------------------------------------------- + !! + !! + !! dWdn is the same as sqrt(zzsum) in Don's code, here reduced to a + !! simpler but mathematically equivalent form that should vary + !! smoothly between deep and intermediate water owing to identities + !! using the computer's tanh() function + !! ---------------------------------------------------------- + !! + !! set grad(,,); + !! looks like the g^2 goes with csq (Webb'1978, eq. A2) + !! ---------------------------------------------------------- + !! + !b dWdnsq = cg2**2 - 2.*cg2*cg4 * cos(th2-th4) + cg4**2 + dWdnsq = cg2*cg2 - 2.*cg2*cg4 * cos(th2-th4) + cg4*cg4 + !! ---------------------------------------------------------- + !! + dWdn = sqrt(dWdnsq) + !! ---------------------------------------------------------- + !! + !!hv Bash; with !hv ON, don't use var Heaviside (by here it's = 1.0) + grad(ipt,kang,izz) = ds(ipt)*csq*gsq/dWdn + !!hv--- + !hv grad(ipt,kang,izz) = Heaviside*ds(ipt)*csq*gsq/dWdn + !!hv--- + !! ---------------------------------------------------------- + !! ========================================================== + !! + !! + !! Set interpolation, indexing and weight parameters for + !! computations along wavenumber radials + !! ---------------------------------------------------------- + !! + !!f2 -------------------- + if ( f2 .lt. f0 ) then + wtk2(ipt,kang,izz) = 1. + tfac2(ipt,kang,izz) = 0. + kref2(ipt,kang,izz) = 1 + else + ir = 1+int((alog(f2)-alf0)/aldfrq) + if ( ir+1 .gt. nrng ) then + wtk2(ipt,kang,izz) = 0. + er = (wka1(nrng)/wn2)**(2.5) + tt2= er*(cg2/cgnrng1)*(frqa(nrng)/f2)*(wka1(nrng)/wn2) + tfac2(ipt,kang,izz) = tt2 + kref2(ipt,kang,izz) = nrng - 1 else - ir = 1+int((alog(f2)-alf0)/aldfrq) - if ( ir+1 .gt. nrng ) then - wtk2(ipt,kang,izz) = 0. - er = (wka1(nrng)/wn2)**(2.5) - tt2= er*(cg2/cgnrng1)*(frqa(nrng)/f2)*(wka1(nrng)/wn2) - tfac2(ipt,kang,izz) = tt2 - kref2(ipt,kang,izz) = nrng - 1 - else - w2 = (f2-frqa(ir))/(frqa(ir+1)-frqa(ir)) - wtk2(ipt,kang,izz) = 1. - w2 - tfac2(ipt,kang,izz) = 1. - kref2(ipt,kang,izz) = ir - end if + w2 = (f2-frqa(ir))/(frqa(ir+1)-frqa(ir)) + wtk2(ipt,kang,izz) = 1. - w2 + tfac2(ipt,kang,izz) = 1. + kref2(ipt,kang,izz) = ir end if -!! ---------------------------------------------------------- -!! -!!f4 -------------------- - if ( f4 .lt. f0 ) then - wtk4(ipt,kang,izz) = 1. - tfac4(ipt,kang,izz) = 0. - kref4(ipt,kang,izz) = 1 + end if + !! ---------------------------------------------------------- + !! + !!f4 -------------------- + if ( f4 .lt. f0 ) then + wtk4(ipt,kang,izz) = 1. + tfac4(ipt,kang,izz) = 0. + kref4(ipt,kang,izz) = 1 + else + ir = 1+int((alog(f4)-alf0)/aldfrq) + if ( ir+1 .gt. nrng ) then + wtk4(ipt,kang,izz) = 0. + er = (wka1(nrng)/wn4)**2.5 + tt4= er*(cg4/cgnrng1)*(frqa(nrng)/f4)*(wka1(nrng)/wn4) + tfac4(ipt,kang,izz) = tt4 + kref4(ipt,kang,izz) = nrng - 1 else - ir = 1+int((alog(f4)-alf0)/aldfrq) - if ( ir+1 .gt. nrng ) then - wtk4(ipt,kang,izz) = 0. - er = (wka1(nrng)/wn4)**2.5 - tt4= er*(cg4/cgnrng1)*(frqa(nrng)/f4)*(wka1(nrng)/wn4) - tfac4(ipt,kang,izz) = tt4 - kref4(ipt,kang,izz) = nrng - 1 - else - w2 = (f4-frqa(ir))/(frqa(ir+1)-frqa(ir)) - wtk4(ipt,kang,izz) = 1. - w2 - tfac4(ipt,kang,izz) = 1. - kref4(ipt,kang,izz) = ir - end if + w2 = (f4-frqa(ir))/(frqa(ir+1)-frqa(ir)) + wtk4(ipt,kang,izz) = 1. - w2 + tfac4(ipt,kang,izz) = 1. + kref4(ipt,kang,izz) = ir end if -!! ---------------------------------------------------------- -!! -!! -!! Set indexing and weight parameters for computations around -!! azimuths; it appears that jref2 and jref4 should be bounded -!! between 0 and nang-1 so that when iang (=1,nang) is added in -!! the integration section, the proper bin index will arise; -!! the weights wta2 and wta4 seem to be the fractional bin -!! widths between th2 or th4 and the next increasing -!! directional bin boundary -!! ---------------------------------------------------------- -!! - i = int(th2/ainc) - wta2(ipt,kang,izz) = 1. - abs(th2-i*ainc)/ainc - if ( i .ge. nang ) i = i - nang - jref2(ipt,kang,izz) = i -!mpc jref2(ipt,kang,izz) = MOD(i,nang) !* is this better that the above two lines? -!! - i = int(th4/ainc) - wta4(ipt,kang,izz) = 1. - abs(th4-i*ainc)/ainc - if ( i .ge. nang ) i = i - nang - jref4(ipt,kang,izz) = i -!mpc jref4(ipt,kang,izz) = MOD(i,nang) !* is this better that the above two lines? -!! -50 end do !* end of ipt loop -!! -40 end do !* end of kang loop -!! -30 end do !* end of krng loop -!! + end if + !! ---------------------------------------------------------- + !! + !! + !! Set indexing and weight parameters for computations around + !! azimuths; it appears that jref2 and jref4 should be bounded + !! between 0 and nang-1 so that when iang (=1,nang) is added in + !! the integration section, the proper bin index will arise; + !! the weights wta2 and wta4 seem to be the fractional bin + !! widths between th2 or th4 and the next increasing + !! directional bin boundary + !! ---------------------------------------------------------- + !! + i = int(th2/ainc) + wta2(ipt,kang,izz) = 1. - abs(th2-i*ainc)/ainc + if ( i .ge. nang ) i = i - nang + jref2(ipt,kang,izz) = i + !mpc jref2(ipt,kang,izz) = MOD(i,nang) !* is this better that the above two lines? + !! + i = int(th4/ainc) + wta4(ipt,kang,izz) = 1. - abs(th4-i*ainc)/ainc + if ( i .ge. nang ) i = i - nang + jref4(ipt,kang,izz) = i + !mpc jref4(ipt,kang,izz) = MOD(i,nang) !* is this better that the above two lines? + !! +50 end do !* end of ipt loop + !! +40 end do !* end of kang loop + !! +30 end do !* end of krng loop + !! 20 end do !* end of irng loop -!! ------------------------------------------------------------------ -!! ================================================================== -!! - RETURN -!! - END SUBROUTINE gridsetr -!! -!!============================================================================== -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE shloxr ( dep, wk1x,wk1y, wk3x,wk3y ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! ------------------------------------------------------------------ -!! -!! it returns: wk2x, wk2y, wk4x, wk4y & ds all dim=(npts) -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!! 1. Purpose : -!! -!! -------------------------------------------------------------------------# -!! ! -!! General locus solution for input vectors (wk1x,wk1y) and ! -!! (wk3x,wk3y) of the same magnitude but NOT in the same direction ! -!! (or singularness will occur), output vectors (wk2x,wk2y) and ! -!! (wk4x,wk4y), and element length ds along locus curve: ! -!! ! -!! With wavenumber vector n identified by (wknx,wkny), its magnitude ! -!! given by wkn = sqrt(wknx**2+wkny**2) and its associated radian ! -!! frequency given by sign = sqrt[g*wkn*tanh(wkn*dep)], where g is ! -!! gravitational acceleration and dep is water depth, the four-wave ! -!! resonance condition is satisfied along a locus of pts defined by ! -!! ! -!! [1] (wk1x,wk1y) + (wk2x,wk2y) - (wk3x,wk3y) - (wk4x,wk4y) = 0 ! -!! ! -!! [2] sig1 + sig2 - sig3 - sig4 = 0 ! -!! ! -!! In the case where k1 [= sqrt(wk1x**2+wk1y**2)] is equal to k3 ! -!! [= sqrt(wk3x**2+wk3y**2)], we have by dispersion, ! -!! ! -!! [3] sig1 = sqrt[g*k1*tanh(k1*h)] = sqrt[g*k3*tanh(k3*h)] = sig3 ! -!! ! -!! so sig1 - sig3 = 0 and [2] becomes sig2 = sig4, where, again by ! -!! dispersion, ! -!! ! -!! [4] sig2 = sqrt(g*k2*tanh(k2*h)] = sig4 = sqrt(g*k4*tanh(k4*h)] ! -!! ! -!! and consequently k2 = k4. This simplifies the locus solution ! -!! considerably, and it can be shown that the (wk2x,wk2y) locus is ! -!! along the perpendicular bisector of the (px,py) vector given by ! -!! ! -!! [5] (px,py) = (wk3x-wk1x,wk3y-wk1y) ! -!! ! -!! and thereby from [1] ! -!! [6] (wk4x,wk4y) = (wk2x,wk2y) - (px,py) ! -!! ! -!! We note that these loci are independent of depth, although depth ! -!! is used to set the length of the locus line by requiring that its ! -!! range on either side of the p vector correspond to a wave with a ! -!!wkx freq four times that of the k1 vector (the locus line is made ! -!! up of npts segments of length ds; the outer edges of the terminal ! -!! segments satisfy the length constraint; vectors k2 and k4 extend ! -!! to segment centers and will sufficiently approximate the length ! -!! constraint). As compared to srshlocr.f, we can do all ! -!! calculations here in dimensional space. ! -!! -------------------------------------------------------------------------# -!! -!! 2. Method : -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! npts int. Public I # of points on the locus -!! np2p1 int. Public I = npts/2 + 1 -!! ---------------------------------------------------------------- -!! -!! *** arrays wk2x,wk2y, wk4x,wk4y & ds are related to locus solutioni -!! for given vectors K1 & k3 all have dim=(npts) -!! wk2x R.A. Public O x_cmp of vector k2 solution on the locus -!! wk2y R.A. Public O y_cmp of vector k2 solution on the locus -!! wk4x R.A. Public O x_cmp of vector k4 solution on the locus -!! wk4y R.A. Public O y_cmp of vector k4 solution on the locus -!! ds R.A. Public O element length along the locus -!! (npts*ds circles the whole locus) -!! ---------------------------------------------------------------- -!! -!! 4. Subroutines used : -!! -!! Name Type Module Description -!! ---------------------------------------------------------------- -!! ---------------------------------------------------------------- -!! -!! 5. Called by : -!! -!! Name Type Module Description -!! ---------------------------------------------------------------- -!! gridsetr Subr. W3SNL4MD Setup geometric integration grid -!! ---------------------------------------------------------------- -!! -!! 6. Error messages : -!! -!! None. -!! -!! 7. Remarks : -!! -!! 8. Structure : -!! -!! See source code. -!! -!! 9. Switches : -!! -!! !/S Enable subroutine tracing. -!! -!!10. Source code : -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! -!!wvn -!wvn USE W3DISPMD, ONLY: WAVNU2 -!!wvn--- -!! - IMPLICIT NONE -!! -!! Parameter list -!! -------------- - real, intent(in) :: dep - real, intent(in) :: wk1x,wk1y, wk3x,wk3y -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! -!! -!! Local Parameters & variables -!! ----------------------------- - integer :: m, n - real :: g - real :: wk1, f1, fx - real :: wkx, db, px, py, p, thp, halfp - real :: a, b, dth, a_halfp -!a real :: wkfnc !* real function or use WAVNU2 -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!! initial constants -!! ------------------ - g = 9.806 !* set = GRAV as in CONSTANTS -!! -!!ini -!! initial all returned arrays before they are computed -!! ----------------------------------------------------- - wk2x(:) = 0.0 - wk2y(:) = 0.0 - wk4x(:) = 0.0 - wk4y(:) = 0.0 - ds(:) = 0.0 -!!ini--- -!! ------------------------------------------------------------------ -!! -!!wkx Bash; Try use wkx = wka(nrng) instead of wkx = wkfnc(4.*f1,dep) -!b wk1 = sqrt(wk1x**2+wk1y**2) !* k1=wk1x since wk1y=0.0 - wk1 = wk1x - f1 = sqrt(g*wk1*tanh(wk1*dep))/twopi !* f1=f(k1,dep) - fx = 4. * f1 !* fx = 4*f1 -!! -!!wvn Bash; Try use subr WAVNU2 instead of function wkfnc -!wvn call WAVNU2(twopi*fx,dep,wkx,cgx) !* => wkx=k(4*f1,dep) & cgx=Cg(4*f1,dep) - wkx = wkfnc(fx,dep) !* +> wkx=k(4*f1,dep) (cgx not needed) -!!wvn--- -!! ------------------------------------------------------------------ -!! - db = wkx/float(np2p1-1) !* locus length increment -!! -!! - px = wk3x - wk1x - py = wk3y - wk1y !* wk1y=0.0 can be omitted -!b p = sqrt(px**2 + py**2) !* argument never = 0.0 - p = sqrt(px*px + py*py) - thp = atan2(py,px) - halfp = 0.5*p -!! -!! + !! ------------------------------------------------------------------ + !! ================================================================== + !! + RETURN + !! + END SUBROUTINE gridsetr + !! + !!============================================================================== + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + SUBROUTINE shloxr ( dep, wk1x,wk1y, wk3x,wk3y ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! ------------------------------------------------------------------ + !! + !! it returns: wk2x, wk2y, wk4x, wk4y & ds all dim=(npts) + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !! 1. Purpose : + !! + !! -------------------------------------------------------------------------# + !! ! + !! General locus solution for input vectors (wk1x,wk1y) and ! + !! (wk3x,wk3y) of the same magnitude but NOT in the same direction ! + !! (or singularness will occur), output vectors (wk2x,wk2y) and ! + !! (wk4x,wk4y), and element length ds along locus curve: ! + !! ! + !! With wavenumber vector n identified by (wknx,wkny), its magnitude ! + !! given by wkn = sqrt(wknx**2+wkny**2) and its associated radian ! + !! frequency given by sign = sqrt[g*wkn*tanh(wkn*dep)], where g is ! + !! gravitational acceleration and dep is water depth, the four-wave ! + !! resonance condition is satisfied along a locus of pts defined by ! + !! ! + !! [1] (wk1x,wk1y) + (wk2x,wk2y) - (wk3x,wk3y) - (wk4x,wk4y) = 0 ! + !! ! + !! [2] sig1 + sig2 - sig3 - sig4 = 0 ! + !! ! + !! In the case where k1 [= sqrt(wk1x**2+wk1y**2)] is equal to k3 ! + !! [= sqrt(wk3x**2+wk3y**2)], we have by dispersion, ! + !! ! + !! [3] sig1 = sqrt[g*k1*tanh(k1*h)] = sqrt[g*k3*tanh(k3*h)] = sig3 ! + !! ! + !! so sig1 - sig3 = 0 and [2] becomes sig2 = sig4, where, again by ! + !! dispersion, ! + !! ! + !! [4] sig2 = sqrt(g*k2*tanh(k2*h)] = sig4 = sqrt(g*k4*tanh(k4*h)] ! + !! ! + !! and consequently k2 = k4. This simplifies the locus solution ! + !! considerably, and it can be shown that the (wk2x,wk2y) locus is ! + !! along the perpendicular bisector of the (px,py) vector given by ! + !! ! + !! [5] (px,py) = (wk3x-wk1x,wk3y-wk1y) ! + !! ! + !! and thereby from [1] ! + !! [6] (wk4x,wk4y) = (wk2x,wk2y) - (px,py) ! + !! ! + !! We note that these loci are independent of depth, although depth ! + !! is used to set the length of the locus line by requiring that its ! + !! range on either side of the p vector correspond to a wave with a ! + !!wkx freq four times that of the k1 vector (the locus line is made ! + !! up of npts segments of length ds; the outer edges of the terminal ! + !! segments satisfy the length constraint; vectors k2 and k4 extend ! + !! to segment centers and will sufficiently approximate the length ! + !! constraint). As compared to srshlocr.f, we can do all ! + !! calculations here in dimensional space. ! + !! -------------------------------------------------------------------------# + !! + !! 2. Method : + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! npts int. Public I # of points on the locus + !! np2p1 int. Public I = npts/2 + 1 + !! ---------------------------------------------------------------- + !! + !! *** arrays wk2x,wk2y, wk4x,wk4y & ds are related to locus solutioni + !! for given vectors K1 & k3 all have dim=(npts) + !! wk2x R.A. Public O x_cmp of vector k2 solution on the locus + !! wk2y R.A. Public O y_cmp of vector k2 solution on the locus + !! wk4x R.A. Public O x_cmp of vector k4 solution on the locus + !! wk4y R.A. Public O y_cmp of vector k4 solution on the locus + !! ds R.A. Public O element length along the locus + !! (npts*ds circles the whole locus) + !! ---------------------------------------------------------------- + !! + !! 4. Subroutines used : + !! + !! Name Type Module Description + !! ---------------------------------------------------------------- + !! ---------------------------------------------------------------- + !! + !! 5. Called by : + !! + !! Name Type Module Description + !! ---------------------------------------------------------------- + !! gridsetr Subr. W3SNL4MD Setup geometric integration grid + !! ---------------------------------------------------------------- + !! + !! 6. Error messages : + !! + !! None. + !! + !! 7. Remarks : + !! + !! 8. Structure : + !! + !! See source code. + !! + !! 9. Switches : + !! + !! !/S Enable subroutine tracing. + !! + !!10. Source code : + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + !!wvn + !wvn USE W3DISPMD, ONLY: WAVNU2 + !!wvn--- + !! + IMPLICIT NONE + !! + !! Parameter list + !! -------------- + real, intent(in) :: dep + real, intent(in) :: wk1x,wk1y, wk3x,wk3y + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! + !! + !! Local Parameters & variables + !! ----------------------------- + integer :: m, n + real :: g + real :: wk1, f1, fx + real :: wkx, db, px, py, p, thp, halfp + real :: a, b, dth, a_halfp + !a real :: wkfnc !* real function or use WAVNU2 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !! initial constants + !! ------------------ + g = 9.806 !* set = GRAV as in CONSTANTS + !! + !!ini + !! initial all returned arrays before they are computed + !! ----------------------------------------------------- + wk2x(:) = 0.0 + wk2y(:) = 0.0 + wk4x(:) = 0.0 + wk4y(:) = 0.0 + ds(:) = 0.0 + !!ini--- + !! ------------------------------------------------------------------ + !! + !!wkx Bash; Try use wkx = wka(nrng) instead of wkx = wkfnc(4.*f1,dep) + !b wk1 = sqrt(wk1x**2+wk1y**2) !* k1=wk1x since wk1y=0.0 + wk1 = wk1x + f1 = sqrt(g*wk1*tanh(wk1*dep))/twopi !* f1=f(k1,dep) + fx = 4. * f1 !* fx = 4*f1 + !! + !!wvn Bash; Try use subr WAVNU2 instead of function wkfnc + !wvn call WAVNU2(twopi*fx,dep,wkx,cgx) !* => wkx=k(4*f1,dep) & cgx=Cg(4*f1,dep) + wkx = wkfnc(fx,dep) !* +> wkx=k(4*f1,dep) (cgx not needed) + !!wvn--- + !! ------------------------------------------------------------------ + !! + db = wkx/float(np2p1-1) !* locus length increment + !! + !! + px = wk3x - wk1x + py = wk3y - wk1y !* wk1y=0.0 can be omitted + !b p = sqrt(px**2 + py**2) !* argument never = 0.0 + p = sqrt(px*px + py*py) + thp = atan2(py,px) + halfp = 0.5*p + !! + !! do n=np2p1,npts !* for npts = 30 -!! !* n = 16 --> 30 -!! -!b b = 0.5 * db + float(n-np2p1) * db - b = db * (0.5 + float(n-np2p1)) -!b a = sqrt(1. + (2.*b/p)**2) - a = sqrt(1. + (2.*b/p)*(2.*b/p)) - dth = acos(1./a) - a_halfp = a*halfp -!! -!b wk2x(n) = a*halfp * cos(thp+dth) -!b wk2y(n) = a*halfp * sin(thp+dth) - wk2x(n) = a_halfp * cos(thp+dth) - wk2y(n) = a_halfp * sin(thp+dth) - wk4x(n) = wk2x(n) - px - wk4y(n) = wk2y(n) - py - ds(n) = db -!! - m = npts - n + 1 !* m = 15 --> 1 -!b wk2x(m) = a*halfp * cos(thp-dth) -!b wk2y(m) = a*halfp * sin(thp-dth) - wk2x(m) = a_halfp * cos(thp-dth) - wk2y(m) = a_halfp * sin(thp-dth) - wk4x(m) = wk2x(m) - px - wk4y(m) = wk2y(m) - py - ds(m) = db -!! + !! !* n = 16 --> 30 + !! + !b b = 0.5 * db + float(n-np2p1) * db + b = db * (0.5 + float(n-np2p1)) + !b a = sqrt(1. + (2.*b/p)**2) + a = sqrt(1. + (2.*b/p)*(2.*b/p)) + dth = acos(1./a) + a_halfp = a*halfp + !! + !b wk2x(n) = a*halfp * cos(thp+dth) + !b wk2y(n) = a*halfp * sin(thp+dth) + wk2x(n) = a_halfp * cos(thp+dth) + wk2y(n) = a_halfp * sin(thp+dth) + wk4x(n) = wk2x(n) - px + wk4y(n) = wk2y(n) - py + ds(n) = db + !! + m = npts - n + 1 !* m = 15 --> 1 + !b wk2x(m) = a*halfp * cos(thp-dth) + !b wk2y(m) = a*halfp * sin(thp-dth) + wk2x(m) = a_halfp * cos(thp-dth) + wk2y(m) = a_halfp * sin(thp-dth) + wk4x(m) = wk2x(m) - px + wk4y(m) = wk2y(m) - py + ds(m) = db + !! end do ! do n=np2p1,npts -!! ------------------------------------------------------------------ -!! ================================================================== -!! - RETURN -!! - END SUBROUTINE shloxr -!! -!!============================================================================== -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! ------------------------------------------------------------------ -!! -!! it returns: wk2x, wk2y, wk4x, wk4y & ds all dim=(npts) -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!! 1. Purpose : -!! -!! -----------------------------------------------------------------# -!! ! -!! With wavenumber vector n identified by (wknx,wkny), its magnitude! -!! given by wkn = sqrt(wknx**2+wkny**2) and its associated radian ! -!! frequency given by sign = sqrt[g*wkn*tanh(wkn*dep)], where g is ! -!! gravitational acceleration and dep is water depth, the four-wave ! -!! resonance condition is satisfied along a locus of pts defined by ! -!! ! -!! [1] (wk1x,wk1y) + (wk2x,wk2y) - (wk3x,wk3y) - (wk4x,wk4y) = 0 ! -!! ! -!! [2] sig1 + sig2 - sig3 - sig4 = 0 ! -!! ! -!! Because of the influence of depth, it is convenient to define new! -!! vectors (wnx,wny) = (wknx*dep,wkny*dep) with magnitudes wn = ! -!! sqrt(wnx**2+wny**2) = wkn*dep such that a dimensionless frequency! -!! is sign*sqrt(dep/g) = sqrt[wkn*dep*tanh(wkn*dep)] ! -!! = sqrt[wn*tanh(wn)]. ! -!! With these definitions and vectors (wk1x,wk1y) and (wk3x,wk3y) ! -!! given as input, we can write (with some rearrangement ! -!! of [1] and [2]) ! -!! ! -!! [3] w3x - w1x = px = w2x - w4x ! -!! [4] w3y - w1y = py = w2y - w4y ! -!! [5] sqrt[w3*tanh(w3)] - sqrt[w1*tanh(w1)] = q ! -!! = sqrt[w2*tanh(w2)] - sqrt[w4*tanh(w4)] ! -!! ! -!! With dimensionless vector (px,py) = (w3x-w1x,w3y-w1y) [magnitude ! -!! p = sqrt(px**2+py**2), direction atan2(py,px)] and dimensionless ! -!! frequency difference q = sqrt(w3*tanh(w3)] - sqrt(w1*tanh(w1)] ! -!! defined by input parameters, we see from [3] and [4] that ! -!! (w4x,w4y) = (w2x-px,w2y-py) [magnitude w4 = sqrt((w2x-px)**2 + ! -!! (w2y-py)**2)] and thus from [5] we must basically find elements ! -!! w2x and w2y that satisfy ! -!! ! -!! [6] sqrt[sqrt(w2x**2+w2y**2)*tanh(sqrt(w2x**2+w2y**2))] - ! -!! sqrt[sqrt((w2x-px)**2+(w2y-py)**2) * ! -!! tanh(sqrt((w2x-px)**2+(w2y-py)**2] = q ! -!! ! -!! The locus curve defined by the set of pts (w2x,w2y) crosses the ! -!! p-vector axis at two points; one with magnitude w2=rmin*p with ! -!! 0.5 < rmin < 1.0 and one with magnitude w2=rmax*p with rmax > 1. ! -!! We first isolate rmin, rmax using various iterative algorithms, ! -!! and then find locus pts that are not on the p-vector axis with ! -!! another iterative scheme. At the end, we un-normalize the w2 ! -!! and w4 vectors to find the wk2 and wk4 vectors. ! -!! -----------------------------------------------------------------# -!! -!! 2. Method : -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! npts int. Public I # of points on the locus -!! np2p1 int. Public I = npts/2 + 1 -!! ---------------------------------------------------------------- -!! -!! *** arrays wk2x,wk2y, wk4x,wk4y & ds are related to locus solutioni -!! for given vectors K1 & k3 all have dim=(npts) -!! wk2x R.A. Public O x_cmp of vector k2 solution on the locus -!! wk2y R.A. Public O y_cmp of vector k2 solution on the locus -!! wk4x R.A. Public O x_cmp of vector k4 solution on the locus -!! wk4y R.A. Public O y_cmp of vector k4 solution on the locus -!! ds R.A. Public O element length along the locus -!! (npts*ds circles the whole locus) -!! ---------------------------------------------------------------- -!! -!! 4. Subroutines used : -!! -!! Name Type Module Description -!! ---------------------------------------------------------------- -!! ---------------------------------------------------------------- -!! -!! 5. Called by : -!! -!! Name Type Module Description -!! ---------------------------------------------------------------- -!! gridsetr Subr. W3SNL4MD Setup geometric integration grid -!! ---------------------------------------------------------------- -!! -!! 6. Error messages : -!! -!! None. -!! -!! 7. Remarks : -!! -!! 8. Structure : -!! -!! See source code. -!! -!! 9. Switches : -!! -!! !/S Enable subroutine tracing. -!! -!!10. Source code : -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE -!! -!! - IMPLICIT NONE -!! -!! Parameter list -!! -------------- - real, intent(in) :: dep - real, intent(in) :: wk1x,wk1y, wk3x,wk3y -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! -!! -!! Local Parameters & variables -!! ----------------------------- - integer :: n, np, nnp, nplace - integer :: ierr_gr -!! - real :: p, px, py, q, qrtp, qsqp, & - dr, dth, thp, dphi, cphi, & - w1, w1x, w1y, wk1, w3, w3x, w3y, wk3, & - rold, rold1, rold2, rnew, rnew1, rnew2, & - pxod, pyod, zpod, & - t, t1, t2, t3, tm, tp, ds1, ds2, & - rmin, rmax, rcenter, rradius -!! - double precision :: dbt3,dbt4,dbt5,dbt6, dbz, dbp, dbqrtp, & - cdthold, cdthnew, wate1, wate2 -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!!ini -!! initial all returned arrays before they are computed -!! ----------------------------------------------------- - wk2x(:) = 0.0 - wk2y(:) = 0.0 - wk4x(:) = 0.0 - wk4y(:) = 0.0 - ds(:) = 0.0 -!!ini--- -!! ------------------------------------------------------------------ -!! -!! -!b wk1 = sqrt(wk1x**2 + wk1y**2) !* k1=wk1x since wk1y=0.0 - wk1 = wk1x -!b wk3 = sqrt(wk3x**2 + wk3y**2) - wk3 = sqrt(wk3x*wk3x + wk3y*wk3y) -!! - w1 = wk1 * dep - w1x = wk1x * dep -!b w1y = wk1y * dep - w1y = wk1y !* wk1y=0.0 -!! - w3 = wk3 * dep - w3x = wk3x * dep - w3y = wk3y * dep -!! - px = w3x - w1x - py = w3y - w1y -!b p = sqrt(px**2 + py**2) !* argument never = 0.0 - p = sqrt(px*px + py*py) !* argument never = 0.0 + !! ------------------------------------------------------------------ + !! ================================================================== + !! + RETURN + !! + END SUBROUTINE shloxr + !! + !!============================================================================== + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! ------------------------------------------------------------------ + !! + !! it returns: wk2x, wk2y, wk4x, wk4y & ds all dim=(npts) + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !! 1. Purpose : + !! + !! -----------------------------------------------------------------# + !! ! + !! With wavenumber vector n identified by (wknx,wkny), its magnitude! + !! given by wkn = sqrt(wknx**2+wkny**2) and its associated radian ! + !! frequency given by sign = sqrt[g*wkn*tanh(wkn*dep)], where g is ! + !! gravitational acceleration and dep is water depth, the four-wave ! + !! resonance condition is satisfied along a locus of pts defined by ! + !! ! + !! [1] (wk1x,wk1y) + (wk2x,wk2y) - (wk3x,wk3y) - (wk4x,wk4y) = 0 ! + !! ! + !! [2] sig1 + sig2 - sig3 - sig4 = 0 ! + !! ! + !! Because of the influence of depth, it is convenient to define new! + !! vectors (wnx,wny) = (wknx*dep,wkny*dep) with magnitudes wn = ! + !! sqrt(wnx**2+wny**2) = wkn*dep such that a dimensionless frequency! + !! is sign*sqrt(dep/g) = sqrt[wkn*dep*tanh(wkn*dep)] ! + !! = sqrt[wn*tanh(wn)]. ! + !! With these definitions and vectors (wk1x,wk1y) and (wk3x,wk3y) ! + !! given as input, we can write (with some rearrangement ! + !! of [1] and [2]) ! + !! ! + !! [3] w3x - w1x = px = w2x - w4x ! + !! [4] w3y - w1y = py = w2y - w4y ! + !! [5] sqrt[w3*tanh(w3)] - sqrt[w1*tanh(w1)] = q ! + !! = sqrt[w2*tanh(w2)] - sqrt[w4*tanh(w4)] ! + !! ! + !! With dimensionless vector (px,py) = (w3x-w1x,w3y-w1y) [magnitude ! + !! p = sqrt(px**2+py**2), direction atan2(py,px)] and dimensionless ! + !! frequency difference q = sqrt(w3*tanh(w3)] - sqrt(w1*tanh(w1)] ! + !! defined by input parameters, we see from [3] and [4] that ! + !! (w4x,w4y) = (w2x-px,w2y-py) [magnitude w4 = sqrt((w2x-px)**2 + ! + !! (w2y-py)**2)] and thus from [5] we must basically find elements ! + !! w2x and w2y that satisfy ! + !! ! + !! [6] sqrt[sqrt(w2x**2+w2y**2)*tanh(sqrt(w2x**2+w2y**2))] - ! + !! sqrt[sqrt((w2x-px)**2+(w2y-py)**2) * ! + !! tanh(sqrt((w2x-px)**2+(w2y-py)**2] = q ! + !! ! + !! The locus curve defined by the set of pts (w2x,w2y) crosses the ! + !! p-vector axis at two points; one with magnitude w2=rmin*p with ! + !! 0.5 < rmin < 1.0 and one with magnitude w2=rmax*p with rmax > 1. ! + !! We first isolate rmin, rmax using various iterative algorithms, ! + !! and then find locus pts that are not on the p-vector axis with ! + !! another iterative scheme. At the end, we un-normalize the w2 ! + !! and w4 vectors to find the wk2 and wk4 vectors. ! + !! -----------------------------------------------------------------# + !! + !! 2. Method : + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! npts int. Public I # of points on the locus + !! np2p1 int. Public I = npts/2 + 1 + !! ---------------------------------------------------------------- + !! + !! *** arrays wk2x,wk2y, wk4x,wk4y & ds are related to locus solutioni + !! for given vectors K1 & k3 all have dim=(npts) + !! wk2x R.A. Public O x_cmp of vector k2 solution on the locus + !! wk2y R.A. Public O y_cmp of vector k2 solution on the locus + !! wk4x R.A. Public O x_cmp of vector k4 solution on the locus + !! wk4y R.A. Public O y_cmp of vector k4 solution on the locus + !! ds R.A. Public O element length along the locus + !! (npts*ds circles the whole locus) + !! ---------------------------------------------------------------- + !! + !! 4. Subroutines used : + !! + !! Name Type Module Description + !! ---------------------------------------------------------------- + !! ---------------------------------------------------------------- + !! + !! 5. Called by : + !! + !! Name Type Module Description + !! ---------------------------------------------------------------- + !! gridsetr Subr. W3SNL4MD Setup geometric integration grid + !! ---------------------------------------------------------------- + !! + !! 6. Error messages : + !! + !! None. + !! + !! 7. Remarks : + !! + !! 8. Structure : + !! + !! See source code. + !! + !! 9. Switches : + !! + !! !/S Enable subroutine tracing. + !! + !!10. Source code : + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE + !! + !! + IMPLICIT NONE + !! + !! Parameter list + !! -------------- + real, intent(in) :: dep + real, intent(in) :: wk1x,wk1y, wk3x,wk3y + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! + !! + !! Local Parameters & variables + !! ----------------------------- + integer :: n, np, nnp, nplace + integer :: ierr_gr + !! + real :: p, px, py, q, qrtp, qsqp, & + dr, dth, thp, dphi, cphi, & + w1, w1x, w1y, wk1, w3, w3x, w3y, wk3, & + rold, rold1, rold2, rnew, rnew1, rnew2, & + pxod, pyod, zpod, & + t, t1, t2, t3, tm, tp, ds1, ds2, & + rmin, rmax, rcenter, rradius + !! + double precision :: dbt3,dbt4,dbt5,dbt6, dbz, dbp, dbqrtp, & + cdthold, cdthnew, wate1, wate2 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !!ini + !! initial all returned arrays before they are computed + !! ----------------------------------------------------- + wk2x(:) = 0.0 + wk2y(:) = 0.0 + wk4x(:) = 0.0 + wk4y(:) = 0.0 + ds(:) = 0.0 + !!ini--- + !! ------------------------------------------------------------------ + !! + !! + !b wk1 = sqrt(wk1x**2 + wk1y**2) !* k1=wk1x since wk1y=0.0 + wk1 = wk1x + !b wk3 = sqrt(wk3x**2 + wk3y**2) + wk3 = sqrt(wk3x*wk3x + wk3y*wk3y) + !! + w1 = wk1 * dep + w1x = wk1x * dep + !b w1y = wk1y * dep + w1y = wk1y !* wk1y=0.0 + !! + w3 = wk3 * dep + w3x = wk3x * dep + w3y = wk3y * dep + !! + px = w3x - w1x + py = w3y - w1y + !b p = sqrt(px**2 + py**2) !* argument never = 0.0 + p = sqrt(px*px + py*py) !* argument never = 0.0 - thp = atan2(py,px) - q = sqrt(w3*tanh(w3)) - sqrt(w1*tanh(w1)) - qrtp = q / sqrt(p) - qsqp = qrtp*qrtp -!! -!! -!! -----------------------------------------------------------------# -!! ! -!! for (w2x,w2y) = rmin*(px,py) (locus crossing the p-vector axis ! -!! nearest the origin), we have (w4x,w4y) = (w2x,w2y) - (px,py) ! -!! = rmin*(px,py) - (px,py) = (rmin - 1)*(px,py); note that because ! -!! rmin < 1, the length of (w4x,w4y) is w4 = (1 - rmin)*p; then [6] ! -!! takes the simpler form ! -!! ! -!! [7] sqrt(rmin*p*tanh(rmin*p)) - sqrt[(1-rmin)*p*tanh((1-rmin)*p)]! -!! = q ! -!! ! -!! assuming the tanh() functions are slowly varying and can be ! -!! treated as separate entities, [7] can be written as a quadratic ! -!! in sqrt(rmin), i.e., ! -!! ! -!! 2*qrtp*sqrt(rmin*p) ! -!! [8] rmin - ------------------- sqrt(rmin) + ! -!! T ! -!! ! -!! qsqp-p*tanh((1-rmin)*p) ! -!! ----------------------- = 0, ! -!! T ! -!! ! -!! where T = tanh(rmin*p) + tanh((1-rmin)*p), ! -!! qrtp = q/sqrt(p) and qsqp = qrtp**2 ! -!! ! -!! the square of the most positive root of [8] can (with some ! -!! algebra) be written ! -!! ! -!! [9] rmin = ! -!! (1/T**2)*{qsqp*[tanh(rmin*p)-tanh((1-rmin)*p)]+T*tanh((1-rmin)*p) ! -!! +2*qrtp*sqrt[tanh(rmin*p)*tanh((1-rmin)*p)]*sqrt(T-qsqp)} ! -!! ! -!! setting rnew=rmin on the LHS and rold=rmin on the RHS in all ! -!! instances allows the creation of an iterative algorithm for rmin;! -!! convergence can be slow in general, so a coarse search for the ! -!! crossing of [9] with the rnew=rold line is conducted first, then ! -!! a weighted iterative replacement loop is executed until the ! -!! desired accuracy is achieved; ! -!! Note that if p is sufficiently large, all tanh() -> 1 ! -!! and [9] becomes the analytic expression ! -!! rmin = 0.5*[1 + qrtp*sqrt(2-qsqp)] ! -!! ! -!! following is the coarse search using rold1 = 0.5,0.1,1.0, ! -!! rold2 = rold1 + 0.1: ! -!! ! -!! -----------------------------------------------------------------# -!! -!! - ierr_gr = 0 -!! - rold1 = 0.5 - tp = tanh(rold1 * p) - tm = tanh((1.-rold1) * p) + thp = atan2(py,px) + q = sqrt(w3*tanh(w3)) - sqrt(w1*tanh(w1)) + qrtp = q / sqrt(p) + qsqp = qrtp*qrtp + !! + !! + !! -----------------------------------------------------------------# + !! ! + !! for (w2x,w2y) = rmin*(px,py) (locus crossing the p-vector axis ! + !! nearest the origin), we have (w4x,w4y) = (w2x,w2y) - (px,py) ! + !! = rmin*(px,py) - (px,py) = (rmin - 1)*(px,py); note that because ! + !! rmin < 1, the length of (w4x,w4y) is w4 = (1 - rmin)*p; then [6] ! + !! takes the simpler form ! + !! ! + !! [7] sqrt(rmin*p*tanh(rmin*p)) - sqrt[(1-rmin)*p*tanh((1-rmin)*p)]! + !! = q ! + !! ! + !! assuming the tanh() functions are slowly varying and can be ! + !! treated as separate entities, [7] can be written as a quadratic ! + !! in sqrt(rmin), i.e., ! + !! ! + !! 2*qrtp*sqrt(rmin*p) ! + !! [8] rmin - ------------------- sqrt(rmin) + ! + !! T ! + !! ! + !! qsqp-p*tanh((1-rmin)*p) ! + !! ----------------------- = 0, ! + !! T ! + !! ! + !! where T = tanh(rmin*p) + tanh((1-rmin)*p), ! + !! qrtp = q/sqrt(p) and qsqp = qrtp**2 ! + !! ! + !! the square of the most positive root of [8] can (with some ! + !! algebra) be written ! + !! ! + !! [9] rmin = ! + !! (1/T**2)*{qsqp*[tanh(rmin*p)-tanh((1-rmin)*p)]+T*tanh((1-rmin)*p) ! + !! +2*qrtp*sqrt[tanh(rmin*p)*tanh((1-rmin)*p)]*sqrt(T-qsqp)} ! + !! ! + !! setting rnew=rmin on the LHS and rold=rmin on the RHS in all ! + !! instances allows the creation of an iterative algorithm for rmin;! + !! convergence can be slow in general, so a coarse search for the ! + !! crossing of [9] with the rnew=rold line is conducted first, then ! + !! a weighted iterative replacement loop is executed until the ! + !! desired accuracy is achieved; ! + !! Note that if p is sufficiently large, all tanh() -> 1 ! + !! and [9] becomes the analytic expression ! + !! rmin = 0.5*[1 + qrtp*sqrt(2-qsqp)] ! + !! ! + !! following is the coarse search using rold1 = 0.5,0.1,1.0, ! + !! rold2 = rold1 + 0.1: ! + !! ! + !! -----------------------------------------------------------------# + !! + !! + ierr_gr = 0 + !! + rold1 = 0.5 + tp = tanh(rold1 * p) + tm = tanh((1.-rold1) * p) + t = tp + tm + t1 = qsqp * (tp-tm) + t2 = t * tm + t3 = 2. * qrtp * sqrt(tp*tm) * sqrt(t-qsqp) + rnew1 = (t1 + t2 + t3) / (t*t) + !! + !! + do n=1,4 + rold2 = rold1 + 0.1 + tp = tanh(rold2 * p) + tm = tanh((1.-rold2) * p) t = tp + tm t1 = qsqp * (tp-tm) t2 = t * tm t3 = 2. * qrtp * sqrt(tp*tm) * sqrt(t-qsqp) - rnew1 = (t1 + t2 + t3) / (t*t) -!! -!! - do n=1,4 - rold2 = rold1 + 0.1 - tp = tanh(rold2 * p) - tm = tanh((1.-rold2) * p) - t = tp + tm - t1 = qsqp * (tp-tm) - t2 = t * tm - t3 = 2. * qrtp * sqrt(tp*tm) * sqrt(t-qsqp) - rnew2 = (t1 + t2 + t3) / (t*t) - if ( rnew2 .lt. rold2 ) then - rold = (rold2*rnew1-rold1*rnew2)/(rold2-rold1-rnew2+rnew1) - go to 11 - end if - rold1 = rold2 - rnew1 = rnew2 + rnew2 = (t1 + t2 + t3) / (t*t) + if ( rnew2 .lt. rold2 ) then + rold = (rold2*rnew1-rold1*rnew2)/(rold2-rold1-rnew2+rnew1) + go to 11 + end if + rold1 = rold2 + rnew1 = rnew2 end do ! do n=1,4 - rold = 0.9 !* default if not otherwise found - 11 continue -!! ------------------------------------------------------------------ -!! -!! -!! iterative replacement search for rmin + rold = 0.9 !* default if not otherwise found +11 continue + !! ------------------------------------------------------------------ + !! + !! + !! iterative replacement search for rmin do n=1,50 - tp = tanh(rold * p) - tm = tanh((1.-rold) * p) - t = tp + tm - t1 = qsqp * (tp-tm) - t2 = t * tm - t3 = 2. * qrtp*sqrt(tp*tm)*sqrt(t-qsqp) - rnew = (t1 + t2 + t3) / (t*t) - if ( abs(rnew-rold) .lt. 0.00001 ) then - rmin = rnew - go to 21 - end if - rold = 0.5 * (rold + rnew) + tp = tanh(rold * p) + tm = tanh((1.-rold) * p) + t = tp + tm + t1 = qsqp * (tp-tm) + t2 = t * tm + t3 = 2. * qrtp*sqrt(tp*tm)*sqrt(t-qsqp) + rnew = (t1 + t2 + t3) / (t*t) + if ( abs(rnew-rold) .lt. 0.00001 ) then + rmin = rnew + go to 21 + end if + rold = 0.5 * (rold + rnew) end do - ierr_gr = ierr_gr + 1 !* set 1's flag in ierr_gr if no convergence - rmin = rnew - 21 continue -!! ------------------------------------------------------------------ -!! -!! set (dimensional) wavenumber components for this point on locus - wk2x(1) = rmin * px / dep - wk2y(1) = rmin * py / dep - wk4x(1) = (rmin-1.) * px / dep - wk4y(1) = (rmin-1.) * py / dep -!! -!! -!! -----------------------------------------------------------------# -!! ! -!! for (w2x,w2y) = rmax*(px,py) (locus crossing the p-vector axis ! -!! farthest from the origin), we have (w4x,w4y)=(w2x,w2y) - (px,py) ! -!! = rmax*(px,py) - (px,py) = (rmax - 1)*(px,py); ! -!! here, because rmax > 1, the length of (w4x,w4y) is ! -!! w4 = (rmax - 1)*p; then [6] takes the form ! -!! ! -!! [10] sqrt(rmax*p*tanh(rmax*p))-sqrt[(rmax-1)*p*tanh((rmax-1)*p)] ! -!! = q ! -!! ! -!! rearranging terms, squaring both sides and again rearranging ! -!! terms yields ! -!! ! -!! [11] rmax*p*[tanh(rmax*p) - tanh((rmax-1)*p)] ! -!! = 2*q*sqrt(tanh(rmax*p))*sqrt(rmax*p) + ! -!! q**2 + p*tanh((rmax-1)*p) ! -!! ! -!! because the difference of the two tanh()'s on the LHS tend to ! -!! make the whole term small, we solve for rmax from the rapidly ! -!! varying part of the first term on the RHS, i.e., ! -!! ! -!! [tanh((rmax-1)*p)+qsqp + rmax*T]**2 ! -!! [12] rmax = ----------------------------------- , ! -!! 4*qsqp*tanh(rmax*p) ! -!! ! -!! where, in this algorithm, T = tanh(rmax*p) - tanh((rmax-1)*p); ! -!! as for rmin in [9], setting rnew=rmax on the LHS and rold=rmax ! -!! in all instances on the RHS allows the formation of an iterative ! -!! algorithm; initially, we only know rmax > 1 so we do a coarse ! -!! search in the 10's place out to some reasonably big number to ! -!! try to find the place where [12] crosses the rnew = rold line ! -!! (if this fails, we set an error flag); in refining the estimate, ! -!! it appears that [12] can get a little squirrely, so we do a ! -!! brute force successive decimation search to nplace decimal places! -!! to home in on the answer; note that if p is big enough for the ! -!! tanh()'s to reach unity, [12] becomes exact and ! -!! rmax = [(1 + qsqp)**2]/(4*qsqp) ! -!! following is the coarse search with rold = 1,10,2001: ! -!! ! -!! -----------------------------------------------------------------# -!! - rold = 1.0 + ierr_gr = ierr_gr + 1 !* set 1's flag in ierr_gr if no convergence + rmin = rnew +21 continue + !! ------------------------------------------------------------------ + !! + !! set (dimensional) wavenumber components for this point on locus + wk2x(1) = rmin * px / dep + wk2y(1) = rmin * py / dep + wk4x(1) = (rmin-1.) * px / dep + wk4y(1) = (rmin-1.) * py / dep + !! + !! + !! -----------------------------------------------------------------# + !! ! + !! for (w2x,w2y) = rmax*(px,py) (locus crossing the p-vector axis ! + !! farthest from the origin), we have (w4x,w4y)=(w2x,w2y) - (px,py) ! + !! = rmax*(px,py) - (px,py) = (rmax - 1)*(px,py); ! + !! here, because rmax > 1, the length of (w4x,w4y) is ! + !! w4 = (rmax - 1)*p; then [6] takes the form ! + !! ! + !! [10] sqrt(rmax*p*tanh(rmax*p))-sqrt[(rmax-1)*p*tanh((rmax-1)*p)] ! + !! = q ! + !! ! + !! rearranging terms, squaring both sides and again rearranging ! + !! terms yields ! + !! ! + !! [11] rmax*p*[tanh(rmax*p) - tanh((rmax-1)*p)] ! + !! = 2*q*sqrt(tanh(rmax*p))*sqrt(rmax*p) + ! + !! q**2 + p*tanh((rmax-1)*p) ! + !! ! + !! because the difference of the two tanh()'s on the LHS tend to ! + !! make the whole term small, we solve for rmax from the rapidly ! + !! varying part of the first term on the RHS, i.e., ! + !! ! + !! [tanh((rmax-1)*p)+qsqp + rmax*T]**2 ! + !! [12] rmax = ----------------------------------- , ! + !! 4*qsqp*tanh(rmax*p) ! + !! ! + !! where, in this algorithm, T = tanh(rmax*p) - tanh((rmax-1)*p); ! + !! as for rmin in [9], setting rnew=rmax on the LHS and rold=rmax ! + !! in all instances on the RHS allows the formation of an iterative ! + !! algorithm; initially, we only know rmax > 1 so we do a coarse ! + !! search in the 10's place out to some reasonably big number to ! + !! try to find the place where [12] crosses the rnew = rold line ! + !! (if this fails, we set an error flag); in refining the estimate, ! + !! it appears that [12] can get a little squirrely, so we do a ! + !! brute force successive decimation search to nplace decimal places! + !! to home in on the answer; note that if p is big enough for the ! + !! tanh()'s to reach unity, [12] becomes exact and ! + !! rmax = [(1 + qsqp)**2]/(4*qsqp) ! + !! following is the coarse search with rold = 1,10,2001: ! + !! ! + !! -----------------------------------------------------------------# + !! + rold = 1.0 do n=1,200 - rold = rold + 10. + rold = rold + 10. + tp = tanh(rold * p) + tm = tanh((rold-1.) * p) + t = tp - tm + t1 = tm + qsqp + t2 = 4. * tp * qsqp + rnew = ((t1+rold*t)**2) / t2 + if ( rnew .lt. rold ) then + rold = rold - 10. + go to 31 + end if + end do + ierr_gr = ierr_gr + 10 !* set 10's place in ierr_gr if no sol'n +31 continue + !! ------------------------------------------------------------------ + !! + !! + !! successive decimation search to refine rmax + dr = 10. + do nplace=1,6 + dr = dr/10. + do n=1,10 + rold = rold + dr tp = tanh(rold * p) tm = tanh((rold-1.) * p) t = tp - tm @@ -2458,2668 +2480,2646 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) t2 = 4. * tp * qsqp rnew = ((t1+rold*t)**2) / t2 if ( rnew .lt. rold ) then - rold = rold - 10. - go to 31 + rold = rold - dr + go to 51 end if + end do +51 continue end do - ierr_gr = ierr_gr + 10 !* set 10's place in ierr_gr if no sol'n - 31 continue -!! ------------------------------------------------------------------ -!! -!! -!! successive decimation search to refine rmax - dr = 10. - do nplace=1,6 - dr = dr/10. - do n=1,10 - rold = rold + dr - tp = tanh(rold * p) - tm = tanh((rold-1.) * p) - t = tp - tm - t1 = tm + qsqp - t2 = 4. * tp * qsqp - rnew = ((t1+rold*t)**2) / t2 - if ( rnew .lt. rold ) then - rold = rold - dr - go to 51 - end if - end do - 51 continue - end do -!! - rmax = rold -!! -!! set (dimensional) wavenumber components for this locus point -!! - wk2x(np2p1) = rmax * px / dep - wk2y(np2p1) = rmax * py / dep - wk4x(np2p1) = (rmax-1.) * px / dep - wk4y(np2p1) = (rmax-1.) * py / dep -!! -!! -!! -----------------------------------------------------------------# -!! ! -!! search for cos(dth) for off-p-vector solutions; use a circle ! -!! centered on the p-vector axis at a distance ! -!! rcenter = 0.5*(rmax+rmin) from the origin with a ! -!! radius = 0.5*(rmax-rmin); radii from the center of the circle ! -!! at successive angle increments np*dphi intersect the circle at ! -!! distances r*p from the origin of the p vector such that ! -!! ! -!! [13] r**2 = rradius**2 + rcenter**2 - ! -!! 2*rcenter*rradius*cos(np*dphi) ! -!! ! -!! and makes an angle dth with the p vector satisfying ! -!! ! -!! [14] cdth = cos(dth) = (rcenter/r) - (rradius/r)*cos(np*dphi) ! -!! ! -!! we then rotate this vector, holding its length=r*p constant and ! -!! successively estimating cdth (using the above equation as an ! -!! initial guess) until it intersects the locus curve; some algebra ! -!! yields the estimation equation as ! -!! ! -!! r**2 + 1 [sqrt(r*tanh(rp)) - q/sqrt(p)]**4 ! -!! [15] cdthnew= ------- - ---------------------------------------- ! -!! 2*r 2*r*[tanh(p*sqrt(r**2-2*r*cdthold+1))]**2! -!! ! -!! we use a weighted new estimate of cdthold with the weights based ! -!! on the argument of the tanh() function in the denominator ! -!! (if the argument is big, tanh() -> 1 and cdthnew is found in one ! -!! pass; for small arguments, convergence is faster with equal ! -!! weighting of old and new estimates; all this is empirical to try ! -!! to increase speed); double precision is used to gain enough ! -!! accuracy when the arccos is taken; note that if p is big enough ! -!! for all tanh()'s -> 1, [15] is exact and ! -!! cdthnew = cdth = [r**2 + 1 - (sqrt(r) - qrtp)**4]/(2*r) ! -!! ! -!! -----------------------------------------------------------------# -!! -!! - rcenter = 0.5 * (rmax + rmin) - rradius = 0.5 * (rmax - rmin) - t1 = rradius**2 + rcenter**2 - t2 = 2. * rradius * rcenter - dphi = 6.283185308 / float(npts) - pxod = px / dep - pyod = py / dep -!! - dbp = dble(p) - dbqrtp = dble(qrtp) -!! -!! + !! + rmax = rold + !! + !! set (dimensional) wavenumber components for this locus point + !! + wk2x(np2p1) = rmax * px / dep + wk2y(np2p1) = rmax * py / dep + wk4x(np2p1) = (rmax-1.) * px / dep + wk4y(np2p1) = (rmax-1.) * py / dep + !! + !! + !! -----------------------------------------------------------------# + !! ! + !! search for cos(dth) for off-p-vector solutions; use a circle ! + !! centered on the p-vector axis at a distance ! + !! rcenter = 0.5*(rmax+rmin) from the origin with a ! + !! radius = 0.5*(rmax-rmin); radii from the center of the circle ! + !! at successive angle increments np*dphi intersect the circle at ! + !! distances r*p from the origin of the p vector such that ! + !! ! + !! [13] r**2 = rradius**2 + rcenter**2 - ! + !! 2*rcenter*rradius*cos(np*dphi) ! + !! ! + !! and makes an angle dth with the p vector satisfying ! + !! ! + !! [14] cdth = cos(dth) = (rcenter/r) - (rradius/r)*cos(np*dphi) ! + !! ! + !! we then rotate this vector, holding its length=r*p constant and ! + !! successively estimating cdth (using the above equation as an ! + !! initial guess) until it intersects the locus curve; some algebra ! + !! yields the estimation equation as ! + !! ! + !! r**2 + 1 [sqrt(r*tanh(rp)) - q/sqrt(p)]**4 ! + !! [15] cdthnew= ------- - ---------------------------------------- ! + !! 2*r 2*r*[tanh(p*sqrt(r**2-2*r*cdthold+1))]**2! + !! ! + !! we use a weighted new estimate of cdthold with the weights based ! + !! on the argument of the tanh() function in the denominator ! + !! (if the argument is big, tanh() -> 1 and cdthnew is found in one ! + !! pass; for small arguments, convergence is faster with equal ! + !! weighting of old and new estimates; all this is empirical to try ! + !! to increase speed); double precision is used to gain enough ! + !! accuracy when the arccos is taken; note that if p is big enough ! + !! for all tanh()'s -> 1, [15] is exact and ! + !! cdthnew = cdth = [r**2 + 1 - (sqrt(r) - qrtp)**4]/(2*r) ! + !! ! + !! -----------------------------------------------------------------# + !! + !! + rcenter = 0.5 * (rmax + rmin) + rradius = 0.5 * (rmax - rmin) + t1 = rradius**2 + rcenter**2 + t2 = 2. * rradius * rcenter + dphi = 6.283185308 / float(npts) + pxod = px / dep + pyod = py / dep + !! + dbp = dble(p) + dbqrtp = dble(qrtp) + !! + !! do np=2,npts/2 !* np = 2 --> 15 -!! - cphi = cos(float(np-1)*dphi) - dbz = dsqrt(dble(t1-t2*cphi)) - cdthold = dble(rcenter-rradius*cphi) / dbz - dbt3 = (dbz*dbz) + 1.d0 - dbt4 = dbt3 / (2.d0*dbz) - dbt5 = ((dsqrt(dbz*dtanh(dbz*dbp))-dbqrtp)**4)/(2.d0*dbz) + !! + cphi = cos(float(np-1)*dphi) + dbz = dsqrt(dble(t1-t2*cphi)) + cdthold = dble(rcenter-rradius*cphi) / dbz + dbt3 = (dbz*dbz) + 1.d0 + dbt4 = dbt3 / (2.d0*dbz) + dbt5 = ((dsqrt(dbz*dtanh(dbz*dbp))-dbqrtp)**4)/(2.d0*dbz) + dbt6 = dbp * dsqrt(dbt3-2.d0*dbz*cdthold) + !! + if ( dbt6 .gt. 0.55d0 ) then + wate1 = dtanh(dbt6) + wate2 = 1.d0 - wate1 + else + wate1 = 0.5d0 + wate2 = 0.5d0 + end if + !! + do n=1,25 + cdthnew = dbt4 - dbt5 / ((dtanh(dbt6))**2) + if ( dabs(cdthnew-cdthold) .lt. 0.0000001d0 ) go to 71 + cdthold = wate1 * cdthnew + wate2 * cdthold dbt6 = dbp * dsqrt(dbt3-2.d0*dbz*cdthold) -!! - if ( dbt6 .gt. 0.55d0 ) then - wate1 = dtanh(dbt6) - wate2 = 1.d0 - wate1 - else - wate1 = 0.5d0 - wate2 = 0.5d0 - end if -!! - do n=1,25 - cdthnew = dbt4 - dbt5 / ((dtanh(dbt6))**2) - if ( dabs(cdthnew-cdthold) .lt. 0.0000001d0 ) go to 71 - cdthold = wate1 * cdthnew + wate2 * cdthold - dbt6 = dbp * dsqrt(dbt3-2.d0*dbz*cdthold) - end do - ierr_gr = ierr_gr + 100 !* add to 100's place for every failure - 71 continue -!! - dth = sngl(dacos(cdthnew)) - zpod = sngl(dbz) * p / dep -!! - wk2x(np) = zpod * cos(thp+dth) - wk2y(np) = zpod * sin(thp+dth) - wk4x(np) = wk2x(np) - pxod - wk4y(np) = wk2y(np) - pyod -!! - nnp = npts-np+2 !* for npts = 30 -!! !* nnp = 30 --> 17 -!! - wk2x(nnp) = zpod * cos(thp-dth) - wk2y(nnp) = zpod * sin(thp-dth) - wk4x(nnp) = wk2x(nnp) - pxod - wk4y(nnp) = wk2y(nnp) - pyod -!! + end do + ierr_gr = ierr_gr + 100 !* add to 100's place for every failure +71 continue + !! + dth = sngl(dacos(cdthnew)) + zpod = sngl(dbz) * p / dep + !! + wk2x(np) = zpod * cos(thp+dth) + wk2y(np) = zpod * sin(thp+dth) + wk4x(np) = wk2x(np) - pxod + wk4y(np) = wk2y(np) - pyod + !! + nnp = npts-np+2 !* for npts = 30 + !! !* nnp = 30 --> 17 + !! + wk2x(nnp) = zpod * cos(thp-dth) + wk2y(nnp) = zpod * sin(thp-dth) + wk4x(nnp) = wk2x(nnp) - pxod + wk4y(nnp) = wk2y(nnp) - pyod + !! end do ! do np=2,npts/2 -!! ------------------------------------------------------------------ -!! -!! - if ( ierr_gr .ne. 0 ) then - write ( ndse,1000 ) ierr_gr - CALL EXTCDE ( 60 ) - endif -!! ------------------------------------------------------------------ -!! -!! -!! set arc length ds as the sum of half the segment lengths on either -!! side of a given point -!! - ds1 = sqrt((wk2x(2)-wk2x(1))**2+(wk2y(2)-wk2y(1))**2) - ds(1) = ds1 + !! ------------------------------------------------------------------ + !! + !! + if ( ierr_gr .ne. 0 ) then + write ( ndse,1000 ) ierr_gr + CALL EXTCDE ( 60 ) + endif + !! ------------------------------------------------------------------ + !! + !! + !! set arc length ds as the sum of half the segment lengths on either + !! side of a given point + !! + ds1 = sqrt((wk2x(2)-wk2x(1))**2+(wk2y(2)-wk2y(1))**2) + ds(1) = ds1 do np=3,npts/2+1 - ds2 = sqrt((wk2x(np)-wk2x(np-1))**2+(wk2y(np)-wk2y(np-1))**2) - ds(np-1) = 0.5*(ds1+ds2) - ds(npts-np+3) = ds(np-1) - ds1 = ds2 + ds2 = sqrt((wk2x(np)-wk2x(np-1))**2+(wk2y(np)-wk2y(np-1))**2) + ds(np-1) = 0.5*(ds1+ds2) + ds(npts-np+3) = ds(np-1) + ds1 = ds2 end do - ds(npts/2+1) = ds2 -!! ------------------------------------------------------------------ -!! ================================================================== -!! - RETURN -!! - 1000 format ( ' W3SNL4 Error : In shlocr. Error from gridset ',i10) -!! - END SUBROUTINE shlocr -!! -!!============================================================================== -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE cplshr ( w1x0,w1y0, w2x0,w2y0, w3x0,w3y0, & - h, csq, irng,krng, kang,ipt ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! -!! it returns: the coupling coefficient csq -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!! 1. Purpose : -!! -!! -----------------------------------------------------------------# -!! ! -!! Calculates four-wave Boltzmann coupling coefficient in shallow ! -!! water given k1,k2,k3 and following at least Hasselmann (1962) ! -!! and probably Herterich and Hasselmann (1982). Dimensional ! -!! wavenumbers are (wnx0,wny0), n = 1,3, h = depth, csq = coupling ! -!! coefficient. This is the same as Don's cplesh, except within ! -!! the algorithm, wavenumbers are made dimensionless with h and ! -!! frequencies with sqrt(h/g), g = gravitational acceleration (the ! -!! idea is to simplify and speed up the calculations while keeping ! -!! a reasonable machine resolution of the result). At the end, ! -!! dimensionless csqhat is redimensioned as csq = csqhat/(h**6) ! -!! so it is returned as a dimensional entity. ! -!! ! -!! This calculation can be a touchy bird, so we use double precision! -!! for internal calculations, using single precision for input and ! -!! output. ! -!! ! -!! -----------------------------------------------------------------# -!! -!! 2. Method : -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! ------------------------------------------------------------------ -!! -!! 4. Subroutines used : -!! -!! Name Type Module Description -!! ------------------------------------------------------------------ -!! ------------------------------------------------------------------ -!! -!! 5. Called by : -!! -!! Name Type Module Description -!! ------------------------------------------------------------------ -!! gridsetr Subr. W3SNL4MD Setup geometric integration grid -!! ------------------------------------------------------------------ -!! -!! 6. Error messages : -!! -!! None. -!! -!! 7. Remarks : -!! -!! 8. Structure : -!! -!! See source code. -!! -!! 9. Switches : -!! -!! !/S Enable subroutine tracing. -!! -!!10. Source code : -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! - IMPLICIT NONE -!! -!! Parameter list -!! -------------- - integer, intent(in) :: irng,krng, kang,ipt - real, intent(in) :: w1x0,w1y0, w2x0,w2y0, w3x0,w3y0 - real, intent(in) :: h !* depth 'dep' - real, intent(out) :: csq -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! -!! -!! Local Parameters & variables -!! ----------------------------- - integer :: ipass - double precision :: hh - double precision :: s1, s2, s3 - double precision :: k1x, k2x, k3x - double precision :: k1y, k2y, k3y - double precision :: k1, k2, k3 - double precision :: om1, om2, om3 - double precision :: som1, som2, som3 - double precision :: om1sq, om2sq, om3sq - double precision :: k23, k23x, k23y - double precision :: dot23, dot123 - double precision :: omsq23 -!!mpc - double precision :: k1sq, k2sq, k3sq, k23sq - double precision :: tanh_k1, tanh_k2, tanh_k3, tanh_k23 -!!mpc--- - double precision :: k1x0, k2x0, k3x0, k1zx - double precision :: k1y0, k2y0, k3y0, k1zy - double precision :: di, e - double precision :: p1, p2, p3, p4 - double precision :: t1, t2, t3, t4, t5 -!! - double precision :: csqhatd, csqd - double precision :: scple - double precision :: pi4 -!! -!!eps Bash; added +eps to avoid dividing by 0.0. Dividing by 0.0 causes NaN -!eps double precision :: eps -!! -!! Bash; Added domsq23 = denominator of t1 in cplshr -!! and sumom = denominator of csqhatd in cplshr - double precision :: domsq23, sumom -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!! initial constants -!! ------------------ - hh = dble(h) !* single to dbl precision - pi4 = 0.785398175d0 !* Set = PI/4 as in CONSTANTS -!eps eps = 1.d-12 !* set eps to a very small number - scple = 0.d0 !* initialize accumulator -!!ini -!! initialize returned variable 'csq' -!! ---------------------------------- - csq = 0.d0 -!!ini--- -!! ------------------------------------------------------------------ -!! - do ipass=1,3 -!p1 - if (ipass .eq. 1) then !* initial pass (+1,+1,-1) - s1 = 1.d0 - s2 = 1.d0 - s3 = -1.d0 - k1x0 = dble(w1x0) * hh !* norm. k elements with h - k1y0 = dble(w1y0) * hh - k2x0 = dble(w2x0) * hh - k2y0 = dble(w2y0) * hh - k3x0 = dble(w3x0) * hh - k3y0 = dble(w3y0) * hh -!p1 -!p2 - else if (ipass .eq. 2) then !* 1st permutation (+1,-1,+1) - s1 = 1.d0 - s2 = -1.d0 - s3 = 1.d0 - k1zx = k1x0 - k1zy = k1y0 - k1x0 = k2x0 - k1y0 = k2y0 - k2x0 = k3x0 - k2y0 = k3y0 - k3x0 = k1zx - k3y0 = k1zy -!p2 -!p3 - else !* 2nd permutation (-1,+1,+1) - s1 = -1.d0 - s2 = 1.d0 - s3 = 1.d0 - k1zx = k1x0 - k1zy = k1y0 - k1x0 = k2x0 - k1y0 = k2y0 - k2x0 = k3x0 - k2y0 = k3y0 - k3x0 = k1zx - k3y0 = k1zy -!p3 - end if -!!k19p1 -!!k19p1 Note: na2p1=nang/2+1 !* this is the angle index opposite to iang=1 -!k19p1 if (krng.ne.irng .and. kang.eq.na2p1 .and. ipt.eq.1 .and. & -!k19p1 ipass.eq.1) go to 10 -!!k19p1--- -!! - k1x = s1 * k1x0 !* sign the norm'ed k parts - k1y = s1 * k1y0 - k2x = s2 * k2x0 - k2y = s2 * k2y0 - k3x = s3 * k3x0 - k3y = s3 * k3y0 -!!mpc -!mpc k1 = dsqrt(k1x**2 + k1y**2) !* normalized |k| -!mpc k2 = dsqrt(k2x**2 + k2y**2) -!mpc k3 = dsqrt(k3x**2 + k3y**2) -!!mpc--- - k1sq = (k1x*k1x + k1y*k1y) !* normalized |k| **2 - k2sq = (k2x*k2x + k2y*k2y) - k3sq = (k3x*k3x + k3y*k3y) - k1 = dsqrt(k1sq) !* normalized |k| - k2 = dsqrt(k2sq) - k3 = dsqrt(k3sq) -!!mpc--- -!! -!!mpc -!mpc om1 = dsqrt(k1*dtanh(k1)) !* norm. omega (by sqrt(h/g)) -!mpc om2 = dsqrt(k2*dtanh(k2)) -!mpc om3 = dsqrt(k3*dtanh(k3)) -!mpc om1sq = om1**2 -!mpc om2sq = om2**2 -!mpc om3sq = om3**2 -!!mpc--- - tanh_k1 = dtanh(k1) - tanh_k2 = dtanh(k2) - tanh_k3 = dtanh(k3) - om1sq = k1*tanh_k1 - om2sq = k2*tanh_k2 - om3sq = k3*tanh_k3 - om1 = dsqrt(om1sq) !* norm. omega (by sqrt(h/g)) - om2 = dsqrt(om2sq) - om3 = dsqrt(om3sq) -!!mpc--- -!! - som1 = s1 * om1 !* sign the norm'ed omega's - som2 = s2 * om2 - som3 = s3 * om3 -!! ---------------------------------------------------------------- -!! ================================================================ -!! -!! - dot23 = k2x*k3x + k2y*k3y !* vector k2 dot vector k3 -!! - k23x = k2x + k3x !* (vector k2 + vector k3)_x - k23y = k2y + k3y !* (vector k2 + vector k3)_y -!! -!!mpc -!mpc k23 = dsqrt(k23x**2+k23y**2) !* |vector k2 + vector k3| -!!mpc--- - k23sq = (k23x*k23x + k23y*k23y) - k23 = dsqrt(k23sq) !* |vector k2 + vector k3| -!!mpc--- -!! -!!mpc -!mpc omsq23 = k23 * dtanh(k23) !* norm sq frq of v.k2+v.k3 -!!mpc--- - tanh_k23 = dtanh(k23) - omsq23 = k23 * tanh_k23 !* norm sq frq of v.k2+v.k3 -!!mpc--- -!! - dot123 = k1x*k23x + k1y*k23y !* v.k1 dot (v.k2 + v.k3) -!! ---------------------------------------------------------------- -!! -!! note: the "i**2" factor from some reference is included in this term -!! -!!mpc -!mpc di = -(som2+som3)*(om2sq*om3sq-dot23)+0.5d0 * & -!mpc (som2*(k3**2-om3sq**2)+som3*(k2**2-om2sq**2)) -!!mpc--- - di = -(som2+som3)*(om2sq*om3sq-dot23)+0.5d0 * & - (som2*(k3sq-om3sq*om3sq)+som3*(k2sq-om2sq*om2sq)) -!!mpc--- -!! - e = 0.5d0*(dot23-som2*som3*(om2sq+om3sq+som2*som3)) -!! - p1 = 2.d0 * (som1+som2+som3) * (om1sq*omsq23 - dot123) -!! -!!mpc -!mpc p2 = -som1 * (k23**2 - omsq23**2) -!mpc p3 = -(som2+som3) * (k1**2 - om1sq**2) -!mpc p4 = k1**2 - om1sq**2 -!!mpc--- -!! equation p2 rewritten to preserve numerical precision -!! equations p3, p4 rearranged to avoid recomputations. - p2 = -som1 * (k23sq*(1 - tanh_k23*tanh_k23)) - p4 = (k1sq*(1-tanh_k1*tanh_k1)) - p3 = -(som2+som3) * p4 -!!mpc--- -!! ---------------------------------------------------------------- -!! -!! Bash; added & used variable domsq23 = denominator of t1 - domsq23 = omsq23 - ((som2+som3)**2) !* Bash; needed for test below -!! ---------------------------------------------------------------- -!! -!!cp4 Bash; with !cp4 ON, test if ( domsq23 .eq. 0.d0 ) -!cp4 if ( domsq23 .eq. 0.d0 ) then !* Bash; this test was needed -!! !* when !k19p1 & !hv were OFF -!! domsq23=0.0 Dividing by 0.0 causes NaN; here we avoid it -!cp4 t1 = 0.d0 -!eps t1 = di * (p1+p2+p3) / (domsq23+eps) !* Add eps to denominator -!! !* and may be to numerator -!cp4 endif -!!cp4--- -!! Bash; with !cp4 OFF, don't test if ( domsq23 .eq. 0.d0 ) -!! domsq23 is not = 0.0 (when !k19p1 & !hv were OFF) -!b t1 = di * (p1+p2+p3) / (omsq23 - ((som2+som3)**2)) - t1 = di * (p1+p2+p3) / (domsq23) -!!cp4--- -!! ---------------------------------------------------------------- -!! - t2 = -di * som1 * (om1sq+omsq23) - t3 = e * ((som1**3) * (som2+som3) - dot123 - p4) - t4 = 0.5d0 * som1 * dot23 * & - ((som1+som2+som3) * (om2sq+om3sq) + som2*som3*(som2+som3)) -!! -!!mpc -!mpc t5 = -0.5d0 * som1 * & -!mpc (om2sq * (k3**2) * (som1+som2 + 2.d0 * som3) + & -!mpc om3sq * (k2**2) * (som1+som3 + 2.d0 * som2)) -!!mpc--- - t5 = -0.5d0 * som1 * & - (om2sq * (k3sq) * (som1+som2 + 2.d0 * som3) + & - om3sq * (k2sq) * (som1+som3 + 2.d0 * som2)) -!!mpc--- -!! - scple = scple + t1 + t2 + t3 + t4 + t5 -!! - end do ! do ipass=1,3 -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!!as HH did division by 3 after adding 3 terms -!as scple = scple/3.d0 -!!as--- -!! -!! Bash; Added sumom = denominator of csqhatd in cplshr - sumom = om1*om2*om3*(om2+om3-om1) -!b csqhatd = scple*scple*pi4/(om1*om2*om3*(om2+om3-om1)) !* Bash; ok - csqhatd = scple*scple*pi4/(sumom) -!! ------------------------------------------------------------------ -!! - csqd = csqhatd / (hh**6) - csq = sngl(csqd) !* from dbl to single precision -!! ------------------------------------------------------------------ -!! ================================================================== -!! - RETURN -!! - END SUBROUTINE cplshr -!! -!!============================================================================== -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! ------------------------------------------------------------------ -!! -!! It returns variables dens1(nrng,nang) and dens2(nrng,nang) -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!! 1. Purpose : -!! -!! Splits the Action Density into two parts: -!! (1) large-scale part dens1(nrng,nang) and -!! (2) small-scale part dens2(nrng,nang) -!! dens1 & dens2 in Polar Action Density (k,theta) space Norm. (in k) -!! -!! 2. Method : -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!!op2 -!! nrmn int. Local I number of first freq. bin in [1,nrng-1] -!! nrmx int. Local I number of last freq. bin in [2,nrng] -!! npk int. Local I number of peak frequency in [2,nrng-1] -!! nbins int. Local I actual # of bins > npk (incl. nfs) or -!! actual # of bins > npk2 (incl. nrng) -!! to guarantee a min 1 bin in equi. range -!! (see subr. W3SNL4) -!! ------------------------------------------------------------ !!op2 -!! -!! nrng int. Public I # of freq. or rings -!! nang int. Public I # of angles -!! -!! dfrq Real Public I freq mult. for log freq spacing -!! fpk Real Public I peak freq. [Hz] of initial freq spectrum -!! oma R.A. Public I rel. freq. array (rad*Hz) ----- dim=(nrng) -!! frqa R.A. Public I radian frequencies (Hz) ------- dim=(nrng) -!! -!! ainc Real Public I angle increment (radians) -!! angl R.A. Public I dir. array (rad) (full circle); dim=(nrng) -!! cosan R.A. Public I cosine angles array ----------- dim=(nang) -!! sinan R.A. Public I sine angles array ----------- dim=(nang) -!! ------------------------------------------------------------------ -!! -!! wka R.A. Local I wavenumbers array [1/m] ------- dim=(nrng) -!! cga R.A. Local I group velocities array [m/s] -- dim=(nrng) -!! wka & cga arrays are corrsp. to depth 'dep' -!! ------------------------------------------------------------------ -!! -!! ef2 R.A. Public I 2D Energy Density spectrum ef2(theta,f) -!! = A(theta,k)*2*pi*oma(f)/cga(f) dim=(nrng,nang) -!! ef1 R.A. Public I 1D Energy Density spectrum ef1(f) dim=(nrng) -!! ------------------------------------------------------------------ -!! -!! dens1 R.A. Public O large-scale Action Density (k,theta) -!! dim=(nrng,nang) -!! dens2 R.A. Public O Small-scale Action Density (k,theta) -!! dim=(nrng,nang) -!! ------------------------------------------------------------------ -!! -!! 4. Subroutines used : -!! -!! Name Type Module Description -!! ------------------------------------------------------------------ -!! ------------------------------------------------------------------ -!! -!! 5. Called by : -!! -!! Name Type Module Description -!! ------------------------------------------------------------------ -!! gridsetr Subr. W3SNL4MD Setup geometric integration grid -!! ------------------------------------------------------------------ -!! -!! 6. Error messages : -!! -!! None. -!! -!! 7. Remarks : -!! -!! 8. Structure : -!! -!! See source code. -!! -!! 9. Switches : -!! -!! !/S Enable subroutine tracing. -!! -!!10. Source code : -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! -!! - IMPLICIT NONE -!! -!! -!! -!! Parameter list -!! -------------- -!!op2 Bash; new for optsa2 - integer, intent(in) :: nrmn, nrmx, nbins -!! ------------------------------------------------------------ !!op2 -!! - integer, intent(in) :: npk - real, intent(in) :: fpk - real, intent(in) :: wka(nrng), cga(nrng) -!! ------------------------------------------------------------------ -!! -!! -!! Local Parameters & variables -!! ----------------------------- - integer :: irng, iang -!! -!!p2 -!! Bash; Uses of original "psi2(:)", it was very bad (see below) -!p2 integer :: n1, n2, m, mm -!p2 integer :: nn1, nn2, ii, idif -!p2 real :: q(16) -!p2 real :: emax -!p2 real :: y, qmin, adif -!!p2--- -!! -!!p3 -!! Bash; This is an attempt to replace the original psi2(:) -!! with a distr. based on sin()**mm with 'newmaxang' -!! - not good enough (see below) -!! !!p4 is an override of !!p3 with mm=4 -!p3 integer :: n1, n2, m, mm -!p3 real :: q(16) -!p3 real :: y, qmin, adif -!! The var. below are needed to find 'newmaxang' used in !p3 & !p4 - integer :: maxang, newmaxang - integer :: maxangshift - integer :: halfangl, halfangu - real :: ef2maxrow(nang) - real :: ef2shift(nang) - real :: halfmax -!!p3--- -!! -!!p4 -!! Bash; !!p4 is an override of !!p3 with mm=4 - integer :: n1, n2 - real :: q4 -!!p4--- -!! -!!eq -!! Bash; Use variable equi. range suitable to TSA min condition -!! simplifed to one point equi. range nearest to 2.*fp -!eq integer :: neq -!eq real :: fovfp -!!eq--- -!! - integer :: igam - real :: sum1, fac - real :: beta, gam - real :: fdenp, fr, ratio, z, ddd - real :: sigz !* sigz = 0.109 - real :: fk(nrng), fknrm(nrng) - real :: bscl1(nrng), fkscl1(nrng) - real :: psi2(nang) - real :: act2d(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!!ini -!! Bash; initialize psi2() array here - psi2(:) = 0.0 -!! -!! Initialize all the 1d & 2d arrays that are being used -!! and especially those that are being returned - fk(:) = 0.0 - fknrm(:) = 0.0 - fkscl1(:) = 0.0 - bscl1(:) = 0.0 - act2d(:,:) = 0.0 - dens1(:,:) = 0.0 - dens2(:,:) = 0.0 -!!ini--- -!! ------------------------------------------------------------------ -!! -!! -!!* Convert 2D Energy Density ef2(f,theta) -!! to 2D Polar Action Density act2d(k,theta) Norm. (in k) - do irng=nrmn,nrmx - fac = cga(irng)/(twopi*oma(irng)*wka(irng)) - do iang=1,nang - act2d(irng,iang) = ef2(irng,iang) * fac - end do -!! -!!* Convert ef1(f) to fk(k); both are 1d Energy Density - fk(irng) = cga(irng)*ef1(irng)/twopi !* fk(k) energy -!! -!!* Normalize the 1d wavenumber Energy Density fk(k) to give fknrm(k) - fknrm(irng) = fk(irng)*wka(irng)**2.5 !* fknrm(k) = Norm. fk(k) - end do -!! ------------------------------------------------------------------ -!! -!! -!! Fit parameters to spectrum -!! -------------------------- -!!eq -!eq sum1 = 0. -!eq neq = 0 -!eq do 26 irng=nrmn,nrmx -!eq fovfp = frqa(irng)/fpk -!! Bash; check2 test equilibrium range -!b if ( fovfp.ge.1.55.and.fovfp.le.2.45 ) then !* orig equi range -!b if ( fovfp.ge.1.20.and.fovfp.le.2.20 ) then !* wide equi range -!b if ( fovfp.ge.1.90.and.fovfp.le.2.20 ) then !* narrow equi range -!! --------------------------------------------------------------!* <<<<< -!! Bash; select variable equi. range suitable to TSA min condition -!eq if ( fovfp.ge.(dfrq**(nbins))-0.005 .and. & -!eq fovfp.le.(dfrq**(nbins))+0.005 ) then !* narrow equi range <<<<< -!! --------------------------------------------------------------!* <<<<< -!eq sum1 = sum1 + fknrm(irng) -!eq neq = neq + 1 -!eq endif -! 26 end do -!eq beta = sum1 / neq -!eq gam = fknrm(npk) / beta -!!eq--- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! Simplify - beta = fknrm(npk+nbins) - gam = fknrm(npk) / beta -!!eq--- -!! ------------------------------------------------------------------ -!! - do irng=nrmn,nrmx - fknrm(irng) = fknrm(irng) / beta - end do -!! ================================================================== -!! -!! -!!p2 -!! Construct Directional Distribution "psi2(:)" - original option -!! ------------------------------------------------------------------ -!! -!! Solve for Normalizing Coefficient for Integral [1.0/(cos**m)] -!! Note: n1, n2 spans half circle (from -pi/2 to +pi/2 going through 0.) -!p2 n1 = -nang/4 + 1 -!p2 n2 = nang/4 + 1 -!p2 do m=1,16 -!p2 sum1 = 0. -!p2 do iang=n1,n2 -!p2 ii = iang -!p2 if ( iang .lt. 1 ) ii = iang + nang -!p2 sum1 = sum1 + cosan(ii)**m -! end do -!p2 q(m) = 1./(sum1*ainc) -! end do -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! Find peak direction "maxang" in ef2() at "npk" the peak in ef1() -!! needed to define the energy spreading factor y=ef2(npk,maxang)/ef1(npk) -!! Bash; Note; This original "psi2(:)" was simply very bad because the drift -!! in "maxang" location causing the 2D Snl to lose symmetry -!p2 emax = 0. -!p2 maxang = 0 -!p2 do iang=1,nang -!p2 if ( ef2(npk,iang).gt.emax ) then -!p2 emax = ef2(npk,iang) -!p2 maxang = iang !* in [1,nang] -!p2 endif -! end do -!p2 y = ef2(npk,maxang)/ef1(npk) !* Bash; Energy Spread -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! Compare value of peak with q-array for closest fit to cos()**m at peak -!p2 mm = 1 -!p2 qmin = abs(q(1)-y) -!p2 do m=2,16 -!p2 adif = abs(q(m)-y) -!p2 if ( adif.lt.qmin ) then -!p2 qmin = adif -!p2 mm = m -!p2 endif -! end do -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!p2 nn1 = maxang - nang/4 !* nn1 in [-8, 27], -ve/+ve (incl. 0) -!p2 nn2 = maxang + nang/4 !* nn2 in [10, 45], all +ve (no 0) -!p2 do iang=nn1,nn2 !* Bash; nn1 -> nn2 covers half circle -!p2 ii = iang !* ii always in range [1,nang] -!p2 if ( ii .lt. 1 ) ii = ii + nang !* "" -!p2 if ( ii .gt. nang ) ii = ii - nang !* "" -!p2 idif = iabs(maxang-iang) + 1 !* =10,9,..,2,1,2,..,9,10 -!p2 psi2(ii) = q(mm) * cos(angl(idif))**mm !* Normalized psi2 distr. -! end do -!!p2--- -!! ================================================================== -!! -!! -!!p3 -!! Construct New Directional Distribution "psi2(:)" -!! In an attempt to replace the original psi2(:) with -!! a distribution based on sin()**mm with 'newmaxang' - not good enough -!! ------------------------------------------------------------------ -!! -!! Solve for Normalizing Coefficient for Integral [1.0/(sin()**m)] -!! Note: n1, n2 spans half circle (from 0 to +pi) -!p3 n1 = 1 -!p3 n2 = nang/2 + 1 -!p3 do m=1,16 -!p3 sum1 = 0. -!p3 do iang=n1,n2 -!p3 sum1 = sum1 + sinan(iang)**m -! end do -!p3 q(m) = 1./(sum1*ainc) -! end do -!!p3--- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!!p3 - ef2maxrow(:) = ef2(npk,:) - maxang = MAXLOC(ef2maxrow,1) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! Shift the row so that the max is at location of 90 degress -!! Negative shift is to the right, Postive to the left -!! halfangl - lower angular limit of the half maximum -!! halfangu - upper angular limit of the half maximum - ef2shift(:) = CSHIFT( ef2maxrow(:), (maxang-1-nang/4) ) - halfangu = nang/4+2 - halfangl = nang/4 -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! - halfmax = 0.5 * ef2(npk,maxang) - do while((ef2shift(halfangu).gt.halfmax).and.(halfangu.lt.nang/2)) - halfangu = halfangu + 1 - enddo - do while((ef2shift(halfangl).gt.halfmax).and.(halfangl.gt.1)) - halfangl = halfangl - 1 - enddo -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! Convert angles indices with respect to peak -!! e.g. halfangl should go to halfangl - (nang/4+1) -!! halfangu should go to halfangu - (nang/4+1) - halfangl = halfangl - (nang/4+1) - halfangu = halfangu - (nang/4+1) -!! -!! Now average the positions, round to nearest integer. -!! -ve result means the centre is one greater than it should be. - maxangshift = NINT( 0.5 * (halfangl + halfangu) ) - newmaxang = maxang + maxangshift - if (newmaxang .lt. 1) newmaxang = newmaxang + nang - if (newmaxang .gt. nang) newmaxang = newmaxang - nang -!!p3--- -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!!p3 -!! Bash; need this section if you want to try sin()**mm with 'newmaxang' -!p3 y = ef2(npk,newmaxang) / ef1(npk) !* New Energy Spread -!! -!! Compare value of peak with q-array for closest fit to sin()**m at peak -!! This !p3 section is needed for use with sin()**mm -!! Bash; Note; This new "psi2(:)" although better than original "psi2(:)" -!! it was still not good enough: the 2D Energy was OK but -!! the 2D Snl, now with better symmetry, didn't always have the side lobes. -!p3 mm = 1 -!p3 qmin = abs(q(1)-y) -!p3 do m=2,16 -!p3 adif = abs(q(m)-y) -!p3 if ( adif.lt.qmin ) then -!p3 qmin = adif -!p3 mm = m -!p3 endif -! end do -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! Final step, use 'mm' for sin()**mm -!p3 psi2(n1:n2) = (sinan(n1:n2))**mm !* Un-norm. psi2 distr. -!p3 psi2(n1:n2) = q(mm) * psi2(n1:n2) !* Norm. psi2 distr. -!! Rotate peak to correct angle -!p3 psi2(:) = CSHIFT( psi2(:), newmaxang-1+nang/4 ) -!!p3--- -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!!p4 -!! !!p4 is an override of !!p3 with mm=4, so go straight to Final step -!! Note; all you need from !!p3 is the "newmaxang" -!! So it's a sin()**4 distr. shifted to "newmaxang" - worked very well -!! ------------------------------------------------------------------ -!! -!! Solve for Normalizing Coefficient for Integral [1.0/(sin()**4)] -!! Note: n1, n2 spans half circle (from 0 to +pi) - n1 = 1 - n2 = nang/2 + 1 -!p4 sum1 = 0. -!p4 do iang=n1,n2 -!p4 sum1 = sum1 + sinan(iang)**4 -! end do -!p4 q4 = 1.0/(sum1*ainc) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! Change the angles that aren't zero (0 deg to +180 deg) - psi2(n1:n2) = (sinan(n1:n2))**4 !* Un-norm. psi2 distr. - q4 = 1.0/(SUM(psi2(n1:n2))*ainc) - psi2(n1:n2) = q4 * psi2(n1:n2) !* Norm. psi2 distr. -!! -!! Rotate peak to correct angle - psi2(:) = CSHIFT( psi2(:), newmaxang-1+nang/4 ) -!!p4--- -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!! -!! Estimate parametric spectrum and deviation from parametric spectrum -!! ------------------------------------------------------------------ - igam = (gam-0.4)*10 + 0.5 - sigz = 0.109 - gam = igam/10. + 0.4 - fdenp = gam * beta / wka(npk)**2.5 -!! -!! - do irng=nrmn,nrmx - fr = frqa(irng) / fpk - if ( fr.le.1.0001 ) then - if ( fr.ge.0.85 ) then - ratio = 1.-(1.-fr)*0.7/0.15 - else - ratio = 0.3*exp(-17.3*(0.85-fr)) - endif - fkscl1(irng) = fdenp*ratio - bscl1(irng) = fkscl1(irng)/oma(irng) - else - z = 0.5*((fr-1.)/sigz)**1.2 - if ( z.gt.6. ) z = 6. - ratio = 1.+exp(-z)*(gam-1.) - fkscl1(irng) = beta*ratio/wka(irng)**2.5 - bscl1(irng) = fkscl1(irng)/oma(irng) - endif -!! - do iang=1,nang - ddd = bscl1(irng) * psi2(iang) / wka(irng) !* large-scale - dens1(irng,iang) = ddd !* large-scale - dens2(irng,iang) = act2d(irng,iang) - ddd !* small-scale - end do - end do ! do irng=nrmn,nrmx -!! ------------------------------------------------------------------ -!! ================================================================== -!! - RETURN -!! - END SUBROUTINE optsa2 -!! -!!============================================================================== -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE snlr_fbi ( pha, ialt ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! ------------------------------------------------------------------ -!! -!! it returns: fbi & diag2 all dim=(nrng,nang) -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!! 1. Purpose : -!! -!! -----------------------------------------------------------------# -!! ! -!! For a given Action Density array dens1(k,theta), computes the ! -!! rate-of-change array sumint(k,theta) = dN(k,theta)/dt owing to ! -!! wave-wave interaction, as well as some ancillary arrays ! -!! relating to positive and negative fluxes and their integrals. ! -!! ! -!! -----------------------------------------------------------------# -!! ! -!! Compute: ! -!! -------- ! -!! for both -tsa and -fbi ! -!! + sumint contains scale 1 contibution for Snl -tsa & Snl -fbi ! -!! ! -!! for -tsa ! -!! + sumintsa contains tsa approximation to Snl -tsa ! -!! ! -!! for -fbi ! -!! + sumintp contains scale 2 contribution to Snl -fbi ! -!! + sumintx contains cross interactions between scales 1 and 2 ! -!! -----------------------------------------------------------------# -!! -!! 2. Method : -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! nrng int. Public I # of freq. or rings -!! nang int. Public I # of angles -!! npts int. Public I # of points on the locus -!! nzz int. Public I linear irng x krng = (NK*(NK+1))/2 -!! ialt int. Public I integer switch ialt=2; do alternate -!! ialt=1; do not alternate -!! kzone int. Public I zone of influence = INT(alog(4.0)/alog(dfrq)) -!! na2p1 int. Public I = nang/2 + 1 -!! np2p1 int. Public I = npts/2 + 1 -!! dfrq real Public I frequency multiplier for log freq. spacing -!! frqa R.A. Public I radian frequencies (Hz); dim=(nrng) -!! pha R.A. local I pha = k*dk*dtheta ; dim=(nrng) -!! ------------------------------------------------------------------ -!! -!! *** The 11 grid integration geometry arrays at one given depth -!! *** from gridsetr. dim=(npts,nang,nzz,ndep) -!! kref2 I.A. Public I Index of reference wavenumber for k2 -!! kref4 I.A. Public I Idem for k4 -!! jref2 I.A. Public I Index of reference angle for k2 -!! jref4 I.A. Public I Idem for k4 -!! wtk2 R.A. Public I k2 Interpolation weigth along wavenumbers -!! wtk4 R.A. Public I Idem for k4 -!! wta2 R.A. Public I k2 Interpolation weigth along angles -!! wta4 R.A. Public I Idem for k4 -!! tfac2 R.A. Public I Norm. for interp Action Density at k2 -!! tfac4 R.A. Public I Idem for k4 -!! grad R.A. Public I Coupling and gradient term in integral -!! grad = C * H * g**2 * ds / |dW/dn| -!! ------------------------------------------------------------------ -!! -!! *** large & small scale Action Density from optsa dim=(nrng,nang) -!! dens1 R.A. Public I lrg-scl Action Density (k,theta); -!! dens2 R.A. Public I Sml-scl Action Density (k,theta); -!! ------------------------------------------------------------------ -!! -!! for both -tsa and -fbi -!! sumint R.A. local O contains scale 1 contribution to Snl -!! dim=(nrng,nang) -!! for -tsa -!! sumintsa R.A. local O contains tsa approximation to Snl -tsa -!! dim=(nrng,nang) -!! for -fbi -!! sumintp R.A. local O contains scale 2 contribution to Snl -fbi -!! dim=(nrng,nang) -!! sumintx R.A. local O contains cross interactions " " " -fbi -!! dim=(nrng,nang) -!! ------------------------------------------------------------------ -!! -!! for -tsa; The 2 returned arrays tsa & diag dim=(nrng,nang) -!! tsa R.A. Public O Snl-tsa = sumint + sumintsa -!! diag R.A. Public O Snl-tsa diagonal term = [dN/dn1] -!! ------------------------------------------------------------------ -!! -!! for -fbi; The 2 returned arrays fbi & diag2 dim=(nrng,nang) -!! fbi R.A. Public O Snl-fbi = sumint + sumintp + sumintx -!! diag2 R.A. Public O Snl-fbi diagonal term = [dN/dn1] -!! ------------------------------------------------------------------ -!! -!! 4. Subroutines used : -!! -!! Name Type Module Description -!! ---------------------------------------------------------------- -!! ---------------------------------------------------------------- -!! -!! 5. Called by : -!! -!! Name Type Module Description -!! ---------------------------------------------------------------- -!! gridsetr Subr. W3SNL4MD Setup geometric integration grid -!! ---------------------------------------------------------------- -!! -!! 6. Error messages : -!! -!! None. -!! -!! 7. Remarks : -!! -!! 8. Structure : -!! -!! See source code. -!! -!! 9. Switches : -!! -!! !/S Enable subroutine tracing. -!! -!!10. Source code : -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! - IMPLICIT NONE -!! -!! Parameter list -!! -------------- - real, intent(in) :: pha(nrng) - integer, intent(in) :: ialt -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! -!! -!! Local Parameters & variables -!! ----------------------------- -!! for both -tsa and -fbi - integer :: irng,krng, iang,kang - integer :: ipt, iizz, izz - integer :: kmax - integer :: ia2, ia2p, k2, k2p - integer :: ia4, ia4p, k4, k4p - integer :: nref -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for -tsa -!tsa integer :: nklimit, nalimit -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for both -tsa and -fbi - real :: d1, d3, d2, d4 - real :: dp1, dp3 -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for both -tsa and -fbi -!! but for -tsa they are being calc. inside if/endif if test is successful -!! and for -fbi they are being calc. outside if/endif always - real :: dz4, dz5 -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for both -tsa and -fbi - real :: dx13, ds13, dxp13, dsp13 - real :: dgm, t31, tr31 - real :: w2, w2p, wa2, wa2p, d2a, d2b, tt2 - real :: w4, w4p, wa4, wa4p, d4a, d4b, tt4 - real :: sumint(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for -tsa -!tsa real :: dz2a, dz3a, ttsa, trtsa -!tsa real :: ddn1, ddn3, diagk1, diagk3 -!tsa real :: sumintsa(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for -fbi - real :: dp2, dp4 - real :: d2pa, d4pa - real :: d2pb, d4pb - real :: dz1, dz2, dz3, dz6, dz7, dz8 - real :: dgmp, tp31, trp31, dzsum, txp31, trx31 -!! -!! for -fbi; Bash added 4 new terms for a full expression of diag2 term - real :: ddp1, ddp2, ddp3, ddp4 !* ddpi=di+dpi for i=1,4 - real :: dd2n1, dd2n3, diag2k1, diag2k3 - real :: sumintp(nrng,nang) - real :: sumintx(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!! for -tsa -!! Bash; hardwire these two parameters -!tsa nklimit = 6 -!tsa nalimit = 6 -!! -!! -!!ini -!! Bash; move initialization of all returned arrays from below to here -!! ------------------------------------------------------------------ -!! for both -tsa and -fbi -!! sumint is now initialized here instead of below! - sumint(:,:) = 0.0 -!! -!! for -tsa -!! sumintsa are now initialized here instead of below! -!tsa sumintsa(:,:) = 0.0 -!tsa tsa(:,:) = 0.0 -!tsa diag(:,:) = 0.0 -!! -!! for -fbi -!! sumintp and sumintx are now initialized here instead of below! - sumintp(:,:) = 0.0 - sumintx(:,:) = 0.0 - fbi(:,:) = 0.0 - diag2(:,:) = 0.0 -!!ini--- -!! ------------------------------------------------------------------ -!! ------------------------------------------------------------------ -!! ################################################################## -!! -!! -!! for -tsa -!tsa ddn1 = 0.0 !* for -tsa diag [dN/dn1] -!tsa ddn3 = 0.0 !* for -tsa diag [dN/dn3] -!! -!! for -fbi - dd2n1 = 0.0 !* for -fbi diag2 [dN/dn1] - dd2n3 = 0.0 !* for -fbi diag2 [dN/dn3] -!! -!! -!! -!!50 - do 50 irng=1,nrng,ialt -!!kz - kmax = min(irng+kzone, nrng) !* Bash; Sometimes a locus pt is outside nrng -!kz kmax = min(irng+kzone, nrng-1) !* Bash; Taking 1 out will not affect kzone, try it -!!kz--- -!! - iizz = (nrng-1)*(irng-1) - ((irng-2)*(irng-1))/2 -!! ---------------------------------------------------------------- -!! -!! -!!60 - do 60 iang=1,nang,ialt -!! -!! for both -tsa and -fbi - d1 = dens1(irng,iang) - dp1 = dens2(irng,iang) -!! -!! for -fbi - ddp1 = d1+dp1 !! for full expression of diag2 term -!! -!!70 -!!kz -!kz do 70 krng=irng,nrng - do 70 krng=irng,kmax,ialt -!! -!! for both -tsa and -fbi -!! Bash; check5 be consistent with gridsetr -!! moved here from below (was after do 80 kang=1,nang) -!! and changed go to 80 into go to 70 (i.e. go to next krng) -!kz if ( frqa(krng)/frqa(irng) .gt. 4. ) go to 70 !* original gridsetr -!kz if ( frqa(krng)/frqa(irng) .gt. 3. ) go to 70 !* original snlr_'s -!kz if ( frqa(krng)/frqa(irng) .gt. 2. ) go to 70 !* Bash; use .gt. 2 -!!kz--- -!! - izz = krng + iizz -!! ------------------------------------------------------------ -!! -!!80 - do 80 kang=1,nang,ialt -!! -!! for both -tsa and -fbi -!!ba1 Bash; Remove self interaction -!! skip k1 but keep the opposite angle to k1 - original setting - if ( krng.eq.irng ) then !* wn3 = wn1 - if ( kang.eq.iang ) go to 80 !* th3 = th1 - endif -!!ba1--- -!! ---------------------------------------------------------- -!! -!! for both -tsa and -fbi - d3 = dens1(krng,kang) - dp3 = dens2(krng,kang) -!! -!! for -fbi - ddp3 = d3+dp3 !! for full expression of diag2 term -!! -!! -!! for both -tsa and -fbi - nref = kang - iang + 1 - if ( nref .lt. 1 ) nref = nref + nang -!! -!! -!! for both -tsa and -fbi -!! Bash; check5 be consistent with gridsetr -!! and move this test above right after do 70 krng=irng,nrng -!x if ( frqa(krng)/frqa(irng) .gt. 4. ) go to 80 !* gridsetr -!b if ( frqa(krng)/frqa(irng) .gt. 3. ) go to 80 !* original -!! -!! -!! for both -tsa and -fbi - t31 = 0.0 !* must be reset to 0.0 -!! -!! for -tsa -!tsa ttsa = 0.0 !* must be reset to 0.0 -!tsa diagk1 = 0.0 !* must be reset to 0.0 -!tsa diagk3 = 0.0 !* must be reset to 0.0 -!! -!! for -fbi - tp31 = 0.0 !* must be reset to 0.0 - txp31 = 0.0 !* must be reset to 0.0 - diag2k1 = 0.0 !* must be reset to 0.0 - diag2k3 = 0.0 !* must be reset to 0.0 -!! -!! for both -tsa and -fbi - dx13 = d1*d3 - ds13 = d3-d1 - dxp13 = dp1*dp3 - dsp13 = dp3-dp1 -!! ---------------------------------------------------------- -!! -!!90 - do 90 ipt=1,npts -!! -!! for both -tsa and -fbi -!! save time by skipping insignificant contributions -!!e-30 -!e-30 if ( grad(ipt,nref,izz) .lt. 1.e-30 ) go to 90 -!!e-30--- - if ( grad(ipt,nref,izz) .lt. 1.e-15 ) go to 90 -!!e-30--- -!! -------------------------------------------------------- -!! -!!xlc1 Bash; skip k1 but keep the opposite angle to k1 - original setting -!xlc1 if ( kang.eq.iang ) then !* th3=+th1 -!xlc1 if (ipt.eq.1 .or. ipt.eq.np2p1) go to 90 !* skip x-axis loci -!xlc1 end if -!!xlc1--- -!! -------------------------------------------------------- -!! -!! -!!2 Estimation of Density for wave #2 -!! -!! for both -tsa and -fbi - k2 = kref2(ipt,nref,izz) - k2p = k2 + 1 - w2 = wtk2(ipt,nref,izz) - w2p = 1. - w2 -!! -!! for both -tsa and -fbi - ia2 = iang + jref2(ipt,nref,izz) - if ( ia2 .gt. nang ) ia2 = ia2 - nang -!! -!! for both -tsa and -fbi - ia2p = ia2 + 1 - if ( ia2p .gt. nang ) ia2p = ia2p - nang -!! -!! for both -tsa and -fbi - wa2 = wta2(ipt,nref,izz) - wa2p = 1. - wa2 - d2a = w2 * dens1(k2,ia2) + w2p * dens1(k2p,ia2) - d2b = w2 * dens1(k2,ia2p) + w2p * dens1(k2p,ia2p) - tt2 = tfac2(ipt,nref,izz) - d2 = (wa2*d2a + wa2p*d2b) * tt2 -!! -!! for -fbi - d2pa = w2 * dens2(k2,ia2) + w2p * dens2(k2p,ia2) - d2pb = w2 * dens2(k2,ia2p) + w2p * dens2(k2p,ia2p) -!! -!! for -fbi - dp2 = (wa2*d2pa + wa2p*d2pb) * tt2 !* for -fbi - ddp2 = d2+dp2 !! for full expression of diag2 term -!! ======================================================== -!! -!! -!!4 Estimation of Density for wave #4 -!! -!! for both -tsa and -fbi - k4 = kref4(ipt,nref,izz) - k4p = k4 + 1 - w4 = wtk4(ipt,nref,izz) - w4p = 1. - w4 -!! -!! for both -tsa and -fbi - ia4 = iang + jref4(ipt,nref,izz) - if ( ia4 .gt. nang ) ia4 = ia4 - nang -!! -!! for both -tsa and -fbi - ia4p= ia4 + 1 - if ( ia4p .gt. nang ) ia4p = ia4p - nang -!! -!! for both -tsa and -fbi - wa4 = wta4(ipt,nref,izz) - wa4p = 1. - wa4 - d4a = w4*dens1(k4,ia4) + w4p*dens1(k4p,ia4) - d4b = w4*dens1(k4,ia4p) + w4p*dens1(k4p,ia4p) - tt4 = tfac4(ipt,nref,izz) - d4 = (wa4*d4a + wa4p*d4b) * tt4 -!! -!! for -fbi - d4pa = w4*dens2(k4,ia4) + w4p*dens2(k4p,ia4) - d4pb = w4*dens2(k4,ia4p) + w4p*dens2(k4p,ia4p) -!! -!! for -fbi - dp4 = (wa4*d4pa + wa4p*d4pb) * tt4 !* for -fbi - ddp4 = d4+dp4 !! for full expression of diag2 term -!! ======================================================== -!! -!! -!! for both -tsa and -fbi - dgm = dx13*(d4-d2) + ds13*d4*d2 !* dgm=B of R&P'08 eqn(8) -!! !* represents Broad Scale interactions - t31 = t31 + dgm * grad(ipt,nref,izz) -!! -------------------------------------------------------- -!! -!! for -fbi - dgmp = dxp13*(dp4-dp2) + dsp13*dp4*dp2 !* dgmp=L of R&P'08 eqn(8) -!! !* represents Local Scale interactions - tp31 = tp31 + dgmp * grad(ipt,nref,izz) -!! -------------------------------------------------------- -!! ======================================================== -!! -!! -!! for -tsa : -diag -!! use this expression for the diagonal term -!! whose derivation neglect "dp2" & "dp4" -!tsa ddn1 = (d3+dp3)*(d4-d2) - d4*d2 !* dN/dn1 -!tsa ddn3 = (d1+dp1)*(d4-d2) + d4*d2 !* dN/dn3 -!tsa diagk1 = diagk1 + ddn1 * grad(ipt,nref,izz) -!tsa diagk3 = diagk3 + ddn3 * grad(ipt,nref,izz) -!! -------------------------------------------------------- -!! -!! for -fbi : -diag2 -!! use the full expression for the diagonal terms -!! whose derivation keeps all large + small scale - dd2n1 = ddp3*(ddp4-ddp2) - ddp4*ddp2 !* dN/dn1 - dd2n3 = ddp1*(ddp4-ddp2) + ddp4*ddp2 !* dN/dn3 - diag2k1 = diag2k1 + dd2n1 * grad(ipt,nref,izz) - diag2k3 = diag2k3 + dd2n3 * grad(ipt,nref,izz) -!! -------------------------------------------------------- -!! ======================================================== -!! -!! -!! for -fbi - dz1 = dx13 * (dp4-dp2) - dz2 = d1*dp3 * ((d4-d2)+(dp4-dp2)) - dz3 = d3*dp1 * ((d4-d2)+(dp4-dp2)) -!! -!! for -fbi (calc. dz4 & dz5 here) - dz4 = dxp13 * (d4-d2) - dz5 = d2*d4 * dsp13 -!! -!! for -tsa -!! Cross-interactions between parametric and perturbation -!! that occur only when k3 is close enough to k1 -!! Bash; added an extra check on (nang-nalimit) -!b if ( iabs(irng-krng).lt.nklimit .and. & -!b iabs(iang-kang).lt.nalimit ) then !* original -!! -!tsa if ( (krng-irng).lt.nklimit .and. & -!tsa ( iabs(kang-iang).lt.nalimit .or. & -!tsa iabs(kang-iang).gt.(nang-nalimit) ) ) then !* Bash -!! -!! for -tsa (calc. dz4 & dz5 here) -!tsa dz4 = dxp13 * (d4-d2) -!tsa dz5 = d2*d4 * dsp13 -!tsa dz2a = d1*dp3 * (d4-d2) -!tsa dz3a = d3*dp1 * (d4-d2) -!! -!tsa ttsa = ttsa + (dz4+dz5+dz2a+dz3a)*grad(ipt,nref,izz) -!! -!tsa endif -!! -------------------------------------------------------- -!! -!! for -fbi - dz6 = d2*dp4 * (ds13+dsp13) - dz7 = d4*dp2 * (ds13+dsp13) - dz8 = dp2*dp4 * ds13 - dzsum = dz1 + dz2 + dz3 + dz4 + dz5 + dz6 + dz7 + dz8 - txp31 = txp31 + dzsum * grad(ipt,nref,izz) -!! -------------------------------------------------------- -!! ======================================================== -!! -!! -90 end do !* end of ipt (locus) loop -!! ---------------------------------------------------------- -!! -!! -!! multiply the following components by factor 2. in here -!! -!! for both -tsa and -fbi - tr31 = 2. * t31 -!! -!! for -tsa -!tsa trtsa = 2. * ttsa -!! -!! for -fbi - trp31 = 2. * tp31 - trx31 = 2. * txp31 -!! -!! for -tsa : -diag -!tsa diagk1 = 2. * diagk1 -!tsa diagk3 = 2. * diagk3 -!! -!! for -fbi : -diag2 - diag2k1 = 2. * diag2k1 - diag2k3 = 2. * diag2k3 -!! ---------------------------------------------------------- -!! -!! for both -tsa and -fbi - sumint(irng,iang) = sumint(irng,iang) + tr31*pha(krng) - sumint(krng,kang) = sumint(krng,kang) - tr31*pha(irng) -!! ---------------------------------------------------------- -!! -!! for -tsa -!tsa sumintsa(irng,iang)= sumintsa(irng,iang)+ trtsa*pha(krng) -!tsa sumintsa(krng,kang)= sumintsa(krng,kang)- trtsa*pha(irng) -!! ---------------------------------------------------------- -!! -!! for -fbi - sumintp(irng,iang) = sumintp(irng,iang) + trp31*pha(krng) - sumintp(krng,kang) = sumintp(krng,kang) - trp31*pha(irng) -!! -!! for -fbi - sumintx(irng,iang) = sumintx(irng,iang) + trx31*pha(krng) - sumintx(krng,kang) = sumintx(krng,kang) - trx31*pha(irng) -!! ---------------------------------------------------------- -!! -!! for -tsa : -diag -!tsa diag(irng,iang) = diag(irng,iang) + diagk1*pha(krng) -!tsa diag(krng,kang) = diag(krng,kang) - diagk3*pha(irng) -!! ---------------------------------------------------------- -!! -!! for -fbi : -diag2 - diag2(irng,iang) = diag2(irng,iang) + diag2k1*pha(krng) - diag2(krng,kang) = diag2(krng,kang) - diag2k3*pha(irng) -!! ---------------------------------------------------------- -!! -80 end do !* end of kang loop -!! -70 end do !* end of krng loop -!! -60 end do !* end of iang loop -!! -50 end do !* end of irng loop -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!! Final sum-up to get Snl and diag. term to be returned -!! -!! for -tsa -!tsa tsa(:,:) = sumint(:,:) + sumintsa(:,:) -!b diag(:,:) = diag(:,:) !* is Ok, already summed up -!! -!! for -fbi - fbi(:,:) = sumint(:,:) + sumintp(:,:) + sumintx(:,:) -!b diag2(:,:) = diag2(:,:) !* is Ok, already summed up -!! -------------------------------------------------------------------------- -!! ========================================================================== -!! -!! -!!alt Call interp2 only if ialt=2, -!! Interpolate bi-linearly to fill in tsa/fbi & diag/diag2 arrays -!! after alternating the irng, iang, krng & kang loops above -!! ------------------------------------------------------------------ - if ( ialt.eq.2 ) then -!! for -tsa -!tsa call interp2 ( tsa ) -!tsa call interp2 ( diag ) -!! -!! for -fbi - call interp2 ( fbi ) - call interp2 ( diag2 ) - endif -!!alt--- -!! -------------------------------------------------------------------------- -!! ========================================================================== -!! - RETURN -!! - END SUBROUTINE snlr_fbi -!! -!!============================================================================== -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE snlr_tsa ( pha, ialt ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! ------------------------------------------------------------------ -!! -!! it returns: tsa & diag all dim=(nrng,nang) -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!! 1. Purpose : -!! -!! -----------------------------------------------------------------# -!! ! -!! For a given Action Density array dens1(k,theta), computes the ! -!! rate-of-change array sumint(k,theta) = dN(k,theta)/dt owing to ! -!! wave-wave interaction, as well as some ancillary arrays ! -!! relating to positive and negative fluxes and their integrals. ! -!! ! -!! -----------------------------------------------------------------# -!! ! -!! Compute: ! -!! -------- ! -!! for both -tsa and -fbi ! -!! + sumint contains scale 1 contibution for Snl -tsa & Snl -fbi ! -!! ! -!! for -tsa ! -!! + sumintsa contains tsa approximation to Snl -tsa ! -!! ! -!! for -fbi ! -!! + sumintp contains scale 2 contribution to Snl -fbi ! -!! + sumintx contains cross interactions between scales 1 and 2 ! -!! -----------------------------------------------------------------# -!! -!! 2. Method : -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! nrng int. Public I # of freq. or rings -!! nang int. Public I # of angles -!! npts int. Public I # of points on the locus -!! nzz int. Public I linear irng x krng = (NK*(NK+1))/2 -!! ialt int. Public I integer switch ialt=2; do alternate -!! ialt=1; do not alternate -!! kzone int. Public I zone of influence = INT(alog(4.0)/alog(dfrq)) -!! na2p1 int. Public I = nang/2 + 1 -!! np2p1 int. Public I = npts/2 + 1 -!! dfrq real Public I frequency multiplier for log freq. spacing -!! frqa R.A. Public I radian frequencies (Hz); dim=(nrng) -!! pha R.A. local I pha = k*dk*dtheta ; dim=(nrng) -!! ------------------------------------------------------------------ -!! -!! *** The 11 grid integration geometry arrays at one given depth -!! *** from gridsetr. dim=(npts,nang,nzz,ndep) -!! kref2 I.A. Public I Index of reference wavenumber for k2 -!! kref4 I.A. Public I Idem for k4 -!! jref2 I.A. Public I Index of reference angle for k2 -!! jref4 I.A. Public I Idem for k4 -!! wtk2 R.A. Public I k2 Interpolation weigth along wavenumbers -!! wtk4 R.A. Public I Idem for k4 -!! wta2 R.A. Public I k2 Interpolation weigth along angles -!! wta4 R.A. Public I Idem for k4 -!! tfac2 R.A. Public I Norm. for interp Action Density at k2 -!! tfac4 R.A. Public I Idem for k4 -!! grad R.A. Public I Coupling and gradient term in integral -!! grad = C * H * g**2 * ds / |dW/dn| -!! ------------------------------------------------------------------ -!! -!! *** large & small scale Action Density from optsa dim=(nrng,nang) -!! dens1 R.A. Public I lrg-scl Action Density (k,theta); -!! dens2 R.A. Public I Sml-scl Action Density (k,theta); -!! ------------------------------------------------------------------ -!! -!! for both -tsa and -fbi -!! sumint R.A. local O contains scale 1 contribution to Snl -!! dim=(nrng,nang) -!! for -tsa -!! sumintsa R.A. local O contains tsa approximation to Snl -tsa -!! dim=(nrng,nang) -!! for -fbi -!! sumintp R.A. local O contains scale 2 contribution to Snl -fbi -!! dim=(nrng,nang) -!! sumintx R.A. local O contains cross interactions " " " -fbi -!! dim=(nrng,nang) -!! ------------------------------------------------------------------ -!! -!! for -tsa; The 2 returned arrays tsa & diag dim=(nrng,nang) -!! tsa R.A. Public O Snl-tsa = sumint + sumintsa -!! diag R.A. Public O Snl-tsa diagonal term = [dN/dn1] -!! ------------------------------------------------------------------ -!! -!! for -fbi; The 2 returned arrays fbi & diag2 dim=(nrng,nang) -!! fbi R.A. Public O Snl-fbi = sumint + sumintp + sumintx -!! diag2 R.A. Public O Snl-fbi diagonal term = [dN/dn1] -!! ------------------------------------------------------------------ -!! -!! 4. Subroutines used : -!! -!! Name Type Module Description -!! ---------------------------------------------------------------- -!! ---------------------------------------------------------------- -!! -!! 5. Called by : -!! -!! Name Type Module Description -!! ---------------------------------------------------------------- -!! gridsetr Subr. W3SNL4MD Setup geometric integration grid -!! ---------------------------------------------------------------- -!! -!! 6. Error messages : -!! -!! None. -!! -!! 7. Remarks : -!! -!! 8. Structure : -!! -!! See source code. -!! -!! 9. Switches : -!! -!! !/S Enable subroutine tracing. -!! -!!10. Source code : -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! - IMPLICIT NONE -!! -!! Parameter list -!! -------------- - real, intent(in) :: pha(nrng) - integer, intent(in) :: ialt -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! -!! -!! Local Parameters & variables -!! ----------------------------- -!! for both -tsa and -fbi - integer :: irng,krng, iang,kang - integer :: ipt, iizz, izz - integer :: kmax - integer :: ia2, ia2p, k2, k2p - integer :: ia4, ia4p, k4, k4p - integer :: nref -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for -tsa - integer :: nklimit, nalimit -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for both -tsa and -fbi - real :: d1, d3, d2, d4 - real :: dp1, dp3 -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for both -tsa and -fbi -!! but for -tsa they are being calc. inside if/endif if test is successful -!! and for -fbi they are being calc. outside if/endif always - real :: dz4, dz5 -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for both -tsa and -fbi - real :: dx13, ds13, dxp13, dsp13 - real :: dgm, t31, tr31 - real :: w2, w2p, wa2, wa2p, d2a, d2b, tt2 - real :: w4, w4p, wa4, wa4p, d4a, d4b, tt4 - real :: sumint(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for -tsa - real :: dz2a, dz3a, ttsa, trtsa - real :: ddn1, ddn3, diagk1, diagk3 - real :: sumintsa(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! -!! for -fbi -!fbi real :: dp2, dp4 -!fbi real :: d2pa, d4pa -!fbi real :: d2pb, d4pb -!fbi real :: dz1, dz2, dz3, dz6, dz7, dz8 -!fbi real :: dgmp, tp31, trp31, dzsum, txp31, trx31 -!! -!! for -fbi; Bash added 4 new terms for a full expression of diag2 term -!fbi real :: ddp1, ddp2, ddp3, ddp4 !* ddpi=di+dpi for i=1,4 -!fbi real :: dd2n1, dd2n3, diag2k1, diag2k3 -!fbi real :: sumintp(nrng,nang) -!fbi real :: sumintx(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!! for -tsa -!! Bash; hardwire these two parameters - nklimit = 6 - nalimit = 6 -!! -!! -!!ini -!! Bash; move initialization of all returned arrays from below to here -!! ------------------------------------------------------------------ -!! for both -tsa and -fbi -!! sumint is now initialized here instead of below! - sumint(:,:) = 0.0 -!! -!! for -tsa -!! sumintsa are now initialized here instead of below! - sumintsa(:,:) = 0.0 - tsa(:,:) = 0.0 - diag(:,:) = 0.0 -!! -!! for -fbi -!! sumintp and sumintx are now initialized here instead of below! -!fbi sumintp(:,:) = 0.0 -!fbi sumintx(:,:) = 0.0 -!fbi fbi(:,:) = 0.0 -!fbi diag2(:,:) = 0.0 -!!ini--- -!! ------------------------------------------------------------------ -!! ------------------------------------------------------------------ -!! ################################################################## -!! -!! -!! for -tsa - ddn1 = 0.0 !* for -tsa diag [dN/dn1] - ddn3 = 0.0 !* for -tsa diag [dN/dn3] -!! -!! for -fbi -!fbi dd2n1 = 0.0 !* for -fbi diag2 [dN/dn1] -!fbi dd2n3 = 0.0 !* for -fbi diag2 [dN/dn3] -!! -!! -!! -!!50 - do 50 irng=1,nrng,ialt -!!kz - kmax = min(irng+kzone, nrng) !* Bash; Sometimes a locus pt is outside nrng -!kz kmax = min(irng+kzone, nrng-1) !* Bash; Taking 1 out will not affect kzone, try it -!!kz--- -!! - iizz = (nrng-1)*(irng-1) - ((irng-2)*(irng-1))/2 -!! ---------------------------------------------------------------- -!! -!! -!!60 - do 60 iang=1,nang,ialt -!! -!! for both -tsa and -fbi - d1 = dens1(irng,iang) - dp1 = dens2(irng,iang) -!! -!! for -fbi -!fbi ddp1 = d1+dp1 !! for full expression of diag2 term -!! -!!70 -!!kz -!kz do 70 krng=irng,nrng - do 70 krng=irng,kmax,ialt -!! -!! for both -tsa and -fbi -!! Bash; check5 be consistent with gridsetr -!! moved here from below (was after do 80 kang=1,nang) -!! and changed go to 80 into go to 70 (i.e. go to next krng) -!kz if ( frqa(krng)/frqa(irng) .gt. 4. ) go to 70 !* original gridsetr -!kz if ( frqa(krng)/frqa(irng) .gt. 3. ) go to 70 !* original snlr_'s -!kz if ( frqa(krng)/frqa(irng) .gt. 2. ) go to 70 !* Bash; use .gt. 2 -!!kz--- -!! - izz = krng + iizz -!! ------------------------------------------------------------ -!! -!!80 - do 80 kang=1,nang,ialt -!! -!! for both -tsa and -fbi -!!ba1 Bash; Remove self interaction -!! skip k1 but keep the opposite angle to k1 - original setting - if ( krng.eq.irng ) then !* wn3 = wn1 - if ( kang.eq.iang ) go to 80 !* th3 = th1 - endif -!!ba1--- -!! ---------------------------------------------------------- -!! -!! for both -tsa and -fbi - d3 = dens1(krng,kang) - dp3 = dens2(krng,kang) -!! -!! for -fbi -!fbi ddp3 = d3+dp3 !! for full expression of diag2 term -!! -!! -!! for both -tsa and -fbi - nref = kang - iang + 1 - if ( nref .lt. 1 ) nref = nref + nang -!! -!! -!! for both -tsa and -fbi -!! Bash; check5 be consistent with gridsetr -!! and move this test above right after do 70 krng=irng,nrng -!x if ( frqa(krng)/frqa(irng) .gt. 4. ) go to 80 !* gridsetr -!b if ( frqa(krng)/frqa(irng) .gt. 3. ) go to 80 !* original -!! -!! -!! for both -tsa and -fbi - t31 = 0.0 !* must be reset to 0.0 -!! -!! for -tsa - ttsa = 0.0 !* must be reset to 0.0 - diagk1 = 0.0 !* must be reset to 0.0 - diagk3 = 0.0 !* must be reset to 0.0 -!! -!! for -fbi -!fbi tp31 = 0.0 !* must be reset to 0.0 -!fbi txp31 = 0.0 !* must be reset to 0.0 -!fbi diag2k1 = 0.0 !* must be reset to 0.0 -!fbi diag2k3 = 0.0 !* must be reset to 0.0 -!! -!! for both -tsa and -fbi - dx13 = d1*d3 - ds13 = d3-d1 - dxp13 = dp1*dp3 - dsp13 = dp3-dp1 -!! ---------------------------------------------------------- -!! -!!90 - do 90 ipt=1,npts -!! -!! for both -tsa and -fbi -!! save time by skipping insignificant contributions -!!e-30 -!e-30 if ( grad(ipt,nref,izz) .lt. 1.e-30 ) go to 90 -!!e-30--- - if ( grad(ipt,nref,izz) .lt. 1.e-15 ) go to 90 -!!e-30--- -!! -------------------------------------------------------- -!! -!!xlc1 Bash; skip k1 but keep the opposite angle to k1 - original setting -!xlc1 if ( kang.eq.iang ) then !* th3=+th1 -!xlc1 if (ipt.eq.1 .or. ipt.eq.np2p1) go to 90 !* skip x-axis loci -!xlc1 end if -!!xlc1--- -!! -------------------------------------------------------- -!! -!! -!!2 Estimation of Density for wave #2 -!! -!! for both -tsa and -fbi - k2 = kref2(ipt,nref,izz) - k2p = k2 + 1 - w2 = wtk2(ipt,nref,izz) - w2p = 1. - w2 -!! -!! for both -tsa and -fbi - ia2 = iang + jref2(ipt,nref,izz) - if ( ia2 .gt. nang ) ia2 = ia2 - nang -!! -!! for both -tsa and -fbi - ia2p = ia2 + 1 - if ( ia2p .gt. nang ) ia2p = ia2p - nang -!! -!! for both -tsa and -fbi - wa2 = wta2(ipt,nref,izz) - wa2p = 1. - wa2 - d2a = w2 * dens1(k2,ia2) + w2p * dens1(k2p,ia2) - d2b = w2 * dens1(k2,ia2p) + w2p * dens1(k2p,ia2p) - tt2 = tfac2(ipt,nref,izz) - d2 = (wa2*d2a + wa2p*d2b) * tt2 -!! -!! for -fbi -!fbi d2pa = w2 * dens2(k2,ia2) + w2p * dens2(k2p,ia2) -!fbi d2pb = w2 * dens2(k2,ia2p) + w2p * dens2(k2p,ia2p) -!! -!! for -fbi -!fbi dp2 = (wa2*d2pa + wa2p*d2pb) * tt2 !* for -fbi -!fbi ddp2 = d2+dp2 !! for full expression of diag2 term -!! ======================================================== -!! -!! -!!4 Estimation of Density for wave #4 -!! -!! for both -tsa and -fbi - k4 = kref4(ipt,nref,izz) - k4p = k4 + 1 - w4 = wtk4(ipt,nref,izz) - w4p = 1. - w4 -!! -!! for both -tsa and -fbi - ia4 = iang + jref4(ipt,nref,izz) - if ( ia4 .gt. nang ) ia4 = ia4 - nang -!! -!! for both -tsa and -fbi - ia4p= ia4 + 1 - if ( ia4p .gt. nang ) ia4p = ia4p - nang -!! -!! for both -tsa and -fbi - wa4 = wta4(ipt,nref,izz) - wa4p = 1. - wa4 - d4a = w4*dens1(k4,ia4) + w4p*dens1(k4p,ia4) - d4b = w4*dens1(k4,ia4p) + w4p*dens1(k4p,ia4p) - tt4 = tfac4(ipt,nref,izz) - d4 = (wa4*d4a + wa4p*d4b) * tt4 -!! -!! for -fbi -!fbi d4pa = w4*dens2(k4,ia4) + w4p*dens2(k4p,ia4) -!fbi d4pb = w4*dens2(k4,ia4p) + w4p*dens2(k4p,ia4p) -!! -!! for -fbi -!fbi dp4 = (wa4*d4pa + wa4p*d4pb) * tt4 !* for -fbi -!fbi ddp4 = d4+dp4 !! for full expression of diag2 term -!! ======================================================== -!! -!! -!! for both -tsa and -fbi - dgm = dx13*(d4-d2) + ds13*d4*d2 !* dgm=B of R&P'08 eqn(8) -!! !* represents Broad Scale interactions - t31 = t31 + dgm * grad(ipt,nref,izz) -!! -------------------------------------------------------- -!! -!! for -fbi -!fbi dgmp = dxp13*(dp4-dp2) + dsp13*dp4*dp2 !* dgmp=L of R&P'08 eqn(8) -!! !* represents Local Scale interactions -!fbi tp31 = tp31 + dgmp * grad(ipt,nref,izz) -!! -------------------------------------------------------- -!! ======================================================== -!! -!! -!! for -tsa : -diag -!! use this expression for the diagonal term -!! whose derivation neglect "dp2" & "dp4" - ddn1 = (d3+dp3)*(d4-d2) - d4*d2 !* dN/dn1 - ddn3 = (d1+dp1)*(d4-d2) + d4*d2 !* dN/dn3 - diagk1 = diagk1 + ddn1 * grad(ipt,nref,izz) - diagk3 = diagk3 + ddn3 * grad(ipt,nref,izz) -!! -------------------------------------------------------- -!! -!! for -fbi : -diag2 -!! use the full expression for the diagonal terms -!! whose derivation keeps all large + small scale -!fbi dd2n1 = ddp3*(ddp4-ddp2) - ddp4*ddp2 !* dN/dn1 -!fbi dd2n3 = ddp1*(ddp4-ddp2) + ddp4*ddp2 !* dN/dn3 -!fbi diag2k1 = diag2k1 + dd2n1 * grad(ipt,nref,izz) -!fbi diag2k3 = diag2k3 + dd2n3 * grad(ipt,nref,izz) -!! -------------------------------------------------------- -!! ======================================================== -!! -!! -!! for -fbi -!fbi dz1 = dx13 * (dp4-dp2) -!fbi dz2 = d1*dp3 * ((d4-d2)+(dp4-dp2)) -!fbi dz3 = d3*dp1 * ((d4-d2)+(dp4-dp2)) -!! -!! for -fbi (calc. dz4 & dz5 here) -!fbi dz4 = dxp13 * (d4-d2) -!fbi dz5 = d2*d4 * dsp13 -!! -!! for -tsa -!! Cross-interactions between parametric and perturbation -!! that occur only when k3 is close enough to k1 -!! Bash; added an extra check on (nang-nalimit) -!b if ( iabs(irng-krng).lt.nklimit .and. & -!b iabs(iang-kang).lt.nalimit ) then !* original -!! - if ( (krng-irng).lt.nklimit .and. & + ds(npts/2+1) = ds2 + !! ------------------------------------------------------------------ + !! ================================================================== + !! + RETURN + !! +1000 format ( ' W3SNL4 Error : In shlocr. Error from gridset ',i10) + !! + END SUBROUTINE shlocr + !! + !!============================================================================== + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + SUBROUTINE cplshr ( w1x0,w1y0, w2x0,w2y0, w3x0,w3y0, & + h, csq, irng,krng, kang,ipt ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! + !! it returns: the coupling coefficient csq + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !! 1. Purpose : + !! + !! -----------------------------------------------------------------# + !! ! + !! Calculates four-wave Boltzmann coupling coefficient in shallow ! + !! water given k1,k2,k3 and following at least Hasselmann (1962) ! + !! and probably Herterich and Hasselmann (1982). Dimensional ! + !! wavenumbers are (wnx0,wny0), n = 1,3, h = depth, csq = coupling ! + !! coefficient. This is the same as Don's cplesh, except within ! + !! the algorithm, wavenumbers are made dimensionless with h and ! + !! frequencies with sqrt(h/g), g = gravitational acceleration (the ! + !! idea is to simplify and speed up the calculations while keeping ! + !! a reasonable machine resolution of the result). At the end, ! + !! dimensionless csqhat is redimensioned as csq = csqhat/(h**6) ! + !! so it is returned as a dimensional entity. ! + !! ! + !! This calculation can be a touchy bird, so we use double precision! + !! for internal calculations, using single precision for input and ! + !! output. ! + !! ! + !! -----------------------------------------------------------------# + !! + !! 2. Method : + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! ------------------------------------------------------------------ + !! + !! 4. Subroutines used : + !! + !! Name Type Module Description + !! ------------------------------------------------------------------ + !! ------------------------------------------------------------------ + !! + !! 5. Called by : + !! + !! Name Type Module Description + !! ------------------------------------------------------------------ + !! gridsetr Subr. W3SNL4MD Setup geometric integration grid + !! ------------------------------------------------------------------ + !! + !! 6. Error messages : + !! + !! None. + !! + !! 7. Remarks : + !! + !! 8. Structure : + !! + !! See source code. + !! + !! 9. Switches : + !! + !! !/S Enable subroutine tracing. + !! + !!10. Source code : + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + IMPLICIT NONE + !! + !! Parameter list + !! -------------- + integer, intent(in) :: irng,krng, kang,ipt + real, intent(in) :: w1x0,w1y0, w2x0,w2y0, w3x0,w3y0 + real, intent(in) :: h !* depth 'dep' + real, intent(out) :: csq + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! + !! + !! Local Parameters & variables + !! ----------------------------- + integer :: ipass + double precision :: hh + double precision :: s1, s2, s3 + double precision :: k1x, k2x, k3x + double precision :: k1y, k2y, k3y + double precision :: k1, k2, k3 + double precision :: om1, om2, om3 + double precision :: som1, som2, som3 + double precision :: om1sq, om2sq, om3sq + double precision :: k23, k23x, k23y + double precision :: dot23, dot123 + double precision :: omsq23 + !!mpc + double precision :: k1sq, k2sq, k3sq, k23sq + double precision :: tanh_k1, tanh_k2, tanh_k3, tanh_k23 + !!mpc--- + double precision :: k1x0, k2x0, k3x0, k1zx + double precision :: k1y0, k2y0, k3y0, k1zy + double precision :: di, e + double precision :: p1, p2, p3, p4 + double precision :: t1, t2, t3, t4, t5 + !! + double precision :: csqhatd, csqd + double precision :: scple + double precision :: pi4 + !! + !!eps Bash; added +eps to avoid dividing by 0.0. Dividing by 0.0 causes NaN + !eps double precision :: eps + !! + !! Bash; Added domsq23 = denominator of t1 in cplshr + !! and sumom = denominator of csqhatd in cplshr + double precision :: domsq23, sumom + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !! initial constants + !! ------------------ + hh = dble(h) !* single to dbl precision + pi4 = 0.785398175d0 !* Set = PI/4 as in CONSTANTS + !eps eps = 1.d-12 !* set eps to a very small number + scple = 0.d0 !* initialize accumulator + !!ini + !! initialize returned variable 'csq' + !! ---------------------------------- + csq = 0.d0 + !!ini--- + !! ------------------------------------------------------------------ + !! + do ipass=1,3 + !p1 + if (ipass .eq. 1) then !* initial pass (+1,+1,-1) + s1 = 1.d0 + s2 = 1.d0 + s3 = -1.d0 + k1x0 = dble(w1x0) * hh !* norm. k elements with h + k1y0 = dble(w1y0) * hh + k2x0 = dble(w2x0) * hh + k2y0 = dble(w2y0) * hh + k3x0 = dble(w3x0) * hh + k3y0 = dble(w3y0) * hh + !p1 + !p2 + else if (ipass .eq. 2) then !* 1st permutation (+1,-1,+1) + s1 = 1.d0 + s2 = -1.d0 + s3 = 1.d0 + k1zx = k1x0 + k1zy = k1y0 + k1x0 = k2x0 + k1y0 = k2y0 + k2x0 = k3x0 + k2y0 = k3y0 + k3x0 = k1zx + k3y0 = k1zy + !p2 + !p3 + else !* 2nd permutation (-1,+1,+1) + s1 = -1.d0 + s2 = 1.d0 + s3 = 1.d0 + k1zx = k1x0 + k1zy = k1y0 + k1x0 = k2x0 + k1y0 = k2y0 + k2x0 = k3x0 + k2y0 = k3y0 + k3x0 = k1zx + k3y0 = k1zy + !p3 + end if + !!k19p1 + !!k19p1 Note: na2p1=nang/2+1 !* this is the angle index opposite to iang=1 + !k19p1 if (krng.ne.irng .and. kang.eq.na2p1 .and. ipt.eq.1 .and. & + !k19p1 ipass.eq.1) go to 10 + !!k19p1--- + !! + k1x = s1 * k1x0 !* sign the norm'ed k parts + k1y = s1 * k1y0 + k2x = s2 * k2x0 + k2y = s2 * k2y0 + k3x = s3 * k3x0 + k3y = s3 * k3y0 + !!mpc + !mpc k1 = dsqrt(k1x**2 + k1y**2) !* normalized |k| + !mpc k2 = dsqrt(k2x**2 + k2y**2) + !mpc k3 = dsqrt(k3x**2 + k3y**2) + !!mpc--- + k1sq = (k1x*k1x + k1y*k1y) !* normalized |k| **2 + k2sq = (k2x*k2x + k2y*k2y) + k3sq = (k3x*k3x + k3y*k3y) + k1 = dsqrt(k1sq) !* normalized |k| + k2 = dsqrt(k2sq) + k3 = dsqrt(k3sq) + !!mpc--- + !! + !!mpc + !mpc om1 = dsqrt(k1*dtanh(k1)) !* norm. omega (by sqrt(h/g)) + !mpc om2 = dsqrt(k2*dtanh(k2)) + !mpc om3 = dsqrt(k3*dtanh(k3)) + !mpc om1sq = om1**2 + !mpc om2sq = om2**2 + !mpc om3sq = om3**2 + !!mpc--- + tanh_k1 = dtanh(k1) + tanh_k2 = dtanh(k2) + tanh_k3 = dtanh(k3) + om1sq = k1*tanh_k1 + om2sq = k2*tanh_k2 + om3sq = k3*tanh_k3 + om1 = dsqrt(om1sq) !* norm. omega (by sqrt(h/g)) + om2 = dsqrt(om2sq) + om3 = dsqrt(om3sq) + !!mpc--- + !! + som1 = s1 * om1 !* sign the norm'ed omega's + som2 = s2 * om2 + som3 = s3 * om3 + !! ---------------------------------------------------------------- + !! ================================================================ + !! + !! + dot23 = k2x*k3x + k2y*k3y !* vector k2 dot vector k3 + !! + k23x = k2x + k3x !* (vector k2 + vector k3)_x + k23y = k2y + k3y !* (vector k2 + vector k3)_y + !! + !!mpc + !mpc k23 = dsqrt(k23x**2+k23y**2) !* |vector k2 + vector k3| + !!mpc--- + k23sq = (k23x*k23x + k23y*k23y) + k23 = dsqrt(k23sq) !* |vector k2 + vector k3| + !!mpc--- + !! + !!mpc + !mpc omsq23 = k23 * dtanh(k23) !* norm sq frq of v.k2+v.k3 + !!mpc--- + tanh_k23 = dtanh(k23) + omsq23 = k23 * tanh_k23 !* norm sq frq of v.k2+v.k3 + !!mpc--- + !! + dot123 = k1x*k23x + k1y*k23y !* v.k1 dot (v.k2 + v.k3) + !! ---------------------------------------------------------------- + !! + !! note: the "i**2" factor from some reference is included in this term + !! + !!mpc + !mpc di = -(som2+som3)*(om2sq*om3sq-dot23)+0.5d0 * & + !mpc (som2*(k3**2-om3sq**2)+som3*(k2**2-om2sq**2)) + !!mpc--- + di = -(som2+som3)*(om2sq*om3sq-dot23)+0.5d0 * & + (som2*(k3sq-om3sq*om3sq)+som3*(k2sq-om2sq*om2sq)) + !!mpc--- + !! + e = 0.5d0*(dot23-som2*som3*(om2sq+om3sq+som2*som3)) + !! + p1 = 2.d0 * (som1+som2+som3) * (om1sq*omsq23 - dot123) + !! + !!mpc + !mpc p2 = -som1 * (k23**2 - omsq23**2) + !mpc p3 = -(som2+som3) * (k1**2 - om1sq**2) + !mpc p4 = k1**2 - om1sq**2 + !!mpc--- + !! equation p2 rewritten to preserve numerical precision + !! equations p3, p4 rearranged to avoid recomputations. + p2 = -som1 * (k23sq*(1 - tanh_k23*tanh_k23)) + p4 = (k1sq*(1-tanh_k1*tanh_k1)) + p3 = -(som2+som3) * p4 + !!mpc--- + !! ---------------------------------------------------------------- + !! + !! Bash; added & used variable domsq23 = denominator of t1 + domsq23 = omsq23 - ((som2+som3)**2) !* Bash; needed for test below + !! ---------------------------------------------------------------- + !! + !!cp4 Bash; with !cp4 ON, test if ( domsq23 .eq. 0.d0 ) + !cp4 if ( domsq23 .eq. 0.d0 ) then !* Bash; this test was needed + !! !* when !k19p1 & !hv were OFF + !! domsq23=0.0 Dividing by 0.0 causes NaN; here we avoid it + !cp4 t1 = 0.d0 + !eps t1 = di * (p1+p2+p3) / (domsq23+eps) !* Add eps to denominator + !! !* and may be to numerator + !cp4 endif + !!cp4--- + !! Bash; with !cp4 OFF, don't test if ( domsq23 .eq. 0.d0 ) + !! domsq23 is not = 0.0 (when !k19p1 & !hv were OFF) + !b t1 = di * (p1+p2+p3) / (omsq23 - ((som2+som3)**2)) + t1 = di * (p1+p2+p3) / (domsq23) + !!cp4--- + !! ---------------------------------------------------------------- + !! + t2 = -di * som1 * (om1sq+omsq23) + t3 = e * ((som1**3) * (som2+som3) - dot123 - p4) + t4 = 0.5d0 * som1 * dot23 * & + ((som1+som2+som3) * (om2sq+om3sq) + som2*som3*(som2+som3)) + !! + !!mpc + !mpc t5 = -0.5d0 * som1 * & + !mpc (om2sq * (k3**2) * (som1+som2 + 2.d0 * som3) + & + !mpc om3sq * (k2**2) * (som1+som3 + 2.d0 * som2)) + !!mpc--- + t5 = -0.5d0 * som1 * & + (om2sq * (k3sq) * (som1+som2 + 2.d0 * som3) + & + om3sq * (k2sq) * (som1+som3 + 2.d0 * som2)) + !!mpc--- + !! + scple = scple + t1 + t2 + t3 + t4 + t5 + !! + end do ! do ipass=1,3 + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !!as HH did division by 3 after adding 3 terms + !as scple = scple/3.d0 + !!as--- + !! + !! Bash; Added sumom = denominator of csqhatd in cplshr + sumom = om1*om2*om3*(om2+om3-om1) + !b csqhatd = scple*scple*pi4/(om1*om2*om3*(om2+om3-om1)) !* Bash; ok + csqhatd = scple*scple*pi4/(sumom) + !! ------------------------------------------------------------------ + !! + csqd = csqhatd / (hh**6) + csq = sngl(csqd) !* from dbl to single precision + !! ------------------------------------------------------------------ + !! ================================================================== + !! + RETURN + !! + END SUBROUTINE cplshr + !! + !!============================================================================== + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! ------------------------------------------------------------------ + !! + !! It returns variables dens1(nrng,nang) and dens2(nrng,nang) + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !! 1. Purpose : + !! + !! Splits the Action Density into two parts: + !! (1) large-scale part dens1(nrng,nang) and + !! (2) small-scale part dens2(nrng,nang) + !! dens1 & dens2 in Polar Action Density (k,theta) space Norm. (in k) + !! + !! 2. Method : + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !!op2 + !! nrmn int. Local I number of first freq. bin in [1,nrng-1] + !! nrmx int. Local I number of last freq. bin in [2,nrng] + !! npk int. Local I number of peak frequency in [2,nrng-1] + !! nbins int. Local I actual # of bins > npk (incl. nfs) or + !! actual # of bins > npk2 (incl. nrng) + !! to guarantee a min 1 bin in equi. range + !! (see subr. W3SNL4) + !! ------------------------------------------------------------ !!op2 + !! + !! nrng int. Public I # of freq. or rings + !! nang int. Public I # of angles + !! + !! dfrq Real Public I freq mult. for log freq spacing + !! fpk Real Public I peak freq. [Hz] of initial freq spectrum + !! oma R.A. Public I rel. freq. array (rad*Hz) ----- dim=(nrng) + !! frqa R.A. Public I radian frequencies (Hz) ------- dim=(nrng) + !! + !! ainc Real Public I angle increment (radians) + !! angl R.A. Public I dir. array (rad) (full circle); dim=(nrng) + !! cosan R.A. Public I cosine angles array ----------- dim=(nang) + !! sinan R.A. Public I sine angles array ----------- dim=(nang) + !! ------------------------------------------------------------------ + !! + !! wka R.A. Local I wavenumbers array [1/m] ------- dim=(nrng) + !! cga R.A. Local I group velocities array [m/s] -- dim=(nrng) + !! wka & cga arrays are corrsp. to depth 'dep' + !! ------------------------------------------------------------------ + !! + !! ef2 R.A. Public I 2D Energy Density spectrum ef2(theta,f) + !! = A(theta,k)*2*pi*oma(f)/cga(f) dim=(nrng,nang) + !! ef1 R.A. Public I 1D Energy Density spectrum ef1(f) dim=(nrng) + !! ------------------------------------------------------------------ + !! + !! dens1 R.A. Public O large-scale Action Density (k,theta) + !! dim=(nrng,nang) + !! dens2 R.A. Public O Small-scale Action Density (k,theta) + !! dim=(nrng,nang) + !! ------------------------------------------------------------------ + !! + !! 4. Subroutines used : + !! + !! Name Type Module Description + !! ------------------------------------------------------------------ + !! ------------------------------------------------------------------ + !! + !! 5. Called by : + !! + !! Name Type Module Description + !! ------------------------------------------------------------------ + !! gridsetr Subr. W3SNL4MD Setup geometric integration grid + !! ------------------------------------------------------------------ + !! + !! 6. Error messages : + !! + !! None. + !! + !! 7. Remarks : + !! + !! 8. Structure : + !! + !! See source code. + !! + !! 9. Switches : + !! + !! !/S Enable subroutine tracing. + !! + !!10. Source code : + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + !! + IMPLICIT NONE + !! + !! + !! + !! Parameter list + !! -------------- + !!op2 Bash; new for optsa2 + integer, intent(in) :: nrmn, nrmx, nbins + !! ------------------------------------------------------------ !!op2 + !! + integer, intent(in) :: npk + real, intent(in) :: fpk + real, intent(in) :: wka(nrng), cga(nrng) + !! ------------------------------------------------------------------ + !! + !! + !! Local Parameters & variables + !! ----------------------------- + integer :: irng, iang + !! + !!p2 + !! Bash; Uses of original "psi2(:)", it was very bad (see below) + !p2 integer :: n1, n2, m, mm + !p2 integer :: nn1, nn2, ii, idif + !p2 real :: q(16) + !p2 real :: emax + !p2 real :: y, qmin, adif + !!p2--- + !! + !!p3 + !! Bash; This is an attempt to replace the original psi2(:) + !! with a distr. based on sin()**mm with 'newmaxang' + !! - not good enough (see below) + !! !!p4 is an override of !!p3 with mm=4 + !p3 integer :: n1, n2, m, mm + !p3 real :: q(16) + !p3 real :: y, qmin, adif + !! The var. below are needed to find 'newmaxang' used in !p3 & !p4 + integer :: maxang, newmaxang + integer :: maxangshift + integer :: halfangl, halfangu + real :: ef2maxrow(nang) + real :: ef2shift(nang) + real :: halfmax + !!p3--- + !! + !!p4 + !! Bash; !!p4 is an override of !!p3 with mm=4 + integer :: n1, n2 + real :: q4 + !!p4--- + !! + !!eq + !! Bash; Use variable equi. range suitable to TSA min condition + !! simplifed to one point equi. range nearest to 2.*fp + !eq integer :: neq + !eq real :: fovfp + !!eq--- + !! + integer :: igam + real :: sum1, fac + real :: beta, gam + real :: fdenp, fr, ratio, z, ddd + real :: sigz !* sigz = 0.109 + real :: fk(nrng), fknrm(nrng) + real :: bscl1(nrng), fkscl1(nrng) + real :: psi2(nang) + real :: act2d(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !!ini + !! Bash; initialize psi2() array here + psi2(:) = 0.0 + !! + !! Initialize all the 1d & 2d arrays that are being used + !! and especially those that are being returned + fk(:) = 0.0 + fknrm(:) = 0.0 + fkscl1(:) = 0.0 + bscl1(:) = 0.0 + act2d(:,:) = 0.0 + dens1(:,:) = 0.0 + dens2(:,:) = 0.0 + !!ini--- + !! ------------------------------------------------------------------ + !! + !! + !!* Convert 2D Energy Density ef2(f,theta) + !! to 2D Polar Action Density act2d(k,theta) Norm. (in k) + do irng=nrmn,nrmx + fac = cga(irng)/(twopi*oma(irng)*wka(irng)) + do iang=1,nang + act2d(irng,iang) = ef2(irng,iang) * fac + end do + !! + !!* Convert ef1(f) to fk(k); both are 1d Energy Density + fk(irng) = cga(irng)*ef1(irng)/twopi !* fk(k) energy + !! + !!* Normalize the 1d wavenumber Energy Density fk(k) to give fknrm(k) + fknrm(irng) = fk(irng)*wka(irng)**2.5 !* fknrm(k) = Norm. fk(k) + end do + !! ------------------------------------------------------------------ + !! + !! + !! Fit parameters to spectrum + !! -------------------------- + !!eq + !eq sum1 = 0. + !eq neq = 0 + !eq do 26 irng=nrmn,nrmx + !eq fovfp = frqa(irng)/fpk + !! Bash; check2 test equilibrium range + !b if ( fovfp.ge.1.55.and.fovfp.le.2.45 ) then !* orig equi range + !b if ( fovfp.ge.1.20.and.fovfp.le.2.20 ) then !* wide equi range + !b if ( fovfp.ge.1.90.and.fovfp.le.2.20 ) then !* narrow equi range + !! --------------------------------------------------------------!* <<<<< + !! Bash; select variable equi. range suitable to TSA min condition + !eq if ( fovfp.ge.(dfrq**(nbins))-0.005 .and. & + !eq fovfp.le.(dfrq**(nbins))+0.005 ) then !* narrow equi range <<<<< + !! --------------------------------------------------------------!* <<<<< + !eq sum1 = sum1 + fknrm(irng) + !eq neq = neq + 1 + !eq endif + ! 26 end do + !eq beta = sum1 / neq + !eq gam = fknrm(npk) / beta + !!eq--- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! Simplify + beta = fknrm(npk+nbins) + gam = fknrm(npk) / beta + !!eq--- + !! ------------------------------------------------------------------ + !! + do irng=nrmn,nrmx + fknrm(irng) = fknrm(irng) / beta + end do + !! ================================================================== + !! + !! + !!p2 + !! Construct Directional Distribution "psi2(:)" - original option + !! ------------------------------------------------------------------ + !! + !! Solve for Normalizing Coefficient for Integral [1.0/(cos**m)] + !! Note: n1, n2 spans half circle (from -pi/2 to +pi/2 going through 0.) + !p2 n1 = -nang/4 + 1 + !p2 n2 = nang/4 + 1 + !p2 do m=1,16 + !p2 sum1 = 0. + !p2 do iang=n1,n2 + !p2 ii = iang + !p2 if ( iang .lt. 1 ) ii = iang + nang + !p2 sum1 = sum1 + cosan(ii)**m + ! end do + !p2 q(m) = 1./(sum1*ainc) + ! end do + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! Find peak direction "maxang" in ef2() at "npk" the peak in ef1() + !! needed to define the energy spreading factor y=ef2(npk,maxang)/ef1(npk) + !! Bash; Note; This original "psi2(:)" was simply very bad because the drift + !! in "maxang" location causing the 2D Snl to lose symmetry + !p2 emax = 0. + !p2 maxang = 0 + !p2 do iang=1,nang + !p2 if ( ef2(npk,iang).gt.emax ) then + !p2 emax = ef2(npk,iang) + !p2 maxang = iang !* in [1,nang] + !p2 endif + ! end do + !p2 y = ef2(npk,maxang)/ef1(npk) !* Bash; Energy Spread + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! Compare value of peak with q-array for closest fit to cos()**m at peak + !p2 mm = 1 + !p2 qmin = abs(q(1)-y) + !p2 do m=2,16 + !p2 adif = abs(q(m)-y) + !p2 if ( adif.lt.qmin ) then + !p2 qmin = adif + !p2 mm = m + !p2 endif + ! end do + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !p2 nn1 = maxang - nang/4 !* nn1 in [-8, 27], -ve/+ve (incl. 0) + !p2 nn2 = maxang + nang/4 !* nn2 in [10, 45], all +ve (no 0) + !p2 do iang=nn1,nn2 !* Bash; nn1 -> nn2 covers half circle + !p2 ii = iang !* ii always in range [1,nang] + !p2 if ( ii .lt. 1 ) ii = ii + nang !* "" + !p2 if ( ii .gt. nang ) ii = ii - nang !* "" + !p2 idif = iabs(maxang-iang) + 1 !* =10,9,..,2,1,2,..,9,10 + !p2 psi2(ii) = q(mm) * cos(angl(idif))**mm !* Normalized psi2 distr. + ! end do + !!p2--- + !! ================================================================== + !! + !! + !!p3 + !! Construct New Directional Distribution "psi2(:)" + !! In an attempt to replace the original psi2(:) with + !! a distribution based on sin()**mm with 'newmaxang' - not good enough + !! ------------------------------------------------------------------ + !! + !! Solve for Normalizing Coefficient for Integral [1.0/(sin()**m)] + !! Note: n1, n2 spans half circle (from 0 to +pi) + !p3 n1 = 1 + !p3 n2 = nang/2 + 1 + !p3 do m=1,16 + !p3 sum1 = 0. + !p3 do iang=n1,n2 + !p3 sum1 = sum1 + sinan(iang)**m + ! end do + !p3 q(m) = 1./(sum1*ainc) + ! end do + !!p3--- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !!p3 + ef2maxrow(:) = ef2(npk,:) + maxang = MAXLOC(ef2maxrow,1) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! Shift the row so that the max is at location of 90 degress + !! Negative shift is to the right, Postive to the left + !! halfangl - lower angular limit of the half maximum + !! halfangu - upper angular limit of the half maximum + ef2shift(:) = CSHIFT( ef2maxrow(:), (maxang-1-nang/4) ) + halfangu = nang/4+2 + halfangl = nang/4 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + halfmax = 0.5 * ef2(npk,maxang) + do while((ef2shift(halfangu).gt.halfmax).and.(halfangu.lt.nang/2)) + halfangu = halfangu + 1 + enddo + do while((ef2shift(halfangl).gt.halfmax).and.(halfangl.gt.1)) + halfangl = halfangl - 1 + enddo + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! Convert angles indices with respect to peak + !! e.g. halfangl should go to halfangl - (nang/4+1) + !! halfangu should go to halfangu - (nang/4+1) + halfangl = halfangl - (nang/4+1) + halfangu = halfangu - (nang/4+1) + !! + !! Now average the positions, round to nearest integer. + !! -ve result means the centre is one greater than it should be. + maxangshift = NINT( 0.5 * (halfangl + halfangu) ) + newmaxang = maxang + maxangshift + if (newmaxang .lt. 1) newmaxang = newmaxang + nang + if (newmaxang .gt. nang) newmaxang = newmaxang - nang + !!p3--- + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !!p3 + !! Bash; need this section if you want to try sin()**mm with 'newmaxang' + !p3 y = ef2(npk,newmaxang) / ef1(npk) !* New Energy Spread + !! + !! Compare value of peak with q-array for closest fit to sin()**m at peak + !! This !p3 section is needed for use with sin()**mm + !! Bash; Note; This new "psi2(:)" although better than original "psi2(:)" + !! it was still not good enough: the 2D Energy was OK but + !! the 2D Snl, now with better symmetry, didn't always have the side lobes. + !p3 mm = 1 + !p3 qmin = abs(q(1)-y) + !p3 do m=2,16 + !p3 adif = abs(q(m)-y) + !p3 if ( adif.lt.qmin ) then + !p3 qmin = adif + !p3 mm = m + !p3 endif + ! end do + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! Final step, use 'mm' for sin()**mm + !p3 psi2(n1:n2) = (sinan(n1:n2))**mm !* Un-norm. psi2 distr. + !p3 psi2(n1:n2) = q(mm) * psi2(n1:n2) !* Norm. psi2 distr. + !! Rotate peak to correct angle + !p3 psi2(:) = CSHIFT( psi2(:), newmaxang-1+nang/4 ) + !!p3--- + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !!p4 + !! !!p4 is an override of !!p3 with mm=4, so go straight to Final step + !! Note; all you need from !!p3 is the "newmaxang" + !! So it's a sin()**4 distr. shifted to "newmaxang" - worked very well + !! ------------------------------------------------------------------ + !! + !! Solve for Normalizing Coefficient for Integral [1.0/(sin()**4)] + !! Note: n1, n2 spans half circle (from 0 to +pi) + n1 = 1 + n2 = nang/2 + 1 + !p4 sum1 = 0. + !p4 do iang=n1,n2 + !p4 sum1 = sum1 + sinan(iang)**4 + ! end do + !p4 q4 = 1.0/(sum1*ainc) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! Change the angles that aren't zero (0 deg to +180 deg) + psi2(n1:n2) = (sinan(n1:n2))**4 !* Un-norm. psi2 distr. + q4 = 1.0/(SUM(psi2(n1:n2))*ainc) + psi2(n1:n2) = q4 * psi2(n1:n2) !* Norm. psi2 distr. + !! + !! Rotate peak to correct angle + psi2(:) = CSHIFT( psi2(:), newmaxang-1+nang/4 ) + !!p4--- + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !! + !! Estimate parametric spectrum and deviation from parametric spectrum + !! ------------------------------------------------------------------ + igam = (gam-0.4)*10 + 0.5 + sigz = 0.109 + gam = igam/10. + 0.4 + fdenp = gam * beta / wka(npk)**2.5 + !! + !! + do irng=nrmn,nrmx + fr = frqa(irng) / fpk + if ( fr.le.1.0001 ) then + if ( fr.ge.0.85 ) then + ratio = 1.-(1.-fr)*0.7/0.15 + else + ratio = 0.3*exp(-17.3*(0.85-fr)) + endif + fkscl1(irng) = fdenp*ratio + bscl1(irng) = fkscl1(irng)/oma(irng) + else + z = 0.5*((fr-1.)/sigz)**1.2 + if ( z.gt.6. ) z = 6. + ratio = 1.+exp(-z)*(gam-1.) + fkscl1(irng) = beta*ratio/wka(irng)**2.5 + bscl1(irng) = fkscl1(irng)/oma(irng) + endif + !! + do iang=1,nang + ddd = bscl1(irng) * psi2(iang) / wka(irng) !* large-scale + dens1(irng,iang) = ddd !* large-scale + dens2(irng,iang) = act2d(irng,iang) - ddd !* small-scale + end do + end do ! do irng=nrmn,nrmx + !! ------------------------------------------------------------------ + !! ================================================================== + !! + RETURN + !! + END SUBROUTINE optsa2 + !! + !!============================================================================== + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + SUBROUTINE snlr_fbi ( pha, ialt ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! ------------------------------------------------------------------ + !! + !! it returns: fbi & diag2 all dim=(nrng,nang) + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !! 1. Purpose : + !! + !! -----------------------------------------------------------------# + !! ! + !! For a given Action Density array dens1(k,theta), computes the ! + !! rate-of-change array sumint(k,theta) = dN(k,theta)/dt owing to ! + !! wave-wave interaction, as well as some ancillary arrays ! + !! relating to positive and negative fluxes and their integrals. ! + !! ! + !! -----------------------------------------------------------------# + !! ! + !! Compute: ! + !! -------- ! + !! for both -tsa and -fbi ! + !! + sumint contains scale 1 contibution for Snl -tsa & Snl -fbi ! + !! ! + !! for -tsa ! + !! + sumintsa contains tsa approximation to Snl -tsa ! + !! ! + !! for -fbi ! + !! + sumintp contains scale 2 contribution to Snl -fbi ! + !! + sumintx contains cross interactions between scales 1 and 2 ! + !! -----------------------------------------------------------------# + !! + !! 2. Method : + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! nrng int. Public I # of freq. or rings + !! nang int. Public I # of angles + !! npts int. Public I # of points on the locus + !! nzz int. Public I linear irng x krng = (NK*(NK+1))/2 + !! ialt int. Public I integer switch ialt=2; do alternate + !! ialt=1; do not alternate + !! kzone int. Public I zone of influence = INT(alog(4.0)/alog(dfrq)) + !! na2p1 int. Public I = nang/2 + 1 + !! np2p1 int. Public I = npts/2 + 1 + !! dfrq real Public I frequency multiplier for log freq. spacing + !! frqa R.A. Public I radian frequencies (Hz); dim=(nrng) + !! pha R.A. local I pha = k*dk*dtheta ; dim=(nrng) + !! ------------------------------------------------------------------ + !! + !! *** The 11 grid integration geometry arrays at one given depth + !! *** from gridsetr. dim=(npts,nang,nzz,ndep) + !! kref2 I.A. Public I Index of reference wavenumber for k2 + !! kref4 I.A. Public I Idem for k4 + !! jref2 I.A. Public I Index of reference angle for k2 + !! jref4 I.A. Public I Idem for k4 + !! wtk2 R.A. Public I k2 Interpolation weigth along wavenumbers + !! wtk4 R.A. Public I Idem for k4 + !! wta2 R.A. Public I k2 Interpolation weigth along angles + !! wta4 R.A. Public I Idem for k4 + !! tfac2 R.A. Public I Norm. for interp Action Density at k2 + !! tfac4 R.A. Public I Idem for k4 + !! grad R.A. Public I Coupling and gradient term in integral + !! grad = C * H * g**2 * ds / |dW/dn| + !! ------------------------------------------------------------------ + !! + !! *** large & small scale Action Density from optsa dim=(nrng,nang) + !! dens1 R.A. Public I lrg-scl Action Density (k,theta); + !! dens2 R.A. Public I Sml-scl Action Density (k,theta); + !! ------------------------------------------------------------------ + !! + !! for both -tsa and -fbi + !! sumint R.A. local O contains scale 1 contribution to Snl + !! dim=(nrng,nang) + !! for -tsa + !! sumintsa R.A. local O contains tsa approximation to Snl -tsa + !! dim=(nrng,nang) + !! for -fbi + !! sumintp R.A. local O contains scale 2 contribution to Snl -fbi + !! dim=(nrng,nang) + !! sumintx R.A. local O contains cross interactions " " " -fbi + !! dim=(nrng,nang) + !! ------------------------------------------------------------------ + !! + !! for -tsa; The 2 returned arrays tsa & diag dim=(nrng,nang) + !! tsa R.A. Public O Snl-tsa = sumint + sumintsa + !! diag R.A. Public O Snl-tsa diagonal term = [dN/dn1] + !! ------------------------------------------------------------------ + !! + !! for -fbi; The 2 returned arrays fbi & diag2 dim=(nrng,nang) + !! fbi R.A. Public O Snl-fbi = sumint + sumintp + sumintx + !! diag2 R.A. Public O Snl-fbi diagonal term = [dN/dn1] + !! ------------------------------------------------------------------ + !! + !! 4. Subroutines used : + !! + !! Name Type Module Description + !! ---------------------------------------------------------------- + !! ---------------------------------------------------------------- + !! + !! 5. Called by : + !! + !! Name Type Module Description + !! ---------------------------------------------------------------- + !! gridsetr Subr. W3SNL4MD Setup geometric integration grid + !! ---------------------------------------------------------------- + !! + !! 6. Error messages : + !! + !! None. + !! + !! 7. Remarks : + !! + !! 8. Structure : + !! + !! See source code. + !! + !! 9. Switches : + !! + !! !/S Enable subroutine tracing. + !! + !!10. Source code : + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + IMPLICIT NONE + !! + !! Parameter list + !! -------------- + real, intent(in) :: pha(nrng) + integer, intent(in) :: ialt + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! + !! + !! Local Parameters & variables + !! ----------------------------- + !! for both -tsa and -fbi + integer :: irng,krng, iang,kang + integer :: ipt, iizz, izz + integer :: kmax + integer :: ia2, ia2p, k2, k2p + integer :: ia4, ia4p, k4, k4p + integer :: nref + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for -tsa + !tsa integer :: nklimit, nalimit + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for both -tsa and -fbi + real :: d1, d3, d2, d4 + real :: dp1, dp3 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for both -tsa and -fbi + !! but for -tsa they are being calc. inside if/endif if test is successful + !! and for -fbi they are being calc. outside if/endif always + real :: dz4, dz5 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for both -tsa and -fbi + real :: dx13, ds13, dxp13, dsp13 + real :: dgm, t31, tr31 + real :: w2, w2p, wa2, wa2p, d2a, d2b, tt2 + real :: w4, w4p, wa4, wa4p, d4a, d4b, tt4 + real :: sumint(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for -tsa + !tsa real :: dz2a, dz3a, ttsa, trtsa + !tsa real :: ddn1, ddn3, diagk1, diagk3 + !tsa real :: sumintsa(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for -fbi + real :: dp2, dp4 + real :: d2pa, d4pa + real :: d2pb, d4pb + real :: dz1, dz2, dz3, dz6, dz7, dz8 + real :: dgmp, tp31, trp31, dzsum, txp31, trx31 + !! + !! for -fbi; Bash added 4 new terms for a full expression of diag2 term + real :: ddp1, ddp2, ddp3, ddp4 !* ddpi=di+dpi for i=1,4 + real :: dd2n1, dd2n3, diag2k1, diag2k3 + real :: sumintp(nrng,nang) + real :: sumintx(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !! for -tsa + !! Bash; hardwire these two parameters + !tsa nklimit = 6 + !tsa nalimit = 6 + !! + !! + !!ini + !! Bash; move initialization of all returned arrays from below to here + !! ------------------------------------------------------------------ + !! for both -tsa and -fbi + !! sumint is now initialized here instead of below! + sumint(:,:) = 0.0 + !! + !! for -tsa + !! sumintsa are now initialized here instead of below! + !tsa sumintsa(:,:) = 0.0 + !tsa tsa(:,:) = 0.0 + !tsa diag(:,:) = 0.0 + !! + !! for -fbi + !! sumintp and sumintx are now initialized here instead of below! + sumintp(:,:) = 0.0 + sumintx(:,:) = 0.0 + fbi(:,:) = 0.0 + diag2(:,:) = 0.0 + !!ini--- + !! ------------------------------------------------------------------ + !! ------------------------------------------------------------------ + !! ################################################################## + !! + !! + !! for -tsa + !tsa ddn1 = 0.0 !* for -tsa diag [dN/dn1] + !tsa ddn3 = 0.0 !* for -tsa diag [dN/dn3] + !! + !! for -fbi + dd2n1 = 0.0 !* for -fbi diag2 [dN/dn1] + dd2n3 = 0.0 !* for -fbi diag2 [dN/dn3] + !! + !! + !! + !!50 + do 50 irng=1,nrng,ialt + !!kz + kmax = min(irng+kzone, nrng) !* Bash; Sometimes a locus pt is outside nrng + !kz kmax = min(irng+kzone, nrng-1) !* Bash; Taking 1 out will not affect kzone, try it + !!kz--- + !! + iizz = (nrng-1)*(irng-1) - ((irng-2)*(irng-1))/2 + !! ---------------------------------------------------------------- + !! + !! + !!60 + do 60 iang=1,nang,ialt + !! + !! for both -tsa and -fbi + d1 = dens1(irng,iang) + dp1 = dens2(irng,iang) + !! + !! for -fbi + ddp1 = d1+dp1 !! for full expression of diag2 term + !! + !!70 + !!kz + !kz do 70 krng=irng,nrng + do 70 krng=irng,kmax,ialt + !! + !! for both -tsa and -fbi + !! Bash; check5 be consistent with gridsetr + !! moved here from below (was after do 80 kang=1,nang) + !! and changed go to 80 into go to 70 (i.e. go to next krng) + !kz if ( frqa(krng)/frqa(irng) .gt. 4. ) go to 70 !* original gridsetr + !kz if ( frqa(krng)/frqa(irng) .gt. 3. ) go to 70 !* original snlr_'s + !kz if ( frqa(krng)/frqa(irng) .gt. 2. ) go to 70 !* Bash; use .gt. 2 + !!kz--- + !! + izz = krng + iizz + !! ------------------------------------------------------------ + !! + !!80 + do 80 kang=1,nang,ialt + !! + !! for both -tsa and -fbi + !!ba1 Bash; Remove self interaction + !! skip k1 but keep the opposite angle to k1 - original setting + if ( krng.eq.irng ) then !* wn3 = wn1 + if ( kang.eq.iang ) go to 80 !* th3 = th1 + endif + !!ba1--- + !! ---------------------------------------------------------- + !! + !! for both -tsa and -fbi + d3 = dens1(krng,kang) + dp3 = dens2(krng,kang) + !! + !! for -fbi + ddp3 = d3+dp3 !! for full expression of diag2 term + !! + !! + !! for both -tsa and -fbi + nref = kang - iang + 1 + if ( nref .lt. 1 ) nref = nref + nang + !! + !! + !! for both -tsa and -fbi + !! Bash; check5 be consistent with gridsetr + !! and move this test above right after do 70 krng=irng,nrng + !x if ( frqa(krng)/frqa(irng) .gt. 4. ) go to 80 !* gridsetr + !b if ( frqa(krng)/frqa(irng) .gt. 3. ) go to 80 !* original + !! + !! + !! for both -tsa and -fbi + t31 = 0.0 !* must be reset to 0.0 + !! + !! for -tsa + !tsa ttsa = 0.0 !* must be reset to 0.0 + !tsa diagk1 = 0.0 !* must be reset to 0.0 + !tsa diagk3 = 0.0 !* must be reset to 0.0 + !! + !! for -fbi + tp31 = 0.0 !* must be reset to 0.0 + txp31 = 0.0 !* must be reset to 0.0 + diag2k1 = 0.0 !* must be reset to 0.0 + diag2k3 = 0.0 !* must be reset to 0.0 + !! + !! for both -tsa and -fbi + dx13 = d1*d3 + ds13 = d3-d1 + dxp13 = dp1*dp3 + dsp13 = dp3-dp1 + !! ---------------------------------------------------------- + !! + !!90 + do 90 ipt=1,npts + !! + !! for both -tsa and -fbi + !! save time by skipping insignificant contributions + !!e-30 + !e-30 if ( grad(ipt,nref,izz) .lt. 1.e-30 ) go to 90 + !!e-30--- + if ( grad(ipt,nref,izz) .lt. 1.e-15 ) go to 90 + !!e-30--- + !! -------------------------------------------------------- + !! + !!xlc1 Bash; skip k1 but keep the opposite angle to k1 - original setting + !xlc1 if ( kang.eq.iang ) then !* th3=+th1 + !xlc1 if (ipt.eq.1 .or. ipt.eq.np2p1) go to 90 !* skip x-axis loci + !xlc1 end if + !!xlc1--- + !! -------------------------------------------------------- + !! + !! + !!2 Estimation of Density for wave #2 + !! + !! for both -tsa and -fbi + k2 = kref2(ipt,nref,izz) + k2p = k2 + 1 + w2 = wtk2(ipt,nref,izz) + w2p = 1. - w2 + !! + !! for both -tsa and -fbi + ia2 = iang + jref2(ipt,nref,izz) + if ( ia2 .gt. nang ) ia2 = ia2 - nang + !! + !! for both -tsa and -fbi + ia2p = ia2 + 1 + if ( ia2p .gt. nang ) ia2p = ia2p - nang + !! + !! for both -tsa and -fbi + wa2 = wta2(ipt,nref,izz) + wa2p = 1. - wa2 + d2a = w2 * dens1(k2,ia2) + w2p * dens1(k2p,ia2) + d2b = w2 * dens1(k2,ia2p) + w2p * dens1(k2p,ia2p) + tt2 = tfac2(ipt,nref,izz) + d2 = (wa2*d2a + wa2p*d2b) * tt2 + !! + !! for -fbi + d2pa = w2 * dens2(k2,ia2) + w2p * dens2(k2p,ia2) + d2pb = w2 * dens2(k2,ia2p) + w2p * dens2(k2p,ia2p) + !! + !! for -fbi + dp2 = (wa2*d2pa + wa2p*d2pb) * tt2 !* for -fbi + ddp2 = d2+dp2 !! for full expression of diag2 term + !! ======================================================== + !! + !! + !!4 Estimation of Density for wave #4 + !! + !! for both -tsa and -fbi + k4 = kref4(ipt,nref,izz) + k4p = k4 + 1 + w4 = wtk4(ipt,nref,izz) + w4p = 1. - w4 + !! + !! for both -tsa and -fbi + ia4 = iang + jref4(ipt,nref,izz) + if ( ia4 .gt. nang ) ia4 = ia4 - nang + !! + !! for both -tsa and -fbi + ia4p= ia4 + 1 + if ( ia4p .gt. nang ) ia4p = ia4p - nang + !! + !! for both -tsa and -fbi + wa4 = wta4(ipt,nref,izz) + wa4p = 1. - wa4 + d4a = w4*dens1(k4,ia4) + w4p*dens1(k4p,ia4) + d4b = w4*dens1(k4,ia4p) + w4p*dens1(k4p,ia4p) + tt4 = tfac4(ipt,nref,izz) + d4 = (wa4*d4a + wa4p*d4b) * tt4 + !! + !! for -fbi + d4pa = w4*dens2(k4,ia4) + w4p*dens2(k4p,ia4) + d4pb = w4*dens2(k4,ia4p) + w4p*dens2(k4p,ia4p) + !! + !! for -fbi + dp4 = (wa4*d4pa + wa4p*d4pb) * tt4 !* for -fbi + ddp4 = d4+dp4 !! for full expression of diag2 term + !! ======================================================== + !! + !! + !! for both -tsa and -fbi + dgm = dx13*(d4-d2) + ds13*d4*d2 !* dgm=B of R&P'08 eqn(8) + !! !* represents Broad Scale interactions + t31 = t31 + dgm * grad(ipt,nref,izz) + !! -------------------------------------------------------- + !! + !! for -fbi + dgmp = dxp13*(dp4-dp2) + dsp13*dp4*dp2 !* dgmp=L of R&P'08 eqn(8) + !! !* represents Local Scale interactions + tp31 = tp31 + dgmp * grad(ipt,nref,izz) + !! -------------------------------------------------------- + !! ======================================================== + !! + !! + !! for -tsa : -diag + !! use this expression for the diagonal term + !! whose derivation neglect "dp2" & "dp4" + !tsa ddn1 = (d3+dp3)*(d4-d2) - d4*d2 !* dN/dn1 + !tsa ddn3 = (d1+dp1)*(d4-d2) + d4*d2 !* dN/dn3 + !tsa diagk1 = diagk1 + ddn1 * grad(ipt,nref,izz) + !tsa diagk3 = diagk3 + ddn3 * grad(ipt,nref,izz) + !! -------------------------------------------------------- + !! + !! for -fbi : -diag2 + !! use the full expression for the diagonal terms + !! whose derivation keeps all large + small scale + dd2n1 = ddp3*(ddp4-ddp2) - ddp4*ddp2 !* dN/dn1 + dd2n3 = ddp1*(ddp4-ddp2) + ddp4*ddp2 !* dN/dn3 + diag2k1 = diag2k1 + dd2n1 * grad(ipt,nref,izz) + diag2k3 = diag2k3 + dd2n3 * grad(ipt,nref,izz) + !! -------------------------------------------------------- + !! ======================================================== + !! + !! + !! for -fbi + dz1 = dx13 * (dp4-dp2) + dz2 = d1*dp3 * ((d4-d2)+(dp4-dp2)) + dz3 = d3*dp1 * ((d4-d2)+(dp4-dp2)) + !! + !! for -fbi (calc. dz4 & dz5 here) + dz4 = dxp13 * (d4-d2) + dz5 = d2*d4 * dsp13 + !! + !! for -tsa + !! Cross-interactions between parametric and perturbation + !! that occur only when k3 is close enough to k1 + !! Bash; added an extra check on (nang-nalimit) + !b if ( iabs(irng-krng).lt.nklimit .and. & + !b iabs(iang-kang).lt.nalimit ) then !* original + !! + !tsa if ( (krng-irng).lt.nklimit .and. & + !tsa ( iabs(kang-iang).lt.nalimit .or. & + !tsa iabs(kang-iang).gt.(nang-nalimit) ) ) then !* Bash + !! + !! for -tsa (calc. dz4 & dz5 here) + !tsa dz4 = dxp13 * (d4-d2) + !tsa dz5 = d2*d4 * dsp13 + !tsa dz2a = d1*dp3 * (d4-d2) + !tsa dz3a = d3*dp1 * (d4-d2) + !! + !tsa ttsa = ttsa + (dz4+dz5+dz2a+dz3a)*grad(ipt,nref,izz) + !! + !tsa endif + !! -------------------------------------------------------- + !! + !! for -fbi + dz6 = d2*dp4 * (ds13+dsp13) + dz7 = d4*dp2 * (ds13+dsp13) + dz8 = dp2*dp4 * ds13 + dzsum = dz1 + dz2 + dz3 + dz4 + dz5 + dz6 + dz7 + dz8 + txp31 = txp31 + dzsum * grad(ipt,nref,izz) + !! -------------------------------------------------------- + !! ======================================================== + !! + !! +90 end do !* end of ipt (locus) loop + !! ---------------------------------------------------------- + !! + !! + !! multiply the following components by factor 2. in here + !! + !! for both -tsa and -fbi + tr31 = 2. * t31 + !! + !! for -tsa + !tsa trtsa = 2. * ttsa + !! + !! for -fbi + trp31 = 2. * tp31 + trx31 = 2. * txp31 + !! + !! for -tsa : -diag + !tsa diagk1 = 2. * diagk1 + !tsa diagk3 = 2. * diagk3 + !! + !! for -fbi : -diag2 + diag2k1 = 2. * diag2k1 + diag2k3 = 2. * diag2k3 + !! ---------------------------------------------------------- + !! + !! for both -tsa and -fbi + sumint(irng,iang) = sumint(irng,iang) + tr31*pha(krng) + sumint(krng,kang) = sumint(krng,kang) - tr31*pha(irng) + !! ---------------------------------------------------------- + !! + !! for -tsa + !tsa sumintsa(irng,iang)= sumintsa(irng,iang)+ trtsa*pha(krng) + !tsa sumintsa(krng,kang)= sumintsa(krng,kang)- trtsa*pha(irng) + !! ---------------------------------------------------------- + !! + !! for -fbi + sumintp(irng,iang) = sumintp(irng,iang) + trp31*pha(krng) + sumintp(krng,kang) = sumintp(krng,kang) - trp31*pha(irng) + !! + !! for -fbi + sumintx(irng,iang) = sumintx(irng,iang) + trx31*pha(krng) + sumintx(krng,kang) = sumintx(krng,kang) - trx31*pha(irng) + !! ---------------------------------------------------------- + !! + !! for -tsa : -diag + !tsa diag(irng,iang) = diag(irng,iang) + diagk1*pha(krng) + !tsa diag(krng,kang) = diag(krng,kang) - diagk3*pha(irng) + !! ---------------------------------------------------------- + !! + !! for -fbi : -diag2 + diag2(irng,iang) = diag2(irng,iang) + diag2k1*pha(krng) + diag2(krng,kang) = diag2(krng,kang) - diag2k3*pha(irng) + !! ---------------------------------------------------------- + !! +80 end do !* end of kang loop + !! +70 end do !* end of krng loop + !! +60 end do !* end of iang loop + !! +50 end do !* end of irng loop + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !! Final sum-up to get Snl and diag. term to be returned + !! + !! for -tsa + !tsa tsa(:,:) = sumint(:,:) + sumintsa(:,:) + !b diag(:,:) = diag(:,:) !* is Ok, already summed up + !! + !! for -fbi + fbi(:,:) = sumint(:,:) + sumintp(:,:) + sumintx(:,:) + !b diag2(:,:) = diag2(:,:) !* is Ok, already summed up + !! -------------------------------------------------------------------------- + !! ========================================================================== + !! + !! + !!alt Call interp2 only if ialt=2, + !! Interpolate bi-linearly to fill in tsa/fbi & diag/diag2 arrays + !! after alternating the irng, iang, krng & kang loops above + !! ------------------------------------------------------------------ + if ( ialt.eq.2 ) then + !! for -tsa + !tsa call interp2 ( tsa ) + !tsa call interp2 ( diag ) + !! + !! for -fbi + call interp2 ( fbi ) + call interp2 ( diag2 ) + endif + !!alt--- + !! -------------------------------------------------------------------------- + !! ========================================================================== + !! + RETURN + !! + END SUBROUTINE snlr_fbi + !! + !!============================================================================== + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + SUBROUTINE snlr_tsa ( pha, ialt ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! ------------------------------------------------------------------ + !! + !! it returns: tsa & diag all dim=(nrng,nang) + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !! 1. Purpose : + !! + !! -----------------------------------------------------------------# + !! ! + !! For a given Action Density array dens1(k,theta), computes the ! + !! rate-of-change array sumint(k,theta) = dN(k,theta)/dt owing to ! + !! wave-wave interaction, as well as some ancillary arrays ! + !! relating to positive and negative fluxes and their integrals. ! + !! ! + !! -----------------------------------------------------------------# + !! ! + !! Compute: ! + !! -------- ! + !! for both -tsa and -fbi ! + !! + sumint contains scale 1 contibution for Snl -tsa & Snl -fbi ! + !! ! + !! for -tsa ! + !! + sumintsa contains tsa approximation to Snl -tsa ! + !! ! + !! for -fbi ! + !! + sumintp contains scale 2 contribution to Snl -fbi ! + !! + sumintx contains cross interactions between scales 1 and 2 ! + !! -----------------------------------------------------------------# + !! + !! 2. Method : + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! nrng int. Public I # of freq. or rings + !! nang int. Public I # of angles + !! npts int. Public I # of points on the locus + !! nzz int. Public I linear irng x krng = (NK*(NK+1))/2 + !! ialt int. Public I integer switch ialt=2; do alternate + !! ialt=1; do not alternate + !! kzone int. Public I zone of influence = INT(alog(4.0)/alog(dfrq)) + !! na2p1 int. Public I = nang/2 + 1 + !! np2p1 int. Public I = npts/2 + 1 + !! dfrq real Public I frequency multiplier for log freq. spacing + !! frqa R.A. Public I radian frequencies (Hz); dim=(nrng) + !! pha R.A. local I pha = k*dk*dtheta ; dim=(nrng) + !! ------------------------------------------------------------------ + !! + !! *** The 11 grid integration geometry arrays at one given depth + !! *** from gridsetr. dim=(npts,nang,nzz,ndep) + !! kref2 I.A. Public I Index of reference wavenumber for k2 + !! kref4 I.A. Public I Idem for k4 + !! jref2 I.A. Public I Index of reference angle for k2 + !! jref4 I.A. Public I Idem for k4 + !! wtk2 R.A. Public I k2 Interpolation weigth along wavenumbers + !! wtk4 R.A. Public I Idem for k4 + !! wta2 R.A. Public I k2 Interpolation weigth along angles + !! wta4 R.A. Public I Idem for k4 + !! tfac2 R.A. Public I Norm. for interp Action Density at k2 + !! tfac4 R.A. Public I Idem for k4 + !! grad R.A. Public I Coupling and gradient term in integral + !! grad = C * H * g**2 * ds / |dW/dn| + !! ------------------------------------------------------------------ + !! + !! *** large & small scale Action Density from optsa dim=(nrng,nang) + !! dens1 R.A. Public I lrg-scl Action Density (k,theta); + !! dens2 R.A. Public I Sml-scl Action Density (k,theta); + !! ------------------------------------------------------------------ + !! + !! for both -tsa and -fbi + !! sumint R.A. local O contains scale 1 contribution to Snl + !! dim=(nrng,nang) + !! for -tsa + !! sumintsa R.A. local O contains tsa approximation to Snl -tsa + !! dim=(nrng,nang) + !! for -fbi + !! sumintp R.A. local O contains scale 2 contribution to Snl -fbi + !! dim=(nrng,nang) + !! sumintx R.A. local O contains cross interactions " " " -fbi + !! dim=(nrng,nang) + !! ------------------------------------------------------------------ + !! + !! for -tsa; The 2 returned arrays tsa & diag dim=(nrng,nang) + !! tsa R.A. Public O Snl-tsa = sumint + sumintsa + !! diag R.A. Public O Snl-tsa diagonal term = [dN/dn1] + !! ------------------------------------------------------------------ + !! + !! for -fbi; The 2 returned arrays fbi & diag2 dim=(nrng,nang) + !! fbi R.A. Public O Snl-fbi = sumint + sumintp + sumintx + !! diag2 R.A. Public O Snl-fbi diagonal term = [dN/dn1] + !! ------------------------------------------------------------------ + !! + !! 4. Subroutines used : + !! + !! Name Type Module Description + !! ---------------------------------------------------------------- + !! ---------------------------------------------------------------- + !! + !! 5. Called by : + !! + !! Name Type Module Description + !! ---------------------------------------------------------------- + !! gridsetr Subr. W3SNL4MD Setup geometric integration grid + !! ---------------------------------------------------------------- + !! + !! 6. Error messages : + !! + !! None. + !! + !! 7. Remarks : + !! + !! 8. Structure : + !! + !! See source code. + !! + !! 9. Switches : + !! + !! !/S Enable subroutine tracing. + !! + !!10. Source code : + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + IMPLICIT NONE + !! + !! Parameter list + !! -------------- + real, intent(in) :: pha(nrng) + integer, intent(in) :: ialt + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! + !! + !! Local Parameters & variables + !! ----------------------------- + !! for both -tsa and -fbi + integer :: irng,krng, iang,kang + integer :: ipt, iizz, izz + integer :: kmax + integer :: ia2, ia2p, k2, k2p + integer :: ia4, ia4p, k4, k4p + integer :: nref + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for -tsa + integer :: nklimit, nalimit + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for both -tsa and -fbi + real :: d1, d3, d2, d4 + real :: dp1, dp3 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for both -tsa and -fbi + !! but for -tsa they are being calc. inside if/endif if test is successful + !! and for -fbi they are being calc. outside if/endif always + real :: dz4, dz5 + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for both -tsa and -fbi + real :: dx13, ds13, dxp13, dsp13 + real :: dgm, t31, tr31 + real :: w2, w2p, wa2, wa2p, d2a, d2b, tt2 + real :: w4, w4p, wa4, wa4p, d4a, d4b, tt4 + real :: sumint(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for -tsa + real :: dz2a, dz3a, ttsa, trtsa + real :: ddn1, ddn3, diagk1, diagk3 + real :: sumintsa(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! + !! for -fbi + !fbi real :: dp2, dp4 + !fbi real :: d2pa, d4pa + !fbi real :: d2pb, d4pb + !fbi real :: dz1, dz2, dz3, dz6, dz7, dz8 + !fbi real :: dgmp, tp31, trp31, dzsum, txp31, trx31 + !! + !! for -fbi; Bash added 4 new terms for a full expression of diag2 term + !fbi real :: ddp1, ddp2, ddp3, ddp4 !* ddpi=di+dpi for i=1,4 + !fbi real :: dd2n1, dd2n3, diag2k1, diag2k3 + !fbi real :: sumintp(nrng,nang) + !fbi real :: sumintx(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !! for -tsa + !! Bash; hardwire these two parameters + nklimit = 6 + nalimit = 6 + !! + !! + !!ini + !! Bash; move initialization of all returned arrays from below to here + !! ------------------------------------------------------------------ + !! for both -tsa and -fbi + !! sumint is now initialized here instead of below! + sumint(:,:) = 0.0 + !! + !! for -tsa + !! sumintsa are now initialized here instead of below! + sumintsa(:,:) = 0.0 + tsa(:,:) = 0.0 + diag(:,:) = 0.0 + !! + !! for -fbi + !! sumintp and sumintx are now initialized here instead of below! + !fbi sumintp(:,:) = 0.0 + !fbi sumintx(:,:) = 0.0 + !fbi fbi(:,:) = 0.0 + !fbi diag2(:,:) = 0.0 + !!ini--- + !! ------------------------------------------------------------------ + !! ------------------------------------------------------------------ + !! ################################################################## + !! + !! + !! for -tsa + ddn1 = 0.0 !* for -tsa diag [dN/dn1] + ddn3 = 0.0 !* for -tsa diag [dN/dn3] + !! + !! for -fbi + !fbi dd2n1 = 0.0 !* for -fbi diag2 [dN/dn1] + !fbi dd2n3 = 0.0 !* for -fbi diag2 [dN/dn3] + !! + !! + !! + !!50 + do 50 irng=1,nrng,ialt + !!kz + kmax = min(irng+kzone, nrng) !* Bash; Sometimes a locus pt is outside nrng + !kz kmax = min(irng+kzone, nrng-1) !* Bash; Taking 1 out will not affect kzone, try it + !!kz--- + !! + iizz = (nrng-1)*(irng-1) - ((irng-2)*(irng-1))/2 + !! ---------------------------------------------------------------- + !! + !! + !!60 + do 60 iang=1,nang,ialt + !! + !! for both -tsa and -fbi + d1 = dens1(irng,iang) + dp1 = dens2(irng,iang) + !! + !! for -fbi + !fbi ddp1 = d1+dp1 !! for full expression of diag2 term + !! + !!70 + !!kz + !kz do 70 krng=irng,nrng + do 70 krng=irng,kmax,ialt + !! + !! for both -tsa and -fbi + !! Bash; check5 be consistent with gridsetr + !! moved here from below (was after do 80 kang=1,nang) + !! and changed go to 80 into go to 70 (i.e. go to next krng) + !kz if ( frqa(krng)/frqa(irng) .gt. 4. ) go to 70 !* original gridsetr + !kz if ( frqa(krng)/frqa(irng) .gt. 3. ) go to 70 !* original snlr_'s + !kz if ( frqa(krng)/frqa(irng) .gt. 2. ) go to 70 !* Bash; use .gt. 2 + !!kz--- + !! + izz = krng + iizz + !! ------------------------------------------------------------ + !! + !!80 + do 80 kang=1,nang,ialt + !! + !! for both -tsa and -fbi + !!ba1 Bash; Remove self interaction + !! skip k1 but keep the opposite angle to k1 - original setting + if ( krng.eq.irng ) then !* wn3 = wn1 + if ( kang.eq.iang ) go to 80 !* th3 = th1 + endif + !!ba1--- + !! ---------------------------------------------------------- + !! + !! for both -tsa and -fbi + d3 = dens1(krng,kang) + dp3 = dens2(krng,kang) + !! + !! for -fbi + !fbi ddp3 = d3+dp3 !! for full expression of diag2 term + !! + !! + !! for both -tsa and -fbi + nref = kang - iang + 1 + if ( nref .lt. 1 ) nref = nref + nang + !! + !! + !! for both -tsa and -fbi + !! Bash; check5 be consistent with gridsetr + !! and move this test above right after do 70 krng=irng,nrng + !x if ( frqa(krng)/frqa(irng) .gt. 4. ) go to 80 !* gridsetr + !b if ( frqa(krng)/frqa(irng) .gt. 3. ) go to 80 !* original + !! + !! + !! for both -tsa and -fbi + t31 = 0.0 !* must be reset to 0.0 + !! + !! for -tsa + ttsa = 0.0 !* must be reset to 0.0 + diagk1 = 0.0 !* must be reset to 0.0 + diagk3 = 0.0 !* must be reset to 0.0 + !! + !! for -fbi + !fbi tp31 = 0.0 !* must be reset to 0.0 + !fbi txp31 = 0.0 !* must be reset to 0.0 + !fbi diag2k1 = 0.0 !* must be reset to 0.0 + !fbi diag2k3 = 0.0 !* must be reset to 0.0 + !! + !! for both -tsa and -fbi + dx13 = d1*d3 + ds13 = d3-d1 + dxp13 = dp1*dp3 + dsp13 = dp3-dp1 + !! ---------------------------------------------------------- + !! + !!90 + do 90 ipt=1,npts + !! + !! for both -tsa and -fbi + !! save time by skipping insignificant contributions + !!e-30 + !e-30 if ( grad(ipt,nref,izz) .lt. 1.e-30 ) go to 90 + !!e-30--- + if ( grad(ipt,nref,izz) .lt. 1.e-15 ) go to 90 + !!e-30--- + !! -------------------------------------------------------- + !! + !!xlc1 Bash; skip k1 but keep the opposite angle to k1 - original setting + !xlc1 if ( kang.eq.iang ) then !* th3=+th1 + !xlc1 if (ipt.eq.1 .or. ipt.eq.np2p1) go to 90 !* skip x-axis loci + !xlc1 end if + !!xlc1--- + !! -------------------------------------------------------- + !! + !! + !!2 Estimation of Density for wave #2 + !! + !! for both -tsa and -fbi + k2 = kref2(ipt,nref,izz) + k2p = k2 + 1 + w2 = wtk2(ipt,nref,izz) + w2p = 1. - w2 + !! + !! for both -tsa and -fbi + ia2 = iang + jref2(ipt,nref,izz) + if ( ia2 .gt. nang ) ia2 = ia2 - nang + !! + !! for both -tsa and -fbi + ia2p = ia2 + 1 + if ( ia2p .gt. nang ) ia2p = ia2p - nang + !! + !! for both -tsa and -fbi + wa2 = wta2(ipt,nref,izz) + wa2p = 1. - wa2 + d2a = w2 * dens1(k2,ia2) + w2p * dens1(k2p,ia2) + d2b = w2 * dens1(k2,ia2p) + w2p * dens1(k2p,ia2p) + tt2 = tfac2(ipt,nref,izz) + d2 = (wa2*d2a + wa2p*d2b) * tt2 + !! + !! for -fbi + !fbi d2pa = w2 * dens2(k2,ia2) + w2p * dens2(k2p,ia2) + !fbi d2pb = w2 * dens2(k2,ia2p) + w2p * dens2(k2p,ia2p) + !! + !! for -fbi + !fbi dp2 = (wa2*d2pa + wa2p*d2pb) * tt2 !* for -fbi + !fbi ddp2 = d2+dp2 !! for full expression of diag2 term + !! ======================================================== + !! + !! + !!4 Estimation of Density for wave #4 + !! + !! for both -tsa and -fbi + k4 = kref4(ipt,nref,izz) + k4p = k4 + 1 + w4 = wtk4(ipt,nref,izz) + w4p = 1. - w4 + !! + !! for both -tsa and -fbi + ia4 = iang + jref4(ipt,nref,izz) + if ( ia4 .gt. nang ) ia4 = ia4 - nang + !! + !! for both -tsa and -fbi + ia4p= ia4 + 1 + if ( ia4p .gt. nang ) ia4p = ia4p - nang + !! + !! for both -tsa and -fbi + wa4 = wta4(ipt,nref,izz) + wa4p = 1. - wa4 + d4a = w4*dens1(k4,ia4) + w4p*dens1(k4p,ia4) + d4b = w4*dens1(k4,ia4p) + w4p*dens1(k4p,ia4p) + tt4 = tfac4(ipt,nref,izz) + d4 = (wa4*d4a + wa4p*d4b) * tt4 + !! + !! for -fbi + !fbi d4pa = w4*dens2(k4,ia4) + w4p*dens2(k4p,ia4) + !fbi d4pb = w4*dens2(k4,ia4p) + w4p*dens2(k4p,ia4p) + !! + !! for -fbi + !fbi dp4 = (wa4*d4pa + wa4p*d4pb) * tt4 !* for -fbi + !fbi ddp4 = d4+dp4 !! for full expression of diag2 term + !! ======================================================== + !! + !! + !! for both -tsa and -fbi + dgm = dx13*(d4-d2) + ds13*d4*d2 !* dgm=B of R&P'08 eqn(8) + !! !* represents Broad Scale interactions + t31 = t31 + dgm * grad(ipt,nref,izz) + !! -------------------------------------------------------- + !! + !! for -fbi + !fbi dgmp = dxp13*(dp4-dp2) + dsp13*dp4*dp2 !* dgmp=L of R&P'08 eqn(8) + !! !* represents Local Scale interactions + !fbi tp31 = tp31 + dgmp * grad(ipt,nref,izz) + !! -------------------------------------------------------- + !! ======================================================== + !! + !! + !! for -tsa : -diag + !! use this expression for the diagonal term + !! whose derivation neglect "dp2" & "dp4" + ddn1 = (d3+dp3)*(d4-d2) - d4*d2 !* dN/dn1 + ddn3 = (d1+dp1)*(d4-d2) + d4*d2 !* dN/dn3 + diagk1 = diagk1 + ddn1 * grad(ipt,nref,izz) + diagk3 = diagk3 + ddn3 * grad(ipt,nref,izz) + !! -------------------------------------------------------- + !! + !! for -fbi : -diag2 + !! use the full expression for the diagonal terms + !! whose derivation keeps all large + small scale + !fbi dd2n1 = ddp3*(ddp4-ddp2) - ddp4*ddp2 !* dN/dn1 + !fbi dd2n3 = ddp1*(ddp4-ddp2) + ddp4*ddp2 !* dN/dn3 + !fbi diag2k1 = diag2k1 + dd2n1 * grad(ipt,nref,izz) + !fbi diag2k3 = diag2k3 + dd2n3 * grad(ipt,nref,izz) + !! -------------------------------------------------------- + !! ======================================================== + !! + !! + !! for -fbi + !fbi dz1 = dx13 * (dp4-dp2) + !fbi dz2 = d1*dp3 * ((d4-d2)+(dp4-dp2)) + !fbi dz3 = d3*dp1 * ((d4-d2)+(dp4-dp2)) + !! + !! for -fbi (calc. dz4 & dz5 here) + !fbi dz4 = dxp13 * (d4-d2) + !fbi dz5 = d2*d4 * dsp13 + !! + !! for -tsa + !! Cross-interactions between parametric and perturbation + !! that occur only when k3 is close enough to k1 + !! Bash; added an extra check on (nang-nalimit) + !b if ( iabs(irng-krng).lt.nklimit .and. & + !b iabs(iang-kang).lt.nalimit ) then !* original + !! + if ( (krng-irng).lt.nklimit .and. & ( iabs(kang-iang).lt.nalimit .or. & - iabs(kang-iang).gt.(nang-nalimit) ) ) then !* Bash -!! -!! for -tsa (calc. dz4 & dz5 here) - dz4 = dxp13 * (d4-d2) - dz5 = d2*d4 * dsp13 - dz2a = d1*dp3 * (d4-d2) - dz3a = d3*dp1 * (d4-d2) -!! - ttsa = ttsa + (dz4+dz5+dz2a+dz3a)*grad(ipt,nref,izz) -!! - endif -!! -------------------------------------------------------- -!! -!! for -fbi -!fbi dz6 = d2*dp4 * (ds13+dsp13) -!fbi dz7 = d4*dp2 * (ds13+dsp13) -!fbi dz8 = dp2*dp4 * ds13 -!fbi dzsum = dz1 + dz2 + dz3 + dz4 + dz5 + dz6 + dz7 + dz8 -!fbi txp31 = txp31 + dzsum * grad(ipt,nref,izz) -!! -------------------------------------------------------- -!! ======================================================== -!! -!! -90 end do !* end of ipt (locus) loop -!! ---------------------------------------------------------- -!! -!! -!! multiply the following components by factor 2. in here -!! -!! for both -tsa and -fbi - tr31 = 2. * t31 -!! -!! for -tsa - trtsa = 2. * ttsa -!! -!! for -fbi -!fbi trp31 = 2. * tp31 -!fbi trx31 = 2. * txp31 -!! -!! for -tsa : -diag - diagk1 = 2. * diagk1 - diagk3 = 2. * diagk3 -!! -!! for -fbi : -diag2 -!fbi diag2k1 = 2. * diag2k1 -!fbi diag2k3 = 2. * diag2k3 -!! ---------------------------------------------------------- -!! -!! for both -tsa and -fbi - sumint(irng,iang) = sumint(irng,iang) + tr31*pha(krng) - sumint(krng,kang) = sumint(krng,kang) - tr31*pha(irng) -!! ---------------------------------------------------------- -!! -!! for -tsa - sumintsa(irng,iang)= sumintsa(irng,iang)+ trtsa*pha(krng) - sumintsa(krng,kang)= sumintsa(krng,kang)- trtsa*pha(irng) -!! ---------------------------------------------------------- -!! -!! for -fbi -!fbi sumintp(irng,iang) = sumintp(irng,iang) + trp31*pha(krng) -!fbi sumintp(krng,kang) = sumintp(krng,kang) - trp31*pha(irng) -!! -!! for -fbi -!fbi sumintx(irng,iang) = sumintx(irng,iang) + trx31*pha(krng) -!fbi sumintx(krng,kang) = sumintx(krng,kang) - trx31*pha(irng) -!! ---------------------------------------------------------- -!! -!! for -tsa : -diag - diag(irng,iang) = diag(irng,iang) + diagk1*pha(krng) - diag(krng,kang) = diag(krng,kang) - diagk3*pha(irng) -!! ---------------------------------------------------------- -!! -!! for -fbi : -diag2 -!fbi diag2(irng,iang) = diag2(irng,iang) + diag2k1*pha(krng) -!fbi diag2(krng,kang) = diag2(krng,kang) - diag2k3*pha(irng) -!! ---------------------------------------------------------- -!! -80 end do !* end of kang loop -!! -70 end do !* end of krng loop -!! -60 end do !* end of iang loop -!! + iabs(kang-iang).gt.(nang-nalimit) ) ) then !* Bash + !! + !! for -tsa (calc. dz4 & dz5 here) + dz4 = dxp13 * (d4-d2) + dz5 = d2*d4 * dsp13 + dz2a = d1*dp3 * (d4-d2) + dz3a = d3*dp1 * (d4-d2) + !! + ttsa = ttsa + (dz4+dz5+dz2a+dz3a)*grad(ipt,nref,izz) + !! + endif + !! -------------------------------------------------------- + !! + !! for -fbi + !fbi dz6 = d2*dp4 * (ds13+dsp13) + !fbi dz7 = d4*dp2 * (ds13+dsp13) + !fbi dz8 = dp2*dp4 * ds13 + !fbi dzsum = dz1 + dz2 + dz3 + dz4 + dz5 + dz6 + dz7 + dz8 + !fbi txp31 = txp31 + dzsum * grad(ipt,nref,izz) + !! -------------------------------------------------------- + !! ======================================================== + !! + !! +90 end do !* end of ipt (locus) loop + !! ---------------------------------------------------------- + !! + !! + !! multiply the following components by factor 2. in here + !! + !! for both -tsa and -fbi + tr31 = 2. * t31 + !! + !! for -tsa + trtsa = 2. * ttsa + !! + !! for -fbi + !fbi trp31 = 2. * tp31 + !fbi trx31 = 2. * txp31 + !! + !! for -tsa : -diag + diagk1 = 2. * diagk1 + diagk3 = 2. * diagk3 + !! + !! for -fbi : -diag2 + !fbi diag2k1 = 2. * diag2k1 + !fbi diag2k3 = 2. * diag2k3 + !! ---------------------------------------------------------- + !! + !! for both -tsa and -fbi + sumint(irng,iang) = sumint(irng,iang) + tr31*pha(krng) + sumint(krng,kang) = sumint(krng,kang) - tr31*pha(irng) + !! ---------------------------------------------------------- + !! + !! for -tsa + sumintsa(irng,iang)= sumintsa(irng,iang)+ trtsa*pha(krng) + sumintsa(krng,kang)= sumintsa(krng,kang)- trtsa*pha(irng) + !! ---------------------------------------------------------- + !! + !! for -fbi + !fbi sumintp(irng,iang) = sumintp(irng,iang) + trp31*pha(krng) + !fbi sumintp(krng,kang) = sumintp(krng,kang) - trp31*pha(irng) + !! + !! for -fbi + !fbi sumintx(irng,iang) = sumintx(irng,iang) + trx31*pha(krng) + !fbi sumintx(krng,kang) = sumintx(krng,kang) - trx31*pha(irng) + !! ---------------------------------------------------------- + !! + !! for -tsa : -diag + diag(irng,iang) = diag(irng,iang) + diagk1*pha(krng) + diag(krng,kang) = diag(krng,kang) - diagk3*pha(irng) + !! ---------------------------------------------------------- + !! + !! for -fbi : -diag2 + !fbi diag2(irng,iang) = diag2(irng,iang) + diag2k1*pha(krng) + !fbi diag2(krng,kang) = diag2(krng,kang) - diag2k3*pha(irng) + !! ---------------------------------------------------------- + !! +80 end do !* end of kang loop + !! +70 end do !* end of krng loop + !! +60 end do !* end of iang loop + !! 50 end do !* end of irng loop -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!! Final sum-up to get Snl and diag. term to be returned -!! -!! for -tsa - tsa(:,:) = sumint(:,:) + sumintsa(:,:) -!b diag(:,:) = diag(:,:) !* is Ok, already summed up -!! -!! for -fbi -!fbi fbi(:,:) = sumint(:,:) + sumintp(:,:) + sumintx(:,:) -!b diag2(:,:) = diag2(:,:) !* is Ok, already summed up -!! -------------------------------------------------------------------------- -!! ========================================================================== -!! -!! -!!alt Call interp2 only if ialt=2, -!! Interpolate bi-linearly to fill in tsa/fbi & diag/diag2 arrays -!! after alternating the irng, iang, krng & kang loops above -!! ------------------------------------------------------------------ - if ( ialt.eq.2 ) then -!! for -tsa - call interp2 ( tsa ) - call interp2 ( diag ) -!! -!! for -fbi -!fbi call interp2 ( fbi ) -!fbi call interp2 ( diag2 ) - endif -!!alt--- -!! -------------------------------------------------------------------------- -!! ========================================================================== -!! - RETURN -!! - END SUBROUTINE snlr_tsa -!! -!!============================================================================== -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE interp2 ( X ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! -!! 1. Purpose : -!! -!! Interpolate bi-linearly to fill in tsa/fbi & diag/diag2 arrays -!! and then (optional) smooth the interior and the corners -!! after alternating the irng, iang, krng & kang loops in snlr's -!! -!! 2. Method : -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! nrng int. Public I # of freq. or rings -!! nang int. Public I # of angles -!! ismo int. Local I switch; ismo=0 skip smoothing -!! ismo.ne.0 do smoothing -!! X R.A. Local I/O Array to be ineterp. & smoothing -!! its returned to snlr_tsa as tsa or diag -!! and to snlr_fbi as fbi or diag2 -!! dim=(nrng,nang) -!! ------------------------------------------------------------------ -!! -!! 4. Subroutines used : -!! -!! Name Type Module Description -!! ---------------------------------------------------------------- -!! ---------------------------------------------------------------- -!! -!! 5. Called by : -!! -!! Name Type Module Description -!! ---------------------------------------------------------------- -!! snlr_tsa Subr. W3SNL4MD Computes dN(k,theta)/dt for TSA -!! -------- due to wave-wave inter. (set itsa = 1) -!! snlr_fbi Subr. W3SNL4MD Computes dN(k,theta)/dt for FBI -!! -------- due to wave-wave inter. (set itsa = 0) -!! ---------------------------------------------------------------- -!! -!! 6. Error messages : -!! -!! None. -!! -!! 7. Remarks : -!! -!! 8. Structure : -!! -!! See source code. -!! -!! 9. Switches : -!! -!! !/S Enable subroutine tracing. -!! -!!10. Source code : -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! - IMPLICIT NONE -!! -!! -!! Parameter list -!! -------------- - REAL, INTENT(INOUT) :: X(nrng,nang) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! -!! -!! Local Parameters -!! ---------------- - integer :: irng, iang - real :: Y(nrng,nang) !* dummy array used in smoothing -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! -!!-0 Initial Y(:,:) array before it's computed -!!ini - Y(:,:) = 0.0 -!!ini--- -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!!-1 Interpolate using simple 2 point averaging to fill in X -!! Remeber: nang must be an even number ==> nang-2 is an even number -!! and nrng must be an odd number ==> nrng-1 is an even number -!! Example numbers used here are for nrng=35 & nang=36 -!! ------------------------------------------------------------------ -!! -!!-1a For every calculated iang (1,3,5,..,nang-1=35) -!! fill in missing irng's (2,4,6,..,nrng-1=34) + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !! Final sum-up to get Snl and diag. term to be returned + !! + !! for -tsa + tsa(:,:) = sumint(:,:) + sumintsa(:,:) + !b diag(:,:) = diag(:,:) !* is Ok, already summed up + !! + !! for -fbi + !fbi fbi(:,:) = sumint(:,:) + sumintp(:,:) + sumintx(:,:) + !b diag2(:,:) = diag2(:,:) !* is Ok, already summed up + !! -------------------------------------------------------------------------- + !! ========================================================================== + !! + !! + !!alt Call interp2 only if ialt=2, + !! Interpolate bi-linearly to fill in tsa/fbi & diag/diag2 arrays + !! after alternating the irng, iang, krng & kang loops above + !! ------------------------------------------------------------------ + if ( ialt.eq.2 ) then + !! for -tsa + call interp2 ( tsa ) + call interp2 ( diag ) + !! + !! for -fbi + !fbi call interp2 ( fbi ) + !fbi call interp2 ( diag2 ) + endif + !!alt--- + !! -------------------------------------------------------------------------- + !! ========================================================================== + !! + RETURN + !! + END SUBROUTINE snlr_tsa + !! + !!============================================================================== + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + SUBROUTINE interp2 ( X ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! + !! 1. Purpose : + !! + !! Interpolate bi-linearly to fill in tsa/fbi & diag/diag2 arrays + !! and then (optional) smooth the interior and the corners + !! after alternating the irng, iang, krng & kang loops in snlr's + !! + !! 2. Method : + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! nrng int. Public I # of freq. or rings + !! nang int. Public I # of angles + !! ismo int. Local I switch; ismo=0 skip smoothing + !! ismo.ne.0 do smoothing + !! X R.A. Local I/O Array to be ineterp. & smoothing + !! its returned to snlr_tsa as tsa or diag + !! and to snlr_fbi as fbi or diag2 + !! dim=(nrng,nang) + !! ------------------------------------------------------------------ + !! + !! 4. Subroutines used : + !! + !! Name Type Module Description + !! ---------------------------------------------------------------- + !! ---------------------------------------------------------------- + !! + !! 5. Called by : + !! + !! Name Type Module Description + !! ---------------------------------------------------------------- + !! snlr_tsa Subr. W3SNL4MD Computes dN(k,theta)/dt for TSA + !! -------- due to wave-wave inter. (set itsa = 1) + !! snlr_fbi Subr. W3SNL4MD Computes dN(k,theta)/dt for FBI + !! -------- due to wave-wave inter. (set itsa = 0) + !! ---------------------------------------------------------------- + !! + !! 6. Error messages : + !! + !! None. + !! + !! 7. Remarks : + !! + !! 8. Structure : + !! + !! See source code. + !! + !! 9. Switches : + !! + !! !/S Enable subroutine tracing. + !! + !!10. Source code : + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + IMPLICIT NONE + !! + !! + !! Parameter list + !! -------------- + REAL, INTENT(INOUT) :: X(nrng,nang) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! + !! + !! Local Parameters + !! ---------------- + integer :: irng, iang + real :: Y(nrng,nang) !* dummy array used in smoothing + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + !!-0 Initial Y(:,:) array before it's computed + !!ini + Y(:,:) = 0.0 + !!ini--- + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !!-1 Interpolate using simple 2 point averaging to fill in X + !! Remeber: nang must be an even number ==> nang-2 is an even number + !! and nrng must be an odd number ==> nrng-1 is an even number + !! Example numbers used here are for nrng=35 & nang=36 + !! ------------------------------------------------------------------ + !! + !!-1a For every calculated iang (1,3,5,..,nang-1=35) + !! fill in missing irng's (2,4,6,..,nrng-1=34) do iang=1,nang-1,2 !* = 1,3,5,...,nang-1=35 - do irng=2,nrng-1,2 !* = 2,4,6,...,nrng-1=34 + do irng=2,nrng-1,2 !* = 2,4,6,...,nrng-1=34 X(irng,iang) = 0.5 * ( X(irng-1,iang) + X(irng+1,iang) ) - end do + end do end do -!! ------------------------------------------------------------------ -!! -!!-1b Now, for every irng (1,2,3,..,nrng =35) -!! fill missing iang's (2,4,6,..,nang-2=34) + !! ------------------------------------------------------------------ + !! + !!-1b Now, for every irng (1,2,3,..,nrng =35) + !! fill missing iang's (2,4,6,..,nang-2=34) do irng=1,nrng !* 1,2,3,..,nrng =35 - do iang=2,nang-2,2 !* 2,4,6,..,nang-2=34 + do iang=2,nang-2,2 !* 2,4,6,..,nang-2=34 X(irng,iang) = 0.5 * ( X(irng,iang-1) + X(irng,iang+1) ) - end do + end do end do -!! ------------------------------------------------------------------ -!! -!!-1c for iang = nang (special case since nang is an even number) + !! ------------------------------------------------------------------ + !! + !!-1c for iang = nang (special case since nang is an even number) do irng=1,nrng - X(irng,nang) = 0.5 * ( X(irng,nang-1) + X(irng,1) ) + X(irng,nang) = 0.5 * ( X(irng,nang-1) + X(irng,1) ) end do -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!! -!! Skip smoothing only if ismo = 0 -!! -!! - if ( ismo.eq.0 ) goto 99 -!! -!! -!! -!!-2 Smoothing the 2D array X into array Y -!! -!!-2a Smoothing the interior [2;nrng-1] x [2:nang-1] -!!- Using 9 points averaged with equal weights. -!!- Here use the dummy array so we don't spoil the original array. + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !! + !! Skip smoothing only if ismo = 0 + !! + !! + if ( ismo.eq.0 ) goto 99 + !! + !! + !! + !!-2 Smoothing the 2D array X into array Y + !! + !!-2a Smoothing the interior [2;nrng-1] x [2:nang-1] + !!- Using 9 points averaged with equal weights. + !!- Here use the dummy array so we don't spoil the original array. do irng=2,nrng-1 - do iang=2,nang-1 + do iang=2,nang-1 Y(irng,iang)=(X(irng-1,iang-1)+X(irng-1,iang)+X(irng-1,iang+1) + & - X(irng, iang-1)+X(irng, iang)+X(irng, iang+1) + & - X(irng+1,iang-1)+X(irng+1,iang)+X(irng+1,iang+1))/9. - end do + X(irng, iang-1)+X(irng, iang)+X(irng, iang+1) + & + X(irng+1,iang-1)+X(irng+1,iang)+X(irng+1,iang+1))/9. + end do end do -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!!-3 Smooth first & last line at iang=1 & iang=nang (special cases) -!! -!!-3a Smooth line at iang = 1 (special case) -!!- Using 9 points averaged with equal weights. + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !!-3 Smooth first & last line at iang=1 & iang=nang (special cases) + !! + !!-3a Smooth line at iang = 1 (special case) + !!- Using 9 points averaged with equal weights. do irng=2,nrng-1 - Y(irng, 1) = (X(irng-1,nang) + X(irng-1, 1) + X(irng-1, 2) + & - X(irng, nang) + X(irng, 1) + X(irng, 2) + & - X(irng+1,nang) + X(irng+1, 1) + X(irng+1, 2) )/9. + Y(irng, 1) = (X(irng-1,nang) + X(irng-1, 1) + X(irng-1, 2) + & + X(irng, nang) + X(irng, 1) + X(irng, 2) + & + X(irng+1,nang) + X(irng+1, 1) + X(irng+1, 2) )/9. end do -!! ------------------------------------------------------------------ -!! -!!-3b Smooth line at iang = nang (special case) -!!- Using 9 points averaged with equal weights. + !! ------------------------------------------------------------------ + !! + !!-3b Smooth line at iang = nang (special case) + !!- Using 9 points averaged with equal weights. do irng=2,nrng-1 - Y(irng,nang)=(X(irng-1,nang-1) +X(irng-1,nang) +X(irng-1,1) + & - X(irng, nang-1) +X(irng, nang) +X(irng, 1) + & - X(irng+1,nang-1) +X(irng+1,nang) +X(irng+1,1))/9. + Y(irng,nang)=(X(irng-1,nang-1) +X(irng-1,nang) +X(irng-1,1) + & + X(irng, nang-1) +X(irng, nang) +X(irng, 1) + & + X(irng+1,nang-1) +X(irng+1,nang) +X(irng+1,1))/9. end do -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!!-4 Smooth first & last col. at irng=1 & irng=nrng (special cases) -!! -!!-4a Smooth col. at irng = 1 (low frq. can be skipped) -!!- Using 6 points averaged with equal weights. + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !!-4 Smooth first & last col. at irng=1 & irng=nrng (special cases) + !! + !!-4a Smooth col. at irng = 1 (low frq. can be skipped) + !!- Using 6 points averaged with equal weights. do iang=2,nang-1 - Y(1,iang) = (X(1,iang-1) + X(1,iang) + X(1,iang+1) + & - X(2,iang-1) + X(2,iang) + X(2,iang+1) )/6. + Y(1,iang) = (X(1,iang-1) + X(1,iang) + X(1,iang+1) + & + X(2,iang-1) + X(2,iang) + X(2,iang+1) )/6. end do -!! ------------------------------------------------------------------ -!! -!!-4b Smooth col. at irng = nrng (high frq. can be skipped) -!!- Using 6 points averaged with equal weights. + !! ------------------------------------------------------------------ + !! + !!-4b Smooth col. at irng = nrng (high frq. can be skipped) + !!- Using 6 points averaged with equal weights. do iang=2,nang-1 - Y(nrng,iang)=(X(nrng-1,iang-1)+X(nrng-1,iang)+X(nrng-1,iang+1)+ & - X(nrng, iang-1)+X(nrng, iang)+X(nrng, iang+1) )/6. + Y(nrng,iang)=(X(nrng-1,iang-1)+X(nrng-1,iang)+X(nrng-1,iang+1)+ & + X(nrng, iang-1)+X(nrng, iang)+X(nrng, iang+1) )/6. end do -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!!-5 Smooth the 4 corners (optional): <== Skip no sig. effect -!!- Using 6 points averaged with equal weights -!! -!!-5a Corner (1, 1) - Y(1, 1) =( X(1,nang) + X(1, 1) + X(1, 2) + & - X(2,nang) + X(2, 1) + X(2, 2) )/6.0 -!! ------------------------------------------------------------------ -!! -!!-5b Corner (nrng,1) - Y(nrng,1) =( X(nrng-1,nang) + X(nrng-1,1) + X(nrng-1,2) + & - X(nrng, nang) + X(nrng, 1) + X(nrng, 2) )/6.0 -!! ------------------------------------------------------------------ -!! -!!-5c Corner (1,nang) - Y(1,nang) =( X(1,nang-1) + X(1,nang) + X(1, 1) + & - X(2,nang-1) + X(2,nang) + X(2, 1) ) / 6. -!! ------------------------------------------------------------------ -!! -!!-5d Corner (nrng,nang) - Y(nrng,nang) =( X(nrng-1,nang-1) +X(nrng-1,nang) +X(nrng-1,1) + & - X(nrng, nang-1) +X(nrng, nang) +X(nrng, 1) )/6. -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!!-6 Final, dump smoothed array Y(:,:) into X(:,:) to be returned -!! -!!-6a Done with X(:,:) re-initial before it's replaced by Y(:,:) -!!ini - X(:,:) = 0.0 -!!ini--- -!! -!!-6b Dump smoothed array Y(:,:) into X(:,:) to be returned + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !!-5 Smooth the 4 corners (optional): <== Skip no sig. effect + !!- Using 6 points averaged with equal weights + !! + !!-5a Corner (1, 1) + Y(1, 1) =( X(1,nang) + X(1, 1) + X(1, 2) + & + X(2,nang) + X(2, 1) + X(2, 2) )/6.0 + !! ------------------------------------------------------------------ + !! + !!-5b Corner (nrng,1) + Y(nrng,1) =( X(nrng-1,nang) + X(nrng-1,1) + X(nrng-1,2) + & + X(nrng, nang) + X(nrng, 1) + X(nrng, 2) )/6.0 + !! ------------------------------------------------------------------ + !! + !!-5c Corner (1,nang) + Y(1,nang) =( X(1,nang-1) + X(1,nang) + X(1, 1) + & + X(2,nang-1) + X(2,nang) + X(2, 1) ) / 6. + !! ------------------------------------------------------------------ + !! + !!-5d Corner (nrng,nang) + Y(nrng,nang) =( X(nrng-1,nang-1) +X(nrng-1,nang) +X(nrng-1,1) + & + X(nrng, nang-1) +X(nrng, nang) +X(nrng, 1) )/6. + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !!-6 Final, dump smoothed array Y(:,:) into X(:,:) to be returned + !! + !!-6a Done with X(:,:) re-initial before it's replaced by Y(:,:) + !!ini + X(:,:) = 0.0 + !!ini--- + !! + !!-6b Dump smoothed array Y(:,:) into X(:,:) to be returned do iang=1,nang - do irng=1,nrng + do irng=1,nrng X(irng,iang) = Y(irng,iang) - end do + end do end do -!! Bash; can simplify in one line -!b X(1:nrng, 1:nang) = Y(1:nrng, 1:nang) -!! ------------------------------------------------------------------ -!! ================================================================== -!! - 99 continue -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! - RETURN -!! - END SUBROUTINE interp2 -!! -!!============================================================================== -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL FUNCTION wkfnc ( f, dep ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! -!! it returns: wavenumber 'k' in wkfnc -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! 1. Purpose : -!! -!! Calculate the Wavenumber k (rad/m) as function of -!! frequency 'f' (Hz) and depth 'dep' (m). -!! -!! 2. Method : -!! -!! Using what looks like a "Pade approximation" of an inversion -!! of the linear wave dispersion relation. -!! sigma^2 = gk*tanh(kd), sigma = 2*pi*f -!! Wavenumber k (rad/m) is returned in "wkfnc" -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! twopi Real Public I = TPI; WW3 2*pi=8.*atan(1.) (radians) -!! ------------------------------------------------------------------ -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! - IMPLICIT NONE -!! -!! Parameter list -!! -------------- - real, intent(in) :: f, dep -!! -!! Local variables -!! --------------- - real(KIND=8) :: g, y, x -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! - g = 9.806 !* set = GRAV as in CONSTANTS -!! - y = ( (twopi*f)**2 ) * dep / g !* sigma^2 d/g -!! -!! --------------------------------------------------------------- & - x = y * ( y + & - 1./(1.00000+y*(0.66667+y*(0.35550+y*(0.16084+y*(0.06320 & - +y*(0.02174+y*(0.00654+y*(0.00171+y*(0.00039+y*0.00011) & - ))))))))) -!! --------------------------------------------------------------- & -!! - x = sqrt(x) !* kd -!! - wkfnc = x / dep !* k -!! ------------------------------------------------------------------ -!! ================================================================== -!! - RETURN -!! - END FUNCTION wkfnc -!! -!!============================================================================== -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL FUNCTION cgfnc ( f, dep, cvel ) -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III BIO | -!/ | Bash Toulany | -!/ | Michael Casey | -!/ | William Perrie | -!/ | FORTRAN 90 | -!/ | Last update : 12-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2016 : Origination. ( version 5.13 ) -!/ -!! it returns: group velocity (m/s) in cgfnc -!! -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ------------------------------------------------------------------ -!! ================================================================== -!! -!! -!! 1. Purpose : -!! -!! Calculate the Group velocity Cg (m/s) as function of -!! frequency 'f' (Hz), depth 'dep' (m) and phase speed 'cvel' (m/s) -!! -!! 2. Method : -!! -!! This routine uses the identity -!! sinh(2x) = 2*tanh(x)/(1-tanh(x)**2) -!! to avoid extreme sinh(2x) for large x. -!! thus, 2kd/sinh(2kd) = kd(1-tanh(kd)**2)/tanh(kd) -!! Group velocity Cg (m/s) is returned in "cgfnc" -!! -!! 3. Parameters : -!! -!! Parameter list -!! ------------------------------------------------------------------ -!! Name Type Scope I/O Description -!! ------------------------------------------------------------------ -!! twopi Real Public I = TPI; WW3 2*pi=8.*atan(1.) (radians) -!! ------------------------------------------------------------------ -!! -!! --------------------------------------------------------------- & -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ----------------------------------------------------------------72 -!! ================================================================== -!! -!! - IMPLICIT NONE -!! -!! Parameter list -!! -------------- - real, intent(in) :: f, dep, cvel -!! -!! Local variables -!! --------------- - real :: wkd, tkd -!! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!! ---------------------::-----------------------------------------72 -!! ################################################################## -!!------------------------------------------------------------------------------ -!!============================================================================== -!! -!! - wkd = twopi * f*dep/cvel !* kd - tkd = tanh(wkd) !* tanh(kd) - cgfnc = 0.5*cvel*(1.+wkd*(1.-tkd**2)/tkd) -!! ------------------------------------------------------------------ -!! ================================================================== -!! - RETURN -!! - END FUNCTION cgfnc -!! -!!============================================================================== -!! -!! - END MODULE W3SNL4MD + !! Bash; can simplify in one line + !b X(1:nrng, 1:nang) = Y(1:nrng, 1:nang) + !! ------------------------------------------------------------------ + !! ================================================================== + !! +99 continue + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + RETURN + !! + END SUBROUTINE interp2 + !! + !!============================================================================== + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + REAL FUNCTION wkfnc ( f, dep ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! + !! it returns: wavenumber 'k' in wkfnc + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! 1. Purpose : + !! + !! Calculate the Wavenumber k (rad/m) as function of + !! frequency 'f' (Hz) and depth 'dep' (m). + !! + !! 2. Method : + !! + !! Using what looks like a "Pade approximation" of an inversion + !! of the linear wave dispersion relation. + !! sigma^2 = gk*tanh(kd), sigma = 2*pi*f + !! Wavenumber k (rad/m) is returned in "wkfnc" + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! twopi Real Public I = TPI; WW3 2*pi=8.*atan(1.) (radians) + !! ------------------------------------------------------------------ + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + IMPLICIT NONE + !! + !! Parameter list + !! -------------- + real, intent(in) :: f, dep + !! + !! Local variables + !! --------------- + real(KIND=8) :: g, y, x + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + g = 9.806 !* set = GRAV as in CONSTANTS + !! + y = ( (twopi*f)**2 ) * dep / g !* sigma^2 d/g + !! + !! --------------------------------------------------------------- & + x = y * ( y + & + 1./(1.00000+y*(0.66667+y*(0.35550+y*(0.16084+y*(0.06320 & + +y*(0.02174+y*(0.00654+y*(0.00171+y*(0.00039+y*0.00011) & + ))))))))) + !! --------------------------------------------------------------- & + !! + x = sqrt(x) !* kd + !! + wkfnc = x / dep !* k + !! ------------------------------------------------------------------ + !! ================================================================== + !! + RETURN + !! + END FUNCTION wkfnc + !! + !!============================================================================== + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + REAL FUNCTION cgfnc ( f, dep, cvel ) + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III BIO | + !/ | Bash Toulany | + !/ | Michael Casey | + !/ | William Perrie | + !/ | FORTRAN 90 | + !/ | Last update : 12-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2016 : Origination. ( version 5.13 ) + !/ + !! it returns: group velocity (m/s) in cgfnc + !! + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ------------------------------------------------------------------ + !! ================================================================== + !! + !! + !! 1. Purpose : + !! + !! Calculate the Group velocity Cg (m/s) as function of + !! frequency 'f' (Hz), depth 'dep' (m) and phase speed 'cvel' (m/s) + !! + !! 2. Method : + !! + !! This routine uses the identity + !! sinh(2x) = 2*tanh(x)/(1-tanh(x)**2) + !! to avoid extreme sinh(2x) for large x. + !! thus, 2kd/sinh(2kd) = kd(1-tanh(kd)**2)/tanh(kd) + !! Group velocity Cg (m/s) is returned in "cgfnc" + !! + !! 3. Parameters : + !! + !! Parameter list + !! ------------------------------------------------------------------ + !! Name Type Scope I/O Description + !! ------------------------------------------------------------------ + !! twopi Real Public I = TPI; WW3 2*pi=8.*atan(1.) (radians) + !! ------------------------------------------------------------------ + !! + !! --------------------------------------------------------------- & + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ----------------------------------------------------------------72 + !! ================================================================== + !! + !! + IMPLICIT NONE + !! + !! Parameter list + !! -------------- + real, intent(in) :: f, dep, cvel + !! + !! Local variables + !! --------------- + real :: wkd, tkd + !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! ---------------------::-----------------------------------------72 + !! ################################################################## + !!------------------------------------------------------------------------------ + !!============================================================================== + !! + !! + wkd = twopi * f*dep/cvel !* kd + tkd = tanh(wkd) !* tanh(kd) + cgfnc = 0.5*cvel*(1.+wkd*(1.-tkd**2)/tkd) + !! ------------------------------------------------------------------ + !! ================================================================== + !! + RETURN + !! + END FUNCTION cgfnc + !! + !!============================================================================== + !! + !! +END MODULE W3SNL4MD !! !!============================================================================== diff --git a/model/src/w3snl5md.F90 b/model/src/w3snl5md.F90 index 84f6c8e0a..3f96c78f1 100644 --- a/model/src/w3snl5md.F90 +++ b/model/src/w3snl5md.F90 @@ -1,838 +1,838 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SNL5MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | O. Gramstad | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 07-Jun-2021 | -!/ +-----------------------------------+ -!/ -!/ 24-Sep-2013 : Origination. ( version 3.14 ) -!/ 24-Sep-2013 : GKE for the regular wavenumbergrid ( O. Gramstad ) -!/ (interpolation required) -!/ 02-Dec-2013 : GKE for WW3 logarithmic freq. grid ( O. Gramstad ) -!/ (single grid point) -!/ 27-Feb-2019 : GKE for 2D applications. ( version 7.13 ) -!/ ( Q. Liu ) -!/ 07-06-2021 : Merge into WW3 Github ( version 7.13 ) -!/ ( Q. Liu ) -!/ -! 1. Purpose : -! Interface module for GKE (resonant & quasi-resonant four-wave -! interactions) -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ------------------------------------------------------------------- -! W3SNL5 Subr. Public Interface to gkeModule -! INSNL5 Subr. Public Initialization routine -! CALC_WBTv2 Subr. Private Calc. dominant wave breaking prob. -! INPOUT Subr. Private Point output -! ------------------------------------------------------------------- -! -! 4. Future work: Dnl -!/ -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -! Subrs. - PUBLIC :: W3SNL5, INSNL5 - PRIVATE :: CALC_WBTv2, INPOUT -! Vars. - PRIVATE :: NSEL, PSEA, PNMS -!/ ------------------------------------------------------------------- / -! Parameter list - INTEGER :: NSEL - INTEGER, ALLOCATABLE, SAVE :: PSEA(:) - CHARACTER(LEN=10), ALLOCATABLE, SAVE :: PNMS(:) -! - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SNL5(A, CG, WN, FMEAN, T1ABS, U10, UDIR, JSEA, & - S, D, KURT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | O. Gramstad | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 24-Apr-2019 | -!/ +-----------------------------------+ -!/ -!/ 24-Sep-2013 : Origination. ( version 3.14 ) -!/ 24-Sep-2013 : GKE for resonant & quasi-resonant four-wave -!/ interactions ( O. Gramstad ) -!/ 27-Feb-2019 : Full implementation of GKE ( version 7.13 ) -!/ ( Q. Liu ) -!/ 21-Apr-2019 : Phase mixing option ( version 7.13 ) -!/ ( Q. Liu ) -!/ 24-Apr-2019 : Phase mixing option (b_T) ( version 7.13 ) -!/ ( Q. Liu ) -!/ 02-May-2019 : Organize screen output & disable binary output -!/ ( version 7.13 ) -!/ ( Q. Liu ) -!/ -!/ -! 1. Purpose : -! -! Interface to CalcQRSNL subr. of the GKE module. Please refer to -! ------------- -! gkeModule.f90 for further details. -! ------------- -! -! ◆ Different times used in this module -! -! |----o---------o----o--|-|--o-----o------o-----o------o----> (t) -! ^ ^ ^ ^ ^ T1ABS (absol. current time step)¹ -! | | | | -! | | | v t0 (relat. time, previous time step) -! | |<------->| -! | | PM_IVAL (phase mixing interval, relat. time) -! | | -! | v PM_PREV (phase mixing, appear quasi-periodically) -! | (relat. time) -! | -! v TBEG (absol. begining time, defined by ww3_shel.inp) -! -! ¹ Because of using the dynamic integration scheme, T1ABS -! is related to, but not the same as, TIME in w3wdatmd.ftn -! 2. Method : -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, TPI - USE W3GKEMD, ONLY: CalcQRSNL, qr_depth - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, & - GTYPE, RLGTYPE, CLGTYPE, & - QR5DPT, QI5NNZ, QI5PMX - USE W3WDATMD, ONLY: QI5TBEG, QR5TIM0, QR5CVK0, QC5INT0, & - QR5TMIX - USE W3ODATMD, ONLY: FLOUT, NOPTS, TOSNL5, TOLAST, & - IAPROC, NAPOUT, SCREEN - USE W3PARALL, ONLY: INIT_GET_ISEA - USE W3TIMEMD, ONLY: DSEC21 - USE W3SERVMD, ONLY: EXTCDE +MODULE W3SNL5MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | O. Gramstad | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 07-Jun-2021 | + !/ +-----------------------------------+ + !/ + !/ 24-Sep-2013 : Origination. ( version 3.14 ) + !/ 24-Sep-2013 : GKE for the regular wavenumbergrid ( O. Gramstad ) + !/ (interpolation required) + !/ 02-Dec-2013 : GKE for WW3 logarithmic freq. grid ( O. Gramstad ) + !/ (single grid point) + !/ 27-Feb-2019 : GKE for 2D applications. ( version 7.13 ) + !/ ( Q. Liu ) + !/ 07-06-2021 : Merge into WW3 Github ( version 7.13 ) + !/ ( Q. Liu ) + !/ + ! 1. Purpose : + ! Interface module for GKE (resonant & quasi-resonant four-wave + ! interactions) + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ------------------------------------------------------------------- + ! W3SNL5 Subr. Public Interface to gkeModule + ! INSNL5 Subr. Public Initialization routine + ! CALC_WBTv2 Subr. Private Calc. dominant wave breaking prob. + ! INPOUT Subr. Private Point output + ! ------------------------------------------------------------------- + ! + ! 4. Future work: Dnl + !/ + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + ! Subrs. + PUBLIC :: W3SNL5, INSNL5 + PRIVATE :: CALC_WBTv2, INPOUT + ! Vars. + PRIVATE :: NSEL, PSEA, PNMS + !/ ------------------------------------------------------------------- / + ! Parameter list + INTEGER :: NSEL + INTEGER, ALLOCATABLE, SAVE :: PSEA(:) + CHARACTER(LEN=10), ALLOCATABLE, SAVE :: PNMS(:) + ! +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SNL5(A, CG, WN, FMEAN, T1ABS, U10, UDIR, JSEA, & + S, D, KURT) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | O. Gramstad | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 24-Apr-2019 | + !/ +-----------------------------------+ + !/ + !/ 24-Sep-2013 : Origination. ( version 3.14 ) + !/ 24-Sep-2013 : GKE for resonant & quasi-resonant four-wave + !/ interactions ( O. Gramstad ) + !/ 27-Feb-2019 : Full implementation of GKE ( version 7.13 ) + !/ ( Q. Liu ) + !/ 21-Apr-2019 : Phase mixing option ( version 7.13 ) + !/ ( Q. Liu ) + !/ 24-Apr-2019 : Phase mixing option (b_T) ( version 7.13 ) + !/ ( Q. Liu ) + !/ 02-May-2019 : Organize screen output & disable binary output + !/ ( version 7.13 ) + !/ ( Q. Liu ) + !/ + !/ + ! 1. Purpose : + ! + ! Interface to CalcQRSNL subr. of the GKE module. Please refer to + ! ------------- + ! gkeModule.f90 for further details. + ! ------------- + ! + ! ◆ Different times used in this module + ! + ! |----o---------o----o--|-|--o-----o------o-----o------o----> (t) + ! ^ ^ ^ ^ ^ T1ABS (absol. current time step)¹ + ! | | | | + ! | | | v t0 (relat. time, previous time step) + ! | |<------->| + ! | | PM_IVAL (phase mixing interval, relat. time) + ! | | + ! | v PM_PREV (phase mixing, appear quasi-periodically) + ! | (relat. time) + ! | + ! v TBEG (absol. begining time, defined by ww3_shel.inp) + ! + ! ¹ Because of using the dynamic integration scheme, T1ABS + ! is related to, but not the same as, TIME in w3wdatmd.ftn + ! 2. Method : + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, TPI + USE W3GKEMD, ONLY: CalcQRSNL, qr_depth + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, & + GTYPE, RLGTYPE, CLGTYPE, & + QR5DPT, QI5NNZ, QI5PMX + USE W3WDATMD, ONLY: QI5TBEG, QR5TIM0, QR5CVK0, QC5INT0, & + QR5TMIX + USE W3ODATMD, ONLY: FLOUT, NOPTS, TOSNL5, TOLAST, & + IAPROC, NAPOUT, SCREEN + USE W3PARALL, ONLY: INIT_GET_ISEA + USE W3TIMEMD, ONLY: DSEC21 + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH, NK) ! N(θ, k) - REAL, INTENT(IN) :: CG(NK) ! Cg(k) - REAL, INTENT(IN) :: WN(NK) ! WN(k) - REAL, INTENT(IN) :: FMEAN ! 1/T_{0, -1} - INTEGER, INTENT(IN) :: T1ABS(2) ! Absol. t1 - REAL, INTENT(IN) :: U10 ! Wind velocity - REAL, INTENT(IN) :: UDIR ! φ (in rad) - INTEGER, INTENT(IN) :: JSEA ! Local sea point count - REAL, INTENT(OUT) :: S(NTH,NK), & ! Snl - D(NTH,NK), & ! Dnl - KURT ! Kurtosis + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH, NK) ! N(θ, k) + REAL, INTENT(IN) :: CG(NK) ! Cg(k) + REAL, INTENT(IN) :: WN(NK) ! WN(k) + REAL, INTENT(IN) :: FMEAN ! 1/T_{0, -1} + INTEGER, INTENT(IN) :: T1ABS(2) ! Absol. t1 + REAL, INTENT(IN) :: U10 ! Wind velocity + REAL, INTENT(IN) :: UDIR ! φ (in rad) + INTEGER, INTENT(IN) :: JSEA ! Local sea point count + REAL, INTENT(OUT) :: S(NTH,NK), & ! Snl + D(NTH,NK), & ! Dnl + KURT ! Kurtosis -!/ ------------------------------------------------------------------- / -!/ Local parameters - REAL, PARAMETER :: BTLOW = 10., BTHGH = 500. - REAL :: T0REL, T1REL, TDEL1, TDEL2 - REAL :: Cvk1(NSPEC), SNL(NSPEC), DNL(NSPEC) - REAL :: Cvk0(NSPEC) - COMPLEX :: INPQR0(QI5NNZ) - INTEGER :: IK, ITH, ISPEC, ISEA, JLOC - INTEGER, ALLOCATABLE :: PDIFF(:) - LOGICAL, SAVE :: FSTOUT = .TRUE. - REAL :: FACTOR(NK), A2(NK, NTH), S2(NK, NTH) - REAL :: PM_PREV, PM_IVAL, PM_DELT - REAL :: WBT, BTINV - INTEGER :: IUNT + !/ ------------------------------------------------------------------- / + !/ Local parameters + REAL, PARAMETER :: BTLOW = 10., BTHGH = 500. + REAL :: T0REL, T1REL, TDEL1, TDEL2 + REAL :: Cvk1(NSPEC), SNL(NSPEC), DNL(NSPEC) + REAL :: Cvk0(NSPEC) + COMPLEX :: INPQR0(QI5NNZ) + INTEGER :: IK, ITH, ISPEC, ISEA, JLOC + INTEGER, ALLOCATABLE :: PDIFF(:) + LOGICAL, SAVE :: FSTOUT = .TRUE. + REAL :: FACTOR(NK), A2(NK, NTH), S2(NK, NTH) + REAL :: PM_PREV, PM_IVAL, PM_DELT + REAL :: WBT, BTINV + INTEGER :: IUNT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SNL5') + CALL STRACE (IENT, 'W3SNL5') #endif -! -!/ ------------------------------------------------------------------- / -! Read in wave info. @ the previous time step t0 -! Array initialization is done in w3wdat/w3setw (called by w3initmd) - T0REL = QR5TIM0(JSEA) ! t0 (nsea) - CVK0 = QR5CVK0(:, JSEA) ! Cvk (ns, nsea) @ t0 - INPQR0 = QC5INT0(:, JSEA) ! Inpqr (nnz, nsea) @ t0 -! -! Calc. Relative time for T1ABS (QI5TBEG as the reference) - T1REL = DSEC21(QI5TBEG, T1ABS) ! in second -! -! W3WAVEMD: IF ( IT.EQ.0 ) DTG = 1 → T1REL = -1 (the first step of -! integration; TIME = TCALC/TOFRST, DTG = 0 → 1, QI5TBEG = TIME - 1) - IF(T1REL < 0.) T1REL = 0. -! -! Three options for phase mixing - IF (QI5PMX .EQ. 0) THEN -! 1) 0: no phase mixing + ! + !/ ------------------------------------------------------------------- / + ! Read in wave info. @ the previous time step t0 + ! Array initialization is done in w3wdat/w3setw (called by w3initmd) + T0REL = QR5TIM0(JSEA) ! t0 (nsea) + CVK0 = QR5CVK0(:, JSEA) ! Cvk (ns, nsea) @ t0 + INPQR0 = QC5INT0(:, JSEA) ! Inpqr (nnz, nsea) @ t0 + ! + ! Calc. Relative time for T1ABS (QI5TBEG as the reference) + T1REL = DSEC21(QI5TBEG, T1ABS) ! in second + ! + ! W3WAVEMD: IF ( IT.EQ.0 ) DTG = 1 → T1REL = -1 (the first step of + ! integration; TIME = TCALC/TOFRST, DTG = 0 → 1, QI5TBEG = TIME - 1) + IF(T1REL < 0.) T1REL = 0. + ! + ! Three options for phase mixing + IF (QI5PMX .EQ. 0) THEN + ! 1) 0: no phase mixing #ifdef W3_TS IF (IAPROC .EQ. NAPOUT) & - WRITE(SCREEN, '(A, 2(I10.8, I7.6), E12.3)') & - " ⊚ → [WW3 SNL₅] QI5TBEG, T1ABS, T1REL:", & - QI5TBEG, T1ABS, T1REL + WRITE(SCREEN, '(A, 2(I10.8, I7.6), E12.3)') & + " ⊚ → [WW3 SNL₅] QI5TBEG, T1ABS, T1REL:", & + QI5TBEG, T1ABS, T1REL #endif - ELSE + ELSE #ifdef W3_TS IF (IAPROC .EQ. NAPOUT) & - WRITE(SCREEN, '(A, 2(I10.8, I7.6), E12.3)', ADVANCE='no') & - " ⊚ → [WW3 SNL₅] QI5TBEG, T1ABS, T1REL, T1REL[P]:", & - QI5TBEG, T1ABS, T1REL + WRITE(SCREEN, '(A, 2(I10.8, I7.6), E12.3)', ADVANCE='no') & + " ⊚ → [WW3 SNL₅] QI5TBEG, T1ABS, T1REL, T1REL[P]:", & + QI5TBEG, T1ABS, T1REL #endif -! -! Calc. Phase mixing interval - IF (QI5PMX .GT. 0) THEN -! 2) N: mix phase by every N characteristic wave periods - IF (ABS(FMEAN) < 1E-7) THEN ! FMEAN may be 0. - PM_IVAL = REAL(QI5PMX) * 1. ! then, assume FMEAN = 1. - ELSE - PM_IVAL = REAL(QI5PMX) * (1. / FMEAN) - END IF -! - ELSE IF (QI5PMX .LT. 0) THEN -! 3) < 0: mix phase based on dominant wave breaking probability bT -! Calc bT - WBT = CALC_WBTv2(A, CG, WN, QR5DPT, U10, UDIR) ! [0, 1.] -! Mix phase by every 1/bT periods -! Odin used bT < 1/15. (0.066) → BTLOW = 15 and PM_IVAL > 150 s - BTINV = MAX(BTLOW, MIN(1./MAX(1E-6, WBT), BTHGH)) - IF (ABS(FMEAN) < 1E-7) THEN ! FMEAN may be 0. - PM_IVAL = BTINV * 1. ! then, assume FMEAN = 1. - ELSE - PM_IVAL = BTINV * (1. / FMEAN) - END IF - END IF -! -! Previous phase mixing time (relat. to TBEG) -! QR5TMIX has already been initialized in w3wdatmd as zero. - PM_PREV = QR5TMIX(JSEA) -! Update t1 if necessary - PM_DELT = T1REL - PM_PREV - IF (PM_DELT .GE. PM_IVAL) THEN - QR5TMIX(JSEA) = T1REL ! relat. to TBEG → PM_PREV - T1REL = 0. - ELSE - T1REL = PM_DELT - END IF + ! + ! Calc. Phase mixing interval + IF (QI5PMX .GT. 0) THEN + ! 2) N: mix phase by every N characteristic wave periods + IF (ABS(FMEAN) < 1E-7) THEN ! FMEAN may be 0. + PM_IVAL = REAL(QI5PMX) * 1. ! then, assume FMEAN = 1. + ELSE + PM_IVAL = REAL(QI5PMX) * (1. / FMEAN) + END IF + ! + ELSE IF (QI5PMX .LT. 0) THEN + ! 3) < 0: mix phase based on dominant wave breaking probability bT + ! Calc bT + WBT = CALC_WBTv2(A, CG, WN, QR5DPT, U10, UDIR) ! [0, 1.] + ! Mix phase by every 1/bT periods + ! Odin used bT < 1/15. (0.066) → BTLOW = 15 and PM_IVAL > 150 s + BTINV = MAX(BTLOW, MIN(1./MAX(1E-6, WBT), BTHGH)) + IF (ABS(FMEAN) < 1E-7) THEN ! FMEAN may be 0. + PM_IVAL = BTINV * 1. ! then, assume FMEAN = 1. + ELSE + PM_IVAL = BTINV * (1. / FMEAN) + END IF + END IF + ! + ! Previous phase mixing time (relat. to TBEG) + ! QR5TMIX has already been initialized in w3wdatmd as zero. + PM_PREV = QR5TMIX(JSEA) + ! Update t1 if necessary + PM_DELT = T1REL - PM_PREV + IF (PM_DELT .GE. PM_IVAL) THEN + QR5TMIX(JSEA) = T1REL ! relat. to TBEG → PM_PREV + T1REL = 0. + ELSE + T1REL = PM_DELT + END IF #ifdef W3_TS IF (IAPROC .EQ. NAPOUT) THEN - WRITE(SCREEN, '(F9.1)') T1REL - IF (QI5PMX .LT. 0 ) WRITE(SCREEN, '(A, F6.3)') '↔ bT: ', WBT + WRITE(SCREEN, '(F9.1)') T1REL + IF (QI5PMX .LT. 0 ) WRITE(SCREEN, '(A, F6.3)') '↔ bT: ', WBT ENDIF #endif - END IF -! -! Calc. Cvk1 from A (C(\bm{k}) = g N(k, θ) / k) - DO IK = 1, NK - DO ITH = 1, NTH - ISPEC = ITH + (IK-1) * NTH - Cvk1(ISPEC) = A(ITH, IK) / WN(IK) * GRAV - END DO + END IF + ! + ! Calc. Cvk1 from A (C(\bm{k}) = g N(k, θ) / k) + DO IK = 1, NK + DO ITH = 1, NTH + ISPEC = ITH + (IK-1) * NTH + Cvk1(ISPEC) = A(ITH, IK) / WN(IK) * GRAV END DO -! -! CalcQRSNL(nk, nth, sig, th, t0, t1, Cvk0, Cvk1, Inpqr0, Snl, Dnl, Kurt) -! Depth is needed for reading in kernels at the first run - qr_depth = QR5DPT - CALL CalcQRSNL(NK, NTH, SIG(1:NK), TH, & - T0REL, T1REL, CVK0, CVK1, & - INPQR0, SNL, DNL, KURT) -! -! Tranform back from C(k) to N(k) -! TODO D(ITH, IK) (See NL2 for reference) - D = 0.0 - DO IK = 1, NK - DO ITH = 1, NTH - ISPEC = ITH + (IK-1) * NTH - S(ITH, IK) = SNL(ISPEC) * WN(IK) / GRAV - END DO + END DO + ! + ! CalcQRSNL(nk, nth, sig, th, t0, t1, Cvk0, Cvk1, Inpqr0, Snl, Dnl, Kurt) + ! Depth is needed for reading in kernels at the first run + qr_depth = QR5DPT + CALL CalcQRSNL(NK, NTH, SIG(1:NK), TH, & + T0REL, T1REL, CVK0, CVK1, & + INPQR0, SNL, DNL, KURT) + ! + ! Tranform back from C(k) to N(k) + ! TODO D(ITH, IK) (See NL2 for reference) + D = 0.0 + DO IK = 1, NK + DO ITH = 1, NTH + ISPEC = ITH + (IK-1) * NTH + S(ITH, IK) = SNL(ISPEC) * WN(IK) / GRAV END DO -! -! Store wave info. @ t1 → t0 - QR5TIM0(JSEA) = T0REL - QR5CVK0(:, JSEA) = CVK0 - QC5INT0(:, JSEA) = INPQR0 -! -! Point output (Snl term) -! First ouput action (Find nearest grid points & generate binary files) - IF (FSTOUT) THEN - CALL INPOUT - FSTOUT = .FALSE. - IF (IAPROC .EQ. NAPOUT) THEN - WRITE(SCREEN, *) - WRITE(SCREEN, '(A)') & - ' ⊚ → [WW3 SNL₅] Point ouptut initialization' - WRITE(SCREEN, '(A, I4)') & - ' ⊚ → [WW3 SNL₅] # of valid points: ', NSEL - WRITE(SCREEN, *) - END IF + END DO + ! + ! Store wave info. @ t1 → t0 + QR5TIM0(JSEA) = T0REL + QR5CVK0(:, JSEA) = CVK0 + QC5INT0(:, JSEA) = INPQR0 + ! + ! Point output (Snl term) + ! First ouput action (Find nearest grid points & generate binary files) + IF (FSTOUT) THEN + CALL INPOUT + FSTOUT = .FALSE. + IF (IAPROC .EQ. NAPOUT) THEN + WRITE(SCREEN, *) + WRITE(SCREEN, '(A)') & + ' ⊚ → [WW3 SNL₅] Point ouptut initialization' + WRITE(SCREEN, '(A, I4)') & + ' ⊚ → [WW3 SNL₅] # of valid points: ', NSEL + WRITE(SCREEN, *) END IF -! -! Calc FACTOR used for Jacobian tranformation from N(k, θ) to E(f, θ) - FACTOR = TPI / CG * SIG(1:NK) -! -! Regular grid & curvilinear grid - IF ( ((GTYPE .EQ. RLGTYPE) .OR. (GTYPE .EQ. CLGTYPE)) & - .AND. FLOUT(2) .AND. NSEL .GT. 0) THEN - TDEL1 = DSEC21(T1ABS, TOSNL5) - TDEL2 = DSEC21(T1ABS, TOLAST(:, 2)) ! not really useful since - ! TOSNL5 can never catch - ! TOLAST -! Output time - IF (ABS(TDEL1) < 1E-6 .OR. ABS(TDEL2) < 1E-6) THEN -! JSEA→ ISEA - CALL INIT_GET_ISEA(ISEA, JSEA) -! Find the loc of ISEA at PSEA (nearest sea grid point) - IF (ALLOCATED(PDIFF)) DEALLOCATE(PDIFF); ALLOCATE(PDIFF(NSEL)) - PDIFF = ABS(PSEA(1:NSEL) - ISEA) - IF (ANY(PDIFF .EQ. 0)) THEN - JLOC = MINLOC(PDIFF, 1) + END IF + ! + ! Calc FACTOR used for Jacobian tranformation from N(k, θ) to E(f, θ) + FACTOR = TPI / CG * SIG(1:NK) + ! + ! Regular grid & curvilinear grid + IF ( ((GTYPE .EQ. RLGTYPE) .OR. (GTYPE .EQ. CLGTYPE)) & + .AND. FLOUT(2) .AND. NSEL .GT. 0) THEN + TDEL1 = DSEC21(T1ABS, TOSNL5) + TDEL2 = DSEC21(T1ABS, TOLAST(:, 2)) ! not really useful since + ! TOSNL5 can never catch + ! TOLAST + ! Output time + IF (ABS(TDEL1) < 1E-6 .OR. ABS(TDEL2) < 1E-6) THEN + ! JSEA→ ISEA + CALL INIT_GET_ISEA(ISEA, JSEA) + ! Find the loc of ISEA at PSEA (nearest sea grid point) + IF (ALLOCATED(PDIFF)) DEALLOCATE(PDIFF); ALLOCATE(PDIFF(NSEL)) + PDIFF = ABS(PSEA(1:NSEL) - ISEA) + IF (ANY(PDIFF .EQ. 0)) THEN + JLOC = MINLOC(PDIFF, 1) #ifdef W3_TS - IF (IAPROC .EQ. NAPOUT) & - WRITE(SCREEN, '(3A, I10.8, I7.6)') & - '✓ Point output for |', PNMS(JLOC), '| @', T1ABS + IF (IAPROC .EQ. NAPOUT) & + WRITE(SCREEN, '(3A, I10.8, I7.6)') & + '✓ Point output for |', PNMS(JLOC), '| @', T1ABS #endif -! N(θ, k) → F(f, θ) & S(θ, k) → S(f, θ) - DO ITH = 1, NTH - A2(:, ITH) = A(ITH, :) * FACTOR - S2(:, ITH) = S(ITH, :) * FACTOR - END DO -! NaN Check - IF (HasNaN(NK, NTH, A2) .OR. HasNaN(NK, NTH, S2)) THEN - IF (IAPROC .EQ. NAPOUT) & - WRITE(SCREEN, *) '★★★ Warning: find NaN in E(f, θ) & - & or Snl(f, θ) !' - END IF -! unit no. - IUNT = 500 + JLOC -! Store data (binary) -! OPEN(IUNT, FILE='NL5_'//trim(PNMS(JLOC))//'_src.bin', & -! form='unformatted', convert=file_endian, ACCESS='stream', & -! STATUS='old', POSITION='append', ACTION='write') -! WRITE(IUNT) T1ABS -! WRITE(IUNT) KURT -! WRITE(IUNT) A2 -! WRITE(IUNT) S2 -! CLOSE(IUNT) -! Store data (ascii) - OPEN(IUNT, FILE='NL5_'//trim(PNMS(JLOC))//'_src.dat', & - FORM='formatted', STATUS='old', & - POSITION='append', ACTION='write') - WRITE(IUNT, '(I10.8, I7.6)') T1ABS - WRITE(IUNT, '(ES11.3)') KURT - WRITE(IUNT, 113) A2 - WRITE(IUNT, 113) S2 - CLOSE(IUNT) -! - END IF + ! N(θ, k) → F(f, θ) & S(θ, k) → S(f, θ) + DO ITH = 1, NTH + A2(:, ITH) = A(ITH, :) * FACTOR + S2(:, ITH) = S(ITH, :) * FACTOR + END DO + ! NaN Check + IF (HasNaN(NK, NTH, A2) .OR. HasNaN(NK, NTH, S2)) THEN + IF (IAPROC .EQ. NAPOUT) & + WRITE(SCREEN, *) '★★★ Warning: find NaN in E(f, θ) & + & or Snl(f, θ) !' END IF + ! unit no. + IUNT = 500 + JLOC + ! Store data (binary) + ! OPEN(IUNT, FILE='NL5_'//trim(PNMS(JLOC))//'_src.bin', & + ! form='unformatted', convert=file_endian, ACCESS='stream', & + ! STATUS='old', POSITION='append', ACTION='write') + ! WRITE(IUNT) T1ABS + ! WRITE(IUNT) KURT + ! WRITE(IUNT) A2 + ! WRITE(IUNT) S2 + ! CLOSE(IUNT) + ! Store data (ascii) + OPEN(IUNT, FILE='NL5_'//trim(PNMS(JLOC))//'_src.dat', & + FORM='formatted', STATUS='old', & + POSITION='append', ACTION='write') + WRITE(IUNT, '(I10.8, I7.6)') T1ABS + WRITE(IUNT, '(ES11.3)') KURT + WRITE(IUNT, 113) A2 + WRITE(IUNT, 113) S2 + CLOSE(IUNT) + ! + END IF END IF -! Format - 113 FORMAT ((10ES11.3)) -!/ -!/ End of W3SNL5 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SNL5 -!/ ------------------------------------------------------------------- / - SUBROUTINE INSNL5 -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 27-Feb-2019 | -!/ +-----------------------------------+ -!/ -!/ 27-Feb-2019 : Origination. ( version 7.13 ) -!/ ( Q. Liu ) -!/ -! 1. Purpose : -! -! Initialization for the GKE module (Prepare wavenumber grid & kernel -! coefficients) -! -! 2. Method : -! See subrs. PrepKGrid & PrepKernelIO of gkeModule.f90 -! -! 3. Parameters : -! -! 4. Subroutines used : -! ---------------------------------------------------------------- -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! PrepKernelIO Subr. gkeModule KGrid & Kernel Coeff. -! -! 5. Called by : -! ---------------------------------------------------------------- -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Model definition file management. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GKEMD, ONLY: qr_depth, qr_oml, qi_disc, qi_kev, qi_nnz, & - qi_interp, PrepKernelIO - USE W3GDATMD, ONLY: NK, NTH, SIG, TH, & - QR5DPT, QR5OML, QI5DIS, QI5KEV, QI5NNZ, & - QI5IPL, QI5PMX - USE W3ODATMD, ONLY: IAPROC, NAPOUT, SCREEN - USE W3SERVMD, ONLY: EXTCDE + END IF + ! Format +113 FORMAT ((10ES11.3)) + !/ + !/ End of W3SNL5 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SNL5 + !/ ------------------------------------------------------------------- / + SUBROUTINE INSNL5 + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 27-Feb-2019 | + !/ +-----------------------------------+ + !/ + !/ 27-Feb-2019 : Origination. ( version 7.13 ) + !/ ( Q. Liu ) + !/ + ! 1. Purpose : + ! + ! Initialization for the GKE module (Prepare wavenumber grid & kernel + ! coefficients) + ! + ! 2. Method : + ! See subrs. PrepKGrid & PrepKernelIO of gkeModule.f90 + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! ---------------------------------------------------------------- + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! PrepKernelIO Subr. gkeModule KGrid & Kernel Coeff. + ! + ! 5. Called by : + ! ---------------------------------------------------------------- + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Model definition file management. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GKEMD, ONLY: qr_depth, qr_oml, qi_disc, qi_kev, qi_nnz, & + qi_interp, PrepKernelIO + USE W3GDATMD, ONLY: NK, NTH, SIG, TH, & + QR5DPT, QR5OML, QI5DIS, QI5KEV, QI5NNZ, & + QI5IPL, QI5PMX + USE W3ODATMD, ONLY: IAPROC, NAPOUT, SCREEN + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INSNL5') + CALL STRACE (IENT, 'INSNL5') #endif -! -! Set important parameters for GKE module (QR[I]5DPT/OML/DIS/KEV are -! defined in ww3_grid.inp, and QI5NNZ is not known yet) - qr_depth = QR5DPT - qr_oml = QR5OML - qi_disc = QI5DIS - qi_kev = QI5KEV - qi_interp= QI5IPL -! -! Prepare (kx, ky) grid & kernel coefficients - CALL PrepKernelIO(NK, NTH, SIG(1:NK), TH, 'WRITE') -! -! Store qi_NNZ to QI5NNZ (which will be used to initialize the -! QC5INT0 array) - QI5NNZ = qi_nnz -! -! Q. Liu (TODO) - IF (IAPROC .EQ. NAPOUT) THEN - WRITE(SCREEN, '(A, F6.1)') " ⊚ → [WW3 SNL₅]: water depth : ", qr_depth - WRITE(SCREEN, '(A, F7.2)') " ⊚ → [WW3 SNL₅]: ω λc cut off : ", qr_oml - WRITE(SCREEN, '(A, I4)' ) " ⊚ → [WW3 SNL₅]: Discretiza. : ", qi_disc - WRITE(SCREEN, '(A, I4)' ) " ⊚ → [WW3 SNL₅]: GKE version : ", qi_kev - WRITE(SCREEN, '(A, I12)' ) " ⊚ → [WW3 SNL₅]: # of quartets : ", qi_nnz - WRITE(SCREEN, '(A, I4)' ) " ⊚ → [WW3 SNL₅]: interpol. : ", qi_interp - WRITE(SCREEN, '(A, I4)' ) " ⊚ → [WW3 SNL₅]: phase mixing : ", QI5PMX - END IF -!/ -!/ End of INSNL5 ----------------------------------------------------- / -!/ - END SUBROUTINE INSNL5 -!/ ------------------------------------------------------------------- / - FUNCTION CALC_WBTv2 (A, CG, WN, DPT, U10, UDIR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 24-Apr-2019 | -!/ +-----------------------------------+ -!/ -!/ 24-Aug-2018 : Origination. (w3iogomd.ftn) ( version 6.06 ) -!/ Used for output parameter b_T ( Q. Liu ) -!/ -!/ 24-Apr-2019 : Simplified for NL5 ( version 7.13 ) -!/ ( Q. Liu ) -!/ -! 1. Purpose : -! -! Estimate the dominant wave breaking probability b_T based on -! the empirical parameterization proposed by Babanin et al. (2001). -! From their Fig. 12, we have -! -! b_T = 85.1 * [(εp - 0.055) * (1 + H_s/d)]^2.33, -! -! where ε is the significant steepness of the spectral peak, H_s is -! the significant wave height, d is the water depth. -! -! For more details, please see -! Banner et al. 2000: JPO, 30, 3145 - 3160. -! Babanin et al. 2001: JGR, 106(C6), 11569 - 11676. -! -! See subr. CALC_WBT in w3iogomd.ftn for more details. -! -!/ ------------------------------------------------------------------- / - USE W3DISPMD, ONLY: WAVNU1 - USE W3GDATMD, ONLY: NK, NTH, SIG, ESIN, ECOS, DTH, DSII + ! + ! Set important parameters for GKE module (QR[I]5DPT/OML/DIS/KEV are + ! defined in ww3_grid.inp, and QI5NNZ is not known yet) + qr_depth = QR5DPT + qr_oml = QR5OML + qi_disc = QI5DIS + qi_kev = QI5KEV + qi_interp= QI5IPL + ! + ! Prepare (kx, ky) grid & kernel coefficients + CALL PrepKernelIO(NK, NTH, SIG(1:NK), TH, 'WRITE') + ! + ! Store qi_NNZ to QI5NNZ (which will be used to initialize the + ! QC5INT0 array) + QI5NNZ = qi_nnz + ! + ! Q. Liu (TODO) + IF (IAPROC .EQ. NAPOUT) THEN + WRITE(SCREEN, '(A, F6.1)') " ⊚ → [WW3 SNL₅]: water depth : ", qr_depth + WRITE(SCREEN, '(A, F7.2)') " ⊚ → [WW3 SNL₅]: ω λc cut off : ", qr_oml + WRITE(SCREEN, '(A, I4)' ) " ⊚ → [WW3 SNL₅]: Discretiza. : ", qi_disc + WRITE(SCREEN, '(A, I4)' ) " ⊚ → [WW3 SNL₅]: GKE version : ", qi_kev + WRITE(SCREEN, '(A, I12)' ) " ⊚ → [WW3 SNL₅]: # of quartets : ", qi_nnz + WRITE(SCREEN, '(A, I4)' ) " ⊚ → [WW3 SNL₅]: interpol. : ", qi_interp + WRITE(SCREEN, '(A, I4)' ) " ⊚ → [WW3 SNL₅]: phase mixing : ", QI5PMX + END IF + !/ + !/ End of INSNL5 ----------------------------------------------------- / + !/ + END SUBROUTINE INSNL5 + !/ ------------------------------------------------------------------- / + FUNCTION CALC_WBTv2 (A, CG, WN, DPT, U10, UDIR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 24-Apr-2019 | + !/ +-----------------------------------+ + !/ + !/ 24-Aug-2018 : Origination. (w3iogomd.ftn) ( version 6.06 ) + !/ Used for output parameter b_T ( Q. Liu ) + !/ + !/ 24-Apr-2019 : Simplified for NL5 ( version 7.13 ) + !/ ( Q. Liu ) + !/ + ! 1. Purpose : + ! + ! Estimate the dominant wave breaking probability b_T based on + ! the empirical parameterization proposed by Babanin et al. (2001). + ! From their Fig. 12, we have + ! + ! b_T = 85.1 * [(εp - 0.055) * (1 + H_s/d)]^2.33, + ! + ! where ε is the significant steepness of the spectral peak, H_s is + ! the significant wave height, d is the water depth. + ! + ! For more details, please see + ! Banner et al. 2000: JPO, 30, 3145 - 3160. + ! Babanin et al. 2001: JGR, 106(C6), 11569 - 11676. + ! + ! See subr. CALC_WBT in w3iogomd.ftn for more details. + ! + !/ ------------------------------------------------------------------- / + USE W3DISPMD, ONLY: WAVNU1 + USE W3GDATMD, ONLY: NK, NTH, SIG, ESIN, ECOS, DTH, DSII #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH, NK) ! N(θ, k) - REAL, INTENT(IN) :: CG(NK) ! Cg(k) - REAL, INTENT(IN) :: WN(NK) ! WN(k) - REAL, INTENT(IN) :: DPT ! water depth - REAL, INTENT(IN) :: U10 ! wind velocity - REAL, INTENT(IN) :: UDIR ! wind dirc. (φ in rad) - REAL :: CALC_WBTv2 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + ! + IMPLICIT NONE + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH, NK) ! N(θ, k) + REAL, INTENT(IN) :: CG(NK) ! Cg(k) + REAL, INTENT(IN) :: WN(NK) ! WN(k) + REAL, INTENT(IN) :: DPT ! water depth + REAL, INTENT(IN) :: U10 ! wind velocity + REAL, INTENT(IN) :: UDIR ! wind dirc. (φ in rad) + REAL :: CALC_WBTv2 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! - REAL, PARAMETER :: BETA = 1.2 -! - INTEGER :: IK, ITH - REAL :: SINU, COSU, TC, TFORCE - REAL :: ESIG(NK) ! E(σ) - REAL :: FACTOR, ET, HS, ETP, HSP, SIGP, KP, & - CGP, WSTP, TWBT -!/ -!/ ------------------------------------------------------------------- / -!/ + ! + REAL, PARAMETER :: BETA = 1.2 + ! + INTEGER :: IK, ITH + REAL :: SINU, COSU, TC, TFORCE + REAL :: ESIG(NK) ! E(σ) + REAL :: FACTOR, ET, HS, ETP, HSP, SIGP, KP, & + CGP, WSTP, TWBT + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'CALC_WBTv2') + CALL STRACE (IENT, 'CALC_WBTv2') #endif -! -! Wind info. is required to select wind sea partition from the wave -! spectrum. -! -! Following Janssen et al. (1989) and Bidlot (2001), spectral components -! are considered to be subject to local wind forcing when -! -! c / [U cos(θ - φ)] < β, -! -! where c is the phase velocity c = σ/k, φ is the wind direction, U is -! the wind speed U10, (sometimes approximated by U10≅ 28 * ust), β is -! the constant forcing parameter with β∈ [1.0, 2.0]. By default, we use -! β = 1.2 (Bidlot 2001). -! - SINU = SIN(UDIR) ! sinφ - COSU = COS(UDIR) ! cosφ -! - ESIG = 0. ! E(σ) - ET = 0. ! ΣE(σ)δσ - ETP = 0. ! ΣE(σ)δσ at peak only -! - DO IK = 1, NK - TC = SIG(IK) / WN(IK) ! phase velocity c=σ/k - FACTOR = SIG(IK) / CG(IK) ! σ / cg - FACTOR = FACTOR * DTH ! σ / cg * δθ -! - DO ITH = 1, NTH - TFORCE = TC - U10 * (COSU*ECOS(ITH)+SINU*ESIN(ITH)) & - * BETA + ! + ! Wind info. is required to select wind sea partition from the wave + ! spectrum. + ! + ! Following Janssen et al. (1989) and Bidlot (2001), spectral components + ! are considered to be subject to local wind forcing when + ! + ! c / [U cos(θ - φ)] < β, + ! + ! where c is the phase velocity c = σ/k, φ is the wind direction, U is + ! the wind speed U10, (sometimes approximated by U10≅ 28 * ust), β is + ! the constant forcing parameter with β∈ [1.0, 2.0]. By default, we use + ! β = 1.2 (Bidlot 2001). + ! + SINU = SIN(UDIR) ! sinφ + COSU = COS(UDIR) ! cosφ + ! + ESIG = 0. ! E(σ) + ET = 0. ! ΣE(σ)δσ + ETP = 0. ! ΣE(σ)δσ at peak only + ! + DO IK = 1, NK + TC = SIG(IK) / WN(IK) ! phase velocity c=σ/k + FACTOR = SIG(IK) / CG(IK) ! σ / cg + FACTOR = FACTOR * DTH ! σ / cg * δθ + ! + DO ITH = 1, NTH + TFORCE = TC - U10 * (COSU*ECOS(ITH)+SINU*ESIN(ITH)) & + * BETA - IF (TFORCE .LT. 0.) THEN ! wind sea component - ESIG(IK) = ESIG(IK) + A(ITH, IK) * FACTOR - ENDIF - ENDDO ! ITH -! - ENDDO ! IK -! -! ESIG is E(σ) of the wind sea after filtration of any background swell. -! Now we need to get Hs & σp for the wind sea spectrum. -! Unlike w3iogomd.ftn, the tail energy is not added here. - ET = SUM(ESIG * DSII) - HS = 4. * SQRT(MAX(0., ET)) -! -! Get σp from E(σ) -! FPOPT = 0 in w3iogomd.ftn: fp defined by Young (1999, p. 239) - SIGP = SUM(ESIG**4. * SIG(1:NK) * DSII) / & - MAX(1E-10, SUM(ESIG**4. * DSII)) - IF (ABS(SIGP) < 1E-7) SIGP = SIG(NK) ! σp = 0 -! -! kp from σp (linear dispersion) - CALL WAVNU1 (SIGP, DPT, KP, CGP) -! -! { /1.3σp }1/2 -! peak wave height Hp = 4 { | E(σ) dσ } -! { /0.7σp } -! - DO IK = 1, NK - IF ( (SIG(IK) >= 0.7 * SIGP) .AND. & - (SIG(IK) <= 1.3 * SIGP) ) THEN - ETP = ETP + ESIG(IK) * DSII(IK) - ENDIF - ENDDO ! IK - HSP = 4. * SQRT(MAX(0., ETP)) -! -! significant steepness of the peak region εp -! - WSTP = 0.5 * KP * HSP -! -! Dominant wave breaking b_T -! - TWBT = 85.1 * (MAX(0.0, WSTP - 0.055) * (1 + HS/DPT))**2.33 - TWBT = MIN(1.0, TWBT) -! - CALC_WBTv2 = TWBT + IF (TFORCE .LT. 0.) THEN ! wind sea component + ESIG(IK) = ESIG(IK) + A(ITH, IK) * FACTOR + ENDIF + ENDDO ! ITH + ! + ENDDO ! IK + ! + ! ESIG is E(σ) of the wind sea after filtration of any background swell. + ! Now we need to get Hs & σp for the wind sea spectrum. + ! Unlike w3iogomd.ftn, the tail energy is not added here. + ET = SUM(ESIG * DSII) + HS = 4. * SQRT(MAX(0., ET)) + ! + ! Get σp from E(σ) + ! FPOPT = 0 in w3iogomd.ftn: fp defined by Young (1999, p. 239) + SIGP = SUM(ESIG**4. * SIG(1:NK) * DSII) / & + MAX(1E-10, SUM(ESIG**4. * DSII)) + IF (ABS(SIGP) < 1E-7) SIGP = SIG(NK) ! σp = 0 + ! + ! kp from σp (linear dispersion) + CALL WAVNU1 (SIGP, DPT, KP, CGP) + ! + ! { /1.3σp }1/2 + ! peak wave height Hp = 4 { | E(σ) dσ } + ! { /0.7σp } + ! + DO IK = 1, NK + IF ( (SIG(IK) >= 0.7 * SIGP) .AND. & + (SIG(IK) <= 1.3 * SIGP) ) THEN + ETP = ETP + ESIG(IK) * DSII(IK) + ENDIF + ENDDO ! IK + HSP = 4. * SQRT(MAX(0., ETP)) + ! + ! significant steepness of the peak region εp + ! + WSTP = 0.5 * KP * HSP + ! + ! Dominant wave breaking b_T + ! + TWBT = 85.1 * (MAX(0.0, WSTP - 0.055) * (1 + HS/DPT))**2.33 + TWBT = MIN(1.0, TWBT) + ! + CALC_WBTv2 = TWBT - RETURN -!/ -!/ End of CALC_WBTv2 ------------------------------------------------ / -!/ - END FUNCTION CALC_WBTv2 + RETURN + !/ + !/ End of CALC_WBTv2 ------------------------------------------------ / + !/ + END FUNCTION CALC_WBTv2 -!/ ------------------------------------------------------------------- / - SUBROUTINE INPOUT -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 25-Mar-2019 | -!/ +-----------------------------------+ -!/ -!/ 24-Mar-2019 : Origination. ( version 7.13 ) -!/ ( Q. Liu ) -!/ 27-Apr-2019 : Add the ascii option ( Q. Liu ) -!/ -! 1. Purpose : -! -! Initialization for point output (Snl) [see also W3IOPP of w3iopomd] -! -! 2. Method : -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! 5. Called by : -! ---------------------------------------------------------------- -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SNL5 Subr. W3SNL5MD S_{nl} GKE -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPI - USE W3GDATMD, ONLY: NK, NTH, SIG, TH, QR5DPT, & - FLAGLL, XGRD, YGRD, MAPSTA, MAPFS - USE W3ODATMD, ONLY: NOPTS, PTNME, PTLOC, IPTINT, & - IAPROC, NAPOUT, SCREEN - USE W3SERVMD, ONLY: DIST_SPHERE + !/ ------------------------------------------------------------------- / + SUBROUTINE INPOUT + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 25-Mar-2019 | + !/ +-----------------------------------+ + !/ + !/ 24-Mar-2019 : Origination. ( version 7.13 ) + !/ ( Q. Liu ) + !/ 27-Apr-2019 : Add the ascii option ( Q. Liu ) + !/ + ! 1. Purpose : + ! + ! Initialization for point output (Snl) [see also W3IOPP of w3iopomd] + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! ---------------------------------------------------------------- + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SNL5 Subr. W3SNL5MD S_{nl} GKE + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPI + USE W3GDATMD, ONLY: NK, NTH, SIG, TH, QR5DPT, & + FLAGLL, XGRD, YGRD, MAPSTA, MAPFS + USE W3ODATMD, ONLY: NOPTS, PTNME, PTLOC, IPTINT, & + IAPROC, NAPOUT, SCREEN + USE W3SERVMD, ONLY: DIST_SPHERE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: IXS(4), IYS(4), IX, IY, IPT, IS, & - JLOC, JX, JY, ISEA, SMAP(4), IUNT - REAL :: PLON, PLAT, XLON, YLAT, DIST(4) -!/ ------------------------------------------------------------------- / -!/ -! Initialize arrays - IF (ALLOCATED(PSEA)) DEALLOCATE(PSEA); ALLOCATE(PSEA(NOPTS)) - IF (ALLOCATED(PNMS)) DEALLOCATE(PNMS); ALLOCATE(PNMS(NOPTS)) -! - NSEL = 0 - PSEA(:) = 0 - PNMS(:) = 'null' - DIST(:) = -999. -! - DO IPT = 1, NOPTS -! Get lon & lat of this output point - PLON = PTLOC(1, IPT) - PLAT = PTLOC(2, IPT) -! Get four indices surrounding the output point - IXS(:) = IPTINT(1, :, IPT) - IYS(:) = IPTINT(2, :, IPT) - DO IS = 1, 4 -! Get lon & lat of four corner points - IX = IXS(IS) - IY = IYS(IS) - XLON = XGRD(IY, IX) - YLAT = YGRD(IY, IX) -! Grid point status - IF (MAPSTA(IY, IX) .EQ. 0) CYCLE -! Calc dist. - IF (FLAGLL) THEN - DIST(IS) = DIST_SPHERE(PLON, PLAT, XLON, YLAT) - ELSE - DIST(IS) = SQRT((PLON - XLON)**2. + (PLAT - YLAT)**2.) - END IF - END DO -! A sea point filter: there must be at least one sea grid point around -! the selected output location. [maybe not necessary since IOPP already -! checked this criterion] -! - IF (ALL(DIST < 0.)) CYCLE -! Find the nearest sea grid point - JLOC = MINLOC(DIST, 1, DIST >= 0.) - JX = IXS(JLOC) - JY = IYS(JLOC) - ISEA = MAPFS(JY, JX) -! Basic check + !/ + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: IXS(4), IYS(4), IX, IY, IPT, IS, & + JLOC, JX, JY, ISEA, SMAP(4), IUNT + REAL :: PLON, PLAT, XLON, YLAT, DIST(4) + !/ ------------------------------------------------------------------- / + !/ + ! Initialize arrays + IF (ALLOCATED(PSEA)) DEALLOCATE(PSEA); ALLOCATE(PSEA(NOPTS)) + IF (ALLOCATED(PNMS)) DEALLOCATE(PNMS); ALLOCATE(PNMS(NOPTS)) + ! + NSEL = 0 + PSEA(:) = 0 + PNMS(:) = 'null' + DIST(:) = -999. + ! + DO IPT = 1, NOPTS + ! Get lon & lat of this output point + PLON = PTLOC(1, IPT) + PLAT = PTLOC(2, IPT) + ! Get four indices surrounding the output point + IXS(:) = IPTINT(1, :, IPT) + IYS(:) = IPTINT(2, :, IPT) + DO IS = 1, 4 + ! Get lon & lat of four corner points + IX = IXS(IS) + IY = IYS(IS) + XLON = XGRD(IY, IX) + YLAT = YGRD(IY, IX) + ! Grid point status + IF (MAPSTA(IY, IX) .EQ. 0) CYCLE + ! Calc dist. + IF (FLAGLL) THEN + DIST(IS) = DIST_SPHERE(PLON, PLAT, XLON, YLAT) + ELSE + DIST(IS) = SQRT((PLON - XLON)**2. + (PLAT - YLAT)**2.) + END IF + END DO + ! A sea point filter: there must be at least one sea grid point around + ! the selected output location. [maybe not necessary since IOPP already + ! checked this criterion] + ! + IF (ALL(DIST < 0.)) CYCLE + ! Find the nearest sea grid point + JLOC = MINLOC(DIST, 1, DIST >= 0.) + JX = IXS(JLOC) + JY = IYS(JLOC) + ISEA = MAPFS(JY, JX) + ! Basic check #ifdef W3_TS IF (FLAGLL) THEN - IF (IAPROC .EQ. NAPOUT) & - WRITE(SCREEN, "(A, 2F10.3, A, 2F10.3, A)") & - '✗ (PLON, PLAT): (', PLON, PLAT, ') | (XGRD, YGRD): (',& - XGRD(JY, JX), YGRD(JY, JX), ')' + IF (IAPROC .EQ. NAPOUT) & + WRITE(SCREEN, "(A, 2F10.3, A, 2F10.3, A)") & + '✗ (PLON, PLAT): (', PLON, PLAT, ') | (XGRD, YGRD): (',& + XGRD(JY, JX), YGRD(JY, JX), ')' ELSE - IF (IAPROC .EQ. NAPOUT) & - WRITE(SCREEN, "(A, 2E10.3, A, 2E10.3, A)") & - '✗ (PLON, PLAT): (', PLON, PLAT, ') | (XGRD, YGRD): (',& - XGRD(JY, JX), YGRD(JY, JX), ')' + IF (IAPROC .EQ. NAPOUT) & + WRITE(SCREEN, "(A, 2E10.3, A, 2E10.3, A)") & + '✗ (PLON, PLAT): (', PLON, PLAT, ') | (XGRD, YGRD): (',& + XGRD(JY, JX), YGRD(JY, JX), ')' END IF #endif -! Store ISEA - NSEL = NSEL + 1 - PSEA(NSEL) = ISEA - PNMS(NSEL) = PTNME(IPT) -! Store Unit (Open & Write Binary files) - IUNT = 500 + NSEL -! Binary -! OPEN(IUNT, FILE='NL5_'//trim(PNMS(NSEL))//'_src.bin', & -! form='unformatted', convert=file_endian, ACCESS='stream', STATUS='replace', & -! ACTION='write') -! WRITE(IUNT) PLON, PLAT -! WRITE(IUNT) XGRD(JY, JX), YGRD(JY, JX) -! WRITE(IUNT) QR5DPT -! WRITE(IUNT) NK, NTH -! WRITE(IUNT) SIG(1:NK)/TPI ! f, θ -! WRITE(IUNT) TH -! CLOSE(IUNT) -! Ascii - OPEN(IUNT, FILE='NL5_'//trim(PNMS(NSEL))//'_src.dat', & - FORM='formatted', STATUS='replace', ACTION='write') - WRITE(IUNT, '(2ES11.3)') PLON, PLAT - WRITE(IUNT, '(ES11.3)' ) QR5DPT - WRITE(IUNT, '(2I5)') NK, NTH - WRITE(IUNT, 113) SIG(1:NK)/TPI ! f, θ - WRITE(IUNT, 113) TH - CLOSE(IUNT) -! - END DO -! Format - 113 FORMAT ((10ES11.3)) -! - END SUBROUTINE INPOUT -!/ ------------------------------------------------------------------- / - FUNCTION HasNaN(NK, NTH, ARR2D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 25-Apr-2019 | -!/ +-----------------------------------+ -!/ -!/ 24-Apr-2019 : Origination. ( version 7.13 ) -!/ ( Q. Liu ) -!/ -! 1. Purpose : -! Check if the 2D array `ARR2D` contains NaN (see also w3gsrumd.ftn) -!/ - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: NK, NTH ! # OF FREQ. & DIRC. - REAL, INTENT(IN) :: ARR2D(NK, NTH) - LOGICAL :: HasNaN -!/ - HasNaN = .TRUE. -! - IF ( ALL(ARR2D .GE. -HUGE(ARR2D(1, 1))) .AND. & - ALL(ARR2D .LE. HUGE(ARR2D(1, 1))) ) THEN - HasNaN = .FALSE. - END IF -! - RETURN -!/ - END FUNCTION HasNaN -!/ ------------------------------------------------------------------- / -!/ -!/ End of module W3SNL5MD -------------------------------------------- / -!/ - END MODULE W3SNL5MD + ! Store ISEA + NSEL = NSEL + 1 + PSEA(NSEL) = ISEA + PNMS(NSEL) = PTNME(IPT) + ! Store Unit (Open & Write Binary files) + IUNT = 500 + NSEL + ! Binary + ! OPEN(IUNT, FILE='NL5_'//trim(PNMS(NSEL))//'_src.bin', & + ! form='unformatted', convert=file_endian, ACCESS='stream', STATUS='replace', & + ! ACTION='write') + ! WRITE(IUNT) PLON, PLAT + ! WRITE(IUNT) XGRD(JY, JX), YGRD(JY, JX) + ! WRITE(IUNT) QR5DPT + ! WRITE(IUNT) NK, NTH + ! WRITE(IUNT) SIG(1:NK)/TPI ! f, θ + ! WRITE(IUNT) TH + ! CLOSE(IUNT) + ! Ascii + OPEN(IUNT, FILE='NL5_'//trim(PNMS(NSEL))//'_src.dat', & + FORM='formatted', STATUS='replace', ACTION='write') + WRITE(IUNT, '(2ES11.3)') PLON, PLAT + WRITE(IUNT, '(ES11.3)' ) QR5DPT + WRITE(IUNT, '(2I5)') NK, NTH + WRITE(IUNT, 113) SIG(1:NK)/TPI ! f, θ + WRITE(IUNT, 113) TH + CLOSE(IUNT) + ! + END DO + ! Format +113 FORMAT ((10ES11.3)) + ! + END SUBROUTINE INPOUT + !/ ------------------------------------------------------------------- / + FUNCTION HasNaN(NK, NTH, ARR2D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 25-Apr-2019 | + !/ +-----------------------------------+ + !/ + !/ 24-Apr-2019 : Origination. ( version 7.13 ) + !/ ( Q. Liu ) + !/ + ! 1. Purpose : + ! Check if the 2D array `ARR2D` contains NaN (see also w3gsrumd.ftn) + !/ + IMPLICIT NONE + ! + INTEGER, INTENT(IN) :: NK, NTH ! # OF FREQ. & DIRC. + REAL, INTENT(IN) :: ARR2D(NK, NTH) + LOGICAL :: HasNaN + !/ + HasNaN = .TRUE. + ! + IF ( ALL(ARR2D .GE. -HUGE(ARR2D(1, 1))) .AND. & + ALL(ARR2D .LE. HUGE(ARR2D(1, 1))) ) THEN + HasNaN = .FALSE. + END IF + ! + RETURN + !/ + END FUNCTION HasNaN + !/ ------------------------------------------------------------------- / + !/ + !/ End of module W3SNL5MD -------------------------------------------- / + !/ +END MODULE W3SNL5MD !/ ------------------------------------------------------------------- / diff --git a/model/src/w3snlsmd.F90 b/model/src/w3snlsmd.F90 index 11310c14d..576980553 100644 --- a/model/src/w3snlsmd.F90 +++ b/model/src/w3snlsmd.F90 @@ -1,813 +1,807 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SNLSMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jul-2012 | -!/ +-----------------------------------+ -!/ -!/ 04-Aug-2008 : Origination in research model. ( version 3.13 ) -!/ 27-Sep-2010 : Added to svn repository. ( version 3.15 ) -!/ 13-Jul-2012 : Moved from version 3.15 to 4.08. ( version 4.08 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Nonlinear interaction based `smoother' for high frequencies. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NKD I.P. Private Number of nondimensional depths in -! storage array. -! KDMIN R.P. Private Minimum relative depth in table. -! KDMAX R.P. Private Maximum relative depth in table. -! SITMIN Real Private Minimum nondimensional radian -! frequency in table. -! XSIT Real Private Corresponding incremet factor. -! ABMAX R.P. Public Maximum value of a34, b3 and b4. -! ---------------------------------------------------------------- -! -! Variables in W3GDATMD : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! CNLSA Real Public a34 in quadruplet definition. -! CNLSC Real Public C in Snl definition. -! CNLSFM Real Public Maximum relative spectral change. -! CNLSC1/3 Real Public Constant in frequency filter. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SNLS Subr. Public Nonlinear 'smoother' algorithm. -! EXPAND Subr. W3SNLS Expand spectrum for indirect address. -! INSNLS Subr. Public Initialization routine. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WAVNU1 Subr. W3DISPMD Solve dispersion relation. -! WAVNU2 Subr. W3DISPMD Solve dispersion relation. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Program abort. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER, PRIVATE, PARAMETER :: NKD = 100 - REAL, PRIVATE, PARAMETER :: KDMIN = 0.25 , KDMAX = 10. - REAL, PRIVATE :: SITMIN, XSIT -! - REAL, PARAMETER :: ABMAX = 0.25 -! - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 04-Aug-2008 | -!/ +-----------------------------------+ -!/ -!/ 04-Aug-2008 : Origination. ( version 3.13 ) -!/ -! 1. Purpose : -! -! High-frequeny filter based on the nonlinear interactions for -! an uresolved quadruplet. -! -! 2. Method : -! -! Compute interactions for a quadruplet that is not resolved by -! the discrete spectral rsolution, and then reduces to a simple -! five-point stencil. Furthermore interactions are filtered by -! frequency to allow for high-frequency impact only, and the -! integration schem is embedded, and reduces to a filter technique -! for large time steps or strong interactions. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action spectrum A(ITH,IK) as a function of -! direction (rad) and wavenumber. -! CG R.A. I Group velocities (dimension NK). -! WN R.A. I Wavenumbers (dimension NK). -! DEPTH Real I Water depth in meters. -! UABS Real I Wind speed (m/s). -! DT Real I Numerical time step (s). -! SNL R.A. O Nonlinear source term. (Opt) -! AA R.A. O Averaged spectrum. (Opt) -! ---------------------------------------------------------------- -! Note: A and AA may safely be same array/address. -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WAVNU1 Subr. W3DISPMD Solve dispersion relation. -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T1 Test output frequency filter. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NFR => NK, NTH, SIG, XFR, FACHFA, DTH, & - NTHX, NFRX, NSPL, NSPH, SNSST, CNLSC, & - CNLSFM, CNLSC1, CNLSC2, CNLSC3 - USE W3ODATMD, ONLY: NDST, NDSE -! - USE W3DISPMD, ONLY: WAVNU1 +MODULE W3SNLSMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jul-2012 | + !/ +-----------------------------------+ + !/ + !/ 04-Aug-2008 : Origination in research model. ( version 3.13 ) + !/ 27-Sep-2010 : Added to svn repository. ( version 3.15 ) + !/ 13-Jul-2012 : Moved from version 3.15 to 4.08. ( version 4.08 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Nonlinear interaction based `smoother' for high frequencies. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NKD I.P. Private Number of nondimensional depths in + ! storage array. + ! KDMIN R.P. Private Minimum relative depth in table. + ! KDMAX R.P. Private Maximum relative depth in table. + ! SITMIN Real Private Minimum nondimensional radian + ! frequency in table. + ! XSIT Real Private Corresponding incremet factor. + ! ABMAX R.P. Public Maximum value of a34, b3 and b4. + ! ---------------------------------------------------------------- + ! + ! Variables in W3GDATMD : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! CNLSA Real Public a34 in quadruplet definition. + ! CNLSC Real Public C in Snl definition. + ! CNLSFM Real Public Maximum relative spectral change. + ! CNLSC1/3 Real Public Constant in frequency filter. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SNLS Subr. Public Nonlinear 'smoother' algorithm. + ! EXPAND Subr. W3SNLS Expand spectrum for indirect address. + ! INSNLS Subr. Public Initialization routine. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WAVNU1 Subr. W3DISPMD Solve dispersion relation. + ! WAVNU2 Subr. W3DISPMD Solve dispersion relation. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER, PRIVATE, PARAMETER :: NKD = 100 + REAL, PRIVATE, PARAMETER :: KDMIN = 0.25 , KDMAX = 10. + REAL, PRIVATE :: SITMIN, XSIT + ! + REAL, PARAMETER :: ABMAX = 0.25 + ! + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 04-Aug-2008 | + !/ +-----------------------------------+ + !/ + !/ 04-Aug-2008 : Origination. ( version 3.13 ) + !/ + ! 1. Purpose : + ! + ! High-frequeny filter based on the nonlinear interactions for + ! an uresolved quadruplet. + ! + ! 2. Method : + ! + ! Compute interactions for a quadruplet that is not resolved by + ! the discrete spectral rsolution, and then reduces to a simple + ! five-point stencil. Furthermore interactions are filtered by + ! frequency to allow for high-frequency impact only, and the + ! integration schem is embedded, and reduces to a filter technique + ! for large time steps or strong interactions. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action spectrum A(ITH,IK) as a function of + ! direction (rad) and wavenumber. + ! CG R.A. I Group velocities (dimension NK). + ! WN R.A. I Wavenumbers (dimension NK). + ! DEPTH Real I Water depth in meters. + ! UABS Real I Wind speed (m/s). + ! DT Real I Numerical time step (s). + ! SNL R.A. O Nonlinear source term. (Opt) + ! AA R.A. O Averaged spectrum. (Opt) + ! ---------------------------------------------------------------- + ! Note: A and AA may safely be same array/address. + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WAVNU1 Subr. W3DISPMD Solve dispersion relation. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T1 Test output frequency filter. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NFR => NK, NTH, SIG, XFR, FACHFA, DTH, & + NTHX, NFRX, NSPL, NSPH, SNSST, CNLSC, & + CNLSFM, CNLSC1, CNLSC2, CNLSC3 + USE W3ODATMD, ONLY: NDST, NDSE + ! + USE W3DISPMD, ONLY: WAVNU1 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T2 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NFR), CG(NFR), WN(NFR), & - DEPTH, UABS, DT - REAL, INTENT(OUT), OPTIONAL :: SNL(NTH,NFR), AA(NTH,NFR) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IFR, IFRMIN, ITH, IFRMN2, & - IKD, JKD(0:NFR+2), ISPX0, ISPX + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NFR), CG(NFR), WN(NFR), & + DEPTH, UABS, DT + REAL, INTENT(OUT), OPTIONAL :: SNL(NTH,NFR), AA(NTH,NFR) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IFR, IFRMIN, ITH, IFRMN2, & + IKD, JKD(0:NFR+2), ISPX0, ISPX #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: SIGP, CP, CM, XL, XH, EL, EH, DENOM, & - SIT, XSITLN, MC, F3A, F3B, F3C, & - F4A, F4B, F4C, F00, F31, F32, F41, & - F42, AUXB, AUX11, AUX21, AUX12, & - AUX22, FC1, FC2, FC3, FC4 - REAL :: XSI(NFR+2), XWN(NFR+2), XCG(NFR+2), & - UP(NSPL:NSPH), UN(NSPL:NSPH), & - E1(0:NFR+2), FILTFP(NFR+2), & - FPROP(NFR+2), DS1(NSPL:NSPH), & - DS2(NSPL:NSPH), DS3(NSPL:NSPH), & - DA1(NSPL:NSPH), DA2(NSPL:NSPH), & - DA3(NSPL:NSPH) -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: SIGP, CP, CM, XL, XH, EL, EH, DENOM, & + SIT, XSITLN, MC, F3A, F3B, F3C, & + F4A, F4B, F4C, F00, F31, F32, F41, & + F42, AUXB, AUX11, AUX21, AUX12, & + AUX22, FC1, FC2, FC3, FC4 + REAL :: XSI(NFR+2), XWN(NFR+2), XCG(NFR+2), & + UP(NSPL:NSPH), UN(NSPL:NSPH), & + E1(0:NFR+2), FILTFP(NFR+2), & + FPROP(NFR+2), DS1(NSPL:NSPH), & + DS2(NSPL:NSPH), DS3(NSPL:NSPH), & + DA1(NSPL:NSPH), DA2(NSPL:NSPH), & + DA3(NSPL:NSPH) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SNLS') + CALL STRACE (IENT, 'W3SNLS') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) DEPTH, UABS, DT + WRITE (NDST,9000) DEPTH, UABS, DT #endif -! -! 1. Initializations ------------------------------------------------ * -! 1.a Expanded frequency range -! - XSI(1:NFR) = SIG(1:NFR) - XWN(1:NFR) = WN - XCG(1:NFR) = CG -! - XSI(NFR+1) = XSI(NFR) * XFR - CALL WAVNU1 ( XSI(NFR+1), DEPTH, XWN(NFR+1), XCG(NFR+1) ) - XSI(NFR+2) = XSI(NFR+1) * XFR - CALL WAVNU1 ( XSI(NFR+2), DEPTH, XWN(NFR+2), XCG(NFR+2) ) -! -! 1.b Expanded psuedo spectrum -! - CALL EXPAND ( UP, UN ) -! -! 1.c Get relevant spectral peak frequency -! + ! + ! 1. Initializations ------------------------------------------------ * + ! 1.a Expanded frequency range + ! + XSI(1:NFR) = SIG(1:NFR) + XWN(1:NFR) = WN + XCG(1:NFR) = CG + ! + XSI(NFR+1) = XSI(NFR) * XFR + CALL WAVNU1 ( XSI(NFR+1), DEPTH, XWN(NFR+1), XCG(NFR+1) ) + XSI(NFR+2) = XSI(NFR+1) * XFR + CALL WAVNU1 ( XSI(NFR+2), DEPTH, XWN(NFR+2), XCG(NFR+2) ) + ! + ! 1.b Expanded psuedo spectrum + ! + CALL EXPAND ( UP, UN ) + ! + ! 1.c Get relevant spectral peak frequency + ! #ifdef W3_T1 - E1 = -1. + E1 = -1. #endif - SIGP = - TPI - XL = 1./XFR - 1. - XH = XFR - 1. -! -! 1.c.1 Wind too weak -! - IF ( UABS .LT. XSI(NFR)/XWN(NFR) ) THEN - SIGP = GRAV / MAX ( 0.01 , UABS ) + SIGP = - TPI + XL = 1./XFR - 1. + XH = XFR - 1. + ! + ! 1.c.1 Wind too weak + ! + IF ( UABS .LT. XSI(NFR)/XWN(NFR) ) THEN + SIGP = GRAV / MAX ( 0.01 , UABS ) + ELSE + ! + ! 1.c.2 Compute 1D spectrum + ! + E1(NFR+2) = SUM(A(:,NFR)) * FACHFA**2 * XSI(NFR+2) & + / XCG(NFR+2) * TPI * DTH + E1(NFR+1) = SUM(A(:,NFR)) * FACHFA * XSI(NFR+1) & + / XCG(NFR+1) * TPI * DTH + ! + DO IFR=NFR, 1, -1 + E1(IFR) = SUM(A(:,IFR)) * XSI(IFR) / XCG(IFR) * TPI * DTH + ! + ! 1.c.3 Reached PM frequency + ! + IF ( UABS .LT. XSI(IFR)/XWN(IFR) ) THEN + CP = XSI(IFR)/XWN(IFR) + CM = XSI(IFR+1)/XWN(IFR+1) + SIGP = XSI( IFR ) * (UABS-CM)/(CP-CM) + & + XSI(IFR+1) * (CP-UABS)/(CP-CM) + EXIT + ! + ELSE IF ( E1(IFR) .LT. E1(IFR+1) ) THEN + ! + ! 1.c.4 Reached first peak + ! + EL = E1(IFR ) - E1(IFR+1) + EH = E1(IFR+2) - E1(IFR+1) + DENOM = XL*EH - XH*EL + SIGP = XSI(IFR+1) * (1.+0.5*(XL**2*EH-XH**2*EL) & + / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) + EXIT + ENDIF + ! + ! ... End loop 1.c.2 + ! + END DO + ! + ! 1.c.5 Nothing found + ! + IF ( SIGP .LT. 0. ) THEN + ! + ! 1.c.5.a No energy there + ! + IF ( E1(1) .EQ. 0. ) THEN + SIGP = 2. * SIG(NFR) + ! + ! 1.c.5.b Peak at low boundary + ! ELSE -! -! 1.c.2 Compute 1D spectrum -! - E1(NFR+2) = SUM(A(:,NFR)) * FACHFA**2 * XSI(NFR+2) & - / XCG(NFR+2) * TPI * DTH - E1(NFR+1) = SUM(A(:,NFR)) * FACHFA * XSI(NFR+1) & - / XCG(NFR+1) * TPI * DTH -! - DO IFR=NFR, 1, -1 - E1(IFR) = SUM(A(:,IFR)) * XSI(IFR) / XCG(IFR) * TPI * DTH -! -! 1.c.3 Reached PM frequency -! - IF ( UABS .LT. XSI(IFR)/XWN(IFR) ) THEN - CP = XSI(IFR)/XWN(IFR) - CM = XSI(IFR+1)/XWN(IFR+1) - SIGP = XSI( IFR ) * (UABS-CM)/(CP-CM) + & - XSI(IFR+1) * (CP-UABS)/(CP-CM) - EXIT -! - ELSE IF ( E1(IFR) .LT. E1(IFR+1) ) THEN -! -! 1.c.4 Reached first peak -! - EL = E1(IFR ) - E1(IFR+1) - EH = E1(IFR+2) - E1(IFR+1) - DENOM = XL*EH - XH*EL - SIGP = XSI(IFR+1) * (1.+0.5*(XL**2*EH-XH**2*EL) & - / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) - EXIT - ENDIF -! -! ... End loop 1.c.2 -! - END DO -! -! 1.c.5 Nothing found -! - IF ( SIGP .LT. 0. ) THEN -! -! 1.c.5.a No energy there -! - IF ( E1(1) .EQ. 0. ) THEN - SIGP = 2. * SIG(NFR) -! -! 1.c.5.b Peak at low boundary -! - ELSE - SIGP = XSI(1) - END IF - END IF -! + SIGP = XSI(1) END IF -! -! 1.d Set up filter function etc. -! - XSITLN = LOG(XSIT) - IFRMIN = 1 - JKD = 1 + END IF + ! + END IF + ! + ! 1.d Set up filter function etc. + ! + XSITLN = LOG(XSIT) + IFRMIN = 1 + JKD = 1 #ifdef W3_T1 - FILTFP = -1. + FILTFP = -1. #endif -! - DO IFR=NFR+2, 1, -1 -! - FILTFP(IFR) = EXP(-CNLSC1/(XSI(IFR)/(CNLSC2*SIGP))**CNLSC3) - FPROP (IFR) = FILTFP(IFR) * CNLSC * XWN(IFR)**8 * & - XSI(IFR)**4 / TPI**9 / XCG(IFR) - SIT = XSI(IFR) * SQRT(DEPTH/GRAV) - IKD = 1 + NINT ( ( LOG(SIT) - LOG(SITMIN) ) / XSITLN ) - JKD(IFR) = MAX ( 1 , MIN(IKD,NKD) ) -! - IF ( FILTFP(IFR) .LT. 1.E-10 ) THEN - IFRMIN = IFR - EXIT - END IF -! - END DO -! - IFRMN2 = MAX ( 1 , IFRMIN - 1 ) - SIT = XSI(IFRMN2) * SQRT(DEPTH/GRAV) - IKD = 1 + NINT ( ( LOG(SIT) - LOG(SITMIN) ) / XSITLN ) - JKD(IFRMN2) = MAX ( 1 , MIN(IKD,NKD) ) -! + ! + DO IFR=NFR+2, 1, -1 + ! + FILTFP(IFR) = EXP(-CNLSC1/(XSI(IFR)/(CNLSC2*SIGP))**CNLSC3) + FPROP (IFR) = FILTFP(IFR) * CNLSC * XWN(IFR)**8 * & + XSI(IFR)**4 / TPI**9 / XCG(IFR) + SIT = XSI(IFR) * SQRT(DEPTH/GRAV) + IKD = 1 + NINT ( ( LOG(SIT) - LOG(SITMIN) ) / XSITLN ) + JKD(IFR) = MAX ( 1 , MIN(IKD,NKD) ) + ! + IF ( FILTFP(IFR) .LT. 1.E-10 ) THEN + IFRMIN = IFR + EXIT + END IF + ! + END DO + ! + IFRMN2 = MAX ( 1 , IFRMIN - 1 ) + SIT = XSI(IFRMN2) * SQRT(DEPTH/GRAV) + IKD = 1 + NINT ( ( LOG(SIT) - LOG(SITMIN) ) / XSITLN ) + JKD(IFRMN2) = MAX ( 1 , MIN(IKD,NKD) ) + ! #ifdef W3_T - WRITE (NDST,9010) IFRMIN, SIGP * TPIINV + WRITE (NDST,9010) IFRMIN, SIGP * TPIINV #endif #ifdef W3_T1 - WRITE (NDST,9011) - DO IFR=1, NFR - WRITE (NDST,9012) IFR, XSI(IFR)/TPI, XSI(IFR)/XWN(IFR), & - E1(IFR), FILTFP(IFR) - END DO + WRITE (NDST,9011) + DO IFR=1, NFR + WRITE (NDST,9012) IFR, XSI(IFR)/TPI, XSI(IFR)/XWN(IFR), & + E1(IFR), FILTFP(IFR) + END DO #endif -! -! 1.e Initialize arrays -! -! -! 2. Compute base interactions -------------------------------------- * -! 2.a Loop over frequencies -! - DO IFR=IFRMIN, NFR+1 -! + ! + ! 1.e Initialize arrays + ! + ! + ! 2. Compute base interactions -------------------------------------- * + ! 2.a Loop over frequencies + ! + DO IFR=IFRMIN, NFR+1 + ! + ISPX0 = (IFR-1)*NTHX + IKD = JKD(IFR) + ! + MC = SNSST( 1,IKD) + F3A = SNSST( 2,IKD) + F3B = SNSST( 3,IKD) + F3C = SNSST( 4,IKD) + F4A = SNSST( 5,IKD) + F4B = SNSST( 6,IKD) + F4C = F3C + ! + ! 2.b Loop over directions + ! + DO ITH=1, NTH + ! + ISPX = ISPX0 + ITH + ! + F00 = UP(ISPX) + F31 = UP(ISPX)*F3A + UP(ISPX+1)*F3B + UP(ISPX+NTHX)*F3C + F41 = UP(ISPX)*F4A + UP(ISPX-1)*F4B + UP(ISPX-NTHX)*F4C + F32 = UP(ISPX)*F3A + UP(ISPX-1)*F3B + UP(ISPX+NTHX)*F3C + F42 = UP(ISPX)*F4A + UP(ISPX+1)*F4B + UP(ISPX-NTHX)*F4C + ! + DS1(ISPX) = FPROP(IFR) * (F00**2*(F31+F41)-2.*F00*F31*F41) + DS2(ISPX) = FPROP(IFR) * (F00**2*(F32+F42)-2.*F00*F32*F42) + ! + AUX11 = DT * DS1(ISPX) + AUX21 = DT * DS2(ISPX) + AUXB = CNLSFM * FILTFP(IFR) * MAX(1.E-10,UN(ISPX)) / & + MAX ( 1.E-10 , ABS(AUX11)+ABS(AUX21) ) / MC + AUX12 = AUXB * ABS(AUX11) + AUX22 = AUXB * ABS(AUX21) + ! + ! Expensive but more smooth limiter + ! + ! DA1(ISPX) = AUX12 * TANH(AUX11/MAX(1.E-10,AUX12)) + ! DA2(ISPX) = AUX22 * TANH(AUX21/MAX(1.E-10,AUX22)) + ! + ! Crude but cheaper limiter + ! + DA1(ISPX) = MAX ( -AUX12 , MIN ( AUX11 , AUX12 ) ) + DA2(ISPX) = MAX ( -AUX22 , MIN ( AUX21 , AUX22 ) ) + ! + END DO + ! + ! ... End loop 2.b + ! + END DO + ! + ! 2.c Complete expanded arrays + ! + ! ... End loop 2.a + ! + ! 3. Compute source term if requested ------------------------------- * + ! 3.a Check for request + ! + IF ( PRESENT(SNL) ) THEN +#ifdef W3_T + WRITE (NDST,9030) 'YES/--' +#endif + ! + ! 3.b Initializations + ! + SNL(:,1:IFRMN2-1) = 0. + ! + DS1(NSPL:IFRMN2*NTHX-1) = 0. + DS2(NSPL:IFRMN2*NTHX-1) = 0. + DS3(NSPL:IFRMN2*NTHX-1) = 0. + ! + ISPX = IFRMN2*NTHX + DS1(ISPX+NTH+1:NSPH:NTHX) = DS1(ISPX+ 1 :NSPH:NTHX) + DS1(ISPX :NSPH:NTHX) = DS1(ISPX+NTH:NSPH:NTHX) + DS2(ISPX+NTH+1:NSPH:NTHX) = DS2(ISPX+ 1 :NSPH:NTHX) + DS2(ISPX :NSPH:NTHX) = DS2(ISPX+NTH:NSPH:NTHX) + DS3(IFRMN2*NTHX:NSPH) = DS1(IFRMN2*NTHX:NSPH) + & + DS2(IFRMN2*NTHX:NSPH) + ! + ! 3.c Loop over frequencies + ! + DO IFR=IFRMN2, NFR + ! ISPX0 = (IFR-1)*NTHX IKD = JKD(IFR) -! - MC = SNSST( 1,IKD) - F3A = SNSST( 2,IKD) - F3B = SNSST( 3,IKD) - F3C = SNSST( 4,IKD) - F4A = SNSST( 5,IKD) - F4B = SNSST( 6,IKD) - F4C = F3C -! -! 2.b Loop over directions -! + ! + FC1 = - SNSST(1,IKD) + FC2 = SNSST(4,IKD) + FC3 = SNSST(3,IKD) + FC4 = SNSST(6,IKD) + ! + ! 3.d Loop over directions + ! DO ITH=1, NTH -! - ISPX = ISPX0 + ITH -! - F00 = UP(ISPX) - F31 = UP(ISPX)*F3A + UP(ISPX+1)*F3B + UP(ISPX+NTHX)*F3C - F41 = UP(ISPX)*F4A + UP(ISPX-1)*F4B + UP(ISPX-NTHX)*F4C - F32 = UP(ISPX)*F3A + UP(ISPX-1)*F3B + UP(ISPX+NTHX)*F3C - F42 = UP(ISPX)*F4A + UP(ISPX+1)*F4B + UP(ISPX-NTHX)*F4C -! - DS1(ISPX) = FPROP(IFR) * (F00**2*(F31+F41)-2.*F00*F31*F41) - DS2(ISPX) = FPROP(IFR) * (F00**2*(F32+F42)-2.*F00*F32*F42) -! - AUX11 = DT * DS1(ISPX) - AUX21 = DT * DS2(ISPX) - AUXB = CNLSFM * FILTFP(IFR) * MAX(1.E-10,UN(ISPX)) / & - MAX ( 1.E-10 , ABS(AUX11)+ABS(AUX21) ) / MC - AUX12 = AUXB * ABS(AUX11) - AUX22 = AUXB * ABS(AUX21) -! -! Expensive but more smooth limiter -! -! DA1(ISPX) = AUX12 * TANH(AUX11/MAX(1.E-10,AUX12)) -! DA2(ISPX) = AUX22 * TANH(AUX21/MAX(1.E-10,AUX22)) -! -! Crude but cheaper limiter -! - DA1(ISPX) = MAX ( -AUX12 , MIN ( AUX11 , AUX12 ) ) - DA2(ISPX) = MAX ( -AUX22 , MIN ( AUX21 , AUX22 ) ) -! - END DO -! -! ... End loop 2.b -! + ISPX = ISPX0 + ITH + SNL(ITH,IFR) = FC1 * DS3( ISPX ) & + + FC2 * ( DS3(ISPX-NTHX) + DS3(ISPX+NTHX) ) & + + FC3 * ( DS1(ISPX- 1 ) + DS2(ISPX+ 1 ) ) & + + FC4 * ( DS1(ISPX+ 1 ) + DS2(ISPX- 1 ) ) + ! END DO -! -! 2.c Complete expanded arrays -! -! ... End loop 2.a -! -! 3. Compute source term if requested ------------------------------- * -! 3.a Check for request -! - IF ( PRESENT(SNL) ) THEN + ! + ! ... End loop 3.d + ! + END DO + ! + ! ... End loop 3.c + ! #ifdef W3_T - WRITE (NDST,9030) 'YES/--' + ELSE + WRITE (NDST,9030) '---/NO' #endif -! -! 3.b Initializations -! - SNL(:,1:IFRMN2-1) = 0. -! - DS1(NSPL:IFRMN2*NTHX-1) = 0. - DS2(NSPL:IFRMN2*NTHX-1) = 0. - DS3(NSPL:IFRMN2*NTHX-1) = 0. -! - ISPX = IFRMN2*NTHX - DS1(ISPX+NTH+1:NSPH:NTHX) = DS1(ISPX+ 1 :NSPH:NTHX) - DS1(ISPX :NSPH:NTHX) = DS1(ISPX+NTH:NSPH:NTHX) - DS2(ISPX+NTH+1:NSPH:NTHX) = DS2(ISPX+ 1 :NSPH:NTHX) - DS2(ISPX :NSPH:NTHX) = DS2(ISPX+NTH:NSPH:NTHX) - DS3(IFRMN2*NTHX:NSPH) = DS1(IFRMN2*NTHX:NSPH) + & - DS2(IFRMN2*NTHX:NSPH) -! -! 3.c Loop over frequencies -! - DO IFR=IFRMN2, NFR -! - ISPX0 = (IFR-1)*NTHX - IKD = JKD(IFR) -! - FC1 = - SNSST(1,IKD) - FC2 = SNSST(4,IKD) - FC3 = SNSST(3,IKD) - FC4 = SNSST(6,IKD) -! -! 3.d Loop over directions -! - DO ITH=1, NTH - ISPX = ISPX0 + ITH - SNL(ITH,IFR) = FC1 * DS3( ISPX ) & - + FC2 * ( DS3(ISPX-NTHX) + DS3(ISPX+NTHX) ) & - + FC3 * ( DS1(ISPX- 1 ) + DS2(ISPX+ 1 ) ) & - + FC4 * ( DS1(ISPX+ 1 ) + DS2(ISPX- 1 ) ) -! - END DO -! -! ... End loop 3.d -! - END DO -! -! ... End loop 3.c -! -#ifdef W3_T - ELSE - WRITE (NDST,9030) '---/NO' -#endif - END IF -! -! 4. Compute filtered spectrum if requested ------------------------- * -! 4.a Check for request -! - IF ( PRESENT(AA) ) THEN + END IF + ! + ! 4. Compute filtered spectrum if requested ------------------------- * + ! 4.a Check for request + ! + IF ( PRESENT(AA) ) THEN #ifdef W3_T - WRITE (NDST,9040) 'YES/--' + WRITE (NDST,9040) 'YES/--' #endif -! -! 4.b Initializations -! - AA(:,1:IFRMN2-1) = A(:,1:IFRMN2-1) -! - DA1(NSPL:IFRMN2*NTHX-1) = 0. - DA2(NSPL:IFRMN2*NTHX-1) = 0. - DA3(NSPL:IFRMN2*NTHX-1) = 0. -! - ISPX = IFRMN2*NTHX - DA1(ISPX+NTH+1:NSPH:NTHX) = DA1(ISPX+ 1 :NSPH:NTHX) - DA1(ISPX :NSPH:NTHX) = DA1(ISPX+NTH:NSPH:NTHX) - DA2(ISPX+NTH+1:NSPH:NTHX) = DA2(ISPX+ 1 :NSPH:NTHX) - DA2(ISPX :NSPH:NTHX) = DA2(ISPX+NTH:NSPH:NTHX) - DA3(IFRMN2*NTHX:NSPH) = DA1(IFRMN2*NTHX:NSPH) + & - DA2(IFRMN2*NTHX:NSPH) -! -! 4.c Loop over frequencies -! - DO IFR=IFRMN2, NFR -! - ISPX0 = (IFR-1)*NTHX - IKD = JKD(IFR) -! - FC1 = - SNSST(1,IKD) - FC2 = SNSST(4,IKD) - FC3 = SNSST(3,IKD) - FC4 = SNSST(6,IKD) -! -! 4.d Loop over directions -! - DO ITH=1, NTH - ISPX = ISPX0 + ITH - AA(ITH,IFR) = MAX ( 0. , A(ITH,IFR) + & - FC1 * DA3(ISPX) & - + FC2 * ( DA3(ISPX-NTHX) + DA3(ISPX+NTHX) ) & - + FC3 * ( DA1(ISPX- 1 ) + DA2(ISPX+ 1 ) ) & - + FC4 * ( DA1(ISPX+ 1 ) + DA2(ISPX- 1 ) ) ) - END DO -! -! ... End loop 4.d -! - END DO -! -! ... End loop 4.c -! -#ifdef W3_T - ELSE - WRITE (NDST,9040) '---/NO' -#endif - END IF -! + ! + ! 4.b Initializations + ! + AA(:,1:IFRMN2-1) = A(:,1:IFRMN2-1) + ! + DA1(NSPL:IFRMN2*NTHX-1) = 0. + DA2(NSPL:IFRMN2*NTHX-1) = 0. + DA3(NSPL:IFRMN2*NTHX-1) = 0. + ! + ISPX = IFRMN2*NTHX + DA1(ISPX+NTH+1:NSPH:NTHX) = DA1(ISPX+ 1 :NSPH:NTHX) + DA1(ISPX :NSPH:NTHX) = DA1(ISPX+NTH:NSPH:NTHX) + DA2(ISPX+NTH+1:NSPH:NTHX) = DA2(ISPX+ 1 :NSPH:NTHX) + DA2(ISPX :NSPH:NTHX) = DA2(ISPX+NTH:NSPH:NTHX) + DA3(IFRMN2*NTHX:NSPH) = DA1(IFRMN2*NTHX:NSPH) + & + DA2(IFRMN2*NTHX:NSPH) + ! + ! 4.c Loop over frequencies + ! + DO IFR=IFRMN2, NFR + ! + ISPX0 = (IFR-1)*NTHX + IKD = JKD(IFR) + ! + FC1 = - SNSST(1,IKD) + FC2 = SNSST(4,IKD) + FC3 = SNSST(3,IKD) + FC4 = SNSST(6,IKD) + ! + ! 4.d Loop over directions + ! + DO ITH=1, NTH + ISPX = ISPX0 + ITH + AA(ITH,IFR) = MAX ( 0. , A(ITH,IFR) + & + FC1 * DA3(ISPX) & + + FC2 * ( DA3(ISPX-NTHX) + DA3(ISPX+NTHX) ) & + + FC3 * ( DA1(ISPX- 1 ) + DA2(ISPX+ 1 ) ) & + + FC4 * ( DA1(ISPX+ 1 ) + DA2(ISPX- 1 ) ) ) + END DO + ! + ! ... End loop 4.d + ! + END DO + ! + ! ... End loop 4.c + ! #ifdef W3_T - stop + ELSE + WRITE (NDST,9040) '---/NO' #endif - RETURN -! -! Formats -! + END IF + ! #ifdef W3_T - 9000 FORMAT (/' TEST W3SNLS: DEPTH, UABS, DT :',F9.2,F7.2,F7.2) + stop #endif -! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9010 FORMAT ( ' IFRMIN, FP :',I4,F8.4) +9000 FORMAT (/' TEST W3SNLS: DEPTH, UABS, DT :',F9.2,F7.2,F7.2) +9010 FORMAT ( ' IFRMIN, FP :',I4,F8.4) +9030 FORMAT ( ' TEST W3SNLS: SOURCE TERM REQUESTED : ',A) +9040 FORMAT ( ' TEST W3SNLS: AVERAGING REQUESTED : ',A) #endif #ifdef W3_T1 - 9011 FORMAT ( ' TEST W3SNLS: IFR, FR, C, E1, FILT :') - 9012 FORMAT (13X,I4,F10.4,2F10.2,F10.4) +9011 FORMAT ( ' TEST W3SNLS: IFR, FR, C, E1, FILT :') +9012 FORMAT (13X,I4,F10.4,2F10.2,F10.4) #endif -! -#ifdef W3_T - 9030 FORMAT ( ' TEST W3SNLS: SOURCE TERM REQUESTED : ',A) - 9040 FORMAT ( ' TEST W3SNLS: AVERAGING REQUESTED : ',A) -#endif -!/ -!/ Embedded subroutines -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE EXPAND ( PSPC, SPEC ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Jul-2008 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! Expand spectrum to simplify indirect addressing. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! PSPC R.A. O Expanded spectrum. -! SPEC R.A. O Expanded spectrum. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ Embedded subroutines + !/ + CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE EXPAND ( PSPC, SPEC ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Jul-2008 | + !/ +-----------------------------------+ + !/ + ! 1. Purpose : + ! + ! Expand spectrum to simplify indirect addressing. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! PSPC R.A. O Expanded spectrum. + ! SPEC R.A. O Expanded spectrum. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / IMPLICIT NONE -!/ -!/ Parameter list -!/ + !/ + !/ Parameter list + !/ REAL, INTENT(OUT) :: PSPC(0:NTH+1,0:NFR+2), & - SPEC(0:NTH+1,0:NFR+2) -!/ -!/ Local parameters -!/ + SPEC(0:NTH+1,0:NFR+2) + !/ + !/ Local parameters + !/ INTEGER :: IFR, ITH -!/ -!/ ------------------------------------------------------------------- / -! - SPEC(:,0) = 0. -! + !/ + !/ ------------------------------------------------------------------- / + ! + SPEC(:,0) = 0. + ! SPEC(1:NTH,1:NFR) = A SPEC(1:NTH,NFR+1) = SPEC(1:NTH,NFR) * FACHFA SPEC(1:NTH,NFR+2) = SPEC(1:NTH,NFR+1) * FACHFA -! + ! SPEC(NTH+1,1:NFR+2) = SPEC( 1 ,1:NFR+2) SPEC( 0 ,1:NFR+2) = SPEC(NTH,1:NFR+2) -! + ! DO IFR=1, NFR+2 PSPC(:,IFR) = SPEC(:,IFR) / XWN(IFR) - END DO -! + END DO + ! RETURN -!/ -!/ End of EXPAND ----------------------------------------------------- / -!/ - END SUBROUTINE EXPAND -!/ -!/ End of W3SNLS ----------------------------------------------------- / -!/ - END SUBROUTINE W3SNLS -!/ ------------------------------------------------------------------- / - SUBROUTINE INSNLS -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 04-Aug-2008 | -!/ +-----------------------------------+ -!/ -!/ 04-Aug-2008 : Origination. ( version 3.13 ) -!/ -! 1. Purpose : -! -! Initializations for the Snl / filter source term for high -! frequencies. -! -! 2. Method : -! -! Precompute weight functions and store in array. -! -! 3. Parameters : -! -! No parameter list. -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WAVNU2 Subr. W3DISPMD Solve dispersion relation. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Process model definition file. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check a34, b4 and b5 against MAXAB to assure that the values -! are consistent with a reduced 5-point stencil for unresolved -! quadruplets. a34 is checked in ww3_grid, b3 and b4 are not. -! -! 7. Remarks : -! -! - Small quadruplet compared to grid size reduces interactions -! so that distribution of results is purely local. This results -! in a much simpler model initialization than for the general -! MDIA. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3ODATMD, ONLY: NDST, NDSE - USE W3GDATMD, NFR => NK, A34 => CNLSA -! - USE W3DISPMD, ONLY: WAVNU2 - USE W3SERVMD, ONLY: EXTCDE + !/ + !/ End of EXPAND ----------------------------------------------------- / + !/ + END SUBROUTINE EXPAND + !/ + !/ End of W3SNLS ----------------------------------------------------- / + !/ + END SUBROUTINE W3SNLS + !/ ------------------------------------------------------------------- / + SUBROUTINE INSNLS + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 04-Aug-2008 | + !/ +-----------------------------------+ + !/ + !/ 04-Aug-2008 : Origination. ( version 3.13 ) + !/ + ! 1. Purpose : + ! + ! Initializations for the Snl / filter source term for high + ! frequencies. + ! + ! 2. Method : + ! + ! Precompute weight functions and store in array. + ! + ! 3. Parameters : + ! + ! No parameter list. + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WAVNU2 Subr. W3DISPMD Solve dispersion relation. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Process model definition file. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check a34, b4 and b5 against MAXAB to assure that the values + ! are consistent with a reduced 5-point stencil for unresolved + ! quadruplets. a34 is checked in ww3_grid, b3 and b4 are not. + ! + ! 7. Remarks : + ! + ! - Small quadruplet compared to grid size reduces interactions + ! so that distribution of results is purely local. This results + ! in a much simpler model initialization than for the general + ! MDIA. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3ODATMD, ONLY: NDST, NDSE + USE W3GDATMD, NFR => NK, A34 => CNLSA + ! + USE W3DISPMD, ONLY: WAVNU2 + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IKD, IERR + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IKD, IERR #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: DEPTH, SITMAX, OFF, S0, WN0, CG0, & - S3, WN3, CG3, S4, WN4, CG4, WN12, & - DT3, DT4, B3, B4 -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: DEPTH, SITMAX, OFF, S0, WN0, CG0, & + S3, WN3, CG3, S4, WN4, CG4, WN12, & + DT3, DT4, B3, B4 + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INSNLS') + CALL STRACE (IENT, 'INSNLS') #endif -! -! 1. Initializations ------------------------------------------------ * -! 1.a Set up relative depths -! - DEPTH = 1. - SITMIN = SQRT ( KDMIN * TANH(KDMIN) ) - SITMAX = SQRT ( KDMAX * TANH(KDMAX) ) - XSIT = (SITMAX/SITMIN)**(1./REAL(NKD-1)) -! + ! + ! 1. Initializations ------------------------------------------------ * + ! 1.a Set up relative depths + ! + DEPTH = 1. + SITMIN = SQRT ( KDMIN * TANH(KDMIN) ) + SITMAX = SQRT ( KDMAX * TANH(KDMAX) ) + XSIT = (SITMAX/SITMIN)**(1./REAL(NKD-1)) + ! #ifdef W3_T - WRITE (NDST,9010) NKD, KDMIN, KDMAX, XSIT + WRITE (NDST,9010) NKD, KDMIN, KDMAX, XSIT #endif -! -! 1.b Set up quadruplet -! - OFF = (XFR-1.) * A34 -! -! 1.c Set up storage -! - NTHX = NTH + 2 - NFRX = NFR + 2 - NSPL = - NTHX - NSPH = NFRX*NTHX - 1 -! - ALLOCATE ( MPARS(IGRID)%SNLPS%SNSST(6,NKD) ) - SNSST => MPARS(IGRID)%SNLPS%SNSST -! -! 2. Building quadruplet data base ---------------------------------- * -! For quadruplet and interaction strength evaluation -! - S0 = SITMIN * SQRT ( GRAV / DEPTH ) / XSIT -! -! 2.a Loop over relative depths -! - DO IKD=1, NKD -! -! 2.b Base quadruplet set up -! - S0 = S0 * XSIT - S3 = ( 1. + OFF ) * S0 - S4 = ( 1. - OFF ) * S0 -! - CALL WAVNU2 ( S0, DEPTH, WN0, CG0, 1.E-6, 25, IERR) - CALL WAVNU2 ( S3, DEPTH, WN3, CG3, 1.E-6, 25, IERR) - CALL WAVNU2 ( S4, DEPTH, WN4, CG4, 1.E-6, 25, IERR) -! + ! + ! 1.b Set up quadruplet + ! + OFF = (XFR-1.) * A34 + ! + ! 1.c Set up storage + ! + NTHX = NTH + 2 + NFRX = NFR + 2 + NSPL = - NTHX + NSPH = NFRX*NTHX - 1 + ! + ALLOCATE ( MPARS(IGRID)%SNLPS%SNSST(6,NKD) ) + SNSST => MPARS(IGRID)%SNLPS%SNSST + ! + ! 2. Building quadruplet data base ---------------------------------- * + ! For quadruplet and interaction strength evaluation + ! + S0 = SITMIN * SQRT ( GRAV / DEPTH ) / XSIT + ! + ! 2.a Loop over relative depths + ! + DO IKD=1, NKD + ! + ! 2.b Base quadruplet set up + ! + S0 = S0 * XSIT + S3 = ( 1. + OFF ) * S0 + S4 = ( 1. - OFF ) * S0 + ! + CALL WAVNU2 ( S0, DEPTH, WN0, CG0, 1.E-6, 25, IERR) + CALL WAVNU2 ( S3, DEPTH, WN3, CG3, 1.E-6, 25, IERR) + CALL WAVNU2 ( S4, DEPTH, WN4, CG4, 1.E-6, 25, IERR) + ! #ifdef W3_T - WRITE (NDST,9020) IKD, WN0*DEPTH, S0*TPIINV, DEPTH + WRITE (NDST,9020) IKD, WN0*DEPTH, S0*TPIINV, DEPTH #endif -! -! 2.c Offset angles -! - WN12 = 2. * WN0 - DT3 = ACOS( (WN3**2+WN12**2-WN4**2) / (2.*WN12*WN3) ) - DT4 = ACOS( (WN4**2+WN12**2-WN3**2) / (2.*WN12*WN4) ) -! - B3 = DT3 / DTH - B4 = DT4 / DTH -! + ! + ! 2.c Offset angles + ! + WN12 = 2. * WN0 + DT3 = ACOS( (WN3**2+WN12**2-WN4**2) / (2.*WN12*WN3) ) + DT4 = ACOS( (WN4**2+WN12**2-WN3**2) / (2.*WN12*WN4) ) + ! + B3 = DT3 / DTH + B4 = DT4 / DTH + ! #ifdef W3_T - WRITE (NDST,9021) A34, B3, B4, DT3*RADE, DT4*RADE + WRITE (NDST,9021) A34, B3, B4, DT3*RADE, DT4*RADE #endif -! - IF ( A34.GT.ABMAX .OR. B3.GT.ABMAX .OR. B4.GT.ABMAX .OR. & - A34.LT.0. .OR. B3.LT.0. .OR. B4.LT.0. ) GOTO 801 -! -! 2.d Store weights -! - SNSST( 1,IKD) = 2.*A34 + B3 + B4 - SNSST( 2,IKD) = 1. - A34 - B3 - SNSST( 3,IKD) = B3 - SNSST( 4,IKD) = A34 - SNSST( 5,IKD) = 1. - A34 - B4 - SNSST( 6,IKD) = B4 -! -! ... End loop 2.a -! - END DO -! - RETURN -! -! Error escape locations -! - 801 CONTINUE - WRITE (NDSE,1001) A34, B3, B4 - CALL EXTCDE (1001) -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNLS :'/ & - ' PARAMETER FORCED OUT OF RANGE '/ & - ' A34, B3, B4 :', 3F10.4/) -! + ! + IF ( A34.GT.ABMAX .OR. B3.GT.ABMAX .OR. B4.GT.ABMAX .OR. & + A34.LT.0. .OR. B3.LT.0. .OR. B4.LT.0. ) GOTO 801 + ! + ! 2.d Store weights + ! + SNSST( 1,IKD) = 2.*A34 + B3 + B4 + SNSST( 2,IKD) = 1. - A34 - B3 + SNSST( 3,IKD) = B3 + SNSST( 4,IKD) = A34 + SNSST( 5,IKD) = 1. - A34 - B4 + SNSST( 6,IKD) = B4 + ! + ! ... End loop 2.a + ! + END DO + ! + RETURN + ! + ! Error escape locations + ! +801 CONTINUE + WRITE (NDSE,1001) A34, B3, B4 + CALL EXTCDE (1001) + ! + ! Formats + ! +1001 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNLS :'/ & + ' PARAMETER FORCED OUT OF RANGE '/ & + ' A34, B3, B4 :', 3F10.4/) + ! #ifdef W3_T - 9010 FORMAT (/' TEST INSNLS: NKD, KDMIN/MAX/X :',I5,3F10.4) - 9020 FORMAT ( ' IKD, KD, F, D :',I5,3F10.4) - 9021 FORMAT ( ' A34, B3,B4, TH3/4:',3F7.3,2F6.2) +9010 FORMAT (/' TEST INSNLS: NKD, KDMIN/MAX/X :',I5,3F10.4) +9020 FORMAT ( ' IKD, KD, F, D :',I5,3F10.4) +9021 FORMAT ( ' A34, B3,B4, TH3/4:',3F7.3,2F6.2) #endif -!/ -! /End of INSNLS ------------------------------------------------------/ -!/ - END SUBROUTINE INSNLS -!/ -!/ End of module W3SNLSMD -------------------------------------------- / -!/ - END MODULE W3SNLSMD + !/ + ! /End of INSNLS ------------------------------------------------------/ + !/ + END SUBROUTINE INSNLS + !/ + !/ End of module W3SNLSMD -------------------------------------------- / + !/ +END MODULE W3SNLSMD diff --git a/model/src/w3src0md.F90 b/model/src/w3src0md.F90 index 8075c9eda..507c8feaf 100644 --- a/model/src/w3src0md.F90 +++ b/model/src/w3src0md.F90 @@ -1,235 +1,235 @@ !> @file !> @brief Contains MODULE W3SRC0MD. -!> +!> !> @author H. L. Tolman @date 29-May-2009 -!> +!> #include "w3macros.h" !> !> @brief Mean wave parameter computation for case without input and !> dissipation. -!> -!> @author H. L. Tolman @date 29-May-2009 -!> -!/ ------------------------------------------------------------------- / - MODULE W3SRC0MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 05-Jul-2006 : Origination. ( version 3.09 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Mean wave parameter computation for case without input and -! dissipation. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SPR0 Subr. Public Mean parameters from spectrum. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output, see subroutines. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate mean wave parameters. !> -!> @param[in] A Action as a function of direction and wavenumber. -!> @param[in] CG Group velocities. -!> @param[in] WN Wavenumbers. -!> @param[out] EMEAN Mean wave energy. -!> @param[out] FMEAN Mean wave frequency. -!> @param[out] WNMEAN Mean wavenumber. -!> @param[out] AMAX Maximum action density in spectrum. +!> @author H. L. Tolman @date 29-May-2009 !> -!> @author H. L. Tolman @date 05-Jul-2006 -!> - SUBROUTINE W3SPR0 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 05-Jul-2006 | -!/ +-----------------------------------+ -!/ -!/ 05-Jul-2006 : Origination. ( version 3.09 ) -!/ -! 1. Purpose : -! -! Calculate mean wave parameters. -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action as a function of direction and -! wavenumber. -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! EMEAN Real O Mean wave energy. -! FMEAN Real O Mean wave frequency. -! WNMEAN Real O Mean wavenumber. -! AMAX Real O Maximum action density in spectrum. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! !/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, SIG, DDEN, FTE, FTF, FTWN +MODULE W3SRC0MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 05-Jul-2006 : Origination. ( version 3.09 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Mean wave parameter computation for case without input and + ! dissipation. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SPR0 Subr. Public Mean parameters from spectrum. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output, see subroutines. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate mean wave parameters. + !> + !> @param[in] A Action as a function of direction and wavenumber. + !> @param[in] CG Group velocities. + !> @param[in] WN Wavenumbers. + !> @param[out] EMEAN Mean wave energy. + !> @param[out] FMEAN Mean wave frequency. + !> @param[out] WNMEAN Mean wavenumber. + !> @param[out] AMAX Maximum action density in spectrum. + !> + !> @author H. L. Tolman @date 05-Jul-2006 + !> + SUBROUTINE W3SPR0 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 05-Jul-2006 | + !/ +-----------------------------------+ + !/ + !/ 05-Jul-2006 : Origination. ( version 3.09 ) + !/ + ! 1. Purpose : + ! + ! Calculate mean wave parameters. + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action as a function of direction and + ! wavenumber. + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! EMEAN Real O Mean wave energy. + ! FMEAN Real O Mean wave frequency. + ! WNMEAN Real O Mean wavenumber. + ! AMAX Real O Maximum action density in spectrum. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, SIG, DDEN, FTE, FTF, FTWN #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK) - REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IK, ITH + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK) + REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IK, ITH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: EB(NK), EBAND -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: EB(NK), EBAND + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SPR0') + CALL STRACE (IENT, 'W3SPR0') #endif -! - EMEAN = 0. - FMEAN = 0. - WNMEAN = 0. - AMAX = 0. -! -! 1. Integral over directions -! - DO IK=1, NK - EB(IK) = 0. - DO ITH=1, NTH - EB(IK) = EB(IK) + A(ITH,IK) - AMAX = MAX ( AMAX , A(ITH,IK) ) - END DO - END DO -! -! 2. Integrate over directions -! - DO IK=1, NK - EB(IK) = EB(IK) * DDEN(IK) / CG(IK) - EMEAN = EMEAN + EB(IK) - FMEAN = FMEAN + EB(IK) / SIG(IK) - WNMEAN = WNMEAN + EB(IK) / SQRT(WN(IK)) - END DO -! -! 3. Add tail beyond discrete spectrum -! ( DTH * SIG absorbed in FTxx ) -! - EBAND = EB(NK) / DDEN(NK) - EMEAN = EMEAN + EBAND * FTE - FMEAN = FMEAN + EBAND * FTF - WNMEAN = WNMEAN + EBAND * FTWN -! -! 4. Final processing -! - FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) - WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 -! + ! + EMEAN = 0. + FMEAN = 0. + WNMEAN = 0. + AMAX = 0. + ! + ! 1. Integral over directions + ! + DO IK=1, NK + EB(IK) = 0. + DO ITH=1, NTH + EB(IK) = EB(IK) + A(ITH,IK) + AMAX = MAX ( AMAX , A(ITH,IK) ) + END DO + END DO + ! + ! 2. Integrate over directions + ! + DO IK=1, NK + EB(IK) = EB(IK) * DDEN(IK) / CG(IK) + EMEAN = EMEAN + EB(IK) + FMEAN = FMEAN + EB(IK) / SIG(IK) + WNMEAN = WNMEAN + EB(IK) / SQRT(WN(IK)) + END DO + ! + ! 3. Add tail beyond discrete spectrum + ! ( DTH * SIG absorbed in FTxx ) + ! + EBAND = EB(NK) / DDEN(NK) + EMEAN = EMEAN + EBAND * FTE + FMEAN = FMEAN + EBAND * FTF + WNMEAN = WNMEAN + EBAND * FTWN + ! + ! 4. Final processing + ! + FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) + WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 + ! #ifdef W3_T - WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN + WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SPR0 : E,F,WN MEAN ',3E10.3) +9000 FORMAT (' TEST W3SPR0 : E,F,WN MEAN ',3E10.3) #endif -!/ -!/ End of W3SPR0 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SPR0 -!/ -!/ End of module W3SRC0MD -------------------------------------------- / -!/ - END MODULE W3SRC0MD + !/ + !/ End of W3SPR0 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SPR0 + !/ + !/ End of module W3SRC0MD -------------------------------------------- / + !/ +END MODULE W3SRC0MD diff --git a/model/src/w3src1md.F90 b/model/src/w3src1md.F90 index c67a65aa2..a09e5806c 100644 --- a/model/src/w3src1md.F90 +++ b/model/src/w3src1md.F90 @@ -1,596 +1,590 @@ !> @file !> @brief Contains MODULE W3SRC1MD. -!> +!> !> @author H. L. Tolman @date 29-May-2009 -!> +!> #include "w3macros.h" !> !> @brief Bundle WAM cycle 3 input and dissipation source terms with !> their defining parameters. -!> -!> @author H. L. Tolman @date 29-May-2009 !> -!/ ------------------------------------------------------------------- / - MODULE W3SRC1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 06-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 06-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 23-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Bundle WAM cycle 3 input and dissipation source terms with -! their defining parameters. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SPR1 Subr. Public Mean parameters from spectrum. -! W3SIN1 Subr. Public Input source term. -! W3SDS1 Subr. Public Dissipation source term. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) -! PRT2DS Subr. W3ARRYMD Print plot of spectra. ( !/T0 ) -! OUTMAT Subr. W3WRRYMD Print out 2D matrix. ( !/T1 ) -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T(n) Test output, see subroutines. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief -!> -!> @param[in] A Action as a function of direction and wavenumber. -!> @param[in] CG Group velocities. -!> @param[in] WN Wavenumber. -!> @param[out] EMEAN Mean wave energy. -!> @param[out] FMEAN Mean wave frequency. -!> @param[out] WNMEAN mean wavenumber. -!> @param[out] AMAX Maximum action density in spectrum. +!> @author H. L. Tolman @date 29-May-2009 !> -!> @author H. L. Tolman @date 23-Dec-2004 -!> - SUBROUTINE W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 06-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 06-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 23-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Calculate mean wave parameters for the use in the source term -! routines. (WAM-3) -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action as a function of direction and -! wavenumber. -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! EMEAN Real O Mean wave energy. -! FMEAN Real O Mean wave frequency. -! WNMEAN Real O Mean wavenumber. -! AMAX Real O Maximum action density in spectrum. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! !/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, SIG, DDEN, FTE, FTF, FTWN +MODULE W3SRC1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 06-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 06-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 23-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Bundle WAM cycle 3 input and dissipation source terms with + ! their defining parameters. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SPR1 Subr. Public Mean parameters from spectrum. + ! W3SIN1 Subr. Public Input source term. + ! W3SDS1 Subr. Public Dissipation source term. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) + ! PRT2DS Subr. W3ARRYMD Print plot of spectra. ( !/T0 ) + ! OUTMAT Subr. W3WRRYMD Print out 2D matrix. ( !/T1 ) + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T(n) Test output, see subroutines. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief + !> + !> @param[in] A Action as a function of direction and wavenumber. + !> @param[in] CG Group velocities. + !> @param[in] WN Wavenumber. + !> @param[out] EMEAN Mean wave energy. + !> @param[out] FMEAN Mean wave frequency. + !> @param[out] WNMEAN mean wavenumber. + !> @param[out] AMAX Maximum action density in spectrum. + !> + !> @author H. L. Tolman @date 23-Dec-2004 + !> + SUBROUTINE W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 06-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 06-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 23-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Calculate mean wave parameters for the use in the source term + ! routines. (WAM-3) + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action as a function of direction and + ! wavenumber. + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! EMEAN Real O Mean wave energy. + ! FMEAN Real O Mean wave frequency. + ! WNMEAN Real O Mean wavenumber. + ! AMAX Real O Maximum action density in spectrum. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, SIG, DDEN, FTE, FTF, FTWN #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK) - REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IK, ITH + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK) + REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IK, ITH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: EB(NK), EBAND -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: EB(NK), EBAND + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SPR1') -#endif -! - EMEAN = 0. - FMEAN = 0. - WNMEAN = 0. - AMAX = 0. -! -! 1. Integral over directions -! - DO IK=1, NK - EB(IK) = 0. - DO ITH=1, NTH - EB(IK) = EB(IK) + A(ITH,IK) - AMAX = MAX ( AMAX , A(ITH,IK) ) - END DO - END DO -! -! 2. Integrate over directions -! - DO IK=1, NK - EB(IK) = EB(IK) * DDEN(IK) / CG(IK) - EMEAN = EMEAN + EB(IK) - FMEAN = FMEAN + EB(IK) / SIG(IK) - WNMEAN = WNMEAN + EB(IK) / SQRT(WN(IK)) - END DO -! -! 3. Add tail beyond discrete spectrum -! ( DTH * SIG absorbed in FTxx ) -! - EBAND = EB(NK) / DDEN(NK) - EMEAN = EMEAN + EBAND * FTE - FMEAN = FMEAN + EBAND * FTF - WNMEAN = WNMEAN + EBAND * FTWN -! -! 4. Final processing -! - FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) - WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 -! + CALL STRACE (IENT, 'W3SPR1') +#endif + ! + EMEAN = 0. + FMEAN = 0. + WNMEAN = 0. + AMAX = 0. + ! + ! 1. Integral over directions + ! + DO IK=1, NK + EB(IK) = 0. + DO ITH=1, NTH + EB(IK) = EB(IK) + A(ITH,IK) + AMAX = MAX ( AMAX , A(ITH,IK) ) + END DO + END DO + ! + ! 2. Integrate over directions + ! + DO IK=1, NK + EB(IK) = EB(IK) * DDEN(IK) / CG(IK) + EMEAN = EMEAN + EB(IK) + FMEAN = FMEAN + EB(IK) / SIG(IK) + WNMEAN = WNMEAN + EB(IK) / SQRT(WN(IK)) + END DO + ! + ! 3. Add tail beyond discrete spectrum + ! ( DTH * SIG absorbed in FTxx ) + ! + EBAND = EB(NK) / DDEN(NK) + EMEAN = EMEAN + EBAND * FTE + FMEAN = FMEAN + EBAND * FTF + WNMEAN = WNMEAN + EBAND * FTWN + ! + ! 4. Final processing + ! + FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) + WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 + ! #ifdef W3_T - WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN + WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SPR1 : E,F,WN MEAN ',3E10.3) -#endif -!/ -!/ End of W3SPR1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SPR1 -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate diagonal of input source (actual source term put -!> together in W3SRCE). -!> -!> @param[in] A Action density spectrum (1-D). -!> @param[in] K Wavenumber for entire spectrum. -!> @param[in] USTAR Friction velocity. -!> @param[in] USDIR Direction of USTAR. -!> @param[out] S Source term (1-D version). -!> @param[out] D Diagonal term of derivative. -!> -!> @author H. L. Tolman @date 23-Dec-2004 -!> - SUBROUTINE W3SIN1 (A, K, USTAR, USDIR, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 05-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 08-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 23-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Calculate diagonal of input source (actual source term put -! together in W3SRCE). -! -! 2. Method : -! -! WAM-3 : Snyder et al. (1981), Komen et al. (1984). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D). -! K R.A. I Wavenumber for entire spectrum. *) -! USTAR Real I Friction velocity. -! USDIR Real I Direction of USTAR. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative. *) -! ---------------------------------------------------------------- -! *) Stored as 1-D array with dimension NTH*NK -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! PRT2DS Subr. W3SRRYMD Print plot of spectrum. -! OUTMAT Subr. W3SRRYMD Print out matrix. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +9000 FORMAT (' TEST W3SPR1 : E,F,WN MEAN ',3E10.3) +#endif + !/ + !/ End of W3SPR1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SPR1 + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate diagonal of input source (actual source term put + !> together in W3SRCE). + !> + !> @param[in] A Action density spectrum (1-D). + !> @param[in] K Wavenumber for entire spectrum. + !> @param[in] USTAR Friction velocity. + !> @param[in] USDIR Direction of USTAR. + !> @param[out] S Source term (1-D version). + !> @param[out] D Diagonal term of derivative. + !> + !> @author H. L. Tolman @date 23-Dec-2004 + !> + SUBROUTINE W3SIN1 (A, K, USTAR, USDIR, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 05-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 08-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 23-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Calculate diagonal of input source (actual source term put + ! together in W3SRCE). + ! + ! 2. Method : + ! + ! WAM-3 : Snyder et al. (1981), Komen et al. (1984). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D). + ! K R.A. I Wavenumber for entire spectrum. *) + ! USTAR Real I Friction velocity. + ! USDIR Real I Direction of USTAR. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative. *) + ! ---------------------------------------------------------------- + ! *) Stored as 1-D array with dimension NTH*NK + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! PRT2DS Subr. W3SRRYMD Print plot of spectrum. + ! OUTMAT Subr. W3SRRYMD Print out matrix. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_T - USE CONSTANTS + USE CONSTANTS #endif - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SIG2, ESIN, ECOS, SINC1 + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SIG2, ESIN, ECOS, SINC1 #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NSPEC), K(NSPEC), USTAR, USDIR - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS + USE W3ARRYMD, ONLY: OUTMAT +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NSPEC), K(NSPEC), USTAR, USDIR + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T0 - INTEGER :: IK, ITH + INTEGER :: IK, ITH #endif - REAL :: COSU, SINU + REAL :: COSU, SINU #ifdef W3_T0 - REAL :: DOUT(NK,NTH) + REAL :: DOUT(NK,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIN1') + CALL STRACE (IENT, 'W3SIN1') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) SINC1, USTAR, USDIR*RADE -#endif -! -! 1. Preparations -! - COSU = COS(USDIR) - SINU = SIN(USDIR) -! -! 2. Diagonal -! - DO IS=1, NSPEC - D(IS) = SINC1 * SIG2(IS) * MAX ( 0. , & - ( USTAR * (ECOS(IS)*COSU+ESIN(IS)*SINU) & - * K(IS)/SIG2(IS) - 0.035714) ) - END DO -! - S = D * A -! -! ... Test output of arrays -! + WRITE (NDST,9000) SINC1, USTAR, USDIR*RADE +#endif + ! + ! 1. Preparations + ! + COSU = COS(USDIR) + SINU = SIN(USDIR) + ! + ! 2. Diagonal + ! + DO IS=1, NSPEC + D(IS) = SINC1 * SIG2(IS) * MAX ( 0. , & + ( USTAR * (ECOS(IS)*COSU+ESIN(IS)*SINU) & + * K(IS)/SIG2(IS) - 0.035714) ) + END DO + ! + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO -#endif -! -#ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') -#endif -! + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') +#endif + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SIN1 : COMMON FACT.: ',3E10.3) -#endif -!/ -!/ End of W3SIN1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SIN1 -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate whitecapping source term and diagonal term of derivative. -!> -!> @param[in] A Action density spectrum (1-D). -!> @param[in] K Wavenumber for entire spectrum. -!> @param[in] EMEAN Mean wave energy. -!> @param[in] FMEAN Mean wave frequency. -!> @param[in] WNMEAN Mean wavenumber. -!> @param[out] S Source term (1-D version). -!> @param[out] D Diagonal term of derivative. -!> -!> @author H. L. Tolman @date 23-Dec-2004 -!> - SUBROUTINE W3SDS1 (A, K, EMEAN, FMEAN, WNMEAN, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 05-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 08-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 23-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Calculate whitecapping source term and diagonal term of derivative. -! -! 2. Method : -! -! WAM-3 -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D). -! K R.A. I Wavenumber for entire spectrum. *) -! EMEAN Real I Mean wave energy. -! FMEAN Real I Mean wave frequency. -! WNMEAN Real I Mean wavenumber. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative. *) -! ---------------------------------------------------------------- -! *) Stored in 1-D array with dimension NTH*NK -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! PRT2DS Subr. W3SRRYMD Print plot of spectrum. -! OUTMAT Subr. W3SRRYMD Print out matrix. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SDSC1 +9000 FORMAT (' TEST W3SIN1 : COMMON FACT.: ',3E10.3) +#endif + !/ + !/ End of W3SIN1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SIN1 + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate whitecapping source term and diagonal term of derivative. + !> + !> @param[in] A Action density spectrum (1-D). + !> @param[in] K Wavenumber for entire spectrum. + !> @param[in] EMEAN Mean wave energy. + !> @param[in] FMEAN Mean wave frequency. + !> @param[in] WNMEAN Mean wavenumber. + !> @param[out] S Source term (1-D version). + !> @param[out] D Diagonal term of derivative. + !> + !> @author H. L. Tolman @date 23-Dec-2004 + !> + SUBROUTINE W3SDS1 (A, K, EMEAN, FMEAN, WNMEAN, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 05-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 08-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 23-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Calculate whitecapping source term and diagonal term of derivative. + ! + ! 2. Method : + ! + ! WAM-3 + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D). + ! K R.A. I Wavenumber for entire spectrum. *) + ! EMEAN Real I Mean wave energy. + ! FMEAN Real I Mean wave frequency. + ! WNMEAN Real I Mean wavenumber. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative. *) + ! ---------------------------------------------------------------- + ! *) Stored in 1-D array with dimension NTH*NK + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! PRT2DS Subr. W3SRRYMD Print plot of spectrum. + ! OUTMAT Subr. W3SRRYMD Print out matrix. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SDSC1 #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NSPEC), K(NSPEC), & - EMEAN, FMEAN, WNMEAN - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS + USE W3ARRYMD, ONLY: OUTMAT +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NSPEC), K(NSPEC), & + EMEAN, FMEAN, WNMEAN + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T0 - INTEGER :: IK, ITH + INTEGER :: IK, ITH #endif - REAL :: FACTOR + REAL :: FACTOR #ifdef W3_T0 - REAL :: DOUT(NK,NTH) + REAL :: DOUT(NK,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SDS1') + CALL STRACE (IENT, 'W3SDS1') #endif -! -! 1. Common factor -! - FACTOR = SDSC1 * FMEAN * WNMEAN**3 * EMEAN**2 -! + ! + ! 1. Common factor + ! + FACTOR = SDSC1 * FMEAN * WNMEAN**3 * EMEAN**2 + ! #ifdef W3_T - WRITE (NDST,9000) SDSC1, FMEAN, WNMEAN, EMEAN, FACTOR -#endif -! -! 3. Source term -! - D = FACTOR * K - S = D * A -! -! ... Test output of arrays -! -#ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO -#endif -! + WRITE (NDST,9000) SDSC1, FMEAN, WNMEAN, EMEAN, FACTOR +#endif + ! + ! 3. Source term + ! + D = FACTOR * K + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') -#endif -! + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') +#endif + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SDS1 : COMMON FACT.: ',5E10.3) -#endif -!/ -!/ End of W3SDS1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SDS1 -!/ -!/ End of module W3SRC1MD -------------------------------------------- / -!/ - END MODULE W3SRC1MD +9000 FORMAT (' TEST W3SDS1 : COMMON FACT.: ',5E10.3) +#endif + !/ + !/ End of W3SDS1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SDS1 + !/ + !/ End of module W3SRC1MD -------------------------------------------- / + !/ +END MODULE W3SRC1MD diff --git a/model/src/w3src2md.F90 b/model/src/w3src2md.F90 index e8a182d76..37923a129 100644 --- a/model/src/w3src2md.F90 +++ b/model/src/w3src2md.F90 @@ -1,1243 +1,1232 @@ !> @file !> @brief Contains MODULE W3SRC2MD. -!> +!> !> @author H. L. Tolman @date 29-May-2009 -!> +!> #include "w3macros.h" !> !> @brief Tolman and Chalikov (1996) input and dissipation source terms. -!> +!> !> @details Bundled with interpolation tables. !> !> @author H. L. Tolman @date 29-May-2009 !> !/ ------------------------------------------------------------------- / - MODULE W3SRC2MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 21-Feb-2004 : Multiple model version. ( version 3.06 ) -!/ 03-Jul-2006 : Extract stress computation. ( version 3.09 ) -!/ 13-Apr-2007 : EMEAN in W3SPR2 par list. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Tolman and Chalikov (1996) input and dissipation source terms. -! Bundled with interpolation tables. -! -! 2. Variables and types : -! -! Interpolation tables : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NRSIGA I.P. Public Array dimension (SIGA). -! NRDRAG I.P. Public Array dimension (drag coefficient). -! SIGAMX R.P. Public Maximum nondiensional frequency. -! DRAGMX R.P. Public Maximum drag coefficient. -! DSIGA Real Public Table increment. -! DDRAG Real Public Id. -! BETATB R.A. Public Interpolation table. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SPR2 Subr. Public Mean parameters from spectrum. -! W3SIN2 Subr. Public Input source term. -! W3SDS2 Subr. Public Dissipation source term. -! INPTAB Subr. Public Interpolation table for wind-wave -! interaction parameter. -! W3BETA R.F. INPTAB Id. function. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) -! PRT2DS Subr. W3ARRYMD Print plot of spectra. ( !/T0 ) -! OUTMAT Subr. W3WRRYMD Print out 2D matrix. ( !/T1 ) -! ... Data W3DISPMD Interpolation tables to solve -! dispersion relation. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T(n) Test output, see subroutines. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Interpolation table -!/ - INTEGER, PARAMETER, PRIVATE :: NRSIGA = 400 - INTEGER, PARAMETER, PRIVATE :: NRDRAG = 20 - REAL, PARAMETER, PRIVATE :: SIGAMX = 40. - REAL, PARAMETER, PRIVATE :: DRAGMX = 1.E-2 -! - REAL, PRIVATE :: DSIGA, DDRAG, & - BETATB(-NRSIGA:NRSIGA+1,NRDRAG+1) -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate mean wave parameters for the use in the source term -!> routines (Tolman and Chalikov). -!> -!> @param[in] A Action density spectrum. -!> @param[in] CG Group velocities. -!> @param[in] WN Wavenumbers. -!> @param[in] DEPTH Water depth. -!> @param[in] FPI Peak input frequency. -!> @param[in] U Wind speed. -!> @param[in] USTAR Friction velocity. -!> @param[out] EMEAN Total energy (variance). -!> @param[out] FMEAN Mean frequency. -!> @param[out] WNMEAN Mean wavenumber. -!> @param[out] AMAX Maximum of action spectrum. -!> @param[out] ALFA Phillips' constant. -!> @param[out] FP Peak frequency. -!> -!> @author H. L. Tolman -!> @author D. Chalikov -!> @date 13-Apr-2007 -!> - SUBROUTINE W3SPR2 (A, CG, WN, DEPTH, FPI, U, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALFA, FP ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | D.Chalikov | -!/ | FORTRAN 90 | -!/ | Last update : 13-Apr-2007 | -!/ +-----------------------------------+ -!/ -!/ 06-Dec-1996 : Final version 1.18 / FORTRAN 77 version. -!/ 16-Nov-1999 : Add itteration to section 5. for removal of W3APR2. -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 21-Dec-2004 : Multiple model version. ( version 3.06 ) -!/ 03-Jul-2006 : Extract stress computation. ( version 3.09 ) -!/ 13-Apr-2007 : EMEAN in parameter list. ( version 3.11 ) -! -! 1. Purpose : -! -! Calculate mean wave parameters for the use in the source term -! routines. (Tolman and Chalikov) -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum. -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! DEPTH Real I Water depth. -! FPI Real I Peak input frequency. -! U Real I Wind speed. -! USTAR Real I Friction velocity. -! EMEAN Real O Total energy (variance). -! FMEAN Real O Mean frequency. -! WNMEAN Real O Mean wavenumber. -! AMAX Real O Maximum of action spectrum. -! ALFA R.A. O Phillips' constant. -! FP Real O Peak frequency. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, DTH, SIG, DDEN, FTE, FTF, FTWN, & - NITTIN, ZWIND, CINXSI +MODULE W3SRC2MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 21-Feb-2004 : Multiple model version. ( version 3.06 ) + !/ 03-Jul-2006 : Extract stress computation. ( version 3.09 ) + !/ 13-Apr-2007 : EMEAN in W3SPR2 par list. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Tolman and Chalikov (1996) input and dissipation source terms. + ! Bundled with interpolation tables. + ! + ! 2. Variables and types : + ! + ! Interpolation tables : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NRSIGA I.P. Public Array dimension (SIGA). + ! NRDRAG I.P. Public Array dimension (drag coefficient). + ! SIGAMX R.P. Public Maximum nondiensional frequency. + ! DRAGMX R.P. Public Maximum drag coefficient. + ! DSIGA Real Public Table increment. + ! DDRAG Real Public Id. + ! BETATB R.A. Public Interpolation table. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SPR2 Subr. Public Mean parameters from spectrum. + ! W3SIN2 Subr. Public Input source term. + ! W3SDS2 Subr. Public Dissipation source term. + ! INPTAB Subr. Public Interpolation table for wind-wave + ! interaction parameter. + ! W3BETA R.F. INPTAB Id. function. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S ) + ! PRT2DS Subr. W3ARRYMD Print plot of spectra. ( !/T0 ) + ! OUTMAT Subr. W3WRRYMD Print out 2D matrix. ( !/T1 ) + ! ... Data W3DISPMD Interpolation tables to solve + ! dispersion relation. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T(n) Test output, see subroutines. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + !/ Interpolation table + !/ + INTEGER, PARAMETER, PRIVATE :: NRSIGA = 400 + INTEGER, PARAMETER, PRIVATE :: NRDRAG = 20 + REAL, PARAMETER, PRIVATE :: SIGAMX = 40. + REAL, PARAMETER, PRIVATE :: DRAGMX = 1.E-2 + ! + REAL, PRIVATE :: DSIGA, DDRAG, & + BETATB(-NRSIGA:NRSIGA+1,NRDRAG+1) + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate mean wave parameters for the use in the source term + !> routines (Tolman and Chalikov). + !> + !> @param[in] A Action density spectrum. + !> @param[in] CG Group velocities. + !> @param[in] WN Wavenumbers. + !> @param[in] DEPTH Water depth. + !> @param[in] FPI Peak input frequency. + !> @param[in] U Wind speed. + !> @param[in] USTAR Friction velocity. + !> @param[out] EMEAN Total energy (variance). + !> @param[out] FMEAN Mean frequency. + !> @param[out] WNMEAN Mean wavenumber. + !> @param[out] AMAX Maximum of action spectrum. + !> @param[out] ALFA Phillips' constant. + !> @param[out] FP Peak frequency. + !> + !> @author H. L. Tolman + !> @author D. Chalikov + !> @date 13-Apr-2007 + !> + SUBROUTINE W3SPR2 (A, CG, WN, DEPTH, FPI, U, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALFA, FP ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | D.Chalikov | + !/ | FORTRAN 90 | + !/ | Last update : 13-Apr-2007 | + !/ +-----------------------------------+ + !/ + !/ 06-Dec-1996 : Final version 1.18 / FORTRAN 77 version. + !/ 16-Nov-1999 : Add itteration to section 5. for removal of W3APR2. + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 21-Dec-2004 : Multiple model version. ( version 3.06 ) + !/ 03-Jul-2006 : Extract stress computation. ( version 3.09 ) + !/ 13-Apr-2007 : EMEAN in parameter list. ( version 3.11 ) + ! + ! 1. Purpose : + ! + ! Calculate mean wave parameters for the use in the source term + ! routines. (Tolman and Chalikov) + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum. + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! DEPTH Real I Water depth. + ! FPI Real I Peak input frequency. + ! U Real I Wind speed. + ! USTAR Real I Friction velocity. + ! EMEAN Real O Total energy (variance). + ! FMEAN Real O Mean frequency. + ! WNMEAN Real O Mean wavenumber. + ! AMAX Real O Maximum of action spectrum. + ! ALFA R.A. O Phillips' constant. + ! FP Real O Peak frequency. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, DTH, SIG, DDEN, FTE, FTF, FTWN, & + NITTIN, ZWIND, CINXSI #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK), DEPTH, & - FPI, U, USTAR - REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX, & - ALFA(NK), FP -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IK, ITH, I1, ITT + USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK), DEPTH, & + FPI, U, USTAR + REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX, & + ALFA(NK), FP + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IK, ITH, I1, ITT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: EBAND, FPISTR, EB(NK), UST -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: EBAND, FPISTR, EB(NK), UST + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SPR2') + CALL STRACE (IENT, 'W3SPR2') #endif -! - UST = MAX ( 0.0001 , USTAR ) -! - EMEAN = 0. - FMEAN = 0. - WNMEAN = 0. - AMAX = 0. -! -! 1. Integral over directions and maximum --------------------------- * -! - DO IK=1, NK - EB(IK) = 0. - DO ITH=1, NTH - EB(IK) = EB(IK) + A(ITH,IK) - AMAX = MAX ( AMAX , A(ITH,IK) ) - END DO - END DO -! -! 2. Integrate over directions -------------------------------------- * -! - DO IK=1, NK - ALFA(IK) = 2. * DTH * SIG(IK) * EB(IK) * WN(IK)**3 - EB(IK) = EB(IK) * DDEN(IK) / CG(IK) - EMEAN = EMEAN + EB(IK) - FMEAN = FMEAN + EB(IK) / SIG(IK) - WNMEAN = WNMEAN + EB(IK) / SQRT(WN(IK)) - END DO -! -! 3. Add tail beyond discrete spectrum and get mean pars ------------ * -! ( DTH * SIG absorbed in FTxx ) -! - EBAND = EB(NK) / DDEN(NK) - EMEAN = EMEAN + EBAND * FTE - FMEAN = FMEAN + EBAND * FTF - WNMEAN = WNMEAN + EBAND * FTWN -! - FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) - WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 -! -! 4. Estimate peak frequency from FPI ------------------------------- * -! - FPISTR = MAX ( 0.008 , FPI * UST / GRAV ) - FP = ( 3.6E-4 + 0.92*FPISTR - 6.3E-10/FPISTR**3 )/UST*GRAV - FP = FP * TPIINV -! - RETURN -!/ -!/ End of W3SPR2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SPR2 -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate input source term. -!> -!> @param[in] A Action density spectrum (1-D). -!> @param[in] CG Group velocities for k-axis of spectrum. -!> @param[in] K Wavenumber for entire spectrum (1-D). -!> @param[in] U Wind speed at reference height. -!> @param[in] UDIR Direction of U. -!> @param[in] CD Drag coefficient at wind level ZWIND. -!> @param[in] Z0 Corresponding z0. -!> @param[out] FPI Input 'peak' frequency. -!> @param[out] S Source term (1-D version). -!> @param[out] D Diagonal term of derivative (1-D version). -!> -!> @author H. L. Tolman -!> @author D. Chalikov -!> @date 21-Feb-2004 -!> - SUBROUTINE W3SIN2 ( A, CG, K, U, UDIR, CD, Z0, FPI, S, D ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | D.Chalikov | -!/ | FORTRAN 90 | -!/ | Last update : 21-Feb-2004 | -!/ +-----------------------------------+ -!/ -!/ 14-Jan-1997 : Final FORTRAN 77 ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 21-Feb-2004 : Multiple model version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Calculate input source term. -! -! 2. Method : -! -! Tolman and Chalikov (1996), see manual. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D). -! CG R.A. I Group velocities for k-axis of spectrum. -! K R.A. I Wavenumber for entire spectrum (1-D). -! U Real I Wind speed at reference height. -! UDIR Real I Direction of U. -! CD Real I Drag coefficient at wind level ZWIND. -! Z0 Real I Corresponding z0. -! FPI R.A. O Input 'peak' frequency. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! PRT2DS Subr. W3ARRYMD Print plot of spectra. -! OUTMAT Subr. W3WRRYMD Print out 2D matrix. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Actual height of wind speed does not need to be 10 m, but is -! given by ZWIND. -! - Abs(cos) > 0.0087 to asure continuity in beta. Corresponds -! to shift of up to half a degree. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 Print arrays. -! !/T1 Calculation of diagonal within spectrum -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, DDEN, SIG, SIG2, & - ESIN, ECOS, FTE, FTTR, FPIMIN, ZWIND, & - FACTI1, FACTI2, FSWELL + ! + UST = MAX ( 0.0001 , USTAR ) + ! + EMEAN = 0. + FMEAN = 0. + WNMEAN = 0. + AMAX = 0. + ! + ! 1. Integral over directions and maximum --------------------------- * + ! + DO IK=1, NK + EB(IK) = 0. + DO ITH=1, NTH + EB(IK) = EB(IK) + A(ITH,IK) + AMAX = MAX ( AMAX , A(ITH,IK) ) + END DO + END DO + ! + ! 2. Integrate over directions -------------------------------------- * + ! + DO IK=1, NK + ALFA(IK) = 2. * DTH * SIG(IK) * EB(IK) * WN(IK)**3 + EB(IK) = EB(IK) * DDEN(IK) / CG(IK) + EMEAN = EMEAN + EB(IK) + FMEAN = FMEAN + EB(IK) / SIG(IK) + WNMEAN = WNMEAN + EB(IK) / SQRT(WN(IK)) + END DO + ! + ! 3. Add tail beyond discrete spectrum and get mean pars ------------ * + ! ( DTH * SIG absorbed in FTxx ) + ! + EBAND = EB(NK) / DDEN(NK) + EMEAN = EMEAN + EBAND * FTE + FMEAN = FMEAN + EBAND * FTF + WNMEAN = WNMEAN + EBAND * FTWN + ! + FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) + WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 + ! + ! 4. Estimate peak frequency from FPI ------------------------------- * + ! + FPISTR = MAX ( 0.008 , FPI * UST / GRAV ) + FP = ( 3.6E-4 + 0.92*FPISTR - 6.3E-10/FPISTR**3 )/UST*GRAV + FP = FP * TPIINV + ! + RETURN + !/ + !/ End of W3SPR2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SPR2 + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate input source term. + !> + !> @param[in] A Action density spectrum (1-D). + !> @param[in] CG Group velocities for k-axis of spectrum. + !> @param[in] K Wavenumber for entire spectrum (1-D). + !> @param[in] U Wind speed at reference height. + !> @param[in] UDIR Direction of U. + !> @param[in] CD Drag coefficient at wind level ZWIND. + !> @param[in] Z0 Corresponding z0. + !> @param[out] FPI Input 'peak' frequency. + !> @param[out] S Source term (1-D version). + !> @param[out] D Diagonal term of derivative (1-D version). + !> + !> @author H. L. Tolman + !> @author D. Chalikov + !> @date 21-Feb-2004 + !> + SUBROUTINE W3SIN2 ( A, CG, K, U, UDIR, CD, Z0, FPI, S, D ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | D.Chalikov | + !/ | FORTRAN 90 | + !/ | Last update : 21-Feb-2004 | + !/ +-----------------------------------+ + !/ + !/ 14-Jan-1997 : Final FORTRAN 77 ( version 1.18 ) + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 21-Feb-2004 : Multiple model version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Calculate input source term. + ! + ! 2. Method : + ! + ! Tolman and Chalikov (1996), see manual. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D). + ! CG R.A. I Group velocities for k-axis of spectrum. + ! K R.A. I Wavenumber for entire spectrum (1-D). + ! U Real I Wind speed at reference height. + ! UDIR Real I Direction of U. + ! CD Real I Drag coefficient at wind level ZWIND. + ! Z0 Real I Corresponding z0. + ! FPI R.A. O Input 'peak' frequency. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! PRT2DS Subr. W3ARRYMD Print plot of spectra. + ! OUTMAT Subr. W3WRRYMD Print out 2D matrix. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Actual height of wind speed does not need to be 10 m, but is + ! given by ZWIND. + ! - Abs(cos) > 0.0087 to asure continuity in beta. Corresponds + ! to shift of up to half a degree. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 Print arrays. + ! !/T1 Calculation of diagonal within spectrum + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, DDEN, SIG, SIG2, & + ESIN, ECOS, FTE, FTTR, FPIMIN, ZWIND, & + FACTI1, FACTI2, FSWELL #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NSPEC), CG(NK), K(NSPEC), U, UDIR, & - CD, Z0 - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC), FPI -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS, IK, IOMA, ICL, NKFILT, NKFIL2 + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NSPEC), CG(NK), K(NSPEC), U, UDIR, & + CD, Z0 + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC), FPI + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS, IK, IOMA, ICL, NKFILT, NKFIL2 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T0 - INTEGER ITH + INTEGER ITH #endif - REAL :: COSU, SINU, COSFAC, LAMBDA, ULAM, & - CLAM, OMA, M0, M1, RD1, RD2, BETA, & - FACLN1, FACLN2, USTAR, TRANS, FPISTR,& - FP1STR, FP1, SIN1A(NK) - REAL, PARAMETER :: TRANSF = 0.75 - REAL, PARAMETER :: PEAKFC = 0.8 + REAL :: COSU, SINU, COSFAC, LAMBDA, ULAM, & + CLAM, OMA, M0, M1, RD1, RD2, BETA, & + FACLN1, FACLN2, USTAR, TRANS, FPISTR,& + FP1STR, FP1, SIN1A(NK) + REAL, PARAMETER :: TRANSF = 0.75 + REAL, PARAMETER :: PEAKFC = 0.8 #ifdef W3_T0 - REAL :: DOUT(NK,NTH) + REAL :: DOUT(NK,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIN2') + CALL STRACE (IENT, 'W3SIN2') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) DSIGA, DDRAG, U, UDIR*RADE, CD, Z0 + WRITE (NDST,9000) DSIGA, DDRAG, U, UDIR*RADE, CD, Z0 #endif -! -! 1. Preparations -! - COSU = COS(UDIR) - SINU = SIN(UDIR) -! -! 2. Loop over spectrum -! + ! + ! 1. Preparations + ! + COSU = COS(UDIR) + SINU = SIN(UDIR) + ! + ! 2. Loop over spectrum + ! #ifdef W3_T2 - WRITE (NDST,9020) + WRITE (NDST,9020) #endif -! - FACLN1 = U / LOG(ZWIND/Z0) - FACLN2 = LOG(Z0) -! - DO IS=1, NSPEC - COSFAC = ECOS(IS)*COSU + ESIN(IS)*SINU - COSFAC = SIGN ( MAX ( 0.0087 , ABS(COSFAC) ) , COSFAC ) - LAMBDA = TPI / ( K(IS) * ABS(COSFAC) ) - ULAM = FACLN1 * ( LOG(LAMBDA) - FACLN2 ) - CLAM = CD * ( U / ULAM )**2 - OMA = K(IS) * ULAM * COSFAC / SIG2(IS) - IOMA = INT ( OMA/DSIGA ) + & - MIN ( 0 , INT ( SIGN ( -1.1 , OMA ) ) ) - ICL = INT ( CLAM/DDRAG ) - RD1 = OMA/DSIGA - REAL(IOMA) - RD2 = CLAM/DDRAG - REAL(ICL) - IOMA = MAX ( -NRSIGA , MIN ( NRSIGA , IOMA ) ) - ICL = MAX ( 1 , MIN ( NRDRAG , ICL ) ) - BETA = (1.-RD1) * (1.-RD2) * BETATB( IOMA , ICL ) & - + RD1 * (1.-RD2) * BETATB(IOMA+1, ICL ) & - + (1.-RD1) * RD2 * BETATB( IOMA ,ICL+1) & - + RD1 * RD2 * BETATB(IOMA+1,ICL+1) - D(IS) = BETA * SIG2(IS) - S(IS) = A(IS) * D(IS) + ! + FACLN1 = U / LOG(ZWIND/Z0) + FACLN2 = LOG(Z0) + ! + DO IS=1, NSPEC + COSFAC = ECOS(IS)*COSU + ESIN(IS)*SINU + COSFAC = SIGN ( MAX ( 0.0087 , ABS(COSFAC) ) , COSFAC ) + LAMBDA = TPI / ( K(IS) * ABS(COSFAC) ) + ULAM = FACLN1 * ( LOG(LAMBDA) - FACLN2 ) + CLAM = CD * ( U / ULAM )**2 + OMA = K(IS) * ULAM * COSFAC / SIG2(IS) + IOMA = INT ( OMA/DSIGA ) + & + MIN ( 0 , INT ( SIGN ( -1.1 , OMA ) ) ) + ICL = INT ( CLAM/DDRAG ) + RD1 = OMA/DSIGA - REAL(IOMA) + RD2 = CLAM/DDRAG - REAL(ICL) + IOMA = MAX ( -NRSIGA , MIN ( NRSIGA , IOMA ) ) + ICL = MAX ( 1 , MIN ( NRDRAG , ICL ) ) + BETA = (1.-RD1) * (1.-RD2) * BETATB( IOMA , ICL ) & + + RD1 * (1.-RD2) * BETATB(IOMA+1, ICL ) & + + (1.-RD1) * RD2 * BETATB( IOMA ,ICL+1) & + + RD1 * RD2 * BETATB(IOMA+1,ICL+1) + D(IS) = BETA * SIG2(IS) + S(IS) = A(IS) * D(IS) #ifdef W3_T2 - WRITE (NDST,9021) IS, COSFAC, LAMBDA, ULAM, CLAM*1.E3, & - OMA, BETA*1.E4 + WRITE (NDST,9021) IS, COSFAC, LAMBDA, ULAM, CLAM*1.E3, & + OMA, BETA*1.E4 #endif - END DO -! -! 3. Calculate FPI -! - DO IK=1, NK - SIN1A(IK) = 0. - DO IS=(IK-1)*NTH+1, IK*NTH - SIN1A(IK) = SIN1A(IK) + MAX ( 0. , S(IS) ) - END DO - END DO -! - M0 = 0. - M1 = 0. - DO IK=1, NK - SIN1A(IK) = SIN1A(IK) * DDEN(IK) / ( CG(IK) * SIG(IK)**3 ) - M0 = M0 + SIN1A(IK) - M1 = M1 + SIN1A(IK)/SIG(IK) - END DO -! - SIN1A(NK) = SIN1A(NK) / DDEN(NK) - M0 = M0 + SIN1A(NK) * FTE - M1 = M1 + SIN1A(NK) * FTTR - IF ( M1 .LT. 1E-20 ) THEN - FPI = XFR * SIG(NK) - ELSE - FPI = M0 / M1 - END IF -! -! 4. Filter for swell -! - USTAR = U * SQRT(CD) - FPISTR = MAX ( FPIMIN , FPI * USTAR / GRAV ) - FP1STR = 3.6E-4 + 0.92*FPISTR - 6.3E-10/FPISTR**3 - FP1 = PEAKFC * FP1STR * GRAV / USTAR -! - NKFILT = MIN ( NK , INT(FACTI2+FACTI1*LOG(FP1)) ) - NKFIL2 = MIN ( NK , INT(FACTI2+FACTI1*LOG(TRANSF*FP1)) ) - NKFIL2 = MAX ( 0 , NKFIL2 ) -! - DO IS=1, NKFIL2*NTH - D(IS) = MAX ( D(IS) , FSWELL*D(IS) ) + END DO + ! + ! 3. Calculate FPI + ! + DO IK=1, NK + SIN1A(IK) = 0. + DO IS=(IK-1)*NTH+1, IK*NTH + SIN1A(IK) = SIN1A(IK) + MAX ( 0. , S(IS) ) + END DO + END DO + ! + M0 = 0. + M1 = 0. + DO IK=1, NK + SIN1A(IK) = SIN1A(IK) * DDEN(IK) / ( CG(IK) * SIG(IK)**3 ) + M0 = M0 + SIN1A(IK) + M1 = M1 + SIN1A(IK)/SIG(IK) + END DO + ! + SIN1A(NK) = SIN1A(NK) / DDEN(NK) + M0 = M0 + SIN1A(NK) * FTE + M1 = M1 + SIN1A(NK) * FTTR + IF ( M1 .LT. 1E-20 ) THEN + FPI = XFR * SIG(NK) + ELSE + FPI = M0 / M1 + END IF + ! + ! 4. Filter for swell + ! + USTAR = U * SQRT(CD) + FPISTR = MAX ( FPIMIN , FPI * USTAR / GRAV ) + FP1STR = 3.6E-4 + 0.92*FPISTR - 6.3E-10/FPISTR**3 + FP1 = PEAKFC * FP1STR * GRAV / USTAR + ! + NKFILT = MIN ( NK , INT(FACTI2+FACTI1*LOG(FP1)) ) + NKFIL2 = MIN ( NK , INT(FACTI2+FACTI1*LOG(TRANSF*FP1)) ) + NKFIL2 = MAX ( 0 , NKFIL2 ) + ! + DO IS=1, NKFIL2*NTH + D(IS) = MAX ( D(IS) , FSWELL*D(IS) ) + S(IS) = A(IS) * D(IS) + END DO + ! + DO IK=NKFIL2+1, NKFILT + TRANS = ( SIG(IK)/FP1 - TRANSF ) / (1.-TRANSF) + DO IS=(IK-1)*NTH+1, IK*NTH + D(IS) = (1.-TRANS)*MAX(D(IS),FSWELL*D(IS)) + TRANS*D(IS) S(IS) = A(IS) * D(IS) - END DO -! - DO IK=NKFIL2+1, NKFILT - TRANS = ( SIG(IK)/FP1 - TRANSF ) / (1.-TRANSF) - DO IS=(IK-1)*NTH+1, IK*NTH - D(IS) = (1.-TRANS)*MAX(D(IS),FSWELL*D(IS)) + TRANS*D(IS) - S(IS) = A(IS) * D(IS) - END DO - END DO -! -! ... Test output of arrays -! -#ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO -#endif -! + END DO + END DO + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SIN2 : DSIGA,DDRAG,U,UDIR,CD,Z0(IN) : '/ & - ' ',F8.4,F9.6,F7.2,F6.1,F8.5,F8.5) +9000 FORMAT (' TEST W3SIN2 : DSIGA,DDRAG,U,UDIR,CD,Z0(IN) : '/ & + ' ',F8.4,F9.6,F7.2,F6.1,F8.5,F8.5) #endif -! + ! #ifdef W3_T2 - 9020 FORMAT (' TEST W3SIN2 : IS, COS, LAMBDA, ULAM, CLAM*1E3, ', & - 'OMA, BETA*1E4') - 9021 FORMAT (6X,I6,F7.2,1X,F6.1,2(1X,F5.2),2(1X,F6.2)) +9020 FORMAT (' TEST W3SIN2 : IS, COS, LAMBDA, ULAM, CLAM*1E3, ', & + 'OMA, BETA*1E4') +9021 FORMAT (6X,I6,F7.2,1X,F6.1,2(1X,F5.2),2(1X,F6.2)) #endif -!/ -!/ End of W3SIN2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SIN2 -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate whitecapping source term and diagonal term of derivative. -!> -!> @param[in] A Input action density spectrum. -!> @param[in] CG Group velocity array. -!> @param[in] K Wavenumber array. -!> @param[in] FPI 'Peak frequency' of input (rad/s). -!> @param[in] USTAR Friction velocity (m/s). -!> @param[in] ALFA Phillips' constant. -!> @param[out] S Source term (1-D version). -!> @param[out] D Diagonal term of derivative (1-D version). -!> -!> @author H. L. Tolman @date 21-Feb-2004 -!> - SUBROUTINE W3SDS2 (A, CG, K, FPI, USTAR, ALFA, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 21-Feb-2004 | -!/ +-----------------------------------+ -!/ -!/ 12-Jun-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 23-Apr-2002 : Erick Rogers' fix ( version 2.19 ) -!/ 21-Feb-2004 : Multiple model version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Calculate whitecapping source term and diagonal term of der. -! -! 2. Method : -! -! Tolman and Chalikov (1995). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Input action density spectrum. -! CG R.A. I Group velocity array. -! K R.A. I Wavenumber array. -! FPI Real I 'Peak frequency' of input (rad/s). -! USTAR Real I Friction velocity (m/s). -! ALFA R.A. I Phillips' constant. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! PRT2DS Subr. W3ARRYMD Print plot of spectra. -! OUTMAT Subr. W3WRRYMD Print out 2D matrix. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 Print arrays. -! !/T1 Print filter and constituents. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, SIG, DDEN, DTH, FTE, FPIMIN, & - FACTI1, FACTI2, XF1, XF2, XFH, SDSALN, & - CDSA0, CDSA1, CDSA2, CDSB0, CDSB1, CDSB2, & - CDSB3 + !/ + !/ End of W3SIN2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SIN2 + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate whitecapping source term and diagonal term of derivative. + !> + !> @param[in] A Input action density spectrum. + !> @param[in] CG Group velocity array. + !> @param[in] K Wavenumber array. + !> @param[in] FPI 'Peak frequency' of input (rad/s). + !> @param[in] USTAR Friction velocity (m/s). + !> @param[in] ALFA Phillips' constant. + !> @param[out] S Source term (1-D version). + !> @param[out] D Diagonal term of derivative (1-D version). + !> + !> @author H. L. Tolman @date 21-Feb-2004 + !> + SUBROUTINE W3SDS2 (A, CG, K, FPI, USTAR, ALFA, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 21-Feb-2004 | + !/ +-----------------------------------+ + !/ + !/ 12-Jun-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 23-Apr-2002 : Erick Rogers' fix ( version 2.19 ) + !/ 21-Feb-2004 : Multiple model version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Calculate whitecapping source term and diagonal term of der. + ! + ! 2. Method : + ! + ! Tolman and Chalikov (1995). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Input action density spectrum. + ! CG R.A. I Group velocity array. + ! K R.A. I Wavenumber array. + ! FPI Real I 'Peak frequency' of input (rad/s). + ! USTAR Real I Friction velocity (m/s). + ! ALFA R.A. I Phillips' constant. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! PRT2DS Subr. W3ARRYMD Print plot of spectra. + ! OUTMAT Subr. W3WRRYMD Print out 2D matrix. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 Print arrays. + ! !/T1 Print filter and constituents. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, SIG, DDEN, DTH, FTE, FPIMIN, & + FACTI1, FACTI2, XF1, XF2, XFH, SDSALN, & + CDSA0, CDSA1, CDSA2, CDSB0, CDSB1, CDSB2, & + CDSB3 #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK), CG(NK), K(NK), FPI, & - USTAR, ALFA(NK) - REAL, INTENT(OUT) :: S(NTH,NK), D(NTH,NK) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IK, ITH, IKHW + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK), CG(NK), K(NK), FPI, & + USTAR, ALFA(NK) + REAL, INTENT(OUT) :: S(NTH,NK), D(NTH,NK) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IK, ITH, IKHW #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: FHW, XHW, FPIT, PHI, AF1, AF2, & - AFILT, BFILT, CDIST, FILT, POW, & - CDISH, CDISP, HW, EHIGH, EBD(NK) + REAL :: FHW, XHW, FPIT, PHI, AF1, AF2, & + AFILT, BFILT, CDIST, FILT, POW, & + CDISH, CDISP, HW, EHIGH, EBD(NK) #ifdef W3_T - REAL POWMAX + REAL POWMAX #endif #ifdef W3_T0 - REAL DOUT(NK,NTH) + REAL DOUT(NK,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SDS2') + CALL STRACE (IENT, 'W3SDS2') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) FPI, USTAR + WRITE (NDST,9000) FPI, USTAR #endif -! -! 1. Preparations -! 1.a HW -! - FHW = XFH*FPI - XHW = FACTI2 + FACTI1*LOG(FHW) - IKHW = MIN ( NK , INT ( XHW + 0.5 ) ) - DO IK=IKHW, NK - EBD(IK) = 0. - DO ITH=1, NTH - EBD(IK) = EBD(IK) + A(ITH,IK) - END DO - END DO -! - IF ( FHW .LT. SIG(NK+1) ) THEN - XHW = 1. - MOD ( XHW + 0.5 , 1. ) - IF ( IKHW .EQ. NK ) XHW = MAX ( 0. , XHW - 0.5 ) - HW = XHW * EBD(IKHW)*DDEN(IKHW)/CG(IKHW) - DO IK=IKHW+1, NK - HW = HW + EBD(IK)*DDEN(IK)/CG(IK) - END DO - HW = 4. * SQRT ( HW + EBD(NK)/CG(NK)*FTE ) - ELSE - EHIGH = EBD(NK)/CG(NK) * SIG(NK)*DTH * (SIG(NK)/FHW)**5 - HW = 4. * SQRT ( 0.25 * FHW * EHIGH ) - END IF -! -! 1.b PHI -! - FPIT = MAX ( FPIMIN , FPI*TPIINV*USTAR/GRAV ) - PHI = CDSB0 + CDSB1*FPIT + CDSB2/FPIT**CDSB3 -! -! 1.c Set-up filter -! - AF2 = XF2*FPI - AF1 = XF1*FPI - BFILT = 1. / ( AF2 - AF1 ) - AFILT = - BFILT * AF1 -! -! 1.d Constants -! - CDIST = - 2. * USTAR * HW * PHI - CDISH = G2PI3I * USTAR**2 - CDISP = G1PI1I * USTAR -! -! 2. Combined diagonal factor -! + ! + ! 1. Preparations + ! 1.a HW + ! + FHW = XFH*FPI + XHW = FACTI2 + FACTI1*LOG(FHW) + IKHW = MIN ( NK , INT ( XHW + 0.5 ) ) + DO IK=IKHW, NK + EBD(IK) = 0. + DO ITH=1, NTH + EBD(IK) = EBD(IK) + A(ITH,IK) + END DO + END DO + ! + IF ( FHW .LT. SIG(NK+1) ) THEN + XHW = 1. - MOD ( XHW + 0.5 , 1. ) + IF ( IKHW .EQ. NK ) XHW = MAX ( 0. , XHW - 0.5 ) + HW = XHW * EBD(IKHW)*DDEN(IKHW)/CG(IKHW) + DO IK=IKHW+1, NK + HW = HW + EBD(IK)*DDEN(IK)/CG(IK) + END DO + HW = 4. * SQRT ( HW + EBD(NK)/CG(NK)*FTE ) + ELSE + EHIGH = EBD(NK)/CG(NK) * SIG(NK)*DTH * (SIG(NK)/FHW)**5 + HW = 4. * SQRT ( 0.25 * FHW * EHIGH ) + END IF + ! + ! 1.b PHI + ! + FPIT = MAX ( FPIMIN , FPI*TPIINV*USTAR/GRAV ) + PHI = CDSB0 + CDSB1*FPIT + CDSB2/FPIT**CDSB3 + ! + ! 1.c Set-up filter + ! + AF2 = XF2*FPI + AF1 = XF1*FPI + BFILT = 1. / ( AF2 - AF1 ) + AFILT = - BFILT * AF1 + ! + ! 1.d Constants + ! + CDIST = - 2. * USTAR * HW * PHI + CDISH = G2PI3I * USTAR**2 + CDISP = G1PI1I * USTAR + ! + ! 2. Combined diagonal factor + ! #ifdef W3_T2 - WRITE (NDST,9020) + WRITE (NDST,9020) #endif #ifdef W3_T - POWMAX = 0. + POWMAX = 0. #endif - DO IK=1, NK - FILT = MIN ( 1., MAX ( 0. , AFILT + BFILT*SIG(IK) )) - POW = MIN ( 25. , CDSA1 / ( CDISP*SIG(IK) )**CDSA2 ) - IF ( FILT .GT. 0. ) THEN - D(1,IK) = (1.-FILT) * CDIST * K(IK)**2 & - - FILT * CDSA0 * CDISH * SIG(IK)**3 & - * (ALFA(IK)/SDSALN)**POW - ELSE - D(1,IK) = (1.-FILT) * CDIST * K(IK)**2 - END IF + DO IK=1, NK + FILT = MIN ( 1., MAX ( 0. , AFILT + BFILT*SIG(IK) )) + POW = MIN ( 25. , CDSA1 / ( CDISP*SIG(IK) )**CDSA2 ) + IF ( FILT .GT. 0. ) THEN + D(1,IK) = (1.-FILT) * CDIST * K(IK)**2 & + - FILT * CDSA0 * CDISH * SIG(IK)**3 & + * (ALFA(IK)/SDSALN)**POW + ELSE + D(1,IK) = (1.-FILT) * CDIST * K(IK)**2 + END IF #ifdef W3_T - POWMAX = MAX(POW*FILT,POWMAX) + POWMAX = MAX(POW*FILT,POWMAX) #endif #ifdef W3_T2 - WRITE (NDST,9021) IK, FILT, ALFA(IK)/SDSALN, & - CDIST*PHI*K(IK)**2, CDSA0*CDISH*SIG(IK)**3 & - * (ALFA(IK)/SDSALN)**POW, D(1,IK) + WRITE (NDST,9021) IK, FILT, ALFA(IK)/SDSALN, & + CDIST*PHI*K(IK)**2, CDSA0*CDISH*SIG(IK)**3 & + * (ALFA(IK)/SDSALN)**POW, D(1,IK) #endif - END DO -! + END DO + ! #ifdef W3_T - WRITE (NDST,9010) AF1, AF2, AFILT, BFILT, POWMAX -#endif -! -! 3. 2-D diagonal array -! - DO IK=1, NK - DO ITH=2, NTH - D(ITH,IK) = D(1,IK) - END DO - END DO -! - S = D * A -! -! ... Test output of arrays -! -#ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH,IK) - END DO - END DO + WRITE (NDST,9010) AF1, AF2, AFILT, BFILT, POWMAX #endif -! + ! + ! 3. 2-D diagonal array + ! + DO IK=1, NK + DO ITH=2, NTH + D(ITH,IK) = D(1,IK) + END DO + END DO + ! + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & - 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH,IK) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SDS2 : FPI, USTAR : ',2F8.3) - 9010 FORMAT (' TEST W3SDS2 : AF1-2, A-BFILT, PMAX : ',4F7.3,E10.3) +9000 FORMAT (' TEST W3SDS2 : FPI, USTAR : ',2F8.3) +9010 FORMAT (' TEST W3SDS2 : AF1-2, A-BFILT, PMAX : ',4F7.3,E10.3) #endif #ifdef W3_T2 - 9020 FORMAT (' TEST W3SDS2 : IK, FILT, ALFA, DDST, DDSH, DDS') - 9021 FORMAT (' ',I6,2F7.3,3E11.3) +9020 FORMAT (' TEST W3SDS2 : IK, FILT, ALFA, DDST, DDSH, DDS') +9021 FORMAT (' ',I6,2F7.3,3E11.3) #endif -!/ -!/ End of W3SDS2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SDS2 -!/ ------------------------------------------------------------------- / -!> -!> @brief Generate an interpolation table for the air-sea interaction -!> parameter of Chalikov and Belevich (1993). -!> -!> @details The size of the table is set in parameter statements, -!> the range is set by the input parameters of this routine. The first -!> counter of the table corresponds to the nondimensional frequency -!> -!> @verbatim -!> SIGMA Ul -!> SIGA = ---------- COS ( THETA - THETA ) (1) -!> g wind -!> @endverbatim -!> -!> The second counter of the table represents the drag coefficient. -!> The maximum values of both parameters are passed to the routine -!> through the parameter list. -!> -!> @author H. L. Tolman @date 21-Feb-2004 -!> - SUBROUTINE INPTAB -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 21-Feb-2004 | -!/ +-----------------------------------+ -!/ -!/ 03-Jun-1996 : Final version 1.18 / FORTRAN 77 version. -!/ 06-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 21-Feb-2004 : Multiple model version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Generate an interpolation table for the air-sea interaction -! parameter of Chalikov and Belevich (1993). -! -! 2. Method : -! -! The size of the table is set in parameter statements, the range -! is set by the input parameters of this routine. The first counter -! of the table corresponds to the nondimensional frequency -! -! SIGMA Ul -! SIGA = ---------- COS ( THETA - THETA ) (1) -! g wind -! -! The second counter of the table represents the drag coefficient. -! The maximum values of both parameters are passed to the routine -! through the parameter list. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! W3BETA Func. Internal Function to calculate the -! interaction parameter. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Model definition IO routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T0 Print table. -! !/T1 Estimate maximum errors. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3ODATMD, ONLY: NDST + !/ + !/ End of W3SDS2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SDS2 + !/ ------------------------------------------------------------------- / + !> + !> @brief Generate an interpolation table for the air-sea interaction + !> parameter of Chalikov and Belevich (1993). + !> + !> @details The size of the table is set in parameter statements, + !> the range is set by the input parameters of this routine. The first + !> counter of the table corresponds to the nondimensional frequency + !> + !> @verbatim + !> SIGMA Ul + !> SIGA = ---------- COS ( THETA - THETA ) (1) + !> g wind + !> @endverbatim + !> + !> The second counter of the table represents the drag coefficient. + !> The maximum values of both parameters are passed to the routine + !> through the parameter list. + !> + !> @author H. L. Tolman @date 21-Feb-2004 + !> + SUBROUTINE INPTAB + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 21-Feb-2004 | + !/ +-----------------------------------+ + !/ + !/ 03-Jun-1996 : Final version 1.18 / FORTRAN 77 version. + !/ 06-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 21-Feb-2004 : Multiple model version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Generate an interpolation table for the air-sea interaction + ! parameter of Chalikov and Belevich (1993). + ! + ! 2. Method : + ! + ! The size of the table is set in parameter statements, the range + ! is set by the input parameters of this routine. The first counter + ! of the table corresponds to the nondimensional frequency + ! + ! SIGMA Ul + ! SIGA = ---------- COS ( THETA - THETA ) (1) + ! g wind + ! + ! The second counter of the table represents the drag coefficient. + ! The maximum values of both parameters are passed to the routine + ! through the parameter list. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! W3BETA Func. Internal Function to calculate the + ! interaction parameter. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Model definition IO routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T0 Print table. + ! !/T1 Estimate maximum errors. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3ODATMD, ONLY: NDST #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISIGA, IDRAG + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISIGA, IDRAG #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T0 - INTEGER :: I1 + INTEGER :: I1 #endif #ifdef W3_T1 - INTEGER :: IE1 + INTEGER :: IE1 #endif - REAL :: SIGA, DRAG + REAL :: SIGA, DRAG #ifdef W3_T0 - REAL :: BMIN, BMAX + REAL :: BMIN, BMAX #endif #ifdef W3_T1 - REAL :: ENORM, ERR(NRDRAG) + REAL :: ENORM, ERR(NRDRAG) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INPTAB') + CALL STRACE (IENT, 'INPTAB') #endif -! -! 1. Determine range and increments of table ------------------------ * + ! + ! 1. Determine range and increments of table ------------------------ * -! - DSIGA = SIGAMX / REAL(NRSIGA) - DDRAG = DRAGMX / REAL(NRDRAG) -! + ! + DSIGA = SIGAMX / REAL(NRSIGA) + DDRAG = DRAGMX / REAL(NRDRAG) + ! #ifdef W3_T - WRITE (NDST,9000) SIGAMX, DSIGA, DRAGMX, DDRAG + WRITE (NDST,9000) SIGAMX, DSIGA, DRAGMX, DDRAG #endif -! -! 2. Fill table ----------------------------------------------------- * -! - DO ISIGA=-NRSIGA,NRSIGA+1 - SIGA = REAL(ISIGA) * DSIGA - DO IDRAG=1, NRDRAG+1 - DRAG = REAL(IDRAG) * DDRAG - BETATB(ISIGA,IDRAG) = W3BETA ( SIGA, DRAG , NDST ) - END DO - END DO -! -! 3. Test output ---------------------------------------------------- * -! + ! + ! 2. Fill table ----------------------------------------------------- * + ! + DO ISIGA=-NRSIGA,NRSIGA+1 + SIGA = REAL(ISIGA) * DSIGA + DO IDRAG=1, NRDRAG+1 + DRAG = REAL(IDRAG) * DDRAG + BETATB(ISIGA,IDRAG) = W3BETA ( SIGA, DRAG , NDST ) + END DO + END DO + ! + ! 3. Test output ---------------------------------------------------- * + ! #ifdef W3_T0 - WRITE (NDST,9010) - I1 = MIN (35,NRDRAG) - DO ISIGA=-NRSIGA,NRSIGA - SIGA = REAL(ISIGA) * DSIGA - BMIN = 0. - BMAX = 0. - DO IDRAG=1, NRDRAG - BMIN = MIN ( BMIN , BETATB(ISIGA,IDRAG) ) - BMAX = MAX ( BMAX , BETATB(ISIGA,IDRAG) ) - END DO - BMAX = MAX ( BMAX , -BMIN ) - WRITE (NDST,9011) ISIGA, SIGA, BMAX, & - (NINT(BETATB(ISIGA,IDRAG)/BMAX*100.),IDRAG=1,I1) - IF (I1.LT.NRDRAG) WRITE (NDST,9012) & - (NINT(BETATB(ISIGA,IDRAG)/BMAX*100.),IDRAG=I1+1,NRDRAG) - END DO + WRITE (NDST,9010) + I1 = MIN (35,NRDRAG) + DO ISIGA=-NRSIGA,NRSIGA + SIGA = REAL(ISIGA) * DSIGA + BMIN = 0. + BMAX = 0. + DO IDRAG=1, NRDRAG + BMIN = MIN ( BMIN , BETATB(ISIGA,IDRAG) ) + BMAX = MAX ( BMAX , BETATB(ISIGA,IDRAG) ) + END DO + BMAX = MAX ( BMAX , -BMIN ) + WRITE (NDST,9011) ISIGA, SIGA, BMAX, & + (NINT(BETATB(ISIGA,IDRAG)/BMAX*100.),IDRAG=1,I1) + IF (I1.LT.NRDRAG) WRITE (NDST,9012) & + (NINT(BETATB(ISIGA,IDRAG)/BMAX*100.),IDRAG=I1+1,NRDRAG) + END DO #endif -! + ! #ifdef W3_T1 - WRITE (NDST,9020) - IE1 = MIN (30,NRDRAG-1) - ENORM = 1000. / ABS(BETATB(0,NRDRAG)) - DO ISIGA=-NRSIGA,NRSIGA - SIGA = REAL(ISIGA) * DSIGA - IF ( ABS(SIGA) .LT. 5.01 ) THEN - DO IDRAG=1, NRDRAG-1 - DRAG = ( REAL(IDRAG) + 0.5 ) * DDRAG - ERR(IDRAG) = - W3BETA (SIGA,DRAG,NDST) + 0.5 * & - ( BETATB(ISIGA,IDRAG) + BETATB(ISIGA,IDRAG+1) ) - END DO - WRITE (NDST,9021) ISIGA, SIGA, & - (NINT(ENORM*ERR(IDRAG)),IDRAG=1,IE1) - IF (IE1.LT.NRDRAG-1) WRITE (NDST,9022) & - (NINT(ENORM*ERR(IDRAG)),IDRAG=IE1+1,NRDRAG-1) - ENDIF + WRITE (NDST,9020) + IE1 = MIN (30,NRDRAG-1) + ENORM = 1000. / ABS(BETATB(0,NRDRAG)) + DO ISIGA=-NRSIGA,NRSIGA + SIGA = REAL(ISIGA) * DSIGA + IF ( ABS(SIGA) .LT. 5.01 ) THEN + DO IDRAG=1, NRDRAG-1 + DRAG = ( REAL(IDRAG) + 0.5 ) * DDRAG + ERR(IDRAG) = - W3BETA (SIGA,DRAG,NDST) + 0.5 * & + ( BETATB(ISIGA,IDRAG) + BETATB(ISIGA,IDRAG+1) ) END DO -#endif -! -#ifdef W3_T1 - WRITE (NDST,9030) - IE1 = MIN (30,NRDRAG) - ENORM = 1000. / ABS(BETATB(0,NRDRAG)) - DO ISIGA=-NRSIGA,NRSIGA-1 - SIGA = ( REAL(ISIGA) + 0.5 ) * DSIGA - IF ( ABS(SIGA) .LT. 5.01 ) THEN - DO IDRAG=1, NRDRAG - DRAG = REAL(IDRAG) * DDRAG - ERR(IDRAG) = - W3BETA (SIGA,DRAG,NDST) + 0.5 * & - ( BETATB(ISIGA,IDRAG) + BETATB(ISIGA+1,IDRAG) ) - END DO - WRITE (NDST,9031) ISIGA, SIGA, & - (NINT(ENORM*ERR(IDRAG)),IDRAG=1,IE1) - IF (IE1.LT.NRDRAG) WRITE (NDST,9032) & - (NINT(ENORM*ERR(IDRAG)),IDRAG=IE1+1,NRDRAG) - ENDIF + WRITE (NDST,9021) ISIGA, SIGA, & + (NINT(ENORM*ERR(IDRAG)),IDRAG=1,IE1) + IF (IE1.LT.NRDRAG-1) WRITE (NDST,9022) & + (NINT(ENORM*ERR(IDRAG)),IDRAG=IE1+1,NRDRAG-1) + ENDIF + END DO + ! + WRITE (NDST,9030) + IE1 = MIN (30,NRDRAG) + ENORM = 1000. / ABS(BETATB(0,NRDRAG)) + DO ISIGA=-NRSIGA,NRSIGA-1 + SIGA = ( REAL(ISIGA) + 0.5 ) * DSIGA + IF ( ABS(SIGA) .LT. 5.01 ) THEN + DO IDRAG=1, NRDRAG + DRAG = REAL(IDRAG) * DDRAG + ERR(IDRAG) = - W3BETA (SIGA,DRAG,NDST) + 0.5 * & + ( BETATB(ISIGA,IDRAG) + BETATB(ISIGA+1,IDRAG) ) END DO + WRITE (NDST,9031) ISIGA, SIGA, & + (NINT(ENORM*ERR(IDRAG)),IDRAG=1,IE1) + IF (IE1.LT.NRDRAG) WRITE (NDST,9032) & + (NINT(ENORM*ERR(IDRAG)),IDRAG=IE1+1,NRDRAG) + ENDIF + END DO #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST INPTAB : SIGAMX, DSIGA : ',F6.2,F8.2/ & - ' DRAGMX, DDRAG : ',F8.4,F9.5) +9000 FORMAT ( ' TEST INPTAB : SIGAMX, DSIGA : ',F6.2,F8.2/ & + ' DRAGMX, DDRAG : ',F8.4,F9.5) #endif -! + ! #ifdef W3_T0 - 9010 FORMAT (/' TEST INPTAB : TABLE, NORMALIZED WITH ', & - 'BETATB(ISIGA,NRDRAG)'/ & - ' ISIGA, SIGA, BETA_MAX, TABLE (x100)') - 9011 FORMAT (1X,I4,F7.2,F6.4,1X,35I3) - 9012 FORMAT (19X,35I3) +9010 FORMAT (/' TEST INPTAB : TABLE, NORMALIZED WITH ', & + 'BETATB(ISIGA,NRDRAG)'/ & + ' ISIGA, SIGA, BETA_MAX, TABLE (x100)') +9011 FORMAT (1X,I4,F7.2,F6.4,1X,35I3) +9012 FORMAT (19X,35I3) #endif -! + ! #ifdef W3_T1 - 9020 FORMAT (/' TEST INPTAB : ERROR DUE TO DRAG, NORMALIZED ', & - 'WITH BETATB(ISIGA,NRDRAG)'/ & - ' ISIGA, SIGA, TABLE (x1000)') - 9021 FORMAT (1X,I4,F7.2,35I3) - 9022 FORMAT (12X,35I3) +9020 FORMAT (/' TEST INPTAB : ERROR DUE TO DRAG, NORMALIZED ', & + 'WITH BETATB(ISIGA,NRDRAG)'/ & + ' ISIGA, SIGA, TABLE (x1000)') +9021 FORMAT (1X,I4,F7.2,35I3) +9022 FORMAT (12X,35I3) +9030 FORMAT (/' TEST INPTAB : ERROR DUE TO SIGA, NORMALIZED WITH ', & + 'BETATB(ISIGA,NRDRAG)'/ & + ' ISIGA, SIGA, TABLE (x1000)') +9031 FORMAT (1X,I4,F7.2,35I3) +9032 FORMAT (12X,35I3) #endif -! -#ifdef W3_T1 - 9030 FORMAT (/' TEST INPTAB : ERROR DUE TO SIGA, NORMALIZED WITH ', & - 'BETATB(ISIGA,NRDRAG)'/ & - ' ISIGA, SIGA, TABLE (x1000)') - 9031 FORMAT (1X,I4,F7.2,35I3) - 9032 FORMAT (12X,35I3) -#endif -!/ -!/ Internal function W3BETA -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate wind-wave interaction parameter beta. -!> -!> @param OMA Non-dimensional apparent frequency. -!> @param CL Drag coefficient at height l. -!> @param NDST -!> @returns W3BETA Wind-wave interaction parameter multiplied -!> by density ratio. -!> -!> @author H. L. Tolman -!> @author D. Chalikov -!> @date 21-Feb-2004 -!> - REAL FUNCTION W3BETA ( OMA , CL , NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | D.Chalikov | -!/ | FORTRAN 90 | -!/ | Last update : 21-Feb-2004 | -!/ +-----------------------------------+ -!/ -!/ 06-Dec-1996 : Final version 1.18 / FORTRAN 77 version. -!/ 06-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 21-Feb-2004 : Multiple model version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Calculate wind-wave interaction parameter beta. -! -! 2. Method : -! -! Chalikov and Belevich (1992), see also manual. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! W3BETA Real O Wind-wave interaction parameter multiplied -! by density ratio. -! OMA Real I Non-dimensional apparent frequency. -! -! OMA = OMEGA | U | cos(theta-theta ) / g -! l w -! -! CL Real I Drag coefficient at height l -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T0 Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ + !/ Internal function W3BETA + !/ + CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate wind-wave interaction parameter beta. + !> + !> @param OMA Non-dimensional apparent frequency. + !> @param CL Drag coefficient at height l. + !> @param NDST + !> @returns W3BETA Wind-wave interaction parameter multiplied + !> by density ratio. + !> + !> @author H. L. Tolman + !> @author D. Chalikov + !> @date 21-Feb-2004 + !> + REAL FUNCTION W3BETA ( OMA , CL , NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | D.Chalikov | + !/ | FORTRAN 90 | + !/ | Last update : 21-Feb-2004 | + !/ +-----------------------------------+ + !/ + !/ 06-Dec-1996 : Final version 1.18 / FORTRAN 77 version. + !/ 06-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 21-Feb-2004 : Multiple model version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Calculate wind-wave interaction parameter beta. + ! + ! 2. Method : + ! + ! Chalikov and Belevich (1992), see also manual. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! W3BETA Real O Wind-wave interaction parameter multiplied + ! by density ratio. + ! OMA Real I Non-dimensional apparent frequency. + ! + ! OMA = OMEGA | U | cos(theta-theta ) / g + ! l w + ! + ! CL Real I Drag coefficient at height l + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T0 Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ INTEGER, INTENT(IN) :: NDST REAL, INTENT(IN) :: OMA, CL -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S INTEGER, SAVE :: IENT = 0 #endif REAL :: OM1, OM2, A0, A1, A2, A3, A4, A5, & - A6, A7, A8, A9, A10 -!/ -!/ ------------------------------------------------------------------- / -!/ + A6, A7, A8, A9, A10 + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S CALL STRACE (IENT, 'W3BETA') #endif -! + ! #ifdef W3_T0 WRITE (NDST,9000) OMA, CL #endif -! -! calculate Omegas -! + ! + ! calculate Omegas + ! OM1 = 1.075 + 75.*CL OM2 = 1.2 + 300.*CL -! -! calculate factors a -! + ! + ! calculate factors a + ! A1 = 0.25 + 395.*CL A2 = 0.35 + 150.*CL A4 = 0.3 + 300.*CL A9 = 0.35 + 240.*CL A10 = -0.06 + 470.*CL -! + ! A5 = A4 * OM1 A0 = 0.25 * A5**2 / A4 A3 = (A0-A2-A1) / (A0+A4+A5) A6 = A0 * (1.-A3) A7 = (A9*(OM2-1)**2+A10) / (OM2-OM1) A8 = A7 * OM1 -! + ! #ifdef W3_T0 WRITE (NDST,9001) OM1, OM2 WRITE (NDST,9002) A0, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 #endif -! -! calculate beta * 1.e4 -! + ! + ! calculate beta * 1.e4 + ! IF ( OMA .LT. -1. ) THEN - W3BETA = -A1 * OMA**2 - A2 - ELSE IF (OMA .LT. OM1/2.) THEN - W3BETA = A3 * OMA * ( A4 * OMA - A5 ) - A6 - ELSE IF (OMA .LT. OM1) THEN - W3BETA = OMA * ( A4 * OMA - A5 ) - ELSE IF (OMA .LT. OM2) THEN - W3BETA = A7 * OMA - A8 - ELSE - W3BETA = A9 * (OMA-1.)**2 + A10 - END IF -! -! beta * dwat / dair -! + W3BETA = -A1 * OMA**2 - A2 + ELSE IF (OMA .LT. OM1/2.) THEN + W3BETA = A3 * OMA * ( A4 * OMA - A5 ) - A6 + ELSE IF (OMA .LT. OM1) THEN + W3BETA = OMA * ( A4 * OMA - A5 ) + ELSE IF (OMA .LT. OM2) THEN + W3BETA = A7 * OMA - A8 + ELSE + W3BETA = A9 * (OMA-1.)**2 + A10 + END IF + ! + ! beta * dwat / dair + ! W3BETA = W3BETA * 1.E-4 #ifdef W3_T0 WRITE (NDST,9003) W3BETA #endif -! + ! RETURN -! -! Formats -! + ! + ! Formats + ! #ifdef W3_T0 - 9000 FORMAT ( ' TEST W3BETA : INPUT : ',2E10.3) - 9001 FORMAT ( ' TEST W3BETA : OM1-2 : ',2E10.3) - 9002 FORMAT ( ' TEST W3BETA : A0-10 : ',5E10.3/ & - ' ',6E10.3) - 9003 FORMAT ( ' TEST W3BETA : BETA : ',E10.3) +9000 FORMAT ( ' TEST W3BETA : INPUT : ',2E10.3) +9001 FORMAT ( ' TEST W3BETA : OM1-2 : ',2E10.3) +9002 FORMAT ( ' TEST W3BETA : A0-10 : ',5E10.3/ & + ' ',6E10.3) +9003 FORMAT ( ' TEST W3BETA : BETA : ',E10.3) #endif -!/ -!/ End of W3BETA ----------------------------------------------------- / -!/ - END FUNCTION W3BETA -!/ -!/ End of INPTAB ----------------------------------------------------- / -!/ - END SUBROUTINE INPTAB -!/ -!/ End of module W3SRC2MD -------------------------------------------- / -!/ - END MODULE W3SRC2MD + !/ + !/ End of W3BETA ----------------------------------------------------- / + !/ + END FUNCTION W3BETA + !/ + !/ End of INPTAB ----------------------------------------------------- / + !/ + END SUBROUTINE INPTAB + !/ + !/ End of module W3SRC2MD -------------------------------------------- / + !/ +END MODULE W3SRC2MD diff --git a/model/src/w3src3md.F90 b/model/src/w3src3md.F90 index 91f7db440..b08b45560 100644 --- a/model/src/w3src3md.F90 +++ b/model/src/w3src3md.F90 @@ -1,1287 +1,1278 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SRC3MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III SHOM | -!/ ! F. Ardhuin ! -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 02-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 09-Oct-2007 : Origination. ( version 3.13 ) -!/ 10-Oct-2010 : Adding Janssen-style swell damping ( version 3.14) -!/ 02-Sep-2012 : Clean up test output T, T0, T1 ( version 4.07 ) -!/ -! 1. Purpose : -! -! The 'WAM4+' source terms based on P.A.E.M. Janssen's work, with -! extensions by him and by J.-R. Bidlot. Converted from the original -! WAM codes by F. Ardhuin, with further extensions to adapt to a -! saturation-based breaking and observation-based swell dissipation -! -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SPR3 Subr. Public Mean parameters from spectrum. -! W3SIN3 Subr. Public WAM4+ input source term. -! INSIN3 Subr. Public Corresponding initialization routine. -! TABU_STRESS, TABU_TAUHF, TABU_TAUHF2 -! Subr. Public Populate various tables. -! CALC_USTAR -! Subr. Public Compute stresses. -! W3SDS3 Subr. Public User supplied dissipation. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - USE CONSTANTS, ONLY: KAPPA, nu_air +MODULE W3SRC3MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III SHOM | + !/ ! F. Ardhuin ! + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 02-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 09-Oct-2007 : Origination. ( version 3.13 ) + !/ 10-Oct-2010 : Adding Janssen-style swell damping ( version 3.14) + !/ 02-Sep-2012 : Clean up test output T, T0, T1 ( version 4.07 ) + !/ + ! 1. Purpose : + ! + ! The 'WAM4+' source terms based on P.A.E.M. Janssen's work, with + ! extensions by him and by J.-R. Bidlot. Converted from the original + ! WAM codes by F. Ardhuin, with further extensions to adapt to a + ! saturation-based breaking and observation-based swell dissipation + ! + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SPR3 Subr. Public Mean parameters from spectrum. + ! W3SIN3 Subr. Public WAM4+ input source term. + ! INSIN3 Subr. Public Corresponding initialization routine. + ! TABU_STRESS, TABU_TAUHF, TABU_TAUHF2 + ! Subr. Public Populate various tables. + ! CALC_USTAR + ! Subr. Public Compute stresses. + ! W3SDS3 Subr. Public User supplied dissipation. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + USE CONSTANTS, ONLY: KAPPA, nu_air - IMPLICIT NONE + IMPLICIT NONE - PUBLIC -!/ -!/ Public variables -!/ - !air kinematic viscosity (used in WAM) - INTEGER, PARAMETER :: ITAUMAX=200,JUMAX=200 - INTEGER, PARAMETER :: IUSTAR=100,IALPHA=200, ILEVTAIL=50 - REAL :: TAUT(0:ITAUMAX,0:JUMAX), DELTAUW, DELU - ! Table for H.F. stress as a function of 2 variables - REAL :: TAUHFT(0:IUSTAR,0:IALPHA), DELUST, DELALP - REAL, PARAMETER :: UMAX = 50. - REAL, PARAMETER :: TAUWMAX = 2.2361 !SQRT(5.) -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, WNMEAN, & - AMAX, U, UDIR, USTAR, USDIR, TAUWX, TAUWY, CD, Z0,& - CHARN, LLWS, FMEANWS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III SHOM | -!/ ! F. Ardhuin ! -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 17-Oct-2007 | -!/ +-----------------------------------+ -!/ -!/ 03-Oct-2007 : Origination. ( version 3.13 ) -!/ -! 1. Purpose : -! -! Calculate mean wave parameters for the use in the source term -! routines. -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum. -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! EMEAN Real O Energy -! FMEAN Real O Mean frequency for determination of tail -! FMEANS Real O Mean frequency for dissipation source term -! WNMEAN Real O Mean wavenumber. -! AMAX Real O Maximum of action spectrum. -! U Real I Wind speed. -! UDIR Real I Wind direction. -! USTAR Real I/O Friction velocity. -! USDIR Real I/O wind stress direction. -! TAUWX-Y Real I Components of wave-supported stress. -! CD Real O Drag coefficient at wind level ZWND. -! Z0 Real O Corresponding z0. -! LLWS L.A. I Wind sea true/false array for each component -! FMEANWS Real O Mean frequency of wind sea, used for tail -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3SRCE Source term integration routine. -! W3OUTP Point output program. -! GXEXPO GrADS point output program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPIINV - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, WWNMEANP, & - WWNMEANPTAIL, FTE, FTF, SSTXFTF, SSTXFTWN,& - SSTXFTFTAIL, SSWELLF + PUBLIC + !/ + !/ Public variables + !/ + !air kinematic viscosity (used in WAM) + INTEGER, PARAMETER :: ITAUMAX=200,JUMAX=200 + INTEGER, PARAMETER :: IUSTAR=100,IALPHA=200, ILEVTAIL=50 + REAL :: TAUT(0:ITAUMAX,0:JUMAX), DELTAUW, DELU + ! Table for H.F. stress as a function of 2 variables + REAL :: TAUHFT(0:IUSTAR,0:IALPHA), DELUST, DELALP + REAL, PARAMETER :: UMAX = 50. + REAL, PARAMETER :: TAUWMAX = 2.2361 !SQRT(5.) + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, WNMEAN, & + AMAX, U, UDIR, USTAR, USDIR, TAUWX, TAUWY, CD, Z0,& + CHARN, LLWS, FMEANWS) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III SHOM | + !/ ! F. Ardhuin ! + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 17-Oct-2007 | + !/ +-----------------------------------+ + !/ + !/ 03-Oct-2007 : Origination. ( version 3.13 ) + !/ + ! 1. Purpose : + ! + ! Calculate mean wave parameters for the use in the source term + ! routines. + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum. + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! EMEAN Real O Energy + ! FMEAN Real O Mean frequency for determination of tail + ! FMEANS Real O Mean frequency for dissipation source term + ! WNMEAN Real O Mean wavenumber. + ! AMAX Real O Maximum of action spectrum. + ! U Real I Wind speed. + ! UDIR Real I Wind direction. + ! USTAR Real I/O Friction velocity. + ! USDIR Real I/O wind stress direction. + ! TAUWX-Y Real I Components of wave-supported stress. + ! CD Real O Drag coefficient at wind level ZWND. + ! Z0 Real O Corresponding z0. + ! LLWS L.A. I Wind sea true/false array for each component + ! FMEANWS Real O Mean frequency of wind sea, used for tail + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3SRCE Source term integration routine. + ! W3OUTP Point output program. + ! GXEXPO GrADS point output program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPIINV + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, WWNMEANP, & + WWNMEANPTAIL, FTE, FTF, SSTXFTF, SSTXFTWN,& + SSTXFTFTAIL, SSWELLF #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK), U, UDIR - REAL, INTENT(IN) :: TAUWX, TAUWY - LOGICAL, INTENT(IN) :: LLWS(NSPEC) - REAL, INTENT(INOUT) :: USTAR ,USDIR - REAL, INTENT(OUT) :: EMEAN, FMEAN, FMEANS, WNMEAN, AMAX, & - CD, Z0, CHARN, FMEANWS -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS, IK, ITH + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK), U, UDIR + REAL, INTENT(IN) :: TAUWX, TAUWY + LOGICAL, INTENT(IN) :: LLWS(NSPEC) + REAL, INTENT(INOUT) :: USTAR ,USDIR + REAL, INTENT(OUT) :: EMEAN, FMEAN, FMEANS, WNMEAN, AMAX, & + CD, Z0, CHARN, FMEANWS + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS, IK, ITH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: TAUW, EBAND, EMEANWS, UNZ, & - EB(NK),EB2(NK),ALFA(NK) -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: TAUW, EBAND, EMEANWS, UNZ, & + EB(NK),EB2(NK),ALFA(NK) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SPR3') + CALL STRACE (IENT, 'W3SPR3') #endif -! - UNZ = MAX ( 0.01 , U ) - USTAR = MAX ( 0.0001 , USTAR ) -! - EMEAN = 0. - EMEANWS= 0. - FMEANWS= 0. - FMEAN = 0. - FMEANS = 0. - WNMEAN = 0. - AMAX = 0. -! -! 1. Integral over directions and maximum --------------------------- * -! - DO IK=1, NK - EB(IK) = 0. - EB2(IK) = 0. - DO ITH=1, NTH - IS=ITH+(IK-1)*NTH - EB(IK) = EB(IK) + A(ITH,IK) - IF (LLWS(IS)) EB2(IK) = EB2(IK) + A(ITH,IK) - AMAX = MAX ( AMAX , A(ITH,IK) ) - END DO - END DO -! -! 2. Integrate over directions -------------------------------------- * -! - DO IK=1, NK - ALFA(IK) = 2. * DTH * SIG(IK) * EB(IK) * WN(IK)**3 - EB(IK) = EB(IK) * DDEN(IK) / CG(IK) - EB2(IK) = EB2(IK) * DDEN(IK) / CG(IK) - EMEAN = EMEAN + EB(IK) - FMEAN = FMEAN + EB(IK) *(SIG(IK)**(2.*WWNMEANPTAIL)) - FMEANS = FMEANS + EB(IK) *(SIG(IK)**(2.*WWNMEANP)) - WNMEAN = WNMEAN + EB(IK) *(WN(IK)**WWNMEANP) - EMEANWS = EMEANWS+ EB2(IK) - FMEANWS = FMEANWS+ EB2(IK)*(SIG(IK)**(2.*WWNMEANPTAIL)) - END DO -! -! 3. Add tail beyond discrete spectrum and get mean pars ------------ * -! ( DTH * SIG absorbed in FTxx ) -! - EBAND = EB(NK) / DDEN(NK) - EMEAN = EMEAN + EBAND * FTE - FMEAN = FMEAN + EBAND * SSTXFTFTAIL - FMEANS = FMEANS + EBAND * SSTXFTF - WNMEAN = WNMEAN + EBAND * SSTXFTWN - EBAND = EB2(NK) / DDEN(NK) - EMEANWS = EMEANWS + EBAND * FTE - FMEANWS = FMEANWS + EBAND * SSTXFTFTAIL -! -! 4. Final processing -! + ! + UNZ = MAX ( 0.01 , U ) + USTAR = MAX ( 0.0001 , USTAR ) + ! + EMEAN = 0. + EMEANWS= 0. + FMEANWS= 0. + FMEAN = 0. + FMEANS = 0. + WNMEAN = 0. + AMAX = 0. + ! + ! 1. Integral over directions and maximum --------------------------- * + ! + DO IK=1, NK + EB(IK) = 0. + EB2(IK) = 0. + DO ITH=1, NTH + IS=ITH+(IK-1)*NTH + EB(IK) = EB(IK) + A(ITH,IK) + IF (LLWS(IS)) EB2(IK) = EB2(IK) + A(ITH,IK) + AMAX = MAX ( AMAX , A(ITH,IK) ) + END DO + END DO + ! + ! 2. Integrate over directions -------------------------------------- * + ! + DO IK=1, NK + ALFA(IK) = 2. * DTH * SIG(IK) * EB(IK) * WN(IK)**3 + EB(IK) = EB(IK) * DDEN(IK) / CG(IK) + EB2(IK) = EB2(IK) * DDEN(IK) / CG(IK) + EMEAN = EMEAN + EB(IK) + FMEAN = FMEAN + EB(IK) *(SIG(IK)**(2.*WWNMEANPTAIL)) + FMEANS = FMEANS + EB(IK) *(SIG(IK)**(2.*WWNMEANP)) + WNMEAN = WNMEAN + EB(IK) *(WN(IK)**WWNMEANP) + EMEANWS = EMEANWS+ EB2(IK) + FMEANWS = FMEANWS+ EB2(IK)*(SIG(IK)**(2.*WWNMEANPTAIL)) + END DO + ! + ! 3. Add tail beyond discrete spectrum and get mean pars ------------ * + ! ( DTH * SIG absorbed in FTxx ) + ! + EBAND = EB(NK) / DDEN(NK) + EMEAN = EMEAN + EBAND * FTE + FMEAN = FMEAN + EBAND * SSTXFTFTAIL + FMEANS = FMEANS + EBAND * SSTXFTF + WNMEAN = WNMEAN + EBAND * SSTXFTWN + EBAND = EB2(NK) / DDEN(NK) + EMEANWS = EMEANWS + EBAND * FTE + FMEANWS = FMEANWS + EBAND * SSTXFTFTAIL + ! + ! 4. Final processing + ! - IF (FMEAN.LT.1.E-7) THEN - FMEAN=TPIINV * SIG(NK) - ELSE + IF (FMEAN.LT.1.E-7) THEN + FMEAN=TPIINV * SIG(NK) + ELSE FMEAN = TPIINV *( MAX ( 1.E-7 , FMEAN ) & - / MAX ( 1.E-7 , EMEAN ))**(1/(2.*WWNMEANPTAIL)) - END IF - IF (FMEANS.LT.1.E-7) THEN - FMEANS=TPIINV * SIG(NK) - ELSE - FMEANS = TPIINV *( MAX ( 1.E-7 , FMEANS ) & - / MAX ( 1.E-7 , EMEAN ))**(1/(2.*WWNMEANP)) - END IF - WNMEAN = ( MAX ( 1.E-7 , WNMEAN ) & - / MAX ( 1.E-7 , EMEAN ) )**(1/WWNMEANP) - IF (FMEANWS.LT.1.E-7.OR.EMEANWS.LT.1.E-7) THEN - FMEANWS=TPIINV * SIG(NK) - ELSE - FMEANWS = TPIINV *( MAX ( 1.E-7 , FMEANWS ) & - / MAX ( 1.E-7 , EMEANWS ))**(1/(2.*WWNMEANPTAIL)) - END IF -! -! 5. Cd and z0 ----------------------------------------------- * -! - TAUW = SQRT(TAUWX**2+TAUWY**2) - - Z0=0. - CALL CALC_USTAR(U,TAUW,USTAR,Z0,CHARN) - UNZ = MAX ( 0.01 , U ) - CD = (USTAR/UNZ)**2 - USDIR = UDIR -! -! 6. Final test output ---------------------------------------------- * -! + / MAX ( 1.E-7 , EMEAN ))**(1/(2.*WWNMEANPTAIL)) + END IF + IF (FMEANS.LT.1.E-7) THEN + FMEANS=TPIINV * SIG(NK) + ELSE + FMEANS = TPIINV *( MAX ( 1.E-7 , FMEANS ) & + / MAX ( 1.E-7 , EMEAN ))**(1/(2.*WWNMEANP)) + END IF + WNMEAN = ( MAX ( 1.E-7 , WNMEAN ) & + / MAX ( 1.E-7 , EMEAN ) )**(1/WWNMEANP) + IF (FMEANWS.LT.1.E-7.OR.EMEANWS.LT.1.E-7) THEN + FMEANWS=TPIINV * SIG(NK) + ELSE + FMEANWS = TPIINV *( MAX ( 1.E-7 , FMEANWS ) & + / MAX ( 1.E-7 , EMEANWS ))**(1/(2.*WWNMEANPTAIL)) + END IF + ! + ! 5. Cd and z0 ----------------------------------------------- * + ! + TAUW = SQRT(TAUWX**2+TAUWY**2) + + Z0=0. + CALL CALC_USTAR(U,TAUW,USTAR,Z0,CHARN) + UNZ = MAX ( 0.01 , U ) + CD = (USTAR/UNZ)**2 + USDIR = UDIR + ! + ! 6. Final test output ---------------------------------------------- * + ! #ifdef W3_T - WRITE (NDST,9060) EMEAN, WNMEAN, TPIINV, USTAR, CD, Z0 + WRITE (NDST,9060) EMEAN, WNMEAN, TPIINV, USTAR, CD, Z0 #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9060 FORMAT (' TEST W3SPR3 : E,WN MN :',F8.3,F8.4/ & - ' TPIINV, USTAR, CD, Z0 :',F8.3,F7.2,1X,2F9.5) +9060 FORMAT (' TEST W3SPR3 : E,WN MN :',F8.3,F8.4/ & + ' TPIINV, USTAR, CD, Z0 :',F8.3,F7.2,1X,2F9.5) #endif -!/ -!/ End of W3SPR3 ----------------------------------------------------- / -!/ + !/ + !/ End of W3SPR3 ----------------------------------------------------- / + !/ END SUBROUTINE W3SPR3 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SIN3 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & - TAUWX, TAUWY, TAUWNX, TAUWNY, ICE, S, D, LLWS, IX, IY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III SHOM | -!/ ! F. Ardhuin ! -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 02-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 09-Oct-2007 : Origination. ( version 3.13 ) -!/ 16-May-2010 : Adding sea ice ( version 3.14_Ifremer ) -!/ 02-Sep-2012 : Clean up test output T, T0, T1 ( version 4.07 ) -!/ -! 1. Purpose : -! -! Calculate diagonal and input source term for WAM4+ approach. -! -! 2. Method : -! -! WAM-4 : Janssen et al. -! WAM-"4.5" : gustiness effect (Cavaleri et al. ) -! SWELLF: damping coefficient (=1) for Janssen (2004) theory -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D). -! CG R.A. I Group speed *) -! K R.A. I Wavenumber for entire spectrum. *) -! U Real I WIND SPEED -! USTAR Real I Friction velocity. -! DRAT Real I Air/water density ratio. -! AS Real I Air-sea temperature difference -! USDIR Real I wind stress direction -! Z0 Real I Air-side roughness lengh. -! CD Real I Wind drag coefficient. -! USDIR Real I Direction of friction velocity -! TAUWX-Y Real I Components of the wave-supported stress. -! TAUWNX Real I Component of the negative wave-supported stress. -! TAUWNY Real I Component of the negative wave-supported stress. -! ICE Real I Sea ice fraction. !/Stefan: ICE is DUMMY argument; remove later. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative. *) -! LLWS L.A. O Wind sea true/false array for each component -! ---------------------------------------------------------------- -! *) Stored as 1-D array with dimension NTH*NK -! -! 4. Subroutines used : -! -! STRACE Subroutine tracing. ( !/S switch ) -! PRT2DS Print plot of spectrum. ( !/T0 switch ) -! OUTMAT Print out matrix. ( !/T1 switch ) -! -! 5. Called by : -! -! W3SRCE Source term integration. -! W3EXPO Point output program. -! GXEXPO GrADS point output program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, TPI + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SIN3 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & + TAUWX, TAUWY, TAUWNX, TAUWNY, ICE, S, D, LLWS, IX, IY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III SHOM | + !/ ! F. Ardhuin ! + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 02-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 09-Oct-2007 : Origination. ( version 3.13 ) + !/ 16-May-2010 : Adding sea ice ( version 3.14_Ifremer ) + !/ 02-Sep-2012 : Clean up test output T, T0, T1 ( version 4.07 ) + !/ + ! 1. Purpose : + ! + ! Calculate diagonal and input source term for WAM4+ approach. + ! + ! 2. Method : + ! + ! WAM-4 : Janssen et al. + ! WAM-"4.5" : gustiness effect (Cavaleri et al. ) + ! SWELLF: damping coefficient (=1) for Janssen (2004) theory + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D). + ! CG R.A. I Group speed *) + ! K R.A. I Wavenumber for entire spectrum. *) + ! U Real I WIND SPEED + ! USTAR Real I Friction velocity. + ! DRAT Real I Air/water density ratio. + ! AS Real I Air-sea temperature difference + ! USDIR Real I wind stress direction + ! Z0 Real I Air-side roughness lengh. + ! CD Real I Wind drag coefficient. + ! USDIR Real I Direction of friction velocity + ! TAUWX-Y Real I Components of the wave-supported stress. + ! TAUWNX Real I Component of the negative wave-supported stress. + ! TAUWNY Real I Component of the negative wave-supported stress. + ! ICE Real I Sea ice fraction. !/Stefan: ICE is DUMMY argument; remove later. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative. *) + ! LLWS L.A. O Wind sea true/false array for each component + ! ---------------------------------------------------------------- + ! *) Stored as 1-D array with dimension NTH*NK + ! + ! 4. Subroutines used : + ! + ! STRACE Subroutine tracing. ( !/S switch ) + ! PRT2DS Print plot of spectrum. ( !/T0 switch ) + ! OUTMAT Print out matrix. ( !/T1 switch ) + ! + ! 5. Called by : + ! + ! W3SRCE Source term integration. + ! W3EXPO Point output program. + ! GXEXPO GrADS point output program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, TPI #ifdef W3_T - USE CONSTANTS, ONLY: RADE + USE CONSTANTS, ONLY: RADE #endif - USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, DDEN, SIG, SIG2, TH, & - ESIN, ECOS, EC2, ZZWND, AALPHA, BBETA, ZZALP,& - SSWELLF, & - DDEN2, DTH, SSINTHP,ZZ0RAT + USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, DDEN, SIG, SIG2, TH, & + ESIN, ECOS, EC2, ZZWND, AALPHA, BBETA, ZZALP,& + SSWELLF, & + DDEN2, DTH, SSINTHP,ZZ0RAT #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_T0 - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_T1 - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NSPEC) - REAL, INTENT(IN) :: CG(NK), K(NSPEC),Z0,U, CD - REAL, INTENT(IN) :: USTAR, USDIR, AS, DRAT, ICE !/Stefan: ICE is DUMMY argument; remove later. - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC), TAUWX, TAUWY, TAUWNX, TAUWNY - LOGICAL, INTENT(OUT) :: LLWS(NSPEC) - INTEGER, INTENT(IN) :: IX, IY -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS,IK,ITH + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NSPEC) + REAL, INTENT(IN) :: CG(NK), K(NSPEC),Z0,U, CD + REAL, INTENT(IN) :: USTAR, USDIR, AS, DRAT, ICE !/Stefan: ICE is DUMMY argument; remove later. + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC), TAUWX, TAUWY, TAUWNX, TAUWNY + LOGICAL, INTENT(OUT) :: LLWS(NSPEC) + INTEGER, INTENT(IN) :: IX, IY + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS,IK,ITH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: COSU, SINU, TAUX, TAUY - REAL :: UST2, TAUW, TAUWB - REAL , PARAMETER :: EPS1 = 0.00001, EPS2 = 0.000001 + REAL :: COSU, SINU, TAUX, TAUY + REAL :: UST2, TAUW, TAUWB + REAL , PARAMETER :: EPS1 = 0.00001, EPS2 = 0.000001 #ifdef W3_STAB3 - REAL :: Usigma !standard deviation of U due to gustiness - REAL :: USTARsigma !standard deviation of USTAR due to gustiness + REAL :: Usigma !standard deviation of U due to gustiness + REAL :: USTARsigma !standard deviation of USTAR due to gustiness #endif - REAL :: CM,UCO,UCN,ZCN, & - Z0VISC - REAL XI,DELI1,DELI2 - REAL XJ,DELJ1,DELJ2 - REAL :: CONST, CONST0, CONST2, CONST3, TAU1 - REAL :: X,ZARG,ZLOG,ZBETA,UST - REAL COSWIND,XSTRESS,YSTRESS,TAUHF - REAL TEMP, TEMP2 - INTEGER IND,J,ISTAB - REAL DSTAB(3,NSPEC) - REAL STRESSSTAB(3,2),STRESSSTABN(3,2) + REAL :: CM,UCO,UCN,ZCN, & + Z0VISC + REAL XI,DELI1,DELI2 + REAL XJ,DELJ1,DELJ2 + REAL :: CONST, CONST0, CONST2, CONST3, TAU1 + REAL :: X,ZARG,ZLOG,ZBETA,UST + REAL COSWIND,XSTRESS,YSTRESS,TAUHF + REAL TEMP, TEMP2 + INTEGER IND,J,ISTAB + REAL DSTAB(3,NSPEC) + REAL STRESSSTAB(3,2),STRESSSTABN(3,2) #ifdef W3_T0 - REAL :: DOUT(NK,NTH) + REAL :: DOUT(NK,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIN3') + CALL STRACE (IENT, 'W3SIN3') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) BBETA, USTAR, USDIR*RADE + WRITE (NDST,9000) BBETA, USTAR, USDIR*RADE #endif -! -! 1. Preparations -! -! JDM: initializing arrays (shouldn't change answers) - DSTAB=0.; STRESSSTAB=0. ;STRESSSTABN=0. -! -! 1.a estimation of surface roughness parameters -! - Z0VISC = 0.1*nu_air/MAX(USTAR,0.0001) -! -! 2. Diagonal -! -! Here AS is the air-sea temperature difference in degrees. Expression given by -! Abdalla & Cavaleri, JGR 2002 for Usigma. For USTARsigma ... I do not see where -! I got it from, maybe just made up from drag law ... -! + ! + ! 1. Preparations + ! + ! JDM: initializing arrays (shouldn't change answers) + DSTAB=0.; STRESSSTAB=0. ;STRESSSTABN=0. + ! + ! 1.a estimation of surface roughness parameters + ! + Z0VISC = 0.1*nu_air/MAX(USTAR,0.0001) + ! + ! 2. Diagonal + ! + ! Here AS is the air-sea temperature difference in degrees. Expression given by + ! Abdalla & Cavaleri, JGR 2002 for Usigma. For USTARsigma ... I do not see where + ! I got it from, maybe just made up from drag law ... + ! #ifdef W3_STAB3 - Usigma=MAX(0.,-0.025*AS) - USTARsigma=(1.0+U/(10.+U))*Usigma + Usigma=MAX(0.,-0.025*AS) + USTARsigma=(1.0+U/(10.+U))*Usigma #endif - UST=USTAR - ISTAB=3 + UST=USTAR + ISTAB=3 #ifdef W3_STAB3 - DO ISTAB=1,2 + DO ISTAB=1,2 IF (ISTAB.EQ.1) UST=USTAR*(1.-USTARsigma) IF (ISTAB.EQ.2) UST=USTAR*(1.+USTARsigma) #endif TAUX = UST**2* COS(USDIR) TAUY = UST**2* SIN(USDIR) -! -! Loop over the resolved part of the spectrum -! + ! + ! Loop over the resolved part of the spectrum + ! STRESSSTAB(ISTAB,:)=0. STRESSSTABN(ISTAB,:)=0. CONST0=BBETA*DRAT/(kappa**2) -! SSWELLF(1) is IDAMPING in ECMWAM + ! SSWELLF(1) is IDAMPING in ECMWAM CONST3 = SSWELLF(1)*2.*KAPPA*DRAT -! + ! COSU = COS(USDIR) SINU = SIN(USDIR) DO IK=1, NK IS=1+(IK-1)*NTH CM=K(IS)/SIG2(IS) !inverse of phase speed UCN=UST*CM+ZZALP !this is the inverse wave age -! -! the stress is the real stress (N/m^2) divided by -! rho_a, and thus comparable to USTAR**2 -! it is the integral of rho_w g Sin/C /rho_a -! (air-> waves momentum flux) -! + ! + ! the stress is the real stress (N/m^2) divided by + ! rho_a, and thus comparable to USTAR**2 + ! it is the integral of rho_w g Sin/C /rho_a + ! (air-> waves momentum flux) + ! CONST2=DDEN2(IS)/CG(IK) & !Jacobian to get energy in band - *GRAV/(SIG(IK)/K(IS)*DRAT) ! coefficient to get momentum - CONST=SIG2(IS)*CONST0 -! this CM parameter is 1 / C_phi -! this is the "correct" shallow-water expression -! here Z0 corresponds to Z0+Z1 of the Janssen eq. 14 + *GRAV/(SIG(IK)/K(IS)*DRAT) ! coefficient to get momentum + CONST=SIG2(IS)*CONST0 + ! this CM parameter is 1 / C_phi + ! this is the "correct" shallow-water expression + ! here Z0 corresponds to Z0+Z1 of the Janssen eq. 14 ZCN=ALOG(K(IS)*Z0) -! commented below is the original WAM version (OK for deep water) -! ZCN=ALOG(G*Z0b(I)*CM(I)**2) + ! commented below is the original WAM version (OK for deep water) + ! ZCN=ALOG(G*Z0b(I)*CM(I)**2) DO ITH=1,NTH IS=ITH+(IK-1)*NTH COSWIND=(ECOS(IS)*COSU+ESIN(IS)*SINU) IF (COSWIND.GT.0.01) THEN - X=COSWIND*UCN -! this ZARG term is the argument of the exponential -! in Janssen 1991 eq. 16. + X=COSWIND*UCN + ! this ZARG term is the argument of the exponential + ! in Janssen 1991 eq. 16. ZARG=KAPPA/X -! ZLOG is ALOG(MU) where MU is defined by Janssen 1991 eq. 15 - ZLOG=ZCN+ZARG + ! ZLOG is ALOG(MU) where MU is defined by Janssen 1991 eq. 15 + ZLOG=ZCN+ZARG ZBETA = CONST3*(COSWIND+KAPPA/(ZCN*UST*CM))*UCN**2 IF (ZLOG.LT.0.) THEN -! The source term Sp is beta * omega * X**2 -! as given by Janssen 1991 eq. 19 + ! The source term Sp is beta * omega * X**2 + ! as given by Janssen 1991 eq. 19 DSTAB(ISTAB,IS) = CONST*EXP(ZLOG)*ZLOG**4*UCN**2*COSWIND**SSINTHP LLWS(IS)=.TRUE. ELSE DSTAB(ISTAB,IS) = ZBETA LLWS(IS)=.TRUE. - END IF + END IF ELSE ZBETA = CONST3*(COSWIND+KAPPA/(ZCN*UST*CM))*UCN**2 DSTAB(ISTAB,IS) = ZBETA LLWS(IS)=.FALSE. - END IF -! + END IF + ! TEMP2=CONST2*DSTAB(ISTAB,IS)*A(IS) - IF (DSTAB(ISTAB,IS).LT.0) THEN + IF (DSTAB(ISTAB,IS).LT.0) THEN STRESSSTABN(ISTAB,1)=STRESSSTABN(ISTAB,1)+TEMP2*ECOS(IS) STRESSSTABN(ISTAB,2)=STRESSSTABN(ISTAB,2)+TEMP2*ESIN(IS) - END IF + END IF STRESSSTAB(ISTAB,1)=STRESSSTAB(ISTAB,1)+TEMP2*ECOS(IS) STRESSSTAB(ISTAB,2)=STRESSSTAB(ISTAB,2)+TEMP2*ESIN(IS) - END DO END DO -! - D(:)=DSTAB(3,:) - XSTRESS=STRESSSTAB (3,1) - YSTRESS=STRESSSTAB (3,2) - TAUWNX =STRESSSTABN(3,1) - TAUWNY =STRESSSTABN(3,2) -! WRITE(995,'(A,11G14.5)') 'NEGSTRESS: ',TAUWNX,TAUWNY,FW*UORB**3 + END DO + ! + D(:)=DSTAB(3,:) + XSTRESS=STRESSSTAB (3,1) + YSTRESS=STRESSSTAB (3,2) + TAUWNX =STRESSSTABN(3,1) + TAUWNY =STRESSSTABN(3,2) + ! WRITE(995,'(A,11G14.5)') 'NEGSTRESS: ',TAUWNX,TAUWNY,FW*UORB**3 #ifdef W3_STAB3 - END DO - D(:)=0.5*(DSTAB(1,:)+DSTAB(2,:)) - XSTRESS=0.5*(STRESSSTAB(1,1)+STRESSSTAB(2,1)) - YSTRESS=0.5*(STRESSSTAB(1,2)+STRESSSTAB(2,2)) - TAUWNX=0.5*(STRESSSTABN(1,1)+STRESSSTABN(2,1)) - TAUWNY=0.5*(STRESSSTABN(1,2)+STRESSSTABN(2,2)) + END DO + D(:)=0.5*(DSTAB(1,:)+DSTAB(2,:)) + XSTRESS=0.5*(STRESSSTAB(1,1)+STRESSSTAB(2,1)) + YSTRESS=0.5*(STRESSSTAB(1,2)+STRESSSTAB(2,2)) + TAUWNX=0.5*(STRESSSTABN(1,1)+STRESSSTABN(2,1)) + TAUWNY=0.5*(STRESSSTABN(1,2)+STRESSSTABN(2,2)) #endif - S = D * A -! -! ... Test output of arrays -! + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO -#endif -! -#ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1), ' ', 1., & - 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') #endif -! - ! Computes the high-frequency contribution - ! the difference in spectal density (kx,ky) to (f,theta) - ! is integrated in this modified CONST0 - CONST0=DTH*SIG(NK)**5/((GRAV**2)*tpi) & + ! + ! Computes the high-frequency contribution + ! the difference in spectal density (kx,ky) to (f,theta) + ! is integrated in this modified CONST0 + CONST0=DTH*SIG(NK)**5/((GRAV**2)*tpi) & *TPI*SIG(NK) / CG(NK) !conversion WAM (E(f,theta) to WW3 A(k,theta) - TEMP=0. - DO ITH=1,NTH - IS=ITH+(NK-1)*NTH - COSWIND=(ECOS(IS)*COSU+ESIN(IS)*SINU) - TEMP=TEMP+A(IS)*(MAX(COSWIND,0.))**3 - END DO -! -! finds the values in the tabulated stress TAUHFT -! - XI=UST/DELUST - IND = MAX(1,MIN (IUSTAR-1, INT(XI))) - DELI1= MAX(MIN (1. ,XI-FLOAT(IND)),0.) - DELI2= 1. - DELI1 - XJ=MAX(0.,(GRAV*Z0/MAX(UST,0.00001)**2-AALPHA) / DELALP) - J = MAX(1 ,MIN (IALPHA-1, INT(XJ))) - DELJ1= MAX(0.,MIN (1. , XJ-FLOAT(J))) - DELJ2=1. - DELJ1 - TAU1 =(TAUHFT(IND,J)*DELI2+TAUHFT(IND+1,J)*DELI1 )*DELJ2 & + TEMP=0. + DO ITH=1,NTH + IS=ITH+(NK-1)*NTH + COSWIND=(ECOS(IS)*COSU+ESIN(IS)*SINU) + TEMP=TEMP+A(IS)*(MAX(COSWIND,0.))**3 + END DO + ! + ! finds the values in the tabulated stress TAUHFT + ! + XI=UST/DELUST + IND = MAX(1,MIN (IUSTAR-1, INT(XI))) + DELI1= MAX(MIN (1. ,XI-FLOAT(IND)),0.) + DELI2= 1. - DELI1 + XJ=MAX(0.,(GRAV*Z0/MAX(UST,0.00001)**2-AALPHA) / DELALP) + J = MAX(1 ,MIN (IALPHA-1, INT(XJ))) + DELJ1= MAX(0.,MIN (1. , XJ-FLOAT(J))) + DELJ2=1. - DELJ1 + TAU1 =(TAUHFT(IND,J)*DELI2+TAUHFT(IND+1,J)*DELI1 )*DELJ2 & +(TAUHFT(IND,J+1)*DELI2+TAUHFT(IND+1,J+1)*DELI1)*DELJ1 - TAUHF = CONST0*TEMP*UST**2*TAU1 - TAUWX = XSTRESS+TAUHF*COS(USDIR) - TAUWY = YSTRESS+TAUHF*SIN(USDIR) -! -! Reduces tail effect to make sure that wave-supported stress -! is less than total stress, this is borrowed from ECWAM Stresso.F -! - TAUW = SQRT(TAUWX**2+TAUWY**2) - UST2 = MAX(USTAR,EPS2)**2 - TAUWB = MIN(TAUW,MAX(UST2-EPS1,EPS2**2)) - IF (TAUWB.LT.TAUW) THEN - TAUWX=TAUWX*TAUWB/TAUW - TAUWY=TAUWY*TAUWB/TAUW - END IF - - RETURN -! -! Formats -! + TAUHF = CONST0*TEMP*UST**2*TAU1 + TAUWX = XSTRESS+TAUHF*COS(USDIR) + TAUWY = YSTRESS+TAUHF*SIN(USDIR) + ! + ! Reduces tail effect to make sure that wave-supported stress + ! is less than total stress, this is borrowed from ECWAM Stresso.F + ! + TAUW = SQRT(TAUWX**2+TAUWY**2) + UST2 = MAX(USTAR,EPS2)**2 + TAUWB = MIN(TAUW,MAX(UST2-EPS1,EPS2**2)) + IF (TAUWB.LT.TAUW) THEN + TAUWX=TAUWX*TAUWB/TAUW + TAUWY=TAUWY*TAUWB/TAUW + END IF + + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SIN3 : COMMON FACT.: ',3E10.3) +9000 FORMAT (' TEST W3SIN3 : COMMON FACT.: ',3E10.3) #endif -!/ -!/ End of W3SIN3 ----------------------------------------------------- / -!/ + !/ + !/ End of W3SIN3 ----------------------------------------------------- / + !/ END SUBROUTINE W3SIN3 -!/ ------------------------------------------------------------------- / - SUBROUTINE INSIN3 -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | SHOM | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 23-Jul-2009 | -!/ +-----------------------------------+ -!/ -!/ 23-Jun-2006 : Origination. ( version 3.09 ) -!/ 23-Jul-2007 : Cleaning up convolutions ( version 3.14-SHOM) -! -! 1. Purpose : -! -! Initialization for source term routine. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SIN3 Subr. W3SRC3MD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPIINV - USE W3GDATMD, ONLY: SIG, NK + !/ ------------------------------------------------------------------- / + SUBROUTINE INSIN3 + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | SHOM | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 23-Jul-2009 | + !/ +-----------------------------------+ + !/ + !/ 23-Jun-2006 : Origination. ( version 3.09 ) + !/ 23-Jul-2007 : Cleaning up convolutions ( version 3.14-SHOM) + ! + ! 1. Purpose : + ! + ! Initialization for source term routine. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SIN3 Subr. W3SRC3MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPIINV + USE W3GDATMD, ONLY: SIG, NK #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INSIN3') + CALL STRACE (IENT, 'INSIN3') #endif -! -! 1. .... ----------------------------------------------------------- * -! - CALL TABU_STRESS - CALL TABU_TAUHF(SIG(NK) * TPIINV) !tabulate high-frequency stress -!/ -!/ End of INSIN3 ----------------------------------------------------- / -!/ - END SUBROUTINE INSIN3 -! ---------------------------------------------------------------------- - SUBROUTINE TABU_STRESS -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 17-Oct-2007 | -!/ +-----------------------------------+ -!/ -!/ 23-Jun-2006 : Origination. ( version 3.13 ) -!/ adapted from WAM, original:P.A.E.M. JANSSEN KNMI AUGUST 1990 -!/ adapted version (subr. STRESS): J. BIDLOT ECMWF OCTOBER 2004 -!/ Table values were checkes against the original f90 result and found to -!/ be identical (at least at 0.001 m/s accuracy) -!/ -! 1. Purpose : -! TO GENERATE friction velocity table TAUT(TAUW,U10)=SQRT(TAU). -! METHOD. -! A STEADY STATE WIND PROFILE IS ASSUMED. -! THE WIND STRESS IS COMPUTED USING THE ROUGHNESSLENGTH -! Z1=Z0/SQRT(1-TAUW/TAU) -! WHERE Z0 IS THE CHARNOCK RELATION , TAUW IS THE WAVE- -! INDUCED STRESS AND TAU IS THE TOTAL STRESS. -! WE SEARCH FOR STEADY-STATE SOLUTIONS FOR WHICH TAUW/TAU < 1. -! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. -! -! Initialization for source term routine. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SIN3 Subr. W3SRC3MD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV - USE W3GDATMD, ONLY: ZZWND, AALPHA, ZZ0MAX - IMPLICIT NONE - INTEGER, PARAMETER :: NITER=10 - REAL , PARAMETER :: XM=0.50, EPS1=0.00001 -! VARIABLE. TYPE. PURPOSE. -! *XM* REAL POWER OF TAUW/TAU IN ROUGHNESS LENGTH. -! *XNU* REAL KINEMATIC VISCOSITY OF AIR. -! *NITER* INTEGER NUMBER OF ITERATIONS TO OBTAIN TOTAL STRESS -! *EPS1* REAL SMALL NUMBER TO MAKE SURE THAT A SOLUTION -! IS OBTAINED IN ITERATION WITH TAU>TAUW. -! ---------------------------------------------------------------------- - INTEGER I,J,ITER - REAL ZTAUW,UTOP,CDRAG,WCD,USTOLD,TAUOLD - REAL X,UST,ZZ0,ZNU,F,DELF,ZZ00 -! -! - DELU = UMAX/FLOAT(JUMAX) - DELTAUW = TAUWMAX/FLOAT(ITAUMAX) - DO I=0,ITAUMAX - ZTAUW = (REAL(I)*DELTAUW)**2 - DO J=0,JUMAX - UTOP = FLOAT(J)*DELU - CDRAG = 0.0012875 - WCD = SQRT(CDRAG) - USTOLD = UTOP*WCD - TAUOLD = MAX(USTOLD**2, ZTAUW+EPS1) - DO ITER=1,NITER - X = ZTAUW/TAUOLD - UST = SQRT(TAUOLD) - ZZ00=AALPHA*TAUOLD/GRAV - IF (ZZ0MAX.NE.0) ZZ00=MIN(ZZ00,ZZ0MAX) - ! Corrects roughness ZZ00 for quasi-linear effect - ZZ0 = ZZ00/(1.-X)**XM - !ZNU = 0.1*nu_air/UST ! This was removed by Bidlot in 1996 + ! + ! 1. .... ----------------------------------------------------------- * + ! + CALL TABU_STRESS + CALL TABU_TAUHF(SIG(NK) * TPIINV) !tabulate high-frequency stress + !/ + !/ End of INSIN3 ----------------------------------------------------- / + !/ + END SUBROUTINE INSIN3 + ! ---------------------------------------------------------------------- + SUBROUTINE TABU_STRESS + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 17-Oct-2007 | + !/ +-----------------------------------+ + !/ + !/ 23-Jun-2006 : Origination. ( version 3.13 ) + !/ adapted from WAM, original:P.A.E.M. JANSSEN KNMI AUGUST 1990 + !/ adapted version (subr. STRESS): J. BIDLOT ECMWF OCTOBER 2004 + !/ Table values were checkes against the original f90 result and found to + !/ be identical (at least at 0.001 m/s accuracy) + !/ + ! 1. Purpose : + ! TO GENERATE friction velocity table TAUT(TAUW,U10)=SQRT(TAU). + ! METHOD. + ! A STEADY STATE WIND PROFILE IS ASSUMED. + ! THE WIND STRESS IS COMPUTED USING THE ROUGHNESSLENGTH + ! Z1=Z0/SQRT(1-TAUW/TAU) + ! WHERE Z0 IS THE CHARNOCK RELATION , TAUW IS THE WAVE- + ! INDUCED STRESS AND TAU IS THE TOTAL STRESS. + ! WE SEARCH FOR STEADY-STATE SOLUTIONS FOR WHICH TAUW/TAU < 1. + ! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. + ! + ! Initialization for source term routine. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SIN3 Subr. W3SRC3MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV + USE W3GDATMD, ONLY: ZZWND, AALPHA, ZZ0MAX + IMPLICIT NONE + INTEGER, PARAMETER :: NITER=10 + REAL , PARAMETER :: XM=0.50, EPS1=0.00001 + ! VARIABLE. TYPE. PURPOSE. + ! *XM* REAL POWER OF TAUW/TAU IN ROUGHNESS LENGTH. + ! *XNU* REAL KINEMATIC VISCOSITY OF AIR. + ! *NITER* INTEGER NUMBER OF ITERATIONS TO OBTAIN TOTAL STRESS + ! *EPS1* REAL SMALL NUMBER TO MAKE SURE THAT A SOLUTION + ! IS OBTAINED IN ITERATION WITH TAU>TAUW. + ! ---------------------------------------------------------------------- + INTEGER I,J,ITER + REAL ZTAUW,UTOP,CDRAG,WCD,USTOLD,TAUOLD + REAL X,UST,ZZ0,ZNU,F,DELF,ZZ00 + ! + ! + DELU = UMAX/FLOAT(JUMAX) + DELTAUW = TAUWMAX/FLOAT(ITAUMAX) + DO I=0,ITAUMAX + ZTAUW = (REAL(I)*DELTAUW)**2 + DO J=0,JUMAX + UTOP = FLOAT(J)*DELU + CDRAG = 0.0012875 + WCD = SQRT(CDRAG) + USTOLD = UTOP*WCD + TAUOLD = MAX(USTOLD**2, ZTAUW+EPS1) + DO ITER=1,NITER + X = ZTAUW/TAUOLD + UST = SQRT(TAUOLD) + ZZ00=AALPHA*TAUOLD/GRAV + IF (ZZ0MAX.NE.0) ZZ00=MIN(ZZ00,ZZ0MAX) + ! Corrects roughness ZZ00 for quasi-linear effect + ZZ0 = ZZ00/(1.-X)**XM + !ZNU = 0.1*nu_air/UST ! This was removed by Bidlot in 1996 !ZZ0 = MAX(ZNU,ZZ0) - F = UST-KAPPA*UTOP/(ALOG(ZZWND/ZZ0)) - DELF= 1.-KAPPA*UTOP/(ALOG(ZZWND/ZZ0))**2*2./UST & - *(1.-(XM+1)*X)/(1.-X) - UST = UST-F/DELF - TAUOLD= MAX(UST**2., ZTAUW+EPS1) - END DO - TAUT(I,J) = SQRT(TAUOLD) - END DO - END DO - I=ITAUMAX - J=JUMAX -! -! Force zero wind to have zero stress (Bidlot 1996) -! - DO I=0,ITAUMAX - TAUT(I,0)=0.0 + F = UST-KAPPA*UTOP/(ALOG(ZZWND/ZZ0)) + DELF= 1.-KAPPA*UTOP/(ALOG(ZZWND/ZZ0))**2*2./UST & + *(1.-(XM+1)*X)/(1.-X) + UST = UST-F/DELF + TAUOLD= MAX(UST**2., ZTAUW+EPS1) END DO - RETURN - END SUBROUTINE TABU_STRESS -!/ ------------------------------------------------------------------- / - SUBROUTINE TABU_TAUHF(FRMAX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update 2006/08/14 | -!/ +-----------------------------------+ -!/ -!/ 27-Feb-2004 : Origination in WW3 ( version 2.22.SHOM ) -!/ the resulting table was checked to be identical to the original f77 result -!/ 14-Aug-2006 : Modified following Bidlot ( version 2.22.SHOM ) -!/ 18-Aug-2006 : Ported to version 3.09 -! -! 1. Purpose : -! -! Tabulation of the high-frequency wave-supported stress -! -! 2. Method : -! -! SEE REFERENCE FOR WAVE STRESS CALCULATION. -! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. -! See tech. Memo ECMWF 03 december 2003 by Bidlot & Janssen -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FRMAX Real I maximum frequency. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3SIN3 Wind input Source term routine. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, TPI - USE W3GDATMD, ONLY: AALPHA, BBETA, ZZALP, XFR, FACHFE, ZZ0MAX + TAUT(I,J) = SQRT(TAUOLD) + END DO + END DO + I=ITAUMAX + J=JUMAX + ! + ! Force zero wind to have zero stress (Bidlot 1996) + ! + DO I=0,ITAUMAX + TAUT(I,0)=0.0 + END DO + RETURN + END SUBROUTINE TABU_STRESS + !/ ------------------------------------------------------------------- / + SUBROUTINE TABU_TAUHF(FRMAX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update 2006/08/14 | + !/ +-----------------------------------+ + !/ + !/ 27-Feb-2004 : Origination in WW3 ( version 2.22.SHOM ) + !/ the resulting table was checked to be identical to the original f77 result + !/ 14-Aug-2006 : Modified following Bidlot ( version 2.22.SHOM ) + !/ 18-Aug-2006 : Ported to version 3.09 + ! + ! 1. Purpose : + ! + ! Tabulation of the high-frequency wave-supported stress + ! + ! 2. Method : + ! + ! SEE REFERENCE FOR WAVE STRESS CALCULATION. + ! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. + ! See tech. Memo ECMWF 03 december 2003 by Bidlot & Janssen + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FRMAX Real I maximum frequency. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3SIN3 Wind input Source term routine. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, TPI + USE W3GDATMD, ONLY: AALPHA, BBETA, ZZALP, XFR, FACHFE, ZZ0MAX #ifdef W3_T - USE W3ODATMD, ONLY: NDST -#endif -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3ODATMD, ONLY: NDST #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, intent(in) :: FRMAX ! maximum frequency -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -! USTARM R.A. Maximum friction velocity -! ALPHAM R.A. Maximum Charnock Coefficient -! WLV R.A. Water levels. -! UA R.A. Absolute wind speeds. -! UD R.A. Absolute wind direction. -! U10 R.A. Wind speed used. -! U10D R.A. Wind direction used. -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - REAL :: USTARM, ALPHAM - REAL :: CONST1, OMEGA, OMEGAC - REAL :: UST, ZZ0,OMEGACC, CM - INTEGER, PARAMETER :: JTOT=250 - REAL, ALLOCATABLE :: W(:) - REAL :: ZX,ZARG,ZMU,ZLOG,ZZ00,ZBETA - REAL :: Y,YC,DELY - INTEGER :: I,J,K,L - REAL :: X0 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + USE W3SERVMD, ONLY: STRACE #endif -! + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, intent(in) :: FRMAX ! maximum frequency + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + ! USTARM R.A. Maximum friction velocity + ! ALPHAM R.A. Maximum Charnock Coefficient + ! WLV R.A. Water levels. + ! UA R.A. Absolute wind speeds. + ! UD R.A. Absolute wind direction. + ! U10 R.A. Wind speed used. + ! U10D R.A. Wind direction used. + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + REAL :: USTARM, ALPHAM + REAL :: CONST1, OMEGA, OMEGAC + REAL :: UST, ZZ0,OMEGACC, CM + INTEGER, PARAMETER :: JTOT=250 + REAL, ALLOCATABLE :: W(:) + REAL :: ZX,ZARG,ZMU,ZLOG,ZZ00,ZBETA + REAL :: Y,YC,DELY + INTEGER :: I,J,K,L + REAL :: X0 #ifdef W3_S - CALL STRACE (IENT, 'TABU_HF') + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'TABU_HF') #endif -! - USTARM = 5. - ALPHAM = 20.*AALPHA - DELUST = USTARM/REAL(IUSTAR) - DELALP = ALPHAM/REAL(IALPHA) - CONST1 = BBETA/KAPPA**2 - OMEGAC = TPI*FRMAX -! - TAUHFT(0:IUSTAR,0:IALPHA)=0. !table initialization -! - ALLOCATE(W(JTOT)) - W(2:JTOT-1)=1. - W(1)=0.5 - W(JTOT)=0.5 - X0 = 0.05 -! - DO L=0,IALPHA - DO K=0,IUSTAR - UST = MAX(REAL(K)*DELUST,0.000001) - ZZ00 = UST**2*AALPHA/GRAV - IF (ZZ0MAX.NE.0) ZZ00=MIN(ZZ00,ZZ0MAX) - ZZ0 = ZZ00*(1+FLOAT(L)*DELALP/AALPHA) - OMEGACC = MAX(OMEGAC,X0*GRAV/UST) - YC = OMEGACC*SQRT(ZZ0/GRAV) - DELY = MAX((1.-YC)/REAL(JTOT),0.) - ! For a given value of UST and ALPHA, - ! the wave-supported stress is integrated all the way - ! to 0.05*g/UST - DO J=1,JTOT - Y = YC+REAL(J-1)*DELY - OMEGA = Y*SQRT(GRAV/ZZ0) - ! This is the deep water phase speed - CM = GRAV/OMEGA - !this is the inverse wave age, shifted by ZZALP (tuning) - ZX = UST/CM +ZZALP - ZARG = MIN(KAPPA/ZX,20.) - ZMU = MIN(GRAV*ZZ0/CM**2*EXP(ZARG),1.) - ZLOG = MIN(ALOG(ZMU),0.) - ZBETA = CONST1*ZMU*ZLOG**4 - ! Power of Y in denominator should be FACHFE-4 - TAUHFT(K,L) = TAUHFT(K,L)+W(J)*ZBETA/Y*DELY - END DO - !IF (MOD(K,5).EQ.0.AND.MOD(L,5).EQ.0) & - !WRITE(102,'(2I4,3G16.8)') L,K,UST,AALPHA+FLOAT(L)*DELALP,TAUHFT(K,L) + ! + USTARM = 5. + ALPHAM = 20.*AALPHA + DELUST = USTARM/REAL(IUSTAR) + DELALP = ALPHAM/REAL(IALPHA) + CONST1 = BBETA/KAPPA**2 + OMEGAC = TPI*FRMAX + ! + TAUHFT(0:IUSTAR,0:IALPHA)=0. !table initialization + ! + ALLOCATE(W(JTOT)) + W(2:JTOT-1)=1. + W(1)=0.5 + W(JTOT)=0.5 + X0 = 0.05 + ! + DO L=0,IALPHA + DO K=0,IUSTAR + UST = MAX(REAL(K)*DELUST,0.000001) + ZZ00 = UST**2*AALPHA/GRAV + IF (ZZ0MAX.NE.0) ZZ00=MIN(ZZ00,ZZ0MAX) + ZZ0 = ZZ00*(1+FLOAT(L)*DELALP/AALPHA) + OMEGACC = MAX(OMEGAC,X0*GRAV/UST) + YC = OMEGACC*SQRT(ZZ0/GRAV) + DELY = MAX((1.-YC)/REAL(JTOT),0.) + ! For a given value of UST and ALPHA, + ! the wave-supported stress is integrated all the way + ! to 0.05*g/UST + DO J=1,JTOT + Y = YC+REAL(J-1)*DELY + OMEGA = Y*SQRT(GRAV/ZZ0) + ! This is the deep water phase speed + CM = GRAV/OMEGA + !this is the inverse wave age, shifted by ZZALP (tuning) + ZX = UST/CM +ZZALP + ZARG = MIN(KAPPA/ZX,20.) + ZMU = MIN(GRAV*ZZ0/CM**2*EXP(ZARG),1.) + ZLOG = MIN(ALOG(ZMU),0.) + ZBETA = CONST1*ZMU*ZLOG**4 + ! Power of Y in denominator should be FACHFE-4 + TAUHFT(K,L) = TAUHFT(K,L)+W(J)*ZBETA/Y*DELY + END DO + !IF (MOD(K,5).EQ.0.AND.MOD(L,5).EQ.0) & + !WRITE(102,'(2I4,3G16.8)') L,K,UST,AALPHA+FLOAT(L)*DELALP,TAUHFT(K,L) #ifdef W3_T - WRITE (NDST,9000) L,K,AALPHA+FLOAT(L)*DELALP,UST,TAUHFT(K,L) + WRITE (NDST,9000) L,K,AALPHA+FLOAT(L)*DELALP,UST,TAUHFT(K,L) #endif - END DO END DO - DEALLOCATE(W) -! DO L=0,IALPHA -! DO K=0,IUSTAR -!WRITE(101,'(A,2I4,G16.8)') 'L,K,TAUHFT(K,L):',L,K,TAUHFT(K,L) -! END DO -! END DO -!WRITE(101,*) 'TAUHFT:',FRMAX,BBETA,AALPHA,CONST1,OMEGAC,TPI -!WRITE(101,'(20G16.8)') TAUHFT - RETURN + END DO + DEALLOCATE(W) + ! DO L=0,IALPHA + ! DO K=0,IUSTAR + !WRITE(101,'(A,2I4,G16.8)') 'L,K,TAUHFT(K,L):',L,K,TAUHFT(K,L) + ! END DO + ! END DO + !WRITE(101,*) 'TAUHFT:',FRMAX,BBETA,AALPHA,CONST1,OMEGAC,TPI + !WRITE(101,'(20G16.8)') TAUHFT + RETURN #ifdef W3_T - 9000 FORMAT (' TABU_HF, L, K :',(2I4,3F8.3)/) +9000 FORMAT (' TABU_HF, L, K :',(2I4,3F8.3)/) #endif - END SUBROUTINE TABU_TAUHF -!/ ------------------------------------------------------------------- / + END SUBROUTINE TABU_TAUHF + !/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / - SUBROUTINE CALC_USTAR(WINDSPEED,TAUW,USTAR,Z0,CHARN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update 2006/08/14 | -!/ +-----------------------------------+ -!/ -!/ 27-Feb-2004 : Origination in WW3 ( version 2.22-SHOM ) -!/ the resulting table was checked to be identical to the original f77 result -!/ 14-Aug-2006 : Modified following Bidlot ( version 2.22-SHOM ) -!/ 18-Aug-2006 : Ported to version 3.09 -!/ 03-Apr-2010 : Adding output of Charnock parameter ( version 3.14-IFREMER ) -! -! 1. Purpose : -! -! Compute friction velocity based on wind speed U10 -! -! 2. Method : -! -! Computation of u* based on Quasi-linear theory -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! U10,TAUW,USTAR,Z0 -! ---------------------------------------------------------------- -! WINDSPEED Real I 10-m wind speed ... should be NEUTRAL -! TAUW Real I Wave-supported stress -! USTAR Real O Friction velocity. -! Z0 Real O air-side roughness length -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3SIN3 Wind input Source term routine. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -!-----------------------------------------------------------------------------! - USE CONSTANTS, ONLY: GRAV - USE W3GDATMD, ONLY: ZZWND, AALPHA - IMPLICIT NONE - REAL, intent(in) :: WINDSPEED,TAUW - REAL, intent(out) :: USTAR, Z0, CHARN - ! local variables - REAL SQRTCDM1 - REAL X,XI,DELI1,DELI2,XJ,delj1,delj2 - REAL UST,DELTOLD,TAUW_LOCAL - INTEGER IND,J -! - TAUW_LOCAL=MAX(MIN(TAUW,TAUWMAX),0.) - XI = SQRT(TAUW_LOCAL)/DELTAUW - IND = MIN ( ITAUMAX-1, INT(XI)) ! index for stress table - DELI1 = MIN(1.,XI - REAL(IND)) !interpolation coefficient for stress table - DELI2 = 1. - DELI1 - XJ = WINDSPEED/DELU - J = MIN ( JUMAX-1, INT(XJ) ) - DELJ1 = MIN(1.,XJ - REAL(J)) - DELJ2 = 1. - DELJ1 - USTAR=(TAUT(IND,J)*DELI2+TAUT(IND+1,J )*DELI1)*DELJ2 & - + (TAUT(IND,J+1)*DELI2+TAUT(IND+1,J+1)*DELI1)*DELJ1 - ! - ! Determines roughness length - ! - SQRTCDM1 = MIN(WINDSPEED/USTAR,100.0) - Z0 = ZZWND*EXP(-KAPPA*SQRTCDM1) - IF (USTAR.GT.0.001) THEN - CHARN = GRAV*Z0/USTAR**2 - ELSE - CHARN = AALPHA - END IF -! - RETURN - END SUBROUTINE CALC_USTAR -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SDS3 (A, K, CG, EMEAN, FMEAN, WNMEAN, USTAR, USDIR, & - DEPTH, S, D, IX, IY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ ! F. Ardhuin ! -!/ | FORTRAN 90 | -!/ | Last update : 23-Jul-2009 | -!/ +-----------------------------------+ -!/ -!/ 05-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 08-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 14-Aug-2006 : Generic WAM4+ dissipation term ( version 2.22SHOM ) -!/ 23-Jul-2009 : Addition of Filipot &al convolution ( version 3.14-SHOM ) -!/ -! 1. Purpose : -! -! Calculate whitecapping source term and diagonal term of derivative. -! -! 2. Method : -! -! WAM-Cycle 4 and following. -! The last update (09-May-2005) follows the redefinition of -! the mean wavenumber as in Bidlot et al. (2005). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D). -! K R.A. I Wavenumber for entire spectrum. *) -! EMEAN Real I Mean wave energy. -! FMEAN Real I Mean wave frequency. -! WNMEAN Real I Mean wavenumber. -! USTAR Real I Friction velocity. -! USDIR Real I wind stress direction. -! DEPTH Real I Water depth. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative. *) -! ---------------------------------------------------------------- -! *) Stored in 1-D array with dimension NTH*NK -! -! 4. Subroutines used : -! -! STRACE Subroutine tracing. ( !/S switch ) -! PRT2DS Print plot of spectrum. ( !/T0 switch ) -! OUTMAT Print out matrix. ( !/T1 switch ) -! -! 5. Called by : -! -! W3SRCE Source term integration. -! W3EXPO Point output program. -! GXEXPO GrADS point output program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, TPI - USE W3GDATMD, ONLY: NSPEC, NTH, NK, DDELTA1, DDELTA2, & + !/ ------------------------------------------------------------------- / + SUBROUTINE CALC_USTAR(WINDSPEED,TAUW,USTAR,Z0,CHARN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update 2006/08/14 | + !/ +-----------------------------------+ + !/ + !/ 27-Feb-2004 : Origination in WW3 ( version 2.22-SHOM ) + !/ the resulting table was checked to be identical to the original f77 result + !/ 14-Aug-2006 : Modified following Bidlot ( version 2.22-SHOM ) + !/ 18-Aug-2006 : Ported to version 3.09 + !/ 03-Apr-2010 : Adding output of Charnock parameter ( version 3.14-IFREMER ) + ! + ! 1. Purpose : + ! + ! Compute friction velocity based on wind speed U10 + ! + ! 2. Method : + ! + ! Computation of u* based on Quasi-linear theory + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! U10,TAUW,USTAR,Z0 + ! ---------------------------------------------------------------- + ! WINDSPEED Real I 10-m wind speed ... should be NEUTRAL + ! TAUW Real I Wave-supported stress + ! USTAR Real O Friction velocity. + ! Z0 Real O air-side roughness length + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3SIN3 Wind input Source term routine. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + !-----------------------------------------------------------------------------! + USE CONSTANTS, ONLY: GRAV + USE W3GDATMD, ONLY: ZZWND, AALPHA + IMPLICIT NONE + REAL, intent(in) :: WINDSPEED,TAUW + REAL, intent(out) :: USTAR, Z0, CHARN + ! local variables + REAL SQRTCDM1 + REAL X,XI,DELI1,DELI2,XJ,delj1,delj2 + REAL UST,DELTOLD,TAUW_LOCAL + INTEGER IND,J + ! + TAUW_LOCAL=MAX(MIN(TAUW,TAUWMAX),0.) + XI = SQRT(TAUW_LOCAL)/DELTAUW + IND = MIN ( ITAUMAX-1, INT(XI)) ! index for stress table + DELI1 = MIN(1.,XI - REAL(IND)) !interpolation coefficient for stress table + DELI2 = 1. - DELI1 + XJ = WINDSPEED/DELU + J = MIN ( JUMAX-1, INT(XJ) ) + DELJ1 = MIN(1.,XJ - REAL(J)) + DELJ2 = 1. - DELJ1 + USTAR=(TAUT(IND,J)*DELI2+TAUT(IND+1,J )*DELI1)*DELJ2 & + + (TAUT(IND,J+1)*DELI2+TAUT(IND+1,J+1)*DELI1)*DELJ1 + ! + ! Determines roughness length + ! + SQRTCDM1 = MIN(WINDSPEED/USTAR,100.0) + Z0 = ZZWND*EXP(-KAPPA*SQRTCDM1) + IF (USTAR.GT.0.001) THEN + CHARN = GRAV*Z0/USTAR**2 + ELSE + CHARN = AALPHA + END IF + ! + RETURN + END SUBROUTINE CALC_USTAR + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SDS3 (A, K, CG, EMEAN, FMEAN, WNMEAN, USTAR, USDIR, & + DEPTH, S, D, IX, IY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ ! F. Ardhuin ! + !/ | FORTRAN 90 | + !/ | Last update : 23-Jul-2009 | + !/ +-----------------------------------+ + !/ + !/ 05-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 08-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 14-Aug-2006 : Generic WAM4+ dissipation term ( version 2.22SHOM ) + !/ 23-Jul-2009 : Addition of Filipot &al convolution ( version 3.14-SHOM ) + !/ + ! 1. Purpose : + ! + ! Calculate whitecapping source term and diagonal term of derivative. + ! + ! 2. Method : + ! + ! WAM-Cycle 4 and following. + ! The last update (09-May-2005) follows the redefinition of + ! the mean wavenumber as in Bidlot et al. (2005). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D). + ! K R.A. I Wavenumber for entire spectrum. *) + ! EMEAN Real I Mean wave energy. + ! FMEAN Real I Mean wave frequency. + ! WNMEAN Real I Mean wavenumber. + ! USTAR Real I Friction velocity. + ! USDIR Real I wind stress direction. + ! DEPTH Real I Water depth. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative. *) + ! ---------------------------------------------------------------- + ! *) Stored in 1-D array with dimension NTH*NK + ! + ! 4. Subroutines used : + ! + ! STRACE Subroutine tracing. ( !/S switch ) + ! PRT2DS Print plot of spectrum. ( !/T0 switch ) + ! OUTMAT Print out matrix. ( !/T1 switch ) + ! + ! 5. Called by : + ! + ! W3SRCE Source term integration. + ! W3EXPO Point output program. + ! GXEXPO GrADS point output program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, TPI + USE W3GDATMD, ONLY: NSPEC, NTH, NK, DDELTA1, DDELTA2, & #ifdef W3_T0 - SIG, & + SIG, & #endif - SSDSC1 + SSDSC1 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_T1 - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NSPEC), K(NK), CG(NK), & - DEPTH, USTAR, USDIR, EMEAN, FMEAN, WNMEAN - INTEGER, INTENT(IN) :: IX, IY - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS, IK, ITH + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NSPEC), K(NK), CG(NK), & + DEPTH, USTAR, USDIR, EMEAN, FMEAN, WNMEAN + INTEGER, INTENT(IN) :: IX, IY + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS, IK, ITH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: FACTOR, FACTOR2 - REAL :: ALFAMEAN, WNMEAN2 + REAL :: FACTOR, FACTOR2 + REAL :: ALFAMEAN, WNMEAN2 #ifdef W3_T0 - REAL :: DOUT(NK,NTH) + REAL :: DOUT(NK,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SDS3') + CALL STRACE (IENT, 'W3SDS3') #endif -! -! 0. Pre-initialization of arrays, should be set before being used -! but this is helping with bit reproducibility - D=0. + ! + ! 0. Pre-initialization of arrays, should be set before being used + ! but this is helping with bit reproducibility + D=0. -! 1. Common factor -! - WNMEAN2 = MAX( 1.E-10 , WNMEAN ) - ALFAMEAN=WNMEAN**2*EMEAN - FACTOR = SSDSC1 * TPI*FMEAN * ALFAMEAN**2 -! + ! 1. Common factor + ! + WNMEAN2 = MAX( 1.E-10 , WNMEAN ) + ALFAMEAN=WNMEAN**2*EMEAN + FACTOR = SSDSC1 * TPI*FMEAN * ALFAMEAN**2 + ! #ifdef W3_T - WRITE (NDST,9000) SSDSC1, FMEAN, WNMEAN, EMEAN, FACTOR + WRITE (NDST,9000) SSDSC1, FMEAN, WNMEAN, EMEAN, FACTOR #endif -! -!---------------------------------------------------------------------- -! -! 2. Source term -! - DO IK=1, NK -! -! Original WAM4/WAM4+ dissipation term -! - FACTOR2=FACTOR*(DDELTA1*K(IK)/WNMEAN2 + DDELTA2*(K(IK)/WNMEAN2)**2) - DO ITH=1,NTH - IS=ITH+(IK-1)*NTH - D(IS)= FACTOR2 - END DO - END DO -! - S = D * A -! -! ... Test output of arrays -! -#ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO -#endif -! + ! + !---------------------------------------------------------------------- + ! + ! 2. Source term + ! + DO IK=1, NK + ! + ! Original WAM4/WAM4+ dissipation term + ! + FACTOR2=FACTOR*(DDELTA1*K(IK)/WNMEAN2 + DDELTA2*(K(IK)/WNMEAN2)**2) + DO ITH=1,NTH + IS=ITH+(IK-1)*NTH + D(IS)= FACTOR2 + END DO + END DO + ! + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1), ' ', 1., & - 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SDS3 : COMMON FACT.: ',5E10.3) +9000 FORMAT (' TEST W3SDS3 : COMMON FACT.: ',5E10.3) #endif -!/ -!/ End of W3SDS3 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SDS3 - - END MODULE W3SRC3MD + !/ + !/ End of W3SDS3 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SDS3 + +END MODULE W3SRC3MD diff --git a/model/src/w3src4md.F90 b/model/src/w3src4md.F90 index 438c85c46..004b4708f 100644 --- a/model/src/w3src4md.F90 +++ b/model/src/w3src4md.F90 @@ -1,602 +1,602 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SRC4MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III SHOM | -!/ ! F. Ardhuin ! -!/ | FORTRAN 90 | -!/ | Last update : 13-Nov-2013 | -!/ +-----------------------------------+ -!/ -!/ 30-Aug-2010 : Origination. ( version 3.14-Ifremer ) -!/ 02-Nov-2010 : Addding fudge factor for low freq. ( version 4.03 ) -!/ 02-Sep-2011 : Clean up and time optimization ( version 4.04 ) -!/ 04-Sep-2011 : Estimation of whitecap stats. ( version 4.04 ) -!/ 13-Nov-2013 : Reduced frequency range with IG ( version 4.13 ) -!/ -! 1. Purpose : -! -! The 'SHOM/Ifremer' source terms based on P.A.E.M. Janssen's wind input -! and dissipation functions by Ardhuin et al. (2009,2010) -! and Filipot & Ardhuin (2010) -! The wind input is converted from the original -! WAM codes, courtesy of P.A.E.M. Janssen and J. Bidlot -! -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SPR4 Subr. Public Mean parameters from spectrum. -! W3SIN4 Subr. Public WAM4+ input source term. -! INSIN4 Subr. Public Corresponding initialization routine. -! TABU_STRESS, TABU_TAUHF, TABU_TAUHF2 -! Subr. Public Populate various tables. -! CALC_USTAR -! Subr. Public Compute stresses. -! W3SDS4 Subr. Public Dissipation (Ardhuin & al. / Filipot & Ardhuin) -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC -!/ -!/ Public variables -!/ - !air kinematic viscosity (used in WAM) - INTEGER, PARAMETER :: ITAUMAX=200,JUMAX=200 - INTEGER, PARAMETER :: IUSTAR=100,IALPHA=200, ILEVTAIL=50 - REAL :: TAUT(0:ITAUMAX,0:JUMAX), DELTAUW, DELU - ! Table for H.F. stress as a function of 2 variables - REAL :: TAUHFT(0:IUSTAR,0:IALPHA), DELUST, DELALP - ! Table for H.F. stress as a function of 3 variables - REAL :: TAUHFT2(0:IUSTAR,0:IALPHA,0:ILEVTAIL) - ! Table for swell damping - REAL :: DELTAIL - REAL, PARAMETER :: UMAX = 50. - REAL, PARAMETER :: TAUWMAX = 2.2361 !SQRT(5.) - INTEGER :: DIKCUMUL -! Size of wave height table for integrating the PDF of wave heights - INTEGER, PARAMETER :: NKHI=100, FAC_KD2=1000 - REAL, PARAMETER :: FAC_KD1=1.01, KHSMAX=2., KHMAX=2. - REAL, PARAMETER ::KDMAX=200000. -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, WNMEAN, & - AMAX, U, UDIR, & +MODULE W3SRC4MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III SHOM | + !/ ! F. Ardhuin ! + !/ | FORTRAN 90 | + !/ | Last update : 13-Nov-2013 | + !/ +-----------------------------------+ + !/ + !/ 30-Aug-2010 : Origination. ( version 3.14-Ifremer ) + !/ 02-Nov-2010 : Addding fudge factor for low freq. ( version 4.03 ) + !/ 02-Sep-2011 : Clean up and time optimization ( version 4.04 ) + !/ 04-Sep-2011 : Estimation of whitecap stats. ( version 4.04 ) + !/ 13-Nov-2013 : Reduced frequency range with IG ( version 4.13 ) + !/ + ! 1. Purpose : + ! + ! The 'SHOM/Ifremer' source terms based on P.A.E.M. Janssen's wind input + ! and dissipation functions by Ardhuin et al. (2009,2010) + ! and Filipot & Ardhuin (2010) + ! The wind input is converted from the original + ! WAM codes, courtesy of P.A.E.M. Janssen and J. Bidlot + ! + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SPR4 Subr. Public Mean parameters from spectrum. + ! W3SIN4 Subr. Public WAM4+ input source term. + ! INSIN4 Subr. Public Corresponding initialization routine. + ! TABU_STRESS, TABU_TAUHF, TABU_TAUHF2 + ! Subr. Public Populate various tables. + ! CALC_USTAR + ! Subr. Public Compute stresses. + ! W3SDS4 Subr. Public Dissipation (Ardhuin & al. / Filipot & Ardhuin) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC + !/ + !/ Public variables + !/ + !air kinematic viscosity (used in WAM) + INTEGER, PARAMETER :: ITAUMAX=200,JUMAX=200 + INTEGER, PARAMETER :: IUSTAR=100,IALPHA=200, ILEVTAIL=50 + REAL :: TAUT(0:ITAUMAX,0:JUMAX), DELTAUW, DELU + ! Table for H.F. stress as a function of 2 variables + REAL :: TAUHFT(0:IUSTAR,0:IALPHA), DELUST, DELALP + ! Table for H.F. stress as a function of 3 variables + REAL :: TAUHFT2(0:IUSTAR,0:IALPHA,0:ILEVTAIL) + ! Table for swell damping + REAL :: DELTAIL + REAL, PARAMETER :: UMAX = 50. + REAL, PARAMETER :: TAUWMAX = 2.2361 !SQRT(5.) + INTEGER :: DIKCUMUL + ! Size of wave height table for integrating the PDF of wave heights + INTEGER, PARAMETER :: NKHI=100, FAC_KD2=1000 + REAL, PARAMETER :: FAC_KD1=1.01, KHSMAX=2., KHMAX=2. + REAL, PARAMETER ::KDMAX=200000. + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, WNMEAN, & + AMAX, U, UDIR, & #ifdef W3_FLX5 - TAUA, TAUADIR, DAIR, & + TAUA, TAUADIR, DAIR, & #endif - USTAR, USDIR, & - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III SHOM | -!/ ! F. Ardhuin ! -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Feb-2020 | -!/ +-----------------------------------+ -!/ -!/ 03-Oct-2007 : Origination. ( version 3.13 ) -!/ 13-Jun-2011 : Adds f_m0,-1 as FMEAN in the outout ( version 4.04 ) -!/ 08-Jun-2018 : use STRACE and FLUSH ( version 6.04 ) -!/ 22-Feb-2020 : Merge Romero (2019) and cleanup ( version 7.06 ) -!/ 22-Jun-2021 : Add FLX5 to use stresses with the ST( version 7.14 ) -!/ -! 1. Purpose : -! -! Calculate mean wave parameters for the use in the source term -! routines. -! -! 2. Method : -! -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum. -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! EMEAN Real O Energy -! FMEAN1 Real O Mean frequency (fm0,-1) used for reflection -! FMEAN Real O Mean frequency for determination of tail -! WNMEAN Real O Mean wavenumber. -! AMAX Real O Maximum of action spectrum. -! U Real I Wind speed. -! UDIR Real I Wind direction. -! TAUA Real I Atm. total stress. ( /!FLX5 ) -! TAUADIR Real I Atm. total stress direction. ( /!FLX5 ) -! DAIR Real I Air density. ( /!FLX5 ) -! USTAR Real I/O Friction velocity. -! USDIR Real I/O wind stress direction. -! TAUWX-Y Real I Components of wave-supported stress. -! CD Real O Drag coefficient at wind level ZWND. -! Z0 Real O Corresponding z0. -! CHARN Real O Corresponding Charnock coefficient -! LLWS L.A. I Wind sea true/false array for each component -! FMEANWS Real O Mean frequency of wind sea, used for tail -! DLWMEAN Real O Mean Long wave direction (L. Romero 2019) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3SRCE Source term integration routine. -! W3OUTP Point output program. -! GXEXPO GrADS point output program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/FLX5 Direct use of stress from atmoshperic model. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: IAPROC - USE CONSTANTS, ONLY: TPIINV, GRAV, nu_air - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, WWNMEANP, & - WWNMEANPTAIL, FTE, FTF, SSTXFTF, SSTXFTWN,& - SSTXFTFTAIL, SSWELLF, ESIN, ECOS, AAIRCMIN, & - AAIRGB, AALPHA, ZZWND + USTAR, USDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III SHOM | + !/ ! F. Ardhuin ! + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Feb-2020 | + !/ +-----------------------------------+ + !/ + !/ 03-Oct-2007 : Origination. ( version 3.13 ) + !/ 13-Jun-2011 : Adds f_m0,-1 as FMEAN in the outout ( version 4.04 ) + !/ 08-Jun-2018 : use STRACE and FLUSH ( version 6.04 ) + !/ 22-Feb-2020 : Merge Romero (2019) and cleanup ( version 7.06 ) + !/ 22-Jun-2021 : Add FLX5 to use stresses with the ST( version 7.14 ) + !/ + ! 1. Purpose : + ! + ! Calculate mean wave parameters for the use in the source term + ! routines. + ! + ! 2. Method : + ! + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum. + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! EMEAN Real O Energy + ! FMEAN1 Real O Mean frequency (fm0,-1) used for reflection + ! FMEAN Real O Mean frequency for determination of tail + ! WNMEAN Real O Mean wavenumber. + ! AMAX Real O Maximum of action spectrum. + ! U Real I Wind speed. + ! UDIR Real I Wind direction. + ! TAUA Real I Atm. total stress. ( /!FLX5 ) + ! TAUADIR Real I Atm. total stress direction. ( /!FLX5 ) + ! DAIR Real I Air density. ( /!FLX5 ) + ! USTAR Real I/O Friction velocity. + ! USDIR Real I/O wind stress direction. + ! TAUWX-Y Real I Components of wave-supported stress. + ! CD Real O Drag coefficient at wind level ZWND. + ! Z0 Real O Corresponding z0. + ! CHARN Real O Corresponding Charnock coefficient + ! LLWS L.A. I Wind sea true/false array for each component + ! FMEANWS Real O Mean frequency of wind sea, used for tail + ! DLWMEAN Real O Mean Long wave direction (L. Romero 2019) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3SRCE Source term integration routine. + ! W3OUTP Point output program. + ! GXEXPO GrADS point output program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/FLX5 Direct use of stress from atmoshperic model. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: IAPROC + USE CONSTANTS, ONLY: TPIINV, GRAV, nu_air + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, WWNMEANP, & + WWNMEANPTAIL, FTE, FTF, SSTXFTF, SSTXFTWN,& + SSTXFTFTAIL, SSWELLF, ESIN, ECOS, AAIRCMIN, & + AAIRGB, AALPHA, ZZWND #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T - USE W3ODATMD, ONLY: NDST - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif -! + ! #ifdef W3_FLX5 - USE W3FLX5MD + USE W3FLX5MD #endif - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK), U, UDIR + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK), U, UDIR #ifdef W3_FLX5 - REAL, INTENT(IN) :: TAUA, TAUADIR, DAIR + REAL, INTENT(IN) :: TAUA, TAUADIR, DAIR #endif - REAL, INTENT(IN) :: TAUWX, TAUWY - LOGICAL, INTENT(IN) :: LLWS(NSPEC) - REAL, INTENT(INOUT) :: USTAR ,USDIR - REAL, INTENT(OUT) :: EMEAN, FMEAN, FMEAN1, WNMEAN, AMAX, & - CD, Z0, CHARN, FMEANWS, DLWMEAN -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS, IK, ITH + REAL, INTENT(IN) :: TAUWX, TAUWY + LOGICAL, INTENT(IN) :: LLWS(NSPEC) + REAL, INTENT(INOUT) :: USTAR ,USDIR + REAL, INTENT(OUT) :: EMEAN, FMEAN, FMEAN1, WNMEAN, AMAX, & + CD, Z0, CHARN, FMEANWS, DLWMEAN + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS, IK, ITH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: TAUW, EBAND, EMEANWS,UNZ, & - EB(NK),EB2(NK),ELCS, ELSN -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: TAUW, EBAND, EMEANWS,UNZ, & + EB(NK),EB2(NK),ELCS, ELSN + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SPR4') + CALL STRACE (IENT, 'W3SPR4') #endif -! - UNZ = MAX ( 0.01 , U ) - USTAR = MAX ( 0.0001 , USTAR ) -! - EMEAN = 0. - EMEANWS= 0. - FMEANWS= 0. - FMEAN = 0. - FMEAN1 = 0. - WNMEAN = 0. - AMAX = 0. - DLWMEAN =0. - ELCS =0. - ELSN =0. -! -! 1. Integral over directions and maximum --------------------------- * -! - DO IK=1, NK - EB(IK) = 0. - EB2(IK) = 0. - DO ITH=1, NTH - IS=ITH+(IK-1)*NTH - EB(IK) = EB(IK) + A(ITH,IK) - ELCS = ELCS + A(ITH,IK)*ECOS(IS)*DDEN(IK) / CG(IK) - ELSN = ELSN + A(ITH,IK)*ESIN(IS)*DDEN(IK) / CG(IK) - IF (LLWS(IS)) EB2(IK) = EB2(IK) + A(ITH,IK) - AMAX = MAX ( AMAX , A(ITH,IK) ) - END DO - END DO + ! + UNZ = MAX ( 0.01 , U ) + USTAR = MAX ( 0.0001 , USTAR ) + ! + EMEAN = 0. + EMEANWS= 0. + FMEANWS= 0. + FMEAN = 0. + FMEAN1 = 0. + WNMEAN = 0. + AMAX = 0. + DLWMEAN =0. + ELCS =0. + ELSN =0. + ! + ! 1. Integral over directions and maximum --------------------------- * + ! + DO IK=1, NK + EB(IK) = 0. + EB2(IK) = 0. + DO ITH=1, NTH + IS=ITH+(IK-1)*NTH + EB(IK) = EB(IK) + A(ITH,IK) + ELCS = ELCS + A(ITH,IK)*ECOS(IS)*DDEN(IK) / CG(IK) + ELSN = ELSN + A(ITH,IK)*ESIN(IS)*DDEN(IK) / CG(IK) + IF (LLWS(IS)) EB2(IK) = EB2(IK) + A(ITH,IK) + AMAX = MAX ( AMAX , A(ITH,IK) ) + END DO + END DO - DLWMEAN=ATAN2(ELSN,ELCS); -! -! 2. Integrate over directions -------------------------------------- * -! - DO IK=1, NK - EB(IK) = EB(IK) * DDEN(IK) / CG(IK) - EB2(IK) = EB2(IK) * DDEN(IK) / CG(IK) - EMEAN = EMEAN + EB(IK) - FMEAN = FMEAN + EB(IK) /SIG(IK) - FMEAN1 = FMEAN1 + EB(IK) *(SIG(IK)**(2.*WWNMEANPTAIL)) - WNMEAN = WNMEAN + EB(IK) *(WN(IK)**WWNMEANP) - EMEANWS = EMEANWS+ EB2(IK) - FMEANWS = FMEANWS+ EB2(IK)*(SIG(IK)**(2.*WWNMEANPTAIL)) - END DO -! -! 3. Add tail beyond discrete spectrum and get mean pars ------------ * -! ( DTH * SIG absorbed in FTxx ) -! - EBAND = EB(NK) / DDEN(NK) - EMEAN = EMEAN + EBAND * FTE - FMEAN = FMEAN + EBAND * FTF - FMEAN1 = FMEAN1 + EBAND * SSTXFTFTAIL - WNMEAN = WNMEAN + EBAND * SSTXFTWN - EBAND = EB2(NK) / DDEN(NK) - EMEANWS = EMEANWS + EBAND * FTE - FMEANWS = FMEANWS + EBAND * SSTXFTFTAIL -! -! 4. Final processing -! - FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) - IF (FMEAN1.LT.1.E-7) THEN - FMEAN1=TPIINV * SIG(NK) - ELSE - FMEAN1 = TPIINV *( MAX ( 1.E-7 , FMEAN1 ) & - / MAX ( 1.E-7 , EMEAN ))**(1/(2.*WWNMEANPTAIL)) - ENDIF - WNMEAN = ( MAX ( 1.E-7 , WNMEAN ) & - / MAX ( 1.E-7 , EMEAN ) )**(1/WWNMEANP) - IF (FMEANWS.LT.1.E-7.OR.EMEANWS.LT.1.E-7) THEN - FMEANWS=TPIINV * SIG(NK) - ELSE - FMEANWS = TPIINV *( MAX ( 1.E-7 , FMEANWS ) & - / MAX ( 1.E-7 , EMEANWS ))**(1/(2.*WWNMEANPTAIL)) - END IF + DLWMEAN=ATAN2(ELSN,ELCS); + ! + ! 2. Integrate over directions -------------------------------------- * + ! + DO IK=1, NK + EB(IK) = EB(IK) * DDEN(IK) / CG(IK) + EB2(IK) = EB2(IK) * DDEN(IK) / CG(IK) + EMEAN = EMEAN + EB(IK) + FMEAN = FMEAN + EB(IK) /SIG(IK) + FMEAN1 = FMEAN1 + EB(IK) *(SIG(IK)**(2.*WWNMEANPTAIL)) + WNMEAN = WNMEAN + EB(IK) *(WN(IK)**WWNMEANP) + EMEANWS = EMEANWS+ EB2(IK) + FMEANWS = FMEANWS+ EB2(IK)*(SIG(IK)**(2.*WWNMEANPTAIL)) + END DO + ! + ! 3. Add tail beyond discrete spectrum and get mean pars ------------ * + ! ( DTH * SIG absorbed in FTxx ) + ! + EBAND = EB(NK) / DDEN(NK) + EMEAN = EMEAN + EBAND * FTE + FMEAN = FMEAN + EBAND * FTF + FMEAN1 = FMEAN1 + EBAND * SSTXFTFTAIL + WNMEAN = WNMEAN + EBAND * SSTXFTWN + EBAND = EB2(NK) / DDEN(NK) + EMEANWS = EMEANWS + EBAND * FTE + FMEANWS = FMEANWS + EBAND * SSTXFTFTAIL + ! + ! 4. Final processing + ! + FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) + IF (FMEAN1.LT.1.E-7) THEN + FMEAN1=TPIINV * SIG(NK) + ELSE + FMEAN1 = TPIINV *( MAX ( 1.E-7 , FMEAN1 ) & + / MAX ( 1.E-7 , EMEAN ))**(1/(2.*WWNMEANPTAIL)) + ENDIF + WNMEAN = ( MAX ( 1.E-7 , WNMEAN ) & + / MAX ( 1.E-7 , EMEAN ) )**(1/WWNMEANP) + IF (FMEANWS.LT.1.E-7.OR.EMEANWS.LT.1.E-7) THEN + FMEANWS=TPIINV * SIG(NK) + ELSE + FMEANWS = TPIINV *( MAX ( 1.E-7 , FMEANWS ) & + / MAX ( 1.E-7 , EMEANWS ))**(1/(2.*WWNMEANPTAIL)) + END IF -! -! 5. Cd and z0 ----------------------------------------------- * -! - TAUW = SQRT(TAUWX**2+TAUWY**2) -! + ! + ! 5. Cd and z0 ----------------------------------------------- * + ! + TAUW = SQRT(TAUWX**2+TAUWY**2) + ! #ifdef W3_FLX5 - CALL W3FLX5 ( ZZWND, U, UDIR, TAUA, TAUADIR, DAIR, & - USTAR, USDIR, Z0, CD, CHARN ) + CALL W3FLX5 ( ZZWND, U, UDIR, TAUA, TAUADIR, DAIR, & + USTAR, USDIR, Z0, CD, CHARN ) #else - Z0=0. - CALL CALC_USTAR(U,TAUW,USTAR,Z0,CHARN) - UNZ = MAX ( 0.01 , U ) - CD = (USTAR/UNZ)**2 - USDIR = UDIR + Z0=0. + CALL CALC_USTAR(U,TAUW,USTAR,Z0,CHARN) + UNZ = MAX ( 0.01 , U ) + CD = (USTAR/UNZ)**2 + USDIR = UDIR #endif -! -! 6. Final test output ---------------------------------------------- * -! + ! + ! 6. Final test output ---------------------------------------------- * + ! #ifdef W3_T - WRITE (NDST,9060) EMEAN, WNMEAN, TPIINV, USTAR, CD, Z0 + WRITE (NDST,9060) EMEAN, WNMEAN, TPIINV, USTAR, CD, Z0 #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9060 FORMAT (' TEST W3SPR4 : E,WN MN :',F8.3,F8.4/ & - ' TPIINV, USTAR, CD, Z0 :',F8.3,F7.2,1X,2F9.5) +9060 FORMAT (' TEST W3SPR4 : E,WN MN :',F8.3,F8.4/ & + ' TPIINV, USTAR, CD, Z0 :',F8.3,F7.2,1X,2F9.5) #endif -!/ -!/ End of W3SPR4 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SPR4 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SIN4 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & - TAUWX, TAUWY, TAUWNX, TAUWNY, S, D, LLWS, & - IX, IY, BRLAMBDA) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III SHOM | -!/ ! F. Ardhuin ! -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 05-Dec-2013 | -!/ +-----------------------------------+ -!/ -!/ 09-Oct-2007 : Origination. ( version 3.13 ) -!/ 24-Jan-2013 : Adding breaking-related input ( version 4.16 ) -!/ 05-Dec-2013 : Cleaning up the ICE input ( version 4.16 ) -!/ -! 1. Purpose : -! -! Calculate diagonal and input source term for WAM4+ approach. -! -! 2. Method : -! -! WAM-4 : Janssen et al. -! WAM-"4.5" : gustiness effect (Cavaleri et al. ) -! SAT : high-frequency input reduction for balance with -! saturation dissipation (Ardhuin et al., 2008) -! SWELL : negative wind input (Ardhuin et al. 2008) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D). -! CG R.A. I Group speed *) -! K R.A. I Wavenumber for entire spectrum. *) -! U Real I WIND SPEED -! USTAR Real I Friction velocity. -! DRAT Real I Air/water density ratio. -! AS Real I Air-sea temperature difference -! USDIR Real I wind stress direction -! Z0 Real I Air-side roughness lengh. -! CD Real I Wind drag coefficient. -! USDIR Real I Direction of friction velocity -! TAUWX-Y Real I Components of the wave-supported stress. -! TAUWNX Real I Component of the negative wave-supported stress. -! TAUWNY Real I Component of the negative wave-supported stress. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative. *) -! ---------------------------------------------------------------- -! *) Stored as 1-D array with dimension NTH*NK -! -! 4. Subroutines used : -! -! STRACE Subroutine tracing. ( !/S switch ) -! PRT2DS Print plot of spectrum. ( !/T0 switch ) -! OUTMAT Print out matrix. ( !/T1 switch ) -! -! 5. Called by : -! -! W3SRCE Source term integration. -! W3EXPO Point output program. -! GXEXPO GrADS point output program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV,nu_air,KAPPA,TPI,FWTABLE,SIZEFWTABLE, & + !/ + !/ End of W3SPR4 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SPR4 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SIN4 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & + TAUWX, TAUWY, TAUWNX, TAUWNY, S, D, LLWS, & + IX, IY, BRLAMBDA) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III SHOM | + !/ ! F. Ardhuin ! + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 05-Dec-2013 | + !/ +-----------------------------------+ + !/ + !/ 09-Oct-2007 : Origination. ( version 3.13 ) + !/ 24-Jan-2013 : Adding breaking-related input ( version 4.16 ) + !/ 05-Dec-2013 : Cleaning up the ICE input ( version 4.16 ) + !/ + ! 1. Purpose : + ! + ! Calculate diagonal and input source term for WAM4+ approach. + ! + ! 2. Method : + ! + ! WAM-4 : Janssen et al. + ! WAM-"4.5" : gustiness effect (Cavaleri et al. ) + ! SAT : high-frequency input reduction for balance with + ! saturation dissipation (Ardhuin et al., 2008) + ! SWELL : negative wind input (Ardhuin et al. 2008) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D). + ! CG R.A. I Group speed *) + ! K R.A. I Wavenumber for entire spectrum. *) + ! U Real I WIND SPEED + ! USTAR Real I Friction velocity. + ! DRAT Real I Air/water density ratio. + ! AS Real I Air-sea temperature difference + ! USDIR Real I wind stress direction + ! Z0 Real I Air-side roughness lengh. + ! CD Real I Wind drag coefficient. + ! USDIR Real I Direction of friction velocity + ! TAUWX-Y Real I Components of the wave-supported stress. + ! TAUWNX Real I Component of the negative wave-supported stress. + ! TAUWNY Real I Component of the negative wave-supported stress. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative. *) + ! ---------------------------------------------------------------- + ! *) Stored as 1-D array with dimension NTH*NK + ! + ! 4. Subroutines used : + ! + ! STRACE Subroutine tracing. ( !/S switch ) + ! PRT2DS Print plot of spectrum. ( !/T0 switch ) + ! OUTMAT Print out matrix. ( !/T1 switch ) + ! + ! 5. Called by : + ! + ! W3SRCE Source term integration. + ! W3EXPO Point output program. + ! GXEXPO GrADS point output program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV,nu_air,KAPPA,TPI,FWTABLE,SIZEFWTABLE, & #ifdef W3_T - RADE, & + RADE, & #endif - DELAB,ABMIN - USE W3GDATMD, ONLY: NK, NTH, NSPEC, DDEN, SIG, SIG2, TH, & - ESIN, ECOS, EC2, ZZWND, AALPHA, BBETA, ZZALP,& - TTAUWSHELTER, SSWELLF, DDEN2, DTH, SSINTHP, & - ZZ0RAT, SSINBR + DELAB,ABMIN + USE W3GDATMD, ONLY: NK, NTH, NSPEC, DDEN, SIG, SIG2, TH, & + ESIN, ECOS, EC2, ZZWND, AALPHA, BBETA, ZZALP,& + TTAUWSHELTER, SSWELLF, DDEN2, DTH, SSINTHP, & + ZZ0RAT, SSINBR #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_T0 - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif - USE W3ODATMD, ONLY: IAPROC + USE W3ODATMD, ONLY: IAPROC #ifdef W3_T0 - USE W3ARRYMD, ONLY: PRT2DS + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NSPEC), BRLAMBDA(NSPEC) - REAL, INTENT(IN) :: CG(NK), K(NSPEC),Z0,U, CD - REAL, INTENT(IN) :: USTAR, USDIR, AS, DRAT - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC), TAUWX, TAUWY, TAUWNX, TAUWNY - LOGICAL, INTENT(OUT) :: LLWS(NSPEC) - INTEGER, INTENT(IN) :: IX, IY -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS,IK,ITH + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NSPEC), BRLAMBDA(NSPEC) + REAL, INTENT(IN) :: CG(NK), K(NSPEC),Z0,U, CD + REAL, INTENT(IN) :: USTAR, USDIR, AS, DRAT + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC), TAUWX, TAUWY, TAUWNX, TAUWNY + LOGICAL, INTENT(OUT) :: LLWS(NSPEC) + INTEGER, INTENT(IN) :: IX, IY + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS,IK,ITH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: FACLN1, FACLN2, LAMBDA - REAL :: COSU, SINU, TAUX, TAUY, USDIRP, USTP - REAL :: TAUPX, TAUPY, UST2, TAUW, TAUWB - REAL , PARAMETER :: EPS1 = 0.00001, EPS2 = 0.000001 - REAL :: Usigma !standard deviation of U due to gustiness - REAL :: USTARsigma !standard deviation of USTAR due to gustiness - REAL :: CM,UCN,ZCN, & - Z0VISC, Z0NOZ, EB, & - EBX, EBY, AORB, AORB1, FW, UORB, TH2, & - RE, FU, FUD, SWELLCOEFV, SWELLCOEFT - REAL :: PTURB, PVISC, SMOOTH - REAL XI,DELI1,DELI2 - REAL XJ,DELJ1,DELJ2 - REAL XK,DELK1,DELK2 - REAL :: CONST, CONST0, CONST2, TAU1 - REAL X,ZARG,ZLOG,UST - REAL :: COSWIND, XSTRESS, YSTRESS, TAUHF - REAL TEMP, TEMP2 - INTEGER IND,J,I,ISTAB - REAL DSTAB(3,NSPEC), DVISC, DTURB - REAL STRESSSTAB(3,2),STRESSSTABN(3,2) + REAL :: FACLN1, FACLN2, LAMBDA + REAL :: COSU, SINU, TAUX, TAUY, USDIRP, USTP + REAL :: TAUPX, TAUPY, UST2, TAUW, TAUWB + REAL , PARAMETER :: EPS1 = 0.00001, EPS2 = 0.000001 + REAL :: Usigma !standard deviation of U due to gustiness + REAL :: USTARsigma !standard deviation of USTAR due to gustiness + REAL :: CM,UCN,ZCN, & + Z0VISC, Z0NOZ, EB, & + EBX, EBY, AORB, AORB1, FW, UORB, TH2, & + RE, FU, FUD, SWELLCOEFV, SWELLCOEFT + REAL :: PTURB, PVISC, SMOOTH + REAL XI,DELI1,DELI2 + REAL XJ,DELJ1,DELJ2 + REAL XK,DELK1,DELK2 + REAL :: CONST, CONST0, CONST2, TAU1 + REAL X,ZARG,ZLOG,UST + REAL :: COSWIND, XSTRESS, YSTRESS, TAUHF + REAL TEMP, TEMP2 + INTEGER IND,J,I,ISTAB + REAL DSTAB(3,NSPEC), DVISC, DTURB + REAL STRESSSTAB(3,2),STRESSSTABN(3,2) #ifdef W3_T0 - REAL :: DOUT(NK,NTH) + REAL :: DOUT(NK,NTH) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SIN4') + CALL STRACE (IENT, 'W3SIN4') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) BBETA, USTAR, USDIR*RADE + WRITE (NDST,9000) BBETA, USTAR, USDIR*RADE #endif -! -! 1. Preparations -! - !JDM: Initializing values to zero, they shouldn't be used unless - !set in another place, but seems to solve some bugs with certain - !compilers. - DSTAB =0. - STRESSSTAB =0. - STRESSSTABN =0. -! -! 1.a estimation of surface roughness parameters -! - Z0VISC = 0.1*nu_air/MAX(USTAR,0.0001) - Z0NOZ = MAX(Z0VISC,ZZ0RAT*Z0) - FACLN1 = U / LOG(ZZWND/Z0NOZ) - FACLN2 = LOG(Z0NOZ) -! -! 1.b estimation of surface orbital velocity and displacement -! - UORB=0. - AORB=0. + ! + ! 1. Preparations + ! + !JDM: Initializing values to zero, they shouldn't be used unless + !set in another place, but seems to solve some bugs with certain + !compilers. + DSTAB =0. + STRESSSTAB =0. + STRESSSTABN =0. + ! + ! 1.a estimation of surface roughness parameters + ! + Z0VISC = 0.1*nu_air/MAX(USTAR,0.0001) + Z0NOZ = MAX(Z0VISC,ZZ0RAT*Z0) + FACLN1 = U / LOG(ZZWND/Z0NOZ) + FACLN2 = LOG(Z0NOZ) + ! + ! 1.b estimation of surface orbital velocity and displacement + ! + UORB=0. + AORB=0. - DO IK=1, NK - EB = 0. - EBX = 0. - EBY = 0. - DO ITH=1, NTH - IS=ITH+(IK-1)*NTH - EB = EB + A(IS) - END DO -! -! At this point UORB and AORB are the variances of the orbital velocity and surface elevation -! - UORB = UORB + EB *SIG(IK)**2 * DDEN(IK) / CG(IK) - AORB = AORB + EB * DDEN(IK) / CG(IK) !deep water only - END DO + DO IK=1, NK + EB = 0. + EBX = 0. + EBY = 0. + DO ITH=1, NTH + IS=ITH+(IK-1)*NTH + EB = EB + A(IS) + END DO + ! + ! At this point UORB and AORB are the variances of the orbital velocity and surface elevation + ! + UORB = UORB + EB *SIG(IK)**2 * DDEN(IK) / CG(IK) + AORB = AORB + EB * DDEN(IK) / CG(IK) !deep water only + END DO - UORB = 2*SQRT(UORB) ! significant orbital amplitude - AORB1 = 2*AORB**(1-0.5*SSWELLF(6)) ! half the significant wave height ... if SWELLF(6)=1 - RE = 4*UORB*AORB1 / NU_AIR ! Reynolds number -! -! Defines the swell dissipation based on the "Reynolds number" -! - IF (SSWELLF(4).GT.0) THEN - IF (SSWELLF(7).GT.0.) THEN - SMOOTH = 0.5*TANH((RE-SSWELLF(4))/SSWELLF(7)) - PTURB=(0.5+SMOOTH) - PVISC=(0.5-SMOOTH) - ELSE - IF (RE.LE.SSWELLF(4)) THEN - PTURB = 0. - PVISC = 1. - ELSE - PTURB = 1. - PVISC = 0. - END IF - END IF - ELSE - PTURB=1. - PVISC=1. - END IF - -! - IF (SSWELLF(2).EQ.0) THEN - FW=MAX(ABS(SSWELLF(3)),0.) - FU=0. - FUD=0. + UORB = 2*SQRT(UORB) ! significant orbital amplitude + AORB1 = 2*AORB**(1-0.5*SSWELLF(6)) ! half the significant wave height ... if SWELLF(6)=1 + RE = 4*UORB*AORB1 / NU_AIR ! Reynolds number + ! + ! Defines the swell dissipation based on the "Reynolds number" + ! + IF (SSWELLF(4).GT.0) THEN + IF (SSWELLF(7).GT.0.) THEN + SMOOTH = 0.5*TANH((RE-SSWELLF(4))/SSWELLF(7)) + PTURB=(0.5+SMOOTH) + PVISC=(0.5-SMOOTH) ELSE - FU=ABS(SSWELLF(3)) - FUD=SSWELLF(2) - AORB=2*SQRT(AORB) - XI=(ALOG10(MAX(AORB/Z0NOZ,3.))-ABMIN)/DELAB - IND = MIN (SIZEFWTABLE-1, INT(XI)) - DELI1= MIN (1. ,XI-FLOAT(IND)) - DELI2= 1. - DELI1 - FW =FWTABLE(IND)*DELI2+FWTABLE(IND+1)*DELI1 + IF (RE.LE.SSWELLF(4)) THEN + PTURB = 0. + PVISC = 1. + ELSE + PTURB = 1. + PVISC = 0. END IF -! -! 2. Diagonal -! -! Here AS is the air-sea temperature difference in degrees. Expression given by -! Abdalla & Cavaleri, JGR 2002 for Usigma. For USTARsigma ... I do not see where -! I got it from, maybe just made up from drag law ... -! + END IF + ELSE + PTURB=1. + PVISC=1. + END IF + + ! + IF (SSWELLF(2).EQ.0) THEN + FW=MAX(ABS(SSWELLF(3)),0.) + FU=0. + FUD=0. + ELSE + FU=ABS(SSWELLF(3)) + FUD=SSWELLF(2) + AORB=2*SQRT(AORB) + XI=(ALOG10(MAX(AORB/Z0NOZ,3.))-ABMIN)/DELAB + IND = MIN (SIZEFWTABLE-1, INT(XI)) + DELI1= MIN (1. ,XI-FLOAT(IND)) + DELI2= 1. - DELI1 + FW =FWTABLE(IND)*DELI2+FWTABLE(IND+1)*DELI1 + END IF + ! + ! 2. Diagonal + ! + ! Here AS is the air-sea temperature difference in degrees. Expression given by + ! Abdalla & Cavaleri, JGR 2002 for Usigma. For USTARsigma ... I do not see where + ! I got it from, maybe just made up from drag law ... + ! #ifdef W3_STAB3 - Usigma=MAX(0.,-0.025*AS) - USTARsigma=(1.0+U/(10.+U))*Usigma + Usigma=MAX(0.,-0.025*AS) + USTARsigma=(1.0+U/(10.+U))*Usigma #endif - UST=USTAR - ISTAB=3 + UST=USTAR + ISTAB=3 #ifdef W3_STAB3 - DO ISTAB=1,2 + DO ISTAB=1,2 IF (ISTAB.EQ.1) UST=USTAR*(1.-USTARsigma) IF (ISTAB.EQ.2) UST=USTAR*(1.+USTARsigma) #endif TAUX = UST**2* COS(USDIR) TAUY = UST**2* SIN(USDIR) -! -! Loop over the resolved part of the spectrum -! + ! + ! Loop over the resolved part of the spectrum + ! STRESSSTAB(ISTAB,:)=0. STRESSSTABN(ISTAB,:)=0. -! -! Coupling coefficient times density ratio DRAT -! + ! + ! Coupling coefficient times density ratio DRAT + ! CONST0=BBETA*DRAT/(kappa**2) -! + ! DO IK=1, NK TAUPX=TAUX-ABS(TTAUWSHELTER)*STRESSSTAB(ISTAB,1) TAUPY=TAUY-ABS(TTAUWSHELTER)*STRESSSTAB(ISTAB,2) -! With MIN and MAX the bug should disappear.... but where did it come from? + ! With MIN and MAX the bug should disappear.... but where did it come from? USTP=MIN((TAUPX**2+TAUPY**2)**0.25,MAX(UST,0.3)) USDIRP=ATAN2(TAUPY,TAUPX) COSU = COS(USDIRP) @@ -604,1584 +604,1581 @@ SUBROUTINE W3SIN4 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & IS=1+(IK-1)*NTH CM=K(IS)/SIG2(IS) !inverse of phase speed UCN=USTP*CM+ZZALP !this is the inverse wave age - ! the stress is the real stress (N/m^2) divided by - ! rho_a, and thus comparable to USTAR**2 - ! it is the integral of rho_w g Sin/C /rho_a - ! (air-> waves momentum flux) + ! the stress is the real stress (N/m^2) divided by + ! rho_a, and thus comparable to USTAR**2 + ! it is the integral of rho_w g Sin/C /rho_a + ! (air-> waves momentum flux) CONST2=DDEN2(IS)/CG(IK) & !Jacobian to get energy in band - *GRAV/(SIG(IK)/K(IS)*DRAT) ! coefficient to get momentum - CONST=SIG2(IS)*CONST0 - ! CM parameter is 1 / C_phi - ! Z0 corresponds to Z0+Z1 of the Janssen eq. 14 + *GRAV/(SIG(IK)/K(IS)*DRAT) ! coefficient to get momentum + CONST=SIG2(IS)*CONST0 + ! CM parameter is 1 / C_phi + ! Z0 corresponds to Z0+Z1 of the Janssen eq. 14 ZCN=ALOG(K(IS)*Z0) -! -! precomputes swell factors -! - SWELLCOEFV=-SSWELLF(5)*DRAT*2*K(IS)*SQRT(2*NU_AIR*SIG2(IS)) + ! + ! precomputes swell factors + ! + SWELLCOEFV=-SSWELLF(5)*DRAT*2*K(IS)*SQRT(2*NU_AIR*SIG2(IS)) SWELLCOEFT=-DRAT*SSWELLF(1)*16*SIG2(IS)**2/GRAV -! + ! DO ITH=1,NTH IS=ITH+(IK-1)*NTH COSWIND=(ECOS(IS)*COSU+ESIN(IS)*SINU) - IF (COSWIND.GT.0.01) THEN - X=COSWIND*UCN + IF (COSWIND.GT.0.01) THEN + X=COSWIND*UCN ! this ZARG term is the argument of the exponential - ! in Janssen 1991 eq. 16. + ! in Janssen 1991 eq. 16. ZARG=KAPPA/X ! ZLOG is ALOG(MU) where MU is defined by Janssen 1991 eq. 15 ! MU= - ZLOG=ZCN+ZARG - + ZLOG=ZCN+ZARG + IF (ZLOG.LT.0.) THEN ! The source term Sp is beta * omega * X**2 ! as given by Janssen 1991 eq. 19 ! Note that this is slightly diffent from ECWAM code CY45R2 where ZLOG is replaced by ?? - DSTAB(ISTAB,IS) = CONST*EXP(ZLOG)*ZLOG**4*UCN*UCN*COSWIND**SSINTHP + DSTAB(ISTAB,IS) = CONST*EXP(ZLOG)*ZLOG**4*UCN*UCN*COSWIND**SSINTHP ! Below is an example with breaking probability feeding back to the input... !DSTAB(ISTAB,IS) = CONST*EXP(ZLOG)*ZLOG**4 & - ! *UCN*UCN*COSWIND**SSINTHP *(1+BRLAMBDA(IS)*20*SSINBR) + ! *UCN*UCN*COSWIND**SSINTHP *(1+BRLAMBDA(IS)*20*SSINBR) LLWS(IS)=.TRUE. ELSE DSTAB(ISTAB,IS) = 0. LLWS(IS)=.FALSE. - END IF -! -! Added for consistency with ECWAM implsch.F -! + END IF + ! + ! Added for consistency with ECWAM implsch.F + ! IF (28.*CM*USTAR*COSWIND.GE.1) THEN LLWS(IS)=.TRUE. - END IF - ELSE ! (COSWIND.LE.0.01) + END IF + ELSE ! (COSWIND.LE.0.01) DSTAB(ISTAB,IS) = 0. LLWS(IS)=.FALSE. - END IF -! + END IF + ! IF ((SSWELLF(1).NE.0.AND.DSTAB(ISTAB,IS).LT.1E-7*SIG2(IS)) & - .OR.SSWELLF(3).GT.0) THEN -! - DVISC=SWELLCOEFV - DTURB=SWELLCOEFT*(FW*UORB+(FU+FUD*COSWIND)*USTP) -! - DSTAB(ISTAB,IS) = DSTAB(ISTAB,IS) + PTURB*DTURB + PVISC*DVISC - END IF -! -! Sums up the wave-supported stress -! + .OR.SSWELLF(3).GT.0) THEN + ! + DVISC=SWELLCOEFV + DTURB=SWELLCOEFT*(FW*UORB+(FU+FUD*COSWIND)*USTP) + ! + DSTAB(ISTAB,IS) = DSTAB(ISTAB,IS) + PTURB*DTURB + PVISC*DVISC + END IF + ! + ! Sums up the wave-supported stress + ! ! Wave direction is "direction to" ! therefore there is a PLUS sign for the stress TEMP2=CONST2*DSTAB(ISTAB,IS)*A(IS) - IF (DSTAB(ISTAB,IS).LT.0) THEN + IF (DSTAB(ISTAB,IS).LT.0) THEN STRESSSTABN(ISTAB,1)=STRESSSTABN(ISTAB,1)+TEMP2*ECOS(IS) STRESSSTABN(ISTAB,2)=STRESSSTABN(ISTAB,2)+TEMP2*ESIN(IS) ELSE STRESSSTAB(ISTAB,1)=STRESSSTAB(ISTAB,1)+TEMP2*ECOS(IS) STRESSSTAB(ISTAB,2)=STRESSSTAB(ISTAB,2)+TEMP2*ESIN(IS) - END IF - END DO + END IF END DO -! - D(:)=DSTAB(3,:) - XSTRESS=STRESSSTAB (3,1) - YSTRESS=STRESSSTAB (3,2) - TAUWNX =STRESSSTABN(3,1) - TAUWNY =STRESSSTABN(3,2) + END DO + ! + D(:)=DSTAB(3,:) + XSTRESS=STRESSSTAB (3,1) + YSTRESS=STRESSSTAB (3,2) + TAUWNX =STRESSSTABN(3,1) + TAUWNY =STRESSSTABN(3,2) #ifdef W3_STAB3 - END DO - D(:)=0.5*(DSTAB(1,:)+DSTAB(2,:)) - XSTRESS=0.5*(STRESSSTAB(1,1)+STRESSSTAB(2,1)) - YSTRESS=0.5*(STRESSSTAB(1,2)+STRESSSTAB(2,2)) - TAUWNX=0.5*(STRESSSTABN(1,1)+STRESSSTABN(2,1)) - TAUWNY=0.5*(STRESSSTABN(1,2)+STRESSSTABN(2,2)) -#endif - S = D * A -! -! ... Test output of arrays -! -#ifdef W3_T0 - DO IK=1, NK - DO ITH=1, NTH - DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) - END DO - END DO + END DO + D(:)=0.5*(DSTAB(1,:)+DSTAB(2,:)) + XSTRESS=0.5*(STRESSSTAB(1,1)+STRESSSTAB(2,1)) + YSTRESS=0.5*(STRESSSTAB(1,2)+STRESSSTAB(2,2)) + TAUWNX=0.5*(STRESSSTABN(1,1)+STRESSSTABN(2,1)) + TAUWNY=0.5*(STRESSSTABN(1,2)+STRESSSTABN(2,2)) #endif -! + S = D * A + ! + ! ... Test output of arrays + ! #ifdef W3_T0 - CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1), ' ', 1., & - 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') #endif -! + ! #ifdef W3_T1 - CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') #endif -! - ! Computes the high-frequency contribution - ! the difference in spectal density (kx,ky) to (f,theta) - ! is integrated in this modified CONST0 - CONST0=DTH*SIG(NK)**5/((GRAV**2)*tpi) & + ! + ! Computes the high-frequency contribution + ! the difference in spectal density (kx,ky) to (f,theta) + ! is integrated in this modified CONST0 + CONST0=DTH*SIG(NK)**5/((GRAV**2)*tpi) & *TPI*SIG(NK) / CG(NK) !conversion WAM (E(f,theta) to WW3 A(k,theta) - TEMP=0. - DO ITH=1,NTH - IS=ITH+(NK-1)*NTH - COSWIND=(ECOS(IS)*COSU+ESIN(IS)*SINU) - TEMP=TEMP+A(IS)*(MAX(COSWIND,0.))**3 - END DO + TEMP=0. + DO ITH=1,NTH + IS=ITH+(NK-1)*NTH + COSWIND=(ECOS(IS)*COSU+ESIN(IS)*SINU) + TEMP=TEMP+A(IS)*(MAX(COSWIND,0.))**3 + END DO - TAUPX=TAUX-ABS(TTAUWSHELTER)*XSTRESS - TAUPY=TAUY-ABS(TTAUWSHELTER)*YSTRESS - USTP=(TAUPX**2+TAUPY**2)**0.25 - USDIRP=ATAN2(TAUPY,TAUPX) + TAUPX=TAUX-ABS(TTAUWSHELTER)*XSTRESS + TAUPY=TAUY-ABS(TTAUWSHELTER)*YSTRESS + USTP=(TAUPX**2+TAUPY**2)**0.25 + USDIRP=ATAN2(TAUPY,TAUPX) - UST=USTP - ! finds the values in the tabulated stress TAUHFT - XI=UST/DELUST - IND = MAX(1,MIN (IUSTAR-1, INT(XI))) - DELI1= MAX(MIN (1. ,XI-FLOAT(IND)),0.) - DELI2= 1. - DELI1 - XJ=MAX(0.,(GRAV*Z0/MAX(UST,0.00001)**2-AALPHA) / DELALP) - J = MAX(1 ,MIN (IALPHA-1, INT(XJ))) - DELJ1= MAX(0.,MIN (1. , XJ-FLOAT(J))) - DELJ2=1. - DELJ1 - IF (TTAUWSHELTER.GT.0) THEN - XK = CONST0*TEMP / DELTAIL - I = MIN (ILEVTAIL-1, INT(XK)) - DELK1= MIN (1. ,XK-FLOAT(I)) - DELK2=1. - DELK1 - TAU1 =((TAUHFT2(IND,J,I)*DELI2+TAUHFT2(IND+1,J,I)*DELI1 )*DELJ2 & - +(TAUHFT2(IND,J+1,I)*DELI2+TAUHFT2(IND+1,J+1,I)*DELI1)*DELJ1)*DELK2 & - +((TAUHFT2(IND,J,I+1)*DELI2+TAUHFT2(IND+1,J,I+1)*DELI1 )*DELJ2 & - +(TAUHFT2(IND,J+1,I+1)*DELI2+TAUHFT2(IND+1,J+1,I+1)*DELI1)*DELJ1)*DELK1 - ELSE - TAU1 =(TAUHFT(IND,J)*DELI2+TAUHFT(IND+1,J)*DELI1 )*DELJ2 & - +(TAUHFT(IND,J+1)*DELI2+TAUHFT(IND+1,J+1)*DELI1)*DELJ1 - END IF - TAUHF = CONST0*TEMP*UST**2*TAU1 - TAUWX = XSTRESS+TAUHF*COS(USDIRP) - TAUWY = YSTRESS+TAUHF*SIN(USDIRP) -! -! Reduces tail effect to make sure that wave-supported stress -! is less than total stress, this is borrowed from ECWAM Stresso.F -! - TAUW = SQRT(TAUWX**2+TAUWY**2) - UST2 = MAX(USTAR,EPS2)**2 - TAUWB = MIN(TAUW,MAX(UST2-EPS1,EPS2**2)) - IF (TAUWB.LT.TAUW) THEN - TAUWX=TAUWX*TAUWB/TAUW - TAUWY=TAUWY*TAUWB/TAUW - END IF -! - RETURN -! -! Formats -! + UST=USTP + ! finds the values in the tabulated stress TAUHFT + XI=UST/DELUST + IND = MAX(1,MIN (IUSTAR-1, INT(XI))) + DELI1= MAX(MIN (1. ,XI-FLOAT(IND)),0.) + DELI2= 1. - DELI1 + XJ=MAX(0.,(GRAV*Z0/MAX(UST,0.00001)**2-AALPHA) / DELALP) + J = MAX(1 ,MIN (IALPHA-1, INT(XJ))) + DELJ1= MAX(0.,MIN (1. , XJ-FLOAT(J))) + DELJ2=1. - DELJ1 + IF (TTAUWSHELTER.GT.0) THEN + XK = CONST0*TEMP / DELTAIL + I = MIN (ILEVTAIL-1, INT(XK)) + DELK1= MIN (1. ,XK-FLOAT(I)) + DELK2=1. - DELK1 + TAU1 =((TAUHFT2(IND,J,I)*DELI2+TAUHFT2(IND+1,J,I)*DELI1 )*DELJ2 & + +(TAUHFT2(IND,J+1,I)*DELI2+TAUHFT2(IND+1,J+1,I)*DELI1)*DELJ1)*DELK2 & + +((TAUHFT2(IND,J,I+1)*DELI2+TAUHFT2(IND+1,J,I+1)*DELI1 )*DELJ2 & + +(TAUHFT2(IND,J+1,I+1)*DELI2+TAUHFT2(IND+1,J+1,I+1)*DELI1)*DELJ1)*DELK1 + ELSE + TAU1 =(TAUHFT(IND,J)*DELI2+TAUHFT(IND+1,J)*DELI1 )*DELJ2 & + +(TAUHFT(IND,J+1)*DELI2+TAUHFT(IND+1,J+1)*DELI1)*DELJ1 + END IF + TAUHF = CONST0*TEMP*UST**2*TAU1 + TAUWX = XSTRESS+TAUHF*COS(USDIRP) + TAUWY = YSTRESS+TAUHF*SIN(USDIRP) + ! + ! Reduces tail effect to make sure that wave-supported stress + ! is less than total stress, this is borrowed from ECWAM Stresso.F + ! + TAUW = SQRT(TAUWX**2+TAUWY**2) + UST2 = MAX(USTAR,EPS2)**2 + TAUWB = MIN(TAUW,MAX(UST2-EPS1,EPS2**2)) + IF (TAUWB.LT.TAUW) THEN + TAUWX=TAUWX*TAUWB/TAUW + TAUWY=TAUWY*TAUWB/TAUW + END IF + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SIN4 : COMMON FACT.: ',3E10.3) +9000 FORMAT (' TEST W3SIN4 : COMMON FACT.: ',3E10.3) #endif -!/ -!/ End of W3SIN4 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SIN4 -!/ ------------------------------------------------------------------- / - SUBROUTINE INSIN4(FLTABS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | SHOM | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 30-Aug-2010 | -!/ +-----------------------------------+ -!/ -!/ 30-Aug-2010 : Origination. ( version 3.14-Ifremer ) -! -! 1. Purpose : -! -! Initialization for source term routine. -! -! 2. Method : -! -! 3. Parameters : -! -! ---------------------------------------------------------------- -! FLTABS Logical -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SIN4 Subr. W3SRC3MD Corresponding source term. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPIINV, RADE, GRAV - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE W3DISPMD, ONLY: WAVNU2 - USE W3GDATMD, ONLY: SIG, DSIP, NK, NTH, TTAUWSHELTER, & - SSDSDTH, SSDSCOS, TH, DTH, XFR, ECOS, ESIN, & - SSDSC, SSDSBRF1, SSDSBCK, SSDSBINT, SSDSPBK, & - SSDSABK, SSDSHCK, IKTAB, DCKI, SATINDICES, & - SATWEIGHTS, CUMULW, NKHS, NKD, NDTAB, QBI + !/ + !/ End of W3SIN4 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SIN4 + !/ ------------------------------------------------------------------- / + SUBROUTINE INSIN4(FLTABS) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | SHOM | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 30-Aug-2010 | + !/ +-----------------------------------+ + !/ + !/ 30-Aug-2010 : Origination. ( version 3.14-Ifremer ) + ! + ! 1. Purpose : + ! + ! Initialization for source term routine. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! ---------------------------------------------------------------- + ! FLTABS Logical + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SIN4 Subr. W3SRC3MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPIINV, RADE, GRAV + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE W3DISPMD, ONLY: WAVNU2 + USE W3GDATMD, ONLY: SIG, DSIP, NK, NTH, TTAUWSHELTER, & + SSDSDTH, SSDSCOS, TH, DTH, XFR, ECOS, ESIN, & + SSDSC, SSDSBRF1, SSDSBCK, SSDSBINT, SSDSPBK, & + SSDSABK, SSDSHCK, IKTAB, DCKI, SATINDICES, & + SATWEIGHTS, CUMULW, NKHS, NKD, NDTAB, QBI #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - LOGICAL, INTENT(IN) :: FLTABS -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER SDSNTH, ITH, I_INT, J_INT, IK, IK2, ITH2 , IS, IS2 - INTEGER IKL, ID, ICON, IKD, IKHS, IKH, TOTO - REAL C, C2 - REAL DIFF1, DIFF2, BINF, BSUP, CGG, PROF - REAL KIK, DHS, KD, KHS, KH, XT, GAM, DKH, PR, W, EPS - REAL DKD - REAL, DIMENSION(:,:) , ALLOCATABLE :: SIGTAB - REAL, DIMENSION(:,:) , ALLOCATABLE :: K1, K2 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + LOGICAL, INTENT(IN) :: FLTABS + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER SDSNTH, ITH, I_INT, J_INT, IK, IK2, ITH2 , IS, IS2 + INTEGER IKL, ID, ICON, IKD, IKHS, IKH, TOTO + REAL C, C2 + REAL DIFF1, DIFF2, BINF, BSUP, CGG, PROF + REAL KIK, DHS, KD, KHS, KH, XT, GAM, DKH, PR, W, EPS + REAL DKD + REAL, DIMENSION(:,:) , ALLOCATABLE :: SIGTAB + REAL, DIMENSION(:,:) , ALLOCATABLE :: K1, K2 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INSIN4') + CALL STRACE (IENT, 'INSIN4') #endif -! -! 1. Initializations ------------------------------------------------ * -! -! -! These precomputed tables are written in mod_def.ww3 -! - IF (FLTABS) THEN - CALL TABU_STRESS - CALL TABU_TAUHF(SIG(NK) ) !tabulate high-frequency stress: 2D table - IF (TTAUWSHELTER.GT.0) THEN - CALL TABU_TAUHF2(SIG(NK) ) !tabulate high-frequency stress: 3D table - END IF - END IF -! -! 2. SPONTANEOUS BREAKING -! 2.a Precomputes the indices for integrating the spectrum to get saturation (TEST 4xx ) -! - IF (SSDSDTH.LT.180) THEN - SDSNTH = MIN(NINT(SSDSDTH/(DTH*RADE)),NTH/2-1) - SATINDICES(:,:)=1 - SATWEIGHTS(:,:)=0. - DO ITH=1,NTH - DO I_INT=ITH-SDSNTH, ITH+SDSNTH - J_INT=I_INT - IF (I_INT.LT.1) J_INT=I_INT+NTH - IF (I_INT.GT.NTH) J_INT=I_INT-NTH - SATINDICES(I_INT-(ITH-SDSNTH)+1,ITH)=J_INT - SATWEIGHTS(I_INT-(ITH-SDSNTH)+1,ITH)= & - COS(TH(ITH)-TH(J_INT))**SSDSCOS - END DO - END DO - ELSE - SATINDICES(:,:)=1 - SATWEIGHTS(:,:)=1. - END IF -!/ ------------------------------------------------------------------- / -! -! Precomputes QBI and DCKI (TEST 500) -! - IF (SSDSBCK.GT.0) THEN -! -! Precomputes the indices for integrating the spectrum over frequency bandwidth -! - BINF=(1-SSDSBINT) ! Banner et al 2002: Hp=4*sqrt(int_0.7^1.3fp E df), SSDSBINT=0.3 - BSUP=(1+SSDSBINT) - KIK=0. -! -! High frequency tail for convolution calculation -! - ALLOCATE(K1(NK,NDTAB)) - ALLOCATE(K2(NK,NDTAB)) - ALLOCATE(SIGTAB(NK,NDTAB)) + ! + ! 1. Initializations ------------------------------------------------ * + ! + ! + ! These precomputed tables are written in mod_def.ww3 + ! + IF (FLTABS) THEN + CALL TABU_STRESS + CALL TABU_TAUHF(SIG(NK) ) !tabulate high-frequency stress: 2D table + IF (TTAUWSHELTER.GT.0) THEN + CALL TABU_TAUHF2(SIG(NK) ) !tabulate high-frequency stress: 3D table + END IF + END IF + ! + ! 2. SPONTANEOUS BREAKING + ! 2.a Precomputes the indices for integrating the spectrum to get saturation (TEST 4xx ) + ! + IF (SSDSDTH.LT.180) THEN + SDSNTH = MIN(NINT(SSDSDTH/(DTH*RADE)),NTH/2-1) + SATINDICES(:,:)=1 + SATWEIGHTS(:,:)=0. + DO ITH=1,NTH + DO I_INT=ITH-SDSNTH, ITH+SDSNTH + J_INT=I_INT + IF (I_INT.LT.1) J_INT=I_INT+NTH + IF (I_INT.GT.NTH) J_INT=I_INT-NTH + SATINDICES(I_INT-(ITH-SDSNTH)+1,ITH)=J_INT + SATWEIGHTS(I_INT-(ITH-SDSNTH)+1,ITH)= & + COS(TH(ITH)-TH(J_INT))**SSDSCOS + END DO + END DO + ELSE + SATINDICES(:,:)=1 + SATWEIGHTS(:,:)=1. + END IF + !/ ------------------------------------------------------------------- / + ! + ! Precomputes QBI and DCKI (TEST 500) + ! + IF (SSDSBCK.GT.0) THEN + ! + ! Precomputes the indices for integrating the spectrum over frequency bandwidth + ! + BINF=(1-SSDSBINT) ! Banner et al 2002: Hp=4*sqrt(int_0.7^1.3fp E df), SSDSBINT=0.3 + BSUP=(1+SSDSBINT) + KIK=0. + ! + ! High frequency tail for convolution calculation + ! + ALLOCATE(K1(NK,NDTAB)) + ALLOCATE(K2(NK,NDTAB)) + ALLOCATE(SIGTAB(NK,NDTAB)) - SIGTAB=0. !contains frequency for upper windows boundaries - IKTAB=0 ! contains indices for upper windows boundaries - - DO ID=1,NDTAB - TOTO=0 - PROF=REAL(ID) - DO IKL=1,NK ! last window starts at IK=NK - CALL WAVNU2(SIG(IKL), PROF, KIK, CGG, 1E-7, 15, ICON) - K1(IKL,ID)=KIK ! wavenumber lower boundary (is directly related to the frequency indices, IK) - K2(IKL,ID)=((BSUP/BINF)**2.)*K1(IKL,ID)! wavenumber upper boundary - SIGTAB(IKL,ID)=SQRT(GRAV*K2(IKL,ID)*TANH(K2(IKL,ID)*ID)) ! corresponding frequency upper boundary - IF(SIGTAB(IKL,ID) .LE. SIG(1)) THEN - IKTAB(IKL,ID)=1 + SIGTAB=0. !contains frequency for upper windows boundaries + IKTAB=0 ! contains indices for upper windows boundaries + + DO ID=1,NDTAB + TOTO=0 + PROF=REAL(ID) + DO IKL=1,NK ! last window starts at IK=NK + CALL WAVNU2(SIG(IKL), PROF, KIK, CGG, 1E-7, 15, ICON) + K1(IKL,ID)=KIK ! wavenumber lower boundary (is directly related to the frequency indices, IK) + K2(IKL,ID)=((BSUP/BINF)**2.)*K1(IKL,ID)! wavenumber upper boundary + SIGTAB(IKL,ID)=SQRT(GRAV*K2(IKL,ID)*TANH(K2(IKL,ID)*ID)) ! corresponding frequency upper boundary + IF(SIGTAB(IKL,ID) .LE. SIG(1)) THEN + IKTAB(IKL,ID)=1 + END IF + IF(SIGTAB(IKL,ID) .GT. SIG(NK)) THEN + IKTAB(IKL,ID)=NK+TOTO ! in w3sds4 only windows with IKSUP<=NK will be kept + TOTO=1 + END IF + DO IK=1,NK-1 + DIFF1=0. + DIFF2=0. + IF(SIG(IK)=SIGTAB(IKL,ID)) THEN + DIFF1=SIGTAB(IKL,ID)-SIG(IK) ! seeks the indices of the upper boundary + DIFF2=SIG(IK+1)-SIGTAB(IKL,ID)! the indices of lower boudary = IK + IF (DIFF1=SIGTAB(IKL,ID)) THEN - DIFF1=SIGTAB(IKL,ID)-SIG(IK) ! seeks the indices of the upper boundary - DIFF2=SIG(IK+1)-SIGTAB(IKL,ID)! the indices of lower boudary = IK - IF (DIFF1TAUW. -! ---------------------------------------------------------------------- - INTEGER I,J,ITER - REAL ZTAUW,UTOP,CDRAG,WCD,USTOLD,TAUOLD - REAL X,UST,ZZ0,ZNU,F,DELF,ZZ00 -! -! - DELU = UMAX/FLOAT(JUMAX) - DELTAUW = TAUWMAX/FLOAT(ITAUMAX) - DO I=0,ITAUMAX - ZTAUW = (REAL(I)*DELTAUW)**2 - DO J=0,JUMAX - UTOP = FLOAT(J)*DELU - CDRAG = 0.0012875 - WCD = SQRT(CDRAG) - USTOLD = UTOP*WCD - TAUOLD = MAX(USTOLD**2, ZTAUW+EPS1) - DO ITER=1,NITER - X = ZTAUW/TAUOLD - UST = SQRT(TAUOLD) - ZZ00=AALPHA*TAUOLD/GRAV - IF (ZZ0MAX.NE.0) ZZ00=MIN(ZZ00,ZZ0MAX) - ! Corrects roughness ZZ00 for quasi-linear effect - ZZ0 = ZZ00/(1.-X)**XM - !ZNU = 0.1*nu_air/UST ! This was removed by Bidlot in 1996 - !ZZ0 = MAX(ZNU,ZZ0) - F = UST-KAPPA*UTOP/(ALOG(ZZWND/ZZ0)) - DELF= 1.-KAPPA*UTOP/(ALOG(ZZWND/ZZ0))**2*2./UST & - *(1.-(XM+1)*X)/(1.-X) - UST = UST-F/DELF - TAUOLD= MAX(UST**2., ZTAUW+EPS1) - END DO - TAUT(I,J) = SQRT(TAUOLD) - END DO - END DO - I=ITAUMAX - J=JUMAX -! -! Force zero wind to have zero stress (Bidlot 1996) -! - DO I=0,ITAUMAX - TAUT(I,0)=0.0 END DO - RETURN - END SUBROUTINE TABU_STRESS -!/ ------------------------------------------------------------------- / - SUBROUTINE TABU_TAUHF(SIGMAX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update 2006/08/14 | -!/ +-----------------------------------+ -!/ -!/ 27-Feb-2004 : Origination in WW3 ( version 2.22.SHOM ) -!/ the resulting table was checked to be identical to the original f77 result -!/ 14-Aug-2006 : Modified following Bidlot ( version 2.22.SHOM ) -!/ 18-Aug-2006 : Ported to version 3.09 -! -! 1. Purpose : -! -! Tabulation of the high-frequency wave-supported stress -! -! 2. Method : -! -! SEE REFERENCE FOR WAVE STRESS CALCULATION. -! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. -! See tech. Memo ECMWF 03 december 2003 by Bidlot & Janssen -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! SIGMAX Real I maximum frequency * TPI -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3SIN3 Wind input Source term routine. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: KAPPA, GRAV + END DO + ELSE + CUMULW(:,:)=0. + END IF + !/ + !/ End of INSIN4 ----------------------------------------------------- / + !/ + END SUBROUTINE INSIN4 + ! ---------------------------------------------------------------------- + SUBROUTINE TABU_STRESS + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 17-Oct-2007 | + !/ +-----------------------------------+ + !/ + !/ 23-Jun-2006 : Origination. ( version 3.13 ) + !/ adapted from WAM, original:P.A.E.M. JANSSEN KNMI AUGUST 1990 + !/ adapted version (subr. STRESS): J. BIDLOT ECMWF OCTOBER 2004 + !/ Table values were checkes against the original f90 result and found to + !/ be identical (at least at 0.001 m/s accuracy) + !/ + ! 1. Purpose : + ! TO GENERATE friction velocity table TAUT(TAUW,U10)=SQRT(TAU). + ! METHOD. + ! A STEADY STATE WIND PROFILE IS ASSUMED. + ! THE WIND STRESS IS COMPUTED USING THE ROUGHNESSLENGTH + ! Z1=Z0/SQRT(1-TAUW/TAU) + ! WHERE Z0 IS THE CHARNOCK RELATION , TAUW IS THE WAVE- + ! INDUCED STRESS AND TAU IS THE TOTAL STRESS. + ! WE SEARCH FOR STEADY-STATE SOLUTIONS FOR WHICH TAUW/TAU < 1. + ! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. + ! + ! Initialization for source term routine. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SIN3 Subr. W3SRC3MD Corresponding source term. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: KAPPA, GRAV + USE W3GDATMD, ONLY: ZZWND, AALPHA, ZZ0MAX + IMPLICIT NONE + INTEGER, PARAMETER :: NITER=10 + REAL , PARAMETER :: XM=0.50, EPS1=0.00001 + ! VARIABLE. TYPE. PURPOSE. + ! *XM* REAL POWER OF TAUW/TAU IN ROUGHNESS LENGTH. + ! *XNU* REAL KINEMATIC VISCOSITY OF AIR. + ! *NITER* INTEGER NUMBER OF ITERATIONS TO OBTAIN TOTAL STRESS + ! *EPS1* REAL SMALL NUMBER TO MAKE SURE THAT A SOLUTION + ! IS OBTAINED IN ITERATION WITH TAU>TAUW. + ! ---------------------------------------------------------------------- + INTEGER I,J,ITER + REAL ZTAUW,UTOP,CDRAG,WCD,USTOLD,TAUOLD + REAL X,UST,ZZ0,ZNU,F,DELF,ZZ00 + ! + ! + DELU = UMAX/FLOAT(JUMAX) + DELTAUW = TAUWMAX/FLOAT(ITAUMAX) + DO I=0,ITAUMAX + ZTAUW = (REAL(I)*DELTAUW)**2 + DO J=0,JUMAX + UTOP = FLOAT(J)*DELU + CDRAG = 0.0012875 + WCD = SQRT(CDRAG) + USTOLD = UTOP*WCD + TAUOLD = MAX(USTOLD**2, ZTAUW+EPS1) + DO ITER=1,NITER + X = ZTAUW/TAUOLD + UST = SQRT(TAUOLD) + ZZ00=AALPHA*TAUOLD/GRAV + IF (ZZ0MAX.NE.0) ZZ00=MIN(ZZ00,ZZ0MAX) + ! Corrects roughness ZZ00 for quasi-linear effect + ZZ0 = ZZ00/(1.-X)**XM + !ZNU = 0.1*nu_air/UST ! This was removed by Bidlot in 1996 + !ZZ0 = MAX(ZNU,ZZ0) + F = UST-KAPPA*UTOP/(ALOG(ZZWND/ZZ0)) + DELF= 1.-KAPPA*UTOP/(ALOG(ZZWND/ZZ0))**2*2./UST & + *(1.-(XM+1)*X)/(1.-X) + UST = UST-F/DELF + TAUOLD= MAX(UST**2., ZTAUW+EPS1) + END DO + TAUT(I,J) = SQRT(TAUOLD) + END DO + END DO + I=ITAUMAX + J=JUMAX + ! + ! Force zero wind to have zero stress (Bidlot 1996) + ! + DO I=0,ITAUMAX + TAUT(I,0)=0.0 + END DO + RETURN + END SUBROUTINE TABU_STRESS + !/ ------------------------------------------------------------------- / + SUBROUTINE TABU_TAUHF(SIGMAX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update 2006/08/14 | + !/ +-----------------------------------+ + !/ + !/ 27-Feb-2004 : Origination in WW3 ( version 2.22.SHOM ) + !/ the resulting table was checked to be identical to the original f77 result + !/ 14-Aug-2006 : Modified following Bidlot ( version 2.22.SHOM ) + !/ 18-Aug-2006 : Ported to version 3.09 + ! + ! 1. Purpose : + ! + ! Tabulation of the high-frequency wave-supported stress + ! + ! 2. Method : + ! + ! SEE REFERENCE FOR WAVE STRESS CALCULATION. + ! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. + ! See tech. Memo ECMWF 03 december 2003 by Bidlot & Janssen + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! SIGMAX Real I maximum frequency * TPI + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3SIN3 Wind input Source term routine. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: KAPPA, GRAV #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3GDATMD, ONLY: AALPHA, BBETA, ZZALP, FACHFE, ZZ0MAX + USE W3GDATMD, ONLY: AALPHA, BBETA, ZZALP, FACHFE, ZZ0MAX #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, intent(in) :: SIGMAX ! maximum frequency -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -! USTARM R.A. Maximum friction velocity -! ALPHAM R.A. Maximum Charnock Coefficient -! WLV R.A. Water levels. -! UA R.A. Absolute wind speeds. -! UD R.A. Absolute wind direction. -! U10 R.A. Wind speed used. -! U10D R.A. Wind direction used. -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, intent(in) :: SIGMAX ! maximum frequency + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + ! USTARM R.A. Maximum friction velocity + ! ALPHAM R.A. Maximum Charnock Coefficient + ! WLV R.A. Water levels. + ! UA R.A. Absolute wind speeds. + ! UD R.A. Absolute wind direction. + ! U10 R.A. Wind speed used. + ! U10D R.A. Wind direction used. + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: USTARM, ALPHAM - REAL :: CONST1, OMEGA, OMEGAC - REAL :: UST, ZZ0,OMEGACC, CM - INTEGER, PARAMETER :: JTOT=250 - REAL, ALLOCATABLE :: W(:) - REAL :: ZX,ZARG,ZMU,ZLOG,ZZ00,ZBETA - REAL :: Y,YC,DELY - INTEGER :: J,K,L - REAL :: X0 -! + REAL :: USTARM, ALPHAM + REAL :: CONST1, OMEGA, OMEGAC + REAL :: UST, ZZ0,OMEGACC, CM + INTEGER, PARAMETER :: JTOT=250 + REAL, ALLOCATABLE :: W(:) + REAL :: ZX,ZARG,ZMU,ZLOG,ZZ00,ZBETA + REAL :: Y,YC,DELY + INTEGER :: J,K,L + REAL :: X0 + ! #ifdef W3_S - CALL STRACE (IENT, 'TABU_HF') + CALL STRACE (IENT, 'TABU_HF') #endif -! - USTARM = 5. - ALPHAM = 20.*AALPHA - DELUST = USTARM/REAL(IUSTAR) - DELALP = ALPHAM/REAL(IALPHA) - CONST1 = BBETA/KAPPA**2 - OMEGAC = SIGMAX -! - TAUHFT(0:IUSTAR,0:IALPHA)=0. !table initialization -! - ALLOCATE(W(JTOT)) - W(2:JTOT-1)=1. - W(1)=0.5 - W(JTOT)=0.5 - X0 = 0.05 -! - DO L=0,IALPHA - DO K=0,IUSTAR - UST = MAX(REAL(K)*DELUST,0.000001) - ZZ00 = UST**2*AALPHA/GRAV - IF (ZZ0MAX.NE.0) ZZ00=MIN(ZZ00,ZZ0MAX) - ZZ0 = ZZ00*(1+FLOAT(L)*DELALP/AALPHA) - OMEGACC = MAX(OMEGAC,X0*GRAV/UST) - YC = OMEGACC*SQRT(ZZ0/GRAV) - DELY = MAX((1.-YC)/REAL(JTOT),0.) - ! For a given value of UST and ALPHA, - ! the wave-supported stress is integrated all the way - ! to 0.05*g/UST - DO J=1,JTOT - Y = YC+REAL(J-1)*DELY - OMEGA = Y*SQRT(GRAV/ZZ0) - ! This is the deep water phase speed - CM = GRAV/OMEGA - !this is the inverse wave age, shifted by ZZALP (tuning) - ZX = UST/CM +ZZALP - ZARG = MIN(KAPPA/ZX,20.) - ZMU = MIN(GRAV*ZZ0/CM**2*EXP(ZARG),1.) - ZLOG = MIN(ALOG(ZMU),0.) - ZBETA = CONST1*ZMU*ZLOG**4 - ! Power of Y in denominator should be FACHFE-4 tail applied here - TAUHFT(K,L) = TAUHFT(K,L)+W(J)*ZBETA/Y*DELY - END DO + ! + USTARM = 5. + ALPHAM = 20.*AALPHA + DELUST = USTARM/REAL(IUSTAR) + DELALP = ALPHAM/REAL(IALPHA) + CONST1 = BBETA/KAPPA**2 + OMEGAC = SIGMAX + ! + TAUHFT(0:IUSTAR,0:IALPHA)=0. !table initialization + ! + ALLOCATE(W(JTOT)) + W(2:JTOT-1)=1. + W(1)=0.5 + W(JTOT)=0.5 + X0 = 0.05 + ! + DO L=0,IALPHA + DO K=0,IUSTAR + UST = MAX(REAL(K)*DELUST,0.000001) + ZZ00 = UST**2*AALPHA/GRAV + IF (ZZ0MAX.NE.0) ZZ00=MIN(ZZ00,ZZ0MAX) + ZZ0 = ZZ00*(1+FLOAT(L)*DELALP/AALPHA) + OMEGACC = MAX(OMEGAC,X0*GRAV/UST) + YC = OMEGACC*SQRT(ZZ0/GRAV) + DELY = MAX((1.-YC)/REAL(JTOT),0.) + ! For a given value of UST and ALPHA, + ! the wave-supported stress is integrated all the way + ! to 0.05*g/UST + DO J=1,JTOT + Y = YC+REAL(J-1)*DELY + OMEGA = Y*SQRT(GRAV/ZZ0) + ! This is the deep water phase speed + CM = GRAV/OMEGA + !this is the inverse wave age, shifted by ZZALP (tuning) + ZX = UST/CM +ZZALP + ZARG = MIN(KAPPA/ZX,20.) + ZMU = MIN(GRAV*ZZ0/CM**2*EXP(ZARG),1.) + ZLOG = MIN(ALOG(ZMU),0.) + ZBETA = CONST1*ZMU*ZLOG**4 + ! Power of Y in denominator should be FACHFE-4 tail applied here + TAUHFT(K,L) = TAUHFT(K,L)+W(J)*ZBETA/Y*DELY + END DO #ifdef W3_T - WRITE (NDST,9000) L,K,AALPHA+FLOAT(L)*DELALP,UST,TAUHFT(K,L) + WRITE (NDST,9000) L,K,AALPHA+FLOAT(L)*DELALP,UST,TAUHFT(K,L) #endif - END DO END DO - DEALLOCATE(W) - RETURN + END DO + DEALLOCATE(W) + RETURN #ifdef W3_T - 9000 FORMAT ('TABU_HF, L, K, ALPHA, UST, TAUHFT(K,L) :',(2I4,3F8.3)) +9000 FORMAT ('TABU_HF, L, K, ALPHA, UST, TAUHFT(K,L) :',(2I4,3F8.3)) #endif - END SUBROUTINE TABU_TAUHF + END SUBROUTINE TABU_TAUHF -!/ ------------------------------------------------------------------- / - SUBROUTINE TABU_TAUHF2(SIGMAX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update 2006/08/14 | -!/ | Last update 2013/01/24 | -!/ +-----------------------------------+ -!/ -!/ 15-May-2007 : Origination in WW3 ( version 3.10.SHOM ) -!/ 24-Jan-2013 : Allows to read in table ( version 4.08 ) -! -! 1. Purpose : -! -! Tabulation of the high-frequency wave-supported stress as a function of -! ustar, alpha (modified Charnock), and tail energy level -! -! 2. Method : -! -! SEE REFERENCE FOR WAVE STRESS CALCULATION. -! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. -! See tech. Memo ECMWF 03 december 2003 by Bidlot & Janssen -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! SIGMAX Real I maximum frequency*TPI -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3SIN3 Wind input Source term routine. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: KAPPA, GRAV, file_endian + !/ ------------------------------------------------------------------- / + SUBROUTINE TABU_TAUHF2(SIGMAX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update 2006/08/14 | + !/ | Last update 2013/01/24 | + !/ +-----------------------------------+ + !/ + !/ 15-May-2007 : Origination in WW3 ( version 3.10.SHOM ) + !/ 24-Jan-2013 : Allows to read in table ( version 4.08 ) + ! + ! 1. Purpose : + ! + ! Tabulation of the high-frequency wave-supported stress as a function of + ! ustar, alpha (modified Charnock), and tail energy level + ! + ! 2. Method : + ! + ! SEE REFERENCE FOR WAVE STRESS CALCULATION. + ! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. + ! See tech. Memo ECMWF 03 december 2003 by Bidlot & Janssen + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! SIGMAX Real I maximum frequency*TPI + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3SIN3 Wind input Source term routine. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: KAPPA, GRAV, file_endian #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3GDATMD, ONLY: AALPHA, BBETA, ZZALP, FACHFE, & - TTAUWSHELTER, ZZ0MAX - USE W3ODATMD, ONLY: NDSE + USE W3GDATMD, ONLY: AALPHA, BBETA, ZZALP, FACHFE, & + TTAUWSHELTER, ZZ0MAX + USE W3ODATMD, ONLY: NDSE #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, intent(in) :: SIGMAX ! maximum frequency * TPI -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -! USTARM R.A. Maximum friction velocity -! ALPHAM R.A. Maximum Charnock Coefficient -! WLV R.A. Water levels. -! UA R.A. Absolute wind speeds. -! UD R.A. Absolute wind direction. -! U10 R.A. Wind speed used. -! U10D R.A. Wind direction used. -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, intent(in) :: SIGMAX ! maximum frequency * TPI + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + ! USTARM R.A. Maximum friction velocity + ! ALPHAM R.A. Maximum Charnock Coefficient + ! WLV R.A. Water levels. + ! UA R.A. Absolute wind speeds. + ! UD R.A. Absolute wind direction. + ! U10 R.A. Wind speed used. + ! U10D R.A. Wind direction used. + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: USTARM, ALPHAM, LEVTAILM - REAL :: CONST1, OMEGA, OMEGAC, LEVTAIL - REAL :: UST, UST0, ZZ0,OMEGACC, CM - REAL :: TAUW, TAUW0 - INTEGER, PARAMETER :: JTOT=250 - REAL, ALLOCATABLE :: W(:) - REAL :: ZX,ZARG,ZMU,ZLOG,ZBETA - REAL :: Y,YC,DELY - INTEGER :: I, J, K, L - REAL :: X0, INSIGMAX, INAALPHA, INBBETA, INZZALP, INKAPPA, INGRAV - INTEGER :: INIUSTAR, INIALPHA, INILEVTAIL, IERR - CHARACTER(160) :: FNAMETAB - LOGICAL :: NOFILE - CHARACTER(LEN=10), PARAMETER :: VERGRD = '2018-06-08' - CHARACTER(LEN=35), PARAMETER :: IDSTR = 'WAVEWATCH III ST4 TABLE FOR STRESS ' - CHARACTER(LEN=10) :: VERTST=' ' - CHARACTER(LEN=35) :: IDTST=' ' -! + REAL :: USTARM, ALPHAM, LEVTAILM + REAL :: CONST1, OMEGA, OMEGAC, LEVTAIL + REAL :: UST, UST0, ZZ0,OMEGACC, CM + REAL :: TAUW, TAUW0 + INTEGER, PARAMETER :: JTOT=250 + REAL, ALLOCATABLE :: W(:) + REAL :: ZX,ZARG,ZMU,ZLOG,ZBETA + REAL :: Y,YC,DELY + INTEGER :: I, J, K, L + REAL :: X0, INSIGMAX, INAALPHA, INBBETA, INZZALP, INKAPPA, INGRAV + INTEGER :: INIUSTAR, INIALPHA, INILEVTAIL, IERR + CHARACTER(160) :: FNAMETAB + LOGICAL :: NOFILE + CHARACTER(LEN=10), PARAMETER :: VERGRD = '2018-06-08' + CHARACTER(LEN=35), PARAMETER :: IDSTR = 'WAVEWATCH III ST4 TABLE FOR STRESS ' + CHARACTER(LEN=10) :: VERTST=' ' + CHARACTER(LEN=35) :: IDTST=' ' + ! #ifdef W3_S - CALL STRACE (IENT, 'TABU_HF') + CALL STRACE (IENT, 'TABU_HF') #endif -! - FNAMETAB='ST4TABUHF2.bin' - NOFILE=.TRUE. - OPEN (993,FILE=FNAMETAB,form='UNFORMATTED', convert=file_endian,IOSTAT=IERR,STATUS='OLD') - IF (IERR.EQ.0) THEN - READ(993,IOSTAT=IERR) IDTST, VERTST, INSIGMAX, INAALPHA, INBBETA, INIUSTAR, & - INIALPHA, INILEVTAIL, INZZALP, INKAPPA, INGRAV - IF (VERTST.EQ.VERGRD.AND.IDTST.EQ.IDSTR.AND.IERR.EQ.0 & - .AND.INSIGMAX.EQ.SIGMAX.AND.INAALPHA.EQ.AALPHA.AND.INBBETA.EQ.BBETA) THEN - IF (INIUSTAR.EQ.IUSTAR.AND.INIALPHA.EQ.IALPHA.AND.INILEVTAIL.EQ.ILEVTAIL.AND. & - INZZALP.EQ.ZZALP.AND.INGRAV.EQ.GRAV.AND.INKAPPA.EQ.KAPPA) THEN - NOFILE=.FALSE. - ELSE - CLOSE(993) - END IF - END IF - END IF -! - USTARM = 5. - ALPHAM = 20.*AALPHA - LEVTAILM = 0.05 - DELUST = USTARM/REAL(IUSTAR) - DELALP = ALPHAM/REAL(IALPHA) - DELTAIL = ALPHAM/REAL(ILEVTAIL) - CONST1 = BBETA/KAPPA**2 - OMEGAC = SIGMAX -800 CONTINUE - IF ( NOFILE ) THEN - WRITE(NDSE,*) 'Filling 3D look-up table for SIN4. please wait' - WRITE(NDSE,*) IDSTR, VERGRD, SIGMAX, AALPHA, BBETA, IUSTAR, IALPHA, & - ILEVTAIL, ZZALP, KAPPA, GRAV -! - TAUHFT(0:IUSTAR,0:IALPHA)=0. !table initialization -! - ALLOCATE(W(JTOT)) - W(2:JTOT-1)=1. - W(1)=0.5 - W(JTOT)=0.5 - X0 = 0.05 -! - DO K=0,IUSTAR - UST0 = MAX(REAL(K)*DELUST,0.000001) - DO L=0,IALPHA - UST=UST0 - ZZ0 = UST0**2*(AALPHA+FLOAT(L)*DELALP)/GRAV - OMEGACC = MAX(OMEGAC,X0*GRAV/UST) - YC = OMEGACC*SQRT(ZZ0/GRAV) - DELY = MAX((1.-YC)/REAL(JTOT),0.) - ! For a given value of UST and ALPHA, + ! + FNAMETAB='ST4TABUHF2.bin' + NOFILE=.TRUE. + OPEN (993,FILE=FNAMETAB,form='UNFORMATTED', convert=file_endian,IOSTAT=IERR,STATUS='OLD') + IF (IERR.EQ.0) THEN + READ(993,IOSTAT=IERR) IDTST, VERTST, INSIGMAX, INAALPHA, INBBETA, INIUSTAR, & + INIALPHA, INILEVTAIL, INZZALP, INKAPPA, INGRAV + IF (VERTST.EQ.VERGRD.AND.IDTST.EQ.IDSTR.AND.IERR.EQ.0 & + .AND.INSIGMAX.EQ.SIGMAX.AND.INAALPHA.EQ.AALPHA.AND.INBBETA.EQ.BBETA) THEN + IF (INIUSTAR.EQ.IUSTAR.AND.INIALPHA.EQ.IALPHA.AND.INILEVTAIL.EQ.ILEVTAIL.AND. & + INZZALP.EQ.ZZALP.AND.INGRAV.EQ.GRAV.AND.INKAPPA.EQ.KAPPA) THEN + NOFILE=.FALSE. + ELSE + CLOSE(993) + END IF + END IF + END IF + ! + USTARM = 5. + ALPHAM = 20.*AALPHA + LEVTAILM = 0.05 + DELUST = USTARM/REAL(IUSTAR) + DELALP = ALPHAM/REAL(IALPHA) + DELTAIL = ALPHAM/REAL(ILEVTAIL) + CONST1 = BBETA/KAPPA**2 + OMEGAC = SIGMAX +800 CONTINUE + IF ( NOFILE ) THEN + WRITE(NDSE,*) 'Filling 3D look-up table for SIN4. please wait' + WRITE(NDSE,*) IDSTR, VERGRD, SIGMAX, AALPHA, BBETA, IUSTAR, IALPHA, & + ILEVTAIL, ZZALP, KAPPA, GRAV + ! + TAUHFT(0:IUSTAR,0:IALPHA)=0. !table initialization + ! + ALLOCATE(W(JTOT)) + W(2:JTOT-1)=1. + W(1)=0.5 + W(JTOT)=0.5 + X0 = 0.05 + ! + DO K=0,IUSTAR + UST0 = MAX(REAL(K)*DELUST,0.000001) + DO L=0,IALPHA + UST=UST0 + ZZ0 = UST0**2*(AALPHA+FLOAT(L)*DELALP)/GRAV + OMEGACC = MAX(OMEGAC,X0*GRAV/UST) + YC = OMEGACC*SQRT(ZZ0/GRAV) + DELY = MAX((1.-YC)/REAL(JTOT),0.) + ! For a given value of UST and ALPHA, ! the wave-supported stress is integrated all the way ! to 0.05*g/UST - DO I=0,ILEVTAIL - LEVTAIL=REAL(I)*DELTAIL - TAUHFT(K,L)=0. - TAUHFT2(K,L,I)=0. - TAUW0=UST0**2 - TAUW=TAUW0 - DO J=1,JTOT - Y = YC+REAL(J-1)*DELY - OMEGA = Y*SQRT(GRAV/ZZ0) - ! This is the deep water phase speed - CM = GRAV/OMEGA - !this is the inverse wave age, shifted by ZZALP (tuning) - ZX = UST0/CM +ZZALP - ZARG = MIN(KAPPA/ZX,20.) - ZMU = MIN(GRAV*ZZ0/CM**2*EXP(ZARG),1.) - ZLOG = MIN(ALOG(ZMU),0.) - ZBETA = CONST1*ZMU*ZLOG**4 - ! Power of Y in denominator should be FACHFE-4 - TAUHFT(K,L) = TAUHFT(K,L)+W(J)*ZBETA/Y*DELY - ZX = UST/CM +ZZALP - ZARG = MIN(KAPPA/ZX,20.) - ZMU = MIN(GRAV*ZZ0/CM**2*EXP(ZARG),1.) - ZLOG = MIN(ALOG(ZMU),0.) - ZBETA = CONST1*ZMU*ZLOG**4 - ! Power of Y in denominator should be FACHFE-4 - TAUHFT2(K,L,I) = TAUHFT2(K,L,I)+W(J)*ZBETA*(UST/UST0)**2/Y*DELY - TAUW=TAUW-W(J)*UST**2*ZBETA*LEVTAIL/Y*DELY - UST=SQRT(MAX(TAUW,0.)) - END DO + DO I=0,ILEVTAIL + LEVTAIL=REAL(I)*DELTAIL + TAUHFT(K,L)=0. + TAUHFT2(K,L,I)=0. + TAUW0=UST0**2 + TAUW=TAUW0 + DO J=1,JTOT + Y = YC+REAL(J-1)*DELY + OMEGA = Y*SQRT(GRAV/ZZ0) + ! This is the deep water phase speed + CM = GRAV/OMEGA + !this is the inverse wave age, shifted by ZZALP (tuning) + ZX = UST0/CM +ZZALP + ZARG = MIN(KAPPA/ZX,20.) + ZMU = MIN(GRAV*ZZ0/CM**2*EXP(ZARG),1.) + ZLOG = MIN(ALOG(ZMU),0.) + ZBETA = CONST1*ZMU*ZLOG**4 + ! Power of Y in denominator should be FACHFE-4 + TAUHFT(K,L) = TAUHFT(K,L)+W(J)*ZBETA/Y*DELY + ZX = UST/CM +ZZALP + ZARG = MIN(KAPPA/ZX,20.) + ZMU = MIN(GRAV*ZZ0/CM**2*EXP(ZARG),1.) + ZLOG = MIN(ALOG(ZMU),0.) + ZBETA = CONST1*ZMU*ZLOG**4 + ! Power of Y in denominator should be FACHFE-4 + TAUHFT2(K,L,I) = TAUHFT2(K,L,I)+W(J)*ZBETA*(UST/UST0)**2/Y*DELY + TAUW=TAUW-W(J)*UST**2*ZBETA*LEVTAIL/Y*DELY + UST=SQRT(MAX(TAUW,0.)) + END DO #ifdef W3_T - WRITE (NDST,9000) K,L,I,UST0,AALPHA+FLOAT(L)*DELALP,LEVTAIL,TAUHFT2(K,L,I) + WRITE (NDST,9000) K,L,I,UST0,AALPHA+FLOAT(L)*DELALP,LEVTAIL,TAUHFT2(K,L,I) #endif - END DO - END DO END DO - DEALLOCATE(W) - OPEN (993,FILE=FNAMETAB,form='UNFORMATTED', convert=file_endian,IOSTAT=IERR,STATUS='UNKNOWN') - WRITE(993) IDSTR, VERGRD, SIGMAX, AALPHA, BBETA, IUSTAR, IALPHA, ILEVTAIL, ZZALP, KAPPA, GRAV - WRITE(993) TAUHFT(0:IUSTAR,0:IALPHA) - WRITE(993) TAUHFT2 - CLOSE(993) - !DO K=0,IUSTAR - ! DO L=0,IALPHA - ! DO I=0,ILEVTAIL - ! WRITE(995,*) K,L,I,MAX(REAL(K)*DELUST,0.000001),AALPHA+FLOAT(L)*DELALP,REAL(I)*DELTAIL,TAUHFT(K,L),TAUHFT2(K,L,I) - ! END DO - ! END DO - ! END DO -! - ELSE - WRITE(NDSE,*) 'Reading 3D look-up table for SIN4 from file.' - READ(993,ERR=2000,IOSTAT=IERR ) TAUHFT(0:IUSTAR,0:IALPHA) - READ(993,ERR=2000,IOSTAT=IERR ) TAUHFT2 - CLOSE(993) - END IF -! - GOTO 2001 -2000 NOFILE=.TRUE. - GOTO 800 -2001 CONTINUE - RETURN + END DO + END DO + DEALLOCATE(W) + OPEN (993,FILE=FNAMETAB,form='UNFORMATTED', convert=file_endian,IOSTAT=IERR,STATUS='UNKNOWN') + WRITE(993) IDSTR, VERGRD, SIGMAX, AALPHA, BBETA, IUSTAR, IALPHA, ILEVTAIL, ZZALP, KAPPA, GRAV + WRITE(993) TAUHFT(0:IUSTAR,0:IALPHA) + WRITE(993) TAUHFT2 + CLOSE(993) + !DO K=0,IUSTAR + ! DO L=0,IALPHA + ! DO I=0,ILEVTAIL + ! WRITE(995,*) K,L,I,MAX(REAL(K)*DELUST,0.000001),AALPHA+FLOAT(L)*DELALP,REAL(I)*DELTAIL,TAUHFT(K,L),TAUHFT2(K,L,I) + ! END DO + ! END DO + ! END DO + ! + ELSE + WRITE(NDSE,*) 'Reading 3D look-up table for SIN4 from file.' + READ(993,ERR=2000,IOSTAT=IERR ) TAUHFT(0:IUSTAR,0:IALPHA) + READ(993,ERR=2000,IOSTAT=IERR ) TAUHFT2 + CLOSE(993) + END IF + ! + GOTO 2001 +2000 NOFILE=.TRUE. + GOTO 800 +2001 CONTINUE + RETURN #ifdef W3_T - 9000 FORMAT (' TEST TABU_HFT2, K, L, I, UST, ALPHA, LEVTAIL, TAUHFT2(K,L,I) :',(3I4,4F10.5)) +9000 FORMAT (' TEST TABU_HFT2, K, L, I, UST, ALPHA, LEVTAIL, TAUHFT2(K,L,I) :',(3I4,4F10.5)) #endif - END SUBROUTINE TABU_TAUHF2 + END SUBROUTINE TABU_TAUHF2 -!/ ------------------------------------------------------------------- / - SUBROUTINE CALC_USTAR(WINDSPEED,TAUW,USTAR,Z0,CHARN) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update 2006/08/14 | -!/ +-----------------------------------+ -!/ -!/ 27-Feb-2004 : Origination in WW3 ( version 2.22-SHOM ) -!/ the resulting table was checked to be identical to the original f77 result -!/ 14-Aug-2006 : Modified following Bidlot ( version 2.22-SHOM ) -!/ 18-Aug-2006 : Ported to version 3.09 -!/ 03-Apr-2010 : Adding output of Charnock parameter ( version 3.14-IFREMER ) -! -! 1. Purpose : -! -! Compute friction velocity based on wind speed U10 -! -! 2. Method : -! -! Computation of u* based on Quasi-linear theory -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! U10,TAUW,USTAR,Z0 -! ---------------------------------------------------------------- -! WINDSPEED Real I 10-m wind speed ... should be NEUTRAL -! TAUW Real I Wave-supported stress -! USTAR Real O Friction velocity. -! Z0 Real O air-side roughness length -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3SIN3 Wind input Source term routine. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -!-----------------------------------------------------------------------------! - USE CONSTANTS, ONLY: GRAV, KAPPA - USE W3GDATMD, ONLY: ZZWND, AALPHA + !/ ------------------------------------------------------------------- / + SUBROUTINE CALC_USTAR(WINDSPEED,TAUW,USTAR,Z0,CHARN) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update 2006/08/14 | + !/ +-----------------------------------+ + !/ + !/ 27-Feb-2004 : Origination in WW3 ( version 2.22-SHOM ) + !/ the resulting table was checked to be identical to the original f77 result + !/ 14-Aug-2006 : Modified following Bidlot ( version 2.22-SHOM ) + !/ 18-Aug-2006 : Ported to version 3.09 + !/ 03-Apr-2010 : Adding output of Charnock parameter ( version 3.14-IFREMER ) + ! + ! 1. Purpose : + ! + ! Compute friction velocity based on wind speed U10 + ! + ! 2. Method : + ! + ! Computation of u* based on Quasi-linear theory + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! U10,TAUW,USTAR,Z0 + ! ---------------------------------------------------------------- + ! WINDSPEED Real I 10-m wind speed ... should be NEUTRAL + ! TAUW Real I Wave-supported stress + ! USTAR Real O Friction velocity. + ! Z0 Real O air-side roughness length + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3SIN3 Wind input Source term routine. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + !-----------------------------------------------------------------------------! + USE CONSTANTS, ONLY: GRAV, KAPPA + USE W3GDATMD, ONLY: ZZWND, AALPHA #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif - IMPLICIT NONE - REAL, intent(in) :: WINDSPEED,TAUW - REAL, intent(out) :: USTAR, Z0, CHARN - ! local variables - REAL SQRTCDM1 - REAL XI,DELI1,DELI2,XJ,delj1,delj2 - REAL TAUW_LOCAL - INTEGER IND,J -! - TAUW_LOCAL=MAX(MIN(TAUW,TAUWMAX),0.) - XI = SQRT(TAUW_LOCAL)/DELTAUW - IND = MIN ( ITAUMAX-1, INT(XI)) ! index for stress table - DELI1 = MIN(1.,XI - REAL(IND)) !interpolation coefficient for stress table - DELI2 = 1. - DELI1 - XJ = WINDSPEED/DELU - J = MIN ( JUMAX-1, INT(XJ) ) - DELJ1 = MIN(1.,XJ - REAL(J)) - DELJ2 = 1. - DELJ1 - USTAR=(TAUT(IND,J)*DELI2+TAUT(IND+1,J )*DELI1)*DELJ2 & - + (TAUT(IND,J+1)*DELI2+TAUT(IND+1,J+1)*DELI1)*DELJ1 -! -! Determines roughness length -! - IF (USTAR.GT.0.001) THEN + IMPLICIT NONE + REAL, intent(in) :: WINDSPEED,TAUW + REAL, intent(out) :: USTAR, Z0, CHARN + ! local variables + REAL SQRTCDM1 + REAL XI,DELI1,DELI2,XJ,delj1,delj2 + REAL TAUW_LOCAL + INTEGER IND,J + ! + TAUW_LOCAL=MAX(MIN(TAUW,TAUWMAX),0.) + XI = SQRT(TAUW_LOCAL)/DELTAUW + IND = MIN ( ITAUMAX-1, INT(XI)) ! index for stress table + DELI1 = MIN(1.,XI - REAL(IND)) !interpolation coefficient for stress table + DELI2 = 1. - DELI1 + XJ = WINDSPEED/DELU + J = MIN ( JUMAX-1, INT(XJ) ) + DELJ1 = MIN(1.,XJ - REAL(J)) + DELJ2 = 1. - DELJ1 + USTAR=(TAUT(IND,J)*DELI2+TAUT(IND+1,J )*DELI1)*DELJ2 & + + (TAUT(IND,J+1)*DELI2+TAUT(IND+1,J+1)*DELI1)*DELJ1 + ! + ! Determines roughness length + ! + IF (USTAR.GT.0.001) THEN + SQRTCDM1 = MIN(WINDSPEED/USTAR,100.0) + Z0 = ZZWND*EXP(-KAPPA*SQRTCDM1) + CHARN = GRAV*Z0/USTAR**2 + ELSE + IF (USTAR.GT.0) THEN SQRTCDM1 = MIN(WINDSPEED/USTAR,100.0) Z0 = ZZWND*EXP(-KAPPA*SQRTCDM1) - CHARN = GRAV*Z0/USTAR**2 - ELSE - IF (USTAR.GT.0) THEN - SQRTCDM1 = MIN(WINDSPEED/USTAR,100.0) - Z0 = ZZWND*EXP(-KAPPA*SQRTCDM1) - ELSE - Z0 = AALPHA*0.001*0.001/GRAV - END IF - CHARN = AALPHA + ELSE + Z0 = AALPHA*0.001*0.001/GRAV END IF -! - RETURN - END SUBROUTINE CALC_USTAR -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SDS4 (A, K, CG, USTAR, USDIR, DEPTH, DAIR, SRHS, & - DDIAG, IX, IY, BRLAMBDA, WHITECAP, DLWMEAN ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ ! F. Ardhuin, F. Leckler, L. Romero ! -!/ | FORTRAN 90 | -!/ | Last update : 13-Aug-2021 | -!/ +-----------------------------------+ -!/ -!/ 30-Aug-2010 : Clean up from common ST3-ST4 routine( version 3.14-Ifremer ) -!/ 23-Jan-2012 : Add output of lambdas to be used in SIN -!/ 13-Nov-2013 : Reduced frequency range with IG1 switch -!/ 06-Jun-2018 : Add optional DEBUGSRC ( version 6.04 ) -!/ 22-Feb-2020 : Option to use Romero (GRL 2019) ( version 7.06 ) -!/ 13-Aug-2021 : Consider DAIR a variable ( version 7.14 ) -!/ -! 1. Purpose : -! -! Calculate whitecapping source term and diagonal term of derivative. -! -! 2. Method : -! -! This codes does either one or the other of -! Ardhuin et al. (JPO 2010) -! Filipot & Ardhuin (JGR 2012) -! Romero (GRL 2009) -! the choice depends on SDSBCHOICE -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IX, IY Int I Grid Index -! A R.A. I Action density spectrum (1-D). -! K R.A. I Wavenumber for entire spectrum. *) -! USTAR Real I Friction velocity. -! USDIR Real I wind stress direction. -! DEPTH Real I Water depth. -! DAIR Real I Air density -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative. *) -! BRLAMBDA R.A. O Phillips' Lambdas -! ---------------------------------------------------------------- -! *) Stored in 1-D array with dimension NTH*NK -! -! 4. Subroutines used : -! -! STRACE Subroutine tracing. ( !/S switch ) -! PRT2DS Print plot of spectrum. ( !/T0 switch ) -! OUTMAT Print out matrix. ( !/T1 switch ) -! -! 5. Called by : -! -! W3SRCE Source term integration. -! W3EXPO Point output program. -! GXEXPO GrADS point output program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! !/T0 2-D print plot of source term. -! !/T1 Print arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS,ONLY: GRAV, DWAT, PI, TPI, RADE, DEBUG_NODE - USE W3GDATMD, ONLY: NSPEC, NTH, NK, SSDSBR, SSDSBT, DDEN, & - SSDSC, EC2, ES2, ESC, & - SIG, SSDSP, ECOS, ESIN, DTH, AAIRGB, & - SSDSISO, SSDSDTH, SSDSBM, AAIRCMIN, & - SSDSBRFDF, SSDSBCK, IKTAB, DCKI, & - SATINDICES, SATWEIGHTS, CUMULW, NKHS, NKD, & - NDTAB, QBI + CHARN = AALPHA + END IF + ! + RETURN + END SUBROUTINE CALC_USTAR + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SDS4 (A, K, CG, USTAR, USDIR, DEPTH, DAIR, SRHS, & + DDIAG, IX, IY, BRLAMBDA, WHITECAP, DLWMEAN ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ ! F. Ardhuin, F. Leckler, L. Romero ! + !/ | FORTRAN 90 | + !/ | Last update : 13-Aug-2021 | + !/ +-----------------------------------+ + !/ + !/ 30-Aug-2010 : Clean up from common ST3-ST4 routine( version 3.14-Ifremer ) + !/ 23-Jan-2012 : Add output of lambdas to be used in SIN + !/ 13-Nov-2013 : Reduced frequency range with IG1 switch + !/ 06-Jun-2018 : Add optional DEBUGSRC ( version 6.04 ) + !/ 22-Feb-2020 : Option to use Romero (GRL 2019) ( version 7.06 ) + !/ 13-Aug-2021 : Consider DAIR a variable ( version 7.14 ) + !/ + ! 1. Purpose : + ! + ! Calculate whitecapping source term and diagonal term of derivative. + ! + ! 2. Method : + ! + ! This codes does either one or the other of + ! Ardhuin et al. (JPO 2010) + ! Filipot & Ardhuin (JGR 2012) + ! Romero (GRL 2009) + ! the choice depends on SDSBCHOICE + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IX, IY Int I Grid Index + ! A R.A. I Action density spectrum (1-D). + ! K R.A. I Wavenumber for entire spectrum. *) + ! USTAR Real I Friction velocity. + ! USDIR Real I wind stress direction. + ! DEPTH Real I Water depth. + ! DAIR Real I Air density + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative. *) + ! BRLAMBDA R.A. O Phillips' Lambdas + ! ---------------------------------------------------------------- + ! *) Stored in 1-D array with dimension NTH*NK + ! + ! 4. Subroutines used : + ! + ! STRACE Subroutine tracing. ( !/S switch ) + ! PRT2DS Print plot of spectrum. ( !/T0 switch ) + ! OUTMAT Print out matrix. ( !/T1 switch ) + ! + ! 5. Called by : + ! + ! W3SRCE Source term integration. + ! W3EXPO Point output program. + ! GXEXPO GrADS point output program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! !/T0 2-D print plot of source term. + ! !/T1 Print arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS,ONLY: GRAV, DWAT, PI, TPI, RADE, DEBUG_NODE + USE W3GDATMD, ONLY: NSPEC, NTH, NK, SSDSBR, SSDSBT, DDEN, & + SSDSC, EC2, ES2, ESC, & + SIG, SSDSP, ECOS, ESIN, DTH, AAIRGB, & + SSDSISO, SSDSDTH, SSDSBM, AAIRCMIN, & + SSDSBRFDF, SSDSBCK, IKTAB, DCKI, & + SATINDICES, SATWEIGHTS, CUMULW, NKHS, NKD, & + NDTAB, QBI #ifdef W3_IG1 - USE W3GDATMD, ONLY: IGPARS + USE W3GDATMD, ONLY: IGPARS #endif - USE W3ODATMD, ONLY: FLOGRD + USE W3ODATMD, ONLY: FLOGRD #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_T0 - USE W3ODATMD, ONLY: NDST - USE W3ARRYMD, ONLY: PRT2DS + USE W3ODATMD, ONLY: NDST + USE W3ARRYMD, ONLY: PRT2DS #endif #ifdef W3_T1 - USE W3ARRYMD, ONLY: OUTMAT + USE W3ARRYMD, ONLY: OUTMAT #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, OPTIONAL, INTENT(IN) :: IX, IY - REAL, INTENT(IN) :: A(NSPEC), K(NK), CG(NK), & - DEPTH, DAIR, USTAR, USDIR, DLWMEAN - REAL, INTENT(OUT) :: SRHS(NSPEC), DDIAG(NSPEC), BRLAMBDA(NSPEC) - REAL, INTENT(OUT) :: WHITECAP(1:4) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS, IS2, IS0, IKL, IKC, ID, NKL + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, OPTIONAL, INTENT(IN) :: IX, IY + REAL, INTENT(IN) :: A(NSPEC), K(NK), CG(NK), & + DEPTH, DAIR, USTAR, USDIR, DLWMEAN + REAL, INTENT(OUT) :: SRHS(NSPEC), DDIAG(NSPEC), BRLAMBDA(NSPEC) + REAL, INTENT(OUT) :: WHITECAP(1:4) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS, IS2, IS0, IKL, IKC, ID, NKL #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IK, IK1, ITH, IK2, JTH, ITH2, & - IKHS, IKD, SDSNTH, IT, IKM, NKM - INTEGER :: NSMOOTH(NK) - REAL :: C, COSWIND, ASUM, SDIAGISO - REAL :: COEF1, COEF2, COEF4(NK), & - COEF5(NK) + INTEGER :: IK, IK1, ITH, IK2, JTH, ITH2, & + IKHS, IKD, SDSNTH, IT, IKM, NKM + INTEGER :: NSMOOTH(NK) + REAL :: C, COSWIND, ASUM, SDIAGISO + REAL :: COEF1, COEF2, COEF4(NK), & + COEF5(NK) - REAL :: FACTURB, FACTURB2, DTURB, DVISC, DIAG2, BREAKFRACTION - REAL :: RENEWALFREQ, EPSR - REAL :: S1(NK), E1(NK) - INTEGER :: NTIMES(NK) - REAL :: GAM, XT - REAL :: DK(NK), HS(NK), KBAR(NK), DCK(NK) - REAL :: EFDF(NK) ! Energy integrated over a spectral band - INTEGER :: IKSUP(NK) - REAL :: FACSAT, DKHS, FACSTRAINB, FACSTRAINL - REAL :: BTH0(NK) !saturation spectrum - REAL :: BTH(NSPEC) !saturation spectrum - REAL :: BTH0S(NK) !smoothed saturation spectrum - REAL :: BTHS(NSPEC) !smoothed saturation spectrum - INTEGER :: IMSSMAX(NK), NTHSUM - REAL :: MSSSUM(NK,5), WTHSUM(NTH), FACHF - REAL :: MSSSUM2(NK,NTH) - REAL :: MSSLONG(NK,NTH) - REAL :: MSSPCS, MSSPC2, MSSPS2, MSSP, MSSD, MSSTH - REAL :: MICHE, X, KLOC + REAL :: FACTURB, FACTURB2, DTURB, DVISC, DIAG2, BREAKFRACTION + REAL :: RENEWALFREQ, EPSR + REAL :: S1(NK), E1(NK) + INTEGER :: NTIMES(NK) + REAL :: GAM, XT + REAL :: DK(NK), HS(NK), KBAR(NK), DCK(NK) + REAL :: EFDF(NK) ! Energy integrated over a spectral band + INTEGER :: IKSUP(NK) + REAL :: FACSAT, DKHS, FACSTRAINB, FACSTRAINL + REAL :: BTH0(NK) !saturation spectrum + REAL :: BTH(NSPEC) !saturation spectrum + REAL :: BTH0S(NK) !smoothed saturation spectrum + REAL :: BTHS(NSPEC) !smoothed saturation spectrum + INTEGER :: IMSSMAX(NK), NTHSUM + REAL :: MSSSUM(NK,5), WTHSUM(NTH), FACHF + REAL :: MSSSUM2(NK,NTH) + REAL :: MSSLONG(NK,NTH) + REAL :: MSSPCS, MSSPC2, MSSPS2, MSSP, MSSD, MSSTH + REAL :: MICHE, X, KLOC #ifdef W3_T0 REAL :: DOUT(NK,NTH) #endif - REAL :: QB(NK), S2(NK) - REAL :: TSTR, TMAX, DT, T, MFT - REAL :: PB(NSPEC), PB2(NSPEC), BRM12(NK), BTOVER - REAL :: KO, LMODULATION(NTH) -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: QB(NK), S2(NK) + REAL :: TSTR, TMAX, DT, T, MFT + REAL :: PB(NSPEC), PB2(NSPEC), BRM12(NK), BTOVER + REAL :: KO, LMODULATION(NTH) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SDS4') + CALL STRACE (IENT, 'W3SDS4') #endif -! -! -!---------------------------------------------------------------------- -! -! 0. Pre-Initialization to zero out arrays. All arrays should be reset -! within the computation, but these are helping with some bugs -! found in certain compilers - NSMOOTH=0 - S1=0.; E1=0. - NTIMES=0;IKSUP=0;IMSSMAX=0 - DK=0.; HS=0.; KBAR=0.; DCK=0.; EFDF=0. - BTH0=0.; BTH=0.; BTH0S=0.; DDIAG=0.; SRHS=0.; PB=0. - BTHS=0.; MSSSUM(:,:)=0. + ! + ! + !---------------------------------------------------------------------- + ! + ! 0. Pre-Initialization to zero out arrays. All arrays should be reset + ! within the computation, but these are helping with some bugs + ! found in certain compilers + NSMOOTH=0 + S1=0.; E1=0. + NTIMES=0;IKSUP=0;IMSSMAX=0 + DK=0.; HS=0.; KBAR=0.; DCK=0.; EFDF=0. + BTH0=0.; BTH=0.; BTH0S=0.; DDIAG=0.; SRHS=0.; PB=0. + BTHS=0.; MSSSUM(:,:)=0. #ifdef W3_T0 - DOUT=0. + DOUT=0. #endif - QB=0.; S2=0.;PB=0.; PB2=0. - BRM12(:)=0. -! -! 1. Initialization and numerical factors -! - FACTURB=SSDSC(5)*USTAR**2/GRAV*DAIR/DWAT - BREAKFRACTION=0. - RENEWALFREQ=0. - IK1=1 + QB=0.; S2=0.;PB=0.; PB2=0. + BRM12(:)=0. + ! + ! 1. Initialization and numerical factors + ! + FACTURB=SSDSC(5)*USTAR**2/GRAV*DAIR/DWAT + BREAKFRACTION=0. + RENEWALFREQ=0. + IK1=1 #ifdef W3_IG1 - IK1=NINT(IGPARS(5))+1 + IK1=NINT(IGPARS(5))+1 #endif - NTHSUM=MIN(FLOOR(SSDSC(10)+0.5),NTH-1) ! number of angular bins for enhanced modulation - IF (NTHSUM.GT.0) THEN - WTHSUM(1:NTHSUM)=1 - WTHSUM(NTHSUM+1)=SSDSC(10)+0.5-NTHSUM - ELSE - WTHSUM(1)=2*SSDSC(10) - END IF -! -! 1.b MSS parameters used for Modulation factors for B or lambda -! - IF (SSDSC(8).GT.0.OR.SSDSC(11).GT.0.OR.SSDSC(18).GT.0) THEN - MSSSUM2(:,:)=0. - DO IK=1,NK - IMSSMAX (IK) = 1 - MSSP = 0. - MSSPC2 = 0. - MSSPS2 = 0. - MSSPCS = 0. -! -! Sums the contributions to the directional MSS for all ITH -! - DO ITH=1,NTH - IS=ITH+(IK-1)*NTH - MSSLONG(IK,ITH) = K(IK)**SSDSC(20) * A(IS) * DDEN(IK) / CG(IK) ! contribution to MSS - END DO - DO ITH=1,NTH - DO JTH=-NTHSUM,NTHSUM - ITH2 = 1+MOD(ITH-1+JTH+NTH,NTH) - MSSSUM2(IK,ITH) = MSSSUM2(IK,ITH)+MSSLONG(IK,ITH2)*WTHSUM(ABS(JTH)+1) - END DO - MSSPC2 = MSSPC2 +MSSLONG(IK,ITH)*EC2(ITH) - MSSPS2 = MSSPS2 +MSSLONG(IK,ITH)*ES2(ITH) - MSSPCS = MSSPCS +MSSLONG(IK,ITH)*ESC(ITH) - MSSP = MSSP +MSSLONG(IK,ITH) - END DO -! -! Now sums over IK -! - MSSSUM (IK:NK,1) = MSSSUM (IK:NK,1) +MSSP - MSSSUM (IK:NK,3) = MSSSUM (IK:NK,3) +MSSPC2 - MSSSUM (IK:NK,4) = MSSSUM (IK:NK,4) +MSSPS2 - MSSSUM (IK:NK,5) = MSSSUM (IK:NK,5) +MSSPCS -! -! Direction of long wave mss summed up to IK -! - MSSD=0.5*(ATAN2(2*MSSSUM(IK,5),MSSSUM(IK,3)-MSSSUM(IK,4))) - IF (MSSD.LT.0) MSSD = MSSD + PI - IMSSMAX (IK)=1+NINT(MSSD *NTH/TPI) -! -! mss along perpendicular direction -! - MSSSUM (IK,2) = MAX(0.,MSSSUM(IK,4)*COS(MSSD)**2 & - -2*MSSSUM(IK,5)*SIN(MSSD)*COS(MSSD)+ & - MSSSUM(IK,3)*SIN(MSSD)**2 ) + NTHSUM=MIN(FLOOR(SSDSC(10)+0.5),NTH-1) ! number of angular bins for enhanced modulation + IF (NTHSUM.GT.0) THEN + WTHSUM(1:NTHSUM)=1 + WTHSUM(NTHSUM+1)=SSDSC(10)+0.5-NTHSUM + ELSE + WTHSUM(1)=2*SSDSC(10) + END IF + ! + ! 1.b MSS parameters used for Modulation factors for B or lambda + ! + IF (SSDSC(8).GT.0.OR.SSDSC(11).GT.0.OR.SSDSC(18).GT.0) THEN + MSSSUM2(:,:)=0. + DO IK=1,NK + IMSSMAX (IK) = 1 + MSSP = 0. + MSSPC2 = 0. + MSSPS2 = 0. + MSSPCS = 0. + ! + ! Sums the contributions to the directional MSS for all ITH + ! + DO ITH=1,NTH + IS=ITH+(IK-1)*NTH + MSSLONG(IK,ITH) = K(IK)**SSDSC(20) * A(IS) * DDEN(IK) / CG(IK) ! contribution to MSS + END DO + DO ITH=1,NTH + DO JTH=-NTHSUM,NTHSUM + ITH2 = 1+MOD(ITH-1+JTH+NTH,NTH) + MSSSUM2(IK,ITH) = MSSSUM2(IK,ITH)+MSSLONG(IK,ITH2)*WTHSUM(ABS(JTH)+1) END DO - END IF ! SSDSC(8).GT.0) THEN -! -! 2. Estimation of spontaneous breaking from local saturation -! - SELECT CASE (NINT(SSDSC(1))) - CASE (1) -! -! 2.a Case of a direction-dependent breaking term following Ardhuin et al. 2010 -! - EPSR = SQRT(SSDSBR) -! -! 2.a.1 Computes saturation -! - SDSNTH = MIN(NINT(SSDSDTH/(DTH*RADE)),NTH/2-1) -! SSDSDIK is the integer difference in frequency bands -! between the "large breakers" and short "wiped-out waves" -! - BTH(:) = 0. + MSSPC2 = MSSPC2 +MSSLONG(IK,ITH)*EC2(ITH) + MSSPS2 = MSSPS2 +MSSLONG(IK,ITH)*ES2(ITH) + MSSPCS = MSSPCS +MSSLONG(IK,ITH)*ESC(ITH) + MSSP = MSSP +MSSLONG(IK,ITH) + END DO + ! + ! Now sums over IK + ! + MSSSUM (IK:NK,1) = MSSSUM (IK:NK,1) +MSSP + MSSSUM (IK:NK,3) = MSSSUM (IK:NK,3) +MSSPC2 + MSSSUM (IK:NK,4) = MSSSUM (IK:NK,4) +MSSPS2 + MSSSUM (IK:NK,5) = MSSSUM (IK:NK,5) +MSSPCS + ! + ! Direction of long wave mss summed up to IK + ! + MSSD=0.5*(ATAN2(2*MSSSUM(IK,5),MSSSUM(IK,3)-MSSSUM(IK,4))) + IF (MSSD.LT.0) MSSD = MSSD + PI + IMSSMAX (IK)=1+NINT(MSSD *NTH/TPI) + ! + ! mss along perpendicular direction + ! + MSSSUM (IK,2) = MAX(0.,MSSSUM(IK,4)*COS(MSSD)**2 & + -2*MSSSUM(IK,5)*SIN(MSSD)*COS(MSSD)+ & + MSSSUM(IK,3)*SIN(MSSD)**2 ) + END DO + END IF ! SSDSC(8).GT.0) THEN + ! + ! 2. Estimation of spontaneous breaking from local saturation + ! + SELECT CASE (NINT(SSDSC(1))) + CASE (1) + ! + ! 2.a Case of a direction-dependent breaking term following Ardhuin et al. 2010 + ! + EPSR = SQRT(SSDSBR) + ! + ! 2.a.1 Computes saturation + ! + SDSNTH = MIN(NINT(SSDSDTH/(DTH*RADE)),NTH/2-1) + ! SSDSDIK is the integer difference in frequency bands + ! between the "large breakers" and short "wiped-out waves" + ! + BTH(:) = 0. - DO IK=IK1, NK + DO IK=IK1, NK - FACSAT=SIG(IK)*K(IK)**3*DTH - IS0=(IK-1)*NTH - BTH(IS0+1)=0. - ASUM = SUM(A(IS0+1:IS0+NTH)) - BTH0(IK)=ASUM*FACSAT - IKC = MAX(1,IK-DIKCUMUL) - KLOC=K(IK)**(2-SSDSC(20)) ! local wavenumber factor, if mss not used. - - IF (SSDSDTH.GE.180) THEN ! integrates around full circle - BTH(IS0+1:IS0+NTH)=BTH0(IK) - ELSE - DO ITH=1,NTH ! partial integration - IS=ITH+(IK-1)*NTH + FACSAT=SIG(IK)*K(IK)**3*DTH + IS0=(IK-1)*NTH + BTH(IS0+1)=0. + ASUM = SUM(A(IS0+1:IS0+NTH)) + BTH0(IK)=ASUM*FACSAT + IKC = MAX(1,IK-DIKCUMUL) + KLOC=K(IK)**(2-SSDSC(20)) ! local wavenumber factor, if mss not used. -! straining effect of long waves on short waves -! extended from Longuet-Higgins and Stewart (JFM 1960, eq. 2.27) the amplitude modulation -! in deep water is equal to the long wave slope k*a cos(theta1-theta2) -! Here we assume that the saturation is modulated as (1 + SSDSC(8) * sqrt(mss) ) -! where mss_theta is the mss in direction ITH. -! -! Note: SSDSC(8) is sqrt(2)*times the mss MTF: equal to 4*sqrt(2) according to Longuet-Higgins and Stewart -! - IF (SSDSC(8).GT.0.OR.SSDSC(11).GT.0) THEN -! - MSSTH=(MSSSUM(IKC,1)-MSSSUM(IKC,2))*EC2(1+ABS(ITH-IMSSMAX (IKC))) & - +MSSSUM(IKC,2)*ES2(1+ABS(ITH-IMSSMAX (IKC)))*KLOC -! - FACSTRAINB=1+SSDSC(8)*SQRT(MSSTH)+SSDSC(11)*SQRT(MSSSUM2(IKC,ITH)*KLOC) - ELSE - FACSTRAINB=1 - END IF -! - BTH(IS)=DOT_PRODUCT(SATWEIGHTS(:,ITH), A(IS0+SATINDICES(:,ITH)) ) & - *FACSAT*FACSTRAINB - END DO + IF (SSDSDTH.GE.180) THEN ! integrates around full circle + BTH(IS0+1:IS0+NTH)=BTH0(IK) + ELSE + DO ITH=1,NTH ! partial integration + IS=ITH+(IK-1)*NTH - IF (SSDSISO.NE.1) THEN - BTH0(IK)=MAXVAL(BTH(IS0+1:IS0+NTH)) - END IF - END IF -! - END DO !NK END -! -! Optional smoothing of B and B0 over frequencies -! - IF (SSDSBRFDF.GT.0.AND.SSDSBRFDF.LT.NK/2) THEN - BTH0S(:)=BTH0(:) - BTHS(:)=BTH(:) - NSMOOTH(:)=1 - DO IK=1, SSDSBRFDF - BTH0S(1+SSDSBRFDF)=BTH0S(1+SSDSBRFDF)+BTH0(IK) - NSMOOTH(1+SSDSBRFDF)=NSMOOTH(1+SSDSBRFDF)+1 - DO ITH=1,NTH - IS=ITH+(IK-1)*NTH - BTHS(ITH+SSDSBRFDF*NTH)=BTHS(ITH+SSDSBRFDF*NTH)+BTH(IS) - END DO - END DO - DO IK=IK1+1+SSDSBRFDF,1+2*SSDSBRFDF - BTH0S(1+SSDSBRFDF)=BTH0S(1+SSDSBRFDF)+BTH0(IK) - NSMOOTH(1+SSDSBRFDF)=NSMOOTH(1+SSDSBRFDF)+1 - DO ITH=1,NTH - IS=ITH+(IK-1)*NTH - BTHS(ITH+SSDSBRFDF*NTH)=BTHS(ITH+SSDSBRFDF*NTH)+BTH(IS) - END DO - END DO - DO IK=SSDSBRFDF,IK1,-1 - BTH0S(IK)=BTH0S(IK+1)-BTH0(IK+SSDSBRFDF+1) - NSMOOTH(IK)=NSMOOTH(IK+1)-1 - DO ITH=1,NTH - IS=ITH+(IK-1)*NTH - BTHS(IS)=BTHS(IS+NTH)-BTH(IS+(SSDSBRFDF+1)*NTH) - END DO - END DO -! - DO IK=IK1+1+SSDSBRFDF,NK-SSDSBRFDF - BTH0S(IK)=BTH0S(IK-1)-BTH0(IK-SSDSBRFDF-1)+BTH0(IK+SSDSBRFDF) - NSMOOTH(IK)=NSMOOTH(IK-1) - DO ITH=1,NTH - IS=ITH+(IK-1)*NTH - BTHS(IS)=BTHS(IS-NTH)-BTH(IS-(SSDSBRFDF+1)*NTH)+BTH(IS+(SSDSBRFDF)*NTH) - END DO - END DO -! - DO IK=NK-SSDSBRFDF+1,NK - BTH0S(IK)=BTH0S(IK-1)-BTH0(IK-SSDSBRFDF) - NSMOOTH(IK)=NSMOOTH(IK-1)-1 - DO ITH=1,NTH - IS=ITH+(IK-1)*NTH - BTHS(IS)=BTHS(IS-NTH)-BTH(IS-(SSDSBRFDF+1)*NTH) - END DO - END DO -! division by NSMOOTH - BTH0(:)=MAX(0.,BTH0S(:)/NSMOOTH(:)) - DO IK=IK1,NK - IS0=(IK-1)*NTH - BTH(IS0+1:IS0+NTH)=MAX(0.,BTHS(IS0+1:IS0+NTH)/NSMOOTH(IK)) - END DO - END IF ! end of optional smoothing -! -! 2.a.2 Computes spontaneous breaking dissipation rate -! - DO IK=IK1, NK -! -! Correction of saturation level for shallow-water kinematics -! - IF (SSDSBM(0).EQ.1) THEN - MICHE=1. - ELSE - X=TANH(MIN(K(IK)*DEPTH,10.)) - MICHE=(X*(SSDSBM(1)+X*(SSDSBM(2)+X*(SSDSBM(3)+X*SSDSBM(4)))))**2 ! Correction of saturation level for shallow-water kinematics + ! straining effect of long waves on short waves + ! extended from Longuet-Higgins and Stewart (JFM 1960, eq. 2.27) the amplitude modulation + ! in deep water is equal to the long wave slope k*a cos(theta1-theta2) + ! Here we assume that the saturation is modulated as (1 + SSDSC(8) * sqrt(mss) ) + ! where mss_theta is the mss in direction ITH. + ! + ! Note: SSDSC(8) is sqrt(2)*times the mss MTF: equal to 4*sqrt(2) according to Longuet-Higgins and Stewart + ! + IF (SSDSC(8).GT.0.OR.SSDSC(11).GT.0) THEN + ! + MSSTH=(MSSSUM(IKC,1)-MSSSUM(IKC,2))*EC2(1+ABS(ITH-IMSSMAX (IKC))) & + +MSSSUM(IKC,2)*ES2(1+ABS(ITH-IMSSMAX (IKC)))*KLOC + ! + FACSTRAINB=1+SSDSC(8)*SQRT(MSSTH)+SSDSC(11)*SQRT(MSSSUM2(IKC,ITH)*KLOC) + ELSE + FACSTRAINB=1 END IF - COEF1=(SSDSBR*MICHE) -! -! Computes isotropic part -! - SDIAGISO = SSDSC(2) * SIG(IK)*SSDSC(6)*(MAX(0.,BTH0(IK)/COEF1-1.))**2 -! -! Computes anisotropic part and sums isotropic part -! - COEF2=SSDSC(2) * SIG(IK)*(1-SSDSC(6))/(COEF1*COEF1) - DDIAG((IK-1)*NTH+1:IK*NTH) = SDIAGISO + & - COEF2*((MAX(0.,BTH((IK-1)*NTH+1:IK*NTH)-COEF1))**SSDSP) + ! + BTH(IS)=DOT_PRODUCT(SATWEIGHTS(:,ITH), A(IS0+SATINDICES(:,ITH)) ) & + *FACSAT*FACSTRAINB + END DO + + IF (SSDSISO.NE.1) THEN + BTH0(IK)=MAXVAL(BTH(IS0+1:IS0+NTH)) + END IF + END IF + ! + END DO !NK END + ! + ! Optional smoothing of B and B0 over frequencies + ! + IF (SSDSBRFDF.GT.0.AND.SSDSBRFDF.LT.NK/2) THEN + BTH0S(:)=BTH0(:) + BTHS(:)=BTH(:) + NSMOOTH(:)=1 + DO IK=1, SSDSBRFDF + BTH0S(1+SSDSBRFDF)=BTH0S(1+SSDSBRFDF)+BTH0(IK) + NSMOOTH(1+SSDSBRFDF)=NSMOOTH(1+SSDSBRFDF)+1 + DO ITH=1,NTH + IS=ITH+(IK-1)*NTH + BTHS(ITH+SSDSBRFDF*NTH)=BTHS(ITH+SSDSBRFDF*NTH)+BTH(IS) + END DO + END DO + DO IK=IK1+1+SSDSBRFDF,1+2*SSDSBRFDF + BTH0S(1+SSDSBRFDF)=BTH0S(1+SSDSBRFDF)+BTH0(IK) + NSMOOTH(1+SSDSBRFDF)=NSMOOTH(1+SSDSBRFDF)+1 + DO ITH=1,NTH + IS=ITH+(IK-1)*NTH + BTHS(ITH+SSDSBRFDF*NTH)=BTHS(ITH+SSDSBRFDF*NTH)+BTH(IS) + END DO + END DO + DO IK=SSDSBRFDF,IK1,-1 + BTH0S(IK)=BTH0S(IK+1)-BTH0(IK+SSDSBRFDF+1) + NSMOOTH(IK)=NSMOOTH(IK+1)-1 + DO ITH=1,NTH + IS=ITH+(IK-1)*NTH + BTHS(IS)=BTHS(IS+NTH)-BTH(IS+(SSDSBRFDF+1)*NTH) END DO -! -! Computes Breaking probability -! - PB = (MAX(SQRT(BTH)-EPSR,0.))**2 -! -! Multiplies by 28.16 = 22.0 * 1.6² * 1/2 with -! 22.0 (Banner & al. 2000, figure 6) -! 1.6 the coefficient that transforms SQRT(B) to Banner et al. (2000)'s epsilon -! 1/2 factor to correct overestimation of Banner et al. (2000)'s breaking probability due to zero-crossing analysis -! + END DO + ! + DO IK=IK1+1+SSDSBRFDF,NK-SSDSBRFDF + BTH0S(IK)=BTH0S(IK-1)-BTH0(IK-SSDSBRFDF-1)+BTH0(IK+SSDSBRFDF) + NSMOOTH(IK)=NSMOOTH(IK-1) + DO ITH=1,NTH + IS=ITH+(IK-1)*NTH + BTHS(IS)=BTHS(IS-NTH)-BTH(IS-(SSDSBRFDF+1)*NTH)+BTH(IS+(SSDSBRFDF)*NTH) + END DO + END DO + ! + DO IK=NK-SSDSBRFDF+1,NK + BTH0S(IK)=BTH0S(IK-1)-BTH0(IK-SSDSBRFDF) + NSMOOTH(IK)=NSMOOTH(IK-1)-1 + DO ITH=1,NTH + IS=ITH+(IK-1)*NTH + BTHS(IS)=BTHS(IS-NTH)-BTH(IS-(SSDSBRFDF+1)*NTH) + END DO + END DO + ! division by NSMOOTH + BTH0(:)=MAX(0.,BTH0S(:)/NSMOOTH(:)) + DO IK=IK1,NK + IS0=(IK-1)*NTH + BTH(IS0+1:IS0+NTH)=MAX(0.,BTHS(IS0+1:IS0+NTH)/NSMOOTH(IK)) + END DO + END IF ! end of optional smoothing + ! + ! 2.a.2 Computes spontaneous breaking dissipation rate + ! + DO IK=IK1, NK + ! + ! Correction of saturation level for shallow-water kinematics + ! + IF (SSDSBM(0).EQ.1) THEN + MICHE=1. + ELSE + X=TANH(MIN(K(IK)*DEPTH,10.)) + MICHE=(X*(SSDSBM(1)+X*(SSDSBM(2)+X*(SSDSBM(3)+X*SSDSBM(4)))))**2 ! Correction of saturation level for shallow-water kinematics + END IF + COEF1=(SSDSBR*MICHE) + ! + ! Computes isotropic part + ! + SDIAGISO = SSDSC(2) * SIG(IK)*SSDSC(6)*(MAX(0.,BTH0(IK)/COEF1-1.))**2 + ! + ! Computes anisotropic part and sums isotropic part + ! + COEF2=SSDSC(2) * SIG(IK)*(1-SSDSC(6))/(COEF1*COEF1) + DDIAG((IK-1)*NTH+1:IK*NTH) = SDIAGISO + & + COEF2*((MAX(0.,BTH((IK-1)*NTH+1:IK*NTH)-COEF1))**SSDSP) + END DO + ! + ! Computes Breaking probability + ! + PB = (MAX(SQRT(BTH)-EPSR,0.))**2 + ! + ! Multiplies by 28.16 = 22.0 * 1.6² * 1/2 with + ! 22.0 (Banner & al. 2000, figure 6) + ! 1.6 the coefficient that transforms SQRT(B) to Banner et al. (2000)'s epsilon + ! 1/2 factor to correct overestimation of Banner et al. (2000)'s breaking probability due to zero-crossing analysis + ! PB = PB * 28.16 -! Compute Lambda = PB* l(k,th) -! with l(k,th)=1/(2*pi²)= the breaking crest density + ! Compute Lambda = PB* l(k,th) + ! with l(k,th)=1/(2*pi²)= the breaking crest density BRLAMBDA = PB / (2.*PI**2.) SRHS = DDIAG * A -! - CASE(2) -! -! 2.b Computes spontaneous breaking for T500 (Filipot et al. JGR 2010) -! + ! + CASE(2) + ! + ! 2.b Computes spontaneous breaking for T500 (Filipot et al. JGR 2010) + ! E1 = 0. - HS = 0. + HS = 0. SRHS = 0. DDIAG = 0. PB2 = 0. -! -! Computes Wavenumber spectrum E1 integrated over direction and computes dk -! + ! + ! Computes Wavenumber spectrum E1 integrated over direction and computes dk + ! DO IK=IK1, NK E1(IK)=0. DO ITH=1,NTH IS=ITH+(IK-1)*NTH E1(IK)=E1(IK)+(A(IS)*SIG(IK))*DTH - END DO - DK(IK)=DDEN(IK)/(DTH*SIG(IK)*CG(IK)) END DO -! -! Gets windows indices of IKTAB -! - ID=MIN(NINT(DEPTH),NDTAB) + DK(IK)=DDEN(IK)/(DTH*SIG(IK)*CG(IK)) + END DO + ! + ! Gets windows indices of IKTAB + ! + ID=MIN(NINT(DEPTH),NDTAB) IF (ID < 1) THEN ID = 1 ELSE IF(ID > NDTAB) THEN - ID = NDTAB - END IF -! -! loop over wave scales -! - HS=0. + ID = NDTAB + END IF + ! + ! loop over wave scales + ! + HS=0. EFDF=0. KBAR=0. NKL=0. !number of windows - DO IKL=1,NK + DO IKL=1,NK IKSUP(IKL)=IKTAB(IKL,ID) IF (IKSUP(IKL) .LE. NK) THEN EFDF(IKL) = DOT_PRODUCT(E1(IKL:IKSUP(IKL)-1),DK(IKL:IKSUP(IKL)-1)) IF (EFDF(IKL) .NE. 0) THEN KBAR(IKL) = DOT_PRODUCT(K(IKL:IKSUP(IKL)-1)*E1(IKL:IKSUP(IKL)-1), & - DK(IKL:IKSUP(IKL)-1)) / EFDF(IKL) - ELSE - KBAR(IKL)=0. - END IF -! estimation of Significant wave height of a given scale - HS(IKL) = 4*SQRT(EFDF(IKL)) - NKL = NKL+1 + DK(IKL:IKSUP(IKL)-1)) / EFDF(IKL) + ELSE + KBAR(IKL)=0. END IF - END DO -! -! Computes Dissipation and breaking probability in each scale -! + ! estimation of Significant wave height of a given scale + HS(IKL) = 4*SQRT(EFDF(IKL)) + NKL = NKL+1 + END IF + END DO + ! + ! Computes Dissipation and breaking probability in each scale + ! DCK=0. QB =0. - DKHS = KHSMAX/NKHS + DKHS = KHSMAX/NKHS DO IKL=1, NKL - IF (HS(IKL) .NE. 0. .AND. KBAR(IKL) .NE. 0.) THEN -! gets indices for tabulated dissipation DCKI and breaking probability QBI -! + IF (HS(IKL) .NE. 0. .AND. KBAR(IKL) .NE. 0.) THEN + ! gets indices for tabulated dissipation DCKI and breaking probability QBI + ! IKD = FAC_KD2+ANINT(LOG(KBAR(IKL)*DEPTH)/LOG(FAC_KD1)) IKHS= 1+ANINT(KBAR(IKL)*HS(IKL)/DKHS) IF (IKD > NKD) THEN ! Deep water IKD = NKD ELSE IF (IKD < 1) THEN ! Shallow water IKD = 1 - END IF + END IF IF (IKHS > NKHS) THEN IKHS = NKHS ELSE IF (IKHS < 1) THEN IKHS = 1 - END IF + END IF XT = TANH(KBAR(IKL)*DEPTH) -! -! Gamma corrected for water depth -! - GAM=1.0314*(XT**3)-1.9958*(XT**2)+1.5522*XT+0.1885 -! -! Computes the energy dissipated for the scale IKL -! using DCKI which is tabulated in INSIN4 -! + ! + ! Gamma corrected for water depth + ! + GAM=1.0314*(XT**3)-1.9958*(XT**2)+1.5522*XT+0.1885 + ! + ! Computes the energy dissipated for the scale IKL + ! using DCKI which is tabulated in INSIN4 + ! DCK(IKL)=((KBAR(IKL)**(-2.5))*(KBAR(IKL)/(2*PI)))*DCKI(IKHS,IKD) -! -! Get the breaking probability for the scale IKL -! + ! + ! Get the breaking probability for the scale IKL + ! QB(IKL) = QBI(IKHS,IKD) ! QBI is tabulated in INSIN4 - ELSE + ELSE DCK(IKL)=0. QB(IKL) =0. - END IF - END DO -! -! Distributes scale dissipation over the frequency spectrum -! + END IF + END DO + ! + ! Distributes scale dissipation over the frequency spectrum + ! S1 = 0. S2 = 0. NTIMES = 0 DO IKL=1, NKL - IF (EFDF(IKL) .GT. 0.) THEN + IF (EFDF(IKL) .GT. 0.) THEN S1(IKL:IKSUP(IKL)) = S1(IKL:IKSUP(IKL)) + & - DCK(IKL)*E1(IKL:IKSUP(IKL)) / EFDF(IKL) + DCK(IKL)*E1(IKL:IKSUP(IKL)) / EFDF(IKL) S2(IKL:IKSUP(IKL)) = S2(IKL:IKSUP(IKL)) + & - QB(IKL) *E1(IKL:IKSUP(IKL)) / EFDF(IKL) + QB(IKL) *E1(IKL:IKSUP(IKL)) / EFDF(IKL) NTIMES(IKL:IKSUP(IKL)) = NTIMES(IKL:IKSUP(IKL)) + 1 - END IF - END DO -! -! Finish the average -! + END IF + END DO + ! + ! Finish the average + ! WHERE (NTIMES .GT. 0) S1 = S1 / NTIMES S2 = S2 / NTIMES ELSEWHERE S1 = 0. S2 = 0. - END WHERE -! goes back to action for dissipation source term + END WHERE + ! goes back to action for dissipation source term S1(1:NK) = S1(1:NK) / SIG(1:NK) -! -! Makes Isotropic distribution -! + ! + ! Makes Isotropic distribution + ! ASUM = 0. - DO IK = 1, NK + DO IK = 1, NK ASUM = (SUM(A(((IK-1)*NTH+1):(IK*NTH)))*DTH) IF (ASUM.GT.1.E-8) THEN FORALL (IS=1+(IK-1)*NTH:IK*NTH) DDIAG(IS) = S1(IK)/ASUM @@ -2189,200 +2186,200 @@ SUBROUTINE W3SDS4 (A, K, CG, USTAR, USDIR, DEPTH, DAIR, SRHS, & ELSE FORALL (IS=1+(IK-1)*NTH:IK*NTH) DDIAG(IS) = 0. FORALL (IS=1+(IK-1)*NTH:IK*NTH) PB2(IS) = 0. - END IF - IF (PB2(1+(IK-1)*NTH).GT.0.001) THEN + END IF + IF (PB2(1+(IK-1)*NTH).GT.0.001) THEN BTH0(IK) = 2.*SSDSBR ELSE - BTH0(IK) = 0. - END IF - END DO -! + BTH0(IK) = 0. + END IF + END DO + ! PB = (1-SSDSC(1))*PB2*A + SSDSC(1)*PB -! Compute Lambda = PB* l(k,th) -! with l(k,th)=1/(2*pi²)= the breaking crest density + ! Compute Lambda = PB* l(k,th) + ! with l(k,th)=1/(2*pi²)= the breaking crest density BRLAMBDA = PB / (2.*PI**2.) -! - CASE(3) -! -! 2c Romero (GRL 2019) -! -! directional saturation I -! integrate in azimuth + ! + CASE(3) + ! + ! 2c Romero (GRL 2019) + ! + ! directional saturation I + ! integrate in azimuth KO=(GRAV/(1E-6+USTAR**2))/(28./SSDSC(16))**2 DO IK=1,NK IS0=(IK-1)*NTH KLOC=K(IK)**(2-SSDSC(20)) ! local wavenumber factor, if mss not used. BTH(1:NTH)=MAX(A(IS0+1:IS0+NTH)*SIG(IK)*K(IK)**3,.00000000000001) -! + ! IF (SSDSC(8).GT.0) THEN ! Applies modulation factor on B DO ITH=1,NTH MSSTH=(MSSSUM(IK,1)-MSSSUM(IK,2))*EC2(1+ABS(ITH-IMSSMAX (IK))) & +MSSSUM(IK,2)*ES2(1+ABS(ITH-IMSSMAX (IK)))*KLOC FACSTRAINB=(1.+SSDSC(8)*SQRT(MSSTH)+SSDSC(11)*SQRT(MSSSUM2(IK,ITH))*KLOC) BTH(ITH)=BTH(ITH)*FACSTRAINB - END DO - END IF -! + END DO + END IF + ! C=SIG(IK)/K(IK) - BTH0(IK)=sum(BTH(1:NTH)*DTH) + BTH0(IK)=sum(BTH(1:NTH)*DTH) IF (SSDSC(18).GT.0) THEN ! Applies modulation factor on Lambda DO ITH=1,NTH - IF (SSDSC(11).GT.0) THEN + IF (SSDSC(11).GT.0) THEN MSSTH=(MSSSUM(IK,1)-MSSSUM(IK,2))*EC2(1+ABS(ITH-IMSSMAX (IK))) & - +MSSSUM(IK,2)*ES2(1+ABS(ITH-IMSSMAX (IK)))*KLOC + +MSSSUM(IK,2)*ES2(1+ABS(ITH-IMSSMAX (IK)))*KLOC FACSTRAINL=1.+SSDSC(18)*SQRT(MSSTH)+SSDSC(11)*SQRT(MSSSUM2(IK,ITH)*KLOC) - ELSE + ELSE FACSTRAINL=1.+SSDSC(18)*((MSSSUM(IK,1)*KLOC)**SSDSC(14) * & ! Romero - (ECOS(ITH)*COS(DLWMEAN)+ESIN(ITH)*SIN(DLWMEAN))**2) - ENDIF - LMODULATION(ITH)= FACSTRAINL**SSDSC(19) - END DO - ELSE + (ECOS(ITH)*COS(DLWMEAN)+ESIN(ITH)*SIN(DLWMEAN))**2) + ENDIF + LMODULATION(ITH)= FACSTRAINL**SSDSC(19) + END DO + ELSE LMODULATION(:)= 1. - END IF + END IF -! Lambda + ! Lambda BRLAMBDA(IS0+1:IS0+NTH)=SSDSC(9)*EXP(-SSDSBR/BTH(1:NTH)) & - *( 1.0+SSDSC(13)*MAX(1.,(K(IK)/KO))**SSDSC(15) ) & - /(SSDSC(13)+1)*LMODULATION(1:NTH) -! Breaking strength : generalisation of Duncan's b parameter + *( 1.0+SSDSC(13)*MAX(1.,(K(IK)/KO))**SSDSC(15) ) & + /(SSDSC(13)+1)*LMODULATION(1:NTH) + ! Breaking strength : generalisation of Duncan's b parameter BTOVER = SQRT(BTH0(IK))-SQRT(SSDSBT) BRM12(IK)=SSDSC(2)*(MAX(0.,BTOVER))**(2.5)/SIG(IK) ! not function of direction -! For consistency set BRLAMBDA set to zero if b is zero - BRLAMBDA(IS0+1:IS0+NTH)= MAX(0.,SIGN(BRLAMBDA(IS0+1:IS0+NTH),BTOVER)) -! Source term / sig2 (action dissipation) + ! For consistency set BRLAMBDA set to zero if b is zero + BRLAMBDA(IS0+1:IS0+NTH)= MAX(0.,SIGN(BRLAMBDA(IS0+1:IS0+NTH),BTOVER)) + ! Source term / sig2 (action dissipation) SRHS(IS0+1:IS0+NTH)= BRM12(IK)/GRAV**2*BRLAMBDA(IS0+1:IS0+NTH)*C**5 -! diagonal - DDIAG(IS0+1:IS0+NTH) = SRHS(IS0+1:IS0+NTH)*SSDSBR/MAX(1.e-20,BTH(1:NTH))/MAX(1e-20,A(IS0+1:IS0+NTH)) ! - END DO -! Breaking probability (Is actually the breaking rate) + ! diagonal + DDIAG(IS0+1:IS0+NTH) = SRHS(IS0+1:IS0+NTH)*SSDSBR/MAX(1.e-20,BTH(1:NTH))/MAX(1e-20,A(IS0+1:IS0+NTH)) ! + END DO + ! Breaking probability (Is actually the breaking rate) PB = BRLAMBDA *C -! - END SELECT -! -! -! -!/ ------------------------------------------------------------------- / -! WAVE-TURBULENCE INTERACTION AND CUMULATIVE EFFECT -!/ ------------------------------------------------------------------- / -! -! -! loop over spectrum -! - IF ( (SSDSC(3).NE.0.) .OR. (SSDSC(5).NE.0.) .OR. (SSDSC(21).NE.0.) ) THEN + ! + END SELECT + ! + ! + ! + !/ ------------------------------------------------------------------- / + ! WAVE-TURBULENCE INTERACTION AND CUMULATIVE EFFECT + !/ ------------------------------------------------------------------- / + ! + ! + ! loop over spectrum + ! + IF ( (SSDSC(3).NE.0.) .OR. (SSDSC(5).NE.0.) .OR. (SSDSC(21).NE.0.) ) THEN DO IK=IK1, NK FACTURB2=-2.*SIG(IK)*K(IK)*FACTURB DVISC=-4.*SSDSC(21)*K(IK)*K(IK) -! - DO ITH=1,NTH + ! + DO ITH=1,NTH IS=ITH+(IK-1)*NTH -! -! Computes cumulative effect from Breaking probability -! + ! + ! Computes cumulative effect from Breaking probability + ! RENEWALFREQ = 0. IF (SSDSC(3).NE.0 .AND. IK.GT.DIKCUMUL) THEN DO IK2=IK1,IK-DIKCUMUL IF (BTH0(IK2).GT.SSDSBR) THEN IS2=(IK2-1)*NTH RENEWALFREQ=RENEWALFREQ+DOT_PRODUCT(CUMULW(IS2+1:IS2+NTH,IS),BRLAMBDA(IS2+1:IS2+NTH)) - END IF - END DO - END IF -! -! Computes wave turbulence interaction -! + END IF + END DO + END IF + ! + ! Computes wave turbulence interaction + ! COSWIND=(ECOS(ITH)*COS(USDIR)+ESIN(ITH)*SIN(USDIR)) DTURB=FACTURB2*MAX(0.,COSWIND) ! Theory -> stress direction -! -! Add effects -! - DIAG2 = (SSDSC(3)*RENEWALFREQ+DTURB+DVISC) + ! + ! Add effects + ! + DIAG2 = (SSDSC(3)*RENEWALFREQ+DTURB+DVISC) DDIAG(IS) = DDIAG(IS) + DIAG2 SRHS(IS) = SRHS(IS) + A(IS)* DIAG2 - END DO - END DO - END IF -! -! COMPUTES WHITECAP PARAMETERS -! - IF ( .NOT. (FLOGRD(5,7).OR.FLOGRD(5,8) ) ) THEN - RETURN - END IF -! - WHITECAP(1:2) = 0. -! -! precomputes integration of Lambda over direction -! times wavelength times a (a=5 in Reul&Chapron JGR 2003) times dk -! - DO IK=1,MIN(FLOOR(AAIRCMIN),NK) - C=SIG(IK)/K(IK) - IS0=(IK-1)*NTH - COEF4(IK) = C*C*SUM(BRLAMBDA(IS0+1:IS0+NTH)) & - *2.*PI/GRAV*SSDSC(7) * DDEN(IK)/(SIG(IK)*CG(IK)) - COEF5(IK) = C**3*SUM(BRLAMBDA(IS0+1:IS0+NTH) & - *BRM12(IK)) & - *AAIRGB/GRAV * DDEN(IK)/(SIG(IK)*CG(IK)) -! COEF4(IK) = SUM(BRLAMBDA((IK-1)*NTH+1:IK*NTH) * DTH) *(2*PI/K(IK)) * & -! SSDSC(7) * DDEN(IK)/(DTH*SIG(IK)*CG(IK)) -! NB: SSDSC(7) is WHITECAPWIDTH END DO -! Need to extrapolate above NK if necessary ... to be added later. - DO IK=MIN(FLOOR(AAIRCMIN),NK),NK - COEF4(IK)=0. - COEF5(IK)=0. - END DO - -!/ - IF ( FLOGRD(5,7) ) THEN -! -! Computes the Total WhiteCap Coverage (a=5. ; Reul and Chapron, 2003) -! - DO IK=IK1,MIN(FLOOR(AAIRCMIN),NK) - WHITECAP(1) = WHITECAP(1) + COEF4(IK) * (1-WHITECAP(1)) - WHITECAP(4) = WHITECAP(4) + COEF5(IK) - END DO - END IF -!/ - IF ( FLOGRD(5,8) ) THEN -! -! Calculates the Mean Foam Thickness for component K(IK) => Fig.3, Reul and Chapron, 2003 -! ( Copied from ST4 - not yet tested/validated with Romero 2019 (Lambda model) -! - DO IK=IK1,NK -! Duration of active breaking (TAU*) - TSTR = 0.8 * 2*PI/SIG(IK) -! Time persistence of foam (a=5.) - TMAX = 5. * 2*PI/SIG(IK) - DT = TMAX / 50 - MFT = 0. - DO IT = 1, 50 -! integration over time of foam persistance - T = FLOAT(IT) * DT -! Eq. 5 and 6 of Reul and Chapron, 2003 - IF ( T .LT. TSTR ) THEN - MFT = MFT + 0.4 / (K(IK)*TSTR) * T * DT - ELSE - MFT = MFT + 0.4 / K(IK) * EXP(-1*(T-TSTR)/3.8) * DT - END IF - END DO - MFT = MFT / TMAX -! -! Computes foam-layer thickness (Reul and Chapron, 2003) -! - WHITECAP(2) = WHITECAP(2) + COEF4(IK) * MFT - END DO - END IF -! -! End of output computing -! + END DO + END IF + ! + ! COMPUTES WHITECAP PARAMETERS + ! + IF ( .NOT. (FLOGRD(5,7).OR.FLOGRD(5,8) ) ) THEN RETURN -! -! Formats -! -!/ -!/ End of W3SDS4 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SDS4 + END IF + ! + WHITECAP(1:2) = 0. + ! + ! precomputes integration of Lambda over direction + ! times wavelength times a (a=5 in Reul&Chapron JGR 2003) times dk + ! + DO IK=1,MIN(FLOOR(AAIRCMIN),NK) + C=SIG(IK)/K(IK) + IS0=(IK-1)*NTH + COEF4(IK) = C*C*SUM(BRLAMBDA(IS0+1:IS0+NTH)) & + *2.*PI/GRAV*SSDSC(7) * DDEN(IK)/(SIG(IK)*CG(IK)) + COEF5(IK) = C**3*SUM(BRLAMBDA(IS0+1:IS0+NTH) & + *BRM12(IK)) & + *AAIRGB/GRAV * DDEN(IK)/(SIG(IK)*CG(IK)) + ! COEF4(IK) = SUM(BRLAMBDA((IK-1)*NTH+1:IK*NTH) * DTH) *(2*PI/K(IK)) * & + ! SSDSC(7) * DDEN(IK)/(DTH*SIG(IK)*CG(IK)) + ! NB: SSDSC(7) is WHITECAPWIDTH + END DO + ! Need to extrapolate above NK if necessary ... to be added later. + DO IK=MIN(FLOOR(AAIRCMIN),NK),NK + COEF4(IK)=0. + COEF5(IK)=0. + END DO + + !/ + IF ( FLOGRD(5,7) ) THEN + ! + ! Computes the Total WhiteCap Coverage (a=5. ; Reul and Chapron, 2003) + ! + DO IK=IK1,MIN(FLOOR(AAIRCMIN),NK) + WHITECAP(1) = WHITECAP(1) + COEF4(IK) * (1-WHITECAP(1)) + WHITECAP(4) = WHITECAP(4) + COEF5(IK) + END DO + END IF + !/ + IF ( FLOGRD(5,8) ) THEN + ! + ! Calculates the Mean Foam Thickness for component K(IK) => Fig.3, Reul and Chapron, 2003 + ! ( Copied from ST4 - not yet tested/validated with Romero 2019 (Lambda model) + ! + DO IK=IK1,NK + ! Duration of active breaking (TAU*) + TSTR = 0.8 * 2*PI/SIG(IK) + ! Time persistence of foam (a=5.) + TMAX = 5. * 2*PI/SIG(IK) + DT = TMAX / 50 + MFT = 0. + DO IT = 1, 50 + ! integration over time of foam persistance + T = FLOAT(IT) * DT + ! Eq. 5 and 6 of Reul and Chapron, 2003 + IF ( T .LT. TSTR ) THEN + MFT = MFT + 0.4 / (K(IK)*TSTR) * T * DT + ELSE + MFT = MFT + 0.4 / K(IK) * EXP(-1*(T-TSTR)/3.8) * DT + END IF + END DO + MFT = MFT / TMAX + ! + ! Computes foam-layer thickness (Reul and Chapron, 2003) + ! + WHITECAP(2) = WHITECAP(2) + COEF4(IK) * MFT + END DO + END IF + ! + ! End of output computing + ! + RETURN + ! + ! Formats + ! + !/ + !/ End of W3SDS4 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SDS4 - END MODULE W3SRC4MD +END MODULE W3SRC4MD diff --git a/model/src/w3src6md.F90 b/model/src/w3src6md.F90 index 3c316fe8c..433977991 100644 --- a/model/src/w3src6md.F90 +++ b/model/src/w3src6md.F90 @@ -1,1128 +1,1124 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SRC6MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP/NOPP | -!/ | S. Zieger | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 26-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 29-May-2009 : Origination (w3srcxmd.ftn) ( version 3.14 ) -!/ 10-Feb-2011 : Implementation of source terms ( version 4.04 ) -!/ (S. Zieger) -!/ 26-Jun-2017 : Recalibration of ST6 ( verison 6.06 ) -!/ (Q. Liu ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Observation-based wind input and dissipation after Donelan et al (2006), -! and Babanin et al. (2010). Parameterisation is based on the field -! data from Lake George, Australia. Initial implementation of input -! and dissipation is based on work from Tsagareli et al. (2010) and -! Rogers et al. (2012). Parameterisation extended and account for -! negative input due to opposing winds (see Donelan et al, 2006) and -! the vector version of the stress computation. -! -! References: -! Babanin et al. 2010: JPO 40(4) 667- 683 -! Donelan et al. 2006: JPO 36(8) 1672-1689 -! Tsagareli et al. 2010: JPO 40(4) 656- 666 -! Rogers et al. 2012: JTECH 29(9) 1329-1346 -! -! 2. Variables and types : -! -! Not applicable. -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SPR6 Subr. Public Integral parameter calculation following !/ST1. -! W3SIN6 Subr. Public Observation-based wind input. -! W3SDS6 Subr. Public Observation-based dissipation. -! -! IRANGE Func. Private Generate a sequence of integer values. -! LFACTOR Func. Private Calculate reduction factor for Sin. -! TAUWINDS Func. Private Normal stress calculation for Sin. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T6 Enable test output for wind input and dissipation subroutines. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC :: W3SPR6, W3SIN6, W3SDS6 - PRIVATE :: LFACTOR, TAUWINDS, IRANGE - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP/NOPP | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 11-Feb-2011 | -!/ +-----------------------------------+ -!/ -!/ 08-Oct-2007 : Origination. ( version 3.13 ) -!/ 11-Feb-2011 : Implementation based on W3SPR1 ( version 4.04 ) -!/ (S. Zieger) -!/ -! 1. Purpose : -! Calculate mean wave parameters. -! -! 2. Method : -! See source term routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action as a function of direction and wavenumber -! CG R.A. I Group velocities -! WN R.A. I Wavenumbers -! EMEAN REAL O Mean wave energy -! FMEAN REAL O Mean wave frequency -! WNMEAN REAL O Mean wavenumber -! AMAX REAL O Maximum action density in spectrum -! FP REAL O Peak frequency (rad) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: TPIINV - USE W3GDATMD, ONLY: NK, NTH, SIG, DTH, DDEN, FTE, FTF, FTWN, DSII - USE W3ODATMD, ONLY: NDST, NDSE - USE W3SERVMD, ONLY: EXTCDE +MODULE W3SRC6MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP/NOPP | + !/ | S. Zieger | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 26-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 29-May-2009 : Origination (w3srcxmd.ftn) ( version 3.14 ) + !/ 10-Feb-2011 : Implementation of source terms ( version 4.04 ) + !/ (S. Zieger) + !/ 26-Jun-2017 : Recalibration of ST6 ( verison 6.06 ) + !/ (Q. Liu ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Observation-based wind input and dissipation after Donelan et al (2006), + ! and Babanin et al. (2010). Parameterisation is based on the field + ! data from Lake George, Australia. Initial implementation of input + ! and dissipation is based on work from Tsagareli et al. (2010) and + ! Rogers et al. (2012). Parameterisation extended and account for + ! negative input due to opposing winds (see Donelan et al, 2006) and + ! the vector version of the stress computation. + ! + ! References: + ! Babanin et al. 2010: JPO 40(4) 667- 683 + ! Donelan et al. 2006: JPO 36(8) 1672-1689 + ! Tsagareli et al. 2010: JPO 40(4) 656- 666 + ! Rogers et al. 2012: JTECH 29(9) 1329-1346 + ! + ! 2. Variables and types : + ! + ! Not applicable. + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SPR6 Subr. Public Integral parameter calculation following !/ST1. + ! W3SIN6 Subr. Public Observation-based wind input. + ! W3SDS6 Subr. Public Observation-based dissipation. + ! + ! IRANGE Func. Private Generate a sequence of integer values. + ! LFACTOR Func. Private Calculate reduction factor for Sin. + ! TAUWINDS Func. Private Normal stress calculation for Sin. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T6 Enable test output for wind input and dissipation subroutines. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC :: W3SPR6, W3SIN6, W3SDS6 + PRIVATE :: LFACTOR, TAUWINDS, IRANGE +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP/NOPP | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 11-Feb-2011 | + !/ +-----------------------------------+ + !/ + !/ 08-Oct-2007 : Origination. ( version 3.13 ) + !/ 11-Feb-2011 : Implementation based on W3SPR1 ( version 4.04 ) + !/ (S. Zieger) + !/ + ! 1. Purpose : + ! Calculate mean wave parameters. + ! + ! 2. Method : + ! See source term routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action as a function of direction and wavenumber + ! CG R.A. I Group velocities + ! WN R.A. I Wavenumbers + ! EMEAN REAL O Mean wave energy + ! FMEAN REAL O Mean wave frequency + ! WNMEAN REAL O Mean wavenumber + ! AMAX REAL O Maximum action density in spectrum + ! FP REAL O Peak frequency (rad) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: TPIINV + USE W3GDATMD, ONLY: NK, NTH, SIG, DTH, DDEN, FTE, FTF, FTWN, DSII + USE W3ODATMD, ONLY: NDST, NDSE + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK) - REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX, FP -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK) + REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX, FP + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IMAX - REAL :: EB(NK), EBAND - REAL, PARAMETER :: HSMIN = 0.05 - REAL :: COEFF(3) -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: IMAX + REAL :: EB(NK), EBAND + REAL, PARAMETER :: HSMIN = 0.05 + REAL :: COEFF(3) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SPR6') + CALL STRACE (IENT, 'W3SPR6') #endif -! -! -! 1. Integrate over directions -------------------------------------- / - EB = SUM(A,1) * DDEN / CG - AMAX = MAXVAL(A) -! -! 2. Integrate over wavenumbers ------------------------------------- / - EMEAN = SUM(EB) - FMEAN = SUM(EB / SIG(1:NK)) - WNMEAN = SUM(EB / SQRT(WN)) -! -! 3. Add tail beyond discrete spectrum and get mean pars ------------ / -! ( DTH * SIG absorbed in FTxx ) - EBAND = EB(NK) / DDEN(NK) - EMEAN = EMEAN + EBAND * FTE - FMEAN = FMEAN + EBAND * FTF - WNMEAN = WNMEAN + EBAND * FTWN -! -! 4. Final processing - FMEAN = TPIINV * EMEAN / MAX(1.0E-7, FMEAN) - WNMEAN = ( EMEAN / MAX(1.0E-7,WNMEAN) )**2 -! -! 5. Determine peak frequency using a weighted integral ------------- / -! Young (1999) p239: integrate f F**4 df / integrate F**4 df ----- / -! TODO: keep in mind that **fp** calculated in this way may not -! work under mixing (wind-sea and swell) sea states (QL) - FP = 0.0 -! - IF (4.0*SQRT(EMEAN) .GT. HSMIN) THEN - EB = SUM(A,1) * SIG(1:NK) /CG * DTH - FP = SUM(SIG(1:NK) * EB**4 * DSII) / MAX(1E-10, SUM(EB**4 * DSII)) - FP = FP * TPIINV - END IF -! - RETURN -!/ -!/ End of W3SPR6 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SPR6 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SIN6 (A, CG, WN2, UABS, USTAR, USDIR, CD, DAIR, & - TAUWX, TAUWY, TAUNWX, TAUNWY, S, D ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP/NOPP | -!/ | S. Zieger | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 13-Aug-2021 | -!/ +-----------------------------------+ -!/ -!/ 20-Dec-2010 : Origination. ( version 4.04 ) -!/ (S. Zieger) -!/ -!/ 26-Jun-2018 : UPROXY Update & UABS ( version 6.06 ) -!/ (Q. Liu) -!/ 13-Aug-2021 : Consider DAIR a variable ( version x.xx ) -!/ -! 1. Purpose : -! -! Observation-based source term for wind input after Donelan, Babanin, -! Young and Banner (Donelan et al ,2006) following the implementation -! by Rogers et al. (2012). -! -! References: -! Donelan et al. 2006: JPO 36(8) 1672-1689. -! Rogers et al. 2012: JTECH 29(9) 1329-1346 -! -! 2. Method : -! -! Sin = B * E -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A¹ R.A. I Action density spectrum -! CG R.A. I Group velocities -! WN2¹ R.A. I Wavenumbers -! UABS Real I Wind speed at 10 m above sea level (U10) -! USTAR Real I Friction velocity -! USDIR Real I Direction of USTAR -! CD Real I Drag coefficient -! DAIR Real I Air density -! S¹ R.A. O Source term -! D¹ R.A. O Diagonal term of derivative -! TAUWX-Y Real O Component of the wave-supported stress -! TAUNWX-Y Real O Component of the negative part of the stress -! ¹ Stored as 1-D array with dimension NTH*NK (column by column). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! LFACTOR Subr. W3SRC6MD -! IRANGE Func. W3SRC6MD -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See comments in source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T6 Test and diagnostic output for tail reduction. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: DWAT, TPI, GRAV - USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG2, DDEN2 - USE W3GDATMD, ONLY: ECOS, ESIN, SIN6A0, SIN6WS - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE + ! + ! + ! 1. Integrate over directions -------------------------------------- / + EB = SUM(A,1) * DDEN / CG + AMAX = MAXVAL(A) + ! + ! 2. Integrate over wavenumbers ------------------------------------- / + EMEAN = SUM(EB) + FMEAN = SUM(EB / SIG(1:NK)) + WNMEAN = SUM(EB / SQRT(WN)) + ! + ! 3. Add tail beyond discrete spectrum and get mean pars ------------ / + ! ( DTH * SIG absorbed in FTxx ) + EBAND = EB(NK) / DDEN(NK) + EMEAN = EMEAN + EBAND * FTE + FMEAN = FMEAN + EBAND * FTF + WNMEAN = WNMEAN + EBAND * FTWN + ! + ! 4. Final processing + FMEAN = TPIINV * EMEAN / MAX(1.0E-7, FMEAN) + WNMEAN = ( EMEAN / MAX(1.0E-7,WNMEAN) )**2 + ! + ! 5. Determine peak frequency using a weighted integral ------------- / + ! Young (1999) p239: integrate f F**4 df / integrate F**4 df ----- / + ! TODO: keep in mind that **fp** calculated in this way may not + ! work under mixing (wind-sea and swell) sea states (QL) + FP = 0.0 + ! + IF (4.0*SQRT(EMEAN) .GT. HSMIN) THEN + EB = SUM(A,1) * SIG(1:NK) /CG * DTH + FP = SUM(SIG(1:NK) * EB**4 * DSII) / MAX(1E-10, SUM(EB**4 * DSII)) + FP = FP * TPIINV + END IF + ! + RETURN + !/ + !/ End of W3SPR6 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SPR6 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SIN6 (A, CG, WN2, UABS, USTAR, USDIR, CD, DAIR, & + TAUWX, TAUWY, TAUNWX, TAUNWY, S, D ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP/NOPP | + !/ | S. Zieger | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 13-Aug-2021 | + !/ +-----------------------------------+ + !/ + !/ 20-Dec-2010 : Origination. ( version 4.04 ) + !/ (S. Zieger) + !/ + !/ 26-Jun-2018 : UPROXY Update & UABS ( version 6.06 ) + !/ (Q. Liu) + !/ 13-Aug-2021 : Consider DAIR a variable ( version x.xx ) + !/ + ! 1. Purpose : + ! + ! Observation-based source term for wind input after Donelan, Babanin, + ! Young and Banner (Donelan et al ,2006) following the implementation + ! by Rogers et al. (2012). + ! + ! References: + ! Donelan et al. 2006: JPO 36(8) 1672-1689. + ! Rogers et al. 2012: JTECH 29(9) 1329-1346 + ! + ! 2. Method : + ! + ! Sin = B * E + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A¹ R.A. I Action density spectrum + ! CG R.A. I Group velocities + ! WN2¹ R.A. I Wavenumbers + ! UABS Real I Wind speed at 10 m above sea level (U10) + ! USTAR Real I Friction velocity + ! USDIR Real I Direction of USTAR + ! CD Real I Drag coefficient + ! DAIR Real I Air density + ! S¹ R.A. O Source term + ! D¹ R.A. O Diagonal term of derivative + ! TAUWX-Y Real O Component of the wave-supported stress + ! TAUNWX-Y Real O Component of the negative part of the stress + ! ¹ Stored as 1-D array with dimension NTH*NK (column by column). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! LFACTOR Subr. W3SRC6MD + ! IRANGE Func. W3SRC6MD + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See comments in source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T6 Test and diagnostic output for tail reduction. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: DWAT, TPI, GRAV + USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG2, DDEN2 + USE W3GDATMD, ONLY: ECOS, ESIN, SIN6A0, SIN6WS + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: A (NSPEC), CG(NK), WN2(NSPEC) - REAL, INTENT(IN) :: UABS, USTAR, USDIR, CD, DAIR - REAL, INTENT(OUT) :: TAUWX, TAUWY, TAUNWX, TAUNWY - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: A (NSPEC), CG(NK), WN2(NSPEC) + REAL, INTENT(IN) :: UABS, USTAR, USDIR, CD, DAIR + REAL, INTENT(OUT) :: TAUWX, TAUWY, TAUNWX, TAUNWY + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IK, ITH, IKN(NK) - REAL :: COSU, SINU, UPROXY - REAL, DIMENSION(NSPEC) :: CG2, ECOS2, ESIN2, DSII2 - REAL, DIMENSION(NK) :: DSII, SIG, WN - REAL :: K(NTH,NK), SDENSIG(NTH,NK) ! 1,2,5) - REAL, DIMENSION(NK) :: ADENSIG, KMAX, ANAR, SQRTBN ! 1,2,3) - REAL, DIMENSION(NSPEC) :: W1, W2, SQRTBN2, CINV2 ! 4,7) - REAL, DIMENSION(NK) :: LFACT, CINV ! 5) -!/ ------------------------------------------------------------------- / + INTEGER :: IK, ITH, IKN(NK) + REAL :: COSU, SINU, UPROXY + REAL, DIMENSION(NSPEC) :: CG2, ECOS2, ESIN2, DSII2 + REAL, DIMENSION(NK) :: DSII, SIG, WN + REAL :: K(NTH,NK), SDENSIG(NTH,NK) ! 1,2,5) + REAL, DIMENSION(NK) :: ADENSIG, KMAX, ANAR, SQRTBN ! 1,2,3) + REAL, DIMENSION(NSPEC) :: W1, W2, SQRTBN2, CINV2 ! 4,7) + REAL, DIMENSION(NK) :: LFACT, CINV ! 5) + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'W3SIN6') + CALL STRACE (IENT, 'W3SIN6') #endif -! -!/ 0) --- set up a basic variables ----------------------------------- / - COSU = COS(USDIR) - SINU = SIN(USDIR) -! - TAUNWX = 0. - TAUNWY = 0. - TAUWX = 0. - TAUWY = 0. -! -!/ --- scale friction velocity to wind speed (10m) in -!/ the boundary layer ----------------------------------------- / -!/ Donelan et al. (2006) used U10 or U_{λ/2} in their S_{in} -!/ parameterization. To avoid some disadvantages of using U10 or -!/ U_{λ/2}, Rogers et al. (2012) used the following engineering -!/ conversion: -!/ UPROXY = SIN6WS * UST -!/ -!/ SIN6WS = 28.0 following Komen et al. (1984) -!/ SIN6WS = 32.0 suggested by E. Rogers (2014) -! - UPROXY = SIN6WS * USTAR ! Scale wind speed -! - ECOS2 = ECOS(1:NSPEC) ! Only indices from 1 to NSPEC - ESIN2 = ESIN(1:NSPEC) ! are requested. -! - IKN = IRANGE(1,NSPEC,NTH) ! Index vector for elements of 1 ... NK -! ! such that e.g. SIG(1:NK) = SIG2(IKN). - DSII2 = DDEN2 / DTH / SIG2 ! Frequency bandwidths (int.) (rad) - DSII = DSII2(IKN) - SIG = SIG2(IKN) - WN = WN2(IKN) - CINV2 = WN2 / SIG2 ! inverse phase speed -! + ! + !/ 0) --- set up a basic variables ----------------------------------- / + COSU = COS(USDIR) + SINU = SIN(USDIR) + ! + TAUNWX = 0. + TAUNWY = 0. + TAUWX = 0. + TAUWY = 0. + ! + !/ --- scale friction velocity to wind speed (10m) in + !/ the boundary layer ----------------------------------------- / + !/ Donelan et al. (2006) used U10 or U_{λ/2} in their S_{in} + !/ parameterization. To avoid some disadvantages of using U10 or + !/ U_{λ/2}, Rogers et al. (2012) used the following engineering + !/ conversion: + !/ UPROXY = SIN6WS * UST + !/ + !/ SIN6WS = 28.0 following Komen et al. (1984) + !/ SIN6WS = 32.0 suggested by E. Rogers (2014) + ! + UPROXY = SIN6WS * USTAR ! Scale wind speed + ! + ECOS2 = ECOS(1:NSPEC) ! Only indices from 1 to NSPEC + ESIN2 = ESIN(1:NSPEC) ! are requested. + ! + IKN = IRANGE(1,NSPEC,NTH) ! Index vector for elements of 1 ... NK + ! ! such that e.g. SIG(1:NK) = SIG2(IKN). + DSII2 = DDEN2 / DTH / SIG2 ! Frequency bandwidths (int.) (rad) + DSII = DSII2(IKN) + SIG = SIG2(IKN) + WN = WN2(IKN) + CINV2 = WN2 / SIG2 ! inverse phase speed + ! + DO ITH = 1, NTH + CG2(IKN+(ITH-1)) = CG ! Apply CG to all directions. + END DO + ! + !/ 1) --- calculate 1d action density spectrum (A(sigma)) and + !/ zero-out values less than 1.0E-32 to avoid NaNs when + !/ computing directional narrowness in step 4). --------------- / + K = RESHAPE(A,(/ NTH,NK /)) + ADENSIG = SUM(K,1) * SIG * DTH ! Integrate over directions. + ! + !/ 2) --- calculate normalised directional spectrum K(theta,sigma) --- / + KMAX = MAXVAL(K,1) + DO IK = 1,NK + IF (KMAX(IK).LT.1.0E-34) THEN + K(1:NTH,IK) = 1. + ELSE + K(1:NTH,IK) = K(1:NTH,IK)/KMAX(IK) + END IF + END DO + ! + !/ 3) --- calculate normalised spectral saturation BN(IK) ------------ / + ANAR = 1.0/( SUM(K,1) * DTH ) ! directional narrowness + ! + SQRTBN = SQRT( ANAR * ADENSIG * WN**3 ) + DO ITH = 1, NTH + SQRTBN2(IKN+(ITH-1)) = SQRTBN ! Calculate SQRTBN for + END DO ! the entire spectrum. + ! + !/ 4) --- calculate growth rate GAMMA and S for all directions for + !/ following winds (U10/c - 1 is positive; W1) and in 7) for + !/ adverse winds (U10/c -1 is negative, W2). W1 and W2 + !/ complement one another. ------------------------------------ / + W1 = MAX( 0., UPROXY * CINV2* ( ECOS2*COSU + ESIN2*SINU ) - 1. )**2 + ! + D = (DAIR / DWAT) * SIG2 * & + (2.8 - ( 1. + TANH(10.*SQRTBN2*W1 - 11.) )) *SQRTBN2*W1 + ! + S = D * A + ! + !/ 5) --- calculate reduction factor LFACT using non-directional + ! spectral density of the wind input ------------------------- / + CINV = CINV2(IKN) + SDENSIG = RESHAPE(S*SIG2/CG2,(/ NTH,NK /)) + CALL LFACTOR(SDENSIG, CINV, UABS, USTAR, USDIR, SIG, DSII, & + LFACT, TAUWX, TAUWY ) + ! + !/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / + IF (SUM(LFACT) .LT. NK) THEN DO ITH = 1, NTH - CG2(IKN+(ITH-1)) = CG ! Apply CG to all directions. - END DO -! -!/ 1) --- calculate 1d action density spectrum (A(sigma)) and -!/ zero-out values less than 1.0E-32 to avoid NaNs when -!/ computing directional narrowness in step 4). --------------- / - K = RESHAPE(A,(/ NTH,NK /)) - ADENSIG = SUM(K,1) * SIG * DTH ! Integrate over directions. -! -!/ 2) --- calculate normalised directional spectrum K(theta,sigma) --- / - KMAX = MAXVAL(K,1) - DO IK = 1,NK - IF (KMAX(IK).LT.1.0E-34) THEN - K(1:NTH,IK) = 1. - ELSE - K(1:NTH,IK) = K(1:NTH,IK)/KMAX(IK) - END IF + D(IKN+ITH-1) = D(IKN+ITH-1) * LFACT END DO -! -!/ 3) --- calculate normalised spectral saturation BN(IK) ------------ / - ANAR = 1.0/( SUM(K,1) * DTH ) ! directional narrowness -! - SQRTBN = SQRT( ANAR * ADENSIG * WN**3 ) - DO ITH = 1, NTH - SQRTBN2(IKN+(ITH-1)) = SQRTBN ! Calculate SQRTBN for - END DO ! the entire spectrum. -! -!/ 4) --- calculate growth rate GAMMA and S for all directions for -!/ following winds (U10/c - 1 is positive; W1) and in 7) for -!/ adverse winds (U10/c -1 is negative, W2). W1 and W2 -!/ complement one another. ------------------------------------ / - W1 = MAX( 0., UPROXY * CINV2* ( ECOS2*COSU + ESIN2*SINU ) - 1. )**2 -! - D = (DAIR / DWAT) * SIG2 * & - (2.8 - ( 1. + TANH(10.*SQRTBN2*W1 - 11.) )) *SQRTBN2*W1 -! - S = D * A -! -!/ 5) --- calculate reduction factor LFACT using non-directional -! spectral density of the wind input ------------------------- / - CINV = CINV2(IKN) + S = D * A + END IF + ! + !/ 7) --- compute negative wind input for adverse winds. negative + !/ growth is typically smaller by a factor of ~2.5 (=.28/.11) + !/ than those for the favourable winds [Donelan, 2006, Eq. (7)]. + !/ the factor is adjustable with NAMELIST parameter in + !/ ww3_grid.inp: '&SIN6 SINA0 = 0.04 /' ----------------------- / + IF (SIN6A0.GT.0.0) THEN + W2 = MIN( 0., UPROXY * CINV2* ( ECOS2*COSU + ESIN2*SINU ) - 1. )**2 + D = D - ( (DAIR / DWAT) * SIG2 * SIN6A0 * & + (2.8 - ( 1. + TANH(10.*SQRTBN2*W2 - 11.) )) *SQRTBN2*W2 ) + S = D * A + ! --- compute negative component of the wave supported stresses + ! from negative part of the wind input ---------------------- / SDENSIG = RESHAPE(S*SIG2/CG2,(/ NTH,NK /)) - CALL LFACTOR(SDENSIG, CINV, UABS, USTAR, USDIR, SIG, DSII, & - LFACT, TAUWX, TAUWY ) -! -!/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / - IF (SUM(LFACT) .LT. NK) THEN - DO ITH = 1, NTH - D(IKN+ITH-1) = D(IKN+ITH-1) * LFACT - END DO - S = D * A - END IF -! -!/ 7) --- compute negative wind input for adverse winds. negative -!/ growth is typically smaller by a factor of ~2.5 (=.28/.11) -!/ than those for the favourable winds [Donelan, 2006, Eq. (7)]. -!/ the factor is adjustable with NAMELIST parameter in -!/ ww3_grid.inp: '&SIN6 SINA0 = 0.04 /' ----------------------- / - IF (SIN6A0.GT.0.0) THEN - W2 = MIN( 0., UPROXY * CINV2* ( ECOS2*COSU + ESIN2*SINU ) - 1. )**2 - D = D - ( (DAIR / DWAT) * SIG2 * SIN6A0 * & - (2.8 - ( 1. + TANH(10.*SQRTBN2*W2 - 11.) )) *SQRTBN2*W2 ) - S = D * A -! --- compute negative component of the wave supported stresses -! from negative part of the wind input ---------------------- / - SDENSIG = RESHAPE(S*SIG2/CG2,(/ NTH,NK /)) - CALL TAU_WAVE_ATMOS(SDENSIG, CINV, SIG, DSII, TAUNWX, TAUNWY ) - END IF -! -!/ -!/ End of W3SIN6 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SIN6 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SDS6 (A, CG, WN, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | S. Zieger | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 26-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 23-Jun-2010 : Origination. ( version 4.04 ) -!/ (S. Zieger) -!/ 26-Jun-2018 : Revise the width of the last bin ( version 6.06 ) -!/ (Q. Liu) -!/ -! 1. Purpose : -! -! Observation-based source term for dissipation after Babanin et al. -! (2010) following the implementation by Rogers et al. (2012). The -! dissipation function Sds accommodates an inherent breaking term T1 -! and an additional cumulative term T2 at all frequencies above the -! peak. The forced dissipation term T2 is an integral that grows -! toward higher frequencies and dominates at smaller scales -! (Babanin et al. 2010). -! -! References: -! Babanin et al. 2010: JPO 40(4), 667-683 -! Rogers et al. 2012: JTECH 29(9) 1329-1346 -! -! 2. Method : -! -! Sds = (T1 + T2) * E -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A¹ R.A. I Action density spectrum -! CG R.A. I Group velocities -! WN R.A. I Wavenumbers -! S¹ R.A. O Source term (1-D version) -! D¹ R.A. O Diagonal term of derivative -! ¹ Stored as 1-D array with dimension NTH*NK (column by column). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T6 Test output for dissipation terms T1 and T2. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, TPI - USE W3GDATMD, ONLY: NK, NTH, NSPEC, DDEN, DSII, SIG2, DTH, XFR - USE W3GDATMD, ONLY: SDS6A1, SDS6A2, SDS6P1, SDS6P2, SDS6ET - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE + CALL TAU_WAVE_ATMOS(SDENSIG, CINV, SIG, DSII, TAUNWX, TAUNWY ) + END IF + ! + !/ + !/ End of W3SIN6 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SIN6 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SDS6 (A, CG, WN, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | S. Zieger | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 26-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 23-Jun-2010 : Origination. ( version 4.04 ) + !/ (S. Zieger) + !/ 26-Jun-2018 : Revise the width of the last bin ( version 6.06 ) + !/ (Q. Liu) + !/ + ! 1. Purpose : + ! + ! Observation-based source term for dissipation after Babanin et al. + ! (2010) following the implementation by Rogers et al. (2012). The + ! dissipation function Sds accommodates an inherent breaking term T1 + ! and an additional cumulative term T2 at all frequencies above the + ! peak. The forced dissipation term T2 is an integral that grows + ! toward higher frequencies and dominates at smaller scales + ! (Babanin et al. 2010). + ! + ! References: + ! Babanin et al. 2010: JPO 40(4), 667-683 + ! Rogers et al. 2012: JTECH 29(9) 1329-1346 + ! + ! 2. Method : + ! + ! Sds = (T1 + T2) * E + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A¹ R.A. I Action density spectrum + ! CG R.A. I Group velocities + ! WN R.A. I Wavenumbers + ! S¹ R.A. O Source term (1-D version) + ! D¹ R.A. O Diagonal term of derivative + ! ¹ Stored as 1-D array with dimension NTH*NK (column by column). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T6 Test output for dissipation terms T1 and T2. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, TPI + USE W3GDATMD, ONLY: NK, NTH, NSPEC, DDEN, DSII, SIG2, DTH, XFR + USE W3GDATMD, ONLY: SDS6A1, SDS6A2, SDS6P1, SDS6P2, SDS6ET + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_T6 - USE W3TIMEMD, ONLY: STME21 - USE W3WDATMD, ONLY: TIME - USE W3ODATMD, ONLY: NDST + USE W3TIMEMD, ONLY: STME21 + USE W3WDATMD, ONLY: TIME + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: A(NSPEC), CG(NK), WN(NK) - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: A(NSPEC), CG(NK), WN(NK) + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IK, ITH, IKN(NK) - REAL :: FREQ(NK) ! frequencies [Hz] - REAL :: DFII(NK) ! frequency bandwiths [Hz] - REAL :: ANAR(NK) ! directional narrowness - REAL :: BNT ! empirical constant for - ! wave breaking probability - REAL :: EDENS (NK) ! spectral density E(f) - REAL :: ETDENS(NK) ! threshold spec. density ET(f) - REAL :: EXDENS(NK) ! excess spectral density EX(f) - REAL :: NEXDENS(NK) ! normalised excess spectral density - REAL :: T1(NK) ! inherent breaking term - REAL :: T2(NK) ! forced dissipation term - REAL :: T12(NK) ! = T1+T2 or combined dissipation - REAL :: ADF(NK), XFAC, EDENSMAX ! temp. variables + INTEGER :: IK, ITH, IKN(NK) + REAL :: FREQ(NK) ! frequencies [Hz] + REAL :: DFII(NK) ! frequency bandwiths [Hz] + REAL :: ANAR(NK) ! directional narrowness + REAL :: BNT ! empirical constant for + ! wave breaking probability + REAL :: EDENS (NK) ! spectral density E(f) + REAL :: ETDENS(NK) ! threshold spec. density ET(f) + REAL :: EXDENS(NK) ! excess spectral density EX(f) + REAL :: NEXDENS(NK) ! normalised excess spectral density + REAL :: T1(NK) ! inherent breaking term + REAL :: T2(NK) ! forced dissipation term + REAL :: T12(NK) ! = T1+T2 or combined dissipation + REAL :: ADF(NK), XFAC, EDENSMAX ! temp. variables #ifdef W3_T6 - CHARACTER(LEN=23) :: IDTIME + CHARACTER(LEN=23) :: IDTIME #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SDS6') + CALL STRACE (IENT, 'W3SDS6') #endif -! -!/ 0) --- Initialize essential parameters ---------------------------- / - IKN = IRANGE(1,NSPEC,NTH) ! Index vector for elements of 1, -! ! 2,..., NK such that for example -! ! SIG(1:NK) = SIG2(IKN). - FREQ = SIG2(IKN)/TPI - ANAR = 1.0 - BNT = 0.035**2 - T1 = 0.0 - T2 = 0.0 - NEXDENS = 0.0 -! -!/ 1) --- Calculate threshold spectral density, spectral density, and -!/ the level of exceedence EXDENS(f) -------------------------- / - ETDENS = ( TPI * BNT ) / ( ANAR * CG * WN**3 ) - EDENS = SUM(RESHAPE(A,(/ NTH,NK /)),1) * TPI * SIG2(IKN) * DTH / CG ! E(f) - EXDENS = MAX(0.0,EDENS-ETDENS) -! -!/ --- normalise by a generic spectral density -------------------- / - IF (SDS6ET) THEN ! ww3_grid.inp: &SDS6 SDSET = T or F - NEXDENS = EXDENS / ETDENS ! normalise by threshold spectral density - ELSE ! normalise by spectral density - EDENSMAX = MAXVAL(EDENS)*1E-5 - IF (ALL(EDENS .GT. EDENSMAX)) THEN - NEXDENS = EXDENS / EDENS - ELSE - DO IK = 1,NK - IF (EDENS(IK) .GT. EDENSMAX) NEXDENS(IK) = EXDENS(IK) / EDENS(IK) - END DO - END IF + ! + !/ 0) --- Initialize essential parameters ---------------------------- / + IKN = IRANGE(1,NSPEC,NTH) ! Index vector for elements of 1, + ! ! 2,..., NK such that for example + ! ! SIG(1:NK) = SIG2(IKN). + FREQ = SIG2(IKN)/TPI + ANAR = 1.0 + BNT = 0.035**2 + T1 = 0.0 + T2 = 0.0 + NEXDENS = 0.0 + ! + !/ 1) --- Calculate threshold spectral density, spectral density, and + !/ the level of exceedence EXDENS(f) -------------------------- / + ETDENS = ( TPI * BNT ) / ( ANAR * CG * WN**3 ) + EDENS = SUM(RESHAPE(A,(/ NTH,NK /)),1) * TPI * SIG2(IKN) * DTH / CG ! E(f) + EXDENS = MAX(0.0,EDENS-ETDENS) + ! + !/ --- normalise by a generic spectral density -------------------- / + IF (SDS6ET) THEN ! ww3_grid.inp: &SDS6 SDSET = T or F + NEXDENS = EXDENS / ETDENS ! normalise by threshold spectral density + ELSE ! normalise by spectral density + EDENSMAX = MAXVAL(EDENS)*1E-5 + IF (ALL(EDENS .GT. EDENSMAX)) THEN + NEXDENS = EXDENS / EDENS + ELSE + DO IK = 1,NK + IF (EDENS(IK) .GT. EDENSMAX) NEXDENS(IK) = EXDENS(IK) / EDENS(IK) + END DO END IF -! -!/ 2) --- Calculate inherent breaking component T1 ------------------- / - T1 = SDS6A1 * ANAR * FREQ * (NEXDENS**SDS6P1) -! -!/ 3) --- Calculate T2, the dissipation of waves induced by -!/ the breaking of longer waves T2 ---------------------------- / - ADF = ANAR * (NEXDENS**SDS6P2) - XFAC = (1.0-1.0/XFR)/(XFR-1.0/XFR) - DO IK = 1,NK - DFII = DSII/TPI -! IF (IK .GT. 1) DFII(IK) = DFII(IK) * XFAC - IF (IK .GT. 1 .AND. IK .LT. NK) DFII(IK) = DFII(IK) * XFAC - T2(IK) = SDS6A2 * SUM( ADF(1:IK)*DFII(1:IK) ) - END DO -! -!/ 4) --- Sum up dissipation terms and apply to all directions ------- / - T12 = -1.0 * ( MAX(0.0,T1)+MAX(0.0,T2) ) - DO ITH = 1, NTH - D(IKN+ITH-1) = T12 - END DO -! - S = D * A -! -!/ 5) --- Diagnostic output (switch !/T6) ---------------------------- / -#ifdef W3_T6 - CALL STME21 ( TIME , IDTIME ) - WRITE (NDST,270) 'T1*E',IDTIME(1:19),(T1*EDENS) - WRITE (NDST,270) 'T2*E',IDTIME(1:19),(T2*EDENS) - WRITE (NDST,271) SUM(SUM(RESHAPE(S,(/ NTH,NK /)),1)*DDEN/CG) -#endif -! + END IF + ! + !/ 2) --- Calculate inherent breaking component T1 ------------------- / + T1 = SDS6A1 * ANAR * FREQ * (NEXDENS**SDS6P1) + ! + !/ 3) --- Calculate T2, the dissipation of waves induced by + !/ the breaking of longer waves T2 ---------------------------- / + ADF = ANAR * (NEXDENS**SDS6P2) + XFAC = (1.0-1.0/XFR)/(XFR-1.0/XFR) + DO IK = 1,NK + DFII = DSII/TPI + ! IF (IK .GT. 1) DFII(IK) = DFII(IK) * XFAC + IF (IK .GT. 1 .AND. IK .LT. NK) DFII(IK) = DFII(IK) * XFAC + T2(IK) = SDS6A2 * SUM( ADF(1:IK)*DFII(1:IK) ) + END DO + ! + !/ 4) --- Sum up dissipation terms and apply to all directions ------- / + T12 = -1.0 * ( MAX(0.0,T1)+MAX(0.0,T2) ) + DO ITH = 1, NTH + D(IKN+ITH-1) = T12 + END DO + ! + S = D * A + ! + !/ 5) --- Diagnostic output (switch !/T6) ---------------------------- / #ifdef W3_T6 - 270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) - 271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) + CALL STME21 ( TIME , IDTIME ) + WRITE (NDST,270) 'T1*E',IDTIME(1:19),(T1*EDENS) + WRITE (NDST,270) 'T2*E',IDTIME(1:19),(T2*EDENS) + WRITE (NDST,271) SUM(SUM(RESHAPE(S,(/ NTH,NK /)),1)*DDEN/CG) + ! +270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) +271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) #endif -!/ -!/ End of W3SDS6 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SDS6 -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, SIG, DSII, & - LFACT, TAUWX, TAUWY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | S. Zieger | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 26-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 15-Feb-2011 : Implemented following Rogers et al. (2012) -!/ (S. Zieger) -!/ 26-Jun-2018 : UPROXY, DSII10Hz Updates ( version 6.06 ) -!/ (Q. Liu ) -! -! Rogers et al. (2012) JTECH 29(9), 1329-1346 -! -! 1. Purpose : -! -! Numerical approximation for the reduction factor LFACTOR(f) to -! reduce energy in the high-frequency part of the resolved part -! of the spectrum to meet the constraint on total stress (TAU). -! The constraint is TAU <= TAU_TOT (TAU_TOT = TAU_WAV + TAU_VIS), -! thus the wind input is reduced to match our constraint. -! -! 2. Method : -! -! 1) If required, extend resolved part of the spectrum to 10Hz using -! an approximation for the spectral slope at the high frequency -! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). -! 2) Calculate stresses: -! total stress: TAU_TOT = DAIR * USTAR**2 -! viscous stress: TAU_VIS = DAIR * Cv * U10**2 -! viscous stress (x,y-components): -! TAUV_X = TAU_VIS * COS(USDIR) -! TAUV_Y = TAU_VIS * SIN(USDIR) -! wave supported stress (x,y-components): /10Hz -! TAUW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF -! / -! total stress (input): TAU = SQRT( (TAUW_X + TAUV_X)**2 -! + (TAUW_Y + TAUV_Y)**2 ) -! 3) If TAU does not meet our constraint reduce the wind input -! using reduction factor: -! LFACT(F) = MIN(1,exp((1-U/C(F))*RTAU)) -! Then alter RTAU and repeat 3) until our constraint is matched. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! S R.A. I Wind input energy density spectrum (S_{in}(σ, θ)) -! CINV R.A. I Inverse phase speed 1/C(sigma) -! U10 Real I Wind speed (10m) -! USTAR Real I Friction velocity -! USDIR Real I Wind direction -! SIG R.A. I Relative frequencies [in rad.] -! DSII R.A. I Frequency bandwiths [in rad.] -! LFACTOR R.A. O Factor array LFACT(sigma) -! TAUWX-Y Real O Component of the wave-supported stress -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! IRANGE Func. Private Index generator (ie, array addressing) -! TAUWINDS Func. Private Normal stress calculation (TAU_NRM) -! ---------------------------------------------------------------- -! -! ---------------------------------------------------------------- -! -! 5. Error messages : -! -! A warning is issued to NDST using format 280 if the iteration -! procedure reaches the upper iteration limit (ITERMAX). In this -! case the last approximation for RTAU is used. -! -!/ - USE CONSTANTS, ONLY: DAIR, GRAV, TPI - USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, XFR, ECOS, ESIN - USE W3GDATMD, ONLY: SIN6WS - USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPERR - USE W3TIMEMD, ONLY: STME21 - USE W3WDATMD, ONLY: TIME + !/ + !/ End of W3SDS6 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SDS6 + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, SIG, DSII, & + LFACT, TAUWX, TAUWY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | S. Zieger | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 26-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 15-Feb-2011 : Implemented following Rogers et al. (2012) + !/ (S. Zieger) + !/ 26-Jun-2018 : UPROXY, DSII10Hz Updates ( version 6.06 ) + !/ (Q. Liu ) + ! + ! Rogers et al. (2012) JTECH 29(9), 1329-1346 + ! + ! 1. Purpose : + ! + ! Numerical approximation for the reduction factor LFACTOR(f) to + ! reduce energy in the high-frequency part of the resolved part + ! of the spectrum to meet the constraint on total stress (TAU). + ! The constraint is TAU <= TAU_TOT (TAU_TOT = TAU_WAV + TAU_VIS), + ! thus the wind input is reduced to match our constraint. + ! + ! 2. Method : + ! + ! 1) If required, extend resolved part of the spectrum to 10Hz using + ! an approximation for the spectral slope at the high frequency + ! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). + ! 2) Calculate stresses: + ! total stress: TAU_TOT = DAIR * USTAR**2 + ! viscous stress: TAU_VIS = DAIR * Cv * U10**2 + ! viscous stress (x,y-components): + ! TAUV_X = TAU_VIS * COS(USDIR) + ! TAUV_Y = TAU_VIS * SIN(USDIR) + ! wave supported stress (x,y-components): /10Hz + ! TAUW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF + ! / + ! total stress (input): TAU = SQRT( (TAUW_X + TAUV_X)**2 + ! + (TAUW_Y + TAUV_Y)**2 ) + ! 3) If TAU does not meet our constraint reduce the wind input + ! using reduction factor: + ! LFACT(F) = MIN(1,exp((1-U/C(F))*RTAU)) + ! Then alter RTAU and repeat 3) until our constraint is matched. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! S R.A. I Wind input energy density spectrum (S_{in}(σ, θ)) + ! CINV R.A. I Inverse phase speed 1/C(sigma) + ! U10 Real I Wind speed (10m) + ! USTAR Real I Friction velocity + ! USDIR Real I Wind direction + ! SIG R.A. I Relative frequencies [in rad.] + ! DSII R.A. I Frequency bandwiths [in rad.] + ! LFACTOR R.A. O Factor array LFACT(sigma) + ! TAUWX-Y Real O Component of the wave-supported stress + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! IRANGE Func. Private Index generator (ie, array addressing) + ! TAUWINDS Func. Private Normal stress calculation (TAU_NRM) + ! ---------------------------------------------------------------- + ! + ! ---------------------------------------------------------------- + ! + ! 5. Error messages : + ! + ! A warning is issued to NDST using format 280 if the iteration + ! procedure reaches the upper iteration limit (ITERMAX). In this + ! case the last approximation for RTAU is used. + ! + !/ + USE CONSTANTS, ONLY: DAIR, GRAV, TPI + USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, XFR, ECOS, ESIN + USE W3GDATMD, ONLY: SIN6WS + USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPERR + USE W3TIMEMD, ONLY: STME21 + USE W3WDATMD, ONLY: TIME #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE -! -!/ ------ I/O parameters --------------------------------------------- / - REAL, INTENT(IN) :: S(NTH,NK) ! wind-input source term Sin - REAL, INTENT(IN) :: CINV(NK) ! inverse phase speed - REAL, INTENT(IN) :: U10 ! wind speed - REAL, INTENT(IN) :: USTAR, USDIR ! friction velocity & direction - REAL, INTENT(IN) :: SIG(NK) ! relative frequencies - REAL, INTENT(IN) :: DSII(NK) ! frequency bandwidths - REAL, INTENT(OUT) :: LFACT(NK) ! correction factor - REAL, INTENT(OUT) :: TAUWX, TAUWY ! normal stress components -! -!/ --- local parameters (in order of appearance) ------------------ / + IMPLICIT NONE + ! + !/ ------ I/O parameters --------------------------------------------- / + REAL, INTENT(IN) :: S(NTH,NK) ! wind-input source term Sin + REAL, INTENT(IN) :: CINV(NK) ! inverse phase speed + REAL, INTENT(IN) :: U10 ! wind speed + REAL, INTENT(IN) :: USTAR, USDIR ! friction velocity & direction + REAL, INTENT(IN) :: SIG(NK) ! relative frequencies + REAL, INTENT(IN) :: DSII(NK) ! frequency bandwidths + REAL, INTENT(OUT) :: LFACT(NK) ! correction factor + REAL, INTENT(OUT) :: TAUWX, TAUWY ! normal stress components + ! + !/ --- local parameters (in order of appearance) ------------------ / #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL, PARAMETER :: FRQMAX = 10. ! Upper freq. limit to extrapolate to. - INTEGER, PARAMETER:: ITERMAX = 80 ! Maximum number of iterations to - ! find numerical solution for LFACT. - INTEGER :: IK, NK10Hz, SIGN_NEW, SIGN_OLD -! - REAL :: ECOS2(NSPEC), ESIN2(NSPEC) - REAL, ALLOCATABLE :: IK10Hz(:), LF10Hz(:), SIG10Hz(:), CINV10Hz(:) - REAL, ALLOCATABLE :: SDENS10Hz(:), SDENSX10Hz(:), SDENSY10Hz(:) - REAL, ALLOCATABLE :: DSII10Hz(:), UCINV10Hz(:) - REAL :: TAU_TOT, TAU, TAU_VIS, TAU_WAV - REAL :: TAUVX, TAUVY, TAUX, TAUY - REAL :: TAU_NND, TAU_INIT(2) - REAL :: UPROXY, RTAU, DRTAU, ERR - LOGICAL :: OVERSHOT - CHARACTER(LEN=23) :: IDTIME -! -!/ ------------------------------------------------------------------- / + REAL, PARAMETER :: FRQMAX = 10. ! Upper freq. limit to extrapolate to. + INTEGER, PARAMETER:: ITERMAX = 80 ! Maximum number of iterations to + ! find numerical solution for LFACT. + INTEGER :: IK, NK10Hz, SIGN_NEW, SIGN_OLD + ! + REAL :: ECOS2(NSPEC), ESIN2(NSPEC) + REAL, ALLOCATABLE :: IK10Hz(:), LF10Hz(:), SIG10Hz(:), CINV10Hz(:) + REAL, ALLOCATABLE :: SDENS10Hz(:), SDENSX10Hz(:), SDENSY10Hz(:) + REAL, ALLOCATABLE :: DSII10Hz(:), UCINV10Hz(:) + REAL :: TAU_TOT, TAU, TAU_VIS, TAU_WAV + REAL :: TAUVX, TAUVY, TAUX, TAUY + REAL :: TAU_NND, TAU_INIT(2) + REAL :: UPROXY, RTAU, DRTAU, ERR + LOGICAL :: OVERSHOT + CHARACTER(LEN=23) :: IDTIME + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'LFACTOR') + CALL STRACE (IENT, 'LFACTOR') #endif -! -!/ 0) --- Find the number of frequencies required to extend arrays -!/ up to f=10Hz and allocate arrays --------------------------- / -!/ ALOG is the same as LOG - NK10Hz = CEILING(ALOG(FRQMAX/(SIG(1)/TPI))/ALOG(XFR))+1 - NK10Hz = MAX(NK,NK10Hz) -! - ALLOCATE(IK10Hz(NK10Hz)) - IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) -! - ALLOCATE(SIG10Hz(NK10Hz)) - ALLOCATE(CINV10Hz(NK10Hz)) - ALLOCATE(DSII10Hz(NK10Hz)) - ALLOCATE(LF10Hz(NK10Hz)) - ALLOCATE(SDENS10Hz(NK10Hz)) - ALLOCATE(SDENSX10Hz(NK10Hz)) - ALLOCATE(SDENSY10Hz(NK10Hz)) - ALLOCATE(UCINV10Hz(NK10Hz)) -! - ECOS2 = ECOS(1:NSPEC) - ESIN2 = ESIN(1:NSPEC) -! -!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral -! grid per se. Limit the constraint to the positive part of the -! wind input only. ---------------------------------------------- / - IF (NK .LT. NK10Hz) THEN - SDENS10Hz(1:NK) = SUM(S,1) * DTH - SDENSX10Hz(1:NK) = SUM(MAX(0.,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DTH - SDENSY10Hz(1:NK) = SUM(MAX(0.,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DTH - SIG10Hz = SIG(1)*XFR**(IK10Hz-1.0) - CINV10Hz(1:NK) = CINV - CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978 ! 1/c=σ/g - DSII10Hz = 0.5 * SIG10Hz * (XFR-1.0/XFR) -! The first and last frequency bin: - DSII10Hz(1) = 0.5 * SIG10Hz(1) * (XFR-1.0) - DSII10Hz(NK10Hz) = 0.5 * SIG10Hz(NK10Hz) * (XFR-1.0) / XFR -! -! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - SDENS10Hz(NK+1:NK10Hz) = SDENS10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - ELSE - SIG10Hz = SIG - CINV10Hz = CINV - DSII10Hz = DSII - SDENS10Hz(1:NK) = SUM(S,1) * DTH - SDENSX10Hz(1:NK) = SUM(MAX(0.,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DTH - SDENSY10Hz(1:NK) = SUM(MAX(0.,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DTH - END IF -! -!/ 2) --- Stress calculation ----------------------------------------- / -! --- The total stress ------------------------------------------- / - TAU_TOT = USTAR**2 * DAIR -! -! --- The viscous stress and check that it does not exceed -! the total stress. ------------------------------------------ / - TAU_VIS = MAX(0.0, -5.0E-5*U10 + 1.1E-3) * U10**2 * DAIR -! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) - TAU_VIS = MIN(0.95 * TAU_TOT, TAU_VIS) -! - TAUVX = TAU_VIS * COS(USDIR) - TAUVY = TAU_VIS * SIN(USDIR) -! -! --- The wave supported stress. --------------------------------- / - TAUWX = TAUWINDS(SDENSX10Hz,CINV10Hz,DSII10Hz) ! normal stress (x-component) - TAUWY = TAUWINDS(SDENSY10Hz,CINV10Hz,DSII10Hz) ! normal stress (y-component) - TAU_NND = TAUWINDS(SDENS10Hz, CINV10Hz,DSII10Hz) ! normal stress (non-directional) - TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) - TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components -! - TAUX = TAUVX + TAUWX ! total stress (x-component) - TAUY = TAUVY + TAUWY ! total stress (y-component) - TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) - ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error -! -!/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint -!/ TAU <= TAU_TOT --------------------------------------------- / - CALL STME21 ( TIME , IDTIME ) - LF10Hz = 1.0 - IK = 0 -! - IF (TAU .GT. TAU_TOT) THEN - OVERSHOT = .FALSE. - RTAU = ERR / 90. - DRTAU = 2.0 - SIGN_NEW = INT(SIGN(1.0,ERR)) + ! + !/ 0) --- Find the number of frequencies required to extend arrays + !/ up to f=10Hz and allocate arrays --------------------------- / + !/ ALOG is the same as LOG + NK10Hz = CEILING(ALOG(FRQMAX/(SIG(1)/TPI))/ALOG(XFR))+1 + NK10Hz = MAX(NK,NK10Hz) + ! + ALLOCATE(IK10Hz(NK10Hz)) + IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) + ! + ALLOCATE(SIG10Hz(NK10Hz)) + ALLOCATE(CINV10Hz(NK10Hz)) + ALLOCATE(DSII10Hz(NK10Hz)) + ALLOCATE(LF10Hz(NK10Hz)) + ALLOCATE(SDENS10Hz(NK10Hz)) + ALLOCATE(SDENSX10Hz(NK10Hz)) + ALLOCATE(SDENSY10Hz(NK10Hz)) + ALLOCATE(UCINV10Hz(NK10Hz)) + ! + ECOS2 = ECOS(1:NSPEC) + ESIN2 = ESIN(1:NSPEC) + ! + !/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral + ! grid per se. Limit the constraint to the positive part of the + ! wind input only. ---------------------------------------------- / + IF (NK .LT. NK10Hz) THEN + SDENS10Hz(1:NK) = SUM(S,1) * DTH + SDENSX10Hz(1:NK) = SUM(MAX(0.,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DTH + SDENSY10Hz(1:NK) = SUM(MAX(0.,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DTH + SIG10Hz = SIG(1)*XFR**(IK10Hz-1.0) + CINV10Hz(1:NK) = CINV + CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978 ! 1/c=σ/g + DSII10Hz = 0.5 * SIG10Hz * (XFR-1.0/XFR) + ! The first and last frequency bin: + DSII10Hz(1) = 0.5 * SIG10Hz(1) * (XFR-1.0) + DSII10Hz(NK10Hz) = 0.5 * SIG10Hz(NK10Hz) * (XFR-1.0) / XFR + ! + ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / + SDENS10Hz(NK+1:NK10Hz) = SDENS10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + ELSE + SIG10Hz = SIG + CINV10Hz = CINV + DSII10Hz = DSII + SDENS10Hz(1:NK) = SUM(S,1) * DTH + SDENSX10Hz(1:NK) = SUM(MAX(0.,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DTH + SDENSY10Hz(1:NK) = SUM(MAX(0.,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DTH + END IF + ! + !/ 2) --- Stress calculation ----------------------------------------- / + ! --- The total stress ------------------------------------------- / + TAU_TOT = USTAR**2 * DAIR + ! + ! --- The viscous stress and check that it does not exceed + ! the total stress. ------------------------------------------ / + TAU_VIS = MAX(0.0, -5.0E-5*U10 + 1.1E-3) * U10**2 * DAIR + ! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) + TAU_VIS = MIN(0.95 * TAU_TOT, TAU_VIS) + ! + TAUVX = TAU_VIS * COS(USDIR) + TAUVY = TAU_VIS * SIN(USDIR) + ! + ! --- The wave supported stress. --------------------------------- / + TAUWX = TAUWINDS(SDENSX10Hz,CINV10Hz,DSII10Hz) ! normal stress (x-component) + TAUWY = TAUWINDS(SDENSY10Hz,CINV10Hz,DSII10Hz) ! normal stress (y-component) + TAU_NND = TAUWINDS(SDENS10Hz, CINV10Hz,DSII10Hz) ! normal stress (non-directional) + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) + TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components + ! + TAUX = TAUVX + TAUWX ! total stress (x-component) + TAUY = TAUVY + TAUWY ! total stress (y-component) + TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) + ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error + ! + !/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint + !/ TAU <= TAU_TOT --------------------------------------------- / + CALL STME21 ( TIME , IDTIME ) + LF10Hz = 1.0 + IK = 0 + ! + IF (TAU .GT. TAU_TOT) THEN + OVERSHOT = .FALSE. + RTAU = ERR / 90. + DRTAU = 2.0 + SIGN_NEW = INT(SIGN(1.0,ERR)) - UPROXY = SIN6WS * USTAR - UCINV10Hz = 1.0 - (UPROXY * CINV10Hz) -! -#ifdef W3_T6 - WRITE (NDST,270) IDTIME, U10 - WRITE (NDST,271) -#endif - DO IK=1,ITERMAX - LF10Hz = MIN(1.0, EXP(UCINV10Hz * RTAU) ) -! - TAU_NND = TAUWINDS(SDENS10Hz *LF10Hz,CINV10Hz,DSII10Hz) - TAUWX = TAUWINDS(SDENSX10Hz*LF10Hz,CINV10Hz,DSII10Hz) - TAUWY = TAUWINDS(SDENSY10Hz*LF10Hz,CINV10Hz,DSII10Hz) - TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) -! - TAUX = TAUVX + TAUWX - TAUY = TAUVY + TAUWY - TAU = SQRT(TAUX**2 + TAUY**2) - ERR = (TAU-TAU_TOT) / TAU_TOT -! - SIGN_OLD = SIGN_NEW - SIGN_NEW = INT(SIGN(1.0, ERR)) + UPROXY = SIN6WS * USTAR + UCINV10Hz = 1.0 - (UPROXY * CINV10Hz) + ! #ifdef W3_T6 - WRITE (NDST,272) IK, RTAU, DRTAU, TAU, TAU_TOT, ERR, & - TAUWX, TAUWY, TAUVX, TAUVY, TAU_NND + WRITE (NDST,270) IDTIME, U10 + WRITE (NDST,271) #endif -! -! --- Slow down DRTAU when overshot. -------------------------- / - IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. - IF (OVERSHOT) DRTAU = MAX(0.5*(1.0+DRTAU),1.00010) -! - RTAU = RTAU * (DRTAU**SIGN_NEW) -! - IF (ABS(ERR) .LT. 1.54E-4) EXIT - END DO -! - IF (IK .GE. ITERMAX) WRITE (NDST,280) IDTIME(1:19), U10, TAU, & - TAU_TOT, ERR, TAUWX, TAUWY, TAUVX, TAUVY,TAU_NND - END IF -! - LFACT(1:NK) = LF10Hz(1:NK) -! + DO IK=1,ITERMAX + LF10Hz = MIN(1.0, EXP(UCINV10Hz * RTAU) ) + ! + TAU_NND = TAUWINDS(SDENS10Hz *LF10Hz,CINV10Hz,DSII10Hz) + TAUWX = TAUWINDS(SDENSX10Hz*LF10Hz,CINV10Hz,DSII10Hz) + TAUWY = TAUWINDS(SDENSY10Hz*LF10Hz,CINV10Hz,DSII10Hz) + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) + ! + TAUX = TAUVX + TAUWX + TAUY = TAUVY + TAUWY + TAU = SQRT(TAUX**2 + TAUY**2) + ERR = (TAU-TAU_TOT) / TAU_TOT + ! + SIGN_OLD = SIGN_NEW + SIGN_NEW = INT(SIGN(1.0, ERR)) #ifdef W3_T6 - WRITE (NDST,273) 'Sin ', IDTIME(1:19), SDENS10Hz*TPI - WRITE (NDST,273) 'SinR', IDTIME(1:19), SDENS10Hz*LF10Hz*TPI - WRITE (NDST,274) 'Sin ', SUM(SDENS10Hz(1:NK)*DSII) - WRITE (NDST,274) 'SinR ', SUM(SDENS10Hz(1:NK)*LF10Hz(1:NK)*DSII) - WRITE (NDST,274) 'SinR/C', TAUWINDS(SDENS10Hz(1:NK)*LFACT,CINV,DSII) + WRITE (NDST,272) IK, RTAU, DRTAU, TAU, TAU_TOT, ERR, & + TAUWX, TAUWY, TAUVX, TAUVY, TAU_NND #endif -! + ! + ! --- Slow down DRTAU when overshot. -------------------------- / + IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. + IF (OVERSHOT) DRTAU = MAX(0.5*(1.0+DRTAU),1.00010) + ! + RTAU = RTAU * (DRTAU**SIGN_NEW) + ! + IF (ABS(ERR) .LT. 1.54E-4) EXIT + END DO + ! + IF (IK .GE. ITERMAX) WRITE (NDST,280) IDTIME(1:19), U10, TAU, & + TAU_TOT, ERR, TAUWX, TAUWY, TAUVX, TAUVY,TAU_NND + END IF + ! + LFACT(1:NK) = LF10Hz(1:NK) + ! #ifdef W3_T6 - 270 FORMAT (' TEST W3SIN6 : LFACTOR SUBROUTINE CALCULATING FOR ', & - A,' U10=',F5.1 ) - 271 FORMAT (' TEST W3SIN6 : IK RTAU DRTAU TAU TAU_TOT' & - ' ERR TAUW_X TAUW_Y TAUV_X TAUV_Y TAU1D' ) - 272 FORMAT (' TEST W3SIN6 : ',I2,2F9.5,2F8.5,E10.2,4F7.4,F7.3 ) - 273 FORMAT (' TEST W3SIN6 : ',A,'(',A,'):', 70E11.3 ) + WRITE (NDST,273) 'Sin ', IDTIME(1:19), SDENS10Hz*TPI + WRITE (NDST,273) 'SinR', IDTIME(1:19), SDENS10Hz*LF10Hz*TPI + WRITE (NDST,274) 'Sin ', SUM(SDENS10Hz(1:NK)*DSII) + WRITE (NDST,274) 'SinR ', SUM(SDENS10Hz(1:NK)*LF10Hz(1:NK)*DSII) + WRITE (NDST,274) 'SinR/C', TAUWINDS(SDENS10Hz(1:NK)*LFACT,CINV,DSII) + ! +270 FORMAT (' TEST W3SIN6 : LFACTOR SUBROUTINE CALCULATING FOR ', & + A,' U10=',F5.1 ) +271 FORMAT (' TEST W3SIN6 : IK RTAU DRTAU TAU TAU_TOT' & + ' ERR TAUW_X TAUW_Y TAUV_X TAUV_Y TAU1D' ) +272 FORMAT (' TEST W3SIN6 : ',I2,2F9.5,2F8.5,E10.2,4F7.4,F7.3 ) +273 FORMAT (' TEST W3SIN6 : ',A,'(',A,'):', 70E11.3 ) #endif - 274 FORMAT (' TEST W3SIN6 : Total ',A,' =', E13.5 ) - 280 FORMAT (' WARNING LFACTOR (TIME,U10,TAU,TAU_TOT,ERR,TAUW_XY,' & - 'TAUV_XY,TAU_SCALAR): ',A,F6.1,2F7.4,E10.3,4F7.4,F7.3 ) -! - DEALLOCATE(IK10Hz,SIG10Hz,CINV10Hz,DSII10Hz,LF10Hz) - DEALLOCATE(SDENS10Hz,SDENSX10Hz,SDENSY10Hz,UCINV10Hz) -!/ - END SUBROUTINE LFACTOR -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | S. Zieger | -!/ | Q. Liu | -!/ | FORTRAN 90 | -!/ | Last update : 26-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 24-Oct-2013 : Origination following LFACTOR -!/ (S. Zieger) -!/ 26-Jun-2018 : Updates on DSII10Hz ( version 6.06) -!/ (Q. Liu) -! -! 1. Purpose : -! -! Calculated the stress for the negative part of the input term, -! that is the stress from the waves to the atmosphere. Relevant -! in the case of opposing winds. -! -! 2. Method : -! 1) If required, extend resolved part of the spectrum to 10Hz using -! an approximation for the spectral slope at the high frequency -! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). -! 2) Calculate stresses: -! stress components (x,y): /10Hz -! TAUNW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF -! / -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! S R.A. I Wind input energy density spectrum -! CINV R.A. I Inverse phase speed 1/C(sigma) -! SIG R.A. I Relative frequencies [in rad.] -! DSII R.A. I Frequency bandwiths [in rad.] -! TAUNWX-Y Real O Component of the negative wave-supported stress -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! IRANGE Func. Private Index generator (ie, array addressing) -! TAUWINDS Func. Private Normal stress calculation (TAU_NRM) -! ---------------------------------------------------------------- -! -! 5. Source code : -! -!/ - USE CONSTANTS, ONLY: GRAV, TPI - USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, XFR, ECOS, ESIN +274 FORMAT (' TEST W3SIN6 : Total ',A,' =', E13.5 ) +280 FORMAT (' WARNING LFACTOR (TIME,U10,TAU,TAU_TOT,ERR,TAUW_XY,' & + 'TAUV_XY,TAU_SCALAR): ',A,F6.1,2F7.4,E10.3,4F7.4,F7.3 ) + ! + DEALLOCATE(IK10Hz,SIG10Hz,CINV10Hz,DSII10Hz,LF10Hz) + DEALLOCATE(SDENS10Hz,SDENSX10Hz,SDENSY10Hz,UCINV10Hz) + !/ + END SUBROUTINE LFACTOR + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | S. Zieger | + !/ | Q. Liu | + !/ | FORTRAN 90 | + !/ | Last update : 26-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 24-Oct-2013 : Origination following LFACTOR + !/ (S. Zieger) + !/ 26-Jun-2018 : Updates on DSII10Hz ( version 6.06) + !/ (Q. Liu) + ! + ! 1. Purpose : + ! + ! Calculated the stress for the negative part of the input term, + ! that is the stress from the waves to the atmosphere. Relevant + ! in the case of opposing winds. + ! + ! 2. Method : + ! 1) If required, extend resolved part of the spectrum to 10Hz using + ! an approximation for the spectral slope at the high frequency + ! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). + ! 2) Calculate stresses: + ! stress components (x,y): /10Hz + ! TAUNW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF + ! / + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! S R.A. I Wind input energy density spectrum + ! CINV R.A. I Inverse phase speed 1/C(sigma) + ! SIG R.A. I Relative frequencies [in rad.] + ! DSII R.A. I Frequency bandwiths [in rad.] + ! TAUNWX-Y Real O Component of the negative wave-supported stress + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! IRANGE Func. Private Index generator (ie, array addressing) + ! TAUWINDS Func. Private Normal stress calculation (TAU_NRM) + ! ---------------------------------------------------------------- + ! + ! 5. Source code : + ! + !/ + USE CONSTANTS, ONLY: GRAV, TPI + USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, XFR, ECOS, ESIN #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE -! -!/ ------ I/O parameters --------------------------------------------- / - REAL, INTENT(IN) :: S(NTH,NK) ! wind-input source term Sin - REAL, INTENT(IN) :: CINV(NK) ! inverse phase speed - REAL, INTENT(IN) :: SIG(NK) ! relative frequencies - REAL, INTENT(IN) :: DSII(NK) ! frequency bandwidths - REAL, INTENT(OUT) :: TAUNWX, TAUNWY ! stress components (wave->atmos) -! -!/ --- local parameters (in order of appearance) ------------------ / + IMPLICIT NONE + ! + !/ ------ I/O parameters --------------------------------------------- / + REAL, INTENT(IN) :: S(NTH,NK) ! wind-input source term Sin + REAL, INTENT(IN) :: CINV(NK) ! inverse phase speed + REAL, INTENT(IN) :: SIG(NK) ! relative frequencies + REAL, INTENT(IN) :: DSII(NK) ! frequency bandwidths + REAL, INTENT(OUT) :: TAUNWX, TAUNWY ! stress components (wave->atmos) + ! + !/ --- local parameters (in order of appearance) ------------------ / #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL, PARAMETER :: FRQMAX = 10. ! Upper freq. limit to extrapolate to. - INTEGER :: NK10Hz -! - REAL :: ECOS2(NSPEC), ESIN2(NSPEC) - REAL, ALLOCATABLE :: IK10Hz(:), SIG10Hz(:), CINV10Hz(:) - REAL, ALLOCATABLE :: SDENSX10Hz(:), SDENSY10Hz(:) - REAL, ALLOCATABLE :: DSII10Hz(:), UCINV10Hz(:) -! -!/ ------------------------------------------------------------------- / + REAL, PARAMETER :: FRQMAX = 10. ! Upper freq. limit to extrapolate to. + INTEGER :: NK10Hz + ! + REAL :: ECOS2(NSPEC), ESIN2(NSPEC) + REAL, ALLOCATABLE :: IK10Hz(:), SIG10Hz(:), CINV10Hz(:) + REAL, ALLOCATABLE :: SDENSX10Hz(:), SDENSY10Hz(:) + REAL, ALLOCATABLE :: DSII10Hz(:), UCINV10Hz(:) + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'TAU_WAVE_ATMOS') + CALL STRACE (IENT, 'TAU_WAVE_ATMOS') #endif -! -!/ 0) --- Find the number of frequencies required to extend arrays -!/ up to f=10Hz and allocate arrays --------------------------- / - NK10Hz = CEILING(ALOG(FRQMAX/(SIG(1)/TPI))/ALOG(XFR))+1 - NK10Hz = MAX(NK,NK10Hz) -! - ALLOCATE(IK10Hz(NK10Hz)) - IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) -! - ALLOCATE(SIG10Hz(NK10Hz)) - ALLOCATE(CINV10Hz(NK10Hz)) - ALLOCATE(DSII10Hz(NK10Hz)) - ALLOCATE(SDENSX10Hz(NK10Hz)) - ALLOCATE(SDENSY10Hz(NK10Hz)) - ALLOCATE(UCINV10Hz(NK10Hz)) -! - ECOS2 = ECOS(1:NSPEC) - ESIN2 = ESIN(1:NSPEC) -! -!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral -! grid per se. Limit the constraint to the positive part of the -! wind input only. ---------------------------------------------- / - IF (NK .LT. NK10Hz) THEN - SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.,S))*RESHAPE(ECOS2,(/NTH,NK/)),1) * DTH - SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.,S))*RESHAPE(ESIN2,(/NTH,NK/)),1) * DTH - SIG10Hz = SIG(1)*XFR**(IK10Hz-1.0) - CINV10Hz(1:NK) = CINV - CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978 - DSII10Hz = 0.5 * SIG10Hz * (XFR-1.0/XFR) -! The first and last frequency bin: - DSII10Hz(1) = 0.5 * SIG10Hz(1) * (XFR-1.0) - DSII10Hz(NK10Hz) = 0.5 * SIG10Hz(NK10Hz) * (XFR-1.0) / XFR -! -! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - ELSE - SIG10Hz = SIG - CINV10Hz = CINV - DSII10Hz = DSII - SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.,S))*RESHAPE(ECOS2,(/NTH,NK/)),1) * DTH - SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.,S))*RESHAPE(ESIN2,(/NTH,NK/)),1) * DTH - END IF -! -!/ 2) --- Stress calculation ----------------------------------------- / -! --- The wave supported stress (waves to atmosphere) ------------ / - TAUNWX = TAUWINDS(SDENSX10Hz,CINV10Hz,DSII10Hz) ! x-component - TAUNWY = TAUWINDS(SDENSY10Hz,CINV10Hz,DSII10Hz) ! y-component -!/ + ! + !/ 0) --- Find the number of frequencies required to extend arrays + !/ up to f=10Hz and allocate arrays --------------------------- / + NK10Hz = CEILING(ALOG(FRQMAX/(SIG(1)/TPI))/ALOG(XFR))+1 + NK10Hz = MAX(NK,NK10Hz) + ! + ALLOCATE(IK10Hz(NK10Hz)) + IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) + ! + ALLOCATE(SIG10Hz(NK10Hz)) + ALLOCATE(CINV10Hz(NK10Hz)) + ALLOCATE(DSII10Hz(NK10Hz)) + ALLOCATE(SDENSX10Hz(NK10Hz)) + ALLOCATE(SDENSY10Hz(NK10Hz)) + ALLOCATE(UCINV10Hz(NK10Hz)) + ! + ECOS2 = ECOS(1:NSPEC) + ESIN2 = ESIN(1:NSPEC) + ! + !/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral + ! grid per se. Limit the constraint to the positive part of the + ! wind input only. ---------------------------------------------- / + IF (NK .LT. NK10Hz) THEN + SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.,S))*RESHAPE(ECOS2,(/NTH,NK/)),1) * DTH + SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.,S))*RESHAPE(ESIN2,(/NTH,NK/)),1) * DTH + SIG10Hz = SIG(1)*XFR**(IK10Hz-1.0) + CINV10Hz(1:NK) = CINV + CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978 + DSII10Hz = 0.5 * SIG10Hz * (XFR-1.0/XFR) + ! The first and last frequency bin: + DSII10Hz(1) = 0.5 * SIG10Hz(1) * (XFR-1.0) + DSII10Hz(NK10Hz) = 0.5 * SIG10Hz(NK10Hz) * (XFR-1.0) / XFR + ! + ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / + SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + ELSE + SIG10Hz = SIG + CINV10Hz = CINV + DSII10Hz = DSII + SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.,S))*RESHAPE(ECOS2,(/NTH,NK/)),1) * DTH + SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.,S))*RESHAPE(ESIN2,(/NTH,NK/)),1) * DTH + END IF + ! + !/ 2) --- Stress calculation ----------------------------------------- / + ! --- The wave supported stress (waves to atmosphere) ------------ / + TAUNWX = TAUWINDS(SDENSX10Hz,CINV10Hz,DSII10Hz) ! x-component + TAUNWY = TAUWINDS(SDENSY10Hz,CINV10Hz,DSII10Hz) ! y-component + !/ END SUBROUTINE TAU_WAVE_ATMOS -!/ ------------------------------------------------------------------- / -!/ + !/ ------------------------------------------------------------------- / + !/ FUNCTION IRANGE(X0,X1,DX) RESULT(IX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 15-Feb-2011 | -!/ +-----------------------------------+ -!/ -!/ 15-Feb-2011 : Origination ( version 4.04 ) -!/ (S. Zieger) -!/ -! 1. Purpose : -! Generate a sequence of linear-spaced integer numbers. -! Used for instance array addressing (indexing). -! -!/ - IMPLICIT NONE - INTEGER, INTENT(IN) :: X0, X1, DX - INTEGER, ALLOCATABLE :: IX(:) - INTEGER :: N - INTEGER :: I -! - N = INT(REAL(X1-X0)/REAL(DX))+1 - ALLOCATE(IX(N)) - DO I = 1, N - IX(I) = X0+ (I-1)*DX - END DO -!/ + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 15-Feb-2011 | + !/ +-----------------------------------+ + !/ + !/ 15-Feb-2011 : Origination ( version 4.04 ) + !/ (S. Zieger) + !/ + ! 1. Purpose : + ! Generate a sequence of linear-spaced integer numbers. + ! Used for instance array addressing (indexing). + ! + !/ + IMPLICIT NONE + INTEGER, INTENT(IN) :: X0, X1, DX + INTEGER, ALLOCATABLE :: IX(:) + INTEGER :: N + INTEGER :: I + ! + N = INT(REAL(X1-X0)/REAL(DX))+1 + ALLOCATE(IX(N)) + DO I = 1, N + IX(I) = X0+ (I-1)*DX + END DO + !/ END FUNCTION IRANGE -!/ ------------------------------------------------------------------- / -!/ + !/ ------------------------------------------------------------------- / + !/ FUNCTION TAUWINDS(SDENSIG,CINV,DSII) RESULT(TAU_WINDS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 13-Aug-2012 | -!/ +-----------------------------------+ -!/ -!/ 15-Feb-2011 : Origination ( version 4.04 ) -!/ (S. Zieger) -!/ -! 1. Purpose : -! Wind stress (tau) computation from wind-momentum-input -! function which can be obtained from wind-energy-input (Sin). -! -! / FRMAX -! tau = g * rho_water * | Sin(f)/C(f) df -! / -!/ + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 13-Aug-2012 | + !/ +-----------------------------------+ + !/ + !/ 15-Feb-2011 : Origination ( version 4.04 ) + !/ (S. Zieger) + !/ + ! 1. Purpose : + ! Wind stress (tau) computation from wind-momentum-input + ! function which can be obtained from wind-energy-input (Sin). + ! + ! / FRMAX + ! tau = g * rho_water * | Sin(f)/C(f) df + ! / + !/ USE CONSTANTS, ONLY: GRAV, DWAT ! gravity, density of water IMPLICIT NONE REAL, INTENT(IN) :: SDENSIG(:) ! Sin(sigma) in [m2/rad-Hz] REAL, INTENT(IN) :: CINV(:) ! inverse phase speed REAL, INTENT(IN) :: DSII(:) ! freq. bandwidths in [radians] REAL :: TAU_WINDS ! wind stress -! + ! TAU_WINDS = GRAV * DWAT * SUM(SDENSIG*CINV*DSII) -!/ + !/ END FUNCTION TAUWINDS -!/ ------------------------------------------------------------------- / -!/ -!/ End of module W3SRC6MD -------------------------------------------- / -!/ - END MODULE W3SRC6MD + !/ ------------------------------------------------------------------- / + !/ + !/ End of module W3SRC6MD -------------------------------------------- / + !/ +END MODULE W3SRC6MD diff --git a/model/src/w3srcemd.F90 b/model/src/w3srcemd.F90 index fd9a12eea..1f4f0268d 100644 --- a/model/src/w3srcemd.F90 +++ b/model/src/w3srcemd.F90 @@ -1,1937 +1,1940 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SRCEMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ For updates see subroutine. -!/ -! 1. Purpose : -! -! Source term integration routine. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! OFFSET R.P. Private Offset in time integration scheme. -! 0.5 in original WAM, now 1.0 -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SRCE Subr. Public Calculate and integrate source terms. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See corresponding documentation of W3SRCE. -! -! 5. Remarks : -! -! 6. Switches : -! -! See section 9 of W3SRCE. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - REAL, PARAMETER, PRIVATE:: OFFSET = 1. -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SRCE ( srce_call, IT, ISEA, JSEA, IX, IY, IMOD, & - SPECOLD, SPEC, VSIO, VDIO, SHAVEIO, & - ALPHA, WN1, CG1, CLATSL, & - D_INP, U10ABS, U10DIR, & +MODULE W3SRCEMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ For updates see subroutine. + !/ + ! 1. Purpose : + ! + ! Source term integration routine. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! OFFSET R.P. Private Offset in time integration scheme. + ! 0.5 in original WAM, now 1.0 + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. Public Calculate and integrate source terms. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See corresponding documentation of W3SRCE. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See section 9 of W3SRCE. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + REAL, PARAMETER, PRIVATE:: OFFSET = 1. + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SRCE ( srce_call, IT, ISEA, JSEA, IX, IY, IMOD, & + SPECOLD, SPEC, VSIO, VDIO, SHAVEIO, & + ALPHA, WN1, CG1, CLATSL, & + D_INP, U10ABS, U10DIR, & #ifdef W3_FLX5 - TAUA, TAUADIR, & -#endif - AS, USTAR, USTDIR, & - CX, CY, ICE, ICEH, ICEF, ICEDMAX, & - REFLEC, REFLED, DELX, DELY, DELA, TRNX, & - TRNY, BERG, FPI, DTDYN, FCUT, DTG, TAUWX, & - TAUWY, TAUOX, TAUOY, TAUWIX, TAUWIY, TAUWNX,& - TAUWNY, PHIAW, CHARN, TWS, PHIOC, WHITECAP, & - D50, PSIC, BEDFORM , PHIBBL, TAUBBL, TAUICE,& - PHICE, TAUOCX, TAUOCY, WNMEAN, DAIR, COEF) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | F. Ardhuin | -!/ | A. Roland | -!/ | M. Dutour Sikiric | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 06-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 14-Feb-2000 : Exact-NL added ( version 2.01 ) -!/ 04-May-2000 : Non-central integration ( version 2.03 ) -!/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 27-Nov-2002 : First version of VDIA and MDIA. ( version 3.01 ) -!/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) -!/ 24-Dec-2004 : Multiple model version. ( version 3.06 ) -!/ 23-Jun-2006 : Linear input added. ( version 3.09 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 04-Jul-2006 : Separation of stress computation. ( version 3.09 ) -!/ 16-Apr-2007 : Miche style limiter added. ( version 3.11 ) -!/ (J. H. Alves) -!/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) -!/ (J. H. Alves) -!/ 09-Oct-2007 : Adding WAM 4+ and SB1 options. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 19-Aug-2010 : Making treatment of 0 water depth ( version 3.14.6 ) -!/ consistent with the rest of the model. -!/ 31-Mar-2010 : Adding ice conc. and reflections ( version 3.14.4 ) -!/ 15-May-2010 : Adding transparencies ( version 3.14.4 ) -!/ 01-Jun-2011 : Movable bed bottom friction in BT4 ( version 4.01 ) -!/ 01-Jul-2011 : Energy and momentum flux, friction ( version 4.01 ) -!/ 24-Aug-2011 : Uses true depth for depth-induced ( version 4.04 ) -!/ 16-Sep-2011 : Initialization of TAUWAX, TAUWAY ( version 4.04 ) -!/ 1-Dec-2011 : Adding BYDRZ source term package ( version 4.04 ) -!/ ST6 and optional Hwang (2011) -!/ stresses FLX4. -!/ 14-Mar-2012 : Update of BT4, passing PSIC ( version 4.04 ) -!/ 13-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) -!/ from 3.15 (HLT). ( version 4.08 ) -!/ 28-Aug-2013 : Corrected MLIM application ( version 4.11 ) -!/ 10-Sep-2013 : Special treatment for IG band ( version 4.15 ) -!/ 14-Nov-2013 : Make orphaned pars in par lst local ( version 4.13 ) -!/ 17-Nov-2013 : Coupling fraction of ice-free ( version 4.13 ) -!/ surface to SIN and SDS. (S. Zieger) -!/ 01-Avr-2014 : Adding ice thickness and floe size ( version 4.18 ) -!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) -!/ 27-Aug-2015 : Adding inputs to function W3SIS2 ( version 5.10 ) -!/ 13-Dec-2015 : Implicit integration of Sice (F.A.) ( version 5.10 ) -!/ 30-Jul-2017 : Adds TWS in interface ( version 6.04 ) -!/ 07-Jan-2018 : Allows variable ice scaling (F.A.) ( version 6.04 ) -!/ 01-Jan-2018 : Add implicit source term integration ( version 6.04) -!/ 01-Jan-2018 : within PDLIB (A. Roland, M. Dutour -!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06) -!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) -!/ 22-Mar-2021 : Add extra fields used in coupling ( version 7.13 ) -!/ 07-Jun-2021 : S_{nl5} GKE NL5 (Q. Liu) ( version 7.13 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Calculate and integrate source terms for a single grid point. -! -! 2. Method : -! -! Physics : see manual and corresponding subroutines. -! -! Numerics : -! -! Dynamic-implicit integration of the source terms based on -! WW-II (Tolman 1992). The dynamic time step is calculated -! given a maximum allowed change of spectral densities for -! frequencies / wavenumbers below the usual cut-off. -! The maximum change is given by the minimum of a parametric -! and a relative change. The parametric change relates to a -! PM type equilibrium range -! -! -1 (2pi)**4 1 -! dN(k) = Xp alpha pi ---------- ------------ -! max g**2 k**3 sigma -! -! 1 . -! = FACP ------------ (1) -! k**3 sigma . -! -! where -! alpha = 0.62e-4 (set in W3GRID) -! Xp fraction of PM shape (read in W3GRID) -! FACP combined factor (set in W3GRID) -! -! The maximum relative change is given as -! -! / +- -+ \ . -! dN(k) = Xr max | N(k) , max | Nx , Xfilt N(k) | | (2) -! max \ +- max-+ / . -! -! where -! Xr fraction of relative change (read in W3GRID) -! Xfilt filter level (read in W3GRID) -! Nx Maximum parametric change (1) -! for largest wavenumber. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IX,IY Int. I Discrete grid point counters. -! IMOD Int. I Model number. -! SPEC R.A. I/O Spectrum (action) in 1-D form. -! ALPHA R.A. I/O Nondimenional 1-D spectrum corresponding -! to above full spectra (Phillip's const.). -! Calculated separately for numerical -! economy on vector machine (W3SPR2). -! WN1 R.A. I Discrete wavenumbers. -! CG1 R.A. I Id. group velocities. -! D_INP Real. I Depth. Compared to DMIN to get DEPTH. -! U10ABS Real. I Wind speed at reference height. -! U10DIR Real. I Id. wind direction. -! TAUA Real. I Magnitude of total atmospheric stress ( !/FLX5 ) -! TAUADIR Real. I Direction of atmospheric stress ( !/FLX5 ) -! AS Real. I Air-sea temp. difference. ( !/ST3 ) -! USTAR Real. !/O Friction velocity. -! USTDIR Real !/O Idem, direction. -! CX-Y Real. I Current velocity components. ( !/BS1 ) -! ICE Real I Sea ice concentration -! ICEH Real I Sea ice thickness -! ICEF Real I/O Sea ice maximum floe diameter (updated) -! ICEDMAX Real I/O Sea ice maximum floe diameter -! BERG Real I Iceberg damping coefficient ( !/BS1 ) -! REFLEC R.A. I reflection coefficients ( !/BS1 ) -! REFLED I.A. I reflection direction ( !/BS1 ) -! TRNX-Y Real I Grid transparency in X and Y ( !/BS1 ) -! DELX Real. I grid cell size in X direction ( !/BS1 ) -! DELY Real. I grid cell size in Y direction ( !/BS1 ) -! DELA Real. I grid cell area ( !/BS1 ) -! FPI Real I/O Peak-input frequency. ( !/ST2 ) -! WHITECAP R.A. O Whitecap statisics ( !/ST4 ) -! DTDYN Real O Average dynamic time step. -! FCUT Real O Cut-off frequency for tail. -! DTG Real I Global time step. -! D50 Real I Sand grain size ( !/BT4 ) -! BEDFORM R.A. I/O Bedform parameters ( !/BT4 ) -! PSIC Real I Critical Shields ( !/BT4 ) -! PHIBBL Real O Energy flux to BBL ( !/BTx ) -! TAUBBL R.A. O Momentum flux to BBL ( !/BTx ) -! TAUICE R.A. O Momentum flux to sea ice ( !/ICx ) -! PHICE Real O Energy flux to sea ice ( !/ICx ) -! TAUOCX-YReal O Total ocean momentum components -! WNMEAN Real O Mean wave number -! DAIR Real I Air density -! ---------------------------------------------------------------- -! Note: several pars are set to I/O to avoid compiler warnings. -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SPRn Subr. W3SRCnMD Mean wave parameters for use in -! source terms. -! W3FLXn Subr. W3FLXnMD Flux/stress computation. -! W3SLNn Subr. W3SLNnMD Linear input. -! W3SINn Subr. W3SRCnMD Input source term. -! W3SNLn Subr. W3SNLnMD Nonlinear interactions. -! W3SNLS Subr. W3SNLSMD Nonlinear smoother. -! W3SDSn Subr. W3SRCnMD Whitecapping source term -! W3SBTn Subr. W3SBTnMD Bottom friction source term. -! W3SDBn Subr. W3SBTnMD Depth induced breaking source term. -! W3STRn Subr. W3STRnMD Triad interaction source term. -! W3SBSn Subr. W3SBSnMD Bottom scattering source term. -! W3REFn Subr. W3REFnMD Reflexions (shore, icebergs ...). -! STRACE Subr. W3SERVMD Subroutine tracing (!/S) -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - No testing is performed on the status of the grid point. -! -! 8. Structure : -! -! ----------------------------------------------------------------- -! 1. Preparations -! a Set maximum change and wavenumber arrays. -! b Prepare dynamic time stepping. -! c Compute mean parameters. ( W3SPRn ) -! d Compute stresses (if posible). -! e Prepare cut-off -! f Test output for !/NNT option. -! --start-dynamic-integration-loop--------------------------------- -! 2. Calculate source terms -! a Input. ( W3SLNx, W3SINn ) -! b Nonlinear interactions. ( W3SNLn ) -! c Dissipation ( W3SDSn ) -! 1 as included in source terms ( W3SDSn ) -! 2 optional dissipation due to different physics ( W3SWLn ) -! d Bottom friction. ( W3SBTn ) -! 3. Calculate cut-off frequencie(s) -! 4. Summation of source terms and diagonal term and time step. -! 5. Increment spectrum. -! 6. Add tail -! a Mean wave parameters and cut-off ( W3SPRn ) -! b 'Seeding' of spectrum. ( !/SEED ) -! c Add tail -! 7. Check if integration complete. -! --end-dynamic-integration-loop----------------------------------- -! 8. Save integration data. -! ----------------------------------------------------------------- -! -! 9. Switches : -! -! !/FLX1 Wu (1980) stress computation. ( Choose one ) -! !/FLX2 T&C (1996) stress computation. -! !/FLX3 T&C (1996) stress computation with cap. -! !/FLX4 Hwang (2011) stress computation (2nd order). -! !/FLX5 Direct use of stress from atmoshperic model. -! -! !/LN0 No linear input. ( Choose one ) -! -! !/ST0 No input and dissipation. ( Choose one ) -! !/ST1 WAM-3 input and dissipation. -! !/ST2 Tolman and Chalikov (1996) input and dissipation. -! !/ST3 WAM 4+ input and dissipation. -! !/ST4 Ardhuin et al. (2009, 2010) -! !/ST6 BYDB source terms after Babanin, Young, Donelan and Banner. -! -! !/NL0 No nonlinear interactions. ( Choose one ) -! !/NL1 Discrete interaction approximation. -! !/NL2 Exact nonlinear interactions. -! !/NL3 Generalized Multiple DIA. -! !/NL4 Two Scale Approximation -! !/NL5 Generalized Kinetic Equation. -! !/NLS Nonlinear HF smoother. -! -! !/BT0 No bottom friction. ( Choose one ) -! !/BT1 JONSWAP bottom friction. -! !/BT4 Bottom friction using movable bed roughness -! (Tolman 1994, Ardhuin & al. 2003) -! !/BT8 Muddy bed (Dalrymple & Liu). -! !/BT9 Muddy bed (Ng). -! -! !/IC1 Dissipation via interaction with ice according to simple -! methods: 1) uniform in frequency or -! !/IC2 2) Liu et al. model -! !/IC3 Dissipation via interaction with ice according to a -! viscoelastic sea ice model (Wang and Shen 2010). -! !/IC4 Dissipation via interaction with ice as a function of freq. -! (empirical/parametric methods) -! !/IC5 Dissipation via interaction with ice according to a -! viscoelastic sea ice model (Mosig et al. 2015). -! !/DB0 No depth-limited breaking. ( Choose one ) -! !/DB1 Battjes-Janssen depth-limited breaking. -! -! !/TR0 No triad interactions. ( Choose one ) -! !/TR1 Lumped Triad Approximation (LTA). -! -! !/BS0 No bottom scattering. ( Choose one ) -! !/BS1 Scattering term by Ardhuin and Magne (2007). -! -! !/MLIM Miche style limiter for shallow water and steepness. -! -! !/SEED 'Seeding' of lowest frequency for suffuciently strong -! winds. -! -! !/NNT Write output to file test_data_NNN.ww3 for NN training. -! -! !/S Enable subroutine tracing. -! !/T Enable general test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: DWAT, srce_imp_post, srce_imp_pre, & - srce_direct, GRAV, TPI, TPIINV, LPDLIB - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, DMIN, DTMAX, & - DTMIN, FACTI1, FACTI2, FACSD, FACHFA, FACP, & - XFC, XFLT, XREL, XFT, FXFM, FXPM, DDEN, & - FTE, FTF, FHMAX, ECOS, ESIN, IICEDISP, & - ICESCALES, IICESMOOTH - USE W3GDATMD, ONLY: FSSOURCE, optionCall - USE W3GDATMD, ONLY: B_JGS_NLEVEL, B_JGS_SOURCE_NONLINEAR + TAUA, TAUADIR, & +#endif + AS, USTAR, USTDIR, & + CX, CY, ICE, ICEH, ICEF, ICEDMAX, & + REFLEC, REFLED, DELX, DELY, DELA, TRNX, & + TRNY, BERG, FPI, DTDYN, FCUT, DTG, TAUWX, & + TAUWY, TAUOX, TAUOY, TAUWIX, TAUWIY, TAUWNX,& + TAUWNY, PHIAW, CHARN, TWS, PHIOC, WHITECAP, & + D50, PSIC, BEDFORM , PHIBBL, TAUBBL, TAUICE,& + PHICE, TAUOCX, TAUOCY, WNMEAN, DAIR, COEF) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | F. Ardhuin | + !/ | A. Roland | + !/ | M. Dutour Sikiric | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 06-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 14-Feb-2000 : Exact-NL added ( version 2.01 ) + !/ 04-May-2000 : Non-central integration ( version 2.03 ) + !/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 27-Nov-2002 : First version of VDIA and MDIA. ( version 3.01 ) + !/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) + !/ 24-Dec-2004 : Multiple model version. ( version 3.06 ) + !/ 23-Jun-2006 : Linear input added. ( version 3.09 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 04-Jul-2006 : Separation of stress computation. ( version 3.09 ) + !/ 16-Apr-2007 : Miche style limiter added. ( version 3.11 ) + !/ (J. H. Alves) + !/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) + !/ (J. H. Alves) + !/ 09-Oct-2007 : Adding WAM 4+ and SB1 options. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 19-Aug-2010 : Making treatment of 0 water depth ( version 3.14.6 ) + !/ consistent with the rest of the model. + !/ 31-Mar-2010 : Adding ice conc. and reflections ( version 3.14.4 ) + !/ 15-May-2010 : Adding transparencies ( version 3.14.4 ) + !/ 01-Jun-2011 : Movable bed bottom friction in BT4 ( version 4.01 ) + !/ 01-Jul-2011 : Energy and momentum flux, friction ( version 4.01 ) + !/ 24-Aug-2011 : Uses true depth for depth-induced ( version 4.04 ) + !/ 16-Sep-2011 : Initialization of TAUWAX, TAUWAY ( version 4.04 ) + !/ 1-Dec-2011 : Adding BYDRZ source term package ( version 4.04 ) + !/ ST6 and optional Hwang (2011) + !/ stresses FLX4. + !/ 14-Mar-2012 : Update of BT4, passing PSIC ( version 4.04 ) + !/ 13-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) + !/ from 3.15 (HLT). ( version 4.08 ) + !/ 28-Aug-2013 : Corrected MLIM application ( version 4.11 ) + !/ 10-Sep-2013 : Special treatment for IG band ( version 4.15 ) + !/ 14-Nov-2013 : Make orphaned pars in par lst local ( version 4.13 ) + !/ 17-Nov-2013 : Coupling fraction of ice-free ( version 4.13 ) + !/ surface to SIN and SDS. (S. Zieger) + !/ 01-Avr-2014 : Adding ice thickness and floe size ( version 4.18 ) + !/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) + !/ 27-Aug-2015 : Adding inputs to function W3SIS2 ( version 5.10 ) + !/ 13-Dec-2015 : Implicit integration of Sice (F.A.) ( version 5.10 ) + !/ 30-Jul-2017 : Adds TWS in interface ( version 6.04 ) + !/ 07-Jan-2018 : Allows variable ice scaling (F.A.) ( version 6.04 ) + !/ 01-Jan-2018 : Add implicit source term integration ( version 6.04) + !/ 01-Jan-2018 : within PDLIB (A. Roland, M. Dutour + !/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06) + !/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) + !/ 22-Mar-2021 : Add extra fields used in coupling ( version 7.13 ) + !/ 07-Jun-2021 : S_{nl5} GKE NL5 (Q. Liu) ( version 7.13 ) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Calculate and integrate source terms for a single grid point. + ! + ! 2. Method : + ! + ! Physics : see manual and corresponding subroutines. + ! + ! Numerics : + ! + ! Dynamic-implicit integration of the source terms based on + ! WW-II (Tolman 1992). The dynamic time step is calculated + ! given a maximum allowed change of spectral densities for + ! frequencies / wavenumbers below the usual cut-off. + ! The maximum change is given by the minimum of a parametric + ! and a relative change. The parametric change relates to a + ! PM type equilibrium range + ! + ! -1 (2pi)**4 1 + ! dN(k) = Xp alpha pi ---------- ------------ + ! max g**2 k**3 sigma + ! + ! 1 . + ! = FACP ------------ (1) + ! k**3 sigma . + ! + ! where + ! alpha = 0.62e-4 (set in W3GRID) + ! Xp fraction of PM shape (read in W3GRID) + ! FACP combined factor (set in W3GRID) + ! + ! The maximum relative change is given as + ! + ! / +- -+ \ . + ! dN(k) = Xr max | N(k) , max | Nx , Xfilt N(k) | | (2) + ! max \ +- max-+ / . + ! + ! where + ! Xr fraction of relative change (read in W3GRID) + ! Xfilt filter level (read in W3GRID) + ! Nx Maximum parametric change (1) + ! for largest wavenumber. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IX,IY Int. I Discrete grid point counters. + ! IMOD Int. I Model number. + ! SPEC R.A. I/O Spectrum (action) in 1-D form. + ! ALPHA R.A. I/O Nondimenional 1-D spectrum corresponding + ! to above full spectra (Phillip's const.). + ! Calculated separately for numerical + ! economy on vector machine (W3SPR2). + ! WN1 R.A. I Discrete wavenumbers. + ! CG1 R.A. I Id. group velocities. + ! D_INP Real. I Depth. Compared to DMIN to get DEPTH. + ! U10ABS Real. I Wind speed at reference height. + ! U10DIR Real. I Id. wind direction. + ! TAUA Real. I Magnitude of total atmospheric stress ( !/FLX5 ) + ! TAUADIR Real. I Direction of atmospheric stress ( !/FLX5 ) + ! AS Real. I Air-sea temp. difference. ( !/ST3 ) + ! USTAR Real. !/O Friction velocity. + ! USTDIR Real !/O Idem, direction. + ! CX-Y Real. I Current velocity components. ( !/BS1 ) + ! ICE Real I Sea ice concentration + ! ICEH Real I Sea ice thickness + ! ICEF Real I/O Sea ice maximum floe diameter (updated) + ! ICEDMAX Real I/O Sea ice maximum floe diameter + ! BERG Real I Iceberg damping coefficient ( !/BS1 ) + ! REFLEC R.A. I reflection coefficients ( !/BS1 ) + ! REFLED I.A. I reflection direction ( !/BS1 ) + ! TRNX-Y Real I Grid transparency in X and Y ( !/BS1 ) + ! DELX Real. I grid cell size in X direction ( !/BS1 ) + ! DELY Real. I grid cell size in Y direction ( !/BS1 ) + ! DELA Real. I grid cell area ( !/BS1 ) + ! FPI Real I/O Peak-input frequency. ( !/ST2 ) + ! WHITECAP R.A. O Whitecap statisics ( !/ST4 ) + ! DTDYN Real O Average dynamic time step. + ! FCUT Real O Cut-off frequency for tail. + ! DTG Real I Global time step. + ! D50 Real I Sand grain size ( !/BT4 ) + ! BEDFORM R.A. I/O Bedform parameters ( !/BT4 ) + ! PSIC Real I Critical Shields ( !/BT4 ) + ! PHIBBL Real O Energy flux to BBL ( !/BTx ) + ! TAUBBL R.A. O Momentum flux to BBL ( !/BTx ) + ! TAUICE R.A. O Momentum flux to sea ice ( !/ICx ) + ! PHICE Real O Energy flux to sea ice ( !/ICx ) + ! TAUOCX-YReal O Total ocean momentum components + ! WNMEAN Real O Mean wave number + ! DAIR Real I Air density + ! ---------------------------------------------------------------- + ! Note: several pars are set to I/O to avoid compiler warnings. + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SPRn Subr. W3SRCnMD Mean wave parameters for use in + ! source terms. + ! W3FLXn Subr. W3FLXnMD Flux/stress computation. + ! W3SLNn Subr. W3SLNnMD Linear input. + ! W3SINn Subr. W3SRCnMD Input source term. + ! W3SNLn Subr. W3SNLnMD Nonlinear interactions. + ! W3SNLS Subr. W3SNLSMD Nonlinear smoother. + ! W3SDSn Subr. W3SRCnMD Whitecapping source term + ! W3SBTn Subr. W3SBTnMD Bottom friction source term. + ! W3SDBn Subr. W3SBTnMD Depth induced breaking source term. + ! W3STRn Subr. W3STRnMD Triad interaction source term. + ! W3SBSn Subr. W3SBSnMD Bottom scattering source term. + ! W3REFn Subr. W3REFnMD Reflexions (shore, icebergs ...). + ! STRACE Subr. W3SERVMD Subroutine tracing (!/S) + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - No testing is performed on the status of the grid point. + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------------- + ! 1. Preparations + ! a Set maximum change and wavenumber arrays. + ! b Prepare dynamic time stepping. + ! c Compute mean parameters. ( W3SPRn ) + ! d Compute stresses (if posible). + ! e Prepare cut-off + ! f Test output for !/NNT option. + ! --start-dynamic-integration-loop--------------------------------- + ! 2. Calculate source terms + ! a Input. ( W3SLNx, W3SINn ) + ! b Nonlinear interactions. ( W3SNLn ) + ! c Dissipation ( W3SDSn ) + ! 1 as included in source terms ( W3SDSn ) + ! 2 optional dissipation due to different physics ( W3SWLn ) + ! d Bottom friction. ( W3SBTn ) + ! 3. Calculate cut-off frequencie(s) + ! 4. Summation of source terms and diagonal term and time step. + ! 5. Increment spectrum. + ! 6. Add tail + ! a Mean wave parameters and cut-off ( W3SPRn ) + ! b 'Seeding' of spectrum. ( !/SEED ) + ! c Add tail + ! 7. Check if integration complete. + ! --end-dynamic-integration-loop----------------------------------- + ! 8. Save integration data. + ! ----------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/FLX1 Wu (1980) stress computation. ( Choose one ) + ! !/FLX2 T&C (1996) stress computation. + ! !/FLX3 T&C (1996) stress computation with cap. + ! !/FLX4 Hwang (2011) stress computation (2nd order). + ! !/FLX5 Direct use of stress from atmoshperic model. + ! + ! !/LN0 No linear input. ( Choose one ) + ! + ! !/ST0 No input and dissipation. ( Choose one ) + ! !/ST1 WAM-3 input and dissipation. + ! !/ST2 Tolman and Chalikov (1996) input and dissipation. + ! !/ST3 WAM 4+ input and dissipation. + ! !/ST4 Ardhuin et al. (2009, 2010) + ! !/ST6 BYDB source terms after Babanin, Young, Donelan and Banner. + ! + ! !/NL0 No nonlinear interactions. ( Choose one ) + ! !/NL1 Discrete interaction approximation. + ! !/NL2 Exact nonlinear interactions. + ! !/NL3 Generalized Multiple DIA. + ! !/NL4 Two Scale Approximation + ! !/NL5 Generalized Kinetic Equation. + ! !/NLS Nonlinear HF smoother. + ! + ! !/BT0 No bottom friction. ( Choose one ) + ! !/BT1 JONSWAP bottom friction. + ! !/BT4 Bottom friction using movable bed roughness + ! (Tolman 1994, Ardhuin & al. 2003) + ! !/BT8 Muddy bed (Dalrymple & Liu). + ! !/BT9 Muddy bed (Ng). + ! + ! !/IC1 Dissipation via interaction with ice according to simple + ! methods: 1) uniform in frequency or + ! !/IC2 2) Liu et al. model + ! !/IC3 Dissipation via interaction with ice according to a + ! viscoelastic sea ice model (Wang and Shen 2010). + ! !/IC4 Dissipation via interaction with ice as a function of freq. + ! (empirical/parametric methods) + ! !/IC5 Dissipation via interaction with ice according to a + ! viscoelastic sea ice model (Mosig et al. 2015). + ! !/DB0 No depth-limited breaking. ( Choose one ) + ! !/DB1 Battjes-Janssen depth-limited breaking. + ! + ! !/TR0 No triad interactions. ( Choose one ) + ! !/TR1 Lumped Triad Approximation (LTA). + ! + ! !/BS0 No bottom scattering. ( Choose one ) + ! !/BS1 Scattering term by Ardhuin and Magne (2007). + ! + ! !/MLIM Miche style limiter for shallow water and steepness. + ! + ! !/SEED 'Seeding' of lowest frequency for suffuciently strong + ! winds. + ! + ! !/NNT Write output to file test_data_NNN.ww3 for NN training. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable general test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: DWAT, srce_imp_post, srce_imp_pre, & + srce_direct, GRAV, TPI, TPIINV, LPDLIB +#ifdef W3_T + USE CONSTANTS, ONLY: RADE +#endif + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, DMIN, DTMAX, & + DTMIN, FACTI1, FACTI2, FACSD, FACHFA, FACP, & + XFC, XFLT, XREL, XFT, FXFM, FXPM, DDEN, & + FTE, FTF, FHMAX, ECOS, ESIN, IICEDISP, & + ICESCALES, IICESMOOTH + USE W3GDATMD, ONLY: FSSOURCE, optionCall + USE W3GDATMD, ONLY: B_JGS_NLEVEL, B_JGS_SOURCE_NONLINEAR #ifdef W3_REF1 - USE W3GDATMD, ONLY: IOBP, IOBPD, IOBDP, GTYPE, UNGTYPE, REFPARS + USE W3GDATMD, ONLY: IOBP, IOBPD, IOBDP, GTYPE, UNGTYPE, REFPARS #endif - USE W3WDATMD, ONLY: TIME - USE W3ODATMD, ONLY: NDSE, NDST, IAPROC - USE W3IDATMD, ONLY: INFLAGS2, ICEP2 - USE W3DISPMD + USE W3WDATMD, ONLY: TIME + USE W3ODATMD, ONLY: NDSE, NDST, IAPROC + USE W3IDATMD, ONLY: INFLAGS2, ICEP2 + USE W3DISPMD #ifdef W3_NNT - USE W3ODATMD, ONLY: IAPROC, SCREEN, FNMPRE + USE W3ODATMD, ONLY: IAPROC, SCREEN, FNMPRE #endif #ifdef W3_FLD1 - USE W3FLD1MD, ONLY: W3FLD1 - USE W3GDATMD, ONLY: AALPHA + USE W3FLD1MD, ONLY: W3FLD1 + USE W3GDATMD, ONLY: AALPHA #endif #ifdef W3_FLD2 - USE W3FLD2MD, ONLY: W3FLD2 - USE W3GDATMD, ONLY: AALPHA + USE W3FLD2MD, ONLY: W3FLD2 + USE W3GDATMD, ONLY: AALPHA #endif #ifdef W3_FLX1 - USE W3FLX1MD + USE W3FLX1MD #endif #ifdef W3_FLX2 - USE W3FLX2MD + USE W3FLX2MD #endif #ifdef W3_FLX3 - USE W3FLX3MD + USE W3FLX3MD #endif #ifdef W3_FLX4 - USE W3FLX4MD + USE W3FLX4MD #endif #ifdef W3_FLX5 - USE W3FLX5MD + USE W3FLX5MD #endif #ifdef W3_LN1 - USE W3SLN1MD + USE W3SLN1MD #endif #ifdef W3_ST0 - USE W3SRC0MD + USE W3SRC0MD #endif #ifdef W3_ST1 - USE W3SRC1MD + USE W3SRC1MD #endif #ifdef W3_ST2 - USE W3SRC2MD - USE W3GDATMD, ONLY : ZWIND + USE W3SRC2MD + USE W3GDATMD, ONLY : ZWIND #endif #ifdef W3_ST3 - USE W3SRC3MD - USE W3GDATMD, ONLY : ZZWND, FFXFM, FFXPM + USE W3SRC3MD + USE W3GDATMD, ONLY : ZZWND, FFXFM, FFXPM #endif #ifdef W3_ST4 - USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 - USE W3GDATMD, ONLY : ZZWND, FFXFM, FFXPM, FFXFA + USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 + USE W3GDATMD, ONLY : ZZWND, FFXFM, FFXPM, FFXFA #endif #ifdef W3_ST6 - USE W3SRC6MD - USE W3SWLDMD, ONLY : W3SWL6 - USE W3GDATMD, ONLY : SWL6S6 + USE W3SRC6MD + USE W3SWLDMD, ONLY : W3SWL6 + USE W3GDATMD, ONLY : SWL6S6 #endif #ifdef W3_NL1 - USE W3SNL1MD + USE W3SNL1MD #endif #ifdef W3_NL2 - USE W3SNL2MD + USE W3SNL2MD #endif #ifdef W3_NL3 - USE W3SNL3MD + USE W3SNL3MD #endif #ifdef W3_NL4 - USE W3SNL4MD + USE W3SNL4MD #endif #ifdef W3_NL5 - USE W3SNL5MD - USE W3TIMEMD, ONLY: TICK21 + USE W3SNL5MD + USE W3TIMEMD, ONLY: TICK21 #endif #ifdef W3_NLS - USE W3SNLSMD + USE W3SNLSMD #endif #ifdef W3_BT1 - USE W3SBT1MD + USE W3SBT1MD #endif #ifdef W3_BT4 - USE W3SBT4MD + USE W3SBT4MD #endif #ifdef W3_BT8 - USE W3SBT8MD + USE W3SBT8MD #endif #ifdef W3_BT9 - USE W3SBT9MD + USE W3SBT9MD #endif #ifdef W3_IC1 - USE W3SIC1MD + USE W3SIC1MD #endif #ifdef W3_IC2 - USE W3SIC2MD + USE W3SIC2MD #endif #ifdef W3_IC3 - USE W3SIC3MD + USE W3SIC3MD #endif #ifdef W3_IC4 - USE W3SIC4MD + USE W3SIC4MD #endif #ifdef W3_IC5 - USE W3SIC5MD + USE W3SIC5MD #endif #ifdef W3_IS1 - USE W3SIS1MD + USE W3SIS1MD #endif #ifdef W3_IS2 - USE W3SIS2MD - USE W3GDATMD, ONLY : IS2PARS + USE W3SIS2MD + USE W3GDATMD, ONLY : IS2PARS #endif #ifdef W3_DB1 - USE W3SDB1MD + USE W3SDB1MD #endif #ifdef W3_TR1 - USE W3STR1MD + USE W3STR1MD #endif #ifdef W3_BS1 - USE W3SBS1MD + USE W3SBS1MD #endif #ifdef W3_REF1 - USE W3REF1MD + USE W3REF1MD #endif #ifdef W3_IG1 - USE W3GDATMD, ONLY : IGPARS + USE W3GDATMD, ONLY : IGPARS #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_NNT - USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: EXTCDE #endif #ifdef W3_UOST - USE W3UOSTMD, ONLY : UOST_SRCTRMCOMPUTE + USE W3UOSTMD, ONLY : UOST_SRCTRMCOMPUTE #endif #ifdef W3_PDLIB - USE PDLIB_W3PROFSMD, ONLY : B_JAC, ASPAR_JAC, ASPAR_DIAG_SOURCES, ASPAR_DIAG_ALL + USE PDLIB_W3PROFSMD, ONLY : B_JAC, ASPAR_JAC, ASPAR_DIAG_SOURCES, ASPAR_DIAG_ALL USE yowNodepool, ONLY: PDLIB_CCON, NPA, PDLIB_I_DIAG, PDLIB_JA, PDLIB_IA_P, PDLIB_SI USE W3GDATMD, ONLY: IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC USE W3WDATMD, ONLY: VA USE W3PARALL, ONLY: ONESIXTH, ZERO, THR, IMEM, LSLOC #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: srce_call, IT, ISEA, JSEA, IX, IY, IMOD - REAL, intent(in) :: SPECOLD(NSPEC), CLATSL - REAL, INTENT(OUT) :: VSIO(NSPEC), VDIO(NSPEC) - LOGICAL, INTENT(OUT) :: SHAVEIO - REAL, INTENT(IN) :: D_INP, U10ABS, & - U10DIR, AS, CX, CY, DTG, D50,PSIC, & - ICE, ICEH + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: srce_call, IT, ISEA, JSEA, IX, IY, IMOD + REAL, intent(in) :: SPECOLD(NSPEC), CLATSL + REAL, INTENT(OUT) :: VSIO(NSPEC), VDIO(NSPEC) + LOGICAL, INTENT(OUT) :: SHAVEIO + REAL, INTENT(IN) :: D_INP, U10ABS, & + U10DIR, AS, CX, CY, DTG, D50,PSIC, & + ICE, ICEH #ifdef W3_FLX5 - REAL, INTENT(IN) :: TAUA, TAUADIR -#endif - INTEGER, INTENT(IN) :: REFLED(6) - REAL, INTENT(IN) :: REFLEC(4), DELX, DELY, DELA, & - TRNX, TRNY, BERG, ICEDMAX, DAIR - REAL, INTENT(INOUT) :: WN1(NK), CG1(NK), & - SPEC(NSPEC), ALPHA(NK), USTAR, & - USTDIR, FPI, TAUOX, TAUOY, & - TAUWX, TAUWY, PHIAW, PHIOC, PHICE, & - CHARN, TWS, BEDFORM(3), PHIBBL, & - TAUBBL(2), TAUICE(2), WHITECAP(4), & - TAUWIX, TAUWIY, TAUWNX, TAUWNY, & - ICEF, TAUOCX, TAUOCY, WNMEAN - REAL, INTENT(OUT) :: DTDYN, FCUT - REAL, INTENT(IN) :: COEF -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IK, ITH, IS, IS0, NSTEPS, NKH, NKH1,& - IKS1, IS1, NSPECH, IDT, IERR, NKD, ISP - INTEGER :: IOBPIP, IOBPDIP, IOBDPIP + REAL, INTENT(IN) :: TAUA, TAUADIR +#endif + INTEGER, INTENT(IN) :: REFLED(6) + REAL, INTENT(IN) :: REFLEC(4), DELX, DELY, DELA, & + TRNX, TRNY, BERG, ICEDMAX, DAIR + REAL, INTENT(INOUT) :: WN1(NK), CG1(NK), & + SPEC(NSPEC), ALPHA(NK), USTAR, & + USTDIR, FPI, TAUOX, TAUOY, & + TAUWX, TAUWY, PHIAW, PHIOC, PHICE, & + CHARN, TWS, BEDFORM(3), PHIBBL, & + TAUBBL(2), TAUICE(2), WHITECAP(4), & + TAUWIX, TAUWIY, TAUWNX, TAUWNY, & + ICEF, TAUOCX, TAUOCY, WNMEAN + REAL, INTENT(OUT) :: DTDYN, FCUT + REAL, INTENT(IN) :: COEF + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IK, ITH, IS, IS0, NSTEPS, NKH, NKH1,& + IKS1, IS1, NSPECH, IDT, IERR, NKD, ISP + INTEGER :: IOBPIP, IOBPDIP, IOBDPIP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_NNT - INTEGER, SAVE :: NDSD = 89, NDSD2 = 88, J + INTEGER, SAVE :: NDSD = 89, NDSD2 = 88, J #endif #ifdef W3_NL5 - INTEGER :: QI5TSTART(2) - REAL :: QR5KURT - INTEGER, PARAMETER :: NL5_SELECT = 1 - REAL, PARAMETER :: NL5_OFFSET = 0. ! explicit dyn. -#endif - REAL :: DTTOT, FHIGH, DT, AFILT, DAMAX, AFAC,& - HDT, ZWND, FP, DEPTH, TAUSCX, TAUSCY, FHIGI -! Scaling factor for SIN, SDS, SNL - REAL :: ICESCALELN, ICESCALEIN, ICESCALENL, ICESCALEDS - REAL :: EMEAN, FMEAN, AMAX, CD, Z0, SCAT, & - SMOOTH_ICEDISP - REAL :: WN_R(NK), CG_ICE(NK),ALPHA_LIU(NK), ICECOEF2,& - R(NK) - DOUBLE PRECISION :: ATT, ISO + INTEGER :: QI5TSTART(2) + REAL :: QR5KURT + INTEGER, PARAMETER :: NL5_SELECT = 1 + REAL, PARAMETER :: NL5_OFFSET = 0. ! explicit dyn. +#endif + REAL :: DTTOT, FHIGH, DT, AFILT, DAMAX, AFAC,& + HDT, ZWND, FP, DEPTH, TAUSCX, TAUSCY, FHIGI + ! Scaling factor for SIN, SDS, SNL + REAL :: ICESCALELN, ICESCALEIN, ICESCALENL, ICESCALEDS + REAL :: EMEAN, FMEAN, AMAX, CD, Z0, SCAT, & + SMOOTH_ICEDISP + REAL :: WN_R(NK), CG_ICE(NK),ALPHA_LIU(NK), ICECOEF2,& + R(NK) + DOUBLE PRECISION :: ATT, ISO #ifdef W3_ST1 - REAL :: FH1, FH2 + REAL :: FH1, FH2 #endif #ifdef W3_ST2 - REAL :: FHTRAN, DFH, FACDIA, FACPAR + REAL :: FHTRAN, DFH, FACDIA, FACPAR #endif #ifdef W3_ST3 - REAL :: FMEANS, FH1, FH2 + REAL :: FMEANS, FH1, FH2 #endif #ifdef W3_ST4 - REAL :: FMEANS, FH1, FH2, FAGE, DLWMEAN + REAL :: FMEANS, FH1, FH2, FAGE, DLWMEAN #endif - REAL :: QCERR = 0. !/XNL2 and !/NNT + REAL :: QCERR = 0. !/XNL2 and !/NNT #ifdef W3_SEED - REAL :: UC, SLEV + REAL :: UC, SLEV #endif #ifdef W3_MLIM - REAL :: HM, EM + REAL :: HM, EM #endif #ifdef W3_NNT - REAL :: FACNN + REAL :: FACNN #endif #ifdef W3_T - REAL :: DTRAW -#endif - REAL :: EBAND, DIFF, EFINISH, HSTOT, PHINL, & - FMEAN1, FMEANWS, MWXINIT, MWYINIT, & - FACTOR, FACTOR2, DRAT, TAUWAX, TAUWAY, & - MWXFINISH, MWYFINISH, A1BAND, B1BAND, & - COSI(2) - REAL :: SPECINIT(NSPEC), SPEC2(NSPEC), FRLOCAL, JAC2 - REAL :: DAM (NSPEC), DAM2(NSPEC), WN2 (NSPEC), & - VSLN(NSPEC), & - VSIN(NSPEC), VDIN(NSPEC), & - VSNL(NSPEC), VDNL(NSPEC), & - VSDS(NSPEC), VDDS(NSPEC), & + REAL :: DTRAW +#endif + REAL :: EBAND, DIFF, EFINISH, HSTOT, PHINL, & + FMEAN1, FMEANWS, MWXINIT, MWYINIT, & + FACTOR, FACTOR2, DRAT, TAUWAX, TAUWAY, & + MWXFINISH, MWYFINISH, A1BAND, B1BAND, & + COSI(2) + REAL :: SPECINIT(NSPEC), SPEC2(NSPEC), FRLOCAL, JAC2 + REAL :: DAM (NSPEC), DAM2(NSPEC), WN2 (NSPEC), & + VSLN(NSPEC), & + VSIN(NSPEC), VDIN(NSPEC), & + VSNL(NSPEC), VDNL(NSPEC), & + VSDS(NSPEC), VDDS(NSPEC), & #ifdef W3_ST6 - VSWL(NSPEC), VDWL(NSPEC), & + VSWL(NSPEC), VDWL(NSPEC), & #endif - VSBT(NSPEC), VDBT(NSPEC), & + VSBT(NSPEC), VDBT(NSPEC), & #ifdef W3_IC1 - VSIC(NSPEC), VDIC(NSPEC), & + VSIC(NSPEC), VDIC(NSPEC), & #endif #ifdef W3_IC2 - VSIC(NSPEC), VDIC(NSPEC), & + VSIC(NSPEC), VDIC(NSPEC), & #endif #ifdef W3_IC3 - VSIC(NSPEC), VDIC(NSPEC), & + VSIC(NSPEC), VDIC(NSPEC), & #endif #ifdef W3_IC4 - VSIC(NSPEC), VDIC(NSPEC), & + VSIC(NSPEC), VDIC(NSPEC), & #endif #ifdef W3_IC5 - VSIC(NSPEC), VDIC(NSPEC), & + VSIC(NSPEC), VDIC(NSPEC), & #endif #ifdef W3_DB1 - VSDB(NSPEC), VDDB(NSPEC), & + VSDB(NSPEC), VDDB(NSPEC), & #endif #ifdef W3_TR1 - VSTR(NSPEC), VDTR(NSPEC), & + VSTR(NSPEC), VDTR(NSPEC), & #endif #ifdef W3_BS1 - VSBS(NSPEC), VDBS(NSPEC), & + VSBS(NSPEC), VDBS(NSPEC), & #endif #ifdef W3_REF1 - VREF(NSPEC), & + VREF(NSPEC), & #endif #ifdef W3_IS1 - VSIR(NSPEC), VDIR(NSPEC), & + VSIR(NSPEC), VDIR(NSPEC), & #endif #ifdef W3_IS2 - VSIR(NSPEC), VDIR(NSPEC),VDIR2(NSPEC), & + VSIR(NSPEC), VDIR(NSPEC),VDIR2(NSPEC), & #endif #ifdef W3_UOST - VSUO(NSPEC), VDUO(NSPEC), & + VSUO(NSPEC), VDUO(NSPEC), & #endif - VS(NSPEC), VD(NSPEC), EB(NK) + VS(NSPEC), VD(NSPEC), EB(NK) #ifdef W3_ST3 - LOGICAL :: LLWS(NSPEC) + LOGICAL :: LLWS(NSPEC) #endif #ifdef W3_ST4 - LOGICAL :: LLWS(NSPEC) - REAL :: BRLAMBDA(NSPEC) + LOGICAL :: LLWS(NSPEC) + REAL :: BRLAMBDA(NSPEC) #endif #ifdef W3_IS2 - DOUBLE PRECISION :: SCATSPEC(NTH) + DOUBLE PRECISION :: SCATSPEC(NTH) #endif - REAL :: FOUT(NK,NTH), SOUT(NK,NTH), DOUT(NK,NTH) - REAL, SAVE :: TAUNUX, TAUNUY + REAL :: FOUT(NK,NTH), SOUT(NK,NTH), DOUT(NK,NTH) + REAL, SAVE :: TAUNUX, TAUNUY #ifdef W3_OMPG -!$omp threadprivate( TAUNUX, TAUNUY) + !$omp threadprivate( TAUNUX, TAUNUY) #endif - LOGICAL, SAVE :: FLTEST = .FALSE., FLAGNN = .TRUE. + LOGICAL, SAVE :: FLTEST = .FALSE., FLAGNN = .TRUE. #ifdef W3_OMPG -!$omp threadprivate( FLTEST, FLAGNN ) + !$omp threadprivate( FLTEST, FLAGNN ) #endif - LOGICAL :: SHAVE - LOGICAL :: LBREAK - LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: SHAVE + LOGICAL :: LBREAK + LOGICAL, SAVE :: FIRST = .TRUE. #ifdef W3_OMPG -!$omp threadprivate( FIRST ) + !$omp threadprivate( FIRST ) #endif - LOGICAL :: PrintDeltaSmDA - REAL :: eInc1, eInc2, eVS, eVD, JAC - REAL :: DeltaSRC(NSPEC) - REAL, PARAMETER :: DTMINTOT = 0.01 - LOGICAL :: LNEWLIMITER = .FALSE. + LOGICAL :: PrintDeltaSmDA + REAL :: eInc1, eInc2, eVS, eVD, JAC + REAL :: DeltaSRC(NSPEC) + REAL, PARAMETER :: DTMINTOT = 0.01 + LOGICAL :: LNEWLIMITER = .FALSE. #ifdef W3_PDLIB - REAL :: PreVS, FAK, DVS, SIDT, FAKS, MAXDAC + REAL :: PreVS, FAK, DVS, SIDT, FAKS, MAXDAC #endif #ifdef W3_NNT - CHARACTER(LEN=17), SAVE :: FNAME = 'test_data_nnn.ww3' + CHARACTER(LEN=17), SAVE :: FNAME = 'test_data_nnn.ww3' #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SRCE') + CALL STRACE (IENT, 'W3SRCE') #endif -! + ! #ifdef W3_T - FLTEST = .TRUE. + FLTEST = .TRUE. #endif -! - VDIO = 0. - VSIO = 0. - DEPTH = MAX ( DMIN , D_INP ) + ! + VDIO = 0. + VSIO = 0. + DEPTH = MAX ( DMIN , D_INP ) - IKS1 = 1 - ICESCALELN = MAX(0.,MIN(1.,1.-ICE*ICESCALES(1))) - ICESCALEIN = MAX(0.,MIN(1.,1.-ICE*ICESCALES(2))) - ICESCALENL = MAX(0.,MIN(1.,1.-ICE*ICESCALES(3))) - ICESCALEDS = MAX(0.,MIN(1.,1.-ICE*ICESCALES(4))) + IKS1 = 1 + ICESCALELN = MAX(0.,MIN(1.,1.-ICE*ICESCALES(1))) + ICESCALEIN = MAX(0.,MIN(1.,1.-ICE*ICESCALES(2))) + ICESCALENL = MAX(0.,MIN(1.,1.-ICE*ICESCALES(3))) + ICESCALEDS = MAX(0.,MIN(1.,1.-ICE*ICESCALES(4))) #ifdef W3_IG1 -! -! Does not integrate source terms for IG band if IGPARS(12) = 0. -! - IF (NINT(IGPARS(12)).EQ.0) IKS1 = NINT(IGPARS(5)) + ! + ! Does not integrate source terms for IG band if IGPARS(12) = 0. + ! + IF (NINT(IGPARS(12)).EQ.0) IKS1 = NINT(IGPARS(5)) #endif - IS1=(IKS1-1)*NTH+1 -! + IS1=(IKS1-1)*NTH+1 + ! #ifdef W3_LN0 - VSLN = 0. + VSLN = 0. #endif #ifdef W3_LN1 - VSLN = 0. + VSLN = 0. #endif #ifdef W3_SEED - VSLN = 0. + VSLN = 0. #endif #ifdef W3_ST0 - VSIN = 0. - VDIN = 0. + VSIN = 0. + VDIN = 0. #endif #ifdef W3_ST3 - VSIN = 0. - VDIN = 0. + VSIN = 0. + VDIN = 0. #endif #ifdef W3_ST4 - VSIN = 0. - VDIN = 0. + VSIN = 0. + VDIN = 0. #endif #ifdef W3_NL0 - VSNL = 0. - VDNL = 0. + VSNL = 0. + VDNL = 0. #endif #ifdef W3_NL1 - VSNL = 0. - VDNL = 0. + VSNL = 0. + VDNL = 0. #endif #ifdef W3_TR1 - VSTR = 0. - VDTR = 0. + VSTR = 0. + VDTR = 0. #endif #ifdef W3_ST0 - VSDS = 0. - VDDS = 0. + VSDS = 0. + VDDS = 0. #endif #ifdef W3_ST4 - VSDS = 0. - VDDS = 0. + VSDS = 0. + VDDS = 0. #endif - VSBT = 0. - VDBT = 0. + VSBT = 0. + VDBT = 0. #ifdef W3_DB1 - VSDB = 0. - VDDB = 0. + VSDB = 0. + VDDB = 0. #endif #ifdef W3_IC1 - VSIC = 0. - VDIC = 0. + VSIC = 0. + VDIC = 0. #endif #ifdef W3_IC2 - VSIC = 0. - VDIC = 0. + VSIC = 0. + VDIC = 0. #endif #ifdef W3_IC3 - VSIC = 0. - VDIC = 0. + VSIC = 0. + VDIC = 0. #endif #ifdef W3_IC4 - VSIC = 0. - VDIC = 0. + VSIC = 0. + VDIC = 0. #endif #ifdef W3_UOST - VSUO = 0. - VDUO = 0. + VSUO = 0. + VDUO = 0. #endif #ifdef W3_IC5 - VSIC = 0. - VDIC = 0. + VSIC = 0. + VDIC = 0. #endif -! + ! #ifdef W3_IS1 - VSIR = 0. - VDIR = 0. + VSIR = 0. + VDIR = 0. #endif #ifdef W3_IS2 - VSIR = 0. - VDIR = 0. - VDIR2= 0. + VSIR = 0. + VDIR = 0. + VDIR2= 0. #endif -! + ! #ifdef W3_ST6 - VSWL = 0. - VDWL = 0. + VSWL = 0. + VDWL = 0. #endif -! + ! #ifdef W3_ST0 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST1 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST2 - ZWND = ZWIND + ZWND = ZWIND #endif #ifdef W3_ST4 - ZWND = ZZWND + ZWND = ZZWND #endif #ifdef W3_ST6 - ZWND = 10. + ZWND = 10. #endif -! - DRAT = DAIR / DWAT + ! + DRAT = DAIR / DWAT #ifdef W3_T - WRITE (NDST,9000) - WRITE (NDST,9001) DEPTH, U10ABS, U10DIR*RADE -#endif -! -! 1. Preparations --------------------------------------------------- * -! -! 1.a Set maximum change and wavenumber arrays. -! -!XP = 0.15 -!FACP = XP / PI * 0.62E-3 * TPI**4 / GRAV**2 -! - DO IK=1, NK - DAM(1+(IK-1)*NTH) = FACP / ( SIG(IK) * WN1(IK)**3 ) - WN2(1+(IK-1)*NTH) = WN1(IK) - END DO -! - DO IK=1, NK - IS0 = (IK-1)*NTH - DO ITH=2, NTH - DAM(ITH+IS0) = DAM(1+IS0) - WN2(ITH+IS0) = WN2(1+IS0) - END DO - END DO -! -! 1.b Prepare dynamic time stepping -! - DTDYN = 0. - DTTOT = 0. - NSTEPS = 0 - PHIAW = 0. - CHARN = 0. - TWS = 0. - PHINL = 0. - PHIBBL = 0. - TAUWIX = 0. - TAUWIY = 0. - TAUWNX = 0. - TAUWNY = 0. - TAUWAX = 0. - TAUWAY = 0. - TAUSCX = 0. - TAUSCY = 0. - TAUBBL = 0. - TAUICE = 0. - PHICE = 0. - TAUOCX = 0. - TAUOCY = 0. - WNMEAN = 0. + WRITE (NDST,9000) + WRITE (NDST,9001) DEPTH, U10ABS, U10DIR*RADE +#endif + ! + ! 1. Preparations --------------------------------------------------- * + ! + ! 1.a Set maximum change and wavenumber arrays. + ! + !XP = 0.15 + !FACP = XP / PI * 0.62E-3 * TPI**4 / GRAV**2 + ! + DO IK=1, NK + DAM(1+(IK-1)*NTH) = FACP / ( SIG(IK) * WN1(IK)**3 ) + WN2(1+(IK-1)*NTH) = WN1(IK) + END DO + ! + DO IK=1, NK + IS0 = (IK-1)*NTH + DO ITH=2, NTH + DAM(ITH+IS0) = DAM(1+IS0) + WN2(ITH+IS0) = WN2(1+IS0) + END DO + END DO + ! + ! 1.b Prepare dynamic time stepping + ! + DTDYN = 0. + DTTOT = 0. + NSTEPS = 0 + PHIAW = 0. + CHARN = 0. + TWS = 0. + PHINL = 0. + PHIBBL = 0. + TAUWIX = 0. + TAUWIY = 0. + TAUWNX = 0. + TAUWNY = 0. + TAUWAX = 0. + TAUWAY = 0. + TAUSCX = 0. + TAUSCY = 0. + TAUBBL = 0. + TAUICE = 0. + PHICE = 0. + TAUOCX = 0. + TAUOCY = 0. + WNMEAN = 0. -! -! TIME is updated in W3WAVEMD prior to the call of W3SCRE, we should -! move 'TIME' one time step backward (QL) + ! + ! TIME is updated in W3WAVEMD prior to the call of W3SCRE, we should + ! move 'TIME' one time step backward (QL) #ifdef W3_NL5 - QI5TSTART = TIME - CALL TICK21 (QI5TSTART, -1.0 * DTG) + QI5TSTART = TIME + CALL TICK21 (QI5TSTART, -1.0 * DTG) #endif -! + ! #ifdef W3_DEBUGSRC - IF (IX .eq. DEBUG_NODE) THEN - WRITE(740+IAPROC,*) 'W3SRCE start sum(SPEC)=', sum(SPEC) - WRITE(740+IAPROC,*) 'W3SRCE start sum(SPECOLD)=', sum(SPECOLD) - WRITE(740+IAPROC,*) 'W3SRCE start sum(SPECINIT)=', sum(SPECINIT) - WRITE(740+IAPROC,*) 'W3SRCE start sum(VSIO)=', sum(VSIO) - WRITE(740+IAPROC,*) 'W3SRCE start sum(VDIO)=', sum(VDIO) - WRITE(740+IAPROC,*) 'W3SRCE start USTAR=', USTAR - END IF + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) 'W3SRCE start sum(SPEC)=', sum(SPEC) + WRITE(740+IAPROC,*) 'W3SRCE start sum(SPECOLD)=', sum(SPECOLD) + WRITE(740+IAPROC,*) 'W3SRCE start sum(SPECINIT)=', sum(SPECINIT) + WRITE(740+IAPROC,*) 'W3SRCE start sum(VSIO)=', sum(VSIO) + WRITE(740+IAPROC,*) 'W3SRCE start sum(VDIO)=', sum(VDIO) + WRITE(740+IAPROC,*) 'W3SRCE start USTAR=', USTAR + END IF #endif #ifdef W3_ST4 - DLWMEAN= 0. - BRLAMBDA(:)=0. - WHITECAP(:)=0. + DLWMEAN= 0. + BRLAMBDA(:)=0. + WHITECAP(:)=0. #endif -! -! 1.c Set mean parameters -! + ! + ! 1.c Set mean parameters + ! #ifdef W3_ST0 - CALL W3SPR0 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) - FP = 0.85 * FMEAN + CALL W3SPR0 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN #endif #ifdef W3_ST1 - CALL W3SPR1 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) - FP = 0.85 * FMEAN + CALL W3SPR1 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN #endif #ifdef W3_ST2 - CALL W3SPR2 (SPEC, CG1, WN1, DEPTH, FPI, U10ABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SPR2 (SPEC, CG1, WN1, DEPTH, FPI, U10ABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - TAUWX=0. - TAUWY=0. - IF ( IT .eq. 0 ) THEN - LLWS(:) = .TRUE. - USTAR=0. - USTDIR=0. - CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & - AMAX, U10ABS, U10DIR, USTAR, USTDIR, & - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) - ELSE - CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & - AMAX, U10ABS, U10DIR, USTAR, USTDIR, & - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) - CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & - U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & - ICE, VSIN, VDIN, LLWS, IX, IY ) - END IF + TAUWX=0. + TAUWY=0. + IF ( IT .eq. 0 ) THEN + LLWS(:) = .TRUE. + USTAR=0. + USTDIR=0. + CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & + AMAX, U10ABS, U10DIR, USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) + ELSE CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & - AMAX, U10ABS, U10DIR, USTAR, USTDIR, & - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) - TWS = 1./FMEANWS + AMAX, U10ABS, U10DIR, USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) + CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + ICE, VSIN, VDIN, LLWS, IX, IY ) + END IF + CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & + AMAX, U10ABS, U10DIR, USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) + TWS = 1./FMEANWS #endif #ifdef W3_ST4 - TAUWX=0. - TAUWY=0. - IF ( IT .eq. 0 ) THEN - LLWS(:) = .TRUE. - USTAR=0. - USTDIR=0. - ELSE - CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN, & - AMAX, U10ABS, U10DIR, & + TAUWX=0. + TAUWY=0. + IF ( IT .eq. 0 ) THEN + LLWS(:) = .TRUE. + USTAR=0. + USTDIR=0. + ELSE + CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN, & + AMAX, U10ABS, U10DIR, & #ifdef W3_FLX5 - TAUA, TAUADIR, DAIR, & + TAUA, TAUADIR, DAIR, & #endif - USTAR, USTDIR, & - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) + USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) #endif #ifdef W3_DEBUGSRC #ifdef W3_ST4 - IF (IX == DEBUG_NODE) THEN - WRITE(740+IAPROC,*) '1: out value USTAR=', USTAR, ' USTDIR=', USTDIR - WRITE(740+IAPROC,*) '1: out value EMEAN=', EMEAN, ' FMEAN=', FMEAN - WRITE(740+IAPROC,*) '1: out value FMEAN1=', FMEAN1, ' WNMEAN=', WNMEAN - WRITE(740+IAPROC,*) '1: out value CD=', CD, ' Z0=', Z0 - WRITE(740+IAPROC,*) '1: out value ALPHA=', CHARN, ' FMEANWS=', FMEANWS - END IF + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '1: out value USTAR=', USTAR, ' USTDIR=', USTDIR + WRITE(740+IAPROC,*) '1: out value EMEAN=', EMEAN, ' FMEAN=', FMEAN + WRITE(740+IAPROC,*) '1: out value FMEAN1=', FMEAN1, ' WNMEAN=', WNMEAN + WRITE(740+IAPROC,*) '1: out value CD=', CD, ' Z0=', Z0 + WRITE(740+IAPROC,*) '1: out value ALPHA=', CHARN, ' FMEANWS=', FMEANWS + END IF #endif #endif #ifdef W3_ST4 - CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & - U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & - VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) - END IF + CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) + END IF #endif #ifdef W3_DEBUGSRC #ifdef W3_ST4 - IF (IX == DEBUG_NODE) THEN - WRITE(740+IAPROC,*) '1: U10DIR=', U10DIR, ' Z0=', Z0, ' CHARN=', CHARN - WRITE(740+IAPROC,*) '1: USTAR=', USTAR, ' U10ABS=', U10ABS, ' AS=', AS - WRITE(740+IAPROC,*) '1: DRAT=', DRAT - WRITE(740+IAPROC,*) '1: TAUWX=', TAUWX, ' TAUWY=', TAUWY - WRITE(740+IAPROC,*) '1: TAUWAX=', TAUWAX, ' TAUWAY=', TAUWAY - WRITE(740+IAPROC,*) '1: min(CG1)=', minval(CG1), ' max(CG1)=', maxval(CG1) - WRITE(740+IAPROC,*) '1: W3SIN4(min/max/sum)VSIN=', minval(VSIN), maxval(VSIN), sum(VSIN) - WRITE(740+IAPROC,*) '1: W3SIN4(min/max/sum)VDIN=', minval(VDIN), maxval(VDIN), sum(VDIN) - END IF + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '1: U10DIR=', U10DIR, ' Z0=', Z0, ' CHARN=', CHARN + WRITE(740+IAPROC,*) '1: USTAR=', USTAR, ' U10ABS=', U10ABS, ' AS=', AS + WRITE(740+IAPROC,*) '1: DRAT=', DRAT + WRITE(740+IAPROC,*) '1: TAUWX=', TAUWX, ' TAUWY=', TAUWY + WRITE(740+IAPROC,*) '1: TAUWAX=', TAUWAX, ' TAUWAY=', TAUWAY + WRITE(740+IAPROC,*) '1: min(CG1)=', minval(CG1), ' max(CG1)=', maxval(CG1) + WRITE(740+IAPROC,*) '1: W3SIN4(min/max/sum)VSIN=', minval(VSIN), maxval(VSIN), sum(VSIN) + WRITE(740+IAPROC,*) '1: W3SIN4(min/max/sum)VDIN=', minval(VDIN), maxval(VDIN), sum(VDIN) + END IF #endif #endif #ifdef W3_ST4 - CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN, & - AMAX, U10ABS, U10DIR, & + CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN, & + AMAX, U10ABS, U10DIR, & #ifdef W3_FLX5 - TAUA, TAUADIR, DAIR, & + TAUA, TAUADIR, DAIR, & #endif - USTAR, USTDIR, & - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) - TWS = 1./FMEANWS + USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) + TWS = 1./FMEANWS #endif #ifdef W3_ST6 - CALL W3SPR6 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX, FP) -#endif -! -! 1.c2 Stores the initial data -! - SPECINIT = SPEC -! -! 1.d Stresses -! + CALL W3SPR6 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX, FP) +#endif + ! + ! 1.c2 Stores the initial data + ! + SPECINIT = SPEC + ! + ! 1.d Stresses + ! #ifdef W3_FLX1 - CALL W3FLX1 ( ZWND, U10ABS, U10DIR, USTAR, USTDIR, Z0, CD ) + CALL W3FLX1 ( ZWND, U10ABS, U10DIR, USTAR, USTDIR, Z0, CD ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & - USTAR, USTDIR, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & + USTAR, USTDIR, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & - USTAR, USTDIR, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & + USTAR, USTDIR, Z0, CD ) #endif #ifdef W3_FLX4 - CALL W3FLX4 ( ZWND, U10ABS, U10DIR, USTAR, USTDIR, Z0, CD ) + CALL W3FLX4 ( ZWND, U10ABS, U10DIR, USTAR, USTDIR, Z0, CD ) #endif #ifdef W3_FLX5 - CALL W3FLX5 ( ZWND, U10ABS, U10DIR, TAUA, TAUADIR, DAIR, & - USTAR, USTDIR, Z0, CD, CHARN ) + CALL W3FLX5 ( ZWND, U10ABS, U10DIR, TAUA, TAUADIR, DAIR, & + USTAR, USTDIR, Z0, CD, CHARN ) #endif -! -! 1.e Prepare cut-off beyond which the tail is imposed with a power law -! + ! + ! 1.e Prepare cut-off beyond which the tail is imposed with a power law + ! #ifdef W3_ST0 - FHIGH = SIG(NK) + FHIGH = SIG(NK) #endif #ifdef W3_ST1 - FH1 = FXFM * FMEAN - FH2 = FXPM / USTAR - FHIGH = MAX ( FH1 , FH2 ) - IF (FLTEST) WRITE (NDST,9004) FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV + FH1 = FXFM * FMEAN + FH2 = FXPM / USTAR + FHIGH = MAX ( FH1 , FH2 ) + IF (FLTEST) WRITE (NDST,9004) FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV #endif #ifdef W3_ST2 - FHIGH = XFC * FPI + FHIGH = XFC * FPI #endif #ifdef W3_ST3 - FHIGH = MAX(FFXFM * MAX(FMEAN,FMEANWS),FFXPM / USTAR) + FHIGH = MAX(FFXFM * MAX(FMEAN,FMEANWS),FFXPM / USTAR) #endif #ifdef W3_ST4 -! Introduces a Long & Resio (JGR2007) type dependance on wave age + ! Introduces a Long & Resio (JGR2007) type dependance on wave age #endif -! !/ST4 FAGE = FFXFA*TANH(0.3*U10ABS*FMEANWS*TPI/GRAV) + ! !/ST4 FAGE = FFXFA*TANH(0.3*U10ABS*FMEANWS*TPI/GRAV) #ifdef W3_ST4 - FAGE = 0. - FHIGH = MAX( (FFXFM + FAGE ) * MAX(FMEAN1,FMEANWS), FFXPM / USTAR) - FHIGI = FFXFA * FMEAN1 + FAGE = 0. + FHIGH = MAX( (FFXFM + FAGE ) * MAX(FMEAN1,FMEANWS), FFXPM / USTAR) + FHIGI = FFXFA * FMEAN1 #endif #ifdef W3_ST6 - IF (FXFM .LE. 0) THEN - FHIGH = SIG(NK) - ELSE - FHIGH = MAX (FXFM * FMEAN, FXPM / USTAR) - ENDIF + IF (FXFM .LE. 0) THEN + FHIGH = SIG(NK) + ELSE + FHIGH = MAX (FXFM * FMEAN, FXPM / USTAR) + ENDIF #endif -! -! 1.f Prepare output file for !/NNT option -! + ! + ! 1.f Prepare output file for !/NNT option + ! #ifdef W3_NNT - IF ( IT .EQ. 0 ) THEN - J = LEN_TRIM(FNMPRE) - WRITE (FNAME(11:13),'(I3.3)') IAPROC - OPEN (NDSD,FILE=FNMPRE(:J)//FNAME,form='UNFORMATTED', convert=file_endian, & - ERR=800,IOSTAT=IERR) - WRITE (NDSD,ERR=801,IOSTAT=IERR) NK, NTH - WRITE (NDSD,ERR=801,IOSTAT=IERR) SIG(1:NK) * TPIINV - OPEN (NDSD2,FILE=FNMPRE(:J)//'time.ww3', & - FORM='FORMATTED',ERR=800,IOSTAT=IERR) - END IF -#endif -! -! ... Branch point dynamic integration - - - - - - - - - - - - - - - - -! - DO -! - NSTEPS = NSTEPS + 1 -! + IF ( IT .EQ. 0 ) THEN + J = LEN_TRIM(FNMPRE) + WRITE (FNAME(11:13),'(I3.3)') IAPROC + OPEN (NDSD,FILE=FNMPRE(:J)//FNAME,form='UNFORMATTED', convert=file_endian, & + ERR=800,IOSTAT=IERR) + WRITE (NDSD,ERR=801,IOSTAT=IERR) NK, NTH + WRITE (NDSD,ERR=801,IOSTAT=IERR) SIG(1:NK) * TPIINV + OPEN (NDSD2,FILE=FNMPRE(:J)//'time.ww3', & + FORM='FORMATTED',ERR=800,IOSTAT=IERR) + END IF +#endif + ! + ! ... Branch point dynamic integration - - - - - - - - - - - - - - - - + ! + DO + ! + NSTEPS = NSTEPS + 1 + ! #ifdef W3_T - WRITE (NDST,9020) NSTEPS, DTTOT + WRITE (NDST,9020) NSTEPS, DTTOT #endif -! -! 2. Calculate source terms ----------------------------------------- * -! -! 2.a Input. -! + ! + ! 2. Calculate source terms ----------------------------------------- * + ! + ! 2.a Input. + ! #ifdef W3_LN1 - CALL W3SLN1 ( WN1, FHIGH, USTAR, U10DIR , VSLN ) + CALL W3SLN1 ( WN1, FHIGH, USTAR, U10DIR , VSLN ) #endif -! + ! #ifdef W3_ST1 - CALL W3SIN1 ( SPEC, WN2, USTAR, U10DIR , VSIN, VDIN ) + CALL W3SIN1 ( SPEC, WN2, USTAR, U10DIR , VSIN, VDIN ) #endif #ifdef W3_ST2 - CALL W3SIN2 ( SPEC, CG1, WN2, U10ABS, U10DIR, CD, Z0, & - FPI, VSIN, VDIN ) + CALL W3SIN2 ( SPEC, CG1, WN2, U10ABS, U10DIR, CD, Z0, & + FPI, VSIN, VDIN ) #endif #ifdef W3_ST3 - CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & - U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & - ICE, VSIN, VDIN, LLWS, IX, IY ) + CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + ICE, VSIN, VDIN, LLWS, IX, IY ) #endif #ifdef W3_ST4 - CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & - U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & - VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) + CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) #endif #ifdef W3_DEBUGSRC #ifdef W3_ST4 - IF (IX == DEBUG_NODE) THEN - WRITE(740+IAPROC,*) '2 : W3SIN4(min/max/sum)VSIN=', minval(VSIN), maxval(VSIN), sum(VSIN) - WRITE(740+IAPROC,*) '2 : W3SIN4(min/max/sum)VDIN=', minval(VDIN), maxval(VDIN), sum(VDIN) - END IF + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '2 : W3SIN4(min/max/sum)VSIN=', minval(VSIN), maxval(VSIN), sum(VSIN) + WRITE(740+IAPROC,*) '2 : W3SIN4(min/max/sum)VDIN=', minval(VDIN), maxval(VDIN), sum(VDIN) + END IF #endif #endif #ifdef W3_ST6 - CALL W3SIN6 ( SPEC, CG1, WN2, U10ABS, USTAR, USTDIR, CD, DAIR, & - TAUWX, TAUWY, TAUWAX, TAUWAY, VSIN, VDIN ) + CALL W3SIN6 ( SPEC, CG1, WN2, U10ABS, USTAR, USTDIR, CD, DAIR, & + TAUWX, TAUWY, TAUWAX, TAUWAY, VSIN, VDIN ) #endif -! -! 2.b Nonlinear interactions. -! + ! + ! 2.b Nonlinear interactions. + ! #ifdef W3_NL1 - CALL W3SNL1 ( SPEC, CG1, WNMEAN*DEPTH, VSNL, VDNL ) + CALL W3SNL1 ( SPEC, CG1, WNMEAN*DEPTH, VSNL, VDNL ) #endif #ifdef W3_NL2 - CALL W3SNL2 ( SPEC, CG1, DEPTH, VSNL, VDNL ) + CALL W3SNL2 ( SPEC, CG1, DEPTH, VSNL, VDNL ) #endif #ifdef W3_NL3 - CALL W3SNL3 ( SPEC, CG1, WN1, DEPTH, VSNL, VDNL ) + CALL W3SNL3 ( SPEC, CG1, WN1, DEPTH, VSNL, VDNL ) #endif #ifdef W3_NL4 - CALL W3SNL4 ( SPEC, CG1, WN1, DEPTH, VSNL, VDNL ) + CALL W3SNL4 ( SPEC, CG1, WN1, DEPTH, VSNL, VDNL ) #endif #ifdef W3_NL5 - CALL W3SNL5 ( SPEC, CG1, WN1, FMEAN, QI5TSTART, & - U10ABS, U10DIR, JSEA, VSNL, VDNL, QR5KURT) + CALL W3SNL5 ( SPEC, CG1, WN1, FMEAN, QI5TSTART, & + U10ABS, U10DIR, JSEA, VSNL, VDNL, QR5KURT) #endif -! + ! #ifdef W3_PDLIB - IF (.NOT. FSSOURCE .or. LSLOC) THEN + IF (.NOT. FSSOURCE .or. LSLOC) THEN #endif #ifdef W3_TR1 CALL W3STR1 ( SPEC, CG1, WN1, DEPTH, IX, VSTR, VDTR ) #endif #ifdef W3_PDLIB - ENDIF + ENDIF #endif -! -! 2.c Dissipation... except for ST4 -! 2.c1 as in source term package -! + ! + ! 2.c Dissipation... except for ST4 + ! 2.c1 as in source term package + ! #ifdef W3_ST1 - CALL W3SDS1 ( SPEC, WN2, EMEAN, FMEAN, WNMEAN, VSDS, VDDS ) + CALL W3SDS1 ( SPEC, WN2, EMEAN, FMEAN, WNMEAN, VSDS, VDDS ) #endif #ifdef W3_ST2 - CALL W3SDS2 ( SPEC, CG1, WN1, FPI, USTAR, ALPHA,VSDS, VDDS ) + CALL W3SDS2 ( SPEC, CG1, WN1, FPI, USTAR, ALPHA,VSDS, VDDS ) #endif #ifdef W3_ST3 - CALL W3SDS3 ( SPEC, WN1, CG1, EMEAN, FMEANS, WNMEAN, & - USTAR, USTDIR, DEPTH, VSDS, VDDS, IX, IY ) + CALL W3SDS3 ( SPEC, WN1, CG1, EMEAN, FMEANS, WNMEAN, & + USTAR, USTDIR, DEPTH, VSDS, VDDS, IX, IY ) #endif #ifdef W3_ST4 - CALL W3SDS4 ( SPEC, WN1, CG1, USTAR, USTDIR, DEPTH, DAIR, VSDS, & - VDDS, IX, IY, BRLAMBDA, WHITECAP, DLWMEAN ) + CALL W3SDS4 ( SPEC, WN1, CG1, USTAR, USTDIR, DEPTH, DAIR, VSDS, & + VDDS, IX, IY, BRLAMBDA, WHITECAP, DLWMEAN ) #endif #ifdef W3_DEBUGSRC #ifdef W3_ST4 - IF (IX == DEBUG_NODE) THEN - WRITE(740+IAPROC,*) '2 : W3SDS4(min/max/sum)VSDS=', minval(VSDS), maxval(VSDS), sum(VSDS) - WRITE(740+IAPROC,*) '2 : W3SDS4(min/max/sum)VDDS=', minval(VDDS), maxval(VDDS), sum(VDDS) - END IF + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '2 : W3SDS4(min/max/sum)VSDS=', minval(VSDS), maxval(VSDS), sum(VSDS) + WRITE(740+IAPROC,*) '2 : W3SDS4(min/max/sum)VDDS=', minval(VDDS), maxval(VDDS), sum(VDDS) + END IF #endif #endif #ifdef W3_ST6 - CALL W3SDS6 ( SPEC, CG1, WN1, VSDS, VDDS ) + CALL W3SDS6 ( SPEC, CG1, WN1, VSDS, VDDS ) #endif -! + ! #ifdef W3_PDLIB - IF (.NOT. FSSOURCE .or. LSLOC) THEN + IF (.NOT. FSSOURCE .or. LSLOC) THEN #endif #ifdef W3_DB1 - CALL W3SDB1 ( IX, SPEC, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, & - LBREAK, VSDB, VDDB ) + CALL W3SDB1 ( IX, SPEC, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, & + LBREAK, VSDB, VDDB ) #endif #ifdef W3_PDLIB - ENDIF + ENDIF #endif -! -! 2.c2 optional dissipation parameterisations -! + ! + ! 2.c2 optional dissipation parameterisations + ! #ifdef W3_ST6 - IF (SWL6S6) THEN - CALL W3SWL6 ( SPEC, CG1, WN1, VSWL, VDWL ) - END IF + IF (SWL6S6) THEN + CALL W3SWL6 ( SPEC, CG1, WN1, VSWL, VDWL ) + END IF #endif -! -! 2.d Bottom interactions. -! + ! + ! 2.d Bottom interactions. + ! #ifdef W3_BT1 - CALL W3SBT1 ( SPEC, CG1, WN1, DEPTH, VSBT, VDBT ) + CALL W3SBT1 ( SPEC, CG1, WN1, DEPTH, VSBT, VDBT ) #endif #ifdef W3_BT4 - CALL W3SBT4 ( SPEC, CG1, WN1, DEPTH, D50, PSIC, TAUBBL, & - BEDFORM, VSBT, VDBT, IX, IY ) + CALL W3SBT4 ( SPEC, CG1, WN1, DEPTH, D50, PSIC, TAUBBL, & + BEDFORM, VSBT, VDBT, IX, IY ) #endif #ifdef W3_BT8 - CALL W3SBT8 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) + CALL W3SBT8 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) #endif #ifdef W3_BT9 - CALL W3SBT9 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) + CALL W3SBT9 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) #endif -! + ! #ifdef W3_BS1 - CALL W3SBS1 ( SPEC, CG1, WN1, DEPTH, CX, CY, & - TAUSCX, TAUSCY, VSBS, VDBS ) + CALL W3SBS1 ( SPEC, CG1, WN1, DEPTH, CX, CY, & + TAUSCX, TAUSCY, VSBS, VDBS ) #endif -! -! 2.e Unresolved Obstacles Source Term -! + ! + ! 2.e Unresolved Obstacles Source Term + ! #ifdef W3_UOST - ! UNRESOLVED OBSTACLES - CALL UOST_SRCTRMCOMPUTE(IX, IY, SPEC, CG1, DT, & - U10ABS, U10DIR, VSUO, VDUO) + ! UNRESOLVED OBSTACLES + CALL UOST_SRCTRMCOMPUTE(IX, IY, SPEC, CG1, DT, & + U10ABS, U10DIR, VSUO, VDUO) #endif -! -! 2.g Dump training data if necessary -! + ! + ! 2.g Dump training data if necessary + ! #ifdef W3_NNT - WRITE (SCREEN,8888) TIME, DTTOT, FLAGNN, QCERR - WRITE (NDSD2,8888) TIME, DTTOT, FLAGNN, QCERR - 8888 FORMAT (1X,I8.8,1X,I6.6,F8.1,L2,F8.2) - WRITE (NDSD,ERR=801,IOSTAT=IERR) IX, IY, TIME, NSTEPS, & - DTTOT, FLAGNN, DEPTH, U10ABS, U10DIR + WRITE (SCREEN,8888) TIME, DTTOT, FLAGNN, QCERR + WRITE (NDSD2,8888) TIME, DTTOT, FLAGNN, QCERR +8888 FORMAT (1X,I8.8,1X,I6.6,F8.1,L2,F8.2) + WRITE (NDSD,ERR=801,IOSTAT=IERR) IX, IY, TIME, NSTEPS, & + DTTOT, FLAGNN, DEPTH, U10ABS, U10DIR #endif -! + ! #ifdef W3_NNT - IF ( FLAGNN ) THEN - DO IK=1, NK - FACNN = TPI * SIG(IK) / CG1(IK) - DO ITH=1, NTH - IS = ITH + (IK-1)*NTH - FOUT(IK,ITH) = SPEC(IS) * FACNN - SOUT(IK,ITH) = VSNL(IS) * FACNN - DOUT(IK,ITH) = VDNL(IS) - END DO - END DO - WRITE (NDSD,ERR=801,IOSTAT=IERR) FOUT - WRITE (NDSD,ERR=801,IOSTAT=IERR) SOUT - WRITE (NDSD,ERR=801,IOSTAT=IERR) DOUT - END IF + IF ( FLAGNN ) THEN + DO IK=1, NK + FACNN = TPI * SIG(IK) / CG1(IK) + DO ITH=1, NTH + IS = ITH + (IK-1)*NTH + FOUT(IK,ITH) = SPEC(IS) * FACNN + SOUT(IK,ITH) = VSNL(IS) * FACNN + DOUT(IK,ITH) = VDNL(IS) + END DO + END DO + WRITE (NDSD,ERR=801,IOSTAT=IERR) FOUT + WRITE (NDSD,ERR=801,IOSTAT=IERR) SOUT + WRITE (NDSD,ERR=801,IOSTAT=IERR) DOUT + END IF #endif -! -! 3. Set frequency cut-off ------------------------------------------ * -! + ! + ! 3. Set frequency cut-off ------------------------------------------ * + ! #ifdef W3_ST2 - FHIGH = XFC * FPI - IF ( FLTEST ) WRITE (NDST,9005) FHIGH*TPIINV + FHIGH = XFC * FPI + IF ( FLTEST ) WRITE (NDST,9005) FHIGH*TPIINV #endif - NKH = MIN ( NK , INT(FACTI2+FACTI1*LOG(MAX(1.E-7,FHIGH))) ) - NKH1 = MIN ( NK , NKH+1 ) - NSPECH = NKH1*NTH + NKH = MIN ( NK , INT(FACTI2+FACTI1*LOG(MAX(1.E-7,FHIGH))) ) + NKH1 = MIN ( NK , NKH+1 ) + NSPECH = NKH1*NTH #ifdef W3_T - WRITE (NDST,9021) NKH, NKH1, NSPECH -#endif -! -! 4. Summation of source terms and diagonal term and time step ------ * -! - DT = MIN ( DTG-DTTOT , DTMAX ) - AFILT = MAX ( DAM(NSPEC) , XFLT*AMAX ) -! -! For input and dissipation calculate the fraction of the ice-free -! surface. In the presence of ice, the effective water surface -! is reduce to a fraction of the cell size free from ice, and so is -! input : -! SIN = (1-ICE)**ISCALEIN*SIN and SDS=(1-ICE)**ISCALEDS*SDS ------------------ * -! INFLAGS2(4) is true if ice concentration was ever read during -! this simulation - IF ( INFLAGS2(4) ) THEN - VSNL(1:NSPECH) = ICESCALENL * VSNL(1:NSPECH) - VDNL(1:NSPECH) = ICESCALENL * VDNL(1:NSPECH) - VSLN(1:NSPECH) = ICESCALELN * VSLN(1:NSPECH) - VSIN(1:NSPECH) = ICESCALEIN * VSIN(1:NSPECH) - VDIN(1:NSPECH) = ICESCALEIN * VDIN(1:NSPECH) - VSDS(1:NSPECH) = ICESCALEDS * VSDS(1:NSPECH) - VDDS(1:NSPECH) = ICESCALEDS * VDDS(1:NSPECH) - END IF -! - VS = 0 - VD = 0 - DO IS=IS1, NSPECH - VS(IS) = VSLN(IS) + VSIN(IS) + VSNL(IS) & - + VSDS(IS) + VSBT(IS) + WRITE (NDST,9021) NKH, NKH1, NSPECH +#endif + ! + ! 4. Summation of source terms and diagonal term and time step ------ * + ! + DT = MIN ( DTG-DTTOT , DTMAX ) + AFILT = MAX ( DAM(NSPEC) , XFLT*AMAX ) + ! + ! For input and dissipation calculate the fraction of the ice-free + ! surface. In the presence of ice, the effective water surface + ! is reduce to a fraction of the cell size free from ice, and so is + ! input : + ! SIN = (1-ICE)**ISCALEIN*SIN and SDS=(1-ICE)**ISCALEDS*SDS ------------------ * + ! INFLAGS2(4) is true if ice concentration was ever read during + ! this simulation + IF ( INFLAGS2(4) ) THEN + VSNL(1:NSPECH) = ICESCALENL * VSNL(1:NSPECH) + VDNL(1:NSPECH) = ICESCALENL * VDNL(1:NSPECH) + VSLN(1:NSPECH) = ICESCALELN * VSLN(1:NSPECH) + VSIN(1:NSPECH) = ICESCALEIN * VSIN(1:NSPECH) + VDIN(1:NSPECH) = ICESCALEIN * VDIN(1:NSPECH) + VSDS(1:NSPECH) = ICESCALEDS * VSDS(1:NSPECH) + VDDS(1:NSPECH) = ICESCALEDS * VDDS(1:NSPECH) + END IF + ! + VS = 0 + VD = 0 + DO IS=IS1, NSPECH + VS(IS) = VSLN(IS) + VSIN(IS) + VSNL(IS) & + + VSDS(IS) + VSBT(IS) #ifdef W3_ST6 - VS(IS) = VS(IS) + VSWL(IS) + VS(IS) = VS(IS) + VSWL(IS) #endif #ifdef W3_TR1 - VS(IS) = VS(IS) + VSTR(IS) + VS(IS) = VS(IS) + VSTR(IS) #endif #ifdef W3_BS1 - VS(IS) = VS(IS) + VSBS(IS) + VS(IS) = VS(IS) + VSBS(IS) #endif #ifdef W3_UOST - VS(IS) = VS(IS) + VSUO(IS) + VS(IS) = VS(IS) + VSUO(IS) #endif - VD(IS) = VDIN(IS) + VDNL(IS) & - + VDDS(IS) + VDBT(IS) + VD(IS) = VDIN(IS) + VDNL(IS) & + + VDDS(IS) + VDBT(IS) #ifdef W3_ST6 - VD(IS) = VD(IS) + VDWL(IS) + VD(IS) = VD(IS) + VDWL(IS) #endif #ifdef W3_TR1 - VD(IS) = VD(IS) + VDTR(IS) + VD(IS) = VD(IS) + VDTR(IS) #endif #ifdef W3_BS1 - VD(IS) = VD(IS) + VDBS(IS) + VD(IS) = VD(IS) + VDBS(IS) #endif #ifdef W3_UOST - VD(IS) = VD(IS) + VDUO(IS) + VD(IS) = VD(IS) + VDUO(IS) #endif - DAMAX = MIN ( DAM(IS) , MAX ( XREL*SPECINIT(IS) , AFILT ) ) - AFAC = 1. / MAX( 1.E-10 , ABS(VS(IS)/DAMAX) ) + DAMAX = MIN ( DAM(IS) , MAX ( XREL*SPECINIT(IS) , AFILT ) ) + AFAC = 1. / MAX( 1.E-10 , ABS(VS(IS)/DAMAX) ) #ifdef W3_NL5 - IF (NL5_SELECT .EQ. 1) THEN - DT = MIN ( DT , AFAC / ( MAX ( 1.E-10, & - 1. + NL5_OFFSET*AFAC*MIN(0.,VD(IS)) ) ) ) - ELSE + IF (NL5_SELECT .EQ. 1) THEN + DT = MIN ( DT , AFAC / ( MAX ( 1.E-10, & + 1. + NL5_OFFSET*AFAC*MIN(0.,VD(IS)) ) ) ) + ELSE #endif DT = MIN ( DT , AFAC / ( MAX ( 1.E-10, & - 1. + OFFSET*AFAC*MIN(0.,VD(IS)) ) ) ) + 1. + OFFSET*AFAC*MIN(0.,VD(IS)) ) ) ) #ifdef W3_NL5 - ENDIF + ENDIF #endif - END DO ! end of loop on IS -! - DT = MAX ( 0.5, DT ) ! The hardcoded min. dt is a problem for certain cases e.g. laborotary scale problems. -! - DTDYN = DTDYN + DT + END DO ! end of loop on IS + ! + DT = MAX ( 0.5, DT ) ! The hardcoded min. dt is a problem for certain cases e.g. laborotary scale problems. + ! + DTDYN = DTDYN + DT #ifdef W3_T - DTRAW = DT -#endif - IDT = 1 + INT ( 0.99*(DTG-DTTOT)/DT ) ! number of iterations - DT = (DTG-DTTOT)/REAL(IDT) ! actualy time step - SHAVE = DT.LT.DTMIN .AND. DT.LT.DTG-DTTOT ! limiter check ... - SHAVEIO = SHAVE - DT = MAX ( DT , MIN (DTMIN,DTG-DTTOT) ) ! override dt with input time step or last time step if it is bigger ... anyway the limiter is on! -! + DTRAW = DT +#endif + IDT = 1 + INT ( 0.99*(DTG-DTTOT)/DT ) ! number of iterations + DT = (DTG-DTTOT)/REAL(IDT) ! actualy time step + SHAVE = DT.LT.DTMIN .AND. DT.LT.DTG-DTTOT ! limiter check ... + SHAVEIO = SHAVE + DT = MAX ( DT , MIN (DTMIN,DTG-DTTOT) ) ! override dt with input time step or last time step if it is bigger ... anyway the limiter is on! + ! #ifdef W3_NL5 - DT = INT(DT) * 1.0 + DT = INT(DT) * 1.0 #endif - IF (srce_call .eq. srce_imp_post) DT = DTG ! for implicit part + IF (srce_call .eq. srce_imp_post) DT = DTG ! for implicit part #ifdef W3_NL5 - IF (NL5_SELECT .EQ. 1) THEN - HDT = NL5_OFFSET * DT - ELSE + IF (NL5_SELECT .EQ. 1) THEN + HDT = NL5_OFFSET * DT + ELSE #endif HDT = OFFSET * DT #ifdef W3_NL5 - ENDIF + ENDIF #endif - DTTOT = DTTOT + DT + DTTOT = DTTOT + DT #ifdef W3_DEBUGSRC - IF (IX == DEBUG_NODE) WRITE(*,'(A20,2I10,5F20.10,L20)') 'TIMINGS 2', IDT, NSTEPS, DT, DTMIN, DTDYN, HDT, DTTOT, SHAVE - IF (IX == DEBUG_NODE) THEN - WRITE(740+IAPROC,*) '1: min/max/sum(VS)=', minval(VS), maxval(VS), sum(VS) - WRITE(740+IAPROC,*) '1: min/max/sum(VD)=', minval(VD), maxval(VD), sum(VD) - WRITE(740+IAPROC,*) 'min/max/sum(VSIN)=', minval(VSIN), maxval(VSIN), sum(VSIN) - WRITE(740+IAPROC,*) 'min/max/sum(VDIN)=', minval(VDIN), maxval(VDIN), sum(VDIN) - WRITE(740+IAPROC,*) 'min/max/sum(VSLN)=', minval(VSLN), maxval(VSLN), sum(VSLN) - WRITE(740+IAPROC,*) 'min/max/sum(VSNL)=', minval(VSNL), maxval(VSNL), sum(VSNL) - WRITE(740+IAPROC,*) 'min/max/sum(VDNL)=', minval(VDNL), maxval(VDNL), sum(VDNL) - WRITE(740+IAPROC,*) 'min/max/sum(VSDS)=', minval(VSDS), maxval(VSDS), sum(VSDS) - WRITE(740+IAPROC,*) 'min/max/sum(VDDS)=', minval(VDDS), maxval(VDDS), sum(VDDS) + IF (IX == DEBUG_NODE) WRITE(*,'(A20,2I10,5F20.10,L20)') 'TIMINGS 2', IDT, NSTEPS, DT, DTMIN, DTDYN, HDT, DTTOT, SHAVE + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '1: min/max/sum(VS)=', minval(VS), maxval(VS), sum(VS) + WRITE(740+IAPROC,*) '1: min/max/sum(VD)=', minval(VD), maxval(VD), sum(VD) + WRITE(740+IAPROC,*) 'min/max/sum(VSIN)=', minval(VSIN), maxval(VSIN), sum(VSIN) + WRITE(740+IAPROC,*) 'min/max/sum(VDIN)=', minval(VDIN), maxval(VDIN), sum(VDIN) + WRITE(740+IAPROC,*) 'min/max/sum(VSLN)=', minval(VSLN), maxval(VSLN), sum(VSLN) + WRITE(740+IAPROC,*) 'min/max/sum(VSNL)=', minval(VSNL), maxval(VSNL), sum(VSNL) + WRITE(740+IAPROC,*) 'min/max/sum(VDNL)=', minval(VDNL), maxval(VDNL), sum(VDNL) + WRITE(740+IAPROC,*) 'min/max/sum(VSDS)=', minval(VSDS), maxval(VSDS), sum(VSDS) + WRITE(740+IAPROC,*) 'min/max/sum(VDDS)=', minval(VDDS), maxval(VDDS), sum(VDDS) #ifdef W3_ST6 - WRITE(740+IAPROC,*) 'min/max/sum(VSWL)=', minval(VSWL), maxval(VSWL), sum(VSWL) - WRITE(740+IAPROC,*) 'min/max/sum(VDWL)=', minval(VDWL), maxval(VDWL), sum(VDWL) + WRITE(740+IAPROC,*) 'min/max/sum(VSWL)=', minval(VSWL), maxval(VSWL), sum(VSWL) + WRITE(740+IAPROC,*) 'min/max/sum(VDWL)=', minval(VDWL), maxval(VDWL), sum(VDWL) #endif #ifdef W3_DB1 - WRITE(740+IAPROC,*) 'min/max/sum(VSDB)=', minval(VSDB), maxval(VSDB), sum(VSDB) - WRITE(740+IAPROC,*) 'min/max/sum(VDDB)=', minval(VDDB), maxval(VDDB), sum(VDDB) + WRITE(740+IAPROC,*) 'min/max/sum(VSDB)=', minval(VSDB), maxval(VSDB), sum(VSDB) + WRITE(740+IAPROC,*) 'min/max/sum(VDDB)=', minval(VDDB), maxval(VDDB), sum(VDDB) #endif #ifdef W3_TR1 - WRITE(740+IAPROC,*) 'min/max/sum(VSTR)=', minval(VSTR), maxval(VSTR), sum(VSTR) - WRITE(740+IAPROC,*) 'min/max/sum(VDTR)=', minval(VDTR), maxval(VDTR), sum(VDTR) + WRITE(740+IAPROC,*) 'min/max/sum(VSTR)=', minval(VSTR), maxval(VSTR), sum(VSTR) + WRITE(740+IAPROC,*) 'min/max/sum(VDTR)=', minval(VDTR), maxval(VDTR), sum(VDTR) #endif #ifdef W3_BS1 - WRITE(740+IAPROC,*) 'min/max/sum(VSBS)=', minval(VSBS), maxval(VSBS), sum(VSBS) - WRITE(740+IAPROC,*) 'min/max/sum(VDBS)=', minval(VDBS), maxval(VDBS), sum(VDBS) + WRITE(740+IAPROC,*) 'min/max/sum(VSBS)=', minval(VSBS), maxval(VSBS), sum(VSBS) + WRITE(740+IAPROC,*) 'min/max/sum(VDBS)=', minval(VDBS), maxval(VDBS), sum(VDBS) #endif - WRITE(740+IAPROC,*) 'min/max/sum(VSBT)=', minval(VSBT), maxval(VSBT), sum(VSBT) - WRITE(740+IAPROC,*) 'min/max/sum(VDBT)=', minval(VDBT), maxval(VDBT), sum(VDBT) - END IF + WRITE(740+IAPROC,*) 'min/max/sum(VSBT)=', minval(VSBT), maxval(VSBT), sum(VSBT) + WRITE(740+IAPROC,*) 'min/max/sum(VDBT)=', minval(VDBT), maxval(VDBT), sum(VDBT) + END IF #endif #ifdef W3_PDLIB - IF (srce_call .eq. srce_imp_pre) THEN - IF (LSLOC) THEN - IF (IMEM == 1) THEN - SIDT = PDLIB_SI(JSEA) * DTG - DO IK = 1, NK - JAC = CLATSL/CG1(IK) - DO ITH = 1, NTH - ISP = ITH + (IK-1)*NTH - VD(ISP) = MIN(0., VD(ISP)) - IF (LNEWLIMITER) THEN - MAXDAC = MAX(DAM(ISP),DAM2(ISP)) - ELSE - MAXDAC = DAM(ISP) - ENDIF - FAKS = DTG / MAX ( 1. , (1.-DTG*VD(ISP))) - DVS = VS(ISP) * FAKS - DVS = SIGN(MIN(MAXDAC,ABS(DVS)),DVS) - PreVS = DVS / FAKS - eVS = PreVS / CG1(IK) * CLATSL - eVD = MIN(0.,VD(ISP)) - B_JAC(ISP,JSEA) = B_JAC(ISP,JSEA) + SIDT * (eVS - eVD*SPEC(ISP)*JAC) - ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) - SIDT * eVD + IF (srce_call .eq. srce_imp_pre) THEN + IF (LSLOC) THEN + IF (IMEM == 1) THEN + SIDT = PDLIB_SI(JSEA) * DTG + DO IK = 1, NK + JAC = CLATSL/CG1(IK) + DO ITH = 1, NTH + ISP = ITH + (IK-1)*NTH + VD(ISP) = MIN(0., VD(ISP)) + IF (LNEWLIMITER) THEN + MAXDAC = MAX(DAM(ISP),DAM2(ISP)) + ELSE + MAXDAC = DAM(ISP) + ENDIF + FAKS = DTG / MAX ( 1. , (1.-DTG*VD(ISP))) + DVS = VS(ISP) * FAKS + DVS = SIGN(MIN(MAXDAC,ABS(DVS)),DVS) + PreVS = DVS / FAKS + eVS = PreVS / CG1(IK) * CLATSL + eVD = MIN(0.,VD(ISP)) + B_JAC(ISP,JSEA) = B_JAC(ISP,JSEA) + SIDT * (eVS - eVD*SPEC(ISP)*JAC) + ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) - SIDT * eVD #ifdef W3_DB1 eVS = VSDB(ISP) * JAC eVD = MIN(0.,VDDB(ISP)) IF (eVS .gt. 0.) THEN evS = 2*evS - evD = -evD + evD = -evD ELSE evS = -evS evD = 2*evD ENDIF #endif - B_JAC(ISP,JSEA) = B_JAC(ISP,JSEA) + SIDT * eVS - ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) - SIDT * eVD + B_JAC(ISP,JSEA) = B_JAC(ISP,JSEA) + SIDT * eVS + ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) - SIDT * eVD #ifdef W3_TR1 - eVS = VSTR(ISP) * JAC + eVS = VSTR(ISP) * JAC eVD = VDTR(ISP) IF (eVS .gt. 0.) THEN evS = 2*evS - evD = -evD + evD = -evD ELSE evS = -evS evD = 2*evD ENDIF #endif - B_JAC(ISP,JSEA) = B_JAC(ISP,JSEA) + SIDT * eVS - ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) - SIDT * eVD - END DO - END DO + B_JAC(ISP,JSEA) = B_JAC(ISP,JSEA) + SIDT * eVS + ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(JSEA)) - SIDT * eVD + END DO + END DO - ELSEIF (IMEM == 2) THEN + ELSEIF (IMEM == 2) THEN - SIDT = PDLIB_SI(JSEA) * DTG - DO IK=1,NK - JAC = CLATSL/CG1(IK) - DO ITH=1,NTH - ISP=ITH + (IK-1)*NTH - VD(ISP) = MIN(0., VD(ISP)) - IF (LNEWLIMITER) THEN - MAXDAC = MAX(DAM(ISP),DAM2(ISP)) - ELSE - MAXDAC = DAM(ISP) - ENDIF - FAKS = DTG / MAX ( 1. , (1.-DTG*VD(ISP))) - DVS = VS(ISP) * FAKS - DVS = SIGN(MIN(MAXDAC,ABS(DVS)),DVS) - PreVS = DVS / FAKS - eVS = PreVS / CG1(IK) * CLATSL - eVD = VD(ISP) + SIDT = PDLIB_SI(JSEA) * DTG + DO IK=1,NK + JAC = CLATSL/CG1(IK) + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + VD(ISP) = MIN(0., VD(ISP)) + IF (LNEWLIMITER) THEN + MAXDAC = MAX(DAM(ISP),DAM2(ISP)) + ELSE + MAXDAC = DAM(ISP) + ENDIF + FAKS = DTG / MAX ( 1. , (1.-DTG*VD(ISP))) + DVS = VS(ISP) * FAKS + DVS = SIGN(MIN(MAXDAC,ABS(DVS)),DVS) + PreVS = DVS / FAKS + eVS = PreVS / CG1(IK) * CLATSL + eVD = VD(ISP) #ifdef W3_DB1 - eVS = eVS + DBLE(VSDB(ISP)) * JAC - eVD = evD + MIN(0.,DBLE(VDDB(ISP))) -#endif - B_JAC(ISP,JSEA) = B_JAC(ISP,JSEA) + SIDT * (eVS - eVD*VA(ISP,JSEA)) - ASPAR_DIAG_ALL(ISP,JSEA) = ASPAR_DIAG_ALL(ISP,JSEA) - SIDT * eVD - END DO - END DO - ENDIF - ENDIF - - PrintDeltaSmDA=.FALSE. - IF (PrintDeltaSmDA .eqv. .TRUE.) THEN - DO IS=1,NSPEC - DeltaSRC(IS) = VSIN(IS) - SPEC(IS)*VDIN(IS) - END DO - WRITE(740+IAPROC,*) 'min/max/sum(VSIN)=', minval(VSIN), maxval(VSIN), sum(VSIN) - WRITE(740+IAPROC,*) 'min/max/sum(DeltaIN)=', minval(DeltaSRC), maxval(DeltaSRC), sum(DeltaSRC) - ! - DO IS=1,NSPEC - DeltaSRC(IS) = VSNL(IS) - SPEC(IS)*VDNL(IS) - END DO - WRITE(740+IAPROC,*) 'min/max/sum(VSNL)=', minval(VSNL), maxval(VSNL), sum(VSNL) - WRITE(740+IAPROC,*) 'min/max/sum(DeltaNL)=', minval(DeltaSRC), maxval(DeltaSRC), sum(DeltaSRC) - ! - DO IS=1,NSPEC - DeltaSRC(IS) = VSDS(IS) - SPEC(IS)*VDDS(IS) + eVS = eVS + DBLE(VSDB(ISP)) * JAC + eVD = evD + MIN(0.,DBLE(VDDB(ISP))) +#endif + B_JAC(ISP,JSEA) = B_JAC(ISP,JSEA) + SIDT * (eVS - eVD*VA(ISP,JSEA)) + ASPAR_DIAG_ALL(ISP,JSEA) = ASPAR_DIAG_ALL(ISP,JSEA) - SIDT * eVD + END DO END DO - WRITE(740+IAPROC,*) 'min/max/sum(VSDS)=', minval(VSDS), maxval(VSDS), sum(VSDS) - WRITE(740+IAPROC,*) 'min/max/sum(DeltaDS)=', minval(DeltaSRC), maxval(DeltaSRC), sum(DeltaSRC) - ! -! DO IS=1,NSPEC -! DeltaSRC(IS) = VSIC(IS) - SPEC(IS)*VDIC(IS) -! END DO - WRITE(740+IAPROC,*) 'min/max/sum(DeltaDS)=', minval(DeltaSRC), maxval(DeltaSRC), sum(DeltaSRC) - END IF - - IF (.not. LSLOC) THEN - IF (optionCall .eq. 1) THEN - CALL SIGN_VSD_PATANKAR_WW3(SPEC,VS,VD) - ELSE IF (optionCall .eq. 2) THEN - CALL SIGN_VSD_SEMI_IMPLICIT_WW3(SPEC,VS,VD) - ELSE IF (optionCall .eq. 3) THEN - CALL SIGN_VSD_SEMI_IMPLICIT_WW3(SPEC,VS,VD) - ENDIF - VSIO = VS - VDIO = VD ENDIF + ENDIF + + PrintDeltaSmDA=.FALSE. + IF (PrintDeltaSmDA .eqv. .TRUE.) THEN + DO IS=1,NSPEC + DeltaSRC(IS) = VSIN(IS) - SPEC(IS)*VDIN(IS) + END DO + WRITE(740+IAPROC,*) 'min/max/sum(VSIN)=', minval(VSIN), maxval(VSIN), sum(VSIN) + WRITE(740+IAPROC,*) 'min/max/sum(DeltaIN)=', minval(DeltaSRC), maxval(DeltaSRC), sum(DeltaSRC) + ! + DO IS=1,NSPEC + DeltaSRC(IS) = VSNL(IS) - SPEC(IS)*VDNL(IS) + END DO + WRITE(740+IAPROC,*) 'min/max/sum(VSNL)=', minval(VSNL), maxval(VSNL), sum(VSNL) + WRITE(740+IAPROC,*) 'min/max/sum(DeltaNL)=', minval(DeltaSRC), maxval(DeltaSRC), sum(DeltaSRC) + ! + DO IS=1,NSPEC + DeltaSRC(IS) = VSDS(IS) - SPEC(IS)*VDDS(IS) + END DO + WRITE(740+IAPROC,*) 'min/max/sum(VSDS)=', minval(VSDS), maxval(VSDS), sum(VSDS) + WRITE(740+IAPROC,*) 'min/max/sum(DeltaDS)=', minval(DeltaSRC), maxval(DeltaSRC), sum(DeltaSRC) + ! + ! DO IS=1,NSPEC + ! DeltaSRC(IS) = VSIC(IS) - SPEC(IS)*VDIC(IS) + ! END DO + WRITE(740+IAPROC,*) 'min/max/sum(DeltaDS)=', minval(DeltaSRC), maxval(DeltaSRC), sum(DeltaSRC) + END IF + + IF (.not. LSLOC) THEN + IF (optionCall .eq. 1) THEN + CALL SIGN_VSD_PATANKAR_WW3(SPEC,VS,VD) + ELSE IF (optionCall .eq. 2) THEN + CALL SIGN_VSD_SEMI_IMPLICIT_WW3(SPEC,VS,VD) + ELSE IF (optionCall .eq. 3) THEN + CALL SIGN_VSD_SEMI_IMPLICIT_WW3(SPEC,VS,VD) + ENDIF + VSIO = VS + VDIO = VD + ENDIF #ifdef W3_DEBUGSRC - IF (IX == DEBUG_NODE) THEN - WRITE(740+IAPROC,*) ' srce_imp_pre : SHAVE = ', SHAVE - WRITE(740+IAPROC,*) ' srce_imp_pre : DT=', DT, ' HDT=', HDT, 'DTG=', DTG - WRITE(740+IAPROC,*) ' srce_imp_pre : sum(SPEC)=', sum(SPEC) - WRITE(740+IAPROC,*) ' srce_imp_pre : sum(VSTOT)=', sum(VS) - WRITE(740+IAPROC,*) ' srce_imp_pre : sum(VDTOT)=', sum(MIN(0. , VD)) - END IF + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) ' srce_imp_pre : SHAVE = ', SHAVE + WRITE(740+IAPROC,*) ' srce_imp_pre : DT=', DT, ' HDT=', HDT, 'DTG=', DTG + WRITE(740+IAPROC,*) ' srce_imp_pre : sum(SPEC)=', sum(SPEC) + WRITE(740+IAPROC,*) ' srce_imp_pre : sum(VSTOT)=', sum(VS) + WRITE(740+IAPROC,*) ' srce_imp_pre : sum(VDTOT)=', sum(MIN(0. , VD)) + END IF - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSIN) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDIN) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSDS) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDDS) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSNL) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDNL) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSLN) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSBT) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VS) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VD) -#endif - RETURN ! return everything is done for the implicit ... + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSIN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDIN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSDS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDDS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSNL) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDNL) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSLN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSBT) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VD) +#endif + RETURN ! return everything is done for the implicit ... - END IF ! srce_imp_pre + END IF ! srce_imp_pre #endif W3_PDLIB -! + ! #ifdef W3_T - WRITE (NDST,9040) DTRAW, DT, SHAVE -#endif -! -! 5. Increment spectrum --------------------------------------------- * -! - IF (srce_call .eq. srce_direct) THEN - IF ( SHAVE ) THEN - DO IS=IS1, NSPECH - eInc1 = VS(IS) * DT / MAX ( 1. , (1.-HDT*VD(IS))) - eInc2 = SIGN ( MIN (DAM(IS),ABS(eInc1)) , eInc1 ) - SPEC(IS) = MAX ( 0. , SPEC(IS)+eInc2 ) - END DO - ELSE -! - DO IS=IS1, NSPECH - eInc1 = VS(IS) * DT / MAX ( 1. , (1.-HDT*VD(IS))) - SPEC(IS) = MAX ( 0. , SPEC(IS)+eInc1 ) - END DO - END IF -! + WRITE (NDST,9040) DTRAW, DT, SHAVE +#endif + ! + ! 5. Increment spectrum --------------------------------------------- * + ! + IF (srce_call .eq. srce_direct) THEN + IF ( SHAVE ) THEN + DO IS=IS1, NSPECH + eInc1 = VS(IS) * DT / MAX ( 1. , (1.-HDT*VD(IS))) + eInc2 = SIGN ( MIN (DAM(IS),ABS(eInc1)) , eInc1 ) + SPEC(IS) = MAX ( 0. , SPEC(IS)+eInc2 ) + END DO + ELSE + ! + DO IS=IS1, NSPECH + eInc1 = VS(IS) * DT / MAX ( 1. , (1.-HDT*VD(IS))) + SPEC(IS) = MAX ( 0. , SPEC(IS)+eInc1 ) + END DO + END IF + ! #ifdef W3_DB1 - DO IS=IS1, NSPECH - eInc1 = VSDB(IS) * DT / MAX ( 1. , (1.-HDT*VDDB(IS))) - SPEC(IS) = MAX ( 0. , SPEC(IS)+eInc1 ) - END DO + DO IS=IS1, NSPECH + eInc1 = VSDB(IS) * DT / MAX ( 1. , (1.-HDT*VDDB(IS))) + SPEC(IS) = MAX ( 0. , SPEC(IS)+eInc1 ) + END DO #endif #ifdef W3_DEBUGSRC - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSIN) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDIN) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSDS) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDDS) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSNL) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDNL) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSLN) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSBT) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VS) - IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VD) - IF (IX == DEBUG_NODE) THEN - WRITE(740+IAPROC,*) ' srce_direct : SHAVE = ', SHAVE - WRITE(740+IAPROC,*) ' srce_direct : DT=', DT, ' HDT=', HDT, 'DTG=', DTG - WRITE(740+IAPROC,*) ' srce_direct : sum(SPEC)=', sum(SPEC) - WRITE(740+IAPROC,*) ' srce_direct : sum(VSTOT)=', sum(VS) - WRITE(740+IAPROC,*) ' srce_direct : sum(VDTOT)=', sum(MIN(0. , VD)) - END IF -#endif + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSIN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDIN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSDS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDDS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSNL) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDNL) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSLN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSBT) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VD) + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) ' srce_direct : SHAVE = ', SHAVE + WRITE(740+IAPROC,*) ' srce_direct : DT=', DT, ' HDT=', HDT, 'DTG=', DTG + WRITE(740+IAPROC,*) ' srce_direct : sum(SPEC)=', sum(SPEC) + WRITE(740+IAPROC,*) ' srce_direct : sum(VSTOT)=', sum(VS) + WRITE(740+IAPROC,*) ' srce_direct : sum(VDTOT)=', sum(MIN(0. , VD)) END IF +#endif + END IF -! -! 5.b Computes -! atmos->wave flux PHIAW-------------------------------- * -! wave ->BBL flux PHIBBL------------------------------- * -! wave ->ice flux PHICE ------------------------------- * -! - WHITECAP(3)=0. - HSTOT=0. - DO IK=IKS1, NK - FACTOR = DDEN(IK)/CG1(IK) !Jacobian to get energy in band - FACTOR2= FACTOR*GRAV*WN1(IK)/SIG(IK) ! coefficient to get momentum + ! + ! 5.b Computes + ! atmos->wave flux PHIAW-------------------------------- * + ! wave ->BBL flux PHIBBL------------------------------- * + ! wave ->ice flux PHICE ------------------------------- * + ! + WHITECAP(3)=0. + HSTOT=0. + DO IK=IKS1, NK + FACTOR = DDEN(IK)/CG1(IK) !Jacobian to get energy in band + FACTOR2= FACTOR*GRAV*WN1(IK)/SIG(IK) ! coefficient to get momentum - ! Wave direction is "direction to" - ! therefore there is a PLUS sign for the stress - DO ITH=1, NTH - IS = (IK-1)*NTH + ITH - COSI(1)=ECOS(IS) - COSI(2)=ESIN(IS) - PHIAW = PHIAW + (VSIN(IS))* DT * FACTOR & - / MAX ( 1. , (1.-HDT*VDIN(IS))) ! semi-implict integration scheme + ! Wave direction is "direction to" + ! therefore there is a PLUS sign for the stress + DO ITH=1, NTH + IS = (IK-1)*NTH + ITH + COSI(1)=ECOS(IS) + COSI(2)=ESIN(IS) + PHIAW = PHIAW + (VSIN(IS))* DT * FACTOR & + / MAX ( 1. , (1.-HDT*VDIN(IS))) ! semi-implict integration scheme - PHIBBL= PHIBBL- (VSBT(IS))* DT * FACTOR & - / MAX ( 1. , (1.-HDT*VDBT(IS))) ! semi-implict integration scheme - PHINL = PHINL + VSNL(IS)* DT * FACTOR & - / MAX ( 1. , (1.-HDT*VDNL(IS))) ! semi-implict integration scheme - IF (VSIN(IS).GT.0.) WHITECAP(3) = WHITECAP(3) + SPEC(IS) * FACTOR - HSTOT = HSTOT + SPEC(IS) * FACTOR - END DO - END DO - WHITECAP(3)=4.*SQRT(WHITECAP(3)) - HSTOT=4.*SQRT(HSTOT) - TAUWIX= TAUWIX+ TAUWX * DRAT *DT - TAUWIY= TAUWIY+ TAUWY * DRAT *DT - TAUWNX= TAUWNX+ TAUWAX * DRAT *DT - TAUWNY= TAUWNY+ TAUWAY * DRAT *DT - ! MISSING: TAIL TO BE ADDED ? -! + PHIBBL= PHIBBL- (VSBT(IS))* DT * FACTOR & + / MAX ( 1. , (1.-HDT*VDBT(IS))) ! semi-implict integration scheme + PHINL = PHINL + VSNL(IS)* DT * FACTOR & + / MAX ( 1. , (1.-HDT*VDNL(IS))) ! semi-implict integration scheme + IF (VSIN(IS).GT.0.) WHITECAP(3) = WHITECAP(3) + SPEC(IS) * FACTOR + HSTOT = HSTOT + SPEC(IS) * FACTOR + END DO + END DO + WHITECAP(3)=4.*SQRT(WHITECAP(3)) + HSTOT=4.*SQRT(HSTOT) + TAUWIX= TAUWIX+ TAUWX * DRAT *DT + TAUWIY= TAUWIY+ TAUWY * DRAT *DT + TAUWNX= TAUWNX+ TAUWAX * DRAT *DT + TAUWNY= TAUWNY+ TAUWAY * DRAT *DT + ! MISSING: TAIL TO BE ADDED ? + ! #ifdef W3_NLS CALL W3SNLS ( SPEC, CG1, WN1, DEPTH, U10ABS, DT, AA=SPEC ) #endif -! -! 6. Add tail ------------------------------------------------------- * -! a Mean parameters -! -! + ! + ! 6. Add tail ------------------------------------------------------- * + ! a Mean parameters + ! + ! #ifdef W3_ST0 - CALL W3SPR0 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + CALL W3SPR0 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) #endif #ifdef W3_ST1 - CALL W3SPR1 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + CALL W3SPR1 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) #endif #ifdef W3_ST2 - CALL W3SPR2 (SPEC, CG1, WN1, DEPTH, FPI, U10ABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SPR2 (SPEC, CG1, WN1, DEPTH, FPI, U10ABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, U10ABS, U10DIR, USTAR, USTDIR, & - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) + CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, U10ABS, U10DIR, USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) #endif #ifdef W3_ST4 - CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN,& - AMAX, U10ABS, U10DIR, & + CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN,& + AMAX, U10ABS, U10DIR, & #ifdef W3_FLX5 - TAUA, TAUADIR, DAIR, & + TAUA, TAUADIR, DAIR, & #endif - USTAR, USTDIR, & - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) + USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) #endif #ifdef W3_ST6 - CALL W3SPR6 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX, FP) + CALL W3SPR6 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX, FP) #endif -! + ! #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & - USTAR, USTDIR, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & + USTAR, USTDIR, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & - USTAR, USTDIR, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & + USTAR, USTDIR, Z0, CD ) #endif -! + ! #ifdef W3_ST1 - FH1 = FXFM * FMEAN - FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) - NKH = MAX ( 2 , MIN ( NKH1 , & - INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) + FH1 = FXFM * FMEAN + FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) + NKH = MAX ( 2 , MIN ( NKH1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) #endif -! + ! #ifdef W3_ST1 - IF ( FLTEST ) WRITE (NDST,9060) & - FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV, NKH + IF ( FLTEST ) WRITE (NDST,9060) & + FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV, NKH #endif -! + ! #ifdef W3_ST2 - FHTRAN = XFT*FPI - FHIGH = XFC*FPI - DFH = FHIGH - FHTRAN - NKH = MAX ( 1 , & - INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHTRAN)) ) ) + FHTRAN = XFT*FPI + FHIGH = XFC*FPI + DFH = FHIGH - FHTRAN + NKH = MAX ( 1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHTRAN)) ) ) #endif -! + ! #ifdef W3_ST2 - IF ( FLTEST ) WRITE (NDST,9061) FHTRAN, FHIGH, NKH + IF ( FLTEST ) WRITE (NDST,9061) FHTRAN, FHIGH, NKH #endif -! + ! #ifdef W3_ST3 - FH1 = FFXFM * FMEAN - FH2 = FFXPM / USTAR - FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) - NKH = MAX ( 2 , MIN ( NKH1 , & - INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) + FH1 = FFXFM * FMEAN + FH2 = FFXPM / USTAR + FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) + NKH = MAX ( 2 , MIN ( NKH1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) #endif -! + ! #ifdef W3_ST3 - IF ( FLTEST ) WRITE (NDST,9062) & - FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV, NKH + IF ( FLTEST ) WRITE (NDST,9062) & + FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV, NKH #endif -! + ! #ifdef W3_ST4 -! Introduces a Long & Resio (JGR2007) type dependance on wave age - FAGE = FFXFA*TANH(0.3*U10ABS*FMEANWS*TPI/GRAV) - FH1 = (FFXFM+FAGE) * FMEAN1 + ! Introduces a Long & Resio (JGR2007) type dependance on wave age + FAGE = FFXFA*TANH(0.3*U10ABS*FMEANWS*TPI/GRAV) + FH1 = (FFXFM+FAGE) * FMEAN1 #endif #ifdef W3_ST4 - FH2 = FFXPM / USTAR - FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) - NKH = MAX ( 2 , MIN ( NKH1 , & - INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) + FH2 = FFXPM / USTAR + FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) + NKH = MAX ( 2 , MIN ( NKH1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) #endif -! + ! #ifdef W3_ST6 - IF (FXFM .LE. 0) THEN - FHIGH = SIG(NK) - ELSE - FHIGH = MIN ( SIG(NK), MAX(FXFM * FMEAN, FXPM / USTAR) ) - ENDIF - NKH = MAX ( 2 , MIN ( NKH1 , & - INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) + IF (FXFM .LE. 0) THEN + FHIGH = SIG(NK) + ELSE + FHIGH = MIN ( SIG(NK), MAX(FXFM * FMEAN, FXPM / USTAR) ) + ENDIF + NKH = MAX ( 2 , MIN ( NKH1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) #endif -! + ! #ifdef W3_ST6 - IF ( FLTEST ) WRITE (NDST,9063) FHIGH*TPIINV, NKH + IF ( FLTEST ) WRITE (NDST,9063) FHIGH*TPIINV, NKH #endif -! -! 6.b Limiter for shallow water or Miche style criterion -! Last time step ONLY ! -! uses true depth (D_INP) instead of limited depth -! + ! + ! 6.b Limiter for shallow water or Miche style criterion + ! Last time step ONLY ! + ! uses true depth (D_INP) instead of limited depth + ! #ifdef W3_MLIM - IF ( DTTOT .GE. 0.9999*DTG ) THEN - HM = FHMAX *TANH(WNMEAN*MAX(0.,D_INP)) / MAX(1.E-4,WNMEAN ) - EM = HM * HM / 16. - IF ( EMEAN.GT.EM .AND. EMEAN.GT.1.E-30 ) THEN - SPEC = SPEC / EMEAN * EM - EMEAN = EM - END IF - END IF + IF ( DTTOT .GE. 0.9999*DTG ) THEN + HM = FHMAX *TANH(WNMEAN*MAX(0.,D_INP)) / MAX(1.E-4,WNMEAN ) + EM = HM * HM / 16. + IF ( EMEAN.GT.EM .AND. EMEAN.GT.1.E-30 ) THEN + SPEC = SPEC / EMEAN * EM + EMEAN = EM + END IF + END IF #endif -! -! 6.c Seeding of spectrum -! alpha = 0.005 , 0.5 in eq., 0.25 for directional distribution -! + ! + ! 6.c Seeding of spectrum + ! alpha = 0.005 , 0.5 in eq., 0.25 for directional distribution + ! #ifdef W3_SEED - DO IK=MIN(NK,NKH), NK - UC = FACSD * GRAV / SIG(IK) - SLEV = MIN ( 1. , MAX ( 0. , U10ABS/UC-1. ) ) * & - 6.25E-4 / WN1(IK)**3 / SIG(IK) - IF (INFLAGS2(4)) SLEV=SLEV*(1-ICE) - DO ITH=1, NTH - SPEC(ITH+(IK-1)*NTH) = MAX ( SPEC(ITH+(IK-1)*NTH) , & - SLEV * MAX ( 0. , COS(U10DIR-TH(ITH)) )**2 ) - END DO - END DO + DO IK=MIN(NK,NKH), NK + UC = FACSD * GRAV / SIG(IK) + SLEV = MIN ( 1. , MAX ( 0. , U10ABS/UC-1. ) ) * & + 6.25E-4 / WN1(IK)**3 / SIG(IK) + IF (INFLAGS2(4)) SLEV=SLEV*(1-ICE) + DO ITH=1, NTH + SPEC(ITH+(IK-1)*NTH) = MAX ( SPEC(ITH+(IK-1)*NTH) , & + SLEV * MAX ( 0. , COS(U10DIR-TH(ITH)) )**2 ) + END DO + END DO #endif -! -! 6.d Add tail -! - DO IK=NKH+1, NK + ! + ! 6.d Add tail + ! + DO IK=NKH+1, NK #ifdef W3_ST2 - FACDIA = MAX ( 0. , MIN ( 1., (SIG(IK)-FHTRAN)/DFH) ) - FACPAR = MAX ( 0. , 1.-FACDIA ) + FACDIA = MAX ( 0. , MIN ( 1., (SIG(IK)-FHTRAN)/DFH) ) + FACPAR = MAX ( 0. , 1.-FACDIA ) #endif - DO ITH=1, NTH - SPEC(ITH+(IK-1)*NTH) = SPEC(ITH+(IK-2)*NTH) * FACHFA & + DO ITH=1, NTH + SPEC(ITH+(IK-1)*NTH) = SPEC(ITH+(IK-2)*NTH) * FACHFA & #ifdef W3_ST2 - * FACDIA + FACPAR * SPEC(ITH+(IK-1)*NTH) & + * FACDIA + FACPAR * SPEC(ITH+(IK-1)*NTH) & #endif - + 0. - END DO - END DO -! -! 6.e Update wave-supported stress----------------------------------- * -! + + 0. + END DO + END DO + ! + ! 6.e Update wave-supported stress----------------------------------- * + ! #ifdef W3_ST3 - CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & - U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & - ICE, VSIN, VDIN, LLWS, IX, IY ) + CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + ICE, VSIN, VDIN, LLWS, IX, IY ) #endif #ifdef W3_ST4 - CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & - U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & - VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) + CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) #endif -! -! 7. Check if integration complete ---------------------------------- * -! -! Update QI5TSTART (Q. Liu) + ! + ! 7. Check if integration complete ---------------------------------- * + ! + ! Update QI5TSTART (Q. Liu) #ifdef W3_NL5 - CALL TICK21(QI5TSTART, DT) -#endif - IF (srce_call .eq. srce_imp_post) THEN - EXIT - ENDIF - IF ( DTTOT .GE. 0.9999*DTG ) THEN -! IF (IX == DEBUG_NODE) WRITE(*,*) 'DTTOT, DTG', DTTOT, DTG - EXIT - ENDIF - END DO ! INTEGRATIN LOOP + CALL TICK21(QI5TSTART, DT) +#endif + IF (srce_call .eq. srce_imp_post) THEN + EXIT + ENDIF + IF ( DTTOT .GE. 0.9999*DTG ) THEN + ! IF (IX == DEBUG_NODE) WRITE(*,*) 'DTTOT, DTG', DTTOT, DTG + EXIT + ENDIF + END DO ! INTEGRATIN LOOP #ifdef W3_DEBUGSRC - IF (IX .eq. DEBUG_NODE) THEN - WRITE(740+IAPROC,*) 'NSTEPS=', NSTEPS - WRITE(740+IAPROC,*) '1 : sum(SPEC)=', sum(SPEC) - END IF - WRITE(740+IAPROC,*) 'DT=', DT, 'DTG=', DTG -#endif -! -! ... End point dynamic integration - - - - - - - - - - - - - - - - - - -! -! 8. Save integration data ------------------------------------------ * -! - DTDYN = DTDYN / REAL(MAX(1,NSTEPS)) - FCUT = FHIGH * TPIINV -! - GOTO 888 -! -! Error escape locations -! + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) 'NSTEPS=', NSTEPS + WRITE(740+IAPROC,*) '1 : sum(SPEC)=', sum(SPEC) + END IF + WRITE(740+IAPROC,*) 'DT=', DT, 'DTG=', DTG +#endif + ! + ! ... End point dynamic integration - - - - - - - - - - - - - - - - - - + ! + ! 8. Save integration data ------------------------------------------ * + ! + DTDYN = DTDYN / REAL(MAX(1,NSTEPS)) + FCUT = FHIGH * TPIINV + ! + GOTO 888 + ! + ! Error escape locations + ! #ifdef W3_NNT - 800 CONTINUE - WRITE (NDSE,8000) FNAME, IERR - CALL EXTCDE (1) +800 CONTINUE + WRITE (NDSE,8000) FNAME, IERR + CALL EXTCDE (1) #endif -! + ! #ifdef W3_NNT - 801 CONTINUE - WRITE (NDSE,8001) IERR - CALL EXTCDE (2) -#endif -! - 888 CONTINUE -! -! 9.a Computes PHIOC------------------------------------------ * -! The wave to ocean flux is the difference between initial energy -! and final energy, plus wind input plus the SNL flux to high freq., -! minus the energy lost to the bottom boundary layer (BBL) -! +801 CONTINUE + WRITE (NDSE,8001) IERR + CALL EXTCDE (2) +#endif + ! +888 CONTINUE + ! + ! 9.a Computes PHIOC------------------------------------------ * + ! The wave to ocean flux is the difference between initial energy + ! and final energy, plus wind input plus the SNL flux to high freq., + ! minus the energy lost to the bottom boundary layer (BBL) + ! #ifdef W3_DEBUGSRC - IF (IX .eq. DEBUG_NODE) THEN - WRITE(740+IAPROC,*) '2 : sum(SPEC)=', sum(SPEC) - END IF -#endif - EFINISH = 0. - MWXFINISH = 0. - MWYFINISH = 0. - DO IK=1, NK - EBAND = 0. - A1BAND = 0. - B1BAND = 0. - DO ITH=1, NTH - DIFF = SPECINIT(ITH+(IK-1)*NTH)-SPEC(ITH+(IK-1)*NTH) - EBAND = EBAND + DIFF - A1BAND = A1BAND + DIFF*ECOS(ITH) - B1BAND = B1BAND + DIFF*ESIN(ITH) - END DO - EFINISH = EFINISH + EBAND * DDEN(IK) / CG1(IK) - MWXFINISH = MWXFINISH + A1BAND * DDEN(IK) / CG1(IK) & - * WN1(IK)/SIG(IK) - MWYFINISH = MWYFINISH + B1BAND * DDEN(IK) / CG1(IK) & - * WN1(IK)/SIG(IK) - END DO -! -! Transformation in momentum flux in m^2 / s^2 -! - TAUOX=(GRAV*MWXFINISH+TAUWIX-TAUBBL(1))/DTG - TAUOY=(GRAV*MWYFINISH+TAUWIY-TAUBBL(2))/DTG - TAUWIX=TAUWIX/DTG - TAUWIY=TAUWIY/DTG - TAUWNX=TAUWNX/DTG - TAUWNY=TAUWNY/DTG - TAUBBL(:)=TAUBBL(:)/DTG - TAUOCX=DAIR*COEF*COEF*USTAR*USTAR*COS(USTDIR) + DWAT*(TAUOX-TAUWIX) - TAUOCY=DAIR*COEF*COEF*USTAR*USTAR*SIN(USTDIR) + DWAT*(TAUOY-TAUWIY) -! -! Transformation in wave energy flux in W/m^2=kg / s^3 -! - PHIOC =DWAT*GRAV*(EFINISH+PHIAW-PHIBBL)/DTG - PHIAW =DWAT*GRAV*PHIAW /DTG - PHINL =DWAT*GRAV*PHINL /DTG - PHIBBL=DWAT*GRAV*PHIBBL/DTG -! -! 10.1 Adds ice scattering and dissipation: implicit integration---------------- * -! INFLAGS2(4) is true if ice concentration was ever read during -! this simulation -! + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '2 : sum(SPEC)=', sum(SPEC) + END IF +#endif + EFINISH = 0. + MWXFINISH = 0. + MWYFINISH = 0. + DO IK=1, NK + EBAND = 0. + A1BAND = 0. + B1BAND = 0. + DO ITH=1, NTH + DIFF = SPECINIT(ITH+(IK-1)*NTH)-SPEC(ITH+(IK-1)*NTH) + EBAND = EBAND + DIFF + A1BAND = A1BAND + DIFF*ECOS(ITH) + B1BAND = B1BAND + DIFF*ESIN(ITH) + END DO + EFINISH = EFINISH + EBAND * DDEN(IK) / CG1(IK) + MWXFINISH = MWXFINISH + A1BAND * DDEN(IK) / CG1(IK) & + * WN1(IK)/SIG(IK) + MWYFINISH = MWYFINISH + B1BAND * DDEN(IK) / CG1(IK) & + * WN1(IK)/SIG(IK) + END DO + ! + ! Transformation in momentum flux in m^2 / s^2 + ! + TAUOX=(GRAV*MWXFINISH+TAUWIX-TAUBBL(1))/DTG + TAUOY=(GRAV*MWYFINISH+TAUWIY-TAUBBL(2))/DTG + TAUWIX=TAUWIX/DTG + TAUWIY=TAUWIY/DTG + TAUWNX=TAUWNX/DTG + TAUWNY=TAUWNY/DTG + TAUBBL(:)=TAUBBL(:)/DTG + TAUOCX=DAIR*COEF*COEF*USTAR*USTAR*COS(USTDIR) + DWAT*(TAUOX-TAUWIX) + TAUOCY=DAIR*COEF*COEF*USTAR*USTAR*SIN(USTDIR) + DWAT*(TAUOY-TAUWIY) + ! + ! Transformation in wave energy flux in W/m^2=kg / s^3 + ! + PHIOC =DWAT*GRAV*(EFINISH+PHIAW-PHIBBL)/DTG + PHIAW =DWAT*GRAV*PHIAW /DTG + PHINL =DWAT*GRAV*PHINL /DTG + PHIBBL=DWAT*GRAV*PHIBBL/DTG + ! + ! 10.1 Adds ice scattering and dissipation: implicit integration---------------- * + ! INFLAGS2(4) is true if ice concentration was ever read during + ! this simulation + ! #ifdef W3_DEBUGSRC - IF (IX .eq. DEBUG_NODE) THEN - WRITE(740+IAPROC,*) '3 : sum(SPEC)=', sum(SPEC) - END IF + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '3 : sum(SPEC)=', sum(SPEC) + END IF #endif - IF ( INFLAGS2(4).AND.ICE.GT.0 ) THEN + IF ( INFLAGS2(4).AND.ICE.GT.0 ) THEN - IF (IICEDISP) THEN - ICECOEF2 = 1E-6 - CALL LIU_FORWARD_DISPERSION (ICEH,ICECOEF2,DEPTH, & - SIG,WN_R,CG_ICE,ALPHA_LIU) -! - IF (IICESMOOTH) THEN + IF (IICEDISP) THEN + ICECOEF2 = 1E-6 + CALL LIU_FORWARD_DISPERSION (ICEH,ICECOEF2,DEPTH, & + SIG,WN_R,CG_ICE,ALPHA_LIU) + ! + IF (IICESMOOTH) THEN #ifdef W3_IS2 - DO IK=1,NK - SMOOTH_ICEDISP=0. - IF (IS2PARS(14)*(TPI/WN_R(IK)).LT.ICEF) THEN ! IF ICE IS NOT TOO MUCH BROKEN - SMOOTH_ICEDISP=TANH((ICEF-IS2PARS(14)*(TPI/WN_R(IK)))/(ICEF*IS2PARS(13))) - END IF - WN_R(IK)=WN1(IK)*(1-SMOOTH_ICEDISP)+WN_R(IK)*(SMOOTH_ICEDISP) - END DO + DO IK=1,NK + SMOOTH_ICEDISP=0. + IF (IS2PARS(14)*(TPI/WN_R(IK)).LT.ICEF) THEN ! IF ICE IS NOT TOO MUCH BROKEN + SMOOTH_ICEDISP=TANH((ICEF-IS2PARS(14)*(TPI/WN_R(IK)))/(ICEF*IS2PARS(13))) + END IF + WN_R(IK)=WN1(IK)*(1-SMOOTH_ICEDISP)+WN_R(IK)*(SMOOTH_ICEDISP) + END DO #endif END IF - ELSE - WN_R=WN1 - CG_ICE=CG1 - END IF -! - R(:)=1 ! In case IC2 is defined but not IS2 -! + ELSE + WN_R=WN1 + CG_ICE=CG1 + END IF + ! + R(:)=1 ! In case IC2 is defined but not IS2 + ! #ifdef W3_IC1 CALL W3SIC1 ( SPEC,DEPTH, CG1, IX, IY, VSIC, VDIC ) #endif #ifdef W3_IS2 CALL W3SIS2 ( SPEC, DEPTH, ICE, ICEH, ICEF, ICEDMAX, IX, IY, & - VSIR, VDIR, VDIR2, WN1, CG1, WN_R, CG_ICE, R ) + VSIR, VDIR, VDIR2, WN1, CG1, WN_R, CG_ICE, R ) #endif #ifdef W3_IC2 - CALL W3SIC2 ( SPEC, DEPTH, ICEH, ICEF, CG1, WN1,& - IX, IY, VSIC, VDIC, WN_R, CG_ICE, ALPHA_LIU, R) + CALL W3SIC2 ( SPEC, DEPTH, ICEH, ICEF, CG1, WN1,& + IX, IY, VSIC, VDIC, WN_R, CG_ICE, ALPHA_LIU, R) #endif #ifdef W3_IC3 CALL W3SIC3 ( SPEC,DEPTH, CG1, WN1, IX, IY, VSIC, VDIC ) @@ -1942,527 +1945,527 @@ SUBROUTINE W3SRCE ( srce_call, IT, ISEA, JSEA, IX, IY, IMOD, & #ifdef W3_IC5 CALL W3SIC5 ( SPEC,DEPTH, CG1, WN1, IX, IY, VSIC, VDIC ) #endif -! + ! #ifdef W3_IS1 CALL W3SIS1 ( SPEC, ICE, VSIR ) #endif - SPEC2 = SPEC -! - TAUICE(:) = 0. - PHICE = 0. - DO IK=1,NK - IS = 1+(IK-1)*NTH -! -! First part of ice term integration: dissipation part -! - ATT=1. + SPEC2 = SPEC + ! + TAUICE(:) = 0. + PHICE = 0. + DO IK=1,NK + IS = 1+(IK-1)*NTH + ! + ! First part of ice term integration: dissipation part + ! + ATT=1. #ifdef W3_IC1 - ATT=EXP(ICE*VDIC(IS)*DTG) + ATT=EXP(ICE*VDIC(IS)*DTG) #endif #ifdef W3_IC2 - ATT=EXP(ICE*VDIC(IS)*DTG) + ATT=EXP(ICE*VDIC(IS)*DTG) #endif #ifdef W3_IC3 - ATT=EXP(ICE*VDIC(IS)*DTG) + ATT=EXP(ICE*VDIC(IS)*DTG) #endif #ifdef W3_IC4 - ATT=EXP(ICE*VDIC(IS)*DTG) + ATT=EXP(ICE*VDIC(IS)*DTG) #endif #ifdef W3_IC5 - ATT=EXP(ICE*VDIC(IS)*DTG) + ATT=EXP(ICE*VDIC(IS)*DTG) #endif #ifdef W3_IS1 - ATT=ATT*EXP(ICE*VDIR(IS)*DTG) + ATT=ATT*EXP(ICE*VDIR(IS)*DTG) #endif #ifdef W3_IS2 - ATT=ATT*EXP(ICE*VDIR2(IS)*DTG) - IF (IS2PARS(2).EQ.0) THEN ! Reminder : IS2PARS(2) = IS2BACKSCAT -! -! If there is not re-distribution in directions the scattering is just an attenuation -! - ATT=ATT*EXP((ICE*VDIR(IS))*DTG) - END IF -#endif - SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = ATT*SPEC2(1+(IK-1)*NTH:NTH+(IK-1)*NTH) -! -! Second part of ice term integration: scattering including re-distribution in directions -! + ATT=ATT*EXP(ICE*VDIR2(IS)*DTG) + IF (IS2PARS(2).EQ.0) THEN ! Reminder : IS2PARS(2) = IS2BACKSCAT + ! + ! If there is not re-distribution in directions the scattering is just an attenuation + ! + ATT=ATT*EXP((ICE*VDIR(IS))*DTG) + END IF +#endif + SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = ATT*SPEC2(1+(IK-1)*NTH:NTH+(IK-1)*NTH) + ! + ! Second part of ice term integration: scattering including re-distribution in directions + ! #ifdef W3_IS2 - IF (IS2PARS(2).GE.0) THEN - IF (IS2PARS(20).GT.0.5) THEN -! -! Case of isotropic back-scatter: the directional spectrum is decomposed into -! - an isotropic part (ISO): eigenvalue of scattering is 0 -! - the rest (SPEC-ISO): eigenvalue of scattering is VDIR(IS) -! - SCAT = EXP(VDIR(IS)*IS2PARS(2)*DTG) - ISO = SUM(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH))/NTH - SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = ISO & - +(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH)-ISO)*SCAT - ELSE -! -! General solution with matrix exponentials: same as bottom scattering, see Ardhuin & Herbers (JFM 2002) -! - SCATSPEC(1:NTH)=DBLE(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH)) - SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = & + IF (IS2PARS(2).GE.0) THEN + IF (IS2PARS(20).GT.0.5) THEN + ! + ! Case of isotropic back-scatter: the directional spectrum is decomposed into + ! - an isotropic part (ISO): eigenvalue of scattering is 0 + ! - the rest (SPEC-ISO): eigenvalue of scattering is VDIR(IS) + ! + SCAT = EXP(VDIR(IS)*IS2PARS(2)*DTG) + ISO = SUM(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH))/NTH + SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = ISO & + +(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH)-ISO)*SCAT + ELSE + ! + ! General solution with matrix exponentials: same as bottom scattering, see Ardhuin & Herbers (JFM 2002) + ! + SCATSPEC(1:NTH)=DBLE(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH)) + SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = & REAL(MATMUL(IS2EIGVEC(:,:), EXP(IS2EIGVAL(:)*VDIR(IS)*DTG*IS2PARS(2)) & - *MATMUL(TRANSPOSE(IS2EIGVEC(:,:)),SCATSPEC))) - END IF - END IF -#endif -! -! 10.2 Fluxes of energy and momentum due to ice effects -! - FACTOR = DDEN(IK)/CG1(IK) !Jacobian to get energy in band - FACTOR2= FACTOR*GRAV*WN1(IK)/SIG(IK) ! coefficient to get momentum - DO ITH = 1,NTH - IS = ITH+(IK-1)*NTH - PHICE = PHICE + (SPEC(IS)-SPEC2(IS)) * FACTOR - COSI(1)=ECOS(IS) - COSI(2)=ESIN(IS) - TAUICE(:) = TAUICE(:) - (SPEC(IS)-SPEC2(IS))*FACTOR2*COSI(:) - END DO - END DO - PHICE =-1.*DWAT*GRAV*PHICE /DTG - TAUICE(:)=TAUICE(:)/DTG - ELSE + *MATMUL(TRANSPOSE(IS2EIGVEC(:,:)),SCATSPEC))) + END IF + END IF +#endif + ! + ! 10.2 Fluxes of energy and momentum due to ice effects + ! + FACTOR = DDEN(IK)/CG1(IK) !Jacobian to get energy in band + FACTOR2= FACTOR*GRAV*WN1(IK)/SIG(IK) ! coefficient to get momentum + DO ITH = 1,NTH + IS = ITH+(IK-1)*NTH + PHICE = PHICE + (SPEC(IS)-SPEC2(IS)) * FACTOR + COSI(1)=ECOS(IS) + COSI(2)=ESIN(IS) + TAUICE(:) = TAUICE(:) - (SPEC(IS)-SPEC2(IS))*FACTOR2*COSI(:) + END DO + END DO + PHICE =-1.*DWAT*GRAV*PHICE /DTG + TAUICE(:)=TAUICE(:)/DTG + ELSE #ifdef W3_IS2 - IF (IS2PARS(10).LT.0.5) THEN - ICEF = 0. - ENDIF -#endif - END IF -! -! -! - - - - - - - - - - - - - - - - - - - - - - -! 11. Sea state dependent stress routine calls -! - - - - - - - - - - - - - - - - - - - - - - -!Note the Sea-state dependent stress calculations are primarily for high-wind -!conditions (>10 m/s). It is not recommended to use these at lower wind -!in their current state. -! + IF (IS2PARS(10).LT.0.5) THEN + ICEF = 0. + ENDIF +#endif + END IF + ! + ! + ! - - - - - - - - - - - - - - - - - - - - - - + ! 11. Sea state dependent stress routine calls + ! - - - - - - - - - - - - - - - - - - - - - - + !Note the Sea-state dependent stress calculations are primarily for high-wind + !conditions (>10 m/s). It is not recommended to use these at lower wind + !in their current state. + ! #ifdef W3_DEBUGSRC - IF (IX .eq. DEBUG_NODE) THEN - WRITE(740+IAPROC,*) '4 : sum(SPEC)=', sum(SPEC) - END IF + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '4 : sum(SPEC)=', sum(SPEC) + END IF #endif -! FLD1/2 requires the calculation of FPI: + ! FLD1/2 requires the calculation of FPI: #ifdef W3_FLD1 - CALL CALC_FPI(SPEC, CG1, FPI, VSIN ) + CALL CALC_FPI(SPEC, CG1, FPI, VSIN ) #endif #ifdef W3_FLD2 - CALL CALC_FPI(SPEC, CG1, FPI, VSIN ) + CALL CALC_FPI(SPEC, CG1, FPI, VSIN ) #endif -! + ! #ifdef W3_FLD1 - IF (U10ABS.GT.10. .and. HSTOT.gt.0.5) then - CALL W3FLD1 ( SPEC,min(FPI/TPI,2.0),COEF*U10ABS*COS(U10DIR), & - COEF*U10ABS*Sin(U10DIR), ZWND, DEPTH, 0.0, & - DAIR, USTAR, USTDIR, Z0,TAUNUX,TAUNUY,CHARN) - ELSE - CHARN = AALPHA - ENDIF + IF (U10ABS.GT.10. .and. HSTOT.gt.0.5) then + CALL W3FLD1 ( SPEC,min(FPI/TPI,2.0),COEF*U10ABS*COS(U10DIR), & + COEF*U10ABS*Sin(U10DIR), ZWND, DEPTH, 0.0, & + DAIR, USTAR, USTDIR, Z0,TAUNUX,TAUNUY,CHARN) + ELSE + CHARN = AALPHA + ENDIF #endif #ifdef W3_FLD2 - IF (U10ABS.GT.10. .and. HSTOT.gt.0.5) then - CALL W3FLD2 ( SPEC,min(FPI/TPI,2.0),COEF*U10ABS*COS(U10DIR), & - COEF*U10ABS*Sin(U10DIR), ZWND, DEPTH, 0.0, & - DAIR, USTAR, USTDIR, Z0,TAUNUX,TAUNUY,CHARN) - ELSE - CHARN = AALPHA - ENDIF + IF (U10ABS.GT.10. .and. HSTOT.gt.0.5) then + CALL W3FLD2 ( SPEC,min(FPI/TPI,2.0),COEF*U10ABS*COS(U10DIR), & + COEF*U10ABS*Sin(U10DIR), ZWND, DEPTH, 0.0, & + DAIR, USTAR, USTDIR, Z0,TAUNUX,TAUNUY,CHARN) + ELSE + CHARN = AALPHA + ENDIF #endif -! -! 12. includes shoreline reflection --------------------------------------------- * -! + ! + ! 12. includes shoreline reflection --------------------------------------------- * + ! #ifdef W3_DEBUGSRC - IF (IX .eq. DEBUG_NODE) THEN - WRITE(740+IAPROC,*) '5 : sum(SPEC)=', sum(SPEC) - END IF + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '5 : sum(SPEC)=', sum(SPEC) + END IF #endif #ifdef W3_REF1 - IF (REFLEC(1).GT.0.OR.REFLEC(2).GT.0.OR.(REFLEC(4).GT.0.AND.BERG.GT.0)) THEN - CALL W3SREF ( SPEC, CG1, WN1, EMEAN, FMEAN, DEPTH, CX, CY, & - REFLEC, REFLED, TRNX, TRNY, & - BERG, DTG, IX, IY, VREF ) - IF (GTYPE.EQ.UNGTYPE.AND.REFPARS(3).LT.0.5) THEN + IF (REFLEC(1).GT.0.OR.REFLEC(2).GT.0.OR.(REFLEC(4).GT.0.AND.BERG.GT.0)) THEN + CALL W3SREF ( SPEC, CG1, WN1, EMEAN, FMEAN, DEPTH, CX, CY, & + REFLEC, REFLED, TRNX, TRNY, & + BERG, DTG, IX, IY, VREF ) + IF (GTYPE.EQ.UNGTYPE.AND.REFPARS(3).LT.0.5) THEN #endif -!AR: this can be further simplified let's do some simple tests 1st ... + !AR: this can be further simplified let's do some simple tests 1st ... #ifdef W3_REF1 - IF (IOBP(IX).EQ.0) THEN - DO IK=1, NK - DO ITH=1, NTH - IF (IOBPD(ITH,IX).EQ.0) SPEC(ITH+(IK-1)*NTH) = DTG*VREF(ITH+(IK-1)*NTH) - END DO - END DO - ELSE - IF (IOBDP(IX) .EQ. -1) THEN - SPEC(:) = SPEC(:) + DTG * VREF(:) - ENDIF - ENDIF - ELSE + IF (IOBP(IX).EQ.0) THEN + DO IK=1, NK + DO ITH=1, NTH + IF (IOBPD(ITH,IX).EQ.0) SPEC(ITH+(IK-1)*NTH) = DTG*VREF(ITH+(IK-1)*NTH) + END DO + END DO + ELSE + IF (IOBDP(IX) .EQ. -1) THEN SPEC(:) = SPEC(:) + DTG * VREF(:) - END IF - END IF + ENDIF + ENDIF + ELSE + SPEC(:) = SPEC(:) + DTG * VREF(:) + END IF + END IF #endif -! + ! #ifdef W3_DEBUGSRC - IF (IX .eq. DEBUG_NODE) THEN - WRITE(740+IAPROC,*) '6 : sum(SPEC)=', sum(SPEC) - END IF + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '6 : sum(SPEC)=', sum(SPEC) + END IF #endif - FIRST = .FALSE. + FIRST = .FALSE. - IF (IT.EQ.0) SPEC = SPECINIT + IF (IT.EQ.0) SPEC = SPECINIT - SPEC = MAX(0., SPEC) -! - RETURN -! -! Formats -! + SPEC = MAX(0., SPEC) + ! + RETURN + ! + ! Formats + ! #ifdef W3_NNT - 8000 FORMAT (/' *** ERROR W3SRCE : ERROR IN OPENING FILE ',A,' ***'/ & - ' IOSTAT = ',I10/) - 8001 FORMAT (/' *** ERROR W3SRCE : ERROR IN WRITING TO FILE ***'/ & - ' IOSTAT = ',I10/) +8000 FORMAT (/' *** ERROR W3SRCE : ERROR IN OPENING FILE ',A,' ***'/ & + ' IOSTAT = ',I10/) +8001 FORMAT (/' *** ERROR W3SRCE : ERROR IN WRITING TO FILE ***'/ & + ' IOSTAT = ',I10/) #endif -! + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SRCE : COUNTERS : NO LONGER AVAILABLE') - 9001 FORMAT (' TEST W3SRCE : DEPTH :',F8.1/ & - ' WIND SPEED :',F8.1/ & - ' WIND DIR :',F8.1) +9000 FORMAT (' TEST W3SRCE : COUNTERS : NO LONGER AVAILABLE') +9001 FORMAT (' TEST W3SRCE : DEPTH :',F8.1/ & + ' WIND SPEED :',F8.1/ & + ' WIND DIR :',F8.1) #endif #ifdef W3_ST1 - 9004 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & - ' ------------- NEW DYNAMIC INTEGRATION LOOP', & - ' ------------- ') +9004 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' ------------- NEW DYNAMIC INTEGRATION LOOP', & + ' ------------- ') #endif #ifdef W3_ST2 - 9005 FORMAT (' TEST W3SRCE : FHIGH : ',F8.4/ & - ' ------------- NEW DYNAMIC INTEGRATION LOOP', & - ' ------------- ') +9005 FORMAT (' TEST W3SRCE : FHIGH : ',F8.4/ & + ' ------------- NEW DYNAMIC INTEGRATION LOOP', & + ' ------------- ') #endif #ifdef W3_ST3 - 9006 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & - ' ------------- NEW DYNAMIC INTEGRATION LOOP', & - ' ------------- ') +9006 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' ------------- NEW DYNAMIC INTEGRATION LOOP', & + ' ------------- ') #endif #ifdef W3_ST4 - 9006 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & - ' ------------- NEW DYNAMIC INTEGRATION LOOP', & - ' ------------- ') +9006 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' ------------- NEW DYNAMIC INTEGRATION LOOP', & + ' ------------- ') #endif -! + ! #ifdef W3_T - 9020 FORMAT (' TEST W3SRCE : NSTEP : ',I4,' DTTOT :',F6.1) - 9021 FORMAT (' TEST W3SRCE : NKH (3X) : ',2I3,I6) +9020 FORMAT (' TEST W3SRCE : NSTEP : ',I4,' DTTOT :',F6.1) +9021 FORMAT (' TEST W3SRCE : NKH (3X) : ',2I3,I6) #endif -! + ! #ifdef W3_T - 9040 FORMAT (' TEST W3SRCE : DTRAW, DT, SHAVE :',2F6.1,2X,L1) +9040 FORMAT (' TEST W3SRCE : DTRAW, DT, SHAVE :',2F6.1,2X,L1) #endif -! + ! #ifdef W3_ST1 - 9060 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & - ' NKH : ',I3) +9060 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' NKH : ',I3) #endif #ifdef W3_ST2 - 9061 FORMAT (' TEST W3SRCE : FHIGH (2X) : ',2F8.4/ & - ' NKH : ',I3) +9061 FORMAT (' TEST W3SRCE : FHIGH (2X) : ',2F8.4/ & + ' NKH : ',I3) #endif #ifdef W3_ST3 - 9062 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & - ' NKH : ',I3) +9062 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' NKH : ',I3) #endif #ifdef W3_ST4 - 9062 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & - ' NKH : ',I3) +9062 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' NKH : ',I3) #endif #ifdef W3_ST6 - 9063 FORMAT (' TEST W3SRCE : FHIGH : ',F8.4/ & - ' NKH : ',I3) -#endif -!/ -!/ End of W3SRCE ----------------------------------------------------- / -!/ - END SUBROUTINE W3SRCE -!/ ------------------------------------------------------------------- / - SUBROUTINE CALC_FPI( A, CG, FPI, S ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Jessica Meixner | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 06-Jul-2016 : Origination ( version 5.12 ) -!/ 06-Jul-2016 : Add SUBROUTINE SIGN_VSD_SEMI_IMPLICIT_WW3 -!/ Add optional DEBUGSRC/PDLIB ( version 6.04 ) -!/ -! 1. Purpose : -! -! Calculate equivalent peak frequency -! -! 2. Method : -! -! Tolman and Chalikov (1996), equivalent peak frequency from source +9063 FORMAT (' TEST W3SRCE : FHIGH : ',F8.4/ & + ' NKH : ',I3) +#endif + !/ + !/ End of W3SRCE ----------------------------------------------------- / + !/ + END SUBROUTINE W3SRCE + !/ ------------------------------------------------------------------- / + SUBROUTINE CALC_FPI( A, CG, FPI, S ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Jessica Meixner | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 06-Jul-2016 : Origination ( version 5.12 ) + !/ 06-Jul-2016 : Add SUBROUTINE SIGN_VSD_SEMI_IMPLICIT_WW3 + !/ Add optional DEBUGSRC/PDLIB ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Calculate equivalent peak frequency + ! + ! 2. Method : + ! + ! Tolman and Chalikov (1996), equivalent peak frequency from source -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D). -! CG R.A. I Group velocities for k-axis of spectrum. -! FPI R.A. O Input 'peak' frequency. -! S R.A. I Source term (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, DDEN, SIG,FTE, FTTR + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D). + ! CG R.A. I Group velocities for k-axis of spectrum. + ! FPI R.A. O Input 'peak' frequency. + ! S R.A. I Source term (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, DDEN, SIG,FTE, FTTR #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: A(NSPEC), CG(NK), S(NSPEC) - REAL, INTENT(OUT) :: FPI -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IS, IK + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: A(NSPEC), CG(NK), S(NSPEC) + REAL, INTENT(OUT) :: FPI + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IS, IK #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: M0, M1, SIN1A(NK) -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: M0, M1, SIN1A(NK) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'CALC_FPI') -#endif -! -! Calculate FPI: equivalent peak frequncy from wind source term -! input -! - DO IK=1, NK - SIN1A(IK) = 0. - DO IS=(IK-1)*NTH+1, IK*NTH - SIN1A(IK) = SIN1A(IK) + MAX ( 0. , S(IS) ) - END DO + CALL STRACE (IENT, 'CALC_FPI') +#endif + ! + ! Calculate FPI: equivalent peak frequncy from wind source term + ! input + ! + DO IK=1, NK + SIN1A(IK) = 0. + DO IS=(IK-1)*NTH+1, IK*NTH + SIN1A(IK) = SIN1A(IK) + MAX ( 0. , S(IS) ) END DO -! - M0 = 0. - M1 = 0. - DO IK=1, NK - SIN1A(IK) = SIN1A(IK) * DDEN(IK) / ( CG(IK) * SIG(IK)**3 ) - M0 = M0 + SIN1A(IK) - M1 = M1 + SIN1A(IK)/SIG(IK) - END DO -! - SIN1A(NK) = SIN1A(NK) / DDEN(NK) - M0 = M0 + SIN1A(NK) * FTE - M1 = M1 + SIN1A(NK) * FTTR - IF ( M1 .LT. 1E-20 ) THEN - FPI = XFR * SIG(NK) - ELSE - FPI = M0 / M1 - END IF + END DO + ! + M0 = 0. + M1 = 0. + DO IK=1, NK + SIN1A(IK) = SIN1A(IK) * DDEN(IK) / ( CG(IK) * SIG(IK)**3 ) + M0 = M0 + SIN1A(IK) + M1 = M1 + SIN1A(IK)/SIG(IK) + END DO + ! + SIN1A(NK) = SIN1A(NK) / DDEN(NK) + M0 = M0 + SIN1A(NK) * FTE + M1 = M1 + SIN1A(NK) * FTTR + IF ( M1 .LT. 1E-20 ) THEN + FPI = XFR * SIG(NK) + ELSE + FPI = M0 / M1 + END IF - END SUBROUTINE CALC_FPI -!/ ------------------------------------------------------------------- /! - SUBROUTINE SIGN_VSD_SEMI_IMPLICIT_WW3(SPEC, VS, VD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Put source term in matrix same as done always -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END SUBROUTINE CALC_FPI + !/ ------------------------------------------------------------------- /! + SUBROUTINE SIGN_VSD_SEMI_IMPLICIT_WW3(SPEC, VS, VD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Put source term in matrix same as done always + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, only : NTH, NK, NSPEC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, only : NTH, NK, NSPEC + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ - INTEGER :: ISP, ITH, IK, IS - REAL, INTENT(IN) :: SPEC(NSPEC) - REAL, INTENT(INOUT) :: VS(NSPEC), VD(NSPEC) + INTEGER :: ISP, ITH, IK, IS + REAL, INTENT(IN) :: SPEC(NSPEC) + REAL, INTENT(INOUT) :: VS(NSPEC), VD(NSPEC) #ifdef W3_S - CALL STRACE (IENT, 'SIGN_VSD_SEMI_IMPLICIT_WW3') + CALL STRACE (IENT, 'SIGN_VSD_SEMI_IMPLICIT_WW3') #endif - DO IS=1,NSPEC - VD(IS) = MIN(0., VD(IS)) - END DO + DO IS=1,NSPEC + VD(IS) = MIN(0., VD(IS)) + END DO END SUBROUTINE SIGN_VSD_SEMI_IMPLICIT_WW3 -!/ ------------------------------------------------------------------- / - SUBROUTINE SIGN_VSD_PATANKAR_WW3(SPEC, VS, VD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Put source term in matrix Patankar style (experimental) -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE SIGN_VSD_PATANKAR_WW3(SPEC, VS, VD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Put source term in matrix Patankar style (experimental) + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! - USE W3GDATMD, only : NTH, NK, NSPEC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3GDATMD, only : NTH, NK, NSPEC + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: ISP, ITH, IK, IS - REAL, INTENT(IN) :: SPEC(NSPEC) - REAL, INTENT(INOUT) :: VS(NSPEC), VD(NSPEC) + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: ISP, ITH, IK, IS + REAL, INTENT(IN) :: SPEC(NSPEC) + REAL, INTENT(INOUT) :: VS(NSPEC), VD(NSPEC) #ifdef W3_S - CALL STRACE (IENT, 'SIGN_VSD_PATANKAR_WW3') + CALL STRACE (IENT, 'SIGN_VSD_PATANKAR_WW3') #endif - DO IS=1,NSPEC - VD(IS) = MIN(0., VD(IS)) - VS(IS) = MAX(0., VS(IS)) - END DO + DO IS=1,NSPEC + VD(IS) = MIN(0., VD(IS)) + VS(IS) = MAX(0., VS(IS)) + END DO END SUBROUTINE SIGN_VSD_PATANKAR_WW3 -!/ -!/ End of module W3SRCEMD -------------------------------------------- / -!/ - END MODULE W3SRCEMD + !/ + !/ End of module W3SRCEMD -------------------------------------------- / + !/ +END MODULE W3SRCEMD diff --git a/model/src/w3str1md.F90 b/model/src/w3str1md.F90 index b4a7453a4..99ded2892 100644 --- a/model/src/w3str1md.F90 +++ b/model/src/w3str1md.F90 @@ -1,578 +1,578 @@ !> @file !> @brief Contains module W3STR1MD. -!> +!> !> @author A. J. van der Westhuysen @date 13-Jan-2013 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / !> -!> @brief Module for inclusion of triad nonlinear interaction -!> according to Eldeberky's (1996) Lumped Triad Interaction (LTA) +!> @brief Module for inclusion of triad nonlinear interaction +!> according to Eldeberky's (1996) Lumped Triad Interaction (LTA) !> source term. !> !> @author A. J. van der Westhuysen @date 13-Jan-2013 !> - MODULE W3STR1MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 13 Jan-2013 : Origination, based on SWAN v40.91 code ( version 4.08 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Module for inclusion of triad nonlinear interaction according to -! Eldeberky's (1996) Lumped Triad Interaction (LTA) source term. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3STR1 Subr. Public User supplied triad interactions. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! WAVEWATCH III is designed as a highly plug-compatible code. -! Source term modules can be included as self-contained modules, -! with limited changes needed to the interface of routine calls -! in W3SRCE, and in the point postprocessing programs only. -! Codes submitted for inclusion in WAVEWATCH III should be -! self-contained in the way described below, and might be -! provided with distributions fully integrated in the data -! structure, or as an optional version of this module to be -! included by the user. -! -! Rules for preparing a module to be included in or distributed -! with WAVEWATCH III : -! -! - Fully document the code following the outline given in this -! file, and according to all other WAVEWATCH III routines. -! - Provide a file with necessary modifications to W3SRCE and -! all other routines that require modification. -! - Provide a test case with expected results. -! - It is strongly recommended that the programming style used -! in WAVEWATCH III is followed, in particular -! a) for readability, write as if in fixed FORTRAN format -! regarding column use, even though all files are F90 -! free format. -! b) I prefer upper case programming for permanent code, -! as I use lower case in debugging and temporary code. -! -! This module needs to be self-contained in the following way. -! -! a) All saved variables connected with this source term need -! to be declared in the module header. Upon acceptance as -! permanent code, they will be converted to the WAVEWATCH III -! dynamic data structure. -! b) Provide a separate computation and initialization routine. -! In the submission, the initialization should be called -! from the computation routine upon the first call to the -! routine. Upon acceptance as permanent code, the -! initialization routine will be moved to a more appropriate -! location in the code (i.e., being absorbed in ww3_grid or -! being moved to W3IOGR). -! -! See notes in the file below where to add these elements. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! ***************************************** -! *** Declare saved variables here *** -! *** public or private as appropriate *** -! ***************************************** -! - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Triad interaction source term computed using the Lumped -!> Triad Appproximation (LTA) of Eldeberky (1996). -!> -!> @verbatim -!> The parametrized biphase is given by: -!> -!> 0.2 -!> beta = - pi/2 + pi/2 tanh ( ----- ) -!> Ur -!> -!> where Ur is the Ursell number. -!> -!> The source term as function of frequency p is: -!> -!> + - -!> S(p) = S(p) + S(p) -!> -!> in which -!> -!> + -!> S(p) = alpha Cp Cg,p (R(p/2,p/2))**2 sin (|beta|) ( E(p/2)**2 -2 E(p) E(p/2) ) -!> -!> - + -!> S(p) = - 2 S(2p) -!> -!> with alpha a tunable coefficient and R(p/2,p/2) is the interaction -!> coefficient of which the expression can be found in Eldeberky (1996). -!> -!> Note that a slightly adapted formulation of the LTA is used in -!> in the SWAN model: -!> -!> - Only positive contributions to higher harmonics are considered -!> here (no energy is transferred to lower harmonics). -!> -!> - The mean frequency in the expression of the Ursell number -!> is calculated according to the first order moment over the -!> zeroth order moment (personal communication, Y.Eldeberky, 1997). -!> -!> - The interactions are calculated up to 2.5 times the mean -!> frequency only. -!> -!> - Since the spectral grid is logarithmically distributed in frequency -!> space, the interactions between central bin and interacting bin -!> are interpolated such that the distance between these bins is -!> factor 2 (nearly). -!> -!> - The interactions are calculated in terms of energy density -!> instead of action density. So the action density spectrum -!> is firstly converted to the energy density grid, then the -!> interactions are calculated and then the spectrum is converted -!> to the action density spectrum back. -!> @endverbatim -!> -!> @param[in] A Action density spectrum (1-D) -!> @param[in] CG Group velocities. -!> @param[in] WN Wavenumbers. -!> @param[in] DEPTH Mean water depth. -!> @param[in] IX -!> @param[out] S Source term (1-D version). -!> @param[out] D Diagonal term of derivative (1-D version). -!> -!> @author A. J. van der Westhuysen @date 13-Jan-2013 -!> - SUBROUTINE W3STR1 (A, CG, WN, DEPTH, IX, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 13 Jan-2013 : Origination, based on SWAN v40.91 code ( version 4.08 ) -!/ 05 Oct-2016 : Avoiding divide by zero for EMEAN ( version 5.15 ) -!/ -! 1. Purpose : -! -! Triad interaction source term computed using the Lumped Triad -! Appproximation (LTA) of Eldeberky (1996). -! -! 2. Method : -! -! (Taken from SWAN v40.91, based on code by Marcel Zijlema, TU Delft) -! -! The parametrized biphase is given by: -! -! 0.2 -! beta = - pi/2 + pi/2 tanh ( ----- ) -! Ur -! -! where Ur is the Ursell number. -! -! The source term as function of frequency p is: -! -! + - -! S(p) = S(p) + S(p) -! -! in which -! -! + -! S(p) = alpha Cp Cg,p (R(p/2,p/2))**2 sin (|beta|) ( E(p/2)**2 -2 E(p) E(p/2) ) -! -! - + -! S(p) = - 2 S(2p) -! -! with alpha a tunable coefficient and R(p/2,p/2) is the interaction -! coefficient of which the expression can be found in Eldeberky (1996). -! -! Note that a slightly adapted formulation of the LTA is used in -! in the SWAN model: -! -! - Only positive contributions to higher harmonics are considered -! here (no energy is transferred to lower harmonics). -! -! - The mean frequency in the expression of the Ursell number -! is calculated according to the first order moment over the -! zeroth order moment (personal communication, Y.Eldeberky, 1997). -! -! - The interactions are calculated up to 2.5 times the mean -! frequency only. -! -! - Since the spectral grid is logarithmically distributed in frequency -! space, the interactions between central bin and interacting bin -! are interpolated such that the distance between these bins is -! factor 2 (nearly). -! -! - The interactions are calculated in terms of energy density -! instead of action density. So the action density spectrum -! is firstly converted to the energy density grid, then the -! interactions are calculated and then the spectrum is converted -! to the action density spectrum back. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. I Action density spectrum (1-D) -! CG R.A. I Group velocities. -! WN R.A. I Wavenumbers. -! DEPTH Real I Mean water depth. -! EMEAN Real I Mean wave energy. -! FMEAN Real I Mean wave frequency. -! S R.A. O Source term (1-D version). -! D R.A. O Diagonal term of derivative (1-D version). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! Determine resonance condition and the maximum discrete freq. -! for which the interactions are calculated. -! -! If Ursell number larger than prescribed value compute interactions -! Calculate biphase -! Do for each direction -! Convert action density to energy density -! Do for all frequencies -! Calculate interaction coefficient and interaction factor -! Compute interactions and store results in matrix -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, PI, TPI - USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG, DDEN, FTE, FTF - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE +MODULE W3STR1MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 13 Jan-2013 : Origination, based on SWAN v40.91 code ( version 4.08 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Module for inclusion of triad nonlinear interaction according to + ! Eldeberky's (1996) Lumped Triad Interaction (LTA) source term. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3STR1 Subr. Public User supplied triad interactions. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! WAVEWATCH III is designed as a highly plug-compatible code. + ! Source term modules can be included as self-contained modules, + ! with limited changes needed to the interface of routine calls + ! in W3SRCE, and in the point postprocessing programs only. + ! Codes submitted for inclusion in WAVEWATCH III should be + ! self-contained in the way described below, and might be + ! provided with distributions fully integrated in the data + ! structure, or as an optional version of this module to be + ! included by the user. + ! + ! Rules for preparing a module to be included in or distributed + ! with WAVEWATCH III : + ! + ! - Fully document the code following the outline given in this + ! file, and according to all other WAVEWATCH III routines. + ! - Provide a file with necessary modifications to W3SRCE and + ! all other routines that require modification. + ! - Provide a test case with expected results. + ! - It is strongly recommended that the programming style used + ! in WAVEWATCH III is followed, in particular + ! a) for readability, write as if in fixed FORTRAN format + ! regarding column use, even though all files are F90 + ! free format. + ! b) I prefer upper case programming for permanent code, + ! as I use lower case in debugging and temporary code. + ! + ! This module needs to be self-contained in the following way. + ! + ! a) All saved variables connected with this source term need + ! to be declared in the module header. Upon acceptance as + ! permanent code, they will be converted to the WAVEWATCH III + ! dynamic data structure. + ! b) Provide a separate computation and initialization routine. + ! In the submission, the initialization should be called + ! from the computation routine upon the first call to the + ! routine. Upon acceptance as permanent code, the + ! initialization routine will be moved to a more appropriate + ! location in the code (i.e., being absorbed in ww3_grid or + ! being moved to W3IOGR). + ! + ! See notes in the file below where to add these elements. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! ***************************************** + ! *** Declare saved variables here *** + ! *** public or private as appropriate *** + ! ***************************************** + ! + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Triad interaction source term computed using the Lumped + !> Triad Appproximation (LTA) of Eldeberky (1996). + !> + !> @verbatim + !> The parametrized biphase is given by: + !> + !> 0.2 + !> beta = - pi/2 + pi/2 tanh ( ----- ) + !> Ur + !> + !> where Ur is the Ursell number. + !> + !> The source term as function of frequency p is: + !> + !> + - + !> S(p) = S(p) + S(p) + !> + !> in which + !> + !> + + !> S(p) = alpha Cp Cg,p (R(p/2,p/2))**2 sin (|beta|) ( E(p/2)**2 -2 E(p) E(p/2) ) + !> + !> - + + !> S(p) = - 2 S(2p) + !> + !> with alpha a tunable coefficient and R(p/2,p/2) is the interaction + !> coefficient of which the expression can be found in Eldeberky (1996). + !> + !> Note that a slightly adapted formulation of the LTA is used in + !> in the SWAN model: + !> + !> - Only positive contributions to higher harmonics are considered + !> here (no energy is transferred to lower harmonics). + !> + !> - The mean frequency in the expression of the Ursell number + !> is calculated according to the first order moment over the + !> zeroth order moment (personal communication, Y.Eldeberky, 1997). + !> + !> - The interactions are calculated up to 2.5 times the mean + !> frequency only. + !> + !> - Since the spectral grid is logarithmically distributed in frequency + !> space, the interactions between central bin and interacting bin + !> are interpolated such that the distance between these bins is + !> factor 2 (nearly). + !> + !> - The interactions are calculated in terms of energy density + !> instead of action density. So the action density spectrum + !> is firstly converted to the energy density grid, then the + !> interactions are calculated and then the spectrum is converted + !> to the action density spectrum back. + !> @endverbatim + !> + !> @param[in] A Action density spectrum (1-D) + !> @param[in] CG Group velocities. + !> @param[in] WN Wavenumbers. + !> @param[in] DEPTH Mean water depth. + !> @param[in] IX + !> @param[out] S Source term (1-D version). + !> @param[out] D Diagonal term of derivative (1-D version). + !> + !> @author A. J. van der Westhuysen @date 13-Jan-2013 + !> + SUBROUTINE W3STR1 (A, CG, WN, DEPTH, IX, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 13 Jan-2013 : Origination, based on SWAN v40.91 code ( version 4.08 ) + !/ 05 Oct-2016 : Avoiding divide by zero for EMEAN ( version 5.15 ) + !/ + ! 1. Purpose : + ! + ! Triad interaction source term computed using the Lumped Triad + ! Appproximation (LTA) of Eldeberky (1996). + ! + ! 2. Method : + ! + ! (Taken from SWAN v40.91, based on code by Marcel Zijlema, TU Delft) + ! + ! The parametrized biphase is given by: + ! + ! 0.2 + ! beta = - pi/2 + pi/2 tanh ( ----- ) + ! Ur + ! + ! where Ur is the Ursell number. + ! + ! The source term as function of frequency p is: + ! + ! + - + ! S(p) = S(p) + S(p) + ! + ! in which + ! + ! + + ! S(p) = alpha Cp Cg,p (R(p/2,p/2))**2 sin (|beta|) ( E(p/2)**2 -2 E(p) E(p/2) ) + ! + ! - + + ! S(p) = - 2 S(2p) + ! + ! with alpha a tunable coefficient and R(p/2,p/2) is the interaction + ! coefficient of which the expression can be found in Eldeberky (1996). + ! + ! Note that a slightly adapted formulation of the LTA is used in + ! in the SWAN model: + ! + ! - Only positive contributions to higher harmonics are considered + ! here (no energy is transferred to lower harmonics). + ! + ! - The mean frequency in the expression of the Ursell number + ! is calculated according to the first order moment over the + ! zeroth order moment (personal communication, Y.Eldeberky, 1997). + ! + ! - The interactions are calculated up to 2.5 times the mean + ! frequency only. + ! + ! - Since the spectral grid is logarithmically distributed in frequency + ! space, the interactions between central bin and interacting bin + ! are interpolated such that the distance between these bins is + ! factor 2 (nearly). + ! + ! - The interactions are calculated in terms of energy density + ! instead of action density. So the action density spectrum + ! is firstly converted to the energy density grid, then the + ! interactions are calculated and then the spectrum is converted + ! to the action density spectrum back. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. I Action density spectrum (1-D) + ! CG R.A. I Group velocities. + ! WN R.A. I Wavenumbers. + ! DEPTH Real I Mean water depth. + ! EMEAN Real I Mean wave energy. + ! FMEAN Real I Mean wave frequency. + ! S R.A. O Source term (1-D version). + ! D R.A. O Diagonal term of derivative (1-D version). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! Determine resonance condition and the maximum discrete freq. + ! for which the interactions are calculated. + ! + ! If Ursell number larger than prescribed value compute interactions + ! Calculate biphase + ! Do for each direction + ! Convert action density to energy density + ! Do for all frequencies + ! Calculate interaction coefficient and interaction factor + ! Compute interactions and store results in matrix + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, PI, TPI + USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG, DDEN, FTE, FTF + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, A(NSPEC) - INTEGER, INTENT(IN) :: IX - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -! AUX1 : auxiliary real -! AUX2 : auxiliary real -! BIPH : parameterized biphase of the spectrum -! C0 : phase velocity at central bin -! CM : phase velocity at interacting bin -! DEP : water depth -! DEP_2 : water depth to power 2 -! DEP_3 : water depth to power 3 -! E : energy density as function of frequency -! E0 : energy density at central bin -! EM : energy density at interacting bin -! HS : significant wave height -! FT : auxiliary real indicating multiplication factor -! for triad contribution -! I1 : auxiliary integer -! I2 : auxiliary integer -! ID : counter -! IDDUM : loop counter in direction space -! IENT : number of entries -! II : loop counter -! IS : loop counter in frequency space -! ISM : negative range for IS -! ISM1 : negative range for IS -! ISMAX : maximum of the counter in frequency space for -! which the triad interactions are calculated (cut-off) -! ISP : positive range for IS -! ISP1 : positive range for IS -! RINT : interaction coefficient -! SA : interaction contribution of triad -! SIGPICG : sigma times 2pi/Cg (a Jacobian for E(f) -> E(k)) -! SINBPH: absolute sine of biphase -! STRI : total triad contribution -! WISM : interpolation weight factor corresponding to lower harmonic -! WISM1 : interpolation weight factor corresponding to lower harmonic -! WISP : interpolation weight factor corresponding to higher harmonic -! WISP1 : interpolation weight factor corresponding to higher harmonic -! W0 : radian frequency of central bin -! WM : radian frequency of interacting bin -! WN0 : wave number at central bin -! WNM : wave number at interacting bin -! XIS : rate between two succeeding frequency counters -! XISLN : log of XIS -! + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, A(NSPEC) + INTEGER, INTENT(IN) :: IX + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + ! AUX1 : auxiliary real + ! AUX2 : auxiliary real + ! BIPH : parameterized biphase of the spectrum + ! C0 : phase velocity at central bin + ! CM : phase velocity at interacting bin + ! DEP : water depth + ! DEP_2 : water depth to power 2 + ! DEP_3 : water depth to power 3 + ! E : energy density as function of frequency + ! E0 : energy density at central bin + ! EM : energy density at interacting bin + ! HS : significant wave height + ! FT : auxiliary real indicating multiplication factor + ! for triad contribution + ! I1 : auxiliary integer + ! I2 : auxiliary integer + ! ID : counter + ! IDDUM : loop counter in direction space + ! IENT : number of entries + ! II : loop counter + ! IS : loop counter in frequency space + ! ISM : negative range for IS + ! ISM1 : negative range for IS + ! ISMAX : maximum of the counter in frequency space for + ! which the triad interactions are calculated (cut-off) + ! ISP : positive range for IS + ! ISP1 : positive range for IS + ! RINT : interaction coefficient + ! SA : interaction contribution of triad + ! SIGPICG : sigma times 2pi/Cg (a Jacobian for E(f) -> E(k)) + ! SINBPH: absolute sine of biphase + ! STRI : total triad contribution + ! WISM : interpolation weight factor corresponding to lower harmonic + ! WISM1 : interpolation weight factor corresponding to lower harmonic + ! WISP : interpolation weight factor corresponding to higher harmonic + ! WISP1 : interpolation weight factor corresponding to higher harmonic + ! W0 : radian frequency of central bin + ! WM : radian frequency of interacting bin + ! WN0 : wave number at central bin + ! WNM : wave number at interacting bin + ! XIS : rate between two succeeding frequency counters + ! XISLN : log of XIS + ! #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER I1, I2, ID, IDDUM, II, IS, ISM, ISM1, ISMAX, & - ISP, ISP1, ITH, IK - REAL AUX1, AUX2, BIPH, C0, CM, DEP, DEP_2, DEP_3, E0, EM, HS, & - FT, RINT, SIGPICG, SINBPH, STRI, WISM, WISM1, WISP, & - WISP1, W0, WM, WN0, WNM, XIS, XISLN - REAL, ALLOCATABLE :: E(:), SA(:,:) - REAL :: EB(NK), EBAND, EMEAN, SIGM01 -!----- Temp (to be moved) ----- - REAL, ALLOCATABLE :: EF(:),SF(:) - REAL :: PTRIAD(5) - REAL :: URSELL -!------------------------------ -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER I1, I2, ID, IDDUM, II, IS, ISM, ISM1, ISMAX, & + ISP, ISP1, ITH, IK + REAL AUX1, AUX2, BIPH, C0, CM, DEP, DEP_2, DEP_3, E0, EM, HS, & + FT, RINT, SIGPICG, SINBPH, STRI, WISM, WISM1, WISP, & + WISP1, W0, WM, WN0, WNM, XIS, XISLN + REAL, ALLOCATABLE :: E(:), SA(:,:) + REAL :: EB(NK), EBAND, EMEAN, SIGM01 + !----- Temp (to be moved) ----- + REAL, ALLOCATABLE :: EF(:),SF(:) + REAL :: PTRIAD(5) + REAL :: URSELL + !------------------------------ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3STR1') + CALL STRACE (IENT, 'W3STR1') #endif -! -! 0. Initializations ------------------------------------------------ * -! -! ********************************************************** -! *** The initialization routine should include all *** -! *** initialization, including reading data from files. *** -! ********************************************************** -! -!> IF ( FIRST ) THEN -!> CALL INSTR1 -!> FIRST = .FALSE. -!> END IF -! -! 1. .... ----------------------------------------------------------- * -! -!---- Compute SIGM01 (= 2pi/Tm01) for use in source term -! -! 1. Integral over directions -! - SIGM01 = 0. - EMEAN = 0. -! FMEAN = 0. + ! + ! 0. Initializations ------------------------------------------------ * + ! + ! ********************************************************** + ! *** The initialization routine should include all *** + ! *** initialization, including reading data from files. *** + ! ********************************************************** + ! + !> IF ( FIRST ) THEN + !> CALL INSTR1 + !> FIRST = .FALSE. + !> END IF + ! + ! 1. .... ----------------------------------------------------------- * + ! + !---- Compute SIGM01 (= 2pi/Tm01) for use in source term + ! + ! 1. Integral over directions + ! + SIGM01 = 0. + EMEAN = 0. + ! FMEAN = 0. - DO IK=1, NK - EB(IK) = 0. - DO ITH=1, NTH - EB(IK) = EB(IK) + A(ITH+(IK-1)*NTH) - END DO + DO IK=1, NK + EB(IK) = 0. + DO ITH=1, NTH + EB(IK) = EB(IK) + A(ITH+(IK-1)*NTH) END DO -! -! 2. Integrate over directions -! - DO IK=1, NK - EB(IK) = EB(IK) * DDEN(IK) / CG(IK) - EMEAN = EMEAN + EB(IK) - SIGM01 = SIGM01 + EB(IK)*SIG(IK) - END DO -! -! 3. Add tail beyond discrete spectrum -! ( DTH * SIG(NK) absorbed in FTxx ) -! - EBAND = EB(NK) / DDEN(NK) - EMEAN = EMEAN + EBAND * FTE - SIGM01 = SIGM01 + EBAND * FTF -! -! 4. Final processing -! - SIGM01 = MAX ( 1.E-7 , SIGM01 ) / MAX(EMEAN,0.001) + END DO + ! + ! 2. Integrate over directions + ! + DO IK=1, NK + EB(IK) = EB(IK) * DDEN(IK) / CG(IK) + EMEAN = EMEAN + EB(IK) + SIGM01 = SIGM01 + EB(IK)*SIG(IK) + END DO + ! + ! 3. Add tail beyond discrete spectrum + ! ( DTH * SIG(NK) absorbed in FTxx ) + ! + EBAND = EB(NK) / DDEN(NK) + EMEAN = EMEAN + EBAND * FTE + SIGM01 = SIGM01 + EBAND * FTF + ! + ! 4. Final processing + ! + SIGM01 = MAX ( 1.E-7 , SIGM01 ) / MAX(EMEAN,0.001) -!---- Temporary parameters (to be replaced by namelists) ----- - PTRIAD(1) = 0.05 - PTRIAD(2) = 2.5 - PTRIAD(3) = 10. - PTRIAD(4) = 0.2 - PTRIAD(5) = 0.01 + !---- Temporary parameters (to be replaced by namelists) ----- + PTRIAD(1) = 0.05 + PTRIAD(2) = 2.5 + PTRIAD(3) = 10. + PTRIAD(4) = 0.2 + PTRIAD(5) = 0.01 - HS = 4.*SQRT( MAX(0.,EMEAN) ) - URSELL = (GRAV*HS)/(2.*SQRT(2.)*SIGM01**2*DEPTH**2) -!--------------------------------------------- + HS = 4.*SQRT( MAX(0.,EMEAN) ) + URSELL = (GRAV*HS)/(2.*SQRT(2.)*SIGM01**2*DEPTH**2) + !--------------------------------------------- - DEP = DEPTH - DEP_2 = DEP**2 - DEP_3 = DEP**3 -! -! --- compute some indices in sigma space -! - I2 = INT (FLOAT(NK) / 2.) - I1 = I2 - 1 - XIS = SIG(I2) / SIG(I1) - XISLN = LOG( XIS ) + DEP = DEPTH + DEP_2 = DEP**2 + DEP_3 = DEP**3 + ! + ! --- compute some indices in sigma space + ! + I2 = INT (FLOAT(NK) / 2.) + I1 = I2 - 1 + XIS = SIG(I2) / SIG(I1) + XISLN = LOG( XIS ) - ISP = INT( LOG(2.) / XISLN ) - ISP1 = ISP + 1 - WISP = (2. - XIS**ISP) / (XIS**ISP1 - XIS**ISP) - WISP1 = 1. - WISP + ISP = INT( LOG(2.) / XISLN ) + ISP1 = ISP + 1 + WISP = (2. - XIS**ISP) / (XIS**ISP1 - XIS**ISP) + WISP1 = 1. - WISP - ISM = INT( LOG(0.5) / XISLN ) - ISM1 = ISM - 1 - WISM = (XIS**ISM -0.5) / (XIS**ISM - XIS**ISM1) - WISM1 = 1. - WISM + ISM = INT( LOG(0.5) / XISLN ) + ISM1 = ISM - 1 + WISM = (XIS**ISM -0.5) / (XIS**ISM - XIS**ISM1) + WISM1 = 1. - WISM - ALLOCATE (E (1:NK)) - ALLOCATE (SA(1:NTH,1:NK+ISP1)) - E = 0. - SA = 0. + ALLOCATE (E (1:NK)) + ALLOCATE (SA(1:NTH,1:NK+ISP1)) + E = 0. + SA = 0. -! -! --- compute maximum frequency for which interactions are calculated -! - ISMAX = 1 - DO IK = 1, NK - IF ( SIG(IK) .LT. ( PTRIAD(2) * SIGM01) ) THEN - ISMAX = IK - ENDIF - ENDDO - ISMAX = MAX ( ISMAX , ISP1 ) -! -! --- compute 3-wave interactions -! - IF ( URSELL.GE.PTRIAD(5) ) THEN -! -! --- calculate biphase -! - BIPH = (0.5*PI)*(TANH(PTRIAD(4)/URSELL)-1.) - SINBPH = ABS( SIN(BIPH) ) -! - ALLOCATE (EF (1:NK)) - EF = 0. - DO ITH = 1, NTH -! -! --- initialize array with E(f) for the direction considered -! --- (convert from N(k) to E(f) using proper Jacobian) -! - DO IK = 1, NK - E(IK) = A(ITH+(IK-1)*NTH) * TPI * SIG(IK) / CG(IK) -!------------ Test ------------------------------------------ - EF(IK) = EF(IK) + E(IK) -!------------------------------------------------------------ - END DO -! - DO IK = 1, ISMAX + ! + ! --- compute maximum frequency for which interactions are calculated + ! + ISMAX = 1 + DO IK = 1, NK + IF ( SIG(IK) .LT. ( PTRIAD(2) * SIGM01) ) THEN + ISMAX = IK + ENDIF + ENDDO + ISMAX = MAX ( ISMAX , ISP1 ) + ! + ! --- compute 3-wave interactions + ! + IF ( URSELL.GE.PTRIAD(5) ) THEN + ! + ! --- calculate biphase + ! + BIPH = (0.5*PI)*(TANH(PTRIAD(4)/URSELL)-1.) + SINBPH = ABS( SIN(BIPH) ) + ! + ALLOCATE (EF (1:NK)) + EF = 0. + DO ITH = 1, NTH + ! + ! --- initialize array with E(f) for the direction considered + ! --- (convert from N(k) to E(f) using proper Jacobian) + ! + DO IK = 1, NK + E(IK) = A(ITH+(IK-1)*NTH) * TPI * SIG(IK) / CG(IK) + !------------ Test ------------------------------------------ + EF(IK) = EF(IK) + E(IK) + !------------------------------------------------------------ + END DO + ! + DO IK = 1, ISMAX - E0 = E(IK) - W0 = SIG(IK) - WN0 = WN(IK) - C0 = W0 / WN0 + E0 = E(IK) + W0 = SIG(IK) + WN0 = WN(IK) + C0 = W0 / WN0 - IF ( IK.GT.-ISM1 ) THEN - EM = WISM * E(IK+ISM1) + WISM1 * E(IK+ISM) - WM = WISM * SIG(IK+ISM1) + WISM1 * SIG(IK+ISM) - WNM = WISM * WN(IK+ISM1) + WISM1 * WN(IK+ISM) - CM = WM / WNM - ELSE - EM = 0. - WM = 0. - WNM = 0. - CM = 0. - END IF + IF ( IK.GT.-ISM1 ) THEN + EM = WISM * E(IK+ISM1) + WISM1 * E(IK+ISM) + WM = WISM * SIG(IK+ISM1) + WISM1 * SIG(IK+ISM) + WNM = WISM * WN(IK+ISM1) + WISM1 * WN(IK+ISM) + CM = WM / WNM + ELSE + EM = 0. + WM = 0. + WNM = 0. + CM = 0. + END IF - AUX1 = WNM**2 * ( GRAV * DEP + 2.*CM**2 ) - AUX2 = WN0 * DEP * ( GRAV * DEP + & - (2./15.) * GRAV * DEP_3 * WN0**2 - & - (2./ 5.) * W0**2 * DEP_2 ) - RINT = AUX1 / AUX2 - FT = PTRIAD(1) * C0 * CG(IK) * RINT**2 * SINBPH + AUX1 = WNM**2 * ( GRAV * DEP + 2.*CM**2 ) + AUX2 = WN0 * DEP * ( GRAV * DEP + & + (2./15.) * GRAV * DEP_3 * WN0**2 - & + (2./ 5.) * W0**2 * DEP_2 ) + RINT = AUX1 / AUX2 + FT = PTRIAD(1) * C0 * CG(IK) * RINT**2 * SINBPH - SA(ITH,IK) = MAX(0., FT * ( EM * EM - 2. * EM * E0 )) + SA(ITH,IK) = MAX(0., FT * ( EM * EM - 2. * EM * E0 )) - END DO END DO - DEALLOCATE(EF) -! -! --- put source and diagonal terms together -! (using Jacobian for S(f) -> S(k)) -! - ALLOCATE (SF (1:NK)) - SF = 0. - DO IK = 1, NK - SIGPICG = SIG(IK) * 2. * PI / CG(IK) - DO ITH = 1, NTH -! --- Source term - S(ITH+(IK-1)*NTH) = 2.*( SA(ITH,IK) - & - 2.*(WISP * SA(ITH,IK+ISP1) + & - WISP1 * SA(ITH,IK+ISP )) ) / & - SIGPICG - SF(IK) = 2.*( SA(ITH,IK) - & - 2.*(WISP * SA(ITH,IK+ISP1) + & - WISP1 * SA(ITH,IK+ISP )) ) + SF(IK) -! --- Diagonal term - D = 0. - END DO + END DO + DEALLOCATE(EF) + ! + ! --- put source and diagonal terms together + ! (using Jacobian for S(f) -> S(k)) + ! + ALLOCATE (SF (1:NK)) + SF = 0. + DO IK = 1, NK + SIGPICG = SIG(IK) * 2. * PI / CG(IK) + DO ITH = 1, NTH + ! --- Source term + S(ITH+(IK-1)*NTH) = 2.*( SA(ITH,IK) - & + 2.*(WISP * SA(ITH,IK+ISP1) + & + WISP1 * SA(ITH,IK+ISP )) ) / & + SIGPICG + SF(IK) = 2.*( SA(ITH,IK) - & + 2.*(WISP * SA(ITH,IK+ISP1) + & + WISP1 * SA(ITH,IK+ISP )) ) + SF(IK) + ! --- Diagonal term + D = 0. END DO - DEALLOCATE(SF) + END DO + DEALLOCATE(SF) - ELSE - D = 0. - S = 0. - END IF + ELSE + D = 0. + S = 0. + END IF - DEALLOCATE(E,SA) + DEALLOCATE(E,SA) - RETURN -!/ -!/ End of W3STR1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3STR1 -!/ ------------------------------------------------------------------- / - END MODULE W3STR1MD + RETURN + !/ + !/ End of W3STR1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3STR1 + !/ ------------------------------------------------------------------- / +END MODULE W3STR1MD diff --git a/model/src/w3str2md.F90 b/model/src/w3str2md.F90 index 3ef0a7001..4efc63429 100644 --- a/model/src/w3str2md.F90 +++ b/model/src/w3str2md.F90 @@ -1,449 +1,449 @@ !> @file !> @brief Contains module W3STR2MD. -!> +!> !> @author A. Roland @date 29-May-2012 -!> +!> !/ ------------------------------------------------------------------- / !> !> @brief This piece of code computes the triad interaction term in -!> the same way as done in the SWAN model. -!> +!> the same way as done in the SWAN model. +!> !> @details The approach is truncated version of the work of Elderberky. -!> In SWAN the wave spectra is treated as one-dimensional and the +!> In SWAN the wave spectra is treated as one-dimensional and the !> transfer to the higher harmoics is taken into account for this -!> no justification is given and it has to be further investigated. -!> The approximation of Elderberky is for a flat bottom (actually -!> bragg-0 resonance). The biggest problem is that it is not -!> conservative, which is the biggest limitation factor. Moreover it -!> is questionable if it was taken into account the in spectral -!> wave models the freq. bandwidths are exponentially distributed in -!> freq. space, which leads to the problem that it is possible that -!> some jacobian transformation is missing the derivation of the -!> discrete form, I am now looking into this and I hope that I can +!> no justification is given and it has to be further investigated. +!> The approximation of Elderberky is for a flat bottom (actually +!> bragg-0 resonance). The biggest problem is that it is not +!> conservative, which is the biggest limitation factor. Moreover it +!> is questionable if it was taken into account the in spectral +!> wave models the freq. bandwidths are exponentially distributed in +!> freq. space, which leads to the problem that it is possible that +!> some jacobian transformation is missing the derivation of the +!> discrete form, I am now looking into this and I hope that I can !> give some closure soon. !> !> @author A. Roland @date 29-May-2012 !> - MODULE W3STR2MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Roland (IT&E) | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2012 | -!/ +-----------------------------------+ -!/ -!/ 15-Jul-2005 : Origination. ( version 3.07 ) -!/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) -!/ inclusion in WAVEWATCH III. -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! This peace of code computes the triad interaction term in the same way -! as done in the SWAN model. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3STR2 Subr. Public User supplied triad interactions. -! INSTR2 Subr. Public Corresponding initialization routine. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : The approach is truncated version of the work of Elderberky. -! In SWAN the wave spectra is treated as one-dimensional and -! only the transfer to the higher harmoics is taken into account -! for this no justification is given and it has to be further investigated. -! The approximation of Elderberky is for a flat bottom (actually bragg-0 resonance) -! The biggest problem is that it is not conservative, which is the biggest limitation factor. -! Moreover it is questionable if it was taken into account the in spectral wave models the -! freq. bandwidths are exponentially distributed in freq. space, which leads to the problem that -! it is possible that some jacobian transformation is missing the derivation of hte discrete form, -! I am now looking into this and I hope that I can give some closure soon. -! -! -! See notes in the file below where to add these elements. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! ***************************************** -! *** Declare saved variables here *** -! *** public or private as appropriate *** -! ***************************************** -! - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Slot for user-supplied triad interaction source term. -!> -!> @param[in] A -!> @param[in] CG -!> @param[in] WN -!> @param[in] DEPTH -!> @param[in] IX -!> @param[out] S -!> @param[out] D -!> -!> @author A. Roland @date 02-Feb-2014 -!> - SUBROUTINE W3STR2 (A, CG, WN, DEPTH, IX, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Roland | -!/ | FORTRAN 90 | -!/ | Last update : 2-Feb-2014 | -!/ +-----------------------------------+ -!/ -!/ 15-Jul-2005 : Origination. ( version 3.07 ) -!/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) -!/ inclusion in WAVEWATCH III. -!/ -! 1. Purpose : -! -! Slot for user-supplied triad interaction source term. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! Determine resonance condition and the maximum discrete freq. -! for which the interactions are calculated. -! -! If Ursell number larger than prescribed value compute interactions -! Check resolution -! Calculate biphase -! Do for each direction -! Convert action density to energy density -! Do for all frequencies -! Calculate interaction coefficient and interaction factor -! Compute interactions and store results in matrix -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, PI, TPI - USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG, DDEN, FTE, FTF, PPTRIAD - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE +MODULE W3STR2MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Roland (IT&E) | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2012 | + !/ +-----------------------------------+ + !/ + !/ 15-Jul-2005 : Origination. ( version 3.07 ) + !/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) + !/ inclusion in WAVEWATCH III. + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! This peace of code computes the triad interaction term in the same way + ! as done in the SWAN model. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3STR2 Subr. Public User supplied triad interactions. + ! INSTR2 Subr. Public Corresponding initialization routine. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : The approach is truncated version of the work of Elderberky. + ! In SWAN the wave spectra is treated as one-dimensional and + ! only the transfer to the higher harmoics is taken into account + ! for this no justification is given and it has to be further investigated. + ! The approximation of Elderberky is for a flat bottom (actually bragg-0 resonance) + ! The biggest problem is that it is not conservative, which is the biggest limitation factor. + ! Moreover it is questionable if it was taken into account the in spectral wave models the + ! freq. bandwidths are exponentially distributed in freq. space, which leads to the problem that + ! it is possible that some jacobian transformation is missing the derivation of hte discrete form, + ! I am now looking into this and I hope that I can give some closure soon. + ! + ! + ! See notes in the file below where to add these elements. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! ***************************************** + ! *** Declare saved variables here *** + ! *** public or private as appropriate *** + ! ***************************************** + ! + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Slot for user-supplied triad interaction source term. + !> + !> @param[in] A + !> @param[in] CG + !> @param[in] WN + !> @param[in] DEPTH + !> @param[in] IX + !> @param[out] S + !> @param[out] D + !> + !> @author A. Roland @date 02-Feb-2014 + !> + SUBROUTINE W3STR2 (A, CG, WN, DEPTH, IX, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Roland | + !/ | FORTRAN 90 | + !/ | Last update : 2-Feb-2014 | + !/ +-----------------------------------+ + !/ + !/ 15-Jul-2005 : Origination. ( version 3.07 ) + !/ 23-Jun-2006 : Formatted for submitting code for ( version 3.09 ) + !/ inclusion in WAVEWATCH III. + !/ + ! 1. Purpose : + ! + ! Slot for user-supplied triad interaction source term. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! Determine resonance condition and the maximum discrete freq. + ! for which the interactions are calculated. + ! + ! If Ursell number larger than prescribed value compute interactions + ! Check resolution + ! Calculate biphase + ! Do for each direction + ! Convert action density to energy density + ! Do for all frequencies + ! Calculate interaction coefficient and interaction factor + ! Compute interactions and store results in matrix + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, PI, TPI + USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG, DDEN, FTE, FTF, PPTRIAD + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, A(NSPEC) - INTEGER, INTENT(IN) :: IX - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -! AUX1 : auxiliary real -! AUX2 : auxiliary real -! BIPH : parameterized biphase of the spectrum -! C0 : phase velocity at central bin -! CM : phase velocity at interacting bin -! DEP : water depth -! DEP_2 : water depth to power 2 -! DEP_3 : water depth to power 3 -! E : energy density as function of frequency -! E0 : energy density at central bin -! EM : energy density at interacting bin -! HS : significant wave height -! FT : auxiliary real indicating multiplication factor -! for triad contribution -! I1 : auxiliary integer -! I2 : auxiliary integer -! ID : counter -! IDDUM : loop counter in direction space -! IENT : number of entries -! II : loop counter -! IS : loop counter in frequency space -! ISM : negative range for IS -! ISM1 : negative range for IS -! ISMAX : maximum of the counter in frequency space for -! which the triad interactions are calculated (cut-off) -! ISP : positive range for IS -! ISP1 : positive range for IS -! RINT : interaction coefficient -! SA : interaction contribution of triad -! SIGPICG : sigma times 2pi/Cg (a Jacobian for E(f) -> E(k)) -! SINBPH: absolute sine of biphase -! STRI : total triad contribution -! WISM : interpolation weight factor corresponding to lower harmonic -! WISM1 : interpolation weight factor corresponding to lower harmonic -! WISP : interpolation weight factor corresponding to higher harmonic -! WISP1 : interpolation weight factor corresponding to higher harmonic -! W0 : radian frequency of central bin -! WM : radian frequency of interacting bin -! WN0 : wave number at central bin -! WNM : wave number at interacting bin -! XIS : rate between two succeeding frequency counters -! XISLN : log of XIS -! + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, A(NSPEC) + INTEGER, INTENT(IN) :: IX + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + ! AUX1 : auxiliary real + ! AUX2 : auxiliary real + ! BIPH : parameterized biphase of the spectrum + ! C0 : phase velocity at central bin + ! CM : phase velocity at interacting bin + ! DEP : water depth + ! DEP_2 : water depth to power 2 + ! DEP_3 : water depth to power 3 + ! E : energy density as function of frequency + ! E0 : energy density at central bin + ! EM : energy density at interacting bin + ! HS : significant wave height + ! FT : auxiliary real indicating multiplication factor + ! for triad contribution + ! I1 : auxiliary integer + ! I2 : auxiliary integer + ! ID : counter + ! IDDUM : loop counter in direction space + ! IENT : number of entries + ! II : loop counter + ! IS : loop counter in frequency space + ! ISM : negative range for IS + ! ISM1 : negative range for IS + ! ISMAX : maximum of the counter in frequency space for + ! which the triad interactions are calculated (cut-off) + ! ISP : positive range for IS + ! ISP1 : positive range for IS + ! RINT : interaction coefficient + ! SA : interaction contribution of triad + ! SIGPICG : sigma times 2pi/Cg (a Jacobian for E(f) -> E(k)) + ! SINBPH: absolute sine of biphase + ! STRI : total triad contribution + ! WISM : interpolation weight factor corresponding to lower harmonic + ! WISM1 : interpolation weight factor corresponding to lower harmonic + ! WISP : interpolation weight factor corresponding to higher harmonic + ! WISP1 : interpolation weight factor corresponding to higher harmonic + ! W0 : radian frequency of central bin + ! WM : radian frequency of interacting bin + ! WN0 : wave number at central bin + ! WNM : wave number at interacting bin + ! XIS : rate between two succeeding frequency counters + ! XISLN : log of XIS + ! #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER I1, I2, ID, IDDUM, IENT, II, IS, ISM, ISM1, ISMAX, & - ISP, ISP1, ITH, IK - REAL AUX1, AUX2, BIPH, C0, CM, DEP, DEP_2, DEP_3, E0, EM, HS, & - FT, RINT, SIGPICG, SINBPH, STRI, WISM, WISM1, WISP, & - WISP1, W0, WM, WN0, WNM, XIS, XISLN - REAL, ALLOCATABLE :: E(:), SA(:,:) - REAL :: EB(NK), EBAND, EMEAN, SIGM01 -!----- Temp (to be moved) ----- - REAL, ALLOCATABLE :: EF(:),SF(:) - REAL :: URSELL -!------------------------------ -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER I1, I2, ID, IDDUM, IENT, II, IS, ISM, ISM1, ISMAX, & + ISP, ISP1, ITH, IK + REAL AUX1, AUX2, BIPH, C0, CM, DEP, DEP_2, DEP_3, E0, EM, HS, & + FT, RINT, SIGPICG, SINBPH, STRI, WISM, WISM1, WISP, & + WISP1, W0, WM, WN0, WNM, XIS, XISLN + REAL, ALLOCATABLE :: E(:), SA(:,:) + REAL :: EB(NK), EBAND, EMEAN, SIGM01 + !----- Temp (to be moved) ----- + REAL, ALLOCATABLE :: EF(:),SF(:) + REAL :: URSELL + !------------------------------ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3STR2') + CALL STRACE (IENT, 'W3STR2') #endif -! -! 0. Initializations ------------------------------------------------ * -! -! ********************************************************** -! *** The initialization routine should include all *** -! *** initialization, including reading data from files. *** -! ********************************************************** -! -! 1. .... ----------------------------------------------------------- * -! -!---- Compute SIGM01 (= 2pi/Tm01) for use in source term -! -! 1. Integral over directions -! - SIGM01 = 0. - EMEAN = 0. -! FMEAN = 0. + ! + ! 0. Initializations ------------------------------------------------ * + ! + ! ********************************************************** + ! *** The initialization routine should include all *** + ! *** initialization, including reading data from files. *** + ! ********************************************************** + ! + ! 1. .... ----------------------------------------------------------- * + ! + !---- Compute SIGM01 (= 2pi/Tm01) for use in source term + ! + ! 1. Integral over directions + ! + SIGM01 = 0. + EMEAN = 0. + ! FMEAN = 0. - DO IK=1, NK - EB(IK) = 0. - DO ITH=1, NTH - EB(IK) = EB(IK) + A(ITH+(IK-1)*NTH) - END DO - END DO -! -! 2. Integrate over wave numbers -! - DO IK=1, NK - EB(IK) = EB(IK) * DDEN(IK) / CG(IK) - EMEAN = EMEAN + EB(IK) - SIGM01 = SIGM01 + EB(IK)*SIG(IK) + DO IK=1, NK + EB(IK) = 0. + DO ITH=1, NTH + EB(IK) = EB(IK) + A(ITH+(IK-1)*NTH) END DO -! -! 3. Add tail beyond discrete spectrum -! ( DTH * SIG(NK) absorbed in FTxx ) -! - EBAND = EB(NK) / DDEN(NK) - EMEAN = EMEAN + EBAND * FTE - SIGM01 = SIGM01 + EBAND * FTF -! -! 4. Final processing -! - SIGM01 = MAX ( 1.E-7 , SIGM01 ) / EMEAN + END DO + ! + ! 2. Integrate over wave numbers + ! + DO IK=1, NK + EB(IK) = EB(IK) * DDEN(IK) / CG(IK) + EMEAN = EMEAN + EB(IK) + SIGM01 = SIGM01 + EB(IK)*SIG(IK) + END DO + ! + ! 3. Add tail beyond discrete spectrum + ! ( DTH * SIG(NK) absorbed in FTxx ) + ! + EBAND = EB(NK) / DDEN(NK) + EMEAN = EMEAN + EBAND * FTE + SIGM01 = SIGM01 + EBAND * FTF + ! + ! 4. Final processing + ! + SIGM01 = MAX ( 1.E-7 , SIGM01 ) / EMEAN - IF (ABS(FACSCL-2.).GT.0.05) THEN - FACRES = 10.**( LOG10(2.) / FLOAT(IRES) ) - SIGLOW = SIG(NK) / ( FACRES**(FLOAT(NK-1) ) ) -! WRITE (*,*) 'CHECK RESOLUTION', IRES, FACSCL, FACRES, SIGLOW - END IF + IF (ABS(FACSCL-2.).GT.0.05) THEN + FACRES = 10.**( LOG10(2.) / FLOAT(IRES) ) + SIGLOW = SIG(NK) / ( FACRES**(FLOAT(NK-1) ) ) + ! WRITE (*,*) 'CHECK RESOLUTION', IRES, FACSCL, FACRES, SIGLOW + END IF - HS = 4.*SQRT( MAX(0.,EMEAN) ) - URSELL = (GRAV*HS)/(2.*SQRT(2.)*SIGM01**2*DEPTH**2) -!--------------------------------------------- + HS = 4.*SQRT( MAX(0.,EMEAN) ) + URSELL = (GRAV*HS)/(2.*SQRT(2.)*SIGM01**2*DEPTH**2) + !--------------------------------------------- - DEP = DEPTH - DEP_2 = DEP**2 - DEP_3 = DEP**3 -! -! --- compute some indices in sigma space -! - I2 = INT (FLOAT(NK) / 2.) - I1 = I2 - 1 - XIS = SIG(I2) / SIG(I1) - XISLN = LOG( XIS ) + DEP = DEPTH + DEP_2 = DEP**2 + DEP_3 = DEP**3 + ! + ! --- compute some indices in sigma space + ! + I2 = INT (FLOAT(NK) / 2.) + I1 = I2 - 1 + XIS = SIG(I2) / SIG(I1) + XISLN = LOG( XIS ) - ISP = INT( LOG(2.) / XISLN ) - ISP1 = ISP + 1 - WISP = (2. - XIS**ISP) / (XIS**ISP1 - XIS**ISP) - WISP1 = 1. - WISP + ISP = INT( LOG(2.) / XISLN ) + ISP1 = ISP + 1 + WISP = (2. - XIS**ISP) / (XIS**ISP1 - XIS**ISP) + WISP1 = 1. - WISP - ISM = INT( LOG(0.5) / XISLN ) - ISM1 = ISM - 1 - WISM = (XIS**ISM -0.5) / (XIS**ISM - XIS**ISM1) - WISM1 = 1. - WISM + ISM = INT( LOG(0.5) / XISLN ) + ISM1 = ISM - 1 + WISM = (XIS**ISM -0.5) / (XIS**ISM - XIS**ISM1) + WISM1 = 1. - WISM - ALLOCATE (E (1:NK)) - ALLOCATE (SA(1:NTH,1:NK+ISP1)) - E = 0. - SA = 0. + ALLOCATE (E (1:NK)) + ALLOCATE (SA(1:NTH,1:NK+ISP1)) + E = 0. + SA = 0. -! -! --- compute maximum frequency for which interactions are calculated -! - ISMAX = 1 - DO IK = 1, NK - IF ( SIG(IK) .LT. ( PPTRIAD(2) * SIGM01) ) THEN - ISMAX = IK - ENDIF - ENDDO - ISMAX = MAX ( ISMAX , ISP1 ) -! -! --- compute 3-wave interactions -! - IF ( URSELL.GE.PPTRIAD(5) ) THEN -! -! --- calculate biphase -! - BIPH = (0.5*PI)*(TANH(PPTRIAD(4)/URSELL)-1.) - SINBPH = ABS( SIN(BIPH) ) -! - ALLOCATE (EF (1:NK)) - EF = 0. - DO ITH = 1, NTH -! -! --- initialize array with E(f) for the direction considered -! --- (convert from N(k) to E(f) using proper Jacobian) -! - DO IK = 1, NK - E(IK) = A(ITH+(IK-1)*NTH) * TPI * SIG(IK) / CG(IK) - EF(IK) = EF(IK) + E(IK) - END DO -! - DO IK = 1, ISMAX + ! + ! --- compute maximum frequency for which interactions are calculated + ! + ISMAX = 1 + DO IK = 1, NK + IF ( SIG(IK) .LT. ( PPTRIAD(2) * SIGM01) ) THEN + ISMAX = IK + ENDIF + ENDDO + ISMAX = MAX ( ISMAX , ISP1 ) + ! + ! --- compute 3-wave interactions + ! + IF ( URSELL.GE.PPTRIAD(5) ) THEN + ! + ! --- calculate biphase + ! + BIPH = (0.5*PI)*(TANH(PPTRIAD(4)/URSELL)-1.) + SINBPH = ABS( SIN(BIPH) ) + ! + ALLOCATE (EF (1:NK)) + EF = 0. + DO ITH = 1, NTH + ! + ! --- initialize array with E(f) for the direction considered + ! --- (convert from N(k) to E(f) using proper Jacobian) + ! + DO IK = 1, NK + E(IK) = A(ITH+(IK-1)*NTH) * TPI * SIG(IK) / CG(IK) + EF(IK) = EF(IK) + E(IK) + END DO + ! + DO IK = 1, ISMAX - E0 = E(IK) - W0 = SIG(IK) - WN0 = WN(IK) - C0 = W0 / WN0 + E0 = E(IK) + W0 = SIG(IK) + WN0 = WN(IK) + C0 = W0 / WN0 - IF ( IK.GT.-ISM1 ) THEN - EM = WISM * E(IK+ISM1) + WISM1 * E(IK+ISM) - WM = WISM * SIG(IK+ISM1) + WISM1 * SIG(IK+ISM) - WNM = WISM * WN(IK+ISM1) + WISM1 * WN(IK+ISM) - CM = WM / WNM - ELSE - EM = 0. - WM = 0. - WNM = 0. - CM = 0. - END IF + IF ( IK.GT.-ISM1 ) THEN + EM = WISM * E(IK+ISM1) + WISM1 * E(IK+ISM) + WM = WISM * SIG(IK+ISM1) + WISM1 * SIG(IK+ISM) + WNM = WISM * WN(IK+ISM1) + WISM1 * WN(IK+ISM) + CM = WM / WNM + ELSE + EM = 0. + WM = 0. + WNM = 0. + CM = 0. + END IF - AUX1 = WNM**2 * ( GRAV * DEP + 2.*CM**2 ) - AUX2 = WN0 * DEP * ( GRAV * DEP + & - (2./15.) * GRAV * DEP_3 * WN0**2 - & - (2./ 5.) * W0**2 * DEP_2 ) - RINT = AUX1 / AUX2 - FT = PPTRIAD(1) * C0 * CG(IK) * RINT**2 * SINBPH + AUX1 = WNM**2 * ( GRAV * DEP + 2.*CM**2 ) + AUX2 = WN0 * DEP * ( GRAV * DEP + & + (2./15.) * GRAV * DEP_3 * WN0**2 - & + (2./ 5.) * W0**2 * DEP_2 ) + RINT = AUX1 / AUX2 + FT = PPTRIAD(1) * C0 * CG(IK) * RINT**2 * SINBPH - SA(ITH,IK) = MAX(0., FT * ( EM * EM - 2. * EM * E0 )) + SA(ITH,IK) = MAX(0., FT * ( EM * EM - 2. * EM * E0 )) - END DO END DO + END DO - DEALLOCATE(EF) -! -! --- put source and diagonal terms together -! (using Jacobian for S(f) -> S(k)) -! - ALLOCATE (SF (1:NK)) - SF = 0. - DO IK = 1, NK - SIGPICG = SIG(IK) * 2. * PI / CG(IK) - DO ITH = 1, NTH -! --- Source term - S(ITH+(IK-1)*NTH) = 2.*( SA(ITH,IK) - & - 2.*(WISP * SA(ITH,IK+ISP1) + & - WISP1 * SA(ITH,IK+ISP )) ) / & - SIGPICG -! --- Functional derivative - SF(IK) = 2.*( SA(ITH,IK) - & - 2.*(WISP * SA(ITH,IK+ISP1) + & - WISP1 * SA(ITH,IK+ISP )) ) + SF(IK) - D = 0. - END DO + DEALLOCATE(EF) + ! + ! --- put source and diagonal terms together + ! (using Jacobian for S(f) -> S(k)) + ! + ALLOCATE (SF (1:NK)) + SF = 0. + DO IK = 1, NK + SIGPICG = SIG(IK) * 2. * PI / CG(IK) + DO ITH = 1, NTH + ! --- Source term + S(ITH+(IK-1)*NTH) = 2.*( SA(ITH,IK) - & + 2.*(WISP * SA(ITH,IK+ISP1) + & + WISP1 * SA(ITH,IK+ISP )) ) / & + SIGPICG + ! --- Functional derivative + SF(IK) = 2.*( SA(ITH,IK) - & + 2.*(WISP * SA(ITH,IK+ISP1) + & + WISP1 * SA(ITH,IK+ISP )) ) + SF(IK) + D = 0. END DO - DEALLOCATE(SF) + END DO + DEALLOCATE(SF) - ELSE - D = 0. - S = 0. - END IF + ELSE + D = 0. + S = 0. + END IF - DEALLOCATE(E,SA) + DEALLOCATE(E,SA) - RETURN -!/ -!/ End of W3STR2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3STR2 -!/ ------------------------------------------------------------------- / -!/ - END MODULE W3STR2MD + RETURN + !/ + !/ End of W3STR2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3STR2 + !/ ------------------------------------------------------------------- / + !/ +END MODULE W3STR2MD diff --git a/model/src/w3strkmd.F90 b/model/src/w3strkmd.F90 index 7967c2417..d02a22f7b 100644 --- a/model/src/w3strkmd.F90 +++ b/model/src/w3strkmd.F90 @@ -1,1067 +1,1067 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3STRKMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 03-Mar-2016 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ 29-Nov-2013 : Remove DOC control characters, -!/ update MPI! to MPI/! (H. L. Tolman). ( version 4.15 ) -!/ 26-Sep-2016 : Optimization updates (A. van der Westhuysen) -!/ ( version 5.15 ) -!/ 03-Mar-2016 : Optimization updates for INTERSECT, -!/ UNION, UNIQUE, SORT, SETDIFF, FINDIJ -!/ (S. Zieger, BoM Australia) ( version 5.16 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - use constants, only: file_endian - IMPLICIT NONE -! -! 1. Purpose : -! -! Module containing data structures and subroutines for spatial and -! temporal tracking (part of wave partitioning). -! -! 2. Method : -! -! Read raw partitioning data. -! Perform tracking in space. -! Perform tracking in time. -! -! 3. Variables and types : -! -! NOTE: In Fortran 90/95 derived types cannot contain allocatable arrays. -! The same functionality is achieved here using pointers (pointing -! to unnamed allocatable arrays). Can be replaced by allocatable arrays -! when transitioning to the Fortran 2003 standard. -! -! Name Type Description -! ---------------------------------------------------------------- -! param Der. type structure of basic spectrally partitioned results at a geo point -! hs Real arr array of sign. wave height partitions -! tp Real arr array of peak period partitions -! dir Real arr array of mean direction partitions -! dspr Real arr array of mean directional spread (one-sided) of partitions -! wf Real arr array of wind fraction -! ipart Int arr array of partition indices -! sys Int arr array of system indices to which a given partition has been assigned -! ngbrSys Int arr array of system indices of neighboring grid points -! checked Int 0 = geo point not checked yet (in SUBROUTINE findSys) -! 1 = geo point has been checked -! -1 = geo land point (i.e. no partitioning data found for this point) -! -2 = geo land point, second passing. -! - TYPE param - REAL :: hs(10) - REAL :: tp(10) - REAL :: dir(10) - REAL :: dspr(10) -! REAL :: wf(10) - INTEGER :: ipart(10) - INTEGER :: sys(10) - INTEGER :: ngbrSys(50) - INTEGER :: checked - END TYPE param -! -! wind Der. type structure containing wind-related parameters -! wdir Real wind direction at grid point (Nautical or Cartesian, invariant) -! wspd Real wind speed at grid point -! - TYPE wind - REAL :: wdir - REAL :: wspd - END TYPE wind -! -! dat2d Der. type 2d data structure for storing raw partitioned data -! lat Real arr 2d array of latitudes of input partitioned data -! lon Real arr 2d array of longitudes of input partitioned data -! par type(param) arr 2d array of partitioned parameter structures -! wnd type(wind) arr 2d array of wind parameter structures -! maxi Int size of 2d array of raw partitioned data in i dimension -! maxj Int size of 2d array of raw partitioned data in j dimension -! - TYPE dat2d - REAL*8 :: date - REAL, POINTER :: lat(:,:) - REAL, POINTER :: lon(:,:) - TYPE(param), POINTER :: par(:,:) - TYPE(wind), POINTER :: wnd(:,:) - INTEGER :: maxi - INTEGER :: maxj - END TYPE dat2d -! -! neighbr Der. type structure for storing data of neighboring grid point -! par type(param) partitioned parameter structure at neighboring grid point -! i Int i index of neighboring grid point -! j Int j index of neighboring grid point -! - TYPE neighbr - TYPE(param) :: par - INTEGER :: i - INTEGER :: j - END TYPE neighbr -! -! mtchsys Der. type structure for storing data of matched systems -! sysVal Int arr array of indices of matched systems -! tpVal Real arr array of peak period values of matched systems -! wfVal Real arr array of wind fraction values of matched systems -! - TYPE mtchsys - INTEGER :: sysVal(50) - REAL :: tpVal(50) - REAL :: dirVal(50) - REAL :: hsVal(50) -! REAL :: wfVal(50) - END TYPE mtchsys -! -! system Der. type structure for storing spatially tracked systems (one time level) -! hs Real arr sign wave height field assoc with wave system (in 1d array) -! tp Real arr peak period field assoc with wave system (in 1d array) -! dir Real arr mean direction field assoc with wave system (in 1d array) -! dspr Real arr mean directional spread field assoc with wave system (in 1d array) -! wf Real arr wind fraction assoc with wave system (in 1d array) -! i Int arr i index of geo grid point in wave system (in 1d array) -! j Int arr j index of geo grid point in wave system (in 1d array) -! lat Real arr latitudes of grid point in wave system (in 1d array) -! lon Real arr longitudes of grid point in wave system (in 1d array) -! sysInd Int index of current wave system -! hsMean Real spatial mean sign wave height of current wave system -! tpMean Real spatial mean peak period of current wave system -! dirMean Real spatial mean wave direction of current wave system -! wfMean Real spatial mean wind fraction of current wave system -! nPoints Int total number of grid points in current wave system -! ngbr Int arr indices of neighboring wave systems -! grp Int time-tracked group that system is assigned to -! - TYPE system - REAL, POINTER :: hs(:) - REAL, POINTER :: tp(:) - REAL, POINTER :: dir(:) - REAL, POINTER :: dspr(:) -! REAL, POINTER :: wf(:) - INTEGER, POINTER :: i(:) - INTEGER, POINTER :: j(:) - INTEGER, POINTER :: indx(:) - REAL, POINTER :: lat(:) - REAL, POINTER :: lon(:) - INTEGER :: sysInd - REAL :: hsMean - REAL :: tpMean - REAL :: dirMean -! REAL :: wfMean - INTEGER :: nPoints - INTEGER :: ngbr(1000) - INTEGER :: grp - END TYPE system -! -! timsys Der. type structure for storing time-tracked systems (all time levels) -! sys type(system) arr array of all spatially+temporally tracked systems at given -! time level -! - TYPE timsys - TYPE(system), POINTER :: sys(:) - END TYPE timsys -! -! sysmemory Der. type Structure to store key characteristics of systems over multiple -! time levels. Used during the time tracking routine. -! - TYPE sysmemory - INTEGER :: grp - INTEGER :: nPoints - INTEGER, POINTER :: indx(:) - INTEGER :: updated - INTEGER :: length - REAL :: lonMean - REAL :: latMean - REAL :: tpMean - REAL :: dirMean - END TYPE sysmemory -! -! 4. Subroutines and functions used : -! -! a. Main subroutines for spatial/temporal tracking: -! -! waveTracking_NWS_V2 main subroutine of spatial and temporal tracking algorithm -! spiralTrackV3 performs the spatial spiral tracking for a given time step -! timeTrackingV2 performs the time tracking of all wave systems -! -! b. Auxiliary subroutines and functions for tracking: -! -! findWay find direction and no. steps in spatial search spiral -! findNext find next point on spatial search spiral -! findSys find all neighboring wave systems for given grid point -! combineWaveSystems combine wave systems, then remove small and low-energy systems -! printFinalSys output the final output systems for this time step -! combineSys combine wave systems -! combinePartitionsV2 combine two partitions that have been assigned to the same system -! func. mean_angleV2 compute the mean direction from array of directions -! findIJV4 Find indices of system "a" that lie over or next to system "b" -! -! c. Simple data manipulation (based on Matlab intrinsic functions): -! -! UNIQUE removes duplicate reals from an vector -! SORT sorts the vector in ascending or descending order -! SETDIFF returns elements in vector1 that are not in vector2 -! INTERSECT returns elements that are mutual in vector1 and vector2 -! UNION returns the union of vector1 and vector2 -! func. LENGTH finds no. of indices in vector not filled with blank entries. -! func. FINDFIRST returns index of first instance of a search value in vector -! func. STD computes standard deviation -! -! 5. Called by : -! -! WW3_SYSTRK (main program) -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! The structure of the tracking algorithm is the following -! (parentheses indicate minor subroutines and functions): -! -! +---- SUBROUTINE waveTracking_NWS_V2 main subroutine of spatial and temporal tracking algorithm -! | (CALL UNIQUE) removes duplicate reals from an vector -! | CALL spiralTrackV3 See below -! | CALL timeTrackingV2 See below -! | -! +---+--- SUBROUTINE spiralTrackV3 performs the spatial spiral tracking for a given time step -! | | CALL findWay find direction and no. steps in spatial search spiral -! | | CALL findNext find next point on spatial search spiral -! | | CALL findSys See below -! | | CALL combineWaveSystems See below -! | | -! | +------ SUBROUTINE findSys find all neighboring wave systems for given grid point -! | | (CALL UNIQUE) -! | | CALL combinePartitionsV2 combine two partitions that have been assigned to the same system -! | | -! | +---+-- SUBROUTINE combineWaveSystems combine wave systems, then remove small and low-energy systems -! | | CALL printFinalSys See below -! | | CALL combineSys See below -! | | -! | +----- SUBROUTINE printFinalSys output the final output systems for this time step -! | | (CALL UNIQUE) -! | | (CALL SETDIFF) returns elements in vector1 that are not in vector2 -! | | (CALL SORT) sorts the vector in ascending or descending order -! | | -! | +----- SUBROUTINE combineSys combine wave systems -! | (CALL SORT) -! | (CALL UNIQUE) -! | (CALL UNION) returns the union of vector1 and vector2 -! | (CALL SETDIFF) -! | CALL findIJV4 Find indices of system "a" that lie over or next to system "b" -! | CALL combinePartitionsV2 -! | -! +------- SUBROUTINE timeTrackingV2 performs the time tracking of all wave systems -! (CALL SORT) -! (CALL SETDIFF) -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/MPI Id. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & - tcur ,filename , & - tstart ,tend , & - dt ,ntint , & - minlon ,maxlon , & - minlat ,maxlat , & - mxcwt ,mycwt , & - dirKnob , & - perKnob ,hsKnob , & - wetPts ,seedLat , & - seedLon ,dirTimeKnob, & - tpTimeKnob ,paramFile , & - sysA ,wsdat , & - maxSys ,maxGroup ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE +MODULE W3STRKMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 03-Mar-2016 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ 29-Nov-2013 : Remove DOC control characters, + !/ update MPI! to MPI/! (H. L. Tolman). ( version 4.15 ) + !/ 26-Sep-2016 : Optimization updates (A. van der Westhuysen) + !/ ( version 5.15 ) + !/ 03-Mar-2016 : Optimization updates for INTERSECT, + !/ UNION, UNIQUE, SORT, SETDIFF, FINDIJ + !/ (S. Zieger, BoM Australia) ( version 5.16 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + use constants, only: file_endian + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Module containing data structures and subroutines for spatial and + ! temporal tracking (part of wave partitioning). + ! + ! 2. Method : + ! + ! Read raw partitioning data. + ! Perform tracking in space. + ! Perform tracking in time. + ! + ! 3. Variables and types : + ! + ! NOTE: In Fortran 90/95 derived types cannot contain allocatable arrays. + ! The same functionality is achieved here using pointers (pointing + ! to unnamed allocatable arrays). Can be replaced by allocatable arrays + ! when transitioning to the Fortran 2003 standard. + ! + ! Name Type Description + ! ---------------------------------------------------------------- + ! param Der. type structure of basic spectrally partitioned results at a geo point + ! hs Real arr array of sign. wave height partitions + ! tp Real arr array of peak period partitions + ! dir Real arr array of mean direction partitions + ! dspr Real arr array of mean directional spread (one-sided) of partitions + ! wf Real arr array of wind fraction + ! ipart Int arr array of partition indices + ! sys Int arr array of system indices to which a given partition has been assigned + ! ngbrSys Int arr array of system indices of neighboring grid points + ! checked Int 0 = geo point not checked yet (in SUBROUTINE findSys) + ! 1 = geo point has been checked + ! -1 = geo land point (i.e. no partitioning data found for this point) + ! -2 = geo land point, second passing. + ! + TYPE param + REAL :: hs(10) + REAL :: tp(10) + REAL :: dir(10) + REAL :: dspr(10) + ! REAL :: wf(10) + INTEGER :: ipart(10) + INTEGER :: sys(10) + INTEGER :: ngbrSys(50) + INTEGER :: checked + END TYPE param + ! + ! wind Der. type structure containing wind-related parameters + ! wdir Real wind direction at grid point (Nautical or Cartesian, invariant) + ! wspd Real wind speed at grid point + ! + TYPE wind + REAL :: wdir + REAL :: wspd + END TYPE wind + ! + ! dat2d Der. type 2d data structure for storing raw partitioned data + ! lat Real arr 2d array of latitudes of input partitioned data + ! lon Real arr 2d array of longitudes of input partitioned data + ! par type(param) arr 2d array of partitioned parameter structures + ! wnd type(wind) arr 2d array of wind parameter structures + ! maxi Int size of 2d array of raw partitioned data in i dimension + ! maxj Int size of 2d array of raw partitioned data in j dimension + ! + TYPE dat2d + REAL*8 :: date + REAL, POINTER :: lat(:,:) + REAL, POINTER :: lon(:,:) + TYPE(param), POINTER :: par(:,:) + TYPE(wind), POINTER :: wnd(:,:) + INTEGER :: maxi + INTEGER :: maxj + END TYPE dat2d + ! + ! neighbr Der. type structure for storing data of neighboring grid point + ! par type(param) partitioned parameter structure at neighboring grid point + ! i Int i index of neighboring grid point + ! j Int j index of neighboring grid point + ! + TYPE neighbr + TYPE(param) :: par + INTEGER :: i + INTEGER :: j + END TYPE neighbr + ! + ! mtchsys Der. type structure for storing data of matched systems + ! sysVal Int arr array of indices of matched systems + ! tpVal Real arr array of peak period values of matched systems + ! wfVal Real arr array of wind fraction values of matched systems + ! + TYPE mtchsys + INTEGER :: sysVal(50) + REAL :: tpVal(50) + REAL :: dirVal(50) + REAL :: hsVal(50) + ! REAL :: wfVal(50) + END TYPE mtchsys + ! + ! system Der. type structure for storing spatially tracked systems (one time level) + ! hs Real arr sign wave height field assoc with wave system (in 1d array) + ! tp Real arr peak period field assoc with wave system (in 1d array) + ! dir Real arr mean direction field assoc with wave system (in 1d array) + ! dspr Real arr mean directional spread field assoc with wave system (in 1d array) + ! wf Real arr wind fraction assoc with wave system (in 1d array) + ! i Int arr i index of geo grid point in wave system (in 1d array) + ! j Int arr j index of geo grid point in wave system (in 1d array) + ! lat Real arr latitudes of grid point in wave system (in 1d array) + ! lon Real arr longitudes of grid point in wave system (in 1d array) + ! sysInd Int index of current wave system + ! hsMean Real spatial mean sign wave height of current wave system + ! tpMean Real spatial mean peak period of current wave system + ! dirMean Real spatial mean wave direction of current wave system + ! wfMean Real spatial mean wind fraction of current wave system + ! nPoints Int total number of grid points in current wave system + ! ngbr Int arr indices of neighboring wave systems + ! grp Int time-tracked group that system is assigned to + ! + TYPE system + REAL, POINTER :: hs(:) + REAL, POINTER :: tp(:) + REAL, POINTER :: dir(:) + REAL, POINTER :: dspr(:) + ! REAL, POINTER :: wf(:) + INTEGER, POINTER :: i(:) + INTEGER, POINTER :: j(:) + INTEGER, POINTER :: indx(:) + REAL, POINTER :: lat(:) + REAL, POINTER :: lon(:) + INTEGER :: sysInd + REAL :: hsMean + REAL :: tpMean + REAL :: dirMean + ! REAL :: wfMean + INTEGER :: nPoints + INTEGER :: ngbr(1000) + INTEGER :: grp + END TYPE system + ! + ! timsys Der. type structure for storing time-tracked systems (all time levels) + ! sys type(system) arr array of all spatially+temporally tracked systems at given + ! time level + ! + TYPE timsys + TYPE(system), POINTER :: sys(:) + END TYPE timsys + ! + ! sysmemory Der. type Structure to store key characteristics of systems over multiple + ! time levels. Used during the time tracking routine. + ! + TYPE sysmemory + INTEGER :: grp + INTEGER :: nPoints + INTEGER, POINTER :: indx(:) + INTEGER :: updated + INTEGER :: length + REAL :: lonMean + REAL :: latMean + REAL :: tpMean + REAL :: dirMean + END TYPE sysmemory + ! + ! 4. Subroutines and functions used : + ! + ! a. Main subroutines for spatial/temporal tracking: + ! + ! waveTracking_NWS_V2 main subroutine of spatial and temporal tracking algorithm + ! spiralTrackV3 performs the spatial spiral tracking for a given time step + ! timeTrackingV2 performs the time tracking of all wave systems + ! + ! b. Auxiliary subroutines and functions for tracking: + ! + ! findWay find direction and no. steps in spatial search spiral + ! findNext find next point on spatial search spiral + ! findSys find all neighboring wave systems for given grid point + ! combineWaveSystems combine wave systems, then remove small and low-energy systems + ! printFinalSys output the final output systems for this time step + ! combineSys combine wave systems + ! combinePartitionsV2 combine two partitions that have been assigned to the same system + ! func. mean_angleV2 compute the mean direction from array of directions + ! findIJV4 Find indices of system "a" that lie over or next to system "b" + ! + ! c. Simple data manipulation (based on Matlab intrinsic functions): + ! + ! UNIQUE removes duplicate reals from an vector + ! SORT sorts the vector in ascending or descending order + ! SETDIFF returns elements in vector1 that are not in vector2 + ! INTERSECT returns elements that are mutual in vector1 and vector2 + ! UNION returns the union of vector1 and vector2 + ! func. LENGTH finds no. of indices in vector not filled with blank entries. + ! func. FINDFIRST returns index of first instance of a search value in vector + ! func. STD computes standard deviation + ! + ! 5. Called by : + ! + ! WW3_SYSTRK (main program) + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! The structure of the tracking algorithm is the following + ! (parentheses indicate minor subroutines and functions): + ! + ! +---- SUBROUTINE waveTracking_NWS_V2 main subroutine of spatial and temporal tracking algorithm + ! | (CALL UNIQUE) removes duplicate reals from an vector + ! | CALL spiralTrackV3 See below + ! | CALL timeTrackingV2 See below + ! | + ! +---+--- SUBROUTINE spiralTrackV3 performs the spatial spiral tracking for a given time step + ! | | CALL findWay find direction and no. steps in spatial search spiral + ! | | CALL findNext find next point on spatial search spiral + ! | | CALL findSys See below + ! | | CALL combineWaveSystems See below + ! | | + ! | +------ SUBROUTINE findSys find all neighboring wave systems for given grid point + ! | | (CALL UNIQUE) + ! | | CALL combinePartitionsV2 combine two partitions that have been assigned to the same system + ! | | + ! | +---+-- SUBROUTINE combineWaveSystems combine wave systems, then remove small and low-energy systems + ! | | CALL printFinalSys See below + ! | | CALL combineSys See below + ! | | + ! | +----- SUBROUTINE printFinalSys output the final output systems for this time step + ! | | (CALL UNIQUE) + ! | | (CALL SETDIFF) returns elements in vector1 that are not in vector2 + ! | | (CALL SORT) sorts the vector in ascending or descending order + ! | | + ! | +----- SUBROUTINE combineSys combine wave systems + ! | (CALL SORT) + ! | (CALL UNIQUE) + ! | (CALL UNION) returns the union of vector1 and vector2 + ! | (CALL SETDIFF) + ! | CALL findIJV4 Find indices of system "a" that lie over or next to system "b" + ! | CALL combinePartitionsV2 + ! | + ! +------- SUBROUTINE timeTrackingV2 performs the time tracking of all wave systems + ! (CALL SORT) + ! (CALL SETDIFF) + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/MPI Id. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & + tcur ,filename , & + tstart ,tend , & + dt ,ntint , & + minlon ,maxlon , & + minlat ,maxlat , & + mxcwt ,mycwt , & + dirKnob , & + perKnob ,hsKnob , & + wetPts ,seedLat , & + seedLon ,dirTimeKnob, & + tpTimeKnob ,paramFile , & + sysA ,wsdat , & + maxSys ,maxGroup ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -! -! 1. Purpose : -! -! Main subroutine of spatial and temporal tracking algorithm -! -! 2. Method -! -! (1) Read the raw partitioning output from one of two file formats: -! (a) "partRes" format of IFP-SWAN (intype=1), or -! (b) WW3 spectral bulletin format (intype=2). -! If intype=0, the partition data is read from memory (not activated yet). -! -! (2) Perform tracking in space by calling subroutine spiralTrackV3 -! (3) Perform tracking in time by calling subroutine timeTrackingV2 -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! intype Int input For coupling: Type of input (0 = memory; 1 = partRes file; 2 = WW3 part file) -! tmax Int input For coupling: Value of maxTs to apply (1 or 2) -! tcur Int input For coupling: Index of current time step (1 or 2) -! filename Char input File name of locally partitioned data output -! tstart Char input Start time in raw partition file (if used) -! tend Char input End time in raw partition file (if used) -! minlon Real input Lower lon boundary of domain to be processed -! maxlon Real input Upper lon boundary of domain to be processed -! minlat Real input Lower lat boundary of domain to be processed -! maxlat Real input Upper lat boundary of domain to be processed -! dirKnob Real input Parameter in direction for combining fields in space -! perKnob Real input Parameter in period for combining fields in space -! hsKnob Real input Parameter in wave height for purging fields -! wetPts Real input Percentage of wet points for purging fields (fraction) -! seedLat Real input Start Lat for tracking spiral (if =0 centre of field is used) -! seedLon Real input Start Lon for tracking spiral (if =0 centre of field is used) -! dirTimeKnob Real input Parameter in direction for combining fields in time -! tpTimeKnob Real input Parameter in period for combining fields in time -! paramFile Char input File name of partitioning parameters Is this used??? -! sys TYPE(timsys) output Final set of spatially and temporally tracked systems -! wsdat TYPE(dat2d) output Final version of 2D (gridded) partition data -! maxGroup Int output Maximum number of wave systems ("groups") tracked in time -! - CHARACTER :: filename*50, paramFile*32 - REAL :: dirKnob, perKnob, hsKnob, wetPts, seedLat, & - seedLon, dirTimeKnob, tpTimeKnob - REAL*8 :: tstart, tend - INTEGER :: maxGroup, intype, tmax, tcur, ntint - INTEGER, POINTER :: maxSys(:) - TYPE(dat2d), POINTER :: wsdat(:) - TYPE(timsys), POINTER :: sysA(:), sysAA(:) - INTEGER :: NumConsSys, iConsSys - REAL :: dt - REAL :: minlon, maxlon, minlat, maxlat - INTEGER :: mxcwt, mycwt - -! Note: Variables wsdat, sysA and maxSys have IN/OUT intent so that they -! can be manipulated outside of this subroutine, e.g. re-indexing of -! systems and groups during the simulation. - INTENT (IN) intype, tmax, tcur, filename, paramFile, & - minlon, maxlon, minlat, maxlat, & - hsKnob, wetPts, seedLat, seedLon, & - dirKnob, perKnob, dirTimeKnob, tpTimeKnob - INTENT (OUT) maxGroup -! INTENT (IN OUT) wsdat, sysA, maxSys -! -! Local variables -! ---------------------------------------------------------------- -! llat Real Latitude of partition point, from input file -! llon Real Longitude of partition point, from input file -! ts Real Time step of partition, from input file -! hs0 Real Wave height of partition, from input file -! tp0 Real Peak period of partition, from input file -! dir0 Real Mean direction of partition, from input file -! dspr0 Real Mean directional spread of partition, from input file -! wf0 Real wind fraction of partition, from input file (removed) -! wndSpd0 Real Wind speed of partition, from input file -! wndDir0 Real Wind direction of partition, from input file -! wndFce0 Real Wind force of partition, from input file (not, used; removed) -! tss Int. Time step counter -! t0 Int Index of first time step to compute -! - LOGICAL :: file_exists, FLFORM, LOOP - LOGICAL :: testout - PARAMETER (testout = .FALSE.) - CHARACTER :: dummy*10, dummyc*12 - CHARACTER(LEN=10) :: VERPRT - CHARACTER(LEN=35) :: IDSTR - CHARACTER(LEN=78) :: headln1 - CHARACTER(LEN=51) :: headln2 - INTEGER :: line - INTEGER, ALLOCATABLE :: ts(:), tmp_i4(:) - REAL, ALLOCATABLE :: llat(:),llon(:),hs0(:), & - tp0(:),dir0(:),dspr0(:),& - wndSpd0(:),wndDir0(:) - REAL*8, ALLOCATABLE :: date0(:),tmp_r8(:) - INTEGER :: maxTs, t0, nout1, nout2, maxI, maxJ - REAL, ALLOCATABLE :: mlon(:,:), mlat(:,:), tmp_r4(:) - REAL, POINTER :: uniqueTim(:),uniqueLatraw(:),uniqueLonraw(:), & - uniqueLat(:),uniqueLon(:) - INTEGER :: ioerr,ierr, i, j, k, l, alreadyIn, ok, tss, tsA - INTEGER :: maxPart, DATETIME(2) - INTEGER :: tstep, iline, numpart, skipln, readln, filesize - REAL :: x,y,wnd,wnddir - REAL :: invar1, invar2, invar3, invar4 - REAL :: invar5, invar6, invar7 - REAL, ALLOCATABLE :: phs(:),ptp(:),pdir(:),pspr(:),pwf(:) ! current partition values - REAL*8 :: date1, date2, ttest, ttemp - INTEGER :: ic, leng, maxpartout ! Remove? - REAL :: dx - INTEGER :: latind1, latind2, lonind1, lonind2 - REAL :: lonext, latext + ! + ! 1. Purpose : + ! + ! Main subroutine of spatial and temporal tracking algorithm + ! + ! 2. Method + ! + ! (1) Read the raw partitioning output from one of two file formats: + ! (a) "partRes" format of IFP-SWAN (intype=1), or + ! (b) WW3 spectral bulletin format (intype=2). + ! If intype=0, the partition data is read from memory (not activated yet). + ! + ! (2) Perform tracking in space by calling subroutine spiralTrackV3 + ! (3) Perform tracking in time by calling subroutine timeTrackingV2 + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! intype Int input For coupling: Type of input (0 = memory; 1 = partRes file; 2 = WW3 part file) + ! tmax Int input For coupling: Value of maxTs to apply (1 or 2) + ! tcur Int input For coupling: Index of current time step (1 or 2) + ! filename Char input File name of locally partitioned data output + ! tstart Char input Start time in raw partition file (if used) + ! tend Char input End time in raw partition file (if used) + ! minlon Real input Lower lon boundary of domain to be processed + ! maxlon Real input Upper lon boundary of domain to be processed + ! minlat Real input Lower lat boundary of domain to be processed + ! maxlat Real input Upper lat boundary of domain to be processed + ! dirKnob Real input Parameter in direction for combining fields in space + ! perKnob Real input Parameter in period for combining fields in space + ! hsKnob Real input Parameter in wave height for purging fields + ! wetPts Real input Percentage of wet points for purging fields (fraction) + ! seedLat Real input Start Lat for tracking spiral (if =0 centre of field is used) + ! seedLon Real input Start Lon for tracking spiral (if =0 centre of field is used) + ! dirTimeKnob Real input Parameter in direction for combining fields in time + ! tpTimeKnob Real input Parameter in period for combining fields in time + ! paramFile Char input File name of partitioning parameters Is this used??? + ! sys TYPE(timsys) output Final set of spatially and temporally tracked systems + ! wsdat TYPE(dat2d) output Final version of 2D (gridded) partition data + ! maxGroup Int output Maximum number of wave systems ("groups") tracked in time + ! + CHARACTER :: filename*50, paramFile*32 + REAL :: dirKnob, perKnob, hsKnob, wetPts, seedLat, & + seedLon, dirTimeKnob, tpTimeKnob + REAL*8 :: tstart, tend + INTEGER :: maxGroup, intype, tmax, tcur, ntint + INTEGER, POINTER :: maxSys(:) + TYPE(dat2d), POINTER :: wsdat(:) + TYPE(timsys), POINTER :: sysA(:), sysAA(:) + INTEGER :: NumConsSys, iConsSys + REAL :: dt + REAL :: minlon, maxlon, minlat, maxlat + INTEGER :: mxcwt, mycwt + + ! Note: Variables wsdat, sysA and maxSys have IN/OUT intent so that they + ! can be manipulated outside of this subroutine, e.g. re-indexing of + ! systems and groups during the simulation. + INTENT (IN) intype, tmax, tcur, filename, paramFile, & + minlon, maxlon, minlat, maxlat, & + hsKnob, wetPts, seedLat, seedLon, & + dirKnob, perKnob, dirTimeKnob, tpTimeKnob + INTENT (OUT) maxGroup + ! INTENT (IN OUT) wsdat, sysA, maxSys + ! + ! Local variables + ! ---------------------------------------------------------------- + ! llat Real Latitude of partition point, from input file + ! llon Real Longitude of partition point, from input file + ! ts Real Time step of partition, from input file + ! hs0 Real Wave height of partition, from input file + ! tp0 Real Peak period of partition, from input file + ! dir0 Real Mean direction of partition, from input file + ! dspr0 Real Mean directional spread of partition, from input file + ! wf0 Real wind fraction of partition, from input file (removed) + ! wndSpd0 Real Wind speed of partition, from input file + ! wndDir0 Real Wind direction of partition, from input file + ! wndFce0 Real Wind force of partition, from input file (not, used; removed) + ! tss Int. Time step counter + ! t0 Int Index of first time step to compute + ! + LOGICAL :: file_exists, FLFORM, LOOP + LOGICAL :: testout + PARAMETER (testout = .FALSE.) + CHARACTER :: dummy*10, dummyc*12 + CHARACTER(LEN=10) :: VERPRT + CHARACTER(LEN=35) :: IDSTR + CHARACTER(LEN=78) :: headln1 + CHARACTER(LEN=51) :: headln2 + INTEGER :: line + INTEGER, ALLOCATABLE :: ts(:), tmp_i4(:) + REAL, ALLOCATABLE :: llat(:),llon(:),hs0(:), & + tp0(:),dir0(:),dspr0(:),& + wndSpd0(:),wndDir0(:) + REAL*8, ALLOCATABLE :: date0(:),tmp_r8(:) + INTEGER :: maxTs, t0, nout1, nout2, maxI, maxJ + REAL, ALLOCATABLE :: mlon(:,:), mlat(:,:), tmp_r4(:) + REAL, POINTER :: uniqueTim(:),uniqueLatraw(:),uniqueLonraw(:), & + uniqueLat(:),uniqueLon(:) + INTEGER :: ioerr,ierr, i, j, k, l, alreadyIn, ok, tss, tsA + INTEGER :: maxPart, DATETIME(2) + INTEGER :: tstep, iline, numpart, skipln, readln, filesize + REAL :: x,y,wnd,wnddir + REAL :: invar1, invar2, invar3, invar4 + REAL :: invar5, invar6, invar7 + REAL, ALLOCATABLE :: phs(:),ptp(:),pdir(:),pspr(:),pwf(:) ! current partition values + REAL*8 :: date1, date2, ttest, ttemp + INTEGER :: ic, leng, maxpartout ! Remove? + REAL :: dx + INTEGER :: latind1, latind2, lonind1, lonind2 + REAL :: lonext, latext #ifdef W3_MPI - INTEGER :: rank, irank, nproc, EXTENT, DOMSIZE, tag1, tag2 -! INTEGER :: MPI_INT_DOMARR, MPI_REAL_DOMARR - INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) - INTEGER :: REQ(16) -! INTEGER :: ISTAT(MPI_STATUS_SIZE,16) - REAL :: COMMARR1(44) - INTEGER :: COMMARR2(11) + INTEGER :: rank, irank, nproc, EXTENT, DOMSIZE, tag1, tag2 + ! INTEGER :: MPI_INT_DOMARR, MPI_REAL_DOMARR + INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) + INTEGER :: REQ(16) + ! INTEGER :: ISTAT(MPI_STATUS_SIZE,16) + REAL :: COMMARR1(44) + INTEGER :: COMMARR2(11) #endif -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! UNIQUE -! spiralTrackV3 -! timeTrackingV2 -! -! 5. Subroutines calling -! -! WW3_SYSTRK (main program) -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See above -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! UNIQUE + ! spiralTrackV3 + ! timeTrackingV2 + ! + ! 5. Subroutines calling + ! + ! WW3_SYSTRK (main program) + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See above + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_MPI - CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, ierr) + CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, ierr) #endif - NULLIFY( sysA ) - NULLIFY( maxSys ) - -! Select input type for raw partitioning data - IF ((intype.EQ.1).OR.(intype.EQ.2)) THEN -! Raw partitioning data is coming from an input file. -! Read file here, and set up 2d array wsdat with the data. - t0 = 1 - IF (intype.EQ.1) THEN + NULLIFY( sysA ) + NULLIFY( maxSys ) + + ! Select input type for raw partitioning data + IF ((intype.EQ.1).OR.(intype.EQ.2)) THEN + ! Raw partitioning data is coming from an input file. + ! Read file here, and set up 2d array wsdat with the data. + t0 = 1 + IF (intype.EQ.1) THEN #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif -! Read partRes format file - WRITE(20,*) 'Reading partRes partitioning file...' - filesize = 7500000 - ALLOCATE(ts(filesize)) - ALLOCATE(llat(filesize)) - ALLOCATE(llon(filesize)) - ALLOCATE(hs0(filesize)) - ALLOCATE(tp0(filesize)) - ALLOCATE(dir0(filesize)) - ALLOCATE(dspr0(filesize)) -! ALLOCATE(wf0(filesize)) - ALLOCATE(wndSpd0(filesize)) - ALLOCATE(wndDir0(filesize)) - ALLOCATE(date0(filesize)) - WRITE(20,*) '*** Max number of lines read from "partRes" ', & - 'input file is = ',filesize,'!' - WRITE(6,*) 'Reading partRes file...' - INQUIRE(FILE=filename, EXIST=file_exists) - IF (.NOT.file_exists) THEN - WRITE(20,2001) - WRITE(6,2001) - STOP 1 - END IF - OPEN(unit=11,file=filename,status='old') - line = 1 - DO WHILE (.TRUE.) - READ (11, *, END=113) dummyc,llat(line),llon(line), & - ts(line),hs0(line),tp0(line),dir0(line), & - wndSpd0(line),wndDir0(line),invar7 - !partRes file does not contain the dspr variable - dspr0(line) = 9999. -! wf0(line) = 9999. - line = line+1 - ENDDO - 113 IERR = -1 - CLOSE(11) - line = line-1 - WRITE(6,*) '... finished' -! DEALLOCATE(date0) + ! Read partRes format file + WRITE(20,*) 'Reading partRes partitioning file...' + filesize = 7500000 + ALLOCATE(ts(filesize)) + ALLOCATE(llat(filesize)) + ALLOCATE(llon(filesize)) + ALLOCATE(hs0(filesize)) + ALLOCATE(tp0(filesize)) + ALLOCATE(dir0(filesize)) + ALLOCATE(dspr0(filesize)) + ! ALLOCATE(wf0(filesize)) + ALLOCATE(wndSpd0(filesize)) + ALLOCATE(wndDir0(filesize)) + ALLOCATE(date0(filesize)) + WRITE(20,*) '*** Max number of lines read from "partRes" ', & + 'input file is = ',filesize,'!' + WRITE(6,*) 'Reading partRes file...' + INQUIRE(FILE=filename, EXIST=file_exists) + IF (.NOT.file_exists) THEN + WRITE(20,2001) + WRITE(6,2001) + STOP 1 + END IF + OPEN(unit=11,file=filename,status='old') + line = 1 + DO WHILE (.TRUE.) + READ (11, *, END=113) dummyc,llat(line),llon(line), & + ts(line),hs0(line),tp0(line),dir0(line), & + wndSpd0(line),wndDir0(line),invar7 + !partRes file does not contain the dspr variable + dspr0(line) = 9999. + ! wf0(line) = 9999. + line = line+1 + ENDDO +113 IERR = -1 + CLOSE(11) + line = line-1 + WRITE(6,*) '... finished' + ! DEALLOCATE(date0) #ifdef W3_MPI - END IF + END IF #endif - ELSE IF (intype.EQ.2) THEN + ELSE IF (intype.EQ.2) THEN #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif -! Read WW3 Spectral Partition format file -! Query input file to determine required array sizes - INQUIRE(FILE=filename, EXIST=file_exists) - IF (.NOT.file_exists) THEN - WRITE(20,2001) - WRITE(6,2001) - STOP 1 - END IF -!/ ------------------------------------------------- -!/ Test unformatted read -!/ ------------------------------------------------- - OPEN(UNIT=11,FILE=FILENAME,form='UNFORMATTED', convert=file_endian,STATUS='OLD',ACCESS='STREAM') - READ(11,ERR=802,IOSTAT=IOERR) I + ! Read WW3 Spectral Partition format file + ! Query input file to determine required array sizes + INQUIRE(FILE=filename, EXIST=file_exists) + IF (.NOT.file_exists) THEN + WRITE(20,2001) + WRITE(6,2001) + STOP 1 + END IF + !/ ------------------------------------------------- + !/ Test unformatted read + !/ ------------------------------------------------- + OPEN(UNIT=11,FILE=FILENAME,form='UNFORMATTED', convert=file_endian,STATUS='OLD',ACCESS='STREAM') + READ(11,ERR=802,IOSTAT=IOERR) I + CLOSE(11) + !/ --- First four-byte integer could possibly be byte-swapped, + ! if ww3_shel was compiled on a different architecture. --- + K = SWAPI4(I) + FLFORM = .NOT.(I.EQ.(LEN(IDSTR)+LEN(VERPRT)).OR.& + K.EQ.(LEN(IDSTR)+LEN(VERPRT)) ) + ! ======== COUNT LOOP =========== + IF (FLFORM) THEN + ! Input file in formatted ASCII + WRITE(6,*) 'Reading formatted ASCII file...' + OPEN(unit=11,file=filename,status='old') + READ(11,'(78A)') headln1 + IDSTR = headln1(1:LEN(IDSTR)) + READ(11,'(78A)') headln1 + READ(11,'(51A)') headln2 + ELSE + IF (K.EQ.(LEN(IDSTR)+LEN(VERPRT))) THEN + !/ --- Stop here. The file appears to be endian encoded + ! different from the native machine format. And, the + ! compiler option will override support for FORTRAN + ! convert statements convert=file_endian or + ! convert='little_endian'. --- + WRITE(20,1200) + WRITE(6,1200) + STOP 1 + ELSE + ! Input file in unformatted binary + WRITE(6,*) 'Reading binary formatted file...' + OPEN(unit=11,file=filename,form='UNFORMATTED', convert=file_endian, & + status='OLD') + ENDIF + REWIND(11) + READ(11,ERR=802,IOSTAT=IOERR) IDSTR,VERPRT + READ(11,ERR=802,IOSTAT=IOERR) headln1 + READ(11,ERR=802,IOSTAT=IOERR) headln2 + END IF + !/ + IF (IDSTR(1:9).ne.'WAVEWATCH') THEN CLOSE(11) -!/ --- First four-byte integer could possibly be byte-swapped, -! if ww3_shel was compiled on a different architecture. --- - K = SWAPI4(I) - FLFORM = .NOT.(I.EQ.(LEN(IDSTR)+LEN(VERPRT)).OR.& - K.EQ.(LEN(IDSTR)+LEN(VERPRT)) ) -! ======== COUNT LOOP =========== + WRITE(20,1300) + WRITE(6,1300) + STOP 1 + ENDIF + !/ ------------------------------------------------- + !/ Skip to start time + !/ ------------------------------------------------- + skipln = 3 + ttest = 0 + DO WHILE (ttest.LT.tstart) IF (FLFORM) THEN -! Input file in formatted ASCII - WRITE(6,*) 'Reading formatted ASCII file...' - OPEN(unit=11,file=filename,status='old') - READ(11,'(78A)') headln1 - IDSTR = headln1(1:LEN(IDSTR)) - READ(11,'(78A)') headln1 - READ(11,'(51A)') headln2 - ELSE - IF (K.EQ.(LEN(IDSTR)+LEN(VERPRT))) THEN -!/ --- Stop here. The file appears to be endian encoded -! different from the native machine format. And, the -! compiler option will override support for FORTRAN -! convert statements convert=file_endian or -! convert='little_endian'. --- - WRITE(20,1200) - WRITE(6,1200) - STOP 1 - ELSE -! Input file in unformatted binary - WRITE(6,*) 'Reading binary formatted file...' - OPEN(unit=11,file=filename,form='UNFORMATTED', convert=file_endian, & - status='OLD') - ENDIF - REWIND(11) - READ(11,ERR=802,IOSTAT=IOERR) IDSTR,VERPRT - READ(11,ERR=802,IOSTAT=IOERR) headln1 - READ(11,ERR=802,IOSTAT=IOERR) headln2 - END IF -!/ - IF (IDSTR(1:9).ne.'WAVEWATCH') THEN - CLOSE(11) - WRITE(20,1300) - WRITE(6,1300) - STOP 1 - ENDIF -!/ ------------------------------------------------- -!/ Skip to start time -!/ ------------------------------------------------- - skipln = 3 - ttest = 0 - DO WHILE (ttest.LT.tstart) - IF (FLFORM) THEN - READ (11,1000,ERR=802,END=112) date1,date2,x,y, & - numpart,wnd,wnddir,invar6,invar7 + READ (11,1000,ERR=802,END=112) date1,date2,x,y, & + numpart,wnd,wnddir,invar6,invar7 #ifdef W3_del - write(*,*) '0:',x,y,numpart + write(*,*) '0:',x,y,numpart #endif - skipln = skipln+1 - ELSE - READ (11,ERR=802,IOSTAT=IOERR) DATETIME,x,y, & - dummy,numpart,invar1,wnd,wnddir, & - invar5,invar6 -! write(*,*) '0:',DATETIME,numpart - date1=dble(DATETIME(1)) - date2=dble(DATETIME(2)) - END IF - ttest = date1 + date2*1.0E-6 + skipln = skipln+1 + ELSE + READ (11,ERR=802,IOSTAT=IOERR) DATETIME,x,y, & + dummy,numpart,invar1,wnd,wnddir, & + invar5,invar6 + ! write(*,*) '0:',DATETIME,numpart + date1=dble(DATETIME(1)) + date2=dble(DATETIME(2)) + END IF + ttest = date1 + date2*1.0E-6 + IF (FLFORM) THEN + DO line = 1,numpart+1 + READ(11,1010,END=111,ERR=802,IOSTAT=IOERR) & + invar1,invar2,invar3,invar4 + ! write(*,*) '0+:',line,numpart+1,invar1,invar2,invar3,invar4 + skipln = skipln+1 + END DO + ELSE + DO line = 1,numpart+1 + READ (11,ERR=802,IOSTAT=IOERR) iline,invar1, & + invar2,invar3,invar4,invar5,invar6 + ! write(*,*) '0+:',line,iline,invar1,invar2,invar3,invar4,invar5,invar6 + END DO + END IF + END DO + skipln = skipln-numpart-1-1 + !/ ------------------------------------------------- + ! Read file for ntint time levels + !/ ------------------------------------------------- + readln = numpart + tstep = 1 + ttemp = tstart + maxPart = numpart + DO WHILE (tstep.LE.ntint) + IF (readln.GT.0) THEN IF (FLFORM) THEN - DO line = 1,numpart+1 - READ(11,1010,END=111,ERR=802,IOSTAT=IOERR) & - invar1,invar2,invar3,invar4 -! write(*,*) '0+:',line,numpart+1,invar1,invar2,invar3,invar4 - skipln = skipln+1 - END DO + READ (11,1000,ERR=802,END=111) date1,date2,x,y, & + numpart,wnd,wnddir,invar6,invar7 ELSE - DO line = 1,numpart+1 - READ (11,ERR=802,IOSTAT=IOERR) iline,invar1, & - invar2,invar3,invar4,invar5,invar6 -! write(*,*) '0+:',line,iline,invar1,invar2,invar3,invar4,invar5,invar6 - END DO - END IF - END DO - skipln = skipln-numpart-1-1 -!/ ------------------------------------------------- -! Read file for ntint time levels -!/ ------------------------------------------------- - readln = numpart - tstep = 1 - ttemp = tstart - maxPart = numpart - DO WHILE (tstep.LE.ntint) - IF (readln.GT.0) THEN - IF (FLFORM) THEN - READ (11,1000,ERR=802,END=111) date1,date2,x,y, & - numpart,wnd,wnddir,invar6,invar7 - ELSE - READ (11,END=111,ERR=802,IOSTAT=IOERR) DATETIME, & - x,y,dummy,numpart,wnd,wnddir,invar5,invar6,invar7 -! write(*,*) '1:',numpart,x,y - date1=dble(DATETIME(1)) - date2=dble(DATETIME(2)) - END IF - maxPart = MAX(maxPart,numpart) + READ (11,END=111,ERR=802,IOSTAT=IOERR) DATETIME, & + x,y,dummy,numpart,wnd,wnddir,invar5,invar6,invar7 + ! write(*,*) '1:',numpart,x,y + date1=dble(DATETIME(1)) + date2=dble(DATETIME(2)) END IF + maxPart = MAX(maxPart,numpart) + END IF - ttest = date1 + date2*1.E-6 - IF (ttest.GT.ttemp) THEN - tstep = tstep+1 - ttemp = ttest - IF (tstep.GT.ntint) EXIT - END IF - IF (FLFORM) THEN - DO line = 1,numpart+1 - READ (11,1010,END=111,ERR=802,IOSTAT=IOERR) & - invar1,invar2,invar3,invar4 + ttest = date1 + date2*1.E-6 + IF (ttest.GT.ttemp) THEN + tstep = tstep+1 + ttemp = ttest + IF (tstep.GT.ntint) EXIT + END IF + IF (FLFORM) THEN + DO line = 1,numpart+1 + READ (11,1010,END=111,ERR=802,IOSTAT=IOERR) & + invar1,invar2,invar3,invar4 #ifdef W3_del - write(*,'(A,2I6,4F7.2)') '1+:',line,numpart+1,invar1,invar2,invar3,invar4 + write(*,'(A,2I6,4F7.2)') '1+:',line,numpart+1,invar1,invar2,invar3,invar4 #endif - readln = readln+1 - END DO - ELSE - DO line = 1,numpart+1 - READ (11,END=111,ERR=802,IOSTAT=IOERR) iline,invar1,& - invar2,invar3,invar4,invar5,invar6 - readln = readln+1 - END DO - END IF - ENDDO - 111 CONTINUE - CLOSE(11) -! ===== END COUNT LOOP ===== -! ===== START READ LOOP ===== - ALLOCATE(ts(readln)) - ALLOCATE(llat(readln)) - ALLOCATE(llon(readln)) - ALLOCATE(hs0(readln)) - ALLOCATE(tp0(readln)) - ALLOCATE(dir0(readln)) - ALLOCATE(dspr0(readln)) -! ALLOCATE(wf0(readln)) - ALLOCATE(wndSpd0(readln)) - ALLOCATE(wndDir0(readln)) - ALLOCATE(date0(readln)) - ts(1:readln) = -1 - llat(1:readln) = 9999. - llon(1:readln) = 9999. - hs0(1:readln) = 9999. - tp0(1:readln) = 9999. - dir0(1:readln) = 9999. - dspr0(1:readln) = 9999. - - - IF (FLFORM) THEN - OPEN(unit=11,file=filename,status='old') + readln = readln+1 + END DO ELSE - OPEN(unit=11,file=filename,status='old', & - form='unformatted', convert=file_endian) + DO line = 1,numpart+1 + READ (11,END=111,ERR=802,IOSTAT=IOERR) iline,invar1,& + invar2,invar3,invar4,invar5,invar6 + readln = readln+1 + END DO END IF - line = 1 - tstep = 1 -!/ ------------------------------------------------- -!/ Skip to start time -!/ ------------------------------------------------- - IF (FLFORM) THEN - DO i = 1,skipln - READ (11, *) - END DO - ELSE + ENDDO +111 CONTINUE + CLOSE(11) + ! ===== END COUNT LOOP ===== + ! ===== START READ LOOP ===== + ALLOCATE(ts(readln)) + ALLOCATE(llat(readln)) + ALLOCATE(llon(readln)) + ALLOCATE(hs0(readln)) + ALLOCATE(tp0(readln)) + ALLOCATE(dir0(readln)) + ALLOCATE(dspr0(readln)) + ! ALLOCATE(wf0(readln)) + ALLOCATE(wndSpd0(readln)) + ALLOCATE(wndDir0(readln)) + ALLOCATE(date0(readln)) + ts(1:readln) = -1 + llat(1:readln) = 9999. + llon(1:readln) = 9999. + hs0(1:readln) = 9999. + tp0(1:readln) = 9999. + dir0(1:readln) = 9999. + dspr0(1:readln) = 9999. + + + IF (FLFORM) THEN + OPEN(unit=11,file=filename,status='old') + ELSE + OPEN(unit=11,file=filename,status='old', & + form='unformatted', convert=file_endian) + END IF + line = 1 + tstep = 1 + !/ ------------------------------------------------- + !/ Skip to start time + !/ ------------------------------------------------- + IF (FLFORM) THEN + DO i = 1,skipln + READ (11, *) + END DO + ELSE ! --- Repeat from above since access='DIRECT' ! does not support fseek and ftell. --- - READ(11,END=112,ERR=802,IOSTAT=IOERR) IDSTR,VERPRT - READ(11,END=112,ERR=802,IOSTAT=IOERR) headln1 - READ(11,END=112,ERR=802,IOSTAT=IOERR) headln2 + READ(11,END=112,ERR=802,IOSTAT=IOERR) IDSTR,VERPRT + READ(11,END=112,ERR=802,IOSTAT=IOERR) headln1 + READ(11,END=112,ERR=802,IOSTAT=IOERR) headln2 !/ --- allocate buffer for all partition parameters !/ for a single grid point --- - IF (.NOT.ALLOCATED(PHS)) ALLOCATE(PHS(maxPart)) - IF (.NOT.ALLOCATED(PTP)) ALLOCATE(PTP(maxPart)) - IF (.NOT.ALLOCATED(PDIR)) ALLOCATE(PDIR(maxPart)) - IF (.NOT.ALLOCATED(PSPR)) ALLOCATE(PSPR(maxPart)) - IF (.NOT.ALLOCATED(PWF)) ALLOCATE(PWF(maxPart)) - - ttest = 0 - - DO WHILE (ttest.LT.tstart) - READ (11,END=112,ERR=802,IOSTAT=IOERR) DATETIME, & - invar1,invar2,dummy,numpart,invar3, & - invar4,invar5,invar6,invar7 - date1=dble(DATETIME(1)) - date2=dble(DATETIME(2)) - ttest = date1 + date2*1.0E-6 - !/ --- reset buffer --- - PHS(:) = 0. - PTP(:) = 0. - PDIR(:) = 0. - PSPR(:) = 0. - PWF(:) = 0. + IF (.NOT.ALLOCATED(PHS)) ALLOCATE(PHS(maxPart)) + IF (.NOT.ALLOCATED(PTP)) ALLOCATE(PTP(maxPart)) + IF (.NOT.ALLOCATED(PDIR)) ALLOCATE(PDIR(maxPart)) + IF (.NOT.ALLOCATED(PSPR)) ALLOCATE(PSPR(maxPart)) + IF (.NOT.ALLOCATED(PWF)) ALLOCATE(PWF(maxPart)) - !/ --- fill buffer with partition data --- - READ (11,END=112,ERR=802,IOSTAT=IOERR) iline,invar1, & - invar2,invar3,invar4,invar5,invar6 - DO i = 1,numpart - READ (11,END=112,ERR=802,IOSTAT=IOERR) iline, & - phs(i),ptp(i),invar3,pdir(i),pspr(i),pwf(i) - END DO - END DO - !/ --- move buffer content to data array --- - DO i=1,numpart - hs0(line) = phs(i) - tp0(line) = ptp(i) - dir0(line) = pdir(i) - dspr0(line) = pspr(i) - date0(line) = date1 + date2*1.0E-6 - ts(line) = tstep - llat(line) = x - llon(line) = y - wndSpd0(line) = wnd - wndDir0(line) = wnddir - - line = line + 1 - END DO - - END IF -!/ ------------------------------------------------- -! Read file for ntint time levels -!/ ------------------------------------------------- - ttemp = tstart - DO WHILE (line.LE.readln) - IF (FLFORM) THEN - READ (11,1000,END=112) date1,date2,x,y,numpart, & - wnd,wnddir,invar6,invar7 - ELSE - READ (11,ERR=802,IOSTAT=IOERR) DATETIME,x,y, & - dummy,numpart,wnd,wnddir,invar5,invar6,invar7 - date1=dble(DATETIME(1)) - date2=dble(DATETIME(2)) - END IF + ttest = 0 + DO WHILE (ttest.LT.tstart) + READ (11,END=112,ERR=802,IOSTAT=IOERR) DATETIME, & + invar1,invar2,dummy,numpart,invar3, & + invar4,invar5,invar6,invar7 + date1=dble(DATETIME(1)) + date2=dble(DATETIME(2)) ttest = date1 + date2*1.0E-6 - IF (ttest.GT.ttemp) THEN - tstep = tstep+1 - ttemp = ttest - IF (tstep.GT.ntint) EXIT - END IF + !/ --- reset buffer --- + PHS(:) = 0. + PTP(:) = 0. + PDIR(:) = 0. + PSPR(:) = 0. + PWF(:) = 0. - IF (FLFORM) THEN - READ (11,1010,END=112) invar1,invar2,invar3,invar4 ! Skip total integral parameters - DO i = 1,numpart - IF (line.LE.readln) THEN - READ (11,1010,END=112) hs0(line),tp0(line), & - dir0(line),dspr0(line) - date0(line) = ttest - - ts(line) = tstep - llat(line) = x - llon(line) = y - wndSpd0(line) = wnd - wndDir0(line) = wnddir - - line = line+1 - END IF - END DO - ELSE - READ (11,ERR=802,IOSTAT=IOERR) k,invar1,invar2, & - invar3,invar4,invar5 - DO i = 1,numpart - IF (line.LE.readln) THEN - READ (11,END=112,ERR=802,IOSTAT=IOERR) k, & - hs0(line),tp0(line),invar3,dir0(line), & - dspr0(line) - date0(line) = ttest - - ts(line) = tstep - llat(line) = x - llon(line) = y - wndSpd0(line) = wnd - wndDir0(line) = wnddir - - line = line+1 - END IF - END DO - END IF + !/ --- fill buffer with partition data --- + READ (11,END=112,ERR=802,IOSTAT=IOERR) iline,invar1, & + invar2,invar3,invar4,invar5,invar6 + DO i = 1,numpart + READ (11,END=112,ERR=802,IOSTAT=IOERR) iline, & + phs(i),ptp(i),invar3,pdir(i),pspr(i),pwf(i) + END DO + END DO + !/ --- move buffer content to data array --- + DO i=1,numpart + hs0(line) = phs(i) + tp0(line) = ptp(i) + dir0(line) = pdir(i) + dspr0(line) = pspr(i) + date0(line) = date1 + date2*1.0E-6 + ts(line) = tstep + llat(line) = x + llon(line) = y + wndSpd0(line) = wnd + wndDir0(line) = wnddir + + line = line + 1 END DO - 110 IERR = -1 - CLOSE(11) - 112 CONTINUE - IF (line.EQ.1) THEN - WRITE(20,2002) - WRITE(6,2002) - STOP 1 + END IF + !/ ------------------------------------------------- + ! Read file for ntint time levels + !/ ------------------------------------------------- + ttemp = tstart + DO WHILE (line.LE.readln) + IF (FLFORM) THEN + READ (11,1000,END=112) date1,date2,x,y,numpart, & + wnd,wnddir,invar6,invar7 + ELSE + READ (11,ERR=802,IOSTAT=IOERR) DATETIME,x,y, & + dummy,numpart,wnd,wnddir,invar5,invar6,invar7 + date1=dble(DATETIME(1)) + date2=dble(DATETIME(2)) END IF - CLOSE(11) -! ===== READ LOOP FINISHED ===== - LINE=LINE-1 - WRITE(6,*) '... finished' + ttest = date1 + date2*1.0E-6 + IF (ttest.GT.ttemp) THEN + tstep = tstep+1 + ttemp = ttest + IF (tstep.GT.ntint) EXIT + END IF - IF (ttest.LT.tstart) THEN - WRITE(20,2003) TSTART - WRITE(6,2003) TSTART - STOP 1 + IF (FLFORM) THEN + READ (11,1010,END=112) invar1,invar2,invar3,invar4 ! Skip total integral parameters + DO i = 1,numpart + IF (line.LE.readln) THEN + READ (11,1010,END=112) hs0(line),tp0(line), & + dir0(line),dspr0(line) + date0(line) = ttest + + ts(line) = tstep + llat(line) = x + llon(line) = y + wndSpd0(line) = wnd + wndDir0(line) = wnddir + + line = line+1 + END IF + END DO + ELSE + READ (11,ERR=802,IOSTAT=IOERR) k,invar1,invar2, & + invar3,invar4,invar5 + DO i = 1,numpart + IF (line.LE.readln) THEN + READ (11,END=112,ERR=802,IOSTAT=IOERR) k, & + hs0(line),tp0(line),invar3,dir0(line), & + dspr0(line) + date0(line) = ttest + + ts(line) = tstep + llat(line) = x + llon(line) = y + wndSpd0(line) = wnd + wndDir0(line) = wnddir + + line = line+1 + END IF + END DO END IF + END DO +110 IERR = -1 + CLOSE(11) + +112 CONTINUE + IF (line.EQ.1) THEN + WRITE(20,2002) + WRITE(6,2002) + STOP 1 + END IF + CLOSE(11) + ! ===== READ LOOP FINISHED ===== + LINE=LINE-1 + + WRITE(6,*) '... finished' - IF (ALLOCATED(PHS)) DEALLOCATE(PHS) - IF (ALLOCATED(PTP)) DEALLOCATE(PTP) - IF (ALLOCATED(PDIR)) DEALLOCATE(PDIR) - IF (ALLOCATED(PSPR)) DEALLOCATE(PSPR) - IF (ALLOCATED(PWF)) DEALLOCATE(PWF) + IF (ttest.LT.tstart) THEN + WRITE(20,2003) TSTART + WRITE(6,2003) TSTART + STOP 1 + END IF + + IF (ALLOCATED(PHS)) DEALLOCATE(PHS) + IF (ALLOCATED(PTP)) DEALLOCATE(PTP) + IF (ALLOCATED(PDIR)) DEALLOCATE(PDIR) + IF (ALLOCATED(PSPR)) DEALLOCATE(PSPR) + IF (ALLOCATED(PWF)) DEALLOCATE(PWF) #ifdef W3_MPI - END IF + END IF #endif - END IF + END IF #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif -! Find unique time steps (and sort in ascending order) - CALL UNIQUE(REAL(ts(1:line)),line,uniqueTim,maxTs) - -! Find unique lat and lon values (and sort in ascending order) - CALL UNIQUE(llat(1:line),SIZE(llat(1:line)),uniqueLatraw,nout1) - CALL UNIQUE(llon(1:line),SIZE(llon(1:line)),uniqueLonraw,nout2) - -!--042916----------------------- -! -! Redefine uniqueLatraw and uniqueLonrawto based on domain extent - WRITE(20,*) 'uniqueLatraw(:) =', uniqueLatraw(:) - WRITE(20,*) 'uniqueLonraw(:) =', uniqueLonraw(:) - - WRITE(20,*) 'No. increments: Longitude, Latitue =', mxcwt, mycwt - DEALLOCATE(uniqueLatraw) - DEALLOCATE(uniqueLonraw) - ALLOCATE(uniqueLatraw(mycwt+1)) - ALLOCATE(uniqueLonraw(mxcwt+1)) - DO i = 1,(mycwt+1) - uniqueLatraw(i) = minlat + & - (REAL(i)-1)/REAL(mycwt)*(maxlat-minlat) - END DO - DO i = 1,(mxcwt+1) - uniqueLonraw(i) = minlon + & - (REAL(i)-1)/REAL(mxcwt)*(maxlon-minlon) - END DO - WRITE(20,*) 'uniqueLatraw(:) =', uniqueLatraw(:) - WRITE(20,*) 'uniqueLonraw(:) =', uniqueLonraw(:) -! -!--042916----------------------- - -! Filter out lats and lons outside of domain of interest - DO latind1 = 1,SIZE(uniqueLatraw) - IF (uniqueLatraw(latind1).GE.minlat) EXIT - END DO - DO latind2 = SIZE(uniqueLatraw),1,-1 - IF (uniqueLatraw(latind2).LE.maxlat) EXIT - END DO - DO lonind1 = 1,SIZE(uniqueLonraw) - IF (uniqueLonraw(lonind1).GE.minlon) EXIT - END DO - DO lonind2 = SIZE(uniqueLonraw),1,-1 - IF (uniqueLonraw(lonind2).LE.maxlon) EXIT - END DO - WRITE(20,*) 'latind1, latind2, lonind1, lonind2 =', & - latind1, latind2, lonind1, lonind2 - IF ((latind1.GE.latind2).OR.(lonind1.GE.lonind2)) THEN - WRITE(20,1400) - WRITE(6,1400) - STOP 1 - END IF - NULLIFY(uniqueLat) - NULLIFY(uniqueLon) - ALLOCATE(uniqueLat(latind2-latind1+1)) - ALLOCATE(uniqueLon(lonind2-lonind1+1)) - uniqueLat = uniqueLatraw(latind1:latind2) - uniqueLon = uniqueLonraw(lonind1:lonind2) - WRITE(20,*) 'In waveTracking_NWS_V2: Longitude range =', & - uniqueLon(1), uniqueLon(SIZE(uniqueLon)) - WRITE(20,*) ' Latitude range =', & - uniqueLat(1), uniqueLat(SIZE(uniqueLat)) - -! Map is transposed (rotated by 90 deg), so that: -! I (matrix row) represents Longitute -! J (matrix column) represents Latitude -! i.e. from this point onwards the indices (i,j) represents Cart. coordinates - ALLOCATE( mlon(SIZE(uniqueLon),SIZE(uniqueLat)) ) - ALLOCATE( mlat(SIZE(uniqueLon),SIZE(uniqueLat)) ) -! - maxI = SIZE(uniqueLon) - maxJ = SIZE(uniqueLat) - DO I = 1,maxI - DO J = 1,maxJ - mlon(I,J) = uniqueLon(I) - mlat(I,J) = uniqueLat(J) - END DO - END DO + ! Find unique time steps (and sort in ascending order) + CALL UNIQUE(REAL(ts(1:line)),line,uniqueTim,maxTs) + + ! Find unique lat and lon values (and sort in ascending order) + CALL UNIQUE(llat(1:line),SIZE(llat(1:line)),uniqueLatraw,nout1) + CALL UNIQUE(llon(1:line),SIZE(llon(1:line)),uniqueLonraw,nout2) + + !--042916----------------------- + ! + ! Redefine uniqueLatraw and uniqueLonrawto based on domain extent + WRITE(20,*) 'uniqueLatraw(:) =', uniqueLatraw(:) + WRITE(20,*) 'uniqueLonraw(:) =', uniqueLonraw(:) + + WRITE(20,*) 'No. increments: Longitude, Latitue =', mxcwt, mycwt + DEALLOCATE(uniqueLatraw) + DEALLOCATE(uniqueLonraw) + ALLOCATE(uniqueLatraw(mycwt+1)) + ALLOCATE(uniqueLonraw(mxcwt+1)) + DO i = 1,(mycwt+1) + uniqueLatraw(i) = minlat + & + (REAL(i)-1)/REAL(mycwt)*(maxlat-minlat) + END DO + DO i = 1,(mxcwt+1) + uniqueLonraw(i) = minlon + & + (REAL(i)-1)/REAL(mxcwt)*(maxlon-minlon) + END DO + WRITE(20,*) 'uniqueLatraw(:) =', uniqueLatraw(:) + WRITE(20,*) 'uniqueLonraw(:) =', uniqueLonraw(:) + ! + !--042916----------------------- + + ! Filter out lats and lons outside of domain of interest + DO latind1 = 1,SIZE(uniqueLatraw) + IF (uniqueLatraw(latind1).GE.minlat) EXIT + END DO + DO latind2 = SIZE(uniqueLatraw),1,-1 + IF (uniqueLatraw(latind2).LE.maxlat) EXIT + END DO + DO lonind1 = 1,SIZE(uniqueLonraw) + IF (uniqueLonraw(lonind1).GE.minlon) EXIT + END DO + DO lonind2 = SIZE(uniqueLonraw),1,-1 + IF (uniqueLonraw(lonind2).LE.maxlon) EXIT + END DO + WRITE(20,*) 'latind1, latind2, lonind1, lonind2 =', & + latind1, latind2, lonind1, lonind2 + IF ((latind1.GE.latind2).OR.(lonind1.GE.lonind2)) THEN + WRITE(20,1400) + WRITE(6,1400) + STOP 1 + END IF + NULLIFY(uniqueLat) + NULLIFY(uniqueLon) + ALLOCATE(uniqueLat(latind2-latind1+1)) + ALLOCATE(uniqueLon(lonind2-lonind1+1)) + uniqueLat = uniqueLatraw(latind1:latind2) + uniqueLon = uniqueLonraw(lonind1:lonind2) + WRITE(20,*) 'In waveTracking_NWS_V2: Longitude range =', & + uniqueLon(1), uniqueLon(SIZE(uniqueLon)) + WRITE(20,*) ' Latitude range =', & + uniqueLat(1), uniqueLat(SIZE(uniqueLat)) + + ! Map is transposed (rotated by 90 deg), so that: + ! I (matrix row) represents Longitute + ! J (matrix column) represents Latitude + ! i.e. from this point onwards the indices (i,j) represents Cart. coordinates + ALLOCATE( mlon(SIZE(uniqueLon),SIZE(uniqueLat)) ) + ALLOCATE( mlat(SIZE(uniqueLon),SIZE(uniqueLat)) ) + ! + maxI = SIZE(uniqueLon) + maxJ = SIZE(uniqueLat) + DO I = 1,maxI + DO J = 1,maxJ + mlon(I,J) = uniqueLon(I) + mlat(I,J) = uniqueLat(J) + END DO + END DO #ifdef W3_MPI - END IF + END IF #endif #ifdef W3_MPI - CALL MPI_BCAST(maxI,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(maxJ,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(maxTs,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(maxI,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(maxJ,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(maxTs,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) #endif -! Allocate the wsdat structure + ! Allocate the wsdat structure #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif - WRITE(20,*) 'Allocating wsdat...' + WRITE(20,*) 'Allocating wsdat...' #ifdef W3_MPI - END IF + END IF #endif - NULLIFY(wsdat) - ALLOCATE(wsdat(maxTs)) + NULLIFY(wsdat) + ALLOCATE(wsdat(maxTs)) #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif - WRITE(20,*) 'SIZE(wsdat) = ',SIZE(wsdat) + WRITE(20,*) 'SIZE(wsdat) = ',SIZE(wsdat) #ifdef W3_MPI - END IF + END IF #endif -! Allocate and initialize the wsdat array + ! Allocate and initialize the wsdat array #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif - DO tsA = 1,maxTs - ALLOCATE(wsdat(tsA)%lat(maxI,maxJ)) - ALLOCATE(wsdat(tsA)%lon(maxI,maxJ)) - ALLOCATE(wsdat(tsA)%par(maxI,maxJ)) - ALLOCATE(wsdat(tsA)%wnd(maxI,maxJ)) + DO tsA = 1,maxTs + ALLOCATE(wsdat(tsA)%lat(maxI,maxJ)) + ALLOCATE(wsdat(tsA)%lon(maxI,maxJ)) + ALLOCATE(wsdat(tsA)%par(maxI,maxJ)) + ALLOCATE(wsdat(tsA)%wnd(maxI,maxJ)) - DO j = 1,maxJ - DO i = 1,maxI - wsdat(tsA)%lat(i,j)=mlat(i,j) - wsdat(tsA)%lon(i,j)=mlon(i,j) - wsdat(tsA)%maxi=maxI - wsdat(tsA)%maxj=maxJ - wsdat(tsA)%par(i,j)%hs(1:10)=9999. - wsdat(tsA)%par(i,j)%tp(1:10)=9999. - wsdat(tsA)%par(i,j)%dir(1:10)=9999. - wsdat(tsA)%par(i,j)%dspr(1:10)=9999. -! wsdat(tsA)%par(i,j)%wf(1:10)=9999. - wsdat(tsA)%par(i,j)%ipart(1:10)=0 - wsdat(tsA)%par(i,j)%sys(1:10)=9999 ! 40.PAR Increase this array, or make allocatable - wsdat(tsA)%par(i,j)%ngbrSys(1:50)=9999 - wsdat(tsA)%wnd(i,j)%wdir=9999. - wsdat(tsA)%wnd(i,j)%wspd=9999. - wsdat(tsA)%par(i,j)%checked=-1 - END DO + DO j = 1,maxJ + DO i = 1,maxI + wsdat(tsA)%lat(i,j)=mlat(i,j) + wsdat(tsA)%lon(i,j)=mlon(i,j) + wsdat(tsA)%maxi=maxI + wsdat(tsA)%maxj=maxJ + wsdat(tsA)%par(i,j)%hs(1:10)=9999. + wsdat(tsA)%par(i,j)%tp(1:10)=9999. + wsdat(tsA)%par(i,j)%dir(1:10)=9999. + wsdat(tsA)%par(i,j)%dspr(1:10)=9999. + ! wsdat(tsA)%par(i,j)%wf(1:10)=9999. + wsdat(tsA)%par(i,j)%ipart(1:10)=0 + wsdat(tsA)%par(i,j)%sys(1:10)=9999 ! 40.PAR Increase this array, or make allocatable + wsdat(tsA)%par(i,j)%ngbrSys(1:50)=9999 + wsdat(tsA)%wnd(i,j)%wdir=9999. + wsdat(tsA)%wnd(i,j)%wspd=9999. + wsdat(tsA)%par(i,j)%checked=-1 END DO - END DO + END DO + END DO -! Assign to each line in partition file an entry in wsdat -! At each time step each point contains all numpart partitions. -! Only store the first 10 partitions. - l = 1 + ! Assign to each line in partition file an entry in wsdat + ! At each time step each point contains all numpart partitions. + ! Only store the first 10 partitions. + l = 1 - DO WHILE (l.LE.line) - DO j = 1,maxJ - DO i = 1,maxI -!>042916 IF ( (llat(l).EQ.mlat(i,j)).AND. & -!>042916 (llon(l).EQ.mlon(i,j)) ) THEN - IF ( (ABS(llat(l)-mlat(i,j)).LT.1.E-2).AND. & - (ABS(llon(l)-mlon(i,j)).LT.1.E-2) ) THEN -! WRITE(20,*) 'MATCHED! ',l,& -! llat(l),mlat(i,j),ABS(llat(l)-mlat(i,j)),& -! llon(l),mlon(i,j),ABS(llon(l)-mlon(i,j)) - wsdat(ts(l))%lat(i,j) = llat(l) - wsdat(ts(l))%lon(i,j) = llon(l) -! --- Find ALL partition values associated with -! lat(i,j) and lon(i,j). Keep list index l -! fixed and recycle iline as variable index. --- - iline = l - k = 1 - DO WHILE ( & - ABS(wsdat(ts(l))%lat(i,j)-llat(iline)).LT.1.E-3 & - .AND.ABS(wsdat(ts(l))%lon(i,j)-llon(iline)).LT.1.E-3 ) - IF (k.LE.10) THEN - wsdat(ts(iline))%par(i,j)%ipart(k) = k - wsdat(ts(iline))%par(i,j)%hs(k) = hs0(iline) - wsdat(ts(iline))%par(i,j)%tp(k) = tp0(iline) - wsdat(ts(iline))%par(i,j)%dir(k) = dir0(iline) - wsdat(ts(iline))%par(i,j)%dspr(k) = dspr0(iline) -! wsdat(ts(k))%par(i,j)%wf(k) = wf0(l) - IF (k.EQ.1) THEN - wsdat(ts(iline))%date = date0(iline) - wsdat(ts(iline))%wnd(i,j)%wdir = wndDir0(iline) - wsdat(ts(iline))%wnd(i,j)%wspd = wndSpd0(iline) - wsdat(ts(iline))%par(i,j)%checked = 0 - END IF - END IF - k = k + 1 - iline = iline + 1 - if (iline.GT.line) EXIT - END DO -! --- Account for increment at the end of loop (400 CONTINUE) -! and go one element back in list because of increment. --- - l = iline-1 - GOTO 400 + DO WHILE (l.LE.line) + DO j = 1,maxJ + DO i = 1,maxI + !>042916 IF ( (llat(l).EQ.mlat(i,j)).AND. & + !>042916 (llon(l).EQ.mlon(i,j)) ) THEN + IF ( (ABS(llat(l)-mlat(i,j)).LT.1.E-2).AND. & + (ABS(llon(l)-mlon(i,j)).LT.1.E-2) ) THEN + ! WRITE(20,*) 'MATCHED! ',l,& + ! llat(l),mlat(i,j),ABS(llat(l)-mlat(i,j)),& + ! llon(l),mlon(i,j),ABS(llon(l)-mlon(i,j)) + wsdat(ts(l))%lat(i,j) = llat(l) + wsdat(ts(l))%lon(i,j) = llon(l) + ! --- Find ALL partition values associated with + ! lat(i,j) and lon(i,j). Keep list index l + ! fixed and recycle iline as variable index. --- + iline = l + k = 1 + DO WHILE ( & + ABS(wsdat(ts(l))%lat(i,j)-llat(iline)).LT.1.E-3 & + .AND.ABS(wsdat(ts(l))%lon(i,j)-llon(iline)).LT.1.E-3 ) + IF (k.LE.10) THEN + wsdat(ts(iline))%par(i,j)%ipart(k) = k + wsdat(ts(iline))%par(i,j)%hs(k) = hs0(iline) + wsdat(ts(iline))%par(i,j)%tp(k) = tp0(iline) + wsdat(ts(iline))%par(i,j)%dir(k) = dir0(iline) + wsdat(ts(iline))%par(i,j)%dspr(k) = dspr0(iline) + ! wsdat(ts(k))%par(i,j)%wf(k) = wf0(l) + IF (k.EQ.1) THEN + wsdat(ts(iline))%date = date0(iline) + wsdat(ts(iline))%wnd(i,j)%wdir = wndDir0(iline) + wsdat(ts(iline))%wnd(i,j)%wspd = wndSpd0(iline) + wsdat(ts(iline))%par(i,j)%checked = 0 + END IF END IF - END DO + k = k + 1 + iline = iline + 1 + if (iline.GT.line) EXIT + END DO + ! --- Account for increment at the end of loop (400 CONTINUE) + ! and go one element back in list because of increment. --- + l = iline-1 + GOTO 400 + END IF END DO - 400 CONTINUE - IF (l+1.le.line) THEN - IF (ts(l).LT.ts(l+1)) THEN + END DO +400 CONTINUE + IF (l+1.le.line) THEN + IF (ts(l).LT.ts(l+1)) THEN K = line-l -! --- With each time step completed, deallocate processed 1:l -! elements from 1d array. Create a temporary array size of -! (l+1:line) with k elements and reallocate original array. --- + ! --- With each time step completed, deallocate processed 1:l + ! elements from 1d array. Create a temporary array size of + ! (l+1:line) with k elements and reallocate original array. --- IF (ALLOCATED(tmp_i4)) DEALLOCATE(tmp_i4) -! --- REALLOCATE(integer arrays) --- + ! --- REALLOCATE(integer arrays) --- ALLOCATE(tmp_i4(k)) tmp_i4(1:k) = ts((l+1):line) DEALLOCATE(ts) ALLOCATE(ts(k)) ts(1:k) = tmp_i4(1:k) DEALLOCATE(tmp_i4) -! --- REALLOCATE(double precision arrays) --- + ! --- REALLOCATE(double precision arrays) --- IF (ALLOCATED(tmp_r8)) DEALLOCATE(tmp_r8) ALLOCATE(tmp_r8(k)) tmp_r8(1:k) = date0((l+1):line) @@ -1069,7 +1069,7 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & ALLOCATE(date0(k)) date0(1:k) = tmp_r8(1:k) DEALLOCATE(tmp_r8) -! --- REALLOCATE(single precision arrays) --- + ! --- REALLOCATE(single precision arrays) --- IF (ALLOCATED(tmp_r4)) DEALLOCATE(tmp_r4) ALLOCATE(tmp_r4(k)) tmp_r4(1:k) = llat((l+1):line) @@ -1107,307 +1107,307 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & DEALLOCATE(tmp_r4) line = k l = 0 - END IF END IF - l = l + 1 - END DO -! - IF (ALLOCATED(ts)) DEALLOCATE(ts) - IF (ALLOCATED(llat)) DEALLOCATE(llat) - IF (ALLOCATED(llon)) DEALLOCATE(llon) - IF (ALLOCATED(mlat)) DEALLOCATE(mlat) - IF (ALLOCATED(mlon)) DEALLOCATE(mlon) - IF (ALLOCATED(date0)) DEALLOCATE(date0) - IF (ALLOCATED(hs0)) DEALLOCATE(hs0) - IF (ALLOCATED(tp0)) DEALLOCATE(tp0) - IF (ALLOCATED(dir0)) DEALLOCATE(dir0) - IF (ALLOCATED(dspr0)) DEALLOCATE(dspr0) -! IF (ALLOCATED(wf0)) DEALLOCATE(wf0) - IF (ALLOCATED(wndSpd0)) DEALLOCATE(wndSpd0) - IF (ALLOCATED(wndDir0)) DEALLOCATE(wndDir0) + END IF + l = l + 1 + END DO + ! + IF (ALLOCATED(ts)) DEALLOCATE(ts) + IF (ALLOCATED(llat)) DEALLOCATE(llat) + IF (ALLOCATED(llon)) DEALLOCATE(llon) + IF (ALLOCATED(mlat)) DEALLOCATE(mlat) + IF (ALLOCATED(mlon)) DEALLOCATE(mlon) + IF (ALLOCATED(date0)) DEALLOCATE(date0) + IF (ALLOCATED(hs0)) DEALLOCATE(hs0) + IF (ALLOCATED(tp0)) DEALLOCATE(tp0) + IF (ALLOCATED(dir0)) DEALLOCATE(dir0) + IF (ALLOCATED(dspr0)) DEALLOCATE(dspr0) + ! IF (ALLOCATED(wf0)) DEALLOCATE(wf0) + IF (ALLOCATED(wndSpd0)) DEALLOCATE(wndSpd0) + IF (ALLOCATED(wndDir0)) DEALLOCATE(wndDir0) #ifdef W3_MPI - END IF + END IF #endif #ifdef W3_MPI -! Communicate the wsdat entries from rank=0 to other ranks - DO tsA = t0,maxTs - irank = MOD((tsA-t0),MIN(nproc,maxTS)) -! WRITE(20,*) 'Rank,irank=',rank,irank - IF (irank.NE.0) THEN -! WRITE(20,*) 'Communicating for Rank,irank=',rank,irank - - IF (rank.EQ.irank) THEN - ALLOCATE(wsdat(tsA)%lat(maxI,maxJ)) - ALLOCATE(wsdat(tsA)%lon(maxI,maxJ)) - ALLOCATE(wsdat(tsA)%par(maxI,maxJ)) - ALLOCATE(wsdat(tsA)%wnd(maxI,maxJ)) - - DO j = 1,maxJ - DO i = 1,maxI - wsdat(tsA)%maxi=maxI - wsdat(tsA)%maxj=maxJ - wsdat(tsA)%par(i,j)%hs(1:10)=9999. - wsdat(tsA)%par(i,j)%tp(1:10)=9999. - wsdat(tsA)%par(i,j)%dir(1:10)=9999. - wsdat(tsA)%par(i,j)%dspr(1:10)=9999. - wsdat(tsA)%par(i,j)%ipart(1:10)=0 - wsdat(tsA)%par(i,j)%sys(1:10)=9999 ! 40.PAR Increase this array, or make allocatable - wsdat(tsA)%par(i,j)%ngbrSys(1:50)=9999 - wsdat(tsA)%wnd(i,j)%wdir=9999. - wsdat(tsA)%wnd(i,j)%wspd=9999. - wsdat(tsA)%par(i,j)%checked=-1 - END DO - END DO - END IF + ! Communicate the wsdat entries from rank=0 to other ranks + DO tsA = t0,maxTs + irank = MOD((tsA-t0),MIN(nproc,maxTS)) + ! WRITE(20,*) 'Rank,irank=',rank,irank + IF (irank.NE.0) THEN + ! WRITE(20,*) 'Communicating for Rank,irank=',rank,irank - DO j = 1,maxJ - DO i = 1,maxI - tag1 = ((j-1)*maxI+i)*10 - - IF (rank.EQ.0) THEN -! WRITE(6,*) '>> Sending: rank,irank,tag1=', & -! rank,irank,(tag1+1) - COMMARR1 = (/wsdat(tsA)%par(i,j)%hs(:), & - wsdat(tsA)%par(i,j)%tp(:), & - wsdat(tsA)%par(i,j)%dir(:), & - wsdat(tsA)%par(i,j)%dspr(:), & - wsdat(tsA)%wnd(i,j)%wdir, & - wsdat(tsA)%wnd(i,j)%wspd, & - wsdat(tsA)%lat(i,j), & - wsdat(tsA)%lon(i,j)/) - CALL MPI_SEND(COMMARR1,44,MPI_REAL,irank, & - (tag1+1),MPI_COMM_WORLD,IERR) - END IF - IF (rank.EQ.irank) THEN -! WRITE(6,*) '<< Receiving: rank,irank,tag1=', & -! rank,irank,(tag1+1) - CALL MPI_RECV(COMMARR1,44,MPI_REAL,0,(tag1+1), & - MPI_COMM_WORLD,MPI_STATUS,IERR) - wsdat(tsA)%par(i,j)%hs = COMMARR1(1:10) - wsdat(tsA)%par(i,j)%tp = COMMARR1(11:20) - wsdat(tsA)%par(i,j)%dir = COMMARR1(21:30) - wsdat(tsA)%par(i,j)%dspr = COMMARR1(31:40) - wsdat(tsA)%wnd(i,j)%wdir = COMMARR1(41) - wsdat(tsA)%wnd(i,j)%wspd = COMMARR1(42) - wsdat(tsA)%lat(i,j) = COMMARR1(43) - wsdat(tsA)%lon(i,j) = COMMARR1(44) - END IF + IF (rank.EQ.irank) THEN + ALLOCATE(wsdat(tsA)%lat(maxI,maxJ)) + ALLOCATE(wsdat(tsA)%lon(maxI,maxJ)) + ALLOCATE(wsdat(tsA)%par(maxI,maxJ)) + ALLOCATE(wsdat(tsA)%wnd(maxI,maxJ)) - IF (rank.EQ.0) THEN - CALL MPI_SEND(wsdat(tsA)%date,1, & - MPI_DOUBLE_PRECISION,irank, & - (tag1+2),MPI_COMM_WORLD,IERR) - END IF - IF (rank.EQ.irank) THEN - CALL MPI_RECV(wsdat(tsA)%date,1, & - MPI_DOUBLE_PRECISION,0,(tag1+2), & - MPI_COMM_WORLD,MPI_STATUS,IERR) - END IF + DO j = 1,maxJ + DO i = 1,maxI + wsdat(tsA)%maxi=maxI + wsdat(tsA)%maxj=maxJ + wsdat(tsA)%par(i,j)%hs(1:10)=9999. + wsdat(tsA)%par(i,j)%tp(1:10)=9999. + wsdat(tsA)%par(i,j)%dir(1:10)=9999. + wsdat(tsA)%par(i,j)%dspr(1:10)=9999. + wsdat(tsA)%par(i,j)%ipart(1:10)=0 + wsdat(tsA)%par(i,j)%sys(1:10)=9999 ! 40.PAR Increase this array, or make allocatable + wsdat(tsA)%par(i,j)%ngbrSys(1:50)=9999 + wsdat(tsA)%wnd(i,j)%wdir=9999. + wsdat(tsA)%wnd(i,j)%wspd=9999. + wsdat(tsA)%par(i,j)%checked=-1 + END DO + END DO + END IF - IF (rank.EQ.0) THEN -! WRITE(6,*) '>> Sending: rank,irank,tag1=', & -! rank,irank,(tag1+3) - COMMARR2 = (/wsdat(tsA)%par(i,j)%ipart(:), & - wsdat(tsA)%par(i,j)%checked/) - CALL MPI_SEND(COMMARR2,11, & - MPI_INTEGER,irank,(tag1+3),MPI_COMM_WORLD,IERR) - END IF - IF (rank.EQ.irank) THEN -! WRITE(6,*) '<< Receiving: rank,irank,tag1=', & -! rank,irank,(tag1+3) - CALL MPI_RECV(COMMARR2,11, & - MPI_INTEGER,0,(tag1+3), & - MPI_COMM_WORLD,MPI_STATUS,IERR) - wsdat(tsA)%par(i,j)%ipart(:) = COMMARR2(1:10) - wsdat(tsA)%par(i,j)%checked = COMMARR2(11) - END IF + DO j = 1,maxJ + DO i = 1,maxI + tag1 = ((j-1)*maxI+i)*10 + + IF (rank.EQ.0) THEN + ! WRITE(6,*) '>> Sending: rank,irank,tag1=', & + ! rank,irank,(tag1+1) + COMMARR1 = (/wsdat(tsA)%par(i,j)%hs(:), & + wsdat(tsA)%par(i,j)%tp(:), & + wsdat(tsA)%par(i,j)%dir(:), & + wsdat(tsA)%par(i,j)%dspr(:), & + wsdat(tsA)%wnd(i,j)%wdir, & + wsdat(tsA)%wnd(i,j)%wspd, & + wsdat(tsA)%lat(i,j), & + wsdat(tsA)%lon(i,j)/) + CALL MPI_SEND(COMMARR1,44,MPI_REAL,irank, & + (tag1+1),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.irank) THEN + ! WRITE(6,*) '<< Receiving: rank,irank,tag1=', & + ! rank,irank,(tag1+1) + CALL MPI_RECV(COMMARR1,44,MPI_REAL,0,(tag1+1), & + MPI_COMM_WORLD,MPI_STATUS,IERR) + wsdat(tsA)%par(i,j)%hs = COMMARR1(1:10) + wsdat(tsA)%par(i,j)%tp = COMMARR1(11:20) + wsdat(tsA)%par(i,j)%dir = COMMARR1(21:30) + wsdat(tsA)%par(i,j)%dspr = COMMARR1(31:40) + wsdat(tsA)%wnd(i,j)%wdir = COMMARR1(41) + wsdat(tsA)%wnd(i,j)%wspd = COMMARR1(42) + wsdat(tsA)%lat(i,j) = COMMARR1(43) + wsdat(tsA)%lon(i,j) = COMMARR1(44) + END IF - END DO - END DO - END IF - END DO + IF (rank.EQ.0) THEN + CALL MPI_SEND(wsdat(tsA)%date,1, & + MPI_DOUBLE_PRECISION,irank, & + (tag1+2),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.irank) THEN + CALL MPI_RECV(wsdat(tsA)%date,1, & + MPI_DOUBLE_PRECISION,0,(tag1+2), & + MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF + + IF (rank.EQ.0) THEN + ! WRITE(6,*) '>> Sending: rank,irank,tag1=', & + ! rank,irank,(tag1+3) + COMMARR2 = (/wsdat(tsA)%par(i,j)%ipart(:), & + wsdat(tsA)%par(i,j)%checked/) + CALL MPI_SEND(COMMARR2,11, & + MPI_INTEGER,irank,(tag1+3),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.irank) THEN + ! WRITE(6,*) '<< Receiving: rank,irank,tag1=', & + ! rank,irank,(tag1+3) + CALL MPI_RECV(COMMARR2,11, & + MPI_INTEGER,0,(tag1+3), & + MPI_COMM_WORLD,MPI_STATUS,IERR) + wsdat(tsA)%par(i,j)%ipart(:) = COMMARR2(1:10) + wsdat(tsA)%par(i,j)%checked = COMMARR2(11) + END IF + + END DO + END DO + END IF + END DO - CALL MPI_Barrier(MPI_COMM_WORLD,IERR) + CALL MPI_Barrier(MPI_COMM_WORLD,IERR) #endif #ifdef W3_MPI IF (rank.EQ.0) THEN #endif -! ----*** Test Output *** -------------------------------------------------- - IF (testout) THEN -!-----RAW PARTITION output: Coordinates - OPEN(unit=31,file='PART_COORD.OUT',status='unknown') + ! ----*** Test Output *** -------------------------------------------------- + IF (testout) THEN + !-----RAW PARTITION output: Coordinates + OPEN(unit=31,file='PART_COORD.OUT',status='unknown') - WRITE(31,*) 'Longitude =' - DO j = maxJ,1,-1 - DO i = 1,maxI - WRITE(31,'(F7.2)',ADVANCE='NO') wsdat(1)%lon(i,j) - END DO - WRITE(31,'(A)',ADVANCE='YES') '' - END DO + WRITE(31,*) 'Longitude =' + DO j = maxJ,1,-1 + DO i = 1,maxI + WRITE(31,'(F7.2)',ADVANCE='NO') wsdat(1)%lon(i,j) + END DO + WRITE(31,'(A)',ADVANCE='YES') '' + END DO - WRITE(31,*) 'Latitude = ' - DO j = maxJ,1,-1 - DO i = 1,maxI - WRITE(31,'(F7.2)',ADVANCE='NO') wsdat(1)%lat(i,j) - END DO - WRITE(31,'(A)',ADVANCE='YES') '' - END DO + WRITE(31,*) 'Latitude = ' + DO j = maxJ,1,-1 + DO i = 1,maxI + WRITE(31,'(F7.2)',ADVANCE='NO') wsdat(1)%lat(i,j) + END DO + WRITE(31,'(A)',ADVANCE='YES') '' + END DO - CLOSE(31) - -!-----RAW PARTITION output: hs - OPEN(unit=32, file='PART_HSIGN.OUT', & - status='unknown') - - maxpartout = 5 - DO tsA = 1,SIZE(wsdat) - WRITE(32,'(I4,71x,A)') tsA,'Time step' - WRITE(32,'(I4,71x,A)') maxpartout,'Tot number of raw partitions' - DO k = 1,maxpartout - WRITE(32,'(I4,71x,A)') k,'System number' - WRITE(32,'(I4,71x,A)') 9999,'Number of points in system' - DO j = maxJ,1,-1 - DO i = 1,maxI + CLOSE(31) + + !-----RAW PARTITION output: hs + OPEN(unit=32, file='PART_HSIGN.OUT', & + status='unknown') + + maxpartout = 5 + DO tsA = 1,SIZE(wsdat) + WRITE(32,'(I4,71x,A)') tsA,'Time step' + WRITE(32,'(I4,71x,A)') maxpartout,'Tot number of raw partitions' + DO k = 1,maxpartout + WRITE(32,'(I4,71x,A)') k,'System number' + WRITE(32,'(I4,71x,A)') 9999,'Number of points in system' + DO j = maxJ,1,-1 + DO i = 1,maxI WRITE(32,'(F8.2)',ADVANCE='NO') wsdat(tsA)%par(i,j)%hs(k) - END DO - WRITE(32,'(A)',ADVANCE='YES') '' + END DO + WRITE(32,'(A)',ADVANCE='YES') '' + END DO END DO - END DO - END DO + END DO - CLOSE(32) - -!-----RAW PARTITION output: tp -! OPEN(unit=33,recl=2147483646, file='PART_TP.OUT', & -! status='unknown') - OPEN(unit=33, file='PART_TP.OUT', & - status='unknown') - - DO tsA = 1,SIZE(wsdat) - WRITE(33,'(I4,71x,A)') tsA,'Time step' - WRITE(33,'(I4,71x,A)') maxpartout,'Tot number of raw partitions' - DO k = 1,maxpartout - WRITE(33,'(I4,71x,A)') k,'System number' - WRITE(33,'(I4,71x,A)') 9999,'Number of points in system' - DO j = maxJ,1,-1 - DO i = 1,maxI + CLOSE(32) + + !-----RAW PARTITION output: tp + ! OPEN(unit=33,recl=2147483646, file='PART_TP.OUT', & + ! status='unknown') + OPEN(unit=33, file='PART_TP.OUT', & + status='unknown') + + DO tsA = 1,SIZE(wsdat) + WRITE(33,'(I4,71x,A)') tsA,'Time step' + WRITE(33,'(I4,71x,A)') maxpartout,'Tot number of raw partitions' + DO k = 1,maxpartout + WRITE(33,'(I4,71x,A)') k,'System number' + WRITE(33,'(I4,71x,A)') 9999,'Number of points in system' + DO j = maxJ,1,-1 + DO i = 1,maxI WRITE(33,'(F8.2)',ADVANCE='NO') wsdat(tsA)%par(i,j)%tp(k) - END DO - WRITE(33,'(A)',ADVANCE='YES') '' + END DO + WRITE(33,'(A)',ADVANCE='YES') '' + END DO END DO - END DO - END DO + END DO - CLOSE(33) + CLOSE(33) -!-----RAW PARTITION output: dir - OPEN(unit=34, file='PART_DIR.OUT', & - status='unknown') + !-----RAW PARTITION output: dir + OPEN(unit=34, file='PART_DIR.OUT', & + status='unknown') - DO tsA = 1,SIZE(wsdat) - WRITE(34,'(I4,71x,A)') tsA,'Time step' - WRITE(34,'(I4,71x,A)') maxpartout,'Tot number of raw partitions' - DO k = 1,maxpartout - WRITE(34,'(I4,71x,A)') k,'System number' - WRITE(34,'(I4,71x,A)') 9999,'Number of points in system' - DO j = maxJ,1,-1 - DO i = 1,maxI + DO tsA = 1,SIZE(wsdat) + WRITE(34,'(I4,71x,A)') tsA,'Time step' + WRITE(34,'(I4,71x,A)') maxpartout,'Tot number of raw partitions' + DO k = 1,maxpartout + WRITE(34,'(I4,71x,A)') k,'System number' + WRITE(34,'(I4,71x,A)') 9999,'Number of points in system' + DO j = maxJ,1,-1 + DO i = 1,maxI WRITE(34,'(F8.2)',ADVANCE='NO') wsdat(tsA)%par(i,j)%dir(k) - END DO - WRITE(34,'(A)',ADVANCE='YES') '' + END DO + WRITE(34,'(A)',ADVANCE='YES') '' + END DO END DO - END DO - END DO + END DO - CLOSE(34) - -!-----RAW PARTITION output: dspr - OPEN(unit=35, file='PART_DSPR.OUT', & - status='unknown') - - DO tsA = 1,SIZE(wsdat) - WRITE(35,'(I4,71x,A)') tsA,'Time step' - WRITE(35,'(I4,71x,A)') maxpartout,'Tot number of raw partitions' - DO k = 1,maxpartout - WRITE(35,'(I4,71x,A)') k,'System number' - WRITE(35,'(I4,71x,A)') 9999,'Number of points in system' - DO j = maxJ,1,-1 - DO i = 1,maxI - WRITE(35,'(F8.2)',ADVANCE='NO') & - wsdat(tsA)%par(i,j)%dspr(k) - END DO - WRITE(35,'(A)',ADVANCE='YES') '' + CLOSE(34) + + !-----RAW PARTITION output: dspr + OPEN(unit=35, file='PART_DSPR.OUT', & + status='unknown') + + DO tsA = 1,SIZE(wsdat) + WRITE(35,'(I4,71x,A)') tsA,'Time step' + WRITE(35,'(I4,71x,A)') maxpartout,'Tot number of raw partitions' + DO k = 1,maxpartout + WRITE(35,'(I4,71x,A)') k,'System number' + WRITE(35,'(I4,71x,A)') 9999,'Number of points in system' + DO j = maxJ,1,-1 + DO i = 1,maxI + WRITE(35,'(F8.2)',ADVANCE='NO') & + wsdat(tsA)%par(i,j)%dspr(k) + END DO + WRITE(35,'(A)',ADVANCE='YES') '' + END DO END DO - END DO - END DO + END DO - CLOSE(35) - END IF + CLOSE(35) + END IF #ifdef W3_MPI END IF #endif -! ------------------------------------------------------------------------ + ! ------------------------------------------------------------------------ -! Allocate the sysA structure + ! Allocate the sysA structure #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif - WRITE(20,*) 'Allocating sysA...' + WRITE(20,*) 'Allocating sysA...' #ifdef W3_MPI - END IF + END IF #endif - ALLOCATE( sysA(maxTs) ) + ALLOCATE( sysA(maxTs) ) #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif - WRITE(20,*) 'SIZE(sysA) = ',SIZE(sysA) - WRITE(6,1020) ' Number of time levels being processed:',SIZE(sysA) - 1020 FORMAT(A,I4) + WRITE(20,*) 'SIZE(sysA) = ',SIZE(sysA) + WRITE(6,1020) ' Number of time levels being processed:',SIZE(sysA) +1020 FORMAT(A,I4) #ifdef W3_MPI - END IF -#endif - -! Allocate maxSys - ALLOCATE( maxSys(maxTs) ) - ELSE -! Raw partitioning data from wave model memory, via the array wsdat. -! Set maxTs to the time step to compute: 1=first time step, 2=otherwise - maxTs = tmax - t0 = tcur - -! Allocate the sysA structure - ALLOCATE( sysA(1) ) !Change to sysA(2)? -! Allocate maxSys - ALLOCATE( maxSys(1) ) !Change to maxSys(2)? END IF +#endif -! Big loop over all time levels + ! Allocate maxSys + ALLOCATE( maxSys(maxTs) ) + ELSE + ! Raw partitioning data from wave model memory, via the array wsdat. + ! Set maxTs to the time step to compute: 1=first time step, 2=otherwise + maxTs = tmax + t0 = tcur + + ! Allocate the sysA structure + ALLOCATE( sysA(1) ) !Change to sysA(2)? + ! Allocate maxSys + ALLOCATE( maxSys(1) ) !Change to maxSys(2)? + END IF + + ! Big loop over all time levels #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif - WRITE(6,*) 'Performing spatial tracking...' + WRITE(6,*) 'Performing spatial tracking...' #ifdef W3_MPI - END IF -! WRITE(20,*) 'rank,t0,maxTs,nproc =',rank,t0,maxTs,nproc - DO tsA = (t0+rank),maxTs,MIN(nproc,maxTS) -! WRITE(20,*) 'Computing: Rank, tsA =',rank,tsA + END IF + ! WRITE(20,*) 'rank,t0,maxTs,nproc =',rank,t0,maxTs,nproc + DO tsA = (t0+rank),maxTs,MIN(nproc,maxTS) + ! WRITE(20,*) 'Computing: Rank, tsA =',rank,tsA #endif #ifdef W3_SHRD DO tsA = t0,maxTs #endif - WRITE(20,*) 'Call spiralTrackV3, tsA=',tsA,'...' - CALL spiralTrackV3 ( wsdat(tsA), dirKnob, perKnob, wetPts, & - hsKnob, seedLat, seedLon, & - maxSys(tsA), sysA(tsA)%sys ) + WRITE(20,*) 'Call spiralTrackV3, tsA=',tsA,'...' + CALL spiralTrackV3 ( wsdat(tsA), dirKnob, perKnob, wetPts, & + hsKnob, seedLat, seedLon, & + maxSys(tsA), sysA(tsA)%sys ) - WRITE(20,*) '*** SIZE(sysA(1:tsA)%sys) at end of time step', & - tsA,':' - WRITE(20,*) SIZE(sysA(tsA)%sys) + WRITE(20,*) '*** SIZE(sysA(1:tsA)%sys) at end of time step', & + tsA,':' + WRITE(20,*) SIZE(sysA(tsA)%sys) #ifdef W3_SHRD END DO #endif @@ -1416,4685 +1416,4685 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & #endif #ifdef W3_MPI - CALL MPI_Barrier(MPI_COMM_WORLD,IERR) + CALL MPI_Barrier(MPI_COMM_WORLD,IERR) + + !! Define communicator for array of integers in structure "system" + ! DOMSIZE = maxI*maxJ + ! WRITE(20,*) 'Rank',rank,'DOMSIZE =',DOMSIZE + ! CALL MPI_TYPE_CONTIGUOUS(DOMSIZE,MPI_INTEGER,MPI_INT_DOMARR,IERR) + ! CALL MPI_TYPE_COMMIT(MPI_INT_DOMARR,IERR) + ! CALL MPI_TYPE_EXTENT(MPI_INT_DOMARR,EXTENT,IERR) + ! WRITE(20,*) 'Rank',rank,'has set up communicator MPI_INT_DOMARR, & + ! size =',EXTENT + + !! Define communicator for array of reals in structure "system" + ! CALL MPI_TYPE_CONTIGUOUS(DOMSIZE,MPI_REAL,MPI_REAL_DOMARR,IERR) + ! CALL MPI_TYPE_COMMIT(MPI_REAL_DOMARR,IERR) + ! CALL MPI_TYPE_EXTENT(MPI_REAL_DOMARR,EXTENT,IERR) + ! WRITE(20,*) 'Rank',rank,'has set up communicator MPI_REAL_DOMARR, & + ! size =',EXTENT + + ! Communicate results back to rank 0 + DO tsA = t0,maxTs + irank = MOD((tsA-t0),MIN(nproc,maxTS)) + ! WRITE(20,*) 'Rank,irank=',rank,irank + IF (irank.NE.0) THEN + ! WRITE(20,*) 'Communicating for Rank,irank=',rank,irank + + ! Send maxSys(tsA) at each time level to rank 0 + tag1 = tsA + IF (rank.EQ.irank) THEN + ! Send results from current rank to rank 0 (blocking) + ! WRITE(20,*) '>> Sending: rank,tsA,tag1=',rank,tsA,tag1 + CALL MPI_SEND(maxSys(tsA),1,MPI_INTEGER,0,tag1, & + MPI_COMM_WORLD,IERR) + ! WRITE(20,*) 'Rank, IERR=',rank,IERR + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,tsA,tag1=',rank,tsA,tag1 + CALL MPI_RECV(maxSys(tsA),1,MPI_INTEGER, & + irank,tag1,MPI_COMM_WORLD,MPI_STATUS,IERR) + ! Allocate structure at this time level + ALLOCATE( sysA(tsA)%sys(maxSys(tsA)) ) + DO ic = 1,maxSys(tsA) + NULLIFY( sysA(tsA)%sys(ic)%i ) + NULLIFY( sysA(tsA)%sys(ic)%j ) + NULLIFY( sysA(tsA)%sys(ic)%lon ) + NULLIFY( sysA(tsA)%sys(ic)%lat ) + NULLIFY( sysA(tsA)%sys(ic)%hs ) + NULLIFY( sysA(tsA)%sys(ic)%tp ) + NULLIFY( sysA(tsA)%sys(ic)%dir) + NULLIFY( sysA(tsA)%sys(ic)%dspr) + ALLOCATE( sysA(tsA)%sys(ic)%i(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%j(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%lon(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%lat(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%hs(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%tp(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%dir(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%dspr(maxI*maxJ) ) + sysA(tsA)%sys(ic)%i(:) = 9999 + sysA(tsA)%sys(ic)%j(:) = 9999 + sysA(tsA)%sys(ic)%lon(:) = 9999. + sysA(tsA)%sys(ic)%lat(:) = 9999. + sysA(tsA)%sys(ic)%hs(:) = 9999. + sysA(tsA)%sys(ic)%tp(:) = 9999. + sysA(tsA)%sys(ic)%dir(:) = 9999. + sysA(tsA)%sys(ic)%dspr(:) = 9999. + sysA(tsA)%sys(ic)%hsMean = 9999. + sysA(tsA)%sys(ic)%tpMean = 9999. + sysA(tsA)%sys(ic)%dirMean = 9999. + sysA(tsA)%sys(ic)%sysInd = 9999 + sysA(tsA)%sys(ic)%nPoints = 9999 + sysA(tsA)%sys(ic)%grp = 9999 + END DO + END IF -!! Define communicator for array of integers in structure "system" -! DOMSIZE = maxI*maxJ -! WRITE(20,*) 'Rank',rank,'DOMSIZE =',DOMSIZE -! CALL MPI_TYPE_CONTIGUOUS(DOMSIZE,MPI_INTEGER,MPI_INT_DOMARR,IERR) -! CALL MPI_TYPE_COMMIT(MPI_INT_DOMARR,IERR) -! CALL MPI_TYPE_EXTENT(MPI_INT_DOMARR,EXTENT,IERR) -! WRITE(20,*) 'Rank',rank,'has set up communicator MPI_INT_DOMARR, & -! size =',EXTENT - -!! Define communicator for array of reals in structure "system" -! CALL MPI_TYPE_CONTIGUOUS(DOMSIZE,MPI_REAL,MPI_REAL_DOMARR,IERR) -! CALL MPI_TYPE_COMMIT(MPI_REAL_DOMARR,IERR) -! CALL MPI_TYPE_EXTENT(MPI_REAL_DOMARR,EXTENT,IERR) -! WRITE(20,*) 'Rank',rank,'has set up communicator MPI_REAL_DOMARR, & -! size =',EXTENT - -! Communicate results back to rank 0 - DO tsA = t0,maxTs - irank = MOD((tsA-t0),MIN(nproc,maxTS)) -! WRITE(20,*) 'Rank,irank=',rank,irank - IF (irank.NE.0) THEN -! WRITE(20,*) 'Communicating for Rank,irank=',rank,irank + ! Send data fields at each (tsA,ic) combination + IF ((rank.EQ.0).OR.(rank.EQ.irank)) THEN + DO ic = 1, maxSys(tsA) + ! Construct a unique tag for each message + tag2 = tsA*10000 + ic*100 + DOMSIZE = maxI*maxJ -! Send maxSys(tsA) at each time level to rank 0 - tag1 = tsA IF (rank.EQ.irank) THEN -! Send results from current rank to rank 0 (blocking) -! WRITE(20,*) '>> Sending: rank,tsA,tag1=',rank,tsA,tag1 - CALL MPI_SEND(maxSys(tsA),1,MPI_INTEGER,0,tag1, & - MPI_COMM_WORLD,IERR) -! WRITE(20,*) 'Rank, IERR=',rank,IERR + ! WRITE(20,*) '>> Sending: rank,irank,tag2=', & + ! rank,irank,(tag2+1) + CALL MPI_SEND(sysA(tsA)%sys(ic)%i(:),DOMSIZE, & + MPI_INTEGER,0,(tag2+1),MPI_COMM_WORLD,REQ(1),IERR) END IF IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,tsA,tag1=',rank,tsA,tag1 - CALL MPI_RECV(maxSys(tsA),1,MPI_INTEGER, & - irank,tag1,MPI_COMM_WORLD,MPI_STATUS,IERR) -! Allocate structure at this time level - ALLOCATE( sysA(tsA)%sys(maxSys(tsA)) ) - DO ic = 1,maxSys(tsA) - NULLIFY( sysA(tsA)%sys(ic)%i ) - NULLIFY( sysA(tsA)%sys(ic)%j ) - NULLIFY( sysA(tsA)%sys(ic)%lon ) - NULLIFY( sysA(tsA)%sys(ic)%lat ) - NULLIFY( sysA(tsA)%sys(ic)%hs ) - NULLIFY( sysA(tsA)%sys(ic)%tp ) - NULLIFY( sysA(tsA)%sys(ic)%dir) - NULLIFY( sysA(tsA)%sys(ic)%dspr) - ALLOCATE( sysA(tsA)%sys(ic)%i(maxI*maxJ) ) - ALLOCATE( sysA(tsA)%sys(ic)%j(maxI*maxJ) ) - ALLOCATE( sysA(tsA)%sys(ic)%lon(maxI*maxJ) ) - ALLOCATE( sysA(tsA)%sys(ic)%lat(maxI*maxJ) ) - ALLOCATE( sysA(tsA)%sys(ic)%hs(maxI*maxJ) ) - ALLOCATE( sysA(tsA)%sys(ic)%tp(maxI*maxJ) ) - ALLOCATE( sysA(tsA)%sys(ic)%dir(maxI*maxJ) ) - ALLOCATE( sysA(tsA)%sys(ic)%dspr(maxI*maxJ) ) - sysA(tsA)%sys(ic)%i(:) = 9999 - sysA(tsA)%sys(ic)%j(:) = 9999 - sysA(tsA)%sys(ic)%lon(:) = 9999. - sysA(tsA)%sys(ic)%lat(:) = 9999. - sysA(tsA)%sys(ic)%hs(:) = 9999. - sysA(tsA)%sys(ic)%tp(:) = 9999. - sysA(tsA)%sys(ic)%dir(:) = 9999. - sysA(tsA)%sys(ic)%dspr(:) = 9999. - sysA(tsA)%sys(ic)%hsMean = 9999. - sysA(tsA)%sys(ic)%tpMean = 9999. - sysA(tsA)%sys(ic)%dirMean = 9999. - sysA(tsA)%sys(ic)%sysInd = 9999 - sysA(tsA)%sys(ic)%nPoints = 9999 - sysA(tsA)%sys(ic)%grp = 9999 - END DO + ! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & + ! rank,irank,(tag2+1) + CALL MPI_RECV(sysA(tsA)%sys(ic)%i(:),DOMSIZE, & + MPI_INTEGER,irank,(tag2+1), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) END IF + ! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -! Send data fields at each (tsA,ic) combination - IF ((rank.EQ.0).OR.(rank.EQ.irank)) THEN - DO ic = 1, maxSys(tsA) -! Construct a unique tag for each message - tag2 = tsA*10000 + ic*100 - DOMSIZE = maxI*maxJ - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -! rank,irank,(tag2+1) - CALL MPI_SEND(sysA(tsA)%sys(ic)%i(:),DOMSIZE, & - MPI_INTEGER,0,(tag2+1),MPI_COMM_WORLD,REQ(1),IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -! rank,irank,(tag2+1) - CALL MPI_RECV(sysA(tsA)%sys(ic)%i(:),DOMSIZE, & - MPI_INTEGER,irank,(tag2+1), & - MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) - END IF -! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -! rank,irank,(tag2+2) - CALL MPI_SEND(sysA(tsA)%sys(ic)%j(:),DOMSIZE, & - MPI_INTEGER,0,(tag2+2),MPI_COMM_WORLD,REQ(1),IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -! rank,irank,(tag2+2) - CALL MPI_RECV(sysA(tsA)%sys(ic)%j(:),DOMSIZE, & - MPI_INTEGER,irank,(tag2+2), & - MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) - END IF -! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+3) - CALL MPI_SEND(sysA(tsA)%sys(ic)%lon(:),DOMSIZE, & - MPI_REAL,0,(tag2+3),MPI_COMM_WORLD,REQ(1),IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+3) - CALL MPI_RECV(sysA(tsA)%sys(ic)%lon(:),DOMSIZE, & - MPI_REAL,irank,(tag2+3), & - MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) - END IF -! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+4) - CALL MPI_SEND(sysA(tsA)%sys(ic)%lat(:),DOMSIZE, & - MPI_REAL,0,(tag2+4),MPI_COMM_WORLD,REQ(1),IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+4) - CALL MPI_RECV(sysA(tsA)%sys(ic)%lat(:),DOMSIZE, & - MPI_REAL,irank,(tag2+4), & - MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) - END IF -! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+5) - CALL MPI_SEND(sysA(tsA)%sys(ic)%hs(:),DOMSIZE, & - MPI_REAL,0,(tag2+5),MPI_COMM_WORLD,REQ(1),IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+5) - CALL MPI_RECV(sysA(tsA)%sys(ic)%hs(:),DOMSIZE, & - MPI_REAL,irank,(tag2+5), & - MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) - END IF -! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+6) - CALL MPI_SEND(sysA(tsA)%sys(ic)%tp(:),DOMSIZE, & - MPI_REAL,0,(tag2+6),MPI_COMM_WORLD,REQ(1),IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+6) - CALL MPI_RECV(sysA(tsA)%sys(ic)%tp(:),DOMSIZE, & - MPI_REAL,irank,(tag2+6), & - MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) - END IF -! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+7) - CALL MPI_SEND(sysA(tsA)%sys(ic)%dir(:),DOMSIZE, & - MPI_REAL,0,(tag2+7),MPI_COMM_WORLD,REQ(1),IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+7) - CALL MPI_RECV(sysA(tsA)%sys(ic)%dir(:),DOMSIZE, & - MPI_REAL,irank,(tag2+7), & - MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) - END IF -! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+8) - CALL MPI_SEND(sysA(tsA)%sys(ic)%dspr(:),DOMSIZE, & - MPI_REAL,0,(tag2+8),MPI_COMM_WORLD,REQ(1),IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+8) - CALL MPI_RECV(sysA(tsA)%sys(ic)%dspr(:),DOMSIZE, & - MPI_REAL,irank,(tag2+8), & - MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) - END IF -! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -! rank,irank,(tag2+9) - CALL MPI_SEND(sysA(tsA)%sys(ic)%hsMean,1,MPI_REAL, & - 0,(tag2+9),MPI_COMM_WORLD,IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -! rank,irank,(tag2+9) - CALL MPI_RECV(sysA(tsA)%sys(ic)%hsMean,1,MPI_REAL, & - irank,(tag2+9),MPI_COMM_WORLD,MPI_STATUS,IERR) - END IF - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -! rank,irank,(tag2+10) - CALL MPI_SEND(sysA(tsA)%sys(ic)%tpMean,1,MPI_REAL, & - 0,(tag2+10),MPI_COMM_WORLD,IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -! rank,irank,(tag2+10) - CALL MPI_RECV(sysA(tsA)%sys(ic)%tpMean,1,MPI_REAL, & - irank,(tag2+10),MPI_COMM_WORLD,MPI_STATUS,IERR) - END IF - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -! rank,irank,(tag2+11) - CALL MPI_SEND(sysA(tsA)%sys(ic)%dirMean,1,MPI_REAL, & - 0,(tag2+11),MPI_COMM_WORLD,IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -! rank,irank,(tag2+11) - CALL MPI_RECV(sysA(tsA)%sys(ic)%dirMean,1,MPI_REAL, & - irank,(tag2+11),MPI_COMM_WORLD,MPI_STATUS,IERR) - END IF - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -! rank,irank,(tag2+12) - CALL MPI_SEND(sysA(tsA)%sys(ic)%sysInd,1,MPI_INTEGER,& - 0,(tag2+12),MPI_COMM_WORLD,IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -! rank,irank,(tag2+12) - CALL MPI_RECV(sysA(tsA)%sys(ic)%sysInd,1,MPI_INTEGER,& - irank,(tag2+12),MPI_COMM_WORLD,MPI_STATUS,IERR) - END IF - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -! rank,irank,(tag2+13) - CALL MPI_SEND(sysA(tsA)%sys(ic)%nPoints,1,MPI_INTEGER,& - 0,(tag2+13),MPI_COMM_WORLD,IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -! rank,irank,(tag2+13) - CALL MPI_RECV(sysA(tsA)%sys(ic)%nPoints,1,MPI_INTEGER,& - irank,(tag2+13),MPI_COMM_WORLD,MPI_STATUS,IERR) - END IF - - IF (rank.EQ.irank) THEN -! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -! rank,irank,(tag2+14) - CALL MPI_SEND(sysA(tsA)%sys(ic)%grp,1,MPI_INTEGER,& - 0,(tag2+14),MPI_COMM_WORLD,IERR) - END IF - IF (rank.EQ.0) THEN -! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -! rank,irank,(tag2+14) - CALL MPI_RECV(sysA(tsA)%sys(ic)%grp,1,MPI_INTEGER,& - irank,(tag2+14),MPI_COMM_WORLD,MPI_STATUS,IERR) - END IF - END DO + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,irank,tag2=', & + ! rank,irank,(tag2+2) + CALL MPI_SEND(sysA(tsA)%sys(ic)%j(:),DOMSIZE, & + MPI_INTEGER,0,(tag2+2),MPI_COMM_WORLD,REQ(1),IERR) END IF - END IF - END DO + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & + ! rank,irank,(tag2+2) + CALL MPI_RECV(sysA(tsA)%sys(ic)%j(:),DOMSIZE, & + MPI_INTEGER,irank,(tag2+2), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF + ! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) - CALL MPI_Barrier(MPI_COMM_WORLD,IERR) + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+3) + CALL MPI_SEND(sysA(tsA)%sys(ic)%lon(:),DOMSIZE, & + MPI_REAL,0,(tag2+3),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+3) + CALL MPI_RECV(sysA(tsA)%sys(ic)%lon(:),DOMSIZE, & + MPI_REAL,irank,(tag2+3), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF + ! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -! CALL MPI_TYPE_FREE(MPI_INT_DOMARR,IERR) -! CALL MPI_TYPE_FREE(MPI_REAL_DOMARR,IERR) + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+4) + CALL MPI_SEND(sysA(tsA)%sys(ic)%lat(:),DOMSIZE, & + MPI_REAL,0,(tag2+4),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+4) + CALL MPI_RECV(sysA(tsA)%sys(ic)%lat(:),DOMSIZE, & + MPI_REAL,irank,(tag2+4), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF + ! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -#endif + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+5) + CALL MPI_SEND(sysA(tsA)%sys(ic)%hs(:),DOMSIZE, & + MPI_REAL,0,(tag2+5),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+5) + CALL MPI_RECV(sysA(tsA)%sys(ic)%hs(:),DOMSIZE, & + MPI_REAL,irank,(tag2+5), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF + ! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -#ifdef W3_MPI - IF (rank.EQ.0) THEN -#endif - WRITE(6,*) 'Performing temporal tracking...' - WRITE(20,*) 'Calling timeTrackingV2...' - lonext = wsdat(1)%lon(maxI,1)-wsdat(1)%lon(1,1) - latext = wsdat(1)%lat(1,maxJ)-wsdat(1)%lat(1,1) + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+6) + CALL MPI_SEND(sysA(tsA)%sys(ic)%tp(:),DOMSIZE, & + MPI_REAL,0,(tag2+6),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+6) + CALL MPI_RECV(sysA(tsA)%sys(ic)%tp(:),DOMSIZE, & + MPI_REAL,irank,(tag2+6), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF + ! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) - CALL timeTrackingV2 (sysA, maxSys, tpTimeKnob, dirTimeKnob, 1, & - maxGroup, dt, lonext, latext, maxI, maxJ) -! -#ifdef W3_MPI - END IF -#endif -! - RETURN -! - 802 CONTINUE - WRITE (6,990) IOERR - STOP 1 - - 990 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRKMD : '/ & - ' ERROR IN READING FROM PARTITION FILE'/ & - ' IOSTAT =',I5/) - 1000 FORMAT (F9.0,F7.0,F8.3,F8.3,14X,I3,7X,F5.1,F6.1,F5.1,F6.1) - 1010 FORMAT (3X,F8.2,F8.2,8X,F9.2,F9.2) - 1200 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRKMD : '/ & - ' ERROR IN READING PARTITION FILE '/ & - ' INCOMPATIBLE ENDIANESS'/ ) - 1300 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRKMD : '/ & - ' ERROR IN READING PARTITION FILE '/ & - ' EXPECTED IDSTR "WAVEWATCH III PARTITIONED DATA FILE"'/ ) - 1400 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRKMD : '/ & - ' ERROR IN FINDING DOMAIN TO PROCESS - '/ & - ' SPECIFIED LAT/LON LIMITS WITHIN DOMAIN '/ & - ' OF RAW PARTITION FILE?'/ ) - 2001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' ERROR IN OPENING INPUT FILE'/ ) - 2002 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' PREMATURE END OF INPUT FILE'/ ) - 2003 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' PREMATURE END OF PARTITION FILE - '/ & - ' TSTART=',F13.4/ ) -! -! - END SUBROUTINE waveTracking_NWS_V2 -!/ End of waveTracking_NWS_V2 ---------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE spiralTrackV3 (wsdat ,dirKnob ,perKnob ,wetPts , & - hsKnob ,seedLat ,seedLon , & - maxSys ,sys ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Performs the spatial spiral tracking for a given time step -! -! 2. Method -! -! Index convention on grid: -! -! j -! ^ -! |+(1,maxJ) +(maxI,maxJ) -! | -! | -! | -! | -! | -! | -! |(1,1) +(maxI,1) -! +----------------------> i -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! dirKnob Real input Parameter in direction for combining fields in space -! perKnob Real input Parameter in period for combining fields in space -! wetPts Real input Percentage of wet points for purging fields (fraction) -! hsKnob Real input Parameter in wave height for purging fields -! seedLat Real input Start Lat for tracking spiral (if =0 centre of field is used) -! seedLon Real input Start Lon for tracking spiral (if =0 centre of field is used) -! wsdat Real arr output Input 2d (gridded) data structure to be spiral tracked -! maxSys Int output Maximum number of partition systems -! sys Type(system) output Final set of tracked systems, for one time level -! - TYPE(dat2d) :: wsdat - REAL :: dirKnob,perKnob,wetPts,hsKnob,seedLat,seedLon - INTEGER :: maxSys - TYPE(system), POINTER :: sys(:) - - INTENT (IN) wetPts,dirKnob,perKnob,hsKnob,seedLat,seedLon - INTENT (IN OUT) wsdat -! INTENT (OUT) maxSys,sys -! -! Local variables -! ---------------------------------------------------------------- -! ngbrExt Int How far do we want the neighbour to be considered -! combine Int Toggle (1=combine wave systems; 0=do not combine) -! maxI,MaxJ Int Dimensions of the 2d (gridded) data wsdat -! deltaLat Real Delta in kilometers between 2 pts (in latitude) -! - LOGICAL :: first - CHARACTER :: way *1 - INTEGER :: ngbrExt, combine, maxI, maxJ, i, j, oldJ - INTEGER :: horizStepCount, vertStepCount, checkCount, sc, & - maxPts, landPts, horizBorder, vertBorder, m, k, & - stepCount - REAL :: deltaLat, minLat, maxLat, minLon, maxLon -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! findWay -! findNext -! findSys -! combineWaveSystems -! -! 5. Subroutines calling -! -! waveTracking_NWS_V2 -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+7) + CALL MPI_SEND(sysA(tsA)%sys(ic)%dir(:),DOMSIZE, & + MPI_REAL,0,(tag2+7),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+7) + CALL MPI_RECV(sysA(tsA)%sys(ic)%dir(:),DOMSIZE, & + MPI_REAL,irank,(tag2+7), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF + ! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -! Routine starts by identifying the starting point. Choose the 'center' of the domain -! Set the search distance for neighbors: -! 1: 1 row and column out, i.e. the 8 neighbors around the current point -! 2: 2 rows and columns out... etc. - ngbrExt=1 - combine=1 - WRITE(20,*) 'In spiralTrackV3: combine = ',combine - - maxI = wsdat%maxi - maxJ = wsdat%maxj - IF ( (seedLat.EQ.0).OR.(seedLon.EQ.0) ) THEN - i=NINT(REAL(maxI)/2.) - j=NINT(REAL(maxJ)/2.) - WRITE(20,*) 'In spiralTrackV3, i=NINT(maxI/2.) =',i - WRITE(20,*) 'In spiralTrackV3, j=NINT(maxJ/2.) =',j - ELSE - i=1 - j=1 - DO WHILE ( (wsdat%lat(1,j).LT.seedLat).AND.(j.LT.wsdat%maxj) ) !40.PAR !Improve with SWAN's indice identification - j=j+1 - END DO - DO WHILE ( (wsdat%lon(i,1).LT.seedLon).AND.(i.LT.wsdat%maxi) ) - i=i+1 - END DO - END IF -! In case center point is land point... - IF (wsdat%par(i,j)%checked.EQ.-1) THEN - oldJ=j - DO WHILE (wsdat%par(i,j)%checked.EQ.-1) - j=j+1 - IF (j.EQ.maxJ) THEN - j=oldJ - i=i+1 - oldJ=oldJ+1 - END IF - END DO - END IF -! Compute distance in km between 2 grid points (at equator) - deltaLat=(wsdat%lat(i,j)-wsdat%lat(i,j-1))*111.18 + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+8) + CALL MPI_SEND(sysA(tsA)%sys(ic)%dspr(:),DOMSIZE, & + MPI_REAL,0,(tag2+8),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+8) + CALL MPI_RECV(sysA(tsA)%sys(ic)%dspr(:),DOMSIZE, & + MPI_REAL,irank,(tag2+8), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF + ! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -! Starts the spiral -! Intitiate variables - horizStepCount=0 - vertStepCount=0 - way='R' - first=.TRUE. - checkCount=1 - maxSys=0 - landPts=0 - - minLat=MINVAL(wsdat%lat) - maxLat=MAXVAL(wsdat%lat) - minLon=MINVAL(wsdat%lon) - maxLon=MAXVAL(wsdat%lon) - - horizBorder=0 - vertBorder=0 - DO WHILE (checkCount.LE.(maxI*maxJ-3) ) -! From the direction (way) we were going before, find which direction we -! are going now and how many 'step' we need to take - CALL findWay(way, horizStepCount, vertStepCount, & - vertBorder, horizBorder, stepCount) - IF (first) THEN - m=0 - DO k=1,LENGTH(wsdat%par(i,j)%hs, & - SIZE(wsdat%par(i,j)%hs),9999.) - IF ( (wsdat%par(i,j)%hs(k).EQ.0.).AND. & - (wsdat%par(i,j)%tp(k).EQ.0.) ) THEN - wsdat%par(i,j)%sys(k)=-1 - ELSE - m=m+1 - wsdat%par(i,j)%sys(k)=m - END IF - END DO - - wsdat%par(i,j)%checked=1 - checkCount=checkCount+1 - first=.FALSE. - END IF - DO sc = 1, stepCount - CALL findNext (i,j,maxI,maxJ,way,vertBorder,horizBorder) - IF ( wsdat%par(i,j)%checked.EQ.-1 ) THEN -! Land point is one of our grid points, so we need to update counter - checkCount=checkCount+1 - landPts=landPts+1 -! So that we don't count the land points twice.... - wsdat%par(i,j)%checked=-2 - ELSE IF ( wsdat%par(i,j)%checked.EQ.0 ) THEN -! Hasn't been checked yet and is not land point - checkCount=checkCount+1 - CALL findSys(i, j, wsdat, maxSys, ngbrExt, maxI, maxJ, & - perKnob, dirKnob, hsKnob) - END IF - END DO - END DO -! wetPts% of wet points - maxPts=NINT(wetPts*(maxI*maxJ-1)) -! - WRITE(20,*) 'Call combineWaveSystems...' - CALL combineWaveSystems(wsdat,maxSys,maxPts,maxI,maxJ, & - perKnob,dirKnob,hsKnob,combine,sys) - - RETURN - END SUBROUTINE spiralTrackV3 -!/ End of spiralTrackV3 ---------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE timeTrackingV2 (sysA ,maxSys ,tpTimeKnob , & - dirTimeKnob,ts0 ,maxGroup , & - dt ,lonext ,latext , & - maxI ,maxJ ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Performs the time tracking of the systems identified within -! the subroutine spiralTrackV3. -! -! 2. Method -! -! - -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Note: perKnob, dirKnob in Matlab version replaced by tpTimeKnob, dirTimeKnob! -! -! sysA TYPE(timsys) in/out Final set of spatially and temporally tracked systems -! dirTimeKnob Real input Parameter in direction for combining fields in time -! tpTimeKnob Real input Parameter in period for combining fields in time -! ts0 Int input Time step to which default grp values are associated -! maxSys Int arr input Total number of systems per time level -! maxGroup Int output Maximum number of wave systems ("groups") tracked in time -! lonext Real input Longitudinal extent of domain -! latext Real input Latitudinal extent of domain -! maxI, maxJ Int input Maximum indices of wave field -! - TYPE(timsys), POINTER :: sysA(:) - INTEGER, POINTER :: maxSys(:) - REAL :: dirTimeKnob, tpTimeKnob - INTEGER :: ts0, maxGroup - REAL :: dt - REAL :: lonext, latext - INTEGER :: maxI, maxJ - - INTENT (IN) tpTimeKnob, dirTimeKnob, ts0, maxI, maxJ -! INTENT (IN OUT) sysA - INTENT (OUT) maxGroup -! -! Local variables -! ---------------------------------------------------------------- -! ic Int Counter for wave systems -! ts1 Int Adjusted initial time step in case ts0 has only empty systems -! - LOGICAL :: file_exists - CHARACTER :: dummy*23 - TYPE(sysmemory) :: sysMem(50) !!! 50 memory spaces should be enough Check!!! - INTEGER :: leng, l, i, ii, j, k, kk, idir, numSys, & - counter, new, DIFSIZE, tpMinInd, dirMinInd, used, ok - REAL :: Tb, deltaPer, deltaDir, tpMinVal, dirMinVal, & - dirForTpMin, tpForDirMin - REAL, ALLOCATABLE :: sysOrdered(:), TEMP(:), dirs(:) - REAL, POINTER :: DIFARR(:) - INTEGER, ALLOCATABLE :: indSorted(:), alreadyUsed(:), allInd(:) - INTEGER, ALLOCATABLE :: ind(:), ind2(:) - INTEGER :: ts1 - REAL, ALLOCATABLE :: GOF(:,:), GOFMinVal(:), GOFMinInd(:), & - Tbsysmem(:), deltaDirsysmem(:), & - deltaPersysmem(:),m1sysmem(:),m2sysmem(:) - REAL :: m1, m2 - REAL :: lonmean, latmean, dmndiag - INTEGER :: npnts, npnts2 - REAL, ALLOCATABLE :: mnlonlist(:), mnlatlist(:), mndist(:) - REAL, POINTER :: dummy1(:),dummy2(:),dummy3(:) - INTEGER, ALLOCATABLE :: olsize(:) - REAL :: TEMP1, TEMP2 - INTEGER :: iii, jj, ll, idup -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! SORT -! SETDIFF -! -! 5. Subroutines calling -! -! waveTracking_NWS_V2 -! -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,irank,tag2=', & + ! rank,irank,(tag2+9) + CALL MPI_SEND(sysA(tsA)%sys(ic)%hsMean,1,MPI_REAL, & + 0,(tag2+9),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & + ! rank,irank,(tag2+9) + CALL MPI_RECV(sysA(tsA)%sys(ic)%hsMean,1,MPI_REAL, & + irank,(tag2+9),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF -! Associate default grp value to time step 1 - WRITE(20,*) 'TIME TRACKING' - WRITE(20,*) 'Inside timeTrackingV2: SIZE(sysA(1)%sys) =', & - SIZE(sysA(1)%sys) - WRITE(20,*) 'Inside timeTrackingV2: maxSys(1) =',maxSys(1) - WRITE(20,*) 'ts0 = ',ts0 - - ts1 = ts0 - -! Skip initial time steps with empty systems (e.g. when starting from rest) - DO i = ts1, SIZE(sysA) - IF (SIZE(sysA(ts1)%sys).EQ.0) ts1 = ts1+1 -! No non-empty systems found - IF (ts1.GT.SIZE(sysA)) THEN - maxGroup = 0 - GOTO 2000 - END IF - END DO - WRITE(20,*) 'TS = ',ts1 - - IF (SIZE(sysA(ts1)%sys).GT.0) THEN -! Initialize system memory groups - sysA(ts1)%sys(:)%grp = 9999 - sysMem(:)%grp = 9999 - sysMem(:)%nPoints = 0 - sysMem(:)%lonMean = 9999. - sysMem(:)%latMean = 9999. - sysMem(:)%tpMean = 9999. - sysMem(:)%dirMean = 9999. - sysMem(:)%updated = -9999 - sysMem(:)%length = 0 - DO iii = 1,50 - ALLOCATE(sysMem(iii)%indx(maxI*maxJ)) - sysMem(iii)%indx = 9999 - END DO - - INQUIRE(FILE="sys_restart.ww3", EXIST=file_exists) - IF (file_exists) THEN -! Use groups from wave tracking hotfile - WRITE(20,*) '*** Using group memory hotfile' - OPEN(unit=12,file='sys_restart.ww3',status='old') - READ(12,'(A23,I10)') dummy,maxGroup - WRITE(20,*) 'Reading ',maxGroup,' systems' - DO k = 1,maxGroup - READ(12,'(A23,I10)') dummy,sysMem(k)%grp - READ(12,'(A23,I10)') dummy,sysMem(k)%nPoints - READ(12,'(A23,F10.4)') dummy,sysMem(k)%lonMean - READ(12,'(A23,F10.4)') dummy,sysMem(k)%latMean - READ(12,'(A23,F10.3)') dummy,sysMem(k)%tpMean - READ(12,'(A23,F10.3)') dummy,sysMem(k)%dirMean - READ(12,'(A23,I10)') dummy,sysMem(k)%updated - READ(12,'(A23,I10)') dummy,sysMem(k)%length - DO j = maxJ,1,-1 - READ(12,*) (sysMem(k)%indx((j-1)*maxI+i), i = 1,maxI) - END DO - !Reset update counter - sysMem(k)%updated = 0 - END DO - CLOSE(12) - ts1 = ts1-1 - ELSE -! Set up the group number array for the first time level to be tracked - ALLOCATE( sysOrdered(maxSys(ts1)) ) - ALLOCATE( indSorted(maxSys(ts1)) ) - CALL SORT (REAL(sysA(ts1)%sys(1:maxSys(ts1))%nPoints), & - maxSys(ts1),sysOrdered,indSorted,'D') - sysA(ts1)%sys(1:maxSys(ts1)) = sysA(ts1)%sys(indSorted) - IF (ALLOCATED(sysOrdered)) DEALLOCATE(sysOrdered) - IF (ALLOCATED(indSorted)) DEALLOCATE(indSorted) - -! Set the initial long-term system memory - DO i = 1, maxSys(ts1) - sysA(ts1)%sys(i)%grp = i -! Set initial values of long-term system memory - sysMem(i)%grp = i - sysMem(i)%nPoints = sysA(ts1)%sys(i)%nPoints - sysMem(i)%lonMean = & - SUM(sysA(ts1)%sys(i)%lon(1:sysMem(i)%nPoints))/& - sysMem(i)%nPoints - sysMem(i)%latMean = & - SUM(sysA(ts1)%sys(i)%lat(1:sysMem(i)%nPoints))/& - sysMem(i)%nPoints -!070512----------- Weight averages with Hm0 --------------------- - TEMP1 = 0. - TEMP2 = 0. - DO iii = 1,sysMem(i)%nPoints - TEMP1 = TEMP1 + & - (sysA(ts1)%sys(i)%hs(iii)**2)*sysA(ts1)%sys(i)%lon(iii) - TEMP2 = TEMP2 + & - (sysA(ts1)%sys(i)%hs(iii)**2)*sysA(ts1)%sys(i)%lat(iii) - END DO - sysMem(i)%lonMean = TEMP1/& - MAX(SUM(sysA(ts1)%sys(i)%hs(1:sysMem(i)%nPoints)**2),& - 0.001) - sysMem(i)%latMean = TEMP2/& - MAX(SUM(sysA(ts1)%sys(i)%hs(1:sysMem(i)%nPoints)**2),& - 0.001) -!070512----------- Weight averages with Hm0 --------------------- - sysMem(i)%tpMean = sysA(ts1)%sys(i)%tpMean - sysMem(i)%dirMean = sysA(ts1)%sys(i)%dirMean - sysMem(i)%updated = ts1 - sysMem(i)%length = 1 -!071012----------- Grid point indexing -------------------------- - DO iii = 1,sysMem(i)%nPoints - sysMem(i)%indx(iii) = (sysA(ts1)%sys(i)%j(iii)-1)*maxI +& - sysA(ts1)%sys(i)%i(iii) - END DO -!071012----------- Grid point indexing -------------------------- - END DO - maxGroup = maxSys(ts1) -! i = ts1 - END IF - -!******** Test output *********************** - DO i = 1, maxGroup - WRITE(20,*) 'sysMem(',i,')%grp =',sysMem(i)%grp - WRITE(20,*) 'sysMem(',i,')%nPoints =',sysMem(i)%nPoints - WRITE(20,*) 'sysMem(',i,')%lonMean =',sysMem(i)%lonMean - WRITE(20,*) 'sysMem(',i,')%latMean =',sysMem(i)%latMean - WRITE(20,*) 'sysMem(',i,')%tpMean =',sysMem(i)%tpMean - WRITE(20,*) 'sysMem(',i,')%dirMean =',sysMem(i)%dirMean - WRITE(20,*) 'sysMem(',i,')%updated =',sysMem(i)%updated - WRITE(20,*) 'sysMem(',i,')%length =',sysMem(i)%length - END DO -!******************************************** - END IF + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,irank,tag2=', & + ! rank,irank,(tag2+10) + CALL MPI_SEND(sysA(tsA)%sys(ic)%tpMean,1,MPI_REAL, & + 0,(tag2+10),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & + ! rank,irank,(tag2+10) + CALL MPI_RECV(sysA(tsA)%sys(ic)%tpMean,1,MPI_REAL, & + irank,(tag2+10),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF -! Loop over all time levels to track systems in time - WRITE(20,*) 'Number of time levels = ',SIZE(sysA) - DO i = (ts1+1), SIZE(sysA) - WRITE(20,*) 'TS = ',i - - IF (SIZE(sysA(i)%sys).GT.0) THEN -! *** Added: 02/29/12 ************************************* -! Sort groups, so that larger systems get associated first - ALLOCATE( sysOrdered(maxSys(i)) ) - ALLOCATE( indSorted(maxSys(i)) ) - CALL SORT (REAL(sysA(i)%sys(1:maxSys(i))%nPoints), & - maxSys(i),sysOrdered,indSorted,'D') - sysA(i)%sys(1:maxSys(i)) = sysA(i)%sys(indSorted) - IF (ALLOCATED(sysOrdered)) DEALLOCATE(sysOrdered) - IF (ALLOCATED(indSorted)) DEALLOCATE(indSorted) -! *** Added: 02/29/12 ************************************* - -! Initialize groups ! Optimize? - sysA(i)%sys(:)%grp = 9999 ! Optimize? - counter = 0 - leng = LENGTH(REAL(sysMem(:)%grp), & - SIZE(sysMem(:)%grp),REAL(9999)) - ALLOCATE( alreadyUsed(leng+10) ) !Make space for 10 new potential entries. Improve!!! - WRITE(20,*) 'sysMem(1:leng)%grp =', & - sysMem(1:leng)%grp - ALLOCATE( allInd(leng) ) - alreadyUsed(:) = 0 - allInd(:) = sysMem(1:leng)%grp - -!071212-----GoF 2D------------------------------- - ALLOCATE( ind(SIZE(allInd)) ) - ind(:) = allInd - ALLOCATE( ind2(SIZE(ind)) ) - DO ii = 1, SIZE(ind) - ind2(ii) = FINDFIRST(REAL(allInd),SIZE(allInd), & - REAL(ind(ii))) - END DO -! Define 2D array for evaluating best fit for systems - ALLOCATE( GOF(maxSys(i),maxGroup) ) - ALLOCATE( GOFMinVal(maxGroup) ) - ALLOCATE( GOFMinInd(maxGroup) ) - ALLOCATE( Tbsysmem(maxGroup) ) - ALLOCATE( deltaDirsysmem(maxGroup) ) - ALLOCATE( deltaPersysmem(maxGroup) ) - ALLOCATE( m1sysmem(maxGroup) ) - ALLOCATE( m2sysmem(maxGroup) ) -!071212-----GoF 2D------------------------------- - DO j = 1, maxSys(i) - npnts = sysA(i)%sys(j)%nPoints - lonmean = SUM(sysA(i)%sys(j)%lon(1:npnts))/npnts - latmean = SUM(sysA(i)%sys(j)%lat(1:npnts))/npnts -!070512----------- Weight averages with Hm0 --------------------- - TEMP1 = 0. - TEMP2 = 0. - DO iii = 1,npnts - TEMP1 = TEMP1 + & - (sysA(i)%sys(j)%hs(iii)**2)*sysA(i)%sys(j)%lon(iii) - TEMP2 = TEMP2 + & - (sysA(i)%sys(j)%hs(iii)**2)*sysA(i)%sys(j)%lat(iii) - END DO - lonmean=TEMP1/MAX(SUM(sysA(i)%sys(j)%hs(1:npnts)**2),0.001) - latmean=TEMP2/MAX(SUM(sysA(i)%sys(j)%hs(1:npnts)**2),0.001) -!070512----------- Weight averages with Hm0 --------------------- -!071012----------- Grid point indexing -------------------------- - ALLOCATE(sysA(i)%sys(j)%indx(maxI*maxJ)) - sysA(i)%sys(j)%indx = 9999 - DO iii = 1,sysA(i)%sys(j)%nPoints - sysA(i)%sys(j)%indx(iii) = & - (sysA(i)%sys(j)%j(iii)-1)*maxI + & - sysA(i)%sys(j)%i(iii) - END DO -!071012----------- Grid point indexing -------------------------- - WRITE(20,*) 'System no. ',j,' of ',maxSys(i) - WRITE(20,*) 'Size =', npnts - WRITE(20,*) 'lonMean =', lonmean - WRITE(20,*) 'latMean =', latmean - WRITE(20,*) 'tpMean =', sysA(i)%sys(j)%tpMean - WRITE(20,*) 'dirMean =', sysA(i)%sys(j)%dirMean - sysA(i)%sys(j)%grp = 9999 !Now redundant? - -! Compute deltas - Tbsysmem = sysMem(1:maxGroup)%tpMean - WRITE(20,*) 'Tbsysmem(:) = ', Tbsysmem(:) -! Compute deltas the same way as for field combining - they should -! be of the same degree of strictness as the latter, otherwise -! the time combining will lose track! -!3stddev m1 = -3.645*Tb + 63.211 -!3stddev m1 = MAX(m1,10.) -!3stddev m2 = -0.346*Tb + 3.686 -!3stddev m2 = MAX(m2,0.6) -!1stddev m1 = -2.219*Tb + 35.734 -!1stddev m1 = MAX(m1,5.) -!1stddev m2 = -0.226*Tb + 2.213 -!1stddev m2 = MAX(m2,0.35) -!071412 m1 = -5.071*Tb + 90.688 -!071412 m1 = MAX(m1,16.) -!071412 m2 = -0.467*Tb + 5.161 -!071412 m2 = MAX(m2,1.0) -!071412 deltaDir = (m1*1. + dirTimeKnob)*1. -!071412 deltaPer = (m2*1. + tpTimeKnob)*1. - DO ii = 1,SIZE(ind2) - m1sysmem(ii) = MAX((-3.645*Tbsysmem(ii)+63.211),10.) - m2sysmem(ii) = MAX((-0.346*Tbsysmem(ii)+3.686),0.6) - END DO - deltaDirsysmem = m1sysmem(:)*1. + dirTimeKnob - deltaPersysmem = m2sysmem(:)*1. + tpTimeKnob - WRITE(20,*) 'deltaDirsysmem(:) = ',deltaDirsysmem - WRITE(20,*) 'deltaPersysmem(:) = ',deltaPersysmem - -! Criterion 1: Mean period - ALLOCATE( TEMP(SIZE(ind2)) ) - TEMP = ABS( sysA(i)%sys(j)%tpMean - & - sysMem(ind2(:))%tpMean ) - WRITE(20,*) 'tpMean list =', & - sysMem(ind2(:))%tpMean - WRITE(20,*) 'tpMinVal list =', TEMP - tpMinVal = MINVAL(TEMP) - tpMinInd = FINDFIRST(TEMP,SIZE(TEMP),tpMinVal) - -! Criterion 2: Mean direction - ALLOCATE( dirs(SIZE(ind2)) ) - dirs(:)=ABS( sysA(i)%sys(j)%dirMean - & - sysMem(ind2(:))%dirMean ) -! Deal with wrap around - DO idir = 1, SIZE(dirs) - IF (dirs(idir).GE.180.) dirs(idir)=360-dirs(idir) - END DO - WRITE(20,*) 'dirMean list =', & - sysMem(ind2(:))%dirMean - WRITE(20,*) 'dirMinVal list =', dirs - -! Criterion 3: Size - WRITE(20,*) 'Size list =', & - sysMem(ind2(:))%nPoints - -! Criterion 4: Distance between systems - ALLOCATE (mnlonlist(SIZE(ind2))) - ALLOCATE (mnlatlist(SIZE(ind2))) - ALLOCATE (mndist(SIZE(ind2))) - DO ii = 1,SIZE(ind2) - mnlonlist(ii) = sysMem(ind2(ii))%lonMean - mnlatlist(ii) = sysMem(ind2(ii))%latMean - mndist(ii) = SQRT((lonmean-mnlonlist(ii))**2 + & - (latmean-mnlatlist(ii))**2) - END DO - dmndiag = SQRT(lonext**2+latext**2) - WRITE(20,*) 'Distance list =',mndist(:) - WRITE(20,*) 'Domain diagonal =',dmndiag - -! Criterion 5: Overlap of systems - ALLOCATE (olsize(SIZE(ind2))) - DO ii = 1,SIZE(ind2) - - IF (sysMem(ind2(ii))%nPoints.GT.0) THEN - CALL INTERSECT(REAL(sysA(i)%sys(j)%indx(1:npnts)),npnts, & - REAL(sysMem(ind2(ii))%indx(1:sysMem(ind2(ii))%nPoints)),& - sysMem(ind2(ii))%nPoints,dummy1,olsize(ii),dummy2,dummy3) - ELSE - olsize(ii) = 0 - END IF - END DO + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,irank,tag2=', & + ! rank,irank,(tag2+11) + CALL MPI_SEND(sysA(tsA)%sys(ic)%dirMean,1,MPI_REAL, & + 0,(tag2+11),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & + ! rank,irank,(tag2+11) + CALL MPI_RECV(sysA(tsA)%sys(ic)%dirMean,1,MPI_REAL, & + irank,(tag2+11),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF - GOF(j,1:SIZE(ind2)) = (TEMP/deltaPersysmem(:))**2 + & - (dirs/deltaDirsysmem(:))**2 + & -! (4*mndist(:)/dmndiag)**2 - ( (REAL(olsize(:)) - & - REAL(sysMem(ind2(:))%nPoints) )/& - (0.50*MAX(REAL(sysMem(ind2(:))%nPoints),0.001)) )**2 -! Remove GoF entries which exceed predifined tolerances - DO ii = 1,SIZE(ind2) - WRITE(20,*) 'Testing: ii,olsize(ii),size,frac =',& - ii,olsize(ii),sysMem(ind2(ii))%nPoints,& - REAL(olsize(ii))/& - MAX(REAL(sysMem(ind2(ii))%nPoints),0.001) - IF ( REAL(olsize(ii)).LT.& - 0.50*REAL(sysMem(ind2(ii))%nPoints) ) THEN - GOF(j,ii) = 9999. - END IF - IF ( (TEMP(ii).GT.deltaPersysmem(ii)).OR.& - (dirs(ii).GT.deltaDirsysmem(ii)) ) THEN - GOF(j,ii) = 9999. - END IF - END DO - WRITE(20,*) 'GOF(j,:) =',GOF(j,:) - - IF (ALLOCATED(TEMP)) DEALLOCATE(TEMP) - IF (ALLOCATED(dirs)) DEALLOCATE(dirs) - IF (ALLOCATED(mnlonlist)) DEALLOCATE(mnlonlist) - IF (ALLOCATED(mnlatlist)) DEALLOCATE(mnlatlist) - IF (ALLOCATED(mndist)) DEALLOCATE(mndist) - IF (ALLOCATED(olsize)) DEALLOCATE(olsize) - -!071212-----------GoF 2D------------- - END DO - IF (ALLOCATED(Tbsysmem)) DEALLOCATE(Tbsysmem) - IF (ALLOCATED(deltaDirsysmem)) DEALLOCATE(deltaDirsysmem) - IF (ALLOCATED(deltaPersysmem)) DEALLOCATE(deltaPersysmem) - IF (ALLOCATED(m1sysmem)) DEALLOCATE(m1sysmem) - IF (ALLOCATED(m2sysmem)) DEALLOCATE(m2sysmem) - - WRITE(20,*) 'GoF3:' - DO jj = 1,maxSys(i) - WRITE(20,*) GOF(jj,:) - END DO - -! Find minima in GoF - DO k = 1,maxGroup - GOFMinVal(k) = MINVAL(GOF(:,k)) - GOFMinInd(k) = FINDFIRST(GOF(:,k),SIZE(GOF,1),GOFMinVal(k)) - IF (GOFMinVal(k).EQ.9999) THEN - GOFMinInd(k) = 0 + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,irank,tag2=', & + ! rank,irank,(tag2+12) + CALL MPI_SEND(sysA(tsA)%sys(ic)%sysInd,1,MPI_INTEGER,& + 0,(tag2+12),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & + ! rank,irank,(tag2+12) + CALL MPI_RECV(sysA(tsA)%sys(ic)%sysInd,1,MPI_INTEGER,& + irank,(tag2+12),MPI_COMM_WORLD,MPI_STATUS,IERR) END IF - END DO - - IF (ALLOCATED(GOF)) DEALLOCATE(GOF) - - DO j = 1, maxSys(i) - new = 0 -! Look up sysMem match for this current system. If no match -! is found, the index value 0 is returned. - tpMinInd = 0 - TEMP1 = 9999. - DO jj = 1, SIZE(GOFMinInd) - IF (GOFMinInd(jj).EQ.j) THEN - IF (GOFMinVal(jj).LT.TEMP1) THEN - tpMinInd = jj - TEMP1 = GOFMinVal(jj) - END IF - END IF - END DO - dirMinInd = tpMinInd - WRITE(20,*) 'System, GOFMinInd: ',j,tpMinInd - - IF (tpMinInd.NE.0) THEN -! Success -!071212-----------GoF 2D------------- - - counter = counter+1 - sysA(i)%sys(j)%grp = & - sysMem(ind2(dirMinInd))%grp - alreadyUsed(counter) = sysA(i)%sys(j)%grp - - WRITE(20,*) 'Case 1: matched this ts (',i, & - ') sys ',sysA(i)%sys(j)%sysInd,' (tp=', & - sysA(i)%sys(j)%tpMean,' dir=', & - sysA(i)%sys(j)%dirMean,') with grp ', & - sysMem(ind2(dirMinInd))%grp - WRITE(20,*) 'Added ',alreadyUsed(counter), & - ' in array *alreadyUsed*' - ELSE - new = 1 - END IF - IF (new.EQ.1) THEN - used = 0 - DO k = 1, maxGroup - ok = 1 - WRITE(20,*) 'maxGroup,k,ok,used =', & - maxGroup,k,ok,used -! Make sure it hasn't been used yet (at current time level) - IF ((i.GT.2).AND. & - (.NOT.ANY(alreadyUsed(:).EQ.k))) THEN -! Make sure it hasn't been used yet (at previous time level) - DO l = 1, maxGroup -! If last update of system was more that *6* time steps -! ago, system can be released (TO CALIBRATE) - IF ( (sysMem(l)%grp.EQ.k).AND. & - ((i-sysMem(l)%updated).LT.6) ) ok = 0 - WRITE(20,*) 'l, ok = ',l,ok - END DO - IF (ok.EQ.1) THEN - sysA(i)%sys(j)%grp = k - counter = counter+1; - alreadyUsed(counter) = k - used = 1 - WRITE(20,*) 'k,used,counter =', & - k,used,counter - EXIT - END IF - END IF - END DO - IF (used.EQ.0) THEN - maxGroup = maxGroup+1 - sysA(i)%sys(j)%grp = maxGroup -! Increase sysMem by one slot - sysMem(maxGroup)%grp = maxGroup - counter = counter+1 - alreadyUsed(counter) = maxGroup - END IF - WRITE(20,*) 'counter,maxGroup,sysA(i)%sys(j)%grp =',& - counter,maxGroup,sysA(i)%sys(j)%grp - WRITE(20,*) 'NO GRP MATCH case 2' - END IF + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,irank,tag2=', & + ! rank,irank,(tag2+13) + CALL MPI_SEND(sysA(tsA)%sys(ic)%nPoints,1,MPI_INTEGER,& + 0,(tag2+13),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & + ! rank,irank,(tag2+13) + CALL MPI_RECV(sysA(tsA)%sys(ic)%nPoints,1,MPI_INTEGER,& + irank,(tag2+13),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF - END DO - IF (ALLOCATED(ind)) DEALLOCATE(ind) !071212 Shifted - IF (ALLOCATED(ind2)) DEALLOCATE(ind2) !071212 Shifted - IF (ALLOCATED(GOFMinVal)) DEALLOCATE(GOFMinVal) - IF (ALLOCATED(GOFMinInd)) DEALLOCATE(GOFMinInd) - - IF (ALLOCATED(alreadyUsed)) DEALLOCATE(alreadyUsed) - IF (ALLOCATED(allInd)) DEALLOCATE(allInd) - -! Update sysMem - DO k = 1, maxGroup - DO kk = 1, maxSys(i) - IF (sysA(i)%sys(kk)%grp.EQ.sysMem(k)%grp) THEN - sysMem(k)%nPoints = sysA(i)%sys(kk)%nPoints - sysMem(k)%lonMean = & - SUM(sysA(i)%sys(kk)%lon(1:sysMem(k)%nPoints))/& - sysMem(k)%nPoints - sysMem(k)%latMean = & - SUM(sysA(i)%sys(kk)%lat(1:sysMem(k)%nPoints))/& - sysMem(k)%nPoints -!070512----------- Weight averages with Hm0 --------------------- - TEMP1 = 0. - TEMP2 = 0. - DO iii = 1,sysMem(k)%nPoints - TEMP1 = TEMP1 + & - (sysA(i)%sys(kk)%hs(iii)**2)*sysA(i)%sys(kk)%lon(iii) - TEMP2 = TEMP2 + & - (sysA(i)%sys(kk)%hs(iii)**2)*sysA(i)%sys(kk)%lat(iii) - END DO - sysMem(k)%lonMean = TEMP1/& - MAX(SUM(sysA(i)%sys(kk)%hs(1:sysMem(k)%nPoints)**2),& - 0.001) - sysMem(k)%latMean = TEMP2/& - MAX(SUM(sysA(i)%sys(kk)%hs(1:sysMem(k)%nPoints)**2),& - 0.001) -!070512----------- Weight averages with Hm0 --------------------- - sysMem(k)%tpMean = sysA(i)%sys(kk)%tpMean - sysMem(k)%dirMean = sysA(i)%sys(kk)%dirMean -!071012----------- Grid point indexing -------------------------- - sysMem(k)%indx(:) = 9999 - DO iii = 1,sysMem(k)%nPoints - sysMem(k)%indx(iii) = & - (sysA(i)%sys(kk)%j(iii)-1)*maxI + & - sysA(i)%sys(kk)%i(iii) - END DO -!071012----------- Grid point indexing -------------------------- - sysMem(k)%updated = i - sysMem(k)%length = sysMem(k)%length + 1 - END IF - END DO - !Test for expired groups - IF ((i-sysMem(k)%updated).GE.6) THEN - sysMem(k)%nPoints = 0 - sysMem(k)%lonMean = 9999. - sysMem(k)%latMean = 9999. - sysMem(k)%tpMean = 9999. - sysMem(k)%dirMean = 9999. - sysMem(k)%indx(:) = 9999 - sysMem(k)%updated = -9999 - sysMem(k)%length = 0 + IF (rank.EQ.irank) THEN + ! WRITE(20,*) '>> Sending: rank,irank,tag2=', & + ! rank,irank,(tag2+14) + CALL MPI_SEND(sysA(tsA)%sys(ic)%grp,1,MPI_INTEGER,& + 0,(tag2+14),MPI_COMM_WORLD,IERR) END IF - END DO -!083012 !Filter out duplicates groups that can develop - DO l = 1, maxGroup - DO ll = (l+1), maxGroup - - deltaDir = MAX((-3.645*sysMem(l)%tpMean+63.211),10.)*1. - deltaPer = MAX((-0.346*sysMem(l)%tpMean+3.686),0.6)*1. - - IF ( (ABS(sysMem(l)%tpMean-sysMem(ll)%tpMean).LT.& - deltaPer).AND. & - (ABS(sysMem(l)%dirMean-sysMem(ll)%dirMean).LT.& - deltaDir).AND. & - (sysMem(l)%updated.NE.sysMem(ll)%updated).AND. & - (sysMem(ll)%nPoints.NE.0) ) THEN - !Find the more recent entry, and delete from group - IF (sysMem(ll)%length.LT.sysMem(l)%length) THEN - idup = ll - WRITE(20,*) 'Deleting memgroup ',ll, & - '(updated',sysMem(ll)%updated,', length', & - sysMem(ll)%length,'), duplicate of memgroup', & - l,'(updated',sysMem(l)%updated,', length', & - sysMem(l)%length,'):' - ELSE - idup = l - WRITE(20,*) 'Deleting memgroup ',l, & - '(updated',sysMem(l)%updated,', length', & - sysMem(l)%length,'), duplicate of memgroup', & - ll,'(updated',sysMem(ll)%updated,', length', & - sysMem(ll)%length,'):' - END IF - WRITE(20,*) 'deltaPer, diff Per:',deltaPer,& - ABS(sysMem(l)%tpMean-sysMem(ll)%tpMean) - WRITE(20,*) 'deltaDir, diff Dir:',deltaDir,& - ABS(sysMem(l)%dirMean-sysMem(ll)%dirMean) - sysMem(idup)%nPoints = 0 - sysMem(idup)%lonMean = 9999. - sysMem(idup)%latMean = 9999. - sysMem(idup)%tpMean = 9999. - sysMem(idup)%dirMean = 9999. - sysMem(idup)%indx(:) = 9999 - sysMem(idup)%updated = -9999 - sysMem(idup)%length = 0 - END IF - END DO - END DO - ELSE - WRITE(20,*) '*** No systems at this time level. ', & - 'No. systems =',SIZE(sysA(i)%sys) - !Test for expired groups - DO k = 1, maxGroup - IF ((i-sysMem(k)%updated).GE.6) THEN - sysMem(k)%nPoints = 0 - sysMem(k)%lonMean = 9999. - sysMem(k)%latMean = 9999. - sysMem(k)%tpMean = 9999. - sysMem(k)%dirMean = 9999. - sysMem(k)%indx(:) = 9999 - sysMem(k)%updated = -9999 - sysMem(k)%length = 0 - END IF - END DO - END IF -! ******** Test output *********************** - DO k = 1, maxGroup - WRITE(20,*) 'sysMem(',k,')%grp =',sysMem(k)%grp - WRITE(20,*) 'sysMem(',k,')%nPoints =',sysMem(k)%nPoints - WRITE(20,*) 'sysMem(',k,')%lonMean =',sysMem(k)%lonMean - WRITE(20,*) 'sysMem(',k,')%latMean =',sysMem(k)%latMean - WRITE(20,*) 'sysMem(',k,')%tpMean =',sysMem(k)%tpMean - WRITE(20,*) 'sysMem(',k,')%dirMean =',sysMem(k)%dirMean - WRITE(20,*) 'sysMem(',k,')%updated =',sysMem(k)%updated - WRITE(20,*) 'sysMem(',k,')%length =',sysMem(k)%length - END DO -! ******************************************** - END DO + IF (rank.EQ.0) THEN + ! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & + ! rank,irank,(tag2+14) + CALL MPI_RECV(sysA(tsA)%sys(ic)%grp,1,MPI_INTEGER,& + irank,(tag2+14),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF + END DO + END IF + END IF + END DO -! Write hotfile of wave groups - OPEN(unit=27,file='sys_restart1.ww3',status='unknown') - WRITE(27,'(A23,I10)') 'maxGroup =',maxGroup - DO k = 1, maxGroup - WRITE(27,'(A8,I3,A12,I10)') 'sysMem( ',k, & - ' )%grp =',sysMem(k)%grp - WRITE(27,'(A8,I3,A12,I10)') 'sysMem( ',k, & - ' )%nPoints =',sysMem(k)%nPoints - WRITE(27,'(A8,I3,A12,F10.4)') 'sysMem( ',k, & - ' )%lonMean =',sysMem(k)%lonMean - WRITE(27,'(A8,I3,A12,F10.4)') 'sysMem( ',k, & - ' )%latMean =',sysMem(k)%latMean - WRITE(27,'(A8,I3,A12,F10.3)') 'sysMem( ',k, & - ' )%tpMean =',sysMem(k)%tpMean - WRITE(27,'(A8,I3,A12,F10.3)') 'sysMem( ',k, & - ' )%dirMean =',sysMem(k)%dirMean - WRITE(27,'(A8,I3,A12,I10)') 'sysMem( ',k, & - ' )%updated =',sysMem(k)%updated - WRITE(27,'(A8,I3,A12,I10)') 'sysMem( ',k, & - ' )%length =',sysMem(k)%length - DO j = maxJ,1,-1 - DO i = 1,maxI - WRITE(27,'(I8)',ADVANCE='NO') sysMem(k)%indx((j-1)*maxI+i) - END DO - WRITE(27,'(A)',ADVANCE='YES') '' - END DO - END DO - CLOSE(27) + CALL MPI_Barrier(MPI_COMM_WORLD,IERR) - 2000 CONTINUE - RETURN - END SUBROUTINE timeTrackingV2 -!/ End of timeTrackingV2 --------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE findWay (way ,horizStepCount,vertStepCount , & - vertBorder ,horizBorder ,stepCount ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! From the direction (way) we were going before, find which direction we -! are going now and how many 'steps' we need to take -! -! 2. Method -! -! - -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! way Char in/out Direction of spiral search -! vertBorder Int input -! horizBorder Int input -! stepCount Int output Number of steps to go in the selected direction (way) -! - CHARACTER :: way *1 - INTEGER :: horizStepCount, vertStepCount, & - vertBorder, horizBorder, stepCount - - INTENT (IN) vertBorder, horizBorder - INTENT (OUT) stepCount - INTENT (IN OUT) way -! -! Local variables -! ---------------------------------------------------------------- -! - -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! - -! -! 5. Subroutines calling -! -! spiralTrackV3 -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See above -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - SELECT CASE (way) - CASE ('R') - way='D' - vertStepCount=vertStepCount+1 - IF (horizBorder.EQ.1) THEN - horizStepCount=horizStepCount-1 - END IF - stepCount=vertStepCount - CASE ('D') - way='L' - horizStepCount=horizStepCount+1 - IF (vertBorder.EQ.1) THEN - vertStepCount=vertStepCount-1 - END IF - stepCount=horizStepCount - CASE ('L') - way='U' - vertStepCount=vertStepCount+1 - IF (horizBorder.EQ.1) THEN - horizStepCount=horizStepCount-1 - END IF - stepCount=vertStepCount - CASE ('U') - way='R' - horizStepCount=horizStepCount+1 - IF (vertBorder.EQ.1) THEN - vertStepCount=vertStepCount-1 - END IF - stepCount=horizStepCount - CASE DEFAULT - WRITE(20,*) 'In spaTack:findWay should NOT go here!' - END SELECT - - RETURN - END SUBROUTINE findWay -!/ End of findWay ---------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE findNext (i ,j ,maxI ,maxJ , & - way ,vertBorder ,horizBorder ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Find next point on spatial search spiral -! -! 2. Method -! -! - -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! i,j Int in/out Current grid indices -! maxI, maxJ Int input Maximum indices of wave field -! way Char input Direction of spiral search -! vertBorder Int output Flag indicating that vert domain edge has been hit -! horizBorder Int output Flag indicating that hor domain edge has been hit -! - CHARACTER :: way - INTEGER :: i, j, maxI, maxJ, vertBorder, horizBorder - - INTENT (IN) maxI, maxJ, way - INTENT (IN OUT) i, j - INTENT (OUT) vertBorder, horizBorder -! -! Local variables -! ---------------------------------------------------------------- -! - -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! - -! -! 5. Subroutines calling -! -! spiralTrackV3 -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - vertBorder=0 - horizBorder=0 - SELECT CASE (way) - CASE ('R') - IF (i.LT.maxI) THEN - i=i+1 - ELSE -! Need to tell findWay that if we hit the border we don't -! increment stepCount... - horizBorder=1 - END IF - CASE ('D') - IF (j.GT.1) THEN - j=j-1 - ELSE - vertBorder=1 - END IF - CASE ('L') - IF (i.GT.1) THEN - i=i-1 - ELSE - horizBorder=1 - END IF - CASE ('U') - IF (j.LT.maxJ) THEN - j=j+1 - ELSE - vertBorder=1 - END IF - END SELECT + ! CALL MPI_TYPE_FREE(MPI_INT_DOMARR,IERR) + ! CALL MPI_TYPE_FREE(MPI_REAL_DOMARR,IERR) - RETURN - END SUBROUTINE findNext -!/ End of findNext --------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE findSys (i ,j ,wsdat ,maxSys , & - ngbrExt ,maxI ,maxJ ,perKnob , & - dirKnob ,hsKnob ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Find all wave systems that neighbour the grid point (i,j), and -! match these with the systems at (i,j). -! -! 2. Method -! -! For the given point (i,j), find all wave systems at neighbouring grid -! points within the reach specified by ngbrExt. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! i,j Int input Current grid indices -! maxI, maxJ Int input Maximum indices of wave field -! wsdat Type(dat2d) in/out Input data structure to be spiral tracked -! maxSys Int in/out Maximum number of systems identified -! - TYPE(dat2d) :: wsdat - INTEGER :: i, j, maxI, maxJ, ngbrExt, maxSys - REAL :: perKnob ,dirKnob, hsKnob - - INTENT (IN) i, j, maxI, maxJ, ngbrExt, perKnob ,dirKnob - INTENT (IN OUT) wsdat, maxSys -! -! Local variables -! ---------------------------------------------------------------- -! tmpsys TYPE(system) Temporary instance of the wave system variable -! nngbr Int Number of neighbours found -! - TYPE(system), ALLOCATABLE :: tmpsys(:) - TYPE(neighbr) :: ngbr(50) - TYPE(mtchsys) :: match - LOGICAL :: found - INTEGER :: counter, ii, jj, nngbr, startCount, endCount, l,& - nout, maxS, s, p, n, countAll, ind, minInd, & - npart, pp, leng - INTEGER :: allFullSys(50) - REAL, POINTER :: realarr(:) - INTEGER, ALLOCATABLE :: allSys(:) - REAL :: hsAll(50),tpAll(50),dirAll(50),GOF(50) - REAL :: absDir,absPer,absHs,T,& - deltaPer,deltaDir,deltaHs,temp - REAL :: dx, m1, m2 - REAL :: GOFMinVal - INTEGER :: GOFMinInd -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! UNIQUE -! combinePartitionsV2 -! -! 5. Subroutines calling -! -! spiralTrackV3 -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - NULLIFY(realarr) -! WRITE(20,*) 'findSys: i,j,maxSys =',i,j,maxSys - -! First find the checked neighbor - counter=1 - DO ii=(i-ngbrExt), (i+ngbrExt) - DO jj=(j-ngbrExt), (j+ngbrExt) - IF ( (ii.GT.0).AND.(jj.GT.0).AND. & - (jj.LE.maxJ).AND.(ii.LE.maxI) ) THEN - IF ( wsdat%par(ii,jj)%checked.EQ.1 ) THEN - ngbr(counter)%par = wsdat%par(ii,jj) !Added the par field to maintain the data structure - ngbr(counter)%i = ii - ngbr(counter)%j = jj - counter=counter+1 - END IF - END IF - END DO - END DO -! New variable nngbr - nngbr=counter-1 - - IF (nngbr.GT.0) THEN - allFullSys(:) = 0 - startCount=1 - l=1 - DO WHILE (l.LE.nngbr) - leng = LENGTH(REAL(ngbr(l)%par%sys), & - SIZE(ngbr(l)%par%sys),REAL(9999)) - endCount = startCount+leng-1 - allFullSys(startCount:endCount) = ngbr(l)%par%sys(1:leng) - startCount=endCount+1 - l=l+1 - END DO +#endif - IF (endCount.EQ.0) WRITE(20,*) '***1.Calling UNIQUE w. len=0!' - CALL UNIQUE (REAL(allFullSys),endCount,realarr,nout) !Can one do this? - ALLOCATE(allSys(nout)) - allSys = INT(realarr) !Can one do this? - IF (ASSOCIATED(realarr)) DEALLOCATE(realarr) - maxS = MAXVAL(allSys) +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif + WRITE(6,*) 'Performing temporal tracking...' + WRITE(20,*) 'Calling timeTrackingV2...' + lonext = wsdat(1)%lon(maxI,1)-wsdat(1)%lon(1,1) + latext = wsdat(1)%lat(1,maxJ)-wsdat(1)%lat(1,1) - IF (maxSys.LT.maxS) THEN - maxSys=maxS + CALL timeTrackingV2 (sysA, maxSys, tpTimeKnob, dirTimeKnob, 1, & + maxGroup, dt, lonext, latext, maxI, maxJ) + ! +#ifdef W3_MPI + END IF +#endif + ! + RETURN + ! +802 CONTINUE + WRITE (6,990) IOERR + STOP 1 + +990 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRKMD : '/ & + ' ERROR IN READING FROM PARTITION FILE'/ & + ' IOSTAT =',I5/) +1000 FORMAT (F9.0,F7.0,F8.3,F8.3,14X,I3,7X,F5.1,F6.1,F5.1,F6.1) +1010 FORMAT (3X,F8.2,F8.2,8X,F9.2,F9.2) +1200 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRKMD : '/ & + ' ERROR IN READING PARTITION FILE '/ & + ' INCOMPATIBLE ENDIANESS'/ ) +1300 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRKMD : '/ & + ' ERROR IN READING PARTITION FILE '/ & + ' EXPECTED IDSTR "WAVEWATCH III PARTITIONED DATA FILE"'/ ) +1400 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRKMD : '/ & + ' ERROR IN FINDING DOMAIN TO PROCESS - '/ & + ' SPECIFIED LAT/LON LIMITS WITHIN DOMAIN '/ & + ' OF RAW PARTITION FILE?'/ ) +2001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' ERROR IN OPENING INPUT FILE'/ ) +2002 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' PREMATURE END OF INPUT FILE'/ ) +2003 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' PREMATURE END OF PARTITION FILE - '/ & + ' TSTART=',F13.4/ ) + ! + ! + END SUBROUTINE waveTracking_NWS_V2 + !/ End of waveTracking_NWS_V2 ---------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE spiralTrackV3 (wsdat ,dirKnob ,perKnob ,wetPts , & + hsKnob ,seedLat ,seedLon , & + maxSys ,sys ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Performs the spatial spiral tracking for a given time step + ! + ! 2. Method + ! + ! Index convention on grid: + ! + ! j + ! ^ + ! |+(1,maxJ) +(maxI,maxJ) + ! | + ! | + ! | + ! | + ! | + ! | + ! |(1,1) +(maxI,1) + ! +----------------------> i + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! dirKnob Real input Parameter in direction for combining fields in space + ! perKnob Real input Parameter in period for combining fields in space + ! wetPts Real input Percentage of wet points for purging fields (fraction) + ! hsKnob Real input Parameter in wave height for purging fields + ! seedLat Real input Start Lat for tracking spiral (if =0 centre of field is used) + ! seedLon Real input Start Lon for tracking spiral (if =0 centre of field is used) + ! wsdat Real arr output Input 2d (gridded) data structure to be spiral tracked + ! maxSys Int output Maximum number of partition systems + ! sys Type(system) output Final set of tracked systems, for one time level + ! + TYPE(dat2d) :: wsdat + REAL :: dirKnob,perKnob,wetPts,hsKnob,seedLat,seedLon + INTEGER :: maxSys + TYPE(system), POINTER :: sys(:) + + INTENT (IN) wetPts,dirKnob,perKnob,hsKnob,seedLat,seedLon + INTENT (IN OUT) wsdat + ! INTENT (OUT) maxSys,sys + ! + ! Local variables + ! ---------------------------------------------------------------- + ! ngbrExt Int How far do we want the neighbour to be considered + ! combine Int Toggle (1=combine wave systems; 0=do not combine) + ! maxI,MaxJ Int Dimensions of the 2d (gridded) data wsdat + ! deltaLat Real Delta in kilometers between 2 pts (in latitude) + ! + LOGICAL :: first + CHARACTER :: way *1 + INTEGER :: ngbrExt, combine, maxI, maxJ, i, j, oldJ + INTEGER :: horizStepCount, vertStepCount, checkCount, sc, & + maxPts, landPts, horizBorder, vertBorder, m, k, & + stepCount + REAL :: deltaLat, minLat, maxLat, minLon, maxLon + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! findWay + ! findNext + ! findSys + ! combineWaveSystems + ! + ! 5. Subroutines calling + ! + ! waveTracking_NWS_V2 + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + ! Routine starts by identifying the starting point. Choose the 'center' of the domain + ! Set the search distance for neighbors: + ! 1: 1 row and column out, i.e. the 8 neighbors around the current point + ! 2: 2 rows and columns out... etc. + ngbrExt=1 + combine=1 + WRITE(20,*) 'In spiralTrackV3: combine = ',combine + + maxI = wsdat%maxi + maxJ = wsdat%maxj + IF ( (seedLat.EQ.0).OR.(seedLon.EQ.0) ) THEN + i=NINT(REAL(maxI)/2.) + j=NINT(REAL(maxJ)/2.) + WRITE(20,*) 'In spiralTrackV3, i=NINT(maxI/2.) =',i + WRITE(20,*) 'In spiralTrackV3, j=NINT(maxJ/2.) =',j + ELSE + i=1 + j=1 + DO WHILE ( (wsdat%lat(1,j).LT.seedLat).AND.(j.LT.wsdat%maxj) ) !40.PAR !Improve with SWAN's indice identification + j=j+1 + END DO + DO WHILE ( (wsdat%lon(i,1).LT.seedLon).AND.(i.LT.wsdat%maxi) ) + i=i+1 + END DO + END IF + ! In case center point is land point... + IF (wsdat%par(i,j)%checked.EQ.-1) THEN + oldJ=j + DO WHILE (wsdat%par(i,j)%checked.EQ.-1) + j=j+1 + IF (j.EQ.maxJ) THEN + j=oldJ + i=i+1 + oldJ=oldJ+1 + END IF + END DO + END IF + ! Compute distance in km between 2 grid points (at equator) + deltaLat=(wsdat%lat(i,j)-wsdat%lat(i,j-1))*111.18 + + ! Starts the spiral + ! Intitiate variables + horizStepCount=0 + vertStepCount=0 + way='R' + first=.TRUE. + checkCount=1 + maxSys=0 + landPts=0 + + minLat=MINVAL(wsdat%lat) + maxLat=MAXVAL(wsdat%lat) + minLon=MINVAL(wsdat%lon) + maxLon=MAXVAL(wsdat%lon) + + horizBorder=0 + vertBorder=0 + DO WHILE (checkCount.LE.(maxI*maxJ-3) ) + ! From the direction (way) we were going before, find which direction we + ! are going now and how many 'step' we need to take + CALL findWay(way, horizStepCount, vertStepCount, & + vertBorder, horizBorder, stepCount) + IF (first) THEN + m=0 + DO k=1,LENGTH(wsdat%par(i,j)%hs, & + SIZE(wsdat%par(i,j)%hs),9999.) + IF ( (wsdat%par(i,j)%hs(k).EQ.0.).AND. & + (wsdat%par(i,j)%tp(k).EQ.0.) ) THEN + wsdat%par(i,j)%sys(k)=-1 + ELSE + m=m+1 + wsdat%par(i,j)%sys(k)=m END IF -! Initiate sys num - ALLOCATE( tmpsys(SIZE(allSys)) ) -! Clear the wsdat%par(i,j)%sys field, new values assigned below. -! System info temporarily stored in allSys - wsdat%par(i,j)%sys(1:10) = 9999 - - DO s=1, SIZE(allSys) - hsAll(:) = 0. - tpAll(:) = 0. - dirAll(:) = 0. -! wfAll(:) = 0. - n=1 - countAll=0 - DO WHILE (n.LE.nngbr) -! Calculate mean of common neighbor wave system -! for every neigbor wave system - found = .FALSE. - DO ind = 1, SIZE(ngbr(n)%par%sys) !Optimize this? - IF ( ngbr(n)%par%sys(ind).EQ.allSys(s) ) THEN !Put sys under par to maintain structure - found = .TRUE. - EXIT - END IF - END DO - - IF (found) THEN - countAll=countAll+1 - hsAll(countAll)=ngbr(n)%par%hs(ind) - tpAll(countAll)=ngbr(n)%par%tp(ind) - dirAll(countAll)=ngbr(n)%par%dir(ind) -! wfAll(countAll)=ngbr(n)%par%wf(ind) - ELSE - n=n+1 - CYCLE - END IF - n=n+1 - END DO - tmpsys(s)%hsMean = SUM(hsAll(1:countAll))/countAll - tmpsys(s)%tpMean = SUM(tpAll(1:countAll))/countAll - tmpsys(s)%dirMean = & - mean_angleV2(dirAll(1:countAll),countAll) -! tmpsys(s)%wfMean = SUM(wfAll(1:countAll))/countAll - END DO - -! Find the partition at current (i,j) point that matches previously -! identified wave systems if any... - wsdat%par(i,j)%ngbrSys(1:SIZE(allSys)) = allSys - - npart = LENGTH(REAL(wsdat%par(i,j)%ipart), & - SIZE(wsdat%par(i,j)%ipart),REAL(0)) - DO p = 1, npart - IF ( (wsdat%par(i,j)%hs(p).LT.hsKnob).OR. & - (wsdat%par(i,j)%tp(p).EQ.0.) ) THEN - wsdat%par(i,j)%sys(p)=-1 - CYCLE - END IF - - ind=0 !Replaced 'index' by 'ind' - match%sysVal(:) = 9999 - match%tpVal(:) = 9999. - match%dirVal(:) = 9999. -! match%wfVal(:) = 9999. -! Cycle through the neighbouring systems identified above - DO s=1,SIZE(allSys) - absHs = ABS(wsdat%par(i,j)%hs(p)-tmpsys(s)%hsMean) - absPer = ABS(wsdat%par(i,j)%tp(p)-tmpsys(s)%tpMean) - absDir = ABS(wsdat%par(i,j)%dir(p)-tmpsys(s)%dirMean) -! absWf = ABS(wsdat%par(i,j)%wf(p)-tmpsys(s)%wfMean) - IF (absDir.GT.180) THEN - absDir = 360 - absDir - IF (absDir.LT.0) THEN - WRITE(20,*) '*** WARNING: absDir negative!' - WRITE(20,*) 'wsdat%par(i,j)%dir(p) =', & - wsdat%par(i,j)%dir(p) - WRITE(20,*) 'tmpsys(s)%dirMean) =', & - tmpsys(s)%dirMean - END IF - END IF -! Calculate delta dir and freq as a function of the partition -! dir and freq - T = tmpsys(s)%tpMean - dx = 0.5*( (wsdat%lon(2,1)-wsdat%lon(1,1)) + & - (wsdat%lat(1,2)-wsdat%lat(1,1)) ) - m1 = -3.645*T + 63.211 - m1 = MAX(m1,10.) - m2 = -0.346*T + 3.686 - m2 = MAX(m2,0.6) -!1stddev m1 = -2.219*T + 35.734 -!1stddev m1 = MAX(m1,5.) -!1stddev m2 = -0.226*T + 2.213 -!1stddev m2 = MAX(m2,0.35) -!5stddev m1 = -5.071*T + 90.688 -!5stddev m1 = MAX(m1,16.) -!5stddev m2 = -0.467*T + 5.161 -!5stddev m2 = MAX(m2,1.0) - deltaDir = m1*dx + dirKnob - deltaPer = m2*dx + perKnob - deltaHs = 0.25*tmpsys(s)%hsMean - IF ((absPer.LT.deltaPer).AND.(absDir.LT.deltaDir)) THEN - ind=ind+1 - match%sysVal(ind) = allSys(s) - match%tpVal(ind) = absPer - match%dirVal(ind) = absDir - match%hsVal(ind) = absHs -! match%wfVal(ind) = absWf - END IF - END DO + END DO - IF (ind.GT.0) THEN - IF (ind.EQ.1) THEN - wsdat%par(i,j)%sys(p) = match%sysVal(1) - ELSE -! Take the closest match, using GoF function - GOF(:) = 9999. - GOF(1:ind) = (match%tpVal(1:ind)/deltaPer)**2 + & - (match%dirVal(1:ind)/deltaDir)**2 + & - (match%hsVal(1:ind)/deltaHs)**2 - GOFMinVal = MINVAL(GOF(1:ind)) - GOFMinInd = FINDFIRST(GOF(1:ind),ind,GOFMinVal) - wsdat%par(i,j)%sys(p) = match%sysVal(GOFMinInd) !The index of the system is swapped - the remaining info stays the same! - END IF - END IF - END DO + wsdat%par(i,j)%checked=1 + checkCount=checkCount+1 + first=.FALSE. END IF - -! Now check if 2 partitions have been associated to the same wave system, if -! so combine them - npart = LENGTH(REAL(wsdat%par(i,j)%ipart), & - SIZE(wsdat%par(i,j)%ipart),REAL(0)) - DO p = 1, (npart-1) !Could probably be optimized! - DO pp = (p+1), npart - IF (wsdat%par(i,j)%sys(p).EQ.wsdat%par(i,j)%sys(pp)) THEN -! There is at least one duplicate, so combine systems - CALL combinePartitionsV2(wsdat%par(i,j)) - END IF - END DO + DO sc = 1, stepCount + CALL findNext (i,j,maxI,maxJ,way,vertBorder,horizBorder) + IF ( wsdat%par(i,j)%checked.EQ.-1 ) THEN + ! Land point is one of our grid points, so we need to update counter + checkCount=checkCount+1 + landPts=landPts+1 + ! So that we don't count the land points twice.... + wsdat%par(i,j)%checked=-2 + ELSE IF ( wsdat%par(i,j)%checked.EQ.0 ) THEN + ! Hasn't been checked yet and is not land point + checkCount=checkCount+1 + CALL findSys(i, j, wsdat, maxSys, ngbrExt, maxI, maxJ, & + perKnob, dirKnob, hsKnob) + END IF END DO -! Now that we have associated any possible partition to an existing -! wave system, we check if any wave system is free. If so give it a -! new wave system number - npart = LENGTH(REAL(wsdat%par(i,j)%ipart), & - SIZE(wsdat%par(i,j)%ipart),REAL(0)) - - DO p = 1, npart - IF (wsdat%par(i,j)%sys(p).EQ.9999) THEN - maxSys = maxSys + 1 - wsdat%par(i,j)%sys(p) = maxSys - END IF + END DO + ! wetPts% of wet points + maxPts=NINT(wetPts*(maxI*maxJ-1)) + ! + WRITE(20,*) 'Call combineWaveSystems...' + CALL combineWaveSystems(wsdat,maxSys,maxPts,maxI,maxJ, & + perKnob,dirKnob,hsKnob,combine,sys) + + RETURN + END SUBROUTINE spiralTrackV3 + !/ End of spiralTrackV3 ---------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE timeTrackingV2 (sysA ,maxSys ,tpTimeKnob , & + dirTimeKnob,ts0 ,maxGroup , & + dt ,lonext ,latext , & + maxI ,maxJ ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Performs the time tracking of the systems identified within + ! the subroutine spiralTrackV3. + ! + ! 2. Method + ! + ! - + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Note: perKnob, dirKnob in Matlab version replaced by tpTimeKnob, dirTimeKnob! + ! + ! sysA TYPE(timsys) in/out Final set of spatially and temporally tracked systems + ! dirTimeKnob Real input Parameter in direction for combining fields in time + ! tpTimeKnob Real input Parameter in period for combining fields in time + ! ts0 Int input Time step to which default grp values are associated + ! maxSys Int arr input Total number of systems per time level + ! maxGroup Int output Maximum number of wave systems ("groups") tracked in time + ! lonext Real input Longitudinal extent of domain + ! latext Real input Latitudinal extent of domain + ! maxI, maxJ Int input Maximum indices of wave field + ! + TYPE(timsys), POINTER :: sysA(:) + INTEGER, POINTER :: maxSys(:) + REAL :: dirTimeKnob, tpTimeKnob + INTEGER :: ts0, maxGroup + REAL :: dt + REAL :: lonext, latext + INTEGER :: maxI, maxJ + + INTENT (IN) tpTimeKnob, dirTimeKnob, ts0, maxI, maxJ + ! INTENT (IN OUT) sysA + INTENT (OUT) maxGroup + ! + ! Local variables + ! ---------------------------------------------------------------- + ! ic Int Counter for wave systems + ! ts1 Int Adjusted initial time step in case ts0 has only empty systems + ! + LOGICAL :: file_exists + CHARACTER :: dummy*23 + TYPE(sysmemory) :: sysMem(50) !!! 50 memory spaces should be enough Check!!! + INTEGER :: leng, l, i, ii, j, k, kk, idir, numSys, & + counter, new, DIFSIZE, tpMinInd, dirMinInd, used, ok + REAL :: Tb, deltaPer, deltaDir, tpMinVal, dirMinVal, & + dirForTpMin, tpForDirMin + REAL, ALLOCATABLE :: sysOrdered(:), TEMP(:), dirs(:) + REAL, POINTER :: DIFARR(:) + INTEGER, ALLOCATABLE :: indSorted(:), alreadyUsed(:), allInd(:) + INTEGER, ALLOCATABLE :: ind(:), ind2(:) + INTEGER :: ts1 + REAL, ALLOCATABLE :: GOF(:,:), GOFMinVal(:), GOFMinInd(:), & + Tbsysmem(:), deltaDirsysmem(:), & + deltaPersysmem(:),m1sysmem(:),m2sysmem(:) + REAL :: m1, m2 + REAL :: lonmean, latmean, dmndiag + INTEGER :: npnts, npnts2 + REAL, ALLOCATABLE :: mnlonlist(:), mnlatlist(:), mndist(:) + REAL, POINTER :: dummy1(:),dummy2(:),dummy3(:) + INTEGER, ALLOCATABLE :: olsize(:) + REAL :: TEMP1, TEMP2 + INTEGER :: iii, jj, ll, idup + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! SORT + ! SETDIFF + ! + ! 5. Subroutines calling + ! + ! waveTracking_NWS_V2 + ! + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + ! Associate default grp value to time step 1 + WRITE(20,*) 'TIME TRACKING' + WRITE(20,*) 'Inside timeTrackingV2: SIZE(sysA(1)%sys) =', & + SIZE(sysA(1)%sys) + WRITE(20,*) 'Inside timeTrackingV2: maxSys(1) =',maxSys(1) + WRITE(20,*) 'ts0 = ',ts0 + + ts1 = ts0 + + ! Skip initial time steps with empty systems (e.g. when starting from rest) + DO i = ts1, SIZE(sysA) + IF (SIZE(sysA(ts1)%sys).EQ.0) ts1 = ts1+1 + ! No non-empty systems found + IF (ts1.GT.SIZE(sysA)) THEN + maxGroup = 0 + GOTO 2000 + END IF + END DO + WRITE(20,*) 'TS = ',ts1 + + IF (SIZE(sysA(ts1)%sys).GT.0) THEN + ! Initialize system memory groups + sysA(ts1)%sys(:)%grp = 9999 + sysMem(:)%grp = 9999 + sysMem(:)%nPoints = 0 + sysMem(:)%lonMean = 9999. + sysMem(:)%latMean = 9999. + sysMem(:)%tpMean = 9999. + sysMem(:)%dirMean = 9999. + sysMem(:)%updated = -9999 + sysMem(:)%length = 0 + DO iii = 1,50 + ALLOCATE(sysMem(iii)%indx(maxI*maxJ)) + sysMem(iii)%indx = 9999 END DO - wsdat%par(i,j)%checked=1 - IF (ALLOCATED(allSys)) DEALLOCATE(allSys) - IF (ALLOCATED(tmpsys)) DEALLOCATE(tmpsys) - - RETURN - END SUBROUTINE findSys -!/ End of findSys ---------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE combineWaveSystems (wsdat ,maxSys ,maxPts , & - maxI ,maxJ ,perKnob , & - dirKnob ,hsKnob ,combine , & - sys ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Combine wave systems. Then remove small and low-energy systems from set, -! based on the parameters maxPts and maxHgt. -! -! 2. Method -! -! - -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! wsdat Type(dat2d) output Combined wave system data structure -! sys Type(system) output Final set of tracked systems, for one time level -! maxI, maxJ Int input Maximum indices of wave field -! maxSys Int input Maximum number of systems identified -! maxPts Int input Number of points req for valid system -! hsKnob Real input Parameter for identifying valid system -! combine Int input Toggle: 1=combine systems; 0=do not combine - - TYPE(dat2d) :: wsdat - TYPE(system), POINTER :: sys(:), systemp(:) - INTEGER :: maxSys, maxPts, maxI, maxJ, combine - REAL :: perKnob ,dirKnob, hsKnob - - INTENT (IN) maxPts, maxI, maxJ, hsKnob, combine - INTENT (IN OUT) wsdat, maxSys !In the Matlab code maxSys is only input ??? -! INTENT (OUT) sys -! -! Local variables -! ---------------------------------------------------------------- -! nSys Int Number of wave systems (for checking iterative combining loop) -! - LOGICAL :: found - INTEGER, ALLOCATABLE :: sysOut(:) - INTEGER, ALLOCATABLE :: actSysInd(:) - INTEGER :: iter, ok, nSys, mS, s, so, ss, ind, leng, & - iw, jw, iloop - INTEGER :: actSys - REAL :: dev, hsCmp, maxHgt, temp(5) -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! printFinalSys -! combineSys -! -! 5. Subroutines calling -! -! spiralTrackV3 -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -!012912 WRITE(20,*) 'maxSys,maxPts,maxI,maxJ,hsKnob,combine =', & -!012912 maxSys,maxPts,maxI,maxJ,hsKnob,combine - -! Set up initial index array of active systems - IF (.NOT.ALLOCATED(actSysInd)) ALLOCATE( actSysInd(maxSys) ) - actSysInd(1:maxSys) = (/ (ind, ind = 1, maxSys) /) -!opt WRITE(20,*) 'actSysInd =',actSysInd - - IF (combine.EQ.1) THEN -! Combine wave systems - WRITE(20,*) 'Calling printFinalSys...' - CALL printFinalSys (wsdat,maxSys,actSysInd,maxI,maxJ,1,sys) - iter=0 - ok=0 -! Keep on combining wave systems until all possible combining -! has been carried out (based on the combining criteria) - DO WHILE (ok.EQ.0) - iter = iter+1 -! No of systems before combining - IF (ALLOCATED(actSysInd)) THEN - nSys = SIZE(actSysInd) - ELSE - nSys = maxSys - END IF - WRITE(20,'(A,A,I3,A,I5,A)') 'Calling combineSys for ', & - 'iteration',iter,' (maxSys =',nSys,').' - -!opt WRITE(20,*) 'SIZE(sys)=',SIZE(sys) - CALL combineSys (wsdat,sys,maxSys,maxI,maxJ, & - actSysInd,perKnob,dirKnob) -! No of systems after combining -!opt WRITE(20,*) 'maxSys,nSys,SIZE(actSysInd) =', & -!opt maxSys,nSys,SIZE(actSysInd) -! IF (maxSys.EQ.nSys) ok = 1 - IF (SIZE(actSysInd).EQ.nSys) ok = 1 + INQUIRE(FILE="sys_restart.ww3", EXIST=file_exists) + IF (file_exists) THEN + ! Use groups from wave tracking hotfile + WRITE(20,*) '*** Using group memory hotfile' + OPEN(unit=12,file='sys_restart.ww3',status='old') + READ(12,'(A23,I10)') dummy,maxGroup + WRITE(20,*) 'Reading ',maxGroup,' systems' + DO k = 1,maxGroup + READ(12,'(A23,I10)') dummy,sysMem(k)%grp + READ(12,'(A23,I10)') dummy,sysMem(k)%nPoints + READ(12,'(A23,F10.4)') dummy,sysMem(k)%lonMean + READ(12,'(A23,F10.4)') dummy,sysMem(k)%latMean + READ(12,'(A23,F10.3)') dummy,sysMem(k)%tpMean + READ(12,'(A23,F10.3)') dummy,sysMem(k)%dirMean + READ(12,'(A23,I10)') dummy,sysMem(k)%updated + READ(12,'(A23,I10)') dummy,sysMem(k)%length + DO j = maxJ,1,-1 + READ(12,*) (sysMem(k)%indx((j-1)*maxI+i), i = 1,maxI) END DO + !Reset update counter + sysMem(k)%updated = 0 + END DO + CLOSE(12) + ts1 = ts1-1 ELSE -! Do not combine wave systems - CALL printFinalSys (wsdat,maxSys,actSysInd,maxI,maxJ,3,sys) + ! Set up the group number array for the first time level to be tracked + ALLOCATE( sysOrdered(maxSys(ts1)) ) + ALLOCATE( indSorted(maxSys(ts1)) ) + CALL SORT (REAL(sysA(ts1)%sys(1:maxSys(ts1))%nPoints), & + maxSys(ts1),sysOrdered,indSorted,'D') + sysA(ts1)%sys(1:maxSys(ts1)) = sysA(ts1)%sys(indSorted) + IF (ALLOCATED(sysOrdered)) DEALLOCATE(sysOrdered) + IF (ALLOCATED(indSorted)) DEALLOCATE(indSorted) + + ! Set the initial long-term system memory + DO i = 1, maxSys(ts1) + sysA(ts1)%sys(i)%grp = i + ! Set initial values of long-term system memory + sysMem(i)%grp = i + sysMem(i)%nPoints = sysA(ts1)%sys(i)%nPoints + sysMem(i)%lonMean = & + SUM(sysA(ts1)%sys(i)%lon(1:sysMem(i)%nPoints))/& + sysMem(i)%nPoints + sysMem(i)%latMean = & + SUM(sysA(ts1)%sys(i)%lat(1:sysMem(i)%nPoints))/& + sysMem(i)%nPoints + !070512----------- Weight averages with Hm0 --------------------- + TEMP1 = 0. + TEMP2 = 0. + DO iii = 1,sysMem(i)%nPoints + TEMP1 = TEMP1 + & + (sysA(ts1)%sys(i)%hs(iii)**2)*sysA(ts1)%sys(i)%lon(iii) + TEMP2 = TEMP2 + & + (sysA(ts1)%sys(i)%hs(iii)**2)*sysA(ts1)%sys(i)%lat(iii) + END DO + sysMem(i)%lonMean = TEMP1/& + MAX(SUM(sysA(ts1)%sys(i)%hs(1:sysMem(i)%nPoints)**2),& + 0.001) + sysMem(i)%latMean = TEMP2/& + MAX(SUM(sysA(ts1)%sys(i)%hs(1:sysMem(i)%nPoints)**2),& + 0.001) + !070512----------- Weight averages with Hm0 --------------------- + sysMem(i)%tpMean = sysA(ts1)%sys(i)%tpMean + sysMem(i)%dirMean = sysA(ts1)%sys(i)%dirMean + sysMem(i)%updated = ts1 + sysMem(i)%length = 1 + !071012----------- Grid point indexing -------------------------- + DO iii = 1,sysMem(i)%nPoints + sysMem(i)%indx(iii) = (sysA(ts1)%sys(i)%j(iii)-1)*maxI +& + sysA(ts1)%sys(i)%i(iii) + END DO + !071012----------- Grid point indexing -------------------------- + END DO + maxGroup = maxSys(ts1) + ! i = ts1 END IF -! Remove small and low-energy systems from set, based on -! the parameters maxPts and maxHgt. -! ALLOCATE( sysOut(maxSys) ) -! sysOut = sys(1:maxSys)%sysInd -! mS = maxSys - mS = SIZE(actSysInd) - ss = 1 - WRITE(20,*) 'Filtering the set of',mS,'systems on size and mag.' - - DO so = 1, mS - s = actSysInd(so) -!opt NOTE: if we deallocate the individual records without -!opt compressing sys, then s and sysInd will remain the same - ss = s - - leng = LENGTH(sys(ss)%hs,SIZE(sys(ss)%hs),9999.) - dev = STD(sys(ss)%hs(1:leng),leng) - hsCmp = sys(ss)%hsMean + 2.*dev - maxHgt = hsKnob - - IF ( (hsCmp.LT.maxHgt).OR.(sys(ss)%nPoints.LT.maxPts) ) THEN -! Remove system, and shift up indices to fill the gap - DO ind = 1, maxSys -! Find index to remove - IF (ind.EQ.ss) THEN -! Shift up entries, deleting the duplicate partition -! REPLACE WITH CSHIFT(ARRAY, SHIFT, dim)? -! IF (ind.LT.maxSys) & -! sys( ind:(maxSys-1) ) = sys( (ind+1):maxSys ) - IF (ind.LE.maxSys) THEN -! Since we use pointers, we have to copy each index and -! field individually. Otherwise memory corruption occurs. - DO iloop = ind,ind - sys(iloop)%sysInd = 9999 - sys(iloop)%nPoints = 0 - sys(iloop)%grp = 9999 - DEALLOCATE( sys(iloop)%hs ) - DEALLOCATE( sys(iloop)%tp ) - DEALLOCATE( sys(iloop)%dir ) - DEALLOCATE( sys(iloop)%dspr ) -! DEALLOCATE( sys(iloop)%wf ) - DEALLOCATE( sys(iloop)%i ) - DEALLOCATE( sys(iloop)%j ) - DEALLOCATE( sys(iloop)%lat ) - DEALLOCATE( sys(iloop)%lon ) -! DEALLOCATE( sys(iloop)%hsMean ) -! DEALLOCATE( sys(iloop)%tpMean ) -! DEALLOCATE( sys(iloop)%dirMean ) -! DEALLOCATE( sys(iloop)%ngbr ) - END DO - END IF - END IF - END DO - -! Update wsdat as well - DO iw = 1, maxI - DO jw = 1, maxJ - leng = LENGTH(REAL(wsdat%par(iw,jw)%sys), & - SIZE(wsdat%par(iw,jw)%sys),REAL(9999)) - ind = 1 - found = .FALSE. -! Identify system index (there are no duplicate -! systems at this point. - DO WHILE (ind.LE.leng) - IF ( wsdat%par(iw,jw)%sys(ind).EQ.s ) THEN - found = .TRUE. - EXIT - END IF - ind = ind + 1 - END DO - IF (found) THEN -! Blank out used record - wsdat%par(iw,jw)%sys(ind) = 9999 - wsdat%par(iw,jw)%ipart(ind) = 9999 - END IF - END DO - END DO - END IF + !******** Test output *********************** + DO i = 1, maxGroup + WRITE(20,*) 'sysMem(',i,')%grp =',sysMem(i)%grp + WRITE(20,*) 'sysMem(',i,')%nPoints =',sysMem(i)%nPoints + WRITE(20,*) 'sysMem(',i,')%lonMean =',sysMem(i)%lonMean + WRITE(20,*) 'sysMem(',i,')%latMean =',sysMem(i)%latMean + WRITE(20,*) 'sysMem(',i,')%tpMean =',sysMem(i)%tpMean + WRITE(20,*) 'sysMem(',i,')%dirMean =',sysMem(i)%dirMean + WRITE(20,*) 'sysMem(',i,')%updated =',sysMem(i)%updated + WRITE(20,*) 'sysMem(',i,')%length =',sysMem(i)%length END DO + !******************************************** + END IF + + ! Loop over all time levels to track systems in time + WRITE(20,*) 'Number of time levels = ',SIZE(sysA) + DO i = (ts1+1), SIZE(sysA) + WRITE(20,*) 'TS = ',i + + IF (SIZE(sysA(i)%sys).GT.0) THEN + ! *** Added: 02/29/12 ************************************* + ! Sort groups, so that larger systems get associated first + ALLOCATE( sysOrdered(maxSys(i)) ) + ALLOCATE( indSorted(maxSys(i)) ) + CALL SORT (REAL(sysA(i)%sys(1:maxSys(i))%nPoints), & + maxSys(i),sysOrdered,indSorted,'D') + sysA(i)%sys(1:maxSys(i)) = sysA(i)%sys(indSorted) + IF (ALLOCATED(sysOrdered)) DEALLOCATE(sysOrdered) + IF (ALLOCATED(indSorted)) DEALLOCATE(indSorted) + ! *** Added: 02/29/12 ************************************* + + ! Initialize groups ! Optimize? + sysA(i)%sys(:)%grp = 9999 ! Optimize? + counter = 0 + leng = LENGTH(REAL(sysMem(:)%grp), & + SIZE(sysMem(:)%grp),REAL(9999)) + ALLOCATE( alreadyUsed(leng+10) ) !Make space for 10 new potential entries. Improve!!! + WRITE(20,*) 'sysMem(1:leng)%grp =', & + sysMem(1:leng)%grp + ALLOCATE( allInd(leng) ) + alreadyUsed(:) = 0 + allInd(:) = sysMem(1:leng)%grp + + !071212-----GoF 2D------------------------------- + ALLOCATE( ind(SIZE(allInd)) ) + ind(:) = allInd + ALLOCATE( ind2(SIZE(ind)) ) + DO ii = 1, SIZE(ind) + ind2(ii) = FINDFIRST(REAL(allInd),SIZE(allInd), & + REAL(ind(ii))) + END DO + ! Define 2D array for evaluating best fit for systems + ALLOCATE( GOF(maxSys(i),maxGroup) ) + ALLOCATE( GOFMinVal(maxGroup) ) + ALLOCATE( GOFMinInd(maxGroup) ) + ALLOCATE( Tbsysmem(maxGroup) ) + ALLOCATE( deltaDirsysmem(maxGroup) ) + ALLOCATE( deltaPersysmem(maxGroup) ) + ALLOCATE( m1sysmem(maxGroup) ) + ALLOCATE( m2sysmem(maxGroup) ) + !071212-----GoF 2D------------------------------- + DO j = 1, maxSys(i) + npnts = sysA(i)%sys(j)%nPoints + lonmean = SUM(sysA(i)%sys(j)%lon(1:npnts))/npnts + latmean = SUM(sysA(i)%sys(j)%lat(1:npnts))/npnts + !070512----------- Weight averages with Hm0 --------------------- + TEMP1 = 0. + TEMP2 = 0. + DO iii = 1,npnts + TEMP1 = TEMP1 + & + (sysA(i)%sys(j)%hs(iii)**2)*sysA(i)%sys(j)%lon(iii) + TEMP2 = TEMP2 + & + (sysA(i)%sys(j)%hs(iii)**2)*sysA(i)%sys(j)%lat(iii) + END DO + lonmean=TEMP1/MAX(SUM(sysA(i)%sys(j)%hs(1:npnts)**2),0.001) + latmean=TEMP2/MAX(SUM(sysA(i)%sys(j)%hs(1:npnts)**2),0.001) + !070512----------- Weight averages with Hm0 --------------------- + !071012----------- Grid point indexing -------------------------- + ALLOCATE(sysA(i)%sys(j)%indx(maxI*maxJ)) + sysA(i)%sys(j)%indx = 9999 + DO iii = 1,sysA(i)%sys(j)%nPoints + sysA(i)%sys(j)%indx(iii) = & + (sysA(i)%sys(j)%j(iii)-1)*maxI + & + sysA(i)%sys(j)%i(iii) + END DO + !071012----------- Grid point indexing -------------------------- + WRITE(20,*) 'System no. ',j,' of ',maxSys(i) + WRITE(20,*) 'Size =', npnts + WRITE(20,*) 'lonMean =', lonmean + WRITE(20,*) 'latMean =', latmean + WRITE(20,*) 'tpMean =', sysA(i)%sys(j)%tpMean + WRITE(20,*) 'dirMean =', sysA(i)%sys(j)%dirMean + sysA(i)%sys(j)%grp = 9999 !Now redundant? + + ! Compute deltas + Tbsysmem = sysMem(1:maxGroup)%tpMean + WRITE(20,*) 'Tbsysmem(:) = ', Tbsysmem(:) + ! Compute deltas the same way as for field combining - they should + ! be of the same degree of strictness as the latter, otherwise + ! the time combining will lose track! + !3stddev m1 = -3.645*Tb + 63.211 + !3stddev m1 = MAX(m1,10.) + !3stddev m2 = -0.346*Tb + 3.686 + !3stddev m2 = MAX(m2,0.6) + !1stddev m1 = -2.219*Tb + 35.734 + !1stddev m1 = MAX(m1,5.) + !1stddev m2 = -0.226*Tb + 2.213 + !1stddev m2 = MAX(m2,0.35) + !071412 m1 = -5.071*Tb + 90.688 + !071412 m1 = MAX(m1,16.) + !071412 m2 = -0.467*Tb + 5.161 + !071412 m2 = MAX(m2,1.0) + !071412 deltaDir = (m1*1. + dirTimeKnob)*1. + !071412 deltaPer = (m2*1. + tpTimeKnob)*1. + DO ii = 1,SIZE(ind2) + m1sysmem(ii) = MAX((-3.645*Tbsysmem(ii)+63.211),10.) + m2sysmem(ii) = MAX((-0.346*Tbsysmem(ii)+3.686),0.6) + END DO + deltaDirsysmem = m1sysmem(:)*1. + dirTimeKnob + deltaPersysmem = m2sysmem(:)*1. + tpTimeKnob + WRITE(20,*) 'deltaDirsysmem(:) = ',deltaDirsysmem + WRITE(20,*) 'deltaPersysmem(:) = ',deltaPersysmem + + ! Criterion 1: Mean period + ALLOCATE( TEMP(SIZE(ind2)) ) + TEMP = ABS( sysA(i)%sys(j)%tpMean - & + sysMem(ind2(:))%tpMean ) + WRITE(20,*) 'tpMean list =', & + sysMem(ind2(:))%tpMean + WRITE(20,*) 'tpMinVal list =', TEMP + tpMinVal = MINVAL(TEMP) + tpMinInd = FINDFIRST(TEMP,SIZE(TEMP),tpMinVal) + + ! Criterion 2: Mean direction + ALLOCATE( dirs(SIZE(ind2)) ) + dirs(:)=ABS( sysA(i)%sys(j)%dirMean - & + sysMem(ind2(:))%dirMean ) + ! Deal with wrap around + DO idir = 1, SIZE(dirs) + IF (dirs(idir).GE.180.) dirs(idir)=360-dirs(idir) + END DO + WRITE(20,*) 'dirMean list =', & + sysMem(ind2(:))%dirMean + WRITE(20,*) 'dirMinVal list =', dirs + + ! Criterion 3: Size + WRITE(20,*) 'Size list =', & + sysMem(ind2(:))%nPoints + + ! Criterion 4: Distance between systems + ALLOCATE (mnlonlist(SIZE(ind2))) + ALLOCATE (mnlatlist(SIZE(ind2))) + ALLOCATE (mndist(SIZE(ind2))) + DO ii = 1,SIZE(ind2) + mnlonlist(ii) = sysMem(ind2(ii))%lonMean + mnlatlist(ii) = sysMem(ind2(ii))%latMean + mndist(ii) = SQRT((lonmean-mnlonlist(ii))**2 + & + (latmean-mnlatlist(ii))**2) + END DO + dmndiag = SQRT(lonext**2+latext**2) + WRITE(20,*) 'Distance list =',mndist(:) + WRITE(20,*) 'Domain diagonal =',dmndiag + + ! Criterion 5: Overlap of systems + ALLOCATE (olsize(SIZE(ind2))) + DO ii = 1,SIZE(ind2) + + IF (sysMem(ind2(ii))%nPoints.GT.0) THEN + CALL INTERSECT(REAL(sysA(i)%sys(j)%indx(1:npnts)),npnts, & + REAL(sysMem(ind2(ii))%indx(1:sysMem(ind2(ii))%nPoints)),& + sysMem(ind2(ii))%nPoints,dummy1,olsize(ii),dummy2,dummy3) + ELSE + olsize(ii) = 0 + END IF + END DO -! Compile array index of active systems in sys - actSys = 0 - DO so = 1,maxSys - IF (sys(so)%nPoints>0) actSys = actSys + 1 - END DO - IF (ALLOCATED(actSysInd)) DEALLOCATE(actSysInd) - ALLOCATE( actSysInd(actSys) ) - actSys = 0 - DO so = 1,maxSys - IF (sys(so)%nPoints>0) THEN - actSys = actSys + 1 - actSysInd(actSys) = sys(so)%sysInd - END IF - END DO + GOF(j,1:SIZE(ind2)) = (TEMP/deltaPersysmem(:))**2 + & + (dirs/deltaDirsysmem(:))**2 + & + ! (4*mndist(:)/dmndiag)**2 + ( (REAL(olsize(:)) - & + REAL(sysMem(ind2(:))%nPoints) )/& + (0.50*MAX(REAL(sysMem(ind2(:))%nPoints),0.001)) )**2 + ! Remove GoF entries which exceed predifined tolerances + DO ii = 1,SIZE(ind2) + WRITE(20,*) 'Testing: ii,olsize(ii),size,frac =',& + ii,olsize(ii),sysMem(ind2(ii))%nPoints,& + REAL(olsize(ii))/& + MAX(REAL(sysMem(ind2(ii))%nPoints),0.001) + IF ( REAL(olsize(ii)).LT.& + 0.50*REAL(sysMem(ind2(ii))%nPoints) ) THEN + GOF(j,ii) = 9999. + END IF + IF ( (TEMP(ii).GT.deltaPersysmem(ii)).OR.& + (dirs(ii).GT.deltaDirsysmem(ii)) ) THEN + GOF(j,ii) = 9999. + END IF + END DO + WRITE(20,*) 'GOF(j,:) =',GOF(j,:) -!opt WRITE(20,*) 'actSysInd =',actSysInd - DO so = 1,SIZE(actSysInd) - s = actSysInd(so) -!opt WRITE(20,*) 'sys(',s,')%sysInd =',sys(s)%sysInd - END DO + IF (ALLOCATED(TEMP)) DEALLOCATE(TEMP) + IF (ALLOCATED(dirs)) DEALLOCATE(dirs) + IF (ALLOCATED(mnlonlist)) DEALLOCATE(mnlonlist) + IF (ALLOCATED(mnlatlist)) DEALLOCATE(mnlatlist) + IF (ALLOCATED(mndist)) DEALLOCATE(mndist) + IF (ALLOCATED(olsize)) DEALLOCATE(olsize) - CALL printFinalSys (wsdat,maxSys,actSysInd,maxI,maxJ,1,sys) -!opt WRITE(20,*) 'actSysInd =',actSysInd -!opt DO so = 1,maxSys -!opt WRITE(20,*) 'sys(',so,')%sysInd =',sys(so)%sysInd, & -!opt ', sys(',so,')%nPoints =',sys(so)%nPoints -!opt END DO - - RETURN - END SUBROUTINE combineWaveSystems -!/ End of combineWaveSystems ----------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE printFinalSys (wsdat ,maxSys ,actSysInd , & - maxI ,maxJ ,flag ,sys ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Output (print) the final output systems for this time step. -! -! 2. Method -! -! - -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! wsdat Type(dat2d) input Combined data structure -! maxI, maxJ Int input Maximum indices of wave field -! maxSys Int input Maximum number of systems identified -! flag Int input Flag for printing system -! sys Type(system) output Final set of tracked systems, for one time level -! - TYPE(dat2d) :: wsdat - TYPE(system), POINTER :: sys(:) - INTEGER :: maxSys, maxI, maxJ, flag - INTEGER, ALLOCATABLE :: actSysInd(:) - - INTENT (IN) wsdat, actSysInd, maxI, maxJ, flag - INTENT (OUT) maxSys -! INTENT (IN OUT) sys -! -! Local variables -! ---------------------------------------------------------------- -! ic Int Counter for wave systems -! - INTEGER :: ic, nGuys, startInd, endInd, i, j, ind, leng, leng2 - INTEGER :: UNISIZE, DIFSIZE - REAL, ALLOCATABLE :: sysOrdered(:) - REAL, POINTER :: UNIARR(:), DIFARR(:) - INTEGER, ALLOCATABLE :: ngbrSysAll(:), sysSortedInd(:) - REAL :: TEMP(2), TEMP1, TEMP2 -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! UNIQUE -! SETDIFF -! SORT -! -! 5. Subroutines calling -! -! combineWaveSystems -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !071212-----------GoF 2D------------- + END DO + IF (ALLOCATED(Tbsysmem)) DEALLOCATE(Tbsysmem) + IF (ALLOCATED(deltaDirsysmem)) DEALLOCATE(deltaDirsysmem) + IF (ALLOCATED(deltaPersysmem)) DEALLOCATE(deltaPersysmem) + IF (ALLOCATED(m1sysmem)) DEALLOCATE(m1sysmem) + IF (ALLOCATED(m2sysmem)) DEALLOCATE(m2sysmem) + + WRITE(20,*) 'GoF3:' + DO jj = 1,maxSys(i) + WRITE(20,*) GOF(jj,:) + END DO -! Initialize sys structure - IF (flag.NE.2) THEN -! Allocate data structure with the final wave systems - WRITE(20,*) 'In printFinalSys...' - maxSys = SIZE(actSysInd) - NULLIFY(sys) - ALLOCATE( sys(maxSys) ) - WRITE(20,*) 'Allocated sys okay, SIZE(sys) =',SIZE(sys) - - ALLOCATE( ngbrSysAll(50*maxI*maxJ) ) !Large enough? - DO ic = 1, maxSys - NULLIFY( sys(ic)%hs ) - NULLIFY( sys(ic)%tp ) - NULLIFY( sys(ic)%dir ) - NULLIFY( sys(ic)%dspr ) -! NULLIFY( sys(ic)%wf ) - NULLIFY( sys(ic)%i ) - NULLIFY( sys(ic)%j ) - NULLIFY( sys(ic)%lat ) - NULLIFY( sys(ic)%lon ) - ALLOCATE( sys(ic)%hs(maxI*maxJ) ) - ALLOCATE( sys(ic)%tp(maxI*maxJ) ) - ALLOCATE( sys(ic)%dir(maxI*maxJ) ) - ALLOCATE( sys(ic)%dspr(maxI*maxJ) ) -! ALLOCATE( sys(ic)%wf(maxI*maxJ) ) - ALLOCATE( sys(ic)%i(maxI*maxJ) ) - ALLOCATE( sys(ic)%j(maxI*maxJ) ) - ALLOCATE( sys(ic)%lat(maxI*maxJ) ) - ALLOCATE( sys(ic)%lon(maxI*maxJ) ) - sys(ic)%hs(:) = 9999. !Optimize this further? - sys(ic)%tp(:) = 9999. - sys(ic)%dir(:) = 9999. - sys(ic)%dspr(:) = 9999. -! sys(ic)%wf(:) = 9999. - sys(ic)%i(:) = 9999 - sys(ic)%j(:) = 9999 - sys(ic)%lat(:) = 9999. - sys(ic)%lon(:) = 9999. - sys(ic)%sysInd = 9999 - sys(ic)%hsMean = 9999. - sys(ic)%tpMean = 9999. - sys(ic)%dirMean = 9999. - sys(ic)%nPoints = 0 - sys(ic)%ngbr(:) = 9999 - sys(ic)%grp = 9999 - ngbrSysAll(:) = 0 - startInd=1 - nGuys=0 - - DO i = 1, maxI - DO j = 1, maxJ -! ind=wsdat.par(i,j).sys==ic; - DO ind = 1, SIZE(wsdat%par(i,j)%sys) !40.81 !Optimize this? - IF (wsdat%par(i,j)%sys(ind).EQ.actSysInd(ic)) & - THEN - nGuys=nGuys+1 - sys(ic)%hs(nGuys)=wsdat%par(i,j)%hs(ind) - sys(ic)%tp(nGuys)=wsdat%par(i,j)%tp(ind) - sys(ic)%dir(nGuys)=wsdat%par(i,j)%dir(ind) - sys(ic)%dspr(nGuys)=wsdat%par(i,j)%dspr(ind) -! sys(ic)%wf(nGuys)=wsdat%par(i,j)%wf(ind) - sys(ic)%i(nGuys)=i - sys(ic)%j(nGuys)=j - sys(ic)%lat(nGuys)=wsdat%lat(i,j) - sys(ic)%lon(nGuys)=wsdat%lon(i,j) - leng = LENGTH(REAL(wsdat%par(i,j)%ngbrSys), & - SIZE(wsdat%par(i,j)%ngbrSys),REAL(9999)) - endInd = startInd + leng-1 - ngbrSysAll(startInd:endInd) = & - wsdat%par(i,j)%ngbrSys(1:leng) - startInd=endInd+1 - END IF - END DO - END DO - END DO + ! Find minima in GoF + DO k = 1,maxGroup + GOFMinVal(k) = MINVAL(GOF(:,k)) + GOFMinInd(k) = FINDFIRST(GOF(:,k),SIZE(GOF,1),GOFMinVal(k)) + IF (GOFMinVal(k).EQ.9999) THEN + GOFMinInd(k) = 0 + END IF + END DO -! if ~isempty(sys) - IF (nGuys.GT.0) THEN - sys(ic)%sysInd=ic - sys(ic)%hsMean = SUM(sys(ic)%hs(1:nGuys))/nGuys - sys(ic)%tpMean = SUM(sys(ic)%tp(1:nGuys))/nGuys -! sys(ic)%dirMean=mean_angle_single(sys(ic).dir) 40.81 Replaced with two-argument mean_angleV2 - sys(ic)%dirMean = & - mean_angleV2(sys(ic)%dir(1:nGuys),nGuys) -!070512----------- Weight averages with Hm0 --------------------- - TEMP1 = 0. - TEMP2 = 0. - DO i = 1,nGuys - TEMP1 = TEMP1 + (sys(ic)%hs(i)**2)*sys(ic)%hs(i) - TEMP2 = TEMP2 + (sys(ic)%hs(i)**2)*sys(ic)%tp(i) - END DO - sys(ic)%hsMean = & - TEMP1/MAX(SUM(sys(ic)%hs(1:nGuys)**2),0.001) - sys(ic)%tpMean = & - TEMP2/MAX(SUM(sys(ic)%hs(1:nGuys)**2),0.001) - sys(ic)%dirMean = mean_angleV3(sys(ic)%dir(1:nGuys), & - sys(ic)%hs(1:nGuys),nGuys) -!070512----------- Weight averages with Hm0 --------------------- - sys(ic)%nPoints = nGuys - IF (endInd.GT.0) THEN - CALL UNIQUE(REAL(ngbrSysAll(1:endInd)),endInd, & - UNIARR,UNISIZE) - TEMP = (/REAL(sys(ic)%sysInd),REAL(sys(ic)%sysInd)/) - CALL SETDIFF(REAL(UNIARR),UNISIZE, & - TEMP,2,DIFARR,DIFSIZE) - DIFSIZE = MIN(DIFSIZE,SIZE(sys(ic)%ngbr)) - sys(ic)%ngbr(1:DIFSIZE) = NINT(DIFARR(1:DIFSIZE)) - IF (ASSOCIATED(UNIARR)) DEALLOCATE(UNIARR) - IF (ASSOCIATED(DIFARR)) DEALLOCATE(DIFARR) - END IF - ELSE - CYCLE + IF (ALLOCATED(GOF)) DEALLOCATE(GOF) + + DO j = 1, maxSys(i) + new = 0 + ! Look up sysMem match for this current system. If no match + ! is found, the index value 0 is returned. + tpMinInd = 0 + TEMP1 = 9999. + DO jj = 1, SIZE(GOFMinInd) + IF (GOFMinInd(jj).EQ.j) THEN + IF (GOFMinVal(jj).LT.TEMP1) THEN + tpMinInd = jj + TEMP1 = GOFMinVal(jj) END IF + END IF END DO - IF (ALLOCATED(ngbrSysAll)) DEALLOCATE(ngbrSysAll) - END IF - -! Print the sorted field to the screen - leng = LENGTH(REAL(sys(:)%nPoints), & - SIZE(sys(:)%nPoints),REAL(9999)) - ALLOCATE( sysOrdered(leng) ) - ALLOCATE( sysSortedInd(leng) ) - CALL SORT (REAL(sys(:)%nPoints),leng, & - sysOrdered,sysSortedInd,'D') - leng = LENGTH(REAL(sysOrdered), & - SIZE(sysOrdered),REAL(0)) - - DO ic = 1, leng - leng2 = LENGTH(REAL(sys(sysSortedInd(ic))%ngbr), & - SIZE(sys(sysSortedInd(ic))%ngbr),REAL(9999)) - END DO - IF (ALLOCATED(sysOrdered)) DEALLOCATE(sysOrdered) - IF (ALLOCATED(sysSortedInd)) DEALLOCATE(sysSortedInd) - - RETURN - END SUBROUTINE printFinalSys -!/ End of printFinalSys ---------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE combineSys (wsdat ,sys ,maxSys ,maxI , & - maxJ ,actSysInd,perKnob ,dirKnob ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Combine wave systems -! -! 2. Method -! -! - -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! wsdat Type(dat2d) input Combined data structure -! maxI, maxJ Int input Maximum indices of wave field -! sys Type(system) output Final set of tracked systems, for one time level -! maxSys Int input Number of systems -! dirKnob Real input Parameter in direction for combining fields in space -! perKnob Real input Parameter in period for combining fields in space -! - TYPE(dat2d) :: wsdat !40.PAR - TYPE(system), POINTER :: sys(:) !40.PAR - INTEGER :: maxSys, maxI, maxJ !40.PAR - INTEGER, ALLOCATABLE :: actSysInd(:) - REAL :: perKnob ,dirKnob - REAL :: dx, m1, m2 - - INTENT (IN) maxI, maxJ, perKnob, dirKnob !40.PAR -! INTENT (IN OUT) wsdat, sys, maxSys !40.PAR -! -! Local variables -! ---------------------------------------------------------------- -! ngbIndex Int Arr Array of neighbours -! - INTEGER, ALLOCATABLE :: sysSortedInd(:), sysOut(:) - INTEGER, POINTER :: indSys1(:), indSys2(:) - REAL, ALLOCATABLE :: sysOrdered(:), rounded(:) - REAL, POINTER :: uniarr(:), difarr(:), allngbr(:) - INTEGER :: leng, leng2, s, ss, so, ngb, lsys, lsys2, hh, i, j, & - ii, jj, ind, ind2, nn, nbr, icEnd,ic,iii,iloop - INTEGER :: myngbr, indMatch, matchSys, keep, replacedInd, & - hhForIndMatch, lMatch, tot, outsize - INTEGER :: ngbIndex(10000), keepInd(maxI*maxJ), oneLess(1000) !Array large enough? -! REAL :: Tb,deltaPerB,deltaDirB,absDir,absPer,absHs,absWf - REAL :: Tb,deltaPerB,deltaDirB,deltaHsB,absDir,absPer,absHs - LOGICAL :: file_exists - INTEGER :: MASK(maxI,maxJ) - REAL :: lonmean, latmean, DIST -!061512 ----------------------------------------------- - LOGICAL :: ZIPMATCH - INTEGER :: counter, count2, izp, izp2, in, jn, icnt, ngbrExt - REAL :: T, ngb_tp, ngb_dir - REAL :: ngbmatch(maxI*maxJ) - TYPE(neighbr) :: ngbr(50) -!061512 ----------------------------------------------- - REAL :: TEMP1, TEMP2 - INTEGER :: actSys - -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! SORT -! findIJV4 -! UNIQUE -! combinePartitionsV2 -! UNION -! SETDIFF -! -! 5. Subroutines calling -! -! combineWaveSystems -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! Initialize pointer (first use) - NULLIFY(indSys1) - NULLIFY(indSys2) -! Flag to combine systems on a point-by-point basis along boundary, -! instead of using mean values. - ZIPMATCH = .FALSE. - ngbrExt = 1 -! Combine systems on the basis of tpMean - ALLOCATE( sysOrdered(maxSys) ) - ALLOCATE( sysSortedInd(maxSys) ) - ALLOCATE( sysOut(maxSys) ) - ALLOCATE( rounded(maxSys) ) -! Sort in descending Tp: the following improves the iterative combining in -! the special case that the wave period is constant over the domain, but -! tpMean is not because of truncation errors at very high decimals. - rounded = REAL(INT(sys(1:maxSys)%tpMean*1.E4))*1.E-4 - CALL SORT(rounded,maxSys,sysOrdered,sysSortedInd,'D') - sysOut=sys(sysSortedInd)%sysInd - IF (ALLOCATED(rounded)) DEALLOCATE(rounded) - -!051612 --- Land mask addition - MASK(:,:) = 0 - INQUIRE(FILE="sys_mask.ww3", EXIST=file_exists) - IF (file_exists) THEN - WRITE(20,*) '*** Using land mask' - OPEN(unit=13,file='sys_mask.ww3',status='old') - DO j = maxJ,1,-1 - READ(13,*) (MASK(i,j), i=1,maxI) - END DO - CLOSE(13) - END IF -!051612 --- Land mask addition - -!opt WRITE(20,*) 'SIZE(sysOut)=',SIZE(sysOut) - DO so = 1, SIZE(sysOut) -! WRITE(20,*) 'so =',so - s = sysOut(so) - ss = FINDFIRST(REAL(sys(:)%sysInd),SIZE(sys(:)%sysInd), & - REAL(s)) -!opt WRITE(20,*) 's,ss=',s,ss - ngbIndex(:) = 0 - ii = 1 - leng = LENGTH(REAL(sys(ss)%ngbr),SIZE(sys(ss)%ngbr), & - REAL(9999)) -! Identify the indices of all the systems that neighbour the current system s, -! store in ngbIndex(:) - DO ngb = 1, leng - IF ( sys(ss)%ngbr(ngb).NE.s ) THEN - myngbr = 1 - DO WHILE (myngbr.LE.SIZE(sysOut)) - IF (sys(myngbr)%sysInd.EQ.sys(ss)%ngbr(ngb)) THEN - ngbIndex(ii) = myngbr - ii = ii+1 - IF (ii.GT.1000) & - WRITE(20,*) '*** WARNING: ngbIndex(:) exceeded!' - END IF - myngbr = myngbr+1 - END DO - END IF - END DO - ii = ii-1 -!opt WRITE(20,*) so,'. sys =',s,', Tp =',sys(s)%tpMean, & -!opt ', size=',sys(s)%nPoints,', #neighbours=',ii - - IF ( ii.GT.0 ) THEN - DO ngb = 1, ii -! We first need to find the (i,j) points that are either common -! to both these systems, or at the boundary of the two systems. Here -! sys 1 will carry the 'ss' index and sys 2 the ngbIndex(ngb) index. - CALL findIJV4 (sys(ss),sys(ngbIndex(ngb)), & - maxI,maxJ,indSys1,indSys2) - IF ((SIZE(indSys1)>10).AND.(SIZE(indSys2)>10).AND. & - (sys(ss)%nPoints.GT.sys(ngbIndex(ngb))%nPoints)) & - THEN - lsys = SIZE(indSys1) - lsys2 = SIZE(indSys2) - -!061512---------------Add zipper compare - IF (ZIPMATCH) THEN -! Omit small systems to save time - IF ((sys(ss)%nPoints.LT.5).OR. & - (sys(ngbIndex(ngb))%nPoints.LT.5)) THEN - CYCLE - END IF - dx=0.5*((wsdat%lon(2,1)-wsdat%lon(1,1)) + & - (wsdat%lat(1,2)-wsdat%lat(1,1))) - ngbmatch(:)=0. - DO izp = 1,lsys -! Find neighbors of this point - counter=0 - DO in=(sys(ss)%i(indSys1(izp))-ngbrExt), & - (sys(ss)%i(indSys1(izp))+ngbrExt) - DO jn=(sys(ss)%j(indSys1(izp))-ngbrExt), & - (sys(ss)%j(indSys1(izp))+ngbrExt) - counter=counter+1 - ngbr(counter)%i = in - ngbr(counter)%j = jn - END DO - END DO -! Find these points in neighboring system - ngb_tp = 0. - ngb_dir = 0. - count2 = 0 - DO izp2 = 1,lsys2 - DO icnt = 1,counter - IF ((sys(ngbIndex(ngb))%i(indSys2(izp2)) & - .EQ.ngbr(icnt)%i).AND. & - (sys(ngbIndex(ngb))%j(indSys2(izp2)) & - .EQ.ngbr(icnt)%j)) THEN - count2 = count2+1 - ngb_tp = ngb_tp + & - sys(ngbIndex(ngb))%tp(indSys2(izp2)) - ngb_dir = ngb_dir + & - sys(ngbIndex(ngb))%dir(indSys2(izp2)) - END IF - END DO - END DO - IF (count2.GT.0) THEN - absPer = ABS(sys(ss)%tp(indSys1(izp))-ngb_tp/count2) - absDir = ABS(sys(ss)%dir(indSys1(izp))-ngb_dir/count2) - T = sys(ss)%tp(indSys1(izp)) - m1 = -3.645*T + 63.211 - m1 = MAX(m1,10.) - m2 = -0.346*T + 3.686 - m2 = MAX(m2,0.6) - deltaDirB = (m1*dx + dirKnob)*1. - deltaPerB = (m2*dx + perKnob)*1. - IF ( (absPer.LT.deltaPerB).AND. & - (absDir.LT.deltaDirB) ) THEN - ngbmatch(izp)=1. - END IF - END IF - END DO -! If >80% of neighbors fall within criteria, system is matched - IF ((SUM(ngbmatch(1:lsys))/lsys).GT.0.50) THEN - indMatch = ngbIndex(ngb) - matchSys = sys(indMatch)%sysInd - ELSE - CYCLE - END IF - ELSE -!061512--------------------------------- - - Tb = MAX(SUM(sys(ss)%tp(indSys1))/lsys, & - SUM(sys(ngbIndex(ngb))%tp(indSys2))/lsys2) -! deltaPerB = (-0.06*Tb+2+perKnob)*1.5 -! deltaDirB = (-Tb+(25+10*dirKnob))*1.5 -! deltaPerB = (-0.06*Tb+2+2)*1.5 -! deltaDirB = (-Tb+(25+10*2))*1.5 - dx=0.5*((wsdat%lon(2,1)-wsdat%lon(1,1)) + & - (wsdat%lat(1,2)-wsdat%lat(1,1))) - m1 = -3.523*Tb + 64.081 - m1 = MAX(m1,10.) - m2 = -0.337*Tb + 3.732 - m2 = MAX(m2,0.6) -!1stddev m1 = -2.219*Tb + 35.734 -!1stddev m1 = MAX(m1,5.) -!1stddev m2 = -0.226*Tb + 2.213 -!1stddev m2 = MAX(m2,0.35) -!5stddev m1 = -5.071*Tb + 90.688 -!5stddev m1 = MAX(m1,16.) -!5stddev m2 = -0.467*Tb + 5.161 -!5stddev m2 = MAX(m2,1.0) - deltaDirB = (m1*1. + dirKnob)*1. - deltaPerB = (m2*1. + perKnob)*1. - deltaHsB = 0.50*SUM(sys(ss)%hs(indSys1))/lsys -! deltaHsB = 0.25*SUM(sys(ss)%hs(indSys1))/lsys - -!051612 --- Land mask addition -! Option 1: If system centroid is near a land mask (e.g. 3 arc-deg), -! increase the tolerances - IF (ANY(MASK.EQ.1)) THEN - lonmean = SUM(sys(ss)%lon(indSys1))/lsys - latmean = SUM(sys(ss)%lat(indSys1))/lsys - DO j = 1,maxJ - DO i = 1,maxI - IF (MASK(i,j).EQ.1) THEN -! Land point found. Compute distance to system centroid - DIST = SQRT((lonmean-wsdat%lon(i,j))**2 +& - (latmean-wsdat%lat(i,j))**2) - IF (DIST.LT.3.) THEN -! System assumed to be influenced by land, -! increase tolerances to deltaDirB=30,deltaPerB=3 -! deltaDirB = (m1*1. + 30)*1. -! deltaPerB = (m2*1. + 3)*1. - deltaDirB = (m1*1. + 30)*1. - deltaPerB = (m2*1. + 3)*1. - !Remove dHs limitation from criteria - deltaHsB = 9999. - GOTO 500 - END IF - END IF - END DO - END DO - END IF - 500 CONTINUE -!051612 --- Land mask addition - - absHs = ABS( SUM(sys(ss)%hs(indSys1))/lsys - & - SUM(sys(ngbIndex(ngb))%hs(indSys2))/lsys2 ) - absPer = ABS( SUM(sys(ss)%tp(indSys1))/lsys - & - SUM(sys(ngbIndex(ngb))%tp(indSys2))/lsys2 ) - absDir = ABS( & - mean_angleV2(sys(ss)%dir(indSys1),lsys) - & - mean_angleV2(sys(ngbIndex(ngb))%dir(indSys2), & - lsys2) ) - IF (absDir.GT.180) absDir = 360.-absDir -! absWf = ABS( SUM(sys(ss)%wf(indSys1))/lsys - & -! SUM(sys(ngbIndex(ngb))%wf(indSys2))/lsys2 ) - - IF ( (absPer.LT.deltaPerB).AND. & - (absDir.LT.deltaDirB).AND. & - (absHs.LT.deltaHsB) ) THEN - indMatch = ngbIndex(ngb) - matchSys = sys(indMatch)%sysInd -!opt WRITE(20,*) '-> Matched sys',s, & -!opt 'with neighbor sys',matchSys - ELSE - CYCLE - END IF -!061512--------------------------------- - END IF -!061512--------------------------------- - - keep = 0 - keepInd(:) = 0 - - DO hh = 1, sys(ss)%nPoints - ii = sys(ss)%i(hh) - jj = sys(ss)%j(hh) - ind = 0 - ind = FINDFIRST(REAL(wsdat%par(ii,jj)%sys), & - SIZE(wsdat%par(ii,jj)%sys),REAL(s)) !Shouldn't REAL(s) be matchSys... - IF (ind.NE.0) THEN - wsdat%par(ii,jj)%sys(ind)=matchSys !...and matchSys be s, (i.e. add the matching neigbour to the base?) - END IF -! Remove the "-1" system from the set - ind2 = 1 - oneLess(:) = 9999 !Streamline this? - leng = LENGTH(REAL(wsdat%par(ii,jj)%sys), & - SIZE(wsdat%par(ii,jj)%sys),REAL(9999)) - DO ind = 1, leng - IF ( wsdat%par(ii,jj)%sys(ind).NE.-1 ) THEN - oneLess(ind2) = wsdat%par(ii,jj)%sys(ind) - ind2 = ind2+1 - END IF - END DO - ind2 = ind2-1 -! Combine any partitions assigned to the same systems -! Check for duplicates - IF (ind2.EQ.0) & - WRITE(20,*) '***2.Calling UNIQUE w. len=0!' - CALL UNIQUE(REAL(oneLess(1:ind2)),ind2, & - uniarr,outsize) - IF (ASSOCIATED(uniarr)) DEALLOCATE(uniarr) - IF (ind2.GT.outsize) THEN -! There is at least one duplicate, so combine systems - CALL combinePartitionsV2(wsdat%par(ii,jj)) -! Update the combined partitions values into the system we are keeping. -! Since partitions have been combined we don't know if the index is the same - replacedInd = & - FINDFIRST(REAL(wsdat%par(ii,jj)%sys(:)), & - SIZE(wsdat%par(ii,jj)%sys(:)), & - REAL(matchSys)) - hhForIndMatch = 1 - DO WHILE (hhForIndMatch.LE. & - sys(indMatch)%nPoints) - IF ( (sys(indMatch)%i(hhForIndMatch) & - .EQ.ii).AND. & - (sys(indMatch)%j(hhForIndMatch) & - .EQ.jj) ) EXIT - hhForIndMatch = hhForIndMatch + 1 - END DO - sys(indMatch)%hs(hhForIndMatch) = & - wsdat%par(ii,jj)%hs(replacedInd) - sys(indMatch)%tp(hhForIndMatch) = & - wsdat%par(ii,jj)%tp(replacedInd) - sys(indMatch)%dir(hhForIndMatch) = & - wsdat%par(ii,jj)%dir(replacedInd) - sys(indMatch)%dspr(hhForIndMatch) = & - wsdat%par(ii,jj)%dspr(replacedInd) -! sys(indMatch)%wf(hhForIndMatch) = & -! wsdat%par(ii,jj)%wf(replacedInd) - ELSE - keep = keep+1 - keepInd(keep) = hh - END IF - END DO - leng = LENGTH(REAL(sys(indMatch)%hs), & - SIZE(sys(indMatch)%hs),REAL(9999.)) - -! Update system info -! ------------------ -! First need to find which points were common to both systems => -! keepInd since that means partitions have not been combined for those -! points as a result of the combination of those 2 systems => -! distinct points -! keepInd = keepInd(1:keep) - lMatch = LENGTH(REAL(sys(indMatch)%hs), & - SIZE(sys(indMatch)%hs),REAL(9999.)) - tot = lMatch + keep - CALL UNION (REAL(sys(indMatch)%ngbr), & - SIZE(sys(indMatch)%ngbr), & - REAL(sys(ss)%ngbr), & - SIZE(sys(ss)%ngbr), & - allngbr,outsize) - CALL SETDIFF(allngbr,SIZE(allngbr), & - REAL((/sys(indMatch)%sysInd, & - sys(ss)%sysInd/)), & - SIZE((/sys(indMatch)%sysInd, & - sys(ss)%sysInd/)),difarr,outsize) - sys(indMatch)%ngbr(:) = 9999 - outsize = MIN(outsize,size(sys(indMatch)%ngbr)) - sys(indMatch)%ngbr(1:outsize) = NINT(difarr(1:outsize)) - IF (ASSOCIATED(allngbr)) DEALLOCATE(allngbr) - IF (ASSOCIATED(difarr)) DEALLOCATE(difarr) - - leng = LENGTH(REAL(sys(indMatch)%i), & - SIZE(sys(indMatch)%i),REAL(9999)) - sys(indMatch)%hsMean = SUM((/ & - sys(ss)%hs(keepInd(1:keep)), & - sys(indMatch)%hs(1:leng) /))/tot - sys(indMatch)%tpMean = SUM((/ & - sys(ss)%tp(keepInd(1:keep)), & - sys(indMatch)%tp(1:leng) /))/tot - sys(indMatch)%dirMean = & - mean_angleV2((/ sys(ss)%dir(keepInd(1:keep)), & - sys(indMatch)%dir(1:leng) /),tot) -!070512----------- Weight averages with Hm0 --------------------- - TEMP1 = 0. - TEMP2 = 0. - DO iii = 1,keep - TEMP1 = TEMP1 + (sys(ss)%hs(keepInd(iii))**2)*& - sys(ss)%hs(keepInd(iii)) - TEMP2 = TEMP2 + (sys(ss)%hs(keepInd(iii))**2)*& - sys(ss)%tp(keepInd(iii)) - END DO - DO iii = 1,leng - TEMP1 = TEMP1 + (sys(indMatch)%hs(iii)**2)*& - sys(indMatch)%hs(iii) - TEMP2 = TEMP2 + (sys(indMatch)%hs(iii)**2)*& - sys(indMatch)%tp(iii) - END DO - sys(indMatch)%hsMean = TEMP1/MAX(SUM((/ & - sys(ss)%hs(keepInd(1:keep))**2, & - sys(indMatch)%hs(1:leng)**2 /)),0.001) - sys(indMatch)%tpMean = TEMP2/MAX(SUM((/ & - sys(ss)%hs(keepInd(1:keep))**2, & - sys(indMatch)%hs(1:leng)**2 /)),0.001) - sys(indMatch)%dirMean = & - mean_angleV3((/ sys(ss)%dir(keepInd(1:keep)), & - sys(indMatch)%dir(1:leng) /), & - (/ sys(ss)%hs(keepInd(1:keep)), & - sys(indMatch)%hs(1:leng) /),tot) -!070512----------- Weight averages with Hm0 --------------------- - - sys(indMatch)%i(1:(keep+leng))= & - (/sys(ss)%i(keepInd(1:keep)), & - sys(indMatch)%i(1:leng)/) - sys(indMatch)%j(1:(keep+leng))= & - (/sys(ss)%j(keepInd(1:keep)), & - sys(indMatch)%j(1:leng)/) - sys(indMatch)%lat(1:(keep+leng)) = & - (/sys(ss)%lat(keepInd(1:keep)), & - sys(indMatch)%lat(1:leng)/) - sys(indMatch)%lon(1:(keep+leng)) = & - (/sys(ss)%lon(keepInd(1:keep)), & - sys(indMatch)%lon(1:leng)/) - sys(indMatch)%dir(1:(keep+leng)) = & - (/sys(ss)%dir(keepInd(1:keep)), & - sys(indMatch)%dir(1:leng)/) - sys(indMatch)%dspr(1:(keep+leng)) = & - (/sys(ss)%dspr(keepInd(1:keep)), & - sys(indMatch)%dspr(1:leng)/) -! sys(indMatch)%wf(1:(keep+leng)) = & -! (/sys(ss)%wf(keepInd(1:keep)), & -! sys(indMatch)%wf(1:leng)/) - sys(indMatch)%hs(1:(keep+leng)) = & - (/sys(ss)%hs(keepInd(1:keep)), & - sys(indMatch)%hs(1:leng)/) - sys(indMatch)%tp(1:(keep+leng)) = & - (/sys(ss)%tp(keepInd(1:keep)), & - sys(indMatch)%tp(1:leng)/) - sys(indMatch)%nPoints = & - LENGTH(REAL(sys(indMatch)%i), & - SIZE(sys(indMatch)%i),REAL(9999)) -! Clear array of system that has just been combined with another - sys(ss)%nPoints = 0 - sys(ss)%ngbr(:) = 9999 - WRITE(20,*) 'Deallocating sys',s - DEALLOCATE( sys(ss)%hs ) !opt - DEALLOCATE( sys(ss)%tp ) !opt - DEALLOCATE( sys(ss)%dir ) !opt - DEALLOCATE( sys(ss)%dspr ) !opt -! DEALLOCATE( sys(ss)%wf ) !opt - DEALLOCATE( sys(ss)%i ) !opt - DEALLOCATE( sys(ss)%j ) !opt - DEALLOCATE( sys(ss)%lat ) !opt - DEALLOCATE( sys(ss)%lon ) !opt -! DEALLOCATE( sys(ss)%hsMean ) !opt -! DEALLOCATE( sys(ss)%tpMean ) !opt -! DEALLOCATE( sys(ss)%dirMean ) !opt - -! Loop through wsdat to update neighbouring system values - DO i = 1, maxI - DO j = 1, maxJ - ind = FINDFIRST(REAL(wsdat%par(i,j)%ngbrSys), & - SIZE(wsdat%par(i,j)%ngbrSys),REAL(s)) - IF (ind.NE.0) THEN - wsdat%par(i,j)%ngbrSys(ind)=matchSys - END IF - leng = LENGTH(REAL(wsdat%par(i,j)%ngbrSys), & - SIZE(wsdat%par(i,j)%ngbrSys),REAL(9999)) - IF (leng.GT.0) THEN - CALL UNIQUE( & - REAL(wsdat%par(i,j)%ngbrSys(1:leng)), & - leng,uniarr,outsize) - wsdat%par(i,j)%ngbrSys(:) = 9999 - wsdat%par(i,j)%ngbrSys(1:outsize) = & - NINT(uniarr) - IF (ASSOCIATED(uniarr)) DEALLOCATE(uniarr) - ELSE - wsdat%par(i,j)%ngbrSys(:) = 9999 - END IF - END DO - END DO - -! Update neigbors in sys structure - DO nn = 1, maxSys - nbr = FINDFIRST(REAL(sys(nn)%ngbr), & - SIZE(sys(nn)%ngbr),REAL(s)) - IF (nbr.NE.0) THEN -! WRITE(20,*) 'update' - sys(nn)%ngbr(nbr)=matchSys - END IF - leng2 = LENGTH(REAL(sys(nn)%ngbr), & - SIZE(sys(nn)%ngbr),REAL(9999)) - IF (leng2.GT.0) THEN - CALL UNIQUE(REAL(sys(nn)%ngbr(1:leng2)), & - leng2,uniarr,outsize) - sys(nn)%ngbr(:) = 9999 - sys(nn)%ngbr(1:outsize) = NINT(uniarr) - IF (ASSOCIATED(uniarr)) DEALLOCATE(uniarr) -! WRITE(20,*) 'has now ngbr: ', & -! sys(nn)%ngbr(1:outsize) - END IF - END DO - EXIT - END IF + dirMinInd = tpMinInd + WRITE(20,*) 'System, GOFMinInd: ',j,tpMinInd + + IF (tpMinInd.NE.0) THEN + ! Success + !071212-----------GoF 2D------------- + + counter = counter+1 + sysA(i)%sys(j)%grp = & + sysMem(ind2(dirMinInd))%grp + alreadyUsed(counter) = sysA(i)%sys(j)%grp + + WRITE(20,*) 'Case 1: matched this ts (',i, & + ') sys ',sysA(i)%sys(j)%sysInd,' (tp=', & + sysA(i)%sys(j)%tpMean,' dir=', & + sysA(i)%sys(j)%dirMean,') with grp ', & + sysMem(ind2(dirMinInd))%grp + WRITE(20,*) 'Added ',alreadyUsed(counter), & + ' in array *alreadyUsed*' + ELSE + new = 1 + END IF + IF (new.EQ.1) THEN + used = 0 + DO k = 1, maxGroup + ok = 1 + WRITE(20,*) 'maxGroup,k,ok,used =', & + maxGroup,k,ok,used + ! Make sure it hasn't been used yet (at current time level) + IF ((i.GT.2).AND. & + (.NOT.ANY(alreadyUsed(:).EQ.k))) THEN + ! Make sure it hasn't been used yet (at previous time level) + DO l = 1, maxGroup + ! If last update of system was more that *6* time steps + ! ago, system can be released (TO CALIBRATE) + IF ( (sysMem(l)%grp.EQ.k).AND. & + ((i-sysMem(l)%updated).LT.6) ) ok = 0 + WRITE(20,*) 'l, ok = ',l,ok + END DO + IF (ok.EQ.1) THEN + sysA(i)%sys(j)%grp = k + counter = counter+1; + alreadyUsed(counter) = k + used = 1 + WRITE(20,*) 'k,used,counter =', & + k,used,counter + EXIT + END IF + END IF + END DO + IF (used.EQ.0) THEN + maxGroup = maxGroup+1 + sysA(i)%sys(j)%grp = maxGroup + ! Increase sysMem by one slot + sysMem(maxGroup)%grp = maxGroup + counter = counter+1 + alreadyUsed(counter) = maxGroup + END IF + WRITE(20,*) 'counter,maxGroup,sysA(i)%sys(j)%grp =',& + counter,maxGroup,sysA(i)%sys(j)%grp + WRITE(20,*) 'NO GRP MATCH case 2' + END IF - IF (ASSOCIATED(indSys1)) DEALLOCATE(indSys1) - IF (ASSOCIATED(indSys2)) DEALLOCATE(indSys2) + END DO + IF (ALLOCATED(ind)) DEALLOCATE(ind) !071212 Shifted + IF (ALLOCATED(ind2)) DEALLOCATE(ind2) !071212 Shifted + IF (ALLOCATED(GOFMinVal)) DEALLOCATE(GOFMinVal) + IF (ALLOCATED(GOFMinInd)) DEALLOCATE(GOFMinInd) + + IF (ALLOCATED(alreadyUsed)) DEALLOCATE(alreadyUsed) + IF (ALLOCATED(allInd)) DEALLOCATE(allInd) + + ! Update sysMem + DO k = 1, maxGroup + DO kk = 1, maxSys(i) + IF (sysA(i)%sys(kk)%grp.EQ.sysMem(k)%grp) THEN + sysMem(k)%nPoints = sysA(i)%sys(kk)%nPoints + sysMem(k)%lonMean = & + SUM(sysA(i)%sys(kk)%lon(1:sysMem(k)%nPoints))/& + sysMem(k)%nPoints + sysMem(k)%latMean = & + SUM(sysA(i)%sys(kk)%lat(1:sysMem(k)%nPoints))/& + sysMem(k)%nPoints + !070512----------- Weight averages with Hm0 --------------------- + TEMP1 = 0. + TEMP2 = 0. + DO iii = 1,sysMem(k)%nPoints + TEMP1 = TEMP1 + & + (sysA(i)%sys(kk)%hs(iii)**2)*sysA(i)%sys(kk)%lon(iii) + TEMP2 = TEMP2 + & + (sysA(i)%sys(kk)%hs(iii)**2)*sysA(i)%sys(kk)%lat(iii) + END DO + sysMem(k)%lonMean = TEMP1/& + MAX(SUM(sysA(i)%sys(kk)%hs(1:sysMem(k)%nPoints)**2),& + 0.001) + sysMem(k)%latMean = TEMP2/& + MAX(SUM(sysA(i)%sys(kk)%hs(1:sysMem(k)%nPoints)**2),& + 0.001) + !070512----------- Weight averages with Hm0 --------------------- + sysMem(k)%tpMean = sysA(i)%sys(kk)%tpMean + sysMem(k)%dirMean = sysA(i)%sys(kk)%dirMean + !071012----------- Grid point indexing -------------------------- + sysMem(k)%indx(:) = 9999 + DO iii = 1,sysMem(k)%nPoints + sysMem(k)%indx(iii) = & + (sysA(i)%sys(kk)%j(iii)-1)*maxI + & + sysA(i)%sys(kk)%i(iii) END DO + !071012----------- Grid point indexing -------------------------- + sysMem(k)%updated = i + sysMem(k)%length = sysMem(k)%length + 1 + END IF + END DO + !Test for expired groups + IF ((i-sysMem(k)%updated).GE.6) THEN + sysMem(k)%nPoints = 0 + sysMem(k)%lonMean = 9999. + sysMem(k)%latMean = 9999. + sysMem(k)%tpMean = 9999. + sysMem(k)%dirMean = 9999. + sysMem(k)%indx(:) = 9999 + sysMem(k)%updated = -9999 + sysMem(k)%length = 0 END IF + END DO + !083012 !Filter out duplicates groups that can develop + DO l = 1, maxGroup + DO ll = (l+1), maxGroup + + deltaDir = MAX((-3.645*sysMem(l)%tpMean+63.211),10.)*1. + deltaPer = MAX((-0.346*sysMem(l)%tpMean+3.686),0.6)*1. + + IF ( (ABS(sysMem(l)%tpMean-sysMem(ll)%tpMean).LT.& + deltaPer).AND. & + (ABS(sysMem(l)%dirMean-sysMem(ll)%dirMean).LT.& + deltaDir).AND. & + (sysMem(l)%updated.NE.sysMem(ll)%updated).AND. & + (sysMem(ll)%nPoints.NE.0) ) THEN + !Find the more recent entry, and delete from group + IF (sysMem(ll)%length.LT.sysMem(l)%length) THEN + idup = ll + WRITE(20,*) 'Deleting memgroup ',ll, & + '(updated',sysMem(ll)%updated,', length', & + sysMem(ll)%length,'), duplicate of memgroup', & + l,'(updated',sysMem(l)%updated,', length', & + sysMem(l)%length,'):' + ELSE + idup = l + WRITE(20,*) 'Deleting memgroup ',l, & + '(updated',sysMem(l)%updated,', length', & + sysMem(l)%length,'), duplicate of memgroup', & + ll,'(updated',sysMem(ll)%updated,', length', & + sysMem(ll)%length,'):' + END IF + WRITE(20,*) 'deltaPer, diff Per:',deltaPer,& + ABS(sysMem(l)%tpMean-sysMem(ll)%tpMean) + WRITE(20,*) 'deltaDir, diff Dir:',deltaDir,& + ABS(sysMem(l)%dirMean-sysMem(ll)%dirMean) + sysMem(idup)%nPoints = 0 + sysMem(idup)%lonMean = 9999. + sysMem(idup)%latMean = 9999. + sysMem(idup)%tpMean = 9999. + sysMem(idup)%dirMean = 9999. + sysMem(idup)%indx(:) = 9999 + sysMem(idup)%updated = -9999 + sysMem(idup)%length = 0 + END IF + END DO + END DO + ELSE + WRITE(20,*) '*** No systems at this time level. ', & + 'No. systems =',SIZE(sysA(i)%sys) + !Test for expired groups + DO k = 1, maxGroup + IF ((i-sysMem(k)%updated).GE.6) THEN + sysMem(k)%nPoints = 0 + sysMem(k)%lonMean = 9999. + sysMem(k)%latMean = 9999. + sysMem(k)%tpMean = 9999. + sysMem(k)%dirMean = 9999. + sysMem(k)%indx(:) = 9999 + sysMem(k)%updated = -9999 + sysMem(k)%length = 0 + END IF + END DO + END IF + ! ******** Test output *********************** + DO k = 1, maxGroup + WRITE(20,*) 'sysMem(',k,')%grp =',sysMem(k)%grp + WRITE(20,*) 'sysMem(',k,')%nPoints =',sysMem(k)%nPoints + WRITE(20,*) 'sysMem(',k,')%lonMean =',sysMem(k)%lonMean + WRITE(20,*) 'sysMem(',k,')%latMean =',sysMem(k)%latMean + WRITE(20,*) 'sysMem(',k,')%tpMean =',sysMem(k)%tpMean + WRITE(20,*) 'sysMem(',k,')%dirMean =',sysMem(k)%dirMean + WRITE(20,*) 'sysMem(',k,')%updated =',sysMem(k)%updated + WRITE(20,*) 'sysMem(',k,')%length =',sysMem(k)%length END DO + ! ******************************************** + END DO - IF (ALLOCATED(sysOrdered)) DEALLOCATE(sysOrdered) - IF (ALLOCATED(sysSortedInd)) DEALLOCATE(sysSortedInd) - IF (ALLOCATED(sysOut)) DEALLOCATE(sysOut) - -! Compile array index of active systems in sys - actSys = 0 - DO ic = 1,maxSys - IF (sys(ic)%nPoints>0) actSys = actSys + 1 + ! Write hotfile of wave groups + OPEN(unit=27,file='sys_restart1.ww3',status='unknown') + WRITE(27,'(A23,I10)') 'maxGroup =',maxGroup + DO k = 1, maxGroup + WRITE(27,'(A8,I3,A12,I10)') 'sysMem( ',k, & + ' )%grp =',sysMem(k)%grp + WRITE(27,'(A8,I3,A12,I10)') 'sysMem( ',k, & + ' )%nPoints =',sysMem(k)%nPoints + WRITE(27,'(A8,I3,A12,F10.4)') 'sysMem( ',k, & + ' )%lonMean =',sysMem(k)%lonMean + WRITE(27,'(A8,I3,A12,F10.4)') 'sysMem( ',k, & + ' )%latMean =',sysMem(k)%latMean + WRITE(27,'(A8,I3,A12,F10.3)') 'sysMem( ',k, & + ' )%tpMean =',sysMem(k)%tpMean + WRITE(27,'(A8,I3,A12,F10.3)') 'sysMem( ',k, & + ' )%dirMean =',sysMem(k)%dirMean + WRITE(27,'(A8,I3,A12,I10)') 'sysMem( ',k, & + ' )%updated =',sysMem(k)%updated + WRITE(27,'(A8,I3,A12,I10)') 'sysMem( ',k, & + ' )%length =',sysMem(k)%length + DO j = maxJ,1,-1 + DO i = 1,maxI + WRITE(27,'(I8)',ADVANCE='NO') sysMem(k)%indx((j-1)*maxI+i) + END DO + WRITE(27,'(A)',ADVANCE='YES') '' END DO - IF (ALLOCATED(actSysInd)) DEALLOCATE(actSysInd) - ALLOCATE( actSysInd(actSys) ) - actSys = 0 - DO ic = 1,maxSys - IF (sys(ic)%nPoints>0) THEN - actSys = actSys + 1 - actSysInd(actSys) = sys(ic)%sysInd - END IF + END DO + CLOSE(27) + +2000 CONTINUE + RETURN + END SUBROUTINE timeTrackingV2 + !/ End of timeTrackingV2 --------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE findWay (way ,horizStepCount,vertStepCount , & + vertBorder ,horizBorder ,stepCount ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! From the direction (way) we were going before, find which direction we + ! are going now and how many 'steps' we need to take + ! + ! 2. Method + ! + ! - + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! way Char in/out Direction of spiral search + ! vertBorder Int input + ! horizBorder Int input + ! stepCount Int output Number of steps to go in the selected direction (way) + ! + CHARACTER :: way *1 + INTEGER :: horizStepCount, vertStepCount, & + vertBorder, horizBorder, stepCount + + INTENT (IN) vertBorder, horizBorder + INTENT (OUT) stepCount + INTENT (IN OUT) way + ! + ! Local variables + ! ---------------------------------------------------------------- + ! - + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! - + ! + ! 5. Subroutines calling + ! + ! spiralTrackV3 + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See above + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + SELECT CASE (way) + CASE ('R') + way='D' + vertStepCount=vertStepCount+1 + IF (horizBorder.EQ.1) THEN + horizStepCount=horizStepCount-1 + END IF + stepCount=vertStepCount + CASE ('D') + way='L' + horizStepCount=horizStepCount+1 + IF (vertBorder.EQ.1) THEN + vertStepCount=vertStepCount-1 + END IF + stepCount=horizStepCount + CASE ('L') + way='U' + vertStepCount=vertStepCount+1 + IF (horizBorder.EQ.1) THEN + horizStepCount=horizStepCount-1 + END IF + stepCount=vertStepCount + CASE ('U') + way='R' + horizStepCount=horizStepCount+1 + IF (vertBorder.EQ.1) THEN + vertStepCount=vertStepCount-1 + END IF + stepCount=horizStepCount + CASE DEFAULT + WRITE(20,*) 'In spaTack:findWay should NOT go here!' + END SELECT + + RETURN + END SUBROUTINE findWay + !/ End of findWay ---------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE findNext (i ,j ,maxI ,maxJ , & + way ,vertBorder ,horizBorder ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Find next point on spatial search spiral + ! + ! 2. Method + ! + ! - + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! i,j Int in/out Current grid indices + ! maxI, maxJ Int input Maximum indices of wave field + ! way Char input Direction of spiral search + ! vertBorder Int output Flag indicating that vert domain edge has been hit + ! horizBorder Int output Flag indicating that hor domain edge has been hit + ! + CHARACTER :: way + INTEGER :: i, j, maxI, maxJ, vertBorder, horizBorder + + INTENT (IN) maxI, maxJ, way + INTENT (IN OUT) i, j + INTENT (OUT) vertBorder, horizBorder + ! + ! Local variables + ! ---------------------------------------------------------------- + ! - + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! - + ! + ! 5. Subroutines calling + ! + ! spiralTrackV3 + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + vertBorder=0 + horizBorder=0 + SELECT CASE (way) + CASE ('R') + IF (i.LT.maxI) THEN + i=i+1 + ELSE + ! Need to tell findWay that if we hit the border we don't + ! increment stepCount... + horizBorder=1 + END IF + CASE ('D') + IF (j.GT.1) THEN + j=j-1 + ELSE + vertBorder=1 + END IF + CASE ('L') + IF (i.GT.1) THEN + i=i-1 + ELSE + horizBorder=1 + END IF + CASE ('U') + IF (j.LT.maxJ) THEN + j=j+1 + ELSE + vertBorder=1 + END IF + END SELECT + + RETURN + END SUBROUTINE findNext + !/ End of findNext --------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE findSys (i ,j ,wsdat ,maxSys , & + ngbrExt ,maxI ,maxJ ,perKnob , & + dirKnob ,hsKnob ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Find all wave systems that neighbour the grid point (i,j), and + ! match these with the systems at (i,j). + ! + ! 2. Method + ! + ! For the given point (i,j), find all wave systems at neighbouring grid + ! points within the reach specified by ngbrExt. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! i,j Int input Current grid indices + ! maxI, maxJ Int input Maximum indices of wave field + ! wsdat Type(dat2d) in/out Input data structure to be spiral tracked + ! maxSys Int in/out Maximum number of systems identified + ! + TYPE(dat2d) :: wsdat + INTEGER :: i, j, maxI, maxJ, ngbrExt, maxSys + REAL :: perKnob ,dirKnob, hsKnob + + INTENT (IN) i, j, maxI, maxJ, ngbrExt, perKnob ,dirKnob + INTENT (IN OUT) wsdat, maxSys + ! + ! Local variables + ! ---------------------------------------------------------------- + ! tmpsys TYPE(system) Temporary instance of the wave system variable + ! nngbr Int Number of neighbours found + ! + TYPE(system), ALLOCATABLE :: tmpsys(:) + TYPE(neighbr) :: ngbr(50) + TYPE(mtchsys) :: match + LOGICAL :: found + INTEGER :: counter, ii, jj, nngbr, startCount, endCount, l,& + nout, maxS, s, p, n, countAll, ind, minInd, & + npart, pp, leng + INTEGER :: allFullSys(50) + REAL, POINTER :: realarr(:) + INTEGER, ALLOCATABLE :: allSys(:) + REAL :: hsAll(50),tpAll(50),dirAll(50),GOF(50) + REAL :: absDir,absPer,absHs,T,& + deltaPer,deltaDir,deltaHs,temp + REAL :: dx, m1, m2 + REAL :: GOFMinVal + INTEGER :: GOFMinInd + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! UNIQUE + ! combinePartitionsV2 + ! + ! 5. Subroutines calling + ! + ! spiralTrackV3 + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + NULLIFY(realarr) + ! WRITE(20,*) 'findSys: i,j,maxSys =',i,j,maxSys + + ! First find the checked neighbor + counter=1 + DO ii=(i-ngbrExt), (i+ngbrExt) + DO jj=(j-ngbrExt), (j+ngbrExt) + IF ( (ii.GT.0).AND.(jj.GT.0).AND. & + (jj.LE.maxJ).AND.(ii.LE.maxI) ) THEN + IF ( wsdat%par(ii,jj)%checked.EQ.1 ) THEN + ngbr(counter)%par = wsdat%par(ii,jj) !Added the par field to maintain the data structure + ngbr(counter)%i = ii + ngbr(counter)%j = jj + counter=counter+1 + END IF + END IF END DO - -!opt WRITE(20,*) 'actSys =',actSys -!opt WRITE(20,*) 'actSysInd =',actSysInd -!opt DO ic = 1,SIZE(actSysInd) -!opt s = actSysInd(ic) -!opt WRITE(20,*) 'sys(',s,')%sysInd =',sys(s)%sysInd -!opt END DO - WRITE(20,*) 'Leaving combineSys...' - - RETURN - END SUBROUTINE combineSys -!/ End of combineSys ------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE combinePartitionsV2 (dat) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Combine two partitions that have been assigned to the same system -! -! 2. Method -! -! Of all the partitions associated with a certain common system, -! add all the Hs values to the partition with the largest Hs, -! and delete the rest. NOTE that the tp and dir values of this -! maximum partition is not adjusted! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! dat TYPE(param) in/out Input data structure (partitions set) -! to combine -! - TYPE(param) :: dat - - INTENT (IN OUT) dat -! -! Local variables -! ---------------------------------------------------------------- - TYPE duplicate - INTEGER :: val - INTEGER :: ndup - INTEGER :: ind(50) - END TYPE duplicate - - TYPE(duplicate) :: dup(100) !40.PAR - LOGICAL :: found - INTEGER :: nsys, ndup, p, pp, maxInd, npart, s, ss, ppp - REAL :: temp -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! - -! -! 5. Subroutines calling -! -! findSys -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -! Find indices in dat%sys(:) of all partition associated with -! the same wave system, and store them in the data structure -! dup(1:nsys). Here nsys is the number of systems for which duplicates -! were found, and dup(s)%ndup the number of partitions assigned -! to the same system s. - nsys = 0 - dup(:)%ndup = 0 - dup(:)%val = 9999 - DO s = 1,100 - dup(s)%ind(:) = 0 + END DO + ! New variable nngbr + nngbr=counter-1 + + IF (nngbr.GT.0) THEN + allFullSys(:) = 0 + startCount=1 + l=1 + DO WHILE (l.LE.nngbr) + leng = LENGTH(REAL(ngbr(l)%par%sys), & + SIZE(ngbr(l)%par%sys),REAL(9999)) + endCount = startCount+leng-1 + allFullSys(startCount:endCount) = ngbr(l)%par%sys(1:leng) + startCount=endCount+1 + l=l+1 END DO - npart = LENGTH(REAL(dat%ipart),SIZE(dat%ipart),REAL(0)) - DO p = 1, npart-1 - found = .FALSE. - IF (ANY(dat%sys(p).EQ.dup(:)%val)) CYCLE !found = .TRUE. - DO pp = (p+1), npart - IF (dat%sys(p).EQ.dat%sys(pp)) THEN -! First value - IF (.NOT.found) THEN - nsys=nsys+1 - dup(nsys)%val = dat%sys(p) - dup(nsys)%ndup = 1 - dup(nsys)%ind(dup(nsys)%ndup) = p - found = .TRUE. - END IF -! Subsequent duplicates - IF (.NOT.ANY(pp.EQ.dup(nsys)%ind(:))) THEN - dup(nsys)%ndup = dup(nsys)%ndup+1 - dup(nsys)%ind(dup(nsys)%ndup) = pp - END IF - END IF - END DO - END DO + IF (endCount.EQ.0) WRITE(20,*) '***1.Calling UNIQUE w. len=0!' + CALL UNIQUE (REAL(allFullSys),endCount,realarr,nout) !Can one do this? + ALLOCATE(allSys(nout)) + allSys = INT(realarr) !Can one do this? + IF (ASSOCIATED(realarr)) DEALLOCATE(realarr) + maxS = MAXVAL(allSys) -! Now go through array of duplicates for each of n systems -! to add all the wave energy to the most energetic of the -! duplicates, and then remove the rest. - maxInd = 0 - temp = -9999. - DO s = 1, nsys -! Find duplicate partition with the largest Hs (most energy) - DO p = 1, dup(s)%ndup - IF ( temp.LT.dat%hs(dup(s)%ind(p)) ) THEN - temp = dat%hs(dup(s)%ind(p)) - maxInd = p - END IF - END DO - -! Add all energy (Hs) to this partition - dat%hs(dup(s)%ind(maxInd)) = & - SQRT( SUM(dat%hs(dup(s)%ind(1:dup(s)%ndup))**2) ) - -! Remove duplicate partitions which did not have the maximum Hs, -! and shift up indices to fill the gap - DO p = 1, dup(s)%ndup -! Find index to remove - IF (p.NE.maxInd) THEN -! Shift up entries, deleting the duplicate partition -! REPLACE WITH CSHIFT(ARRAY, SHIFT, dim) ? - dat%hs( dup(s)%ind(p):(npart-1) ) = & - dat%hs( (dup(s)%ind(p)+1):npart) - dat%tp( dup(s)%ind(p):(npart-1) ) = & - dat%tp( (dup(s)%ind(p)+1):npart) - dat%dir( dup(s)%ind(p):(npart-1) ) = & - dat%dir( (dup(s)%ind(p)+1):npart) - dat%dspr( dup(s)%ind(p):(npart-1) ) = & - dat%dspr( (dup(s)%ind(p)+1):npart) -! dat%wf( dup(s)%ind(p):(npart-1) ) = & -! dat%wf( (dup(s)%ind(p)+1):npart) - dat%sys( dup(s)%ind(p):(npart-1) ) = & - dat%sys( (dup(s)%ind(p)+1):npart) - dat%ipart( dup(s)%ind(p):(npart-1) ) = & - dat%ipart( (dup(s)%ind(p)+1):npart) -! Shift up indices - DO ss = 1, nsys - DO ppp = 1, dup(ss)%ndup - IF (dup(ss)%ind(ppp).GT.dup(s)%ind(p)) & - dup(ss)%ind(ppp) = dup(ss)%ind(ppp)-1 - END DO - END DO -! Add blank to end - dat%hs(npart) = 9999. - dat%tp(npart) = 9999. - dat%dir(npart) = 9999. - dat%dspr(npart) = 9999. -! dat%wf(npart) = 9999. - dat%sys(npart) = 9999 - dat%ipart(npart) = 0 + IF (maxSys.LT.maxS) THEN + maxSys=maxS + END IF + ! Initiate sys num + ALLOCATE( tmpsys(SIZE(allSys)) ) + ! Clear the wsdat%par(i,j)%sys field, new values assigned below. + ! System info temporarily stored in allSys + wsdat%par(i,j)%sys(1:10) = 9999 + + DO s=1, SIZE(allSys) + hsAll(:) = 0. + tpAll(:) = 0. + dirAll(:) = 0. + ! wfAll(:) = 0. + n=1 + countAll=0 + DO WHILE (n.LE.nngbr) + ! Calculate mean of common neighbor wave system + ! for every neigbor wave system + found = .FALSE. + DO ind = 1, SIZE(ngbr(n)%par%sys) !Optimize this? + IF ( ngbr(n)%par%sys(ind).EQ.allSys(s) ) THEN !Put sys under par to maintain structure + found = .TRUE. + EXIT END IF - END DO - END DO - - RETURN - END SUBROUTINE combinePartitionsV2 -!/ End of combinePartitionsV2 ---------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - REAL FUNCTION mean_angleV2(ang,ll) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Compute the mean direction from array of directions -! -! 2. Method -! -! ang is a column vector of angles -! m_ang is the mean from a unit-vector average of ang -! Assumes clockwise rotation from North = 0. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ang Real input Array of angles to average -! ll Int input Length of ang -! - REAL :: ang(ll) - INTEGER :: ll -! -! Local variables -! ---------------------------------------------------------------- -! u,v Real Arrays of u,v dir components to average -! um,vm Real Mean u,v dir components -! theta Real Mean direction relative to North -! - REAL :: PI - PARAMETER (PI = 3.1416) - REAL :: u(ll), v(ll), vm, um, theta -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! - -! -! 5. Subroutines calling -! -! findSys -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -! North and East components - v(:) = COS(ang(:)*(PI/180.)) - u(:) = SIN(ang(:)*(PI/180.)) - vm = SUM(v)/ll - um = SUM(u)/ll - -! Compute mean magnitude and direction relative to North (from Upolar.m) - theta = (ATAN2(um,vm))*(180/PI) - -! Convert inputs to radians, the to the -pi to pi range -! (incorporated from original function xunwrapV2.m) - -! Convert to radians - theta = theta*(PI/180) - - theta = PI*((ABS(theta)/PI) - & - 2*CEILING(((ABS(theta)/PI)-1)/2))*SIGN(1.,theta) - -! Shift the points in the -pi to 0 range to the pi to 2pi range - IF (theta.LT.0.) theta = theta + 2*PI - -! Convert back to degrees and return value - mean_angleV2 = theta*(180/PI) - - RETURN - END FUNCTION mean_angleV2 -!/ End of mean_angleV2 ----------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - REAL FUNCTION mean_angleV3(ang,hsign,ll) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Compute the mean direction from array of directions, -! INCLUDING WEIGHTING WITH HMO -! -! 2. Method -! -! ang is a column vector of angles -! m_ang is the mean from a unit-vector average of ang -! Assumes clockwise rotation from North = 0. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ang Real input Array of angles to average -! ll Int input Length of ang -! - REAL :: ang(ll), hsign(ll) - REAL :: TEMP1, TEMP2 - INTEGER :: ll -! -! Local variables -! ---------------------------------------------------------------- -! u,v Real Arrays of u,v dir components to average -! um,vm Real Mean u,v dir components -! theta Real Mean direction relative to North -! - REAL :: PI - PARAMETER (PI = 3.1416) - REAL :: u(ll), v(ll), vm, um, theta - INTEGER :: i -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! - -! -! 5. Subroutines calling -! -! findSys -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + END DO -! North and East components - v(:) = COS(ang(:)*(PI/180.)) - u(:) = SIN(ang(:)*(PI/180.)) - TEMP1 = 0. - TEMP2 = 0. - DO i = 1,ll - TEMP1 = TEMP1 + (hsign(i)**2)*v(i) - TEMP2 = TEMP2 + (hsign(i)**2)*u(i) + IF (found) THEN + countAll=countAll+1 + hsAll(countAll)=ngbr(n)%par%hs(ind) + tpAll(countAll)=ngbr(n)%par%tp(ind) + dirAll(countAll)=ngbr(n)%par%dir(ind) + ! wfAll(countAll)=ngbr(n)%par%wf(ind) + ELSE + n=n+1 + CYCLE + END IF + n=n+1 + END DO + tmpsys(s)%hsMean = SUM(hsAll(1:countAll))/countAll + tmpsys(s)%tpMean = SUM(tpAll(1:countAll))/countAll + tmpsys(s)%dirMean = & + mean_angleV2(dirAll(1:countAll),countAll) + ! tmpsys(s)%wfMean = SUM(wfAll(1:countAll))/countAll END DO - vm = TEMP1/MAX(SUM(hsign**2),0.001) - um = TEMP2/MAX(SUM(hsign**2),0.001) - -! Compute mean magnitude and direction relative to North (from Upolar.m) - theta = (ATAN2(um,vm))*(180/PI) - -! Convert inputs to radians, the to the -pi to pi range -! (incorporated from original function xunwrapV2.m) - -! Convert to radians - theta = theta*(PI/180) - - theta = PI*((ABS(theta)/PI) - & - 2*CEILING(((ABS(theta)/PI)-1)/2))*SIGN(1.,theta) - -! Shift the points in the -pi to 0 range to the pi to 2pi range - IF (theta.LT.0.) theta = theta + 2*PI -! Convert back to degrees and return value - mean_angleV3 = theta*(180/PI) + ! Find the partition at current (i,j) point that matches previously + ! identified wave systems if any... + wsdat%par(i,j)%ngbrSys(1:SIZE(allSys)) = allSys - RETURN - END FUNCTION mean_angleV3 -!/ End of mean_angleV3 ----------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE UNIQUE (INARRAY,INSIZE,OUTARRAY,OUTSIZE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 22-Dec-2016 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ 12-Dec-2016 : Change algorithm from N*N to N*log(N) -!/ (S. Zieger BoM Australia) ( version 5.16 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Returns the sorted elements that are unique in INARRAY. -! -! 2. Method -! -! 1. Sort input array with quicksort -! 2. Copy sequential-elements if the 'current' element -! is not equal to the 'previous' element in array. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INARRAY REAL ARR input Input array -! INSIZE INTEGER input Size of input array -! OUTARRAY REAL ARR output Output array (sorted) -! OUTSIZE INTEGER output Size of output array (number of unique elements) -! - INTEGER, INTENT(IN) :: INSIZE - INTEGER, INTENT(OUT) :: OUTSIZE - REAL, INTENT(IN) :: INARRAY(INSIZE) - REAL, POINTER :: OUTARRAY(:) -! -! Local variables -! ---------------------------------------------------------------- - INTEGER :: I, K - REAL :: ARRAY(INSIZE), TEMP(INSIZE) -! -! 4. Subroutines used : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! QSORT Subr. Private Quicksort algorithm -! -! 5. Subroutines calling -! -! waveTracking_NWS_V2 -! findSys -! printFinalSys -! combineSys -! findIJV4 -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - K = 1 + npart = LENGTH(REAL(wsdat%par(i,j)%ipart), & + SIZE(wsdat%par(i,j)%ipart),REAL(0)) + DO p = 1, npart + IF ( (wsdat%par(i,j)%hs(p).LT.hsKnob).OR. & + (wsdat%par(i,j)%tp(p).EQ.0.) ) THEN + wsdat%par(i,j)%sys(p)=-1 + CYCLE + END IF - IF ( INSIZE.EQ.0 ) THEN - WRITE(20,*) '*** In Subr. UNIQUE: Input array has length=0!' - ELSE -!/ --- Setup input arrays and temporary arrays. --- - DO I=1,INSIZE - ARRAY(I) = INARRAY(I) - TEMP(I) = REAL(I) - END DO -!/ -!/ --- Sort input arrays (use temporary array to store indices). --- - CALL QSORT(ARRAY,TEMP,1,INSIZE) -!/ -!/ --- Reset temporary array. --- - TEMP(:) = 9999. -!/ -!/ --- Initialise first values and array index. --- - K = 1 - TEMP(K) = ARRAY(K) - K = K + 1 -!/ --- Iterate over elements in array. --- - DO I=2,INSIZE -!/ --- Compare sequential array values ('previous' less than 'next') -!/ and test against the last list element check in. --- - IF ( ARRAY(I).GT.ARRAY(I-1) .AND. & - ARRAY(I).GT.TEMP(K-1) ) THEN - TEMP(K) = ARRAY(I) - K = K + 1 + ind=0 !Replaced 'index' by 'ind' + match%sysVal(:) = 9999 + match%tpVal(:) = 9999. + match%dirVal(:) = 9999. + ! match%wfVal(:) = 9999. + ! Cycle through the neighbouring systems identified above + DO s=1,SIZE(allSys) + absHs = ABS(wsdat%par(i,j)%hs(p)-tmpsys(s)%hsMean) + absPer = ABS(wsdat%par(i,j)%tp(p)-tmpsys(s)%tpMean) + absDir = ABS(wsdat%par(i,j)%dir(p)-tmpsys(s)%dirMean) + ! absWf = ABS(wsdat%par(i,j)%wf(p)-tmpsys(s)%wfMean) + IF (absDir.GT.180) THEN + absDir = 360 - absDir + IF (absDir.LT.0) THEN + WRITE(20,*) '*** WARNING: absDir negative!' + WRITE(20,*) 'wsdat%par(i,j)%dir(p) =', & + wsdat%par(i,j)%dir(p) + WRITE(20,*) 'tmpsys(s)%dirMean) =', & + tmpsys(s)%dirMean + END IF + END IF + ! Calculate delta dir and freq as a function of the partition + ! dir and freq + T = tmpsys(s)%tpMean + dx = 0.5*( (wsdat%lon(2,1)-wsdat%lon(1,1)) + & + (wsdat%lat(1,2)-wsdat%lat(1,1)) ) + m1 = -3.645*T + 63.211 + m1 = MAX(m1,10.) + m2 = -0.346*T + 3.686 + m2 = MAX(m2,0.6) + !1stddev m1 = -2.219*T + 35.734 + !1stddev m1 = MAX(m1,5.) + !1stddev m2 = -0.226*T + 2.213 + !1stddev m2 = MAX(m2,0.35) + !5stddev m1 = -5.071*T + 90.688 + !5stddev m1 = MAX(m1,16.) + !5stddev m2 = -0.467*T + 5.161 + !5stddev m2 = MAX(m2,1.0) + deltaDir = m1*dx + dirKnob + deltaPer = m2*dx + perKnob + deltaHs = 0.25*tmpsys(s)%hsMean + IF ((absPer.LT.deltaPer).AND.(absDir.LT.deltaDir)) THEN + ind=ind+1 + match%sysVal(ind) = allSys(s) + match%tpVal(ind) = absPer + match%dirVal(ind) = absDir + match%hsVal(ind) = absHs + ! match%wfVal(ind) = absWf END IF END DO -!/ --- Allocate output array --- - OUTSIZE = K - 1 - ALLOCATE(OUTARRAY(OUTSIZE)) -!/ --- Transfer output from temporary array to output array. --- - IF ( OUTSIZE.GE.1 ) THEN - DO I=1,OUTSIZE - OUTARRAY(I) = TEMP(I) - END DO + IF (ind.GT.0) THEN + IF (ind.EQ.1) THEN + wsdat%par(i,j)%sys(p) = match%sysVal(1) + ELSE + ! Take the closest match, using GoF function + GOF(:) = 9999. + GOF(1:ind) = (match%tpVal(1:ind)/deltaPer)**2 + & + (match%dirVal(1:ind)/deltaDir)**2 + & + (match%hsVal(1:ind)/deltaHs)**2 + GOFMinVal = MINVAL(GOF(1:ind)) + GOFMinInd = FINDFIRST(GOF(1:ind),ind,GOFMinVal) + wsdat%par(i,j)%sys(p) = match%sysVal(GOFMinInd) !The index of the system is swapped - the remaining info stays the same! + END IF END IF - END IF -!/ - RETURN -!/ - END SUBROUTINE UNIQUE -!/ End of UNIQUE ----------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE SORT (INARRAY,INSIZE,OUTARRAY,IY,DIRECTION) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 20-Dec-2016 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ 20-Dec-2016 : Add quicksort algorithm (S. Zieger) ( version 5.16 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Sorts the array INARRAY in ascending (Direction = 'A') or -! descending (Direciton = 'D') order. The sorted array is -! stored in OUTARRAY, and the sorted array of the original -! indices is stored in IY. -! -! 2. Method -! -! Sort algorithm based on quicksort. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INARRAY REAL ARR input Input array -! INSIZE INTEGER input Size of input array -! OUTARRAY REAL ARR output Sorted output array -! IY INTEGER ARR output Sorted array of the original indices - - CHARACTER :: DIRECTION *1 - INTEGER :: INSIZE - INTEGER :: IY(INSIZE) - REAL :: INARRAY(INSIZE), OUTARRAY(INSIZE) - - INTENT (IN) INARRAY, INSIZE, DIRECTION - INTENT (OUT) OUTARRAY, IY -! -! Local variables -! ---------------------------------------------------------------- -! INARRAY - array of values to be sorted -! IY - array to be carried with X (all swaps of X elements are ??? EDIT! -! matched in IY . After the sort IY(J) contains the original -! postition of the value X(J) in the unsorted X array. -! N - number of values in array X to be sorted - - INTEGER :: I - REAL :: IND(INSIZE) -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! - -! -! 5. Subroutines calling -! -! printFinalSys -! combineSys -! timeTrackingV2 -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - -! Sort OUTARRAY in as/decending order - - IF (INSIZE.EQ.0) THEN - WRITE(20,*) '*** In Subr. SORT: Input array has length=0 !!!' - ELSE - - DO I = 1, INSIZE - OUTARRAY(I) = INARRAY(I) - IND(I) = REAL(I) - END DO - - IF (DIRECTION .EQ. 'A') THEN - CALL QSORT(OUTARRAY,IND,1,INSIZE) - ELSE IF (DIRECTION .EQ. 'D') THEN - CALL QSORT_DESC(OUTARRAY,IND,1,INSIZE) + END DO + END IF + + ! Now check if 2 partitions have been associated to the same wave system, if + ! so combine them + npart = LENGTH(REAL(wsdat%par(i,j)%ipart), & + SIZE(wsdat%par(i,j)%ipart),REAL(0)) + DO p = 1, (npart-1) !Could probably be optimized! + DO pp = (p+1), npart + IF (wsdat%par(i,j)%sys(p).EQ.wsdat%par(i,j)%sys(pp)) THEN + ! There is at least one duplicate, so combine systems + CALL combinePartitionsV2(wsdat%par(i,j)) END IF - + END DO + END DO + ! Now that we have associated any possible partition to an existing + ! wave system, we check if any wave system is free. If so give it a + ! new wave system number + npart = LENGTH(REAL(wsdat%par(i,j)%ipart), & + SIZE(wsdat%par(i,j)%ipart),REAL(0)) + + DO p = 1, npart + IF (wsdat%par(i,j)%sys(p).EQ.9999) THEN + maxSys = maxSys + 1 + wsdat%par(i,j)%sys(p) = maxSys END IF -! -!/ --- Cast index array to integer. --- - DO I = 1, INSIZE - IY(I) = INT(IND(I)) + END DO + wsdat%par(i,j)%checked=1 + + IF (ALLOCATED(allSys)) DEALLOCATE(allSys) + IF (ALLOCATED(tmpsys)) DEALLOCATE(tmpsys) + + RETURN + END SUBROUTINE findSys + !/ End of findSys ---------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE combineWaveSystems (wsdat ,maxSys ,maxPts , & + maxI ,maxJ ,perKnob , & + dirKnob ,hsKnob ,combine , & + sys ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Combine wave systems. Then remove small and low-energy systems from set, + ! based on the parameters maxPts and maxHgt. + ! + ! 2. Method + ! + ! - + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! wsdat Type(dat2d) output Combined wave system data structure + ! sys Type(system) output Final set of tracked systems, for one time level + ! maxI, maxJ Int input Maximum indices of wave field + ! maxSys Int input Maximum number of systems identified + ! maxPts Int input Number of points req for valid system + ! hsKnob Real input Parameter for identifying valid system + ! combine Int input Toggle: 1=combine systems; 0=do not combine + + TYPE(dat2d) :: wsdat + TYPE(system), POINTER :: sys(:), systemp(:) + INTEGER :: maxSys, maxPts, maxI, maxJ, combine + REAL :: perKnob ,dirKnob, hsKnob + + INTENT (IN) maxPts, maxI, maxJ, hsKnob, combine + INTENT (IN OUT) wsdat, maxSys !In the Matlab code maxSys is only input ??? + ! INTENT (OUT) sys + ! + ! Local variables + ! ---------------------------------------------------------------- + ! nSys Int Number of wave systems (for checking iterative combining loop) + ! + LOGICAL :: found + INTEGER, ALLOCATABLE :: sysOut(:) + INTEGER, ALLOCATABLE :: actSysInd(:) + INTEGER :: iter, ok, nSys, mS, s, so, ss, ind, leng, & + iw, jw, iloop + INTEGER :: actSys + REAL :: dev, hsCmp, maxHgt, temp(5) + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! printFinalSys + ! combineSys + ! + ! 5. Subroutines calling + ! + ! spiralTrackV3 + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + !012912 WRITE(20,*) 'maxSys,maxPts,maxI,maxJ,hsKnob,combine =', & + !012912 maxSys,maxPts,maxI,maxJ,hsKnob,combine + + ! Set up initial index array of active systems + IF (.NOT.ALLOCATED(actSysInd)) ALLOCATE( actSysInd(maxSys) ) + actSysInd(1:maxSys) = (/ (ind, ind = 1, maxSys) /) + !opt WRITE(20,*) 'actSysInd =',actSysInd + + IF (combine.EQ.1) THEN + ! Combine wave systems + WRITE(20,*) 'Calling printFinalSys...' + CALL printFinalSys (wsdat,maxSys,actSysInd,maxI,maxJ,1,sys) + iter=0 + ok=0 + ! Keep on combining wave systems until all possible combining + ! has been carried out (based on the combining criteria) + DO WHILE (ok.EQ.0) + iter = iter+1 + ! No of systems before combining + IF (ALLOCATED(actSysInd)) THEN + nSys = SIZE(actSysInd) + ELSE + nSys = maxSys + END IF + WRITE(20,'(A,A,I3,A,I5,A)') 'Calling combineSys for ', & + 'iteration',iter,' (maxSys =',nSys,').' + + !opt WRITE(20,*) 'SIZE(sys)=',SIZE(sys) + CALL combineSys (wsdat,sys,maxSys,maxI,maxJ, & + actSysInd,perKnob,dirKnob) + ! No of systems after combining + !opt WRITE(20,*) 'maxSys,nSys,SIZE(actSysInd) =', & + !opt maxSys,nSys,SIZE(actSysInd) + ! IF (maxSys.EQ.nSys) ok = 1 + IF (SIZE(actSysInd).EQ.nSys) ok = 1 END DO -! - RETURN -! - END SUBROUTINE SORT -!/ End of SORT ------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE SETDIFF (INARRAY1, INSIZE1, INARRAY2, INSIZE2, & - OUTARRAY, OUTSIZE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 20-Dec-2016 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ 20-Dec-2016 : Add quicksort algorithm (S.Zieger) ( version 5.16 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! (i) Returns the elements in INARRAY1 that are not in INARRAY2. -! (ii) Sort the resulting array in ascending order. -! -! 2. Method -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INARRAY1 REAL ARR input Input array -! INSIZE1 INTEGER input Size of input array -! INARRAY2 REAL ARR input Input array -! INSIZE2 INTEGER input Size of input array -! OUTARRAY REAL ARR output Output array -! OUTSIZE INTEGER output Size of output array (number of unique elements) - - INTEGER :: INSIZE1, INSIZE2, OUTSIZE - REAL :: INARRAY1(INSIZE1), INARRAY2(INSIZE2) - REAL, POINTER :: OUTARRAY(:) - - INTENT (IN) INARRAY1, INSIZE1, INARRAY2, INSIZE2 - INTENT (OUT) OUTSIZE -! -! Local variables -! ---------------------------------------------------------------- - INTEGER :: I,J,K - REAL :: TEMP(INSIZE1) - REAL :: ARRAY1(INSIZE1),ARRAY2(INSIZE2) - REAL :: ID1(INSIZE1),ID2(INSIZE2) - LOGICAL :: LOOP -! -! 4. Subroutines used : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! QSORT Subr. Private Quicksort algorithm -! -! 5. Subroutines calling -! -! printFinalSys -! combineSys -! timeTrackingV2 -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IF ( (INSIZE1).EQ.0 ) THEN - OUTSIZE = 0 - ALLOCATE(OUTARRAY(OUTSIZE)) - ELSE IF ( INSIZE2.EQ.0 ) THEN - CALL UNIQUE(INARRAY1,INSIZE1,OUTARRAY,OUTSIZE) - ELSE -!/ --- Setup input arrays. --- - DO I=1,INSIZE1 - ARRAY1(I) = INARRAY1(I) - ID1(I) = REAL(I) - END DO - DO I=1,INSIZE2 - ARRAY2(I) = INARRAY2(I) - ID2(I) = REAL(I) + ELSE + ! Do not combine wave systems + CALL printFinalSys (wsdat,maxSys,actSysInd,maxI,maxJ,3,sys) + END IF + + ! Remove small and low-energy systems from set, based on + ! the parameters maxPts and maxHgt. + ! ALLOCATE( sysOut(maxSys) ) + ! sysOut = sys(1:maxSys)%sysInd + ! mS = maxSys + mS = SIZE(actSysInd) + ss = 1 + WRITE(20,*) 'Filtering the set of',mS,'systems on size and mag.' + + DO so = 1, mS + s = actSysInd(so) + !opt NOTE: if we deallocate the individual records without + !opt compressing sys, then s and sysInd will remain the same + ss = s + + leng = LENGTH(sys(ss)%hs,SIZE(sys(ss)%hs),9999.) + dev = STD(sys(ss)%hs(1:leng),leng) + hsCmp = sys(ss)%hsMean + 2.*dev + maxHgt = hsKnob + + IF ( (hsCmp.LT.maxHgt).OR.(sys(ss)%nPoints.LT.maxPts) ) THEN + ! Remove system, and shift up indices to fill the gap + DO ind = 1, maxSys + ! Find index to remove + IF (ind.EQ.ss) THEN + ! Shift up entries, deleting the duplicate partition + ! REPLACE WITH CSHIFT(ARRAY, SHIFT, dim)? + ! IF (ind.LT.maxSys) & + ! sys( ind:(maxSys-1) ) = sys( (ind+1):maxSys ) + IF (ind.LE.maxSys) THEN + ! Since we use pointers, we have to copy each index and + ! field individually. Otherwise memory corruption occurs. + DO iloop = ind,ind + sys(iloop)%sysInd = 9999 + sys(iloop)%nPoints = 0 + sys(iloop)%grp = 9999 + DEALLOCATE( sys(iloop)%hs ) + DEALLOCATE( sys(iloop)%tp ) + DEALLOCATE( sys(iloop)%dir ) + DEALLOCATE( sys(iloop)%dspr ) + ! DEALLOCATE( sys(iloop)%wf ) + DEALLOCATE( sys(iloop)%i ) + DEALLOCATE( sys(iloop)%j ) + DEALLOCATE( sys(iloop)%lat ) + DEALLOCATE( sys(iloop)%lon ) + ! DEALLOCATE( sys(iloop)%hsMean ) + ! DEALLOCATE( sys(iloop)%tpMean ) + ! DEALLOCATE( sys(iloop)%dirMean ) + ! DEALLOCATE( sys(iloop)%ngbr ) + END DO + END IF + END IF END DO -!/ -!/ --- Sort input arrays. --- - CALL QSORT(ARRAY1,ID1,1,INSIZE1) - CALL QSORT(ARRAY2,ID2,1,INSIZE2) -!/ -!/ --- Initialise indices. --- - I = 1 - J = 1 - K = 1 -!/ -!/ --- Allocate and initialize temporary output --- - TEMP(:) = 9999. -!/ -!/ --- Loop though both arrays by incrementing I,J. --- - LOOP = .TRUE. - DO WHILE ( LOOP ) -!/ - IF ( ARRAY1(I).LT.ARRAY2(J) .OR. & - ARRAY1(I).GT.ARRAY2(INSIZE2) ) THEN -!/ --- Populate output array. Check for dumplicates -!/ in output array. --- - IF ( K.EQ.1 ) THEN - TEMP(K) = ARRAY1(I) - K = K + 1 - ELSE IF ( TEMP(K-1).LT.ARRAY1(I) ) THEN - TEMP(K) = ARRAY1(I) - K = K + 1 + + ! Update wsdat as well + DO iw = 1, maxI + DO jw = 1, maxJ + leng = LENGTH(REAL(wsdat%par(iw,jw)%sys), & + SIZE(wsdat%par(iw,jw)%sys),REAL(9999)) + ind = 1 + found = .FALSE. + ! Identify system index (there are no duplicate + ! systems at this point. + DO WHILE (ind.LE.leng) + IF ( wsdat%par(iw,jw)%sys(ind).EQ.s ) THEN + found = .TRUE. + EXIT END IF - I = I + 1 - ELSE IF ( ARRAY2(J).LT.ARRAY1(I) ) THEN - J = J + 1 - ELSE - I = I + 1 - J = J + 1 - END IF -!/ --- Check for exit the loop. --- - IF ( I.GT.INSIZE1 ) THEN - LOOP = .FALSE. + ind = ind + 1 + END DO + IF (found) THEN + ! Blank out used record + wsdat%par(iw,jw)%sys(ind) = 9999 + wsdat%par(iw,jw)%ipart(ind) = 9999 END IF -!/ --- Make sure array pointer I,J are within array bounds. --- - I = MIN(I,INSIZE1) - J = MIN(J,INSIZE2) -!/ - END DO -!/ -!/ --- Allocate output array --- - OUTSIZE = K-1 - ALLOCATE(OUTARRAY(OUTSIZE)) -!/ --- Transfer output from temporary array to output array. --- - DO I=1,OUTSIZE - OUTARRAY(I) = TEMP(I) + END DO END DO END IF -!/ - RETURN -!/ - END SUBROUTINE SETDIFF -!/ End of SETDIFF ---------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE INTERSECT (INARRAY1 ,INSIZE1 ,INARRAY2 ,INSIZE2 , & - OUTARRAY ,OUTSIZE ,IND1 ,IND2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 20-Dec-2016 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ 20-Dec-2016 : Add count-histogram method based on -!/ algorithm from Mirko Velic (BoM) -!/ (S. Zieger BoM, Australia) ( version 5.16 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! (i) Returns the elements that are mutual in INARRAY1 and INARRAY2. -! (ii) Sort the resulting array in ascending order. -! -! 2. Method -! -! Sort with counting/histogram method with input array being -! cast as integer. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INARRAY1 REAL ARR input Input array -! INSIZE1 INTEGER input Size of input array -! INARRAY2 REAL ARR input Input array -! INSIZE2 INTEGER input Size of input array -! OUTARRAY REAL ARR output Output array -! OUTSIZE INTEGER output Size of output array (number of -! intersects) -! - INTEGER :: INSIZE1, INSIZE2, OUTSIZE - REAL :: INARRAY1(INSIZE1), INARRAY2(INSIZE2) - REAL, POINTER :: OUTARRAY(:) - REAL, POINTER :: IND1(:), IND2(:) -! - INTENT (IN) INARRAY1, INSIZE1, INARRAY2, INSIZE2 - INTENT (OUT) OUTSIZE -! -! Local variables -! ---------------------------------------------------------------- -! VIDX1, VIDX2 - array(s) in which the value is represented by -! its index (i.e. histogram with frequency 1) -! N - data range and size of possible intersections. -! - LOGICAL,ALLOCATABLE :: VIDX1(:),VIDX2(:) - INTEGER,ALLOCATABLE :: IPOS1(:),IPOS2(:) -! - INTEGER :: I, J - INTEGER :: N, IMIN, IMAX - INTEGER :: MINV1,MAXV1, MINV2, MAXV2 -! -! 4. Subroutines used : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! -! 5. Subroutines calling -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - OUTSIZE = 0 - -!/ --- Calculate the range of the two sets. --- - MINV1 = INT(MINVAL(INARRAY1)) - MAXV1 = INT(MAXVAL(INARRAY1)) - MINV2 = INT(MINVAL(INARRAY2)) - MAXV2 = INT(MAXVAL(INARRAY2)) - -!/ --- Check if ranges overlap. --- - IF ( MAXV1.LT.MINV2.OR.INSIZE1.EQ.0.OR.INSIZE2.EQ.0 ) THEN - ALLOCATE(OUTARRAY(OUTSIZE)) - ALLOCATE(IND1(OUTSIZE)) - ALLOCATE(IND2(OUTSIZE)) - ELSE -!/ --- Calculate size of temporary output arrays. Allow -!/ extra elements: ZERO, and make sure index is 1:N. --- - IMIN = MIN(MINV1,MINV2)-1 - IMAX = MAX(MAXV1,MAXV2)+1 - - N = IMAX-IMIN + END DO - ALLOCATE(VIDX1(N),VIDX2(N)) - ALLOCATE(IPOS1(N),IPOS2(N)) + ! Compile array index of active systems in sys + actSys = 0 + DO so = 1,maxSys + IF (sys(so)%nPoints>0) actSys = actSys + 1 + END DO + IF (ALLOCATED(actSysInd)) DEALLOCATE(actSysInd) + ALLOCATE( actSysInd(actSys) ) + actSys = 0 + DO so = 1,maxSys + IF (sys(so)%nPoints>0) THEN + actSys = actSys + 1 + actSysInd(actSys) = sys(so)%sysInd + END IF + END DO - VIDX1(1:N) = .FALSE. - VIDX2(1:N) = .FALSE. + !opt WRITE(20,*) 'actSysInd =',actSysInd + DO so = 1,SIZE(actSysInd) + s = actSysInd(so) + !opt WRITE(20,*) 'sys(',s,')%sysInd =',sys(s)%sysInd + END DO - DO I=1,INSIZE1 - J = INT(INARRAY1(I)-IMIN) - VIDX1(J) = .TRUE. - IPOS1(J) = I + CALL printFinalSys (wsdat,maxSys,actSysInd,maxI,maxJ,1,sys) + !opt WRITE(20,*) 'actSysInd =',actSysInd + !opt DO so = 1,maxSys + !opt WRITE(20,*) 'sys(',so,')%sysInd =',sys(so)%sysInd, & + !opt ', sys(',so,')%nPoints =',sys(so)%nPoints + !opt END DO + + RETURN + END SUBROUTINE combineWaveSystems + !/ End of combineWaveSystems ----------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE printFinalSys (wsdat ,maxSys ,actSysInd , & + maxI ,maxJ ,flag ,sys ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Output (print) the final output systems for this time step. + ! + ! 2. Method + ! + ! - + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! wsdat Type(dat2d) input Combined data structure + ! maxI, maxJ Int input Maximum indices of wave field + ! maxSys Int input Maximum number of systems identified + ! flag Int input Flag for printing system + ! sys Type(system) output Final set of tracked systems, for one time level + ! + TYPE(dat2d) :: wsdat + TYPE(system), POINTER :: sys(:) + INTEGER :: maxSys, maxI, maxJ, flag + INTEGER, ALLOCATABLE :: actSysInd(:) + + INTENT (IN) wsdat, actSysInd, maxI, maxJ, flag + INTENT (OUT) maxSys + ! INTENT (IN OUT) sys + ! + ! Local variables + ! ---------------------------------------------------------------- + ! ic Int Counter for wave systems + ! + INTEGER :: ic, nGuys, startInd, endInd, i, j, ind, leng, leng2 + INTEGER :: UNISIZE, DIFSIZE + REAL, ALLOCATABLE :: sysOrdered(:) + REAL, POINTER :: UNIARR(:), DIFARR(:) + INTEGER, ALLOCATABLE :: ngbrSysAll(:), sysSortedInd(:) + REAL :: TEMP(2), TEMP1, TEMP2 + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! UNIQUE + ! SETDIFF + ! SORT + ! + ! 5. Subroutines calling + ! + ! combineWaveSystems + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + ! Initialize sys structure + IF (flag.NE.2) THEN + ! Allocate data structure with the final wave systems + WRITE(20,*) 'In printFinalSys...' + maxSys = SIZE(actSysInd) + NULLIFY(sys) + ALLOCATE( sys(maxSys) ) + WRITE(20,*) 'Allocated sys okay, SIZE(sys) =',SIZE(sys) + + ALLOCATE( ngbrSysAll(50*maxI*maxJ) ) !Large enough? + DO ic = 1, maxSys + NULLIFY( sys(ic)%hs ) + NULLIFY( sys(ic)%tp ) + NULLIFY( sys(ic)%dir ) + NULLIFY( sys(ic)%dspr ) + ! NULLIFY( sys(ic)%wf ) + NULLIFY( sys(ic)%i ) + NULLIFY( sys(ic)%j ) + NULLIFY( sys(ic)%lat ) + NULLIFY( sys(ic)%lon ) + ALLOCATE( sys(ic)%hs(maxI*maxJ) ) + ALLOCATE( sys(ic)%tp(maxI*maxJ) ) + ALLOCATE( sys(ic)%dir(maxI*maxJ) ) + ALLOCATE( sys(ic)%dspr(maxI*maxJ) ) + ! ALLOCATE( sys(ic)%wf(maxI*maxJ) ) + ALLOCATE( sys(ic)%i(maxI*maxJ) ) + ALLOCATE( sys(ic)%j(maxI*maxJ) ) + ALLOCATE( sys(ic)%lat(maxI*maxJ) ) + ALLOCATE( sys(ic)%lon(maxI*maxJ) ) + sys(ic)%hs(:) = 9999. !Optimize this further? + sys(ic)%tp(:) = 9999. + sys(ic)%dir(:) = 9999. + sys(ic)%dspr(:) = 9999. + ! sys(ic)%wf(:) = 9999. + sys(ic)%i(:) = 9999 + sys(ic)%j(:) = 9999 + sys(ic)%lat(:) = 9999. + sys(ic)%lon(:) = 9999. + sys(ic)%sysInd = 9999 + sys(ic)%hsMean = 9999. + sys(ic)%tpMean = 9999. + sys(ic)%dirMean = 9999. + sys(ic)%nPoints = 0 + sys(ic)%ngbr(:) = 9999 + sys(ic)%grp = 9999 + ngbrSysAll(:) = 0 + startInd=1 + nGuys=0 + + DO i = 1, maxI + DO j = 1, maxJ + ! ind=wsdat.par(i,j).sys==ic; + DO ind = 1, SIZE(wsdat%par(i,j)%sys) !40.81 !Optimize this? + IF (wsdat%par(i,j)%sys(ind).EQ.actSysInd(ic)) & + THEN + nGuys=nGuys+1 + sys(ic)%hs(nGuys)=wsdat%par(i,j)%hs(ind) + sys(ic)%tp(nGuys)=wsdat%par(i,j)%tp(ind) + sys(ic)%dir(nGuys)=wsdat%par(i,j)%dir(ind) + sys(ic)%dspr(nGuys)=wsdat%par(i,j)%dspr(ind) + ! sys(ic)%wf(nGuys)=wsdat%par(i,j)%wf(ind) + sys(ic)%i(nGuys)=i + sys(ic)%j(nGuys)=j + sys(ic)%lat(nGuys)=wsdat%lat(i,j) + sys(ic)%lon(nGuys)=wsdat%lon(i,j) + leng = LENGTH(REAL(wsdat%par(i,j)%ngbrSys), & + SIZE(wsdat%par(i,j)%ngbrSys),REAL(9999)) + endInd = startInd + leng-1 + ngbrSysAll(startInd:endInd) = & + wsdat%par(i,j)%ngbrSys(1:leng) + startInd=endInd+1 + END IF + END DO + END DO END DO - DO I=1,INSIZE2 - J = INT(INARRAY2(I)-IMIN) -!/ --- Intersect arrays and check for -!/ duplicate elements in array2. --- - IF ( VIDX1(J).AND..NOT.VIDX2(J) ) THEN - OUTSIZE = OUTSIZE + 1 - VIDX2(J) = .TRUE. - IPOS2(J) = I + ! if ~isempty(sys) + IF (nGuys.GT.0) THEN + sys(ic)%sysInd=ic + sys(ic)%hsMean = SUM(sys(ic)%hs(1:nGuys))/nGuys + sys(ic)%tpMean = SUM(sys(ic)%tp(1:nGuys))/nGuys + ! sys(ic)%dirMean=mean_angle_single(sys(ic).dir) 40.81 Replaced with two-argument mean_angleV2 + sys(ic)%dirMean = & + mean_angleV2(sys(ic)%dir(1:nGuys),nGuys) + !070512----------- Weight averages with Hm0 --------------------- + TEMP1 = 0. + TEMP2 = 0. + DO i = 1,nGuys + TEMP1 = TEMP1 + (sys(ic)%hs(i)**2)*sys(ic)%hs(i) + TEMP2 = TEMP2 + (sys(ic)%hs(i)**2)*sys(ic)%tp(i) + END DO + sys(ic)%hsMean = & + TEMP1/MAX(SUM(sys(ic)%hs(1:nGuys)**2),0.001) + sys(ic)%tpMean = & + TEMP2/MAX(SUM(sys(ic)%hs(1:nGuys)**2),0.001) + sys(ic)%dirMean = mean_angleV3(sys(ic)%dir(1:nGuys), & + sys(ic)%hs(1:nGuys),nGuys) + !070512----------- Weight averages with Hm0 --------------------- + sys(ic)%nPoints = nGuys + IF (endInd.GT.0) THEN + CALL UNIQUE(REAL(ngbrSysAll(1:endInd)),endInd, & + UNIARR,UNISIZE) + TEMP = (/REAL(sys(ic)%sysInd),REAL(sys(ic)%sysInd)/) + CALL SETDIFF(REAL(UNIARR),UNISIZE, & + TEMP,2,DIFARR,DIFSIZE) + DIFSIZE = MIN(DIFSIZE,SIZE(sys(ic)%ngbr)) + sys(ic)%ngbr(1:DIFSIZE) = NINT(DIFARR(1:DIFSIZE)) + IF (ASSOCIATED(UNIARR)) DEALLOCATE(UNIARR) + IF (ASSOCIATED(DIFARR)) DEALLOCATE(DIFARR) END IF - END DO -!/ --- Allocate output arrays. --- - ALLOCATE(OUTARRAY(OUTSIZE)) - ALLOCATE(IND1(OUTSIZE)) - ALLOCATE(IND2(OUTSIZE)) -!/ --- Transfer contents. --- - I = 1 - DO J=1,N - IF ( VIDX1(J).AND.VIDX2(J).AND.I.LE.OUTSIZE ) THEN - OUTARRAY(I) = INARRAY1(IPOS1(J)) - IND1(I) = IPOS1(J) - IND2(I) = IPOS2(J) - I = I + 1 + ELSE + CYCLE + END IF + END DO + IF (ALLOCATED(ngbrSysAll)) DEALLOCATE(ngbrSysAll) + END IF + + ! Print the sorted field to the screen + leng = LENGTH(REAL(sys(:)%nPoints), & + SIZE(sys(:)%nPoints),REAL(9999)) + ALLOCATE( sysOrdered(leng) ) + ALLOCATE( sysSortedInd(leng) ) + CALL SORT (REAL(sys(:)%nPoints),leng, & + sysOrdered,sysSortedInd,'D') + leng = LENGTH(REAL(sysOrdered), & + SIZE(sysOrdered),REAL(0)) + + DO ic = 1, leng + leng2 = LENGTH(REAL(sys(sysSortedInd(ic))%ngbr), & + SIZE(sys(sysSortedInd(ic))%ngbr),REAL(9999)) + END DO + IF (ALLOCATED(sysOrdered)) DEALLOCATE(sysOrdered) + IF (ALLOCATED(sysSortedInd)) DEALLOCATE(sysSortedInd) + + RETURN + END SUBROUTINE printFinalSys + !/ End of printFinalSys ---------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE combineSys (wsdat ,sys ,maxSys ,maxI , & + maxJ ,actSysInd,perKnob ,dirKnob ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Combine wave systems + ! + ! 2. Method + ! + ! - + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! wsdat Type(dat2d) input Combined data structure + ! maxI, maxJ Int input Maximum indices of wave field + ! sys Type(system) output Final set of tracked systems, for one time level + ! maxSys Int input Number of systems + ! dirKnob Real input Parameter in direction for combining fields in space + ! perKnob Real input Parameter in period for combining fields in space + ! + TYPE(dat2d) :: wsdat !40.PAR + TYPE(system), POINTER :: sys(:) !40.PAR + INTEGER :: maxSys, maxI, maxJ !40.PAR + INTEGER, ALLOCATABLE :: actSysInd(:) + REAL :: perKnob ,dirKnob + REAL :: dx, m1, m2 + + INTENT (IN) maxI, maxJ, perKnob, dirKnob !40.PAR + ! INTENT (IN OUT) wsdat, sys, maxSys !40.PAR + ! + ! Local variables + ! ---------------------------------------------------------------- + ! ngbIndex Int Arr Array of neighbours + ! + INTEGER, ALLOCATABLE :: sysSortedInd(:), sysOut(:) + INTEGER, POINTER :: indSys1(:), indSys2(:) + REAL, ALLOCATABLE :: sysOrdered(:), rounded(:) + REAL, POINTER :: uniarr(:), difarr(:), allngbr(:) + INTEGER :: leng, leng2, s, ss, so, ngb, lsys, lsys2, hh, i, j, & + ii, jj, ind, ind2, nn, nbr, icEnd,ic,iii,iloop + INTEGER :: myngbr, indMatch, matchSys, keep, replacedInd, & + hhForIndMatch, lMatch, tot, outsize + INTEGER :: ngbIndex(10000), keepInd(maxI*maxJ), oneLess(1000) !Array large enough? + ! REAL :: Tb,deltaPerB,deltaDirB,absDir,absPer,absHs,absWf + REAL :: Tb,deltaPerB,deltaDirB,deltaHsB,absDir,absPer,absHs + LOGICAL :: file_exists + INTEGER :: MASK(maxI,maxJ) + REAL :: lonmean, latmean, DIST + !061512 ----------------------------------------------- + LOGICAL :: ZIPMATCH + INTEGER :: counter, count2, izp, izp2, in, jn, icnt, ngbrExt + REAL :: T, ngb_tp, ngb_dir + REAL :: ngbmatch(maxI*maxJ) + TYPE(neighbr) :: ngbr(50) + !061512 ----------------------------------------------- + REAL :: TEMP1, TEMP2 + INTEGER :: actSys + + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! SORT + ! findIJV4 + ! UNIQUE + ! combinePartitionsV2 + ! UNION + ! SETDIFF + ! + ! 5. Subroutines calling + ! + ! combineWaveSystems + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! Initialize pointer (first use) + NULLIFY(indSys1) + NULLIFY(indSys2) + ! Flag to combine systems on a point-by-point basis along boundary, + ! instead of using mean values. + ZIPMATCH = .FALSE. + ngbrExt = 1 + ! Combine systems on the basis of tpMean + ALLOCATE( sysOrdered(maxSys) ) + ALLOCATE( sysSortedInd(maxSys) ) + ALLOCATE( sysOut(maxSys) ) + ALLOCATE( rounded(maxSys) ) + ! Sort in descending Tp: the following improves the iterative combining in + ! the special case that the wave period is constant over the domain, but + ! tpMean is not because of truncation errors at very high decimals. + rounded = REAL(INT(sys(1:maxSys)%tpMean*1.E4))*1.E-4 + CALL SORT(rounded,maxSys,sysOrdered,sysSortedInd,'D') + sysOut=sys(sysSortedInd)%sysInd + IF (ALLOCATED(rounded)) DEALLOCATE(rounded) + + !051612 --- Land mask addition + MASK(:,:) = 0 + INQUIRE(FILE="sys_mask.ww3", EXIST=file_exists) + IF (file_exists) THEN + WRITE(20,*) '*** Using land mask' + OPEN(unit=13,file='sys_mask.ww3',status='old') + DO j = maxJ,1,-1 + READ(13,*) (MASK(i,j), i=1,maxI) + END DO + CLOSE(13) + END IF + !051612 --- Land mask addition + + !opt WRITE(20,*) 'SIZE(sysOut)=',SIZE(sysOut) + DO so = 1, SIZE(sysOut) + ! WRITE(20,*) 'so =',so + s = sysOut(so) + ss = FINDFIRST(REAL(sys(:)%sysInd),SIZE(sys(:)%sysInd), & + REAL(s)) + !opt WRITE(20,*) 's,ss=',s,ss + ngbIndex(:) = 0 + ii = 1 + leng = LENGTH(REAL(sys(ss)%ngbr),SIZE(sys(ss)%ngbr), & + REAL(9999)) + ! Identify the indices of all the systems that neighbour the current system s, + ! store in ngbIndex(:) + DO ngb = 1, leng + IF ( sys(ss)%ngbr(ngb).NE.s ) THEN + myngbr = 1 + DO WHILE (myngbr.LE.SIZE(sysOut)) + IF (sys(myngbr)%sysInd.EQ.sys(ss)%ngbr(ngb)) THEN + ngbIndex(ii) = myngbr + ii = ii+1 + IF (ii.GT.1000) & + WRITE(20,*) '*** WARNING: ngbIndex(:) exceeded!' + END IF + myngbr = myngbr+1 + END DO + END IF + END DO + ii = ii-1 + !opt WRITE(20,*) so,'. sys =',s,', Tp =',sys(s)%tpMean, & + !opt ', size=',sys(s)%nPoints,', #neighbours=',ii + + IF ( ii.GT.0 ) THEN + DO ngb = 1, ii + ! We first need to find the (i,j) points that are either common + ! to both these systems, or at the boundary of the two systems. Here + ! sys 1 will carry the 'ss' index and sys 2 the ngbIndex(ngb) index. + CALL findIJV4 (sys(ss),sys(ngbIndex(ngb)), & + maxI,maxJ,indSys1,indSys2) + IF ((SIZE(indSys1)>10).AND.(SIZE(indSys2)>10).AND. & + (sys(ss)%nPoints.GT.sys(ngbIndex(ngb))%nPoints)) & + THEN + lsys = SIZE(indSys1) + lsys2 = SIZE(indSys2) + + !061512---------------Add zipper compare + IF (ZIPMATCH) THEN + ! Omit small systems to save time + IF ((sys(ss)%nPoints.LT.5).OR. & + (sys(ngbIndex(ngb))%nPoints.LT.5)) THEN + CYCLE + END IF + dx=0.5*((wsdat%lon(2,1)-wsdat%lon(1,1)) + & + (wsdat%lat(1,2)-wsdat%lat(1,1))) + ngbmatch(:)=0. + DO izp = 1,lsys + ! Find neighbors of this point + counter=0 + DO in=(sys(ss)%i(indSys1(izp))-ngbrExt), & + (sys(ss)%i(indSys1(izp))+ngbrExt) + DO jn=(sys(ss)%j(indSys1(izp))-ngbrExt), & + (sys(ss)%j(indSys1(izp))+ngbrExt) + counter=counter+1 + ngbr(counter)%i = in + ngbr(counter)%j = jn + END DO + END DO + ! Find these points in neighboring system + ngb_tp = 0. + ngb_dir = 0. + count2 = 0 + DO izp2 = 1,lsys2 + DO icnt = 1,counter + IF ((sys(ngbIndex(ngb))%i(indSys2(izp2)) & + .EQ.ngbr(icnt)%i).AND. & + (sys(ngbIndex(ngb))%j(indSys2(izp2)) & + .EQ.ngbr(icnt)%j)) THEN + count2 = count2+1 + ngb_tp = ngb_tp + & + sys(ngbIndex(ngb))%tp(indSys2(izp2)) + ngb_dir = ngb_dir + & + sys(ngbIndex(ngb))%dir(indSys2(izp2)) + END IF + END DO + END DO + IF (count2.GT.0) THEN + absPer = ABS(sys(ss)%tp(indSys1(izp))-ngb_tp/count2) + absDir = ABS(sys(ss)%dir(indSys1(izp))-ngb_dir/count2) + T = sys(ss)%tp(indSys1(izp)) + m1 = -3.645*T + 63.211 + m1 = MAX(m1,10.) + m2 = -0.346*T + 3.686 + m2 = MAX(m2,0.6) + deltaDirB = (m1*dx + dirKnob)*1. + deltaPerB = (m2*dx + perKnob)*1. + IF ( (absPer.LT.deltaPerB).AND. & + (absDir.LT.deltaDirB) ) THEN + ngbmatch(izp)=1. + END IF + END IF + END DO + ! If >80% of neighbors fall within criteria, system is matched + IF ((SUM(ngbmatch(1:lsys))/lsys).GT.0.50) THEN + indMatch = ngbIndex(ngb) + matchSys = sys(indMatch)%sysInd + ELSE + CYCLE + END IF + ELSE + !061512--------------------------------- + + Tb = MAX(SUM(sys(ss)%tp(indSys1))/lsys, & + SUM(sys(ngbIndex(ngb))%tp(indSys2))/lsys2) + ! deltaPerB = (-0.06*Tb+2+perKnob)*1.5 + ! deltaDirB = (-Tb+(25+10*dirKnob))*1.5 + ! deltaPerB = (-0.06*Tb+2+2)*1.5 + ! deltaDirB = (-Tb+(25+10*2))*1.5 + dx=0.5*((wsdat%lon(2,1)-wsdat%lon(1,1)) + & + (wsdat%lat(1,2)-wsdat%lat(1,1))) + m1 = -3.523*Tb + 64.081 + m1 = MAX(m1,10.) + m2 = -0.337*Tb + 3.732 + m2 = MAX(m2,0.6) + !1stddev m1 = -2.219*Tb + 35.734 + !1stddev m1 = MAX(m1,5.) + !1stddev m2 = -0.226*Tb + 2.213 + !1stddev m2 = MAX(m2,0.35) + !5stddev m1 = -5.071*Tb + 90.688 + !5stddev m1 = MAX(m1,16.) + !5stddev m2 = -0.467*Tb + 5.161 + !5stddev m2 = MAX(m2,1.0) + deltaDirB = (m1*1. + dirKnob)*1. + deltaPerB = (m2*1. + perKnob)*1. + deltaHsB = 0.50*SUM(sys(ss)%hs(indSys1))/lsys + ! deltaHsB = 0.25*SUM(sys(ss)%hs(indSys1))/lsys + + !051612 --- Land mask addition + ! Option 1: If system centroid is near a land mask (e.g. 3 arc-deg), + ! increase the tolerances + IF (ANY(MASK.EQ.1)) THEN + lonmean = SUM(sys(ss)%lon(indSys1))/lsys + latmean = SUM(sys(ss)%lat(indSys1))/lsys + DO j = 1,maxJ + DO i = 1,maxI + IF (MASK(i,j).EQ.1) THEN + ! Land point found. Compute distance to system centroid + DIST = SQRT((lonmean-wsdat%lon(i,j))**2 +& + (latmean-wsdat%lat(i,j))**2) + IF (DIST.LT.3.) THEN + ! System assumed to be influenced by land, + ! increase tolerances to deltaDirB=30,deltaPerB=3 + ! deltaDirB = (m1*1. + 30)*1. + ! deltaPerB = (m2*1. + 3)*1. + deltaDirB = (m1*1. + 30)*1. + deltaPerB = (m2*1. + 3)*1. + !Remove dHs limitation from criteria + deltaHsB = 9999. + GOTO 500 + END IF + END IF + END DO + END DO + END IF +500 CONTINUE + !051612 --- Land mask addition + + absHs = ABS( SUM(sys(ss)%hs(indSys1))/lsys - & + SUM(sys(ngbIndex(ngb))%hs(indSys2))/lsys2 ) + absPer = ABS( SUM(sys(ss)%tp(indSys1))/lsys - & + SUM(sys(ngbIndex(ngb))%tp(indSys2))/lsys2 ) + absDir = ABS( & + mean_angleV2(sys(ss)%dir(indSys1),lsys) - & + mean_angleV2(sys(ngbIndex(ngb))%dir(indSys2), & + lsys2) ) + IF (absDir.GT.180) absDir = 360.-absDir + ! absWf = ABS( SUM(sys(ss)%wf(indSys1))/lsys - & + ! SUM(sys(ngbIndex(ngb))%wf(indSys2))/lsys2 ) + + IF ( (absPer.LT.deltaPerB).AND. & + (absDir.LT.deltaDirB).AND. & + (absHs.LT.deltaHsB) ) THEN + indMatch = ngbIndex(ngb) + matchSys = sys(indMatch)%sysInd + !opt WRITE(20,*) '-> Matched sys',s, & + !opt 'with neighbor sys',matchSys + ELSE + CYCLE + END IF + !061512--------------------------------- + END IF + !061512--------------------------------- + + keep = 0 + keepInd(:) = 0 + + DO hh = 1, sys(ss)%nPoints + ii = sys(ss)%i(hh) + jj = sys(ss)%j(hh) + ind = 0 + ind = FINDFIRST(REAL(wsdat%par(ii,jj)%sys), & + SIZE(wsdat%par(ii,jj)%sys),REAL(s)) !Shouldn't REAL(s) be matchSys... + IF (ind.NE.0) THEN + wsdat%par(ii,jj)%sys(ind)=matchSys !...and matchSys be s, (i.e. add the matching neigbour to the base?) + END IF + ! Remove the "-1" system from the set + ind2 = 1 + oneLess(:) = 9999 !Streamline this? + leng = LENGTH(REAL(wsdat%par(ii,jj)%sys), & + SIZE(wsdat%par(ii,jj)%sys),REAL(9999)) + DO ind = 1, leng + IF ( wsdat%par(ii,jj)%sys(ind).NE.-1 ) THEN + oneLess(ind2) = wsdat%par(ii,jj)%sys(ind) + ind2 = ind2+1 + END IF + END DO + ind2 = ind2-1 + ! Combine any partitions assigned to the same systems + ! Check for duplicates + IF (ind2.EQ.0) & + WRITE(20,*) '***2.Calling UNIQUE w. len=0!' + CALL UNIQUE(REAL(oneLess(1:ind2)),ind2, & + uniarr,outsize) + IF (ASSOCIATED(uniarr)) DEALLOCATE(uniarr) + IF (ind2.GT.outsize) THEN + ! There is at least one duplicate, so combine systems + CALL combinePartitionsV2(wsdat%par(ii,jj)) + ! Update the combined partitions values into the system we are keeping. + ! Since partitions have been combined we don't know if the index is the same + replacedInd = & + FINDFIRST(REAL(wsdat%par(ii,jj)%sys(:)), & + SIZE(wsdat%par(ii,jj)%sys(:)), & + REAL(matchSys)) + hhForIndMatch = 1 + DO WHILE (hhForIndMatch.LE. & + sys(indMatch)%nPoints) + IF ( (sys(indMatch)%i(hhForIndMatch) & + .EQ.ii).AND. & + (sys(indMatch)%j(hhForIndMatch) & + .EQ.jj) ) EXIT + hhForIndMatch = hhForIndMatch + 1 + END DO + sys(indMatch)%hs(hhForIndMatch) = & + wsdat%par(ii,jj)%hs(replacedInd) + sys(indMatch)%tp(hhForIndMatch) = & + wsdat%par(ii,jj)%tp(replacedInd) + sys(indMatch)%dir(hhForIndMatch) = & + wsdat%par(ii,jj)%dir(replacedInd) + sys(indMatch)%dspr(hhForIndMatch) = & + wsdat%par(ii,jj)%dspr(replacedInd) + ! sys(indMatch)%wf(hhForIndMatch) = & + ! wsdat%par(ii,jj)%wf(replacedInd) + ELSE + keep = keep+1 + keepInd(keep) = hh + END IF + END DO + leng = LENGTH(REAL(sys(indMatch)%hs), & + SIZE(sys(indMatch)%hs),REAL(9999.)) + + ! Update system info + ! ------------------ + ! First need to find which points were common to both systems => + ! keepInd since that means partitions have not been combined for those + ! points as a result of the combination of those 2 systems => + ! distinct points + ! keepInd = keepInd(1:keep) + lMatch = LENGTH(REAL(sys(indMatch)%hs), & + SIZE(sys(indMatch)%hs),REAL(9999.)) + tot = lMatch + keep + CALL UNION (REAL(sys(indMatch)%ngbr), & + SIZE(sys(indMatch)%ngbr), & + REAL(sys(ss)%ngbr), & + SIZE(sys(ss)%ngbr), & + allngbr,outsize) + CALL SETDIFF(allngbr,SIZE(allngbr), & + REAL((/sys(indMatch)%sysInd, & + sys(ss)%sysInd/)), & + SIZE((/sys(indMatch)%sysInd, & + sys(ss)%sysInd/)),difarr,outsize) + sys(indMatch)%ngbr(:) = 9999 + outsize = MIN(outsize,size(sys(indMatch)%ngbr)) + sys(indMatch)%ngbr(1:outsize) = NINT(difarr(1:outsize)) + IF (ASSOCIATED(allngbr)) DEALLOCATE(allngbr) + IF (ASSOCIATED(difarr)) DEALLOCATE(difarr) + + leng = LENGTH(REAL(sys(indMatch)%i), & + SIZE(sys(indMatch)%i),REAL(9999)) + sys(indMatch)%hsMean = SUM((/ & + sys(ss)%hs(keepInd(1:keep)), & + sys(indMatch)%hs(1:leng) /))/tot + sys(indMatch)%tpMean = SUM((/ & + sys(ss)%tp(keepInd(1:keep)), & + sys(indMatch)%tp(1:leng) /))/tot + sys(indMatch)%dirMean = & + mean_angleV2((/ sys(ss)%dir(keepInd(1:keep)), & + sys(indMatch)%dir(1:leng) /),tot) + !070512----------- Weight averages with Hm0 --------------------- + TEMP1 = 0. + TEMP2 = 0. + DO iii = 1,keep + TEMP1 = TEMP1 + (sys(ss)%hs(keepInd(iii))**2)*& + sys(ss)%hs(keepInd(iii)) + TEMP2 = TEMP2 + (sys(ss)%hs(keepInd(iii))**2)*& + sys(ss)%tp(keepInd(iii)) + END DO + DO iii = 1,leng + TEMP1 = TEMP1 + (sys(indMatch)%hs(iii)**2)*& + sys(indMatch)%hs(iii) + TEMP2 = TEMP2 + (sys(indMatch)%hs(iii)**2)*& + sys(indMatch)%tp(iii) + END DO + sys(indMatch)%hsMean = TEMP1/MAX(SUM((/ & + sys(ss)%hs(keepInd(1:keep))**2, & + sys(indMatch)%hs(1:leng)**2 /)),0.001) + sys(indMatch)%tpMean = TEMP2/MAX(SUM((/ & + sys(ss)%hs(keepInd(1:keep))**2, & + sys(indMatch)%hs(1:leng)**2 /)),0.001) + sys(indMatch)%dirMean = & + mean_angleV3((/ sys(ss)%dir(keepInd(1:keep)), & + sys(indMatch)%dir(1:leng) /), & + (/ sys(ss)%hs(keepInd(1:keep)), & + sys(indMatch)%hs(1:leng) /),tot) + !070512----------- Weight averages with Hm0 --------------------- + + sys(indMatch)%i(1:(keep+leng))= & + (/sys(ss)%i(keepInd(1:keep)), & + sys(indMatch)%i(1:leng)/) + sys(indMatch)%j(1:(keep+leng))= & + (/sys(ss)%j(keepInd(1:keep)), & + sys(indMatch)%j(1:leng)/) + sys(indMatch)%lat(1:(keep+leng)) = & + (/sys(ss)%lat(keepInd(1:keep)), & + sys(indMatch)%lat(1:leng)/) + sys(indMatch)%lon(1:(keep+leng)) = & + (/sys(ss)%lon(keepInd(1:keep)), & + sys(indMatch)%lon(1:leng)/) + sys(indMatch)%dir(1:(keep+leng)) = & + (/sys(ss)%dir(keepInd(1:keep)), & + sys(indMatch)%dir(1:leng)/) + sys(indMatch)%dspr(1:(keep+leng)) = & + (/sys(ss)%dspr(keepInd(1:keep)), & + sys(indMatch)%dspr(1:leng)/) + ! sys(indMatch)%wf(1:(keep+leng)) = & + ! (/sys(ss)%wf(keepInd(1:keep)), & + ! sys(indMatch)%wf(1:leng)/) + sys(indMatch)%hs(1:(keep+leng)) = & + (/sys(ss)%hs(keepInd(1:keep)), & + sys(indMatch)%hs(1:leng)/) + sys(indMatch)%tp(1:(keep+leng)) = & + (/sys(ss)%tp(keepInd(1:keep)), & + sys(indMatch)%tp(1:leng)/) + sys(indMatch)%nPoints = & + LENGTH(REAL(sys(indMatch)%i), & + SIZE(sys(indMatch)%i),REAL(9999)) + ! Clear array of system that has just been combined with another + sys(ss)%nPoints = 0 + sys(ss)%ngbr(:) = 9999 + WRITE(20,*) 'Deallocating sys',s + DEALLOCATE( sys(ss)%hs ) !opt + DEALLOCATE( sys(ss)%tp ) !opt + DEALLOCATE( sys(ss)%dir ) !opt + DEALLOCATE( sys(ss)%dspr ) !opt + ! DEALLOCATE( sys(ss)%wf ) !opt + DEALLOCATE( sys(ss)%i ) !opt + DEALLOCATE( sys(ss)%j ) !opt + DEALLOCATE( sys(ss)%lat ) !opt + DEALLOCATE( sys(ss)%lon ) !opt + ! DEALLOCATE( sys(ss)%hsMean ) !opt + ! DEALLOCATE( sys(ss)%tpMean ) !opt + ! DEALLOCATE( sys(ss)%dirMean ) !opt + + ! Loop through wsdat to update neighbouring system values + DO i = 1, maxI + DO j = 1, maxJ + ind = FINDFIRST(REAL(wsdat%par(i,j)%ngbrSys), & + SIZE(wsdat%par(i,j)%ngbrSys),REAL(s)) + IF (ind.NE.0) THEN + wsdat%par(i,j)%ngbrSys(ind)=matchSys + END IF + leng = LENGTH(REAL(wsdat%par(i,j)%ngbrSys), & + SIZE(wsdat%par(i,j)%ngbrSys),REAL(9999)) + IF (leng.GT.0) THEN + CALL UNIQUE( & + REAL(wsdat%par(i,j)%ngbrSys(1:leng)), & + leng,uniarr,outsize) + wsdat%par(i,j)%ngbrSys(:) = 9999 + wsdat%par(i,j)%ngbrSys(1:outsize) = & + NINT(uniarr) + IF (ASSOCIATED(uniarr)) DEALLOCATE(uniarr) + ELSE + wsdat%par(i,j)%ngbrSys(:) = 9999 + END IF + END DO + END DO + + ! Update neigbors in sys structure + DO nn = 1, maxSys + nbr = FINDFIRST(REAL(sys(nn)%ngbr), & + SIZE(sys(nn)%ngbr),REAL(s)) + IF (nbr.NE.0) THEN + ! WRITE(20,*) 'update' + sys(nn)%ngbr(nbr)=matchSys + END IF + leng2 = LENGTH(REAL(sys(nn)%ngbr), & + SIZE(sys(nn)%ngbr),REAL(9999)) + IF (leng2.GT.0) THEN + CALL UNIQUE(REAL(sys(nn)%ngbr(1:leng2)), & + leng2,uniarr,outsize) + sys(nn)%ngbr(:) = 9999 + sys(nn)%ngbr(1:outsize) = NINT(uniarr) + IF (ASSOCIATED(uniarr)) DEALLOCATE(uniarr) + ! WRITE(20,*) 'has now ngbr: ', & + ! sys(nn)%ngbr(1:outsize) + END IF + END DO + EXIT END IF - END DO -!/ --- Free memory. --- - DEALLOCATE(VIDX1,VIDX2) - DEALLOCATE(IPOS1,IPOS2) - END IF -!/ - RETURN -!/ - END SUBROUTINE INTERSECT -!/ End of INTERSECT -------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE UNION (INARRAY1, INSIZE1, INARRAY2, INSIZE2, & - OUTARRAY, OUTSIZE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ 20-Dec-2016 : Add count-histogram method similarly -!/ to INTERSECT (S. Zieger) ( version 5.16 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! (i) Returns the union of INARRAY1 and INARRAY2. -! (ii) Sort the resulting array in ascending order. -! -! 2. Method -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INARRAY REAL ARR input Input array -! INSIZE INTEGER input Size of input array -! OUTARRAY REAL ARR output Output array (sorted) -! OUTSIZE INTEGER output Size of output array (number of -! unique elements) - INTEGER :: INSIZE1, INSIZE2, OUTSIZE - REAL :: INARRAY1(INSIZE1), INARRAY2(INSIZE2) - REAL, POINTER :: OUTARRAY(:) -! - INTENT (IN) INARRAY1, INSIZE1, INARRAY2, INSIZE2 - INTENT (OUT) OUTSIZE -! -! Local variables -! ---------------------------------------------------------------- -! VIDX1, VIDX2 - array(s) in which the value is represented by -! its index (i.e. histogram with frequency 1) -! N - data range and size of possible intersections. -! - LOGICAL,ALLOCATABLE :: VIDX1(:),VIDX2(:) - INTEGER,ALLOCATABLE :: IPOS1(:),IPOS2(:) - REAL,ALLOCATABLE :: TEMP(:) -! - INTEGER :: I, J - INTEGER :: N, IMIN, IMAX - INTEGER :: MINV1,MAXV1, MINV2, MAXV2 -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! QSORT Subr. Private Quicksort algorithm -! -! 5. Subroutines calling -! -! combineSys -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! - -! -! 9. Switches : -! -! None defined yet. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ --- Setup input arrays. --- - IF ( (INSIZE1+INSIZE2).EQ.0 ) THEN - OUTSIZE = 0 - ALLOCATE(OUTARRAY(OUTSIZE)) - ELSEIF ( INSIZE1.EQ.0 ) THEN - OUTSIZE = INSIZE2 - ALLOCATE(OUTARRAY(OUTSIZE)) - ALLOCATE(TEMP(OUTSIZE)) - DO I=1,OUTSIZE - OUTARRAY(I) = INARRAY2(I) - TEMP(I) = REAL(I) + IF (ASSOCIATED(indSys1)) DEALLOCATE(indSys1) + IF (ASSOCIATED(indSys2)) DEALLOCATE(indSys2) END DO - CALL QSORT(OUTARRAY,TEMP,1,OUTSIZE) + END IF + END DO - ELSEIF ( INSIZE2.EQ.0 ) THEN - OUTSIZE = INSIZE1 - ALLOCATE(OUTARRAY(OUTSIZE),TEMP(OUTSIZE)) + IF (ALLOCATED(sysOrdered)) DEALLOCATE(sysOrdered) + IF (ALLOCATED(sysSortedInd)) DEALLOCATE(sysSortedInd) + IF (ALLOCATED(sysOut)) DEALLOCATE(sysOut) - DO I=1,OUTSIZE - OUTARRAY(I) = INARRAY1(I) - TEMP(I) = REAL(I) - END DO - CALL QSORT(OUTARRAY,TEMP,1,OUTSIZE) + ! Compile array index of active systems in sys + actSys = 0 + DO ic = 1,maxSys + IF (sys(ic)%nPoints>0) actSys = actSys + 1 + END DO + IF (ALLOCATED(actSysInd)) DEALLOCATE(actSysInd) + ALLOCATE( actSysInd(actSys) ) + actSys = 0 + DO ic = 1,maxSys + IF (sys(ic)%nPoints>0) THEN + actSys = actSys + 1 + actSysInd(actSys) = sys(ic)%sysInd + END IF + END DO - ELSE - OUTSIZE = 0 -!/ --- Calculate the range of the two sets. --- - MINV1 = INT(MINVAL(INARRAY1)) - MAXV1 = INT(MAXVAL(INARRAY1)) - MINV2 = INT(MINVAL(INARRAY2)) - MAXV2 = INT(MAXVAL(INARRAY2)) -! -!/ --- Allow extra elementes: ZERO, and make sure index is 1:N. --- - IMIN = MIN(MINV1,MINV2)-1 - IMAX = MAX(MAXV1,MAXV2)+1 - - N = IMAX-IMIN - - ALLOCATE(VIDX1(N),VIDX2(N)) - ALLOCATE(IPOS1(N),IPOS2(N)) - - VIDX1(1:N) = .FALSE. - VIDX2(1:N) = .FALSE. - IPOS1(1:N) = -9999 - IPOS2(1:N) = -9999 -!/ - DO I=1,INSIZE1 - J = INT(INARRAY1(I)-IMIN) - IF ( .NOT.VIDX1(J) ) THEN - OUTSIZE = OUTSIZE + 1 - VIDX1(J) = .TRUE. - IPOS1(J) = I - END IF - END DO + !opt WRITE(20,*) 'actSys =',actSys + !opt WRITE(20,*) 'actSysInd =',actSysInd + !opt DO ic = 1,SIZE(actSysInd) + !opt s = actSysInd(ic) + !opt WRITE(20,*) 'sys(',s,')%sysInd =',sys(s)%sysInd + !opt END DO + WRITE(20,*) 'Leaving combineSys...' + + RETURN + END SUBROUTINE combineSys + !/ End of combineSys ------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE combinePartitionsV2 (dat) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Combine two partitions that have been assigned to the same system + ! + ! 2. Method + ! + ! Of all the partitions associated with a certain common system, + ! add all the Hs values to the partition with the largest Hs, + ! and delete the rest. NOTE that the tp and dir values of this + ! maximum partition is not adjusted! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! dat TYPE(param) in/out Input data structure (partitions set) + ! to combine + ! + TYPE(param) :: dat + + INTENT (IN OUT) dat + ! + ! Local variables + ! ---------------------------------------------------------------- + TYPE duplicate + INTEGER :: val + INTEGER :: ndup + INTEGER :: ind(50) + END TYPE duplicate + + TYPE(duplicate) :: dup(100) !40.PAR + LOGICAL :: found + INTEGER :: nsys, ndup, p, pp, maxInd, npart, s, ss, ppp + REAL :: temp + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! - + ! + ! 5. Subroutines calling + ! + ! findSys + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + ! Find indices in dat%sys(:) of all partition associated with + ! the same wave system, and store them in the data structure + ! dup(1:nsys). Here nsys is the number of systems for which duplicates + ! were found, and dup(s)%ndup the number of partitions assigned + ! to the same system s. + nsys = 0 + dup(:)%ndup = 0 + dup(:)%val = 9999 + DO s = 1,100 + dup(s)%ind(:) = 0 + END DO - DO I=1,INSIZE2 - J = INT(INARRAY2(I)-IMIN) - IF ( .NOT.VIDX1(J).AND..NOT.VIDX2(J) ) THEN - OUTSIZE = OUTSIZE + 1 - VIDX2(J) = .TRUE. - IPOS2(J) = I + npart = LENGTH(REAL(dat%ipart),SIZE(dat%ipart),REAL(0)) + DO p = 1, npart-1 + found = .FALSE. + IF (ANY(dat%sys(p).EQ.dup(:)%val)) CYCLE !found = .TRUE. + DO pp = (p+1), npart + IF (dat%sys(p).EQ.dat%sys(pp)) THEN + ! First value + IF (.NOT.found) THEN + nsys=nsys+1 + dup(nsys)%val = dat%sys(p) + dup(nsys)%ndup = 1 + dup(nsys)%ind(dup(nsys)%ndup) = p + found = .TRUE. END IF - END DO + ! Subsequent duplicates + IF (.NOT.ANY(pp.EQ.dup(nsys)%ind(:))) THEN + dup(nsys)%ndup = dup(nsys)%ndup+1 + dup(nsys)%ind(dup(nsys)%ndup) = pp + END IF + END IF + END DO + END DO - ALLOCATE(OUTARRAY(OUTSIZE)) + ! Now go through array of duplicates for each of n systems + ! to add all the wave energy to the most energetic of the + ! duplicates, and then remove the rest. + maxInd = 0 + temp = -9999. + DO s = 1, nsys + ! Find duplicate partition with the largest Hs (most energy) + DO p = 1, dup(s)%ndup + IF ( temp.LT.dat%hs(dup(s)%ind(p)) ) THEN + temp = dat%hs(dup(s)%ind(p)) + maxInd = p + END IF + END DO - I = 1 - DO J=1,N - IF ( VIDX1(J).AND.I.LE.OUTSIZE ) THEN - OUTARRAY(I) = INARRAY1(IPOS1(J)) - I = I + 1 - ELSEIF ( VIDX2(J).AND.I.LE.OUTSIZE ) THEN - OUTARRAY(I) = INARRAY2(IPOS2(J)) - I = I + 1 - END IF - END DO + ! Add all energy (Hs) to this partition + dat%hs(dup(s)%ind(maxInd)) = & + SQRT( SUM(dat%hs(dup(s)%ind(1:dup(s)%ndup))**2) ) + + ! Remove duplicate partitions which did not have the maximum Hs, + ! and shift up indices to fill the gap + DO p = 1, dup(s)%ndup + ! Find index to remove + IF (p.NE.maxInd) THEN + ! Shift up entries, deleting the duplicate partition + ! REPLACE WITH CSHIFT(ARRAY, SHIFT, dim) ? + dat%hs( dup(s)%ind(p):(npart-1) ) = & + dat%hs( (dup(s)%ind(p)+1):npart) + dat%tp( dup(s)%ind(p):(npart-1) ) = & + dat%tp( (dup(s)%ind(p)+1):npart) + dat%dir( dup(s)%ind(p):(npart-1) ) = & + dat%dir( (dup(s)%ind(p)+1):npart) + dat%dspr( dup(s)%ind(p):(npart-1) ) = & + dat%dspr( (dup(s)%ind(p)+1):npart) + ! dat%wf( dup(s)%ind(p):(npart-1) ) = & + ! dat%wf( (dup(s)%ind(p)+1):npart) + dat%sys( dup(s)%ind(p):(npart-1) ) = & + dat%sys( (dup(s)%ind(p)+1):npart) + dat%ipart( dup(s)%ind(p):(npart-1) ) = & + dat%ipart( (dup(s)%ind(p)+1):npart) + ! Shift up indices + DO ss = 1, nsys + DO ppp = 1, dup(ss)%ndup + IF (dup(ss)%ind(ppp).GT.dup(s)%ind(p)) & + dup(ss)%ind(ppp) = dup(ss)%ind(ppp)-1 + END DO + END DO + ! Add blank to end + dat%hs(npart) = 9999. + dat%tp(npart) = 9999. + dat%dir(npart) = 9999. + dat%dspr(npart) = 9999. + ! dat%wf(npart) = 9999. + dat%sys(npart) = 9999 + dat%ipart(npart) = 0 + END IF + END DO + END DO - DEALLOCATE(VIDX1,VIDX2) - DEALLOCATE(IPOS1,IPOS2) + RETURN + END SUBROUTINE combinePartitionsV2 + !/ End of combinePartitionsV2 ---------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + REAL FUNCTION mean_angleV2(ang,ll) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Compute the mean direction from array of directions + ! + ! 2. Method + ! + ! ang is a column vector of angles + ! m_ang is the mean from a unit-vector average of ang + ! Assumes clockwise rotation from North = 0. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ang Real input Array of angles to average + ! ll Int input Length of ang + ! + REAL :: ang(ll) + INTEGER :: ll + ! + ! Local variables + ! ---------------------------------------------------------------- + ! u,v Real Arrays of u,v dir components to average + ! um,vm Real Mean u,v dir components + ! theta Real Mean direction relative to North + ! + REAL :: PI + PARAMETER (PI = 3.1416) + REAL :: u(ll), v(ll), vm, um, theta + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! - + ! + ! 5. Subroutines calling + ! + ! findSys + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + ! North and East components + v(:) = COS(ang(:)*(PI/180.)) + u(:) = SIN(ang(:)*(PI/180.)) + vm = SUM(v)/ll + um = SUM(u)/ll + + ! Compute mean magnitude and direction relative to North (from Upolar.m) + theta = (ATAN2(um,vm))*(180/PI) + + ! Convert inputs to radians, the to the -pi to pi range + ! (incorporated from original function xunwrapV2.m) + + ! Convert to radians + theta = theta*(PI/180) + + theta = PI*((ABS(theta)/PI) - & + 2*CEILING(((ABS(theta)/PI)-1)/2))*SIGN(1.,theta) + + ! Shift the points in the -pi to 0 range to the pi to 2pi range + IF (theta.LT.0.) theta = theta + 2*PI + + ! Convert back to degrees and return value + mean_angleV2 = theta*(180/PI) + + RETURN + END FUNCTION mean_angleV2 + !/ End of mean_angleV2 ----------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + REAL FUNCTION mean_angleV3(ang,hsign,ll) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Compute the mean direction from array of directions, + ! INCLUDING WEIGHTING WITH HMO + ! + ! 2. Method + ! + ! ang is a column vector of angles + ! m_ang is the mean from a unit-vector average of ang + ! Assumes clockwise rotation from North = 0. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ang Real input Array of angles to average + ! ll Int input Length of ang + ! + REAL :: ang(ll), hsign(ll) + REAL :: TEMP1, TEMP2 + INTEGER :: ll + ! + ! Local variables + ! ---------------------------------------------------------------- + ! u,v Real Arrays of u,v dir components to average + ! um,vm Real Mean u,v dir components + ! theta Real Mean direction relative to North + ! + REAL :: PI + PARAMETER (PI = 3.1416) + REAL :: u(ll), v(ll), vm, um, theta + INTEGER :: i + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! - + ! + ! 5. Subroutines calling + ! + ! findSys + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + ! North and East components + v(:) = COS(ang(:)*(PI/180.)) + u(:) = SIN(ang(:)*(PI/180.)) + TEMP1 = 0. + TEMP2 = 0. + DO i = 1,ll + TEMP1 = TEMP1 + (hsign(i)**2)*v(i) + TEMP2 = TEMP2 + (hsign(i)**2)*u(i) + END DO + vm = TEMP1/MAX(SUM(hsign**2),0.001) + um = TEMP2/MAX(SUM(hsign**2),0.001) + + ! Compute mean magnitude and direction relative to North (from Upolar.m) + theta = (ATAN2(um,vm))*(180/PI) + + ! Convert inputs to radians, the to the -pi to pi range + ! (incorporated from original function xunwrapV2.m) + + ! Convert to radians + theta = theta*(PI/180) + + theta = PI*((ABS(theta)/PI) - & + 2*CEILING(((ABS(theta)/PI)-1)/2))*SIGN(1.,theta) + + ! Shift the points in the -pi to 0 range to the pi to 2pi range + IF (theta.LT.0.) theta = theta + 2*PI + + ! Convert back to degrees and return value + mean_angleV3 = theta*(180/PI) + + RETURN + END FUNCTION mean_angleV3 + !/ End of mean_angleV3 ----------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE UNIQUE (INARRAY,INSIZE,OUTARRAY,OUTSIZE) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 22-Dec-2016 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ 12-Dec-2016 : Change algorithm from N*N to N*log(N) + !/ (S. Zieger BoM Australia) ( version 5.16 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Returns the sorted elements that are unique in INARRAY. + ! + ! 2. Method + ! + ! 1. Sort input array with quicksort + ! 2. Copy sequential-elements if the 'current' element + ! is not equal to the 'previous' element in array. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INARRAY REAL ARR input Input array + ! INSIZE INTEGER input Size of input array + ! OUTARRAY REAL ARR output Output array (sorted) + ! OUTSIZE INTEGER output Size of output array (number of unique elements) + ! + INTEGER, INTENT(IN) :: INSIZE + INTEGER, INTENT(OUT) :: OUTSIZE + REAL, INTENT(IN) :: INARRAY(INSIZE) + REAL, POINTER :: OUTARRAY(:) + ! + ! Local variables + ! ---------------------------------------------------------------- + INTEGER :: I, K + REAL :: ARRAY(INSIZE), TEMP(INSIZE) + ! + ! 4. Subroutines used : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! QSORT Subr. Private Quicksort algorithm + ! + ! 5. Subroutines calling + ! + ! waveTracking_NWS_V2 + ! findSys + ! printFinalSys + ! combineSys + ! findIJV4 + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + K = 1 + + IF ( INSIZE.EQ.0 ) THEN + WRITE(20,*) '*** In Subr. UNIQUE: Input array has length=0!' + ELSE + !/ --- Setup input arrays and temporary arrays. --- + DO I=1,INSIZE + ARRAY(I) = INARRAY(I) + TEMP(I) = REAL(I) + END DO + !/ + !/ --- Sort input arrays (use temporary array to store indices). --- + CALL QSORT(ARRAY,TEMP,1,INSIZE) + !/ + !/ --- Reset temporary array. --- + TEMP(:) = 9999. + !/ + !/ --- Initialise first values and array index. --- + K = 1 + TEMP(K) = ARRAY(K) + K = K + 1 + !/ --- Iterate over elements in array. --- + DO I=2,INSIZE + !/ --- Compare sequential array values ('previous' less than 'next') + !/ and test against the last list element check in. --- + IF ( ARRAY(I).GT.ARRAY(I-1) .AND. & + ARRAY(I).GT.TEMP(K-1) ) THEN + TEMP(K) = ARRAY(I) + K = K + 1 + END IF + END DO + !/ --- Allocate output array --- + OUTSIZE = K - 1 + ALLOCATE(OUTARRAY(OUTSIZE)) + !/ --- Transfer output from temporary array to output array. --- + IF ( OUTSIZE.GE.1 ) THEN + DO I=1,OUTSIZE + OUTARRAY(I) = TEMP(I) + END DO END IF -!/ - RETURN -!/ - END SUBROUTINE UNION -!/ End of UNION ------------------------------------------------------ / -!/ -!/ ------------------------------------------------------------------- / - INTEGER FUNCTION LENGTH(ARRAY,ARRSIZE,VAL) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Find largest index in ARRAY with a value not equal to the -! filler value VAL. -! E.g. If VAL = 9999. and ARRAY = [X X X X 9999. 9999. 9999.], -! the function returns 4. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- - INTEGER :: ARRSIZE - REAL :: ARRAY(ARRSIZE) - REAL :: VAL -! -! Local variables -! ---------------------------------------------------------------- - REAL :: FIELD - INTEGER :: I -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IF (ARRSIZE.GT.0) THEN - I = 1 - FIELD = ARRAY(I) - DO WHILE (FIELD.NE.VAL) - I = I+1 - IF (I.GT.SIZE(ARRAY)) EXIT - FIELD = ARRAY(I) - END DO - LENGTH = I-1 - ELSE - LENGTH = 0 - END IF + END IF + !/ + RETURN + !/ + END SUBROUTINE UNIQUE + !/ End of UNIQUE ----------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE SORT (INARRAY,INSIZE,OUTARRAY,IY,DIRECTION) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 20-Dec-2016 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ 20-Dec-2016 : Add quicksort algorithm (S. Zieger) ( version 5.16 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Sorts the array INARRAY in ascending (Direction = 'A') or + ! descending (Direciton = 'D') order. The sorted array is + ! stored in OUTARRAY, and the sorted array of the original + ! indices is stored in IY. + ! + ! 2. Method + ! + ! Sort algorithm based on quicksort. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INARRAY REAL ARR input Input array + ! INSIZE INTEGER input Size of input array + ! OUTARRAY REAL ARR output Sorted output array + ! IY INTEGER ARR output Sorted array of the original indices + + CHARACTER :: DIRECTION *1 + INTEGER :: INSIZE + INTEGER :: IY(INSIZE) + REAL :: INARRAY(INSIZE), OUTARRAY(INSIZE) + + INTENT (IN) INARRAY, INSIZE, DIRECTION + INTENT (OUT) OUTARRAY, IY + ! + ! Local variables + ! ---------------------------------------------------------------- + ! INARRAY - array of values to be sorted + ! IY - array to be carried with X (all swaps of X elements are ??? EDIT! + ! matched in IY . After the sort IY(J) contains the original + ! postition of the value X(J) in the unsorted X array. + ! N - number of values in array X to be sorted + + INTEGER :: I + REAL :: IND(INSIZE) + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! - + ! + ! 5. Subroutines calling + ! + ! printFinalSys + ! combineSys + ! timeTrackingV2 + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + ! Sort OUTARRAY in as/decending order + + IF (INSIZE.EQ.0) THEN + WRITE(20,*) '*** In Subr. SORT: Input array has length=0 !!!' + ELSE - RETURN - END FUNCTION LENGTH -!/ End of LENGTH ----------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - INTEGER FUNCTION FINDFIRST(ARRAY,ARRSIZE,VAL) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Fast algorithm to find the *first* index IND in ARRAY -! for which ARRAY(IND) = VAL. Use only when there are -! no duplicates in ARRAY! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- - INTEGER :: ARRSIZE - REAL :: ARRAY(ARRSIZE) - REAL :: VAL -! -! Local variables -! ---------------------------------------------------------------- - INTEGER :: IND -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IND = 1 - DO WHILE (IND.LE.ARRSIZE) - IF ( ARRAY(IND).EQ.VAL ) EXIT - IND = IND + 1 + DO I = 1, INSIZE + OUTARRAY(I) = INARRAY(I) + IND(I) = REAL(I) END DO - IF (IND.GT.ARRSIZE) THEN - FINDFIRST = 0 - ELSE - FINDFIRST = IND - ENDIF - RETURN - END FUNCTION FINDFIRST -!/ End of FINDFIRST -------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / - REAL FUNCTION STD(ARRAY,N) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 4-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Computes standard deviation. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ARRAY REAL Input array for which to compute the std dev. -! N INT Size of ARRAY -! - REAL :: ARRAY(N) - INTEGER :: N -! -! Local variables -! ---------------------------------------------------------------- - REAL :: MN -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IF (N.GT.1) THEN - MN = SUM(ARRAY)/N - STD = SQRT( 1/(REAL(N)-1)*SUM( (ARRAY(:)-MN)**2 ) ) - ELSE - STD = 0. + IF (DIRECTION .EQ. 'A') THEN + CALL QSORT(OUTARRAY,IND,1,INSIZE) + ELSE IF (DIRECTION .EQ. 'D') THEN + CALL QSORT_DESC(OUTARRAY,IND,1,INSIZE) END IF - RETURN - END FUNCTION STD -!/ End of STD -------------------------------------------------------- / -!/ - RECURSIVE SUBROUTINE QSORT(ARRAY,IDX,LO,HI) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Stefan Zieger | -!/ | FORTRAN 95 | -!/ | Last update : 6-Sep-2016 | -!/ +-----------------------------------+ -!/ -!/ 06-Sep-2016 : Origination, based on code by Mirko ( version 5.16 ) -!/ Velic (BoM, Australia) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! -! 1. Purpose : -! -! Quicksort algorithm. -! -! 2. Method -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ARRAY REAL ARR in/out Input array -! IDX REAL ARR in/out Original indices of input array -! LO INTEGER input First element -! HI INTEGER input Last element -! - IMPLICIT NONE -!/ - INTEGER, INTENT(IN) :: LO,HI - REAL,INTENT(INOUT) :: ARRAY(:),IDX(:) -!/ -! Local variables -! ---------------------------------------------------------------- - LOGICAL :: LOOP - INTEGER :: TOP, BOT - REAL :: VAL, TMP -! -! 4. Subroutines used : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! -! 5. Subroutines calling -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -!/ --- Check array size and bounds. --- - IF ( SIZE(ARRAY).EQ. 0 ) THEN - WRITE(6,199) - CALL ABORT - ELSE IF ( SIZE(ARRAY).NE.SIZE(IDX) ) THEN - WRITE(6,201) - CALL ABORT - ELSE IF ( LBOUND(ARRAY,1).GT.LO ) THEN - WRITE(6,203) - CALL ABORT - ELSE IF ( UBOUND(ARRAY,1).LT.HI ) THEN - WRITE(6,205) - CALL ABORT - END IF -! - TOP = LO - BOT = HI - VAL = ARRAY(INT((LO+HI)/2)) -! + END IF + ! + !/ --- Cast index array to integer. --- + DO I = 1, INSIZE + IY(I) = INT(IND(I)) + END DO + ! + RETURN + ! + END SUBROUTINE SORT + !/ End of SORT ------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE SETDIFF (INARRAY1, INSIZE1, INARRAY2, INSIZE2, & + OUTARRAY, OUTSIZE) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 20-Dec-2016 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ 20-Dec-2016 : Add quicksort algorithm (S.Zieger) ( version 5.16 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! (i) Returns the elements in INARRAY1 that are not in INARRAY2. + ! (ii) Sort the resulting array in ascending order. + ! + ! 2. Method + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INARRAY1 REAL ARR input Input array + ! INSIZE1 INTEGER input Size of input array + ! INARRAY2 REAL ARR input Input array + ! INSIZE2 INTEGER input Size of input array + ! OUTARRAY REAL ARR output Output array + ! OUTSIZE INTEGER output Size of output array (number of unique elements) + + INTEGER :: INSIZE1, INSIZE2, OUTSIZE + REAL :: INARRAY1(INSIZE1), INARRAY2(INSIZE2) + REAL, POINTER :: OUTARRAY(:) + + INTENT (IN) INARRAY1, INSIZE1, INARRAY2, INSIZE2 + INTENT (OUT) OUTSIZE + ! + ! Local variables + ! ---------------------------------------------------------------- + INTEGER :: I,J,K + REAL :: TEMP(INSIZE1) + REAL :: ARRAY1(INSIZE1),ARRAY2(INSIZE2) + REAL :: ID1(INSIZE1),ID2(INSIZE2) + LOGICAL :: LOOP + ! + ! 4. Subroutines used : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! QSORT Subr. Private Quicksort algorithm + ! + ! 5. Subroutines calling + ! + ! printFinalSys + ! combineSys + ! timeTrackingV2 + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IF ( (INSIZE1).EQ.0 ) THEN + OUTSIZE = 0 + ALLOCATE(OUTARRAY(OUTSIZE)) + ELSE IF ( INSIZE2.EQ.0 ) THEN + CALL UNIQUE(INARRAY1,INSIZE1,OUTARRAY,OUTSIZE) + ELSE + !/ --- Setup input arrays. --- + DO I=1,INSIZE1 + ARRAY1(I) = INARRAY1(I) + ID1(I) = REAL(I) + END DO + DO I=1,INSIZE2 + ARRAY2(I) = INARRAY2(I) + ID2(I) = REAL(I) + END DO + !/ + !/ --- Sort input arrays. --- + CALL QSORT(ARRAY1,ID1,1,INSIZE1) + CALL QSORT(ARRAY2,ID2,1,INSIZE2) + !/ + !/ --- Initialise indices. --- + I = 1 + J = 1 + K = 1 + !/ + !/ --- Allocate and initialize temporary output --- + TEMP(:) = 9999. + !/ + !/ --- Loop though both arrays by incrementing I,J. --- LOOP = .TRUE. DO WHILE ( LOOP ) - DO WHILE ( ARRAY(TOP).LT.VAL ) - TOP = TOP + 1 - END DO - DO WHILE ( VAL.LT.ARRAY(BOT) ) - BOT = BOT - 1 - END DO - IF ( TOP.LT.BOT ) THEN -!/ --- Swap values at indices TOP and BOT --- - TMP = ARRAY(TOP) - ARRAY(TOP) = ARRAY(BOT) - ARRAY(BOT) = TMP -!/ --- Swap index values at indices TOP and BOT --- - TMP = IDX(TOP) - IDX(TOP) = IDX(BOT) - IDX(BOT) = TMP -! - TOP = TOP + 1 - BOT = BOT - 1 + !/ + IF ( ARRAY1(I).LT.ARRAY2(J) .OR. & + ARRAY1(I).GT.ARRAY2(INSIZE2) ) THEN + !/ --- Populate output array. Check for dumplicates + !/ in output array. --- + IF ( K.EQ.1 ) THEN + TEMP(K) = ARRAY1(I) + K = K + 1 + ELSE IF ( TEMP(K-1).LT.ARRAY1(I) ) THEN + TEMP(K) = ARRAY1(I) + K = K + 1 + END IF + I = I + 1 + ELSE IF ( ARRAY2(J).LT.ARRAY1(I) ) THEN + J = J + 1 ELSE + I = I + 1 + J = J + 1 + END IF + !/ --- Check for exit the loop. --- + IF ( I.GT.INSIZE1 ) THEN LOOP = .FALSE. END IF - + !/ --- Make sure array pointer I,J are within array bounds. --- + I = MIN(I,INSIZE1) + J = MIN(J,INSIZE2) + !/ + END DO + !/ + !/ --- Allocate output array --- + OUTSIZE = K-1 + ALLOCATE(OUTARRAY(OUTSIZE)) + !/ --- Transfer output from temporary array to output array. --- + DO I=1,OUTSIZE + OUTARRAY(I) = TEMP(I) + END DO + END IF + !/ + RETURN + !/ + END SUBROUTINE SETDIFF + !/ End of SETDIFF ---------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE INTERSECT (INARRAY1 ,INSIZE1 ,INARRAY2 ,INSIZE2 , & + OUTARRAY ,OUTSIZE ,IND1 ,IND2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 20-Dec-2016 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ 20-Dec-2016 : Add count-histogram method based on + !/ algorithm from Mirko Velic (BoM) + !/ (S. Zieger BoM, Australia) ( version 5.16 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! (i) Returns the elements that are mutual in INARRAY1 and INARRAY2. + ! (ii) Sort the resulting array in ascending order. + ! + ! 2. Method + ! + ! Sort with counting/histogram method with input array being + ! cast as integer. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INARRAY1 REAL ARR input Input array + ! INSIZE1 INTEGER input Size of input array + ! INARRAY2 REAL ARR input Input array + ! INSIZE2 INTEGER input Size of input array + ! OUTARRAY REAL ARR output Output array + ! OUTSIZE INTEGER output Size of output array (number of + ! intersects) + ! + INTEGER :: INSIZE1, INSIZE2, OUTSIZE + REAL :: INARRAY1(INSIZE1), INARRAY2(INSIZE2) + REAL, POINTER :: OUTARRAY(:) + REAL, POINTER :: IND1(:), IND2(:) + ! + INTENT (IN) INARRAY1, INSIZE1, INARRAY2, INSIZE2 + INTENT (OUT) OUTSIZE + ! + ! Local variables + ! ---------------------------------------------------------------- + ! VIDX1, VIDX2 - array(s) in which the value is represented by + ! its index (i.e. histogram with frequency 1) + ! N - data range and size of possible intersections. + ! + LOGICAL,ALLOCATABLE :: VIDX1(:),VIDX2(:) + INTEGER,ALLOCATABLE :: IPOS1(:),IPOS2(:) + ! + INTEGER :: I, J + INTEGER :: N, IMIN, IMAX + INTEGER :: MINV1,MAXV1, MINV2, MAXV2 + ! + ! 4. Subroutines used : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! + ! 5. Subroutines calling + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + OUTSIZE = 0 + + !/ --- Calculate the range of the two sets. --- + MINV1 = INT(MINVAL(INARRAY1)) + MAXV1 = INT(MAXVAL(INARRAY1)) + MINV2 = INT(MINVAL(INARRAY2)) + MAXV2 = INT(MAXVAL(INARRAY2)) + + !/ --- Check if ranges overlap. --- + IF ( MAXV1.LT.MINV2.OR.INSIZE1.EQ.0.OR.INSIZE2.EQ.0 ) THEN + ALLOCATE(OUTARRAY(OUTSIZE)) + ALLOCATE(IND1(OUTSIZE)) + ALLOCATE(IND2(OUTSIZE)) + ELSE + !/ --- Calculate size of temporary output arrays. Allow + !/ extra elements: ZERO, and make sure index is 1:N. --- + IMIN = MIN(MINV1,MINV2)-1 + IMAX = MAX(MAXV1,MAXV2)+1 + + N = IMAX-IMIN + + ALLOCATE(VIDX1(N),VIDX2(N)) + ALLOCATE(IPOS1(N),IPOS2(N)) + + VIDX1(1:N) = .FALSE. + VIDX2(1:N) = .FALSE. + + DO I=1,INSIZE1 + J = INT(INARRAY1(I)-IMIN) + VIDX1(J) = .TRUE. + IPOS1(J) = I END DO -!/ --- Recursive call quicksort --- - IF (LO.LT.TOP-1) CALL QSORT(ARRAY,IDX,LO,TOP-1) - IF (BOT+1.LT.HI) CALL QSORT(ARRAY,IDX,BOT+1,HI) -! - RETURN -!/ - 199 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' QSORT ARRAY IS EMPTY' ) - 201 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' QSORT ARRAY SIZE AND INDEX ARRAY SIZE MISMATCH' ) - 203 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' QSORT ARRAY INDEX OUT OF LOWER BOUND' ) - 205 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' QSORT ARRAY INDEX OUT OF UPPER BOUND' ) -!/ - END SUBROUTINE QSORT -!/ ------------------------------------------------------------------- / -!/ - RECURSIVE SUBROUTINE QSORT_DESC(ARRAY,IDX,LO,HI) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Stefan Zieger | -!/ | FORTRAN 95 | -!/ | Last update : 6-Sep-2016 | -!/ +-----------------------------------+ -!/ -!/ 06-Sep-2016 : Origination, based on code by Mirko ( version 5.16 ) -!/ Velic (BoM, AUstralia) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! -! 1. Purpose : -! -! Quicksort algorithm with descending sort order. -! -! 2. Method -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ARRAY REAL ARR in/out Input array -! LO INTEGER input First element -! HI INTEGER input Last element -! - IMPLICIT NONE -!/ - INTEGER, INTENT(IN) :: LO,HI - REAL,INTENT(INOUT) :: ARRAY(:),IDX(:) -!/ -! Local variables -! ---------------------------------------------------------------- - INTEGER :: TOP, BOT, I - REAL :: VAL, TMP - LOGICAL :: LOOP -! -! 4. Subroutines used : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! -! 5. Subroutines calling -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -!/ --- Check array size and bounds. --- - IF ( SIZE(ARRAY).EQ. 0 ) THEN - WRITE(6,199) - CALL ABORT - ELSE IF ( SIZE(ARRAY).NE.SIZE(IDX) ) THEN - WRITE(6,201) - CALL ABORT - ELSE IF ( LBOUND(ARRAY,1).GT.LO ) THEN - WRITE(6,203) - CALL ABORT - ELSE IF ( UBOUND(ARRAY,1).LT.HI ) THEN - WRITE(6,205) - CALL ABORT - END IF -! - TOP = LO - BOT = HI - VAL = ARRAY(INT((LO+HI)/2)) -! - LOOP = .TRUE. - DO WHILE ( LOOP ) - DO WHILE ( ARRAY(TOP).GT.VAL ) - TOP = TOP + 1 - END DO - DO WHILE ( VAL.GT.ARRAY(BOT) ) - BOT = BOT - 1 - END DO - IF ( TOP.LT.BOT ) THEN -!/ --- Swap values at indices TOP and BOT --- - TMP = ARRAY(TOP) - ARRAY(TOP) = ARRAY(BOT) - ARRAY(BOT) = TMP -!/ --- Swap index values at indices TOP and BOT --- - TMP = IDX(TOP) - IDX(TOP) = IDX(BOT) - IDX(BOT) = TMP -! - TOP = TOP + 1 - BOT = BOT - 1 - ELSE - LOOP = .FALSE. + DO I=1,INSIZE2 + J = INT(INARRAY2(I)-IMIN) + !/ --- Intersect arrays and check for + !/ duplicate elements in array2. --- + IF ( VIDX1(J).AND..NOT.VIDX2(J) ) THEN + OUTSIZE = OUTSIZE + 1 + VIDX2(J) = .TRUE. + IPOS2(J) = I + END IF + END DO + !/ --- Allocate output arrays. --- + ALLOCATE(OUTARRAY(OUTSIZE)) + ALLOCATE(IND1(OUTSIZE)) + ALLOCATE(IND2(OUTSIZE)) + !/ --- Transfer contents. --- + I = 1 + DO J=1,N + IF ( VIDX1(J).AND.VIDX2(J).AND.I.LE.OUTSIZE ) THEN + OUTARRAY(I) = INARRAY1(IPOS1(J)) + IND1(I) = IPOS1(J) + IND2(I) = IPOS2(J) + I = I + 1 END IF + END DO + !/ --- Free memory. --- + DEALLOCATE(VIDX1,VIDX2) + DEALLOCATE(IPOS1,IPOS2) + END IF + !/ + RETURN + !/ + END SUBROUTINE INTERSECT + !/ End of INTERSECT -------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + SUBROUTINE UNION (INARRAY1, INSIZE1, INARRAY2, INSIZE2, & + OUTARRAY, OUTSIZE) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ 20-Dec-2016 : Add count-histogram method similarly + !/ to INTERSECT (S. Zieger) ( version 5.16 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! (i) Returns the union of INARRAY1 and INARRAY2. + ! (ii) Sort the resulting array in ascending order. + ! + ! 2. Method + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INARRAY REAL ARR input Input array + ! INSIZE INTEGER input Size of input array + ! OUTARRAY REAL ARR output Output array (sorted) + ! OUTSIZE INTEGER output Size of output array (number of + ! unique elements) + INTEGER :: INSIZE1, INSIZE2, OUTSIZE + REAL :: INARRAY1(INSIZE1), INARRAY2(INSIZE2) + REAL, POINTER :: OUTARRAY(:) + ! + INTENT (IN) INARRAY1, INSIZE1, INARRAY2, INSIZE2 + INTENT (OUT) OUTSIZE + ! + ! Local variables + ! ---------------------------------------------------------------- + ! VIDX1, VIDX2 - array(s) in which the value is represented by + ! its index (i.e. histogram with frequency 1) + ! N - data range and size of possible intersections. + ! + LOGICAL,ALLOCATABLE :: VIDX1(:),VIDX2(:) + INTEGER,ALLOCATABLE :: IPOS1(:),IPOS2(:) + REAL,ALLOCATABLE :: TEMP(:) + ! + INTEGER :: I, J + INTEGER :: N, IMIN, IMAX + INTEGER :: MINV1,MAXV1, MINV2, MAXV2 + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! QSORT Subr. Private Quicksort algorithm + ! + ! 5. Subroutines calling + ! + ! combineSys + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! - + ! + ! 9. Switches : + ! + ! None defined yet. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ --- Setup input arrays. --- + IF ( (INSIZE1+INSIZE2).EQ.0 ) THEN + OUTSIZE = 0 + ALLOCATE(OUTARRAY(OUTSIZE)) + + ELSEIF ( INSIZE1.EQ.0 ) THEN + OUTSIZE = INSIZE2 + ALLOCATE(OUTARRAY(OUTSIZE)) + ALLOCATE(TEMP(OUTSIZE)) + DO I=1,OUTSIZE + OUTARRAY(I) = INARRAY2(I) + TEMP(I) = REAL(I) END DO -!/ --- Recursive call quicksort --- - IF (LO.LT.TOP-1) CALL QSORT_DESC(ARRAY,IDX,LO,TOP-1) - IF (BOT+1.LT.HI) CALL QSORT_DESC(ARRAY,IDX,BOT+1,HI) -! - RETURN -!/ - 199 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' QSORT ARRAY IS EMPTY' ) - 201 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' QSORT ARRAY SIZE AND INDEX ARRAY SIZE MISMATCH' ) - 203 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' QSORT ARRAY INDEX OUT OF LOWER BOUND' ) - 205 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' QSORT ARRAY INDEX OUT OF UPPER BOUND' ) -!/ - END SUBROUTINE QSORT_DESC -!/ ------------------------------------------------------------------- / -!/ - FUNCTION SWAPI4(INT4) RESULT(INT4SWP) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 03-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 03-Jan-2017 : Origination ( version 5.16 ) -!/ (S. Zieger) -!/ -! 1. Purpose : -! -! Return a Byte-swapped integer (size of 4 bytes) -! -! 2. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - INTEGER(KIND=4), INTENT(IN) :: INT4 - INTEGER(KIND=4) :: INT4SWP -!/ -! Local variables -! ---------------------------------------------------------------- - INTEGER(KIND=1), DIMENSION(4) :: BYTEIN, BYTEOUT -!/ - BYTEIN = TRANSFER(INT4, BYTEIN) - BYTEOUT = (/BYTEIN(4),BYTEIN(3),BYTEIN(2),BYTEIN(1)/) - INT4SWP = TRANSFER(BYTEOUT, INT4SWP) -!/ - RETURN -!/ - END FUNCTION SWAPI4 -!/ ------------------------------------------------------------------- / - SUBROUTINE findIJV4 (a ,b ,maxI, maxJ ,indA ,indB ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 03-Mar-2017 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ 03-Mar-2017 : Calls to INTERSECT and UNION ( version 5.16 ) -!/ replaced (S. Zieger, BoM, Australia) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - IMPLICIT NONE -! -! 1. Purpose : -! -! Find a(i,j) indices of system "a" that lie over or along the -! fringes of system "b". -! -! 2. Method -! -! (i) Use an index matrix to map locations of wave systems in B -! (ii) Avoid multiple use of INTERSECT and UNION as in findIJV3 -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! a, b Type(system) input Final set of tracked systems, for one time level -! maxI Int input Number rows indices of wave field -! maxJ Int input Number column indices of wave field -! indA*, indB* Int.A. output Pointer array of indices for combining systems -! - TYPE(system) :: a, b - INTEGER :: maxI, maxJ - INTEGER, POINTER :: indA(:), indB(:) -! - INTENT (IN) a, b, maxI,maxJ -! -! Local variables -! ---------------------------------------------------------------- -! posB Int Neighbour index -! posB_MM Int Neighbour index (-1,-1) -! posB_MP Int Neighbour index (-1,+1) -! posB_PM Int Neighbour index (+1,-1) -! posB_PP Int Neighbour index (+1,+1) -! tmpA*, tmpB* Int.A. Array of indices for combining -! systems -! - INTEGER :: LENG_AI,LENG_BI - INTEGER :: OUTA,OUTB,I,J,IND,OUTDUMB - INTEGER :: POSB,POSB_MM,POSB_PM,POSB_MP,POSB_PP - INTEGER :: IND_B2(maxI,maxJ) - REAL,ALLOCATABLE :: TMPA(:),DUMA(:),TMPB(:) - REAL,POINTER :: DUMB(:) - LOGICAL :: FOUND -! -! 4. Subroutines used : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! QSORT Subr. Private Quicksort algorithm -! UNIQUE Subr. Private Return sorted unique numbers of an array -! -! 5. Subroutines calling -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - NULLIFY(DUMB) -! - IF (ASSOCIATED(INDA)) DEALLOCATE(INDA) - IF (ASSOCIATED(INDB)) DEALLOCATE(INDB) -! - LENG_AI = LENGTH(REAL(a%i),SIZE(a%i),REAL(9999)) - LENG_BI = LENGTH(REAL(b%i),SIZE(b%i),REAL(9999)) -! - ALLOCATE(TMPA(LENG_AI)) - ALLOCATE(TMPB(5*LENG_AI)) -! - TMPA(:) = 9999. - TMPB(:) = 9999. -! - OUTA = 0 - OUTB = 0 - IND_B2(:,:) = 0 -! - DO IND=1,LENG_BI - I = B%I(IND) - J = B%J(IND) - IF (IND_B2(I,J).EQ.0) IND_B2(I,J) = IND + CALL QSORT(OUTARRAY,TEMP,1,OUTSIZE) + + ELSEIF ( INSIZE2.EQ.0 ) THEN + OUTSIZE = INSIZE1 + ALLOCATE(OUTARRAY(OUTSIZE),TEMP(OUTSIZE)) + + DO I=1,OUTSIZE + OUTARRAY(I) = INARRAY1(I) + TEMP(I) = REAL(I) END DO -! - DO IND=1,LENG_AI - I = A%I(IND) - J = A%J(IND) - POSB = IND_B2(I,J) - POSB_MM = 0 - POSB_PP = 0 - POSB_MP = 0 - POSB_PM = 0 - IF (I.GT.1.AND.J.GT.1) POSB_MM = IND_B2(i-1,j-1) - IF (I.GT.1.AND.J.LT.MAXJ) POSB_MP = IND_B2(i-1,j+1) - IF (I.LT.MAXI.AND.J.LT.MAXJ) POSB_PP = IND_B2(i+1,j+1) - IF (I.LT.MAXI.AND.J.GT.1) POSB_PM = IND_B2(i+1,j-1) - - FOUND = .FALSE. - IF (POSB.NE.0) THEN - OUTB = OUTB + 1 - TMPB(OUTB) = REAL(POSB) - IF (.NOT.FOUND) THEN - OUTA = OUTA + 1 - TMPA(OUTA) = REAL(IND) - FOUND = .TRUE. - END IF - END IF - IF (POSB_MM.NE.0) THEN - OUTB = OUTB + 1 - TMPB(OUTB) = REAL(POSB_MM) - IF (.NOT.FOUND) THEN - OUTA = OUTA + 1 - TMPA(OUTA) = REAL(IND) - FOUND = .TRUE. - END IF - END IF - IF (POSB_MP.NE.0) THEN - OUTB = OUTB + 1 - TMPB(OUTB) = REAL(POSB_MP) - IF (.NOT.FOUND) THEN - OUTA = OUTA + 1 - TMPA(OUTA) = REAL(IND) - FOUND = .TRUE. - END IF + CALL QSORT(OUTARRAY,TEMP,1,OUTSIZE) + + ELSE + OUTSIZE = 0 + !/ --- Calculate the range of the two sets. --- + MINV1 = INT(MINVAL(INARRAY1)) + MAXV1 = INT(MAXVAL(INARRAY1)) + MINV2 = INT(MINVAL(INARRAY2)) + MAXV2 = INT(MAXVAL(INARRAY2)) + ! + !/ --- Allow extra elementes: ZERO, and make sure index is 1:N. --- + IMIN = MIN(MINV1,MINV2)-1 + IMAX = MAX(MAXV1,MAXV2)+1 + + N = IMAX-IMIN + + ALLOCATE(VIDX1(N),VIDX2(N)) + ALLOCATE(IPOS1(N),IPOS2(N)) + + VIDX1(1:N) = .FALSE. + VIDX2(1:N) = .FALSE. + IPOS1(1:N) = -9999 + IPOS2(1:N) = -9999 + !/ + DO I=1,INSIZE1 + J = INT(INARRAY1(I)-IMIN) + IF ( .NOT.VIDX1(J) ) THEN + OUTSIZE = OUTSIZE + 1 + VIDX1(J) = .TRUE. + IPOS1(J) = I END IF - IF (POSB_PM.NE.0) THEN - OUTB = OUTB + 1 - TMPB(OUTB) = REAL(POSB_PM) - IF (.NOT.FOUND) THEN - OUTA = OUTA + 1 - TMPA(OUTA) = REAL(IND) - FOUND = .TRUE. - END IF + END DO + + DO I=1,INSIZE2 + J = INT(INARRAY2(I)-IMIN) + IF ( .NOT.VIDX1(J).AND..NOT.VIDX2(J) ) THEN + OUTSIZE = OUTSIZE + 1 + VIDX2(J) = .TRUE. + IPOS2(J) = I END IF - IF (POSB_PP.NE.0) THEN - OUTB = OUTB + 1 - TMPB(OUTB) = REAL(POSB_PP) - IF (.NOT.FOUND) THEN - OUTA = OUTA + 1 - TMPA(OUTA) = REAL(IND) - FOUND = .TRUE. - END IF + END DO + + ALLOCATE(OUTARRAY(OUTSIZE)) + + I = 1 + DO J=1,N + IF ( VIDX1(J).AND.I.LE.OUTSIZE ) THEN + OUTARRAY(I) = INARRAY1(IPOS1(J)) + I = I + 1 + ELSEIF ( VIDX2(J).AND.I.LE.OUTSIZE ) THEN + OUTARRAY(I) = INARRAY2(IPOS2(J)) + I = I + 1 END IF + END DO + DEALLOCATE(VIDX1,VIDX2) + DEALLOCATE(IPOS1,IPOS2) + + END IF + !/ + RETURN + !/ + END SUBROUTINE UNION + !/ End of UNION ------------------------------------------------------ / + !/ + !/ ------------------------------------------------------------------- / + INTEGER FUNCTION LENGTH(ARRAY,ARRSIZE,VAL) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Find largest index in ARRAY with a value not equal to the + ! filler value VAL. + ! E.g. If VAL = 9999. and ARRAY = [X X X X 9999. 9999. 9999.], + ! the function returns 4. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + INTEGER :: ARRSIZE + REAL :: ARRAY(ARRSIZE) + REAL :: VAL + ! + ! Local variables + ! ---------------------------------------------------------------- + REAL :: FIELD + INTEGER :: I + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IF (ARRSIZE.GT.0) THEN + I = 1 + FIELD = ARRAY(I) + DO WHILE (FIELD.NE.VAL) + I = I+1 + IF (I.GT.SIZE(ARRAY)) EXIT + FIELD = ARRAY(I) + END DO + LENGTH = I-1 + ELSE + LENGTH = 0 + END IF + + RETURN + END FUNCTION LENGTH + !/ End of LENGTH ----------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + INTEGER FUNCTION FINDFIRST(ARRAY,ARRSIZE,VAL) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Fast algorithm to find the *first* index IND in ARRAY + ! for which ARRAY(IND) = VAL. Use only when there are + ! no duplicates in ARRAY! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + INTEGER :: ARRSIZE + REAL :: ARRAY(ARRSIZE) + REAL :: VAL + ! + ! Local variables + ! ---------------------------------------------------------------- + INTEGER :: IND + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IND = 1 + DO WHILE (IND.LE.ARRSIZE) + IF ( ARRAY(IND).EQ.VAL ) EXIT + IND = IND + 1 + END DO + IF (IND.GT.ARRSIZE) THEN + FINDFIRST = 0 + ELSE + FINDFIRST = IND + ENDIF + + RETURN + END FUNCTION FINDFIRST + !/ End of FINDFIRST -------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + REAL FUNCTION STD(ARRAY,N) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 4-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Computes standard deviation. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ARRAY REAL Input array for which to compute the std dev. + ! N INT Size of ARRAY + ! + REAL :: ARRAY(N) + INTEGER :: N + ! + ! Local variables + ! ---------------------------------------------------------------- + REAL :: MN + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IF (N.GT.1) THEN + MN = SUM(ARRAY)/N + STD = SQRT( 1/(REAL(N)-1)*SUM( (ARRAY(:)-MN)**2 ) ) + ELSE + STD = 0. + END IF + + RETURN + END FUNCTION STD + !/ End of STD -------------------------------------------------------- / + !/ + RECURSIVE SUBROUTINE QSORT(ARRAY,IDX,LO,HI) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Stefan Zieger | + !/ | FORTRAN 95 | + !/ | Last update : 6-Sep-2016 | + !/ +-----------------------------------+ + !/ + !/ 06-Sep-2016 : Origination, based on code by Mirko ( version 5.16 ) + !/ Velic (BoM, Australia) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! + ! 1. Purpose : + ! + ! Quicksort algorithm. + ! + ! 2. Method + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ARRAY REAL ARR in/out Input array + ! IDX REAL ARR in/out Original indices of input array + ! LO INTEGER input First element + ! HI INTEGER input Last element + ! + IMPLICIT NONE + !/ + INTEGER, INTENT(IN) :: LO,HI + REAL,INTENT(INOUT) :: ARRAY(:),IDX(:) + !/ + ! Local variables + ! ---------------------------------------------------------------- + LOGICAL :: LOOP + INTEGER :: TOP, BOT + REAL :: VAL, TMP + ! + ! 4. Subroutines used : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! + ! 5. Subroutines calling + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + !/ --- Check array size and bounds. --- + IF ( SIZE(ARRAY).EQ. 0 ) THEN + WRITE(6,199) + CALL ABORT + ELSE IF ( SIZE(ARRAY).NE.SIZE(IDX) ) THEN + WRITE(6,201) + CALL ABORT + ELSE IF ( LBOUND(ARRAY,1).GT.LO ) THEN + WRITE(6,203) + CALL ABORT + ELSE IF ( UBOUND(ARRAY,1).LT.HI ) THEN + WRITE(6,205) + CALL ABORT + END IF + ! + TOP = LO + BOT = HI + VAL = ARRAY(INT((LO+HI)/2)) + ! + LOOP = .TRUE. + DO WHILE ( LOOP ) + DO WHILE ( ARRAY(TOP).LT.VAL ) + TOP = TOP + 1 + END DO + DO WHILE ( VAL.LT.ARRAY(BOT) ) + BOT = BOT - 1 END DO -! -!/ Compact indices for wave systems in B. -!/ Check for empty arrays first. - IF (OUTB.GT.0) THEN - CALL UNIQUE(TMPB,OUTB,DUMB,OUTDUMB) - OUTB = OUTDUMB + IF ( TOP.LT.BOT ) THEN + !/ --- Swap values at indices TOP and BOT --- + TMP = ARRAY(TOP) + ARRAY(TOP) = ARRAY(BOT) + ARRAY(BOT) = TMP + !/ --- Swap index values at indices TOP and BOT --- + TMP = IDX(TOP) + IDX(TOP) = IDX(BOT) + IDX(BOT) = TMP + ! + TOP = TOP + 1 + BOT = BOT - 1 + ELSE + LOOP = .FALSE. END IF - ALLOCATE(INDB(OUTB)) - IF (OUTB.GT.0) INDB(1:OUTB) = INT(DUMB(1:OUTB)) - IF (ASSOCIATED(DUMB)) DEALLOCATE(DUMB) -! -!/ Allocate output array and transfer content -!/ for wave systems in A. - ALLOCATE(INDA(OUTA)) - IF (OUTA.GT.0) THEN - ALLOCATE(DUMA(OUTA)) - DUMA(:) = 0 - CALL QSORT(TMPA(1:OUTA),DUMA(1:OUTA),1,OUTA) - IF (ALLOCATED(DUMA)) DEALLOCATE(DUMA) - INDA(1:OUTA) = INT(TMPA(1:OUTA)) + + END DO + + !/ --- Recursive call quicksort --- + IF (LO.LT.TOP-1) CALL QSORT(ARRAY,IDX,LO,TOP-1) + IF (BOT+1.LT.HI) CALL QSORT(ARRAY,IDX,BOT+1,HI) + ! + RETURN + !/ +199 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' QSORT ARRAY IS EMPTY' ) +201 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' QSORT ARRAY SIZE AND INDEX ARRAY SIZE MISMATCH' ) +203 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' QSORT ARRAY INDEX OUT OF LOWER BOUND' ) +205 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' QSORT ARRAY INDEX OUT OF UPPER BOUND' ) + !/ + END SUBROUTINE QSORT + !/ ------------------------------------------------------------------- / + !/ + RECURSIVE SUBROUTINE QSORT_DESC(ARRAY,IDX,LO,HI) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Stefan Zieger | + !/ | FORTRAN 95 | + !/ | Last update : 6-Sep-2016 | + !/ +-----------------------------------+ + !/ + !/ 06-Sep-2016 : Origination, based on code by Mirko ( version 5.16 ) + !/ Velic (BoM, AUstralia) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! + ! 1. Purpose : + ! + ! Quicksort algorithm with descending sort order. + ! + ! 2. Method + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ARRAY REAL ARR in/out Input array + ! LO INTEGER input First element + ! HI INTEGER input Last element + ! + IMPLICIT NONE + !/ + INTEGER, INTENT(IN) :: LO,HI + REAL,INTENT(INOUT) :: ARRAY(:),IDX(:) + !/ + ! Local variables + ! ---------------------------------------------------------------- + INTEGER :: TOP, BOT, I + REAL :: VAL, TMP + LOGICAL :: LOOP + ! + ! 4. Subroutines used : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! + ! 5. Subroutines calling + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + !/ --- Check array size and bounds. --- + IF ( SIZE(ARRAY).EQ. 0 ) THEN + WRITE(6,199) + CALL ABORT + ELSE IF ( SIZE(ARRAY).NE.SIZE(IDX) ) THEN + WRITE(6,201) + CALL ABORT + ELSE IF ( LBOUND(ARRAY,1).GT.LO ) THEN + WRITE(6,203) + CALL ABORT + ELSE IF ( UBOUND(ARRAY,1).LT.HI ) THEN + WRITE(6,205) + CALL ABORT + END IF + ! + TOP = LO + BOT = HI + VAL = ARRAY(INT((LO+HI)/2)) + ! + LOOP = .TRUE. + DO WHILE ( LOOP ) + DO WHILE ( ARRAY(TOP).GT.VAL ) + TOP = TOP + 1 + END DO + DO WHILE ( VAL.GT.ARRAY(BOT) ) + BOT = BOT - 1 + END DO + IF ( TOP.LT.BOT ) THEN + !/ --- Swap values at indices TOP and BOT --- + TMP = ARRAY(TOP) + ARRAY(TOP) = ARRAY(BOT) + ARRAY(BOT) = TMP + !/ --- Swap index values at indices TOP and BOT --- + TMP = IDX(TOP) + IDX(TOP) = IDX(BOT) + IDX(BOT) = TMP + ! + TOP = TOP + 1 + BOT = BOT - 1 + ELSE + LOOP = .FALSE. END IF -!/ - IF (ALLOCATED(TMPA)) DEALLOCATE(TMPA) - IF (ALLOCATED(TMPB)) DEALLOCATE(TMPB) -!/ - RETURN -!/ - END SUBROUTINE findIJV4 -!/ End of findIJV4 --------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ - END MODULE W3STRKMD + + END DO + !/ --- Recursive call quicksort --- + IF (LO.LT.TOP-1) CALL QSORT_DESC(ARRAY,IDX,LO,TOP-1) + IF (BOT+1.LT.HI) CALL QSORT_DESC(ARRAY,IDX,BOT+1,HI) + ! + RETURN + !/ +199 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' QSORT ARRAY IS EMPTY' ) +201 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' QSORT ARRAY SIZE AND INDEX ARRAY SIZE MISMATCH' ) +203 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' QSORT ARRAY INDEX OUT OF LOWER BOUND' ) +205 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' QSORT ARRAY INDEX OUT OF UPPER BOUND' ) + !/ + END SUBROUTINE QSORT_DESC + !/ ------------------------------------------------------------------- / + !/ + FUNCTION SWAPI4(INT4) RESULT(INT4SWP) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 03-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 03-Jan-2017 : Origination ( version 5.16 ) + !/ (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Return a Byte-swapped integer (size of 4 bytes) + ! + ! 2. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + INTEGER(KIND=4), INTENT(IN) :: INT4 + INTEGER(KIND=4) :: INT4SWP + !/ + ! Local variables + ! ---------------------------------------------------------------- + INTEGER(KIND=1), DIMENSION(4) :: BYTEIN, BYTEOUT + !/ + BYTEIN = TRANSFER(INT4, BYTEIN) + BYTEOUT = (/BYTEIN(4),BYTEIN(3),BYTEIN(2),BYTEIN(1)/) + INT4SWP = TRANSFER(BYTEOUT, INT4SWP) + !/ + RETURN + !/ + END FUNCTION SWAPI4 + !/ ------------------------------------------------------------------- / + SUBROUTINE findIJV4 (a ,b ,maxI, maxJ ,indA ,indB ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 03-Mar-2017 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ 03-Mar-2017 : Calls to INTERSECT and UNION ( version 5.16 ) + !/ replaced (S. Zieger, BoM, Australia) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + IMPLICIT NONE + ! + ! 1. Purpose : + ! + ! Find a(i,j) indices of system "a" that lie over or along the + ! fringes of system "b". + ! + ! 2. Method + ! + ! (i) Use an index matrix to map locations of wave systems in B + ! (ii) Avoid multiple use of INTERSECT and UNION as in findIJV3 + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! a, b Type(system) input Final set of tracked systems, for one time level + ! maxI Int input Number rows indices of wave field + ! maxJ Int input Number column indices of wave field + ! indA*, indB* Int.A. output Pointer array of indices for combining systems + ! + TYPE(system) :: a, b + INTEGER :: maxI, maxJ + INTEGER, POINTER :: indA(:), indB(:) + ! + INTENT (IN) a, b, maxI,maxJ + ! + ! Local variables + ! ---------------------------------------------------------------- + ! posB Int Neighbour index + ! posB_MM Int Neighbour index (-1,-1) + ! posB_MP Int Neighbour index (-1,+1) + ! posB_PM Int Neighbour index (+1,-1) + ! posB_PP Int Neighbour index (+1,+1) + ! tmpA*, tmpB* Int.A. Array of indices for combining + ! systems + ! + INTEGER :: LENG_AI,LENG_BI + INTEGER :: OUTA,OUTB,I,J,IND,OUTDUMB + INTEGER :: POSB,POSB_MM,POSB_PM,POSB_MP,POSB_PP + INTEGER :: IND_B2(maxI,maxJ) + REAL,ALLOCATABLE :: TMPA(:),DUMA(:),TMPB(:) + REAL,POINTER :: DUMB(:) + LOGICAL :: FOUND + ! + ! 4. Subroutines used : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! QSORT Subr. Private Quicksort algorithm + ! UNIQUE Subr. Private Return sorted unique numbers of an array + ! + ! 5. Subroutines calling + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + NULLIFY(DUMB) + ! + IF (ASSOCIATED(INDA)) DEALLOCATE(INDA) + IF (ASSOCIATED(INDB)) DEALLOCATE(INDB) + ! + LENG_AI = LENGTH(REAL(a%i),SIZE(a%i),REAL(9999)) + LENG_BI = LENGTH(REAL(b%i),SIZE(b%i),REAL(9999)) + ! + ALLOCATE(TMPA(LENG_AI)) + ALLOCATE(TMPB(5*LENG_AI)) + ! + TMPA(:) = 9999. + TMPB(:) = 9999. + ! + OUTA = 0 + OUTB = 0 + IND_B2(:,:) = 0 + ! + DO IND=1,LENG_BI + I = B%I(IND) + J = B%J(IND) + IF (IND_B2(I,J).EQ.0) IND_B2(I,J) = IND + END DO + ! + DO IND=1,LENG_AI + I = A%I(IND) + J = A%J(IND) + POSB = IND_B2(I,J) + POSB_MM = 0 + POSB_PP = 0 + POSB_MP = 0 + POSB_PM = 0 + IF (I.GT.1.AND.J.GT.1) POSB_MM = IND_B2(i-1,j-1) + IF (I.GT.1.AND.J.LT.MAXJ) POSB_MP = IND_B2(i-1,j+1) + IF (I.LT.MAXI.AND.J.LT.MAXJ) POSB_PP = IND_B2(i+1,j+1) + IF (I.LT.MAXI.AND.J.GT.1) POSB_PM = IND_B2(i+1,j-1) + + FOUND = .FALSE. + IF (POSB.NE.0) THEN + OUTB = OUTB + 1 + TMPB(OUTB) = REAL(POSB) + IF (.NOT.FOUND) THEN + OUTA = OUTA + 1 + TMPA(OUTA) = REAL(IND) + FOUND = .TRUE. + END IF + END IF + IF (POSB_MM.NE.0) THEN + OUTB = OUTB + 1 + TMPB(OUTB) = REAL(POSB_MM) + IF (.NOT.FOUND) THEN + OUTA = OUTA + 1 + TMPA(OUTA) = REAL(IND) + FOUND = .TRUE. + END IF + END IF + IF (POSB_MP.NE.0) THEN + OUTB = OUTB + 1 + TMPB(OUTB) = REAL(POSB_MP) + IF (.NOT.FOUND) THEN + OUTA = OUTA + 1 + TMPA(OUTA) = REAL(IND) + FOUND = .TRUE. + END IF + END IF + IF (POSB_PM.NE.0) THEN + OUTB = OUTB + 1 + TMPB(OUTB) = REAL(POSB_PM) + IF (.NOT.FOUND) THEN + OUTA = OUTA + 1 + TMPA(OUTA) = REAL(IND) + FOUND = .TRUE. + END IF + END IF + IF (POSB_PP.NE.0) THEN + OUTB = OUTB + 1 + TMPB(OUTB) = REAL(POSB_PP) + IF (.NOT.FOUND) THEN + OUTA = OUTA + 1 + TMPA(OUTA) = REAL(IND) + FOUND = .TRUE. + END IF + END IF + + END DO + ! + !/ Compact indices for wave systems in B. + !/ Check for empty arrays first. + IF (OUTB.GT.0) THEN + CALL UNIQUE(TMPB,OUTB,DUMB,OUTDUMB) + OUTB = OUTDUMB + END IF + ALLOCATE(INDB(OUTB)) + IF (OUTB.GT.0) INDB(1:OUTB) = INT(DUMB(1:OUTB)) + IF (ASSOCIATED(DUMB)) DEALLOCATE(DUMB) + ! + !/ Allocate output array and transfer content + !/ for wave systems in A. + ALLOCATE(INDA(OUTA)) + IF (OUTA.GT.0) THEN + ALLOCATE(DUMA(OUTA)) + DUMA(:) = 0 + CALL QSORT(TMPA(1:OUTA),DUMA(1:OUTA),1,OUTA) + IF (ALLOCATED(DUMA)) DEALLOCATE(DUMA) + INDA(1:OUTA) = INT(TMPA(1:OUTA)) + END IF + !/ + IF (ALLOCATED(TMPA)) DEALLOCATE(TMPA) + IF (ALLOCATED(TMPB)) DEALLOCATE(TMPB) + !/ + RETURN + !/ + END SUBROUTINE findIJV4 + !/ End of findIJV4 --------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ +END MODULE W3STRKMD !/ !/ End of module W3STRKMD -------------------------------------------- / !/ diff --git a/model/src/w3swldmd.F90 b/model/src/w3swldmd.F90 index dbe0c5f24..6b8a93a95 100644 --- a/model/src/w3swldmd.F90 +++ b/model/src/w3swldmd.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains MODULE W3SWLMD, for swell dissipation source term. -!> +!> !> @author H. L. Tolman @date 21-Nov-2011 !> @@ -8,456 +8,456 @@ !/ ------------------------------------------------------------------- / !> !> @brief Source term module for swell dissipation. -!> +!> !> @details Source term for swell dissipation based on different !> physics that can be independently selected from the input !> and whitecapping dissipation terms in the model setup. !> !> @author H. L. Tolman @date 21-Nov-2011 !> - MODULE W3SWLDMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ +-----------------------------------+ -!/ -!/ 21-Nov-2011 : Origination. ( version 4.07 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Source term module for swell dissipation based on different -! physics that can be independently selected form the input -! and whitecapping dissipation terms in the model setup. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3SWL4 Subr. Public Ardhuin et al (2010+) swell dissipation -! W3SWL6 Subr. Public Babanin (2011) swell dissipation -! -! IRANGE Func. Private Generate a sequence of integer values -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - PUBLIC :: W3SWL4, W3SWL6 - PRIVATE :: IRANGE -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief FIXME -!> -!> @details A, S, D all stored as 1-D arrays with dimension NTH*NK -!> (column by column). -!> -!> @param[in] A Action density spectrum. -!> @param[in] CG Group velocities. -!> @param[in] WN Wavenumbers. -!> @param[in] DAIR Air density. -!> @param[out] S Source term. -!> @param[out] D Diagonal term of the derivative. -!> -!> @author H. L. Tolman @date 13-Aug-2021 -!> - SUBROUTINE W3SWL4 (A, CG, WN, DAIR, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Aug-2021 | -!/ +-----------------------------------+ -!/ -!/ 29-May-2009 : Origination (w3srcxmd.ftn) ( version 3.14 ) -!/ 06-Jan-2012 : Implementation (S. Zieger) -!/ 13-Aug-2021 : Consider DAIR a variable ( version x.xx ) -!/ -! 1. Purpose : -! -! FIXME -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A¹ R.A. I Action density spectrum -! CG R.A. I Group velocities -! WN R.A. I Wavenumbers -! DAIR R.A. I Air density -! S¹ R.A. O Source term -! D¹ R.A. O Diagonal term of derivative -! ¹ Stored as 1-D array with dimension NTH*NK (column by column). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! IRANGE Func. W3SWLDMD -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See comments in source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV, DWAT - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG2, DDEN, FTE, SWL6B1 +MODULE W3SWLDMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ +-----------------------------------+ + !/ + !/ 21-Nov-2011 : Origination. ( version 4.07 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Source term module for swell dissipation based on different + ! physics that can be independently selected form the input + ! and whitecapping dissipation terms in the model setup. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3SWL4 Subr. Public Ardhuin et al (2010+) swell dissipation + ! W3SWL6 Subr. Public Babanin (2011) swell dissipation + ! + ! IRANGE Func. Private Generate a sequence of integer values + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + PUBLIC :: W3SWL4, W3SWL6 + PRIVATE :: IRANGE + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief FIXME + !> + !> @details A, S, D all stored as 1-D arrays with dimension NTH*NK + !> (column by column). + !> + !> @param[in] A Action density spectrum. + !> @param[in] CG Group velocities. + !> @param[in] WN Wavenumbers. + !> @param[in] DAIR Air density. + !> @param[out] S Source term. + !> @param[out] D Diagonal term of the derivative. + !> + !> @author H. L. Tolman @date 13-Aug-2021 + !> + SUBROUTINE W3SWL4 (A, CG, WN, DAIR, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Aug-2021 | + !/ +-----------------------------------+ + !/ + !/ 29-May-2009 : Origination (w3srcxmd.ftn) ( version 3.14 ) + !/ 06-Jan-2012 : Implementation (S. Zieger) + !/ 13-Aug-2021 : Consider DAIR a variable ( version x.xx ) + !/ + ! 1. Purpose : + ! + ! FIXME + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A¹ R.A. I Action density spectrum + ! CG R.A. I Group velocities + ! WN R.A. I Wavenumbers + ! DAIR R.A. I Air density + ! S¹ R.A. O Source term + ! D¹ R.A. O Diagonal term of derivative + ! ¹ Stored as 1-D array with dimension NTH*NK (column by column). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! IRANGE Func. W3SWLDMD + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See comments in source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV, DWAT + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG2, DDEN, FTE, SWL6B1 #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: A(NSPEC), CG(NK), WN(NK), DAIR - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: A(NSPEC), CG(NK), WN(NK), DAIR + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IKN(NK), ITH - REAL, PARAMETER :: VA = 1.4E-5 ! Air kinematic viscosity (used in WAM). - REAL :: EB(NK), WN2(NSPEC), EMEAN - REAL :: FE, AORB, RE, RECRIT, UOSIG, CDSV -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: IKN(NK), ITH + REAL, PARAMETER :: VA = 1.4E-5 ! Air kinematic viscosity (used in WAM). + REAL :: EB(NK), WN2(NSPEC), EMEAN + REAL :: FE, AORB, RE, RECRIT, UOSIG, CDSV + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SWL4') + CALL STRACE (IENT, 'W3SWL4') #endif -! - IKN = IRANGE(1,NSPEC,NTH) - D = 0. - WN2 = 0. -! - DO ITH = 1, NTH - WN2(IKN+(ITH-1)) = WN ! Wavenumbers to all directions. - END DO -! - EB = SUM(RESHAPE(A,(/ NTH,NK /)),1) * DDEN(1:NK) / CG - EMEAN = SUM(EB) + (EB(NK) / DDEN(NK)) * FTE -! - AORB = 2.0*SQRT(EMEAN) -! - EB = SUM(RESHAPE(A*SIG2**2,(/ NTH,NK /)),1) * DDEN(1:NK) / CG - UOSIG = 2.0*SQRT(SUM(EB)) + ! + IKN = IRANGE(1,NSPEC,NTH) + D = 0. + WN2 = 0. + ! + DO ITH = 1, NTH + WN2(IKN+(ITH-1)) = WN ! Wavenumbers to all directions. + END DO + ! + EB = SUM(RESHAPE(A,(/ NTH,NK /)),1) * DDEN(1:NK) / CG + EMEAN = SUM(EB) + (EB(NK) / DDEN(NK)) * FTE + ! + AORB = 2.0*SQRT(EMEAN) + ! + EB = SUM(RESHAPE(A*SIG2**2,(/ NTH,NK /)),1) * DDEN(1:NK) / CG + UOSIG = 2.0*SQRT(SUM(EB)) - FE = SWL6B1 ! (from NAMELIST) -! FE = 0.001 ! (from NAMELIST) -!/ 0.001 - 0.019 with median value 0.007 (Ardhuin et al 2009, Babanin 2011) - CDSV = 1.2 -! - RECRIT = 1.0E5 - RE = 4.0 * UOSIG * AORB / VA -! - IF (RE .GT. RECRIT) THEN - D = -(16.0/GRAV) * (DAIR/DWAT) * FE * (SIG2**2) *UOSIG - ELSE - D = -2.0 * (DAIR/DWAT) * CDSV * WN2 * SQRT(2.0 * VA * SIG2) - END IF -! - S = D * A -! -! WRITE(*,*) ' FE =',FE -! WRITE(*,*) ' HS =',4.*SQRT(EMEAN) -! WRITE(*,*) ' UOSIG =',UOSIG -! WRITE(*,*) ' AORB =',AORB -! WRITE(*,*) ' RE/RECRIT=',RE/RECRIT -! WRITE(*,*) ' SWL4_tot =',SUM(SUM(RESHAPE(S,(/ NTH,NK /)),1)*DDEN/CG) -!/ -!/ End of W3SWL4 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SWL4 -!/ ------------------------------------------------------------------- / -!> -!> @brief Turbulent dissipation of narrow-banded swell. -!> -!> -!> @details A, S, D all stored as 1-D arrays with dimension NTH*NK -!> (column by column). -!> -!> Described in Babanin (2011, Section 7.5). -!> Babanin 2011: Cambridge Press, 295-321, 463pp. -!> -!> S = D * A -!> -!> @param[in] A Action density spectrum. -!> @param[in] CG Group velocities. -!> @param[in] WN Wavenumbers. -!> @param[out] S Source term. -!> @param[out] D Diagonal term of the derivative. -!> -!> @author H. L. Tolman @date 16-Feb-2012 -!> - SUBROUTINE W3SWL6 (A, CG, WN, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 16-Feb-2012 | -!/ +-----------------------------------+ -!/ -!/ 29-May-2009 : Origination (w3srcxmd.ftn) ( version 3.14 ) -!/ 16-Feb-2012 : Implementation ( version 4.07 ) -!/ (S. Zieger) -!/ -! 1. Purpose : -! -! Turbulent dissipation of narrow-banded swell as described in -! Babanin (2011, Section 7.5). -! -! Babanin 2011: Cambridge Press, 295-321, 463pp. -! -! 2. Method : -! -! S = D * A -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A¹ R.A. I Action density spectrum -! CG R.A. I Group velocities -! WN R.A. I Wavenumbers -! S¹ R.A. O Source term -! D¹ R.A. O Diagonal term of derivative -! ¹ Stored as 1-D array with dimension NTH*NK (column by column). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! IRANGE Func. W3SWLDMD -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Source term integration. -! W3EXPO Subr. N/A Point output post-processor. -! GXEXPO Subr. N/A GrADS point output post-processor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See comments in source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: GRAV - USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DDEN, DTH - USE W3GDATMD, ONLY: SWL6CSTB1, SWL6B1, FTE, FTWN + FE = SWL6B1 ! (from NAMELIST) + ! FE = 0.001 ! (from NAMELIST) + !/ 0.001 - 0.019 with median value 0.007 (Ardhuin et al 2009, Babanin 2011) + CDSV = 1.2 + ! + RECRIT = 1.0E5 + RE = 4.0 * UOSIG * AORB / VA + ! + IF (RE .GT. RECRIT) THEN + D = -(16.0/GRAV) * (DAIR/DWAT) * FE * (SIG2**2) *UOSIG + ELSE + D = -2.0 * (DAIR/DWAT) * CDSV * WN2 * SQRT(2.0 * VA * SIG2) + END IF + ! + S = D * A + ! + ! WRITE(*,*) ' FE =',FE + ! WRITE(*,*) ' HS =',4.*SQRT(EMEAN) + ! WRITE(*,*) ' UOSIG =',UOSIG + ! WRITE(*,*) ' AORB =',AORB + ! WRITE(*,*) ' RE/RECRIT=',RE/RECRIT + ! WRITE(*,*) ' SWL4_tot =',SUM(SUM(RESHAPE(S,(/ NTH,NK /)),1)*DDEN/CG) + !/ + !/ End of W3SWL4 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SWL4 + !/ ------------------------------------------------------------------- / + !> + !> @brief Turbulent dissipation of narrow-banded swell. + !> + !> + !> @details A, S, D all stored as 1-D arrays with dimension NTH*NK + !> (column by column). + !> + !> Described in Babanin (2011, Section 7.5). + !> Babanin 2011: Cambridge Press, 295-321, 463pp. + !> + !> S = D * A + !> + !> @param[in] A Action density spectrum. + !> @param[in] CG Group velocities. + !> @param[in] WN Wavenumbers. + !> @param[out] S Source term. + !> @param[out] D Diagonal term of the derivative. + !> + !> @author H. L. Tolman @date 16-Feb-2012 + !> + SUBROUTINE W3SWL6 (A, CG, WN, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 16-Feb-2012 | + !/ +-----------------------------------+ + !/ + !/ 29-May-2009 : Origination (w3srcxmd.ftn) ( version 3.14 ) + !/ 16-Feb-2012 : Implementation ( version 4.07 ) + !/ (S. Zieger) + !/ + ! 1. Purpose : + ! + ! Turbulent dissipation of narrow-banded swell as described in + ! Babanin (2011, Section 7.5). + ! + ! Babanin 2011: Cambridge Press, 295-321, 463pp. + ! + ! 2. Method : + ! + ! S = D * A + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A¹ R.A. I Action density spectrum + ! CG R.A. I Group velocities + ! WN R.A. I Wavenumbers + ! S¹ R.A. O Source term + ! D¹ R.A. O Diagonal term of derivative + ! ¹ Stored as 1-D array with dimension NTH*NK (column by column). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! IRANGE Func. W3SWLDMD + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Source term integration. + ! W3EXPO Subr. N/A Point output post-processor. + ! GXEXPO Subr. N/A GrADS point output post-processor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See comments in source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: GRAV + USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DDEN, DTH + USE W3GDATMD, ONLY: SWL6CSTB1, SWL6B1, FTE, FTWN #ifdef W3_T6 - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - REAL, INTENT(IN) :: A(NSPEC), CG(NK), WN(NK) - REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL, INTENT(IN) :: A(NSPEC), CG(NK), WN(NK) + REAL, INTENT(OUT) :: S(NSPEC), D(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IK, ITH, IKN(NK) - REAL, DIMENSION(NK) :: ABAND, KMAX, ANAR, BN, AORB, DDIS - REAL :: K(NTH,NK), B1 -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: IK, ITH, IKN(NK) + REAL, DIMENSION(NK) :: ABAND, KMAX, ANAR, BN, AORB, DDIS + REAL :: K(NTH,NK), B1 + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SWL6') + CALL STRACE (IENT, 'W3SWL6') #endif -! -!/ 0) --- Initialize parameters -------------------------------------- / - IKN = IRANGE(1,NSPEC,NTH) ! Index vector for array access, e.g. -! ! in form of WN(1:NK) == WN2(IKN). - ABAND = SUM(RESHAPE(A,(/ NTH,NK /)),1) ! action density as function of wavenumber - DDIS = 0. - D = 0. - B1 = SWL6B1 ! empirical constant from NAMELIST -! -!/ 1) --- Choose calculation of steepness a*k ------------------------ / -!/ Replace the measure of steepness with the spectral -! saturation after Banner et al. (2002) ---------------------- / - K = RESHAPE(A,(/ NTH,NK /)) - KMAX = MAXVAL(K,1) - DO IK = 1,NK - IF (KMAX(IK).LT.1.0E-34) THEN - K(1:NTH,IK) = 1. - ELSE - K(1:NTH,IK) = K(1:NTH,IK)/KMAX(IK) - END IF - END DO - ANAR = 1.0/( SUM(K,1) * DTH ) - BN = ANAR * ( ABAND * SIG(1:NK) * DTH ) * WN**3 -! - IF (.NOT.SWL6CSTB1) THEN -! -!/ --- A constant value for B1 attenuates swell too strong in the -!/ western central Pacific (i.e. cross swell less than 1.0m). -!/ Workaround is to scale B1 with steepness a*kp, where kp is -!/ the peak wavenumber. SWL6B1 remains a scaling constant, but -!/ with different magnitude. --------------------------------- / - IK = MAXLOC(ABAND,1) ! Index for peak -! EMEAN = SUM(ABAND * DDEN / CG) ! Total sea surface variance - B1 = SWL6B1 * ( 2. * SQRT(SUM(ABAND*DDEN/CG)) * WN(IK) ) -! + ! + !/ 0) --- Initialize parameters -------------------------------------- / + IKN = IRANGE(1,NSPEC,NTH) ! Index vector for array access, e.g. + ! ! in form of WN(1:NK) == WN2(IKN). + ABAND = SUM(RESHAPE(A,(/ NTH,NK /)),1) ! action density as function of wavenumber + DDIS = 0. + D = 0. + B1 = SWL6B1 ! empirical constant from NAMELIST + ! + !/ 1) --- Choose calculation of steepness a*k ------------------------ / + !/ Replace the measure of steepness with the spectral + ! saturation after Banner et al. (2002) ---------------------- / + K = RESHAPE(A,(/ NTH,NK /)) + KMAX = MAXVAL(K,1) + DO IK = 1,NK + IF (KMAX(IK).LT.1.0E-34) THEN + K(1:NTH,IK) = 1. + ELSE + K(1:NTH,IK) = K(1:NTH,IK)/KMAX(IK) END IF -! -!/ 2) --- Calculate the derivative term only (in units of 1/s) ------- / - DO IK = 1,NK - IF (ABAND(IK) .GT. 1.E-30) THEN - DDIS(IK) = -(2./3.) * B1 * SIG(IK) * SQRT(BN(IK)) - END IF - END DO -! -!/ 3) --- Apply dissipation term of derivative to all directions ----- / - DO ITH = 1, NTH - D(IKN+(ITH-1)) = DDIS - END DO -! - S = D * A -! -! WRITE(*,*) ' B1 =',B1 -! WRITE(*,*) ' DDIS_tot =',SUM(DDIS*ABAND*DDEN/CG) -! WRITE(*,*) ' EDENS_tot=',sum(aband*dden/cg) -! WRITE(*,*) ' EDENS_tot=',sum(aband*sig*dth*dsii/cg) -! WRITE(*,*) ' ' -! WRITE(*,*) ' SWL6_tot =',sum(SUM(RESHAPE(S,(/ NTH,NK /)),1)*DDEN/CG) -! -!/ -!/ End of W3SWL6 ----------------------------------------------------- / -!/ - END SUBROUTINE W3SWL6 -!/ ------------------------------------------------------------------- / -!/ -!> -!> @brief Generate a linear-spaced sequence of integer numbers. -!> -!> @details Used for array addressing (indexing). -!> -!> @param X0 -!> @param X1 -!> @param DX -!> @returns IX -!> -!> @author H. L. Tolman -!> @author S. Zieger -!> @date 15-Feb-2011 -!> - FUNCTION IRANGE(X0,X1,DX) RESULT(IX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | S. Zieger | -!/ | FORTRAN 90 | -!/ | Last update : 15-Feb-2011 | -!/ +-----------------------------------+ -!/ -!/ 15-Feb-2011 : Origination from W3SRC6MD ( version 4.07 ) -!/ (S. Zieger) -!/ -! 1. Purpose : -! Generate a linear-spaced sequence of integer -! numbers. Used for array addressing (indexing). -! -!/ - IMPLICIT NONE - INTEGER, INTENT(IN) :: X0, X1, DX - INTEGER, ALLOCATABLE :: IX(:) - INTEGER :: N - INTEGER :: I -! - N = INT(REAL(X1-X0)/REAL(DX))+1 - ALLOCATE(IX(N)) - DO I = 1, N - IX(I) = X0+ (I-1)*DX - END DO -!/ - END FUNCTION IRANGE -!/ ------------------------------------------------------------------- / -!/ - END MODULE W3SWLDMD + END DO + ANAR = 1.0/( SUM(K,1) * DTH ) + BN = ANAR * ( ABAND * SIG(1:NK) * DTH ) * WN**3 + ! + IF (.NOT.SWL6CSTB1) THEN + ! + !/ --- A constant value for B1 attenuates swell too strong in the + !/ western central Pacific (i.e. cross swell less than 1.0m). + !/ Workaround is to scale B1 with steepness a*kp, where kp is + !/ the peak wavenumber. SWL6B1 remains a scaling constant, but + !/ with different magnitude. --------------------------------- / + IK = MAXLOC(ABAND,1) ! Index for peak + ! EMEAN = SUM(ABAND * DDEN / CG) ! Total sea surface variance + B1 = SWL6B1 * ( 2. * SQRT(SUM(ABAND*DDEN/CG)) * WN(IK) ) + ! + END IF + ! + !/ 2) --- Calculate the derivative term only (in units of 1/s) ------- / + DO IK = 1,NK + IF (ABAND(IK) .GT. 1.E-30) THEN + DDIS(IK) = -(2./3.) * B1 * SIG(IK) * SQRT(BN(IK)) + END IF + END DO + ! + !/ 3) --- Apply dissipation term of derivative to all directions ----- / + DO ITH = 1, NTH + D(IKN+(ITH-1)) = DDIS + END DO + ! + S = D * A + ! + ! WRITE(*,*) ' B1 =',B1 + ! WRITE(*,*) ' DDIS_tot =',SUM(DDIS*ABAND*DDEN/CG) + ! WRITE(*,*) ' EDENS_tot=',sum(aband*dden/cg) + ! WRITE(*,*) ' EDENS_tot=',sum(aband*sig*dth*dsii/cg) + ! WRITE(*,*) ' ' + ! WRITE(*,*) ' SWL6_tot =',sum(SUM(RESHAPE(S,(/ NTH,NK /)),1)*DDEN/CG) + ! + !/ + !/ End of W3SWL6 ----------------------------------------------------- / + !/ + END SUBROUTINE W3SWL6 + !/ ------------------------------------------------------------------- / + !/ + !> + !> @brief Generate a linear-spaced sequence of integer numbers. + !> + !> @details Used for array addressing (indexing). + !> + !> @param X0 + !> @param X1 + !> @param DX + !> @returns IX + !> + !> @author H. L. Tolman + !> @author S. Zieger + !> @date 15-Feb-2011 + !> + FUNCTION IRANGE(X0,X1,DX) RESULT(IX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | S. Zieger | + !/ | FORTRAN 90 | + !/ | Last update : 15-Feb-2011 | + !/ +-----------------------------------+ + !/ + !/ 15-Feb-2011 : Origination from W3SRC6MD ( version 4.07 ) + !/ (S. Zieger) + !/ + ! 1. Purpose : + ! Generate a linear-spaced sequence of integer + ! numbers. Used for array addressing (indexing). + ! + !/ + IMPLICIT NONE + INTEGER, INTENT(IN) :: X0, X1, DX + INTEGER, ALLOCATABLE :: IX(:) + INTEGER :: N + INTEGER :: I + ! + N = INT(REAL(X1-X0)/REAL(DX))+1 + ALLOCATE(IX(N)) + DO I = 1, N + IX(I) = X0+ (I-1)*DX + END DO + !/ + END FUNCTION IRANGE + !/ ------------------------------------------------------------------- / + !/ +END MODULE W3SWLDMD diff --git a/model/src/w3tidemd.F90 b/model/src/w3tidemd.F90 index 7d1413e62..4f58afd4b 100644 --- a/model/src/w3tidemd.F90 +++ b/model/src/w3tidemd.F90 @@ -1,1675 +1,1675 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3TIDEMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III | -!/ ! M. Foreman, IOS ! -!/ | FORTRAN 90 | -!/ | Last update : 21-Apr-2020 | -!/ +-----------------------------------+ -!/ -!/ 01-Sep-2012 : Origination. ( version 4.07 ) -!/ 04-Mar-2013 : Correction of FAST and new VFAST ( version 4.08 ) -!/ 21-Apr-2020 : Correction of time and implicit none( version 7.13 ) -!/ -! 1. Purpose : -! -! Tidal analysis of time series for storage of tidal constituents -! only. This module is built around the versatile tidal analysis -! package : http://www.pac.dfo-mpo.gc.ca/science/oceans/tidal-marees/index-eng.htm -! by Mike Foreman et al. (see publication in J. Ocean Atmos. Tech.: vol. -! http://journals.ametsoc.org/doi/pdf/10.1175/2008JTECHO615.1 ) -! Adaptation to WAVEWATCH III was performed by F. Ardhuin -! -! STILL TO BE DONE: -! - adding a namelist in ww3_grid to allow adjustment of TIDE_DT -! - check on constituents (M2, S2, N2 ...) when running ww3_shel, -! in order to allow use of different sets of constituents -! - add residual currents (or geostrophic ...) ... -! - make this work with multigrids -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! TIDE_WRITE_RESULTS Subr. Public Writes tidal results -! (with M. Forman's format) -! TIDE_PREDICT Subr. Public Predicts tide from amp. & phases -! TIDE_SETTINGS_FULL Subr. Public Choice of constituents -! TIDE_SETTINGS_FAST Subr. Public Choice of constituents -! TIDE_SETTINGS_VFAST Subr. Public Choice of constituents -! TIDE_SET_INDICES Subr. Public -! SETVUF_FAST Subr. Public Calculates the V,u,f values -! TIDE_READ_SETTINGS Subr. Public Reads data from file (IOS format) -! TIDE_READ_ANAPAR Subr. Public Reads data from file (IOS format) -! TIDE_READ_TIMESERIES Subr. Public Reads data from file (IOS format) -! ASTR Subr. Public Calculates the ephermides -! JULDAYT Func. Public Julian day -! CALDATT Subr. Public -! dsvbksb Subr. Public -! dsvdcmp Subr. Public -! svd Subr. Public Matrix singular value decomposition -! VUF_SET_PARAMETERS Subr. Public -! VUF Subr. Public -! OPNVUF Subr. Public -! SETVUF Subr. Public -! flex_tidana_webpage Subr. Public -! TIDE_PREDICT Subr. Public Tide prediction and error estimate -! TIDE_PREDICT_ONLY Subr. Public Tide prediction only -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! 7. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ -! PUBLIC -!/ -!/ Private variables -!/ - DOUBLE PRECISION, PARAMETER :: TWPI=3.1415926535898*2. - DOUBLE PRECISION, PARAMETER :: FAC=TWPI/360. - -! -! Array sizes -! - INTEGER, PARAMETER :: MC=70,NR=106000,NMAXP1=MC*2,NMAXPM=NR*2+NMAXP1 - INTEGER, PARAMETER :: MC2=MC*2 - CHARACTER*5, PARAMETER :: KBLANK=' ' -! - INTEGER :: NTIDAL_CON, NTOTAL_CON, NKONCO - CHARACTER*5, ALLOCATABLE :: TIDECON_ALLNAMES(:) ! array of names of tidal constituents - CHARACTER*5, ALLOCATABLE :: KONCO_CON(:) - INTEGER, ALLOCATABLE, PRIVATE :: II(:),JJ(:),KK(:),LL(:),MM(:),NN(:),NJ(:) - REAL, ALLOCATABLE :: SEMI(:),COEF_CON(:) - REAL , ALLOCATABLE :: V_ARG(:,:),F_ARG(:,:),U_ARG(:,:) - REAL :: EE(180),PH(180) - INTEGER :: LDEL(180),MDEL(180),NDEL(180),IR(180) -! these two index table are used in VUF ... - INTEGER , ALLOCATABLE :: TIDE_INDEXJ(:),TIDE_INDEXJK(:) -! -! Parameters for tidal analysis -! - INTEGER :: TIDE_MF, TIDE_NX, TIDE_NY - REAL, ALLOCATABLE :: TIDE_FREQC(:) ! array of freq. of tidal constituents - CHARACTER(LEN=5), ALLOCATABLE:: TIDECON_NAMEI(:) ! array of names of tidal constituents - CHARACTER(LEN=5), ALLOCATABLE:: TIDECON_NAME(:) ! array of names of tidal constituents - CHARACTER(LEN=5) :: TIDE_KONAN(10), TIDE_KONIN(10,10) - REAL :: TIDE_R(10,10), TIDE_ZETA(10,10) - REAL :: TIDE_SIGAN(10),TIDE_SIGIN(10,10) ! these two are only read from files and written out - INTEGER :: TIDE_NIN,TIDE_NINF(10) - REAL, ALLOCATABLE :: TIDAL_CONST(:,:,:,:,:) ! array of freq. of tidal constituents -! -! Data to be analyzed -! - INTEGER(KIND=4) :: TIDE_NTI - REAL, ALLOCATABLE :: TIDE_DATA(:,:) - INTEGER(KIND=4), ALLOCATABLE :: TIDE_DAYS(:), TIDE_SECS(:) - REAL(KIND=8), ALLOCATABLE :: TIDE_HOURS(:) - REAL, PARAMETER :: TIDE_DT = 1800. ! time step used for forcing -! -! Analysis result -! - REAL :: TIDE_AMPC(MC,2), TIDE_PHG(MC,2), & - TIDE_SIG1(MC,2), TIDE_SIG2(MC,2), & - TIDE_SIG3(MC,2), TIDE_TTEST(MC,2) - REAL :: TIDE_ampci(10,10,2), TIDE_phgi(10,10,2) - INTEGER :: TIDE_INDEX(MC),TIDE_INDEX2(MC) - - - INTEGER :: NDSET, TIDE_VERBOSE = 0 - - !PUBLIC :: TIDE_MF, TIDECON_NAME - -!/ - CONTAINS - -!/ ------------------------------------------------------------------- / - SUBROUTINE TIDE_WRITE_RESULTS(LP,filename,ndef,KD1, KD2, ITZ, xlat,xlon, & - RES, SSQ, RMSR0, SDEV0,SDEV,RMSR, RESMAX, IMAX, RMSRP) - - IMPLICIT NONE -! - CHARACTER*256, INTENT(IN) :: filename - INTEGER, INTENT(IN) :: LP, NDEF, IMAX(NDEF) - INTEGER(KIND=4),INTENT(IN) :: KD1,KD2 - CHARACTER*4 , INTENT(IN) :: ITZ - REAL(KIND=8), INTENT(IN) :: RMSR0(NDEF), & - SDEV0(NDEF), SDEV(NDEF), RMSR(NDEF), RESMAX(NDEF), RMSRP(NDEF) - REAL , INTENT(IN) :: RES(NDEF), SSQ(NDEF), XLAT,XLON -! - INTEGER :: IDEF, I, K, K2, L, I1, INFTOT - INTEGER :: ID1,IM1,IY1,ID2,IM2,IY2 - - open(unit=lp,file=filename,status='unknown',form='formatted') - - CALL CALDATT(KD1,id1,im1,iy1) - CALL CALDATT(KD2,id2,im2,iy2) - - WRITE(LP,15) ID1,IM1,IY1,ID2,IM2,IY2,ITZ - 15 FORMAT(/'THE ANALYSIS PERIOD IS FROM',I3,'/',I2,'/',I4, & - ' TO ',I2,'/',I2,'/',I4,' IN THE TIME ZONE ',A4) - WRITE(LP,*)'USING SVD TO SOLVE THE OVERDETERMINED SYSTEM' -! write(lp,150)ID1,IM1,IC1,IY1,ID2,IM2,IC2,IY2 -150 format(2i3,2i2,5x,2i3,2i2) - - WRITE(LP,255)TIDE_NTI - 255 FORMAT('NUMBER OF POINTS IN THE ANALYSIS =',I6) - write(lp,*) ' nin=',TIDE_NIN - - DO IDEF=1,NDEF - - WRITE(LP,52) RES(IDEF),SSQ(IDEF) - 52 FORMAT('LARGEST RESIDUAL MAGNITUDE & RESIDUAL SUM OF SQUARES:' & - ,2E12.5) - WRITE(LP,66) SDEV0(IDEF),RMSR0(IDEF) - 66 FORMAT( & - 'ST. DEV. OF RIGHT HAND SIDES OF ORIGINAL OVERDETERMINED SYSTEM:' & - ,E12.5/ & - ' AND THE ROOT MEAN SQUARE RESIDUAL ERROR:' & - ,E12.5) +MODULE W3TIDEMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III | + !/ ! M. Foreman, IOS ! + !/ | FORTRAN 90 | + !/ | Last update : 21-Apr-2020 | + !/ +-----------------------------------+ + !/ + !/ 01-Sep-2012 : Origination. ( version 4.07 ) + !/ 04-Mar-2013 : Correction of FAST and new VFAST ( version 4.08 ) + !/ 21-Apr-2020 : Correction of time and implicit none( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Tidal analysis of time series for storage of tidal constituents + ! only. This module is built around the versatile tidal analysis + ! package : http://www.pac.dfo-mpo.gc.ca/science/oceans/tidal-marees/index-eng.htm + ! by Mike Foreman et al. (see publication in J. Ocean Atmos. Tech.: vol. + ! http://journals.ametsoc.org/doi/pdf/10.1175/2008JTECHO615.1 ) + ! Adaptation to WAVEWATCH III was performed by F. Ardhuin + ! + ! STILL TO BE DONE: + ! - adding a namelist in ww3_grid to allow adjustment of TIDE_DT + ! - check on constituents (M2, S2, N2 ...) when running ww3_shel, + ! in order to allow use of different sets of constituents + ! - add residual currents (or geostrophic ...) ... + ! - make this work with multigrids + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! TIDE_WRITE_RESULTS Subr. Public Writes tidal results + ! (with M. Forman's format) + ! TIDE_PREDICT Subr. Public Predicts tide from amp. & phases + ! TIDE_SETTINGS_FULL Subr. Public Choice of constituents + ! TIDE_SETTINGS_FAST Subr. Public Choice of constituents + ! TIDE_SETTINGS_VFAST Subr. Public Choice of constituents + ! TIDE_SET_INDICES Subr. Public + ! SETVUF_FAST Subr. Public Calculates the V,u,f values + ! TIDE_READ_SETTINGS Subr. Public Reads data from file (IOS format) + ! TIDE_READ_ANAPAR Subr. Public Reads data from file (IOS format) + ! TIDE_READ_TIMESERIES Subr. Public Reads data from file (IOS format) + ! ASTR Subr. Public Calculates the ephermides + ! JULDAYT Func. Public Julian day + ! CALDATT Subr. Public + ! dsvbksb Subr. Public + ! dsvdcmp Subr. Public + ! svd Subr. Public Matrix singular value decomposition + ! VUF_SET_PARAMETERS Subr. Public + ! VUF Subr. Public + ! OPNVUF Subr. Public + ! SETVUF Subr. Public + ! flex_tidana_webpage Subr. Public + ! TIDE_PREDICT Subr. Public Tide prediction and error estimate + ! TIDE_PREDICT_ONLY Subr. Public Tide prediction only + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! 7. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + ! PUBLIC + !/ + !/ Private variables + !/ + DOUBLE PRECISION, PARAMETER :: TWPI=3.1415926535898*2. + DOUBLE PRECISION, PARAMETER :: FAC=TWPI/360. + + ! + ! Array sizes + ! + INTEGER, PARAMETER :: MC=70,NR=106000,NMAXP1=MC*2,NMAXPM=NR*2+NMAXP1 + INTEGER, PARAMETER :: MC2=MC*2 + CHARACTER*5, PARAMETER :: KBLANK=' ' + ! + INTEGER :: NTIDAL_CON, NTOTAL_CON, NKONCO + CHARACTER*5, ALLOCATABLE :: TIDECON_ALLNAMES(:) ! array of names of tidal constituents + CHARACTER*5, ALLOCATABLE :: KONCO_CON(:) + INTEGER, ALLOCATABLE, PRIVATE :: II(:),JJ(:),KK(:),LL(:),MM(:),NN(:),NJ(:) + REAL, ALLOCATABLE :: SEMI(:),COEF_CON(:) + REAL , ALLOCATABLE :: V_ARG(:,:),F_ARG(:,:),U_ARG(:,:) + REAL :: EE(180),PH(180) + INTEGER :: LDEL(180),MDEL(180),NDEL(180),IR(180) + ! these two index table are used in VUF ... + INTEGER , ALLOCATABLE :: TIDE_INDEXJ(:),TIDE_INDEXJK(:) + ! + ! Parameters for tidal analysis + ! + INTEGER :: TIDE_MF, TIDE_NX, TIDE_NY + REAL, ALLOCATABLE :: TIDE_FREQC(:) ! array of freq. of tidal constituents + CHARACTER(LEN=5), ALLOCATABLE:: TIDECON_NAMEI(:) ! array of names of tidal constituents + CHARACTER(LEN=5), ALLOCATABLE:: TIDECON_NAME(:) ! array of names of tidal constituents + CHARACTER(LEN=5) :: TIDE_KONAN(10), TIDE_KONIN(10,10) + REAL :: TIDE_R(10,10), TIDE_ZETA(10,10) + REAL :: TIDE_SIGAN(10),TIDE_SIGIN(10,10) ! these two are only read from files and written out + INTEGER :: TIDE_NIN,TIDE_NINF(10) + REAL, ALLOCATABLE :: TIDAL_CONST(:,:,:,:,:) ! array of freq. of tidal constituents + ! + ! Data to be analyzed + ! + INTEGER(KIND=4) :: TIDE_NTI + REAL, ALLOCATABLE :: TIDE_DATA(:,:) + INTEGER(KIND=4), ALLOCATABLE :: TIDE_DAYS(:), TIDE_SECS(:) + REAL(KIND=8), ALLOCATABLE :: TIDE_HOURS(:) + REAL, PARAMETER :: TIDE_DT = 1800. ! time step used for forcing + ! + ! Analysis result + ! + REAL :: TIDE_AMPC(MC,2), TIDE_PHG(MC,2), & + TIDE_SIG1(MC,2), TIDE_SIG2(MC,2), & + TIDE_SIG3(MC,2), TIDE_TTEST(MC,2) + REAL :: TIDE_ampci(10,10,2), TIDE_phgi(10,10,2) + INTEGER :: TIDE_INDEX(MC),TIDE_INDEX2(MC) + + + INTEGER :: NDSET, TIDE_VERBOSE = 0 + + !PUBLIC :: TIDE_MF, TIDECON_NAME + + !/ +CONTAINS + + !/ ------------------------------------------------------------------- / + SUBROUTINE TIDE_WRITE_RESULTS(LP,filename,ndef,KD1, KD2, ITZ, xlat,xlon, & + RES, SSQ, RMSR0, SDEV0,SDEV,RMSR, RESMAX, IMAX, RMSRP) + + IMPLICIT NONE + ! + CHARACTER*256, INTENT(IN) :: filename + INTEGER, INTENT(IN) :: LP, NDEF, IMAX(NDEF) + INTEGER(KIND=4),INTENT(IN) :: KD1,KD2 + CHARACTER*4 , INTENT(IN) :: ITZ + REAL(KIND=8), INTENT(IN) :: RMSR0(NDEF), & + SDEV0(NDEF), SDEV(NDEF), RMSR(NDEF), RESMAX(NDEF), RMSRP(NDEF) + REAL , INTENT(IN) :: RES(NDEF), SSQ(NDEF), XLAT,XLON + ! + INTEGER :: IDEF, I, K, K2, L, I1, INFTOT + INTEGER :: ID1,IM1,IY1,ID2,IM2,IY2 + + open(unit=lp,file=filename,status='unknown',form='formatted') + + CALL CALDATT(KD1,id1,im1,iy1) + CALL CALDATT(KD2,id2,im2,iy2) + + WRITE(LP,15) ID1,IM1,IY1,ID2,IM2,IY2,ITZ +15 FORMAT(/'THE ANALYSIS PERIOD IS FROM',I3,'/',I2,'/',I4, & + ' TO ',I2,'/',I2,'/',I4,' IN THE TIME ZONE ',A4) + WRITE(LP,*)'USING SVD TO SOLVE THE OVERDETERMINED SYSTEM' + ! write(lp,150)ID1,IM1,IC1,IY1,ID2,IM2,IC2,IY2 +150 format(2i3,2i2,5x,2i3,2i2) + + WRITE(LP,255)TIDE_NTI +255 FORMAT('NUMBER OF POINTS IN THE ANALYSIS =',I6) + write(lp,*) ' nin=',TIDE_NIN + + DO IDEF=1,NDEF + + WRITE(LP,52) RES(IDEF),SSQ(IDEF) +52 FORMAT('LARGEST RESIDUAL MAGNITUDE & RESIDUAL SUM OF SQUARES:' & + ,2E12.5) + WRITE(LP,66) SDEV0(IDEF),RMSR0(IDEF) +66 FORMAT( & + 'ST. DEV. OF RIGHT HAND SIDES OF ORIGINAL OVERDETERMINED SYSTEM:' & + ,E12.5/ & + ' AND THE ROOT MEAN SQUARE RESIDUAL ERROR:' & + ,E12.5) write(lp,*) ' rms residual: brute force =',rmsr(IDEF) write(lp,*) ' max residual: ',resmax(IDEF),imax(IDEF) WRITE(LP,41) - 41 FORMAT('HARMONIC ANALYSIS RESULTS: AMPLITUDES, PHASE LAGS, C, S, & - & amp SD estimates, t-test value') -! write out results for constant term & linear trend +41 FORMAT('HARMONIC ANALYSIS RESULTS: AMPLITUDES, PHASE LAGS, C, S, & + & amp SD estimates, t-test value') + ! write out results for constant term & linear trend - DO I=1,TIDE_MF - WRITE(LP,43) TIDECON_NAME(I),TIDE_FREQC(I),TIDE_AMPC(I,idef),TIDE_PHG(I,idef), & - TIDE_sig1(I,idef),TIDE_sig2(I,idef),TIDE_sig3(I,idef),TIDE_ttest(I,idef) - END DO - - 43 FORMAT(5X,A5,4X,F12.9,2X,F10.5,2X,F10.3,5x,4f8.3) + DO I=1,TIDE_MF + WRITE(LP,43) TIDECON_NAME(I),TIDE_FREQC(I),TIDE_AMPC(I,idef),TIDE_PHG(I,idef), & + TIDE_sig1(I,idef),TIDE_sig2(I,idef),TIDE_sig3(I,idef),TIDE_ttest(I,idef) + END DO -! -!* INFERENCE results are given now -! - IF (TIDE_NIN.GE.0) THEN +43 FORMAT(5X,A5,4X,F12.9,2X,F10.5,2X,F10.3,5x,4f8.3) + + ! + !* INFERENCE results are given now + ! + IF (TIDE_NIN.GE.0) THEN write(lp,*) ' INFERENCE RESULTS' l=0 do k=1,TIDE_NIN do i=2,TIDE_MF IF (TIDECON_NAME(i).eq.TIDE_KONAN(k)) EXIT - END DO + END DO i1=i do k2=1,TIDE_NINF(k) l=l+1 write(lp,79) TIDE_KONIN(k,k2),TIDE_SIGIN(k,k2),TIDE_ampci(k,k2,idef), & - TIDE_phgi(k,k2,idef) -79 format(5x,a5,4x,f12.9,15x,f10.4,5x,f10.4) - END DO + TIDE_phgi(k,k2,idef) +79 format(5x,a5,4x,f12.9,15x,f10.4,5x,f10.4) END DO + END DO inftot=l - END IF + END IF - WRITE(LP,70)TIDE_NTI,TIDE_MF*2,' ',xlat,xlon,sngl(SDEV0),sngl(SDEV) - 70 format('N,m,LAT,LON,SDEV0,SDEV: ',2i10,a4,f9.4,f10.4,2f10.2) -! - IF (TIDE_NIN.GT.0) THEN + WRITE(LP,70)TIDE_NTI,TIDE_MF*2,' ',xlat,xlon,sngl(SDEV0),sngl(SDEV) +70 format('N,m,LAT,LON,SDEV0,SDEV: ',2i10,a4,f9.4,f10.4,2f10.2) + ! + IF (TIDE_NIN.GT.0) THEN WRITE(LP,71) RMSRP(IDEF) - 71 FORMAT('ROOT MEAN SQUARE RESIDUAL ERROR AFTER INFERENCE IS', & - E15.6, //) - ELSE +71 FORMAT('ROOT MEAN SQUARE RESIDUAL ERROR AFTER INFERENCE IS', & + E15.6, //) + ELSE WRITE(LP,72) RMSRP(IDEF) - 72 FORMAT('RECALCULATED ROOT MEAN SQUARE RESIDUAL ERROR IS ', & - E15.6, //) - ENDIF - END DO - - END SUBROUTINE TIDE_WRITE_RESULTS - -!/ ------------------------------------------------------------------- / - SUBROUTINE TIDE_FIND_INDICES_PREDICTION(LIST,INDS,TIDE_PRMF) -!/ +-----------------------------------+ -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 28-Feb-2013 | -!/ +-----------------------------------+ -!/ -!/ 29-Jun-2013 : Creation ( version 4.11 ) -!/ -! 1. Purpose : -! -! Finds indices of tidal constituents to be used for prediction -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! LIST Char I Array of tidal constituents names to be used -! INDS I.A. O Array of indices -! TIDE_PRMF I.A. O number of constituents to be used -! ---------------------------------------------------------------- -! -! -! 4. Subroutines used : -! -! None -! -! 5. Called by : -! -! ww3_prtide -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! - USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT - USE W3ODATMD, ONLY: NDSE, NDSO +72 FORMAT('RECALCULATED ROOT MEAN SQUARE RESIDUAL ERROR IS ', & + E15.6, //) + ENDIF + END DO + + END SUBROUTINE TIDE_WRITE_RESULTS + + !/ ------------------------------------------------------------------- / + SUBROUTINE TIDE_FIND_INDICES_PREDICTION(LIST,INDS,TIDE_PRMF) + !/ +-----------------------------------+ + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 28-Feb-2013 | + !/ +-----------------------------------+ + !/ + !/ 29-Jun-2013 : Creation ( version 4.11 ) + !/ + ! 1. Purpose : + ! + ! Finds indices of tidal constituents to be used for prediction + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! LIST Char I Array of tidal constituents names to be used + ! INDS I.A. O Array of indices + ! TIDE_PRMF I.A. O number of constituents to be used + ! ---------------------------------------------------------------- + ! + ! + ! 4. Subroutines used : + ! + ! None + ! + ! 5. Called by : + ! + ! ww3_prtide + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT + USE W3ODATMD, ONLY: NDSE, NDSO #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - CHARACTER(LEN=100), INTENT(IN) :: LIST(70) - INTEGER, INTENT(OUT) :: INDS(70), TIDE_PRMF - - INTEGER J, FOUND + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + CHARACTER(LEN=100), INTENT(IN) :: LIST(70) + INTEGER, INTENT(OUT) :: INDS(70), TIDE_PRMF + + INTEGER J, FOUND #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! + ! #ifdef W3_S - CALL STRACE (IENT, 'TIDE_FIND_INDICES_PREDICTION') + CALL STRACE (IENT, 'TIDE_FIND_INDICES_PREDICTION') #endif -! - TIDE_PRMF=0 - IF (TRIM(LIST(1)).EQ.'VFAST' .OR. TRIM(LIST(1)).EQ.'FAST') THEN - DO J=1,TIDE_MF - INDS(J)=J - END DO - TIDE_PRMF = TIDE_MF - RETURN - END IF -! - DO WHILE (len_trim(LIST(TIDE_PRMF+1)).NE.0) - TIDE_PRMF=TIDE_PRMF+1 - FOUND = 0 - DO J=1,TIDE_MF - IF (TRIM(TIDECON_NAME(J)).EQ.TRIM(LIST(TIDE_PRMF))) THEN - INDS(TIDE_PRMF)=J - FOUND=1 - IF (IAPROC.EQ.NAPOUT) WRITE(NDSO,'(A,A,E12.2)') 'Tidal constituent to be used in pre:', & - TRIM(LIST(TIDE_PRMF)),TIDE_FREQC(J) - END IF - END DO - IF (FOUND.EQ.0 .AND. IAPROC.EQ.NAPOUT) WRITE(NDSO,'(3A)') 'Tidal constituent ',TRIM(LIST(TIDE_PRMF)), & - ' not available.' + ! + TIDE_PRMF=0 + IF (TRIM(LIST(1)).EQ.'VFAST' .OR. TRIM(LIST(1)).EQ.'FAST') THEN + DO J=1,TIDE_MF + INDS(J)=J END DO -! - END SUBROUTINE TIDE_FIND_INDICES_PREDICTION - - -!/ ------------------------------------------------------------------- / - SUBROUTINE TIDE_FIND_INDICES_ANALYSIS(LIST) -!/ +-----------------------------------+ -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 21-Apr-2020 | -!/ +-----------------------------------+ -!/ -!/ 29-Jun-2013 : Creation ( version 4.11 ) -!/ 21-Apr-2020 : Add 5 additional tidal const. ( version 7.13 ) -!/ -! 1. Purpose : -! -! Finds indices of tidal constituents to be used for analysis -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! LIST Char I Array of tidal constituents names to be used -! ---------------------------------------------------------------- -! -! -! 4. Subroutines used : -! -! None -! -! 5. Called by : -! -! ww3_prtide -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! - USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT - USE W3ODATMD, ONLY: NDSE, NDSO + TIDE_PRMF = TIDE_MF + RETURN + END IF + ! + DO WHILE (len_trim(LIST(TIDE_PRMF+1)).NE.0) + TIDE_PRMF=TIDE_PRMF+1 + FOUND = 0 + DO J=1,TIDE_MF + IF (TRIM(TIDECON_NAME(J)).EQ.TRIM(LIST(TIDE_PRMF))) THEN + INDS(TIDE_PRMF)=J + FOUND=1 + IF (IAPROC.EQ.NAPOUT) WRITE(NDSO,'(A,A,E12.2)') 'Tidal constituent to be used in pre:', & + TRIM(LIST(TIDE_PRMF)),TIDE_FREQC(J) + END IF + END DO + IF (FOUND.EQ.0 .AND. IAPROC.EQ.NAPOUT) WRITE(NDSO,'(3A)') 'Tidal constituent ',TRIM(LIST(TIDE_PRMF)), & + ' not available.' + END DO + ! + END SUBROUTINE TIDE_FIND_INDICES_PREDICTION + + + !/ ------------------------------------------------------------------- / + SUBROUTINE TIDE_FIND_INDICES_ANALYSIS(LIST) + !/ +-----------------------------------+ + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 21-Apr-2020 | + !/ +-----------------------------------+ + !/ + !/ 29-Jun-2013 : Creation ( version 4.11 ) + !/ 21-Apr-2020 : Add 5 additional tidal const. ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Finds indices of tidal constituents to be used for analysis + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! LIST Char I Array of tidal constituents names to be used + ! ---------------------------------------------------------------- + ! + ! + ! 4. Subroutines used : + ! + ! None + ! + ! 5. Called by : + ! + ! ww3_prtide + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT + USE W3ODATMD, ONLY: NDSE, NDSO #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - CHARACTER(LEN=100), INTENT(IN) :: LIST(70) -! - INTEGER TIDE_MF_ALL - CHARACTER(LEN=5) :: TIDECON_NAME_ALL(65) ! array of names of tidal constituents - REAL :: TIDE_FREQC_ALL(65) ! array of freq. of tidal constituents - INTEGER :: INDS(65), J, FOUND, NTIDES + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + CHARACTER(LEN=100), INTENT(IN) :: LIST(70) + ! + INTEGER TIDE_MF_ALL + CHARACTER(LEN=5) :: TIDECON_NAME_ALL(65) ! array of names of tidal constituents + REAL :: TIDE_FREQC_ALL(65) ! array of freq. of tidal constituents + INTEGER :: INDS(65), J, FOUND, NTIDES #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! + ! #ifdef W3_S - CALL STRACE (IENT, 'TIDE_FIND_INDICES_PREDICTION') + CALL STRACE (IENT, 'TIDE_FIND_INDICES_PREDICTION') #endif -! - TIDECON_NAME_ALL(:)=(/ & - 'Z0 ', 'SSA ', 'MSM ', 'MM ', 'MSF ', 'MF ', 'ALP1 ', '2Q1 ', 'SIG1 ', 'Q1 ', & - 'RHO1 ', 'O1 ', 'TAU1 ', 'BET1 ', 'NO1 ', 'CHI1 ', 'P1 ', 'K1 ', 'PHI1 ', 'THE1 ', & - 'J1 ', 'SO1 ', 'OO1 ', 'UPS1 ', 'OQ2 ', 'EPS2 ', '2N2 ', 'MU2 ', 'N2 ', 'NU2 ', & - 'M2 ', 'MKS2 ', 'LDA2 ', 'L2 ', 'S2 ', 'K2 ', 'MSN2 ', 'ETA2 ', 'MO3 ', 'M3 ', & - 'SO3 ', 'MK3 ', 'SK3 ', 'MN4 ', 'M4 ', 'SN4 ', 'MS4 ', 'MK4 ', 'S4 ', 'SK4 ', & - '2MK5 ', '2SK5 ', '2MN6 ', 'M6 ', '2MS6 ', '2MK6 ', '2SM6 ', 'MSK6 ', '3MK7 ', 'M8 ', & - 'N4 ', 'R2 ', 'S1 ', 'SA ', 'T2 ' /) -! - TIDE_FREQC_ALL(:)=(/0.0000000000, 0.0002281591, 0.0013097807, 0.0015121520, 0.0028219327, 0.0030500918, & - 0.0343965698, 0.0357063505, 0.0359087218, 0.0372185025, 0.0374208738, & - 0.0387306544, 0.0389588136, 0.0400404351, 0.0402685943, 0.0404709655, & - 0.0415525871, 0.0417807462, 0.0420089053, 0.0430905269, 0.0432928982, & - 0.0446026789, 0.0448308380, 0.0463429900, 0.0759749448, 0.0761773160, & - 0.0774870967, 0.0776894680, 0.0789992487, 0.0792016200, 0.0805114007, & - 0.0807395598, 0.0818211814, 0.0820235526, 0.0833333333, 0.0835614924, & - 0.0848454853, 0.0850736444, 0.1192420551, 0.1207671010, 0.1220639878, & - 0.1222921469, 0.1251140796, 0.1595106494, 0.1610228013, 0.1623325820, & - 0.1638447340, 0.1640728931, 0.1666666667, 0.1668948258, 0.2028035476, & - 0.2084474129, 0.2400220500, 0.2415342020, 0.2443561347, 0.2445842938, & - 0.2471780673, 0.2474062264, 0.2833149482, 0.3220456027, & - 0.157998497 , 0.083447407 , 0.041666667 , 0.000114080 , 0.083219259 /) - - INDS(:) = 0 -! - IF (TRIM(LIST(1)).EQ.'FAST') THEN - TIDE_MF = 44 - INDS(1:44)= (/ 1, 2, 3, 4, 5, 6, 12, 17, 18, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, & - 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54,& - 55, 56, 57, 58, 59, 60 /) -! - ELSE IF (TRIM(LIST(1)).EQ.'VFAST') THEN - TIDE_MF = 20 - INDS(1:20)= (/ 1, 2, 3, 5, 6, 27, 28, 29, 30, 31, 35, 36, 37, 44, 45, 47, 49, 54, 55, 60 /) -! - ELSE - TIDE_MF=0 - NTIDES=0 -! - DO WHILE (len_trim(LIST(TIDE_MF+1)).NE.0) -! - TIDE_MF=TIDE_MF+1 - FOUND = 0 - DO J=1,65 - IF (TRIM(TIDECON_NAME_ALL(J)).EQ.TRIM(LIST(TIDE_MF))) THEN - NTIDES=NTIDES+1 - INDS(NTIDES)=J - FOUND = 1 - IF (IAPROC.EQ.NAPOUT) WRITE(NDSO,'(A,I4,2A,E12.2)') & - 'Tidal constituent in analysis:', J, ' ', & - TRIM(TIDECON_NAME_ALL(J)),TIDE_FREQC_ALL(J) - END IF - END DO - IF (FOUND.EQ.0 .AND. IAPROC.EQ.NAPOUT) WRITE(NDSO,'(A,I4,A,A)') & - 'Tidal constituent ',TIDE_MF,TRIM(LIST(TIDE_MF)),' not available.' -! + ! + TIDECON_NAME_ALL(:)=(/ & + 'Z0 ', 'SSA ', 'MSM ', 'MM ', 'MSF ', 'MF ', 'ALP1 ', '2Q1 ', 'SIG1 ', 'Q1 ', & + 'RHO1 ', 'O1 ', 'TAU1 ', 'BET1 ', 'NO1 ', 'CHI1 ', 'P1 ', 'K1 ', 'PHI1 ', 'THE1 ', & + 'J1 ', 'SO1 ', 'OO1 ', 'UPS1 ', 'OQ2 ', 'EPS2 ', '2N2 ', 'MU2 ', 'N2 ', 'NU2 ', & + 'M2 ', 'MKS2 ', 'LDA2 ', 'L2 ', 'S2 ', 'K2 ', 'MSN2 ', 'ETA2 ', 'MO3 ', 'M3 ', & + 'SO3 ', 'MK3 ', 'SK3 ', 'MN4 ', 'M4 ', 'SN4 ', 'MS4 ', 'MK4 ', 'S4 ', 'SK4 ', & + '2MK5 ', '2SK5 ', '2MN6 ', 'M6 ', '2MS6 ', '2MK6 ', '2SM6 ', 'MSK6 ', '3MK7 ', 'M8 ', & + 'N4 ', 'R2 ', 'S1 ', 'SA ', 'T2 ' /) + ! + TIDE_FREQC_ALL(:)=(/0.0000000000, 0.0002281591, 0.0013097807, 0.0015121520, 0.0028219327, 0.0030500918, & + 0.0343965698, 0.0357063505, 0.0359087218, 0.0372185025, 0.0374208738, & + 0.0387306544, 0.0389588136, 0.0400404351, 0.0402685943, 0.0404709655, & + 0.0415525871, 0.0417807462, 0.0420089053, 0.0430905269, 0.0432928982, & + 0.0446026789, 0.0448308380, 0.0463429900, 0.0759749448, 0.0761773160, & + 0.0774870967, 0.0776894680, 0.0789992487, 0.0792016200, 0.0805114007, & + 0.0807395598, 0.0818211814, 0.0820235526, 0.0833333333, 0.0835614924, & + 0.0848454853, 0.0850736444, 0.1192420551, 0.1207671010, 0.1220639878, & + 0.1222921469, 0.1251140796, 0.1595106494, 0.1610228013, 0.1623325820, & + 0.1638447340, 0.1640728931, 0.1666666667, 0.1668948258, 0.2028035476, & + 0.2084474129, 0.2400220500, 0.2415342020, 0.2443561347, 0.2445842938, & + 0.2471780673, 0.2474062264, 0.2833149482, 0.3220456027, & + 0.157998497 , 0.083447407 , 0.041666667 , 0.000114080 , 0.083219259 /) + + INDS(:) = 0 + ! + IF (TRIM(LIST(1)).EQ.'FAST') THEN + TIDE_MF = 44 + INDS(1:44)= (/ 1, 2, 3, 4, 5, 6, 12, 17, 18, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, & + 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54,& + 55, 56, 57, 58, 59, 60 /) + ! + ELSE IF (TRIM(LIST(1)).EQ.'VFAST') THEN + TIDE_MF = 20 + INDS(1:20)= (/ 1, 2, 3, 5, 6, 27, 28, 29, 30, 31, 35, 36, 37, 44, 45, 47, 49, 54, 55, 60 /) + ! + ELSE + TIDE_MF=0 + NTIDES=0 + ! + DO WHILE (len_trim(LIST(TIDE_MF+1)).NE.0) + ! + TIDE_MF=TIDE_MF+1 + FOUND = 0 + DO J=1,65 + IF (TRIM(TIDECON_NAME_ALL(J)).EQ.TRIM(LIST(TIDE_MF))) THEN + NTIDES=NTIDES+1 + INDS(NTIDES)=J + FOUND = 1 + IF (IAPROC.EQ.NAPOUT) WRITE(NDSO,'(A,I4,2A,E12.2)') & + 'Tidal constituent in analysis:', J, ' ', & + TRIM(TIDECON_NAME_ALL(J)),TIDE_FREQC_ALL(J) + END IF END DO -! - TIDE_MF=NTIDES - END IF -! -! Defines names and frequencies -! - IF (ALLOCATED(TIDE_FREQC)) DEALLOCATE(TIDE_FREQC) - ALLOCATE(TIDE_FREQC(TIDE_MF),TIDECON_NAME(TIDE_MF)) - - DO J=1,TIDE_MF - TIDECON_NAME(J) = TIDECON_NAME_ALL(INDS(J)) - TIDE_FREQC(J) = TIDE_FREQC_ALL(INDS(J)) + IF (FOUND.EQ.0 .AND. IAPROC.EQ.NAPOUT) WRITE(NDSO,'(A,I4,A,A)') & + 'Tidal constituent ',TIDE_MF,TRIM(LIST(TIDE_MF)),' not available.' + ! END DO - CALL TIDE_SET_INDICES - -! - END SUBROUTINE TIDE_FIND_INDICES_ANALYSIS -!/ ------------------------------------------------------------------- / - - - -!/ ------------------------------------------------------------------- / - SUBROUTINE TIDE_SET_INDICES -! - IMPLICIT NONE -! - INTEGER J, K, K1, L, J1, JL, L2, KM1, JBASE -! - DO L=1,TIDE_MF - DO K=1,NTOTAL_CON - IF (TIDECON_ALLNAMES(k).EQ.TIDECON_NAME(L)) TIDE_INDEX2(L)=K - END DO - END DO -! - TIDE_INDEXJ(:)=0 - TIDE_INDEXJK(:)=0 - JBASE=0 - K1=NTIDAL_CON+1 -! - DO K=K1,NTOTAL_CON - J1=JBASE+1 - TIDE_INDEXJ(K)=J1 - JL=JBASE+NJ(K) - DO J=J1,JL - KM1=K-1 - L2=0 - DO L2=1,KM1 - IF (TIDECON_ALLNAMES(L2).EQ.KONCO_CON(J)) THEN - TIDE_INDEXJK(J)=L2 - END IF - END DO ! L2 - END DO ! J - JBASE=JL - END DO ! K -! - END SUBROUTINE TIDE_SET_INDICES - - -!/ ------------------------------------------------------------------- / - SUBROUTINE SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,XLAT,F,U,V) -! setvuf calculates the V,u,f values at time hr for all constituents - IMPLICIT NONE - REAL, INTENT(IN) :: XLAT - REAL(KIND=8), INTENT(IN) :: h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau - INTEGER, PARAMETER :: NTIL=44 - REAL , INTENT(OUT) :: F(NTIL),U(NTIL),V(NTIL) - REAL :: FA(170),UA(170),VA(170) -! -! Local variables -! - INTEGER :: K, L, L2, JBASE, J1, J, JL, K1 - REAL(KIND=4), PARAMETER :: PI=3.1415926536 - REAL(KIND=4), PARAMETER :: TWOPI=2.*3.1415926536 - - REAL :: SLAT, VDBL, RR, SUMC, SUMS, UUDBL, UU, CXLAT - INTEGER :: IUU, IV - ! This comment was taken from t_tide, a matlab tidal prediction suite ! - ! Apparently the second-order terms in the tidal potential go to zero - ! at the equator, but the third-order terms do not. Hence when trying - ! to infer the third-order terms from the second-order terms, the - ! nodal correction factors blow up. In order to prevent this, it is - ! assumed that the equatorial forcing is due to second-order forcing - ! OFF the equator, from about the 5 degree location. Latitudes are - ! hence (somewhat arbitrarily) forced to be no closer than 5 deg to - ! the equator, as per note in Foreman. - CXLAT = MAX(ABS(XLAT), 5.) - SLAT=SIN(PI*CXLAT/180.) - - JBASE=0 -! All -! 1'Z0 *','SA ','SSA *','MSM *','MM *,'MSF *','MF *','ALP1*','2Q1 ','SIG1 ', & -!11'Q1 ','RHO1 ','O1 *','TAU1 ','BET1 ','NO1 ','CHI1 ','PI1 ','P1 *','S1 ', & -!21'K1 *','PSI1 ','PHI1 ','THE1 ','J1 ','OO1 ','UPS1 ','OQ2 ','EPS2*','2N2 *', & -!31'MU2 *','N2 *','NU2 *','GAM2 ','H1 ','M2 *','H2 ','LDA2*','L2 *','T2 ', & -!41'S2 *','R2 ','K2 *','ETA2 ','M3 ','2PO1 ','SO1 ','ST36 ','2NS2 ','ST37 ', & -!51'ST1 ','ST2 ','ST3 ','O2 ','ST4 ','SNK2 ','OP2 ','MKS2*','ST5 ','ST6 ', & -!61'2SK2 ','MSN2 ','ST7 ','2SM2 ','ST38 ','SKM2 ','2SN2 ','NO3 ','MO3 ','NK3 ', & -!71'SO3 ','MK3 ','SP3 ','SK3 ','ST8 ','N4 ','3MS4 ','ST39 ','MN4 ','ST40 ', & -!81'ST9 ','M4 ','ST10 ','SN4 ','KN4 ','MS4 ','MK4 ','SL4 ','S4 ','SK4 ', & -!91'MNO5 ','2MO5 ','3MP5 ','MNK5 ','2MP5 ','2MK5 ','MSK5 ','3KM5 ','2SK5 ','ST11 ', & -!01'2NM6 ','ST12 ','ST41 ','2MN6 ','ST13 ','M6 ','MSN6 ','MKN6 ','2MS6 ','2MK6 ', & -!11'NSK6 ','2SM6 ','MSK6 ','ST42 ','S6 ','ST14 ','ST15 ','M7 ','ST16 ','3MK7 ', & -!21'ST17 ','ST18 ','3MN8 ','ST19 ','M8 ','ST20 ','ST21 ','3MS8 ','3MK8 ','ST22 ', & -!31'ST23 ','ST24 ','ST25 ','ST26 ','4MK9 ','ST27 ','ST28 ','M10 ','ST29 ','ST30 ', & -!41'ST31 ','ST32 ','ST33 ','M12 ','ST34 ','ST35 '/) - -! Possible -! 'Z0 ', 'SSA ', 'MSM ', 'MM ', 'MSF ', 'MF ', 'ALP1 ', '2Q1 ', 'SIG1 ', 'Q1 ', & -! 'RHO1 ', 'O1 ', 'TAU1 ', 'BET1 ', 'NO1 ', 'CHI1 ', 'P1 ', 'K1 ', 'PHI1 ', 'THE1 ', & -! 'J1 ', 'SO1 ', 'OO1 ', 'UPS1 ', 'OQ2 ', 'EPS2 ', '2N2 ', 'MU2 ', 'N2 ', 'NU2 ', & -! 'M2 ', 'MKS2 ', 'LDA2 ', 'L2 ', 'S2 ', 'K2 ', 'MSN2 ', 'ETA2 ', 'MO3 ', 'M3 ', & -! 'SO3 ', 'MK3 ', 'SK3 ', 'MN4 ', 'M4 ', 'SN4 ', 'MS4 ', 'MK4 ', 'S4 ', 'SK4 ', & -! '2MK5 ', '2SK5 ', '2MN6 ', 'M6 ', '2MS6 ', '2MK6 ', '2SM6 ', 'MSK6 ', '3MK7 ', 'M8 ' /) - -! Subset -! 'Z0 ', 'SSA ', 'MSM ', 'MM ', 'MSF ', 'MF ', & -! 'O1 ', 'P1 ', 'K1 ' , & -! 'EPS2 ', '2N2 ', 'MU2 ', 'N2 ', 'NU2 ', & -! 'M2 ', 'MKS2 ', 'LDA2 ', 'L2 ', 'S2 ', 'K2 ', 'MSN2 ', 'ETA2 ', 'MO3 ', 'M3 ', & -! 'SO3 ', 'MK3 ', 'SK3 ', 'MN4 ', 'M4 ', 'SN4 ', 'MS4 ', 'MK4 ', 'S4 ', 'SK4 ', & -! '2MK5 ', '2SK5 ', '2MN6 ', 'M6 ', '2MS6 ', '2MK6 ', '2SM6 ', 'MSK6 ', '3MK7 ', 'M8 ' /) - - -! - JBASE=0 - - ! initialize arrays to avoid NaN values - FA(:)=0 - UA(:)=0 - VA(:)=0 - - DO K=1,NTIDAL_CON - J1=JBASE+1 - JL=JBASE+NJ(K) - DO L=1,TIDE_MF - IF (TIDE_INDEX2(L).EQ.K) THEN - VDBL=II(K)*TAU+JJ(K)*S+KK(K)*H+LL(K)*P+MM(K)*ENP+NN(K)*PP+SEMI(K) - IV=VDBL - IV=(IV/2)*2 - SUMC=1. - SUMS=0. - DO J=J1,JL -! ITIME ??? -!*********************************************************************** -!* HERE THE SATELLITE AMPLITUDE RATIO ADJUSTMENT FOR LATITUDE IS MADE -! - RR=EE(J) - L2=IR(J)+1 - IF (L2.EQ.2) THEN - RR=EE(J)*0.36309*(1.-5.*SLAT*SLAT)/SLAT - ELSE IF (L2.EQ.3) THEN - RR=EE(J)*2.59808*SLAT - END IF - UUDBL=LDEL(J)*P+MDEL(J)*ENP+NDEL(J)*PP+PH(J) - IUU=UUDBL - UU=UUDBL-IUU - SUMC=SUMC+RR*COS(UU*TWOPI) - SUMS=SUMS+RR*SIN(UU*TWOPI) - END DO -! - FA(K)=SQRT(SUMC*SUMC+SUMS*SUMS) - VA(K)=VDBL-IV - UA(K)=ATAN2(SUMS,SUMC)/TWOPI + TIDE_MF=NTIDES + END IF + ! + ! Defines names and frequencies + ! + IF (ALLOCATED(TIDE_FREQC)) DEALLOCATE(TIDE_FREQC) + ALLOCATE(TIDE_FREQC(TIDE_MF),TIDECON_NAME(TIDE_MF)) + + DO J=1,TIDE_MF + TIDECON_NAME(J) = TIDECON_NAME_ALL(INDS(J)) + TIDE_FREQC(J) = TIDE_FREQC_ALL(INDS(J)) + END DO + CALL TIDE_SET_INDICES + + ! + END SUBROUTINE TIDE_FIND_INDICES_ANALYSIS + !/ ------------------------------------------------------------------- / + + + + !/ ------------------------------------------------------------------- / + SUBROUTINE TIDE_SET_INDICES + ! + IMPLICIT NONE + ! + INTEGER J, K, K1, L, J1, JL, L2, KM1, JBASE + ! + DO L=1,TIDE_MF + DO K=1,NTOTAL_CON + IF (TIDECON_ALLNAMES(k).EQ.TIDECON_NAME(L)) TIDE_INDEX2(L)=K + END DO + END DO + ! + TIDE_INDEXJ(:)=0 + TIDE_INDEXJK(:)=0 + JBASE=0 + K1=NTIDAL_CON+1 + ! + DO K=K1,NTOTAL_CON + J1=JBASE+1 + TIDE_INDEXJ(K)=J1 + JL=JBASE+NJ(K) + DO J=J1,JL + KM1=K-1 + L2=0 + DO L2=1,KM1 + IF (TIDECON_ALLNAMES(L2).EQ.KONCO_CON(J)) THEN + TIDE_INDEXJK(J)=L2 + END IF + END DO ! L2 + END DO ! J + JBASE=JL + END DO ! K + ! + END SUBROUTINE TIDE_SET_INDICES + + + !/ ------------------------------------------------------------------- / + SUBROUTINE SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,XLAT,F,U,V) + ! setvuf calculates the V,u,f values at time hr for all constituents + IMPLICIT NONE + REAL, INTENT(IN) :: XLAT + REAL(KIND=8), INTENT(IN) :: h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau + INTEGER, PARAMETER :: NTIL=44 + REAL , INTENT(OUT) :: F(NTIL),U(NTIL),V(NTIL) + REAL :: FA(170),UA(170),VA(170) + ! + ! Local variables + ! + INTEGER :: K, L, L2, JBASE, J1, J, JL, K1 + REAL(KIND=4), PARAMETER :: PI=3.1415926536 + REAL(KIND=4), PARAMETER :: TWOPI=2.*3.1415926536 + + REAL :: SLAT, VDBL, RR, SUMC, SUMS, UUDBL, UU, CXLAT + INTEGER :: IUU, IV + ! This comment was taken from t_tide, a matlab tidal prediction suite + ! + ! Apparently the second-order terms in the tidal potential go to zero + ! at the equator, but the third-order terms do not. Hence when trying + ! to infer the third-order terms from the second-order terms, the + ! nodal correction factors blow up. In order to prevent this, it is + ! assumed that the equatorial forcing is due to second-order forcing + ! OFF the equator, from about the 5 degree location. Latitudes are + ! hence (somewhat arbitrarily) forced to be no closer than 5 deg to + ! the equator, as per note in Foreman. + CXLAT = MAX(ABS(XLAT), 5.) + SLAT=SIN(PI*CXLAT/180.) + + JBASE=0 + ! All + ! 1'Z0 *','SA ','SSA *','MSM *','MM *,'MSF *','MF *','ALP1*','2Q1 ','SIG1 ', & + !11'Q1 ','RHO1 ','O1 *','TAU1 ','BET1 ','NO1 ','CHI1 ','PI1 ','P1 *','S1 ', & + !21'K1 *','PSI1 ','PHI1 ','THE1 ','J1 ','OO1 ','UPS1 ','OQ2 ','EPS2*','2N2 *', & + !31'MU2 *','N2 *','NU2 *','GAM2 ','H1 ','M2 *','H2 ','LDA2*','L2 *','T2 ', & + !41'S2 *','R2 ','K2 *','ETA2 ','M3 ','2PO1 ','SO1 ','ST36 ','2NS2 ','ST37 ', & + !51'ST1 ','ST2 ','ST3 ','O2 ','ST4 ','SNK2 ','OP2 ','MKS2*','ST5 ','ST6 ', & + !61'2SK2 ','MSN2 ','ST7 ','2SM2 ','ST38 ','SKM2 ','2SN2 ','NO3 ','MO3 ','NK3 ', & + !71'SO3 ','MK3 ','SP3 ','SK3 ','ST8 ','N4 ','3MS4 ','ST39 ','MN4 ','ST40 ', & + !81'ST9 ','M4 ','ST10 ','SN4 ','KN4 ','MS4 ','MK4 ','SL4 ','S4 ','SK4 ', & + !91'MNO5 ','2MO5 ','3MP5 ','MNK5 ','2MP5 ','2MK5 ','MSK5 ','3KM5 ','2SK5 ','ST11 ', & + !01'2NM6 ','ST12 ','ST41 ','2MN6 ','ST13 ','M6 ','MSN6 ','MKN6 ','2MS6 ','2MK6 ', & + !11'NSK6 ','2SM6 ','MSK6 ','ST42 ','S6 ','ST14 ','ST15 ','M7 ','ST16 ','3MK7 ', & + !21'ST17 ','ST18 ','3MN8 ','ST19 ','M8 ','ST20 ','ST21 ','3MS8 ','3MK8 ','ST22 ', & + !31'ST23 ','ST24 ','ST25 ','ST26 ','4MK9 ','ST27 ','ST28 ','M10 ','ST29 ','ST30 ', & + !41'ST31 ','ST32 ','ST33 ','M12 ','ST34 ','ST35 '/) + + ! Possible + ! 'Z0 ', 'SSA ', 'MSM ', 'MM ', 'MSF ', 'MF ', 'ALP1 ', '2Q1 ', 'SIG1 ', 'Q1 ', & + ! 'RHO1 ', 'O1 ', 'TAU1 ', 'BET1 ', 'NO1 ', 'CHI1 ', 'P1 ', 'K1 ', 'PHI1 ', 'THE1 ', & + ! 'J1 ', 'SO1 ', 'OO1 ', 'UPS1 ', 'OQ2 ', 'EPS2 ', '2N2 ', 'MU2 ', 'N2 ', 'NU2 ', & + ! 'M2 ', 'MKS2 ', 'LDA2 ', 'L2 ', 'S2 ', 'K2 ', 'MSN2 ', 'ETA2 ', 'MO3 ', 'M3 ', & + ! 'SO3 ', 'MK3 ', 'SK3 ', 'MN4 ', 'M4 ', 'SN4 ', 'MS4 ', 'MK4 ', 'S4 ', 'SK4 ', & + ! '2MK5 ', '2SK5 ', '2MN6 ', 'M6 ', '2MS6 ', '2MK6 ', '2SM6 ', 'MSK6 ', '3MK7 ', 'M8 ' /) + + ! Subset + ! 'Z0 ', 'SSA ', 'MSM ', 'MM ', 'MSF ', 'MF ', & + ! 'O1 ', 'P1 ', 'K1 ' , & + ! 'EPS2 ', '2N2 ', 'MU2 ', 'N2 ', 'NU2 ', & + ! 'M2 ', 'MKS2 ', 'LDA2 ', 'L2 ', 'S2 ', 'K2 ', 'MSN2 ', 'ETA2 ', 'MO3 ', 'M3 ', & + ! 'SO3 ', 'MK3 ', 'SK3 ', 'MN4 ', 'M4 ', 'SN4 ', 'MS4 ', 'MK4 ', 'S4 ', 'SK4 ', & + ! '2MK5 ', '2SK5 ', '2MN6 ', 'M6 ', '2MS6 ', '2MK6 ', '2SM6 ', 'MSK6 ', '3MK7 ', 'M8 ' /) + + + ! + JBASE=0 + + ! initialize arrays to avoid NaN values + FA(:)=0 + UA(:)=0 + VA(:)=0 + + DO K=1,NTIDAL_CON + J1=JBASE+1 + JL=JBASE+NJ(K) + DO L=1,TIDE_MF + IF (TIDE_INDEX2(L).EQ.K) THEN + VDBL=II(K)*TAU+JJ(K)*S+KK(K)*H+LL(K)*P+MM(K)*ENP+NN(K)*PP+SEMI(K) + IV=VDBL + IV=(IV/2)*2 + SUMC=1. + SUMS=0. + DO J=J1,JL + ! ITIME ??? + !*********************************************************************** + !* HERE THE SATELLITE AMPLITUDE RATIO ADJUSTMENT FOR LATITUDE IS MADE + ! + RR=EE(J) + L2=IR(J)+1 + IF (L2.EQ.2) THEN + RR=EE(J)*0.36309*(1.-5.*SLAT*SLAT)/SLAT + ELSE IF (L2.EQ.3) THEN + RR=EE(J)*2.59808*SLAT END IF - JBASE=JL ! (indx(L).EQ.K) - END DO ! L - END DO ! K -! -! HERE F AND V+U OF THE SHALLOW WATER CONSTITUENTS ARE COMPUTED FROM -! THE VALUES OF THE MAIN CONSTITUENT FROM WHICH THEY ARE DERIVED. -! - K1=NTIDAL_CON+1 - IF (K1.GT.NTOTAL_CON) RETURN -! - DO K=K1,NTOTAL_CON - FA(K)=1.0 - VA(K)=0.0 - UA(K)=0. - DO J=TIDE_INDEXJ(K),TIDE_INDEXJ(K)+NJ(K)-1 - L2=TIDE_INDEXJK(J) - FA(K)=FA(K)*FA(L2)**ABS(COEF_CON(J)) - vA(k)=vA(K)+COEF_CON(J)*vA(L2) - UA(K)=UA(k)+COEF_CON(J)*UA(L2) - END DO ! J - END DO ! K -! - DO L=1,TIDE_MF - F(L)=FA(TIDE_INDEX2(L)) - U(L)=UA(TIDE_INDEX2(L)) - V(L)=VA(TIDE_INDEX2(L)) - END DO ! L - - RETURN -! - END SUBROUTINE SETVUF_FAST - - -!/ ------------------------------------------------------------------- / - SUBROUTINE TIDE_READ_SETTINGS(filename,fnam6,fnam7,fnam8,fnam9,fnam11) - IMPLICIT NONE - CHARACTER*256, INTENT(IN) :: filename - CHARACTER*256, INTENT(OUT) :: fnam6,fnam7,fnam8,fnam9,fnam11 - - INTEGER KIN - -! Parameters for reading KR1 -! FILE I/O -! KIN is the master input file. -! fnam6 is the file to which the output is sent. It is assigned the number -! lp. -! fnam7 is file containing the constituents to be included in the analysis, -! the analysis period, inference parameters, the flag controlling -! height or current analyses, and site information. It is assigned the -! number kr1. -! fnam8 is the file containing all the astronomical argument information -! (it should not have to be changed) -! fnam11 is a file to which information on the SVD matrix fit is output when -! -! Original, fitted, and residual time series are output to file 25 while -! the same are also output to file 26 in a format that could be input to -! Excel for plotting. -! - KIN=40 ! Input file assigned to unit 4 - -! OPEN(UNIT=KIN,FILE='tuk75_tidana.inp',STATUS='OLD') -! OPEN(UNIT=KIN,FILE='victoria_2008_test.inp',STATUS='OLD') - OPEN(UNIT=KIN,FILE=filename,STATUS='OLD') -! OPEN(UNIT=KIN,FILE='kiw05_mar2008.inp',STATUS='OLD') -! OPEN(UNIT=KIN,FILE='tcs05_sep07-mar08.inp',STATUS='OLD') - read(KIN,'(a)') fnam6 - read(KIN,'(a)') fnam7 - read(KIN,'(a)') fnam8 - read(KIN,'(a)') fnam9 - read(KIN,'(a)') fnam11 -! open(unit=11,file=fnam11,status='unknown',form='formatted') -! unit 25 stores the residual time series - !read(KIN,'(a)') fname - !open(unit=25,file=fname,status='unknown',form='formatted') - !read(KIN,'(a)') fname - !open(unit=26,file=fname,status='unknown',form='formatted') - END SUBROUTINE TIDE_READ_SETTINGS - -!/ ------------------------------------------------------------------- / - SUBROUTINE TIDE_READ_ANAPAR(KR1,LP,filename,KD1,KD2,XLON,XLAT,NDEF,ITREND,ITZ) -! Parameters for reading KR1 - IMPLICIT NONE - - INTEGER, INTENT(IN) :: KR1, LP - CHARACTER*256, INTENT(IN) :: filename - INTEGER(KIND=4), INTENT(OUT) :: KD1, KD2 - INTEGER , INTENT(OUT) :: NDEF,ITREND - REAL, INTENT(OUT) :: XLON, XLAT - CHARACTER*4 , INTENT(OUT) :: ITZ -! - INTEGER :: I, IY - INTEGER ID1,IM1,IY1,ID2,IM2,IY2,IC1,IC2 - INTEGER JSTN, LATD,LATM,LOND,LONM, K, K2 - CHARACTER*4 NSTN(5) - - open(unit=kr1,file=filename,status='old',form='formatted') - -! -!* -!*********************************************************************** -!* READ FROM DEVICE KR1 THE ANALYSIS TYPE AND TIDAL STATION DETAILS. -!* -!* 1)ONE RECORD FOR THE VARIABLES TIDE_MF -!* TIDE_MF = THE NUMBER OF CONSTITUENTS, INCLUDING THE CONSTANT TERM Z0, -!* TO BE IN THE LEAST SQUARES FIT. -!* -!* 2)ONE RECORD FOR EACH OF THE TIDE_MF CONSTITUENTS TO BE INCLUDED IN THE -!* FIT. EACH RECORD CONTAINS THE VARIABLES NAME AND TIDE_FREQC IN THE -!* FORMAT (A5,2X,F13.10). NAME IS THE CONSTITUENT NAME, WHICH SHOULD -!* BE LEFT JUSTIFIED IN THE ALPHANUMERIC FIELD, WHILE TIDE_FREQC IS ITS -!* FREQUENCY MEASURED IN CYCLES PER HOUR. -!* -!* 3) ONE RECORD IN THE FORMAT (8I5) CONTAINING THE FOLLOWING -!* INFORMATION ON THE TIME PERIOD OF THE ANALYSIS. -!* ID1,IM1,IY1 - DAY,MONTH,YEAR OF THE BEGINNING OF THE ANALYSIS -!* PERIOD, -!* ID2,IM2,IY2 - DAY,MONTH,YEAR OF THE END OF THE ANALYSIS PERIOD. -!* IC1,IC2 - CENTURY OFR THE BEGINNING AND END OF THE ANALYSIS -!* PERIOD (ZERO VALUES ARE RESET TO 19) -!* -!* -!* 4)ONE RECORD IN THE FORMAT (I5,5A4,1X,A4,4I5) CONTAINING THE -!* FOLLOWING TIDAL STATION INFORMATION. -!* JSTN = TIDAL STATION NUMBER, -!* (NSTN(I),I=1,5) = TIDAL STATION NAME, -! * ITZ = TIME ZONE IN WHICH THE OBSERVATIONS WERE RECORDED, -! * LATD,LATM = STATION LATITUDE IN DEGREES AND MINUTES, -! * LOND,LONM = STATION LONGITUDE IN DEGREES AND MINUTES. -! * -! * 5)ONE SET RECORDS FOR EACH POSSIBLE INFERENCE. THE FIRST RECORD HAS THE -! * CONSITUENT NAME, ITS FREQUENCY, AND THE NUMBER OF CONSTITUENTS TO BE -! * INFERRED (4X,A5,E16.10,i5), WHILE THERE IS ONE RECORD FOR EACH OF THE -! * CONSTITUENTS TO BE INFERRED WITH THE NAME, FREQUENCY, AMPLITUDE RATIO -! * (INFERRED TO REFERENCE) AND PHASE DIFFERENCE (GREENWICH PHASE LAG OF -! * THE INFERRED CONSTITUENT SUBTRACTED FROM THE GREENWICH PHASE LAG OF THE -! * (ANALYSED CONSTITUENT IN THE FORMAT(4X,A5,E16.10,2F10.3) -! * -! * FOR KR1 INPUT, ALL CONSTITUENT NAMES SHOULD BE LEFT JUSTIFIED IN -! * THE ALPHANUMERIC FIELD, FREQUENCIES ARE MEASURED IN CYCLES/HOUR, AND -! * ALL CONSTITUENTS MUST BE INCLUDED IN THE LIST IN READ FROM FNAM8. -! -! write(6,*) ' reading from unit kr1' - READ(KR1,*) TIDE_MF,ndef,itrend - ALLOCATE(TIDE_FREQC(TIDE_MF),TIDECON_NAME(TIDE_MF)) -! ndef=1 if only 1D field to be analysed (eg., elevations) -! ndef=2 if 2D field: velocity components, EW followed by NS : this is now de-activated + UUDBL=LDEL(J)*P+MDEL(J)*ENP+NDEL(J)*PP+PH(J) + IUU=UUDBL + UU=UUDBL-IUU + SUMC=SUMC+RR*COS(UU*TWOPI) + SUMS=SUMS+RR*SIN(UU*TWOPI) + END DO + ! + FA(K)=SQRT(SUMC*SUMC+SUMS*SUMS) + VA(K)=VDBL-IV + UA(K)=ATAN2(SUMS,SUMC)/TWOPI + END IF + JBASE=JL ! (indx(L).EQ.K) + END DO ! L + END DO ! K + ! + ! HERE F AND V+U OF THE SHALLOW WATER CONSTITUENTS ARE COMPUTED FROM + ! THE VALUES OF THE MAIN CONSTITUENT FROM WHICH THEY ARE DERIVED. + ! + K1=NTIDAL_CON+1 + IF (K1.GT.NTOTAL_CON) RETURN + ! + DO K=K1,NTOTAL_CON + FA(K)=1.0 + VA(K)=0.0 + UA(K)=0. + DO J=TIDE_INDEXJ(K),TIDE_INDEXJ(K)+NJ(K)-1 + L2=TIDE_INDEXJK(J) + FA(K)=FA(K)*FA(L2)**ABS(COEF_CON(J)) + vA(k)=vA(K)+COEF_CON(J)*vA(L2) + UA(K)=UA(k)+COEF_CON(J)*UA(L2) + END DO ! J + END DO ! K + ! + DO L=1,TIDE_MF + F(L)=FA(TIDE_INDEX2(L)) + U(L)=UA(TIDE_INDEX2(L)) + V(L)=VA(TIDE_INDEX2(L)) + END DO ! L + + RETURN + ! + END SUBROUTINE SETVUF_FAST + + + !/ ------------------------------------------------------------------- / + SUBROUTINE TIDE_READ_SETTINGS(filename,fnam6,fnam7,fnam8,fnam9,fnam11) + IMPLICIT NONE + CHARACTER*256, INTENT(IN) :: filename + CHARACTER*256, INTENT(OUT) :: fnam6,fnam7,fnam8,fnam9,fnam11 + + INTEGER KIN + + ! Parameters for reading KR1 + ! FILE I/O + ! KIN is the master input file. + ! fnam6 is the file to which the output is sent. It is assigned the number + ! lp. + ! fnam7 is file containing the constituents to be included in the analysis, + ! the analysis period, inference parameters, the flag controlling + ! height or current analyses, and site information. It is assigned the + ! number kr1. + ! fnam8 is the file containing all the astronomical argument information + ! (it should not have to be changed) + ! fnam11 is a file to which information on the SVD matrix fit is output when + ! + ! Original, fitted, and residual time series are output to file 25 while + ! the same are also output to file 26 in a format that could be input to + ! Excel for plotting. + ! + KIN=40 ! Input file assigned to unit 4 + + ! OPEN(UNIT=KIN,FILE='tuk75_tidana.inp',STATUS='OLD') + ! OPEN(UNIT=KIN,FILE='victoria_2008_test.inp',STATUS='OLD') + OPEN(UNIT=KIN,FILE=filename,STATUS='OLD') + ! OPEN(UNIT=KIN,FILE='kiw05_mar2008.inp',STATUS='OLD') + ! OPEN(UNIT=KIN,FILE='tcs05_sep07-mar08.inp',STATUS='OLD') + read(KIN,'(a)') fnam6 + read(KIN,'(a)') fnam7 + read(KIN,'(a)') fnam8 + read(KIN,'(a)') fnam9 + read(KIN,'(a)') fnam11 + ! open(unit=11,file=fnam11,status='unknown',form='formatted') + ! unit 25 stores the residual time series + !read(KIN,'(a)') fname + !open(unit=25,file=fname,status='unknown',form='formatted') + !read(KIN,'(a)') fname + !open(unit=26,file=fname,status='unknown',form='formatted') + END SUBROUTINE TIDE_READ_SETTINGS + + !/ ------------------------------------------------------------------- / + SUBROUTINE TIDE_READ_ANAPAR(KR1,LP,filename,KD1,KD2,XLON,XLAT,NDEF,ITREND,ITZ) + ! Parameters for reading KR1 + IMPLICIT NONE + + INTEGER, INTENT(IN) :: KR1, LP + CHARACTER*256, INTENT(IN) :: filename + INTEGER(KIND=4), INTENT(OUT) :: KD1, KD2 + INTEGER , INTENT(OUT) :: NDEF,ITREND + REAL, INTENT(OUT) :: XLON, XLAT + CHARACTER*4 , INTENT(OUT) :: ITZ + ! + INTEGER :: I, IY + INTEGER ID1,IM1,IY1,ID2,IM2,IY2,IC1,IC2 + INTEGER JSTN, LATD,LATM,LOND,LONM, K, K2 + CHARACTER*4 NSTN(5) + + open(unit=kr1,file=filename,status='old',form='formatted') + + ! + !* + !*********************************************************************** + !* READ FROM DEVICE KR1 THE ANALYSIS TYPE AND TIDAL STATION DETAILS. + !* + !* 1)ONE RECORD FOR THE VARIABLES TIDE_MF + !* TIDE_MF = THE NUMBER OF CONSTITUENTS, INCLUDING THE CONSTANT TERM Z0, + !* TO BE IN THE LEAST SQUARES FIT. + !* + !* 2)ONE RECORD FOR EACH OF THE TIDE_MF CONSTITUENTS TO BE INCLUDED IN THE + !* FIT. EACH RECORD CONTAINS THE VARIABLES NAME AND TIDE_FREQC IN THE + !* FORMAT (A5,2X,F13.10). NAME IS THE CONSTITUENT NAME, WHICH SHOULD + !* BE LEFT JUSTIFIED IN THE ALPHANUMERIC FIELD, WHILE TIDE_FREQC IS ITS + !* FREQUENCY MEASURED IN CYCLES PER HOUR. + !* + !* 3) ONE RECORD IN THE FORMAT (8I5) CONTAINING THE FOLLOWING + !* INFORMATION ON THE TIME PERIOD OF THE ANALYSIS. + !* ID1,IM1,IY1 - DAY,MONTH,YEAR OF THE BEGINNING OF THE ANALYSIS + !* PERIOD, + !* ID2,IM2,IY2 - DAY,MONTH,YEAR OF THE END OF THE ANALYSIS PERIOD. + !* IC1,IC2 - CENTURY OFR THE BEGINNING AND END OF THE ANALYSIS + !* PERIOD (ZERO VALUES ARE RESET TO 19) + !* + !* + !* 4)ONE RECORD IN THE FORMAT (I5,5A4,1X,A4,4I5) CONTAINING THE + !* FOLLOWING TIDAL STATION INFORMATION. + !* JSTN = TIDAL STATION NUMBER, + !* (NSTN(I),I=1,5) = TIDAL STATION NAME, + ! * ITZ = TIME ZONE IN WHICH THE OBSERVATIONS WERE RECORDED, + ! * LATD,LATM = STATION LATITUDE IN DEGREES AND MINUTES, + ! * LOND,LONM = STATION LONGITUDE IN DEGREES AND MINUTES. + ! * + ! * 5)ONE SET RECORDS FOR EACH POSSIBLE INFERENCE. THE FIRST RECORD HAS THE + ! * CONSITUENT NAME, ITS FREQUENCY, AND THE NUMBER OF CONSTITUENTS TO BE + ! * INFERRED (4X,A5,E16.10,i5), WHILE THERE IS ONE RECORD FOR EACH OF THE + ! * CONSTITUENTS TO BE INFERRED WITH THE NAME, FREQUENCY, AMPLITUDE RATIO + ! * (INFERRED TO REFERENCE) AND PHASE DIFFERENCE (GREENWICH PHASE LAG OF + ! * THE INFERRED CONSTITUENT SUBTRACTED FROM THE GREENWICH PHASE LAG OF THE + ! * (ANALYSED CONSTITUENT IN THE FORMAT(4X,A5,E16.10,2F10.3) + ! * + ! * FOR KR1 INPUT, ALL CONSTITUENT NAMES SHOULD BE LEFT JUSTIFIED IN + ! * THE ALPHANUMERIC FIELD, FREQUENCIES ARE MEASURED IN CYCLES/HOUR, AND + ! * ALL CONSTITUENTS MUST BE INCLUDED IN THE LIST IN READ FROM FNAM8. + ! + ! write(6,*) ' reading from unit kr1' + READ(KR1,*) TIDE_MF,ndef,itrend + ALLOCATE(TIDE_FREQC(TIDE_MF),TIDECON_NAME(TIDE_MF)) + ! ndef=1 if only 1D field to be analysed (eg., elevations) + ! ndef=2 if 2D field: velocity components, EW followed by NS : this is now de-activated #ifdef W3_T - WRITE(6,*) ' number of constituents & degrees of freedom=',TIDE_MF,ndef + WRITE(6,*) ' number of constituents & degrees of freedom=',TIDE_MF,ndef #endif - IF (itrend.eq.1) then + IF (itrend.eq.1) then #ifdef W3_T WRITE(6,*) ' a linear trend is included in the analysis' #endif - else + else #ifdef W3_T WRITE(6,*) ' no linear trend is included' #endif - END IF -! TIDE_MF= number of consituents, excluding linear trend. The constant -! term, Z0 should be first in the list. -! itrend= 1 if include linear trend -! itrend= otherwise, no trend -! number of unknowns, M, depends on whether we have a linear trend - - 10 FORMAT(2I5,F5.2) - READ(KR1,11) (TIDECON_NAME(I),TIDE_FREQC(I),I=1,TIDE_MF) + END IF + ! TIDE_MF= number of consituents, excluding linear trend. The constant + ! term, Z0 should be first in the list. + ! itrend= 1 if include linear trend + ! itrend= otherwise, no trend + ! number of unknowns, M, depends on whether we have a linear trend + +10 FORMAT(2I5,F5.2) + READ(KR1,11) (TIDECON_NAME(I),TIDE_FREQC(I),I=1,TIDE_MF) #ifdef W3_T - WRITE(6,*) (TIDECON_NAME(I),TIDE_FREQC(I),I=1,TIDE_MF) + WRITE(6,*) (TIDECON_NAME(I),TIDE_FREQC(I),I=1,TIDE_MF) #endif - 11 FORMAT(4x,A5,F16.10) - READ(KR1,7) ID1,IM1,IY1,ID2,IM2,IY2,IC1,IC2 +11 FORMAT(4x,A5,F16.10) + READ(KR1,7) ID1,IM1,IY1,ID2,IM2,IY2,IC1,IC2 #ifdef W3_T - WRITE(6,*) ID1,IM1,IY1,ID2,IM2,IY2,IC1,IC2 + WRITE(6,*) ID1,IM1,IY1,ID2,IM2,IY2,IC1,IC2 #endif - IF (IC1.EQ.0) IC1=19 - IF (IC2.EQ.0) IC2=19 - 7 FORMAT(16I5) - READ(KR1,9) JSTN,NSTN(1:5),ITZ,LATD,LATM,LOND,LONM - 9 FORMAT(I5,5A4,1X,A4,4I5) - - iy=ic1*100+iy1 - kd1=JULDAYT(id1,im1,iy) - - iy=ic2*100+iy2 - kd2=JULDAYT(id2,im2,iy) -! -! read in inference information now as it will be used in the lsq matrix -! - DO K=1,10 - READ(KR1,'(4X,A5,E16.10,i5)')TIDE_KONAN(K),TIDE_SIGAN(K),TIDE_NINF(k) -! write(6,1010)TIDE_KONAN(K),TIDE_SIGAN(K),TIDE_NINF(k) - IF (TIDE_KONAN(K).EQ.KBLANK) EXIT - do k2=1,TIDE_NINF(k) - read(kr1,'(4X,A5,E16.10,2F10.3)') TIDE_KONIN(K,k2),TIDE_SIGIN(K,k2),TIDE_R(K,k2),TIDE_ZETA(K,k2) - END DO - END DO - TIDE_NIN=K-1 - CLOSE(kr1) - - xlat=latd+latm/60. - xlon=lond+lonm/60. - - RETURN - END SUBROUTINE TIDE_READ_ANAPAR - -!/ ------------------------------------------------------------------- / - SUBROUTINE TIDE_READ_TIMESERIES(KR2,filename,KD1,KD2,TIDE_NTI,NDEF) -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: KR2, NDEF - CHARACTER*256, INTENT(IN) :: filename - INTEGER(KIND=4), INTENT(IN) :: KD1,KD2 - INTEGER(KIND=4), INTENT(OUT) :: TIDE_NTI -! - INTEGER :: I, idd,imm,icc,iyy,ihh,imin,isec,iy - REAL, ALLOCATABLE :: TIDE_DATATMP(:,:) - INTEGER(KIND=4), ALLOCATABLE :: TIDE_DAYSTMP(:), TIDE_SECSTMP(:) - INTEGER(KIND=4) :: KDD - INTEGER :: ICODE - REAL :: htt(NDEF) -! -! Initialize Variables -! - ALLOCATE( TIDE_DATATMP(NR,NDEF), TIDE_DAYSTMP(NR), TIDE_SECSTMP(NR) ) - -! Reads in data between dates kd1 and kd2 in file kr2 -! - OPEN(unit=kr2,file=filename,status='old',form='formatted') - - ICODE = 0 - KDD = KD1 - I=0 - DO WHILE(ICODE.EQ.0.AND.KDD.LE.KD2) -! -! reads with the original Foreman's format -! - READ(kr2,145,IOSTAT=ICODE) idd,imm,icc,iyy,ihh,imin,htt(1:NDEF) -145 format(6i2,4f10.4) - isec=0 - iy=icc*100+iyy - - kdd=JULDAYT(idd,imm,iy) - - IF (kdD.lt.kd1) then - WRITE(*,*) icc,iyy,imm,idd,ihh,imin - WRITE(*,*)'kd, kd1, kd2 =',kdd,kd1,kd2 - write(*,*) ' observation before analysis period' - ELSE -! -! Fills in data array -! - IF (ICODE.EQ.0.AND.KDD.LE.KD2) THEN - i=i+1 - TIDE_DATATMP(I,:)=htt(:) - TIDE_DAYSTMP(I)=kdd - TIDE_SECSTMP(I)=ihh*3600+imin*60+isec - END IF - END IF - END DO - - TIDE_NTI=i - ALLOCATE( TIDE_DATA(TIDE_NTI,NDEF) ) - ALLOCATE( TIDE_DAYS(TIDE_NTI), TIDE_SECS(TIDE_NTI), TIDE_HOURS(TIDE_NTI) ) - TIDE_DATA(1:TIDE_NTI,1:NDEF)=TIDE_DATATMP(1:TIDE_NTI,1:NDEF) - TIDE_DAYS(1:TIDE_NTI)=TIDE_DAYSTMP(1:TIDE_NTI) - TIDE_SECS(1:TIDE_NTI)=TIDE_SECSTMP(1:TIDE_NTI) - TIDE_HOURS(:)=24.d0*dfloat(TIDE_DAYS(:))+dfloat(TIDE_SECS(:))/3600.d0 - CLOSE(KR2) - RETURN - END SUBROUTINE TIDE_READ_TIMESERIES - -!/ ------------------------------------------------------------------- / - SUBROUTINE ASTR(d1,h,pp,s,p,np,dh,dpp,ds,dp,dnp) -! this subroutine calculates the following five ephermides -! of the sun and moon -! h = mean longitude of the sum -! pp = mean longitude of the solar perigee -! s = mean longitude of the moon -! p = mean longitude of the lunar perigee -! np = negative of the longitude of the mean ascending node -! and their rates of change. -! Units for the ephermides are cycles and for their derivatives -! are cycles/365 days -! The formulae for calculating this ephermides were taken from -! pages 98 and 107 of the Explanatory Supplement to the -! Astronomical Ephermeris and the American Ephermis and -! Nautical Almanac (1961) -! - implicit none - REAL(KIND=8), INTENT(IN ):: d1 - REAL(KIND=8), INTENT(OUT):: h,pp,s,p,np,dh,dpp,ds,dp,dnp -! -! Local variables -! - REAL(KIND=8) :: d2,f,f2 - - d2=d1*1.d-4 - f=360.d0 - f2=f/365.d0 - h=279.696678d0+.9856473354d0*d1+.00002267d0*d2*d2 - pp=281.220833d0+.0000470684d0*d1+.0000339d0*d2*d2+& - .00000007d0*d2**3 - s=270.434164d0+13.1763965268d0*d1-.000085d0*d2*d2+& - .000000039d0*d2**3 - p=334.329556d0+.1114040803d0*d1-.0007739d0*d2*d2-& - .00000026d0*d2**3 - np=-259.183275d0+.0529539222d0*d1-.0001557d0*d2*d2-& - .00000005d0*d2**3 - h=h/f - pp=pp/f - s=s/f - p=p/f - np=np/f - h=h-dint(h) - pp=pp-dint(pp) - s=s-dint(s) - p=p-dint(p) - np=np-dint(np) - dh=.9856473354d0+2.d-8*.00002267d0*d1 - dpp=.0000470684d0+2.d-8*.0000339d0*d1& - +3.d-12*.00000007d0*d1**2 - ds=13.1763965268d0-2.d-8*.000085d0*d1+& - 3.d-12*.000000039d0*d1**2 - dp=.1114040803d0-2.d-8*.0007739d0*d1-& - 3.d-12*.00000026d0*d1**2 - dnp=+.0529539222d0-2.d-8*.0001557d0*d1-& - 3.d-12*.00000005d0*d1**2 - dh=dh/f2 - dpp=dpp/f2 - ds=ds/f2 - dp=dp/f2 - dnp=dnp/f2 - return - end SUBROUTINE ASTR + IF (IC1.EQ.0) IC1=19 + IF (IC2.EQ.0) IC2=19 +7 FORMAT(16I5) + READ(KR1,9) JSTN,NSTN(1:5),ITZ,LATD,LATM,LOND,LONM +9 FORMAT(I5,5A4,1X,A4,4I5) + + iy=ic1*100+iy1 + kd1=JULDAYT(id1,im1,iy) + + iy=ic2*100+iy2 + kd2=JULDAYT(id2,im2,iy) + ! + ! read in inference information now as it will be used in the lsq matrix + ! + DO K=1,10 + READ(KR1,'(4X,A5,E16.10,i5)')TIDE_KONAN(K),TIDE_SIGAN(K),TIDE_NINF(k) + ! write(6,1010)TIDE_KONAN(K),TIDE_SIGAN(K),TIDE_NINF(k) + IF (TIDE_KONAN(K).EQ.KBLANK) EXIT + do k2=1,TIDE_NINF(k) + read(kr1,'(4X,A5,E16.10,2F10.3)') TIDE_KONIN(K,k2),TIDE_SIGIN(K,k2),TIDE_R(K,k2),TIDE_ZETA(K,k2) + END DO + END DO + TIDE_NIN=K-1 + CLOSE(kr1) + + xlat=latd+latm/60. + xlon=lond+lonm/60. + + RETURN + END SUBROUTINE TIDE_READ_ANAPAR + + !/ ------------------------------------------------------------------- / + SUBROUTINE TIDE_READ_TIMESERIES(KR2,filename,KD1,KD2,TIDE_NTI,NDEF) + ! + IMPLICIT NONE + ! + INTEGER, INTENT(IN) :: KR2, NDEF + CHARACTER*256, INTENT(IN) :: filename + INTEGER(KIND=4), INTENT(IN) :: KD1,KD2 + INTEGER(KIND=4), INTENT(OUT) :: TIDE_NTI + ! + INTEGER :: I, idd,imm,icc,iyy,ihh,imin,isec,iy + REAL, ALLOCATABLE :: TIDE_DATATMP(:,:) + INTEGER(KIND=4), ALLOCATABLE :: TIDE_DAYSTMP(:), TIDE_SECSTMP(:) + INTEGER(KIND=4) :: KDD + INTEGER :: ICODE + REAL :: htt(NDEF) + ! + ! Initialize Variables + ! + ALLOCATE( TIDE_DATATMP(NR,NDEF), TIDE_DAYSTMP(NR), TIDE_SECSTMP(NR) ) + + ! Reads in data between dates kd1 and kd2 in file kr2 + ! + OPEN(unit=kr2,file=filename,status='old',form='formatted') + + ICODE = 0 + KDD = KD1 + I=0 + DO WHILE(ICODE.EQ.0.AND.KDD.LE.KD2) + ! + ! reads with the original Foreman's format + ! + READ(kr2,145,IOSTAT=ICODE) idd,imm,icc,iyy,ihh,imin,htt(1:NDEF) +145 format(6i2,4f10.4) + isec=0 + iy=icc*100+iyy + kdd=JULDAYT(idd,imm,iy) -!/ ------------------------------------------------------------------- / -! Note by FA: should try to replace with standard distance d= sqrt(a^2+b^2) - FUNCTION dpythag(a,b) - DOUBLE PRECISION a,b,dpythag - DOUBLE PRECISION absa,absb - absa=abs(a) - absb=abs(b) - IF (absa.gt.absb)then - dpythag=absa*sqrt(1.0d0+(absb/absa)**2) + IF (kdD.lt.kd1) then + WRITE(*,*) icc,iyy,imm,idd,ihh,imin + WRITE(*,*)'kd, kd1, kd2 =',kdd,kd1,kd2 + write(*,*) ' observation before analysis period' + ELSE + ! + ! Fills in data array + ! + IF (ICODE.EQ.0.AND.KDD.LE.KD2) THEN + i=i+1 + TIDE_DATATMP(I,:)=htt(:) + TIDE_DAYSTMP(I)=kdd + TIDE_SECSTMP(I)=ihh*3600+imin*60+isec + END IF + END IF + END DO + + TIDE_NTI=i + ALLOCATE( TIDE_DATA(TIDE_NTI,NDEF) ) + ALLOCATE( TIDE_DAYS(TIDE_NTI), TIDE_SECS(TIDE_NTI), TIDE_HOURS(TIDE_NTI) ) + TIDE_DATA(1:TIDE_NTI,1:NDEF)=TIDE_DATATMP(1:TIDE_NTI,1:NDEF) + TIDE_DAYS(1:TIDE_NTI)=TIDE_DAYSTMP(1:TIDE_NTI) + TIDE_SECS(1:TIDE_NTI)=TIDE_SECSTMP(1:TIDE_NTI) + TIDE_HOURS(:)=24.d0*dfloat(TIDE_DAYS(:))+dfloat(TIDE_SECS(:))/3600.d0 + CLOSE(KR2) + RETURN + END SUBROUTINE TIDE_READ_TIMESERIES + + !/ ------------------------------------------------------------------- / + SUBROUTINE ASTR(d1,h,pp,s,p,np,dh,dpp,ds,dp,dnp) + ! this subroutine calculates the following five ephermides + ! of the sun and moon + ! h = mean longitude of the sum + ! pp = mean longitude of the solar perigee + ! s = mean longitude of the moon + ! p = mean longitude of the lunar perigee + ! np = negative of the longitude of the mean ascending node + ! and their rates of change. + ! Units for the ephermides are cycles and for their derivatives + ! are cycles/365 days + ! The formulae for calculating this ephermides were taken from + ! pages 98 and 107 of the Explanatory Supplement to the + ! Astronomical Ephermeris and the American Ephermis and + ! Nautical Almanac (1961) + ! + implicit none + REAL(KIND=8), INTENT(IN ):: d1 + REAL(KIND=8), INTENT(OUT):: h,pp,s,p,np,dh,dpp,ds,dp,dnp + ! + ! Local variables + ! + REAL(KIND=8) :: d2,f,f2 + + d2=d1*1.d-4 + f=360.d0 + f2=f/365.d0 + h=279.696678d0+.9856473354d0*d1+.00002267d0*d2*d2 + pp=281.220833d0+.0000470684d0*d1+.0000339d0*d2*d2+& + .00000007d0*d2**3 + s=270.434164d0+13.1763965268d0*d1-.000085d0*d2*d2+& + .000000039d0*d2**3 + p=334.329556d0+.1114040803d0*d1-.0007739d0*d2*d2-& + .00000026d0*d2**3 + np=-259.183275d0+.0529539222d0*d1-.0001557d0*d2*d2-& + .00000005d0*d2**3 + h=h/f + pp=pp/f + s=s/f + p=p/f + np=np/f + h=h-dint(h) + pp=pp-dint(pp) + s=s-dint(s) + p=p-dint(p) + np=np-dint(np) + dh=.9856473354d0+2.d-8*.00002267d0*d1 + dpp=.0000470684d0+2.d-8*.0000339d0*d1& + +3.d-12*.00000007d0*d1**2 + ds=13.1763965268d0-2.d-8*.000085d0*d1+& + 3.d-12*.000000039d0*d1**2 + dp=.1114040803d0-2.d-8*.0007739d0*d1-& + 3.d-12*.00000026d0*d1**2 + dnp=+.0529539222d0-2.d-8*.0001557d0*d1-& + 3.d-12*.00000005d0*d1**2 + dh=dh/f2 + dpp=dpp/f2 + ds=ds/f2 + dp=dp/f2 + dnp=dnp/f2 + return + end SUBROUTINE ASTR + + + !/ ------------------------------------------------------------------- / + ! Note by FA: should try to replace with standard distance d= sqrt(a^2+b^2) + FUNCTION dpythag(a,b) + DOUBLE PRECISION a,b,dpythag + DOUBLE PRECISION absa,absb + absa=abs(a) + absb=abs(b) + IF (absa.gt.absb)then + dpythag=absa*sqrt(1.0d0+(absb/absa)**2) + else + IF (absb.eq.0.0d0)then + dpythag=0.0d0 else - IF (absb.eq.0.0d0)then - dpythag=0.0d0 - else - dpythag=absb*sqrt(1.0d0+(absa/absb)**2) - endif + dpythag=absb*sqrt(1.0d0+(absa/absb)**2) endif - return - END FUNCTION dpythag - -!/ ------------------------------------------------------------------- / -! (C) Copr. 1986-92 Numerical Recipes Software '%1&&Yw^2. - SUBROUTINE dsvbksb(u,w,v,m,n,mp,np,b,x) - INTEGER m,mp,n,np,NMAX - DOUBLE PRECISION b(mp),u(mp,np),v(np,np),w(np),x(np) - PARAMETER (NMAX=500) - INTEGER i,j,jj - DOUBLE PRECISION s,tmp(NMAX) + endif + return + END FUNCTION dpythag + + !/ ------------------------------------------------------------------- / + ! (C) Copr. 1986-92 Numerical Recipes Software '%1&&Yw^2. + SUBROUTINE dsvbksb(u,w,v,m,n,mp,np,b,x) + INTEGER m,mp,n,np,NMAX + DOUBLE PRECISION b(mp),u(mp,np),v(np,np),w(np),x(np) + PARAMETER (NMAX=500) + INTEGER i,j,jj + DOUBLE PRECISION s,tmp(NMAX) do j=1,n - s=0.0d0 - IF (w(j).ne.0.0d0)then - do i=1,m - s=s+u(i,j)*b(i) - end do - s=s/w(j) - endif - tmp(j)=s + s=0.0d0 + IF (w(j).ne.0.0d0)then + do i=1,m + s=s+u(i,j)*b(i) + end do + s=s/w(j) + endif + tmp(j)=s end do do j=1,n - s=0.0d0 - do jj=1,n - s=s+v(j,jj)*tmp(jj) - end do - x(j)=s + s=0.0d0 + do jj=1,n + s=s+v(j,jj)*tmp(jj) + end do + x(j)=s end do - return - END SUBROUTINE dsvbksb + return + END SUBROUTINE dsvbksb -!/ ------------------------------------------------------------------- / - SUBROUTINE dsvdcmp(a,m,n,mp,np,w,v) - INTEGER m,mp,n,np,NMAX - DOUBLE PRECISION a(mp,np),v(np,np),w(np) - PARAMETER (NMAX=500) - - INTEGER i,its,j,jj,k,l,nm - DOUBLE PRECISION anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX) - + !/ ------------------------------------------------------------------- / + SUBROUTINE dsvdcmp(a,m,n,mp,np,w,v) + INTEGER m,mp,n,np,NMAX + DOUBLE PRECISION a(mp,np),v(np,np),w(np) + PARAMETER (NMAX=500) + + INTEGER i,its,j,jj,k,l,nm + DOUBLE PRECISION anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX) + + g=0.0d0 + scale=0.0d0 + anorm=0.0d0 + do i=1,n + l=i+1 + rv1(i)=scale*g g=0.0d0 + s=0.0d0 scale=0.0d0 - anorm=0.0d0 - do i=1,n - l=i+1 - rv1(i)=scale*g - g=0.0d0 - s=0.0d0 - scale=0.0d0 - IF (i.le.m)then - DO k=i,m - scale=scale+abs(a(k,i)) + IF (i.le.m)then + DO k=i,m + scale=scale+abs(a(k,i)) + END DO + IF (scale.ne.0.0d0) THEN + DO k=i,m + a(k,i)=a(k,i)/scale + s=s+a(k,i)*a(k,i) + END DO + f=a(i,i) + g=-sign(sqrt(s),f) + h=f*g-s + a(i,i)=f-g + DO j=l,n + s=0.0d0 + DO k=i,m + s=s+a(k,i)*a(k,j) END DO - IF (scale.ne.0.0d0) THEN - DO k=i,m - a(k,i)=a(k,i)/scale - s=s+a(k,i)*a(k,i) - END DO - f=a(i,i) - g=-sign(sqrt(s),f) - h=f*g-s - a(i,i)=f-g - DO j=l,n - s=0.0d0 - DO k=i,m - s=s+a(k,i)*a(k,j) - END DO - f=s/h - DO k=i,m - a(k,j)=a(k,j)+f*a(k,i) - END DO - END DO + f=s/h DO k=i,m - a(k,i)=scale*a(k,i) - END DO -! - END IF -! - END IF -! - w(i)=scale *g - g=0.0d0 - s=0.0d0 - scale=0.0d0 - IF ((i.le.m).and.(i.ne.n))then + a(k,j)=a(k,j)+f*a(k,i) + END DO + END DO + DO k=i,m + a(k,i)=scale*a(k,i) + END DO + ! + END IF + ! + END IF + ! + w(i)=scale *g + g=0.0d0 + s=0.0d0 + scale=0.0d0 + IF ((i.le.m).and.(i.ne.n))then + do k=l,n + scale=scale+abs(a(i,k)) + end do + IF (scale.ne.0.0d0)then do k=l,n - scale=scale+abs(a(i,k)) + a(i,k)=a(i,k)/scale + s=s+a(i,k)*a(i,k) + end do + f=a(i,l) + g=-sign(sqrt(s),f) + h=f*g-s + a(i,l)=f-g + do k=l,n + rv1(k)=a(i,k)/h + end do + do j=l,m + s=0.0d0 + do k=l,n + s=s+a(j,k)*a(i,k) + end do + do k=l,n + a(j,k)=a(j,k)+s*rv1(k) + end do + end do + do k=l,n + a(i,k)=scale*a(i,k) end do - IF (scale.ne.0.0d0)then - do k=l,n - a(i,k)=a(i,k)/scale - s=s+a(i,k)*a(i,k) - end do - f=a(i,l) - g=-sign(sqrt(s),f) - h=f*g-s - a(i,l)=f-g - do k=l,n - rv1(k)=a(i,k)/h - end do - do j=l,m - s=0.0d0 - do k=l,n - s=s+a(j,k)*a(i,k) - end do - do k=l,n - a(j,k)=a(j,k)+s*rv1(k) - end do - end do - do k=l,n - a(i,k)=scale*a(i,k) - end do - endif endif - anorm=max(anorm,(abs(w(i))+abs(rv1(i)))) + endif + anorm=max(anorm,(abs(w(i))+abs(rv1(i)))) end do do i=n,1,-1 - IF (i.lt.n)then - IF (g.ne.0.0d0)then - do j=l,n - v(j,i)=(a(i,j)/a(i,l))/g - end do - do j=l,n - s=0.0d0 - do k=l,n - s=s+a(i,k)*v(k,j) - end do - do k=l,n - v(k,j)=v(k,j)+s*v(k,i) - end do - end do - endif + IF (i.lt.n)then + IF (g.ne.0.0d0)then do j=l,n - v(i,j)=0.0d0 - v(j,i)=0.0d0 + v(j,i)=(a(i,j)/a(i,l))/g end do - endif - v(i,i)=1.0d0 - g=rv1(i) - l=i - end do - do i=min(m,n),1,-1 - l=i+1 - g=w(i) - do j=l,n - a(i,j)=0.0d0 - end do - IF (g.ne.0.0d0)then - g=1.0d0/g do j=l,n s=0.0d0 - do k=l,m - s=s+a(k,i)*a(k,j) - end do - f=(s/a(i,i))*g - do k=i,m - a(k,j)=a(k,j)+f*a(k,i) - end do + do k=l,n + s=s+a(i,k)*v(k,j) + end do + do k=l,n + v(k,j)=v(k,j)+s*v(k,i) + end do end do - do j=i,m - a(j,i)=a(j,i)*g + endif + do j=l,n + v(i,j)=0.0d0 + v(j,i)=0.0d0 + end do + endif + v(i,i)=1.0d0 + g=rv1(i) + l=i + end do + do i=min(m,n),1,-1 + l=i+1 + g=w(i) + do j=l,n + a(i,j)=0.0d0 + end do + IF (g.ne.0.0d0)then + g=1.0d0/g + do j=l,n + s=0.0d0 + do k=l,m + s=s+a(k,i)*a(k,j) end do - else - do j= i,m - a(j,i)=0.0d0 + f=(s/a(i,i))*g + do k=i,m + a(k,j)=a(k,j)+f*a(k,i) end do - endif - a(i,i)=a(i,i)+1.0d0 + end do + do j=i,m + a(j,i)=a(j,i)*g + end do + else + do j= i,m + a(j,i)=0.0d0 + end do + endif + a(i,i)=a(i,i)+1.0d0 end do do k=n,1,-1 - do its=1,30 - do l=k,1,-1 - nm=l-1 - IF ((abs(rv1(l))+anorm).eq.anorm) goto 2 - IF ((abs(w(nm))+anorm).eq.anorm) goto 1 + do its=1,30 + do l=k,1,-1 + nm=l-1 + IF ((abs(rv1(l))+anorm).eq.anorm) goto 2 + IF ((abs(w(nm))+anorm).eq.anorm) goto 1 + end do +1 c=0.0d0 + s=1.0d0 + do i=l,k + f=s*rv1(i) + rv1(i)=c*rv1(i) + IF ((abs(f)+anorm).eq.anorm) goto 2 + g=w(i) + h=dpythag(f,g) + w(i)=h + h=1.0d0/h + c= (g*h) + s=-(f*h) + do j=1,m + y=a(j,nm) + z=a(j,i) + a(j,nm)=(y*c)+(z*s) + a(j,i)=-(y*s)+(z*c) end do -1 c=0.0d0 - s=1.0d0 - do i=l,k - f=s*rv1(i) - rv1(i)=c*rv1(i) - IF ((abs(f)+anorm).eq.anorm) goto 2 - g=w(i) - h=dpythag(f,g) - w(i)=h - h=1.0d0/h - c= (g*h) - s=-(f*h) - do j=1,m - y=a(j,nm) - z=a(j,i) - a(j,nm)=(y*c)+(z*s) - a(j,i)=-(y*s)+(z*c) - end do + end do +2 z=w(k) + IF (l.eq.k)then + IF (z.lt.0.0d0)then + w(k)=-z + do j=1,n + v(j,k)=-v(j,k) + end do + endif + goto 3 + endif + IF (ITS.eq.30) THEN + WRITE(6,*) 'no convergence in svdcmp' + STOP + END IF + x=w(l) + nm=k-1 + y=w(nm) + g=rv1(nm) + h=rv1(k) + f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0d0*h*y) + g=dpythag(f,1.0d0) + f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x + c=1.0d0 + s=1.0d0 + do j=l,nm + i=j+1 + g=rv1(i) + y=w(i) + h=s*g + g=c*g + z=dpythag(f,h) + rv1(j)=z + c=f/z + s=h/z + f= (x*c)+(g*s) + g=-(x*s)+(g*c) + h=y*s + y=y*c + do jj=1,n + x=v(jj,j) + z=v(jj,i) + v(jj,j)= (x*c)+(z*s) + v(jj,i)=-(x*s)+(z*c) end do -2 z=w(k) - IF (l.eq.k)then - IF (z.lt.0.0d0)then - w(k)=-z - do j=1,n - v(j,k)=-v(j,k) - end do - endif - goto 3 + z=dpythag(f,h) + w(j)=z + IF (z.ne.0.0d0)then + z=1.0d0/z + c=f*z + s=h*z endif - IF (ITS.eq.30) THEN - WRITE(6,*) 'no convergence in svdcmp' - STOP - END IF - x=w(l) - nm=k-1 - y=w(nm) - g=rv1(nm) - h=rv1(k) - f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0d0*h*y) - g=dpythag(f,1.0d0) - f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x - c=1.0d0 - s=1.0d0 - do j=l,nm - i=j+1 - g=rv1(i) - y=w(i) - h=s*g - g=c*g - z=dpythag(f,h) - rv1(j)=z - c=f/z - s=h/z - f= (x*c)+(g*s) - g=-(x*s)+(g*c) - h=y*s - y=y*c - do jj=1,n - x=v(jj,j) - z=v(jj,i) - v(jj,j)= (x*c)+(z*s) - v(jj,i)=-(x*s)+(z*c) - end do - z=dpythag(f,h) - w(j)=z - IF (z.ne.0.0d0)then - z=1.0d0/z - c=f*z - s=h*z - endif - f= (c*g)+(s*y) - x=-(s*g)+(c*y) - do jj=1,m - y=a(jj,j) - z=a(jj,i) - a(jj,j)= (y*c)+(z*s) - a(jj,i)=-(y*s)+(z*c) - end do + f= (c*g)+(s*y) + x=-(s*g)+(c*y) + do jj=1,m + y=a(jj,j) + z=a(jj,i) + a(jj,j)= (y*c)+(z*s) + a(jj,i)=-(y*s)+(z*c) end do - rv1(l)=0.0d0 - rv1(k)=f - w(k)=x - end do -3 continue + end do + rv1(l)=0.0d0 + rv1(k)=f + w(k)=x + end do +3 continue end do - return - END SUBROUTINE dsvdcmp - -!/ ------------------------------------------------------------------- / - FUNCTION JULDAYT(id,mm,iyyy) -! See numerical recipes 2nd ed. The order of month and day have been swapped! -!********************************************************************* - IMPLICIT NONE - INTEGER id,mm,iyyy - INTEGER IGREG - INTEGER*4 ja,jm,jy - INTEGER*4 JULDAYT - IGREG=15+31*(10+12*1582) - jy=iyyy - IF (jy.EQ.0) WRITE(6,*) 'There is no zero year !!' - IF (jy.LT.0) jy=jy+1 - IF (mm.GT.2) THEN - jm=mm+1 - ELSE - jy=jy-1 - jm=mm+13 - ENDIF - JULDAYT=INT(365.25*jy)+int(30.6001*jm)+id+1720995 - IF (id+31*(mm+12*iyyy).GE.IGREG) THEN - ja=INT(0.01*jy) - JULDAYT=JULDAYT+2-ja+INT(0.25*ja) - ENDIF - RETURN - END FUNCTION JULDAYT - -!/ ------------------------------------------------------------------- / - SUBROUTINE CALDATT(julian,id,mm,iyyy) -! See numerical recipes 2nd ed. The order of month and day have been swapped! -! Should be removed : same is now in W3TIMEMD -!********************************************************************* - IMPLICIT NONE - INTEGER(KIND=4), INTENT(in) :: julian - INTEGER(KIND=4), INTENT(out) :: id,mm,iyyy - INTEGER(KIND=4), PARAMETER :: IGREG=2299161 - INTEGER(KIND=4) ja,jalpha,jb,jc,jd,je - if (julian.GE.IGREG) THEN + return + END SUBROUTINE dsvdcmp + + !/ ------------------------------------------------------------------- / + FUNCTION JULDAYT(id,mm,iyyy) + ! See numerical recipes 2nd ed. The order of month and day have been swapped! + !********************************************************************* + IMPLICIT NONE + INTEGER id,mm,iyyy + INTEGER IGREG + INTEGER*4 ja,jm,jy + INTEGER*4 JULDAYT + IGREG=15+31*(10+12*1582) + jy=iyyy + IF (jy.EQ.0) WRITE(6,*) 'There is no zero year !!' + IF (jy.LT.0) jy=jy+1 + IF (mm.GT.2) THEN + jm=mm+1 + ELSE + jy=jy-1 + jm=mm+13 + ENDIF + JULDAYT=INT(365.25*jy)+int(30.6001*jm)+id+1720995 + IF (id+31*(mm+12*iyyy).GE.IGREG) THEN + ja=INT(0.01*jy) + JULDAYT=JULDAYT+2-ja+INT(0.25*ja) + ENDIF + RETURN + END FUNCTION JULDAYT + + !/ ------------------------------------------------------------------- / + SUBROUTINE CALDATT(julian,id,mm,iyyy) + ! See numerical recipes 2nd ed. The order of month and day have been swapped! + ! Should be removed : same is now in W3TIMEMD + !********************************************************************* + IMPLICIT NONE + INTEGER(KIND=4), INTENT(in) :: julian + INTEGER(KIND=4), INTENT(out) :: id,mm,iyyy + INTEGER(KIND=4), PARAMETER :: IGREG=2299161 + INTEGER(KIND=4) ja,jalpha,jb,jc,jd,je + if (julian.GE.IGREG) THEN jalpha=INT(((julian-1867216)-0.25)/36524.25) ja=julian+1+jalpha-INT(0.25*jalpha) - ELSE + ELSE ja=julian - ENDIF - jb=ja+1524 - jc=INT(6680.+((jb-2439870)-122.1)/365.25) - jd=365*jc+INT(0.25*jc) - je=INT((jb-jd)/30.6001) - id=jb-jd-INT(30.6001*je) - mm=je-1 - IF (mm.GT.12) mm=mm-12 - iyyy=jc-4715 - IF (mm.GT.2) iyyy=iyyy-1 - IF (iyyy.LE.0) iyyy=iyyy-1 - RETURN - END SUBROUTINE CALDATT - -!/ ------------------------------------------------------------------- / - subroutine svd(q,u,v,cov,w,p,b,sig,ic,m,n,mm,N2,toler,jc & - ,ssq,res) -!----------------------------------------------------------------------- -! svd uses singular-value-decomposition to calculate the least-squares -! solution p to an overdetermined system of linear equations with -! coefficient matrix q, which includes right hand side vector b. -! -! there are two ways to use svd: -! 1 given an overdetermined system, svd will orthogonalize -! a and b and produce the least-squares solution. -! 2 given an orthogonalized a (i.e. output from 1), -! svd will orthogonalize b with respect to a and produce -! the least-squares solution. this allows the use of -! multiple r.h.s. without reorthogonalizing a. -!----------------------------------------------------------------------- -! description of parameters: -! ic an input code which must be set to 1 or 2 -! m the number of equations (rows of q) to solve. -! n the total number of columns of q to be used ( expected value of N2 - -! I/O VARIABLES - integer, intent(IN) :: ic, m, n, N2, mm - real, intent(IN) :: toler - real, intent(INOUT) :: q(mm,N2), ssq, res - integer, intent(INOUT) :: jc - double precision, intent(INOUT) :: sig(mm) - double precision, intent(OUT) :: u(mm,N2),v(N2,N2),cov(N2,N2), & - w(N2),b(mm),p(N2) - -! LOCAL VARIABLES - double precision :: wti(nwt) - integer :: i, j, k - real :: wmax, thresh - double precision :: eps, sum, resi - - jc=0 + ENDIF + jb=ja+1524 + jc=INT(6680.+((jb-2439870)-122.1)/365.25) + jd=365*jc+INT(0.25*jc) + je=INT((jb-jd)/30.6001) + id=jb-jd-INT(30.6001*je) + mm=je-1 + IF (mm.GT.12) mm=mm-12 + iyyy=jc-4715 + IF (mm.GT.2) iyyy=iyyy-1 + IF (iyyy.LE.0) iyyy=iyyy-1 + RETURN + END SUBROUTINE CALDATT + + !/ ------------------------------------------------------------------- / + subroutine svd(q,u,v,cov,w,p,b,sig,ic,m,n,mm,N2,toler,jc & + ,ssq,res) + !----------------------------------------------------------------------- + ! svd uses singular-value-decomposition to calculate the least-squares + ! solution p to an overdetermined system of linear equations with + ! coefficient matrix q, which includes right hand side vector b. + ! + ! there are two ways to use svd: + ! 1 given an overdetermined system, svd will orthogonalize + ! a and b and produce the least-squares solution. + ! 2 given an orthogonalized a (i.e. output from 1), + ! svd will orthogonalize b with respect to a and produce + ! the least-squares solution. this allows the use of + ! multiple r.h.s. without reorthogonalizing a. + !----------------------------------------------------------------------- + ! description of parameters: + ! ic an input code which must be set to 1 or 2 + ! m the number of equations (rows of q) to solve. + ! n the total number of columns of q to be used ( expected value of N2 + + ! I/O VARIABLES + integer, intent(IN) :: ic, m, n, N2, mm + real, intent(IN) :: toler + real, intent(INOUT) :: q(mm,N2), ssq, res + integer, intent(INOUT) :: jc + double precision, intent(INOUT) :: sig(mm) + double precision, intent(OUT) :: u(mm,N2),v(N2,N2),cov(N2,N2), & + w(N2),b(mm),p(N2) + + ! LOCAL VARIABLES + double precision :: wti(nwt) + integer :: i, j, k + real :: wmax, thresh + double precision :: eps, sum, resi + + jc=0 + do i=1,mm + b(i)=q(i,N2) + enddo + ! no need to solve if only rhs has changed + IF (ic.eq.2) go to 10 + ! define a "design matrix" u(=a) and set-up working arrays + do j=1,N2 do i=1,mm - b(i)=q(i,N2) + u(i,j)=q(i,j) enddo -! no need to solve if only rhs has changed - IF (ic.eq.2) go to 10 -! define a "design matrix" u(=a) and set-up working arrays - do j=1,N2 - do i=1,mm - u(i,j)=q(i,j) - enddo - enddo -! compute svd decomposition of u(=a), with a being replaced by its upper -! matrix u, viz a=u*w*transpose(v), and vector w is output of a diagonal -! matrix of singular values w(i), i=1,n. - call dsvdcmp(u,m,n,mm,N2,w,v) -! check for small singular values - wmax=0. - do j=1,n - IF (w(j).gt.wmax) wmax=w(j) - enddo - thresh=toler*wmax - do j=1,n - IF (w(j).lt.thresh) then - w(j)=0.d0 - IF (jc.lt.1) jc=j - endif - enddo - 10 eps=1.d-10 -! compute summation weights (wti, used below) + enddo + ! compute svd decomposition of u(=a), with a being replaced by its upper + ! matrix u, viz a=u*w*transpose(v), and vector w is output of a diagonal + ! matrix of singular values w(i), i=1,n. + call dsvdcmp(u,m,n,mm,N2,w,v) + ! check for small singular values + wmax=0. + do j=1,n + IF (w(j).gt.wmax) wmax=w(j) + enddo + thresh=toler*wmax + do j=1,n + IF (w(j).lt.thresh) then + w(j)=0.d0 + IF (jc.lt.1) jc=j + endif + enddo +10 eps=1.d-10 + ! compute summation weights (wti, used below) + do j=1,n + wti(j)=0.d0 + IF (w(j).gt.eps) then + ! wti(j)=sig(j)*sig(j)/(w(j)*w(j)) + wti(j)=1.d0/(w(j)*w(j)) + endif + enddo + ! use back-substitution to compute the solution p(i), i=1,n + call dsvbksb(u,w,v,m,n,mm,N2,b,p) + ! compute chisq (=ssq) and the largest residual (res) + ssq=0. + res=0. + do i=1,m + sum=0.d0 do j=1,n - wti(j)=0.d0 - IF (w(j).gt.eps) then -! wti(j)=sig(j)*sig(j)/(w(j)*w(j)) - wti(j)=1.d0/(w(j)*w(j)) - endif + sum=sum+p(j)*q(i,j) enddo -! use back-substitution to compute the solution p(i), i=1,n - call dsvbksb(u,w,v,m,n,mm,N2,b,p) -! compute chisq (=ssq) and the largest residual (res) - ssq=0. - res=0. - do i=1,m + resi=abs(b(i)-sum) + ! TIDE_MF addition + q(i,N2)=b(i)-sum + res=max(res,resi) + ssq=ssq+resi**2 + enddo + ! compute variances, covariances, these may need to be given dimension + ! of b(i), e.g., using sig(i), but this is better done after return to main + do i=1,n + do j=1,i sum=0.d0 - do j=1,n - sum=sum+p(j)*q(i,j) - enddo - resi=abs(b(i)-sum) -! TIDE_MF addition - q(i,N2)=b(i)-sum - res=max(res,resi) - ssq=ssq+resi**2 - enddo -! compute variances, covariances, these may need to be given dimension -! of b(i), e.g., using sig(i), but this is better done after return to main - do i=1,n - do j=1,i - sum=0.d0 - do k=1,n - sum=sum+v(i,k)*v(j,k)*wti(k) - enddo - cov(i,j)=sum - cov(j,i)=sum + do k=1,n + sum=sum+v(i,k)*v(j,k)*wti(k) enddo + cov(i,j)=sum + cov(j,i)=sum enddo - return - end subroutine svd - -!/ ------------------------------------------------------------------- / - SUBROUTINE VUF_SET_PARAMETERS -! -!*********************************************************************** -!* HERE THE MAIN CONSTITUENTS AND THEIR DOODSON NUMBERS ARE SET -!* FORMAT (6X,A5,1X,6I3,F5.2,I4). THE VALUES ARE RESPECTIVELY -!* TIDECON_ALLNAMES = CONSTITUENT NAME -!* II,JJ,KK,LL,MM,NN = THE SIX DOODSON NUMBERS -!* SEMI = PHASE CORRECTION -!* NJ = THE NUMBER OF SATELLITES FOR THIS CONSTITUENT. -!* THE END OF ALL MAIN CONSTITUENTS IS DENOTED BY A BLANK CARD. -! - - IMPLICIT NONE - - INTEGER :: JLM - - NTIDAL_CON = 45 - NTOTAL_CON = 45+101 - NKONCO = 251 - JLM = 170 - - ALLOCATE(TIDE_INDEXJ(NTOTAL_CON),TIDE_INDEXJK(NKONCO)) -! - ALLOCATE(TIDECON_ALLNAMES(NTOTAL_CON)) - ALLOCATE(II(NTIDAL_CON),JJ(NTIDAL_CON),KK(NTIDAL_CON),LL(NTIDAL_CON),MM(NTIDAL_CON), & - NN(NTIDAL_CON),SEMI(NTIDAL_CON), NJ(NTOTAL_CON)) - - ALLOCATE(KONCO_CON(NKONCO),COEF_CON(NKONCO)) - - TIDECON_ALLNAMES(:)=(/ & - 'Z0 ','SA ','SSA ','MSM ','MM ','MSF ','MF ','ALP1 ','2Q1 ','SIG1 ', & -'Q1 ','RHO1 ','O1 ','TAU1 ','BET1 ','NO1 ','CHI1 ','PI1 ','P1 ','S1 ', & -'K1 ','PSI1 ','PHI1 ','THE1 ','J1 ','OO1 ','UPS1 ','OQ2 ','EPS2 ','2N2 ', & -'MU2 ','N2 ','NU2 ','GAM2 ','H1 ','M2 ','H2 ','LDA2 ','L2 ','T2 ', & -'S2 ','R2 ','K2 ','ETA2 ','M3 ','2PO1 ','SO1 ','ST36 ','2NS2 ','ST37 ', & -'ST1 ','ST2 ','ST3 ','O2 ','ST4 ','SNK2 ','OP2 ','MKS2 ','ST5 ','ST6 ', & -'2SK2 ','MSN2 ','ST7 ','2SM2 ','ST38 ','SKM2 ','2SN2 ','NO3 ','MO3 ','NK3 ', & -'SO3 ','MK3 ','SP3 ','SK3 ','ST8 ','N4 ','3MS4 ','ST39 ','MN4 ','ST40 ', & -'ST9 ','M4 ','ST10 ','SN4 ','KN4 ','MS4 ','MK4 ','SL4 ','S4 ','SK4 ', & -'MNO5 ','2MO5 ','3MP5 ','MNK5 ','2MP5 ','2MK5 ','MSK5 ','3KM5 ','2SK5 ','ST11 ', & -'2NM6 ','ST12 ','ST41 ','2MN6 ','ST13 ','M6 ','MSN6 ','MKN6 ','2MS6 ','2MK6 ', & -'NSK6 ','2SM6 ','MSK6 ','ST42 ','S6 ','ST14 ','ST15 ','M7 ','ST16 ','3MK7 ', & -'ST17 ','ST18 ','3MN8 ','ST19 ','M8 ','ST20 ','ST21 ','3MS8 ','3MK8 ','ST22 ', & -'ST23 ','ST24 ','ST25 ','ST26 ','4MK9 ','ST27 ','ST28 ','M10 ','ST29 ','ST30 ', & -'ST31 ','ST32 ','ST33 ','M12 ','ST34 ','ST35 '/) - - II(:)=(/ 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 2, 2, 3 /) - JJ(:)=(/ 0, 0, 0, 1, 1, 2, 2, -4, -3, -3, & - -2, -2, -1, -1, 0, 0, 0, 1, 1, 1, & - 1, 1, 1, 2, 2, 3, 4, -3, -3, -2, & - -2, -1, -1, 0, 0, 0, 0, 1, 1, 2, & - 2, 2, 2, 3, 0 /) - KK(:)=(/ 0, 1, 2, -2, 0, -2, 0, 2, 0, 2, & - 0, 2, 0, 2, -2, 0, 2, -3, -2, -1, & - 0, 1, 2, -2, 0, 0, 0, 0, 2, 0, & - 2, 0, 2, -2, -1, 0, 1, -2, 0, -3, & - -2, -1, 0, 0, 0 /) - LL(:)=(/ 0, 0, 0, 1, -1, 0, 0, 1, 2, 0, & - 1, -1, 0, 0, 1, 1, -1, 0, 0, 0, & - 0, 0, 0, 1, -1, 0, -1, 3, 1, 2, & - 0, 1, -1, 2, 0, 0, 0, 1, -1, 0, & - 0, 0, 0, -1, 0 /) - MM(:)=(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0 /) - NN(:)=(/ 0, -1, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, & - 0, -1, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 1, 0, -1, 0, 0, 1, & - 0, -1, 0, 0, 0 /) - SEMI(:)=(/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,-0.25,-0.25,-0.25, & - -0.25,-0.25,-0.25,-0.75,-0.75,-0.75,-0.75,-0.25,-0.25,-0.75, & - -0.75,-0.75,-0.75,-0.75,-0.75,-0.75,-0.75, 0.00, 0.00, 0.00, & - 0.00, 0.00, 0.00,-0.50,-0.50, 0.00, 0.00,-0.50,-0.50, 0.00, & - 0.00,-0.50, 0.00, 0.00,-0.50 /) - NJ(:)=(/ 1, 1, 1, 1, 1, 1, 1, 2, 5, 4, & - 10, 5, 8, 5, 1, 9, 2, 1, 6, 2, & - 10, 1, 5, 4, 10, 8, 5, 2, 3, 4, & - 3, 4, 4, 3, 2, 9, 1, 1, 5, 1, & - 3, 2, 5, 7, 1, 2, 2, 3, 2, 2, & - 3, 4, 3, 1, 3, 3, 2, 3, 3, 4, & - 2, 3, 4, 2, 3, 3, 2, 2, 2, 2, & - 2, 2, 2, 2, 3, 1, 2, 4, 2, 3, & - 4, 1, 3, 2, 2, 2, 2, 2, 1, 2, & - 3, 2, 2, 3, 2, 2, 3, 3, 2, 3, & - 2, 4, 3, 2, 4, 1, 3, 3, 2, 2, & - 3, 2, 3, 3, 1, 3, 3, 1, 3, 2, & - 4, 2, 2, 4, 1, 3, 3, 2, 2, 4, & - 2, 3, 3, 3, 2, 3, 2, 1, 3, 2, & - 4, 2, 3, 1, 2, 4/) - - LDEL(1:JLM)=(/ 0, 0, 0, 0, 0, 0, 0, -1, 0, -2, & - -1, -1, 0, 0, -1, 0, 0, 2, -2, -2, & - -1, -1, -1, 0, -1, 0, 1, 2, 0, 0, & - 1, 2, 2, -1, 0, 0, 1, 1, 1, 2, & - 2, -2, -1, 0, 0, 0, 0, -2, -2, -2, & - -1, -1, -1, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 1, 2, 2, 0, 0, -2, -1, -1, & - -1, 0, 0, 0, 0, 1, 1, 0, -2, -2, & - 0, 0, 0, -2, -1, 0, 0, 0, 0, 0, & - 1, 1, 1, 1, 2, 2, 2, -2, -2, -2, & - -1, -1, 0, 0, 0, -2, 0, 0, 1, 1, & - -1, 0, -1, -1, 0, -2, -1, -1, 0, -1, & - -1, 0, -2, -1, 0, 0, 0, 1, 2, 2, & - -2, -1, 0, 0, 1, -1, -1, 0, 0, 1, & - 1, 1, 2, 2, 0, 0, 0, 2, 2, 2, & - 2, 0, 0, 1, 2, 0, 0, -1, -1, 0, & - 0, 0, 0, 0, 0, 1, 1, 1, 2, 0/) - MDEL(1:JLM)=(/ 0, 0, 0, 0, 0, 0, 0, 0, -1, -2, & - -1, 0, -2, -1, 0, -2, -1, 0, -3, -2, & - -2, -1, 0, -2, 0, -1, 0, 0, -2, -1, & - 0, 0, 1, 0, -2, -1, -1, 0, 1, 0, & - 1, 0, 0, -1, 1, 2, -1, -2, -1, 0, & - -1, 0, 1, -1, 1, 2, -1, 1, -1, -2, & - -1, 0, 0, 0, 1, 0, 1, -1, -1, 0, & - 1, -2, -1, 1, 2, 0, 1, 1, 0, 1, & - 0, 1, 2, -1, 0, -1, 1, -1, 1, 2, & - -1, 0, 1, 2, 0, 1, 2, -1, 0, 1, & - 0, 1, 1, 2, 3, 0, 1, 2, 0, 1, & - 0, -1, -1, 0, -1, -2, -1, 0, -1, -1, & - 0, -1, -2, 0, -2, -1, -1, 0, 0, 1, & - -2, 0, -1, -1, 0, -1, 0, -2, -1, -1, & - 0, 1, 0, 1, -1, -1, -1, -1, 0, 1, & - 2, 0, -1, 0, 0, 0, 1, 0, 1, -1, & - 1, 2, -1, 1, 2, 0, 1, 2, 0, -1 /) - NDEL(1:JLM)=(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 2, 0, 0, 0, -2, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - -2, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, -1, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 2, 2, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /) - PH(1:JLM)=(/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.75, 0.00, 0.50, & - 0.75, 0.75, 0.50, 0.00, 0.75, 0.50, 0.00, 0.50, 0.50, 0.50, & - 0.75, 0.75, 0.75, 0.50, 0.00, 0.00, 0.75, 0.50, 0.50, 0.00, & - 0.75, 0.50, 0.00, 0.25, 0.50, 0.00, 0.25, 0.75, 0.25, 0.50, & - 0.50, 0.00, 0.25, 0.50, 0.50, 0.50, 0.00, 0.50, 0.00, 0.00, & - 0.75, 0.25, 0.75, 0.50, 0.00, 0.50, 0.50, 0.00, 0.50, 0.00, & - 0.50, 0.50, 0.75, 0.50, 0.50, 0.00, 0.50, 0.00, 0.75, 0.25, & - 0.75, 0.00, 0.50, 0.00, 0.50, 0.25, 0.25, 0.00, 0.00, 0.00, & - 0.00, 0.50, 0.50, 0.00, 0.25, 0.50, 0.00, 0.50, 0.00, 0.50, & - 0.75, 0.25, 0.25, 0.25, 0.50, 0.50, 0.50, 0.50, 0.00, 0.00, & - 0.25, 0.25, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.25, 0.25, & - 0.25, 0.50, 0.25, 0.25, 0.50, 0.50, 0.25, 0.25, 0.50, 0.25, & - 0.25, 0.50, 0.50, 0.00, 0.00, 0.50, 0.50, 0.75, 0.00, 0.50, & - 0.00, 0.25, 0.50, 0.50, 0.50, 0.75, 0.75, 0.00, 0.50, 0.25, & - 0.75, 0.75, 0.00, 0.00, 0.50, 0.50, 0.50, 0.00, 0.50, 0.50, & - 0.50, 0.00, 0.00, 0.75, 0.00, 0.50, 0.00, 0.75, 0.75, 0.50, & - 0.00, 0.00, 0.50, 0.00, 0.00, 0.75, 0.75, 0.75, 0.50, 0.50 /) - - EE(1:JLM)=(/ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0360, 0.1906, 0.0063, & - 0.0241, 0.0607, 0.0063, 0.1885, 0.0095, 0.0061, 0.1884, 0.0087, 0.0007, 0.0039, & - 0.0010, 0.0115, 0.0292, 0.0057, 0.0008, 0.1884, 0.0018, 0.0028, 0.0058, 0.1882, & - 0.0131, 0.0576, 0.0175, 0.0003, 0.0058, 0.1885, 0.0004, 0.0029, 0.0004, 0.0064, & - 0.0010, 0.0446, 0.0426, 0.0284, 0.2170, 0.0142, 0.2266, 0.0057, 0.0665, 0.3596, & - 0.0331, 0.2227, 0.0290, 0.0290, 0.2004, 0.0054, 0.0282, 0.2187, 0.0078, 0.0008, & - 0.0112, 0.0004, 0.0004, 0.0015, 0.0003, 0.3534, 0.0264, 0.0002, 0.0001, 0.0007, & - 0.0001, 0.0001, 0.0198, 0.1356, 0.0029, 0.0002, 0.0001, 0.0190, 0.0344, 0.0106, & - 0.0132, 0.0384, 0.0185, 0.0300, 0.0141, 0.0317, 0.1993, 0.0294, 0.1980, 0.0047, & - 0.0027, 0.0816, 0.0331, 0.0027, 0.0152, 0.0098, 0.0057, 0.0037, 0.1496, 0.0296, & - 0.0240, 0.0099, 0.6398, 0.1342, 0.0086, 0.0611, 0.6399, 0.1318, 0.0289, 0.0257, & - 0.1042, 0.0386, 0.0075, 0.0402, 0.0373, 0.0061, 0.0117, 0.0678, 0.0374, 0.0018, & - 0.0104, 0.0375, 0.0039, 0.0008, 0.0005, 0.0373, 0.0373, 0.0042, 0.0042, 0.0036, & - 0.1429, 0.0293, 0.0330, 0.0224, 0.0447, 0.0001, 0.0004, 0.0005, 0.0373, 0.0001, & - 0.0009, 0.0002, 0.0006, 0.0002, 0.0217, 0.0448, 0.0366, 0.0047, 0.2505, 0.1102, & - 0.0156, 0.0000, 0.0022, 0.0001, 0.0001, 0.2535, 0.0141, 0.0024, 0.0004, 0.0128, & - 0.2980, 0.0324, 0.0187, 0.4355, 0.0467, 0.0747, 0.0482, 0.0093, 0.0078, 0.0564 /) - - IR(1:JLM)=(/ 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, & - 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, & - 1, 1, 1, 0, 0, 0, 1, 0, 0, 0, & - 1, 0, 0, 1, 0, 0, 1, 1, 1, 0, & - 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, & - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, & - 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, & - 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, & - 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, & - 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, & - 2, 0, 2, 2, 0, 0, 2, 2, 0, 2, & - 2, 0, 0, 0, 0, 0, 0, 2, 0, 0, & - 0, 2, 0, 0, 0, 2, 2, 0, 0, 2, & - 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 2, 0, 0, 0, 2, 2, 0, & - 0, 0, 0, 0, 0, 2, 2, 2, 0, 0 /) - - COEF_CON(:)=(/ 2.00,-1.00, 1.00,-1.00, 2.00, 1.00,-2.00, 2.00,-1.00, 3.00, & - -2.00, 2.00, 1.00,-2.00, 1.00, 1.00, 1.00,-2.00, 2.00, 1.00, & - -2.00, 2.00, 2.00, 1.00,-2.00, 1.00, 1.00,-1.00, 1.00, 1.00, & - 1.00, 1.00,-1.00, 1.00, 2.00,-2.00, 2.00, 1.00,-1.00,-1.00, & - 2.00,-1.00, 1.00, 1.00,-1.00, 2.00, 1.00,-1.00,-1.00, 2.00, & - -1.00, 2.00, 1.00,-2.00, 1.00, 1.00,-1.00, 2.00,-1.00, 1.00, & - 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, & - 1.00, 1.00, 1.00, 2.00, 1.00,-1.00, 2.00, 3.00,-1.00, 1.00, & - 1.00, 1.00,-1.00, 1.00, 1.00, 2.00, 1.00,-1.00, 1.00, 1.00, & - 1.00,-1.00, 2.00, 2.00, 1.00,-1.00, 1.00, 1.00, 1.00, 1.00, & - 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 1.00, 1.00, 1.00, & - 1.00, 1.00, 2.00, 1.00, 3.00,-1.00, 1.00, 1.00, 1.00, 2.00, & - 1.00, 2.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, & - 1.00, 3.00, 1.00,-1.00, 2.00, 1.00, 2.00, 1.00, 1.00,-1.00, & - 3.00, 1.00,-1.00, 2.00, 1.00, 2.00, 1.00, 1.00,-1.00, 3.00, & - 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 1.00, 2.00, 1.00, & - 1.00, 1.00, 1.00, 2.00, 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & - -1.00, 3.00, 2.00, 1.00, 1.00, 2.00, 1.00, 1.00, 3.50, 2.00, & - 1.00, 1.00, 3.00, 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & - 3.00, 1.00, 3.00, 1.00, 1.00,-1.00, 4.00, 2.00, 1.00, 1.00, & - 2.00, 1.00, 1.00, 3.00, 1.00, 3.00, 1.00, 1.00, 1.00, 1.00, & - 1.00, 2.00, 2.00, 2.00, 1.00, 1.00, 2.00, 2.00, 1.00, 3.00, & - 1.00, 1.00, 4.00, 1.00, 3.00, 1.00, 1.00, 4.00, 1.00, 5.00, & - 3.00, 1.00, 1.00, 4.00, 1.00, 2.00, 1.00, 1.00, 1.00, 3.00, & - 2.00, 4.00, 1.00, 1.00, 6.00, 5.00, 1.00, 3.00, 1.00, 1.00, & - 1.00 /) - KONCO_CON(:)=(/ & + enddo + return + end subroutine svd + + !/ ------------------------------------------------------------------- / + SUBROUTINE VUF_SET_PARAMETERS + ! + !*********************************************************************** + !* HERE THE MAIN CONSTITUENTS AND THEIR DOODSON NUMBERS ARE SET + !* FORMAT (6X,A5,1X,6I3,F5.2,I4). THE VALUES ARE RESPECTIVELY + !* TIDECON_ALLNAMES = CONSTITUENT NAME + !* II,JJ,KK,LL,MM,NN = THE SIX DOODSON NUMBERS + !* SEMI = PHASE CORRECTION + !* NJ = THE NUMBER OF SATELLITES FOR THIS CONSTITUENT. + !* THE END OF ALL MAIN CONSTITUENTS IS DENOTED BY A BLANK CARD. + ! + + IMPLICIT NONE + + INTEGER :: JLM + + NTIDAL_CON = 45 + NTOTAL_CON = 45+101 + NKONCO = 251 + JLM = 170 + + ALLOCATE(TIDE_INDEXJ(NTOTAL_CON),TIDE_INDEXJK(NKONCO)) + ! + ALLOCATE(TIDECON_ALLNAMES(NTOTAL_CON)) + ALLOCATE(II(NTIDAL_CON),JJ(NTIDAL_CON),KK(NTIDAL_CON),LL(NTIDAL_CON),MM(NTIDAL_CON), & + NN(NTIDAL_CON),SEMI(NTIDAL_CON), NJ(NTOTAL_CON)) + + ALLOCATE(KONCO_CON(NKONCO),COEF_CON(NKONCO)) + + TIDECON_ALLNAMES(:)=(/ & + 'Z0 ','SA ','SSA ','MSM ','MM ','MSF ','MF ','ALP1 ','2Q1 ','SIG1 ', & + 'Q1 ','RHO1 ','O1 ','TAU1 ','BET1 ','NO1 ','CHI1 ','PI1 ','P1 ','S1 ', & + 'K1 ','PSI1 ','PHI1 ','THE1 ','J1 ','OO1 ','UPS1 ','OQ2 ','EPS2 ','2N2 ', & + 'MU2 ','N2 ','NU2 ','GAM2 ','H1 ','M2 ','H2 ','LDA2 ','L2 ','T2 ', & + 'S2 ','R2 ','K2 ','ETA2 ','M3 ','2PO1 ','SO1 ','ST36 ','2NS2 ','ST37 ', & + 'ST1 ','ST2 ','ST3 ','O2 ','ST4 ','SNK2 ','OP2 ','MKS2 ','ST5 ','ST6 ', & + '2SK2 ','MSN2 ','ST7 ','2SM2 ','ST38 ','SKM2 ','2SN2 ','NO3 ','MO3 ','NK3 ', & + 'SO3 ','MK3 ','SP3 ','SK3 ','ST8 ','N4 ','3MS4 ','ST39 ','MN4 ','ST40 ', & + 'ST9 ','M4 ','ST10 ','SN4 ','KN4 ','MS4 ','MK4 ','SL4 ','S4 ','SK4 ', & + 'MNO5 ','2MO5 ','3MP5 ','MNK5 ','2MP5 ','2MK5 ','MSK5 ','3KM5 ','2SK5 ','ST11 ', & + '2NM6 ','ST12 ','ST41 ','2MN6 ','ST13 ','M6 ','MSN6 ','MKN6 ','2MS6 ','2MK6 ', & + 'NSK6 ','2SM6 ','MSK6 ','ST42 ','S6 ','ST14 ','ST15 ','M7 ','ST16 ','3MK7 ', & + 'ST17 ','ST18 ','3MN8 ','ST19 ','M8 ','ST20 ','ST21 ','3MS8 ','3MK8 ','ST22 ', & + 'ST23 ','ST24 ','ST25 ','ST26 ','4MK9 ','ST27 ','ST28 ','M10 ','ST29 ','ST30 ', & + 'ST31 ','ST32 ','ST33 ','M12 ','ST34 ','ST35 '/) + + II(:)=(/ 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 2, 2, 3 /) + JJ(:)=(/ 0, 0, 0, 1, 1, 2, 2, -4, -3, -3, & + -2, -2, -1, -1, 0, 0, 0, 1, 1, 1, & + 1, 1, 1, 2, 2, 3, 4, -3, -3, -2, & + -2, -1, -1, 0, 0, 0, 0, 1, 1, 2, & + 2, 2, 2, 3, 0 /) + KK(:)=(/ 0, 1, 2, -2, 0, -2, 0, 2, 0, 2, & + 0, 2, 0, 2, -2, 0, 2, -3, -2, -1, & + 0, 1, 2, -2, 0, 0, 0, 0, 2, 0, & + 2, 0, 2, -2, -1, 0, 1, -2, 0, -3, & + -2, -1, 0, 0, 0 /) + LL(:)=(/ 0, 0, 0, 1, -1, 0, 0, 1, 2, 0, & + 1, -1, 0, 0, 1, 1, -1, 0, 0, 0, & + 0, 0, 0, 1, -1, 0, -1, 3, 1, 2, & + 0, 1, -1, 2, 0, 0, 0, 1, -1, 0, & + 0, 0, 0, -1, 0 /) + MM(:)=(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0 /) + NN(:)=(/ 0, -1, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, & + 0, -1, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 1, 0, -1, 0, 0, 1, & + 0, -1, 0, 0, 0 /) + SEMI(:)=(/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,-0.25,-0.25,-0.25, & + -0.25,-0.25,-0.25,-0.75,-0.75,-0.75,-0.75,-0.25,-0.25,-0.75, & + -0.75,-0.75,-0.75,-0.75,-0.75,-0.75,-0.75, 0.00, 0.00, 0.00, & + 0.00, 0.00, 0.00,-0.50,-0.50, 0.00, 0.00,-0.50,-0.50, 0.00, & + 0.00,-0.50, 0.00, 0.00,-0.50 /) + NJ(:)=(/ 1, 1, 1, 1, 1, 1, 1, 2, 5, 4, & + 10, 5, 8, 5, 1, 9, 2, 1, 6, 2, & + 10, 1, 5, 4, 10, 8, 5, 2, 3, 4, & + 3, 4, 4, 3, 2, 9, 1, 1, 5, 1, & + 3, 2, 5, 7, 1, 2, 2, 3, 2, 2, & + 3, 4, 3, 1, 3, 3, 2, 3, 3, 4, & + 2, 3, 4, 2, 3, 3, 2, 2, 2, 2, & + 2, 2, 2, 2, 3, 1, 2, 4, 2, 3, & + 4, 1, 3, 2, 2, 2, 2, 2, 1, 2, & + 3, 2, 2, 3, 2, 2, 3, 3, 2, 3, & + 2, 4, 3, 2, 4, 1, 3, 3, 2, 2, & + 3, 2, 3, 3, 1, 3, 3, 1, 3, 2, & + 4, 2, 2, 4, 1, 3, 3, 2, 2, 4, & + 2, 3, 3, 3, 2, 3, 2, 1, 3, 2, & + 4, 2, 3, 1, 2, 4/) + + LDEL(1:JLM)=(/ 0, 0, 0, 0, 0, 0, 0, -1, 0, -2, & + -1, -1, 0, 0, -1, 0, 0, 2, -2, -2, & + -1, -1, -1, 0, -1, 0, 1, 2, 0, 0, & + 1, 2, 2, -1, 0, 0, 1, 1, 1, 2, & + 2, -2, -1, 0, 0, 0, 0, -2, -2, -2, & + -1, -1, -1, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 1, 2, 2, 0, 0, -2, -1, -1, & + -1, 0, 0, 0, 0, 1, 1, 0, -2, -2, & + 0, 0, 0, -2, -1, 0, 0, 0, 0, 0, & + 1, 1, 1, 1, 2, 2, 2, -2, -2, -2, & + -1, -1, 0, 0, 0, -2, 0, 0, 1, 1, & + -1, 0, -1, -1, 0, -2, -1, -1, 0, -1, & + -1, 0, -2, -1, 0, 0, 0, 1, 2, 2, & + -2, -1, 0, 0, 1, -1, -1, 0, 0, 1, & + 1, 1, 2, 2, 0, 0, 0, 2, 2, 2, & + 2, 0, 0, 1, 2, 0, 0, -1, -1, 0, & + 0, 0, 0, 0, 0, 1, 1, 1, 2, 0/) + MDEL(1:JLM)=(/ 0, 0, 0, 0, 0, 0, 0, 0, -1, -2, & + -1, 0, -2, -1, 0, -2, -1, 0, -3, -2, & + -2, -1, 0, -2, 0, -1, 0, 0, -2, -1, & + 0, 0, 1, 0, -2, -1, -1, 0, 1, 0, & + 1, 0, 0, -1, 1, 2, -1, -2, -1, 0, & + -1, 0, 1, -1, 1, 2, -1, 1, -1, -2, & + -1, 0, 0, 0, 1, 0, 1, -1, -1, 0, & + 1, -2, -1, 1, 2, 0, 1, 1, 0, 1, & + 0, 1, 2, -1, 0, -1, 1, -1, 1, 2, & + -1, 0, 1, 2, 0, 1, 2, -1, 0, 1, & + 0, 1, 1, 2, 3, 0, 1, 2, 0, 1, & + 0, -1, -1, 0, -1, -2, -1, 0, -1, -1, & + 0, -1, -2, 0, -2, -1, -1, 0, 0, 1, & + -2, 0, -1, -1, 0, -1, 0, -2, -1, -1, & + 0, 1, 0, 1, -1, -1, -1, -1, 0, 1, & + 2, 0, -1, 0, 0, 0, 1, 0, 1, -1, & + 1, 2, -1, 1, 2, 0, 1, 2, 0, -1 /) + NDEL(1:JLM)=(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 2, 0, 0, 0, -2, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + -2, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, -1, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 2, 2, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /) + PH(1:JLM)=(/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.75, 0.00, 0.50, & + 0.75, 0.75, 0.50, 0.00, 0.75, 0.50, 0.00, 0.50, 0.50, 0.50, & + 0.75, 0.75, 0.75, 0.50, 0.00, 0.00, 0.75, 0.50, 0.50, 0.00, & + 0.75, 0.50, 0.00, 0.25, 0.50, 0.00, 0.25, 0.75, 0.25, 0.50, & + 0.50, 0.00, 0.25, 0.50, 0.50, 0.50, 0.00, 0.50, 0.00, 0.00, & + 0.75, 0.25, 0.75, 0.50, 0.00, 0.50, 0.50, 0.00, 0.50, 0.00, & + 0.50, 0.50, 0.75, 0.50, 0.50, 0.00, 0.50, 0.00, 0.75, 0.25, & + 0.75, 0.00, 0.50, 0.00, 0.50, 0.25, 0.25, 0.00, 0.00, 0.00, & + 0.00, 0.50, 0.50, 0.00, 0.25, 0.50, 0.00, 0.50, 0.00, 0.50, & + 0.75, 0.25, 0.25, 0.25, 0.50, 0.50, 0.50, 0.50, 0.00, 0.00, & + 0.25, 0.25, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.25, 0.25, & + 0.25, 0.50, 0.25, 0.25, 0.50, 0.50, 0.25, 0.25, 0.50, 0.25, & + 0.25, 0.50, 0.50, 0.00, 0.00, 0.50, 0.50, 0.75, 0.00, 0.50, & + 0.00, 0.25, 0.50, 0.50, 0.50, 0.75, 0.75, 0.00, 0.50, 0.25, & + 0.75, 0.75, 0.00, 0.00, 0.50, 0.50, 0.50, 0.00, 0.50, 0.50, & + 0.50, 0.00, 0.00, 0.75, 0.00, 0.50, 0.00, 0.75, 0.75, 0.50, & + 0.00, 0.00, 0.50, 0.00, 0.00, 0.75, 0.75, 0.75, 0.50, 0.50 /) + + EE(1:JLM)=(/ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0360, 0.1906, 0.0063, & + 0.0241, 0.0607, 0.0063, 0.1885, 0.0095, 0.0061, 0.1884, 0.0087, 0.0007, 0.0039, & + 0.0010, 0.0115, 0.0292, 0.0057, 0.0008, 0.1884, 0.0018, 0.0028, 0.0058, 0.1882, & + 0.0131, 0.0576, 0.0175, 0.0003, 0.0058, 0.1885, 0.0004, 0.0029, 0.0004, 0.0064, & + 0.0010, 0.0446, 0.0426, 0.0284, 0.2170, 0.0142, 0.2266, 0.0057, 0.0665, 0.3596, & + 0.0331, 0.2227, 0.0290, 0.0290, 0.2004, 0.0054, 0.0282, 0.2187, 0.0078, 0.0008, & + 0.0112, 0.0004, 0.0004, 0.0015, 0.0003, 0.3534, 0.0264, 0.0002, 0.0001, 0.0007, & + 0.0001, 0.0001, 0.0198, 0.1356, 0.0029, 0.0002, 0.0001, 0.0190, 0.0344, 0.0106, & + 0.0132, 0.0384, 0.0185, 0.0300, 0.0141, 0.0317, 0.1993, 0.0294, 0.1980, 0.0047, & + 0.0027, 0.0816, 0.0331, 0.0027, 0.0152, 0.0098, 0.0057, 0.0037, 0.1496, 0.0296, & + 0.0240, 0.0099, 0.6398, 0.1342, 0.0086, 0.0611, 0.6399, 0.1318, 0.0289, 0.0257, & + 0.1042, 0.0386, 0.0075, 0.0402, 0.0373, 0.0061, 0.0117, 0.0678, 0.0374, 0.0018, & + 0.0104, 0.0375, 0.0039, 0.0008, 0.0005, 0.0373, 0.0373, 0.0042, 0.0042, 0.0036, & + 0.1429, 0.0293, 0.0330, 0.0224, 0.0447, 0.0001, 0.0004, 0.0005, 0.0373, 0.0001, & + 0.0009, 0.0002, 0.0006, 0.0002, 0.0217, 0.0448, 0.0366, 0.0047, 0.2505, 0.1102, & + 0.0156, 0.0000, 0.0022, 0.0001, 0.0001, 0.2535, 0.0141, 0.0024, 0.0004, 0.0128, & + 0.2980, 0.0324, 0.0187, 0.4355, 0.0467, 0.0747, 0.0482, 0.0093, 0.0078, 0.0564 /) + + IR(1:JLM)=(/ 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, & + 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, & + 1, 1, 1, 0, 0, 0, 1, 0, 0, 0, & + 1, 0, 0, 1, 0, 0, 1, 1, 1, 0, & + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, & + 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, & + 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, & + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, & + 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, & + 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, & + 2, 0, 2, 2, 0, 0, 2, 2, 0, 2, & + 2, 0, 0, 0, 0, 0, 0, 2, 0, 0, & + 0, 2, 0, 0, 0, 2, 2, 0, 0, 2, & + 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 2, 0, 0, 0, 2, 2, 0, & + 0, 0, 0, 0, 0, 2, 2, 2, 0, 0 /) + + COEF_CON(:)=(/ 2.00,-1.00, 1.00,-1.00, 2.00, 1.00,-2.00, 2.00,-1.00, 3.00, & + -2.00, 2.00, 1.00,-2.00, 1.00, 1.00, 1.00,-2.00, 2.00, 1.00, & + -2.00, 2.00, 2.00, 1.00,-2.00, 1.00, 1.00,-1.00, 1.00, 1.00, & + 1.00, 1.00,-1.00, 1.00, 2.00,-2.00, 2.00, 1.00,-1.00,-1.00, & + 2.00,-1.00, 1.00, 1.00,-1.00, 2.00, 1.00,-1.00,-1.00, 2.00, & + -1.00, 2.00, 1.00,-2.00, 1.00, 1.00,-1.00, 2.00,-1.00, 1.00, & + 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, & + 1.00, 1.00, 1.00, 2.00, 1.00,-1.00, 2.00, 3.00,-1.00, 1.00, & + 1.00, 1.00,-1.00, 1.00, 1.00, 2.00, 1.00,-1.00, 1.00, 1.00, & + 1.00,-1.00, 2.00, 2.00, 1.00,-1.00, 1.00, 1.00, 1.00, 1.00, & + 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 1.00, 1.00, 1.00, & + 1.00, 1.00, 2.00, 1.00, 3.00,-1.00, 1.00, 1.00, 1.00, 2.00, & + 1.00, 2.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, & + 1.00, 3.00, 1.00,-1.00, 2.00, 1.00, 2.00, 1.00, 1.00,-1.00, & + 3.00, 1.00,-1.00, 2.00, 1.00, 2.00, 1.00, 1.00,-1.00, 3.00, & + 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 1.00, 2.00, 1.00, & + 1.00, 1.00, 1.00, 2.00, 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & + -1.00, 3.00, 2.00, 1.00, 1.00, 2.00, 1.00, 1.00, 3.50, 2.00, & + 1.00, 1.00, 3.00, 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & + 3.00, 1.00, 3.00, 1.00, 1.00,-1.00, 4.00, 2.00, 1.00, 1.00, & + 2.00, 1.00, 1.00, 3.00, 1.00, 3.00, 1.00, 1.00, 1.00, 1.00, & + 1.00, 2.00, 2.00, 2.00, 1.00, 1.00, 2.00, 2.00, 1.00, 3.00, & + 1.00, 1.00, 4.00, 1.00, 3.00, 1.00, 1.00, 4.00, 1.00, 5.00, & + 3.00, 1.00, 1.00, 4.00, 1.00, 2.00, 1.00, 1.00, 1.00, 3.00, & + 2.00, 4.00, 1.00, 1.00, 6.00, 5.00, 1.00, 3.00, 1.00, 1.00, & + 1.00 /) + KONCO_CON(:)=(/ & 'P1 ','O1 ','S2 ','O1 ','M2 ','N2 ','S2 ','N2 ','S2 ','M2 ', & 'S2 ','N2 ','K2 ','S2 ','M2 ','N2 ','K2 ','S2 ','M2 ','S2 ', & 'K2 ','O1 ','K2 ','N2 ','S2 ','S2 ','N2 ','K2 ','O1 ','P1 ', & @@ -1698,255 +1698,255 @@ SUBROUTINE VUF_SET_PARAMETERS 'S2 '/) - END SUBROUTINE VUF_SET_PARAMETERS - -!/ ------------------------------------------------------------------- / - SUBROUTINE VUF (KONX,Vx,ux,FX,ITIME) -! -! -!* GIVEN CONSTITUENT KONX , THE NODAL CORRECTIONS V+U AND F ARE RETURNED -! That subroutine can now be replaced by look-up table to get K from J -! -! - IMPLICIT NONE -! - character*5, INTENT(IN) :: KONX - REAL(KIND=8), INTENT(OUT) :: Vx,ux,FX - INTEGER, INTENT(IN) :: ITIME - - INTEGER :: K - - DO K=1,NTOTAL_CON - IF (TIDECON_ALLNAMES(K).eq.KONX) go to 40 - END DO - WRITE(NDSET,30) KONX -30 FORMAT('ERROR IN VUF: STOP.',A5) - STOP -40 VX=V_ARG(K,ITIME) - UX=U_ARG(k,ITIME) - FX=F_ARG(K,ITIME) - RETURN -! -!*********************************************************************** -!* THE ASTRONOMICAL ARGUMENTS AND THEIR RATES OF CHANGE, -!* S0,H0,P0,ENP0,PP0,DS,DH,DP,DNP,DPP, ARE READ FROM TWO RECORDS IN -!* THE FORMAT(5F13.10): -!* S0 = MEAN LONGITUDE OF THE MOON (CYCLES) AT 000 ET 1/1/1976. -!* H0 = MEAN LONGITUDE OF THE SUN. -!* P0 = MEAN LONGITUDE OF THE LUNAR PERIGEE. -!* ENP0= NEGATIVE OF THE MEAN LONGITUDE OF THE ASCENDING NODE. -!* PP0 = MEAN LONGITUDE OF THE SOLAR PERIGEE (PERIHELION). -!* DS,DH,DP,DNP,DPP ARE THEIR RESPECTIVE RATES OF CHANGE OVER A 365 -!* DAY PERIOD AS OF 000 ET 1/1/1976. -! - - END SUBROUTINE VUF - -!/ ------------------------------------------------------------------- / - SUBROUTINE OPNVUF(filename) - - IMPLICIT NONE - - CHARACTER*256, INTENT(IN) :: filename - - INTEGER :: J, J1, JBASE, J4, K, K1, JL, JLM, KR - - DOUBLE PRECISION, PARAMETER :: TWOPI=3.1415926535898*2. - DOUBLE PRECISION, PARAMETER :: FAC=TWPI/360. - - KR=8 -! -!*********************************************************************** -!* HERE THE MAIN CONSTITUENTS AND THEIR DOODSON NUMBERS ARE READ IN -!* FORMAT (6X,A5,1X,6I3,F5.2,I4). THE VALUES ARE RESPECTIVELY -!* TIDECON_ALLNAMES = CONSTITUENT NAME -!* II,JJ,KK,LL,MM,NN = THE SIX DOODSON NUMBERS -!* SEMI = PHASE CORRECTION -!* NJ = THE NUMBER OF SATELLITES FOR THIS CONSTITUENT. -!* THE END OF ALL MAIN CONSTITUENTS IS DENOTED BY A BLANK CARD. -! - ALLOCATE(TIDECON_ALLNAMES(170)) - ALLOCATE(II(MC2),JJ(MC2),KK(MC2),LL(MC2),MM(MC2),NN(MC2), & - SEMI(MC2), NJ(170)) - ALLOCATE(KONCO_CON(320),COEF_CON(320)) - - KR=8 - open(unit=KR,file=filename,status='old',form='formatted') - - JBASE=0 + END SUBROUTINE VUF_SET_PARAMETERS + + !/ ------------------------------------------------------------------- / + SUBROUTINE VUF (KONX,Vx,ux,FX,ITIME) + ! + ! + !* GIVEN CONSTITUENT KONX , THE NODAL CORRECTIONS V+U AND F ARE RETURNED + ! That subroutine can now be replaced by look-up table to get K from J + ! + ! + IMPLICIT NONE + ! + character*5, INTENT(IN) :: KONX + REAL(KIND=8), INTENT(OUT) :: Vx,ux,FX + INTEGER, INTENT(IN) :: ITIME + + INTEGER :: K + + DO K=1,NTOTAL_CON + IF (TIDECON_ALLNAMES(K).eq.KONX) go to 40 + END DO + WRITE(NDSET,30) KONX +30 FORMAT('ERROR IN VUF: STOP.',A5) + STOP +40 VX=V_ARG(K,ITIME) + UX=U_ARG(k,ITIME) + FX=F_ARG(K,ITIME) + RETURN + ! + !*********************************************************************** + !* THE ASTRONOMICAL ARGUMENTS AND THEIR RATES OF CHANGE, + !* S0,H0,P0,ENP0,PP0,DS,DH,DP,DNP,DPP, ARE READ FROM TWO RECORDS IN + !* THE FORMAT(5F13.10): + !* S0 = MEAN LONGITUDE OF THE MOON (CYCLES) AT 000 ET 1/1/1976. + !* H0 = MEAN LONGITUDE OF THE SUN. + !* P0 = MEAN LONGITUDE OF THE LUNAR PERIGEE. + !* ENP0= NEGATIVE OF THE MEAN LONGITUDE OF THE ASCENDING NODE. + !* PP0 = MEAN LONGITUDE OF THE SOLAR PERIGEE (PERIHELION). + !* DS,DH,DP,DNP,DPP ARE THEIR RESPECTIVE RATES OF CHANGE OVER A 365 + !* DAY PERIOD AS OF 000 ET 1/1/1976. + ! + + END SUBROUTINE VUF + + !/ ------------------------------------------------------------------- / + SUBROUTINE OPNVUF(filename) + + IMPLICIT NONE + + CHARACTER*256, INTENT(IN) :: filename + + INTEGER :: J, J1, JBASE, J4, K, K1, JL, JLM, KR + + DOUBLE PRECISION, PARAMETER :: TWOPI=3.1415926535898*2. + DOUBLE PRECISION, PARAMETER :: FAC=TWPI/360. + + KR=8 + ! + !*********************************************************************** + !* HERE THE MAIN CONSTITUENTS AND THEIR DOODSON NUMBERS ARE READ IN + !* FORMAT (6X,A5,1X,6I3,F5.2,I4). THE VALUES ARE RESPECTIVELY + !* TIDECON_ALLNAMES = CONSTITUENT NAME + !* II,JJ,KK,LL,MM,NN = THE SIX DOODSON NUMBERS + !* SEMI = PHASE CORRECTION + !* NJ = THE NUMBER OF SATELLITES FOR THIS CONSTITUENT. + !* THE END OF ALL MAIN CONSTITUENTS IS DENOTED BY A BLANK CARD. + ! + ALLOCATE(TIDECON_ALLNAMES(170)) + ALLOCATE(II(MC2),JJ(MC2),KK(MC2),LL(MC2),MM(MC2),NN(MC2), & + SEMI(MC2), NJ(170)) + ALLOCATE(KONCO_CON(320),COEF_CON(320)) + + KR=8 + open(unit=KR,file=filename,status='old',form='formatted') + + JBASE=0 DO K=1,1000 - READ(KR,60)TIDECON_ALLNAMES(K),II(K),JJ(K),KK(K),LL(K),MM(K),NN(K),SEMI(K), & - NJ(K) -60 FORMAT(6X,A5,1X,6I3,F5.2,I4) - !WRITE(995,'(I4,A5,1X,6I3,F5.2,I4)') K,TIDECON_ALLNAMES(K),II(K),JJ(K),KK(K),LL(K),MM(K),NN(K),SEMI(K), & - ! NJ(K) - IF (TIDECON_ALLNAMES(K).eq.KBLANK) go to 100 -70 J1=JBASE+1 - IF (NJ(K).LT.1) THEN - NJ(K)=1 - JL=J1 - PH(J1)=0. - EE(J1)=0. - LDEL(J1)=0 - MDEL(J1)=0 - NDEL(J1)=0 - IR(J1)=0 - ELSE - JL=JBASE+NJ(K) -! -!*********************************************************************** -!* IF NJ>0, INFORMATION ON THE SATELLITE CONSTITUENTS IS READ , THREE -!* SATELLITES PER CARD, IN THE FORMAT (11X,3(3I3,F4.2,F7.4,1X,I1,1X)). -!* FOR EACH SATELLITE THE VALUES READ ARE -!* LDEL,MDEL,NDEL = THE CHANGES IN THE LAST THREE DOODSON NUMBERS -!* FROM THOSE OF THE MAIN CONSTITUENT. -!* PH = THE PHASE CORRECTION -!* EE = THE AMPLITUDE RATIO OF THE SATELLITE TIDAL POTENTIAL TO -!* THAT OF THE MAIN CONSTITUENT. -!* IR = 1 IF THE AMPLITUDE RATIO HAS TO BE MULTIPLIED BY THE -!* LATITUDE CORRECTION FACTOR FOR DIURNAL CONSTITUENTS -!* 2 IF THE AMPLITUDE RATIO HAS TO BE MULTIPLIED BY THE -!* LATITUDE CORRECTION FACTOR FOR SEMI-DIURNAL CONSTI- -!* TUENTS. -!* OTHERWISE IF NO CORRECTION IS REQUIRED TO THE AMPLITUDE -!* RATIO. -! - READ(KR,80)(LDEL(J),MDEL(J),NDEL(J),PH(J),EE(J),IR(J),J=J1,JL) -80 FORMAT((11X,3(3I3,F4.2,F7.4,1X,I1,1X))) - END IF - JBASE=JL + READ(KR,60)TIDECON_ALLNAMES(K),II(K),JJ(K),KK(K),LL(K),MM(K),NN(K),SEMI(K), & + NJ(K) +60 FORMAT(6X,A5,1X,6I3,F5.2,I4) + !WRITE(995,'(I4,A5,1X,6I3,F5.2,I4)') K,TIDECON_ALLNAMES(K),II(K),JJ(K),KK(K),LL(K),MM(K),NN(K),SEMI(K), & + ! NJ(K) + IF (TIDECON_ALLNAMES(K).eq.KBLANK) go to 100 +70 J1=JBASE+1 + IF (NJ(K).LT.1) THEN + NJ(K)=1 + JL=J1 + PH(J1)=0. + EE(J1)=0. + LDEL(J1)=0 + MDEL(J1)=0 + NDEL(J1)=0 + IR(J1)=0 + ELSE + JL=JBASE+NJ(K) + ! + !*********************************************************************** + !* IF NJ>0, INFORMATION ON THE SATELLITE CONSTITUENTS IS READ , THREE + !* SATELLITES PER CARD, IN THE FORMAT (11X,3(3I3,F4.2,F7.4,1X,I1,1X)). + !* FOR EACH SATELLITE THE VALUES READ ARE + !* LDEL,MDEL,NDEL = THE CHANGES IN THE LAST THREE DOODSON NUMBERS + !* FROM THOSE OF THE MAIN CONSTITUENT. + !* PH = THE PHASE CORRECTION + !* EE = THE AMPLITUDE RATIO OF THE SATELLITE TIDAL POTENTIAL TO + !* THAT OF THE MAIN CONSTITUENT. + !* IR = 1 IF THE AMPLITUDE RATIO HAS TO BE MULTIPLIED BY THE + !* LATITUDE CORRECTION FACTOR FOR DIURNAL CONSTITUENTS + !* 2 IF THE AMPLITUDE RATIO HAS TO BE MULTIPLIED BY THE + !* LATITUDE CORRECTION FACTOR FOR SEMI-DIURNAL CONSTI- + !* TUENTS. + !* OTHERWISE IF NO CORRECTION IS REQUIRED TO THE AMPLITUDE + !* RATIO. + ! + READ(KR,80)(LDEL(J),MDEL(J),NDEL(J),PH(J),EE(J),IR(J),J=J1,JL) +80 FORMAT((11X,3(3I3,F4.2,F7.4,1X,I1,1X))) + END IF + JBASE=JL end do -100 NTIDAL_CON=K-1 - JLM=JL - -! -!*********************************************************************** -!* THE SHALLOW WATER CONSTITUENTS AND THE MAIN CONSTITUENTS FROM WHICH -!* THEY ARE DERIVED ARE READ IN HERE WITH THE FORMAT -!* (6X,A5,I1,2X,4(F5.2,A5,5X)). THE VALUES ARE RESPECTIVELY -!* TIDECON_ALLNAMES = NAME OF THE SHALLOW WATER CONSTITUENT -!* NJ = NUMBER OF MAIN CONSTITUENTS FROM WHICH IT IS DERIVED. -!* COEF_CON,KONCO_CON = COMBINATION NUMBER AND NAME OF THESE MAIN -!* CONSTITUENTS. -!* THE END OF THESE CONSTITUENTS IS DENOTED BY A BLANK CARD. -! - JBASE=0 - K1=NTIDAL_CON+1 +100 NTIDAL_CON=K-1 + JLM=JL + + ! + !*********************************************************************** + !* THE SHALLOW WATER CONSTITUENTS AND THE MAIN CONSTITUENTS FROM WHICH + !* THEY ARE DERIVED ARE READ IN HERE WITH THE FORMAT + !* (6X,A5,I1,2X,4(F5.2,A5,5X)). THE VALUES ARE RESPECTIVELY + !* TIDECON_ALLNAMES = NAME OF THE SHALLOW WATER CONSTITUENT + !* NJ = NUMBER OF MAIN CONSTITUENTS FROM WHICH IT IS DERIVED. + !* COEF_CON,KONCO_CON = COMBINATION NUMBER AND NAME OF THESE MAIN + !* CONSTITUENTS. + !* THE END OF THESE CONSTITUENTS IS DENOTED BY A BLANK CARD. + ! + JBASE=0 + K1=NTIDAL_CON+1 DO K=K1,1000 - J1=JBASE+1 - J4=J1+3 - READ(KR,130)TIDECON_ALLNAMES(K),NJ(K),(COEF_CON(J),KONCO_CON(J),J=J1,J4) -130 FORMAT(6X,A5,I1,2X,4(F5.2,A5,5X)) - !WRITE(995,130)TIDECON_ALLNAMES(K),NJ(K),(COEF_CON(J),KONCO_CON(J),J=J1,J4) - IF (TIDECON_ALLNAMES(K).eq.KBLANK) go to 170 - JBASE=JBASE+NJ(K) + J1=JBASE+1 + J4=J1+3 + READ(KR,130)TIDECON_ALLNAMES(K),NJ(K),(COEF_CON(J),KONCO_CON(J),J=J1,J4) +130 FORMAT(6X,A5,I1,2X,4(F5.2,A5,5X)) + !WRITE(995,130)TIDECON_ALLNAMES(K),NJ(K),(COEF_CON(J),KONCO_CON(J),J=J1,J4) + IF (TIDECON_ALLNAMES(K).eq.KBLANK) go to 170 + JBASE=JBASE+NJ(K) end do -170 NTOTAL_CON=K-1 - -! Write out for cut and paste ... -! WRITE(6,*) 'Numbers:',NTIDAL_CON, NTOTAL_CON, JLM, J1, J4 -! WRITE(996,*) NTIDAL, NTOTAL_CON, JLM, J1, J4 -!999 FORMAT(10("'",A5,"',"),' &') -! WRITE(996,999) TIDECON_ALLNAMES(1:NTOTAL_CON) -!998 FORMAT(10(I3,","),' &') -!997 FORMAT(10(I4,","),' &') -!991 FORMAT(10(F5.2,","),' &') -!990 FORMAT(10(F7.4,","),' &') -! WRITE(996,998) II(1:NTIDAL_CON) -! WRITE(996,998) JJ(1:NTIDAL_CON) -! WRITE(996,998) KK(1:NTIDAL_CON) -! WRITE(996,998) LL(1:NTIDAL_CON) -! WRITE(996,998) MM(1:NTIDAL_CON) -! WRITE(996,998) NN(1:NTIDAL_CON) -! WRITE(996,991) SEMI(1:NTIDAL_CON) -! WRITE(996,997) NJ(1:NTOTAL_CON) - -! WRITE(996,998) LDEL(1:JLM) -! WRITE(996,998) MDEL(1:JLM) -! WRITE(996,998) NDEL(1:JLM) -! WRITE(996,991) PH(1:JLM) -! WRITE(996,990) EE(1:JLM) -! WRITE(996,998) IR(1:JLM) - -! WRITE(996,991) COEF_CON(1:J4) -! WRITE(996,999) KONCO_CON(1:J4) - RETURN -! -!*********************************************************************** -!* NTIDAL_CON IS THE NUMBER OF MAIN CONSTITUENTS -!* NTOTAL_CON IS THE NUMBER OF CONSTITUENTS (MAIN + SHALLOW WATER) -!* FOR THE GIVEN TIME hr, THE TABLE OF F AND V+U VALUES IS -!* CALCULATED FOR ALL THE CONSTITUENTS. -!* F IS THE NODAL MODULATION ADJUSTMENT FACTOR FOR AMPLITUDE -!* U IS THE NODAL MODULATION ADJUSTMENT FACTOR FOR PHASE -!* V IS THE ASTRONOMICAL ARGUMENT ADJUSTMENT FOR PHASE. -! -! setvuf calculates the V,u,f values at time hr for all constituents -! - END SUBROUTINE OPNVUF - -!/ ------------------------------------------------------------------- / - SUBROUTINE SETVUF(hr,XLAT,ITIME) -! setvuf calculates the V,u,f values at time hr for all constituents - - IMPLICIT NONE - - REAL(KIND=8), INTENT(IN) :: hr - REAL, INTENT(IN) :: XLAT - INTEGER, INTENT(IN) :: ITIME - -! -! Local variables -! - INTEGER :: KD0, INT24, INTDYS, & - JBASE, J, K, L, J1, K1, JL, LK, iflag - INTEGER :: IV, IUU -! - REAL(KIND=4), PARAMETER :: PI=3.1415926536 - REAL(KIND=4), PARAMETER :: TWOPI=2.*3.1415926536 -! - REAL :: SLAT, VDBL, VV, SUMC, SUMS, RR, & - UUDBL, UU, CXLAT - REAL(KIND=8) :: d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp,hh,tau - - INTEGER :: indx(170) - - CXLAT = MAX(ABS(XLAT), 5.) - SLAT=SIN(PI*CXLAT/180.) -! -!*********************************************************************** -!* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION -!* AT THE MID POINT OF THE ANALYSIS PERIOD. -! -! day number measured from January 0.5 1900 (i.e., -! 1200 UT December 31, 1899 - d1=hr/24.d0 - ! This was with "gregorian days from KDAY" - !call gday(31,12,99,18,kd0) ! CALL GDAY(IDd,IMm,IYy,ICc,KDd) - ! Now uses "julian days from JULDAYT" - ! KD0= 693961 - !KD0=JULDAYT(31,12,1899) ! JULDAYT(id,mm,iyyy) - KD0= 2415020 - ! substracting 0.5day is not necessary anymore with new time functions - d1=d1-dfloat(KD0) - call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) - INT24=24 - INTDYS=int((hr+0.00001)/INT24) - HH=hr-dfloat(INTDYS*INT24) - TAU=HH/24.D0+H-S -! -!*********************************************************************** -!* ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU- -!* TING THE LUNAR TIME TAU. -! - JBASE=0 +170 NTOTAL_CON=K-1 + + ! Write out for cut and paste ... + ! WRITE(6,*) 'Numbers:',NTIDAL_CON, NTOTAL_CON, JLM, J1, J4 + ! WRITE(996,*) NTIDAL, NTOTAL_CON, JLM, J1, J4 + !999 FORMAT(10("'",A5,"',"),' &') + ! WRITE(996,999) TIDECON_ALLNAMES(1:NTOTAL_CON) + !998 FORMAT(10(I3,","),' &') + !997 FORMAT(10(I4,","),' &') + !991 FORMAT(10(F5.2,","),' &') + !990 FORMAT(10(F7.4,","),' &') + ! WRITE(996,998) II(1:NTIDAL_CON) + ! WRITE(996,998) JJ(1:NTIDAL_CON) + ! WRITE(996,998) KK(1:NTIDAL_CON) + ! WRITE(996,998) LL(1:NTIDAL_CON) + ! WRITE(996,998) MM(1:NTIDAL_CON) + ! WRITE(996,998) NN(1:NTIDAL_CON) + ! WRITE(996,991) SEMI(1:NTIDAL_CON) + ! WRITE(996,997) NJ(1:NTOTAL_CON) + + ! WRITE(996,998) LDEL(1:JLM) + ! WRITE(996,998) MDEL(1:JLM) + ! WRITE(996,998) NDEL(1:JLM) + ! WRITE(996,991) PH(1:JLM) + ! WRITE(996,990) EE(1:JLM) + ! WRITE(996,998) IR(1:JLM) + + ! WRITE(996,991) COEF_CON(1:J4) + ! WRITE(996,999) KONCO_CON(1:J4) + RETURN + ! + !*********************************************************************** + !* NTIDAL_CON IS THE NUMBER OF MAIN CONSTITUENTS + !* NTOTAL_CON IS THE NUMBER OF CONSTITUENTS (MAIN + SHALLOW WATER) + !* FOR THE GIVEN TIME hr, THE TABLE OF F AND V+U VALUES IS + !* CALCULATED FOR ALL THE CONSTITUENTS. + !* F IS THE NODAL MODULATION ADJUSTMENT FACTOR FOR AMPLITUDE + !* U IS THE NODAL MODULATION ADJUSTMENT FACTOR FOR PHASE + !* V IS THE ASTRONOMICAL ARGUMENT ADJUSTMENT FOR PHASE. + ! + ! setvuf calculates the V,u,f values at time hr for all constituents + ! + END SUBROUTINE OPNVUF + + !/ ------------------------------------------------------------------- / + SUBROUTINE SETVUF(hr,XLAT,ITIME) + ! setvuf calculates the V,u,f values at time hr for all constituents + + IMPLICIT NONE + + REAL(KIND=8), INTENT(IN) :: hr + REAL, INTENT(IN) :: XLAT + INTEGER, INTENT(IN) :: ITIME + + ! + ! Local variables + ! + INTEGER :: KD0, INT24, INTDYS, & + JBASE, J, K, L, J1, K1, JL, LK, iflag + INTEGER :: IV, IUU + ! + REAL(KIND=4), PARAMETER :: PI=3.1415926536 + REAL(KIND=4), PARAMETER :: TWOPI=2.*3.1415926536 + ! + REAL :: SLAT, VDBL, VV, SUMC, SUMS, RR, & + UUDBL, UU, CXLAT + REAL(KIND=8) :: d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp,hh,tau + + INTEGER :: indx(170) + + CXLAT = MAX(ABS(XLAT), 5.) + SLAT=SIN(PI*CXLAT/180.) + ! + !*********************************************************************** + !* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION + !* AT THE MID POINT OF THE ANALYSIS PERIOD. + ! + ! day number measured from January 0.5 1900 (i.e., + ! 1200 UT December 31, 1899 + d1=hr/24.d0 + ! This was with "gregorian days from KDAY" + !call gday(31,12,99,18,kd0) ! CALL GDAY(IDd,IMm,IYy,ICc,KDd) + ! Now uses "julian days from JULDAYT" + ! KD0= 693961 + !KD0=JULDAYT(31,12,1899) ! JULDAYT(id,mm,iyyy) + KD0= 2415020 + ! substracting 0.5day is not necessary anymore with new time functions + d1=d1-dfloat(KD0) + call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) + INT24=24 + INTDYS=int((hr+0.00001)/INT24) + HH=hr-dfloat(INTDYS*INT24) + TAU=HH/24.D0+H-S + ! + !*********************************************************************** + !* ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU- + !* TING THE LUNAR TIME TAU. + ! + JBASE=0 DO K=1,NTIDAL_CON - do l=1,TIDE_MF - IF (TIDECON_ALLNAMES(k).eq.TIDECON_NAME(l)) then - indx(k)=l - END IF - end do + do l=1,TIDE_MF + IF (TIDECON_ALLNAMES(k).eq.TIDECON_NAME(l)) then + indx(k)=l + END IF + end do VDBL=II(K)*TAU+JJ(K)*S+KK(K)*H+LL(K)*P+MM(K)*ENP+NN(K)*PP+SEMI(K) IV=VDBL IV=(IV/2)*2 @@ -1955,666 +1955,666 @@ SUBROUTINE SETVUF(hr,XLAT,ITIME) JL=JBASE+NJ(K) SUMC=1. SUMS=0. - DO J=J1,JL -! -!*********************************************************************** -!* HERE THE SATELLITE AMPLITUDE RATIO ADJUSTMENT FOR LATITUDE IS MADE -! - RR=EE(J) - L=IR(J)+1 - IF (L.EQ.2) THEN - RR=EE(J)*0.36309*(1.-5.*SLAT*SLAT)/SLAT - ELSE IF (L.EQ.3) THEN - RR=EE(J)*2.59808*SLAT - END IF - UUDBL=LDEL(J)*P+MDEL(J)*ENP+NDEL(J)*PP+PH(J) - IUU=UUDBL - UU=UUDBL-IUU - SUMC=SUMC+RR*COS(UU*TWOPI) - SUMS=SUMS+RR*SIN(UU*TWOPI) - end do + DO J=J1,JL + ! + !*********************************************************************** + !* HERE THE SATELLITE AMPLITUDE RATIO ADJUSTMENT FOR LATITUDE IS MADE + ! + RR=EE(J) + L=IR(J)+1 + IF (L.EQ.2) THEN + RR=EE(J)*0.36309*(1.-5.*SLAT*SLAT)/SLAT + ELSE IF (L.EQ.3) THEN + RR=EE(J)*2.59808*SLAT + END IF + UUDBL=LDEL(J)*P+MDEL(J)*ENP+NDEL(J)*PP+PH(J) + IUU=UUDBL + UU=UUDBL-IUU + SUMC=SUMC+RR*COS(UU*TWOPI) + SUMS=SUMS+RR*SIN(UU*TWOPI) + end do F_ARG(K,ITIME)=SQRT(SUMC*SUMC+SUMS*SUMS) v_ARG(k,ITIME)=vv U_ARG(K,ITIME)=ATAN2(SUMS,SUMC)/TWOPI - JBASE=JL + JBASE=JL end do -! -!*********************************************************************** -!* HERE F AND V+U OF THE SHALLOW WATER CONSTITUENTS ARE COMPUTED FROM -!* THE VALUES OF THE MAIN CONSTITUENT FROM WHICH THEY ARE DERIVED. -! - JBASE=0 - K1=NTIDAL_CON+1 - IF (K1.GT.NTOTAL_CON) RETURN -! - DO K=K1,NTOTAL_CON - F_ARG(K,ITIME)=1.0 - V_ARG(K,ITIME)=0.0 - u_ARG(k,ITIME)=0. - iflag=0 - DO lk=1,TIDE_MF - IF (TIDECON_ALLNAMES(K).eq.TIDECON_NAME(lk)) then - iflag=1 - EXIT - END IF - END DO ! lk - - DO J=TIDE_INDEXJ(K),TIDE_INDEXJ(K)+NJ(K)-1 - L=TIDE_INDEXJK(J) - F_ARG(K,ITIME)=F_ARG(K,ITIME)*F_ARG(L,ITIME)**ABS(COEF_CON(J)) - V_ARG(K,ITIME)=V_ARG(K,ITIME)+COEF_CON(J)*V_ARG(L,ITIME) - U_ARG(K,ITIME)=U_ARG(K,ITIME)+COEF_CON(J)*U_ARG(L,ITIME) - END DO ! J - END DO ! K - -! Test output for verification purposes - IF (ITIME.EQ.-1) THEN - WRITE(992,'(A,F20.2,13F8.3)') 'TEST ISEA 0:', & - d1,H,S,TAU,pp,s,p,enp,dh,dpp,ds,dp,dnp,XLAT - do l=1,TIDE_MF - do k=1,NTOTAL_CON - IF (TIDECON_ALLNAMES(k).eq.TIDECON_NAME(l)) then - TIDE_INDEX(L)=K - WRITE(992,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',1,L,20071201,0,hR, & - F_ARG(K,ITIME),U_ARG(K,ITIME),V_ARG(K,ITIME),TIDE_INDEX(L),TIDECON_NAME(l) - END IF - END DO - ENDDO - ENDIF - - RETURN -! - END SUBROUTINE SETVUF - - -!/ ------------------------------------------------------------------- / - subroutine flex_tidana_webpage(IX,IY,XLON,XLAT,KD1,KD2,ndef, itrend, RES, SSQ, RMSR0, SDEV0, & - RMSR, RESMAX, IMAX, ITEST) -! -!*********************************************************************** -!* -!* THIS PROGRAM DOES A TIDAL HEIGHTS 'HARMONIC' ANALYSIS OF IRREGULARLY -!* SAMPLED OBSERVATIONS. THE ANALYSIS METHOD IS A LEAST SQUARES FIT -!* USING SVD COUPLED WITH NODAL MODULATION AND INFERENCE(IF SO REQUESTED). -!* -!* The code is based on TOPEX analysis code originally developed by Josef -!* Cherniawsky (JAOT, 2001, 18(4): 649-664) and modified by Rob Bell and -!* Mike Foreman. Enhancements to that version include -!* -!* 1. Provision for multi-constituent inferences computed directly within -!* the least squares matrix rather than as post fit corrections. This -!* means that the inferred constituents will affect all constituents, not -!* just the reference constituent. -!* -!* 2. An extension to permit the analysis of current observations. -!* -!* 3. Removal of a central time as the basis for the calculation of the -!* astronomical arguments V. Now the V value for each observation, as well -!* as those for the nodal corrections f and u (done for the JAOT analysis), -!* are incorporated directly into the overdetermined matrix. These changes -!* mean that analyses no longer need be restricted to periods of a year or -!* less. (Though as the period approaches 18.6 years, using another "long -!* period" analysis program that solves for the "nodal satellites" directly -!* is advisable.) -!* -!*********************************************************************** -!* -!* FILE REFERENCE NUMBERS OF DEVICES REQUIRED BY THIS PROGRAM. -!* KR - INPUT FILE - CONTAINS THE TIDAL CONSTITUENT INFORMATION. -!* KR1 - INPUT FILE - GIVES ANALYSIS TYPE AND TIDAL STATION -!* DETAILS. -!* KR2 - INPUT FILE - CONTAINS THE OBSERVED TIMES AND HEIGHTS. -!* PRESENTLY KR,KR1,KR2, AND LP ARE ASSIGNED THE RESPECTIVE VALUES -!* 8,5,9, AND 6. SEE THE MANUAL OR COMMENT STATEMENTS WITHIN THIS -!* PROGRAM FOR FURTHER DETAILS ON THEIR USE. -!* -!*********************************************************************** -!* -!* ARRAY DEFINITIONS AND DIMENSION GUIDELINES. -!* -!* LET MC BE THE TOTAL NUMBER OF CONSTITUENTS, INCLUDING Z0 -!* AND ANY INFERRED CONSTITUENTS, TO BE INCLUDED IN THE -!* ANALYSIS; (For T/P, MC=30 > NUMBER OF CONSTITUENTS) -!* TIDE_NTI BE THE NUMBER OF TIDAL HEIGHT OBSERVATIONS; -!* NR BE THE NUMBER OF INPUT RECORDS OF OBSERVED TIDAL -!* HEIGHTS (For T/P data, same as TIDE_NTI, set to 200) -!* MPAR BE 2*MC-1; -!* NEQ BE TIDE_NTI*2 IF ALL THE OBSERVATIONS ARE EXTREMES AND -!* THE DERIVATIVE CONDITION IS TO BE INCLUDED FOR EACH, -!* AND TIDE_NTI OTHERWISE (= NR for T/P data). -!* THEN PARAMETERS NMAXP1, AND NMAXPM SHOULD BE AT LEAST MPAR+1, AND -!* NEQ+MPAR RESPECTIVELY. THEY ARE CURRENTLY SET TO 40 AND 240. -!* -!* TIDECON_NAME(I) IS THE ARRAY CONTAINING ALL THE CONSTITUENT NAMES, -!* INCLUDING Z0 AND ANY INFERRED CONSTITUENTS, TO BE IN -!* THE ANALYSIS. IT SHOULD BE DIMENSIONED AT LEAST MC. -!* TIDE_FREQC(I), ARE THE ARRAYS OF FREQUENCIES IN CYCLES/HR AND -!* FREQ(I) RADIANS/HR RESPECTIVELY CORRESPONDING TO THE -!* CONSTITUENT NAME(I). THEY SHOULD BE DIMENSIONED AT -!* LEAST MC. -!* AMP(I),PH(I) ARE ARRAYS CONTAINING THE RAW AMPLITUDE AND PHASE FOR -!* CONSTITUENT NAME(I) AS FOUND VIA THE LEAST SQUARES -!* ANALYSIS. THEY SHOULD BE DIMENSIONED AT LEAST MC. -!* AMPC(I),PHG(I) ARE ARRAYS CONTAINING THE AMPLITUDE AND PHASE FOR -!* CONSTITUENT NAME(I) AFTER CORRECTIONS FOR NODAL -!* MODULATION, ASTRONOMICAL ARGUMENT AND INFERRED -!* CONSTITUENTS. THEIR MINIMUM DIMENSION SHOULD BE MC. -!* TIDE_DATA(I) AND HEIGHTS, OF THE OBSERVED DATA AS IT IS INPUT BY -!* RECORD. THEY SHOULD BE DIMENSIONED ACCORDINGLY( AT -!* PRESENT ONLY 6 OBSERVATIONS ARE EXPECTED PER RECORD). -!* X(I) ARRAY CONTAINING ALL THE TIMES(IN HOURS AS -!* MEASURED FROM THE CENTRE OF THE ANALYSIS PERIOD) ITS MINIMUM -!* DIMENSION SHOULD BE TIDE_NTI. -!* NSTN(I) IS THE ARRAY CONTAINING THE TIDAL STATION TIDECON_NAME. IT -!* SHOULD HAVE MINIMUM DIMENSION 5. -!* Q(I) IS THE OVERDETERMINED ARRAY OF EQUATIONS THAT IS -!* SOLVED IN THE LEAST SQUARES SENSE BY THE MODIFIED -!* GRAM-SCHMIDT ALGORITHM. IT SHOULD HAVE THE EXACT -!* DIMENSION OF NMAXPM BY NMAXP1. -!* P(I) IS THE ARRAY CONTAINING THE TIDAL CONSTITUENT SINE -!* AND COSINE COEFICIENTS AS FOUND WITH THE LEAST -!* SQUARES FIT. IT SHOULD HAVE MINIMUM DIMENSION MPAR. -! -!*********************************************************************** -! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NDEF, ITREND, ITEST - INTEGER(KIND=4), INTENT(IN) :: KD1, KD2, IX, IY - REAL , INTENT(IN) :: XLON, XLAT - REAL(KIND=8) , INTENT(OUT):: SDEV0(NDEF), RMSR0(NDEF), RMSR(NDEF), RESMAX(NDEF) - REAL , INTENT(OUT):: SSQ(NDEF), RES(NDEF) - INTEGER , INTENT(OUT):: IMAX(NDEF) -! - INTEGER :: I, I1, I2, I21, II1, IDEF, ICODE, INFLAG, & - J, INFTOT, IREP, J2, JCODE, JJ1, K, K2, KH1, & - KH2, KHM, KINF, L, M, MEQ, N, NCOL, NEW, NMAX - REAL(KIND=8) :: AAMP, ARG, ARG1, ARG2, ARG3, C, C2, C3, & - FX, FXI, S, S2, S3, UX, VX, UXI, VXI, & - WMIN, WMAX, XMID - REAL :: TOLER - REAL(KIND=8) :: AV, SDEV, SUM2, hrm - DOUBLE PRECISION :: X(NR),Y(NR), TIME(NR) - REAL :: Q(NMAXPM,NMAXP1),FREQ(MC),AMP(MC),PH(MC) - DOUBLE PRECISION :: P(NMAXP1),CENHR,CUMHR - DOUBLE PRECISION :: yy -! -! Additional arrays, for use in the SVD routine (J.Ch., Aug. 1997) - DOUBLE PRECISION :: U(NMAXPM,NMAXP1),V(NMAXP1,NMAXP1), & - COV(NMAXP1,NMAXP1),B(NMAXPM),W(NMAXP1),SIG(NMAXPM) -! -!*********************************************************************** -! - - KH1=24*kd1 - KH2=24*(kd2+1) - KHM=(KH1+KH2)/2 - hrm=khm - CENHR=DFLOAT((KH2-KH1)/2) - - IF (itrend.eq.1) then + ! + !*********************************************************************** + !* HERE F AND V+U OF THE SHALLOW WATER CONSTITUENTS ARE COMPUTED FROM + !* THE VALUES OF THE MAIN CONSTITUENT FROM WHICH THEY ARE DERIVED. + ! + JBASE=0 + K1=NTIDAL_CON+1 + IF (K1.GT.NTOTAL_CON) RETURN + ! + DO K=K1,NTOTAL_CON + F_ARG(K,ITIME)=1.0 + V_ARG(K,ITIME)=0.0 + u_ARG(k,ITIME)=0. + iflag=0 + DO lk=1,TIDE_MF + IF (TIDECON_ALLNAMES(K).eq.TIDECON_NAME(lk)) then + iflag=1 + EXIT + END IF + END DO ! lk + + DO J=TIDE_INDEXJ(K),TIDE_INDEXJ(K)+NJ(K)-1 + L=TIDE_INDEXJK(J) + F_ARG(K,ITIME)=F_ARG(K,ITIME)*F_ARG(L,ITIME)**ABS(COEF_CON(J)) + V_ARG(K,ITIME)=V_ARG(K,ITIME)+COEF_CON(J)*V_ARG(L,ITIME) + U_ARG(K,ITIME)=U_ARG(K,ITIME)+COEF_CON(J)*U_ARG(L,ITIME) + END DO ! J + END DO ! K + + ! Test output for verification purposes + IF (ITIME.EQ.-1) THEN + WRITE(992,'(A,F20.2,13F8.3)') 'TEST ISEA 0:', & + d1,H,S,TAU,pp,s,p,enp,dh,dpp,ds,dp,dnp,XLAT + do l=1,TIDE_MF + do k=1,NTOTAL_CON + IF (TIDECON_ALLNAMES(k).eq.TIDECON_NAME(l)) then + TIDE_INDEX(L)=K + WRITE(992,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',1,L,20071201,0,hR, & + F_ARG(K,ITIME),U_ARG(K,ITIME),V_ARG(K,ITIME),TIDE_INDEX(L),TIDECON_NAME(l) + END IF + END DO + ENDDO + ENDIF + + RETURN + ! + END SUBROUTINE SETVUF + + + !/ ------------------------------------------------------------------- / + subroutine flex_tidana_webpage(IX,IY,XLON,XLAT,KD1,KD2,ndef, itrend, RES, SSQ, RMSR0, SDEV0, & + RMSR, RESMAX, IMAX, ITEST) + ! + !*********************************************************************** + !* + !* THIS PROGRAM DOES A TIDAL HEIGHTS 'HARMONIC' ANALYSIS OF IRREGULARLY + !* SAMPLED OBSERVATIONS. THE ANALYSIS METHOD IS A LEAST SQUARES FIT + !* USING SVD COUPLED WITH NODAL MODULATION AND INFERENCE(IF SO REQUESTED). + !* + !* The code is based on TOPEX analysis code originally developed by Josef + !* Cherniawsky (JAOT, 2001, 18(4): 649-664) and modified by Rob Bell and + !* Mike Foreman. Enhancements to that version include + !* + !* 1. Provision for multi-constituent inferences computed directly within + !* the least squares matrix rather than as post fit corrections. This + !* means that the inferred constituents will affect all constituents, not + !* just the reference constituent. + !* + !* 2. An extension to permit the analysis of current observations. + !* + !* 3. Removal of a central time as the basis for the calculation of the + !* astronomical arguments V. Now the V value for each observation, as well + !* as those for the nodal corrections f and u (done for the JAOT analysis), + !* are incorporated directly into the overdetermined matrix. These changes + !* mean that analyses no longer need be restricted to periods of a year or + !* less. (Though as the period approaches 18.6 years, using another "long + !* period" analysis program that solves for the "nodal satellites" directly + !* is advisable.) + !* + !*********************************************************************** + !* + !* FILE REFERENCE NUMBERS OF DEVICES REQUIRED BY THIS PROGRAM. + !* KR - INPUT FILE - CONTAINS THE TIDAL CONSTITUENT INFORMATION. + !* KR1 - INPUT FILE - GIVES ANALYSIS TYPE AND TIDAL STATION + !* DETAILS. + !* KR2 - INPUT FILE - CONTAINS THE OBSERVED TIMES AND HEIGHTS. + !* PRESENTLY KR,KR1,KR2, AND LP ARE ASSIGNED THE RESPECTIVE VALUES + !* 8,5,9, AND 6. SEE THE MANUAL OR COMMENT STATEMENTS WITHIN THIS + !* PROGRAM FOR FURTHER DETAILS ON THEIR USE. + !* + !*********************************************************************** + !* + !* ARRAY DEFINITIONS AND DIMENSION GUIDELINES. + !* + !* LET MC BE THE TOTAL NUMBER OF CONSTITUENTS, INCLUDING Z0 + !* AND ANY INFERRED CONSTITUENTS, TO BE INCLUDED IN THE + !* ANALYSIS; (For T/P, MC=30 > NUMBER OF CONSTITUENTS) + !* TIDE_NTI BE THE NUMBER OF TIDAL HEIGHT OBSERVATIONS; + !* NR BE THE NUMBER OF INPUT RECORDS OF OBSERVED TIDAL + !* HEIGHTS (For T/P data, same as TIDE_NTI, set to 200) + !* MPAR BE 2*MC-1; + !* NEQ BE TIDE_NTI*2 IF ALL THE OBSERVATIONS ARE EXTREMES AND + !* THE DERIVATIVE CONDITION IS TO BE INCLUDED FOR EACH, + !* AND TIDE_NTI OTHERWISE (= NR for T/P data). + !* THEN PARAMETERS NMAXP1, AND NMAXPM SHOULD BE AT LEAST MPAR+1, AND + !* NEQ+MPAR RESPECTIVELY. THEY ARE CURRENTLY SET TO 40 AND 240. + !* + !* TIDECON_NAME(I) IS THE ARRAY CONTAINING ALL THE CONSTITUENT NAMES, + !* INCLUDING Z0 AND ANY INFERRED CONSTITUENTS, TO BE IN + !* THE ANALYSIS. IT SHOULD BE DIMENSIONED AT LEAST MC. + !* TIDE_FREQC(I), ARE THE ARRAYS OF FREQUENCIES IN CYCLES/HR AND + !* FREQ(I) RADIANS/HR RESPECTIVELY CORRESPONDING TO THE + !* CONSTITUENT NAME(I). THEY SHOULD BE DIMENSIONED AT + !* LEAST MC. + !* AMP(I),PH(I) ARE ARRAYS CONTAINING THE RAW AMPLITUDE AND PHASE FOR + !* CONSTITUENT NAME(I) AS FOUND VIA THE LEAST SQUARES + !* ANALYSIS. THEY SHOULD BE DIMENSIONED AT LEAST MC. + !* AMPC(I),PHG(I) ARE ARRAYS CONTAINING THE AMPLITUDE AND PHASE FOR + !* CONSTITUENT NAME(I) AFTER CORRECTIONS FOR NODAL + !* MODULATION, ASTRONOMICAL ARGUMENT AND INFERRED + !* CONSTITUENTS. THEIR MINIMUM DIMENSION SHOULD BE MC. + !* TIDE_DATA(I) AND HEIGHTS, OF THE OBSERVED DATA AS IT IS INPUT BY + !* RECORD. THEY SHOULD BE DIMENSIONED ACCORDINGLY( AT + !* PRESENT ONLY 6 OBSERVATIONS ARE EXPECTED PER RECORD). + !* X(I) ARRAY CONTAINING ALL THE TIMES(IN HOURS AS + !* MEASURED FROM THE CENTRE OF THE ANALYSIS PERIOD) ITS MINIMUM + !* DIMENSION SHOULD BE TIDE_NTI. + !* NSTN(I) IS THE ARRAY CONTAINING THE TIDAL STATION TIDECON_NAME. IT + !* SHOULD HAVE MINIMUM DIMENSION 5. + !* Q(I) IS THE OVERDETERMINED ARRAY OF EQUATIONS THAT IS + !* SOLVED IN THE LEAST SQUARES SENSE BY THE MODIFIED + !* GRAM-SCHMIDT ALGORITHM. IT SHOULD HAVE THE EXACT + !* DIMENSION OF NMAXPM BY NMAXP1. + !* P(I) IS THE ARRAY CONTAINING THE TIDAL CONSTITUENT SINE + !* AND COSINE COEFICIENTS AS FOUND WITH THE LEAST + !* SQUARES FIT. IT SHOULD HAVE MINIMUM DIMENSION MPAR. + ! + !*********************************************************************** + ! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NDEF, ITREND, ITEST + INTEGER(KIND=4), INTENT(IN) :: KD1, KD2, IX, IY + REAL , INTENT(IN) :: XLON, XLAT + REAL(KIND=8) , INTENT(OUT):: SDEV0(NDEF), RMSR0(NDEF), RMSR(NDEF), RESMAX(NDEF) + REAL , INTENT(OUT):: SSQ(NDEF), RES(NDEF) + INTEGER , INTENT(OUT):: IMAX(NDEF) + ! + INTEGER :: I, I1, I2, I21, II1, IDEF, ICODE, INFLAG, & + J, INFTOT, IREP, J2, JCODE, JJ1, K, K2, KH1, & + KH2, KHM, KINF, L, M, MEQ, N, NCOL, NEW, NMAX + REAL(KIND=8) :: AAMP, ARG, ARG1, ARG2, ARG3, C, C2, C3, & + FX, FXI, S, S2, S3, UX, VX, UXI, VXI, & + WMIN, WMAX, XMID + REAL :: TOLER + REAL(KIND=8) :: AV, SDEV, SUM2, hrm + DOUBLE PRECISION :: X(NR),Y(NR), TIME(NR) + REAL :: Q(NMAXPM,NMAXP1),FREQ(MC),AMP(MC),PH(MC) + DOUBLE PRECISION :: P(NMAXP1),CENHR,CUMHR + DOUBLE PRECISION :: yy + ! + ! Additional arrays, for use in the SVD routine (J.Ch., Aug. 1997) + DOUBLE PRECISION :: U(NMAXPM,NMAXP1),V(NMAXP1,NMAXP1), & + COV(NMAXP1,NMAXP1),B(NMAXPM),W(NMAXP1),SIG(NMAXPM) + ! + !*********************************************************************** + ! + + KH1=24*kd1 + KH2=24*(kd2+1) + KHM=(KH1+KH2)/2 + hrm=khm + CENHR=DFLOAT((KH2-KH1)/2) + + IF (itrend.eq.1) then M=2*TIDE_MF - else + else M=2*TIDE_MF-1 - END IF - - - I=0 - DO I=1,TIDE_MF - FREQ(I)=TIDE_FREQC(I)*TWPI - END DO -! -!*********************************************************************** -!* DETERMINE THE CENTRAL HOUR OF THE ANALYSIS PERIOD AND SET UP THE -!* DEPENDENT AND INDEPENDENT VARIABLES, Y AND X. -! actually, CUMHR=24.d0*(KD-KHM) (check), but keep same notation as before -! - k=1 - DO i=1,TIDE_NTI - CUMHR=-CENHR+24.D0*(TIDE_DAYS(i)-kd1) - time(i)=CUMHR+DFLOAT(TIDE_SECS(i))/3600.d0 - X(K)=time(i)-time(1) - N=K - K=K+1 - END DO - -! -!*********************************************************************** -!* SETTING UP THE OVERDETERMINED MATRIX AND SOLVING WITH MODIFIED SVD -! - IREP=0 - - DO idef=1,ndef ! loop thru once or twice - -! Modifies the time reference xmid and puts it at 0 : modification by FA, 2012/09/26 -! the impact of that change has not been verified ... - xmid=0. !0.5*(TIDE_HOURS(1)+TIDE_HOURS(TIDE_NTI)) - Q(1:NMAXPM,1:NMAXP1)=0.0 - DO I=1,N -! if itrend=1, then -! first 2 parameters are constant and linear trend (per 365 days) -! fitted as const+trend(t-tmid) where tmid (=xmid) is the middle time -! of the analysis period (This makes the constant consistent with z0 -! in the old analysis program) -! If itrend=0 then the second parameter is is associated with the next -! constituent - Q(I,1)=1. - IF (itrend.eq.1) then -! Q(I,2)=(x(i)-xmid)/(24.*365.) - Q(I,2)=x(i)/(24.*365.) - END IF - Q(I,NMAXP1)=TIDE_DATA(I,IDEF) - icode=1 -! should only have to assemble lhs of matrix when idef=1 -! but something is not right if don't do it 2nd time too - ! CALL SETVUF(TIDE_HOURS(I),xlat,I) - DO J=2,TIDE_MF - CALL VUF(TIDECON_NAME(j),VX,ux,FX,I) -! check to see if this constituent is to be used for inference - inflag=0 - kinf=0 - IF (TIDE_NIN.GE.0) THEN - do k=1,TIDE_NIN - IF (TIDECON_NAME(j).eq.TIDE_KONAN(k)) then - inflag=1 - kinf=k - EXIT - END IF - END DO - END IF -! - IF (inflag.eq.0) then - ARG=(vx+ux)*twpi - IF (itrend.eq.1) then - J2=2*(J-1)+1 - else - J2=2*(J-1) - END IF - JJ1=J2+1 - Q(I,J2)=COS(ARG)*fx - Q(I,JJ1)=SIN(ARG)*fx - else - IF (itrend.eq.1) then - J2=2*(J-1)+1 - else - J2=2*(J-1) - END IF - JJ1=J2+1 - ARG1=(vx+ux)*twpi - Q(I,J2)=COS(ARG1)*fx - Q(I,JJ1)=SIN(ARG1)*fx - do k2=1,TIDE_NINF(kinf) - CALL VUF(TIDE_KONIN(kinf,k2),VXi,uxi,FXi,I) -! freq is radians/hr but sigin is cycles/hr - ARG2=(vxi+uxi)*twpi - c2=cos(arg2) - s2=sin(arg2) - arg3=TIDE_ZETA(kinf,k2)*fac - c3=cos(arg3) - s3=sin(arg3) - Q(I,J2)=q(i,J2)+fxi*TIDE_R(kinf,k2)*(c2*c3-s2*s3) - Q(I,JJ1)=q(i,jj1)+fxi*TIDE_R(kinf,k2)*(c2*s3+s2*c3) - END DO + END IF + + + I=0 + DO I=1,TIDE_MF + FREQ(I)=TIDE_FREQC(I)*TWPI + END DO + ! + !*********************************************************************** + !* DETERMINE THE CENTRAL HOUR OF THE ANALYSIS PERIOD AND SET UP THE + !* DEPENDENT AND INDEPENDENT VARIABLES, Y AND X. + ! actually, CUMHR=24.d0*(KD-KHM) (check), but keep same notation as before + ! + k=1 + DO i=1,TIDE_NTI + CUMHR=-CENHR+24.D0*(TIDE_DAYS(i)-kd1) + time(i)=CUMHR+DFLOAT(TIDE_SECS(i))/3600.d0 + X(K)=time(i)-time(1) + N=K + K=K+1 + END DO + + ! + !*********************************************************************** + !* SETTING UP THE OVERDETERMINED MATRIX AND SOLVING WITH MODIFIED SVD + ! + IREP=0 + + DO idef=1,ndef ! loop thru once or twice + + ! Modifies the time reference xmid and puts it at 0 : modification by FA, 2012/09/26 + ! the impact of that change has not been verified ... + xmid=0. !0.5*(TIDE_HOURS(1)+TIDE_HOURS(TIDE_NTI)) + Q(1:NMAXPM,1:NMAXP1)=0.0 + DO I=1,N + ! if itrend=1, then + ! first 2 parameters are constant and linear trend (per 365 days) + ! fitted as const+trend(t-tmid) where tmid (=xmid) is the middle time + ! of the analysis period (This makes the constant consistent with z0 + ! in the old analysis program) + ! If itrend=0 then the second parameter is is associated with the next + ! constituent + Q(I,1)=1. + IF (itrend.eq.1) then + ! Q(I,2)=(x(i)-xmid)/(24.*365.) + Q(I,2)=x(i)/(24.*365.) + END IF + Q(I,NMAXP1)=TIDE_DATA(I,IDEF) + icode=1 + ! should only have to assemble lhs of matrix when idef=1 + ! but something is not right if don't do it 2nd time too + ! CALL SETVUF(TIDE_HOURS(I),xlat,I) + DO J=2,TIDE_MF + CALL VUF(TIDECON_NAME(j),VX,ux,FX,I) + ! check to see if this constituent is to be used for inference + inflag=0 + kinf=0 + IF (TIDE_NIN.GE.0) THEN + do k=1,TIDE_NIN + IF (TIDECON_NAME(j).eq.TIDE_KONAN(k)) then + inflag=1 + kinf=k + EXIT END IF - END DO ! j - END DO !i - + END DO + END IF + ! + IF (inflag.eq.0) then + ARG=(vx+ux)*twpi + IF (itrend.eq.1) then + J2=2*(J-1)+1 + else + J2=2*(J-1) + END IF + JJ1=J2+1 + Q(I,J2)=COS(ARG)*fx + Q(I,JJ1)=SIN(ARG)*fx + else + IF (itrend.eq.1) then + J2=2*(J-1)+1 + else + J2=2*(J-1) + END IF + JJ1=J2+1 + ARG1=(vx+ux)*twpi + Q(I,J2)=COS(ARG1)*fx + Q(I,JJ1)=SIN(ARG1)*fx + do k2=1,TIDE_NINF(kinf) + CALL VUF(TIDE_KONIN(kinf,k2),VXi,uxi,FXi,I) + ! freq is radians/hr but sigin is cycles/hr + ARG2=(vxi+uxi)*twpi + c2=cos(arg2) + s2=sin(arg2) + arg3=TIDE_ZETA(kinf,k2)*fac + c3=cos(arg3) + s3=sin(arg3) + Q(I,J2)=q(i,J2)+fxi*TIDE_R(kinf,k2)*(c2*c3-s2*s3) + Q(I,JJ1)=q(i,jj1)+fxi*TIDE_R(kinf,k2)*(c2*s3+s2*c3) + END DO + END IF + END DO ! j + END DO !i + #ifdef W3_T WRITE(6,*) 'assembled overdetermined matrix and/or rhs' #endif - NMAX=M - MEQ=N - SSQ(IDEF)=1.0 - RES(IDEF)=1.0 - NCOL=NMAX - NEW=NMAX -! -!*********************************************************************** -!* CALCULATION OF THE STANDARD DEVIATION OF THE RIGHT HAND SIDES OF -!* THE OVERDETERMINED SYSTEM -! - AV=0.D0 - DO I=1,MEQ - AV=AV+Q(I,NMAXP1) - END DO - AV=AV/MEQ - SDEV=0.D0 - DO I=1,MEQ - SDEV=SDEV+(Q(I,NMAXP1)-AV)**2 - END DO - SDEV=SDEV/(MEQ-1) - SDEV=SQRT(SDEV) - SDEV0(IDEF)=SDEV - 109 CONTINUE -! -! USE SINGULAR-VALUE-DECOMPOSITION TO SOLVE THE OVERDETERMINED SYSTEM -! - TOLER=1.E-5 - DO I=1,NMAXPM - SIG(I)=1.D0 - END DO -! -! no solution if meq lt m. ie underdetermined system -! go to next time series - IF (meq.le.m) then - write(NDSET,*) ' underdetermined system: no svd solution',IX,IY,meq,m - stop - END IF + NMAX=M + MEQ=N + SSQ(IDEF)=1.0 + RES(IDEF)=1.0 + NCOL=NMAX + NEW=NMAX + ! + !*********************************************************************** + !* CALCULATION OF THE STANDARD DEVIATION OF THE RIGHT HAND SIDES OF + !* THE OVERDETERMINED SYSTEM + ! + AV=0.D0 + DO I=1,MEQ + AV=AV+Q(I,NMAXP1) + END DO + AV=AV/MEQ + SDEV=0.D0 + DO I=1,MEQ + SDEV=SDEV+(Q(I,NMAXP1)-AV)**2 + END DO + SDEV=SDEV/(MEQ-1) + SDEV=SQRT(SDEV) + SDEV0(IDEF)=SDEV +109 CONTINUE + ! + ! USE SINGULAR-VALUE-DECOMPOSITION TO SOLVE THE OVERDETERMINED SYSTEM + ! + TOLER=1.E-5 + DO I=1,NMAXPM + SIG(I)=1.D0 + END DO + ! + ! no solution if meq lt m. ie underdetermined system + ! go to next time series + IF (meq.le.m) then + write(NDSET,*) ' underdetermined system: no svd solution',IX,IY,meq,m + stop + END IF #ifdef W3_T WRITE(6,*) ' applying svd' #endif - CALL SVD(Q,U,V,COV,W,P,B,SIG,ICODE,MEQ,NMAX,NMAXPM,NMAXP1,TOLER & - ,JCODE,SSQ(IDEF),RES(IDEF)) -! IF (JCODE.GT.0) WRITE(LP,55)JCODE -! 55 FORMAT('COLUMN',I5,' IS THE 1ST DEPENDENT COLUMNS IN SVD') -! write out eigenvalues - wmax=-1000. - wmin=1000. - do i=1,nmax - IF (w(i).gt.wmax) wmax=w(i) - IF (w(i).lt.wmin) wmin=w(i) - end do -! write(6,*) ' max, min eigenvalues =',wmax,wmin -! write(6,*) ' all eigenvalues' -! write(6,56) (w(i),i=1,nmax) -56 format(10e12.5) -!*********************************************************************** - IF (ssq(IDEF).gt.1.e-10) then - RMSR0(IDEF)=SQRT(SSQ(IDEF)/(MEQ-M)) - else - rmsr0(IDEF)=0. - END IF + CALL SVD(Q,U,V,COV,W,P,B,SIG,ICODE,MEQ,NMAX,NMAXPM,NMAXP1,TOLER & + ,JCODE,SSQ(IDEF),RES(IDEF)) + ! IF (JCODE.GT.0) WRITE(LP,55)JCODE + ! 55 FORMAT('COLUMN',I5,' IS THE 1ST DEPENDENT COLUMNS IN SVD') + ! write out eigenvalues + wmax=-1000. + wmin=1000. + do i=1,nmax + IF (w(i).gt.wmax) wmax=w(i) + IF (w(i).lt.wmin) wmin=w(i) + end do + ! write(6,*) ' max, min eigenvalues =',wmax,wmin + ! write(6,*) ' all eigenvalues' + ! write(6,56) (w(i),i=1,nmax) +56 format(10e12.5) + !*********************************************************************** + IF (ssq(IDEF).gt.1.e-10) then + RMSR0(IDEF)=SQRT(SSQ(IDEF)/(MEQ-M)) + else + rmsr0(IDEF)=0. + END IF rmsr(IDEF)=0.d0 resmax(IDEF)=0. - do i=1,n - yy=q(i,nmaxp1) - rmsr(IDEF)=rmsr(IDEF)+yy*yy - IF (abs(yy).gt.resmax(IDEF)) then - resmax(IDEF)=abs(yy) - imax(IDEF)=i - END IF - end do -160 format(' ',7i2,f15.5,f10.5,i6) + do i=1,n + yy=q(i,nmaxp1) + rmsr(IDEF)=rmsr(IDEF)+yy*yy + IF (abs(yy).gt.resmax(IDEF)) then + resmax(IDEF)=abs(yy) + imax(IDEF)=i + END IF + end do +160 format(' ',7i2,f15.5,f10.5,i6) IF (rmsr(IDEF).gt.1.e-10) then - rmsr(IDEF)=dsqrt(rmsr(IDEF)/(n-m)) + rmsr(IDEF)=dsqrt(rmsr(IDEF)/(n-m)) else - rmsr(IDEF)=0. + rmsr(IDEF)=0. END IF -! close(unit=25) -! -!*********************************************************************** -!* CALCULATE AMPLITUDES AND PHASES -! -! if itrend=1 then the linear trend is shown as the phase of the constant -! Z0 term (& the true phase of Z0 is zero) -! otherwise, the phase of Z0 is shown as zero + ! close(unit=25) + ! + !*********************************************************************** + !* CALCULATE AMPLITUDES AND PHASES + ! + ! if itrend=1 then the linear trend is shown as the phase of the constant + ! Z0 term (& the true phase of Z0 is zero) + ! otherwise, the phase of Z0 is shown as zero AMP(1)=P(1) - IF (itrend.eq.1) then - PH(1)=P(2) - else - PH(1)=0. - END IF - DO I=2,TIDE_MF -! - IF (itrend.eq.1) then - I2=2*(I-1)+1 - else - I2=2*(I-1) - END IF - I21=I2+1 - C=P(I2) - S=P(I21) - AAMP=SQRT(C*C+S*S) - IF (AAMP.LT.1.E-5) THEN - PH(I)=0. - ELSE - PH(I)=ATAN2(S,C)/FAC - IF (PH(I).LT.0.) PH(I)=PH(I)+360. - END IF - AMP(I)=AAMP - END DO ! end of loop on TIDE_MF -!*********************************************************************** -! Note that with f & u included in the lsq fit, we only need V from routine VUF -! but we don't want to correct with V for a central hour. Better to include -! the right V in the lsq fit. This has been done. - - TIDE_AMPC(1,idef)=AMP(1) - TIDE_PHG(1,idef)=PH(1) - DO I=2,TIDE_MF - TIDE_AMPC(I,idef)=AMP(I) - TIDE_phg(i,idef)=ph(i) - END DO -! - TIDE_sig3(:,idef)=0. - TIDE_ttest(:,idef)=0. -! - IF (ITEST.GE.1) THEN -!--------------------------------------------------- -! - i=1 - IF (cov(1,1).gt.1.e-8) then - TIDE_sig1(I,idef)=sqrt(cov(1,1))*rmsr0(IDEF) - else - TIDE_sig1(I,idef)=0. - END IF - IF (itrend.eq.1.and.cov(2,2).gt.1.e-8) then - TIDE_sig2(I,idef)=sqrt(cov(2,2))*rmsr0(IDEF) + IF (itrend.eq.1) then + PH(1)=P(2) else - TIDE_sig2(I,idef)=0. - END IF - TIDE_sig3(I,idef)=0. - TIDE_ttest(I,idef)=0. -! -! results for the other constituents -! + PH(1)=0. + END IF DO I=2,TIDE_MF + ! IF (itrend.eq.1) then I2=2*(I-1)+1 else I2=2*(I-1) - END IF - II1=I2+1 -! -! multiply cov values with residual standard deviation, as described in equation -! (6) of Cherniasky et al. (2001) -! - IF (cov(I2,I2).gt.1.e-8) then - TIDE_sig1(I,idef)=sqrt(cov(I2,I2))*rmsr0(IDEF) + END IF + I21=I2+1 + C=P(I2) + S=P(I21) + AAMP=SQRT(C*C+S*S) + IF (AAMP.LT.1.E-5) THEN + PH(I)=0. + ELSE + PH(I)=ATAN2(S,C)/FAC + IF (PH(I).LT.0.) PH(I)=PH(I)+360. + END IF + AMP(I)=AAMP + END DO ! end of loop on TIDE_MF + !*********************************************************************** + ! Note that with f & u included in the lsq fit, we only need V from routine VUF + ! but we don't want to correct with V for a central hour. Better to include + ! the right V in the lsq fit. This has been done. + + TIDE_AMPC(1,idef)=AMP(1) + TIDE_PHG(1,idef)=PH(1) + DO I=2,TIDE_MF + TIDE_AMPC(I,idef)=AMP(I) + TIDE_phg(i,idef)=ph(i) + END DO + ! + TIDE_sig3(:,idef)=0. + TIDE_ttest(:,idef)=0. + ! + IF (ITEST.GE.1) THEN + !--------------------------------------------------- + ! + i=1 + IF (cov(1,1).gt.1.e-8) then + TIDE_sig1(I,idef)=sqrt(cov(1,1))*rmsr0(IDEF) else TIDE_sig1(I,idef)=0. - END IF - IF (cov(ii1,ii1).gt.1.e-8) then - TIDE_sig2(I,idef)=sqrt(cov(ii1,ii1))*rmsr0(IDEF) + END IF + IF (itrend.eq.1.and.cov(2,2).gt.1.e-8) then + TIDE_sig2(I,idef)=sqrt(cov(2,2))*rmsr0(IDEF) else TIDE_sig2(I,idef)=0. + END IF + TIDE_sig3(I,idef)=0. + TIDE_ttest(I,idef)=0. + ! + ! results for the other constituents + ! + DO I=2,TIDE_MF + IF (itrend.eq.1) then + I2=2*(I-1)+1 + else + I2=2*(I-1) + END IF + II1=I2+1 + ! + ! multiply cov values with residual standard deviation, as described in equation + ! (6) of Cherniasky et al. (2001) + ! + IF (cov(I2,I2).gt.1.e-8) then + TIDE_sig1(I,idef)=sqrt(cov(I2,I2))*rmsr0(IDEF) + else + TIDE_sig1(I,idef)=0. + END IF + IF (cov(ii1,ii1).gt.1.e-8) then + TIDE_sig2(I,idef)=sqrt(cov(ii1,ii1))*rmsr0(IDEF) + else + TIDE_sig2(I,idef)=0. END IF -! from equation 11 in Pawlowicz et al (2002) - c=TIDE_ampc(i,idef)*cos(TIDE_phg(i,idef)*fac) - s=TIDE_ampc(i,idef)*sin(TIDE_phg(i,idef)*fac) - TIDE_sig3(I,idef)=sqrt(((c*TIDE_sig1(I,idef))**2+(s*TIDE_sig2(I,idef))**2)/(c**2+s**2)) - TIDE_ttest(I,idef)=TIDE_ampc(i,idef)/TIDE_sig3(I,idef) + ! from equation 11 in Pawlowicz et al (2002) + c=TIDE_ampc(i,idef)*cos(TIDE_phg(i,idef)*fac) + s=TIDE_ampc(i,idef)*sin(TIDE_phg(i,idef)*fac) + TIDE_sig3(I,idef)=sqrt(((c*TIDE_sig1(I,idef))**2+(s*TIDE_sig2(I,idef))**2)/(c**2+s**2)) + TIDE_ttest(I,idef)=TIDE_ampc(i,idef)/TIDE_sig3(I,idef) END DO -!--------------------------------------------------- + !--------------------------------------------------- END IF ! (ITEST.GE.1) -! -! now inferred constituents -! - IF (TIDE_NIN.GE.0) THEN + ! + ! now inferred constituents + ! + IF (TIDE_NIN.GE.0) THEN l=0 do k=1,TIDE_NIN do i=2,TIDE_MF IF (TIDECON_NAME(i).eq.TIDE_KONAN(k)) EXIT - END DO + END DO i1=i do k2=1,TIDE_NINF(k) l=l+1 TIDE_ampci(k,k2,idef)=TIDE_ampc(i1,idef)*TIDE_R(k,k2) TIDE_phgi(k,k2,idef)=TIDE_phg(i1,idef)-TIDE_ZETA(k,k2) - END DO END DO + END DO inftot=l - END IF + END IF -! -!*********************************************************************** -! compute (Cherniawsky et al (2001), page 653) and rank correlation coefficients -! largest niter value are computed and shown -! if itrend=1, then the second part of Z0 is the linear trend coefficient -! -! do i=1,m -! do j=1,i -! cor(i,j)=cov(i,j)/sqrt(cov(i,i)*cov(j,j)) -! END DO -! END DO -! -! niter=20 -! do 81 iter=1,niter -! cormax=0. -! do i=2,m -! im1=i-1 -! do j=1,im1 -! ac=abs(cor(i,j)) -! if (ac.gt.cormax) then -! cormax=ac -! imax=i -! jmax=j -! END IF -! END DO -! END DO -! if (itrend.eq.1) then -! iconst=(imax+1)/2 -! jconst=(jmax+1)/2 -! else -! iconst=(imax+2)/2 -! jconst=(jmax+2)/2 -! END IF -! write(lp,83) iter,cormax,imax,jmax,TIDECON_NAME(iconst),TIDECON_NAME(jconst) -!83 format(i5,' largest correlation coefficient is ',f8.3,' at (i,j)=' & -! ,2i5,' for constituents ',a5,' and ',a5) -! cor(imax,jmax)=0. -! END DO -! - END DO ! end of loop on IDEF - RETURN + ! + !*********************************************************************** + ! compute (Cherniawsky et al (2001), page 653) and rank correlation coefficients + ! largest niter value are computed and shown + ! if itrend=1, then the second part of Z0 is the linear trend coefficient + ! + ! do i=1,m + ! do j=1,i + ! cor(i,j)=cov(i,j)/sqrt(cov(i,i)*cov(j,j)) + ! END DO + ! END DO + ! + ! niter=20 + ! do 81 iter=1,niter + ! cormax=0. + ! do i=2,m + ! im1=i-1 + ! do j=1,im1 + ! ac=abs(cor(i,j)) + ! if (ac.gt.cormax) then + ! cormax=ac + ! imax=i + ! jmax=j + ! END IF + ! END DO + ! END DO + ! if (itrend.eq.1) then + ! iconst=(imax+1)/2 + ! jconst=(jmax+1)/2 + ! else + ! iconst=(imax+2)/2 + ! jconst=(jmax+2)/2 + ! END IF + ! write(lp,83) iter,cormax,imax,jmax,TIDECON_NAME(iconst),TIDECON_NAME(jconst) + !83 format(i5,' largest correlation coefficient is ',f8.3,' at (i,j)=' & + ! ,2i5,' for constituents ',a5,' and ',a5) + ! cor(imax,jmax)=0. + ! END DO + ! + END DO ! end of loop on IDEF + RETURN - END SUBROUTINE flex_tidana_webpage + END SUBROUTINE flex_tidana_webpage -!/ ------------------------------------------------------------------- / - SUBROUTINE TIDE_PREDICT(itrend,ndef,N,HOURS, DATAIN, PREDICTED, RESID, XLAT,SDEV,RMSR) -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: itrend, NDEF, N - REAL(KIND=8) , INTENT(IN) :: HOURS(N) - REAL, INTENT(IN) :: XLAT, DATAIN(N,NDEF) - REAL(KIND=8), INTENT(OUT) :: SDEV(NDEF),RMSR(NDEF) - REAL, INTENT(OUT) :: PREDICTED(N,NDEF), RESID(N,NDEF) - ! - INTEGER :: IDEF, I, K, K2 - INTEGER :: J, M - REAL :: ARG, ADD, SUM1, SSQ - REAL(KIND=8) :: VX, UX, FX - - M = 2*TIDE_MF - - DO IDEF=1,NDEF - SDEV=0.D0 - DO I=1,N - IF (itrend.eq.1) THEN - SUM1=TIDE_AMPC(1,idef)+TIDE_PHG(1,idef)*HOURS(i)/(365.*24.) - ELSE - SUM1=TIDE_AMPC(1,idef) - END IF -! + !/ ------------------------------------------------------------------- / + SUBROUTINE TIDE_PREDICT(itrend,ndef,N,HOURS, DATAIN, PREDICTED, RESID, XLAT,SDEV,RMSR) + ! + IMPLICIT NONE + ! + INTEGER, INTENT(IN) :: itrend, NDEF, N + REAL(KIND=8) , INTENT(IN) :: HOURS(N) + REAL, INTENT(IN) :: XLAT, DATAIN(N,NDEF) + REAL(KIND=8), INTENT(OUT) :: SDEV(NDEF),RMSR(NDEF) + REAL, INTENT(OUT) :: PREDICTED(N,NDEF), RESID(N,NDEF) + ! + INTEGER :: IDEF, I, K, K2 + INTEGER :: J, M + REAL :: ARG, ADD, SUM1, SSQ + REAL(KIND=8) :: VX, UX, FX + + M = 2*TIDE_MF + + DO IDEF=1,NDEF + SDEV=0.D0 + DO I=1,N + IF (itrend.eq.1) THEN + SUM1=TIDE_AMPC(1,idef)+TIDE_PHG(1,idef)*HOURS(i)/(365.*24.) + ELSE + SUM1=TIDE_AMPC(1,idef) + END IF + ! DO J=2,TIDE_MF CALL VUF(TIDECON_NAME(j),VX,ux,FX,I) ARG=(vx+ux)*twpi-TIDE_phg(j,idef)*fac ADD=fx*TIDE_AMPc(J,idef)*COS(ARG) SUM1=SUM1+ADD - END DO -! - IF (TIDE_NIN.NE.0) THEN + END DO + ! + IF (TIDE_NIN.NE.0) THEN DO k=1,TIDE_NIN DO k2=1,TIDE_NINF(k) CALL VUF(TIDE_KONIN(k,k2),VX,ux,FX,I) ARG=(vx+ux)*twpi-TIDE_phgi(k,k2,idef)*fac ADD=fx*TIDE_AMPci(k,k2,idef)*COS(ARG) SUM1=SUM1+ADD - END DO - END DO - END IF -! + END DO + END DO + END IF + ! PREDICTED(I,IDEF)=SUM1 -! + ! RESID(I,IDEF)=DATAIN(I,IDEF)-SUM1 SDEV(IDEF)=SDEV(IDEF)+RESID(I,IDEF)**2 - END DO -! + END DO + ! SSQ=SDEV(IDEF) RMSR(IDEF)=SQRT(SSQ/(N-M)) SDEV(IDEF)=sqrt(ssq/N) - ENDDO -! - END SUBROUTINE TIDE_PREDICT - -!/ ------------------------------------------------------------------- / - SUBROUTINE TIDE_PREDICT_ONLY(itrend,ndef,N,TIDE_HOURS, PREDICTED, XLAT) -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: itrend, NDEF, N - REAL(KIND=8) , INTENT(IN) :: TIDE_HOURS(N) - REAL, INTENT(IN) :: XLAT - REAL, INTENT(OUT) :: PREDICTED(N,NDEF) - ! - INTEGER :: IDEF, I, K, K2 - INTEGER :: J - REAL :: ARG, ADD, SUM1 - REAL(KIND=8) :: VX, UX, FX - - DO IDEF=1,NDEF - DO I=1,N - IF (itrend.eq.1) THEN - SUM1=TIDE_AMPC(1,idef)+TIDE_PHG(1,idef)*TIDE_HOURS(i)/(365.*24.) - ELSE - SUM1=TIDE_AMPC(1,idef) - END IF -! + ENDDO + ! + END SUBROUTINE TIDE_PREDICT + + !/ ------------------------------------------------------------------- / + SUBROUTINE TIDE_PREDICT_ONLY(itrend,ndef,N,TIDE_HOURS, PREDICTED, XLAT) + ! + IMPLICIT NONE + ! + INTEGER, INTENT(IN) :: itrend, NDEF, N + REAL(KIND=8) , INTENT(IN) :: TIDE_HOURS(N) + REAL, INTENT(IN) :: XLAT + REAL, INTENT(OUT) :: PREDICTED(N,NDEF) + ! + INTEGER :: IDEF, I, K, K2 + INTEGER :: J + REAL :: ARG, ADD, SUM1 + REAL(KIND=8) :: VX, UX, FX + + DO IDEF=1,NDEF + DO I=1,N + IF (itrend.eq.1) THEN + SUM1=TIDE_AMPC(1,idef)+TIDE_PHG(1,idef)*TIDE_HOURS(i)/(365.*24.) + ELSE + SUM1=TIDE_AMPC(1,idef) + END IF + ! DO J=2,TIDE_MF CALL VUF(TIDECON_NAME(j),VX,UX,FX,I) ARG=(VX+UX)*twpi-TIDE_phg(J,IDEF)*fac ADD=FX*TIDE_AMPc(J,IDEF)*COS(ARG) SUM1=SUM1+ADD - END DO -! - IF (TIDE_NIN.NE.0) THEN + END DO + ! + IF (TIDE_NIN.NE.0) THEN DO k=1,TIDE_NIN DO k2=1,TIDE_NINF(k) CALL VUF(TIDE_KONIN(k,k2),VX,ux,FX,I) ARG=(vx+ux)*twpi-TIDE_phgi(k,k2,idef)*fac ADD=fx*TIDE_AMPci(k,k2,idef)*COS(ARG) SUM1=SUM1+ADD - END DO - END DO - END IF -! + END DO + END DO + END IF + ! PREDICTED(I,IDEF)=SUM1 -! - END DO -! - ENDDO -! - END SUBROUTINE TIDE_PREDICT_ONLY - -!/ -!/ End of module WMTIDEMD -------------------------------------------- / -!/ - END MODULE W3TIDEMD + ! + END DO + ! + ENDDO + ! + END SUBROUTINE TIDE_PREDICT_ONLY + + !/ + !/ End of module WMTIDEMD -------------------------------------------- / + !/ +END MODULE W3TIDEMD diff --git a/model/src/w3timemd.F90 b/model/src/w3timemd.F90 index 42bca707a..00a8a952f 100644 --- a/model/src/w3timemd.F90 +++ b/model/src/w3timemd.F90 @@ -1,2038 +1,2038 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3TIMEMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 12-Jan-2021 | -!/ +-----------------------------------+ -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Routines for management of date and time. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! PRFTB I.A. Private Base time for profiling. -! FLPROF Log. Private Flag for profiling initialization. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! TICK21 Subr. Public Increment a date and time array with -! a given number of seconds. -! IYMD21 I.F. TICK21 Date increment function. -! DSEC21 R.F. Public Calculate the difference in seconds -! between two data/time arrays. -! TDIFF R.F. Public Calculate the difference in seconds -! between two date/time arrays that -! were generated from DATE_AND_TIME -! MYMD21 I.F. DSEC21 Julian date function. -! STME21 Subr. Public Converts integer time to string. -! JULDAY I.F. Public Julian date function -! CALDAT Subr. Public Transform Julian day to date -! PRINIT Subr. Public Initialize profiling. -! PRTIME Subr. Public Get profiling time. -! D2J Subr. Public Convert date array to julian date -! J2D Subr. Public Convert julian date to date array -! T2D Subr. Public Convert time array to date array -! TSUB I.D. Public Substract two time arrays in days -! TSUBSEC I.D. Public Substract two time arrays in seconds -! U2D Subr. Public Convert time units attribute to date array -! T2ISO Subr. Public Convert time array to ISO time string -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ +MODULE W3TIMEMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 12-Jan-2021 | + !/ +-----------------------------------+ + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Routines for management of date and time. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! PRFTB I.A. Private Base time for profiling. + ! FLPROF Log. Private Flag for profiling initialization. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! TICK21 Subr. Public Increment a date and time array with + ! a given number of seconds. + ! IYMD21 I.F. TICK21 Date increment function. + ! DSEC21 R.F. Public Calculate the difference in seconds + ! between two data/time arrays. + ! TDIFF R.F. Public Calculate the difference in seconds + ! between two date/time arrays that + ! were generated from DATE_AND_TIME + ! MYMD21 I.F. DSEC21 Julian date function. + ! STME21 Subr. Public Converts integer time to string. + ! JULDAY I.F. Public Julian date function + ! CALDAT Subr. Public Transform Julian day to date + ! PRINIT Subr. Public Initialize profiling. + ! PRTIME Subr. Public Get profiling time. + ! D2J Subr. Public Convert date array to julian date + ! J2D Subr. Public Convert julian date to date array + ! T2D Subr. Public Convert time array to date array + ! TSUB I.D. Public Substract two time arrays in days + ! TSUBSEC I.D. Public Substract two time arrays in seconds + ! U2D Subr. Public Convert time units attribute to date array + ! T2ISO Subr. Public Convert time array to ISO time string + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - ! module default - implicit none + ! + ! module default + implicit none - PUBLIC -! - INTEGER, PRIVATE :: PRFTB(8) - LOGICAL, PRIVATE :: FLPROF = .FALSE. - CHARACTER, PUBLIC :: CALTYPE*8 -! - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE TICK21 ( TIME, DTIME ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Nov-1999 | -!/ +-----------------------------------+ -!/ Based on TICK of the GLA GCM. -!/ -!/ 23-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Updates time information, DTIME=0 converts to "legal" time. -! Goes into the 21st century. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! TIME I.A. I/O (1) Current date in YYYYMMDD format. -! (2) Current time in HHMMSS format. -! DTIME Real I Time step in seconds. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! IYMD21 Func. Internal Increment date in YYYYMMDD format. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any other routine. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(INOUT) :: TIME(2) - REAL, INTENT(IN) :: DTIME -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NYMD, NHMS, NSEC + PUBLIC + ! + INTEGER, PRIVATE :: PRFTB(8) + LOGICAL, PRIVATE :: FLPROF = .FALSE. + CHARACTER, PUBLIC :: CALTYPE*8 + ! +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE TICK21 ( TIME, DTIME ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Nov-1999 | + !/ +-----------------------------------+ + !/ Based on TICK of the GLA GCM. + !/ + !/ 23-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Updates time information, DTIME=0 converts to "legal" time. + ! Goes into the 21st century. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! TIME I.A. I/O (1) Current date in YYYYMMDD format. + ! (2) Current time in HHMMSS format. + ! DTIME Real I Time step in seconds. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! IYMD21 Func. Internal Increment date in YYYYMMDD format. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any other routine. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(INOUT) :: TIME(2) + REAL, INTENT(IN) :: DTIME + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NYMD, NHMS, NSEC #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'TICK21') + CALL STRACE (IENT, 'TICK21') #endif -! -! Zero increment: get "legal" date -! - NYMD = TIME(1) - NHMS = TIME(2) - IF (DTIME.EQ.0.) THEN - NYMD = IYMD21 (NYMD,-1) - NYMD = IYMD21 (NYMD, 1) - END IF -! -! Convert and increment time : -! - NSEC = NHMS/10000*3600 + MOD(NHMS,10000)/100* 60 + & - MOD(NHMS,100) + NINT(DTIME) -! -! Check change of date : -! - 100 CONTINUE - IF (NSEC.GE.86400) THEN - NSEC = NSEC - 86400 - NYMD = IYMD21 (NYMD,1) - GOTO 100 - END IF -! - 200 CONTINUE - IF (NSEC.LT.00000) THEN - NSEC = 86400 + NSEC - NYMD = IYMD21 (NYMD,-1) - GOTO 200 - END IF -! - NHMS = NSEC/3600*10000 + MOD(NSEC,3600)/60*100 + MOD(NSEC,60) -! - TIME(1) = NYMD - TIME(2) = NHMS -! - RETURN -!/ -!/ Internal function IYMD21 ------------------------------------------ / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - INTEGER FUNCTION IYMD21 ( NYMD ,M ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 18-Jun-2020 | -!/ +-----------------------------------+ -!/ Based on INCYMD of the GLA GCM. -!/ -!/ 18-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 10-Jan-2017 : Add NOLEAP option, 365 day calendar ( version 6.00 ) -!/ 18-Jun-2020 : Add 360-day calendar option ( version 7.08 ) -!/ -! 1. Purpose : -! -! Increment date in YYYYMMDD format by +/- 1 day. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NYMD Int. I Old date in YYMMDD format. -! M Int. I +/- 1 (Day adjustment) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any subroutine. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ + ! + ! Zero increment: get "legal" date + ! + NYMD = TIME(1) + NHMS = TIME(2) + IF (DTIME.EQ.0.) THEN + NYMD = IYMD21 (NYMD,-1) + NYMD = IYMD21 (NYMD, 1) + END IF + ! + ! Convert and increment time : + ! + NSEC = NHMS/10000*3600 + MOD(NHMS,10000)/100* 60 + & + MOD(NHMS,100) + NINT(DTIME) + ! + ! Check change of date : + ! +100 CONTINUE + IF (NSEC.GE.86400) THEN + NSEC = NSEC - 86400 + NYMD = IYMD21 (NYMD,1) + GOTO 100 + END IF + ! +200 CONTINUE + IF (NSEC.LT.00000) THEN + NSEC = 86400 + NSEC + NYMD = IYMD21 (NYMD,-1) + GOTO 200 + END IF + ! + NHMS = NSEC/3600*10000 + MOD(NSEC,3600)/60*100 + MOD(NSEC,60) + ! + TIME(1) = NYMD + TIME(2) = NHMS + ! + RETURN + !/ + !/ Internal function IYMD21 ------------------------------------------ / + !/ + CONTAINS + !/ ------------------------------------------------------------------- / + INTEGER FUNCTION IYMD21 ( NYMD ,M ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 18-Jun-2020 | + !/ +-----------------------------------+ + !/ Based on INCYMD of the GLA GCM. + !/ + !/ 18-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 10-Jan-2017 : Add NOLEAP option, 365 day calendar ( version 6.00 ) + !/ 18-Jun-2020 : Add 360-day calendar option ( version 7.08 ) + !/ + ! 1. Purpose : + ! + ! Increment date in YYYYMMDD format by +/- 1 day. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NYMD Int. I Old date in YYMMDD format. + ! M Int. I +/- 1 (Day adjustment) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any subroutine. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ INTEGER, INTENT(IN) :: NYMD, M -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ INTEGER :: NY, NM, ND INTEGER, SAVE :: NDPM(12) #ifdef W3_S INTEGER, SAVE :: IENT = 0 #endif LOGICAL :: LEAP -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S CALL STRACE (IENT, 'IYMD21') #endif -! -! Declare the number of days in month depending on calendar -! + ! + ! Declare the number of days in month depending on calendar + ! IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN NDPM=(/ 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30 /) ELSE NDPM=(/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) END IF -! -! "Unpack" and increment date : -! + ! + ! "Unpack" and increment date : + ! NY = NYMD / 10000 NM = MOD(NYMD,10000) / 100 NM = MIN ( 12 , MAX(1,NM) ) ND = MOD(NYMD,100) + M ! Add override for simulations with no leap years IF (TRIM(CALTYPE) .EQ. 'standard' ) THEN - LEAP = MOD(NY,400).EQ.0 .OR. & - ( MOD(NY,4).EQ.0 .AND. MOD(NY,100).NE.0 ) + LEAP = MOD(NY,400).EQ.0 .OR. & + ( MOD(NY,4).EQ.0 .AND. MOD(NY,100).NE.0 ) ELSE - LEAP = .false. + LEAP = .false. END IF -! -! M = -1, change month if necessary : -! + ! + ! M = -1, change month if necessary : + ! IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP) ND = 29 - END IF -! -! M = 1, leap year -! + NM = NM - 1 + IF (NM.EQ.0) THEN + NM = 12 + NY = NY - 1 + ENDIF + ND = NDPM(NM) + IF (NM.EQ.2 .AND. LEAP) ND = 29 + END IF + ! + ! M = 1, leap year + ! IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP) GO TO 20 -! -! next month -! + ! + ! next month + ! IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - END IF -! - 20 CONTINUE + ND = 1 + NM = NM + 1 + IF (NM.GT.12) THEN + NM = 1 + NY = NY + 1 + ENDIF + END IF + ! +20 CONTINUE IYMD21 = NY*10000 + NM*100 + ND -! + ! RETURN -!/ -!/ End of IYMD21 ----------------------------------------------------- / -!/ - END FUNCTION IYMD21 -!/ -!/ End of TICK21 ----------------------------------------------------- / -!/ - END SUBROUTINE TICK21 -!/ ------------------------------------------------------------------- / - REAL FUNCTION DSEC21 ( TIME1, TIME2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 18-Jun-2020 | -!/ +-----------------------------------+ -!/ -!/ 23-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 05-Jan-2001 : Y2K leap year error correction. ( version 2.05 ) -!/ 18-Jun-2020 : Add 360-day calendar support ( version 7.08 ) -!/ -!/ -! 1. Purpose : -! -! Calculate the time difference in seconds between two times in -! YYMMD HHMMMSS formats. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! TIMEn I.A. I Times, TIMEn(1) is date in YYYYMMDD format, -! TIMEn(2) is time in HHMMSS format. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! MYMD21 Func. Internal Calculate Julian date. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any routine. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: TIME1(2), TIME2(2) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NY1, ND1, NY2, ND2, NS1, NS2, NS, & - ND, NST + !/ + !/ End of IYMD21 ----------------------------------------------------- / + !/ + END FUNCTION IYMD21 + !/ + !/ End of TICK21 ----------------------------------------------------- / + !/ + END SUBROUTINE TICK21 + !/ ------------------------------------------------------------------- / + REAL FUNCTION DSEC21 ( TIME1, TIME2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 18-Jun-2020 | + !/ +-----------------------------------+ + !/ + !/ 23-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 05-Jan-2001 : Y2K leap year error correction. ( version 2.05 ) + !/ 18-Jun-2020 : Add 360-day calendar support ( version 7.08 ) + !/ + !/ + ! 1. Purpose : + ! + ! Calculate the time difference in seconds between two times in + ! YYMMD HHMMMSS formats. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! TIMEn I.A. I Times, TIMEn(1) is date in YYYYMMDD format, + ! TIMEn(2) is time in HHMMSS format. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! MYMD21 Func. Internal Calculate Julian date. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: TIME1(2), TIME2(2) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NY1, ND1, NY2, ND2, NS1, NS2, NS, & + ND, NST #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'DSEC21') + CALL STRACE (IENT, 'DSEC21') #endif -! -! Convert dates and times : -! - NY1 = TIME1(1) / 10000 - ND1 = MYMD21 ( TIME1(1) ) - NS1 = TIME1(2)/10000*3600 + MOD(TIME1(2),10000)/100*60 + & - MOD(TIME1(2),100) -! - NY2 = TIME2(1) / 10000 - ND2 = MYMD21 ( TIME2(1) ) - NS2 = TIME2(2)/10000*3600 + MOD(TIME2(2),10000)/100*60 + & - MOD(TIME2(2),100) -! -! Number of days and seconds in difference : -! - ND = ND2 - ND1 -! - IF ( NY1 .NE. NY2 ) THEN - NST = SIGN ( 1 , NY2-NY1 ) - 100 CONTINUE - IF (NY1.EQ.NY2) GOTO 200 - IF (NST.GT.0) THEN - NY2 = NY2 - 1 - IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN - ND = ND + MYMD21 ( NY2*10000 + 1230 ) - ELSE - ND = ND + MYMD21 ( NY2*10000 + 1231 ) - END IF - ELSE - IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN - ND = ND - MYMD21 ( NY2*10000 + 1230 ) - ELSE - ND = ND - MYMD21 ( NY2*10000 + 1231 ) - END IF - NY2 = NY2 + 1 - ENDIF - GOTO 100 - 200 CONTINUE + ! + ! Convert dates and times : + ! + NY1 = TIME1(1) / 10000 + ND1 = MYMD21 ( TIME1(1) ) + NS1 = TIME1(2)/10000*3600 + MOD(TIME1(2),10000)/100*60 + & + MOD(TIME1(2),100) + ! + NY2 = TIME2(1) / 10000 + ND2 = MYMD21 ( TIME2(1) ) + NS2 = TIME2(2)/10000*3600 + MOD(TIME2(2),10000)/100*60 + & + MOD(TIME2(2),100) + ! + ! Number of days and seconds in difference : + ! + ND = ND2 - ND1 + ! + IF ( NY1 .NE. NY2 ) THEN + NST = SIGN ( 1 , NY2-NY1 ) +100 CONTINUE + IF (NY1.EQ.NY2) GOTO 200 + IF (NST.GT.0) THEN + NY2 = NY2 - 1 + IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN + ND = ND + MYMD21 ( NY2*10000 + 1230 ) + ELSE + ND = ND + MYMD21 ( NY2*10000 + 1231 ) END IF -! - NS = NS2 - NS1 -! -! Output of time difference : -! - DSEC21 = REAL(NS) + 86400.*REAL(ND) -! - RETURN -!/ -!/ Internal function MYMD21 ------------------------------------------ / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - INTEGER FUNCTION MYMD21 ( NYMD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 18-Jun-2020 | -!/ +-----------------------------------+ -!/ Based on MODYMD of the GLA GCM. -!/ -!/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 10-Jan-2017 : Add NOLEAP option, 365 day calendar ( version 6.01 ) -!/ 18-Jun-2020 : Add 360-day calendar support ( version 7.08 ) -!/ -! 1. Purpose : -! -! Convert date in YYMMDD format to julian date. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NYMD Int. I Date in YYMMDD format. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any subroutine. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ + ELSE + IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN + ND = ND - MYMD21 ( NY2*10000 + 1230 ) + ELSE + ND = ND - MYMD21 ( NY2*10000 + 1231 ) + END IF + NY2 = NY2 + 1 + ENDIF + GOTO 100 +200 CONTINUE + END IF + ! + NS = NS2 - NS1 + ! + ! Output of time difference : + ! + DSEC21 = REAL(NS) + 86400.*REAL(ND) + ! + RETURN + !/ + !/ Internal function MYMD21 ------------------------------------------ / + !/ + CONTAINS + !/ ------------------------------------------------------------------- / + INTEGER FUNCTION MYMD21 ( NYMD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 18-Jun-2020 | + !/ +-----------------------------------+ + !/ Based on MODYMD of the GLA GCM. + !/ + !/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 10-Jan-2017 : Add NOLEAP option, 365 day calendar ( version 6.01 ) + !/ 18-Jun-2020 : Add 360-day calendar support ( version 7.08 ) + !/ + ! 1. Purpose : + ! + ! Convert date in YYMMDD format to julian date. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NYMD Int. I Date in YYMMDD format. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any subroutine. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ INTEGER, INTENT(IN) :: NYMD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ INTEGER :: NY, NM, ND INTEGER, SAVE :: NDPM(12) #ifdef W3_S INTEGER, SAVE :: IENT = 0 #endif LOGICAL :: LEAP -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S CALL STRACE (IENT, 'MYMD21') #endif -! -! Declare the number of days in month depending on calendar -! + ! + ! Declare the number of days in month depending on calendar + ! IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN NDPM=(/ 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30 /) ELSE NDPM=(/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) END IF -! -! "Unpack" and increment date : -! + ! + ! "Unpack" and increment date : + ! NY = NYMD / 10000 NM = MOD(NYMD,10000) / 100 ND = MOD(NYMD,100) !Allow override for NoLeap simulations IF (TRIM(CALTYPE) .EQ. 'standard' ) THEN - LEAP = MOD(NY,400).EQ.0 .OR. & - ( MOD(NY,4).EQ.0 .AND. MOD(NY,100).NE.0 ) + LEAP = MOD(NY,400).EQ.0 .OR. & + ( MOD(NY,4).EQ.0 .AND. MOD(NY,100).NE.0 ) ELSE - LEAP=.false. + LEAP=.false. ENDIF -! -! Loop over months : -! + ! + ! Loop over months : + ! IF (NM.GT.2 .AND. LEAP) ND = ND + 1 -! - 40 CONTINUE + ! +40 CONTINUE IF (NM.LE.1) GO TO 60 NM = NM - 1 ND = ND + NDPM(NM) GO TO 40 -! - 60 CONTINUE + ! +60 CONTINUE MYMD21 = ND -! - RETURN -!/ -!/ End of MYMD21 ----------------------------------------------------- / -!/ - END FUNCTION MYMD21 -!/ -!/ End of DSEC21 ----------------------------------------------------- / -!/ - END FUNCTION DSEC21 -!/ ------------------------------------------------------------------- / - REAL FUNCTION TDIFF ( T1, T2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Arun Chawla | -!/ | Mark Szyszka | -!/ | FORTRAN 90 | -!/ | Last update : 02-Feb-2014 | -!/ +-----------------------------------+ -!/ -!/ 02-Feb-2014 : Original code ( version 4.18 ) -!/ -!/ -! 1. Purpose : -! -! Calculate the time difference in seconds between two time arrays -! that have been generated from the F90 internal function -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! Tn I.A. I This is an integer array returned from the -! internal subroutine DATE_AND_TIME. The type -! is integer(8). Individual values are -! Tn(1) the year -! Tn(2) the month -! Tn(3) day of the month -! Tn(4) time difference with UTC in minutes -! Tn(5) hour of the day -! Tn(6) minutes of the hour -! Tn(7) seconds of the minute -! Tn(8) milli seconds of the second -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any routine. -! -! 7. Remarks : -! -! This code has been provided by Mark Szyszka of RPSGROUP -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: T1(8), T2(8) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: A1, B1, C1, D1, A2, B2, C2, D2 - REAL :: E1, E2 -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'TDIFF') -#endif -! -! Convert dates and times : -! - A1 = (14-T1(2))/12 - B1 = T1(1) + 4800 - A1 - C1 = T1(2) + 12*A1 - 3 - D1 = T1(3) + (153*C1 + 2)/5 + 365*B1 + B1/4 -B1/100 + B1/400 - E1 = 3600.0*T1(5) + 60.0*(T1(6)-T1(4)) + T1(7) + T1(8)/1000.0 -! - A2 = (14-T2(2))/12 - B2 = T2(1) + 4800 - A2 - C2 = T2(2) + 12*A2 - 3 - D2 = T2(3) + (153*C2 + 2)/5 + 365*B2 + B2/4 -B2/100 + B2/400 - E2 = 3600.0*T2(5) + 60.0*(T2(6)-T2(4)) + T2(7) + T2(8)/1000.0 -! - TDIFF = 86400.0*(D2-D1) + E2-E1 -! - RETURN -!/ -!/ End of TDIFF ------------------------------------------------------ / -!/ - END FUNCTION TDIFF -!/ ------------------------------------------------------------------- / - SUBROUTINE STME21 ( TIME , DTME21 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 21-Jun-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Converts time to more readable string. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! TIME I.A. I Time in YYYYMMDD HHMMSS format. -! TIME(1) < 0 indicates that time is not set. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Any subroutine/program. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: TIME(2) - CHARACTER, INTENT(OUT) :: DTME21*23 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IY, IMO, ID, IH, IMI, IS -!/ -!/ ------------------------------------------------------------------- / -!/ - IF ( TIME(1) .LT. 0 ) THEN - DTME21 = ' date and time not set.' - ELSE - IY = TIME(1) / 10000 - IMO = MOD(TIME(1),10000) / 100 - ID = MOD(TIME(1),100) - IH = TIME(2) / 10000 - IMI = MOD(TIME(2),10000) / 100 - IS = MOD(TIME(2),100) - WRITE (DTME21,900) IY, IMO, ID, IH, IMI, IS - ENDIF -! + ! RETURN -! -! Formats -! - 900 FORMAT (I4.4,'/',I2.2,'/',I2.2,' ',I2.2,':',I2.2,':',I2.2,' UTC') -!/ -!/ End of STME21 ----------------------------------------------------- / -!/ - END SUBROUTINE STME21 - -!/ ------------------------------------------------------------------- / - INTEGER FUNCTION JULDAY(id,mm,iyyy) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 23-Sep-2012 | -!/ +-----------------------------------+ -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ -!/ ------------------------------------------------------------------- / - INTEGER(KIND=4), INTENT(in) :: id,mm,iyyy -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER(KIND=4), PARAMETER :: IGREG=15+31*(10+12*1582) - INTEGER(KIND=4) ja,jm,jy - jy=iyyy - IF (jy.EQ.0) WRITE(6,*) 'There is no zero year !!' - IF (jy.LT.0) jy=jy+1 - IF (mm.GT.2) THEN - jm=mm+1 - ELSE - jy=jy-1 - jm=mm+13 - ENDIF - julday=INT(365.25*jy)+int(30.6001*jm)+id+1720995 - IF (id+31*(mm+12*iyyy).GE.IGREG) THEN - ja=INT(0.01*jy) - julday=julday+2-ja+INT(0.25*ja) - END IF - RETURN -!/ -!/ End of JULDAY ----------------------------------------------------- / -!/ - END FUNCTION JULDAY - -!/ ------------------------------------------------------------------- / - SUBROUTINE CALDAT(julian,id,mm,iyyy) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 23-Sep-2012 | -!/ +-----------------------------------+ -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -! See numerical recipes 2nd ed. The order of month and day have been swapped! -! -!/ - INTEGER(KIND=4), INTENT(in) :: julian - INTEGER(KIND=4), INTENT(out) :: id,mm,iyyy - INTEGER(KIND=4), PARAMETER :: IGREG=2299161 - INTEGER(KIND=4) ja,jalpha,jb,jc,jd,je - if (julian.GE.IGREG) THEN - jalpha=INT(((julian-1867216)-0.25)/36524.25) - ja=julian+1+jalpha-INT(0.25*jalpha) - ELSE - ja=julian - END IF - jb=ja+1524 - jc=INT(6680.+((jb-2439870)-122.1)/365.25) - jd=365*jc+INT(0.25*jc) - je=INT((jb-jd)/30.6001) - id=jb-jd-INT(30.6001*je) - mm=je-1 - IF (mm.GT.12) mm=mm-12 - iyyy=jc-4715 - IF (mm.GT.2) iyyy=iyyy-1 - IF (iyyy.LE.0) iyyy=iyyy-1 - RETURN -!/ -!/ End of CALDAT ----------------------------------------------------- / -!/ - END SUBROUTINE CALDAT -!/ ------------------------------------------------------------------- / - REAL(KIND=8) FUNCTION TIME2HOURS(TIME) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 26-Sep-2012 | -!/ +-----------------------------------+ -! -! 1. Purpose : -! -! Gives date as real number -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! TIME I.A. I/O (1) Current date in YYYYMMDD format. -! (2) Current time in HHMMSS format. -! DTIME Real I Time step in seconds. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! IYMD21 Func. Internal Increment date in YYYYMMDD format. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any other routine. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing using STRACE. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(INOUT) :: TIME(2) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IY,IMO,ID,IH,IMI,IS - INTEGER(KIND=4) :: JDAY + !/ + !/ End of MYMD21 ----------------------------------------------------- / + !/ + END FUNCTION MYMD21 + !/ + !/ End of DSEC21 ----------------------------------------------------- / + !/ + END FUNCTION DSEC21 + !/ ------------------------------------------------------------------- / + REAL FUNCTION TDIFF ( T1, T2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Arun Chawla | + !/ | Mark Szyszka | + !/ | FORTRAN 90 | + !/ | Last update : 02-Feb-2014 | + !/ +-----------------------------------+ + !/ + !/ 02-Feb-2014 : Original code ( version 4.18 ) + !/ + !/ + ! 1. Purpose : + ! + ! Calculate the time difference in seconds between two time arrays + ! that have been generated from the F90 internal function + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! Tn I.A. I This is an integer array returned from the + ! internal subroutine DATE_AND_TIME. The type + ! is integer(8). Individual values are + ! Tn(1) the year + ! Tn(2) the month + ! Tn(3) day of the month + ! Tn(4) time difference with UTC in minutes + ! Tn(5) hour of the day + ! Tn(6) minutes of the hour + ! Tn(7) seconds of the minute + ! Tn(8) milli seconds of the second + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 7. Remarks : + ! + ! This code has been provided by Mark Szyszka of RPSGROUP + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: T1(8), T2(8) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: A1, B1, C1, D1, A2, B2, C2, D2 + REAL :: E1, E2 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'TICK21') + CALL STRACE (IENT, 'TDIFF') #endif -! -! Zero increment: get "legal" date -! + ! + ! Convert dates and times : + ! + A1 = (14-T1(2))/12 + B1 = T1(1) + 4800 - A1 + C1 = T1(2) + 12*A1 - 3 + D1 = T1(3) + (153*C1 + 2)/5 + 365*B1 + B1/4 -B1/100 + B1/400 + E1 = 3600.0*T1(5) + 60.0*(T1(6)-T1(4)) + T1(7) + T1(8)/1000.0 + ! + A2 = (14-T2(2))/12 + B2 = T2(1) + 4800 - A2 + C2 = T2(2) + 12*A2 - 3 + D2 = T2(3) + (153*C2 + 2)/5 + 365*B2 + B2/4 -B2/100 + B2/400 + E2 = 3600.0*T2(5) + 60.0*(T2(6)-T2(4)) + T2(7) + T2(8)/1000.0 + ! + TDIFF = 86400.0*(D2-D1) + E2-E1 + ! + RETURN + !/ + !/ End of TDIFF ------------------------------------------------------ / + !/ + END FUNCTION TDIFF + !/ ------------------------------------------------------------------- / + SUBROUTINE STME21 ( TIME , DTME21 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 21-Jun-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Converts time to more readable string. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! TIME I.A. I Time in YYYYMMDD HHMMSS format. + ! TIME(1) < 0 indicates that time is not set. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Any subroutine/program. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: TIME(2) + CHARACTER, INTENT(OUT) :: DTME21*23 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IY, IMO, ID, IH, IMI, IS + !/ + !/ ------------------------------------------------------------------- / + !/ + IF ( TIME(1) .LT. 0 ) THEN + DTME21 = ' date and time not set.' + ELSE IY = TIME(1) / 10000 IMO = MOD(TIME(1),10000) / 100 ID = MOD(TIME(1),100) IH = TIME(2) / 10000 IMI = MOD(TIME(2),10000) / 100 IS = MOD(TIME(2),100) - JDAY = julday(id,IMO,iy) - TIME2HOURS = 24.d0*dfloat(JDAY)+dfloat(IH)+dfloat(IS+IMI*60)/3600.d0 - RETURN -!/ -!/ End of TIME2HOURS-------------------------------------------------- / -!/ - END FUNCTION TIME2HOURS -!/ ------------------------------------------------------------------- / - SUBROUTINE PRINIT -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-May-2005 ! -!/ +-----------------------------------+ -!/ -!/ 06-May-2005 : Origination. ( version 3.07 ) -!/ -! 1. Purpose : -! -! Initialize profiling routine PRTIME. -! -! 2. Method : -! -! FORTRAN 90 SYSTEM_CLOCK intrinsic routine. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! SYSTEM_CLOCK -! Sur. n/a Get system time -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -! -------------------------------------------------------------------- / -! - CALL DATE_AND_TIME ( VALUES=PRFTB ) -! - FLPROF = .TRUE. -! - RETURN -!/ -!/ End of PRINIT ----------------------------------------------------- / -!/ - END SUBROUTINE PRINIT -!/ ------------------------------------------------------------------- / - SUBROUTINE PRTIME ( PTIME ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-May-2005 ! -!/ +-----------------------------------+ -!/ -!/ 06-May-2005 : Origination. ( version 3.07 ) -!/ -! 1. Purpose : -! -! Get wallclock time for profiling purposes. -! -! 2. Method : -! -! FORTRAN 90 SYSTEM_CLOCK intrinsic routine. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! PTIME Real O Time retrieced from system. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! SYSTEM_CLOCK -! Sur. n/a Get system time -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any, after PRINIT has been called. -! -! 6. Error messages : -! -! - If no initialization, returned time equals -1. -! - If no system clock, returned time equals -1. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(OUT) :: PTIME -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: PRFTA(8) -! -! -------------------------------------------------------------------- / -! - PTIME = -1. -! - IF ( .NOT. FLPROF ) RETURN -! - CALL DATE_AND_TIME ( VALUES=PRFTA ) - PTIME = TDIFF ( PRFTB,PRFTA ) -! - RETURN -!/ -!/ End of PRTIME ----------------------------------------------------- / -!/ - END SUBROUTINE PRTIME + WRITE (DTME21,900) IY, IMO, ID, IH, IMI, IS + ENDIF + ! + RETURN + ! + ! Formats + ! +900 FORMAT (I4.4,'/',I2.2,'/',I2.2,' ',I2.2,':',I2.2,':',I2.2,' UTC') + !/ + !/ End of STME21 ----------------------------------------------------- / + !/ + END SUBROUTINE STME21 -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + INTEGER FUNCTION JULDAY(id,mm,iyyy) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 23-Sep-2012 | + !/ +-----------------------------------+ + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ + !/ ------------------------------------------------------------------- / + INTEGER(KIND=4), INTENT(in) :: id,mm,iyyy + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER(KIND=4), PARAMETER :: IGREG=15+31*(10+12*1582) + INTEGER(KIND=4) ja,jm,jy + jy=iyyy + IF (jy.EQ.0) WRITE(6,*) 'There is no zero year !!' + IF (jy.LT.0) jy=jy+1 + IF (mm.GT.2) THEN + jm=mm+1 + ELSE + jy=jy-1 + jm=mm+13 + ENDIF + julday=INT(365.25*jy)+int(30.6001*jm)+id+1720995 + IF (id+31*(mm+12*iyyy).GE.IGREG) THEN + ja=INT(0.01*jy) + julday=julday+2-ja+INT(0.25*ja) + END IF + RETURN + !/ + !/ End of JULDAY ----------------------------------------------------- / + !/ + END FUNCTION JULDAY - SUBROUTINE T2D(TIME,DAT,IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 04-Jan-2018 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-2018 : Origination ( version 6.04 ) -!/ -! 1. Purpose : -! -! Converts time array from TIME(2) to DAT(8) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! TIME I.A. I Time array like 'YYYYMMDD HHMMSS' -! DAT I.A. O Time array like returned by DATE_AND_TIME(3f) -! IERR Integer O Error code returned -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any subroutine/program. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER,INTENT(IN) :: TIME(2) ! array like 'YYYYMMDD HHMMSS' - INTEGER,INTENT(OUT) :: DAT(8) ! array like returned by DATE_AND_TIME(3f) - INTEGER,INTENT(OUT) :: IERR ! Error return, 0 for successful execution - ! Otherwise return 1 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ ------------------------------------------------------------------- / + SUBROUTINE CALDAT(julian,id,mm,iyyy) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 23-Sep-2012 | + !/ +-----------------------------------+ + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + ! See numerical recipes 2nd ed. The order of month and day have been swapped! + ! + !/ + INTEGER(KIND=4), INTENT(in) :: julian + INTEGER(KIND=4), INTENT(out) :: id,mm,iyyy + INTEGER(KIND=4), PARAMETER :: IGREG=2299161 + INTEGER(KIND=4) ja,jalpha,jb,jc,jd,je + if (julian.GE.IGREG) THEN + jalpha=INT(((julian-1867216)-0.25)/36524.25) + ja=julian+1+jalpha-INT(0.25*jalpha) + ELSE + ja=julian + END IF + jb=ja+1524 + jc=INT(6680.+((jb-2439870)-122.1)/365.25) + jd=365*jc+INT(0.25*jc) + je=INT((jb-jd)/30.6001) + id=jb-jd-INT(30.6001*je) + mm=je-1 + IF (mm.GT.12) mm=mm-12 + iyyy=jc-4715 + IF (mm.GT.2) iyyy=iyyy-1 + IF (iyyy.LE.0) iyyy=iyyy-1 + RETURN + !/ + !/ End of CALDAT ----------------------------------------------------- / + !/ + END SUBROUTINE CALDAT + !/ ------------------------------------------------------------------- / + REAL(KIND=8) FUNCTION TIME2HOURS(TIME) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 26-Sep-2012 | + !/ +-----------------------------------+ + ! + ! 1. Purpose : + ! + ! Gives date as real number + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! TIME I.A. I/O (1) Current date in YYYYMMDD format. + ! (2) Current time in HHMMSS format. + ! DTIME Real I Time step in seconds. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! IYMD21 Func. Internal Increment date in YYYYMMDD format. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any other routine. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing using STRACE. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(INOUT) :: TIME(2) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IY,IMO,ID,IH,IMI,IS + INTEGER(KIND=4) :: JDAY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'T2D') + CALL STRACE (IENT, 'TICK21') #endif -! - DAT(1)=TIME(1)/10000 - DAT(2)=(TIME(1)-DAT(1)*10000)/100 - DAT(3)=TIME(1)-DAT(1)*10000-100*DAT(2) - DAT(4)=0 - DAT(5)=TIME(2)/10000 - DAT(6)=(TIME(2)-DAT(5)*10000)/100 - DAT(7)=TIME(2)-DAT(5)*10000-100*DAT(6) - DAT(8)=0 - IERR=0 -! - RETURN -!/ -!/ End of T2D ----------------------------------------------------- / -!/ - END SUBROUTINE T2D + ! + ! Zero increment: get "legal" date + ! + IY = TIME(1) / 10000 + IMO = MOD(TIME(1),10000) / 100 + ID = MOD(TIME(1),100) + IH = TIME(2) / 10000 + IMI = MOD(TIME(2),10000) / 100 + IS = MOD(TIME(2),100) + JDAY = julday(id,IMO,iy) + TIME2HOURS = 24.d0*dfloat(JDAY)+dfloat(IH)+dfloat(IS+IMI*60)/3600.d0 + RETURN + !/ + !/ End of TIME2HOURS-------------------------------------------------- / + !/ + END FUNCTION TIME2HOURS + !/ ------------------------------------------------------------------- / + SUBROUTINE PRINIT + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-May-2005 ! + !/ +-----------------------------------+ + !/ + !/ 06-May-2005 : Origination. ( version 3.07 ) + !/ + ! 1. Purpose : + ! + ! Initialize profiling routine PRTIME. + ! + ! 2. Method : + ! + ! FORTRAN 90 SYSTEM_CLOCK intrinsic routine. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! SYSTEM_CLOCK + ! Sur. n/a Get system time + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + ! -------------------------------------------------------------------- / + ! + CALL DATE_AND_TIME ( VALUES=PRFTB ) + ! + FLPROF = .TRUE. + ! + RETURN + !/ + !/ End of PRINIT ----------------------------------------------------- / + !/ + END SUBROUTINE PRINIT + !/ ------------------------------------------------------------------- / + SUBROUTINE PRTIME ( PTIME ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-May-2005 ! + !/ +-----------------------------------+ + !/ + !/ 06-May-2005 : Origination. ( version 3.07 ) + !/ + ! 1. Purpose : + ! + ! Get wallclock time for profiling purposes. + ! + ! 2. Method : + ! + ! FORTRAN 90 SYSTEM_CLOCK intrinsic routine. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! PTIME Real O Time retrieced from system. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! SYSTEM_CLOCK + ! Sur. n/a Get system time + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any, after PRINIT has been called. + ! + ! 6. Error messages : + ! + ! - If no initialization, returned time equals -1. + ! - If no system clock, returned time equals -1. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(OUT) :: PTIME + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: PRFTA(8) + ! + ! -------------------------------------------------------------------- / + ! + PTIME = -1. + ! + IF ( .NOT. FLPROF ) RETURN + ! + CALL DATE_AND_TIME ( VALUES=PRFTA ) + PTIME = TDIFF ( PRFTB,PRFTA ) + ! + RETURN + !/ + !/ End of PRTIME ----------------------------------------------------- / + !/ + END SUBROUTINE PRTIME -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE T2D(TIME,DAT,IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 04-Jan-2018 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-2018 : Origination ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Converts time array from TIME(2) to DAT(8) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! TIME I.A. I Time array like 'YYYYMMDD HHMMSS' + ! DAT I.A. O Time array like returned by DATE_AND_TIME(3f) + ! IERR Integer O Error code returned + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any subroutine/program. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER,INTENT(IN) :: TIME(2) ! array like 'YYYYMMDD HHMMSS' + INTEGER,INTENT(OUT) :: DAT(8) ! array like returned by DATE_AND_TIME(3f) + INTEGER,INTENT(OUT) :: IERR ! Error return, 0 for successful execution + ! Otherwise return 1 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'T2D') +#endif + ! + DAT(1)=TIME(1)/10000 + DAT(2)=(TIME(1)-DAT(1)*10000)/100 + DAT(3)=TIME(1)-DAT(1)*10000-100*DAT(2) + DAT(4)=0 + DAT(5)=TIME(2)/10000 + DAT(6)=(TIME(2)-DAT(5)*10000)/100 + DAT(7)=TIME(2)-DAT(5)*10000-100*DAT(6) + DAT(8)=0 + IERR=0 + ! + RETURN + !/ + !/ End of T2D ----------------------------------------------------- / + !/ + END SUBROUTINE T2D - SUBROUTINE D2T(DAT,TIME,IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 04-Jan-2018 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-2018 : Origination ( version 6.04 ) -!/ -! 1. Purpose : -! -! Converts time array from DAT(8) to TIME(2) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! DAT I.A. I Time array like returned by DATE_AND_TIME(3f) -! TIME I.A. O Time array like 'YYYYMMDD HHMMSS' -! IERR Integer O Error code returned -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any subroutine/program. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER,INTENT(IN) :: DAT(8) ! array like returned by DATE_AND_TIME(3f) - INTEGER,INTENT(OUT) :: TIME(2) ! array like 'YYYYMMDD HHMMSS' - INTEGER,INTENT(OUT) :: IERR ! Error return, 0 for successful execution - ! Otherwise return 1 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ ------------------------------------------------------------------- / + + + SUBROUTINE D2T(DAT,TIME,IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 04-Jan-2018 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-2018 : Origination ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Converts time array from DAT(8) to TIME(2) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! DAT I.A. I Time array like returned by DATE_AND_TIME(3f) + ! TIME I.A. O Time array like 'YYYYMMDD HHMMSS' + ! IERR Integer O Error code returned + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any subroutine/program. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER,INTENT(IN) :: DAT(8) ! array like returned by DATE_AND_TIME(3f) + INTEGER,INTENT(OUT) :: TIME(2) ! array like 'YYYYMMDD HHMMSS' + INTEGER,INTENT(OUT) :: IERR ! Error return, 0 for successful execution + ! Otherwise return 1 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'D2T') + CALL STRACE (IENT, 'D2T') #endif -! - TIME(1)=DAT(1)*10000+DAT(2)*100+DAT(3) - TIME(2)=DAT(5)*10000+DAT(6)*100+DAT(7) - IERR=0 -! - RETURN -!/ -!/ End of D2T ----------------------------------------------------- / -!/ - END SUBROUTINE D2T + ! + TIME(1)=DAT(1)*10000+DAT(2)*100+DAT(3) + TIME(2)=DAT(5)*10000+DAT(6)*100+DAT(7) + IERR=0 + ! + RETURN + !/ + !/ End of D2T ----------------------------------------------------- / + !/ + END SUBROUTINE D2T -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / - SUBROUTINE D2J(DAT,JULIAN,IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 04-Jan-2018 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-2018 : Origination from m_time library ( version 6.04 ) -!/ -! 1. Purpose : -! -! Converts proleptic Gregorian date array to Julian Day -! -! -! * UDUNITS standard : mixed Gregorian/Julian calendar system. -! Dates prior to 1582-10-15 are assumed to use -! the Julian calendar, which was introduced by Julius Caesar -! in 46 BCE and is based on a year that is exactly 365.25 days -! long. Dates on and after 1582-10-15 are assumed to use the -! Gregorian calendar, which was introduced on that date and is -! based on a year that is exactly 365.2425 days long. (A year -! is actually approximately 365.242198781 days long.) -! -! * There is no year zero -! * Julian Day must be non-negative -! * Julian Day starts at noon; while Civil Calendar date starts at midnight -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! DAT I.A. I Time array like returned by DATE_AND_TIME(3f) -! JULIAN Double O Julian day -! IERR Integer O Error code returned -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any subroutine/program. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER,INTENT(IN) :: DAT(8) ! array like returned by DATE_AND_TIME(3f) - DOUBLE PRECISION,INTENT(OUT) :: JULIAN ! Julian Day (non-negative, but may be non-integer) - INTEGER,INTENT(OUT) :: IERR ! Error return, 0 for successful execution - ! -1=invalid year,-2=invalid month,-3=invalid day, - ! -4=invalid date (29th Feb, non leap-year) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: YEAR, MONTH, DAY, UTC, HOUR, MINUTE - REAL :: SECOND - INTEGER :: A, Y, M, JDN + SUBROUTINE D2J(DAT,JULIAN,IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 04-Jan-2018 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-2018 : Origination from m_time library ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Converts proleptic Gregorian date array to Julian Day + ! + ! + ! * UDUNITS standard : mixed Gregorian/Julian calendar system. + ! Dates prior to 1582-10-15 are assumed to use + ! the Julian calendar, which was introduced by Julius Caesar + ! in 46 BCE and is based on a year that is exactly 365.25 days + ! long. Dates on and after 1582-10-15 are assumed to use the + ! Gregorian calendar, which was introduced on that date and is + ! based on a year that is exactly 365.2425 days long. (A year + ! is actually approximately 365.242198781 days long.) + ! + ! * There is no year zero + ! * Julian Day must be non-negative + ! * Julian Day starts at noon; while Civil Calendar date starts at midnight + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! DAT I.A. I Time array like returned by DATE_AND_TIME(3f) + ! JULIAN Double O Julian day + ! IERR Integer O Error code returned + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any subroutine/program. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER,INTENT(IN) :: DAT(8) ! array like returned by DATE_AND_TIME(3f) + DOUBLE PRECISION,INTENT(OUT) :: JULIAN ! Julian Day (non-negative, but may be non-integer) + INTEGER,INTENT(OUT) :: IERR ! Error return, 0 for successful execution + ! -1=invalid year,-2=invalid month,-3=invalid day, + ! -4=invalid date (29th Feb, non leap-year) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: YEAR, MONTH, DAY, UTC, HOUR, MINUTE + REAL :: SECOND + INTEGER :: A, Y, M, JDN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'D2J') + CALL STRACE (IENT, 'D2J') #endif -! - YEAR = DAT(1) ! Year - MONTH = DAT(2) ! Month - DAY = DAT(3) ! Day - UTC = DAT(4)*60 ! Delta from UTC, convert from minutes to seconds - HOUR = DAT(5) ! Hour - MINUTE = DAT(6) ! Minute - SECOND = DAT(7)-UTC+DAT(8)/1000.d0 ! Second ! correction for time zone and milliseconds + ! + YEAR = DAT(1) ! Year + MONTH = DAT(2) ! Month + DAY = DAT(3) ! Day + UTC = DAT(4)*60 ! Delta from UTC, convert from minutes to seconds + HOUR = DAT(5) ! Hour + MINUTE = DAT(6) ! Minute + SECOND = DAT(7)-UTC+DAT(8)/1000.d0 ! Second ! correction for time zone and milliseconds - JULIAN = -HUGE(99999) ! this is the date if an error occurs and IERR is < 0 + JULIAN = -HUGE(99999) ! this is the date if an error occurs and IERR is < 0 - IF(YEAR==0 .or. YEAR .lt. -4713) THEN + IF(YEAR==0 .or. YEAR .lt. -4713) THEN IERR=-1 RETURN - END IF + END IF -! You must compute first the number of years (Y) and months (M) since March 1st -4800 (March 1, 4801 BC) - A=(14-MONTH)/12 ! A will be 1 for January or Febuary, and 0 for other months, with integer truncation - Y=YEAR+4800-A - M=MONTH+12*A-3 ! M will be 0 for March and 11 for Febuary + ! You must compute first the number of years (Y) and months (M) since March 1st -4800 (March 1, 4801 BC) + A=(14-MONTH)/12 ! A will be 1 for January or Febuary, and 0 for other months, with integer truncation + Y=YEAR+4800-A + M=MONTH+12*A-3 ! M will be 0 for March and 11 for Febuary -! All years in the BC era must be converted to astronomical years, so that 1BC is year 0, 2 BC is year "-1", etc. -! Convert to a negative number, then increment towards zero -! Starting from a Gregorian calendar date - JDN=DAY + (153*M+2)/5 + 365*Y + Y/4 - Y/100 + Y/400 - 32045 ! with integer truncation + ! All years in the BC era must be converted to astronomical years, so that 1BC is year 0, 2 BC is year "-1", etc. + ! Convert to a negative number, then increment towards zero + ! Starting from a Gregorian calendar date + JDN=DAY + (153*M+2)/5 + 365*Y + Y/4 - Y/100 + Y/400 - 32045 ! with integer truncation -! Finding the Julian date given the JDN (Julian day number) and time of day - JULIAN=DBLE(JDN) + DBLE(HOUR-12)/24.0d0 + DBLE(MINUTE)/1440.0d0 + DBLE(SECOND)/86400.0d0 + ! Finding the Julian date given the JDN (Julian day number) and time of day + JULIAN=DBLE(JDN) + DBLE(HOUR-12)/24.0d0 + DBLE(MINUTE)/1440.0d0 + DBLE(SECOND)/86400.0d0 - ! Check if Julian Day is non-negative - IF(JULIAN.lt.0.d0) THEN - IERR=1 - ELSE - IERR=0 - END IF -! - RETURN -!/ -!/ End of D2J ----------------------------------------------------- / -!/ - END SUBROUTINE D2J + ! Check if Julian Day is non-negative + IF(JULIAN.lt.0.d0) THEN + IERR=1 + ELSE + IERR=0 + END IF + ! + RETURN + !/ + !/ End of D2J ----------------------------------------------------- / + !/ + END SUBROUTINE D2J -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / - SUBROUTINE J2D(JULIAN,DAT,IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 04-Jan-2018 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-2018 : Origination from m_time library ( version 6.04 ) -!/ -! 1. Purpose : -! -! Converts Julian Day to date array -! -! * There is no year zero -! * Julian Day must be non-negative -! * Julian Day starts at noon; while Civil Calendar date starts at midnight -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! JULIAN Double I Julian day -! DAT I.A. O Time array like returned by DATE_AND_TIME(3f) -! IERR Integer O Error code returned -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any subroutine/program. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - DOUBLE PRECISION,INTENT(IN) :: JULIAN ! Julian Day (non-negative, but may be non-integer) - INTEGER,INTENT(OUT) :: DAT(8) ! array like returned by DATE_AND_TIME(3f) - INTEGER,INTENT(OUT) :: IERR ! Error return, 0 for successful execution - ! Otherwise returnb 1 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - REAL :: SECDAY=86400.0d0 - INTEGER :: TIMEZONE(8), TZ + SUBROUTINE J2D(JULIAN,DAT,IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 04-Jan-2018 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-2018 : Origination from m_time library ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Converts Julian Day to date array + ! + ! * There is no year zero + ! * Julian Day must be non-negative + ! * Julian Day starts at noon; while Civil Calendar date starts at midnight + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! JULIAN Double I Julian day + ! DAT I.A. O Time array like returned by DATE_AND_TIME(3f) + ! IERR Integer O Error code returned + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any subroutine/program. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + DOUBLE PRECISION,INTENT(IN) :: JULIAN ! Julian Day (non-negative, but may be non-integer) + INTEGER,INTENT(OUT) :: DAT(8) ! array like returned by DATE_AND_TIME(3f) + INTEGER,INTENT(OUT) :: IERR ! Error return, 0 for successful execution + ! Otherwise returnb 1 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL :: SECDAY=86400.0d0 + INTEGER :: TIMEZONE(8), TZ - REAL :: SECOND - INTEGER :: YEAR, MONTH, DAY, HOUR, MINUTE - INTEGER :: JALPHA,JA,JB,JC,JD,JE,IJUL + REAL :: SECOND + INTEGER :: YEAR, MONTH, DAY, HOUR, MINUTE + INTEGER :: JALPHA,JA,JB,JC,JD,JE,IJUL #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'J2D') + CALL STRACE (IENT, 'J2D') #endif -! - IF(JULIAN.LT.0.d0) THEN ! Negative Julian Day not allowed + ! + IF(JULIAN.LT.0.d0) THEN ! Negative Julian Day not allowed IERR=1 RETURN - ELSE + ELSE IERR=0 - END IF + END IF - !CALL DATE_AND_TIME(values=TIMEZONE) ! Get the timezone - !TZ=TIMEZONE(4) - TZ=0 ! Force to UTC timezone + !CALL DATE_AND_TIME(values=TIMEZONE) ! Get the timezone + !TZ=TIMEZONE(4) + TZ=0 ! Force to UTC timezone - IJUL=IDINT(JULIAN) ! Integral Julian Day - SECOND=SNGL((JULIAN-DBLE(IJUL))*SECDAY) ! Seconds from beginning of Jul. Day - SECOND=SECOND+(tz*60) + IJUL=IDINT(JULIAN) ! Integral Julian Day + SECOND=SNGL((JULIAN-DBLE(IJUL))*SECDAY) ! Seconds from beginning of Jul. Day + SECOND=SECOND+(tz*60) - IF(SECOND.GE.(SECDAY/2.0d0)) THEN ! In next calendar day + IF(SECOND.GE.(SECDAY/2.0d0)) THEN ! In next calendar day IJUL=IJUL+1 SECOND=SECOND-(SECDAY/2.0d0) ! Adjust from noon to midnight - ELSE ! In same calendar day + ELSE ! In same calendar day SECOND=SECOND+(SECDAY/2.0d0) ! Adjust from noon to midnight - END IF + END IF - IF(SECOND.GE.SECDAY) THEN ! Final check to prevent time 24:00:00 + IF(SECOND.GE.SECDAY) THEN ! Final check to prevent time 24:00:00 IJUL=IJUL+1 SECOND=SECOND-SECDAY - END IF + END IF - MINUTE=INT(SECOND/60.0) ! Integral minutes from beginning of day - SECOND=SECOND-FLOAT(MINUTE*60) ! Seconds from beginning of minute - HOUR=MINUTE/60 ! Integral hours from beginning of day - MINUTE=MINUTE-HOUR*60 ! Integral minutes from beginning of hour + MINUTE=INT(SECOND/60.0) ! Integral minutes from beginning of day + SECOND=SECOND-FLOAT(MINUTE*60) ! Seconds from beginning of minute + HOUR=MINUTE/60 ! Integral hours from beginning of day + MINUTE=MINUTE-HOUR*60 ! Integral minutes from beginning of hour - !--------------------------------------------- - JALPHA=IDINT((DBLE(IJUL-1867216)-0.25d0)/36524.25d0) ! Correction for Gregorian Calendar - JA=IJUL+1+JALPHA-IDINT(0.25d0*DBLE(JALPHA)) - !--------------------------------------------- + !--------------------------------------------- + JALPHA=IDINT((DBLE(IJUL-1867216)-0.25d0)/36524.25d0) ! Correction for Gregorian Calendar + JA=IJUL+1+JALPHA-IDINT(0.25d0*DBLE(JALPHA)) + !--------------------------------------------- - JB=JA+1524 - JC=IDINT(6680.d0+(DBLE(JB-2439870)-122.1d0)/365.25d0) - JD=365*JC+IDINT(0.25d0*DBLE(JC)) - JE=IDINT(DBLE(JB-JD)/30.6001d0) - DAY=JB-JD-IDINT(30.6001d0*DBLE(JE)) - MONTH=JE-1 + JB=JA+1524 + JC=IDINT(6680.d0+(DBLE(JB-2439870)-122.1d0)/365.25d0) + JD=365*JC+IDINT(0.25d0*DBLE(JC)) + JE=IDINT(DBLE(JB-JD)/30.6001d0) + DAY=JB-JD-IDINT(30.6001d0*DBLE(JE)) + MONTH=JE-1 - IF(MONTH.GT.12) THEN + IF(MONTH.GT.12) THEN MONTH=MONTH-12 - END IF + END IF - YEAR=jc-4715 - IF(MONTH.GT.2) THEN + YEAR=jc-4715 + IF(MONTH.GT.2) THEN YEAR=YEAR-1 - END IF + END IF - IF(YEAR.LE.0) THEN + IF(YEAR.LE.0) THEN YEAR=YEAR-1 - END IF + END IF - DAT(1)=YEAR - DAT(2)=MONTH - DAT(3)=DAY - DAT(4)=TZ - DAT(5)=HOUR - DAT(6)=MINUTE - DAT(7)=INT(SECOND) - DAT(8)=INT((SECOND-INT(SECOND))*1000.0) - IERR=0 -! - RETURN -!/ -!/ End of J2D ----------------------------------------------------- / -!/ - END SUBROUTINE J2D + DAT(1)=YEAR + DAT(2)=MONTH + DAT(3)=DAY + DAT(4)=TZ + DAT(5)=HOUR + DAT(6)=MINUTE + DAT(7)=INT(SECOND) + DAT(8)=INT((SECOND-INT(SECOND))*1000.0) + IERR=0 + ! + RETURN + !/ + !/ End of J2D ----------------------------------------------------- / + !/ + END SUBROUTINE J2D -!/ ------------------------------------------------------------------- / - DOUBLE PRECISION FUNCTION TSUB ( T1, T2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 18-Jun-2020 | -!/ +-----------------------------------+ -!/ -!/ 15-May-2018 : Origination ( version 6.05 ) -!/ 18-Jun-2020 : Addition of 360-day calendar ( version 7.08 ) -!/ -! 1. Purpose : -! -! Substract two time arrays to get the time difference in days -! in a way to avoid decimal approximation error -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! T1 I.A. I Time array -! T2 I.A. I Time array -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any routine. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: T1(8), T2(8) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: A1, B1, C1, D1, A2, B2, C2, D2 - DOUBLE PRECISION :: E1, E2 + !/ ------------------------------------------------------------------- / + DOUBLE PRECISION FUNCTION TSUB ( T1, T2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 18-Jun-2020 | + !/ +-----------------------------------+ + !/ + !/ 15-May-2018 : Origination ( version 6.05 ) + !/ 18-Jun-2020 : Addition of 360-day calendar ( version 7.08 ) + !/ + ! 1. Purpose : + ! + ! Substract two time arrays to get the time difference in days + ! in a way to avoid decimal approximation error + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! T1 I.A. I Time array + ! T2 I.A. I Time array + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: T1(8), T2(8) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: A1, B1, C1, D1, A2, B2, C2, D2 + DOUBLE PRECISION :: E1, E2 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'TSUB') + CALL STRACE (IENT, 'TSUB') #endif -! -! Convert dates and times : -! - IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN - A1 = (T2(1)-T1(1))*360 + (T2(2)-T1(2))*30 + (T2(3)-T1(3)) + ! + ! Convert dates and times : + ! + IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN + A1 = (T2(1)-T1(1))*360 + (T2(2)-T1(2))*30 + (T2(3)-T1(3)) - E1 = 3600.0*T1(5) + 60.0*(T1(6)-T1(4)) + T1(7) + T1(8)/1000.0 - E2 = 3600.0*T2(5) + 60.0*(T2(6)-T2(4)) + T2(7) + T2(8)/1000.0 -! - TSUB = DBLE(A1) + (E2-E1)/86400.0d0 - ELSE - A1 = (14-T1(2))/12 - B1 = T1(1) + 4800 - A1 - C1 = T1(2) + 12*A1 - 3 - D1 = T1(3) + (153*C1 + 2)/5 + 365*B1 - IF (TRIM(CALTYPE) .EQ. 'standard' ) THEN - D1 = D1 + B1/4 -B1/100 + B1/400 - ENDIF - E1 = 3600.0*T1(5) + 60.0*(T1(6)-T1(4)) + T1(7) + T1(8)/1000.0 -! - A2 = (14-T2(2))/12 - B2 = T2(1) + 4800 - A2 - C2 = T2(2) + 12*A2 - 3 - D2 = T2(3) + (153*C2 + 2)/5 + 365*B2 - IF (TRIM(CALTYPE) .EQ. 'standard' ) THEN - D2 = D2 + B2/4 -B2/100 + B2/400 - ENDIF - E2 = 3600.0*T2(5) + 60.0*(T2(6)-T2(4)) + T2(7) + T2(8)/1000.0 -! - TSUB = DBLE(D2-D1) + (E2-E1)/86400.0d0 + E1 = 3600.0*T1(5) + 60.0*(T1(6)-T1(4)) + T1(7) + T1(8)/1000.0 + E2 = 3600.0*T2(5) + 60.0*(T2(6)-T2(4)) + T2(7) + T2(8)/1000.0 + ! + TSUB = DBLE(A1) + (E2-E1)/86400.0d0 + ELSE + A1 = (14-T1(2))/12 + B1 = T1(1) + 4800 - A1 + C1 = T1(2) + 12*A1 - 3 + D1 = T1(3) + (153*C1 + 2)/5 + 365*B1 + IF (TRIM(CALTYPE) .EQ. 'standard' ) THEN + D1 = D1 + B1/4 -B1/100 + B1/400 ENDIF -! - RETURN -!/ -!/ End of TSUB ------------------------------------------------------- / -!/ - END FUNCTION TSUB + E1 = 3600.0*T1(5) + 60.0*(T1(6)-T1(4)) + T1(7) + T1(8)/1000.0 + ! + A2 = (14-T2(2))/12 + B2 = T2(1) + 4800 - A2 + C2 = T2(2) + 12*A2 - 3 + D2 = T2(3) + (153*C2 + 2)/5 + 365*B2 + IF (TRIM(CALTYPE) .EQ. 'standard' ) THEN + D2 = D2 + B2/4 -B2/100 + B2/400 + ENDIF + E2 = 3600.0*T2(5) + 60.0*(T2(6)-T2(4)) + T2(7) + T2(8)/1000.0 + ! + TSUB = DBLE(D2-D1) + (E2-E1)/86400.0d0 + ENDIF + ! + RETURN + !/ + !/ End of TSUB ------------------------------------------------------- / + !/ + END FUNCTION TSUB -!/ ------------------------------------------------------------------- / - DOUBLE PRECISION FUNCTION TSUBSEC ( T1, T2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | C. Bunney | -!/ | FORTRAN 90 | -!/ | Last update : 18-Jun-2020 | -!/ +-----------------------------------+ -!/ -!/ 15-May-2018 : Origination (adapted from TSUB) ( version 7.12 ) -!/ -! 1. Purpose : -! -! Substract two time arrays to get the time difference in seconds. -! The milliseconds part of the array (index 8) is rounded to the -! nearest whole second. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! T1 I.A. I Time array -! T2 I.A. I Time array -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any routine. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: T1(8), T2(8) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER(KIND=8) :: A1, B1, C1, D1, A2, B2, C2, D2 - INTEGER(KIND=8) :: E1, E2 + !/ ------------------------------------------------------------------- / + DOUBLE PRECISION FUNCTION TSUBSEC ( T1, T2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | C. Bunney | + !/ | FORTRAN 90 | + !/ | Last update : 18-Jun-2020 | + !/ +-----------------------------------+ + !/ + !/ 15-May-2018 : Origination (adapted from TSUB) ( version 7.12 ) + !/ + ! 1. Purpose : + ! + ! Substract two time arrays to get the time difference in seconds. + ! The milliseconds part of the array (index 8) is rounded to the + ! nearest whole second. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! T1 I.A. I Time array + ! T2 I.A. I Time array + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: T1(8), T2(8) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER(KIND=8) :: A1, B1, C1, D1, A2, B2, C2, D2 + INTEGER(KIND=8) :: E1, E2 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'TSUBSEC') + CALL STRACE (IENT, 'TSUBSEC') #endif -! - IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN - A1 = (T2(1)-T1(1))*360 + (T2(2)-T1(2))*30 + (T2(3)-T1(3)) + ! + IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN + A1 = (T2(1)-T1(1))*360 + (T2(2)-T1(2))*30 + (T2(3)-T1(3)) - E1 = 3600.0*T1(5) + 60.0*(T1(6)-T1(4)) + T1(7) + NINT(T1(8) / 1000.0) - E2 = 3600.0*T2(5) + 60.0*(T2(6)-T2(4)) + T2(7) + NINT(T2(8) / 1000.0) -! - TSUBSEC = A1 * 86400 + (E2-E1) - ELSE - A1 = (14-T1(2))/12 - B1 = T1(1) + 4800 - A1 - C1 = T1(2) + 12*A1 - 3 - D1 = T1(3) + (153*C1 + 2)/5 + 365*B1 - IF (TRIM(CALTYPE) .EQ. 'standard' ) THEN - D1 = D1 + B1/4 -B1/100 + B1/400 - ENDIF - E1 = 3600.0*T1(5) + 60.0*(T1(6)-T1(4)) + T1(7) + NINT(T1(8) / 1000.0) -! - A2 = (14-T2(2))/12 - B2 = T2(1) + 4800 - A2 - C2 = T2(2) + 12*A2 - 3 - D2 = T2(3) + (153*C2 + 2)/5 + 365*B2 - IF (TRIM(CALTYPE) .EQ. 'standard' ) THEN - D2 = D2 + B2/4 -B2/100 + B2/400 - ENDIF - E2 = 3600.0*T2(5) + 60.0*(T2(6)-T2(4)) + T2(7) + NINT(T1(8) / 1000.0) -! - TSUBSEC = (D2-D1)*86400 + (E2-E1) + E1 = 3600.0*T1(5) + 60.0*(T1(6)-T1(4)) + T1(7) + NINT(T1(8) / 1000.0) + E2 = 3600.0*T2(5) + 60.0*(T2(6)-T2(4)) + T2(7) + NINT(T2(8) / 1000.0) + ! + TSUBSEC = A1 * 86400 + (E2-E1) + ELSE + A1 = (14-T1(2))/12 + B1 = T1(1) + 4800 - A1 + C1 = T1(2) + 12*A1 - 3 + D1 = T1(3) + (153*C1 + 2)/5 + 365*B1 + IF (TRIM(CALTYPE) .EQ. 'standard' ) THEN + D1 = D1 + B1/4 -B1/100 + B1/400 ENDIF -! - RETURN -!/ -!/ End of TSUBSEC ---------------------------------------------------- / -!/ - END FUNCTION TSUBSEC + E1 = 3600.0*T1(5) + 60.0*(T1(6)-T1(4)) + T1(7) + NINT(T1(8) / 1000.0) + ! + A2 = (14-T2(2))/12 + B2 = T2(1) + 4800 - A2 + C2 = T2(2) + 12*A2 - 3 + D2 = T2(3) + (153*C2 + 2)/5 + 365*B2 + IF (TRIM(CALTYPE) .EQ. 'standard' ) THEN + D2 = D2 + B2/4 -B2/100 + B2/400 + ENDIF + E2 = 3600.0*T2(5) + 60.0*(T2(6)-T2(4)) + T2(7) + NINT(T1(8) / 1000.0) + ! + TSUBSEC = (D2-D1)*86400 + (E2-E1) + ENDIF + ! + RETURN + !/ + !/ End of TSUBSEC ---------------------------------------------------- / + !/ + END FUNCTION TSUBSEC -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / - SUBROUTINE U2D(UNITS,DAT,IERR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ 15-May-2018 : Origination ( version 6.05 ) -!/ -! 1. Purpose : -! -! Convert time units attribute to date array -! -! * units attribute must respect convention ISO8601 -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! UNITS Char I Units attribute -! DAT I.A. O Time array like returned by DATE_AND_TIME(3f) -! IERR Integer O Error code returned -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any subroutine/program. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - CHARACTER(*),INTENT(IN) :: UNITS ! Units attribute - INTEGER,INTENT(OUT) :: DAT(8) ! array like returned by DATE_AND_TIME(3f) - INTEGER,INTENT(OUT) :: IERR ! Error return, 0 for successful execution - ! Otherwise returnb 1 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + SUBROUTINE U2D(UNITS,DAT,IERR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ 15-May-2018 : Origination ( version 6.05 ) + !/ + ! 1. Purpose : + ! + ! Convert time units attribute to date array + ! + ! * units attribute must respect convention ISO8601 + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! UNITS Char I Units attribute + ! DAT I.A. O Time array like returned by DATE_AND_TIME(3f) + ! IERR Integer O Error code returned + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any subroutine/program. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + CHARACTER(*),INTENT(IN) :: UNITS ! Units attribute + INTEGER,INTENT(OUT) :: DAT(8) ! array like returned by DATE_AND_TIME(3f) + INTEGER,INTENT(OUT) :: IERR ! Error return, 0 for successful execution + ! Otherwise returnb 1 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'U2D') + CALL STRACE (IENT, 'U2D') #endif -! + ! -DAT(4) = 0 ! force to UTC timezone -DAT(8) = 0 ! force milliseconds to 0 + DAT(4) = 0 ! force to UTC timezone + DAT(8) = 0 ! force milliseconds to 0 -! seconds - IF (INDEX(UNITS, "seconds").NE.0) THEN - ! seconds since YYYY-MM-DD hh:mm:ss - IF (INDEX(UNITS, "-", .TRUE.).EQ.22) THEN - READ(UNITS(15:18),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) - READ(UNITS(20:21),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(2) - READ(UNITS(23:24),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(3) - READ(UNITS(26:27),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(29:30),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(32:33),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) + ! seconds + IF (INDEX(UNITS, "seconds").NE.0) THEN + ! seconds since YYYY-MM-DD hh:mm:ss + IF (INDEX(UNITS, "-", .TRUE.).EQ.22) THEN + READ(UNITS(15:18),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) + READ(UNITS(20:21),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(2) + READ(UNITS(23:24),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(3) + READ(UNITS(26:27),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(29:30),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(32:33),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) ! seconds since YYYY-M-D ... - ELSE IF (INDEX(UNITS, "-", .TRUE.).EQ.21) THEN - READ(UNITS(15:18),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) - READ(UNITS(20:20),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(2) - READ(UNITS(22:22),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(3) - ! seconds since YYYY-M-D h:m:s - IF (INDEX(UNITS, ":", .FALSE.).EQ.25) THEN - READ(UNITS(24:24),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(26:26),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(28:28),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(7) + ELSE IF (INDEX(UNITS, "-", .TRUE.).EQ.21) THEN + READ(UNITS(15:18),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) + READ(UNITS(20:20),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(2) + READ(UNITS(22:22),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(3) + ! seconds since YYYY-M-D h:m:s + IF (INDEX(UNITS, ":", .FALSE.).EQ.25) THEN + READ(UNITS(24:24),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(26:26),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(28:28),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(7) ! seconds since YYYY-M-D hh:mm:ss - ELSE IF (INDEX(UNITS, ":", .FALSE.).EQ.26) THEN - READ(UNITS(24:25),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(27:28),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(30:31),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) - ELSE - GOTO 804 - END IF + ELSE IF (INDEX(UNITS, ":", .FALSE.).EQ.26) THEN + READ(UNITS(24:25),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(27:28),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(30:31),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) ELSE GOTO 804 END IF + ELSE + GOTO 804 + END IF -! days - ELSE IF (INDEX(UNITS, "days").NE.0) THEN - ! days since YYYY-MM-DD hh:mm:ss - IF (INDEX(UNITS, "-", .TRUE.).EQ.19) THEN - READ(UNITS(12:15),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) - READ(UNITS(17:18),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(2) - READ(UNITS(20:21),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(3) - READ(UNITS(23:24),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(26:27),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(29:30),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) + ! days + ELSE IF (INDEX(UNITS, "days").NE.0) THEN + ! days since YYYY-MM-DD hh:mm:ss + IF (INDEX(UNITS, "-", .TRUE.).EQ.19) THEN + READ(UNITS(12:15),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) + READ(UNITS(17:18),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(2) + READ(UNITS(20:21),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(3) + READ(UNITS(23:24),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(26:27),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(29:30),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) ! days since YYYY-M-D ... - ELSE IF (INDEX(UNITS, "-", .TRUE.).EQ.18) THEN - READ(UNITS(12:15),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) - READ(UNITS(17:17),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(2) - READ(UNITS(19:19),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(3) - ! days since YYYY-M-D h:m:s - IF (INDEX(UNITS, ":", .FALSE.).EQ.22) THEN - READ(UNITS(21:21),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(23:23),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(25:25),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(7) + ELSE IF (INDEX(UNITS, "-", .TRUE.).EQ.18) THEN + READ(UNITS(12:15),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) + READ(UNITS(17:17),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(2) + READ(UNITS(19:19),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(3) + ! days since YYYY-M-D h:m:s + IF (INDEX(UNITS, ":", .FALSE.).EQ.22) THEN + READ(UNITS(21:21),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(23:23),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(25:25),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(7) ! days since YYYY-M-D hh:mm:ss - ELSE IF (INDEX(UNITS, ":", .FALSE.).EQ.23) THEN - READ(UNITS(21:22),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(24:25),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(27:28),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) - ELSE - GOTO 804 - END IF + ELSE IF (INDEX(UNITS, ":", .FALSE.).EQ.23) THEN + READ(UNITS(21:22),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(24:25),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(27:28),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) ELSE GOTO 804 END IF + ELSE + GOTO 804 + END IF -! hours - ELSE IF (INDEX(UNITS, "hours").NE.0) THEN - ! hours since YYYY-MM-DD hh:mm:ss - IF (INDEX(UNITS, "-", .TRUE.).EQ.20) THEN - READ(UNITS(13:16),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) - READ(UNITS(18:19),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(2) - READ(UNITS(21:22),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(3) - READ(UNITS(24:25),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(27:28),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(30:31),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) + ! hours + ELSE IF (INDEX(UNITS, "hours").NE.0) THEN + ! hours since YYYY-MM-DD hh:mm:ss + IF (INDEX(UNITS, "-", .TRUE.).EQ.20) THEN + READ(UNITS(13:16),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) + READ(UNITS(18:19),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(2) + READ(UNITS(21:22),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(3) + READ(UNITS(24:25),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(27:28),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(30:31),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) ! hours since YYYY-M-D ... - ELSE IF (INDEX(UNITS, "-", .TRUE.).EQ.19) THEN - READ(UNITS(13:16),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) - READ(UNITS(18:18),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(2) - READ(UNITS(20:20),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(3) + ELSE IF (INDEX(UNITS, "-", .TRUE.).EQ.19) THEN + READ(UNITS(13:16),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) + READ(UNITS(18:18),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(2) + READ(UNITS(20:20),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(3) ! hours since YYYY-M-D h:m:s - IF (INDEX(UNITS, ":", .FALSE.).EQ.23) THEN - READ(UNITS(22:22),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(24:24),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(26:26),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(7) - ! hours since YYYY-M-D hh:mm:ss - ELSE IF (INDEX(UNITS, ":", .FALSE.).EQ.24) THEN - READ(UNITS(22:23),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(25:26),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(28:29),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) - ELSE - GOTO 804 - END IF + IF (INDEX(UNITS, ":", .FALSE.).EQ.23) THEN + READ(UNITS(22:22),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(24:24),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(26:26),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(7) + ! hours since YYYY-M-D hh:mm:ss + ELSE IF (INDEX(UNITS, ":", .FALSE.).EQ.24) THEN + READ(UNITS(22:23),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(25:26),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(28:29),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) ELSE GOTO 804 END IF + ELSE + GOTO 804 + END IF -! minutes - ELSE IF (INDEX(UNITS, "minutes").NE.0) THEN - ! minutes since YYYY-MM-DD hh:mm:ss - IF (INDEX(UNITS, "-", .TRUE.).EQ.22) THEN - READ(UNITS(15:18),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) - READ(UNITS(20:21),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(2) - READ(UNITS(23:24),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(3) - READ(UNITS(26:27),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(29:30),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(32:33),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) + ! minutes + ELSE IF (INDEX(UNITS, "minutes").NE.0) THEN + ! minutes since YYYY-MM-DD hh:mm:ss + IF (INDEX(UNITS, "-", .TRUE.).EQ.22) THEN + READ(UNITS(15:18),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) + READ(UNITS(20:21),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(2) + READ(UNITS(23:24),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(3) + READ(UNITS(26:27),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(29:30),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(32:33),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) ! minutes since YYYY-M-D ... - ELSE IF (INDEX(UNITS, "-", .TRUE.).EQ.21) THEN - READ(UNITS(15:18),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) - READ(UNITS(20:20),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(2) - READ(UNITS(22:22),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(3) + ELSE IF (INDEX(UNITS, "-", .TRUE.).EQ.21) THEN + READ(UNITS(15:18),'(I4.4)',END=804,ERR=805,IOSTAT=IERR) DAT(1) + READ(UNITS(20:20),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(2) + READ(UNITS(22:22),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(3) ! minutes since YYYY-M-D h:m:s - IF (INDEX(UNITS, ":", .FALSE.).EQ.25) THEN - READ(UNITS(24:24),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(26:26),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(28:28),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(7) - ! minutes since YYYY-M-D hh:mm:ss - ELSE IF (INDEX(UNITS, ":", .FALSE.).EQ.26) THEN - READ(UNITS(24:25),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) - READ(UNITS(27:28),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) - READ(UNITS(30:31),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) - ELSE - GOTO 804 - END IF + IF (INDEX(UNITS, ":", .FALSE.).EQ.25) THEN + READ(UNITS(24:24),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(26:26),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(28:28),'(I1.1)',END=804,ERR=805,IOSTAT=IERR) DAT(7) + ! minutes since YYYY-M-D hh:mm:ss + ELSE IF (INDEX(UNITS, ":", .FALSE.).EQ.26) THEN + READ(UNITS(24:25),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(5) + READ(UNITS(27:28),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(6) + READ(UNITS(30:31),'(I2.2)',END=804,ERR=805,IOSTAT=IERR) DAT(7) ELSE GOTO 804 END IF - -! nothing ELSE GOTO 804 END IF -! - GOTO 888 -! -! Error escape locations -! - 804 CONTINUE - WRITE (NDSE,1004) TRIM(UNITS) - CALL EXTCDE ( 44 ) -! - 805 CONTINUE - WRITE (NDSE,1005) IERR - CALL EXTCDE ( 45 ) -! - 888 CONTINUE -! -! Formats -! - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3TIMEMD : '/ & - ' PREMATURE END OF TIME ATTRIBUTE '/ & - ' ',A/ & - ' DIFFERS FROM CONVENTIONS ISO8601 '/ & - ' XXX since YYYY-MM-DD hh:mm:ss'/ & - ' XXX since YYYY-M-D h:m:s'/ & - ' XXX since YYYY-M-D hh:mm:ss'/) -! - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3TIMEMD : '/ & - ' ERROR IN READING OF TIME ATTRIBUTE '/ & - ' ',A/ & - ' DIFFERS FROM CONVENTIONS ISO8601 '/ & - ' XXX since YYYY-MM-DD hh:mm:ss'/ & - ' XXX since YYYY-M-D h:m:s'/ & - ' XXX since YYYY-M-D hh:mm:ss'/ & - ' IOSTAT =',I5/) -! - RETURN -!/ -!/ End of U2D ----------------------------------------------------- / -!/ - END SUBROUTINE U2D + ! nothing + ELSE + GOTO 804 + END IF + ! + GOTO 888 + ! + ! Error escape locations + ! +804 CONTINUE + WRITE (NDSE,1004) TRIM(UNITS) + CALL EXTCDE ( 44 ) + ! +805 CONTINUE + WRITE (NDSE,1005) IERR + CALL EXTCDE ( 45 ) + ! +888 CONTINUE + ! + ! Formats + ! +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3TIMEMD : '/ & + ' PREMATURE END OF TIME ATTRIBUTE '/ & + ' ',A/ & + ' DIFFERS FROM CONVENTIONS ISO8601 '/ & + ' XXX since YYYY-MM-DD hh:mm:ss'/ & + ' XXX since YYYY-M-D h:m:s'/ & + ' XXX since YYYY-M-D hh:mm:ss'/) + ! +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3TIMEMD : '/ & + ' ERROR IN READING OF TIME ATTRIBUTE '/ & + ' ',A/ & + ' DIFFERS FROM CONVENTIONS ISO8601 '/ & + ' XXX since YYYY-MM-DD hh:mm:ss'/ & + ' XXX since YYYY-M-D h:m:s'/ & + ' XXX since YYYY-M-D hh:mm:ss'/ & + ' IOSTAT =',I5/) + ! + RETURN + !/ + !/ End of U2D ----------------------------------------------------- / + !/ + END SUBROUTINE U2D -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / - SUBROUTINE T2ISO(TIME,ISODT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | FORTRAN 90 | -!/ | Last update : 19-Jan-2020 | -!/ +-----------------------------------+ -!/ -!/ 19-Jan-2020 : Origination ( version 7.12 ) -!/ -! 1. Purpose : -! -! Convert time array to ISO8601 format string -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! TIME I.A. I Time array like 'YYYYMMDD HHMMSS' -! ISODT Char. O ISO8601 datetime string -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any subroutine/program. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: NDSE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER,INTENT(IN) :: TIME(2) ! array like 'YYYYMMDD HHMMSS' - CHARACTER(LEN=32),INTENT(OUT) :: ISODT ! ISO date time -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ ------------------------------------------------------------------- / + + SUBROUTINE T2ISO(TIME,ISODT) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | FORTRAN 90 | + !/ | Last update : 19-Jan-2020 | + !/ +-----------------------------------+ + !/ + !/ 19-Jan-2020 : Origination ( version 7.12 ) + !/ + ! 1. Purpose : + ! + ! Convert time array to ISO8601 format string + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! TIME I.A. I Time array like 'YYYYMMDD HHMMSS' + ! ISODT Char. O ISO8601 datetime string + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any subroutine/program. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: NDSE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER,INTENT(IN) :: TIME(2) ! array like 'YYYYMMDD HHMMSS' + CHARACTER(LEN=32),INTENT(OUT) :: ISODT ! ISO date time + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'T2ISO') + CALL STRACE (IENT, 'T2ISO') #endif -! -!/ - WRITE(ISODT,'(I4,"-",I2.2,"-",I2.2,"T",I2.2,":",I2.2,":",I2.2)') & + ! + !/ + WRITE(ISODT,'(I4,"-",I2.2,"-",I2.2,"T",I2.2,":",I2.2,":",I2.2)') & TIME(1) / 10000, & MOD(TIME(1) / 100, 100), & MOD(TIME(1), 100), & TIME(2) / 10000, & MOD(TIME(2) / 100, 100), & MOD(TIME(2), 100) -!/ -!/ End of T2ISO ------------------------------------------------------ / -!/ - END SUBROUTINE T2ISO -!> Create a timestring for custom user filenames -!! @details Creates a character string of form YYYY-MM-DD-SSSSS -!! @param[in] time(2) YYYYMMDD HHMMSS -!! @param[out] user_timestring YYYY-MM-DD-SSSSS -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !/ + !/ End of T2ISO ------------------------------------------------------ / + !/ + END SUBROUTINE T2ISO + !> Create a timestring for custom user filenames + !! @details Creates a character string of form YYYY-MM-DD-SSSSS + !! @param[in] time(2) YYYYMMDD HHMMSS + !! @param[out] user_timestring YYYY-MM-DD-SSSSS + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine set_user_timestring(time, user_timestring) - integer , intent(in) :: time(2) - character(len=16), intent(out) :: user_timestring + integer , intent(in) :: time(2) + character(len=16), intent(out) :: user_timestring - ! local variables - integer :: yy,mm,dd,hh,mn,ss,totsec - yy = time(1)/10000 - mm = (time(1)-yy*10000)/100 - dd = (time(1)-yy*10000-mm*100) - hh = time(2)/10000 - mn = (time(2)-hh*10000)/100 - ss = (time(2)-hh*10000-mn*100) - totsec = hh*3600+mn*60+ss - write(user_timestring,'(i4.4,a,i2.2,a,i2.2,a,i5.5)')yy,'-',mm,'-',dd,'-',totsec + ! local variables + integer :: yy,mm,dd,hh,mn,ss,totsec + yy = time(1)/10000 + mm = (time(1)-yy*10000)/100 + dd = (time(1)-yy*10000-mm*100) + hh = time(2)/10000 + mn = (time(2)-hh*10000)/100 + ss = (time(2)-hh*10000-mn*100) + totsec = hh*3600+mn*60+ss + write(user_timestring,'(i4.4,a,i2.2,a,i2.2,a,i5.5)')yy,'-',mm,'-',dd,'-',totsec end subroutine set_user_timestring -!/ End of module W3TIMEMD -------------------------------------------- / -!/ - END MODULE W3TIMEMD + !/ End of module W3TIMEMD -------------------------------------------- / + !/ +END MODULE W3TIMEMD diff --git a/model/src/w3triamd.F90 b/model/src/w3triamd.F90 index ffec15443..ffa60a36a 100644 --- a/model/src/w3triamd.F90 +++ b/model/src/w3triamd.F90 @@ -1,535 +1,560 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3TRIAMD -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin and A. Roland | -!/ | FORTRAN 90 | -!/ | Last update : 26-Jan-2014| -!/ +-----------------------------------+ -!/ -!/ 15-Mar-2007 : Origination. ( version 3.13 ) -!/ 25-Aug-2011 : Modification of boundary treatment ( version 4.04 ) -!/ 30-Aug-2012 : Automatic detection of open BC ( version 4.08 ) -!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) -!/ 14-Oct-2013 : Correction of latitude factor ( version 4.12 ) -!/ 26-Jan-2014 : Correction interpolation weights ( version 4.18 ) -!/ 21-Apr-2016 : New algorithm to detect boundary ( version 5.12 ) -!/ -! -! 1. Purpose : -! -! Reads triangle and unstructured grid information -! -! 2. Method : -! -! Look for namelist with name NAME in unit NDS and read if found. -! -! 3. Parameters : -! -! -! 4. Subroutines used : -! -! Name Type Module Description -! ------------------------------------------------------------------------------------ -! READTRI Subr. Internal Read unstructured grid data from .grd .tri formatted files. -! READMSH Subr. Id. Read unstructured grid data from MSH format -! COUNT Subr. Internal Count connection. -! SPATIAL_GRID Subr. Id. Calculate surfaces. -! NVECTRI Subr. Id. Define cell normals and angles and edge length -! COORDMAX Subr. Id. Calculate useful grid elements -! AREA_SI Subr. Id. Define Connections -! ------------------------------------------------------------------------------------ -! -! -! 5. Called by : -! -! Program in which it is contained. -! -! 6. Error messages : -! -! 7. Remarks : -! The only point index which is needed is IX and NX stands for the total number of grid point. -! IY and NY are not needed anymore, they are set to 1 in the unstructured case -! Some noticeable arrays are: -! TRIGP : give the vertices of each triangle -! 8. Structure : -! -! 9. Switches : -! !/PR3 : Enables unstructured meshes (temporary, will be replace by Unstructured switch) -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -! USE CONSTANTS -! USE W3GDATMD, ONLY: W3NMOD, W3SETG -! USE W3ODATMD, ONLY: W3NOUT, W3SETO, W3DMO5 -! USE W3IOGRMD, ONLY: W3IOGR -! USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE -! USE W3ARRYMD, ONLY: INA2R, INA2I -! USE W3DISPMD, ONLY: DISTAB -! USE W3GDATMD -! USE W3ODATMD, ONLY: NDSE, NDST, NDSO -! USE W3ODATMD, ONLY: NBI, NBI2, NFBPO, NBO, NBO2, FLBPI, FLBPO, & -! IPBPO, ISBPO, XBPO, YBPO, RDBPO, FNMPRE -!--------------------------------------------------------------------- -! -!C -! integer :: node_num -! integer :: dim_num -! integer :: triangle_order -! integer :: triangle_num -! integer :: bound_edge_num -! integer :: bound_num -!C -! logical,save, allocatable :: edge_boundary(:) -! logical,save, allocatable :: node_boundary(:) -! integer,save, allocatable :: edge_nums(:) -! integer,save, allocatable :: boundary_node_index(:) -!C -! integer,save, allocatable :: triangle_node(:,:) -! integer,save, allocatable :: edge(:,:) -! integer,save, allocatable :: edge_index(:,:) -! integer,save, allocatable :: iobp_aux(:) - - INTEGER, SAVE :: N_OUTSIDE_BOUNDARY - INTEGER, SAVE, ALLOCATABLE :: OUTSIDE_BOUNDARY(:) - +MODULE W3TRIAMD + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin and A. Roland | + !/ | FORTRAN 90 | + !/ | Last update : 26-Jan-2014| + !/ +-----------------------------------+ + !/ + !/ 15-Mar-2007 : Origination. ( version 3.13 ) + !/ 25-Aug-2011 : Modification of boundary treatment ( version 4.04 ) + !/ 30-Aug-2012 : Automatic detection of open BC ( version 4.08 ) + !/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) + !/ 14-Oct-2013 : Correction of latitude factor ( version 4.12 ) + !/ 26-Jan-2014 : Correction interpolation weights ( version 4.18 ) + !/ 21-Apr-2016 : New algorithm to detect boundary ( version 5.12 ) + !/ + ! + ! 1. Purpose : + ! + ! Reads triangle and unstructured grid information + ! + ! 2. Method : + ! + ! Look for namelist with name NAME in unit NDS and read if found. + ! + ! 3. Parameters : + ! + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------------------------ + ! READTRI Subr. Internal Read unstructured grid data from .grd .tri formatted files. + ! READMSH Subr. Id. Read unstructured grid data from MSH format + ! COUNT Subr. Internal Count connection. + ! SPATIAL_GRID Subr. Id. Calculate surfaces. + ! NVECTRI Subr. Id. Define cell normals and angles and edge length + ! COORDMAX Subr. Id. Calculate useful grid elements + ! AREA_SI Subr. Id. Define Connections + ! ------------------------------------------------------------------------------------ + ! + ! + ! 5. Called by : + ! + ! Program in which it is contained. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! The only point index which is needed is IX and NX stands for the total number of grid point. + ! IY and NY are not needed anymore, they are set to 1 in the unstructured case + ! Some noticeable arrays are: + ! TRIGP : give the vertices of each triangle + ! 8. Structure : + ! + ! 9. Switches : + ! !/PR3 : Enables unstructured meshes (temporary, will be replace by Unstructured switch) + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + ! USE CONSTANTS + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG + ! USE W3ODATMD, ONLY: W3NOUT, W3SETO, W3DMO5 + ! USE W3IOGRMD, ONLY: W3IOGR + ! USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE + ! USE W3ARRYMD, ONLY: INA2R, INA2I + ! USE W3DISPMD, ONLY: DISTAB + ! USE W3GDATMD + ! USE W3ODATMD, ONLY: NDSE, NDST, NDSO + ! USE W3ODATMD, ONLY: NBI, NBI2, NFBPO, NBO, NBO2, FLBPI, FLBPO, & + ! IPBPO, ISBPO, XBPO, YBPO, RDBPO, FNMPRE + !--------------------------------------------------------------------- + ! + !C + ! integer :: node_num + ! integer :: dim_num + ! integer :: triangle_order + ! integer :: triangle_num + ! integer :: bound_edge_num + ! integer :: bound_num + !C + ! logical,save, allocatable :: edge_boundary(:) + ! logical,save, allocatable :: node_boundary(:) + ! integer,save, allocatable :: edge_nums(:) + ! integer,save, allocatable :: boundary_node_index(:) + !C + ! integer,save, allocatable :: triangle_node(:,:) + ! integer,save, allocatable :: edge(:,:) + ! integer,save, allocatable :: edge_index(:,:) + ! integer,save, allocatable :: iobp_aux(:) + + INTEGER, SAVE :: N_OUTSIDE_BOUNDARY + INTEGER, SAVE, ALLOCATABLE :: OUTSIDE_BOUNDARY(:) + CONTAINS -!/ -------------------------------------------------------------------/ - SUBROUTINE READMSH(NDS,FNAME) -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | A. Roland | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018| -!/ +-----------------------------------+ -!/ -!/ 15-Feb-2008 : Origination. ( version 3.13 ) -!/ 25-Aug-2011 : Change of method for IOBPD ( version 4.04 ) -!/ 06-Jun-2018 : Add DEBUGINIT/PDLIB/DEBUGSTP/DEBUGSETIOBP -!/ ( version 6.04 ) -!/ -! -! 1. Purpose : -! -! Reads triangle and unstructured grid information from GMSH files -! Calls the subroutines needed to compute grid connectivity -! -! 2. Method : -! -! Look for namelist with name NAME in unit NDS and read if found. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Data set number used for search. -! NAME C*4 I Name of namelist. -! STATUS C*20 O Status at end of routine, -! '(default values) ' if no namelist found. -! '(user def. values)' if namelist read. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ------------------------------------------------------------------------------------ -! NEXTLN Subr. -! COUNT Subr. Internal Count connection. -! SPATIAL_GRID Subr. Id. Calculate surfaces. -! NVECTRI Subr. Id. Define cell normals and angles and edge length -! COORDMAX Subr. Id. Calculate useful grid elements -! AREA_SI Subr. Id. Define Connections -! ---------------------------------------------------------------- -! -! -! -! 5. Called by : -! Name Type Module Description -! ---------------------------------------------------------------- -! W3GRID Prog. Model configuration program -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! The only point index which is needed is IX and NX stands for the total number of grid point. -! IY and NY are not needed anymore, they are set to 1 in the unstructured case -! Some noticeable arrays are: -! TRIGP : give the vertices of each triangle -! GMSH file gives too much information that is not necessarily required so data processing is needed (data sort and nesting). -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: NDSE, NDST, NDSO - USE W3GDATMD, ONLY: ZB, XGRD, YGRD, NTRI, NX, COUNTOT, TRIGP, NNZ, W3DIMUG - USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE - USE CONSTANTS, only: LPDLIB - USE W3ODATMD, ONLY: IAPROC -! - IMPLICIT NONE -!/ -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS - CHARACTER(60), INTENT(IN) :: FNAME -!/ -!/ local parameters -!/ - INTEGER :: i,j,k, NODES, NELTS, ID, KID - INTEGER :: ID1, ID2, KID1, ITMP(3) - INTEGER :: I1, I2, I3 - INTEGER(KIND=4) :: Ind,eltype,ntag, INode - CHARACTER :: COMSTR*1, SPACE*1 = ' ', CELS*64 - REAL, ALLOCATABLE :: TAGS(:) - CHARACTER(LEN=64), ALLOCATABLE :: ELS(:) - CHARACTER(LEN=120) :: LINE - CHARACTER(LEN=50) :: CHTMP - CHARACTER(LEN=10) :: A, B, C - INTEGER,ALLOCATABLE :: NELS(:), TRIGPTMP1(:,:), TRIGPTMP2(:,:) - INTEGER(KIND=4),ALLOCATABLE :: IFOUND(:), VERTEX(:), BOUNDTMP(:) - DOUBLE PRECISION, ALLOCATABLE :: XYBTMP1(:,:),XYBTMP2(:,:) - REAL :: z - - OPEN(NDS,FILE = FNAME,STATUS='old') - READ (NDS,'(A)') COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - CALL NEXTLN(COMSTR, NDS, NDSE) - READ(NDS,*) i,j,k - CALL NEXTLN(COMSTR, NDS, NDSE) - LPDLIB = .FALSE. + !/ -------------------------------------------------------------------/ + SUBROUTINE READMSH(NDS,FNAME) + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | A. Roland | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018| + !/ +-----------------------------------+ + !/ + !/ 15-Feb-2008 : Origination. ( version 3.13 ) + !/ 25-Aug-2011 : Change of method for IOBPD ( version 4.04 ) + !/ 06-Jun-2018 : Add DEBUGINIT/PDLIB/DEBUGSTP/DEBUGSETIOBP + !/ ( version 6.04 ) + !/ + ! + ! 1. Purpose : + ! + ! Reads triangle and unstructured grid information from GMSH files + ! Calls the subroutines needed to compute grid connectivity + ! + ! 2. Method : + ! + ! Look for namelist with name NAME in unit NDS and read if found. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Data set number used for search. + ! NAME C*4 I Name of namelist. + ! STATUS C*20 O Status at end of routine, + ! '(default values) ' if no namelist found. + ! '(user def. values)' if namelist read. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------------------------ + ! NEXTLN Subr. + ! COUNT Subr. Internal Count connection. + ! SPATIAL_GRID Subr. Id. Calculate surfaces. + ! NVECTRI Subr. Id. Define cell normals and angles and edge length + ! COORDMAX Subr. Id. Calculate useful grid elements + ! AREA_SI Subr. Id. Define Connections + ! ---------------------------------------------------------------- + ! + ! + ! + ! 5. Called by : + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3GRID Prog. Model configuration program + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! The only point index which is needed is IX and NX stands for the total number of grid point. + ! IY and NY are not needed anymore, they are set to 1 in the unstructured case + ! Some noticeable arrays are: + ! TRIGP : give the vertices of each triangle + ! GMSH file gives too much information that is not necessarily required so data processing is needed (data sort and nesting). + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: NDSE, NDST, NDSO + USE W3GDATMD, ONLY: ZB, XGRD, YGRD, NTRI, NX, COUNTOT, TRIGP, NNZ, W3DIMUG + USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE + USE CONSTANTS, only: LPDLIB + USE W3ODATMD, ONLY: IAPROC + ! + IMPLICIT NONE + !/ + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS + CHARACTER(60), INTENT(IN) :: FNAME + !/ + !/ local parameters + !/ + INTEGER :: i,j,k, NODES, NELTS, ID, KID + INTEGER :: ID1, ID2, KID1, ITMP(3) + INTEGER :: I1, I2, I3 + INTEGER(KIND=4) :: Ind,eltype,ntag, INode + CHARACTER :: COMSTR*1, SPACE*1 = ' ', CELS*64 + REAL, ALLOCATABLE :: TAGS(:) + CHARACTER(LEN=64), ALLOCATABLE :: ELS(:) + CHARACTER(LEN=120) :: LINE + CHARACTER(LEN=50) :: CHTMP + CHARACTER(LEN=10) :: A, B, C + INTEGER,ALLOCATABLE :: NELS(:), TRIGPTMP1(:,:), TRIGPTMP2(:,:) + INTEGER(KIND=4),ALLOCATABLE :: IFOUND(:), VERTEX(:), BOUNDTMP(:) + DOUBLE PRECISION, ALLOCATABLE :: XYBTMP1(:,:),XYBTMP2(:,:) + REAL :: z + + OPEN(NDS,FILE = FNAME,STATUS='old') + READ (NDS,'(A)') COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + CALL NEXTLN(COMSTR, NDS, NDSE) + READ(NDS,*) i,j,k + CALL NEXTLN(COMSTR, NDS, NDSE) + LPDLIB = .FALSE. #ifdef W3_PDLIB - LPDLIB = .TRUE. + LPDLIB = .TRUE. #endif -! -! read number of nodes and nodes from Gmsh files -! - READ(NDS,*) NODES - ALLOCATE(XYBTMP1(3,NODES)) - DO I= 1, NODES - READ(NDS,*) j, XYBTMP1(1,I), XYBTMP1(2,I), XYBTMP1(3,I) - END DO -! -! read number of elements and elements from Gmsh files -! - ALLOCATE(BOUNDTMP(NODES)) - N_OUTSIDE_BOUNDARY = 0 - CALL NEXTLN(COMSTR, NDS, NDSE) - READ(NDS,*) NELTS - ALLOCATE(TRIGPTMP1(3,NELTS)) - J = 0 - DO I= 1, NELTS - READ(NDS,'(A100)') LINE - READ(LINE,*) Ind,eltype,ntag - ALLOCATE(TAGS(ntag)) - SELECT CASE (eltype) -! -! eltype = 15 : boundary points (this is used to make the difference -! between the outside polygon and islands) -! - CASE(15) - READ(LINE,*) Ind,eltype,ntag,TAGS,INODE - N_OUTSIDE_BOUNDARY = N_OUTSIDE_BOUNDARY +1 - BOUNDTMP(N_OUTSIDE_BOUNDARY)=INODE -! -! eltype = 2 : triangles -! - CASE (2) - J = J + 1 - READ(LINE,*) Ind,eltype,ntag,tags,ITMP - TRIGPTMP1(1:3,J) = ITMP - END SELECT + ! + ! read number of nodes and nodes from Gmsh files + ! + READ(NDS,*) NODES + ALLOCATE(XYBTMP1(3,NODES)) + DO I= 1, NODES + READ(NDS,*) j, XYBTMP1(1,I), XYBTMP1(2,I), XYBTMP1(3,I) + END DO + ! + ! read number of elements and elements from Gmsh files + ! + ALLOCATE(BOUNDTMP(NODES)) + N_OUTSIDE_BOUNDARY = 0 + CALL NEXTLN(COMSTR, NDS, NDSE) + READ(NDS,*) NELTS + ALLOCATE(TRIGPTMP1(3,NELTS)) + J = 0 + DO I= 1, NELTS + READ(NDS,'(A100)') LINE + READ(LINE,*) Ind,eltype,ntag + ALLOCATE(TAGS(ntag)) + SELECT CASE (eltype) + ! + ! eltype = 15 : boundary points (this is used to make the difference + ! between the outside polygon and islands) + ! + CASE(15) + READ(LINE,*) Ind,eltype,ntag,TAGS,INODE + N_OUTSIDE_BOUNDARY = N_OUTSIDE_BOUNDARY +1 + BOUNDTMP(N_OUTSIDE_BOUNDARY)=INODE + ! + ! eltype = 2 : triangles + ! + CASE (2) + J = J + 1 + READ(LINE,*) Ind,eltype,ntag,tags,ITMP + TRIGPTMP1(1:3,J) = ITMP + END SELECT + + DEALLOCATE(TAGS) + END DO + ! + ! organizes the grid data structure + ! + ALLOCATE(OUTSIDE_BOUNDARY(N_OUTSIDE_BOUNDARY)) + OUTSIDE_BOUNDARY(:) = BOUNDTMP(1:N_OUTSIDE_BOUNDARY) + NTRI = J + + ALLOCATE(IFOUND(NODES)) + + IFOUND = 0 + ! + ! Verifies that the nodes are used in at least one triangle + ! + DO K = 1, NTRI + I1 = TRIGPTMP1(1,K) + I2 = TRIGPTMP1(2,K) + I3 = TRIGPTMP1(3,K) + + IFOUND(I1)= IFOUND(I1) + 1 + IFOUND(I2)= IFOUND(I2) + 1 + IFOUND(I3)= IFOUND(I3) + 1 + END DO - DEALLOCATE(TAGS) - END DO -! -! organizes the grid data structure -! - ALLOCATE(OUTSIDE_BOUNDARY(N_OUTSIDE_BOUNDARY)) - OUTSIDE_BOUNDARY(:) = BOUNDTMP(1:N_OUTSIDE_BOUNDARY) - NTRI = J - - ALLOCATE(IFOUND(NODES)) - - IFOUND = 0 -! -! Verifies that the nodes are used in at least one triangle -! - DO K = 1, NTRI - I1 = TRIGPTMP1(1,K) - I2 = TRIGPTMP1(2,K) - I3 = TRIGPTMP1(3,K) - - IFOUND(I1)= IFOUND(I1) + 1 - IFOUND(I2)= IFOUND(I2) + 1 - IFOUND(I3)= IFOUND(I3) + 1 - END DO - - J = 0 - - ALLOCATE(TRIGPTMP2(3,NTRI),VERTEX(NODES),XYBTMP2(3,NODES)) - VERTEX(:)=0 - XYBTMP2 = 0 - - DO I = 1, NODES - IF( IFOUND(I) .GT. 0) THEN - J = J+1 - XYBTMP2(:,J) = XYBTMP1(:,I) - VERTEX(I) = J - END IF - END DO -! -! Number of nodes after clean up -! - NX = J -! - DO I = 1, NTRI - I1 = TRIGPTMP1(1,I) - I2 = TRIGPTMP1(2,I) - I3 = TRIGPTMP1(3,I) - TRIGPTMP2(1,I) = VERTEX(I1) - TRIGPTMP2(2,I) = VERTEX(I2) - TRIGPTMP2(3,I) = VERTEX(I3) - END DO -! - DEALLOCATE(XYBTMP1,IFOUND,TRIGPTMP1) - DEALLOCATE(VERTEX) -! -!count points connections to allocate array in W3DIMUG -! - CALL COUNT(TRIGPTMP2) - CALL W3DIMUG ( 1, NTRI, NX, COUNTOT, NNZ, NDSE, NDST ) -! -! fills arrays -! - DO I = 1, NX - XGRD(1,I) = XYBTMP2(1,I) - YGRD(1,I) = XYBTMP2(2,I) - ZB(I) = XYBTMP2(3,I) - END DO -! - DO I=1, NTRI - ITMP = TRIGPTMP2(:,I) - TRIGP(:,I) = ITMP - END DO -! - DEALLOCATE(TRIGPTMP2,XYBTMP2) -! -! call the various routines which define the point spotting strategy -! - CALL SPATIAL_GRID - CALL NVECTRI - CALL COORDMAX + J = 0 + + ALLOCATE(TRIGPTMP2(3,NTRI),VERTEX(NODES),XYBTMP2(3,NODES)) + VERTEX(:)=0 + XYBTMP2 = 0 + + DO I = 1, NODES + IF( IFOUND(I) .GT. 0) THEN + J = J+1 + XYBTMP2(:,J) = XYBTMP1(:,I) + VERTEX(I) = J + END IF + END DO + ! + ! Number of nodes after clean up + ! + NX = J + ! + DO I = 1, NTRI + I1 = TRIGPTMP1(1,I) + I2 = TRIGPTMP1(2,I) + I3 = TRIGPTMP1(3,I) + TRIGPTMP2(1,I) = VERTEX(I1) + TRIGPTMP2(2,I) = VERTEX(I2) + TRIGPTMP2(3,I) = VERTEX(I3) + END DO + ! + DEALLOCATE(XYBTMP1,IFOUND,TRIGPTMP1) + DEALLOCATE(VERTEX) + ! + !count points connections to allocate array in W3DIMUG + ! + CALL COUNT(TRIGPTMP2) + CALL W3DIMUG ( 1, NTRI, NX, COUNTOT, NNZ, NDSE, NDST ) + ! + ! fills arrays + ! + DO I = 1, NX + XGRD(1,I) = XYBTMP2(1,I) + YGRD(1,I) = XYBTMP2(2,I) + ZB(I) = XYBTMP2(3,I) + END DO + ! + DO I=1, NTRI + ITMP = TRIGPTMP2(:,I) + TRIGP(:,I) = ITMP + END DO + ! + DEALLOCATE(TRIGPTMP2,XYBTMP2) + ! + ! call the various routines which define the point spotting strategy + ! + CALL SPATIAL_GRID + CALL NVECTRI + CALL COORDMAX #ifdef W3_PDLIB - IF(.false.) THEN + IF(.false.) THEN #endif - CALL AREA_SI(1) + CALL AREA_SI(1) #ifdef W3_PDLIB - ENDIF + ENDIF #endif -! - CLOSE(NDS) - END SUBROUTINE READMSH -!/--------------------------------------------------------------------/ - SUBROUTINE READMSH_IOBP(NDS,FNAME) -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Roland | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018| -!/ +-----------------------------------+ -!/ -!/ 15-Feb-2008 : Origination. ( version 3.13 ) -!/ 25-Aug-2011 : Change of method for IOBPD ( version 4.04 ) -!/ 06-Jun-2018 : Add DEBUGINIT/PDLIB/DEBUGSTP/DEBUGSETIOBP -!/ ( version 6.04 ) -!/ -! -! 1. Purpose : -! -! Reads triangle and unstructured grid information from GMSH files -! Calls the subroutines needed to compute grid connectivity -! -! 2. Method : -! -! Look for namelist with name NAME in unit NDS and read if found. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Data set number used for search. -! NAME C*4 I Name of namelist. -! STATUS C*20 O Status at end of routine, -! '(default values) ' if no namelist found. -! '(user def. values)' if namelist read. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ------------------------------------------------------------------------------------ -! NEXTLN Subr. -! COUNT Subr. Internal Count connection. -! SPATIAL_GRID Subr. Id. Calculate surfaces. -! NVECTRI Subr. Id. Define cell normals and angles and edge length -! COORDMAX Subr. Id. Calculate useful grid elements -! AREA_SI Subr. Id. Define Connections -! ---------------------------------------------------------------- -! -! -! -! 5. Called by : -! Name Type Module Description -! ---------------------------------------------------------------- -! W3GRID Prog. Model configuration program -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! The only point index which is needed is IX and NX stands for the total number of grid point. -! IY and NY are not needed anymore, they are set to 1 in the unstructured case -! Some noticeable arrays are: -! TRIGP : give the vertices of each triangle -! GMSH file gives too much information that is not necessarily required so data processing is needed (data sort and nesting). -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3ODATMD, ONLY: NDSE, NDST, NDSO - USE W3GDATMD - USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE - USE CONSTANTS, only: LPDLIB - USE W3ODATMD, ONLY: IAPROC -! - IMPLICIT NONE -!/ -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS - CHARACTER(60), INTENT(IN) :: FNAME -!/ -!/ local parameters -!/ - INTEGER :: i,j,k, NODES - LOGICAL :: lfile_exists - CHARACTER :: COMSTR*1, SPACE*1 = ' ', CELS*64 - DOUBLE PRECISION, ALLOCATABLE :: XYBTMP1(:,:) - - INQUIRE(FILE=FNAME, EXIST=lfile_exists) - IF (.NOT. lfile_exists) RETURN - OPEN(NDS,FILE = FNAME,STATUS='old') - READ (NDS,'(A)') COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - CALL NEXTLN(COMSTR, NDS, NDSE) - READ(NDS,*) i,j,k - CALL NEXTLN(COMSTR, NDS, NDSE) -! -! read number of nodes and nodes from Gmsh files -! - READ(NDS,*) NODES - ALLOCATE(XYBTMP1(3,NODES)) - DO I= 1, NODES - READ(NDS,*) j, XYBTMP1(1,I), XYBTMP1(2,I), XYBTMP1(3,I) - IF (INT(XYBTMP1(3,I)) .EQ. 3) IOBP(I) = 3 - END DO -! - CLOSE(NDS) - END SUBROUTINE READMSH_IOBP -!/--------------------------------------------------------------------/ - SUBROUTINE GET_BOUNDARY_STATUS(STATUS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : boundary status (code duplication) -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! + CLOSE(NDS) + END SUBROUTINE READMSH + !/--------------------------------------------------------------------/ + SUBROUTINE READMSH_IOBP(NDS,FNAME) + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Roland | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018| + !/ +-----------------------------------+ + !/ + !/ 15-Feb-2008 : Origination. ( version 3.13 ) + !/ 25-Aug-2011 : Change of method for IOBPD ( version 4.04 ) + !/ 06-Jun-2018 : Add DEBUGINIT/PDLIB/DEBUGSTP/DEBUGSETIOBP + !/ ( version 6.04 ) + !/ + ! + ! 1. Purpose : + ! + ! Reads triangle and unstructured grid information from GMSH files + ! Calls the subroutines needed to compute grid connectivity + ! + ! 2. Method : + ! + ! Look for namelist with name NAME in unit NDS and read if found. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Data set number used for search. + ! NAME C*4 I Name of namelist. + ! STATUS C*20 O Status at end of routine, + ! '(default values) ' if no namelist found. + ! '(user def. values)' if namelist read. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ------------------------------------------------------------------------------------ + ! NEXTLN Subr. + ! COUNT Subr. Internal Count connection. + ! SPATIAL_GRID Subr. Id. Calculate surfaces. + ! NVECTRI Subr. Id. Define cell normals and angles and edge length + ! COORDMAX Subr. Id. Calculate useful grid elements + ! AREA_SI Subr. Id. Define Connections + ! ---------------------------------------------------------------- + ! + ! + ! + ! 5. Called by : + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3GRID Prog. Model configuration program + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! The only point index which is needed is IX and NX stands for the total number of grid point. + ! IY and NY are not needed anymore, they are set to 1 in the unstructured case + ! Some noticeable arrays are: + ! TRIGP : give the vertices of each triangle + ! GMSH file gives too much information that is not necessarily required so data processing is needed (data sort and nesting). + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3ODATMD, ONLY: NDSE, NDST, NDSO + USE W3GDATMD + USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE + USE CONSTANTS, only: LPDLIB + USE W3ODATMD, ONLY: IAPROC + ! + IMPLICIT NONE + !/ + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS + CHARACTER(60), INTENT(IN) :: FNAME + !/ + !/ local parameters + !/ + INTEGER :: i,j,k, NODES + LOGICAL :: lfile_exists + CHARACTER :: COMSTR*1, SPACE*1 = ' ', CELS*64 + DOUBLE PRECISION, ALLOCATABLE :: XYBTMP1(:,:) + + INQUIRE(FILE=FNAME, EXIST=lfile_exists) + IF (.NOT. lfile_exists) RETURN + OPEN(NDS,FILE = FNAME,STATUS='old') + READ (NDS,'(A)') COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + CALL NEXTLN(COMSTR, NDS, NDSE) + READ(NDS,*) i,j,k + CALL NEXTLN(COMSTR, NDS, NDSE) + ! + ! read number of nodes and nodes from Gmsh files + ! + READ(NDS,*) NODES + ALLOCATE(XYBTMP1(3,NODES)) + DO I= 1, NODES + READ(NDS,*) j, XYBTMP1(1,I), XYBTMP1(2,I), XYBTMP1(3,I) + IF (INT(XYBTMP1(3,I)) .EQ. 3) IOBP(I) = 3 + END DO + ! + CLOSE(NDS) + END SUBROUTINE READMSH_IOBP + !/--------------------------------------------------------------------/ + SUBROUTINE GET_BOUNDARY_STATUS(STATUS) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : boundary status (code duplication) + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! #ifdef W3_PDLIB - use yowElementpool, only: ne_global - use yowNodepool, only: np_global + use yowElementpool, only: ne_global + use yowNodepool, only: np_global #endif - USE W3GDATMD, ONLY : TRIGP, NTRI, NX - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + USE W3GDATMD, ONLY : TRIGP, NTRI, NX + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -! - integer*2, intent(out) :: STATUS(NX) - INTEGER :: COLLECTED(NX), NEXTVERT(NX), PREVVERT(NX) - INTEGER :: ISFINISHED, INEXT, IPREV - INTEGER :: IPNEXT, IPPREV, ZNEXT, IP, I, IE + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + integer*2, intent(out) :: STATUS(NX) + INTEGER :: COLLECTED(NX), NEXTVERT(NX), PREVVERT(NX) + INTEGER :: ISFINISHED, INEXT, IPREV + INTEGER :: IPNEXT, IPPREV, ZNEXT, IP, I, IE #ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') + CALL STRACE (IENT, 'VA_SETUP_IOBPD') #endif - STATUS(:) = 0 + STATUS(:) = 0 + DO IE=1,NTRI + DO I=1,3 + IF (I.EQ.1) THEN + IPREV=3 + ELSE + IPREV=I-1 + END IF + IF (I.EQ.3) THEN + INEXT=1 + ELSE + INEXT=I+1 + END IF + IP=TRIGP(I,IE) + IPNEXT=TRIGP(INEXT,IE) + IPPREV=TRIGP(IPREV,IE) + IF (STATUS(IP).EQ.0) THEN + STATUS(IP)=1 + PREVVERT(IP)=IPPREV + NEXTVERT(IP)=IPNEXT + END IF + END DO + END DO + STATUS(:)=0 + DO + COLLECTED(:)=0 DO IE=1,NTRI DO I=1,3 IF (I.EQ.1) THEN @@ -545,1489 +570,1464 @@ SUBROUTINE GET_BOUNDARY_STATUS(STATUS) IP=TRIGP(I,IE) IPNEXT=TRIGP(INEXT,IE) IPPREV=TRIGP(IPREV,IE) - IF (STATUS(IP).EQ.0) THEN - STATUS(IP)=1 - PREVVERT(IP)=IPPREV - NEXTVERT(IP)=IPNEXT - END IF - END DO - END DO - STATUS(:)=0 - DO - COLLECTED(:)=0 - DO IE=1,NTRI - DO I=1,3 - IF (I.EQ.1) THEN - IPREV=3 - ELSE - IPREV=I-1 - END IF - IF (I.EQ.3) THEN - INEXT=1 - ELSE - INEXT=I+1 - END IF - IP=TRIGP(I,IE) - IPNEXT=TRIGP(INEXT,IE) - IPPREV=TRIGP(IPREV,IE) - IF (STATUS(IP).eq.0) THEN - ZNEXT=NEXTVERT(IP) - IF (ZNEXT.eq.IPPREV) THEN - COLLECTED(IP)=1 - NEXTVERT(IP)=IPNEXT - IF (NEXTVERT(IP).eq.PREVVERT(IP)) THEN - STATUS(IP)=1 - END IF + IF (STATUS(IP).eq.0) THEN + ZNEXT=NEXTVERT(IP) + IF (ZNEXT.eq.IPPREV) THEN + COLLECTED(IP)=1 + NEXTVERT(IP)=IPNEXT + IF (NEXTVERT(IP).eq.PREVVERT(IP)) THEN + STATUS(IP)=1 END IF END IF - END DO - END DO - ISFINISHED=1 - DO IP=1,NX - IF ((COLLECTED(IP).eq.0).and.(STATUS(IP).eq.0)) THEN - STATUS(IP)=-1 - END IF - IF (STATUS(IP).eq.0) THEN - ISFINISHED=0 END IF END DO - IF (ISFINISHED.eq.1) THEN - EXIT + END DO + ISFINISHED=1 + DO IP=1,NX + IF ((COLLECTED(IP).eq.0).and.(STATUS(IP).eq.0)) THEN + STATUS(IP)=-1 + END IF + IF (STATUS(IP).eq.0) THEN + ISFINISHED=0 END IF END DO + IF (ISFINISHED.eq.1) THEN + EXIT + END IF + END DO END SUBROUTINE GET_BOUNDARY_STATUS -!/ -------------------------------------------------------------------/ - SUBROUTINE READMSHOBC(NDS, FNAME, TMPSTA, UGOBCOK) -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 14-Mar-2018| -!/ +-----------------------------------+ -!/ -!/ 14-Mar-2018 : Origination. ( version 6.02 ) -!/ -! -! 1. Purpose : -! -! Reads open boundary information for UNST grids following GMESH type format -! -! 2. Method : -! -! Reads an ASCII file -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Data set number used for search. -! FNAME Char*60 I File name -! TMPSTA Char*60 I/O status map to be updated (for OBC, TMPSTA = 2) -! UGOBCOK Logical O flag for proper reading of OBC file -! ---------------------------------------------------------------- -! -! 4. Subroutines used : NONE -! -! 5. Called by : -! Name Type Module Description -! ---------------------------------------------------------------- -! W3GRID Prog. Model configuration program -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NX, NY, CCON , COUNTCON - USE W3ODATMD, ONLY: NDSE, NDST, NDSO - USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE + !/ -------------------------------------------------------------------/ + SUBROUTINE READMSHOBC(NDS, FNAME, TMPSTA, UGOBCOK) + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 14-Mar-2018| + !/ +-----------------------------------+ + !/ + !/ 14-Mar-2018 : Origination. ( version 6.02 ) + !/ + ! + ! 1. Purpose : + ! + ! Reads open boundary information for UNST grids following GMESH type format + ! + ! 2. Method : + ! + ! Reads an ASCII file + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Data set number used for search. + ! FNAME Char*60 I File name + ! TMPSTA Char*60 I/O status map to be updated (for OBC, TMPSTA = 2) + ! UGOBCOK Logical O flag for proper reading of OBC file + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : NONE + ! + ! 5. Called by : + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3GRID Prog. Model configuration program + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NX, NY, CCON , COUNTCON + USE W3ODATMD, ONLY: NDSE, NDST, NDSO + USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS - CHARACTER(60), INTENT(IN) :: FNAME - INTEGER, INTENT(INOUT) :: TMPSTA(NY,NX) - LOGICAL, INTENT(OUT) :: UGOBCOK -!/ -!/ local parameters -!/ - INTEGER :: I, IERR - INTEGER(KIND=4) :: Ind,ntag, INode - CHARACTER :: COMSTR*1, SPACE*1 = ' ', CELS*64 - REAL, ALLOCATABLE :: TAGS(:) - CHARACTER(LEN=120) :: LINE - - UGOBCOK=.FALSE. - - OPEN(NDS,FILE = FNAME,STATUS='old') - READ (NDS,'(A)') COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - CALL NEXTLN(COMSTR, NDS, NDSE) - IERR = 0 - DO WHILE (IERR.EQ.0) - READ (NDS,'(A100)',END=2001,ERR=2002,IOSTAT=IERR) LINE - READ(LINE,*,IOSTAT=IERR) Ind,ntag - IF (IERR.EQ.0) THEN - ALLOCATE(TAGS(ntag)) - READ(LINE,*,IOSTAT=IERR) Ind,ntag,TAGS,INODE - IF (IERR.EQ.0) THEN - TMPSTA(1,INODE)=2 - DEALLOCATE(TAGS) - ELSE - GOTO 2001 - END IF - END IF - END DO - CLOSE(NDS) - UGOBCOK=.TRUE. - RETURN -! - 2001 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 61 ) -! - 2002 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 62 ) - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN READMSHOBC : '/ & - ' PREMATURE END OF FILE IN READING ',A/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN READMSHOBC : '/ & - ' ERROR IN READING ',A,' IOSTAT =',I8/) - - END SUBROUTINE READMSHOBC -!/ ------------------------------------------------------------------- / - - -!/ ------------------------------------------------------------------- / - SUBROUTINE UG_GETOPENBOUNDARY(TMPSTA,ZBIN,ZLIM) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 30-Aug-2012| -!/ +-----------------------------------+ -!/ -!/ 30-Aug-2012 : Adpatation from SHOM-Ifremer program( version 4.07 ) -!/ -! -! 1. purpose: defines open boundary points based on depth -! 2. Method : a boundary node has more node around it than triangles -! -! -! 3. Parameters : -! TMPSTA: status map to be updated (for OBC, TMPSTA = 2) -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! w3GRID Prog. Model configuration program -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! - -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : - USE W3GDATMD, ONLY: NX, NY, CCON, COUNTCON, IOBP + + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS + CHARACTER(60), INTENT(IN) :: FNAME + INTEGER, INTENT(INOUT) :: TMPSTA(NY,NX) + LOGICAL, INTENT(OUT) :: UGOBCOK + !/ + !/ local parameters + !/ + INTEGER :: I, IERR + INTEGER(KIND=4) :: Ind,ntag, INode + CHARACTER :: COMSTR*1, SPACE*1 = ' ', CELS*64 + REAL, ALLOCATABLE :: TAGS(:) + CHARACTER(LEN=120) :: LINE + + UGOBCOK=.FALSE. + + OPEN(NDS,FILE = FNAME,STATUS='old') + READ (NDS,'(A)') COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + CALL NEXTLN(COMSTR, NDS, NDSE) + IERR = 0 + DO WHILE (IERR.EQ.0) + READ (NDS,'(A100)',END=2001,ERR=2002,IOSTAT=IERR) LINE + READ(LINE,*,IOSTAT=IERR) Ind,ntag + IF (IERR.EQ.0) THEN + ALLOCATE(TAGS(ntag)) + READ(LINE,*,IOSTAT=IERR) Ind,ntag,TAGS,INODE + IF (IERR.EQ.0) THEN + TMPSTA(1,INODE)=2 + DEALLOCATE(TAGS) + ELSE + GOTO 2001 + END IF + END IF + END DO + CLOSE(NDS) + UGOBCOK=.TRUE. + RETURN + ! +2001 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 61 ) + ! +2002 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 62 ) +1001 FORMAT (/' *** WAVEWATCH III ERROR IN READMSHOBC : '/ & + ' PREMATURE END OF FILE IN READING ',A/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN READMSHOBC : '/ & + ' ERROR IN READING ',A,' IOSTAT =',I8/) + + END SUBROUTINE READMSHOBC + !/ ------------------------------------------------------------------- / + + + !/ ------------------------------------------------------------------- / + SUBROUTINE UG_GETOPENBOUNDARY(TMPSTA,ZBIN,ZLIM) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 30-Aug-2012| + !/ +-----------------------------------+ + !/ + !/ 30-Aug-2012 : Adpatation from SHOM-Ifremer program( version 4.07 ) + !/ + ! + ! 1. purpose: defines open boundary points based on depth + ! 2. Method : a boundary node has more node around it than triangles + ! + ! + ! 3. Parameters : + ! TMPSTA: status map to be updated (for OBC, TMPSTA = 2) + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! w3GRID Prog. Model configuration program + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + USE W3GDATMD, ONLY: NX, NY, CCON, COUNTCON, IOBP #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(INOUT) :: TMPSTA(NY,NX) + + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(INOUT) :: TMPSTA(NY,NX) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL , INTENT(IN) :: ZBIN(NY,NX) - REAL , INTENT(IN) :: ZLIM -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IBC, IX - INTEGER :: MASK(NX) - INTEGER*2 :: STATUS(NX) -! - MASK(:)=1 - CALL SET_IOBP (MASK, STATUS) -! + REAL , INTENT(IN) :: ZBIN(NY,NX) + REAL , INTENT(IN) :: ZLIM + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IBC, IX + INTEGER :: MASK(NX) + INTEGER*2 :: STATUS(NX) + ! + MASK(:)=1 + CALL SET_IOBP (MASK, STATUS) + ! #ifdef W3_S - CALL STRACE (IENT, 'UG_GETOPENBOUNDARY') + CALL STRACE (IENT, 'UG_GETOPENBOUNDARY') #endif - DO IBC = 1, N_OUTSIDE_BOUNDARY - IX = OUTSIDE_BOUNDARY(IBC) - !write(*,*) 'TEST1', IX, TMPSTA(1,IX), CCON(IX), COUNTCON(IX), ZBIN(1,IX), ZLIM - ! OUTSIDE_BOUNDARY(IBC) is defined over the full nodes NODES indexes - ! whereas TMPSTA and ZBIN are defined over the clean up list of nodes NX - IF ((IX.NE.0).AND.(IX.LE.NX)) THEN - IF ( (TMPSTA(1,IX).EQ.1) .AND. (STATUS(IX).EQ.0) .AND. (ZBIN(1,IX) .LT. ZLIM)) TMPSTA(1,IX) = 2 - END IF - END DO -! - END SUBROUTINE UG_GETOPENBOUNDARY -!/ ------------------------------------------------------------------- / - - -!/---------------------------------------------------------------------- - SUBROUTINE SPATIAL_GRID -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Roland (BGS IT&E GbmH) | -!/ | F. Ardhuin (IFREMER) | -!/ | FORTRAN 90 | -!/ | Last update : 31-Aug-2011| -!/ +-----------------------------------+ -!/ -!/ 15-May-2007 : Origination: adjustment from the WWM code ( version 3.13 ) -!/ 31-Aug-2011 : Simplfies the cross products ( version 4.05 ) -!/ -! -! 1. Purpose : -! -! Calculates triangle areas and reorders the triangles to have them -! oriented counterclockwise -! -! 2. Method : -! -! The triangle surface calculation is based on cross product. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! READTRI Subr. Internal Unstructured mesh definition. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! This part of code is adapted from the WWM wave model develop at the Darmstadt University -! (Aaron Roland) -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD + DO IBC = 1, N_OUTSIDE_BOUNDARY + IX = OUTSIDE_BOUNDARY(IBC) + !write(*,*) 'TEST1', IX, TMPSTA(1,IX), CCON(IX), COUNTCON(IX), ZBIN(1,IX), ZLIM + ! OUTSIDE_BOUNDARY(IBC) is defined over the full nodes NODES indexes + ! whereas TMPSTA and ZBIN are defined over the clean up list of nodes NX + IF ((IX.NE.0).AND.(IX.LE.NX)) THEN + IF ( (TMPSTA(1,IX).EQ.1) .AND. (STATUS(IX).EQ.0) .AND. (ZBIN(1,IX) .LT. ZLIM)) TMPSTA(1,IX) = 2 + END IF + END DO + ! + END SUBROUTINE UG_GETOPENBOUNDARY + !/ ------------------------------------------------------------------- / + + + !/---------------------------------------------------------------------- + SUBROUTINE SPATIAL_GRID + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Roland (BGS IT&E GbmH) | + !/ | F. Ardhuin (IFREMER) | + !/ | FORTRAN 90 | + !/ | Last update : 31-Aug-2011| + !/ +-----------------------------------+ + !/ + !/ 15-May-2007 : Origination: adjustment from the WWM code ( version 3.13 ) + !/ 31-Aug-2011 : Simplfies the cross products ( version 4.05 ) + !/ + ! + ! 1. Purpose : + ! + ! Calculates triangle areas and reorders the triangles to have them + ! oriented counterclockwise + ! + ! 2. Method : + ! + ! The triangle surface calculation is based on cross product. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! READTRI Subr. Internal Unstructured mesh definition. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! This part of code is adapted from the WWM wave model develop at the Darmstadt University + ! (Aaron Roland) + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3ODATMD, ONLY: NDSE + USE W3ODATMD, ONLY: NDSE - IMPLICIT NONE -! -!local parameters -! - REAL :: TL1, TL2, TL3, TMPTRIGP - INTEGER :: I1, I2, I3 - INTEGER :: K - REAL*8 :: PT(3,2) + IMPLICIT NONE + ! + !local parameters + ! + REAL :: TL1, TL2, TL3, TMPTRIGP + INTEGER :: I1, I2, I3 + INTEGER :: K + REAL*8 :: PT(3,2) #ifdef W3_S - INTEGER :: IENT = 0 + INTEGER :: IENT = 0 #endif -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'SPATIAL_GRID') + CALL STRACE (IENT, 'SPATIAL_GRID') #endif - DO K = 1, NTRI - - I1 = TRIGP(1,K) - I2 = TRIGP(2,K) - I3 = TRIGP(3,K) - - CALL FIX_PERIODCITY(I1,I2,I3,XGRD,YGRD,PT) -! -! cross product of edge-vector (orientated anticlockwise) -! - - TRIA(K) = REAL( (PT(2,2)-PT(1,2)) & ! (Y2-Y1) - *(PT(1,1)-PT(3,1)) & ! *(X1-X3) - +(PT(3,2)-PT(1,2)) & ! (Y3-Y1)*(X2-X1) - *(PT(2,1)-PT(1,1)) )*0.5 -! -! test on negative triangle area, which means that the orientiation is not as assumed to be anticw. -! therefore we swap the nodes !!! -! - IF (TRIA(K) .lt. TINY(1.)) THEN - TMPTRIGP = TRIGP(2,K) - TRIGP(2,K) = TRIGP(3,K) - TRIGP(3,K) = TMPTRIGP - I2 = TRIGP(2,K) - I3 = TRIGP(3,K) - TRIA(K) = -1.d0*TRIA(K) - !WRITE(NDSE,*) 'WRONG TRIANGLE',TRIA(K),K,I1,I2,I3, XYB(I2,2)-XYB(I1,2), & - ! XYB(I1,1)-XYB(I3,1),XYB(I3,2)-XYB(I1,2), XYB(I2,1)-XYB(I1,1) - !STOP - END IF - END DO + DO K = 1, NTRI + + I1 = TRIGP(1,K) + I2 = TRIGP(2,K) + I3 = TRIGP(3,K) + + CALL FIX_PERIODCITY(I1,I2,I3,XGRD,YGRD,PT) + ! + ! cross product of edge-vector (orientated anticlockwise) + ! + + TRIA(K) = REAL( (PT(2,2)-PT(1,2)) & ! (Y2-Y1) + *(PT(1,1)-PT(3,1)) & ! *(X1-X3) + +(PT(3,2)-PT(1,2)) & ! (Y3-Y1)*(X2-X1) + *(PT(2,1)-PT(1,1)) )*0.5 + ! + ! test on negative triangle area, which means that the orientiation is not as assumed to be anticw. + ! therefore we swap the nodes !!! + ! + IF (TRIA(K) .lt. TINY(1.)) THEN + TMPTRIGP = TRIGP(2,K) + TRIGP(2,K) = TRIGP(3,K) + TRIGP(3,K) = TMPTRIGP + I2 = TRIGP(2,K) + I3 = TRIGP(3,K) + TRIA(K) = -1.d0*TRIA(K) + !WRITE(NDSE,*) 'WRONG TRIANGLE',TRIA(K),K,I1,I2,I3, XYB(I2,2)-XYB(I1,2), & + ! XYB(I1,1)-XYB(I3,1),XYB(I3,2)-XYB(I1,2), XYB(I2,1)-XYB(I1,1) + !STOP + END IF + END DO END SUBROUTINE SPATIAL_GRID -!/--------------------------------------------------------------------/ -! -!/--------------------------------------------------------------------/ - SUBROUTINE NVECTRI -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Roland | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2008| -!/ +-----------------------------------+ -!/ -!/ 15-May-2007 : Origination: adjustment from the WWM code ( version 3.13 ) -!/ -! -! 1. Purpose : -! -! Calculate cell tools: inward normal, angles and length of edges. -! -! 2. Method : -! To get inward pointing normals, triangle are glanced through anti-clockwisely -! -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! READTRI Subr. Internal Unstructured mesh definition. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/--------------------------------------------------------------------/ + ! + !/--------------------------------------------------------------------/ + SUBROUTINE NVECTRI + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Roland | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2008| + !/ +-----------------------------------+ + !/ + !/ 15-May-2007 : Origination: adjustment from the WWM code ( version 3.13 ) + !/ + ! + ! 1. Purpose : + ! + ! Calculate cell tools: inward normal, angles and length of edges. + ! + ! 2. Method : + ! To get inward pointing normals, triangle are glanced through anti-clockwisely + ! + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! READTRI Subr. Internal Unstructured mesh definition. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3GDATMD #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif USE CONSTANTS - IMPLICIT NONE -! -!local parameter -! - INTEGER :: IP, IE - INTEGER :: I1, I2, I3, I11, I22, I33 -! - REAL*8 :: P1(2), P2(2), P3(2) - REAL*8 :: R1(2), R2(2), R3(2) - REAL*8 :: N1(2), N2(2), N3(2) - REAL*8 :: TMP(3) - REAL*8 :: TMPINV(3) - REAL*8 :: PT(3,2) + IMPLICIT NONE + ! + !local parameter + ! + INTEGER :: IP, IE + INTEGER :: I1, I2, I3, I11, I22, I33 + ! + REAL*8 :: P1(2), P2(2), P3(2) + REAL*8 :: R1(2), R2(2), R3(2) + REAL*8 :: N1(2), N2(2), N3(2) + REAL*8 :: TMP(3) + REAL*8 :: TMPINV(3) + REAL*8 :: PT(3,2) #ifdef W3_S - INTEGER :: IENT = 0 + INTEGER :: IENT = 0 #endif -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'NVECTRI') + CALL STRACE (IENT, 'NVECTRI') #endif -! - DO IE = 1, NTRI -! -! vertices -! - I1 = TRIGP(1,IE) - I2 = TRIGP(2,IE) - I3 = TRIGP(3,IE) - - CALL FIX_PERIODCITY(I1,I2,I3,XGRD,YGRD,PT) - - P1(1) = PT(1,1) - P1(2) = PT(1,2) - P2(1) = PT(2,1) - P2(2) = PT(2,2) - P3(1) = PT(3,1) - P3(2) = PT(3,2) -! -! I1 -> I2, I2 -> I3, I3 -> I1 (anticlockwise orientation is preserved) -! - R1 = P3-P2 - R2 = P1-P3 - R3 = P2-P1 - - N1(1) = (-R1(2)) - N1(2) = ( R1(1)) - N2(1) = (-R2(2)) - N2(2) = ( R2(1)) - N3(1) = (-R3(2)) - N3(2) = ( R3(1)) -! -! edges length -! - LEN(IE,1) = DSQRT(R1(1)**2+R1(2)**2) - LEN(IE,2) = DSQRT(R2(1)**2+R2(2)**2) - LEN(IE,3) = DSQRT(R3(1)**2+R3(2)**2) -! -! inward normal used for propagation (not normalized) -! - IEN(IE,1) = N1(1) - IEN(IE,2) = N1(2) - IEN(IE,3) = N2(1) - IEN(IE,4) = N2(2) - IEN(IE,5) = N3(1) - IEN(IE,6) = N3(2) - - END DO + ! + DO IE = 1, NTRI + ! + ! vertices + ! + I1 = TRIGP(1,IE) + I2 = TRIGP(2,IE) + I3 = TRIGP(3,IE) + + CALL FIX_PERIODCITY(I1,I2,I3,XGRD,YGRD,PT) + + P1(1) = PT(1,1) + P1(2) = PT(1,2) + P2(1) = PT(2,1) + P2(2) = PT(2,2) + P3(1) = PT(3,1) + P3(2) = PT(3,2) + ! + ! I1 -> I2, I2 -> I3, I3 -> I1 (anticlockwise orientation is preserved) + ! + R1 = P3-P2 + R2 = P1-P3 + R3 = P2-P1 + + N1(1) = (-R1(2)) + N1(2) = ( R1(1)) + N2(1) = (-R2(2)) + N2(2) = ( R2(1)) + N3(1) = (-R3(2)) + N3(2) = ( R3(1)) + ! + ! edges length + ! + LEN(IE,1) = DSQRT(R1(1)**2+R1(2)**2) + LEN(IE,2) = DSQRT(R2(1)**2+R2(2)**2) + LEN(IE,3) = DSQRT(R3(1)**2+R3(2)**2) + ! + ! inward normal used for propagation (not normalized) + ! + IEN(IE,1) = N1(1) + IEN(IE,2) = N1(2) + IEN(IE,3) = N2(1) + IEN(IE,4) = N2(2) + IEN(IE,5) = N3(1) + IEN(IE,6) = N3(2) + + END DO END SUBROUTINE NVECTRI -!/--------------------------------------------------------------------------- - -!/------------------------------------------------------------------------ - - SUBROUTINE COUNT(TRIGPTEMP) - -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Roland | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2008| -!/ +-----------------------------------+ -!/ -!/ 15-May-2007 : Origination. ( version 3.13 ) -!/ -! -! 1. Purpose : -! -! Calculate global and maximum number of connection for array allocations . -! -! 2. Method : -! -! 3. Parameters : -! Parameter list -! ---------------------------------------------------------------- -! NTRI Int. I Total number of triangle. -! TRIGPTEMP Int I Temporary array of triangle vertices -! COUNTRI Int O Maximum number of connected triangle -! for a given points -! COUNTOT Int O Global number of triangle connection -! for the whole grid. -! ---------------------------------------------------------------- -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! READTRI Subr. Internal Unstructured mesh definition. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD + !/--------------------------------------------------------------------------- + + !/------------------------------------------------------------------------ + + SUBROUTINE COUNT(TRIGPTEMP) + + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Roland | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2008| + !/ +-----------------------------------+ + !/ + !/ 15-May-2007 : Origination. ( version 3.13 ) + !/ + ! + ! 1. Purpose : + ! + ! Calculate global and maximum number of connection for array allocations . + ! + ! 2. Method : + ! + ! 3. Parameters : + ! Parameter list + ! ---------------------------------------------------------------- + ! NTRI Int. I Total number of triangle. + ! TRIGPTEMP Int I Temporary array of triangle vertices + ! COUNTRI Int O Maximum number of connected triangle + ! for a given points + ! COUNTOT Int O Global number of triangle connection + ! for the whole grid. + ! ---------------------------------------------------------------- + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! READTRI Subr. Internal Unstructured mesh definition. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE + IMPLICIT NONE - -!/ parameter list - INTEGER,INTENT(IN) :: TRIGPTEMP(:,:) -!/ ------------------------------------------------------------------- / -!/ local parameter + !/ parameter list - INTEGER :: CONN(NX) - INTEGER :: COUNTER, IP, IE, I, J, N(3) + INTEGER,INTENT(IN) :: TRIGPTEMP(:,:) + !/ ------------------------------------------------------------------- / + !/ local parameter + + INTEGER :: CONN(NX) + INTEGER :: COUNTER, IP, IE, I, J, N(3) #ifdef W3_S - INTEGER :: IENT = 0 + INTEGER :: IENT = 0 #endif -!/------------------------------------------------------------------------ + !/------------------------------------------------------------------------ #ifdef W3_S - CALL STRACE (IENT, 'COUNT') + CALL STRACE (IENT, 'COUNT') #endif -COUNTRI=0 -COUNTOT=0 -CONN(:)= 0 - -! -!calculate the number of connected triangles for a given point. -! - -DO IE = 1,NTRI - N(:) = 0. - N(1) = TRIGPTEMP(1,IE) - N(2) = TRIGPTEMP(2,IE) - N(3) = TRIGPTEMP(3,IE) - CONN(N(1)) = CONN(N(1)) + 1 - CONN(N(2)) = CONN(N(2)) + 1 - CONN(N(3)) = CONN(N(3)) + 1 -ENDDO - - COUNTRI = MAXVAL(CONN) -! -! calculate the global number of connections available through the mesh -! -J=0 - DO IP=1,NX - DO I=1,CONN(IP) - J=J+1 - ENDDO - ENDDO - COUNTOT=J + COUNTRI=0 + COUNTOT=0 + CONN(:)= 0 + + ! + !calculate the number of connected triangles for a given point. + ! + + DO IE = 1,NTRI + N(:) = 0. + N(1) = TRIGPTEMP(1,IE) + N(2) = TRIGPTEMP(2,IE) + N(3) = TRIGPTEMP(3,IE) + CONN(N(1)) = CONN(N(1)) + 1 + CONN(N(2)) = CONN(N(2)) + 1 + CONN(N(3)) = CONN(N(3)) + 1 + ENDDO + + COUNTRI = MAXVAL(CONN) + ! + ! calculate the global number of connections available through the mesh + ! + J=0 + DO IP=1,NX + DO I=1,CONN(IP) + J=J+1 + ENDDO + ENDDO + COUNTOT=J END SUBROUTINE COUNT -!/---------------------------------------------------------------------------- - SUBROUTINE COORDMAX -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2008| -!/ +-----------------------------------+ -!/ -!/ 15-May-2007 : Origination. ( version 3.13 ) -!/ -! 1. Purpose : -! -! Calculate first point and last point coordinates, and minimum and maximum edge length. -! -! 2. Method : -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! READTRI Subr. Internal Unstructured mesh definition. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD + !/---------------------------------------------------------------------------- + SUBROUTINE COORDMAX + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2008| + !/ +-----------------------------------+ + !/ + !/ 15-May-2007 : Origination. ( version 3.13 ) + !/ + ! 1. Purpose : + ! + ! Calculate first point and last point coordinates, and minimum and maximum edge length. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! READTRI Subr. Internal Unstructured mesh definition. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE + IMPLICIT NONE #ifdef W3_S - INTEGER :: IENT = 0 + INTEGER :: IENT = 0 #endif - - + + #ifdef W3_S - CALL STRACE (IENT, 'COORDMAX') + CALL STRACE (IENT, 'COORDMAX') #endif -! -! maximum of coordinates s -! + ! + ! maximum of coordinates s + ! MAXX = MAXVAL(XGRD(1,:)) MAXY = MAXVAL(YGRD(1,:)) -! -! minimum of coordinates -! + ! + ! minimum of coordinates + ! X0 = MINVAL(XGRD(1,:)) Y0 = MINVAL(YGRD(1,:)) -! -!maximum and minimum length of edges -! + ! + !maximum and minimum length of edges + ! DXYMAX = MAXVAL(LEN(:,:)) SX = MINVAL(LEN(:,:)) SY = SX -! + ! END SUBROUTINE COORDMAX -!------------------------------------------------------------------------- + !------------------------------------------------------------------------- SUBROUTINE AREA_SI(IMOD) -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. Roland | -!/ | FORTRAN 90 | -!/ | Last update : 23-Aug-2011| -!/ +-----------------------------------+ -!/ -!/ 15-May-2007 : Origination: adjustment from the WWM code ( version 3.13 ) -!/ 23-Aug-2011 : Removes double entries in VNEIGH ( version 4.04 ) -!/ -! -! 1. Purpose : -! -! Define optimized connection arrays (points and triangles) for spatial propagation schemes. -! -! 2. Method : -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! READTRI Subr. Internal Unstructured mesh definition. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! The storage is optimize especially considering the iterative solver used. -! The schemes used are vertex-centered, a point has to be considered within its -! median dual cell. For a given point, the surface of the dual cell is one third -! of the sum of the surface of connected triangles. -! This routine is from WWM developped in Darmstadt(Aaron Roland) -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE W3GDATMD + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. Roland | + !/ | FORTRAN 90 | + !/ | Last update : 23-Aug-2011| + !/ +-----------------------------------+ + !/ + !/ 15-May-2007 : Origination: adjustment from the WWM code ( version 3.13 ) + !/ 23-Aug-2011 : Removes double entries in VNEIGH ( version 4.04 ) + !/ + ! + ! 1. Purpose : + ! + ! Define optimized connection arrays (points and triangles) for spatial propagation schemes. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! READTRI Subr. Internal Unstructured mesh definition. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! The storage is optimize especially considering the iterative solver used. + ! The schemes used are vertex-centered, a point has to be considered within its + ! median dual cell. For a given point, the surface of the dual cell is one third + ! of the sum of the surface of connected triangles. + ! This routine is from WWM developped in Darmstadt(Aaron Roland) + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE W3GDATMD #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE -!/ input + IMPLICIT NONE + !/ input - INTEGER, INTENT(IN) :: IMOD + INTEGER, INTENT(IN) :: IMOD -!/ local parameters + !/ local parameters - INTEGER :: COUNTER,ifound,alreadyfound - INTEGER :: I, J, K, II - INTEGER :: IP, IE, POS, POS_I, POS_J, POS_K, IP_I, IP_J, IP_K - INTEGER :: I1, I2, I3, IP2, CHILF(NX) - INTEGER :: TMP(NX), CELLVERTEX(NX,COUNTRI,2) - INTEGER :: COUNT_MAX - DOUBLE PRECISION :: TRIA03 - INTEGER, ALLOCATABLE :: PTABLE(:,:) + INTEGER :: COUNTER,ifound,alreadyfound + INTEGER :: I, J, K, II + INTEGER :: IP, IE, POS, POS_I, POS_J, POS_K, IP_I, IP_J, IP_K + INTEGER :: I1, I2, I3, IP2, CHILF(NX) + INTEGER :: TMP(NX), CELLVERTEX(NX,COUNTRI,2) + INTEGER :: COUNT_MAX + DOUBLE PRECISION :: TRIA03 + INTEGER, ALLOCATABLE :: PTABLE(:,:) #ifdef W3_S - INTEGER :: IENT = 0 + INTEGER :: IENT = 0 #endif -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / #ifdef W3_S - CALL STRACE (IENT, 'AREA_SI') + CALL STRACE (IENT, 'AREA_SI') #endif - WRITE(*,'("+TRACE......",A)') 'COMPUTE SI, TRIA und CCON' - - SI(:) = 0.D0 -! - CCON(:) = 0 ! Number of connected Elements - DO IE = 1, NTRI - I1 = TRIGP(1,IE) - I2 = TRIGP(2,IE) - I3 = TRIGP(3,IE) - CCON(I1) = CCON(I1) + 1 - CCON(I2) = CCON(I2) + 1 - CCON(I3) = CCON(I3) + 1 - TRIA03 = 1./3. * TRIA(IE) - SI(I1) = SI(I1) + TRIA03 - SI(I2) = SI(I2) + TRIA03 - SI(I3) = SI(I3) + TRIA03 - ENDDO - - CELLVERTEX(:,:,:) = 0 ! Stores for each node the Elementnumbers of the connected Elements - ! and the Position of the Node in the Element Index - - WRITE(*,'("+TRACE......",A)') 'COMPUTE CELLVERTEX' - - CHILF = 0 - - DO IE = 1, NTRI - DO J=1,3 - I = TRIGP(J,IE)!INE(J,IE) - CHILF(I) = CHILF(I)+1 - CELLVERTEX(I,CHILF(I),1) = IE - CELLVERTEX(I,CHILF(I),2) = J - END DO - ENDDO - - WRITE(*,'("+TRACE......",A)') 'COMPUTE IE_CELL and POS_CELL' -! -! Second step in storage, the initial 3D array CELLVERTEX, is transformed in a 1D array -! the global index is J . From now, all the computation step based on these arrays must -! abide by the conservation of the 2 loop algorithm (points + connected triangles) -! - INDEX_CELL(1)=1 - J = 0 - DO IP = 1, NX - DO I = 1, CCON(IP) - J = J + 1 - IE_CELL(J) = CELLVERTEX(IP,I,1) - POS_CELL(J) = CELLVERTEX(IP,I,2) - END DO - INDEX_CELL(IP+1)=J+1 - END DO - - IF (.NOT. FSNIMP) RETURN - - J = 0 - DO IP = 1, NX - DO I = 1, CCON(IP) - J = J + 1 - END DO - END DO - - COUNT_MAX = J - - ALLOCATE(PTABLE(COUNT_MAX,7)) - - J = 0 - PTABLE(:,:) = 0. - DO IP = 1, NX - DO I = 1, CCON(IP) - J = J + 1 - IE = IE_CELL(J) - POS = POS_CELL(J) - I1 = TRIGP(1,IE) - I2 = TRIGP(2,IE) - I3 = TRIGP(3,IE) - IF (POS == 1) THEN - POS_J = 2 - POS_K = 3 - ELSE IF (POS == 2) THEN - POS_J = 3 - POS_K = 1 - ELSE - POS_J = 1 - POS_K = 2 - END IF - IP_I = IP - IP_J = TRIGP(POS_J,IE) - IP_K = TRIGP(POS_K,IE) - PTABLE(J,1) = IP_I - PTABLE(J,2) = IP_J - PTABLE(J,3) = IP_K - PTABLE(J,4) = POS - PTABLE(J,5) = POS_J - PTABLE(J,6) = POS_K - PTABLE(J,7) = IE - END DO - END DO - -! WRITE(*,'("+TRACE......",A)') 'SET UP SPARSE MATRIX POINTER ... COUNT NONZERO ENTRY' - - J = 0 - K = 0 - DO IP = 1, NX - TMP(:) = 0 - DO I = 1, CCON(IP) - J = J + 1 - IP_J = PTABLE(J,2) - IP_K = PTABLE(J,3) - POS = PTABLE(J,4) - TMP(IP) = 1 - TMP(IP_J) = 1 - TMP(IP_K) = 1 - END DO - K = K + SUM(TMP) - END DO - - NNZ => GRIDS(IMOD)%NNZ - NNZ = K - -! WRITE(*,'("+TRACE......",A)') 'SET UP SPARSE MATRIX POINTER ... SETUP POINTER' - - ALLOCATE (GRIDS(IMOD)%JAA(NNZ)) - ALLOCATE (GRIDS(IMOD)%IAA(NX+1)) - ALLOCATE (GRIDS(IMOD)%POSI(3,COUNT_MAX)) - JAA => GRIDS(IMOD)%JAA - IAA => GRIDS(IMOD)%IAA - POSI => GRIDS(IMOD)%POSI - - J = 0 - K = 0 - IAA(1) = 1 - JAA = 0 - DO IP = 1, NX ! Run through all rows - TMP = 0 - DO I = 1, CCON(IP) ! Check how many entries there are ... - J = J + 1 ! this is the same J index as in IE_CELL - IP_J = PTABLE(J,2) - IP_K = PTABLE(J,3) - TMP(IP) = 1 - TMP(IP_J) = 1 - TMP(IP_K) = 1 - END DO - DO I = 1, NX ! Run through all columns - IF (TMP(I) .GT. 0) THEN ! this is true only for the connected points - K = K + 1 - JAA(K) = I - END IF - END DO - IAA(IP + 1) = K + 1 - END DO - - POSI = 0 - J = 0 - DO IP = 1, NX - DO I = 1, CCON(IP) - J = J + 1 - IP_J = PTABLE(J,2) - IP_K = PTABLE(J,3) - DO K = IAA(IP), IAA(IP+1) - 1 - IF (IP == JAA(K)) POSI(1,J) = K - IF (IP_J == JAA(K)) POSI(2,J) = K - IF (IP_K == JAA(K)) POSI(3,J) = K - IF (K == 0) THEN - WRITE(*,*) 'ERROR IN AREA_SI K .EQ. 0' - STOP - END IF - END DO - END DO - END DO - - DEALLOCATE(PTABLE) + WRITE(*,'("+TRACE......",A)') 'COMPUTE SI, TRIA und CCON' + + SI(:) = 0.D0 + ! + CCON(:) = 0 ! Number of connected Elements + DO IE = 1, NTRI + I1 = TRIGP(1,IE) + I2 = TRIGP(2,IE) + I3 = TRIGP(3,IE) + CCON(I1) = CCON(I1) + 1 + CCON(I2) = CCON(I2) + 1 + CCON(I3) = CCON(I3) + 1 + TRIA03 = 1./3. * TRIA(IE) + SI(I1) = SI(I1) + TRIA03 + SI(I2) = SI(I2) + TRIA03 + SI(I3) = SI(I3) + TRIA03 + ENDDO + + CELLVERTEX(:,:,:) = 0 ! Stores for each node the Elementnumbers of the connected Elements + ! and the Position of the Node in the Element Index + + WRITE(*,'("+TRACE......",A)') 'COMPUTE CELLVERTEX' + + CHILF = 0 + + DO IE = 1, NTRI + DO J=1,3 + I = TRIGP(J,IE)!INE(J,IE) + CHILF(I) = CHILF(I)+1 + CELLVERTEX(I,CHILF(I),1) = IE + CELLVERTEX(I,CHILF(I),2) = J + END DO + ENDDO + + WRITE(*,'("+TRACE......",A)') 'COMPUTE IE_CELL and POS_CELL' + ! + ! Second step in storage, the initial 3D array CELLVERTEX, is transformed in a 1D array + ! the global index is J . From now, all the computation step based on these arrays must + ! abide by the conservation of the 2 loop algorithm (points + connected triangles) + ! + INDEX_CELL(1)=1 + J = 0 + DO IP = 1, NX + DO I = 1, CCON(IP) + J = J + 1 + IE_CELL(J) = CELLVERTEX(IP,I,1) + POS_CELL(J) = CELLVERTEX(IP,I,2) + END DO + INDEX_CELL(IP+1)=J+1 + END DO + + IF (.NOT. FSNIMP) RETURN + + J = 0 + DO IP = 1, NX + DO I = 1, CCON(IP) + J = J + 1 + END DO + END DO + + COUNT_MAX = J + + ALLOCATE(PTABLE(COUNT_MAX,7)) + + J = 0 + PTABLE(:,:) = 0. + DO IP = 1, NX + DO I = 1, CCON(IP) + J = J + 1 + IE = IE_CELL(J) + POS = POS_CELL(J) + I1 = TRIGP(1,IE) + I2 = TRIGP(2,IE) + I3 = TRIGP(3,IE) + IF (POS == 1) THEN + POS_J = 2 + POS_K = 3 + ELSE IF (POS == 2) THEN + POS_J = 3 + POS_K = 1 + ELSE + POS_J = 1 + POS_K = 2 + END IF + IP_I = IP + IP_J = TRIGP(POS_J,IE) + IP_K = TRIGP(POS_K,IE) + PTABLE(J,1) = IP_I + PTABLE(J,2) = IP_J + PTABLE(J,3) = IP_K + PTABLE(J,4) = POS + PTABLE(J,5) = POS_J + PTABLE(J,6) = POS_K + PTABLE(J,7) = IE + END DO + END DO + + ! WRITE(*,'("+TRACE......",A)') 'SET UP SPARSE MATRIX POINTER ... COUNT NONZERO ENTRY' + + J = 0 + K = 0 + DO IP = 1, NX + TMP(:) = 0 + DO I = 1, CCON(IP) + J = J + 1 + IP_J = PTABLE(J,2) + IP_K = PTABLE(J,3) + POS = PTABLE(J,4) + TMP(IP) = 1 + TMP(IP_J) = 1 + TMP(IP_K) = 1 + END DO + K = K + SUM(TMP) + END DO + + NNZ => GRIDS(IMOD)%NNZ + NNZ = K + + ! WRITE(*,'("+TRACE......",A)') 'SET UP SPARSE MATRIX POINTER ... SETUP POINTER' + + ALLOCATE (GRIDS(IMOD)%JAA(NNZ)) + ALLOCATE (GRIDS(IMOD)%IAA(NX+1)) + ALLOCATE (GRIDS(IMOD)%POSI(3,COUNT_MAX)) + JAA => GRIDS(IMOD)%JAA + IAA => GRIDS(IMOD)%IAA + POSI => GRIDS(IMOD)%POSI + + J = 0 + K = 0 + IAA(1) = 1 + JAA = 0 + DO IP = 1, NX ! Run through all rows + TMP = 0 + DO I = 1, CCON(IP) ! Check how many entries there are ... + J = J + 1 ! this is the same J index as in IE_CELL + IP_J = PTABLE(J,2) + IP_K = PTABLE(J,3) + TMP(IP) = 1 + TMP(IP_J) = 1 + TMP(IP_K) = 1 + END DO + DO I = 1, NX ! Run through all columns + IF (TMP(I) .GT. 0) THEN ! this is true only for the connected points + K = K + 1 + JAA(K) = I + END IF + END DO + IAA(IP + 1) = K + 1 + END DO + + POSI = 0 + J = 0 + DO IP = 1, NX + DO I = 1, CCON(IP) + J = J + 1 + IP_J = PTABLE(J,2) + IP_K = PTABLE(J,3) + DO K = IAA(IP), IAA(IP+1) - 1 + IF (IP == JAA(K)) POSI(1,J) = K + IF (IP_J == JAA(K)) POSI(2,J) = K + IF (IP_K == JAA(K)) POSI(3,J) = K + IF (K == 0) THEN + WRITE(*,*) 'ERROR IN AREA_SI K .EQ. 0' + STOP + END IF + END DO + END DO + END DO + + DEALLOCATE(PTABLE) END SUBROUTINE AREA_SI - - SUBROUTINE IS_IN_UNGRID(IMOD, XTIN, YTIN, ITOUT, IS, JS, RW) -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Mathieu Dutour Sikiric, IRB | -!/ | Aron Roland, Z&P | -!/ | Fabrice Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 26-Jan-2014| -!/ +-----------------------------------+ -!/ -!/ Adapted from other subroutine -!/ 15-Oct-2007 : Origination. ( version 3.13 ) -!/ 21-Sep-2012 : Uses same interpolation as regular ( version 4.08 ) -!/ 26-Jan-2014 : Correcting bug in RW ( version 4.18 ) -!/ -! 1. Purpose : -! -! Determine whether a point is inside or outside an unstructured grid, -! and returns index of triangle and interpolation weights -! This is the analogue for triangles of the FUNCTION W3GRMP -! -! 2. Method : -! -! Using barycentric coordinates defined as the ratio of triangle algebric areas -! which are positive or negative. -! Computes the 3 interpolation weights for each triangle until they are all positive -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! XTIN Real I X-coordinate of target point. -! YTIN Real I Y-coordinate of target point. -! ITOUT Int. I Model number to point to. -! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. -! RW R.A. O Array of interpolation weights. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None -! -! 5. Called by : -! -! WMGLOW, W3IOPP, WMIOPP, WW3_GINT -! -! 6. Error messages : -! -! - Error checks on previous setting of variable. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -! 2. Method : -! -! Using barycentric coordinates. Each coefficient depends on the mass of its related point in the interpolation. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOPP Subr. Internal Preprocessing of point output. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! This subroutine is adjusted from CREST code (Fabrice Ardhuin) -! For a given output point, the algorithm enable to glance through all the triangles -! to find the one the point belong to, and then make interpolation. -! -! 8. Structure : -! -! 9. Switches : -! -! !/LLG Spherical grid. -! !/XYG Carthesian grid. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD - USE W3SERVMD, ONLY: EXTCDE + + SUBROUTINE IS_IN_UNGRID(IMOD, XTIN, YTIN, ITOUT, IS, JS, RW) + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Mathieu Dutour Sikiric, IRB | + !/ | Aron Roland, Z&P | + !/ | Fabrice Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 26-Jan-2014| + !/ +-----------------------------------+ + !/ + !/ Adapted from other subroutine + !/ 15-Oct-2007 : Origination. ( version 3.13 ) + !/ 21-Sep-2012 : Uses same interpolation as regular ( version 4.08 ) + !/ 26-Jan-2014 : Correcting bug in RW ( version 4.18 ) + !/ + ! 1. Purpose : + ! + ! Determine whether a point is inside or outside an unstructured grid, + ! and returns index of triangle and interpolation weights + ! This is the analogue for triangles of the FUNCTION W3GRMP + ! + ! 2. Method : + ! + ! Using barycentric coordinates defined as the ratio of triangle algebric areas + ! which are positive or negative. + ! Computes the 3 interpolation weights for each triangle until they are all positive + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! XTIN Real I X-coordinate of target point. + ! YTIN Real I Y-coordinate of target point. + ! ITOUT Int. I Model number to point to. + ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. + ! RW R.A. O Array of interpolation weights. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None + ! + ! 5. Called by : + ! + ! WMGLOW, W3IOPP, WMIOPP, WW3_GINT + ! + ! 6. Error messages : + ! + ! - Error checks on previous setting of variable. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + ! 2. Method : + ! + ! Using barycentric coordinates. Each coefficient depends on the mass of its related point in the interpolation. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOPP Subr. Internal Preprocessing of point output. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! This subroutine is adjusted from CREST code (Fabrice Ardhuin) + ! For a given output point, the algorithm enable to glance through all the triangles + ! to find the one the point belong to, and then make interpolation. + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/LLG Spherical grid. + ! !/XYG Carthesian grid. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3ODATMD, ONLY: NDSE - IMPLICIT NONE - -!/ ------------------------------------------------------------------- / -! Parameter list - - INTEGER, INTENT(IN) :: IMOD - DOUBLE PRECISION, INTENT(IN) :: XTIN, YTIN - INTEGER, INTENT(OUT) :: itout - INTEGER, INTENT(OUT) :: IS(4), JS(4) - REAL, INTENT(OUT) :: RW(4) -!/ ------------------------------------------------------------------- / -!local parameters - - DOUBLE PRECISION :: x1, x2, x3 - DOUBLE PRECISION :: y1, y2, y3 - DOUBLE PRECISION :: s1, s2, s3, sg1, sg2, sg3 - REAL*8 :: PT(3,2) - INTEGER :: ITRI - INTEGER :: I1, I2, I3 - INTEGER :: nbFound + USE W3ODATMD, ONLY: NDSE + IMPLICIT NONE + + !/ ------------------------------------------------------------------- / + ! Parameter list + + INTEGER, INTENT(IN) :: IMOD + DOUBLE PRECISION, INTENT(IN) :: XTIN, YTIN + INTEGER, INTENT(OUT) :: itout + INTEGER, INTENT(OUT) :: IS(4), JS(4) + REAL, INTENT(OUT) :: RW(4) + !/ ------------------------------------------------------------------- / + !local parameters + + DOUBLE PRECISION :: x1, x2, x3 + DOUBLE PRECISION :: y1, y2, y3 + DOUBLE PRECISION :: s1, s2, s3, sg1, sg2, sg3 + REAL*8 :: PT(3,2) + INTEGER :: ITRI + INTEGER :: I1, I2, I3 + INTEGER :: nbFound #ifdef W3_S - INTEGER :: IENT = 0 - CALL STRACE (IENT, 'IS_IN_UNGRID') + INTEGER :: IENT = 0 + CALL STRACE (IENT, 'IS_IN_UNGRID') #endif -! - itout = 0 - nbFound=0 - ITRI = 0 - DO WHILE (nbFound.EQ.0.AND.ITRI.LT.GRIDS(IMOD)%NTRI) - ITRI = ITRI +1 - I1=GRIDS(IMOD)%TRIGP(1,ITRI) - I2=GRIDS(IMOD)%TRIGP(2,ITRI) - I3=GRIDS(IMOD)%TRIGP(3,ITRI) - - CALL FIX_PERIODCITY(I1,I2,I3,GRIDS(IMOD)%XGRD,GRIDS(IMOD)%YGRD,PT) -! coordinates of the first vertex A - x1 = PT(1,1) - y1 = PT(1,2) -! coordinates of the 2nd vertex B - x2 = PT(2,1) - y2 = PT(2,2) -!coordinates of the 3rd vertex C - x3 = PT(3,1) - y3 = PT(3,2) -!with M = (XTIN,YTIN) the target point ... -!vector product of AB and AC - sg3=(y3-y1)*(x2-x1)-(x3-x1)*(y2-y1) -!vector product of AB and AM - s3=(YTIN-y1)*(x2-x1)-(XTIN-x1)*(y2-y1) -!vector product of BC and BA - sg1=(y1-y2)*(x3-x2)-(x1-x2)*(y3-y2) -!vector product of BC and BM - s1=(YTIN-y2)*(x3-x2)-(XTIN-x2)*(y3-y2) -!vector product of CA and CB - sg2=(y2-y3)*(x1-x3)-(x2-x3)*(y1-y3) -!vector product of CA and CM - s2=(YTIN-y3)*(x1-x3)-(XTIN-x3)*(y1-y3) - IF ((s1*sg1.GE.0).AND.(s2*sg2.GE.0).AND.(s3*sg3.GE.0)) THEN - itout=ITRI - nbFound=nbFound+1 - IS(1)=I1 - IS(2)=I2 - IS(3)=I3 - IS(4)=1 - JS(:)=1 - RW(1)=s1/sg1 - RW(2)=s2/sg2 - RW(3)=1.-RW(1)-RW(2) !s3/sg3 - RW(4)=0. - END IF - ENDDO - END SUBROUTINE IS_IN_UNGRID -!/ ------------------------------------------------------------------- - SUBROUTINE IS_IN_UNGRID2(IMOD, XTIN, YTIN, FORCE, ITOUT, IS, JS, RW) -!/ ------------------------------------------------------------------- -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Mathieu Dutour Sikiric, IRB | -!/ | Aron Roland, Z&P | -!/ | Fabrice Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 26-Jan-2014| -!/ +-----------------------------------+ -!/ -!/ Adapted from other subroutine -!/ 15-Oct-2007 : Origination. ( version 3.13 ) -!/ 21-Sep-2012 : Uses same interpolation as regular ( version 4.08 ) -!/ 26-Jan-2014 : Correcting bug in RW ( version 4.18 ) -!/ -! 1. Purpose : -! -! Determine whether a point is inside or outside an unstructured grid, -! and returns index of triangle and interpolation weights -! This is the analogue for triangles of the FUNCTION W3GRMP -! -! 2. Method : -! -! Using barycentric coordinates defined as the ratio of triangle algebric areas -! which are positive or negative. -! Computes the 3 interpolation weights for each triangle until they are all positive -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! XTIN Real I X-coordinate of target point. -! YTIN Real I Y-coordinate of target point. -! ITOUT Int. I Model number to point to. -! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. -! RW R.A. O Array of interpolation weights. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None -! -! 5. Called by : -! -! WMGLOW, W3IOPP, WMIOPP, WW3_GINT -! -! 6. Error messages : -! -! - Error checks on previous setting of variable. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! - - -! 2. Method : -! -! Using barycentric coordinates. Each coefficient depends on the mass of its related point in the interpolation. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOPP Subr. Internal Preprocessing of point output. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! This subroutine is adjusted from CREST code (Fabrice Ardhuin) -! For a given output point, the algorithm enable to glance through all the triangles -! to find the one the point belong to, and then make interpolation. -! -! 8. Structure : -! -! 9. Switches : -! -! !/LLG Spherical grid. -! !/XYG Carthesian grid. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD - USE W3SERVMD, ONLY: EXTCDE + ! + itout = 0 + nbFound=0 + ITRI = 0 + DO WHILE (nbFound.EQ.0.AND.ITRI.LT.GRIDS(IMOD)%NTRI) + ITRI = ITRI +1 + I1=GRIDS(IMOD)%TRIGP(1,ITRI) + I2=GRIDS(IMOD)%TRIGP(2,ITRI) + I3=GRIDS(IMOD)%TRIGP(3,ITRI) + + CALL FIX_PERIODCITY(I1,I2,I3,GRIDS(IMOD)%XGRD,GRIDS(IMOD)%YGRD,PT) + ! coordinates of the first vertex A + x1 = PT(1,1) + y1 = PT(1,2) + ! coordinates of the 2nd vertex B + x2 = PT(2,1) + y2 = PT(2,2) + !coordinates of the 3rd vertex C + x3 = PT(3,1) + y3 = PT(3,2) + !with M = (XTIN,YTIN) the target point ... + !vector product of AB and AC + sg3=(y3-y1)*(x2-x1)-(x3-x1)*(y2-y1) + !vector product of AB and AM + s3=(YTIN-y1)*(x2-x1)-(XTIN-x1)*(y2-y1) + !vector product of BC and BA + sg1=(y1-y2)*(x3-x2)-(x1-x2)*(y3-y2) + !vector product of BC and BM + s1=(YTIN-y2)*(x3-x2)-(XTIN-x2)*(y3-y2) + !vector product of CA and CB + sg2=(y2-y3)*(x1-x3)-(x2-x3)*(y1-y3) + !vector product of CA and CM + s2=(YTIN-y3)*(x1-x3)-(XTIN-x3)*(y1-y3) + IF ((s1*sg1.GE.0).AND.(s2*sg2.GE.0).AND.(s3*sg3.GE.0)) THEN + itout=ITRI + nbFound=nbFound+1 + IS(1)=I1 + IS(2)=I2 + IS(3)=I3 + IS(4)=1 + JS(:)=1 + RW(1)=s1/sg1 + RW(2)=s2/sg2 + RW(3)=1.-RW(1)-RW(2) !s3/sg3 + RW(4)=0. + END IF + ENDDO + END SUBROUTINE IS_IN_UNGRID + !/ ------------------------------------------------------------------- + SUBROUTINE IS_IN_UNGRID2(IMOD, XTIN, YTIN, FORCE, ITOUT, IS, JS, RW) + !/ ------------------------------------------------------------------- + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Mathieu Dutour Sikiric, IRB | + !/ | Aron Roland, Z&P | + !/ | Fabrice Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 26-Jan-2014| + !/ +-----------------------------------+ + !/ + !/ Adapted from other subroutine + !/ 15-Oct-2007 : Origination. ( version 3.13 ) + !/ 21-Sep-2012 : Uses same interpolation as regular ( version 4.08 ) + !/ 26-Jan-2014 : Correcting bug in RW ( version 4.18 ) + !/ + ! 1. Purpose : + ! + ! Determine whether a point is inside or outside an unstructured grid, + ! and returns index of triangle and interpolation weights + ! This is the analogue for triangles of the FUNCTION W3GRMP + ! + ! 2. Method : + ! + ! Using barycentric coordinates defined as the ratio of triangle algebric areas + ! which are positive or negative. + ! Computes the 3 interpolation weights for each triangle until they are all positive + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! XTIN Real I X-coordinate of target point. + ! YTIN Real I Y-coordinate of target point. + ! ITOUT Int. I Model number to point to. + ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. + ! RW R.A. O Array of interpolation weights. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None + ! + ! 5. Called by : + ! + ! WMGLOW, W3IOPP, WMIOPP, WW3_GINT + ! + ! 6. Error messages : + ! + ! - Error checks on previous setting of variable. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + + + ! 2. Method : + ! + ! Using barycentric coordinates. Each coefficient depends on the mass of its related point in the interpolation. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOPP Subr. Internal Preprocessing of point output. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! This subroutine is adjusted from CREST code (Fabrice Ardhuin) + ! For a given output point, the algorithm enable to glance through all the triangles + ! to find the one the point belong to, and then make interpolation. + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/LLG Spherical grid. + ! !/XYG Carthesian grid. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3ODATMD, ONLY: NDSE - IMPLICIT NONE - -!/ ------------------------------------------------------------------- / -! Parameter list - - INTEGER, INTENT(IN) :: IMOD, FORCE - DOUBLE PRECISION, INTENT(IN) :: XTIN, YTIN - INTEGER, INTENT(OUT) :: itout - INTEGER, INTENT(OUT) :: IS(4), JS(4) - REAL, INTENT(OUT) :: RW(4) -!/ ------------------------------------------------------------------- / -!local parameters - - DOUBLE PRECISION :: x1, x2, x3, D1, D2, D3, DISTMIN, DDMIN - DOUBLE PRECISION :: s1, s2, s3, sg1, sg2, sg3, smin, ssum - DOUBLE PRECISION :: y1, y2, y3 - INTEGER :: ITRI, ITRIS - INTEGER :: I1, I2, I3 - INTEGER :: nbFound - LOGICAL :: MAPSTAOK + USE W3ODATMD, ONLY: NDSE + IMPLICIT NONE + + !/ ------------------------------------------------------------------- / + ! Parameter list + + INTEGER, INTENT(IN) :: IMOD, FORCE + DOUBLE PRECISION, INTENT(IN) :: XTIN, YTIN + INTEGER, INTENT(OUT) :: itout + INTEGER, INTENT(OUT) :: IS(4), JS(4) + REAL, INTENT(OUT) :: RW(4) + !/ ------------------------------------------------------------------- / + !local parameters + + DOUBLE PRECISION :: x1, x2, x3, D1, D2, D3, DISTMIN, DDMIN + DOUBLE PRECISION :: s1, s2, s3, sg1, sg2, sg3, smin, ssum + DOUBLE PRECISION :: y1, y2, y3 + INTEGER :: ITRI, ITRIS + INTEGER :: I1, I2, I3 + INTEGER :: nbFound + LOGICAL :: MAPSTAOK #ifdef W3_S - INTEGER :: IENT = 0 - CALL STRACE (IENT, 'IS_IN_UNGRID2') + INTEGER :: IENT = 0 + CALL STRACE (IENT, 'IS_IN_UNGRID2') #endif -! - itout = 0 - nbFound=0 - ITRI = 0 - ITRIS = 1 - ssum = 0 - smin = 0 - DO WHILE (nbFound.EQ.0.AND.ITRI.LT.GRIDS(IMOD)%NTRI) - ITRI = ITRI +1 - I1=GRIDS(IMOD)%TRIGP(1,ITRI) - I2=GRIDS(IMOD)%TRIGP(2,ITRI) - I3=GRIDS(IMOD)%TRIGP(3,ITRI) -! coordinates of the first vertex A - x1=GRIDS(IMOD)%XGRD(1,I1) - y1=GRIDS(IMOD)%YGRD(1,I1) -! coordinates of the 2nd vertex B - x2=GRIDS(IMOD)%XGRD(1,I2) - y2=GRIDS(IMOD)%XGRD(1,I2) -!coordinates of the 3rd vertex C - x3=GRIDS(IMOD)%XGRD(1,I3) - y3=GRIDS(IMOD)%YGRD(1,I3) -!with M = (XTIN,YTIN) the target point ... -!vector product of AB and AC - sg3=(y3-y1)*(x2-x1)-(x3-x1)*(y2-y1) -!vector product of AB and AM - s3=(YTIN-y1)*(x2-x1)-(XTIN-x1)*(y2-y1) -!vector product of BC and BA - sg1=(y1-y2)*(x3-x2)-(x1-x2)*(y3-y2) -!vector product of BC and BM - s1=(YTIN-y2)*(x3-x2)-(XTIN-x2)*(y3-y2) -!vector product of CA and CB - sg2=(y2-y3)*(x1-x3)-(x2-x3)*(y1-y3) -!vector product of CA and CM - s2=(YTIN-y3)*(x1-x3)-(XTIN-x3)*(y1-y3) -! ssum = ABS(s1*sg1)+ABS(s2*sg2)+ABS(s3*sg3) - MAPSTAOK = ((GRIDS(IMOD)%MAPSTA(1,I1).GE.1).AND. & - (GRIDS(IMOD)%MAPSTA(1,I2).GE.1).AND.(GRIDS(IMOD)%MAPSTA(1,I3).GE.1)) - IF (FORCE.LT.2) MAPSTAOK =.TRUE. - ssum = (XTIN-(x1+x2+x3)/3.)**2+(YTIN-(y1+y2+y2)/3.)**2 - IF (smin.EQ.0.AND. MAPSTAOK ) smin=ssum - !WRITE(6,*) 'ssum',ITRI,MAPSTAOK,ssum,smin - IF (ssum.LT.smin .AND. MAPSTAOK ) THEN - smin=ssum - ITRIS=ITRI - ENDIF - IF ((s1*sg1.GE.0).AND.(s2*sg2.GE.0).AND.(s3*sg3.GE.0)) THEN - itout=ITRI - nbFound=nbFound+1 - IS(1)=I1 - IS(2)=I2 - IS(3)=I3 - IS(4)=1 - JS(:)=1 - RW(1)=s1/sg1 - RW(2)=s2/sg2 - RW(3)=1.-RW(1)-RW(2) !s3/sg3 - RW(4)=0. - END IF - ENDDO - IF (itout.EQ.0.AND.FORCE.GT.0) THEN - ITRI=ITRIS - I1=GRIDS(IMOD)%TRIGP(1,ITRI) - I2=GRIDS(IMOD)%TRIGP(2,ITRI) - I3=GRIDS(IMOD)%TRIGP(3,ITRI) -! coordinates of the first vertex A - x1=GRIDS(IMOD)%XGRD(1,I1) - y1=GRIDS(IMOD)%YGRD(1,I1) -! coordinates of the 2nd vertex B - x2=GRIDS(IMOD)%XGRD(1,I2) - y2=GRIDS(IMOD)%YGRD(1,I2) -!coordinates of the 3rd vertex C - x3=GRIDS(IMOD)%XGRD(1,I3) - y3=GRIDS(IMOD)%YGRD(1,I3) - D1=(XTIN-X1)**2+(YTIN-Y1)**2 - D2=(XTIN-X2)**2+(YTIN-Y2)**2 - D3=(XTIN-X3)**2+(YTIN-Y3)**2 - IF (D1.LE.D2.AND.D1.LE.D3) IS(1)=I1 - IF (D2.LE.D1.AND.D2.LE.D3) IS(1)=I2 - IF (D3.LE.D2.AND.D3.LE.D1) IS(1)=I3 - IS(2:4)=1 - JS(:)=1 - RW(1)=1 - RW(2:4)=0. - ITOUT=ITRI - - ENDIF - END SUBROUTINE IS_IN_UNGRID2 -!/ ------------------------------------------------------------------- / - SUBROUTINE UG_GRADIENTS (PARAM, DIFFX, DIFFY) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | A. Roland | -!/ | FORTRAN 90 | -!/ | Last update : 14-Oct-2013| -!/ +-----------------------------------+ -!/ -!/ 15-Nov-2007 : Origination. ( version 3.13 ) -!/ 31-Oct-2010 : Merging of 4.03 with 3.14-Ifremer ( version 4.04 ) -!/ 08-Nov-2011 : Correction for zero grad. on contour( version 4.04 ) -!/ 14-Oct-2013 : Correction of latitude factor ( version 4.12 ) -!/ 01-Mai-2018 : Using linear shape function for gradients [ version 6.04) -!/ -! -! 1. purpose: calculate gradients at a point via its connection. -! 2. Method : using linear shape function this is a basis on which -! all advection schemes in Roland (2008) are checked. -! -! 3. Parameters : -! PARAM : depth or current field (indices 0 to NSEA) -! DIFFX : x gradient (indices 1 to NX) -! DIFFY : y gradient (indices 1 to NX) -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. Actual wind wave routine -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! This subroutine is adjusted from WWM code (Aaron Roland) -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : - USE CONSTANTS - USE W3GDATMD, ONLY : TRIGP, NTRI, NX, NSEA, MAPFS, CLATIS, & - MAPSTA, ANGLE, FLAGLL, IOBP, IEN, TRIA, NSEAL, NTRI - USE W3ADATMD, ONLY : NSEALM + ! + itout = 0 + nbFound=0 + ITRI = 0 + ITRIS = 1 + ssum = 0 + smin = 0 + DO WHILE (nbFound.EQ.0.AND.ITRI.LT.GRIDS(IMOD)%NTRI) + ITRI = ITRI +1 + I1=GRIDS(IMOD)%TRIGP(1,ITRI) + I2=GRIDS(IMOD)%TRIGP(2,ITRI) + I3=GRIDS(IMOD)%TRIGP(3,ITRI) + ! coordinates of the first vertex A + x1=GRIDS(IMOD)%XGRD(1,I1) + y1=GRIDS(IMOD)%YGRD(1,I1) + ! coordinates of the 2nd vertex B + x2=GRIDS(IMOD)%XGRD(1,I2) + y2=GRIDS(IMOD)%XGRD(1,I2) + !coordinates of the 3rd vertex C + x3=GRIDS(IMOD)%XGRD(1,I3) + y3=GRIDS(IMOD)%YGRD(1,I3) + !with M = (XTIN,YTIN) the target point ... + !vector product of AB and AC + sg3=(y3-y1)*(x2-x1)-(x3-x1)*(y2-y1) + !vector product of AB and AM + s3=(YTIN-y1)*(x2-x1)-(XTIN-x1)*(y2-y1) + !vector product of BC and BA + sg1=(y1-y2)*(x3-x2)-(x1-x2)*(y3-y2) + !vector product of BC and BM + s1=(YTIN-y2)*(x3-x2)-(XTIN-x2)*(y3-y2) + !vector product of CA and CB + sg2=(y2-y3)*(x1-x3)-(x2-x3)*(y1-y3) + !vector product of CA and CM + s2=(YTIN-y3)*(x1-x3)-(XTIN-x3)*(y1-y3) + ! ssum = ABS(s1*sg1)+ABS(s2*sg2)+ABS(s3*sg3) + MAPSTAOK = ((GRIDS(IMOD)%MAPSTA(1,I1).GE.1).AND. & + (GRIDS(IMOD)%MAPSTA(1,I2).GE.1).AND.(GRIDS(IMOD)%MAPSTA(1,I3).GE.1)) + IF (FORCE.LT.2) MAPSTAOK =.TRUE. + ssum = (XTIN-(x1+x2+x3)/3.)**2+(YTIN-(y1+y2+y2)/3.)**2 + IF (smin.EQ.0.AND. MAPSTAOK ) smin=ssum + !WRITE(6,*) 'ssum',ITRI,MAPSTAOK,ssum,smin + IF (ssum.LT.smin .AND. MAPSTAOK ) THEN + smin=ssum + ITRIS=ITRI + ENDIF + IF ((s1*sg1.GE.0).AND.(s2*sg2.GE.0).AND.(s3*sg3.GE.0)) THEN + itout=ITRI + nbFound=nbFound+1 + IS(1)=I1 + IS(2)=I2 + IS(3)=I3 + IS(4)=1 + JS(:)=1 + RW(1)=s1/sg1 + RW(2)=s2/sg2 + RW(3)=1.-RW(1)-RW(2) !s3/sg3 + RW(4)=0. + END IF + ENDDO + IF (itout.EQ.0.AND.FORCE.GT.0) THEN + ITRI=ITRIS + I1=GRIDS(IMOD)%TRIGP(1,ITRI) + I2=GRIDS(IMOD)%TRIGP(2,ITRI) + I3=GRIDS(IMOD)%TRIGP(3,ITRI) + ! coordinates of the first vertex A + x1=GRIDS(IMOD)%XGRD(1,I1) + y1=GRIDS(IMOD)%YGRD(1,I1) + ! coordinates of the 2nd vertex B + x2=GRIDS(IMOD)%XGRD(1,I2) + y2=GRIDS(IMOD)%YGRD(1,I2) + !coordinates of the 3rd vertex C + x3=GRIDS(IMOD)%XGRD(1,I3) + y3=GRIDS(IMOD)%YGRD(1,I3) + D1=(XTIN-X1)**2+(YTIN-Y1)**2 + D2=(XTIN-X2)**2+(YTIN-Y2)**2 + D3=(XTIN-X3)**2+(YTIN-Y3)**2 + IF (D1.LE.D2.AND.D1.LE.D3) IS(1)=I1 + IF (D2.LE.D1.AND.D2.LE.D3) IS(1)=I2 + IF (D3.LE.D2.AND.D3.LE.D1) IS(1)=I3 + IS(2:4)=1 + JS(:)=1 + RW(1)=1 + RW(2:4)=0. + ITOUT=ITRI + + ENDIF + END SUBROUTINE IS_IN_UNGRID2 + !/ ------------------------------------------------------------------- / + SUBROUTINE UG_GRADIENTS (PARAM, DIFFX, DIFFY) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | A. Roland | + !/ | FORTRAN 90 | + !/ | Last update : 14-Oct-2013| + !/ +-----------------------------------+ + !/ + !/ 15-Nov-2007 : Origination. ( version 3.13 ) + !/ 31-Oct-2010 : Merging of 4.03 with 3.14-Ifremer ( version 4.04 ) + !/ 08-Nov-2011 : Correction for zero grad. on contour( version 4.04 ) + !/ 14-Oct-2013 : Correction of latitude factor ( version 4.12 ) + !/ 01-Mai-2018 : Using linear shape function for gradients [ version 6.04) + !/ + ! + ! 1. purpose: calculate gradients at a point via its connection. + ! 2. Method : using linear shape function this is a basis on which + ! all advection schemes in Roland (2008) are checked. + ! + ! 3. Parameters : + ! PARAM : depth or current field (indices 0 to NSEA) + ! DIFFX : x gradient (indices 1 to NX) + ! DIFFY : y gradient (indices 1 to NX) + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. Actual wind wave routine + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! This subroutine is adjusted from WWM code (Aaron Roland) + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + USE CONSTANTS + USE W3GDATMD, ONLY : TRIGP, NTRI, NX, NSEA, MAPFS, CLATIS, & + MAPSTA, ANGLE, FLAGLL, IOBP, IEN, TRIA, NSEAL, NTRI + USE W3ADATMD, ONLY : NSEALM #ifdef W3_PDLIB - USE yowElementpool - use yowNodepool, only: PDLIB_IEN, PDLIB_TRIA, NPA - USE yowExchangeModule, only : PDLIB_exchange1Dreal + USE yowElementpool + use yowNodepool, only: PDLIB_IEN, PDLIB_TRIA, NPA + USE yowExchangeModule, only : PDLIB_exchange1Dreal #endif - IMPLICIT NONE - - - REAL, INTENT(IN) :: PARAM(0:NSEA) - REAL, INTENT(OUT) :: DIFFX(:,:), DIFFY(:,:) - -! local parameters - - INTEGER :: VERTICES(3), NI(3), NI_GL(3) - REAL :: TMP1(3), TMP2(3) - INTEGER :: I, IX, IE, IE_GL - REAL :: VAR(3), FACT, LATMEAN - REAL :: DIFFXTMP, DIFFYTMP - REAL :: DEDX(3), DEDY(3) - REAL :: DVDXIE, DVDYIE - REAL :: WEI(NX), WEI_LOCAL(NSEAL) - REAL*8 :: RTMP(NSEAL) - - DIFFX = 0. - DIFFY = 0. -! - IF (FLAGLL) THEN - FACT=1./(DERA*RADIUS) - ELSE - FACT=1. - END IF + IMPLICIT NONE + + + REAL, INTENT(IN) :: PARAM(0:NSEA) + REAL, INTENT(OUT) :: DIFFX(:,:), DIFFY(:,:) + + ! local parameters + + INTEGER :: VERTICES(3), NI(3), NI_GL(3) + REAL :: TMP1(3), TMP2(3) + INTEGER :: I, IX, IE, IE_GL + REAL :: VAR(3), FACT, LATMEAN + REAL :: DIFFXTMP, DIFFYTMP + REAL :: DEDX(3), DEDY(3) + REAL :: DVDXIE, DVDYIE + REAL :: WEI(NX), WEI_LOCAL(NSEAL) + REAL*8 :: RTMP(NSEAL) + + DIFFX = 0. + DIFFY = 0. + ! + IF (FLAGLL) THEN + FACT=1./(DERA*RADIUS) + ELSE + FACT=1. + END IF #ifdef W3_PDLIB - IF (.NOT. LPDLIB) THEN + IF (.NOT. LPDLIB) THEN #endif - WEI = 0. - DO IE = 1, NTRI - NI = TRIGP(:,IE) - LATMEAN = 1./3. * SUM(CLATIS(MAPFS(1,NI))) - WEI(NI) = WEI(NI) + 2.*TRIA(IE) - DEDX(1) = IEN(IE,1) - DEDX(2) = IEN(IE,3) - DEDX(3) = IEN(IE,5) - DEDY(1) = IEN(IE,2) - DEDY(2) = IEN(IE,4) - DEDY(3) = IEN(IE,6) - VAR = PARAM(MAPFS(1,NI)) * FACT - DVDXIE = DOT_PRODUCT( VAR,DEDX) - DVDYIE = DOT_PRODUCT( VAR,DEDY) - DIFFX(1,NI) = DIFFX(1,NI) + DVDXIE * LATMEAN - DIFFY(1,NI) = DIFFY(1,NI) + DVDYIE - END DO - DIFFX(1,:) = DIFFX(1,:)/WEI - DIFFY(1,:) = DIFFY(1,:)/WEI + WEI = 0. + DO IE = 1, NTRI + NI = TRIGP(:,IE) + LATMEAN = 1./3. * SUM(CLATIS(MAPFS(1,NI))) + WEI(NI) = WEI(NI) + 2.*TRIA(IE) + DEDX(1) = IEN(IE,1) + DEDX(2) = IEN(IE,3) + DEDX(3) = IEN(IE,5) + DEDY(1) = IEN(IE,2) + DEDY(2) = IEN(IE,4) + DEDY(3) = IEN(IE,6) + VAR = PARAM(MAPFS(1,NI)) * FACT + DVDXIE = DOT_PRODUCT( VAR,DEDX) + DVDYIE = DOT_PRODUCT( VAR,DEDY) + DIFFX(1,NI) = DIFFX(1,NI) + DVDXIE * LATMEAN + DIFFY(1,NI) = DIFFY(1,NI) + DVDYIE + END DO + DIFFX(1,:) = DIFFX(1,:)/WEI + DIFFY(1,:) = DIFFY(1,:)/WEI #ifdef W3_PDLIB - ELSE - WEI_LOCAL = 0. - DO IE = 1, NE - NI = INE(:,IE) - IE_GL = IELG(IE) - NI_GL = TRIGP(:,IE_GL) - LATMEAN = 1./3. * SUM(CLATIS(MAPFS(1,NI_GL))) - WEI_LOCAL(NI) = WEI_LOCAL(NI) + 2.*PDLIB_TRIA(IE) - DEDX(1) = PDLIB_IEN(1,IE) - DEDX(2) = PDLIB_IEN(3,IE) - DEDX(3) = PDLIB_IEN(5,IE) - DEDY(1) = PDLIB_IEN(2,IE) - DEDY(2) = PDLIB_IEN(4,IE) - DEDY(3) = PDLIB_IEN(6,IE) - VAR = PARAM(MAPFS(1,NI_GL)) * FACT - DVDXIE = DOT_PRODUCT(VAR,DEDX) - DVDYIE = DOT_PRODUCT(VAR,DEDY) - DIFFX(1,NI) = DIFFX(1,NI) + DVDXIE * LATMEAN - DIFFY(1,NI) = DIFFY(1,NI) + DVDYIE - END DO - DIFFX(1,:) = DIFFX(1,:)/WEI_LOCAL - DIFFY(1,:) = DIFFY(1,:)/WEI_LOCAL - ENDIF - CALL PDLIB_exchange1Dreal(DIFFX(1,:)) - CALL PDLIB_exchange1Dreal(DIFFY(1,:)) + ELSE + WEI_LOCAL = 0. + DO IE = 1, NE + NI = INE(:,IE) + IE_GL = IELG(IE) + NI_GL = TRIGP(:,IE_GL) + LATMEAN = 1./3. * SUM(CLATIS(MAPFS(1,NI_GL))) + WEI_LOCAL(NI) = WEI_LOCAL(NI) + 2.*PDLIB_TRIA(IE) + DEDX(1) = PDLIB_IEN(1,IE) + DEDX(2) = PDLIB_IEN(3,IE) + DEDX(3) = PDLIB_IEN(5,IE) + DEDY(1) = PDLIB_IEN(2,IE) + DEDY(2) = PDLIB_IEN(4,IE) + DEDY(3) = PDLIB_IEN(6,IE) + VAR = PARAM(MAPFS(1,NI_GL)) * FACT + DVDXIE = DOT_PRODUCT(VAR,DEDX) + DVDYIE = DOT_PRODUCT(VAR,DEDY) + DIFFX(1,NI) = DIFFX(1,NI) + DVDXIE * LATMEAN + DIFFY(1,NI) = DIFFY(1,NI) + DVDYIE + END DO + DIFFX(1,:) = DIFFX(1,:)/WEI_LOCAL + DIFFY(1,:) = DIFFY(1,:)/WEI_LOCAL + ENDIF + CALL PDLIB_exchange1Dreal(DIFFX(1,:)) + CALL PDLIB_exchange1Dreal(DIFFY(1,:)) #endif -! - END SUBROUTINE UG_GRADIENTS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3NESTUG(DISTMIN,FLOK) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : UGTYPE nesting initialization -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! + END SUBROUTINE UG_GRADIENTS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3NESTUG(DISTMIN,FLOK) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : UGTYPE nesting initialization + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! + ! USE W3ODATMD, ONLY: NBI, NDSE, ISBPI, XBPI, YBPI USE W3GDATMD, ONLY: NX, XGRD, YGRD, MAPSTA, MAPFS, MAPSF @@ -2037,18 +2037,18 @@ SUBROUTINE W3NESTUG(DISTMIN,FLOK) INTEGER :: I, J, JMEMO, IS, IX, N, IX1(NBI) REAL :: DIST, DIST0 -! - N = 0 -! -!1. look for input boundary point index -! warning: if land points are included as boundary points to abide by the nest -! file, their status should be -2. -! + ! + N = 0 + ! + !1. look for input boundary point index + ! warning: if land points are included as boundary points to abide by the nest + ! file, their status should be -2. + ! IX1 = 0 ISBPI = 1 DO IX = 1, NX IF (ABS(MAPSTA (1,IX)) .EQ. 2) THEN - N = N + 1 + N = N + 1 IF (N.GT.NBI) THEN WRITE(NDSE,*) 'Error: boundary node index > NBI ... nest.ww3 file is not consistent with mod_def.ww3' STOP @@ -2059,930 +2059,930 @@ SUBROUTINE W3NESTUG(DISTMIN,FLOK) #endif END IF END DO -! -!2. Matches the model grid points (where MAPSTA = 2) with the points in nest.ww3 -! For this, we use the nearest point in the nest file. -! - DO I = 1, NBI + ! + !2. Matches the model grid points (where MAPSTA = 2) with the points in nest.ww3 + ! For this, we use the nearest point in the nest file. + ! + DO I = 1, NBI DIST0 = HUGE(1.) IS = 1 DO J = 1, N DIST = (XBPI(I) - XGRD(1,IX1(J)))**2 + (YBPI(I) - YGRD(1,IX1(J)))**2 - IF (DIST.LT.DIST0) THEN + IF (DIST.LT.DIST0) THEN IS = MAPFS(1,IX1(J)) DIST0 = DIST JMEMO = J - END IF + END IF END DO DIST0 = SQRT(DIST0) - IF (DIST0.LE.DISTMIN) THEN + IF (DIST0.LE.DISTMIN) THEN ISBPI(I) = IS #ifdef W3_T WRITE(NDSE ,'(A,I6,A,I7,A,I6)') 'MATCHED BOUNDARY POINT:',I,'GRID POINT:', & - MAPSF(IS,1),'INDEX IN nest.ww3:', JMEMO + MAPSF(IS,1),'INDEX IN nest.ww3:', JMEMO #endif ELSE FLOK=.TRUE. END IF - END DO + END DO - IF ( N .NE. NBI) THEN + IF ( N .NE. NBI) THEN WRITE(NDSE ,900) N, NBI DO J=1,N - WRITE(6,*) 'THIS POINT HAS MAPSTA=2:',ISBPI(J) + WRITE(6,*) 'THIS POINT HAS MAPSTA=2:',ISBPI(J) END DO ISBPI(N+1:NBI)=ISBPI(1) END IF 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & - ' NUMBER OF MAPSTA=2 DIFFERS FROM NUMBER IN nest.ww3 '/ & - ' CHECK nest.ww3 AND ww3_grid.inp ',2I8/) + ' NUMBER OF MAPSTA=2 DIFFERS FROM NUMBER IN nest.ww3 '/ & + ' CHECK nest.ww3 AND ww3_grid.inp ',2I8/) END SUBROUTINE W3NESTUG -!/ ------------------------------------------------------------------- / - SUBROUTINE SET_IOBP (MASK, STATUS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : setup boundary pointer -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE SET_IOBP (MASK, STATUS) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : setup boundary pointer + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! -!/ -! - USE CONSTANTS -! -! - USE W3GDATMD, ONLY: NX, NTRI, TRIGP - USE W3ODATMD, ONLY: IAPROC - - - IMPLICIT NONE - -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MASK(NX) - INTEGER*2, INTENT(OUT) :: STATUS(NX) -! - INTEGER :: COLLECTED(NX), NEXTVERT(NX), PREVVERT(NX) - INTEGER :: ISFINISHED !, INEXT, IPREV - INTEGER :: INEXT(3), IPREV(3) - INTEGER :: ZNEXT, IP, I, IE, IPNEXT, IPPREV, COUNT - integer nb0, nb1, nbM1 - STATUS = -1 - INEXT=(/ 2, 3, 1 /) !IPREV=1+MOD(I+1,3) - IPREV=(/ 3, 1, 2 /) !INEXT=1+MOD(I,3) - DO IE=1,NTRI -! If one of the points of the triangle is masked out (land) then do as if triangle does not exist... -! IF ((MASK(TRIGP(1,IE)).GT.0).AND.(MASK(TRIGP(2,IE)).GT.0).AND.(MASK(TRIGP(3,IE)).GT.0)) THEN + ! + !/ + ! + USE CONSTANTS + ! + ! + USE W3GDATMD, ONLY: NX, NTRI, TRIGP + USE W3ODATMD, ONLY: IAPROC + + + IMPLICIT NONE + + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MASK(NX) + INTEGER*2, INTENT(OUT) :: STATUS(NX) + ! + INTEGER :: COLLECTED(NX), NEXTVERT(NX), PREVVERT(NX) + INTEGER :: ISFINISHED !, INEXT, IPREV + INTEGER :: INEXT(3), IPREV(3) + INTEGER :: ZNEXT, IP, I, IE, IPNEXT, IPPREV, COUNT + integer nb0, nb1, nbM1 + STATUS = -1 + INEXT=(/ 2, 3, 1 /) !IPREV=1+MOD(I+1,3) + IPREV=(/ 3, 1, 2 /) !INEXT=1+MOD(I,3) + DO IE=1,NTRI + ! If one of the points of the triangle is masked out (land) then do as if triangle does not exist... + ! IF ((MASK(TRIGP(1,IE)).GT.0).AND.(MASK(TRIGP(2,IE)).GT.0).AND.(MASK(TRIGP(3,IE)).GT.0)) THEN + DO I=1,3 + IP=TRIGP(I,IE) + CALL TRIANG_INDEXES(I, IPNEXT, IPPREV) + !IPNEXT=TRIGP(INEXT(I),IE) + !IPPREV=TRIGP(IPREV(I),IE) + IF (STATUS(IP).EQ.-1) THEN + STATUS(IP)=1 + PREVVERT(IP)=IPPREV + NEXTVERT(IP)=IPNEXT + END IF + END DO + ! ENDIF + END DO + STATUS(:)=-1 + ! + COUNT = 0 + DO + COUNT = COUNT + 1 + COLLECTED(:)=0 + DO IE=1,NTRI + ! IF ((MASK(TRIGP(1,IE)).GT.0).AND.(MASK(TRIGP(2,IE)).GT.0).AND.(MASK(TRIGP(3,IE)).GT.0)) THEN DO I=1,3 IP=TRIGP(I,IE) CALL TRIANG_INDEXES(I, IPNEXT, IPPREV) !IPNEXT=TRIGP(INEXT(I),IE) !IPPREV=TRIGP(IPREV(I),IE) IF (STATUS(IP).EQ.-1) THEN - STATUS(IP)=1 - PREVVERT(IP)=IPPREV - NEXTVERT(IP)=IPNEXT - END IF - END DO -! ENDIF - END DO - STATUS(:)=-1 - ! - COUNT = 0 - DO - COUNT = COUNT + 1 - COLLECTED(:)=0 - DO IE=1,NTRI -! IF ((MASK(TRIGP(1,IE)).GT.0).AND.(MASK(TRIGP(2,IE)).GT.0).AND.(MASK(TRIGP(3,IE)).GT.0)) THEN - DO I=1,3 - IP=TRIGP(I,IE) - CALL TRIANG_INDEXES(I, IPNEXT, IPPREV) - !IPNEXT=TRIGP(INEXT(I),IE) - !IPPREV=TRIGP(IPREV(I),IE) - IF (STATUS(IP).EQ.-1) THEN - ZNEXT=NEXTVERT(IP) - IF (ZNEXT.EQ.IPPREV) THEN - COLLECTED(IP)=1 - NEXTVERT(IP)=IPNEXT - IF (NEXTVERT(IP).EQ.PREVVERT(IP)) THEN - STATUS(IP)=1 - END IF - END IF - END IF - END DO -! END IF ! end of test on MASK - END DO -! -! Checks that all nodes have been treated ... -! - ISFINISHED=1 - DO IP=1,NX - IF (MASK(IP).LE.0) THEN - STATUS(IP)=0 - ELSE - IF ((COLLECTED(IP).EQ.0).AND.(STATUS(IP).EQ.-1)) THEN - STATUS(IP)=0 - END IF - IF (STATUS(IP).eq.-1) THEN - ISFINISHED=0 + ZNEXT=NEXTVERT(IP) + IF (ZNEXT.EQ.IPPREV) THEN + COLLECTED(IP)=1 + NEXTVERT(IP)=IPNEXT + IF (NEXTVERT(IP).EQ.PREVVERT(IP)) THEN + STATUS(IP)=1 END IF - ENDIF + END IF + END IF END DO - IF (ISFINISHED.EQ.1) THEN - EXIT - END IF + ! END IF ! end of test on MASK END DO + ! + ! Checks that all nodes have been treated ... + ! + ISFINISHED=1 + DO IP=1,NX + IF (MASK(IP).LE.0) THEN + STATUS(IP)=0 + ELSE + IF ((COLLECTED(IP).EQ.0).AND.(STATUS(IP).EQ.-1)) THEN + STATUS(IP)=0 + END IF + IF (STATUS(IP).eq.-1) THEN + ISFINISHED=0 + END IF + ENDIF + END DO + IF (ISFINISHED.EQ.1) THEN + EXIT + END IF + END DO - STATUS = 1 - CALL GET_BOUNDARY(NX, NTRI, TRIGP, STATUS, PREVVERT, NEXTVERT) - -!#ifdef MPI_PARALL_GRID -! CALL exchange_p2di(STATUS) -!#endif - END SUBROUTINE SET_IOBP -!/ ------------------------------------------------------------------- / - - SUBROUTINE GET_BOUNDARY(MNP, MNE, TRIGP, IOBP, NEIGHBOR_PREV, & - & NEIGHBOR_NEXT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : find boundary points -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + STATUS = 1 + CALL GET_BOUNDARY(NX, NTRI, TRIGP, STATUS, PREVVERT, NEXTVERT) + + !#ifdef MPI_PARALL_GRID + ! CALL exchange_p2di(STATUS) + !#endif + END SUBROUTINE SET_IOBP + !/ ------------------------------------------------------------------- / + + SUBROUTINE GET_BOUNDARY(MNP, MNE, TRIGP, IOBP, NEIGHBOR_PREV, & + & NEIGHBOR_NEXT) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : find boundary points + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE W3SERVMD, ONLY: EXTCDE - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + ! + USE W3SERVMD, ONLY: EXTCDE + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, INTENT(IN) :: MNP, MNE, TRIGP(3,MNE) - INTEGER*2, INTENT(INOUT) :: IOBP(MNP) - INTEGER, INTENT(INOUT) :: NEIGHBOR_PREV(MNP) - INTEGER, INTENT(INOUT) :: NEIGHBOR_NEXT(MNP) + INTEGER, INTENT(IN) :: MNP, MNE, TRIGP(3,MNE) + INTEGER*2, INTENT(INOUT) :: IOBP(MNP) + INTEGER, INTENT(INOUT) :: NEIGHBOR_PREV(MNP) + INTEGER, INTENT(INOUT) :: NEIGHBOR_NEXT(MNP) - INTEGER, POINTER :: STATUS(:) - INTEGER, POINTER :: COLLECTED(:) - INTEGER, POINTER :: NEXTVERT(:) - INTEGER, POINTER :: PREVVERT(:) + INTEGER, POINTER :: STATUS(:) + INTEGER, POINTER :: COLLECTED(:) + INTEGER, POINTER :: NEXTVERT(:) + INTEGER, POINTER :: PREVVERT(:) - INTEGER :: IE, I, IP, IP2, IP3 - INTEGER :: ISFINISHED, INEXT, IPREV, ISTAT - INTEGER :: IPNEXT, IPPREV, ZNEXT, ZPREV + INTEGER :: IE, I, IP, IP2, IP3 + INTEGER :: ISFINISHED, INEXT, IPREV, ISTAT + INTEGER :: IPNEXT, IPPREV, ZNEXT, ZPREV #ifdef W3_S - CALL STRACE (IENT, 'GET_BOUNDARY') + CALL STRACE (IENT, 'GET_BOUNDARY') #endif - ALLOCATE(STATUS(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(COLLECTED(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(PREVVERT(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(NEXTVERT(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - NEIGHBOR_NEXT = 0 - NEIGHBOR_PREV = 0 -! Now computing the next items - STATUS = 0 - NEXTVERT = 0 - PREVVERT = 0 - - DO IE=1,MNE - DO I=1,3 - CALL TRIANG_INDEXES(I, INEXT, IPREV) - IP=TRIGP(I,IE) - IPNEXT=TRIGP(INEXT,IE) - IPPREV=TRIGP(IPREV,IE) - IF (STATUS(IP).EQ.0) THEN - STATUS(IP)=1 - PREVVERT(IP)=IPPREV + ALLOCATE(STATUS(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(COLLECTED(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(PREVVERT(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(NEXTVERT(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + NEIGHBOR_NEXT = 0 + NEIGHBOR_PREV = 0 + ! Now computing the next items + STATUS = 0 + NEXTVERT = 0 + PREVVERT = 0 + + DO IE=1,MNE + DO I=1,3 + CALL TRIANG_INDEXES(I, INEXT, IPREV) + IP=TRIGP(I,IE) + IPNEXT=TRIGP(INEXT,IE) + IPPREV=TRIGP(IPREV,IE) + IF (STATUS(IP).EQ.0) THEN + STATUS(IP)=1 + PREVVERT(IP)=IPPREV + NEXTVERT(IP)=IPNEXT + END IF + END DO + END DO + STATUS(:)=0 + DO + COLLECTED(:)=0 + DO IE=1,MNE + DO I=1,3 + CALL TRIANG_INDEXES(I, INEXT, IPREV) + IP=TRIGP(I,IE) + IPNEXT=TRIGP(INEXT,IE) + IPPREV=TRIGP(IPREV,IE) + IF (STATUS(IP).EQ.0) THEN + ZNEXT=NEXTVERT(IP) + IF (ZNEXT.EQ.IPPREV) THEN + COLLECTED(IP)=1 NEXTVERT(IP)=IPNEXT - END IF - END DO - END DO - STATUS(:)=0 - DO - COLLECTED(:)=0 - DO IE=1,MNE - DO I=1,3 - CALL TRIANG_INDEXES(I, INEXT, IPREV) - IP=TRIGP(I,IE) - IPNEXT=TRIGP(INEXT,IE) - IPPREV=TRIGP(IPREV,IE) - IF (STATUS(IP).EQ.0) THEN - ZNEXT=NEXTVERT(IP) - IF (ZNEXT.EQ.IPPREV) THEN - COLLECTED(IP)=1 - NEXTVERT(IP)=IPNEXT - IF (NEXTVERT(IP).EQ.PREVVERT(IP)) THEN - STATUS(IP)=1 - END IF - END IF + IF (NEXTVERT(IP).EQ.PREVVERT(IP)) THEN + STATUS(IP)=1 END IF - END DO - END DO - - ISFINISHED=1 - DO IP=1,MNP - IF ((COLLECTED(IP).EQ.0).AND.(STATUS(IP).EQ.0)) THEN - STATUS(IP)=-1 - NEIGHBOR_NEXT(IP)=NEXTVERT(IP) - END IF - IF (STATUS(IP).EQ.0) THEN - ISFINISHED=0 END IF - END DO - IF (ISFINISHED.EQ.1) THEN - EXIT END IF END DO + END DO + + ISFINISHED=1 + DO IP=1,MNP + IF ((COLLECTED(IP).EQ.0).AND.(STATUS(IP).EQ.0)) THEN + STATUS(IP)=-1 + NEIGHBOR_NEXT(IP)=NEXTVERT(IP) + END IF + IF (STATUS(IP).EQ.0) THEN + ISFINISHED=0 + END IF + END DO + IF (ISFINISHED.EQ.1) THEN + EXIT + END IF + END DO -! Now computing the prev items - STATUS = 0 - NEXTVERT = 0 - PREVVERT = 0 - DO IE=1,MNE - DO I=1,3 - CALL TRIANG_INDEXES(I, INEXT, IPREV) - IP=TRIGP(I,IE) - IPNEXT=TRIGP(INEXT,IE) - IPPREV=TRIGP(IPREV,IE) - IF (STATUS(IP).EQ.0) THEN - STATUS(IP)=1 + ! Now computing the prev items + STATUS = 0 + NEXTVERT = 0 + PREVVERT = 0 + DO IE=1,MNE + DO I=1,3 + CALL TRIANG_INDEXES(I, INEXT, IPREV) + IP=TRIGP(I,IE) + IPNEXT=TRIGP(INEXT,IE) + IPPREV=TRIGP(IPREV,IE) + IF (STATUS(IP).EQ.0) THEN + STATUS(IP)=1 + PREVVERT(IP)=IPPREV + NEXTVERT(IP)=IPNEXT + END IF + END DO + END DO + STATUS(:)=0 + DO + COLLECTED(:)=0 + DO IE=1,MNE + DO I=1,3 + CALL TRIANG_INDEXES(I, INEXT, IPREV) + IP=TRIGP(I,IE) + IPNEXT=TRIGP(INEXT,IE) + IPPREV=TRIGP(IPREV,IE) + IF (STATUS(IP).EQ.0) THEN + ZPREV=PREVVERT(IP) + IF (ZPREV.EQ.IPNEXT) THEN + COLLECTED(IP)=1 PREVVERT(IP)=IPPREV - NEXTVERT(IP)=IPNEXT - END IF - END DO - END DO - STATUS(:)=0 - DO - COLLECTED(:)=0 - DO IE=1,MNE - DO I=1,3 - CALL TRIANG_INDEXES(I, INEXT, IPREV) - IP=TRIGP(I,IE) - IPNEXT=TRIGP(INEXT,IE) - IPPREV=TRIGP(IPREV,IE) - IF (STATUS(IP).EQ.0) THEN - ZPREV=PREVVERT(IP) - IF (ZPREV.EQ.IPNEXT) THEN - COLLECTED(IP)=1 - PREVVERT(IP)=IPPREV - IF (PREVVERT(IP).EQ.NEXTVERT(IP)) THEN - STATUS(IP)=1 - END IF - END IF + IF (PREVVERT(IP).EQ.NEXTVERT(IP)) THEN + STATUS(IP)=1 END IF - END DO - END DO - - ISFINISHED=1 - DO IP=1,MNP - IF ((COLLECTED(IP).EQ.0).AND.(STATUS(IP).EQ.0)) THEN - STATUS(IP)=-1 - NEIGHBOR_PREV(IP)=PREVVERT(IP) ! new code - END IF - IF (STATUS(IP).EQ.0) THEN - ISFINISHED=0 - END IF - END DO - IF (ISFINISHED.EQ.1) THEN - EXIT - END IF - END DO -! Now making checks - DO IP=1,MNP - IP2=NEIGHBOR_NEXT(IP) - IF (IP2.GT.0) THEN - IP3=NEIGHBOR_PREV(IP2) - IF (ABS(IP3 - IP).GT.0) THEN - WRITE(*,*) 'IP=', IP, ' IP2=', IP2, ' IP3=', IP3 - WRITE(*,*) 'We have a dramatic inconsistency' - STOP END IF END IF END DO -! Now assigning the boundary IOBP array - DO IP=1,MNP - IF (STATUS(IP).EQ.-1 .AND. IOBP(IP) .EQ. 1) THEN - IOBP(IP)=0 - END IF - END DO + END DO - DEALLOCATE(STATUS, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(COLLECTED, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(NEXTVERT, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(PREVVERT, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) + ISFINISHED=1 + DO IP=1,MNP + IF ((COLLECTED(IP).EQ.0).AND.(STATUS(IP).EQ.0)) THEN + STATUS(IP)=-1 + NEIGHBOR_PREV(IP)=PREVVERT(IP) ! new code + END IF + IF (STATUS(IP).EQ.0) THEN + ISFINISHED=0 + END IF + END DO + IF (ISFINISHED.EQ.1) THEN + EXIT + END IF + END DO + ! Now making checks + DO IP=1,MNP + IP2=NEIGHBOR_NEXT(IP) + IF (IP2.GT.0) THEN + IP3=NEIGHBOR_PREV(IP2) + IF (ABS(IP3 - IP).GT.0) THEN + WRITE(*,*) 'IP=', IP, ' IP2=', IP2, ' IP3=', IP3 + WRITE(*,*) 'We have a dramatic inconsistency' + STOP + END IF + END IF + END DO + ! Now assigning the boundary IOBP array + DO IP=1,MNP + IF (STATUS(IP).EQ.-1 .AND. IOBP(IP) .EQ. 1) THEN + IOBP(IP)=0 + END IF + END DO - END SUBROUTINE GET_BOUNDARY + DEALLOCATE(STATUS, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(COLLECTED, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(NEXTVERT, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(PREVVERT, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) -!/ ------------------------------------------------------------------- / + END SUBROUTINE GET_BOUNDARY - SUBROUTINE TRIANG_INDEXES(I, INEXT, IPREV) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : set indices of the triangle -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + + SUBROUTINE TRIANG_INDEXES(I, INEXT, IPREV) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : set indices of the triangle + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + IMPLICIT NONE + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(OUT) :: INEXT, IPREV + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(OUT) :: INEXT, IPREV #ifdef W3_S - CALL STRACE (IENT, 'TRIANG_INDEXES') + CALL STRACE (IENT, 'TRIANG_INDEXES') #endif - IF (I.EQ.1) THEN - INEXT=3 - ELSE - INEXT=I-1 - END IF - IF (I.EQ.3) THEN - IPREV=1 - ELSE - IPREV=I+1 - END IF + IF (I.EQ.1) THEN + INEXT=3 + ELSE + INEXT=I-1 + END IF + IF (I.EQ.3) THEN + IPREV=1 + ELSE + IPREV=I+1 + END IF END SUBROUTINE TRIANG_INDEXES -!/ ------------------------------------------------------------------- / - - SUBROUTINE GET_INTERFACE() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : get interface nodes of the wetting and drying part -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + + SUBROUTINE GET_INTERFACE() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : get interface nodes of the wetting and drying part + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY : NX, IOBP, CCON, NSEAL, IOBDP, IE_CELL, IOBDP, TRIGP + ! + USE CONSTANTS, ONLY : LPDLIB + USE W3GDATMD, ONLY : NX, IOBP, CCON, NSEAL, IOBDP, IE_CELL, IOBDP, TRIGP #ifdef W3_PDLIB - USE yowNodepool, only: PDLIB_SI, PDLIB_IEN, PDLIB_CCON, NPA, PDLIB_IE_CELL2, PDLIB_POS_CELL2 - USE yowElementpool, only: INE + USE yowNodepool, only: PDLIB_SI, PDLIB_IEN, PDLIB_CCON, NPA, PDLIB_IE_CELL2, PDLIB_POS_CELL2 + USE yowElementpool, only: INE #endif - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: I, J, IP, IE + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: I, J, IP, IE #ifdef W3_S - CALL STRACE (IENT, 'GET_INTERFACE') + CALL STRACE (IENT, 'GET_INTERFACE') #endif #ifdef W3_PDLIB - IF (LPDLIB) THEN + IF (LPDLIB) THEN DO IP = 1, NSEAL IF (IOBP(IP) .NE. 0 .OR. IOBDP(IP) .EQ. 0) CYCLE DO I = 1, PDLIB_CCON(IP) IE = PDLIB_IE_CELL2(I,IP) IF (ANY(IOBDP(TRIGP(:,IE)) .EQ. 0)) THEN - IOBDP(IP) = -1 + IOBDP(IP) = -1 CYCLE ENDIF ENDDO ENDDO !CALL EXCHANGE_.... - ELSE + ELSE #endif J = 0 DO IP = 1, NSEAL DO I = 1, CCON(IP) - J = J + 1 + J = J + 1 IE = IE_CELL(J) IF (ANY(IOBDP(TRIGP(:,IE)) .EQ. 0)) THEN - IOBDP(IP) = -1 ! Set this node as a wet node adjacent to a dry one ... now what's next? Here on this points we want to compute the reflection source term, yes? - EXIT + IOBDP(IP) = -1 ! Set this node as a wet node adjacent to a dry one ... now what's next? Here on this points we want to compute the reflection source term, yes? + EXIT ENDIF ENDDO ENDDO #ifdef W3_PDLIB - ENDIF + ENDIF #endif - + END SUBROUTINE GET_INTERFACE -!/ ------------------------------------------------------------------- / - SUBROUTINE SET_UG_IOBP() -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Fabrice Ardhuin | -!/ | Aron Roland | -!/ | FORTRAN 90 | -!/ | Last update : 17-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 23-Aug-2011 : Origination. ( version 4.04 ) -!/ 17-Apr-2016 : Uses optimized boundary detection ( version 5.10 ) -!/ -! 1. Purpose : -! -! Redefines the values of the boundary points and angle pointers -! based on the MAPSTA array -! -! 2. Method : -! -! Adapted boundary detection from A. Roland and M. Dutour (WWM code) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! - -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_GRID Prog. WW3_GRID Grid preprocessor -! W3ULEV Subr. W3UPDTMD Water level update -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! -! 10. Source code : -!/ ------------------------------------------------------------------- / -!/ -! - USE CONSTANTS -! -! - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPFS, & - NK, NTH, DTH, XFR, MAPSTA, COUNTRI, & - ECOS, ESIN, IEN, NTRI, TRIGP, & - IOBP,IOBPD, IOBPA, & + !/ ------------------------------------------------------------------- / + SUBROUTINE SET_UG_IOBP() + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Fabrice Ardhuin | + !/ | Aron Roland | + !/ | FORTRAN 90 | + !/ | Last update : 17-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 23-Aug-2011 : Origination. ( version 4.04 ) + !/ 17-Apr-2016 : Uses optimized boundary detection ( version 5.10 ) + !/ + ! 1. Purpose : + ! + ! Redefines the values of the boundary points and angle pointers + ! based on the MAPSTA array + ! + ! 2. Method : + ! + ! Adapted boundary detection from A. Roland and M. Dutour (WWM code) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_GRID Prog. WW3_GRID Grid preprocessor + ! W3ULEV Subr. W3UPDTMD Water level update + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + !/ + ! + USE CONSTANTS + ! + ! + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPFS, & + NK, NTH, DTH, XFR, MAPSTA, COUNTRI, & + ECOS, ESIN, IEN, NTRI, TRIGP, & + IOBP,IOBPD, IOBPA, & #ifdef W3_REF1 - REFPARS, REFLC, REFLD, & + REFPARS, REFLC, REFLD, & #endif - ANGLE0, ANGLE + ANGLE0, ANGLE - USE W3ODATMD, ONLY: TBPI0, TBPIN, FLBPI - USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, ITIME, CFLXYMAX - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, only : IAPROC + USE W3ODATMD, ONLY: TBPI0, TBPIN, FLBPI + USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, ITIME, CFLXYMAX + USE W3IDATMD, ONLY: FLCUR + USE W3ODATMD, only : IAPROC #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITH, IX, I, J, IP, IE, NDIRSUM - REAL (KIND = 8) :: COSSUM, SINSUM - REAL (KIND = 8) :: DIRMIN, DIRMAX, SHIFT, TEMPO, DIRCOAST - REAL (KIND = 8) :: X1, X2, Y1, Y2, DXP1, DXP2, DXP3 - REAL (KIND = 8) :: DYP1, DYP2, DYP3, eDet1, eDet2, EVX, EVY - REAL(KIND=8), PARAMETER :: THR = TINY(1.) - INTEGER :: I1, I2, I3 - INTEGER :: ITMP(NX), NEXTVERT(NX), PREVVERT(NX) - CHARACTER(60) :: FNAME + + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITH, IX, I, J, IP, IE, NDIRSUM + REAL (KIND = 8) :: COSSUM, SINSUM + REAL (KIND = 8) :: DIRMIN, DIRMAX, SHIFT, TEMPO, DIRCOAST + REAL (KIND = 8) :: X1, X2, Y1, Y2, DXP1, DXP2, DXP3 + REAL (KIND = 8) :: DYP1, DYP2, DYP3, eDet1, eDet2, EVX, EVY + REAL(KIND=8), PARAMETER :: THR = TINY(1.) + INTEGER :: I1, I2, I3 + INTEGER :: ITMP(NX), NEXTVERT(NX), PREVVERT(NX) + CHARACTER(60) :: FNAME #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ ------------------------------------------------------------------- / -! -! 1. Preparations --------------------------------------------------- * -! 1.a Set constants -! + !/ ------------------------------------------------------------------- / + ! + ! 1. Preparations --------------------------------------------------- * + ! 1.a Set constants + ! #ifdef W3_S - CALL STRACE (IENT, 'SETUGIOBP') + CALL STRACE (IENT, 'SETUGIOBP') #endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Searches for boundary points -! - ITMP = MAPSTA(1,:) - CALL SET_IOBP(ITMP, IOBP) - FNAME = 'meshbnd.msh' - CALL READMSH_IOBP(23456,FNAME) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Defines directions pointing into land or sea -! - IOBPD(:,:) = 0 - IOBPA(:) = 0 -! - DO IP=1,NX - IF (MAPSTA(1,IP).EQ.2) THEN - IOBPA(IP) = 1 - IOBP(IP) = 2 - ENDIF - END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Searches for boundary points + ! + ITMP = MAPSTA(1,:) + CALL SET_IOBP(ITMP, IOBP) + FNAME = 'meshbnd.msh' + CALL READMSH_IOBP(23456,FNAME) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Defines directions pointing into land or sea + ! + IOBPD(:,:) = 0 + IOBPA(:) = 0 + ! + DO IP=1,NX + IF (MAPSTA(1,IP).EQ.2) THEN + IOBPA(IP) = 1 + IOBP(IP) = 2 + ENDIF + END DO - DO IE = 1,NTRI - I1 = TRIGP(1,IE) - I2 = TRIGP(2,IE) - I3 = TRIGP(3,IE) - DXP1 = IEN(IE,6) - DYP1 = - IEN(IE,5) - DXP2 = IEN(IE,2) - DYP2 = - IEN(IE,1) - DXP3 = IEN(IE,4) - DYP3 = - IEN(IE,3) - DO ITH=1,NTH - EVX=ECOS(ITH) - EVY=ESIN(ITH) - DO I=1,3 - IF (I.eq.1) THEN - x1= DXP1 - y1= DYP1 - x2= - DXP3 - y2= - DYP3 - IP= I1 - END IF - IF (I.eq.2) THEN - x1 = DXP2 - y1 = DYP2 - x2 = - DXP1 - y2 = - DYP1 - IP = I2 - END IF - IF (I.eq.3) THEN - x1 = DXP3 - y1 = DYP3 - x2 = - DXP2 - y2 = - DYP2 - IP = I3 - END IF - IF (IOBP(IP) .eq. 0) THEN ! physical boundary - eDet1 = THR-x1*EVY+y1*EVX - eDet2 = THR+x2*EVY-y2*EVX - IF ((eDet1.gt.0.).and.(eDet2.gt.0.)) THEN -! this is the case of waves going towards the boundary ... - IOBPD(ITH,IP)=1 - ENDIF - ELSE ! water ... + DO IE = 1,NTRI + I1 = TRIGP(1,IE) + I2 = TRIGP(2,IE) + I3 = TRIGP(3,IE) + DXP1 = IEN(IE,6) + DYP1 = - IEN(IE,5) + DXP2 = IEN(IE,2) + DYP2 = - IEN(IE,1) + DXP3 = IEN(IE,4) + DYP3 = - IEN(IE,3) + DO ITH=1,NTH + EVX=ECOS(ITH) + EVY=ESIN(ITH) + DO I=1,3 + IF (I.eq.1) THEN + x1= DXP1 + y1= DYP1 + x2= - DXP3 + y2= - DYP3 + IP= I1 + END IF + IF (I.eq.2) THEN + x1 = DXP2 + y1 = DYP2 + x2 = - DXP1 + y2 = - DYP1 + IP = I2 + END IF + IF (I.eq.3) THEN + x1 = DXP3 + y1 = DYP3 + x2 = - DXP2 + y2 = - DYP2 + IP = I3 + END IF + IF (IOBP(IP) .eq. 0) THEN ! physical boundary + eDet1 = THR-x1*EVY+y1*EVX + eDet2 = THR+x2*EVY-y2*EVX + IF ((eDet1.gt.0.).and.(eDet2.gt.0.)) THEN + ! this is the case of waves going towards the boundary ... IOBPD(ITH,IP)=1 - END IF - END DO + ENDIF + ELSE ! water ... + IOBPD(ITH,IP)=1 + END IF END DO END DO - DO IP = 1, NX - IF ( IOBPA(IP) .eq. 1 .OR. IOBP(IP) .eq. 3 .OR. IOBP(IP) .eq. 4) IOBPD(:,IP) = 1 - END DO -!2do: recode for mpi -! IF (LBCWA .OR. LBCSP) THEN -! IF (.NOT. ANY(IOBP .EQ. 2)) THEN -! CALL WWM_ABORT('YOU IMPOSED BOUNDARY CONDITIONS BUT IN THE BOUNDARY FILE ARE NO NODES WITH FLAG = 2') -! ENDIF -! ENDIF -!#ifdef MPI_PARALL_GRID -! CALL exchange_p2di(IOBWB) -! DO ID = 1, MDC -! iwild = IOBPD(ID,:) -! CALL exchange_p2di(iwild) -! IOBPD(ID,:) = iwild -! ENDDO -!#endif -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Updates the reflection direction and sharp / flat shoreline angle + END DO + DO IP = 1, NX + IF ( IOBPA(IP) .eq. 1 .OR. IOBP(IP) .eq. 3 .OR. IOBP(IP) .eq. 4) IOBPD(:,IP) = 1 + END DO + !2do: recode for mpi + ! IF (LBCWA .OR. LBCSP) THEN + ! IF (.NOT. ANY(IOBP .EQ. 2)) THEN + ! CALL WWM_ABORT('YOU IMPOSED BOUNDARY CONDITIONS BUT IN THE BOUNDARY FILE ARE NO NODES WITH FLAG = 2') + ! ENDIF + ! ENDIF + !#ifdef MPI_PARALL_GRID + ! CALL exchange_p2di(IOBWB) + ! DO ID = 1, MDC + ! iwild = IOBPD(ID,:) + ! CALL exchange_p2di(iwild) + ! IOBPD(ID,:) = iwild + ! ENDDO + !#endif + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Updates the reflection direction and sharp / flat shoreline angle #ifdef W3_REF1 - ! - ! Finds the shoreline direction from IOBPD - ! - REFLC(1,:)= 0. - REFLD(:,:)= 1 - DO IP=1,NX - IF (IOBP(IP).EQ.0.AND.MAPSTA(1,IP).EQ.1) THEN - COSSUM=0. - SINSUM=0. - NDIRSUM=0. - DO ITH=1,NTH - COSSUM=COSSUM+IOBPD(ITH,IP)*ECOS(ITH) - SINSUM=SINSUM+IOBPD(ITH,IP)*ESIN(ITH) - NDIRSUM=NDIRSUM+IOBPD(ITH,IP) - END DO - DIRCOAST=ATAN2(SINSUM, COSSUM) - REFLD(1,MAPFS(1,IP)) = 1+MOD(NTH+NINT(DIRCOAST/DTH),NTH) - REFLD(2,MAPFS(1,IP)) = 4-MAX(2,NINT(4.*REAL(NDIRSUM)/REAL(NTH))) - REFLC(1,MAPFS(1,IP))= REFPARS(1) - END IF - END DO + ! + ! Finds the shoreline direction from IOBPD + ! + REFLC(1,:)= 0. + REFLD(:,:)= 1 + DO IP=1,NX + IF (IOBP(IP).EQ.0.AND.MAPSTA(1,IP).EQ.1) THEN + COSSUM=0. + SINSUM=0. + NDIRSUM=0. + DO ITH=1,NTH + COSSUM=COSSUM+IOBPD(ITH,IP)*ECOS(ITH) + SINSUM=SINSUM+IOBPD(ITH,IP)*ESIN(ITH) + NDIRSUM=NDIRSUM+IOBPD(ITH,IP) + END DO + DIRCOAST=ATAN2(SINSUM, COSSUM) + REFLD(1,MAPFS(1,IP)) = 1+MOD(NTH+NINT(DIRCOAST/DTH),NTH) + REFLD(2,MAPFS(1,IP)) = 4-MAX(2,NINT(4.*REAL(NDIRSUM)/REAL(NTH))) + REFLC(1,MAPFS(1,IP))= REFPARS(1) + END IF + END DO #endif -! -! Recomputes the angles used in the gradients estimation -! -! - RETURN - END SUBROUTINE SET_UG_IOBP -!/ ------------------------------------------------------------------- / - - SUBROUTINE FIX_PERIODCITY(I1,I2,I3,XGRD,YGRD,PT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Steven Brus | -!/ | Ali Abdolali | -!/ | FORTRAN 90 | -!/ | Last update : 21-May-2020 | -!/ +-----------------------------------+ -!/ -!/ 21-May-2020 : Origination. ( version 6.07 ) -!/ -!/ -! 1. Purpose : -! -! Adjust element longitude coordinates for elements straddling the -! dateline with distance of ~360 degrees -! -! 2. Method : -! -! Detect if element has nodes on both sides of dateline and adjust -! coordinates so that all nodes have the same sign -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- - IMPLICIT NONE - INTEGER, INTENT(IN) :: I1, I2, I3 - DOUBLE PRECISION, INTENT(IN) :: XGRD(:,:), YGRD(:,:) - REAL*8, INTENT(OUT) :: PT(3,2) -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- - INTEGER :: I - INTEGER :: R1GT180, R2GT180, R3GT180 -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! - -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! SPATIAL_GRID Subr. W3TRIAM Triangle area calculation -! NVECTRI Subr. W3TRIAM Edge length, angle, normal calcuation -! IS_IN_UNGRID Subr. W3TRIAM Point in element calculation -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -!/ ------------------------------------------------------------------- / - - PT(1,1) = XGRD(1,I1) - PT(1,2) = YGRD(1,I1) - PT(2,1) = XGRD(1,I2) - PT(2,2) = YGRD(1,I2) - PT(3,1) = XGRD(1,I3) - PT(3,2) = YGRD(1,I3) - - - R1GT180 = MERGE(1, 0, ABS(PT(3,1)-PT(2,1)).GT.180) - R2GT180 = MERGE(1, 0, ABS(PT(1,1)-PT(3,1)).GT.180) - R3GT180 = MERGE(1, 0, ABS(PT(2,1)-PT(1,1)).GT.180) - ! if R1GT180+R2GT180+R3GT180 .eq. 0 the element does not cross the dateline - ! if R1GT180+R2GT180+R3GT180 .eq. 1 the element contains the pole - ! if R1GT180+R2GT180+R3GT180 .eq. 2 the element crosses the dateline - - - IF ( R1GT180 + R2GT180 == 2 ) THEN - PT(3,1)=PT(3,1)-SIGN(360.0d0,(PT(3,1)-PT(2,1))) - ELSE IF ( R2GT180 + R3GT180 == 2 ) THEN - PT(1,1)=PT(1,1)-SIGN(360.0d0,(PT(1,1)-PT(2,1))) - ELSE IF ( R1GT180 + R3GT180 == 2 ) THEN - PT(2,1)=PT(2,1)-SIGN(360.0d0,(PT(2,1)-PT(3,1))) - ENDIF - - RETURN - END SUBROUTINE FIX_PERIODCITY + ! + ! Recomputes the angles used in the gradients estimation + ! + ! + RETURN + END SUBROUTINE SET_UG_IOBP + !/ ------------------------------------------------------------------- / + + SUBROUTINE FIX_PERIODCITY(I1,I2,I3,XGRD,YGRD,PT) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Steven Brus | + !/ | Ali Abdolali | + !/ | FORTRAN 90 | + !/ | Last update : 21-May-2020 | + !/ +-----------------------------------+ + !/ + !/ 21-May-2020 : Origination. ( version 6.07 ) + !/ + !/ + ! 1. Purpose : + ! + ! Adjust element longitude coordinates for elements straddling the + ! dateline with distance of ~360 degrees + ! + ! 2. Method : + ! + ! Detect if element has nodes on both sides of dateline and adjust + ! coordinates so that all nodes have the same sign + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: I1, I2, I3 + DOUBLE PRECISION, INTENT(IN) :: XGRD(:,:), YGRD(:,:) + REAL*8, INTENT(OUT) :: PT(3,2) + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + INTEGER :: I + INTEGER :: R1GT180, R2GT180, R3GT180 + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! SPATIAL_GRID Subr. W3TRIAM Triangle area calculation + ! NVECTRI Subr. W3TRIAM Edge length, angle, normal calcuation + ! IS_IN_UNGRID Subr. W3TRIAM Point in element calculation + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + + PT(1,1) = XGRD(1,I1) + PT(1,2) = YGRD(1,I1) + PT(2,1) = XGRD(1,I2) + PT(2,2) = YGRD(1,I2) + PT(3,1) = XGRD(1,I3) + PT(3,2) = YGRD(1,I3) + + + R1GT180 = MERGE(1, 0, ABS(PT(3,1)-PT(2,1)).GT.180) + R2GT180 = MERGE(1, 0, ABS(PT(1,1)-PT(3,1)).GT.180) + R3GT180 = MERGE(1, 0, ABS(PT(2,1)-PT(1,1)).GT.180) + ! if R1GT180+R2GT180+R3GT180 .eq. 0 the element does not cross the dateline + ! if R1GT180+R2GT180+R3GT180 .eq. 1 the element contains the pole + ! if R1GT180+R2GT180+R3GT180 .eq. 2 the element crosses the dateline + + + IF ( R1GT180 + R2GT180 == 2 ) THEN + PT(3,1)=PT(3,1)-SIGN(360.0d0,(PT(3,1)-PT(2,1))) + ELSE IF ( R2GT180 + R3GT180 == 2 ) THEN + PT(1,1)=PT(1,1)-SIGN(360.0d0,(PT(1,1)-PT(2,1))) + ELSE IF ( R1GT180 + R3GT180 == 2 ) THEN + PT(2,1)=PT(2,1)-SIGN(360.0d0,(PT(2,1)-PT(3,1))) + ENDIF + + RETURN + END SUBROUTINE FIX_PERIODCITY END MODULE W3TRIAMD diff --git a/model/src/w3uno2md.F90 b/model/src/w3uno2md.F90 index 29e7756ed..cb8fce7fc 100644 --- a/model/src/w3uno2md.F90 +++ b/model/src/w3uno2md.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains MODULE W3UNO2MD, with UNO2 scheme. -!> +!> !> @author Jain-Guo Li @date 1-Jul-2013 !> @@ -8,1222 +8,1222 @@ !/ ------------------------------------------------------------------- / !> !> @brief Portable UNO2 scheme on irregular grid. -!> +!> !> @author Jain-Guo Li @date 1-Jul-2013 !> - MODULE W3UNO2MD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III MetOffice | -!/ | Jian-Guo Li | -!/ | FORTRAN 90 | -!/ | Last update : 01-Jul-2013 | -!/ +-----------------------------------+ -!/ -!/ Adapted from WAVEWATCH-III W3UQCKMD -!/ for UNO2 advection scheme. -!/ -!/ 18-Mar-2008 : Origination. ( version 3.14 ) -!/ ..-...-... : ..... ( version 3.14 ) -!/ 19-Mar-2008 : last modified by Jian-Guo ( version 3.14 ) -!/ 01-Jul-2013 : Put in NCEP branch (Tolman). ( version 4.12 ) -!/ 08-Jan-2018 : Added OMPH switches in W3UNO2. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Portable UNO2 scheme on irregular grid. -! -! 2. Variables and types : -! -! None. -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3UNO2 Subr. Public UNO2 scheme for irregular grid. -! W3UNO2r Subr. Public UNO2 scheme reduced to regular grid. -! W3UNO2s Subr. Public UNO2 regular grid with subgrid obstruction. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - STRACE and !/S irrelevant for running code. The module is -! therefore fully portable to any other model. -! -! 6. Switches : -! -! !/OMPH Ading OMP directves for hybrid paralellization. -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / +MODULE W3UNO2MD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III MetOffice | + !/ | Jian-Guo Li | + !/ | FORTRAN 90 | + !/ | Last update : 01-Jul-2013 | + !/ +-----------------------------------+ + !/ + !/ Adapted from WAVEWATCH-III W3UQCKMD + !/ for UNO2 advection scheme. + !/ + !/ 18-Mar-2008 : Origination. ( version 3.14 ) + !/ ..-...-... : ..... ( version 3.14 ) + !/ 19-Mar-2008 : last modified by Jian-Guo ( version 3.14 ) + !/ 01-Jul-2013 : Put in NCEP branch (Tolman). ( version 4.12 ) + !/ 08-Jan-2018 : Added OMPH switches in W3UNO2. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Portable UNO2 scheme on irregular grid. + ! + ! 2. Variables and types : + ! + ! None. + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3UNO2 Subr. Public UNO2 scheme for irregular grid. + ! W3UNO2r Subr. Public UNO2 scheme reduced to regular grid. + ! W3UNO2s Subr. Public UNO2 regular grid with subgrid obstruction. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - STRACE and !/S irrelevant for running code. The module is + ! therefore fully portable to any other model. + ! + ! 6. Switches : + ! + ! !/OMPH Ading OMP directves for hybrid paralellization. + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief UNO2 scheme for irregular grid. -!> -!> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. -!> @param[in] MY Field dimensions -!> @param[in] NX Part of field actually used -!> @param[in] NY Part of field actually used -!> @param[inout] VELO Local velocities (MY, MX+1). -!> @param[in] DT Time step. -!> @param[inout] DX1 Band width at points (MY, MX+1). -!> @param[inout] DX2 Band width between points (MY,0:MX+1). -!> @param[inout] Q Propagated quantity. -!> @param[in] BCLOSE Flag for closed 'X' dimension. -!> @param[in] INC Increment in 1-D array corresponding to increment in 2-D space. -!> @param[in] MAPACT List of active grid points. -!> @param[in] NACT Size of MAPACT. -!> @param[in] MAPBOU Map with boundary information (see W3MAP2). -!> @param[in] NB0 Counter in MAPBOU -!> @param[in] NB1 Counter in MAPBOU -!> @param[in] NB2 Counter in MAPBOU -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author Jain-Guo Li @date 1-Jul-2013 -!> - SUBROUTINE W3UNO2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q,BCLOSE,& - INC, MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & - NDSE, NDST ) -!/ -! -! Parameter list -! ---------------------------------------------------------------- -! MX,MY Int. I Field dimensions, if grid is 'closed' or -! circular, MX is the closed dimension. -! NX,NY Int. I Part of field actually used. -! VELO R.A. I Local velocities. (MY, MX+1) -! DT Real I Time step. -! DX1 R.A. I/O Band width at points. (MY, MX+1) -! DX2 R.A. I/O Band width between points. (MY,0:MX+1) -! (local counter and counter+INC) -! Q R.A. I/O Propagated quantity. (MY,0:MX+2) -! BCLOSE Log. I Flag for closed 'X' dimension' -! INC Int. I Increment in 1-D array corresponding to -! increment in 2-D space. -! MAPACT I.A. I List of active grid points. -! NACT Int. I Size of MAPACT. -! MAPBOU I.A. I Map with boundary information (see W3MAP2). -! NBn Int. I Counters in MAPBOU. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! - VELO amd Q need only bee filled in the (MY,MX) range, -! extension is used internally for closure. -! - VELO and Q are defined as 1-D arrays internally. -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3XYP2 Propagation in physical space -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - This routine can be used independently from WAVEWATCH-III. -! -! 8. Structure : -! -! ------------------------------------------------------ -! 1. Initialize aux. array FLA. -! 2. Fluxes for central points (3rd order + limiter). -! 3. Fluxes boundary point above (1st order). -! 4. Fluxes boundary point below (1st order). -! 5. Closure of 'X' if required -! 6. Propagate. -! ------------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T0 Test output input/output fields. -! !/T1 Test output fluxes. -! !/T2 Test output integration. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & - NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & - NDSE, NDST - REAL, INTENT(IN) :: DT - REAL, INTENT(INOUT) :: VELO(MY*(MX+1)), DX1(MY*(MX+1)), & - DX2(1-MY:MY*(MX+1)), Q(1-MY:MY*(MX+2)) - LOGICAL, INTENT(IN) :: BCLOSE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & - IAD00, IAD02, IADN0, IADN1, IADN2 + USE W3SERVMD, ONLY: STRACE +#endif + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief UNO2 scheme for irregular grid. + !> + !> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. + !> @param[in] MY Field dimensions + !> @param[in] NX Part of field actually used + !> @param[in] NY Part of field actually used + !> @param[inout] VELO Local velocities (MY, MX+1). + !> @param[in] DT Time step. + !> @param[inout] DX1 Band width at points (MY, MX+1). + !> @param[inout] DX2 Band width between points (MY,0:MX+1). + !> @param[inout] Q Propagated quantity. + !> @param[in] BCLOSE Flag for closed 'X' dimension. + !> @param[in] INC Increment in 1-D array corresponding to increment in 2-D space. + !> @param[in] MAPACT List of active grid points. + !> @param[in] NACT Size of MAPACT. + !> @param[in] MAPBOU Map with boundary information (see W3MAP2). + !> @param[in] NB0 Counter in MAPBOU + !> @param[in] NB1 Counter in MAPBOU + !> @param[in] NB2 Counter in MAPBOU + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author Jain-Guo Li @date 1-Jul-2013 + !> + SUBROUTINE W3UNO2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q,BCLOSE,& + INC, MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & + NDSE, NDST ) + !/ + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MX,MY Int. I Field dimensions, if grid is 'closed' or + ! circular, MX is the closed dimension. + ! NX,NY Int. I Part of field actually used. + ! VELO R.A. I Local velocities. (MY, MX+1) + ! DT Real I Time step. + ! DX1 R.A. I/O Band width at points. (MY, MX+1) + ! DX2 R.A. I/O Band width between points. (MY,0:MX+1) + ! (local counter and counter+INC) + ! Q R.A. I/O Propagated quantity. (MY,0:MX+2) + ! BCLOSE Log. I Flag for closed 'X' dimension' + ! INC Int. I Increment in 1-D array corresponding to + ! increment in 2-D space. + ! MAPACT I.A. I List of active grid points. + ! NACT Int. I Size of MAPACT. + ! MAPBOU I.A. I Map with boundary information (see W3MAP2). + ! NBn Int. I Counters in MAPBOU. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! - VELO amd Q need only bee filled in the (MY,MX) range, + ! extension is used internally for closure. + ! - VELO and Q are defined as 1-D arrays internally. + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3XYP2 Propagation in physical space + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - This routine can be used independently from WAVEWATCH-III. + ! + ! 8. Structure : + ! + ! ------------------------------------------------------ + ! 1. Initialize aux. array FLA. + ! 2. Fluxes for central points (3rd order + limiter). + ! 3. Fluxes boundary point above (1st order). + ! 4. Fluxes boundary point below (1st order). + ! 5. Closure of 'X' if required + ! 6. Propagate. + ! ------------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T0 Test output input/output fields. + ! !/T1 Test output fluxes. + ! !/T2 Test output integration. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & + NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & + NDSE, NDST + REAL, INTENT(IN) :: DT + REAL, INTENT(INOUT) :: VELO(MY*(MX+1)), DX1(MY*(MX+1)), & + DX2(1-MY:MY*(MX+1)), Q(1-MY:MY*(MX+2)) + LOGICAL, INTENT(IN) :: BCLOSE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & + IAD00, IAD02, IADN0, IADN1, IADN2 #ifdef W3_S - INTEGER, SAVE :: IENT + INTEGER, SAVE :: IENT #endif #ifdef W3_T1 - INTEGER :: IX2, IY2 + INTEGER :: IX2, IY2 #endif - REAL :: CFL, VEL, QB, DQ, DQNZ, QCN, QBN, & - QBR, CFAC, FLA(1-MY:MY*MX) + REAL :: CFL, VEL, QB, DQ, DQNZ, QCN, QBN, & + QBR, CFAC, FLA(1-MY:MY*MX) #ifdef W3_T0 - REAL :: QMAX + REAL :: QMAX #endif #ifdef W3_T1 - REAL :: QBO, QN, XCFL + REAL :: QBO, QN, XCFL #endif #ifdef W3_T2 - REAL :: QOLD + REAL :: QOLD #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3UNO2') + CALL STRACE (IENT, 'W3UNO2') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) MX, MY, NX, NY, DT, BCLOSE, INC, NB0, NB1, NB2 + WRITE (NDST,9000) MX, MY, NX, NY, DT, BCLOSE, INC, NB0, NB1, NB2 #endif -! + ! #ifdef W3_T0 - QMAX = 0. - DO IY=1, NY - DO IX=1, NX - QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) - END DO - END DO - QMAX = MAX ( 0.01*QMAX , 1.E-10 ) + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) #endif -! + ! #ifdef W3_T0 - WRITE (NDST,9001) 'VELO' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(100.*VELO(IY+(IX-1)*MY) & - *DT/DX1(IY+(IX-1)*MY)),IX=1,NX) - END DO - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO - WRITE (NDST,9001) 'MAPACT' - WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) -#endif -! -! 1. Initialize aux. array FLA and closure ------------------------- * -! - FLA = 0. -! - IF ( BCLOSE ) THEN + WRITE (NDST,9001) 'VELO' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*VELO(IY+(IX-1)*MY) & + *DT/DX1(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif + ! + ! 1. Initialize aux. array FLA and closure ------------------------- * + ! + FLA = 0. + ! + IF ( BCLOSE ) THEN #ifdef W3_T - WRITE (NDST,9005) -#endif - IAD00 = -MY - IAD02 = MY - IADN0 = IAD00 + MY*NX - IADN1 = MY*NX - IADN2 = IAD02 + MY*NX - DO IY=1, NY - Q (IY+IAD00) = Q (IY+IADN0) - Q (IY+IADN1) = Q ( IY ) - Q (IY+IADN2) = Q (IY+IAD02) - VELO(IY+IADN1) = VELO( IY ) - DX1 (IY+IADN1) = DX1 ( IY ) - DX2 (IY+IAD00) = DX1 (IY+IADN0) - DX2 (IY+IADN1) = DX1 ( IY ) - END DO - END IF -! -! 2. Fluxes for central points ------------------------------------- * -! ( 2rd order UNO2 scheme ) -! + WRITE (NDST,9005) +#endif + IAD00 = -MY + IAD02 = MY + IADN0 = IAD00 + MY*NX + IADN1 = MY*NX + IADN2 = IAD02 + MY*NX + DO IY=1, NY + Q (IY+IAD00) = Q (IY+IADN0) + Q (IY+IADN1) = Q ( IY ) + Q (IY+IADN2) = Q (IY+IAD02) + VELO(IY+IADN1) = VELO( IY ) + DX1 (IY+IADN1) = DX1 ( IY ) + DX2 (IY+IAD00) = DX1 (IY+IADN0) + DX2 (IY+IADN1) = DX1 ( IY ) + END DO + END IF + ! + ! 2. Fluxes for central points ------------------------------------- * + ! ( 2rd order UNO2 scheme ) + ! #ifdef W3_T1 - WRITE (NDST,9010) - WRITE (NDST,9011) NB0, 'CENTRAL' -#endif -! - DO IP=1, NB0 -! - IXY = MAPBOU(IP) - VEL = 0.5 * ( VELO(IXY) + VELO(IXY+INC) ) -! Assuming velocity is at cell centre, so face velocity is an average. - CFL = DT * VEL -! Courant number without gradient distance (between IXY and IXY+INC cells) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) -! Central cell index, depending on flow direction. -! IXY for positive CFL, IXY+INC for negative CFL -! Upstream and downstream cell numbers - IXYD = IXYC + INC * INT ( SIGN (1.1,CFL) ) -! Minimum gradient is derived from the two sides of the central cell -! - QB = Q(IXYC)+SIGN(0.5, Q(IXYD)-Q(IXYC))*(DX1(IXYC)-ABS(CFL)) & - *MIN(ABS(Q(IXYC+INC)-Q(IXYC))/DX2(IXYC), & - ABS(Q(IXYC)-Q(IXYC-INC))/DX2(IXYC-INC) ) -! + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' +#endif + ! + DO IP=1, NB0 + ! + IXY = MAPBOU(IP) + VEL = 0.5 * ( VELO(IXY) + VELO(IXY+INC) ) + ! Assuming velocity is at cell centre, so face velocity is an average. + CFL = DT * VEL + ! Courant number without gradient distance (between IXY and IXY+INC cells) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + ! Central cell index, depending on flow direction. + ! IXY for positive CFL, IXY+INC for negative CFL + ! Upstream and downstream cell numbers + IXYD = IXYC + INC * INT ( SIGN (1.1,CFL) ) + ! Minimum gradient is derived from the two sides of the central cell + ! + QB = Q(IXYC)+SIGN(0.5, Q(IXYD)-Q(IXYC))*(DX1(IXYC)-ABS(CFL)) & + *MIN(ABS(Q(IXYC+INC)-Q(IXYC))/DX2(IXYC), & + ABS(Q(IXYC)-Q(IXYC-INC))/DX2(IXYC-INC) ) + ! #ifdef W3_T1 - QBO = QB + QBO = QB #endif -! - FLA(IXY) = CFL * QB -! + ! + FLA(IXY) = CFL * QB + ! #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & - Q(IXY+INC), Q(IXY+2*INC) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & - CFL, DT*VELO(IXY)/DX1(IXY), & - DT*VELO(IXY+INC)/DX1(IXY+INC), & - QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & - Q(IXY+INC)*QN, Q(IXY+2*INC)*QN - END IF -#endif -! - END DO -! -! 3. Fluxes for points with boundary above ------------------------- * -! ( 1st order without limiter ) -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, DT*VELO(IXY)/DX1(IXY), & + DT*VELO(IXY+INC)/DX1(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif + ! + END DO + ! + ! 3. Fluxes for points with boundary above ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' -#endif -! - DO IP=NB0+1, NB1 - IXY = MAPBOU(IP) - VEL = VELO(IXY) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) - FLA(IXY) = VEL * DT * Q(IXYC) + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif + ! + DO IP=NB0+1, NB1 + IXY = MAPBOU(IP) + VEL = VELO(IXY) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) + FLA(IXY) = VEL * DT * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9013) IP, IX, IY, IX2, IY2, XCFL, & - DT*VELO(IXY)/DX2(IXY), & - Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, XCFL, & + DT*VELO(IXY)/DX2(IXY), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF #endif - END DO -! -! 4. Fluxes for points with boundary below ------------------------- * -! ( 1st order without limiter ) -! + END DO + ! + ! 4. Fluxes for points with boundary below ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' -#endif -! - DO IP=NB1+1, NB2 - IXY = MAPBOU(IP) - VEL = VELO(IXY+INC) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) - FLA(IXY) = VEL * DT * Q(IXYC) + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif + ! + DO IP=NB1+1, NB2 + IXY = MAPBOU(IP) + VEL = VELO(IXY+INC) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) + FLA(IXY) = VEL * DT * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9014) IP, IX, IY, IX2, IY2, XCFL, & - DT*VELO(IXY+INC)/DX2(IXY), & - Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, XCFL, & + DT*VELO(IXY+INC)/DX2(IXY), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF #endif - END DO -! -! 5. Global closure ----------------------------------------------- * -! - IF ( BCLOSE ) THEN + END DO + ! + ! 5. Global closure ----------------------------------------------- * + ! + IF ( BCLOSE ) THEN #ifdef W3_T - WRITE (NDST,9015) + WRITE (NDST,9015) #endif - DO IY=1, NY - FLA (IY+IAD00) = FLA (IY+IADN0) - END DO - END IF -! -! 6. Propagation -------------------------------------------------- * -! + DO IY=1, NY + FLA (IY+IAD00) = FLA (IY+IADN0) + END DO + END IF + ! + ! 6. Propagation -------------------------------------------------- * + ! #ifdef W3_T2 - WRITE (NDST,9020) + WRITE (NDST,9020) #endif - DO IP=1, NACT - IXY = MAPACT(IP) + DO IP=1, NACT + IXY = MAPACT(IP) #ifdef W3_T2 - QOLD = Q(IXY) + QOLD = Q(IXY) #endif -! Li Update transported quantity with fluxes - Q(IXY) = MAX( 0., Q(IXY)+( FLA(IXY-INC)-FLA(IXY) )/DX1(IXY) ) -! Li This positive filter is not necessary for UNO2 scheme but kept here. + ! Li Update transported quantity with fluxes + Q(IXY) = MAX( 0., Q(IXY)+( FLA(IXY-INC)-FLA(IXY) )/DX1(IXY) ) + ! Li This positive filter is not necessary for UNO2 scheme but kept here. #ifdef W3_T2 - IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & - WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & - DT*FLA(IXY-INC)/DX1(IXY), & - DT*FLA(IXY)/DX1(IXY) + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + DT*FLA(IXY-INC)/DX1(IXY), & + DT*FLA(IXY)/DX1(IXY) #endif - END DO -! + END DO + ! #ifdef W3_T0 - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO -#endif -! - RETURN -! -! Formats -! + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3UNO2 : ARRAY DIMENSIONS :',2I6/ & - ' USED :',2I6/ & - ' TIME STEP :',F8.1/ & - ' BCLOSE, INC :',L6,I6/ & - ' NB0, NB1, NB2 :',3I6) +9000 FORMAT ( ' TEST W3UNO2 : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' TIME STEP :',F8.1/ & + ' BCLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) #endif #ifdef W3_T0 - 9001 FORMAT ( ' TEST W3UNO2 : DUMP ARRAY ',A,' :') - 9002 FORMAT ( 1X,43I3) - 9003 FORMAT ( 1X,21I6) +9001 FORMAT ( ' TEST W3UNO2 : DUMP ARRAY ',A,' :') +9002 FORMAT ( 1X,43I3) +9003 FORMAT ( 1X,21I6) #endif #ifdef W3_T - 9005 FORMAT (' TEST W3UNO2 : GLOBAL CLOSURE (1)') +9005 FORMAT (' TEST W3UNO2 : GLOBAL CLOSURE (1)') #endif -! + ! #ifdef W3_T1 - 9010 FORMAT (' TEST W3UNO2 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & - ' Q (b,b,i-1,i,i+1,i+2)') - 9011 FORMAT (' TEST W3UNO2 :',I6,' POINTS OF TYPE ',A) - 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) - 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') - 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') +9010 FORMAT (' TEST W3UNO2 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') +9011 FORMAT (' TEST W3UNO2 :',I6,' POINTS OF TYPE ',A) +9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) +9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') #endif #ifdef W3_T - 9015 FORMAT (' TEST W3UNO2 : GLOBAL CLOSURE (2)') +9015 FORMAT (' TEST W3UNO2 : GLOBAL CLOSURE (2)') #endif -! + ! #ifdef W3_T2 - 9020 FORMAT (' TEST W3UNO2 : IP, IXY, 2Q, 2FL') - 9021 FORMAT (' ',2I6,2(1X,2E11.3)) -#endif - END SUBROUTINE W3UNO2 -!/ -!/ End of W3UNO2 ----------------------------------------------------- / -!> -!> @brief Preform one-dimensional propagation in a two-dimensional space -!> with irregular boundaries and regular grid. -!> -!> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. -!> @param[in] MY Field dimensions -!> @param[in] NX Part of field actually used -!> @param[in] NY Part of field actually used -!> @param[inout] CFLL Local Courant numbers (MY, MX+1). -!> @param[inout] Q Propagated quantity (MY,0:MX+2). -!> @param[in] BCLOSE Flag for closed 'X' dimension. -!> @param[in] INC Increment in 1-D array corresponding to increment in 2-D space. -!> @param[in] MAPACT List of active grid points. -!> @param[in] NACT Size of MAPACT. -!> @param[in] MAPBOU Map with boundary information (see W3MAP2). -!> @param[in] NB0 Counter in MAPBOU -!> @param[in] NB1 Counter in MAPBOU -!> @param[in] NB2 Counter in MAPBOU -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author Jain-Guo Li @date 8-Jan-2018 -!> - SUBROUTINE W3UNO2r (MX, MY, NX, NY, CFLL, Q, BCLOSE, INC, & - MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & - NDSE, NDST ) -!/ -!/ Adapted from W3QCK1 for UNO2 regular grid scheme. -!/ First created: 19 Mar 2008 Jian-Guo Li -!/ Last modified: 8 Jan 2018 Jian-Guo Li -!/ -! 1. Purpose : -! -! Preform one-dimensional propagation in a two-dimensional space -! with irregular boundaries and regular grid. -! -! 2. Method : -! -! UNO2 regular grid scheme -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MX,MY Int. I Field dimensions, if grid is 'closed' or -! circular, MX is the closed dimension. -! NX,NY Int. I Part of field actually used. -! CFLL R.A. I Local Courant numbers. (MY, MX+1) -! Q R.A. I/O Propagated quantity. (MY,0:MX+2) -! BCLOSE Log. I Flag for closed 'X' dimension' -! INC Int. I Increment in 1-D array corresponding to -! increment in 2-D space. -! MAPACT I.A. I List of active grid points. -! NACT Int. I Size of MAPACT. -! MAPBOU I.A. I Map with boundary information (see W3MAP2). -! NBn Int. I Counters in MAPBOU. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! - CFLL amd Q need only bee filled in the (MY,MX) range, -! extension is used internally for closure. -! - CFLL and Q are defined as 1-D arrays internally. -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3XYP2 Propagation in physical space -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - This routine can be used independently from WAVEWATCH-III. -! -! 8. Structure : -! -! ------------------------------------------------------ -! 1. Initialize aux. array FLA. -! 2. Fluxes for central points (3rd order + limiter). -! 3. Fluxes boundary point above (1st order). -! 4. Fluxes boundary point below (1st order). -! 5. Closure of 'X' if required -! 6. Propagate. -! ------------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T0 Test output input/output fields. -! !/T1 Test output fluxes. -! !/T2 Test output integration. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & - NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & - NDSE, NDST - REAL, INTENT(INOUT) :: CFLL(MY*(MX+1)), Q(1-MY:MY*(MX+2)) - LOGICAL, INTENT(IN) :: BCLOSE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & - IAD00, IAD02, IADN0, IADN1, IADN2 +9020 FORMAT (' TEST W3UNO2 : IP, IXY, 2Q, 2FL') +9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif + END SUBROUTINE W3UNO2 + !/ + !/ End of W3UNO2 ----------------------------------------------------- / + !> + !> @brief Preform one-dimensional propagation in a two-dimensional space + !> with irregular boundaries and regular grid. + !> + !> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. + !> @param[in] MY Field dimensions + !> @param[in] NX Part of field actually used + !> @param[in] NY Part of field actually used + !> @param[inout] CFLL Local Courant numbers (MY, MX+1). + !> @param[inout] Q Propagated quantity (MY,0:MX+2). + !> @param[in] BCLOSE Flag for closed 'X' dimension. + !> @param[in] INC Increment in 1-D array corresponding to increment in 2-D space. + !> @param[in] MAPACT List of active grid points. + !> @param[in] NACT Size of MAPACT. + !> @param[in] MAPBOU Map with boundary information (see W3MAP2). + !> @param[in] NB0 Counter in MAPBOU + !> @param[in] NB1 Counter in MAPBOU + !> @param[in] NB2 Counter in MAPBOU + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author Jain-Guo Li @date 8-Jan-2018 + !> + SUBROUTINE W3UNO2r (MX, MY, NX, NY, CFLL, Q, BCLOSE, INC, & + MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & + NDSE, NDST ) + !/ + !/ Adapted from W3QCK1 for UNO2 regular grid scheme. + !/ First created: 19 Mar 2008 Jian-Guo Li + !/ Last modified: 8 Jan 2018 Jian-Guo Li + !/ + ! 1. Purpose : + ! + ! Preform one-dimensional propagation in a two-dimensional space + ! with irregular boundaries and regular grid. + ! + ! 2. Method : + ! + ! UNO2 regular grid scheme + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MX,MY Int. I Field dimensions, if grid is 'closed' or + ! circular, MX is the closed dimension. + ! NX,NY Int. I Part of field actually used. + ! CFLL R.A. I Local Courant numbers. (MY, MX+1) + ! Q R.A. I/O Propagated quantity. (MY,0:MX+2) + ! BCLOSE Log. I Flag for closed 'X' dimension' + ! INC Int. I Increment in 1-D array corresponding to + ! increment in 2-D space. + ! MAPACT I.A. I List of active grid points. + ! NACT Int. I Size of MAPACT. + ! MAPBOU I.A. I Map with boundary information (see W3MAP2). + ! NBn Int. I Counters in MAPBOU. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! - CFLL amd Q need only bee filled in the (MY,MX) range, + ! extension is used internally for closure. + ! - CFLL and Q are defined as 1-D arrays internally. + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3XYP2 Propagation in physical space + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - This routine can be used independently from WAVEWATCH-III. + ! + ! 8. Structure : + ! + ! ------------------------------------------------------ + ! 1. Initialize aux. array FLA. + ! 2. Fluxes for central points (3rd order + limiter). + ! 3. Fluxes boundary point above (1st order). + ! 4. Fluxes boundary point below (1st order). + ! 5. Closure of 'X' if required + ! 6. Propagate. + ! ------------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T0 Test output input/output fields. + ! !/T1 Test output fluxes. + ! !/T2 Test output integration. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & + NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & + NDSE, NDST + REAL, INTENT(INOUT) :: CFLL(MY*(MX+1)), Q(1-MY:MY*(MX+2)) + LOGICAL, INTENT(IN) :: BCLOSE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & + IAD00, IAD02, IADN0, IADN1, IADN2 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T1 - INTEGER :: IX2, IY2 + INTEGER :: IX2, IY2 #endif - REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC - REAL :: FLA(1-MY:MY*MX) + REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC + REAL :: FLA(1-MY:MY*MX) #ifdef W3_T0 - REAL :: QMAX + REAL :: QMAX #endif #ifdef W3_T1 - REAL :: QBO, QN + REAL :: QBO, QN #endif #ifdef W3_T2 - REAL :: QOLD + REAL :: QOLD #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3UNO2r') + CALL STRACE (IENT, 'W3UNO2r') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) MX, MY, NX, NY, BCLOSE, INC, NB0, NB1, NB2 + WRITE (NDST,9000) MX, MY, NX, NY, BCLOSE, INC, NB0, NB1, NB2 #endif -! + ! #ifdef W3_T0 - QMAX = 0. - DO IY=1, NY - DO IX=1, NX - QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) - END DO - END DO - QMAX = MAX ( 0.01*QMAX , 1.E-10 ) + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) #endif -! + ! #ifdef W3_T0 - WRITE (NDST,9001) 'CFLL' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) - END DO - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO - WRITE (NDST,9001) 'MAPACT' - WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) -#endif -! -! 1. Initialize aux. array FLA and closure ------------------------- * -! - FLA = 0. -! - IF ( BCLOSE ) THEN + WRITE (NDST,9001) 'CFLL' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif + ! + ! 1. Initialize aux. array FLA and closure ------------------------- * + ! + FLA = 0. + ! + IF ( BCLOSE ) THEN #ifdef W3_T - WRITE (NDST,9005) -#endif - IAD00 = -MY - IAD02 = MY - IADN0 = IAD00 + MY*NX - IADN1 = MY*NX - IADN2 = IAD02 + MY*NX - DO IY=1, NY - Q (IY+IAD00) = Q (IY+IADN0) - Q (IY+IADN1) = Q ( IY ) - Q (IY+IADN2) = Q (IY+IAD02) - CFLL(IY+IADN1) = CFLL( IY ) - END DO - END IF -! -! 2. Fluxes for central points ------------------------------------- * -! ( 3rd order + limiter ) -! + WRITE (NDST,9005) +#endif + IAD00 = -MY + IAD02 = MY + IADN0 = IAD00 + MY*NX + IADN1 = MY*NX + IADN2 = IAD02 + MY*NX + DO IY=1, NY + Q (IY+IAD00) = Q (IY+IADN0) + Q (IY+IADN1) = Q ( IY ) + Q (IY+IADN2) = Q (IY+IAD02) + CFLL(IY+IADN1) = CFLL( IY ) + END DO + END IF + ! + ! 2. Fluxes for central points ------------------------------------- * + ! ( 3rd order + limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9010) - WRITE (NDST,9011) NB0, 'CENTRAL' -#endif -! - DO IP=1, NB0 -! - IXY = MAPBOU(IP) - CFL = 0.5 * ( CFLL(IXY) + CFLL(IXY+INC) ) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - IXYD = IXYC + INC * INT( SIGN (1.1,CFL) ) - QB = Q(IXYC)+SIGN(0.5, Q(IXYD)-Q(IXYC))*(1.0-ABS(CFL)) & - *MIN(ABS(Q(IXYC+INC)-Q(IXYC)), & - ABS(Q(IXYC)-Q(IXYC-INC)) ) + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' +#endif + ! + DO IP=1, NB0 + ! + IXY = MAPBOU(IP) + CFL = 0.5 * ( CFLL(IXY) + CFLL(IXY+INC) ) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + IXYD = IXYC + INC * INT( SIGN (1.1,CFL) ) + QB = Q(IXYC)+SIGN(0.5, Q(IXYD)-Q(IXYC))*(1.0-ABS(CFL)) & + *MIN(ABS(Q(IXYC+INC)-Q(IXYC)), & + ABS(Q(IXYC)-Q(IXYC-INC)) ) #ifdef W3_T1 - QBO = QB + QBO = QB #endif -! - FLA(IXY) = CFL * QB -! + ! + FLA(IXY) = CFL * QB + ! #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & - Q(IXY+INC), Q(IXY+2*INC) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & - CFL, CFLL(IXY), CFLL(IXY+INC), & - QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & - Q(IXY+INC)*QN, Q(IXY+2*INC)*QN - END IF -#endif -! - END DO -! -! 3. Fluxes for points with boundary above ------------------------- * -! ( 1st order without limiter ) -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, CFLL(IXY), CFLL(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif + ! + END DO + ! + ! 3. Fluxes for points with boundary above ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' -#endif -! - DO IP=NB0+1, NB1 - IXY = MAPBOU(IP) - CFL = CFLL(IXY) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - FLA(IXY) = CFL * Q(IXYC) + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif + ! + DO IP=NB0+1, NB1 + IXY = MAPBOU(IP) + CFL = CFLL(IXY) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + FLA(IXY) = CFL * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & - CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF -#endif - END DO -! -! 4. Fluxes for points with boundary below ------------------------- * -! ( 1st order without limiter ) -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif + END DO + ! + ! 4. Fluxes for points with boundary below ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' -#endif -! - DO IP=NB1+1, NB2 - IXY = MAPBOU(IP) - CFL = CFLL(IXY+INC) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - FLA(IXY) = CFL * Q(IXYC) + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif + ! + DO IP=NB1+1, NB2 + IXY = MAPBOU(IP) + CFL = CFLL(IXY+INC) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + FLA(IXY) = CFL * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, & - CFLL(IXY+INC), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF -#endif - END DO -! -! 5. Global closure ----------------------------------------------- * -! - IF ( BCLOSE ) THEN + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY+INC), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif + END DO + ! + ! 5. Global closure ----------------------------------------------- * + ! + IF ( BCLOSE ) THEN #ifdef W3_T - WRITE (NDST,9015) -#endif - DO IY=1, NY - FLA (IY+IAD00) = FLA (IY+IADN0) - END DO - END IF -! -! 6. Propagation -------------------------------------------------- * -! + WRITE (NDST,9015) +#endif + DO IY=1, NY + FLA (IY+IAD00) = FLA (IY+IADN0) + END DO + END IF + ! + ! 6. Propagation -------------------------------------------------- * + ! #ifdef W3_T2 - WRITE (NDST,9020) + WRITE (NDST,9020) #endif - DO IP=1, NACT - IXY = MAPACT(IP) + DO IP=1, NACT + IXY = MAPACT(IP) #ifdef W3_T2 - QOLD = Q(IXY) + QOLD = Q(IXY) #endif - Q(IXY) = MAX ( 0. , Q(IXY) + FLA(IXY-INC) - FLA(IXY) ) + Q(IXY) = MAX ( 0. , Q(IXY) + FLA(IXY-INC) - FLA(IXY) ) #ifdef W3_T2 - IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & - WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & - FLA(IXY-INC), FLA(IXY) + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + FLA(IXY-INC), FLA(IXY) #endif - END DO -! + END DO + ! #ifdef W3_T0 - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO -#endif -! - RETURN -! -! Formats -! + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3UNO2r : ARRAY DIMENSIONS :',2I6/ & - ' USED :',2I6/ & - ' BCLOSE, INC :',L6,I6/ & - ' NB0, NB1, NB2 :',3I6) +9000 FORMAT ( ' TEST W3UNO2r : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' BCLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) #endif #ifdef W3_T0 - 9001 FORMAT ( ' TEST W3UNO2r : DUMP ARRAY ',A,' :') - 9002 FORMAT ( 1X,43I3) - 9003 FORMAT ( 1X,21I6) +9001 FORMAT ( ' TEST W3UNO2r : DUMP ARRAY ',A,' :') +9002 FORMAT ( 1X,43I3) +9003 FORMAT ( 1X,21I6) #endif #ifdef W3_T - 9005 FORMAT (' TEST W3UNO2r : GLOBAL CLOSURE (1)') +9005 FORMAT (' TEST W3UNO2r : GLOBAL CLOSURE (1)') #endif -! + ! #ifdef W3_T1 - 9010 FORMAT (' TEST W3UNO2r : IP, 2x(IX,IY), CFL (b,i,i+1), ', & - ' Q (b,b,i-1,i,i+1,i+2)') - 9011 FORMAT (' TEST W3UNO2r :',I6,' POINTS OF TYPE ',A) - 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) - 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') - 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') +9010 FORMAT (' TEST W3UNO2r : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') +9011 FORMAT (' TEST W3UNO2r :',I6,' POINTS OF TYPE ',A) +9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) +9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') #endif #ifdef W3_T - 9015 FORMAT (' TEST W3UNO2r : GLOBAL CLOSURE (2)') +9015 FORMAT (' TEST W3UNO2r : GLOBAL CLOSURE (2)') #endif -! + ! #ifdef W3_T2 - 9020 FORMAT (' TEST W3UNO2r : IP, IXY, 2Q, 2FL') - 9021 FORMAT (' ',2I6,2(1X,2E11.3)) -#endif -!/ - END SUBROUTINE W3UNO2r -!/ -!/ End of W3UNO2r ---------------------------------------------------- / -!/ -!/ - -!> -!> @brief Like W3UNO2r with cell transparencies added. -!> -!> @details Adapted from W3QCK3 for UNO2 regular grid scheme with subgrid obstruction. -!> -!> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. -!> @param[in] MY Field dimensions -!> @param[in] NX Part of field actually used -!> @param[in] NY Part of field actually used -!> @param[in] TRANS -!> @param[inout] CFLL Local Courant numbers (MY, MX+1). -!> @param[inout] Q Propagated quantity (MY,0:MX+2). -!> @param[in] BCLOSE Flag for closed 'X' dimension. -!> @param[in] INC Increment in 1-D array corresponding to increment in 2-D space. -!> @param[in] MAPACT List of active grid points. -!> @param[in] NACT Size of MAPACT. -!> @param[in] MAPBOU Map with boundary information (see W3MAP2). -!> @param[in] NB0 Counter in MAPBOU -!> @param[in] NB1 Counter in MAPBOU -!> @param[in] NB2 Counter in MAPBOU -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author Jain-Guo Li @date 8-Jan-2018 -!> - SUBROUTINE W3UNO2s (MX, MY, NX, NY, CFLL, TRANS, Q, BCLOSE, & - INC, MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & - NDSE, NDST ) -!/ -!/ -!/ Adapted from W3QCK3 for UNO2 regular grid scheme with -!/ subgrid obstruction. -!/ First created: 19 Mar 2008 Jian-Guo Li -!/ Last modified: 8 Jan 2018 Jian-Guo Li -!/ -! 1. Purpose : -! -! Like W3UNO2r with cell transparencies added. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MX,MY Int. I Field dimensions, if grid is 'closed' or -! circular, MX is the closed dimension. -! NX,NY Int. I Part of field actually used. -! CFLL R.A. I Local Courant numbers. (MY, MX+1) -! Q R.A. I/O Propagated quantity. (MY,0:MX+2) -! BCLOSE Log. I Flag for closed 'X' dimension' -! INC Int. I Increment in 1-D array corresponding to -! increment in 2-D space. -! MAPACT I.A. I List of active grid points. -! NACT Int. I Size of MAPACT. -! MAPBOU I.A. I Map with boundary information (see W3MAP2). -! NBn Int. I Counters in MAPBOU. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! - CFLL amd Q need only bee filled in the (MY,MX) range, -! extension is used internally for closure. -! - CFLL and Q are defined as 1-D arrays internally. -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3XYP2 Propagation in physical space -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - This routine can be used independently from WAVEWATCH-III. -! -! 8. Structure : -! -! ------------------------------------------------------ -! 1. Initialize aux. array FLA. -! 2. Fluxes for central points (3rd order + limiter). -! 3. Fluxes boundary point above (1st order). -! 4. Fluxes boundary point below (1st order). -! 5. Closure of 'X' if required -! 6. Propagate. -! ------------------------------------------------------ -! -! 9. Switches : -! -! !/OMPH Ading OMP directves for hybrid paralellization. -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T0 Test output input/output fields. -! !/T1 Test output fluxes. -! !/T2 Test output integration. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & - NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & - NDSE, NDST - REAL, INTENT(IN) :: TRANS(MY*MX,-1:1) - REAL, INTENT(INOUT) :: CFLL(MY*(MX+1)), Q(1-MY:MY*(MX+2)) - LOGICAL, INTENT(IN) :: BCLOSE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & - IAD00, IAD02, IADN0, IADN1, IADN2, & - JN, JP +9020 FORMAT (' TEST W3UNO2r : IP, IXY, 2Q, 2FL') +9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif + !/ + END SUBROUTINE W3UNO2r + !/ + !/ End of W3UNO2r ---------------------------------------------------- / + !/ + !/ + + !> + !> @brief Like W3UNO2r with cell transparencies added. + !> + !> @details Adapted from W3QCK3 for UNO2 regular grid scheme with subgrid obstruction. + !> + !> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. + !> @param[in] MY Field dimensions + !> @param[in] NX Part of field actually used + !> @param[in] NY Part of field actually used + !> @param[in] TRANS + !> @param[inout] CFLL Local Courant numbers (MY, MX+1). + !> @param[inout] Q Propagated quantity (MY,0:MX+2). + !> @param[in] BCLOSE Flag for closed 'X' dimension. + !> @param[in] INC Increment in 1-D array corresponding to increment in 2-D space. + !> @param[in] MAPACT List of active grid points. + !> @param[in] NACT Size of MAPACT. + !> @param[in] MAPBOU Map with boundary information (see W3MAP2). + !> @param[in] NB0 Counter in MAPBOU + !> @param[in] NB1 Counter in MAPBOU + !> @param[in] NB2 Counter in MAPBOU + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author Jain-Guo Li @date 8-Jan-2018 + !> + SUBROUTINE W3UNO2s (MX, MY, NX, NY, CFLL, TRANS, Q, BCLOSE, & + INC, MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & + NDSE, NDST ) + !/ + !/ + !/ Adapted from W3QCK3 for UNO2 regular grid scheme with + !/ subgrid obstruction. + !/ First created: 19 Mar 2008 Jian-Guo Li + !/ Last modified: 8 Jan 2018 Jian-Guo Li + !/ + ! 1. Purpose : + ! + ! Like W3UNO2r with cell transparencies added. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MX,MY Int. I Field dimensions, if grid is 'closed' or + ! circular, MX is the closed dimension. + ! NX,NY Int. I Part of field actually used. + ! CFLL R.A. I Local Courant numbers. (MY, MX+1) + ! Q R.A. I/O Propagated quantity. (MY,0:MX+2) + ! BCLOSE Log. I Flag for closed 'X' dimension' + ! INC Int. I Increment in 1-D array corresponding to + ! increment in 2-D space. + ! MAPACT I.A. I List of active grid points. + ! NACT Int. I Size of MAPACT. + ! MAPBOU I.A. I Map with boundary information (see W3MAP2). + ! NBn Int. I Counters in MAPBOU. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! - CFLL amd Q need only bee filled in the (MY,MX) range, + ! extension is used internally for closure. + ! - CFLL and Q are defined as 1-D arrays internally. + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3XYP2 Propagation in physical space + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - This routine can be used independently from WAVEWATCH-III. + ! + ! 8. Structure : + ! + ! ------------------------------------------------------ + ! 1. Initialize aux. array FLA. + ! 2. Fluxes for central points (3rd order + limiter). + ! 3. Fluxes boundary point above (1st order). + ! 4. Fluxes boundary point below (1st order). + ! 5. Closure of 'X' if required + ! 6. Propagate. + ! ------------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/OMPH Ading OMP directves for hybrid paralellization. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T0 Test output input/output fields. + ! !/T1 Test output fluxes. + ! !/T2 Test output integration. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & + NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & + NDSE, NDST + REAL, INTENT(IN) :: TRANS(MY*MX,-1:1) + REAL, INTENT(INOUT) :: CFLL(MY*(MX+1)), Q(1-MY:MY*(MX+2)) + LOGICAL, INTENT(IN) :: BCLOSE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & + IAD00, IAD02, IADN0, IADN1, IADN2, & + JN, JP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T1 - INTEGER :: IX2, IY2 + INTEGER :: IX2, IY2 #endif - REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC - REAL :: FLA(1-MY:MY*MX) + REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC + REAL :: FLA(1-MY:MY*MX) #ifdef W3_T0 - REAL :: QMAX + REAL :: QMAX #endif #ifdef W3_T1 - REAL :: QBO, QN + REAL :: QBO, QN #endif #ifdef W3_T2 - REAL :: QOLD + REAL :: QOLD #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3UNO2s') + CALL STRACE (IENT, 'W3UNO2s') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) MX, MY, NX, NY, BCLOSE, INC, NB0, NB1, NB2 + WRITE (NDST,9000) MX, MY, NX, NY, BCLOSE, INC, NB0, NB1, NB2 #endif -! + ! #ifdef W3_T0 - QMAX = 0. - DO IY=1, NY - DO IX=1, NX - QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) - END DO - END DO - QMAX = MAX ( 0.01*QMAX , 1.E-10 ) + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) #endif -! + ! #ifdef W3_T0 - WRITE (NDST,9001) 'CFLL' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) - END DO - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO - WRITE (NDST,9001) 'MAPACT' - WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) -#endif -! -! 1. Initialize aux. array FLA and closure ------------------------- * -! - FLA = 0. -! - IF ( BCLOSE ) THEN + WRITE (NDST,9001) 'CFLL' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif + ! + ! 1. Initialize aux. array FLA and closure ------------------------- * + ! + FLA = 0. + ! + IF ( BCLOSE ) THEN #ifdef W3_T - WRITE (NDST,9005) -#endif - IAD00 = -MY - IAD02 = MY - IADN0 = IAD00 + MY*NX - IADN1 = MY*NX - IADN2 = IAD02 + MY*NX -! + WRITE (NDST,9005) +#endif + IAD00 = -MY + IAD02 = MY + IADN0 = IAD00 + MY*NX + IADN1 = MY*NX + IADN2 = IAD02 + MY*NX + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (IY) -#endif -! - DO IY=1, NY - Q (IY+IAD00) = Q (IY+IADN0) - Q (IY+IADN1) = Q ( IY ) - Q (IY+IADN2) = Q (IY+IAD02) - CFLL(IY+IADN1) = CFLL( IY ) - END DO -! + !$OMP PARALLEL DO PRIVATE (IY) +#endif + ! + DO IY=1, NY + Q (IY+IAD00) = Q (IY+IADN0) + Q (IY+IADN1) = Q ( IY ) + Q (IY+IADN2) = Q (IY+IAD02) + CFLL(IY+IADN1) = CFLL( IY ) + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO -#endif -! - END IF -! -! 2. Fluxes for central points ------------------------------------- * -! ( 3rd order + limiter ) -! + !$OMP END PARALLEL DO +#endif + ! + END IF + ! + ! 2. Fluxes for central points ------------------------------------- * + ! ( 3rd order + limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9010) - WRITE (NDST,9011) NB0, 'CENTRAL' + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, & + !$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, & #ifdef W3_T1 -!$OMP QBO, IX, IY, IY2, IX2, QN & -#endif -!$OMP IXYC, IXYD, QB) -#endif -! - DO IP=1, NB0 -! - IXY = MAPBOU(IP) - CFL = 0.5 * ( CFLL(IXY) + CFLL(IXY+INC) ) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - IXYD = IXYC + INC * INT( SIGN (1.1,CFL) ) - QB = Q(IXYC)+SIGN(0.5, Q(IXYD)-Q(IXYC))*(1.0-ABS(CFL)) & - *MIN(ABS(Q(IXYC+INC)-Q(IXYC)), & - ABS(Q(IXYC)-Q(IXYC-INC)) ) -! + !$OMP QBO, IX, IY, IY2, IX2, QN & +#endif + !$OMP IXYC, IXYD, QB) +#endif + ! + DO IP=1, NB0 + ! + IXY = MAPBOU(IP) + CFL = 0.5 * ( CFLL(IXY) + CFLL(IXY+INC) ) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + IXYD = IXYC + INC * INT( SIGN (1.1,CFL) ) + QB = Q(IXYC)+SIGN(0.5, Q(IXYD)-Q(IXYC))*(1.0-ABS(CFL)) & + *MIN(ABS(Q(IXYC+INC)-Q(IXYC)), & + ABS(Q(IXYC)-Q(IXYC-INC)) ) + ! #ifdef W3_T1 - QBO = QB + QBO = QB #endif -! - FLA(IXY) = CFL * QB -! + ! + FLA(IXY) = CFL * QB + ! #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & - Q(IXY+INC), Q(IXY+2*INC) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & - CFL, CFLL(IXY), CFLL(IXY+INC), & - QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & - Q(IXY+INC)*QN, Q(IXY+2*INC)*QN - END IF -#endif -! - END DO -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, CFLL(IXY), CFLL(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif + ! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! -! 3. Fluxes for points with boundary above ------------------------- * -! ( 1st order without limiter ) -! + ! + ! 3. Fluxes for points with boundary above ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' -#endif -! - DO IP=NB0+1, NB1 - IXY = MAPBOU(IP) - CFL = CFLL(IXY) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - FLA(IXY) = CFL * Q(IXYC) + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif + ! + DO IP=NB0+1, NB1 + IXY = MAPBOU(IP) + CFL = CFLL(IXY) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + FLA(IXY) = CFL * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & - CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF -#endif - END DO -! -! 4. Fluxes for points with boundary below ------------------------- * -! ( 1st order without limiter ) -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif + END DO + ! + ! 4. Fluxes for points with boundary below ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' -#endif -! - DO IP=NB1+1, NB2 - IXY = MAPBOU(IP) - CFL = CFLL(IXY+INC) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - FLA(IXY) = CFL * Q(IXYC) + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif + ! + DO IP=NB1+1, NB2 + IXY = MAPBOU(IP) + CFL = CFLL(IXY+INC) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + FLA(IXY) = CFL * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, CFLL(IXY+INC), & - Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF -#endif - END DO -! -! 5. Global closure ----------------------------------------------- * -! - IF ( BCLOSE ) THEN + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, CFLL(IXY+INC), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif + END DO + ! + ! 5. Global closure ----------------------------------------------- * + ! + IF ( BCLOSE ) THEN #ifdef W3_T - WRITE (NDST,9015) -#endif - DO IY=1, NY - FLA (IY+IAD00) = FLA (IY+IADN0) - END DO - END IF -! -! 6. Propagation -------------------------------------------------- * -! + WRITE (NDST,9015) +#endif + DO IY=1, NY + FLA (IY+IAD00) = FLA (IY+IADN0) + END DO + END IF + ! + ! 6. Propagation -------------------------------------------------- * + ! #ifdef W3_T2 - WRITE (NDST,9020) + WRITE (NDST,9020) #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO & + !$OMP PARALLEL DO & #ifdef W3_T2 -!$OMP PRIVATE(QOLD), & -#endif -!$OMP PRIVATE (IP, IXY, JN, JP) -#endif -! - DO IP=1, NACT -! - IXY = MAPACT(IP) - IF ( FLA(IXY-INC) .GT. 0. ) THEN - JN = -1 - ELSE - JN = 0 - END IF - IF ( FLA(IXY ) .LT. 0. ) THEN - JP = 1 - ELSE - JP = 0 - END IF -! + !$OMP PRIVATE(QOLD), & +#endif + !$OMP PRIVATE (IP, IXY, JN, JP) +#endif + ! + DO IP=1, NACT + ! + IXY = MAPACT(IP) + IF ( FLA(IXY-INC) .GT. 0. ) THEN + JN = -1 + ELSE + JN = 0 + END IF + IF ( FLA(IXY ) .LT. 0. ) THEN + JP = 1 + ELSE + JP = 0 + END IF + ! #ifdef W3_T2 - QOLD = Q(IXY) + QOLD = Q(IXY) #endif - Q(IXY) = MAX ( 0. , Q(IXY) + TRANS(IXY,JN) * FLA(IXY-INC) & - - TRANS(IXY,JP) * FLA(IXY) ) + Q(IXY) = MAX ( 0. , Q(IXY) + TRANS(IXY,JN) * FLA(IXY-INC) & + - TRANS(IXY,JP) * FLA(IXY) ) #ifdef W3_T2 - IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & - WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & - FLA(IXY-INC), FLA(IXY) + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + FLA(IXY-INC), FLA(IXY) #endif - END DO -! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! + ! #ifdef W3_T0 - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO -#endif -! - RETURN -! -! Formats -! + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3UNO2s : ARRAY DIMENSIONS :',2I6/ & - ' USED :',2I6/ & - ' BCLOSE, INC :',L6,I6/ & - ' NB0, NB1, NB2 :',3I6) +9000 FORMAT ( ' TEST W3UNO2s : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' BCLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) #endif #ifdef W3_T0 - 9001 FORMAT ( ' TEST W3UNO2s : DUMP ARRAY ',A,' :') - 9002 FORMAT ( 1X,43I3) - 9003 FORMAT ( 1X,21I6) +9001 FORMAT ( ' TEST W3UNO2s : DUMP ARRAY ',A,' :') +9002 FORMAT ( 1X,43I3) +9003 FORMAT ( 1X,21I6) #endif #ifdef W3_T - 9005 FORMAT (' TEST W3UNO2s : GLOBAL CLOSURE (1)') +9005 FORMAT (' TEST W3UNO2s : GLOBAL CLOSURE (1)') #endif -! + ! #ifdef W3_T1 - 9010 FORMAT (' TEST W3UNO2s : IP, 2x(IX,IY), CFL (b,i,i+1), ', & - ' Q (b,b,i-1,i,i+1,i+2)') - 9011 FORMAT (' TEST W3UNO2s :',I6,' POINTS OF TYPE ',A) - 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) - 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') - 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') +9010 FORMAT (' TEST W3UNO2s : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') +9011 FORMAT (' TEST W3UNO2s :',I6,' POINTS OF TYPE ',A) +9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) +9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') #endif #ifdef W3_T - 9015 FORMAT (' TEST W3UNO2s : GLOBAL CLOSURE (2)') +9015 FORMAT (' TEST W3UNO2s : GLOBAL CLOSURE (2)') #endif -! + ! #ifdef W3_T2 - 9020 FORMAT (' TEST W3UNO2s : IP, IXY, 2Q, 2FL') - 9021 FORMAT (' ',2I6,2(1X,2E11.3)) -#endif -!/ -!/ End of W3UNO2s ---------------------------------------------------- / -!/ - END SUBROUTINE W3UNO2s -!/ -!/ End of module W3UNO2MD -------------------------------------------- / -!/ - END MODULE W3UNO2MD +9020 FORMAT (' TEST W3UNO2s : IP, IXY, 2Q, 2FL') +9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif + !/ + !/ End of W3UNO2s ---------------------------------------------------- / + !/ + END SUBROUTINE W3UNO2s + !/ + !/ End of module W3UNO2MD -------------------------------------------- / + !/ +END MODULE W3UNO2MD !/ diff --git a/model/src/w3uostmd.F90 b/model/src/w3uostmd.F90 index 0efb0d6d8..35494b321 100644 --- a/model/src/w3uostmd.F90 +++ b/model/src/w3uostmd.F90 @@ -1,962 +1,961 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3UOSTMD -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 08-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ 18-Sep-2019 : Added UNIT_AB and changed unit ( version 7.06 ) -!/ number to 110 (C. Bunney, UKMO) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : Parmeterization of the unresoled obstacles -! -! 2. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! UOST_INITGRID Subr. Public allocates UOST variables on each grid, -! and loads the matrices of alpha and beta coefficient -! UOST_SETGRID Subr. Public sets the actual computation grid in the source term -! UOST_SRCTRMCOMPUTE Subr. Public computes the source term for a given input spectrum -! ---------------------------------------------------------------- -! -! 3. Switches : -! -! 4. Source code : -!/ -!/ ------------------------------------------------------------------- / -!/ - - USE W3GDATMD, ONLY: GRID, SGRD, GRIDS, SGRDS - USE W3ODATMD, ONLY: NDSO, NDSE - USE W3SERVMD, ONLY: EXTCDE +MODULE W3UOSTMD + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 08-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ 18-Sep-2019 : Added UNIT_AB and changed unit ( version 7.06 ) + !/ number to 110 (C. Bunney, UKMO) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : Parmeterization of the unresoled obstacles + ! + ! 2. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! UOST_INITGRID Subr. Public allocates UOST variables on each grid, + ! and loads the matrices of alpha and beta coefficient + ! UOST_SETGRID Subr. Public sets the actual computation grid in the source term + ! UOST_SRCTRMCOMPUTE Subr. Public computes the source term for a given input spectrum + ! ---------------------------------------------------------------- + ! + ! 3. Switches : + ! + ! 4. Source code : + !/ + !/ ------------------------------------------------------------------- / + !/ + + USE W3GDATMD, ONLY: GRID, SGRD, GRIDS, SGRDS + USE W3ODATMD, ONLY: NDSO, NDSE + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - IMPLICIT NONE - - PUBLIC :: UOST_INITGRID - PUBLIC :: UOST_SETGRID - PUBLIC :: UOST_SRCTRMCOMPUTE - - - PRIVATE - - - TYPE UOST_SOURCETERM - REAL, ALLOCATABLE :: COSTH(:), SINTH(:) - REAL :: GAMMAUP = 10 - REAL :: GAMMADOWN = 20 - ! griddata is a pointer to the grid actually computed - TYPE(GRID), POINTER :: GRD - TYPE(SGRD), POINTER :: SGD - CONTAINS - !PROCEDURE, PASS, PRIVATE :: COMPUTE_PSI => UOST_SOURCETERM_COMPUTE_PSI - - !compute_ld: estimates the local dissipation (private method) - PROCEDURE, PASS, PRIVATE :: COMPUTE_LD => UOST_SOURCETERM_COMPUTE_LD - !compute_se: estimates the shadow effect (private method) - PROCEDURE, PASS, PRIVATE :: COMPUTE_SE => UOST_SOURCETERM_COMPUTE_SE - !compute: estimates the whole dissipation - PROCEDURE, PASS :: COMPUTE => UOST_SOURCETERM_COMPUTE - !setgrid: sets grd pointer and computes some cached structures - PROCEDURE, PASS :: SETGRID => UOST_SOURCETERM_SETGRID - END TYPE UOST_SOURCETERM - - ! srctrm: global singleton source term - CLASS(UOST_SOURCETERM), ALLOCATABLE :: SRCTRM - - INTEGER, PARAMETER :: UNIT_AB = 110 ! Unit number for LOAD_ALPHABETA - - - CONTAINS - - -!/ ------------------------------------------------------------------- / - SUBROUTINE UOST_INITGRID(IGRID, FILELOCAL, FILESHADOW, LOCALFACTOR, SHADOWFACTOR) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 01-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ -! 1. Purpose : allocate the UOST variables for a given grid, and load -! them from file -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IGRID, integer: id of the grid being initialized -! FILELOCAL, string: file from where the alpha/beta coefficient -! for the local dissipation are loaded -! FILESHADOW, string: file from where the alpha/beta coefficient -! for the shadow effect are loaded -! LOCALFACTOR, double: adjustment parameter for the local -! dissipation alpha and beta -! SHADOWFACTOR, double: adjustment parameter for the shadow -! dissipation alpha and beta -! ---------------------------------------------------------------- -! -! 3. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Initialization of grid objects -! ---------------------------------------------------------------- -! -! 4. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IGRID - CHARACTER(LEN=*), INTENT(IN) :: FILELOCAL, FILESHADOW - REAL, INTENT(IN) :: LOCALFACTOR, SHADOWFACTOR - TYPE(GRID), POINTER :: GRD - TYPE(SGRD), POINTER :: SGD - REAL :: CGMAX, MINSIZE + IMPLICIT NONE + + PUBLIC :: UOST_INITGRID + PUBLIC :: UOST_SETGRID + PUBLIC :: UOST_SRCTRMCOMPUTE + + + PRIVATE + + + TYPE UOST_SOURCETERM + REAL, ALLOCATABLE :: COSTH(:), SINTH(:) + REAL :: GAMMAUP = 10 + REAL :: GAMMADOWN = 20 + ! griddata is a pointer to the grid actually computed + TYPE(GRID), POINTER :: GRD + TYPE(SGRD), POINTER :: SGD + CONTAINS + !PROCEDURE, PASS, PRIVATE :: COMPUTE_PSI => UOST_SOURCETERM_COMPUTE_PSI + + !compute_ld: estimates the local dissipation (private method) + PROCEDURE, PASS, PRIVATE :: COMPUTE_LD => UOST_SOURCETERM_COMPUTE_LD + !compute_se: estimates the shadow effect (private method) + PROCEDURE, PASS, PRIVATE :: COMPUTE_SE => UOST_SOURCETERM_COMPUTE_SE + !compute: estimates the whole dissipation + PROCEDURE, PASS :: COMPUTE => UOST_SOURCETERM_COMPUTE + !setgrid: sets grd pointer and computes some cached structures + PROCEDURE, PASS :: SETGRID => UOST_SOURCETERM_SETGRID + END TYPE UOST_SOURCETERM + + ! srctrm: global singleton source term + CLASS(UOST_SOURCETERM), ALLOCATABLE :: SRCTRM + + INTEGER, PARAMETER :: UNIT_AB = 110 ! Unit number for LOAD_ALPHABETA + + +CONTAINS + + + !/ ------------------------------------------------------------------- / + SUBROUTINE UOST_INITGRID(IGRID, FILELOCAL, FILESHADOW, LOCALFACTOR, SHADOWFACTOR) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 01-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ + ! 1. Purpose : allocate the UOST variables for a given grid, and load + ! them from file + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IGRID, integer: id of the grid being initialized + ! FILELOCAL, string: file from where the alpha/beta coefficient + ! for the local dissipation are loaded + ! FILESHADOW, string: file from where the alpha/beta coefficient + ! for the shadow effect are loaded + ! LOCALFACTOR, double: adjustment parameter for the local + ! dissipation alpha and beta + ! SHADOWFACTOR, double: adjustment parameter for the shadow + ! dissipation alpha and beta + ! ---------------------------------------------------------------- + ! + ! 3. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Initialization of grid objects + ! ---------------------------------------------------------------- + ! + ! 4. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IGRID + CHARACTER(LEN=*), INTENT(IN) :: FILELOCAL, FILESHADOW + REAL, INTENT(IN) :: LOCALFACTOR, SHADOWFACTOR + TYPE(GRID), POINTER :: GRD + TYPE(SGRD), POINTER :: SGD + REAL :: CGMAX, MINSIZE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'UOST_INITGRID') + CALL STRACE (IENT, 'UOST_INITGRID') #endif - IF ( (IGRID .LE. 0) .OR. (.NOT. ALLOCATED(GRIDS)) ) THEN - RETURN - ENDIF - - GRD => GRIDS(IGRID) - SGD => SGRDS(IGRID) - GRD%UOSTFILELOCAL = FILELOCAL - GRD%UOSTFILESHADOW = FILESHADOW - GRD%UOSTLOCALFACTOR = LOCALFACTOR - GRD%UOSTSHADOWFACTOR = SHADOWFACTOR - - ALLOCATE( GRD%UOST_LCL_OBSTRUCTED(GRD%NX, GRD%NY) ) - GRD%UOST_LCL_OBSTRUCTED = .FALSE. - ALLOCATE( GRD%UOST_SHD_OBSTRUCTED(GRD%NX, GRD%NY) ) - GRD%UOST_SHD_OBSTRUCTED = .FALSE. - ALLOCATE( GRD%UOSTCELLSIZE(GRD%NX, GRD%NY, SGD%NTH) ) - GRD%UOSTCELLSIZE = 0 - ALLOCATE( GRD%UOSTLOCALALPHA(GRD%NX, GRD%NY, SGD%NK, SGD%NTH) ) - GRD%UOSTLOCALALPHA = 100 - ALLOCATE( GRD%UOSTLOCALBETA(GRD%NX, GRD%NY, SGD%NK, SGD%NTH) ) - GRD%UOSTLOCALBETA = 100 - ALLOCATE( GRD%UOSTSHADOWALPHA(GRD%NX, GRD%NY, SGD%NK, SGD%NTH) ) - GRD%UOSTSHADOWALPHA = 100 - ALLOCATE( GRD%UOSTSHADOWBETA(GRD%NX, GRD%NY, SGD%NK, SGD%NTH) ) - GRD%UOSTSHADOWBETA = 100 - - - IF ( (IGRID .GT. 0) .AND. ( ALLOCATED(SRCTRM)) ) THEN - ! loading local/shadow alpha/beta - CALL LOAD_ALPHABETA(GRD, SGD, UNIT_AB) - - ! warning the user that for cells too small UOST may be inaccurate - CGMAX = 20 ! simply taking a high value for the max group velocity to give an indication of this threshold - MINSIZE = CGMAX*GRD%DTMAX/1000 - WRITE(NDSO,*)'*** WAVEWATCH-III WARNING IN W3UOST/UOST_INITGRID' - WRITE(NDSO,*)'UOST: grid ',TRIM(GRD%GNAME),':' - WRITE(NDSO,*)' global time step == ', GRD%DTMAX, ' s' - WRITE(NDSO,*)' FOR CELLS SMALLER THAN ABOUT ', MINSIZE, & - ' KM UOST MAY UNDERESTIMATE THE DISSIPATION' - WRITE(NDSO,*) - ENDIF - END SUBROUTINE UOST_INITGRID - - - -!/ ------------------------------------------------------------------- / - SUBROUTINE UOST_SETGRID(IGRID) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 01-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ -! 1. Purpose : sets the current grid in the sourceterm object -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IGRID, integer: id of the actual grid -! ---------------------------------------------------------------- -! -! 3. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Initialization of grid objects -! W3WAVE Subr. W3WAVEMD Initialization of grid objects -! before computation -! ---------------------------------------------------------------- -! -! 4. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IGRID + IF ( (IGRID .LE. 0) .OR. (.NOT. ALLOCATED(GRIDS)) ) THEN + RETURN + ENDIF + + GRD => GRIDS(IGRID) + SGD => SGRDS(IGRID) + GRD%UOSTFILELOCAL = FILELOCAL + GRD%UOSTFILESHADOW = FILESHADOW + GRD%UOSTLOCALFACTOR = LOCALFACTOR + GRD%UOSTSHADOWFACTOR = SHADOWFACTOR + + ALLOCATE( GRD%UOST_LCL_OBSTRUCTED(GRD%NX, GRD%NY) ) + GRD%UOST_LCL_OBSTRUCTED = .FALSE. + ALLOCATE( GRD%UOST_SHD_OBSTRUCTED(GRD%NX, GRD%NY) ) + GRD%UOST_SHD_OBSTRUCTED = .FALSE. + ALLOCATE( GRD%UOSTCELLSIZE(GRD%NX, GRD%NY, SGD%NTH) ) + GRD%UOSTCELLSIZE = 0 + ALLOCATE( GRD%UOSTLOCALALPHA(GRD%NX, GRD%NY, SGD%NK, SGD%NTH) ) + GRD%UOSTLOCALALPHA = 100 + ALLOCATE( GRD%UOSTLOCALBETA(GRD%NX, GRD%NY, SGD%NK, SGD%NTH) ) + GRD%UOSTLOCALBETA = 100 + ALLOCATE( GRD%UOSTSHADOWALPHA(GRD%NX, GRD%NY, SGD%NK, SGD%NTH) ) + GRD%UOSTSHADOWALPHA = 100 + ALLOCATE( GRD%UOSTSHADOWBETA(GRD%NX, GRD%NY, SGD%NK, SGD%NTH) ) + GRD%UOSTSHADOWBETA = 100 + + + IF ( (IGRID .GT. 0) .AND. ( ALLOCATED(SRCTRM)) ) THEN + ! loading local/shadow alpha/beta + CALL LOAD_ALPHABETA(GRD, SGD, UNIT_AB) + + ! warning the user that for cells too small UOST may be inaccurate + CGMAX = 20 ! simply taking a high value for the max group velocity to give an indication of this threshold + MINSIZE = CGMAX*GRD%DTMAX/1000 + WRITE(NDSO,*)'*** WAVEWATCH-III WARNING IN W3UOST/UOST_INITGRID' + WRITE(NDSO,*)'UOST: grid ',TRIM(GRD%GNAME),':' + WRITE(NDSO,*)' global time step == ', GRD%DTMAX, ' s' + WRITE(NDSO,*)' FOR CELLS SMALLER THAN ABOUT ', MINSIZE, & + ' KM UOST MAY UNDERESTIMATE THE DISSIPATION' + WRITE(NDSO,*) + ENDIF + END SUBROUTINE UOST_INITGRID + + + + !/ ------------------------------------------------------------------- / + SUBROUTINE UOST_SETGRID(IGRID) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 01-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ + ! 1. Purpose : sets the current grid in the sourceterm object + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IGRID, integer: id of the actual grid + ! ---------------------------------------------------------------- + ! + ! 3. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Initialization of grid objects + ! W3WAVE Subr. W3WAVEMD Initialization of grid objects + ! before computation + ! ---------------------------------------------------------------- + ! + ! 4. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IGRID #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'UOST_SETGRID') + CALL STRACE (IENT, 'UOST_SETGRID') #endif - IF ( .NOT. ALLOCATED(SRCTRM) ) THEN - ALLOCATE(SRCTRM) - ENDIF - - CALL SRCTRM%SETGRID(GRIDS(IGRID), SGRDS(IGRID)) - END SUBROUTINE UOST_SETGRID -!/ ------------------------------------------------------------------- / - - -!/ ------------------------------------------------------------------- / - SUBROUTINE UOST_SRCTRMCOMPUTE(IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 01-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ -! 1. Purpose : estimates the UOST source term for a give spectrum -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IGRID, integer: id of the actual grid -! ---------------------------------------------------------------- -! -! 3. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SRCE Subr. W3SRCEMD Computation of the source terms -! ---------------------------------------------------------------- -! -! 4. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IX, IY - REAL, INTENT(IN) :: DT - REAL, INTENT(IN) :: SPEC(SRCTRM%SGD%NSPEC), CG(SRCTRM%SGD%NK) - REAL, INTENT(IN) :: U10ABS, U10DIR - REAL, INTENT(OUT) :: S(SRCTRM%SGD%NSPEC), D(SRCTRM%SGD%NSPEC) + IF ( .NOT. ALLOCATED(SRCTRM) ) THEN + ALLOCATE(SRCTRM) + ENDIF + + CALL SRCTRM%SETGRID(GRIDS(IGRID), SGRDS(IGRID)) + END SUBROUTINE UOST_SETGRID + !/ ------------------------------------------------------------------- / + + + !/ ------------------------------------------------------------------- / + SUBROUTINE UOST_SRCTRMCOMPUTE(IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 01-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ + ! 1. Purpose : estimates the UOST source term for a give spectrum + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IGRID, integer: id of the actual grid + ! ---------------------------------------------------------------- + ! + ! 3. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SRCE Subr. W3SRCEMD Computation of the source terms + ! ---------------------------------------------------------------- + ! + ! 4. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IX, IY + REAL, INTENT(IN) :: DT + REAL, INTENT(IN) :: SPEC(SRCTRM%SGD%NSPEC), CG(SRCTRM%SGD%NK) + REAL, INTENT(IN) :: U10ABS, U10DIR + REAL, INTENT(OUT) :: S(SRCTRM%SGD%NSPEC), D(SRCTRM%SGD%NSPEC) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'UOST_SRCTRMCOMPUTE') + CALL STRACE (IENT, 'UOST_SRCTRMCOMPUTE') #endif - CALL SRCTRM%COMPUTE(IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) - END SUBROUTINE UOST_SRCTRMCOMPUTE - -!/ ------------------------------------------------------------------- / - SUBROUTINE LOAD_ALPHABETA(GRD, SGD, FILEUNIT) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 01-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ -! 1. Purpose : loads local and shadow alpha and beta from files -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! GRD, GRID type: object representing the spatial grid to -! be loaded -! SGD, SGRD type: object representing the current spectral grid -! FILEUNIT, Integer: unit id of the input files -! ---------------------------------------------------------------- -! -! 3. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! UOST_INITGRID Subr. W3UOSTMD Initialization of the UOST grid -! ---------------------------------------------------------------- -! -! 4. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - TYPE(GRID), INTENT(INOUT) :: GRD - TYPE(SGRD), INTENT(IN) :: SGD - INTEGER, INTENT(IN) :: FILEUNIT - CHARACTER(256) :: FILENAME - LOGICAL :: FILEEXISTS - INTEGER :: JG, J, L, I, IX, IY + CALL SRCTRM%COMPUTE(IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) + END SUBROUTINE UOST_SRCTRMCOMPUTE + + !/ ------------------------------------------------------------------- / + SUBROUTINE LOAD_ALPHABETA(GRD, SGD, FILEUNIT) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 01-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ + ! 1. Purpose : loads local and shadow alpha and beta from files + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! GRD, GRID type: object representing the spatial grid to + ! be loaded + ! SGD, SGRD type: object representing the current spectral grid + ! FILEUNIT, Integer: unit id of the input files + ! ---------------------------------------------------------------- + ! + ! 3. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! UOST_INITGRID Subr. W3UOSTMD Initialization of the UOST grid + ! ---------------------------------------------------------------- + ! + ! 4. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + TYPE(GRID), INTENT(INOUT) :: GRD + TYPE(SGRD), INTENT(IN) :: SGD + INTEGER, INTENT(IN) :: FILEUNIT + CHARACTER(256) :: FILENAME + LOGICAL :: FILEEXISTS + INTEGER :: JG, J, L, I, IX, IY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'LOAD_ALPHABETA') + CALL STRACE (IENT, 'LOAD_ALPHABETA') #endif - - - ! LOADING LOCAL ALPHA/BETA - FILENAME = GRD%UOSTFILELOCAL - INQUIRE(FILE=FILENAME, EXIST=FILEEXISTS) - - J = LEN_TRIM(FILENAME) - IF (.NOT. FILEEXISTS) THEN - WRITE(NDSE,*)'*** WAVEWATCH III ERROR IN W3UOST: '// & - 'FILE '//FILENAME(:J)//' NOT FOUND. QUITTING' - CALL EXTCDE (9999) - ENDIF - WRITE(NDSO,*)'FILE '//FILENAME(:J)//' FOUND.'// & - 'LOADING UOST SETTINGS FOR GRID '//GRD%GNAME - - CALL LOAD_ALPHABETA_FROMFILE(FILEUNIT, FILENAME(:J), GRD%NX, GRD%NY, SGD%NK, SGD%NTH,& - GRD%UOSTABMULTFACTOR, GRD%UOSTLOCALALPHA, GRD%UOSTLOCALBETA,& - GRD%UOSTCELLSIZE, GRD%UOST_LCL_OBSTRUCTED) - - - ! LOADING SHADOW ALPHA/BETA - FILENAME = GRD%UOSTFILESHADOW - INQUIRE(FILE=FILENAME, EXIST=FILEEXISTS) - - J = LEN_TRIM(FILENAME) - IF (.NOT. FILEEXISTS) THEN - WRITE(NDSE,*)'*** WAVEWATCH III ERROR IN W3UOST: '// & - 'FILE '//FILENAME(:J)//' NOT FOUND. QUITTING' - CALL EXTCDE (9999) - ENDIF - WRITE(NDSO,*)'FILE '//FILENAME(:J)//' FOUND.'//& - 'LOADING UOST SETTINGS FOR GRID '//GRD%GNAME - - CALL LOAD_ALPHABETA_FROMFILE(FILEUNIT, FILENAME(:J), GRD%NX, GRD%NY, SGD%NK, SGD%NTH,& - GRD%UOSTABMULTFACTOR, GRD%UOSTSHADOWALPHA, GRD%UOSTSHADOWBETA,& - GRD%UOSTCELLSIZE, GRD%UOST_SHD_OBSTRUCTED) - - - END SUBROUTINE LOAD_ALPHABETA - -!/ ------------------------------------------------------------------- / - SUBROUTINE LOAD_ALPHABETA_FROMFILE(FILEUNIT, FILENAME, NX, NY, NK, NTH,& - MULTFACTOR, ALPHAMTX, BETAMTX, CELLSIZE, ISOBSTRUCTED) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 01-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ -! 1. Purpose : loads alpha and beta from a single obstructions file -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FILEUNIT, Integer: unit of the file to be opened -! FILENAME, string: name of the file -! NX, NY, NK, NTH, Integer: size of the spatial/spectral grid -! MULTFACTOR, REAL: multiplication factor for alpha and beta: -! alpha and beta should be real in [0,1] -! but to save memory the are stored in Integer*1 -! ALPHAMTX, BETAMTX, Integer*1: loaded alpha and beta spatial/spectral matrices -! CELLSIZE, REAL, REAL: cell size for each spectral direction, -! also loaded from the file -! ISOBSTRUCTED, LOGICAL: matrix of logicals, indicating for each cell -! if it is obstructed or not -! ---------------------------------------------------------------- -! -! 3. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! LOAD_ALPHABETA Subr. W3UOSTMD Initialization of the UOST grid -! ---------------------------------------------------------------- -! -! 4. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - CHARACTER(*), INTENT(IN) :: FILENAME - REAL, INTENT(IN) :: MULTFACTOR - INTEGER, INTENT(IN) :: FILEUNIT, NX, NY, NK, NTH - INTEGER*1, INTENT(INOUT) :: ALPHAMTX(:,:,:,:), BETAMTX(:,:,:,:) - REAL*4, INTENT(INOUT) :: CELLSIZE(:,:,:) - LOGICAL, INTENT(INOUT) :: ISOBSTRUCTED(:,:) - CHARACTER(LEN=600) :: LINE - INTEGER :: FIOSTAT - LOGICAL :: HEADER, FILESTART, READINGCELLSIZE, READINGALPHA - INTEGER :: IX, IY, SPGRDS_SIZE, IK - REAL, ALLOCATABLE :: TRANS(:) + + + ! LOADING LOCAL ALPHA/BETA + FILENAME = GRD%UOSTFILELOCAL + INQUIRE(FILE=FILENAME, EXIST=FILEEXISTS) + + J = LEN_TRIM(FILENAME) + IF (.NOT. FILEEXISTS) THEN + WRITE(NDSE,*)'*** WAVEWATCH III ERROR IN W3UOST: '// & + 'FILE '//FILENAME(:J)//' NOT FOUND. QUITTING' + CALL EXTCDE (9999) + ENDIF + WRITE(NDSO,*)'FILE '//FILENAME(:J)//' FOUND.'// & + 'LOADING UOST SETTINGS FOR GRID '//GRD%GNAME + + CALL LOAD_ALPHABETA_FROMFILE(FILEUNIT, FILENAME(:J), GRD%NX, GRD%NY, SGD%NK, SGD%NTH,& + GRD%UOSTABMULTFACTOR, GRD%UOSTLOCALALPHA, GRD%UOSTLOCALBETA,& + GRD%UOSTCELLSIZE, GRD%UOST_LCL_OBSTRUCTED) + + + ! LOADING SHADOW ALPHA/BETA + FILENAME = GRD%UOSTFILESHADOW + INQUIRE(FILE=FILENAME, EXIST=FILEEXISTS) + + J = LEN_TRIM(FILENAME) + IF (.NOT. FILEEXISTS) THEN + WRITE(NDSE,*)'*** WAVEWATCH III ERROR IN W3UOST: '// & + 'FILE '//FILENAME(:J)//' NOT FOUND. QUITTING' + CALL EXTCDE (9999) + ENDIF + WRITE(NDSO,*)'FILE '//FILENAME(:J)//' FOUND.'//& + 'LOADING UOST SETTINGS FOR GRID '//GRD%GNAME + + CALL LOAD_ALPHABETA_FROMFILE(FILEUNIT, FILENAME(:J), GRD%NX, GRD%NY, SGD%NK, SGD%NTH,& + GRD%UOSTABMULTFACTOR, GRD%UOSTSHADOWALPHA, GRD%UOSTSHADOWBETA,& + GRD%UOSTCELLSIZE, GRD%UOST_SHD_OBSTRUCTED) + + + END SUBROUTINE LOAD_ALPHABETA + + !/ ------------------------------------------------------------------- / + SUBROUTINE LOAD_ALPHABETA_FROMFILE(FILEUNIT, FILENAME, NX, NY, NK, NTH,& + MULTFACTOR, ALPHAMTX, BETAMTX, CELLSIZE, ISOBSTRUCTED) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 01-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ + ! 1. Purpose : loads alpha and beta from a single obstructions file + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FILEUNIT, Integer: unit of the file to be opened + ! FILENAME, string: name of the file + ! NX, NY, NK, NTH, Integer: size of the spatial/spectral grid + ! MULTFACTOR, REAL: multiplication factor for alpha and beta: + ! alpha and beta should be real in [0,1] + ! but to save memory the are stored in Integer*1 + ! ALPHAMTX, BETAMTX, Integer*1: loaded alpha and beta spatial/spectral matrices + ! CELLSIZE, REAL, REAL: cell size for each spectral direction, + ! also loaded from the file + ! ISOBSTRUCTED, LOGICAL: matrix of logicals, indicating for each cell + ! if it is obstructed or not + ! ---------------------------------------------------------------- + ! + ! 3. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! LOAD_ALPHABETA Subr. W3UOSTMD Initialization of the UOST grid + ! ---------------------------------------------------------------- + ! + ! 4. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + CHARACTER(*), INTENT(IN) :: FILENAME + REAL, INTENT(IN) :: MULTFACTOR + INTEGER, INTENT(IN) :: FILEUNIT, NX, NY, NK, NTH + INTEGER*1, INTENT(INOUT) :: ALPHAMTX(:,:,:,:), BETAMTX(:,:,:,:) + REAL*4, INTENT(INOUT) :: CELLSIZE(:,:,:) + LOGICAL, INTENT(INOUT) :: ISOBSTRUCTED(:,:) + CHARACTER(LEN=600) :: LINE + INTEGER :: FIOSTAT + LOGICAL :: HEADER, FILESTART, READINGCELLSIZE, READINGALPHA + INTEGER :: IX, IY, SPGRDS_SIZE, IK + REAL, ALLOCATABLE :: TRANS(:) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'LOAD_ALPHABETA_FROMFILE') + CALL STRACE (IENT, 'LOAD_ALPHABETA_FROMFILE') #endif - - ! INITIALIZING LOGICALS REPRESENTING THE DIFFERENT PHASES OF THE LOAD - FILESTART = .TRUE. - HEADER = .TRUE.; - READINGCELLSIZE = .FALSE. - READINGALPHA = .FALSE. - IK = 0 - - ALLOCATE(TRANS(NTH)) - - OPEN(FILEUNIT, FILE=FILENAME, STATUS='OLD', ACTION='READ') - READ_LOOP: DO - READ(FILEUNIT, '(A)', IOSTAT=FIOSTAT) LINE - - IF (FIOSTAT .NE. 0) EXIT READ_LOOP - - IF (LINE(1:1) .EQ. '$') CYCLE - - IF (FILESTART) THEN - ! reading the first line - READ(LINE, '(I5)') SPGRDS_SIZE - FILESTART = .FALSE. - ELSEIF (HEADER) THEN - ! reading the position of an obstructed cell - READ(LINE, *) IX, IY - ISOBSTRUCTED(IX, IY) = .TRUE. + + ! INITIALIZING LOGICALS REPRESENTING THE DIFFERENT PHASES OF THE LOAD + FILESTART = .TRUE. + HEADER = .TRUE.; + READINGCELLSIZE = .FALSE. + READINGALPHA = .FALSE. + IK = 0 + + ALLOCATE(TRANS(NTH)) + + OPEN(FILEUNIT, FILE=FILENAME, STATUS='OLD', ACTION='READ') + READ_LOOP: DO + READ(FILEUNIT, '(A)', IOSTAT=FIOSTAT) LINE + + IF (FIOSTAT .NE. 0) EXIT READ_LOOP + + IF (LINE(1:1) .EQ. '$') CYCLE + + IF (FILESTART) THEN + ! reading the first line + READ(LINE, '(I5)') SPGRDS_SIZE + FILESTART = .FALSE. + ELSEIF (HEADER) THEN + ! reading the position of an obstructed cell + READ(LINE, *) IX, IY + ISOBSTRUCTED(IX, IY) = .TRUE. IF ((IX .GT. NX) .OR. (IY .GT. NY)) THEN WRITE(NDSE,*) '*** WAVEWATCH III ERROR IN W3UOST: '// & - 'GRID INDICES OUT OF RANGE.'// & - 'CHECK FILE '//FILENAME + 'GRID INDICES OUT OF RANGE.'// & + 'CHECK FILE '//FILENAME CALL EXTCDE (9999) ENDIF - ! marking the end of the reading of the header - HEADER = .FALSE. + ! marking the end of the reading of the header + HEADER = .FALSE. + IK = 1 + READINGCELLSIZE = .TRUE. + ELSEIF (READINGCELLSIZE) THEN + ! reading the sizes of the cell + READ(LINE, *) CELLSIZE(IX, IY, :) + READINGCELLSIZE = .FALSE. + READINGALPHA = .TRUE. + ELSE + READ(LINE, *) TRANS + IF (READINGALPHA) THEN + ! reading alpha for frequency IK + ALPHAMTX(IX, IY, IK, :) = NINT(TRANS*MULTFACTOR) + ELSE + ! reading beta for frequency IK + BETAMTX(IX, IY, IK, :) = NINT(TRANS*MULTFACTOR) + ENDIF + IF (IK .LT. NK) THEN + IK = IK + 1 + ELSE IF (READINGALPHA) THEN + ! preparing to read the next cell + READINGALPHA = .FALSE. + IK = 1 + ELSE + HEADER = .TRUE. IK = 1 - READINGCELLSIZE = .TRUE. - ELSEIF (READINGCELLSIZE) THEN - ! reading the sizes of the cell - READ(LINE, *) CELLSIZE(IX, IY, :) - READINGCELLSIZE = .FALSE. - READINGALPHA = .TRUE. - ELSE - READ(LINE, *) TRANS - IF (READINGALPHA) THEN - ! reading alpha for frequency IK - ALPHAMTX(IX, IY, IK, :) = NINT(TRANS*MULTFACTOR) - ELSE - ! reading beta for frequency IK - BETAMTX(IX, IY, IK, :) = NINT(TRANS*MULTFACTOR) - ENDIF - IF (IK .LT. NK) THEN - IK = IK + 1 - ELSE IF (READINGALPHA) THEN - ! preparing to read the next cell - READINGALPHA = .FALSE. - IK = 1 - ELSE - HEADER = .TRUE. - IK = 1 - ENDIF ENDIF - ENDDO READ_LOOP - CLOSE(FILEUNIT) - - DEALLOCATE(TRANS) - - END SUBROUTINE LOAD_ALPHABETA_FROMFILE - -!/ ------------------------------------------------------------------- / - - SUBROUTINE UOST_SOURCETERM_SETGRID(THIS, GRD, SGD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 01-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ -! 1. Purpose : method of the class UOST_SOURCETERM, -! to set the actual spatial and spectral grid -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! GRD, GRID type: object representing the spatial grid to -! be loaded -! SGD, SGRD type: object representing the current spectral grid -! ---------------------------------------------------------------- -! -! 3. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! UOST_SETGRID Subr. W3UOSTMD Setting the actual computation grid -! ---------------------------------------------------------------- -! -! 4. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - CLASS(UOST_SOURCETERM), INTENT(INOUT) :: THIS - TYPE(GRID), TARGET, INTENT(IN) :: GRD - TYPE(SGRD), TARGET, INTENT(IN) :: SGD - INTEGER :: ITH, NTH + ENDIF + ENDDO READ_LOOP + CLOSE(FILEUNIT) + + DEALLOCATE(TRANS) + + END SUBROUTINE LOAD_ALPHABETA_FROMFILE + + !/ ------------------------------------------------------------------- / + + SUBROUTINE UOST_SOURCETERM_SETGRID(THIS, GRD, SGD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 01-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ + ! 1. Purpose : method of the class UOST_SOURCETERM, + ! to set the actual spatial and spectral grid + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! GRD, GRID type: object representing the spatial grid to + ! be loaded + ! SGD, SGRD type: object representing the current spectral grid + ! ---------------------------------------------------------------- + ! + ! 3. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! UOST_SETGRID Subr. W3UOSTMD Setting the actual computation grid + ! ---------------------------------------------------------------- + ! + ! 4. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + CLASS(UOST_SOURCETERM), INTENT(INOUT) :: THIS + TYPE(GRID), TARGET, INTENT(IN) :: GRD + TYPE(SGRD), TARGET, INTENT(IN) :: SGD + INTEGER :: ITH, NTH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'UOST_SOURCETERM_SETGRID') + CALL STRACE (IENT, 'UOST_SOURCETERM_SETGRID') #endif - - THIS%GRD => GRD - THIS%SGD => SGD - - IF (ALLOCATED(THIS%COSTH)) THEN - DEALLOCATE(THIS%COSTH) - DEALLOCATE(THIS%SINTH) - ENDIF - - NTH = THIS%SGD%NTH - ALLOCATE(THIS%COSTH(NTH)) - ALLOCATE(THIS%SINTH(NTH)) - DO ITH=1,NTH - THIS%COSTH(ITH) = COS(SGD%TH(ITH)) - THIS%SINTH(ITH) = SIN(SGD%TH(ITH)) - ENDDO - END SUBROUTINE UOST_SOURCETERM_SETGRID - -!/ ------------------------------------------------------------------- / - - - SUBROUTINE COMPUTE_REDUCTION_PSI(U10ABS, U10DIR, CGABS, CGDIR, DT, PSI) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 01-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ -! 1. Purpose : In conditions of wind sea, the effect -! of the unresolved obstacles is reduced. -! Here a reduction psi is computed, as a function of the -! wave age. -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! U10ABS, real: absolute value of U10 -! U10DIR, real: direction of U10 -! CGABS, real: absolute value of the group velocity -! CGDIR, real: direction of the group velocity -! DT, real: time step -! PSI, real: output psi factor -! ---------------------------------------------------------------- -! -! 3. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! UOST_SOURCETERM_COMPUTE_LD Subr. W3UOSTMD Computing the local dissipation -! UOST_SOURCETERM_COMPUTE_SE Subr. W3UOSTMD Computing the shadow effect -! ---------------------------------------------------------------- -! -! 4. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: PI - - IMPLICIT NONE - - REAL, PARAMETER :: TOLERANCE = 0.000001 - REAL, PARAMETER :: WHTHR1 = .5, WHTHR2 = 1.5 - - REAL, INTENT(IN) :: U10ABS, U10DIR, CGABS, CGDIR, DT - REAL, INTENT(OUT) :: PSI - REAL :: THDELTA, CP, WA + + THIS%GRD => GRD + THIS%SGD => SGD + + IF (ALLOCATED(THIS%COSTH)) THEN + DEALLOCATE(THIS%COSTH) + DEALLOCATE(THIS%SINTH) + ENDIF + + NTH = THIS%SGD%NTH + ALLOCATE(THIS%COSTH(NTH)) + ALLOCATE(THIS%SINTH(NTH)) + DO ITH=1,NTH + THIS%COSTH(ITH) = COS(SGD%TH(ITH)) + THIS%SINTH(ITH) = SIN(SGD%TH(ITH)) + ENDDO + END SUBROUTINE UOST_SOURCETERM_SETGRID + + !/ ------------------------------------------------------------------- / + + + SUBROUTINE COMPUTE_REDUCTION_PSI(U10ABS, U10DIR, CGABS, CGDIR, DT, PSI) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 01-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ + ! 1. Purpose : In conditions of wind sea, the effect + ! of the unresolved obstacles is reduced. + ! Here a reduction psi is computed, as a function of the + ! wave age. + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! U10ABS, real: absolute value of U10 + ! U10DIR, real: direction of U10 + ! CGABS, real: absolute value of the group velocity + ! CGDIR, real: direction of the group velocity + ! DT, real: time step + ! PSI, real: output psi factor + ! ---------------------------------------------------------------- + ! + ! 3. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! UOST_SOURCETERM_COMPUTE_LD Subr. W3UOSTMD Computing the local dissipation + ! UOST_SOURCETERM_COMPUTE_SE Subr. W3UOSTMD Computing the shadow effect + ! ---------------------------------------------------------------- + ! + ! 4. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: PI + + IMPLICIT NONE + + REAL, PARAMETER :: TOLERANCE = 0.000001 + REAL, PARAMETER :: WHTHR1 = .5, WHTHR2 = 1.5 + + REAL, INTENT(IN) :: U10ABS, U10DIR, CGABS, CGDIR, DT + REAL, INTENT(OUT) :: PSI + REAL :: THDELTA, CP, WA #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'COMPUTE_REDUCTION_PSI') + CALL STRACE (IENT, 'COMPUTE_REDUCTION_PSI') #endif - ! computing the wave age - THDELTA = ABS(U10DIR - CGDIR) - DO WHILE (THDELTA .GT. PI) - THDELTA = THDELTA - 2*PI - ENDDO - THDELTA = ABS(THDELTA) - IF (PI/2 - THDELTA .GT. TOLERANCE) THEN - CP = CGABS*2 ! this is scrictly valid only in deep water - WA = CP/U10ABS/COS(THDELTA) - ELSE - WA = 9999999 ! a very high number - ENDIF - - IF (WA .LE. WHTHR1) THEN - ! if the wave age is less that 0.5, psi = 0, i.e. - ! no unresolved obstacle is considered - PSI = 0 - ELSEIF ((WA .GT. WHTHR1) .AND. (WA .LT. WHTHR2)) THEN - ! if the wave age is between 0.5 and 1.5 - ! psi scales linearly with WA - PSI = (WA - WHTHR1)/(WHTHR2 - WHTHR1) - ELSE - ! if the wave age is greater than 1.5 psi = 1 - PSI = 1 - ENDIF - - END SUBROUTINE COMPUTE_REDUCTION_PSI - -!/ ------------------------------------------------------------------- / - - SUBROUTINE UOST_SOURCETERM_COMPUTE_LD(THIS, IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 01-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ -! 1. Purpose : Method of the class UOST_SOURCETERM. -! Computation of the local dissipation of the spectrum -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! THIS: UOST_SOURCETERM instance of UOST_SOURCETERM passed to the method -! (compulsory in oo programming) -! IX, IY: Integer coordinates of the actual cell -! SPEC: real input spectrum -! CG: real group velocity -! DT: real time step -! U10ABS: real absolute value of U10 -! U10DIR: real direction of U10 -! S: real source term -! D: real differential of the source term over the spectrum -! ---------------------------------------------------------------- -! -! 3. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! UOST_SOURCETERM_COMPUTE Subr. W3UOSTMD Computing the source term -! ---------------------------------------------------------------- -! -! 4. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - CLASS(UOST_SOURCETERM), INTENT(INOUT) :: THIS - INTEGER, INTENT(IN) :: IX, IY - REAL, INTENT(IN) :: SPEC(THIS%SGD%NSPEC), CG(THIS%SGD%NK) - REAL, INTENT(OUT) :: S(THIS%SGD%NSPEC), D(THIS%SGD%NSPEC) - REAL, INTENT(IN) :: U10ABS, U10DIR - REAL, INTENT(IN) :: DT - - INTEGER :: IK, ITH, ISP, NK, NTH - REAL :: ALPHA, BETA, CGI, CELLSIZE, SPECI, SFC - LOGICAL :: CELLOBSTRUCTED - REAL :: TH, PSI + ! computing the wave age + THDELTA = ABS(U10DIR - CGDIR) + DO WHILE (THDELTA .GT. PI) + THDELTA = THDELTA - 2*PI + ENDDO + THDELTA = ABS(THDELTA) + IF (PI/2 - THDELTA .GT. TOLERANCE) THEN + CP = CGABS*2 ! this is scrictly valid only in deep water + WA = CP/U10ABS/COS(THDELTA) + ELSE + WA = 9999999 ! a very high number + ENDIF + + IF (WA .LE. WHTHR1) THEN + ! if the wave age is less that 0.5, psi = 0, i.e. + ! no unresolved obstacle is considered + PSI = 0 + ELSEIF ((WA .GT. WHTHR1) .AND. (WA .LT. WHTHR2)) THEN + ! if the wave age is between 0.5 and 1.5 + ! psi scales linearly with WA + PSI = (WA - WHTHR1)/(WHTHR2 - WHTHR1) + ELSE + ! if the wave age is greater than 1.5 psi = 1 + PSI = 1 + ENDIF + + END SUBROUTINE COMPUTE_REDUCTION_PSI + + !/ ------------------------------------------------------------------- / + + SUBROUTINE UOST_SOURCETERM_COMPUTE_LD(THIS, IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 01-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ + ! 1. Purpose : Method of the class UOST_SOURCETERM. + ! Computation of the local dissipation of the spectrum + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! THIS: UOST_SOURCETERM instance of UOST_SOURCETERM passed to the method + ! (compulsory in oo programming) + ! IX, IY: Integer coordinates of the actual cell + ! SPEC: real input spectrum + ! CG: real group velocity + ! DT: real time step + ! U10ABS: real absolute value of U10 + ! U10DIR: real direction of U10 + ! S: real source term + ! D: real differential of the source term over the spectrum + ! ---------------------------------------------------------------- + ! + ! 3. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! UOST_SOURCETERM_COMPUTE Subr. W3UOSTMD Computing the source term + ! ---------------------------------------------------------------- + ! + ! 4. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + CLASS(UOST_SOURCETERM), INTENT(INOUT) :: THIS + INTEGER, INTENT(IN) :: IX, IY + REAL, INTENT(IN) :: SPEC(THIS%SGD%NSPEC), CG(THIS%SGD%NK) + REAL, INTENT(OUT) :: S(THIS%SGD%NSPEC), D(THIS%SGD%NSPEC) + REAL, INTENT(IN) :: U10ABS, U10DIR + REAL, INTENT(IN) :: DT + + INTEGER :: IK, ITH, ISP, NK, NTH + REAL :: ALPHA, BETA, CGI, CELLSIZE, SPECI, SFC + LOGICAL :: CELLOBSTRUCTED + REAL :: TH, PSI #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE_LD') + CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE_LD') #endif - S = 0 - D = 0 - - CELLOBSTRUCTED = THIS%GRD%UOST_LCL_OBSTRUCTED(IX, IY) - IF (.NOT. CELLOBSTRUCTED) RETURN - - NK = THIS%SGD%NK - NTH = THIS%SGD%NTH - - DO IK = 1,NK - CGI = CG(IK) - DO ITH = 1,NTH - - ! Getting alpha and beta for local dissipation - ALPHA = THIS%GRD%UOSTLOCALALPHA(IX, IY, IK, ITH)/THIS%GRD%UOSTABMULTFACTOR - ALPHA = MAX(MIN(ALPHA*THIS%GRD%UOSTLOCALFACTOR, 1.), 0.) - BETA = THIS%GRD%UOSTLOCALBETA(IX, IY, IK, ITH)/THIS%GRD%UOSTABMULTFACTOR - BETA = MAX(MIN(BETA*THIS%GRD%UOSTLOCALFACTOR, 1.), 0.) - - - IF (ALPHA .EQ. 1) CYCLE - - ! Getting the size of the cell along direction ith - CELLSIZE = THIS%GRD%UOSTCELLSIZE(IX, IY, ITH)*THIS%GRD%UOSTCELLSIZEFACTOR - - ISP = ITH + (IK-1)*NTH - SPECI = SPEC(ISP) - - TH = THIS%SGD%TH(ITH) - CALL COMPUTE_REDUCTION_PSI(U10ABS, U10DIR, CG(IK), TH, DT, PSI) - - IF (BETA > 0.09) THEN - ! Computing the local dissipation for a partially obstructed cell - SFC = - CGI/CELLSIZE * (1 - BETA)/BETA - ELSE - ! The cell is almost completely obstructed. - ! Dissipating the energy almost completely. - SFC = - CGI/CELLSIZE * THIS%GAMMAUP - ENDIF - - S(ISP) = SFC * SPECI * PSI - D(ISP) = SFC * PSI - ENDDO + S = 0 + D = 0 + + CELLOBSTRUCTED = THIS%GRD%UOST_LCL_OBSTRUCTED(IX, IY) + IF (.NOT. CELLOBSTRUCTED) RETURN + + NK = THIS%SGD%NK + NTH = THIS%SGD%NTH + + DO IK = 1,NK + CGI = CG(IK) + DO ITH = 1,NTH + + ! Getting alpha and beta for local dissipation + ALPHA = THIS%GRD%UOSTLOCALALPHA(IX, IY, IK, ITH)/THIS%GRD%UOSTABMULTFACTOR + ALPHA = MAX(MIN(ALPHA*THIS%GRD%UOSTLOCALFACTOR, 1.), 0.) + BETA = THIS%GRD%UOSTLOCALBETA(IX, IY, IK, ITH)/THIS%GRD%UOSTABMULTFACTOR + BETA = MAX(MIN(BETA*THIS%GRD%UOSTLOCALFACTOR, 1.), 0.) + + + IF (ALPHA .EQ. 1) CYCLE + + ! Getting the size of the cell along direction ith + CELLSIZE = THIS%GRD%UOSTCELLSIZE(IX, IY, ITH)*THIS%GRD%UOSTCELLSIZEFACTOR + + ISP = ITH + (IK-1)*NTH + SPECI = SPEC(ISP) + + TH = THIS%SGD%TH(ITH) + CALL COMPUTE_REDUCTION_PSI(U10ABS, U10DIR, CG(IK), TH, DT, PSI) + + IF (BETA > 0.09) THEN + ! Computing the local dissipation for a partially obstructed cell + SFC = - CGI/CELLSIZE * (1 - BETA)/BETA + ELSE + ! The cell is almost completely obstructed. + ! Dissipating the energy almost completely. + SFC = - CGI/CELLSIZE * THIS%GAMMAUP + ENDIF + + S(ISP) = SFC * SPECI * PSI + D(ISP) = SFC * PSI ENDDO - - END SUBROUTINE UOST_SOURCETERM_COMPUTE_LD - -!/ ------------------------------------------------------------------- / - SUBROUTINE UOST_SOURCETERM_COMPUTE_SE(THIS, IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 01-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ -! 1. Purpose : Method of the class UOST_SOURCETERM. -! Computation of the shadow dissipation of the spectrum -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! THIS: UOST_SOURCETERM instance of UOST_SOURCETERM passed to the method -! (compulsory in oo programming) -! IX, IY: Integer coordinates of the actual cell -! SPEC: real input spectrum -! CG: real group velocity -! DT: real time step -! U10ABS: real absolute value of U10 -! U10DIR: real direction of U10 -! S: real source term -! D: real differential of the source term over the spectrum -! ---------------------------------------------------------------- -! -! 3. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! UOST_SOURCETERM_COMPUTE Subr. W3UOSTMD Computing the source term -! ---------------------------------------------------------------- -! -! 4. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - CLASS(UOST_SOURCETERM), INTENT(INOUT), TARGET :: THIS - INTEGER, INTENT(IN) :: IX, IY - REAL, INTENT(IN) :: SPEC(THIS%SGD%NSPEC), CG(THIS%SGD%NK) - REAL, INTENT(OUT) :: S(THIS%SGD%NSPEC), D(THIS%SGD%NSPEC) - REAL, INTENT(IN) :: U10ABS, U10DIR - REAL, INTENT(IN) :: DT - - INTEGER :: IK, ITH, IS - REAL :: CGI, SPECI, SFC, CELLSIZE, & - SFCLEFT, SFCRIGHT, SFCCENTER, THDIAG, CGDIAG, & - ALPHASH, BETASH, GAMMMA, GG - INTEGER :: N = 8, ITHDIAG, ISP, NK, NTH, NX, NY - LOGICAL :: CELLOBSTRUCTED - REAL :: TH, PSI + ENDDO + + END SUBROUTINE UOST_SOURCETERM_COMPUTE_LD + + !/ ------------------------------------------------------------------- / + SUBROUTINE UOST_SOURCETERM_COMPUTE_SE(THIS, IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 01-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ + ! 1. Purpose : Method of the class UOST_SOURCETERM. + ! Computation of the shadow dissipation of the spectrum + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! THIS: UOST_SOURCETERM instance of UOST_SOURCETERM passed to the method + ! (compulsory in oo programming) + ! IX, IY: Integer coordinates of the actual cell + ! SPEC: real input spectrum + ! CG: real group velocity + ! DT: real time step + ! U10ABS: real absolute value of U10 + ! U10DIR: real direction of U10 + ! S: real source term + ! D: real differential of the source term over the spectrum + ! ---------------------------------------------------------------- + ! + ! 3. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! UOST_SOURCETERM_COMPUTE Subr. W3UOSTMD Computing the source term + ! ---------------------------------------------------------------- + ! + ! 4. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + CLASS(UOST_SOURCETERM), INTENT(INOUT), TARGET :: THIS + INTEGER, INTENT(IN) :: IX, IY + REAL, INTENT(IN) :: SPEC(THIS%SGD%NSPEC), CG(THIS%SGD%NK) + REAL, INTENT(OUT) :: S(THIS%SGD%NSPEC), D(THIS%SGD%NSPEC) + REAL, INTENT(IN) :: U10ABS, U10DIR + REAL, INTENT(IN) :: DT + + INTEGER :: IK, ITH, IS + REAL :: CGI, SPECI, SFC, CELLSIZE, & + SFCLEFT, SFCRIGHT, SFCCENTER, THDIAG, CGDIAG, & + ALPHASH, BETASH, GAMMMA, GG + INTEGER :: N = 8, ITHDIAG, ISP, NK, NTH, NX, NY + LOGICAL :: CELLOBSTRUCTED + REAL :: TH, PSI #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE_SE') + CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE_SE') #endif - - S = 0 - D = 0 - - NK = THIS%SGD%NK - NTH = THIS%SGD%NTH - NX = THIS%GRD%NX - NY = THIS%GRD%NY - - IF ((IX .EQ. 1) .OR. (IX .EQ. NX) .OR. (IY .EQ. 1) .OR. (IY .EQ. NY)) RETURN - - CELLOBSTRUCTED = THIS%GRD%UOST_SHD_OBSTRUCTED(IX, IY) - IF (.NOT. CELLOBSTRUCTED) RETURN - - DO IK=1,NK - DO ITH=1,NTH - - ! Getting alpha and beta of the shadow - ALPHASH = THIS%GRD%UOSTSHADOWALPHA(IX, IY, IK, ITH)/THIS%GRD%UOSTABMULTFACTOR - ALPHASH = MAX(MIN(ALPHASH*THIS%GRD%UOSTSHADOWFACTOR, 1.), 0.) - BETASH = THIS%GRD%UOSTSHADOWBETA(IX, IY, IK, ITH)/THIS%GRD%UOSTABMULTFACTOR - BETASH = MAX(MIN(BETASH*THIS%GRD%UOSTSHADOWFACTOR, 1.), 0.) - - IF (ALPHASH .EQ. 1) CYCLE - - ! Getting the size of the cell along direction ith - CELLSIZE = THIS%GRD%UOSTCELLSIZE(IX, IY, ITH)*THIS%GRD%UOSTCELLSIZEFACTOR - - CGI = CG(IK) - - GG = CGI/CELLSIZE - - IF (ALPHASH > 0.2) THEN - ! Computing the shadow gamma coefficient for a partially obstructed cell - GAMMMA = (BETASH/ALPHASH - 1) - ELSE - ! Alpha is small. The shadow dissipates the energy almost completely - GAMMMA = THIS%GAMMADOWN - ENDIF - - TH = THIS%SGD%TH(ITH) - ! Computing the reduction psi related with the wind component of the spectrum - CALL COMPUTE_REDUCTION_PSI(U10ABS, U10DIR, CG(IK), TH, DT, PSI) - - SFC = - GG*GAMMMA - - ISP = ITH + (IK-1)*NTH - SPECI = SPEC(ISP) - S(ISP) = SFC * SPECI * PSI - D(ISP) = SFC * PSI - ENDDO - ENDDO - END SUBROUTINE UOST_SOURCETERM_COMPUTE_SE - -!/ ------------------------------------------------------------------- / - - SUBROUTINE UOST_SOURCETERM_COMPUTE(THIS, IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Lorenzo Mentaschi | -!/ | FORTRAN 90 | -!/ | Last update : 01-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ Aug-2018 : Origination. ( version 6.07 ) -!/ -! 1. Purpose : Method of the class UOST_SOURCETERM. -! Computation of the source term -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! THIS: UOST_SOURCETERM instance of UOST_SOURCETERM passed to the method -! (compulsory in oo programming) -! IX, IY: Integer coordinates of the actual cell -! SPEC: real input spectrum -! CG: real group velocity -! DT: real time step -! U10ABS: real absolute value of U10 -! U10DIR: real direction of U10 -! S: real source term -! D: real differential of the source term over the spectrum -! ---------------------------------------------------------------- -! -! 3. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! UOST_SRCTRMCOMPUTE Subr. W3UOSTMD Computing the source term -! ---------------------------------------------------------------- -! -! 4. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE - - CLASS(UOST_SOURCETERM), INTENT(INOUT) :: THIS - INTEGER, INTENT(IN) :: IX, IY - REAL, INTENT(IN) :: SPEC(THIS%SGD%NSPEC), CG(THIS%SGD%NK) - REAL, INTENT(IN) :: DT - REAL, INTENT(IN) :: U10ABS, U10DIR - REAL, INTENT(OUT) :: S(THIS%SGD%NSPEC), D(THIS%SGD%NSPEC) - - REAL :: S_LD(THIS%SGD%NSPEC), S_SE(THIS%SGD%NSPEC) - REAL :: D_LD(THIS%SGD%NSPEC), D_SE(THIS%SGD%NSPEC) + + S = 0 + D = 0 + + NK = THIS%SGD%NK + NTH = THIS%SGD%NTH + NX = THIS%GRD%NX + NY = THIS%GRD%NY + + IF ((IX .EQ. 1) .OR. (IX .EQ. NX) .OR. (IY .EQ. 1) .OR. (IY .EQ. NY)) RETURN + + CELLOBSTRUCTED = THIS%GRD%UOST_SHD_OBSTRUCTED(IX, IY) + IF (.NOT. CELLOBSTRUCTED) RETURN + + DO IK=1,NK + DO ITH=1,NTH + + ! Getting alpha and beta of the shadow + ALPHASH = THIS%GRD%UOSTSHADOWALPHA(IX, IY, IK, ITH)/THIS%GRD%UOSTABMULTFACTOR + ALPHASH = MAX(MIN(ALPHASH*THIS%GRD%UOSTSHADOWFACTOR, 1.), 0.) + BETASH = THIS%GRD%UOSTSHADOWBETA(IX, IY, IK, ITH)/THIS%GRD%UOSTABMULTFACTOR + BETASH = MAX(MIN(BETASH*THIS%GRD%UOSTSHADOWFACTOR, 1.), 0.) + + IF (ALPHASH .EQ. 1) CYCLE + + ! Getting the size of the cell along direction ith + CELLSIZE = THIS%GRD%UOSTCELLSIZE(IX, IY, ITH)*THIS%GRD%UOSTCELLSIZEFACTOR + + CGI = CG(IK) + + GG = CGI/CELLSIZE + + IF (ALPHASH > 0.2) THEN + ! Computing the shadow gamma coefficient for a partially obstructed cell + GAMMMA = (BETASH/ALPHASH - 1) + ELSE + ! Alpha is small. The shadow dissipates the energy almost completely + GAMMMA = THIS%GAMMADOWN + ENDIF + + TH = THIS%SGD%TH(ITH) + ! Computing the reduction psi related with the wind component of the spectrum + CALL COMPUTE_REDUCTION_PSI(U10ABS, U10DIR, CG(IK), TH, DT, PSI) + + SFC = - GG*GAMMMA + + ISP = ITH + (IK-1)*NTH + SPECI = SPEC(ISP) + S(ISP) = SFC * SPECI * PSI + D(ISP) = SFC * PSI + ENDDO + ENDDO + END SUBROUTINE UOST_SOURCETERM_COMPUTE_SE + + !/ ------------------------------------------------------------------- / + + SUBROUTINE UOST_SOURCETERM_COMPUTE(THIS, IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Lorenzo Mentaschi | + !/ | FORTRAN 90 | + !/ | Last update : 01-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ Aug-2018 : Origination. ( version 6.07 ) + !/ + ! 1. Purpose : Method of the class UOST_SOURCETERM. + ! Computation of the source term + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! THIS: UOST_SOURCETERM instance of UOST_SOURCETERM passed to the method + ! (compulsory in oo programming) + ! IX, IY: Integer coordinates of the actual cell + ! SPEC: real input spectrum + ! CG: real group velocity + ! DT: real time step + ! U10ABS: real absolute value of U10 + ! U10DIR: real direction of U10 + ! S: real source term + ! D: real differential of the source term over the spectrum + ! ---------------------------------------------------------------- + ! + ! 3. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! UOST_SRCTRMCOMPUTE Subr. W3UOSTMD Computing the source term + ! ---------------------------------------------------------------- + ! + ! 4. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + + CLASS(UOST_SOURCETERM), INTENT(INOUT) :: THIS + INTEGER, INTENT(IN) :: IX, IY + REAL, INTENT(IN) :: SPEC(THIS%SGD%NSPEC), CG(THIS%SGD%NK) + REAL, INTENT(IN) :: DT + REAL, INTENT(IN) :: U10ABS, U10DIR + REAL, INTENT(OUT) :: S(THIS%SGD%NSPEC), D(THIS%SGD%NSPEC) + + REAL :: S_LD(THIS%SGD%NSPEC), S_SE(THIS%SGD%NSPEC) + REAL :: D_LD(THIS%SGD%NSPEC), D_SE(THIS%SGD%NSPEC) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_S - CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE') + CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE') #endif - - IF (.NOT. THIS%GRD%UOSTENABLED) THEN - S = 0 - RETURN - ENDIF - - ! Initializing the LD and SE components - S_LD = 0 - S_SE = 0 - ! Local dissipation - CALL THIS%COMPUTE_LD(IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S_LD, D_LD) - ! Shadow effect - CALL THIS%COMPUTE_SE(IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S_SE, D_SE) - S = S_LD + S_SE - D = D_LD + D_SE - END SUBROUTINE UOST_SOURCETERM_COMPUTE - - -!/ ------------------------------------------------------------------- / - - END MODULE W3UOSTMD - -!/ ------------------------------------------------------------------- / - + + IF (.NOT. THIS%GRD%UOSTENABLED) THEN + S = 0 + RETURN + ENDIF + + ! Initializing the LD and SE components + S_LD = 0 + S_SE = 0 + ! Local dissipation + CALL THIS%COMPUTE_LD(IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S_LD, D_LD) + ! Shadow effect + CALL THIS%COMPUTE_SE(IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S_SE, D_SE) + S = S_LD + S_SE + D = D_LD + D_SE + END SUBROUTINE UOST_SOURCETERM_COMPUTE + + + !/ ------------------------------------------------------------------- / + +END MODULE W3UOSTMD + +!/ ------------------------------------------------------------------- / diff --git a/model/src/w3updtmd.F90 b/model/src/w3updtmd.F90 index aa46f07f1..9a614ec0e 100644 --- a/model/src/w3updtmd.F90 +++ b/model/src/w3updtmd.F90 @@ -1,3292 +1,3292 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3UPDTMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 21-Jan-2000 : Origination. ( version 2.00 ) -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 02-Apr-2001 : Adding sub-grid obstacles. ( version 2.10 ) -!/ 18-May-2001 : Clean up and bug fixes. ( version 2.11 ) -!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) -!/ 30-Apr-2002 : Water level fixes. ( version 2.20 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 26-Dec-2002 : Moving grid wind correction. ( version 3.02 ) -!/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 15-Jul-2005 : Adding MAPST2. ( version 3.07 ) -!/ 07-Sep-2005 : Upgrading W3UBPT. ( version 3.08 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 11-Jan-2007 : Clean-up W3UTRN boundary points. ( version 3.10 ) -!/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 17-Aug-2010 : ABPI0-N(:,0) init. bug fix. ( version 3.14 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 05-Apr-2011 : Place holder for XGR in UNGTYPE ( version 4.04 ) -!/ (A. Roland/F. Ardhuin) -!/ 13-Mar-2012 : Add initialization of UST on re- ( version 4.07 ) -!/ activation of grid point. -!/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.07 ) -!/ 26-Sep-2012 : Adding update from tidal analysis ( version 4.08 ) -!/ (F. Ardhuin) -!/ 16-Sep-2013 : Add Arctic part for SMC grid. ( version 4.11 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 13-Nov-2013 : Moved reflection from ww3_grid.ftn ( version 4.13 ) -!/ 27-May-2014 : Ading OMPG parallelizations dir, ( version 5.02 ) -!/ 08-May-2014 : Implement tripolar grid for first order propagation -!/ scheme ( version 5.03 ) -!/ (W. E. Rogers, NRL) -!/ 27-Aug-2015 : New function to update variables ( version 5.08 ) -!/ ICEF and ICEDMAX at the first time step -!/ and add ICEH initialization in W3UICE. -!/ 13-Jan-2016 : Changed initial value of ICEDMAX ( version 5.08 ) -!/ 26-Mar-2018 : Sea-point only Wnd/Cur input. JGLi ( version 6.04 ) -!/ 07-Oct-2019 : RTD option with standard lat-lon -!/ grid when nesting to rotated grid ( version 7.11 ) -!/ 22-Mar-2021 : Add W3UTAU, W3URHO routines ( version 7.13 ) -!/ 06-May-2021 : Use ARCTC option for SMC grid. JGLi ( version 7.13 ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Bundles all input updating routines for WAVEWATCH III. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3UCUR Subr. Public Update current fields. -! W3UWND Subr. Public Update wind fields. -! W3UTAU Subr. Public Update atmospheric momentum fields. -! W3UINI Subr. Public Update initial conditions. -! W3UBPT Subr. Public Update boundary conditions. -! W3UICE Subr. Public Update ice concentrations. -! W3ULEV Subr. Public Update water levels. -! W3URHO Subr. Public Update air density. -! W3UTRN Subr. Public Update cell boundary transparancies. -! W3DZXY Subr. Public Calculate derivatives of a field. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! DSEC21 Func. W3TIMEMD Difference in time. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Exit program with error code. -! PRTBLK Subr. W3ARRYMD Print plot output. -! PRT2DS Subr. W3ARRYMD Print plot output. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/OMPG OpenMP compiler directives. -! -! !/CRT0 No current interpolation. -! !/CRT1 Linear current interpolation. -! !/CRT2 Quasi-quadratic current interpolation. -! -! !/WNT0 No wind/momentum interpolation. -! !/WNT1 Linear wind/momentum interpolation. -! !/WNT2 Energy conservation in wind/momentum interpolation. -! -! !/RWND Use wind speeds relative to currents. -! -! !/STAB2 Calculate effective wind speed factor for stability -! to be used with !/ST2. -! -! !/S Enable subroutine tracing. -! !/Tn Test output -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3ODATMD, ONLY: NDSE, NDST, NAPROC, IAPROC, NAPERR +MODULE W3UPDTMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 21-Jan-2000 : Origination. ( version 2.00 ) + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 02-Apr-2001 : Adding sub-grid obstacles. ( version 2.10 ) + !/ 18-May-2001 : Clean up and bug fixes. ( version 2.11 ) + !/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) + !/ 30-Apr-2002 : Water level fixes. ( version 2.20 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 26-Dec-2002 : Moving grid wind correction. ( version 3.02 ) + !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 15-Jul-2005 : Adding MAPST2. ( version 3.07 ) + !/ 07-Sep-2005 : Upgrading W3UBPT. ( version 3.08 ) + !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 11-Jan-2007 : Clean-up W3UTRN boundary points. ( version 3.10 ) + !/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 17-Aug-2010 : ABPI0-N(:,0) init. bug fix. ( version 3.14 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 05-Apr-2011 : Place holder for XGR in UNGTYPE ( version 4.04 ) + !/ (A. Roland/F. Ardhuin) + !/ 13-Mar-2012 : Add initialization of UST on re- ( version 4.07 ) + !/ activation of grid point. + !/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) + !/ 12-Jun-2012 : Add /RTD option or rotated grid option. + !/ (Jian-Guo Li) ( version 4.07 ) + !/ 26-Sep-2012 : Adding update from tidal analysis ( version 4.08 ) + !/ (F. Ardhuin) + !/ 16-Sep-2013 : Add Arctic part for SMC grid. ( version 4.11 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 13-Nov-2013 : Moved reflection from ww3_grid.ftn ( version 4.13 ) + !/ 27-May-2014 : Ading OMPG parallelizations dir, ( version 5.02 ) + !/ 08-May-2014 : Implement tripolar grid for first order propagation + !/ scheme ( version 5.03 ) + !/ (W. E. Rogers, NRL) + !/ 27-Aug-2015 : New function to update variables ( version 5.08 ) + !/ ICEF and ICEDMAX at the first time step + !/ and add ICEH initialization in W3UICE. + !/ 13-Jan-2016 : Changed initial value of ICEDMAX ( version 5.08 ) + !/ 26-Mar-2018 : Sea-point only Wnd/Cur input. JGLi ( version 6.04 ) + !/ 07-Oct-2019 : RTD option with standard lat-lon + !/ grid when nesting to rotated grid ( version 7.11 ) + !/ 22-Mar-2021 : Add W3UTAU, W3URHO routines ( version 7.13 ) + !/ 06-May-2021 : Use ARCTC option for SMC grid. JGLi ( version 7.13 ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Bundles all input updating routines for WAVEWATCH III. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3UCUR Subr. Public Update current fields. + ! W3UWND Subr. Public Update wind fields. + ! W3UTAU Subr. Public Update atmospheric momentum fields. + ! W3UINI Subr. Public Update initial conditions. + ! W3UBPT Subr. Public Update boundary conditions. + ! W3UICE Subr. Public Update ice concentrations. + ! W3ULEV Subr. Public Update water levels. + ! W3URHO Subr. Public Update air density. + ! W3UTRN Subr. Public Update cell boundary transparancies. + ! W3DZXY Subr. Public Calculate derivatives of a field. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! DSEC21 Func. W3TIMEMD Difference in time. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Exit program with error code. + ! PRTBLK Subr. W3ARRYMD Print plot output. + ! PRT2DS Subr. W3ARRYMD Print plot output. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/OMPG OpenMP compiler directives. + ! + ! !/CRT0 No current interpolation. + ! !/CRT1 Linear current interpolation. + ! !/CRT2 Quasi-quadratic current interpolation. + ! + ! !/WNT0 No wind/momentum interpolation. + ! !/WNT1 Linear wind/momentum interpolation. + ! !/WNT2 Energy conservation in wind/momentum interpolation. + ! + ! !/RWND Use wind speeds relative to currents. + ! + ! !/STAB2 Calculate effective wind speed factor for stability + ! to be used with !/ST2. + ! + ! !/S Enable subroutine tracing. + ! !/Tn Test output + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3ODATMD, ONLY: NDSE, NDST, NAPROC, IAPROC, NAPERR #ifdef W3_S - USE W3SERVMD, ONLY : STRACE -#endif - USE W3TIMEMD, ONLY: DSEC21 -!/ -!/ ------------------------------------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3UCUR ( FLFRST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 15-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 09-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 27-Aug-2015 : Rename DT0,DTT by DT0T,DT0N ( version 5.10 ) -!/ 23-Mar-2016 : SMC grid Arctic part adjustment. ( version 5.18 ) -!/ 26-Mar-2018 : Sea-point only current on SMC grid. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Interpolate the current field to the present time. -! -! 2. Method : -! -! Linear interpolation of speed and direction, with optionally -! a correction to get approximate quadratic interpolation of speed -! only. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FLFRST Log. I Flag for first pass through routine. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Only currents at sea points are considered. -! - Time ranges checked in W3WAVE. -! - Currents are stored by components to save on the use of -! SIN and COS functions. The actual interpolations, however -! are by absolute value and direction. -! -! 8. Structure : -! -! -------------------------------------- -! 1. Prepare auxiliary arrays. -! 2. Calculate interpolation factors. -! 3. Get actual winds. -! -------------------------------------- -! -! 9. Switches : -! -! !/CRT0 No current interpolation. -! !/CRT1 Linear current interpolation. -! !/CRT2 Quasi-quadratic current interpolation. -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF + USE W3SERVMD, ONLY : STRACE +#endif + USE W3TIMEMD, ONLY: DSEC21 + !/ + !/ ------------------------------------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3UCUR ( FLFRST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 15-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 09-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 27-Aug-2015 : Rename DT0,DTT by DT0T,DT0N ( version 5.10 ) + !/ 23-Mar-2016 : SMC grid Arctic part adjustment. ( version 5.18 ) + !/ 26-Mar-2018 : Sea-point only current on SMC grid. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Interpolate the current field to the present time. + ! + ! 2. Method : + ! + ! Linear interpolation of speed and direction, with optionally + ! a correction to get approximate quadratic interpolation of speed + ! only. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FLFRST Log. I Flag for first pass through routine. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Only currents at sea points are considered. + ! - Time ranges checked in W3WAVE. + ! - Currents are stored by components to save on the use of + ! SIN and COS functions. The actual interpolations, however + ! are by absolute value and direction. + ! + ! 8. Structure : + ! + ! -------------------------------------- + ! 1. Prepare auxiliary arrays. + ! 2. Calculate interpolation factors. + ! 3. Get actual winds. + ! -------------------------------------- + ! + ! 9. Switches : + ! + ! !/CRT0 No current interpolation. + ! !/CRT1 Linear current interpolation. + ! !/CRT2 Quasi-quadratic current interpolation. + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF #ifdef W3_SMC - USE W3GDATMD, ONLY: NARC, NGLO, ANGARC - USE W3GDATMD, ONLY: FSWND, ARCTC + USE W3GDATMD, ONLY: NARC, NGLO, ANGARC + USE W3GDATMD, ONLY: FSWND, ARCTC #endif - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: CX, CY, CA0, CAI, CD0, CDI - USE W3IDATMD, ONLY: TC0, CX0, CY0, TCN, CXN, CYN + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: CX, CY, CA0, CAI, CD0, CDI + USE W3IDATMD, ONLY: TC0, CX0, CY0, TCN, CXN, CYN #ifdef W3_TIDE - USE W3GDATMD, ONLY: YGRD - USE W3TIMEMD - USE W3IDATMD, ONLY: FLCURTIDE, CXTIDE, CYTIDE, NTIDE - USE W3TIDEMD -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - LOGICAL, INTENT(IN) :: FLFRST -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: ISEA, IX, IY + USE W3GDATMD, ONLY: YGRD + USE W3TIMEMD + USE W3IDATMD, ONLY: FLCURTIDE, CXTIDE, CYTIDE, NTIDE + USE W3TIDEMD +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + LOGICAL, INTENT(IN) :: FLFRST + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: ISEA, IX, IY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: D0, DN, DD, DT0N, DT0T, RD, CABS, CDIR + REAL :: D0, DN, DD, DT0N, DT0T, RD, CABS, CDIR #ifdef W3_CRT2 - REAL :: RD2, CI2 + REAL :: RD2, CI2 #endif #ifdef W3_TIDE - INTEGER :: J,K - INTEGER(KIND=4) :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" - REAL :: WCURTIDEX, WCURTIDEY, TIDE_ARGX, TIDE_ARGY - REAL(KIND=8) :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau - REAL :: FX(44),UX(44),VX(44) -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: J,K + INTEGER(KIND=4) :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" + REAL :: WCURTIDEX, WCURTIDEY, TIDE_ARGX, TIDE_ARGY + REAL(KIND=8) :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau + REAL :: FX(44),UX(44),VX(44) +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3UCUR') + CALL STRACE (IENT, 'W3UCUR') #endif -! -! 1. Prepare auxiliary arrays -! - IF ( FLFRST ) THEN - DO ISEA=1, NSEA + ! + ! 1. Prepare auxiliary arrays + ! + IF ( FLFRST ) THEN + DO ISEA=1, NSEA #ifdef W3_SMC - !!Li For sea-point SMC grid current, the 1-D current is stored on - !!Li 2-D CX0(NSEA, 1) variable. + !!Li For sea-point SMC grid current, the 1-D current is stored on + !!Li 2-D CX0(NSEA, 1) variable. IF( FSWND ) THEN - IX = ISEA - IY = 1 + IX = ISEA + IY = 1 ELSE #endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) #ifdef W3_SMC ENDIF #endif - CA0(ISEA) = SQRT ( CX0(IX,IY)**2 + CY0(IX,IY)**2 ) - CAI(ISEA) = SQRT ( CXN(IX,IY)**2 + CYN(IX,IY)**2 ) - IF ( CA0(ISEA) .GT. 1.E-7) THEN - D0 = MOD ( TPI+ATAN2(CY0(IX,IY),CX0(IX,IY)) , TPI ) - ELSE - D0 = 0 - END IF - IF ( CAI(ISEA) .GT. 1.E-7) THEN - DN = MOD ( TPI+ATAN2(CYN(IX,IY),CXN(IX,IY)) , TPI ) - ELSE - DN = D0 - END IF - IF ( CA0(ISEA) .GT. 1.E-7) THEN - CD0(ISEA) = D0 - ELSE - CD0(ISEA) = DN - END IF - DD = DN - CD0(ISEA) - IF (ABS(DD).GT.PI) DD = DD - TPI*SIGN(1.,DD) - CDI(ISEA) = DD - CAI(ISEA) = CAI(ISEA) - CA0(ISEA) - END DO + CA0(ISEA) = SQRT ( CX0(IX,IY)**2 + CY0(IX,IY)**2 ) + CAI(ISEA) = SQRT ( CXN(IX,IY)**2 + CYN(IX,IY)**2 ) + IF ( CA0(ISEA) .GT. 1.E-7) THEN + D0 = MOD ( TPI+ATAN2(CY0(IX,IY),CX0(IX,IY)) , TPI ) + ELSE + D0 = 0 + END IF + IF ( CAI(ISEA) .GT. 1.E-7) THEN + DN = MOD ( TPI+ATAN2(CYN(IX,IY),CXN(IX,IY)) , TPI ) + ELSE + DN = D0 END IF -! -! 2. Calculate interpolation factor -! - DT0N = DSEC21 ( TC0, TCN ) - DT0T = DSEC21 ( TC0, TIME ) -! + IF ( CA0(ISEA) .GT. 1.E-7) THEN + CD0(ISEA) = D0 + ELSE + CD0(ISEA) = DN + END IF + DD = DN - CD0(ISEA) + IF (ABS(DD).GT.PI) DD = DD - TPI*SIGN(1.,DD) + CDI(ISEA) = DD + CAI(ISEA) = CAI(ISEA) - CA0(ISEA) + END DO + END IF + ! + ! 2. Calculate interpolation factor + ! + DT0N = DSEC21 ( TC0, TCN ) + DT0T = DSEC21 ( TC0, TIME ) + ! #ifdef W3_CRT0 - RD = 0. + RD = 0. #endif #ifdef W3_CRT1 - RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD = DT0T / MAX ( 1.E-7 , DT0N ) #endif #ifdef W3_CRT2 - RD = DT0T / MAX ( 1.E-7 , DT0N ) - RD2 = 1. - RD + RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD2 = 1. - RD #endif #ifdef W3_OASOCM - RD = 1. + RD = 1. #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) DT0N, DT0T, RD + WRITE (NDST,9000) DT0N, DT0T, RD #endif #ifdef W3_TIDE - IF (FLCURTIDE) THEN -! WRITE(6,*) 'TIME CUR:',TIME, '##',TC0, '##',TCN - TIDE_HOUR = TIME2HOURS(TIME) -! -!* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION -!* AT THE MID POINT OF THE ANALYSIS PERIOD. - d1=TIDE_HOUR/24.d0 - TIDE_KD0= 2415020 - d1=d1-dfloat(TIDE_kd0)-0.5d0 - call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) - INT24=24 - INTDYS=int((TIDE_HOUR+0.00001)/INT24) - HH=TIDE_HOUR-dfloat(INTDYS*INT24) - TAU=HH/24.D0+H-S - END IF -! -! ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU- -! TING THE LUNAR TIME TAU. -! + IF (FLCURTIDE) THEN + ! WRITE(6,*) 'TIME CUR:',TIME, '##',TC0, '##',TCN + TIDE_HOUR = TIME2HOURS(TIME) + ! + !* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION + !* AT THE MID POINT OF THE ANALYSIS PERIOD. + d1=TIDE_HOUR/24.d0 + TIDE_KD0= 2415020 + d1=d1-dfloat(TIDE_kd0)-0.5d0 + call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) + INT24=24 + INTDYS=int((TIDE_HOUR+0.00001)/INT24) + HH=TIDE_HOUR-dfloat(INTDYS*INT24) + TAU=HH/24.D0+H-S + END IF + ! + ! ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU- + ! TING THE LUNAR TIME TAU. + ! #endif -! -! 3. Actual currents for all grid points -! - DO ISEA=1, NSEA + ! + ! 3. Actual currents for all grid points + ! + DO ISEA=1, NSEA #ifdef W3_TIDE - IF (FLCURTIDE) THEN ! could move IF test outside of ISEA loop ... -! VUF should only be updated in latitude changes significantly ... - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,REAL(YGRD(IY,IX)),FX,UX,VX) - WCURTIDEX = CXTIDE(IX,IY,1,1) - WCURTIDEY = CYTIDE(IX,IY,1,1) - - DO J=2,TIDE_MF - TIDE_ARGX=(VX(J)+UX(J))*twpi-CXTIDE(IX,IY,J,2)*DERA - TIDE_ARGY=(VX(J)+UX(J))*twpi-CYTIDE(IX,IY,J,2)*DERA - WCURTIDEX = WCURTIDEX+FX(J)*CXTIDE(IX,IY,J,1)*COS(TIDE_ARGX) - WCURTIDEY = WCURTIDEY+FX(J)*CYTIDE(IX,IY,J,1)*COS(TIDE_ARGY) - END DO - + IF (FLCURTIDE) THEN ! could move IF test outside of ISEA loop ... + ! VUF should only be updated in latitude changes significantly ... + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,REAL(YGRD(IY,IX)),FX,UX,VX) + WCURTIDEX = CXTIDE(IX,IY,1,1) + WCURTIDEY = CYTIDE(IX,IY,1,1) + + DO J=2,TIDE_MF + TIDE_ARGX=(VX(J)+UX(J))*twpi-CXTIDE(IX,IY,J,2)*DERA + TIDE_ARGY=(VX(J)+UX(J))*twpi-CYTIDE(IX,IY,J,2)*DERA + WCURTIDEX = WCURTIDEX+FX(J)*CXTIDE(IX,IY,J,1)*COS(TIDE_ARGX) + WCURTIDEY = WCURTIDEY+FX(J)*CYTIDE(IX,IY,J,1)*COS(TIDE_ARGY) + END DO + #endif #ifdef W3_TIDET - !Verification - IF (ISEA.EQ.1) THEN + !Verification + IF (ISEA.EQ.1) THEN - TIDE_AMPC(1:NTIDE,1)=CXTIDE(IX,IY,1:NTIDE,1) - TIDE_PHG(1:NTIDE,1 )=CXTIDE(IX,IY,1:NTIDE,2) - TIDE_AMPC(1:NTIDE,2)=CYTIDE(IX,IY,1:NTIDE,1) - TIDE_PHG(1:NTIDE,2) =CYTIDE(IX,IY,1:NTIDE,2) + TIDE_AMPC(1:NTIDE,1)=CXTIDE(IX,IY,1:NTIDE,1) + TIDE_PHG(1:NTIDE,1 )=CXTIDE(IX,IY,1:NTIDE,2) + TIDE_AMPC(1:NTIDE,2)=CYTIDE(IX,IY,1:NTIDE,1) + TIDE_PHG(1:NTIDE,2) =CYTIDE(IX,IY,1:NTIDE,2) - WRITE(993,'(A,F20.2,13F8.3)') 'TEST ISEA 0:', & - d1,H,S,TAU,pp,s,p,enp,dh,dpp,ds,dp,dnp,REAL(YGRD(IY,IX)) + WRITE(993,'(A,F20.2,13F8.3)') 'TEST ISEA 0:', & + d1,H,S,TAU,pp,s,p,enp,dh,dpp,ds,dp,dnp,REAL(YGRD(IY,IX)) - DO J=1,TIDE_MF - WRITE(993,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & - FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) - END DO + DO J=1,TIDE_MF + WRITE(993,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & + FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) + END DO DO K=1,2 DO J=1,TIDE_MF WRITE(993,'(A,5I9,F12.0,5F8.3)') 'TEST ISEA 2:',IX,K,J,TIME,TIDE_HOUR, & - FX(J),UX(J),VX(J),TIDE_AMPC(J,K),TIDE_PHG(J,K) - END DO - END DO + FX(J),UX(J),VX(J),TIDE_AMPC(J,K),TIDE_PHG(J,K) + END DO + END DO - WRITE(993,'(A,2F8.4,A,2F8.4)') '#:',CX0(IX,IY),CY0(IX,IY),'##',WCURTIDEX,WCURTIDEY - CLOSE(993) - END IF - ! End of verification + WRITE(993,'(A,2F8.4,A,2F8.4)') '#:',CX0(IX,IY),CY0(IX,IY),'##',WCURTIDEX,WCURTIDEY + CLOSE(993) + END IF + ! End of verification #endif #ifdef W3_TIDE - CX(ISEA) = WCURTIDEX - CY(ISEA) = WCURTIDEY - ELSE + CX(ISEA) = WCURTIDEX + CY(ISEA) = WCURTIDEY + ELSE #endif CABS = CA0(ISEA) + RD * CAI(ISEA) #ifdef W3_CRT2 CI2 = SQRT ( RD2 * CA0(ISEA)**2 + & - RD *(CA0(ISEA)+CAI(ISEA))**2 ) + RD *(CA0(ISEA)+CAI(ISEA))**2 ) CABS = CABS * MIN( 1.25 , CI2/MAX(1.E-7,CABS) ) #endif CDIR = CD0(ISEA) + RD * CDI(ISEA) #ifdef W3_SMC - !Li Rotate curreent direction by ANGARC for Arctic part cells. JGLi23Mar2016 + !Li Rotate curreent direction by ANGARC for Arctic part cells. JGLi23Mar2016 IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN - DN = CDIR + ANGARC( ISEA - NGLO )*DERA - CDIR = MOD ( TPI + DN, TPI ) + DN = CDIR + ANGARC( ISEA - NGLO )*DERA + CDIR = MOD ( TPI + DN, TPI ) ENDIF #endif CX(ISEA) = CABS * COS(CDIR) CY(ISEA) = CABS * SIN(CDIR) #ifdef W3_TIDE - ! IF (ISEA.EQ.1) WRITE(6,'(A,4F8.4,A,4F8.4)') 'CUR#:',RD,CA0(ISEA),CAI(ISEA),CABS,'##', & - ! CX(ISEA), CY(ISEA),WCURTIDEX, WCURTIDEY - END IF + ! IF (ISEA.EQ.1) WRITE(6,'(A,4F8.4,A,4F8.4)') 'CUR#:',RD,CA0(ISEA),CAI(ISEA),CABS,'##', & + ! CX(ISEA), CY(ISEA),WCURTIDEX, WCURTIDEY + END IF #endif -! - END DO -! - RETURN -! -! Formats -! + ! + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3UCUR : DT0N, DT0T, RD :',2F8.1,F6.3) -#endif -!/ -!/ End of W3UCUR ----------------------------------------------------- / -!/ - END SUBROUTINE W3UCUR -!/ ------------------------------------------------------------------- / - SUBROUTINE W3UWND ( FLFRST, VGX, VGY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2014 | -!/ +-----------------------------------+ -!/ -!/ 03-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 26-Dec-2002 : Moving grid wind correction. ( version 3.02 ) -!/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 16-Sep-2013 : Rotating wind for Arctic part. ( version 4.11 ) -!/ 27-May-2014 : Adding OMPG parallelizations dir. ( version 5.02 ) -!/ 27-Aug-2015 : Rename DT0,DTT by DT0T,DT0N ( version 5.10 ) -!/ 26-Mar-2018 : Sea-point only wind for SMC grid. ( version 6.07 ) -!/ -! 1. Purpose : -! -! Interpolate wind fields to the given time. -! -! 2. Method : -! -! Linear interpolation of wind speed and direction, with a simple -! correction to obtain quasi-conservation of energy. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FLFRST Log. I Flag for first pass through routine. -! VGX/Y Real I Grid velocity (!/MGW) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Only winds over sea points are considered. -! - Time ranges checked in W3WAVE. -! -! 8. Structure : -! -! -------------------------------------- -! 1. Prepare auxiliary arrays. -! 2. Calculate interpolation factors -! 3. Get actual winds -! 4. Correct for currents -! 5. Convert to stresses -! 6. Stability correction -! -------------------------------------- -! -! 9. Switches : -! -! !/OMPG OpenMP compiler directives. -! -! !/WNT0 No wind interpolation. -! !/WNT1 Linear wind interpolation. -! !/WNT2 Energy conservation in wind interpolation. -! -! !/RWND Use wind speeds relative to currents. -! !/MGW Moving grid wind correction. -! -! !/STAB2 Calculate effective wind speed factor for stability -! to be used with !/ST2. -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF +9000 FORMAT (' TEST W3UCUR : DT0N, DT0T, RD :',2F8.1,F6.3) +#endif + !/ + !/ End of W3UCUR ----------------------------------------------------- / + !/ + END SUBROUTINE W3UCUR + !/ ------------------------------------------------------------------- / + SUBROUTINE W3UWND ( FLFRST, VGX, VGY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2014 | + !/ +-----------------------------------+ + !/ + !/ 03-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 26-Dec-2002 : Moving grid wind correction. ( version 3.02 ) + !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 16-Sep-2013 : Rotating wind for Arctic part. ( version 4.11 ) + !/ 27-May-2014 : Adding OMPG parallelizations dir. ( version 5.02 ) + !/ 27-Aug-2015 : Rename DT0,DTT by DT0T,DT0N ( version 5.10 ) + !/ 26-Mar-2018 : Sea-point only wind for SMC grid. ( version 6.07 ) + !/ + ! 1. Purpose : + ! + ! Interpolate wind fields to the given time. + ! + ! 2. Method : + ! + ! Linear interpolation of wind speed and direction, with a simple + ! correction to obtain quasi-conservation of energy. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FLFRST Log. I Flag for first pass through routine. + ! VGX/Y Real I Grid velocity (!/MGW) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Only winds over sea points are considered. + ! - Time ranges checked in W3WAVE. + ! + ! 8. Structure : + ! + ! -------------------------------------- + ! 1. Prepare auxiliary arrays. + ! 2. Calculate interpolation factors + ! 3. Get actual winds + ! 4. Correct for currents + ! 5. Convert to stresses + ! 6. Stability correction + ! -------------------------------------- + ! + ! 9. Switches : + ! + ! !/OMPG OpenMP compiler directives. + ! + ! !/WNT0 No wind interpolation. + ! !/WNT1 Linear wind interpolation. + ! !/WNT2 Energy conservation in wind interpolation. + ! + ! !/RWND Use wind speeds relative to currents. + ! !/MGW Moving grid wind correction. + ! + ! !/STAB2 Calculate effective wind speed factor for stability + ! to be used with !/ST2. + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF #ifdef W3_WCOR - USE W3GDATMD, ONLY: WWCOR + USE W3GDATMD, ONLY: WWCOR #endif #ifdef W3_RWND - USE W3GDATMD, ONLY: RWINDC + USE W3GDATMD, ONLY: RWINDC #endif #ifdef W3_ST2 - USE W3GDATMD, ONLY: ZWIND, OFSTAB, FFNG, FFPS, CCNG, CCPS, SHSTAB + USE W3GDATMD, ONLY: ZWIND, OFSTAB, FFNG, FFPS, CCNG, CCPS, SHSTAB #endif #ifdef W3_SMC - USE W3GDATMD, ONLY: NARC, NGLO, ANGARC, ARCTC, FSWND -#endif - USE W3WDATMD, ONLY: TIME, ASF - USE W3ADATMD, ONLY: DW, CX, CY, UA, UD, U10, U10D, AS, & - UA0, UAI, UD0, UDI, AS0, ASI - USE W3IDATMD, ONLY: TW0, WX0, WY0, DT0, TWN, WXN, WYN, DTN, FLCUR -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: VGX, VGY - LOGICAL, INTENT(IN) :: FLFRST -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: ISEA, IX, IY + USE W3GDATMD, ONLY: NARC, NGLO, ANGARC, ARCTC, FSWND +#endif + USE W3WDATMD, ONLY: TIME, ASF + USE W3ADATMD, ONLY: DW, CX, CY, UA, UD, U10, U10D, AS, & + UA0, UAI, UD0, UDI, AS0, ASI + USE W3IDATMD, ONLY: TW0, WX0, WY0, DT0, TWN, WXN, WYN, DTN, FLCUR + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: VGX, VGY + LOGICAL, INTENT(IN) :: FLFRST + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: ISEA, IX, IY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: D0, DN, DD, DT0N, DT0T, RD, UI2, & - UXR, UYR + REAL :: D0, DN, DD, DT0N, DT0T, RD, UI2, & + UXR, UYR #ifdef W3_WNT2 - REAL :: RD2 + REAL :: RD2 #endif #ifdef W3_STAB2 - REAL :: STAB0, STAB, THARG1, THARG2, COR1, COR2 + REAL :: STAB0, STAB, THARG1, THARG2, COR1, COR2 #endif - REAL :: UDARC -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: UDARC + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3UWND') + CALL STRACE (IENT, 'W3UWND') #endif -! -! 1. Prepare auxiliary arrays -! - IF ( FLFRST ) THEN - DO ISEA=1, NSEA + ! + ! 1. Prepare auxiliary arrays + ! + IF ( FLFRST ) THEN + DO ISEA=1, NSEA #ifdef W3_SMC - !!Li For sea-point only SMC grid wind 1-D wind is stored on - !!Li 2-D WX0(NSEA, 1) variable. + !!Li For sea-point only SMC grid wind 1-D wind is stored on + !!Li 2-D WX0(NSEA, 1) variable. IF( FSWND ) THEN - IX = ISEA - IY = 1 + IX = ISEA + IY = 1 ELSE #endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) #ifdef W3_SMC ENDIF #endif - UA0(ISEA) = SQRT ( WX0(IX,IY)**2 + WY0(IX,IY)**2 ) - UAI(ISEA) = SQRT ( WXN(IX,IY)**2 + WYN(IX,IY)**2 ) - IF ( UA0(ISEA) .GT. 1.E-7) THEN - D0 = MOD ( TPI+ATAN2(WY0(IX,IY),WX0(IX,IY)) , TPI ) - ELSE - D0 = 0 - END IF - IF ( UAI(ISEA) .GT. 1.E-7) THEN - DN = MOD ( TPI+ATAN2(WYN(IX,IY),WXN(IX,IY)) , TPI ) - ELSE - DN = D0 - END IF - IF ( UA0(ISEA) .GT. 1.E-7) THEN - UD0(ISEA) = D0 - ELSE - UD0(ISEA) = DN - END IF - DD = DN - UD0(ISEA) - IF (ABS(DD).GT.PI) DD = DD - TPI*SIGN(1.,DD) - UDI(ISEA) = DD - UAI(ISEA) = UAI(ISEA) - UA0(ISEA) - AS0(ISEA) = DT0(IX,IY) - ASI(ISEA) = DTN(IX,IY) - DT0(IX,IY) - END DO + UA0(ISEA) = SQRT ( WX0(IX,IY)**2 + WY0(IX,IY)**2 ) + UAI(ISEA) = SQRT ( WXN(IX,IY)**2 + WYN(IX,IY)**2 ) + IF ( UA0(ISEA) .GT. 1.E-7) THEN + D0 = MOD ( TPI+ATAN2(WY0(IX,IY),WX0(IX,IY)) , TPI ) + ELSE + D0 = 0 + END IF + IF ( UAI(ISEA) .GT. 1.E-7) THEN + DN = MOD ( TPI+ATAN2(WYN(IX,IY),WXN(IX,IY)) , TPI ) + ELSE + DN = D0 + END IF + IF ( UA0(ISEA) .GT. 1.E-7) THEN + UD0(ISEA) = D0 + ELSE + UD0(ISEA) = DN END IF -! -! 2. Calculate interpolation factor -! - DT0N = DSEC21 ( TW0, TWN ) - DT0T = DSEC21 ( TW0, TIME ) -! + DD = DN - UD0(ISEA) + IF (ABS(DD).GT.PI) DD = DD - TPI*SIGN(1.,DD) + UDI(ISEA) = DD + UAI(ISEA) = UAI(ISEA) - UA0(ISEA) + AS0(ISEA) = DT0(IX,IY) + ASI(ISEA) = DTN(IX,IY) - DT0(IX,IY) + END DO + END IF + ! + ! 2. Calculate interpolation factor + ! + DT0N = DSEC21 ( TW0, TWN ) + DT0T = DSEC21 ( TW0, TIME ) + ! #ifdef W3_WNT0 - RD = 0. + RD = 0. #endif #ifdef W3_WNT1 - RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD = DT0T / MAX ( 1.E-7 , DT0N ) #endif #ifdef W3_WNT2 - RD = DT0T / MAX ( 1.E-7 , DT0N ) - RD2 = 1. - RD + RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD2 = 1. - RD #endif #ifdef W3_OASACM - RD = 1. + RD = 1. #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) DT0N, DT0T, RD + WRITE (NDST,9000) DT0N, DT0T, RD #endif -! -! 3. Actual wind for all grid points -! + ! + ! 3. Actual wind for all grid points + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE (ISEA,UI2,UXR,UYR,UDARC) + !$OMP PARALLEL DO PRIVATE (ISEA,UI2,UXR,UYR,UDARC) #endif -! - DO ISEA=1, NSEA -! - UA(ISEA) = UA0(ISEA) + RD * UAI(ISEA) + ! + DO ISEA=1, NSEA + ! + UA(ISEA) = UA0(ISEA) + RD * UAI(ISEA) #ifdef W3_WNT2 - UI2 = SQRT ( RD2 * UA0(ISEA)**2 + & - RD *(UA0(ISEA)+UAI(ISEA))**2 ) - UA(ISEA) = UA(ISEA) * MIN(1.25,UI2/MAX(1.E-7,UA(ISEA))) + UI2 = SQRT ( RD2 * UA0(ISEA)**2 + & + RD *(UA0(ISEA)+UAI(ISEA))**2 ) + UA(ISEA) = UA(ISEA) * MIN(1.25,UI2/MAX(1.E-7,UA(ISEA))) #endif - UD(ISEA) = UD0(ISEA) + RD * UDI(ISEA) + UD(ISEA) = UD0(ISEA) + RD * UDI(ISEA) #ifdef W3_MGW - UXR = UA(ISEA)*COS(UD(ISEA)) + VGX - UYR = UA(ISEA)*SIN(UD(ISEA)) + VGY - UA(ISEA) = MAX ( 0.001 , SQRT(UXR**2+UYR**2) ) - UD(ISEA) = MOD ( TPI+ATAN2(UYR,UXR) , TPI ) + UXR = UA(ISEA)*COS(UD(ISEA)) + VGX + UYR = UA(ISEA)*SIN(UD(ISEA)) + VGY + UA(ISEA) = MAX ( 0.001 , SQRT(UXR**2+UYR**2) ) + UD(ISEA) = MOD ( TPI+ATAN2(UYR,UXR) , TPI ) #endif #ifdef W3_SMC - !Li Rotate wind direction by ANGARC for Arctic part cells. - IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN - UDARC = UD(ISEA) + ANGARC( ISEA - NGLO )*DERA - UD(ISEA) = MOD ( TPI + UDARC, TPI ) - ENDIF + !Li Rotate wind direction by ANGARC for Arctic part cells. + IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN + UDARC = UD(ISEA) + ANGARC( ISEA - NGLO )*DERA + UD(ISEA) = MOD ( TPI + UDARC, TPI ) + ENDIF #endif -! - AS(ISEA) = AS0(ISEA) + RD * ASI(ISEA) -! IF (UA(ISEA).NE.UA(ISEA)) WRITE(6,*) 'BUG WIND:',ISEA,UA(ISEA),MAPSF(ISEA,1), MAPSF(ISEA,2),UA0(ISEA),RD,UAI(ISEA) -! IF (UD(ISEA).NE.UD(ISEA)) WRITE(6,*) 'BUG WIN2:',ISEA,UD(ISEA),MAPSF(ISEA,1), MAPSF(ISEA,2) -! - END DO -! + ! + AS(ISEA) = AS0(ISEA) + RD * ASI(ISEA) + ! IF (UA(ISEA).NE.UA(ISEA)) WRITE(6,*) 'BUG WIND:',ISEA,UA(ISEA),MAPSF(ISEA,1), MAPSF(ISEA,2),UA0(ISEA),RD,UAI(ISEA) + ! IF (UD(ISEA).NE.UD(ISEA)) WRITE(6,*) 'BUG WIN2:',ISEA,UD(ISEA),MAPSF(ISEA,1), MAPSF(ISEA,2) + ! + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! -! 3.b Bias correction ( !/WCOR ) + ! + ! 3.b Bias correction ( !/WCOR ) #ifdef W3_WCOR - WHERE ( UA .GE. WWCOR(1) ) UA = UA+(UA-WWCOR(1))*WWCOR(2) + WHERE ( UA .GE. WWCOR(1) ) UA = UA+(UA-WWCOR(1))*WWCOR(2) #endif -! -! 4. Correct for currents and grid motion -! + ! + ! 4. Correct for currents and grid motion + ! #ifdef W3_RWND - IF ( FLCUR ) THEN + IF ( FLCUR ) THEN #endif -! + ! #ifdef W3_RWND - DO ISEA=1, NSEA - UXR = UA(ISEA)*COS(UD(ISEA)) - RWINDC*CX(ISEA) - UYR = UA(ISEA)*SIN(UD(ISEA)) - RWINDC*CY(ISEA) - U10 (ISEA) = MAX ( 0.001 , SQRT(UXR**2+UYR**2) ) - U10D(ISEA) = MOD ( TPI+ATAN2(UYR,UXR) , TPI ) - END DO + DO ISEA=1, NSEA + UXR = UA(ISEA)*COS(UD(ISEA)) - RWINDC*CX(ISEA) + UYR = UA(ISEA)*SIN(UD(ISEA)) - RWINDC*CY(ISEA) + U10 (ISEA) = MAX ( 0.001 , SQRT(UXR**2+UYR**2) ) + U10D(ISEA) = MOD ( TPI+ATAN2(UYR,UXR) , TPI ) + END DO #endif -! + ! #ifdef W3_RWND - ELSE + ELSE #endif -! + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE (ISEA) + !$OMP PARALLEL DO PRIVATE (ISEA) #endif -! - DO ISEA=1, NSEA - U10 (ISEA) = MAX ( UA(ISEA) , 0.001 ) - U10D(ISEA) = UD(ISEA) - END DO -! + ! + DO ISEA=1, NSEA + U10 (ISEA) = MAX ( UA(ISEA) , 0.001 ) + U10D(ISEA) = UD(ISEA) + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! + ! #ifdef W3_RWND - END IF -#endif -! -! 5. Stability correction ( !/STAB2 ) -! Original settings : -! -! SHSTAB = 1.4 -! OFSTAB = -0.01 -! CCNG = -0.1 -! CCPS = 0.1 -! FFNG = -150. -! FFPS = 150. -! + END IF +#endif + ! + ! 5. Stability correction ( !/STAB2 ) + ! Original settings : + ! + ! SHSTAB = 1.4 + ! OFSTAB = -0.01 + ! CCNG = -0.1 + ! CCPS = 0.1 + ! FFNG = -150. + ! FFPS = 150. + ! #ifdef W3_STAB2 - STAB0 = ZWIND * GRAV / 273. + STAB0 = ZWIND * GRAV / 273. #endif -! + ! #ifdef W3_STAB2 - DO ISEA=1, NSEA - STAB = STAB0 * AS(ISEA) / MAX(5.,U10(ISEA))**2 - STAB = MAX ( -1. , MIN ( 1. , STAB ) ) + DO ISEA=1, NSEA + STAB = STAB0 * AS(ISEA) / MAX(5.,U10(ISEA))**2 + STAB = MAX ( -1. , MIN ( 1. , STAB ) ) #endif -! + ! #ifdef W3_STAB2 - THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) - THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) - COR1 = CCNG * TANH(THARG1) - COR2 = CCPS * TANH(THARG2) + THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) + THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) + COR1 = CCNG * TANH(THARG1) + COR2 = CCPS * TANH(THARG2) #endif -! + ! #ifdef W3_STAB2 - ASF(ISEA) = SQRT ( (1.+COR1+COR2)/SHSTAB ) - U10(ISEA) = U10(ISEA) / ASF(ISEA) - END DO -#endif -! - RETURN -! -! Formats -! + ASF(ISEA) = SQRT ( (1.+COR1+COR2)/SHSTAB ) + U10(ISEA) = U10(ISEA) / ASF(ISEA) + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3UWND : DT0N, DT0T, RD :',2F8.1,F6.3) -#endif -!/ -!/ End of W3UWND ----------------------------------------------------- / -!/ - END SUBROUTINE W3UWND -!/ ------------------------------------------------------------------- / - SUBROUTINE W3UTAU ( FLFRST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | J. M. Castillo | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 22-Mar-2021 : First implementation ( version 7.13 ) -!/ -! 1. Purpose : -! -! Interpolate atmosphere momentum fields to the given time. -! -! 2. Method : -! -! Linear interpolation of momentum module and direction, with a simple -! correction to obtain quasi-conservation of energy. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FLFRST Log. I Flag for first pass through routine. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Only momentum over sea points is considered. -! - Time ranges checked in W3WAVE. -! -! 8. Structure : -! -! -------------------------------------- -! 1. Prepare auxiliary arrays. -! 2. Calculate interpolation factors -! 3. Get actual momentum -! -------------------------------------- -! -! 9. Switches : -! -! !/OMPG OpenMP compiler directives. -! -! !/WNT0 No momentum interpolation. -! !/WNT1 Linear momentum interpolation. -! !/WNT2 Energy conservation in momentum interpolation. -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NSEA, MAPSF +9000 FORMAT (' TEST W3UWND : DT0N, DT0T, RD :',2F8.1,F6.3) +#endif + !/ + !/ End of W3UWND ----------------------------------------------------- / + !/ + END SUBROUTINE W3UWND + !/ ------------------------------------------------------------------- / + SUBROUTINE W3UTAU ( FLFRST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | J. M. Castillo | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 22-Mar-2021 : First implementation ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Interpolate atmosphere momentum fields to the given time. + ! + ! 2. Method : + ! + ! Linear interpolation of momentum module and direction, with a simple + ! correction to obtain quasi-conservation of energy. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FLFRST Log. I Flag for first pass through routine. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Only momentum over sea points is considered. + ! - Time ranges checked in W3WAVE. + ! + ! 8. Structure : + ! + ! -------------------------------------- + ! 1. Prepare auxiliary arrays. + ! 2. Calculate interpolation factors + ! 3. Get actual momentum + ! -------------------------------------- + ! + ! 9. Switches : + ! + ! !/OMPG OpenMP compiler directives. + ! + ! !/WNT0 No momentum interpolation. + ! !/WNT1 Linear momentum interpolation. + ! !/WNT2 Energy conservation in momentum interpolation. + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NSEA, MAPSF #ifdef W3_SMC - USE W3GDATMD, ONLY: NARC, NGLO, ANGARC - USE W3GDATMD, ONLY: FSWND, ARCTC -#endif - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: TAUA, TAUADIR, MA0, MAI, MD0, MDI - USE W3IDATMD, ONLY: TU0, UX0, UY0, TUN, UXN, UYN -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - LOGICAL, INTENT(IN) :: FLFRST -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: ISEA, IX, IY + USE W3GDATMD, ONLY: NARC, NGLO, ANGARC + USE W3GDATMD, ONLY: FSWND, ARCTC +#endif + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: TAUA, TAUADIR, MA0, MAI, MD0, MDI + USE W3IDATMD, ONLY: TU0, UX0, UY0, TUN, UXN, UYN + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + LOGICAL, INTENT(IN) :: FLFRST + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: ISEA, IX, IY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: D0, DN, DD, DT0N, DT0T, RD, MI2, & - MXR, MYR + REAL :: D0, DN, DD, DT0N, DT0T, RD, MI2, & + MXR, MYR #ifdef W3_WNT2 - REAL :: RD2 + REAL :: RD2 #endif - REAL :: MDARC -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: MDARC + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3UTAU') + CALL STRACE (IENT, 'W3UTAU') #endif -! -! 1. Prepare auxiliary arrays -! - IF ( FLFRST ) THEN - DO ISEA=1, NSEA + ! + ! 1. Prepare auxiliary arrays + ! + IF ( FLFRST ) THEN + DO ISEA=1, NSEA #ifdef W3_SMC - !!Li For sea-point only SMC grid momentum 1-D momentum is stored on - !!Li 2-D UX0(NSEA, 1) variable. + !!Li For sea-point only SMC grid momentum 1-D momentum is stored on + !!Li 2-D UX0(NSEA, 1) variable. IF( FSWND ) THEN - IX = ISEA - IY = 1 + IX = ISEA + IY = 1 ELSE #endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) #ifdef W3_SMC ENDIF #endif - MA0(ISEA) = SQRT ( UX0(IX,IY)**2 + UY0(IX,IY)**2 ) - MAI(ISEA) = SQRT ( UXN(IX,IY)**2 + UYN(IX,IY)**2 ) - IF ( MA0(ISEA) .GT. 1.E-7) THEN - D0 = MOD ( TPI+ATAN2(UY0(IX,IY),UX0(IX,IY)) , TPI ) - ELSE - D0 = 0 - END IF - IF ( MAI(ISEA) .GT. 1.E-7) THEN - DN = MOD ( TPI+ATAN2(UYN(IX,IY),UXN(IX,IY)) , TPI ) - ELSE - DN = D0 - END IF - IF ( MA0(ISEA) .GT. 1.E-7) THEN - MD0(ISEA) = D0 - ELSE - MD0(ISEA) = DN - END IF - DD = DN - MD0(ISEA) - IF (ABS(DD).GT.PI) DD = DD - TPI*SIGN(1.,DD) - MDI(ISEA) = DD - MAI(ISEA) = MAI(ISEA) - MA0(ISEA) - END DO + MA0(ISEA) = SQRT ( UX0(IX,IY)**2 + UY0(IX,IY)**2 ) + MAI(ISEA) = SQRT ( UXN(IX,IY)**2 + UYN(IX,IY)**2 ) + IF ( MA0(ISEA) .GT. 1.E-7) THEN + D0 = MOD ( TPI+ATAN2(UY0(IX,IY),UX0(IX,IY)) , TPI ) + ELSE + D0 = 0 + END IF + IF ( MAI(ISEA) .GT. 1.E-7) THEN + DN = MOD ( TPI+ATAN2(UYN(IX,IY),UXN(IX,IY)) , TPI ) + ELSE + DN = D0 END IF -! -! 2. Calculate interpolation factor -! - DT0N = DSEC21 ( TU0, TUN ) - DT0T = DSEC21 ( TU0, TIME ) -! + IF ( MA0(ISEA) .GT. 1.E-7) THEN + MD0(ISEA) = D0 + ELSE + MD0(ISEA) = DN + END IF + DD = DN - MD0(ISEA) + IF (ABS(DD).GT.PI) DD = DD - TPI*SIGN(1.,DD) + MDI(ISEA) = DD + MAI(ISEA) = MAI(ISEA) - MA0(ISEA) + END DO + END IF + ! + ! 2. Calculate interpolation factor + ! + DT0N = DSEC21 ( TU0, TUN ) + DT0T = DSEC21 ( TU0, TIME ) + ! #ifdef W3_WNT0 - RD = 0. + RD = 0. #endif #ifdef W3_WNT1 - RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD = DT0T / MAX ( 1.E-7 , DT0N ) #endif #ifdef W3_WNT2 - RD = DT0T / MAX ( 1.E-7 , DT0N ) - RD2 = 1. - RD + RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD2 = 1. - RD #endif #ifdef W3_OASACM - RD = 1. + RD = 1. #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) DT0N, DT0T, RD + WRITE (NDST,9000) DT0N, DT0T, RD #endif -! -! 3. Actual momentum for all grid points -! + ! + ! 3. Actual momentum for all grid points + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE (ISEA,MI2,MXR,MYR,MDARC) + !$OMP PARALLEL DO PRIVATE (ISEA,MI2,MXR,MYR,MDARC) #endif -! - DO ISEA=1, NSEA -! - TAUA(ISEA) = MA0(ISEA) + RD * MAI(ISEA) + ! + DO ISEA=1, NSEA + ! + TAUA(ISEA) = MA0(ISEA) + RD * MAI(ISEA) #ifdef W3_WNT2 - MI2 = SQRT ( RD2 * MA0(ISEA)**2 + & - RD *(MA0(ISEA)+MAI(ISEA))**2 ) - TAUA(ISEA) = TAUA(ISEA) * MIN(1.25,MI2/MAX(1.E-7,TAUA(ISEA))) + MI2 = SQRT ( RD2 * MA0(ISEA)**2 + & + RD *(MA0(ISEA)+MAI(ISEA))**2 ) + TAUA(ISEA) = TAUA(ISEA) * MIN(1.25,MI2/MAX(1.E-7,TAUA(ISEA))) #endif - TAUADIR(ISEA) = MD0(ISEA) + RD * MDI(ISEA) + TAUADIR(ISEA) = MD0(ISEA) + RD * MDI(ISEA) #ifdef W3_SMC - !Li Rotate momentum direction by ANGARC for Arctic part cells. - IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN - MDARC = TAUADIR(ISEA) + ANGARC( ISEA - NGLO )*DERA - TAUADIR(ISEA) = MOD ( TPI + MDARC, TPI ) - ENDIF + !Li Rotate momentum direction by ANGARC for Arctic part cells. + IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN + MDARC = TAUADIR(ISEA) + ANGARC( ISEA - NGLO )*DERA + TAUADIR(ISEA) = MOD ( TPI + MDARC, TPI ) + ENDIF #endif -! - END DO -! - RETURN -! -! Formats -! + ! + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3UTAU : DT0N, DT0T, RD :',2F8.1,F6.3) -#endif -!/ -!/ End of W3UTAU ----------------------------------------------------- / -!/ - END SUBROUTINE W3UTAU -!/ ------------------------------------------------------------------- / - SUBROUTINE W3UINI ( A ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 18-May-2001 : Fix CG declaration. ( version 2.11 ) -!/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ 06-Jun-2018 : use W3PARALL and INIT_GET_ISEA ( version 6.04 ) -!/ -! 1. Purpose : -! -! Initialize the wave field with fetch-limited spectra before the -! actual calculation start. (Named as an update routine due to -! placement in code.) -! -! 2. Method : -! -! Fetch-limited JONSWAP spectra with a cosine^2 directional -! distribution and a mean direction taken from the wind. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! A R.A. O Action density spectra. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Wind speeds filtered by U10MIN and U10MAX (DATA statements) -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/S Enable subroutine tracing. -! !/T General test output. -! !/T1 Parameters at grid points. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSF, & - NK, NTH, TH, SIG, DTH, DSIP, UNGTYPE, & - RLGTYPE, CLGTYPE, GTYPE, FLAGLL, & - HPFAC, HQFAC - USE W3ADATMD, ONLY: U10, U10D, CG - USE W3PARALL, only : INIT_GET_JSEA_ISPROC, INIT_GET_ISEA - USE W3PARALL, only : GET_JSEA_IBELONG +9000 FORMAT (' TEST W3UTAU : DT0N, DT0T, RD :',2F8.1,F6.3) +#endif + !/ + !/ End of W3UTAU ----------------------------------------------------- / + !/ + END SUBROUTINE W3UTAU + !/ ------------------------------------------------------------------- / + SUBROUTINE W3UINI ( A ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 18-May-2001 : Fix CG declaration. ( version 2.11 ) + !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ 06-Jun-2018 : use W3PARALL and INIT_GET_ISEA ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize the wave field with fetch-limited spectra before the + ! actual calculation start. (Named as an update routine due to + ! placement in code.) + ! + ! 2. Method : + ! + ! Fetch-limited JONSWAP spectra with a cosine^2 directional + ! distribution and a mean direction taken from the wind. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! A R.A. O Action density spectra. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Wind speeds filtered by U10MIN and U10MAX (DATA statements) + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/S Enable subroutine tracing. + ! !/T General test output. + ! !/T1 Parameters at grid points. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSF, & + NK, NTH, TH, SIG, DTH, DSIP, UNGTYPE, & + RLGTYPE, CLGTYPE, GTYPE, FLAGLL, & + HPFAC, HQFAC + USE W3ADATMD, ONLY: U10, U10D, CG + USE W3PARALL, only : INIT_GET_JSEA_ISPROC, INIT_GET_ISEA + USE W3PARALL, only : GET_JSEA_IBELONG #ifdef W3_T - USE W3ARRYMD, ONLY : PRTBLK -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(OUT) :: A(NTH,NK,0:NSEAL) -!/ -!/ ------------------------------------------------------------------- / -!/ Local variables -!/ - INTEGER :: IX, IY, ISEA, JSEA, IK, ITH, ISPROC + USE W3ARRYMD, ONLY : PRTBLK +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(OUT) :: A(NTH,NK,0:NSEAL) + !/ + !/ ------------------------------------------------------------------- / + !/ Local variables + !/ + INTEGER :: IX, IY, ISEA, JSEA, IK, ITH, ISPROC #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T - INTEGER :: IX0, IXN, MAPOUT(NX,NY) - INTEGER :: NXP = 60 -#endif - REAL :: ALFA(NSEAL), FP(NSEAL), YLN(NSEAL), & - AA, BB, CC - REAL :: XGR, U10C, U10DIR, XSTAR, FSTAR, & - GAMMA, FR, D1(NTH), D1INT, F1, F2 - REAL :: ETOT, E1I - REAL :: U10MIN = 1. - REAL :: U10MAX = 20. + INTEGER :: IX0, IXN, MAPOUT(NX,NY) + INTEGER :: NXP = 60 +#endif + REAL :: ALFA(NSEAL), FP(NSEAL), YLN(NSEAL), & + AA, BB, CC + REAL :: XGR, U10C, U10DIR, XSTAR, FSTAR, & + GAMMA, FR, D1(NTH), D1INT, F1, F2 + REAL :: ETOT, E1I + REAL :: U10MIN = 1. + REAL :: U10MAX = 20. #ifdef W3_T - REAL :: HSIG(NX,NY) + REAL :: HSIG(NX,NY) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3UINI') + CALL STRACE (IENT, 'W3UINI') #endif -! -! -! Pre-process JONSWAP data for all grid points ----------------------- * -! + ! + ! + ! Pre-process JONSWAP data for all grid points ----------------------- * + ! #ifdef W3_T1 - WRITE (NDST,9010) -#endif -! -! this is not clear what is going on betwen w3init and this ... - A(:,:,:)=0 - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IF (GTYPE.EQ.UNGTYPE) THEN - XGR=1. ! to be fixed later - ELSE - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - XGR = 0.5 * SQRT(HPFAC(IY,IX)**2+HQFAC(IY,IX)**2) - END IF - IF ( FLAGLL ) THEN - XGR = XGR * RADIUS * DERA - END IF -! - U10C = MAX ( MIN(U10(ISEA),U10MAX) , U10MIN ) -! - XSTAR = GRAV * XGR / U10C**2 - FSTAR = 3.5 / XSTAR**(0.33) - GAMMA = MAX ( 1. , 7.0 / XSTAR**(0.143) ) -! - ALFA(JSEA) = 0.076 / XSTAR**(0.22) - FP (JSEA) = FSTAR * GRAV / U10C - YLN (JSEA) = LOG ( GAMMA ) -! + WRITE (NDST,9010) +#endif + ! + ! this is not clear what is going on betwen w3init and this ... + A(:,:,:)=0 + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IF (GTYPE.EQ.UNGTYPE) THEN + XGR=1. ! to be fixed later + ELSE + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + XGR = 0.5 * SQRT(HPFAC(IY,IX)**2+HQFAC(IY,IX)**2) + END IF + IF ( FLAGLL ) THEN + XGR = XGR * RADIUS * DERA + END IF + ! + U10C = MAX ( MIN(U10(ISEA),U10MAX) , U10MIN ) + ! + XSTAR = GRAV * XGR / U10C**2 + FSTAR = 3.5 / XSTAR**(0.33) + GAMMA = MAX ( 1. , 7.0 / XSTAR**(0.143) ) + ! + ALFA(JSEA) = 0.076 / XSTAR**(0.22) + FP (JSEA) = FSTAR * GRAV / U10C + YLN (JSEA) = LOG ( GAMMA ) + ! #ifdef W3_T1 - WRITE (NDST,9011) ISEA, U10C, XSTAR, & - ALFA(JSEA), FP(JSEA), GAMMA -#endif -! - END DO -! -! 1-D spectrum at location ITH = NTH --------------------------------- * -! - DO IK=1, NK - FR = SIG(IK) * TPIINV - DO JSEA=1, NSEAL -! -!/ ----- INLINED EJ5P (REDUCED) -------------------------------------- / -! - AA = ALFA(JSEA) * 0.06175/FR**5 - BB = MAX( -50. , -1.25*(FP(JSEA)/FR)**4 ) - CC = MAX( -50. , -0.5*((FR-FP(JSEA))/(0.07*FP(JSEA)))**2 ) - A(NTH,IK,JSEA) & - = AA * EXP(BB + EXP(CC) * YLN(JSEA)) -! -!/ ----- INLINED EJ5P (END) ------------------------------------------ / -! - END DO - END DO -! -! Apply directional distribution ------------------------------------- * -! + WRITE (NDST,9011) ISEA, U10C, XSTAR, & + ALFA(JSEA), FP(JSEA), GAMMA +#endif + ! + END DO + ! + ! 1-D spectrum at location ITH = NTH --------------------------------- * + ! + DO IK=1, NK + FR = SIG(IK) * TPIINV DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - U10DIR = U10D(ISEA) - D1INT = 0. -! + ! + !/ ----- INLINED EJ5P (REDUCED) -------------------------------------- / + ! + AA = ALFA(JSEA) * 0.06175/FR**5 + BB = MAX( -50. , -1.25*(FP(JSEA)/FR)**4 ) + CC = MAX( -50. , -0.5*((FR-FP(JSEA))/(0.07*FP(JSEA)))**2 ) + A(NTH,IK,JSEA) & + = AA * EXP(BB + EXP(CC) * YLN(JSEA)) + ! + !/ ----- INLINED EJ5P (END) ------------------------------------------ / + ! + END DO + END DO + ! + ! Apply directional distribution ------------------------------------- * + ! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + U10DIR = U10D(ISEA) + D1INT = 0. + ! + DO ITH=1, NTH + D1(ITH) = ( MAX ( 0. , COS(TH(ITH)-U10DIR) ) )**2 + D1INT = D1INT + D1(ITH) + END DO + ! + D1INT = D1INT * DTH + F1 = TPIINV / D1INT + ! + DO IK=1, NK + F2 = F1 * A(NTH,IK,JSEA) * CG(IK,ISEA) / SIG(IK) DO ITH=1, NTH - D1(ITH) = ( MAX ( 0. , COS(TH(ITH)-U10DIR) ) )**2 - D1INT = D1INT + D1(ITH) - END DO -! - D1INT = D1INT * DTH - F1 = TPIINV / D1INT -! - DO IK=1, NK - F2 = F1 * A(NTH,IK,JSEA) * CG(IK,ISEA) / SIG(IK) - DO ITH=1, NTH - A(ITH,IK,JSEA) = F2 * D1(ITH) - END DO - END DO -! + A(ITH,IK,JSEA) = F2 * D1(ITH) END DO -! -! Test output -------------------------------------------------------- * -! + END DO + ! + END DO + ! + ! Test output -------------------------------------------------------- * + ! #ifdef W3_T - HSIG = 0. - MAPOUT = 0 + HSIG = 0. + MAPOUT = 0 #endif -! + ! #ifdef W3_T - DO ISEA=IAPROC, NSEA, NAPROC - JSEA = 1 + (ISEA-1)/NAPROC - ETOT = 0. - DO IK=1, NK - E1I = 0. - DO ITH=1, NTH - E1I = E1I + A(ITH,IK,JSEA) - END DO - ETOT = ETOT + E1I * DSIP(IK) * SIG(IK) / CG(IK,ISEA) - END DO - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - HSIG (IX,IY) = 4. * SQRT ( ETOT * DTH ) - MAPOUT(IX,IY) = 1 + DO ISEA=IAPROC, NSEA, NAPROC + JSEA = 1 + (ISEA-1)/NAPROC + ETOT = 0. + DO IK=1, NK + E1I = 0. + DO ITH=1, NTH + E1I = E1I + A(ITH,IK,JSEA) END DO + ETOT = ETOT + E1I * DSIP(IK) * SIG(IK) / CG(IK,ISEA) + END DO + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + HSIG (IX,IY) = 4. * SQRT ( ETOT * DTH ) + MAPOUT(IX,IY) = 1 + END DO #endif -! + ! #ifdef W3_T - IX0 = 1 - DO - IXN = MIN ( NX , IX0+NXP-1 ) - CALL PRTBLK (NDST, NX, NY, NX, HSIG, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Hs', 'm') - IF ( IXN .EQ. NX ) EXIT - IX0 = IX0 + NXP - END DO -#endif -! - RETURN -! -! Formats -! + IX0 = 1 + DO + IXN = MIN ( NX , IX0+NXP-1 ) + CALL PRTBLK (NDST, NX, NY, NX, HSIG, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Hs', 'm') + IF ( IXN .EQ. NX ) EXIT + IX0 = IX0 + NXP + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3UINI : XGR = ',E10.3) +9000 FORMAT (' TEST W3UINI : XGR = ',E10.3) #endif -! + ! #ifdef W3_T1 - 9010 FORMAT (' TEST W3UINI : ISEA, U10C, XSTAR, ALPHA, FP, GAMMA') - 9011 FORMAT (' ',I6,F8.2,F10.1,2F6.3,F6.2) -#endif -!/ -!/ End of W3UINI ----------------------------------------------------- / -!/ - END SUBROUTINE W3UINI -!/ ------------------------------------------------------------------- / - SUBROUTINE W3UBPT -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Moving update to end of time step. ( version 3.08 ) -!/ 17-Aug-2010 : Add initialization ABPI0-N(:,0). ( version 3.14.5 ) -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 06-Jun-2018 : Add DEBUGIOBC/SETUP/DEBUGW3ULEV ( version 6.04 ) -!/ 13-Jun-2019 : Rotation only if POLAT<90 (C.Hansen)( version 7.11 ) -!/ -! 1. Purpose : -! -! Update spectra at the active boundary points. -! -! 2. Method : -! -! Spectra are read and interpolated in space and time from the -! data read by W3IOBC. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! STRACE, DSEC21 -! Service routines. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The data arrays contain sigma spectra to assure conservation -! when changing grids. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T0 Test output of wave heights. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NSPEC, MAPWN, SIG2, DDEN +9010 FORMAT (' TEST W3UINI : ISEA, U10C, XSTAR, ALPHA, FP, GAMMA') +9011 FORMAT (' ',I6,F8.2,F10.1,2F6.3,F6.2) +#endif + !/ + !/ End of W3UINI ----------------------------------------------------- / + !/ + END SUBROUTINE W3UINI + !/ ------------------------------------------------------------------- / + SUBROUTINE W3UBPT + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 07-Sep-2005 : Moving update to end of time step. ( version 3.08 ) + !/ 17-Aug-2010 : Add initialization ABPI0-N(:,0). ( version 3.14.5 ) + !/ 12-Jun-2012 : Add /RTD option or rotated grid option. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 06-Jun-2018 : Add DEBUGIOBC/SETUP/DEBUGW3ULEV ( version 6.04 ) + !/ 13-Jun-2019 : Rotation only if POLAT<90 (C.Hansen)( version 7.11 ) + !/ + ! 1. Purpose : + ! + ! Update spectra at the active boundary points. + ! + ! 2. Method : + ! + ! Spectra are read and interpolated in space and time from the + ! data read by W3IOBC. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! STRACE, DSEC21 + ! Service routines. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - The data arrays contain sigma spectra to assure conservation + ! when changing grids. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T0 Test output of wave heights. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NSPEC, MAPWN, SIG2, DDEN #ifdef W3_RTD - !! Use rotation angle and action conversion sub. JGLi12Jun2012 - USE W3GDATMD, ONLY: NK, NTH, NSPEC, AnglD, PoLat - USE W3SERVMD, ONLY: W3ACTURN -#endif - USE W3ADATMD, ONLY: CG - USE W3ODATMD, ONLY: NBI, ABPI0, ABPIN, ISBPI, IPBPI, RDBPI, & - BBPI0, BBPIN -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: IBI, ISP, ISEA + !! Use rotation angle and action conversion sub. JGLi12Jun2012 + USE W3GDATMD, ONLY: NK, NTH, NSPEC, AnglD, PoLat + USE W3SERVMD, ONLY: W3ACTURN +#endif + USE W3ADATMD, ONLY: CG + USE W3ODATMD, ONLY: NBI, ABPI0, ABPIN, ISBPI, IPBPI, RDBPI, & + BBPI0, BBPIN + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: IBI, ISP, ISEA #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T0 - REAL :: HS1, HS2 + REAL :: HS1, HS2 #endif #ifdef W3_RTD - !! Declare a temporary spectr variable. JGLi12Jun2012 - REAL :: Spectr(NSPEC), AnglBP + !! Declare a temporary spectr variable. JGLi12Jun2012 + REAL :: Spectr(NSPEC), AnglBP #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3UBPT') + CALL STRACE (IENT, 'W3UBPT') #endif -! -! 1. Process BBPI0 -------------------------------------------------- * -! 1.a First intialization + ! + ! 1. Process BBPI0 -------------------------------------------------- * + ! 1.a First intialization -! - IF ( BBPI0(1,0) .EQ. -1. ) THEN -! - BBPI0(:,0) = 0. - BBPIN(:,0) = 0. - ABPI0(:,0) = 0. - ABPIN(:,0) = 0. -! - DO IBI=1, NBI - ISEA = ISBPI(IBI) - DO ISP=1, NSPEC - BBPI0(ISP,IBI) = CG(MAPWN(ISP),ISEA) / SIG2(ISP) * & - ( RDBPI(IBI,1) * ABPI0(ISP,IPBPI(IBI,1)) & - + RDBPI(IBI,2) * ABPI0(ISP,IPBPI(IBI,2)) & - + RDBPI(IBI,3) * ABPI0(ISP,IPBPI(IBI,3)) & - + RDBPI(IBI,4) * ABPI0(ISP,IPBPI(IBI,4)) ) - END DO - END DO -! -! 1.b Shift BBPIN -! - ELSE - BBPI0 = BBPIN - END IF -! -! 2. Process BBPIN -------------------------------------------------- * -! + ! + IF ( BBPI0(1,0) .EQ. -1. ) THEN + ! + BBPI0(:,0) = 0. + BBPIN(:,0) = 0. + ABPI0(:,0) = 0. + ABPIN(:,0) = 0. + ! DO IBI=1, NBI ISEA = ISBPI(IBI) DO ISP=1, NSPEC - BBPIN(ISP,IBI) = CG(MAPWN(ISP),ISEA) / SIG2(ISP) * & - ( RDBPI(IBI,1) * ABPIN(ISP,IPBPI(IBI,1)) & - + RDBPI(IBI,2) * ABPIN(ISP,IPBPI(IBI,2)) & - + RDBPI(IBI,3) * ABPIN(ISP,IPBPI(IBI,3)) & - + RDBPI(IBI,4) * ABPIN(ISP,IPBPI(IBI,4)) ) - END DO -! + BBPI0(ISP,IBI) = CG(MAPWN(ISP),ISEA) / SIG2(ISP) * & + ( RDBPI(IBI,1) * ABPI0(ISP,IPBPI(IBI,1)) & + + RDBPI(IBI,2) * ABPI0(ISP,IPBPI(IBI,2)) & + + RDBPI(IBI,3) * ABPI0(ISP,IPBPI(IBI,3)) & + + RDBPI(IBI,4) * ABPI0(ISP,IPBPI(IBI,4)) ) + END DO + END DO + ! + ! 1.b Shift BBPIN + ! + ELSE + BBPI0 = BBPIN + END IF + ! + ! 2. Process BBPIN -------------------------------------------------- * + ! + DO IBI=1, NBI + ISEA = ISBPI(IBI) + DO ISP=1, NSPEC + BBPIN(ISP,IBI) = CG(MAPWN(ISP),ISEA) / SIG2(ISP) * & + ( RDBPI(IBI,1) * ABPIN(ISP,IPBPI(IBI,1)) & + + RDBPI(IBI,2) * ABPIN(ISP,IPBPI(IBI,2)) & + + RDBPI(IBI,3) * ABPIN(ISP,IPBPI(IBI,3)) & + + RDBPI(IBI,4) * ABPIN(ISP,IPBPI(IBI,4)) ) + END DO + ! #ifdef W3_RTD - !! Rotate the spectra if model is on rotated grid. JGLi12Jun2012 - !! PoLat == 90. if the grid is standard lat/lon (C. Hansen 20190613) - IF ( PoLat < 90. ) THEN - Spectr = BBPIN(:,IBI) - AnglBP = AnglD(ISEA) - CALL W3ACTURN( NTH, NK, AnglBP, Spectr ) - BBPIN(:,IBI) = Spectr - END IF + !! Rotate the spectra if model is on rotated grid. JGLi12Jun2012 + !! PoLat == 90. if the grid is standard lat/lon (C. Hansen 20190613) + IF ( PoLat < 90. ) THEN + Spectr = BBPIN(:,IBI) + AnglBP = AnglD(ISEA) + CALL W3ACTURN( NTH, NK, AnglBP, Spectr ) + BBPIN(:,IBI) = Spectr + END IF #endif -! - END DO + ! + END DO -! 3. Wave height test output ---------------------------------------- * -! + ! 3. Wave height test output ---------------------------------------- * + ! #ifdef W3_T0 - WRITE (NDST,9000) - DO IBI=1, NBI - HS1 = 0. - HS2 = 0. - DO ISP=1, NSPEC - HS1 = HS1 + BBPI0(ISP,IBI) * DDEN(MAPWN(ISP)) / & - CG(MAPWN(ISP),ISBPI(IBI)) - HS2 = HS2 + BBPIN(ISP,IBI) * DDEN(MAPWN(ISP)) / & - CG(MAPWN(ISP),ISBPI(IBI)) - END DO - HS1 = 4. * SQRT ( HS1 ) - HS2 = 4. * SQRT ( HS2 ) - WRITE (NDST,9001) IBI, ISBPI(IBI), HS1, HS2 - END DO -#endif -! - RETURN -! -! Formats -! + WRITE (NDST,9000) + DO IBI=1, NBI + HS1 = 0. + HS2 = 0. + DO ISP=1, NSPEC + HS1 = HS1 + BBPI0(ISP,IBI) * DDEN(MAPWN(ISP)) / & + CG(MAPWN(ISP),ISBPI(IBI)) + HS2 = HS2 + BBPIN(ISP,IBI) * DDEN(MAPWN(ISP)) / & + CG(MAPWN(ISP),ISBPI(IBI)) + END DO + HS1 = 4. * SQRT ( HS1 ) + HS2 = 4. * SQRT ( HS2 ) + WRITE (NDST,9001) IBI, ISBPI(IBI), HS1, HS2 + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T0 - 9000 FORMAT ( ' TEST W3UBPT : WAVE HEIGHTS BBPI0/N (NO TAIL)') - 9001 FORMAT ( ' ',2I8,2X,2F8.2) +9000 FORMAT ( ' TEST W3UBPT : WAVE HEIGHTS BBPI0/N (NO TAIL)') +9001 FORMAT ( ' ',2I8,2X,2F8.2) #endif -!/ -!/ End of W3UBPT ----------------------------------------------------- / -!/ - END SUBROUTINE W3UBPT -!/ ------------------------------------------------------------------- / - SUBROUTINE W3UIC1( FLFRST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Sevigny | -!/ | FORTRAN 90 | -!/ | Last update : 27-Aug-2015 | -!/ +-----------------------------------+ -!/ -!/ 27-Aug-2015 : Creation ( version 5.10 ) -!/ -! 1. Purpose : -! -! Update ice thickness in the wave model. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FLFRST L. I Spectra in 1-D or 2-D representation -! (points to same address). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NSEA, NSEA, MAPSF, IICEHMIN, IICEHFAC - USE W3WDATMD, ONLY: TIME, TIC1, ICEH - USE W3IDATMD, ONLY: TI1, ICEP1, FLIC1 -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - LOGICAL, INTENT(IN) :: FLFRST -!/ -!/ ------------------------------------------------------------------- / -!/ Local variables -!/ - INTEGER :: IX, IY, ISEA -!/ -!/ -! 1. Preparations --------------------------------------------------- * -! 1.a Update times -! + !/ + !/ End of W3UBPT ----------------------------------------------------- / + !/ + END SUBROUTINE W3UBPT + !/ ------------------------------------------------------------------- / + SUBROUTINE W3UIC1( FLFRST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Sevigny | + !/ | FORTRAN 90 | + !/ | Last update : 27-Aug-2015 | + !/ +-----------------------------------+ + !/ + !/ 27-Aug-2015 : Creation ( version 5.10 ) + !/ + ! 1. Purpose : + ! + ! Update ice thickness in the wave model. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FLFRST L. I Spectra in 1-D or 2-D representation + ! (points to same address). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NSEA, NSEA, MAPSF, IICEHMIN, IICEHFAC + USE W3WDATMD, ONLY: TIME, TIC1, ICEH + USE W3IDATMD, ONLY: TI1, ICEP1, FLIC1 + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + LOGICAL, INTENT(IN) :: FLFRST + !/ + !/ ------------------------------------------------------------------- / + !/ Local variables + !/ + INTEGER :: IX, IY, ISEA + !/ + !/ + ! 1. Preparations --------------------------------------------------- * + ! 1.a Update times + ! #ifdef W3_T - WRITE (NDST,9010) TIME, TIC1, TI1 + WRITE (NDST,9010) TIME, TIC1, TI1 #endif - TIC1(1) = TI1(1) - TIC1(2) = TI1(2) + TIC1(1) = TI1(1) + TIC1(2) = TI1(2) -! 2. Main loop over sea points -------------------------------------- * + ! 2. Main loop over sea points -------------------------------------- * - DO ISEA=1, NSEA -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - ICEH(ISEA) = MAX(IICEHMIN,IICEHFAC*ICEP1(IX,IY)) - END DO -! - RETURN + DO ISEA=1, NSEA + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + ICEH(ISEA) = MAX(IICEHMIN,IICEHFAC*ICEP1(IX,IY)) + END DO + ! + RETURN #ifdef W3_T - 9010 FORMAT ( ' TEST W3UIC1 : TIME :',I9.8,I7.6/ & - ' OLD TICE :',I9.8,I7.6/ & - ' NEW TICE :',I9.8,I7.6) -#endif -!/ -!/ End of W3UIC1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3UIC1 -!/ ------------------------------------------------------------------- / - SUBROUTINE W3UIC5( FLFRST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Sevigny & F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jan-2016 | -!/ +-----------------------------------+ -!/ -!/ 27-Aug-2015 : Creation ( version 5.08 ) -!/ 13-Jan-2016 : Changed initial value of ICEDMAX ( version 5.08 ) -!/ -! 1. Purpose : -! -! Update ice floe mean and max diameters in the wave model. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FLFRST L. I Spectra in 1-D or 2-D representation -! (points to same address). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3IDATMD, ONLY: TI5, ICEP5 - USE W3GDATMD, ONLY: NSEA, MAPSF - USE W3WDATMD, ONLY: TIME, TIC5, ICE, ICEH, ICEF, ICEDMAX -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list - LOGICAL, INTENT(IN) :: FLFRST -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Local variables -!/ - INTEGER :: IX, IY, ISEA - LOGICAL :: FLFLOE -!/ -!/ -! 1. Preparations --------------------------------------------------- * -! 1.a Update times -! +9010 FORMAT ( ' TEST W3UIC1 : TIME :',I9.8,I7.6/ & + ' OLD TICE :',I9.8,I7.6/ & + ' NEW TICE :',I9.8,I7.6) +#endif + !/ + !/ End of W3UIC1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3UIC1 + !/ ------------------------------------------------------------------- / + SUBROUTINE W3UIC5( FLFRST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Sevigny & F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jan-2016 | + !/ +-----------------------------------+ + !/ + !/ 27-Aug-2015 : Creation ( version 5.08 ) + !/ 13-Jan-2016 : Changed initial value of ICEDMAX ( version 5.08 ) + !/ + ! 1. Purpose : + ! + ! Update ice floe mean and max diameters in the wave model. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FLFRST L. I Spectra in 1-D or 2-D representation + ! (points to same address). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3IDATMD, ONLY: TI5, ICEP5 + USE W3GDATMD, ONLY: NSEA, MAPSF + USE W3WDATMD, ONLY: TIME, TIC5, ICE, ICEH, ICEF, ICEDMAX + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + LOGICAL, INTENT(IN) :: FLFRST + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local variables + !/ + INTEGER :: IX, IY, ISEA + LOGICAL :: FLFLOE + !/ + !/ + ! 1. Preparations --------------------------------------------------- * + ! 1.a Update times + ! #ifdef W3_T - WRITE (NDST,9010) TIME, TIC5, TI5 + WRITE (NDST,9010) TIME, TIC5, TI5 #endif - TIC5(1) = TI5(1) - TIC5(2) = TI5(2) + TIC5(1) = TI5(1) + TIC5(2) = TI5(2) -! 2. Main loop over sea points -------------------------------------- * + ! 2. Main loop over sea points -------------------------------------- * - DO ISEA=1, NSEA -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - FLFLOE = ICE(ISEA) .EQ. 0 .OR. ICEH(ISEA) .EQ. 0 - IF ( FLFLOE) THEN - ICEF(ISEA) = 0.0 - ICEDMAX(ISEA) = 1000.0 - ELSE - ICEF(ISEA) = ICEP5(IX,IY) - ICEDMAX(ISEA) = ICEP5(IX,IY) - END IF - END DO -! - RETURN + DO ISEA=1, NSEA + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + FLFLOE = ICE(ISEA) .EQ. 0 .OR. ICEH(ISEA) .EQ. 0 + IF ( FLFLOE) THEN + ICEF(ISEA) = 0.0 + ICEDMAX(ISEA) = 1000.0 + ELSE + ICEF(ISEA) = ICEP5(IX,IY) + ICEDMAX(ISEA) = ICEP5(IX,IY) + END IF + END DO + ! + RETURN #ifdef W3_T - 9010 FORMAT ( ' TEST W3UIC5 : TIME :',I9.8,I7.6/ & - ' OLD TICE :',I9.8,I7.6/ & - ' NEW TICE :',I9.8,I7.6) +9010 FORMAT ( ' TEST W3UIC5 : TIME :',I9.8,I7.6/ & + ' OLD TICE :',I9.8,I7.6/ & + ' NEW TICE :',I9.8,I7.6) #endif -!/ -!/ -!/ End of W3UIC5 ----------------------------------------------------- / -!/ - END SUBROUTINE W3UIC5 -!/ ------------------------------------------------------------------- / - - SUBROUTINE W3UICE ( VA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 28-Mar-2014 | -!/ +-----------------------------------+ -!/ -!/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) -!/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 28-Jun-2005 : Adding MAPST2. ( version 3.07 ) -!/ Taking out initilization. -!/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 15-May-2010 : Adding second field for icebergs ( version 3.14 ) -!/ 13-Mar-2012 : Add initialization of UST on re- ( version 4.07 ) -!/ activation of grid point. -!/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) -!/ 28-Mar-2014 : Adapting to ICx source terms ( version 4.18 ) -!/ -! 1. Purpose : -! -! Update ice map in the wave model. -! -! 2. Method : -! -! Points with an ice concentration larger than FICEN are removed -! from the sea map in the wave model. Such points are identified -! by negative numbers is the grid status map MAPSTA. For ice -! points spectra are set to zero. Points from wich ice disappears -! are initialized with a "small" JONSWAP spectrum, based on the -! frequency SIG(NK-1) and the local wind direction. -! -! In the case of icebergs, the iceberg attenuation coefficient is -! added to the subgrid obstruction map. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! VA R.A. I/O Spectra in 1-D or 2-D representation -! (points to same address). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, MAPSTA, MAPST2, & - NSPEC, FICEN - USE W3WDATMD, ONLY: TIME, TICE, ICE, BERG, UST - USE W3ADATMD, ONLY: NSEALM + !/ + !/ + !/ End of W3UIC5 ----------------------------------------------------- / + !/ + END SUBROUTINE W3UIC5 + !/ ------------------------------------------------------------------- / + + SUBROUTINE W3UICE ( VA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 28-Mar-2014 | + !/ +-----------------------------------+ + !/ + !/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) + !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 28-Jun-2005 : Adding MAPST2. ( version 3.07 ) + !/ Taking out initilization. + !/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 15-May-2010 : Adding second field for icebergs ( version 3.14 ) + !/ 13-Mar-2012 : Add initialization of UST on re- ( version 4.07 ) + !/ activation of grid point. + !/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) + !/ 28-Mar-2014 : Adapting to ICx source terms ( version 4.18 ) + !/ + ! 1. Purpose : + ! + ! Update ice map in the wave model. + ! + ! 2. Method : + ! + ! Points with an ice concentration larger than FICEN are removed + ! from the sea map in the wave model. Such points are identified + ! by negative numbers is the grid status map MAPSTA. For ice + ! points spectra are set to zero. Points from wich ice disappears + ! are initialized with a "small" JONSWAP spectrum, based on the + ! frequency SIG(NK-1) and the local wind direction. + ! + ! In the case of icebergs, the iceberg attenuation coefficient is + ! added to the subgrid obstruction map. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! VA R.A. I/O Spectra in 1-D or 2-D representation + ! (points to same address). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, MAPSTA, MAPST2, & + NSPEC, FICEN + USE W3WDATMD, ONLY: TIME, TICE, ICE, BERG, UST + USE W3ADATMD, ONLY: NSEALM #if defined(W3_UWM) || defined(W3_CESMCOUPLED) - USE W3GDATMD, ONLY: aalpha - USE W3ADATMD, ONLY: charn -#endif - USE W3IDATMD, ONLY: TIN, ICEI, BERGI - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC, INIT_GET_ISEA -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(INOUT) :: VA(NSPEC,0:NSEALM) -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: ISEA, JSEA, IX, IY + USE W3GDATMD, ONLY: aalpha + USE W3ADATMD, ONLY: charn +#endif + USE W3IDATMD, ONLY: TIN, ICEI, BERGI + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC, INIT_GET_ISEA + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(INOUT) :: VA(NSPEC,0:NSEALM) + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: ISEA, JSEA, IX, IY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: MAPICE(NY,NX), ISPROC - LOGICAL :: LOCAL -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: MAPICE(NY,NX), ISPROC + LOGICAL :: LOCAL + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3UICE') + CALL STRACE (IENT, 'W3UICE') #endif -! - LOCAL = IAPROC .LE. NAPROC -! + ! + LOCAL = IAPROC .LE. NAPROC + ! #ifdef W3_T - WRITE (NDST,9000) FICEN - IF ( .NOT. LOCAL ) WRITE (NDST,9001) + WRITE (NDST,9000) FICEN + IF ( .NOT. LOCAL ) WRITE (NDST,9001) #endif -! -! 1. Preparations --------------------------------------------------- * -! 1.a Update times -! + ! + ! 1. Preparations --------------------------------------------------- * + ! 1.a Update times + ! #ifdef W3_T - WRITE (NDST,9010) TIME, TICE, TIN + WRITE (NDST,9010) TIME, TICE, TIN #endif - TICE(1) = TIN(1) - TICE(2) = TIN(2) -! -! 1.b Process maps -! + TICE(1) = TIN(1) + TICE(2) = TIN(2) + ! + ! 1.b Process maps + ! #ifdef W3_IC0 - MAPICE = MOD(MAPST2,2) - MAPST2 = MAPST2 - MAPICE -#endif -! -! 2. Main loop over sea points -------------------------------------- * -! - DO ISEA=1, NSEA -! -! 2.a Get grid counters -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - ICE(ISEA) = ICEI(IX,IY) - BERG(ISEA)= BERGI(IX,IY) -! -! 2.b Sea point to be de-activated.. -! + MAPICE = MOD(MAPST2,2) + MAPST2 = MAPST2 - MAPICE +#endif + ! + ! 2. Main loop over sea points -------------------------------------- * + ! + DO ISEA=1, NSEA + ! + ! 2.a Get grid counters + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + ICE(ISEA) = ICEI(IX,IY) + BERG(ISEA)= BERGI(IX,IY) + ! + ! 2.b Sea point to be de-activated.. + ! #ifdef W3_IC0 - IF ( ICEI(IX,IY).GE.FICEN .AND. MAPICE(IY,IX).EQ.0 ) THEN - MAPSTA(IY,IX) = - ABS(MAPSTA(IY,IX)) - MAPICE(IY,IX) = 1 - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) - IF (LOCAL .AND. (IAPROC .eq. ISPROC)) THEN + IF ( ICEI(IX,IY).GE.FICEN .AND. MAPICE(IY,IX).EQ.0 ) THEN + MAPSTA(IY,IX) = - ABS(MAPSTA(IY,IX)) + MAPICE(IY,IX) = 1 + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + IF (LOCAL .AND. (IAPROC .eq. ISPROC)) THEN #ifdef W3_T - WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & - ICEI(IX,IY), 'ICE (NEW)' + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'ICE (NEW)' #endif - VA(:,JSEA) = 0. + VA(:,JSEA) = 0. #if defined(W3_UWM) || defined(W3_CESMCOUPLED) - charn(jsea) = aalpha + charn(jsea) = aalpha #endif #ifdef W3_T - ELSE - WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & - ICEI(IX,IY), 'ICE (NEW X)' + ELSE + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'ICE (NEW X)' #endif - END IF -! + END IF + ! #ifdef W3_T - ELSE IF ( ICEI(IX,IY).GE.FICEN ) THEN - WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & - ICEI(IX,IY), 'ICE' + ELSE IF ( ICEI(IX,IY).GE.FICEN ) THEN + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'ICE' #endif - END IF -! -! 2.b Ice point to be re-activated. -! - IF ( ICEI(IX,IY).LT.FICEN .AND. MAPICE(IY,IX).EQ.1 ) THEN -! - MAPICE(IY,IX) = 0 - UST(ISEA) = 0.05 -! - IF ( MAPST2(IY,IX) .EQ. 0 ) THEN - MAPSTA(IY,IX) = ABS(MAPSTA(IY,IX)) -! - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) - IF ( LOCAL .AND. (IAPROC .eq. ISPROC) ) THEN + END IF + ! + ! 2.b Ice point to be re-activated. + ! + IF ( ICEI(IX,IY).LT.FICEN .AND. MAPICE(IY,IX).EQ.1 ) THEN + ! + MAPICE(IY,IX) = 0 + UST(ISEA) = 0.05 + ! + IF ( MAPST2(IY,IX) .EQ. 0 ) THEN + MAPSTA(IY,IX) = ABS(MAPSTA(IY,IX)) + ! + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + IF ( LOCAL .AND. (IAPROC .eq. ISPROC) ) THEN #ifdef W3_T - WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & - ICEI(IX,IY), 'SEA (NEW)' + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'SEA (NEW)' #endif - VA(:,JSEA) = 0. + VA(:,JSEA) = 0. #if defined(W3_UWM) || defined(W3_CESMCOUPLED) - charn(jsea) = aalpha + charn(jsea) = aalpha #endif -! + ! #ifdef W3_T - ELSE - WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & - ICEI(IX,IY), 'SEA (NEW X)' + ELSE + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'SEA (NEW X)' #endif - END IF -! + END IF + ! #ifdef W3_T - ELSE - WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & - ICEI(IX,IY), 'DIS' + ELSE + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'DIS' #endif - END IF -! + END IF + ! #ifdef W3_T - ELSE IF ( ICEI(IX,IY).LT.FICEN ) THEN - WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & - ICEI(IX,IY), 'SEA' + ELSE IF ( ICEI(IX,IY).LT.FICEN ) THEN + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'SEA' #endif -! - END IF + ! + END IF #endif -! - END DO -! -! 3. Update MAPST2 -------------------------------------------------- * -! + ! + END DO + ! + ! 3. Update MAPST2 -------------------------------------------------- * + ! #ifdef W3_IC0 - MAPST2 = MAPST2 + MAPICE + MAPST2 = MAPST2 + MAPICE #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3UICE : FICEN :',F9.3) - 9001 FORMAT ( ' TEST W3UICE : NO LOCAL SPECTRA') -! - 9010 FORMAT ( ' TEST W3UICE : TIME :',I9.8,I7.6/ & - ' OLD TICE :',I9.8,I7.6/ & - ' NEW TICE :',I9.8,I7.6) -! - 9020 FORMAT ( ' TEST W3UICE : ISEA, IX, IY, MAP, ICE, STATUS :') - 9021 FORMAT ( ' ',I8,3I4,F6.2,2X,A) -#endif -!/ -!/ End of W3UICE ----------------------------------------------------- / -!/ - END SUBROUTINE W3UICE -!/ ------------------------------------------------------------------- / - SUBROUTINE W3ULEV ( A, VA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 30-Apr-2002 : Water level fixes. ( version 2.20 ) -!/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 15-Jul-2005 : Adding drying out of points. ( version 3.07 ) -!/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 23-Aug-2011 : Bug fix for UG grids : new boundary ( version 4.04 ) -!/ 13-Mar-2012 : Add initialization of UST on re- ( version 4.07 ) -!/ activation of grid point. -!/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) -!/ 26-Sep-2012 : Adding update from tidal analysis ( version 4.08 ) -!/ -! 1. Purpose : -! -! Update the water level. -! -! 2. Method : -! -! The wavenumber grid is modified without modyfying the spectrum -! (conservative linear interpolation to new grid). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! (V)A R.A. I/O 2-D and 1-D represetation of the spectra. -! ---------------------------------------------------------------- -! -! Local variables -! ---------------------------------------------------------------- -! KDMAX Real Deep water cut-off for kd. -! WNO R.A. Old wavenumbers. -! CGO R.A. Old group velocities. -! OWN R.A. Old wavenumber band width. -! DWN R.A. New wavenumber band width. -! TA R.A. Auxiliary spectrum. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The grid is updated only if KDmin > KDMAX. -! - The grid is updated for inactive points too. -! - The local wavenumber bandwidth is DSIGMA/CG. -! - The local spectrum is updated only if the grid is updated, -! the grid point is not disabled (MAPST2) and if the change of -! the lowest wavenumber exceeds RDKMIN times the band width. -! - No spectral initialization for newly wet points. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Basic test output. -! !/T2 Output of minimum relative depth per grid point. -! !/T3 Spectra before and after -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSF, MAPSTA, MAPST2, & - ZB, DMIN, NK, NTH, NSPEC, SIG, DSIP, & - MAPWN, MAPTH, FACHFA, GTYPE, UNGTYPE, W3SETREF - USE W3WDATMD, ONLY: TIME, TLEV, WLV, UST - USE W3ADATMD, ONLY: CG, WN, DW - USE W3IDATMD, ONLY: TLN, WLEV - USE W3SERVMD, ONLY: EXTCDE - USE W3DISPMD, ONLY: WAVNU1 - USE W3TIMEMD - USE W3PARALL, only : INIT_GET_JSEA_ISPROC, INIT_GET_ISEA - USE W3PARALL, only : GET_JSEA_IBELONG - USE W3DISPMD, ONLY: WAVNU1 +9000 FORMAT ( ' TEST W3UICE : FICEN :',F9.3) +9001 FORMAT ( ' TEST W3UICE : NO LOCAL SPECTRA') + ! +9010 FORMAT ( ' TEST W3UICE : TIME :',I9.8,I7.6/ & + ' OLD TICE :',I9.8,I7.6/ & + ' NEW TICE :',I9.8,I7.6) + ! +9020 FORMAT ( ' TEST W3UICE : ISEA, IX, IY, MAP, ICE, STATUS :') +9021 FORMAT ( ' ',I8,3I4,F6.2,2X,A) +#endif + !/ + !/ End of W3UICE ----------------------------------------------------- / + !/ + END SUBROUTINE W3UICE + !/ ------------------------------------------------------------------- / + SUBROUTINE W3ULEV ( A, VA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 30-Apr-2002 : Water level fixes. ( version 2.20 ) + !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 15-Jul-2005 : Adding drying out of points. ( version 3.07 ) + !/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 23-Aug-2011 : Bug fix for UG grids : new boundary ( version 4.04 ) + !/ 13-Mar-2012 : Add initialization of UST on re- ( version 4.07 ) + !/ activation of grid point. + !/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) + !/ 26-Sep-2012 : Adding update from tidal analysis ( version 4.08 ) + !/ + ! 1. Purpose : + ! + ! Update the water level. + ! + ! 2. Method : + ! + ! The wavenumber grid is modified without modyfying the spectrum + ! (conservative linear interpolation to new grid). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! (V)A R.A. I/O 2-D and 1-D represetation of the spectra. + ! ---------------------------------------------------------------- + ! + ! Local variables + ! ---------------------------------------------------------------- + ! KDMAX Real Deep water cut-off for kd. + ! WNO R.A. Old wavenumbers. + ! CGO R.A. Old group velocities. + ! OWN R.A. Old wavenumber band width. + ! DWN R.A. New wavenumber band width. + ! TA R.A. Auxiliary spectrum. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - The grid is updated only if KDmin > KDMAX. + ! - The grid is updated for inactive points too. + ! - The local wavenumber bandwidth is DSIGMA/CG. + ! - The local spectrum is updated only if the grid is updated, + ! the grid point is not disabled (MAPST2) and if the change of + ! the lowest wavenumber exceeds RDKMIN times the band width. + ! - No spectral initialization for newly wet points. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Basic test output. + ! !/T2 Output of minimum relative depth per grid point. + ! !/T3 Spectra before and after + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSF, MAPSTA, MAPST2, & + ZB, DMIN, NK, NTH, NSPEC, SIG, DSIP, & + MAPWN, MAPTH, FACHFA, GTYPE, UNGTYPE, W3SETREF + USE W3WDATMD, ONLY: TIME, TLEV, WLV, UST + USE W3ADATMD, ONLY: CG, WN, DW + USE W3IDATMD, ONLY: TLN, WLEV + USE W3SERVMD, ONLY: EXTCDE + USE W3DISPMD, ONLY: WAVNU1 + USE W3TIMEMD + USE W3PARALL, only : INIT_GET_JSEA_ISPROC, INIT_GET_ISEA + USE W3PARALL, only : GET_JSEA_IBELONG + USE W3DISPMD, ONLY: WAVNU1 #ifdef W3_PDLIB - USE PDLIB_W3PROFSMD, ONLY : SET_IOBDP_PDLIB + USE PDLIB_W3PROFSMD, ONLY : SET_IOBDP_PDLIB #endif #ifdef W3_TIDE - USE W3GDATMD, ONLY: YGRD - USE W3IDATMD, ONLY: FLLEVTIDE, WLTIDE, NTIDE - USE W3TIDEMD + USE W3GDATMD, ONLY: YGRD + USE W3IDATMD, ONLY: FLLEVTIDE, WLTIDE, NTIDE + USE W3TIDEMD #endif #ifdef W3_SETUP - USE W3WDATMD, ONLY: ZETA_SETUP - USE W3GDATMD, ONLY : DO_CHANGE_WLV + USE W3WDATMD, ONLY: ZETA_SETUP + USE W3GDATMD, ONLY : DO_CHANGE_WLV #endif #ifdef W3_T3 - USE W3ARRYMD, ONLY: PRT2DS -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(INOUT) :: A(NTH,NK,0:NSEAL), VA(NSPEC,0:NSEAL) -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: ISEA, JSEA, IX, IY, IK, I1, I2, & - ISPEC, IK0, ITH + USE W3ARRYMD, ONLY: PRT2DS +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(INOUT) :: A(NTH,NK,0:NSEAL), VA(NSPEC,0:NSEAL) + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: ISEA, JSEA, IX, IY, IK, I1, I2, & + ISPEC, IK0, ITH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER :: MAPDRY(NY,NX), ISPROC - REAL :: DWO(NSEA), KDCHCK, WNO(0:NK+1), & - CGO(0:NK+1), DEPTH, & - RDK, RD1, RD2, TA(NTH,NK), & - OWN(NK), DWN(NK) - REAL :: KDMAX = 4., RDKMIN = 0.05 - REAL :: WLVeff + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER :: MAPDRY(NY,NX), ISPROC + REAL :: DWO(NSEA), KDCHCK, WNO(0:NK+1), & + CGO(0:NK+1), DEPTH, & + RDK, RD1, RD2, TA(NTH,NK), & + OWN(NK), DWN(NK) + REAL :: KDMAX = 4., RDKMIN = 0.05 + REAL :: WLVeff #ifdef W3_T3 - REAL :: OUT(NK,NTH) + REAL :: OUT(NK,NTH) #endif - LOGICAL :: LOCAL - INTEGER :: IBELONG -! + LOGICAL :: LOCAL + INTEGER :: IBELONG + ! #ifdef W3_TIDE - INTEGER :: J - INTEGER(KIND=4) :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" - REAL :: WLEVTIDE, TIDE_ARG, WLEVTIDE2(1) - REAL(KIND=8) :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau - REAL :: FX(44),UX(44),VX(44) -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: J + INTEGER(KIND=4) :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" + REAL :: WLEVTIDE, TIDE_ARG, WLEVTIDE2(1) + REAL(KIND=8) :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau + REAL :: FX(44),UX(44),VX(44) +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3ULEV') + CALL STRACE (IENT, 'W3ULEV') #endif -! - LOCAL = IAPROC .LE. NAPROC -! + ! + LOCAL = IAPROC .LE. NAPROC + ! #ifdef W3_T - WRITE (NDST,9000) KDMAX, RDKMIN -#endif -! -! 1. Preparations --------------------------------------------------- * -! 1.a Check NK -! - IF ( NK .LT. 2 ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) - CALL EXTCDE ( 1 ) - END IF -! -! 1.b Update times -! + WRITE (NDST,9000) KDMAX, RDKMIN +#endif + ! + ! 1. Preparations --------------------------------------------------- * + ! 1.a Check NK + ! + IF ( NK .LT. 2 ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) + CALL EXTCDE ( 1 ) + END IF + ! + ! 1.b Update times + ! #ifdef W3_T - WRITE (NDST,9010) TIME, TLEV + WRITE (NDST,9010) TIME, TLEV #endif - TLEV = TLN + TLEV = TLN #ifdef W3_T - WRITE (NDST,9011) TLEV -#endif -! -! 1.c Extract dry point map, and residual MAPST2 -! - MAPDRY = MOD(MAPST2/2,2) - MAPST2 = MAPST2 - 2*MAPDRY -! -! 1.d Update water levels and save old -! + WRITE (NDST,9011) TLEV +#endif + ! + ! 1.c Extract dry point map, and residual MAPST2 + ! + MAPDRY = MOD(MAPST2/2,2) + MAPST2 = MAPST2 - 2*MAPDRY + ! + ! 1.d Update water levels and save old + ! #ifdef W3_TIDE - IF (FLLEVTIDE) THEN -! WRITE(6,*) 'TIME:',TIME - TIDE_HOUR = TIME2HOURS(TIME) -! -!* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION -!* AT THE MID POINT OF THE ANALYSIS PERIOD. - d1=TIDE_HOUR/24.d0 - TIDE_KD0= 2415020 - d1=d1-dfloat(TIDE_kd0)-0.5d0 - call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) - INT24=24 - INTDYS=int((TIDE_HOUR+0.00001)/INT24) - HH=TIDE_HOUR-dfloat(INTDYS*INT24) - TAU=HH/24.D0+H-S - END IF -! -! ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU- -! TING THE LUNAR TIME TAU. -! -#endif - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - DWO(ISEA) = DW(ISEA) -! + IF (FLLEVTIDE) THEN + ! WRITE(6,*) 'TIME:',TIME + TIDE_HOUR = TIME2HOURS(TIME) + ! + !* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION + !* AT THE MID POINT OF THE ANALYSIS PERIOD. + d1=TIDE_HOUR/24.d0 + TIDE_KD0= 2415020 + d1=d1-dfloat(TIDE_kd0)-0.5d0 + call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) + INT24=24 + INTDYS=int((TIDE_HOUR+0.00001)/INT24) + HH=TIDE_HOUR-dfloat(INTDYS*INT24) + TAU=HH/24.D0+H-S + END IF + ! + ! ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU- + ! TING THE LUNAR TIME TAU. + ! +#endif + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + DWO(ISEA) = DW(ISEA) + ! #ifdef W3_TIDE - IF (FLLEVTIDE) THEN -! VUF should be updated only if latitude changes significantly ... - CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,REAL(YGRD(IY,IX)),FX,UX,VX) - WLEVTIDE = WLTIDE(IX,IY,1,1) - !Verification - ! IF (ISEA.EQ.1) THEN + IF (FLLEVTIDE) THEN + ! VUF should be updated only if latitude changes significantly ... + CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,REAL(YGRD(IY,IX)),FX,UX,VX) + WLEVTIDE = WLTIDE(IX,IY,1,1) + !Verification + ! IF (ISEA.EQ.1) THEN - TIDE_AMPC(1:NTIDE,1)=WLTIDE(IX,IY,1:NTIDE,1) - TIDE_PHG(1:NTIDE,1)=WLTIDE(IX,IY,1:NTIDE,2) -! - ! WRITE(991,'(A,F20.2,13F8.3)') 'TEST ISEA 0:', & - ! d1,H,S,TAU,pp,s,p,enp,dh,dpp,ds,dp,dnp,YGRD(IY,IX) - J=1 - ! WRITE(991,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & - ! FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) - DO J=2,TIDE_MF - TIDE_ARG=(VX(J)+UX(J))*twpi-WLTIDE(IX,IY,J,2)*DERA - WLEVTIDE =WLEVTIDE+FX(J)*WLTIDE(IX,IY,J,1)*COS(TIDE_ARG) - ! WRITE(991,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & - ! FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) - END DO - DO J=1,TIDE_MF - ! WRITE(991,'(A,4I9,F12.0,5F8.3)') 'TEST ISEA 2:',IX,J,TIME,TIDE_HOUR, & - ! FX(J),UX(J),VX(J),TIDE_AMPC(J,1),TIDE_PHG(J,1) - END DO - ! WRITE(991,'(A,3F7.3)') '#:',WLEV(IX,IY),WLEVTIDE,WLEV(IX,IY)-WLEVTIDE + TIDE_AMPC(1:NTIDE,1)=WLTIDE(IX,IY,1:NTIDE,1) + TIDE_PHG(1:NTIDE,1)=WLTIDE(IX,IY,1:NTIDE,2) + ! + ! WRITE(991,'(A,F20.2,13F8.3)') 'TEST ISEA 0:', & + ! d1,H,S,TAU,pp,s,p,enp,dh,dpp,ds,dp,dnp,YGRD(IY,IX) + J=1 + ! WRITE(991,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & + ! FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) + DO J=2,TIDE_MF + TIDE_ARG=(VX(J)+UX(J))*twpi-WLTIDE(IX,IY,J,2)*DERA + WLEVTIDE =WLEVTIDE+FX(J)*WLTIDE(IX,IY,J,1)*COS(TIDE_ARG) + ! WRITE(991,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & + ! FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) + END DO + DO J=1,TIDE_MF + ! WRITE(991,'(A,4I9,F12.0,5F8.3)') 'TEST ISEA 2:',IX,J,TIME,TIDE_HOUR, & + ! FX(J),UX(J),VX(J),TIDE_AMPC(J,1),TIDE_PHG(J,1) + END DO + ! WRITE(991,'(A,3F7.3)') '#:',WLEV(IX,IY),WLEVTIDE,WLEV(IX,IY)-WLEVTIDE #endif #ifdef W3_TIDE - ! CLOSE(991) - ! END IF - ! End of verification - WLV(ISEA) = WLEVTIDE - ELSE + ! CLOSE(991) + ! END IF + ! End of verification + WLV(ISEA) = WLEVTIDE + ELSE #endif -! + ! WLV(ISEA) = WLEV(IX,IY) WLVeff = WLV(ISEA) #ifdef W3_SETUP - IF (DO_CHANGE_WLV) THEN - WLVeff=WLVeff + ZETA_SETUP(ISEA) - END IF + IF (DO_CHANGE_WLV) THEN + WLVeff=WLVeff + ZETA_SETUP(ISEA) + END IF #endif #ifdef W3_TIDE - ENDIF + ENDIF #endif - DW (ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) + DW (ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) - END DO ! NSEA + END DO ! NSEA -! -! 2. Loop over all sea points --------------------------------------- * -! + ! + ! 2. Loop over all sea points --------------------------------------- * + ! #ifdef W3_T2 - WRITE (NDST,9020) -#endif -! - DO ISEA=1, NSEA -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) -! -! 2.a Check if deep water -! - KDCHCK = WN(1,ISEA) * MIN( DWO(ISEA) , DW(ISEA) ) - IF ( KDCHCK .LT. KDMAX ) THEN -! -! 2.b Update grid and save old grid -! - DEPTH = MAX ( DMIN, DW(ISEA) ) -! - DO IK=0, NK+1 - WNO(IK) = WN(IK,ISEA) - CGO(IK) = CG(IK,ISEA) -! -! Calculate wavenumbers and group velocities. - CALL WAVNU1(SIG(IK),DEPTH,WN(IK,ISEA),CG(IK,ISEA)) -! - END DO -! - DO IK=1, NK - OWN(IK) = DSIP(IK) / CGO(IK) - DWN(IK) = DSIP(IK) / CG(IK,ISEA) - END DO -! -! 2.c Process dry points -! - IF ( WLV(ISEA)-ZB(ISEA) .LE.0. ) THEN - IF ( MAPDRY(IY,IX) .EQ. 0 ) THEN - CALL GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) - IF ( LOCAL .AND. (IBELONG .eq. 1) ) THEN - VA(:,JSEA) = 0. - END IF - MAPDRY(IY,IX) = 1 - MAPSTA(IY,IX) = -ABS(MAPSTA(IY,IX)) + WRITE (NDST,9020) +#endif + ! + DO ISEA=1, NSEA + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + ! + ! 2.a Check if deep water + ! + KDCHCK = WN(1,ISEA) * MIN( DWO(ISEA) , DW(ISEA) ) + IF ( KDCHCK .LT. KDMAX ) THEN + ! + ! 2.b Update grid and save old grid + ! + DEPTH = MAX ( DMIN, DW(ISEA) ) + ! + DO IK=0, NK+1 + WNO(IK) = WN(IK,ISEA) + CGO(IK) = CG(IK,ISEA) + ! + ! Calculate wavenumbers and group velocities. + CALL WAVNU1(SIG(IK),DEPTH,WN(IK,ISEA),CG(IK,ISEA)) + ! + END DO + ! + DO IK=1, NK + OWN(IK) = DSIP(IK) / CGO(IK) + DWN(IK) = DSIP(IK) / CG(IK,ISEA) + END DO + ! + ! 2.c Process dry points + ! + IF ( WLV(ISEA)-ZB(ISEA) .LE.0. ) THEN + IF ( MAPDRY(IY,IX) .EQ. 0 ) THEN + CALL GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) + IF ( LOCAL .AND. (IBELONG .eq. 1) ) THEN + VA(:,JSEA) = 0. + END IF + MAPDRY(IY,IX) = 1 + MAPSTA(IY,IX) = -ABS(MAPSTA(IY,IX)) #ifdef W3_T2 - WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & - 0., 0., ' (NEW DRY)' - ELSE - WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & - 0., 0., ' (DRY)' -#endif - ENDIF - CYCLE - END IF -! -! 2.d Process new wet point -! - IF (WLV(ISEA)-ZB(ISEA).GT.0. .AND. MAPDRY(IY,IX).EQ.1) THEN - MAPDRY(IY,IX) = 0 -! -! Resets the spectrum to zero -! - CALL GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) - IF ( LOCAL .AND. (IBELONG .eq. 1) ) THEN - VA(:,JSEA) = 0. - END IF -! - UST(ISEA) = 0.05 - IF ( MAPST2(IY,IX) .EQ. 0 ) THEN - MAPSTA(IY,IX) = ABS(MAPSTA(IY,IX)) + WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & + 0., 0., ' (NEW DRY)' + ELSE + WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & + 0., 0., ' (DRY)' +#endif + ENDIF + CYCLE + END IF + ! + ! 2.d Process new wet point + ! + IF (WLV(ISEA)-ZB(ISEA).GT.0. .AND. MAPDRY(IY,IX).EQ.1) THEN + MAPDRY(IY,IX) = 0 + ! + ! Resets the spectrum to zero + ! + CALL GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) + IF ( LOCAL .AND. (IBELONG .eq. 1) ) THEN + VA(:,JSEA) = 0. + END IF + ! + UST(ISEA) = 0.05 + IF ( MAPST2(IY,IX) .EQ. 0 ) THEN + MAPSTA(IY,IX) = ABS(MAPSTA(IY,IX)) #ifdef W3_T2 - WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & - 0., 0., ' (NEW WET)' - ELSE - WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & - 0., 0., ' (NEW WET INACTIVE)' -#endif - END IF - CYCLE - END IF -! -! 2.e Check if ice on grid point, or if grid changes negligible -! - RDK = ABS(WNO(1)-WN(1,ISEA)) / DWN(1) -! + WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & + 0., 0., ' (NEW WET)' + ELSE + WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & + 0., 0., ' (NEW WET INACTIVE)' +#endif + END IF + CYCLE + END IF + ! + ! 2.e Check if ice on grid point, or if grid changes negligible + ! + RDK = ABS(WNO(1)-WN(1,ISEA)) / DWN(1) + ! #ifdef W3_T2 - IF ( MAPSTA(IY,IX) .LT. 0 ) THEN - WRITE (NDST,9021) & - ISEA, DW(ISEA), KDCHCK, RDK, ' (INACTIVE)' - ELSE IF ( RDK .LT. RDKMIN ) THEN - WRITE (NDST,9021) & - ISEA, DW(ISEA), KDCHCK, RDK, ' (NEGL)' - ELSE - WRITE (NDST,9021) & - ISEA, DW(ISEA), KDCHCK, RDK, ' ' - END IF -#endif -! - IF ( RDK.LT.RDKMIN .OR. MAPSTA(IY,IX).LT.0 ) CYCLE - CALL GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) - IF ( IBELONG .eq. 0) CYCLE -! - IF ( .NOT. LOCAL ) CYCLE -! -! 2.d Save discrete actions and clean spectrum -! - DO IK=1, NK - DO ITH=1, NTH -#ifdef W3_T3 - OUT(IK,ITH) = A(ITH,IK,JSEA) * SIG(IK) / CGO(IK) + IF ( MAPSTA(IY,IX) .LT. 0 ) THEN + WRITE (NDST,9021) & + ISEA, DW(ISEA), KDCHCK, RDK, ' (INACTIVE)' + ELSE IF ( RDK .LT. RDKMIN ) THEN + WRITE (NDST,9021) & + ISEA, DW(ISEA), KDCHCK, RDK, ' (NEGL)' + ELSE + WRITE (NDST,9021) & + ISEA, DW(ISEA), KDCHCK, RDK, ' ' + END IF #endif - TA(ITH,IK) = A(ITH,IK,JSEA) * OWN(IK) - END DO - END DO -! - VA(:,JSEA) = 0. -! + ! + IF ( RDK.LT.RDKMIN .OR. MAPSTA(IY,IX).LT.0 ) CYCLE + CALL GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) + IF ( IBELONG .eq. 0) CYCLE + ! + IF ( .NOT. LOCAL ) CYCLE + ! + ! 2.d Save discrete actions and clean spectrum + ! + DO IK=1, NK + DO ITH=1, NTH #ifdef W3_T3 - CALL PRT2DS ( NDST, NK, NK, NTH, OUT, SIG, ' ', & - TPI, 0., 1.E-5, 'F(f,th)', 'm2s', 'Before' ) -#endif -! -! 2.e Redistribute discrete action density -! - IF ( WNO(1) .LT. WN(1,ISEA) ) THEN - IK0 = 1 - I1 = 0 - I2 = 1 - 220 CONTINUE - IK0 = IK0 + 1 - IF ( IK0 .GT. NK+1 ) GOTO 251 - IF ( WNO(IK0) .GE. WN(1,ISEA) ) THEN - IK0 = IK0 - 1 - ELSE - GOTO 220 - END IF - ELSE - IK0 = 1 - I1 = 1 - I2 = 2 - END IF -! - DO IK=IK0, NK -! - 230 CONTINUE - IF ( WNO(IK) .GT. WN(I2,ISEA) ) THEN - I1 = I1 + 1 - IF ( I1 .GT. NK ) GOTO 250 - I2 = I1 + 1 - GOTO 230 - END IF -! - IF ( I1 .EQ. 0 ) THEN - RD1 = ( WN(1,ISEA) - WNO(IK) ) / DWN(1) - RD2 = 1. - RD1 - ELSE - RD1 = ( WN(I2,ISEA) - WNO(IK) ) / & - ( WN(I2,ISEA) - WN(I1,ISEA) ) - RD2 = 1. - RD1 - END IF -! - IF ( I1 .GE. 1 ) THEN - DO ITH=1, NTH - A(ITH,I1,JSEA) = A(ITH,I1,JSEA) + RD1*TA(ITH,IK) - END DO - END IF -! - IF ( I2 .LE. NK ) THEN - DO ITH=1, NTH - A(ITH,I2,JSEA) = A(ITH,I2,JSEA) + RD2*TA(ITH,IK) - END DO - END IF -! - 250 CONTINUE + OUT(IK,ITH) = A(ITH,IK,JSEA) * SIG(IK) / CGO(IK) +#endif + TA(ITH,IK) = A(ITH,IK,JSEA) * OWN(IK) END DO - 251 CONTINUE -! -! 2.f Convert discrete action densities to spectrum -! - DO ISPEC=1, NSPEC - VA(ISPEC,JSEA) = VA(ISPEC,JSEA) / DWN(MAPWN(ISPEC)) + END DO + ! + VA(:,JSEA) = 0. + ! +#ifdef W3_T3 + CALL PRT2DS ( NDST, NK, NK, NTH, OUT, SIG, ' ', & + TPI, 0., 1.E-5, 'F(f,th)', 'm2s', 'Before' ) +#endif + ! + ! 2.e Redistribute discrete action density + ! + IF ( WNO(1) .LT. WN(1,ISEA) ) THEN + IK0 = 1 + I1 = 0 + I2 = 1 +220 CONTINUE + IK0 = IK0 + 1 + IF ( IK0 .GT. NK+1 ) GOTO 251 + IF ( WNO(IK0) .GE. WN(1,ISEA) ) THEN + IK0 = IK0 - 1 + ELSE + GOTO 220 + END IF + ELSE + IK0 = 1 + I1 = 1 + I2 = 2 + END IF + ! + DO IK=IK0, NK + ! +230 CONTINUE + IF ( WNO(IK) .GT. WN(I2,ISEA) ) THEN + I1 = I1 + 1 + IF ( I1 .GT. NK ) GOTO 250 + I2 = I1 + 1 + GOTO 230 + END IF + ! + IF ( I1 .EQ. 0 ) THEN + RD1 = ( WN(1,ISEA) - WNO(IK) ) / DWN(1) + RD2 = 1. - RD1 + ELSE + RD1 = ( WN(I2,ISEA) - WNO(IK) ) / & + ( WN(I2,ISEA) - WN(I1,ISEA) ) + RD2 = 1. - RD1 + END IF + ! + IF ( I1 .GE. 1 ) THEN + DO ITH=1, NTH + A(ITH,I1,JSEA) = A(ITH,I1,JSEA) + RD1*TA(ITH,IK) END DO -! -! 2.f Add tail if necessary -! - IF ( I2.LE.NK .AND. RD2.LE.0.95 ) THEN - DO IK=MAX(I2,2), NK - DO ITH=1, NTH - A(ITH,IK,JSEA) = FACHFA * A(ITH,IK-1,JSEA) - END DO - END DO - END IF -! + END IF + ! + IF ( I2 .LE. NK ) THEN + DO ITH=1, NTH + A(ITH,I2,JSEA) = A(ITH,I2,JSEA) + RD2*TA(ITH,IK) + END DO + END IF + ! +250 CONTINUE + END DO +251 CONTINUE + ! + ! 2.f Convert discrete action densities to spectrum + ! + DO ISPEC=1, NSPEC + VA(ISPEC,JSEA) = VA(ISPEC,JSEA) / DWN(MAPWN(ISPEC)) + END DO + ! + ! 2.f Add tail if necessary + ! + IF ( I2.LE.NK .AND. RD2.LE.0.95 ) THEN + DO IK=MAX(I2,2), NK + DO ITH=1, NTH + A(ITH,IK,JSEA) = FACHFA * A(ITH,IK-1,JSEA) + END DO + END DO + END IF + ! #ifdef W3_T3 - DO ISPEC=1, NSPEC - IK = MAPWN(ISPEC) - ITH = MAPTH(ISPEC) - OUT(IK,ITH) = A(ITH,IK,JSEA) * SIG(IK) / CG(IK,ISEA) - END DO + DO ISPEC=1, NSPEC + IK = MAPWN(ISPEC) + ITH = MAPTH(ISPEC) + OUT(IK,ITH) = A(ITH,IK,JSEA) * SIG(IK) / CG(IK,ISEA) + END DO #endif -! + ! #ifdef W3_T3 - CALL PRT2DS ( NDST, NK, NK, NTH, OUT, SIG, ' ', & - TPI, 0., 1.E-5, 'F(f,th)', 'm2s', 'After' ) + CALL PRT2DS ( NDST, NK, NK, NTH, OUT, SIG, ' ', & + TPI, 0., 1.E-5, 'F(f,th)', 'm2s', 'After' ) #endif -! + ! #ifdef W3_T2 - ELSE - WRITE (NDST,9021) ISEA, KDCHCK, ' (DEEP)' + ELSE + WRITE (NDST,9021) ISEA, KDCHCK, ' (DEEP)' #endif - END IF -! - END DO ! NSEA -! -! 3. Reconstruct new MAPST2 ----------------------------------------- * -! - MAPST2 = MAPST2 + 2*MAPDRY -! -! 4. Re-generates the boundary data ---------------------------------- * -! - IF (GTYPE.EQ.UNGTYPE) THEN - !CALL SET_UG_IOBP + END IF + ! + END DO ! NSEA + ! + ! 3. Reconstruct new MAPST2 ----------------------------------------- * + ! + MAPST2 = MAPST2 + 2*MAPDRY + ! + ! 4. Re-generates the boundary data ---------------------------------- * + ! + IF (GTYPE.EQ.UNGTYPE) THEN + !CALL SET_UG_IOBP #ifdef W3_PDLIB - CALL SET_IOBDP_PDLIB + CALL SET_IOBDP_PDLIB #endif #ifdef W3_REF1 - ELSE - CALL W3SETREF -#endif - ENDIF -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** ERROR W3ULEV *** '/ & - ' THIS ROUTINE REQUIRES NK > 1 '/) -! + ELSE + CALL W3SETREF +#endif + ENDIF + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** ERROR W3ULEV *** '/ & + ' THIS ROUTINE REQUIRES NK > 1 '/) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3ULEV : KDMAX :',F6.1/ & - ' RDKMIN :',F8.3) +9000 FORMAT ( ' TEST W3ULEV : KDMAX :',F6.1/ & + ' RDKMIN :',F8.3) #endif -! + ! #ifdef W3_T - 9010 FORMAT ( ' TEST W3ULEV : TIME :',I9.8,I7.6/ & - ' OLD TLEV :',I9.8,I7.6) - 9011 FORMAT ( ' NEW TLEV :',I9.8,I7.6) +9010 FORMAT ( ' TEST W3ULEV : TIME :',I9.8,I7.6/ & + ' OLD TLEV :',I9.8,I7.6) +9011 FORMAT ( ' NEW TLEV :',I9.8,I7.6) #endif -! + ! #ifdef W3_T2 - 9020 FORMAT ( ' TEST W3ULEV : LOOP OVER ALL POINTS:', & - ' ISEA, DW, KDMIN, RDK : ') - 9021 FORMAT ( ' ',I6,F8.2,F6.2,F7.3,A) -#endif -!/ -!/ End of W3ULEV ----------------------------------------------------- / -!/ - END SUBROUTINE W3ULEV -!/ ------------------------------------------------------------------- / - SUBROUTINE W3URHO ( FLFRST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | J. M. Castillo | -!/ | FORTRAN 90 | -!/ | Last update : 13-Aug-2021 | -!/ +-----------------------------------+ -!/ -!/ 22-Mar-2021 : First implementation ( version 7.13 ) -!/ 13-Aug-2021 : Enable time interpolation ( version 7.14 ) -!/ -! 1. Purpose : -! -! Interpolate air density field to the given time. -! -! 2. Method : -! -! Linear interpolation. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FLFRST Log. I Flag for first pass through routine. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Only air density over sea points is considered. -! - Time ranges checked in W3WAVE. -! -! 8. Structure : -! -! -------------------------------------- -! 1. Prepare auxiliary arrays -! 2. Calculate interpolation factors -! 3. Get actual air density -! -------------------------------------- -! -! 9. Switches : -! -! !/OMPG OpenMP compiler directives -! -! !/WNT0 No air density interpolation. -! !/WNT1 Linear air density interpolation. -! !/WNT2 Linear air density interpolation (and energy conservation for momentum). -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NSEA, MAPSF +9020 FORMAT ( ' TEST W3ULEV : LOOP OVER ALL POINTS:', & + ' ISEA, DW, KDMIN, RDK : ') +9021 FORMAT ( ' ',I6,F8.2,F6.2,F7.3,A) +#endif + !/ + !/ End of W3ULEV ----------------------------------------------------- / + !/ + END SUBROUTINE W3ULEV + !/ ------------------------------------------------------------------- / + SUBROUTINE W3URHO ( FLFRST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | J. M. Castillo | + !/ | FORTRAN 90 | + !/ | Last update : 13-Aug-2021 | + !/ +-----------------------------------+ + !/ + !/ 22-Mar-2021 : First implementation ( version 7.13 ) + !/ 13-Aug-2021 : Enable time interpolation ( version 7.14 ) + !/ + ! 1. Purpose : + ! + ! Interpolate air density field to the given time. + ! + ! 2. Method : + ! + ! Linear interpolation. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FLFRST Log. I Flag for first pass through routine. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Only air density over sea points is considered. + ! - Time ranges checked in W3WAVE. + ! + ! 8. Structure : + ! + ! -------------------------------------- + ! 1. Prepare auxiliary arrays + ! 2. Calculate interpolation factors + ! 3. Get actual air density + ! -------------------------------------- + ! + ! 9. Switches : + ! + ! !/OMPG OpenMP compiler directives + ! + ! !/WNT0 No air density interpolation. + ! !/WNT1 Linear air density interpolation. + ! !/WNT2 Linear air density interpolation (and energy conservation for momentum). + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NSEA, MAPSF #ifdef W3_SMC - USE W3GDATMD, ONLY: FSWND -#endif - USE W3WDATMD, ONLY: TIME, TRHO, RHOAIR - USE W3IDATMD, ONLY: TR0, TRN, RH0, RHN - USE W3ADATMD, ONLY: RA0, RAI - USE W3ODATMD, ONLY: IAPROC, NAPROC -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - LOGICAL, INTENT(IN) :: FLFRST -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: ISEA, IX, IY + USE W3GDATMD, ONLY: FSWND +#endif + USE W3WDATMD, ONLY: TIME, TRHO, RHOAIR + USE W3IDATMD, ONLY: TR0, TRN, RH0, RHN + USE W3ADATMD, ONLY: RA0, RAI + USE W3ODATMD, ONLY: IAPROC, NAPROC + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + LOGICAL, INTENT(IN) :: FLFRST + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: ISEA, IX, IY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: DT0N, DT0T, RD -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: DT0N, DT0T, RD + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3URHO') + CALL STRACE (IENT, 'W3URHO') #endif -! -! 1. Prepare auxiliary arrays -! - IF ( FLFRST ) THEN - DO ISEA=1, NSEA + ! + ! 1. Prepare auxiliary arrays + ! + IF ( FLFRST ) THEN + DO ISEA=1, NSEA #ifdef W3_SMC - !!Li For sea-point only SMC grid air density is stored on - !!Li 2-D RH0(NSEA, 1) variable. + !!Li For sea-point only SMC grid air density is stored on + !!Li 2-D RH0(NSEA, 1) variable. IF( FSWND ) THEN - IX = ISEA - IY = 1 + IX = ISEA + IY = 1 ELSE #endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) #ifdef W3_SMC ENDIF #endif - RA0(ISEA) = RH0(IX,IY) - RAI(ISEA) = RHN(IX,IY) - RH0(IX,IY) - END DO - END IF -! -! 2. Calculate interpolation factor -! - DT0N = DSEC21 ( TR0, TRN ) - DT0T = DSEC21 ( TR0, TIME ) -! + RA0(ISEA) = RH0(IX,IY) + RAI(ISEA) = RHN(IX,IY) - RH0(IX,IY) + END DO + END IF + ! + ! 2. Calculate interpolation factor + ! + DT0N = DSEC21 ( TR0, TRN ) + DT0T = DSEC21 ( TR0, TIME ) + ! #ifdef W3_WNT0 - RD = 0. + RD = 0. #endif #ifdef W3_WNT1 - RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD = DT0T / MAX ( 1.E-7 , DT0N ) #endif #ifdef W3_WNT2 - RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD = DT0T / MAX ( 1.E-7 , DT0N ) #endif #ifdef W3_OASACM - RD = 1. + RD = 1. #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) DT0N, DT0T, RD + WRITE (NDST,9000) DT0N, DT0T, RD #endif -! -! 3. Actual momentum for all grid points -! + ! + ! 3. Actual momentum for all grid points + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE (ISEA,RA0,RAI) -#endif -! - DO ISEA=1, NSEA -! - RHOAIR(ISEA) = RA0(ISEA) + RD * RAI(ISEA) -! - END DO -! - RETURN -! -! Formats -! + !$OMP PARALLEL DO PRIVATE (ISEA,RA0,RAI) +#endif + ! + DO ISEA=1, NSEA + ! + RHOAIR(ISEA) = RA0(ISEA) + RD * RAI(ISEA) + ! + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3URHO : DT0N, DT0T, RD :',2F8.1,F6.3) -#endif -!/ -!/ End of W3URHO ----------------------------------------------------- / -!/ - END SUBROUTINE W3URHO -!/ ------------------------------------------------------------------- / - SUBROUTINE W3UTRN ( TRNX, TRNY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ 02-Apr-2001 : Origination. ( version 2.10 ) -!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) -!/ 30-Apr-2002 : Change to ICE on storage grid. ( version 2.20 ) -!/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 11-Jan-2007 : Clean-up for boundary points. ( version 3.10 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! Update cell boundary transparencies for general use in propagation -! routines. -! -! 2. Method : -! -! Two arrays are generated with the size (NY*NX,-1:1). The value -! at (IXY,-1) indicates the transparency to be used if the lower -! or left boundary is an inflow boundary. (IXY,1) is used if the -! upper or right boundary is an inflow boundary. (IXY,0) is used -! for all other cases (by definition full transparency). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! TRNX/Y R.A. I Transparencies from model defintion file. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Basic test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSTA, MAPSF, & - TRFLAG, FICE0, FICEN, FICEL, & - RLGTYPE, CLGTYPE, GTYPE, FLAGLL, & - HPFAC, HQFAC, FFACBERG - USE W3WDATMD, ONLY: ICE, BERG - USE W3ADATMD, ONLY: ATRNX, ATRNY -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: TRNX(NY*NX), TRNY(NY*NX) -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: ISEA, IX, IY, IXY, IXN, IXP, IYN, IYP +9000 FORMAT (' TEST W3URHO : DT0N, DT0T, RD :',2F8.1,F6.3) +#endif + !/ + !/ End of W3URHO ----------------------------------------------------- / + !/ + END SUBROUTINE W3URHO + !/ ------------------------------------------------------------------- / + SUBROUTINE W3UTRN ( TRNX, TRNY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ + !/ 02-Apr-2001 : Origination. ( version 2.10 ) + !/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) + !/ 30-Apr-2002 : Change to ICE on storage grid. ( version 2.20 ) + !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 11-Jan-2007 : Clean-up for boundary points. ( version 3.10 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ + ! 1. Purpose : + ! + ! Update cell boundary transparencies for general use in propagation + ! routines. + ! + ! 2. Method : + ! + ! Two arrays are generated with the size (NY*NX,-1:1). The value + ! at (IXY,-1) indicates the transparency to be used if the lower + ! or left boundary is an inflow boundary. (IXY,1) is used if the + ! upper or right boundary is an inflow boundary. (IXY,0) is used + ! for all other cases (by definition full transparency). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! TRNX/Y R.A. I Transparencies from model defintion file. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Basic test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSTA, MAPSF, & + TRFLAG, FICE0, FICEN, FICEL, & + RLGTYPE, CLGTYPE, GTYPE, FLAGLL, & + HPFAC, HQFAC, FFACBERG + USE W3WDATMD, ONLY: ICE, BERG + USE W3ADATMD, ONLY: ATRNX, ATRNY + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: TRNX(NY*NX), TRNY(NY*NX) + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: ISEA, IX, IY, IXY, IXN, IXP, IYN, IYP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T - INTEGER :: ILEV, NLEV + INTEGER :: ILEV, NLEV #endif - REAL :: TRIX(NY*NX), TRIY(NY*NX), DX, DY, & - LICE0, LICEN + REAL :: TRIX(NY*NX), TRIY(NY*NX), DX, DY, & + LICE0, LICEN #ifdef W3_T - REAL :: LEVS(0:10) + REAL :: LEVS(0:10) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3UTRN') + CALL STRACE (IENT, 'W3UTRN') #endif #ifdef W3_T - WRITE (NDST,9000) TRFLAG + WRITE (NDST,9000) TRFLAG #endif -! -! 1. Preparations --------------------------------------------------- * -! - ATRNX = 1. - ATRNY = 1. + ! + ! 1. Preparations --------------------------------------------------- * + ! + ATRNX = 1. + ATRNY = 1. #ifdef W3_T - WRITE (NDST,9001) 'INITIALIZING ATRNX/Y' + WRITE (NDST,9001) 'INITIALIZING ATRNX/Y' #endif -! -! 2. Filling arrays from TRNX/Y for obstructions -------------------- * -! 2.a TRFLAG = 0, no action needed - IF ( TRFLAG .EQ. 0 ) THEN + ! + ! 2. Filling arrays from TRNX/Y for obstructions -------------------- * + ! 2.a TRFLAG = 0, no action needed + IF ( TRFLAG .EQ. 0 ) THEN #ifdef W3_T - WRITE (NDST,9001) 'NO FURTHER ACTION REQUIRED' + WRITE (NDST,9001) 'NO FURTHER ACTION REQUIRED' #endif - RETURN -! -! 2.b TRFLAG = 1,3: TRNX/Y defined at boundaries -! - ELSE IF ( TRFLAG.EQ.1 .OR. TRFLAG.EQ.3 .OR. TRFLAG.EQ.5 ) THEN -#ifdef W3_T - WRITE (NDST,9001) 'DATA APPLIED AT CELL BOUNDARIES' - LEVS = 0. -#endif -! - DO ISEA=1, NSEA -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) - IF ( IX .EQ. 1 ) THEN - ATRNX(IXY,-1) = TRNX(IY+(NX-1)*NY) - ATRNX(IXY, 1) = TRNX(IXY) - ELSE IF ( IX .EQ. NX ) THEN - ATRNX(IXY,-1) = TRNX(IXY-NY) - ATRNX(IXY, 1) = TRNX(IY) - ELSE - ATRNX(IXY,-1) = TRNX(IXY-NY) - ATRNX(IXY, 1) = TRNX(IXY) - END IF - ATRNY(IXY,-1) = TRNY(IXY-1) - ATRNY(IXY, 1) = TRNY(IXY) -! + RETURN + ! + ! 2.b TRFLAG = 1,3: TRNX/Y defined at boundaries + ! + ELSE IF ( TRFLAG.EQ.1 .OR. TRFLAG.EQ.3 .OR. TRFLAG.EQ.5 ) THEN #ifdef W3_T - ILEV = NINT(10.*MIN(TRNX(IXY),TRNY(IXY))) - LEVS(ILEV) = LEVS(ILEV) + 1. + WRITE (NDST,9001) 'DATA APPLIED AT CELL BOUNDARIES' + LEVS = 0. #endif -! - END DO -! -! 2.c TRFLAG = 2,4: TRNX/Y defined at cell centers -! + ! + DO ISEA=1, NSEA + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + IF ( IX .EQ. 1 ) THEN + ATRNX(IXY,-1) = TRNX(IY+(NX-1)*NY) + ATRNX(IXY, 1) = TRNX(IXY) + ELSE IF ( IX .EQ. NX ) THEN + ATRNX(IXY,-1) = TRNX(IXY-NY) + ATRNX(IXY, 1) = TRNX(IY) ELSE + ATRNX(IXY,-1) = TRNX(IXY-NY) + ATRNX(IXY, 1) = TRNX(IXY) + END IF + ATRNY(IXY,-1) = TRNY(IXY-1) + ATRNY(IXY, 1) = TRNY(IXY) + ! #ifdef W3_T - WRITE (NDST,9001) 'DATA APPLIED AT CELL CENTERS' - LEVS = 0. -#endif -! - DO ISEA=1, NSEA -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) -! - IF ( IX .EQ. 1 ) THEN - IXN = IY + (NX-1)*NY - IXP = IY + IX *NY - ELSE IF ( IX .EQ. NX ) THEN - IXN = IY + (IX-2)*NY - IXP = IY - ELSE - IXN = IY + (IX-2)*NY - IXP = IY + IX *NY - END IF -! - IF ( IY .EQ. 1 ) THEN - IYN = IXY - IYP = IXY + 1 - ELSE IF ( IY .EQ. NY ) THEN - IYN = IXY - 1 - IYP = IXY - ELSE - IYN = IXY - 1 - IYP = IXY + 1 - END IF -! -! factors 0.5 in first term and 2. in second term cancel -! - ATRNX(IXY,-1) = (1.+TRNX(IXY)) * TRNX(IXN)/(1.+TRNX(IXN)) - ATRNX(IXY, 1) = (1.+TRNX(IXY)) * TRNX(IXP)/(1.+TRNX(IXP)) - ATRNY(IXY,-1) = (1.+TRNY(IXY)) * TRNY(IYN)/(1.+TRNY(IYN)) - ATRNY(IXY, 1) = (1.+TRNY(IXY)) * TRNY(IYP)/(1.+TRNY(IYP)) -! - IF ( MAPSTA(IY,IX) .EQ. 2 ) THEN - IF ( IX .EQ. 1 ) THEN - ATRNX(IXY,-1) = 1. - ELSE IF ( MAPSTA( IY ,IX-1) .LE. 0 ) THEN - ATRNX(IXY,-1) = 1. - END IF - IF ( IX .EQ. NX ) THEN - ATRNX(IXY, 1) = 1. - ELSE IF ( MAPSTA( IY ,IX+1) .LE. 0 ) THEN - ATRNX(IXY, 1) = 1. - END IF - IF ( IY .EQ. 1 ) THEN - ATRNY(IXY,-1) = 1. - ELSE IF ( MAPSTA(IY-1, IX ) .LE. 0 ) THEN - ATRNY(IXY,-1) = 1. - END IF - IF ( IY .EQ. NY ) THEN - ATRNY(IXY, 1) = 1. - ELSE IF ( MAPSTA(IY+1, IX ) .LE. 0 ) THEN - ATRNY(IXY, 1) = 1. - END IF - END IF -! + ILEV = NINT(10.*MIN(TRNX(IXY),TRNY(IXY))) + LEVS(ILEV) = LEVS(ILEV) + 1. +#endif + ! + END DO + ! + ! 2.c TRFLAG = 2,4: TRNX/Y defined at cell centers + ! + ELSE #ifdef W3_T - ILEV = NINT(10.*MIN(TRNX(IXY),TRNY(IXY))) - LEVS(ILEV) = LEVS(ILEV) + 1. + WRITE (NDST,9001) 'DATA APPLIED AT CELL CENTERS' + LEVS = 0. #endif -! - END DO + ! + DO ISEA=1, NSEA + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + ! + IF ( IX .EQ. 1 ) THEN + IXN = IY + (NX-1)*NY + IXP = IY + IX *NY + ELSE IF ( IX .EQ. NX ) THEN + IXN = IY + (IX-2)*NY + IXP = IY + ELSE + IXN = IY + (IX-2)*NY + IXP = IY + IX *NY + END IF + ! + IF ( IY .EQ. 1 ) THEN + IYN = IXY + IYP = IXY + 1 + ELSE IF ( IY .EQ. NY ) THEN + IYN = IXY - 1 + IYP = IXY + ELSE + IYN = IXY - 1 + IYP = IXY + 1 + END IF + ! + ! factors 0.5 in first term and 2. in second term cancel + ! + ATRNX(IXY,-1) = (1.+TRNX(IXY)) * TRNX(IXN)/(1.+TRNX(IXN)) + ATRNX(IXY, 1) = (1.+TRNX(IXY)) * TRNX(IXP)/(1.+TRNX(IXP)) + ATRNY(IXY,-1) = (1.+TRNY(IXY)) * TRNY(IYN)/(1.+TRNY(IYN)) + ATRNY(IXY, 1) = (1.+TRNY(IXY)) * TRNY(IYP)/(1.+TRNY(IYP)) + ! + IF ( MAPSTA(IY,IX) .EQ. 2 ) THEN + IF ( IX .EQ. 1 ) THEN + ATRNX(IXY,-1) = 1. + ELSE IF ( MAPSTA( IY ,IX-1) .LE. 0 ) THEN + ATRNX(IXY,-1) = 1. + END IF + IF ( IX .EQ. NX ) THEN + ATRNX(IXY, 1) = 1. + ELSE IF ( MAPSTA( IY ,IX+1) .LE. 0 ) THEN + ATRNX(IXY, 1) = 1. + END IF + IF ( IY .EQ. 1 ) THEN + ATRNY(IXY,-1) = 1. + ELSE IF ( MAPSTA(IY-1, IX ) .LE. 0 ) THEN + ATRNY(IXY,-1) = 1. + END IF + IF ( IY .EQ. NY ) THEN + ATRNY(IXY, 1) = 1. + ELSE IF ( MAPSTA(IY+1, IX ) .LE. 0 ) THEN + ATRNY(IXY, 1) = 1. + END IF END IF -! + ! #ifdef W3_T - WRITE(NDST,9010) 'ISLANDS' - NLEV = 0 - DO ILEV=0, 10 - WRITE (NDST,9011) ILEV, LEVS(ILEV)/REAL(NSEA) - NLEV = NLEV + NINT(LEVS(ILEV)) - END DO + ILEV = NINT(10.*MIN(TRNX(IXY),TRNY(IXY))) + LEVS(ILEV) = LEVS(ILEV) + 1. #endif -! -! 3. Adding ice to obstructions ------------------------------------- * -! 3.a TRFLAG < 3, no action needed -! - IF ( TRFLAG.LT.3 .OR. FICEN-FICE0.LT.1.E-6 ) THEN + ! + END DO + END IF + ! +#ifdef W3_T + WRITE(NDST,9010) 'ISLANDS' + NLEV = 0 + DO ILEV=0, 10 + WRITE (NDST,9011) ILEV, LEVS(ILEV)/REAL(NSEA) + NLEV = NLEV + NINT(LEVS(ILEV)) + END DO +#endif + ! + ! 3. Adding ice to obstructions ------------------------------------- * + ! 3.a TRFLAG < 3, no action needed + ! + IF ( TRFLAG.LT.3 .OR. FICEN-FICE0.LT.1.E-6 ) THEN #ifdef W3_T - WRITE (NDST,9001) 'NO ICE ACTION REQUIRED' + WRITE (NDST,9001) 'NO ICE ACTION REQUIRED' #endif - RETURN -! -! 3.b TRFLAG = 3,4: Calculate ice transparencies -! - ELSE + RETURN + ! + ! 3.b TRFLAG = 3,4: Calculate ice transparencies + ! + ELSE #ifdef W3_T - WRITE (NDST,9001) 'CALCULATE ICE TRANSPARENCIES' - LEVS = 0. -#endif - TRIX = 1. - TRIY = 1. -! - DO ISEA=1, NSEA -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) -! - DX = HPFAC(IY,IX) - DY = HQFAC(IY,IX) - IF ( FLAGLL ) THEN - DX = DX * RADIUS * DERA - DY = DY * RADIUS * DERA - END IF + WRITE (NDST,9001) 'CALCULATE ICE TRANSPARENCIES' + LEVS = 0. +#endif + TRIX = 1. + TRIY = 1. + ! + DO ISEA=1, NSEA + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + ! + DX = HPFAC(IY,IX) + DY = HQFAC(IY,IX) + IF ( FLAGLL ) THEN + DX = DX * RADIUS * DERA + DY = DY * RADIUS * DERA + END IF -! + ! #ifdef W3_IC0 - IF (ICE(ISEA).GT.0) THEN - IF (FICEL.GT.0.) THEN - TRIX(IXY) = EXP(-ICE(ISEA)*DX/FICEL) - TRIY(IXY) = EXP(-ICE(ISEA)*DY/FICEL) - ELSE + IF (ICE(ISEA).GT.0) THEN + IF (FICEL.GT.0.) THEN + TRIX(IXY) = EXP(-ICE(ISEA)*DX/FICEL) + TRIY(IXY) = EXP(-ICE(ISEA)*DY/FICEL) + ELSE #endif -! Otherwise: original Tolman expression (Tolman 2003) + ! Otherwise: original Tolman expression (Tolman 2003) #ifdef W3_IC0 - LICE0 = FICE0*DX - LICEN = FICEN*DX - TRIX(IXY) = ( LICEN - ICE(ISEA)*DX ) / ( LICEN - LICE0 ) + LICE0 = FICE0*DX + LICEN = FICEN*DX + TRIX(IXY) = ( LICEN - ICE(ISEA)*DX ) / ( LICEN - LICE0 ) #endif -! begin temporary notes -! TRIX = ( LICEN - ICE(ISEA)*DX ) / ( LICEN - LICE0 ) -! thus, it is TRIX= ( (FICEN*DX) - ICE(ISEA)*DX ) / ( (FICEN*DX) - (FICE0*DX) ) -! thus, it is TRIX= ( FICEN - ICE(ISEA) ) / ( FICEN - FICE0 ) -! in other words, the variables DX DY are not used -! and the variables LICE0 LICEN are not necessary. -! end temporary notes + ! begin temporary notes + ! TRIX = ( LICEN - ICE(ISEA)*DX ) / ( LICEN - LICE0 ) + ! thus, it is TRIX= ( (FICEN*DX) - ICE(ISEA)*DX ) / ( (FICEN*DX) - (FICE0*DX) ) + ! thus, it is TRIX= ( FICEN - ICE(ISEA) ) / ( FICEN - FICE0 ) + ! in other words, the variables DX DY are not used + ! and the variables LICE0 LICEN are not necessary. + ! end temporary notes #ifdef W3_IC0 - LICE0 = FICE0*DY - LICEN = FICEN*DY - TRIY(IXY) = ( LICEN - ICE(ISEA)*DY ) / ( LICEN - LICE0 ) - END IF + LICE0 = FICE0*DY + LICEN = FICEN*DY + TRIY(IXY) = ( LICEN - ICE(ISEA)*DY ) / ( LICEN - LICE0 ) + END IF #endif -! + ! #ifdef W3_IC0 - TRIX(IXY) = MAX ( 0. , MIN ( 1. , TRIX(IXY) ) ) - TRIY(IXY) = MAX ( 0. , MIN ( 1. , TRIY(IXY) ) ) - END IF -#endif -! -! Adding iceberg attenuation -! - IF (BERG(ISEA).GT.0) THEN - TRIX(IXY) = TRIX(IXY)*EXP(-BERG(ISEA)*FFACBERG *DX*0.0001) - TRIY(IXY) = TRIY(IXY)*EXP(-BERG(ISEA)*FFACBERG *DY*0.0001) - END IF -! + TRIX(IXY) = MAX ( 0. , MIN ( 1. , TRIX(IXY) ) ) + TRIY(IXY) = MAX ( 0. , MIN ( 1. , TRIY(IXY) ) ) + END IF +#endif + ! + ! Adding iceberg attenuation + ! + IF (BERG(ISEA).GT.0) THEN + TRIX(IXY) = TRIX(IXY)*EXP(-BERG(ISEA)*FFACBERG *DX*0.0001) + TRIY(IXY) = TRIY(IXY)*EXP(-BERG(ISEA)*FFACBERG *DY*0.0001) + END IF + ! #ifdef W3_T - ILEV = NINT(10.*MIN(TRIX(IXY),TRIY(IXY))) - LEVS(ILEV) = LEVS(ILEV) + 1. + ILEV = NINT(10.*MIN(TRIX(IXY),TRIY(IXY))) + LEVS(ILEV) = LEVS(ILEV) + 1. #endif -! - END DO -! + ! + END DO + ! #ifdef W3_T WRITE(NDST,9010) 'ICE' NLEV = 0 DO ILEV=0, 10 WRITE (NDST,9011) ILEV, LEVS(ILEV)/REAL(NSEA) NLEV = NLEV + NINT(LEVS(ILEV)) - END DO + END DO #endif -! -! 3.c Combine transparencies, ice always defined at cell center ! -! - DO ISEA=1, NSEA -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXY = MAPSF(ISEA,3) -! - IF ( IX .EQ. 1 ) THEN - IXN = IY + (NX-1)*NY - IXP = IY + IX *NY - ELSE IF ( IX .EQ. NX ) THEN - IXN = IY + (IX-2)*NY - IXP = IY - ELSE - IXN = IY + (IX-2)*NY - IXP = IY + IX *NY - END IF -! - IF ( IY .EQ. 1 ) THEN - IYN = IXY - IYP = IXY + 1 - ELSE IF ( IY .EQ. NY ) THEN - IYN = IXY - 1 - IYP = IXY - ELSE - IYN = IXY - 1 - IYP = IXY + 1 - END IF -! - ATRNX(IXY,-1) = ATRNX(IXY,-1) & - * (1.+TRIX(IXY)) * TRIX(IXN)/(1.+TRIX(IXN)) - ATRNX(IXY, 1) = ATRNX(IXY, 1) & - * (1.+TRIX(IXY)) * TRIX(IXP)/(1.+TRIX(IXP)) - ATRNY(IXY,-1) = ATRNY(IXY,-1) & - * (1.+TRIY(IXY)) * TRIY(IYN)/(1.+TRIY(IYN)) - ATRNY(IXY, 1) = ATRNY(IXY, 1) & - * (1.+TRIY(IXY)) * TRIY(IYP)/(1.+TRIY(IYP)) -! - END DO -! + ! + ! 3.c Combine transparencies, ice always defined at cell center ! + ! + DO ISEA=1, NSEA + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXY = MAPSF(ISEA,3) + ! + IF ( IX .EQ. 1 ) THEN + IXN = IY + (NX-1)*NY + IXP = IY + IX *NY + ELSE IF ( IX .EQ. NX ) THEN + IXN = IY + (IX-2)*NY + IXP = IY + ELSE + IXN = IY + (IX-2)*NY + IXP = IY + IX *NY END IF -! - RETURN -! -! Formats -! + ! + IF ( IY .EQ. 1 ) THEN + IYN = IXY + IYP = IXY + 1 + ELSE IF ( IY .EQ. NY ) THEN + IYN = IXY - 1 + IYP = IXY + ELSE + IYN = IXY - 1 + IYP = IXY + 1 + END IF + ! + ATRNX(IXY,-1) = ATRNX(IXY,-1) & + * (1.+TRIX(IXY)) * TRIX(IXN)/(1.+TRIX(IXN)) + ATRNX(IXY, 1) = ATRNX(IXY, 1) & + * (1.+TRIX(IXY)) * TRIX(IXP)/(1.+TRIX(IXP)) + ATRNY(IXY,-1) = ATRNY(IXY,-1) & + * (1.+TRIY(IXY)) * TRIY(IYN)/(1.+TRIY(IYN)) + ATRNY(IXY, 1) = ATRNY(IXY, 1) & + * (1.+TRIY(IXY)) * TRIY(IYP)/(1.+TRIY(IYP)) + ! + END DO + ! + END IF + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3UTRN : TRFLAG = ',I3) - 9001 FORMAT ( ' TEST W3UTRN : ',A) - 9010 FORMAT ( ' TEST W3UTRN : OBSTRICTION LEVELS FOR ',A,' :') - 9011 FORMAT ( ' ',I4,F8.5) -#endif -!/ -!/ End of W3UTRN ----------------------------------------------------- / -!/ - END SUBROUTINE W3UTRN -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DZXY( ZZ, ZUNIT, DZZDX, DZZDY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | W. E. Rogers, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 06-Dec-2010 | -!/ +-----------------------------------+ -!/ -!/ 30-Oct-2009 : Origination. ( version 3.14 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! Calculate derivatives of a field. -! -! 2. Method : -! -! Derivatives are calculated in m/m from the longitude/latitude -! grid, central in space for iternal points, one-sided for -! coastal points. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ZZ R.A. I Field to calculate derivatives of. -! ZUNIT R.A. I Units of ZZ (used for test output). -! DZZDX R.A. O Derivative in X-direction (W-E). -! DZZDY R.A. O Derivative in Y-direction (S-N). -! IXP: IX plus 1 (with branch cut incorporated) -! IYP, IXM, IYM: ditto -! IXPS: value to use for IXP if IXPS is not masked. -! (use IX if masked) -! IYPS, IXMS, IYMS : ditto -! IXTRPL : in case of needing IY+1 for IY=NY, IX needs to be -! modified (tripole grid only) -! IXTRPLS : value to use for IXTRPL if IXTRPLS is not masked -! (use IX if masked) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! This routine replaces the functionality of W3DDXY and W3DCXY. -! NB: subroutine "W3CGDM" has a similar purpose. -! Output arrays are always initialized to zero. -! -! 8. Structure : -! -! ---------------------------------------- -! 1. Preparations -! a Initialize arrays -! b Set constants -! 2. Derivatives in X-direction (W-E). -! 3. Derivatives in Y-direction (S-N). -! ---------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSTA, MAPFS, MAPFS, & - DPDX, DPDY, DQDX, DQDY, FLAGLL, ICLOSE, & - ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL - USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR, NAPROC - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT ( ' TEST W3UTRN : TRFLAG = ',I3) +9001 FORMAT ( ' TEST W3UTRN : ',A) +9010 FORMAT ( ' TEST W3UTRN : OBSTRICTION LEVELS FOR ',A,' :') +9011 FORMAT ( ' ',I4,F8.5) +#endif + !/ + !/ End of W3UTRN ----------------------------------------------------- / + !/ + END SUBROUTINE W3UTRN + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DZXY( ZZ, ZUNIT, DZZDX, DZZDY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | W. E. Rogers, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 06-Dec-2010 | + !/ +-----------------------------------+ + !/ + !/ 30-Oct-2009 : Origination. ( version 3.14 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ + ! 1. Purpose : + ! + ! Calculate derivatives of a field. + ! + ! 2. Method : + ! + ! Derivatives are calculated in m/m from the longitude/latitude + ! grid, central in space for iternal points, one-sided for + ! coastal points. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ZZ R.A. I Field to calculate derivatives of. + ! ZUNIT R.A. I Units of ZZ (used for test output). + ! DZZDX R.A. O Derivative in X-direction (W-E). + ! DZZDY R.A. O Derivative in Y-direction (S-N). + ! IXP: IX plus 1 (with branch cut incorporated) + ! IYP, IXM, IYM: ditto + ! IXPS: value to use for IXP if IXPS is not masked. + ! (use IX if masked) + ! IYPS, IXMS, IYMS : ditto + ! IXTRPL : in case of needing IY+1 for IY=NY, IX needs to be + ! modified (tripole grid only) + ! IXTRPLS : value to use for IXTRPL if IXTRPLS is not masked + ! (use IX if masked) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! This routine replaces the functionality of W3DDXY and W3DCXY. + ! NB: subroutine "W3CGDM" has a similar purpose. + ! Output arrays are always initialized to zero. + ! + ! 8. Structure : + ! + ! ---------------------------------------- + ! 1. Preparations + ! a Initialize arrays + ! b Set constants + ! 2. Derivatives in X-direction (W-E). + ! 3. Derivatives in Y-direction (S-N). + ! ---------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSTA, MAPFS, MAPFS, & + DPDX, DPDY, DQDX, DQDY, FLAGLL, ICLOSE, & + ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL + USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR, NAPROC + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_T - USE W3ARRYMD, ONLY : PRTBLK -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - REAL, INTENT(IN) :: ZZ(NSEA) - CHARACTER, INTENT(IN) :: ZUNIT*(*) - REAL, INTENT(OUT) :: DZZDX(NY,NX), DZZDY(NY,NX) - INTEGER :: ISEA, IX, IY, IXP, IXM, IYP, IYM + USE W3ARRYMD, ONLY : PRTBLK +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL, INTENT(IN) :: ZZ(NSEA) + CHARACTER, INTENT(IN) :: ZUNIT*(*) + REAL, INTENT(OUT) :: DZZDX(NY,NX), DZZDY(NY,NX) + INTEGER :: ISEA, IX, IY, IXP, IXM, IYP, IYM #ifdef W3_T - INTEGER :: ISX, ISY, MAPOUT(NX,NY) + INTEGER :: ISX, ISY, MAPOUT(NX,NY) #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T - INTEGER, SAVE :: NXS = 49 + INTEGER, SAVE :: NXS = 49 #endif - REAL :: DFAC , STX, STY - INTEGER :: IXPS,IYPS,IXMS,IYMS,IXTRPL,IXTRPLS - INTEGER :: IXSTART,IXEND + REAL :: DFAC , STX, STY + INTEGER :: IXPS,IYPS,IXMS,IYMS,IXTRPL,IXTRPLS + INTEGER :: IXSTART,IXEND #ifdef W3_T - REAL :: XOUT(NX,NY) + REAL :: XOUT(NX,NY) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3DZXY') + CALL STRACE (IENT, 'W3DZXY') #endif -! -! 1. Preparations --------------------------------------------------- * + ! + ! 1. Preparations --------------------------------------------------- * -! 1.a Initialize arrays -! - DZZDX = 0. - DZZDY = 0. -! -! 1.b Set constants -! + ! 1.a Initialize arrays + ! + DZZDX = 0. + DZZDY = 0. + ! + ! 1.b Set constants + ! - IF ( FLAGLL ) THEN - DFAC = 1. / ( DERA * RADIUS ) - ELSE - DFAC = 1. - END IF + IF ( FLAGLL ) THEN + DFAC = 1. / ( DERA * RADIUS ) + ELSE + DFAC = 1. + END IF -! -! 2. Derivatives in X-direction (W-E) and Y-direction (S-N) ----- * -! + ! + ! 2. Derivatives in X-direction (W-E) and Y-direction (S-N) ----- * + ! -! 2a. All points previously done in 2a,2b,2c of v4.18 done in 2a now: - IF ( ICLOSE.EQ.ICLOSE_NONE ) THEN - IXSTART=2 - IXEND=NX-1 - ELSE - IXSTART=1 - IXEND=NX - ENDIF + ! 2a. All points previously done in 2a,2b,2c of v4.18 done in 2a now: + IF ( ICLOSE.EQ.ICLOSE_NONE ) THEN + IXSTART=2 + IXEND=NX-1 + ELSE + IXSTART=1 + IXEND=NX + ENDIF - DO IY=2, NY-1 - DO IX=IXSTART,IXEND - IF ( MAPSTA(IY,IX) .NE. 0 ) THEN - STX = 0.5 - IF (IX.EQ.NX)THEN - IXPS=1 - ELSE - IXPS=IX+1 - ENDIF + DO IY=2, NY-1 + DO IX=IXSTART,IXEND + IF ( MAPSTA(IY,IX) .NE. 0 ) THEN + STX = 0.5 + IF (IX.EQ.NX)THEN + IXPS=1 + ELSE + IXPS=IX+1 + ENDIF - IF (MAPSTA(IY,IXPS).EQ.0) THEN - IXP = IX - STX = 1.0 - ELSE - IXP = IXPS - END IF + IF (MAPSTA(IY,IXPS).EQ.0) THEN + IXP = IX + STX = 1.0 + ELSE + IXP = IXPS + END IF - IF(IX.EQ.1)THEN - IXMS=NX - ELSE - IXMS=IX-1 - ENDIF + IF(IX.EQ.1)THEN + IXMS=NX + ELSE + IXMS=IX-1 + ENDIF - IF (MAPSTA(IY,IXMS).EQ.0) THEN - IXM = IX - STX = 1.0 - ELSE - IXM = IXMS - END IF - STY = 0.5 - IYPS=IY+1 - IF (MAPSTA(IYPS,IX).EQ.0) THEN - IYP = IY - STY = 1.0 - ELSE - IYP = IYPS - END IF - IYMS=IY-1 - IF (MAPSTA(IYMS,IX).EQ.0) THEN - IYM = IY - STY = 1.0 - ELSE - IYM = IYMS - END IF - DZZDX(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDX(IY,IX) & - + (ZZ(MAPFS(IYP,IX ))-ZZ(MAPFS(IYM,IX ))) * STY * DQDX(IY,IX) - DZZDY(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDY(IY,IX) & - + (ZZ(MAPFS(IYP,IX ))-ZZ(MAPFS(IYM,IX ))) * STY * DQDY(IY,IX) - DZZDX(IY,IX) = DZZDX(IY,IX) * DFAC - DZZDY(IY,IX) = DZZDY(IY,IX) * DFAC - END IF - END DO + IF (MAPSTA(IY,IXMS).EQ.0) THEN + IXM = IX + STX = 1.0 + ELSE + IXM = IXMS + END IF + STY = 0.5 + IYPS=IY+1 + IF (MAPSTA(IYPS,IX).EQ.0) THEN + IYP = IY + STY = 1.0 + ELSE + IYP = IYPS + END IF + IYMS=IY-1 + IF (MAPSTA(IYMS,IX).EQ.0) THEN + IYM = IY + STY = 1.0 + ELSE + IYM = IYMS + END IF + DZZDX(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDX(IY,IX) & + + (ZZ(MAPFS(IYP,IX ))-ZZ(MAPFS(IYM,IX ))) * STY * DQDX(IY,IX) + DZZDY(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDY(IY,IX) & + + (ZZ(MAPFS(IYP,IX ))-ZZ(MAPFS(IYM,IX ))) * STY * DQDY(IY,IX) + DZZDX(IY,IX) = DZZDX(IY,IX) * DFAC + DZZDY(IY,IX) = DZZDY(IY,IX) * DFAC + END IF END DO + END DO -! 2b. column IY=NY for tripole case -! This is more complex, since for these two points: (IYP,IX) (IYM,IX), -! not only is the first index different (IYP.NE.IYM), but also the -! second index is different (IX.NE.IX)! - IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN + ! 2b. column IY=NY for tripole case + ! This is more complex, since for these two points: (IYP,IX) (IYM,IX), + ! not only is the first index different (IYP.NE.IYM), but also the + ! second index is different (IX.NE.IX)! + IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN - IY=NY - DO IX=1, NX - IF ( MAPSTA(IY,IX) .NE. 0 ) THEN + IY=NY + DO IX=1, NX + IF ( MAPSTA(IY,IX) .NE. 0 ) THEN - STX = 0.5 - - IF (IX.EQ.NX)THEN - IXPS=1 - ELSE - IXPS=IX+1 - ENDIF - IF (MAPSTA(IY,IXPS).EQ.0) THEN - IXP = IX - STX = 1.0 - ELSE - IXP = IXPS - END IF - - IF(IX.EQ.1)THEN - IXMS=NX - ELSE - IXMS=IX-1 - ENDIF - IF (MAPSTA(IY,IXMS).EQ.0) THEN - IXM = IX - STX = 1.0 - ELSE - IXM = IXMS - END IF + STX = 0.5 - STY = 0.5 + IF (IX.EQ.NX)THEN + IXPS=1 + ELSE + IXPS=IX+1 + ENDIF + IF (MAPSTA(IY,IXPS).EQ.0) THEN + IXP = IX + STX = 1.0 + ELSE + IXP = IXPS + END IF -!..............next point: j+1: tripole: j==>j+1==>j and i==>ni-i+1 -!..............i.e. target point is MAPFS(IY,(NX-IX+1)) - IXTRPLS=NX-IX+1 - IF (MAPSTA(IY,IXTRPLS).EQ.0) THEN - IXTRPL = IX - STY = 1.0 - ELSE - IXTRPL=IXTRPLS - END IF + IF(IX.EQ.1)THEN + IXMS=NX + ELSE + IXMS=IX-1 + ENDIF + IF (MAPSTA(IY,IXMS).EQ.0) THEN + IXM = IX + STX = 1.0 + ELSE + IXM = IXMS + END IF - IYMS=IY-1 - IF (MAPSTA(IYMS,IX).EQ.0) THEN - IYM = IY - STY = 1.0 - ELSE - IYM = IYMS - END IF + STY = 0.5 -! tripole grid: (IYP,IX) is replaced with (IY,IXTRPL) - DZZDX(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDX(IY,IX) & - + (ZZ(MAPFS(IY,IXTRPL))-ZZ(MAPFS(IYM,IX ))) * STY * DQDX(IY,IX) - DZZDY(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDY(IY,IX) & - + (ZZ(MAPFS(IY,IXTRPL))-ZZ(MAPFS(IYM,IX ))) * STY * DQDY(IY,IX) - DZZDX(IY,IX) = DZZDX(IY,IX) * DFAC - DZZDY(IY,IX) = DZZDY(IY,IX) * DFAC - END IF - END DO + !..............next point: j+1: tripole: j==>j+1==>j and i==>ni-i+1 + !..............i.e. target point is MAPFS(IY,(NX-IX+1)) + IXTRPLS=NX-IX+1 + IF (MAPSTA(IY,IXTRPLS).EQ.0) THEN + IXTRPL = IX + STY = 1.0 + ELSE + IXTRPL=IXTRPLS + END IF - END IF ! IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN + IYMS=IY-1 + IF (MAPSTA(IYMS,IX).EQ.0) THEN + IYM = IY + STY = 1.0 + ELSE + IYM = IYMS + END IF + + ! tripole grid: (IYP,IX) is replaced with (IY,IXTRPL) + DZZDX(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDX(IY,IX) & + + (ZZ(MAPFS(IY,IXTRPL))-ZZ(MAPFS(IYM,IX ))) * STY * DQDX(IY,IX) + DZZDY(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDY(IY,IX) & + + (ZZ(MAPFS(IY,IXTRPL))-ZZ(MAPFS(IYM,IX ))) * STY * DQDY(IY,IX) + DZZDX(IY,IX) = DZZDX(IY,IX) * DFAC + DZZDY(IY,IX) = DZZDY(IY,IX) * DFAC + END IF + END DO + + END IF ! IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN -! -! 3. Test output of fields ------------------------------------------ * -! + ! + ! 3. Test output of fields ------------------------------------------ * + ! #ifdef W3_T - WRITE (NDST,9010) - ISX = 1 + NX/NXS - ISY = 1 + NY/NXS - DO IY=1, NY - DO IX=1, NX - MAPOUT(IX,IY) = MAPSTA(IY,IX) - IF ( MAPFS(IY,IX) .NE. 0 ) & - XOUT(IX,IY) = ZZ(MAPFS(IY,IX)) - END DO - END DO - CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & - 1, NX, ISX, 1, NY, ISY, 'ZZ', ZUNIT) - DO IY=1, NY - DO IX=1, NX - XOUT(IX,IY) = DZZDX(IY,IX) - END DO - END DO - CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & - 1, NX, ISX, 1, NY, ISY, 'DZZDX',TRIM(ZUNIT)//'/m') - DO IY=1, NY - DO IX=1, NX - XOUT(IX,IY) = DZZDY(IY,IX) - END DO - END DO - CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & - 1, NX, ISX, 1, NY, ISY, 'DZZDY',TRIM(ZUNIT)//'/m') -#endif -! - RETURN -! -! Formats -! + WRITE (NDST,9010) + ISX = 1 + NX/NXS + ISY = 1 + NY/NXS + DO IY=1, NY + DO IX=1, NX + MAPOUT(IX,IY) = MAPSTA(IY,IX) + IF ( MAPFS(IY,IX) .NE. 0 ) & + XOUT(IX,IY) = ZZ(MAPFS(IY,IX)) + END DO + END DO + CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & + 1, NX, ISX, 1, NY, ISY, 'ZZ', ZUNIT) + DO IY=1, NY + DO IX=1, NX + XOUT(IX,IY) = DZZDX(IY,IX) + END DO + END DO + CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & + 1, NX, ISX, 1, NY, ISY, 'DZZDX',TRIM(ZUNIT)//'/m') + DO IY=1, NY + DO IX=1, NX + XOUT(IX,IY) = DZZDY(IY,IX) + END DO + END DO + CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & + 1, NX, ISX, 1, NY, ISY, 'DZZDY',TRIM(ZUNIT)//'/m') +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT (' TEST W3DZXY : DX0I, DY0I : ',2E12.5) - 9010 FORMAT (' TEST W3DZXY : FIELDS ') -#endif -!/ -!/ End of W3DZXY ----------------------------------------------------- / -!/ - END SUBROUTINE W3DZXY -!/ ------------------------------------------------------------------- / -!/ End of module W3UPDTMD -------------------------------------------- / -!/ - END MODULE W3UPDTMD +9000 FORMAT (' TEST W3DZXY : DX0I, DY0I : ',2E12.5) +9010 FORMAT (' TEST W3DZXY : FIELDS ') +#endif + !/ + !/ End of W3DZXY ----------------------------------------------------- / + !/ + END SUBROUTINE W3DZXY + !/ ------------------------------------------------------------------- / + !/ End of module W3UPDTMD -------------------------------------------- / + !/ +END MODULE W3UPDTMD diff --git a/model/src/w3uqckmd.F90 b/model/src/w3uqckmd.F90 index 4f5121d75..edcf0e0de 100644 --- a/model/src/w3uqckmd.F90 +++ b/model/src/w3uqckmd.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains MODULE W3UQCKMD. -!> +!> !> @author H. L. Tolman @date 27-May-2014 !> @@ -11,1321 +11,1321 @@ !> !> @author H. L. Tolman @date 27-May-2014 !> - MODULE W3UQCKMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2014 | -!/ +-----------------------------------+ -!/ -!/ 08-Feb-2001 : Origination of module. Routines ( version 2.08 ) -!/ taken out of w3pro2md.ftn -!/ 13-Nov-2001 : Version with obstacles added. ( version 2.14 ) -!/ 16-Oct-2002 : Fix par list W3QCK3. ( version 3.00 ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives. -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Fixed a couple of doc lines. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 27-May-2014 : Added OMPH switches in W3QCK3. ( version 5.02 ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Portable ULTIMATE QUICKEST schemes. -! -! 2. Variables and types : -! -! None. -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3QCK1 Subr. Public Original ULTIMATE QUICKEST scheme. -! W3QCK2 Subr. Public UQ scheme for irregular grid. -! W3QCK3 Subr. Public Original ULTIMATE QUICKEST with obst. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - STRACE and !/S irrelevant for running code. The module is -! therefore fully portable to any other model. -! -! 6. Switches : -! -! !/OMPH Ading OMP directves for hybrid paralellization. -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / +MODULE W3UQCKMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2014 | + !/ +-----------------------------------+ + !/ + !/ 08-Feb-2001 : Origination of module. Routines ( version 2.08 ) + !/ taken out of w3pro2md.ftn + !/ 13-Nov-2001 : Version with obstacles added. ( version 2.14 ) + !/ 16-Oct-2002 : Fix par list W3QCK3. ( version 3.00 ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives. + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Fixed a couple of doc lines. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 27-May-2014 : Added OMPH switches in W3QCK3. ( version 5.02 ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Portable ULTIMATE QUICKEST schemes. + ! + ! 2. Variables and types : + ! + ! None. + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3QCK1 Subr. Public Original ULTIMATE QUICKEST scheme. + ! W3QCK2 Subr. Public UQ scheme for irregular grid. + ! W3QCK3 Subr. Public Original ULTIMATE QUICKEST with obst. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - STRACE and !/S irrelevant for running code. The module is + ! therefore fully portable to any other model. + ! + ! 6. Switches : + ! + ! !/OMPH Ading OMP directves for hybrid paralellization. + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Preform one-dimensional propagation in a two-dimensional space -!> with irregular boundaries and regular grid. -!> -!> @details ULTIMATE QUICKEST scheme (see manual). -!> -!> Note that the check on monotonous behavior of QCN is performed -!> using weights CFAC, to avoid the need for IF statements. -!> -!> Called by: W3KTP2 Propagation in spectral space. -!> -!> This routine can be used independently from WAVEWATCH III. -!> -!> -!> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. -!> @param[in] MY Field dimension (See MX) -!> @param[in] NX Part of field actually used -!> @param[in] NY Part of field actually used -!> @param[in] INC Increment in 1-D array corresponding to increment in 2-D space. -!> @param[in] MAPACT List of active grid points. -!> @param[in] NACT Size of MAPACT. -!> @param[in] MAPBOU Map with boundary information (See W3MAP2). -!> @param[in] NB0 Counter in MAPBOU -!> @param[in] NB1 Counter in MAPBOU -!> @param[in] NB2 Counter in MAPBOU -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> @param[inout] CFLL Local Courant numbers (MY, MX+1) -!> @param[inout] Q Propagated quantity (MY,0:MX+2) -!> @param[in] CLOSE Flag for closed 'X' dimension. -!> -!> @author H. L. Tolman @date 30-Oct-2009 -!> - SUBROUTINE W3QCK1 (MX, MY, NX, NY, CFLL, Q, CLOSE, INC, & - MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & - NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ 11-Mar-1997 : Final FORTRAN 77 ( version 1.18 ) -!/ 15-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 15-Feb-2001 : Unit numbers added to par list. ( version 2.08 ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives. -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 30-Oct-2009 : Fixed "Called by" doc line. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! Preform one-dimensional propagation in a two-dimensional space -! with irregular boundaries and regular grid. -! -! 2. Method : -! -! ULTIMATE QUICKEST scheme (see manual). -! -! Note that the check on monotonous behavior of QCN is performed -! using weights CFAC, to avoid the need for IF statements. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MX,MY Int. I Field dimensions, if grid is 'closed' or -! circular, MX is the closed dimension. -! NX,NY Int. I Part of field actually used. -! CFLL R.A. I Local Courant numbers. (MY, MX+1) -! Q R.A. I/O Propagated quantity. (MY,0:MX+2) -! CLOSE Log. I Flag for closed 'X' dimension' -! INC Int. I Increment in 1-D array corresponding to -! increment in 2-D space. -! MAPACT I.A. I List of active grid points. -! NACT Int. I Size of MAPACT. -! MAPBOU I.A. I Map with boundary information (see W3MAP2). -! NBn Int. I Counters in MAPBOU. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! - CFLL amd Q need only bee filled in the (MY,MX) range, -! extension is used internally for closure. -! - CFLL and Q are defined as 1-D arrays internally. -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3KTP2 Propagation in spectral space -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - This routine can be used independently from WAVEWATCH III. -! -! 8. Structure : -! -! ------------------------------------------------------ -! 1. Initialize aux. array FLA. -! 2. Fluxes for central points (3rd order + limiter). -! 3. Fluxes boundary point above (1st order). -! 4. Fluxes boundary point below (1st order). -! 5. Closure of 'X' if required -! 6. Propagate. -! ------------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T0 Test output input/output fields. -! !/T1 Test output fluxes. -! !/T2 Test output integration. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & - NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & - NDSE, NDST - REAL, INTENT(INOUT) :: CFLL(MY*(MX+1)), Q(1-MY:MY*(MX+2)) - LOGICAL, INTENT(IN) :: CLOSE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & - IAD00, IAD02, IADN0, IADN1, IADN2 + USE W3SERVMD, ONLY: STRACE +#endif + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Preform one-dimensional propagation in a two-dimensional space + !> with irregular boundaries and regular grid. + !> + !> @details ULTIMATE QUICKEST scheme (see manual). + !> + !> Note that the check on monotonous behavior of QCN is performed + !> using weights CFAC, to avoid the need for IF statements. + !> + !> Called by: W3KTP2 Propagation in spectral space. + !> + !> This routine can be used independently from WAVEWATCH III. + !> + !> + !> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. + !> @param[in] MY Field dimension (See MX) + !> @param[in] NX Part of field actually used + !> @param[in] NY Part of field actually used + !> @param[in] INC Increment in 1-D array corresponding to increment in 2-D space. + !> @param[in] MAPACT List of active grid points. + !> @param[in] NACT Size of MAPACT. + !> @param[in] MAPBOU Map with boundary information (See W3MAP2). + !> @param[in] NB0 Counter in MAPBOU + !> @param[in] NB1 Counter in MAPBOU + !> @param[in] NB2 Counter in MAPBOU + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> @param[inout] CFLL Local Courant numbers (MY, MX+1) + !> @param[inout] Q Propagated quantity (MY,0:MX+2) + !> @param[in] CLOSE Flag for closed 'X' dimension. + !> + !> @author H. L. Tolman @date 30-Oct-2009 + !> + SUBROUTINE W3QCK1 (MX, MY, NX, NY, CFLL, Q, CLOSE, INC, & + MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & + NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ + !/ 11-Mar-1997 : Final FORTRAN 77 ( version 1.18 ) + !/ 15-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 15-Feb-2001 : Unit numbers added to par list. ( version 2.08 ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives. + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 30-Oct-2009 : Fixed "Called by" doc line. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ + ! 1. Purpose : + ! + ! Preform one-dimensional propagation in a two-dimensional space + ! with irregular boundaries and regular grid. + ! + ! 2. Method : + ! + ! ULTIMATE QUICKEST scheme (see manual). + ! + ! Note that the check on monotonous behavior of QCN is performed + ! using weights CFAC, to avoid the need for IF statements. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MX,MY Int. I Field dimensions, if grid is 'closed' or + ! circular, MX is the closed dimension. + ! NX,NY Int. I Part of field actually used. + ! CFLL R.A. I Local Courant numbers. (MY, MX+1) + ! Q R.A. I/O Propagated quantity. (MY,0:MX+2) + ! CLOSE Log. I Flag for closed 'X' dimension' + ! INC Int. I Increment in 1-D array corresponding to + ! increment in 2-D space. + ! MAPACT I.A. I List of active grid points. + ! NACT Int. I Size of MAPACT. + ! MAPBOU I.A. I Map with boundary information (see W3MAP2). + ! NBn Int. I Counters in MAPBOU. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! - CFLL amd Q need only bee filled in the (MY,MX) range, + ! extension is used internally for closure. + ! - CFLL and Q are defined as 1-D arrays internally. + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3KTP2 Propagation in spectral space + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - This routine can be used independently from WAVEWATCH III. + ! + ! 8. Structure : + ! + ! ------------------------------------------------------ + ! 1. Initialize aux. array FLA. + ! 2. Fluxes for central points (3rd order + limiter). + ! 3. Fluxes boundary point above (1st order). + ! 4. Fluxes boundary point below (1st order). + ! 5. Closure of 'X' if required + ! 6. Propagate. + ! ------------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T0 Test output input/output fields. + ! !/T1 Test output fluxes. + ! !/T2 Test output integration. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & + NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & + NDSE, NDST + REAL, INTENT(INOUT) :: CFLL(MY*(MX+1)), Q(1-MY:MY*(MX+2)) + LOGICAL, INTENT(IN) :: CLOSE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & + IAD00, IAD02, IADN0, IADN1, IADN2 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T1 - INTEGER :: IX2, IY2 + INTEGER :: IX2, IY2 #endif - REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC - REAL :: FLA(1-MY:MY*MX) + REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC + REAL :: FLA(1-MY:MY*MX) #ifdef W3_T0 - REAL :: QMAX + REAL :: QMAX #endif #ifdef W3_T1 - REAL :: QBO, QN + REAL :: QBO, QN #endif #ifdef W3_T2 - REAL :: QOLD + REAL :: QOLD #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3QCK1') + CALL STRACE (IENT, 'W3QCK1') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) MX, MY, NX, NY, CLOSE, INC, NB0, NB1, NB2 + WRITE (NDST,9000) MX, MY, NX, NY, CLOSE, INC, NB0, NB1, NB2 #endif -! + ! #ifdef W3_T0 - QMAX = 0. - DO IY=1, NY - DO IX=1, NX - QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) - END DO - END DO - QMAX = MAX ( 0.01*QMAX , 1.E-10 ) -#endif -! + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) +#endif + ! #ifdef W3_T0 - WRITE (NDST,9001) 'CFLL' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) - END DO - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO - WRITE (NDST,9001) 'MAPACT' - WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) -#endif -! -! 1. Initialize aux. array FLA and closure ------------------------- * -! - FLA = 0. -! - IF ( CLOSE ) THEN + WRITE (NDST,9001) 'CFLL' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif + ! + ! 1. Initialize aux. array FLA and closure ------------------------- * + ! + FLA = 0. + ! + IF ( CLOSE ) THEN #ifdef W3_T - WRITE (NDST,9005) -#endif - IAD00 = -MY - IAD02 = MY - IADN0 = IAD00 + MY*NX - IADN1 = MY*NX - IADN2 = IAD02 + MY*NX - DO IY=1, NY - Q (IY+IAD00) = Q (IY+IADN0) - Q (IY+IADN1) = Q ( IY ) - Q (IY+IADN2) = Q (IY+IAD02) - CFLL(IY+IADN1) = CFLL( IY ) - END DO - END IF -! -! 2. Fluxes for central points ------------------------------------- * -! ( 3rd order + limiter ) -! + WRITE (NDST,9005) +#endif + IAD00 = -MY + IAD02 = MY + IADN0 = IAD00 + MY*NX + IADN1 = MY*NX + IADN2 = IAD02 + MY*NX + DO IY=1, NY + Q (IY+IAD00) = Q (IY+IADN0) + Q (IY+IADN1) = Q ( IY ) + Q (IY+IADN2) = Q (IY+IAD02) + CFLL(IY+IADN1) = CFLL( IY ) + END DO + END IF + ! + ! 2. Fluxes for central points ------------------------------------- * + ! ( 3rd order + limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9010) - WRITE (NDST,9011) NB0, 'CENTRAL' -#endif -! - DO IP=1, NB0 -! - IXY = MAPBOU(IP) - CFL = 0.5 * ( CFLL(IXY) + CFLL(IXY+INC) ) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - QB = 0.5 * ( (1.-CFL)*Q(IXY+INC) + (1.+CFL)*Q(IXY) ) & - - (1.-CFL**2)/6. * (Q(IXYC-INC)-2.*Q(IXYC)+Q(IXYC+INC)) -! - IXYU = IXYC - INC * INT ( SIGN (1.1,CFL) ) - IXYD = 2*IXYC - IXYU - DQ = Q(IXYD) - Q(IXYU) - DQNZ = SIGN ( MAX(1.E-15,ABS(DQ)) , DQ ) - QCN = ( Q(IXYC) - Q(IXYU) ) / DQNZ - QCN = MIN ( 1.1, MAX ( -0.1 , QCN ) ) -! + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' +#endif + ! + DO IP=1, NB0 + ! + IXY = MAPBOU(IP) + CFL = 0.5 * ( CFLL(IXY) + CFLL(IXY+INC) ) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + QB = 0.5 * ( (1.-CFL)*Q(IXY+INC) + (1.+CFL)*Q(IXY) ) & + - (1.-CFL**2)/6. * (Q(IXYC-INC)-2.*Q(IXYC)+Q(IXYC+INC)) + ! + IXYU = IXYC - INC * INT ( SIGN (1.1,CFL) ) + IXYD = 2*IXYC - IXYU + DQ = Q(IXYD) - Q(IXYU) + DQNZ = SIGN ( MAX(1.E-15,ABS(DQ)) , DQ ) + QCN = ( Q(IXYC) - Q(IXYU) ) / DQNZ + QCN = MIN ( 1.1, MAX ( -0.1 , QCN ) ) + ! #ifdef W3_T1 - QBO = QB -#endif - QBN = MAX ( (QB-Q(IXYU))/DQNZ , QCN ) - QBN = MIN ( QBN , 1. , QCN/MAX(1.E-10,ABS(CFL)) ) - QBR = Q(IXYU) + QBN*DQ - CFAC = REAL ( INT( 2. * ABS(QCN-0.5) ) ) - QB = (1.-CFAC)*QBR + CFAC*Q(IXYC) -! - FLA(IXY) = CFL * QB -! + QBO = QB +#endif + QBN = MAX ( (QB-Q(IXYU))/DQNZ , QCN ) + QBN = MIN ( QBN , 1. , QCN/MAX(1.E-10,ABS(CFL)) ) + QBR = Q(IXYU) + QBN*DQ + CFAC = REAL ( INT( 2. * ABS(QCN-0.5) ) ) + QB = (1.-CFAC)*QBR + CFAC*Q(IXYC) + ! + FLA(IXY) = CFL * QB + ! #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & - Q(IXY+INC), Q(IXY+2*INC) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & - CFL, CFLL(IXY), CFLL(IXY+INC), & - QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & - Q(IXY+INC)*QN, Q(IXY+2*INC)*QN - END IF -#endif -! - END DO -! -! 3. Fluxes for points with boundary above ------------------------- * -! ( 1st order without limiter ) -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, CFLL(IXY), CFLL(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif + ! + END DO + ! + ! 3. Fluxes for points with boundary above ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' -#endif -! - DO IP=NB0+1, NB1 - IXY = MAPBOU(IP) - CFL = CFLL(IXY) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - FLA(IXY) = CFL * Q(IXYC) + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif + ! + DO IP=NB0+1, NB1 + IXY = MAPBOU(IP) + CFL = CFLL(IXY) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + FLA(IXY) = CFL * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & - CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF -#endif - END DO -! -! 4. Fluxes for points with boundary below ------------------------- * -! ( 1st order without limiter ) -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif + END DO + ! + ! 4. Fluxes for points with boundary below ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' -#endif -! - DO IP=NB1+1, NB2 - IXY = MAPBOU(IP) - CFL = CFLL(IXY+INC) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - FLA(IXY) = CFL * Q(IXYC) + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif + ! + DO IP=NB1+1, NB2 + IXY = MAPBOU(IP) + CFL = CFLL(IXY+INC) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + FLA(IXY) = CFL * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, & - CFLL(IXY+INC), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF -#endif - END DO -! -! 5. Global closure ----------------------------------------------- * -! - IF ( CLOSE ) THEN + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY+INC), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif + END DO + ! + ! 5. Global closure ----------------------------------------------- * + ! + IF ( CLOSE ) THEN #ifdef W3_T - WRITE (NDST,9015) -#endif - DO IY=1, NY - FLA (IY+IAD00) = FLA (IY+IADN0) - END DO - END IF -! -! 6. Propagation -------------------------------------------------- * -! + WRITE (NDST,9015) +#endif + DO IY=1, NY + FLA (IY+IAD00) = FLA (IY+IADN0) + END DO + END IF + ! + ! 6. Propagation -------------------------------------------------- * + ! #ifdef W3_T2 - WRITE (NDST,9020) + WRITE (NDST,9020) #endif - DO IP=1, NACT - IXY = MAPACT(IP) + DO IP=1, NACT + IXY = MAPACT(IP) #ifdef W3_T2 - QOLD = Q(IXY) + QOLD = Q(IXY) #endif - Q(IXY) = MAX ( 0. , Q(IXY) + FLA(IXY-INC) - FLA(IXY) ) + Q(IXY) = MAX ( 0. , Q(IXY) + FLA(IXY-INC) - FLA(IXY) ) #ifdef W3_T2 - IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & - WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & - FLA(IXY-INC), FLA(IXY) + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + FLA(IXY-INC), FLA(IXY) #endif - END DO -! + END DO + ! #ifdef W3_T0 - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO -#endif -! - RETURN -! -! Formats -! + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3QCK1 : ARRAY DIMENSIONS :',2I6/ & - ' USED :',2I6/ & - ' CLOSE, INC :',L6,I6/ & - ' NB0, NB1, NB2 :',3I6) +9000 FORMAT ( ' TEST W3QCK1 : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' CLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) #endif #ifdef W3_T0 - 9001 FORMAT ( ' TEST W3QCK1 : DUMP ARRAY ',A,' :') - 9002 FORMAT ( 1X,43I3) - 9003 FORMAT ( 1X,21I6) +9001 FORMAT ( ' TEST W3QCK1 : DUMP ARRAY ',A,' :') +9002 FORMAT ( 1X,43I3) +9003 FORMAT ( 1X,21I6) #endif #ifdef W3_T - 9005 FORMAT (' TEST W3QCK1 : GLOBAL CLOSURE (1)') +9005 FORMAT (' TEST W3QCK1 : GLOBAL CLOSURE (1)') #endif -! + ! #ifdef W3_T1 - 9010 FORMAT (' TEST W3QCK1 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & - ' Q (b,b,i-1,i,i+1,i+2)') - 9011 FORMAT (' TEST W3QCK1 :',I6,' POINTS OF TYPE ',A) - 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) - 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') - 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') +9010 FORMAT (' TEST W3QCK1 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') +9011 FORMAT (' TEST W3QCK1 :',I6,' POINTS OF TYPE ',A) +9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) +9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') #endif #ifdef W3_T - 9015 FORMAT (' TEST W3QCK1 : GLOBAL CLOSURE (2)') +9015 FORMAT (' TEST W3QCK1 : GLOBAL CLOSURE (2)') #endif -! + ! #ifdef W3_T2 - 9020 FORMAT (' TEST W3QCK1 : IP, IXY, 2Q, 2FL') - 9021 FORMAT (' ',2I6,2(1X,2E11.3)) -#endif -!/ -!/ End of W3QCK1 ----------------------------------------------------- / -!/ - END SUBROUTINE W3QCK1 -!/ ------------------------------------------------------------------- / -!> -!> @brief Like W3QCK1 with variable grid spacing. -!> -!> @details VELO amd Q need only bee filled in the (MY,MX) range, -!> extension is used internally for closure. -!> VELO and Q are defined as 1-D arrays internally. -!> -!> Called by: W3KTP2 Propagation in spectral space. -!> -!> This routine can be used independently from WAVEWATCH III. -!> -!> -!> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. -!> @param[in] MY Field dimension (See MX). -!> @param[in] NX Part of field actually used. -!> @param[in] NY Part of field actually used. -!> @param[in] MAPACT List of active grid points. -!> @param[in] NACT Size of MAPACT. -!> @param[in] MAPBOU Map with boundary information (See W3MAP2). -!> @param[in] NB0 Counter in MAPBOU. -!> @param[in] NB1 Counter in MAPBOU. -!> @param[in] NB2 Counter in MAPBOU. -!> @param[inout] VELO Local velocities (MY, MX+1). -!> @param[in] DT Time step. -!> @param[inout] DX1 Band width at points (MY, MX+1). -!> @param[inout] DX2 Band width between points (MY,0:MX+1) -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> @param[inout] Q Propagated quantity (MY,0:MX+2). -!> @param[in] CLOSE Flag for closed 'X' dimension. -!> @param[in] INC Increment in 1-D array corresponding to -!> increment in 2-D space. -!> -!> @author H. L. Tolman @date 30-Oct-2009 -!> - SUBROUTINE W3QCK2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q, CLOSE,& - INC, MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & - NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ 07-Sep-1997 : Final FORTRAN 77 ( version 1.18 ) -!/ 16-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 14-Feb-2001 : Unit numbers added to par list. ( version 2.08 ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives. -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 30-Oct-2009 : Fixed "Called by" doc line. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! Like W3QCK1 with variable grid spacing. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MX,MY Int. I Field dimensions, if grid is 'closed' or -! circular, MX is the closed dimension. -! NX,NY Int. I Part of field actually used. -! VELO R.A. I Local velocities. (MY, MX+1) -! DT Real I Time step. -! DX1 R.A. I/O Band width at points. (MY, MX+1) -! DX2 R.A. I/O Band width between points. (MY,0:MX+1) -! (local counter and counter+INC) -! Q R.A. I/O Propagated quantity. (MY,0:MX+2) -! CLOSE Log. I Flag for closed 'X' dimension' -! INC Int. I Increment in 1-D array corresponding to -! increment in 2-D space. -! MAPACT I.A. I List of active grid points. -! NACT Int. I Size of MAPACT. -! MAPBOU I.A. I Map with boundary information (see W3MAP2). -! NBn Int. I Counters in MAPBOU. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! - VELO amd Q need only bee filled in the (MY,MX) range, -! extension is used internally for closure. -! - VELO and Q are defined as 1-D arrays internally. -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3KTP2 Propagation in spectral space -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - This routine can be used independently from WAVEWATCH III. -! -! 8. Structure : -! -! ------------------------------------------------------ -! 1. Initialize aux. array FLA. -! 2. Fluxes for central points (3rd order + limiter). -! 3. Fluxes boundary point above (1st order). -! 4. Fluxes boundary point below (1st order). -! 5. Closure of 'X' if required -! 6. Propagate. -! ------------------------------------------------------ -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T0 Test output input/output fields. -! !/T1 Test output fluxes. -! !/T2 Test output integration. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & - NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & - NDSE, NDST - REAL, INTENT(IN) :: DT - REAL, INTENT(INOUT) :: VELO(MY*(MX+1)), DX1(MY*(MX+1)), & - DX2(1-MY:MY*(MX+1)), Q(1-MY:MY*(MX+2)) - LOGICAL, INTENT(IN) :: CLOSE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & - IAD00, IAD02, IADN0, IADN1, IADN2 +9020 FORMAT (' TEST W3QCK1 : IP, IXY, 2Q, 2FL') +9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif + !/ + !/ End of W3QCK1 ----------------------------------------------------- / + !/ + END SUBROUTINE W3QCK1 + !/ ------------------------------------------------------------------- / + !> + !> @brief Like W3QCK1 with variable grid spacing. + !> + !> @details VELO amd Q need only bee filled in the (MY,MX) range, + !> extension is used internally for closure. + !> VELO and Q are defined as 1-D arrays internally. + !> + !> Called by: W3KTP2 Propagation in spectral space. + !> + !> This routine can be used independently from WAVEWATCH III. + !> + !> + !> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. + !> @param[in] MY Field dimension (See MX). + !> @param[in] NX Part of field actually used. + !> @param[in] NY Part of field actually used. + !> @param[in] MAPACT List of active grid points. + !> @param[in] NACT Size of MAPACT. + !> @param[in] MAPBOU Map with boundary information (See W3MAP2). + !> @param[in] NB0 Counter in MAPBOU. + !> @param[in] NB1 Counter in MAPBOU. + !> @param[in] NB2 Counter in MAPBOU. + !> @param[inout] VELO Local velocities (MY, MX+1). + !> @param[in] DT Time step. + !> @param[inout] DX1 Band width at points (MY, MX+1). + !> @param[inout] DX2 Band width between points (MY,0:MX+1) + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> @param[inout] Q Propagated quantity (MY,0:MX+2). + !> @param[in] CLOSE Flag for closed 'X' dimension. + !> @param[in] INC Increment in 1-D array corresponding to + !> increment in 2-D space. + !> + !> @author H. L. Tolman @date 30-Oct-2009 + !> + SUBROUTINE W3QCK2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q, CLOSE,& + INC, MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & + NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ + !/ 07-Sep-1997 : Final FORTRAN 77 ( version 1.18 ) + !/ 16-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 14-Feb-2001 : Unit numbers added to par list. ( version 2.08 ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives. + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 30-Oct-2009 : Fixed "Called by" doc line. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ + ! 1. Purpose : + ! + ! Like W3QCK1 with variable grid spacing. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MX,MY Int. I Field dimensions, if grid is 'closed' or + ! circular, MX is the closed dimension. + ! NX,NY Int. I Part of field actually used. + ! VELO R.A. I Local velocities. (MY, MX+1) + ! DT Real I Time step. + ! DX1 R.A. I/O Band width at points. (MY, MX+1) + ! DX2 R.A. I/O Band width between points. (MY,0:MX+1) + ! (local counter and counter+INC) + ! Q R.A. I/O Propagated quantity. (MY,0:MX+2) + ! CLOSE Log. I Flag for closed 'X' dimension' + ! INC Int. I Increment in 1-D array corresponding to + ! increment in 2-D space. + ! MAPACT I.A. I List of active grid points. + ! NACT Int. I Size of MAPACT. + ! MAPBOU I.A. I Map with boundary information (see W3MAP2). + ! NBn Int. I Counters in MAPBOU. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! - VELO amd Q need only bee filled in the (MY,MX) range, + ! extension is used internally for closure. + ! - VELO and Q are defined as 1-D arrays internally. + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3KTP2 Propagation in spectral space + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - This routine can be used independently from WAVEWATCH III. + ! + ! 8. Structure : + ! + ! ------------------------------------------------------ + ! 1. Initialize aux. array FLA. + ! 2. Fluxes for central points (3rd order + limiter). + ! 3. Fluxes boundary point above (1st order). + ! 4. Fluxes boundary point below (1st order). + ! 5. Closure of 'X' if required + ! 6. Propagate. + ! ------------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T0 Test output input/output fields. + ! !/T1 Test output fluxes. + ! !/T2 Test output integration. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & + NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & + NDSE, NDST + REAL, INTENT(IN) :: DT + REAL, INTENT(INOUT) :: VELO(MY*(MX+1)), DX1(MY*(MX+1)), & + DX2(1-MY:MY*(MX+1)), Q(1-MY:MY*(MX+2)) + LOGICAL, INTENT(IN) :: CLOSE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & + IAD00, IAD02, IADN0, IADN1, IADN2 #ifdef W3_S - INTEGER, SAVE :: IENT + INTEGER, SAVE :: IENT #endif #ifdef W3_T1 - INTEGER :: IX2, IY2 + INTEGER :: IX2, IY2 #endif - REAL :: CFL, VEL, QB, DQ, DQNZ, QCN, QBN, & - QBR, CFAC, FLA(1-MY:MY*MX) + REAL :: CFL, VEL, QB, DQ, DQNZ, QCN, QBN, & + QBR, CFAC, FLA(1-MY:MY*MX) #ifdef W3_T0 - REAL :: QMAX + REAL :: QMAX #endif #ifdef W3_T1 - REAL :: QBO, QN, XCFL + REAL :: QBO, QN, XCFL #endif #ifdef W3_T2 - REAL :: QOLD + REAL :: QOLD #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3QCK2') + CALL STRACE (IENT, 'W3QCK2') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) MX, MY, NX, NY, DT, CLOSE, INC, NB0, NB1, NB2 + WRITE (NDST,9000) MX, MY, NX, NY, DT, CLOSE, INC, NB0, NB1, NB2 #endif -! + ! #ifdef W3_T0 - QMAX = 0. - DO IY=1, NY - DO IX=1, NX - QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) - END DO - END DO - QMAX = MAX ( 0.01*QMAX , 1.E-10 ) -#endif -! + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) +#endif + ! #ifdef W3_T0 - WRITE (NDST,9001) 'VELO' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(100.*VELO(IY+(IX-1)*MY) & - *DT/DX1(IY+(IX-1)*MY)),IX=1,NX) - END DO - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO - WRITE (NDST,9001) 'MAPACT' - WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) -#endif -! -! 1. Initialize aux. array FLA and closure ------------------------- * -! - FLA = 0. -! - IF ( CLOSE ) THEN + WRITE (NDST,9001) 'VELO' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*VELO(IY+(IX-1)*MY) & + *DT/DX1(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif + ! + ! 1. Initialize aux. array FLA and closure ------------------------- * + ! + FLA = 0. + ! + IF ( CLOSE ) THEN #ifdef W3_T - WRITE (NDST,9005) -#endif - IAD00 = -MY - IAD02 = MY - IADN0 = IAD00 + MY*NX - IADN1 = MY*NX - IADN2 = IAD02 + MY*NX - DO IY=1, NY - Q (IY+IAD00) = Q (IY+IADN0) - Q (IY+IADN1) = Q ( IY ) - Q (IY+IADN2) = Q (IY+IAD02) - VELO(IY+IADN1) = VELO( IY ) - DX1 (IY+IADN1) = DX1 ( IY ) - DX2 (IY+IAD00) = DX1 (IY+IADN0) - DX2 (IY+IADN1) = DX1 ( IY ) - END DO - END IF -! -! 2. Fluxes for central points ------------------------------------- * -! ( 3rd order + limiter ) -! + WRITE (NDST,9005) +#endif + IAD00 = -MY + IAD02 = MY + IADN0 = IAD00 + MY*NX + IADN1 = MY*NX + IADN2 = IAD02 + MY*NX + DO IY=1, NY + Q (IY+IAD00) = Q (IY+IADN0) + Q (IY+IADN1) = Q ( IY ) + Q (IY+IADN2) = Q (IY+IAD02) + VELO(IY+IADN1) = VELO( IY ) + DX1 (IY+IADN1) = DX1 ( IY ) + DX2 (IY+IAD00) = DX1 (IY+IADN0) + DX2 (IY+IADN1) = DX1 ( IY ) + END DO + END IF + ! + ! 2. Fluxes for central points ------------------------------------- * + ! ( 3rd order + limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9010) - WRITE (NDST,9011) NB0, 'CENTRAL' -#endif -! - DO IP=1, NB0 -! - IXY = MAPBOU(IP) - VEL = 0.5 * ( VELO(IXY) + VELO(IXY+INC) ) - CFL = DT * VEL / DX2(IXY) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - QB = 0.5 * ( (1.-CFL)*Q(IXY+INC) + (1.+CFL)*Q(IXY) ) & - - DX2(IXY)**2 / DX1(IXYC) * (1.-CFL**2) / 6. & - * ( (Q(IXYC+INC)-Q(IXYC))/DX2(IXYC) & - - (Q(IXYC)-Q(IXYC-INC))/DX2(IXYC-INC) ) -! - IXYU = IXYC - INC * INT ( SIGN (1.1,CFL) ) - IXYD = 2*IXYC - IXYU - DQ = Q(IXYD) - Q(IXYU) - DQNZ = SIGN ( MAX(1.E-15,ABS(DQ)) , DQ ) - QCN = ( Q(IXYC) - Q(IXYU) ) / DQNZ - QCN = MIN ( 1.1, MAX ( -0.1 , QCN ) ) -! + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' +#endif + ! + DO IP=1, NB0 + ! + IXY = MAPBOU(IP) + VEL = 0.5 * ( VELO(IXY) + VELO(IXY+INC) ) + CFL = DT * VEL / DX2(IXY) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + QB = 0.5 * ( (1.-CFL)*Q(IXY+INC) + (1.+CFL)*Q(IXY) ) & + - DX2(IXY)**2 / DX1(IXYC) * (1.-CFL**2) / 6. & + * ( (Q(IXYC+INC)-Q(IXYC))/DX2(IXYC) & + - (Q(IXYC)-Q(IXYC-INC))/DX2(IXYC-INC) ) + ! + IXYU = IXYC - INC * INT ( SIGN (1.1,CFL) ) + IXYD = 2*IXYC - IXYU + DQ = Q(IXYD) - Q(IXYU) + DQNZ = SIGN ( MAX(1.E-15,ABS(DQ)) , DQ ) + QCN = ( Q(IXYC) - Q(IXYU) ) / DQNZ + QCN = MIN ( 1.1, MAX ( -0.1 , QCN ) ) + ! #ifdef W3_T1 - QBO = QB -#endif - QBN = MAX ( (QB-Q(IXYU))/DQNZ , QCN ) - QBN = MIN ( QBN , 1. , QCN/MAX(1.E-10,ABS(CFL)) ) - QBR = Q(IXYU) + QBN*DQ - CFAC = REAL ( INT( 2. * ABS(QCN-0.5) ) ) - QB = (1.-CFAC)*QBR + CFAC*Q(IXYC) -! - FLA(IXY) = VEL * QB -! + QBO = QB +#endif + QBN = MAX ( (QB-Q(IXYU))/DQNZ , QCN ) + QBN = MIN ( QBN , 1. , QCN/MAX(1.E-10,ABS(CFL)) ) + QBR = Q(IXYU) + QBN*DQ + CFAC = REAL ( INT( 2. * ABS(QCN-0.5) ) ) + QB = (1.-CFAC)*QBR + CFAC*Q(IXYC) + ! + FLA(IXY) = VEL * QB + ! #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & - Q(IXY+INC), Q(IXY+2*INC) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & - CFL, DT*VELO(IXY)/DX1(IXY), & - DT*VELO(IXY+INC)/DX1(IXY+INC), & - QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & - Q(IXY+INC)*QN, Q(IXY+2*INC)*QN - END IF -#endif -! - END DO -! -! 3. Fluxes for points with boundary above ------------------------- * -! ( 1st order without limiter ) -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, DT*VELO(IXY)/DX1(IXY), & + DT*VELO(IXY+INC)/DX1(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif + ! + END DO + ! + ! 3. Fluxes for points with boundary above ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' -#endif -! - DO IP=NB0+1, NB1 - IXY = MAPBOU(IP) - VEL = VELO(IXY) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) - FLA(IXY) = VEL * Q(IXYC) + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif + ! + DO IP=NB0+1, NB1 + IXY = MAPBOU(IP) + VEL = VELO(IXY) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) + FLA(IXY) = VEL * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9013) IP, IX, IY, IX2, IY2, XCFL, & - DT*VELO(IXY)/DX2(IXY), & - Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF -#endif - END DO -! -! 4. Fluxes for points with boundary below ------------------------- * -! ( 1st order without limiter ) -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, XCFL, & + DT*VELO(IXY)/DX2(IXY), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif + END DO + ! + ! 4. Fluxes for points with boundary below ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' -#endif -! - DO IP=NB1+1, NB2 - IXY = MAPBOU(IP) - VEL = VELO(IXY+INC) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) - FLA(IXY) = VEL * Q(IXYC) + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif + ! + DO IP=NB1+1, NB2 + IXY = MAPBOU(IP) + VEL = VELO(IXY+INC) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) + FLA(IXY) = VEL * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9014) IP, IX, IY, IX2, IY2, XCFL, & - DT*VELO(IXY+INC)/DX2(IXY), & - Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF -#endif - END DO -! -! 5. Global closure ----------------------------------------------- * -! - IF ( CLOSE ) THEN + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, XCFL, & + DT*VELO(IXY+INC)/DX2(IXY), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif + END DO + ! + ! 5. Global closure ----------------------------------------------- * + ! + IF ( CLOSE ) THEN #ifdef W3_T - WRITE (NDST,9015) -#endif - DO IY=1, NY - FLA (IY+IAD00) = FLA (IY+IADN0) - END DO - END IF -! -! 6. Propagation -------------------------------------------------- * -! + WRITE (NDST,9015) +#endif + DO IY=1, NY + FLA (IY+IAD00) = FLA (IY+IADN0) + END DO + END IF + ! + ! 6. Propagation -------------------------------------------------- * + ! #ifdef W3_T2 - WRITE (NDST,9020) + WRITE (NDST,9020) #endif - DO IP=1, NACT - IXY = MAPACT(IP) + DO IP=1, NACT + IXY = MAPACT(IP) #ifdef W3_T2 - QOLD = Q(IXY) + QOLD = Q(IXY) #endif - Q(IXY) = MAX ( 0. , Q(IXY) + DT/DX1(IXY) * & - (FLA(IXY-INC)-FLA(IXY)) ) + Q(IXY) = MAX ( 0. , Q(IXY) + DT/DX1(IXY) * & + (FLA(IXY-INC)-FLA(IXY)) ) #ifdef W3_T2 - IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & - WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & - DT*FLA(IXY-INC)/DX1(IXY), & - DT*FLA(IXY)/DX1(IXY) + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + DT*FLA(IXY-INC)/DX1(IXY), & + DT*FLA(IXY)/DX1(IXY) #endif - END DO -! + END DO + ! #ifdef W3_T0 - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO -#endif -! - RETURN -! -! Formats -! + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3QCK2 : ARRAY DIMENSIONS :',2I6/ & - ' USED :',2I6/ & - ' TIME STEP :',F8.1/ & - ' CLOSE, INC :',L6,I6/ & - ' NB0, NB1, NB2 :',3I6) +9000 FORMAT ( ' TEST W3QCK2 : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' TIME STEP :',F8.1/ & + ' CLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) #endif #ifdef W3_T0 - 9001 FORMAT ( ' TEST W3QCK2 : DUMP ARRAY ',A,' :') - 9002 FORMAT ( 1X,43I3) - 9003 FORMAT ( 1X,21I6) +9001 FORMAT ( ' TEST W3QCK2 : DUMP ARRAY ',A,' :') +9002 FORMAT ( 1X,43I3) +9003 FORMAT ( 1X,21I6) #endif #ifdef W3_T - 9005 FORMAT (' TEST W3QCK2 : GLOBAL CLOSURE (1)') +9005 FORMAT (' TEST W3QCK2 : GLOBAL CLOSURE (1)') #endif -! + ! #ifdef W3_T1 - 9010 FORMAT (' TEST W3QCK2 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & - ' Q (b,b,i-1,i,i+1,i+2)') - 9011 FORMAT (' TEST W3QCK2 :',I6,' POINTS OF TYPE ',A) - 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) - 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') - 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') +9010 FORMAT (' TEST W3QCK2 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') +9011 FORMAT (' TEST W3QCK2 :',I6,' POINTS OF TYPE ',A) +9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) +9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') #endif #ifdef W3_T - 9015 FORMAT (' TEST W3QCK2 : GLOBAL CLOSURE (2)') +9015 FORMAT (' TEST W3QCK2 : GLOBAL CLOSURE (2)') #endif -! + ! #ifdef W3_T2 - 9020 FORMAT (' TEST W3QCK2 : IP, IXY, 2Q, 2FL') - 9021 FORMAT (' ',2I6,2(1X,2E11.3)) -#endif -!/ -!/ End of W3QCK2 ----------------------------------------------------- / -!/ - END SUBROUTINE W3QCK2 -!/ ------------------------------------------------------------------- / -!> -!> @brief Like W3QCK1 with cell transparencies added. -!> -!> @details CFLL amd Q need only bee filled in the (MY,MX) range, -!> extension is used internally for closure. -!> CFLL and Q are defined as 1-D arrays internally. -!> -!> Called by: W3XYP2 Propagation in physical space. -!> -!> This routine can be used independently from WAVEWATCH III. -!> -!> -!> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. -!> @param[in] MY Field dimension (See MX) -!> @param[in] NX Part of field actually used -!> @param[in] NY Part of field actually used -!> @param[inout] CFLL Local Courant numbers (MY, MX+1). -!> @param[in] TRANS -!> @param[in] INC Increment in 1-D array corresponding to increment in 2-D space. -!> @param[in] MAPACT List of active grid points. -!> @param[in] NACT Size of MAPACT. -!> @param[in] MAPBOU Map with boundary information (See W3MAP2). -!> @param[in] NB0 Counter in MAPBOU -!> @param[in] NB1 Counter in MAPBOU -!> @param[in] NB2 Counter in MAPBOU -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> @param[inout] Q Propagated quantity (MY,0:MX+2) -!> @param[in] CLOSE Flag for closed 'X' dimension. -!> -!> @author H. L. Tolman @date 30-Oct-2009 -!> - SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & - INC, MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & - NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2014 | -!/ +-----------------------------------+ -!/ -!/ 13_nov-2001 : Origination. ( version 2.14 ) -!/ 16-Oct-2002 : Fix INTENT for TRANS. ( version 3.00 ) -!/ 05-Mar-2008 : Added NEC sxf90 compiler directives. -!/ (Chris Bunney, UK Met Office) ( version 3.13 ) -!/ 27-May-2014 : Added OMPH switches in W3QCK3. ( version 5.02 ) -!/ -! 1. Purpose : -! -! Like W3QCK1 with cell transparencies added. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MX,MY Int. I Field dimensions, if grid is 'closed' or -! circular, MX is the closed dimension. -! NX,NY Int. I Part of field actually used. -! CFLL R.A. I Local Courant numbers. (MY, MX+1) -! Q R.A. I/O Propagated quantity. (MY,0:MX+2) -! CLOSE Log. I Flag for closed 'X' dimension' -! INC Int. I Increment in 1-D array corresponding to -! increment in 2-D space. -! MAPACT I.A. I List of active grid points. -! NACT Int. I Size of MAPACT. -! MAPBOU I.A. I Map with boundary information (see W3MAP2). -! NBn Int. I Counters in MAPBOU. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! - CFLL amd Q need only bee filled in the (MY,MX) range, -! extension is used internally for closure. -! - CFLL and Q are defined as 1-D arrays internally. -! -! 4. Subroutines used : -! -! STRACE Service routine. -! -! 5. Called by : -! -! W3XYP2 Propagation in physical space -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - This routine can be used independently from WAVEWATCH III. -! -! 8. Structure : -! -! ------------------------------------------------------ -! 1. Initialize aux. array FLA. -! 2. Fluxes for central points (3rd order + limiter). -! 3. Fluxes boundary point above (1st order). -! 4. Fluxes boundary point below (1st order). -! 5. Closure of 'X' if required -! 6. Propagate. -! ------------------------------------------------------ -! -! 9. Switches : -! -! !/OMPH Ading OMP directves for hybrid paralellization. -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T0 Test output input/output fields. -! !/T1 Test output fluxes. -! !/T2 Test output integration. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & - NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & - NDSE, NDST - REAL, INTENT(IN) :: TRANS(MY*MX,-1:1) - REAL, INTENT(INOUT) :: CFLL(MY*(MX+1)), Q(1-MY:MY*(MX+2)) - LOGICAL, INTENT(IN) :: CLOSE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & - IAD00, IAD02, IADN0, IADN1, IADN2, & - JN, JP +9020 FORMAT (' TEST W3QCK2 : IP, IXY, 2Q, 2FL') +9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif + !/ + !/ End of W3QCK2 ----------------------------------------------------- / + !/ + END SUBROUTINE W3QCK2 + !/ ------------------------------------------------------------------- / + !> + !> @brief Like W3QCK1 with cell transparencies added. + !> + !> @details CFLL amd Q need only bee filled in the (MY,MX) range, + !> extension is used internally for closure. + !> CFLL and Q are defined as 1-D arrays internally. + !> + !> Called by: W3XYP2 Propagation in physical space. + !> + !> This routine can be used independently from WAVEWATCH III. + !> + !> + !> @param[in] MX Field dimensions, if grid is 'closed' or circular, MX is the closed dimension. + !> @param[in] MY Field dimension (See MX) + !> @param[in] NX Part of field actually used + !> @param[in] NY Part of field actually used + !> @param[inout] CFLL Local Courant numbers (MY, MX+1). + !> @param[in] TRANS + !> @param[in] INC Increment in 1-D array corresponding to increment in 2-D space. + !> @param[in] MAPACT List of active grid points. + !> @param[in] NACT Size of MAPACT. + !> @param[in] MAPBOU Map with boundary information (See W3MAP2). + !> @param[in] NB0 Counter in MAPBOU + !> @param[in] NB1 Counter in MAPBOU + !> @param[in] NB2 Counter in MAPBOU + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> @param[inout] Q Propagated quantity (MY,0:MX+2) + !> @param[in] CLOSE Flag for closed 'X' dimension. + !> + !> @author H. L. Tolman @date 30-Oct-2009 + !> + SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & + INC, MAPACT, NACT, MAPBOU, NB0, NB1, NB2, & + NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2014 | + !/ +-----------------------------------+ + !/ + !/ 13_nov-2001 : Origination. ( version 2.14 ) + !/ 16-Oct-2002 : Fix INTENT for TRANS. ( version 3.00 ) + !/ 05-Mar-2008 : Added NEC sxf90 compiler directives. + !/ (Chris Bunney, UK Met Office) ( version 3.13 ) + !/ 27-May-2014 : Added OMPH switches in W3QCK3. ( version 5.02 ) + !/ + ! 1. Purpose : + ! + ! Like W3QCK1 with cell transparencies added. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MX,MY Int. I Field dimensions, if grid is 'closed' or + ! circular, MX is the closed dimension. + ! NX,NY Int. I Part of field actually used. + ! CFLL R.A. I Local Courant numbers. (MY, MX+1) + ! Q R.A. I/O Propagated quantity. (MY,0:MX+2) + ! CLOSE Log. I Flag for closed 'X' dimension' + ! INC Int. I Increment in 1-D array corresponding to + ! increment in 2-D space. + ! MAPACT I.A. I List of active grid points. + ! NACT Int. I Size of MAPACT. + ! MAPBOU I.A. I Map with boundary information (see W3MAP2). + ! NBn Int. I Counters in MAPBOU. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! - CFLL amd Q need only bee filled in the (MY,MX) range, + ! extension is used internally for closure. + ! - CFLL and Q are defined as 1-D arrays internally. + ! + ! 4. Subroutines used : + ! + ! STRACE Service routine. + ! + ! 5. Called by : + ! + ! W3XYP2 Propagation in physical space + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - This routine can be used independently from WAVEWATCH III. + ! + ! 8. Structure : + ! + ! ------------------------------------------------------ + ! 1. Initialize aux. array FLA. + ! 2. Fluxes for central points (3rd order + limiter). + ! 3. Fluxes boundary point above (1st order). + ! 4. Fluxes boundary point below (1st order). + ! 5. Closure of 'X' if required + ! 6. Propagate. + ! ------------------------------------------------------ + ! + ! 9. Switches : + ! + ! !/OMPH Ading OMP directves for hybrid paralellization. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T0 Test output input/output fields. + ! !/T1 Test output fluxes. + ! !/T2 Test output integration. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MX, MY, NX, NY, INC, MAPACT(MY*MX), & + NACT, MAPBOU(MY*MX), NB0, NB1, NB2, & + NDSE, NDST + REAL, INTENT(IN) :: TRANS(MY*MX,-1:1) + REAL, INTENT(INOUT) :: CFLL(MY*(MX+1)), Q(1-MY:MY*(MX+2)) + LOGICAL, INTENT(IN) :: CLOSE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & + IAD00, IAD02, IADN0, IADN1, IADN2, & + JN, JP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T1 - INTEGER :: IX2, IY2 + INTEGER :: IX2, IY2 #endif - REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC - REAL :: FLA(1-MY:MY*MX) + REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC + REAL :: FLA(1-MY:MY*MX) #ifdef W3_T0 - REAL :: QMAX + REAL :: QMAX #endif #ifdef W3_T1 - REAL :: QBO, QN + REAL :: QBO, QN #endif #ifdef W3_T2 - REAL :: QOLD + REAL :: QOLD #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3QCK3') + CALL STRACE (IENT, 'W3QCK3') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) MX, MY, NX, NY, CLOSE, INC, NB0, NB1, NB2 + WRITE (NDST,9000) MX, MY, NX, NY, CLOSE, INC, NB0, NB1, NB2 #endif -! + ! #ifdef W3_T0 - QMAX = 0. - DO IY=1, NY - DO IX=1, NX - QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) - END DO - END DO - QMAX = MAX ( 0.01*QMAX , 1.E-10 ) -#endif -! + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) +#endif + ! #ifdef W3_T0 - WRITE (NDST,9001) 'CFLL' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) - END DO - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO - WRITE (NDST,9001) 'MAPACT' - WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) -#endif -! -! 1. Initialize aux. array FLA and closure ------------------------- * -! - FLA = 0. -! - IF ( CLOSE ) THEN + WRITE (NDST,9001) 'CFLL' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif + ! + ! 1. Initialize aux. array FLA and closure ------------------------- * + ! + FLA = 0. + ! + IF ( CLOSE ) THEN #ifdef W3_T - WRITE (NDST,9005) -#endif - IAD00 = -MY - IAD02 = MY - IADN0 = IAD00 + MY*NX - IADN1 = MY*NX - IADN2 = IAD02 + MY*NX -! + WRITE (NDST,9005) +#endif + IAD00 = -MY + IAD02 = MY + IADN0 = IAD00 + MY*NX + IADN1 = MY*NX + IADN2 = IAD02 + MY*NX + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (IY) -#endif -! - DO IY=1, NY - Q (IY+IAD00) = Q (IY+IADN0) ! 1 ghost column to left - Q (IY+IADN1) = Q ( IY ) ! 1st ghost column to right - Q (IY+IADN2) = Q (IY+IAD02) ! 2nd ghost column to right - CFLL(IY+IADN1) = CFLL( IY ) ! as for Q above, 1st to rt - END DO -! + !$OMP PARALLEL DO PRIVATE (IY) +#endif + ! + DO IY=1, NY + Q (IY+IAD00) = Q (IY+IADN0) ! 1 ghost column to left + Q (IY+IADN1) = Q ( IY ) ! 1st ghost column to right + Q (IY+IADN2) = Q (IY+IAD02) ! 2nd ghost column to right + CFLL(IY+IADN1) = CFLL( IY ) ! as for Q above, 1st to rt + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO -#endif -! - END IF -! -! 2. Fluxes for central points ------------------------------------- * -! ( 3rd order + limiter ) -! + !$OMP END PARALLEL DO +#endif + ! + END IF + ! + ! 2. Fluxes for central points ------------------------------------- * + ! ( 3rd order + limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9010) - WRITE (NDST,9011) NB0, 'CENTRAL' + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' #endif -! + ! #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, IXYC, QB, IXYU, IXYD, & + !$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, IXYC, QB, IXYU, IXYD, & #ifdef W3_T1 -!$OMP QBO, QN, IX, IY, IX2, IY2, & -#endif -!$OMP& DQ, DQNZ, QCN, QBN, QBR, CFAC ) -#endif -! - DO IP=1, NB0 -! - IXY = MAPBOU(IP) - CFL = 0.5 * ( CFLL(IXY) + CFLL(IXY+INC) ) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - QB = 0.5 * ( (1.-CFL)*Q(IXY+INC) + (1.+CFL)*Q(IXY) ) & - - (1.-CFL**2)/6. * (Q(IXYC-INC)-2.*Q(IXYC)+Q(IXYC+INC)) -! - IXYU = IXYC - INC * INT ( SIGN (1.1,CFL) ) - IXYD = 2*IXYC - IXYU - DQ = Q(IXYD) - Q(IXYU) - DQNZ = SIGN ( MAX(1.E-15,ABS(DQ)) , DQ ) - QCN = ( Q(IXYC) - Q(IXYU) ) / DQNZ - QCN = MIN ( 1.1, MAX ( -0.1 , QCN ) ) -! + !$OMP QBO, QN, IX, IY, IX2, IY2, & +#endif + !$OMP& DQ, DQNZ, QCN, QBN, QBR, CFAC ) +#endif + ! + DO IP=1, NB0 + ! + IXY = MAPBOU(IP) + CFL = 0.5 * ( CFLL(IXY) + CFLL(IXY+INC) ) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + QB = 0.5 * ( (1.-CFL)*Q(IXY+INC) + (1.+CFL)*Q(IXY) ) & + - (1.-CFL**2)/6. * (Q(IXYC-INC)-2.*Q(IXYC)+Q(IXYC+INC)) + ! + IXYU = IXYC - INC * INT ( SIGN (1.1,CFL) ) + IXYD = 2*IXYC - IXYU + DQ = Q(IXYD) - Q(IXYU) + DQNZ = SIGN ( MAX(1.E-15,ABS(DQ)) , DQ ) + QCN = ( Q(IXYC) - Q(IXYU) ) / DQNZ + QCN = MIN ( 1.1, MAX ( -0.1 , QCN ) ) + ! #ifdef W3_T1 - QBO = QB -#endif - QBN = MAX ( (QB-Q(IXYU))/DQNZ , QCN ) - QBN = MIN ( QBN , 1. , QCN/MAX(1.E-10,ABS(CFL)) ) - QBR = Q(IXYU) + QBN*DQ - CFAC = REAL ( INT( 2. * ABS(QCN-0.5) ) ) - QB = (1.-CFAC)*QBR + CFAC*Q(IXYC) -! - FLA(IXY) = CFL * QB -! + QBO = QB +#endif + QBN = MAX ( (QB-Q(IXYU))/DQNZ , QCN ) + QBN = MIN ( QBN , 1. , QCN/MAX(1.E-10,ABS(CFL)) ) + QBR = Q(IXYU) + QBN*DQ + CFAC = REAL ( INT( 2. * ABS(QCN-0.5) ) ) + QB = (1.-CFAC)*QBR + CFAC*Q(IXYC) + ! + FLA(IXY) = CFL * QB + ! #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & - Q(IXY+INC), Q(IXY+2*INC) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & - CFL, CFLL(IXY), CFLL(IXY+INC), & - QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & - Q(IXY+INC)*QN, Q(IXY+2*INC)*QN - END IF -#endif -! - END DO -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, CFLL(IXY), CFLL(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif + ! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! -! 3. Fluxes for points with boundary above ------------------------- * -! ( 1st order without limiter ) -! + ! + ! 3. Fluxes for points with boundary above ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' #endif -! + ! !!!/OMPH/!$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, IXYC) !!! - DO IP=NB0+1, NB1 - IXY = MAPBOU(IP) - CFL = CFLL(IXY) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - FLA(IXY) = CFL * Q(IXYC) + DO IP=NB0+1, NB1 + IXY = MAPBOU(IP) + CFL = CFLL(IXY) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + FLA(IXY) = CFL * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & - CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF -#endif - END DO + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif + END DO !!! !!!/OMPH/!$OMP END PARALLEL DO -! -! 4. Fluxes for points with boundary below ------------------------- * -! ( 1st order without limiter ) -! + ! + ! 4. Fluxes for points with boundary below ------------------------- * + ! ( 1st order without limiter ) + ! #ifdef W3_T1 - WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' #endif -! + ! !!!/OMPH/!$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, IXYC) !!! - DO IP=NB1+1, NB2 - IXY = MAPBOU(IP) - CFL = CFLL(IXY+INC) - IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) - FLA(IXY) = CFL * Q(IXYC) + DO IP=NB1+1, NB2 + IXY = MAPBOU(IP) + CFL = CFLL(IXY+INC) + IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) + FLA(IXY) = CFL * Q(IXYC) #ifdef W3_T1 - IY = MOD ( IXY , MY ) - IX = 1 + IXY/MY - IY2 = MOD ( IXY+INC , MY ) - IX2 = 1 + (IXY+INC)/MY - QN = MAX ( Q(IXY+INC), Q(IXY) ) - IF ( QN .GT. 1.E-10 ) THEN - QN = 1. /QN - WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, CFLL(IXY+INC), & - Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN - END IF -#endif - END DO -! + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, CFLL(IXY+INC), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif + END DO + ! !!!/OMPH/!$OMP END PARALLEL DO -! -! 5. Global closure ----------------------------------------------- * -! - IF ( CLOSE ) THEN + ! + ! 5. Global closure ----------------------------------------------- * + ! + IF ( CLOSE ) THEN #ifdef W3_T - WRITE (NDST,9015) -#endif - DO IY=1, NY - FLA (IY+IAD00) = FLA (IY+IADN0) - END DO - END IF -! -! 6. Propagation -------------------------------------------------- * -! + WRITE (NDST,9015) +#endif + DO IY=1, NY + FLA (IY+IAD00) = FLA (IY+IADN0) + END DO + END IF + ! + ! 6. Propagation -------------------------------------------------- * + ! #ifdef W3_T2 - WRITE (NDST,9020) + WRITE (NDST,9020) #endif #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE (IP, IXY, JN, JP ) -#endif -! - DO IP=1, NACT -! - IXY = MAPACT(IP) - IF ( FLA(IXY-INC) .GT. 0. ) THEN - JN = -1 - ELSE - JN = 0 - END IF - IF ( FLA(IXY ) .LT. 0. ) THEN - JP = 1 - ELSE - JP = 0 - END IF -! + !$OMP PARALLEL DO PRIVATE (IP, IXY, JN, JP ) +#endif + ! + DO IP=1, NACT + ! + IXY = MAPACT(IP) + IF ( FLA(IXY-INC) .GT. 0. ) THEN + JN = -1 + ELSE + JN = 0 + END IF + IF ( FLA(IXY ) .LT. 0. ) THEN + JP = 1 + ELSE + JP = 0 + END IF + ! #ifdef W3_T2 - QOLD = Q(IXY) + QOLD = Q(IXY) #endif - Q(IXY) = MAX ( 0. , Q(IXY) + TRANS(IXY,JN) * FLA(IXY-INC) & - - TRANS(IXY,JP) * FLA(IXY) ) + Q(IXY) = MAX ( 0. , Q(IXY) + TRANS(IXY,JN) * FLA(IXY-INC) & + - TRANS(IXY,JP) * FLA(IXY) ) #ifdef W3_T2 - IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & - WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & - FLA(IXY-INC), FLA(IXY) + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + FLA(IXY-INC), FLA(IXY) #endif - END DO -! + END DO + ! #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! + ! #ifdef W3_T0 - WRITE (NDST,9001) 'Q' - DO IY=NY,1,-1 - WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) - END DO -#endif -! - RETURN -! -! Formats -! + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3QCK3 : ARRAY DIMENSIONS :',2I6/ & - ' USED :',2I6/ & - ' CLOSE, INC :',L6,I6/ & - ' NB0, NB1, NB2 :',3I6) +9000 FORMAT ( ' TEST W3QCK3 : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' CLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) #endif #ifdef W3_T0 - 9001 FORMAT ( ' TEST W3QCK3 : DUMP ARRAY ',A,' :') - 9002 FORMAT ( 1X,43I3) - 9003 FORMAT ( 1X,21I6) +9001 FORMAT ( ' TEST W3QCK3 : DUMP ARRAY ',A,' :') +9002 FORMAT ( 1X,43I3) +9003 FORMAT ( 1X,21I6) #endif #ifdef W3_T - 9005 FORMAT (' TEST W3QCK3 : GLOBAL CLOSURE (1)') +9005 FORMAT (' TEST W3QCK3 : GLOBAL CLOSURE (1)') #endif -! + ! #ifdef W3_T1 - 9010 FORMAT (' TEST W3QCK3 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & - ' Q (b,b,i-1,i,i+1,i+2)') - 9011 FORMAT (' TEST W3QCK3 :',I6,' POINTS OF TYPE ',A) - 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) - 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') - 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& - 2F6.2,' --- ') +9010 FORMAT (' TEST W3QCK3 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') +9011 FORMAT (' TEST W3QCK3 :',I6,' POINTS OF TYPE ',A) +9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) +9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') #endif #ifdef W3_T - 9015 FORMAT (' TEST W3QCK3 : GLOBAL CLOSURE (2)') +9015 FORMAT (' TEST W3QCK3 : GLOBAL CLOSURE (2)') #endif -! + ! #ifdef W3_T2 - 9020 FORMAT (' TEST W3QCK3 : IP, IXY, 2Q, 2FL') - 9021 FORMAT (' ',2I6,2(1X,2E11.3)) -#endif -!/ -!/ End of W3QCK3 ----------------------------------------------------- / -!/ - END SUBROUTINE W3QCK3 -!/ -!/ End of module W3UQCKMD -------------------------------------------- / -!/ - END MODULE W3UQCKMD +9020 FORMAT (' TEST W3QCK3 : IP, IXY, 2Q, 2FL') +9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif + !/ + !/ End of W3QCK3 ----------------------------------------------------- / + !/ + END SUBROUTINE W3QCK3 + !/ + !/ End of module W3UQCKMD -------------------------------------------- / + !/ +END MODULE W3UQCKMD diff --git a/model/src/w3wavemd.F90 b/model/src/w3wavemd.F90 index baf995157..eb5c4b596 100644 --- a/model/src/w3wavemd.F90 +++ b/model/src/w3wavemd.F90 @@ -1,1583 +1,1585 @@ !> @file !> @brief Contains MODULE W3WAVEMD. -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> -#include "w3macros.h" -!/ ------------------------------------------------------------------- / !> -!> @brief Contains wave model subroutine, w3wave. -!> !> @author H. L. Tolman @date 22-Mar-2021 !> - MODULE W3WAVEMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Sep-2022 | -!/ +-----------------------------------+ -!/ -!/ 04-Feb-2000 : Origination. ( version 2.00 ) -!/ For upgrades see subroutines. -!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) -!/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) -!/ without output. -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) -!/ 23-Feb-2001 : Check for barrier after source -!/ terms added ( W3NMIN ). ( delayed version 2.07 ) -!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) -!/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) -!/ 23-May-2001 : Clean up and bug fixes. ( version 2.11 ) -!/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) -!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) -!/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) -!/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) -!/ 30-Apr-2002 : Add field output types 17-18. ( version 2.20 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) -!/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) -!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) -!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ W3INIT, W3MPII-O and WWVER moved to w3initmd.ftn -!/ 04-Feb-2005 : Add STAMP to par list of W3WAVE. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) -!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) -!/ Fix NRQSG1/2 = 0 array bound issue. -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) -!/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) -!/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Mar-2010 : Adding coupling, ice in W3SRCE. ( version 3.14_SHOM ) -!/ 16-May-2010 : Adding transparencies in W3SCRE ( version 3.14_SHOM ) -!/ 23-Jun-2011 : Movable bed bottom friction BT4 ( version 4.04 ) -!/ 03-Nov-2011 : Shoreline reflection on unst. grids ( version 4.04 ) -!/ 02-Jul-2011 : Update for PALM coupling ( version 4.07 ) -!/ 06-Mar-2012 : Initializing ITEST as needed. ( version 4.07 ) -!/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) -!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) -!/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) -!/ 07-Dec-2012 : Wrap W3SRCE with TMPn to limit WARN ( version 4.OF ) -!/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) -!/ structure and smaller memory footprint. -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) -!/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) -!/ 16-Sep-2013 : Add Arctic part for SMC grid. ( version 4.11 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 14-Nov-2013 : Remove orphaned work arrays. ( version 4.13 ) -!/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) -!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) -!/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) -!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) -!/ (M. Accensi & F. Ardhuin, IFREMER) -!/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.08 ) -!/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) -!/ 15-Sep-2020 : Bugfix FIELD allocation. Remove ( version 7.11 ) -!/ defunct OMPX switches. -!/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) -!/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ 11-Nov-2021 : Remove XYB since it is obsolete ( version 7.xx ) -!/ 13-Sep-2022 : Add OMP for W3NMIN loops. Hide -!/ W3NMIN in W3_DEBUGRUN for scaling. ( version 7.xx ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3WAVE Subr. Public Actual wave model. -! W3GATH Subr. Public Data transpose before propagation. -! W3SCAT Subr. Public Data transpose after propagation. -! W3NMIN Subr. Public Calculate minimum number of sea -! points per processor. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETx Subr. W3xDATMD Point to data structure. -! -! W3UCUR Subr. W3UPDTMD Interpolate current fields in time. -! W3UWND Subr. W3UPDTMD Interpolate wind fields in time. -! W3UINI Subr. W3UPDTMD Update initial conditions if init. -! with initial wind conditions. -! W3UBPT Subr. W3UPDTMD Update boundary points. -! W3UICE Subr. W3UPDTMD Update ice coverage. -! W3ULEV Subr. W3UPDTMD Transform the wavenumber grid. -! W3DDXY Subr. W3UPDTMD Calculate dirivatives of the depth. -! W3DCXY Subr. W3UPDTMD Calculate dirivatives of the current. -! -! W3MAPn Subr. W3PROnMD Preparation for ropagation schemes. -! W3XYPn Subr. W3PROnMD Longitude-latitude ("XY") propagation. -! W3KTPn Subr. W3PROnMD Intra-spectral ("k-theta") propagation. -! -! W3SRCE Subr. W3SRCEMD Source term integration and calculation. -! -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3OUTG Subr. W3IOGOMD Generate gridded output fields. -! W3IOGO Subr. W3IOGOMD Read/write gridded output. -! W3IOPE Subr. W3IOPOMD Extract point output. -! W3IOPO Subr. W3IOPOMD Read/write point output. -! W3IOTR Subr. W3IOTRMD Process spectral output along tracks. -! W3IORS Subr. W3IORSMD Read/write restart files. -! W3IOBC Subr. W3IOBCMD Read/write boundary conditions. -! W3CPRT Subr. W3IOSFMD Partition spectra. -! W3IOSF Subr. Id. Write partitioned spectral data. -! -! STRACE Subr. W3SERVMD Subroutine tracing. -! WWTIME Subr. Id. System time in readable format. -! EXTCDE Subr. Id. Program abort. -! -! TICK21 Subr. W3TIMEMD Advance the clock. -! DSEC21 Func. Id. Difference between times. -! STME21 Subr. Id. Time in readable format. -! -! MPI_BARRIER, MPI_STARTALL, MPI_WAITALL -! Subr. Basic MPI routines. -! ---------------------------------------------------------------- -! -! 5. Remarks : Call to W3NMIN hidden behind W3_DEBUGRUN. This call -! currently only serves to warn when one or more procs -! have no active seapoints. It has been hid as this -! dramatically increases runtime performance. -! -! 6. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! !/OMPG Id. -! -! !/PR1 First order propagation schemes. -! !/PR2 ULTIMATE QUICKEST scheme. -! !/PR3 Averaged ULTIMATE QUICKEST scheme. -! !/SMC UNO2 scheme on SMC grid. -! -! !/S Enable subroutine tracing. -! !/T Test output. -! !/MPIT Test output for MPI specific code. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_MPI - USE W3ADATMD, ONLY: MPIBUF -#endif - ! module default - IMPLICIT NONE -! - PUBLIC -!/ - CONTAINS +#include "w3macros.h" !/ ------------------------------------------------------------------- / !> -!> @brief Run WAVEWATCH III for a given time interval. -!> -!> @details Currents are updated before winds as currents are used in wind -!> and USTAR processing. -!> -!> Ice and water levels can be updated only once per call. -!> -!> If ice or water level time are undefined, the update -!> takes place asap, otherwise around the "half-way point" -!> between the old and new times. -!> -!> To increase accuracy, the calculation of the intra-spectral -!> propagation is performed in two parts around the spatial propagation. -!> -!> @param[in] IMOD Model number. -!> @param[in] TEND Ending time of integration. -!> @param[in] STAMP Write time stamp (optional, defaults to T). -!> @param[in] NO_OUT Skip output (optional, defaults to F). -!> @param[in] ODAT -!> @param[in] ID_LCOMM Present only when using W3_OASIS. -!> @param[in] TIMEN Present only when using W3_OASIS. +!> @brief Contains wave model subroutine, w3wave. !> !> @author H. L. Tolman @date 22-Mar-2021 !> - - SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & +MODULE W3WAVEMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Sep-2022 | + !/ +-----------------------------------+ + !/ + !/ 04-Feb-2000 : Origination. ( version 2.00 ) + !/ For upgrades see subroutines. + !/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) + !/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) + !/ without output. + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) + !/ 23-Feb-2001 : Check for barrier after source + !/ terms added ( W3NMIN ). ( delayed version 2.07 ) + !/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) + !/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) + !/ 23-May-2001 : Clean up and bug fixes. ( version 2.11 ) + !/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) + !/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) + !/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) + !/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) + !/ 30-Apr-2002 : Add field output types 17-18. ( version 2.20 ) + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) + !/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) + !/ 20-Aug-2003 : Output server options added. ( version 3.04 ) + !/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) + !/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ W3INIT, W3MPII-O and WWVER moved to w3initmd.ftn + !/ 04-Feb-2005 : Add STAMP to par list of W3WAVE. ( version 3.07 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) + !/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) + !/ Fix NRQSG1/2 = 0 array bound issue. + !/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) + !/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) + !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) + !/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) + !/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) + !/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) + !/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) + !/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 29-Mar-2010 : Adding coupling, ice in W3SRCE. ( version 3.14_SHOM ) + !/ 16-May-2010 : Adding transparencies in W3SCRE ( version 3.14_SHOM ) + !/ 23-Jun-2011 : Movable bed bottom friction BT4 ( version 4.04 ) + !/ 03-Nov-2011 : Shoreline reflection on unst. grids ( version 4.04 ) + !/ 02-Jul-2011 : Update for PALM coupling ( version 4.07 ) + !/ 06-Mar-2012 : Initializing ITEST as needed. ( version 4.07 ) + !/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) + !/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) + !/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) + !/ 07-Dec-2012 : Wrap W3SRCE with TMPn to limit WARN ( version 4.OF ) + !/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) + !/ structure and smaller memory footprint. + !/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) + !/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) + !/ 16-Sep-2013 : Add Arctic part for SMC grid. ( version 4.11 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 14-Nov-2013 : Remove orphaned work arrays. ( version 4.13 ) + !/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) + !/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) + !/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) + !/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) + !/ (M. Accensi & F. Ardhuin, IFREMER) + !/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.08 ) + !/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) + !/ 15-Sep-2020 : Bugfix FIELD allocation. Remove ( version 7.11 ) + !/ defunct OMPX switches. + !/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) + !/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ 11-Nov-2021 : Remove XYB since it is obsolete ( version 7.xx ) + !/ 13-Sep-2022 : Add OMP for W3NMIN loops. Hide + !/ W3NMIN in W3_DEBUGRUN for scaling. ( version 7.xx ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. Public Actual wave model. + ! W3GATH Subr. Public Data transpose before propagation. + ! W3SCAT Subr. Public Data transpose after propagation. + ! W3NMIN Subr. Public Calculate minimum number of sea + ! points per processor. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETx Subr. W3xDATMD Point to data structure. + ! + ! W3UCUR Subr. W3UPDTMD Interpolate current fields in time. + ! W3UWND Subr. W3UPDTMD Interpolate wind fields in time. + ! W3UINI Subr. W3UPDTMD Update initial conditions if init. + ! with initial wind conditions. + ! W3UBPT Subr. W3UPDTMD Update boundary points. + ! W3UICE Subr. W3UPDTMD Update ice coverage. + ! W3ULEV Subr. W3UPDTMD Transform the wavenumber grid. + ! W3DDXY Subr. W3UPDTMD Calculate dirivatives of the depth. + ! W3DCXY Subr. W3UPDTMD Calculate dirivatives of the current. + ! + ! W3MAPn Subr. W3PROnMD Preparation for ropagation schemes. + ! W3XYPn Subr. W3PROnMD Longitude-latitude ("XY") propagation. + ! W3KTPn Subr. W3PROnMD Intra-spectral ("k-theta") propagation. + ! + ! W3SRCE Subr. W3SRCEMD Source term integration and calculation. + ! + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3OUTG Subr. W3IOGOMD Generate gridded output fields. + ! W3IOGO Subr. W3IOGOMD Read/write gridded output. + ! W3IOPE Subr. W3IOPOMD Extract point output. + ! W3IOPO Subr. W3IOPOMD Read/write point output. + ! W3IOTR Subr. W3IOTRMD Process spectral output along tracks. + ! W3IORS Subr. W3IORSMD Read/write restart files. + ! W3IOBC Subr. W3IOBCMD Read/write boundary conditions. + ! W3CPRT Subr. W3IOSFMD Partition spectra. + ! W3IOSF Subr. Id. Write partitioned spectral data. + ! + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! WWTIME Subr. Id. System time in readable format. + ! EXTCDE Subr. Id. Program abort. + ! + ! TICK21 Subr. W3TIMEMD Advance the clock. + ! DSEC21 Func. Id. Difference between times. + ! STME21 Subr. Id. Time in readable format. + ! + ! MPI_BARRIER, MPI_STARTALL, MPI_WAITALL + ! Subr. Basic MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : Call to W3NMIN hidden behind W3_DEBUGRUN. This call + ! currently only serves to warn when one or more procs + ! have no active seapoints. It has been hid as this + ! dramatically increases runtime performance. + ! + ! 6. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! !/OMPG Id. + ! + ! !/PR1 First order propagation schemes. + ! !/PR2 ULTIMATE QUICKEST scheme. + ! !/PR3 Averaged ULTIMATE QUICKEST scheme. + ! !/SMC UNO2 scheme on SMC grid. + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! !/MPIT Test output for MPI specific code. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPIBUF +#endif + ! module default + IMPLICIT NONE + ! + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Run WAVEWATCH III for a given time interval. + !> + !> @details Currents are updated before winds as currents are used in wind + !> and USTAR processing. + !> + !> Ice and water levels can be updated only once per call. + !> + !> If ice or water level time are undefined, the update + !> takes place asap, otherwise around the "half-way point" + !> between the old and new times. + !> + !> To increase accuracy, the calculation of the intra-spectral + !> propagation is performed in two parts around the spatial propagation. + !> + !> @param[in] IMOD Model number. + !> @param[in] TEND Ending time of integration. + !> @param[in] STAMP Write time stamp (optional, defaults to T). + !> @param[in] NO_OUT Skip output (optional, defaults to F). + !> @param[in] ODAT + !> @param[in] ID_LCOMM Present only when using W3_OASIS. + !> @param[in] TIMEN Present only when using W3_OASIS. + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + + SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #ifdef W3_OASIS - ,ID_LCOMM, TIMEN & -#endif - ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) -!/ without output. -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) -!/ 23-Feb-2001 : Check for barrier after source -!/ terms added ( W3NMIN ). ( delayed version 2.07 ) -!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) -!/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) -!/ 23-May-2001 : Barrier added for dry run, changed ( version 2.10 ) -!/ declaration of FLIWND. -!/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) -!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) -!/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) -!/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) -!/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) -!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 04-Feb-2005 : Add STAMP to par list. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) -!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) -!/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ Improve MPI_WAITALL call tests/allocations. -!/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) -!/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) -!/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 31-Mar-2010 : Add reflections ( version 3.14.4 ) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Mar-2011 : Output of max. CFL (F.Ardhuin) ( version 3.14.4 ) -!/ 05-Apr-2011 : Implement iteration for DTMAX <1s ( version 3.14.4 ) -!/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) -!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) -!/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) -!/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) -!/ structure and smaller memory footprint. -!/ 16-Nov-2013 : Allows reflection on curvi. grids ( version 4.13 ) -!/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) -!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) -!/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) -!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) -!/ (M. Accensi & F. Ardhuin, IFREMER) -!/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.10 ) -!/ 31-Mar-2016 : Current option for smc grid. ( version 5.18 ) -!/ 06-Jun-2018 : Add PDLIB/MEMCHECK/SETUP/NETCDF_QAD/TIMING -!/ OASIS/DEBUGINIT/DEBUGSRC/DEBUGRUN/DEBUGCOH -!/ DEBUGIOBP/DEBUGIOBC ( version 6.04 ) -!/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) -!/ 25-Sep-2020 : Oasis coupling at T+0 ( version 7.10 ) -!/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) -!/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) -!/ -! 1. Purpose : -! -! Run WAVEWATCH III for a given time interval. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! TEND I.A. I Ending time of integration. -! STAMP Log. I WRITE(*,*)time stamp (optional, defaults to T). -! NO_OUT Log. I Skip output (optional, defaults to F). -! Skip at ending time only! -! ---------------------------------------------------------------- -! -! Local parameters : Flags -! ---------------------------------------------------------------- -! FLOUTG Log. Flag for running W3OUTG. -! FLPART Log. Flag for running W3CPRT. -! FLZERO Log. Flag for zero time interval. -! FLAG0 Log. Flag for processors without tasks. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program shell or integrated model which uses WAVEWATCH III. -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Currents are updated before winds as currents are used in wind -! and USTAR processing. -! - Ice and water levels can be updated only once per call. -! - If ice or water level time are undefined, the update -! takes place asap, otherwise around the "half-way point" -! betweem the old and new times. -! - To increase accuracy, the calculation of the intra-spectral -! propagation is performed in two parts around the spatial propagation. -! -! 8. Structure : -! -! ----------------------------------------------------------- -! 0. Initializations -! a Point to data structures -! b Subroutine tracing -! c Local parameter initialization -! d Test output -! 1. Check the consistency of the input. -! a Ending time versus initial time. -! b Water level time. -! c Current time interval. -! d Wind time interval. -! e Ice time. -! 2. Determine next time from ending and output -! time and get corresponding time step. -! 3. Loop over time steps (see below). -! 4. Perform output to file if requested. -! a Check if time is output time. -! b Processing and MPP preparations. ( W3CPRT, W3OUTG ) -! c Reset next output time. -! -------------- loop over output types ------------------ -! d Perform output. ( W3IOxx ) -! e Update next output time. -! -------------------- end loop -------------------------- -! 5. Update log file. -! 6. If time is not ending time, branch back to 2. -! ----------------------------------------------------------- -! -! Section 3. -! ---------------------------------------------------------- -! 3.1 Interpolate winds and currents. ( W3UCUR, W3DCXY ) -! ( W3UWND ) -! ( W3UINI ) -! 3.2 Update boundary conditions. ( W3IOBC, W3UBPT ) -! 3.3 Update ice coverage (if new ice map). ( W3UICE ) -! 3.4 Transform grid (if new water level). ( W3ULEV ) -! 3.5 Update maps and dirivatives. ( W3MAPn, W3DDXY ) -! ( W3NMIN, W3UTRN ) -! Update grid advection vector. -! 3.6 Perform propagation -! a Preparations. -! b Intra spectral part 1. ( W3KTPn ) -! c Longitude-latitude ( W3GATH, W3XYPn W3SCAT ) -! b Intra spectral part 2. ( W3KTPn ) -! 3.7 Calculate and integrate source terms. ( W3SRCE ) -! 3.8 Update global time step. -! ---------------------------------------------------------- -! -! 9. Switches : -! -! See module documentation. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ - USE W3GDATMD - USE W3WDATMD - USE W3ADATMD - USE W3IDATMD - USE W3ODATMD -!/ - USE W3UPDTMD - USE W3SRCEMD + ,ID_LCOMM, TIMEN & +#endif + ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) + !/ without output. + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) + !/ 23-Feb-2001 : Check for barrier after source + !/ terms added ( W3NMIN ). ( delayed version 2.07 ) + !/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) + !/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) + !/ 23-May-2001 : Barrier added for dry run, changed ( version 2.10 ) + !/ declaration of FLIWND. + !/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) + !/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) + !/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) + !/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) + !/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) + !/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 04-Feb-2005 : Add STAMP to par list. ( version 3.07 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) + !/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) + !/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) + !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) + !/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) + !/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) + !/ Improve MPI_WAITALL call tests/allocations. + !/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) + !/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) + !/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 31-Mar-2010 : Add reflections ( version 3.14.4 ) + !/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) + !/ (A. Roland and F. Ardhuin) + !/ 06-Mar-2011 : Output of max. CFL (F.Ardhuin) ( version 3.14.4 ) + !/ 05-Apr-2011 : Implement iteration for DTMAX <1s ( version 3.14.4 ) + !/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) + !/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) + !/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) + !/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) + !/ structure and smaller memory footprint. + !/ 16-Nov-2013 : Allows reflection on curvi. grids ( version 4.13 ) + !/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) + !/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) + !/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) + !/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) + !/ (M. Accensi & F. Ardhuin, IFREMER) + !/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.10 ) + !/ 31-Mar-2016 : Current option for smc grid. ( version 5.18 ) + !/ 06-Jun-2018 : Add PDLIB/MEMCHECK/SETUP/NETCDF_QAD/TIMING + !/ OASIS/DEBUGINIT/DEBUGSRC/DEBUGRUN/DEBUGCOH + !/ DEBUGIOBP/DEBUGIOBC ( version 6.04 ) + !/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) + !/ 25-Sep-2020 : Oasis coupling at T+0 ( version 7.10 ) + !/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) + !/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Run WAVEWATCH III for a given time interval. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! TEND I.A. I Ending time of integration. + ! STAMP Log. I WRITE(*,*)time stamp (optional, defaults to T). + ! NO_OUT Log. I Skip output (optional, defaults to F). + ! Skip at ending time only! + ! ---------------------------------------------------------------- + ! + ! Local parameters : Flags + ! ---------------------------------------------------------------- + ! FLOUTG Log. Flag for running W3OUTG. + ! FLPART Log. Flag for running W3CPRT. + ! FLZERO Log. Flag for zero time interval. + ! FLAG0 Log. Flag for processors without tasks. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program shell or integrated model which uses WAVEWATCH III. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Currents are updated before winds as currents are used in wind + ! and USTAR processing. + ! - Ice and water levels can be updated only once per call. + ! - If ice or water level time are undefined, the update + ! takes place asap, otherwise around the "half-way point" + ! betweem the old and new times. + ! - To increase accuracy, the calculation of the intra-spectral + ! propagation is performed in two parts around the spatial propagation. + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------- + ! 0. Initializations + ! a Point to data structures + ! b Subroutine tracing + ! c Local parameter initialization + ! d Test output + ! 1. Check the consistency of the input. + ! a Ending time versus initial time. + ! b Water level time. + ! c Current time interval. + ! d Wind time interval. + ! e Ice time. + ! 2. Determine next time from ending and output + ! time and get corresponding time step. + ! 3. Loop over time steps (see below). + ! 4. Perform output to file if requested. + ! a Check if time is output time. + ! b Processing and MPP preparations. ( W3CPRT, W3OUTG ) + ! c Reset next output time. + ! -------------- loop over output types ------------------ + ! d Perform output. ( W3IOxx ) + ! e Update next output time. + ! -------------------- end loop -------------------------- + ! 5. Update log file. + ! 6. If time is not ending time, branch back to 2. + ! ----------------------------------------------------------- + ! + ! Section 3. + ! ---------------------------------------------------------- + ! 3.1 Interpolate winds and currents. ( W3UCUR, W3DCXY ) + ! ( W3UWND ) + ! ( W3UINI ) + ! 3.2 Update boundary conditions. ( W3IOBC, W3UBPT ) + ! 3.3 Update ice coverage (if new ice map). ( W3UICE ) + ! 3.4 Transform grid (if new water level). ( W3ULEV ) + ! 3.5 Update maps and dirivatives. ( W3MAPn, W3DDXY ) + ! ( W3NMIN, W3UTRN ) + ! Update grid advection vector. + ! 3.6 Perform propagation + ! a Preparations. + ! b Intra spectral part 1. ( W3KTPn ) + ! c Longitude-latitude ( W3GATH, W3XYPn W3SCAT ) + ! b Intra spectral part 2. ( W3KTPn ) + ! 3.7 Calculate and integrate source terms. ( W3SRCE ) + ! 3.8 Update global time step. + ! ---------------------------------------------------------- + ! + ! 9. Switches : + ! + ! See module documentation. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + USE W3GDATMD + USE W3WDATMD + USE W3ADATMD + USE W3IDATMD + USE W3ODATMD + !/ + USE W3UPDTMD + USE W3SRCEMD #ifdef W3_PR1 - USE W3PRO1MD + USE W3PRO1MD #endif #ifdef W3_PR2 - USE W3PRO2MD + USE W3PRO2MD #endif #ifdef W3_PR3 - USE W3PRO3MD + USE W3PRO3MD #endif #ifdef W3_SMC - USE W3PSMCMD + USE W3PSMCMD #endif -! + ! #ifdef W3_PR1 - USE W3PROFSMD + USE W3PROFSMD #endif #ifdef W3_PR2 - USE W3PROFSMD + USE W3PROFSMD #endif #ifdef W3_PR3 - USE W3PROFSMD -#endif -!/ - USE W3TRIAMD - USE W3IOGRMD - USE W3IOGOMD - USE W3IOPOMD - USE W3IOTRMD - USE W3IORSMD - USE W3IOBCMD - USE W3IOSFMD + USE W3PROFSMD +#endif + !/ + USE W3TRIAMD + USE W3IOGRMD + USE W3IOGOMD + USE W3IOPOMD + USE W3IOTRMD + USE W3IORSMD + USE W3IOBCMD + USE W3IOSFMD #ifdef W3_PDLIB - USE PDLIB_W3PROFSMD, only : APPLY_BOUNDARY_CONDITION_VA - USE PDLIB_W3PROFSMD, only : PDLIB_W3XYPUG, PDLIB_W3XYPUG_BLOCK_IMPLICIT, PDLIB_W3XYPUG_BLOCK_EXPLICIT - USE PDLIB_W3PROFSMD, only : ALL_VA_INTEGRAL_PRINT, ALL_VAOLD_INTEGRAL_PRINT, ALL_FIELD_INTEGRAL_PRINT - USE W3PARALL, only : PDLIB_NSEAL, PDLIB_NSEALM - USE yowNodepool, only: npa, iplg, np -#endif -!/ - USE W3SERVMD - USE W3TIMEMD + USE PDLIB_W3PROFSMD, only : APPLY_BOUNDARY_CONDITION_VA + USE PDLIB_W3PROFSMD, only : PDLIB_W3XYPUG, PDLIB_W3XYPUG_BLOCK_IMPLICIT, PDLIB_W3XYPUG_BLOCK_EXPLICIT + USE PDLIB_W3PROFSMD, only : ALL_VA_INTEGRAL_PRINT, ALL_VAOLD_INTEGRAL_PRINT, ALL_FIELD_INTEGRAL_PRINT + USE W3PARALL, only : PDLIB_NSEAL, PDLIB_NSEALM + USE yowNodepool, only: npa, iplg, np +#endif + !/ + USE W3SERVMD + USE W3TIMEMD #ifdef W3_IC3 - USE W3SIC3MD + USE W3SIC3MD #endif #ifdef W3_IS2 - USE W3SIS2MD + USE W3SIS2MD #endif #ifdef W3_UOST - USE W3UOSTMD, ONLY: UOST_SETGRID + USE W3UOSTMD, ONLY: UOST_SETGRID #endif - USE W3PARALL, ONLY : INIT_GET_ISEA + USE W3PARALL, ONLY : INIT_GET_ISEA #ifdef W3_MEMCHECK - USE MallocInfo_m + USE MallocInfo_m #endif #ifdef W3_SETUP - USE W3WAVSET, only : WAVE_SETUP_COMPUTATION + USE W3WAVSET, only : WAVE_SETUP_COMPUTATION #endif #ifdef W3_OASIS - USE W3OACPMD, ONLY: ID_OASIS_TIME, CPLT0 + USE W3OACPMD, ONLY: ID_OASIS_TIME, CPLT0 #endif #ifdef W3_OASOCM - USE W3OGCMMD, ONLY: SND_FIELDS_TO_OCEAN + USE W3OGCMMD, ONLY: SND_FIELDS_TO_OCEAN #endif #ifdef W3_OASACM - USE W3AGCMMD, ONLY: SND_FIELDS_TO_ATMOS + USE W3AGCMMD, ONLY: SND_FIELDS_TO_ATMOS #endif #ifdef W3_OASICM - USE W3IGCMMD, ONLY: SND_FIELDS_TO_ICE + USE W3IGCMMD, ONLY: SND_FIELDS_TO_ICE #endif #ifdef W3_PDLIB - USE PDLIB_FIELD_VEC, only : DO_OUTPUT_EXCHANGES - USE PDLIB_W3PROFSMD, ONLY: ASPAR_JAC, ASPAR_DIAG_ALL, B_JAC - USE W3PARALL, only : LSLOC + USE PDLIB_FIELD_VEC, only : DO_OUTPUT_EXCHANGES + USE PDLIB_W3PROFSMD, ONLY: ASPAR_JAC, ASPAR_DIAG_ALL, B_JAC + USE W3PARALL, only : LSLOC #endif #ifdef W3_TIMINGS USE W3PARALL, only : PRINT_MY_TIME #endif - use w3iogoncdmd , only : w3iogoncd - use w3odatmd , only : histwr, rstwr, user_netcdf_grdout -! -! + use w3iogoncdmd , only : w3iogoncd + use w3odatmd , only : histwr, rstwr, user_netcdf_grdout + ! + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, TEND(2),ODAT(35) - LOGICAL, INTENT(IN), OPTIONAL :: STAMP, NO_OUT + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, TEND(2),ODAT(35) + LOGICAL, INTENT(IN), OPTIONAL :: STAMP, NO_OUT #ifdef W3_OASIS - INTEGER, INTENT(IN), OPTIONAL :: ID_LCOMM - INTEGER, INTENT(IN), OPTIONAL :: TIMEN(2) + INTEGER, INTENT(IN), OPTIONAL :: ID_LCOMM + INTEGER, INTENT(IN), OPTIONAL :: TIMEN(2) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters : -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters : + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER :: IP - INTEGER :: TCALC(2), IT, IT0, NT, ITEST, & - ITLOC, ITLOCH, NTLOC, ISEA, JSEA, & - IX, IY, ISPEC, J, TOUT(2), TLST(2), & - REFLED(6), IK, ITH, IS, NKCFL - INTEGER :: ISP, IP_glob - INTEGER :: TTEST(2),DTTEST - REAL :: ICEDAVE -! - LOGICAL :: SBSED + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER :: IP + INTEGER :: TCALC(2), IT, IT0, NT, ITEST, & + ITLOC, ITLOCH, NTLOC, ISEA, JSEA, & + IX, IY, ISPEC, J, TOUT(2), TLST(2), & + REFLED(6), IK, ITH, IS, NKCFL + INTEGER :: ISP, IP_glob + INTEGER :: TTEST(2),DTTEST + REAL :: ICEDAVE + ! + LOGICAL :: SBSED #ifdef W3_SEC1 - INTEGER :: ISEC1 + INTEGER :: ISEC1 #endif - INTEGER :: JJ, NDSOFLG + INTEGER :: JJ, NDSOFLG #ifdef W3_MPI - INTEGER :: IERR_MPI, NRQMAX - INTEGER, ALLOCATABLE :: STATCO(:,:), STATIO(:,:) -#endif - INTEGER :: IXrel - REAL :: DTTST, DTTST1, DTTST2, DTTST3, & - DTL0, DTI0, DTR0, DTI10, DTI50, & - DTGA, DTG, DTGpre, DTRES, & - FAC, VGX, VGY, FACK, FACTH, & - FACX, XXX, REFLEC(4), & - DELX, DELY, DELA, DEPTH, D50, PSIC - REAL :: VSioDummy(NSPEC), VDioDummy(NSPEC), VAoldDummy(NSPEC) - LOGICAL :: SHAVETOTioDummy + INTEGER :: IERR_MPI, NRQMAX + INTEGER, ALLOCATABLE :: STATCO(:,:), STATIO(:,:) +#endif + INTEGER :: IXrel + REAL :: DTTST, DTTST1, DTTST2, DTTST3, & + DTL0, DTI0, DTR0, DTI10, DTI50, & + DTGA, DTG, DTGpre, DTRES, & + FAC, VGX, VGY, FACK, FACTH, & + FACX, XXX, REFLEC(4), & + DELX, DELY, DELA, DEPTH, D50, PSIC + REAL :: VSioDummy(NSPEC), VDioDummy(NSPEC), VAoldDummy(NSPEC) + LOGICAL :: SHAVETOTioDummy #ifdef W3_SEC1 - REAL :: DTGTEMP + REAL :: DTGTEMP #endif -! - REAL, ALLOCATABLE :: FIELD(:) - REAL :: TMP1(4), TMP2(3), TMP3(2), TMP4(2) + ! + REAL, ALLOCATABLE :: FIELD(:) + REAL :: TMP1(4), TMP2(3), TMP3(2), TMP4(2) #ifdef W3_IC3 - REAL, ALLOCATABLE :: WN_I(:) + REAL, ALLOCATABLE :: WN_I(:) #endif #ifdef W3_REFRX - REAL, ALLOCATABLE :: CIK(:) -#endif -! -! Orphaned arrays from old data structure -! - REAL, ALLOCATABLE :: TAUWX(:), TAUWY(:) -! - LOGICAL :: FLACT, FLZERO, FLFRST, FLMAP, TSTAMP,& - SKIP_O, FLAG_O, FLDDIR, READBC, & - FLAG0 = .FALSE., FLOUTG, FLPFLD, & - FLPART, LOCAL, FLOUTG2 -! + REAL, ALLOCATABLE :: CIK(:) +#endif + ! + ! Orphaned arrays from old data structure + ! + REAL, ALLOCATABLE :: TAUWX(:), TAUWY(:) + ! + LOGICAL :: FLACT, FLZERO, FLFRST, FLMAP, TSTAMP,& + SKIP_O, FLAG_O, FLDDIR, READBC, & + FLAG0 = .FALSE., FLOUTG, FLPFLD, & + FLPART, LOCAL, FLOUTG2 + ! #ifdef W3_MPI - LOGICAL :: FLGMPI(0:8) + LOGICAL :: FLGMPI(0:8) #endif #ifdef W3_IC3 - REAL :: FIXEDVISC,FIXEDDENS,FIXEDELAS - REAL :: USE_CHENG, USE_CGICE, HICE -#endif - LOGICAL :: UGDTUPDATE ! true if time step should be updated for UG schemes - CHARACTER(LEN=8) :: STTIME - CHARACTER(LEN=21) :: IDACT - CHARACTER(LEN=16) :: OUTID - CHARACTER(LEN=23) :: IDTIME - INTEGER eIOBP - INTEGER ITH_F + REAL :: FIXEDVISC,FIXEDDENS,FIXEDELAS + REAL :: USE_CHENG, USE_CGICE, HICE +#endif + LOGICAL :: UGDTUPDATE ! true if time step should be updated for UG schemes + CHARACTER(LEN=8) :: STTIME + CHARACTER(LEN=21) :: IDACT + CHARACTER(LEN=16) :: OUTID + CHARACTER(LEN=23) :: IDTIME + INTEGER eIOBP + INTEGER ITH_F #ifdef W3_PDLIB - REAL :: VS_SPEC(NSPEC) - REAL :: VD_SPEC(NSPEC) + REAL :: VS_SPEC(NSPEC) + REAL :: VD_SPEC(NSPEC) #endif -! - CHARACTER(LEN=30) :: FOUTNAME -! + ! + CHARACTER(LEN=30) :: FOUTNAME + ! #ifdef W3_T - REAL :: INDSORT(NSEA), DTCFL1(NSEA) + REAL :: INDSORT(NSEA), DTCFL1(NSEA) #endif -!/ + !/ #ifdef W3_SMC - !Li Temperature spectra for Arctic boundary update. - REAL, ALLOCATABLE :: BACSPEC(:) - REAL :: BACANGL + !Li Temperature spectra for Arctic boundary update. + REAL, ALLOCATABLE :: BACSPEC(:) + REAL :: BACANGL #endif - ! locally defined flags + ! locally defined flags #ifdef W3_SBS - logical, parameter :: w3_sbs_flag = .true. + logical, parameter :: w3_sbs_flag = .true. #else - logical, parameter :: w3_sbs_flag = .false. + logical, parameter :: w3_sbs_flag = .false. #endif #ifdef W3_CESMCOUPLED - logical, parameter :: w3_cesmcoupled_flag = .true. + logical, parameter :: w3_cesmcoupled_flag = .true. #else - logical, parameter :: w3_cesmcoupled_flag = .false. -#endif - integer :: memunit - logical :: do_gridded_output - logical :: do_point_output - logical :: do_track_output - logical :: do_restart_output - logical :: do_sf_output - logical :: do_coupler_output - logical :: do_wavefield_separation_output - logical :: do_startall - logical :: do_w3outg - -!/ ------------------------------------------------------------------- / -! 0. Initializations -! - XXX = undef - memunit = 40000+iaproc + logical, parameter :: w3_cesmcoupled_flag = .false. +#endif + integer :: memunit + logical :: do_gridded_output + logical :: do_point_output + logical :: do_track_output + logical :: do_restart_output + logical :: do_sf_output + logical :: do_coupler_output + logical :: do_wavefield_separation_output + logical :: do_startall + logical :: do_w3outg + + !/ ------------------------------------------------------------------- / + ! 0. Initializations + ! + XXX = undef + memunit = 40000+iaproc + ! 0.a Set pointers to data structure + ! #ifdef W3_COU - SCREEN = 333 -#endif -! - IF ( IOUTP .NE. IMOD ) CALL W3SETO ( IMOD, NDSE, NDST ) - IF ( IGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) - IF ( IWDATA .NE. IMOD ) CALL W3SETW ( IMOD, NDSE, NDST ) - IF ( IADATA .NE. IMOD ) CALL W3SETA ( IMOD, NDSE, NDST ) - IF ( IIDATA .NE. IMOD ) CALL W3SETI ( IMOD, NDSE, NDST ) + SCREEN = 333 +#endif + ! + IF ( IOUTP .NE. IMOD ) CALL W3SETO ( IMOD, NDSE, NDST ) + IF ( IGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + IF ( IWDATA .NE. IMOD ) CALL W3SETW ( IMOD, NDSE, NDST ) + IF ( IADATA .NE. IMOD ) CALL W3SETA ( IMOD, NDSE, NDST ) + IF ( IIDATA .NE. IMOD ) CALL W3SETI ( IMOD, NDSE, NDST ) #ifdef W3_UOST - CALL UOST_SETGRID(IMOD) + CALL UOST_SETGRID(IMOD) #endif #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 1", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 1", 1) #endif -! - ALLOCATE(TAUWX(NSEAL), TAUWY(NSEAL)) + ! + ALLOCATE(TAUWX(NSEAL), TAUWY(NSEAL)) #ifdef W3_REFRX - ALLOCATE(CIK(NSEAL)) -#endif -! - IF ( PRESENT(STAMP) ) THEN - TSTAMP = STAMP - ELSE - TSTAMP = .TRUE. - END IF -! - IF ( PRESENT(NO_OUT) ) THEN - SKIP_O = NO_OUT - ELSE - SKIP_O = .FALSE. - END IF + ALLOCATE(CIK(NSEAL)) +#endif + ! + IF ( PRESENT(STAMP) ) THEN + TSTAMP = STAMP + ELSE + TSTAMP = .TRUE. + END IF + ! + IF ( PRESENT(NO_OUT) ) THEN + SKIP_O = NO_OUT + ELSE + SKIP_O = .FALSE. + END IF #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 2", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 2", 1) #endif -! -! 0.b Subroutine tracing -! + ! + ! 0.b Subroutine tracing + ! #ifdef W3_S - CALL STRACE (IENT, 'W3WAVE') -#endif -! -! -! 0.c Local parameter initialization -! - IPASS = IPASS + 1 - IDACT = ' ' - OUTID = ' ' - FLACT = ITIME .EQ. 0 - FLMAP = ITIME .EQ. 0 - FLDDIR = ITIME .EQ. 0 .AND. ( FLCTH .OR. FSREFRACTION .OR. FLCK .OR. FSFREQSHIFT ) -! - FLPFLD = .FALSE. - DO J=1,NOGE(4) - FLPFLD = FLPFLD .OR. FLOGRD(4,J) .OR. FLOGR2(4,J) - END DO -! - IF ( IAPROC .EQ. NAPLOG ) BACKSPACE ( NDSO ) -! - IF ( FLCOLD ) THEN - DTDYN = 0. - FCUT = SIG(NK) * TPIINV - END IF -! - IF( GTYPE .EQ. SMCTYPE ) THEN - J = 1 + CALL STRACE (IENT, 'W3WAVE') +#endif + ! + ! + ! 0.c Local parameter initialization + ! + IPASS = IPASS + 1 + IDACT = ' ' + OUTID = ' ' + FLACT = ITIME .EQ. 0 + FLMAP = ITIME .EQ. 0 + FLDDIR = ITIME .EQ. 0 .AND. ( FLCTH .OR. FSREFRACTION .OR. FLCK .OR. FSFREQSHIFT ) + ! + FLPFLD = .FALSE. + DO J=1,NOGE(4) + FLPFLD = FLPFLD .OR. FLOGRD(4,J) .OR. FLOGR2(4,J) + END DO + ! + IF ( IAPROC .EQ. NAPLOG ) BACKSPACE ( NDSO ) + ! + IF ( FLCOLD ) THEN + DTDYN = 0. + FCUT = SIG(NK) * TPIINV + END IF + ! + IF( GTYPE .EQ. SMCTYPE ) THEN + J = 1 #ifdef W3_SMC - !!Li Use sea point only field for SMC grid. - ALLOCATE ( FIELD(NCel) ) -#endif - ELSE - ALLOCATE ( FIELD(1-NY:NY*(NX+2)) ) - ENDIF -! - LOCAL = IAPROC .LE. NAPROC - UGDTUPDATE = .FALSE. - IF (FLAGLL) THEN - FACX = 1./(DERA * RADIUS) - ELSE - FACX = 1. - END IF -! - SBSED = .FALSE. - if (w3_sbs_flag) then - NDSOFLG = 99 - SBSED = .TRUE. - end if - -! - TAUWX = 0. - TAUWY = 0. -! -! 0.d Test output -! + !!Li Use sea point only field for SMC grid. + ALLOCATE ( FIELD(NCel) ) +#endif + ELSE + ALLOCATE ( FIELD(1-NY:NY*(NX+2)) ) + ENDIF + ! + LOCAL = IAPROC .LE. NAPROC + UGDTUPDATE = .FALSE. + IF (FLAGLL) THEN + FACX = 1./(DERA * RADIUS) + ELSE + FACX = 1. + END IF + ! + SBSED = .FALSE. + if (w3_sbs_flag) then + NDSOFLG = 99 + SBSED = .TRUE. + end if + + ! + TAUWX = 0. + TAUWY = 0. + ! + ! 0.d Test output + ! #ifdef W3_T - WRITE (NDST,9000) IMOD, trim(FILEXT), TEND -#endif -! -! 1. Check the consistency of the input ----------------------------- / -! 1.a Ending time versus initial time -! - DTTST = DSEC21 ( TIME , TEND ) - FLZERO = DTTST .EQ. 0. + WRITE (NDST,9000) IMOD, trim(FILEXT), TEND +#endif + ! + ! 1. Check the consistency of the input ----------------------------- / + ! 1.a Ending time versus initial time + ! + DTTST = DSEC21 ( TIME , TEND ) + FLZERO = DTTST .EQ. 0. #ifdef W3_T - WRITE (NDST,9010) DTTST, FLZERO -#endif - IF ( DTTST .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) - CALL EXTCDE ( 1 ) - END IF -! -! 1.b Water level time -! - IF ( FLLEV ) THEN - IF ( TLEV(1) .GE. 0. ) THEN - DTL0 = DSEC21 ( TLEV , TLN ) - ELSE - DTL0 = 1. - END IF + WRITE (NDST,9010) DTTST, FLZERO +#endif + IF ( DTTST .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) + CALL EXTCDE ( 1 ) + END IF + ! + ! 1.b Water level time + ! + IF ( FLLEV ) THEN + IF ( TLEV(1) .GE. 0. ) THEN + DTL0 = DSEC21 ( TLEV , TLN ) + ELSE + DTL0 = 1. + END IF #ifdef W3_T - WRITE (NDST,9011) DTL0 + WRITE (NDST,9011) DTL0 #endif - IF ( DTL0 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) - CALL EXTCDE ( 2 ) - END IF - ELSE - DTL0 = 0. - END IF + IF ( DTL0 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) + CALL EXTCDE ( 2 ) + END IF + ELSE + DTL0 = 0. + END IF #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 4", 1) -#endif -! -! 1.c Current interval -! - IF ( FLCUR ) THEN - DTTST1 = DSEC21 ( TC0 , TCN ) - DTTST2 = DSEC21 ( TC0 , TIME ) - DTTST3 = DSEC21 ( TEND , TCN ) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 4", 1) +#endif + ! + ! 1.c Current interval + ! + IF ( FLCUR ) THEN + DTTST1 = DSEC21 ( TC0 , TCN ) + DTTST2 = DSEC21 ( TC0 , TIME ) + DTTST3 = DSEC21 ( TEND , TCN ) #ifdef W3_T - WRITE (NDST,9012) DTTST1, DTTST2, DTTST3 + WRITE (NDST,9012) DTTST1, DTTST2, DTTST3 #endif - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) - CALL EXTCDE ( 3 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(7:7) = 'F' - TOFRST = TIME - END IF - END IF -! -! 1.d Wind interval -! - IF ( FLWIND ) THEN - DTTST1 = DSEC21 ( TW0 , TWN ) - DTTST2 = DSEC21 ( TW0 , TIME ) - DTTST3 = DSEC21 ( TEND , TWN ) + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) + CALL EXTCDE ( 3 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(7:7) = 'F' + TOFRST = TIME + END IF + END IF + ! + ! 1.d Wind interval + ! + IF ( FLWIND ) THEN + DTTST1 = DSEC21 ( TW0 , TWN ) + DTTST2 = DSEC21 ( TW0 , TIME ) + DTTST3 = DSEC21 ( TEND , TWN ) #ifdef W3_T - WRITE (NDST,9013) DTTST1, DTTST2, DTTST3 + WRITE (NDST,9013) DTTST1, DTTST2, DTTST3 #endif - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) - CALL EXTCDE ( 4 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(3:3) = 'F' - TOFRST = TIME - END IF - END IF + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) + CALL EXTCDE ( 4 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(3:3) = 'F' + TOFRST = TIME + END IF + END IF #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 5", 1) -#endif -! -! 1.e Ice concentration interval -! - IF ( FLICE ) THEN - IF ( TICE(1) .GE. 0 ) THEN - DTI0 = DSEC21 ( TICE , TIN ) - ELSE - DTI0 = 1. - END IF + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 5", 1) +#endif + ! + ! 1.e Ice concentration interval + ! + IF ( FLICE ) THEN + IF ( TICE(1) .GE. 0 ) THEN + DTI0 = DSEC21 ( TICE , TIN ) + ELSE + DTI0 = 1. + END IF #ifdef W3_T - WRITE (NDST,9014) DTI0 + WRITE (NDST,9014) DTI0 #endif - IF ( DTI0 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1004) - CALL EXTCDE ( 5 ) - END IF - ELSE - DTI0 = 0. - END IF + IF ( DTI0 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1004) + CALL EXTCDE ( 5 ) + END IF + ELSE + DTI0 = 0. + END IF #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6", 1) -#endif -! -! 1.f Momentum interval -! - IF ( FLTAUA ) THEN - DTTST1 = DSEC21 ( TU0 , TUN ) - DTTST2 = DSEC21 ( TU0 , TIME ) - DTTST3 = DSEC21 ( TEND , TUN ) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6", 1) +#endif + ! + ! 1.f Momentum interval + ! + IF ( FLTAUA ) THEN + DTTST1 = DSEC21 ( TU0 , TUN ) + DTTST2 = DSEC21 ( TU0 , TIME ) + DTTST3 = DSEC21 ( TEND , TUN ) #ifdef W3_T - WRITE (NDST,9017) DTTST1, DTTST2, DTTST3 + WRITE (NDST,9017) DTTST1, DTTST2, DTTST3 #endif - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1007) - CALL EXTCDE ( 3 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(9:9) = 'F' - TOFRST = TIME - END IF - END IF -! -! 1.g Air density time -! - IF ( FLRHOA ) THEN - DTTST1 = DSEC21 ( TR0 , TRN ) - DTTST2 = DSEC21 ( TR0 , TIME ) - DTTST3 = DSEC21 ( TEND , TRN ) + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1007) + CALL EXTCDE ( 3 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(9:9) = 'F' + TOFRST = TIME + END IF + END IF + ! + ! 1.g Air density time + ! + IF ( FLRHOA ) THEN + DTTST1 = DSEC21 ( TR0 , TRN ) + DTTST2 = DSEC21 ( TR0 , TIME ) + DTTST3 = DSEC21 ( TEND , TRN ) #ifdef W3_T - WRITE (NDST,9018) DTTST1, DTTST2, DTTST3 + WRITE (NDST,9018) DTTST1, DTTST2, DTTST3 #endif - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1008) - CALL EXTCDE ( 2 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(11:11) = 'F' - TOFRST = TIME - END IF - END IF -! -! 1.e Ice thickness interval -! - IF ( FLIC1 ) THEN - IF ( TIC1(1) .GE. 0 ) THEN - DTI10 = DSEC21 ( TIC1 , TI1 ) - ELSE - DTI10 = 1. - END IF + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1008) + CALL EXTCDE ( 2 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(11:11) = 'F' + TOFRST = TIME + END IF + END IF + ! + ! 1.e Ice thickness interval + ! + IF ( FLIC1 ) THEN + IF ( TIC1(1) .GE. 0 ) THEN + DTI10 = DSEC21 ( TIC1 , TI1 ) + ELSE + DTI10 = 1. + END IF #ifdef W3_T - WRITE (NDST,9015) DTI10 + WRITE (NDST,9015) DTI10 #endif - IF ( DTI10 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1005) - CALL EXTCDE ( 5 ) - END IF - ELSE - DTI10 = 0. - END IF -! -! 1.e Ice floe interval -! + IF ( DTI10 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1005) + CALL EXTCDE ( 5 ) + END IF + ELSE + DTI10 = 0. + END IF + ! + ! 1.e Ice floe interval + ! #ifdef W3_IS2 - IF ( FLIC5 ) THEN - IF ( TIC5(1) .GE. 0 ) THEN - DTI50 = DSEC21 ( TIC5 , TI5 ) - ELSE - DTI50 = 1. - END IF + IF ( FLIC5 ) THEN + IF ( TIC5(1) .GE. 0 ) THEN + DTI50 = DSEC21 ( TIC5 , TI5 ) + ELSE + DTI50 = 1. + END IF #ifdef W3_T - WRITE (NDST,9016) DTI50 -#endif - IF ( DTI50 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006) - CALL EXTCDE ( 5 ) - END IF - ELSE - DTI50 = 0. - END IF + WRITE (NDST,9016) DTI50 #endif -! -! 2. Determine next time from ending and output --------------------- / -! time and get corresponding time step. -! - FLFRST = .TRUE. - DO + IF ( DTI50 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006) + CALL EXTCDE ( 5 ) + END IF + ELSE + DTI50 = 0. + END IF +#endif + ! + ! 2. Determine next time from ending and output --------------------- / + ! time and get corresponding time step. + ! + FLFRST = .TRUE. + DO #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("First entry in the TIME LOOP") -#endif -! DO JSEA = 1, NSEAL -! DO IS = 1, NSPEC -! IF (VA(IS, JSEA) .LT. 0.) THEN -! WRITE(740+IAPROC,*) 'TEST W3WAVE 2', VA(IS,JSEA) -! CALL FLUSH(740+IAPROC) -! ENDIF -! ENDDO -! ENDDO -! IF (SUM(VA) .NE. SUM(VA)) THEN -! WRITE(740+IAPROC,*) 'NAN in ACTION 2', IX, IY, SUM(VA) -! CALL FLUSH(740+IAPROC) -! STOP -! ENDIF + CALL PRINT_MY_TIME("First entry in the TIME LOOP") +#endif + ! DO JSEA = 1, NSEAL + ! DO IS = 1, NSPEC + ! IF (VA(IS, JSEA) .LT. 0.) THEN + ! WRITE(740+IAPROC,*) 'TEST W3WAVE 2', VA(IS,JSEA) + ! CALL FLUSH(740+IAPROC) + ! ENDIF + ! ENDDO + ! ENDDO + ! IF (SUM(VA) .NE. SUM(VA)) THEN + ! WRITE(740+IAPROC,*) 'NAN in ACTION 2', IX, IY, SUM(VA) + ! CALL FLUSH(740+IAPROC) + ! STOP + ! ENDIF #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6.1", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6.1", 1) #endif -! -! -! 2.a Pre-calculate table for IC3 ------------------------------------ / + ! + ! + ! 2.a Pre-calculate table for IC3 ------------------------------------ / #ifdef W3_IC3 - USE_CHENG=IC3PARS(9) - IF( USE_CHENG==1.0 )THEN - FIXEDVISC=IC3PARS(14) - FIXEDDENS=IC3PARS(15) - FIXEDELAS=IC3PARS(16) - IF ( (FIXEDVISC.LT.0.0).OR.(FIXEDDENS.LT.0.0) .OR. (FIXEDELAS.LT.0.0) ) THEN - IF ( IAPROC .EQ. NAPERR ) & + USE_CHENG=IC3PARS(9) + IF( USE_CHENG==1.0 )THEN + FIXEDVISC=IC3PARS(14) + FIXEDDENS=IC3PARS(15) + FIXEDELAS=IC3PARS(16) + IF ( (FIXEDVISC.LT.0.0).OR.(FIXEDDENS.LT.0.0) .OR. (FIXEDELAS.LT.0.0) ) THEN + IF ( IAPROC .EQ. NAPERR ) & WRITE(NDSE,*)'Cheng method requires stationary', & - ' and uniform rheology from namelist.' - CALL EXTCDE(2) - END IF - IF (CALLEDIC3TABLE==0) THEN - CALL IC3TABLE_CHENG(FIXEDVISC,FIXEDDENS,FIXEDELAS) - CALLEDIC3TABLE = 1 - ENDIF + ' and uniform rheology from namelist.' + CALL EXTCDE(2) + END IF + IF (CALLEDIC3TABLE==0) THEN + CALL IC3TABLE_CHENG(FIXEDVISC,FIXEDDENS,FIXEDELAS) + CALLEDIC3TABLE = 1 ENDIF + ENDIF #endif -! 2.b Update group velocity and wavenumber from ice parameters ------- / -! from W3SIC3MD module. ------------------------------------------ / -! Note: "IF FLFRST" can be added for efficiency, but testing req'd + ! 2.b Update group velocity and wavenumber from ice parameters ------- / + ! from W3SIC3MD module. ------------------------------------------ / + ! Note: "IF FLFRST" can be added for efficiency, but testing req'd - JSEA=1 ! no switch (intentional) + JSEA=1 ! no switch (intentional) #ifdef W3_IC3 - USE_CGICE=IC3PARS(12) - IF ( USE_CGICE==1.0 ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE(SCREEN,920) + USE_CGICE=IC3PARS(12) + IF ( USE_CGICE==1.0 ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE(SCREEN,920) #endif #ifdef W3_IC3 - DO JSEA=1,NSEAL + DO JSEA=1,NSEAL #endif #ifdef W3_DIST - ISEA = IAPROC + (JSEA-1)*NAPROC + ISEA = IAPROC + (JSEA-1)*NAPROC #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif #ifdef W3_IC3 - ALLOCATE(WN_I(SIZE(WN(:,ISEA)))) - WN_I(:) = 0. - DEPTH = MAX( DMIN , DW(ISEA) ) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + ALLOCATE(WN_I(SIZE(WN(:,ISEA)))) + WN_I(:) = 0. + DEPTH = MAX( DMIN , DW(ISEA) ) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) #endif -! 2.b.1 Using Cheng method: requires stationary/uniform rheology. -! However, ice thickness may be input by either method + ! 2.b.1 Using Cheng method: requires stationary/uniform rheology. + ! However, ice thickness may be input by either method #ifdef W3_IC3 - IF ( USE_CHENG==1.0 ) THEN - IF (FLIC1) THEN - HICE=ICEP1(IX,IY) - ELSEIF (IC3PARS(13).GE.0.0)THEN - HICE=IC3PARS(13) - ELSE - IF ( IAPROC .EQ. NAPERR ) & - WRITE(NDSE,*)'ICE THICKNESS NOT AVAILABLE ', & - 'FOR CG CALC' - CALL EXTCDE(2) - ENDIF - IF (HICE > 0.0) THEN ! non-zero ice - CALL W3IC3WNCG_CHENG(WN(:,ISEA),WN_I(:), & - CG(:,ISEA),HICE,FIXEDVISC, & - FIXEDDENS, FIXEDELAS, DEPTH) - END IF ! non-zero ice + IF ( USE_CHENG==1.0 ) THEN + IF (FLIC1) THEN + HICE=ICEP1(IX,IY) + ELSEIF (IC3PARS(13).GE.0.0)THEN + HICE=IC3PARS(13) + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE(NDSE,*)'ICE THICKNESS NOT AVAILABLE ', & + 'FOR CG CALC' + CALL EXTCDE(2) + ENDIF + IF (HICE > 0.0) THEN ! non-zero ice + CALL W3IC3WNCG_CHENG(WN(:,ISEA),WN_I(:), & + CG(:,ISEA),HICE,FIXEDVISC, & + FIXEDDENS, FIXEDELAS, DEPTH) + END IF ! non-zero ice #endif #ifdef W3_IC3 - ELSE ! not using Cheng method + ELSE ! not using Cheng method #endif -! 2.b.2 If not using Cheng method: require FLIC1 to FLIC4 (not strictly -! necesssary, but makes code simpler) + ! 2.b.2 If not using Cheng method: require FLIC1 to FLIC4 (not strictly + ! necesssary, but makes code simpler) #ifdef W3_IC3 - IF (FLIC1.AND.FLIC2.AND.FLIC3.AND.FLIC4) THEN - IF (ICEP1(IX,IY)>0.0) THEN ! non-zero ice - CALL W3IC3WNCG_V1(WN(:,ISEA),WN_I(:), & - CG(:,ISEA),ICEP1(IX,IY),ICEP2(IX,IY), & - ICEP3(IX,IY),ICEP4(IX,IY),DEPTH) - END IF ! non-zero ice - ELSE - IF ( IAPROC .EQ. NAPERR ) & - WRITE(NDSE,*)'ICE PARAMETERS NOT AVAILABLE ', & - 'FOR CG CALC' - CALL EXTCDE(2) - END IF - ENDIF ! IF USE_CHENG... + IF (FLIC1.AND.FLIC2.AND.FLIC3.AND.FLIC4) THEN + IF (ICEP1(IX,IY)>0.0) THEN ! non-zero ice + CALL W3IC3WNCG_V1(WN(:,ISEA),WN_I(:), & + CG(:,ISEA),ICEP1(IX,IY),ICEP2(IX,IY), & + ICEP3(IX,IY),ICEP4(IX,IY),DEPTH) + END IF ! non-zero ice + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE(NDSE,*)'ICE PARAMETERS NOT AVAILABLE ', & + 'FOR CG CALC' + CALL EXTCDE(2) + END IF + ENDIF ! IF USE_CHENG... #endif #ifdef W3_IC3 - DEALLOCATE(WN_I) - END DO ! DO JSEA=1,NSEAL - END IF ! IF USE_CGICE ... + DEALLOCATE(WN_I) + END DO ! DO JSEA=1,NSEAL + END IF ! IF USE_CGICE ... #endif -! - IF ( TOFRST(1) .GT. 0 ) THEN - DTTST = DSEC21 ( TEND , TOFRST ) - ELSE - DTTST = 0. - ENDIF -! - IF ( DTTST.GE.0. ) THEN - TCALC = TEND - ELSE - TCALC = TOFRST - END IF -! - DTTST = DSEC21 ( TIME , TCALC ) - NT = 1 + INT ( DTTST / DTMAX - 0.001 ) - DTGA = DTTST / REAL(NT) - IF ( DTTST .EQ. 0. ) THEN - IT0 = 0 - IF ( .NOT.FLZERO ) ITIME = ITIME - 1 - NT = 0 - ELSE - IT0 = 1 - END IF + ! + IF ( TOFRST(1) .GT. 0 ) THEN + DTTST = DSEC21 ( TEND , TOFRST ) + ELSE + DTTST = 0. + ENDIF + ! + IF ( DTTST.GE.0. ) THEN + TCALC = TEND + ELSE + TCALC = TOFRST + END IF + ! + DTTST = DSEC21 ( TIME , TCALC ) + NT = 1 + INT ( DTTST / DTMAX - 0.001 ) + DTGA = DTTST / REAL(NT) + IF ( DTTST .EQ. 0. ) THEN + IT0 = 0 + IF ( .NOT.FLZERO ) ITIME = ITIME - 1 + NT = 0 + ELSE + IT0 = 1 + END IF #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif -! + ! #ifdef W3_T - WRITE (NDST,9020) IT0, NT, DTGA + WRITE (NDST,9020) IT0, NT, DTGA #endif -! -! ==================================================================== / -! -! 3. Loop over time steps -! - DTRES = 0. + ! + ! ==================================================================== / + ! + ! 3. Loop over time steps + ! + DTRES = 0. -! - DO IT = IT0, NT + ! + DO IT = IT0, NT #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Begin of IT loop") + CALL PRINT_MY_TIME("Begin of IT loop") #endif #ifdef W3_SETUP - CALL WAVE_SETUP_COMPUTATION + CALL WAVE_SETUP_COMPUTATION #endif -! copy old values + ! copy old values #ifdef W3_PDLIB - DO IP=1,NSEAL - DO ISPEC=1,NSPEC - VAOLD(ISPEC,IP)=VA(ISPEC,IP) - END DO - END DO + DO IP=1,NSEAL + DO ISPEC=1,NSPEC + VAOLD(ISPEC,IP)=VA(ISPEC,IP) + END DO + END DO #endif -! + ! #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Beginning time loop", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Beginning time loop", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After assigning VAOLD") + CALL PRINT_MY_TIME("After assigning VAOLD") #endif -! + ! #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 0' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! - ITIME = ITIME + 1 -! - DTG = REAL(NINT(DTGA+DTRES+0.0001)) - DTRES = DTRES + DTGA - DTG - IF ( ABS(DTRES) .LT. 0.001 ) DTRES = 0. - CALL TICK21 ( TIME , DTG ) -! + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 0' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + ! + ITIME = ITIME + 1 + ! + DTG = REAL(NINT(DTGA+DTRES+0.0001)) + DTRES = DTRES + DTGA - DTG + IF ( ABS(DTRES) .LT. 0.001 ) DTRES = 0. + CALL TICK21 ( TIME , DTG ) + ! #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 1' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif - IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN - CALL WWTIME ( STTIME ) - CALL STME21 ( TIME , IDTIME ) - WRITE (SCREEN,950) IDTIME, STTIME - END IF + IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN + CALL WWTIME ( STTIME ) + CALL STME21 ( TIME , IDTIME ) + WRITE (SCREEN,950) IDTIME, STTIME + END IF #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 2' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -! - VGX = 0. - VGY = 0. - IF(INFLAGS1(10)) THEN - DTTST1 = DSEC21 ( TIME, TGN ) - DTTST2 = DSEC21 ( TG0, TGN ) - FAC = DTTST1 / MAX ( 1. , DTTST2 ) - VGX = (FAC*GA0+(1.-FAC)*GAN) * & - COS(FAC*GD0+(1.-FAC)*GDN) - VGY = (FAC*GA0+(1.-FAC)*GAN) * & - SIN(FAC*GD0+(1.-FAC)*GDN) - END IF + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + + ! + VGX = 0. + VGY = 0. + IF(INFLAGS1(10)) THEN + DTTST1 = DSEC21 ( TIME, TGN ) + DTTST2 = DSEC21 ( TG0, TGN ) + FAC = DTTST1 / MAX ( 1. , DTTST2 ) + VGX = (FAC*GA0+(1.-FAC)*GAN) * & + COS(FAC*GD0+(1.-FAC)*GDN) + VGY = (FAC*GA0+(1.-FAC)*GAN) * & + SIN(FAC*GD0+(1.-FAC)*GDN) + END IF #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After VGX/VGY assignation") + CALL PRINT_MY_TIME("After VGX/VGY assignation") #endif -! + ! #ifdef W3_T WRITE (NDST,9021) ITIME, IT, TIME, FLMAP, FLDDIR, VGX, VGY, DTG, DTRES #endif -! -! 3.1 Interpolate winds, currents, and momentum. -! (Initialize wave fields with winds) -! + ! + ! 3.1 Interpolate winds, currents, and momentum. + ! (Initialize wave fields with winds) + ! #ifdef W3_DEBUGDCXDX - WRITE(740+IAPROC,*) 'Debug DCXDX FLCUR=', FLCUR + WRITE(740+IAPROC,*) 'Debug DCXDX FLCUR=', FLCUR #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 3a ' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 3a ' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif - IF ( FLCUR ) THEN + IF ( FLCUR ) THEN #ifdef W3_DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before UCUR", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("W3WAVE, step 6.4.1") + CALL PRINT_MY_TIME("W3WAVE, step 6.4.1") #endif - CALL W3UCUR ( FLFRST ) + CALL W3UCUR ( FLFRST ) #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 3b ' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 3b ' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif - IF (GTYPE .EQ. SMCTYPE) THEN - IX = 1 + IF (GTYPE .EQ. SMCTYPE) THEN + IX = 1 #ifdef W3_SMC - !!Li Use new sub for DCXDX/Y and DCYDX/Y assignment. - CALL SMCDCXY + !!Li Use new sub for DCXDX/Y and DCYDX/Y assignment. + CALL SMCDCXY #endif - ELSE IF (GTYPE .EQ. UNGTYPE) THEN + ELSE IF (GTYPE .EQ. UNGTYPE) THEN #ifdef W3_DEBUGDCXDX - WRITE(740+IAPROC,*) 'Before call to UG_GRADIENT for assigning DCXDX/DCXDY array' + WRITE(740+IAPROC,*) 'Before call to UG_GRADIENT for assigning DCXDX/DCXDY array' #endif - CALL UG_GRADIENTS(CX, DCXDX, DCXDY) - CALL UG_GRADIENTS(CY, DCYDX, DCYDY) - UGDTUPDATE=.TRUE. - CFLXYMAX = 0. - ELSE - CALL W3DZXY(CX(1:UBOUND(CX,1)),'m/s',DCXDX, DCXDY) !CX GRADIENT - CALL W3DZXY(CY(1:UBOUND(CY,1)),'m/s',DCYDX, DCYDY) !CY GRADIENT - ENDIF !! End GTYPE -! + CALL UG_GRADIENTS(CX, DCXDX, DCXDY) + CALL UG_GRADIENTS(CY, DCYDX, DCYDY) + UGDTUPDATE=.TRUE. + CFLXYMAX = 0. + ELSE + CALL W3DZXY(CX(1:UBOUND(CX,1)),'m/s',DCXDX, DCXDY) !CX GRADIENT + CALL W3DZXY(CY(1:UBOUND(CY,1)),'m/s',DCYDX, DCYDY) !CY GRADIENT + ENDIF !! End GTYPE + ! #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 4' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! - ELSE IF ( FLFRST ) THEN - UGDTUPDATE=.TRUE. - CFLXYMAX = 0. - CX = 0. - CY = 0. - END IF ! FLCUR + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + ! + ELSE IF ( FLFRST ) THEN + UGDTUPDATE=.TRUE. + CFLXYMAX = 0. + CX = 0. + CY = 0. + END IF ! FLCUR #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After CX/CY assignation") + CALL PRINT_MY_TIME("After CX/CY assignation") #endif -! + ! #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 5' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - - IF ( FLWIND ) THEN - IF ( FLFRST ) ASF = 1. - CALL W3UWND ( FLFRST, VGX, VGY ) - ELSE IF ( FLFRST ) THEN - U10 = 0.01 - U10D = 0. - UST = 0.05 - USTDIR = 0.05 - END IF + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + + IF ( FLWIND ) THEN + IF ( FLFRST ) ASF = 1. + CALL W3UWND ( FLFRST, VGX, VGY ) + ELSE IF ( FLFRST ) THEN + U10 = 0.01 + U10D = 0. + UST = 0.05 + USTDIR = 0.05 + END IF -! DO JSEA = 1, NSEAL -! DO IS = 1, NSPEC -! IF (VA(IS, JSEA) .LT. 0.) THEN -! WRITE(740+IAPROC,*) 'TEST W3WAVE 5', VA(IS,JSEA) -! CALL FLUSH(740+IAPROC) -! ENDIF -! ENDDO -! ENDDO -! IF (SUM(VA) .NE. SUM(VA)) THEN -! WRITE(740+IAPROC,*) 'NAN in ACTION 5', IX, IY, SUM(VA) -! CALL FLUSH(740+IAPROC) -! STOP -! ENDIF + ! DO JSEA = 1, NSEAL + ! DO IS = 1, NSPEC + ! IF (VA(IS, JSEA) .LT. 0.) THEN + ! WRITE(740+IAPROC,*) 'TEST W3WAVE 5', VA(IS,JSEA) + ! CALL FLUSH(740+IAPROC) + ! ENDIF + ! ENDDO + ! ENDDO + ! IF (SUM(VA) .NE. SUM(VA)) THEN + ! WRITE(740+IAPROC,*) 'NAN in ACTION 5', IX, IY, SUM(VA) + ! CALL FLUSH(740+IAPROC) + ! STOP + ! ENDIF #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 6' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After U10, etc. assignation") + CALL PRINT_MY_TIME("After U10, etc. assignation") #endif -! + ! #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before call to W3UINI", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before call to W3UINI", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before call W3UINI") -#endif - IF ( FLIWND .AND. LOCAL ) CALL W3UINI ( VA ) -! - IF ( FLTAUA ) THEN - CALL W3UTAU ( FLFRST ) - ELSE IF ( FLFRST ) THEN - TAUA = 0.01 - TAUADIR = 0. - END IF -! - IF ( FLRHOA ) THEN - CALL W3URHO ( FLFRST ) - ELSE IF ( FLFRST ) THEN - RHOAIR = DAIR - END IF -! -! 3.2 Update boundary conditions if boundary flag is true (FLBPI) -! + CALL PRINT_MY_TIME("Before call W3UINI") +#endif + IF ( FLIWND .AND. LOCAL ) CALL W3UINI ( VA ) + ! + IF ( FLTAUA ) THEN + CALL W3UTAU ( FLFRST ) + ELSE IF ( FLFRST ) THEN + TAUA = 0.01 + TAUADIR = 0. + END IF + ! + IF ( FLRHOA ) THEN + CALL W3URHO ( FLFRST ) + ELSE IF ( FLFRST ) THEN + RHOAIR = DAIR + END IF + ! + ! 3.2 Update boundary conditions if boundary flag is true (FLBPI) + ! #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before boundary update", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before boundary update", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before boundary update") + CALL PRINT_MY_TIME("Before boundary update") #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 7' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif - IF ( FLBPI .AND. LOCAL ) THEN -! - DO - IF ( TBPIN(1) .EQ. -1 ) THEN - READBC = .TRUE. - IDACT(1:1) = 'F' - ELSE - READBC = DSEC21(TIME,TBPIN).LT.0. - IF (READBC.AND.IDACT(1:1).EQ.' ') IDACT(1:1) = 'X' - END IF - FLACT = READBC .OR. FLACT + IF ( FLBPI .AND. LOCAL ) THEN + ! + DO + IF ( TBPIN(1) .EQ. -1 ) THEN + READBC = .TRUE. + IDACT(1:1) = 'F' + ELSE + READBC = DSEC21(TIME,TBPIN).LT.0. + IF (READBC.AND.IDACT(1:1).EQ.' ') IDACT(1:1) = 'X' + END IF + FLACT = READBC .OR. FLACT - IF ( READBC ) THEN - CALL W3IOBC ( 'READ', NDS(9), TBPI0, TBPIN, & - ITEST, IMOD ) - IF ( ITEST .NE. 1 ) CALL W3UBPT - ELSE - ITEST = 0 - END IF - IF ( ITEST .LT. 0 ) IDACT(1:1) = 'L' - IF ( ITEST .GT. 0 ) IDACT(1:1) = ' ' - IF ( .NOT. (READBC.AND.FLBPI) ) EXIT - END DO + IF ( READBC ) THEN + CALL W3IOBC ( 'READ', NDS(9), TBPI0, TBPIN, & + ITEST, IMOD ) + IF ( ITEST .NE. 1 ) CALL W3UBPT + ELSE + ITEST = 0 + END IF + IF ( ITEST .LT. 0 ) IDACT(1:1) = 'L' + IF ( ITEST .GT. 0 ) IDACT(1:1) = ' ' + IF ( .NOT. (READBC.AND.FLBPI) ) EXIT + END DO - END IF + END IF #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 7' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif #ifdef W3_PDLIB - CALL APPLY_BOUNDARY_CONDITION_VA + CALL APPLY_BOUNDARY_CONDITION_VA #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLBPI and LOCAL", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLBPI and LOCAL", 1) #endif #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After FLBPI and LOCAL") + CALL PRINT_MY_TIME("After FLBPI and LOCAL") #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 8' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! -! 3.3.1 Update ice coverage (if new ice map). -! Need to be run on output nodes too, to update MAPSTx -! - IF ( FLICE .AND. DTI0.NE.0. ) THEN -! - IF ( TICE(1).GE.0 ) THEN - IF ( DTI0 .LT. 0. ) THEN - IDACT(13:13) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TIN ) - IF ( DTTST .LE. 0.5*DTI0 ) IDACT(13:13) = 'U' - END IF - ELSE - IDACT(13:13) = 'I' - END IF -! - IF ( IDACT(13:13).NE.' ' ) THEN - CALL W3UICE ( VA ) - DTI0 = 0. - FLACT = .TRUE. - FLMAP = .TRUE. - END IF + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 8' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + ! + ! 3.3.1 Update ice coverage (if new ice map). + ! Need to be run on output nodes too, to update MAPSTx + ! + IF ( FLICE .AND. DTI0.NE.0. ) THEN + ! + IF ( TICE(1).GE.0 ) THEN + IF ( DTI0 .LT. 0. ) THEN + IDACT(13:13) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TIN ) + IF ( DTTST .LE. 0.5*DTI0 ) IDACT(13:13) = 'U' + END IF + ELSE + IDACT(13:13) = 'I' + END IF + ! + IF ( IDACT(13:13).NE.' ' ) THEN + CALL W3UICE ( VA ) + DTI0 = 0. + FLACT = .TRUE. + FLMAP = .TRUE. END IF + END IF #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLICE and DTI0", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLICE and DTI0", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After FLICE and DTI0") + CALL PRINT_MY_TIME("After FLICE and DTI0") #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 9' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! -! 3.3.2 Update ice thickness -! - IF ( FLIC1 .AND. DTI10.NE.0. ) THEN -! - IF ( TIC1(1).GE.0 ) THEN - IF ( DTI10 .LT. 0. ) THEN - IDACT(15:15) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TI1 ) - IF ( DTTST .LE. 0.5*DTI10 ) IDACT(15:15) = 'U' - END IF - ELSE - IDACT(15:15) = 'I' - END IF - -! - IF ( IDACT(15:15).NE.' ' ) THEN - CALL W3UIC1 ( FLFRST ) - DTI10 = 0. - FLACT = .TRUE. - FLMAP = .TRUE. - END IF -! + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 9' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + ! + ! 3.3.2 Update ice thickness + ! + IF ( FLIC1 .AND. DTI10.NE.0. ) THEN + ! + IF ( TIC1(1).GE.0 ) THEN + IF ( DTI10 .LT. 0. ) THEN + IDACT(15:15) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TI1 ) + IF ( DTTST .LE. 0.5*DTI10 ) IDACT(15:15) = 'U' END IF + ELSE + IDACT(15:15) = 'I' + END IF + + ! + IF ( IDACT(15:15).NE.' ' ) THEN + CALL W3UIC1 ( FLFRST ) + DTI10 = 0. + FLACT = .TRUE. + FLMAP = .TRUE. + END IF + ! + END IF #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 10' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 10' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif -! -! 3.3.3 Update ice floe diameter -! + ! + ! 3.3.3 Update ice floe diameter + ! #ifdef W3_IS2 - IF ( FLIC5 .AND. DTI50.NE.0. ) THEN -! - IF ( TIC5(1).GE.0 ) THEN - IF ( DTI50 .LT. 0. ) THEN - IDACT(18:18) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TI5 ) - IF ( DTTST .LE. 0.5*DTI50 ) IDACT(18:18) = 'U' - END IF - ELSE - IDACT(18:18) = 'I' - END IF -! - IF ( IDACT(18:18).NE.' ' ) THEN - CALL W3UIC5( FLFRST ) - DTI50 = 0. - FLACT = .TRUE. - FLMAP = .TRUE. - END IF -! + IF ( FLIC5 .AND. DTI50.NE.0. ) THEN + ! + IF ( TIC5(1).GE.0 ) THEN + IF ( DTI50 .LT. 0. ) THEN + IDACT(18:18) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TI5 ) + IF ( DTTST .LE. 0.5*DTI50 ) IDACT(18:18) = 'U' END IF + ELSE + IDACT(18:18) = 'I' + END IF + ! + IF ( IDACT(18:18).NE.' ' ) THEN + CALL W3UIC5( FLFRST ) + DTI50 = 0. + FLACT = .TRUE. + FLMAP = .TRUE. + END IF + ! + END IF #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 11a' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! -! 3.4 Transform grid (if new water level). -! - IF ( FLLEV .AND. DTL0 .NE.0. ) THEN -! - IF ( TLEV(1) .GE. 0 ) THEN - IF ( DTL0 .LT. 0. ) THEN - IDACT(5:5) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TLN ) - IF ( DTTST .LE. 0.5*DTL0 ) IDACT(5:5) = 'U' - END IF - ELSE - IDACT(5:5) = 'I' - END IF -! - IF ( IDACT(5:5).NE.' ' ) THEN + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 11a' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + ! + ! 3.4 Transform grid (if new water level). + ! + IF ( FLLEV .AND. DTL0 .NE.0. ) THEN + ! + IF ( TLEV(1) .GE. 0 ) THEN + IF ( DTL0 .LT. 0. ) THEN + IDACT(5:5) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TLN ) + IF ( DTTST .LE. 0.5*DTL0 ) IDACT(5:5) = 'U' + END IF + ELSE + IDACT(5:5) = 'I' + END IF + ! + IF ( IDACT(5:5).NE.' ' ) THEN - CALL W3ULEV ( VA, VA ) + CALL W3ULEV ( VA, VA ) - UGDTUPDATE=.TRUE. - CFLXYMAX = 0. - DTL0 = 0. - FLACT = .TRUE. - FLMAP = .TRUE. - FLDDIR = FLDDIR .OR. FLCTH .OR. FSREFRACTION .OR. FLCK .OR. FSFREQSHIFT - END IF + UGDTUPDATE=.TRUE. + CFLXYMAX = 0. + DTL0 = 0. + FLACT = .TRUE. + FLMAP = .TRUE. + FLDDIR = FLDDIR .OR. FLCTH .OR. FSREFRACTION .OR. FLCK .OR. FSFREQSHIFT END IF + END IF #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FFLEV and DTL0", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FFLEV and DTL0", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After FFLEV and DTL0") + CALL PRINT_MY_TIME("After FFLEV and DTL0") #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 11b' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 11b' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif -! -! 3.5 Update maps and derivatives. -! - IF ( FLMAP ) THEN - IF ( GTYPE .NE. SMCTYPE ) THEN + ! + ! 3.5 Update maps and derivatives. + ! + IF ( FLMAP ) THEN + IF ( GTYPE .NE. SMCTYPE ) THEN #ifdef W3_PR1 - CALL W3MAP1 ( MAPSTA ) + CALL W3MAP1 ( MAPSTA ) #endif #ifdef W3_PR2 - CALL W3MAP2 + CALL W3MAP2 #endif #ifdef W3_PR3 - CALL W3MAP3 + CALL W3MAP3 #endif - CALL W3UTRN ( TRNX, TRNY ) + CALL W3UTRN ( TRNX, TRNY ) #ifdef W3_PR3 - CALL W3MAPT + CALL W3MAPT #endif - END IF !! GTYPE + END IF !! GTYPE -!! Hides call to W3NMIN, which currently only serves to warn when -!! one or more procs have zero active seapoints. + !! Hides call to W3NMIN, which currently only serves to warn when + !! one or more procs have zero active seapoints. #ifdef W3_DEBUGRUN - CALL W3NMIN ( MAPSTA, FLAG0 ) - IF ( FLAG0 .AND. IAPROC.EQ.NAPERR ) WRITE (NDSE,1030) IMOD + CALL W3NMIN ( MAPSTA, FLAG0 ) + IF ( FLAG0 .AND. IAPROC.EQ.NAPERR ) WRITE (NDSE,1030) IMOD #endif - FLMAP = .FALSE. - END IF -! -! - IF ( FLDDIR ) THEN - IF (GTYPE .EQ. SMCTYPE) THEN - IX = 1 + FLMAP = .FALSE. + END IF + ! + ! + IF ( FLDDIR ) THEN + IF (GTYPE .EQ. SMCTYPE) THEN + IX = 1 #ifdef W3_SMC - !!Li Use new sub for DDDX and DDDY assignment. - CALL SMCDHXY + !!Li Use new sub for DDDX and DDDY assignment. + CALL SMCDHXY #endif - ELSE IF (GTYPE .EQ. UNGTYPE) THEN - CALL UG_GRADIENTS(DW, DDDX, DDDY) - ELSE - CALL W3DZXY(DW(1:UBOUND(DW,1)),'m',DDDX,DDDY) - END IF - FLDDIR = .FALSE. + ELSE IF (GTYPE .EQ. UNGTYPE) THEN + CALL UG_GRADIENTS(DW, DDDX, DDDY) + ELSE + CALL W3DZXY(DW(1:UBOUND(DW,1)),'m',DDDX,DDDY) END IF + FLDDIR = .FALSE. + END IF #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 12' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 12' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif -! -! Calculate PHASE SPEED GRADIENT. - DCDX = 0. - DCDY = 0. + ! + ! Calculate PHASE SPEED GRADIENT. + DCDX = 0. + DCDY = 0. #ifdef W3_REFRX - CIK = 0. -! - IF (GTYPE .NE. UNGTYPE) THEN - DO IK=0,NK+1 - CIK = SIG(IK) / WN(IK,1:NSEA) - CALL W3DZXY(CIK,'m/s',DCDX(IK,:,:),DCDY(IK,:,:)) - END DO - ELSE - WRITE (NDSE,1040) - CALL EXTCDE(2) - ! CALL UG_GRADIENTS(CMN, DCDX, DCDY) !/ Stefan, to be confirmed! - END IF + CIK = 0. + ! + IF (GTYPE .NE. UNGTYPE) THEN + DO IK=0,NK+1 + CIK = SIG(IK) / WN(IK,1:NSEA) + CALL W3DZXY(CIK,'m/s',DCDX(IK,:,:),DCDY(IK,:,:)) + END DO + ELSE + WRITE (NDSE,1040) + CALL EXTCDE(2) + ! CALL UG_GRADIENTS(CMN, DCDX, DCDY) !/ Stefan, to be confirmed! + END IF #endif -! -! - FLIWND = .FALSE. - FLFRST = .FALSE. -! + ! + ! + FLIWND = .FALSE. + FLFRST = .FALSE. + ! #ifdef W3_PDLIB #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_PRE", 1) - CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT before W3SRCE_IMP_PRE") - CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT before W3SRCE_IMP_PRE") - IF (DEBUG_NODE .le. NSEAL) THEN - WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE - WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) - END IF + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_PRE", 1) + CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT before W3SRCE_IMP_PRE") + CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT before W3SRCE_IMP_PRE") + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) + END IF #endif - IF (IT .eq. 0) THEN - DTGpre = 1. - ELSE - DTGpre = DTG - END IF + IF (IT .eq. 0) THEN + DTGpre = 1. + ELSE + DTGpre = DTG + END IF #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 13' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 13' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif -! + ! #ifdef W3_PDLIB IF ( FLSOU .and. LPDLIB .and. FSSOURCE) THEN #endif #ifdef W3_OMP0 -!$OMP PARALLEL DO PRIVATE (JSEA,ISEA,IX,IY) SCHEDULE (DYNAMIC,1) + !$OMP PARALLEL DO PRIVATE (JSEA,ISEA,IX,IY) SCHEDULE (DYNAMIC,1) #endif #ifdef W3_PDLIB @@ -1614,46 +1616,46 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & DELX=1. DELY=1. #ifdef W3_REF1 - IF (GTYPE.EQ.RLGTYPE) THEN - DELX=SX*CLATS(ISEA)/FACX - DELY=SY/FACX - DELA=DELX*DELY - END IF - IF (GTYPE.EQ.CLGTYPE) THEN -! Maybe what follows works also for RLGTYPE ... to be verified - DELX=HPFAC(IY,IX)/ FACX - DELY=HQFAC(IY,IX)/ FACX - DELA=DELX*DELY - END IF + IF (GTYPE.EQ.RLGTYPE) THEN + DELX=SX*CLATS(ISEA)/FACX + DELY=SY/FACX + DELA=DELX*DELY + END IF + IF (GTYPE.EQ.CLGTYPE) THEN + ! Maybe what follows works also for RLGTYPE ... to be verified + DELX=HPFAC(IY,IX)/ FACX + DELY=HQFAC(IY,IX)/ FACX + DELA=DELX*DELY + END IF #endif -! + ! #ifdef W3_REF1 - REFLEC=REFLC(:,ISEA) - REFLEC(4)=BERG(ISEA)*REFLEC(4) - REFLED=REFLD(:,ISEA) + REFLEC=REFLC(:,ISEA) + REFLEC(4)=BERG(ISEA)*REFLEC(4) + REFLED=REFLD(:,ISEA) #endif #ifdef W3_BT4 - D50=SED_D50(ISEA) - PSIC=SED_PSIC(ISEA) + D50=SED_D50(ISEA) + PSIC=SED_PSIC(ISEA) #endif -! + ! #ifdef W3_PDLIB - IF ((IOBP_LOC(JSEA) .eq. 1 .or. IOBP_LOC(JSEA) .eq. 3) & - & .and. IOBDP_LOC(JSEA) .eq. 1 .and. IOBPA_LOC(JSEA) .eq. 0) THEN + IF ((IOBP_LOC(JSEA) .eq. 1 .or. IOBP_LOC(JSEA) .eq. 3) & + & .and. IOBDP_LOC(JSEA) .eq. 1 .and. IOBPA_LOC(JSEA) .eq. 0) THEN #endif #ifdef W3_PDLIB #ifdef W3_DEBUGSRC - IF (IX .eq. DEBUG_NODE) THEN - WRITE(740+IAPROC,*) 'NODE_SRCE_IMP_PRE : IX=', IX, ' JSEA=', JSEA - END IF - WRITE(740+IAPROC,*) 'IT/IX/IY/IMOD=', IT, IX, IY, IMOD - WRITE(740+IAPROC,*) 'ISEA/JSEA=', ISEA, JSEA - WRITE(740+IAPROC,*) 'Before sum(VA)=', sum(VA(:,JSEA)) - FLUSH(740+IAPROC) -#endif - CALL W3SRCE(srce_imp_pre, IT, ISEA, JSEA, IX, IY, IMOD, & + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) 'NODE_SRCE_IMP_PRE : IX=', IX, ' JSEA=', JSEA + END IF + WRITE(740+IAPROC,*) 'IT/IX/IY/IMOD=', IT, IX, IY, IMOD + WRITE(740+IAPROC,*) 'ISEA/JSEA=', ISEA, JSEA + WRITE(740+IAPROC,*) 'Before sum(VA)=', sum(VA(:,JSEA)) + FLUSH(740+IAPROC) +#endif + CALL W3SRCE(srce_imp_pre, IT, ISEA, JSEA, IX, IY, IMOD, & VAold(:,JSEA), VA(:,JSEA), & VSioDummy, VDioDummy, SHAVETOT(JSEA), & ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & @@ -1677,16 +1679,16 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & RHOAIR(ISEA), ASF(ISEA)) - IF (.not. LSLOC) THEN - VSTOT(:,JSEA) = VSioDummy - VDTOT(:,JSEA) = VDioDummy - ENDIF + IF (.not. LSLOC) THEN + VSTOT(:,JSEA) = VSioDummy + VDTOT(:,JSEA) = VDioDummy + ENDIF #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'After sum(VA)=', sum(VA(:,JSEA)) - WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,JSEA)) - WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,JSEA)) - WRITE(740+IAPROC,*) ' SHAVETOT=', SHAVETOT(JSEA) - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'After sum(VA)=', sum(VA(:,JSEA)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,JSEA)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,JSEA)) + WRITE(740+IAPROC,*) ' SHAVETOT=', SHAVETOT(JSEA) + FLUSH(740+IAPROC) #endif #endif ELSE @@ -1702,139 +1704,139 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #ifdef W3_PDLIB #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE", 1) - CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT after W3SRCE_IMP_PRE") - CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT after W3SRCE_IMP_PRE") - IF (DEBUG_NODE .le. NSEAL) THEN - WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE - WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) - END IF + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE", 1) + CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT after W3SRCE_IMP_PRE") + CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT after W3SRCE_IMP_PRE") + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) + END IF #endif #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 14' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 14' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif - IF ( FLZERO ) THEN + IF ( FLZERO ) THEN #ifdef W3_T - WRITE (NDST,9022) + WRITE (NDST,9022) #endif - GOTO 400 - END IF - IF ( IT.EQ.0 ) THEN - DTG = 1. -! DTG = 60. - GOTO 370 - END IF - IF ( FLDRY .OR. IAPROC.GT.NAPROC ) THEN + GOTO 400 + END IF + IF ( IT.EQ.0 ) THEN + DTG = 1. + ! DTG = 60. + GOTO 370 + END IF + IF ( FLDRY .OR. IAPROC.GT.NAPROC ) THEN #ifdef W3_T - WRITE (NDST,9023) + WRITE (NDST,9023) #endif - GOTO 380 - END IF -! -! Estimation of the local maximum CFL for XY propagation -! + GOTO 380 + END IF + ! + ! Estimation of the local maximum CFL for XY propagation + ! #ifdef W3_T - WRITE(NDSE,*) 'Computing CFLs .... ',NSEAL + WRITE(NDSE,*) 'Computing CFLs .... ',NSEAL #endif - IF ( FLOGRD(9,3).AND. UGDTUPDATE ) THEN - IF (FSTOTALIMP .eqv. .FALSE.) THEN - NKCFL=NK + IF ( FLOGRD(9,3).AND. UGDTUPDATE ) THEN + IF (FSTOTALIMP .eqv. .FALSE.) THEN + NKCFL=NK #ifdef W3_T - NKCFL=1 + NKCFL=1 #endif -! + ! #ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE (JSEA,ISEA) SCHEDULE (DYNAMIC,1) + !$OMP PARALLEL DO PRIVATE (JSEA,ISEA) SCHEDULE (DYNAMIC,1) #endif -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) + ! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) #ifdef W3_PR3 - IF (GTYPE .EQ. UNGTYPE) THEN - IF ( FLOGRD(9,3) ) THEN + IF (GTYPE .EQ. UNGTYPE) THEN + IF ( FLOGRD(9,3) ) THEN #endif #ifdef W3_T - IF (MOD(ISEA,100).EQ.0) WRITE(NDSE,*) 'COMPUTING CFL FOR NODE:',ISEA + IF (MOD(ISEA,100).EQ.0) WRITE(NDSE,*) 'COMPUTING CFL FOR NODE:',ISEA #endif #ifdef W3_PDLIB - IF (.NOT. LPDLIB) THEN + IF (.NOT. LPDLIB) THEN #endif #ifdef W3_PR3 - CALL W3CFLUG ( ISEA, NKCFL, FACX, FACX, DTG, MAPFS, CFLXYMAX(JSEA), VGX, VGY ) + CALL W3CFLUG ( ISEA, NKCFL, FACX, FACX, DTG, MAPFS, CFLXYMAX(JSEA), VGX, VGY ) #endif #ifdef W3_PDLIB - ENDIF + ENDIF #endif #ifdef W3_PR3 - END IF - ELSE - CALL W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, CFLXYMAX(JSEA), VGX, VGY ) - END IF + END IF + ELSE + CALL W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, CFLXYMAX(JSEA), VGX, VGY ) + END IF #endif - END DO -! + END DO + ! #ifdef W3_OMPG -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif -! - END IF - END IF + ! + END IF + END IF #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 15' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 15' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif -! + ! -! + ! #ifdef W3_T - IF (GTYPE .EQ. UNGTYPE) THEN - IF ( FLOGRD(9,3) ) THEN - DTCFL1(:)=1. - DO JSEA=1,NSEAL - INDSORT(JSEA)=FLOAT(JSEA) - DTCFL1(JSEA)=DTG/CFLXYMAX(JSEA) - END DO - CALL SSORT1 (DTCFL1, INDSORT, NSEAL, 2) - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,*) 'Nodes requesting smallest timesteps:' - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10I10)') 'Nodes ',NINT(INDSORT(1:10)) - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10F10.2)') 'time steps ',DTCFL1(1:10) - DO JSEA = 1, MIN(NSEAL,200) - ISEA = NINT(INDSORT(JSEA)) ! will not work with MPI - IX = MAPSF(ISEA,1) - IF (JSEA.EQ.1) then - WRITE(995,*) ' IP dtmax_exp(ip) x-coord y-coord z-coord' - end IF - WRITE(995,'(I10,F10.2,3F10.4)') IX, DTCFL1(JSEA), XGRD(1,IX), YGRD(2,IX), ZB(IX) - END DO ! JSEA - CLOSE(995) - END IF - END IF -#endif - -! -! 3.6 Perform Propagation = = = = = = = = = = = = = = = = = = = = = = = -! 3.6.1 Preparations -! + IF (GTYPE .EQ. UNGTYPE) THEN + IF ( FLOGRD(9,3) ) THEN + DTCFL1(:)=1. + DO JSEA=1,NSEAL + INDSORT(JSEA)=FLOAT(JSEA) + DTCFL1(JSEA)=DTG/CFLXYMAX(JSEA) + END DO + CALL SSORT1 (DTCFL1, INDSORT, NSEAL, 2) + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,*) 'Nodes requesting smallest timesteps:' + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10I10)') 'Nodes ',NINT(INDSORT(1:10)) + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10F10.2)') 'time steps ',DTCFL1(1:10) + DO JSEA = 1, MIN(NSEAL,200) + ISEA = NINT(INDSORT(JSEA)) ! will not work with MPI + IX = MAPSF(ISEA,1) + IF (JSEA.EQ.1) then + WRITE(995,*) ' IP dtmax_exp(ip) x-coord y-coord z-coord' + end IF + WRITE(995,'(I10,F10.2,3F10.4)') IX, DTCFL1(JSEA), XGRD(1,IX), YGRD(2,IX), ZB(IX) + END DO ! JSEA + CLOSE(995) + END IF + END IF +#endif + + ! + ! 3.6 Perform Propagation = = = = = = = = = = = = = = = = = = = = = = = + ! 3.6.1 Preparations + ! #ifdef W3_SEC1 - DTGTEMP=DTG - DTG=DTG/NITERSEC1 - DO ISEC1=1,NITERSEC1 + DTGTEMP=DTG + DTG=DTG/NITERSEC1 + DO ISEC1=1,NITERSEC1 #endif NTLOC = 1 + INT( DTG/DTCFLI - 0.001 ) #ifdef W3_SEC1 - IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSE,'(A,I4,A,I4)') ' SUBSECOND STEP:',ISEC1,' out of ',NITERSEC1 + IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSE,'(A,I4,A,I4)') ' SUBSECOND STEP:',ISEC1,' out of ',NITERSEC1 #endif -! + ! FACTH = DTG / (DTH*REAL(NTLOC)) FACK = DTG / REAL(NTLOC) @@ -1842,2083 +1844,2083 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & TTEST(2) = 0 DTTEST = DSEC21(TTEST,TIME) ITLOCH = ( NTLOC + 1 - MOD(NINT(DTTEST/DTG),2) ) / 2 -! -! 3.6.2 Intra-spectral part 1 -! + ! + ! 3.6.2 Intra-spectral part 1 + ! #ifdef W3_DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before intraspectral part 1", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before intraspectral") + CALL PRINT_MY_TIME("Before intraspectral") #endif IF ( FLCTH .OR. FLCK ) THEN - DO ITLOC=1, ITLOCH -! + DO ITLOC=1, ITLOCH + ! #ifdef W3_OMPG -!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) -!$OMP DO SCHEDULE (DYNAMIC,1) + !$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) + !$OMP DO SCHEDULE (DYNAMIC,1) #endif -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + ! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) - IF ( GTYPE .EQ. UNGTYPE ) THEN - IF (LPDLIB) THEN + IF ( GTYPE .EQ. UNGTYPE ) THEN + IF (LPDLIB) THEN #ifdef W3_PDLIB - IF (IOBP_LOC(JSEA) .NE. 1) CYCLE + IF (IOBP_LOC(JSEA) .NE. 1) CYCLE #endif - ELSE - IF (IOBP(ISEA) .NE. 1) CYCLE - ENDIF + ELSE + IF (IOBP(ISEA) .NE. 1) CYCLE ENDIF + ENDIF - IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN - DEPTH = MAX ( DMIN , DW(ISEA) ) - IF (LPDLIB) THEN - IXrel = JSEA - ELSE - IXrel = IX - END IF -! - IF( GTYPE .EQ. SMCTYPE ) THEN - J = 1 + IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN + DEPTH = MAX ( DMIN , DW(ISEA) ) + IF (LPDLIB) THEN + IXrel = JSEA + ELSE + IXrel = IX + END IF + ! + IF( GTYPE .EQ. SMCTYPE ) THEN + J = 1 #ifdef W3_SMC - !!Li Refraction and GCT in theta direction is done by rotation. - CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & - CX(ISEA), CY(ISEA), DCXDX(IY,IX), & - DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & - DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) -#endif -! - ELSE - J = 1 -! + !!Li Refraction and GCT in theta direction is done by rotation. + CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & + CX(ISEA), CY(ISEA), DCXDX(IY,IX), & + DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & + DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) +#endif + ! + ELSE + J = 1 + ! #ifdef W3_PR1 - CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) + CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) #endif #ifdef W3_PR2 - CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) + CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) #endif #ifdef W3_PR3 - CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & - CFLTHMAX(JSEA), CFLKMAX(JSEA) ) -#endif -! - END IF !! GTYPE -! - END IF - END DO -! + CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & + CFLTHMAX(JSEA), CFLKMAX(JSEA) ) +#endif + ! + END IF !! GTYPE + ! + END IF + END DO + ! #ifdef W3_OMPG -!$OMP END DO -!$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL #endif -! - END DO + ! + END DO END IF #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 16' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 16' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before spatial advection", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before spatial advection", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before spatial advection") -#endif -! -! 3.6.3 Longitude-latitude -! (time step correction in routine) -! - IF (GTYPE .EQ. UNGTYPE) THEN - IF (FLAGLL) THEN - FACX = 1./(DERA * RADIUS) - ELSE - FACX = 1. + CALL PRINT_MY_TIME("Before spatial advection") +#endif + ! + ! 3.6.3 Longitude-latitude + ! (time step correction in routine) + ! + IF (GTYPE .EQ. UNGTYPE) THEN + IF (FLAGLL) THEN + FACX = 1./(DERA * RADIUS) + ELSE + FACX = 1. + END IF END IF - END IF - IF ((GTYPE .EQ. UNGTYPE) .and. LPDLIB) THEN -! + IF ((GTYPE .EQ. UNGTYPE) .and. LPDLIB) THEN + ! #ifdef W3_PDLIB - IF ((FSTOTALIMP .eqv. .FALSE.).and.(FLCX .or. FLCY)) THEN + IF ((FSTOTALIMP .eqv. .FALSE.).and.(FLCX .or. FLCY)) THEN #endif #ifdef W3_PDLIB - DO ISPEC=1,NSPEC - CALL PDLIB_W3XYPUG ( ISPEC, FACX, FACX, DTG, VGX, VGY, UGDTUPDATE ) - END DO + DO ISPEC=1,NSPEC + CALL PDLIB_W3XYPUG ( ISPEC, FACX, FACX, DTG, VGX, VGY, UGDTUPDATE ) + END DO #endif #ifdef W3_PDLIB - END IF + END IF #endif -! + ! #ifdef W3_PDLIB - IF (FSTOTALIMP .and. (IT .ne. 0)) THEN + IF (FSTOTALIMP .and. (IT .ne. 0)) THEN #endif #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before Block implicit", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before Block implicit", 1) #endif #ifdef W3_PDLIB - CALL PDLIB_W3XYPUG_BLOCK_IMPLICIT(IMOD, FACX, FACX, DTG, VGX, VGY) + CALL PDLIB_W3XYPUG_BLOCK_IMPLICIT(IMOD, FACX, FACX, DTG, VGX, VGY) #endif #ifdef W3_PDLIB - ELSE IF(FSTOTALEXP .and. (IT .ne. 0)) THEN + ELSE IF(FSTOTALEXP .and. (IT .ne. 0)) THEN #endif #ifdef W3_PDLIB - CALL PDLIB_W3XYPUG_BLOCK_EXPLICIT(IMOD, FACX, FACX, DTG, VGX, VGY) + CALL PDLIB_W3XYPUG_BLOCK_EXPLICIT(IMOD, FACX, FACX, DTG, VGX, VGY) #endif #ifdef W3_PDLIB - ENDIF + ENDIF #endif - ELSE - IF (FLCX .or. FLCY) THEN -! + ELSE + IF (FLCX .or. FLCY) THEN + ! #ifdef W3_MPI - IF ( NRQSG1 .GT. 0 ) THEN - CALL MPI_STARTALL (NRQSG1, IRQSG1(1,1), IERR_MPI) - CALL MPI_STARTALL (NRQSG1, IRQSG1(1,2), IERR_MPI) - END IF -#endif -! -! -! Initialize FIELD variable - FIELD = 0. -! - DO ISPEC=1, NSPEC - IF ( IAPPRO(ISPEC) .EQ. IAPROC ) THEN -! - IF( GTYPE .EQ. SMCTYPE ) THEN + IF ( NRQSG1 .GT. 0 ) THEN + CALL MPI_STARTALL (NRQSG1, IRQSG1(1,1), IERR_MPI) + CALL MPI_STARTALL (NRQSG1, IRQSG1(1,2), IERR_MPI) + END IF +#endif + ! + ! + ! Initialize FIELD variable + FIELD = 0. + ! + DO ISPEC=1, NSPEC + IF ( IAPPRO(ISPEC) .EQ. IAPROC ) THEN + ! + IF( GTYPE .EQ. SMCTYPE ) THEN IX = 1 #ifdef W3_SMC - !!Li Use SMC sub to gether field - CALL W3GATHSMC ( ISPEC, FIELD ) -#endif - ELSE IF (.NOT.LPDLIB ) THEN - CALL W3GATH ( ISPEC, FIELD ) - END IF !! GTYPE -! - IF (GTYPE .EQ. SMCTYPE) THEN - IX = 1 + !!Li Use SMC sub to gether field + CALL W3GATHSMC ( ISPEC, FIELD ) +#endif + ELSE IF (.NOT.LPDLIB ) THEN + CALL W3GATH ( ISPEC, FIELD ) + END IF !! GTYPE + ! + IF (GTYPE .EQ. SMCTYPE) THEN + IX = 1 #ifdef W3_SMC - !!Li Propagation on SMC grid uses UNO2 scheme. - CALL W3PSMC ( ISPEC, DTG, FIELD ) + !!Li Propagation on SMC grid uses UNO2 scheme. + CALL W3PSMC ( ISPEC, DTG, FIELD ) #endif -! - ELSE IF (GTYPE .EQ. UNGTYPE) THEN - IX = 1 + ! + ELSE IF (GTYPE .EQ. UNGTYPE) THEN + IX = 1 #ifdef W3_MPI - IF (.NOT. LPDLIB) THEN + IF (.NOT. LPDLIB) THEN #endif #ifdef W3_PR1 - CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, FIELD, VGX, VGY, UGDTUPDATE ) + CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, FIELD, VGX, VGY, UGDTUPDATE ) #endif #ifdef W3_PR2 - CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, FIELD, VGX, VGY, UGDTUPDATE ) + CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, FIELD, VGX, VGY, UGDTUPDATE ) #endif #ifdef W3_PR3 - CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, FIELD, VGX, VGY, UGDTUPDATE ) + CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, FIELD, VGX, VGY, UGDTUPDATE ) #endif #ifdef W3_MPI - END IF + END IF #endif -! - ELSE - IX = 1 + ! + ELSE + IX = 1 #ifdef W3_PR1 - CALL W3XYP1 ( ISPEC, DTG, MAPSTA, FIELD, VGX, VGY ) + CALL W3XYP1 ( ISPEC, DTG, MAPSTA, FIELD, VGX, VGY ) #endif #ifdef W3_PR2 - CALL W3XYP2 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) + CALL W3XYP2 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) #endif #ifdef W3_PR3 - CALL W3XYP3 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) + CALL W3XYP3 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) #endif -! - END IF !! GTYPE -! - IF( GTYPE .EQ. SMCTYPE ) THEN - IX = 1 + ! + END IF !! GTYPE + ! + IF( GTYPE .EQ. SMCTYPE ) THEN + IX = 1 #ifdef W3_SMC - !!Li Use SMC sub to scatter field - CALL W3SCATSMC ( ISPEC, MAPSTA, FIELD ) + !!Li Use SMC sub to scatter field + CALL W3SCATSMC ( ISPEC, MAPSTA, FIELD ) #endif - ELSE IF (.NOT.LPDLIB ) THEN - CALL W3SCAT ( ISPEC, MAPSTA, FIELD ) - END IF !! GTYPE + ELSE IF (.NOT.LPDLIB ) THEN + CALL W3SCAT ( ISPEC, MAPSTA, FIELD ) + END IF !! GTYPE - END IF - END DO -! + END IF + END DO + ! #ifdef W3_MPI - IF ( NRQSG1 .GT. 0 ) THEN - ALLOCATE ( STATCO(MPI_STATUS_SIZE,NRQSG1) ) - CALL MPI_WAITALL (NRQSG1, IRQSG1(1,1), STATCO, IERR_MPI) - CALL MPI_WAITALL (NRQSG1, IRQSG1(1,2), STATCO, IERR_MPI) - DEALLOCATE ( STATCO ) - END IF + IF ( NRQSG1 .GT. 0 ) THEN + ALLOCATE ( STATCO(MPI_STATUS_SIZE,NRQSG1) ) + CALL MPI_WAITALL (NRQSG1, IRQSG1(1,1), STATCO, IERR_MPI) + CALL MPI_WAITALL (NRQSG1, IRQSG1(1,2), STATCO, IERR_MPI) + DEALLOCATE ( STATCO ) + END IF #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 17' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 17' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif -! -!Li Initialise IK IX IY in case ARC option is not used to avoid warnings. + ! + !Li Initialise IK IX IY in case ARC option is not used to avoid warnings. IK=1 IX=1 IY=1 #ifdef W3_SMC - !Li Find source boundary spectra and assign to SPCBAC - IF( ARCTC ) THEN + !Li Find source boundary spectra and assign to SPCBAC + IF( ARCTC ) THEN - DO IK = 1, NBAC - IF( IK .LE. (NBAC-NBGL) ) THEN - IY = ICLBAC(IK) - ELSE - IY = NGLO + IK - ENDIF + DO IK = 1, NBAC + IF( IK .LE. (NBAC-NBGL) ) THEN + IY = ICLBAC(IK) + ELSE + IY = NGLO + IK + ENDIF - !Li Work out root PE (ISPEC) and JSEA numbers for IY + !Li Work out root PE (ISPEC) and JSEA numbers for IY #ifdef W3_DIST - ISPEC = MOD( IY-1, NAPROC ) - JSEA = 1 + (IY - ISPEC - 1)/NAPROC + ISPEC = MOD( IY-1, NAPROC ) + JSEA = 1 + (IY - ISPEC - 1)/NAPROC #endif #ifdef W3_SHRD - ISPEC = 0 - JSEA = IY + ISPEC = 0 + JSEA = IY #endif #endif -! W3_SMC ... -! + ! W3_SMC ... + ! #ifdef W3_SMC - !!Li Assign boundary cell spectra. - IF( IAPROC .EQ. ISPEC+1 ) THEN - SPCBAC(:,IK)=VA(:,JSEA) - ENDIF + !!Li Assign boundary cell spectra. + IF( IAPROC .EQ. ISPEC+1 ) THEN + SPCBAC(:,IK)=VA(:,JSEA) + ENDIF #endif -! + ! #ifdef W3_SMC - !!Li Broadcast local SPCBAC(:,IK) to all other PEs. + !!Li Broadcast local SPCBAC(:,IK) to all other PEs. #ifdef W3_MPI - CALL MPI_BCAST(SPCBAC(1,IK),NSPEC,MPI_REAL,ISPEC,MPI_COMM_WAVE,IERR_MPI) - CALL MPI_BARRIER (MPI_COMM_WAVE,IERR_MPI) + CALL MPI_BCAST(SPCBAC(1,IK),NSPEC,MPI_REAL,ISPEC,MPI_COMM_WAVE,IERR_MPI) + CALL MPI_BARRIER (MPI_COMM_WAVE,IERR_MPI) #endif #endif -! + ! #ifdef W3_SMC - END DO !! Loop IK ends. + END DO !! Loop IK ends. #endif -! + ! #ifdef W3_SMC - !!Li Update Arctic boundary cell spectra if within local range - ALLOCATE ( BACSPEC(NSPEC) ) - DO IK = 1, NBAC - IF( IK .LE. (NBAC-NBGL) ) THEN - IX = NGLO + IK - BACANGL = ANGARC(IK) - ELSE - IX = ICLBAC(IK) - BACANGL = - ANGARC(IK) - ENDIF - - !!Li Work out boundary PE (ISPEC) and JSEA numbers for IX + !!Li Update Arctic boundary cell spectra if within local range + ALLOCATE ( BACSPEC(NSPEC) ) + DO IK = 1, NBAC + IF( IK .LE. (NBAC-NBGL) ) THEN + IX = NGLO + IK + BACANGL = ANGARC(IK) + ELSE + IX = ICLBAC(IK) + BACANGL = - ANGARC(IK) + ENDIF + + !!Li Work out boundary PE (ISPEC) and JSEA numbers for IX #ifdef W3_DIST - ISPEC = MOD( IX-1, NAPROC ) - JSEA = 1 + (IX - ISPEC - 1)/NAPROC + ISPEC = MOD( IX-1, NAPROC ) + JSEA = 1 + (IX - ISPEC - 1)/NAPROC #endif #ifdef W3_SHRD - ISPEC = 0 - JSEA = IX + ISPEC = 0 + JSEA = IX #endif #endif -! + ! #ifdef W3_SMC - IF( IAPROC .EQ. ISPEC+1 ) THEN - BACSPEC = SPCBAC(:,IK) + IF( IAPROC .EQ. ISPEC+1 ) THEN + BACSPEC = SPCBAC(:,IK) - CALL w3acturn( NTH, NK, BACANGL, BACSPEC ) + CALL w3acturn( NTH, NK, BACANGL, BACSPEC ) - VA(:,JSEA) = BACSPEC - !!Li WRITE(NDSE,*) "IAPROC, IX, JSEAx, IK=", IAPROC, IX, JSEA, IK - ENDIF + VA(:,JSEA) = BACSPEC + !!Li WRITE(NDSE,*) "IAPROC, IX, JSEAx, IK=", IAPROC, IX, JSEA, IK + ENDIF - END DO !! Loop IK ends. - DEALLOCATE ( BACSPEC ) + END DO !! Loop IK ends. + DEALLOCATE ( BACSPEC ) - ENDIF !! ARCTC + ENDIF !! ARCTC #endif -! -! End of test FLCX.OR.FLCY + ! + ! End of test FLCX.OR.FLCY + END IF + ! END IF -! - END IF #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After spatial advection", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After spatial advection", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After spatial advection") + CALL PRINT_MY_TIME("After spatial advection") #endif -! -! 3.6.4 Intra-spectral part 2 -! + ! + ! 3.6.4 Intra-spectral part 2 + ! IF ( FLCTH .OR. FLCK ) THEN - DO ITLOC=ITLOCH+1, NTLOC -! + DO ITLOC=ITLOCH+1, NTLOC + ! #ifdef W3_OMPG -!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) -!$OMP DO SCHEDULE (DYNAMIC,1) + !$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) + !$OMP DO SCHEDULE (DYNAMIC,1) #endif -! - DO JSEA = 1, NSEAL + ! + DO JSEA = 1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - DEPTH = MAX ( DMIN , DW(ISEA) ) + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + DEPTH = MAX ( DMIN , DW(ISEA) ) - IF ( GTYPE .EQ. UNGTYPE ) THEN - IF (LPDLIB) THEN + IF ( GTYPE .EQ. UNGTYPE ) THEN + IF (LPDLIB) THEN #ifdef W3_PDLIB - IF (IOBP_LOC(JSEA) .NE. 1) CYCLE + IF (IOBP_LOC(JSEA) .NE. 1) CYCLE #endif - ELSE - IF (IOBP(ISEA) .NE. 1) CYCLE - ENDIF + ELSE + IF (IOBP(ISEA) .NE. 1) CYCLE ENDIF + ENDIF - IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN - IF (LPDLIB) THEN - IXrel = JSEA - ELSE - IXrel = IX - END IF -! - IF( GTYPE .EQ. SMCTYPE ) THEN - J = 1 + IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN + IF (LPDLIB) THEN + IXrel = JSEA + ELSE + IXrel = IX + END IF + ! + IF( GTYPE .EQ. SMCTYPE ) THEN + J = 1 #ifdef W3_SMC - !!Li Refraction and GCT in theta direction is done by rotation. - CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & - CX(ISEA), CY(ISEA), DCXDX(IY,IX), & - DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & - DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) -#endif -! - ELSE - J = 1 + !!Li Refraction and GCT in theta direction is done by rotation. + CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & + CX(ISEA), CY(ISEA), DCXDX(IY,IX), & + DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & + DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) +#endif + ! + ELSE + J = 1 #ifdef W3_PR1 - CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) + CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) #endif #ifdef W3_PR2 - CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) + CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) #endif #ifdef W3_PR3 - CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & - CFLTHMAX(JSEA), CFLKMAX(JSEA) ) -#endif -! - END IF !! GTYPE -! - END IF - END DO -! + CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & + CFLTHMAX(JSEA), CFLKMAX(JSEA) ) +#endif + ! + END IF !! GTYPE + ! + END IF + END DO + ! #ifdef W3_OMPG -!$OMP END DO -!$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL #endif -! - END DO - END IF + ! + END DO + END IF #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After intraspectral adv.", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After intraspectral adv.", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("fter intraspectral adv.") + CALL PRINT_MY_TIME("fter intraspectral adv.") #endif -! + ! UGDTUPDATE = .FALSE. -! -! 3.6 End propapgation = = = = = = = = = = = = = = = = = = = = = = = = + ! + ! 3.6 End propapgation = = = = = = = = = = = = = = = = = = = = = = = = -! 3.7 Calculate and integrate source terms. -! - 370 CONTINUE + ! 3.7 Calculate and integrate source terms. + ! +370 CONTINUE IF ( FLSOU ) THEN -! + ! D50=0.0002 REFLEC(:)=0. REFLED(:)=0 PSIC=0. #ifdef W3_PDLIB #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT - CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD before W3SRCE_IMP_POST", 1) - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_POST", 1) - IF (DEBUG_NODE .le. NSEAL) THEN - WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE - WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VAOLD)=', sum(VAOLD(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) - END IF + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD before W3SRCE_IMP_POST", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_POST", 1) + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VAOLD)=', sum(VAOLD(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) + END IF #endif #endif -! + ! #ifdef W3_OMPG -!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DELA,DELX,DELY, & -!$OMP& REFLEC,REFLED,D50,PSIC,TMP1,TMP2,TMP3,TMP4) -!$OMP DO SCHEDULE (DYNAMIC,1) + !$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DELA,DELX,DELY, & + !$OMP& REFLEC,REFLED,D50,PSIC,TMP1,TMP2,TMP3,TMP4) + !$OMP DO SCHEDULE (DYNAMIC,1) #endif -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - DELA=1. - DELX=1. - DELY=1. + ! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + DELA=1. + DELX=1. + DELY=1. #ifdef W3_REF1 - IF (GTYPE.EQ.RLGTYPE) THEN - DELX=SX*CLATS(ISEA)/FACX - DELY=SY/FACX - DELA=DELX*DELY - END IF - IF (GTYPE.EQ.CLGTYPE) THEN -! Maybe what follows works also for RLGTYPE ... to be verified - DELX=HPFAC(IY,IX)/ FACX - DELY=HQFAC(IY,IX)/ FACX - DELA=DELX*DELY - END IF + IF (GTYPE.EQ.RLGTYPE) THEN + DELX=SX*CLATS(ISEA)/FACX + DELY=SY/FACX + DELA=DELX*DELY + END IF + IF (GTYPE.EQ.CLGTYPE) THEN + ! Maybe what follows works also for RLGTYPE ... to be verified + DELX=HPFAC(IY,IX)/ FACX + DELY=HQFAC(IY,IX)/ FACX + DELA=DELX*DELY + END IF #endif -! + ! #ifdef W3_REF1 - REFLEC=REFLC(:,ISEA) - REFLEC(4)=BERG(ISEA)*REFLEC(4) - REFLED=REFLD(:,ISEA) + REFLEC=REFLC(:,ISEA) + REFLEC(4)=BERG(ISEA)*REFLEC(4) + REFLED=REFLD(:,ISEA) #endif #ifdef W3_BT4 - D50=SED_D50(ISEA) - PSIC=SED_PSIC(ISEA) + D50=SED_D50(ISEA) + PSIC=SED_PSIC(ISEA) #endif - IF ( MAPSTA(IY,IX) .EQ. 1 .AND. FLAGST(ISEA)) THEN - TMP1 = WHITECAP(JSEA,1:4) - TMP2 = BEDFORMS(JSEA,1:3) - TMP3 = TAUBBL(JSEA,1:2) - TMP4 = TAUICE(JSEA,1:2) + IF ( MAPSTA(IY,IX) .EQ. 1 .AND. FLAGST(ISEA)) THEN + TMP1 = WHITECAP(JSEA,1:4) + TMP2 = BEDFORMS(JSEA,1:3) + TMP3 = TAUBBL(JSEA,1:2) + TMP4 = TAUICE(JSEA,1:2) #ifdef W3_PDLIB - IF (FSSOURCE) THEN - CALL W3SRCE(srce_imp_post,IT,ISEA,JSEA,IX,IY,IMOD, & - VAOLD(:,JSEA), VA(:,JSEA), & - VSioDummy,VDioDummy,SHAVETOT(JSEA), & - ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & - CG(1:NK,ISEA), CLATS(ISEA), DW(ISEA), U10(ISEA), & - U10D(ISEA), & + IF (FSSOURCE) THEN + CALL W3SRCE(srce_imp_post,IT,ISEA,JSEA,IX,IY,IMOD, & + VAOLD(:,JSEA), VA(:,JSEA), & + VSioDummy,VDioDummy,SHAVETOT(JSEA), & + ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & + CG(1:NK,ISEA), CLATS(ISEA), DW(ISEA), U10(ISEA), & + U10D(ISEA), & #ifdef W3_FLX5 - TAUA(ISEA), TAUADIR(ISEA), & -#endif - AS(ISEA), UST(ISEA), & - USTDIR(ISEA), CX(ISEA), CY(ISEA), & - ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & - ICEDMAX(ISEA), & - REFLEC, REFLED, DELX, DELY, DELA, & - TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & - FPIS(ISEA), DTDYN(JSEA), & - FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & - TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & - TAUWIY(JSEA), TAUWNX(JSEA), & - TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & - TWS(JSEA),PHIOC(JSEA), TMP1, D50, PSIC, TMP2,& - PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & - TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & - RHOAIR(ISEA), ASF(ISEA)) - ELSE + TAUA(ISEA), TAUADIR(ISEA), & +#endif + AS(ISEA), UST(ISEA), & + USTDIR(ISEA), CX(ISEA), CY(ISEA), & + ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & + ICEDMAX(ISEA), & + REFLEC, REFLED, DELX, DELY, DELA, & + TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & + FPIS(ISEA), DTDYN(JSEA), & + FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & + TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & + TAUWIY(JSEA), TAUWNX(JSEA), & + TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & + TWS(JSEA),PHIOC(JSEA), TMP1, D50, PSIC, TMP2,& + PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & + TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & + RHOAIR(ISEA), ASF(ISEA)) + ELSE #endif - CALL W3SRCE(srce_direct, IT, ISEA, JSEA, IX, IY, IMOD, & - VAoldDummy, VA(:,JSEA), & - VSioDummy, VDioDummy, SHAVETOTioDummy, & - ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & - CG(1:NK,ISEA), CLATS(ISEA), DW(ISEA), U10(ISEA), & - U10D(ISEA), & + CALL W3SRCE(srce_direct, IT, ISEA, JSEA, IX, IY, IMOD, & + VAoldDummy, VA(:,JSEA), & + VSioDummy, VDioDummy, SHAVETOTioDummy, & + ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & + CG(1:NK,ISEA), CLATS(ISEA), DW(ISEA), U10(ISEA), & + U10D(ISEA), & #ifdef W3_FLX5 - TAUA(ISEA), TAUADIR(ISEA), & -#endif - AS(ISEA), UST(ISEA), & - USTDIR(ISEA), CX(ISEA), CY(ISEA), & - ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & - ICEDMAX(ISEA), & - REFLEC, REFLED, DELX, DELY, DELA, & - TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & - FPIS(ISEA), DTDYN(JSEA), & - FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & - TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & - TAUWIY(JSEA), TAUWNX(JSEA), & - TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & - TWS(JSEA), PHIOC(JSEA), TMP1, D50, PSIC,TMP2,& - PHIBBL(JSEA), TMP3, TMP4 , PHICE(JSEA), & - TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & - RHOAIR(ISEA), ASF(ISEA)) + TAUA(ISEA), TAUADIR(ISEA), & +#endif + AS(ISEA), UST(ISEA), & + USTDIR(ISEA), CX(ISEA), CY(ISEA), & + ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & + ICEDMAX(ISEA), & + REFLEC, REFLED, DELX, DELY, DELA, & + TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & + FPIS(ISEA), DTDYN(JSEA), & + FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & + TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & + TAUWIY(JSEA), TAUWNX(JSEA), & + TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & + TWS(JSEA), PHIOC(JSEA), TMP1, D50, PSIC,TMP2,& + PHIBBL(JSEA), TMP3, TMP4 , PHICE(JSEA), & + TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & + RHOAIR(ISEA), ASF(ISEA)) #ifdef W3_PDLIB - END IF -#endif - WHITECAP(JSEA,1:4) = TMP1 - BEDFORMS(JSEA,1:3) = TMP2 - TAUBBL(JSEA,1:2) = TMP3 - TAUICE(JSEA,1:2) = TMP4 - ELSE - UST (ISEA) = UNDEF - USTDIR(ISEA) = UNDEF - DTDYN (JSEA) = UNDEF - FCUT (JSEA) = UNDEF -! VA(:,JSEA) = 0. END IF - END DO +#endif + WHITECAP(JSEA,1:4) = TMP1 + BEDFORMS(JSEA,1:3) = TMP2 + TAUBBL(JSEA,1:2) = TMP3 + TAUICE(JSEA,1:2) = TMP4 + ELSE + UST (ISEA) = UNDEF + USTDIR(ISEA) = UNDEF + DTDYN (JSEA) = UNDEF + FCUT (JSEA) = UNDEF + ! VA(:,JSEA) = 0. + END IF + END DO -! + ! #ifdef W3_OMPG -!$OMP END DO -!$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL #endif -! + ! #ifdef W3_PDLIB #ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT - CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD after W3SRCE_IMP_PRE_POST", 1) - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE_POST", 1) - IF (DEBUG_NODE .le. NSEAL) THEN - WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE - WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' min/max(VA)=', minval(VA(:,DEBUG_NODE)), maxval(VA(:,DEBUG_NODE)) - END IF + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD after W3SRCE_IMP_PRE_POST", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE_POST", 1) + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' min/max(VA)=', minval(VA(:,DEBUG_NODE)), maxval(VA(:,DEBUG_NODE)) + END IF #endif #endif - END IF + END IF #ifdef W3_DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After source terms", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After source terms") + CALL PRINT_MY_TIME("After source terms") #endif -! -! End of interations for DTMAX < 1s -! + ! + ! End of interations for DTMAX < 1s + ! #ifdef W3_SEC1 - IF (IT.EQ.0) EXIT - END DO - IF (IT.GT.0) DTG=DTGTEMP -#endif - -! -! -! 3.8 Update global time step. -! (Branch point FLDRY, IT=0) -! - 380 CONTINUE -! - IF (IT.NE.NT) THEN - DTTST = DSEC21 ( TIME , TCALC ) - DTG = DTTST / REAL(NT-IT) - END IF -! - IF ( FLACT .AND. IT.NE.NT .AND. IAPROC.EQ.NAPLOG ) THEN - CALL STME21 ( TIME , IDTIME ) - IF ( IDLAST .NE. TIME(1) ) THEN - WRITE (NDSO,900) ITIME, IPASS, IDTIME(01:19), & - IDACT, OUTID - IDLAST = TIME(1) - ELSE - WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & - IDACT, OUTID - END IF - FLACT = .FALSE. - IDACT = ' ' + IF (IT.EQ.0) EXIT + END DO + IF (IT.GT.0) DTG=DTGTEMP +#endif + + ! + ! + ! 3.8 Update global time step. + ! (Branch point FLDRY, IT=0) + ! +380 CONTINUE + ! + IF (IT.NE.NT) THEN + DTTST = DSEC21 ( TIME , TCALC ) + DTG = DTTST / REAL(NT-IT) + END IF + ! + IF ( FLACT .AND. IT.NE.NT .AND. IAPROC.EQ.NAPLOG ) THEN + CALL STME21 ( TIME , IDTIME ) + IF ( IDLAST .NE. TIME(1) ) THEN + WRITE (NDSO,900) ITIME, IPASS, IDTIME(01:19), & + IDACT, OUTID + IDLAST = TIME(1) + ELSE + WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & + IDACT, OUTID END IF -! + FLACT = .FALSE. + IDACT = ' ' + END IF + ! #ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "end of time loop", 1) + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "end of time loop", 1) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("end of time loop") + CALL PRINT_MY_TIME("end of time loop") #endif -! -! - END DO + ! + ! + END DO #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("W3WAVE, step 6.21.1") + CALL PRINT_MY_TIME("W3WAVE, step 6.21.1") #endif -! + ! #ifdef W3_T WRITE (NDST,9030) #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE END TIME LOOP' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! -! End of loop over time steps -! ==================================================================== / -! - 400 CONTINUE -! -! 4. Perform output to file if requested ---------------------------- / -! 4.a Check if time is output time -! Delay if data assimilation time. -! -! - IF ( TOFRST(1) .EQ. -1 ) THEN - DTTST = 1. - ELSE - DTTST = DSEC21 ( TIME, TOFRST ) - END IF -! - IF ( TDN(1) .EQ. -1 ) THEN - DTTST1 = 1. - ELSE - DTTST1 = DSEC21 ( TIME, TDN ) - END IF -! - DTTST2 = DSEC21 ( TIME, TEND ) - FLAG_O = .NOT.SKIP_O .OR. ( SKIP_O .AND. DTTST2.NE.0. ) -! + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE END TIME LOOP' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + ! + ! End of loop over time steps + ! ==================================================================== / + ! +400 CONTINUE + ! + ! 4. Perform output to file if requested ---------------------------- / + ! 4.a Check if time is output time + ! Delay if data assimilation time. + ! + ! + IF ( TOFRST(1) .EQ. -1 ) THEN + DTTST = 1. + ELSE + DTTST = DSEC21 ( TIME, TOFRST ) + END IF + ! + IF ( TDN(1) .EQ. -1 ) THEN + DTTST1 = 1. + ELSE + DTTST1 = DSEC21 ( TIME, TDN ) + END IF + ! + DTTST2 = DSEC21 ( TIME, TEND ) + FLAG_O = .NOT.SKIP_O .OR. ( SKIP_O .AND. DTTST2.NE.0. ) + ! #ifdef W3_T - WRITE (NDST,9040) TOFRST, TDN, DTTST, DTTST1, FLAG_O + WRITE (NDST,9040) TOFRST, TDN, DTTST, DTTST1, FLAG_O #endif -! - IF ( DTTST.LE.0. .AND. DTTST1.NE.0. .AND. FLAG_O ) THEN -! + ! + IF ( DTTST.LE.0. .AND. DTTST1.NE.0. .AND. FLAG_O ) THEN + ! #ifdef W3_T - WRITE (NDST,9041) + WRITE (NDST,9041) #endif -! -! 4.b Processing and MPP preparations -! - IF ( FLOUT(1) ) THEN - FLOUTG = DSEC21(TIME,TONEXT(:,1)).EQ.0. - ELSE - FLOUTG = .FALSE. - END IF -! - IF ( FLOUT(7) ) THEN - FLOUTG2 = DSEC21(TIME,TONEXT(:,7)).EQ.0. - ELSE - FLOUTG2 = .FALSE. - END IF -! - FLPART = .FALSE. - IF ( FLOUT(1) .AND. FLPFLD ) & - FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,1)).EQ.0. - IF ( FLOUT(6) ) & - FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,6)).EQ.0. -! + ! + ! 4.b Processing and MPP preparations + ! + IF ( FLOUT(1) ) THEN + FLOUTG = DSEC21(TIME,TONEXT(:,1)).EQ.0. + ELSE + FLOUTG = .FALSE. + END IF + ! + IF ( FLOUT(7) ) THEN + FLOUTG2 = DSEC21(TIME,TONEXT(:,7)).EQ.0. + ELSE + FLOUTG2 = .FALSE. + END IF + ! + FLPART = .FALSE. + IF ( FLOUT(1) .AND. FLPFLD ) & + FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,1)).EQ.0. + IF ( FLOUT(6) ) & + FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,6)).EQ.0. + ! #ifdef W3_T - WRITE (NDST,9042) LOCAL, FLPART, FLOUTG -#endif -! - IF ( LOCAL .AND. FLPART ) then - CALL W3CPRT ( IMOD ) - end IF - - do_w3outg = .false. - if (w3_cesmcoupled_flag .and. histwr) then - do_w3outg = .true. - else if ( LOCAL .AND. (FLOUTG .OR. FLOUTG2) ) then - do_w3outg = .true. - end if - if (do_w3outg) then - CALL W3OUTG ( VA, FLPFLD, FLOUTG, FLOUTG2 ) - end if -! + WRITE (NDST,9042) LOCAL, FLPART, FLOUTG +#endif + ! + IF ( LOCAL .AND. FLPART ) then + CALL W3CPRT ( IMOD ) + end IF + + do_w3outg = .false. + if (w3_cesmcoupled_flag .and. histwr) then + do_w3outg = .true. + else if ( LOCAL .AND. (FLOUTG .OR. FLOUTG2) ) then + do_w3outg = .true. + end if + if (do_w3outg) then + CALL W3OUTG ( VA, FLPFLD, FLOUTG, FLOUTG2 ) + end if + ! #ifdef W3_MPI - FLGMPI = .FALSE. - NRQMAX = 0 - ! - do_startall = .false. - if (w3_cesmcoupled_flag .and. histwr) then - IF ( FLOUT(1) .OR. FLOUT(7) ) THEN - do_startall = .true. - end IF - else - IF ( ( (DSEC21(TIME,TONEXT(:,1)).EQ.0.) .AND. FLOUT(1) ) .OR. & - ( (DSEC21(TIME,TONEXT(:,7)).EQ.0.) .AND. FLOUT(7) .AND. SBSED ) ) THEN - do_startall = .true. - end IF - end if - if (do_startall) then - IF (.NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE)) THEN - IF (NRQGO.NE.0 ) THEN - CALL MPI_STARTALL ( NRQGO, IRQGO , IERR_MPI ) - - FLGMPI(0) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQGO ) + FLGMPI = .FALSE. + NRQMAX = 0 + ! + do_startall = .false. + if (w3_cesmcoupled_flag .and. histwr) then + IF ( FLOUT(1) .OR. FLOUT(7) ) THEN + do_startall = .true. + end IF + else + IF ( ( (DSEC21(TIME,TONEXT(:,1)).EQ.0.) .AND. FLOUT(1) ) .OR. & + ( (DSEC21(TIME,TONEXT(:,7)).EQ.0.) .AND. FLOUT(7) .AND. SBSED ) ) THEN + do_startall = .true. + end IF + end if + if (do_startall) then + IF (.NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE)) THEN + IF (NRQGO.NE.0 ) THEN + CALL MPI_STARTALL ( NRQGO, IRQGO , IERR_MPI ) + + FLGMPI(0) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQGO ) #ifdef W3_MPIT - WRITE (NDST,9043) '1a', NRQGO, NRQMAX, NAPFLD + WRITE (NDST,9043) '1a', NRQGO, NRQMAX, NAPFLD #endif - END IF - ! - IF (NRQGO2.NE.0 ) THEN - CALL MPI_STARTALL ( NRQGO2, IRQGO2, IERR_MPI ) + END IF + ! + IF (NRQGO2.NE.0 ) THEN + CALL MPI_STARTALL ( NRQGO2, IRQGO2, IERR_MPI ) - FLGMPI(1) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQGO2 ) + FLGMPI(1) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQGO2 ) #ifdef W3_MPIT - WRITE (NDST,9043) '1b', NRQGO2, NRQMAX, NAPFLD + WRITE (NDST,9043) '1b', NRQGO2, NRQMAX, NAPFLD #endif - END IF - ELSE + END IF + ELSE #ifdef W3_PDLIB - CALL DO_OUTPUT_EXCHANGES(IMOD) + CALL DO_OUTPUT_EXCHANGES(IMOD) #endif - END IF ! IF (.NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE)) - END IF ! if (do_startall) + END IF ! IF (.NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE)) + END IF ! if (do_startall) #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 1' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif -! + ! #ifdef W3_MPI - IF ( FLOUT(2) .AND. NRQPO.NE.0 ) THEN - IF ( DSEC21(TIME,TONEXT(:,2)).EQ.0. ) THEN - CALL MPI_STARTALL ( NRQPO, IRQPO1, IERR_MPI ) - FLGMPI(2) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQPO ) + IF ( FLOUT(2) .AND. NRQPO.NE.0 ) THEN + IF ( DSEC21(TIME,TONEXT(:,2)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQPO, IRQPO1, IERR_MPI ) + FLGMPI(2) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQPO ) #endif #ifdef W3_MPIT - WRITE (NDST,9043) '2 ', NRQPO, NRQMAX, NAPPNT + WRITE (NDST,9043) '2 ', NRQPO, NRQMAX, NAPPNT #endif #ifdef W3_MPI - END IF - END IF + END IF + END IF #endif -! + ! #ifdef W3_MPI - IF ( FLOUT(4) .AND. NRQRS.NE.0 ) THEN - IF ( DSEC21(TIME,TONEXT(:,4)).EQ.0. ) THEN - CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) - FLGMPI(4) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQRS ) + IF ( FLOUT(4) .AND. NRQRS.NE.0 ) THEN + IF ( DSEC21(TIME,TONEXT(:,4)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) + FLGMPI(4) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQRS ) #endif #ifdef W3_MPIT - WRITE (NDST,9043) '4 ', NRQRS, NRQMAX, NAPRST + WRITE (NDST,9043) '4 ', NRQRS, NRQMAX, NAPRST #endif #ifdef W3_MPI - END IF - END IF + END IF + END IF #endif -! + ! #ifdef W3_MPI - IF ( FLOUT(8) .AND. NRQRS.NE.0 ) THEN - IF ( DSEC21(TIME,TONEXT(:,8)).EQ.0. ) THEN - CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) - FLGMPI(8) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQRS ) + IF ( FLOUT(8) .AND. NRQRS.NE.0 ) THEN + IF ( DSEC21(TIME,TONEXT(:,8)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) + FLGMPI(8) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQRS ) #endif #ifdef W3_MPIT - WRITE (NDST,9043) '8 ', NRQRS, NRQMAX, NAPRST + WRITE (NDST,9043) '8 ', NRQRS, NRQMAX, NAPRST #endif #ifdef W3_MPI - END IF - END IF + END IF + END IF #endif -! + ! #ifdef W3_MPI - IF ( FLOUT(5) .AND. NRQBP.NE.0 ) THEN - IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN - CALL MPI_STARTALL ( NRQBP , IRQBP1, IERR_MPI ) - FLGMPI(5) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQBP ) + IF ( FLOUT(5) .AND. NRQBP.NE.0 ) THEN + IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQBP , IRQBP1, IERR_MPI ) + FLGMPI(5) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQBP ) #endif #ifdef W3_MPIT - WRITE (NDST,9043) '5a', NRQBP, NRQMAX, NAPBPT + WRITE (NDST,9043) '5a', NRQBP, NRQMAX, NAPBPT #endif #ifdef W3_MPI - END IF - END IF + END IF + END IF #endif -! + ! #ifdef W3_MPI - IF ( FLOUT(5) .AND. NRQBP2.NE.0 .AND. IAPROC.EQ.NAPBPT) THEN - IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN - CALL MPI_STARTALL (NRQBP2,IRQBP2,IERR_MPI) - NRQMAX = MAX ( NRQMAX , NRQBP2 ) + IF ( FLOUT(5) .AND. NRQBP2.NE.0 .AND. IAPROC.EQ.NAPBPT) THEN + IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN + CALL MPI_STARTALL (NRQBP2,IRQBP2,IERR_MPI) + NRQMAX = MAX ( NRQMAX , NRQBP2 ) #endif #ifdef W3_MPIT - WRITE (NDST,9043) '5b', NRQBP2, NRQMAX, NAPBPT + WRITE (NDST,9043) '5b', NRQBP2, NRQMAX, NAPBPT #endif #ifdef W3_MPI - END IF - END IF + END IF + END IF #endif -! + ! #ifdef W3_MPI - IF ( NRQMAX .NE. 0 ) ALLOCATE ( STATIO(MPI_STATUS_SIZE,NRQMAX) ) + IF ( NRQMAX .NE. 0 ) ALLOCATE ( STATIO(MPI_STATUS_SIZE,NRQMAX) ) #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 2' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) #endif -! -! 4.c Reset next output time + ! + ! 4.c Reset next output time -! - TOFRST(1) = -1 - TOFRST(2) = 0 -! - DO J=1, NOTYPE + ! + TOFRST(1) = -1 + TOFRST(2) = 0 + ! + DO J=1, NOTYPE - IF ( FLOUT(J) ) THEN -! - ! - ! Determine output flags - ! - if (w3_sbs_flag) then - do_gridded_output = ( j .eq. 1 ) .or. ( j .eq. 7 ) - else - if (w3_cesmcoupled_flag) then - do_gridded_output = ( j .eq. 1 ) .and. histwr - else - do_gridded_output = ( j .eq. 1 ) - end if - end if - do_point_output = (j .eq. 2) - do_track_output = (j .eq. 3) - if (w3_cesmcoupled_flag) then - do_restart_output = (j .eq. 4) .and. rstwr - else - do_restart_output = (j .eq. 4) - end if - do_wavefield_separation_output = (j .eq. 5) - do_sf_output = (j .eq. 6) - do_coupler_output = (j .eq. 7) -! -! 4.d Perform output -! + IF ( FLOUT(J) ) THEN + ! + ! + ! Determine output flags + ! + if (w3_sbs_flag) then + do_gridded_output = ( j .eq. 1 ) .or. ( j .eq. 7 ) + else + if (w3_cesmcoupled_flag) then + do_gridded_output = ( j .eq. 1 ) .and. histwr + else + do_gridded_output = ( j .eq. 1 ) + end if + end if + do_point_output = (j .eq. 2) + do_track_output = (j .eq. 3) + if (w3_cesmcoupled_flag) then + do_restart_output = (j .eq. 4) .and. rstwr + else + do_restart_output = (j .eq. 4) + end if + do_wavefield_separation_output = (j .eq. 5) + do_sf_output = (j .eq. 6) + do_coupler_output = (j .eq. 7) + ! + ! 4.d Perform output + ! #ifdef W3_NL5 - IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) -#endif - TOUT(:) = TONEXT(:,J) - DTTST = DSEC21 ( TIME, TOUT ) -! - IF ( DTTST .EQ. 0. ) THEN - if (do_gridded_output) then - if (user_netcdf_grdout) then + IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) +#endif + TOUT(:) = TONEXT(:,J) + DTTST = DSEC21 ( TIME, TOUT ) + ! + IF ( DTTST .EQ. 0. ) THEN + if (do_gridded_output) then + if (user_netcdf_grdout) then #ifdef W3_MPI - CALL MPI_WAITALL( NRQGO, IRQGO, STATIO, IERR_MPI ) - FLGMPI(0) = .FALSE. + CALL MPI_WAITALL( NRQGO, IRQGO, STATIO, IERR_MPI ) + FLGMPI(0) = .FALSE. #endif - IF ( IAPROC .EQ. NAPFLD ) THEN + IF ( IAPROC .EQ. NAPFLD ) THEN #ifdef W3_MPI - IF ( FLGMPI(1) ) CALL MPI_WAITALL( NRQGO2, IRQGO2, STATIO, IERR_MPI ) - FLGMPI(1) = .FALSE. -#endif - CALL W3IOGONCD () - END IF - else - ! default (binary) output - IF ( IAPROC .EQ. NAPFLD ) THEN + IF ( FLGMPI(1) ) CALL MPI_WAITALL( NRQGO2, IRQGO2, STATIO, IERR_MPI ) + FLGMPI(1) = .FALSE. +#endif + CALL W3IOGONCD () + END IF + else + ! default (binary) output + IF ( IAPROC .EQ. NAPFLD ) THEN #ifdef W3_MPI - IF ( FLGMPI(1) ) CALL MPI_WAITALL( NRQGO2, IRQGO2, STATIO, IERR_MPI ) - FLGMPI(1) = .FALSE. -#endif - if (w3_sbs_flag) then - IF ( J .EQ. 1 ) THEN - CALL W3IOGO( 'WRITE', NDS(7), ITEST, IMOD ) - ENDIF - - ! Generate output flag file for fields and SBS coupling. - CALL STME21 ( TIME, IDTIME ) - FOUTNAME = 'Field_done.' // IDTIME(1:4) & - // IDTIME(6:7) // IDTIME(9:10) & - // IDTIME(12:13) // '.' // TRIM(FILEXT) - OPEN( UNIT=NDSOFLG, FILE=FOUTNAME) - CLOSE( NDSOFLG ) - else - CALL W3IOGO( 'WRITE', NDS(7), ITEST, IMOD ) - endif - end if - end if ! user_netcdf_grdout - - ELSE IF ( do_point_output ) THEN - IF ( IAPROC .EQ. NAPPNT ) THEN - CALL W3IOPE ( VA ) - CALL W3IOPO ( 'WRITE', NDS(8), ITEST, IMOD ) - END IF - - ELSE IF ( do_track_output ) THEN - CALL W3IOTR ( NDS(11), NDS(12), VA, IMOD ) - - ELSE IF ( do_restart_output ) THEN - CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) - ITEST = RSTYPE - - ELSE IF ( do_wavefield_separation_output ) THEN - IF ( IAPROC .EQ. NAPBPT ) THEN + IF ( FLGMPI(1) ) CALL MPI_WAITALL( NRQGO2, IRQGO2, STATIO, IERR_MPI ) + FLGMPI(1) = .FALSE. +#endif + if (w3_sbs_flag) then + IF ( J .EQ. 1 ) THEN + CALL W3IOGO( 'WRITE', NDS(7), ITEST, IMOD ) + ENDIF + + ! Generate output flag file for fields and SBS coupling. + CALL STME21 ( TIME, IDTIME ) + FOUTNAME = 'Field_done.' // IDTIME(1:4) & + // IDTIME(6:7) // IDTIME(9:10) & + // IDTIME(12:13) // '.' // TRIM(FILEXT) + OPEN( UNIT=NDSOFLG, FILE=FOUTNAME) + CLOSE( NDSOFLG ) + else + CALL W3IOGO( 'WRITE', NDS(7), ITEST, IMOD ) + endif + end if + end if ! user_netcdf_grdout + + ELSE IF ( do_point_output ) THEN + IF ( IAPROC .EQ. NAPPNT ) THEN + CALL W3IOPE ( VA ) + CALL W3IOPO ( 'WRITE', NDS(8), ITEST, IMOD ) + END IF + + ELSE IF ( do_track_output ) THEN + CALL W3IOTR ( NDS(11), NDS(12), VA, IMOD ) + + ELSE IF ( do_restart_output ) THEN + CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) + ITEST = RSTYPE + + ELSE IF ( do_wavefield_separation_output ) THEN + IF ( IAPROC .EQ. NAPBPT ) THEN #ifdef W3_MPI - IF (NRQBP2.NE.0) CALL MPI_WAITALL( NRQBP2, IRQBP2, STATIO, IERR_MPI ) + IF (NRQBP2.NE.0) CALL MPI_WAITALL( NRQBP2, IRQBP2, STATIO, IERR_MPI ) #endif - CALL W3IOBC ( 'WRITE', NDS(10), TIME, TIME, ITEST, IMOD ) - END IF - ELSE IF ( do_sf_output ) THEN - CALL W3IOSF ( NDS(13), IMOD ) + CALL W3IOBC ( 'WRITE', NDS(10), TIME, TIME, ITEST, IMOD ) + END IF + ELSE IF ( do_sf_output ) THEN + CALL W3IOSF ( NDS(13), IMOD ) #ifdef W3_OASIS - ELSE IF ( do_coupler_output ) THEN - ! - ! Send variables to atmospheric or ocean circulation or ice model - ! - IF (DTOUT(7).NE.0) THEN - IF ( (MOD(ID_OASIS_TIME,NINT(DTOUT(7))) .EQ. 0 ) .AND. & - (DSEC21 (TIME00, TIME) .GT. 0.0) ) THEN - IF ( (CPLT0 .AND. (DSEC21 (TIME, TIMEN) .GT. 0.0)) .OR. .NOT. CPLT0 ) THEN - IF (CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) + ELSE IF ( do_coupler_output ) THEN + ! + ! Send variables to atmospheric or ocean circulation or ice model + ! + IF (DTOUT(7).NE.0) THEN + IF ( (MOD(ID_OASIS_TIME,NINT(DTOUT(7))) .EQ. 0 ) .AND. & + (DSEC21 (TIME00, TIME) .GT. 0.0) ) THEN + IF ( (CPLT0 .AND. (DSEC21 (TIME, TIMEN) .GT. 0.0)) .OR. .NOT. CPLT0 ) THEN + IF (CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) #endif #ifdef W3_OASACM - CALL SND_FIELDS_TO_ATMOS() + CALL SND_FIELDS_TO_ATMOS() #endif #ifdef W3_OASOCM - CALL SND_FIELDS_TO_OCEAN() + CALL SND_FIELDS_TO_OCEAN() #endif #ifdef W3_OASICM - CALL SND_FIELDS_TO_ICE() + CALL SND_FIELDS_TO_ICE() #endif #ifdef W3_OASIS - IF (.NOT. CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) - ENDIF - ENDIF - ENDIF -#endif - END IF -! - CALL TICK21 ( TOUT, DTOUT(J) ) - TONEXT(:,J) = TOUT - TLST = TOLAST(:,J) - DTTST = DSEC21 ( TOUT , TLST ) - FLOUT(J) = DTTST.GE.0. - IF ( FLOUT(J) ) THEN - OUTID(2*J-1:2*J-1) = 'X' + IF (.NOT. CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) + ENDIF + ENDIF + ENDIF +#endif + END IF + ! + CALL TICK21 ( TOUT, DTOUT(J) ) + TONEXT(:,J) = TOUT + TLST = TOLAST(:,J) + DTTST = DSEC21 ( TOUT , TLST ) + FLOUT(J) = DTTST.GE.0. + IF ( FLOUT(J) ) THEN + OUTID(2*J-1:2*J-1) = 'X' #ifdef W3_OASIS - IF ( (DTOUT(7).NE.0) .AND. & - (DSEC21(TIME,TIME00).EQ.0 .OR. & - DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' + IF ( (DTOUT(7).NE.0) .AND. & + (DSEC21(TIME,TIME00).EQ.0 .OR. & + DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' #endif - ELSE - OUTID(2*J-1:2*J-1) = 'L' - END IF - END IF -! -! 4.e Update next output time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF - END IF - END IF -! + ELSE + OUTID(2*J-1:2*J-1) = 'L' + END IF + END IF + ! + ! 4.e Update next output time + ! + IF ( FLOUT(J) ) THEN + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT END IF -! - END DO -! + END IF + END IF + ! + END IF + ! + END DO + ! #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 3' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -! If there is a second stream of restart files then J=8 and FLOUT(8)=.TRUE. - J=8 + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + + ! If there is a second stream of restart files then J=8 and FLOUT(8)=.TRUE. + J=8 + IF ( FLOUT(J) ) THEN + ! + ! 4.d Perform output + ! + TOUT(:) = TONEXT(:,J) + DTTST = DSEC21 ( TIME, TOUT ) + IF ( DTTST .EQ. 0. ) THEN + CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) + ITEST = RSTYPE + CALL TICK21 ( TOUT, DTOUT(J) ) + TONEXT(:,J) = TOUT + TLST = TOLAST(:,J) + DTTST = DSEC21 ( TOUT , TLST ) + FLOUT(J) = DTTST.GE.0. IF ( FLOUT(J) ) THEN -! -! 4.d Perform output -! - TOUT(:) = TONEXT(:,J) - DTTST = DSEC21 ( TIME, TOUT ) - IF ( DTTST .EQ. 0. ) THEN - CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) - ITEST = RSTYPE - CALL TICK21 ( TOUT, DTOUT(J) ) - TONEXT(:,J) = TOUT - TLST = TOLAST(:,J) - DTTST = DSEC21 ( TOUT , TLST ) - FLOUT(J) = DTTST.GE.0. - IF ( FLOUT(J) ) THEN - OUTID(2*J-1:2*J-1) = 'X' + OUTID(2*J-1:2*J-1) = 'X' #ifdef W3_OASIS - IF ( (DTOUT(7).NE.0) .AND. & - (DSEC21(TIME,TIME00).EQ.0 .OR. & - DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' + IF ( (DTOUT(7).NE.0) .AND. & + (DSEC21(TIME,TIME00).EQ.0 .OR. & + DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' #endif - ELSE - OUTID(2*J-1:2*J-1) = 'L' - END IF - END IF -! -! 4.e Update next output time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF - END IF + ELSE + OUTID(2*J-1:2*J-1) = 'L' + END IF + END IF + ! + ! 4.e Update next output time + ! + IF ( FLOUT(J) ) THEN + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT END IF END IF -! END OF CHECKPOINT -! + END IF + END IF + ! END OF CHECKPOINT + ! #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 3' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif -! + ! #ifdef W3_MPI - IF ( FLGMPI(0) ) CALL MPI_WAITALL ( NRQGO, IRQGO , STATIO, IERR_MPI ) - if (user_netcdf_grdout) then - IF ( FLGMPI(1) .and. ( IAPROC .EQ. NAPFLD ) ) then - CALL MPI_WAITALL ( NRQGO2, IRQGO2 , STATIO, IERR_MPI ) - end if - end if - IF ( FLGMPI(2) ) CALL MPI_WAITALL ( NRQPO, IRQPO1, STATIO, IERR_MPI ) - IF ( FLGMPI(4) ) CALL MPI_WAITALL ( NRQRS, IRQRS , STATIO, IERR_MPI ) - IF ( FLGMPI(8) ) CALL MPI_WAITALL ( NRQRS, IRQRS , STATIO, IERR_MPI ) - IF ( FLGMPI(5) ) CALL MPI_WAITALL ( NRQBP, IRQBP1, STATIO, IERR_MPI ) - IF ( NRQMAX .NE. 0 ) DEALLOCATE ( STATIO ) -#endif -! + IF ( FLGMPI(0) ) CALL MPI_WAITALL ( NRQGO, IRQGO , STATIO, IERR_MPI ) + if (user_netcdf_grdout) then + IF ( FLGMPI(1) .and. ( IAPROC .EQ. NAPFLD ) ) then + CALL MPI_WAITALL ( NRQGO2, IRQGO2 , STATIO, IERR_MPI ) + end if + end if + IF ( FLGMPI(2) ) CALL MPI_WAITALL ( NRQPO, IRQPO1, STATIO, IERR_MPI ) + IF ( FLGMPI(4) ) CALL MPI_WAITALL ( NRQRS, IRQRS , STATIO, IERR_MPI ) + IF ( FLGMPI(8) ) CALL MPI_WAITALL ( NRQRS, IRQRS , STATIO, IERR_MPI ) + IF ( FLGMPI(5) ) CALL MPI_WAITALL ( NRQBP, IRQBP1, STATIO, IERR_MPI ) + IF ( NRQMAX .NE. 0 ) DEALLOCATE ( STATIO ) +#endif + ! #ifdef W3_T - WRITE (NDST,9044) + WRITE (NDST,9044) #endif - END IF + END IF #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before update log file") + CALL PRINT_MY_TIME("Before update log file") #endif #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 4' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -! -! 5. Update log file ------------------------------------------------ / -! - IF ( IAPROC.EQ.NAPLOG ) THEN -! - CALL STME21 ( TIME , IDTIME ) - IF ( FLCUR ) THEN - DTTST = DSEC21 ( TIME , TCN ) - IF ( DTTST .EQ. 0. ) IDACT(7:7) = 'X' - END IF - IF ( FLWIND ) THEN - DTTST = DSEC21 ( TIME , TWN ) - IF ( DTTST .EQ. 0. ) IDACT(3:3) = 'X' - END IF - IF ( FLTAUA ) THEN - DTTST = DSEC21 ( TIME , TUN ) - IF ( DTTST .EQ. 0. ) IDACT(9:9) = 'X' - END IF - IF ( FLRHOA ) THEN - DTTST = DSEC21 ( TIME , TRN ) - IF ( DTTST .EQ. 0. ) IDACT(11:11) = 'X' - END IF - IF ( TDN(1) .GT. 0 ) THEN - DTTST = DSEC21 ( TIME , TDN ) - IF ( DTTST .EQ. 0. ) IDACT(21:21) = 'X' - END IF -! - IF ( IDLAST.NE.TIME(1) ) THEN - WRITE (NDSO,900) ITIME, IPASS, IDTIME(1:19), & - IDACT, OUTID - IDLAST = TIME(1) - ELSE - WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & - IDACT, OUTID - END IF -! - END IF -! - IDACT = ' ' - OUTID = ' ' - FLACT = .FALSE. -! -! 6. If time is not ending time, branch back to 2 ------------------- / -! - DTTST = DSEC21 ( TIME, TEND ) - IF ( DTTST .EQ. 0. ) EXIT + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + + ! + ! 5. Update log file ------------------------------------------------ / + ! + IF ( IAPROC.EQ.NAPLOG ) THEN + ! + CALL STME21 ( TIME , IDTIME ) + IF ( FLCUR ) THEN + DTTST = DSEC21 ( TIME , TCN ) + IF ( DTTST .EQ. 0. ) IDACT(7:7) = 'X' + END IF + IF ( FLWIND ) THEN + DTTST = DSEC21 ( TIME , TWN ) + IF ( DTTST .EQ. 0. ) IDACT(3:3) = 'X' + END IF + IF ( FLTAUA ) THEN + DTTST = DSEC21 ( TIME , TUN ) + IF ( DTTST .EQ. 0. ) IDACT(9:9) = 'X' + END IF + IF ( FLRHOA ) THEN + DTTST = DSEC21 ( TIME , TRN ) + IF ( DTTST .EQ. 0. ) IDACT(11:11) = 'X' + END IF + IF ( TDN(1) .GT. 0 ) THEN + DTTST = DSEC21 ( TIME , TDN ) + IF ( DTTST .EQ. 0. ) IDACT(21:21) = 'X' + END IF + ! + IF ( IDLAST.NE.TIME(1) ) THEN + WRITE (NDSO,900) ITIME, IPASS, IDTIME(1:19), & + IDACT, OUTID + IDLAST = TIME(1) + ELSE + WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & + IDACT, OUTID + END IF + ! + END IF + ! + IDACT = ' ' + OUTID = ' ' + FLACT = .FALSE. + ! + ! 6. If time is not ending time, branch back to 2 ------------------- / + ! + DTTST = DSEC21 ( TIME, TEND ) + IF ( DTTST .EQ. 0. ) EXIT #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Continuing the loop") + CALL PRINT_MY_TIME("Continuing the loop") #endif - END DO + END DO #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 5' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! - - IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN - CALL WWTIME ( STTIME ) - WRITE (SCREEN,951) STTIME - END IF - - IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,902) -! - DEALLOCATE(FIELD) - DEALLOCATE(TAUWX, TAUWY) -! + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + ! + + IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN + CALL WWTIME ( STTIME ) + WRITE (SCREEN,951) STTIME + END IF + + IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,902) + ! + DEALLOCATE(FIELD) + DEALLOCATE(TAUWX, TAUWY) + ! #ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE END W3WAVE' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! - RETURN -! -! Formats -! - 900 FORMAT (4X,I6,'|',I6,'| ', A19 ,' | ',A,' | ',A,' |') - 901 FORMAT (4X,I6,'|',I6,'| ',11X,A8,' | ',A,' | ',A,' |') - 902 FORMAT (2X,'--------+------+---------------------+' & - ,'-----------------------+------------------+') -! + write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE END W3WAVE' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC+40000,mallInfos) +#endif + ! + RETURN + ! + ! Formats + ! +900 FORMAT (4X,I6,'|',I6,'| ', A19 ,' | ',A,' | ',A,' |') +901 FORMAT (4X,I6,'|',I6,'| ',11X,A8,' | ',A,' | ',A,' |') +902 FORMAT (2X,'--------+------+---------------------+' & + ,'-----------------------+------------------+') + ! #ifdef W3_IC3 - 920 FORMAT (' Updating k and Cg from ice param. 1,2,3,4.'/) -#endif - 950 FORMAT (' WAVEWATCH III calculating for ',A,' at ',A) - 951 FORMAT (' WAVEWATCH III reached the end of a computation', & - ' loop at ',A) - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' ENDING TIME BEFORE STARTING TIME '/) - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW WATER LEVEL BEFORE OLD WATER LEVEL '/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' ILLEGAL CURRENT INTERVAL '/) - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' ILLEGAL WIND INTERVAL '/) - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW ICE FIELD BEFORE OLD ICE FIELD '/) - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW IC1 FIELD BEFORE OLD IC1 FIELD '/) - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW ATM MOMENTUM BEFORE OLD ATM MOMENTUM '/) - 1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW AIR DENSITY BEFORE OLD AIR DENSITY '/) +920 FORMAT (' Updating k and Cg from ice param. 1,2,3,4.'/) +#endif +950 FORMAT (' WAVEWATCH III calculating for ',A,' at ',A) +951 FORMAT (' WAVEWATCH III reached the end of a computation', & + ' loop at ',A) +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' ENDING TIME BEFORE STARTING TIME '/) +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW WATER LEVEL BEFORE OLD WATER LEVEL '/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' ILLEGAL CURRENT INTERVAL '/) +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' ILLEGAL WIND INTERVAL '/) +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW ICE FIELD BEFORE OLD ICE FIELD '/) +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW IC1 FIELD BEFORE OLD IC1 FIELD '/) +1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW ATM MOMENTUM BEFORE OLD ATM MOMENTUM '/) +1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW AIR DENSITY BEFORE OLD AIR DENSITY '/) #ifdef W3_IS2 - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW IC5 FIELD BEFORE OLD IC5 FIELD '/) +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW IC5 FIELD BEFORE OLD IC5 FIELD '/) #endif - 1030 FORMAT (/' *** WAVEWATCH III WARING IN W3WAVE :'/ & - ' AT LEAST ONE PROCESSOR HAS 0 ACTIVE POINTS', & - ' IN GRID',I3) +1030 FORMAT (/' *** WAVEWATCH III WARING IN W3WAVE :'/ & + ' AT LEAST ONE PROCESSOR HAS 0 ACTIVE POINTS', & + ' IN GRID',I3) #ifdef W3_REFRX - 1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' EXPERIMENTAL FEATURE !/REFRX NOT FULLY IMPLEMENTED.'/) +1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' EXPERIMENTAL FEATURE !/REFRX NOT FULLY IMPLEMENTED.'/) #endif -! + ! #ifdef W3_T - 9000 FORMAT ( & - '============================================================', & - '===================='/ & - ' TEST W3WAVE : RUN MODEL',I3,' FILEXT [',A, & - '] UP TO ',I8.8,I7.6 / & - '====================', & - '============================================================') - 9010 FORMAT (' TEST W3WAVE : DT INT. =',F12.1,' FLZERO = ',L1) - 9011 FORMAT (' TEST W3WAVE : DT LEV. =',F12.1) - 9012 FORMAT (' TEST W3WAVE : DT CUR. =',F12.1/ & - ' ',F12.1/ & - ' ',F12.1) - 9013 FORMAT (' TEST W3WAVE : DT WIND =',F12.1/ & - ' ',F12.1/ & - ' ',F12.1) - 9014 FORMAT (' TEST W3WAVE : DT ICE =',F12.1) - 9015 FORMAT (' TEST W3WAVE : DT IC1 =',F12.1) - 9016 FORMAT (' TEST W3WAVE : DT IC5 =',F12.1) - 9017 FORMAT (' TEST W3WAVE : DT TAU =',F12.1) - 9018 FORMAT (' TEST W3WAVE : DT RHO =',F12.1) - 9020 FORMAT (' TEST W3WAVE : IT0, NT, DTG :',2I4,F8.1) - 9021 FORMAT (' TEST W3WAVE : ITIME etc',I6,I4,I10.8,I7.6,1X,2L1, & - 2F6.2,F7.1,F6.2) - 9022 FORMAT (' TEST W3WAVE : SKIP TO 400 IN 3.5') - 9023 FORMAT (' TEST W3WAVE : SKIP TO 380 IN 3.5') - 9030 FORMAT (' TEST W3WAVE : END OF COMPUTATION LOOP') - 9040 FORMAT (' TEST W3WAVE : CHECKING FOR OUTPUT'/ & - ' TOFRST :',I9.8,I7.6/ & - ' TND :',I9.8,I7.6/ & - ' DTTST[1], FLAG_O :',2F8.1,L4) - 9041 FORMAT (' TEST W3WAVE : PERFORMING OUTPUT') - 9042 FORMAT (' TEST W3WAVE : OUTPUT COMPUTATION FLAGS: ',3L2) +9000 FORMAT ( & + '============================================================', & + '===================='/ & + ' TEST W3WAVE : RUN MODEL',I3,' FILEXT [',A, & + '] UP TO ',I8.8,I7.6 / & + '====================', & + '============================================================') +9010 FORMAT (' TEST W3WAVE : DT INT. =',F12.1,' FLZERO = ',L1) +9011 FORMAT (' TEST W3WAVE : DT LEV. =',F12.1) +9012 FORMAT (' TEST W3WAVE : DT CUR. =',F12.1/ & + ' ',F12.1/ & + ' ',F12.1) +9013 FORMAT (' TEST W3WAVE : DT WIND =',F12.1/ & + ' ',F12.1/ & + ' ',F12.1) +9014 FORMAT (' TEST W3WAVE : DT ICE =',F12.1) +9015 FORMAT (' TEST W3WAVE : DT IC1 =',F12.1) +9016 FORMAT (' TEST W3WAVE : DT IC5 =',F12.1) +9017 FORMAT (' TEST W3WAVE : DT TAU =',F12.1) +9018 FORMAT (' TEST W3WAVE : DT RHO =',F12.1) +9020 FORMAT (' TEST W3WAVE : IT0, NT, DTG :',2I4,F8.1) +9021 FORMAT (' TEST W3WAVE : ITIME etc',I6,I4,I10.8,I7.6,1X,2L1, & + 2F6.2,F7.1,F6.2) +9022 FORMAT (' TEST W3WAVE : SKIP TO 400 IN 3.5') +9023 FORMAT (' TEST W3WAVE : SKIP TO 380 IN 3.5') +9030 FORMAT (' TEST W3WAVE : END OF COMPUTATION LOOP') +9040 FORMAT (' TEST W3WAVE : CHECKING FOR OUTPUT'/ & + ' TOFRST :',I9.8,I7.6/ & + ' TND :',I9.8,I7.6/ & + ' DTTST[1], FLAG_O :',2F8.1,L4) +9041 FORMAT (' TEST W3WAVE : PERFORMING OUTPUT') +9042 FORMAT (' TEST W3WAVE : OUTPUT COMPUTATION FLAGS: ',3L2) #endif #ifdef W3_MPIT - 9043 FORMAT (' TEST W3WAVE : TYPE, NRQ, NRQMAX, NA : ',A2,3I6) +9043 FORMAT (' TEST W3WAVE : TYPE, NRQ, NRQMAX, NA : ',A2,3I6) #endif #ifdef W3_T - 9044 FORMAT (' TEST W3WAVE : END OF OUTPUT') -#endif -!/ -!/ End of W3WAVE ----------------------------------------------------- / -!/ - END SUBROUTINE W3WAVE -!/ ------------------------------------------------------------------- / -!> -!> @brief Gather spectral bin information into a propagation field array. -!> -!> @details Direct copy or communication calls (MPP version). -!> The field is extracted but not converted. -!> -!> MPI version requires posing of send and receive calls in -!> W3WAVE to match local calls. -!> -!> MPI version does not require an MPI_TESTALL call for the -!> posted gather operation as MPI_WAITALL is mandatory to -!> reset persistent communication for next time step. -!> -!> MPI version allows only two new pre-fetch postings per -!> call to minimize chances to be slowed down by gathers that -!> are not yet needed, while maximizing the pre-loading -!> during the early (low-frequency) calls to the routine -!> where the amount of calculation needed for proagation is -!> the largest. -!> -!> @param[in] ISPEC Spectral bin considered. -!> @param[out] FIELD Full field to be propagated. -!> -!> @author H. L. Tolman @date 26-Dec-2012 -!> - SUBROUTINE W3GATH ( ISPEC, FIELD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2012 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) -!/ -! 1. Purpose : -! -! Gather spectral bin information into a propagation field array. -! -! 2. Method : -! -! Direct copy or communication calls (MPP version). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISPEC Int. I Spectral bin considered. -! FIELD R.A. O Full field to be propagated. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_STARTALL, MPI_WAITALL -! Subr. mpif.h MPI persistent comm. routines (!/MPI). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The field is extracted but not converted. -! - MPI version requires posing of send and receive calls in -! W3WAVE to match local calls. -! - MPI version does not require an MPI_TESTALL call for the -! posted gather operation as MPI_WAITALL is mandatory to -! reset persistent communication for next time step. -! - MPI version allows only two new pre-fetch postings per -! call to minimize chances to be slowed down by gathers that -! are not yet needed, while maximizing the pre-loading -! during the early (low-frequency) calls to the routine -! where the amount of calculation needed for proagation is -! the largest. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/MPIT MPI test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +9044 FORMAT (' TEST W3WAVE : END OF OUTPUT') +#endif + !/ + !/ End of W3WAVE ----------------------------------------------------- / + !/ + END SUBROUTINE W3WAVE + !/ ------------------------------------------------------------------- / + !> + !> @brief Gather spectral bin information into a propagation field array. + !> + !> @details Direct copy or communication calls (MPP version). + !> The field is extracted but not converted. + !> + !> MPI version requires posing of send and receive calls in + !> W3WAVE to match local calls. + !> + !> MPI version does not require an MPI_TESTALL call for the + !> posted gather operation as MPI_WAITALL is mandatory to + !> reset persistent communication for next time step. + !> + !> MPI version allows only two new pre-fetch postings per + !> call to minimize chances to be slowed down by gathers that + !> are not yet needed, while maximizing the pre-loading + !> during the early (low-frequency) calls to the routine + !> where the amount of calculation needed for proagation is + !> the largest. + !> + !> @param[in] ISPEC Spectral bin considered. + !> @param[out] FIELD Full field to be propagated. + !> + !> @author H. L. Tolman @date 26-Dec-2012 + !> + SUBROUTINE W3GATH ( ISPEC, FIELD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Dec-2012 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) + !/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) + !/ + ! 1. Purpose : + ! + ! Gather spectral bin information into a propagation field array. + ! + ! 2. Method : + ! + ! Direct copy or communication calls (MPP version). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISPEC Int. I Spectral bin considered. + ! FIELD R.A. O Full field to be propagated. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_STARTALL, MPI_WAITALL + ! Subr. mpif.h MPI persistent comm. routines (!/MPI). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - The field is extracted but not converted. + ! - MPI version requires posing of send and receive calls in + ! W3WAVE to match local calls. + ! - MPI version does not require an MPI_TESTALL call for the + ! posted gather operation as MPI_WAITALL is mandatory to + ! reset persistent communication for next time step. + ! - MPI version allows only two new pre-fetch postings per + ! call to minimize chances to be slowed down by gathers that + ! are not yet needed, while maximizing the pre-loading + ! during the early (low-frequency) calls to the routine + ! where the amount of calculation needed for proagation is + ! the largest. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for message passing method. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/MPIT MPI test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, MAPSF, DMIN - USE W3PARALL, ONLY: INIT_GET_ISEA - USE W3WDATMD, ONLY: A => VA + !/ + USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, MAPSF, DMIN + USE W3PARALL, ONLY: INIT_GET_ISEA + USE W3WDATMD, ONLY: A => VA #ifdef W3_MPI - USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & - NSPLOC, NRQSG2, IRQSG2, GSTORE - USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NOTYPE + USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & + NSPLOC, NRQSG2, IRQSG2, GSTORE + USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NOTYPE #endif -!/ -! + !/ + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISPEC - REAL, INTENT(OUT) :: FIELD(1-NY:NY*(NX+2)) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISPEC + REAL, INTENT(OUT) :: FIELD(1-NY:NY*(NX+2)) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_SHRD - INTEGER :: ISEA, IXY + INTEGER :: ISEA, IXY #endif #ifdef W3_MPI - INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC), & - IOFF, IERR_MPI, JSEA, ISEA, & - IXY, IS0, IB0, NPST, J + INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC), & + IOFF, IERR_MPI, JSEA, ISEA, & + IXY, IS0, IB0, NPST, J #endif #ifdef W3_S - INTEGER, SAVE :: IENT + INTEGER, SAVE :: IENT #endif #ifdef W3_MPIT - CHARACTER(LEN=15) :: STR(MPIBUF), STRT + CHARACTER(LEN=15) :: STR(MPIBUF), STRT #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3GATH') + CALL STRACE (IENT, 'W3GATH') #endif -! - FIELD = 0. -! -! 1. Shared memory version ------------------------------------------ / -! + ! + FIELD = 0. + ! + ! 1. Shared memory version ------------------------------------------ / + ! #ifdef W3_SHRD - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - FIELD(IXY) = A(ISPEC,ISEA) - END DO + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + FIELD(IXY) = A(ISPEC,ISEA) + END DO #endif -! + ! #ifdef W3_SHRD - RETURN + RETURN #endif -! -! 2. Distributed memory version ( MPI ) ----------------------------- / -! 2.a Update counters -! + ! + ! 2. Distributed memory version ( MPI ) ----------------------------- / + ! 2.a Update counters + ! #ifdef W3_MPI - ISPLOC = ISPLOC + 1 - IBFLOC = IBFLOC + 1 - IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 + ISPLOC = ISPLOC + 1 + IBFLOC = IBFLOC + 1 + IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 #endif -! + ! #ifdef W3_MPIT - IF ( ISPLOC .EQ. 1 ) THEN - STR = '--------------+' - WRITE (NDST,9000) STR - END IF - STR = ' |' - STRT = STR(IBFLOC) - STRT(9:9) = 'A' -#endif -! -! 2.b Check status of present buffer -! 2.b.1 Scatter (send) still in progress, wait to end -! + IF ( ISPLOC .EQ. 1 ) THEN + STR = '--------------+' + WRITE (NDST,9000) STR + END IF + STR = ' |' + STRT = STR(IBFLOC) + STRT(9:9) = 'A' +#endif + ! + ! 2.b Check status of present buffer + ! 2.b.1 Scatter (send) still in progress, wait to end + ! #ifdef W3_MPI - IF ( BSTAT(IBFLOC) .EQ. 2 ) THEN - IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & - STATUS, IERR_MPI ) - BSTAT(IBFLOC) = 0 + IF ( BSTAT(IBFLOC) .EQ. 2 ) THEN + IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + BSTAT(IBFLOC) = 0 #endif #ifdef W3_MPIT - STRT(13:13) = 'S' + STRT(13:13) = 'S' #endif #ifdef W3_MPI - END IF + END IF #endif -! -! 2.b.2 Gather (recv) not yet posted, post now -! + ! + ! 2.b.2 Gather (recv) not yet posted, post now + ! #ifdef W3_MPI - IF ( BSTAT(IBFLOC) .EQ. 0 ) THEN - BSTAT(IBFLOC) = 1 - BISPL(IBFLOC) = ISPLOC - IOFF = 1 + (ISPLOC-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) + IF ( BSTAT(IBFLOC) .EQ. 0 ) THEN + BSTAT(IBFLOC) = 1 + BISPL(IBFLOC) = ISPLOC + IOFF = 1 + (ISPLOC-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) #endif #ifdef W3_MPIT - STRT(10:10) = 'g' + STRT(10:10) = 'g' #endif #ifdef W3_MPI - END IF + END IF #endif -! -! 2.c Put local spectral densities in store -! + ! + ! 2.c Put local spectral densities in store + ! #ifdef W3_MPI - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - GSTORE(ISEA,IBFLOC) = A(ISPEC,JSEA) - END DO -#endif -! -! 2.d Wait for remote spectral densities -! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + GSTORE(ISEA,IBFLOC) = A(ISPEC,JSEA) + END DO +#endif + ! + ! 2.d Wait for remote spectral densities + ! #ifdef W3_MPI - IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI ) + IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI ) #endif -! + ! #ifdef W3_MPIT - STRT(11:11) = 'G' - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC - STR(IBFLOC) = STRT + STRT(11:11) = 'G' + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC + STR(IBFLOC) = STRT #endif -! -! 2.e Convert storage array to field. -! + ! + ! 2.e Convert storage array to field. + ! #ifdef W3_MPI - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - FIELD(IXY) = GSTORE(ISEA,IBFLOC) - END DO -#endif -! -! 2.f Pre-fetch data in available buffers -! + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + FIELD(IXY) = GSTORE(ISEA,IBFLOC) + END DO +#endif + ! + ! 2.f Pre-fetch data in available buffers + ! #ifdef W3_MPI - IS0 = ISPLOC - IB0 = IBFLOC - NPST = 0 + IS0 = ISPLOC + IB0 = IBFLOC + NPST = 0 #endif -! + ! #ifdef W3_MPI - DO J=1, MPIBUF-1 - IS0 = IS0 + 1 - IF ( IS0 .GT. NSPLOC ) EXIT - IB0 = 1 + MOD(IB0,MPIBUF) - IF ( BSTAT(IB0) .EQ. 0 ) THEN - BSTAT(IB0) = 1 - BISPL(IB0) = IS0 - IOFF = 1 + (IS0-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) - NPST = NPST + 1 + DO J=1, MPIBUF-1 + IS0 = IS0 + 1 + IF ( IS0 .GT. NSPLOC ) EXIT + IB0 = 1 + MOD(IB0,MPIBUF) + IF ( BSTAT(IB0) .EQ. 0 ) THEN + BSTAT(IB0) = 1 + BISPL(IB0) = IS0 + IOFF = 1 + (IS0-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) + NPST = NPST + 1 #endif #ifdef W3_MPIT - STRT = STR(IB0) - STRT(10:10) = 'g' - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) - STR(IB0) = STRT + STRT = STR(IB0) + STRT(10:10) = 'g' + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + STR(IB0) = STRT #endif #ifdef W3_MPI - END IF - IF ( NPST .GE. 2 ) EXIT - END DO + END IF + IF ( NPST .GE. 2 ) EXIT + END DO #endif -! -! 2.g Test output -! + ! + ! 2.g Test output + ! #ifdef W3_MPIT - DO IB0=1, MPIBUF - STRT = STR(IB0) - IF ( STRT(2:2) .EQ. ' ' ) THEN - IF ( BSTAT(IB0) .EQ. 0 ) THEN - WRITE (STRT(1:2),'(I2)') BSTAT(IB0) - ELSE - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) - END IF - STR(IB0) = STRT - END IF - END DO - WRITE (NDST,9010) ISPLOC, STR + DO IB0=1, MPIBUF + STRT = STR(IB0) + IF ( STRT(2:2) .EQ. ' ' ) THEN + IF ( BSTAT(IB0) .EQ. 0 ) THEN + WRITE (STRT(1:2),'(I2)') BSTAT(IB0) + ELSE + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + END IF + STR(IB0) = STRT + END IF + END DO + WRITE (NDST,9010) ISPLOC, STR #endif -! + ! #ifdef W3_MPI - RETURN + RETURN #endif -! -! Formats -! + ! + ! Formats + ! #ifdef W3_MPIT - 9000 FORMAT ( ' TEST OF BUFFER MANAGEMENT MPI :'/ & - ' -------------------------------'/ & - ' RECORDS ALTERNATELY WRITTEN BY W3GATH AND W3SCAT'/ & - ' FRIST COLLUMN : LOCAL ISPEC'/ & - ' OTHER COLLUMNS : BUFFER STATUS INDICATOR '/ & - ' 0 : INACTIVE'/ & - ' 1 : RECEIVING'/ & - ' 2 : SENDING'/ & - ' LOCAL ISPEC FOR BUFFER'/ & - ' A : ACTIVE BUFFER'/ & - ' g/G: START/FINISH RECIEVE'/ & - ' s/S: START/FINISH SEND'/ & - ' +-----+',8A15) - 9010 FORMAT ( ' |',I4,' |',8A15) -#endif -!/ -!/ End of W3GATH ----------------------------------------------------- / -!/ - END SUBROUTINE W3GATH -!/ ------------------------------------------------------------------- / -!> -!> @brief Scatter data back to spectral storage after propagation. -!> -!> @details Direct copy or communication calls (MPP version). See also W3GATH. -!> The field is put back but not converted! -!> MPI persistent communication calls initialize in W3MPII. -!> See W3GATH and W3MPII for additional comments on data buffering. -!> -!> @param[inout] ISPEC Spectral bin considered. -!> @param[inout] MAPSTA Status map for spatial grid. -!> @param[inout] FIELD Full field to be propagated. -!> -!> @author H. L. Tolman @date 13-Jun-2006 -!> - SUBROUTINE W3SCAT ( ISPEC, MAPSTA, FIELD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jun-2006 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ -! 1. Purpose : -! -! 'Scatter' data back to spectral storage after propagation. -! -! 2. Method : -! -! Direct copy or communication calls (MPP version). -! See also W3GATH. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISPEC Int. I Spectral bin considered. -! MAPSTA I.A. I Status map for spatial grid. -! FIELD R.A. I Full field to be propagated. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_STARTALL, MPI_WAITALL, MPI_TESTALL -! Subr. mpif.h MPI persistent comm. routines (!/MPI). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The field is put back but not converted ! -! - MPI persistent communication calls initialize in W3MPII. -! - See W3GATH and W3MPII for additional comments on data -! buffering. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/MPIT MPI test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NSEA, NSEAL, MAPSF, NSPEC, NX, NY +9000 FORMAT ( ' TEST OF BUFFER MANAGEMENT MPI :'/ & + ' -------------------------------'/ & + ' RECORDS ALTERNATELY WRITTEN BY W3GATH AND W3SCAT'/ & + ' FRIST COLLUMN : LOCAL ISPEC'/ & + ' OTHER COLLUMNS : BUFFER STATUS INDICATOR '/ & + ' 0 : INACTIVE'/ & + ' 1 : RECEIVING'/ & + ' 2 : SENDING'/ & + ' LOCAL ISPEC FOR BUFFER'/ & + ' A : ACTIVE BUFFER'/ & + ' g/G: START/FINISH RECIEVE'/ & + ' s/S: START/FINISH SEND'/ & + ' +-----+',8A15) +9010 FORMAT ( ' |',I4,' |',8A15) +#endif + !/ + !/ End of W3GATH ----------------------------------------------------- / + !/ + END SUBROUTINE W3GATH + !/ ------------------------------------------------------------------- / + !> + !> @brief Scatter data back to spectral storage after propagation. + !> + !> @details Direct copy or communication calls (MPP version). See also W3GATH. + !> The field is put back but not converted! + !> MPI persistent communication calls initialize in W3MPII. + !> See W3GATH and W3MPII for additional comments on data buffering. + !> + !> @param[inout] ISPEC Spectral bin considered. + !> @param[inout] MAPSTA Status map for spatial grid. + !> @param[inout] FIELD Full field to be propagated. + !> + !> @author H. L. Tolman @date 13-Jun-2006 + !> + SUBROUTINE W3SCAT ( ISPEC, MAPSTA, FIELD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jun-2006 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) + !/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) + !/ + ! 1. Purpose : + ! + ! 'Scatter' data back to spectral storage after propagation. + ! + ! 2. Method : + ! + ! Direct copy or communication calls (MPP version). + ! See also W3GATH. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISPEC Int. I Spectral bin considered. + ! MAPSTA I.A. I Status map for spatial grid. + ! FIELD R.A. I Full field to be propagated. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_STARTALL, MPI_WAITALL, MPI_TESTALL + ! Subr. mpif.h MPI persistent comm. routines (!/MPI). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - The field is put back but not converted ! + ! - MPI persistent communication calls initialize in W3MPII. + ! - See W3GATH and W3MPII for additional comments on data + ! buffering. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for message passing method. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/MPIT MPI test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NSEA, NSEAL, MAPSF, NSPEC, NX, NY #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3WDATMD, ONLY: A => VA + !/ + USE W3WDATMD, ONLY: A => VA #ifdef W3_MPI - USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & - NSPLOC, NRQSG2, IRQSG2, SSTORE + USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & + NSPLOC, NRQSG2, IRQSG2, SSTORE #endif - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #ifdef W3_MPI - USE W3ODATMD, ONLY: IAPROC, NAPROC + USE W3ODATMD, ONLY: IAPROC, NAPROC #endif - USE CONSTANTS, ONLY : LPDLIB - USE W3PARALL, only: INIT_GET_ISEA -!/ -! + USE CONSTANTS, ONLY : LPDLIB + USE W3PARALL, only: INIT_GET_ISEA + !/ + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISPEC, MAPSTA(NY*NX) - REAL, INTENT(IN) :: FIELD(1-NY:NY*(NX+2)) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ISPEC, MAPSTA(NY*NX) + REAL, INTENT(IN) :: FIELD(1-NY:NY*(NX+2)) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_SHRD - INTEGER :: ISEA, IXY + INTEGER :: ISEA, IXY #endif #ifdef W3_MPI - INTEGER :: ISEA, IXY, IOFF, IERR_MPI, J, & - STATUS(MPI_STATUS_SIZE,NSPEC), & - JSEA, IB0 + INTEGER :: ISEA, IXY, IOFF, IERR_MPI, J, & + STATUS(MPI_STATUS_SIZE,NSPEC), & + JSEA, IB0 #endif #ifdef W3_S - INTEGER, SAVE :: IENT + INTEGER, SAVE :: IENT #endif #ifdef W3_MPIT - CHARACTER(LEN=15) :: STR(MPIBUF), STRT + CHARACTER(LEN=15) :: STR(MPIBUF), STRT #endif #ifdef W3_MPI - LOGICAL :: DONE + LOGICAL :: DONE #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SCAT') + CALL STRACE (IENT, 'W3SCAT') #endif -! -! 1. Shared memory version ------------------------------------------ * -! + ! + ! 1. Shared memory version ------------------------------------------ * + ! #ifdef W3_SHRD - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .NE. 0 ) A(ISPEC,ISEA) = FIELD(IXY) - END DO + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .NE. 0 ) A(ISPEC,ISEA) = FIELD(IXY) + END DO #endif -! + ! #ifdef W3_SHRD - RETURN + RETURN #endif -! -! 2. Distributed memory version ( MPI ) ----------------------------- * -! 2.a Initializations -! + ! + ! 2. Distributed memory version ( MPI ) ----------------------------- * + ! 2.a Initializations + ! #ifdef W3_MPIT - DO IB0=1, MPIBUF - STR(IB0) = ' |' - END DO + DO IB0=1, MPIBUF + STR(IB0) = ' |' + END DO #endif -! + ! #ifdef W3_MPIT - STRT = STR(IBFLOC) - STRT(9:9) = 'A' + STRT = STR(IBFLOC) + STRT(9:9) = 'A' #endif -! -! 2.b Convert full grid to sea grid, active points only -! + ! + ! 2.b Convert full grid to sea grid, active points only + ! #ifdef W3_MPI - DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .NE. 0 ) SSTORE(ISEA,IBFLOC) = FIELD(IXY) - END DO -#endif -! -! 2.c Send spectral densities to appropriate remote -! + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .NE. 0 ) SSTORE(ISEA,IBFLOC) = FIELD(IXY) + END DO +#endif + ! + ! 2.c Send spectral densities to appropriate remote + ! #ifdef W3_MPI - IOFF = 1 + (ISPLOC-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI ) - BSTAT(IBFLOC) = 2 + IOFF = 1 + (ISPLOC-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI ) + BSTAT(IBFLOC) = 2 #endif #ifdef W3_MPIT - STRT(12:12) = 's' - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC - STR(IBFLOC) = STRT + STRT(12:12) = 's' + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC + STR(IBFLOC) = STRT #endif -! -! 2.d Save locally stored results -! + ! + ! 2.d Save locally stored results + ! #ifdef W3_MPI - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IXY = MAPSF(ISEA,3) - IF (MAPSTA(IXY) .NE. 0) A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC) - END DO -#endif -! -! 2.e Check if any sends have finished -! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IXY = MAPSF(ISEA,3) + IF (MAPSTA(IXY) .NE. 0) A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC) + END DO +#endif + ! + ! 2.e Check if any sends have finished + ! #ifdef W3_MPI - IB0 = IBFLOC + IB0 = IBFLOC #endif -! + ! #ifdef W3_MPI - DO J=1, MPIBUF - IB0 = 1 + MOD(IB0,MPIBUF) - IF ( BSTAT(IB0) .EQ. 2 ) THEN - IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) THEN - CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, STATUS, IERR_MPI ) - ELSE - DONE = .TRUE. - END IF - IF ( DONE .AND. NRQSG2.GT.0 ) THEN - CALL MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), STATUS, IERR_MPI ) - END IF - IF ( DONE ) THEN - BSTAT(IB0) = 0 + DO J=1, MPIBUF + IB0 = 1 + MOD(IB0,MPIBUF) + IF ( BSTAT(IB0) .EQ. 2 ) THEN + IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) THEN + CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, STATUS, IERR_MPI ) + ELSE + DONE = .TRUE. + END IF + IF ( DONE .AND. NRQSG2.GT.0 ) THEN + CALL MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), STATUS, IERR_MPI ) + END IF + IF ( DONE ) THEN + BSTAT(IB0) = 0 #endif #ifdef W3_MPIT - STRT = STR(IB0) - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) - STRT(13:13) = 'S' - STR(IB0) = STRT + STRT = STR(IB0) + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + STRT(13:13) = 'S' + STR(IB0) = STRT #endif #ifdef W3_MPI - END IF - END IF - END DO + END IF + END IF + END DO #endif -! -! 2.f Last component, finish message passing, reset buffer control -! + ! + ! 2.f Last component, finish message passing, reset buffer control + ! #ifdef W3_MPI - IF ( ISPLOC .EQ. NSPLOC ) THEN + IF ( ISPLOC .EQ. NSPLOC ) THEN #endif -! + ! #ifdef W3_MPI - DO IB0=1, MPIBUF - IF ( BSTAT(IB0) .EQ. 2 ) THEN - IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & - STATUS, IERR_MPI ) - BSTAT(IB0) = 0 + DO IB0=1, MPIBUF + IF ( BSTAT(IB0) .EQ. 2 ) THEN + IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + BSTAT(IB0) = 0 #endif #ifdef W3_MPIT - STRT = STR(IB0) - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) - STRT(13:13) = 'S' - STR(IB0) = STRT + STRT = STR(IB0) + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + STRT(13:13) = 'S' + STR(IB0) = STRT #endif #ifdef W3_MPI - END IF - END DO + END IF + END DO #endif -! + ! #ifdef W3_MPI - ISPLOC = 0 - IBFLOC = 0 + ISPLOC = 0 + IBFLOC = 0 #endif -! + ! #ifdef W3_MPI - END IF + END IF #endif -! -! 2.g Test output -! + ! + ! 2.g Test output + ! #ifdef W3_MPIT - DO IB0=1, MPIBUF - STRT = STR(IB0) - IF ( STRT(2:2) .EQ. ' ' ) THEN - IF ( BSTAT(IB0) .EQ. 0 ) THEN - WRITE (STRT(1:2),'(I2)') BSTAT(IB0) - ELSE - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) - END IF - STR(IB0) = STRT - END IF - END DO + DO IB0=1, MPIBUF + STRT = STR(IB0) + IF ( STRT(2:2) .EQ. ' ' ) THEN + IF ( BSTAT(IB0) .EQ. 0 ) THEN + WRITE (STRT(1:2),'(I2)') BSTAT(IB0) + ELSE + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + END IF + STR(IB0) = STRT + END IF + END DO #endif -! + ! #ifdef W3_MPIT - WRITE (NDST,9000) STR + WRITE (NDST,9000) STR #endif -! + ! #ifdef W3_MPIT - IF ( ISPLOC .EQ. 0 ) THEN - DO IB0=1, MPIBUF - STR(IB0) = '--------------+' - END DO - WRITE (NDST,9010) STR - WRITE (NDST,*) - END IF + IF ( ISPLOC .EQ. 0 ) THEN + DO IB0=1, MPIBUF + STR(IB0) = '--------------+' + END DO + WRITE (NDST,9010) STR + WRITE (NDST,*) + END IF #endif -! + ! #ifdef W3_MPI - RETURN + RETURN #endif -! -! Formats -! + ! + ! Formats + ! #ifdef W3_MPIT - 9000 FORMAT ( ' | |',8A15) - 9010 FORMAT ( ' +-----+',8A15) -#endif -!/ -!/ End of W3SCAT ----------------------------------------------------- / -!/ - END SUBROUTINE W3SCAT -!/ ------------------------------------------------------------------- / -!> -!> @brief Check minimum number of active sea points at given processor to -!> evaluate the need for a MPI_BARRIER call. -!> -!> @param[in] MAPSTA Status map for spatial grid. -!> @param[out] FLAG0 Flag to identify 0 as minimum. -!> -!> @author H. L. Tolman @date 28-Dec-2004 -!> - SUBROUTINE W3NMIN ( MAPSTA, FLAG0 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 28-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 23-Feb-2001 : Origination. ( version 2.07 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Check minimum number of active sea points at given processor to -! evaluate the need for a MPI_BARRIER call. -! -! 2. Method : -! -! Evaluate mapsta. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MAPSTA I.A. I Status map for spatial grid. -! FLAG0 log. O Flag to identify 0 as minimum. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +9000 FORMAT ( ' | |',8A15) +9010 FORMAT ( ' +-----+',8A15) +#endif + !/ + !/ End of W3SCAT ----------------------------------------------------- / + !/ + END SUBROUTINE W3SCAT + !/ ------------------------------------------------------------------- / + !> + !> @brief Check minimum number of active sea points at given processor to + !> evaluate the need for a MPI_BARRIER call. + !> + !> @param[in] MAPSTA Status map for spatial grid. + !> @param[out] FLAG0 Flag to identify 0 as minimum. + !> + !> @author H. L. Tolman @date 28-Dec-2004 + !> + SUBROUTINE W3NMIN ( MAPSTA, FLAG0 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 28-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 23-Feb-2001 : Origination. ( version 2.07 ) + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Check minimum number of active sea points at given processor to + ! evaluate the need for a MPI_BARRIER call. + ! + ! 2. Method : + ! + ! Evaluate mapsta. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MAPSTA I.A. I Status map for spatial grid. + ! FLAG0 log. O Flag to identify 0 as minimum. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - USE W3GDATMD, ONLY: NSEA, MAPSF, NX, NY - USE W3ODATMD, ONLY: NDST, NAPROC - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MAPSTA(NY*NX) - LOGICAL, INTENT(OUT) :: FLAG0 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NMIN, IPROC, NLOC, ISEA, IXY - INTEGER :: JSEA, ISPROC + USE W3SERVMD, ONLY: STRACE +#endif + !/ + USE W3GDATMD, ONLY: NSEA, MAPSF, NX, NY + USE W3ODATMD, ONLY: NDST, NAPROC + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MAPSTA(NY*NX) + LOGICAL, INTENT(OUT) :: FLAG0 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NMIN, IPROC, NLOC, ISEA, IXY + INTEGER :: JSEA, ISPROC #ifdef W3_S - INTEGER, SAVE :: IENT + INTEGER, SAVE :: IENT #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3NMIN') + CALL STRACE (IENT, 'W3NMIN') #endif -! - NMIN = NSEA -! + ! + NMIN = NSEA + ! #ifdef W3_OMPG -!$OMP PARALLEL PRIVATE (IPROC,NLOC,ISEA,JSEA,ISPROC,IXY,NMIN) -!$OMP DO SCHEDULE (DYNAMIC,1) -#endif - DO IPROC=1, NAPROC - NLOC = 0 - DO ISEA=1, NSEA - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) - IF (ISPROC .eq. IPROC) THEN - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .EQ. 1 ) NLOC = NLOC + 1 - END IF - END DO + !$OMP PARALLEL PRIVATE (IPROC,NLOC,ISEA,JSEA,ISPROC,IXY,NMIN) + !$OMP DO SCHEDULE (DYNAMIC,1) +#endif + DO IPROC=1, NAPROC + NLOC = 0 + DO ISEA=1, NSEA + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + IF (ISPROC .eq. IPROC) THEN + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .EQ. 1 ) NLOC = NLOC + 1 + END IF + END DO #ifdef W3_SMC - !!Li For SMC grid, local sea points are equally NSEA/NAPROC - !!Li so the NLOC is overwirte by a constant. - NLOC = NSEA/NAPROC + !!Li For SMC grid, local sea points are equally NSEA/NAPROC + !!Li so the NLOC is overwirte by a constant. + NLOC = NSEA/NAPROC #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) IPROC, NLOC + WRITE (NDST,9000) IPROC, NLOC #endif - NMIN = MIN ( NMIN , NLOC ) - END DO + NMIN = MIN ( NMIN , NLOC ) + END DO #ifdef W3_OMPG -!$OMP END DO -!$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL #endif -! - FLAG0 = NMIN .EQ. 0 + ! + FLAG0 = NMIN .EQ. 0 #ifdef W3_T - WRITE (NDST,9001) NMIN, FLAG0 + WRITE (NDST,9001) NMIN, FLAG0 #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3NMIN : IPROC =',I3,' NLOC =',I5) - 9001 FORMAT ( ' TEST W3NMIN : NMIN =',I5,' FLAG0 =',L2) -#endif -!/ -!/ End of W3NMIN ----------------------------------------------------- / -!/ - END SUBROUTINE W3NMIN -!/ -!/ End of module W3WAVEMD -------------------------------------------- / -!/ - END MODULE W3WAVEMD +9000 FORMAT ( ' TEST W3NMIN : IPROC =',I3,' NLOC =',I5) +9001 FORMAT ( ' TEST W3NMIN : NMIN =',I5,' FLAG0 =',L2) +#endif + !/ + !/ End of W3NMIN ----------------------------------------------------- / + !/ + END SUBROUTINE W3NMIN + !/ + !/ End of module W3WAVEMD -------------------------------------------- / + !/ +END MODULE W3WAVEMD diff --git a/model/src/w3wavset.F90 b/model/src/w3wavset.F90 index 8837acb6a..5a92fa3d8 100644 --- a/model/src/w3wavset.F90 +++ b/model/src/w3wavset.F90 @@ -10,193 +10,319 @@ !> !> @brief Implicit solution of wave setup problem following !> Dingemans for structured and unstructured grids. -!> +!> !> @author Aron Roland !> @author Mathieu Dutour-Sikiric !> @date 1-Jun-2018 !> - MODULE W3WAVSET -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 95 | -!/ | Last update : 1-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2016 : Origination ( version 6.04 ) -!/ -! 1. Purpose : Implicit solution of wave setup problem following -! Dingemans for structured and unstructured grids -! -! 2. Method : To be described -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! +MODULE W3WAVSET + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 95 | + !/ | Last update : 1-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2016 : Origination ( version 6.04 ) + !/ + ! 1. Purpose : Implicit solution of wave setup problem following + ! Dingemans for structured and unstructured grids + ! + ! 2. Method : To be described + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! - LOGICAL :: DO_WAVE_SETUP = .TRUE. - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Differentiate xy, using linear shape function. -!> -!> @param[in] VAR -!> @param[out] DVDX -!> @param[out] DVDY -!> -!> @author Aron Roland -!> @author Mathieu Dutour-Sikiric -!> @date 1-May-2018 -!> - SUBROUTINE DIFFERENTIATE_XYDIR_NATIVE(VAR, DVDX, DVDY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : differentiate xy -! 2. Method : linear shape function -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - use yowExchangeModule, only : PDLIB_exchange1Dreal - use yowNodepool, only : PDLIB_IEN, PDLIB_TRIA, npa - use yowElementpool, only : INE, NE - USE W3GDATMD, ONLY : MAPSTA - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - REAL(8), INTENT(IN) :: VAR(npa) - REAL(8), INTENT(OUT) :: DVDX(npa), DVDY(npa) - INTEGER :: NI(3) - INTEGER :: IE, I1, I2, I3, IP - REAL(8) :: DEDY(3),DEDX(3) - REAL(8) :: DVDXIE, DVDYIE - REAL(8) :: WEI(npa), eW - INTEGER :: IX - WEI = 0.0 - DVDX = 0.0 - DVDY = 0.0 + LOGICAL :: DO_WAVE_SETUP = .TRUE. +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Differentiate xy, using linear shape function. + !> + !> @param[in] VAR + !> @param[out] DVDX + !> @param[out] DVDY + !> + !> @author Aron Roland + !> @author Mathieu Dutour-Sikiric + !> @date 1-May-2018 + !> + SUBROUTINE DIFFERENTIATE_XYDIR_NATIVE(VAR, DVDX, DVDY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : differentiate xy + ! 2. Method : linear shape function + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + use yowExchangeModule, only : PDLIB_exchange1Dreal + use yowNodepool, only : PDLIB_IEN, PDLIB_TRIA, npa + use yowElementpool, only : INE, NE + USE W3GDATMD, ONLY : MAPSTA + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + REAL(8), INTENT(IN) :: VAR(npa) + REAL(8), INTENT(OUT) :: DVDX(npa), DVDY(npa) + INTEGER :: NI(3) + INTEGER :: IE, I1, I2, I3, IP + REAL(8) :: DEDY(3),DEDX(3) + REAL(8) :: DVDXIE, DVDYIE + REAL(8) :: WEI(npa), eW + INTEGER :: IX + WEI = 0.0 + DVDX = 0.0 + DVDY = 0.0 + + DO IE = 1, NE + NI = INE(:,IE) + I1 = INE(1,IE) + I2 = INE(2,IE) + I3 = INE(3,IE) + WEI(NI) = WEI(NI) + 2.*PDLIB_TRIA(IE) + DEDX(1) = PDLIB_IEN(1,IE) + DEDX(2) = PDLIB_IEN(3,IE) + DEDX(3) = PDLIB_IEN(5,IE) + DEDY(1) = PDLIB_IEN(2,IE) + DEDY(2) = PDLIB_IEN(4,IE) + DEDY(3) = PDLIB_IEN(6,IE) + DVDXIE = DOT_PRODUCT( VAR(NI),DEDX) + DVDYIE = DOT_PRODUCT( VAR(NI),DEDY) + DVDX(NI) = DVDX(NI) + DVDXIE + DVDY(NI) = DVDY(NI) + DVDYIE + END DO + DO IX=1,npa + eW=WEI(IX) + DVDX(IX)=DVDX(IX) / eW + DVDY(IX)=DVDY(IX) / eW + END DO + CALL PDLIB_exchange1Dreal(DVDX) + CALL PDLIB_exchange1Dreal(DVDY) + END SUBROUTINE DIFFERENTIATE_XYDIR_NATIVE + !/ ------------------------------------------------------------------- / + !> + !> @brief Differentiate xy based on mapsta, using linear shape function. + !> + !> @param[in] VAR + !> @param[out] DVDX + !> @param[out] DVDY + !> + !> @author Aron Roland + !> @author Mathieu Dutour-Sikiric + !> @date 1-May-2018 + !> + SUBROUTINE DIFFERENTIATE_XYDIR_MAPSTA(VAR, DVDX, DVDY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : differentiate xy based on mapsta + ! 2. Method : linear shape function + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + use yowExchangeModule, only : PDLIB_exchange1Dreal + use yowNodepool, only : PDLIB_IEN, PDLIB_TRIA, npa, iplg + use yowElementpool, only : INE, NE + USE W3GDATMD, ONLY : MAPSTA + USE W3PARALL, only: INIT_GET_ISEA + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + + REAL(8), INTENT(IN) :: VAR(npa) + REAL(8), INTENT(OUT) :: DVDX(npa), DVDY(npa) + INTEGER :: NI(3) + INTEGER :: IE, I1, I2, I3, IP, IX + REAL(8) :: DEDY(3),DEDX(3) + REAL(8) :: DVDXIE, DVDYIE + REAL(8) :: WEI(npa), eW + INTEGER :: IX1, IX2, IX3, ISEA + WEI = 0.0 + DVDX = 0.0 + DVDY = 0.0 - DO IE = 1, NE - NI = INE(:,IE) - I1 = INE(1,IE) - I2 = INE(2,IE) - I3 = INE(3,IE) + DO IE = 1, NE + NI = INE(:,IE) + I1 = INE(1,IE) + I2 = INE(2,IE) + I3 = INE(3,IE) + IX1=iplg(I1) + IX2=iplg(I2) + IX3=iplg(I3) + IF ((MAPSTA(1,IX1) .gt. 0).and.(MAPSTA(1,IX2) .gt. 0).and.(MAPSTA(1,IX3) .gt. 0)) THEN WEI(NI) = WEI(NI) + 2.*PDLIB_TRIA(IE) DEDX(1) = PDLIB_IEN(1,IE) DEDX(2) = PDLIB_IEN(3,IE) @@ -208,2990 +334,2864 @@ SUBROUTINE DIFFERENTIATE_XYDIR_NATIVE(VAR, DVDX, DVDY) DVDYIE = DOT_PRODUCT( VAR(NI),DEDY) DVDX(NI) = DVDX(NI) + DVDXIE DVDY(NI) = DVDY(NI) + DVDYIE - END DO - DO IX=1,npa - eW=WEI(IX) - DVDX(IX)=DVDX(IX) / eW - DVDY(IX)=DVDY(IX) / eW - END DO - CALL PDLIB_exchange1Dreal(DVDX) - CALL PDLIB_exchange1Dreal(DVDY) - END SUBROUTINE DIFFERENTIATE_XYDIR_NATIVE -!/ ------------------------------------------------------------------- / -!> -!> @brief Differentiate xy based on mapsta, using linear shape function. -!> -!> @param[in] VAR -!> @param[out] DVDX -!> @param[out] DVDY -!> -!> @author Aron Roland -!> @author Mathieu Dutour-Sikiric -!> @date 1-May-2018 -!> - SUBROUTINE DIFFERENTIATE_XYDIR_MAPSTA(VAR, DVDX, DVDY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : differentiate xy based on mapsta -! 2. Method : linear shape function -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - use yowExchangeModule, only : PDLIB_exchange1Dreal - use yowNodepool, only : PDLIB_IEN, PDLIB_TRIA, npa, iplg - use yowElementpool, only : INE, NE - USE W3GDATMD, ONLY : MAPSTA - USE W3PARALL, only: INIT_GET_ISEA - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') + END IF + END DO + DO IP=1,npa + IX=iplg(IP) + eW=WEI(IP) + IF (eW .gt. 0 .and. MAPSTA(1,IX) .gt. 0) THEN + DVDX(IP)=DVDX(IP) / eW + DVDY(IP)=DVDY(IP) / eW + ELSE + DVDX(IP)=0. + DVDY(IP)=0. + ENDIF + END DO + DO IP=1,npa + IX=iplg(IP) + IF (MAPSTA(1,IX) .lt. 0) THEN + DVDX(IP)=0. + DVDY(IP)=0. + END IF + END DO + CALL PDLIB_exchange1Dreal(DVDX) + CALL PDLIB_exchange1Dreal(DVDY) + END SUBROUTINE DIFFERENTIATE_XYDIR_MAPSTA + !/ ------------------------------------------------------------------- / + !> + !> @brief Driver routine for xydir. + !> + !> @param[in] VAR + !> @param[out] DVDX + !> @param[out] DVDY + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE DIFFERENTIATE_XYDIR(VAR, DVDX, DVDY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Driver routine for xydir + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + use yowNodepool, only: npa + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + + REAL(8), INTENT(IN) :: VAR(npa) + REAL(8), INTENT(OUT) :: DVDX(npa), DVDY(npa) + CALL DIFFERENTIATE_XYDIR_MAPSTA(VAR, DVDX, DVDY) + ! CALL DIFFERENTIATE_XYDIR_NATIVE(VAR, DVDX, DVDY) + END SUBROUTINE DIFFERENTIATE_XYDIR + !/ ------------------------------------------------------------------- / + !> + !> @brief Setup boundary pointer. + !> + !> @param[out] F_X + !> @param[out] F_Y + !> @param[out] DWNX + !> + !> @author Aron Roland + !> @author Mathieu Dutour-Sikiric + !> @date 1-May-2018 + !> + SUBROUTINE TRIG_COMPUTE_LH_STRESS(F_X, F_Y, DWNX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Setup boundary pointer + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE CONSTANTS, ONLY: GRAV, DWAT + use yowNodepool, only: npa, iplg + USE W3GDATMD, only : MAPFS + USE W3ADATMD, ONLY: SXX, SXY, SYY, WN, CG + USE W3PARALL, only: INIT_GET_ISEA + USE W3ODATMD, only : IAPROC + USE W3GDATMD, ONLY : NSEAL, MAPSTA + USE W3ADATMD, ONLY: DW + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + real(8), intent(out) :: F_X(npa), F_Y(npa), DWNX(npa) + REAL(8) :: h + REAL(8) :: SXX_X, SXX_Y + REAL(8) :: SXY_X, SXY_Y + REAL(8) :: SYY_X, SYY_Y + INTEGER I, IP, IX + INTEGER JSEA, ISEA + real(8) :: U_X1(npa), U_Y1(npa) + real(8) :: U_X2(npa), U_Y2(npa) + real(8) :: SXX_p(npa), SXY_p(npa), SYY_p(npa) + real(8) :: eSXX, eSXY, eSYY + integer :: SXXmethod = 1 + SXX_p=0 + SXY_p=0 + SYY_p=0 + DWNX=0 + DO JSEA=1,NSEAL + IP = JSEA ! We remove the Z_status because now NX = NSEA + IX=iplg(IP) + ISEA=MAPFS(1,IX) + IF (SXXmethod .eq. 1) THEN + eSXX=SXX(JSEA)/(DWAT*GRAV) + eSXY=SXY(JSEA)/(DWAT*GRAV) + eSYY=SYY(JSEA)/(DWAT*GRAV) + END IF + SXX_p(IP)=DBLE(eSXX) + SXY_p(IP)=DBLE(eSXY) + SYY_p(IP)=DBLE(eSYY) + DWNX(IP)=DW(ISEA) + END DO + ! +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'min/max(DEP)=', minval(DWNX), maxval(DWNX) #endif -! - REAL(8), INTENT(IN) :: VAR(npa) - REAL(8), INTENT(OUT) :: DVDX(npa), DVDY(npa) - INTEGER :: NI(3) - INTEGER :: IE, I1, I2, I3, IP, IX - REAL(8) :: DEDY(3),DEDX(3) - REAL(8) :: DVDXIE, DVDYIE - REAL(8) :: WEI(npa), eW - INTEGER :: IX1, IX2, IX3, ISEA - WEI = 0.0 - DVDX = 0.0 - DVDY = 0.0 +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'sum(abs(SXX))=', sum(abs(SXX_p)) + WRITE(740+IAPROC,*) 'sum(abs(SXY))=', sum(abs(SXY_p)) + WRITE(740+IAPROC,*) 'sum(abs(SYY))=', sum(abs(SYY_p)) + FLUSH(740+IAPROC) +#endif - DO IE = 1, NE - NI = INE(:,IE) - I1 = INE(1,IE) - I2 = INE(2,IE) - I3 = INE(3,IE) - IX1=iplg(I1) - IX2=iplg(I2) - IX3=iplg(I3) - IF ((MAPSTA(1,IX1) .gt. 0).and.(MAPSTA(1,IX2) .gt. 0).and.(MAPSTA(1,IX3) .gt. 0)) THEN - WEI(NI) = WEI(NI) + 2.*PDLIB_TRIA(IE) - DEDX(1) = PDLIB_IEN(1,IE) - DEDX(2) = PDLIB_IEN(3,IE) - DEDX(3) = PDLIB_IEN(5,IE) - DEDY(1) = PDLIB_IEN(2,IE) - DEDY(2) = PDLIB_IEN(4,IE) - DEDY(3) = PDLIB_IEN(6,IE) - DVDXIE = DOT_PRODUCT( VAR(NI),DEDX) - DVDYIE = DOT_PRODUCT( VAR(NI),DEDY) - DVDX(NI) = DVDX(NI) + DVDXIE - DVDY(NI) = DVDY(NI) + DVDYIE + CALL DIFFERENTIATE_XYDIR(SXX_p, U_X1, U_Y1) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'sum(absU_XY1)=', sum(abs(U_X1)), sum(abs(U_Y1)) + FLUSH(740+IAPROC) +#endif + CALL DIFFERENTIATE_XYDIR(SXY_p, U_X2, U_Y2) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'sum(absU_XY2)=', sum(abs(U_X2)), sum(abs(U_Y2)) + FLUSH(740+IAPROC) +#endif + F_X = -U_X1 - U_Y2 + ! + CALL DIFFERENTIATE_XYDIR(SYY_p, U_X1, U_Y1) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'sum(absU_XY1)=', sum(abs(U_X1)), sum(abs(U_Y1)) + FLUSH(740+IAPROC) +#endif + F_Y = -U_Y1 - U_X2 +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'sum(F_X)=', sum(F_X) + WRITE(740+IAPROC,*) 'sum(F_Y)=', sum(F_Y) + FLUSH(740+IAPROC) +#endif + END SUBROUTINE TRIG_COMPUTE_LH_STRESS + !/ ------------------------------------------------------------------- / + !> + !> @brief Differentiate other way around. + !> + !> @param[in] IE + !> @param[in] I1 + !> @param[inout] UGRAD + !> @param[inout] VGRAD + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE TRIG_COMPUTE_DIFF(IE, I1, UGRAD, VGRAD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : differentiate other way around ... + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + use yowElementpool, only: INE + use yowNodepool, only: x, y, PDLIB_TRIA + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + INTEGER, intent(in) :: IE, I1 + REAL(8), intent(inout) :: UGRAD, VGRAD + REAL(8) :: h + integer I2, I3, IP1, IP2, IP3 + INTEGER :: POS_TRICK(3,2) + POS_TRICK(1,1) = 2 + POS_TRICK(1,2) = 3 + POS_TRICK(2,1) = 3 + POS_TRICK(2,2) = 1 + POS_TRICK(3,1) = 1 + POS_TRICK(3,2) = 2 + I2=POS_TRICK(I1, 1) + I3=POS_TRICK(I1, 2) + IP1=INE(I1, IE) + IP2=INE(I2, IE) + IP3=INE(I3, IE) + h=2.0*PDLIB_TRIA(IE) + UGRAD=-(y(IP3) - y(IP2))/h + VGRAD= (x(IP3) - x(IP2))/h + END SUBROUTINE TRIG_COMPUTE_DIFF + !/ ------------------------------------------------------------------- / + !> + !> @brief Setup system matrix for solutions of wave setup eq. + !> + !> @param[in] FX + !> @param[in] FY + !> @param[in] DWNX + !> @param[out] ASPAR + !> @param[out] B + !> @param[in] ACTIVE + !> @param[out] ACTIVESEC + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE TRIG_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, FX, FY, DWNX, ACTIVE, ACTIVESEC) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Setup system matrix for solutions of wave setup eq. + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + use yowElementpool, only: INE, NE + use yowNodepool, only: PDLIB_NNZ, PDLIB_JA_IE, PDLIB_TRIA, npa, np + USE yowNodepool, only: iplg + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + real(8), intent(in) :: FX(npa), FY(npa), DWNX(npa) + real(8), intent(out) :: ASPAR(PDLIB_NNZ) + real(8), intent(out) :: B(npa) + integer, intent(in) :: ACTIVE(npa) + integer, intent(out) :: ACTIVESEC(npa) + INTEGER :: POS_TRICK(3,2), POS_SHIFT(3,3) + integer I1, I2, I3, IP1, IP2, IP3 + integer IDX, IDX1, IDX2, IDX3 + INTEGER IE, IP, I, J, K, IPp, JPp + real(8) :: eDep, eFX, eFY, eScal, eFact, eArea + real(8) :: UGRAD, VGRAD, UGRAD1, VGRAD1 + real(8) :: eOff + logical DoPrintOut + INTEGER sumActive + INTEGER LIDX(2), KIDX(2), jdx + INTEGER IPglob1, IPglob2, IPglob3 + POS_TRICK(1,1) = 2 + POS_TRICK(1,2) = 3 + POS_TRICK(2,1) = 3 + POS_TRICK(2,2) = 1 + POS_TRICK(3,1) = 1 + POS_TRICK(3,2) = 2 + ASPAR=0 + B=0 + DO I=1,3 + DO J=1,3 + K= I-J+1 + IF (K .le. 0) THEN + K=K+3 END IF + IF (K .ge. 4) THEN + K=K-3 + END IF + POS_SHIFT(I,J)=K + END DO + END DO + DO I=1,3 + jdx=0 + DO IDX=1,3 + K=POS_SHIFT(I,IDX) + IF (K .ne. I) THEN + jdx=jdx+1 + LIDX(jdx)=IDX + KIDX(jdx)=K + END IF + END DO + POS_SHIFT(I,LIDX(1))=KIDX(2) + POS_SHIFT(I,LIDX(2))=KIDX(1) + END DO + ACTIVESEC=0 + DO IE=1,ne + IP1=INE(1,IE) + IP2=INE(2,IE) + IP3=INE(3,IE) + eFX =(FX(IP1) + FX(IP2) + FX(IP3))/3 + eFY =(FY(IP1) + FY(IP2) + FY(IP3))/3 + sumActive=ACTIVE(IP1) + ACTIVE(IP2) + ACTIVE(IP3) + IF (sumActive .eq. 3) THEN + ACTIVESEC(IP1)=1 + ACTIVESEC(IP2)=1 + ACTIVESEC(IP3)=1 + eDep=(DWNX(IP1) + DWNX(IP2) + DWNX(IP3))/3.0 + eArea=PDLIB_TRIA(IE) + eFact=eDep*eArea + DO I1=1,3 + I2=POS_TRICK(I1,1) + I3=POS_TRICK(I1,2) + IP1=INE(I1,IE) + IP2=INE(I2,IE) + IP3=INE(I3,IE) + IDX1=PDLIB_JA_IE(I1,1,IE) + IDX2=PDLIB_JA_IE(I1,2,IE) + IDX3=PDLIB_JA_IE(I1,3,IE) + CALL TRIG_COMPUTE_DIFF(IE, I1, UGRAD1, VGRAD1) + eScal=UGRAD1*eFX + VGRAD1*eFY + B(IP1) = B(IP1) + eScal*eArea + ! + DO IDX=1,3 + K=POS_SHIFT(I1, IDX) + CALL TRIG_COMPUTE_DIFF(IE, K, UGRAD, VGRAD) + eScal=UGRAD*UGRAD1 + VGRAD*VGRAD1 + J=PDLIB_JA_IE(I1,IDX,IE) + ASPAR(J)=ASPAR(J) + eFact*eScal + END DO + END DO + END IF + END DO + DoPrintOut=.TRUE. + IF (DoPrintOut .eqv. .TRUE.) THEN + DO IP=1,NP + eOff=0 END DO + END IF + END SUBROUTINE TRIG_WAVE_SETUP_COMPUTE_SYSTEM + !/ ------------------------------------------------------------------- / + !> + !> @brief Preconditioner. + !> + !> @param[in] ASPAR + !> @param[in] TheIn + !> @param[out] TheOut + !> @param[in] ACTIVE + !> @param[in] ACTIVESEC + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, TheIn, TheOut, ACTIVE, ACTIVESEC) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : preconditioner + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + use yowExchangeModule, only : PDLIB_exchange1Dreal + use yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, PDLIB_I_DIAG + use yowNodepool, only: npa + USE W3ODATMD, only : IAPROC + USE W3ODATMD, only : IAPROC + USE yowNodepool, only: iplg + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + REAL(8), intent(in) :: ASPAR(PDLIB_NNZ) + REAL(8), intent(in) :: TheIn(npa) + REAL(8), intent(out) :: TheOut(npa) + INTEGER, intent(IN) :: ACTIVE(npa), ACTIVESEC(npa) + REAL(8) :: ListDiag(npa) + integer IP, J1, J, JP, J2 + REAL(8) :: eCoeff + INTEGER :: ThePrecond = 2 + IF (ThePrecond .eq. 0) THEN + TheOut=TheIn + END IF + IF (ThePrecond .eq. 1) THEN + TheOut=0 DO IP=1,npa - IX=iplg(IP) - eW=WEI(IP) - IF (eW .gt. 0 .and. MAPSTA(1,IX) .gt. 0) THEN - DVDX(IP)=DVDX(IP) / eW - DVDY(IP)=DVDY(IP) / eW - ELSE - DVDX(IP)=0. - DVDY(IP)=0. - ENDIF + IF (ACTIVE(IP) .eq. 1) THEN + J1=PDLIB_I_DIAG(IP) + DO J=PDLIB_IA(IP),PDLIB_IA(IP+1)-1 + JP=PDLIB_JA(J) + IF (ACTIVESEC(JP) .eq. 1) THEN + IF (J .eq. J1) THEN + eCoeff=1.0/ASPAR(J) + ELSE + J2=PDLIB_I_DIAG(JP) + eCoeff=-ASPAR(J) /(ASPAR(J1)*ASPAR(J2)) + END IF + TheOut(IP)=TheOut(IP) + eCoeff*TheIn(JP) + END IF + END DO + END IF END DO + END IF + IF (ThePrecond .eq. 2) THEN DO IP=1,npa - IX=iplg(IP) - IF (MAPSTA(1,IX) .lt. 0) THEN - DVDX(IP)=0. - DVDY(IP)=0. + IF (ACTIVESEC(IP) .eq. 1) THEN + J=PDLIB_I_DIAG(IP) + ListDiag(IP)=ASPAR(J) + TheOut(IP)=TheIn(IP)/ASPAR(J) + ELSE + ListDiag(IP)=1 + TheOut(IP)=TheIn(IP) END IF END DO - CALL PDLIB_exchange1Dreal(DVDX) - CALL PDLIB_exchange1Dreal(DVDY) - END SUBROUTINE DIFFERENTIATE_XYDIR_MAPSTA -!/ ------------------------------------------------------------------- / -!> -!> @brief Driver routine for xydir. -!> -!> @param[in] VAR -!> @param[out] DVDX -!> @param[out] DVDY -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE DIFFERENTIATE_XYDIR(VAR, DVDX, DVDY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Driver routine for xydir -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + WRITE(740+IAPROC,*) 'Diag, min=', minval(ListDiag), ' max=', maxval(ListDiag) + WRITE(740+IAPROC,*) 'Diag, quot=', maxval(ListDiag)/minval(ListDiag) + END IF + CALL PDLIB_exchange1Dreal(TheOut) + END SUBROUTINE TRIG_WAVE_SETUP_APPLY_PRECOND + !/ ------------------------------------------------------------------- / + !> + !> @brief + !> + !> @param[in] ASPAR + !> @param[in] TheIn + !> @param[out] TheOut + !> @param[in] ACTIVE + !> @param[in] ACTIVESEC + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE TRIG_WAVE_SETUP_APPLY_FCT(ASPAR, TheIn, TheOut, ACTIVE, ACTIVESEC) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : compute off diagonal contr. + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + use yowExchangeModule, only : PDLIB_exchange1Dreal + USE yowNodepool, only: PDLIB_IA, PDLIB_JA, PDLIB_NNZ + use yowNodepool, only: np, npa + USE W3GDATMD, ONLY: NSEAL + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + REAL(8), intent(in) :: ASPAR(PDLIB_NNZ) + REAL(8), intent(in) :: TheIn(npa) + REAL(8), intent(out) :: TheOut(npa) + INTEGER, intent(in) :: ACTIVE(npa), ACTIVESEC(npa) + integer IP, J, JP + REAL(8) :: eCoeff + TheOut=0 + DO IP=1,npa + IF (ACTIVESEC(IP) .eq. 1) THEN + DO J=PDLIB_IA(IP),PDLIB_IA(IP+1)-1 + JP=PDLIB_JA(J) + eCoeff=ASPAR(J) + TheOut(IP)=TheOut(IP) + eCoeff*TheIn(JP) + END DO + END IF + END DO + CALL PDLIB_exchange1Dreal(TheOut) + END SUBROUTINE TRIG_WAVE_SETUP_APPLY_FCT + !/ ------------------------------------------------------------------- / + !> + !> @brief Scalar product plus exchange. + !> + !> @param[in] V1 + !> @param[in] V2 + !> @param[inout] eScal + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE TRIG_WAVE_SETUP_SCALAR_PROD(V1, V2, eScal) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : scalar prod. + exchange + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY: NX + USE W3ADATMD, ONLY: MPI_COMM_WCMP + use yowDatapool, only: rtype, istatus + use yowNodepool, only: np, npa + USE W3ODATMD, only : IAPROC, NAPROC, NTPROC + USE W3GDATMD, ONLY: NSEAL + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + real(8), intent(in) :: V1(npa), V2(npa) + real(8), intent(inout) :: eScal + integer IP, myrank, myproc + real(8) :: rScal(1), lScal(1) + integer iProc + integer ierr + CALL MPI_COMM_RANK(MPI_COMM_WCMP, myrank, ierr) + CALL MPI_COMM_SIZE(MPI_COMM_WCMP, myproc, ierr) + lScal=0 + DO IP=1,np + lScal(1)=lScal(1) + V1(IP)*V2(IP) + END DO + IF (IAPROC .eq. 1) THEN + DO iProc=2,NAPROC + CALL MPI_RECV(rScal,1,rtype, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) + lScal = lScal + rScal + END DO + DO iProc=2,NAPROC + CALL MPI_SEND(lScal,1,rtype, iProc-1, 23, MPI_COMM_WCMP, ierr) + END DO + ELSE + CALL MPI_SEND(lScal,1,rtype, 0, 19, MPI_COMM_WCMP, ierr) + CALL MPI_RECV(lScal,1,rtype, 0, 23, MPI_COMM_WCMP, istatus, ierr) + END IF + eScal=lScal(1) + END SUBROUTINE TRIG_WAVE_SETUP_SCALAR_PROD + !/ ------------------------------------------------------------------- / + !> + !> @brief Poisson equation solver. + !> + !> @param[in] ASPAR + !> @param[in] B + !> @param[out] TheOut + !> @param[in] ACTIVE + !> @param[in] ACTIVESEC + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut, ACTIVE, ACTIVESEC) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : poisson eq. solver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE yowNodepool, only: PDLIB_NNZ + USE W3GDATMD, ONLY: NSEAL, SOLVERTHR_STP + USE W3ODATMD, only : IAPROC + use yowNodepool, only: np, npa + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + real(8), intent(in) :: ASPAR(PDLIB_NNZ) + real(8), intent(in) :: B(npa) + real(8), intent(out) :: TheOut(npa) + integer, intent(in) :: ACTIVE(npa), ACTIVESEC(npa) + real(8) :: V_X(npa), V_R(npa), V_Z(npa), V_P(npa), V_Y(npa) + real(8) :: uO, uN, alphaV, h1, h2 + real(8) :: eNorm, beta + real(8) :: SOLVERTHR + integer IP, nbIter + SOLVERTHR=SOLVERTHR_STP + +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Begin TRIG_WAVE_SETUP_SOLVE ....' + FLUSH(740+IAPROC) +#endif + nbIter=0 + V_X=0 + V_R=B + CALL TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, V_R, V_Z, ACTIVE, ACTIVESEC) + V_P=V_Z + CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_Z, V_R, uO) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'uO=', uO + FLUSH(740+IAPROC) #endif -! - use yowNodepool, only: npa - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + CALL TRIG_WAVE_SETUP_SCALAR_PROD(B, B, eNorm) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'eNorm(B)=', eNorm + WRITE(740+IAPROC,*) 'SOLVERTHR=', SOLVERTHR + FLUSH(740+IAPROC) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') + WRITE(740+IAPROC,*) 'SOLVERTHR=', SOLVERTHR, ' eNorm(B)=', eNorm + IF (eNorm .le. SOLVERTHR) THEN +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Leaving here, zero solution' + FLUSH(740+IAPROC) #endif -! - - REAL(8), INTENT(IN) :: VAR(npa) - REAL(8), INTENT(OUT) :: DVDX(npa), DVDY(npa) - CALL DIFFERENTIATE_XYDIR_MAPSTA(VAR, DVDX, DVDY) -! CALL DIFFERENTIATE_XYDIR_NATIVE(VAR, DVDX, DVDY) - END SUBROUTINE DIFFERENTIATE_XYDIR -!/ ------------------------------------------------------------------- / -!> -!> @brief Setup boundary pointer. -!> -!> @param[out] F_X -!> @param[out] F_Y -!> @param[out] DWNX -!> -!> @author Aron Roland -!> @author Mathieu Dutour-Sikiric -!> @date 1-May-2018 -!> - SUBROUTINE TRIG_COMPUTE_LH_STRESS(F_X, F_Y, DWNX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Setup boundary pointer -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE CONSTANTS, ONLY: GRAV, DWAT - use yowNodepool, only: npa, iplg - USE W3GDATMD, only : MAPFS - USE W3ADATMD, ONLY: SXX, SXY, SYY, WN, CG - USE W3PARALL, only: INIT_GET_ISEA - USE W3ODATMD, only : IAPROC - USE W3GDATMD, ONLY : NSEAL, MAPSTA - USE W3ADATMD, ONLY: DW - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + TheOut=V_X + RETURN + END IF + DO + nbIter=nbIter + 1 +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) ' nbIter=', nbIter + FLUSH(740+IAPROC) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - real(8), intent(out) :: F_X(npa), F_Y(npa), DWNX(npa) - REAL(8) :: h - REAL(8) :: SXX_X, SXX_Y - REAL(8) :: SXY_X, SXY_Y - REAL(8) :: SYY_X, SYY_Y - INTEGER I, IP, IX - INTEGER JSEA, ISEA - real(8) :: U_X1(npa), U_Y1(npa) - real(8) :: U_X2(npa), U_Y2(npa) - real(8) :: SXX_p(npa), SXY_p(npa), SYY_p(npa) - real(8) :: eSXX, eSXY, eSYY - integer :: SXXmethod = 1 - SXX_p=0 - SXY_p=0 - SYY_p=0 - DWNX=0 - DO JSEA=1,NSEAL - IP = JSEA ! We remove the Z_status because now NX = NSEA - IX=iplg(IP) - ISEA=MAPFS(1,IX) - IF (SXXmethod .eq. 1) THEN - eSXX=SXX(JSEA)/(DWAT*GRAV) - eSXY=SXY(JSEA)/(DWAT*GRAV) - eSYY=SYY(JSEA)/(DWAT*GRAV) - END IF - SXX_p(IP)=DBLE(eSXX) - SXY_p(IP)=DBLE(eSXY) - SYY_p(IP)=DBLE(eSYY) - DWNX(IP)=DW(ISEA) - END DO - ! + CALL TRIG_WAVE_SETUP_APPLY_FCT(ASPAR, V_P, V_Y, ACTIVE, ACTIVESEC) + CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_P, V_Y, h2) #ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'min/max(DEP)=', minval(DWNX), maxval(DWNX) + WRITE(740+IAPROC,*) ' h2=', h2 + FLUSH(740+IAPROC) #endif - + alphaV=uO/h2 #ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'sum(abs(SXX))=', sum(abs(SXX_p)) - WRITE(740+IAPROC,*) 'sum(abs(SXY))=', sum(abs(SXY_p)) - WRITE(740+IAPROC,*) 'sum(abs(SYY))=', sum(abs(SYY_p)) + WRITE(740+IAPROC,*) ' alphaV=', alphaV FLUSH(740+IAPROC) #endif - CALL DIFFERENTIATE_XYDIR(SXX_p, U_X1, U_Y1) + ! + DO IP=1,npa + V_X(IP) = V_X(IP) + alphaV * V_P(IP) + V_R(IP) = V_R(IP) - alphaV * V_Y(IP) + END DO + ! + CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_R, V_R, eNorm) #ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'sum(absU_XY1)=', sum(abs(U_X1)), sum(abs(U_Y1)) + WRITE(740+IAPROC,*) 'eNorm=', eNorm FLUSH(740+IAPROC) #endif - CALL DIFFERENTIATE_XYDIR(SXY_p, U_X2, U_Y2) + WRITE(740+IAPROC,*) 'nbIter=', nbIter, ' eNorm(res)=', eNorm + FLUSH(740+IAPROC) + IF (eNorm .le. SOLVERTHR) THEN + EXIT + END IF + ! + CALL TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, V_R, V_Z, ACTIVE, ACTIVESEC) + CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_Z, V_R, uN) #ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'sum(absU_XY2)=', sum(abs(U_X2)), sum(abs(U_Y2)) + WRITE(740+IAPROC,*) ' uN=', uN FLUSH(740+IAPROC) #endif - F_X = -U_X1 - U_Y2 ! - CALL DIFFERENTIATE_XYDIR(SYY_p, U_X1, U_Y1) + beta=uN/uO + uO=uN #ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'sum(absU_XY1)=', sum(abs(U_X1)), sum(abs(U_Y1)) + WRITE(740+IAPROC,*) 'beta=', beta FLUSH(740+IAPROC) #endif - F_Y = -U_Y1 - U_X2 + ! + DO IP=1,npa + V_P(IP)=V_Z(IP) + beta * V_P(IP) + END DO + END DO + TheOut=V_X + END SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR + !/ ------------------------------------------------------------------- / + !> + !> @brief Set mean value. + !> + !> @param[inout] TheVar + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE TRIG_SET_MEANVALUE_TO_ZERO(TheVar) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : set. mean value + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE yowNodepool, only: PDLIB_SI + USE W3GDATMD, ONLY: NX, SI + USE W3GDATMD, ONLY: NSEAL + USE W3ADATMD, ONLY: MPI_COMM_WCMP + USE W3ODATMD, only : IAPROC, NAPROC, NTPROC + use yowDatapool, only: rtype, istatus + use yowNodepool, only: np, npa + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + real(8), intent(inout) :: TheVar(npa) + real(8) :: SUM_SI_Var, SUM_SI, TheMean + INTEGER IP, ierr + real(8) :: eVect(2), rVect(2) + integer iProc + SUM_SI_Var=0 + SUM_SI=0 + DO IP=1,np + SUM_SI_Var = SUM_SI_Var + PDLIB_SI(IP)*TheVar(IP) + SUM_SI = SUM_SI + PDLIB_SI(IP) + END DO + eVect(1)=SUM_SI_Var + eVect(2)=SUM_SI #ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'sum(F_X)=', sum(F_X) - WRITE(740+IAPROC,*) 'sum(F_Y)=', sum(F_Y) - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'SUM_SI_Var=', SUM_SI_Var, 'SUM_SI=', SUM_SI + FLUSH(740+IAPROC) #endif - END SUBROUTINE TRIG_COMPUTE_LH_STRESS -!/ ------------------------------------------------------------------- / -!> -!> @brief Differentiate other way around. -!> -!> @param[in] IE -!> @param[in] I1 -!> @param[inout] UGRAD -!> @param[inout] VGRAD -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE TRIG_COMPUTE_DIFF(IE, I1, UGRAD, VGRAD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : differentiate other way around ... -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + IF (IAPROC .eq. 1) THEN + DO iProc=2,NAPROC + CALL MPI_RECV(rVect,2,rtype, iProc-1, 367, MPI_COMM_WCMP, istatus, ierr) + eVect=eVect + rVect + END DO + DO iProc=2,NAPROC + CALL MPI_SEND(eVect,2,rtype, iProc-1, 37, MPI_COMM_WCMP, ierr) + END DO + ELSE + CALL MPI_SEND(eVect,2,rtype, 0, 367, MPI_COMM_WCMP, ierr) + CALL MPI_RECV(eVect,2,rtype, 0, 37, MPI_COMM_WCMP, istatus, ierr) + END IF + SUM_SI_Var=eVect(1) + SUM_SI =eVect(2) + TheMean=SUM_SI_Var/SUM_SI +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'TheMean=', TheMean + FLUSH(740+IAPROC) #endif -! - use yowElementpool, only: INE - use yowNodepool, only: x, y, PDLIB_TRIA - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + DO IP=1,npa + TheVar(IP)=TheVar(IP) - TheMean + END DO + END SUBROUTINE TRIG_SET_MEANVALUE_TO_ZERO + !/ ------------------------------------------------------------------- / + !> + !> @brief Compute active node for setup comp. + !> + !> @param[in] DWNX + !> @param[out] ACTIVE + !> + !> @author Aron Roland + !> @author Mathieu Dutour-Sikiric + !> @date 1-May-2018 + !> + SUBROUTINE COMPUTE_ACTIVE_NODE(DWNX, ACTIVE) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute active node for setup comp. + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY : CRIT_DEP_STP + USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, iplg, npa, np + USE W3ODATMD, only : IAPROC + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + REAL*8, INTENT(in) :: DWNX(npa) + INTEGER, INTENT(out) :: ACTIVE(npa) + INTEGER IP, eAct +#ifdef W3_DEBUGSTP + INTEGER nbActive + nbActive=0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - INTEGER, intent(in) :: IE, I1 - REAL(8), intent(inout) :: UGRAD, VGRAD - REAL(8) :: h - integer I2, I3, IP1, IP2, IP3 - INTEGER :: POS_TRICK(3,2) - POS_TRICK(1,1) = 2 - POS_TRICK(1,2) = 3 - POS_TRICK(2,1) = 3 - POS_TRICK(2,2) = 1 - POS_TRICK(3,1) = 1 - POS_TRICK(3,2) = 2 - I2=POS_TRICK(I1, 1) - I3=POS_TRICK(I1, 2) - IP1=INE(I1, IE) - IP2=INE(I2, IE) - IP3=INE(I3, IE) - h=2.0*PDLIB_TRIA(IE) - UGRAD=-(y(IP3) - y(IP2))/h - VGRAD= (x(IP3) - x(IP2))/h - END SUBROUTINE TRIG_COMPUTE_DIFF -!/ ------------------------------------------------------------------- / -!> -!> @brief Setup system matrix for solutions of wave setup eq. -!> -!> @param[in] FX -!> @param[in] FY -!> @param[in] DWNX -!> @param[out] ASPAR -!> @param[out] B -!> @param[in] ACTIVE -!> @param[out] ACTIVESEC -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE TRIG_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, FX, FY, DWNX, ACTIVE, ACTIVESEC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Setup system matrix for solutions of wave setup eq. -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + DO IP=1,NPA + IF (DWNX(IP) .ge. CRIT_DEP_STP) THEN + eAct=1 + ELSE + eAct=0 + END IF +#ifdef W3_DEBUGSTP + nbActive=nbActive + eAct #endif -! - use yowElementpool, only: INE, NE - use yowNodepool, only: PDLIB_NNZ, PDLIB_JA_IE, PDLIB_TRIA, npa, np - USE yowNodepool, only: iplg - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + ACTIVE(IP)=eAct + END DO +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'min/max(DWNX)=', minval(DWNX), maxval(DWNX) + WRITE(740+IAPROC,*) 'CRIT_DEP_STP=', CRIT_DEP_STP + WRITE(740+IAPROC,*) 'nbActive=', nbActive, ' npa=', npa + FLUSH(740+IAPROC) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - real(8), intent(in) :: FX(npa), FY(npa), DWNX(npa) - real(8), intent(out) :: ASPAR(PDLIB_NNZ) - real(8), intent(out) :: B(npa) - integer, intent(in) :: ACTIVE(npa) - integer, intent(out) :: ACTIVESEC(npa) - INTEGER :: POS_TRICK(3,2), POS_SHIFT(3,3) - integer I1, I2, I3, IP1, IP2, IP3 - integer IDX, IDX1, IDX2, IDX3 - INTEGER IE, IP, I, J, K, IPp, JPp - real(8) :: eDep, eFX, eFY, eScal, eFact, eArea - real(8) :: UGRAD, VGRAD, UGRAD1, VGRAD1 - real(8) :: eOff - logical DoPrintOut - INTEGER sumActive - INTEGER LIDX(2), KIDX(2), jdx - INTEGER IPglob1, IPglob2, IPglob3 - POS_TRICK(1,1) = 2 - POS_TRICK(1,2) = 3 - POS_TRICK(2,1) = 3 - POS_TRICK(2,2) = 1 - POS_TRICK(3,1) = 1 - POS_TRICK(3,2) = 2 - ASPAR=0 - B=0 - DO I=1,3 - DO J=1,3 - K= I-J+1 - IF (K .le. 0) THEN - K=K+3 - END IF - IF (K .ge. 4) THEN - K=K-3 - END IF - POS_SHIFT(I,J)=K - END DO - END DO - DO I=1,3 - jdx=0 - DO IDX=1,3 - K=POS_SHIFT(I,IDX) - IF (K .ne. I) THEN - jdx=jdx+1 - LIDX(jdx)=IDX - KIDX(jdx)=K - END IF - END DO - POS_SHIFT(I,LIDX(1))=KIDX(2) - POS_SHIFT(I,LIDX(2))=KIDX(1) - END DO - ACTIVESEC=0 - DO IE=1,ne - IP1=INE(1,IE) - IP2=INE(2,IE) - IP3=INE(3,IE) - eFX =(FX(IP1) + FX(IP2) + FX(IP3))/3 - eFY =(FY(IP1) + FY(IP2) + FY(IP3))/3 - sumActive=ACTIVE(IP1) + ACTIVE(IP2) + ACTIVE(IP3) - IF (sumActive .eq. 3) THEN - ACTIVESEC(IP1)=1 - ACTIVESEC(IP2)=1 - ACTIVESEC(IP3)=1 - eDep=(DWNX(IP1) + DWNX(IP2) + DWNX(IP3))/3.0 - eArea=PDLIB_TRIA(IE) - eFact=eDep*eArea - DO I1=1,3 - I2=POS_TRICK(I1,1) - I3=POS_TRICK(I1,2) - IP1=INE(I1,IE) - IP2=INE(I2,IE) - IP3=INE(I3,IE) - IDX1=PDLIB_JA_IE(I1,1,IE) - IDX2=PDLIB_JA_IE(I1,2,IE) - IDX3=PDLIB_JA_IE(I1,3,IE) - CALL TRIG_COMPUTE_DIFF(IE, I1, UGRAD1, VGRAD1) - eScal=UGRAD1*eFX + VGRAD1*eFY - B(IP1) = B(IP1) + eScal*eArea - ! - DO IDX=1,3 - K=POS_SHIFT(I1, IDX) - CALL TRIG_COMPUTE_DIFF(IE, K, UGRAD, VGRAD) - eScal=UGRAD*UGRAD1 + VGRAD*VGRAD1 - J=PDLIB_JA_IE(I1,IDX,IE) - ASPAR(J)=ASPAR(J) + eFact*eScal - END DO - END DO - END IF - END DO - DoPrintOut=.TRUE. - IF (DoPrintOut .eqv. .TRUE.) THEN - DO IP=1,NP - eOff=0 - END DO + END SUBROUTINE COMPUTE_ACTIVE_NODE + !/ ------------------------------------------------------------------- / + !> + !> @brief Setup computation. + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Setup computation + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, iplg, npa, np + USE W3GDATMD, only : MAPFS + USE W3PARALL, only : SYNCHRONIZE_GLOBAL_ARRAY + USE W3ADATMD, ONLY: DW + USE W3GDATMD, ONLY: NSEAL, NSEA, NX + USE W3WDATMD, ONLY: ZETA_SETUP + USE W3ODATMD, only : IAPROC, NAPROC, NTPROC + USE W3PARALL, only: INIT_GET_ISEA + use yowExchangeModule, only : PDLIB_exchange1Dreal + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + ! CALL W3SETG + REAL(8) :: ZETA_WORK(npa), ZETA_WORK_ALL(NX) + REAL(8) :: F_X(npa), F_Y(npa), DWNX(npa) + REAL(8) :: ASPAR(PDLIB_NNZ), B(npa) + INTEGER I, ISEA, JSEA, IX, IP, IP_glob + INTEGER :: ACTIVE(npa), ACTIVESEC(npa) + ! ZETA_SETUP is allocated on 1:NSEA + ! ZETA_WORK is on 1:npa +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, ' NTPROC=', NTPROC + WRITE(740+IAPROC,*) 'NSEAL=', NSEAL + WRITE(740+IAPROC,*) 'npa=', npa, ' np=', np +#endif + FLUSH(740+IAPROC) + ZETA_WORK=0 + DO IP=1,npa + IX=iplg(IP) + ISEA=MAPFS(1,IX) + IF (ISEA .gt. 0) THEN + ZETA_WORK(IP)=ZETA_SETUP(ISEA) END IF - END SUBROUTINE TRIG_WAVE_SETUP_COMPUTE_SYSTEM -!/ ------------------------------------------------------------------- / -!> -!> @brief Preconditioner. -!> -!> @param[in] ASPAR -!> @param[in] TheIn -!> @param[out] TheOut -!> @param[in] ACTIVE -!> @param[in] ACTIVESEC -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, TheIn, TheOut, ACTIVE, ACTIVESEC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : preconditioner -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - use yowExchangeModule, only : PDLIB_exchange1Dreal - use yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, PDLIB_I_DIAG - use yowNodepool, only: npa - USE W3ODATMD, only : IAPROC - USE W3ODATMD, only : IAPROC - USE yowNodepool, only: iplg - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - REAL(8), intent(in) :: ASPAR(PDLIB_NNZ) - REAL(8), intent(in) :: TheIn(npa) - REAL(8), intent(out) :: TheOut(npa) - INTEGER, intent(IN) :: ACTIVE(npa), ACTIVESEC(npa) - REAL(8) :: ListDiag(npa) - integer IP, J1, J, JP, J2 - REAL(8) :: eCoeff - INTEGER :: ThePrecond = 2 - IF (ThePrecond .eq. 0) THEN - TheOut=TheIn - END IF - IF (ThePrecond .eq. 1) THEN - TheOut=0 - DO IP=1,npa - IF (ACTIVE(IP) .eq. 1) THEN - J1=PDLIB_I_DIAG(IP) - DO J=PDLIB_IA(IP),PDLIB_IA(IP+1)-1 - JP=PDLIB_JA(J) - IF (ACTIVESEC(JP) .eq. 1) THEN - IF (J .eq. J1) THEN - eCoeff=1.0/ASPAR(J) - ELSE - J2=PDLIB_I_DIAG(JP) - eCoeff=-ASPAR(J) /(ASPAR(J1)*ASPAR(J2)) - END IF - TheOut(IP)=TheOut(IP) + eCoeff*TheIn(JP) - END IF - END DO - END IF - END DO - END IF - IF (ThePrecond .eq. 2) THEN - DO IP=1,npa - IF (ACTIVESEC(IP) .eq. 1) THEN - J=PDLIB_I_DIAG(IP) - ListDiag(IP)=ASPAR(J) - TheOut(IP)=TheIn(IP)/ASPAR(J) - ELSE - ListDiag(IP)=1 - TheOut(IP)=TheIn(IP) - END IF - END DO - WRITE(740+IAPROC,*) 'Diag, min=', minval(ListDiag), ' max=', maxval(ListDiag) - WRITE(740+IAPROC,*) 'Diag, quot=', maxval(ListDiag)/minval(ListDiag) - END IF - CALL PDLIB_exchange1Dreal(TheOut) - END SUBROUTINE TRIG_WAVE_SETUP_APPLY_PRECOND -!/ ------------------------------------------------------------------- / -!> -!> @brief -!> -!> @param[in] ASPAR -!> @param[in] TheIn -!> @param[out] TheOut -!> @param[in] ACTIVE -!> @param[in] ACTIVESEC -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE TRIG_WAVE_SETUP_APPLY_FCT(ASPAR, TheIn, TheOut, ACTIVE, ACTIVESEC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : compute off diagonal contr. -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - use yowExchangeModule, only : PDLIB_exchange1Dreal - USE yowNodepool, only: PDLIB_IA, PDLIB_JA, PDLIB_NNZ - use yowNodepool, only: np, npa - USE W3GDATMD, ONLY: NSEAL - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - REAL(8), intent(in) :: ASPAR(PDLIB_NNZ) - REAL(8), intent(in) :: TheIn(npa) - REAL(8), intent(out) :: TheOut(npa) - INTEGER, intent(in) :: ACTIVE(npa), ACTIVESEC(npa) - integer IP, J, JP - REAL(8) :: eCoeff - TheOut=0 - DO IP=1,npa - IF (ACTIVESEC(IP) .eq. 1) THEN - DO J=PDLIB_IA(IP),PDLIB_IA(IP+1)-1 - JP=PDLIB_JA(J) - eCoeff=ASPAR(J) - TheOut(IP)=TheOut(IP) + eCoeff*TheIn(JP) - END DO - END IF - END DO - CALL PDLIB_exchange1Dreal(TheOut) - END SUBROUTINE TRIG_WAVE_SETUP_APPLY_FCT -!/ ------------------------------------------------------------------- / -!> -!> @brief Scalar product plus exchange. -!> -!> @param[in] V1 -!> @param[in] V2 -!> @param[inout] eScal -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE TRIG_WAVE_SETUP_SCALAR_PROD(V1, V2, eScal) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : scalar prod. + exchange -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NX - USE W3ADATMD, ONLY: MPI_COMM_WCMP - use yowDatapool, only: rtype, istatus - use yowNodepool, only: np, npa - USE W3ODATMD, only : IAPROC, NAPROC, NTPROC - USE W3GDATMD, ONLY: NSEAL - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - real(8), intent(in) :: V1(npa), V2(npa) - real(8), intent(inout) :: eScal - integer IP, myrank, myproc - real(8) :: rScal(1), lScal(1) - integer iProc - integer ierr - CALL MPI_COMM_RANK(MPI_COMM_WCMP, myrank, ierr) - CALL MPI_COMM_SIZE(MPI_COMM_WCMP, myproc, ierr) - lScal=0 - DO IP=1,np - lScal(1)=lScal(1) + V1(IP)*V2(IP) - END DO - IF (IAPROC .eq. 1) THEN - DO iProc=2,NAPROC - CALL MPI_RECV(rScal,1,rtype, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) - lScal = lScal + rScal - END DO - DO iProc=2,NAPROC - CALL MPI_SEND(lScal,1,rtype, iProc-1, 23, MPI_COMM_WCMP, ierr) - END DO - ELSE - CALL MPI_SEND(lScal,1,rtype, 0, 19, MPI_COMM_WCMP, ierr) - CALL MPI_RECV(lScal,1,rtype, 0, 23, MPI_COMM_WCMP, istatus, ierr) - END IF - eScal=lScal(1) - END SUBROUTINE TRIG_WAVE_SETUP_SCALAR_PROD -!/ ------------------------------------------------------------------- / -!> -!> @brief Poisson equation solver. -!> -!> @param[in] ASPAR -!> @param[in] B -!> @param[out] TheOut -!> @param[in] ACTIVE -!> @param[in] ACTIVESEC -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut, ACTIVE, ACTIVESEC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : poisson eq. solver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE yowNodepool, only: PDLIB_NNZ - USE W3GDATMD, ONLY: NSEAL, SOLVERTHR_STP - USE W3ODATMD, only : IAPROC - use yowNodepool, only: np, npa - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - real(8), intent(in) :: ASPAR(PDLIB_NNZ) - real(8), intent(in) :: B(npa) - real(8), intent(out) :: TheOut(npa) - integer, intent(in) :: ACTIVE(npa), ACTIVESEC(npa) - real(8) :: V_X(npa), V_R(npa), V_Z(npa), V_P(npa), V_Y(npa) - real(8) :: uO, uN, alphaV, h1, h2 - real(8) :: eNorm, beta - real(8) :: SOLVERTHR - integer IP, nbIter - SOLVERTHR=SOLVERTHR_STP - -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'Begin TRIG_WAVE_SETUP_SOLVE ....' - FLUSH(740+IAPROC) -#endif - nbIter=0 - V_X=0 - V_R=B - CALL TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, V_R, V_Z, ACTIVE, ACTIVESEC) - V_P=V_Z - CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_Z, V_R, uO) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'uO=', uO - FLUSH(740+IAPROC) -#endif - CALL TRIG_WAVE_SETUP_SCALAR_PROD(B, B, eNorm) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'eNorm(B)=', eNorm - WRITE(740+IAPROC,*) 'SOLVERTHR=', SOLVERTHR - FLUSH(740+IAPROC) -#endif - WRITE(740+IAPROC,*) 'SOLVERTHR=', SOLVERTHR, ' eNorm(B)=', eNorm - IF (eNorm .le. SOLVERTHR) THEN -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'Leaving here, zero solution' - FLUSH(740+IAPROC) -#endif - TheOut=V_X - RETURN - END IF - DO - nbIter=nbIter + 1 -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) ' nbIter=', nbIter - FLUSH(740+IAPROC) -#endif - CALL TRIG_WAVE_SETUP_APPLY_FCT(ASPAR, V_P, V_Y, ACTIVE, ACTIVESEC) - CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_P, V_Y, h2) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) ' h2=', h2 - FLUSH(740+IAPROC) -#endif - alphaV=uO/h2 -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) ' alphaV=', alphaV - FLUSH(740+IAPROC) -#endif - - ! - DO IP=1,npa - V_X(IP) = V_X(IP) + alphaV * V_P(IP) - V_R(IP) = V_R(IP) - alphaV * V_Y(IP) - END DO - ! - CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_R, V_R, eNorm) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'eNorm=', eNorm - FLUSH(740+IAPROC) -#endif - WRITE(740+IAPROC,*) 'nbIter=', nbIter, ' eNorm(res)=', eNorm - FLUSH(740+IAPROC) - IF (eNorm .le. SOLVERTHR) THEN - EXIT - END IF - ! - CALL TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, V_R, V_Z, ACTIVE, ACTIVESEC) - CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_Z, V_R, uN) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) ' uN=', uN - FLUSH(740+IAPROC) -#endif - ! - beta=uN/uO - uO=uN -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'beta=', beta - FLUSH(740+IAPROC) -#endif - ! - DO IP=1,npa - V_P(IP)=V_Z(IP) + beta * V_P(IP) - END DO - END DO - TheOut=V_X - END SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR -!/ ------------------------------------------------------------------- / -!> -!> @brief Set mean value. -!> -!> @param[inout] TheVar -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE TRIG_SET_MEANVALUE_TO_ZERO(TheVar) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : set. mean value -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE yowNodepool, only: PDLIB_SI - USE W3GDATMD, ONLY: NX, SI - USE W3GDATMD, ONLY: NSEAL - USE W3ADATMD, ONLY: MPI_COMM_WCMP - USE W3ODATMD, only : IAPROC, NAPROC, NTPROC - use yowDatapool, only: rtype, istatus - use yowNodepool, only: np, npa - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - real(8), intent(inout) :: TheVar(npa) - real(8) :: SUM_SI_Var, SUM_SI, TheMean - INTEGER IP, ierr - real(8) :: eVect(2), rVect(2) - integer iProc - SUM_SI_Var=0 - SUM_SI=0 - DO IP=1,np - SUM_SI_Var = SUM_SI_Var + PDLIB_SI(IP)*TheVar(IP) - SUM_SI = SUM_SI + PDLIB_SI(IP) - END DO - eVect(1)=SUM_SI_Var - eVect(2)=SUM_SI -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'SUM_SI_Var=', SUM_SI_Var, 'SUM_SI=', SUM_SI - FLUSH(740+IAPROC) -#endif - IF (IAPROC .eq. 1) THEN - DO iProc=2,NAPROC - CALL MPI_RECV(rVect,2,rtype, iProc-1, 367, MPI_COMM_WCMP, istatus, ierr) - eVect=eVect + rVect - END DO - DO iProc=2,NAPROC - CALL MPI_SEND(eVect,2,rtype, iProc-1, 37, MPI_COMM_WCMP, ierr) - END DO - ELSE - CALL MPI_SEND(eVect,2,rtype, 0, 367, MPI_COMM_WCMP, ierr) - CALL MPI_RECV(eVect,2,rtype, 0, 37, MPI_COMM_WCMP, istatus, ierr) - END IF - SUM_SI_Var=eVect(1) - SUM_SI =eVect(2) - TheMean=SUM_SI_Var/SUM_SI -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'TheMean=', TheMean - FLUSH(740+IAPROC) -#endif - DO IP=1,npa - TheVar(IP)=TheVar(IP) - TheMean - END DO - END SUBROUTINE TRIG_SET_MEANVALUE_TO_ZERO -!/ ------------------------------------------------------------------- / -!> -!> @brief Compute active node for setup comp. -!> -!> @param[in] DWNX -!> @param[out] ACTIVE -!> -!> @author Aron Roland -!> @author Mathieu Dutour-Sikiric -!> @date 1-May-2018 -!> - SUBROUTINE COMPUTE_ACTIVE_NODE(DWNX, ACTIVE) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute active node for setup comp. -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY : CRIT_DEP_STP - USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, iplg, npa, np - USE W3ODATMD, only : IAPROC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - REAL*8, INTENT(in) :: DWNX(npa) - INTEGER, INTENT(out) :: ACTIVE(npa) - INTEGER IP, eAct -#ifdef W3_DEBUGSTP - INTEGER nbActive - nbActive=0 -#endif - DO IP=1,NPA - IF (DWNX(IP) .ge. CRIT_DEP_STP) THEN - eAct=1 - ELSE - eAct=0 - END IF -#ifdef W3_DEBUGSTP - nbActive=nbActive + eAct -#endif - ACTIVE(IP)=eAct - END DO -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'min/max(DWNX)=', minval(DWNX), maxval(DWNX) - WRITE(740+IAPROC,*) 'CRIT_DEP_STP=', CRIT_DEP_STP - WRITE(740+IAPROC,*) 'nbActive=', nbActive, ' npa=', npa - FLUSH(740+IAPROC) -#endif - END SUBROUTINE COMPUTE_ACTIVE_NODE -!/ ------------------------------------------------------------------- / -!> -!> @brief Setup computation. -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Setup computation -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, iplg, npa, np - USE W3GDATMD, only : MAPFS - USE W3PARALL, only : SYNCHRONIZE_GLOBAL_ARRAY - USE W3ADATMD, ONLY: DW - USE W3GDATMD, ONLY: NSEAL, NSEA, NX - USE W3WDATMD, ONLY: ZETA_SETUP - USE W3ODATMD, only : IAPROC, NAPROC, NTPROC - USE W3PARALL, only: INIT_GET_ISEA - use yowExchangeModule, only : PDLIB_exchange1Dreal - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! -! CALL W3SETG - REAL(8) :: ZETA_WORK(npa), ZETA_WORK_ALL(NX) - REAL(8) :: F_X(npa), F_Y(npa), DWNX(npa) - REAL(8) :: ASPAR(PDLIB_NNZ), B(npa) - INTEGER I, ISEA, JSEA, IX, IP, IP_glob - INTEGER :: ACTIVE(npa), ACTIVESEC(npa) -! ZETA_SETUP is allocated on 1:NSEA -! ZETA_WORK is on 1:npa -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, ' NTPROC=', NTPROC - WRITE(740+IAPROC,*) 'NSEAL=', NSEAL - WRITE(740+IAPROC,*) 'npa=', npa, ' np=', np -#endif - FLUSH(740+IAPROC) - ZETA_WORK=0 - DO IP=1,npa - IX=iplg(IP) - ISEA=MAPFS(1,IX) - IF (ISEA .gt. 0) THEN - ZETA_WORK(IP)=ZETA_SETUP(ISEA) - END IF - END DO -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'Before TRIG_COMPUTE_LH_STRESS' - FLUSH(740+IAPROC) -#endif - - CALL TRIG_COMPUTE_LH_STRESS(F_X, F_Y, DWNX) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'After TRIG_COMPUTE_LH_STRESS' - FLUSH(740+IAPROC) -#endif - CALL COMPUTE_ACTIVE_NODE(DWNX, ACTIVE) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'After COMPUTE_ACTIVE_NODE' - FLUSH(740+IAPROC) -#endif - CALL TRIG_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, F_X, F_Y, DWNX, ACTIVE, ACTIVESEC) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'Before,B,min=', minval(B), ' max=', maxval(B) - FLUSH(740+IAPROC) -#endif - - -! CALL TRIG_SET_MEANVALUE_TO_ZERO(B) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'After,B,min=', minval(B), ' max=', maxval(B) - FLUSH(740+IAPROC) -#endif - - - CALL TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, ZETA_WORK, ACTIVE, ACTIVESEC) - - CALL TRIG_SET_MEANVALUE_TO_ZERO(ZETA_WORK) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'After SET_MEAN min=', minval(ZETA_WORK), ' max=', maxval(ZETA_WORK) - FLUSH(740+IAPROC) -#endif - DO IP=1,npa - IX=iplg(IP) - ZETA_WORK_ALL(IX)=ZETA_WORK(IP) - END DO - CALL SYNCHRONIZE_GLOBAL_ARRAY(ZETA_WORK_ALL) - DO IX=1,NX - ISEA=MAPFS(1,IX) - IF (ISEA .gt. 0) THEN - ZETA_SETUP(ISEA) = ZETA_WORK_ALL(IX) - END IF - END DO -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'Now exiting TRIG_WAVE_SETUP_COMPUTATION' - FLUSH(740+IAPROC) -#endif - END SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION -!/ ------------------------------------------------------------------- / -!> -!> @brief Wave setup for FD grids. -!> -!> @param[in] IMOD -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE PREPARATION_FD_SCHEME(IMOD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Wave setup for FD grids -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, PDLIB_I_DIAG - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, GRIDS - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - integer, intent(in) :: IMOD - integer IN, ISEA, nbEdge - integer IX, IY, idx - integer NeighMat(4,2) - integer, allocatable :: STAT_SeaLand(:,:) - integer, allocatable :: EDGES(:,:) - integer IXN, JXN, JSEA, J - ! - allocate(GRIDS(IMOD)%NEIGH(NSEA,4)) - GRIDS(IMOD)%NEIGH=0 - allocate(STAT_SeaLand(NX,NY)) - STAT_SeaLand=0 - DO ISEA=1,NSEA - IX=MAPSF(ISEA,1) - IY=MAPSF(ISEA,2) - STAT_SeaLand(IX,IY)=ISEA - END DO - NeighMat(1,1)=1 - NeighMat(1,2)=0 - NeighMat(2,1)=-1 - NeighMat(2,2)=0 - NeighMat(3,1)=0 - NeighMat(3,2)=1 - NeighMat(4,1)=0 - NeighMat(4,2)=-1 - nbEdge=0 - PDLIB_NNZ=0 - DO ISEA=1,NSEA - IX=MAPSF(ISEA,1) - IY=MAPSF(ISEA,2) - idx=0 - DO IN=1,4 - IXN=IX+NeighMat(IN,1) - JXN=IX+NeighMat(IN,2) - JSEA=STAT_SeaLand(IXN,JXN) - IF (JSEA .gt. 0) THEN - idx=idx+1 - GRIDS(IMOD)%NEIGH(ISEA,idx)=JSEA - IF (JSEA < ISEA) THEN - nbEdge=nbEdge+1 - END IF - PDLIB_NNZ=PDLIB_NNZ+1 - END IF - END DO - PDLIB_NNZ=PDLIB_NNZ+1 - END DO - ! - GRIDS(IMOD)%NBEDGE=NBEDGE - ALLOCATE(GRIDS(IMOD)%EDGES(NBEDGE,2)) - idx=0 - DO ISEA=1,NSEA - IX=MAPSF(ISEA,1) - IY=MAPSF(ISEA,2) - DO IN=1,4 - IXN=IX+NeighMat(IN,1) - JXN=IX+NeighMat(IN,2) - JSEA=STAT_SeaLand(IXN,JXN) - IF (JSEA .gt. 0) THEN - IF (JSEA < ISEA) THEN - idx=idx+1 - GRIDS(IMOD)%EDGES(idx,1)=JSEA - GRIDS(IMOD)%EDGES(idx,2)=ISEA - END IF - END IF - END DO - END DO - ! - ALLOCATE(PDLIB_IA(NSEA+1)) - ALLOCATE(PDLIB_JA(PDLIB_NNZ)) - ALLOCATE(PDLIB_I_DIAG(NSEA)) - PDLIB_IA(1)=1 - J=0 - DO ISEA=1,NSEA - DO IN=1,4 - IXN=IX+NeighMat(IN,1) - JXN=IX+NeighMat(IN,2) - JSEA=STAT_SeaLand(IXN,JXN) - IF (JSEA .gt. 0) THEN - J=J+1 - PDLIB_JA(J)=JSEA - END IF - END DO - J=J+1 - PDLIB_JA(J)=ISEA - PDLIB_I_DIAG(ISEA)=J - PDLIB_IA(ISEA+1)=J+1 - END DO - END SUBROUTINE PREPARATION_FD_SCHEME -!/ ------------------------------------------------------------------- / -!> -!> @brief Compute off diagonal for FD grids. -!> -!> @param[in] ASPAR -!> @param[in] TheIn -!> @param[out] TheOut -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE FD_WAVE_SETUP_APPLY_FCT(ASPAR, TheIn, TheOut) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : comp. off diagonal for FD grids -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NX, NNZ, IAA, JAA, NSEA - use yowNodepool, only: PDLIB_IA, PDLIB_JA - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - REAL(8), intent(in) :: ASPAR(NNZ) - REAL(8), intent(in) :: TheIn(NSEA) - REAL(8), intent(out) :: TheOut(NSEA) - integer IP, J, JP - REAL(8) :: eCoeff - TheOut=0 - DO IP=1,NSEA - DO J=PDLIB_IA(IP),PDLIB_IA(IP+1)-1 - JP=PDLIB_JA(J) - eCoeff=ASPAR(J) - TheOut(IP)=TheOut(IP) + eCoeff*TheIn(JP) - END DO - END DO - END SUBROUTINE FD_WAVE_SETUP_APPLY_FCT -!/ ------------------------------------------------------------------- / -!> -!> @brief Preconditioning for FD grids. -!> -!> @param[in] ASPAR -!> @param[in] TheIn -!> @param[out] TheOut -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE FD_WAVE_SETUP_APPLY_PRECOND(ASPAR, TheIn, TheOut) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Precond. for FD grids -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, PDLIB_I_DIAG - USE W3GDATMD, ONLY: NSEA - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - REAL(8), intent(in) :: ASPAR(PDLIB_NNZ) - REAL(8), intent(in) :: TheIn(NSEA) - REAL(8), intent(out) :: TheOut(NSEA) - integer IP, J1, J, JP, J2 - REAL(8) :: eCoeff - INTEGER :: ThePrecond = 0 - IF (ThePrecond .eq. 0) THEN - TheOut=TheIn - END IF - IF (ThePrecond .eq. 1) THEN - TheOut=0 - DO IP=1,NSEA - J1=PDLIB_I_DIAG(IP) - DO J=PDLIB_IA(IP),PDLIB_IA(IP+1)-1 - JP=PDLIB_JA(J) - IF (J .eq. J1) THEN - eCoeff=1.0/ASPAR(J) - ELSE - J2=PDLIB_I_DIAG(JP) - eCoeff=-ASPAR(J) /(ASPAR(J1)*ASPAR(J2)) - END IF - TheOut(IP)=TheOut(IP) + eCoeff*TheIn(JP) - END DO - END DO - END IF - IF (ThePrecond .eq. 2) THEN - - DO IP=1,NSEA - J=PDLIB_I_DIAG(IP) - TheOut(IP)=TheIn(IP)/ASPAR(J) - END DO - END IF - END SUBROUTINE FD_WAVE_SETUP_APPLY_PRECOND -!/ ------------------------------------------------------------------- / -!> -!> @brief Radiation stresses for FD grids. -!> -!> @param[out] SXX_t -!> @param[out] SXY_t -!> @param[out] SYY_t -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE FD_COLLECT_SXX_XY_YY(SXX_t, SXY_t, SYY_t) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Rad. stresses for FD grids -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3ADATMD, ONLY: SXX, SXY, SYY - USE W3GDATMD, ONLY: NSEA, NSEAL - USE W3ODATMD, only : IAPROC, NAPROC - use yowDatapool, only: rtype, istatus - USE W3ADATMD, ONLY: MPI_COMM_WCMP - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - integer ISEA, JSEA - integer ierr - real(8), intent(out) :: SXX_t(NSEA), SXY_t(NSEA), SYY_t(NSEA) - real(8) :: SXX_p(NSEAL), SXY_p(NSEAL), SYY_p(NSEAL) - real(8), allocatable :: rVect(:) - integer IPROC, NSEAL_loc - DO ISEA=1,NSEAL - SXX_p(ISEA)=SXX(ISEA) - SXY_p(ISEA)=SXY(ISEA) - SYY_p(ISEA)=SYY(ISEA) - END DO - IF (IAPROC .eq. 1) THEN - DO JSEA=1,NSEAL - ISEA=1 + (JSEA-1)*NAPROC - SXX_t(ISEA)=SXX_p(JSEA) - SXY_t(ISEA)=SXY_p(JSEA) - SYY_t(ISEA)=SYY_p(JSEA) - END DO - DO IPROC=2,NAPROC - NSEAL_loc=1 + (NSEA-IPROC)/NAPROC - allocate(rVect(NSEAL_loc)) - CALL MPI_RECV(rVect,NSEAL_loc,rtype, iProc-1, 83, MPI_COMM_WCMP, istatus, ierr) - DO JSEA=1,NSEAL_loc - ISEA = IPROC + (JSEA-1)*NAPROC - SXX_t(ISEA)=rVect(JSEA) - END DO - CALL MPI_RECV(rVect,NSEAL_loc,rtype, iProc-1, 89, MPI_COMM_WCMP, istatus, ierr) - DO JSEA=1,NSEAL_loc - ISEA = IPROC + (JSEA-1)*NAPROC - SXY_t(ISEA)=rVect(JSEA) - END DO - CALL MPI_RECV(rVect,NSEAL_loc,rtype, iProc-1, 97, MPI_COMM_WCMP, istatus, ierr) - DO JSEA=1,NSEAL_loc - ISEA = IPROC + (JSEA-1)*NAPROC - SYY_t(ISEA)=rVect(JSEA) - END DO - deallocate(rVect) - END DO - ELSE - CALL MPI_SEND(SXX_p,NSEAL,rtype, 0, 83, MPI_COMM_WCMP, ierr) - CALL MPI_SEND(SXY_p,NSEAL,rtype, 0, 83, MPI_COMM_WCMP, ierr) - CALL MPI_SEND(SYY_p,NSEAL,rtype, 0, 83, MPI_COMM_WCMP, ierr) - END IF - END SUBROUTINE FD_COLLECT_SXX_XY_YY -!/ ------------------------------------------------------------------- / -!> -!> @brief Setup fluxes. -!> -!> @param[in] SXX_t -!> @param[in] SXY_t -!> @param[in] SYY_t -!> @param[out] FX -!> @param[out] FY -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE FD_COMPUTE_LH_STRESS(SXX_t, SXY_t, SYY_t, FX, FY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : setup fluxes -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + END DO +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Before TRIG_COMPUTE_LH_STRESS' + FLUSH(740+IAPROC) #endif -! - USE W3GDATMD, ONLY: NX, NY, NSEA, NEIGH - USE W3ADATMD, ONLY: SXX, SXY, SYY - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + + CALL TRIG_COMPUTE_LH_STRESS(F_X, F_Y, DWNX) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'After TRIG_COMPUTE_LH_STRESS' + FLUSH(740+IAPROC) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - real(8), intent(in) :: SXX_t(NSEA), SXY_t(NSEA), SYY_t(NSEA) - real(8), intent(out) :: FX(NSEA), FY(NSEA) - REAL(8) :: h - REAL(8) :: SXX_X, SXX_Y - REAL(8) :: SXY_X, SXY_Y - REAL(8) :: SYY_X, SYY_Y - REAL(8) :: eFX, eFY - REAL(8) :: UGRAD, VGRAD - INTEGER IE, I1, I2, I3, IP1, IP2, IP3 - integer ISEA, JSEA1, JSEA2, JSEA3, JSEA4 - integer NeighMat(4,2) - real(8) dist_X, dist_Y - ! - NeighMat(1,1)=1 - NeighMat(1,2)=0 - NeighMat(2,1)=-1 - NeighMat(2,2)=0 - NeighMat(3,1)=0 - NeighMat(3,2)=1 - NeighMat(4,1)=0 - NeighMat(4,2)=-1 - FX=0 - FY=0 - DO ISEA=1,NSEA - JSEA1=NEIGH(ISEA,1) - JSEA2=NEIGH(ISEA,2) - JSEA3=NEIGH(ISEA,3) - JSEA4=NEIGH(ISEA,4) - SXX_X=0 - SXX_Y=0 - SXY_X=0 - SXY_Y=0 - SYY_X=0 - SYY_Y=0 - IF ((JSEA1 .gt. 0).and.(JSEA2 .gt. 0)) THEN - SXX_X=(SXX(JSEA1) - SXX(JSEA2))/(2*dist_X) - SXY_X=(SXY(JSEA1) - SXY(JSEA2))/(2*dist_X) - SYY_X=(SXY(JSEA1) - SYY(JSEA2))/(2*dist_X) - END IF - IF ((JSEA1 .gt. 0).and.(JSEA2 .eq. 0)) THEN - SXX_X=(SXX(JSEA1) - SXX(ISEA ))/dist_X - SXY_X=(SXY(JSEA1) - SXY(ISEA ))/dist_X - SYY_X=(SXY(JSEA1) - SYY(ISEA ))/dist_X - END IF - IF ((JSEA1 .eq. 0).and.(JSEA2 .gt. 0)) THEN - SXX_X=(SXX(ISEA ) - SXX(JSEA2))/dist_X - SXY_X=(SXY(ISEA ) - SXY(JSEA2))/dist_X - SYY_X=(SXY(ISEA ) - SYY(JSEA2))/dist_X - END IF - IF ((JSEA3 .gt. 0).and.(JSEA4 .gt. 0)) THEN - SXX_X=(SXX(JSEA3) - SXX(JSEA4))/(2*dist_Y) - SXY_X=(SXY(JSEA3) - SXY(JSEA4))/(2*dist_Y) - SYY_X=(SXY(JSEA3) - SYY(JSEA4))/(2*dist_Y) - END IF - IF ((JSEA3 .eq. 0).and.(JSEA4 .gt. 0)) THEN - SXX_X=(SXX(ISEA ) - SXX(JSEA4))/dist_Y - SXY_X=(SXY(ISEA ) - SXY(JSEA4))/dist_Y - SYY_X=(SXY(ISEA ) - SYY(JSEA4))/dist_Y - END IF - IF ((JSEA3 .gt. 0).and.(JSEA4 .gt. 0)) THEN - SXX_X=(SXX(JSEA3) - SXX(ISEA ))/dist_Y - SXY_X=(SXY(JSEA3) - SXY(ISEA ))/dist_Y - SYY_X=(SXY(JSEA3) - SYY(ISEA ))/dist_Y - END IF - eFX=-SXX_X - SXY_Y - eFY=-SYY_Y - SXY_X - FX(ISEA)=eFX - FY(ISEA)=eFY - END DO - END SUBROUTINE FD_COMPUTE_LH_STRESS -!/ ------------------------------------------------------------------- / -!> -!> @brief Differences on FD grids. -!> -!> @param[in] IEDGE -!> @param[in] ISEA -!> @param[inout] UGRAD -!> @param[inout] VGRAD -!> @param[inout] dist -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE FD_COMPUTE_DIFF(IEDGE, ISEA, UGRAD, VGRAD, dist) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : differences on FD grids -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + CALL COMPUTE_ACTIVE_NODE(DWNX, ACTIVE) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'After COMPUTE_ACTIVE_NODE' + FLUSH(740+IAPROC) #endif -! - USE W3GDATMD, ONLY: MAPSF, EDGES - USE W3GDATMD, ONLY: XGRD, YGRD - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + CALL TRIG_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, F_X, F_Y, DWNX, ACTIVE, ACTIVESEC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Before,B,min=', minval(B), ' max=', maxval(B) + FLUSH(740+IAPROC) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - INTEGER, intent(in) :: IEDGE, ISEA - REAL(8), intent(inout) :: UGRAD, VGRAD, dist - REAL(8) :: h - integer I2, I3, IP1, IP2, IP3 - integer IX1, IY1, IX2, IY2 - integer ISEA1, ISEA2 - REAL(8) deltaX, deltaY - ! - ISEA1=EDGES(IEDGE,1) - ISEA2=EDGES(IEDGE,2) - IX1=MAPSF(ISEA1,1) - IY1=MAPSF(ISEA1,2) - IX2=MAPSF(ISEA2,1) - IY2=MAPSF(ISEA2,2) - deltaX=XGRD(IX1,IY1) - XGRD(IX2,IY2) - deltaY=YGRD(IX1,IY1) - YGRD(IX2,IY2) - dist=SQRT(deltaX*deltaX + deltaY*deltaY) - IF (ISEA .eq. ISEA1) THEN - UGRAD= deltaX/dist - VGRAD= deltaY/dist - ELSE - UGRAD=-deltaX/dist - VGRAD=-deltaY/dist - END IF - END SUBROUTINE FD_COMPUTE_DIFF -!/ ------------------------------------------------------------------- / -!> -!> @brief Setup matrix on FD grids. -!> -!> @param[out] ASPAR -!> @param[out] B -!> @param[in] FX -!> @param[in] FY -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE FD_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, FX, FY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Setup matrix on FD grids -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + + + ! CALL TRIG_SET_MEANVALUE_TO_ZERO(B) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'After,B,min=', minval(B), ' max=', maxval(B) + FLUSH(740+IAPROC) #endif -! - USE yowNodepool, only: PDLIB_NNZ - USE W3GDATMD, ONLY: NX, NY, NSEA, NBEDGE, EDGES - USE W3ADATMD, ONLY: DW - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + + + CALL TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, ZETA_WORK, ACTIVE, ACTIVESEC) + + CALL TRIG_SET_MEANVALUE_TO_ZERO(ZETA_WORK) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'After SET_MEAN min=', minval(ZETA_WORK), ' max=', maxval(ZETA_WORK) + FLUSH(740+IAPROC) +#endif + DO IP=1,npa + IX=iplg(IP) + ZETA_WORK_ALL(IX)=ZETA_WORK(IP) + END DO + CALL SYNCHRONIZE_GLOBAL_ARRAY(ZETA_WORK_ALL) + DO IX=1,NX + ISEA=MAPFS(1,IX) + IF (ISEA .gt. 0) THEN + ZETA_SETUP(ISEA) = ZETA_WORK_ALL(IX) + END IF + END DO +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Now exiting TRIG_WAVE_SETUP_COMPUTATION' + FLUSH(740+IAPROC) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - real(8), intent(in) :: FX(NSEA), FY(NSEA) - real(8), intent(out) :: ASPAR(PDLIB_NNZ) - real(8), intent(out) :: B(NX) - INTEGER :: POS_TRICK(3,2), POS_SHIFT(3,3) - integer I1, I2, I3, IP1, IP2, IP3 - integer IDX, IDX1, IDX2, IDX3 - INTEGER IE, IP, I, J, K, IPp, JPp - real(8) :: eDep, eFX, eFY, eScal, eFact, eLen - real(8) :: UGRAD, VGRAD, UGRAD1, VGRAD1, dist1, dist2 - INTEGER LIDX(2), KIDX(2), jdx - INTEGER ISEAREL, JSEAREL, ISEA, JSEA, IEDGE - ! - ASPAR=0 - B=0 - DO IEDGE=1,NBEDGE - ISEA=EDGES(IEDGE,1) - JSEA=EDGES(IEDGE,2) - eDep=(DW(ISEA) + DW(JSEA))/2.0 - eFX =(FX(ISEA) + FX(JSEA))/2.0 - eFY =(FY(ISEA) + FY(JSEA))/2.0 - DO I=1,2 - ISEAREL=EDGES(IEDGE,I) - CALL FD_COMPUTE_DIFF(IEDGE, ISEAREL, UGRAD1, VGRAD1, dist1) - eScal=UGRAD1*eFX + VGRAD1*eFY - B(ISEAREL) = B(ISEAREL) + eScal*dist1 - ! - DO J=1,2 - JSEAREL=EDGES(IEDGE,J) - CALL FD_COMPUTE_DIFF(IEDGE, JSEAREL, UGRAD, VGRAD, dist2) - eScal=UGRAD*UGRAD1 + VGRAD*VGRAD1 - ASPAR(J)=ASPAR(J)+eFact*eScal - END DO + END SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION + !/ ------------------------------------------------------------------- / + !> + !> @brief Wave setup for FD grids. + !> + !> @param[in] IMOD + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE PREPARATION_FD_SCHEME(IMOD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Wave setup for FD grids + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, PDLIB_I_DIAG + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, GRIDS + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + integer, intent(in) :: IMOD + integer IN, ISEA, nbEdge + integer IX, IY, idx + integer NeighMat(4,2) + integer, allocatable :: STAT_SeaLand(:,:) + integer, allocatable :: EDGES(:,:) + integer IXN, JXN, JSEA, J + ! + allocate(GRIDS(IMOD)%NEIGH(NSEA,4)) + GRIDS(IMOD)%NEIGH=0 + allocate(STAT_SeaLand(NX,NY)) + STAT_SeaLand=0 + DO ISEA=1,NSEA + IX=MAPSF(ISEA,1) + IY=MAPSF(ISEA,2) + STAT_SeaLand(IX,IY)=ISEA + END DO + NeighMat(1,1)=1 + NeighMat(1,2)=0 + NeighMat(2,1)=-1 + NeighMat(2,2)=0 + NeighMat(3,1)=0 + NeighMat(3,2)=1 + NeighMat(4,1)=0 + NeighMat(4,2)=-1 + nbEdge=0 + PDLIB_NNZ=0 + DO ISEA=1,NSEA + IX=MAPSF(ISEA,1) + IY=MAPSF(ISEA,2) + idx=0 + DO IN=1,4 + IXN=IX+NeighMat(IN,1) + JXN=IX+NeighMat(IN,2) + JSEA=STAT_SeaLand(IXN,JXN) + IF (JSEA .gt. 0) THEN + idx=idx+1 + GRIDS(IMOD)%NEIGH(ISEA,idx)=JSEA + IF (JSEA < ISEA) THEN + nbEdge=nbEdge+1 + END IF + PDLIB_NNZ=PDLIB_NNZ+1 + END IF + END DO + PDLIB_NNZ=PDLIB_NNZ+1 + END DO + ! + GRIDS(IMOD)%NBEDGE=NBEDGE + ALLOCATE(GRIDS(IMOD)%EDGES(NBEDGE,2)) + idx=0 + DO ISEA=1,NSEA + IX=MAPSF(ISEA,1) + IY=MAPSF(ISEA,2) + DO IN=1,4 + IXN=IX+NeighMat(IN,1) + JXN=IX+NeighMat(IN,2) + JSEA=STAT_SeaLand(IXN,JXN) + IF (JSEA .gt. 0) THEN + IF (JSEA < ISEA) THEN + idx=idx+1 + GRIDS(IMOD)%EDGES(idx,1)=JSEA + GRIDS(IMOD)%EDGES(idx,2)=ISEA + END IF + END IF + END DO + END DO + ! + ALLOCATE(PDLIB_IA(NSEA+1)) + ALLOCATE(PDLIB_JA(PDLIB_NNZ)) + ALLOCATE(PDLIB_I_DIAG(NSEA)) + PDLIB_IA(1)=1 + J=0 + DO ISEA=1,NSEA + DO IN=1,4 + IXN=IX+NeighMat(IN,1) + JXN=IX+NeighMat(IN,2) + JSEA=STAT_SeaLand(IXN,JXN) + IF (JSEA .gt. 0) THEN + J=J+1 + PDLIB_JA(J)=JSEA + END IF + END DO + J=J+1 + PDLIB_JA(J)=ISEA + PDLIB_I_DIAG(ISEA)=J + PDLIB_IA(ISEA+1)=J+1 + END DO + END SUBROUTINE PREPARATION_FD_SCHEME + !/ ------------------------------------------------------------------- / + !> + !> @brief Compute off diagonal for FD grids. + !> + !> @param[in] ASPAR + !> @param[in] TheIn + !> @param[out] TheOut + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE FD_WAVE_SETUP_APPLY_FCT(ASPAR, TheIn, TheOut) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : comp. off diagonal for FD grids + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY: NX, NNZ, IAA, JAA, NSEA + use yowNodepool, only: PDLIB_IA, PDLIB_JA + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + REAL(8), intent(in) :: ASPAR(NNZ) + REAL(8), intent(in) :: TheIn(NSEA) + REAL(8), intent(out) :: TheOut(NSEA) + integer IP, J, JP + REAL(8) :: eCoeff + TheOut=0 + DO IP=1,NSEA + DO J=PDLIB_IA(IP),PDLIB_IA(IP+1)-1 + JP=PDLIB_JA(J) + eCoeff=ASPAR(J) + TheOut(IP)=TheOut(IP) + eCoeff*TheIn(JP) + END DO + END DO + END SUBROUTINE FD_WAVE_SETUP_APPLY_FCT + !/ ------------------------------------------------------------------- / + !> + !> @brief Preconditioning for FD grids. + !> + !> @param[in] ASPAR + !> @param[in] TheIn + !> @param[out] TheOut + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE FD_WAVE_SETUP_APPLY_PRECOND(ASPAR, TheIn, TheOut) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Precond. for FD grids + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, PDLIB_I_DIAG + USE W3GDATMD, ONLY: NSEA + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + REAL(8), intent(in) :: ASPAR(PDLIB_NNZ) + REAL(8), intent(in) :: TheIn(NSEA) + REAL(8), intent(out) :: TheOut(NSEA) + integer IP, J1, J, JP, J2 + REAL(8) :: eCoeff + INTEGER :: ThePrecond = 0 + IF (ThePrecond .eq. 0) THEN + TheOut=TheIn + END IF + IF (ThePrecond .eq. 1) THEN + TheOut=0 + DO IP=1,NSEA + J1=PDLIB_I_DIAG(IP) + DO J=PDLIB_IA(IP),PDLIB_IA(IP+1)-1 + JP=PDLIB_JA(J) + IF (J .eq. J1) THEN + eCoeff=1.0/ASPAR(J) + ELSE + J2=PDLIB_I_DIAG(JP) + eCoeff=-ASPAR(J) /(ASPAR(J1)*ASPAR(J2)) + END IF + TheOut(IP)=TheOut(IP) + eCoeff*TheIn(JP) END DO END DO - END SUBROUTINE FD_WAVE_SETUP_COMPUTE_SYSTEM -!/ ------------------------------------------------------------------- / -!> -!> @brief Scalar product. -!> -!> @param[in] V1 -!> @param[in] V2 -!> @param[inout] eScal -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE FD_WAVE_SETUP_SCALAR_PROD(V1, V2, eScal) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : scalar prod. -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NX - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - real(8), intent(in) :: V1(NX), V2(NX) - real(8), intent(inout) :: eScal - integer IP - eScal=0 - DO IP=1,NX - eScal=eScal + V1(IP)*V2(IP) + END IF + IF (ThePrecond .eq. 2) THEN + + DO IP=1,NSEA + J=PDLIB_I_DIAG(IP) + TheOut(IP)=TheIn(IP)/ASPAR(J) END DO - END SUBROUTINE FD_WAVE_SETUP_SCALAR_PROD -!/ ------------------------------------------------------------------- / -!> -!> @brief Poisson solver on FD grids. -!> -!> @param[in] ASPAR -!> @param[in] B -!> @param[out] TheOut -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE FD_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : possoin solver on fd grids -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE yowNodepool, only: PDLIB_NNZ - USE W3GDATMD, ONLY: NX - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - real(8), intent(in) :: ASPAR(PDLIB_NNZ) - real(8), intent(in) :: B(NX) - real(8), intent(out) :: TheOut(NX) - real(8) :: V_X(NX), V_R(NX), V_Z(NX), V_P(NX), V_Y(NX) - real(8) :: uO, uN, alphaV, h1, h2 - real(8) :: eNorm, beta - real(8) :: SOLVERTHR - integer IP, nbIter - SOLVERTHR=0.00000001 - nbIter=0 - V_X=0 - V_R=B - CALL FD_WAVE_SETUP_APPLY_PRECOND(ASPAR, V_R, V_Z) - V_P=V_Z - CALL FD_WAVE_SETUP_SCALAR_PROD(V_Z, V_R, uO) - DO - nbIter=nbIter + 1 - CALL FD_WAVE_SETUP_APPLY_FCT(ASPAR, V_P, V_Y) - CALL FD_WAVE_SETUP_SCALAR_PROD(V_P, V_Y, h2) - alphaV=uO/h2 - ! - DO IP=1,NX - V_X(IP) = V_X(IP) + alphaV * V_P(IP) - V_R(IP) = V_R(IP) - alphaV * V_Y(IP) + END IF + END SUBROUTINE FD_WAVE_SETUP_APPLY_PRECOND + !/ ------------------------------------------------------------------- / + !> + !> @brief Radiation stresses for FD grids. + !> + !> @param[out] SXX_t + !> @param[out] SXY_t + !> @param[out] SYY_t + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE FD_COLLECT_SXX_XY_YY(SXX_t, SXY_t, SYY_t) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Rad. stresses for FD grids + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3ADATMD, ONLY: SXX, SXY, SYY + USE W3GDATMD, ONLY: NSEA, NSEAL + USE W3ODATMD, only : IAPROC, NAPROC + use yowDatapool, only: rtype, istatus + USE W3ADATMD, ONLY: MPI_COMM_WCMP + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + integer ISEA, JSEA + integer ierr + real(8), intent(out) :: SXX_t(NSEA), SXY_t(NSEA), SYY_t(NSEA) + real(8) :: SXX_p(NSEAL), SXY_p(NSEAL), SYY_p(NSEAL) + real(8), allocatable :: rVect(:) + integer IPROC, NSEAL_loc + DO ISEA=1,NSEAL + SXX_p(ISEA)=SXX(ISEA) + SXY_p(ISEA)=SXY(ISEA) + SYY_p(ISEA)=SYY(ISEA) + END DO + IF (IAPROC .eq. 1) THEN + DO JSEA=1,NSEAL + ISEA=1 + (JSEA-1)*NAPROC + SXX_t(ISEA)=SXX_p(JSEA) + SXY_t(ISEA)=SXY_p(JSEA) + SYY_t(ISEA)=SYY_p(JSEA) + END DO + DO IPROC=2,NAPROC + NSEAL_loc=1 + (NSEA-IPROC)/NAPROC + allocate(rVect(NSEAL_loc)) + CALL MPI_RECV(rVect,NSEAL_loc,rtype, iProc-1, 83, MPI_COMM_WCMP, istatus, ierr) + DO JSEA=1,NSEAL_loc + ISEA = IPROC + (JSEA-1)*NAPROC + SXX_t(ISEA)=rVect(JSEA) END DO + CALL MPI_RECV(rVect,NSEAL_loc,rtype, iProc-1, 89, MPI_COMM_WCMP, istatus, ierr) + DO JSEA=1,NSEAL_loc + ISEA = IPROC + (JSEA-1)*NAPROC + SXY_t(ISEA)=rVect(JSEA) + END DO + CALL MPI_RECV(rVect,NSEAL_loc,rtype, iProc-1, 97, MPI_COMM_WCMP, istatus, ierr) + DO JSEA=1,NSEAL_loc + ISEA = IPROC + (JSEA-1)*NAPROC + SYY_t(ISEA)=rVect(JSEA) + END DO + deallocate(rVect) + END DO + ELSE + CALL MPI_SEND(SXX_p,NSEAL,rtype, 0, 83, MPI_COMM_WCMP, ierr) + CALL MPI_SEND(SXY_p,NSEAL,rtype, 0, 83, MPI_COMM_WCMP, ierr) + CALL MPI_SEND(SYY_p,NSEAL,rtype, 0, 83, MPI_COMM_WCMP, ierr) + END IF + END SUBROUTINE FD_COLLECT_SXX_XY_YY + !/ ------------------------------------------------------------------- / + !> + !> @brief Setup fluxes. + !> + !> @param[in] SXX_t + !> @param[in] SXY_t + !> @param[in] SYY_t + !> @param[out] FX + !> @param[out] FY + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE FD_COMPUTE_LH_STRESS(SXX_t, SXY_t, SYY_t, FX, FY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : setup fluxes + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY: NX, NY, NSEA, NEIGH + USE W3ADATMD, ONLY: SXX, SXY, SYY + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + real(8), intent(in) :: SXX_t(NSEA), SXY_t(NSEA), SYY_t(NSEA) + real(8), intent(out) :: FX(NSEA), FY(NSEA) + REAL(8) :: h + REAL(8) :: SXX_X, SXX_Y + REAL(8) :: SXY_X, SXY_Y + REAL(8) :: SYY_X, SYY_Y + REAL(8) :: eFX, eFY + REAL(8) :: UGRAD, VGRAD + INTEGER IE, I1, I2, I3, IP1, IP2, IP3 + integer ISEA, JSEA1, JSEA2, JSEA3, JSEA4 + integer NeighMat(4,2) + real(8) dist_X, dist_Y + ! + NeighMat(1,1)=1 + NeighMat(1,2)=0 + NeighMat(2,1)=-1 + NeighMat(2,2)=0 + NeighMat(3,1)=0 + NeighMat(3,2)=1 + NeighMat(4,1)=0 + NeighMat(4,2)=-1 + FX=0 + FY=0 + DO ISEA=1,NSEA + JSEA1=NEIGH(ISEA,1) + JSEA2=NEIGH(ISEA,2) + JSEA3=NEIGH(ISEA,3) + JSEA4=NEIGH(ISEA,4) + SXX_X=0 + SXX_Y=0 + SXY_X=0 + SXY_Y=0 + SYY_X=0 + SYY_Y=0 + IF ((JSEA1 .gt. 0).and.(JSEA2 .gt. 0)) THEN + SXX_X=(SXX(JSEA1) - SXX(JSEA2))/(2*dist_X) + SXY_X=(SXY(JSEA1) - SXY(JSEA2))/(2*dist_X) + SYY_X=(SXY(JSEA1) - SYY(JSEA2))/(2*dist_X) + END IF + IF ((JSEA1 .gt. 0).and.(JSEA2 .eq. 0)) THEN + SXX_X=(SXX(JSEA1) - SXX(ISEA ))/dist_X + SXY_X=(SXY(JSEA1) - SXY(ISEA ))/dist_X + SYY_X=(SXY(JSEA1) - SYY(ISEA ))/dist_X + END IF + IF ((JSEA1 .eq. 0).and.(JSEA2 .gt. 0)) THEN + SXX_X=(SXX(ISEA ) - SXX(JSEA2))/dist_X + SXY_X=(SXY(ISEA ) - SXY(JSEA2))/dist_X + SYY_X=(SXY(ISEA ) - SYY(JSEA2))/dist_X + END IF + IF ((JSEA3 .gt. 0).and.(JSEA4 .gt. 0)) THEN + SXX_X=(SXX(JSEA3) - SXX(JSEA4))/(2*dist_Y) + SXY_X=(SXY(JSEA3) - SXY(JSEA4))/(2*dist_Y) + SYY_X=(SXY(JSEA3) - SYY(JSEA4))/(2*dist_Y) + END IF + IF ((JSEA3 .eq. 0).and.(JSEA4 .gt. 0)) THEN + SXX_X=(SXX(ISEA ) - SXX(JSEA4))/dist_Y + SXY_X=(SXY(ISEA ) - SXY(JSEA4))/dist_Y + SYY_X=(SXY(ISEA ) - SYY(JSEA4))/dist_Y + END IF + IF ((JSEA3 .gt. 0).and.(JSEA4 .gt. 0)) THEN + SXX_X=(SXX(JSEA3) - SXX(ISEA ))/dist_Y + SXY_X=(SXY(JSEA3) - SXY(ISEA ))/dist_Y + SYY_X=(SXY(JSEA3) - SYY(ISEA ))/dist_Y + END IF + eFX=-SXX_X - SXY_Y + eFY=-SYY_Y - SXY_X + FX(ISEA)=eFX + FY(ISEA)=eFY + END DO + END SUBROUTINE FD_COMPUTE_LH_STRESS + !/ ------------------------------------------------------------------- / + !> + !> @brief Differences on FD grids. + !> + !> @param[in] IEDGE + !> @param[in] ISEA + !> @param[inout] UGRAD + !> @param[inout] VGRAD + !> @param[inout] dist + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE FD_COMPUTE_DIFF(IEDGE, ISEA, UGRAD, VGRAD, dist) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : differences on FD grids + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY: MAPSF, EDGES + USE W3GDATMD, ONLY: XGRD, YGRD + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + INTEGER, intent(in) :: IEDGE, ISEA + REAL(8), intent(inout) :: UGRAD, VGRAD, dist + REAL(8) :: h + integer I2, I3, IP1, IP2, IP3 + integer IX1, IY1, IX2, IY2 + integer ISEA1, ISEA2 + REAL(8) deltaX, deltaY + ! + ISEA1=EDGES(IEDGE,1) + ISEA2=EDGES(IEDGE,2) + IX1=MAPSF(ISEA1,1) + IY1=MAPSF(ISEA1,2) + IX2=MAPSF(ISEA2,1) + IY2=MAPSF(ISEA2,2) + deltaX=XGRD(IX1,IY1) - XGRD(IX2,IY2) + deltaY=YGRD(IX1,IY1) - YGRD(IX2,IY2) + dist=SQRT(deltaX*deltaX + deltaY*deltaY) + IF (ISEA .eq. ISEA1) THEN + UGRAD= deltaX/dist + VGRAD= deltaY/dist + ELSE + UGRAD=-deltaX/dist + VGRAD=-deltaY/dist + END IF + END SUBROUTINE FD_COMPUTE_DIFF + !/ ------------------------------------------------------------------- / + !> + !> @brief Setup matrix on FD grids. + !> + !> @param[out] ASPAR + !> @param[out] B + !> @param[in] FX + !> @param[in] FY + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE FD_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, FX, FY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Setup matrix on FD grids + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE yowNodepool, only: PDLIB_NNZ + USE W3GDATMD, ONLY: NX, NY, NSEA, NBEDGE, EDGES + USE W3ADATMD, ONLY: DW + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + real(8), intent(in) :: FX(NSEA), FY(NSEA) + real(8), intent(out) :: ASPAR(PDLIB_NNZ) + real(8), intent(out) :: B(NX) + INTEGER :: POS_TRICK(3,2), POS_SHIFT(3,3) + integer I1, I2, I3, IP1, IP2, IP3 + integer IDX, IDX1, IDX2, IDX3 + INTEGER IE, IP, I, J, K, IPp, JPp + real(8) :: eDep, eFX, eFY, eScal, eFact, eLen + real(8) :: UGRAD, VGRAD, UGRAD1, VGRAD1, dist1, dist2 + INTEGER LIDX(2), KIDX(2), jdx + INTEGER ISEAREL, JSEAREL, ISEA, JSEA, IEDGE + ! + ASPAR=0 + B=0 + DO IEDGE=1,NBEDGE + ISEA=EDGES(IEDGE,1) + JSEA=EDGES(IEDGE,2) + eDep=(DW(ISEA) + DW(JSEA))/2.0 + eFX =(FX(ISEA) + FX(JSEA))/2.0 + eFY =(FY(ISEA) + FY(JSEA))/2.0 + DO I=1,2 + ISEAREL=EDGES(IEDGE,I) + CALL FD_COMPUTE_DIFF(IEDGE, ISEAREL, UGRAD1, VGRAD1, dist1) + eScal=UGRAD1*eFX + VGRAD1*eFY + B(ISEAREL) = B(ISEAREL) + eScal*dist1 ! - CALL FD_WAVE_SETUP_SCALAR_PROD(V_R, V_R, eNorm) - IF (eNorm .le. SOLVERTHR) THEN - EXIT - END IF - ! - CALL FD_WAVE_SETUP_APPLY_PRECOND(ASPAR, V_R, V_Z) - CALL FD_WAVE_SETUP_SCALAR_PROD(V_Z, V_R, uN) - ! - beta=uN/uO - uO=uN - ! - DO IP=1,NX - V_P(IP)=V_Z(IP) + beta * V_P(IP) + DO J=1,2 + JSEAREL=EDGES(IEDGE,J) + CALL FD_COMPUTE_DIFF(IEDGE, JSEAREL, UGRAD, VGRAD, dist2) + eScal=UGRAD*UGRAD1 + VGRAD*VGRAD1 + ASPAR(J)=ASPAR(J)+eFact*eScal END DO END DO - TheOut=V_X - END SUBROUTINE FD_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR -!/ ------------------------------------------------------------------- / -!> -!> @brief Set mean value. -!> -!> @param[inout] TheVar -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE FD_SET_MEANVALUE_TO_ZERO(TheVar) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : set meanvalue -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NX, SI - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - real(8), intent(inout) :: TheVar(NX) - real(8) :: SUM_SI_Var, SUM_SI, TheMean - INTEGER IP - SUM_SI_Var=0 - SUM_SI=0 + END DO + END SUBROUTINE FD_WAVE_SETUP_COMPUTE_SYSTEM + !/ ------------------------------------------------------------------- / + !> + !> @brief Scalar product. + !> + !> @param[in] V1 + !> @param[in] V2 + !> @param[inout] eScal + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE FD_WAVE_SETUP_SCALAR_PROD(V1, V2, eScal) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : scalar prod. + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY: NX + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + real(8), intent(in) :: V1(NX), V2(NX) + real(8), intent(inout) :: eScal + integer IP + eScal=0 + DO IP=1,NX + eScal=eScal + V1(IP)*V2(IP) + END DO + END SUBROUTINE FD_WAVE_SETUP_SCALAR_PROD + !/ ------------------------------------------------------------------- / + !> + !> @brief Poisson solver on FD grids. + !> + !> @param[in] ASPAR + !> @param[in] B + !> @param[out] TheOut + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE FD_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : possoin solver on fd grids + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE yowNodepool, only: PDLIB_NNZ + USE W3GDATMD, ONLY: NX + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + real(8), intent(in) :: ASPAR(PDLIB_NNZ) + real(8), intent(in) :: B(NX) + real(8), intent(out) :: TheOut(NX) + real(8) :: V_X(NX), V_R(NX), V_Z(NX), V_P(NX), V_Y(NX) + real(8) :: uO, uN, alphaV, h1, h2 + real(8) :: eNorm, beta + real(8) :: SOLVERTHR + integer IP, nbIter + SOLVERTHR=0.00000001 + nbIter=0 + V_X=0 + V_R=B + CALL FD_WAVE_SETUP_APPLY_PRECOND(ASPAR, V_R, V_Z) + V_P=V_Z + CALL FD_WAVE_SETUP_SCALAR_PROD(V_Z, V_R, uO) + DO + nbIter=nbIter + 1 + CALL FD_WAVE_SETUP_APPLY_FCT(ASPAR, V_P, V_Y) + CALL FD_WAVE_SETUP_SCALAR_PROD(V_P, V_Y, h2) + alphaV=uO/h2 + ! DO IP=1,NX - SUM_SI_Var = SUM_SI_Var + SI(IP)*TheVar(IP) - SUM_SI = SUM_SI + SI(IP) + V_X(IP) = V_X(IP) + alphaV * V_P(IP) + V_R(IP) = V_R(IP) - alphaV * V_Y(IP) END DO - TheMean=SUM_SI_Var/SUM_SI + ! + CALL FD_WAVE_SETUP_SCALAR_PROD(V_R, V_R, eNorm) + IF (eNorm .le. SOLVERTHR) THEN + EXIT + END IF + ! + CALL FD_WAVE_SETUP_APPLY_PRECOND(ASPAR, V_R, V_Z) + CALL FD_WAVE_SETUP_SCALAR_PROD(V_Z, V_R, uN) + ! + beta=uN/uO + uO=uN + ! DO IP=1,NX - TheVar(IP)=TheVar(IP) - TheMean + V_P(IP)=V_Z(IP) + beta * V_P(IP) END DO + END DO + TheOut=V_X + END SUBROUTINE FD_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR + !/ ------------------------------------------------------------------- / + !> + !> @brief Set mean value. + !> + !> @param[inout] TheVar + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE FD_SET_MEANVALUE_TO_ZERO(TheVar) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : set meanvalue + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY: NX, SI + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + real(8), intent(inout) :: TheVar(NX) + real(8) :: SUM_SI_Var, SUM_SI, TheMean + INTEGER IP + SUM_SI_Var=0 + SUM_SI=0 + DO IP=1,NX + SUM_SI_Var = SUM_SI_Var + SI(IP)*TheVar(IP) + SUM_SI = SUM_SI + SI(IP) + END DO + TheMean=SUM_SI_Var/SUM_SI + DO IP=1,NX + TheVar(IP)=TheVar(IP) - TheMean + END DO END SUBROUTINE FD_SET_MEANVALUE_TO_ZERO -!/ ------------------------------------------------------------------- / -!> -!> @brief Wave setup comp on FD grids. -!> -!> @param[inout] TheVar -!> -!> @author Mathieu Dutour-Sikiric -!> @author Aron Roland -!> @date 1-May-2018 -!> - SUBROUTINE FD_WAVE_SETUP_COMPUTATION -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : wave setup comp. on fd grids -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE yowNodepool, only: PDLIB_NNZ - USE W3GDATMD, ONLY: NX, NSEA, NSEAL - USE W3WDATMD, ONLY: ZETA_SETUP - use yowDatapool, only: rtype, istatus - USE W3ADATMD, ONLY: MPI_COMM_WCMP - USE W3ODATMD, only : IAPROC, NAPROC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! -! CALL W3SETG - REAL(8) :: ZETA_WORK(NSEA) - REAL(8) :: F_X(NSEA), F_Y(NSEA) - REAL(8) :: ASPAR(PDLIB_NNZ), B(NX) - INTEGER ISEA, IPROC - real(8) :: SXX_t(NSEA), SXY_t(NSEA), SYY_t(NSEA) - integer ierr - CALL FD_COLLECT_SXX_XY_YY(SXX_t, SXY_t, SYY_t) - IF (IAPROC .eq. 1) THEN - CALL FD_COMPUTE_LH_STRESS(SXX_t, SXY_t, SYY_t, F_X, F_Y) - DO ISEA=1,NSEA - ZETA_WORK(ISEA)=ZETA_SETUP(ISEA) - END DO - CALL FD_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, F_X, F_Y) - CALL FD_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, ZETA_WORK) - CALL FD_SET_MEANVALUE_TO_ZERO(ZETA_WORK) - DO IPROC=2,NAPROC - CALL MPI_SEND(ZETA_WORK,NSEA,rtype, IPROC-1, 23, MPI_COMM_WCMP, ierr) - END DO - ELSE - CALL MPI_RECV(ZETA_WORK,NSEAL,rtype, 0, 23, MPI_COMM_WCMP, istatus, ierr) - END IF + !/ ------------------------------------------------------------------- / + !> + !> @brief Wave setup comp on FD grids. + !> + !> @param[inout] TheVar + !> + !> @author Mathieu Dutour-Sikiric + !> @author Aron Roland + !> @date 1-May-2018 + !> + SUBROUTINE FD_WAVE_SETUP_COMPUTATION + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : wave setup comp. on fd grids + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE yowNodepool, only: PDLIB_NNZ + USE W3GDATMD, ONLY: NX, NSEA, NSEAL + USE W3WDATMD, ONLY: ZETA_SETUP + use yowDatapool, only: rtype, istatus + USE W3ADATMD, ONLY: MPI_COMM_WCMP + USE W3ODATMD, only : IAPROC, NAPROC + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + ! CALL W3SETG + REAL(8) :: ZETA_WORK(NSEA) + REAL(8) :: F_X(NSEA), F_Y(NSEA) + REAL(8) :: ASPAR(PDLIB_NNZ), B(NX) + INTEGER ISEA, IPROC + real(8) :: SXX_t(NSEA), SXY_t(NSEA), SYY_t(NSEA) + integer ierr + CALL FD_COLLECT_SXX_XY_YY(SXX_t, SXY_t, SYY_t) + IF (IAPROC .eq. 1) THEN + CALL FD_COMPUTE_LH_STRESS(SXX_t, SXY_t, SYY_t, F_X, F_Y) DO ISEA=1,NSEA - ZETA_SETUP(ISEA)=ZETA_WORK(ISEA) + ZETA_WORK(ISEA)=ZETA_SETUP(ISEA) END DO + CALL FD_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, F_X, F_Y) + CALL FD_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, ZETA_WORK) + CALL FD_SET_MEANVALUE_TO_ZERO(ZETA_WORK) + DO IPROC=2,NAPROC + CALL MPI_SEND(ZETA_WORK,NSEA,rtype, IPROC-1, 23, MPI_COMM_WCMP, ierr) + END DO + ELSE + CALL MPI_RECV(ZETA_WORK,NSEAL,rtype, 0, 23, MPI_COMM_WCMP, istatus, ierr) + END IF + DO ISEA=1,NSEA + ZETA_SETUP(ISEA)=ZETA_WORK(ISEA) + END DO END SUBROUTINE FD_WAVE_SETUP_COMPUTATION -!/ ------------------------------------------------------------------- / -!> -!> @brief General driver. -!> -!> @author Aron Roland -!> @author Mathieu Dutour-Sikiric -!> @date 1-May-2018 -!> - SUBROUTINE WAVE_SETUP_COMPUTATION -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mai-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mai-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : general driver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NSEA, NSEAL - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE W3ODATMD, only : IAPROC, NAPROC, NTPROC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETERs -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'VA_SETUP_IOBPD') -#endif -! - INTEGER ISEA, JSEA - REAL*8, allocatable :: ZETA_WORK(:) + !/ ------------------------------------------------------------------- / + !> + !> @brief General driver. + !> + !> @author Aron Roland + !> @author Mathieu Dutour-Sikiric + !> @date 1-May-2018 + !> + SUBROUTINE WAVE_SETUP_COMPUTATION + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mai-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mai-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : general driver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY: NSEA, NSEAL + USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE W3ODATMD, only : IAPROC, NAPROC, NTPROC + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETERs + !/ +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif + ! + INTEGER ISEA, JSEA + REAL*8, allocatable :: ZETA_WORK(:) #ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'NAPROC=', NAPROC - WRITE(740+IAPROC,*) 'NTPROC=', NTPROC - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC + WRITE(740+IAPROC,*) 'NTPROC=', NTPROC + FLUSH(740+IAPROC) #endif - IF (IAPROC .le. NAPROC) THEN + IF (IAPROC .le. NAPROC) THEN #ifdef W3_DEBUGSTP WRITE(740+IAPROC,*) 'Begin WAVE_SETUP_COMPUTATION' FLUSH(740+IAPROC) #endif - IF (DO_WAVE_SETUP) THEN - IF (GTYPE .EQ. UNGTYPE) THEN - CALL TRIG_WAVE_SETUP_COMPUTATION - ELSE - CALL FD_WAVE_SETUP_COMPUTATION - END IF + IF (DO_WAVE_SETUP) THEN + IF (GTYPE .EQ. UNGTYPE) THEN + CALL TRIG_WAVE_SETUP_COMPUTATION + ELSE + CALL FD_WAVE_SETUP_COMPUTATION END IF END IF + END IF #ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'Begin WAVE_SETUP_COMPUTATION' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Begin WAVE_SETUP_COMPUTATION' + FLUSH(740+IAPROC) #endif END SUBROUTINE WAVE_SETUP_COMPUTATION -!/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / END MODULE W3WAVSET !/ ------------------------------------------------------------------- / diff --git a/model/src/w3wdasmd.F90 b/model/src/w3wdasmd.F90 index 78762f014..4acf37c79 100644 --- a/model/src/w3wdasmd.F90 +++ b/model/src/w3wdasmd.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains module W3WDASMD. -!> +!> !> @author H. L. Tolman @date 06-Dec-2010 !> @@ -9,9 +9,9 @@ !> !> @brief Intended as the interface for externally supplied !> data assimilation software. -!> -!> @details This module is intended as the interface for externally -!> supplied data assimilation software to be used with WAVEWATCH III. +!> +!> @details This module is intended as the interface for externally +!> supplied data assimilation software to be used with WAVEWATCH III. !> The main subroutine W3WDAS is incorporated in the generic WAVEWATCH !> III shell ww3_shel, and thus provides integrated time management !> and running of the wave model and data assimilation side by side. @@ -22,7 +22,7 @@ !> !> A three tier data structure is used with three separate data !> sets. Tentatively, they are intended for mean wave parameters, -!> 1-D and 2-D spectral data. This separation is made only for +!> 1-D and 2-D spectral data. This separation is made only for !> economy in file and memory usage. All three data sets are defined !> here only by a record length and a number of records. All data are !> treated as real numbers, but the meaning of all record components @@ -34,285 +34,285 @@ !> !> @author H. L. Tolman @date 06-Dec-2010 !> - MODULE W3WDASMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Dec-2010 | -!/ +-----------------------------------+ -!/ -!/ 25-Jan-2002 : Origination. ( version 2.17 ) -!/ 27-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! This module is intended as the interface for externally supplied -! data assimlation software to be used with WAVEWATCH III. The -! main subroutine W3WDAS is incorporated in the generic WAVEWATCH -! III shell ww3_shel, and thus provides integrated time management -! and running of the wave model and data assimilation side by side. -! -! Present wave conditions (including dynamically changing wave -! grids), as well as wave data are passed to the routine through -! the dynamic data structrure, as introduced in model version 3.06 -! -! A three tier data structure is used with three separate data -! sets. Tentatively, they are intended for mean wave parameters, -! 1-D and 2-D spectral data. This separation is made only for -! economy in file and menory usage. All three data sets are defined -! here onlt by a record length and a number of records. All data are -! treated as real numbers, but the meaing of all record components -! is completely at the discretion of the author of the data -! assimilation scheme. -! -! To promote portability, it is suggested to use this module only -! as an interface to your own assimilation routine(s). -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3WDAS Subr. Public Actual wave model. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! .... Subr. W3SERVMD Service routines. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - This module still requires an OpenMP or MPI setup to be made -! compatible with WAVEWATCH III inside the user supplied -! routines. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief WAVEWATCH III data assimilation interface routine. -!> -!> @param[in] DASFLAG FLags for three data sets. -!> @param[in] RECL Record lengths for three data sets. -!> @param[in] NDAT Number of data for three data sets. -!> @param[in] DATA0 Observations. -!> @param[in] DATA1 Observations. -!> @param[in] DATA2 Observations. -!> -!> @author H. L. Tolman @date 06-Dec-2010 -!> - SUBROUTINE W3WDAS ( DASFLAG, RECL, NDAT, DATA0, DATA1, DATA2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Dec-2010 | -!/ +-----------------------------------+ -!/ -!/ 25-Jan-2002 : Origination. ( version 2.17 ) -!/ 27-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! WAVEWATCH III data assimilation interface routine. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! DASFLAG L.A. I FLags for three data sets. -! RECLD I.A. I Record lengths for three data sets. -! ND I.A. I Number of data for three data sets. -! DATAn R.A. I Observations. -! ---------------------------------------------------------------- -! -! Local parameters : -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any program shell or integrated model after initialization of -! WAVEWATCH III (to assure availability of data in used modules). -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD - USE W3WDATMD - USE W3ADATMD - USE W3ODATMD, ONLY: NDSO, NDSE, NDST, SCREEN, NAPROC, IAPROC, & - NAPLOG, NAPOUT, NAPERR +MODULE W3WDASMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Dec-2010 | + !/ +-----------------------------------+ + !/ + !/ 25-Jan-2002 : Origination. ( version 2.17 ) + !/ 27-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! This module is intended as the interface for externally supplied + ! data assimlation software to be used with WAVEWATCH III. The + ! main subroutine W3WDAS is incorporated in the generic WAVEWATCH + ! III shell ww3_shel, and thus provides integrated time management + ! and running of the wave model and data assimilation side by side. + ! + ! Present wave conditions (including dynamically changing wave + ! grids), as well as wave data are passed to the routine through + ! the dynamic data structrure, as introduced in model version 3.06 + ! + ! A three tier data structure is used with three separate data + ! sets. Tentatively, they are intended for mean wave parameters, + ! 1-D and 2-D spectral data. This separation is made only for + ! economy in file and menory usage. All three data sets are defined + ! here onlt by a record length and a number of records. All data are + ! treated as real numbers, but the meaing of all record components + ! is completely at the discretion of the author of the data + ! assimilation scheme. + ! + ! To promote portability, it is suggested to use this module only + ! as an interface to your own assimilation routine(s). + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3WDAS Subr. Public Actual wave model. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! .... Subr. W3SERVMD Service routines. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - This module still requires an OpenMP or MPI setup to be made + ! compatible with WAVEWATCH III inside the user supplied + ! routines. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief WAVEWATCH III data assimilation interface routine. + !> + !> @param[in] DASFLAG FLags for three data sets. + !> @param[in] RECL Record lengths for three data sets. + !> @param[in] NDAT Number of data for three data sets. + !> @param[in] DATA0 Observations. + !> @param[in] DATA1 Observations. + !> @param[in] DATA2 Observations. + !> + !> @author H. L. Tolman @date 06-Dec-2010 + !> + SUBROUTINE W3WDAS ( DASFLAG, RECL, NDAT, DATA0, DATA1, DATA2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Dec-2010 | + !/ +-----------------------------------+ + !/ + !/ 25-Jan-2002 : Origination. ( version 2.17 ) + !/ 27-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ + ! 1. Purpose : + ! + ! WAVEWATCH III data assimilation interface routine. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! DASFLAG L.A. I FLags for three data sets. + ! RECLD I.A. I Record lengths for three data sets. + ! ND I.A. I Number of data for three data sets. + ! DATAn R.A. I Observations. + ! ---------------------------------------------------------------- + ! + ! Local parameters : + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any program shell or integrated model after initialization of + ! WAVEWATCH III (to assure availability of data in used modules). + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD + USE W3WDATMD + USE W3ADATMD + USE W3ODATMD, ONLY: NDSO, NDSE, NDST, SCREEN, NAPROC, IAPROC, & + NAPLOG, NAPOUT, NAPERR #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: RECL(3), NDAT(3) - REAL, INTENT(IN) :: DATA0(RECL(1),NDAT(1)) - REAL, INTENT(IN) :: DATA1(RECL(2),NDAT(2)) - REAL, INTENT(IN) :: DATA2(RECL(3),NDAT(3)) - LOGICAL, INTENT(IN) :: DASFLAG(3) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters : -!/ - INTEGER :: J + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: RECL(3), NDAT(3) + REAL, INTENT(IN) :: DATA0(RECL(1),NDAT(1)) + REAL, INTENT(IN) :: DATA1(RECL(2),NDAT(2)) + REAL, INTENT(IN) :: DATA2(RECL(3),NDAT(3)) + LOGICAL, INTENT(IN) :: DASFLAG(3) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters : + !/ + INTEGER :: J #ifdef W3_T - INTEGER :: MREC, MDAT, IREC, IDAT + INTEGER :: MREC, MDAT, IREC, IDAT #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T - REAL, ALLOCATABLE :: TDATA(:,:) + REAL, ALLOCATABLE :: TDATA(:,:) #endif -!/ -!/ ------------------------------------------------------------------- / -! 1. Initializations and test output -! 1.a Subroutine tracing -! + !/ + !/ ------------------------------------------------------------------- / + ! 1. Initializations and test output + ! 1.a Subroutine tracing + ! #ifdef W3_S - CALL STRACE (IENT, 'W3WDAS') + CALL STRACE (IENT, 'W3WDAS') #endif -! -! 1.b Echo part of parameter list (test output only). -! + ! + ! 1.b Echo part of parameter list (test output only). + ! #ifdef W3_T - WRITE (NDST,9000) NDSO, NDSE, NDST, SCREEN, NAPROC, IAPROC, & - NAPOUT, NAPERR, TIME - DO J=1, 3 - IF ( DASFLAG(J) ) THEN - WRITE (NDST,9001) J, DASFLAG(J), RECL(J), NDAT(J) - MREC = MIN(RECL(J),6) - MDAT = MIN(NDAT(J),10) - IF ( ALLOCATED(TDATA) ) DEALLOCATE (TDATA) - ALLOCATE ( TDATA(RECL(J),MDAT) ) - IF ( J .EQ. 1 ) TDATA = DATA0(:,1:MDAT) - IF ( J .EQ. 2 ) TDATA = DATA1(:,1:MDAT) - IF ( J .EQ. 3 ) TDATA = DATA2(:,1:MDAT) - DO IDAT=1, MDAT - WRITE (NDST,9002) IDAT, TDATA(1:MREC,IDAT) - IF ( MREC .LT. RECL(J) ) WRITE (NDST,9003) & - TDATA(MREC+1:RECL(J),IDAT) - END DO - ELSE - WRITE (NDST,9001) J, DASFLAG(J) - END IF + WRITE (NDST,9000) NDSO, NDSE, NDST, SCREEN, NAPROC, IAPROC, & + NAPOUT, NAPERR, TIME + DO J=1, 3 + IF ( DASFLAG(J) ) THEN + WRITE (NDST,9001) J, DASFLAG(J), RECL(J), NDAT(J) + MREC = MIN(RECL(J),6) + MDAT = MIN(NDAT(J),10) + IF ( ALLOCATED(TDATA) ) DEALLOCATE (TDATA) + ALLOCATE ( TDATA(RECL(J),MDAT) ) + IF ( J .EQ. 1 ) TDATA = DATA0(:,1:MDAT) + IF ( J .EQ. 2 ) TDATA = DATA1(:,1:MDAT) + IF ( J .EQ. 3 ) TDATA = DATA2(:,1:MDAT) + DO IDAT=1, MDAT + WRITE (NDST,9002) IDAT, TDATA(1:MREC,IDAT) + IF ( MREC .LT. RECL(J) ) WRITE (NDST,9003) & + TDATA(MREC+1:RECL(J),IDAT) END DO - IF ( ALLOCATED(TDATA) ) DEALLOCATE (TDATA) + ELSE + WRITE (NDST,9001) J, DASFLAG(J) + END IF + END DO + IF ( ALLOCATED(TDATA) ) DEALLOCATE (TDATA) #endif -! -! 1.c Test grid info from W3GDATMD -! + ! + ! 1.c Test grid info from W3GDATMD + ! #ifdef W3_T - WRITE (NDST,9010) NX, NY, NSEA, NSEAL, NK, NTH, & - ICLOSE, FLAGLL, SX, SY, X0, Y0 + WRITE (NDST,9010) NX, NY, NSEA, NSEAL, NK, NTH, & + ICLOSE, FLAGLL, SX, SY, X0, Y0 #endif -! -! 2. Actual data assimilation routine ------------------------------- / -! -! User-defined data assimilation routines to be plugged in here. -! All that could be needed is avainalble in this subroutine, -! including the grid definition from W3GDATMD. All -! can thus be included in the parameter list, and no explcit links -! to other WAVEWATCH III routines will be needed within the -! data assimilation routines ( with the possible exception of the -! CONSTANTS module ), If there is a reason to terminate the code, -! pass an error code out of the routine and use EXTCDE to stop -! the WAVEWATCH III run altogether. Check the system documentation -! on how to ad your routines to the compile and link system. -! -! CALL ..... -! -! IF ( ..... ) CALL EXTCDE ( 99 ) -! - RETURN -! -! Formats -! -!1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3WDAS :'/ & -! ' ILLIGAL GRID SIZES INPUT : ',4I8/ & -! ' GRID : ',4I8/) + ! + ! 2. Actual data assimilation routine ------------------------------- / + ! + ! User-defined data assimilation routines to be plugged in here. + ! All that could be needed is avainalble in this subroutine, + ! including the grid definition from W3GDATMD. All + ! can thus be included in the parameter list, and no explcit links + ! to other WAVEWATCH III routines will be needed within the + ! data assimilation routines ( with the possible exception of the + ! CONSTANTS module ), If there is a reason to terminate the code, + ! pass an error code out of the routine and use EXTCDE to stop + ! the WAVEWATCH III run altogether. Check the system documentation + ! on how to ad your routines to the compile and link system. + ! + ! CALL ..... + ! + ! IF ( ..... ) CALL EXTCDE ( 99 ) + ! + RETURN + ! + ! Formats + ! + !1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3WDAS :'/ & + ! ' ILLIGAL GRID SIZES INPUT : ',4I8/ & + ! ' GRID : ',4I8/) #ifdef W3_T - 9000 FORMAT ( ' TEST W3WDAS : UNIT NUMBERS : ',4I4/ & - ' MPI SETTINGS : ',4I4/ & - ' TIME : ',I8.8,I7.6) - 9001 FORMAT ( ' DATASET INFO : ',I1,L2,2I8) - 9002 FORMAT (17X,I2,6E10.3) - 9003 FORMAT (19X, 6E10.3) +9000 FORMAT ( ' TEST W3WDAS : UNIT NUMBERS : ',4I4/ & + ' MPI SETTINGS : ',4I4/ & + ' TIME : ',I8.8,I7.6) +9001 FORMAT ( ' DATASET INFO : ',I1,L2,2I8) +9002 FORMAT (17X,I2,6E10.3) +9003 FORMAT (19X, 6E10.3) #endif -! + ! #ifdef W3_T - 9010 FORMAT ( ' TEST W3WDAS : ARRAY DIMS. : ',6I8/ & - ' GRID : ',1I2,1L2,4E11.4) +9010 FORMAT ( ' TEST W3WDAS : ARRAY DIMS. : ',6I8/ & + ' GRID : ',1I2,1L2,4E11.4) #endif -!/ -!/ End of W3WDAS ----------------------------------------------------- / -!/ - END SUBROUTINE W3WDAS -!/ -!/ End of module W3WDASMD -------------------------------------------- / -!/ - END MODULE W3WDASMD + !/ + !/ End of W3WDAS ----------------------------------------------------- / + !/ + END SUBROUTINE W3WDAS + !/ + !/ End of module W3WDASMD -------------------------------------------- / + !/ +END MODULE W3WDASMD diff --git a/model/src/w3wdatmd.F90 b/model/src/w3wdatmd.F90 index d2b824167..848f3858f 100644 --- a/model/src/w3wdatmd.F90 +++ b/model/src/w3wdatmd.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains module W3WDATMD. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 !> @@ -9,828 +9,828 @@ !> !> @brief Define data structures to set up wave model dynamic data for !> several models simultaneously. -!> +!> !> @details The number of grids is taken from W3GDATMD, and needs to be !> set first with W3DIMG. !> !> @author H. L. Tolman @date 22-Mar-2021 !> - MODULE W3WDATMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 22-Oct-2004 : Origination. ( version 3.06 ) -!/ 13-Jun-2006 : Allocate VA consistent with MPI ( version 3.09 ) -!/ data types and initialize as needed. -!/ 05-Jul-2006 : Consolidate stress vector. ( version 3.09 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 16-May-2010 : Add iceberg damping ( version 3.14.4 ) -!/ 14-Nov-2013 : Initialize UST and USTDIR. ( version 4.13 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 06-Jun-2018 : Add PDLIB/SETUP/DEBUGINIT ( version 6.04 ) -!/ 22-Mar-2021 : Support for variable air density ( version 7.13 ) -!/ 28-Jun-2021 : GKE NL5 parameters (Q. Liu) ( version 7.13 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Define data structures to set up wave model dynamic data for -! several models simultaneously. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NWDATA Int. Public Number of models in array dim. -! IWDATA Int. Public Selected model for output, init. at -1. -! WDATA TYPE Public Basic data structure. -! WDATAS WDATA Public Array of data structures. -! ---------------------------------------------------------------- -! -! All elements of WDATA are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! TIME I.A. Public Valid time for spectra. -! TIME00 I.A. Public Initial time -! TIMEEND I.A. Public Final time -! QI5TBEG I.A. Public Initial time for NL5 (absol. time) -! QR5TIM0 R.A. Public Previous time step t0 (relat. time) -! QR5CVK0 R.A. Public Cvk @ t0 -! QC5INT0 C.A. Public Inpqr (time integral) @ t0 -! QR5TMIX R.A. Public Previous time for phase mixing -! TLEV I.A. Public Valid time for water levels. -! TICE I.A. Public Valid time for ice concentration -! TRHO I.A. Public Valid time for air density -! TIC1 I.A. Public Valid time for ice thickness -! TIC5 I.A. Public Valid time for ice floe -! VA R.A. Public Storage array for spectra. -! WLV R.A. Public Water levels. -! ICE R.A. Public Ice coverage. -! RHOAIR R.A. Public Air density -! ICEH R.A. Public Ice thickness. -! ICEF R.A. Public Ice flow maximum diameter. -! ICEDMAX R.A. Public Ice flow maximum diameter for updates. -! BERG R.A. Public Iceberg damping. -! UST R.A. Public Friction velocity (absolute). -! USTDIR R.A. Public Friction velocity direction. -! ASF R.A. Public Stability correction factor. -! FPIS R.A. Public Input peak frequencies. -! DINIT Log. Public Flag for array initialization. -! FL_ALL Log. Public Flag for initializing all arrays, -! otherwise VA is skipped. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3NDAT Subr. Public Set number of grids/models. -! W3DIMW Subr. Public Set dimensions of arrays. -! W3SETW Subr. Public Point to selected grid / model. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to proper model grid. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - The number of grids is taken from W3GDATMD, and needs to be -! set first with W3DIMG. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Module private variable for checking error returns -!/ - INTEGER, PRIVATE :: ISTAT -!/ -!/ Conventional declarations -!/ - INTEGER :: NWDATA = -1, IWDATA = -1 -!/ -!/ Data structures -!/ - TYPE WDATA - INTEGER :: TIME(2), TLEV(2), TICE(2), TRHO(2), & - TIC1(2), TIC5(2) +MODULE W3WDATMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 22-Oct-2004 : Origination. ( version 3.06 ) + !/ 13-Jun-2006 : Allocate VA consistent with MPI ( version 3.09 ) + !/ data types and initialize as needed. + !/ 05-Jul-2006 : Consolidate stress vector. ( version 3.09 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 16-May-2010 : Add iceberg damping ( version 3.14.4 ) + !/ 14-Nov-2013 : Initialize UST and USTDIR. ( version 4.13 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 06-Jun-2018 : Add PDLIB/SETUP/DEBUGINIT ( version 6.04 ) + !/ 22-Mar-2021 : Support for variable air density ( version 7.13 ) + !/ 28-Jun-2021 : GKE NL5 parameters (Q. Liu) ( version 7.13 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Define data structures to set up wave model dynamic data for + ! several models simultaneously. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NWDATA Int. Public Number of models in array dim. + ! IWDATA Int. Public Selected model for output, init. at -1. + ! WDATA TYPE Public Basic data structure. + ! WDATAS WDATA Public Array of data structures. + ! ---------------------------------------------------------------- + ! + ! All elements of WDATA are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! TIME I.A. Public Valid time for spectra. + ! TIME00 I.A. Public Initial time + ! TIMEEND I.A. Public Final time + ! QI5TBEG I.A. Public Initial time for NL5 (absol. time) + ! QR5TIM0 R.A. Public Previous time step t0 (relat. time) + ! QR5CVK0 R.A. Public Cvk @ t0 + ! QC5INT0 C.A. Public Inpqr (time integral) @ t0 + ! QR5TMIX R.A. Public Previous time for phase mixing + ! TLEV I.A. Public Valid time for water levels. + ! TICE I.A. Public Valid time for ice concentration + ! TRHO I.A. Public Valid time for air density + ! TIC1 I.A. Public Valid time for ice thickness + ! TIC5 I.A. Public Valid time for ice floe + ! VA R.A. Public Storage array for spectra. + ! WLV R.A. Public Water levels. + ! ICE R.A. Public Ice coverage. + ! RHOAIR R.A. Public Air density + ! ICEH R.A. Public Ice thickness. + ! ICEF R.A. Public Ice flow maximum diameter. + ! ICEDMAX R.A. Public Ice flow maximum diameter for updates. + ! BERG R.A. Public Iceberg damping. + ! UST R.A. Public Friction velocity (absolute). + ! USTDIR R.A. Public Friction velocity direction. + ! ASF R.A. Public Stability correction factor. + ! FPIS R.A. Public Input peak frequencies. + ! DINIT Log. Public Flag for array initialization. + ! FL_ALL Log. Public Flag for initializing all arrays, + ! otherwise VA is skipped. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3NDAT Subr. Public Set number of grids/models. + ! W3DIMW Subr. Public Set dimensions of arrays. + ! W3SETW Subr. Public Point to selected grid / model. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to proper model grid. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - The number of grids is taken from W3GDATMD, and needs to be + ! set first with W3DIMG. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + !/ Module private variable for checking error returns + !/ + INTEGER, PRIVATE :: ISTAT + !/ + !/ Conventional declarations + !/ + INTEGER :: NWDATA = -1, IWDATA = -1 + !/ + !/ Data structures + !/ + TYPE WDATA + INTEGER :: TIME(2), TLEV(2), TICE(2), TRHO(2), & + TIC1(2), TIC5(2) #ifdef W3_OASIS - INTEGER :: TIME00(2) - INTEGER :: TIMEEND(2) + INTEGER :: TIME00(2) + INTEGER :: TIMEEND(2) #endif #ifdef W3_NL5 - INTEGER :: QI5TBEG(2) - REAL, POINTER :: QR5TIM0(:), QR5CVK0(:, :), QR5TMIX(:) - COMPLEX, POINTER :: QC5INT0(:, :) + INTEGER :: QI5TBEG(2) + REAL, POINTER :: QR5TIM0(:), QR5CVK0(:, :), QR5TMIX(:) + COMPLEX, POINTER :: QC5INT0(:, :) #endif - REAL, POINTER :: VA(:,:), WLV(:), ICE(:), RHOAIR(:), & - UST(:), USTDIR(:), ASF(:), FPIS(:), & - BERG(:), ICEH(:), ICEF(:), ICEDMAX(:) + REAL, POINTER :: VA(:,:), WLV(:), ICE(:), RHOAIR(:), & + UST(:), USTDIR(:), ASF(:), FPIS(:), & + BERG(:), ICEH(:), ICEF(:), ICEDMAX(:) #ifdef W3_SETUP - REAL, POINTER :: ZETA_SETUP(:), FX_zs(:), FY_zs(:) - REAL, POINTER :: SXX_zs(:), SXY_zs(:), SYY_zs(:) + REAL, POINTER :: ZETA_SETUP(:), FX_zs(:), FY_zs(:) + REAL, POINTER :: SXX_zs(:), SXY_zs(:), SYY_zs(:) #endif #ifdef W3_PDLIB - REAL, POINTER :: VSTOT(:,:), VDTOT(:,:) - REAL, POINTER :: VAOLD(:,:) - LOGICAL, POINTER :: SHAVETOT(:) -#endif - LOGICAL :: DINIT, FL_ALL - END TYPE WDATA -! -!/ -!/ Data storage -!/ - TYPE(WDATA), TARGET, ALLOCATABLE :: WDATAS(:) -!/ -!/ Data aliasses for structure WDATA(S) -!/ - INTEGER, POINTER :: TIME(:), TLEV(:), TICE(:), TRHO(:), & - TIC1(:), TIC5(:) + REAL, POINTER :: VSTOT(:,:), VDTOT(:,:) + REAL, POINTER :: VAOLD(:,:) + LOGICAL, POINTER :: SHAVETOT(:) +#endif + LOGICAL :: DINIT, FL_ALL + END TYPE WDATA + ! + !/ + !/ Data storage + !/ + TYPE(WDATA), TARGET, ALLOCATABLE :: WDATAS(:) + !/ + !/ Data aliasses for structure WDATA(S) + !/ + INTEGER, POINTER :: TIME(:), TLEV(:), TICE(:), TRHO(:), & + TIC1(:), TIC5(:) #ifdef W3_OASIS - INTEGER, POINTER :: TIME00(:) - INTEGER, POINTER :: TIMEEND(:) + INTEGER, POINTER :: TIME00(:) + INTEGER, POINTER :: TIMEEND(:) #endif #ifdef W3_NL5 - INTEGER, POINTER :: QI5TBEG(:) - REAL, POINTER :: QR5TIM0(:), QR5CVK0(:, :), QR5TMIX(:) - COMPLEX, POINTER :: QC5INT0(:, :) + INTEGER, POINTER :: QI5TBEG(:) + REAL, POINTER :: QR5TIM0(:), QR5CVK0(:, :), QR5TMIX(:) + COMPLEX, POINTER :: QC5INT0(:, :) #endif - REAL, POINTER :: VA(:,:), WLV(:), ICE(:), RHOAIR(:), & - UST(:), USTDIR(:), ASF(:), FPIS(:), & - BERG(:), ICEH(:), ICEF(:), ICEDMAX(:) + REAL, POINTER :: VA(:,:), WLV(:), ICE(:), RHOAIR(:), & + UST(:), USTDIR(:), ASF(:), FPIS(:), & + BERG(:), ICEH(:), ICEF(:), ICEDMAX(:) #ifdef W3_SETUP - REAL, POINTER :: ZETA_SETUP(:), FX_zs(:), FY_zs(:) - REAL, POINTER :: SXX_zs(:), SXY_zs(:), SYY_zs(:) + REAL, POINTER :: ZETA_SETUP(:), FX_zs(:), FY_zs(:) + REAL, POINTER :: SXX_zs(:), SXY_zs(:), SYY_zs(:) #endif #ifdef W3_PDLIB - REAL, POINTER :: VSTOT(:,:), VDTOT(:,:) - REAL, POINTER :: VAOLD(:,:) - LOGICAL, POINTER :: SHAVETOT(:) -#endif - LOGICAL, POINTER :: DINIT, FL_ALL -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Set up the number of grids to be used. -!> -!> @details Use data stored in NGRIDS in W3GDATMD. -!> -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author H. L. Tolman @date 10-Dec-2014 -!> - SUBROUTINE W3NDAT ( NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 31-Mar-2004 : Origination. ( version 3.06 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Set up the number of grids to be used. -! -! 2. Method : -! -! Use data stored in NGRIDS in W3GDATMD. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program that uses this grid structure. -! -! 6. Error messages : -! -! - Error checks on previous setting of variable NGRIDS. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS - USE W3SERVMD, ONLY: EXTCDE + REAL, POINTER :: VSTOT(:,:), VDTOT(:,:) + REAL, POINTER :: VAOLD(:,:) + LOGICAL, POINTER :: SHAVETOT(:) +#endif + LOGICAL, POINTER :: DINIT, FL_ALL + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Set up the number of grids to be used. + !> + !> @details Use data stored in NGRIDS in W3GDATMD. + !> + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author H. L. Tolman @date 10-Dec-2014 + !> + SUBROUTINE W3NDAT ( NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 31-Mar-2004 : Origination. ( version 3.06 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Set up the number of grids to be used. + ! + ! 2. Method : + ! + ! Use data stored in NGRIDS in W3GDATMD. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program that uses this grid structure. + ! + ! 6. Error messages : + ! + ! - Error checks on previous setting of variable NGRIDS. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3NDAT') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) NGRIDS - CALL EXTCDE (1) - END IF -! -! -------------------------------------------------------------------- / -! 2. Set variable and allocate arrays -! - ALLOCATE ( WDATAS(0:NGRIDS), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - NWDATA = NGRIDS -! -! -------------------------------------------------------------------- / -! 3. Initialize parameters -! - DO I=0, NGRIDS - WDATAS(I)%DINIT = .FALSE. - WDATAS(I)%FL_ALL = .FALSE. - END DO -! + CALL STRACE (IENT, 'W3NDAT') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) NGRIDS + CALL EXTCDE (1) + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Set variable and allocate arrays + ! + ALLOCATE ( WDATAS(0:NGRIDS), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + NWDATA = NGRIDS + ! + ! -------------------------------------------------------------------- / + ! 3. Initialize parameters + ! + DO I=0, NGRIDS + WDATAS(I)%DINIT = .FALSE. + WDATAS(I)%FL_ALL = .FALSE. + END DO + ! #ifdef W3_T - WRITE (NDST,9000) NGRIDS -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3NDAT : NGRIDS NOT YET SET *** '/ & - ' NGRIDS = ',I10/ & - ' RUN W3NMOD FIRST'/) -! + WRITE (NDST,9000) NGRIDS +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3NDAT : NGRIDS NOT YET SET *** '/ & + ' NGRIDS = ',I10/ & + ' RUN W3NMOD FIRST'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3NDAT : SETTING UP FOR ',I4,' GRIDS') -#endif -!/ -!/ End of W3NDAT ----------------------------------------------------- / -!/ - END SUBROUTINE W3NDAT -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize an individual data grid at the proper dimensions. -!> -!> @details Allocate directly into the structure array. Note that -!> this cannot be done through the pointer alias! -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> @param[in] F_ONLY FLag for initializing field arrays only. -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 22-Oct-2004 : Origination. ( version 3.06 ) -!/ 13-Jun-2006 : Allocate VA consistent with MPI ( version 3.09 ) -!/ data types and initialize as needed. -!/ 05-Jul-2006 : Consolidate stress vector. ( version 3.09 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 14-Nov-2013 : Initialize UST and USTDIR. ( version 4.13 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 22-Mar-2021 : Support for variable air density ( version 7.13 ) -!/ -! 1. Purpose : -! -! Initialize an individual data grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! F_ONLY L.O. I FLag for initializing field arrays only. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGO Subr. W3IOGOMD Grid output IO routine. -! W3IORS Subr. W3IORSMD Restart file IO routine. -! WW3_SHEL Prog. N/A Main wave model driver. -! WW3_STRT Prog. N/A Initial conditions program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - W3SETW needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG, NSPEC, NSEA, NSEAL, GRIDS - USE W3ODATMD, ONLY: NAPROC, IAPROC - USE W3SERVMD, ONLY: EXTCDE - USE CONSTANTS, ONLY : LPDLIB, DAIR - USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM, LSLOC +9000 FORMAT (' TEST W3NDAT : SETTING UP FOR ',I4,' GRIDS') +#endif + !/ + !/ End of W3NDAT ----------------------------------------------------- / + !/ + END SUBROUTINE W3NDAT + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize an individual data grid at the proper dimensions. + !> + !> @details Allocate directly into the structure array. Note that + !> this cannot be done through the pointer alias! + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> @param[in] F_ONLY FLag for initializing field arrays only. + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 22-Oct-2004 : Origination. ( version 3.06 ) + !/ 13-Jun-2006 : Allocate VA consistent with MPI ( version 3.09 ) + !/ data types and initialize as needed. + !/ 05-Jul-2006 : Consolidate stress vector. ( version 3.09 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 14-Nov-2013 : Initialize UST and USTDIR. ( version 4.13 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 22-Mar-2021 : Support for variable air density ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! F_ONLY L.O. I FLag for initializing field arrays only. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGO Subr. W3IOGOMD Grid output IO routine. + ! W3IORS Subr. W3IORSMD Restart file IO routine. + ! WW3_SHEL Prog. N/A Main wave model driver. + ! WW3_STRT Prog. N/A Initial conditions program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - W3SETW needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG, NSPEC, NSEA, NSEAL, GRIDS + USE W3ODATMD, ONLY: NAPROC, IAPROC + USE W3SERVMD, ONLY: EXTCDE + USE CONSTANTS, ONLY : LPDLIB, DAIR + USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM, LSLOC #ifdef W3_NL5 - USE W3GDATMD, ONLY: QI5NNZ + USE W3GDATMD, ONLY: QI5NNZ #endif #ifdef W3_PDLIB - use yowNodepool, only: npa, np - use yowRankModule, only : rank - USE W3GDATMD, ONLY: GTYPE, UNGTYPE + use yowNodepool, only: npa, np + use yowRankModule, only : rank + USE W3GDATMD, ONLY: GTYPE, UNGTYPE #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST - LOGICAL, INTENT(IN), OPTIONAL :: F_ONLY -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID, NSEALM, NSEATM - INTEGER :: NSEAL_DUMMY, ISEA + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + LOGICAL, INTENT(IN), OPTIONAL :: F_ONLY + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID, NSEALM, NSEATM + INTEGER :: NSEAL_DUMMY, ISEA #ifdef W3_PDLIB - INTEGER IRANK + INTEGER IRANK #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3DIMW') + CALL STRACE (IENT, 'W3DIMW') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( PRESENT(F_ONLY) ) THEN - FL_ALL = .NOT. F_ONLY - ELSE - FL_ALL = .TRUE. - END IF -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NWDATA ) THEN - WRITE (NDSE,1002) IMOD, NWDATA - CALL EXTCDE (2) - END IF -! - IF ( WDATAS(IMOD)%DINIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( PRESENT(F_ONLY) ) THEN + FL_ALL = .NOT. F_ONLY + ELSE + FL_ALL = .TRUE. + END IF + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NWDATA ) THEN + WRITE (NDSE,1002) IMOD, NWDATA + CALL EXTCDE (2) + END IF + ! + IF ( WDATAS(IMOD)%DINIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! - JGRID = IGRID - IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! - CALL SET_UP_NSEAL_NSEALM(NSEAL_DUMMY, NSEALM) - NSEATM = NSEALM * NAPROC -! - IF ( FL_ALL ) THEN - ALLOCATE ( WDATAS(IMOD)%VA(NSPEC,0:NSEALM), STAT=ISTAT ); WDATAS(IMOD)%VA = 0. - CHECK_ALLOC_STATUS ( ISTAT ) + WRITE (NDST,9000) IMOD +#endif + ! + JGRID = IGRID + IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + CALL SET_UP_NSEAL_NSEALM(NSEAL_DUMMY, NSEALM) + NSEATM = NSEALM * NAPROC + ! + IF ( FL_ALL ) THEN + ALLOCATE ( WDATAS(IMOD)%VA(NSPEC,0:NSEALM), STAT=ISTAT ); WDATAS(IMOD)%VA = 0. + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_PDLIB - ALLOCATE ( WDATAS(IMOD)%SHAVETOT(NSEAL), stat=istat ) + ALLOCATE ( WDATAS(IMOD)%SHAVETOT(NSEAL), stat=istat ) #endif #ifdef W3_PDLIB - IF (.not. LSLOC) THEN - ALLOCATE ( WDATAS(IMOD)%VSTOT(NSPEC,NSEAL), stat=istat ) + IF (.not. LSLOC) THEN + ALLOCATE ( WDATAS(IMOD)%VSTOT(NSPEC,NSEAL), stat=istat ) #endif #ifdef W3_PDLIB - ALLOCATE ( WDATAS(IMOD)%VDTOT(NSPEC,NSEAL), stat=istat ) + ALLOCATE ( WDATAS(IMOD)%VDTOT(NSPEC,NSEAL), stat=istat ) #endif #ifdef W3_PDLIB - ENDIF ! LSLOC - ALLOCATE ( WDATAS(IMOD)%VAOLD(NSPEC,NSEAL), stat=istat ) + ENDIF ! LSLOC + ALLOCATE ( WDATAS(IMOD)%VAOLD(NSPEC,NSEAL), stat=istat ) #endif #ifdef W3_PDLIB - IF (.not. LSLOC) THEN - WDATAS(IMOD)%VSTOT=0 + IF (.not. LSLOC) THEN + WDATAS(IMOD)%VSTOT=0 #endif #ifdef W3_PDLIB - WDATAS(IMOD)%VDTOT=0 + WDATAS(IMOD)%VDTOT=0 #endif #ifdef W3_PDLIB - ENDIF ! LSLOC - WDATAS(IMOD)%SHAVETOT=.FALSE. -#endif -! -! * Four arrays for NL5 (QL) -! * AFAIK, the set up of QR5TIM0, QR5CVK0, QC5INT0 should be similar -! * to VA, though I am not really clear about how FL_ALL works. -! * + ENDIF ! LSLOC + WDATAS(IMOD)%SHAVETOT=.FALSE. +#endif + ! + ! * Four arrays for NL5 (QL) + ! * AFAIK, the set up of QR5TIM0, QR5CVK0, QC5INT0 should be similar + ! * to VA, though I am not really clear about how FL_ALL works. + ! * #ifdef W3_NL5 - ALLOCATE ( WDATAS(IMOD)%QR5TIM0(0:NSEALM), & - WDATAS(IMOD)%QR5CVK0(NSPEC, 0:NSEALM), & - WDATAS(IMOD)%QC5INT0(QI5NNZ, 0:NSEALM), & - WDATAS(IMOD)%QR5TMIX(0:NSEALM), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! -! * Initialized NL5 arrays with zero (QL) + ALLOCATE ( WDATAS(IMOD)%QR5TIM0(0:NSEALM), & + WDATAS(IMOD)%QR5CVK0(NSPEC, 0:NSEALM), & + WDATAS(IMOD)%QC5INT0(QI5NNZ, 0:NSEALM), & + WDATAS(IMOD)%QR5TMIX(0:NSEALM), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! + ! * Initialized NL5 arrays with zero (QL) #ifdef W3_NL5 - WDATAS(IMOD)%QR5TIM0 = 0.0 - WDATAS(IMOD)%QR5CVK0 = 0.0 - WDATAS(IMOD)%QC5INT0 = (0.0, 0.0) - WDATAS(IMOD)%QR5TMIX = 0.0 + WDATAS(IMOD)%QR5TIM0 = 0.0 + WDATAS(IMOD)%QR5CVK0 = 0.0 + WDATAS(IMOD)%QC5INT0 = (0.0, 0.0) + WDATAS(IMOD)%QR5TMIX = 0.0 #endif -! + ! #ifdef W3_NL5 - WRITE(*, *) - WRITE(*, '(A, I4, I12)') '⊚ → [WW3 WDAT]: IMOD & QI5NNZ: ', IMOD, QI5NNZ - WRITE(*, *) -#endif -! - IF ( NSEAL .NE. NSEALM ) THEN - DO ISEA=NSEAL+1,NSEALM - WDATAS(IMOD)%VA(:,ISEA) = 0. -! + WRITE(*, *) + WRITE(*, '(A, I4, I12)') '⊚ → [WW3 WDAT]: IMOD & QI5NNZ: ', IMOD, QI5NNZ + WRITE(*, *) +#endif + ! + IF ( NSEAL .NE. NSEALM ) THEN + DO ISEA=NSEAL+1,NSEALM + WDATAS(IMOD)%VA(:,ISEA) = 0. + ! #ifdef W3_NL5 - WDATAS(IMOD)%QR5TIM0(ISEA) = 0.0 - WDATAS(IMOD)%QR5CVK0(:,ISEA) = 0.0 - WDATAS(IMOD)%QC5INT0(:,ISEA) = (0.0, 0.0) - WDATAS(IMOD)%QR5TMIX(ISEA) = 0.0 -#endif - END DO - END IF - END IF -! - ! ICE, ICEH, ICEF must be defined from 0:NSEA - ALLOCATE ( WDATAS(IMOD)%WLV(NSEA), & - WDATAS(IMOD)%ICE(0:NSEA), & - WDATAS(IMOD)%RHOAIR(NSEA), & + WDATAS(IMOD)%QR5TIM0(ISEA) = 0.0 + WDATAS(IMOD)%QR5CVK0(:,ISEA) = 0.0 + WDATAS(IMOD)%QC5INT0(:,ISEA) = (0.0, 0.0) + WDATAS(IMOD)%QR5TMIX(ISEA) = 0.0 +#endif + END DO + END IF + END IF + ! + ! ICE, ICEH, ICEF must be defined from 0:NSEA + ALLOCATE ( WDATAS(IMOD)%WLV(NSEA), & + WDATAS(IMOD)%ICE(0:NSEA), & + WDATAS(IMOD)%RHOAIR(NSEA), & #ifdef W3_SETUP - WDATAS(IMOD)%ZETA_SETUP(NSEA), & -#endif - WDATAS(IMOD)%BERG(NSEA), & - WDATAS(IMOD)%ICEH(0:NSEA), & - WDATAS(IMOD)%ICEF(0:NSEA), & - WDATAS(IMOD)%ICEDMAX(NSEA), & - WDATAS(IMOD)%UST(0:NSEATM), & - WDATAS(IMOD)%USTDIR(0:NSEATM), & - WDATAS(IMOD)%ASF(NSEATM), & - WDATAS(IMOD)%FPIS(NSEATM), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + WDATAS(IMOD)%ZETA_SETUP(NSEA), & +#endif + WDATAS(IMOD)%BERG(NSEA), & + WDATAS(IMOD)%ICEH(0:NSEA), & + WDATAS(IMOD)%ICEF(0:NSEA), & + WDATAS(IMOD)%ICEDMAX(NSEA), & + WDATAS(IMOD)%UST(0:NSEATM), & + WDATAS(IMOD)%USTDIR(0:NSEATM), & + WDATAS(IMOD)%ASF(NSEATM), & + WDATAS(IMOD)%FPIS(NSEATM), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) - WDATAS(IMOD)%WLV (:) = 0. - WDATAS(IMOD)%ICE (0:NSEA) = 0. - WDATAS(IMOD)%RHOAIR(:) = DAIR + WDATAS(IMOD)%WLV (:) = 0. + WDATAS(IMOD)%ICE (0:NSEA) = 0. + WDATAS(IMOD)%RHOAIR(:) = DAIR #ifdef W3_SETUP - WDATAS(IMOD)%ZETA_SETUP(:) = 0. -#endif - WDATAS(IMOD)%BERG (:) = 0. - WDATAS(IMOD)%ICEH (0:NSEA) = GRIDS(IMOD)%IICEHINIT - WDATAS(IMOD)%ICEF (0:NSEA) = 1000. - WDATAS(IMOD)%ICEDMAX(:) = 1000. - WDATAS(IMOD)%UST (0:NSEATM) = 1.E-5 - WDATAS(IMOD)%USTDIR(0:NSEATM) = 0. - WDATAS(IMOD)%ASF (:) = 0. - WDATAS(IMOD)%FPIS (:) = 0. - WDATAS(IMOD)%DINIT = .TRUE. - CALL W3SETW ( IMOD, NDSE, NDST ) -! + WDATAS(IMOD)%ZETA_SETUP(:) = 0. +#endif + WDATAS(IMOD)%BERG (:) = 0. + WDATAS(IMOD)%ICEH (0:NSEA) = GRIDS(IMOD)%IICEHINIT + WDATAS(IMOD)%ICEF (0:NSEA) = 1000. + WDATAS(IMOD)%ICEDMAX(:) = 1000. + WDATAS(IMOD)%UST (0:NSEATM) = 1.E-5 + WDATAS(IMOD)%USTDIR(0:NSEATM) = 0. + WDATAS(IMOD)%ASF (:) = 0. + WDATAS(IMOD)%FPIS (:) = 0. + WDATAS(IMOD)%DINIT = .TRUE. + CALL W3SETW ( IMOD, NDSE, NDST ) + ! #ifdef W3_T - WRITE (NDST,9003) -#endif -! -! -------------------------------------------------------------------- / -! 5. Restore previous grid setting if necessary -! - IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DIMW : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DIMW : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NWDATA = ',I10/) - 1003 FORMAT (/' *** ERROR W3DIMW : ARRAY(S) ALREADY ALLOCATED *** ') -! + WRITE (NDST,9003) +#endif + ! + ! -------------------------------------------------------------------- / + ! 5. Restore previous grid setting if necessary + ! + IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DIMW : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DIMW : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NWDATA = ',I10/) +1003 FORMAT (/' *** ERROR W3DIMW : ARRAY(S) ALREADY ALLOCATED *** ') + ! #ifdef W3_T - 9000 FORMAT (' TEST W3DIMW : MODEL ',I4,' DIM. AT ',2I5,I7) +9000 FORMAT (' TEST W3DIMW : MODEL ',I4,' DIM. AT ',2I5,I7) #endif -! + ! #ifdef W3_T - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETW ( IMOD, NDSE, NDST ) -! + WRITE (NDST,9001) +#endif + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETW ( IMOD, NDSE, NDST ) + ! #ifdef W3_T - WRITE (NDST,9002) + WRITE (NDST,9002) #endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid #ifdef W3_T - 9001 FORMAT (' TEST W3DIMW : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DIMW : POINTERS RESET') - 9003 FORMAT (' TEST W3DIMW : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DIMW ----------------------------------------------------- / -!/ - END SUBROUTINE W3DIMW -!/ ------------------------------------------------------------------- / -!> -!> @brief Select one of the WAVEWATCH III grids / models. -!> -!> @details Point pointers to the proper variables in the proper element of -!> the GRIDS array. -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE W3SETW ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 31-Mar-2004 : Origination. ( version 3.06 ) -!/ 05-Jul-2006 : Consolidate stress vector. ( version 3.09 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 22-Mar-2021 : Support for variable air density ( version 7.13 ) -!/ -! 1. Purpose : -! -! Select one of the WAVEWATCH III grids / models. -! -! 2. Method : -! -! Point pointers to the proper variables in the proper element of -! the GRIDS array. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Many subroutines in the WAVEWATCH system. -! -! 6. Error messages : -! -! Checks on parameter list IMOD. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE +9001 FORMAT (' TEST W3DIMW : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DIMW : POINTERS RESET') +9003 FORMAT (' TEST W3DIMW : DIMENSIONS STORED') +#endif + !/ + !/ End of W3DIMW ----------------------------------------------------- / + !/ + END SUBROUTINE W3DIMW + !/ ------------------------------------------------------------------- / + !> + !> @brief Select one of the WAVEWATCH III grids / models. + !> + !> @details Point pointers to the proper variables in the proper element of + !> the GRIDS array. + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE W3SETW ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 31-Mar-2004 : Origination. ( version 3.06 ) + !/ 05-Jul-2006 : Consolidate stress vector. ( version 3.09 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 22-Mar-2021 : Support for variable air density ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Select one of the WAVEWATCH III grids / models. + ! + ! 2. Method : + ! + ! Point pointers to the proper variables in the proper element of + ! the GRIDS array. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Many subroutines in the WAVEWATCH system. + ! + ! 6. Error messages : + ! + ! Checks on parameter list IMOD. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3SETW') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NWDATA .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.0 .OR. IMOD.GT.NWDATA ) THEN - WRITE (NDSE,1002) IMOD, NWDATA - CALL EXTCDE (2) - END IF -! + CALL STRACE (IENT, 'W3SETW') +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NWDATA .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.0 .OR. IMOD.GT.NWDATA ) THEN + WRITE (NDSE,1002) IMOD, NWDATA + CALL EXTCDE (2) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Set model numbers -! - IWDATA = IMOD -! -! -------------------------------------------------------------------- / -! 3. Set pointers -! - TIME => WDATAS(IMOD)%TIME + WRITE (NDST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Set model numbers + ! + IWDATA = IMOD + ! + ! -------------------------------------------------------------------- / + ! 3. Set pointers + ! + TIME => WDATAS(IMOD)%TIME #ifdef W3_OASIS - TIME00 => WDATAS(IMOD)%TIME00 - TIMEEND => WDATAS(IMOD)%TIMEEND + TIME00 => WDATAS(IMOD)%TIME00 + TIMEEND => WDATAS(IMOD)%TIMEEND #endif #ifdef W3_NL5 - QI5TBEG => WDATAS(IMOD)%QI5TBEG -#endif - TLEV => WDATAS(IMOD)%TLEV - TICE => WDATAS(IMOD)%TICE - TRHO => WDATAS(IMOD)%TRHO - TIC1 => WDATAS(IMOD)%TIC1 - TIC5 => WDATAS(IMOD)%TIC5 - DINIT => WDATAS(IMOD)%DINIT - FL_ALL => WDATAS(IMOD)%FL_ALL -! - IF ( DINIT ) THEN - IF ( FL_ALL ) THEN - VA => WDATAS(IMOD)%VA + QI5TBEG => WDATAS(IMOD)%QI5TBEG +#endif + TLEV => WDATAS(IMOD)%TLEV + TICE => WDATAS(IMOD)%TICE + TRHO => WDATAS(IMOD)%TRHO + TIC1 => WDATAS(IMOD)%TIC1 + TIC5 => WDATAS(IMOD)%TIC5 + DINIT => WDATAS(IMOD)%DINIT + FL_ALL => WDATAS(IMOD)%FL_ALL + ! + IF ( DINIT ) THEN + IF ( FL_ALL ) THEN + VA => WDATAS(IMOD)%VA #ifdef W3_NL5 - QR5TIM0 => WDATAS(IMOD)%QR5TIM0 - QR5CVK0 => WDATAS(IMOD)%QR5CVK0 - QC5INT0 => WDATAS(IMOD)%QC5INT0 - QR5TMIX => WDATAS(IMOD)%QR5TMIX + QR5TIM0 => WDATAS(IMOD)%QR5TIM0 + QR5CVK0 => WDATAS(IMOD)%QR5CVK0 + QC5INT0 => WDATAS(IMOD)%QC5INT0 + QR5TMIX => WDATAS(IMOD)%QR5TMIX #endif #ifdef W3_PDLIB - SHAVETOT => WDATAS(IMOD)%SHAVETOT - VSTOT => WDATAS(IMOD)%VSTOT - VDTOT => WDATAS(IMOD)%VDTOT - VAOLD => WDATAS(IMOD)%VAOLD -#endif - END IF - WLV => WDATAS(IMOD)%WLV - ICE => WDATAS(IMOD)%ICE - RHOAIR => WDATAS(IMOD)%RHOAIR + SHAVETOT => WDATAS(IMOD)%SHAVETOT + VSTOT => WDATAS(IMOD)%VSTOT + VDTOT => WDATAS(IMOD)%VDTOT + VAOLD => WDATAS(IMOD)%VAOLD +#endif + END IF + WLV => WDATAS(IMOD)%WLV + ICE => WDATAS(IMOD)%ICE + RHOAIR => WDATAS(IMOD)%RHOAIR #ifdef W3_SETUP - ZETA_SETUP => WDATAS(IMOD)%ZETA_SETUP - FX_zs => WDATAS(IMOD)%FX_zs - FY_zs => WDATAS(IMOD)%FY_zs - SXX_zs => WDATAS(IMOD)%SXX_zs - SXY_zs => WDATAS(IMOD)%SXY_zs - SYY_zs => WDATAS(IMOD)%SYY_zs -#endif - BERG => WDATAS(IMOD)%BERG - ICEH => WDATAS(IMOD)%ICEH - ICEF => WDATAS(IMOD)%ICEF - ICEDMAX=> WDATAS(IMOD)%ICEDMAX - UST => WDATAS(IMOD)%UST - USTDIR => WDATAS(IMOD)%USTDIR - ASF => WDATAS(IMOD)%ASF - FPIS => WDATAS(IMOD)%FPIS - END IF -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3SETW : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3SETW : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NWDATA = ',I10/) -! + ZETA_SETUP => WDATAS(IMOD)%ZETA_SETUP + FX_zs => WDATAS(IMOD)%FX_zs + FY_zs => WDATAS(IMOD)%FY_zs + SXX_zs => WDATAS(IMOD)%SXX_zs + SXY_zs => WDATAS(IMOD)%SXY_zs + SYY_zs => WDATAS(IMOD)%SYY_zs +#endif + BERG => WDATAS(IMOD)%BERG + ICEH => WDATAS(IMOD)%ICEH + ICEF => WDATAS(IMOD)%ICEF + ICEDMAX=> WDATAS(IMOD)%ICEDMAX + UST => WDATAS(IMOD)%UST + USTDIR => WDATAS(IMOD)%USTDIR + ASF => WDATAS(IMOD)%ASF + FPIS => WDATAS(IMOD)%FPIS + END IF + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3SETW : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3SETW : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NWDATA = ',I10/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3SETW : MODEL ',I4,' SELECTED') -#endif -!/ -!/ End of W3SETW ----------------------------------------------------- / -!/ - END SUBROUTINE W3SETW -!/ -!/ End of module W3WDATMD -------------------------------------------- / -!/ - END MODULE W3WDATMD +9000 FORMAT (' TEST W3SETW : MODEL ',I4,' SELECTED') +#endif + !/ + !/ End of W3SETW ----------------------------------------------------- / + !/ + END SUBROUTINE W3SETW + !/ + !/ End of module W3WDATMD -------------------------------------------- / + !/ +END MODULE W3WDATMD diff --git a/model/src/wav_comp_nuopc.F90 b/model/src/wav_comp_nuopc.F90 index 4ab470f3c..47b7cf37a 100644 --- a/model/src/wav_comp_nuopc.F90 +++ b/model/src/wav_comp_nuopc.F90 @@ -41,7 +41,7 @@ module wav_comp_nuopc use wav_import_export , only : advertise_fields, realize_fields use wav_shr_mod , only : state_diagnose, state_getfldptr, state_fldchk use wav_shr_mod , only : chkerr, state_setscalar, state_getscalar, alarmInit, ymd2date - use wav_shr_mod , only : wav_coupling_to_cice + use wav_shr_mod , only : wav_coupling_to_cice, nwav_elev_spectrum use wav_shr_mod , only : merge_import, dbug_flag use w3odatmd , only : nds, iaproc, napout use w3odatmd , only : runtype, use_user_histname, user_histfname, use_user_restname, user_restfname @@ -247,77 +247,77 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - flds_scalar_name = trim(cvalue) - call ESMF_LogWrite(trim(subname)//' flds_scalar_name = '//trim(flds_scalar_name), ESMF_LOGMSG_INFO) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(trim(subname)//' flds_scalar_name = '//trim(flds_scalar_name), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else - call ESMF_LogWrite(trim(subname)//'Need to set attribute ScalarFieldName',& - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//'Need to set attribute ScalarFieldName',& + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return endif call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(cvalue, *) flds_scalar_num - write(logmsg,*) flds_scalar_num - call ESMF_LogWrite(trim(subname)//' flds_scalar_num = '//trim(logmsg), ESMF_LOGMSG_INFO) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue, *) flds_scalar_num + write(logmsg,*) flds_scalar_num + call ESMF_LogWrite(trim(subname)//' flds_scalar_num = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else - call ESMF_LogWrite(trim(subname)//'Need to set attribute ScalarFieldCount',& - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//'Need to set attribute ScalarFieldCount',& + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return endif call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(cvalue,*) flds_scalar_index_nx - write(logmsg,*) flds_scalar_index_nx - call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_nx = '//trim(logmsg), ESMF_LOGMSG_INFO) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_scalar_index_nx + write(logmsg,*) flds_scalar_index_nx + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_nx = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else - call ESMF_LogWrite(trim(subname)//'Need to set attribute ScalarFieldIdxGridNX',& - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//'Need to set attribute ScalarFieldIdxGridNX',& + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return endif call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(cvalue,*) flds_scalar_index_ny - write(logmsg,*) flds_scalar_index_ny - call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_ny = '//trim(logmsg), ESMF_LOGMSG_INFO) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_scalar_index_ny + write(logmsg,*) flds_scalar_index_ny + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_ny = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else - call ESMF_LogWrite(trim(subname)//'Need to set attribute ScalarFieldIdxGridNY',& - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//'Need to set attribute ScalarFieldIdxGridNY',& + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return endif call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(cvalue,*) profile_memory - call ESMF_LogWrite(trim(subname)//': profile_memory = '//trim(cvalue), ESMF_LOGMSG_INFO, rc=rc) + read(cvalue,*) profile_memory + call ESMF_LogWrite(trim(subname)//': profile_memory = '//trim(cvalue), ESMF_LOGMSG_INFO, rc=rc) end if call NUOPC_CompAttributeGet(gcomp, name="merge_import", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - if (trim(cvalue) == '.true.') then - merge_import = .true. - end if + if (trim(cvalue) == '.true.') then + merge_import = .true. + end if end if call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(cvalue,*) dbug_flag + read(cvalue,*) dbug_flag end if write(logmsg,'(A,i6)') trim(subname)//': Wave cap dbug_flag is ',dbug_flag call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) @@ -332,13 +332,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call NUOPC_CompAttributeGet(gcomp, name="inst_suffix", isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then - call NUOPC_CompAttributeGet(gcomp, name="inst_suffix", value=inst_suffix, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - cvalue = inst_suffix(2:) - read(cvalue, *) inst_index + call NUOPC_CompAttributeGet(gcomp, name="inst_suffix", value=inst_suffix, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + cvalue = inst_suffix(2:) + read(cvalue, *) inst_index else - inst_suffix = "" - inst_index=1 + inst_suffix = "" + inst_index=1 endif ! Get Multigrid setting @@ -346,7 +346,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call NUOPC_CompAttributeGet(gcomp, name='multigrid', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - multigrid=(trim(cvalue)=="true") + multigrid=(trim(cvalue)=="true") end if write(logmsg,'(A,l)') trim(subname)//': Wave multigrid setting is ',multigrid call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) @@ -357,7 +357,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - wav_coupling_to_cice=(trim(cvalue)=="true") + wav_coupling_to_cice=(trim(cvalue)=="true") end if write(logmsg,'(A,l)') trim(subname)//': Wave wav_coupling_to_cice setting is ',wav_coupling_to_cice call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) @@ -398,7 +398,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) use w3timemd , only : stme21 use w3adatmd , only : w3naux, w3seta use w3idatmd , only : w3seti, w3ninp - use w3gdatmd , only : nseal, nsea, nx, ny, mapsf, w3nmod, w3setg + use w3gdatmd , only : nk, nseal, nsea, nx, ny, mapsf, w3nmod, w3setg use w3wdatmd , only : va, time, w3ndat, w3dimw, w3setw #ifndef W3_CESMCOUPLED use wminitmd , only : wminit, wminitnml @@ -470,17 +470,17 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !-------------------------------------------------------------------- if (.not. multigrid) then - call w3nmod ( 1, 6, 6 ) - call w3ndat ( 6, 6 ) - call w3naux ( 6, 6 ) - call w3nout ( 6, 6 ) - call w3ninp ( 6, 6 ) - - call w3setg ( 1, 6, 6 ) - call w3setw ( 1, 6, 6 ) - call w3seta ( 1, 6, 6 ) - call w3seto ( 1, 6, 6 ) - call w3seti ( 1, 6, 6 ) + call w3nmod ( 1, 6, 6 ) + call w3ndat ( 6, 6 ) + call w3naux ( 6, 6 ) + call w3nout ( 6, 6 ) + call w3ninp ( 6, 6 ) + + call w3setg ( 1, 6, 6 ) + call w3setw ( 1, 6, 6 ) + call w3seta ( 1, 6, 6 ) + call w3seto ( 1, 6, 6 ) + call w3seti ( 1, 6, 6 ) end if !---------------------------------------------------------------------------- @@ -502,13 +502,13 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) #ifndef W3_CESMCOUPLED improc = iam + 1 if (multigrid) then - nmpscr = 1 - is_esmf_component = .true. + nmpscr = 1 + is_esmf_component = .true. else - iaproc = iam + 1 - naproc = nmproc - napout = 1 - naperr = 1 + iaproc = iam + 1 + naproc = nmproc + napout = 1 + naperr = 1 end if if (improc == 1) root_task = .true. #else @@ -523,25 +523,25 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !-------------------------------------------------------------------- if (cesmcoupled) then - shrlogunit = 6 - if ( root_task ) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - open (newunit=stdout, file=trim(diro)//"/"//trim(logfile)) - else - stdout = 6 - endif + shrlogunit = 6 + if ( root_task ) then + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + open (newunit=stdout, file=trim(diro)//"/"//trim(logfile)) + else + stdout = 6 + endif else - stdout = 6 + stdout = 6 end if if (.not. multigrid) call set_shel_io(stdout,mds,ntrace) if ( root_task ) then - write(stdout,'(a)')' *** WAVEWATCH III Program shell *** ' - write(stdout,'(a)')'===============================================' + write(stdout,'(a)')' *** WAVEWATCH III Program shell *** ' + write(stdout,'(a)')'===============================================' end if !-------------------------------------------------------------------- @@ -551,14 +551,14 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call NUOPC_CompAttributeGet(gcomp, name='start_type', value=starttype, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if ( trim(starttype) == trim('startup')) then - runtype = "initial" + runtype = "initial" else if (trim(starttype) == trim('continue') ) then - runtype = "continue" + runtype = "continue" else if (trim(starttype) == trim('branch')) then - runtype = "branch" + runtype = "branch" end if if ( root_task ) then - write(stdout,*) 'WW3 runtype is '//trim(runtype) + write(stdout,*) 'WW3 runtype is '//trim(runtype) end if call ESMF_LogWrite('WW3 runtype is '//trim(runtype), ESMF_LOGMSG_INFO) @@ -570,17 +570,17 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! NOTE - are not setting TIMEN here if ( root_task ) then - write(stdout,'(a)')' Time interval : ' - write(stdout,'(a)')'--------------------------------------------------' + write(stdout,'(a)')' Time interval : ' + write(stdout,'(a)')'--------------------------------------------------' end if ! Initial run or restart run if ( runtype == "initial") then - call ESMF_ClockGet( clock, startTime=esmfTime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet( clock, startTime=esmfTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else - call ESMF_ClockGet( clock, currTime=esmfTime, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet( clock, currTime=esmfTime, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! Determine time attributes for history output call ESMF_TimeGet( esmfTime, timeString=time_origin, calendar=calendar, rc=rc ) @@ -588,9 +588,9 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) time_origin = 'seconds since '//time_origin(1:10)//' '//time_origin(12:19) !call ESMF_ClockGet(clock, calendar=calendar) if (calendar == ESMF_CALKIND_GREGORIAN) then - calendar_name = 'standard' + calendar_name = 'standard' else if (calendar == ESMF_CALKIND_NOLEAP) then - calendar_name = 'noleap' + calendar_name = 'noleap' end if call ESMF_TimeGet( esmfTime, yy=yy, mm=mm, dd=dd, s=start_tod, rc=rc ) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -618,8 +618,8 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call stme21 ( time0 , dtme21 ) if ( root_task ) then - write (stdout,'(a)')' Starting time : '//trim(dtme21) - write (stdout,'(a,i8,2x,i8)') 'start_ymd, stop_ymd = ',start_ymd, stop_ymd + write (stdout,'(a)')' Starting time : '//trim(dtme21) + write (stdout,'(a,i8,2x,i8)') 'start_ymd, stop_ymd = ',start_ymd, stop_ymd end if #ifndef W3_CESMCOUPLED stime = time0 @@ -632,30 +632,30 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) #ifndef W3_CESMCOUPLED if (multigrid) then - call ESMF_UtilIOUnitGet(idsi); open(unit=idsi, status='scratch') - call ESMF_UtilIOUnitGet(idso); open(unit=idso, status='scratch') - call ESMF_UtilIOUnitGet(idss); open(unit=idss, status='scratch') - call ESMF_UtilIOUnitGet(idst); open(unit=idst, status='scratch') - call ESMF_UtilIOUnitGet(idse); open(unit=idse, status='scratch') - close(idsi); close(idso); close(idss); close(idst); close(idse) - - if ( trim(ifname) == 'ww3_multi.nml' ) then - call wminitnml ( idsi, idso, idss, idst, idse, trim(ifname), & - mpi_comm, preamb=preamb ) - else - call wminit ( idsi, idso, idss, idst, idse, trim(ifname), & - mpi_comm, preamb=preamb ) - endif - - allocate(tend(2,nrgrd)) - do imod = 1,nrgrd - tend(1,imod) = etime(1) - tend(2,imod) = etime(2) - end do - call ESMF_LogWrite(trim(subname)//' done = wminit', ESMF_LOGMSG_INFO) + call ESMF_UtilIOUnitGet(idsi); open(unit=idsi, status='scratch') + call ESMF_UtilIOUnitGet(idso); open(unit=idso, status='scratch') + call ESMF_UtilIOUnitGet(idss); open(unit=idss, status='scratch') + call ESMF_UtilIOUnitGet(idst); open(unit=idst, status='scratch') + call ESMF_UtilIOUnitGet(idse); open(unit=idse, status='scratch') + close(idsi); close(idso); close(idss); close(idst); close(idse) + + if ( trim(ifname) == 'ww3_multi.nml' ) then + call wminitnml ( idsi, idso, idss, idst, idse, trim(ifname), & + mpi_comm, preamb=preamb ) + else + call wminit ( idsi, idso, idss, idst, idse, trim(ifname), & + mpi_comm, preamb=preamb ) + endif + + allocate(tend(2,nrgrd)) + do imod = 1,nrgrd + tend(1,imod) = etime(1) + tend(2,imod) = etime(2) + end do + call ESMF_LogWrite(trim(subname)//' done = wminit', ESMF_LOGMSG_INFO) else - call waveinit_ufs(gcomp, ntrace, mpi_comm, mds, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call waveinit_ufs(gcomp, ntrace, mpi_comm, mds, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if #else time = time0 @@ -667,8 +667,15 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! call mpi_barrier ( mpi_comm, ierr ) if ( root_task ) then - inquire(unit=nds(1), name=logfile) - print *,'WW3 log written to '//trim(logfile) + inquire(unit=nds(1), name=logfile) + print *,'WW3 log written to '//trim(logfile) + end if + + if (wav_coupling_to_cice) then + if (nwav_elev_spectrum .gt. nk) then + call ESMF_LogWrite('nwav_elev_spectrum is greater than nk ', ESMF_LOGMSG_INFO) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + end if end if !-------------------------------------------------------------------- @@ -676,7 +683,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !-------------------------------------------------------------------- if (user_netcdf_grdout) then - call wavinit_grdout + call wavinit_grdout end if !-------------------------------------------------------------------- @@ -689,10 +696,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! create a global index array for sea points allocate(gindex_sea(nseal)) do jsea=1, nseal - isea = iaproc + (jsea-1)*naproc - ix = mapsf(isea,1) - iy = mapsf(isea,2) - gindex_sea(jsea) = ix + (iy-1)*nx + isea = iaproc + (jsea-1)*naproc + ix = mapsf(isea,1) + iy = mapsf(isea,2) + gindex_sea(jsea) = ix + (iy-1)*nx end do ! create a global index array for non-sea (i.e. land points) @@ -700,10 +707,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) mask_local(:) = 0 mask_global(:) = 0 do jsea=1, nseal - isea = iaproc + (jsea-1)*naproc - ix = mapsf(isea,1) - iy = mapsf(isea,2) - mask_local(ix + (iy-1)*nx) = 1 + isea = iaproc + (jsea-1)*naproc + ix = mapsf(isea,1) + iy = mapsf(isea,2) + mask_local(ix + (iy-1)*nx) = 1 end do call ESMF_VMAllReduce(vm, sendData=mask_local, recvData=mask_global, count=nx*ny, & reduceflag=ESMF_REDUCE_MAX, rc=rc) @@ -712,19 +719,19 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) nlnd_local = nlnd_global / naproc my_lnd_start = nlnd_local*iam + min(iam, mod(nlnd_global, naproc)) + 1 if (iam < mod(nlnd_global, naproc)) then - nlnd_local = nlnd_local + 1 + nlnd_local = nlnd_local + 1 end if my_lnd_end = my_lnd_start + nlnd_local - 1 allocate(gindex_lnd(my_lnd_end - my_lnd_start + 1)) ncnt = 0 do n = 1,nx*ny - if (mask_global(n) == 0) then ! this is a land point - ncnt = ncnt + 1 - if (ncnt >= my_lnd_start .and. ncnt <= my_lnd_end) then - gindex_lnd(ncnt - my_lnd_start + 1) = n - end if - end if + if (mask_global(n) == 0) then ! this is a land point + ncnt = ncnt + 1 + if (ncnt >= my_lnd_start .and. ncnt <= my_lnd_end) then + gindex_lnd(ncnt - my_lnd_start + 1) = n + end if + end if end do deallocate(mask_global) deallocate(mask_local) @@ -733,11 +740,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) nlnd = (my_lnd_end - my_lnd_start + 1) allocate(gindex(nlnd + nseal)) do ncnt = 1,nlnd + nseal - if (ncnt <= nseal) then - gindex(ncnt) = gindex_sea(ncnt) - else - gindex(ncnt) = gindex_lnd(ncnt-nseal) - end if + if (ncnt <= nseal) then + gindex(ncnt) = gindex_sea(ncnt) + else + gindex(ncnt) = gindex_lnd(ncnt-nseal) + end if end do deallocate(gindex_sea) deallocate(gindex_lnd) @@ -754,7 +761,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if ( root_task ) then - write(nds(1),*)'mesh file for domain is ',trim(cvalue) + write(nds(1),*)'mesh file for domain is ',trim(cvalue) end if ! recreate the mesh using the above distGrid @@ -774,17 +781,17 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (maskmin == 1) then - ! replace mesh mask with internal mask - meshmask(:) = 0 - meshmask(1:nseal) = 1 - call ESMF_MeshSet(mesh=EMesh, elementMask=meshmask, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! replace mesh mask with internal mask + meshmask(:) = 0 + meshmask(1:nseal) = 1 + call ESMF_MeshSet(mesh=EMesh, elementMask=meshmask, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return end if if (dbug_flag > 5) then - call ESMF_ArrayWrite(elemMaskArray, 'meshmask.nc', variableName = 'mask', & - overwrite=.true., rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ArrayWrite(elemMaskArray, 'meshmask.nc', variableName = 'mask', & + overwrite=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if deallocate(meshmask) deallocate(gindex) @@ -799,16 +806,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) #ifndef W3_CESMCOUPLED !TODO: when is this required? if (multigrid) then - do imod = 1,nrgrd - call w3setg ( imod, mdse, mdst ) - call w3setw ( imod, mdse, mdst ) - call w3seta ( imod, mdse, mdst ) - call w3seti ( imod, mdse, mdst ) - call w3seto ( imod, mdse, mdst ) - call wmsetm ( imod, mdse, mdst ) - local = iaproc .gt. 0 .and. iaproc .le. naproc - if ( local .and. flcold .and. fliwnd ) call w3uini( va ) - enddo + do imod = 1,nrgrd + call w3setg ( imod, mdse, mdst ) + call w3setw ( imod, mdse, mdst ) + call w3seta ( imod, mdse, mdst ) + call w3seti ( imod, mdse, mdst ) + call w3seto ( imod, mdse, mdst ) + call wmsetm ( imod, mdse, mdst ) + local = iaproc .gt. 0 .and. iaproc .le. naproc + if ( local .and. flcold .and. fliwnd ) call w3uini( va ) + enddo end if #endif @@ -859,29 +866,29 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (state_fldchk(exportState, 'Sw_lamult')) then - call state_getfldptr(exportState, 'Sw_lamult', sw_lamult, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_lamult (:) = 1. + call state_getfldptr(exportState, 'Sw_lamult', sw_lamult, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_lamult (:) = 1. endif if (state_fldchk(exportState, 'Sw_ustokes')) then - call state_getfldptr(exportState, 'Sw_ustokes', sw_ustokes, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_ustokes(:) = 0. + call state_getfldptr(exportState, 'Sw_ustokes', sw_ustokes, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_ustokes(:) = 0. endif if (state_fldchk(exportState, 'Sw_vstokes')) then - call state_getfldptr(exportState, 'Sw_vstokes', sw_vstokes, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_vstokes(:) = 0. + call state_getfldptr(exportState, 'Sw_vstokes', sw_vstokes, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_vstokes(:) = 0. endif if (state_fldchk(exportState, 'Sw_z0')) then - call state_getfldptr(exportState, 'Sw_z0', z0rlen, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call CalcRoughl(z0rlen) + call state_getfldptr(exportState, 'Sw_z0', z0rlen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call CalcRoughl(z0rlen) endif if (wav_coupling_to_cice) then - call state_getfldptr(exportState, 'wave_elevation_spectrum', wave_elevation_spectrum, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - wave_elevation_spectrum(:,:) = 0. + call state_getfldptr(exportState, 'wave_elevation_spectrum', wave_elevation_spectrum, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + wave_elevation_spectrum(:,:) = 0. endif ! Set global grid size scalars in export state @@ -891,8 +898,8 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if ( dbug_flag > 5) then - call state_diagnose(exportState, 'at DataInitialize ', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_diagnose(exportState, 'at DataInitialize ', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) @@ -978,7 +985,7 @@ subroutine ModelAdvance(gcomp, rc) time0(1) = ymd time0(2) = hh*10000 + mm*100 + ss if ( root_task ) then - write(nds(1),'(a,3i4,i10)') 'ymd2date currTime wav_comp_nuopc hh,mm,ss,ymd', hh,mm,ss,ymd + write(nds(1),'(a,3i4,i10)') 'ymd2date currTime wav_comp_nuopc hh,mm,ss,ymd', hh,mm,ss,ymd end if ! use next time; the NUOPC clock is not updated @@ -1003,10 +1010,10 @@ subroutine ModelAdvance(gcomp, rc) time = time0 #ifndef W3_CESMCOUPLED if (multigrid) then - do imod = 1,nrgrd - tend(1,imod) = timen(1) - tend(2,imod) = timen(2) - end do + do imod = 1,nrgrd + tend(1,imod) = timen(1) + tend(2,imod) = timen(2) + end do end if #endif @@ -1022,47 +1029,47 @@ subroutine ModelAdvance(gcomp, rc) if(profile_memory) call ESMF_VMLogMemInfo("Entering WW3 Run : ") if (user_restalarm) then - ! Determine if time to write ww3 restart files - call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ChkErr(rc,__LINE__,u_FILE_u)) return - rstwr = .true. - call ESMF_AlarmRingerOff( alarm, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - rstwr = .false. - endif + ! Determine if time to write ww3 restart files + call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + rstwr = .true. + call ESMF_AlarmRingerOff( alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + rstwr = .false. + endif else - rstwr = .false. + rstwr = .false. end if if (user_histalarm) then - ! Determine if time to write ww3 history files - call ESMF_ClockGetAlarm(clock, alarmname='alarm_history', alarm=alarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ChkErr(rc,__LINE__,u_FILE_u)) return - histwr = .true. - call ESMF_AlarmRingerOff( alarm, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - histwr = .false. - endif + ! Determine if time to write ww3 history files + call ESMF_ClockGetAlarm(clock, alarmname='alarm_history', alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + histwr = .true. + call ESMF_AlarmRingerOff( alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + histwr = .false. + endif else - histwr = .false. + histwr = .false. end if if ( root_task ) then - ! write(nds(1),*) 'wav_comp_nuopc time', time, timen - ! write(nds(1),*) 'ww3 hist flag ', histwr, hh + ! write(nds(1),*) 'wav_comp_nuopc time', time, timen + ! write(nds(1),*) 'ww3 hist flag ', histwr, hh end if ! Advance the wave model #ifndef W3_CESMCOUPLED if (multigrid) then - call wmwave ( tend ) + call wmwave ( tend ) else - call w3wave ( 1, odat, timen ) + call w3wave ( 1, odat, timen ) end if #else call w3wave ( 1, odat, timen ) @@ -1151,104 +1158,104 @@ subroutine ModelSetRunClock(gcomp, rc) if (alarmCount == 0) then - call ESMF_ClockGet(mclock, startTime=mStartTime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridCompGet(gcomp, name=name, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(trim(subname)//'setting alarms for ' // trim(name), ESMF_LOGMSG_INFO) - - !---------------- - ! Restart alarm - !---------------- - call NUOPC_CompAttributeGet(gcomp, name="restart_option", isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) restart_n - - call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) restart_ymd - - call alarmInit(mclock, restart_alarm, restart_option, & - opt_n = restart_n, & - opt_ymd = restart_ymd, & - RefTime = mCurrTime, & - alarmname = 'alarm_restart', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - user_restalarm = .true. - else - ! If attribute is not present - write restarts at native WW3 freq - restart_option = 'none' - restart_n = -999 - user_restalarm = .false. - end if - - !---------------- - ! Stop alarm - !---------------- - call NUOPC_CompAttributeGet(gcomp, name="stop_option", value=stop_option, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call NUOPC_CompAttributeGet(gcomp, name="stop_n", value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) stop_n - - call NUOPC_CompAttributeGet(gcomp, name="stop_ymd", value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) stop_ymd - - call alarmInit(mclock, stop_alarm, stop_option, & - opt_n = stop_n, & - opt_ymd = stop_ymd, & - RefTime = mCurrTime, & - alarmname = 'alarm_stop', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_AlarmSet(stop_alarm, clock=mclock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - !---------------- - ! History alarm - !---------------- - call NUOPC_CompAttributeGet(gcomp, name="history_option", isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - call NUOPC_CompAttributeGet(gcomp, name='history_option', value=history_option, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call NUOPC_CompAttributeGet(gcomp, name="history_n", value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) history_n - - call NUOPC_CompAttributeGet(gcomp, name="history_ymd", value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) history_ymd - - call alarmInit(mclock, history_alarm, history_option, & - opt_n = history_n, & - opt_ymd = history_ymd, & - RefTime = mStartTime, & - alarmname = 'alarm_history', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_AlarmSet(history_alarm, clock=mclock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - user_histalarm = .true. - else - ! If attribute is not present - write history output at native WW3 frequency - history_option = 'none' - history_n = -999 - user_histalarm = .false. - end if + call ESMF_ClockGet(mclock, startTime=mStartTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridCompGet(gcomp, name=name, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(trim(subname)//'setting alarms for ' // trim(name), ESMF_LOGMSG_INFO) + + !---------------- + ! Restart alarm + !---------------- + call NUOPC_CompAttributeGet(gcomp, name="restart_option", isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) restart_n + + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) restart_ymd + + call alarmInit(mclock, restart_alarm, restart_option, & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mCurrTime, & + alarmname = 'alarm_restart', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + user_restalarm = .true. + else + ! If attribute is not present - write restarts at native WW3 freq + restart_option = 'none' + restart_n = -999 + user_restalarm = .false. + end if + + !---------------- + ! Stop alarm + !---------------- + call NUOPC_CompAttributeGet(gcomp, name="stop_option", value=stop_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="stop_n", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) stop_n + + call NUOPC_CompAttributeGet(gcomp, name="stop_ymd", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) stop_ymd + + call alarmInit(mclock, stop_alarm, stop_option, & + opt_n = stop_n, & + opt_ymd = stop_ymd, & + RefTime = mCurrTime, & + alarmname = 'alarm_stop', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_AlarmSet(stop_alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---------------- + ! History alarm + !---------------- + call NUOPC_CompAttributeGet(gcomp, name="history_option", isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name='history_option', value=history_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="history_n", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) history_n + + call NUOPC_CompAttributeGet(gcomp, name="history_ymd", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) history_ymd + + call alarmInit(mclock, history_alarm, history_option, & + opt_n = history_n, & + opt_ymd = history_ymd, & + RefTime = mStartTime, & + alarmname = 'alarm_history', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_AlarmSet(history_alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + user_histalarm = .true. + else + ! If attribute is not present - write history output at native WW3 frequency + history_option = 'none' + history_n = -999 + user_histalarm = .false. + end if end if @@ -1290,9 +1297,9 @@ subroutine ModelFinalize(gcomp, rc) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) if ( root_task ) then - write(nds(1),F91) - write(nds(1),F00) 'WW3: end of main integration loop' - write(nds(1),F91) + write(nds(1),F91) + write(nds(1),F00) 'WW3: end of main integration loop' + write(nds(1),F91) end if call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) @@ -1357,70 +1364,70 @@ subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, mds, rc) inst_name = "WAV"//trim(inst_suffix) ! Read namelist (set initfile in w3odatmd) if ( root_task ) then - open (newunit=unitn, file='wav_in'//trim(inst_suffix), status='old') - read (unitn, ww3_inparm, iostat=ierr) - if (ierr /= 0) then - call ESMF_LogWrite(trim(subname)//' problem reading ww3_inparm namelist',& - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return - end if - close (unitn) - - ! Write out input - stdout = mds(1) - write(stdout,*) - write(stdout,'(a)')' --------------------------------------------------' - write(stdout,'(a)')' Initializations : ' - write(stdout,'(a)')' --------------------------------------------------' - write(stdout,'(a)')' Case Name is '//trim(casename) - write(stdout,'(a)') trim(subname)//' inst_name = '//trim(inst_name) - write(stdout,'(a)') trim(subname)//' inst_suffix = '//trim(inst_suffix) - write(stdout,'(a,i4)') trim(subname)//' inst_index = ',inst_index - write(stdout,'(a)')' Read in ww3_inparm namelist from wav_in'//trim(inst_suffix) - write(stdout,'(a)')' initfile = '//trim(initfile) - write(stdout,'(a, 2x, f10.3)')' dtcfl = ',dtcfl - write(stdout,'(a, 2x, f10.3)')' dtcfli = ',dtcfli - write(stdout,'(a, 2x, f10.3)')' dtmax = ',dtmax - write(stdout,'(a, 2x, f10.3)')' dtmin = ',dtmin - write(stdout,*) + open (newunit=unitn, file='wav_in'//trim(inst_suffix), status='old') + read (unitn, ww3_inparm, iostat=ierr) + if (ierr /= 0) then + call ESMF_LogWrite(trim(subname)//' problem reading ww3_inparm namelist',& + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + end if + close (unitn) + + ! Write out input + stdout = mds(1) + write(stdout,*) + write(stdout,'(a)')' --------------------------------------------------' + write(stdout,'(a)')' Initializations : ' + write(stdout,'(a)')' --------------------------------------------------' + write(stdout,'(a)')' Case Name is '//trim(casename) + write(stdout,'(a)') trim(subname)//' inst_name = '//trim(inst_name) + write(stdout,'(a)') trim(subname)//' inst_suffix = '//trim(inst_suffix) + write(stdout,'(a,i4)') trim(subname)//' inst_index = ',inst_index + write(stdout,'(a)')' Read in ww3_inparm namelist from wav_in'//trim(inst_suffix) + write(stdout,'(a)')' initfile = '//trim(initfile) + write(stdout,'(a, 2x, f10.3)')' dtcfl = ',dtcfl + write(stdout,'(a, 2x, f10.3)')' dtcfli = ',dtcfli + write(stdout,'(a, 2x, f10.3)')' dtmax = ',dtmax + write(stdout,'(a, 2x, f10.3)')' dtmin = ',dtmin + write(stdout,*) end if ! ESMF does not have a broadcast for chars call mpi_bcast(initfile, len(initfile), MPI_CHARACTER, 0, mpi_comm, ierr) if (ierr /= MPI_SUCCESS) then - call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for initfile ', & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for initfile ', & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return end if call mpi_bcast(dtcfl, 1, MPI_INTEGER, 0, mpi_comm, ierr) if (ierr /= MPI_SUCCESS) then - call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for dtcfl ',& - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for dtcfl ',& + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return end if call mpi_bcast(dtcfli, 1, MPI_INTEGER, 0, mpi_comm, ierr) if (ierr /= MPI_SUCCESS) then - call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for dtcfli ',& - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for dtcfli ',& + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return end if call mpi_bcast(dtmax, 1, MPI_INTEGER, 0, mpi_comm, ierr) if (ierr /= MPI_SUCCESS) then - call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for dtmax ',& - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for dtmax ',& + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return end if call mpi_bcast(dtmin, 1, MPI_INTEGER, 0, mpi_comm, ierr) if (ierr /= MPI_SUCCESS) then - call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for dtmax ',& - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for dtmax ',& + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return end if dtmax_in = dtmax dtcfl_in = dtcfl @@ -1444,16 +1451,16 @@ subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, mds, rc) ! Currently IC4 is used in cesm inflags2(:) = .false. if (wav_coupling_to_cice) then - inflags2(4) = .true. ! inflags2(4) is true if ice concentration was read during initialization - inflags1(-7) = .true. ! ice thickness - inflags2(-7) = .true. ! ice thickness - inflags1(-3) = .true. ! ice floe size - inflags2(-3) = .true. ! ice floe size + inflags2(4) = .true. ! inflags2(4) is true if ice concentration was read during initialization + inflags1(-7) = .true. ! ice thickness + inflags2(-7) = .true. ! ice thickness + inflags1(-3) = .true. ! ice floe size + inflags2(-3) = .true. ! ice floe size else - inflags1(-7) = .false. ! ice thickness - inflags2(-7) = .false. ! ice thickness - inflags1(-3) = .false. ! ice floe size - inflags2(-3) = .false. ! ice floe size + inflags1(-7) = .false. ! ice thickness + inflags2(-7) = .false. ! ice thickness + inflags1(-3) = .false. ! ice floe size + inflags2(-3) = .false. ! ice floe size end if ! custom restart and history file names are used for CESM @@ -1462,11 +1469,11 @@ subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, mds, rc) ! if runtype=initial, the initfile will be read in w3iorsmd if (len_trim(inst_suffix) > 0) then - user_restfname = trim(casename)//'.ww3'//trim(inst_suffix)//'.r.' - user_histfname = trim(casename)//'.ww3'//trim(inst_suffix)//'.hi.' + user_restfname = trim(casename)//'.ww3'//trim(inst_suffix)//'.r.' + user_histfname = trim(casename)//'.ww3'//trim(inst_suffix)//'.hi.' else - user_restfname = trim(casename)//'.ww3.r.' - user_histfname = trim(casename)//'.ww3.hi.' + user_restfname = trim(casename)//'.ww3.r.' + user_histfname = trim(casename)//'.ww3.hi.' endif ! netcdf gridded output is used for CESM @@ -1541,7 +1548,7 @@ subroutine waveinit_ufs( gcomp, ntrace, mpi_comm, mds, rc) call NUOPC_CompAttributeGet(gcomp, name='user_sets_histname', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - use_user_histname=(trim(cvalue)=="true") + use_user_histname=(trim(cvalue)=="true") end if write(logmsg,'(A,l)') trim(subname)//': Custom history names in use ',use_user_histname call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) @@ -1549,7 +1556,7 @@ subroutine waveinit_ufs( gcomp, ntrace, mpi_comm, mds, rc) call NUOPC_CompAttributeGet(gcomp, name='user_sets_restname', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - use_user_restname=(trim(cvalue)=="true") + use_user_restname=(trim(cvalue)=="true") end if write(logmsg,'(A,l)') trim(subname)//': Custom restart names in use ',use_user_restname call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) @@ -1557,16 +1564,16 @@ subroutine waveinit_ufs( gcomp, ntrace, mpi_comm, mds, rc) call NUOPC_CompAttributeGet(gcomp, name='gridded_netcdfout', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - user_netcdf_grdout=(trim(cvalue)=="true") + user_netcdf_grdout=(trim(cvalue)=="true") end if write(logmsg,'(A,l)') trim(subname)//': Gridded netcdf output is requested ',user_netcdf_grdout call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) if (use_user_histname) then - user_histfname = trim(casename)//'.ww3.hi.' + user_histfname = trim(casename)//'.ww3.hi.' end if if (use_user_restname) then - user_restfname = trim(casename)//'.ww3.r.' + user_restfname = trim(casename)//'.ww3.r.' end if fnmpre = './' diff --git a/model/src/wav_grdout.F90 b/model/src/wav_grdout.F90 index 166802ad6..7e592e618 100644 --- a/model/src/wav_grdout.F90 +++ b/model/src/wav_grdout.F90 @@ -15,21 +15,21 @@ module wav_grdout ! tag read from inp file and is used to set flogrd flags ! var_name is the name of the variable type :: varatts - character(len= 5) :: tag - character(len=10) :: var_name - character(len=48) :: long_name - character(len=10) :: unit_name - character(len= 2) :: dims - logical :: validout - end type + character(len= 5) :: tag + character(len=10) :: var_name + character(len=48) :: long_name + character(len=10) :: unit_name + character(len= 2) :: dims + logical :: validout + end type varatts type(varatts), dimension(nogrp,maxvars) :: gridoutdefs type(varatts), dimension(:), allocatable :: outvars -!=============================================================================== + !=============================================================================== contains -!=============================================================================== + !=============================================================================== !==================================================================================== subroutine wavinit_grdout @@ -52,42 +52,42 @@ subroutine wavinit_grdout ! determine which variables are tagged for output do k = 1,nogrp - do j = 1,maxvars - if (len_trim(gridoutdefs(k,j)%tag) > 0) then - do n = 1,len(inptags) - if (len_trim(inptags(n)) > 0) then - if (trim(inptags(n)) == trim(gridoutdefs(k,j)%tag)) gridoutdefs(k,j)%validout = .true. - end if - end do - end if - end do + do j = 1,maxvars + if (len_trim(gridoutdefs(k,j)%tag) > 0) then + do n = 1,len(inptags) + if (len_trim(inptags(n)) > 0) then + if (trim(inptags(n)) == trim(gridoutdefs(k,j)%tag)) gridoutdefs(k,j)%validout = .true. + end if + end do + end if + end do end do ! remove requested variables which are only allocated if specific ! options are set in mod_def (see w3adatmd, '3D arrays') do k = 1,nogrp - do j = 1,maxvars - if (gridoutdefs(k,j)%validout) then - ttag = trim(gridoutdefs(k,j)%tag) - if (ttag == 'EF' .and. e3df(1,1) == 0) gridoutdefs(k,j)%validout = .false. - if (ttag == 'TH1M' .and. e3df(1,2) == 0) gridoutdefs(k,j)%validout = .false. - if (ttag == 'STH1M' .and. e3df(1,3) == 0) gridoutdefs(k,j)%validout = .false. - if (ttag == 'TH2M' .and. e3df(1,4) == 0) gridoutdefs(k,j)%validout = .false. - if (ttag == 'STH2M' .and. e3df(1,5) == 0) gridoutdefs(k,j)%validout = .false. - - if (ttag == 'P2L' .and. p2msf(1) == 0) gridoutdefs(k,j)%validout = .false. - if (ttag == 'USF' .and. us3df(1) == 0) gridoutdefs(k,j)%validout = .false. - if (ttag == 'USP' .and. usspf(1) == 0) gridoutdefs(k,j)%validout = .false. - end if - end do - end do + do j = 1,maxvars + if (gridoutdefs(k,j)%validout) then + ttag = trim(gridoutdefs(k,j)%tag) + if (ttag == 'EF' .and. e3df(1,1) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'TH1M' .and. e3df(1,2) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'STH1M' .and. e3df(1,3) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'TH2M' .and. e3df(1,4) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'STH2M' .and. e3df(1,5) == 0) gridoutdefs(k,j)%validout = .false. + + if (ttag == 'P2L' .and. p2msf(1) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'USF' .and. us3df(1) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'USP' .and. usspf(1) == 0) gridoutdefs(k,j)%validout = .false. + end if + end do + end do ! determine number of output variables (not the same as the number of tags) n = 0 do k = 1,nogrp - do j = 1,maxvars - if (gridoutdefs(k,j)%validout) n = n+1 - end do + do j = 1,maxvars + if (gridoutdefs(k,j)%validout) n = n+1 + end do end do nout = n allocate(outvars(1:nout)) @@ -95,27 +95,27 @@ subroutine wavinit_grdout ! subset variables requested n = 0 do k = 1,nogrp - do j = 1,maxvars - if (gridoutdefs(k,j)%validout) then - n = n+1 - outvars(n) = gridoutdefs(k,j) - end if - enddo + do j = 1,maxvars + if (gridoutdefs(k,j)%validout) then + n = n+1 + outvars(n) = gridoutdefs(k,j) + end if + enddo end do ! check if ( iaproc == napout ) then - write(nds(1),*) - write(nds(1),'(a)')' --------------------------------------------------' - write(nds(1),'(a)')' Requested gridded output variables : ' - write(nds(1),'(a)')' --------------------------------------------------' - write(nds(1),*) - do n = 1,nout - write(nds(1),'(i5,2a12,a50)')n,' '//trim(outvars(n)%tag), & - ' '//trim(outvars(n)%var_name), & - ' '//trim(outvars(n)%long_name) - end do - write(nds(1),*) + write(nds(1),*) + write(nds(1),'(a)')' --------------------------------------------------' + write(nds(1),'(a)')' Requested gridded output variables : ' + write(nds(1),'(a)')' --------------------------------------------------' + write(nds(1),*) + do n = 1,nout + write(nds(1),'(i5,2a12,a50)')n,' '//trim(outvars(n)%tag), & + ' '//trim(outvars(n)%var_name), & + ' '//trim(outvars(n)%long_name) + end do + write(nds(1),*) end if end subroutine wavinit_grdout @@ -133,162 +133,162 @@ subroutine initialize_gridout ! TODO: confirm unit values ! 1 Forcing Fields gridoutdefs(1,1:14) = [ & - varatts( "DPT ", "DW ", "Water depth ", "m ", " ", .false.) , & - varatts( "CUR ", "CX ", "Mean current, x-component ", "m s-1 ", " ", .false.) , & - varatts( "CUR ", "CY ", "Mean current, y-component ", "m s-1 ", " ", .false.) , & - varatts( "WND ", "UAX ", "Mean wind, x-component ", "m s-1 ", " ", .false.) , & - varatts( "WND ", "UAY ", "Mean wind, y-component ", "m s-1 ", " ", .false.) , & - varatts( "AST ", "AS ", "Air-sea temperature difference ", "K ", " ", .false.) , & - varatts( "WLV ", "WLV ", "Water levels ", "m ", " ", .false.) , & - varatts( "ICE ", "ICE ", "Ice coverage ", "nd ", " ", .false.) , & - varatts( "IBG ", "BERG ", "Iceberg-induced damping ", "km-1 ", " ", .false.) , & - varatts( "TAUA ", "TAUAX ", "Atm momentum x ", "Pa ", " ", .false.) , & - varatts( "TAUA ", "TAUAY ", "Atm momentum y ", "Pa ", " ", .false.) , & - varatts( "RHO ", "RHOAIR ", "Air density ", "kg m-3 ", " ", .false.) , & - varatts( "IC1 ", "ICEH ", "Ice thickness ", "m ", " ", .false.) , & - varatts( "IC5 ", "ICEF ", "Ice floe diameter ", "m ", " ", .false.) & - ] + varatts( "DPT ", "DW ", "Water depth ", "m ", " ", .false.) , & + varatts( "CUR ", "CX ", "Mean current, x-component ", "m s-1 ", " ", .false.) , & + varatts( "CUR ", "CY ", "Mean current, y-component ", "m s-1 ", " ", .false.) , & + varatts( "WND ", "UAX ", "Mean wind, x-component ", "m s-1 ", " ", .false.) , & + varatts( "WND ", "UAY ", "Mean wind, y-component ", "m s-1 ", " ", .false.) , & + varatts( "AST ", "AS ", "Air-sea temperature difference ", "K ", " ", .false.) , & + varatts( "WLV ", "WLV ", "Water levels ", "m ", " ", .false.) , & + varatts( "ICE ", "ICE ", "Ice coverage ", "nd ", " ", .false.) , & + varatts( "IBG ", "BERG ", "Iceberg-induced damping ", "km-1 ", " ", .false.) , & + varatts( "TAUA ", "TAUAX ", "Atm momentum x ", "Pa ", " ", .false.) , & + varatts( "TAUA ", "TAUAY ", "Atm momentum y ", "Pa ", " ", .false.) , & + varatts( "RHO ", "RHOAIR ", "Air density ", "kg m-3 ", " ", .false.) , & + varatts( "IC1 ", "ICEH ", "Ice thickness ", "m ", " ", .false.) , & + varatts( "IC5 ", "ICEF ", "Ice floe diameter ", "m ", " ", .false.) & + ] ! 2 Standard mean wave Parameters gridoutdefs(2,1:18) = [ & - varatts( "HS ", "HS ", "Significant wave height ", "m ", " ", .false.) , & - varatts( "LM ", "WLM ", "Mean wave length ", "m ", " ", .false.) , & - varatts( "T02 ", "T02 ", "Mean wave period (Tm0,2) ", "s ", " ", .false.) , & - varatts( "T0M1 ", "T0M1 ", "Mean wave period (Tm0,-1) ", "s ", " ", .false.) , & - varatts( "T01 ", "T01 ", "Mean wave period (Tm0,1) ", "s ", " ", .false.) , & - varatts( "FP ", "FP0 ", "Peak frequency ", "s-1 ", " ", .false.) , & - varatts( "DIR ", "THM ", "Mean wave direction ", "rad ", " ", .false.) , & - varatts( "SPR ", "THS ", "Mean directional spread ", "rad ", " ", .false.) , & - varatts( "DP ", "THP0 ", "Peak direction ", "rad ", " ", .false.) , & - varatts( "HIG ", "HSIG ", "Infragravity height ", "m ", " ", .false.) , & - varatts( "MXE ", "STMAXE ", "Max surface elev (STE) ", "m ", " ", .false.) , & - varatts( "MXES ", "STMAXD ", "St Dev Max surface elev (STE) ", "m ", " ", .false.) , & - varatts( "MXH ", "HMAXE ", "Max wave height (S.) ", "m ", " ", .false.) , & - varatts( "MXHC ", "HCMAXE ", "Max wave height from crest (STE) ", "m ", " ", .false.) , & - varatts( "SDMH ", "HMAXD ", "St Dev of MXC (STE) ", "m ", " ", .false.) , & - varatts( "SDMHC", "HCMAXD ", "St Dev of MXHC (STE) ", "m ", " ", .false.) , & - varatts( "WBT ", "WBT ", "Dominant wave breaking probability (b_T) ", "nd ", " ", .false.) , & - varatts( "WNM ", "WNMEAN ", "Mean wave number ", "m-1 ", " ", .false.) & - ] + varatts( "HS ", "HS ", "Significant wave height ", "m ", " ", .false.) , & + varatts( "LM ", "WLM ", "Mean wave length ", "m ", " ", .false.) , & + varatts( "T02 ", "T02 ", "Mean wave period (Tm0,2) ", "s ", " ", .false.) , & + varatts( "T0M1 ", "T0M1 ", "Mean wave period (Tm0,-1) ", "s ", " ", .false.) , & + varatts( "T01 ", "T01 ", "Mean wave period (Tm0,1) ", "s ", " ", .false.) , & + varatts( "FP ", "FP0 ", "Peak frequency ", "s-1 ", " ", .false.) , & + varatts( "DIR ", "THM ", "Mean wave direction ", "rad ", " ", .false.) , & + varatts( "SPR ", "THS ", "Mean directional spread ", "rad ", " ", .false.) , & + varatts( "DP ", "THP0 ", "Peak direction ", "rad ", " ", .false.) , & + varatts( "HIG ", "HSIG ", "Infragravity height ", "m ", " ", .false.) , & + varatts( "MXE ", "STMAXE ", "Max surface elev (STE) ", "m ", " ", .false.) , & + varatts( "MXES ", "STMAXD ", "St Dev Max surface elev (STE) ", "m ", " ", .false.) , & + varatts( "MXH ", "HMAXE ", "Max wave height (S.) ", "m ", " ", .false.) , & + varatts( "MXHC ", "HCMAXE ", "Max wave height from crest (STE) ", "m ", " ", .false.) , & + varatts( "SDMH ", "HMAXD ", "St Dev of MXC (STE) ", "m ", " ", .false.) , & + varatts( "SDMHC", "HCMAXD ", "St Dev of MXHC (STE) ", "m ", " ", .false.) , & + varatts( "WBT ", "WBT ", "Dominant wave breaking probability (b_T) ", "nd ", " ", .false.) , & + varatts( "WNM ", "WNMEAN ", "Mean wave number ", "m-1 ", " ", .false.) & + ] ! 3 Spectral Parameters gridoutdefs(3,1:6) = [ & - varatts( "EF ", "EF ", "1D spectral density ", "m2 s ", "k ", .false.) , & - varatts( "TH1M ", "TH1M ", "Mean wave direction from a1,b2 ", "deg ", "k ", .false.) , & - varatts( "STH1M", "STH1M ", "Directional spreading from a1,b2 ", "deg ", "k ", .false.) , & - varatts( "TH2M ", "TH2M ", "Mean wave direction from a2,b2 ", "deg ", "k ", .false.) , & - varatts( "STH2M", "STH2M ", "Directional spreading from a2,b2 ", "deg ", "k ", .false.) , & - !TODO: has reverse indices (nk,nsea) - varatts( "WN ", "WN ", "Wavenumber array ", "m-1 ", "k ", .false.) & - ] + varatts( "EF ", "EF ", "1D spectral density ", "m2 s ", "k ", .false.) , & + varatts( "TH1M ", "TH1M ", "Mean wave direction from a1,b2 ", "deg ", "k ", .false.) , & + varatts( "STH1M", "STH1M ", "Directional spreading from a1,b2 ", "deg ", "k ", .false.) , & + varatts( "TH2M ", "TH2M ", "Mean wave direction from a2,b2 ", "deg ", "k ", .false.) , & + varatts( "STH2M", "STH2M ", "Directional spreading from a2,b2 ", "deg ", "k ", .false.) , & + !TODO: has reverse indices (nk,nsea) + varatts( "WN ", "WN ", "Wavenumber array ", "m-1 ", "k ", .false.) & + ] ! 4 Spectral Partition Parameters gridoutdefs(4,1:17) = [ & - varatts( "PHS ", "PHS ", "Partitioned wave heights ", "m ", "s ", .false.) , & - varatts( "PTP ", "PTP ", "Partitioned peak period ", "s ", "s ", .false.) , & - varatts( "PLP ", "PLP ", "Partitioned peak wave length ", "m ", "s ", .false.) , & - varatts( "PDIR ", "PDIR ", "Partitioned mean direction ", "deg ", "s ", .false.) , & - varatts( "PSPR ", "PSI ", "Partitioned mean directional spread ", "deg ", "s ", .false.) , & - varatts( "PWS ", "PWS ", "Partitioned wind sea fraction ", "nd ", "s ", .false.) , & - varatts( "PDP ", "PTHP0 ", "Peak wave direction of partition ", "deg ", "s ", .false.) , & - varatts( "PQP ", "PQP ", "Goda peakdedness parameter of partition ", "nd ", "s ", .false.) , & - varatts( "PPE ", "PPE ", "JONSWAP peak enhancement factor of partition ", "s-1 ", "s ", .false.) , & - varatts( "PGW ", "PGW ", "Gaussian frequency width of partition ", "nd ", "s ", .false.) , & - varatts( "PSW ", "PSW ", "Spectral width of partition ", "nd ", "s ", .false.) , & - varatts( "PTM10", "PTM1 ", "Mean wave period (m-1,0) of partition ", "s ", "s ", .false.) , & - varatts( "PT01 ", "PT1 ", "Mean wave period (m0,1) of partition ", "s ", "s ", .false.) , & - varatts( "PT02 ", "PT2 ", "Mean wave period (m0,2) of partition ", "s ", "s ", .false.) , & - varatts( "PEP ", "PEP ", "Peak spectral density of partition ", "m2 s rad-1", "s ", .false.) , & - varatts( "TWS ", "PWST ", "Total wind sea fraction ", "nd ", " ", .false.) , & - varatts( "PNR ", "PNR ", "Number of partitions ", "nd ", " ", .false.) & - ] + varatts( "PHS ", "PHS ", "Partitioned wave heights ", "m ", "s ", .false.) , & + varatts( "PTP ", "PTP ", "Partitioned peak period ", "s ", "s ", .false.) , & + varatts( "PLP ", "PLP ", "Partitioned peak wave length ", "m ", "s ", .false.) , & + varatts( "PDIR ", "PDIR ", "Partitioned mean direction ", "deg ", "s ", .false.) , & + varatts( "PSPR ", "PSI ", "Partitioned mean directional spread ", "deg ", "s ", .false.) , & + varatts( "PWS ", "PWS ", "Partitioned wind sea fraction ", "nd ", "s ", .false.) , & + varatts( "PDP ", "PTHP0 ", "Peak wave direction of partition ", "deg ", "s ", .false.) , & + varatts( "PQP ", "PQP ", "Goda peakdedness parameter of partition ", "nd ", "s ", .false.) , & + varatts( "PPE ", "PPE ", "JONSWAP peak enhancement factor of partition ", "s-1 ", "s ", .false.) , & + varatts( "PGW ", "PGW ", "Gaussian frequency width of partition ", "nd ", "s ", .false.) , & + varatts( "PSW ", "PSW ", "Spectral width of partition ", "nd ", "s ", .false.) , & + varatts( "PTM10", "PTM1 ", "Mean wave period (m-1,0) of partition ", "s ", "s ", .false.) , & + varatts( "PT01 ", "PT1 ", "Mean wave period (m0,1) of partition ", "s ", "s ", .false.) , & + varatts( "PT02 ", "PT2 ", "Mean wave period (m0,2) of partition ", "s ", "s ", .false.) , & + varatts( "PEP ", "PEP ", "Peak spectral density of partition ", "m2 s rad-1", "s ", .false.) , & + varatts( "TWS ", "PWST ", "Total wind sea fraction ", "nd ", " ", .false.) , & + varatts( "PNR ", "PNR ", "Number of partitions ", "nd ", " ", .false.) & + ] ! 5 Atmosphere-waves layer gridoutdefs(5,1:14) = [ & - varatts( "UST ", "USTX ", "Friction velocity x ", "m s-1 ", " ", .false.) , & - varatts( "UST ", "USTY ", "Friction velocity y ", "m s-1 ", " ", .false.) , & - varatts( "CHA ", "CHARN ", "Charnock parameter ", "nd ", " ", .false.) , & - varatts( "CGE ", "CGE ", "Energy flux ", "kW m-1 ", " ", .false.) , & - varatts( "FAW ", "PHIAW ", "Air-sea energy flux ", "W m-2 ", " ", .false.) , & - varatts( "TAW ", "TAUWIX ", "Net wave-supported stress x ", "m2 s-2 ", " ", .false.) , & - varatts( "TAW ", "TAUWIY ", "Net wave-supported stress y ", "m2 s-2 ", " ", .false.) , & - varatts( "TWA ", "TAUWNX ", "Negative part of the wave-supported stress x ", "m2 s-2 ", " ", .false.) , & - varatts( "TWA ", "TAUWNY ", "Negative part of the wave-supported stress y ", "m2 s-2 ", " ", .false.) , & - varatts( "WCC ", "WCC ", "Whitecap coverage ", "nd ", " ", .false.) , & - varatts( "WCF ", "WCF ", "Whitecap foam thickness ", "m ", " ", .false.) , & - varatts( "WCH ", "WCH ", "Mean breaking wave heigh ", "m ", " ", .false.) , & - varatts( "WCM ", "WCM ", "Whitecap moment ", "nd ", " ", .false.) , & - varatts( "FWS ", "TWS ", "Wind sea mean period ", "s ", " ", .false.) & - ] + varatts( "UST ", "USTX ", "Friction velocity x ", "m s-1 ", " ", .false.) , & + varatts( "UST ", "USTY ", "Friction velocity y ", "m s-1 ", " ", .false.) , & + varatts( "CHA ", "CHARN ", "Charnock parameter ", "nd ", " ", .false.) , & + varatts( "CGE ", "CGE ", "Energy flux ", "kW m-1 ", " ", .false.) , & + varatts( "FAW ", "PHIAW ", "Air-sea energy flux ", "W m-2 ", " ", .false.) , & + varatts( "TAW ", "TAUWIX ", "Net wave-supported stress x ", "m2 s-2 ", " ", .false.) , & + varatts( "TAW ", "TAUWIY ", "Net wave-supported stress y ", "m2 s-2 ", " ", .false.) , & + varatts( "TWA ", "TAUWNX ", "Negative part of the wave-supported stress x ", "m2 s-2 ", " ", .false.) , & + varatts( "TWA ", "TAUWNY ", "Negative part of the wave-supported stress y ", "m2 s-2 ", " ", .false.) , & + varatts( "WCC ", "WCC ", "Whitecap coverage ", "nd ", " ", .false.) , & + varatts( "WCF ", "WCF ", "Whitecap foam thickness ", "m ", " ", .false.) , & + varatts( "WCH ", "WCH ", "Mean breaking wave heigh ", "m ", " ", .false.) , & + varatts( "WCM ", "WCM ", "Whitecap moment ", "nd ", " ", .false.) , & + varatts( "FWS ", "TWS ", "Wind sea mean period ", "s ", " ", .false.) & + ] ! 6 Wave-ocean layer gridoutdefs(6,1:24) = [ & - varatts( "SXY ", "SXX ", "Radiation stresses xx ", "N m-1 ", " ", .false.) , & - varatts( "SXY ", "SYY ", "Radiation stresses yy ", "N m-1 ", " ", .false.) , & - varatts( "SXY ", "SXY ", "Radiation stresses xy ", "N m-1 ", " ", .false.) , & - varatts( "TWO ", "TAUOX ", "Wave to ocean momentum flux x ", "m2 s-2 ", " ", .false.) , & - varatts( "TWO ", "TAUOY ", "Wave to ocean momentum flux y ", "m2 s-2 ", " ", .false.) , & - varatts( "BHD ", "BHD ", "Bernoulli head (J term) ", "m2 s-2 ", " ", .false.) , & - varatts( "FOC ", "PHIOC ", "Wave to ocean energy flux ", "W m-2 ", " ", .false.) , & - varatts( "TUS ", "TUSX ", "Stokes transport x ", "m2 s-1 ", " ", .false.) , & - varatts( "TUS ", "TUSY ", "Stokes transport y ", "m2 s-1 ", " ", .false.) , & - varatts( "USS ", "USSX ", "Surface Stokes drift x ", "m s-1 ", " ", .false.) , & - varatts( "USS ", "USSY ", "Surface Stokes drift y ", "m s-1 ", " ", .false.) , & - varatts( "P2S ", "PRMS ", "Second-order sum pressure ", "m4 ", " ", .false.) , & - varatts( "P2S ", "TPMS ", "Second-order sum pressure ", "s-1 ", " ", .false.) , & - varatts( "USF ", "US3DX ", "Spectrum of surface Stokes drift x ", "m s-1 Hz-1", "k ", .false.) , & - varatts( "USF ", "US3DY ", "Spectrum of surface Stokes drift y ", "m s-1 Hz-1", "k ", .false.) , & - varatts( "P2L ", "P2SMS ", "Micro seism source term ", "Pa2 m2 s ", "m ", .false.) , & - varatts( "TWI ", "TAUICEX ", "Wave to sea ice stress x ", "m2 s-2 ", " ", .false.) , & - varatts( "TWI ", "TAUICEY ", "Wave to sea ice stress y ", "m2 s-2 ", " ", .false.) , & - varatts( "FIC ", "PHICE ", "Wave to sea ice energy flux ", "W m-2 ", " ", .false.) , & - varatts( "USP ", "USSPX ", "Partitioned surface Stokes drift x ", "m s-1 ", "p ", .false.) , & - varatts( "USP ", "USSPY ", "Partitioned surface Stokes drift y ", "m s-1 ", "p ", .false.) , & - varatts( "TWC ", "TAUOCX ", "Total wave to ocean stress x ", "Pa ", " ", .false.) , & - varatts( "TWC ", "TAUOCY ", "Total wave to ocean stress y ", "Pa ", " ", .false.) , & - varatts( "LAN ", "LANGMT ", "Turbulent Langmuir number (La_t) ", "nd ", " ", .false.) & - ] + varatts( "SXY ", "SXX ", "Radiation stresses xx ", "N m-1 ", " ", .false.) , & + varatts( "SXY ", "SYY ", "Radiation stresses yy ", "N m-1 ", " ", .false.) , & + varatts( "SXY ", "SXY ", "Radiation stresses xy ", "N m-1 ", " ", .false.) , & + varatts( "TWO ", "TAUOX ", "Wave to ocean momentum flux x ", "m2 s-2 ", " ", .false.) , & + varatts( "TWO ", "TAUOY ", "Wave to ocean momentum flux y ", "m2 s-2 ", " ", .false.) , & + varatts( "BHD ", "BHD ", "Bernoulli head (J term) ", "m2 s-2 ", " ", .false.) , & + varatts( "FOC ", "PHIOC ", "Wave to ocean energy flux ", "W m-2 ", " ", .false.) , & + varatts( "TUS ", "TUSX ", "Stokes transport x ", "m2 s-1 ", " ", .false.) , & + varatts( "TUS ", "TUSY ", "Stokes transport y ", "m2 s-1 ", " ", .false.) , & + varatts( "USS ", "USSX ", "Surface Stokes drift x ", "m s-1 ", " ", .false.) , & + varatts( "USS ", "USSY ", "Surface Stokes drift y ", "m s-1 ", " ", .false.) , & + varatts( "P2S ", "PRMS ", "Second-order sum pressure ", "m4 ", " ", .false.) , & + varatts( "P2S ", "TPMS ", "Second-order sum pressure ", "s-1 ", " ", .false.) , & + varatts( "USF ", "US3DX ", "Spectrum of surface Stokes drift x ", "m s-1 Hz-1", "k ", .false.) , & + varatts( "USF ", "US3DY ", "Spectrum of surface Stokes drift y ", "m s-1 Hz-1", "k ", .false.) , & + varatts( "P2L ", "P2SMS ", "Micro seism source term ", "Pa2 m2 s ", "m ", .false.) , & + varatts( "TWI ", "TAUICEX ", "Wave to sea ice stress x ", "m2 s-2 ", " ", .false.) , & + varatts( "TWI ", "TAUICEY ", "Wave to sea ice stress y ", "m2 s-2 ", " ", .false.) , & + varatts( "FIC ", "PHICE ", "Wave to sea ice energy flux ", "W m-2 ", " ", .false.) , & + varatts( "USP ", "USSPX ", "Partitioned surface Stokes drift x ", "m s-1 ", "p ", .false.) , & + varatts( "USP ", "USSPY ", "Partitioned surface Stokes drift y ", "m s-1 ", "p ", .false.) , & + varatts( "TWC ", "TAUOCX ", "Total wave to ocean stress x ", "Pa ", " ", .false.) , & + varatts( "TWC ", "TAUOCY ", "Total wave to ocean stress y ", "Pa ", " ", .false.) , & + varatts( "LAN ", "LANGMT ", "Turbulent Langmuir number (La_t) ", "nd ", " ", .false.) & + ] ! 7 Wave-bottom layer gridoutdefs(7,1:10) = [ & - varatts( "ABR ", "ABAX ", "Near bottom rms wave excursion amplitudes x ", "m ", " ", .false.) , & - varatts( "ABR ", "ABAY ", "Near bottom rms wave excursion amplitudes y ", "m ", " ", .false.) , & - varatts( "UBR ", "UBAX ", "Near bottom rms wave velocities x ", "m s-1 ", " ", .false.) , & - varatts( "UBR ", "UBAY ", "Near bottom rms wave velocities y ", "m s-1 ", " ", .false.) , & - varatts( "BED ", "BED ", "Bottom roughness ", "m ", " ", .false.) , & - varatts( "BED ", "RIPPLEX ", "Sea bottom ripple wavelength x ", "m ", " ", .false.) , & - varatts( "BED ", "RIPPLEY ", "Sea bottom ripple wavelength y ", "m ", " ", .false.) , & - varatts( "FBB ", "PHIBBL ", "Energy flux due to bottom friction ", "W m-2 ", " ", .false.) , & - varatts( "TBB ", "TAUBBLX ", "Momentum flux due to bottom friction x ", "m2 s-2 ", " ", .false.) , & - varatts( "TBB ", "TAUBBLY ", "Momentum flux due to bottom friction y ", "m2 s-2 ", " ", .false.) & - ] + varatts( "ABR ", "ABAX ", "Near bottom rms wave excursion amplitudes x ", "m ", " ", .false.) , & + varatts( "ABR ", "ABAY ", "Near bottom rms wave excursion amplitudes y ", "m ", " ", .false.) , & + varatts( "UBR ", "UBAX ", "Near bottom rms wave velocities x ", "m s-1 ", " ", .false.) , & + varatts( "UBR ", "UBAY ", "Near bottom rms wave velocities y ", "m s-1 ", " ", .false.) , & + varatts( "BED ", "BED ", "Bottom roughness ", "m ", " ", .false.) , & + varatts( "BED ", "RIPPLEX ", "Sea bottom ripple wavelength x ", "m ", " ", .false.) , & + varatts( "BED ", "RIPPLEY ", "Sea bottom ripple wavelength y ", "m ", " ", .false.) , & + varatts( "FBB ", "PHIBBL ", "Energy flux due to bottom friction ", "W m-2 ", " ", .false.) , & + varatts( "TBB ", "TAUBBLX ", "Momentum flux due to bottom friction x ", "m2 s-2 ", " ", .false.) , & + varatts( "TBB ", "TAUBBLY ", "Momentum flux due to bottom friction y ", "m2 s-2 ", " ", .false.) & + ] ! 8 Spectrum parameters gridoutdefs(8,1:9) = [ & - varatts( "MSS ", "MSSX ", "Surface mean square slope x ", "nd ", " ", .false.) , & - varatts( "MSS ", "MSSY ", "Surface mean square slope y ", "nd ", " ", .false.) , & - varatts( "MSC ", "MSCX ", "Spectral level at high frequency tail x ", "nd ", " ", .false.) , & - varatts( "MSC ", "MSCY ", "Spectral level at high frequency tail y ", "nd ", " ", .false.) , & - varatts( "WL02 ", "WL02X ", "East/X North/Y mean wavelength component ", "nd ", " ", .false.) , & - varatts( "WL02 ", "WL02Y ", "East/X North/Y mean wavelength component ", "nd ", " ", .false.) , & - varatts( "AXT ", "ALPXT ", "Correl sea surface gradients (x,t) ", "nd ", " ", .false.) , & - varatts( "AYT ", "ALPYT ", "Correl sea surface gradients (y,t) ", "nd ", " ", .false.) , & - varatts( "AXY ", "ALPXY ", "Correl sea surface gradients (x,y) ", "nd ", " ", .false.) & - ] + varatts( "MSS ", "MSSX ", "Surface mean square slope x ", "nd ", " ", .false.) , & + varatts( "MSS ", "MSSY ", "Surface mean square slope y ", "nd ", " ", .false.) , & + varatts( "MSC ", "MSCX ", "Spectral level at high frequency tail x ", "nd ", " ", .false.) , & + varatts( "MSC ", "MSCY ", "Spectral level at high frequency tail y ", "nd ", " ", .false.) , & + varatts( "WL02 ", "WL02X ", "East/X North/Y mean wavelength component ", "nd ", " ", .false.) , & + varatts( "WL02 ", "WL02Y ", "East/X North/Y mean wavelength component ", "nd ", " ", .false.) , & + varatts( "AXT ", "ALPXT ", "Correl sea surface gradients (x,t) ", "nd ", " ", .false.) , & + varatts( "AYT ", "ALPYT ", "Correl sea surface gradients (y,t) ", "nd ", " ", .false.) , & + varatts( "AXY ", "ALPXY ", "Correl sea surface gradients (x,y) ", "nd ", " ", .false.) & + ] ! 9 Numerical diagnostics gridoutdefs(9,1:5) = [ & - varatts( "DTD ", "DTDYN ", "Average time step in integration ", "min ", " ", .false.) , & - varatts( "FC ", "FCUT ", "Cut-off frequency ", "s-1 ", " ", .false.) , & - varatts( "CFX ", "CFLXYMAX ", "Max. CFL number for spatial advection ", "nd ", " ", .false.) , & - varatts( "CFD ", "CFLTHMAX ", "Max. CFL number for theta-advection ", "nd ", " ", .false.) , & - varatts( "CFK ", "CFLKMAX ", "Max. CFL number for k-advection ", "nd ", " ", .false.) & - ] + varatts( "DTD ", "DTDYN ", "Average time step in integration ", "min ", " ", .false.) , & + varatts( "FC ", "FCUT ", "Cut-off frequency ", "s-1 ", " ", .false.) , & + varatts( "CFX ", "CFLXYMAX ", "Max. CFL number for spatial advection ", "nd ", " ", .false.) , & + varatts( "CFD ", "CFLTHMAX ", "Max. CFL number for theta-advection ", "nd ", " ", .false.) , & + varatts( "CFK ", "CFLKMAX ", "Max. CFL number for k-advection ", "nd ", " ", .false.) & + ] ! 10 User defined gridoutdefs(10,1:2) = [ & - varatts( "U1 ", "U1 ", "User defined 1 ", "nd ", " ", .false.) , & - varatts( "U2 ", "U2 ", "User defined 2 ", "nd ", " ", .false.) & - ] + varatts( "U1 ", "U1 ", "User defined 1 ", "nd ", " ", .false.) , & + varatts( "U2 ", "U2 ", "User defined 2 ", "nd ", " ", .false.) & + ] end subroutine initialize_gridout end module wav_grdout diff --git a/model/src/wav_import_export.F90 b/model/src/wav_import_export.F90 index 068627acb..35d3e8d08 100644 --- a/model/src/wav_import_export.F90 +++ b/model/src/wav_import_export.F90 @@ -19,7 +19,7 @@ module wav_import_export use wav_shr_mod , only : ymd2date use wav_shr_mod , only : chkerr use wav_shr_mod , only : state_diagnose, state_reset, state_getfldptr, state_fldchk - use wav_shr_mod , only : wav_coupling_to_cice, merge_import, dbug_flag, multigrid + use wav_shr_mod , only : wav_coupling_to_cice, nwav_elev_spectrum, merge_import, dbug_flag, multigrid use constants , only : grav, tpi, dwat implicit none @@ -38,14 +38,14 @@ module wav_import_export private :: readfromfile !< @private read values from a file interface FillGlobalInput - module procedure fillglobal_with_import - module procedure fillglobal_with_merge_import - end interface - - type fld_list_type !< @private a structure for the list of fields - character(len=128) :: stdname !< a standard field name - integer :: ungridded_lbound = 0 !< the ungridded dimension lower bound - integer :: ungridded_ubound = 0 !< the ugridded dimension upper bound + module procedure fillglobal_with_import + module procedure fillglobal_with_merge_import + end interface FillGlobalInput + + type fld_list_type !< @private a structure for the list of fields + character(len=128) :: stdname !< a standard field name + integer :: ungridded_lbound = 0 !< the ungridded dimension lower bound + integer :: ungridded_ubound = 0 !< the ugridded dimension upper bound end type fld_list_type integer, parameter :: fldsMax = 100 !< the maximum allowed number of fields in a state @@ -62,30 +62,27 @@ module wav_import_export #else logical :: cesmcoupled = .false. !< logical defining a non-CESM use case (UWM) #endif - - integer, parameter :: nwav_elev_spectrum = 25 !< the size of the wave spectrum exported if coupling - !! waves to cice6 character(*),parameter :: u_FILE_u = & !< a character string for an ESMF log message __FILE__ -!=============================================================================== + !=============================================================================== contains -!=============================================================================== -!> Set up the list of exchanged field to be advertised -!! -!> @details Called by InitializAdvertise, a list of standard field names to or -!! from the wave model is created and then advertised in either the import or -!! export state. A field with name set by the configuration variable ScalarFieldName -!! and size of ScalarFieldCount is added to the list of fields in the export state -!! and is used by CMEPS to write mediator history and restart fields as 2D arrays -!! -!! @param importState an ESMF_State for the import -!! @param exportState an ESMF_State for the export -!! @param[in] flds_scalar_name the name of the scalar field -!! @param[out] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !=============================================================================== + !> Set up the list of exchanged field to be advertised + !! + !> @details Called by InitializAdvertise, a list of standard field names to or + !! from the wave model is created and then advertised in either the import or + !! export state. A field with name set by the configuration variable ScalarFieldName + !! and size of ScalarFieldCount is added to the list of fields in the export state + !! and is used by CMEPS to write mediator history and restart fields as 2D arrays + !! + !! @param importState an ESMF_State for the import + !! @param exportState an ESMF_State for the export + !! @param[in] flds_scalar_name the name of the scalar field + !! @param[out] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine advertise_fields(importState, ExportState, flds_scalar_name, rc) ! input/output variables type(ESMF_State) :: importState @@ -106,29 +103,29 @@ subroutine advertise_fields(importState, ExportState, flds_scalar_name, rc) ! Advertise import fields !-------------------------------- - !call fldlist_add(fldsToWav_num, fldsToWav, 'So_h' ) + !call fldlist_add(fldsToWav_num, fldsToWav, 'So_h' ) call fldlist_add(fldsToWav_num, fldsToWav, 'Si_ifrac' ) call fldlist_add(fldsToWav_num, fldsToWav, 'So_u' ) call fldlist_add(fldsToWav_num, fldsToWav, 'So_v' ) call fldlist_add(fldsToWav_num, fldsToWav, 'So_t' ) call fldlist_add(fldsToWav_num, fldsToWav, 'Sa_tbot' ) if (cesmcoupled) then - call fldlist_add(fldsToWav_num, fldsToWav, 'Sa_u' ) - call fldlist_add(fldsToWav_num, fldsToWav, 'Sa_v' ) - call fldlist_add(fldsToWav_num, fldsToWav, 'So_bldepth' ) + call fldlist_add(fldsToWav_num, fldsToWav, 'Sa_u' ) + call fldlist_add(fldsToWav_num, fldsToWav, 'Sa_v' ) + call fldlist_add(fldsToWav_num, fldsToWav, 'So_bldepth' ) else - call fldlist_add(fldsToWav_num, fldsToWav, 'Sa_u10m' ) - call fldlist_add(fldsToWav_num, fldsToWav, 'Sa_v10m' ) + call fldlist_add(fldsToWav_num, fldsToWav, 'Sa_u10m' ) + call fldlist_add(fldsToWav_num, fldsToWav, 'Sa_v10m' ) end if if (wav_coupling_to_cice) then - call fldlist_add(fldsToWav_num, fldsToWav, 'Si_thick' ) - call fldlist_add(fldsToWav_num, fldsToWav, 'Si_floediam') + call fldlist_add(fldsToWav_num, fldsToWav, 'Si_thick' ) + call fldlist_add(fldsToWav_num, fldsToWav, 'Si_floediam') end if do n = 1,fldsToWav_num - call NUOPC_Advertise(importState, standardName=fldsToWav(n)%stdname, & - TransferOfferGeomObject='will provide', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_Advertise(importState, standardName=fldsToWav(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end do !-------------------------------- @@ -137,20 +134,20 @@ subroutine advertise_fields(importState, ExportState, flds_scalar_name, rc) call fldlist_add(fldsFrWav_num, fldsFrWav, trim(flds_scalar_name)) if (cesmcoupled) then - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_lamult' ) - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_ustokes') - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_vstokes') + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_lamult' ) + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_ustokes') + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_vstokes') !call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_hstokes') - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_pstokes_x', ungridded_lbound=1, ungridded_ubound=3) - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_pstokes_y', ungridded_lbound=1, ungridded_ubound=3) + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_pstokes_x', ungridded_lbound=1, ungridded_ubound=3) + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_pstokes_y', ungridded_lbound=1, ungridded_ubound=3) else - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_z0') - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_ustokes1') - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_ustokes2') - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_ustokes3') - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_vstokes1') - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_vstokes2') - call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_vstokes3') + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_z0') + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_ustokes1') + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_ustokes2') + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_ustokes3') + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_vstokes1') + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_vstokes2') + call fldlist_add(fldsFrWav_num, fldsFrWav, 'Sw_vstokes3') end if ! AA TODO: In the above fldlist_add calls, we are passing hardcoded ungridded_ubound values (3) because, USSPF(2) @@ -158,14 +155,14 @@ subroutine advertise_fields(importState, ExportState, flds_scalar_name, rc) ! will be implemented soon based on receiving USSP and USSPF from the coupler instead of the mod_def file. This will ! also ensure compatibility with the ocean component since ocean will also receive these from the coupler. if (wav_coupling_to_cice) then - call fldlist_add(fldsFrWav_num, fldsFrWav, 'wave_elevation_spectrum', & - ungridded_lbound=1, ungridded_ubound=nwav_elev_spectrum) + call fldlist_add(fldsFrWav_num, fldsFrWav, 'wave_elevation_spectrum', & + ungridded_lbound=1, ungridded_ubound=nwav_elev_spectrum) end if do n = 1,fldsFrWav_num - call NUOPC_Advertise(exportState, standardName=fldsFrWav(n)%stdname, & - TransferOfferGeomObject='will provide', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_Advertise(exportState, standardName=fldsFrWav(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end do if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) @@ -173,19 +170,19 @@ subroutine advertise_fields(importState, ExportState, flds_scalar_name, rc) end subroutine advertise_fields !=============================================================================== -!> Realize the advertised fields -!! -!> @details Called by InitializeRealize, realize the advertised fields on the mesh -!! and set all initial values to zero -!! -!! @param gcomp an ESMF_GridComp object -!! @param mesh an ESMF_Mesh object -!! @param[in] flds_scalar_name the name of the scalar field -!! @param[in] flds_scalar_num the number of scalar fields -!! @param[out] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Realize the advertised fields + !! + !> @details Called by InitializeRealize, realize the advertised fields on the mesh + !! and set all initial values to zero + !! + !! @param gcomp an ESMF_GridComp object + !! @param mesh an ESMF_Mesh object + !! @param[in] flds_scalar_name the name of the scalar field + !! @param[in] flds_scalar_num the number of scalar fields + !! @param[out] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine realize_fields(gcomp, mesh, flds_scalar_name, flds_scalar_num, rc) ! input/output variables @@ -233,8 +230,8 @@ subroutine realize_fields(gcomp, mesh, flds_scalar_name, flds_scalar_num, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (dbug_flag > 5) then - call state_diagnose(exportState, 'after state_reset', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_diagnose(exportState, 'after state_reset', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) @@ -242,21 +239,21 @@ subroutine realize_fields(gcomp, mesh, flds_scalar_name, flds_scalar_num, rc) end subroutine realize_fields !=============================================================================== -!> Fill WW3 fields with values from the import state -!! -!> @details Called by ModelAdvance, a global field for each connected field is -!! created in SetGlobalInput and used to fill the internal WW3 global variables in -!! FillGlobalInput. Optionally, the WW3 field can be created by merging with a -!! provided field in cases where the WW3 model domain extends outside the source -!! domain -!! -!! @param[inout] gcomp an ESMF_GridComp object -!! @param[in] time0 the starting time of ModelAdvance -!! @param[in] timen the ending time of ModelAdvance -!! @param[out] rc return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Fill WW3 fields with values from the import state + !! + !> @details Called by ModelAdvance, a global field for each connected field is + !! created in SetGlobalInput and used to fill the internal WW3 global variables in + !! FillGlobalInput. Optionally, the WW3 field can be created by merging with a + !! provided field in cases where the WW3 model domain extends outside the source + !! domain + !! + !! @param[inout] gcomp an ESMF_GridComp object + !! @param[in] time0 the starting time of ModelAdvance + !! @param[in] timen the ending time of ModelAdvance + !! @param[out] rc return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine import_fields( gcomp, time0, timen, rc ) !--------------------------------------------------------------------------- @@ -307,11 +304,11 @@ subroutine import_fields( gcomp, time0, timen, rc ) if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) if (cesmcoupled) then - uwnd = 'Sa_u' - vwnd = 'Sa_v' + uwnd = 'Sa_u' + vwnd = 'Sa_v' else - uwnd = 'Sa_u10m' - vwnd = 'Sa_v10m' + uwnd = 'Sa_u10m' + vwnd = 'Sa_v10m' end if ! Get import state, clock and vm @@ -319,8 +316,8 @@ subroutine import_fields( gcomp, time0, timen, rc ) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (dbug_flag > 5) then - call state_diagnose(importState, 'at import ', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_diagnose(importState, 'at import ', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if ! input fields associated with W3FLDG calls in ww3_shel.ftn @@ -339,142 +336,142 @@ subroutine import_fields( gcomp, time0, timen, rc ) ! INFLAGS1(1) ! --------------- if (INFLAGS1(1)) then - TLN = timen - - WLEV(:,:) = def_value ! water level - if (state_fldchk(importState, 'So_h')) then - call SetGlobalInput(importState, 'So_h', vm, global_data, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FillGlobalInput(global_data, WLEV) - end if + TLN = timen + + WLEV(:,:) = def_value ! water level + if (state_fldchk(importState, 'So_h')) then + call SetGlobalInput(importState, 'So_h', vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FillGlobalInput(global_data, WLEV) + end if endif ! --------------- ! INFLAGS1(2) - ocn current fields ! --------------- if (INFLAGS1(2)) then - TC0 = time0 ! times for ocn current fields - TCN = timen - - CX0(:,:) = def_value ! ocn u current - CXN(:,:) = def_value - if (state_fldchk(importState, 'So_u')) then - call SetGlobalInput(importState, 'So_u', vm, global_data, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FillGlobalInput(global_data, CX0) - call FillGlobalInput(global_data, CXN) - end if - - CY0(:,:) = def_value ! ocn v current - CYN(:,:) = def_value - if (state_fldchk(importState, 'So_v')) then - call SetGlobalInput(importState, 'So_v', vm, global_data, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FillGlobalInput(global_data, CY0) - call FillGlobalInput(global_data, CYN) - end if + TC0 = time0 ! times for ocn current fields + TCN = timen + + CX0(:,:) = def_value ! ocn u current + CXN(:,:) = def_value + if (state_fldchk(importState, 'So_u')) then + call SetGlobalInput(importState, 'So_u', vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FillGlobalInput(global_data, CX0) + call FillGlobalInput(global_data, CXN) + end if + + CY0(:,:) = def_value ! ocn v current + CYN(:,:) = def_value + if (state_fldchk(importState, 'So_v')) then + call SetGlobalInput(importState, 'So_v', vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FillGlobalInput(global_data, CY0) + call FillGlobalInput(global_data, CYN) + end if end if ! --------------- ! INFLAGS1(3) - atm wind/temp fields ! --------------- if (INFLAGS1(3)) then - TW0 = time0 ! times for atm wind/temp fields. - TWN = timen - - if (merge_import) then - ! set mask using u-wind field if merge_import; assume all import fields - ! will have same missing overlap region - ! import_mask memory will be allocate in set_importmask - call set_importmask(importState, clock, trim(uwnd), vm, rc) + TW0 = time0 ! times for atm wind/temp fields. + TWN = timen + + if (merge_import) then + ! set mask using u-wind field if merge_import; assume all import fields + ! will have same missing overlap region + ! import_mask memory will be allocate in set_importmask + call set_importmask(importState, clock, trim(uwnd), vm, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(wxdata(nsea)) + allocate(wydata(nsea)) + call readfromfile('WND', wxdata, wydata, time0, timen, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (dbug_flag > 10) then + call check_globaldata(gcomp, 'wxdata', wxdata, nsea, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate(wxdata(nsea)) - allocate(wydata(nsea)) - call readfromfile('WND', wxdata, wydata, time0, timen, rc) + call check_globaldata(gcomp, 'wydata', wydata, nsea, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (dbug_flag > 10) then - call check_globaldata(gcomp, 'wxdata', wxdata, nsea, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call check_globaldata(gcomp, 'wydata', wydata, nsea, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call check_globaldata(gcomp, 'import_mask', import_mask, nsea, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - end if - - ! atm u wind - WX0(:,:) = def_value - WXN(:,:) = def_value - if (state_fldchk(importState, trim(uwnd))) then - call SetGlobalInput(importState, trim(uwnd), vm, global_data, rc) + call check_globaldata(gcomp, 'import_mask', import_mask, nsea, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (merge_import) then - call FillGlobalInput(global_data, import_mask, wxdata, WX0) - call FillGlobalInput(global_data, import_mask, wxdata, WXN) - if (dbug_flag > 10) then - call check_globaldata(gcomp, 'wx0', wx0, nx*ny, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - else - call FillGlobalInput(global_data, WX0) - call FillGlobalInput(global_data, WXN) + end if + end if + + ! atm u wind + WX0(:,:) = def_value + WXN(:,:) = def_value + if (state_fldchk(importState, trim(uwnd))) then + call SetGlobalInput(importState, trim(uwnd), vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (merge_import) then + call FillGlobalInput(global_data, import_mask, wxdata, WX0) + call FillGlobalInput(global_data, import_mask, wxdata, WXN) + if (dbug_flag > 10) then + call check_globaldata(gcomp, 'wx0', wx0, nx*ny, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - end if - - ! atm v wind - WY0(:,:) = def_value - WYN(:,:) = def_value - if (state_fldchk(importState, trim(vwnd))) then - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call SetGlobalInput(importState, trim(vwnd), vm, global_data, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (merge_import) then - call FillGlobalInput(global_data, import_mask, wydata, WY0) - call FillGlobalInput(global_data, import_mask, wydata, WYN) - if (dbug_flag > 10) then - call check_globaldata(gcomp, 'wy0', wy0, nx*ny, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - else - call FillGlobalInput(global_data, WY0) - call FillGlobalInput(global_data, WYN) + else + call FillGlobalInput(global_data, WX0) + call FillGlobalInput(global_data, WXN) + end if + end if + + ! atm v wind + WY0(:,:) = def_value + WYN(:,:) = def_value + if (state_fldchk(importState, trim(vwnd))) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call SetGlobalInput(importState, trim(vwnd), vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (merge_import) then + call FillGlobalInput(global_data, import_mask, wydata, WY0) + call FillGlobalInput(global_data, import_mask, wydata, WYN) + if (dbug_flag > 10) then + call check_globaldata(gcomp, 'wy0', wy0, nx*ny, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - end if - - ! air temp - ocn temp - DT0(:,:) = def_value - DTN(:,:) = def_value - if ((state_fldchk(importState, 'So_t')) .and. (state_fldchk(importState, 'Sa_tbot'))) then - allocate(global_data2(nsea)) - call SetGlobalInput(importState, 'Sa_tbot', vm, global_data, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call SetGlobalInput(importState, 'So_t', vm, global_data2, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! So_tbot - So_t - global_data = global_data - global_data2 - call FillGlobalInput(global_data, DT0) - call FillGlobalInput(global_data, DTN) - deallocate(global_data2) - end if - ! Deallocate memory for merge_import - if (merge_import) then - deallocate(wxdata) - deallocate(wydata) - end if + else + call FillGlobalInput(global_data, WY0) + call FillGlobalInput(global_data, WYN) + end if + end if + + ! air temp - ocn temp + DT0(:,:) = def_value + DTN(:,:) = def_value + if ((state_fldchk(importState, 'So_t')) .and. (state_fldchk(importState, 'Sa_tbot'))) then + allocate(global_data2(nsea)) + call SetGlobalInput(importState, 'Sa_tbot', vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call SetGlobalInput(importState, 'So_t', vm, global_data2, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! So_tbot - So_t + global_data = global_data - global_data2 + call FillGlobalInput(global_data, DT0) + call FillGlobalInput(global_data, DTN) + deallocate(global_data2) + end if + ! Deallocate memory for merge_import + if (merge_import) then + deallocate(wxdata) + deallocate(wydata) + end if end if ! --------------- ! INFLAGS1(4) - ice fraction field ! --------------- if (INFLAGS1(4)) then - TIN = timen ! time for ice field - ICEI(:,:) = def_value ! ice frac - if (state_fldchk(importState, 'Si_ifrac')) then - call SetGlobalInput(importState, 'Si_ifrac', vm, global_data, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FillGlobalInput(global_data, ICEI) - end if + TIN = timen ! time for ice field + ICEI(:,:) = def_value ! ice frac + if (state_fldchk(importState, 'Si_ifrac')) then + call SetGlobalInput(importState, 'Si_ifrac', vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FillGlobalInput(global_data, ICEI) + end if end if #ifdef W3_CESMCOUPLED ! --------------- @@ -491,76 +488,76 @@ subroutine import_fields( gcomp, time0, timen, rc ) ! INFLAGS1(5) - atm momentum fields ! --------------- if (INFLAGS1(5)) then - TU0 = time0 ! times for atm momentum fields. - TUN = timen - - UX0(:,:) = def_value ! atm u momentum - UXN(:,:) = def_value - if (state_fldchk(importState, 'Faxa_taux')) then - call SetGlobalInput(importState, 'Faxa_taux', vm, global_data, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FillGlobalInput(global_data, UX0) - call FillGlobalInput(global_data, UXN) - end if - - UY0(:,:) = def_value ! atm v momentum - UYN(:,:) = def_value - if (state_fldchk(importState, 'Faxa_tauy')) then - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call SetGlobalInput(importState, 'Faxa_tauy', vm, global_data, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FillGlobalInput(global_data, UY0) - call FillGlobalInput(global_data, UYN) - end if + TU0 = time0 ! times for atm momentum fields. + TUN = timen + + UX0(:,:) = def_value ! atm u momentum + UXN(:,:) = def_value + if (state_fldchk(importState, 'Faxa_taux')) then + call SetGlobalInput(importState, 'Faxa_taux', vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FillGlobalInput(global_data, UX0) + call FillGlobalInput(global_data, UXN) + end if + + UY0(:,:) = def_value ! atm v momentum + UYN(:,:) = def_value + if (state_fldchk(importState, 'Faxa_tauy')) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call SetGlobalInput(importState, 'Faxa_tauy', vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FillGlobalInput(global_data, UY0) + call FillGlobalInput(global_data, UYN) + end if end if ! --------------- ! INFLAGS1(-7) ! --------------- if (INFLAGS1(-7)) then - TI1 = timen ! time for ice field - ICEP1(:,:) = def_value ! ice thickness - if (state_fldchk(importState, 'Si_thick')) then - call SetGlobalInput(importState, 'Si_thick', vm, global_data, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FillGlobalInput(global_data, ICEP1) - end if + TI1 = timen ! time for ice field + ICEP1(:,:) = def_value ! ice thickness + if (state_fldchk(importState, 'Si_thick')) then + call SetGlobalInput(importState, 'Si_thick', vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FillGlobalInput(global_data, ICEP1) + end if end if ! --------------- ! INFLAGS1(-3) ! --------------- if (INFLAGS1(-3)) then - TI5 = timen ! time for ice field - ICEP5(:,:) = def_value ! ice floe size - if (state_fldchk(importState, 'Si_floediam')) then - call SetGlobalInput(importState, 'Si_floediam', vm, global_data, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FillGlobalInput(global_data, ICEP5) - end if + TI5 = timen ! time for ice field + ICEP5(:,:) = def_value ! ice floe size + if (state_fldchk(importState, 'Si_floediam')) then + call SetGlobalInput(importState, 'Si_floediam', vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FillGlobalInput(global_data, ICEP5) + end if end if #ifndef W3_CESMCOUPLED if (multigrid) then - do j = lbound(inflags1,1),ubound(inflags1,1) - if (inflags1(j)) then - do imod = 1,nrgrd - tfn(:,j) = timen(:) - call w3setg ( imod, mdse, mdst ) - call w3setw ( imod, mdse, mdst ) - call w3seti ( imod, mdse, mdst ) - call w3seto ( imod, mdse, mdst ) - call wmsetm ( imod, mdse, mdst ) + do j = lbound(inflags1,1),ubound(inflags1,1) + if (inflags1(j)) then + do imod = 1,nrgrd + tfn(:,j) = timen(:) + call w3setg ( imod, mdse, mdst ) + call w3setw ( imod, mdse, mdst ) + call w3seti ( imod, mdse, mdst ) + call w3seto ( imod, mdse, mdst ) + call wmsetm ( imod, mdse, mdst ) #ifdef W3_MPI - if ( mpi_comm_grd .eq. mpi_comm_null ) cycle + if ( mpi_comm_grd .eq. mpi_comm_null ) cycle #endif - !TODO: when is this active? jmod = -999 - jmod = inpmap(imod,j) - if ( jmod.lt.0 .and. jmod.ne.-999 ) then - call wmupd2( imod, j, jmod, rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - end do - end if - end do + !TODO: when is this active? jmod = -999 + jmod = inpmap(imod,j) + if ( jmod.lt.0 .and. jmod.ne.-999 ) then + call wmupd2( imod, j, jmod, rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + end do + end if + end do end if #endif if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) @@ -568,15 +565,15 @@ subroutine import_fields( gcomp, time0, timen, rc ) end subroutine import_fields !=============================================================================== -!> Fill the export state with values from WW3 fields -!! -!> @details Called by ModelAdvance, fill or compute the values in the export state. -!! -!! @param gcomp an ESMF_GridComp object -!! @param[out] rc return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Fill the export state with values from WW3 fields + !! + !> @details Called by ModelAdvance, fill or compute the values in the export state. + !! + !! @param gcomp an ESMF_GridComp object + !! @param[out] rc return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine export_fields (gcomp, rc) !--------------------------------------------------------------------------- @@ -584,7 +581,7 @@ subroutine export_fields (gcomp, rc) !--------------------------------------------------------------------------- use wav_kind_mod, only : R8 => SHR_KIND_R8 - use w3adatmd , only : USSX, USSY, EF, USSP + use w3adatmd , only : USSX, USSY, USSP use w3adatmd , only : w3seta use w3idatmd , only : w3seti use w3wdatmd , only : va, w3setw @@ -604,15 +601,15 @@ subroutine export_fields (gcomp, rc) ! Local variables real(R8) :: fillvalue = 1.0e30_R8 ! special missing value type(ESMF_State) :: exportState - integer :: n, jsea, isea, ix, iy, lsize, ib + integer :: n, jsea, isea, ix, iy, ib real(r8), pointer :: z0rlen(:) real(r8), pointer :: charno(:) real(r8), pointer :: wbcuru(:) real(r8), pointer :: wbcurv(:) real(r8), pointer :: wbcurp(:) - !real(r8), pointer :: uscurr(:) - !real(r8), pointer :: vscurr(:) + !real(r8), pointer :: uscurr(:) + !real(r8), pointer :: vscurr(:) real(r8), pointer :: sxxn(:) real(r8), pointer :: sxyn(:) real(r8), pointer :: syyn(:) @@ -650,68 +647,68 @@ subroutine export_fields (gcomp, rc) call w3seti ( 1, mdse, mdst ) call w3seto ( 1, mdse, mdst ) if (multigrid) then - call wmsetm ( 1, mdse, mdst ) + call wmsetm ( 1, mdse, mdst ) end if #else if (state_fldchk(exportState, 'Sw_lamult')) then - call state_getfldptr(exportState, 'Sw_lamult', sw_lamult, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_lamult(:) = fillvalue - do jsea=1, nseal - isea = iaproc + (jsea-1)*naproc - ix = mapsf(isea,1) - iy = mapsf(isea,2) - if (mapsta(iy,ix) == 1) then - sw_lamult(jsea) = LAMULT(jsea) - else - sw_lamult(jsea) = 1. - endif - enddo + call state_getfldptr(exportState, 'Sw_lamult', sw_lamult, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_lamult(:) = fillvalue + do jsea=1, nseal + isea = iaproc + (jsea-1)*naproc + ix = mapsf(isea,1) + iy = mapsf(isea,2) + if (mapsta(iy,ix) == 1) then + sw_lamult(jsea) = LAMULT(jsea) + else + sw_lamult(jsea) = 1. + endif + enddo end if #endif ! surface stokes drift if (state_fldchk(exportState, 'Sw_ustokes')) then - call state_getfldptr(exportState, 'Sw_ustokes', sw_ustokes, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_ustokes(:) = fillvalue - do jsea=1, nseal - isea = iaproc + (jsea-1)*naproc - ix = mapsf(isea,1) - iy = mapsf(isea,2) - if (mapsta(iy,ix) == 1) then - sw_ustokes(jsea) = USSX(jsea) - else - sw_ustokes(jsea) = 0. - endif - enddo + call state_getfldptr(exportState, 'Sw_ustokes', sw_ustokes, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_ustokes(:) = fillvalue + do jsea=1, nseal + isea = iaproc + (jsea-1)*naproc + ix = mapsf(isea,1) + iy = mapsf(isea,2) + if (mapsta(iy,ix) == 1) then + sw_ustokes(jsea) = USSX(jsea) + else + sw_ustokes(jsea) = 0. + endif + enddo end if if (state_fldchk(exportState, 'Sw_vstokes')) then - call state_getfldptr(exportState, 'Sw_vstokes', sw_vstokes, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_vstokes(:) = fillvalue - do jsea=1, nseal - isea = iaproc + (jsea-1)*naproc - ix = mapsf(isea,1) - iy = mapsf(isea,2) - if (mapsta(iy,ix) == 1) then - sw_vstokes(jsea) = USSY(jsea) - else - sw_vstokes(jsea) = 0. - endif - enddo + call state_getfldptr(exportState, 'Sw_vstokes', sw_vstokes, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_vstokes(:) = fillvalue + do jsea=1, nseal + isea = iaproc + (jsea-1)*naproc + ix = mapsf(isea,1) + iy = mapsf(isea,2) + if (mapsta(iy,ix) == 1) then + sw_vstokes(jsea) = USSY(jsea) + else + sw_vstokes(jsea) = 0. + endif + enddo end if if (state_fldchk(exportState, 'Sw_ch')) then - call state_getfldptr(exportState, 'charno', charno, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call CalcCharnk(charno) + call state_getfldptr(exportState, 'charno', charno, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call CalcCharnk(charno) endif if (state_fldchk(exportState, 'Sw_z0')) then - call state_getfldptr(exportState, 'Sw_z0', z0rlen, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call CalcRoughl(z0rlen) + call state_getfldptr(exportState, 'Sw_z0', z0rlen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call CalcRoughl(z0rlen) endif !TODO: what is difference between uscurr/vscurr and sw_ustokes,sw_vstokes? @@ -730,65 +727,52 @@ subroutine export_fields (gcomp, rc) if ( state_fldchk(exportState, 'wbcuru') .and. & state_fldchk(exportState, 'wbcurv') .and. & state_fldchk(exportState, 'wbcurp')) then - call state_getfldptr(exportState, 'wbcuru', wbcuru, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'wbcurv', wbcurv, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'wbcurp', wbcurp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call CalcBotcur( va, wbcuru, wbcurv, wbcurp) + call state_getfldptr(exportState, 'wbcuru', wbcuru, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'wbcurv', wbcurv, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'wbcurp', wbcurp, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call CalcBotcur( va, wbcuru, wbcurv, wbcurp) end if if ( state_fldchk(exportState, 'wavsuu') .and. & state_fldchk(exportState, 'wavsuv') .and. & state_fldchk(exportState, 'wavsvv')) then - call state_getfldptr(exportState, 'sxxn', sxxn, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'sxyn', sxyn, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'syyn', syyn, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call CalcRadstr2D( va, sxxn, sxyn, syyn) + call state_getfldptr(exportState, 'sxxn', sxxn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'sxyn', sxyn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'syyn', syyn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call CalcRadstr2D( va, sxxn, sxyn, syyn) end if if (wav_coupling_to_cice) then - call state_getfldptr(exportState, 'wave_elevation_spectrum', wave_elevation_spectrum, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Initialize wave elevation spectrum - wave_elevation_spectrum(:,:) = fillvalue - - do jsea=1, nseal ! jsea is local - isea = iaproc + (jsea-1)*naproc ! isea is global - ix = mapsf(isea,1) ! global ix - iy = mapsf(isea,2) ! global iy - if (mapsta(iy,ix) .eq. 1) then ! active sea point - ! If wave_elevation_spectrum is UNDEF - needs ouput flag to be turned on - ! wave_elevation_spectrum as 25 variables - wave_elevation_spectrum(1:nwav_elev_spectrum,jsea) = EF(jsea,1:nwav_elev_spectrum) - else - wave_elevation_spectrum(:,jsea) = 0. - endif - enddo + call state_getfldptr(exportState, 'wave_elevation_spectrum', wave_elevation_spectrum, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Initialize wave elevation spectrum + wave_elevation_spectrum(:,:) = fillvalue + call CalcEF(va, wave_elevation_spectrum) end if if ( state_fldchk(exportState, 'Sw_pstokes_x') .and. & state_fldchk(exportState, 'Sw_pstokes_y') )then - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sw_pstokes_x', sw_pstokes_x, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sw_pstokes_y', sw_pstokes_y, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_pstokes_x(:,:) = fillvalue - sw_pstokes_y(:,:) = fillvalue - if (USSPF(1) > 0) then ! Partitioned Stokes drift computation is turned on in mod_def file. - call CALC_U3STOKES(va, 2) - do ib = 1, USSPF(2) - do jsea = 1, nseal - sw_pstokes_x(ib,jsea) = ussp(jsea,ib) - sw_pstokes_y(ib,jsea) = ussp(jsea,nk+ib) - enddo - end do - end if + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sw_pstokes_x', sw_pstokes_x, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sw_pstokes_y', sw_pstokes_y, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_pstokes_x(:,:) = fillvalue + sw_pstokes_y(:,:) = fillvalue + if (USSPF(1) > 0) then ! Partitioned Stokes drift computation is turned on in mod_def file. + call CALC_U3STOKES(va, 2) + do ib = 1, USSPF(2) + do jsea = 1, nseal + sw_pstokes_x(ib,jsea) = ussp(jsea,ib) + sw_pstokes_y(ib,jsea) = ussp(jsea,nk+ib) + enddo + end do + end if endif if ( state_fldchk(exportState, 'Sw_ustokes1') .and. & @@ -798,53 +782,53 @@ subroutine export_fields (gcomp, rc) state_fldchk(exportState, 'Sw_vstokes2') .and. & state_fldchk(exportState, 'Sw_vstokes3') ) then - call state_getfldptr(exportState, 'Sw_ustokes1', sw_ustokes1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sw_ustokes2', sw_ustokes2, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sw_ustokes3', sw_ustokes3, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sw_vstokes1', sw_vstokes1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sw_vstokes2', sw_vstokes2, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getfldptr(exportState, 'Sw_vstokes3', sw_vstokes3, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_ustokes1(:)= zero - sw_vstokes1(:)= zero - sw_ustokes2(:)= zero - sw_vstokes2(:)= zero - sw_ustokes3(:)= zero - sw_vstokes3(:)= zero - call CALC_U3STOKES(va, 2) - do jsea = 1,nseal - sw_ustokes1(jsea)=ussp(jsea,1) - sw_vstokes1(jsea)=ussp(jsea,nk+1) - sw_ustokes2(jsea)=ussp(jsea,2) - sw_vstokes2(jsea)=ussp(jsea,nk+2) - sw_ustokes3(jsea)=ussp(jsea,3) - sw_vstokes3(jsea)=ussp(jsea,nk+3) - end do + call state_getfldptr(exportState, 'Sw_ustokes1', sw_ustokes1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sw_ustokes2', sw_ustokes2, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sw_ustokes3', sw_ustokes3, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sw_vstokes1', sw_vstokes1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sw_vstokes2', sw_vstokes2, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'Sw_vstokes3', sw_vstokes3, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_ustokes1(:)= zero + sw_vstokes1(:)= zero + sw_ustokes2(:)= zero + sw_vstokes2(:)= zero + sw_ustokes3(:)= zero + sw_vstokes3(:)= zero + call CALC_U3STOKES(va, 2) + do jsea = 1,nseal + sw_ustokes1(jsea)=ussp(jsea,1) + sw_vstokes1(jsea)=ussp(jsea,nk+1) + sw_ustokes2(jsea)=ussp(jsea,2) + sw_vstokes2(jsea)=ussp(jsea,nk+2) + sw_ustokes3(jsea)=ussp(jsea,3) + sw_vstokes3(jsea)=ussp(jsea,nk+3) + end do end if if (dbug_flag > 5) then - call state_diagnose(exportState, 'at export ', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_diagnose(exportState, 'at export ', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if end subroutine export_fields !=============================================================================== -!> Add a fieldname to a list of fields in a state -!! -!! @param[inout] num a counter for added fields -!! @param[inout] fldlist a structure for the standard name and ungridded dims -!! @param[in] stdname a standard field name -!! @param[in] ungridded_lbound the lower bound of an ungridded dimension -!! @param[in] ungridded_ubound the upper bound of an ungridded dimension -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Add a fieldname to a list of fields in a state + !! + !! @param[inout] num a counter for added fields + !! @param[inout] fldlist a structure for the standard name and ungridded dims + !! @param[in] stdname a standard field name + !! @param[in] ungridded_lbound the lower bound of an ungridded dimension + !! @param[in] ungridded_ubound the upper bound of an ungridded dimension + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine fldlist_add(num, fldlist, stdname, ungridded_lbound, ungridded_ubound) integer, intent(inout) :: num type(fld_list_type), intent(inout) :: fldlist(:) @@ -861,36 +845,36 @@ subroutine fldlist_add(num, fldlist, stdname, ungridded_lbound, ungridded_ubound ! Set up a list of field information num = num + 1 if (num > fldsMax) then - call ESMF_LogWrite(trim(subname)//": ERROR num > fldsMax "//trim(stdname), & - ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__) - return + call ESMF_LogWrite(trim(subname)//": ERROR num > fldsMax "//trim(stdname), & + ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__) + return endif fldlist(num)%stdname = trim(stdname) if (present(ungridded_lbound) .and. present(ungridded_ubound)) then - fldlist(num)%ungridded_lbound = ungridded_lbound - fldlist(num)%ungridded_ubound = ungridded_ubound + fldlist(num)%ungridded_lbound = ungridded_lbound + fldlist(num)%ungridded_ubound = ungridded_ubound end if end subroutine fldlist_add !=============================================================================== -!> Realize a list of fields in a state -!! -!> @details For a connected field in a State, create an ESMF_Field object of -!! the required dimensionality on the ESMF_Mesh. Remove any unconnected fields from -!! the State. For a scalar field, create a field of dimensionality (1:flds_scalar_num) -!! -!! @param[inout] state an ESMF_State object -!! @param[in] fldlist a list of fields in the State -!! @param[in] numflds the number of fields in the state -!! @param[in] flds_scalar_name the name of the scalar field -!! @param[in] flds_scalar_num the count of scalar fields -!! @param[in] tag a character string for logging -!! @param[in] mesh an ESMF_Mesh object -!! @param[inout] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Realize a list of fields in a state + !! + !> @details For a connected field in a State, create an ESMF_Field object of + !! the required dimensionality on the ESMF_Mesh. Remove any unconnected fields from + !! the State. For a scalar field, create a field of dimensionality (1:flds_scalar_num) + !! + !! @param[inout] state an ESMF_State object + !! @param[in] fldlist a list of fields in the State + !! @param[in] numflds the number of fields in the state + !! @param[in] flds_scalar_name the name of the scalar field + !! @param[in] flds_scalar_num the count of scalar fields + !! @param[in] tag a character string for logging + !! @param[in] mesh an ESMF_Mesh object + !! @param[inout] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scalar_num, mesh, tag, rc) ! input/output variables @@ -914,55 +898,55 @@ subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scala if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) do n = 1, numflds - stdname = fldList(n)%stdname - if (NUOPC_IsConnected(state, fieldName=stdname)) then - if (stdname == trim(flds_scalar_name)) then - call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected on root pe", & - ESMF_LOGMSG_INFO) - ! Create the scalar field - call SetScalarField(field, flds_scalar_name, flds_scalar_num, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected using mesh", & - ESMF_LOGMSG_INFO) - ! Create the field - if (fldlist(n)%ungridded_lbound > 0 .and. fldlist(n)%ungridded_ubound > 0) then - call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" has ungridded dimension", & - ESMF_LOGMSG_INFO) - field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, & - ungriddedLbound=(/fldlist(n)%ungridded_lbound/), & - ungriddedUbound=(/fldlist(n)%ungridded_ubound/), & - gridToFieldMap=(/2/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - end if ! if not scalar field - - ! NOW call NUOPC_Realize - call NUOPC_Realize(state, field=field, rc=rc) + stdname = fldList(n)%stdname + if (NUOPC_IsConnected(state, fieldName=stdname)) then + if (stdname == trim(flds_scalar_name)) then + call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected on root pe", & + ESMF_LOGMSG_INFO) + ! Create the scalar field + call SetScalarField(field, flds_scalar_name, flds_scalar_num, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - if (stdname /= trim(flds_scalar_name)) then - call ESMF_LogWrite(subname // trim(tag) // " Field = "// trim(stdname) // " is not connected.", & - ESMF_LOGMSG_INFO) - call ESMF_StateRemove(state, (/stdname/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected using mesh", & + ESMF_LOGMSG_INFO) + ! Create the field + if (fldlist(n)%ungridded_lbound > 0 .and. fldlist(n)%ungridded_ubound > 0) then + call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" has ungridded dimension", & + ESMF_LOGMSG_INFO) + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLbound=(/fldlist(n)%ungridded_lbound/), & + ungriddedUbound=(/fldlist(n)%ungridded_ubound/), & + gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - end if + end if ! if not scalar field + + ! NOW call NUOPC_Realize + call NUOPC_Realize(state, field=field, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + if (stdname /= trim(flds_scalar_name)) then + call ESMF_LogWrite(subname // trim(tag) // " Field = "// trim(stdname) // " is not connected.", & + ESMF_LOGMSG_INFO) + call ESMF_StateRemove(state, (/stdname/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if end do contains !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!> Create a field with scalar data on the root pe -!! -!! @param[inout] field an ESMF_Field -!! @param[in] flds_scalar_name the scalar field name -!! @param[in[ flds_scalar_num the dimnsionality of the scalar field -!! @param[inout] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Create a field with scalar data on the root pe + !! + !! @param[inout] field an ESMF_Field + !! @param[in] flds_scalar_name the scalar field name + !! @param[in[ flds_scalar_num the dimnsionality of the scalar field + !! @param[inout] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine SetScalarField(field, flds_scalar_name, flds_scalar_num, rc) ! ---------------------------------------------- ! create a field with scalar data on the root pe @@ -997,14 +981,14 @@ end subroutine SetScalarField end subroutine fldlist_realize !=============================================================================== -!> Calculate Charnok parameter for export -!! -!> @details TODO: -!! -!! @param[inout] chkn a 1-D pointer to a field on a mesh -!! -!> @author T. J. Campbell, NRL -!> @date 09-Aug-2017 + !> Calculate Charnok parameter for export + !! + !> @details TODO: + !! + !! @param[inout] chkn a 1-D pointer to a field on a mesh + !! + !> @author T. J. Campbell, NRL + !> @date 09-Aug-2017 subroutine CalcCharnk ( chkn ) ! Calculate Charnok for export @@ -1034,27 +1018,27 @@ subroutine CalcCharnk ( chkn ) !TODO: fix firstCall like for Roughl jsea_loop: do jsea = 1,nseal - isea = iaproc + (jsea-1)*naproc - if ( firstCall ) then - charn(jsea) = zero - llws(:) = .true. - ustar = zero - ustdr = zero + isea = iaproc + (jsea-1)*naproc + if ( firstCall ) then + charn(jsea) = zero + llws(:) = .true. + ustar = zero + ustdr = zero #ifdef W3_ST3 - call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & - emean, fmean, fmean1, wnmean, amax, & - u10(isea), u10d(isea), ustar, ustdr, tauwx, & - tauwy, cd, z0, charn(jsea), llws, fmeanws ) + call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws ) #endif #ifdef W3_ST4 - call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & - emean, fmean, fmean1, wnmean, amax, & - u10(isea), u10d(isea), ustar, ustdr, tauwx, & - tauwy, cd, z0, charn(jsea), llws, fmeanws, & - dlwmean ) + call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws, & + dlwmean ) #endif - endif !firstCall - chkn(jsea) = charn(jsea) + endif !firstCall + chkn(jsea) = charn(jsea) enddo jsea_loop firstCall = .false. @@ -1062,14 +1046,14 @@ subroutine CalcCharnk ( chkn ) end subroutine CalcCharnk !=============================================================================== -!> Calculate wave roughness length for export -!! -!> @details TODO: -!! -!! @param[inout] wrln a 1-D pointer to a field on a mesh -!! -!> @author T. J. Campbell, NRL -!> @date 09-Aug-2017 + !> Calculate wave roughness length for export + !! + !> @details TODO: + !! + !! @param[inout] wrln a 1-D pointer to a field on a mesh + !! + !> @author T. J. Campbell, NRL + !> @date 09-Aug-2017 subroutine CalcRoughl ( wrln) ! Calculate 2D wave roughness length for export @@ -1098,34 +1082,34 @@ subroutine CalcRoughl ( wrln) !---------------------------------------------------------------------- jsea_loop: do jsea = 1,nseal - isea = iaproc + (jsea-1)*naproc - ix = mapsf(isea,1) - iy = mapsf(isea,2) - if ( firstCall ) then - if(( runtype == 'initial' .and. mapsta(iy,ix) == 1 ) .or. & + isea = iaproc + (jsea-1)*naproc + ix = mapsf(isea,1) + iy = mapsf(isea,2) + if ( firstCall ) then + if(( runtype == 'initial' .and. mapsta(iy,ix) == 1 ) .or. & ( runtype == 'continue' .and. abs(mapsta(iy,ix)) == 1 )) then - charn(jsea) = zero - llws(:) = .true. - ustar = zero - ustdr = zero - tauwx = zero - tauwy = zero + charn(jsea) = zero + llws(:) = .true. + ustar = zero + ustdr = zero + tauwx = zero + tauwy = zero #ifdef W3_ST3 - call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & - emean, fmean, fmean1, wnmean, amax, & - u10(isea), u10d(isea), ustar, ustdr, tauwx, & - tauwy, cd, z0, charn(jsea), llws, fmeanws ) + call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws ) #endif #ifdef W3_ST4 - call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & - emean, fmean, fmean1, wnmean, amax, & - u10(isea), u10d(isea), ustar, ustdr, tauwx, & - tauwy, cd, z0, charn(jsea), llws, fmeanws, & - dlwmean ) + call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws, & + dlwmean ) #endif - end if - endif !firstCall - wrln(jsea) = charn(jsea)*ust(isea)**2/grav + end if + endif !firstCall + wrln(jsea) = charn(jsea)*ust(isea)**2/grav enddo jsea_loop firstCall = .false. @@ -1133,17 +1117,17 @@ subroutine CalcRoughl ( wrln) end subroutine CalcRoughl !=============================================================================== -!> Calculate wave-bottom currents for export -!! -!> @details TODO: -!! -!! @param[in] a input spectra -!! @param wbxn a 1-D pointer to a field on a mesh -!! @param wbyn a 1-D pointer to a field on a mesh -!! @param wbpn a 1-D pointer to a field on a mesh -!! -!> @author T. J. Campbell, NRL -!> @date 09-Aug-2017 + !> Calculate wave-bottom currents for export + !! + !> @details TODO: + !! + !! @param[in] a input spectra + !! @param wbxn a 1-D pointer to a field on a mesh + !! @param wbyn a 1-D pointer to a field on a mesh + !! @param wbpn a 1-D pointer to a field on a mesh + !! + !> @author T. J. Campbell, NRL + !> @date 09-Aug-2017 subroutine CalcBotcur ( a, wbxn, wbyn, wbpn ) ! Calculate wave-bottom currents for export @@ -1178,37 +1162,37 @@ subroutine CalcBotcur ( a, wbxn, wbyn, wbpn ) wbpn(:) = zero jsea_loop: do jsea = 1,nseal - isea = iaproc + (jsea-1)*naproc - if ( dw(isea).le.zero ) cycle jsea_loop - depth = max(dmin,dw(isea)) - abr = zero - ubr = zero - ubx = zero - uby = zero - ik_loop: do ik = 1,nk - aka = zero - akx = zero - aky = zero - ith_loop: do ith = 1,nth - aka = aka + a(ith,ik,jsea) - akx = akx + a(ith,ik,jsea)*ecos(ith) - aky = aky + a(ith,ik,jsea)*esin(ith) - enddo ith_loop - fack = dden(ik)/cg(ik,isea) - kd = max(kdmin,min(kdmax,wn(ik,isea)*depth)) - fkd = fack/sinh(kd)**2 - abr = abr + aka*fkd - ubr = ubr + aka*sig2(ik)*fkd - ubx = ubx + akx*sig2(ik)*fkd - uby = uby + aky*sig2(ik)*fkd - enddo ik_loop - if ( abr.le.zero .or. ubr.le.zero ) cycle jsea_loop - abr = sqrt(two*abr) - ubr = sqrt(two*ubr) - dir = atan2(uby,ubx) - wbxn(jsea) = ubr*cos(dir) - wbyn(jsea) = ubr*sin(dir) - wbpn(jsea) = tpi*abr/ubr + isea = iaproc + (jsea-1)*naproc + if ( dw(isea).le.zero ) cycle jsea_loop + depth = max(dmin,dw(isea)) + abr = zero + ubr = zero + ubx = zero + uby = zero + ik_loop: do ik = 1,nk + aka = zero + akx = zero + aky = zero + ith_loop: do ith = 1,nth + aka = aka + a(ith,ik,jsea) + akx = akx + a(ith,ik,jsea)*ecos(ith) + aky = aky + a(ith,ik,jsea)*esin(ith) + enddo ith_loop + fack = dden(ik)/cg(ik,isea) + kd = max(kdmin,min(kdmax,wn(ik,isea)*depth)) + fkd = fack/sinh(kd)**2 + abr = abr + aka*fkd + ubr = ubr + aka*sig2(ik)*fkd + ubx = ubx + akx*sig2(ik)*fkd + uby = uby + aky*sig2(ik)*fkd + enddo ik_loop + if ( abr.le.zero .or. ubr.le.zero ) cycle jsea_loop + abr = sqrt(two*abr) + ubr = sqrt(two*ubr) + dir = atan2(uby,ubx) + wbxn(jsea) = ubr*cos(dir) + wbyn(jsea) = ubr*sin(dir) + wbpn(jsea) = tpi*abr/ubr enddo jsea_loop deallocate( sig2 ) @@ -1216,17 +1200,17 @@ subroutine CalcBotcur ( a, wbxn, wbyn, wbpn ) end subroutine CalcBotcur !=============================================================================== -!> Calculate radiation stresses for export -!! -!> @details TODO: -!! -!! @param[in] a input spectra -!! @param sxxn a 1-D pointer to a field on a mesh -!! @param sxyn a 1-D pointer to a field on a mesh -!! @param syyn a 1-D pointer to a field on a mesh -!! -!> @author T. J. Campbell, NRL -!> @date 09-Aug-2017 + !> Calculate radiation stresses for export + !! + !> @details TODO: + !! + !! @param[in] a input spectra + !! @param sxxn a 1-D pointer to a field on a mesh + !! @param sxyn a 1-D pointer to a field on a mesh + !! @param syyn a 1-D pointer to a field on a mesh + !! + !> @author T. J. Campbell, NRL + !> @date 09-Aug-2017 subroutine CalcRadstr2D ( a, sxxn, sxyn, syyn ) ! Calculate 2D radiation stresses for export @@ -1257,49 +1241,101 @@ subroutine CalcRadstr2D ( a, sxxn, sxyn, syyn ) facd = dwat*grav jsea_loop: do jsea = 1,nseal - isea = iaproc + (jsea-1)*naproc - if ( dw(isea).le.zero ) cycle jsea_loop - sxxs = zero - sxys = zero - syys = zero - ik_loop: do ik = 1,nk - akxx = zero - akxy = zero - akyy = zero - cgoc = cg(ik,isea)*wn(ik,isea)/sig(ik) - cgoc = min(one,max(half,cgoc)) - ith_loop: do ith = 1,nth - akxx = akxx + (cgoc*(ec2(ith)+one)-half)*a(ith,ik,jsea) - akxy = akxy + cgoc*esc(ith)*a(ith,ik,jsea) - akyy = akyy + (cgoc*(es2(ith)+one)-half)*a(ith,ik,jsea) - enddo ith_loop - fack = dden(ik)/cg(ik,isea) - sxxs = sxxs + akxx*fack - sxys = sxys + akxy*fack - syys = syys + akyy*fack - enddo ik_loop - facs = (one+fte/cg(nk,isea))*facd - sxxn(jsea) = sxxs*facs - sxyn(jsea) = sxys*facs - syyn(jsea) = syys*facs + isea = iaproc + (jsea-1)*naproc + if ( dw(isea).le.zero ) cycle jsea_loop + sxxs = zero + sxys = zero + syys = zero + ik_loop: do ik = 1,nk + akxx = zero + akxy = zero + akyy = zero + cgoc = cg(ik,isea)*wn(ik,isea)/sig(ik) + cgoc = min(one,max(half,cgoc)) + ith_loop: do ith = 1,nth + akxx = akxx + (cgoc*(ec2(ith)+one)-half)*a(ith,ik,jsea) + akxy = akxy + cgoc*esc(ith)*a(ith,ik,jsea) + akyy = akyy + (cgoc*(es2(ith)+one)-half)*a(ith,ik,jsea) + enddo ith_loop + fack = dden(ik)/cg(ik,isea) + sxxs = sxxs + akxx*fack + sxys = sxys + akxy*fack + syys = syys + akyy*fack + enddo ik_loop + facs = (one+fte/cg(nk,isea))*facd + sxxn(jsea) = sxxs*facs + sxyn(jsea) = sxys*facs + syyn(jsea) = syys*facs enddo jsea_loop end subroutine CalcRadstr2D + !=============================================================================== + !> Calculate wave elevation spectrum for export + !! + !> @details Calculates wave elevation spectrum independently of w3iogomd to ensure + !! that EF field sent to sea ice component is updated at the coupling frequency + !! + !! @param[in] a input spectra + !! @param[inout] wave_elevation_spectrum a 2-D pointer to a field on a mesh + !! + !> @author Denise.Worthen@noaa.gov + !> @date 10-28-2022 + subroutine CalcEF (a, wave_elevation_spectrum) + + use constants, only : tpi + use w3gdatmd, only : nth, nk, nseal, mapsf, mapsta, dden, dsii + use w3adatmd, only : nsealm, cg + use w3parall, only : init_get_isea + + ! input/output variables + real, intent(in) :: a(nth,nk,0:nseal) + real(r8), pointer :: wave_elevation_spectrum(:,:) + + ! local variables + real :: ab(nseal) + real :: ebd, factor + integer :: ik, ith, isea, jsea, ix, iy + + do ik = 1,nwav_elev_spectrum + ab = 0.0 + do ith = 1, nth + do jsea = 1,nseal + ab(jsea) = ab(jsea) + a(ith,ik,jsea) + end do + end do + + do jsea = 1,nseal + call init_get_isea(isea, jsea) + ix = mapsf(isea,1) ! global ix + iy = mapsf(isea,2) ! global iy + if (mapsta(iy,ix) .eq. 1) then ! active sea point + factor = dden(ik) / cg(ik,isea) + ebd = ab(jsea) * factor + ebd = ebd / dsii(ik) + wave_elevation_spectrum(ik,jsea) = ebd * tpi + else + wave_elevation_spectrum(ik,jsea) = 0. + end if + end do + end do + + end subroutine CalcEF + !==================================================================================== -!> Create a global field across all PEs -!! -!> @details Distributes the global values of the named import state field to all PEs -!! using a global reduce across all PEs. -!! -!! @param[in] importstate the import state -!! @param[in] fldname the field name -!! @param[in] vm the ESMF VM object -!! @param[out] global_output the global nsea values -!! @param[out] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Create a global field across all PEs + !! + !> @details Distributes the global values of the named import state field to all PEs + !! using a global reduce across all PEs. + !! + !! @param[in] importstate the import state + !! @param[in] fldname the field name + !! @param[in] vm the ESMF VM object + !! @param[out] global_output the global nsea values + !! @param[out] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine SetGlobalInput(importState, fldname, vm, global_output, rc) use w3gdatmd, only: nsea, nseal, nx, ny @@ -1328,8 +1364,8 @@ subroutine SetGlobalInput(importState, fldname, vm, global_output, rc) global_output(:) = 0._r4 global_input(:) = 0._r4 do jsea = 1, nseal - isea = iaproc + (jsea-1)*naproc - global_input(isea) = real(dataptr(jsea),4) + isea = iaproc + (jsea-1)*naproc + global_input(isea) = real(dataptr(jsea),4) end do call ESMF_VMAllReduce(vm, sendData=global_input, recvData=global_output, count=nsea, reduceflag=ESMF_REDUCE_SUM, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1337,15 +1373,15 @@ subroutine SetGlobalInput(importState, fldname, vm, global_output, rc) end subroutine SetGlobalInput !==================================================================================== -!> Fill a global field with import state values at nsea points -!! -!> @details Fills a global field on all points from the values at all sea points -!! -!! @param[in] global_data values of a global field on nsea points -!! @param[inout] globalfield values of a global field on all points -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Fill a global field with import state values at nsea points + !! + !> @details Fills a global field on all points from the values at all sea points + !! + !! @param[in] global_data values of a global field on nsea points + !! @param[inout] globalfield values of a global field on all points + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine fillglobal_with_import(global_data, globalfield) use w3gdatmd, only: nsea, mapsf, nx, ny @@ -1357,26 +1393,26 @@ subroutine fillglobal_with_import(global_data, globalfield) integer :: isea, ix, iy do isea = 1,nsea - ix = mapsf(isea,1) - iy = mapsf(isea,2) - globalfield(ix,iy) = global_data(isea) + ix = mapsf(isea,1) + iy = mapsf(isea,2) + globalfield(ix,iy) = global_data(isea) end do end subroutine fillglobal_with_import !==================================================================================== -!> Fill a global field by merging -!! -!> @details Merges the global import field values on sea points with values from a file -!! using a provided mask -!! -!! @param[in] global_data values of a global field on nsea points -!! @param[in] global_mask values of a global mask -!! @param[in] filedata values of a global field from a file -!! @param[inout] globalfield values of a global field on all points -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Fill a global field by merging + !! + !> @details Merges the global import field values on sea points with values from a file + !! using a provided mask + !! + !! @param[in] global_data values of a global field on nsea points + !! @param[in] global_mask values of a global mask + !! @param[in] filedata values of a global field from a file + !! @param[inout] globalfield values of a global field on all points + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine fillglobal_with_merge_import(global_data, global_mask, filedata, globalfield) use w3gdatmd, only: nsea, mapsf, nx, ny @@ -1390,35 +1426,35 @@ subroutine fillglobal_with_merge_import(global_data, global_mask, filedata, glob integer :: isea, ix, iy do isea = 1,nsea - ix = mapsf(isea,1) - iy = mapsf(isea,2) - globalfield(ix,iy) = global_data(isea)*global_mask(isea) + (1.0_r4 - global_mask(isea))*filedata(isea) + ix = mapsf(isea,1) + iy = mapsf(isea,2) + globalfield(ix,iy) = global_data(isea)*global_mask(isea) + (1.0_r4 - global_mask(isea))*filedata(isea) end do end subroutine fillglobal_with_merge_import !==================================================================================== -!> Obtain the import mask used to merge a field from the import state with values from -!! a file -!! -!> @details Set the import mask for merging an import state field with values from -!! a file. The import mask is set 0 where the field from the import state has a value -!! of fillValue due to non-overlapping model domains. The field values read from a -!! file will be used to provide the values in these regions. The values of the import -!! mask are set initially (on the first ModelAdvance) to be 0 everywhere. In this case -!! there are no valid import state values and only the values read from the file are -!! used. At the second ModelAdvance, the import state contains valid values and the -!! import mask can be set according the regions where the import state contains the -!! fillValue. The import mask is fixed in time after the second ModelAdvance. -!! -!! @param[in] importState an ESMF_State object for import fields -!! @param[in] clock an ESMF_Clock object -!! @param[in] fldname a field name -!! @param[in] vm an ESMF_VM object -!! @param[out] rc return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Obtain the import mask used to merge a field from the import state with values from + !! a file + !! + !> @details Set the import mask for merging an import state field with values from + !! a file. The import mask is set 0 where the field from the import state has a value + !! of fillValue due to non-overlapping model domains. The field values read from a + !! file will be used to provide the values in these regions. The values of the import + !! mask are set initially (on the first ModelAdvance) to be 0 everywhere. In this case + !! there are no valid import state values and only the values read from the file are + !! used. At the second ModelAdvance, the import state contains valid values and the + !! import mask can be set according the regions where the import state contains the + !! fillValue. The import mask is fixed in time after the second ModelAdvance. + !! + !! @param[in] importState an ESMF_State object for import fields + !! @param[in] clock an ESMF_Clock object + !! @param[in] fldname a field name + !! @param[in] vm an ESMF_VM object + !! @param[out] rc return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine set_importmask(importState, clock, fldname, vm, rc) use w3gdatmd, only: nsea, nseal, nx, ny @@ -1451,17 +1487,17 @@ subroutine set_importmask(importState, clock, fldname, vm, rc) ! set call flags if (startTime == currTime) then - firstCall = .true. - secondCall = .false. + firstCall = .true. + secondCall = .false. elseif (currTime == startTime+timeStep) then - firstCall = .false. - secondCall = .true. + firstCall = .false. + secondCall = .true. else - firstCall = .false. - secondCall = .false. + firstCall = .false. + secondCall = .false. end if if (firstcall) then - allocate(import_mask(nsea)) + allocate(import_mask(nsea)) end if ! return if not the first or second call, mask has already been set @@ -1469,30 +1505,30 @@ subroutine set_importmask(importState, clock, fldname, vm, rc) ! no valid import at firstCall, use all data if (firstCall) then - import_mask(:) = 0.0_r4 - call ESMF_ClockPrint(clock, options='currTime', preString='Setting initial import_mask at currTime : ', & - unit=msgString, rc=rc) - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + import_mask(:) = 0.0_r4 + call ESMF_ClockPrint(clock, options='currTime', preString='Setting initial import_mask at currTime : ', & + unit=msgString, rc=rc) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) end if ! set merge mask where import field has fillvalue due to non-overlapping model domains ! import_mask will be 1 where valid import exists and 0 where no valid import exists if (secondCall) then - call ESMF_ClockPrint(clock, options='currTime', preString='Setting new import_mask at currTime : ', & - unit=msgString, rc=rc) - call state_getfldptr(importState, trim(fldname), dataptr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - import_mask(:) = 0.0_r4 - mask_local(:) = 1.0_r4 - do jsea = 1, nseal - isea = iaproc + (jsea-1)*naproc - if (real(dataptr(jsea),4) .ge. fillValue) then - mask_local(isea) = 0.0_r4 - end if - end do - call ESMF_VMAllReduce(vm, sendData=mask_local, recvData=import_mask, count=nsea, reduceflag=ESMF_REDUCE_MIN, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockPrint(clock, options='currTime', preString='Setting new import_mask at currTime : ', & + unit=msgString, rc=rc) + call state_getfldptr(importState, trim(fldname), dataptr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + import_mask(:) = 0.0_r4 + mask_local(:) = 1.0_r4 + do jsea = 1, nseal + isea = iaproc + (jsea-1)*naproc + if (real(dataptr(jsea),4) .ge. fillValue) then + mask_local(isea) = 0.0_r4 + end if + end do + call ESMF_VMAllReduce(vm, sendData=mask_local, recvData=import_mask, count=nsea, reduceflag=ESMF_REDUCE_MIN, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) @@ -1500,20 +1536,20 @@ subroutine set_importmask(importState, clock, fldname, vm, rc) end subroutine set_importmask !==================================================================================== -!> Write a netCDF file containing the global field values for debugging -!! -!> @details Write a time-stamped netCDF file containing the values of a global field, -!! where the global_field is provided on either on all points or only nsea points. In -!! either case, the field will be written to the file on the mesh. -!! -!! @param[in] gcomp an ESMF_GridComp object -!! @param[in] fldname a field name -!! @param[in] global_data a global field -!! @param[in] nvals the dimension of global_data -!! @param[out] rc return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Write a netCDF file containing the global field values for debugging + !! + !> @details Write a time-stamped netCDF file containing the values of a global field, + !! where the global_field is provided on either on all points or only nsea points. In + !! either case, the field will be written to the file on the mesh. + !! + !! @param[in] gcomp an ESMF_GridComp object + !! @param[in] fldname a field name + !! @param[in] global_data a global field + !! @param[in] nvals the dimension of global_data + !! @param[out] rc return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine check_globaldata(gcomp, fldname, global_data, nvals, rc) use w3gdatmd, only: nseal, nsea, mapsf, nx, ny @@ -1578,21 +1614,21 @@ subroutine check_globaldata(gcomp, fldname, global_data, nvals, rc) dataptr1d(:) = fillValue if (nvals .eq. nx*ny) then - do jsea = 1, nseal - isea = iaproc + (jsea-1)*naproc - ix = mapsf(isea,1) - iy = mapsf(isea,2) - dataptr1d(jsea) = global_data(ix + (iy-1)*nx) - end do + do jsea = 1, nseal + isea = iaproc + (jsea-1)*naproc + ix = mapsf(isea,1) + iy = mapsf(isea,2) + dataptr1d(jsea) = global_data(ix + (iy-1)*nx) + end do else - do jsea = 1,nseal - isea = iaproc + (jsea-1)*naproc - dataptr1d(jsea) = global_data(isea) - end do + do jsea = 1,nseal + isea = iaproc + (jsea-1)*naproc + dataptr1d(jsea) = global_data(isea) + end do end if call ESMF_FieldWrite(newfield, filename=trim(fldname)//'.'//trim(timestr)//'.nc', & - variableName=trim(fldname), overwrite=.true., rc=rc) + variableName=trim(fldname), overwrite=.true., rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldDestroy(newfield, rc=rc, noGarbage=.true.) @@ -1601,20 +1637,20 @@ subroutine check_globaldata(gcomp, fldname, global_data, nvals, rc) end subroutine check_globaldata !======================================================================== -!> Read input from a file -!! -!> @details Obtain values from a file to fill an import state within a -!! non-overlapped region of the wave domain -!! -!! @param[in] idfld a file name to read -!! @param[in] time0 the initial time -!! @param[in] timen the ending time -!! @param[out] wxdata a 1-D pointer to a zonal wind field -!! @param[out] wydata a 1-D pointer to a meridional wind field -!! @param[out] rc a return code -!! -!> @author U. Turuncoglu, NCAR -!> @date 18-May-2021 + !> Read input from a file + !! + !> @details Obtain values from a file to fill an import state within a + !! non-overlapped region of the wave domain + !! + !! @param[in] idfld a file name to read + !! @param[in] time0 the initial time + !! @param[in] timen the ending time + !! @param[out] wxdata a 1-D pointer to a zonal wind field + !! @param[out] wydata a 1-D pointer to a meridional wind field + !! @param[out] rc a return code + !! + !> @author U. Turuncoglu, NCAR + !> @date 18-May-2021 subroutine readfromfile (idfld, wxdata, wydata, time0, timen, rc) use w3gdatmd, only: nsea, mapsf, gtype, nx, ny @@ -1680,20 +1716,20 @@ subroutine readfromfile (idfld, wxdata, wydata, time0, timen, rc) ! this was inside of w3fldo call but since we are opening file ! once and rewinding, the header need to be read read(mdsf, iostat=ierr) tsstr, tsfld, nxt, nyt, & - gtypet, filler(1:2), tideflag + gtypet, filler(1:2), tideflag ! read input call w3fldg('READ', lstring, mdsf, mdst, mdse, nx, ny, & - nx, ny, time0, timen, tw0l, wx0l, wy0l, dt0l, twnl, & - wxnl, wynl, dtnl, ierr, flagsc) + nx, ny, time0, timen, tw0l, wx0l, wy0l, dt0l, twnl, & + wxnl, wynl, dtnl, ierr, flagsc) wxdata(:) = 0.0_r4 wydata(:) = 0.0_r4 do isea = 1,nsea - ix = mapsf(isea,1) - iy = mapsf(isea,2) - wxdata(isea) = wx0l(ix,iy) - wydata(isea) = wy0l(ix,iy) + ix = mapsf(isea,1) + iy = mapsf(isea,2) + wxdata(isea) = wx0l(ix,iy) + wydata(isea) = wy0l(ix,iy) end do if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) diff --git a/model/src/wav_shel_inp.F90 b/model/src/wav_shel_inp.F90 index 229e65bb0..5a2ed6d29 100644 --- a/model/src/wav_shel_inp.F90 +++ b/model/src/wav_shel_inp.F90 @@ -213,18 +213,18 @@ subroutine read_shel_config(mpi_comm, mds, time0_overwrite, timen_overwrite) ndsm = 17 inquire(unit=ndsm, opened=is_open) if (is_open) then - call extcde (60, msg='unit ndsm is already in use ') + call extcde (60, msg='unit ndsm is already in use ') end if ndss = 90 inquire(unit=ndss, opened=is_open) if (is_open) then - call extcde (60, msg='unit ndss is already in use ') + call extcde (60, msg='unit ndss is already in use ') end if ! naperr is set in InitializeRealize if ( iaproc .eq. naperr ) then - ndsen = ndse + ndsen = ndse else - ndsen = -1 + ndsen = -1 end if #ifdef W3_OMPH if ( iaproc .eq. napout ) write (ndso,905) MPI_THREAD_FUNNELED, thrlev @@ -260,505 +260,505 @@ subroutine read_shel_config(mpi_comm, mds, time0_overwrite, timen_overwrite) inquire(file=trim(fnmpre)//"ww3_shel.nml", exist=flgnml) if (flgnml) then - open(newunit=ndsi, file=trim(fnmpre)//"ww3_shel.nml", status='old', iostat=ierr) - - !-------------------- - ! Read namelist - !-------------------- - - call w3nmlshel (mpi_comm, ndsi, trim(fnmpre)//'ww3_shel.nml', & - nml_domain, nml_input, nml_output_type, & - nml_output_date, nml_homog_count, & - nml_homog_input, ierr) - - !-------------------- - ! 2.1 forcing flags - !-------------------- - - flh(-7:10) = .false. - flagtfc(-7) = trim(nml_input%forcing%ice_param1) - flagtfc(-6) = trim(nml_input%forcing%ice_param2) - flagtfc(-5) = trim(nml_input%forcing%ice_param3) - flagtfc(-4) = trim(nml_input%forcing%ice_param4) - flagtfc(-3) = trim(nml_input%forcing%ice_param5) - flagtfc(-2) = trim(nml_input%forcing%mud_density) - flagtfc(-1) = trim(nml_input%forcing%mud_thickness) - flagtfc(0) = trim(nml_input%forcing%mud_viscosity) - flagtfc(1) = trim(nml_input%forcing%water_levels) - flagtfc(2) = trim(nml_input%forcing%currents) - flagtfc(3) = trim(nml_input%forcing%winds) - flagtfc(4) = trim(nml_input%forcing%ice_conc) - flagtfc(5) = trim(nml_input%forcing%atm_momentum) - flagtfc(6) = trim(nml_input%forcing%air_density) - flagtfc(7) = trim(nml_input%assim%mean) - flagtfc(8) = trim(nml_input%assim%spec1d) - flagtfc(9) = trim(nml_input%assim%spec2d) - - if (trim(nml_input%forcing%ice_param1) .eq. 'H') then - flagtfc(-7)='T' - flh(-7)=.true. - end if - if (trim(nml_input%forcing%ice_param2) .eq. 'H') THEN - flagtfc(-6)='T' - flh(-6)=.true. - end if - if (trim(nml_input%forcing%ice_param3) .eq. 'H') THEN - flagtfc(-5)='T' - flh(-5)=.true. - end if - if (trim(nml_input%forcing%ice_param4) .eq. 'H') THEN - flagtfc(-4)='T' - flh(-4)=.true. - end if - if (trim(nml_input%forcing%ice_param5) .eq. 'H') THEN - flagtfc(-3)='T' - flh(-3)=.true. - end if - if (trim(nml_input%forcing%mud_density) .eq. 'H') THEN - flagtfc(-2)='T' - flh(-2)=.true. - end if - if (trim(nml_input%forcing%mud_thickness) .eq. 'H') THEN - flagtfc(-1)='T' - flh(-1)=.true. - end if - if (trim(nml_input%forcing%mud_viscosity) .eq. 'H') THEN - flagtfc(0)='T' - flh(0)=.true. - end if - if (trim(nml_input%forcing%water_levels) .eq. 'H') THEN - flagtfc(1)='T' - flh(1)=.true. - end if - if (trim(nml_input%forcing%currents) .eq. 'H') THEN - flagtfc(2)='T' - flh(2)=.true. - end if - if (trim(nml_input%forcing%winds) .eq. 'H') THEN - flagtfc(3)='T' - flh(3)=.true. - end if - if (trim(nml_input%forcing%ice_conc) .eq. 'H') THEN - flagtfc(4)='T' - flh(4)=.true. - end if - if (trim(nml_input%forcing%atm_momentum) .eq. 'H') THEN - flagtfc(5)='T' - flh(5)=.true. - end if - if (trim(nml_input%forcing%air_density) .eq. 'H') THEN - flagtfc(6)='T' - flh(6)=.true. - end if - - if ( iaproc .eq. napout ) write (ndso, 920) - DO J=JFIRST, 9 - if (flagtfc(j).eq.'T') THEN - inflags1(j)=.true. - flagsc(j)=.false. - end if - if (flagtfc(j).eq.'F') THEN - inflags1(j)=.false. - flagsc(j)=.false. - end if - if (flagtfc(j).eq.'C') THEN - inflags1(j)=.true. - flagsc(j)=.true. - end if - if ( j .le. 6 ) then - flh(j) = flh(j) .and. inflags1(j) - end if - if ( inflags1(j) ) then - yesxno = 'YES/--' - else - yesxno = '---/NO' - end IF - if ( flh(j) ) then - strng = '(homogeneous field) ' - else if ( flagsc(j) ) then - strng = '(coupling field) ' - else - strng = ' ' - end if - if ( iaproc .eq. napout ) write (ndso,921) idflds(j), yesxno, strng - end do - if (w3_cou_flag) then - if (flagsc(1) .and. inflags1(2) .and. .not. flagsc(2)) goto 2102 - if (flagsc(2) .and. inflags1(1) .and. .not. flagsc(1)) goto 2102 - end if - - inflags1(10) = .false. - if (w3_mgw_flag .or. w3_mgp_flag) then - inflags1(10) = .true. - flh(10) = .true. - end if - if ( inflags1(10) .and. iaproc.eq.napout ) & - write (ndso,921) idflds(10), 'yes/--', ' ' - - flflg = inflags1(-7) .or. inflags1(-6) .or. inflags1(-5) .or. inflags1(-4) & - .or. inflags1(-3) .or. inflags1(-2) .or. inflags1(-1) & - .or. inflags1(0) .or. inflags1(1) .or. inflags1(2) & - .or. inflags1(3) .or. inflags1(4) .or. inflags1(5) & - .or. inflags1(6) .or. inflags1(7) .or. inflags1(8) & - .or. inflags1(9) - flhom = flh(-7) .or. flh(-6) .or. flh(-5) .or. flh(-4) & - .or. flh(-3) .or. flh(-2) .or. flh(-1) .or. flh(0) & - .or. flh(1) .or. flh(2) .or. flh(3) .or. flh(4) & - .or. flh(5) .or. flh(6) .or. flh(10) - - if ( iaproc .eq. napout ) write (ndso,922) - ! inflags2 is just "initial value of inflags1", i.e. does *not* get - ! changed when model reads last record of ice.ww3 - inflags2=inflags1 - if (w3_t_flag) then - write (ndst,9020) flflg, inflags1, flhom, flh - end if - - !-------------------- - ! 2.2 Time setup - !-------------------- - - read (nml_domain%start,*) time0 - call t2d(time0,startdate,ierr) - call d2j(startdate,startjulday,ierr) - read(nml_domain%stop,*) timen - call t2d(timen,stopdate,ierr) - call d2j(stopdate,stopjulday,ierr) - - !-------------------- - ! 2.3 Domain setup - !-------------------- - - iostyp = nml_domain%iostyp - if (w3_pdlib_flag) then - if (iostyp .gt. 1) then - write(*,*) 'iostyp not supported in domain decomposition mode' - call extcde ( 6666 ) - endif - end if - - call w3iogr ( 'GRID', ndsm ) - if ( flagll ) then - factor = 1. - else - factor = 1.e-3 - end if - - !-------------------- - ! 2.4 Output dates - !-------------------- - - read(nml_output_date%field%start, *) odat(1), odat(2) - read(nml_output_date%field%stride, *) odat(3) - read(nml_output_date%field%stop, *) odat(4), odat(5) - - read(nml_output_date%field%outffile, *) ofiles(1) - ! outpts(i)%outstride(1)=odat(3,i) - - read(nml_output_date%point%start, *) odat(6), odat(7) - read(nml_output_date%point%stride, *) odat(8) - read(nml_output_date%point%stop, *) odat(9), odat(10) - - read(nml_output_date%point%outffile, *) ofiles(2) - ! outpts(i)%outstride(2)=odat(8,i) - - read(nml_output_date%track%start, *) odat(11), odat(12) - read(nml_output_date%track%stride, *) odat(13) - read(nml_output_date%track%stop, *) odat(14), odat(15) - - read(nml_output_date%restart%start, *) odat(16), odat(17) - read(nml_output_date%restart%stride, *) odat(18) - read(nml_output_date%restart%stop, *) odat(19), odat(20) - - read(nml_output_date%restart2%start, *) odat(36), odat(37) - read(nml_output_date%restart2%stride, *) odat(38) - read(nml_output_date%restart2%stop, *) odat(39), odat(40) - - read(nml_output_date%boundary%start, *) odat(21), odat(22) - read(nml_output_date%boundary%stride, *) odat(23) - read(nml_output_date%boundary%stop, *) odat(24), odat(25) - - read(nml_output_date%partition%start, *) odat(26), odat(27) - read(nml_output_date%partition%stride, *) odat(28) - read(nml_output_date%partition%stop, *) odat(29), odat(30) - - read(nml_output_date%coupling%start, *) odat(31), odat(32) - read(nml_output_date%coupling%stride, *) odat(33) - read(nml_output_date%coupling%stop, *) odat(34), odat(35) - - ! set the time stride at 0 or more - odat(3) = max ( 0 , odat(3) ) - odat(8) = max ( 0 , odat(8) ) - odat(13) = max ( 0 , odat(13) ) - odat(18) = max ( 0 , odat(18) ) - odat(23) = max ( 0 , odat(23) ) - odat(28) = max ( 0 , odat(28) ) - odat(33) = max ( 0 , odat(33) ) - odat(38) = max ( 0 , odat(38) ) - - if (w3_cou_flag) then - ! test the validity of the coupling time step - if (odat(33) == 0) then - if ( iaproc .eq. napout ) then - write(ndso,1010) odat(33), int(dtmax) - end if - odat(33) = int(dtmax) - else if (mod(odat(33),int(dtmax)) .ne. 0) then - goto 2009 + open(newunit=ndsi, file=trim(fnmpre)//"ww3_shel.nml", status='old', iostat=ierr) + + !-------------------- + ! Read namelist + !-------------------- + + call w3nmlshel (mpi_comm, ndsi, trim(fnmpre)//'ww3_shel.nml', & + nml_domain, nml_input, nml_output_type, & + nml_output_date, nml_homog_count, & + nml_homog_input, ierr) + + !-------------------- + ! 2.1 forcing flags + !-------------------- + + flh(-7:10) = .false. + flagtfc(-7) = trim(nml_input%forcing%ice_param1) + flagtfc(-6) = trim(nml_input%forcing%ice_param2) + flagtfc(-5) = trim(nml_input%forcing%ice_param3) + flagtfc(-4) = trim(nml_input%forcing%ice_param4) + flagtfc(-3) = trim(nml_input%forcing%ice_param5) + flagtfc(-2) = trim(nml_input%forcing%mud_density) + flagtfc(-1) = trim(nml_input%forcing%mud_thickness) + flagtfc(0) = trim(nml_input%forcing%mud_viscosity) + flagtfc(1) = trim(nml_input%forcing%water_levels) + flagtfc(2) = trim(nml_input%forcing%currents) + flagtfc(3) = trim(nml_input%forcing%winds) + flagtfc(4) = trim(nml_input%forcing%ice_conc) + flagtfc(5) = trim(nml_input%forcing%atm_momentum) + flagtfc(6) = trim(nml_input%forcing%air_density) + flagtfc(7) = trim(nml_input%assim%mean) + flagtfc(8) = trim(nml_input%assim%spec1d) + flagtfc(9) = trim(nml_input%assim%spec2d) + + if (trim(nml_input%forcing%ice_param1) .eq. 'H') then + flagtfc(-7)='T' + flh(-7)=.true. + end if + if (trim(nml_input%forcing%ice_param2) .eq. 'H') THEN + flagtfc(-6)='T' + flh(-6)=.true. + end if + if (trim(nml_input%forcing%ice_param3) .eq. 'H') THEN + flagtfc(-5)='T' + flh(-5)=.true. + end if + if (trim(nml_input%forcing%ice_param4) .eq. 'H') THEN + flagtfc(-4)='T' + flh(-4)=.true. + end if + if (trim(nml_input%forcing%ice_param5) .eq. 'H') THEN + flagtfc(-3)='T' + flh(-3)=.true. + end if + if (trim(nml_input%forcing%mud_density) .eq. 'H') THEN + flagtfc(-2)='T' + flh(-2)=.true. + end if + if (trim(nml_input%forcing%mud_thickness) .eq. 'H') THEN + flagtfc(-1)='T' + flh(-1)=.true. + end if + if (trim(nml_input%forcing%mud_viscosity) .eq. 'H') THEN + flagtfc(0)='T' + flh(0)=.true. + end if + if (trim(nml_input%forcing%water_levels) .eq. 'H') THEN + flagtfc(1)='T' + flh(1)=.true. + end if + if (trim(nml_input%forcing%currents) .eq. 'H') THEN + flagtfc(2)='T' + flh(2)=.true. + end if + if (trim(nml_input%forcing%winds) .eq. 'H') THEN + flagtfc(3)='T' + flh(3)=.true. + end if + if (trim(nml_input%forcing%ice_conc) .eq. 'H') THEN + flagtfc(4)='T' + flh(4)=.true. + end if + if (trim(nml_input%forcing%atm_momentum) .eq. 'H') THEN + flagtfc(5)='T' + flh(5)=.true. + end if + if (trim(nml_input%forcing%air_density) .eq. 'H') THEN + flagtfc(6)='T' + flh(6)=.true. + end if + + if ( iaproc .eq. napout ) write (ndso, 920) + DO J=JFIRST, 9 + if (flagtfc(j).eq.'T') THEN + inflags1(j)=.true. + flagsc(j)=.false. + end if + if (flagtfc(j).eq.'F') THEN + inflags1(j)=.false. + flagsc(j)=.false. + end if + if (flagtfc(j).eq.'C') THEN + inflags1(j)=.true. + flagsc(j)=.true. + end if + if ( j .le. 6 ) then + flh(j) = flh(j) .and. inflags1(j) + end if + if ( inflags1(j) ) then + yesxno = 'YES/--' + else + yesxno = '---/NO' + end IF + if ( flh(j) ) then + strng = '(homogeneous field) ' + else if ( flagsc(j) ) then + strng = '(coupling field) ' + else + strng = ' ' + end if + if ( iaproc .eq. napout ) write (ndso,921) idflds(j), yesxno, strng + end do + if (w3_cou_flag) then + if (flagsc(1) .and. inflags1(2) .and. .not. flagsc(2)) goto 2102 + if (flagsc(2) .and. inflags1(1) .and. .not. flagsc(1)) goto 2102 + end if + + inflags1(10) = .false. + if (w3_mgw_flag .or. w3_mgp_flag) then + inflags1(10) = .true. + flh(10) = .true. + end if + if ( inflags1(10) .and. iaproc.eq.napout ) & + write (ndso,921) idflds(10), 'yes/--', ' ' + + flflg = inflags1(-7) .or. inflags1(-6) .or. inflags1(-5) .or. inflags1(-4) & + .or. inflags1(-3) .or. inflags1(-2) .or. inflags1(-1) & + .or. inflags1(0) .or. inflags1(1) .or. inflags1(2) & + .or. inflags1(3) .or. inflags1(4) .or. inflags1(5) & + .or. inflags1(6) .or. inflags1(7) .or. inflags1(8) & + .or. inflags1(9) + flhom = flh(-7) .or. flh(-6) .or. flh(-5) .or. flh(-4) & + .or. flh(-3) .or. flh(-2) .or. flh(-1) .or. flh(0) & + .or. flh(1) .or. flh(2) .or. flh(3) .or. flh(4) & + .or. flh(5) .or. flh(6) .or. flh(10) + + if ( iaproc .eq. napout ) write (ndso,922) + ! inflags2 is just "initial value of inflags1", i.e. does *not* get + ! changed when model reads last record of ice.ww3 + inflags2=inflags1 + if (w3_t_flag) then + write (ndst,9020) flflg, inflags1, flhom, flh + end if + + !-------------------- + ! 2.2 Time setup + !-------------------- + + read (nml_domain%start,*) time0 + call t2d(time0,startdate,ierr) + call d2j(startdate,startjulday,ierr) + read(nml_domain%stop,*) timen + call t2d(timen,stopdate,ierr) + call d2j(stopdate,stopjulday,ierr) + + !-------------------- + ! 2.3 Domain setup + !-------------------- + + iostyp = nml_domain%iostyp + if (w3_pdlib_flag) then + if (iostyp .gt. 1) then + write(*,*) 'iostyp not supported in domain decomposition mode' + call extcde ( 6666 ) + endif + end if + + call w3iogr ( 'GRID', ndsm ) + if ( flagll ) then + factor = 1. + else + factor = 1.e-3 + end if + + !-------------------- + ! 2.4 Output dates + !-------------------- + + read(nml_output_date%field%start, *) odat(1), odat(2) + read(nml_output_date%field%stride, *) odat(3) + read(nml_output_date%field%stop, *) odat(4), odat(5) + + read(nml_output_date%field%outffile, *) ofiles(1) + ! outpts(i)%outstride(1)=odat(3,i) + + read(nml_output_date%point%start, *) odat(6), odat(7) + read(nml_output_date%point%stride, *) odat(8) + read(nml_output_date%point%stop, *) odat(9), odat(10) + + read(nml_output_date%point%outffile, *) ofiles(2) + ! outpts(i)%outstride(2)=odat(8,i) + + read(nml_output_date%track%start, *) odat(11), odat(12) + read(nml_output_date%track%stride, *) odat(13) + read(nml_output_date%track%stop, *) odat(14), odat(15) + + read(nml_output_date%restart%start, *) odat(16), odat(17) + read(nml_output_date%restart%stride, *) odat(18) + read(nml_output_date%restart%stop, *) odat(19), odat(20) + + read(nml_output_date%restart2%start, *) odat(36), odat(37) + read(nml_output_date%restart2%stride, *) odat(38) + read(nml_output_date%restart2%stop, *) odat(39), odat(40) + + read(nml_output_date%boundary%start, *) odat(21), odat(22) + read(nml_output_date%boundary%stride, *) odat(23) + read(nml_output_date%boundary%stop, *) odat(24), odat(25) + + read(nml_output_date%partition%start, *) odat(26), odat(27) + read(nml_output_date%partition%stride, *) odat(28) + read(nml_output_date%partition%stop, *) odat(29), odat(30) + + read(nml_output_date%coupling%start, *) odat(31), odat(32) + read(nml_output_date%coupling%stride, *) odat(33) + read(nml_output_date%coupling%stop, *) odat(34), odat(35) + + ! set the time stride at 0 or more + odat(3) = max ( 0 , odat(3) ) + odat(8) = max ( 0 , odat(8) ) + odat(13) = max ( 0 , odat(13) ) + odat(18) = max ( 0 , odat(18) ) + odat(23) = max ( 0 , odat(23) ) + odat(28) = max ( 0 , odat(28) ) + odat(33) = max ( 0 , odat(33) ) + odat(38) = max ( 0 , odat(38) ) + + if (w3_cou_flag) then + ! test the validity of the coupling time step + if (odat(33) == 0) then + if ( iaproc .eq. napout ) then + write(ndso,1010) odat(33), int(dtmax) end if - end if - - !-------------------- - ! 2.5 Output types - !-------------------- - - npts = 0 - notype = 6 - if (w3_cou_flag) then - notype = 7 - end if - do j = 1, notype - - ! outpts(i)%ofiles(j)=ofiles(j) - if ( odat(5*(j-1)+3) .ne. 0 ) then - - if ( j .eq. 1 ) then - - ! type 1: fields of mean wave parameters - fldout = nml_output_type%field%list - call w3flgrdflag ( ndso, ndso, ndse, fldout, flgd, flgrd, iaproc, napout, ierr ) - if ( ierr .ne. 0 ) goto 2222 - - else if ( j .eq. 2 ) then - - ! type 2: point output - open (newunit=ndsl, file=trim(fnmpre)//trim(nml_output_type%point%file), & - form='formatted', status='old', err=2104, iostat=ierr) - - ! first loop to count the number of points - ! second loop to allocate the array and store the points - ipts = 0 - do iloop=1,2 - rewind (ndsl) - - if ( iloop.eq.2) then - npts = ipts - if ( npts.gt.0 ) then - allocate ( x(npts), y(npts), pnames(npts) ) - ipts = 0 ! reset counter to be reused for next do loop + odat(33) = int(dtmax) + else if (mod(odat(33),int(dtmax)) .ne. 0) then + goto 2009 + end if + end if + + !-------------------- + ! 2.5 Output types + !-------------------- + + npts = 0 + notype = 6 + if (w3_cou_flag) then + notype = 7 + end if + do j = 1, notype + + ! outpts(i)%ofiles(j)=ofiles(j) + if ( odat(5*(j-1)+3) .ne. 0 ) then + + if ( j .eq. 1 ) then + + ! type 1: fields of mean wave parameters + fldout = nml_output_type%field%list + call w3flgrdflag ( ndso, ndso, ndse, fldout, flgd, flgrd, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 + + else if ( j .eq. 2 ) then + + ! type 2: point output + open (newunit=ndsl, file=trim(fnmpre)//trim(nml_output_type%point%file), & + form='formatted', status='old', err=2104, iostat=ierr) + + ! first loop to count the number of points + ! second loop to allocate the array and store the points + ipts = 0 + do iloop=1,2 + rewind (ndsl) + + if ( iloop.eq.2) then + npts = ipts + if ( npts.gt.0 ) then + allocate ( x(npts), y(npts), pnames(npts) ) + ipts = 0 ! reset counter to be reused for next do loop + else + allocate ( x(1), y(1), pnames(1) ) + goto 2054 + end if + end if + + do + read (ndsl,*,err=2004,iostat=ierr) tmpline + ! if end of file or stopstring, then exit + if ( ierr.ne.0 .or. index(tmpline,"STOPSTRING").ne.0 ) exit + + ! leading blanks removed and placed on the right + test = adjustl ( tmpline ) + if ( test(1:1).eq.comstr .or. len_trim(test).eq.0 ) then + ! if comment or blank line, then skip + cycle + else + ! otherwise, backup to beginning of line + backspace ( ndsl, err=2004, iostat=ierr) + read (ndsl,*,err=2004,iostat=ierr) xx, yy, pn + end if + ipts = ipts + 1 + if ( iloop .eq. 1 ) cycle + if ( iloop .eq. 2 ) then + x(ipts) = xx + y(ipts) = yy + pnames(ipts) = pn + if ( iaproc .eq. napout ) then + if ( flagll ) then + if ( ipts .eq. 1 ) then + write (ndso,2945) factor*xx, factor*yy, pn else - allocate ( x(1), y(1), pnames(1) ) - goto 2054 + write (ndso,2946) ipts, factor*xx, factor*yy, pn end if - end if - - do - read (ndsl,*,err=2004,iostat=ierr) tmpline - ! if end of file or stopstring, then exit - if ( ierr.ne.0 .or. index(tmpline,"STOPSTRING").ne.0 ) exit - - ! leading blanks removed and placed on the right - test = adjustl ( tmpline ) - if ( test(1:1).eq.comstr .or. len_trim(test).eq.0 ) then - ! if comment or blank line, then skip - cycle + else + if ( ipts .eq. 1 ) then + write (ndso,2955) factor*xx, factor*yy, pn else - ! otherwise, backup to beginning of line - backspace ( ndsl, err=2004, iostat=ierr) - read (ndsl,*,err=2004,iostat=ierr) xx, yy, pn + write (ndso,2956) ipts, factor*xx, factor*yy, pn end if - ipts = ipts + 1 - if ( iloop .eq. 1 ) cycle - if ( iloop .eq. 2 ) then - x(ipts) = xx - y(ipts) = yy - pnames(ipts) = pn - if ( iaproc .eq. napout ) then - if ( flagll ) then - if ( ipts .eq. 1 ) then - write (ndso,2945) factor*xx, factor*yy, pn - else - write (ndso,2946) ipts, factor*xx, factor*yy, pn - end if - else - if ( ipts .eq. 1 ) then - write (ndso,2955) factor*xx, factor*yy, pn - else - write (ndso,2956) ipts, factor*xx, factor*yy, pn - end if - end if - end if - end if ! iloop.eq.2 - end do ! end of file - end do ! iloop - close(ndsl) - - else if ( j .eq. 3 ) then - - ! Type 3: track output - tflagi = nml_output_type%track%format - if ( .not. tflagi ) nds(11) = -nds(11) - if ( iaproc .eq. napout ) then - if ( .not. tflagi ) then - write (ndso,3945) 'input', 'unformatted' - else - write (ndso,3945) 'input', 'formatted' - end if - end if - - else if ( j .eq. 6 ) then - - ! Type 6: partitioning - iprt(1) = nml_output_type%partition%x0 - iprt(2) = nml_output_type%partition%xn - iprt(3) = nml_output_type%partition%nx - iprt(4) = nml_output_type%partition%y0 - iprt(5) = nml_output_type%partition%yn - iprt(6) = nml_output_type%partition%ny - prtfrm = nml_output_type%partition%format - - if ( iaproc .eq. napout ) then - if ( prtfrm ) then - yesxno = 'YES/--' - else - yesxno = '---/NO' - end if - write (ndso,6945) iprt, yesxno - end if - - else if ( j .eq. 7 ) then + end if + end if + end if ! iloop.eq.2 + end do ! end of file + end do ! iloop + close(ndsl) + + else if ( j .eq. 3 ) then + + ! Type 3: track output + tflagi = nml_output_type%track%format + if ( .not. tflagi ) nds(11) = -nds(11) + if ( iaproc .eq. napout ) then + if ( .not. tflagi ) then + write (ndso,3945) 'input', 'unformatted' + else + write (ndso,3945) 'input', 'formatted' + end if + end if + + else if ( j .eq. 6 ) then + + ! Type 6: partitioning + iprt(1) = nml_output_type%partition%x0 + iprt(2) = nml_output_type%partition%xn + iprt(3) = nml_output_type%partition%nx + iprt(4) = nml_output_type%partition%y0 + iprt(5) = nml_output_type%partition%yn + iprt(6) = nml_output_type%partition%ny + prtfrm = nml_output_type%partition%format + + if ( iaproc .eq. napout ) then + if ( prtfrm ) then + yesxno = 'YES/--' + else + yesxno = '---/NO' + end if + write (ndso,6945) iprt, yesxno + end if + + else if ( j .eq. 7 ) then #ifdef W3_COU - ! Type 7: coupling - fldout = nml_output_type%coupling%sent - call w3flgrdflag ( ndso, ndso, ndse, fldout, flg2, flgr2, iaproc, napout, ierr ) - if ( ierr .ne. 0 ) goto 2222 - fldin = nml_output_type%coupling%received - cplt0 = nml_output_type%coupling%couplet0 + ! Type 7: coupling + fldout = nml_output_type%coupling%sent + call w3flgrdflag ( ndso, ndso, ndse, fldout, flg2, flgr2, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 + fldin = nml_output_type%coupling%received + cplt0 = nml_output_type%coupling%couplet0 #endif - end if ! j - end if ! odat - end do ! j - - ! Extra fields to be written in the restart - fldrst = nml_output_type%restart%extra - call w3flgrdflag ( ndso, ndso, ndse, fldrst, flogr, flogrr, iaproc, napout, ierr ) - if ( ierr .ne. 0 ) goto 2222 - - ! force minimal allocation to avoid memory seg fault - if ( .not.allocated(x) .and. npts.eq.0 ) allocate ( x(1), y(1), pnames(1) ) - - !-------------------- - ! 2.6 Homogeneous field data - !-------------------- - - if ( flhom ) then - if ( iaproc .eq. napout ) write (ndso,951) & - 'Homogeneous field data (and moving grid) ...' - - nh(-7) = nml_homog_count%n_ic1 - nh(-6) = nml_homog_count%n_ic2 - nh(-5) = nml_homog_count%n_ic3 - nh(-4) = nml_homog_count%n_ic4 - nh(-3) = nml_homog_count%n_ic5 - nh(-2) = nml_homog_count%n_mdn - nh(-1) = nml_homog_count%n_mth - nh(0) = nml_homog_count%n_mvs - nh(1) = nml_homog_count%n_lev - nh(2) = nml_homog_count%n_cur - nh(3) = nml_homog_count%n_wnd - nh(4) = nml_homog_count%n_ice - nh(5) = nml_homog_count%n_tau - nh(6) = nml_homog_count%n_rho - nh(10) = nml_homog_count%n_mov - - n_tot = nml_homog_count%n_tot - - do j=jfirst,10 - if ( nh(j) .gt. nhmax ) goto 2006 + end if ! j + end if ! odat + end do ! j + + ! Extra fields to be written in the restart + fldrst = nml_output_type%restart%extra + call w3flgrdflag ( ndso, ndso, ndse, fldrst, flogr, flogrr, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 + + ! force minimal allocation to avoid memory seg fault + if ( .not.allocated(x) .and. npts.eq.0 ) allocate ( x(1), y(1), pnames(1) ) + + !-------------------- + ! 2.6 Homogeneous field data + !-------------------- + + if ( flhom ) then + if ( iaproc .eq. napout ) write (ndso,951) & + 'Homogeneous field data (and moving grid) ...' + + nh(-7) = nml_homog_count%n_ic1 + nh(-6) = nml_homog_count%n_ic2 + nh(-5) = nml_homog_count%n_ic3 + nh(-4) = nml_homog_count%n_ic4 + nh(-3) = nml_homog_count%n_ic5 + nh(-2) = nml_homog_count%n_mdn + nh(-1) = nml_homog_count%n_mth + nh(0) = nml_homog_count%n_mvs + nh(1) = nml_homog_count%n_lev + nh(2) = nml_homog_count%n_cur + nh(3) = nml_homog_count%n_wnd + nh(4) = nml_homog_count%n_ice + nh(5) = nml_homog_count%n_tau + nh(6) = nml_homog_count%n_rho + nh(10) = nml_homog_count%n_mov + + n_tot = nml_homog_count%n_tot + + do j=jfirst,10 + if ( nh(j) .gt. nhmax ) goto 2006 + end do + + ! Store homogeneous fields + if ( n_tot .gt. 0 ) then + ihh(:)=0 + do ih=1,n_tot + read(nml_homog_input(ih)%name,*) idtst + select case (idtst) + case ('IC1') + j=-7 + case ('IC2') + j=-6 + case ('IC3') + j=-5 + case ('IC4') + j=-4 + case ('IC5') + j=-3 + case ('MDN') + j=-2 + case ('MTH') + j=-1 + case ('MVS') + j=0 + case ('LEV') + j=1 + case ('CUR') + j=2 + case ('WND') + j=3 + case ('ICE') + j=4 + case ('TAU') + j=5 + case ('RHO') + j=6 + case ('MOV') + j=10 + case DEFAULT + goto 2062 + end SELECT + ihh(j)=ihh(j)+1 + read(nml_homog_input(ih)%date,*) tho(:,j,ihh(j)) + ha(ihh(j),j) = nml_homog_input(ih)%value1 + hd(ihh(j),j) = nml_homog_input(ih)%value2 + hs(ihh(j),j) = nml_homog_input(ih)%value3 end do - - ! Store homogeneous fields - if ( n_tot .gt. 0 ) then - ihh(:)=0 - do ih=1,n_tot - read(nml_homog_input(ih)%name,*) idtst - select case (idtst) - case ('IC1') - j=-7 - case ('IC2') - j=-6 - case ('IC3') - j=-5 - case ('IC4') - j=-4 - case ('IC5') - j=-3 - case ('MDN') - j=-2 - case ('MTH') - j=-1 - case ('MVS') - j=0 - case ('LEV') - j=1 - case ('CUR') - j=2 - case ('WND') - j=3 - case ('ICE') - j=4 - case ('TAU') - j=5 - case ('RHO') - j=6 - case ('MOV') - j=10 - case DEFAULT - goto 2062 - end SELECT - ihh(j)=ihh(j)+1 - read(nml_homog_input(ih)%date,*) tho(:,j,ihh(j)) - ha(ihh(j),j) = nml_homog_input(ih)%value1 - hd(ihh(j),j) = nml_homog_input(ih)%value2 - hs(ihh(j),j) = nml_homog_input(ih)%value3 - end do - end if - - if (w3_o7_flag) then - do j=jfirst, 10 - if ( flh(j) .and. iaproc.eq.napout ) then - write (ndso,952) nh(j), idflds(j) - do i=1, nh(j) - if ( ( j .le. 1 ) .or. ( j .eq. 4 ) .or. ( j .eq. 6 ) ) then - write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j) - else if ( ( j .eq. 2 ) .or. ( j .eq. 5 ) .or. ( j .eq. 10 ) ) then - write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j) - else if ( j .eq. 3 ) then - write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j), hs(i,j) - end if - end do + end if + + if (w3_o7_flag) then + do j=jfirst, 10 + if ( flh(j) .and. iaproc.eq.napout ) then + write (ndso,952) nh(j), idflds(j) + do i=1, nh(j) + if ( ( j .le. 1 ) .or. ( j .eq. 4 ) .or. ( j .eq. 6 ) ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j) + else if ( ( j .eq. 2 ) .or. ( j .eq. 5 ) .or. ( j .eq. 10 ) ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j) + else if ( j .eq. 3 ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j), hs(i,j) end if - end do - end if - - if ( ( flh(-7) .and. (nh(-7).eq.0) ) .or. & - ( flh(-6) .and. (nh(-6).eq.0) ) .or. & - ( flh(-5) .and. (nh(-5).eq.0) ) .or. & - ( flh(-4) .and. (nh(-4).eq.0) ) .or. & - ( flh(-3) .and. (nh(-3).eq.0) ) .or. & - ( flh(-2) .and. (nh(-2).eq.0) ) .or. & - ( flh(-1) .and. (nh(-1).eq.0) ) .or. & - ( flh(0) .and. (nh(0).eq.0) ) .or. & - ( flh(1) .and. (nh(1).eq.0) ) .or. & - ( flh(2) .and. (nh(2).eq.0) ) .or. & - ( flh(3) .and. (nh(3).eq.0) ) .or. & - ( flh(4) .and. (nh(4).eq.0) ) .or. & - ( flh(5) .and. (nh(5).eq.0) ) .or. & - ( flh(6) .and. (nh(6).eq.0) ) .or. & - ( flh(10) .and. (nh(10).eq.0) ) ) goto 2007 - - end if ! flhom + end do + end if + end do + end if + + if ( ( flh(-7) .and. (nh(-7).eq.0) ) .or. & + ( flh(-6) .and. (nh(-6).eq.0) ) .or. & + ( flh(-5) .and. (nh(-5).eq.0) ) .or. & + ( flh(-4) .and. (nh(-4).eq.0) ) .or. & + ( flh(-3) .and. (nh(-3).eq.0) ) .or. & + ( flh(-2) .and. (nh(-2).eq.0) ) .or. & + ( flh(-1) .and. (nh(-1).eq.0) ) .or. & + ( flh(0) .and. (nh(0).eq.0) ) .or. & + ( flh(1) .and. (nh(1).eq.0) ) .or. & + ( flh(2) .and. (nh(2).eq.0) ) .or. & + ( flh(3) .and. (nh(3).eq.0) ) .or. & + ( flh(4) .and. (nh(4).eq.0) ) .or. & + ( flh(5) .and. (nh(5).eq.0) ) .or. & + ( flh(6) .and. (nh(6).eq.0) ) .or. & + ( flh(10) .and. (nh(10).eq.0) ) ) goto 2007 + + end if ! flhom end if ! flgnml @@ -769,466 +769,466 @@ subroutine read_shel_config(mpi_comm, mds, time0_overwrite, timen_overwrite) ! if (.not. flgnml) then - call print_logmsg(740+IAPROC, ' fnmpre'//trim(fnmpre), w3_debuginit_flag) - open (newunit=ndsi,file=trim(fnmpre)//'ww3_shel.inp',status='old',iostat=ierr) - rewind (ndsi) - - read (ndsi,'(a)') comstr - if (comstr.eq.' ') comstr = '$' - if ( iaproc .eq. napout ) write (ndso,901) comstr - - !-------------------- - ! 2.1 forcing flags - !-------------------- - - call print_logmsg(740+IAPROC, '2.1 Forcing flags', w3_debuginit_flag) - flh(-7:10) = .false. - do j=jfirst, 9 - call nextln ( comstr , ndsi , ndsen ) - if ( j .le. 6 ) then - read (ndsi,*) flagtfc(j), flh(j) - else - read (ndsi,*) flagtfc(j) - end if - write(msg1,*)' J=', j, ' FLAGTFC=', flagtfc(j), ' FLH=', flh(j) - call print_logmsg(740+IAPROC, trim(msg1), w3_debuginit_flag) - end do - - if ( iaproc .eq. napout ) write (ndso,920) - do j=jfirst, 9 - if (flagtfc(j).eq.'T') then - inflags1(j)=.true. - flagsc(j)=.false. - end if - if (flagtfc(j).eq.'F') then - inflags1(j)=.false. - flagsc(j)=.false. - end if - if (flagtfc(j).eq.'C') then - inflags1(j)=.true. - flagsc(j)=.true. - end if - if ( j .le. 6 ) then - flh(j) = flh(j) .and. inflags1(j) - end if - if ( inflags1(j) ) then - yesxno = 'YES/--' - else - yesxno = '---/NO' + call print_logmsg(740+IAPROC, ' fnmpre'//trim(fnmpre), w3_debuginit_flag) + open (newunit=ndsi,file=trim(fnmpre)//'ww3_shel.inp',status='old',iostat=ierr) + rewind (ndsi) + + read (ndsi,'(a)') comstr + if (comstr.eq.' ') comstr = '$' + if ( iaproc .eq. napout ) write (ndso,901) comstr + + !-------------------- + ! 2.1 forcing flags + !-------------------- + + call print_logmsg(740+IAPROC, '2.1 Forcing flags', w3_debuginit_flag) + flh(-7:10) = .false. + do j=jfirst, 9 + call nextln ( comstr , ndsi , ndsen ) + if ( j .le. 6 ) then + read (ndsi,*) flagtfc(j), flh(j) + else + read (ndsi,*) flagtfc(j) + end if + write(msg1,*)' J=', j, ' FLAGTFC=', flagtfc(j), ' FLH=', flh(j) + call print_logmsg(740+IAPROC, trim(msg1), w3_debuginit_flag) + end do + + if ( iaproc .eq. napout ) write (ndso,920) + do j=jfirst, 9 + if (flagtfc(j).eq.'T') then + inflags1(j)=.true. + flagsc(j)=.false. + end if + if (flagtfc(j).eq.'F') then + inflags1(j)=.false. + flagsc(j)=.false. + end if + if (flagtfc(j).eq.'C') then + inflags1(j)=.true. + flagsc(j)=.true. + end if + if ( j .le. 6 ) then + flh(j) = flh(j) .and. inflags1(j) + end if + if ( inflags1(j) ) then + yesxno = 'YES/--' + else + yesxno = '---/NO' + end if + if ( flh(j) ) then + strng = '(homogeneous field) ' + else if ( flagsc(j) ) then + strng = '(coupling field) ' + else + strng = ' ' + end if + if ( iaproc .eq. napout ) write (ndso,921) idflds(j), yesxno, strng + end do + if (w3_cou_flag) then + if (flagsc(1) .and. inflags1(2) .and. .not. flagsc(2)) goto 2102 + if (flagsc(2) .and. inflags1(1) .and. .not. flagsc(1)) goto 2102 + end if + + call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 2b') + + inflags1(10) = .false. + if (w3_mgw_flag .or. w3_mgp_flag) then + inflags1(10) = .true. + flh(10) = .true. + end if + if ( inflags1(10) .and. iaproc.eq.napout ) & + write (ndso,921) idflds(10), 'yes/--', ' ' + + flflg = inflags1(-7) .or. inflags1(-6) .or. inflags1(-5) .or. inflags1(-4) & + .or. inflags1(-3) .or. inflags1(-2) .or. inflags1(-1) & + .or. inflags1(0) .or. inflags1(1) .or. inflags1(2) & + .or. inflags1(3) .or. inflags1(4) .or. inflags1(5) & + .or. inflags1(6) .or. inflags1(7) .or. inflags1(8) & + .or. inflags1(9) + flhom = flh(-7) .or. flh(-6) .or. flh(-5) .or. flh(-4) & + .or. flh(-3) .or. flh(-2) .or. flh(-1) .or. flh(0) & + .or. flh(1) .or. flh(2) .or. flh(3) .or. flh(4) & + .or. flh(5) .or. flh(6) .or. flh(10) + + if ( iaproc .eq. napout ) write (ndso,922) + ! inflags2 is just "initial value of inflags1", i.e. does *not* get + ! changed when model reads last record of ice.ww3 + inflags2=inflags1 + + if (w3_t_flag) then + write (ndst,9020) flflg, inflags1, flhom, flh + end if + + !-------------------- + ! 2.2 Time setup + !-------------------- + call print_logmsg(740+IAPROC, '2.2 Time setup ', w3_debuginit_flag) + call nextln ( comstr , ndsi , ndsen ) + read (ndsi,*) time0 + + call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 2c') + + call nextln ( comstr , ndsi , ndsen ) + read (ndsi,*) timen + call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 2d') + + !-------------------- + ! 2.3 Domain setup + !-------------------- + + call print_logmsg(740+IAPROC, '2.3 Domain setup ', w3_debuginit_flag) + call nextln ( COMSTR , NDSI , NDSEN ) + read (ndsi,*) iostyp + if (w3_pdlib_flag) then + if (iostyp .gt. 1) then + write(*,*) 'iostyp not supported in domain decomposition mode' + call extcde ( 6666 ) + endif + end if + call w3iogr ( 'GRID', ndsm ) + if ( flagll ) then + factor = 1. + else + factor = 1.e-3 + end if + + !-------------------- + ! 2.4 Output dates + !-------------------- + + call print_logmsg(740+IAPROC, '2.4 Output dates ', w3_debuginit_flag) + npts = 0 + notype = 6 + if (w3_cou_flag) then + notype = 7 + end if + do j = 1, notype + write(msg1,*)'J=', J, '/ NOTYPE=', NOTYPE + call nextln ( comstr , ndsi , ndsen ) + + ! checkpoint + if (j .eq. 4) then + odat(38)=0 + words(1:7)='' + read (ndsi,'(a)') linein + read(linein,*,iostat=ierr) words + read(words( 1 ), * ) odat(16) + read(words( 2 ), * ) odat(17) + read(words( 3 ), * ) odat(18) + read(words( 4 ), * ) odat(19) + read(words( 5 ), * ) odat(20) + if (words(6) .eq. 'T') then + call nextln ( comstr , ndsi , ndsen ) + read (ndsi,*,end=2001,err=2002)(odat(i),i=5*(8-1)+1,5*8) + if(iaproc .eq. naproc) write(*,*)'odat(j=4): ',(odat(i),i=5*(8-1)+1,5*8) end if - if ( flh(j) ) then - strng = '(homogeneous field) ' - else if ( flagsc(j) ) then - strng = '(coupling field) ' - else - strng = ' ' + if (words(7) .eq. 'T') then + call nextln ( comstr , ndsi , ndsen ) + read (ndsi,'(a)',end=2001,err=2002) fldrst end if - if ( iaproc .eq. napout ) write (ndso,921) idflds(j), yesxno, strng - end do - if (w3_cou_flag) then - if (flagsc(1) .and. inflags1(2) .and. .not. flagsc(2)) goto 2102 - if (flagsc(2) .and. inflags1(1) .and. .not. flagsc(1)) goto 2102 - end if - - call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 2b') - - inflags1(10) = .false. - if (w3_mgw_flag .or. w3_mgp_flag) then - inflags1(10) = .true. - flh(10) = .true. - end if - if ( inflags1(10) .and. iaproc.eq.napout ) & - write (ndso,921) idflds(10), 'yes/--', ' ' - - flflg = inflags1(-7) .or. inflags1(-6) .or. inflags1(-5) .or. inflags1(-4) & - .or. inflags1(-3) .or. inflags1(-2) .or. inflags1(-1) & - .or. inflags1(0) .or. inflags1(1) .or. inflags1(2) & - .or. inflags1(3) .or. inflags1(4) .or. inflags1(5) & - .or. inflags1(6) .or. inflags1(7) .or. inflags1(8) & - .or. inflags1(9) - flhom = flh(-7) .or. flh(-6) .or. flh(-5) .or. flh(-4) & - .or. flh(-3) .or. flh(-2) .or. flh(-1) .or. flh(0) & - .or. flh(1) .or. flh(2) .or. flh(3) .or. flh(4) & - .or. flh(5) .or. flh(6) .or. flh(10) - - if ( iaproc .eq. napout ) write (ndso,922) - ! inflags2 is just "initial value of inflags1", i.e. does *not* get - ! changed when model reads last record of ice.ww3 - inflags2=inflags1 - - if (w3_t_flag) then - write (ndst,9020) flflg, inflags1, flhom, flh - end if - - !-------------------- - ! 2.2 Time setup - !-------------------- - call print_logmsg(740+IAPROC, '2.2 Time setup ', w3_debuginit_flag) - call nextln ( comstr , ndsi , ndsen ) - read (ndsi,*) time0 - - call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 2c') - - call nextln ( comstr , ndsi , ndsen ) - read (ndsi,*) timen - call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 2d') - - !-------------------- - ! 2.3 Domain setup - !-------------------- - - call print_logmsg(740+IAPROC, '2.3 Domain setup ', w3_debuginit_flag) - call nextln ( COMSTR , NDSI , NDSEN ) - read (ndsi,*) iostyp - if (w3_pdlib_flag) then - if (iostyp .gt. 1) then - write(*,*) 'iostyp not supported in domain decomposition mode' - call extcde ( 6666 ) - endif - end if - call w3iogr ( 'GRID', ndsm ) - if ( flagll ) then - factor = 1. - else - factor = 1.e-3 - end if - - !-------------------- - ! 2.4 Output dates - !-------------------- - - call print_logmsg(740+IAPROC, '2.4 Output dates ', w3_debuginit_flag) - npts = 0 - notype = 6 - if (w3_cou_flag) then - notype = 7 - end if - do j = 1, notype - write(msg1,*)'J=', J, '/ NOTYPE=', NOTYPE - call nextln ( comstr , ndsi , ndsen ) - - ! checkpoint - if (j .eq. 4) then - odat(38)=0 - words(1:7)='' - read (ndsi,'(a)') linein - read(linein,*,iostat=ierr) words - read(words( 1 ), * ) odat(16) - read(words( 2 ), * ) odat(17) - read(words( 3 ), * ) odat(18) - read(words( 4 ), * ) odat(19) - read(words( 5 ), * ) odat(20) - if (words(6) .eq. 'T') then - call nextln ( comstr , ndsi , ndsen ) - read (ndsi,*,end=2001,err=2002)(odat(i),i=5*(8-1)+1,5*8) - if(iaproc .eq. naproc) write(*,*)'odat(j=4): ',(odat(i),i=5*(8-1)+1,5*8) - end if - if (words(7) .eq. 'T') then - call nextln ( comstr , ndsi , ndsen ) - read (ndsi,'(a)',end=2001,err=2002) fldrst - end if - call w3flgrdflag ( ndso, ndso, ndse, fldrst, flogr, flogrr, iaproc, napout, ierr ) - if ( ierr .ne. 0 ) goto 2222 - else - - !inline new variable to read if present ofiles(j), if not ==0 - ! read (ndsi,*) (odat(i),i=5*(j-1)+1,5*j) - ! read (ndsi,*,iostat=ierr) (odat(i),i=5*(j-1)+1,5*j),ofiles(j) - if(j .le. 2) then - words(1:6)='' - ! read (ndsi,*,end=2001,err=2002)(odat(i),i=5*(j-1)+1,5*j),ofiles(j) - read (ndsi,'(a)') linein - read(linein,*,iostat=ierr) words - - if(j .eq. 1) then - read(words( 1 ), * ) odat(1) - read(words( 2 ), * ) odat(2) - read(words( 3 ), * ) odat(3) - read(words( 4 ), * ) odat(4) - read(words( 5 ), * ) odat(5) - else - read(words( 1 ), * ) odat(6) - read(words( 2 ), * ) odat(7) - read(words( 3 ), * ) odat(8) - read(words( 4 ), * ) odat(9) - read(words( 5 ), * ) odat(10) - end if - - if (words(6) .ne. '0' .and. words(6) .ne. '1') then - ofiles(j)=0 - else - read(words( 6 ), * ) ofiles(j) - end if - - else if(j .eq. 7) then + call w3flgrdflag ( ndso, ndso, ndse, fldrst, flogr, flogrr, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 + else + + !inline new variable to read if present ofiles(j), if not ==0 + ! read (ndsi,*) (odat(i),i=5*(j-1)+1,5*j) + ! read (ndsi,*,iostat=ierr) (odat(i),i=5*(j-1)+1,5*j),ofiles(j) + if(j .le. 2) then + words(1:6)='' + ! read (ndsi,*,end=2001,err=2002)(odat(i),i=5*(j-1)+1,5*j),ofiles(j) + read (ndsi,'(a)') linein + read(linein,*,iostat=ierr) words + + if(j .eq. 1) then + read(words( 1 ), * ) odat(1) + read(words( 2 ), * ) odat(2) + read(words( 3 ), * ) odat(3) + read(words( 4 ), * ) odat(4) + read(words( 5 ), * ) odat(5) + else + read(words( 1 ), * ) odat(6) + read(words( 2 ), * ) odat(7) + read(words( 3 ), * ) odat(8) + read(words( 4 ), * ) odat(9) + read(words( 5 ), * ) odat(10) + end if + + if (words(6) .ne. '0' .and. words(6) .ne. '1') then + ofiles(j)=0 + else + read(words( 6 ), * ) ofiles(j) + end if + + else if(j .eq. 7) then #ifdef W3_COU - words(1:6)='' - read (ndsi,'(a)') linein - read(linein,*,iostat=ierr) words - - read(words( 1 ), * ) odat(31) - read(words( 2 ), * ) odat(32) - read(words( 3 ), * ) odat(33) - read(words( 4 ), * ) odat(34) - read(words( 5 ), * ) odat(35) - - if (words(6) .eq. 'T') then - cplt0 = .true. - else - cplt0 = .false. - end if + words(1:6)='' + read (ndsi,'(a)') linein + read(linein,*,iostat=ierr) words + + read(words( 1 ), * ) odat(31) + read(words( 2 ), * ) odat(32) + read(words( 3 ), * ) odat(33) + read(words( 4 ), * ) odat(34) + read(words( 5 ), * ) odat(35) + + if (words(6) .eq. 'T') then + cplt0 = .true. + else + cplt0 = .false. + end if #endif - else + else - ofiles(j)=0 - read (ndsi,*,end=2001,err=2002)(odat(i),i=5*(j-1)+1,5*j) + ofiles(j)=0 + read (ndsi,*,end=2001,err=2002)(odat(i),i=5*(j-1)+1,5*j) - end if !j le 2 - odat(5*(j-1)+3) = max ( 0 , odat(5*(j-1)+3) ) - write(msg1, *) 'read_shel_config NOTTYPE', J - call print_memcheck(740+IAPROC, 'memcheck_____:'//trim(msg1)) + end if !j le 2 + odat(5*(j-1)+3) = max ( 0 , odat(5*(j-1)+3) ) + write(msg1, *) 'read_shel_config NOTTYPE', J + call print_memcheck(740+IAPROC, 'memcheck_____:'//trim(msg1)) - !-------------------- - ! 2.5 Output types - !-------------------- + !-------------------- + ! 2.5 Output types + !-------------------- - call print_logmsg(740+IAPROC, ' 2.5 Output types ', w3_debuginit_flag) - if ( odat(5*(j-1)+3) .ne. 0 ) then - if ( j .eq. 1 ) then + call print_logmsg(740+IAPROC, ' 2.5 Output types ', w3_debuginit_flag) + if ( odat(5*(j-1)+3) .ne. 0 ) then + if ( j .eq. 1 ) then - ! type 1: fields of mean wave parameters - call w3readflgrd ( ndsi, ndso, 9, ndsen, comstr, flgd, flgrd, iaproc, napout, ierr ) - if ( ierr .ne. 0 ) goto 2222 + ! type 1: fields of mean wave parameters + call w3readflgrd ( ndsi, ndso, 9, ndsen, comstr, flgd, flgrd, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 - else if ( j .eq. 2 ) then + else if ( j .eq. 2 ) then - ! type 2: point output - do iloop=1,2 - if ( iloop .eq. 1 ) then - ndsi2 = ndsi - if ( iaproc .eq. 1 ) open (ndss,file=trim(fnmpre)//'ww3_shel.scratch') - else - ndsi2 = ndss + ! type 2: point output + do iloop=1,2 + if ( iloop .eq. 1 ) then + ndsi2 = ndsi + if ( iaproc .eq. 1 ) open (ndss,file=trim(fnmpre)//'ww3_shel.scratch') + else + ndsi2 = ndss #ifdef W3_MPI - call mpi_barrier (mpi_comm,ierr_mpi) + call mpi_barrier (mpi_comm,ierr_mpi) #endif - open (ndss,file=trim(fnmpre)//'ww3_shel.scratch') - rewind (ndss) - - if ( .not.allocated(x) ) then - if ( npts.gt.0 ) then - allocate ( x(npts), y(npts), pnames(npts) ) - else - allocate ( x(1), y(1), pnames(1) ) - goto 2054 - end if - end if + open (ndss,file=trim(fnmpre)//'ww3_shel.scratch') + rewind (ndss) + + if ( .not.allocated(x) ) then + if ( npts.gt.0 ) then + allocate ( x(npts), y(npts), pnames(npts) ) + else + allocate ( x(1), y(1), pnames(1) ) + goto 2054 + end if + end if + end if + + npts = 0 + do + call nextln ( comstr , ndsi , ndsen ) + read (ndsi2,*) xx, yy, pn + if ( iloop.eq.1 .and. iaproc.eq.1 ) then + backspace (ndsi) + read (ndsi,'(a)') line + write (ndss,'(a)') line + end if + if ( index(pn,"STOPSTRING").ne.0 ) exit + npts = npts + 1 + if ( iloop .eq. 1 ) cycle + x(npts) = xx + y(npts) = yy + pnames(npts) = pn + if ( iaproc .eq. napout ) then + if ( flagll ) then + if ( npts .eq. 1 ) then + write (ndso,2945) factor*xx, factor*yy, pn + else + write (ndso,2946) npts, factor*xx, factor*yy, pn end if + else + if ( npts .eq. 1 ) then + write (ndso,2955) factor*xx, factor*yy, pn + else + write (ndso,2956) npts, factor*xx, factor*yy, pn + end if + end if + end if + end do + + if ( iaproc.eq.1 .and. iloop.eq.1 ) close (ndss) + end do - npts = 0 - do - call nextln ( comstr , ndsi , ndsen ) - read (ndsi2,*) xx, yy, pn - if ( iloop.eq.1 .and. iaproc.eq.1 ) then - backspace (ndsi) - read (ndsi,'(a)') line - write (ndss,'(a)') line - end if - if ( index(pn,"STOPSTRING").ne.0 ) exit - npts = npts + 1 - if ( iloop .eq. 1 ) cycle - x(npts) = xx - y(npts) = yy - pnames(npts) = pn - if ( iaproc .eq. napout ) then - if ( flagll ) then - if ( npts .eq. 1 ) then - write (ndso,2945) factor*xx, factor*yy, pn - else - write (ndso,2946) npts, factor*xx, factor*yy, pn - end if - else - if ( npts .eq. 1 ) then - write (ndso,2955) factor*xx, factor*yy, pn - else - write (ndso,2956) npts, factor*xx, factor*yy, pn - end if - end if - end if - end do - - if ( iaproc.eq.1 .and. iloop.eq.1 ) close (ndss) - end do - - if ( npts.eq.0 .and. iaproc.eq.napout ) write (ndso,2947) - if ( iaproc .eq. 1 ) then + if ( npts.eq.0 .and. iaproc.eq.napout ) write (ndso,2947) + if ( iaproc .eq. 1 ) then #ifdef W3_MPI - call mpi_barrier ( mpi_comm, ierr_mpi ) + call mpi_barrier ( mpi_comm, ierr_mpi ) #endif - close (ndss,status='delete') - else + close (ndss,status='delete') + else #ifdef W3_MPI - call mpi_barrier ( mpi_comm, ierr_mpi ) + call mpi_barrier ( mpi_comm, ierr_mpi ) #endif - close (ndss) - end if - - else if ( j .eq. 3 ) then - call print_logmsg(740+IAPROC, ' 2.5 Track output ', w3_debuginit_flag) - ! Type 3: track output - call nextln ( comstr , ndsi , ndsen ) - read (ndsi,*) tflagi - if ( .not. tflagi ) nds(11) = -nds(11) - if ( iaproc .eq. napout ) then - if ( .not. tflagi ) then - write (ndso,3945) 'input', 'UNFORMATTED' - else - write (ndso,3945) 'input', 'FORMATTED' - end if - end if - - else if ( j .eq. 6 ) then - call print_logmsg(740+IAPROC, ' 2.6 Partitioning output ', w3_debuginit_flag) - ! Type 6: partitioning - ! IPRT: IX0, IXN, IXS, IY0, IYN, IYS - call nextln ( comstr , ndsi , ndsen ) - read (ndsi,*) iprt, prtfrm - - if ( iaproc .eq. napout ) then - if ( prtfrm ) then - yesxno = 'YES/--' - else - yesxno = '---/NO' - end if - write (ndso,6945) iprt, yesxno - end if + close (ndss) + end if + + else if ( j .eq. 3 ) then + call print_logmsg(740+IAPROC, ' 2.5 Track output ', w3_debuginit_flag) + ! Type 3: track output + call nextln ( comstr , ndsi , ndsen ) + read (ndsi,*) tflagi + if ( .not. tflagi ) nds(11) = -nds(11) + if ( iaproc .eq. napout ) then + if ( .not. tflagi ) then + write (ndso,3945) 'input', 'UNFORMATTED' + else + write (ndso,3945) 'input', 'FORMATTED' + end if + end if + + else if ( j .eq. 6 ) then + call print_logmsg(740+IAPROC, ' 2.6 Partitioning output ', w3_debuginit_flag) + ! Type 6: partitioning + ! IPRT: IX0, IXN, IXS, IY0, IYN, IYS + call nextln ( comstr , ndsi , ndsen ) + read (ndsi,*) iprt, prtfrm + + if ( iaproc .eq. napout ) then + if ( prtfrm ) then + yesxno = 'YES/--' + else + yesxno = '---/NO' + end if + write (ndso,6945) iprt, yesxno + end if - else if ( j .eq. 7 ) then + else if ( j .eq. 7 ) then - ! Type 7: coupling + ! Type 7: coupling #ifdef W3_COU - call w3readflgrd ( ndsi, ndso, ndss, ndsen, comstr, flg2, flgr2, iaproc, napout, ierr ) - if ( ierr .ne. 0 ) goto 2222 - call nextln ( comstr , ndsi , ndsen ) - read (ndsi,'(a)',end=2001,err=2002,iostat=ierr) fldin + call w3readflgrd ( ndsi, ndso, ndss, ndsen, comstr, flg2, flgr2, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 + call nextln ( comstr , ndsi , ndsen ) + read (ndsi,'(a)',end=2001,err=2002,iostat=ierr) fldin #endif - end if ! j - - end if ! odat - end if ! if j=4 - end do ! j - - ! force minimal allocation to avoid memory seg fault - if ( .not.allocated(x) .and. npts.eq.0 ) allocate ( x(1), y(1), pnames(1) ) - - !-------------------- - ! 2.6 Homogeneous field data - !-------------------- - - call print_logmsg(740+IAPROC, ' 2.6 Homogeneous field data ', w3_debuginit_flag) - if ( flhom ) then - if ( iaproc .eq. napout ) write (ndso,951) 'homogeneous field data (and moving grid) ...' - nh = 0 - - ! Start of loop - do - call nextln ( comstr , ndsi , ndsen ) - read (ndsi,*) idtst - ! Exit if illegal id - if ( idtst.ne.idstr(-7) .and. idtst.ne.idstr(-6) .and. & - idtst.ne.idstr(-5) .and. idtst.ne.idstr(-4) .and. & - idtst.ne.idstr(-3) .and. idtst.ne.idstr(-2) .and. & - idtst.ne.idstr(-1) .and. idtst.ne.idstr(0) .and. & - idtst.ne.idstr(1) .and. idtst.ne.idstr(2) .and. & - idtst.ne.idstr(3) .and. idtst.ne.idstr(4) .and. & - idtst.ne.idstr(5) .and. idtst.ne.idstr(6) .and. & - idtst.ne.idstr(10) .and. idtst.ne.'STP' ) goto 2005 - - ! Stop conditions - if ( idtst .eq. 'STP' ) then - exit - else - backspace ( ndsi ) - end if - - call print_logmsg(740+IAPROC, ' 2.6 Store data ', w3_debuginit_flag) - ! Store data - do j=lbound(idstr,1), 10 - if ( idtst .eq. idstr(j) ) then - nh(j) = nh(j) + 1 - if ( nh(j) .gt. nhmax ) goto 2006 - IF ( J .LE. 1 ) THEN ! water levels, etc. : get HA - read (ndsi,*) idtst, & - tho(1,j,nh(j)), tho(2,j,nh(j)), & - ha(nh(j),j) - ELSE IF ( J .EQ. 2 ) THEN ! currents: get HA and HD - read (ndsi,*) idtst, & - tho(1,j,nh(j)), tho(2,j,nh(j)), & - ha(nh(j),j), hd(nh(j),j) - ELSE IF ( J .EQ. 3 ) THEN ! wind: get HA HD and HS - read (ndsi,*) idtst, & - tho(1,j,nh(j)), tho(2,j,nh(j)), & - ha(nh(j),j), hd(nh(j),j), hs(nh(j),j) - ELSE IF ( J .EQ. 4 ) THEN ! ice - read (ndsi,*) idtst, & - tho(1,j,nh(j)), tho(2,j,nh(j)), & - ha(nh(j),j) - ELSE IF ( J .EQ. 5 ) THEN ! atmospheric momentum - read (ndsi,*) idtst, & - tho(1,j,nh(j)), tho(2,j,nh(j)), & - ha(nh(j),j), hd(nh(j),j) - ELSE IF ( J .EQ. 6 ) THEN ! air density - read (ndsi,*) idtst, & - tho(1,j,nh(j)), tho(2,j,nh(j)), & - ha(nh(j),j) - ELSE IF ( J .EQ. 10 ) THEN ! mov: HA and HD - read (ndsi,*) idtst, & - tho(1,j,nh(j)), tho(2,j,nh(j)), & - ha(nh(j),j), hd(nh(j),j) - END IF - end if - end do - end do - call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 3') - - if (w3_o7_flag) then - do j=jfirst, 10 - if ( flh(j) .and. iaproc.eq.napout ) then - write (ndso,952) nh(j), idflds(j) - do i=1, nh(j) - if ( ( j .le. 1 ) .or. ( j .eq. 4 ) .or. ( j .eq. 6 ) ) then - write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j) - else if ( ( j .eq. 2 ) .or. ( j .eq. 5 ) .or. ( j .eq. 10 ) ) then - write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j) - else if ( j .eq. 3 ) then - write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j), hs(i,j) - end if - end do - end if - end do + end if ! j + + end if ! odat + end if ! if j=4 + end do ! j + + ! force minimal allocation to avoid memory seg fault + if ( .not.allocated(x) .and. npts.eq.0 ) allocate ( x(1), y(1), pnames(1) ) + + !-------------------- + ! 2.6 Homogeneous field data + !-------------------- + + call print_logmsg(740+IAPROC, ' 2.6 Homogeneous field data ', w3_debuginit_flag) + if ( flhom ) then + if ( iaproc .eq. napout ) write (ndso,951) 'homogeneous field data (and moving grid) ...' + nh = 0 + + ! Start of loop + do + call nextln ( comstr , ndsi , ndsen ) + read (ndsi,*) idtst + ! Exit if illegal id + if ( idtst.ne.idstr(-7) .and. idtst.ne.idstr(-6) .and. & + idtst.ne.idstr(-5) .and. idtst.ne.idstr(-4) .and. & + idtst.ne.idstr(-3) .and. idtst.ne.idstr(-2) .and. & + idtst.ne.idstr(-1) .and. idtst.ne.idstr(0) .and. & + idtst.ne.idstr(1) .and. idtst.ne.idstr(2) .and. & + idtst.ne.idstr(3) .and. idtst.ne.idstr(4) .and. & + idtst.ne.idstr(5) .and. idtst.ne.idstr(6) .and. & + idtst.ne.idstr(10) .and. idtst.ne.'STP' ) goto 2005 + + ! Stop conditions + if ( idtst .eq. 'STP' ) then + exit + else + backspace ( ndsi ) end if - if ( ( flh(-7) .and. (nh(-7).eq.0) ) .or. & - ( flh(-6) .and. (nh(-6).eq.0) ) .or. & - ( flh(-5) .and. (nh(-5).eq.0) ) .or. & - ( flh(-4) .and. (nh(-4).eq.0) ) .or. & - ( flh(-3) .and. (nh(-3).eq.0) ) .or. & - ( flh(-2) .and. (nh(-2).eq.0) ) .or. & - ( flh(-1) .and. (nh(-1).eq.0) ) .or. & - ( flh(0) .and. (nh(0).eq.0) ) .or. & - ( flh(1) .and. (nh(1).eq.0) ) .or. & - ( flh(2) .and. (nh(2).eq.0) ) .or. & - ( flh(3) .and. (nh(3).eq.0) ) .or. & - ( flh(4) .and. (nh(4).eq.0) ) .or. & - ( flh(5) .and. (nh(5).eq.0) ) .or. & - ( flh(6) .and. (nh(6).eq.0) ) .or. & - ( flh(10) .and. (nh(10).eq.0) ) ) goto 2007 - - end if ! flhom - close(ndsi) + call print_logmsg(740+IAPROC, ' 2.6 Store data ', w3_debuginit_flag) + ! Store data + do j=lbound(idstr,1), 10 + if ( idtst .eq. idstr(j) ) then + nh(j) = nh(j) + 1 + if ( nh(j) .gt. nhmax ) goto 2006 + IF ( J .LE. 1 ) THEN ! water levels, etc. : get HA + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j) + ELSE IF ( J .EQ. 2 ) THEN ! currents: get HA and HD + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j), hd(nh(j),j) + ELSE IF ( J .EQ. 3 ) THEN ! wind: get HA HD and HS + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j), hd(nh(j),j), hs(nh(j),j) + ELSE IF ( J .EQ. 4 ) THEN ! ice + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j) + ELSE IF ( J .EQ. 5 ) THEN ! atmospheric momentum + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j), hd(nh(j),j) + ELSE IF ( J .EQ. 6 ) THEN ! air density + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j) + ELSE IF ( J .EQ. 10 ) THEN ! mov: HA and HD + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j), hd(nh(j),j) + END IF + end if + end do + end do + call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 3') + + if (w3_o7_flag) then + do j=jfirst, 10 + if ( flh(j) .and. iaproc.eq.napout ) then + write (ndso,952) nh(j), idflds(j) + do i=1, nh(j) + if ( ( j .le. 1 ) .or. ( j .eq. 4 ) .or. ( j .eq. 6 ) ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j) + else if ( ( j .eq. 2 ) .or. ( j .eq. 5 ) .or. ( j .eq. 10 ) ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j) + else if ( j .eq. 3 ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j), hs(i,j) + end if + end do + end if + end do + end if + + if ( ( flh(-7) .and. (nh(-7).eq.0) ) .or. & + ( flh(-6) .and. (nh(-6).eq.0) ) .or. & + ( flh(-5) .and. (nh(-5).eq.0) ) .or. & + ( flh(-4) .and. (nh(-4).eq.0) ) .or. & + ( flh(-3) .and. (nh(-3).eq.0) ) .or. & + ( flh(-2) .and. (nh(-2).eq.0) ) .or. & + ( flh(-1) .and. (nh(-1).eq.0) ) .or. & + ( flh(0) .and. (nh(0).eq.0) ) .or. & + ( flh(1) .and. (nh(1).eq.0) ) .or. & + ( flh(2) .and. (nh(2).eq.0) ) .or. & + ( flh(3) .and. (nh(3).eq.0) ) .or. & + ( flh(4) .and. (nh(4).eq.0) ) .or. & + ( flh(5) .and. (nh(5).eq.0) ) .or. & + ( flh(6) .and. (nh(6).eq.0) ) .or. & + ( flh(10) .and. (nh(10).eq.0) ) ) goto 2007 + + end if ! flhom + close(ndsi) end if ! .not. flgnml call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 4') @@ -1238,23 +1238,23 @@ subroutine read_shel_config(mpi_comm, mds, time0_overwrite, timen_overwrite) !-------------------- if (present(time0_overwrite) .and. present(timen_overwrite)) then - time0(:) = time0_overwrite(:) - timen(:) = timen_overwrite(:) - do j = 1,notype - if (odat(5*(j-1)+3) .ne. 0 ) then ! non-zero stride - odat(5*(j-1)+1) = time0(1) - odat(5*(j-1)+2) = time0(2) - odat(5*(j-1)+4) = timen(1) - odat(5*(j-1)+5) = timen(2) - end if - end do - j=8 - if (odat(5*(j-1)+3) .ne. 0) then ! non-zero stride + time0(:) = time0_overwrite(:) + timen(:) = timen_overwrite(:) + do j = 1,notype + if (odat(5*(j-1)+3) .ne. 0 ) then ! non-zero stride odat(5*(j-1)+1) = time0(1) odat(5*(j-1)+2) = time0(2) odat(5*(j-1)+4) = timen(1) odat(5*(j-1)+5) = timen(2) - end if + end if + end do + j=8 + if (odat(5*(j-1)+3) .ne. 0) then ! non-zero stride + odat(5*(j-1)+1) = time0(1) + odat(5*(j-1)+2) = time0(2) + odat(5*(j-1)+4) = timen(1) + odat(5*(j-1)+5) = timen(2) + end if end if if ( iaproc .eq. napout ) write (ndso,930) @@ -1280,24 +1280,24 @@ subroutine read_shel_config(mpi_comm, mds, time0_overwrite, timen_overwrite) iostyp = max ( 0 , min ( 3 , iostyp ) ) if (w3_pdlib_flag) then - if (iostyp .gt. 1) then - write(*,*) 'iostyp not supported in domain decomposition mode' - call extcde ( 6666 ) - end if + if (iostyp .gt. 1) then + write(*,*) 'iostyp not supported in domain decomposition mode' + call extcde ( 6666 ) + end if endif if ( iaproc .eq. napout ) then - if ( iostyp .eq. 0 ) then - write (ndso,940) 'No dedicated output process, parallel file system required.' - else if ( iostyp .eq. 1 ) then - write (ndso,940) 'No dedicated output process, any file system.' - else if ( iostyp .eq. 2 ) then - write (ndso,940) 'Single dedicated output process.' - else if ( iostyp .eq. 3 ) then - write (ndso,940) 'Multiple dedicated output processes.' - else - write (ndso,940) 'IOSTYP NOT RECOGNIZED' - end if + if ( iostyp .eq. 0 ) then + write (ndso,940) 'No dedicated output process, parallel file system required.' + else if ( iostyp .eq. 1 ) then + write (ndso,940) 'No dedicated output process, any file system.' + else if ( iostyp .eq. 2 ) then + write (ndso,940) 'Single dedicated output process.' + else if ( iostyp .eq. 3 ) then + write (ndso,940) 'Multiple dedicated output processes.' + else + write (ndso,940) 'IOSTYP NOT RECOGNIZED' + end if end if ! TODO: the following documents the output dates according to @@ -1307,108 +1307,108 @@ subroutine read_shel_config(mpi_comm, mds, time0_overwrite, timen_overwrite) ! 2.4 Output dates do j = 1, notype - if ( odat(5*(j-1)+3) .ne. 0 ) then - if ( iaproc .eq. napout ) write (ndso,941) j, idotyp(j) - ttime(1) = odat(5*(j-1)+1) - ttime(2) = odat(5*(j-1)+2) - call stme21 ( ttime , dtme21 ) - if ( iaproc .eq. napout ) write (ndso,942) dtme21 - ttime(1) = odat(5*(j-1)+4) - ttime(2) = odat(5*(j-1)+5) - call stme21 ( ttime , dtme21 ) - if ( iaproc .eq. napout ) write (ndso,943) dtme21 - ttime(1) = 0 - ttime(2) = 0 - dttst = real ( odat(5*(j-1)+3) ) - call tick21 ( ttime , dttst ) - call stme21 ( ttime , dtme21 ) - if ( ( odat(5*(j-1)+1) .ne. odat(5*(j-1)+4) .or. odat(5*(j-1)+2) .ne. odat(5*(j-1)+5) ) & - .and. iaproc .eq. napout ) then - if ( dtme21(9:9) .ne. '0' ) then - write (ndso,1944) dtme21( 9:19) - else if ( dtme21(10:10) .ne. '0' ) then - write (ndso,2944) dtme21(10:19) - else - write (ndso,3944) dtme21(12:19) - end if + if ( odat(5*(j-1)+3) .ne. 0 ) then + if ( iaproc .eq. napout ) write (ndso,941) j, idotyp(j) + ttime(1) = odat(5*(j-1)+1) + ttime(2) = odat(5*(j-1)+2) + call stme21 ( ttime , dtme21 ) + if ( iaproc .eq. napout ) write (ndso,942) dtme21 + ttime(1) = odat(5*(j-1)+4) + ttime(2) = odat(5*(j-1)+5) + call stme21 ( ttime , dtme21 ) + if ( iaproc .eq. napout ) write (ndso,943) dtme21 + ttime(1) = 0 + ttime(2) = 0 + dttst = real ( odat(5*(j-1)+3) ) + call tick21 ( ttime , dttst ) + call stme21 ( ttime , dtme21 ) + if ( ( odat(5*(j-1)+1) .ne. odat(5*(j-1)+4) .or. odat(5*(j-1)+2) .ne. odat(5*(j-1)+5) ) & + .and. iaproc .eq. napout ) then + if ( dtme21(9:9) .ne. '0' ) then + write (ndso,1944) dtme21( 9:19) + else if ( dtme21(10:10) .ne. '0' ) then + write (ndso,2944) dtme21(10:19) + else + write (ndso,3944) dtme21(12:19) end if - end if + end if + end if end do ! CHECKPOINT j=8 if (odat(5*(j-1)+3) .ne. 0) then - if ( iaproc .eq. napout ) write (ndso,941) j, idotyp(j) - ttime(1) = odat(5*(j-1)+1) - ttime(2) = odat(5*(j-1)+2) - call stme21 ( ttime , dtme21 ) - if ( iaproc .eq. napout ) write (ndso,942) dtme21 - ttime(1) = odat(5*(j-1)+4) - ttime(2) = odat(5*(j-1)+5) - call stme21 ( ttime , dtme21 ) - if ( iaproc .eq. napout ) write (ndso,943) dtme21 - ttime(1) = 0 - ttime(2) = 0 - dttst = real ( odat(5*(j-1)+3) ) - call tick21 ( ttime , dttst ) - call stme21 ( ttime , dtme21 ) - if ( ( odat(5*(j-1)+1) .ne. odat(5*(j-1)+4) .or. & - odat(5*(j-1)+2) .ne. odat(5*(j-1)+5) ) .and. & - iaproc .eq. napout ) then - if ( dtme21(9:9) .ne. '0' ) then - write (ndso,1944) dtme21( 9:19) - else if ( dtme21(10:10) .ne. '0' ) then - write (ndso,2944) dtme21(10:19) - else - write (ndso,3944) dtme21(12:19) - end if - end if + if ( iaproc .eq. napout ) write (ndso,941) j, idotyp(j) + ttime(1) = odat(5*(j-1)+1) + ttime(2) = odat(5*(j-1)+2) + call stme21 ( ttime , dtme21 ) + if ( iaproc .eq. napout ) write (ndso,942) dtme21 + ttime(1) = odat(5*(j-1)+4) + ttime(2) = odat(5*(j-1)+5) + call stme21 ( ttime , dtme21 ) + if ( iaproc .eq. napout ) write (ndso,943) dtme21 + ttime(1) = 0 + ttime(2) = 0 + dttst = real ( odat(5*(j-1)+3) ) + call tick21 ( ttime , dttst ) + call stme21 ( ttime , dtme21 ) + if ( ( odat(5*(j-1)+1) .ne. odat(5*(j-1)+4) .or. & + odat(5*(j-1)+2) .ne. odat(5*(j-1)+5) ) .and. & + iaproc .eq. napout ) then + if ( dtme21(9:9) .ne. '0' ) then + write (ndso,1944) dtme21( 9:19) + else if ( dtme21(10:10) .ne. '0' ) then + write (ndso,2944) dtme21(10:19) + else + write (ndso,3944) dtme21(12:19) + end if + end if end if ! 2.5 Output types if (w3_t_flag) then - write (ndst,9040) odat - write (ndst,9041) flgrd - write (ndst,9042) iprt, prtfrm + write (ndst,9040) odat + write (ndst,9041) flgrd + write (ndst,9042) iprt, prtfrm end if if (.not. present(time0_overwrite) .and. .not. present(timen_overwrite)) then - ! - ! For outputs with non-zero time step, check dates : - ! If output ends before run start OR output starts after run end, - ! deactivate output cleanly with output time step = 0 - ! This is usefull for IOSTYP=3 (Multiple dedicated output processes) - ! to avoid the definition of dedicated proc. for unused output. - ! - do j = 1, notype - dttst = dsec21 ( time0 , odat(5*(j-1)+4:5*(j-1)+5) ) - if ( dttst .lt. 0 ) then - odat(5*(j-1)+3) = 0 - if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) - continue - end if - dttst = dsec21 ( odat(5*(j-1)+1:5*(j-1)+2), timen ) - if ( dttst .lt. 0 ) then - odat(5*(j-1)+3) = 0 - if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) - continue - end if - end do + ! + ! For outputs with non-zero time step, check dates : + ! If output ends before run start OR output starts after run end, + ! deactivate output cleanly with output time step = 0 + ! This is usefull for IOSTYP=3 (Multiple dedicated output processes) + ! to avoid the definition of dedicated proc. for unused output. + ! + do j = 1, notype + dttst = dsec21 ( time0 , odat(5*(j-1)+4:5*(j-1)+5) ) + if ( dttst .lt. 0 ) then + odat(5*(j-1)+3) = 0 + if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) + continue + end if + dttst = dsec21 ( odat(5*(j-1)+1:5*(j-1)+2), timen ) + if ( dttst .lt. 0 ) then + odat(5*(j-1)+3) = 0 + if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) + continue + end if + end do end if ! checkpoint j = 8 dttst = dsec21 ( time0 , odat(5*(j-1)+4:5*(j-1)+5) ) if ( dttst .lt. 0 ) then - odat(5*(j-1)+3) = 0 - if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) - continue + odat(5*(j-1)+3) = 0 + if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) + continue end if dttst = dsec21 ( odat(5*(j-1)+1:5*(j-1)+2), timen ) if ( dttst .lt. 0 ) then - odat(5*(j-1)+3) = 0 - if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) - continue + odat(5*(j-1)+3) = 0 + if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) + continue end if ! @@ -1463,27 +1463,27 @@ subroutine read_shel_config(mpi_comm, mds, time0_overwrite, timen_overwrite) 15X,'==============================================='/) 901 FORMAT ( ' Comment character is ''',A,''''/) 905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & - ' Requested: ', I2/ & - ' Provided: ', I2/ ) + ' Requested: ', I2/ & + ' Provided: ', I2/ ) 920 FORMAT (/' Input fields : '/ & - ' --------------------------------------------------') + ' --------------------------------------------------') 921 FORMAT ( ' ',A,2X,A,2X,A) 922 FORMAT ( ' ' ) 930 FORMAT (/' Time interval : '/ & - ' --------------------------------------------------') + ' --------------------------------------------------') 931 FORMAT ( ' Starting time : ',A) 932 FORMAT ( ' Ending time : ',A/) 940 FORMAT (/' Output requests : '/ & - ' --------------------------------------------------'/ & - ' ',A) + ' --------------------------------------------------'/ & + ' ',A) 941 FORMAT (/' Type',I2,' : ',A/ & - ' -----------------------------------------') + ' -----------------------------------------') 942 FORMAT ( ' From : ',A) 943 FORMAT ( ' To : ',A) 954 FORMAT ( ' ',A,': file not needed') 955 FORMAT ( ' ',A,': file OK') 956 FORMAT ( ' ',A,': file OK, recl =',I3, & - ' undef = ',E10.3) + ' undef = ',E10.3) 1944 FORMAT ( ' Interval : ', 8X,A11/) 2944 FORMAT ( ' Interval : ', 9X,A10/) 3944 FORMAT ( ' Interval : ',11X,A8/) @@ -1494,51 +1494,51 @@ subroutine read_shel_config(mpi_comm, mds, time0_overwrite, timen_overwrite) 2947 FORMAT ( ' No points defined') 3945 FORMAT ( ' The file with ',A,' data is ',A,'.') 6945 FORMAT ( ' IX first,last,inc :',3I5/ & - ' IY first,last,inc :',3I5/ & - ' Formatted file : ',A) + ' IY first,last,inc :',3I5/ & + ' Formatted file : ',A) 8945 FORMAT ( ' output dates out of run dates : ', A, & ' deactivated') 950 FORMAT (/' Initializations :'/ & - ' --------------------------------------------------') + ' --------------------------------------------------') 951 FORMAT ( ' ',A) 952 FORMAT ( ' ',I6,2X,A) 953 FORMAT ( ' ',I6,I11.8,I7.6,3E12.4) 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' PREMATURE END OF INPUT FILE'/) + ' PREMATURE END OF INPUT FILE'/) 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) 1102 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' LEVEL AND CURRENT ARE MIXING COUPLED AND FORCED'/& - ' IT MUST BE FULLY COUPLED OR DISABLED '/) + ' LEVEL AND CURRENT ARE MIXING COUPLED AND FORCED'/& + ' IT MUST BE FULLY COUPLED OR DISABLED '/) 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ILLEGAL TIME INTERVAL'/) + ' ILLEGAL TIME INTERVAL'/) 1104 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN OPENING POINT FILE'/ & - ' IOSTAT =',I5/) + ' ERROR IN OPENING POINT FILE'/ & + ' IOSTAT =',I5/) 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN READING FROM POINT FILE'/ & - ' IOSTAT =',I5/) + ' ERROR IN READING FROM POINT FILE'/ & + ' IOSTAT =',I5/) 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ILLEGAL ID STRING HOMOGENEOUS FIELD : ',A/) + ' ILLEGAL ID STRING HOMOGENEOUS FIELD : ',A/) 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' TOO MANY HOMOGENEOUS FIELDS : ',A,1X,I4/) + ' TOO MANY HOMOGENEOUS FIELDS : ',A,1X,I4/) 1062 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : ***'/ & - ' HOMOGENEOUS NAME NOT RECOGNIZED : ', A/) + ' HOMOGENEOUS NAME NOT RECOGNIZED : ', A/) 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' INSUFFICIENT DATA FOR HOMOGENEOUS FIELDS'/) + ' INSUFFICIENT DATA FOR HOMOGENEOUS FIELDS'/) 1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN OPENING OUTPUT FILE'/ & - ' IOSTAT =',I5/) + ' ERROR IN OPENING OUTPUT FILE'/ & + ' IOSTAT =',I5/) 1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' COUPLING TIME STEP NOT MULTIPLE OF'/ & - ' MODEL TIME STEP: ',I6, I6/) + ' COUPLING TIME STEP NOT MULTIPLE OF'/ & + ' MODEL TIME STEP: ',I6, I6/) 1010 FORMAT (/' *** WAVEWATCH III WARNING IN W3SHEL : *** '/ & - ' COUPLING TIME STEP NOT DEFINED, '/ & - ' IT WILL BE OVERRIDEN TO DEFAULT VALUE'/ & - ' FROM ',I6, ' TO ',I6/) + ' COUPLING TIME STEP NOT DEFINED, '/ & + ' IT WILL BE OVERRIDEN TO DEFAULT VALUE'/ & + ' FROM ',I6, ' TO ',I6/) 1054 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' POINT OUTPUT ACTIVATED BUT NO POINTS DEFINED'/) + ' POINT OUTPUT ACTIVATED BUT NO POINTS DEFINED'/) 9000 FORMAT ( ' TEST W3SHEL : UNIT NUMBERS :',12I4) 9001 FORMAT ( ' TEST W3SHEL : SUBR. TRACING :',2I4) 9020 FORMAT ( ' TEST W3SHEL : FLAGS DEF / HOM : ',9L2,2X,9L2) diff --git a/model/src/wav_shr_flags.F90 b/model/src/wav_shr_flags.F90 index 704c16893..b4f50c18d 100644 --- a/model/src/wav_shr_flags.F90 +++ b/model/src/wav_shr_flags.F90 @@ -1050,10 +1050,10 @@ module wav_shr_flags #endif interface print_logmsg - module procedure print_logmsg_1line - module procedure print_logmsg_2line - module procedure print_logmsg_3line - module procedure print_logmsg_4line + module procedure print_logmsg_1line + module procedure print_logmsg_2line + module procedure print_logmsg_3line + module procedure print_logmsg_4line end interface print_logmsg contains diff --git a/model/src/wav_shr_mod.F90 b/model/src/wav_shr_mod.F90 index 7ae58a5d2..e81330c41 100644 --- a/model/src/wav_shr_mod.F90 +++ b/model/src/wav_shr_mod.F90 @@ -46,13 +46,15 @@ module wav_shr_mod private :: field_getfldptr !< @private obtain a pointer to a field interface state_getfldptr - module procedure state_getfldptr_1d - module procedure state_getfldptr_2d + module procedure state_getfldptr_1d + module procedure state_getfldptr_2d end interface state_getfldptr ! used by both CESM and UFS logical , public :: wav_coupling_to_cice = .false. !< @public flag to specify additional wave export !! fields for coupling to CICE (TODO: generalize) + integer, parameter , public :: nwav_elev_spectrum = 25 !< the size of the wave spectrum exported if coupling + !! waves to cice6 integer , public :: dbug_flag = 0 !< @public flag used to produce additional output character(len=256) , public :: casename = '' !< @public the name pre-prended to an output file @@ -71,8 +73,8 @@ module wav_shr_mod !! as multigrid interface ymd2date - module procedure ymd2date_int - module procedure ymd2date_long + module procedure ymd2date_int + module procedure ymd2date_long end interface ymd2date ! Clock and alarm option @@ -102,23 +104,23 @@ module wav_shr_mod character(len=*), parameter :: u_FILE_u = & !< a character string for an ESMF log message __FILE__ -!=============================================================================== + !=============================================================================== contains -!=============================================================================== -!> Get scalar data from a state -!! -!> @details Obtain the field flds_scalar_name from a State and broadcast and -!! it to all PEs -!! -!! @param[in] State an ESMF_State -!! @param[in] scalar_value the value of the scalar -!! @param[in] scalar_id the identity of the scalar -!! @param[in] flds_scalar_name the name of the scalar -!! @param[in] flds_scalar_num the number of scalars -!! @param[out] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !=============================================================================== + !> Get scalar data from a state + !! + !> @details Obtain the field flds_scalar_name from a State and broadcast and + !! it to all PEs + !! + !! @param[in] State an ESMF_State + !! @param[in] scalar_value the value of the scalar + !! @param[in] scalar_id the identity of the scalar + !! @param[in] flds_scalar_name the name of the scalar + !! @param[in] flds_scalar_num the number of scalars + !! @param[out] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine state_getscalar(state, scalar_id, scalar_value, flds_scalar_name, flds_scalar_num, rc) ! ---------------------------------------------- @@ -169,24 +171,24 @@ subroutine state_getscalar(state, scalar_id, scalar_value, flds_scalar_name, fld end subroutine state_getscalar -!================================================================================ -!> Set scalar data into a state -!! -!! Called by fldlist_realize to set the required scalar data into a state. The -!! scalar_value will be set into a field with name flds_scalar_name. The scalar_id -!! identifies which dimension in the scalar field is given by the scalar_value. The -!! number of scalars is used to ensure that the scalar_id is within the bounds of -!! the scalar field -!! -!! @param[inout] State an ESMF_State -!! @param[in] scalar_value the value of the scalar -!! @param[in] scalar_id the identity of the scalar -!! @param[in] flds_scalar_name the name of the scalar -!! @param[in] flds_scalar_num the number of scalars -!! @param[inout] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !================================================================================ + !> Set scalar data into a state + !! + !! Called by fldlist_realize to set the required scalar data into a state. The + !! scalar_value will be set into a field with name flds_scalar_name. The scalar_id + !! identifies which dimension in the scalar field is given by the scalar_value. The + !! number of scalars is used to ensure that the scalar_id is within the bounds of + !! the scalar field + !! + !! @param[inout] State an ESMF_State + !! @param[in] scalar_value the value of the scalar + !! @param[in] scalar_id the identity of the scalar + !! @param[in] flds_scalar_name the name of the scalar + !! @param[in] flds_scalar_num the number of scalars + !! @param[inout] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine state_setscalar(scalar_value, scalar_id, State, flds_scalar_name, flds_scalar_num, rc) ! ---------------------------------------------- @@ -221,27 +223,27 @@ subroutine state_setscalar(scalar_value, scalar_id, State, flds_scalar_name, fld if (chkerr(rc,__LINE__,u_FILE_u)) return if (mytask == 0) then - call ESMF_FieldGet(lfield, farrayPtr = farrayptr, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (scalar_id < 0 .or. scalar_id > flds_scalar_num) then - call ESMF_LogWrite(trim(subname)//": ERROR in scalar_id", ESMF_LOGMSG_INFO) - rc = ESMF_FAILURE - return - endif - farrayptr(scalar_id,1) = scalar_value + call ESMF_FieldGet(lfield, farrayPtr = farrayptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (scalar_id < 0 .or. scalar_id > flds_scalar_num) then + call ESMF_LogWrite(trim(subname)//": ERROR in scalar_id", ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + endif + farrayptr(scalar_id,1) = scalar_value endif end subroutine state_setscalar -!=============================================================================== -!> Reset all fields in a state to a value -!! -!! @param[inout] State an ESMF_State -!! @param[in] reset_value the reset value -!! @param[out] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !=============================================================================== + !> Reset all fields in a state to a value + !! + !! @param[inout] State an ESMF_State + !! @param[in] reset_value the reset value + !! @param[out] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine state_reset(State, reset_value, rc) ! ---------------------------------------------- @@ -274,23 +276,23 @@ subroutine state_reset(State, reset_value, rc) do n = 1, fieldCount - call ESMF_StateGet(State, itemName=trim(lfieldnamelist(n)), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call field_getfldptr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, rank=lrank, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (lrank == 0) then - ! no local data - elseif (lrank == 1) then - fldptr1 = reset_value - elseif (lrank == 2) then - fldptr2 = reset_value - else - call ESMF_LogWrite(trim(subname)//": ERROR in rank "//trim(lfieldnamelist(n)), ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return - endif + call ESMF_StateGet(State, itemName=trim(lfieldnamelist(n)), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call field_getfldptr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, rank=lrank, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (lrank == 0) then + ! no local data + elseif (lrank == 1) then + fldptr1 = reset_value + elseif (lrank == 2) then + fldptr2 = reset_value + else + call ESMF_LogWrite(trim(subname)//": ERROR in rank "//trim(lfieldnamelist(n)), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif enddo deallocate(lfieldnamelist) @@ -298,15 +300,15 @@ subroutine state_reset(State, reset_value, rc) end subroutine state_reset !=============================================================================== -!> Obtain a 1-D pointer to a field in a state -!! -!! @param[in] State an ESMF_State -!! @param[in] fldname the name of an ESMF field -!! @param[inout] fldptr a 1-d pointer to an ESMF field -!! @param[out] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Obtain a 1-D pointer to a field in a state + !! + !! @param[in] State an ESMF_State + !! @param[in] fldname the name of an ESMF field + !! @param[inout] fldptr a 1-d pointer to an ESMF field + !! @param[out] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine state_getfldptr_1d(State, fldname, fldptr, rc) ! ---------------------------------------------- ! Get pointer to a state field @@ -333,26 +335,26 @@ subroutine state_getfldptr_1d(State, fldname, fldptr, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (status /= ESMF_FIELDSTATUS_COMPLETE) then - call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return else - call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if end subroutine state_getfldptr_1d !=============================================================================== -!> Obtain a 2-D pointer to a field in a state -!! -!! @param[in] State an ESMF_State -!! @param[in] fldname the name of an ESMF field -!! @param[inout] fldptr a 2-d pointer to an ESMF field -!! @param[out] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Obtain a 2-D pointer to a field in a state + !! + !! @param[in] State an ESMF_State + !! @param[in] fldname the name of an ESMF field + !! @param[inout] fldptr a 2-d pointer to an ESMF field + !! @param[out] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine state_getfldptr_2d(State, fldname, fldptr, rc) ! ---------------------------------------------- ! Get pointer to a state field @@ -379,24 +381,24 @@ subroutine state_getfldptr_2d(State, fldname, fldptr, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (status /= ESMF_FIELDSTATUS_COMPLETE) then - call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return else - call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if end subroutine state_getfldptr_2d !=============================================================================== -!> Return true if a field is in a state -!! -!! @param[in] State an ESMF_State -!! @param[in] fldname the name of an ESMF field -!! @return state_fldchk logical indicating a field is present in a state -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Return true if a field is in a state + !! + !! @param[in] State an ESMF_State + !! @param[in] fldname the name of an ESMF field + !! @return state_fldchk logical indicating a field is present in a state + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 logical function state_fldchk(State, fldname) ! ---------------------------------------------- ! Determine if field is in state @@ -415,15 +417,15 @@ logical function state_fldchk(State, fldname) end function state_fldchk -!=============================================================================== -!> Print minimum, maximum, sum and size for a field in a state -!! -!! @param[in] State an ESMF_State -!! @param[in] string a string for denoting the location of the call -!! @param[out] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !=============================================================================== + !> Print minimum, maximum, sum and size for a field in a state + !! + !! @param[in] State an ESMF_State + !! @param[in] string a string for denoting the location of the call + !! @param[out] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine state_diagnose(State, string, rc) ! ---------------------------------------------- @@ -455,52 +457,52 @@ subroutine state_diagnose(State, string, rc) do n = 1, fieldCount - call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - if (lrank == 0) then - ! no local data - elseif (lrank == 1) then - if (size(dataPtr1d) > 0) then - write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n))//' ', & - minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) - else - write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" - endif - elseif (lrank == 2) then - if (size(dataPtr2d) > 0) then - write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n))//' ', & - minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) - else - write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" - endif - else - call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return - endif - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (lrank == 0) then + ! no local data + elseif (lrank == 1) then + if (size(dataPtr1d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n))//' ', & + minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + elseif (lrank == 2) then + if (size(dataPtr2d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n))//' ', & + minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + else + call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) enddo deallocate(lfieldnamelist) end subroutine state_diagnose -!=============================================================================== -!> Obtain a 1 or 2-D pointer to a field -!! -!! @param[in] field an ESMF_Field -!! @param[inout] fldptr1 a 1-d pointer to an ESMF field -!! @param[inout] fldptr2 a 2-d pointer to an ESMF field -!! @param[out] rank the field rank -!! @param[in] abort an optional flag to override the default abort value -!! @param[out] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !=============================================================================== + !> Obtain a 1 or 2-D pointer to a field + !! + !! @param[in] field an ESMF_Field + !! @param[inout] fldptr1 a 1-d pointer to an ESMF field + !! @param[inout] fldptr2 a 2-d pointer to an ESMF field + !! @param[out] rank the field rank + !! @param[in] abort an optional flag to override the default abort value + !! @param[out] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) ! ---------------------------------------------- @@ -527,17 +529,17 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) ! ---------------------------------------------- if (.not.present(rc)) then - call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return endif rc = ESMF_SUCCESS labort = .true. if (present(abort)) then - labort = abort + labort = abort endif lrank = -99 @@ -545,92 +547,92 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (status /= ESMF_FIELDSTATUS_COMPLETE) then - lrank = 0 - if (labort) then - call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - return - else - call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO, rc=rc) - endif + lrank = 0 + if (labort) then + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + else + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + endif else - call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - if (geomtype == ESMF_GEOMTYPE_GRID) then - call ESMF_FieldGet(field, rank=lrank, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - elseif (geomtype == ESMF_GEOMTYPE_MESH) then - call ESMF_FieldGet(field, rank=lrank, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(field, mesh=lmesh, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (nnodes == 0 .and. nelements == 0) lrank = 0 - else - call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & - ESMF_LOGMSG_INFO, rc=rc) + call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (geomtype == ESMF_GEOMTYPE_MESH) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field, mesh=lmesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (nnodes == 0 .and. nelements == 0) lrank = 0 + else + call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + endif ! geomtype + + if (lrank == 0) then + call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & + ESMF_LOGMSG_INFO) + elseif (lrank == 1) then + if (.not.present(fldptr1)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) rc = ESMF_FAILURE return - endif ! geomtype - - if (lrank == 0) then - call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & - ESMF_LOGMSG_INFO) - elseif (lrank == 1) then - if (.not.present(fldptr1)) then - call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return - endif - call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - elseif (lrank == 2) then - if (.not.present(fldptr2)) then - call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return - endif - call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - else - call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + endif + call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (lrank == 2) then + if (.not.present(fldptr2)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) rc = ESMF_FAILURE return - endif + endif + call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif endif ! status if (present(rank)) then - rank = lrank + rank = lrank endif end subroutine field_getfldptr -!=============================================================================== -!> Set up an alarm in a clock -!! -!> @details Create an ESMF_Alarm according to the desired frequency, where the -!! frequency is relative to a time frequency of seconds, days, hours etc. -!! -!! @param[inout] clock an ESMF_Clock -!! @param[inout] alarm an ESMF_Alarm -!! @param[in] option the alarm option (day,hour etc) -!! @param[in] opt_n the alarm frequency -!! @param[in] opt_ymd the YMD, required for alarm_option when option is -!! date -!! @param[in] opt_tod the time-of-day in seconds -!! @param[in] Reftime initial guess of next alarm time -!! @param[in] alarmname the alarm name -!! @param[inout] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !=============================================================================== + !> Set up an alarm in a clock + !! + !> @details Create an ESMF_Alarm according to the desired frequency, where the + !! frequency is relative to a time frequency of seconds, days, hours etc. + !! + !! @param[inout] clock an ESMF_Clock + !! @param[inout] alarm an ESMF_Alarm + !! @param[in] option the alarm option (day,hour etc) + !! @param[in] opt_n the alarm frequency + !! @param[in] opt_ymd the YMD, required for alarm_option when option is + !! date + !! @param[in] opt_tod the time-of-day in seconds + !! @param[in] Reftime initial guess of next alarm time + !! @param[in] alarmname the alarm name + !! @param[inout] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine alarmInit( clock, alarm, option, & opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) @@ -688,9 +690,9 @@ subroutine alarmInit( clock, alarm, option, & ! initial guess of next alarm, this will be updated below if (present(RefTime)) then - NextAlarm = RefTime + NextAlarm = RefTime else - NextAlarm = CurrTime + NextAlarm = CurrTime endif ! Determine calendar @@ -700,303 +702,303 @@ subroutine alarmInit( clock, alarm, option, & selectcase (trim(option)) case (optNONE) - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. case (optNever) - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. - - call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE case (optDate) - if (.not. present(opt_ymd)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_ymd', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (lymd < 0 .or. ltod < 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//'opt_ymd, opt_tod invalid', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call timeInit(NextAlarm, lymd, cal, ltod, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. + if (.not. present(opt_ymd)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_ymd', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (lymd < 0 .or. ltod < 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//'opt_ymd, opt_tod invalid', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call timeInit(NextAlarm, lymd, cal, ltod, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. case (optIfdays0) - if (.not. present(opt_ymd)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_ymd', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=cal, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + if (.not. present(opt_ymd)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_ymd', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case (optNSteps) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNStep) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNSeconds) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNSecond) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNMinutes) - call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNMinute) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNHours) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNHour) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNDays) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNDay) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNMonths) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNMonth) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optMonthly) - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case (optNYears) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNYear) - if (.not.present(opt_n)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - if (opt_n <= 0) then - call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE - end if - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + if (.not.present(opt_n)) then + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + if (opt_n <= 0) then + call ESMF_LogWrite(trim(subname)//trim(option)//' invalid opt_n', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + end if + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optYearly) - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case default - call ESMF_LogWrite(trim(subname)//'unknown option '//trim(option), & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE + call ESMF_LogWrite(trim(subname)//'unknown option '//trim(option), & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE end select @@ -1008,10 +1010,10 @@ subroutine alarmInit( clock, alarm, option, & ! --- most options above. go back one alarminterval just to be careful if (update_nextalarm) then - NextAlarm = NextAlarm - AlarmInterval - do while (NextAlarm <= CurrTime) - NextAlarm = NextAlarm + AlarmInterval - enddo + NextAlarm = NextAlarm - AlarmInterval + do while (NextAlarm <= CurrTime) + NextAlarm = NextAlarm + AlarmInterval + enddo endif alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, & @@ -1020,20 +1022,20 @@ subroutine alarmInit( clock, alarm, option, & end subroutine alarmInit -!=============================================================================== -!> Create an ESMF_Time object -!! -!> @details Create a ESMF_Time corresponding to a input time YYYYMMMDD and -!! time of day in seconds -!! -!! @param[inout] Time an ESMF_Time object -!! @param[in] ymd year, month, day YYYYMMDD -!! @param[in] cal an ESMF_Calendar -!! @param[in] tod time of day in secons -!! @param[out] rc a return code -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !=============================================================================== + !> Create an ESMF_Time object + !! + !> @details Create a ESMF_Time corresponding to a input time YYYYMMMDD and + !! time of day in seconds + !! + !! @param[inout] Time an ESMF_Time object + !! @param[in] ymd year, month, day YYYYMMDD + !! @param[in] cal an ESMF_Calendar + !! @param[in] tod time of day in secons + !! @param[out] rc a return code + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine timeInit( Time, ymd, cal, tod, rc) ! Create the ESMF_Time object corresponding to the given input time, @@ -1058,9 +1060,9 @@ subroutine timeInit( Time, ymd, cal, tod, rc) rc = ESMF_SUCCESS if ( (ymd < 0) .or. (tod < 0) .or. (tod > SecPerDay) )then - call ESMF_LogWrite(trim(subname)//'ERROR yymmdd is a negative number or time-of-day out of bounds', & - ESMF_LOGMSG_INFO, rc=rc) - rc = ESMF_FAILURE + call ESMF_LogWrite(trim(subname)//'ERROR yymmdd is a negative number or time-of-day out of bounds', & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE end if tdate = abs(date) @@ -1075,15 +1077,15 @@ subroutine timeInit( Time, ymd, cal, tod, rc) end subroutine timeInit !=============================================================================== -!> Convert year, month, day to integer*4 coded-date -!! -!! @param[in] year calendar year -!! @param[in] month calendary month -!! @param[in] day calendar day -!! @param[out] date calendar date yyyymmmdd -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Convert year, month, day to integer*4 coded-date + !! + !! @param[in] year calendar year + !! @param[in] month calendary month + !! @param[in] day calendar day + !! @param[out] date calendar date yyyymmmdd + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine ymd2date_int(year,month,day,date) ! Converts year, month, day to coded-date @@ -1098,15 +1100,15 @@ subroutine ymd2date_int(year,month,day,date) end subroutine ymd2date_int !=============================================================================== -!> Converts year, month, day to integer*8 coded-date -!! -!! @param[in] year calendar year -!! @param[in] month calendary month -!! @param[in] day calendar day -!! @param[out] date calendar date yyyymmmdd -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !> Converts year, month, day to integer*8 coded-date + !! + !! @param[in] year calendar year + !! @param[in] month calendary month + !! @param[in] day calendar day + !! @param[out] date calendar date yyyymmmdd + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 subroutine ymd2date_long(year,month,day,date) ! Converts year, month, day to coded-date @@ -1120,16 +1122,16 @@ subroutine ymd2date_long(year,month,day,date) if (year < 0) date = -date end subroutine ymd2date_long -!=============================================================================== -!> Return a logical true if ESMF_LogFoundError detects an error -!! -!! @param[in] rc return code -!! @param[in] line source code line number -!! @param[in] file user provided source file name -!! @return chkerr logical indicating an error was found -!! -!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov -!> @date 01-05-2022 + !=============================================================================== + !> Return a logical true if ESMF_LogFoundError detects an error + !! + !! @param[in] rc return code + !! @param[in] line source code line number + !! @param[in] file user provided source file name + !! @return chkerr logical indicating an error was found + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 logical function chkerr(rc, line, file) integer, intent(in) :: rc @@ -1141,7 +1143,7 @@ logical function chkerr(rc, line, file) chkerr = .false. lrc = rc if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then - chkerr = .true. + chkerr = .true. endif end function chkerr diff --git a/model/src/wmesmfmd.F90 b/model/src/wmesmfmd.F90 index ba77582cc..f160964f4 100644 --- a/model/src/wmesmfmd.F90 +++ b/model/src/wmesmfmd.F90 @@ -1,11 +1,11 @@ !> @file !> @brief Contains module WMESMFMD. -!> +!> !> @author T. J. Campell !> @author J. Meixner !> @author A. J. van der Westhuysen !> @date 09-Aug-2017 -!> +!> #include "w3macros.h" !/ @@ -55,7 +55,7 @@ !> @brief National Unified Prediction Capability (NUOPC) based !> Earth System Modeling Framework (ESMF) interface module for !> multi-grid wave model. -!> +!> !> @details All module variables and types are scoped private by default. !> The private module variables and types are not listed in this section. !> @@ -64,1028 +64,1028 @@ !> @author A. J. van der Westhuysen !> @date 09-Aug-2017 !> - module WMESMFMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | J. Meixner, NCEP | -!/ | A. J. van der Westhuysen | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ 09-Aug-2017 : Add ocean forcing export fields ( version 6.03 ) -!/ 28-Feb-2018 : Modifications for unstruc meshes ( version 6.06 ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! National Unified Prediction Capability (NUOPC) based -! Earth System Modeling Framework (ESMF) interface module for -! multi-grid wave model. -! -! 2. Variables and types : -! -! All module variables and types are scoped private by default. -! The private module variables and types are not listed in this section. -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! All module subroutines and functions are scoped private by default. -! -! Name Type Scope Description -! ----------------------------------------------------------------- -! SetServices Subr. Public Wave model ESMF Set Services -! ----------------------------------------------------------------- -! InitializeP0 Subr. Private NUOPC/ESMF Initialize phase 0 -! InitializeP1 Subr. Private NUOPC/ESMF Initialize phase 1 -! InitializeP3 Subr. Private NUOPC/ESMF Initialize phase 3 -! Finalize Subr. Private NUOPC/ESMF Finalize -! DataInitialize Subr. Private NUOPC/ESMF Data Initialize -! ModelAdvance Subr. Private NUOPC/ESMF Model Advance -! GetImport Subr. Private Get fields from import state -! SetExport Subr. Private Set fields from export state -! CreateImpGrid Subr. Private Create ESMF grid for import -! CreateExpGrid Subr. Private Create ESMF grid for export -! CreateImpMesh Subr. Private Create ESMF mesh for import -! CreateExpMesh Subr. Private Create ESMF mesh for export -! SetupImpBmsk Subr. Private Setup background blending mask -! BlendImpField Subr. Private Blend import field with background -! SetupImpMmsk Subr. Private Setup merging mask -! FieldFill Subr. Private Fill ESMF field -! FieldGather Subr. Private Gather ESMF field -! FieldIndex Func. Private Return field index -! PrintTimers Subr. Private Print wallclock timers -! CalcDecomp Subr. Private Calculate a 2D processor layout -! GetEnvValue Subr. Private Get value of env. variable -! GetZlevels Subr. Private Get z-levels from file for SDC -! CalcCharnk Subr. Private Calculate Charnock for export -! CalcRoughl Subr. Private Calculate roughness length for export -! CalcBotcur Subr. Private Calculate wave-bottom currents for export -! CalcRadstr2D Subr. Private Calculate 2D radiation stresses for export -! CalcStokes3D Subr. Private Calculate 3D Stokes drift current for export -! CalcPStokes Subr. Private Calculate partitioned Stokes drift for export -! ReadFromFile Subr. Private Read input file -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! See subroutine documentation. -! -! !/MPI Switch for enabling Message Passing Interface API -! !/SHRD Switch for shared memory architecture -! !/DIST Switch for distributed memory architecture -! !/ST3 WAM 4+ input and dissipation. -! !/ST4 Ardhuin et al. (2009, 2010) -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ Use associated modules -!/ -! --- ESMF Module - use ESMF - -! --- NUOPC modules - use NUOPC - use NUOPC_Model, parent_SetServices => SetServices - -! --- WW3 modules - use CONSTANTS - use WMINITMD, only: WMINIT, WMINITNML - use WMWAVEMD, only: WMWAVE - use WMFINLMD, only: WMFINL - use WMMDATMD - use W3GDATMD - use W3IDATMD - use W3ODATMD - use W3WDATMD - use W3ADATMD - use W3TIMEMD - use WMUPDTMD, only: WMUPD2 - use W3UPDTMD, only: W3UINI +module WMESMFMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | J. Meixner, NCEP | + !/ | A. J. van der Westhuysen | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ 09-Aug-2017 : Add ocean forcing export fields ( version 6.03 ) + !/ 28-Feb-2018 : Modifications for unstruc meshes ( version 6.06 ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! National Unified Prediction Capability (NUOPC) based + ! Earth System Modeling Framework (ESMF) interface module for + ! multi-grid wave model. + ! + ! 2. Variables and types : + ! + ! All module variables and types are scoped private by default. + ! The private module variables and types are not listed in this section. + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! All module subroutines and functions are scoped private by default. + ! + ! Name Type Scope Description + ! ----------------------------------------------------------------- + ! SetServices Subr. Public Wave model ESMF Set Services + ! ----------------------------------------------------------------- + ! InitializeP0 Subr. Private NUOPC/ESMF Initialize phase 0 + ! InitializeP1 Subr. Private NUOPC/ESMF Initialize phase 1 + ! InitializeP3 Subr. Private NUOPC/ESMF Initialize phase 3 + ! Finalize Subr. Private NUOPC/ESMF Finalize + ! DataInitialize Subr. Private NUOPC/ESMF Data Initialize + ! ModelAdvance Subr. Private NUOPC/ESMF Model Advance + ! GetImport Subr. Private Get fields from import state + ! SetExport Subr. Private Set fields from export state + ! CreateImpGrid Subr. Private Create ESMF grid for import + ! CreateExpGrid Subr. Private Create ESMF grid for export + ! CreateImpMesh Subr. Private Create ESMF mesh for import + ! CreateExpMesh Subr. Private Create ESMF mesh for export + ! SetupImpBmsk Subr. Private Setup background blending mask + ! BlendImpField Subr. Private Blend import field with background + ! SetupImpMmsk Subr. Private Setup merging mask + ! FieldFill Subr. Private Fill ESMF field + ! FieldGather Subr. Private Gather ESMF field + ! FieldIndex Func. Private Return field index + ! PrintTimers Subr. Private Print wallclock timers + ! CalcDecomp Subr. Private Calculate a 2D processor layout + ! GetEnvValue Subr. Private Get value of env. variable + ! GetZlevels Subr. Private Get z-levels from file for SDC + ! CalcCharnk Subr. Private Calculate Charnock for export + ! CalcRoughl Subr. Private Calculate roughness length for export + ! CalcBotcur Subr. Private Calculate wave-bottom currents for export + ! CalcRadstr2D Subr. Private Calculate 2D radiation stresses for export + ! CalcStokes3D Subr. Private Calculate 3D Stokes drift current for export + ! CalcPStokes Subr. Private Calculate partitioned Stokes drift for export + ! ReadFromFile Subr. Private Read input file + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! !/MPI Switch for enabling Message Passing Interface API + ! !/SHRD Switch for shared memory architecture + ! !/DIST Switch for distributed memory architecture + ! !/ST3 WAM 4+ input and dissipation. + ! !/ST4 Ardhuin et al. (2009, 2010) + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ Use associated modules + !/ + ! --- ESMF Module + use ESMF + + ! --- NUOPC modules + use NUOPC + use NUOPC_Model, parent_SetServices => SetServices + + ! --- WW3 modules + use CONSTANTS + use WMINITMD, only: WMINIT, WMINITNML + use WMWAVEMD, only: WMWAVE + use WMFINLMD, only: WMFINL + use WMMDATMD + use W3GDATMD + use W3IDATMD + use W3ODATMD + use W3WDATMD + use W3ADATMD + use W3TIMEMD + use WMUPDTMD, only: WMUPD2 + use W3UPDTMD, only: W3UINI #ifdef W3_ST3 - use W3SRC3MD, only: W3SPR3 + use W3SRC3MD, only: W3SPR3 #endif #ifdef W3_ST4 - use W3SRC4MD, only: W3SPR4 + use W3SRC4MD, only: W3SPR4 #endif - use W3IOGOMD, only: W3OUTG + use W3IOGOMD, only: W3OUTG #ifdef W3_SCRIP - use WMSCRPMD, only: get_scrip_info_structured + use WMSCRPMD, only: get_scrip_info_structured #endif -!/ -!/ Specify default data typing -!/ - implicit none -!/ -!/ Include MPI definitions -!/ + !/ + !/ Specify default data typing + !/ + implicit none + !/ + !/ Include MPI definitions + !/ #ifdef W3_MPI - include "mpif.h" + include "mpif.h" #endif -!/ -!/ Specify default accessibility -!/ - private - save -!/ -!/ Public module methods -!/ - public SetServices, SetVM -!/ -!/ Private module parameters -!/ -! --- Default Mask Convention for import/export fields - INTEGER, PARAMETER :: DEFAULT_MASK_WATER = 0 !< DEFAULT_MASK_WATER - INTEGER, PARAMETER :: DEFAULT_MASK_LAND = 1 !< DEFAULT_MASK_LAND - -! --- Miscellaneous - integer, parameter :: stdo = 6 !< stdo - type(ESMF_VM) :: vm !< vm - integer :: lpet !< lpet - integer :: npet !< npet - integer :: verbosity !< verbosity - logical :: realizeAllExport = .false. !< realizeAllExport - integer :: maskValueWater = DEFAULT_MASK_WATER !< maskValueWater - integer :: maskValueLand = DEFAULT_MASK_LAND !< maskValueLand - integer :: nz !< nz Number of z-levels for SDC - real(4), allocatable :: zl(:) !< zl Array of z-levels for SDC - character(256) :: zlfile = 'none' !< zlfile File containing z-levels for SDC - character(ESMF_MAXSTR) :: msg !< msg - real(ESMF_KIND_RX) :: zeroValue !< zeroValue - real(ESMF_KIND_RX) :: missingValue !< missingValue - real(ESMF_KIND_RX) :: fillValue !< fillValue -! -! --- Timing - integer, parameter :: numwt=10 !< numwt - character(32) :: wtnam(numwt) !< wtnam - integer :: wtcnt(numwt) !< wtcnt - real(8) :: wtime(numwt) !< wtime -! -! --- Import fields - type(ESMF_ArraySpec) :: impArraySpec2D !< impArraySpec2D - type(ESMF_StaggerLoc) :: impStaggerLoc !< impStaggerLoc - type(ESMF_Index_Flag) :: impIndexFlag !< impIndexFlag - type(ESMF_Grid) :: impGrid !< impGrid - integer :: impGridID !< impGridID - logical :: impGridIsLocal !< impGridIsLocal - integer, parameter :: impHaloWidth = 3 !< impHaloWidth - integer :: impHaloLWidth(2) !< impHaloLWidth - integer :: impHaloUWidth(2) !< impHaloUWidth - type(ESMF_RouteHandle) :: impHaloRH !< impHaloRH - type(ESMF_Field) :: impMask !< impMask - logical :: noActiveImpFields !< noActiveImpFields - integer :: numImpFields !< numImpFields - character(64), allocatable :: impFieldName(:) !< impFieldName - character(128), allocatable :: impFieldStdName(:) !< impFieldStdName - logical, allocatable :: impFieldInitRqrd(:) !< impFieldInitRqrd - logical, allocatable :: impFieldActive(:) !< impFieldActive - type(ESMF_Field), allocatable :: impField(:) !< impField -! -! --- Background import fields - character(10), allocatable :: mbgFieldName(:) !< mbgFieldName - character(128), allocatable :: mbgFieldStdName(:) !< mbgFieldStdName - logical, allocatable :: mbgFieldActive(:) !< mbgFieldActive - type(ESMF_Field), allocatable :: mbgField(:) !< mbgField - type(ESMF_Field), allocatable :: bmskField(:) !< bmskField -! -! --- Unstructured import meshes - type(ESMF_Mesh) :: impMesh !< impMesh -! integer :: impMeshID !< impMeshID -! logical :: impMeshIsLocal !< impMeshIsLocal -! -! --- Export fields - type(ESMF_ArraySpec) :: expArraySpec2D !< expArraySpec2D - type(ESMF_ArraySpec) :: expArraySpec3D !< expArraySpec3D - type(ESMF_StaggerLoc) :: expStaggerLoc !< expStaggerLoc - type(ESMF_Index_Flag) :: expIndexFlag !< expIndexFlag - type(ESMF_Grid) :: expGrid !< expGrid - integer :: expGridID = 1 !< expGridID - logical :: expGridIsLocal !< expGridIsLocal - integer, parameter :: expHaloWidth = 3 !< expHaloWidth - integer :: expHaloLWidth(2) !< expHaloLWidth - integer :: expHaloUWidth(2) !< expHaloUWidth - type(ESMF_RouteHandle) :: expHaloRH !< expHaloRH - type(ESMF_Field) :: expMask !< expMask - logical :: noActiveExpFields !< noActiveExpFields - integer :: numExpFields !< numExpFields - character(64), allocatable :: expFieldName(:) !< expFieldName - character(128), allocatable :: expFieldStdName(:) !< expFieldStdName - integer, allocatable :: expFieldDim(:) !< expFieldDim - logical, allocatable :: expFieldActive(:) !< expFieldActive - type(ESMF_Field), allocatable :: expField(:) !< expField -! -! --- Unstructured export meshes - type(ESMF_Mesh) :: expMesh !< expMesh - integer :: expMeshID !< expMeshID - logical :: expMeshIsLocal !< expMeshIsLocal -! -! --- Native field stuff - type(ESMF_ArraySpec) :: natArraySpec1D !< natArraySpec1D - type(ESMF_ArraySpec) :: natArraySpec2D !< natArraySpec2D - type(ESMF_ArraySpec) :: natArraySpec3D !< natArraySpec3D - type(ESMF_StaggerLoc) :: natStaggerLoc !< natStaggerLoc - type(ESMF_Index_Flag) :: natIndexFlag !< natIndexFlag - type(ESMF_Grid) :: natGrid !< natGrid - integer :: natGridID !< natGridID - logical :: natGridIsLocal !< natGridIsLocal - type(ESMF_RouteHandle):: n2eRH !< n2eRH -! -! --- Mediator - logical :: med_present = .false. !< med_present - character(256) :: flds_scalar_name = '' !< flds_scalar_name - integer :: flds_scalar_num = 0 !< flds_scalar_num - ! flds_scalar_index_nx and flds_scalar_index_nx are domain - ! metadata that allows CMEPS to convert a mesh back to 2d - ! space for mediator restart and history outputs - integer :: flds_scalar_index_nx = 0 !< flds_scalar_index_nx - integer :: flds_scalar_index_ny = 0 !< flds_scalar_index_ny -! --- Memory Profiling - logical :: profile_memory = .false. !< profile_memory -! -! --- Coupling stuff for non completely overlapped domains - logical :: merge_import = .false. !< merge_import - logical, allocatable :: mmskCreated(:) !< mmskCreated - type(ESMF_Field), allocatable :: mmskField(:) !< mmskField - type(ESMF_Field), allocatable :: mdtField(:) !< mdtField -!/ -!/ ------------------------------------------------------------------- / - contains -!/ ------------------------------------------------------------------- / -!> -!> @brief Wave model ESMF set services. -!> -!> @param gcomp Gridded component. -!> @param[out] rc Return code. -!> -!> @author T. J. Campbell @date 20-Jan-2017 -!> + !/ + !/ Specify default accessibility + !/ + private + save + !/ + !/ Public module methods + !/ + public SetServices, SetVM + !/ + !/ Private module parameters + !/ + ! --- Default Mask Convention for import/export fields + INTEGER, PARAMETER :: DEFAULT_MASK_WATER = 0 !< DEFAULT_MASK_WATER + INTEGER, PARAMETER :: DEFAULT_MASK_LAND = 1 !< DEFAULT_MASK_LAND + + ! --- Miscellaneous + integer, parameter :: stdo = 6 !< stdo + type(ESMF_VM) :: vm !< vm + integer :: lpet !< lpet + integer :: npet !< npet + integer :: verbosity !< verbosity + logical :: realizeAllExport = .false. !< realizeAllExport + integer :: maskValueWater = DEFAULT_MASK_WATER !< maskValueWater + integer :: maskValueLand = DEFAULT_MASK_LAND !< maskValueLand + integer :: nz !< nz Number of z-levels for SDC + real(4), allocatable :: zl(:) !< zl Array of z-levels for SDC + character(256) :: zlfile = 'none' !< zlfile File containing z-levels for SDC + character(ESMF_MAXSTR) :: msg !< msg + real(ESMF_KIND_RX) :: zeroValue !< zeroValue + real(ESMF_KIND_RX) :: missingValue !< missingValue + real(ESMF_KIND_RX) :: fillValue !< fillValue + ! + ! --- Timing + integer, parameter :: numwt=10 !< numwt + character(32) :: wtnam(numwt) !< wtnam + integer :: wtcnt(numwt) !< wtcnt + real(8) :: wtime(numwt) !< wtime + ! + ! --- Import fields + type(ESMF_ArraySpec) :: impArraySpec2D !< impArraySpec2D + type(ESMF_StaggerLoc) :: impStaggerLoc !< impStaggerLoc + type(ESMF_Index_Flag) :: impIndexFlag !< impIndexFlag + type(ESMF_Grid) :: impGrid !< impGrid + integer :: impGridID !< impGridID + logical :: impGridIsLocal !< impGridIsLocal + integer, parameter :: impHaloWidth = 3 !< impHaloWidth + integer :: impHaloLWidth(2) !< impHaloLWidth + integer :: impHaloUWidth(2) !< impHaloUWidth + type(ESMF_RouteHandle) :: impHaloRH !< impHaloRH + type(ESMF_Field) :: impMask !< impMask + logical :: noActiveImpFields !< noActiveImpFields + integer :: numImpFields !< numImpFields + character(64), allocatable :: impFieldName(:) !< impFieldName + character(128), allocatable :: impFieldStdName(:) !< impFieldStdName + logical, allocatable :: impFieldInitRqrd(:) !< impFieldInitRqrd + logical, allocatable :: impFieldActive(:) !< impFieldActive + type(ESMF_Field), allocatable :: impField(:) !< impField + ! + ! --- Background import fields + character(10), allocatable :: mbgFieldName(:) !< mbgFieldName + character(128), allocatable :: mbgFieldStdName(:) !< mbgFieldStdName + logical, allocatable :: mbgFieldActive(:) !< mbgFieldActive + type(ESMF_Field), allocatable :: mbgField(:) !< mbgField + type(ESMF_Field), allocatable :: bmskField(:) !< bmskField + ! + ! --- Unstructured import meshes + type(ESMF_Mesh) :: impMesh !< impMesh + ! integer :: impMeshID !< impMeshID + ! logical :: impMeshIsLocal !< impMeshIsLocal + ! + ! --- Export fields + type(ESMF_ArraySpec) :: expArraySpec2D !< expArraySpec2D + type(ESMF_ArraySpec) :: expArraySpec3D !< expArraySpec3D + type(ESMF_StaggerLoc) :: expStaggerLoc !< expStaggerLoc + type(ESMF_Index_Flag) :: expIndexFlag !< expIndexFlag + type(ESMF_Grid) :: expGrid !< expGrid + integer :: expGridID = 1 !< expGridID + logical :: expGridIsLocal !< expGridIsLocal + integer, parameter :: expHaloWidth = 3 !< expHaloWidth + integer :: expHaloLWidth(2) !< expHaloLWidth + integer :: expHaloUWidth(2) !< expHaloUWidth + type(ESMF_RouteHandle) :: expHaloRH !< expHaloRH + type(ESMF_Field) :: expMask !< expMask + logical :: noActiveExpFields !< noActiveExpFields + integer :: numExpFields !< numExpFields + character(64), allocatable :: expFieldName(:) !< expFieldName + character(128), allocatable :: expFieldStdName(:) !< expFieldStdName + integer, allocatable :: expFieldDim(:) !< expFieldDim + logical, allocatable :: expFieldActive(:) !< expFieldActive + type(ESMF_Field), allocatable :: expField(:) !< expField + ! + ! --- Unstructured export meshes + type(ESMF_Mesh) :: expMesh !< expMesh + integer :: expMeshID !< expMeshID + logical :: expMeshIsLocal !< expMeshIsLocal + ! + ! --- Native field stuff + type(ESMF_ArraySpec) :: natArraySpec1D !< natArraySpec1D + type(ESMF_ArraySpec) :: natArraySpec2D !< natArraySpec2D + type(ESMF_ArraySpec) :: natArraySpec3D !< natArraySpec3D + type(ESMF_StaggerLoc) :: natStaggerLoc !< natStaggerLoc + type(ESMF_Index_Flag) :: natIndexFlag !< natIndexFlag + type(ESMF_Grid) :: natGrid !< natGrid + integer :: natGridID !< natGridID + logical :: natGridIsLocal !< natGridIsLocal + type(ESMF_RouteHandle):: n2eRH !< n2eRH + ! + ! --- Mediator + logical :: med_present = .false. !< med_present + character(256) :: flds_scalar_name = '' !< flds_scalar_name + integer :: flds_scalar_num = 0 !< flds_scalar_num + ! flds_scalar_index_nx and flds_scalar_index_nx are domain + ! metadata that allows CMEPS to convert a mesh back to 2d + ! space for mediator restart and history outputs + integer :: flds_scalar_index_nx = 0 !< flds_scalar_index_nx + integer :: flds_scalar_index_ny = 0 !< flds_scalar_index_ny + ! --- Memory Profiling + logical :: profile_memory = .false. !< profile_memory + ! + ! --- Coupling stuff for non completely overlapped domains + logical :: merge_import = .false. !< merge_import + logical, allocatable :: mmskCreated(:) !< mmskCreated + type(ESMF_Field), allocatable :: mmskField(:) !< mmskField + type(ESMF_Field), allocatable :: mdtField(:) !< mdtField + !/ + !/ ------------------------------------------------------------------- / +contains + !/ ------------------------------------------------------------------- / + !> + !> @brief Wave model ESMF set services. + !> + !> @param gcomp Gridded component. + !> @param[out] rc Return code. + !> + !> @author T. J. Campbell @date 20-Jan-2017 + !> #undef METHOD #define METHOD "SetServices" - subroutine SetServices ( gcomp, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Wave model ESMF set services. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! InitializeP0 Subr. WMESMFMD Wave model NUOPC/ESMF Initialize phase 0 -! InitializeP1 Subr. WMESMFMD Wave model NUOPC/ESMF Initialize phase 1 -! InitializeP3 Subr. WMESMFMD Wave model NUOPC/ESMF Initialize phase 3 -! Finalize Subr. WMESMFMD Wave model NUOPC/ESMF Finalize -! DataInitialize Subr. WMESMFMD Wave model NUOPC/ESMF Data Initialize -! ModelAdvance Subr. WMESMFMD Wave model NUOPC/ESMF Model Advance -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - !NONE -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - -! --- Initialize wallclock timers - - wtnam( 1) = 'InitializeP0' - wtnam( 2) = 'InitializeP1' - wtnam( 3) = 'InitializeP3' - wtnam( 4) = 'DataInitialize' - wtnam( 5) = 'ModelAdvance' - wtnam( 6) = 'Finalize' - wtnam( 7) = 'GetImport' - wtnam( 8) = 'SetExport' - wtnam( 9) = 'FieldGather' - wtnam(10) = 'FieldFill' - wtcnt( :) = 0 - wtime( :) = 0d0 -! -! -------------------------------------------------------------------- / -! 1. NUOPC model component will register the generic methods -! - call NUOPC_CompDerive(gcomp, parent_SetServices, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! 2. Set model entry points -! -! --- Initialize - phase 0 (requires use of ESMF method) - - call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & - userRoutine=InitializeP0, phase=0, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - -! --- Set entry points for initialize methods - - ! >= IPDv03 supports satisfying inter-model data dependencies and - ! the transfer of ESMF Grid & Mesh objects between Model and/or - ! Mediator components during initialization - ! IPDv03p1: advertise import & export fields - call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & - phaseLabelList=(/"IPDv03p1"/), userRoutine=InitializeP1, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - ! IPDv03p2: unspecified by NUOPC -- not required - ! IPDv03p3: realize import & export fields - call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & - phaseLabelList=(/"IPDv03p3"/), userRoutine=InitializeP3, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - ! IPDv03p4: relevant for TransferActionGeomObject=="accept" - ! IPDv03p5: relevant for TransferActionGeomObject=="accept" - ! IPDv03p6: check compatibility of fields connected status - ! IPDv03p7: handle field data initialization - -! -! -------------------------------------------------------------------- / -! 3. Register specializing methods -! -! --- Model initialize export data method - - call NUOPC_CompSpecialize(gcomp, specLabel=label_DataInitialize, & - specRoutine=DataInitialize, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - -! --- Model checkImport method (overriding default) - - call ESMF_MethodRemove(gcomp, label_CheckImport, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call NUOPC_CompSpecialize(gcomp, specLabel=label_CheckImport, & - specRoutine=NUOPC_NoOp, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - -! --- Model advance method - - call NUOPC_CompSpecialize(gcomp, specLabel=label_Advance, & - specRoutine=ModelAdvance, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - -! --- Model finalize method - - call NUOPC_CompSpecialize(gcomp, specLabel=label_Finalize, & - specRoutine=Finalize, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! Post -! - rc = ESMF_SUCCESS -!/ -!/ End of SetServices ------------------------------------------------ / -!/ - end subroutine SetServices -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize wave model (phase 0). -!> -!> @details Define the NUOPC Initialize Phase Mapping. -!> -!> @param gcomp Gridded component. -!> @param impState Import state. -!> @param expState Export state. -!> @param extClock External clock. -!> @param[out] rc Return code. -!> -!> @author T. J. Campbell @date 20-Jan-2017 -!> + subroutine SetServices ( gcomp, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Wave model ESMF set services. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! InitializeP0 Subr. WMESMFMD Wave model NUOPC/ESMF Initialize phase 0 + ! InitializeP1 Subr. WMESMFMD Wave model NUOPC/ESMF Initialize phase 1 + ! InitializeP3 Subr. WMESMFMD Wave model NUOPC/ESMF Initialize phase 3 + ! Finalize Subr. WMESMFMD Wave model NUOPC/ESMF Finalize + ! DataInitialize Subr. WMESMFMD Wave model NUOPC/ESMF Data Initialize + ! ModelAdvance Subr. WMESMFMD Wave model NUOPC/ESMF Model Advance + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + !NONE + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + + ! --- Initialize wallclock timers + + wtnam( 1) = 'InitializeP0' + wtnam( 2) = 'InitializeP1' + wtnam( 3) = 'InitializeP3' + wtnam( 4) = 'DataInitialize' + wtnam( 5) = 'ModelAdvance' + wtnam( 6) = 'Finalize' + wtnam( 7) = 'GetImport' + wtnam( 8) = 'SetExport' + wtnam( 9) = 'FieldGather' + wtnam(10) = 'FieldFill' + wtcnt( :) = 0 + wtime( :) = 0d0 + ! + ! -------------------------------------------------------------------- / + ! 1. NUOPC model component will register the generic methods + ! + call NUOPC_CompDerive(gcomp, parent_SetServices, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! 2. Set model entry points + ! + ! --- Initialize - phase 0 (requires use of ESMF method) + + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=InitializeP0, phase=0, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + ! --- Set entry points for initialize methods + + ! >= IPDv03 supports satisfying inter-model data dependencies and + ! the transfer of ESMF Grid & Mesh objects between Model and/or + ! Mediator components during initialization + ! IPDv03p1: advertise import & export fields + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv03p1"/), userRoutine=InitializeP1, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! IPDv03p2: unspecified by NUOPC -- not required + ! IPDv03p3: realize import & export fields + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv03p3"/), userRoutine=InitializeP3, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! IPDv03p4: relevant for TransferActionGeomObject=="accept" + ! IPDv03p5: relevant for TransferActionGeomObject=="accept" + ! IPDv03p6: check compatibility of fields connected status + ! IPDv03p7: handle field data initialization + + ! + ! -------------------------------------------------------------------- / + ! 3. Register specializing methods + ! + ! --- Model initialize export data method + + call NUOPC_CompSpecialize(gcomp, specLabel=label_DataInitialize, & + specRoutine=DataInitialize, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + ! --- Model checkImport method (overriding default) + + call ESMF_MethodRemove(gcomp, label_CheckImport, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call NUOPC_CompSpecialize(gcomp, specLabel=label_CheckImport, & + specRoutine=NUOPC_NoOp, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + ! --- Model advance method + + call NUOPC_CompSpecialize(gcomp, specLabel=label_Advance, & + specRoutine=ModelAdvance, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + ! --- Model finalize method + + call NUOPC_CompSpecialize(gcomp, specLabel=label_Finalize, & + specRoutine=Finalize, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! Post + ! + rc = ESMF_SUCCESS + !/ + !/ End of SetServices ------------------------------------------------ / + !/ + end subroutine SetServices + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize wave model (phase 0). + !> + !> @details Define the NUOPC Initialize Phase Mapping. + !> + !> @param gcomp Gridded component. + !> @param impState Import state. + !> @param expState Export state. + !> @param extClock External clock. + !> @param[out] rc Return code. + !> + !> @author T. J. Campbell @date 20-Jan-2017 + !> #undef METHOD #define METHOD "InitializeP0" - subroutine InitializeP0 ( gcomp, impState, expState, extClock, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Initialize wave model (phase 0) -! * Define the NUOPC Initialize Phase Mapping -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! impState Type I/O Import state -! expState Type I/O Export state -! extClock Type I External clock -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - type(ESMF_State) :: impState - type(ESMF_State) :: expState - type(ESMF_Clock) :: extClock - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - character(ESMF_MAXSTR) :: valueString - integer, parameter :: iwt=1 - real(8) :: wstime, wftime - logical :: isPresent, isSet -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - call ESMF_VMWtime(wstime) - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! Determine verbosity -! - call NUOPC_CompAttributeGet(gcomp, name='Verbosity', & - value=valueString, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - verbosity = ESMF_UtilString2Int( valueString, & - specialStringList=(/'high','max '/), & - specialValueList=(/ 255, 255/), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered InitializeP0', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! Define initialization phases -! * switch to IPDv03 by filtering all other phaseMap entries -! - call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & - acceptStringList=(/"IPDv03p"/), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! Check if coupled with CMEPS mediator or not -! - call NUOPC_CompAttributeGet(gcomp, name="mediator_present", & - value=valueString, isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - if (isPresent .and. isSet) then - read(valueString,*) med_present - call ESMF_LogWrite(trim(cname)//': mediator_present = '// & - trim(valueString), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if -! -! -------------------------------------------------------------------- / -! Set memory profiling -! - call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", & - value=valueString, isPresent=isPresent, isSet=isSet, rc=rc) + subroutine InitializeP0 ( gcomp, impState, expState, extClock, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Initialize wave model (phase 0) + ! * Define the NUOPC Initialize Phase Mapping + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! impState Type I/O Import state + ! expState Type I/O Export state + ! extClock Type I External clock + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: impState + type(ESMF_State) :: expState + type(ESMF_Clock) :: extClock + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + character(ESMF_MAXSTR) :: valueString + integer, parameter :: iwt=1 + real(8) :: wstime, wftime + logical :: isPresent, isSet + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + call ESMF_VMWtime(wstime) + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! Determine verbosity + ! + call NUOPC_CompAttributeGet(gcomp, name='Verbosity', & + value=valueString, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + verbosity = ESMF_UtilString2Int( valueString, & + specialStringList=(/'high','max '/), & + specialValueList=(/ 255, 255/), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered InitializeP0', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! Define initialization phases + ! * switch to IPDv03 by filtering all other phaseMap entries + ! + call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & + acceptStringList=(/"IPDv03p"/), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! Check if coupled with CMEPS mediator or not + ! + call NUOPC_CompAttributeGet(gcomp, name="mediator_present", & + value=valueString, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + if (isPresent .and. isSet) then + read(valueString,*) med_present + call ESMF_LogWrite(trim(cname)//': mediator_present = '// & + trim(valueString), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + end if + ! + ! -------------------------------------------------------------------- / + ! Set memory profiling + ! + call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", & + value=valueString, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + if (isPresent .and. isSet) then + read(valueString,*) profile_memory + call ESMF_LogWrite(trim(cname)//': profile_memory = '// & + trim(valueString), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + end if + + ! + ! -------------------------------------------------------------------- / + ! Post + ! + rc = ESMF_SUCCESS + call ESMF_VMWtime(wftime) + wtime(iwt) = wtime(iwt) + wftime - wstime + wtcnt(iwt) = wtcnt(iwt) + 1 + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving InitializeP0', ESMF_LOGMSG_INFO) + !/ + !/ End of InitializeP0 ----------------------------------------------- / + !/ + end subroutine InitializeP0 + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize wave model (phase 1). + !> + !> @details Advertise fields in import and export states. + !> + !> @param gcomp Gridded component. + !> @param impState Import state. + !> @param expState Export state. + !> @param extClock External clock. + !> @param[out] rc Return code. + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> +#undef METHOD +#define METHOD "InitializeP1" + subroutine InitializeP1 ( gcomp, impState, expState, extClock, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ 09-Aug-2017 : Add ocean forcing export fields ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Initialize wave model (phase 1) + ! * Advertise fields in import and export states. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! impState Type I/O Import state + ! expState Type I/O Export state + ! extClock Type I External clock + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINIT Subr. WMINITMD Wave model initialization + ! WMINITNML Subr. WMINITMD Wave model initialization + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! ---------------------------------------------------------------- + ! 1. Initialization necessary for driver + ! a General I/O: (implicit in WMMDATMD) + ! b MPI environment + ! c Identifying output to "screen" unit + ! 2. Initialization of all wave models / grids + ! 3. Advertise import fields + ! 4. Advertise export fields + ! ---------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: impState + type(ESMF_State) :: expState + type(ESMF_Clock) :: extClock + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + integer, parameter :: iwt=2 + real(8) :: wstime, wftime + integer :: idsi, idso, idss, idst, idse + integer :: mpiComm = -99 + logical :: configIsPresent + type(ESMF_Config) :: config + character(ESMF_MAXSTR) :: wrkdir = '.' + character(ESMF_MAXSTR) :: preamb = '.' + character(ESMF_MAXSTR) :: ifname = 'ww3_multi.inp' + logical :: lsep_ss = .true. + logical :: lsep_st = .true. + logical :: lsep_se = .true. + character(ESMF_MAXSTR) :: attstr + integer(ESMF_KIND_I4) :: yy,mm,dd,h,m,s + type(ESMF_Time) :: ttmp, cttmp + type(ESMF_TimeInterval) :: tstep, etstep + integer :: i, j, n, istep, imod, jmod + integer, allocatable :: cplmap(:,:) + logical :: includeObg, includeAbg, includeIbg + character(256) :: cvalue, logmsg + logical :: isPresent, isSet + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + call ESMF_VMWtime(wstime) + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered InitializeP1', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! Query mediator specific attributes + ! + if (med_present) then + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", & + value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (isPresent .and. isSet) then - read(valueString,*) profile_memory - call ESMF_LogWrite(trim(cname)//': profile_memory = '// & - trim(valueString), ESMF_LOGMSG_INFO, rc=rc) + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(trim(cname)//': flds_scalar_name = '// & + trim(flds_scalar_name), ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return end if -! -! -------------------------------------------------------------------- / -! Post -! - rc = ESMF_SUCCESS - call ESMF_VMWtime(wftime) - wtime(iwt) = wtime(iwt) + wftime - wstime - wtcnt(iwt) = wtcnt(iwt) + 1 - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving InitializeP0', ESMF_LOGMSG_INFO) -!/ -!/ End of InitializeP0 ----------------------------------------------- / -!/ - end subroutine InitializeP0 -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize wave model (phase 1). -!> -!> @details Advertise fields in import and export states. -!> -!> @param gcomp Gridded component. -!> @param impState Import state. -!> @param expState Export state. -!> @param extClock External clock. -!> @param[out] rc Return code. -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> -#undef METHOD -#define METHOD "InitializeP1" - subroutine InitializeP1 ( gcomp, impState, expState, extClock, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ 09-Aug-2017 : Add ocean forcing export fields ( version 6.03 ) -!/ -! 1. Purpose : -! -! Initialize wave model (phase 1) -! * Advertise fields in import and export states. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! impState Type I/O Import state -! expState Type I/O Export state -! extClock Type I External clock -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINIT Subr. WMINITMD Wave model initialization -! WMINITNML Subr. WMINITMD Wave model initialization -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! ---------------------------------------------------------------- -! 1. Initialization necessary for driver -! a General I/O: (implicit in WMMDATMD) -! b MPI environment -! c Identifying output to "screen" unit -! 2. Initialization of all wave models / grids -! 3. Advertise import fields -! 4. Advertise export fields -! ---------------------------------------------------------------- -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - type(ESMF_State) :: impState - type(ESMF_State) :: expState - type(ESMF_Clock) :: extClock - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - integer, parameter :: iwt=2 - real(8) :: wstime, wftime - integer :: idsi, idso, idss, idst, idse - integer :: mpiComm = -99 - logical :: configIsPresent - type(ESMF_Config) :: config - character(ESMF_MAXSTR) :: wrkdir = '.' - character(ESMF_MAXSTR) :: preamb = '.' - character(ESMF_MAXSTR) :: ifname = 'ww3_multi.inp' - logical :: lsep_ss = .true. - logical :: lsep_st = .true. - logical :: lsep_se = .true. - character(ESMF_MAXSTR) :: attstr - integer(ESMF_KIND_I4) :: yy,mm,dd,h,m,s - type(ESMF_Time) :: ttmp, cttmp - type(ESMF_TimeInterval) :: tstep, etstep - integer :: i, j, n, istep, imod, jmod - integer, allocatable :: cplmap(:,:) - logical :: includeObg, includeAbg, includeIbg - character(256) :: cvalue, logmsg - logical :: isPresent, isSet -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - call ESMF_VMWtime(wstime) - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", & + value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered InitializeP1', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! Query mediator specific attributes -! - if (med_present) then - call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (isPresent .and. isSet) then - flds_scalar_name = trim(cvalue) - call ESMF_LogWrite(trim(cname)//': flds_scalar_name = '// & - trim(flds_scalar_name), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if - - call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (isPresent .and. isSet) then + flds_scalar_num = ESMF_UtilString2Int(cvalue, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (isPresent .and. isSet) then - flds_scalar_num = ESMF_UtilString2Int(cvalue, rc=rc) + if (verbosity.gt.0) then + write(logmsg,*) flds_scalar_num + call ESMF_LogWrite(trim(cname)//': flds_scalar_num = '// & + trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) then - write(logmsg,*) flds_scalar_num - call ESMF_LogWrite(trim(cname)//': flds_scalar_num = '// & - trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if end if + end if - call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", & + value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (isPresent .and. isSet) then + flds_scalar_index_nx = ESMF_UtilString2Int(cvalue, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (isPresent .and. isSet) then - flds_scalar_index_nx = ESMF_UtilString2Int(cvalue, rc=rc) + if (verbosity.gt.0) then + write(logmsg,*) flds_scalar_index_nx + call ESMF_LogWrite(trim(cname)//': flds_scalar_index_nx = '// & + trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) then - write(logmsg,*) flds_scalar_index_nx - call ESMF_LogWrite(trim(cname)//': flds_scalar_index_nx = '// & - trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if end if + end if - call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", & + value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (isPresent .and. isSet) then + flds_scalar_index_ny = ESMF_UtilString2Int(cvalue, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (isPresent .and. isSet) then - flds_scalar_index_ny = ESMF_UtilString2Int(cvalue, rc=rc) + if (verbosity.gt.0) then + write(logmsg,*) flds_scalar_index_ny + call ESMF_LogWrite(trim(cname)//': flds_scalar_index_ny = '// & + trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) then - write(logmsg,*) flds_scalar_index_ny - call ESMF_LogWrite(trim(cname)//': flds_scalar_index_ny = '// & - trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if end if + end if - call NUOPC_CompAttributeGet(gcomp, name="mask_value_water", & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name="mask_value_water", & + value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (isPresent .and. isSet) then + maskvaluewater = ESMF_UtilString2Int(cvalue, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (isPresent .and. isSet) then - maskvaluewater = ESMF_UtilString2Int(cvalue, rc=rc) + if (verbosity.gt.0) then + write(logmsg,*) maskvaluewater + call ESMF_LogWrite(trim(cname)//': mask_value_water = '// & + trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) then - write(logmsg,*) maskvaluewater - call ESMF_LogWrite(trim(cname)//': mask_value_water = '// & - trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if end if + end if - call NUOPC_CompAttributeGet(gcomp, name="mask_value_land", & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name="mask_value_land", & + value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (isPresent .and. isSet) then + maskvalueland = ESMF_UtilString2Int(cvalue, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (isPresent .and. isSet) then - maskvalueland = ESMF_UtilString2Int(cvalue, rc=rc) + if (verbosity.gt.0) then + write(logmsg,*) maskvalueland + call ESMF_LogWrite(trim(cname)//': mask_value_land = '// & + trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) then - write(logmsg,*) maskvalueland - call ESMF_LogWrite(trim(cname)//': mask_value_land = '// & - trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if end if end if -! -! -------------------------------------------------------------------- / -! 1. Initialization necessary for driver -! -! 1.a Set global flag indicating that model is an ESMF Component -! - is_esmf_component = .true. - zeroValue = real(0,ESMF_KIND_RX) - missingValue = real(0,ESMF_KIND_RX) - fillValue = real(9.99e20,ESMF_KIND_RX) -! -! -! 1.b Get MPI environment from ESMF VM and set WW3 MPI related variables -! - call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_VMGet(vm, petCount=npet, localPet=lpet, & - mpiCommunicator=mpiComm, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - nmproc = npet - improc = lpet + 1 - nmpscr = 1 - if ( improc .eq. nmpscr ) write (*,900) -! -! 1.c Get background model info -! + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Initialization necessary for driver + ! + ! 1.a Set global flag indicating that model is an ESMF Component + ! + is_esmf_component = .true. + zeroValue = real(0,ESMF_KIND_RX) + missingValue = real(0,ESMF_KIND_RX) + fillValue = real(9.99e20,ESMF_KIND_RX) + ! + ! + ! 1.b Get MPI environment from ESMF VM and set WW3 MPI related variables + ! + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_VMGet(vm, petCount=npet, localPet=lpet, & + mpiCommunicator=mpiComm, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + nmproc = npet + improc = lpet + 1 + nmpscr = 1 + if ( improc .eq. nmpscr ) write (*,900) + ! + ! 1.c Get background model info + ! #if defined(COAMPS) - call ESMF_AttributeGet(gcomp, name="OcnBackground", & - value=attstr, defaultValue="none", & - convention="COAMPS", purpose="General", rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - includeObg = trim(attstr).eq."model" - call ESMF_AttributeGet(gcomp, name="AtmBackground", & - value=attstr, defaultValue="none", & - convention="COAMPS", purpose="General", rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - includeAbg = trim(attstr).eq."model" - call ESMF_AttributeGet(gcomp, name="IceBackground", & - value=attstr, defaultValue="none", & - convention="COAMPS", purpose="General", rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - includeIbg = trim(attstr).eq."model" - call ESMF_AttributeGet(gcomp, name="MissingValue", & - value=missingValue, defaultValue=real(0,ESMF_KIND_RX), & - convention="COAMPS", purpose="General", rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_AttributeGet(gcomp, name="OcnBackground", & + value=attstr, defaultValue="none", & + convention="COAMPS", purpose="General", rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + includeObg = trim(attstr).eq."model" + call ESMF_AttributeGet(gcomp, name="AtmBackground", & + value=attstr, defaultValue="none", & + convention="COAMPS", purpose="General", rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + includeAbg = trim(attstr).eq."model" + call ESMF_AttributeGet(gcomp, name="IceBackground", & + value=attstr, defaultValue="none", & + convention="COAMPS", purpose="General", rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + includeIbg = trim(attstr).eq."model" + call ESMF_AttributeGet(gcomp, name="MissingValue", & + value=missingValue, defaultValue=real(0,ESMF_KIND_RX), & + convention="COAMPS", purpose="General", rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #else - includeObg = .false. - includeAbg = .false. - includeIbg = .false. + includeObg = .false. + includeAbg = .false. + includeIbg = .false. #endif -! -! 1.d Config input -! - call ESMF_GridCompGet(gcomp, configIsPresent=configIsPresent, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (configIsPresent) then - call ESMF_GridCompGet(gcomp, config=config, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - ! working directory - call ESMF_ConfigGetAttribute(config, wrkdir, & - label=trim(cname)//'_work_dir:', default='.', rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - ! I/O options - call ESMF_ConfigGetAttribute(config, ifname, & - label=trim(cname)//'_input_file_name:', & - default='ww3_multi.inp', rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_ConfigGetAttribute(config, lsep_ss, & - label=trim(cname)//'_stdo_output_to_file:', default=.false., rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_ConfigGetAttribute(config, lsep_st, & - label=trim(cname)//'_test_output_to_file:', default=.false., rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_ConfigGetAttribute(config, lsep_se, & - label=trim(cname)//'_error_output_to_file:', default=.false., rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - ! export grid id - call ESMF_ConfigGetAttribute(config, expGridID, & - label=trim(cname)//'_export_grid_id:', default=1, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - ! realize all export flag - call ESMF_ConfigGetAttribute(config, realizeAllExport, & - label=trim(cname)//'_realize_all_export:', default=.false., rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - ! grid mask convention - call ESMF_ConfigGetAttribute(config, maskValueWater, & - label='mask_value_water:', default=DEFAULT_MASK_WATER, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_ConfigGetAttribute(config, maskValueLand, & - label='mask_value_land:', default=DEFAULT_MASK_LAND, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - ! z-level file - call ESMF_ConfigGetAttribute(config, zlfile, & - label=trim(cname)//'_zlevel_exp_file:', default='none', rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! preamb = trim(wrkdir)//'/' - preamb = trim(preamb)//'/' !TODO: have separate paths for .inp, logs and data? -! -! 1.e Set internal start/stop time from external start/stop time -! - - call ESMF_ClockGet(extClock, startTime=ttmp, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_ClockGet(extClock, currTime=cttmp, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! Adjust internal start time to currTime in case of delayed start -! - if ( cttmp.gt.ttmp ) ttmp=cttmp - call ESMF_TimeGet(ttmp, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - stime(1) = 10000*yy + 100*mm + dd - stime(2) = 10000*h + 100*m + s - - call ESMF_ClockGet(extClock, stopTime=ttmp, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_TimeGet(ttmp, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - etime(1) = 10000*yy + 100*mm + dd - etime(2) = 10000*h + 100*m + s -! -! 1.f Identify available unit numbers -! Each ESMF_UtilIOUnitGet is followed by an OPEN statement for that -! unit so that subsequent ESMF_UtilIOUnitGet calls do not return the -! the same unit. After getting all the available unit numbers, close -! the units since they will be opened within WMINIT. -! - call ESMF_UtilIOUnitGet(idsi); open(unit=idsi, status='scratch'); - call ESMF_UtilIOUnitGet(idso); open(unit=idso, status='scratch'); - call ESMF_UtilIOUnitGet(idss); open(unit=idss, status='scratch'); - call ESMF_UtilIOUnitGet(idst); open(unit=idst, status='scratch'); - call ESMF_UtilIOUnitGet(idse); open(unit=idse, status='scratch'); - close(idsi); close(idso); close(idss); close(idst); close(idse); -! -! 1.g Get merging option for regional coupling that domians does not -! overlap complately. This will blend the data coming from forcing with -! the data coming from coupling. -! - call NUOPC_CompAttributeGet(gcomp, name="merge_import", & - value=attstr, isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (isPresent .and. isSet) then - if (trim(attstr) .eq. '.true.') then - merge_import = .true. - end if - end if - if (verbosity.gt.0) then - write(logmsg,'(l)') merge_import - call ESMF_LogWrite(trim(cname)//': merge_import = '// & - trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 1.d Config input + ! + call ESMF_GridCompGet(gcomp, configIsPresent=configIsPresent, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (configIsPresent) then + call ESMF_GridCompGet(gcomp, config=config, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! working directory + call ESMF_ConfigGetAttribute(config, wrkdir, & + label=trim(cname)//'_work_dir:', default='.', rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! I/O options + call ESMF_ConfigGetAttribute(config, ifname, & + label=trim(cname)//'_input_file_name:', & + default='ww3_multi.inp', rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_ConfigGetAttribute(config, lsep_ss, & + label=trim(cname)//'_stdo_output_to_file:', default=.false., rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_ConfigGetAttribute(config, lsep_st, & + label=trim(cname)//'_test_output_to_file:', default=.false., rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_ConfigGetAttribute(config, lsep_se, & + label=trim(cname)//'_error_output_to_file:', default=.false., rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! export grid id + call ESMF_ConfigGetAttribute(config, expGridID, & + label=trim(cname)//'_export_grid_id:', default=1, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! realize all export flag + call ESMF_ConfigGetAttribute(config, realizeAllExport, & + label=trim(cname)//'_realize_all_export:', default=.false., rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! grid mask convention + call ESMF_ConfigGetAttribute(config, maskValueWater, & + label='mask_value_water:', default=DEFAULT_MASK_WATER, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_ConfigGetAttribute(config, maskValueLand, & + label='mask_value_land:', default=DEFAULT_MASK_LAND, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! z-level file + call ESMF_ConfigGetAttribute(config, zlfile, & + label=trim(cname)//'_zlevel_exp_file:', default='none', rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! preamb = trim(wrkdir)//'/' + preamb = trim(preamb)//'/' !TODO: have separate paths for .inp, logs and data? + ! + ! 1.e Set internal start/stop time from external start/stop time + ! + + call ESMF_ClockGet(extClock, startTime=ttmp, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_ClockGet(extClock, currTime=cttmp, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! Adjust internal start time to currTime in case of delayed start + ! + if ( cttmp.gt.ttmp ) ttmp=cttmp + call ESMF_TimeGet(ttmp, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + stime(1) = 10000*yy + 100*mm + dd + stime(2) = 10000*h + 100*m + s + + call ESMF_ClockGet(extClock, stopTime=ttmp, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_TimeGet(ttmp, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + etime(1) = 10000*yy + 100*mm + dd + etime(2) = 10000*h + 100*m + s + ! + ! 1.f Identify available unit numbers + ! Each ESMF_UtilIOUnitGet is followed by an OPEN statement for that + ! unit so that subsequent ESMF_UtilIOUnitGet calls do not return the + ! the same unit. After getting all the available unit numbers, close + ! the units since they will be opened within WMINIT. + ! + call ESMF_UtilIOUnitGet(idsi); open(unit=idsi, status='scratch'); + call ESMF_UtilIOUnitGet(idso); open(unit=idso, status='scratch'); + call ESMF_UtilIOUnitGet(idss); open(unit=idss, status='scratch'); + call ESMF_UtilIOUnitGet(idst); open(unit=idst, status='scratch'); + call ESMF_UtilIOUnitGet(idse); open(unit=idse, status='scratch'); + close(idsi); close(idso); close(idss); close(idst); close(idse); + ! + ! 1.g Get merging option for regional coupling that domians does not + ! overlap complately. This will blend the data coming from forcing with + ! the data coming from coupling. + ! + call NUOPC_CompAttributeGet(gcomp, name="merge_import", & + value=attstr, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (isPresent .and. isSet) then + if (trim(attstr) .eq. '.true.') then + merge_import = .true. end if -! -! -------------------------------------------------------------------- / -! 2. Initialization of all wave models / grids -! -! 2.a Call into WMINIT -! - if ( .not.lsep_ss ) idss = stdo - if ( .not.lsep_st ) idst = stdo - if ( .not.lsep_se ) idse = stdo - if ( trim(ifname).eq.'ww3_multi.nml' ) then - call wminitnml ( idsi, idso, idss, idst, idse, trim(ifname), & - mpicomm, preamb=preamb ) - else - call wminit ( idsi, idso, idss, idst, idse, trim(ifname), & - mpicomm, preamb=preamb ) - endif -! -! 2.b Check consistency between internal timestep and external -! timestep (coupling interval) -! - call ESMF_ClockGet(extClock, timeStep=etstep, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 2.c Trap unsupported CPL input forcing settings -! - if ( any(inpmap.lt.0) ) then - if ( nrgrd.gt.1 ) then - if ( any(inpmap.eq.-999) ) then - write (msg,'(a)') 'CPL input forcing defined on a '// & - 'native grid is not supported with multiple model grids' - if ( improc .eq. nmpscr ) write (idse,'(a)') trim(msg) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return - endif - endif - allocate (cplmap(nrgrd,jfirst:8), stat=rc) - if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return - jmod = minval(inpmap) - cplmap = inpmap - where ( inpmap.lt.0 ) cplmap = jmod - if ( any(inpmap.ne.cplmap) ) then - write (msg,'(a)') 'All CPL input forcing must be '// & - 'defined on the same grid' + end if + if (verbosity.gt.0) then + write(logmsg,'(l)') merge_import + call ESMF_LogWrite(trim(cname)//': merge_import = '// & + trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + end if + ! + ! -------------------------------------------------------------------- / + ! 2. Initialization of all wave models / grids + ! + ! 2.a Call into WMINIT + ! + if ( .not.lsep_ss ) idss = stdo + if ( .not.lsep_st ) idst = stdo + if ( .not.lsep_se ) idse = stdo + if ( trim(ifname).eq.'ww3_multi.nml' ) then + call wminitnml ( idsi, idso, idss, idst, idse, trim(ifname), & + mpicomm, preamb=preamb ) + else + call wminit ( idsi, idso, idss, idst, idse, trim(ifname), & + mpicomm, preamb=preamb ) + endif + ! + ! 2.b Check consistency between internal timestep and external + ! timestep (coupling interval) + ! + call ESMF_ClockGet(extClock, timeStep=etstep, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 2.c Trap unsupported CPL input forcing settings + ! + if ( any(inpmap.lt.0) ) then + if ( nrgrd.gt.1 ) then + if ( any(inpmap.eq.-999) ) then + write (msg,'(a)') 'CPL input forcing defined on a '// & + 'native grid is not supported with multiple model grids' if ( improc .eq. nmpscr ) write (idse,'(a)') trim(msg) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return endif - deallocate (cplmap, stat=rc) - if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return endif -! -! -------------------------------------------------------------------- / -! 3. Initialize import field list -! - istep_import: do istep = 1, 2 - + allocate (cplmap(nrgrd,jfirst:8), stat=rc) + if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return + jmod = minval(inpmap) + cplmap = inpmap + where ( inpmap.lt.0 ) cplmap = jmod + if ( any(inpmap.ne.cplmap) ) then + write (msg,'(a)') 'All CPL input forcing must be '// & + 'defined on the same grid' + if ( improc .eq. nmpscr ) write (idse,'(a)') trim(msg) + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + deallocate (cplmap, stat=rc) + if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! 3. Initialize import field list + ! + istep_import: do istep = 1, 2 + if ( istep.eq.2 ) then allocate ( impFieldName(numImpFields), & - impFieldStdName(numImpFields), & - impFieldInitRqrd(numImpFields), & - impFieldActive(numImpFields), & - impField(numImpFields), & - stat=rc ) + impFieldStdName(numImpFields), & + impFieldInitRqrd(numImpFields), & + impFieldActive(numImpFields), & + impField(numImpFields), & + stat=rc ) if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return allocate ( mbgFieldName(numImpFields), & - mbgFieldStdName(numImpFields), & - mbgFieldActive(numImpFields), & - mbgField(numImpFields), & - bmskField(numImpFields), & - stat=rc ) + mbgFieldStdName(numImpFields), & + mbgFieldActive(numImpFields), & + mbgField(numImpFields), & + bmskField(numImpFields), & + stat=rc ) if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return if (merge_import) then allocate (mmskCreated(numImpFields)) @@ -1158,27 +1158,27 @@ subroutine InitializeP1 ( gcomp, impState, expState, extClock, rc ) endif numImpFields = i - enddo istep_import + enddo istep_import - noActiveImpFields = all(.not.impFieldActive) + noActiveImpFields = all(.not.impFieldActive) + + do i = 1,numImpFields + mbgFieldName(i) = 'mbg_'//trim(impFieldName(i)) + mbgFieldStdName(i) = 'mbg_'//trim(impFieldStdName(i)) + enddo + ! + ! -------------------------------------------------------------------- / + ! 4. Initialize export field list + ! + istep_export: do istep = 1, 2 - do i = 1,numImpFields - mbgFieldName(i) = 'mbg_'//trim(impFieldName(i)) - mbgFieldStdName(i) = 'mbg_'//trim(impFieldStdName(i)) - enddo -! -! -------------------------------------------------------------------- / -! 4. Initialize export field list -! - istep_export: do istep = 1, 2 - if ( istep.eq.2 ) then allocate ( expFieldName(numExpFields), & - expFieldStdName(numExpFields), & - expFieldDim(numExpFields), & - expFieldActive(numExpFields), & - expField(numExpFields), & - stat=rc ) + expFieldStdName(numExpFields), & + expFieldDim(numExpFields), & + expFieldActive(numExpFields), & + expField(numExpFields), & + stat=rc ) if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return expFieldActive(:) = .false. endif @@ -1296,780 +1296,780 @@ subroutine InitializeP1 ( gcomp, impState, expState, extClock, rc ) expFieldDim(i) = 2 endif - if (med_present) then + if (med_present) then i = i + 1 if ( istep.eq.2 ) then - expFieldName(i) = trim(flds_scalar_name) + expFieldName(i) = trim(flds_scalar_name) expFieldStdName(i) = trim(flds_scalar_name) expFieldDim(i) = 1 endif endif numExpFields = i - enddo istep_export - - noActiveExpFields = all(.not.expFieldActive) -! -! -------------------------------------------------------------------- / -! 5. Advertise import fields -! -! 5.a Advertise active import fields -! - n = 0 - do i = 1,numImpFields - if (.not.impFieldActive(i)) cycle - n = n + 1 - call NUOPC_Advertise(impState, & - trim(impFieldStdName(i)), name=trim(impFieldName(i)), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (.not.mbgFieldActive(i)) cycle - n = n + 1 - call NUOPC_Advertise(impState, & - trim(mbgFieldStdName(i)), name=trim(mbgFieldName(i)), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - enddo -! -! 5.b Report advertised import fields -! - write(msg,'(a,i0,a)') trim(cname)// & - ': List of advertised import fields(',n,'):' - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// & - ': ','index',' ','name',' ','standardName' + enddo istep_export + + noActiveExpFields = all(.not.expFieldActive) + ! + ! -------------------------------------------------------------------- / + ! 5. Advertise import fields + ! + ! 5.a Advertise active import fields + ! + n = 0 + do i = 1,numImpFields + if (.not.impFieldActive(i)) cycle + n = n + 1 + call NUOPC_Advertise(impState, & + trim(impFieldStdName(i)), name=trim(impFieldName(i)), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (.not.mbgFieldActive(i)) cycle + n = n + 1 + call NUOPC_Advertise(impState, & + trim(mbgFieldStdName(i)), name=trim(mbgFieldName(i)), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo + ! + ! 5.b Report advertised import fields + ! + write(msg,'(a,i0,a)') trim(cname)// & + ': List of advertised import fields(',n,'):' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// & + ': ','index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + n = 0 + do i = 1,numImpFields + if (.not.impFieldActive(i)) cycle + n = n + 1 + write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, & + ' ',trim(impFieldName(i)),' ',trim(impFieldStdName(i)) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - n = 0 - do i = 1,numImpFields - if (.not.impFieldActive(i)) cycle - n = n + 1 - write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, & - ' ',trim(impFieldName(i)),' ',trim(impFieldStdName(i)) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - if (.not.mbgFieldActive(i)) cycle - n = n + 1 - write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, & - ' ',trim(mbgFieldName(i)),' ',trim(mbgFieldStdName(i)) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - enddo -! -! -------------------------------------------------------------------- / -! 6. Advertise export fields -! -! 6.a Advertise all export fields -! - do i = 1,numExpFields - call NUOPC_Advertise(expState, & - trim(expFieldStdName(i)), name=trim(expFieldName(i)), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - enddo -! -! 6.b Report advertised export fields -! - write(msg,'(a,i0,a)') trim(cname)// & - ': List of advertised export fields(',numExpFields,'):' + if (.not.mbgFieldActive(i)) cycle + n = n + 1 + write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, & + ' ',trim(mbgFieldName(i)),' ',trim(mbgFieldStdName(i)) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// & - ': ','index',' ','name',' ','standardName' + enddo + ! + ! -------------------------------------------------------------------- / + ! 6. Advertise export fields + ! + ! 6.a Advertise all export fields + ! + do i = 1,numExpFields + call NUOPC_Advertise(expState, & + trim(expFieldStdName(i)), name=trim(expFieldName(i)), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo + ! + ! 6.b Report advertised export fields + ! + write(msg,'(a,i0,a)') trim(cname)// & + ': List of advertised export fields(',numExpFields,'):' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// & + ': ','index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + do i = 1,numExpFields + write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',i, & + ' ',trim(expFieldName(i)),' ',trim(expFieldStdName(i)) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - do i = 1,numExpFields - write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',i, & - ' ',trim(expFieldName(i)),' ',trim(expFieldStdName(i)) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - enddo -! -! -------------------------------------------------------------------- / -! Post -! - rc = ESMF_SUCCESS - call ESMF_VMWtime(wftime) - wtime(iwt) = wtime(iwt) + wftime - wstime - wtcnt(iwt) = wtcnt(iwt) + 1 - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving InitializeP1', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! Formats -! - 900 format (/15x,' *** WAVEWATCH III Multi-grid shell *** '/ & - 15x,'================================================='/) -!/ -!/ End of InitializeP1 ----------------------------------------------- / -!/ - end subroutine InitializeP1 -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize wave model (phase 3). -!> -!> @details Realize fields in import and export states. -!> -!> @param gcomp Gridded component. -!> @param impState Import state. -!> @param expState Export state. -!> @param extClock External clock. -!> @param[out] rc Return code. -!> -!> @author T. J. Campbell -!> @author A. J. van der Westhuysen -!> @date 09-Aug-2017 -!> + enddo + ! + ! -------------------------------------------------------------------- / + ! Post + ! + rc = ESMF_SUCCESS + call ESMF_VMWtime(wftime) + wtime(iwt) = wtime(iwt) + wftime - wstime + wtcnt(iwt) = wtcnt(iwt) + 1 + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving InitializeP1', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! Formats + ! +900 format (/15x,' *** WAVEWATCH III Multi-grid shell *** '/ & + 15x,'================================================='/) + !/ + !/ End of InitializeP1 ----------------------------------------------- / + !/ + end subroutine InitializeP1 + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize wave model (phase 3). + !> + !> @details Realize fields in import and export states. + !> + !> @param gcomp Gridded component. + !> @param impState Import state. + !> @param expState Export state. + !> @param extClock External clock. + !> @param[out] rc Return code. + !> + !> @author T. J. Campbell + !> @author A. J. van der Westhuysen + !> @date 09-Aug-2017 + !> #undef METHOD #define METHOD "InitializeP3" - subroutine InitializeP3 ( gcomp, impState, expState, extClock, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | A. J. van der Westhuysen | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ 09-Aug-2017 : Update 3D export field setup ( version 6.03 ) -!/ 28-Feb-2018 : Modifications for unstruc meshes ( version 6.06 ) -!/ -! 1. Purpose : -! -! Initialize wave model (phase 3) -! * Realize fields in import and export states. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! impState Type I/O Import state -! expState Type I/O Export state -! extClock Type I External clock -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINIT Subr. WMINITMD Wave model initialization -! WMINITNML Subr. WMINITMD Wave model initialization -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - type(ESMF_State) :: impState - type(ESMF_State) :: expState - type(ESMF_Clock) :: extClock - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - integer, parameter :: iwt=3 - real(8) :: wstime, wftime - integer :: i1, i2, i3, i, n - logical :: isConnected - type(ESMF_DistGrid) :: distgrid - type(ESMF_Grid) :: grid_scalar -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - call ESMF_VMWtime(wstime) - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered InitializeP3', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! 1. Realize active import fields -! -! 1.a Create ESMF grid for import fields -! - if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then - write(msg,'(a)') trim(cname)// & + subroutine InitializeP3 ( gcomp, impState, expState, extClock, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | A. J. van der Westhuysen | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ 09-Aug-2017 : Update 3D export field setup ( version 6.03 ) + !/ 28-Feb-2018 : Modifications for unstruc meshes ( version 6.06 ) + !/ + ! 1. Purpose : + ! + ! Initialize wave model (phase 3) + ! * Realize fields in import and export states. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! impState Type I/O Import state + ! expState Type I/O Export state + ! extClock Type I External clock + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINIT Subr. WMINITMD Wave model initialization + ! WMINITNML Subr. WMINITMD Wave model initialization + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: impState + type(ESMF_State) :: expState + type(ESMF_Clock) :: extClock + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + integer, parameter :: iwt=3 + real(8) :: wstime, wftime + integer :: i1, i2, i3, i, n + logical :: isConnected + type(ESMF_DistGrid) :: distgrid + type(ESMF_Grid) :: grid_scalar + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + call ESMF_VMWtime(wstime) + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered InitializeP3', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! 1. Realize active import fields + ! + ! 1.a Create ESMF grid for import fields + ! + if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then + write(msg,'(a)') trim(cname)// & ': Creating import grid for Reg/Curvilinear Mode' - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - call CreateImpGrid( gcomp, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - elseif (GTYPE.eq.UNGTYPE) then - write(msg,'(a)') trim(cname)// & + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + call CreateImpGrid( gcomp, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + elseif (GTYPE.eq.UNGTYPE) then + write(msg,'(a)') trim(cname)// & ': Creating import mesh for Unstructured Mode' - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - call CreateImpMesh( gcomp, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! 1.b Create import fields and realize -! - n = 0 - do i = 1,numImpFields - if (.not.impFieldActive(i)) cycle - n = n + 1 - if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then - impField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, & + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + call CreateImpMesh( gcomp, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! 1.b Create import fields and realize + ! + n = 0 + do i = 1,numImpFields + if (.not.impFieldActive(i)) cycle + n = n + 1 + if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then + impField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, & totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & name=trim(impFieldName(i)), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( impField(i), zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - elseif (GTYPE.eq.UNGTYPE) then - impField(i) = ESMF_FieldCreate( impMesh, & + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( impField(i), zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + elseif (GTYPE.eq.UNGTYPE) then + impField(i) = ESMF_FieldCreate( impMesh, & typekind=ESMF_TYPEKIND_RX, name=trim(impFieldName(i)), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( impField(i), zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - call NUOPC_Realize( impState, impField(i), rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then - if (merge_import) then - mmskField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, & - totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & - staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & - name='mmsk_'//trim(impFieldName(i)), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( mmskField(i), zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - mdtField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, & - totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & - staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & - name='mdt_'//trim(impFieldName(i)), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( mdtField(i), zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if - if (.not.mbgFieldActive(i)) cycle - n = n + 1 - mbgField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, & + call FieldFill( impField(i), zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + call NUOPC_Realize( impState, impField(i), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then + if (merge_import) then + mmskField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, & + totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & + staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & + name='mmsk_'//trim(impFieldName(i)), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( mmskField(i), zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + mdtField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, & + totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & + staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & + name='mdt_'//trim(impFieldName(i)), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( mdtField(i), zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + end if + if (.not.mbgFieldActive(i)) cycle + n = n + 1 + mbgField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, & totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & name=trim(mbgFieldName(i)), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( mbgField(i), zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call NUOPC_Realize( impState, mbgField(i), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - bmskField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, & + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( mbgField(i), zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call NUOPC_Realize( impState, mbgField(i), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + bmskField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, & totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & name='bmsk_'//trim(impFieldName(i)), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - enddo -! -! 1.c Report realized import fields -! - write(msg,'(a,i0,a)') trim(cname)// & - ': List of realized import fields(',n,'):' + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + enddo + ! + ! 1.c Report realized import fields + ! + write(msg,'(a,i0,a)') trim(cname)// & + ': List of realized import fields(',n,'):' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// & + ': ','index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + n = 0 + do i = 1,numImpFields + if (.not.impFieldActive(i)) cycle + n = n + 1 + write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, & + ' ',trim(impFieldName(i)),' ',trim(impFieldStdName(i)) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// & - ': ','index',' ','name',' ','standardName' + if (.not.mbgFieldActive(i)) cycle + n = n + 1 + write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, & + ' ',trim(mbgFieldName(i)),' ',trim(mbgFieldStdName(i)) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - n = 0 - do i = 1,numImpFields - if (.not.impFieldActive(i)) cycle - n = n + 1 - write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, & - ' ',trim(impFieldName(i)),' ',trim(impFieldStdName(i)) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - if (.not.mbgFieldActive(i)) cycle - n = n + 1 - write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, & - ' ',trim(mbgFieldName(i)),' ',trim(mbgFieldStdName(i)) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - enddo -! -! -------------------------------------------------------------------- / -! 2. Realize active export fields -! -! 2.a Set connected export fields as active and remove unconnected -! If realizeAllExport, then set all fields as active and realize. -! - do i = 1,numExpFields - isConnected = NUOPC_IsConnected(expState, & - expFieldName(i), rc=rc) + enddo + ! + ! -------------------------------------------------------------------- / + ! 2. Realize active export fields + ! + ! 2.a Set connected export fields as active and remove unconnected + ! If realizeAllExport, then set all fields as active and realize. + ! + do i = 1,numExpFields + isConnected = NUOPC_IsConnected(expState, & + expFieldName(i), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + expFieldActive(i) = isConnected .or. realizeAllExport + if (expFieldActive(i)) noActiveExpFields = .false. + if (.not.expFieldActive(i)) then + call ESMF_StateRemove(expState, (/expFieldName(i)/), rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - expFieldActive(i) = isConnected .or. realizeAllExport - if (expFieldActive(i)) noActiveExpFields = .false. - if (.not.expFieldActive(i)) then - call ESMF_StateRemove(expState, (/expFieldName(i)/), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - write(msg,fmt="(a,l)") trim(cname)//': '//trim(expFieldName(i)), expFieldActive(i) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - endif - enddo -! -! 2.b Create ESMF grid for export fields -! - if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then - write(msg,'(a)') trim(cname)// & + write(msg,fmt="(a,l)") trim(cname)//': '//trim(expFieldName(i)), expFieldActive(i) + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + endif + enddo + ! + ! 2.b Create ESMF grid for export fields + ! + if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then + write(msg,'(a)') trim(cname)// & ': Creating export grid for Reg/Curvilinear Mode' - call CreateExpGrid( gcomp, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - elseif (GTYPE.eq.UNGTYPE) then - write(msg,'(a)') trim(cname)// & + call CreateExpGrid( gcomp, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + elseif (GTYPE.eq.UNGTYPE) then + write(msg,'(a)') trim(cname)// & ': Creating export mesh for Unstructured Mode' - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - call CreateExpMesh( gcomp, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! 2.c Create active export fields and realize -! - n = 0 - do i = 1,numExpFields - if (.not.expFieldActive(i)) cycle - n = n + 1 - if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then - if (trim(expFieldName(i)) == trim(flds_scalar_name)) then - distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - grid_scalar = ESMF_GridCreate(distgrid, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - expField(i) = ESMF_FieldCreate(grid_scalar, typekind=ESMF_TYPEKIND_R8, & - name=trim(expFieldName(i)), ungriddedLBound=(/1/), & - ungriddedUBound=(/flds_scalar_num/), gridToFieldMap=(/2/), rc=rc) + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + call CreateExpMesh( gcomp, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! 2.c Create active export fields and realize + ! + n = 0 + do i = 1,numExpFields + if (.not.expFieldActive(i)) cycle + n = n + 1 + if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then + if (trim(expFieldName(i)) == trim(flds_scalar_name)) then + distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + grid_scalar = ESMF_GridCreate(distgrid, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + expField(i) = ESMF_FieldCreate(grid_scalar, typekind=ESMF_TYPEKIND_R8, & + name=trim(expFieldName(i)), ungriddedLBound=(/1/), & + ungriddedUBound=(/flds_scalar_num/), gridToFieldMap=(/2/), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + else + if ( expFieldDim(i).eq.3 ) then + expField(i) = ESMF_FieldCreate( expGrid, expArraySpec3D, & + totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, & + gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), & + staggerLoc=expStaggerLoc, name=trim(expFieldName(i)), rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return else - if ( expFieldDim(i).eq.3 ) then - expField(i) = ESMF_FieldCreate( expGrid, expArraySpec3D, & - totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, & - gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), & - staggerLoc=expStaggerLoc, name=trim(expFieldName(i)), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - else - expField(i) = ESMF_FieldCreate( expGrid, expArraySpec2D, & - totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, & - staggerLoc=expStaggerLoc, name=trim(expFieldName(i)), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - call FieldFill( expField(i), zeroValue, rc=rc ) + expField(i) = ESMF_FieldCreate( expGrid, expArraySpec2D, & + totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, & + staggerLoc=expStaggerLoc, name=trim(expFieldName(i)), rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return endif - elseif (GTYPE.eq.UNGTYPE) then - expField(i) = ESMF_FieldCreate( expMesh, & - typekind=ESMF_TYPEKIND_RX, name=trim(expFieldName(i)), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return call FieldFill( expField(i), zeroValue, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return endif - call NUOPC_Realize( expState, expField(i), rc=rc ) + elseif (GTYPE.eq.UNGTYPE) then + expField(i) = ESMF_FieldCreate( expMesh, & + typekind=ESMF_TYPEKIND_RX, name=trim(expFieldName(i)), rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - enddo -! -! 2.d Report realized export fields -! - write(msg,'(a,i0,a)') trim(cname)// & - ': List of realized export fields(',n,'):' - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// & - ': ','index',' ','name',' ','standardName' + call FieldFill( expField(i), zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + call NUOPC_Realize( expState, expField(i), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo + ! + ! 2.d Report realized export fields + ! + write(msg,'(a,i0,a)') trim(cname)// & + ': List of realized export fields(',n,'):' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// & + ': ','index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + n = 0 + do i = 1,numExpFields + if (.not.expFieldActive(i)) cycle + n = n + 1 + write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, & + ' ',trim(expFieldName(i)),' ',trim(expFieldStdName(i)) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - n = 0 - do i = 1,numExpFields - if (.not.expFieldActive(i)) cycle - n = n + 1 - write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, & - ' ',trim(expFieldName(i)),' ',trim(expFieldStdName(i)) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - enddo -! -! 2.e Set W3OUTG flags needed for calculating export fields -! + enddo + ! + ! 2.e Set W3OUTG flags needed for calculating export fields + ! #ifdef USE_W3OUTG_FOR_EXPORT - call w3seto ( expGridID, mdse, mdst ) - - i1 = FieldIndex( expFieldName, 'uscurr', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = FieldIndex( expFieldName, 'vscurr', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expFieldActive(i1) .and. & - expFieldActive(i2) ) then - flogr2(6,8) = .true. !Spectrum of surface Stokes drift - if ( us3df(1) .le. 0 ) then - msg = trim(cname)//': Stokes drift export using W3OUTG'// & - ' requires setting US3D=1 (ww3_grid.inp: OUTS namelist)' - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return - endif - endif - - i1 = FieldIndex( expFieldName, 'wbcuru', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = FieldIndex( expFieldName, 'wbcurv', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i3 = FieldIndex( expFieldName, 'wbcurp', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expFieldActive(i1) .and. & - expFieldActive(i2) .and. & - expFieldActive(i3) ) then - flogr2(7,1) = .true. !Near bottom rms amplitudes - flogr2(7,2) = .true. !Near bottom rms velocities - endif - - i1 = FieldIndex( expFieldName, 'wavsuu', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = FieldIndex( expFieldName, 'wavsuv', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i3 = FieldIndex( expFieldName, 'wavsvv', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expFieldActive(i1) .and. & - expFieldActive(i2) .and. & - expFieldActive(i3) ) then - flogr2(6,1) = .true. !Radiation stresses + call w3seto ( expGridID, mdse, mdst ) + + i1 = FieldIndex( expFieldName, 'uscurr', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = FieldIndex( expFieldName, 'vscurr', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expFieldActive(i1) .and. & + expFieldActive(i2) ) then + flogr2(6,8) = .true. !Spectrum of surface Stokes drift + if ( us3df(1) .le. 0 ) then + msg = trim(cname)//': Stokes drift export using W3OUTG'// & + ' requires setting US3D=1 (ww3_grid.inp: OUTS namelist)' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return endif + endif + + i1 = FieldIndex( expFieldName, 'wbcuru', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = FieldIndex( expFieldName, 'wbcurv', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i3 = FieldIndex( expFieldName, 'wbcurp', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expFieldActive(i1) .and. & + expFieldActive(i2) .and. & + expFieldActive(i3) ) then + flogr2(7,1) = .true. !Near bottom rms amplitudes + flogr2(7,2) = .true. !Near bottom rms velocities + endif + + i1 = FieldIndex( expFieldName, 'wavsuu', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = FieldIndex( expFieldName, 'wavsuv', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i3 = FieldIndex( expFieldName, 'wavsvv', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expFieldActive(i1) .and. & + expFieldActive(i2) .and. & + expFieldActive(i3) ) then + flogr2(6,1) = .true. !Radiation stresses + endif #endif -! -! -------------------------------------------------------------------- / -! Post -! - rc = ESMF_SUCCESS - call ESMF_VMWtime(wftime) - wtime(iwt) = wtime(iwt) + wftime - wstime - wtcnt(iwt) = wtcnt(iwt) + 1 - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving InitializeP3', ESMF_LOGMSG_INFO) -!/ -!/ End of InitializeP3 ----------------------------------------------- / -!/ - end subroutine InitializeP3 -!/ ------------------------------------------------------------------- / -!> -!> @brief Finalize wave model. -!> -!> @param gcomp Gridded component. -!> @param[out] rc Return code. -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + ! + ! -------------------------------------------------------------------- / + ! Post + ! + rc = ESMF_SUCCESS + call ESMF_VMWtime(wftime) + wtime(iwt) = wtime(iwt) + wftime - wstime + wtcnt(iwt) = wtcnt(iwt) + 1 + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving InitializeP3', ESMF_LOGMSG_INFO) + !/ + !/ End of InitializeP3 ----------------------------------------------- / + !/ + end subroutine InitializeP3 + !/ ------------------------------------------------------------------- / + !> + !> @brief Finalize wave model. + !> + !> @param gcomp Gridded component. + !> @param[out] rc Return code. + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "Finalize" - subroutine Finalize ( gcomp, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ 09-Aug-2017 : Add clean up of local allocations ( version 6.03 ) -!/ -! 1. Purpose : -! -! Finalize wave model -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMFINL Subr. WMFINLMD Wave model finalization -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - integer, parameter :: iwt=6 - real(8) :: wstime, wftime - integer :: i -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - call ESMF_VMWtime(wstime) - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered Finalize', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! 1. Finalize the wave model -! - call wmfinl -! -! -------------------------------------------------------------------- / -! 2. Clean up ESMF data structures -! -! 2.a Import field and grid stuff -! - if ( .not.noActiveImpFields ) then - - do i = 1,numImpFields - if (.not.impFieldActive(i)) cycle - call ESMF_FieldDestroy(impField(i), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (merge_import) then - call ESMF_FieldDestroy(mdtField(i), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy(mmskField(i), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if - if (.not.mbgFieldActive(i)) cycle - call ESMF_FieldDestroy(mbgField(i), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy(bmskField(i), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - enddo + subroutine Finalize ( gcomp, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ 09-Aug-2017 : Add clean up of local allocations ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Finalize wave model + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMFINL Subr. WMFINLMD Wave model finalization + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + integer, parameter :: iwt=6 + real(8) :: wstime, wftime + integer :: i + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + call ESMF_VMWtime(wstime) + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered Finalize', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! 1. Finalize the wave model + ! + call wmfinl + ! + ! -------------------------------------------------------------------- / + ! 2. Clean up ESMF data structures + ! + ! 2.a Import field and grid stuff + ! + if ( .not.noActiveImpFields ) then - if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then - call ESMF_FieldHaloRelease(impHaloRH, rc=rc) + do i = 1,numImpFields + if (.not.impFieldActive(i)) cycle + call ESMF_FieldDestroy(impField(i), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (merge_import) then + call ESMF_FieldDestroy(mdtField(i), rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - - call ESMF_GridDestroy(impGrid, rc=rc) + call ESMF_FieldDestroy(mmskField(i), rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return + end if + if (.not.mbgFieldActive(i)) cycle + call ESMF_FieldDestroy(mbgField(i), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy(bmskField(i), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo - elseif (GTYPE.eq.UNGTYPE) then -!AW call ESMF_GridDestroy(impMesh, rc=rc) -!AW if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif + if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then + call ESMF_FieldHaloRelease(impHaloRH, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif + call ESMF_GridDestroy(impGrid, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - deallocate (impFieldName, & - impFieldStdName, & - impFieldInitRqrd, & - impFieldActive, & - impField, & - stat=rc) - if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return + elseif (GTYPE.eq.UNGTYPE) then + !AW call ESMF_GridDestroy(impMesh, rc=rc) + !AW if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif - deallocate (mbgFieldName, & - mbgFieldStdName, & - mbgFieldActive, & - mbgField, & - bmskField, & - stat=rc) + endif + + deallocate (impFieldName, & + impFieldStdName, & + impFieldInitRqrd, & + impFieldActive, & + impField, & + stat=rc) + if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return + + deallocate (mbgFieldName, & + mbgFieldStdName, & + mbgFieldActive, & + mbgField, & + bmskField, & + stat=rc) + if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return + + if (merge_import) then + deallocate(mmskCreated, & + mmskField, & + mdtField, & + stat=rc) if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return + end if + ! + ! 2.b Export field and grid stuff + ! + if ( .not.noActiveExpFields ) then - if (merge_import) then - deallocate(mmskCreated, & - mmskField, & - mdtField, & - stat=rc) - if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return - end if -! -! 2.b Export field and grid stuff -! - if ( .not.noActiveExpFields ) then - - do i = 1,numExpFields - if (.not.expFieldActive(i)) cycle - call ESMF_FieldDestroy(expField(i), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - enddo - - if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then - call ESMF_FieldHaloRelease(expHaloRH, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + do i = 1,numExpFields + if (.not.expFieldActive(i)) cycle + call ESMF_FieldDestroy(expField(i), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo - call ESMF_GridDestroy(expGrid, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then + call ESMF_FieldHaloRelease(expHaloRH, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - elseif (GTYPE.eq.UNGTYPE) then -!AW call ESMF_GridDestroy(expMesh, rc=rc) -!AW if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif + call ESMF_GridDestroy(expGrid, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + elseif (GTYPE.eq.UNGTYPE) then + !AW call ESMF_GridDestroy(expMesh, rc=rc) + !AW if (ESMF_LogFoundError(rc, PASSTHRU)) return endif - deallocate (expFieldName, & - expFieldStdName, & - expFieldDim, & - expFieldActive, & - expField, & - stat=rc) - if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return -! -! 2.c Native field and grid stuff -! - if ( .not.noActiveExpFields ) then + endif - call ESMF_FieldRedistRelease(n2eRH, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + deallocate (expFieldName, & + expFieldStdName, & + expFieldDim, & + expFieldActive, & + expField, & + stat=rc) + if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return + ! + ! 2.c Native field and grid stuff + ! + if ( .not.noActiveExpFields ) then - call ESMF_GridDestroy(natGrid, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedistRelease(n2eRH, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! 3. Clean up locally allocated data structures -! - if (allocated(zl)) then - deallocate (zl, stat=rc) - if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! Post -! - call ESMF_VMWtime(wftime) - wtime(iwt) = wtime(iwt) + wftime - wstime - wtcnt(iwt) = wtcnt(iwt) + 1 - call PrintTimers(trim(cname), wtnam, wtcnt, wtime) - rc = ESMF_SUCCESS - if ( improc .eq. nmpscr ) write (*,999) - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving Finalize', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! Formats -! - 999 format(//' End of program '/ & - ' ========================================'/ & - ' WAVEWATCH III Multi-grid shell '/) -!/ -!/ End of Finalize --------------------------------------------------- / -!/ - end subroutine Finalize -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize wave model export data -!> -!> @param gcomp Gridded component. -!> @param[out] rc Return code. -!> -!> @author T. J. Campbell @date 20-Jan-2017 -!> + call ESMF_GridDestroy(natGrid, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + endif + ! + ! -------------------------------------------------------------------- / + ! 3. Clean up locally allocated data structures + ! + if (allocated(zl)) then + deallocate (zl, stat=rc) + if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! Post + ! + call ESMF_VMWtime(wftime) + wtime(iwt) = wtime(iwt) + wftime - wstime + wtcnt(iwt) = wtcnt(iwt) + 1 + call PrintTimers(trim(cname), wtnam, wtcnt, wtime) + rc = ESMF_SUCCESS + if ( improc .eq. nmpscr ) write (*,999) + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving Finalize', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! Formats + ! +999 format(//' End of program '/ & + ' ========================================'/ & + ' WAVEWATCH III Multi-grid shell '/) + !/ + !/ End of Finalize --------------------------------------------------- / + !/ + end subroutine Finalize + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize wave model export data + !> + !> @param gcomp Gridded component. + !> @param[out] rc Return code. + !> + !> @author T. J. Campbell @date 20-Jan-2017 + !> #undef METHOD #define METHOD "DataInitialize" - subroutine DataInitialize ( gcomp, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Initialize wave model export data -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! GetImport Subr. WMESMFMD Wave model get import fields -! SetExport Subr. WMESMFMD Wave model set export fields -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - integer, parameter :: iwt=4 - real(8) :: wstime, wftime - type(ESMF_Clock) :: clock - type(ESMF_Time) :: currTime - logical :: fldUpdated, allUpdated - integer :: i, imod - logical :: local -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - call ESMF_VMWtime(wstime) - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered DataInitialize', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! 1. Check that required import fields show correct time stamp -! - if (med_present) then + subroutine DataInitialize ( gcomp, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Initialize wave model export data + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! GetImport Subr. WMESMFMD Wave model get import fields + ! SetExport Subr. WMESMFMD Wave model set export fields + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + integer, parameter :: iwt=4 + real(8) :: wstime, wftime + type(ESMF_Clock) :: clock + type(ESMF_Time) :: currTime + logical :: fldUpdated, allUpdated + integer :: i, imod + logical :: local + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + call ESMF_VMWtime(wstime) + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered DataInitialize', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! 1. Check that required import fields show correct time stamp + ! + if (med_present) then allUpdated = .true. - else + else call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return call ESMF_ClockGet(clock, currTime=currTime, rc=rc) @@ -2083,18 +2083,18 @@ subroutine DataInitialize ( gcomp, rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return if (fldUpdated) then write(msg,'(a,a10,a,a13)') trim(cname)//': ', & - trim(impFieldName(i)),': inter-model data dependency: ', & - 'SATISFIED' + trim(impFieldName(i)),': inter-model data dependency: ', & + 'SATISFIED' else allUpdated = .false. write(msg,'(a,a10,a,a13)') trim(cname)//': ', & - trim(impFieldName(i)),': inter-model data dependency: ', & - 'NOT SATISFIED' + trim(impFieldName(i)),': inter-model data dependency: ', & + 'NOT SATISFIED' endif else write(msg,'(a,a10,a,a13)') trim(cname)//': ', & - trim(impFieldName(i)),': inter-model data dependency: ', & - 'NOT REQUIRED' + trim(impFieldName(i)),': inter-model data dependency: ', & + 'NOT REQUIRED' endif if (verbosity.gt.0) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) if (improc.eq.nmpscr) write(*,'(a)') trim(msg) @@ -2105,612 +2105,612 @@ subroutine DataInitialize ( gcomp, rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return if (fldUpdated) then write(msg,'(a,a10,a,a13)') trim(cname)//': ', & - trim(mbgFieldName(i)),': inter-model data dependency: ', & - 'SATISFIED' + trim(mbgFieldName(i)),': inter-model data dependency: ', & + 'SATISFIED' else allUpdated = .false. write(msg,'(a,a10,a,a13)') trim(cname)//': ', & - trim(mbgFieldName(i)),': inter-model data dependency: ', & - 'NOT SATISFIED' + trim(mbgFieldName(i)),': inter-model data dependency: ', & + 'NOT SATISFIED' endif else write(msg,'(a,a10,a,a13)') trim(cname)//': ', & - trim(mbgFieldName(i)),': inter-model data dependency: ', & - 'NOT REQUIRED' + trim(mbgFieldName(i)),': inter-model data dependency: ', & + 'NOT REQUIRED' endif if (verbosity.gt.0) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) if (improc.eq.nmpscr) write(*,'(a)') trim(msg) enddo + endif + ! + ! If not all import dependencies are satisfied, then return + ! + if (.not.allUpdated) goto 1 + ! + ! -------------------------------------------------------------------- / + ! 2. All import dependencies are satisfied, so finish initialization + ! + ! 2.a Report all import dependencies are satisfied + ! + write(msg,'(a)') trim(cname)// & + ': all inter-model data dependencies SATISFIED' + if (verbosity.gt.0) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + if (improc.eq.nmpscr) write(*,'(a)') trim(msg) + ! + ! 2.b Setup background blending mask for each import field + ! + do i = 1,numImpFields + if (.not.impFieldActive(i)) cycle + if (.not.mbgFieldActive(i)) cycle + call SetupImpBmsk(bmskField(i), impField(i), missingValue, rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo + ! + ! 2.c Get import fields + ! + call GetImport(gcomp, rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 2.d Finish initialization (compute initial state), if not restart + ! + do imod = 1,nrgrd + call w3setg ( imod, mdse, mdst ) + call w3setw ( imod, mdse, mdst ) + call w3seta ( imod, mdse, mdst ) + call w3seti ( imod, mdse, mdst ) + call w3seto ( imod, mdse, mdst ) + call wmsetm ( imod, mdse, mdst ) + local = iaproc .gt. 0 .and. iaproc .le. naproc + if ( local .and. flcold .and. fliwnd ) call w3uini( va ) + enddo + ! + ! 2.e Set export fields + ! + call SetExport(gcomp, rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 2.f Set Updated Field Attribute to "true", indicating to the + ! generic code to set the timestamp for these fields + ! + do i = 1,numExpFields + if (.not.expFieldActive(i)) cycle + call NUOPC_SetAttribute(expField(i), name="Updated", & + value="true", rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo + ! + ! 2.g Set InitializeDataComplete Attribute to "true", indicating to the + ! generic code that all inter-model data dependencies are satisfied + ! + call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", & + value="true", rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! Post + ! +1 rc = ESMF_SUCCESS + call ESMF_VMWtime(wftime) + wtime(iwt) = wtime(iwt) + wftime - wstime + wtcnt(iwt) = wtcnt(iwt) + 1 + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving DataInitialize', ESMF_LOGMSG_INFO) + !/ + !/ End of DataInitialize --------------------------------------------- / + !/ + end subroutine DataInitialize + !/ ------------------------------------------------------------------- / + !> + !> @brief Advance wave model in time. + !> + !> @param gcomp Gridded component. + !> @param[out] rc Return code. + !> + !> @author T. J. Campbell @date 20-Jan-2017 + !> +#undef METHOD +#define METHOD "ModelAdvance" + subroutine ModelAdvance ( gcomp, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Advance wave model in time + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! GetImport Subr. WMESMFMD Wave model get import fields + ! SetExport Subr. WMESMFMD Wave model set export fields + ! WMWAVE Subr. WMWAVEMD Wave model run + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + integer, parameter :: iwt=5 + real(8) :: wstime, wftime + integer :: i, stat, imod, tcur(2) + integer, allocatable :: tend(:,:) + integer(ESMF_KIND_I4) :: yy,mm,dd,h,m,s + type(ESMF_Clock) :: clock + type(ESMF_Time) :: currTime, stopTime + real :: delt + logical :: lerr + + type(ESMF_Time) :: startTime + type(ESMF_TimeInterval) :: timeStep + character(len=256) :: msgString + + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + call ESMF_VMWtime(wstime) + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered ModelAdvance', ESMF_LOGMSG_INFO) + if(profile_memory) call ESMF_VMLogMemInfo('Entering WW3 '// & + 'Model_ADVANCE: ') + + allocate (tend(2,nrgrd), stat=rc) + if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! 1. Advance model to requested end time + ! + ! 1.a Get component clock + ! + call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 1.b Report + ! + if ( improc .eq. nmpscr ) then + write(*,'(///)') + call ESMF_ClockPrint(clock, options="currTime", & + preString="-->Advancing "//TRIM(cname)//" from: ") + call ESMF_ClockPrint(clock, options="stopTime", & + preString="-----------------> to: ") + endif + + if (profile_memory) then + call ESMF_ClockPrint(clock, options="currTime", & + preString="------>Advancing WAV from: ", & + unit=msgString, rc=rc) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + + call ESMF_ClockGet(clock, startTime=startTime, & + currTime=currTime, & + timeStep=timeStep, rc=rc) + + call ESMF_TimePrint(currTime + timeStep, & + preString="--------------------------------> to: ", & + unit=msgString, rc=rc) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + endif + ! + ! 1.c Check internal current time with component current time + ! + call ESMF_ClockGet(clock, currTime=currTime, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_TimeGet(currTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + lerr=.false. + do imod = 1,nrgrd + tcur(1) = 10000*yy + 100*mm + dd + tcur(2) = 10000*h + 100*m + s + call w3setw ( imod, mdse, mdst ) + delt = dsec21 ( time, tcur ) + if ( abs(delt).gt.0 ) then + lerr=.true. + write(msg,'(a,i2,a,2(a,i8,a,i8,a))') & + 'Wave model grid ',imod,': ', & + 'Internal time (',time(1),'.',time(2),') /= ', & + 'Component time (',tcur(1),'.',tcur(2),')' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) endif -! -! If not all import dependencies are satisfied, then return -! - if (.not.allUpdated) goto 1 -! -! -------------------------------------------------------------------- / -! 2. All import dependencies are satisfied, so finish initialization -! -! 2.a Report all import dependencies are satisfied -! - write(msg,'(a)') trim(cname)// & - ': all inter-model data dependencies SATISFIED' - if (verbosity.gt.0) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - if (improc.eq.nmpscr) write(*,'(a)') trim(msg) -! -! 2.b Setup background blending mask for each import field -! - do i = 1,numImpFields - if (.not.impFieldActive(i)) cycle - if (.not.mbgFieldActive(i)) cycle - call SetupImpBmsk(bmskField(i), impField(i), missingValue, rc) + enddo + if (lerr) then + rc = ESMF_FAILURE + return + endif + ! + ! 1.d Set end time of this advance + ! + call ESMF_ClockGet(clock, stopTime=stopTime, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_TimeGet(stopTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + do imod = 1,nrgrd + tend(1,imod) = 10000*yy + 100*mm + dd + tend(2,imod) = 10000*h + 100*m + s + enddo + ! + ! 1.e Get import fields + ! + call GetImport(gcomp, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 1.f Advance model + ! + if(profile_memory) call ESMF_VMLogMemInfo("Entering WW3 Run : ") + call wmwave ( tend ) + if(profile_memory) call ESMF_VMLogMemInfo("Entering WW3 Run : ") + ! + ! 1.g Set export fields + ! + call SetExport(gcomp, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! Post + ! + deallocate (tend, stat=rc) + if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return + rc = ESMF_SUCCESS + call ESMF_VMWtime(wftime) + wtime(iwt) = wtime(iwt) + wftime - wstime + wtcnt(iwt) = wtcnt(iwt) + 1 + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving ModelAdvance', ESMF_LOGMSG_INFO) + if(profile_memory) call ESMF_VMLogMemInfo('Leaving WW3 '// & + 'Model_ADVANCE: ') + !/ + !/ End of ModelAdvance ----------------------------------------------- / + !/ + end subroutine ModelAdvance + !/ ------------------------------------------------------------------- / + !> + !> @brief Get import fields and put in internal data structures. + !> + !> @param gcomp Gridded component. + !> @param[out] rc Return code. + !> + !> @author T. J. Campbell @date 20-Jan-2017 + !> +#undef METHOD +#define METHOD "GetImport" + subroutine GetImport ( gcomp, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Get import fields and put in internal data structures + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ +#ifdef W3_MPI + USE WMMDATMD, ONLY: IMPROC +#endif + implicit none + type(ESMF_GridComp) :: gcomp + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + !AW ---TEST-TEST-TEST--------------------------- + character(500) :: msg + integer :: k + !AW ---TEST-TEST-TEST--------------------------- + integer, parameter :: iwt=7 + real(8) :: wstime, wftime + integer :: i1, i2, i3, j, imod, jmod + logical, save :: firstCall = .true. + integer :: tcur(2), tend(2) + integer(ESMF_KIND_I4) :: yy,mm,dd,h,m,s + type(ESMF_Clock) :: clock + type(ESMF_Time) :: currTime, stopTime +#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_GETIMPORT) + type(ESMF_State) :: dumpState + integer, save :: timeSlice = 1 +#endif + real(ESMF_KIND_RX), pointer :: rptr(:,:) + integer :: iy, ix + integer :: elb(2), eub(2) + character(len=3) :: fieldName + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + if ( noActiveImpFields ) return + call ESMF_VMWtime(wstime) + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered GetImport', ESMF_LOGMSG_INFO) +#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_GETIMPORT) + call NUOPC_ModelGet(gcomp, importState=dumpState, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call NUOPC_Write(dumpState, overwrite=.true., & + fileNamePrefix="field_"//trim(cname)//"_import1_", & + timeslice=timeSlice, relaxedFlag=.true., rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return +#endif + ! + ! -------------------------------------------------------------------- / + ! Set time stamps using currTime and stopTime + ! + call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_ClockGet(clock, currTime=currTime, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_TimeGet(currTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + tcur(1) = 10000*yy + 100*mm + dd + tcur(2) = 10000*h + 100*m + s + call ESMF_ClockGet(clock, stopTime=stopTime, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_TimeGet(stopTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + tend(1) = 10000*yy + 100*mm + dd + tend(2) = 10000*h + 100*m + s + ! + ! -------------------------------------------------------------------- / + ! Water levels + ! + j = 1 + i1 = FieldIndex( impFieldName, 'seahgt', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = i1 + if ( impFieldActive(i1) ) then + call w3setg ( impGridID, mdse, mdst ) + call w3seti ( impGridID, mdse, mdst ) + if (firstCall) then + tln = tcur + else + tln = tend + endif + tfn(:,j) = tln + if ( mbgFieldActive(i1) ) then + call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return - enddo -! -! 2.c Get import fields -! - call GetImport(gcomp, rc) + endif + call FieldGather( impField(i1), nx, ny, wlev, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 2.d Finish initialization (compute initial state), if not restart -! do imod = 1,nrgrd call w3setg ( imod, mdse, mdst ) call w3setw ( imod, mdse, mdst ) - call w3seta ( imod, mdse, mdst ) call w3seti ( imod, mdse, mdst ) call w3seto ( imod, mdse, mdst ) call wmsetm ( imod, mdse, mdst ) - local = iaproc .gt. 0 .and. iaproc .le. naproc - if ( local .and. flcold .and. fliwnd ) call w3uini( va ) - enddo -! -! 2.e Set export fields -! - call SetExport(gcomp, rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 2.f Set Updated Field Attribute to "true", indicating to the -! generic code to set the timestamp for these fields -! - do i = 1,numExpFields - if (.not.expFieldActive(i)) cycle - call NUOPC_SetAttribute(expField(i), name="Updated", & - value="true", rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return +#ifdef W3_MPI + if ( mpi_comm_grd .eq. mpi_comm_null ) cycle +#endif + jmod = inpmap(imod,j) + if ( jmod.lt.0 .and. jmod.ne.-999 ) then + call wmupd2( imod, j, jmod, rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif enddo -! -! 2.g Set InitializeDataComplete Attribute to "true", indicating to the -! generic code that all inter-model data dependencies are satisfied -! - call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", & - value="true", rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! Post -! -1 rc = ESMF_SUCCESS - call ESMF_VMWtime(wftime) - wtime(iwt) = wtime(iwt) + wftime - wstime - wtcnt(iwt) = wtcnt(iwt) + 1 - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving DataInitialize', ESMF_LOGMSG_INFO) -!/ -!/ End of DataInitialize --------------------------------------------- / -!/ - end subroutine DataInitialize -!/ ------------------------------------------------------------------- / -!> -!> @brief Advance wave model in time. -!> -!> @param gcomp Gridded component. -!> @param[out] rc Return code. -!> -!> @author T. J. Campbell @date 20-Jan-2017 -!> -#undef METHOD -#define METHOD "ModelAdvance" - subroutine ModelAdvance ( gcomp, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Advance wave model in time -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! GetImport Subr. WMESMFMD Wave model get import fields -! SetExport Subr. WMESMFMD Wave model set export fields -! WMWAVE Subr. WMWAVEMD Wave model run -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - integer, parameter :: iwt=5 - real(8) :: wstime, wftime - integer :: i, stat, imod, tcur(2) - integer, allocatable :: tend(:,:) - integer(ESMF_KIND_I4) :: yy,mm,dd,h,m,s - type(ESMF_Clock) :: clock - type(ESMF_Time) :: currTime, stopTime - real :: delt - logical :: lerr - - type(ESMF_Time) :: startTime - type(ESMF_TimeInterval) :: timeStep - character(len=256) :: msgString - -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - call ESMF_VMWtime(wstime) - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered ModelAdvance', ESMF_LOGMSG_INFO) - if(profile_memory) call ESMF_VMLogMemInfo('Entering WW3 '// & - 'Model_ADVANCE: ') - - allocate (tend(2,nrgrd), stat=rc) - if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! 1. Advance model to requested end time -! -! 1.a Get component clock -! - call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 1.b Report -! - if ( improc .eq. nmpscr ) then - write(*,'(///)') - call ESMF_ClockPrint(clock, options="currTime", & - preString="-->Advancing "//TRIM(cname)//" from: ") - call ESMF_ClockPrint(clock, options="stopTime", & - preString="-----------------> to: ") + endif + ! + ! -------------------------------------------------------------------- / + ! Currents + ! + j = 2 + i1 = FieldIndex( impFieldName, 'uucurr', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = FieldIndex( impFieldName, 'vvcurr', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( impFieldActive(i1) ) then + call w3setg ( impGridID, mdse, mdst ) + call w3seti ( impGridID, mdse, mdst ) + if (firstCall) then + tcn = tcur + else + tc0 = tcn + cx0 = cxn + cy0 = cyn + tcn = tend endif - - if (profile_memory) then - call ESMF_ClockPrint(clock, options="currTime", & - preString="------>Advancing WAV from: ", & - unit=msgString, rc=rc) - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) - - call ESMF_ClockGet(clock, startTime=startTime, & - currTime=currTime, & - timeStep=timeStep, rc=rc) - - call ESMF_TimePrint(currTime + timeStep, & - preString="--------------------------------> to: ", & - unit=msgString, rc=rc) - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + tfn(:,j) = tcn + if ( mbgFieldActive(i1) ) then + call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call BlendImpField( impField(i2), mbgField(i2), bmskField(i2), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return endif -! -! 1.c Check internal current time with component current time -! - call ESMF_ClockGet(clock, currTime=currTime, rc=rc) + call FieldGather( impField(i1), nx, ny, cxn, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_TimeGet(currTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) + call FieldGather( impField(i2), nx, ny, cyn, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return - lerr=.false. + if (firstCall) then + tc0 = tcn + cx0 = cxn + cy0 = cyn + endif do imod = 1,nrgrd - tcur(1) = 10000*yy + 100*mm + dd - tcur(2) = 10000*h + 100*m + s + call w3setg ( imod, mdse, mdst ) call w3setw ( imod, mdse, mdst ) - delt = dsec21 ( time, tcur ) - if ( abs(delt).gt.0 ) then - lerr=.true. - write(msg,'(a,i2,a,2(a,i8,a,i8,a))') & - 'Wave model grid ',imod,': ', & - 'Internal time (',time(1),'.',time(2),') /= ', & - 'Component time (',tcur(1),'.',tcur(2),')' - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) + call w3seti ( imod, mdse, mdst ) + call wmsetm ( imod, mdse, mdst ) +#ifdef W3_MPI + if ( mpi_comm_grd .eq. mpi_comm_null ) cycle +#endif + jmod = inpmap(imod,j) + if ( jmod.lt.0 .and. jmod.ne.-999 ) then + call wmupd2( imod, j, jmod, rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return endif enddo - if (lerr) then - rc = ESMF_FAILURE - return + endif + ! + ! -------------------------------------------------------------------- / + ! Winds + ! + j = 3 + i1 = FieldIndex( impFieldName, 'uutrue', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = FieldIndex( impFieldName, 'vvtrue', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( impFieldActive(i1) ) then + call w3setg ( impGridID, mdse, mdst ) + call w3seti ( impGridID, mdse, mdst ) + + if (firstCall) then + twn = tcur + else + tw0 = twn + wx0 = wxn + wy0 = wyn + twn = tend endif -! -! 1.d Set end time of this advance -! - call ESMF_ClockGet(clock, stopTime=stopTime, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_TimeGet(stopTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - do imod = 1,nrgrd - tend(1,imod) = 10000*yy + 100*mm + dd - tend(2,imod) = 10000*h + 100*m + s - enddo -! -! 1.e Get import fields -! - call GetImport(gcomp, rc=rc) + tfn(:,j) = twn + if ( mbgFieldActive(i1) ) then + call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call BlendImpField( impField(i2), mbgField(i2), bmskField(i2), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + if (merge_import) then + ! read wave input + fieldName = 'WND' + call ReadFromFile(fieldName, mdtField(i1), mdtField(i2), tcur, tend, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! create merge mask + if (.not. firstCall) then + call SetupImpMmsk(mmskField(i1), impField(i1), fillValue, mmskCreated(i1), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call SetupImpMmsk(mmskField(i2), impField(i2), fillValue, mmskCreated(i2), rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + end if + ! blend data, mask is all zero initially (use all data) + call BlendImpField( impField(i1), mdtField(i1), mmskField(i1), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call BlendImpField( impField(i2), mdtField(i2), mmskField(i2), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + end if + call FieldGather( impField(i1), nx, ny, wxn, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 1.f Advance model -! - if(profile_memory) call ESMF_VMLogMemInfo("Entering WW3 Run : ") - call wmwave ( tend ) - if(profile_memory) call ESMF_VMLogMemInfo("Entering WW3 Run : ") -! -! 1.g Set export fields -! - call SetExport(gcomp, rc=rc) + call FieldGather( impField(i2), nx, ny, wyn, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! Post -! - deallocate (tend, stat=rc) - if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return - rc = ESMF_SUCCESS - call ESMF_VMWtime(wftime) - wtime(iwt) = wtime(iwt) + wftime - wstime - wtcnt(iwt) = wtcnt(iwt) + 1 - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving ModelAdvance', ESMF_LOGMSG_INFO) - if(profile_memory) call ESMF_VMLogMemInfo('Leaving WW3 '// & - 'Model_ADVANCE: ') -!/ -!/ End of ModelAdvance ----------------------------------------------- / -!/ - end subroutine ModelAdvance -!/ ------------------------------------------------------------------- / -!> -!> @brief Get import fields and put in internal data structures. -!> -!> @param gcomp Gridded component. -!> @param[out] rc Return code. -!> -!> @author T. J. Campbell @date 20-Jan-2017 -!> -#undef METHOD -#define METHOD "GetImport" - subroutine GetImport ( gcomp, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Get import fields and put in internal data structures -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -#ifdef W3_MPI - USE WMMDATMD, ONLY: IMPROC -#endif - implicit none - type(ESMF_GridComp) :: gcomp - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname -!AW ---TEST-TEST-TEST--------------------------- - character(500) :: msg - integer :: k -!AW ---TEST-TEST-TEST--------------------------- - integer, parameter :: iwt=7 - real(8) :: wstime, wftime - integer :: i1, i2, i3, j, imod, jmod - logical, save :: firstCall = .true. - integer :: tcur(2), tend(2) - integer(ESMF_KIND_I4) :: yy,mm,dd,h,m,s - type(ESMF_Clock) :: clock - type(ESMF_Time) :: currTime, stopTime -#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_GETIMPORT) - type(ESMF_State) :: dumpState - integer, save :: timeSlice = 1 -#endif - real(ESMF_KIND_RX), pointer :: rptr(:,:) - integer :: iy, ix - integer :: elb(2), eub(2) - character(len=3) :: fieldName -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - if ( noActiveImpFields ) return - call ESMF_VMWtime(wstime) - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered GetImport', ESMF_LOGMSG_INFO) -#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_GETIMPORT) - call NUOPC_ModelGet(gcomp, importState=dumpState, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call NUOPC_Write(dumpState, overwrite=.true., & - fileNamePrefix="field_"//trim(cname)//"_import1_", & - timeslice=timeSlice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -#endif -! -! -------------------------------------------------------------------- / -! Set time stamps using currTime and stopTime -! - call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_ClockGet(clock, currTime=currTime, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_TimeGet(currTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - tcur(1) = 10000*yy + 100*mm + dd - tcur(2) = 10000*h + 100*m + s - call ESMF_ClockGet(clock, stopTime=stopTime, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_TimeGet(stopTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - tend(1) = 10000*yy + 100*mm + dd - tend(2) = 10000*h + 100*m + s -! -! -------------------------------------------------------------------- / -! Water levels -! - j = 1 - i1 = FieldIndex( impFieldName, 'seahgt', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = i1 - if ( impFieldActive(i1) ) then - call w3setg ( impGridID, mdse, mdst ) - call w3seti ( impGridID, mdse, mdst ) - if (firstCall) then - tln = tcur - else - tln = tend - endif - tfn(:,j) = tln - if ( mbgFieldActive(i1) ) then - call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - call FieldGather( impField(i1), nx, ny, wlev, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (firstCall) then + tw0 = twn + wx0 = wxn + wy0 = wyn +#ifdef W3_WRST + ! The WRST switch saves the values of wind in the + ! restart file and then uses the wind for the first + ! time step here. This is needed when coupling with + ! an atm model that does not have 10m wind speeds at + ! initialization. If there is no restart, wind is zero + wxn = WXNwrst !replace with values from restart + wyn = WYNwrst + wx0 = WXNwrst + wy0 = WYNwrst do imod = 1,nrgrd call w3setg ( imod, mdse, mdst ) call w3setw ( imod, mdse, mdst ) call w3seti ( imod, mdse, mdst ) - call w3seto ( imod, mdse, mdst ) call wmsetm ( imod, mdse, mdst ) #ifdef W3_MPI if ( mpi_comm_grd .eq. mpi_comm_null ) cycle #endif - jmod = inpmap(imod,j) - if ( jmod.lt.0 .and. jmod.ne.-999 ) then - call wmupd2( imod, j, jmod, rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - enddo - endif -! -! -------------------------------------------------------------------- / -! Currents -! - j = 2 - i1 = FieldIndex( impFieldName, 'uucurr', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = FieldIndex( impFieldName, 'vvcurr', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( impFieldActive(i1) ) then - call w3setg ( impGridID, mdse, mdst ) - call w3seti ( impGridID, mdse, mdst ) - if (firstCall) then - tcn = tcur - else - tc0 = tcn - cx0 = cxn - cy0 = cyn - tcn = tend - endif - tfn(:,j) = tcn - if ( mbgFieldActive(i1) ) then - call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call BlendImpField( impField(i2), mbgField(i2), bmskField(i2), rc=rc ) + INPUTS(IMOD)%TW0(:) = INPUTS(impGridID)%TW0(:) + INPUTS(IMOD)%TFN(:,3) = INPUTS(impGridID)%TFN(:,3) + wxn = WXNwrst !replace with values from restart + wyn = WYNwrst + wx0 = WXNwrst + wy0 = WYNwrst if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - call FieldGather( impField(i1), nx, ny, cxn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldGather( impField(i2), nx, ny, cyn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (firstCall) then - tc0 = tcn - cx0 = cxn - cy0 = cyn - endif - do imod = 1,nrgrd - call w3setg ( imod, mdse, mdst ) - call w3setw ( imod, mdse, mdst ) - call w3seti ( imod, mdse, mdst ) - call wmsetm ( imod, mdse, mdst ) -#ifdef W3_MPI - if ( mpi_comm_grd .eq. mpi_comm_null ) cycle -#endif - jmod = inpmap(imod,j) - if ( jmod.lt.0 .and. jmod.ne.-999 ) then - call wmupd2( imod, j, jmod, rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif enddo +#endif endif -! -! -------------------------------------------------------------------- / -! Winds -! - j = 3 - i1 = FieldIndex( impFieldName, 'uutrue', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = FieldIndex( impFieldName, 'vvtrue', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( impFieldActive(i1) ) then - call w3setg ( impGridID, mdse, mdst ) - call w3seti ( impGridID, mdse, mdst ) - if (firstCall) then - twn = tcur - else - tw0 = twn - wx0 = wxn - wy0 = wyn - twn = tend - endif - tfn(:,j) = twn - if ( mbgFieldActive(i1) ) then - call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call BlendImpField( impField(i2), mbgField(i2), bmskField(i2), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - if (merge_import) then - ! read wave input - fieldName = 'WND' - call ReadFromFile(fieldName, mdtField(i1), mdtField(i2), tcur, tend, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - ! create merge mask - if (.not. firstCall) then - call SetupImpMmsk(mmskField(i1), impField(i1), fillValue, mmskCreated(i1), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call SetupImpMmsk(mmskField(i2), impField(i2), fillValue, mmskCreated(i2), rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if - ! blend data, mask is all zero initially (use all data) - call BlendImpField( impField(i1), mdtField(i1), mmskField(i1), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call BlendImpField( impField(i2), mdtField(i2), mmskField(i2), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - end if - call FieldGather( impField(i1), nx, ny, wxn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldGather( impField(i2), nx, ny, wyn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (firstCall) then - tw0 = twn - wx0 = wxn - wy0 = wyn #ifdef W3_WRST - ! The WRST switch saves the values of wind in the - ! restart file and then uses the wind for the first - ! time step here. This is needed when coupling with - ! an atm model that does not have 10m wind speeds at - ! initialization. If there is no restart, wind is zero - wxn = WXNwrst !replace with values from restart - wyn = WYNwrst - wx0 = WXNwrst - wy0 = WYNwrst - do imod = 1,nrgrd - call w3setg ( imod, mdse, mdst ) - call w3setw ( imod, mdse, mdst ) - call w3seti ( imod, mdse, mdst ) - call wmsetm ( imod, mdse, mdst ) -#ifdef W3_MPI - if ( mpi_comm_grd .eq. mpi_comm_null ) cycle -#endif - INPUTS(IMOD)%TW0(:) = INPUTS(impGridID)%TW0(:) - INPUTS(IMOD)%TFN(:,3) = INPUTS(impGridID)%TFN(:,3) - wxn = WXNwrst !replace with values from restart - wyn = WYNwrst - wx0 = WXNwrst - wy0 = WYNwrst - if (ESMF_LogFoundError(rc, PASSTHRU)) return - enddo -#endif - endif - -#ifdef W3_WRST - if ( ((twn(1)-tw0(1))*1000000+((twn(2)-tw0(2)))) .le. 0 ) then + if ( ((twn(1)-tw0(1))*1000000+((twn(2)-tw0(2)))) .le. 0 ) then !If the time of the field is still initial time, replace !with restart field wxn = WXNwrst !replace with values from restart - wyn = WYNwrst - else !twn>tw0 + wyn = WYNwrst + else !twn>tw0 #endif do imod = 1,nrgrd call w3setg ( imod, mdse, mdst ) @@ -2727,2231 +2727,2231 @@ subroutine GetImport ( gcomp, rc ) endif enddo #ifdef W3_WRST - endif !if ( twn-tw0 .le. 0 ) + endif !if ( twn-tw0 .le. 0 ) #endif + endif + ! + ! -------------------------------------------------------------------- / + ! Sea ice concentration + ! + j = 4 + i1 = FieldIndex( impFieldName, 'seaice', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = i1 + if ( impFieldActive(i1) ) then + call w3setg ( impGridID, mdse, mdst ) + call w3seti ( impGridID, mdse, mdst ) + if (firstCall) then + tin = tcur + else + tin = tend endif -! -! -------------------------------------------------------------------- / -! Sea ice concentration -! - j = 4 - i1 = FieldIndex( impFieldName, 'seaice', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = i1 - if ( impFieldActive(i1) ) then - call w3setg ( impGridID, mdse, mdst ) - call w3seti ( impGridID, mdse, mdst ) - if (firstCall) then - tin = tcur - else - tin = tend - endif - tfn(:,j) = tin - if ( mbgFieldActive(i1) ) then - call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - call FieldGather( impField(i1), nx, ny, icei, rc=rc ) + tfn(:,j) = tin + if ( mbgFieldActive(i1) ) then + call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return - do imod = 1,nrgrd - call w3setg ( imod, mdse, mdst ) - call w3setw ( imod, mdse, mdst ) - call w3seti ( imod, mdse, mdst ) - call wmsetm ( imod, mdse, mdst ) + endif + call FieldGather( impField(i1), nx, ny, icei, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + do imod = 1,nrgrd + call w3setg ( imod, mdse, mdst ) + call w3setw ( imod, mdse, mdst ) + call w3seti ( imod, mdse, mdst ) + call wmsetm ( imod, mdse, mdst ) #ifdef W3_MPI - if ( mpi_comm_grd .eq. mpi_comm_null ) cycle + if ( mpi_comm_grd .eq. mpi_comm_null ) cycle #endif - jmod = inpmap(imod,j) - if ( jmod.lt.0 .and. jmod.ne.-999 ) then - call wmupd2( imod, j, jmod, rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - enddo - endif -! -! -------------------------------------------------------------------- / -! Post -! + jmod = inpmap(imod,j) + if ( jmod.lt.0 .and. jmod.ne.-999 ) then + call wmupd2( imod, j, jmod, rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + enddo + endif + ! + ! -------------------------------------------------------------------- / + ! Post + ! #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_GETIMPORT) - call NUOPC_Write(dumpState, overwrite=.true., & - fileNamePrefix="field_"//trim(cname)//"_import2_", & - timeslice=timeSlice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - timeSlice = timeSlice + 1 + call NUOPC_Write(dumpState, overwrite=.true., & + fileNamePrefix="field_"//trim(cname)//"_import2_", & + timeslice=timeSlice, relaxedFlag=.true., rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + timeSlice = timeSlice + 1 #endif - firstCall = .false. - rc = ESMF_SUCCESS - call ESMF_VMWtime(wftime) - wtime(iwt) = wtime(iwt) + wftime - wstime - wtcnt(iwt) = wtcnt(iwt) + 1 - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving GetImport', ESMF_LOGMSG_INFO) -!/ -!/ End of GetImport -------------------------------------------------- / -!/ - end subroutine GetImport -!/ ------------------------------------------------------------------- / -!> -!> @brief Set export fields from internal data structures. -!> -!> @param gcomp Gridded component -!> @param[out] rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + firstCall = .false. + rc = ESMF_SUCCESS + call ESMF_VMWtime(wftime) + wtime(iwt) = wtime(iwt) + wftime - wstime + wtcnt(iwt) = wtcnt(iwt) + 1 + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving GetImport', ESMF_LOGMSG_INFO) + !/ + !/ End of GetImport -------------------------------------------------- / + !/ + end subroutine GetImport + !/ ------------------------------------------------------------------- / + !> + !> @brief Set export fields from internal data structures. + !> + !> @param gcomp Gridded component + !> @param[out] rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "SetExport" - subroutine SetExport ( gcomp, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ 09-Aug-2017 : Add ocean forcing export fields ( version 6.03 ) -!/ -! 1. Purpose : -! -! Set export fields from internal data structures -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - integer, parameter :: iwt=8 - real(8) :: wstime, wftime - integer :: i1, i2, i3, i4, i5, i6 - logical :: flpart = .false., floutg = .false., floutg2 = .true. + subroutine SetExport ( gcomp, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ 09-Aug-2017 : Add ocean forcing export fields ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Set export fields from internal data structures + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + integer, parameter :: iwt=8 + real(8) :: wstime, wftime + integer :: i1, i2, i3, i4, i5, i6 + logical :: flpart = .false., floutg = .false., floutg2 = .true. #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETEXPORT) - type(ESMF_State) :: dumpState - integer, save :: timeSlice = 1 + type(ESMF_State) :: dumpState + integer, save :: timeSlice = 1 #endif - real(ESMF_KIND_R8), pointer :: farrayptr(:,:) -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - if ( noActiveExpFields ) return - call ESMF_VMWtime(wstime) - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered SetExport', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! Setup -! - call w3setg ( expGridID, mdse, mdst ) - call w3setw ( expGridID, mdse, mdst ) - call w3seta ( expGridID, mdse, mdst ) - call w3seti ( expGridID, mdse, mdst ) - call w3seto ( expGridID, mdse, mdst ) - call wmsetm ( expGridID, mdse, mdst ) + real(ESMF_KIND_R8), pointer :: farrayptr(:,:) + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + if ( noActiveExpFields ) return + call ESMF_VMWtime(wstime) + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered SetExport', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! Setup + ! + call w3setg ( expGridID, mdse, mdst ) + call w3setw ( expGridID, mdse, mdst ) + call w3seta ( expGridID, mdse, mdst ) + call w3seti ( expGridID, mdse, mdst ) + call w3seto ( expGridID, mdse, mdst ) + call wmsetm ( expGridID, mdse, mdst ) #ifdef USE_W3OUTG_FOR_EXPORT - if ( natGridIsLocal ) call w3outg( va, flpart, floutg, floutg2 ) + if ( natGridIsLocal ) call w3outg( va, flpart, floutg, floutg2 ) #endif -! -! -------------------------------------------------------------------- / -! Charnock -! - i1 = FieldIndex( expFieldName, 'charno', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expFieldActive(i1) ) then - call CalcCharnk( expField(i1), rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! Surface Roughness -! - i1 = FieldIndex( expFieldName, 'z0rlen', rc ) + ! + ! -------------------------------------------------------------------- / + ! Charnock + ! + i1 = FieldIndex( expFieldName, 'charno', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expFieldActive(i1) ) then + call CalcCharnk( expField(i1), rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! Surface Roughness + ! + i1 = FieldIndex( expFieldName, 'z0rlen', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expFieldActive(i1) ) then + call CalcRoughl( expField(i1), rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! Stokes Drift 3D + ! + i1 = FieldIndex( expFieldName, 'uscurr', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = FieldIndex( expFieldName, 'vscurr', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expFieldActive(i1) .and. & + expFieldActive(i2) ) then + call CalcStokes3D( va, expField(i1), expField(i2), rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! Partitioned Stokes Drift 3 2D fields + ! + i1 = FieldIndex( expFieldName, 'x1pstk', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = FieldIndex( expFieldName, 'y1pstk', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i3 = FieldIndex( expFieldName, 'x2pstk', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i4 = FieldIndex( expFieldName, 'y2pstk', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i5 = FieldIndex( expFieldName, 'x3pstk', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i6 = FieldIndex( expFieldName, 'y3pstk', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expFieldActive(i1) .and. & + expFieldActive(i2) .and. & + expFieldActive(i3) .and. & + expFieldActive(i4) .and. & + expFieldActive(i5) .and. & + expFieldActive(i6) ) then + call CalcPStokes( va, expField(i1), expField(i2), expField(i3), & + expField(i4), expField(i5), expField(i6), rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! Bottom Currents + ! + i1 = FieldIndex( expFieldName, 'wbcuru', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = FieldIndex( expFieldName, 'wbcurv', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i3 = FieldIndex( expFieldName, 'wbcurp', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expFieldActive(i1) .and. & + expFieldActive(i2) .and. & + expFieldActive(i3) ) then + call CalcBotcur( va, expField(i1), expField(i2), expField(i3), rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! Radiation stresses 2D + ! + i1 = FieldIndex( expFieldName, 'wavsuu', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i2 = FieldIndex( expFieldName, 'wavsuv', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + i3 = FieldIndex( expFieldName, 'wavsvv', rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expFieldActive(i1) .and. & + expFieldActive(i2) .and. & + expFieldActive(i3) ) then + call CalcRadstr2D( va, expField(i1), expField(i2), expField(i3), rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! cpl_scalars - grid sizes + ! + if (med_present) then + i1 = FieldIndex( expFieldName, trim(flds_scalar_name), rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return if ( expFieldActive(i1) ) then - call CalcRoughl( expField(i1), rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! Stokes Drift 3D -! - i1 = FieldIndex( expFieldName, 'uscurr', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = FieldIndex( expFieldName, 'vscurr', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expFieldActive(i1) .and. & - expFieldActive(i2) ) then - call CalcStokes3D( va, expField(i1), expField(i2), rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! Partitioned Stokes Drift 3 2D fields -! - i1 = FieldIndex( expFieldName, 'x1pstk', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = FieldIndex( expFieldName, 'y1pstk', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i3 = FieldIndex( expFieldName, 'x2pstk', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i4 = FieldIndex( expFieldName, 'y2pstk', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i5 = FieldIndex( expFieldName, 'x3pstk', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i6 = FieldIndex( expFieldName, 'y3pstk', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expFieldActive(i1) .and. & - expFieldActive(i2) .and. & - expFieldActive(i3) .and. & - expFieldActive(i4) .and. & - expFieldActive(i5) .and. & - expFieldActive(i6) ) then - call CalcPStokes( va, expField(i1), expField(i2), expField(i3), & - expField(i4), expField(i5), expField(i6), rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! Bottom Currents -! - i1 = FieldIndex( expFieldName, 'wbcuru', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = FieldIndex( expFieldName, 'wbcurv', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i3 = FieldIndex( expFieldName, 'wbcurp', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expFieldActive(i1) .and. & - expFieldActive(i2) .and. & - expFieldActive(i3) ) then - call CalcBotcur( va, expField(i1), expField(i2), expField(i3), rc ) + call ESMF_FieldGet(expField(i1), farrayPtr=farrayptr, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! Radiation stresses 2D -! - i1 = FieldIndex( expFieldName, 'wavsuu', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i2 = FieldIndex( expFieldName, 'wavsuv', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - i3 = FieldIndex( expFieldName, 'wavsvv', rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expFieldActive(i1) .and. & - expFieldActive(i2) .and. & - expFieldActive(i3) ) then - call CalcRadstr2D( va, expField(i1), expField(i2), expField(i3), rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! cpl_scalars - grid sizes -! - if (med_present) then - i1 = FieldIndex( expFieldName, trim(flds_scalar_name), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expFieldActive(i1) ) then - call ESMF_FieldGet(expField(i1), farrayPtr=farrayptr, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (flds_scalar_index_nx > 0 .and. flds_scalar_index_nx < flds_scalar_num) then - farrayptr(flds_scalar_index_nx,1) = dble(nx) - endif - if (flds_scalar_index_ny > 0 .and. flds_scalar_index_ny < flds_scalar_num) then - farrayptr(flds_scalar_index_ny,1) = dble(ny) - endif + if (flds_scalar_index_nx > 0 .and. flds_scalar_index_nx < flds_scalar_num) then + farrayptr(flds_scalar_index_nx,1) = dble(nx) + endif + if (flds_scalar_index_ny > 0 .and. flds_scalar_index_ny < flds_scalar_num) then + farrayptr(flds_scalar_index_ny,1) = dble(ny) endif - endif -! -! -------------------------------------------------------------------- / -! Post -! + endif + endif + ! + ! -------------------------------------------------------------------- / + ! Post + ! #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETEXPORT) - call NUOPC_ModelGet(gcomp, exportState=dumpState, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call NUOPC_Write(dumpState, overwrite=.true., & - fileNamePrefix="field_"//trim(cname)//"_export_", & - timeslice=timeSlice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - timeSlice = timeSlice + 1 + call NUOPC_ModelGet(gcomp, exportState=dumpState, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call NUOPC_Write(dumpState, overwrite=.true., & + fileNamePrefix="field_"//trim(cname)//"_export_", & + timeslice=timeSlice, relaxedFlag=.true., rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + timeSlice = timeSlice + 1 #endif - rc = ESMF_SUCCESS - call ESMF_VMWtime(wftime) - wtime(iwt) = wtime(iwt) + wftime - wstime - wtcnt(iwt) = wtcnt(iwt) + 1 - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving SetExport', ESMF_LOGMSG_INFO) -!/ -!/ End of SetExport -------------------------------------------------- / -!/ - end subroutine SetExport -!/ ------------------------------------------------------------------- / -!> -!> @brief Create ESMF grid for import fields. -!> -!> @param gcomp Gridded component -!> @param[out] rc Return code -!> -!> @author T. J. Campbell @date 20-Jan-2017 -!> + rc = ESMF_SUCCESS + call ESMF_VMWtime(wftime) + wtime(iwt) = wtime(iwt) + wftime - wstime + wtcnt(iwt) = wtcnt(iwt) + 1 + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving SetExport', ESMF_LOGMSG_INFO) + !/ + !/ End of SetExport -------------------------------------------------- / + !/ + end subroutine SetExport + !/ ------------------------------------------------------------------- / + !> + !> @brief Create ESMF grid for import fields. + !> + !> @param gcomp Gridded component + !> @param[out] rc Return code + !> + !> @author T. J. Campbell @date 20-Jan-2017 + !> #undef METHOD #define METHOD "CreateImpGrid" - subroutine CreateImpGrid ( gcomp, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Create ESMF grid for import fields -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - type(ESMF_VM) :: vm - character(ESMF_MAXSTR) :: cname - integer :: nproc, nxproc, nyproc - integer, parameter :: lde = 0 - integer :: lpet, ldecnt - integer :: ix, iy, isea, jsea, irec, ubx, uby - integer :: elb(2), eub(2), elbc(2), eubc(2) - integer :: tlb(2), tub(2) - integer(ESMF_KIND_I4), pointer :: iptr(:,:) - real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:) - real(ESMF_KIND_RX), pointer :: rptr(:,:) - real(ESMF_KIND_R8), allocatable :: xgrd_center(:) - real(ESMF_KIND_R8), allocatable :: ygrd_center(:) - real(ESMF_KIND_R8), allocatable :: xgrd_corner(:,:) - real(ESMF_KIND_R8), allocatable :: ygrd_corner(:,:) - logical, allocatable :: land_sea(:) - integer, allocatable :: grid_dims(:) - integer :: grid_size, grid_corners, grid_rank - type(ESMF_Field) :: tmpField -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - if ( noActiveImpFields ) return - call ESMF_GridCompGet(gcomp, name=cname, vm=vm, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_VMGet(vm, localPet=lpet, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered CreateImpGrid', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! 1. Setup -! -! 1.a Set grid pointers -! - impGridID = minval(inpmap) - if ( impGridID.eq.-999 ) impGridID = 1 - call w3setg ( impGridID, mdse, mdst ) - call w3seti ( impGridID, mdse, mdst ) - call w3seto ( impGridID, mdse, mdst ) - if ( impGridID.gt.0 ) then - call wmsetm ( impGridID, mdse, mdst ) - nproc = naproc - else - nproc = nmproc - endif -! -! 1.b Compute a 2D subdomain layout based on nproc -! - call CalcDecomp( nx, ny, nproc, impHaloWidth, .true., nxproc, nyproc, rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 1.c Set arraySpec, staggerLoc, and indexFlag for import fields -! - call ESMF_ArraySpecSet( impArraySpec2D, rank=2, & - typekind=ESMF_TYPEKIND_RX, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - impStaggerLoc = ESMF_STAGGERLOC_CENTER - impIndexFlag = ESMF_INDEX_GLOBAL -! -! -------------------------------------------------------------------- / -! 2. Create ESMF grid for import with 2D subdomain layout -! Note that the ESMF grid layout is dim1=X, dim2=Y -! -! 2.a Create ESMF import grid -! + subroutine CreateImpGrid ( gcomp, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Create ESMF grid for import fields + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + type(ESMF_VM) :: vm + character(ESMF_MAXSTR) :: cname + integer :: nproc, nxproc, nyproc + integer, parameter :: lde = 0 + integer :: lpet, ldecnt + integer :: ix, iy, isea, jsea, irec, ubx, uby + integer :: elb(2), eub(2), elbc(2), eubc(2) + integer :: tlb(2), tub(2) + integer(ESMF_KIND_I4), pointer :: iptr(:,:) + real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:) + real(ESMF_KIND_RX), pointer :: rptr(:,:) + real(ESMF_KIND_R8), allocatable :: xgrd_center(:) + real(ESMF_KIND_R8), allocatable :: ygrd_center(:) + real(ESMF_KIND_R8), allocatable :: xgrd_corner(:,:) + real(ESMF_KIND_R8), allocatable :: ygrd_corner(:,:) + logical, allocatable :: land_sea(:) + integer, allocatable :: grid_dims(:) + integer :: grid_size, grid_corners, grid_rank + type(ESMF_Field) :: tmpField + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + if ( noActiveImpFields ) return + call ESMF_GridCompGet(gcomp, name=cname, vm=vm, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_VMGet(vm, localPet=lpet, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered CreateImpGrid', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! 1. Setup + ! + ! 1.a Set grid pointers + ! + impGridID = minval(inpmap) + if ( impGridID.eq.-999 ) impGridID = 1 + call w3setg ( impGridID, mdse, mdst ) + call w3seti ( impGridID, mdse, mdst ) + call w3seto ( impGridID, mdse, mdst ) + if ( impGridID.gt.0 ) then + call wmsetm ( impGridID, mdse, mdst ) + nproc = naproc + else + nproc = nmproc + endif + ! + ! 1.b Compute a 2D subdomain layout based on nproc + ! + call CalcDecomp( nx, ny, nproc, impHaloWidth, .true., nxproc, nyproc, rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 1.c Set arraySpec, staggerLoc, and indexFlag for import fields + ! + call ESMF_ArraySpecSet( impArraySpec2D, rank=2, & + typekind=ESMF_TYPEKIND_RX, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + impStaggerLoc = ESMF_STAGGERLOC_CENTER + impIndexFlag = ESMF_INDEX_GLOBAL + ! + ! -------------------------------------------------------------------- / + ! 2. Create ESMF grid for import with 2D subdomain layout + ! Note that the ESMF grid layout is dim1=X, dim2=Y + ! + ! 2.a Create ESMF import grid + ! + select case (iclose) + case (iclose_none) + impGrid = ESMF_GridCreateNoPeriDim( & + minIndex=(/ 1, 1/), & + maxIndex=(/nx,ny/), & + coordDep1=(/1,2/), & + coordDep2=(/1,2/), & + regDecomp=(/nxproc,nyproc/), & + decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), & + coordTypeKind=ESMF_TYPEKIND_RX, & + coordSys=ESMF_COORDSYS_SPH_DEG, & + indexFlag=impIndexFlag, & + name=trim(cname)//"_import_grid", rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + case (iclose_smpl) + impGrid = ESMF_GridCreate1PeriDim( & + periodicDim=1, & + poleDim=2, & + poleKindFlag=(/ESMF_POLEKIND_NONE,ESMF_POLEKIND_NONE/), & + minIndex=(/ 1, 1/), & + maxIndex=(/nx,ny/), & + coordDep1=(/1,2/), & + coordDep2=(/1,2/), & + regDecomp=(/nxproc,nyproc/), & + decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), & + coordTypeKind=ESMF_TYPEKIND_RX, & + coordSys=ESMF_COORDSYS_SPH_DEG, & + indexFlag=impIndexFlag, & + name=trim(cname)//"_import_grid", rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + case default + write(msg,'(a,i1,a)') 'Index closure ',iclose, & + ' not supported for import grid' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endselect + ! + ! 2.b Add coordinate arrays and land/sea mask to import grid + ! + call ESMF_GridAddCoord( impGrid, staggerLoc=impStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_GridAddItem( impGrid, ESMF_GRIDITEM_MASK, & + staggerLoc=impStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 2.c Set flag to indicate that this processor has local import grid storage + ! + call ESMF_GridGet( impGrid, localDECount=ldecnt, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + impGridIsLocal = ldecnt.gt.0 + ! + ! 2.d Get exclusive bounds (global index) for import grid + ! + if ( impGridIsLocal ) then + call ESMF_GridGet( impGrid, impStaggerLoc, lde, & + exclusiveLBound=elb, exclusiveUBound=eub, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! 2.e Set halo widths for import fields + ! + if ( impGridIsLocal ) then + impHaloLWidth = (/impHaloWidth,impHaloWidth/) + impHaloUWidth = (/impHaloWidth,impHaloWidth/) select case (iclose) - case (iclose_none) - impGrid = ESMF_GridCreateNoPeriDim( & - minIndex=(/ 1, 1/), & - maxIndex=(/nx,ny/), & - coordDep1=(/1,2/), & - coordDep2=(/1,2/), & - regDecomp=(/nxproc,nyproc/), & - decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), & - coordTypeKind=ESMF_TYPEKIND_RX, & - coordSys=ESMF_COORDSYS_SPH_DEG, & - indexFlag=impIndexFlag, & - name=trim(cname)//"_import_grid", rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - case (iclose_smpl) - impGrid = ESMF_GridCreate1PeriDim( & - periodicDim=1, & - poleDim=2, & - poleKindFlag=(/ESMF_POLEKIND_NONE,ESMF_POLEKIND_NONE/), & - minIndex=(/ 1, 1/), & - maxIndex=(/nx,ny/), & - coordDep1=(/1,2/), & - coordDep2=(/1,2/), & - regDecomp=(/nxproc,nyproc/), & - decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), & - coordTypeKind=ESMF_TYPEKIND_RX, & - coordSys=ESMF_COORDSYS_SPH_DEG, & - indexFlag=impIndexFlag, & - name=trim(cname)//"_import_grid", rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - case default - write(msg,'(a,i1,a)') 'Index closure ',iclose, & - ' not supported for import grid' - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return + case (iclose_none) + if ( elb(1).eq.1 ) impHaloLWidth(1) = 0 + if ( elb(2).eq.1 ) impHaloLWidth(2) = 0 + if ( eub(1).eq.nx ) impHaloUWidth(1) = 0 + if ( eub(2).eq.ny ) impHaloUWidth(2) = 0 + case (iclose_smpl) + if ( elb(2).eq.1 ) impHaloLWidth(2) = 0 + if ( eub(2).eq.ny ) impHaloUWidth(2) = 0 endselect -! -! 2.b Add coordinate arrays and land/sea mask to import grid -! - call ESMF_GridAddCoord( impGrid, staggerLoc=impStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_GridAddItem( impGrid, ESMF_GRIDITEM_MASK, & - staggerLoc=impStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 2.c Set flag to indicate that this processor has local import grid storage -! - call ESMF_GridGet( impGrid, localDECount=ldecnt, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - impGridIsLocal = ldecnt.gt.0 -! -! 2.d Get exclusive bounds (global index) for import grid -! - if ( impGridIsLocal ) then - call ESMF_GridGet( impGrid, impStaggerLoc, lde, & - exclusiveLBound=elb, exclusiveUBound=eub, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! 2.e Set halo widths for import fields -! - if ( impGridIsLocal ) then - impHaloLWidth = (/impHaloWidth,impHaloWidth/) - impHaloUWidth = (/impHaloWidth,impHaloWidth/) - select case (iclose) - case (iclose_none) - if ( elb(1).eq.1 ) impHaloLWidth(1) = 0 - if ( elb(2).eq.1 ) impHaloLWidth(2) = 0 - if ( eub(1).eq.nx ) impHaloUWidth(1) = 0 - if ( eub(2).eq.ny ) impHaloUWidth(2) = 0 - case (iclose_smpl) - if ( elb(2).eq.1 ) impHaloLWidth(2) = 0 - if ( eub(2).eq.ny ) impHaloUWidth(2) = 0 - endselect - else - impHaloLWidth = (/0,0/) - impHaloUWidth = (/0,0/) - endif -! -! 2.f Set ESMF import grid coordinates -! - if ( impGridIsLocal ) then - call ESMF_GridGetCoord( impGrid, 1, localDE=lde, & - staggerLoc=impStaggerLoc, farrayPtr=rptrx, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_GridGetCoord( impGrid, 2, localDE=lde, & - staggerLoc=impStaggerLoc, farrayPtr=rptry, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptrx(ix,iy) = xgrd(iy,ix) - rptry(ix,iy) = ygrd(iy,ix) - enddo + else + impHaloLWidth = (/0,0/) + impHaloUWidth = (/0,0/) + endif + ! + ! 2.f Set ESMF import grid coordinates + ! + if ( impGridIsLocal ) then + call ESMF_GridGetCoord( impGrid, 1, localDE=lde, & + staggerLoc=impStaggerLoc, farrayPtr=rptrx, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_GridGetCoord( impGrid, 2, localDE=lde, & + staggerLoc=impStaggerLoc, farrayPtr=rptry, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptrx(ix,iy) = xgrd(iy,ix) + rptry(ix,iy) = ygrd(iy,ix) enddo - nullify(rptrx) - nullify(rptry) - endif -! -! 2.g Set ESMF import grid land/sea mask values. -! Land/sea mask is fixed in time and based on excluded points only. -! - if ( impGridIsLocal ) then - call ESMF_GridGetItem( impGrid, ESMF_GRIDITEM_MASK, localDE=lde, & - staggerLoc=impStaggerLoc, farrayPtr=iptr, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - if ( mapsta(iy,ix).ne.0 ) then - iptr(ix,iy) = maskValueWater - else - iptr(ix,iy) = maskValueLand - endif - enddo + enddo + nullify(rptrx) + nullify(rptry) + endif + ! + ! 2.g Set ESMF import grid land/sea mask values. + ! Land/sea mask is fixed in time and based on excluded points only. + ! + if ( impGridIsLocal ) then + call ESMF_GridGetItem( impGrid, ESMF_GRIDITEM_MASK, localDE=lde, & + staggerLoc=impStaggerLoc, farrayPtr=iptr, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + if ( mapsta(iy,ix).ne.0 ) then + iptr(ix,iy) = maskValueWater + else + iptr(ix,iy) = maskValueLand + endif enddo - endif -! -! 2.h Set ESMF import grid corner coordinates -! + enddo + endif + ! + ! 2.h Set ESMF import grid corner coordinates + ! #ifdef W3_SCRIP - call ESMF_GridAddCoord( impGrid, & - staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - ! Calculate grid coordinates with help of SCRIP module - ! It does not return coordinates of top-most row and - ! right-most column but ESMF expects it. So, top-most row - ! and right-most column are theated specially in below - call get_scrip_info_structured(impGridID, & - xgrd_center, ygrd_center, xgrd_corner, ygrd_corner, & - land_sea, grid_dims, grid_size, grid_corners, grid_rank) - - ! Add corner coordinates - if ( impGridIsLocal ) then - ! Retrieve pointers - call ESMF_GridGetCoord( impGrid, 1, localDE=lde, & - staggerLoc=ESMF_STAGGERLOC_CORNER, farrayPtr=rptrx, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_GridGetCoord( impGrid, 2, localDE=lde, & - staggerLoc=ESMF_STAGGERLOC_CORNER, farrayPtr=rptry, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - ! Get exclusive bounds (global index) for import grid - ! corner coordinates - call ESMF_GridGet( impGrid, ESMF_STAGGERLOC_CORNER, lde, & - exclusiveLBound=elbc, exclusiveUBound=eubc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - ! Adjust upper bounds for specific PEs - ubx = 0 - uby = 0 - if (eubc(1) == grid_dims(1)+1) ubx = -1 - if (eubc(2) == grid_dims(2)+1) uby = -1 - - ! Fill coordinates - do iy = elbc(2),eubc(2)+uby - do ix = elbc(1),eubc(1)+ubx - irec = (iy-1)*grid_dims(1)+ix - rptrx(ix,iy) = real(xgrd_corner(1,irec), kind=ESMF_KIND_RX) - rptry(ix,iy) = real(ygrd_corner(1,irec), kind=ESMF_KIND_RX) - enddo + call ESMF_GridAddCoord( impGrid, & + staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + ! Calculate grid coordinates with help of SCRIP module + ! It does not return coordinates of top-most row and + ! right-most column but ESMF expects it. So, top-most row + ! and right-most column are theated specially in below + call get_scrip_info_structured(impGridID, & + xgrd_center, ygrd_center, xgrd_corner, ygrd_corner, & + land_sea, grid_dims, grid_size, grid_corners, grid_rank) + + ! Add corner coordinates + if ( impGridIsLocal ) then + ! Retrieve pointers + call ESMF_GridGetCoord( impGrid, 1, localDE=lde, & + staggerLoc=ESMF_STAGGERLOC_CORNER, farrayPtr=rptrx, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_GridGetCoord( impGrid, 2, localDE=lde, & + staggerLoc=ESMF_STAGGERLOC_CORNER, farrayPtr=rptry, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + ! Get exclusive bounds (global index) for import grid + ! corner coordinates + call ESMF_GridGet( impGrid, ESMF_STAGGERLOC_CORNER, lde, & + exclusiveLBound=elbc, exclusiveUBound=eubc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + ! Adjust upper bounds for specific PEs + ubx = 0 + uby = 0 + if (eubc(1) == grid_dims(1)+1) ubx = -1 + if (eubc(2) == grid_dims(2)+1) uby = -1 + + ! Fill coordinates + do iy = elbc(2),eubc(2)+uby + do ix = elbc(1),eubc(1)+ubx + irec = (iy-1)*grid_dims(1)+ix + rptrx(ix,iy) = real(xgrd_corner(1,irec), kind=ESMF_KIND_RX) + rptry(ix,iy) = real(ygrd_corner(1,irec), kind=ESMF_KIND_RX) enddo + enddo - ! Fill data on top-most row - if (eubc(2) == grid_dims(2)+1) then - do ix = elbc(1),eubc(1)+ubx - rptrx(ix,grid_dims(2)+1) = rptrx(ix,grid_dims(2))+ & - (rptrx(ix,grid_dims(2))-rptrx(ix,grid_dims(2)-1)) - rptry(ix,grid_dims(2)+1) = rptry(ix,grid_dims(2))+ & - (rptry(ix,grid_dims(2))-rptry(ix,grid_dims(2)-1)) - end do - end if + ! Fill data on top-most row + if (eubc(2) == grid_dims(2)+1) then + do ix = elbc(1),eubc(1)+ubx + rptrx(ix,grid_dims(2)+1) = rptrx(ix,grid_dims(2))+ & + (rptrx(ix,grid_dims(2))-rptrx(ix,grid_dims(2)-1)) + rptry(ix,grid_dims(2)+1) = rptry(ix,grid_dims(2))+ & + (rptry(ix,grid_dims(2))-rptry(ix,grid_dims(2)-1)) + end do + end if - ! Fill data on right-most column - if (eubc(1) == grid_dims(1)+1) then - do iy = elbc(2),eubc(2)+uby - rptrx(grid_dims(1)+1,iy) = rptrx(grid_dims(1),iy)+ & - (rptrx(grid_dims(1),iy)-rptrx(grid_dims(1)-1,iy)) - rptry(grid_dims(1)+1,iy) = rptry(grid_dims(1),iy)+ & - (rptry(grid_dims(1),iy)-rptry(grid_dims(1)-1,iy)) - end do - end if + ! Fill data on right-most column + if (eubc(1) == grid_dims(1)+1) then + do iy = elbc(2),eubc(2)+uby + rptrx(grid_dims(1)+1,iy) = rptrx(grid_dims(1),iy)+ & + (rptrx(grid_dims(1),iy)-rptrx(grid_dims(1)-1,iy)) + rptry(grid_dims(1)+1,iy) = rptry(grid_dims(1),iy)+ & + (rptry(grid_dims(1),iy)-rptry(grid_dims(1)-1,iy)) + end do + end if - ! Fill data on top-right corner, single point - if (eubc(1) == grid_dims(1)+1 .and. eubc(2) == grid_dims(2)+1) then - rptrx(grid_dims(1)+1,grid_dims(2)+1) = & - rptrx(grid_dims(1)+1,grid_dims(2)) - rptry(grid_dims(1)+1,grid_dims(2)+1) = & - rptry(grid_dims(1),grid_dims(2)+1) - end if - endif -#endif -! -! -------------------------------------------------------------------- / -! 3. Create import field mask and routeHandle halo update -! -! 3.a Create field for import grid land/sea mask. -! - impMask = ESMF_FieldCreate( impGrid, impArraySpec2D, & - totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & - staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & - name='mask', rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 3.b Store import field halo routeHandle -! - call ESMF_FieldHaloStore( impMask, routeHandle=impHaloRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 3.c Set import field land/sea mask values and update halos -! - if ( impGridIsLocal ) then - call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=rptr, & - totalLBound=tlb, totalUBound=tub, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = iptr(ix,iy) - enddo + ! Fill data on top-right corner, single point + if (eubc(1) == grid_dims(1)+1 .and. eubc(2) == grid_dims(2)+1) then + rptrx(grid_dims(1)+1,grid_dims(2)+1) = & + rptrx(grid_dims(1)+1,grid_dims(2)) + rptry(grid_dims(1)+1,grid_dims(2)+1) = & + rptry(grid_dims(1),grid_dims(2)+1) + end if + endif +#endif + ! + ! -------------------------------------------------------------------- / + ! 3. Create import field mask and routeHandle halo update + ! + ! 3.a Create field for import grid land/sea mask. + ! + impMask = ESMF_FieldCreate( impGrid, impArraySpec2D, & + totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & + staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & + name='mask', rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 3.b Store import field halo routeHandle + ! + call ESMF_FieldHaloStore( impMask, routeHandle=impHaloRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 3.c Set import field land/sea mask values and update halos + ! + if ( impGridIsLocal ) then + call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=rptr, & + totalLBound=tlb, totalUBound=tub, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = iptr(ix,iy) enddo - endif - - call ESMF_FieldHalo( impMask, impHaloRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! Post -! + enddo + endif + + call ESMF_FieldHalo( impMask, impHaloRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! Post + ! #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_CREATEIMPGRID) - write(msg,'(a,i6)') ' impGridID: ',impGridID - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,l6)') 'impGridIsLocal: ',impGridIsLocal - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' nx, ny: ',nx,ny - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') 'naproc, nmproc: ',naproc,nmproc - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,i6)') ' nproc: ',nproc - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') 'nxproc, nyproc: ',nxproc,nyproc - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' elb: ',elb(:) - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' eub: ',eub(:) - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' tlb: ',tlb(:) - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' tub: ',tub(:) - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' impHaloLWidth: ',impHaloLWidth(:) - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' impHaloUWidth: ',impHaloUWidth(:) - call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - call ESMF_FieldWrite( impMask, & - "wmesmfmd_createimpgrid_import_mask.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - tmpField = ESMF_FieldCreate( impGrid, impArraySpec2D, & - totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & - staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & - name='temp', rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( impGridIsLocal ) then - call ESMF_FieldGet( tmpField, localDE=lde, farrayPtr=rptr, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - if ( impGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = xgrd(iy,ix) - enddo + write(msg,'(a,i6)') ' impGridID: ',impGridID + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,l6)') 'impGridIsLocal: ',impGridIsLocal + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' nx, ny: ',nx,ny + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') 'naproc, nmproc: ',naproc,nmproc + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,i6)') ' nproc: ',nproc + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') 'nxproc, nyproc: ',nxproc,nyproc + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' elb: ',elb(:) + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' eub: ',eub(:) + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' tlb: ',tlb(:) + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' tub: ',tub(:) + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' impHaloLWidth: ',impHaloLWidth(:) + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' impHaloUWidth: ',impHaloUWidth(:) + call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + call ESMF_FieldWrite( impMask, & + "wmesmfmd_createimpgrid_import_mask.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + tmpField = ESMF_FieldCreate( impGrid, impArraySpec2D, & + totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & + staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, & + name='temp', rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( impGridIsLocal ) then + call ESMF_FieldGet( tmpField, localDE=lde, farrayPtr=rptr, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + if ( impGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = xgrd(iy,ix) enddo - endif - call ESMF_FieldWrite( tmpField, & - "wmesmfmd_createimpgrid_import_xgrd.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( impGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = ygrd(iy,ix) - enddo + enddo + endif + call ESMF_FieldWrite( tmpField, & + "wmesmfmd_createimpgrid_import_xgrd.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( impGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = ygrd(iy,ix) enddo - endif - call ESMF_FieldWrite( tmpField, & - "wmesmfmd_createimpgrid_import_ygrd.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( impGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = hpfac(iy,ix) - enddo + enddo + endif + call ESMF_FieldWrite( tmpField, & + "wmesmfmd_createimpgrid_import_ygrd.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( impGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = hpfac(iy,ix) enddo - endif - call ESMF_FieldWrite( tmpField, & - "wmesmfmd_createimpgrid_import_hpfac.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( impGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = hqfac(iy,ix) - enddo + enddo + endif + call ESMF_FieldWrite( tmpField, & + "wmesmfmd_createimpgrid_import_hpfac.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( impGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = hqfac(iy,ix) enddo - endif - call ESMF_FieldWrite( tmpField, & - "wmesmfmd_createimpgrid_import_hqfac.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( impGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = lpet - enddo + enddo + endif + call ESMF_FieldWrite( tmpField, & + "wmesmfmd_createimpgrid_import_hqfac.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( impGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = lpet enddo - endif - call ESMF_FieldWrite( tmpField, & - "wmesmfmd_createimpgrid_import_dcomp.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( tmpField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo + endif + call ESMF_FieldWrite( tmpField, & + "wmesmfmd_createimpgrid_import_dcomp.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( tmpField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #endif -! - rc = ESMF_SUCCESS - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving CreateImpGrid', ESMF_LOGMSG_INFO) -!/ -!/ End of CreateImpGrid ---------------------------------------------- / -!/ - end subroutine CreateImpGrid -!/ ------------------------------------------------------------------- / -!> -!> @brief Create ESMF grid for export fields -!> -!> @param gcomp Gridded component -!> @param[out] rc Return code -!> -!> @author T. J. Campbell @date 20-Jan-2017 -!> + ! + rc = ESMF_SUCCESS + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving CreateImpGrid', ESMF_LOGMSG_INFO) + !/ + !/ End of CreateImpGrid ---------------------------------------------- / + !/ + end subroutine CreateImpGrid + !/ ------------------------------------------------------------------- / + !> + !> @brief Create ESMF grid for export fields + !> + !> @param gcomp Gridded component + !> @param[out] rc Return code + !> + !> @author T. J. Campbell @date 20-Jan-2017 + !> #undef METHOD #define METHOD "CreateExpGrid" - subroutine CreateExpGrid ( gcomp, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ -! 1. Purpose : -! -! -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - integer :: nproc, nxproc, nyproc - integer, parameter :: lde = 0 - integer :: ldecnt - integer :: ix, iy, isea, jsea, irec, k, ubx, uby - integer :: elb(2), eub(2), elbc(2), eubc(2) - integer :: tlb(2), tub(2) - integer(ESMF_KIND_I4), pointer :: iptr(:,:) - real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:) - real(ESMF_KIND_RX), pointer :: rptr(:,:) - real(ESMF_KIND_R8), allocatable :: xgrd_center(:) - real(ESMF_KIND_R8), allocatable :: ygrd_center(:) - real(ESMF_KIND_R8), allocatable :: xgrd_corner(:,:) - real(ESMF_KIND_R8), allocatable :: ygrd_corner(:,:) - logical, allocatable :: land_sea(:) - integer, allocatable :: grid_dims(:) - integer :: grid_size, grid_corners, grid_rank - integer :: arbIndexCount - integer, allocatable :: arbIndexList(:,:) - type(ESMF_Field) :: nField, eField - type(ESMF_Field) :: tmpField -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - if ( noActiveExpFields ) return - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered CreateExpGrid', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! 1. Setup -! -! 1.a Set grid pointers -! - !TODO: only export from one grid - !expGridID set from config input (default = 1) - call w3setg ( expGridID, mdse, mdst ) - call w3setw ( expGridID, mdse, mdst ) - call w3seta ( expGridID, mdse, mdst ) - call w3seti ( expGridID, mdse, mdst ) - call w3seto ( expGridID, mdse, mdst ) - call wmsetm ( expGridID, mdse, mdst ) - natGridID = expGridID - nproc = naproc -! -! 1.b Compute a 2D subdomain layout based on nproc -! - call CalcDecomp( nx, ny, nproc, expHaloWidth, .true., nxproc, nyproc, rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 1.c Set arraySpec, staggerLoc, and indexFlag for export fields -! - call ESMF_ArraySpecSet( expArraySpec2D, rank=2, & - typekind=ESMF_TYPEKIND_RX, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_ArraySpecSet( expArraySpec3D, rank=3, & - typekind=ESMF_TYPEKIND_RX, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - expStaggerLoc = ESMF_STAGGERLOC_CENTER - expIndexFlag = ESMF_INDEX_GLOBAL -! -! 1.d Set arraySpec, staggerLoc, and indexFlag for native fields -! - call ESMF_ArraySpecSet( natArraySpec2D, rank=1, & - typekind=ESMF_TYPEKIND_RX, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_ArraySpecSet( natArraySpec3D, rank=2, & - typekind=ESMF_TYPEKIND_RX, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - natStaggerLoc = ESMF_STAGGERLOC_CENTER - natIndexFlag = ESMF_INDEX_DELOCAL -! -! 1.e Get z-levels for 3D export fields -! - call GetZlevels( rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - write(msg,'(a)') 'input z-level file: '//trim(zlfile) - call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a)') 'table of z-levels' + subroutine CreateExpGrid ( gcomp, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + integer :: nproc, nxproc, nyproc + integer, parameter :: lde = 0 + integer :: ldecnt + integer :: ix, iy, isea, jsea, irec, k, ubx, uby + integer :: elb(2), eub(2), elbc(2), eubc(2) + integer :: tlb(2), tub(2) + integer(ESMF_KIND_I4), pointer :: iptr(:,:) + real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:) + real(ESMF_KIND_RX), pointer :: rptr(:,:) + real(ESMF_KIND_R8), allocatable :: xgrd_center(:) + real(ESMF_KIND_R8), allocatable :: ygrd_center(:) + real(ESMF_KIND_R8), allocatable :: xgrd_corner(:,:) + real(ESMF_KIND_R8), allocatable :: ygrd_corner(:,:) + logical, allocatable :: land_sea(:) + integer, allocatable :: grid_dims(:) + integer :: grid_size, grid_corners, grid_rank + integer :: arbIndexCount + integer, allocatable :: arbIndexList(:,:) + type(ESMF_Field) :: nField, eField + type(ESMF_Field) :: tmpField + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + if ( noActiveExpFields ) return + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered CreateExpGrid', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! 1. Setup + ! + ! 1.a Set grid pointers + ! + !TODO: only export from one grid + !expGridID set from config input (default = 1) + call w3setg ( expGridID, mdse, mdst ) + call w3setw ( expGridID, mdse, mdst ) + call w3seta ( expGridID, mdse, mdst ) + call w3seti ( expGridID, mdse, mdst ) + call w3seto ( expGridID, mdse, mdst ) + call wmsetm ( expGridID, mdse, mdst ) + natGridID = expGridID + nproc = naproc + ! + ! 1.b Compute a 2D subdomain layout based on nproc + ! + call CalcDecomp( nx, ny, nproc, expHaloWidth, .true., nxproc, nyproc, rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 1.c Set arraySpec, staggerLoc, and indexFlag for export fields + ! + call ESMF_ArraySpecSet( expArraySpec2D, rank=2, & + typekind=ESMF_TYPEKIND_RX, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_ArraySpecSet( expArraySpec3D, rank=3, & + typekind=ESMF_TYPEKIND_RX, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + expStaggerLoc = ESMF_STAGGERLOC_CENTER + expIndexFlag = ESMF_INDEX_GLOBAL + ! + ! 1.d Set arraySpec, staggerLoc, and indexFlag for native fields + ! + call ESMF_ArraySpecSet( natArraySpec2D, rank=1, & + typekind=ESMF_TYPEKIND_RX, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_ArraySpecSet( natArraySpec3D, rank=2, & + typekind=ESMF_TYPEKIND_RX, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + natStaggerLoc = ESMF_STAGGERLOC_CENTER + natIndexFlag = ESMF_INDEX_DELOCAL + ! + ! 1.e Get z-levels for 3D export fields + ! + call GetZlevels( rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + write(msg,'(a)') 'input z-level file: '//trim(zlfile) + call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a)') 'table of z-levels' + call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a)') ' index z' + call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO) + do k=1,nz + write(msg,'(i8,1f10.2)') k, zl(k) call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a)') ' index z' - call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO) - do k=1,nz - write(msg,'(i8,1f10.2)') k, zl(k) - call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO) - enddo -! -! -------------------------------------------------------------------- / -! 2. Create ESMF grid for export with 2D subdomain layout -! Note that the ESMF grid layout is dim1=X, dim2=Y -! -! 2.a Create ESMF export grid -! + enddo + ! + ! -------------------------------------------------------------------- / + ! 2. Create ESMF grid for export with 2D subdomain layout + ! Note that the ESMF grid layout is dim1=X, dim2=Y + ! + ! 2.a Create ESMF export grid + ! + select case (iclose) + case (iclose_none) + expGrid = ESMF_GridCreateNoPeriDim( & + minIndex=(/ 1, 1/), & + maxIndex=(/nx,ny/), & + coordDep1=(/1,2/), & + coordDep2=(/1,2/), & + regDecomp=(/nxproc,nyproc/), & + decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), & + coordTypeKind=ESMF_TYPEKIND_RX, & + coordSys=ESMF_COORDSYS_SPH_DEG, & + indexFlag=expIndexFlag, & + name=trim(cname)//"_export_grid", rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + case (iclose_smpl) + expGrid = ESMF_GridCreate1PeriDim( & + periodicDim=1, & + poleDim=2, & + poleKindFlag=(/ESMF_POLEKIND_NONE,ESMF_POLEKIND_NONE/), & + minIndex=(/ 1, 1/), & + maxIndex=(/nx,ny/), & + coordDep1=(/1,2/), & + coordDep2=(/1,2/), & + regDecomp=(/nxproc,nyproc/), & + decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), & + coordTypeKind=ESMF_TYPEKIND_RX, & + coordSys=ESMF_COORDSYS_SPH_DEG, & + indexFlag=expIndexFlag, & + name=trim(cname)//"_export_grid", rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + case default + write(msg,'(a,i1,a)') 'Index closure ',iclose, & + ' not supported for export grid' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endselect + ! + ! 2.b Add coordinate arrays and land/sea mask to export grid + ! + call ESMF_GridAddCoord( expGrid, staggerLoc=expStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_GridAddItem( expGrid, ESMF_GRIDITEM_MASK, & + staggerLoc=expStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 2.c Set flag to indicate that this processor has local export grid storage + ! + call ESMF_GridGet( expGrid, localDECount=ldecnt, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + expGridIsLocal = ldecnt.gt.0 + ! + ! 2.d Get exclusive bounds (global index) for export grid + ! + if ( expGridIsLocal ) then + call ESMF_GridGet( expGrid, expStaggerLoc, lde, & + exclusiveLBound=elb, exclusiveUBound=eub, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! 2.e Set halo widths for export fields + ! + if ( expGridIsLocal ) then + expHaloLWidth = (/expHaloWidth,expHaloWidth/) + expHaloUWidth = (/expHaloWidth,expHaloWidth/) select case (iclose) - case (iclose_none) - expGrid = ESMF_GridCreateNoPeriDim( & - minIndex=(/ 1, 1/), & - maxIndex=(/nx,ny/), & - coordDep1=(/1,2/), & - coordDep2=(/1,2/), & - regDecomp=(/nxproc,nyproc/), & - decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), & - coordTypeKind=ESMF_TYPEKIND_RX, & - coordSys=ESMF_COORDSYS_SPH_DEG, & - indexFlag=expIndexFlag, & - name=trim(cname)//"_export_grid", rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - case (iclose_smpl) - expGrid = ESMF_GridCreate1PeriDim( & - periodicDim=1, & - poleDim=2, & - poleKindFlag=(/ESMF_POLEKIND_NONE,ESMF_POLEKIND_NONE/), & - minIndex=(/ 1, 1/), & - maxIndex=(/nx,ny/), & - coordDep1=(/1,2/), & - coordDep2=(/1,2/), & - regDecomp=(/nxproc,nyproc/), & - decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), & - coordTypeKind=ESMF_TYPEKIND_RX, & - coordSys=ESMF_COORDSYS_SPH_DEG, & - indexFlag=expIndexFlag, & - name=trim(cname)//"_export_grid", rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - case default - write(msg,'(a,i1,a)') 'Index closure ',iclose, & - ' not supported for export grid' - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return + case (iclose_none) + if ( elb(1).eq.1 ) expHaloLWidth(1) = 0 + if ( elb(2).eq.1 ) expHaloLWidth(2) = 0 + if ( eub(1).eq.nx ) expHaloUWidth(1) = 0 + if ( eub(2).eq.ny ) expHaloUWidth(2) = 0 + case (iclose_smpl) + if ( elb(2).eq.1 ) expHaloLWidth(2) = 0 + if ( eub(2).eq.ny ) expHaloUWidth(2) = 0 endselect -! -! 2.b Add coordinate arrays and land/sea mask to export grid -! - call ESMF_GridAddCoord( expGrid, staggerLoc=expStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_GridAddItem( expGrid, ESMF_GRIDITEM_MASK, & - staggerLoc=expStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 2.c Set flag to indicate that this processor has local export grid storage -! - call ESMF_GridGet( expGrid, localDECount=ldecnt, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - expGridIsLocal = ldecnt.gt.0 -! -! 2.d Get exclusive bounds (global index) for export grid -! - if ( expGridIsLocal ) then - call ESMF_GridGet( expGrid, expStaggerLoc, lde, & - exclusiveLBound=elb, exclusiveUBound=eub, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! 2.e Set halo widths for export fields -! - if ( expGridIsLocal ) then - expHaloLWidth = (/expHaloWidth,expHaloWidth/) - expHaloUWidth = (/expHaloWidth,expHaloWidth/) - select case (iclose) - case (iclose_none) - if ( elb(1).eq.1 ) expHaloLWidth(1) = 0 - if ( elb(2).eq.1 ) expHaloLWidth(2) = 0 - if ( eub(1).eq.nx ) expHaloUWidth(1) = 0 - if ( eub(2).eq.ny ) expHaloUWidth(2) = 0 - case (iclose_smpl) - if ( elb(2).eq.1 ) expHaloLWidth(2) = 0 - if ( eub(2).eq.ny ) expHaloUWidth(2) = 0 - endselect - else - expHaloLWidth = (/0,0/) - expHaloUWidth = (/0,0/) - endif -! -! 2.f Set ESMF export grid coordinate -! - if ( expGridIsLocal ) then - call ESMF_GridGetCoord( expGrid, 1, localDE=lde, & - staggerLoc=expStaggerLoc, farrayPtr=rptrx, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_GridGetCoord( expGrid, 2, localDE=lde, & - staggerLoc=expStaggerLoc, farrayPtr=rptry, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptrx(ix,iy) = xgrd(iy,ix) - rptry(ix,iy) = ygrd(iy,ix) - enddo + else + expHaloLWidth = (/0,0/) + expHaloUWidth = (/0,0/) + endif + ! + ! 2.f Set ESMF export grid coordinate + ! + if ( expGridIsLocal ) then + call ESMF_GridGetCoord( expGrid, 1, localDE=lde, & + staggerLoc=expStaggerLoc, farrayPtr=rptrx, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_GridGetCoord( expGrid, 2, localDE=lde, & + staggerLoc=expStaggerLoc, farrayPtr=rptry, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptrx(ix,iy) = xgrd(iy,ix) + rptry(ix,iy) = ygrd(iy,ix) enddo - endif -! -! 2.g Set ESMF export grid land/sea mask values. -! Land/sea mask is fixed in time and based on excluded points only. -! - if ( expGridIsLocal ) then - call ESMF_GridGetItem( expGrid, ESMF_GRIDITEM_MASK, localDE=lde, & - staggerLoc=expStaggerLoc, farrayPtr=iptr, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - if ( mapsta(iy,ix).ne.0 ) then - iptr(ix,iy) = maskValueWater - else - iptr(ix,iy) = maskValueLand - endif - enddo + enddo + endif + ! + ! 2.g Set ESMF export grid land/sea mask values. + ! Land/sea mask is fixed in time and based on excluded points only. + ! + if ( expGridIsLocal ) then + call ESMF_GridGetItem( expGrid, ESMF_GRIDITEM_MASK, localDE=lde, & + staggerLoc=expStaggerLoc, farrayPtr=iptr, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + if ( mapsta(iy,ix).ne.0 ) then + iptr(ix,iy) = maskValueWater + else + iptr(ix,iy) = maskValueLand + endif enddo - endif -! -! 2.h Set ESMF export grid corner coordinates -! + enddo + endif + ! + ! 2.h Set ESMF export grid corner coordinates + ! #ifdef W3_SCRIP - call ESMF_GridAddCoord( expGrid, & - staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - ! Calculate grid coordinates with help of SCRIP module - ! It does not return coordinates of top-most row and - ! right-most column but ESMF expects it. So, top-most row - ! and right-most column are theated specially in below - call get_scrip_info_structured(expGridID, & - xgrd_center, ygrd_center, xgrd_corner, ygrd_corner, & - land_sea, grid_dims, grid_size, grid_corners, grid_rank) - - ! Add corner coordinates - if ( impGridIsLocal ) then - ! Retrieve pointers - call ESMF_GridGetCoord( expGrid, 1, localDE=lde, & - staggerLoc=ESMF_STAGGERLOC_CORNER, farrayPtr=rptrx, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_GridGetCoord( expGrid, 2, localDE=lde, & - staggerLoc=ESMF_STAGGERLOC_CORNER, farrayPtr=rptry, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - ! Get exclusive bounds (global index) for export grid - ! corner coordinates - call ESMF_GridGet( impGrid, ESMF_STAGGERLOC_CORNER, lde, & - exclusiveLBound=elbc, exclusiveUBound=eubc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - ! Adjust upper bounds for specific PEs - ubx = 0 - uby = 0 - if (eubc(1) == grid_dims(1)+1) ubx = -1 - if (eubc(2) == grid_dims(2)+1) uby = -1 - - ! Fill coordinates - do iy = elbc(2),eubc(2)+uby - do ix = elbc(1),eubc(1)+ubx - irec = (iy-1)*grid_dims(1)+ix - rptrx(ix,iy) = real(xgrd_corner(1,irec), kind=ESMF_KIND_RX) - rptry(ix,iy) = real(ygrd_corner(1,irec), kind=ESMF_KIND_RX) - enddo + call ESMF_GridAddCoord( expGrid, & + staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + ! Calculate grid coordinates with help of SCRIP module + ! It does not return coordinates of top-most row and + ! right-most column but ESMF expects it. So, top-most row + ! and right-most column are theated specially in below + call get_scrip_info_structured(expGridID, & + xgrd_center, ygrd_center, xgrd_corner, ygrd_corner, & + land_sea, grid_dims, grid_size, grid_corners, grid_rank) + + ! Add corner coordinates + if ( impGridIsLocal ) then + ! Retrieve pointers + call ESMF_GridGetCoord( expGrid, 1, localDE=lde, & + staggerLoc=ESMF_STAGGERLOC_CORNER, farrayPtr=rptrx, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_GridGetCoord( expGrid, 2, localDE=lde, & + staggerLoc=ESMF_STAGGERLOC_CORNER, farrayPtr=rptry, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + ! Get exclusive bounds (global index) for export grid + ! corner coordinates + call ESMF_GridGet( impGrid, ESMF_STAGGERLOC_CORNER, lde, & + exclusiveLBound=elbc, exclusiveUBound=eubc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + ! Adjust upper bounds for specific PEs + ubx = 0 + uby = 0 + if (eubc(1) == grid_dims(1)+1) ubx = -1 + if (eubc(2) == grid_dims(2)+1) uby = -1 + + ! Fill coordinates + do iy = elbc(2),eubc(2)+uby + do ix = elbc(1),eubc(1)+ubx + irec = (iy-1)*grid_dims(1)+ix + rptrx(ix,iy) = real(xgrd_corner(1,irec), kind=ESMF_KIND_RX) + rptry(ix,iy) = real(ygrd_corner(1,irec), kind=ESMF_KIND_RX) enddo + enddo - ! Fill data on top-most row - if (eubc(2) == grid_dims(2)+1) then - do ix = elbc(1),eubc(1)+ubx - rptrx(ix,grid_dims(2)+1) = rptrx(ix,grid_dims(2))+ & - (rptrx(ix,grid_dims(2))-rptrx(ix,grid_dims(2)-1)) - rptry(ix,grid_dims(2)+1) = rptry(ix,grid_dims(2))+ & - (rptry(ix,grid_dims(2))-rptry(ix,grid_dims(2)-1)) - end do - end if + ! Fill data on top-most row + if (eubc(2) == grid_dims(2)+1) then + do ix = elbc(1),eubc(1)+ubx + rptrx(ix,grid_dims(2)+1) = rptrx(ix,grid_dims(2))+ & + (rptrx(ix,grid_dims(2))-rptrx(ix,grid_dims(2)-1)) + rptry(ix,grid_dims(2)+1) = rptry(ix,grid_dims(2))+ & + (rptry(ix,grid_dims(2))-rptry(ix,grid_dims(2)-1)) + end do + end if - ! Fill data on right-most column - if (eubc(1) == grid_dims(1)+1) then - do iy = elbc(2),eubc(2)+uby - rptrx(grid_dims(1)+1,iy) = rptrx(grid_dims(1),iy)+ & - (rptrx(grid_dims(1),iy)-rptrx(grid_dims(1)-1,iy)) - rptry(grid_dims(1)+1,iy) = rptry(grid_dims(1),iy)+ & - (rptry(grid_dims(1),iy)-rptry(grid_dims(1)-1,iy)) - end do - end if + ! Fill data on right-most column + if (eubc(1) == grid_dims(1)+1) then + do iy = elbc(2),eubc(2)+uby + rptrx(grid_dims(1)+1,iy) = rptrx(grid_dims(1),iy)+ & + (rptrx(grid_dims(1),iy)-rptrx(grid_dims(1)-1,iy)) + rptry(grid_dims(1)+1,iy) = rptry(grid_dims(1),iy)+ & + (rptry(grid_dims(1),iy)-rptry(grid_dims(1)-1,iy)) + end do + end if - ! Fill data on top-right corner, single point - if (eubc(1) == grid_dims(1)+1 .and. eubc(2) == grid_dims(2)+1) then - rptrx(grid_dims(1)+1,grid_dims(2)+1) = & - rptrx(grid_dims(1)+1,grid_dims(2)) - rptry(grid_dims(1)+1,grid_dims(2)+1) = & - rptry(grid_dims(1),grid_dims(2)+1) - end if + ! Fill data on top-right corner, single point + if (eubc(1) == grid_dims(1)+1 .and. eubc(2) == grid_dims(2)+1) then + rptrx(grid_dims(1)+1,grid_dims(2)+1) = & + rptrx(grid_dims(1)+1,grid_dims(2)) + rptry(grid_dims(1)+1,grid_dims(2)+1) = & + rptry(grid_dims(1),grid_dims(2)+1) end if + end if #endif -! -! -------------------------------------------------------------------- / -! 3. Create export field mask and routeHandle halo update -! -! 3.a Create field for export grid land/sea mask. -! - expMask = ESMF_FieldCreate( expGrid, expArraySpec2D, & - totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, & - staggerLoc=expStaggerLoc, indexFlag=expIndexFlag, & - name='mask', rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 3.b Store export field halo routeHandle -! - call ESMF_FieldHaloStore( expMask, routeHandle=expHaloRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 3.c Set export field land/sea mask values and update halos -! - if ( expGridIsLocal ) then - call ESMF_FieldGet( expMask, localDE=lde, farrayPtr=rptr, & - totalLBound=tlb, totalUBound=tub, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = iptr(ix,iy) - enddo + ! + ! -------------------------------------------------------------------- / + ! 3. Create export field mask and routeHandle halo update + ! + ! 3.a Create field for export grid land/sea mask. + ! + expMask = ESMF_FieldCreate( expGrid, expArraySpec2D, & + totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, & + staggerLoc=expStaggerLoc, indexFlag=expIndexFlag, & + name='mask', rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 3.b Store export field halo routeHandle + ! + call ESMF_FieldHaloStore( expMask, routeHandle=expHaloRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 3.c Set export field land/sea mask values and update halos + ! + if ( expGridIsLocal ) then + call ESMF_FieldGet( expMask, localDE=lde, farrayPtr=rptr, & + totalLBound=tlb, totalUBound=tub, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = iptr(ix,iy) enddo + enddo + endif + + call ESMF_FieldHalo( expMask, expHaloRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! 4. Create ESMF grid with arbitrary domain decomposition to match + ! the native domain decomposition of the non-excluded points + ! Note that the native grid layout is dim1=X, dim2=Y + ! Note that coordinates and mask are not needed since this + ! grid is only used to define fields for a redist operation + ! + ! 4.a Set flag to indicate that this processor has local native grid storage + ! + natGridIsLocal = iaproc .gt. 0 .and. iaproc .le. naproc + ! + ! 4.b Setup arbitrary sequence index list + ! + do ipass = 1,2 + if (ipass.eq.2) then + allocate (arbIndexList(arbIndexCount,2), stat=rc) + if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return endif - - call ESMF_FieldHalo( expMask, expHaloRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! 4. Create ESMF grid with arbitrary domain decomposition to match -! the native domain decomposition of the non-excluded points -! Note that the native grid layout is dim1=X, dim2=Y -! Note that coordinates and mask are not needed since this -! grid is only used to define fields for a redist operation -! -! 4.a Set flag to indicate that this processor has local native grid storage -! - natGridIsLocal = iaproc .gt. 0 .and. iaproc .le. naproc -! -! 4.b Setup arbitrary sequence index list -! - do ipass = 1,2 - if (ipass.eq.2) then - allocate (arbIndexList(arbIndexCount,2), stat=rc) - if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return - endif - arbIndexCount = 0 - ! list local native grid non-excluded points - if ( natGridIsLocal ) then - do jsea = 1,nseal + arbIndexCount = 0 + ! list local native grid non-excluded points + if ( natGridIsLocal ) then + do jsea = 1,nseal #ifdef W3_DIST - isea = iaproc + (jsea-1)*naproc + isea = iaproc + (jsea-1)*naproc #endif #ifdef W3_SHRD - isea = jsea + isea = jsea #endif + arbIndexCount = arbIndexCount+1 + if (ipass.eq.2) then + ix = mapsf(isea,1) + iy = mapsf(isea,2) + ! native grid layout: dim1=X, dim2=Y + arbIndexList(arbIndexCount,1) = ix + arbIndexList(arbIndexCount,2) = iy + endif + enddo + endif + ! list local export grid excluded points + if ( expGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + if ( mapsta(iy,ix).ne.0 ) cycle ! skip non-excluded point arbIndexCount = arbIndexCount+1 if (ipass.eq.2) then - ix = mapsf(isea,1) - iy = mapsf(isea,2) ! native grid layout: dim1=X, dim2=Y arbIndexList(arbIndexCount,1) = ix arbIndexList(arbIndexCount,2) = iy endif enddo - endif - ! list local export grid excluded points - if ( expGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - if ( mapsta(iy,ix).ne.0 ) cycle ! skip non-excluded point - arbIndexCount = arbIndexCount+1 - if (ipass.eq.2) then - ! native grid layout: dim1=X, dim2=Y - arbIndexList(arbIndexCount,1) = ix - arbIndexList(arbIndexCount,2) = iy - endif - enddo - enddo - endif - enddo !ipass -! -! 4.c Create ESMF native grid -! - select case (iclose) - case (iclose_none) - natGrid = ESMF_GridCreateNoPeriDim( & - minIndex=(/ 1, 1/), & - maxIndex=(/nx,ny/), & - coordDep1=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & - coordDep2=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & - arbIndexCount=arbIndexCount, & - arbIndexList=arbIndexList, & - coordTypeKind=ESMF_TYPEKIND_RX, & - coordSys=ESMF_COORDSYS_SPH_DEG, & - name=trim(cname)//"_native_grid", rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - case (iclose_smpl) - natGrid = ESMF_GridCreate1PeriDim( & - periodicDim=1, & - poleDim=2, & - poleKindFlag=(/ESMF_POLEKIND_NONE,ESMF_POLEKIND_NONE/), & - minIndex=(/ 1, 1/), & - maxIndex=(/nx,ny/), & - coordDep1=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & - coordDep2=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & - arbIndexCount=arbIndexCount, & - arbIndexList=arbIndexList, & - coordTypeKind=ESMF_TYPEKIND_RX, & - coordSys=ESMF_COORDSYS_SPH_DEG, & - name=trim(cname)//"_native_grid", rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - case default - write(msg,'(a,i1,a)') 'Index closure ',iclose, & - ' not supported for native grid' - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return - endselect -! -! 4.d Deallocate arbitrary sequence index list -! - deallocate (arbIndexList, stat=rc) - if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! 5. Create route handle for redist between native grid domain -! decomposition and the export grid domain decomposition -! -! 5.a Create temporary fields -! - nField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - eField = ESMF_FieldCreate( expGrid, expArraySpec2D, & - totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, & - staggerLoc=expStaggerLoc, indexFlag=expIndexFlag, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 5.b Store route handle -! - call ESMF_FieldRedistStore( nField, eField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 5.c Clean up -! - call ESMF_FieldDestroy( nField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( eField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! Post -! -#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_CREATEEXPGRID) - write(msg,'(a,i6)') ' expGridID: ',expGridID - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,l6)') 'expGridIsLocal: ',expGridIsLocal - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' nx, ny: ',nx,ny - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') 'naproc, nmproc: ',naproc,nmproc - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,i6)') ' nproc: ',nproc - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') 'nxproc, nyproc: ',nxproc,nyproc - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' elb: ',elb(:) - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' eub: ',eub(:) - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' tlb: ',tlb(:) - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' tub: ',tub(:) - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' expHaloLWidth: ',expHaloLWidth(:) - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - write(msg,'(a,2i6)') ' expHaloUWidth: ',expHaloUWidth(:) - call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) - call ESMF_FieldWrite( expMask, & - "wmesmfmd_createexpgrid_export_mask.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - tmpField = ESMF_FieldCreate( expGrid, expArraySpec2D, & - totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, & - staggerLoc=expStaggerLoc, indexFlag=expIndexFlag, & - name='temp', rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expGridIsLocal ) then - call ESMF_FieldGet( tmpField, localDE=lde, farrayPtr=rptr, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif - if ( expGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = xgrd(iy,ix) - enddo enddo endif - call ESMF_FieldWrite( tmpField, & - "wmesmfmd_createexpgrid_export_xgrd.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = ygrd(iy,ix) - enddo + enddo !ipass + ! + ! 4.c Create ESMF native grid + ! + select case (iclose) + case (iclose_none) + natGrid = ESMF_GridCreateNoPeriDim( & + minIndex=(/ 1, 1/), & + maxIndex=(/nx,ny/), & + coordDep1=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & + coordDep2=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & + arbIndexCount=arbIndexCount, & + arbIndexList=arbIndexList, & + coordTypeKind=ESMF_TYPEKIND_RX, & + coordSys=ESMF_COORDSYS_SPH_DEG, & + name=trim(cname)//"_native_grid", rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + case (iclose_smpl) + natGrid = ESMF_GridCreate1PeriDim( & + periodicDim=1, & + poleDim=2, & + poleKindFlag=(/ESMF_POLEKIND_NONE,ESMF_POLEKIND_NONE/), & + minIndex=(/ 1, 1/), & + maxIndex=(/nx,ny/), & + coordDep1=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & + coordDep2=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & + arbIndexCount=arbIndexCount, & + arbIndexList=arbIndexList, & + coordTypeKind=ESMF_TYPEKIND_RX, & + coordSys=ESMF_COORDSYS_SPH_DEG, & + name=trim(cname)//"_native_grid", rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + case default + write(msg,'(a,i1,a)') 'Index closure ',iclose, & + ' not supported for native grid' + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endselect + ! + ! 4.d Deallocate arbitrary sequence index list + ! + deallocate (arbIndexList, stat=rc) + if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! 5. Create route handle for redist between native grid domain + ! decomposition and the export grid domain decomposition + ! + ! 5.a Create temporary fields + ! + nField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + eField = ESMF_FieldCreate( expGrid, expArraySpec2D, & + totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, & + staggerLoc=expStaggerLoc, indexFlag=expIndexFlag, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 5.b Store route handle + ! + call ESMF_FieldRedistStore( nField, eField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 5.c Clean up + ! + call ESMF_FieldDestroy( nField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( eField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! -------------------------------------------------------------------- / + ! Post + ! +#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_CREATEEXPGRID) + write(msg,'(a,i6)') ' expGridID: ',expGridID + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,l6)') 'expGridIsLocal: ',expGridIsLocal + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' nx, ny: ',nx,ny + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') 'naproc, nmproc: ',naproc,nmproc + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,i6)') ' nproc: ',nproc + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') 'nxproc, nyproc: ',nxproc,nyproc + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' elb: ',elb(:) + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' eub: ',eub(:) + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' tlb: ',tlb(:) + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' tub: ',tub(:) + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' expHaloLWidth: ',expHaloLWidth(:) + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + write(msg,'(a,2i6)') ' expHaloUWidth: ',expHaloUWidth(:) + call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO) + call ESMF_FieldWrite( expMask, & + "wmesmfmd_createexpgrid_export_mask.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + tmpField = ESMF_FieldCreate( expGrid, expArraySpec2D, & + totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, & + staggerLoc=expStaggerLoc, indexFlag=expIndexFlag, & + name='temp', rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expGridIsLocal ) then + call ESMF_FieldGet( tmpField, localDE=lde, farrayPtr=rptr, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + if ( expGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = xgrd(iy,ix) enddo - endif - call ESMF_FieldWrite( tmpField, & - "wmesmfmd_createexpgrid_export_ygrd.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = hpfac(iy,ix) - enddo + enddo + endif + call ESMF_FieldWrite( tmpField, & + "wmesmfmd_createexpgrid_export_xgrd.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = ygrd(iy,ix) enddo - endif - call ESMF_FieldWrite( tmpField, & - "wmesmfmd_createexpgrid_export_hpfac.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = hqfac(iy,ix) - enddo + enddo + endif + call ESMF_FieldWrite( tmpField, & + "wmesmfmd_createexpgrid_export_ygrd.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = hpfac(iy,ix) enddo - endif - call ESMF_FieldWrite( tmpField, & - "wmesmfmd_createexpgrid_export_hqfac.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( expGridIsLocal ) then - do iy = elb(2),eub(2) - do ix = elb(1),eub(1) - rptr(ix,iy) = lpet - enddo + enddo + endif + call ESMF_FieldWrite( tmpField, & + "wmesmfmd_createexpgrid_export_hpfac.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = hqfac(iy,ix) enddo - endif - call ESMF_FieldWrite( tmpField, & - "wmesmfmd_createexpgrid_export_dcomp.nc", overwrite=.true., rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( tmpField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo + endif + call ESMF_FieldWrite( tmpField, & + "wmesmfmd_createexpgrid_export_hqfac.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if ( expGridIsLocal ) then + do iy = elb(2),eub(2) + do ix = elb(1),eub(1) + rptr(ix,iy) = lpet + enddo + enddo + endif + call ESMF_FieldWrite( tmpField, & + "wmesmfmd_createexpgrid_export_dcomp.nc", overwrite=.true., rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( tmpField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #endif -! - rc = ESMF_SUCCESS - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving CreateExpGrid', ESMF_LOGMSG_INFO) -!/ -!/ End of CreateExpGrid ---------------------------------------------- / -!/ - end subroutine CreateExpGrid -!/ ------------------------------------------------------------------- / -!> -!> @brief Create ESMF mesh (unstructured) for import fields. -!> -!> @details Create an ESMF Mesh for import using the unstructured mesh -!> description in W3GDATMD. At present, this import mesh is not -!> domain decomposed, but instead is defined on PET 0 only. (In -!> future, when the unstructured mesh will run on domain decomposition, -!> we will use that decomposition.) -!> -!> @param gcomp Gridded component -!> @param[out] rc Return code -!> -!> @author A. J. van der Westhuysen @date 28-Feb-2018 -!> + ! + rc = ESMF_SUCCESS + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving CreateExpGrid', ESMF_LOGMSG_INFO) + !/ + !/ End of CreateExpGrid ---------------------------------------------- / + !/ + end subroutine CreateExpGrid + !/ ------------------------------------------------------------------- / + !> + !> @brief Create ESMF mesh (unstructured) for import fields. + !> + !> @details Create an ESMF Mesh for import using the unstructured mesh + !> description in W3GDATMD. At present, this import mesh is not + !> domain decomposed, but instead is defined on PET 0 only. (In + !> future, when the unstructured mesh will run on domain decomposition, + !> we will use that decomposition.) + !> + !> @param gcomp Gridded component + !> @param[out] rc Return code + !> + !> @author A. J. van der Westhuysen @date 28-Feb-2018 + !> #undef METHOD #define METHOD "CreateImpMesh" - subroutine CreateImpMesh ( gcomp, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | FORTRAN 90 | -!/ | Last update : 28-FEB_2018 | -!/ +-----------------------------------+ -!/ -!/ 28-Feb-2018 : Origination. ( version 6.06 ) -!/ -! 1. Purpose : -! -! Create ESMF mesh (unstructured) for import fields -! -! 2. Method : -! -! Create an ESMF Mesh for import using the unstructured mesh description -! in W3GDATMD. At present, this import mesh is not domain decomposed, -! but instead is defined on PET 0 only. (In future, when the unstructured -! mesh will run on domain decomposition, we will use that decomposition.) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + subroutine CreateImpMesh ( gcomp, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | FORTRAN 90 | + !/ | Last update : 28-FEB_2018 | + !/ +-----------------------------------+ + !/ + !/ 28-Feb-2018 : Origination. ( version 6.06 ) + !/ + ! 1. Purpose : + ! + ! Create ESMF mesh (unstructured) for import fields + ! + ! 2. Method : + ! + ! Create an ESMF Mesh for import using the unstructured mesh description + ! in W3GDATMD. At present, this import mesh is not domain decomposed, + ! but instead is defined on PET 0 only. (In future, when the unstructured + ! mesh will run on domain decomposition, we will use that decomposition.) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_PDLIB - use yowNodepool, only: npa, iplg, nodes_global - use yowElementpool, only: ne, ielg, INE + use yowNodepool, only: npa, iplg, nodes_global + use yowElementpool, only: ne, ielg, INE #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - character(128) :: msg - integer :: nproc, nxproc, nyproc, n, nfac, irp - real :: gr, rp, pr, diff - integer, parameter :: lde = 0 - integer :: ldecnt - integer :: i, j, pos, ix, iy - integer(ESMF_KIND_I4), pointer :: iptr(:,:) - real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:) - real(ESMF_KIND_RX), pointer :: rptr(:,:) - type(ESMF_Field) :: tmpField - integer(ESMF_KIND_I4), allocatable :: nodeIds(:) - real(ESMF_KIND_R8), allocatable :: nodeCoords(:) - integer(ESMF_KIND_I4), allocatable :: nodeOwners(:) - integer(ESMF_KIND_I4), allocatable :: elemIds(:) - integer(ESMF_KIND_I4), allocatable :: elemTypes(:) - integer(ESMF_KIND_I4), allocatable :: elemConn(:) -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - if ( noActiveImpFields ) return - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered CreateImpMesh', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! 1. Setup -! -! 1.a Set grid pointers -! - impGridID = minval(inpmap) - if ( impGridID.eq.-999 ) impGridID = 1 - call w3setg ( impGridID, mdse, mdst ) - call w3seti ( impGridID, mdse, mdst ) - call w3seto ( impGridID, mdse, mdst ) - if ( impGridID.gt.0 ) then - call wmsetm ( impGridID, mdse, mdst ) - nproc = naproc - else - nproc = nmproc - endif -! -! 1.b Set arraySpec, staggerLoc, and indexFlag for import fields -! -! call ESMF_ArraySpecSet( impArraySpec2D, rank=2, & -! typekind=ESMF_TYPEKIND_RX, rc=rc ) -! if (ESMF_LogFoundError(rc, PASSTHRU)) return -! impStaggerLoc = ESMF_STAGGERLOC_CENTER -! impIndexFlag = ESMF_INDEX_GLOBAL -! -! -------------------------------------------------------------------- / -! 2. Create ESMF mesh for import, currently without domain decomposition -! Note that the ESMF grid layout is dim1=X, dim2=Y -! -! 2.a Create ESMF import mesh -! -! Allocate and fill the node id array. + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + character(128) :: msg + integer :: nproc, nxproc, nyproc, n, nfac, irp + real :: gr, rp, pr, diff + integer, parameter :: lde = 0 + integer :: ldecnt + integer :: i, j, pos, ix, iy + integer(ESMF_KIND_I4), pointer :: iptr(:,:) + real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:) + real(ESMF_KIND_RX), pointer :: rptr(:,:) + type(ESMF_Field) :: tmpField + integer(ESMF_KIND_I4), allocatable :: nodeIds(:) + real(ESMF_KIND_R8), allocatable :: nodeCoords(:) + integer(ESMF_KIND_I4), allocatable :: nodeOwners(:) + integer(ESMF_KIND_I4), allocatable :: elemIds(:) + integer(ESMF_KIND_I4), allocatable :: elemTypes(:) + integer(ESMF_KIND_I4), allocatable :: elemConn(:) + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + if ( noActiveImpFields ) return + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered CreateImpMesh', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! 1. Setup + ! + ! 1.a Set grid pointers + ! + impGridID = minval(inpmap) + if ( impGridID.eq.-999 ) impGridID = 1 + call w3setg ( impGridID, mdse, mdst ) + call w3seti ( impGridID, mdse, mdst ) + call w3seto ( impGridID, mdse, mdst ) + if ( impGridID.gt.0 ) then + call wmsetm ( impGridID, mdse, mdst ) + nproc = naproc + else + nproc = nmproc + endif + ! + ! 1.b Set arraySpec, staggerLoc, and indexFlag for import fields + ! + ! call ESMF_ArraySpecSet( impArraySpec2D, rank=2, & + ! typekind=ESMF_TYPEKIND_RX, rc=rc ) + ! if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! impStaggerLoc = ESMF_STAGGERLOC_CENTER + ! impIndexFlag = ESMF_INDEX_GLOBAL + ! + ! -------------------------------------------------------------------- / + ! 2. Create ESMF mesh for import, currently without domain decomposition + ! Note that the ESMF grid layout is dim1=X, dim2=Y + ! + ! 2.a Create ESMF import mesh + ! + ! Allocate and fill the node id array. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(nodeIds(NX)) - do i = 1,NX - nodeIds(i)=i - enddo + allocate(nodeIds(NX)) + do i = 1,NX + nodeIds(i)=i + enddo #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: The global id's of the nodes resident on this processor -! ------------------------------------------------------------------- -! Allocate global node ids, including ghost nodes (npa=np+ng) - allocate(nodeIds(npa)) - do i = 1,npa - nodeIds(i)=iplg(i) - enddo - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeIds=', & -! ESMF_LOGMSG_INFO) -! do i = 1,npa -! write(msg,*) trim(cname)//': nodeIds(i)',i, & -! ' ',nodeIds(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: The global id's of the nodes resident on this processor + ! ------------------------------------------------------------------- + ! Allocate global node ids, including ghost nodes (npa=np+ng) + allocate(nodeIds(npa)) + do i = 1,npa + nodeIds(i)=iplg(i) + enddo + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeIds=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,npa + ! write(msg,*) trim(cname)//': nodeIds(i)',i, & + ! ' ',nodeIds(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeIds=', & -! ESMF_LOGMSG_INFO) -! do i = 1,NX -! write(msg,*) trim(cname)//': ',i, & -! ' ',nodeIds(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo - -! Allocate and fill node coordinate array. -! Since this is a 2D Mesh the size is 2x the -! number of nodes. + ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeIds=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,NX + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',nodeIds(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo + + ! Allocate and fill node coordinate array. + ! Since this is a 2D Mesh the size is 2x the + ! number of nodes. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(nodeCoords(2*NX)) - do i = 1,NX - do j = 1,2 - pos=2*(i-1)+j - if (j == 1) then - nodeCoords(pos) = xgrd(1,i) - else - nodeCoords(pos) = ygrd(1,i) - endif - enddo - enddo + allocate(nodeCoords(2*NX)) + do i = 1,NX + do j = 1,2 + pos=2*(i-1)+j + if (j == 1) then + nodeCoords(pos) = xgrd(1,i) + else + nodeCoords(pos) = ygrd(1,i) + endif + enddo + enddo #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: Physical coordinates of the nodes -! ------------------------------------------------------------------- - allocate(nodeCoords(2*npa)) - do i = 1,npa - do j = 1,2 - pos=2*(i-1)+j - if ( j == 1) then - nodeCoords(pos) = xgrd(1,iplg(i)) - else - nodeCoords(pos) = ygrd(1,iplg(i)) - endif - enddo - enddo - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeCoords=', & -! ESMF_LOGMSG_INFO) -! do i = 1,(2*npa) -! write(msg,*) trim(cname)//': nodeCoords(i)',i, & -! ' ',nodeCoords(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: Physical coordinates of the nodes + ! ------------------------------------------------------------------- + allocate(nodeCoords(2*npa)) + do i = 1,npa + do j = 1,2 + pos=2*(i-1)+j + if ( j == 1) then + nodeCoords(pos) = xgrd(1,iplg(i)) + else + nodeCoords(pos) = ygrd(1,iplg(i)) + endif + enddo + enddo + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeCoords=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,(2*npa) + ! write(msg,*) trim(cname)//': nodeCoords(i)',i, & + ! ' ',nodeCoords(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeCoords=', & -! ESMF_LOGMSG_INFO) -! do i = 1,(2*NX) -! write(msg,*) trim(cname)//': ',i, & -! ' ',nodeCoords(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeCoords=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,(2*NX) + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',nodeCoords(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo -! Allocate and fill the node owner array. -! Since this mesh is all on PET 0, it’s just set to all 0. + ! Allocate and fill the node owner array. + ! Since this mesh is all on PET 0, it’s just set to all 0. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(nodeOwners(NX)) - nodeOwners=0 ! everything on PET 0 + allocate(nodeOwners(NX)) + nodeOwners=0 ! everything on PET 0 #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: Processor that owns the node -! ------------------------------------------------------------------- - allocate(nodeOwners(npa)) - nodeOwners=nodes_global(iplg(1:npa))%domainID-1 - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeOwners=', & -! ESMF_LOGMSG_INFO) -! do i = 1,npa -! write(msg,*) trim(cname)//': nodeOwners(i)',i, & -! ' ',nodeOwners(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: Processor that owns the node + ! ------------------------------------------------------------------- + allocate(nodeOwners(npa)) + nodeOwners=nodes_global(iplg(1:npa))%domainID-1 + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeOwners=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,npa + ! write(msg,*) trim(cname)//': nodeOwners(i)',i, & + ! ' ',nodeOwners(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeOwners=', & -! ESMF_LOGMSG_INFO) -! do i = 1,NX -! write(msg,*) trim(cname)//': ',i, & -! ' ',nodeOwners(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeOwners=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,NX + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',nodeOwners(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo -! Allocate and fill the element id array. + ! Allocate and fill the element id array. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(elemIds(NTRI)) - do i = 1,NTRI - elemIds(i)=i - enddo + allocate(elemIds(NTRI)) + do i = 1,NTRI + elemIds(i)=i + enddo #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: The global id's of the elements resident on this processor -! ------------------------------------------------------------------- - allocate(elemIds(ne)) - do i = 1,ne - elemIds(i)=ielg(i) - enddo - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemIds=', & -! ESMF_LOGMSG_INFO) -! do i = 1,ne -! write(msg,*) trim(cname)//': elemIds(i)',i, & -! ' ',elemIds(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: The global id's of the elements resident on this processor + ! ------------------------------------------------------------------- + allocate(elemIds(ne)) + do i = 1,ne + elemIds(i)=ielg(i) + enddo + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemIds=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,ne + ! write(msg,*) trim(cname)//': elemIds(i)',i, & + ! ' ',elemIds(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemIds=', & -! ESMF_LOGMSG_INFO) -! do i = 1,NTRI -! write(msg,*) trim(cname)//': ',i, & -! ' ',elemIds(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemIds=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,NTRI + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',elemIds(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo -! Allocate and fill the element topology type array. + ! Allocate and fill the element topology type array. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(elemTypes(NTRI)) - do i = 1,NTRI - elemTypes(i)=ESMF_MESHELEMTYPE_TRI - enddo + allocate(elemTypes(NTRI)) + do i = 1,NTRI + elemTypes(i)=ESMF_MESHELEMTYPE_TRI + enddo #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: Topology of the given element (one of ESMF_MeshElement) -! ------------------------------------------------------------------- - allocate(elemTypes(ne)) - do i = 1,ne - elemTypes(i)=ESMF_MESHELEMTYPE_TRI - enddo - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateImpM, elemTypes=', & -! ESMF_LOGMSG_INFO) -! do i = 1,ne -! write(msg,*) trim(cname)//': elemTypes(i)',i, & -! ' ',elemTypes(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: Topology of the given element (one of ESMF_MeshElement) + ! ------------------------------------------------------------------- + allocate(elemTypes(ne)) + do i = 1,ne + elemTypes(i)=ESMF_MESHELEMTYPE_TRI + enddo + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateImpM, elemTypes=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,ne + ! write(msg,*) trim(cname)//': elemTypes(i)',i, & + ! ' ',elemTypes(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateImpM, elemTypes=', & -! ESMF_LOGMSG_INFO) -! do i = 1,NTRI -! write(msg,*) trim(cname)//': ',i, & -! ' ',elemTypes(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In CreateImpM, elemTypes=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,NTRI + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',elemTypes(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo -! Allocate and fill the element connection type array. + ! Allocate and fill the element connection type array. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(elemConn(3*NTRI)) - do i = 1,NTRI - do j = 1,3 - pos=3*(i-1)+j - elemConn(pos)=TRIGP(j,i) - enddo - enddo + allocate(elemConn(3*NTRI)) + do i = 1,NTRI + do j = 1,3 + pos=3*(i-1)+j + elemConn(pos)=TRIGP(j,i) + enddo + enddo #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: Connectivity table. The number of entries should -! be equal to the number of nodes in the given topology. The indices -! should be the local index (1 based) into the array of nodes that -! was declared with MeshAddNodes. -! ------------------------------------------------------------------- -! > INE is local element array. it stores the local node IDs -! > first index from 1 to 3. -! > second index from 1 to ne. - allocate(elemConn(3*ne)) - do i = 1,ne - do j = 1,3 - pos=3*(i-1)+j - elemConn(pos)=INE(j,i) - enddo - enddo - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemConn=', & -! ESMF_LOGMSG_INFO) -! do i = 1,(3*ne) -! write(msg,*) trim(cname)//': elemConn(i)',i, & -! ' ',elemConn(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: Connectivity table. The number of entries should + ! be equal to the number of nodes in the given topology. The indices + ! should be the local index (1 based) into the array of nodes that + ! was declared with MeshAddNodes. + ! ------------------------------------------------------------------- + ! > INE is local element array. it stores the local node IDs + ! > first index from 1 to 3. + ! > second index from 1 to ne. + allocate(elemConn(3*ne)) + do i = 1,ne + do j = 1,3 + pos=3*(i-1)+j + elemConn(pos)=INE(j,i) + enddo + enddo + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemConn=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,(3*ne) + ! write(msg,*) trim(cname)//': elemConn(i)',i, & + ! ' ',elemConn(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemConn=', & -! ESMF_LOGMSG_INFO) -! do i = 1,(3*NTRI) -! write(msg,*) trim(cname)//': ',i, & -! ' ',elemConn(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemConn=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,(3*NTRI) + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',elemConn(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo - impMesh = ESMF_MeshCreate( parametricDim=2,spatialDim=2, & + impMesh = ESMF_MeshCreate( parametricDim=2,spatialDim=2, & nodeIds=nodeIds, nodeCoords=nodeCoords, & nodeOwners=nodeOwners, elementIds=elemIds,& elementTypes=elemTypes, elementConn=elemConn, & rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - deallocate(nodeIds) - deallocate(nodeCoords) - deallocate(nodeOwners) - deallocate(elemIds) - deallocate(elemTypes) - deallocate(elemConn) - - call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, created impMesh', & - ESMF_LOGMSG_INFO) -! - rc = ESMF_SUCCESS - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving CreateImpMesh', ESMF_LOGMSG_INFO) -!/ -!/ End of CreateImpMesh ---------------------------------------------- / -!/ - end subroutine CreateImpMesh -!/ ------------------------------------------------------------------- / -!> -!> @brief Create ESMF mesh (unstructured) for export fields. -!> -!> @details Create an ESMF Mesh for export using the unstructured mesh -!> description in W3GDATMD. At present, this export mesh is not domain -!> decomposed, but instead is defined on PET 0 only. (In future, when the -!> unstructured mesh will run on domain decomposition, we will use that -!> decomposition.) -!> -!> Since the internal parallel data is currently stored accross grid points -!> in a "card deck" fashion, we will define an intermediate native grid, as -!> is done for regular/curvilinear grids, and perform an ESMF regrid to the -!> export mesh. This code segment is taken from T. J. Campbell, and -!> modified to 1D, because the internal data structure for unstructred -!> meshes is an array with dimensions [NX,NY=1]. -!> -!> @param gcomp Gridded component -!> @param[out] rc Return code -!> -!> @author A. J. van der Westhuysen @date 28-Feb-2018 -!> + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + deallocate(nodeIds) + deallocate(nodeCoords) + deallocate(nodeOwners) + deallocate(elemIds) + deallocate(elemTypes) + deallocate(elemConn) + + call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, created impMesh', & + ESMF_LOGMSG_INFO) + ! + rc = ESMF_SUCCESS + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving CreateImpMesh', ESMF_LOGMSG_INFO) + !/ + !/ End of CreateImpMesh ---------------------------------------------- / + !/ + end subroutine CreateImpMesh + !/ ------------------------------------------------------------------- / + !> + !> @brief Create ESMF mesh (unstructured) for export fields. + !> + !> @details Create an ESMF Mesh for export using the unstructured mesh + !> description in W3GDATMD. At present, this export mesh is not domain + !> decomposed, but instead is defined on PET 0 only. (In future, when the + !> unstructured mesh will run on domain decomposition, we will use that + !> decomposition.) + !> + !> Since the internal parallel data is currently stored accross grid points + !> in a "card deck" fashion, we will define an intermediate native grid, as + !> is done for regular/curvilinear grids, and perform an ESMF regrid to the + !> export mesh. This code segment is taken from T. J. Campbell, and + !> modified to 1D, because the internal data structure for unstructred + !> meshes is an array with dimensions [NX,NY=1]. + !> + !> @param gcomp Gridded component + !> @param[out] rc Return code + !> + !> @author A. J. van der Westhuysen @date 28-Feb-2018 + !> #undef METHOD #define METHOD "CreateExpMesh" - subroutine CreateExpMesh ( gcomp, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | FORTRAN 90 | -!/ | Last update : 28-FEB-2018 | -!/ +-----------------------------------+ -!/ -!/ 28-Feb-2018 : Origination. ( version 6.06 ) -!/ -! 1. Purpose : -! -! Create ESMF mesh (unstructured) for export fields -! -! 2. Method : -! -! Create an ESMF Mesh for export using the unstructured mesh description -! in W3GDATMD. At present, this export mesh is not domain decomposed, -! but instead is defined on PET 0 only. (In future, when the unstructured -! mesh will run on domain decomposition, we will use that decomposition.) -! -! Since the internal parallel data is currently stored accross grid points -! in a "card deck" fashion, we will define an intermediate native grid, as -! is done for regular/curvilinear grids, and perform an ESMF regrid to the -! export mesh. This code segment is taken from T. J. Campbell, and -! modified to 1D, because the internal data structure for unstructred -! meshes is an array with dimensions [NX,NY=1]. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! gcomp Type I/O Gridded component -! rc Int. O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + subroutine CreateExpMesh ( gcomp, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | FORTRAN 90 | + !/ | Last update : 28-FEB-2018 | + !/ +-----------------------------------+ + !/ + !/ 28-Feb-2018 : Origination. ( version 6.06 ) + !/ + ! 1. Purpose : + ! + ! Create ESMF mesh (unstructured) for export fields + ! + ! 2. Method : + ! + ! Create an ESMF Mesh for export using the unstructured mesh description + ! in W3GDATMD. At present, this export mesh is not domain decomposed, + ! but instead is defined on PET 0 only. (In future, when the unstructured + ! mesh will run on domain decomposition, we will use that decomposition.) + ! + ! Since the internal parallel data is currently stored accross grid points + ! in a "card deck" fashion, we will define an intermediate native grid, as + ! is done for regular/curvilinear grids, and perform an ESMF regrid to the + ! export mesh. This code segment is taken from T. J. Campbell, and + ! modified to 1D, because the internal data structure for unstructred + ! meshes is an array with dimensions [NX,NY=1]. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! gcomp Type I/O Gridded component + ! rc Int. O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_PDLIB - use yowNodepool, only: npa, iplg, nodes_global - use yowElementpool, only: ne, ielg, INE + use yowNodepool, only: npa, iplg, nodes_global + use yowElementpool, only: ne, ielg, INE #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_GridComp) :: gcomp - integer,intent(out) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - character(128) :: msg - integer :: nproc, nxproc, nyproc, n, nfac, irp - real :: gr, rp, pr, diff - integer, parameter :: lde = 0 - integer :: ldecnt - integer :: i, j, pos, ix, iy, isea, jsea, iproc - integer :: elb(2), eub(2) - integer(ESMF_KIND_I4), pointer :: iptr(:,:) - real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:) - real(ESMF_KIND_RX), pointer :: rptr(:,:) - integer :: arbIndexCount - integer, allocatable :: arbIndexList(:,:) - type(ESMF_Field) :: nField, eField - type(ESMF_Field) :: tmpField - integer(ESMF_KIND_I4), allocatable :: nodeIds(:) - real(ESMF_KIND_R8), allocatable :: nodeCoords(:) - integer(ESMF_KIND_I4), allocatable :: nodeOwners(:) - integer(ESMF_KIND_I4), allocatable :: elemIds(:) - integer(ESMF_KIND_I4), allocatable :: elemTypes(:) - integer(ESMF_KIND_I4), allocatable :: elemConn(:) -! -! -------------------------------------------------------------------- / -! Prep -! - rc = ESMF_SUCCESS - if ( noActiveExpFields ) return - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': entered CreateExpMesh', ESMF_LOGMSG_INFO) -! -! -------------------------------------------------------------------- / -! Set flag to indicate that this processor has local native grid storage -! - natGridIsLocal = iaproc .gt. 0 .and. iaproc .le. naproc - -! 1. Setup -! -! 1.a Set grid pointers -! - expGridID = 1 !TODO: only export from grid 1 - call w3setg ( expGridID, mdse, mdst ) - call w3setw ( expGridID, mdse, mdst ) - call w3seta ( expGridID, mdse, mdst ) - call w3seti ( expGridID, mdse, mdst ) - call w3seto ( expGridID, mdse, mdst ) - call wmsetm ( expGridID, mdse, mdst ) - natGridID = expGridID - nproc = naproc -! -! 1.b Set arraySpec, staggerLoc, and indexFlag for native fields. -! NOTE: For unstructured meshes the native grid is a 1D array (NY=1) -! - call ESMF_ArraySpecSet( natArraySpec1D, rank=1, & - typekind=ESMF_TYPEKIND_RX, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - natStaggerLoc = ESMF_STAGGERLOC_CENTER - natIndexFlag = ESMF_INDEX_DELOCAL -! -! -------------------------------------------------------------------- / -! 2. Create ESMF mesh for export -! -! 2.a Create ESMF export mesh -! -! Allocate and fill the node id array. + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_GridComp) :: gcomp + integer,intent(out) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + character(128) :: msg + integer :: nproc, nxproc, nyproc, n, nfac, irp + real :: gr, rp, pr, diff + integer, parameter :: lde = 0 + integer :: ldecnt + integer :: i, j, pos, ix, iy, isea, jsea, iproc + integer :: elb(2), eub(2) + integer(ESMF_KIND_I4), pointer :: iptr(:,:) + real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:) + real(ESMF_KIND_RX), pointer :: rptr(:,:) + integer :: arbIndexCount + integer, allocatable :: arbIndexList(:,:) + type(ESMF_Field) :: nField, eField + type(ESMF_Field) :: tmpField + integer(ESMF_KIND_I4), allocatable :: nodeIds(:) + real(ESMF_KIND_R8), allocatable :: nodeCoords(:) + integer(ESMF_KIND_I4), allocatable :: nodeOwners(:) + integer(ESMF_KIND_I4), allocatable :: elemIds(:) + integer(ESMF_KIND_I4), allocatable :: elemTypes(:) + integer(ESMF_KIND_I4), allocatable :: elemConn(:) + ! + ! -------------------------------------------------------------------- / + ! Prep + ! + rc = ESMF_SUCCESS + if ( noActiveExpFields ) return + call ESMF_GridCompGet(gcomp, name=cname, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': entered CreateExpMesh', ESMF_LOGMSG_INFO) + ! + ! -------------------------------------------------------------------- / + ! Set flag to indicate that this processor has local native grid storage + ! + natGridIsLocal = iaproc .gt. 0 .and. iaproc .le. naproc + + ! 1. Setup + ! + ! 1.a Set grid pointers + ! + expGridID = 1 !TODO: only export from grid 1 + call w3setg ( expGridID, mdse, mdst ) + call w3setw ( expGridID, mdse, mdst ) + call w3seta ( expGridID, mdse, mdst ) + call w3seti ( expGridID, mdse, mdst ) + call w3seto ( expGridID, mdse, mdst ) + call wmsetm ( expGridID, mdse, mdst ) + natGridID = expGridID + nproc = naproc + ! + ! 1.b Set arraySpec, staggerLoc, and indexFlag for native fields. + ! NOTE: For unstructured meshes the native grid is a 1D array (NY=1) + ! + call ESMF_ArraySpecSet( natArraySpec1D, rank=1, & + typekind=ESMF_TYPEKIND_RX, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + natStaggerLoc = ESMF_STAGGERLOC_CENTER + natIndexFlag = ESMF_INDEX_DELOCAL + ! + ! -------------------------------------------------------------------- / + ! 2. Create ESMF mesh for export + ! + ! 2.a Create ESMF export mesh + ! + ! Allocate and fill the node id array. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(nodeIds(NX)) - do i = 1,NX - nodeIds(i)=i - enddo + allocate(nodeIds(NX)) + do i = 1,NX + nodeIds(i)=i + enddo #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: The global id's of the nodes resident on this processor -! ------------------------------------------------------------------- -! Allocate global node ids, including ghost nodes (npa=np+ng) - allocate(nodeIds(npa)) - do i = 1,npa - nodeIds(i)=iplg(i) - enddo - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeIds=', & -! ESMF_LOGMSG_INFO) -! do i = 1,npa -! write(msg,*) trim(cname)//': nodeIds(i)',i, & -! ' ',nodeIds(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: The global id's of the nodes resident on this processor + ! ------------------------------------------------------------------- + ! Allocate global node ids, including ghost nodes (npa=np+ng) + allocate(nodeIds(npa)) + do i = 1,npa + nodeIds(i)=iplg(i) + enddo + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeIds=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,npa + ! write(msg,*) trim(cname)//': nodeIds(i)',i, & + ! ' ',nodeIds(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeIds=', & -! ESMF_LOGMSG_INFO) -! do i = 1,NX -! write(msg,*) trim(cname)//': ',i, & -! ' ',nodeIds(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo - -! Allocate and fill node coordinate array. -! Since this is a 2D Mesh the size is 2x the -! number of nodes. + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeIds=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,NX + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',nodeIds(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo + + ! Allocate and fill node coordinate array. + ! Since this is a 2D Mesh the size is 2x the + ! number of nodes. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(nodeCoords(2*NX)) - do i = 1,NX - do j = 1,2 - pos=2*(i-1)+j - if (j == 1) then - nodeCoords(pos) = xgrd(1,i) - else - nodeCoords(pos) = ygrd(1,i) - endif - enddo - enddo + allocate(nodeCoords(2*NX)) + do i = 1,NX + do j = 1,2 + pos=2*(i-1)+j + if (j == 1) then + nodeCoords(pos) = xgrd(1,i) + else + nodeCoords(pos) = ygrd(1,i) + endif + enddo + enddo #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: Physical coordinates of the nodes -! ------------------------------------------------------------------- - allocate(nodeCoords(2*npa)) - do i = 1,npa - do j = 1,2 - pos=2*(i-1)+j - if ( j == 1) then - nodeCoords(pos) = xgrd(1,iplg(i)) - else - nodeCoords(pos) = ygrd(1,iplg(i)) - endif - enddo - enddo - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeCoords=', & -! ESMF_LOGMSG_INFO) -! do i = 1,(2*npa) -! write(msg,*) trim(cname)//': nodeCoords(i)',i, & -! ' ',nodeCoords(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: Physical coordinates of the nodes + ! ------------------------------------------------------------------- + allocate(nodeCoords(2*npa)) + do i = 1,npa + do j = 1,2 + pos=2*(i-1)+j + if ( j == 1) then + nodeCoords(pos) = xgrd(1,iplg(i)) + else + nodeCoords(pos) = ygrd(1,iplg(i)) + endif + enddo + enddo + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeCoords=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,(2*npa) + ! write(msg,*) trim(cname)//': nodeCoords(i)',i, & + ! ' ',nodeCoords(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeCoords=', & -! ESMF_LOGMSG_INFO) -! do i = 1,(2*NX) -! write(msg,*) trim(cname)//': ',i, & -! ' ',nodeCoords(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeCoords=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,(2*NX) + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',nodeCoords(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo -! Allocate and fill the node owner array. + ! Allocate and fill the node owner array. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(nodeOwners(NX)) - nodeOwners=0 ! TODO: For now, export everything via PET 0 + allocate(nodeOwners(NX)) + nodeOwners=0 ! TODO: For now, export everything via PET 0 #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: Processor that owns the node -! ------------------------------------------------------------------- - allocate(nodeOwners(npa)) - nodeOwners=nodes_global(iplg(1:npa))%domainID-1 - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeOwners=', & -! ESMF_LOGMSG_INFO) -! do i = 1,npa -! write(msg,*) trim(cname)//': nodeOwners(i)',i, & -! ' ',nodeOwners(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: Processor that owns the node + ! ------------------------------------------------------------------- + allocate(nodeOwners(npa)) + nodeOwners=nodes_global(iplg(1:npa))%domainID-1 + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeOwners=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,npa + ! write(msg,*) trim(cname)//': nodeOwners(i)',i, & + ! ' ',nodeOwners(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeOwners=', & -! ESMF_LOGMSG_INFO) -! do i = 1,NX -! write(msg,*) trim(cname)//': ',i, & -! ' ',nodeOwners(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeOwners=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,NX + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',nodeOwners(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo -! Allocate and fill the element id array. + ! Allocate and fill the element id array. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(elemIds(NTRI)) - do i = 1,NTRI - elemIds(i)=i - enddo + allocate(elemIds(NTRI)) + do i = 1,NTRI + elemIds(i)=i + enddo #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: The global id's of the elements resident on this processor -! ------------------------------------------------------------------- - allocate(elemIds(ne)) - do i = 1,ne - elemIds(i)=ielg(i) - enddo - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemIds=', & -! ESMF_LOGMSG_INFO) -! do i = 1,ne -! write(msg,*) trim(cname)//': elemIds(i)',i, & -! ' ',elemIds(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: The global id's of the elements resident on this processor + ! ------------------------------------------------------------------- + allocate(elemIds(ne)) + do i = 1,ne + elemIds(i)=ielg(i) + enddo + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemIds=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,ne + ! write(msg,*) trim(cname)//': elemIds(i)',i, & + ! ' ',elemIds(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemIds=', & -! ESMF_LOGMSG_INFO) -! do i = 1,NTRI -! write(msg,*) trim(cname)//': ',i, & -! ' ',elemIds(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemIds=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,NTRI + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',elemIds(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo -! Allocate and fill the element topology type array. + ! Allocate and fill the element topology type array. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(elemTypes(NTRI)) - do i = 1,NTRI - elemTypes(i)=ESMF_MESHELEMTYPE_TRI - enddo + allocate(elemTypes(NTRI)) + do i = 1,NTRI + elemTypes(i)=ESMF_MESHELEMTYPE_TRI + enddo #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: Topology of the given element (one of ESMF_MeshElement) -! ------------------------------------------------------------------- - allocate(elemTypes(ne)) - do i = 1,ne - elemTypes(i)=ESMF_MESHELEMTYPE_TRI - enddo - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemTypes=', & -! ESMF_LOGMSG_INFO) -! do i = 1,ne -! write(msg,*) trim(cname)//': elemTypes(i)',i, & -! ' ',elemTypes(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: Topology of the given element (one of ESMF_MeshElement) + ! ------------------------------------------------------------------- + allocate(elemTypes(ne)) + do i = 1,ne + elemTypes(i)=ESMF_MESHELEMTYPE_TRI + enddo + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemTypes=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,ne + ! write(msg,*) trim(cname)//': elemTypes(i)',i, & + ! ' ',elemTypes(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemTypes=', & -! ESMF_LOGMSG_INFO) -! do i = 1,NTRI -! write(msg,*) trim(cname)//': ',i, & -! ' ',elemTypes(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemTypes=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,NTRI + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',elemTypes(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo -! Allocate and fill the element connection type array. + ! Allocate and fill the element connection type array. #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif - allocate(elemConn(3*NTRI)) - do i = 1,NTRI - do j = 1,3 - pos=3*(i-1)+j - elemConn(pos)=TRIGP(j,i) - enddo - enddo + allocate(elemConn(3*NTRI)) + do i = 1,NTRI + do j = 1,3 + pos=3*(i-1)+j + elemConn(pos)=TRIGP(j,i) + enddo + enddo #ifdef W3_PDLIB - else -! ------------------------------------------------------------------- -! ESMF Definition: Connectivity table. The number of entries should -! be equal to the number of nodes in the given topology. The indices -! should be the local index (1 based) into the array of nodes that -! was declared with MeshAddNodes. -! ------------------------------------------------------------------- -! > INE is local element array. it stores the local node IDs -! > first index from 1 to 3. -! > second index from 1 to ne. - allocate(elemConn(3*ne)) - do i = 1,ne - do j = 1,3 - pos=3*(i-1)+j - elemConn(pos)=INE(j,i) - enddo - enddo - endif -! -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemConn=', & -! ESMF_LOGMSG_INFO) -! do i = 1,(3*ne) -! write(msg,*) trim(cname)//': elemConn(i)',i, & -! ' ',elemConn(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + else + ! ------------------------------------------------------------------- + ! ESMF Definition: Connectivity table. The number of entries should + ! be equal to the number of nodes in the given topology. The indices + ! should be the local index (1 based) into the array of nodes that + ! was declared with MeshAddNodes. + ! ------------------------------------------------------------------- + ! > INE is local element array. it stores the local node IDs + ! > first index from 1 to 3. + ! > second index from 1 to ne. + allocate(elemConn(3*ne)) + do i = 1,ne + do j = 1,3 + pos=3*(i-1)+j + elemConn(pos)=INE(j,i) + enddo + enddo + endif + ! + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemConn=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,(3*ne) + ! write(msg,*) trim(cname)//': elemConn(i)',i, & + ! ' ',elemConn(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif -! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemConn=', & -! ESMF_LOGMSG_INFO) -! do i = 1,(3*NTRI) -! write(msg,*) trim(cname)//': ',i, & -! ' ',elemConn(i) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemConn=', & + ! ESMF_LOGMSG_INFO) + ! do i = 1,(3*NTRI) + ! write(msg,*) trim(cname)//': ',i, & + ! ' ',elemConn(i) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo - expMesh = ESMF_MeshCreate( parametricDim=2,spatialDim=2, & + expMesh = ESMF_MeshCreate( parametricDim=2,spatialDim=2, & nodeIds=nodeIds, nodeCoords=nodeCoords, & nodeOwners=nodeOwners, elementIds=elemIds,& elementTypes=elemTypes, elementConn=elemConn, & rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - deallocate(nodeIds) - deallocate(nodeCoords) - deallocate(nodeOwners) - deallocate(elemIds) - deallocate(elemTypes) - deallocate(elemConn) -! -! Set flag to indicate that this processor has local export grid storage -! -!AW if (lpet == 0) then -!AW call ESMF_GridGet( expMesh, localDECount=ldecnt, rc=rc ) -!AW if (ESMF_LogFoundError(rc, PASSTHRU)) return -!AW expGridIsLocal = ldecnt.gt.0 -!AW endif - -! -! -------------------------------------------------------------------- / -! 3. Create ESMF grid with arbitrary domain decomposition to match -! the native domain decomposition of the non-excluded points -! Note that the native grid layout is dim1=Y, dim2=X -! Note that coordinates and mask are not needed since this -! grid is only used to define fields for a redist operation -! -! 3.a Set flag to indicate that this processor has local native grid storage -! - natGridIsLocal = iaproc .gt. 0 .and. iaproc .le. naproc + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + deallocate(nodeIds) + deallocate(nodeCoords) + deallocate(nodeOwners) + deallocate(elemIds) + deallocate(elemTypes) + deallocate(elemConn) + ! + ! Set flag to indicate that this processor has local export grid storage + ! + !AW if (lpet == 0) then + !AW call ESMF_GridGet( expMesh, localDECount=ldecnt, rc=rc ) + !AW if (ESMF_LogFoundError(rc, PASSTHRU)) return + !AW expGridIsLocal = ldecnt.gt.0 + !AW endif + + ! + ! -------------------------------------------------------------------- / + ! 3. Create ESMF grid with arbitrary domain decomposition to match + ! the native domain decomposition of the non-excluded points + ! Note that the native grid layout is dim1=Y, dim2=X + ! Note that coordinates and mask are not needed since this + ! grid is only used to define fields for a redist operation + ! + ! 3.a Set flag to indicate that this processor has local native grid storage + ! + natGridIsLocal = iaproc .gt. 0 .and. iaproc .le. naproc #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif -! -! 3.b Setup arbitrary sequence index list -! + ! + ! 3.b Setup arbitrary sequence index list + ! do ipass = 1,2 if (ipass.eq.2) then allocate (arbIndexList(arbIndexCount,2), stat=rc) @@ -4978,801 +4978,801 @@ subroutine CreateExpMesh ( gcomp, rc ) enddo endif enddo !ipass -! -! 3.c Create ESMF native grid -! + ! + ! 3.c Create ESMF native grid + ! natGrid = ESMF_GridCreateNoPeriDim( & - minIndex=(/ 1, 1/), & - maxIndex=(/ny,nx/), & - coordDep1=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & - coordDep2=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & - arbIndexCount=arbIndexCount, & - arbIndexList=arbIndexList, & - coordTypeKind=ESMF_TYPEKIND_RX, & - coordSys=ESMF_COORDSYS_SPH_DEG, & - name=trim(cname)//"_native_grid", rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 3.d Deallocate arbitrary sequence index list -! + minIndex=(/ 1, 1/), & + maxIndex=(/ny,nx/), & + coordDep1=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & + coordDep2=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), & + arbIndexCount=arbIndexCount, & + arbIndexList=arbIndexList, & + coordTypeKind=ESMF_TYPEKIND_RX, & + coordSys=ESMF_COORDSYS_SPH_DEG, & + name=trim(cname)//"_native_grid", rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! + ! 3.d Deallocate arbitrary sequence index list + ! deallocate (arbIndexList, stat=rc) if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return -! -! -------------------------------------------------------------------- / -! 4. Create route handle for redist between native grid domain -! decomposition and the export grid domain decomposition -! -! 4.a Create temporary fields -! + ! + ! -------------------------------------------------------------------- / + ! 4. Create route handle for redist between native grid domain + ! decomposition and the export grid domain decomposition + ! + ! 4.a Create temporary fields + ! nField = ESMF_FieldCreate( natGrid, natArraySpec1D, & - staggerLoc=natStaggerLoc, rc=rc ) + staggerLoc=natStaggerLoc, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return eField = ESMF_FieldCreate(expMesh, typekind=ESMF_TYPEKIND_RX, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 4.b Store route handle -! - call ESMF_FieldRedistStore( nField, eField, n2eRH, rc=rc ) + ! + ! 4.b Store route handle + ! + call ESMF_FieldRedistStore( nField, eField, n2eRH, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return -! -! 4.c Clean up -! + ! + ! 4.c Clean up + ! call ESMF_FieldDestroy( nField, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return call ESMF_FieldDestroy( eField, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return #ifdef W3_PDLIB - endif + endif #endif - call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, created expMesh', & - ESMF_LOGMSG_INFO) - - rc = ESMF_SUCCESS - if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & - ': leaving CreateExpMesh', ESMF_LOGMSG_INFO) -!/ -!/ End of CreateExpMesh ---------------------------------------------- / -!/ - end subroutine CreateExpMesh -!/ ------------------------------------------------------------------- / -!> -!> @brief Setup background blending mask field for an import field. -!> -!> @param bmskField Blending mask field -!> @param impField Import field -!> @param missingVal Missing value -!> @param rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, created expMesh', & + ESMF_LOGMSG_INFO) + + rc = ESMF_SUCCESS + if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// & + ': leaving CreateExpMesh', ESMF_LOGMSG_INFO) + !/ + !/ End of CreateExpMesh ---------------------------------------------- / + !/ + end subroutine CreateExpMesh + !/ ------------------------------------------------------------------- / + !> + !> @brief Setup background blending mask field for an import field. + !> + !> @param bmskField Blending mask field + !> @param impField Import field + !> @param missingVal Missing value + !> @param rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "SetupImpBmsk" - subroutine SetupImpBmsk( bmskField, impField, missingVal, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2017 : Origination. ( version 6.03 ) -!/ -! 1. Purpose : -! -! Setup background blending mask field for an import field -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! bmskField Type I/O blending mask field -! impField Type I import field -! missingVal Real I missing value -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_Field) :: bmskField - type(ESMF_Field) :: impField - real(ESMF_KIND_RX) :: missingVal - integer, optional :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - real(ESMF_KIND_RX), parameter :: zero = 0.0 - real(ESMF_KIND_RX), parameter :: half = 0.5 - real(ESMF_KIND_RX), parameter :: one = 1.0 - integer, parameter :: nsig = impHaloWidth-1 - integer, parameter :: niter = 10 - integer, parameter :: iter0 = 1-niter - integer, parameter :: lde = 0 - integer :: iter, i, j, ii, jj, k, l - integer :: elb(2), eub(2) - integer :: tlb(2), tub(2) - real(ESMF_KIND_RX), pointer :: mptr(:,:), dptr(:,:) - type(ESMF_Field) :: cmskField - real(ESMF_KIND_RX), pointer :: bmsk(:,:), cmsk(:,:) - real(ESMF_KIND_RX) :: bsum, wsum - real(ESMF_KIND_RX) :: wflt(-nsig:nsig,-nsig:nsig) - character(ESMF_MAXSTR) :: fnm + subroutine SetupImpBmsk( bmskField, impField, missingVal, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2017 : Origination. ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Setup background blending mask field for an import field + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! bmskField Type I/O blending mask field + ! impField Type I import field + ! missingVal Real I missing value + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_Field) :: bmskField + type(ESMF_Field) :: impField + real(ESMF_KIND_RX) :: missingVal + integer, optional :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + real(ESMF_KIND_RX), parameter :: zero = 0.0 + real(ESMF_KIND_RX), parameter :: half = 0.5 + real(ESMF_KIND_RX), parameter :: one = 1.0 + integer, parameter :: nsig = impHaloWidth-1 + integer, parameter :: niter = 10 + integer, parameter :: iter0 = 1-niter + integer, parameter :: lde = 0 + integer :: iter, i, j, ii, jj, k, l + integer :: elb(2), eub(2) + integer :: tlb(2), tub(2) + real(ESMF_KIND_RX), pointer :: mptr(:,:), dptr(:,:) + type(ESMF_Field) :: cmskField + real(ESMF_KIND_RX), pointer :: bmsk(:,:), cmsk(:,:) + real(ESMF_KIND_RX) :: bsum, wsum + real(ESMF_KIND_RX) :: wflt(-nsig:nsig,-nsig:nsig) + character(ESMF_MAXSTR) :: fnm #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETUPIMPBMSK) - integer :: timeSlice + integer :: timeSlice #endif -! -! -------------------------------------------------------------------- / -! Initialize filter -! - if (present(rc)) rc = ESMF_SUCCESS - - do l = -nsig,nsig - do k = -nsig,nsig - wflt(k,l) = exp( -half*( real(k,ESMF_KIND_RX)**2 & - + real(l,ESMF_KIND_RX)**2 ) ) + ! + ! -------------------------------------------------------------------- / + ! Initialize filter + ! + if (present(rc)) rc = ESMF_SUCCESS + + do l = -nsig,nsig + do k = -nsig,nsig + wflt(k,l) = exp( -half*( real(k,ESMF_KIND_RX)**2 & + + real(l,ESMF_KIND_RX)**2 ) ) + enddo + enddo + ! + ! -------------------------------------------------------------------- / + ! Set up fields and pointers + ! + call ESMF_FieldGet( impField, name=fnm, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + cmskField = ESMF_FieldCreate( impGrid, impArraySpec2D, & + totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & + staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + if ( impGridIsLocal ) then + call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=mptr, & + exclusiveLBound=elb, exclusiveUBound=eub, & + totalLBound=tlb, totalUBound=tub, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( impField, localDE=lde, farrayPtr=dptr, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( bmskField, localDE=lde, farrayPtr=bmsk, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( cmskField, localDE=lde, farrayPtr=cmsk, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! Create blending mask + ! + if ( impGridIsLocal ) then + do j = elb(2),eub(2) + do i = elb(1),eub(1) + if ( nint(dptr(i,j)).eq.nint(missingVal) ) then + bmsk(i,j) = zero + else + bmsk(i,j) = one + endif + cmsk(i,j) = bmsk(i,j) enddo enddo -! -! -------------------------------------------------------------------- / -! Set up fields and pointers -! - call ESMF_FieldGet( impField, name=fnm, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif +#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETUPIMPBMSK) + timeSlice = 1 + call ESMF_FieldWrite( bmskField, & + "wmesmfmd_setupimpbmsk_"//trim(fnm)//".nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return +#endif + + iter_loop: do iter = iter0,niter - cmskField = ESMF_FieldCreate( impGrid, impArraySpec2D, & - totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, & - staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, rc=rc ) + call ESMF_FieldHalo( bmskField, impHaloRH, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return if ( impGridIsLocal ) then - call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=mptr, & - exclusiveLBound=elb, exclusiveUBound=eub, & - totalLBound=tlb, totalUBound=tub, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( impField, localDE=lde, farrayPtr=dptr, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( bmskField, localDE=lde, farrayPtr=bmsk, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( cmskField, localDE=lde, farrayPtr=cmsk, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! Create blending mask -! - if ( impGridIsLocal ) then - do j = elb(2),eub(2) - do i = elb(1),eub(1) - if ( nint(dptr(i,j)).eq.nint(missingVal) ) then - bmsk(i,j) = zero + + j_loop: do j = elb(2),eub(2) + i_loop: do i = elb(1),eub(1) + if ( nint(mptr(i,j)).eq.maskValueLand ) cycle i_loop + if ( nint(dptr(i,j)).eq.nint(missingVal) ) cycle i_loop + + if (iter.le.0) then + + ! initialize blending zone to zero + l_loop0: do l = -1,1 + jj = j + l + if ( jj.lt.tlb(2).or.jj.gt.tub(2) ) cycle l_loop0 + k_loop0: do k = -1,1 + ii = i + k + if ( ii.lt.tlb(1).or.ii.gt.tub(1) ) cycle k_loop0 + if ( nint(mptr(ii,jj)).eq.maskValueLand ) cycle k_loop0 + if ( bmsk(ii,jj).eq.zero ) cmsk(i,j) = zero + enddo k_loop0 + enddo l_loop0 + else - bmsk(i,j) = one + + ! iterate filter over blending zone + bsum = zero + wsum = zero + l_loop: do l = -nsig,nsig + jj = j + l + if ( jj.lt.tlb(2).or.jj.gt.tub(2) ) cycle l_loop + k_loop: do k = -nsig,nsig + ii = i + k + if ( ii.lt.tlb(1).or.ii.gt.tub(1) ) cycle k_loop + if ( nint(mptr(ii,jj)).eq.maskValueLand ) cycle k_loop + bsum = bsum + wflt(k,l)*bmsk(ii,jj) + wsum = wsum + wflt(k,l) + enddo k_loop + enddo l_loop + if ( wsum.gt.zero ) cmsk(i,j) = bsum/wsum + endif - cmsk(i,j) = bmsk(i,j) + + enddo i_loop + enddo j_loop + + do j = elb(2),eub(2) + do i = elb(1),eub(1) + if ( nint(mptr(i,j)).eq.maskValueLand ) cycle + bmsk(i,j) = cmsk(i,j) enddo enddo + endif #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETUPIMPBMSK) - timeSlice = 1 + timeSlice = timeSlice + 1 call ESMF_FieldWrite( bmskField, & - "wmesmfmd_setupimpbmsk_"//trim(fnm)//".nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) + "wmesmfmd_setupimpbmsk_"//trim(fnm)//".nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return #endif - iter_loop: do iter = iter0,niter - - call ESMF_FieldHalo( bmskField, impHaloRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - if ( impGridIsLocal ) then - - j_loop: do j = elb(2),eub(2) - i_loop: do i = elb(1),eub(1) - if ( nint(mptr(i,j)).eq.maskValueLand ) cycle i_loop - if ( nint(dptr(i,j)).eq.nint(missingVal) ) cycle i_loop - - if (iter.le.0) then - - ! initialize blending zone to zero - l_loop0: do l = -1,1 - jj = j + l - if ( jj.lt.tlb(2).or.jj.gt.tub(2) ) cycle l_loop0 - k_loop0: do k = -1,1 - ii = i + k - if ( ii.lt.tlb(1).or.ii.gt.tub(1) ) cycle k_loop0 - if ( nint(mptr(ii,jj)).eq.maskValueLand ) cycle k_loop0 - if ( bmsk(ii,jj).eq.zero ) cmsk(i,j) = zero - enddo k_loop0 - enddo l_loop0 - - else - - ! iterate filter over blending zone - bsum = zero - wsum = zero - l_loop: do l = -nsig,nsig - jj = j + l - if ( jj.lt.tlb(2).or.jj.gt.tub(2) ) cycle l_loop - k_loop: do k = -nsig,nsig - ii = i + k - if ( ii.lt.tlb(1).or.ii.gt.tub(1) ) cycle k_loop - if ( nint(mptr(ii,jj)).eq.maskValueLand ) cycle k_loop - bsum = bsum + wflt(k,l)*bmsk(ii,jj) - wsum = wsum + wflt(k,l) - enddo k_loop - enddo l_loop - if ( wsum.gt.zero ) cmsk(i,j) = bsum/wsum - - endif - - enddo i_loop - enddo j_loop - - do j = elb(2),eub(2) - do i = elb(1),eub(1) - if ( nint(mptr(i,j)).eq.maskValueLand ) cycle - bmsk(i,j) = cmsk(i,j) - enddo - enddo - - endif -#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETUPIMPBMSK) - timeSlice = timeSlice + 1 - call ESMF_FieldWrite( bmskField, & - "wmesmfmd_setupimpbmsk_"//trim(fnm)//".nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -#endif - - enddo iter_loop -! -! -------------------------------------------------------------------- / -! Clean up -! - call ESMF_FieldDestroy( cmskField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/ -!/ End of SetupImpBmsk ----------------------------------------------- / -!/ - end subroutine SetupImpBmsk -!/ ------------------------------------------------------------------- / -!> -!> @brief Blend import field with background field. -!> -!> @param[inout] impField Import field -!> @param[in] mbgField Import background field -!> @param[in] bmskField Blending mask field -!> @param[inout] rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + enddo iter_loop + ! + ! -------------------------------------------------------------------- / + ! Clean up + ! + call ESMF_FieldDestroy( cmskField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + !/ + !/ End of SetupImpBmsk ----------------------------------------------- / + !/ + end subroutine SetupImpBmsk + !/ ------------------------------------------------------------------- / + !> + !> @brief Blend import field with background field. + !> + !> @param[inout] impField Import field + !> @param[in] mbgField Import background field + !> @param[in] bmskField Blending mask field + !> @param[inout] rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "BlendImpField" - subroutine BlendImpField( impField, mbgField, bmskField, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2017 : Origination. ( version 6.03 ) -!/ -! 1. Purpose : -! -! Blend import field with background field -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! impField Type I/O import field -! mbgField Type I import background field -! bmskField Type I blending mask field -! rc Int I/O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_Field), intent(inout) :: impField - type(ESMF_Field), intent(in) :: mbgField - type(ESMF_Field), intent(in) :: bmskField - integer, optional, intent(inout) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - real(ESMF_KIND_RX), parameter :: one = 1.0 - integer, parameter :: lde = 0 - integer :: i, j - integer :: elb(2), eub(2) - real(ESMF_KIND_RX), pointer :: mptr(:,:), dptr(:,:), sptr(:,:) - real(ESMF_KIND_RX), pointer :: bmsk(:,:) -! -! -------------------------------------------------------------------- / -! Get array pointers and bounds -! - if (present(rc)) rc = ESMF_SUCCESS - - if ( impGridIsLocal ) then - call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=mptr, & - exclusiveLBound=elb, exclusiveUBound=eub, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( impField, localDE=lde, farrayPtr=dptr, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( mbgField, localDE=lde, farrayPtr=sptr, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( bmskField, localDE=lde, farrayPtr=bmsk, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! Blend Fields -! - if ( impGridIsLocal ) then - do j = elb(2),eub(2) - do i = elb(1),eub(1) - if ( nint(mptr(i,j)).eq.maskValueLand ) cycle - dptr(i,j) = bmsk(i,j)*dptr(i,j) + (one-bmsk(i,j))*sptr(i,j) - enddo + subroutine BlendImpField( impField, mbgField, bmskField, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2017 : Origination. ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Blend import field with background field + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! impField Type I/O import field + ! mbgField Type I import background field + ! bmskField Type I blending mask field + ! rc Int I/O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_Field), intent(inout) :: impField + type(ESMF_Field), intent(in) :: mbgField + type(ESMF_Field), intent(in) :: bmskField + integer, optional, intent(inout) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + real(ESMF_KIND_RX), parameter :: one = 1.0 + integer, parameter :: lde = 0 + integer :: i, j + integer :: elb(2), eub(2) + real(ESMF_KIND_RX), pointer :: mptr(:,:), dptr(:,:), sptr(:,:) + real(ESMF_KIND_RX), pointer :: bmsk(:,:) + ! + ! -------------------------------------------------------------------- / + ! Get array pointers and bounds + ! + if (present(rc)) rc = ESMF_SUCCESS + + if ( impGridIsLocal ) then + call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=mptr, & + exclusiveLBound=elb, exclusiveUBound=eub, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( impField, localDE=lde, farrayPtr=dptr, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( mbgField, localDE=lde, farrayPtr=sptr, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( bmskField, localDE=lde, farrayPtr=bmsk, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! Blend Fields + ! + if ( impGridIsLocal ) then + do j = elb(2),eub(2) + do i = elb(1),eub(1) + if ( nint(mptr(i,j)).eq.maskValueLand ) cycle + dptr(i,j) = bmsk(i,j)*dptr(i,j) + (one-bmsk(i,j))*sptr(i,j) enddo - endif -!/ -!/ End of BlendImpField ---------------------------------------------- / -!/ - end subroutine BlendImpField -!/ ------------------------------------------------------------------- / -!> -!> @brief Setup merging mask field for an import field for the cases -!> that model domains does not overlap completely. -!> -!> @param mmskField Merging mask field -!> @param impField Import field -!> @param fillVal Fill value -!> @param mskCreated Mask is created or not -!> @param rc Return code -!> -!> @author U. Turuncoglu @date 18-May-2021 -!> + enddo + endif + !/ + !/ End of BlendImpField ---------------------------------------------- / + !/ + end subroutine BlendImpField + !/ ------------------------------------------------------------------- / + !> + !> @brief Setup merging mask field for an import field for the cases + !> that model domains does not overlap completely. + !> + !> @param mmskField Merging mask field + !> @param impField Import field + !> @param fillVal Fill value + !> @param mskCreated Mask is created or not + !> @param rc Return code + !> + !> @author U. Turuncoglu @date 18-May-2021 + !> #undef METHOD #define METHOD "SetupImpMmsk" - subroutine SetupImpMmsk( mmskField, impField, fillVal, mskCreated, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | U. Turuncoglu | -!/ | FORTRAN 90 | -!/ | Last update : 18-May-2021 | -!/ +-----------------------------------+ -!/ -!/ 18-May-2021 : Origination. ( version 7.13 ) -!/ -! 1. Purpose : -! -! Setup merging mask field for an import field for the cases that -! model domains does not overlap completely -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! mmskField Type I/O merging mask field -! impField Type I import field -! fillVal Real I fill value -! mskCreated Log. I/O mask is created or not -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_Field) :: mmskField - type(ESMF_Field) :: impField - real(ESMF_KIND_RX) :: fillVal - logical :: mskCreated - integer, optional :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - integer, parameter :: lde = 0 - integer :: i, j - integer :: elb(2), eub(2) - integer :: tlb(2), tub(2) - real(ESMF_KIND_RX), pointer :: mptr(:,:), dptr(:,:) - real(ESMF_KIND_RX), pointer :: mmsk(:,:) - character(ESMF_MAXSTR) :: fnm + subroutine SetupImpMmsk( mmskField, impField, fillVal, mskCreated, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | U. Turuncoglu | + !/ | FORTRAN 90 | + !/ | Last update : 18-May-2021 | + !/ +-----------------------------------+ + !/ + !/ 18-May-2021 : Origination. ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Setup merging mask field for an import field for the cases that + ! model domains does not overlap completely + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! mmskField Type I/O merging mask field + ! impField Type I import field + ! fillVal Real I fill value + ! mskCreated Log. I/O mask is created or not + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_Field) :: mmskField + type(ESMF_Field) :: impField + real(ESMF_KIND_RX) :: fillVal + logical :: mskCreated + integer, optional :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + integer, parameter :: lde = 0 + integer :: i, j + integer :: elb(2), eub(2) + integer :: tlb(2), tub(2) + real(ESMF_KIND_RX), pointer :: mptr(:,:), dptr(:,:) + real(ESMF_KIND_RX), pointer :: mmsk(:,:) + character(ESMF_MAXSTR) :: fnm #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETUPIMPMMSK) - integer, save :: timeSlice = 1 + integer, save :: timeSlice = 1 #endif -! -! -------------------------------------------------------------------- / -! Check mask is created or not -! - if ( mskCreated ) return -! -! -------------------------------------------------------------------- / -! Set up fields and pointers -! - - call ESMF_FieldGet( impField, name=fnm, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - if ( impGridIsLocal ) then - call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=mptr, & - exclusiveLBound=elb, exclusiveUBound=eub, & - totalLBound=tlb, totalUBound=tub, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( impField, localDE=lde, farrayPtr=dptr, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( mmskField, localDE=lde, farrayPtr=mmsk, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - endif -! -! -------------------------------------------------------------------- / -! Create merging mask -! - if ( impGridIsLocal ) then - do j = elb(2),eub(2) - do i = elb(1),eub(1) - mmsk(i,j) = 0.0 - if (dptr(i,j).lt.fillVal) then - mmsk(i,j) = 1.0 - end if - enddo + ! + ! -------------------------------------------------------------------- / + ! Check mask is created or not + ! + if ( mskCreated ) return + ! + ! -------------------------------------------------------------------- / + ! Set up fields and pointers + ! + + call ESMF_FieldGet( impField, name=fnm, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + if ( impGridIsLocal ) then + call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=mptr, & + exclusiveLBound=elb, exclusiveUBound=eub, & + totalLBound=tlb, totalUBound=tub, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( impField, localDE=lde, farrayPtr=dptr, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( mmskField, localDE=lde, farrayPtr=mmsk, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif + ! + ! -------------------------------------------------------------------- / + ! Create merging mask + ! + if ( impGridIsLocal ) then + do j = elb(2),eub(2) + do i = elb(1),eub(1) + mmsk(i,j) = 0.0 + if (dptr(i,j).lt.fillVal) then + mmsk(i,j) = 1.0 + end if enddo - endif -! -! -------------------------------------------------------------------- / -! Set mask created flag -! - mskCreated = .true. + enddo + endif + ! + ! -------------------------------------------------------------------- / + ! Set mask created flag + ! + mskCreated = .true. #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETUPIMPMMSK) - call ESMF_FieldWrite( mmskField, & - "wmesmfmd_setupimpmmsk_"//trim(fnm)//".nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - timeSlice = timeSlice+1 + call ESMF_FieldWrite( mmskField, & + "wmesmfmd_setupimpmmsk_"//trim(fnm)//".nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + timeSlice = timeSlice+1 #endif -!/ -!/ End of SetupImpMmsk ----------------------------------------------- / -!/ - end subroutine SetupImpMmsk -!/ ------------------------------------------------------------------- / -!> -!> @brief Fill ESMF field. -!> -!> @param field -!> @param fillVal -!> @param rc -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + !/ + !/ End of SetupImpMmsk ----------------------------------------------- / + !/ + end subroutine SetupImpMmsk + !/ ------------------------------------------------------------------- / + !> + !> @brief Fill ESMF field. + !> + !> @param field + !> @param fillVal + !> @param rc + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "FieldFill" - subroutine FieldFill(field, fillVal, rc) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ 09-Aug-2017 : Remove mask parameter. ( version 6.03 ) -!/ -! 1. Purpose : -! -! Fill ESMF Field -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! field Type I/O ESMF field -! fillVal Real I fill value -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_Field) :: field - real(ESMF_KIND_RX) :: fillVal - integer, optional :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - integer :: ldecnt, lde, i, j, k - integer :: rank - integer :: lb1(1), ub1(1) - integer :: lb2(2), ub2(2) - integer :: lb3(3), ub3(3) - real(ESMF_KIND_RX), pointer :: dptr1(:) - real(ESMF_KIND_RX), pointer :: dptr2(:,:) - real(ESMF_KIND_RX), pointer :: dptr3(:,:,:) - integer, parameter :: iwt=10 - real(8) :: wstime, wftime -! -! -------------------------------------------------------------------- / -! Fill Field -! - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_VMWtime(wstime) - - call ESMF_FieldGet(field, localDECount=ldecnt, rank=rank, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out - if (rank.ne.1.and.rank.ne.2.and.rank.ne.3) then - call ESMF_LogSetError(ESMF_FAILURE, rcToReturn=rc, & - msg='FieldFill: rank must be 1, 2 or 3') - return ! bail out + subroutine FieldFill(field, fillVal, rc) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ 09-Aug-2017 : Remove mask parameter. ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Fill ESMF Field + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! field Type I/O ESMF field + ! fillVal Real I fill value + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_Field) :: field + real(ESMF_KIND_RX) :: fillVal + integer, optional :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + integer :: ldecnt, lde, i, j, k + integer :: rank + integer :: lb1(1), ub1(1) + integer :: lb2(2), ub2(2) + integer :: lb3(3), ub3(3) + real(ESMF_KIND_RX), pointer :: dptr1(:) + real(ESMF_KIND_RX), pointer :: dptr2(:,:) + real(ESMF_KIND_RX), pointer :: dptr3(:,:,:) + integer, parameter :: iwt=10 + real(8) :: wstime, wftime + ! + ! -------------------------------------------------------------------- / + ! Fill Field + ! + if (present(rc)) rc = ESMF_SUCCESS + + call ESMF_VMWtime(wstime) + + call ESMF_FieldGet(field, localDECount=ldecnt, rank=rank, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out + if (rank.ne.1.and.rank.ne.2.and.rank.ne.3) then + call ESMF_LogSetError(ESMF_FAILURE, rcToReturn=rc, & + msg='FieldFill: rank must be 1, 2 or 3') + return ! bail out + endif + + do lde=0,ldecnt-1 + + if (rank.eq.1) then + call ESMF_FieldGet(field, localDE=lde, farrayPtr=dptr1, & + exclusiveLBound=lb1, exclusiveUBound=ub1, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out + elseif (rank.eq.2) then + call ESMF_FieldGet(field, localDE=lde, farrayPtr=dptr2, & + exclusiveLBound=lb2, exclusiveUBound=ub2, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out + else + call ESMF_FieldGet(field, localDE=lde, farrayPtr=dptr3, & + exclusiveLBound=lb3, exclusiveUBound=ub3, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out endif - do lde=0,ldecnt-1 - - if (rank.eq.1) then - call ESMF_FieldGet(field, localDE=lde, farrayPtr=dptr1, & - exclusiveLBound=lb1, exclusiveUBound=ub1, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out - elseif (rank.eq.2) then - call ESMF_FieldGet(field, localDE=lde, farrayPtr=dptr2, & - exclusiveLBound=lb2, exclusiveUBound=ub2, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out - else - call ESMF_FieldGet(field, localDE=lde, farrayPtr=dptr3, & - exclusiveLBound=lb3, exclusiveUBound=ub3, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out - endif - - if (rank.eq.1) then - dptr1(lb1(1):ub1(1)) = fillVal - elseif (rank.eq.2) then - dptr2(lb2(1):ub2(1),lb2(2):ub2(2)) = fillVal - else - dptr3(lb3(1):ub3(1),lb3(2):ub3(2),lb3(3):ub3(3)) = fillVal - endif - - enddo + if (rank.eq.1) then + dptr1(lb1(1):ub1(1)) = fillVal + elseif (rank.eq.2) then + dptr2(lb2(1):ub2(1),lb2(2):ub2(2)) = fillVal + else + dptr3(lb3(1):ub3(1),lb3(2):ub3(2),lb3(3):ub3(3)) = fillVal + endif - call ESMF_VMWtime(wftime) - wtime(iwt) = wtime(iwt) + wftime - wstime - wtcnt(iwt) = wtcnt(iwt) + 1 -!/ -!/ End of FieldFill ------------------------------------------------- / -!/ - end subroutine FieldFill -!/ ------------------------------------------------------------------- / -!> -!> @brief All gather of ESMF field. -!> -!> @param field ESMF field -!> @param n1 Dimension of output array -!> @param n2 Dimension of output array -!> @param fout Global output array -!> @param rc Return code -!> -!> @author T. J. Campbell -!> @author A. J. van der Westhuysen -!> @date 20-Jan-2017 -!> + enddo + + call ESMF_VMWtime(wftime) + wtime(iwt) = wtime(iwt) + wftime - wstime + wtcnt(iwt) = wtcnt(iwt) + 1 + !/ + !/ End of FieldFill ------------------------------------------------- / + !/ + end subroutine FieldFill + !/ ------------------------------------------------------------------- / + !> + !> @brief All gather of ESMF field. + !> + !> @param field ESMF field + !> @param n1 Dimension of output array + !> @param n2 Dimension of output array + !> @param fout Global output array + !> @param rc Return code + !> + !> @author T. J. Campbell + !> @author A. J. van der Westhuysen + !> @date 20-Jan-2017 + !> #undef METHOD #define METHOD "FieldGather" - subroutine FieldGather(field, n1, n2, fout, rc) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | A. J. van der Westhuysen | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ 27-Feb-2018 : Modification for use with UNGTYPE ( version 6.06 ) -!/ -! 1. Purpose : -! -! All gather of ESMF field -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! field Type I/O ESMF field -! n1,n2 Int I Dimensions of output array -! fout R.A. O global output array -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + subroutine FieldGather(field, n1, n2, fout, rc) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | A. J. van der Westhuysen | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ 27-Feb-2018 : Modification for use with UNGTYPE ( version 6.06 ) + !/ + ! 1. Purpose : + ! + ! All gather of ESMF field + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! field Type I/O ESMF field + ! n1,n2 Int I Dimensions of output array + ! fout R.A. O global output array + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_PDLIB - use yowNodepool, only: np, iplg - use yowrankModule, only: rank + use yowNodepool, only: np, iplg + use yowrankModule, only: rank #endif -!/ - implicit none -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - type(ESMF_Field) :: field - integer :: n1, n2 - real :: fout(n1,n2) - integer, optional :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - character(500) :: msg - integer :: i, j, k, ir, ip, count - real(ESMF_KIND_RX) :: floc(n1,n2) - real(ESMF_KIND_RX) :: floc1d(n1), floc1dary(n1*n2) + !/ + implicit none + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + type(ESMF_Field) :: field + integer :: n1, n2 + real :: fout(n1,n2) + integer, optional :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + character(500) :: msg + integer :: i, j, k, ir, ip, count + real(ESMF_KIND_RX) :: floc(n1,n2) + real(ESMF_KIND_RX) :: floc1d(n1), floc1dary(n1*n2) #ifdef W3_PDLIB - real(ESMF_KIND_R8), pointer :: fldptr(:) + real(ESMF_KIND_R8), pointer :: fldptr(:) #endif - integer, parameter :: iwt=9 - real(8) :: wstime, wftime -! -! -------------------------------------------------------------------- / -! Gather Field -! - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_VMWtime(wstime) - - if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then - count = n1 * n2 - floc = 0. - floc1dary = 0. - call ESMF_FieldGather( field, floc, rootPet=0, vm=vm, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - do j=1,n2 - do i=1,n1 - floc1dary(i+(j-1)*n1) = floc(i,j) - enddo + integer, parameter :: iwt=9 + real(8) :: wstime, wftime + ! + ! -------------------------------------------------------------------- / + ! Gather Field + ! + if (present(rc)) rc = ESMF_SUCCESS + + call ESMF_VMWtime(wstime) + + if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then + count = n1 * n2 + floc = 0. + floc1dary = 0. + call ESMF_FieldGather( field, floc, rootPet=0, vm=vm, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + do j=1,n2 + do i=1,n1 + floc1dary(i+(j-1)*n1) = floc(i,j) enddo - call ESMF_VMbroadcast( vm, bcstData=floc1dary, count=count, rootPet=0, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - do j=1,n2 - do i=1,n1 - fout(i,j) = floc1dary(i+(j-1)*n1) - enddo - enddo - elseif (GTYPE.eq.UNGTYPE) then - count = n1 - floc1d = 0. - call ESMF_FieldGather( field, floc1d, rootPet=0, vm=vm, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_VMbroadcast( vm, bcstData=floc1d, count=count, rootPet=0, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo + call ESMF_VMbroadcast( vm, bcstData=floc1dary, count=count, rootPet=0, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + do j=1,n2 + do i=1,n1 + fout(i,j) = floc1dary(i+(j-1)*n1) + enddo + enddo + elseif (GTYPE.eq.UNGTYPE) then + count = n1 + floc1d = 0. + call ESMF_FieldGather( field, floc1d, rootPet=0, vm=vm, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_VMbroadcast( vm, bcstData=floc1d, count=count, rootPet=0, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #ifdef W3_PDLIB if ( LPDLIB .EQV. .FALSE. ) then #endif @@ -5781,1272 +5781,1272 @@ subroutine FieldGather(field, n1, n2, fout, rc) enddo #ifdef W3_PDLIB else - count = 0 - do ir = 1, npet - do ip = 1, rank(ir)%np - count = count+1 - fout(rank(ir)%iplg(ip),1) = floc1d(count) -! write(msg,*) trim(cname)//': count,ir,ip =',count, & -! ir,ip -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - enddo - enddo + count = 0 + do ir = 1, npet + do ip = 1, rank(ir)%np + count = count+1 + fout(rank(ir)%iplg(ip),1) = floc1d(count) + ! write(msg,*) trim(cname)//': count,ir,ip =',count, & + ! ir,ip + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + enddo + enddo endif #endif #ifdef W3_PDLIB -! call ESMF_LogWrite(trim(cname)//': In FieldGather, fout(k,1)=', & -! ESMF_LOGMSG_INFO) -! do k = 1, n1 -! write(msg,*) trim(cname)//': fout(k,1) =',k, & -! ' ',fout(k,1) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -! enddo + ! call ESMF_LogWrite(trim(cname)//': In FieldGather, fout(k,1)=', & + ! ESMF_LOGMSG_INFO) + ! do k = 1, n1 + ! write(msg,*) trim(cname)//': fout(k,1) =',k, & + ! ' ',fout(k,1) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! enddo #endif - endif - - call ESMF_VMWtime(wftime) - wtime(iwt) = wtime(iwt) + wftime - wstime - wtcnt(iwt) = wtcnt(iwt) + 1 - -!/ -!/ End of FieldGather ------------------------------------------------ / -!/ - end subroutine FieldGather -!/ ------------------------------------------------------------------- / -!> -!> @brief Return index associated with field name. -!> -!> @param[inout] fnameList Array of field names -!> @param[inout] fname Field name -!> @param[inout] rc Return code -!> @returns indx Returned index of fname -!> -!> @author T. J. Campbell @date 20-Jan-2017 -!> + endif + + call ESMF_VMWtime(wftime) + wtime(iwt) = wtime(iwt) + wftime - wstime + wtcnt(iwt) = wtcnt(iwt) + 1 + + !/ + !/ End of FieldGather ------------------------------------------------ / + !/ + end subroutine FieldGather + !/ ------------------------------------------------------------------- / + !> + !> @brief Return index associated with field name. + !> + !> @param[inout] fnameList Array of field names + !> @param[inout] fname Field name + !> @param[inout] rc Return code + !> @returns indx Returned index of fname + !> + !> @author T. J. Campbell @date 20-Jan-2017 + !> #undef METHOD #define METHOD "FieldIndex" - function FieldIndex ( fnameList, fname, rc ) result (indx) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Return index associated with field name -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! fnameList StrA I Array of field names -! fname Str I Field name -! rc Int. O Return code -! indx Int I Returned index of fname -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - character (len=*) :: fnameList(:) - character (len=*) :: fname - integer :: rc - integer :: indx -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - integer :: i, check -! -! -------------------------------------------------------------------- / -! Find name in fnameList that matches fname -! - check = lbound(fnameList,1) - 1 - indx = check - do i = lbound(fnameList,1),ubound(fnameList,1) - if ( trim(fnameList(i)).eq.trim(fname) ) then - indx = i - exit - endif - enddo - if ( indx.eq.check ) then - call ESMF_LogSetError(ESMF_FAILURE, rcToReturn=rc, & - msg='FieldIndex: input name ('//fname//') not in list') + function FieldIndex ( fnameList, fname, rc ) result (indx) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Return index associated with field name + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! fnameList StrA I Array of field names + ! fname Str I Field name + ! rc Int. O Return code + ! indx Int I Returned index of fname + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + character (len=*) :: fnameList(:) + character (len=*) :: fname + integer :: rc + integer :: indx + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + integer :: i, check + ! + ! -------------------------------------------------------------------- / + ! Find name in fnameList that matches fname + ! + check = lbound(fnameList,1) - 1 + indx = check + do i = lbound(fnameList,1),ubound(fnameList,1) + if ( trim(fnameList(i)).eq.trim(fname) ) then + indx = i + exit endif -!/ -!/ End of FieldIndex ------------------------------------------------- / -!/ - end function FieldIndex -!/ ------------------------------------------------------------------- / -!> -!> @brief Print wallclock timers to ESMF log file. -!> -!> @param cname -!> @param wtnam -!> @param wtcnt -!> @param wtime -!> -!> @author T. J. Campbell @date 20-Jan-2017 -!> + enddo + if ( indx.eq.check ) then + call ESMF_LogSetError(ESMF_FAILURE, rcToReturn=rc, & + msg='FieldIndex: input name ('//fname//') not in list') + endif + !/ + !/ End of FieldIndex ------------------------------------------------- / + !/ + end function FieldIndex + !/ ------------------------------------------------------------------- / + !> + !> @brief Print wallclock timers to ESMF log file. + !> + !> @param cname + !> @param wtnam + !> @param wtcnt + !> @param wtime + !> + !> @author T. J. Campbell @date 20-Jan-2017 + !> #undef METHOD #define METHOD "PrintTimers" - subroutine PrintTimers ( cname, wtnam, wtcnt, wtime ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 20-Jan-2017 : Origination. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Print wallclock timers to ESMF log file -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! cname Str I Name of component -! wtnam Str I Timer names -! wtcnt Int I Timer counts -! wtime R8 I Timers -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - character(*) :: cname - character(*) :: wtnam(:) - integer :: wtcnt(:) - real(8) :: wtime(:) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(128) :: msg - integer :: k -! -! -------------------------------------------------------------------- / -! Print timers to ESMF log file -! - write(msg,1) trim(cname),"timer","count","time" + subroutine PrintTimers ( cname, wtnam, wtcnt, wtime ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 20-Jan-2017 : Origination. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Print wallclock timers to ESMF log file + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! cname Str I Name of component + ! wtnam Str I Timer names + ! wtcnt Int I Timer counts + ! wtime R8 I Timers + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + character(*) :: cname + character(*) :: wtnam(:) + integer :: wtcnt(:) + real(8) :: wtime(:) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(128) :: msg + integer :: k + ! + ! -------------------------------------------------------------------- / + ! Print timers to ESMF log file + ! + write(msg,1) trim(cname),"timer","count","time" + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + do k=lbound(wtcnt,1),ubound(wtcnt,1) + write(msg,2) trim(cname),trim(wtnam(k)),wtcnt(k),wtime(k) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - do k=lbound(wtcnt,1),ubound(wtcnt,1) - write(msg,2) trim(cname),trim(wtnam(k)),wtcnt(k),wtime(k) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) - enddo -! -! -------------------------------------------------------------------- / -! Formats -! -1 format(a,': wtime: ',a20,a10,a14) -2 format(a,': wtime: ',a20,i10,e14.6) -!/ -!/ End of PrintTimers ------------------------------------------------ / -!/ - end subroutine PrintTimers -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate a 2D processor layout -!> -!> @param[in] nx Grid dimension x -!> @param[in] ny Grid dimension y -!> @param[in] nproc Total processor count -!> @param[in] npmin Min number of grid points per tile per direction -!> @param[in] adjust Enable/disable adjusting proc count downward -!> @param[out] nxproc Processor count in x-direction -!> @param[out] nyproc Processor count in y-direction -!> @param[inout] rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + enddo + ! + ! -------------------------------------------------------------------- / + ! Formats + ! +1 format(a,': wtime: ',a20,a10,a14) +2 format(a,': wtime: ',a20,i10,e14.6) + !/ + !/ End of PrintTimers ------------------------------------------------ / + !/ + end subroutine PrintTimers + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate a 2D processor layout + !> + !> @param[in] nx Grid dimension x + !> @param[in] ny Grid dimension y + !> @param[in] nproc Total processor count + !> @param[in] npmin Min number of grid points per tile per direction + !> @param[in] adjust Enable/disable adjusting proc count downward + !> @param[out] nxproc Processor count in x-direction + !> @param[out] nyproc Processor count in y-direction + !> @param[inout] rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "CalcDecomp" - subroutine CalcDecomp ( nx, ny, nproc, npmin, adjust, nxproc, nyproc, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2017 : Origination. ( version 6.03 ) -!/ -! 1. Purpose : -! -! Calculate a 2D processor layout -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! nx,ny Int I Grid dimensions -! nproc Int I Total processor count -! npmin Int I Min number of grid points per tile per direction -! adjust Log I Enable/disable adjusting proc count downward -! nxproc Int O Processor count in x-direction -! nyproc Int O Processor count in y-direction -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - integer, intent(in) :: nx, ny - integer, intent(in) :: nproc - integer, intent(in) :: npmin - logical, intent(in) :: adjust - integer, intent(out) :: nxproc - integer, intent(out) :: nyproc - integer, intent(inout) :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - integer, parameter :: k = 4 - integer :: mproc, n, nfac, irp - real(k) :: gr, rp, pr, diff, npx, npy - character(256) :: msg -! -! -------------------------------------------------------------------- / -! - rc = ESMF_SUCCESS - + subroutine CalcDecomp ( nx, ny, nproc, npmin, adjust, nxproc, nyproc, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2017 : Origination. ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Calculate a 2D processor layout + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! nx,ny Int I Grid dimensions + ! nproc Int I Total processor count + ! npmin Int I Min number of grid points per tile per direction + ! adjust Log I Enable/disable adjusting proc count downward + ! nxproc Int O Processor count in x-direction + ! nyproc Int O Processor count in y-direction + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + integer, intent(in) :: nx, ny + integer, intent(in) :: nproc + integer, intent(in) :: npmin + logical, intent(in) :: adjust + integer, intent(out) :: nxproc + integer, intent(out) :: nyproc + integer, intent(inout) :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + integer, parameter :: k = 4 + integer :: mproc, n, nfac, irp + real(k) :: gr, rp, pr, diff, npx, npy + character(256) :: msg + ! + ! -------------------------------------------------------------------- / + ! + rc = ESMF_SUCCESS + + if ( nx.gt.ny ) then + gr = real(nx,k)/real(ny,k) + else + gr = real(ny,k)/real(nx,k) + endif + + mproc = nproc + mproc_loop: do + + irp = int(sqrt(real(mproc,k))) + diff = huge(gr) + nfac = mproc + do n = irp,mproc + if ( mod(mproc,n).ne.0 ) cycle + pr = real(n**2,k)/real(mproc,k) + if ( abs(gr-pr) < diff ) then + diff = abs(gr-pr) + nfac = n + endif + enddo if ( nx.gt.ny ) then - gr = real(nx,k)/real(ny,k) + nxproc = nfac + nyproc = mproc/nfac else - gr = real(ny,k)/real(nx,k) + nxproc = mproc/nfac + nyproc = nfac endif - mproc = nproc - mproc_loop: do - - irp = int(sqrt(real(mproc,k))) - diff = huge(gr) - nfac = mproc - do n = irp,mproc - if ( mod(mproc,n).ne.0 ) cycle - pr = real(n**2,k)/real(mproc,k) - if ( abs(gr-pr) < diff ) then - diff = abs(gr-pr) - nfac = n - endif - enddo - if ( nx.gt.ny ) then - nxproc = nfac - nyproc = mproc/nfac - else - nxproc = mproc/nfac - nyproc = nfac - endif + npx = nx/real(nxproc,k) + npy = ny/real(nyproc,k) + if (.not.adjust) exit mproc_loop - npx = nx/real(nxproc,k) - npy = ny/real(nyproc,k) - if (.not.adjust) exit mproc_loop - - if ( npx.ge.npmin .and. npy.ge.npmin ) then - exit mproc_loop + if ( npx.ge.npmin .and. npy.ge.npmin ) then + exit mproc_loop + else + if ( mproc.gt.1 ) then + mproc = mproc - 1 else - if ( mproc.gt.1 ) then - mproc = mproc - 1 - else - exit mproc_loop - endif + exit mproc_loop endif - - enddo mproc_loop - - if ( npx.lt.npmin .or. npy.lt.npmin ) then - write(msg,'(a,7i6)') 'proc count is too large for grid size:', & - nx,ny,npmin,nproc,mproc,nxproc,nyproc - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE endif -!/ -!/ End of CalcDecomp ------------------------------------------------- / -!/ - end subroutine CalcDecomp -!/ ------------------------------------------------------------------- / -!> -!> @brief Get value of environment variable. -!> -!> @param cenv Name of environment variable -!> @param cval Value of environment variable -!> @param rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + + enddo mproc_loop + + if ( npx.lt.npmin .or. npy.lt.npmin ) then + write(msg,'(a,7i6)') 'proc count is too large for grid size:', & + nx,ny,npmin,nproc,mproc,nxproc,nyproc + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + endif + !/ + !/ End of CalcDecomp ------------------------------------------------- / + !/ + end subroutine CalcDecomp + !/ ------------------------------------------------------------------- / + !> + !> @brief Get value of environment variable. + !> + !> @param cenv Name of environment variable + !> @param cval Value of environment variable + !> @param rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "GetEnvValue" - subroutine GetEnvValue ( cenv, cval, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2017 : Origination. ( version 6.03 ) -!/ -! 1. Purpose : -! -! Get value of environment variable -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! cenv Str I Name of environment variable -! cval Str O Value of environment variable -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - character(*) :: cenv - character(*) :: cval - integer :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(256) :: msg - integer :: length, istat -! -! -------------------------------------------------------------------- / -! - rc = ESMF_SUCCESS - call get_environment_variable( name=trim(cenv), value=cval, & - length=length, trim_name=.false., status=istat ) - if (istat.lt.0) then - ! The VALUE argument is present and has a length less than - ! the significant length of the environment variable value. - write(msg,'(a,i3,a)') "Length of input variable", & - " is less than length of environment variable " & - //trim(cenv)//" value (",length,")." - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) - rc = istat - elseif (istat.gt.0) then - ! 1: The specified environment variable NAME does not exist. - ! 2: The processor does not support environment variables. - !>2: Some other error condition occured. - cval=" " - endif - if (length.eq.0) cval=" " -!/ -!/ End of GetEnvValue ------------------------------------------------ / -!/ - end subroutine GetEnvValue -!/ ------------------------------------------------------------------- / -!> -!> @brief Get array of z-levels from zlfile for SDC. -!> -!> @param[inout] rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + subroutine GetEnvValue ( cenv, cval, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2017 : Origination. ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Get value of environment variable + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! cenv Str I Name of environment variable + ! cval Str O Value of environment variable + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + character(*) :: cenv + character(*) :: cval + integer :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(256) :: msg + integer :: length, istat + ! + ! -------------------------------------------------------------------- / + ! + rc = ESMF_SUCCESS + call get_environment_variable( name=trim(cenv), value=cval, & + length=length, trim_name=.false., status=istat ) + if (istat.lt.0) then + ! The VALUE argument is present and has a length less than + ! the significant length of the environment variable value. + write(msg,'(a,i3,a)') "Length of input variable", & + " is less than length of environment variable " & + //trim(cenv)//" value (",length,")." + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) + rc = istat + elseif (istat.gt.0) then + ! 1: The specified environment variable NAME does not exist. + ! 2: The processor does not support environment variables. + !>2: Some other error condition occured. + cval=" " + endif + if (length.eq.0) cval=" " + !/ + !/ End of GetEnvValue ------------------------------------------------ / + !/ + end subroutine GetEnvValue + !/ ------------------------------------------------------------------- / + !> + !> @brief Get array of z-levels from zlfile for SDC. + !> + !> @param[inout] rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "GetZlevels" - subroutine GetZlevels ( rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2017 : Origination. ( version 6.03 ) -!/ -! 1. Purpose : -! -! Get array of z-levels from zlfile for SDC -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - integer :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(256) :: msg - integer :: k, iunit, ierr -! -! -------------------------------------------------------------------- / -! - rc = ESMF_SUCCESS - - if (len_trim(zlfile).eq.0 .or. trim(zlfile) .eq. 'none') then - - nz = 1 - allocate(zl(nz), stat=rc) - if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return - zl(1) = 0 + subroutine GetZlevels ( rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2017 : Origination. ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Get array of z-levels from zlfile for SDC + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + integer :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(256) :: msg + integer :: k, iunit, ierr + ! + ! -------------------------------------------------------------------- / + ! + rc = ESMF_SUCCESS + + if (len_trim(zlfile).eq.0 .or. trim(zlfile) .eq. 'none') then + + nz = 1 + allocate(zl(nz), stat=rc) + if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return + zl(1) = 0 - else + else - call ESMF_UtilIOUnitGet(iunit, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - open(unit=iunit, file=trim(zlfile), form='formatted', & - status='old', access='sequential', iostat=ierr) - if (ierr.ne.0) then - msg = "failed opening "//trim(zlfile) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return - endif - read(iunit, fmt=*, iostat=ierr) nz + call ESMF_UtilIOUnitGet(iunit, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + open(unit=iunit, file=trim(zlfile), form='formatted', & + status='old', access='sequential', iostat=ierr) + if (ierr.ne.0) then + msg = "failed opening "//trim(zlfile) + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + read(iunit, fmt=*, iostat=ierr) nz + if (ierr.ne.0) then + msg = "read nz failed: "//trim(zlfile) + call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + allocate(zl(nz), stat=rc) + if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return + do k=1,nz + read(iunit, fmt=*, iostat=ierr) zl(k) if (ierr.ne.0) then - msg = "read nz failed: "//trim(zlfile) + msg = "read zl failed: "//trim(zlfile) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return endif - allocate(zl(nz), stat=rc) - if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return - do k=1,nz - read(iunit, fmt=*, iostat=ierr) zl(k) - if (ierr.ne.0) then - msg = "read zl failed: "//trim(zlfile) - call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return - endif - enddo - close(iunit) - - endif -!/ -!/ End of GetZlevels ------------------------------------------------- / -!/ - end subroutine GetZlevels -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate Charnock for export. -!> -!> @param chkField 2D Charnock export field -!> @param rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + enddo + close(iunit) + + endif + !/ + !/ End of GetZlevels ------------------------------------------------- / + !/ + end subroutine GetZlevels + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate Charnock for export. + !> + !> @param chkField 2D Charnock export field + !> @param rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "CalcCharnk" - subroutine CalcCharnk ( chkField, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2017 : Origination. ( version 6.03 ) -!/ -! 1. Purpose : -! -! Calculate Charnock for export -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! chkField Type I/O 2D Charnock export field -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_Field) :: chkField - integer :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - real , parameter :: zero = 0.0 - logical, save :: firstCall = .true. - integer :: isea, jsea - real :: emean, fmean, fmean1, wnmean, amax, ustar, ustdr, & - tauwx, tauwy, cd, z0, fmeanws, dlwmean - logical :: llws(nspec) - type(ESMF_Field) :: chknField - real(ESMF_KIND_RX), pointer :: chkn(:) - integer, save :: timeSlice = 1 -! -! -------------------------------------------------------------------- / -! - rc = ESMF_SUCCESS - - chknField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - call FieldFill( chknField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - if ( natGridIsLocal ) then - - call ESMF_FieldGet( chknField, farrayPtr=chkn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - jsea_loop: do jsea = 1,nseal + subroutine CalcCharnk ( chkField, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2017 : Origination. ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Calculate Charnock for export + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! chkField Type I/O 2D Charnock export field + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_Field) :: chkField + integer :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + real , parameter :: zero = 0.0 + logical, save :: firstCall = .true. + integer :: isea, jsea + real :: emean, fmean, fmean1, wnmean, amax, ustar, ustdr, & + tauwx, tauwy, cd, z0, fmeanws, dlwmean + logical :: llws(nspec) + type(ESMF_Field) :: chknField + real(ESMF_KIND_RX), pointer :: chkn(:) + integer, save :: timeSlice = 1 + ! + ! -------------------------------------------------------------------- / + ! + rc = ESMF_SUCCESS + + chknField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + call FieldFill( chknField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + if ( natGridIsLocal ) then + + call ESMF_FieldGet( chknField, farrayPtr=chkn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + jsea_loop: do jsea = 1,nseal #ifdef W3_DIST - isea = iaproc + (jsea-1)*naproc + isea = iaproc + (jsea-1)*naproc #endif #ifdef W3_SHRD - isea = jsea + isea = jsea #endif - if ( firstCall ) then - charn(jsea) = zero + if ( firstCall ) then + charn(jsea) = zero #ifdef W3_ST3 - llws(:) = .true. - ustar = zero - ustdr = zero - tauwx = zero - tauwy = zero - call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & - emean, fmean, fmean1, wnmean, amax, & - u10(isea), u10d(isea), ustar, ustdr, tauwx, & - tauwy, cd, z0, charn(jsea), llws, fmeanws ) + llws(:) = .true. + ustar = zero + ustdr = zero + tauwx = zero + tauwy = zero + call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws ) #endif #ifdef W3_ST4 - llws(:) = .true. - ustar = zero - ustdr = zero - tauwx = zero - tauwy = zero - call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & - emean, fmean, fmean1, wnmean, amax, & - u10(isea), u10d(isea), ustar, ustdr, tauwx, & - tauwy, cd, z0, charn(jsea), llws, fmeanws, & - dlwmean ) + llws(:) = .true. + ustar = zero + ustdr = zero + tauwx = zero + tauwy = zero + call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws, & + dlwmean ) #endif - endif !firstCall - chkn(jsea) = charn(jsea) - enddo jsea_loop + endif !firstCall + chkn(jsea) = charn(jsea) + enddo jsea_loop - endif !natGridIsLocal + endif !natGridIsLocal - call ESMF_FieldRedist( chknField, chkField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( chknField, chkField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( chknField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( chknField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - firstCall = .false. + firstCall = .false. #ifdef TEST_WMESMFMD_CHARNK - call ESMF_FieldWrite( chkField, "wmesmfmd_charnk_chk.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - timeSlice = timeSlice + 1 + call ESMF_FieldWrite( chkField, "wmesmfmd_charnk_chk.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + timeSlice = timeSlice + 1 #endif -!/ -!/ End of CalcCharnk ------------------------------------------------- / -!/ - end subroutine CalcCharnk -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate 2D wave roughness length for export. -!> -!> @param wrlField 2D roughness length export field -!> @param rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + !/ + !/ End of CalcCharnk ------------------------------------------------- / + !/ + end subroutine CalcCharnk + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate 2D wave roughness length for export. + !> + !> @param wrlField 2D roughness length export field + !> @param rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "CalcRoughl" - subroutine CalcRoughl ( wrlField, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2017 : Origination. ( version 6.03 ) -!/ -! 1. Purpose : -! -! Calculate 2D wave roughness length for export -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! wrlField Type I/O 2D roughness length export field -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - type(ESMF_Field) :: wrlField - integer :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - real , parameter :: zero = 0.0 - logical, save :: firstCall = .true. - integer :: isea, jsea, ix, iy - real :: emean, fmean, fmean1, wnmean, amax, ustar, ustdr, & - tauwx, tauwy, cd, z0, fmeanws, dlwmean - logical :: llws(nspec) - type(ESMF_Field) :: wrlnField - real(ESMF_KIND_RX), pointer :: wrln(:) - integer, save :: timeSlice = 1 -! -! -------------------------------------------------------------------- / -! - rc = ESMF_SUCCESS - - wrlnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - call FieldFill( wrlnField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - if ( natGridIsLocal ) then - - call ESMF_FieldGet( wrlnField, farrayPtr=wrln, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - jsea_loop: do jsea = 1,nseal + subroutine CalcRoughl ( wrlField, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2017 : Origination. ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Calculate 2D wave roughness length for export + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! wrlField Type I/O 2D roughness length export field + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + type(ESMF_Field) :: wrlField + integer :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + real , parameter :: zero = 0.0 + logical, save :: firstCall = .true. + integer :: isea, jsea, ix, iy + real :: emean, fmean, fmean1, wnmean, amax, ustar, ustdr, & + tauwx, tauwy, cd, z0, fmeanws, dlwmean + logical :: llws(nspec) + type(ESMF_Field) :: wrlnField + real(ESMF_KIND_RX), pointer :: wrln(:) + integer, save :: timeSlice = 1 + ! + ! -------------------------------------------------------------------- / + ! + rc = ESMF_SUCCESS + + wrlnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + call FieldFill( wrlnField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + if ( natGridIsLocal ) then + + call ESMF_FieldGet( wrlnField, farrayPtr=wrln, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + jsea_loop: do jsea = 1,nseal #ifdef W3_DIST - isea = iaproc + (jsea-1)*naproc -#endif -#ifdef W3_SHRD - isea = jsea -#endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN - if ( firstCall ) then - charn(jsea) = zero -#ifdef W3_ST3 - llws(:) = .true. - ustar = zero - ustdr = zero - tauwx = zero - tauwy = zero - call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & - emean, fmean, fmean1, wnmean, amax, & - u10(isea), u10d(isea), ustar, ustdr, tauwx, & - tauwy, cd, z0, charn(jsea), llws, fmeanws ) -#endif -#ifdef W3_ST4 - llws(:) = .true. - ustar = zero - ustdr = zero - tauwx = zero - tauwy = zero - call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & - emean, fmean, fmean1, wnmean, amax, & - u10(isea), u10d(isea), ustar, ustdr, tauwx, & - tauwy, cd, z0, charn(jsea), llws, fmeanws, & - dlwmean ) -#endif - endif !firstCall - wrln(jsea) = charn(jsea)*ust(isea)**2/grav - endif - enddo jsea_loop - - endif !natGridIsLocal - - call ESMF_FieldRedist( wrlnField, wrlField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - call ESMF_FieldDestroy( wrlnField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - firstCall = .false. - -#ifdef TEST_WMESMFMD_ROUGHL - call ESMF_FieldWrite( wrlField, "wmesmfmd_roughl_wrl.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - timeSlice = timeSlice + 1 + isea = iaproc + (jsea-1)*naproc #endif -!/ -!/ End of CalcRoughl ------------------------------------------------- / -!/ - end subroutine CalcRoughl -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate wave-bottom currents for export. -!> -!> @param a Input spectra (in par list to change shape) -!> @param wbxField WBC 2D eastward-component export field -!> @param wbyField WBC 2D northward-component export field -!> @param wbpField WBC 2D period export field -!> @param rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> -#undef METHOD -#define METHOD "CalcBotcur" - subroutine CalcBotcur ( a, wbxField, wbyField, wbpField, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2017 : Origination. ( version 6.03 ) -!/ -! 1. Purpose : -! -! Calculate wave-bottom currents for export -! -! 2. Method : -! -! > Madsen, O. S. (1994), ICCE -! -! // -! U_bot = sqrt( 2*|| S_ub dsig dtheta ) -! (magnitude) // -! -! // -! || S_ub*sin(theta) dsig dtheta -! // -! phi_b = arctan( ---------------------------------- ) -! (direction) // -! || S_ub*cos(theta) dsig dtheta -! // -! -! // -! || S_ub dsig dtheta -! // -! U_bp = 2*pi * ---------------------------- -! (period) // -! || sig*S_ub dsig dtheta -! // -! -! Where: -! S_ub(theta,k) = near-bottom orbital velocity spectrum -! = ( sig^2 / sinh^2(kD) ) * E(theta,k) / Cg -! = ( sig^3 / sinh^2(kD) ) * Ac(theta,k) / Cg -! Ac(theta,k) = wave action density -! D = depth -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! a Real I Input spectra (in par list to change shape) -! wbxField Type I/O WBC 2D eastward-component export field -! wbyField Type I/O WBC 2D northward-component export field -! wbpField Type I/O WBC 2D period export field -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - real :: a(nth,nk,0:nseal) - type(ESMF_Field) :: wbxField - type(ESMF_Field) :: wbyField - type(ESMF_Field) :: wbpField - integer :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - real(8), parameter :: zero = 0.0 - real(8), parameter :: half = 0.5 - real(8), parameter :: one = 1.0 - real(8), parameter :: two = 2.0 - ! kdmin = 1e-7: sinh(kdmin)**2 ~ 1e-14 - real(8), parameter :: kdmin = 1e-7 - ! kdmax = 18.0: 1/sinh(kdmax)**2 ~ 1e-14 - real(8), parameter :: kdmax = 18.0 - integer :: isea, jsea, ik, ith - real(8) :: depth - real(8) :: kd, fack, fkd, aka, akx, aky, abr, ubr, ubx, uby, dir - real(8), allocatable :: sig2(:) - type(ESMF_Field) :: wbxnField, wbynField, wbpnField - real(ESMF_KIND_RX), pointer :: wbxn(:), wbyn(:), wbpn(:) - integer, save :: timeSlice = 1 -! -! -------------------------------------------------------------------- / -! - rc = ESMF_SUCCESS - - wbxnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - wbynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - wbpnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return +#ifdef W3_SHRD + isea = jsea +#endif + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN + if ( firstCall ) then + charn(jsea) = zero +#ifdef W3_ST3 + llws(:) = .true. + ustar = zero + ustdr = zero + tauwx = zero + tauwy = zero + call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws ) +#endif +#ifdef W3_ST4 + llws(:) = .true. + ustar = zero + ustdr = zero + tauwx = zero + tauwy = zero + call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws, & + dlwmean ) +#endif + endif !firstCall + wrln(jsea) = charn(jsea)*ust(isea)**2/grav + endif + enddo jsea_loop - call FieldFill( wbxnField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( wbynField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( wbpnField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif !natGridIsLocal - if ( natGridIsLocal ) then + call ESMF_FieldRedist( wrlnField, wrlField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( wbxnField, farrayPtr=wbxn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( wbynField, farrayPtr=wbyn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( wbpnField, farrayPtr=wbpn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( wrlnField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - allocate( sig2(1:nk) ) - sig2(1:nk) = sig(1:nk)**2 + firstCall = .false. - jsea_loop: do jsea = 1,nseal +#ifdef TEST_WMESMFMD_ROUGHL + call ESMF_FieldWrite( wrlField, "wmesmfmd_roughl_wrl.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + timeSlice = timeSlice + 1 +#endif + !/ + !/ End of CalcRoughl ------------------------------------------------- / + !/ + end subroutine CalcRoughl + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate wave-bottom currents for export. + !> + !> @param a Input spectra (in par list to change shape) + !> @param wbxField WBC 2D eastward-component export field + !> @param wbyField WBC 2D northward-component export field + !> @param wbpField WBC 2D period export field + !> @param rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> +#undef METHOD +#define METHOD "CalcBotcur" + subroutine CalcBotcur ( a, wbxField, wbyField, wbpField, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2017 : Origination. ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Calculate wave-bottom currents for export + ! + ! 2. Method : + ! + ! > Madsen, O. S. (1994), ICCE + ! + ! // + ! U_bot = sqrt( 2*|| S_ub dsig dtheta ) + ! (magnitude) // + ! + ! // + ! || S_ub*sin(theta) dsig dtheta + ! // + ! phi_b = arctan( ---------------------------------- ) + ! (direction) // + ! || S_ub*cos(theta) dsig dtheta + ! // + ! + ! // + ! || S_ub dsig dtheta + ! // + ! U_bp = 2*pi * ---------------------------- + ! (period) // + ! || sig*S_ub dsig dtheta + ! // + ! + ! Where: + ! S_ub(theta,k) = near-bottom orbital velocity spectrum + ! = ( sig^2 / sinh^2(kD) ) * E(theta,k) / Cg + ! = ( sig^3 / sinh^2(kD) ) * Ac(theta,k) / Cg + ! Ac(theta,k) = wave action density + ! D = depth + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! a Real I Input spectra (in par list to change shape) + ! wbxField Type I/O WBC 2D eastward-component export field + ! wbyField Type I/O WBC 2D northward-component export field + ! wbpField Type I/O WBC 2D period export field + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + real :: a(nth,nk,0:nseal) + type(ESMF_Field) :: wbxField + type(ESMF_Field) :: wbyField + type(ESMF_Field) :: wbpField + integer :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + real(8), parameter :: zero = 0.0 + real(8), parameter :: half = 0.5 + real(8), parameter :: one = 1.0 + real(8), parameter :: two = 2.0 + ! kdmin = 1e-7: sinh(kdmin)**2 ~ 1e-14 + real(8), parameter :: kdmin = 1e-7 + ! kdmax = 18.0: 1/sinh(kdmax)**2 ~ 1e-14 + real(8), parameter :: kdmax = 18.0 + integer :: isea, jsea, ik, ith + real(8) :: depth + real(8) :: kd, fack, fkd, aka, akx, aky, abr, ubr, ubx, uby, dir + real(8), allocatable :: sig2(:) + type(ESMF_Field) :: wbxnField, wbynField, wbpnField + real(ESMF_KIND_RX), pointer :: wbxn(:), wbyn(:), wbpn(:) + integer, save :: timeSlice = 1 + ! + ! -------------------------------------------------------------------- / + ! + rc = ESMF_SUCCESS + + wbxnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + wbynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + wbpnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + call FieldFill( wbxnField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( wbynField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( wbpnField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + if ( natGridIsLocal ) then + + call ESMF_FieldGet( wbxnField, farrayPtr=wbxn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( wbynField, farrayPtr=wbyn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( wbpnField, farrayPtr=wbpn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + allocate( sig2(1:nk) ) + sig2(1:nk) = sig(1:nk)**2 + + jsea_loop: do jsea = 1,nseal #ifdef W3_DIST - isea = iaproc + (jsea-1)*naproc + isea = iaproc + (jsea-1)*naproc #endif #ifdef W3_SHRD - isea = jsea + isea = jsea #endif - if ( dw(isea).le.zero ) cycle jsea_loop - depth = max(dmin,dw(isea)) + if ( dw(isea).le.zero ) cycle jsea_loop + depth = max(dmin,dw(isea)) #ifdef USE_W3OUTG_FOR_EXPORT - if ( aba(jsea).le.zero ) cycle jsea_loop - if ( uba(jsea).le.zero ) cycle jsea_loop - wbxn(jsea) = uba(jsea)*cos(ubd(jsea)) - wbyn(jsea) = uba(jsea)*sin(ubd(jsea)) - wbpn(jsea) = tpi*aba(jsea)/uba(jsea) + if ( aba(jsea).le.zero ) cycle jsea_loop + if ( uba(jsea).le.zero ) cycle jsea_loop + wbxn(jsea) = uba(jsea)*cos(ubd(jsea)) + wbyn(jsea) = uba(jsea)*sin(ubd(jsea)) + wbpn(jsea) = tpi*aba(jsea)/uba(jsea) #else - abr = zero - ubr = zero - ubx = zero - uby = zero - ik_loop: do ik = 1,nk - aka = zero - akx = zero - aky = zero - ith_loop: do ith = 1,nth - aka = aka + a(ith,ik,jsea) - akx = akx + a(ith,ik,jsea)*ecos(ith) - aky = aky + a(ith,ik,jsea)*esin(ith) - enddo ith_loop - fack = dden(ik)/cg(ik,isea) - kd = max(kdmin,min(kdmax,wn(ik,isea)*depth)) - fkd = fack/sinh(kd)**2 - abr = abr + aka*fkd - ubr = ubr + aka*sig2(ik)*fkd - ubx = ubx + akx*sig2(ik)*fkd - uby = uby + aky*sig2(ik)*fkd - enddo ik_loop - if ( abr.le.zero .or. ubr.le.zero ) cycle jsea_loop - abr = sqrt(two*abr) - ubr = sqrt(two*ubr) - dir = atan2(uby,ubx) - wbxn(jsea) = ubr*cos(dir) - wbyn(jsea) = ubr*sin(dir) - wbpn(jsea) = tpi*abr/ubr + abr = zero + ubr = zero + ubx = zero + uby = zero + ik_loop: do ik = 1,nk + aka = zero + akx = zero + aky = zero + ith_loop: do ith = 1,nth + aka = aka + a(ith,ik,jsea) + akx = akx + a(ith,ik,jsea)*ecos(ith) + aky = aky + a(ith,ik,jsea)*esin(ith) + enddo ith_loop + fack = dden(ik)/cg(ik,isea) + kd = max(kdmin,min(kdmax,wn(ik,isea)*depth)) + fkd = fack/sinh(kd)**2 + abr = abr + aka*fkd + ubr = ubr + aka*sig2(ik)*fkd + ubx = ubx + akx*sig2(ik)*fkd + uby = uby + aky*sig2(ik)*fkd + enddo ik_loop + if ( abr.le.zero .or. ubr.le.zero ) cycle jsea_loop + abr = sqrt(two*abr) + ubr = sqrt(two*ubr) + dir = atan2(uby,ubx) + wbxn(jsea) = ubr*cos(dir) + wbyn(jsea) = ubr*sin(dir) + wbpn(jsea) = tpi*abr/ubr #endif - enddo jsea_loop + enddo jsea_loop - deallocate( sig2 ) + deallocate( sig2 ) - endif !natGridIsLocal + endif !natGridIsLocal - call ESMF_FieldRedist( wbxnField, wbxField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldRedist( wbynField, wbyField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldRedist( wbpnField, wbpField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( wbxnField, wbxField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( wbynField, wbyField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( wbpnField, wbpField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( wbxnField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( wbynField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( wbpnField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( wbxnField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( wbynField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( wbpnField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #ifdef TEST_WMESMFMD_BOTCUR - call ESMF_FieldWrite( wbxField, "wmesmfmd_botcur_wbx.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( wbyField, "wmesmfmd_botcur_wby.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( wbpField, "wmesmfmd_botcur_wbp.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - timeSlice = timeSlice + 1 + call ESMF_FieldWrite( wbxField, "wmesmfmd_botcur_wbx.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( wbyField, "wmesmfmd_botcur_wby.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( wbpField, "wmesmfmd_botcur_wbp.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + timeSlice = timeSlice + 1 #endif -!/ -!/ End of CalcBotcur ------------------------------------------------- / -!/ - end subroutine CalcBotcur -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate 2D radiation stresses for export. -!> -!> @param[inout] a Input spectra (in par list to change shape) -!> @param[inout] sxxField RS 2D eastward-component export field -!> @param[inout] sxyField RS 2D eastward-northward-component export field -!> @param[inout] syyField RS 2D northward-component field -!> @param[inout] rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + !/ + !/ End of CalcBotcur ------------------------------------------------- / + !/ + end subroutine CalcBotcur + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate 2D radiation stresses for export. + !> + !> @param[inout] a Input spectra (in par list to change shape) + !> @param[inout] sxxField RS 2D eastward-component export field + !> @param[inout] sxyField RS 2D eastward-northward-component export field + !> @param[inout] syyField RS 2D northward-component field + !> @param[inout] rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "CalcRadstr2D" - subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | A. J. van der Westhuysen | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2017 : Origination. ( version 6.03 ) -!/ 27-Feb-2018 : Modification for use with UNGTYPE ( version 6.06 ) -!/ -! 1. Purpose : -! -! Calculate 2D radiation stresses for export -! -! 2. Method : -! -! Radiation stresses are defined as: -! -! // -! Sxx = rho grav || (N*cos^2(theta) + N - 1/2) * sig*Ac(theta,k)/Cg dsig dtheta -! // -! // -! Sxy = rho grav || N*sin(theta)*cos(theta) * sig*Ac(theta,k)/Cg dsig dtheta -! // -! // -! Syy = rho grav || (N*sin^2(theta) + N - 1/2) * sig*Ac(theta,k)/Cg dsig dtheta -! // -! -! Where: -! rho = density of sea water -! grav = acceleration due to gravity -! Ac(theta,k) = wave action density -! N = Cg/C = ratio of group velocity and phase velocity -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! a Real I Input spectra (in par list to change shape) -! sxxField Type I/O RS 2D eastward-component export field -! sxyField Type I/O RS 2D eastward-northward-component export field -! syyField Type I/O RS 2D northward-component export field -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ + subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | A. J. van der Westhuysen | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2017 : Origination. ( version 6.03 ) + !/ 27-Feb-2018 : Modification for use with UNGTYPE ( version 6.06 ) + !/ + ! 1. Purpose : + ! + ! Calculate 2D radiation stresses for export + ! + ! 2. Method : + ! + ! Radiation stresses are defined as: + ! + ! // + ! Sxx = rho grav || (N*cos^2(theta) + N - 1/2) * sig*Ac(theta,k)/Cg dsig dtheta + ! // + ! // + ! Sxy = rho grav || N*sin(theta)*cos(theta) * sig*Ac(theta,k)/Cg dsig dtheta + ! // + ! // + ! Syy = rho grav || (N*sin^2(theta) + N - 1/2) * sig*Ac(theta,k)/Cg dsig dtheta + ! // + ! + ! Where: + ! rho = density of sea water + ! grav = acceleration due to gravity + ! Ac(theta,k) = wave action density + ! N = Cg/C = ratio of group velocity and phase velocity + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! a Real I Input spectra (in par list to change shape) + ! sxxField Type I/O RS 2D eastward-component export field + ! sxyField Type I/O RS 2D eastward-northward-component export field + ! syyField Type I/O RS 2D northward-component export field + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_PDLIB - use yowNodepool, only: np, iplg + use yowNodepool, only: np, iplg #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - real :: a(nth,nk,0:nseal) - type(ESMF_Field) :: sxxField - type(ESMF_Field) :: sxyField - type(ESMF_Field) :: syyField - integer :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - character(ESMF_MAXSTR) :: cname - character(128) :: msg - real(8), parameter :: zero = 0.0 - real(8), parameter :: half = 0.5 - real(8), parameter :: one = 1.0 - real(8), parameter :: two = 2.0 - integer :: isea, jsea, ik, ith - real(8) :: sxxs, sxys, syys - real(8) :: akxx, akxy, akyy, cgoc, facd, fack, facs - type(ESMF_Field) :: sxxnField, sxynField, syynField - real(ESMF_KIND_RX), pointer :: sxxn(:), sxyn(:), syyn(:) - integer, save :: timeSlice = 1 -! -! -------------------------------------------------------------------- / -! - rc = ESMF_SUCCESS - -! For regular and curvilinear grids the native grid has a 2D -! layout, whereas for unstructured meshes it is a 1D array - if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then - sxxnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + real :: a(nth,nk,0:nseal) + type(ESMF_Field) :: sxxField + type(ESMF_Field) :: sxyField + type(ESMF_Field) :: syyField + integer :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + character(ESMF_MAXSTR) :: cname + character(128) :: msg + real(8), parameter :: zero = 0.0 + real(8), parameter :: half = 0.5 + real(8), parameter :: one = 1.0 + real(8), parameter :: two = 2.0 + integer :: isea, jsea, ik, ith + real(8) :: sxxs, sxys, syys + real(8) :: akxx, akxy, akyy, cgoc, facd, fack, facs + type(ESMF_Field) :: sxxnField, sxynField, syynField + real(ESMF_KIND_RX), pointer :: sxxn(:), sxyn(:), syyn(:) + integer, save :: timeSlice = 1 + ! + ! -------------------------------------------------------------------- / + ! + rc = ESMF_SUCCESS + + ! For regular and curvilinear grids the native grid has a 2D + ! layout, whereas for unstructured meshes it is a 1D array + if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then + sxxnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - sxynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + if (ESMF_LogFoundError(rc, PASSTHRU)) return + sxynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - syynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + if (ESMF_LogFoundError(rc, PASSTHRU)) return + syynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - elseif (GTYPE.eq.UNGTYPE) then + if (ESMF_LogFoundError(rc, PASSTHRU)) return + elseif (GTYPE.eq.UNGTYPE) then #ifdef W3_PDLIB if ( LPDLIB .EQV. .FALSE. ) then #endif - sxxnField = ESMF_FieldCreate( natGrid, natArraySpec1D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - sxynField = ESMF_FieldCreate( natGrid, natArraySpec1D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - syynField = ESMF_FieldCreate( natGrid, natArraySpec1D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + sxxnField = ESMF_FieldCreate( natGrid, natArraySpec1D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + sxynField = ESMF_FieldCreate( natGrid, natArraySpec1D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + syynField = ESMF_FieldCreate( natGrid, natArraySpec1D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #ifdef W3_PDLIB endif #endif - endif + endif #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif call FieldFill( sxxnField, zeroValue, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return @@ -7055,14 +7055,14 @@ subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) call FieldFill( syynField, zeroValue, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return #ifdef W3_PDLIB - endif + endif #endif - if ( natGridIsLocal ) then + if ( natGridIsLocal ) then #ifdef W3_PDLIB if ( LPDLIB .EQV. .FALSE. ) then -! Use auxiliary native grid/mesh to populate and redistribute data + ! Use auxiliary native grid/mesh to populate and redistribute data #endif call ESMF_FieldGet( sxxnField, farrayPtr=sxxn, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return @@ -7072,17 +7072,17 @@ subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return #ifdef W3_PDLIB else -! Use single domain-decomposed native mesh to populate and communicate data - call ESMF_FieldGet( sxxField, farrayPtr=sxxn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( sxyField, farrayPtr=sxyn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( syyField, farrayPtr=syyn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + ! Use single domain-decomposed native mesh to populate and communicate data + call ESMF_FieldGet( sxxField, farrayPtr=sxxn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( sxyField, farrayPtr=sxyn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( syyField, farrayPtr=syyn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return endif #endif - facd = dwat*grav + facd = dwat*grav #ifdef W3_PDLIB if ( LPDLIB .EQV. .FALSE. ) then #endif @@ -7126,22 +7126,22 @@ subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) enddo jsea_loop #ifdef W3_PDLIB else - jsea_loop2: do jsea = 1,np + jsea_loop2: do jsea = 1,np isea = iplg(jsea) -! if ( dw(isea).le.zero ) cycle jsea_loop + ! if ( dw(isea).le.zero ) cycle jsea_loop sxxn(jsea) = sxx(jsea) sxyn(jsea) = sxy(jsea) syyn(jsea) = syy(jsea) -! write(msg,*) trim(cname)//' sxxn', sxxn(jsea) -! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + ! write(msg,*) trim(cname)//' sxxn', sxxn(jsea) + ! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) enddo jsea_loop2 endif #endif - endif !natGridIsLocal + endif !natGridIsLocal #ifdef W3_PDLIB - if ( LPDLIB .EQV. .FALSE. ) then + if ( LPDLIB .EQV. .FALSE. ) then #endif call ESMF_FieldRedist( sxxnField, sxxField, n2eRH, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return @@ -7157,696 +7157,696 @@ subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) call ESMF_FieldDestroy( syynField, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return #ifdef W3_PDLIB - endif + endif #endif #ifdef TEST_WMESMFMD_RADSTR2D - call ESMF_FieldWrite( sxxField, "wmesmfmd_radstr2d_sxx.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( sxyField, "wmesmfmd_radstr2d_sxy.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( syyField, "wmesmfmd_radstr2d_syy.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - timeSlice = timeSlice + 1 + call ESMF_FieldWrite( sxxField, "wmesmfmd_radstr2d_sxx.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( sxyField, "wmesmfmd_radstr2d_sxy.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( syyField, "wmesmfmd_radstr2d_syy.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + timeSlice = timeSlice + 1 #endif -!/ -!/ End of CalcRadstr2D ----------------------------------------------- / -!/ - end subroutine CalcRadstr2D -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate 3D Stokes drift current for export. -!> -!> @param a Input spectra (in par list to change shape) -!> @param usxField 3D SDC eastward-component export field -!> @param usyField 3D SDC northward-component export field -!> @param rc Return code -!> -!> @author T. J. Campbell @date 09-Aug-2017 -!> + !/ + !/ End of CalcRadstr2D ----------------------------------------------- / + !/ + end subroutine CalcRadstr2D + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate 3D Stokes drift current for export. + !> + !> @param a Input spectra (in par list to change shape) + !> @param usxField 3D SDC eastward-component export field + !> @param usyField 3D SDC northward-component export field + !> @param rc Return code + !> + !> @author T. J. Campbell @date 09-Aug-2017 + !> #undef METHOD #define METHOD "CalcStokes3D" - subroutine CalcStokes3D ( a, usxField, usyField, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | T. J. Campbell, NRL | -!/ | FORTRAN 90 | -!/ | Last update : 09-Aug-2017 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2017 : Origination. ( version 6.03 ) -!/ -! 1. Purpose : -! -! Calculate 3D Stokes drift current for export -! -! 2. Method : -! -! Kenyon, K. E. (1969), J. Geophys. R., Vol 74, No 28, p 6991 -! -! U_vec(z) -! // -! = 2 g || ( F(f,theta) k_vec/C cosh(2k(D+z))/sinh(2kD) ) dsig dtheta -! // -! -! // -! = || (Ac(k,theta) sig^2 k_vec/Cg cosh(2k(D+z))/sinh^2(kD) ) dsig dtheta -! // -! -! Where: -! Ac(k,theta) = wave action density -! k_vec = k*[cos(theta),sin(theta)] -! D = depth -! z = height (0 = mean sea level) -! -! In deep water (kD large): cosh(2k(D+z))/sinh^2(kD) --> 2*exp(2kz) -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! a Real I Input spectra (in par list to change shape) -! usxField Type I/O 3D SDC eastward-component export field -! usyField Type I/O 3D SDC northward-component export field -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - implicit none - real :: a(nth,nk,0:nseal) - type(ESMF_Field) :: usxField - type(ESMF_Field) :: usyField - integer :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - real(8), parameter :: zero = 0.0 - real(8), parameter :: half = 0.5 - real(8), parameter :: one = 1.0 - real(8), parameter :: two = 2.0 - ! kdmin = 1e-7: sinh(kdmin)**2 ~ 1e-14 - real(8), parameter :: kdmin = 1e-7 - ! kdmax = 18.0: cosh(2*(kdmax+kz))/sinh(kdmax)**2 - 2*exp(2*kz) < 1e-14 - real(8), parameter :: kdmax = 18.0 - ! kdmin & kdmax settings used in w3iogomd - real(8), parameter :: kdmin_us3d = 1e-3 - real(8), parameter :: kdmax_us3d = 6.0 - integer :: isea, jsea, ik, ith, iz - real(8) :: depth - real(8) :: akx, aky, kd, kz, fac1, fac2, fac3 - real(8) :: uzx(nz), uzy(nz) - real(8), allocatable :: fack(:) - type(ESMF_Field) :: usxnField, usynField - real(ESMF_KIND_RX), pointer :: usxn(:,:), usyn(:,:) - integer, save :: timeSlice = 1 -! Need this workaround to deal with ESMF_FieldCreate not setting up the -! Fortran arrays with the ungridded dimension as the first array dimension + subroutine CalcStokes3D ( a, usxField, usyField, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | T. J. Campbell, NRL | + !/ | FORTRAN 90 | + !/ | Last update : 09-Aug-2017 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2017 : Origination. ( version 6.03 ) + !/ + ! 1. Purpose : + ! + ! Calculate 3D Stokes drift current for export + ! + ! 2. Method : + ! + ! Kenyon, K. E. (1969), J. Geophys. R., Vol 74, No 28, p 6991 + ! + ! U_vec(z) + ! // + ! = 2 g || ( F(f,theta) k_vec/C cosh(2k(D+z))/sinh(2kD) ) dsig dtheta + ! // + ! + ! // + ! = || (Ac(k,theta) sig^2 k_vec/Cg cosh(2k(D+z))/sinh^2(kD) ) dsig dtheta + ! // + ! + ! Where: + ! Ac(k,theta) = wave action density + ! k_vec = k*[cos(theta),sin(theta)] + ! D = depth + ! z = height (0 = mean sea level) + ! + ! In deep water (kD large): cosh(2k(D+z))/sinh^2(kD) --> 2*exp(2kz) + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! a Real I Input spectra (in par list to change shape) + ! usxField Type I/O 3D SDC eastward-component export field + ! usyField Type I/O 3D SDC northward-component export field + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + implicit none + real :: a(nth,nk,0:nseal) + type(ESMF_Field) :: usxField + type(ESMF_Field) :: usyField + integer :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + real(8), parameter :: zero = 0.0 + real(8), parameter :: half = 0.5 + real(8), parameter :: one = 1.0 + real(8), parameter :: two = 2.0 + ! kdmin = 1e-7: sinh(kdmin)**2 ~ 1e-14 + real(8), parameter :: kdmin = 1e-7 + ! kdmax = 18.0: cosh(2*(kdmax+kz))/sinh(kdmax)**2 - 2*exp(2*kz) < 1e-14 + real(8), parameter :: kdmax = 18.0 + ! kdmin & kdmax settings used in w3iogomd + real(8), parameter :: kdmin_us3d = 1e-3 + real(8), parameter :: kdmax_us3d = 6.0 + integer :: isea, jsea, ik, ith, iz + real(8) :: depth + real(8) :: akx, aky, kd, kz, fac1, fac2, fac3 + real(8) :: uzx(nz), uzy(nz) + real(8), allocatable :: fack(:) + type(ESMF_Field) :: usxnField, usynField + real(ESMF_KIND_RX), pointer :: usxn(:,:), usyn(:,:) + integer, save :: timeSlice = 1 + ! Need this workaround to deal with ESMF_FieldCreate not setting up the + ! Fortran arrays with the ungridded dimension as the first array dimension #define ESMF_ARBSEQ_WORKAROUND #ifdef ESMF_ARBSEQ_WORKAROUND - type(ESMF_DistGrid) :: natDistGrid - type(ESMF_Array) :: usxnArray, usynArray + type(ESMF_DistGrid) :: natDistGrid + type(ESMF_Array) :: usxnArray, usynArray #endif -! -! -------------------------------------------------------------------- / -! - rc = ESMF_SUCCESS + ! + ! -------------------------------------------------------------------- / + ! + rc = ESMF_SUCCESS #ifdef ESMF_ARBSEQ_WORKAROUND - call ESMF_GridGet( natGrid, distGrid=natDistGrid, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - usxnArray = ESMF_ArrayCreate( natDistGrid, ESMF_TYPEKIND_RX, & - distGridToArrayMap=(/2/), undistLBound=(/1/), undistUBound=(/nz/), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - usxnField = ESMF_FieldCreate( natGrid, usxnArray, & - gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - usynArray = ESMF_ArrayCreate( natDistGrid, ESMF_TYPEKIND_RX, & - distGridToArrayMap=(/2/), undistLBound=(/1/), undistUBound=(/nz/), rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - usynField = ESMF_FieldCreate( natGrid, usynArray, & - gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_GridGet( natGrid, distGrid=natDistGrid, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + usxnArray = ESMF_ArrayCreate( natDistGrid, ESMF_TYPEKIND_RX, & + distGridToArrayMap=(/2/), undistLBound=(/1/), undistUBound=(/nz/), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + usxnField = ESMF_FieldCreate( natGrid, usxnArray, & + gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + usynArray = ESMF_ArrayCreate( natDistGrid, ESMF_TYPEKIND_RX, & + distGridToArrayMap=(/2/), undistLBound=(/1/), undistUBound=(/nz/), rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + usynField = ESMF_FieldCreate( natGrid, usynArray, & + gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #else - usxnField = ESMF_FieldCreate( natGrid, natArraySpec3D, & - gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - usynField = ESMF_FieldCreate( natGrid, natArraySpec3D, & - gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + usxnField = ESMF_FieldCreate( natGrid, natArraySpec3D, & + gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + usynField = ESMF_FieldCreate( natGrid, natArraySpec3D, & + gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #endif - call FieldFill( usxnField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( usynField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( usxnField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( usynField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - if ( natGridIsLocal ) then + if ( natGridIsLocal ) then - call ESMF_FieldGet( usxnField, farrayPtr=usxn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( usynField, farrayPtr=usyn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( usxnField, farrayPtr=usxn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( usynField, farrayPtr=usyn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return - allocate( fack(1:nk) ) - fack(1:nk) = dden(1:nk) * sig(1:nk) + allocate( fack(1:nk) ) + fack(1:nk) = dden(1:nk) * sig(1:nk) - jsea_loop: do jsea = 1,nseal + jsea_loop: do jsea = 1,nseal #ifdef W3_DIST - isea = iaproc + (jsea-1)*naproc + isea = iaproc + (jsea-1)*naproc #endif #ifdef W3_SHRD - isea = jsea + isea = jsea #endif - if ( dw(isea).le.zero ) cycle jsea_loop - depth = max(dmin,dw(isea)) - uzx(:) = zero - uzy(:) = zero + if ( dw(isea).le.zero ) cycle jsea_loop + depth = max(dmin,dw(isea)) + uzx(:) = zero + uzy(:) = zero #ifdef USE_W3OUTG_FOR_EXPORT - ik_loop: do ik = us3df(2),us3df(3) - fac1 = tpiinv*dsii(ik) - kd = max(kdmin_us3d,wn(ik,isea)*dw(isea)) - iz_loop: do iz = 1,nz - if ( dw(isea)+zl(iz).le.zero ) cycle iz_loop - kz = wn(ik,isea)*zl(iz) - if ( kd .lt. kdmax_us3d ) then - fac2 = fac1*cosh(two*max(zero,kd+kz))/cosh(two*kd) - else - fac2 = fac1*exp(two*kz) - endif - uzx(iz) = uzx(iz) + us3d(jsea,ik )*fac2 - uzy(iz) = uzy(iz) + us3d(jsea,nk+ik)*fac2 - enddo iz_loop - enddo ik_loop + ik_loop: do ik = us3df(2),us3df(3) + fac1 = tpiinv*dsii(ik) + kd = max(kdmin_us3d,wn(ik,isea)*dw(isea)) + iz_loop: do iz = 1,nz + if ( dw(isea)+zl(iz).le.zero ) cycle iz_loop + kz = wn(ik,isea)*zl(iz) + if ( kd .lt. kdmax_us3d ) then + fac2 = fac1*cosh(two*max(zero,kd+kz))/cosh(two*kd) + else + fac2 = fac1*exp(two*kz) + endif + uzx(iz) = uzx(iz) + us3d(jsea,ik )*fac2 + uzy(iz) = uzy(iz) + us3d(jsea,nk+ik)*fac2 + enddo iz_loop + enddo ik_loop #else - ik_loop: do ik = 1,nk - akx = zero - aky = zero - ith_loop: do ith = 1,nth - akx = akx + a(ith,ik,jsea)*ecos(ith) - aky = aky + a(ith,ik,jsea)*esin(ith) - enddo ith_loop - fac1 = fack(ik)*wn(ik,isea)/cg(ik,isea) - kd = max(kdmin,wn(ik,isea)*depth) + ik_loop: do ik = 1,nk + akx = zero + aky = zero + ith_loop: do ith = 1,nth + akx = akx + a(ith,ik,jsea)*ecos(ith) + aky = aky + a(ith,ik,jsea)*esin(ith) + enddo ith_loop + fac1 = fack(ik)*wn(ik,isea)/cg(ik,isea) + kd = max(kdmin,wn(ik,isea)*depth) + if ( kd .lt. kdmax ) then + fac2 = fac1/sinh(kd)**2 + else + fac2 = fac1*two + endif + akx = akx*fac2 + aky = aky*fac2 + iz_loop: do iz = 1,nz + if ( depth+zl(iz).le.zero ) cycle iz_loop + kz = wn(ik,isea)*zl(iz) if ( kd .lt. kdmax ) then - fac2 = fac1/sinh(kd)**2 + fac3 = cosh(two*max(zero,kd+kz)) else - fac2 = fac1*two + fac3 = exp(two*kz) endif - akx = akx*fac2 - aky = aky*fac2 - iz_loop: do iz = 1,nz - if ( depth+zl(iz).le.zero ) cycle iz_loop - kz = wn(ik,isea)*zl(iz) - if ( kd .lt. kdmax ) then - fac3 = cosh(two*max(zero,kd+kz)) - else - fac3 = exp(two*kz) - endif - uzx(iz) = uzx(iz) + akx*fac3 - uzy(iz) = uzy(iz) + aky*fac3 - enddo iz_loop - enddo ik_loop + uzx(iz) = uzx(iz) + akx*fac3 + uzy(iz) = uzy(iz) + aky*fac3 + enddo iz_loop + enddo ik_loop #endif - usxn(:,jsea) = uzx(:) - usyn(:,jsea) = uzy(:) - enddo jsea_loop + usxn(:,jsea) = uzx(:) + usyn(:,jsea) = uzy(:) + enddo jsea_loop - deallocate( fack ) + deallocate( fack ) - endif !natGridIsLocal + endif !natGridIsLocal - call ESMF_FieldRedist( usxnField, usxField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldRedist( usynField, usyField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( usxnField, usxField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( usynField, usyField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #ifdef ESMF_ARBSEQ_WORKAROUND - call ESMF_ArrayDestroy( usxnArray, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_ArrayDestroy( usynArray, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_ArrayDestroy( usxnArray, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_ArrayDestroy( usynArray, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #endif - call ESMF_FieldDestroy( usxnField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( usynField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( usxnField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( usynField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #ifdef TEST_WMESMFMD_STOKES3D - call ESMF_FieldWrite( usxField, "wmesmfmd_stokes3d_usx.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( usyField, "wmesmfmd_stokes3d_usy.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - timeSlice = timeSlice + 1 + call ESMF_FieldWrite( usxField, "wmesmfmd_stokes3d_usx.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( usyField, "wmesmfmd_stokes3d_usy.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + timeSlice = timeSlice + 1 #endif -!/ -!/ End of CalcStokes3D ----------------------------------------------- / -!/ - end subroutine CalcStokes3D -!/ ------------------------------------------------------------------- / -!> -!> @brief Calculate partitioned Stokes drift for export. -!> -!> @param a Input spectra (in par list to change shape) -!> @param p1xField -!> @param p1yField -!> @param p2xField -!> @param p2yField -!> @param p3xField -!> @param p3yField -!> @param rc Return code -!> -!> @author J. Meixner @date 29-Oct-2019 -!> + !/ + !/ End of CalcStokes3D ----------------------------------------------- / + !/ + end subroutine CalcStokes3D + !/ ------------------------------------------------------------------- / + !> + !> @brief Calculate partitioned Stokes drift for export. + !> + !> @param a Input spectra (in par list to change shape) + !> @param p1xField + !> @param p1yField + !> @param p2xField + !> @param p2yField + !> @param p3xField + !> @param p3yField + !> @param rc Return code + !> + !> @author J. Meixner @date 29-Oct-2019 + !> #undef METHOD #define METHOD "CalcPStokes" - subroutine CalcPStokes ( a, p1xField, p1yField, p2xField, & - p2yField, p3xField, p3yField, rc ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | J. Meixner | -!/ | FORTRAN 90 | -!/ | Last update : 29-Oct-2019 | -!/ +-----------------------------------+ -!/ -!/ DD-MMM-YYYY : Origination. ( version 7.13 ) -!/ -! 1. Purpose : -! -! Calculate partitioned Stokes drift for export -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! a Real I Input spectra (in par list to change shape) -! p1Field Type I/O -! p2Field Type I/O -! p3Field Type I/O -! rc Int O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3ADATMD, ONLY: USSP - USE W3IOGOMD, ONLY: CALC_U3STOKES - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - real :: a(nth,nk,0:nseal) - type(ESMF_Field) :: p1xField,p2xField,p3xField - type(ESMF_Field) :: p1yField,p2yField,p3yField - integer :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - !real(8) :: sxxs, sxys, syys - type(ESMF_Field) :: p1xnField, p2xnField, p3xnField - type(ESMF_Field) :: p1ynField, p2ynField, p3ynField - real(ESMF_KIND_RX), pointer :: p1xn(:), p2xn(:), p3xn(:) - real(ESMF_KIND_RX), pointer :: p1yn(:), p2yn(:), p3yn(:) - integer, save :: timeSlice = 1 - integer :: isea,jsea -! -! -------------------------------------------------------------------- / -! - rc = ESMF_SUCCESS - - - p1xnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - p1ynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - p2xnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - p2ynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - p3xnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - p3ynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & - staggerLoc=natStaggerLoc, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - call FieldFill( p1xnField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( p1ynField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( p2xnField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( p2ynField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( p3xnField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call FieldFill( p3ynField, zeroValue, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - if ( natGridIsLocal ) then - - call ESMF_FieldGet( p1xnField, farrayPtr=p1xn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( p1ynField, farrayPtr=p1yn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( p2xnField, farrayPtr=p2xn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( p2ynField, farrayPtr=p2yn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( p3xnField, farrayPtr=p3xn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldGet( p3ynField, farrayPtr=p3yn, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - call CALC_U3STOKES ( a , 2 ) - - jsea_loop: do jsea = 1,nseal + subroutine CalcPStokes ( a, p1xField, p1yField, p2xField, & + p2yField, p3xField, p3yField, rc ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | J. Meixner | + !/ | FORTRAN 90 | + !/ | Last update : 29-Oct-2019 | + !/ +-----------------------------------+ + !/ + !/ DD-MMM-YYYY : Origination. ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Calculate partitioned Stokes drift for export + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! a Real I Input spectra (in par list to change shape) + ! p1Field Type I/O + ! p2Field Type I/O + ! p3Field Type I/O + ! rc Int O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3ADATMD, ONLY: USSP + USE W3IOGOMD, ONLY: CALC_U3STOKES + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + real :: a(nth,nk,0:nseal) + type(ESMF_Field) :: p1xField,p2xField,p3xField + type(ESMF_Field) :: p1yField,p2yField,p3yField + integer :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + !real(8) :: sxxs, sxys, syys + type(ESMF_Field) :: p1xnField, p2xnField, p3xnField + type(ESMF_Field) :: p1ynField, p2ynField, p3ynField + real(ESMF_KIND_RX), pointer :: p1xn(:), p2xn(:), p3xn(:) + real(ESMF_KIND_RX), pointer :: p1yn(:), p2yn(:), p3yn(:) + integer, save :: timeSlice = 1 + integer :: isea,jsea + ! + ! -------------------------------------------------------------------- / + ! + rc = ESMF_SUCCESS + + + p1xnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + p1ynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + p2xnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + p2ynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + p3xnField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + p3ynField = ESMF_FieldCreate( natGrid, natArraySpec2D, & + staggerLoc=natStaggerLoc, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + call FieldFill( p1xnField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( p1ynField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( p2xnField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( p2ynField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( p3xnField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call FieldFill( p3ynField, zeroValue, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + if ( natGridIsLocal ) then + + call ESMF_FieldGet( p1xnField, farrayPtr=p1xn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( p1ynField, farrayPtr=p1yn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( p2xnField, farrayPtr=p2xn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( p2ynField, farrayPtr=p2yn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( p3xnField, farrayPtr=p3xn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( p3ynField, farrayPtr=p3yn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + call CALC_U3STOKES ( a , 2 ) + + jsea_loop: do jsea = 1,nseal #ifdef W3_DIST - isea = iaproc + (jsea-1)*naproc + isea = iaproc + (jsea-1)*naproc #endif #ifdef W3_SHRD - isea = jsea + isea = jsea #endif - p1xn(jsea)=ussp(jsea,1) - p1yn(jsea)=ussp(jsea,nk+1) - p2xn(jsea)=ussp(jsea,2) - p2yn(jsea)=ussp(jsea,nk+2) - p3xn(jsea)=ussp(jsea,3) - p3yn(jsea)=ussp(jsea,nk+3) - enddo jsea_loop - - endif !natGridIsLocal - - call ESMF_FieldRedist( p1xnField, p1xField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldRedist( p1ynField, p1yField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldRedist( p2xnField, p2xField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldRedist( p2ynField, p2yField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldRedist( p3xnField, p3xField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldRedist( p3ynField, p3yField, n2eRH, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - - call ESMF_FieldDestroy( p1xnField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( p2xnField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( p3xnField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( p1ynField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( p2ynField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldDestroy( p3ynField, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + p1xn(jsea)=ussp(jsea,1) + p1yn(jsea)=ussp(jsea,nk+1) + p2xn(jsea)=ussp(jsea,2) + p2yn(jsea)=ussp(jsea,nk+2) + p3xn(jsea)=ussp(jsea,3) + p3yn(jsea)=ussp(jsea,nk+3) + enddo jsea_loop + + endif !natGridIsLocal + + call ESMF_FieldRedist( p1xnField, p1xField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( p1ynField, p1yField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( p2xnField, p2xField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( p2ynField, p2yField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( p3xnField, p3xField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldRedist( p3ynField, p3yField, n2eRH, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + + call ESMF_FieldDestroy( p1xnField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( p2xnField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( p3xnField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( p1ynField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( p2ynField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldDestroy( p3ynField, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return #ifdef TEST_WMESMFMD_PSTOKES - call ESMF_FieldWrite( p1xField, "wmesmfmd_pstokes_1x.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( p1yField, "wmesmfmd_pstokes_1y.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( p2xField, "wmesmfmd_pstokes_2x.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( p2yField, "wmesmfmd_pstokes_2y.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( p3xField, "wmesmfmd_pstokes_3x.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( p3yField, "wmesmfmd_pstokes_3y.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - timeSlice = timeSlice + 1 + call ESMF_FieldWrite( p1xField, "wmesmfmd_pstokes_1x.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( p1yField, "wmesmfmd_pstokes_1y.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( p2xField, "wmesmfmd_pstokes_2x.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( p2yField, "wmesmfmd_pstokes_2y.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( p3xField, "wmesmfmd_pstokes_3x.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( p3yField, "wmesmfmd_pstokes_3y.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + timeSlice = timeSlice + 1 #endif -!/ -!/ End of CalcPStokes ----------------------------------------------- / -!/ - end subroutine CalcPStokes -!/ ------------------------------------------------------------------- / -!> -!> @brief Read input file to fill unmapped point for regional applications. -!> -!> @param[inout] idfld Field name -!> @param[inout] fldwx 2D eastward-component of field -!> @param[inout] fldwy 2D northward-component of field -!> @param[in] time0 Time stamp for current time -!> @param[in] timen Time stamp for end time -!> @param[inout] rc Return code -!> -!> @author U. Turuncoglu @date 18-May-2021 -!> + !/ + !/ End of CalcPStokes ----------------------------------------------- / + !/ + end subroutine CalcPStokes + !/ ------------------------------------------------------------------- / + !> + !> @brief Read input file to fill unmapped point for regional applications. + !> + !> @param[inout] idfld Field name + !> @param[inout] fldwx 2D eastward-component of field + !> @param[inout] fldwy 2D northward-component of field + !> @param[in] time0 Time stamp for current time + !> @param[in] timen Time stamp for end time + !> @param[inout] rc Return code + !> + !> @author U. Turuncoglu @date 18-May-2021 + !> #undef METHOD #define METHOD "ReadFromFile" - subroutine ReadFromFile (idfld, fldwx, fldwy, time0, timen, rc) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | U. Turuncoglu | -!/ | FORTRAN 90 | -!/ | Last update : 18-May-2021 | -!/ +-----------------------------------+ -!/ -!/ 18-May-2021 : Origination. ( version 7.13 ) -!/ -! 1. Purpose : -! -! Read input file to fill unmapped point for regional applications -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! idfld Str I/O Field name -! fldwx Type I/O 2D eastward-component of field -! fldwy Type I/O 2D northward-component of field -! time0 Int I Time stamp for current time -! timen Int I Time stamp for end time -! rc Int I/O Return code -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! NONE -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3FLDSMD, ONLY: W3FLDO, W3FLDG - USE WMUNITMD, ONLY: WMUGET, WMUSET - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - character(len=3), intent(inout) :: idfld - type(ESMF_Field), intent(inout) :: fldwx - type(ESMF_Field), intent(inout) :: fldwy - integer, intent(in) :: time0(2) - integer, intent(in) :: timen(2) - integer, intent(inout), optional :: rc -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - integer :: ierr, tw0l(2), twnl(2), lb(2), ub(2) - real :: wx0l(nx,ny), wy0l(nx,ny) - real :: wxnl(nx,ny), wynl(nx,ny) - real :: dt0l(nx,ny), dtnl(nx,ny) - real(ESMF_KIND_RX), pointer :: dptr(:,:) - integer :: mdse = 6 - integer :: mdst = 10 - integer, save :: mdsf - character(256) :: logmsg - logical :: flagsc = .false. - integer, parameter :: lde = 0 - logical, save :: firstCall = .true. - character(len=13) :: tsstr - character(len=3) :: tsfld - integer :: nxt, nyt, gtypet, filler(3), tideflag + subroutine ReadFromFile (idfld, fldwx, fldwy, time0, timen, rc) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | U. Turuncoglu | + !/ | FORTRAN 90 | + !/ | Last update : 18-May-2021 | + !/ +-----------------------------------+ + !/ + !/ 18-May-2021 : Origination. ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Read input file to fill unmapped point for regional applications + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! idfld Str I/O Field name + ! fldwx Type I/O 2D eastward-component of field + ! fldwy Type I/O 2D northward-component of field + ! time0 Int I Time stamp for current time + ! timen Int I Time stamp for end time + ! rc Int I/O Return code + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! NONE + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3FLDSMD, ONLY: W3FLDO, W3FLDG + USE WMUNITMD, ONLY: WMUGET, WMUSET + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + character(len=3), intent(inout) :: idfld + type(ESMF_Field), intent(inout) :: fldwx + type(ESMF_Field), intent(inout) :: fldwy + integer, intent(in) :: time0(2) + integer, intent(in) :: timen(2) + integer, intent(inout), optional :: rc + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + integer :: ierr, tw0l(2), twnl(2), lb(2), ub(2) + real :: wx0l(nx,ny), wy0l(nx,ny) + real :: wxnl(nx,ny), wynl(nx,ny) + real :: dt0l(nx,ny), dtnl(nx,ny) + real(ESMF_KIND_RX), pointer :: dptr(:,:) + integer :: mdse = 6 + integer :: mdst = 10 + integer, save :: mdsf + character(256) :: logmsg + logical :: flagsc = .false. + integer, parameter :: lde = 0 + logical, save :: firstCall = .true. + character(len=13) :: tsstr + character(len=3) :: tsfld + integer :: nxt, nyt, gtypet, filler(3), tideflag #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_READFROMFILE) - integer, save :: timeSlice = 1 + integer, save :: timeSlice = 1 #endif -! -! -------------------------------------------------------------------- / -! - rc = ESMF_SUCCESS - - if (firstCall) then - ! assign unit number for input file - call wmuget(mdse, mdst, mdsf, 'INP') - call wmuset(mdse, mdst, mdsf, .true., desc='Input data file') - - ! open file - call w3fldo('READ', idfld, mdsf, mdst, mdse, nx, ny, gtype, ierr) - if (ierr.ne.0) then - write(logmsg,*) "Error in opening "//idfld//", iostat = ", ierr - call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return - endif - - firstCall = .false. - end if + ! + ! -------------------------------------------------------------------- / + ! + rc = ESMF_SUCCESS + + if (firstCall) then + ! assign unit number for input file + call wmuget(mdse, mdst, mdsf, 'INP') + call wmuset(mdse, mdst, mdsf, .true., desc='Input data file') + + ! open file + call w3fldo('READ', idfld, mdsf, mdst, mdse, nx, ny, gtype, ierr) + if (ierr.ne.0) then + write(logmsg,*) "Error in opening "//idfld//", iostat = ", ierr + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif - ! init variables - wx0l = 0.0 - wy0l = 0.0 - dt0l = 0.0 - wxnl = 0.0 - wynl = 0.0 - dtnl = 0.0 - - ! need to rewind to the begining of the file to access - ! data of requested date correctly - rewind(mdsf) - - ! read header information - ! this was inside of w3fldo call but since we are opening file - ! once and rewinding, the header need to be read - read(mdsf, iostat=ierr) tsstr, tsfld, nxt, nyt, & - gtypet, filler(1:2), tideflag - - ! read input - call w3fldg('READ', idfld, mdsf, mdst, mdse, nx, ny, & - nx, ny, time0, timen, tw0l, wx0l, wy0l, dt0l, twnl, & - wxnl, wynl, dtnl, ierr, flagsc) - - ! fill fields with data belong to current time - if ( impGridIsLocal ) then - call ESMF_FieldGet(fldwx, localDE=lde, farrayPtr=dptr, & - exclusiveLBound=lb, exclusiveUBound=ub, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - dptr(lb(1):ub(1),lb(2):ub(2)) = wx0l(lb(1):ub(1),lb(2):ub(2)) - if (associated(dptr)) nullify(dptr) - call ESMF_FieldGet(fldwy, localDE=lde, farrayPtr=dptr, & - exclusiveLBound=lb, exclusiveUBound=ub, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - dptr(lb(1):ub(1),lb(2):ub(2)) = wy0l(lb(1):ub(1),lb(2):ub(2)) - if (associated(dptr)) nullify(dptr) - end if + firstCall = .false. + end if + + ! init variables + wx0l = 0.0 + wy0l = 0.0 + dt0l = 0.0 + wxnl = 0.0 + wynl = 0.0 + dtnl = 0.0 + + ! need to rewind to the begining of the file to access + ! data of requested date correctly + rewind(mdsf) + + ! read header information + ! this was inside of w3fldo call but since we are opening file + ! once and rewinding, the header need to be read + read(mdsf, iostat=ierr) tsstr, tsfld, nxt, nyt, & + gtypet, filler(1:2), tideflag + + ! read input + call w3fldg('READ', idfld, mdsf, mdst, mdse, nx, ny, & + nx, ny, time0, timen, tw0l, wx0l, wy0l, dt0l, twnl, & + wxnl, wynl, dtnl, ierr, flagsc) + + ! fill fields with data belong to current time + if ( impGridIsLocal ) then + call ESMF_FieldGet(fldwx, localDE=lde, farrayPtr=dptr, & + exclusiveLBound=lb, exclusiveUBound=ub, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + dptr(lb(1):ub(1),lb(2):ub(2)) = wx0l(lb(1):ub(1),lb(2):ub(2)) + if (associated(dptr)) nullify(dptr) + call ESMF_FieldGet(fldwy, localDE=lde, farrayPtr=dptr, & + exclusiveLBound=lb, exclusiveUBound=ub, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + dptr(lb(1):ub(1),lb(2):ub(2)) = wy0l(lb(1):ub(1),lb(2):ub(2)) + if (associated(dptr)) nullify(dptr) + end if #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_READFROMFILE) - write(logmsg,*) 'time0 = ', time0(1), time0(2) - call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - write(logmsg,*) 'timen = ', timen(1), timen(2) - call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - write(logmsg,*) 'tw0 = ', tw0l(1), tw0l(2) - call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - write(logmsg,*) 'twn = ', twnl(1), twnl(2) - call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - write(logmsg,*) 'wx0 min, max = ', minval(wx0l), maxval(wx0l) - call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - write(logmsg,*) 'wy0 min, max = ', minval(wy0l), maxval(wy0l) - call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - write(logmsg,*) 'wxn min, max = ', minval(wxnl), maxval(wxnl) - call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - write(logmsg,*) 'wyn min, max = ', minval(wynl), maxval(wynl) - call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( fldwx, & - "wmesmfmd_read_wx0.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - call ESMF_FieldWrite( fldwy, & - "wmesmfmd_read_wy0.nc", & - overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return - timeSlice = timeSlice + 1 + write(logmsg,*) 'time0 = ', time0(1), time0(2) + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + write(logmsg,*) 'timen = ', timen(1), timen(2) + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + write(logmsg,*) 'tw0 = ', tw0l(1), tw0l(2) + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + write(logmsg,*) 'twn = ', twnl(1), twnl(2) + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + write(logmsg,*) 'wx0 min, max = ', minval(wx0l), maxval(wx0l) + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + write(logmsg,*) 'wy0 min, max = ', minval(wy0l), maxval(wy0l) + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + write(logmsg,*) 'wxn min, max = ', minval(wxnl), maxval(wxnl) + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + write(logmsg,*) 'wyn min, max = ', minval(wynl), maxval(wynl) + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( fldwx, & + "wmesmfmd_read_wx0.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldWrite( fldwy, & + "wmesmfmd_read_wy0.nc", & + overwrite=.true., timeSlice=timeSlice, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + timeSlice = timeSlice + 1 #endif -!/ -!/ End of ReadFromFile ------------------------------------------- / -!/ - end subroutine ReadFromFile -!/ ------------------------------------------------------------------- / -!/ -!/ End of module WMESMFMD -------------------------------------------- / -!/ - end module WMESMFMD + !/ + !/ End of ReadFromFile ------------------------------------------- / + !/ + end subroutine ReadFromFile + !/ ------------------------------------------------------------------- / + !/ + !/ End of module WMESMFMD -------------------------------------------- / + !/ +end module WMESMFMD diff --git a/model/src/wmfinlmd.F90 b/model/src/wmfinlmd.F90 index 25031e366..7217bdb2f 100644 --- a/model/src/wmfinlmd.F90 +++ b/model/src/wmfinlmd.F90 @@ -1,248 +1,248 @@ !> @file !> @brief Contains module WMFINLMD. -!> +!> !> @author H. L. Tolman @date 04-Feb-2014 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / !> !> @brief Finalization of the multi-grid wave model. -!> -!> @author H. L. Tolman @date 04-Feb-2014 !> - MODULE WMFINLMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 04-Feb-2014 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2005 : Origination. ( version 3.07 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 03-Sep-2012 : Output of initilization time. ( version 4.10 ) -!/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) -!/ 04-Feb-2014 : Switched clock to DATE_AND_TIME ( version 4.18 ) -!/ (A. Chawla and Mark Szyszka) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Finalization of the multi-grid wave model. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WMFINL Subr. Public Wave model initialization. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize multi-grid version of WAVEWATCH III. +!> @author H. L. Tolman @date 04-Feb-2014 !> -!> @author H. L. Tolman @date 28-Jan-2014 -!> - SUBROUTINE WMFINL -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 28-Jan-2014 | -!/ +-----------------------------------+ -!/ -!/ 06-May-2005 : Origination. ( version 3.07 ) -!/ 03-Sep-2012 : Output of initilization time. ( version 4.10 ) -!/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) -!/ -! 1. Purpose : -! -! Initialize multi-grid version of WAVEWATCH III. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! PRTIME Subr. W3SERVMD Profiling routine ( !/MPRF ) -! MPI_BARRIER -! Subr. Standard MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_MULTI Prog. N/A Multi-grid model driver. -! .... Any coupled model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI MPI routines. -! -! !/O10 Enable output identifying start and end of routine -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/MPRF Profiling. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +MODULE WMFINLMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 04-Feb-2014 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2005 : Origination. ( version 3.07 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 03-Sep-2012 : Output of initilization time. ( version 4.10 ) + !/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) + !/ 04-Feb-2014 : Switched clock to DATE_AND_TIME ( version 4.18 ) + !/ (A. Chawla and Mark Szyszka) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Finalization of the multi-grid wave model. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WMFINL Subr. Public Wave model initialization. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize multi-grid version of WAVEWATCH III. + !> + !> @author H. L. Tolman @date 28-Jan-2014 + !> + SUBROUTINE WMFINL + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 28-Jan-2014 | + !/ +-----------------------------------+ + !/ + !/ 06-May-2005 : Origination. ( version 3.07 ) + !/ 03-Sep-2012 : Output of initilization time. ( version 4.10 ) + !/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) + !/ + ! 1. Purpose : + ! + ! Initialize multi-grid version of WAVEWATCH III. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! PRTIME Subr. W3SERVMD Profiling routine ( !/MPRF ) + ! MPI_BARRIER + ! Subr. Standard MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_MULTI Prog. N/A Multi-grid model driver. + ! .... Any coupled model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI MPI routines. + ! + ! !/O10 Enable output identifying start and end of routine + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/MPRF Profiling. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_MPRF -! use w3getmem ; fake use statement for make_makefile.sh -! + ! use w3getmem ; fake use statement for make_makefile.sh + ! #endif - USE W3TIMEMD, ONLY: TDIFF - USE WMMDATMD, ONLY: MDSS, MDSO, NMPSCR, NMPLOG, IMPROC - USE WMMDATMD, ONLY: CLKDT1, CLKDT2, CLKDT3, CLKFIN + USE W3TIMEMD, ONLY: TDIFF + USE WMMDATMD, ONLY: MDSS, MDSO, NMPSCR, NMPLOG, IMPROC + USE WMMDATMD, ONLY: CLKDT1, CLKDT2, CLKDT3, CLKFIN #ifdef W3_MPRF - USE WMMDATMD, ONLY: MDSP + USE WMMDATMD, ONLY: MDSP #endif #ifdef W3_MPI - USE WMMDATMD, ONLY: MPI_COMM_MWAVE + USE WMMDATMD, ONLY: MPI_COMM_MWAVE #endif -!/ + !/ #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_MPRF - USE W3TIMEMD, ONLY: PRTIME + USE W3TIMEMD, ONLY: PRTIME #endif -!/ - IMPLICIT NONE -! + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_MPI - INTEGER :: IERR_MPI + INTEGER :: IERR_MPI #endif #ifdef W3_MPRF - REAL :: PRFT0, PRFTN - REAL(KIND=8) :: get_memory + REAL :: PRFT0, PRFTN + REAL(KIND=8) :: get_memory #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -! 1. Identification at start -! + !/ + !/ ------------------------------------------------------------------- / + ! 1. Identification at start + ! #ifdef W3_S - CALL STRACE (IENT, 'WMFINL') + CALL STRACE (IENT, 'WMFINL') #endif #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) + CALL PRTIME ( PRFT0 ) #endif -! + ! #ifdef W3_O10 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) #endif -! -!/ ------------------------------------------------------------------- / -! 2. Finalization -! + ! + !/ ------------------------------------------------------------------- / + ! 2. Finalization + ! #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) #endif -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,920) CLKFIN - IF ( NMPLOG.EQ.IMPROC ) WRITE (MDSO,920) CLKFIN + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,920) CLKFIN + IF ( NMPLOG.EQ.IMPROC ) WRITE (MDSO,920) CLKFIN - CALL DATE_AND_TIME ( VALUES=CLKDT3 ) + CALL DATE_AND_TIME ( VALUES=CLKDT3 ) - CLKFIN = TDIFF ( CLKDT1,CLKDT3 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,921) CLKFIN - IF ( NMPLOG.EQ.IMPROC ) WRITE (MDSO,921) CLKFIN -! -!/ ------------------------------------------------------------------- / -! 3. Identification at end -! + CLKFIN = TDIFF ( CLKDT1,CLKDT3 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,921) CLKFIN + IF ( NMPLOG.EQ.IMPROC ) WRITE (MDSO,921) CLKFIN + ! + !/ ------------------------------------------------------------------- / + ! 3. Identification at end + ! #ifdef W3_O10 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) #endif -! + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory() -#endif -! - RETURN -! -! Formats -! - 900 FORMAT ( ' ========== STARTING MWW3 FINALIZATION (WMFINL) ===', & - '============================' ) - 920 FORMAT (/' Initialization time :',F10.2,' s') - 921 FORMAT ( ' Elapsed time :',F10.2,' s') + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory() +#endif + ! + RETURN + ! + ! Formats + ! +900 FORMAT ( ' ========== STARTING MWW3 FINALIZATION (WMFINL) ===', & + '============================' ) +920 FORMAT (/' Initialization time :',F10.2,' s') +921 FORMAT ( ' Elapsed time :',F10.2,' s') -! + ! #ifdef W3_MPRF - 990 FORMAT (1X,3F12.3,' WMFINL') -#endif -! - 999 FORMAT (/' ========== END OF MWW3 INITIALIZATION (WMFINL) ===', & - '============================'/) -!/ -!/ End of WMFINL ----------------------------------------------------- / -!/ - END SUBROUTINE WMFINL -!/ -!/ End of module WMFINLMD -------------------------------------------- / -!/ - END MODULE WMFINLMD +990 FORMAT (1X,3F12.3,' WMFINL') +#endif + ! +999 FORMAT (/' ========== END OF MWW3 INITIALIZATION (WMFINL) ===', & + '============================'/) + !/ + !/ End of WMFINL ----------------------------------------------------- / + !/ + END SUBROUTINE WMFINL + !/ + !/ End of module WMFINLMD -------------------------------------------- / + !/ +END MODULE WMFINLMD diff --git a/model/src/wmgridmd.F90 b/model/src/wmgridmd.F90 index c1984a354..9c5c00cd7 100644 --- a/model/src/wmgridmd.F90 +++ b/model/src/wmgridmd.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains module WMGRIDMD. -!> +!> !> @author H. L. Tolman !> @author W. E. Rogers !> @date 10-Dec-2014 @@ -9,6080 +9,6080 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / !> -!> @brief Routines to determine and process grid dependencies in the +!> @brief Routines to determine and process grid dependencies in the !> multi-grid wave model. -!> +!> !> @author H. L. Tolman !> @author W. E. Rogers !> @date 10-Dec-2014 !> - MODULE WMGRIDMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | W. E. Rogers | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 | -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2005 : Origination WMGLOW, WMGHGH, WMRSPC. ( version 3.08 ) -!/ 09-Mar-2006 : Carry land mask in WMGHGH. ( version 3.09 ) -!/ 24-Apr-2006 : Origination WMGEQL. ( version 3.09 ) -!/ 25-Jul-2006 : Point output grid in WMRSPC. ( version 3.10 ) -!/ 23-Dec-2006 : Adding group test in WMGEQL. ( version 3.10 ) -!/ 28-Dec-2006 : Simplify NIT for partial comm. ( version 3.10 ) -!/ 22-Jan-2007 : Add saving of NAVMAX in WMGEQL. ( version 3.10 ) -!/ 02-Feb-2007 : Setting FLAGST in WMGEQL. ( version 3.10 ) -!/ 07-Feb-2007 : Setting FLAGST in WMGHGH. ( version 3.10 ) -!/ 15-Feb-2007 : Tweaking MAPODI algorithm in WMGEQL.( version 3.10 ) -!/ 11-Apr-2008 : Bug fix active edges WMGEQL. ( version 3.13 ) -!/ 14-Apr-2008 : Bug fix for global grids WMGEQL. ( version 3.13 ) -!/ 26-Mar-2009 : Adding test output !/T9 to WMGLOW. ( version 3.14 ) -!/ 20-May-2009 : Linking FLAGST and FLGHG1. ( version 3.14 ) -!/ 26-May-2009 : Fix erroneous cyclic upd in WMGHGH. ( version 3.14 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) -!/ factor with DXDP and DXDQ terms. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 12-Mar-2012 : Use MPI_COMM_NULL in checks. ( version 3.14 ) -!/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) -!/ 05-Sep-2012 : Implementation of UNGTYPE with SCRIP -!/ (Mathieu Dutour Sikiric, IRB; Aron Roland, Z&P) -!/ 21-Sep-2012 : Modify WMGHGH to support SCRIP remap( version 4.11 ) -!/ write/read capabilities (K. Lind, NRL) -!/ 05-Aug-2013 : Change PR2/3 to UQ/UNO in distances.( version 4.12 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 28-Oct-2020 : Add SMCTYPE for SMC sub-grid. JGLi ( version 7.13 ) -!/ 26-Jan-2021 : Add WMSMCEQL for SMC sub-grid. JGLi ( version 7.13 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Routines to determine and process grid dependencies in the -! multi-grid wave model. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WMGLOW Subr. Public Dependencies to lower ranked grids. -! WMGHGH Subr. Public Dependencies to higher ranked grids. -! WMGEQL Subr. Public Dependencies to same ranked grids. -! WMRSPC Subr. Public Make map of flags for spectral -! conversion between grids. -! WMSMCEQL Subr. Public Dependencies on same ranked SMC grids. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETO, W3SETG, W3DMO5, WMSETM -! Subr. W3xDATMD Manage data structures. -! -! STRACE Sur. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! -! MPI_BCAST, MPI_BARRIER -! Subr. mpif.h Comunication routines. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - WMGLOW and WMGHGH need to be run in this order to -! assure proper resolving of cross-dependencies. -! - WMGLOW and WMGEQL, idem. -! -! 6. Switches : -! -! !/PRn propagation scheme. -! !/UQ propagation scheme. -! !/UNO propagation scheme. -! !/SMC Enable SMC sub-grids. -! -! !/SHRD Distributed memory approach -! !/DIST -! !/MPI -! -! !/O12 Removed boundary points output WMGEQL (central). -! !/O13 Removed boundary points output WMGEQL (edge). -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ Specify default accessibility -!/ - PUBLIC -!/ -!/ Module private variable for checking error returns -!/ - INTEGER, PRIVATE :: ISTAT !< ISTAT Checking error returns. -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Determine relations to lower ranked grids for each grid. -!> -!> @details On the fly, the opposite relations are also saved. -!> Map active boundary points to lower ranked grids. -!> -!> @param[out] FLRBPI Array with flags for external file use. -!> -!> @author H. L. Tolman -!> @author W. E. Rogers -!> @date 06-Jun-2018 -!> - SUBROUTINE WMGLOW ( FLRBPI ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | W. E. Rogers | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018 ! -!/ +-----------------------------------+ -!/ -!/ 06-Oct-2005 : Origination. ( version 3.08 ) -!/ 10-Feb-2006 : Add test on grid resolution. ( version 3.09 ) -!/ 26-Mar-2009 : Adding test output !/T9. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 22-Dec-2010 : Adapt for use with irregular grids ( version 3.14 ) -!/ (W. E. Rogers, NRL) -!/ 12-Mar-2012 : Use MPI_COMM_NULL in checks. ( version 4.07 ) -!/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 06-Jun-2018 : Use W3PARALL ( version 6.04 ) -!/ -! 1. Purpose : -! -! Determine relations to lower ranked grids for each grid. -! On the fly, the opposite relations are also saved. -! -! 2. Method : -! -! Map active boundary points to lower ranked grids. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! FLRBPI L.A. O Array with flags for external file use. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETO, W3SETG, W3DMO5 -! Subr. W3xDATMD Manage data structures. -! -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! -! MPI_BCAST, MPI_BARRIER -! Subr. mpif.h Comunication routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINIT Subr WMINITMD Multi-grid model initialization. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - For MPI version it is assumed that NX, NY, NSEA, and NSEAL are -! properly initialized even if the grid is not run on the local -! process. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Distribbuted memory management. -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T1 Test output for individual boundary points -! !/T2 Test output cross-reference table -! !/T9 Test output of map of boundary origine. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3SERVMD, ONLY: EXTCDE +MODULE WMGRIDMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | W. E. Rogers | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 | + !/ +-----------------------------------+ + !/ + !/ 28-Dec-2005 : Origination WMGLOW, WMGHGH, WMRSPC. ( version 3.08 ) + !/ 09-Mar-2006 : Carry land mask in WMGHGH. ( version 3.09 ) + !/ 24-Apr-2006 : Origination WMGEQL. ( version 3.09 ) + !/ 25-Jul-2006 : Point output grid in WMRSPC. ( version 3.10 ) + !/ 23-Dec-2006 : Adding group test in WMGEQL. ( version 3.10 ) + !/ 28-Dec-2006 : Simplify NIT for partial comm. ( version 3.10 ) + !/ 22-Jan-2007 : Add saving of NAVMAX in WMGEQL. ( version 3.10 ) + !/ 02-Feb-2007 : Setting FLAGST in WMGEQL. ( version 3.10 ) + !/ 07-Feb-2007 : Setting FLAGST in WMGHGH. ( version 3.10 ) + !/ 15-Feb-2007 : Tweaking MAPODI algorithm in WMGEQL.( version 3.10 ) + !/ 11-Apr-2008 : Bug fix active edges WMGEQL. ( version 3.13 ) + !/ 14-Apr-2008 : Bug fix for global grids WMGEQL. ( version 3.13 ) + !/ 26-Mar-2009 : Adding test output !/T9 to WMGLOW. ( version 3.14 ) + !/ 20-May-2009 : Linking FLAGST and FLGHG1. ( version 3.14 ) + !/ 26-May-2009 : Fix erroneous cyclic upd in WMGHGH. ( version 3.14 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) + !/ factor with DXDP and DXDQ terms. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 12-Mar-2012 : Use MPI_COMM_NULL in checks. ( version 3.14 ) + !/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) + !/ 05-Sep-2012 : Implementation of UNGTYPE with SCRIP + !/ (Mathieu Dutour Sikiric, IRB; Aron Roland, Z&P) + !/ 21-Sep-2012 : Modify WMGHGH to support SCRIP remap( version 4.11 ) + !/ write/read capabilities (K. Lind, NRL) + !/ 05-Aug-2013 : Change PR2/3 to UQ/UNO in distances.( version 4.12 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 28-Oct-2020 : Add SMCTYPE for SMC sub-grid. JGLi ( version 7.13 ) + !/ 26-Jan-2021 : Add WMSMCEQL for SMC sub-grid. JGLi ( version 7.13 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Routines to determine and process grid dependencies in the + ! multi-grid wave model. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WMGLOW Subr. Public Dependencies to lower ranked grids. + ! WMGHGH Subr. Public Dependencies to higher ranked grids. + ! WMGEQL Subr. Public Dependencies to same ranked grids. + ! WMRSPC Subr. Public Make map of flags for spectral + ! conversion between grids. + ! WMSMCEQL Subr. Public Dependencies on same ranked SMC grids. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETO, W3SETG, W3DMO5, WMSETM + ! Subr. W3xDATMD Manage data structures. + ! + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! + ! MPI_BCAST, MPI_BARRIER + ! Subr. mpif.h Comunication routines. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - WMGLOW and WMGHGH need to be run in this order to + ! assure proper resolving of cross-dependencies. + ! - WMGLOW and WMGEQL, idem. + ! + ! 6. Switches : + ! + ! !/PRn propagation scheme. + ! !/UQ propagation scheme. + ! !/UNO propagation scheme. + ! !/SMC Enable SMC sub-grids. + ! + ! !/SHRD Distributed memory approach + ! !/DIST + ! !/MPI + ! + ! !/O12 Removed boundary points output WMGEQL (central). + ! !/O13 Removed boundary points output WMGEQL (edge). + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ Specify default accessibility + !/ + PUBLIC + !/ + !/ Module private variable for checking error returns + !/ + INTEGER, PRIVATE :: ISTAT !< ISTAT Checking error returns. + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Determine relations to lower ranked grids for each grid. + !> + !> @details On the fly, the opposite relations are also saved. + !> Map active boundary points to lower ranked grids. + !> + !> @param[out] FLRBPI Array with flags for external file use. + !> + !> @author H. L. Tolman + !> @author W. E. Rogers + !> @date 06-Jun-2018 + !> + SUBROUTINE WMGLOW ( FLRBPI ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | W. E. Rogers | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018 ! + !/ +-----------------------------------+ + !/ + !/ 06-Oct-2005 : Origination. ( version 3.08 ) + !/ 10-Feb-2006 : Add test on grid resolution. ( version 3.09 ) + !/ 26-Mar-2009 : Adding test output !/T9. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 22-Dec-2010 : Adapt for use with irregular grids ( version 3.14 ) + !/ (W. E. Rogers, NRL) + !/ 12-Mar-2012 : Use MPI_COMM_NULL in checks. ( version 4.07 ) + !/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 06-Jun-2018 : Use W3PARALL ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Determine relations to lower ranked grids for each grid. + ! On the fly, the opposite relations are also saved. + ! + ! 2. Method : + ! + ! Map active boundary points to lower ranked grids. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! FLRBPI L.A. O Array with flags for external file use. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETO, W3SETG, W3DMO5 + ! Subr. W3xDATMD Manage data structures. + ! + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! + ! MPI_BCAST, MPI_BARRIER + ! Subr. mpif.h Comunication routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINIT Subr WMINITMD Multi-grid model initialization. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - For MPI version it is assumed that NX, NY, NSEA, and NSEAL are + ! properly initialized even if the grid is not run on the local + ! process. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Distribbuted memory management. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T1 Test output for individual boundary points + ! !/T2 Test output cross-reference table + ! !/T9 Test output of map of boundary origine. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD - USE W3ODATMD - USE W3TRIAMD - USE WMMDATMD - USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC -! - IMPLICIT NONE -! + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD + USE W3ODATMD + USE W3TRIAMD + USE WMMDATMD + USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - LOGICAL, INTENT(OUT), OPTIONAL :: FLRBPI(NRGRD) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, IBI, IX, IY, JS, J, & - JTOT, I1, J1, I2, J2 + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + LOGICAL, INTENT(OUT), OPTIONAL :: FLRBPI(NRGRD) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, IBI, IX, IY, JS, J, & + JTOT, I1, J1, I2, J2 #ifdef W3_MPI - INTEGER :: NXYG, IERR_MPI + INTEGER :: NXYG, IERR_MPI #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, ALLOCATABLE :: TSTORE(:,:) + INTEGER, ALLOCATABLE :: TSTORE(:,:) #ifdef W3_MPI - LOGICAL :: FLBARR -#endif - REAL :: XA, YA - REAL :: FACTOR - LOGICAL :: GRIDD(NRGRD,NRGRD) ! indicates grid-to-grid - ! dependency - LOGICAL :: RFILE(NRGRD), FLAGOK - LOGICAL :: INGRID ! indicates whether boundary point - ! is in lower rank grid - INTEGER :: IVER(4),JVER(4) ! (I,J) indices of vertices - ! of cell (in lower rank grid J) enclosing - ! boundary point (in higher rank grid I) - REAL :: RW(4) ! Array of interpolation weights. - INTEGER :: KVER ! counter for 4 vertices - - REAL :: DX_MIN_GRIDI,DY_MIN_GRIDI,DX_MAX_GRIDI, & - DY_MAX_GRIDI - REAL :: DX_MIN_GRIDJ,DY_MIN_GRIDJ,DX_MAX_GRIDJ, & - DY_MAX_GRIDJ - INTEGER :: ITRI, IM1, IM2, IT, JT, ISFIRST, ITOUT, NBRELEVANT - REAL :: DIST_MIN, DIST_MAX, EDIST - LOGICAL RESOL_CHECK -! + LOGICAL :: FLBARR +#endif + REAL :: XA, YA + REAL :: FACTOR + LOGICAL :: GRIDD(NRGRD,NRGRD) ! indicates grid-to-grid + ! dependency + LOGICAL :: RFILE(NRGRD), FLAGOK + LOGICAL :: INGRID ! indicates whether boundary point + ! is in lower rank grid + INTEGER :: IVER(4),JVER(4) ! (I,J) indices of vertices + ! of cell (in lower rank grid J) enclosing + ! boundary point (in higher rank grid I) + REAL :: RW(4) ! Array of interpolation weights. + INTEGER :: KVER ! counter for 4 vertices + + REAL :: DX_MIN_GRIDI,DY_MIN_GRIDI,DX_MAX_GRIDI, & + DY_MAX_GRIDI + REAL :: DX_MIN_GRIDJ,DY_MIN_GRIDJ,DX_MAX_GRIDJ, & + DY_MAX_GRIDJ + INTEGER :: ITRI, IM1, IM2, IT, JT, ISFIRST, ITOUT, NBRELEVANT + REAL :: DIST_MIN, DIST_MAX, EDIST + LOGICAL RESOL_CHECK + ! #ifdef W3_T9 - CHARACTER(LEN=1), ALLOCATABLE :: TMAP(:,:) + CHARACTER(LEN=1), ALLOCATABLE :: TMAP(:,:) #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMGLOW') + CALL STRACE (IENT, 'WMGLOW') #endif -! -! -------------------------------------------------------------------- / -! 1. Test grid, Initialize and synchronize grids as needed ( !/MPI ) -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test grid, Initialize and synchronize grids as needed ( !/MPI ) + ! #ifdef W3_MPI - FLBARR = .FALSE. -#endif -! - DO I=1, NRGRD -! - IF ( .NOT. GRIDS(I)%GINIT ) THEN - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1000) I - CALL EXTCDE ( 1000 ) - END IF + FLBARR = .FALSE. +#endif + ! + DO I=1, NRGRD + ! + IF ( .NOT. GRIDS(I)%GINIT ) THEN + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1000) I + CALL EXTCDE ( 1000 ) + END IF - CALL W3SETO ( I, MDSE, MDST ) - CALL W3SETG ( I, MDSE, MDST ) -! + CALL W3SETO ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) + ! #ifdef W3_MPI - FLBARR = FLBARR .OR. MDATAS(I)%FBCAST - IF ( MDATAS(I)%FBCAST .AND. & - MDATAS(I)%MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN - NXYG = GRIDS(I)%NX * GRIDS(I)%NY - CALL MPI_BCAST ( GRIDS(I)%MAPSTA(1,1), NXYG, & - MPI_INTEGER, 0, & - MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( GRIDS(I)%MAPST2(1,1), NXYG, & - MPI_INTEGER, 0, & - MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( GRIDS(I)%MAPFS (1,1), NXYG, & - MPI_INTEGER, 0, & - MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) - NXYG = 3*GRIDS(I)%NSEA - CALL MPI_BCAST ( GRIDS(I)%MAPSF (1,1), NXYG, & - MPI_INTEGER, 0, & - MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( GRIDS(I)%CLATIS(1), NSEA, MPI_REAL, 0,& - MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( SGRDS(I)%SIG(0), NK+2, MPI_REAL, 0,& - MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) - END IF -#endif -! - END DO -! + FLBARR = FLBARR .OR. MDATAS(I)%FBCAST + IF ( MDATAS(I)%FBCAST .AND. & + MDATAS(I)%MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN + NXYG = GRIDS(I)%NX * GRIDS(I)%NY + CALL MPI_BCAST ( GRIDS(I)%MAPSTA(1,1), NXYG, & + MPI_INTEGER, 0, & + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRIDS(I)%MAPST2(1,1), NXYG, & + MPI_INTEGER, 0, & + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRIDS(I)%MAPFS (1,1), NXYG, & + MPI_INTEGER, 0, & + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + NXYG = 3*GRIDS(I)%NSEA + CALL MPI_BCAST ( GRIDS(I)%MAPSF (1,1), NXYG, & + MPI_INTEGER, 0, & + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRIDS(I)%CLATIS(1), NSEA, MPI_REAL, 0,& + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( SGRDS(I)%SIG(0), NK+2, MPI_REAL, 0,& + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + END IF +#endif + ! + END DO + ! #ifdef W3_MPI - IF (FLBARR) CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) + IF (FLBARR) CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) #endif -! + ! #ifdef W3_T - WRITE (MDST,9010) + WRITE (MDST,9010) #endif -! + ! #ifdef W3_SMC - !! Check GTYPE for all grids. - IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) " GTYPES in WMGLOW:", & - ( GRIDS(I)%GTYPE, I=1, NRGRD ) -#endif -! -! -------------------------------------------------------------------- / -! 2. Process grids -! - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF -! - GRIDD = .FALSE. - RFILE = .FALSE. -! - IF ( .NOT. ALLOCATED(NBI2G) ) THEN - ALLOCATE ( NBI2G(NRGRD,NRGRD), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - NBI2G = 0 -! + !! Check GTYPE for all grids. + IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) " GTYPES in WMGLOW:", & + ( GRIDS(I)%GTYPE, I=1, NRGRD ) +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Process grids + ! + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + ! + GRIDD = .FALSE. + RFILE = .FALSE. + ! + IF ( .NOT. ALLOCATED(NBI2G) ) THEN + ALLOCATE ( NBI2G(NRGRD,NRGRD), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + NBI2G = 0 + ! #ifdef W3_T - WRITE (MDST,9020) + WRITE (MDST,9020) #endif -! - DO I=1, NRGRD -! + ! + DO I=1, NRGRD + ! #ifdef W3_T - WRITE (MDST,9021) I, GRANK(I), OUTPTS(I)%OUT5%NBI + WRITE (MDST,9021) I, GRANK(I), OUTPTS(I)%OUT5%NBI #endif -! -! 2.a Test for input boundary points -! - IF ( OUTPTS(I)%OUT5%NBI .EQ. 0 ) THEN + ! + ! 2.a Test for input boundary points + ! + IF ( OUTPTS(I)%OUT5%NBI .EQ. 0 ) THEN #ifdef W3_T - WRITE (MDST,9022) 'NO INPUT BOUNDARY POINTS, SKIPPING' + WRITE (MDST,9022) 'NO INPUT BOUNDARY POINTS, SKIPPING' #endif - CYCLE - END IF -! -! 2.b Test for lowest rank -! - IF ( GRANK(I) .EQ. 1 ) THEN - RFILE(I) = .TRUE. + CYCLE + END IF + ! + ! 2.b Test for lowest rank + ! + IF ( GRANK(I) .EQ. 1 ) THEN + RFILE(I) = .TRUE. #ifdef W3_T - WRITE (MDST,9022) 'RANK = 1, DATA FROM FILE' + WRITE (MDST,9022) 'RANK = 1, DATA FROM FILE' #endif - CYCLE - END IF -! + CYCLE + END IF + ! #ifdef W3_SMC - !! SMC grid only appears in same ranked group. JGLi23Mar2021 - IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN - IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) ' WMGLOW skip SMC grid', I - CYCLE - END IF + !! SMC grid only appears in same ranked group. JGLi23Mar2021 + IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN + IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) ' WMGLOW skip SMC grid', I + CYCLE + END IF #endif -! -! 2.c Search for input boundary points -! + ! + ! 2.c Search for input boundary points + ! #ifdef W3_T - WRITE (MDST,9022) 'SEARCHING FOR ACTIVE BOUNDARY POINTS' -#endif - IBI = 0 -! -! ... Set up data structure for grid -! - CALL W3SETO ( I, MDSE, MDST ) - CALL W3SETG ( I, MDSE, MDST ) - CALL W3DMO5 ( I, MDSE, MDST, 1 ) - ALLOCATE ( TSTORE(NBI,0:4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! -! ... Set up loop structure for grid -! - DO IY=1, NY - DO IX=1, NX - -!notes : MAPSTA refers to GRIDS(I)%MAPSTA ...this is set in W3SETG - IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 ) THEN - XA = REAL(XGRD(IY,IX)) !old code: X0 + REAL(IX-1)*SX - YA = REAL(YGRD(IY,IX)) !old code: Y0 + REAL(IY-1)*SY -! -! ... Loop over previous (lower ranked) grids, going in order from highest -! of lower ranked grids (I-1) to lowest of lower ranked grids (1) -! - JS = 0 -! - DO J=I-1, 1, -1 -! - IF ( GRANK(J) .GE. GRANK(I) ) CYCLE -! + WRITE (MDST,9022) 'SEARCHING FOR ACTIVE BOUNDARY POINTS' +#endif + IBI = 0 + ! + ! ... Set up data structure for grid + ! + CALL W3SETO ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) + CALL W3DMO5 ( I, MDSE, MDST, 1 ) + ALLOCATE ( TSTORE(NBI,0:4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + ! ... Set up loop structure for grid + ! + DO IY=1, NY + DO IX=1, NX + + !notes : MAPSTA refers to GRIDS(I)%MAPSTA ...this is set in W3SETG + IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 ) THEN + XA = REAL(XGRD(IY,IX)) !old code: X0 + REAL(IX-1)*SX + YA = REAL(YGRD(IY,IX)) !old code: Y0 + REAL(IY-1)*SY + ! + ! ... Loop over previous (lower ranked) grids, going in order from highest + ! of lower ranked grids (I-1) to lowest of lower ranked grids (1) + ! + JS = 0 + ! + DO J=I-1, 1, -1 + ! + IF ( GRANK(J) .GE. GRANK(I) ) CYCLE + ! #ifdef W3_SMC - !! SMC grid only suppots same ranked group so far. JGLi12Apr2021 - IF( GRIDS(J)%GTYPE .EQ. SMCTYPE ) THEN - IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) & - ' WMGLOW skip SMC grid', J - CYCLE - END IF -#endif -! -! ... Check if in grid -! -! notes: -! old version (v4.00): -! if in grid, return location in grid: a) JX, JY -! (lower left indices of cell), -! b) RX, RY -! (normalized location in cell) -! in not in grid, cycle (search next grid) -! new version (v4.01): -! Check if point within grid and compute interpolation weights using GSU -! if not in grid, cycle (search next grid) -! - IF (GRIDS(J)%GTYPE .EQ. UNGTYPE) THEN -!AR: Here we need to take special care in the case that any problem occurs due to the XA, YA beeing 4 byte - CALL IS_IN_UNGRID(J, DBLE(XA), DBLE(YA), ITOUT, IVER, JVER, RW) - IF (ITOUT.EQ.0) THEN - INGRID=.FALSE. - ELSE - INGRID=.TRUE. - FLAGOK =( ABS(GRIDS(J)%MAPSTA(JVER(1),IVER(1))).GE.1 .OR. & - RW(1).LT.0.05 ) .AND. & - ( ABS(GRIDS(J)%MAPSTA(JVER(2),IVER(2))).GE.1 .OR. & - RW(2).LT.0.05 ) .AND. & - ( ABS(GRIDS(J)%MAPSTA(JVER(3),IVER(3))).GE.1 .OR. & - RW(3).LT.0.05 ) - END IF - NbRelevant=3 - ELSE - INGRID = W3GRMP( GRIDS(J)%GSU, XA, YA, IVER , JVER, RW ) -! Print *, 'J=', J, 'IX=', IX, 'IY=', IY -! Print *, 'IN=', INGRID, 'XA=', XA, 'YA=', YA -! Print *, ' 1: IVER=', IVER(1), 'JVER=', JVER(1), 'RW=', RW(1) -! Print *, ' 2: IVER=', IVER(2), 'JVER=', JVER(2), 'RW=', RW(2) -! Print *, ' 3: IVER=', IVER(3), 'JVER=', JVER(3), 'RW=', RW(3) -! Print *, ' 4: IVER=', IVER(4), 'JVER=', JVER(4), 'RW=', RW(4) - IF (INGRID) THEN - FLAGOK =( ABS(GRIDS(J)%MAPSTA(JVER(1),IVER(1))).GE.1 .OR. & - RW(1).LT.0.05 ) .AND. & - ( ABS(GRIDS(J)%MAPSTA(JVER(2),IVER(2))).GE.1 .OR. & - RW(2).LT.0.05 ) .AND. & - ( ABS(GRIDS(J)%MAPSTA(JVER(4),IVER(4))).GE.1 .OR. & - RW(4) .LT.0.05 ) .AND. & - ( ABS(GRIDS(J)%MAPSTA(JVER(3),IVER(3))).GE.1 .OR. & - RW(3) .LT.0.05 ) - END IF - NbRelevant=4 - END IF -! internal name= GSU XTIN YTIN IS JS RW (notes) -! role=out in in in out out out -! size= --- 1 1 4 4 4 -! -! notes: -! - organization of IVER(4),JVER(4),RW(4) as returned by W3GRMP are -! as follows: -! Point 1 : lower i , lower j (JY1,JX1) -! Point 2 : upper i , lower j (JY1,JX2) -! Point 3 : upper i , upper j (JY2,JX2) -! Point 4 : lower i , upper j (JY2,JX1) -! (counter-clockwise starting from lower i, lower j) -! -! ... if not in grid, warning message and cycle (search next grid) - IF ( .NOT.INGRID ) THEN + !! SMC grid only suppots same ranked group so far. JGLi12Apr2021 + IF( GRIDS(J)%GTYPE .EQ. SMCTYPE ) THEN + IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) & + ' WMGLOW skip SMC grid', J + CYCLE + END IF +#endif + ! + ! ... Check if in grid + ! + ! notes: + ! old version (v4.00): + ! if in grid, return location in grid: a) JX, JY + ! (lower left indices of cell), + ! b) RX, RY + ! (normalized location in cell) + ! in not in grid, cycle (search next grid) + ! new version (v4.01): + ! Check if point within grid and compute interpolation weights using GSU + ! if not in grid, cycle (search next grid) + ! + IF (GRIDS(J)%GTYPE .EQ. UNGTYPE) THEN + !AR: Here we need to take special care in the case that any problem occurs due to the XA, YA beeing 4 byte + CALL IS_IN_UNGRID(J, DBLE(XA), DBLE(YA), ITOUT, IVER, JVER, RW) + IF (ITOUT.EQ.0) THEN + INGRID=.FALSE. + ELSE + INGRID=.TRUE. + FLAGOK =( ABS(GRIDS(J)%MAPSTA(JVER(1),IVER(1))).GE.1 .OR. & + RW(1).LT.0.05 ) .AND. & + ( ABS(GRIDS(J)%MAPSTA(JVER(2),IVER(2))).GE.1 .OR. & + RW(2).LT.0.05 ) .AND. & + ( ABS(GRIDS(J)%MAPSTA(JVER(3),IVER(3))).GE.1 .OR. & + RW(3).LT.0.05 ) + END IF + NbRelevant=3 + ELSE + INGRID = W3GRMP( GRIDS(J)%GSU, XA, YA, IVER , JVER, RW ) + ! Print *, 'J=', J, 'IX=', IX, 'IY=', IY + ! Print *, 'IN=', INGRID, 'XA=', XA, 'YA=', YA + ! Print *, ' 1: IVER=', IVER(1), 'JVER=', JVER(1), 'RW=', RW(1) + ! Print *, ' 2: IVER=', IVER(2), 'JVER=', JVER(2), 'RW=', RW(2) + ! Print *, ' 3: IVER=', IVER(3), 'JVER=', JVER(3), 'RW=', RW(3) + ! Print *, ' 4: IVER=', IVER(4), 'JVER=', JVER(4), 'RW=', RW(4) + IF (INGRID) THEN + FLAGOK =( ABS(GRIDS(J)%MAPSTA(JVER(1),IVER(1))).GE.1 .OR. & + RW(1).LT.0.05 ) .AND. & + ( ABS(GRIDS(J)%MAPSTA(JVER(2),IVER(2))).GE.1 .OR. & + RW(2).LT.0.05 ) .AND. & + ( ABS(GRIDS(J)%MAPSTA(JVER(4),IVER(4))).GE.1 .OR. & + RW(4) .LT.0.05 ) .AND. & + ( ABS(GRIDS(J)%MAPSTA(JVER(3),IVER(3))).GE.1 .OR. & + RW(3) .LT.0.05 ) + END IF + NbRelevant=4 + END IF + ! internal name= GSU XTIN YTIN IS JS RW (notes) + ! role=out in in in out out out + ! size= --- 1 1 4 4 4 + ! + ! notes: + ! - organization of IVER(4),JVER(4),RW(4) as returned by W3GRMP are + ! as follows: + ! Point 1 : lower i , lower j (JY1,JX1) + ! Point 2 : upper i , lower j (JY1,JX2) + ! Point 3 : upper i , upper j (JY2,JX2) + ! Point 4 : lower i , upper j (JY2,JX1) + ! (counter-clockwise starting from lower i, lower j) + ! + ! ... if not in grid, warning message and cycle (search next grid) + IF ( .NOT.INGRID ) THEN #ifdef W3_T - IF ( IAPROC .EQ. NAPERR ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSE,2000) XA, YA - ELSE - WRITE (NDSE,2001) XA, YA - END IF - END IF + IF ( IAPROC .EQ. NAPERR ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSE,2000) XA, YA + ELSE + WRITE (NDSE,2001) XA, YA + END IF + END IF #endif - CYCLE - END IF - -! -! ... Check against MAPSTA -! - -! Notes: -! Old code | becomes | New code -!-----------------| --------| ------- -! (1.-RX)*(1.-RY) | becomes | RW(1) -! RX*(1.-RY) | becomes | RW(2) -! (1.-RX)*RY | becomes | RW(4) -! RX*RY | becomes | RW(3) -! JX1 | becomes | IVER(1) -! JY1 | becomes | JVER(1) -! JX2 | becomes | IVER(3) -! JY2 | becomes | JVER(3) - -! Notes: -! IVER(1)=IVER(4), IVER(2)=IVER(3) -! JVER(1)=JVER(2), JVER(3)=JVER(4) - -! point 1: - FLAGOK = ( ABS(GRIDS(J)%MAPSTA(JVER(1),IVER(1))).GE.1 .OR. & - RW(1).LT.0.05 ) .AND. & -! point 2: - ( ABS(GRIDS(J)%MAPSTA(JVER(2),IVER(2))).GE.1 .OR. & - RW(2).LT.0.05 ) .AND. & -! point 4: - ( ABS(GRIDS(J)%MAPSTA(JVER(4),IVER(4))).GE.1 .OR. & - RW(4) .LT.0.05 ) .AND. & -! point 3: - ( ABS(GRIDS(J)%MAPSTA(JVER(3),IVER(3))).GE.1 .OR. & - RW(3) .LT.0.05 ) -! - IF ( .NOT.FLAGOK ) CYCLE -! -! ... We found interpolation data ! -! - JS = J - IBI = IBI + 1 - GRIDD(I,JS) = .TRUE. -! - XBPI(IBI) = XA - YBPI(IBI) = YA - ISBPI(IBI) = MAPFS(IY,IX) -! - TSTORE(IBI, 0) = JS -! -! notes: -! To maintain perfect consistency with old code, we would make code such that: -! - point 1 in GSU goes to point 1 in RDBPI, TSTORE -! - point 2 in GSU goes to point 2 in RDBPI, TSTORE -! - point 4 in GSU goes to point 3 in RDBPI, TSTORE -! - point 3 in GSU goes to point 4 in RDBPI, TSTORE -! Instead, here, we map point 4 in GSU goes to point 4 in RDBPI, TSTORE, etc. -! Thus the ordering of RDBPI, TSTORE has changed. -! I have no reason to believe that the ordering in RDBPI, TSTORE is important. -! I have gone through test case mww3_test_02 for gridsets a,b,c,d and found -! no change in result vs v4.00. - - DO KVER=1,4 - IF (KVER .LE. NbRelevant) THEN - IF ( ABS(GRIDS(J)%MAPSTA(JVER(KVER),IVER(KVER))).GE.1 & - .AND. RW(KVER) .GT.0.05 ) THEN - RDBPI (IBI,KVER) = RW(KVER) - TSTORE(IBI,KVER) = GRIDS(J)%MAPFS(JVER(KVER),IVER(KVER)) - ELSE - RDBPI (IBI,KVER) = 0. - TSTORE(IBI,KVER) = 0 - END IF - ELSE - RDBPI (IBI,KVER) = 0. - TSTORE(IBI,KVER) = 0 - END IF - - END DO - -! -! .....normalize weights to give sum(R)=1 - RDBPI(IBI,:) = RDBPI(IBI,:) / SUM(RDBPI(IBI,:)) -! -! Search was successful, so no need to search through other grids, so exit loop - EXIT - END DO ! "DO J=..." -! - IF ( JS.EQ.0 .AND. IMPROC.EQ.NMPERR ) & - WRITE (MDSE,1020) I, IX, IY, XA, YA -! - END IF ! If a boundary point... - - END DO ! "DO IX=..." - END DO ! "DO IY=..." - -! -! 2.d Error checks -! - IF ( IBI .EQ. 0 ) THEN - RFILE(I) = .TRUE. - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1021) - DEALLOCATE ( OUTPTS(I)%OUT5%IPBPI, OUTPTS(I)%OUT5%ISBPI, & - OUTPTS(I)%OUT5%XBPI, OUTPTS(I)%OUT5%YBPI, & - OUTPTS(I)%OUT5%RDBPI, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - CYCLE - ELSE IF ( IBI .NE. OUTPTS(I)%OUT5%NBI ) THEN - CALL EXTCDE ( 1020 ) - ENDIF -! -! 2.e Sort spectra by grid, fill IPBPI, and get NBI2 and .... -! + CYCLE + END IF - IPBPI = 0 - NBI2 = 0 -! - DO J=1, NRGRD - DO I1=1, NBI - IF ( TSTORE(I1,0) .NE. J ) CYCLE - DO J1=1, 4 - IF ( TSTORE(I1,J1).NE.0 .AND. IPBPI(I1,J1).EQ.0 ) THEN - NBI2 = NBI2 + 1 - IPBPI(I1,J1) = NBI2 - DO I2=I1, NBI - IF ( TSTORE(I2,0) .NE. J ) CYCLE - DO J2=1, 4 - IF ( TSTORE(I2,J2) .EQ. TSTORE(I1,J1) ) & - IPBPI(I2,J2) = NBI2 - END DO - END DO + ! + ! ... Check against MAPSTA + ! + + ! Notes: + ! Old code | becomes | New code + !-----------------| --------| ------- + ! (1.-RX)*(1.-RY) | becomes | RW(1) + ! RX*(1.-RY) | becomes | RW(2) + ! (1.-RX)*RY | becomes | RW(4) + ! RX*RY | becomes | RW(3) + ! JX1 | becomes | IVER(1) + ! JY1 | becomes | JVER(1) + ! JX2 | becomes | IVER(3) + ! JY2 | becomes | JVER(3) + + ! Notes: + ! IVER(1)=IVER(4), IVER(2)=IVER(3) + ! JVER(1)=JVER(2), JVER(3)=JVER(4) + + ! point 1: + FLAGOK = ( ABS(GRIDS(J)%MAPSTA(JVER(1),IVER(1))).GE.1 .OR. & + RW(1).LT.0.05 ) .AND. & + ! point 2: + ( ABS(GRIDS(J)%MAPSTA(JVER(2),IVER(2))).GE.1 .OR. & + RW(2).LT.0.05 ) .AND. & + ! point 4: + ( ABS(GRIDS(J)%MAPSTA(JVER(4),IVER(4))).GE.1 .OR. & + RW(4) .LT.0.05 ) .AND. & + ! point 3: + ( ABS(GRIDS(J)%MAPSTA(JVER(3),IVER(3))).GE.1 .OR. & + RW(3) .LT.0.05 ) + ! + IF ( .NOT.FLAGOK ) CYCLE + ! + ! ... We found interpolation data ! + ! + JS = J + IBI = IBI + 1 + GRIDD(I,JS) = .TRUE. + ! + XBPI(IBI) = XA + YBPI(IBI) = YA + ISBPI(IBI) = MAPFS(IY,IX) + ! + TSTORE(IBI, 0) = JS + ! + ! notes: + ! To maintain perfect consistency with old code, we would make code such that: + ! - point 1 in GSU goes to point 1 in RDBPI, TSTORE + ! - point 2 in GSU goes to point 2 in RDBPI, TSTORE + ! - point 4 in GSU goes to point 3 in RDBPI, TSTORE + ! - point 3 in GSU goes to point 4 in RDBPI, TSTORE + ! Instead, here, we map point 4 in GSU goes to point 4 in RDBPI, TSTORE, etc. + ! Thus the ordering of RDBPI, TSTORE has changed. + ! I have no reason to believe that the ordering in RDBPI, TSTORE is important. + ! I have gone through test case mww3_test_02 for gridsets a,b,c,d and found + ! no change in result vs v4.00. + + DO KVER=1,4 + IF (KVER .LE. NbRelevant) THEN + IF ( ABS(GRIDS(J)%MAPSTA(JVER(KVER),IVER(KVER))).GE.1 & + .AND. RW(KVER) .GT.0.05 ) THEN + RDBPI (IBI,KVER) = RW(KVER) + TSTORE(IBI,KVER) = GRIDS(J)%MAPFS(JVER(KVER),IVER(KVER)) + ELSE + RDBPI (IBI,KVER) = 0. + TSTORE(IBI,KVER) = 0 + END IF + ELSE + RDBPI (IBI,KVER) = 0. + TSTORE(IBI,KVER) = 0 END IF + END DO - END DO - END DO -! -! 2.f Set up spectral storage and cross-grid mapping -! - CALL W3DMO5 ( I, MDSE, MDST, 3 ) -! - ALLOCATE ( MDATAS(I)%NBI2S(NBI2,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - NBI2S => MDATAS(I)%NBI2S -! + + ! + ! .....normalize weights to give sum(R)=1 + RDBPI(IBI,:) = RDBPI(IBI,:) / SUM(RDBPI(IBI,:)) + ! + ! Search was successful, so no need to search through other grids, so exit loop + EXIT + END DO ! "DO J=..." + ! + IF ( JS.EQ.0 .AND. IMPROC.EQ.NMPERR ) & + WRITE (MDSE,1020) I, IX, IY, XA, YA + ! + END IF ! If a boundary point... + + END DO ! "DO IX=..." + END DO ! "DO IY=..." + + ! + ! 2.d Error checks + ! + IF ( IBI .EQ. 0 ) THEN + RFILE(I) = .TRUE. + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1021) + DEALLOCATE ( OUTPTS(I)%OUT5%IPBPI, OUTPTS(I)%OUT5%ISBPI, & + OUTPTS(I)%OUT5%XBPI, OUTPTS(I)%OUT5%YBPI, & + OUTPTS(I)%OUT5%RDBPI, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + CYCLE + ELSE IF ( IBI .NE. OUTPTS(I)%OUT5%NBI ) THEN + CALL EXTCDE ( 1020 ) + ENDIF + ! + ! 2.e Sort spectra by grid, fill IPBPI, and get NBI2 and .... + ! + + IPBPI = 0 + NBI2 = 0 + ! + DO J=1, NRGRD DO I1=1, NBI + IF ( TSTORE(I1,0) .NE. J ) CYCLE DO J1=1, 4 - IF ( IPBPI(I1,J1) .NE. 0 ) THEN - NBI2S(IPBPI(I1,J1),1) = TSTORE(I1,0) - NBI2S(IPBPI(I1,J1),2) = TSTORE(I1,J1) - END IF - END DO - END DO -! - DO I1=1, NBI2 - NBI2G(I,NBI2S(I1,1)) = NBI2G(I,NBI2S(I1,1)) + 1 + IF ( TSTORE(I1,J1).NE.0 .AND. IPBPI(I1,J1).EQ.0 ) THEN + NBI2 = NBI2 + 1 + IPBPI(I1,J1) = NBI2 + DO I2=I1, NBI + IF ( TSTORE(I2,0) .NE. J ) CYCLE + DO J2=1, 4 + IF ( TSTORE(I2,J2) .EQ. TSTORE(I1,J1) ) & + IPBPI(I2,J2) = NBI2 + END DO + END DO + END IF END DO -! -! 2.g Test output -! + END DO + END DO + ! + ! 2.f Set up spectral storage and cross-grid mapping + ! + CALL W3DMO5 ( I, MDSE, MDST, 3 ) + ! + ALLOCATE ( MDATAS(I)%NBI2S(NBI2,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + NBI2S => MDATAS(I)%NBI2S + ! + DO I1=1, NBI + DO J1=1, 4 + IF ( IPBPI(I1,J1) .NE. 0 ) THEN + NBI2S(IPBPI(I1,J1),1) = TSTORE(I1,0) + NBI2S(IPBPI(I1,J1),2) = TSTORE(I1,J1) + END IF + END DO + END DO + ! + DO I1=1, NBI2 + NBI2G(I,NBI2S(I1,1)) = NBI2G(I,NBI2S(I1,1)) + 1 + END DO + ! + ! 2.g Test output + ! #ifdef W3_T1 - WRITE (MDST,9023) - DO J=1, NBI - WRITE (MDST,9024) J, ISBPI(J), FACTOR*XBPI(J), & + WRITE (MDST,9023) + DO J=1, NBI + WRITE (MDST,9024) J, ISBPI(J), FACTOR*XBPI(J), & FACTOR*YBPI(J), IPBPI(J,:), RDBPI(J,:), TSTORE(J,:) - END DO + END DO #endif -! + ! #ifdef W3_T2 - WRITE (MDST,9025) - DO J=1, NBI2 - WRITE (MDST,9026) J, NBI2S(J,:) - END DO + WRITE (MDST,9025) + DO J=1, NBI2 + WRITE (MDST,9026) J, NBI2S(J,:) + END DO #endif -! + ! #ifdef W3_T9 - ALLOCATE ( TMAP(NX,NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( TMAP(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -! + ! #ifdef W3_T9 - DO IX=1, NX - DO IY=1, NY - IF ( ABS(MAPSTA(IY,IX)) .EQ. 0 ) then - TMAP(IX,IY) = '/' - ELSE IF ( ABS(MAPSTA(IY,IX)) .EQ. 1 ) then - TMAP(IX,IY) = '-' - ELSE IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 ) then - TMAP(IX,IY) = 'X' - END IF - END DO - END DO + DO IX=1, NX + DO IY=1, NY + IF ( ABS(MAPSTA(IY,IX)) .EQ. 0 ) then + TMAP(IX,IY) = '/' + ELSE IF ( ABS(MAPSTA(IY,IX)) .EQ. 1 ) then + TMAP(IX,IY) = '-' + ELSE IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 ) then + TMAP(IX,IY) = 'X' + END IF + END DO + END DO #endif -! + ! #ifdef W3_T9 - DO J=1, NBI - IX = MAPSF(ISBPI(J),1) - IY = MAPSF(ISBPI(J),2) - WRITE (TMAP(IX,IY),'(I1)') TSTORE(J,0) - END DO + DO J=1, NBI + IX = MAPSF(ISBPI(J),1) + IY = MAPSF(ISBPI(J),2) + WRITE (TMAP(IX,IY),'(I1)') TSTORE(J,0) + END DO #endif -! + ! #ifdef W3_T9 - DO J=1, 1+(NX-1)/130 - WRITE (MDST,9029) I, J - DO IY=NY, 1, -1 - I1 = J*130-129 - I2 = MIN ( NX , J*130 ) - WRITE (MDST,'(1X,130A1)') TMAP(I1:I2,IY) - END DO - END DO + DO J=1, 1+(NX-1)/130 + WRITE (MDST,9029) I, J + DO IY=NY, 1, -1 + I1 = J*130-129 + I2 = MIN ( NX , J*130 ) + WRITE (MDST,'(1X,130A1)') TMAP(I1:I2,IY) + END DO + END DO #endif -! + ! #ifdef W3_T9 - DEALLOCATE ( TMAP, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE ( TMAP, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) #endif -! - DEALLOCATE ( TSTORE, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) -! - END DO -! + ! + DEALLOCATE ( TSTORE, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + ! + END DO + ! #ifdef W3_T - WRITE (MDST,9027) - DO I=1, NRGRD - WRITE (MDST,9028) OUTPTS(I)%OUT5%NBI, OUTPTS(I)%OUT5%NBI2, & - RFILE(I), NBI2G(I,:) - END DO -#endif -! -! -------------------------------------------------------------------- / -! 3. Finalyze grid dependencies in GRDLOW -! 3.a Get size of array and dimension -! + WRITE (MDST,9027) + DO I=1, NRGRD + WRITE (MDST,9028) OUTPTS(I)%OUT5%NBI, OUTPTS(I)%OUT5%NBI2, & + RFILE(I), NBI2G(I,:) + END DO +#endif + ! + ! -------------------------------------------------------------------- / + ! 3. Finalyze grid dependencies in GRDLOW + ! 3.a Get size of array and dimension + ! + + ! notes: + ! GRIDD(I,J) indicates whether grid I is dependent on lower ranked grid J + ! JS counts the number of grids J that grid I is dependent on + ! GRDLOW is sized to accomodate the grid with the largest JS + + JTOT = 0 + DO I=1, NRGRD + JS = 0 + DO J=1, NRGRD + IF ( GRIDD(I,J) ) JS = JS + 1 + END DO + JTOT = MAX ( JTOT , JS ) + END DO + ! + IF ( ALLOCATED(GRDLOW) ) THEN + DEALLOCATE ( GRDLOW, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + ALLOCATE ( GRDLOW(NRGRD,0:JTOT), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + GRDLOW = 0 + ! +#ifdef W3_T + WRITE (MDST,9030) JTOT +#endif + ! + ! 3.b Fill array + ! + FLAGOK = .TRUE. + ! + DO I=1, NRGRD + JTOT = 0 + DO J=1, NRGRD + IF ( GRIDD(I,J) ) THEN + JTOT = JTOT + 1 + GRDLOW(I,JTOT) = J + ! ... error checking: catch situation where ranks are inconsistent with + ! resolution + + ! notes: + ! old code: SXJ=GRIDS(J)%SX + ! SXI=GRIDS(I)%SX + ! SYJ=GRIDS(J)%SY + ! SYI=GRIDS(I)%SY + ! also, old code did not need to check both min and max, + ! since they were the same + ! new code: + ! SXI(:,:) ==> GRIDS(I)%HPFAC ! resolution in higher rank grid I + ! (approximate in case of irregular grids) + ! SYI(:,:) ==> GRIDS(I)%HQFAC ! viz. + ! SXJ(:,:) ==> GRIDS(J)%HPFAC ! resolution in lower rank grid J + ! (approximate in case of irregular grids) + ! SYJ(:,:) ==> GRIDS(J)%HQFAC ! viz. + + ! notes: + ! for irregular grids, we require + ! 1) smallest cell in low rank grid is larger than smallest cell + ! in high rank grid + ! 2) largest cell in low rank grid is larger than largest cell + ! in high rank grid + ! Each dimension (along i/p and j/q axes) is checked separately, + ! making 4 checks total. + ! This is strict, and may generate "false positives" in error checking + ! here. In this case, the user may wish to disable this error checking. + ! For case of regular grids, we cannot use HPFAC, since it goes to zero + ! at pole. We instead use good ol' SX and SY + + IF ( GRIDS(I)%GTYPE .EQ. CLGTYPE ) THEN + DX_MIN_GRIDI=MINVAL(GRIDS(I)%HPFAC) + DY_MIN_GRIDI=MINVAL(GRIDS(I)%HQFAC) + DX_MAX_GRIDI=MAXVAL(GRIDS(I)%HPFAC) + DY_MAX_GRIDI=MAXVAL(GRIDS(I)%HQFAC) + ELSEIF ( GRIDS(I)%GTYPE .EQ. RLGTYPE .OR. & + GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN + !!Li SMC grid shares mesh with regular grid. 22Mar2021 + DX_MIN_GRIDI=GRIDS(I)%SX + DY_MIN_GRIDI=GRIDS(I)%SY + DX_MAX_GRIDI=GRIDS(I)%SX + DY_MAX_GRIDI=GRIDS(I)%SY + ELSEIF ( GRIDS(I)%GTYPE .EQ. UNGTYPE ) THEN + ISFIRST=1 + DIST_MAX=0 + DIST_MIN=0 + DO ITRI=1,GRIDS(I)%NTRI + DO IT=1,3 + IF (IT.EQ.3) THEN + JT=1 + ELSE + JT=IT+1 + END IF + IM1=GRIDS(I)%TRIGP(IT,ITRI) + IM2=GRIDS(I)%TRIGP(JT,ITRI) + EDIST=W3DIST(FLAGLL, REAL(GRIDS(I)%XGRD(1,IM1)), & + REAL(GRIDS(I)%YGRD(1,IM1)), REAL(GRIDS(I)%XGRD(1,IM2)), & + REAL(GRIDS(I)%YGRD(1,IM2))) + IF (ISFIRST.EQ.1) THEN + DIST_MAX=EDIST + DIST_MIN=EDIST + ISFIRST=0 + ELSE + IF (EDIST.GT.DIST_MAX) THEN + DIST_MAX=EDIST + END IF + IF (EDIST.LT.DIST_MIN) THEN + DIST_MIN=EDIST + END IF + END IF + END DO + END DO + DX_MIN_GRIDI=DIST_MIN + DY_MIN_GRIDI=DIST_MIN + DX_MAX_GRIDI=DIST_MAX + DY_MAX_GRIDI=DIST_MAX + ELSE + CALL EXTCDE ( 601 ) + END IF -! notes: -! GRIDD(I,J) indicates whether grid I is dependent on lower ranked grid J -! JS counts the number of grids J that grid I is dependent on -! GRDLOW is sized to accomodate the grid with the largest JS + IF ( GRIDS(J)%GTYPE .EQ. CLGTYPE ) THEN + DX_MIN_GRIDJ=MINVAL(GRIDS(J)%HPFAC) + DY_MIN_GRIDJ=MINVAL(GRIDS(J)%HQFAC) + DX_MAX_GRIDJ=MAXVAL(GRIDS(J)%HPFAC) + DY_MAX_GRIDJ=MAXVAL(GRIDS(J)%HQFAC) + ELSEIF ( GRIDS(J)%GTYPE .EQ. RLGTYPE .OR. & + GRIDS(J)%GTYPE .EQ. SMCTYPE ) THEN + !!Li SMC grid shares mesh with regular grid. 22Mar2021 + DX_MIN_GRIDJ=GRIDS(J)%SX + DY_MIN_GRIDJ=GRIDS(J)%SY + DX_MAX_GRIDJ=GRIDS(J)%SX + DY_MAX_GRIDJ=GRIDS(J)%SY + ELSEIF ( GRIDS(J)%GTYPE .EQ. UNGTYPE ) THEN + ISFIRST=1 + DIST_MAX=0 + DIST_MIN=0 + DO ITRI=1,GRIDS(J)%NTRI + DO IT=1,3 + IF (IT.EQ.3) THEN + JT=1 + ELSE + JT=IT+1 + END IF + IM1=GRIDS(J)%TRIGP(IT,ITRI) + IM2=GRIDS(J)%TRIGP(JT,ITRI) + EDIST=W3DIST(FLAGLL, REAL(GRIDS(J)%XGRD(1,IM1)), & + REAL(GRIDS(J)%YGRD(1,IM1)), REAL(GRIDS(J)%XGRD(1,IM2)), & + REAL(GRIDS(J)%YGRD(1,IM2))) + IF (ISFIRST.EQ.1) THEN + DIST_MAX=EDIST + DIST_MIN=EDIST + ISFIRST=0 + ELSE + IF (EDIST.GT.DIST_MAX) THEN + DIST_MAX=EDIST + END IF + IF (EDIST.LT.DIST_MIN) THEN + DIST_MIN=EDIST + END IF + END IF + END DO + END DO + DX_MIN_GRIDJ=DIST_MIN + DY_MIN_GRIDJ=DIST_MIN + DX_MAX_GRIDJ=DIST_MAX + DY_MAX_GRIDJ=DIST_MAX + ELSE + CALL EXTCDE ( 602 ) + END IF - JTOT = 0 - DO I=1, NRGRD - JS = 0 - DO J=1, NRGRD - IF ( GRIDD(I,J) ) JS = JS + 1 - END DO - JTOT = MAX ( JTOT , JS ) - END DO -! - IF ( ALLOCATED(GRDLOW) ) THEN - DEALLOCATE ( GRDLOW, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END IF - ALLOCATE ( GRDLOW(NRGRD,0:JTOT), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - GRDLOW = 0 -! -#ifdef W3_T - WRITE (MDST,9030) JTOT -#endif -! -! 3.b Fill array -! - FLAGOK = .TRUE. -! - DO I=1, NRGRD - JTOT = 0 - DO J=1, NRGRD - IF ( GRIDD(I,J) ) THEN - JTOT = JTOT + 1 - GRDLOW(I,JTOT) = J -! ... error checking: catch situation where ranks are inconsistent with -! resolution - -! notes: -! old code: SXJ=GRIDS(J)%SX -! SXI=GRIDS(I)%SX -! SYJ=GRIDS(J)%SY -! SYI=GRIDS(I)%SY -! also, old code did not need to check both min and max, -! since they were the same -! new code: -! SXI(:,:) ==> GRIDS(I)%HPFAC ! resolution in higher rank grid I -! (approximate in case of irregular grids) -! SYI(:,:) ==> GRIDS(I)%HQFAC ! viz. -! SXJ(:,:) ==> GRIDS(J)%HPFAC ! resolution in lower rank grid J -! (approximate in case of irregular grids) -! SYJ(:,:) ==> GRIDS(J)%HQFAC ! viz. - -! notes: -! for irregular grids, we require -! 1) smallest cell in low rank grid is larger than smallest cell -! in high rank grid -! 2) largest cell in low rank grid is larger than largest cell -! in high rank grid -! Each dimension (along i/p and j/q axes) is checked separately, -! making 4 checks total. -! This is strict, and may generate "false positives" in error checking -! here. In this case, the user may wish to disable this error checking. -! For case of regular grids, we cannot use HPFAC, since it goes to zero -! at pole. We instead use good ol' SX and SY - - IF ( GRIDS(I)%GTYPE .EQ. CLGTYPE ) THEN - DX_MIN_GRIDI=MINVAL(GRIDS(I)%HPFAC) - DY_MIN_GRIDI=MINVAL(GRIDS(I)%HQFAC) - DX_MAX_GRIDI=MAXVAL(GRIDS(I)%HPFAC) - DY_MAX_GRIDI=MAXVAL(GRIDS(I)%HQFAC) - ELSEIF ( GRIDS(I)%GTYPE .EQ. RLGTYPE .OR. & - GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN -!!Li SMC grid shares mesh with regular grid. 22Mar2021 - DX_MIN_GRIDI=GRIDS(I)%SX - DY_MIN_GRIDI=GRIDS(I)%SY - DX_MAX_GRIDI=GRIDS(I)%SX - DY_MAX_GRIDI=GRIDS(I)%SY - ELSEIF ( GRIDS(I)%GTYPE .EQ. UNGTYPE ) THEN - ISFIRST=1 - DIST_MAX=0 - DIST_MIN=0 - DO ITRI=1,GRIDS(I)%NTRI - DO IT=1,3 - IF (IT.EQ.3) THEN - JT=1 - ELSE - JT=IT+1 - END IF - IM1=GRIDS(I)%TRIGP(IT,ITRI) - IM2=GRIDS(I)%TRIGP(JT,ITRI) - EDIST=W3DIST(FLAGLL, REAL(GRIDS(I)%XGRD(1,IM1)), & - REAL(GRIDS(I)%YGRD(1,IM1)), REAL(GRIDS(I)%XGRD(1,IM2)), & - REAL(GRIDS(I)%YGRD(1,IM2))) - IF (ISFIRST.EQ.1) THEN - DIST_MAX=EDIST - DIST_MIN=EDIST - ISFIRST=0 - ELSE - IF (EDIST.GT.DIST_MAX) THEN - DIST_MAX=EDIST - END IF - IF (EDIST.LT.DIST_MIN) THEN - DIST_MIN=EDIST - END IF - END IF - END DO - END DO - DX_MIN_GRIDI=DIST_MIN - DY_MIN_GRIDI=DIST_MIN - DX_MAX_GRIDI=DIST_MAX - DY_MAX_GRIDI=DIST_MAX - ELSE - CALL EXTCDE ( 601 ) + RESOL_CHECK=.FALSE. +#ifdef W3_T38 + RESOL_CHECK=.TRUE. +#endif + IF (RESOL_CHECK) THEN + IF ( DX_MIN_GRIDJ .LT. 0.99*DX_MIN_GRIDI .OR. & + DY_MIN_GRIDJ .LT. 0.99*DY_MIN_GRIDI .OR. & + DX_MAX_GRIDJ .LT. 0.99*DX_MAX_GRIDI .OR. & + DY_MAX_GRIDJ .LT. 0.99*DY_MAX_GRIDI ) THEN + Print *, 'DX_MIN_GRID I=', DX_MIN_GRIDI, ' J=', DX_MIN_GRIDJ + Print *, 'DX_MAX_GRID I=', DX_MAX_GRIDI, ' J=', DX_MAX_GRIDJ + IF ( IMPROC.EQ.NMPERR ) WRITE (MDSE,1030) & + J, GRANK(J), DX_MIN_GRIDJ, DY_MIN_GRIDJ, & + DX_MAX_GRIDJ, DY_MAX_GRIDJ, & + I, GRANK(I), DX_MIN_GRIDI, DY_MIN_GRIDI, & + DX_MAX_GRIDI, DY_MAX_GRIDI + FLAGOK = .FALSE. END IF + END IF - IF ( GRIDS(J)%GTYPE .EQ. CLGTYPE ) THEN - DX_MIN_GRIDJ=MINVAL(GRIDS(J)%HPFAC) - DY_MIN_GRIDJ=MINVAL(GRIDS(J)%HQFAC) - DX_MAX_GRIDJ=MAXVAL(GRIDS(J)%HPFAC) - DY_MAX_GRIDJ=MAXVAL(GRIDS(J)%HQFAC) - ELSEIF ( GRIDS(J)%GTYPE .EQ. RLGTYPE .OR. & - GRIDS(J)%GTYPE .EQ. SMCTYPE ) THEN -!!Li SMC grid shares mesh with regular grid. 22Mar2021 - DX_MIN_GRIDJ=GRIDS(J)%SX - DY_MIN_GRIDJ=GRIDS(J)%SY - DX_MAX_GRIDJ=GRIDS(J)%SX - DY_MAX_GRIDJ=GRIDS(J)%SY - ELSEIF ( GRIDS(J)%GTYPE .EQ. UNGTYPE ) THEN - ISFIRST=1 - DIST_MAX=0 - DIST_MIN=0 - DO ITRI=1,GRIDS(J)%NTRI - DO IT=1,3 - IF (IT.EQ.3) THEN - JT=1 - ELSE - JT=IT+1 - END IF - IM1=GRIDS(J)%TRIGP(IT,ITRI) - IM2=GRIDS(J)%TRIGP(JT,ITRI) - EDIST=W3DIST(FLAGLL, REAL(GRIDS(J)%XGRD(1,IM1)), & - REAL(GRIDS(J)%YGRD(1,IM1)), REAL(GRIDS(J)%XGRD(1,IM2)), & - REAL(GRIDS(J)%YGRD(1,IM2))) - IF (ISFIRST.EQ.1) THEN - DIST_MAX=EDIST - DIST_MIN=EDIST - ISFIRST=0 - ELSE - IF (EDIST.GT.DIST_MAX) THEN - DIST_MAX=EDIST - END IF - IF (EDIST.LT.DIST_MIN) THEN - DIST_MIN=EDIST - END IF - END IF - END DO - END DO - DX_MIN_GRIDJ=DIST_MIN - DY_MIN_GRIDJ=DIST_MIN - DX_MAX_GRIDJ=DIST_MAX - DY_MAX_GRIDJ=DIST_MAX - ELSE - CALL EXTCDE ( 602 ) - END IF - - RESOL_CHECK=.FALSE. -#ifdef W3_T38 - RESOL_CHECK=.TRUE. -#endif - IF (RESOL_CHECK) THEN - IF ( DX_MIN_GRIDJ .LT. 0.99*DX_MIN_GRIDI .OR. & - DY_MIN_GRIDJ .LT. 0.99*DY_MIN_GRIDI .OR. & - DX_MAX_GRIDJ .LT. 0.99*DX_MAX_GRIDI .OR. & - DY_MAX_GRIDJ .LT. 0.99*DY_MAX_GRIDI ) THEN - Print *, 'DX_MIN_GRID I=', DX_MIN_GRIDI, ' J=', DX_MIN_GRIDJ - Print *, 'DX_MAX_GRID I=', DX_MAX_GRIDI, ' J=', DX_MAX_GRIDJ - IF ( IMPROC.EQ.NMPERR ) WRITE (MDSE,1030) & - J, GRANK(J), DX_MIN_GRIDJ, DY_MIN_GRIDJ, & - DX_MAX_GRIDJ, DY_MAX_GRIDJ, & - I, GRANK(I), DX_MIN_GRIDI, DY_MIN_GRIDI, & - DX_MAX_GRIDI, DY_MAX_GRIDI - FLAGOK = .FALSE. - END IF - END IF - - END IF ! IF ( GRIDD(I,J) ) THEN - - END DO ! DO J=... - GRDLOW(I,0) = JTOT - END DO ! DO I=... -! + END IF ! IF ( GRIDD(I,J) ) THEN + + END DO ! DO J=... + GRDLOW(I,0) = JTOT + END DO ! DO I=... + ! #ifdef W3_T - WRITE (MDST,9031) - DO I=1, NRGRD - WRITE (MDST,9032) I, GRDLOW(I,0:GRDLOW(I,0)) - END DO + WRITE (MDST,9031) + DO I=1, NRGRD + WRITE (MDST,9032) I, GRDLOW(I,0:GRDLOW(I,0)) + END DO +#endif + ! + IF ( .NOT. FLAGOK ) CALL EXTCDE ( 1030 ) + ! + ! -------------------------------------------------------------------- / + ! 4. Finalyze grid dependencies in GRDHGH + ! 4.a Get size of array and dimension + ! + JTOT = 0 + DO I=1, NRGRD + JS = 0 + DO J=1, NRGRD + IF ( GRIDD(J,I) ) JS = JS + 1 + END DO + JTOT = MAX ( JTOT , JS ) + END DO + ! + IF ( ALLOCATED(GRDHGH) ) THEN + DEALLOCATE ( GRDHGH, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + ALLOCATE ( GRDHGH(NRGRD,0:JTOT), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + GRDHGH = 0 + ! +#ifdef W3_T + WRITE (MDST,9040) JTOT #endif -! - IF ( .NOT. FLAGOK ) CALL EXTCDE ( 1030 ) -! -! -------------------------------------------------------------------- / -! 4. Finalyze grid dependencies in GRDHGH -! 4.a Get size of array and dimension -! + ! + ! 4.b Fill array + ! + DO I=1, NRGRD ! low rank grid JTOT = 0 - DO I=1, NRGRD - JS = 0 - DO J=1, NRGRD - IF ( GRIDD(J,I) ) JS = JS + 1 - END DO - JTOT = MAX ( JTOT , JS ) - END DO -! - IF ( ALLOCATED(GRDHGH) ) THEN - DEALLOCATE ( GRDHGH, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + DO J=1, NRGRD + IF ( GRIDD(J,I) ) THEN ! grid j is of higher rank than grid i + ! *and* there is dependency + JTOT = JTOT + 1 ! count the number of grids of higher + ! rank than grid i + GRDHGH(I,JTOT) = J ! save the grid number of the higher rank grid END IF - ALLOCATE ( GRDHGH(NRGRD,0:JTOT), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - GRDHGH = 0 -! -#ifdef W3_T - WRITE (MDST,9040) JTOT -#endif -! -! 4.b Fill array -! - DO I=1, NRGRD ! low rank grid - JTOT = 0 - DO J=1, NRGRD - IF ( GRIDD(J,I) ) THEN ! grid j is of higher rank than grid i - ! *and* there is dependency - JTOT = JTOT + 1 ! count the number of grids of higher - ! rank than grid i - GRDHGH(I,JTOT) = J ! save the grid number of the higher rank grid - END IF - END DO - GRDHGH(I,0) = JTOT ! save the count of higher ranked grids - END DO -! + END DO + GRDHGH(I,0) = JTOT ! save the count of higher ranked grids + END DO + ! #ifdef W3_T - WRITE (MDST,9041) - DO I=1, NRGRD - WRITE (MDST,9042) I, GRDHGH(I,0:GRDHGH(I,0)) - END DO -#endif -! -! -------------------------------------------------------------------- / -! 5. Export file flags -! - IF ( PRESENT(FLRBPI) ) FLRBPI = RFILE -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMGLOW : *** '/ & - ' GRID NOT INITIALIZED, GRID NR',I4 /) -! - 1020 FORMAT (/' *** WAVEWATCH III ERROR IN WMGLOW : *** '/ & - ' CANNOT FIND SOURCE FOR BOUNDARY DATA '/ & - ' GRID, IX, IY, X, Y:',3I6,2E12.4/) -! - 1021 FORMAT (/' *** WAVEWATCH III ERROR IN WMGLOW : *** '/ & - ' NONE OF BOUNDARY POINTS CAN BE MAPPED'/ & - ' READING FROM FILE INSTEAD'/) -! - 1030 FORMAT (/' *** WAVEWATCH III ERROR IN WMGLOW : *** '/ & - ' RANKS AND RESOLUTIONS INCONSISTENT'/ & - ' GRID',I4,' RANK',I4,' RESOLUTION :',4E10.3/ & - ' GRID',I4,' RANK',I4,' RESOLUTION :',4E10.3/) -! - 2000 FORMAT (/' *** WAVEWATCH-III WARNING : BOUNDARY POINT'/ & - ' NOT FOUND IN LOWER RANK GRID : ',2F10.3/ & - ' POINT SKIPPED '/) -! - 2001 FORMAT (/' *** WAVEWATCH-III WARNING : BOUNDARY POINT'/ & - ' NOT FOUND IN LOWER RANK GRID : ',2E10.3/ & - ' POINT SKIPPED '/) -! + WRITE (MDST,9041) + DO I=1, NRGRD + WRITE (MDST,9042) I, GRDHGH(I,0:GRDHGH(I,0)) + END DO +#endif + ! + ! -------------------------------------------------------------------- / + ! 5. Export file flags + ! + IF ( PRESENT(FLRBPI) ) FLRBPI = RFILE + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMGLOW : *** '/ & + ' GRID NOT INITIALIZED, GRID NR',I4 /) + ! +1020 FORMAT (/' *** WAVEWATCH III ERROR IN WMGLOW : *** '/ & + ' CANNOT FIND SOURCE FOR BOUNDARY DATA '/ & + ' GRID, IX, IY, X, Y:',3I6,2E12.4/) + ! +1021 FORMAT (/' *** WAVEWATCH III ERROR IN WMGLOW : *** '/ & + ' NONE OF BOUNDARY POINTS CAN BE MAPPED'/ & + ' READING FROM FILE INSTEAD'/) + ! +1030 FORMAT (/' *** WAVEWATCH III ERROR IN WMGLOW : *** '/ & + ' RANKS AND RESOLUTIONS INCONSISTENT'/ & + ' GRID',I4,' RANK',I4,' RESOLUTION :',4E10.3/ & + ' GRID',I4,' RANK',I4,' RESOLUTION :',4E10.3/) + ! +2000 FORMAT (/' *** WAVEWATCH-III WARNING : BOUNDARY POINT'/ & + ' NOT FOUND IN LOWER RANK GRID : ',2F10.3/ & + ' POINT SKIPPED '/) + ! +2001 FORMAT (/' *** WAVEWATCH-III WARNING : BOUNDARY POINT'/ & + ' NOT FOUND IN LOWER RANK GRID : ',2E10.3/ & + ' POINT SKIPPED '/) + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMGLOW : ALL GRIDS INITIALIZED') +9010 FORMAT ( ' TEST WMGLOW : ALL GRIDS INITIALIZED') #endif -! + ! #ifdef W3_T - 9020 FORMAT ( ' TEST WMGLOW : STARTING LOOP OVER GRIDS') - 9021 FORMAT ( ' TEST WMGLOW : I, RANK, NBI :',2I4,I6) - 9022 FORMAT ( ' ',A) +9020 FORMAT ( ' TEST WMGLOW : STARTING LOOP OVER GRIDS') +9021 FORMAT ( ' TEST WMGLOW : I, RANK, NBI :',2I4,I6) +9022 FORMAT ( ' ',A) #endif #ifdef W3_T1 - 9023 FORMAT (' TEST WMGLOW : POINT DATA ') - 9024 FORMAT (I5,I8,2F6.1,4I5,4F5.2,I3,4I8) +9023 FORMAT (' TEST WMGLOW : POINT DATA ') +9024 FORMAT (I5,I8,2F6.1,4I5,4F5.2,I3,4I8) #endif #ifdef W3_T2 - 9025 FORMAT (' TEST WMGLOW : NBI2S ') - 9026 FORMAT (' ',2I4,2X,I8) +9025 FORMAT (' TEST WMGLOW : NBI2S ') +9026 FORMAT (' ',2I4,2X,I8) #endif #ifdef W3_T - 9027 FORMAT (' TEST WMGLOW : NBI, NBI2, RFILE, NBI2G ') - 9028 FORMAT (' ',2I5,L2,' : ',20I5) +9027 FORMAT (' TEST WMGLOW : NBI, NBI2, RFILE, NBI2G ') +9028 FORMAT (' ',2I5,L2,' : ',20I5) #endif #ifdef W3_T9 - 9029 FORMAT (' TEST WMGLOW : SOURCE MAP GRID',I3,' PART',I3) +9029 FORMAT (' TEST WMGLOW : SOURCE MAP GRID',I3,' PART',I3) #endif -! + ! #ifdef W3_T - 9030 FORMAT ( ' TEST WMGLOW : GRDLOW DIMENSIONED AT ',I2) - 9031 FORMAT ( ' TEST WMGLOW : GRDLOW :') - 9032 FORMAT ( ' ',2i4,' : ',20I3) +9030 FORMAT ( ' TEST WMGLOW : GRDLOW DIMENSIONED AT ',I2) +9031 FORMAT ( ' TEST WMGLOW : GRDLOW :') +9032 FORMAT ( ' ',2i4,' : ',20I3) #endif -! + ! #ifdef W3_T - 9040 FORMAT ( ' TEST WMGLOW : GRDHGH DIMENSIONED AT ',I2) - 9041 FORMAT ( ' TEST WMGLOW : GRDHGH :') - 9042 FORMAT ( ' ',2i4,' : ',20I3) -#endif -!/ -!/ End of WMGLOW ----------------------------------------------------- / -!/ - END SUBROUTINE WMGLOW - -!/ ------------------------------------------------------------------- / -!> -!> @brief Determine relation to higher ranked grids for each grid. -!> -!> @details Base map set in WMGLOW, supplemental data computed here. -!> Map averaging information for higher ranked grid to lower ranked grid. -!> -!> @author H. L. Tolman -!> @author W. E. Rogers -!> @date 10-Dec-2014 -!> - SUBROUTINE WMGHGH -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | W. E. Rogers | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2005 : Origination. ( version 3.08 ) -!/ 09-Mar-2006 : Carry over land mask. ( version 3.09 ) -!/ 28-Dec-2006 : Simplify NIT for partial comm. ( version 3.10 ) -!/ 07-Feb-2007 : Setting FLAGST. ( version 3.10 ) -!/ 20-May-2009 : Linking FLAGST and FLGHG1. ( version 3.14 ) -!/ 26-May-2009 : Fix erroneous cyclic updating. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) -!/ factor with DXDP and DXDQ terms. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 07-Jul-2011 : Bug fix for IX bounds with wrapping ( version 3.14+) -!/ grids (see use of "IDSTLA" below) -!/ (W. E. Rogers, NRL) -!/ 02-Aug-2011 : Adapted for use with irregular ( version 3.14+) -!/ grids (W. E. Rogers, NRL) -!/ 21-Sep-2012 : Modified to implement SCRIP remap ( version 4.11 ) -!/ file read and write option -!/ (K. R. Lind, NRL) -!/ 05-Aug-2013 : Change PR2/3 to UQ/UNO in distances.( version 4.12 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 20-Jan-2017 : Fix SCRIP ALLWGTS allocation error and improve -!/ SCRIPNC SCRIP_STOP report and exit. ( version 6.02 ) -!/ -! 1. Purpose : -! -! Determine relation to higher ranked grids for each grid. -! Base map set in WMGLOW, supplemental data computed here. -! -! 2. Method : -! -! Map averaging information for higher ranked grid to lower -! ranked grid. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETO, W3SETG, W3DMO5, WMSETM -! Subr. W3xDATMD Manage data structures. -! STRACE Sur. W3SERVMD Subroutine tracing. -! EXTCDE Sur. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! Regarding the map of distances to the boundary : -! - v4.00 : the map of distances to the boundary was intentionally -! not an accurate characteristic distance. It was felt that -! it was more important that it be 'safe' and quick to compute. -! An iterative method was used to compute distance by starting -! at boundary and working inwards one grid row layer at a time, -! incrementing distance by dx etc. until the distance map was -! filled in. This was characterized as "local increment solution -! only." -! - v4.01 : conversion to work with irregular grids. Author could not -! think of any way to retain "local increment solution" method -! for situation of irregular grids. Therefore method has been -! changed to compute accurate distances. New method is also -! more transparent and simpler with much less code, thus -! easier to modify or debug. It is expected that this method -! could be more expensive to compute. Isolated timings were -! not performed. Since the iteration step has been removed, -! it is hoped that the expense is at least offset somewhat. -! -! Regarding method of calculating weights : -! o If SCRIP software is not compiled into WW3 by user -! (i.e. if SCRIP switch is not set, then original method -! (denoted "_OM") will be used. -! o If SCRIP is activated by user, and all grids are -! regular and specified in terms of meters (cartesian), -! then WMGHGH will calculate weights using both methods, -! and then compare the two, producing an error message -! if they do not match (built-in regression testing) -! For more info, see Section 0a below. -! -! re: Inconsistent RANK vs NBI (warning message) in Section 1.d : -! This was an error, but has been changed to a warning to allow -! more flexibility, e.g. having two outer grids with different -! rank (latter to avoid handling via WMGEQL). -! Change made July 2016. -! Old system: -! * grid rank > 1 and NBI>0 : do computations -! * grid rank > 1 and NBI=0 : error message -! * grid rank = 1 and NBI>0 : do nothing -! * grid rank = 1 and NBI=0 : do nothing -! New system: -! * grid rank > 1 and NBI>0 : do computations -! * grid rank > 1 and NBI=0 : do nothing w/ warning message -! * grid rank = 1 and NBI>0 : do nothing -! * grid rank = 1 and NBI=0 : do nothing -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Distributed memory approach -! !/DIST -! -! !/PRn propagation scheme. -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T3 Test output for received spectra. -! !/T4 Test output for sent spectra. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE CONSTANTS - USE W3SERVMD, ONLY: EXTCDE - USE W3GSRUMD, ONLY: W3DIST +9040 FORMAT ( ' TEST WMGLOW : GRDHGH DIMENSIONED AT ',I2) +9041 FORMAT ( ' TEST WMGLOW : GRDHGH :') +9042 FORMAT ( ' ',2i4,' : ',20I3) +#endif + !/ + !/ End of WMGLOW ----------------------------------------------------- / + !/ + END SUBROUTINE WMGLOW + + !/ ------------------------------------------------------------------- / + !> + !> @brief Determine relation to higher ranked grids for each grid. + !> + !> @details Base map set in WMGLOW, supplemental data computed here. + !> Map averaging information for higher ranked grid to lower ranked grid. + !> + !> @author H. L. Tolman + !> @author W. E. Rogers + !> @date 10-Dec-2014 + !> + SUBROUTINE WMGHGH + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | W. E. Rogers | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 28-Dec-2005 : Origination. ( version 3.08 ) + !/ 09-Mar-2006 : Carry over land mask. ( version 3.09 ) + !/ 28-Dec-2006 : Simplify NIT for partial comm. ( version 3.10 ) + !/ 07-Feb-2007 : Setting FLAGST. ( version 3.10 ) + !/ 20-May-2009 : Linking FLAGST and FLGHG1. ( version 3.14 ) + !/ 26-May-2009 : Fix erroneous cyclic updating. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) + !/ factor with DXDP and DXDQ terms. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 07-Jul-2011 : Bug fix for IX bounds with wrapping ( version 3.14+) + !/ grids (see use of "IDSTLA" below) + !/ (W. E. Rogers, NRL) + !/ 02-Aug-2011 : Adapted for use with irregular ( version 3.14+) + !/ grids (W. E. Rogers, NRL) + !/ 21-Sep-2012 : Modified to implement SCRIP remap ( version 4.11 ) + !/ file read and write option + !/ (K. R. Lind, NRL) + !/ 05-Aug-2013 : Change PR2/3 to UQ/UNO in distances.( version 4.12 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 20-Jan-2017 : Fix SCRIP ALLWGTS allocation error and improve + !/ SCRIPNC SCRIP_STOP report and exit. ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Determine relation to higher ranked grids for each grid. + ! Base map set in WMGLOW, supplemental data computed here. + ! + ! 2. Method : + ! + ! Map averaging information for higher ranked grid to lower + ! ranked grid. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETO, W3SETG, W3DMO5, WMSETM + ! Subr. W3xDATMD Manage data structures. + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! EXTCDE Sur. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! Regarding the map of distances to the boundary : + ! - v4.00 : the map of distances to the boundary was intentionally + ! not an accurate characteristic distance. It was felt that + ! it was more important that it be 'safe' and quick to compute. + ! An iterative method was used to compute distance by starting + ! at boundary and working inwards one grid row layer at a time, + ! incrementing distance by dx etc. until the distance map was + ! filled in. This was characterized as "local increment solution + ! only." + ! - v4.01 : conversion to work with irregular grids. Author could not + ! think of any way to retain "local increment solution" method + ! for situation of irregular grids. Therefore method has been + ! changed to compute accurate distances. New method is also + ! more transparent and simpler with much less code, thus + ! easier to modify or debug. It is expected that this method + ! could be more expensive to compute. Isolated timings were + ! not performed. Since the iteration step has been removed, + ! it is hoped that the expense is at least offset somewhat. + ! + ! Regarding method of calculating weights : + ! o If SCRIP software is not compiled into WW3 by user + ! (i.e. if SCRIP switch is not set, then original method + ! (denoted "_OM") will be used. + ! o If SCRIP is activated by user, and all grids are + ! regular and specified in terms of meters (cartesian), + ! then WMGHGH will calculate weights using both methods, + ! and then compare the two, producing an error message + ! if they do not match (built-in regression testing) + ! For more info, see Section 0a below. + ! + ! re: Inconsistent RANK vs NBI (warning message) in Section 1.d : + ! This was an error, but has been changed to a warning to allow + ! more flexibility, e.g. having two outer grids with different + ! rank (latter to avoid handling via WMGEQL). + ! Change made July 2016. + ! Old system: + ! * grid rank > 1 and NBI>0 : do computations + ! * grid rank > 1 and NBI=0 : error message + ! * grid rank = 1 and NBI>0 : do nothing + ! * grid rank = 1 and NBI=0 : do nothing + ! New system: + ! * grid rank > 1 and NBI>0 : do computations + ! * grid rank > 1 and NBI=0 : do nothing w/ warning message + ! * grid rank = 1 and NBI>0 : do nothing + ! * grid rank = 1 and NBI=0 : do nothing + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Distributed memory approach + ! !/DIST + ! + ! !/PRn propagation scheme. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T3 Test output for received spectra. + ! !/T4 Test output for sent spectra. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE CONSTANTS + USE W3SERVMD, ONLY: EXTCDE + USE W3GSRUMD, ONLY: W3DIST #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD - USE W3ODATMD - USE WMMDATMD - USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC -! USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC_GLOB + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD + USE W3ODATMD + USE WMMDATMD + USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC + ! USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC_GLOB #ifdef W3_SCRIP - USE WMSCRPMD - USE SCRIP_INTERFACE + USE WMSCRPMD + USE SCRIP_INTERFACE #endif -!/ - IMPLICIT NONE -! + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - -! notes re: variable names: During the extension for irregular grids, -! some variable were renamed to make the code more readable: -! JX==> ISRC -! JY==> JSRC -! IX==> IDST -! IY==> JDST -! grid I ==> grid GDST -! grid J ==> grid GSRC - - INTEGER :: GDST, IJ, IDST, JDST, GSRC, JJ, IB, ISEA, & - JSEA, IDSTLA, IDSTHA, JDSTLA, JDSTHA, & - ISRC, JSRC, ISRCL, ISRCH, JSRCL, JSRCH, NIT, & - NRTOT, NROK, JF, JR, NLMAX, ISPROC, ISPRO2, & - IREC, ISND, ITMP,ILOC + INCLUDE "mpif.h" +#endif + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + + ! notes re: variable names: During the extension for irregular grids, + ! some variable were renamed to make the code more readable: + ! JX==> ISRC + ! JY==> JSRC + ! IX==> IDST + ! IY==> JDST + ! grid I ==> grid GDST + ! grid J ==> grid GSRC + + INTEGER :: GDST, IJ, IDST, JDST, GSRC, JJ, IB, ISEA, & + JSEA, IDSTLA, IDSTHA, JDSTLA, JDSTHA, & + ISRC, JSRC, ISRCL, ISRCH, JSRCL, JSRCH, NIT, & + NRTOT, NROK, JF, JR, NLMAX, ISPROC, ISPRO2, & + IREC, ISND, ITMP,ILOC #ifdef W3_SCRIP INTEGER :: NLMAX_SCRIP #endif #ifdef W3_DIST - INTEGER :: LTAG0 + INTEGER :: LTAG0 #endif #ifdef W3_MPI - INTEGER :: IERR_MPI + INTEGER :: IERR_MPI #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, ALLOCATABLE :: IDSTL(:), IDSTH(:), JDSTL(:), JDSTH(:), & - MAPTST(:,:), & - I1(:,:), I2(:,:), I3(:), I4(:), & - INFLND(:,:) - INTEGER, ALLOCATABLE :: NX_BEG(:), NX_END(:) + INTEGER, ALLOCATABLE :: IDSTL(:), IDSTH(:), JDSTL(:), JDSTH(:), & + MAPTST(:,:), & + I1(:,:), I2(:,:), I3(:), I4(:), & + INFLND(:,:) + INTEGER, ALLOCATABLE :: NX_BEG(:), NX_END(:) #ifdef W3_MPIBDI - INTEGER, ALLOCATABLE :: NX_SIZE(:), IRQ(:), MSTAT(:,:) + INTEGER, ALLOCATABLE :: NX_SIZE(:), IRQ(:), MSTAT(:,:) #endif #ifdef W3_MPI - INTEGER :: IM, NX_REM, TAG, NRQ + INTEGER :: IM, NX_REM, TAG, NRQ #endif - INTEGER, ALLOCATABLE :: TMPINT_OM(:,:),TMPINT(:,:) - REAL, ALLOCATABLE :: TMPRL_OM(:,:) ,TMPRL(:,:) - REAL, ALLOCATABLE :: BDIST_OM(:) ,BDIST(:) - INTEGER :: NR0 , NR1 , NR2 , NRL , NLOC - INTEGER :: NR0_OM, NR1_OM, NR2_OM, NRL_OM, NLOC_OM + INTEGER, ALLOCATABLE :: TMPINT_OM(:,:),TMPINT(:,:) + REAL, ALLOCATABLE :: TMPRL_OM(:,:) ,TMPRL(:,:) + REAL, ALLOCATABLE :: BDIST_OM(:) ,BDIST(:) + INTEGER :: NR0 , NR1 , NR2 , NRL , NLOC + INTEGER :: NR0_OM, NR1_OM, NR2_OM, NRL_OM, NLOC_OM #ifdef W3_DIST - INTEGER, ALLOCATABLE :: LTAG(:) + INTEGER, ALLOCATABLE :: LTAG(:) #endif - REAL :: FACTOR, STX, STY, STXY, NEWVAL, & - XL, XH, YL, YH, XA, YA, DXC, JD, & - WX, WY, WTOT + REAL :: FACTOR, STX, STY, STXY, NEWVAL, & + XL, XH, YL, YH, XA, YA, DXC, JD, & + WX, WY, WTOT - LOGICAL :: FLGREC + LOGICAL :: FLGREC - LOGICAL, ALLOCATABLE :: GRIDOK(:), & - STMASK(:,:), MASKI(:,:), TMPLOG(:) + LOGICAL, ALLOCATABLE :: GRIDOK(:), & + STMASK(:,:), MASKI(:,:), TMPLOG(:) - INTEGER :: JBND,IBND ! counter for boundary points - REAL :: DD ! distance to boundary point - ! (temporary variable) - REAL :: XDST,YDST - REAL :: XSRC,YSRC - REAL :: WXWY - INTEGER :: NJDST,NIDST,KDST - INTEGER :: NJSRC,NISRC,KSRC - INTEGER :: IPNT,ICOUNT,IPNT2 - INTEGER :: DST_GRID_SIZE,ISTOP,JTMP + INTEGER :: JBND,IBND ! counter for boundary points + REAL :: DD ! distance to boundary point + ! (temporary variable) + REAL :: XDST,YDST + REAL :: XSRC,YSRC + REAL :: WXWY + INTEGER :: NJDST,NIDST,KDST + INTEGER :: NJSRC,NISRC,KSRC + INTEGER :: IPNT,ICOUNT,IPNT2 + INTEGER :: DST_GRID_SIZE,ISTOP,JTMP - REAL :: DX_MAX_GDST,DY_MAX_GDST - REAL :: DX_MIN_GSRC,DY_MIN_GSRC + REAL :: DX_MAX_GDST,DY_MAX_GDST + REAL :: DX_MIN_GSRC,DY_MIN_GSRC #ifdef W3_SCRIP - TYPE ALLWGT - TYPE(WEIGHT_DATA), POINTER :: WGTDATA(:) - END TYPE ALLWGT - TYPE(ALLWGT), ALLOCATABLE :: ALLWGTS(:) - LOGICAL :: L_MASTER = .TRUE. - LOGICAL :: L_READ = .FALSE. - LOGICAL :: L_WRITE = .FALSE. + TYPE ALLWGT + TYPE(WEIGHT_DATA), POINTER :: WGTDATA(:) + END TYPE ALLWGT + TYPE(ALLWGT), ALLOCATABLE :: ALLWGTS(:) + LOGICAL :: L_MASTER = .TRUE. + LOGICAL :: L_READ = .FALSE. + LOGICAL :: L_WRITE = .FALSE. #endif #ifdef W3_SCRIPNC - INTEGER :: IMPROC_ASSIGN - CHARACTER(LEN=80) :: interp_file1, interp_file_test - CHARACTER(LEN=3) :: cdst, csrc - LOGICAL, ALLOCATABLE :: LGRDREAD(:,:) - LOGICAL, ALLOCATABLE :: LGRDWRITE(:,:) - INTEGER :: NGRDRANK(2) -#endif - - LOGICAL :: LSCRIP=.FALSE. ! true if SCRIP switch is set, - ! indicates that SCRIP code has - ! been compiled into WW3 - LOGICAL :: LSCRIPNC=.FALSE. ! true if SCRIPNC switch is set, - ! indicates that SCRIP code has - ! been compiled with netCDF - ! into WW3 - LOGICAL :: L_STOP = .FALSE. ! true if SCRIPNC switch is set - ! and STOP_SCRIP file exists - LOGICAL :: T38=.FALSE. ! true if T38 switch is set. - ! This logical is necessary - ! since it isn't possible to - ! have two switches disabling - ! the same line of code. - LOGICAL :: ALL_REGULAR=.TRUE. ! true if all grids are - ! regular grids - LOGICAL :: DO_CHECKING=.FALSE. ! true if we will be - ! checking "old method" of - ! computing weights vs. - ! SCRIP method of computing - ! weights. - LOGICAL :: OLD_METHOD=.FALSE. ! true if we will compute - ! using "old method" (does - ! not necessarily mean - ! that this solution is - ! utilized) - LOGICAL :: LMPIBDI=.FALSE. ! true if MPIBDI switch is set - LOGICAL :: CALLED_SCRIP=.FALSE.! true if SCRIP has been - ! called for this processor - - - INTEGER :: ITRI, IM1, IM2, IT, JT, IsFirst - REAL :: DIST_MIN, DIST_MAX, eDist + INTEGER :: IMPROC_ASSIGN + CHARACTER(LEN=80) :: interp_file1, interp_file_test + CHARACTER(LEN=3) :: cdst, csrc + LOGICAL, ALLOCATABLE :: LGRDREAD(:,:) + LOGICAL, ALLOCATABLE :: LGRDWRITE(:,:) + INTEGER :: NGRDRANK(2) +#endif + + LOGICAL :: LSCRIP=.FALSE. ! true if SCRIP switch is set, + ! indicates that SCRIP code has + ! been compiled into WW3 + LOGICAL :: LSCRIPNC=.FALSE. ! true if SCRIPNC switch is set, + ! indicates that SCRIP code has + ! been compiled with netCDF + ! into WW3 + LOGICAL :: L_STOP = .FALSE. ! true if SCRIPNC switch is set + ! and STOP_SCRIP file exists + LOGICAL :: T38=.FALSE. ! true if T38 switch is set. + ! This logical is necessary + ! since it isn't possible to + ! have two switches disabling + ! the same line of code. + LOGICAL :: ALL_REGULAR=.TRUE. ! true if all grids are + ! regular grids + LOGICAL :: DO_CHECKING=.FALSE. ! true if we will be + ! checking "old method" of + ! computing weights vs. + ! SCRIP method of computing + ! weights. + LOGICAL :: OLD_METHOD=.FALSE. ! true if we will compute + ! using "old method" (does + ! not necessarily mean + ! that this solution is + ! utilized) + LOGICAL :: LMPIBDI=.FALSE. ! true if MPIBDI switch is set + LOGICAL :: CALLED_SCRIP=.FALSE.! true if SCRIP has been + ! called for this processor + + + INTEGER :: ITRI, IM1, IM2, IT, JT, IsFirst + REAL :: DIST_MIN, DIST_MAX, eDist #ifdef W3_T - CHARACTER(LEN=1), ALLOCATABLE :: MAPST(:,:) + CHARACTER(LEN=1), ALLOCATABLE :: MAPST(:,:) #endif -!/ + !/ #ifdef W3_T38 - CHARACTER (LEN=10) :: CDATE_TIME(3) - INTEGER :: DATE_TIME(8) - INTEGER :: ELAPSED_TIME, BEG_TIME(10), END_TIME - INTEGER :: NMYOUT=42 - CHARACTER (LEN=14) :: CMYOUT="myout00000.lis" - CHARACTER (LEN=5) :: CRANK + CHARACTER (LEN=10) :: CDATE_TIME(3) + INTEGER :: DATE_TIME(8) + INTEGER :: ELAPSED_TIME, BEG_TIME(10), END_TIME + INTEGER :: NMYOUT=42 + CHARACTER (LEN=14) :: CMYOUT="myout00000.lis" + CHARACTER (LEN=5) :: CRANK #endif #ifdef W3_T38 - WRITE(CRANK, "(I5.5)") IMPROC-1 - CMYOUT(6:10) = CRANK(1:5) - OPEN (NMYOUT, FILE=CMYOUT, STATUS="REPLACE") + WRITE(CRANK, "(I5.5)") IMPROC-1 + CMYOUT(6:10) = CRANK(1:5) + OPEN (NMYOUT, FILE=CMYOUT, STATUS="REPLACE") #endif #ifdef W3_S - CALL STRACE (IENT, 'WMGHGH') + CALL STRACE (IENT, 'WMGHGH') #endif -! + ! #ifdef W3_MPI CALL MPI_BARRIER(MPI_COMM_MWAVE, IERR_MPI) #endif #ifdef W3_T38 - CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - BEG_TIME(1) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) - WRITE(NMYOUT,*) "WMGHGH: START: 0 MSEC" + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(1) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + WRITE(NMYOUT,*) "WMGHGH: START: 0 MSEC" #endif -! -------------------------------------------------------------------- / -! 0. Initializations / tests -! - IF ( .NOT. ALLOCATED(GRDHGH) ) THEN - IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,1000) - CALL EXTCDE (1000) - END IF + ! -------------------------------------------------------------------- / + ! 0. Initializations / tests + ! + IF ( .NOT. ALLOCATED(GRDHGH) ) THEN + IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,1000) + CALL EXTCDE (1000) + END IF #ifdef W3_MPIBDI - LMPIBDI=.TRUE. + LMPIBDI=.TRUE. #endif #ifdef W3_SCRIP - IF (IMPROC .EQ. 1) THEN - L_MASTER = .TRUE. - L_WRITE = .TRUE. - ELSE - L_MASTER = .FALSE. - L_WRITE = .FALSE. - ENDIF + IF (IMPROC .EQ. 1) THEN + L_MASTER = .TRUE. + L_WRITE = .TRUE. + ELSE + L_MASTER = .FALSE. + L_WRITE = .FALSE. + ENDIF #endif #ifdef W3_SCRIPNC - INQUIRE(FILE="SCRIP_STOP", EXIST=L_STOP) - IMPROC_ASSIGN = 1 + INQUIRE(FILE="SCRIP_STOP", EXIST=L_STOP) + IMPROC_ASSIGN = 1 #endif -! -!KRL Allocate helper arrays to enable bottleneck loop parallelization - ALLOCATE ( NX_BEG(NMPROC), NX_END(NMPROC), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ! + !KRL Allocate helper arrays to enable bottleneck loop parallelization + ALLOCATE ( NX_BEG(NMPROC), NX_END(NMPROC), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_MPIBDI - ALLOCATE ( NX_SIZE(NMPROC), IRQ(2*NMPROC), & - MSTAT(MPI_STATUS_SIZE,2*NMPROC), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! -!!HT: -!!HT: Set up and initialize storage data structures .... -!!HT: + ALLOCATE ( NX_SIZE(NMPROC), IRQ(2*NMPROC), & + MSTAT(MPI_STATUS_SIZE,2*NMPROC), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! + !!HT: + !!HT: Set up and initialize storage data structures .... + !!HT: #ifdef W3_T38 - CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - BEG_TIME(2) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -#endif - DO GDST=1, NRGRD - DO GSRC=1, NRGRD - IF ( HGSTGE(GDST,GSRC)%INIT ) THEN - IF ( HGSTGE(GDST,GSRC)%NREC .NE. 0 ) THEN - DEALLOCATE ( & - HGSTGE(GDST,GSRC)%LJSEA , HGSTGE(GDST,GSRC)%NRAVG, & - HGSTGE(GDST,GSRC)%IMPSRC, HGSTGE(GDST,GSRC)%ITAG , & - HGSTGE(GDST,GSRC)%WGTH , HGSTGE(GDST,GSRC)%SHGH , & - STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END IF - IF ( HGSTGE(GDST,GSRC)%NSND .NE. 0 ) THEN - DEALLOCATE ( & - HGSTGE(GDST,GSRC)%ISEND , & - STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END IF - HGSTGE(GDST,GSRC)%NTOT = 0 - HGSTGE(GDST,GSRC)%NREC = 0 - HGSTGE(GDST,GSRC)%NRC1 = 0 - HGSTGE(GDST,GSRC)%NSND = 0 - HGSTGE(GDST,GSRC)%NSN1 = 0 - HGSTGE(GDST,GSRC)%NSMX = 0 - HGSTGE(GDST,GSRC)%INIT = .FALSE. - END IF - END DO + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(2) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) +#endif + DO GDST=1, NRGRD + DO GSRC=1, NRGRD + IF ( HGSTGE(GDST,GSRC)%INIT ) THEN + IF ( HGSTGE(GDST,GSRC)%NREC .NE. 0 ) THEN + DEALLOCATE ( & + HGSTGE(GDST,GSRC)%LJSEA , HGSTGE(GDST,GSRC)%NRAVG, & + HGSTGE(GDST,GSRC)%IMPSRC, HGSTGE(GDST,GSRC)%ITAG , & + HGSTGE(GDST,GSRC)%WGTH , HGSTGE(GDST,GSRC)%SHGH , & + STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + IF ( HGSTGE(GDST,GSRC)%NSND .NE. 0 ) THEN + DEALLOCATE ( & + HGSTGE(GDST,GSRC)%ISEND , & + STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + HGSTGE(GDST,GSRC)%NTOT = 0 + HGSTGE(GDST,GSRC)%NREC = 0 + HGSTGE(GDST,GSRC)%NRC1 = 0 + HGSTGE(GDST,GSRC)%NSND = 0 + HGSTGE(GDST,GSRC)%NSN1 = 0 + HGSTGE(GDST,GSRC)%NSMX = 0 + HGSTGE(GDST,GSRC)%INIT = .FALSE. + END IF END DO - GDST=-999 ! unset grid - GSRC=-999 ! unset grid + END DO + GDST=-999 ! unset grid + GSRC=-999 ! unset grid #ifdef W3_T38 - CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) - ELAPSED_TIME = END_TIME - BEG_TIME(2) - WRITE(NMYOUT,*) "WMGHGH, LOOP 1 TOOK ", ELAPSED_TIME, " MSEC" + CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = END_TIME - BEG_TIME(2) + WRITE(NMYOUT,*) "WMGHGH, LOOP 1 TOOK ", ELAPSED_TIME, " MSEC" #endif -! -------------------------------------------------------------------- / -! 0.a Plan future behavior by setting logical variables. + ! -------------------------------------------------------------------- / + ! 0.a Plan future behavior by setting logical variables. #ifdef W3_SCRIP - LSCRIP=.TRUE. + LSCRIP=.TRUE. #endif #ifdef W3_SCRIPNC - LSCRIPNC=.TRUE. + LSCRIPNC=.TRUE. #endif #ifdef W3_T38 - T38=.TRUE. + T38=.TRUE. #endif - DO GDST=1, NRGRD - IF ( GRIDS(GDST)%GTYPE .NE. RLGTYPE .AND. & - GRIDS(GDST)%GTYPE .NE. SMCTYPE ) THEN -!!Li Add SMCTYPE option into ALL_REGULAR case. JGLi20Nov2020 - ALL_REGULAR=.FALSE. - END IF - END DO - -! Notes re: FLAGLL case: Old method calculates overlap area based on deg lat -! and deg lon. New method (SCRIP) calculates overlap area based on real -! distances. Therefore weights will not match for FLAGLL case, so we -! do not perform checking for FLAGLL case. - - IF ( (.NOT.FLAGLL) .AND. ALL_REGULAR .AND. LSCRIP ) THEN - IF ( IMPROC.EQ.NMPERR ) & - WRITE (MDSE,'(/2A)')'We will check SCRIP calculations ', & - 'against old method of calculating weights.' - DO_CHECKING=.TRUE. - END IF - - IF (DO_CHECKING .OR. (.NOT.LSCRIP)) OLD_METHOD=.TRUE. - -! -------------------------------------------------------------------- / -! 0.b Check solution method - - IF ( (.NOT.LSCRIP) .AND. (.NOT.ALL_REGULAR) .AND. & - (NRGRD.GT.1) ) THEN - IF ( IMPROC.EQ.NMPERR ) & - WRITE (MDSE,'(/3A)') ' *** ERROR WMGHGH: ', & - 'IRREGULAR or UNSTRUCTURED grid detected: this requires ', & - 'SCRIP switch.' - CALL EXTCDE ( 999 ) + DO GDST=1, NRGRD + IF ( GRIDS(GDST)%GTYPE .NE. RLGTYPE .AND. & + GRIDS(GDST)%GTYPE .NE. SMCTYPE ) THEN + !!Li Add SMCTYPE option into ALL_REGULAR case. JGLi20Nov2020 + ALL_REGULAR=.FALSE. END IF - -! -! -------------------------------------------------------------------- / -! 1. Set boundary distance maps -! 1.a Check if needed -! -!!HT: FLGBDI is a flag set in WMMDATMD to .FALSE. and is used to identify -!!HT: if the boundary distance maps have been initialized -!!HT: -!!HT: For each individual grid a map is generated identifying the distance -!!HT: to open boundaries (MAPBDI, saved in structure MDATA in WMMDATMD). -!!HT: This map is used later to choose if more that 1 high-res grids -!!HT: could provide data to a low-res grid. The high-res grid with data -!!HT: furthest away from its own open boundary will be used. + END DO + + ! Notes re: FLAGLL case: Old method calculates overlap area based on deg lat + ! and deg lon. New method (SCRIP) calculates overlap area based on real + ! distances. Therefore weights will not match for FLAGLL case, so we + ! do not perform checking for FLAGLL case. + + IF ( (.NOT.FLAGLL) .AND. ALL_REGULAR .AND. LSCRIP ) THEN + IF ( IMPROC.EQ.NMPERR ) & + WRITE (MDSE,'(/2A)')'We will check SCRIP calculations ', & + 'against old method of calculating weights.' + DO_CHECKING=.TRUE. + END IF + + IF (DO_CHECKING .OR. (.NOT.LSCRIP)) OLD_METHOD=.TRUE. + + ! -------------------------------------------------------------------- / + ! 0.b Check solution method + + IF ( (.NOT.LSCRIP) .AND. (.NOT.ALL_REGULAR) .AND. & + (NRGRD.GT.1) ) THEN + IF ( IMPROC.EQ.NMPERR ) & + WRITE (MDSE,'(/3A)') ' *** ERROR WMGHGH: ', & + 'IRREGULAR or UNSTRUCTURED grid detected: this requires ', & + 'SCRIP switch.' + CALL EXTCDE ( 999 ) + END IF + + ! + ! -------------------------------------------------------------------- / + ! 1. Set boundary distance maps + ! 1.a Check if needed + ! + !!HT: FLGBDI is a flag set in WMMDATMD to .FALSE. and is used to identify + !!HT: if the boundary distance maps have been initialized + !!HT: + !!HT: For each individual grid a map is generated identifying the distance + !!HT: to open boundaries (MAPBDI, saved in structure MDATA in WMMDATMD). + !!HT: This map is used later to choose if more that 1 high-res grids + !!HT: could provide data to a low-res grid. The high-res grid with data + !!HT: furthest away from its own open boundary will be used. #ifdef W3_SCRIPNC - IF (.NOT. L_STOP) THEN ! Do not need MAPBDI if going to stop after generating mappings + IF (.NOT. L_STOP) THEN ! Do not need MAPBDI if going to stop after generating mappings #endif IF ( .NOT. FLGBDI ) THEN -! - IF ( FLAGLL ) THEN - FACTOR = RADIUS * DERA -!notes: was FACTOR = RADIUS / 360. (bug fix) - ELSE - FACTOR = 1. - END IF -! + ! + IF ( FLAGLL ) THEN + FACTOR = RADIUS * DERA + !notes: was FACTOR = RADIUS / 360. (bug fix) + ELSE + FACTOR = 1. + END IF + ! #ifdef W3_T - WRITE (MDST,9010) + WRITE (MDST,9010) #endif -! -! 1.b Loop over grids -! + ! + ! 1.b Loop over grids + ! #ifdef W3_T38 - CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - BEG_TIME(3) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) - ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) - WRITE(NMYOUT,*) "WMGHGH, BEGINNING BOTTLENECK LOOP AT ", ELAPSED_TIME, " MSEC" + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(3) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) + WRITE(NMYOUT,*) "WMGHGH, BEGINNING BOTTLENECK LOOP AT ", ELAPSED_TIME, " MSEC" #endif - DO GDST=1, NRGRD + DO GDST=1, NRGRD #ifdef W3_T38 - IF(IMPROC.EQ.NMPERR)WRITE(MDSE,*)'GDST = ',GDST,' OUT OF ',NRGRD + IF(IMPROC.EQ.NMPERR)WRITE(MDSE,*)'GDST = ',GDST,' OUT OF ',NRGRD #endif - CALL W3SETO ( GDST, MDSE, MDST ) - CALL W3SETG ( GDST, MDSE, MDST ) - CALL WMSETM ( GDST, MDSE, MDST ) + CALL W3SETO ( GDST, MDSE, MDST ) + CALL W3SETG ( GDST, MDSE, MDST ) + CALL WMSETM ( GDST, MDSE, MDST ) -! IF ( GTYPE .EQ. UNGTYPE ) THEN -! IF ( IMPROC.EQ.NMPERR ) & -! WRITE (MDSE,'(/2A)') ' *** ERROR WMGHGH: ', & -! 'UNSTRUCTURED GRID SUPPORT NOT YET IMPLEMENTED ***' -! CALL EXTCDE ( 999 ) -! END IF + ! IF ( GTYPE .EQ. UNGTYPE ) THEN + ! IF ( IMPROC.EQ.NMPERR ) & + ! WRITE (MDSE,'(/2A)') ' *** ERROR WMGHGH: ', & + ! 'UNSTRUCTURED GRID SUPPORT NOT YET IMPLEMENTED ***' + ! CALL EXTCDE ( 999 ) + ! END IF -! + ! #ifdef W3_T - WRITE (MDST,9011) GDST, GRANK(GDST), NBI -#endif -! -! -------------------------------------------------------------------- / -! Inconsistent RANK vs NBI (warning message) -! This was an error, now changed to a warning (see notes section) - IF ( (GRANK(GDST).NE.1) .AND. (NBI.EQ.0) ) THEN - IF ( IMPROC.EQ.NMPERR ) & - WRITE (MDSE,'(/2A)') ' WARNING in WMGHGH: ', & - 'NBI=0 AND RANK > 1 ' - END IF + WRITE (MDST,9011) GDST, GRANK(GDST), NBI +#endif + ! + ! -------------------------------------------------------------------- / + ! Inconsistent RANK vs NBI (warning message) + ! This was an error, now changed to a warning (see notes section) + IF ( (GRANK(GDST).NE.1) .AND. (NBI.EQ.0) ) THEN + IF ( IMPROC.EQ.NMPERR ) & + WRITE (MDSE,'(/2A)') ' WARNING in WMGHGH: ', & + 'NBI=0 AND RANK > 1 ' + END IF -! -------------------------------------------------------------------- / -! 1.c NBI=0, so computations not needed (test output only) -! - IF ( (NBI.EQ.0) .OR. (GRANK(GDST).EQ.1) ) THEN -! (then do nothing except test output) + ! -------------------------------------------------------------------- / + ! 1.c NBI=0, so computations not needed (test output only) + ! + IF ( (NBI.EQ.0) .OR. (GRANK(GDST).EQ.1) ) THEN + ! (then do nothing except test output) #ifdef W3_T - WRITE (MDST,9012) + WRITE (MDST,9012) #endif -! -------------------------------------------------------------------- / -! 1.d NBI>0, Generate map with distances to boundary. + ! -------------------------------------------------------------------- / + ! 1.d NBI>0, Generate map with distances to boundary. -!!HT: Initialize MAPBDI -!!HT: 0. for active boundary points -!!HT: -1. for points that are not considered at all (rescaled for test -!!HT: output only, only negative value is essentially later). -!!HT: -2. for points that still need to be processed. + !!HT: Initialize MAPBDI + !!HT: 0. for active boundary points + !!HT: -1. for points that are not considered at all (rescaled for test + !!HT: output only, only negative value is essentially later). + !!HT: -2. for points that still need to be processed. - ELSE + ELSE - IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A)') & - ' Generating map with distances to boundary.' -! for purposes of screen output, would be useful to wait for other processors to catch up here...(if mpibdi switch used) - ALLOCATE ( MDATAS(GDST)%MAPBDI(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - MAPBDI => MDATAS(GDST)%MAPBDI -! -!KRL Set up ranges for X. If not MPIBDI, just 1 to NX - NX_BEG(IMPROC) = 1 - NX_END(IMPROC) = NX + IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A)') & + ' Generating map with distances to boundary.' + ! for purposes of screen output, would be useful to wait for other processors to catch up here...(if mpibdi switch used) + ALLOCATE ( MDATAS(GDST)%MAPBDI(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + MAPBDI => MDATAS(GDST)%MAPBDI + ! + !KRL Set up ranges for X. If not MPIBDI, just 1 to NX + NX_BEG(IMPROC) = 1 + NX_END(IMPROC) = NX #ifdef W3_MPIBDI - NX_BEG(1) = 1 - IF ( NMPROC .EQ. 1 ) THEN - NX_END(1) = NX - NX_SIZE(1) = NX - ELSE - NX_REM = MOD( NX, NMPROC ) - NX_SIZE(1) = NX / NMPROC - IF (NX_REM .GT. 0) NX_SIZE(1) = NX_SIZE(1) + 1 - NX_END(1) = NX_BEG(1) + NX_SIZE(1) - 1 - DO IM = 2, NMPROC - NX_BEG(IM) = NX_END(IM-1) + 1 - NX_SIZE(IM) = NX / NMPROC - IF (IM .LE. NX_REM) NX_SIZE(IM) = NX_SIZE(IM) + 1 - NX_END(IM) = NX_BEG(IM) + NX_SIZE(IM) - 1 - NX_SIZE(IM-1) = NX_SIZE(IM-1) * NY - END DO - NX_SIZE(NMPROC) = NX_SIZE(NMPROC) * NY - END IF -#endif -!KRL Setup complete -! -! -------------------------------------------------------------------- / -! Loop to determine MAPBDI -! -------------------------------------------------------------------- / - - IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A)') & - 'Starting MAPBDI 1st loop.' - - DO IDST=NX_BEG(IMPROC), NX_END(IMPROC) - IF(MOD(IDST,250).EQ.0)THEN - IF(LMPIBDI)THEN - WRITE(MDSE,'(4x,3(A,I5))')& - 'processing column ',IDST,' out of ',NX, & - ' on processor ',IMPROC - ELSEIF(IMPROC.EQ.NMPERR)THEN - WRITE(MDSE,'(4x,2(A,I5))')& - 'processing column ',IDST,' out of ',NX - ENDIF - ENDIF - DO JDST=1, NY - IF ( MAPSTA(JDST,IDST) .EQ. 0 ) THEN ! (excluded point) - MAPBDI(JDST,IDST) = -1. / SIG(1) * DTMAX ! new (bug fix) - ELSE IF ( ABS(MAPSTA(JDST,IDST)) .EQ. 2 ) THEN - ! (boundary point) - MAPBDI(JDST,IDST) = 0. - ELSE ! ABS(MAPSTA)=1 (sea point) - MAPBDI(JDST,IDST) = 1.0E+10 - ENDIF ! IF MAPSTA - END DO ! DO JDST... - END DO ! DO IDST... - -! -------------------------------------------------------------------- / - - IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A)') & - 'Starting MAPBDI 2nd loop.' - - DO IBND=1,NX - IF ( (MOD(IBND,25).EQ.0) .AND. & - (IMPROC.EQ.NMPERR) ) THEN - WRITE(MDSE,'(4x,2(A,I5))') & - 'bnd. point ',IBND,' out of ',NX - ENDIF - DO JBND=1,NY - IF ( ABS(MAPSTA(JBND,IBND)) .EQ. 2 ) THEN - ! (boundary point) + NX_BEG(1) = 1 + IF ( NMPROC .EQ. 1 ) THEN + NX_END(1) = NX + NX_SIZE(1) = NX + ELSE + NX_REM = MOD( NX, NMPROC ) + NX_SIZE(1) = NX / NMPROC + IF (NX_REM .GT. 0) NX_SIZE(1) = NX_SIZE(1) + 1 + NX_END(1) = NX_BEG(1) + NX_SIZE(1) - 1 + DO IM = 2, NMPROC + NX_BEG(IM) = NX_END(IM-1) + 1 + NX_SIZE(IM) = NX / NMPROC + IF (IM .LE. NX_REM) NX_SIZE(IM) = NX_SIZE(IM) + 1 + NX_END(IM) = NX_BEG(IM) + NX_SIZE(IM) - 1 + NX_SIZE(IM-1) = NX_SIZE(IM-1) * NY + END DO + NX_SIZE(NMPROC) = NX_SIZE(NMPROC) * NY + END IF +#endif + !KRL Setup complete + ! + ! -------------------------------------------------------------------- / + ! Loop to determine MAPBDI + ! -------------------------------------------------------------------- / + + IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A)') & + 'Starting MAPBDI 1st loop.' + + DO IDST=NX_BEG(IMPROC), NX_END(IMPROC) + IF(MOD(IDST,250).EQ.0)THEN + IF(LMPIBDI)THEN + WRITE(MDSE,'(4x,3(A,I5))')& + 'processing column ',IDST,' out of ',NX, & + ' on processor ',IMPROC + ELSEIF(IMPROC.EQ.NMPERR)THEN + WRITE(MDSE,'(4x,2(A,I5))')& + 'processing column ',IDST,' out of ',NX + ENDIF + ENDIF + DO JDST=1, NY + IF ( MAPSTA(JDST,IDST) .EQ. 0 ) THEN ! (excluded point) + MAPBDI(JDST,IDST) = -1. / SIG(1) * DTMAX ! new (bug fix) + ELSE IF ( ABS(MAPSTA(JDST,IDST)) .EQ. 2 ) THEN + ! (boundary point) + MAPBDI(JDST,IDST) = 0. + ELSE ! ABS(MAPSTA)=1 (sea point) + MAPBDI(JDST,IDST) = 1.0E+10 + ENDIF ! IF MAPSTA + END DO ! DO JDST... + END DO ! DO IDST... + + ! -------------------------------------------------------------------- / + + IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A)') & + 'Starting MAPBDI 2nd loop.' + + DO IBND=1,NX + IF ( (MOD(IBND,25).EQ.0) .AND. & + (IMPROC.EQ.NMPERR) ) THEN + WRITE(MDSE,'(4x,2(A,I5))') & + 'bnd. point ',IBND,' out of ',NX + ENDIF + DO JBND=1,NY + IF ( ABS(MAPSTA(JBND,IBND)) .EQ. 2 ) THEN + ! (boundary point) #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE(IDST,JDST,DD),SCHEDULE(DYNAMIC) -#endif - DO IDST=NX_BEG(IMPROC), NX_END(IMPROC) - DO JDST=1, NY - IF (ABS(MAPSTA(JDST,IDST)) .EQ. 1) THEN - !....find distance to this boundary point. - DD=FACTOR*W3DIST(FLAGLL,REAL(XGRD(JDST,IDST)), & - REAL(YGRD(JDST,IDST)),REAL(XGRD(JBND,IBND)), & - REAL(YGRD(JBND,IBND))) - -! Notes: The origin of "0.58 * GRAV" is to translate from distance (in meters) -! to time (in seconds) required for a wave to travel from the boundary to point -! JDST,IDST based on a specific group velocity 0.58*grav would be the group -! velocity of a 7.3 s wave in deep water. Significance of T=7.3 s is explained -! in notes by HT below. - - DD=DD/ ( 0.58 * GRAV ) - MAPBDI(JDST,IDST)=MIN(MAPBDI(JDST,IDST),DD) - ENDIF - END DO ! DO JDST - END DO ! DO IDST + !$OMP PARALLEL DO PRIVATE(IDST,JDST,DD),SCHEDULE(DYNAMIC) +#endif + DO IDST=NX_BEG(IMPROC), NX_END(IMPROC) + DO JDST=1, NY + IF (ABS(MAPSTA(JDST,IDST)) .EQ. 1) THEN + !....find distance to this boundary point. + DD=FACTOR*W3DIST(FLAGLL,REAL(XGRD(JDST,IDST)), & + REAL(YGRD(JDST,IDST)),REAL(XGRD(JBND,IBND)), & + REAL(YGRD(JBND,IBND))) + + ! Notes: The origin of "0.58 * GRAV" is to translate from distance (in meters) + ! to time (in seconds) required for a wave to travel from the boundary to point + ! JDST,IDST based on a specific group velocity 0.58*grav would be the group + ! velocity of a 7.3 s wave in deep water. Significance of T=7.3 s is explained + ! in notes by HT below. + + DD=DD/ ( 0.58 * GRAV ) + MAPBDI(JDST,IDST)=MIN(MAPBDI(JDST,IDST),DD) + ENDIF + END DO ! DO JDST + END DO ! DO IDST #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif - ENDIF ! (if BND point) + ENDIF ! (if BND point) - END DO ! DO JBND - END DO ! DO IBND + END DO ! DO JBND + END DO ! DO IBND - IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A)') & - 'Finished MAPBDI 2nd loop.' + IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A)') & + 'Finished MAPBDI 2nd loop.' -! -------------------------------------------------------------------- / + ! -------------------------------------------------------------------- / #ifdef W3_MPIBDI - !KRL Exchange (Note: for efficiency, post receives first) - !KRL MPI_ALLGATHERV would do this, but freezes for PGI and open_mpi - !KRL This suggests they use blocking SEND/RECV, so this is faster anyway and less implementation-dependent - NRQ = 0 - DO IM = 1, NMPROC - IF ( IM .NE. IMPROC ) THEN - NRQ = NRQ + 1 - TAG = NMPROC * IM + IMPROC - CALL MPI_IRECV ( MAPBDI(1,NX_BEG(IM)), NX_SIZE(IM), MPI_REAL, IM - 1, TAG, MPI_COMM_MWAVE, & - IRQ(NRQ), IERR_MPI ) - END IF - END DO - DO IM = 1, NMPROC - IF ( IM .NE. IMPROC ) THEN - NRQ = NRQ + 1 - TAG = NMPROC * IMPROC + IM - CALL MPI_ISEND( MAPBDI(1,NX_BEG(IMPROC)), NX_SIZE(IMPROC), MPI_REAL, IM - 1, TAG, MPI_COMM_MWAVE, & - IRQ(NRQ), IERR_MPI ) - END IF - END DO - CALL MPI_WAITALL( NRQ, IRQ, MPI_STATUS_IGNORE, IERR_MPI ) - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) -#endif - - IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A/)') & - ' Finished generating map with distances to boundary.' - -!...notes regarding old method of doing what we just did -!!HT: -!!HT: (1) -!!HT: -!!HT: CHANGE array is used to identify grid points that still need to -!!HT: be processed, and that are adjacent to points that have been -!!HT: processed. Only those points can be updated in this step of the -!!HT: loop started above here. The two loops below set the CHANGE array. -!!HT: -!!HT: (2) -!!HT: -!!HT: CHANGD identify if more points have been updated -!!HT: -!!HT: STX and STY are partial normalized distances, defined as the -!!HT: physical distance Delta Y ( FACTOR * SY ) and Delta X -!!HT: ( FACTOR * SX * XLAT(JDST) ), devided by the sistance traveled, -!!HT: which is CgMAX * DTMAX. CgMAX is approximately 1.15 * CgDEEP, -!!HT: or 1.15 * 0.5 * C_DEEP = 0.58 * GRAV / SIG(1). Since SIG(1) and -!!HT: DTMAX may vary, these two factors are not included in MAPBDI. -!!HT: -!!HT: This defines MAPBDI similar to an inverse CFL number. -!!HT: -!!HT: (3) -!!HT: -!!HT: ERROR : Should be CLAT(JDST), not CLATI(JDST) : "STX = FACTOR * SX * CLATI(JDST) / ( 0.58 * GRAV )" - -! 1.e Test output -! -!!HT: Note that SIG(1) and DTMAX are included here so that the map defines -!!HT: how many time steps DTMAX it takes to reach this place. + !KRL Exchange (Note: for efficiency, post receives first) + !KRL MPI_ALLGATHERV would do this, but freezes for PGI and open_mpi + !KRL This suggests they use blocking SEND/RECV, so this is faster anyway and less implementation-dependent + NRQ = 0 + DO IM = 1, NMPROC + IF ( IM .NE. IMPROC ) THEN + NRQ = NRQ + 1 + TAG = NMPROC * IM + IMPROC + CALL MPI_IRECV ( MAPBDI(1,NX_BEG(IM)), NX_SIZE(IM), MPI_REAL, IM - 1, TAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) + END IF + END DO + DO IM = 1, NMPROC + IF ( IM .NE. IMPROC ) THEN + NRQ = NRQ + 1 + TAG = NMPROC * IMPROC + IM + CALL MPI_ISEND( MAPBDI(1,NX_BEG(IMPROC)), NX_SIZE(IMPROC), MPI_REAL, IM - 1, TAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) + END IF + END DO + CALL MPI_WAITALL( NRQ, IRQ, MPI_STATUS_IGNORE, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif + + IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A/)') & + ' Finished generating map with distances to boundary.' + + !...notes regarding old method of doing what we just did + !!HT: + !!HT: (1) + !!HT: + !!HT: CHANGE array is used to identify grid points that still need to + !!HT: be processed, and that are adjacent to points that have been + !!HT: processed. Only those points can be updated in this step of the + !!HT: loop started above here. The two loops below set the CHANGE array. + !!HT: + !!HT: (2) + !!HT: + !!HT: CHANGD identify if more points have been updated + !!HT: + !!HT: STX and STY are partial normalized distances, defined as the + !!HT: physical distance Delta Y ( FACTOR * SY ) and Delta X + !!HT: ( FACTOR * SX * XLAT(JDST) ), devided by the sistance traveled, + !!HT: which is CgMAX * DTMAX. CgMAX is approximately 1.15 * CgDEEP, + !!HT: or 1.15 * 0.5 * C_DEEP = 0.58 * GRAV / SIG(1). Since SIG(1) and + !!HT: DTMAX may vary, these two factors are not included in MAPBDI. + !!HT: + !!HT: This defines MAPBDI similar to an inverse CFL number. + !!HT: + !!HT: (3) + !!HT: + !!HT: ERROR : Should be CLAT(JDST), not CLATI(JDST) : "STX = FACTOR * SX * CLATI(JDST) / ( 0.58 * GRAV )" + + ! 1.e Test output + ! + !!HT: Note that SIG(1) and DTMAX are included here so that the map defines + !!HT: how many time steps DTMAX it takes to reach this place. #ifdef W3_T - WRITE (MDST,9013) - DO JDST=NY,1 , -1 - WRITE (MDST,9014) NINT(MAPBDI(JDST,:)*SIG(1)/DTMAX) - END DO + WRITE (MDST,9013) + DO JDST=NY,1 , -1 + WRITE (MDST,9014) NINT(MAPBDI(JDST,:)*SIG(1)/DTMAX) + END DO #endif -! - END IF - END DO - FLGBDI = .TRUE. + ! + END IF + END DO + FLGBDI = .TRUE. END IF #ifdef W3_SCRIPNC - END IF + END IF #endif -! -! -------------------------------------------------------------------- / -! 2. Data sources for reconcilliation -! 2.a Loop over grids, processing check -! + ! + ! -------------------------------------------------------------------- / + ! 2. Data sources for reconcilliation + ! 2.a Loop over grids, processing check + ! -!!HT: GRDHGH(GDST,0) was set in WMGLOW to identify how many grids may -!!HT: contribute from higher ranks to the present grid (GDST). + !!HT: GRDHGH(GDST,0) was set in WMGLOW to identify how many grids may + !!HT: contribute from higher ranks to the present grid (GDST). - ALLOCATE ( I1(NRGRD,NMPROC), I2(NRGRD,NMPROC), & - I3(NRGRD), I4(NRGRD), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( I1(NRGRD,NMPROC), I2(NRGRD,NMPROC), & + I3(NRGRD), I4(NRGRD), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_DIST - LTAG0 = 0 + LTAG0 = 0 #endif #ifdef W3_SCRIPNC - ! If reading/writing SCRIP files, need to determine in advance which it is to avoid race condition: - ! Processor writing file before other processor can check for it - NGRDRANK = SHAPE(GRDHGH) - ALLOCATE( LGRDREAD(NGRDRANK(1)-1, NGRDRANK(2)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(LGRDWRITE(NGRDRANK(1)-1, NGRDRANK(2)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - DO GDST=1, NRGRD - DO JJ = 1, GRDHGH(GDST,0) - IF ( GRDHGH(GDST,0) .EQ. 0 ) THEN - ! If no remap, then no file - LGRDREAD(GDST,JJ) = .FALSE. - LGRDWRITE(GDST,JJ) = .FALSE. - ELSE - GSRC = GRDHGH(GDST,JJ) - INTERP_FILE1 = "rmp_src_to_dst_conserv_xxx_xxx.nc" - WRITE(CDST, "(I3.3)") GDST - WRITE(CSRC, "(I3.3)") GSRC - INTERP_FILE1(24:26) = CSRC - INTERP_FILE1(28:30) = CDST - INQUIRE(FILE=INTERP_FILE1, EXIST=L_READ) - ! At this point, file either exists already (L_READ = .TRUE.) or needs to be written - LGRDREAD(GDST,JJ) = L_READ - LGRDWRITE(GDST,JJ) = .NOT. L_READ - END IF - END DO + ! If reading/writing SCRIP files, need to determine in advance which it is to avoid race condition: + ! Processor writing file before other processor can check for it + NGRDRANK = SHAPE(GRDHGH) + ALLOCATE( LGRDREAD(NGRDRANK(1)-1, NGRDRANK(2)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(LGRDWRITE(NGRDRANK(1)-1, NGRDRANK(2)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + DO GDST=1, NRGRD + DO JJ = 1, GRDHGH(GDST,0) + IF ( GRDHGH(GDST,0) .EQ. 0 ) THEN + ! If no remap, then no file + LGRDREAD(GDST,JJ) = .FALSE. + LGRDWRITE(GDST,JJ) = .FALSE. + ELSE + GSRC = GRDHGH(GDST,JJ) + INTERP_FILE1 = "rmp_src_to_dst_conserv_xxx_xxx.nc" + WRITE(CDST, "(I3.3)") GDST + WRITE(CSRC, "(I3.3)") GSRC + INTERP_FILE1(24:26) = CSRC + INTERP_FILE1(28:30) = CDST + INQUIRE(FILE=INTERP_FILE1, EXIST=L_READ) + ! At this point, file either exists already (L_READ = .TRUE.) or needs to be written + LGRDREAD(GDST,JJ) = L_READ + LGRDWRITE(GDST,JJ) = .NOT. L_READ + END IF END DO + END DO #endif #ifdef W3_MPI - IF (LSCRIPNC) CALL MPI_BARRIER(MPI_COMM_MWAVE, IERR_MPI) + IF (LSCRIPNC) CALL MPI_BARRIER(MPI_COMM_MWAVE, IERR_MPI) #endif - LOWRANK_GRID : DO GDST=1, NRGRD + LOWRANK_GRID : DO GDST=1, NRGRD #ifdef W3_T38 - CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - BEG_TIME(2) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) - ELAPSED_TIME = BEG_TIME(2) - BEG_TIME(1) - WRITE(NMYOUT,*) "WMGHGH, LOOP LOWRANK_GRID, GDST= ", GDST, " START: ", ELAPSED_TIME, " MSEC" + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(2) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = BEG_TIME(2) - BEG_TIME(1) + WRITE(NMYOUT,*) "WMGHGH, LOOP LOWRANK_GRID, GDST= ", GDST, " START: ", ELAPSED_TIME, " MSEC" #endif -! Test output + ! Test output #ifdef W3_T - WRITE (MDST,9020) GDST, GRDHGH(GDST,0) + WRITE (MDST,9020) GDST, GRDHGH(GDST,0) #endif #ifdef W3_SCRIP - IF ( IMPROC.EQ.NMPERR.AND.T38 )WRITE(MDST,*)'GDST = ',GDST,' OUT OF ',NRGRD + IF ( IMPROC.EQ.NMPERR.AND.T38 )WRITE(MDST,*)'GDST = ',GDST,' OUT OF ',NRGRD #endif -! - IF ( GRDHGH(GDST,0) .EQ. 0 ) THEN ! no grids of higher rank than this - ! one. + ! + IF ( GRDHGH(GDST,0) .EQ. 0 ) THEN ! no grids of higher rank than this + ! one. #ifdef W3_T - WRITE (MDST,9021) -#endif - ELSE ! processing required - -! -! 2.b Process grid -! 2.b.1 Preparations -! -!!HT: Grid I has higher rank grids covering it, we now set up MAPTST -!!HT: MAPTST shows from which gid the data is averages. -!!HT: INFLND inferred land points based on land in high-res grids. -!!HT: - CALL W3SETO ( GDST, MDSE, MDST ) - CALL W3SETG ( GDST, MDSE, MDST ) - CALL WMSETM ( GDST, MDSE, MDST ) - -! W3SETG set ICLOSE for us, and we have determined that there is -! interaction between high and low rank. So this is a good point -! to check the closure type. - - IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN - IF ( IMPROC.EQ.NMPERR ) & - WRITE(MDSE,*)'SUBROUTINE WMGHGH IS'// & - ' NOT YET ADAPTED FOR TRIPOLE GRIDS. STOPPING NOW.' - CALL EXTCDE ( 1 ) - END IF - - ALLOCATE ( MAPTST(NY,NX), INFLND(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - MAPTST = 0 - INFLND = 0 - -!################################################################ -! Start new block of code: Calculate weights by calling SCRIP interface -!################################################################ - -! Notes on grid variables: -! GRIDS(GSRC)%{grid variable} (src grid, high rank, high resolution grid) -! GRIDS(GDST)%{grid variable} (dst grid, low rank, low resolution grid) - -! At this point, we are working on a particular low rank (dst) grid. -! We will save our weight information in the structure "ALLWGTS". -! For this dst grid, it is possible to have many src grids. That is -! why we store it this way. -! First, we ALLOCATE ALLWGTS from 1 up to the largest value of all -! the possible source grids. This will be referenced as "GSRC" -! Not every value of GSRC will be filled (e.g. "1" usually isn't filled) -! but since we are doing this as a derived data type, we are still -! efficient in terms of memory usage. -! Inside SCRIP interface, we have: -! type weight_data -! integer (kind=int_kind) :: n ! number of weights for -! dst cell, formerly npnts(:) -! real (kind=dbl_kind), allocatable :: w(:) ! weights, sized by n, -! formerly wxwy(:,:) -! integer (kind=int_kind), allocatable :: k(:) ! source grid cells, -! sized by n, formerly KSRC(:,:) -! end type weight_data -! .... -! type(weight_data), allocatable :: WGTDATA(:) -! .... -! ALLOCATE ( WGTDATA(grid2_size), STAT=ISTAT ) ! grid2=destination grid -! CHECK_ALLOC_STATUS ( ISTAT ) + WRITE (MDST,9021) +#endif + ELSE ! processing required + + ! + ! 2.b Process grid + ! 2.b.1 Preparations + ! + !!HT: Grid I has higher rank grids covering it, we now set up MAPTST + !!HT: MAPTST shows from which gid the data is averages. + !!HT: INFLND inferred land points based on land in high-res grids. + !!HT: + CALL W3SETO ( GDST, MDSE, MDST ) + CALL W3SETG ( GDST, MDSE, MDST ) + CALL WMSETM ( GDST, MDSE, MDST ) + + ! W3SETG set ICLOSE for us, and we have determined that there is + ! interaction between high and low rank. So this is a good point + ! to check the closure type. + + IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN + IF ( IMPROC.EQ.NMPERR ) & + WRITE(MDSE,*)'SUBROUTINE WMGHGH IS'// & + ' NOT YET ADAPTED FOR TRIPOLE GRIDS. STOPPING NOW.' + CALL EXTCDE ( 1 ) + END IF + + ALLOCATE ( MAPTST(NY,NX), INFLND(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + MAPTST = 0 + INFLND = 0 + + !################################################################ + ! Start new block of code: Calculate weights by calling SCRIP interface + !################################################################ + + ! Notes on grid variables: + ! GRIDS(GSRC)%{grid variable} (src grid, high rank, high resolution grid) + ! GRIDS(GDST)%{grid variable} (dst grid, low rank, low resolution grid) + + ! At this point, we are working on a particular low rank (dst) grid. + ! We will save our weight information in the structure "ALLWGTS". + ! For this dst grid, it is possible to have many src grids. That is + ! why we store it this way. + ! First, we ALLOCATE ALLWGTS from 1 up to the largest value of all + ! the possible source grids. This will be referenced as "GSRC" + ! Not every value of GSRC will be filled (e.g. "1" usually isn't filled) + ! but since we are doing this as a derived data type, we are still + ! efficient in terms of memory usage. + ! Inside SCRIP interface, we have: + ! type weight_data + ! integer (kind=int_kind) :: n ! number of weights for + ! dst cell, formerly npnts(:) + ! real (kind=dbl_kind), allocatable :: w(:) ! weights, sized by n, + ! formerly wxwy(:,:) + ! integer (kind=int_kind), allocatable :: k(:) ! source grid cells, + ! sized by n, formerly KSRC(:,:) + ! end type weight_data + ! .... + ! type(weight_data), allocatable :: WGTDATA(:) + ! .... + ! ALLOCATE ( WGTDATA(grid2_size), STAT=ISTAT ) ! grid2=destination grid + ! CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_SCRIP - NJDST=NY - NIDST=NX - ALLOCATE ( ALLWGTS(MAXVAL(GRDHGH)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + NJDST=NY + NIDST=NX + ALLOCATE ( ALLWGTS(MAXVAL(GRDHGH)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -! Next, we loop through the src grids for the dst grid that we are working on. + ! Next, we loop through the src grids for the dst grid that we are working on. #ifdef W3_SCRIP - DO JJ=1, GRDHGH(GDST,0) + DO JJ=1, GRDHGH(GDST,0) #endif #ifdef W3_T38 - CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - BEG_TIME(3) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) - ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) - WRITE(NMYOUT,*) "WMGHGH, LOOP JJ= ", JJ, " START: ", ELAPSED_TIME, " MSEC" + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(3) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) + WRITE(NMYOUT,*) "WMGHGH, LOOP JJ= ", JJ, " START: ", ELAPSED_TIME, " MSEC" #endif #ifdef W3_SCRIP - GSRC = GRDHGH(GDST,JJ) - NISRC=GRIDS(GSRC)%NX - NJSRC=GRIDS(GSRC)%NY ! only needed for diagnostics -#endif - -! Next, we call SCRIP for this src grid. -! Conditions for calling SCRIP are: -! 1) Not using L_STOP: in this case, all processes need all the weight -! information, so all processes need to call SCRIP for all grid pairs -! OR -! 2) Using L_STOP, writing .nc files and not reading .nc files. With -! L_STOP, different processors are doing different things, and so -! have different settings for L_WRITE. L_READ is the same for all -! processors, since it is simply based on whether the file already -! exists. + GSRC = GRDHGH(GDST,JJ) + NISRC=GRIDS(GSRC)%NX + NJSRC=GRIDS(GSRC)%NY ! only needed for diagnostics +#endif + + ! Next, we call SCRIP for this src grid. + ! Conditions for calling SCRIP are: + ! 1) Not using L_STOP: in this case, all processes need all the weight + ! information, so all processes need to call SCRIP for all grid pairs + ! OR + ! 2) Using L_STOP, writing .nc files and not reading .nc files. With + ! L_STOP, different processors are doing different things, and so + ! have different settings for L_WRITE. L_READ is the same for all + ! processors, since it is simply based on whether the file already + ! exists. #ifdef W3_SCRIPNC - INTERP_FILE1 = "rmp_src_to_dst_conserv_xxx_xxx.nc" - WRITE(CDST, "(I3.3)") GDST - WRITE(CSRC, "(I3.3)") GSRC - INTERP_FILE1(24:26) = CSRC - INTERP_FILE1(28:30) = CDST - L_READ = LGRDREAD(GDST, JJ) + INTERP_FILE1 = "rmp_src_to_dst_conserv_xxx_xxx.nc" + WRITE(CDST, "(I3.3)") GDST + WRITE(CSRC, "(I3.3)") GSRC + INTERP_FILE1(24:26) = CSRC + INTERP_FILE1(28:30) = CDST + L_READ = LGRDREAD(GDST, JJ) #endif #ifdef W3_T38 - CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - BEG_TIME(4) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) - ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) - WRITE(NMYOUT,*) "WMGHGH, SCRIP WRAPPER START: ", ELAPSED_TIME, " MSEC" + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(4) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) + WRITE(NMYOUT,*) "WMGHGH, SCRIP WRAPPER START: ", ELAPSED_TIME, " MSEC" #endif #ifdef W3_SCRIPNC - IF (L_STOP) L_WRITE = (IMPROC .EQ. IMPROC_ASSIGN) + IF (L_STOP) L_WRITE = (IMPROC .EQ. IMPROC_ASSIGN) #endif #ifdef W3_SCRIPNC - IF(L_STOP.AND.L_READ)THEN - IF ( IMPROC.EQ.NMPERR ) & - WRITE(MDSE,'(A)')'ERROR: You should either have SCRIP_STOP '// & - 'or remapping (.nc) files. Not both. We will exit now.' - CALL EXTCDE (505) - ENDIF + IF(L_STOP.AND.L_READ)THEN + IF ( IMPROC.EQ.NMPERR ) & + WRITE(MDSE,'(A)')'ERROR: You should either have SCRIP_STOP '// & + 'or remapping (.nc) files. Not both. We will exit now.' + CALL EXTCDE (505) + ENDIF #endif #ifdef W3_SCRIP - CALLED_SCRIP=.FALSE. ! initialize + CALLED_SCRIP=.FALSE. ! initialize #endif #ifdef W3_SCRIPNC - IF ((.NOT. L_STOP) .OR. ((.NOT. L_READ) .AND. L_WRITE)) THEN + IF ((.NOT. L_STOP) .OR. ((.NOT. L_READ) .AND. L_WRITE)) THEN #endif #ifdef W3_SCRIP - IF (L_STOP) THEN ! we are sending different grids to different processors - WRITE(MDSE,'(A,2(I5),A,I5)')'Calling SCRIP for GSRC,GDST = ', & - GSRC,GDST,' on processor ',IMPROC - ELSEIF(IMPROC.EQ.NMPERR)THEN - WRITE(MDSE,'(A,2(I5))')'Calling SCRIP interface for GSRC,GDST = ', & - GSRC,GDST - ENDIF - CALL scrip_wrapper (GSRC, GDST, & - GRIDS(GSRC)%MAPSTA,GRIDS(GSRC)%MAPST2,FLAGLL, & - GRIDS(GSRC)%GRIDSHIFT,L_WRITE,L_READ,T38) - CALLED_SCRIP=.TRUE. + IF (L_STOP) THEN ! we are sending different grids to different processors + WRITE(MDSE,'(A,2(I5),A,I5)')'Calling SCRIP for GSRC,GDST = ', & + GSRC,GDST,' on processor ',IMPROC + ELSEIF(IMPROC.EQ.NMPERR)THEN + WRITE(MDSE,'(A,2(I5))')'Calling SCRIP interface for GSRC,GDST = ', & + GSRC,GDST + ENDIF + CALL scrip_wrapper (GSRC, GDST, & + GRIDS(GSRC)%MAPSTA,GRIDS(GSRC)%MAPST2,FLAGLL, & + GRIDS(GSRC)%GRIDSHIFT,L_WRITE,L_READ,T38) + CALLED_SCRIP=.TRUE. #endif #ifdef W3_SCRIPNC - END IF + END IF #endif #ifdef W3_SCRIP - CALL FLUSH(MDSE) + CALL FLUSH(MDSE) #endif #ifdef W3_SCRIPNC - IF (L_STOP) THEN - IF (.NOT. L_READ) THEN - IMPROC_ASSIGN = IMPROC_ASSIGN + 1 - IF (IMPROC_ASSIGN .GT. NMPROC) IMPROC_ASSIGN = 1 - IF(CALLED_SCRIP)THEN ! we called scrip_wrapper, so we need - ! to deallocate before leaving - DST_GRID_SIZE=NIDST*NJDST - DO KDST=1,DST_GRID_SIZE - DEALLOCATE(WGTDATA(KDST)%W, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(WGTDATA(KDST)%K, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END DO - DEALLOCATE(WGTDATA, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END IF - CYCLE ! cycle out of this loop : DO JJ=1, GRDHGH(GDST,0) - END IF - END IF -#endif + IF (L_STOP) THEN + IF (.NOT. L_READ) THEN + IMPROC_ASSIGN = IMPROC_ASSIGN + 1 + IF (IMPROC_ASSIGN .GT. NMPROC) IMPROC_ASSIGN = 1 + IF(CALLED_SCRIP)THEN ! we called scrip_wrapper, so we need + ! to deallocate before leaving + DST_GRID_SIZE=NIDST*NJDST + DO KDST=1,DST_GRID_SIZE + DEALLOCATE(WGTDATA(KDST)%W, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(WGTDATA(KDST)%K, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END DO + DEALLOCATE(WGTDATA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + CYCLE ! cycle out of this loop : DO JJ=1, GRDHGH(GDST,0) + END IF + END IF +#endif #ifdef W3_T38 - CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) - ELAPSED_TIME = END_TIME - BEG_TIME(4) - WRITE(NMYOUT,*) "WMGHGH, SCRIP WRAPPER, GSRC= ", GSRC, " TOOK ", ELAPSED_TIME, " MSEC" + CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = END_TIME - BEG_TIME(4) + WRITE(NMYOUT,*) "WMGHGH, SCRIP WRAPPER, GSRC= ", GSRC, " TOOK ", ELAPSED_TIME, " MSEC" #endif #ifdef W3_SCRIP - IF(.NOT.CALLED_SCRIP)THEN ! we should not be here, since we need - ! WGTDATA(KDST)%N which is created by SCRIP - IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,'(A)')'ERROR: we '// & - 'should have cycled out by now. We will exit now.' - CALL EXTCDE (506) - ENDIF + IF(.NOT.CALLED_SCRIP)THEN ! we should not be here, since we need + ! WGTDATA(KDST)%N which is created by SCRIP + IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,'(A)')'ERROR: we '// & + 'should have cycled out by now. We will exit now.' + CALL EXTCDE (506) + ENDIF #endif -! SCRIP has now created the data strucure "WGTDATA" and stored the weights -! in it. However, this is only for the present src grid. We want to store the -! data for all the src grids. Thus, we use a new data structure of type -! "ALLWGT" to store this data. First though, we need to ALLOCATE it: -! (note: "k" is equivalent to isea, but includes *all* points) + ! SCRIP has now created the data strucure "WGTDATA" and stored the weights + ! in it. However, this is only for the present src grid. We want to store the + ! data for all the src grids. Thus, we use a new data structure of type + ! "ALLWGT" to store this data. First though, we need to ALLOCATE it: + ! (note: "k" is equivalent to isea, but includes *all* points) #ifdef W3_SCRIP - DST_GRID_SIZE=NIDST*NJDST - ALLOCATE(ALLWGTS(GSRC)%WGTDATA(DST_GRID_SIZE),STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - DO KDST=1,DST_GRID_SIZE - ALLOCATE(ALLWGTS(GSRC)%WGTDATA(KDST) & - %W(WGTDATA(KDST)%N),STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(ALLWGTS(GSRC)%WGTDATA(KDST) & - %K(WGTDATA(KDST)%N),STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - END DO + DST_GRID_SIZE=NIDST*NJDST + ALLOCATE(ALLWGTS(GSRC)%WGTDATA(DST_GRID_SIZE),STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + DO KDST=1,DST_GRID_SIZE + ALLOCATE(ALLWGTS(GSRC)%WGTDATA(KDST) & + %W(WGTDATA(KDST)%N),STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(ALLWGTS(GSRC)%WGTDATA(KDST) & + %K(WGTDATA(KDST)%N),STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + END DO #endif -! Now that we have it allocated, we can just copy WGTDATA into ALLWGTS + ! Now that we have it allocated, we can just copy WGTDATA into ALLWGTS -! Notes re: short and long way to do this: -! pgf90 on IBM Opteron, gfortran, g95, xlf, all tested ok with "short method" -! pgf90 on our linux workstations (Intel) requires the "long method" -! (possible compiler bug) -! ALLWGTS(GSRC)%WGTDATA = WGTDATA !short method + ! Notes re: short and long way to do this: + ! pgf90 on IBM Opteron, gfortran, g95, xlf, all tested ok with "short method" + ! pgf90 on our linux workstations (Intel) requires the "long method" + ! (possible compiler bug) + ! ALLWGTS(GSRC)%WGTDATA = WGTDATA !short method -! BEGIN long method for filling derived data type "ALLWGTS" + ! BEGIN long method for filling derived data type "ALLWGTS" #ifdef W3_SCRIP - DO KDST=1,DST_GRID_SIZE - ALLWGTS(GSRC)%WGTDATA(KDST)%N=WGTDATA(KDST)%N - ALLWGTS(GSRC)%WGTDATA(KDST)%NR0=WGTDATA(KDST)%NR0 - ALLWGTS(GSRC)%WGTDATA(KDST)%NR2=WGTDATA(KDST)%NR2 - ALLWGTS(GSRC)%WGTDATA(KDST)%NRL=WGTDATA(KDST)%NRL - DO IPNT=1,WGTDATA(KDST)%N - ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) & - =WGTDATA(KDST)%W(IPNT) - ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) & - =WGTDATA(KDST)%K(IPNT) - END DO - END DO + DO KDST=1,DST_GRID_SIZE + ALLWGTS(GSRC)%WGTDATA(KDST)%N=WGTDATA(KDST)%N + ALLWGTS(GSRC)%WGTDATA(KDST)%NR0=WGTDATA(KDST)%NR0 + ALLWGTS(GSRC)%WGTDATA(KDST)%NR2=WGTDATA(KDST)%NR2 + ALLWGTS(GSRC)%WGTDATA(KDST)%NRL=WGTDATA(KDST)%NRL + DO IPNT=1,WGTDATA(KDST)%N + ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) & + =WGTDATA(KDST)%W(IPNT) + ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) & + =WGTDATA(KDST)%K(IPNT) + END DO + END DO #endif -! END long method for filling derived data type "ALLWGTS" + ! END long method for filling derived data type "ALLWGTS" -! We're done with WGTDATA, so we can DEALLOCATE it. This is important, -! since it will be allocated again the next time SCRIP is called. + ! We're done with WGTDATA, so we can DEALLOCATE it. This is important, + ! since it will be allocated again the next time SCRIP is called. #ifdef W3_SCRIP - DO KDST=1,DST_GRID_SIZE - DEALLOCATE(WGTDATA(KDST)%W, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(WGTDATA(KDST)%K, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END DO - DEALLOCATE(WGTDATA, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + DO KDST=1,DST_GRID_SIZE + DEALLOCATE(WGTDATA(KDST)%W, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(WGTDATA(KDST)%K, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END DO + DEALLOCATE(WGTDATA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) #endif -! Here's a "test output" block of code to demonstrate how the weights can -! be called up from ALLWGTS...and to verify that the data is stored properly. -! (again note that "k" is equivalent to isea, but includes *all* points) + ! Here's a "test output" block of code to demonstrate how the weights can + ! be called up from ALLWGTS...and to verify that the data is stored properly. + ! (again note that "k" is equivalent to isea, but includes *all* points) #ifdef W3_SCRIP - IF(T38)THEN - WRITE(MDST,'(/2A)')' XDST YDST ', & - ' XSRC YSRC WXWY' - DO JDST=1,NJDST - DO IDST=1,NIDST - KDST=(JDST-1)*NIDST+IDST - XDST=REAL(GRIDS(GDST)%XGRD(JDST,IDST)) - YDST=REAL(GRIDS(GDST)%YGRD(JDST,IDST)) - DO IPNT=1,ALLWGTS(GSRC)%WGTDATA(KDST)%N - KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) - JSRC=INT((KSRC-1)/NISRC)+1 - ISRC=KSRC-(JSRC-1)*NISRC - XSRC=REAL(GRIDS(GSRC)%XGRD(JSRC,ISRC)) - YSRC=REAL(GRIDS(GSRC)%YGRD(JSRC,ISRC)) - WXWY=ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) - WRITE(MDST,'(5(1X,F12.5))')XDST,YDST,XSRC, & - YSRC,WXWY - END DO - END DO - END DO ! DO JDST=1,NJDST - ENDIF ! IF(T38)THEN + IF(T38)THEN + WRITE(MDST,'(/2A)')' XDST YDST ', & + ' XSRC YSRC WXWY' + DO JDST=1,NJDST + DO IDST=1,NIDST + KDST=(JDST-1)*NIDST+IDST + XDST=REAL(GRIDS(GDST)%XGRD(JDST,IDST)) + YDST=REAL(GRIDS(GDST)%YGRD(JDST,IDST)) + DO IPNT=1,ALLWGTS(GSRC)%WGTDATA(KDST)%N + KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) + JSRC=INT((KSRC-1)/NISRC)+1 + ISRC=KSRC-(JSRC-1)*NISRC + XSRC=REAL(GRIDS(GSRC)%XGRD(JSRC,ISRC)) + YSRC=REAL(GRIDS(GSRC)%YGRD(JSRC,ISRC)) + WXWY=ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) + WRITE(MDST,'(5(1X,F12.5))')XDST,YDST,XSRC, & + YSRC,WXWY + END DO + END DO + END DO ! DO JDST=1,NJDST + ENDIF ! IF(T38)THEN #endif #ifdef W3_T38 - CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) - ELAPSED_TIME = END_TIME - BEG_TIME(3) - WRITE(NMYOUT,*) "WMGHGH, LOOP JJ, GSRC= ", GSRC, " TOOK ", ELAPSED_TIME, " MSEC" + CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = END_TIME - BEG_TIME(3) + WRITE(NMYOUT,*) "WMGHGH, LOOP JJ, GSRC= ", GSRC, " TOOK ", ELAPSED_TIME, " MSEC" #endif #ifdef W3_SCRIP - END DO ! DO JJ=1, GRDHGH(GDST,0) - GSRC = -999 ! unset grid + END DO ! DO JJ=1, GRDHGH(GDST,0) + GSRC = -999 ! unset grid #endif -! If SCRIPNC and L_STOP, then cycle LOWRANK_GRID loop and deallocate -! storage associated with dst grid. + ! If SCRIPNC and L_STOP, then cycle LOWRANK_GRID loop and deallocate + ! storage associated with dst grid. #ifdef W3_SCRIPNC - IF (L_STOP) THEN - IF ( ALLOCATED(MAPTST) ) THEN - DEALLOCATE ( MAPTST, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END IF - IF ( ALLOCATED(INFLND) ) THEN - DEALLOCATE ( INFLND, STAT=ISTAT ) + IF (L_STOP) THEN + IF ( ALLOCATED(MAPTST) ) THEN + DEALLOCATE ( MAPTST, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + IF ( ALLOCATED(INFLND) ) THEN + DEALLOCATE ( INFLND, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + IF ( ALLOCATED(ALLWGTS) ) THEN + DO JJ=1, GRDHGH(GDST,0) + GSRC = GRDHGH(GDST,JJ) + IF ( ASSOCIATED(ALLWGTS(GSRC)%WGTDATA) ) THEN + DO KDST=1, DST_GRID_SIZE + + !######################################################################################### + !menta: for some reason gfortran complains that these lines are too long. Unindenting them + IF ( ALLOCATED(ALLWGTS(GSRC)%WGTDATA(KDST)%W) ) THEN + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%W, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) END IF - IF ( ALLOCATED(ALLWGTS) ) THEN - DO JJ=1, GRDHGH(GDST,0) - GSRC = GRDHGH(GDST,JJ) - IF ( ASSOCIATED(ALLWGTS(GSRC)%WGTDATA) ) THEN - DO KDST=1, DST_GRID_SIZE - - !######################################################################################### - !menta: for some reason gfortran complains that these lines are too long. Unindenting them - IF ( ALLOCATED(ALLWGTS(GSRC)%WGTDATA(KDST)%W) ) THEN - DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%W, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END IF - IF ( ALLOCATED(ALLWGTS(GSRC)%WGTDATA(KDST)%K) ) THEN - DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%K, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END IF - !######################################################################################### - END DO - DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - NULLIFY ( ALLWGTS(GSRC)%WGTDATA ) - END IF - END DO - DEALLOCATE ( ALLWGTS, STAT=ISTAT ) + IF ( ALLOCATED(ALLWGTS(GSRC)%WGTDATA(KDST)%K) ) THEN + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%K, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) END IF - CYCLE LOWRANK_GRID + !######################################################################################### + END DO + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + NULLIFY ( ALLWGTS(GSRC)%WGTDATA ) END IF + END DO + DEALLOCATE ( ALLWGTS, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + CYCLE LOWRANK_GRID + END IF #endif -!################################################################ -! End new block of code: Calculate weights by calling SCRIP interface -!################################################################ - -! 2.b.2 Find points used for boundary data in higher ranked grids -! -!!HT: These points are marked in MAPTST as negative values to assure -!!HT: that the grid poits used for boundary data are not getting -!!HT: averaged values from high-reswolution grids as that will result -!!HT: in cyclic, possibly non-conservative updating. -!!HT: -!!HT: NBI2S has all necessary data set in WMGLOW as called before WMGHGH. -!!HT: -!!HT: JJ loop goes over grids that reviously have been identified as -!!HT: getting data from the grid presently cousidered. -! -! notes: The purpose of this is to identify points -! that should not be used in the averaging procedure. It is -! related to statement in Tolman (OM, 2008): "Second, Eq (7) is not -! applied to grid points in the low resolution grid that contribute -! to boundary data for the high resolution grid. This avoids cyclic -! updating of data between grids. - -! notes: GRDHGH(GDST,0) is number of grids of higher rank than the present -! grid (GDST) -! GRDHGH(GDST,1...etc.) is the grid number - -! notes: Setting MAPTST=negative here is probably overkill, since it means -! we will not have weights for this point. However, to change this, -! we would need a new variable to use in its place, since we need -! to mark the point for use in STMASK determination. - - DO JJ=1, GRDHGH(GDST,0) - GSRC = GRDHGH(GDST,JJ) - DO IB=1, SIZE(MDATAS(GSRC)%NBI2S(:,1)) - IF ( MDATAS(GSRC)%NBI2S(IB,1) .EQ. GDST ) THEN - IDST = MAPSF(MDATAS(GSRC)%NBI2S(IB,2),1) - JDST = MAPSF(MDATAS(GSRC)%NBI2S(IB,2),2) - MAPTST(JDST,IDST) = - GSRC - END IF - END DO - END DO - GSRC = -999 ! unset grid -! -! 2.b.3 Range of coverage per grid - -!!HT: -!!HT: In this JJ loop, we go over all higher resolution grids to find -!!HT: ranges that can be averaged to replace data in the 'I' (GDST) grid.! -!!HT: - - ALLOCATE ( IDSTL(GRDHGH(GDST,0)), IDSTH(GRDHGH(GDST,0)), & - JDSTL(GRDHGH(GDST,0)), JDSTH(GRDHGH(GDST,0)), & - GRIDOK(GRDHGH(GDST,0)),BDIST(GRDHGH(GDST,0)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + !################################################################ + ! End new block of code: Calculate weights by calling SCRIP interface + !################################################################ + + ! 2.b.2 Find points used for boundary data in higher ranked grids + ! + !!HT: These points are marked in MAPTST as negative values to assure + !!HT: that the grid poits used for boundary data are not getting + !!HT: averaged values from high-reswolution grids as that will result + !!HT: in cyclic, possibly non-conservative updating. + !!HT: + !!HT: NBI2S has all necessary data set in WMGLOW as called before WMGHGH. + !!HT: + !!HT: JJ loop goes over grids that reviously have been identified as + !!HT: getting data from the grid presently cousidered. + ! + ! notes: The purpose of this is to identify points + ! that should not be used in the averaging procedure. It is + ! related to statement in Tolman (OM, 2008): "Second, Eq (7) is not + ! applied to grid points in the low resolution grid that contribute + ! to boundary data for the high resolution grid. This avoids cyclic + ! updating of data between grids. + + ! notes: GRDHGH(GDST,0) is number of grids of higher rank than the present + ! grid (GDST) + ! GRDHGH(GDST,1...etc.) is the grid number + + ! notes: Setting MAPTST=negative here is probably overkill, since it means + ! we will not have weights for this point. However, to change this, + ! we would need a new variable to use in its place, since we need + ! to mark the point for use in STMASK determination. + + DO JJ=1, GRDHGH(GDST,0) + GSRC = GRDHGH(GDST,JJ) + DO IB=1, SIZE(MDATAS(GSRC)%NBI2S(:,1)) + IF ( MDATAS(GSRC)%NBI2S(IB,1) .EQ. GDST ) THEN + IDST = MAPSF(MDATAS(GSRC)%NBI2S(IB,2),1) + JDST = MAPSF(MDATAS(GSRC)%NBI2S(IB,2),2) + MAPTST(JDST,IDST) = - GSRC + END IF + END DO + END DO + GSRC = -999 ! unset grid + ! + ! 2.b.3 Range of coverage per grid + + !!HT: + !!HT: In this JJ loop, we go over all higher resolution grids to find + !!HT: ranges that can be averaged to replace data in the 'I' (GDST) grid.! + !!HT: + + ALLOCATE ( IDSTL(GRDHGH(GDST,0)), IDSTH(GRDHGH(GDST,0)), & + JDSTL(GRDHGH(GDST,0)), JDSTH(GRDHGH(GDST,0)), & + GRIDOK(GRDHGH(GDST,0)),BDIST(GRDHGH(GDST,0)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) - IF (OLD_METHOD) THEN - ALLOCATE (BDIST_OM(GRDHGH(GDST,0)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF + IF (OLD_METHOD) THEN + ALLOCATE (BDIST_OM(GRDHGH(GDST,0)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF -! -! Notes: For case of lower ranked grid GDST being irregular, grid indices -! i and j do not correspond to x and y, so optimization -! by limiting search in manner of pre-curvilinear versions of -! WW3 is not appropriate. -! - IF ( (GTYPE .EQ. CLGTYPE).or.(GTYPE .EQ. UNGTYPE) ) THEN + ! + ! Notes: For case of lower ranked grid GDST being irregular, grid indices + ! i and j do not correspond to x and y, so optimization + ! by limiting search in manner of pre-curvilinear versions of + ! WW3 is not appropriate. + ! + IF ( (GTYPE .EQ. CLGTYPE).or.(GTYPE .EQ. UNGTYPE) ) THEN - IDSTLA = 1 - IDSTHA = NX - JDSTLA = 1 - JDSTHA = NY + IDSTLA = 1 + IDSTHA = NX + JDSTLA = 1 + JDSTHA = NY - ELSE + ELSE -! loop through higher ranked grids GSRC - - DO JJ=1, GRDHGH(GDST,0) - GSRC = GRDHGH(GDST,JJ) -!!HT: -!!HT: XL,XH, and YL,YH and the low and high (X,Y) values of the grid box -!!HT: in the grid 'I' fro which the high-res data needs to be averaged. -!!HT: To be efficient, we compute a range of high-res grid point that -!!HT: could be considered, rather than looking through the whole grid. -!!HT: This will work only for the old grids, not for the newer curvilinear -!!HT: and unstructured grids. -!!HT: -!!HT: This sets the range in the low-res grid to consider. -! -! Notes (HLT): outer edges already taken off here ... -! will not work in a simple way for spherical grids, -! so we don't even try .... -! -! Notes: SX and SY are only used in cases where GTYPE .NE. CLGTYPE, -! i.e. regular grids. In case of regular grids, SX and SY -! can be replaced with HPFAC HQFAC, if desired. -! -! find upper and lower bounds of higher ranks grids - - IF ( (GRIDS(GSRC)%GTYPE .EQ. CLGTYPE) .OR. & - (GRIDS(GSRC)%GTYPE .EQ. UNGTYPE) ) THEN - -! Notes: in case of irregular grids, there is no obvious way to -! offset by dx/2 dy/2, so we omit that sliver (thus we increase -! search area slightly). - - XL=REAL(MINVAL(GRIDS(GSRC)%XGRD)) - YL=REAL(MINVAL(GRIDS(GSRC)%YGRD)) - XH=REAL(MAXVAL(GRIDS(GSRC)%XGRD)) - YH=REAL(MAXVAL(GRIDS(GSRC)%YGRD)) + ! loop through higher ranked grids GSRC + + DO JJ=1, GRDHGH(GDST,0) + GSRC = GRDHGH(GDST,JJ) + !!HT: + !!HT: XL,XH, and YL,YH and the low and high (X,Y) values of the grid box + !!HT: in the grid 'I' fro which the high-res data needs to be averaged. + !!HT: To be efficient, we compute a range of high-res grid point that + !!HT: could be considered, rather than looking through the whole grid. + !!HT: This will work only for the old grids, not for the newer curvilinear + !!HT: and unstructured grids. + !!HT: + !!HT: This sets the range in the low-res grid to consider. + ! + ! Notes (HLT): outer edges already taken off here ... + ! will not work in a simple way for spherical grids, + ! so we don't even try .... + ! + ! Notes: SX and SY are only used in cases where GTYPE .NE. CLGTYPE, + ! i.e. regular grids. In case of regular grids, SX and SY + ! can be replaced with HPFAC HQFAC, if desired. + ! + ! find upper and lower bounds of higher ranks grids + + IF ( (GRIDS(GSRC)%GTYPE .EQ. CLGTYPE) .OR. & + (GRIDS(GSRC)%GTYPE .EQ. UNGTYPE) ) THEN + + ! Notes: in case of irregular grids, there is no obvious way to + ! offset by dx/2 dy/2, so we omit that sliver (thus we increase + ! search area slightly). + + XL=REAL(MINVAL(GRIDS(GSRC)%XGRD)) + YL=REAL(MINVAL(GRIDS(GSRC)%YGRD)) + XH=REAL(MAXVAL(GRIDS(GSRC)%XGRD)) + YH=REAL(MAXVAL(GRIDS(GSRC)%YGRD)) - ELSE + ELSE - XL = GRIDS(GSRC)%X0 + 0.5 * GRIDS(GSRC)%SX - XH = GRIDS(GSRC)%X0 + ( REAL(GRIDS(GSRC)%NX) - 1.5 ) & - * GRIDS(GSRC)%SX - YL = GRIDS(GSRC)%Y0 + 0.5 * GRIDS(GSRC)%SY - YH = GRIDS(GSRC)%Y0 + ( REAL(GRIDS(GSRC)%NY) - 1.5 ) & - * GRIDS(GSRC)%SY + XL = GRIDS(GSRC)%X0 + 0.5 * GRIDS(GSRC)%SX + XH = GRIDS(GSRC)%X0 + ( REAL(GRIDS(GSRC)%NX) - 1.5 ) & + * GRIDS(GSRC)%SX + YL = GRIDS(GSRC)%Y0 + 0.5 * GRIDS(GSRC)%SY + YH = GRIDS(GSRC)%Y0 + ( REAL(GRIDS(GSRC)%NY) - 1.5 ) & + * GRIDS(GSRC)%SY - ENDIF ! IF ( GRIDS(GSRC)%GTYPE .EQ. CLGTYPE ) + ENDIF ! IF ( GRIDS(GSRC)%GTYPE .EQ. CLGTYPE ) -! -! find where this falls in the current (low) ranked grid - - IF ( FLAGLL ) THEN - IDSTL(JJ) = 1 - IDSTH(JJ) = NX - ELSE + ! + ! find where this falls in the current (low) ranked grid + + IF ( FLAGLL ) THEN + IDSTL(JJ) = 1 + IDSTH(JJ) = NX + ELSE -! Notes: from check "IF ( GTYPE .EQ. CLGTYPE ) THEN" above, we know that -! GTYPE .NE CLGTYPE....so it is safe to use SX SY etc here + ! Notes: from check "IF ( GTYPE .EQ. CLGTYPE ) THEN" above, we know that + ! GTYPE .NE CLGTYPE....so it is safe to use SX SY etc here - IDSTL(JJ) = 2 + INT( (XL-X0)/SX + 0.49 ) - IDSTH(JJ) = 1 + INT( (XH-X0)/SX - 0.49 ) - END IF + IDSTL(JJ) = 2 + INT( (XL-X0)/SX + 0.49 ) + IDSTH(JJ) = 1 + INT( (XH-X0)/SX - 0.49 ) + END IF - JDSTL(JJ) = 2 + INT( (YL-Y0)/SY + 0.49 ) - JDSTH(JJ) = 1 + INT( (YH-Y0)/SY - 0.49 ) + JDSTL(JJ) = 2 + INT( (YL-Y0)/SY + 0.49 ) + JDSTH(JJ) = 1 + INT( (YH-Y0)/SY - 0.49 ) - IDSTL(JJ) = MAX ( 1 , IDSTL(JJ) ) - IDSTH(JJ) = MIN ( NX , IDSTH(JJ) ) - JDSTL(JJ) = MAX ( 1 , JDSTL(JJ) ) - JDSTH(JJ) = MIN ( NY , JDSTH(JJ) ) -! + IDSTL(JJ) = MAX ( 1 , IDSTL(JJ) ) + IDSTH(JJ) = MIN ( NX , IDSTH(JJ) ) + JDSTL(JJ) = MAX ( 1 , JDSTL(JJ) ) + JDSTH(JJ) = MIN ( NY , JDSTH(JJ) ) + ! #ifdef W3_T - WRITE (MDST,9022) GSRC, IDSTL(JJ),IDSTH(JJ), & - JDSTL(JJ),JDSTH(JJ) -#endif -! - END DO ! end loop through higher ranked grids - GSRC = -999 ! unset grid -! - -! save the extremities of that set of high-ranked grids - IDSTLA = MINVAL(IDSTL) - IDSTHA = MAXVAL(IDSTH) - JDSTLA = MINVAL(JDSTL) - JDSTHA = MAXVAL(JDSTH) - - ENDIF ! IF ( (GTYPE .EQ. CLGTYPE ) .or. (GTYPE .EQ. UNGTYPE)) - -! loop through higher ranked grids - -! -! 2.b.4 Point by point check -! -! Notes: We loop through all grids of higher rank -! GSRC=the grid number of the higher rank grid. -! NLMAX is used for dimensioning purposes. -! It is apparently using the ratio between the resolution -! of the low rank grid (GDST) and high rank grid (GSRC) -! Obviously, we cannot use this calculation for irregular grids. - - NLMAX = 0 + WRITE (MDST,9022) GSRC, IDSTL(JJ),IDSTH(JJ), & + JDSTL(JJ),JDSTH(JJ) +#endif + ! + END DO ! end loop through higher ranked grids + GSRC = -999 ! unset grid + ! + + ! save the extremities of that set of high-ranked grids + IDSTLA = MINVAL(IDSTL) + IDSTHA = MAXVAL(IDSTH) + JDSTLA = MINVAL(JDSTL) + JDSTHA = MAXVAL(JDSTH) + + ENDIF ! IF ( (GTYPE .EQ. CLGTYPE ) .or. (GTYPE .EQ. UNGTYPE)) + + ! loop through higher ranked grids + + ! + ! 2.b.4 Point by point check + ! + ! Notes: We loop through all grids of higher rank + ! GSRC=the grid number of the higher rank grid. + ! NLMAX is used for dimensioning purposes. + ! It is apparently using the ratio between the resolution + ! of the low rank grid (GDST) and high rank grid (GSRC) + ! Obviously, we cannot use this calculation for irregular grids. + + NLMAX = 0 #ifdef W3_SCRIP - NLMAX_SCRIP=0 -#endif - DO JJ=1, GRDHGH(GDST,0) - GSRC = GRDHGH(GDST,JJ) - -! Notes: NLMAX is used to dimension TMPINT,TMPRL, and to set ITAG and LTAG -! (MPI case). -! As we remove more of the older code, it may turn out that -! NLMAX is no longer needed, in which case we can remove this -! block of code. For example, the weights data structure is introduced -! to WW3 already dimensioned. - - IF ( GRIDS(GDST)%GTYPE .EQ. CLGTYPE ) THEN - DX_MAX_GDST=MAXVAL(GRIDS(GDST)%HPFAC) - DY_MAX_GDST=MAXVAL(GRIDS(GDST)%HQFAC) - ELSEIF ( GRIDS(GDST)%GTYPE .EQ. RLGTYPE ) THEN - DX_MAX_GDST=GRIDS(GDST)%SX - DY_MAX_GDST=GRIDS(GDST)%SY - ELSE - IsFirst=1 - DIST_MAX=0 - DIST_MIN=0 - DO ITRI=1,GRIDS(GDST)%NTRI - DO IT=1,3 - IF (IT.eq.3) THEN - JT=1 - ELSE - JT=IT+1 - END IF - IM1=GRIDS(GDST)%TRIGP(IT,ITRI) - IM2=GRIDS(GDST)%TRIGP(JT,ITRI) - eDist=W3DIST(FLAGLL, REAL(GRIDS(GDST)%XGRD(1,IM1)), & - REAL(GRIDS(GDST)%YGRD(1,IM1)), & - REAL(GRIDS(GDST)%XGRD(1,IM2)), REAL(GRIDS(GDST)%YGRD(1,IM2))) - IF (IsFirst.eq.1) THEN - DIST_MAX=eDist - DIST_MIN=eDist - IsFirst=0 - ELSE - IF (eDist.gt.DIST_MAX) THEN - DIST_MAX=eDist - END IF - IF (eDist.lt.DIST_MIN) THEN - DIST_MIN=eDist - END IF - END IF - END DO - END DO - DX_MAX_GDST=DIST_MAX - DY_MAX_GDST=DIST_MAX - END IF - - IF ( GRIDS(GSRC)%GTYPE .EQ. CLGTYPE ) THEN - DX_MIN_GSRC=MINVAL(GRIDS(GSRC)%HPFAC) - DY_MIN_GSRC=MINVAL(GRIDS(GSRC)%HQFAC) - ELSEIF ( GRIDS(GSRC)%GTYPE .EQ. RLGTYPE ) THEN - DX_MIN_GSRC=GRIDS(GSRC)%SX - DY_MIN_GSRC=GRIDS(GSRC)%SY - ELSE - IsFirst=1 - DIST_MAX=0 - DIST_MIN=0 - DO ITRI=1,GRIDS(GSRC)%NTRI - DO IT=1,3 - IF (IT.eq.3) THEN - JT=1 - ELSE - JT=IT+1 - END IF - IM1=GRIDS(GSRC)%TRIGP(IT,ITRI) - IM2=GRIDS(GSRC)%TRIGP(JT,ITRI) - eDist=W3DIST(FLAGLL, REAL(GRIDS(GSRC)%XGRD(1,IM1)), & - REAL(GRIDS(GSRC)%YGRD(1,IM1)), & - REAL(GRIDS(GSRC)%XGRD(1,IM2)), REAL(GRIDS(GSRC)%YGRD(1,IM2))) - IF (IsFirst.eq.1) THEN - DIST_MAX=eDist - DIST_MIN=eDist - IsFirst=0 - ELSE - IF (eDist.gt.DIST_MAX) THEN - DIST_MAX=eDist - END IF - IF (eDist.lt.DIST_MIN) THEN - DIST_MIN=eDist - END IF - END IF - END DO - END DO - DX_MIN_GSRC=DIST_MIN - DY_MIN_GSRC=DIST_MIN - END IF - -! notes: original code was much simpler: -! NLMAX = MAX ( NLMAX , (2+INT(SX/GRIDS(J)%SX+0.001)) * & -! (2+INT(SY/GRIDS(J)%SY+0.001)) ) - - NLMAX = MAX ( NLMAX , & - (2+INT(DX_MAX_GDST/DX_MIN_GSRC+0.001)) * & - (2+INT(DY_MAX_GDST/DY_MIN_GSRC+0.001)) ) + NLMAX_SCRIP=0 +#endif + DO JJ=1, GRDHGH(GDST,0) + GSRC = GRDHGH(GDST,JJ) + + ! Notes: NLMAX is used to dimension TMPINT,TMPRL, and to set ITAG and LTAG + ! (MPI case). + ! As we remove more of the older code, it may turn out that + ! NLMAX is no longer needed, in which case we can remove this + ! block of code. For example, the weights data structure is introduced + ! to WW3 already dimensioned. + + IF ( GRIDS(GDST)%GTYPE .EQ. CLGTYPE ) THEN + DX_MAX_GDST=MAXVAL(GRIDS(GDST)%HPFAC) + DY_MAX_GDST=MAXVAL(GRIDS(GDST)%HQFAC) + ELSEIF ( GRIDS(GDST)%GTYPE .EQ. RLGTYPE ) THEN + DX_MAX_GDST=GRIDS(GDST)%SX + DY_MAX_GDST=GRIDS(GDST)%SY + ELSE + IsFirst=1 + DIST_MAX=0 + DIST_MIN=0 + DO ITRI=1,GRIDS(GDST)%NTRI + DO IT=1,3 + IF (IT.eq.3) THEN + JT=1 + ELSE + JT=IT+1 + END IF + IM1=GRIDS(GDST)%TRIGP(IT,ITRI) + IM2=GRIDS(GDST)%TRIGP(JT,ITRI) + eDist=W3DIST(FLAGLL, REAL(GRIDS(GDST)%XGRD(1,IM1)), & + REAL(GRIDS(GDST)%YGRD(1,IM1)), & + REAL(GRIDS(GDST)%XGRD(1,IM2)), REAL(GRIDS(GDST)%YGRD(1,IM2))) + IF (IsFirst.eq.1) THEN + DIST_MAX=eDist + DIST_MIN=eDist + IsFirst=0 + ELSE + IF (eDist.gt.DIST_MAX) THEN + DIST_MAX=eDist + END IF + IF (eDist.lt.DIST_MIN) THEN + DIST_MIN=eDist + END IF + END IF + END DO + END DO + DX_MAX_GDST=DIST_MAX + DY_MAX_GDST=DIST_MAX + END IF + + IF ( GRIDS(GSRC)%GTYPE .EQ. CLGTYPE ) THEN + DX_MIN_GSRC=MINVAL(GRIDS(GSRC)%HPFAC) + DY_MIN_GSRC=MINVAL(GRIDS(GSRC)%HQFAC) + ELSEIF ( GRIDS(GSRC)%GTYPE .EQ. RLGTYPE ) THEN + DX_MIN_GSRC=GRIDS(GSRC)%SX + DY_MIN_GSRC=GRIDS(GSRC)%SY + ELSE + IsFirst=1 + DIST_MAX=0 + DIST_MIN=0 + DO ITRI=1,GRIDS(GSRC)%NTRI + DO IT=1,3 + IF (IT.eq.3) THEN + JT=1 + ELSE + JT=IT+1 + END IF + IM1=GRIDS(GSRC)%TRIGP(IT,ITRI) + IM2=GRIDS(GSRC)%TRIGP(JT,ITRI) + eDist=W3DIST(FLAGLL, REAL(GRIDS(GSRC)%XGRD(1,IM1)), & + REAL(GRIDS(GSRC)%YGRD(1,IM1)), & + REAL(GRIDS(GSRC)%XGRD(1,IM2)), REAL(GRIDS(GSRC)%YGRD(1,IM2))) + IF (IsFirst.eq.1) THEN + DIST_MAX=eDist + DIST_MIN=eDist + IsFirst=0 + ELSE + IF (eDist.gt.DIST_MAX) THEN + DIST_MAX=eDist + END IF + IF (eDist.lt.DIST_MIN) THEN + DIST_MIN=eDist + END IF + END IF + END DO + END DO + DX_MIN_GSRC=DIST_MIN + DY_MIN_GSRC=DIST_MIN + END IF + + ! notes: original code was much simpler: + ! NLMAX = MAX ( NLMAX , (2+INT(SX/GRIDS(J)%SX+0.001)) * & + ! (2+INT(SY/GRIDS(J)%SY+0.001)) ) + + NLMAX = MAX ( NLMAX , & + (2+INT(DX_MAX_GDST/DX_MIN_GSRC+0.001)) * & + (2+INT(DY_MAX_GDST/DY_MIN_GSRC+0.001)) ) #ifdef W3_T38 WRITE(MDST,*)'ratio 1 = ',(DX_MAX_GDST/DX_MIN_GSRC), & - DX_MAX_GDST,DX_MIN_GSRC - WRITE(MDST,*)'ratio 2 = ',(DY_MAX_GDST/DY_MIN_GSRC), & - DY_MAX_GDST,DY_MIN_GSRC + DX_MAX_GDST,DX_MIN_GSRC + WRITE(MDST,*)'ratio 2 = ',(DY_MAX_GDST/DY_MIN_GSRC), & + DY_MAX_GDST,DY_MIN_GSRC WRITE(MDSE,*)'GSRC, NLMAX = ',GSRC,NLMAX #endif #ifdef W3_SCRIP - DO JDST=1, NY - DO IDST=1, NX - KDST=(JDST-1)*NIDST+IDST - NLOC=ALLWGTS(GSRC)%WGTDATA(KDST)%N - NLMAX_SCRIP=MAX(NLMAX_SCRIP,NLOC) - END DO - END DO + DO JDST=1, NY + DO IDST=1, NX + KDST=(JDST-1)*NIDST+IDST + NLOC=ALLWGTS(GSRC)%WGTDATA(KDST)%N + NLMAX_SCRIP=MAX(NLMAX_SCRIP,NLOC) + END DO + END DO #endif - END DO ! DO JJ=1, GRDHGH(GDST,0) - GSRC=-999 ! unset grid - -! Notes regarding 3 possible scenarios: -! If only using SCRIP, then -! * set NLMAX=NLMAX_SCRIP here. -! * TMPRL_OM will not be created -! * TMPRL will be calculated using SCRIP -! If only using old method -! * NLMAX is already set, and SCRIP switch does not exist, so -! nothing is done here -! * both TMPRL and TMPRL_OM will be dimensioned -! * TMPRL_OM will be calculated -! * TMPRL_OM will be copied to TMPRL for use -! If using both methods ("DO_CHECKING") -! * set NLMAX=MAX(NLMAX, NLMAX_SCRIP) here. -! * both TMPRL_OM and TMPRL will be created -! * both will be calculated using the 2 methods, and -! checked against each other -! * the SCRIP version of weights (TMPRL) will be the ones used. + END DO ! DO JJ=1, GRDHGH(GDST,0) + GSRC=-999 ! unset grid + + ! Notes regarding 3 possible scenarios: + ! If only using SCRIP, then + ! * set NLMAX=NLMAX_SCRIP here. + ! * TMPRL_OM will not be created + ! * TMPRL will be calculated using SCRIP + ! If only using old method + ! * NLMAX is already set, and SCRIP switch does not exist, so + ! nothing is done here + ! * both TMPRL and TMPRL_OM will be dimensioned + ! * TMPRL_OM will be calculated + ! * TMPRL_OM will be copied to TMPRL for use + ! If using both methods ("DO_CHECKING") + ! * set NLMAX=MAX(NLMAX, NLMAX_SCRIP) here. + ! * both TMPRL_OM and TMPRL will be created + ! * both will be calculated using the 2 methods, and + ! checked against each other + ! * the SCRIP version of weights (TMPRL) will be the ones used. #ifdef W3_SCRIP - IF ( IMPROC.EQ.NMPERR.AND.T38 ) & - WRITE(MDSE,*) 'NLMAX,NLMAX_SCRIP=',NLMAX,NLMAX_SCRIP - IF(DO_CHECKING)THEN + IF ( IMPROC.EQ.NMPERR.AND.T38 ) & + WRITE(MDSE,*) 'NLMAX,NLMAX_SCRIP=',NLMAX,NLMAX_SCRIP + IF(DO_CHECKING)THEN NLMAX = MAX (NLMAX, NLMAX_SCRIP) - ELSE + ELSE NLMAX = NLMAX_SCRIP - ENDIF - IF ( IMPROC.EQ.NMPERR.AND.T38 ) & - WRITE(MDSE,*) 'NEW NLMAX:',NLMAX + ENDIF + IF ( IMPROC.EQ.NMPERR.AND.T38 ) & + WRITE(MDSE,*) 'NEW NLMAX:',NLMAX #endif - IF(NLMAX.GT.100)THEN - WRITE(MDSE,'(/A,I8)') & + IF(NLMAX.GT.100)THEN + WRITE(MDSE,'(/A,I8)') & 'WARNING: unusually large value for NLMAX : ',NLMAX - END IF + END IF - NRTOT = 0 - IF(OLD_METHOD)THEN - ALLOCATE ( TMPINT_OM(NX*NY,-4:NLMAX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( TMPRL_OM(NX*NY,0:NLMAX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ENDIF - ALLOCATE ( TMPINT(NX*NY,-4:NLMAX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( TMPRL(NX*NY,0:NLMAX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( TMPLOG(NX*NY), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! + NRTOT = 0 + IF(OLD_METHOD)THEN + ALLOCATE ( TMPINT_OM(NX*NY,-4:NLMAX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( TMPRL_OM(NX*NY,0:NLMAX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ENDIF + ALLOCATE ( TMPINT(NX*NY,-4:NLMAX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( TMPRL(NX*NY,0:NLMAX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( TMPLOG(NX*NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! #ifdef W3_DIST - ALLOCATE ( LTAG(NLMAX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - DO JJ=1, NLMAX - LTAG(JJ) = JJ + LTAG0 - END DO + ALLOCATE ( LTAG(NLMAX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + DO JJ=1, NLMAX + LTAG(JJ) = JJ + LTAG0 + END DO #endif -! -!!HT: -!!HT: After the search range is set, we are actually searching in the -!!HT: high-res grid. IDST, JDST are counters in the grid to which the -!!HT: averaged data is to go. XA and YA are center locatons of target -!!HT: grid. Necxt two loops over all relevant point in target grid. -!!HT: + ! + !!HT: + !!HT: After the search range is set, we are actually searching in the + !!HT: high-res grid. IDST, JDST are counters in the grid to which the + !!HT: averaged data is to go. XA and YA are center locatons of target + !!HT: grid. Necxt two loops over all relevant point in target grid. + !!HT: -! Notes: This is the start of the large loop through the individual -! grid points of the low-rank grid. -! The checks below for JDST.LT.JDSTLA , IDST.LT.IDSTLA etc are to save -! time but will only be useful for the case of regular grids. + ! Notes: This is the start of the large loop through the individual + ! grid points of the low-rank grid. + ! The checks below for JDST.LT.JDSTLA , IDST.LT.IDSTLA etc are to save + ! time but will only be useful for the case of regular grids. - LOWRANK_J : DO JDST=1, NY - IF ( JDST.LT.JDSTLA .OR. JDST.GT.JDSTHA ) CYCLE + LOWRANK_J : DO JDST=1, NY + IF ( JDST.LT.JDSTLA .OR. JDST.GT.JDSTHA ) CYCLE - LOWRANK_I : DO IDST=1, NX - IF ( IDST.LT.IDSTLA .OR. IDST.GT.IDSTHA ) CYCLE - ! check that this is a sea point - IF ( ABS(MAPSTA(JDST,IDST)) .NE. 1 ) CYCLE - ! MAPTST: see Section 2.b.2 above - IF ( MAPTST(JDST,IDST) .LT. 0 ) CYCLE - XA = REAL(XGRD(JDST,IDST)) ! old code: X0 + REAL(IDST-1)*SX - YA = REAL(YGRD(JDST,IDST)) ! old code: Y0 + REAL(JDST-1)*SY + LOWRANK_I : DO IDST=1, NX + IF ( IDST.LT.IDSTLA .OR. IDST.GT.IDSTHA ) CYCLE + ! check that this is a sea point + IF ( ABS(MAPSTA(JDST,IDST)) .NE. 1 ) CYCLE + ! MAPTST: see Section 2.b.2 above + IF ( MAPTST(JDST,IDST) .LT. 0 ) CYCLE + XA = REAL(XGRD(JDST,IDST)) ! old code: X0 + REAL(IDST-1)*SX + YA = REAL(YGRD(JDST,IDST)) ! old code: Y0 + REAL(JDST-1)*SY -!!HT: For each point in the target grid, loop over all relevant high-res -!!HT: grid (JJ loop). + !!HT: For each point in the target grid, loop over all relevant high-res + !!HT: grid (JJ loop). - NROK = 0 + NROK = 0 -! notes: GRDHGH(GDST,0) is number of grids of higher rank than the present -! grid (GDST) -! GRDHGH(GDST,1...etc.) is the grid number + ! notes: GRDHGH(GDST,0) is number of grids of higher rank than the present + ! grid (GDST) + ! GRDHGH(GDST,1...etc.) is the grid number - DO JJ=1, GRDHGH(GDST,0) - GSRC = GRDHGH(GDST,JJ) + DO JJ=1, GRDHGH(GDST,0) + GSRC = GRDHGH(GDST,JJ) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Start counting using old method + ! Start counting using old method !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Note for LLG: Assumption is made that the higher ranked grid -! cannot be global. -! -!!HT: Set search range in [candidate] high-res grid. - -! Notes: The quantities XL YL XH YH apear to be a bounding box in -! index space for later searching within the high rank grid (or -! otherwise making computations from the high rank grid). They -! are the distance from the coarse grid point to the origin of -! the high rank grid, measured in grid cells of the high rank -! grid. So, they are the i and j values in the high rank -! bounding the low rank grid cell. - - IF (OLD_METHOD)THEN - ! ...then we do the counting using the old method - -! Notes: Resulting "old method" variables are saved with "_OM" suffix. - - IF ( FLAGLL ) THEN - DXC = MOD ( 1080.+XA-GRIDS(GSRC)%X0 , 360. ) - XL = 1. + (DXC-0.5*SX)/GRIDS(GSRC)%SX - XH = 1. + (DXC+0.5*SX)/GRIDS(GSRC)%SX - ELSE - XL = 1. + (XA-GRIDS(GSRC)%X0-0.5*SX)/GRIDS(GSRC)%SX - XH = 1. + (XA-GRIDS(GSRC)%X0+0.5*SX)/GRIDS(GSRC)%SX - END IF - YL = 1. + (YA-GRIDS(GSRC)%Y0-0.5*SY)/GRIDS(GSRC)%SY - YH = 1. + (YA-GRIDS(GSRC)%Y0+0.5*SY)/GRIDS(GSRC)%SY - - ISRCL = NINT(XL+0.01) - ISRCH = NINT(XH-0.01) - JSRCL = NINT(YL+0.01) - JSRCH = NINT(YH-0.01) - - IF ( ISRCL.LT.1 .OR. ISRCH.GT.GRIDS(GSRC)%NX .OR. & - JSRCL.LT.1 .OR. JSRCH.GT.GRIDS(GSRC)%NY ) THEN -! dst point not in src grid, so go to next src grid - GRIDOK(JJ) = .FALSE. ! does this get used anywhere? - CYCLE ! leave GSRC loop - END IF - -!!HT: Loop over search range in high-res grid, ISRC and JSRC loops. -!!HT: NR0_OM counts high-res grid points with MAPSTA=0, etc. -!!HT: NRL_OM separately identifies explitcit land points. -!!HT: BDIST_OM saves the boundary data from the source grid. -!!HT: - -! Notes: We appear to be searching for the smallest boundary distance and -! doing some counting -! Purpose of counting is unknown (for dimensioning?) - -! Initialize - NR0_OM = 0 ! counter of MAPSTA=0 (indicates - ! excluded point) - NRL_OM = 0 ! counter of MAPSTA=0 (indicates - ! excluded point) and MAPST2=0 - ! (indicates land) - NR1_OM = 0 ! counter of |MAPSTA|=1 - ! (indicates sea point) - NR2_OM = 0 ! counter of |MAPSTA|=2 - ! (indicates boundary point) - BDIST_OM(JJ) = 9.99E33 - - DO ISRC=ISRCL, ISRCH - DO JSRC=JSRCL, JSRCH - IF (GRIDS(GSRC)%MAPSTA(JSRC,ISRC).EQ.0) THEN - ! excluded point - NR0_OM = NR0_OM + 1 - -! Notes: Q: What does MAPST2=0 indicate? -! A: MAPST2 is the "second grid status map" -! For disabled points (MAPSTA=0) , MAPST2 indicates land (0) or -! excluded (1). For sea and active boundary points, MAPST2 indicates -! a) ice coverage b) drying out of points c) land in moving grid or -! inferred land in nesting and d) masked in two-way nesting - - IF (GRIDS(GSRC)%MAPST2(JSRC,ISRC).EQ.0) & - NRL_OM = NRL_OM + 1 - ELSE IF (ABS(GRIDS(GSRC)%MAPSTA(JSRC,ISRC)) & - .EQ.1) THEN ! sea point - NR1_OM = NR1_OM + 1 - -! Notes: check against stored "distance to boundary point" -! This BDIST_OM array will be used later, when we select -! the high rank grid to average from. - - BDIST_OM(JJ) = MIN ( BDIST_OM(JJ) , & - MDATAS(GSRC)%MAPBDI(JSRC,ISRC) ) - ELSE IF (ABS(GRIDS(GSRC)%MAPSTA(JSRC,ISRC)) & - .EQ.2) THEN ! bnd point - NR2_OM = NR2_OM + 1 - END IF - END DO ! DO JSRC=JSRCL, JSRCH - END DO ! DO ISRC=ISRCL, ISRCH - - END IF ! (if OLD_METHOD) + ! Note for LLG: Assumption is made that the higher ranked grid + ! cannot be global. + ! + !!HT: Set search range in [candidate] high-res grid. + + ! Notes: The quantities XL YL XH YH apear to be a bounding box in + ! index space for later searching within the high rank grid (or + ! otherwise making computations from the high rank grid). They + ! are the distance from the coarse grid point to the origin of + ! the high rank grid, measured in grid cells of the high rank + ! grid. So, they are the i and j values in the high rank + ! bounding the low rank grid cell. + + IF (OLD_METHOD)THEN + ! ...then we do the counting using the old method + + ! Notes: Resulting "old method" variables are saved with "_OM" suffix. + + IF ( FLAGLL ) THEN + DXC = MOD ( 1080.+XA-GRIDS(GSRC)%X0 , 360. ) + XL = 1. + (DXC-0.5*SX)/GRIDS(GSRC)%SX + XH = 1. + (DXC+0.5*SX)/GRIDS(GSRC)%SX + ELSE + XL = 1. + (XA-GRIDS(GSRC)%X0-0.5*SX)/GRIDS(GSRC)%SX + XH = 1. + (XA-GRIDS(GSRC)%X0+0.5*SX)/GRIDS(GSRC)%SX + END IF + YL = 1. + (YA-GRIDS(GSRC)%Y0-0.5*SY)/GRIDS(GSRC)%SY + YH = 1. + (YA-GRIDS(GSRC)%Y0+0.5*SY)/GRIDS(GSRC)%SY + + ISRCL = NINT(XL+0.01) + ISRCH = NINT(XH-0.01) + JSRCL = NINT(YL+0.01) + JSRCH = NINT(YH-0.01) + + IF ( ISRCL.LT.1 .OR. ISRCH.GT.GRIDS(GSRC)%NX .OR. & + JSRCL.LT.1 .OR. JSRCH.GT.GRIDS(GSRC)%NY ) THEN + ! dst point not in src grid, so go to next src grid + GRIDOK(JJ) = .FALSE. ! does this get used anywhere? + CYCLE ! leave GSRC loop + END IF + + !!HT: Loop over search range in high-res grid, ISRC and JSRC loops. + !!HT: NR0_OM counts high-res grid points with MAPSTA=0, etc. + !!HT: NRL_OM separately identifies explitcit land points. + !!HT: BDIST_OM saves the boundary data from the source grid. + !!HT: + + ! Notes: We appear to be searching for the smallest boundary distance and + ! doing some counting + ! Purpose of counting is unknown (for dimensioning?) + + ! Initialize + NR0_OM = 0 ! counter of MAPSTA=0 (indicates + ! excluded point) + NRL_OM = 0 ! counter of MAPSTA=0 (indicates + ! excluded point) and MAPST2=0 + ! (indicates land) + NR1_OM = 0 ! counter of |MAPSTA|=1 + ! (indicates sea point) + NR2_OM = 0 ! counter of |MAPSTA|=2 + ! (indicates boundary point) + BDIST_OM(JJ) = 9.99E33 + + DO ISRC=ISRCL, ISRCH + DO JSRC=JSRCL, JSRCH + IF (GRIDS(GSRC)%MAPSTA(JSRC,ISRC).EQ.0) THEN + ! excluded point + NR0_OM = NR0_OM + 1 + + ! Notes: Q: What does MAPST2=0 indicate? + ! A: MAPST2 is the "second grid status map" + ! For disabled points (MAPSTA=0) , MAPST2 indicates land (0) or + ! excluded (1). For sea and active boundary points, MAPST2 indicates + ! a) ice coverage b) drying out of points c) land in moving grid or + ! inferred land in nesting and d) masked in two-way nesting + + IF (GRIDS(GSRC)%MAPST2(JSRC,ISRC).EQ.0) & + NRL_OM = NRL_OM + 1 + ELSE IF (ABS(GRIDS(GSRC)%MAPSTA(JSRC,ISRC)) & + .EQ.1) THEN ! sea point + NR1_OM = NR1_OM + 1 + + ! Notes: check against stored "distance to boundary point" + ! This BDIST_OM array will be used later, when we select + ! the high rank grid to average from. + + BDIST_OM(JJ) = MIN ( BDIST_OM(JJ) , & + MDATAS(GSRC)%MAPBDI(JSRC,ISRC) ) + ELSE IF (ABS(GRIDS(GSRC)%MAPSTA(JSRC,ISRC)) & + .EQ.2) THEN ! bnd point + NR2_OM = NR2_OM + 1 + END IF + END DO ! DO JSRC=JSRCL, JSRCH + END DO ! DO ISRC=ISRCL, ISRCH + + END IF ! (if OLD_METHOD) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Done with counting using old method. + ! Done with counting using old method. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Start counting using new method + ! Start counting using new method !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Initialize + ! Initialize #ifdef W3_SCRIP - BDIST(JJ) = 9.99E33 + BDIST(JJ) = 9.99E33 #endif -! Notes on variables used here: -! IDST, JDST given by loop, NIDST set above, the rest we need to set here + ! Notes on variables used here: + ! IDST, JDST given by loop, NIDST set above, the rest we need to set here #ifdef W3_SCRIP - NISRC=GRIDS(GSRC)%NX - KDST=(JDST-1)*NIDST+IDST + NISRC=GRIDS(GSRC)%NX + KDST=(JDST-1)*NIDST+IDST #endif #ifdef W3_SCRIP - DO IPNT=1,ALLWGTS(GSRC)%WGTDATA(KDST)%N - KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) - JSRC=INT((KSRC-1)/NISRC)+1 - ISRC=KSRC-(JSRC-1)*NISRC - IF (ABS(GRIDS(GSRC)%MAPSTA(JSRC,ISRC)).EQ.1) THEN + DO IPNT=1,ALLWGTS(GSRC)%WGTDATA(KDST)%N + KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) + JSRC=INT((KSRC-1)/NISRC)+1 + ISRC=KSRC-(JSRC-1)*NISRC + IF (ABS(GRIDS(GSRC)%MAPSTA(JSRC,ISRC)).EQ.1) THEN #endif - ! sea point + ! sea point #ifdef W3_SCRIP - BDIST(JJ) = MIN ( BDIST(JJ) , & - MDATAS(GSRC)%MAPBDI(JSRC,ISRC) ) - ELSE - IF ( IMPROC.EQ.NMPERR ) & - WRITE(MDSE,*) & - 'we masked non-sea points. (coding error)' - CALL EXTCDE ( 999 ) - END IF - END DO -#endif - -! Pull NR0, etc. from storage... + BDIST(JJ) = MIN ( BDIST(JJ) , & + MDATAS(GSRC)%MAPBDI(JSRC,ISRC) ) + ELSE + IF ( IMPROC.EQ.NMPERR ) & + WRITE(MDSE,*) & + 'we masked non-sea points. (coding error)' + CALL EXTCDE ( 999 ) + END IF + END DO +#endif + + ! Pull NR0, etc. from storage... #ifdef W3_SCRIP - NR0 = ALLWGTS(GSRC)%WGTDATA(KDST)%NR0 + NR0 = ALLWGTS(GSRC)%WGTDATA(KDST)%NR0 #endif -! counter of MAPSTA=0 (indicates excluded point) + ! counter of MAPSTA=0 (indicates excluded point) #ifdef W3_SCRIP - NRL = ALLWGTS(GSRC)%WGTDATA(KDST)%NRL + NRL = ALLWGTS(GSRC)%WGTDATA(KDST)%NRL #endif -! counter of MAPSTA=0 (indicates excluded point) -! and MAPST2=0 (indicates land) + ! counter of MAPSTA=0 (indicates excluded point) + ! and MAPST2=0 (indicates land) #ifdef W3_SCRIP - NR1 = ALLWGTS(GSRC)%WGTDATA(KDST)%N + NR1 = ALLWGTS(GSRC)%WGTDATA(KDST)%N #endif -! counter of |MAPSTA|=1 (indicates sea point) + ! counter of |MAPSTA|=1 (indicates sea point) #ifdef W3_SCRIP - NR2 = ALLWGTS(GSRC)%WGTDATA(KDST)%NR2 + NR2 = ALLWGTS(GSRC)%WGTDATA(KDST)%NR2 #endif -! counter of |MAPSTA|=2 (indicates boundary point) + ! counter of |MAPSTA|=2 (indicates boundary point) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Finished counting using new method. + ! Finished counting using new method. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Compare results - IF(DO_CHECKING)THEN -! then it is OK to compare with the values that we got using the old method + ! Compare results + IF(DO_CHECKING)THEN + ! then it is OK to compare with the values that we got using the old method #ifdef W3_T38 - WRITE(MDST,*)'STARTING TEST 1' -#endif - IF(NR0_OM.NE.NR0)THEN - IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & - ' *** ERROR WMGHGH: NR0_OM,NR0 = ',NR0_OM,NR0 - CALL EXTCDE ( 999 ) - ENDIF - IF(NR1_OM.NE.NR1)THEN - IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & - ' *** ERROR WMGHGH: NR1_OM,NR1 = ',NR1_OM,NR1 - CALL EXTCDE ( 999 ) - ENDIF - IF(NR2_OM.NE.NR2)THEN - IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & - ' *** ERROR WMGHGH: NR2_OM,NR2 = ',NR2_OM,NR2 - CALL EXTCDE ( 999 ) - ENDIF - IF(NRL_OM.NE.NRL)THEN - IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & - ' *** ERROR WMGHGH: NRL_OM,NRL = ',NRL_OM,NRL - CALL EXTCDE ( 999 ) - ENDIF - IF(BDIST_OM(JJ).NE.BDIST(JJ))THEN - IF ( IMPROC.EQ.NMPERR ) & - WRITE (MDSE,'(/2A,2(F12.5))') & - ' *** ERROR WMGHGH: ', & - ' BDIST_OM(JJ),BDIST(JJ) = ', & - BDIST_OM(JJ),BDIST(JJ) - CALL EXTCDE ( 999 ) - ENDIF + WRITE(MDST,*)'STARTING TEST 1' +#endif + IF(NR0_OM.NE.NR0)THEN + IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & + ' *** ERROR WMGHGH: NR0_OM,NR0 = ',NR0_OM,NR0 + CALL EXTCDE ( 999 ) + ENDIF + IF(NR1_OM.NE.NR1)THEN + IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & + ' *** ERROR WMGHGH: NR1_OM,NR1 = ',NR1_OM,NR1 + CALL EXTCDE ( 999 ) + ENDIF + IF(NR2_OM.NE.NR2)THEN + IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & + ' *** ERROR WMGHGH: NR2_OM,NR2 = ',NR2_OM,NR2 + CALL EXTCDE ( 999 ) + ENDIF + IF(NRL_OM.NE.NRL)THEN + IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & + ' *** ERROR WMGHGH: NRL_OM,NRL = ',NRL_OM,NRL + CALL EXTCDE ( 999 ) + ENDIF + IF(BDIST_OM(JJ).NE.BDIST(JJ))THEN + IF ( IMPROC.EQ.NMPERR ) & + WRITE (MDSE,'(/2A,2(F12.5))') & + ' *** ERROR WMGHGH: ', & + ' BDIST_OM(JJ),BDIST(JJ) = ', & + BDIST_OM(JJ),BDIST(JJ) + CALL EXTCDE ( 999 ) + ENDIF #ifdef W3_T38 - WRITE(MDST,*)'PASSED TEST 1' + WRITE(MDST,*)'PASSED TEST 1' #endif - END IF ! (if DO_CHECKING) + END IF ! (if DO_CHECKING) + + ! Notes: We are done with the counting. If we didn't use SCRIP to get NR0, + ! etc., then we need to set them using the _OM variables. -! Notes: We are done with the counting. If we didn't use SCRIP to get NR0, -! etc., then we need to set them using the _OM variables. + IF(.NOT.LSCRIP)THEN + NR0=NR0_OM + NR1=NR1_OM + NR2=NR2_OM + NRL=NRL_OM + BDIST=BDIST_OM + END IF + + ! Notes: Potential future improvement: for irregular grids, it would make + ! more sense to use the overlapped area, rather than simply counting cells + ! to decide on "inferred land". However, since grid cell size it typically + ! fairly uniform locally, the current approach will suffice for now. - IF(.NOT.LSCRIP)THEN - NR0=NR0_OM - NR1=NR1_OM - NR2=NR2_OM - NRL=NRL_OM - BDIST=BDIST_OM - END IF + ! Notes: This is the only place that the "NRL" "NR0" "NR1" and "NR2" variables + ! are used directly. They affect MAPST2 indirectly below. + ! The calculation itself is essentially "50% or more of the grid + ! cells are land". -! Notes: Potential future improvement: for irregular grids, it would make -! more sense to use the overlapped area, rather than simply counting cells -! to decide on "inferred land". However, since grid cell size it typically -! fairly uniform locally, the current approach will suffice for now. + IF ( NRL .GT. (NR0+NR1+NR2)/2 ) THEN -! Notes: This is the only place that the "NRL" "NR0" "NR1" and "NR2" variables -! are used directly. They affect MAPST2 indirectly below. -! The calculation itself is essentially "50% or more of the grid -! cells are land". + ! Notes: This is not considered an OK grid (NROK is not incremented) and + ! it is considered "inferred land" - IF ( NRL .GT. (NR0+NR1+NR2)/2 ) THEN + INFLND(JDST,IDST) = 1 + ELSE + GRIDOK(JJ) = NR1.GT.0 .AND. NR2.EQ.0 -! Notes: This is not considered an OK grid (NROK is not incremented) and -! it is considered "inferred land" + ! Notes: for a grid cell to be considered "OK", we require that there is + ! at least one sea point being used, and no boundary points being used - INFLND(JDST,IDST) = 1 - ELSE - GRIDOK(JJ) = NR1.GT.0 .AND. NR2.EQ.0 + IF ( GRIDOK(JJ) ) NROK = NROK + 1 + END IF -! Notes: for a grid cell to be considered "OK", we require that there is -! at least one sea point being used, and no boundary points being used - - IF ( GRIDOK(JJ) ) NROK = NROK + 1 - END IF + END DO ! GSRC loop + GSRC=-999 ! unset grid - END DO ! GSRC loop - GSRC=-999 ! unset grid + IF ( NROK .EQ. 0 ) THEN - IF ( NROK .EQ. 0 ) THEN + ! Notes: exit IDST loop since there are no "OK" source grid cells for this + ! dst point. At this point, INFLND could be 1, but isn't necessarily 1 -! Notes: exit IDST loop since there are no "OK" source grid cells for this -! dst point. At this point, INFLND could be 1, but isn't necessarily 1 - - CYCLE + CYCLE - ELSE + ELSE -! Notes: If any grids are OK for this dst point, then we override any prior -! setting of INFLD=1. Apparently this is for the situation of having some src -! grids giving INFLD=1 and another giving INFLD=0 for the same dst point. -! I wouldn't expect this to happen very often. - - INFLND(JDST,IDST) = 0 + ! Notes: If any grids are OK for this dst point, then we override any prior + ! setting of INFLD=1. Apparently this is for the situation of having some src + ! grids giving INFLD=1 and another giving INFLD=0 for the same dst point. + ! I wouldn't expect this to happen very often. + INFLND(JDST,IDST) = 0 + + END IF + ! + ! 2.b.5 Select source grid + ! + ! Notes: It appears that we are selecting the high rank grid from + ! which we will perform the averaging. + ! The code is written such that the first higher rank + ! grid that we find has the rank that we want, but isn't necessarily the + ! grid that we want. + ! Are grids necessarily in order of rank? If so, then we want the grid + ! that is higher rank but of nearest rank to the present grid. + ! Anyway, once we have decided on the grid rank that we want, we select + ! the specific grid according to criterion: larger distance to + ! boundary = better + ! Keep in mind that this grid is selected for *this* (IDST,JDST) and not + ! necesssarily for the next... + + JF = 0 + + !!HT: Another loop over all high-res grid to decide which grid will + !!HT: be used to average data. If more than 1 grids are available, + !!HT: the boundary distance in the high-res grid, stored in BDIST is + !!HT: used to make the choice. + + !!ER: Old logic was to select a grid that is of the "next rank up, + !!ER: for which data is available". This was done by searching + !!ER: from 1 to GRDHGH (remember that the available source grids + !!ER: are in order of rank), and exiting when the rank increased. + !!ER: The problem with selecting the "lowest rank grid with rank + !!ER: greater than that of GDST" is that at this point, we have + !!ER: no knowledge of what will be masked in that SRC grid, since + !!ER: we haven't updated MAPSTA for that GSRC yet, based on what + !!ER: points are covered by higher rank grids (in case of masking + !!ER: computations). We can avoid this problem by reversing the + !!ER: order of GSRC search (from highest rank to lowest rank of + !!ER: higher rank). For example, grid 1 wants data from grid 2, + !!ER: but just gets zeros because grid 2 is masked there, because + !!ER: grid 2 is masked by grid 3 in Section 2.3.2 below. Going + !!ER: directly to GSRC=3 for GDST=1 (skipping GSRC=2) avoids + !!ER: this: the highest rank at that location will never be + !!ER: masked by a higher rank grid. + + DO JJ=GRDHGH(GDST,0),1,-1 + !old DO JJ=1, GRDHGH(GDST,0) ! used before Aug 2014 + + GSRC = GRDHGH(GDST,JJ) + + IF ( GRIDOK(JJ) ) THEN + IF ( JF .EQ. 0 ) THEN ! we haven't already found a grid + JF = GSRC ! now we have found a grid. + JR = GRANK(GSRC) + ! this is the rank that we want....the rank of the first grid that we find + JD = BDIST(JJ) ! larger distance = better + ELSE + ! we already found a grid, but maybe this one is better + IF ( GRANK(GSRC) .NE. JR ) EXIT + ! this is not the rank that we want + IF ( BDIST(JJ) .GT. JD ) THEN + ! we like this grid better + JF = GSRC + JD = BDIST(JJ) END IF -! -! 2.b.5 Select source grid -! -! Notes: It appears that we are selecting the high rank grid from -! which we will perform the averaging. -! The code is written such that the first higher rank -! grid that we find has the rank that we want, but isn't necessarily the -! grid that we want. -! Are grids necessarily in order of rank? If so, then we want the grid -! that is higher rank but of nearest rank to the present grid. -! Anyway, once we have decided on the grid rank that we want, we select -! the specific grid according to criterion: larger distance to -! boundary = better -! Keep in mind that this grid is selected for *this* (IDST,JDST) and not -! necesssarily for the next... - - JF = 0 - -!!HT: Another loop over all high-res grid to decide which grid will -!!HT: be used to average data. If more than 1 grids are available, -!!HT: the boundary distance in the high-res grid, stored in BDIST is -!!HT: used to make the choice. - -!!ER: Old logic was to select a grid that is of the "next rank up, -!!ER: for which data is available". This was done by searching -!!ER: from 1 to GRDHGH (remember that the available source grids -!!ER: are in order of rank), and exiting when the rank increased. -!!ER: The problem with selecting the "lowest rank grid with rank -!!ER: greater than that of GDST" is that at this point, we have -!!ER: no knowledge of what will be masked in that SRC grid, since -!!ER: we haven't updated MAPSTA for that GSRC yet, based on what -!!ER: points are covered by higher rank grids (in case of masking -!!ER: computations). We can avoid this problem by reversing the -!!ER: order of GSRC search (from highest rank to lowest rank of -!!ER: higher rank). For example, grid 1 wants data from grid 2, -!!ER: but just gets zeros because grid 2 is masked there, because -!!ER: grid 2 is masked by grid 3 in Section 2.3.2 below. Going -!!ER: directly to GSRC=3 for GDST=1 (skipping GSRC=2) avoids -!!ER: this: the highest rank at that location will never be -!!ER: masked by a higher rank grid. - - DO JJ=GRDHGH(GDST,0),1,-1 -!old DO JJ=1, GRDHGH(GDST,0) ! used before Aug 2014 - - GSRC = GRDHGH(GDST,JJ) - - IF ( GRIDOK(JJ) ) THEN - IF ( JF .EQ. 0 ) THEN ! we haven't already found a grid - JF = GSRC ! now we have found a grid. - JR = GRANK(GSRC) -! this is the rank that we want....the rank of the first grid that we find - JD = BDIST(JJ) ! larger distance = better - ELSE -! we already found a grid, but maybe this one is better - IF ( GRANK(GSRC) .NE. JR ) EXIT -! this is not the rank that we want - IF ( BDIST(JJ) .GT. JD ) THEN -! we like this grid better - JF = GSRC - JD = BDIST(JJ) - END IF - END IF - END IF - END DO - GSRC=JF + END IF + END IF + END DO + GSRC=JF #ifdef W3_T38 - WRITE(MDST,'(A,2(I8),A,I8)')'For grid point IDST,JDST = ',IDST,JDST,', we selected GSRC = ',GSRC + WRITE(MDST,'(A,2(I8),A,I8)')'For grid point IDST,JDST = ',IDST,JDST,', we selected GSRC = ',GSRC #endif -!!HT: Data for grid point IDST,JDST in the low-res grid will be taken from -!!HT: high-res grid GSRC. + !!HT: Data for grid point IDST,JDST in the low-res grid will be taken from + !!HT: high-res grid GSRC. - MAPTST(JDST,IDST) = GSRC -! -! 2.b.6 Store data (temp) -! -! Notes: This section is for calculations of weights for the -! area-weighted averaging. + MAPTST(JDST,IDST) = GSRC + ! + ! 2.b.6 Store data (temp) + ! + ! Notes: This section is for calculations of weights for the + ! area-weighted averaging. - NRTOT = NRTOT + 1 - TMPINT(NRTOT,-4) = IDST - TMPINT(NRTOT,-3) = JDST - TMPINT(NRTOT,-2) = MAPFS(JDST,IDST) - TMPINT(NRTOT,-1) = GSRC - TMPRL (NRTOT, 0) = JD * SIG(1) / DTMAX + NRTOT = NRTOT + 1 + TMPINT(NRTOT,-4) = IDST + TMPINT(NRTOT,-3) = JDST + TMPINT(NRTOT,-2) = MAPFS(JDST,IDST) + TMPINT(NRTOT,-1) = GSRC + TMPRL (NRTOT, 0) = JD * SIG(1) / DTMAX -! Notes: Calculation for XL YL XH YH is same as it was in section 2.b.4, so -! see notes in that section. + ! Notes: Calculation for XL YL XH YH is same as it was in section 2.b.4, so + ! see notes in that section. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!...Begin block of code for computing weights using old method + !...Begin block of code for computing weights using old method !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - IF (OLD_METHOD)THEN -! it is OK to do the counting using the old method -! (These variables are saved with "_OM" suffix) - - DO ITMP=-4,-1 - TMPINT_OM(NRTOT,ITMP)=TMPINT(NRTOT,ITMP) - END DO - TMPRL_OM(NRTOT,0)=TMPRL(NRTOT,0) - - IF ( FLAGLL ) THEN - DXC = MOD ( 1080.+XA-GRIDS(GSRC)%X0 , 360. ) - XL = 1. + (DXC-0.5*SX)/GRIDS(GSRC)%SX - XH = 1. + (DXC+0.5*SX)/GRIDS(GSRC)%SX - ELSE - XL = 1. + (XA-GRIDS(GSRC)%X0-0.5*SX)/GRIDS(GSRC)%SX - XH = 1. + (XA-GRIDS(GSRC)%X0+0.5*SX)/GRIDS(GSRC)%SX - END IF - YL = 1. + (YA-GRIDS(GSRC)%Y0-0.5*SY)/GRIDS(GSRC)%SY - YH = 1. + (YA-GRIDS(GSRC)%Y0+0.5*SY)/GRIDS(GSRC)%SY - -! Notes: Here, we save the search bounds. These bounds are given in terms of -! index space of the high rank grid. "L" and "H" here do *not* refer -! to grid rank! They refer to lower and upper bounds. - - ISRCL = NINT(XL+0.01) - ISRCH = NINT(XH-0.01) - JSRCL = NINT(YL+0.01) - JSRCH = NINT(YH-0.01) - - WTOT = 0. - NLOC_OM = 0 - DO ISRC=ISRCL, ISRCH - WX = MIN(XH,REAL(ISRC)+0.5) - MAX(XL,REAL(ISRC)-0.5) - DO JSRC=JSRCL, JSRCH - IF (ABS(GRIDS(GSRC)%MAPSTA(JSRC,ISRC)).EQ.1) THEN -! sea point - WY = MIN(YH,REAL(JSRC)+0.5) - & - MAX(YL,REAL(JSRC)-0.5) - WTOT = WTOT + WX*WY - NLOC_OM = NLOC_OM + 1 -! Notes: check here that we are sufficiently dimensioned. - IF ( NLOC_OM .GT. NLMAX ) THEN - IF ( IMPROC.EQ.NMPERR ) WRITE (MDSE,1020) - CALL EXTCDE(1020) - END IF - TMPINT_OM(NRTOT,NLOC_OM) = & - GRIDS(GSRC)%MAPFS(JSRC,ISRC) - TMPRL_OM (NRTOT,NLOC_OM) = WX*WY - END IF - END DO - END DO - TMPINT_OM(NRTOT,0) = NLOC_OM - TMPRL_OM (NRTOT,1:NLOC_OM) = TMPRL_OM(NRTOT,1:NLOC_OM) & - / WTOT - - END IF ! (if OLD_METHOD) + + IF (OLD_METHOD)THEN + ! it is OK to do the counting using the old method + ! (These variables are saved with "_OM" suffix) + + DO ITMP=-4,-1 + TMPINT_OM(NRTOT,ITMP)=TMPINT(NRTOT,ITMP) + END DO + TMPRL_OM(NRTOT,0)=TMPRL(NRTOT,0) + + IF ( FLAGLL ) THEN + DXC = MOD ( 1080.+XA-GRIDS(GSRC)%X0 , 360. ) + XL = 1. + (DXC-0.5*SX)/GRIDS(GSRC)%SX + XH = 1. + (DXC+0.5*SX)/GRIDS(GSRC)%SX + ELSE + XL = 1. + (XA-GRIDS(GSRC)%X0-0.5*SX)/GRIDS(GSRC)%SX + XH = 1. + (XA-GRIDS(GSRC)%X0+0.5*SX)/GRIDS(GSRC)%SX + END IF + YL = 1. + (YA-GRIDS(GSRC)%Y0-0.5*SY)/GRIDS(GSRC)%SY + YH = 1. + (YA-GRIDS(GSRC)%Y0+0.5*SY)/GRIDS(GSRC)%SY + + ! Notes: Here, we save the search bounds. These bounds are given in terms of + ! index space of the high rank grid. "L" and "H" here do *not* refer + ! to grid rank! They refer to lower and upper bounds. + + ISRCL = NINT(XL+0.01) + ISRCH = NINT(XH-0.01) + JSRCL = NINT(YL+0.01) + JSRCH = NINT(YH-0.01) + + WTOT = 0. + NLOC_OM = 0 + DO ISRC=ISRCL, ISRCH + WX = MIN(XH,REAL(ISRC)+0.5) - MAX(XL,REAL(ISRC)-0.5) + DO JSRC=JSRCL, JSRCH + IF (ABS(GRIDS(GSRC)%MAPSTA(JSRC,ISRC)).EQ.1) THEN + ! sea point + WY = MIN(YH,REAL(JSRC)+0.5) - & + MAX(YL,REAL(JSRC)-0.5) + WTOT = WTOT + WX*WY + NLOC_OM = NLOC_OM + 1 + ! Notes: check here that we are sufficiently dimensioned. + IF ( NLOC_OM .GT. NLMAX ) THEN + IF ( IMPROC.EQ.NMPERR ) WRITE (MDSE,1020) + CALL EXTCDE(1020) + END IF + TMPINT_OM(NRTOT,NLOC_OM) = & + GRIDS(GSRC)%MAPFS(JSRC,ISRC) + TMPRL_OM (NRTOT,NLOC_OM) = WX*WY + END IF + END DO + END DO + TMPINT_OM(NRTOT,0) = NLOC_OM + TMPRL_OM (NRTOT,1:NLOC_OM) = TMPRL_OM(NRTOT,1:NLOC_OM) & + / WTOT + + END IF ! (if OLD_METHOD) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!...End block of code for computing weights using old method + !...End block of code for computing weights using old method !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!...Begin block of code for "computing" weights using new method + !...Begin block of code for "computing" weights using new method !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Notes: Weights have already been computed by SCRIP. -! We just need to transfer them to TMPINT and TMPRL + ! Notes: Weights have already been computed by SCRIP. + ! We just need to transfer them to TMPINT and TMPRL #ifdef W3_SCRIP - KDST=(JDST-1)*NIDST+IDST - NLOC=ALLWGTS(GSRC)%WGTDATA(KDST)%N - TMPINT(NRTOT,0) = NLOC - NISRC=GRIDS(GSRC)%NX + KDST=(JDST-1)*NIDST+IDST + NLOC=ALLWGTS(GSRC)%WGTDATA(KDST)%N + TMPINT(NRTOT,0) = NLOC + NISRC=GRIDS(GSRC)%NX #endif -! Test output + ! Test output #ifdef W3_SCRIP - IF ( IMPROC.EQ.NMPERR.AND.T38 ) THEN - WRITE(MDST,*)'GSRC,KDST,NLOC = ',GSRC,KDST,NLOC - ENDIF + IF ( IMPROC.EQ.NMPERR.AND.T38 ) THEN + WRITE(MDST,*)'GSRC,KDST,NLOC = ',GSRC,KDST,NLOC + ENDIF #endif -! Notes: check here that we are sufficiently dimensioned. + ! Notes: check here that we are sufficiently dimensioned. #ifdef W3_SCRIP - IF ( NLOC .GT. NLMAX ) THEN - IF ( IMPROC.EQ.NMPERR ) THEN - WRITE (MDSE,'(/2A,4(1x,I8))') & - ' *** ERROR WMGHGH: ', & - ' IDST,JDST,NLOC,NLMAX = ', & - IDST,JDST,NLOC,NLMAX - WRITE(MDSE,1021) - ENDIF - CALL EXTCDE(1021) - END IF - DO IPNT=1,NLOC - KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) - JSRC=INT((KSRC-1)/NISRC)+1 - ISRC=KSRC-(JSRC-1)*NISRC - TMPINT(NRTOT,IPNT) = GRIDS(GSRC)%MAPFS(JSRC,ISRC) - TMPRL(NRTOT,IPNT)= & - ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) ! WX*WY / WTOT - END DO ! DO IPNT=1,NLOC + IF ( NLOC .GT. NLMAX ) THEN + IF ( IMPROC.EQ.NMPERR ) THEN + WRITE (MDSE,'(/2A,4(1x,I8))') & + ' *** ERROR WMGHGH: ', & + ' IDST,JDST,NLOC,NLMAX = ', & + IDST,JDST,NLOC,NLMAX + WRITE(MDSE,1021) + ENDIF + CALL EXTCDE(1021) + END IF + DO IPNT=1,NLOC + KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) + JSRC=INT((KSRC-1)/NISRC)+1 + ISRC=KSRC-(JSRC-1)*NISRC + TMPINT(NRTOT,IPNT) = GRIDS(GSRC)%MAPFS(JSRC,ISRC) + TMPRL(NRTOT,IPNT)= & + ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) ! WX*WY / WTOT + END DO ! DO IPNT=1,NLOC #endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!...End block of code for "computing" weights using new method + !...End block of code for "computing" weights using new method !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!...Begin block of code that is just for testing + !...Begin block of code that is just for testing !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF (DO_CHECKING)THEN -! compare with the values that we got using the old method + IF (DO_CHECKING)THEN + ! compare with the values that we got using the old method #ifdef W3_T38 - WRITE(MDST,*)'STARTING TEST 2' -#endif - if (NLOC.NE.NLOC_OM) THEN - IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & - ' *** ERROR WMGHGH: NLOC,NLOC_OM = ',NLOC,NLOC_OM - CALL EXTCDE ( 999 ) - END IF - ISTOP=0 - ICOUNT=0 - DO IPNT=1,NLOC - DO IPNT2=1,NLOC - IF (TMPINT_OM(NRTOT,IPNT).EQ.TMPINT(NRTOT,IPNT2))THEN -! we found our point - ICOUNT=ICOUNT+1 - IF(ABS(TMPRL_OM(NRTOT,IPNT)-TMPRL(NRTOT,IPNT2)) & - .GT.4.0e-5)then - IF ( IMPROC.EQ.NMPERR )WRITE & - (MDSE,'(/2A,2(F12.5))') & + WRITE(MDST,*)'STARTING TEST 2' +#endif + if (NLOC.NE.NLOC_OM) THEN + IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & + ' *** ERROR WMGHGH: NLOC,NLOC_OM = ',NLOC,NLOC_OM + CALL EXTCDE ( 999 ) + END IF + ISTOP=0 + ICOUNT=0 + DO IPNT=1,NLOC + DO IPNT2=1,NLOC + IF (TMPINT_OM(NRTOT,IPNT).EQ.TMPINT(NRTOT,IPNT2))THEN + ! we found our point + ICOUNT=ICOUNT+1 + IF(ABS(TMPRL_OM(NRTOT,IPNT)-TMPRL(NRTOT,IPNT2)) & + .GT.4.0e-5)then + IF ( IMPROC.EQ.NMPERR )WRITE & + (MDSE,'(/2A,2(F12.5))') & ' *** ERROR WMGHGH: ', & ' *** TMPRL_OM(NRTOT,IPNT),TMPRL(NRTOT,IPNT2) = ', & - TMPRL_OM(NRTOT,IPNT),TMPRL(NRTOT,IPNT2) - ISTOP=1 - END IF - END IF - END DO - END DO - IF(ICOUNT.NE.NLOC)THEN - IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & - ' *** ERROR WMGHGH: ICOUNT,NLOC = ',ICOUNT,NLOC - ISTOP=1 - END IF - IF(ISTOP.EQ.1)THEN - CALL EXTCDE ( 999 ) - END IF + TMPRL_OM(NRTOT,IPNT),TMPRL(NRTOT,IPNT2) + ISTOP=1 + END IF + END IF + END DO + END DO + IF(ICOUNT.NE.NLOC)THEN + IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & + ' *** ERROR WMGHGH: ICOUNT,NLOC = ',ICOUNT,NLOC + ISTOP=1 + END IF + IF(ISTOP.EQ.1)THEN + CALL EXTCDE ( 999 ) + END IF #ifdef W3_T38 - WRITE(MDST,*)'PASSED TEST 2' + WRITE(MDST,*)'PASSED TEST 2' #endif - END IF ! (if both grids are regular grids) - + END IF ! (if both grids are regular grids) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!...End block of code that is just for testing + !...End block of code that is just for testing !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - NROK = 0 + NROK = 0 - END DO LOWRANK_I ! DO IDST=1, NX - END DO LOWRANK_J ! DO JDST=1, NY + END DO LOWRANK_I ! DO IDST=1, NX + END DO LOWRANK_J ! DO JDST=1, NY #ifdef W3_T38 - WRITE(MDST,*)'WMGHGH Section 2.b.6 completed.' + WRITE(MDST,*)'WMGHGH Section 2.b.6 completed.' #endif -! Notes: We are done with the counting. If we didn't use SCRIP to get -! TMPINT, TMPRL, then we need to set them using the _OM variables. + ! Notes: We are done with the counting. If we didn't use SCRIP to get + ! TMPINT, TMPRL, then we need to set them using the _OM variables. - IF(.NOT.LSCRIP)THEN - TMPINT=TMPINT_OM - TMPRL=TMPRL_OM - END IF + IF(.NOT.LSCRIP)THEN + TMPINT=TMPINT_OM + TMPRL=TMPRL_OM + END IF #ifdef W3_T - WRITE (MDST,9023) GDST, NRTOT -#endif -! -! 2.c Set up masks based on stencil width of scheme and inferred land -! 2.c.1 Inferred land -! -!!HT: Inferred land from INFLND is added to MAPSTA / MAPST2 -!!HT: - MAPST2 = MAPST2 - 4*MOD(MAPST2/4,2) - MAPST2 = MAPST2 + 4*INFLND - DO IDST=1, NX - DO JDST=1, NY - IF ( MAPST2(JDST,IDST).GT.0 ) MAPSTA(JDST,IDST) = & - - ABS(MAPSTA(JDST,IDST)) - END DO - END DO -! -! 2.c.2 Masking -! -!!HT: This is masking in the low-res grid to identify where the grid -!!HT: is covered by high-res grids, and far enough away from the -!!HT: high-res grid edges so that no dynamic computations are needed -!!HT: in the low-res grid. -!!HT: - ALLOCATE ( STMASK(NY,0:NX+1), MASKI(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - IF ( MDATAS(GDST)%MSKINI ) THEN - DEALLOCATE ( MDATAS(GDST)%MAPMSK, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END IF - ALLOCATE ( MDATAS(GDST)%MAPMSK(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - MAPMSK => MDATAS(GDST)%MAPMSK - MDATAS(GDST)%MSKINI = .TRUE. + WRITE (MDST,9023) GDST, NRTOT +#endif + ! + ! 2.c Set up masks based on stencil width of scheme and inferred land + ! 2.c.1 Inferred land + ! + !!HT: Inferred land from INFLND is added to MAPSTA / MAPST2 + !!HT: + MAPST2 = MAPST2 - 4*MOD(MAPST2/4,2) + MAPST2 = MAPST2 + 4*INFLND + DO IDST=1, NX + DO JDST=1, NY + IF ( MAPST2(JDST,IDST).GT.0 ) MAPSTA(JDST,IDST) = & + - ABS(MAPSTA(JDST,IDST)) + END DO + END DO + ! + ! 2.c.2 Masking + ! + !!HT: This is masking in the low-res grid to identify where the grid + !!HT: is covered by high-res grids, and far enough away from the + !!HT: high-res grid edges so that no dynamic computations are needed + !!HT: in the low-res grid. + !!HT: + ALLOCATE ( STMASK(NY,0:NX+1), MASKI(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + IF ( MDATAS(GDST)%MSKINI ) THEN + DEALLOCATE ( MDATAS(GDST)%MAPMSK, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + ALLOCATE ( MDATAS(GDST)%MAPMSK(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + MAPMSK => MDATAS(GDST)%MAPMSK + MDATAS(GDST)%MSKINI = .TRUE. - MAPMSK = MOD(MAPST2/8,2) - MAPST2 = MAPST2 - 8*MAPMSK + MAPMSK = MOD(MAPST2/8,2) + MAPST2 = MAPST2 - 8*MAPMSK -!!HT: STMASK (logical) is used to start this up. We first use the point -!!HT: MAPTST that have been marked as used for boundary points in -!!HT: the corrsponding high-res grids. -!!HT: NIT sets the stencil width of the propagation scheme, used to see -!!HT: how far we need to move in from the boundary points of -!!HT: the high-res grid to reach the area in the low-res grid -!!HT: where we do not need to compute. + !!HT: STMASK (logical) is used to start this up. We first use the point + !!HT: MAPTST that have been marked as used for boundary points in + !!HT: the corrsponding high-res grids. + !!HT: NIT sets the stencil width of the propagation scheme, used to see + !!HT: how far we need to move in from the boundary points of + !!HT: the high-res grid to reach the area in the low-res grid + !!HT: where we do not need to compute. - STMASK(:,1:NX) = MAPTST .LT. 0 - STMASK(:,0) = STMASK(:,NX) - STMASK(:,NX+1) = STMASK(:,1) + STMASK(:,1:NX) = MAPTST .LT. 0 + STMASK(:,0) = STMASK(:,NX) + STMASK(:,NX+1) = STMASK(:,1) #ifdef W3_PR0 - NIT = 0 + NIT = 0 #endif #ifdef W3_PR1 - NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 #endif #ifdef W3_UQ - NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 #endif #ifdef W3_UNO - NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 #endif - IDSTLA=2 - IDSTHA=NX-1 + IDSTLA=2 + IDSTHA=NX-1 -! notes....bug fix: in official release 3.14, the if-then below -! was missing. This would produce incorrect results for a global grid that -! had a higher rank grid on the branch cut (180 to -180 or 360 to 0). See -! treatment of STMASK after the if-then statement. There, it is clear that -! it was intended that MASKI be available for i=1 and i=nx, ... but it wasn't -! available. Symptoms of bug: when using "T T" for masking options, a strip -! of land would be placed along the i-column just east of the branch cut. -! This would be seen in the global (low rank) grid. + ! notes....bug fix: in official release 3.14, the if-then below + ! was missing. This would produce incorrect results for a global grid that + ! had a higher rank grid on the branch cut (180 to -180 or 360 to 0). See + ! treatment of STMASK after the if-then statement. There, it is clear that + ! it was intended that MASKI be available for i=1 and i=nx, ... but it wasn't + ! available. Symptoms of bug: when using "T T" for masking options, a strip + ! of land would be placed along the i-column just east of the branch cut. + ! This would be seen in the global (low rank) grid. - IF ( ICLOSE.NE.ICLOSE_NONE ) THEN - IDSTLA=1 - IDSTHA=NX - END IF + IF ( ICLOSE.NE.ICLOSE_NONE ) THEN + IDSTLA=1 + IDSTHA=NX + END IF - DO JTMP=1, NIT - MASKI = .FALSE. - DO IDST=IDSTLA,IDSTHA - DO JDST=2, NY-1 - IF ( .NOT. STMASK(JDST,IDST) .AND. ( & - STMASK(JDST+1,IDST+1) .OR. STMASK(JDST+1,IDST ) .OR. & - STMASK(JDST+1,IDST-1) .OR. STMASK(JDST ,IDST-1) .OR. & - STMASK(JDST-1,IDST-1) .OR. STMASK(JDST-1,IDST ) .OR. & - STMASK(JDST-1,IDST+1) .OR. STMASK(JDST ,IDST+1) ) ) & - MASKI(JDST,IDST) = .TRUE. - END DO - END DO - STMASK(:,1:NX) = STMASK(:,1:NX) .OR. MASKI - STMASK(:,0) = STMASK(:,NX) - STMASK(:,NX+1) = STMASK(:,1) + DO JTMP=1, NIT + MASKI = .FALSE. + DO IDST=IDSTLA,IDSTHA + DO JDST=2, NY-1 + IF ( .NOT. STMASK(JDST,IDST) .AND. ( & + STMASK(JDST+1,IDST+1) .OR. STMASK(JDST+1,IDST ) .OR. & + STMASK(JDST+1,IDST-1) .OR. STMASK(JDST ,IDST-1) .OR. & + STMASK(JDST-1,IDST-1) .OR. STMASK(JDST-1,IDST ) .OR. & + STMASK(JDST-1,IDST+1) .OR. STMASK(JDST ,IDST+1) ) ) & + MASKI(JDST,IDST) = .TRUE. END DO + END DO + STMASK(:,1:NX) = STMASK(:,1:NX) .OR. MASKI + STMASK(:,0) = STMASK(:,NX) + STMASK(:,NX+1) = STMASK(:,1) + END DO -!!HT: Loop over all point from which low-res grid gets data from -!!HT: high-res grid(s). Comparing to STMASK shows which points can be -!!HT: masked out for computation. -!!HT: -!!HT: MAPMSK is stored in WMMDATMD for use in wave model. - - DO ILOC=1, NRTOT - IDST = TMPINT(ILOC,-4) - JDST = TMPINT(ILOC,-3) - TMPLOG(ILOC) = STMASK(JDST,IDST) - IF ( .NOT. STMASK(JDST,IDST) ) THEN - MAPMSK(JDST,IDST) = 1 - IF ( FLGHG1 ) MAPSTA(JDST,IDST) = -ABS(MAPSTA(JDST,IDST)) - MAPTST(JDST,IDST) = 99 - END IF - END DO + !!HT: Loop over all point from which low-res grid gets data from + !!HT: high-res grid(s). Comparing to STMASK shows which points can be + !!HT: masked out for computation. + !!HT: + !!HT: MAPMSK is stored in WMMDATMD for use in wave model. + + DO ILOC=1, NRTOT + IDST = TMPINT(ILOC,-4) + JDST = TMPINT(ILOC,-3) + TMPLOG(ILOC) = STMASK(JDST,IDST) + IF ( .NOT. STMASK(JDST,IDST) ) THEN + MAPMSK(JDST,IDST) = 1 + IF ( FLGHG1 ) MAPSTA(JDST,IDST) = -ABS(MAPSTA(JDST,IDST)) + MAPTST(JDST,IDST) = 99 + END IF + END DO - IF ( FLGHG1 ) MAPST2 = MAPST2 + 8*MAPMSK + IF ( FLGHG1 ) MAPST2 = MAPST2 + 8*MAPMSK - DEALLOCATE ( STMASK, MASKI, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE ( STMASK, MASKI, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) -!!HT: Now that all temporary data is stored, and all mosks are set, all -!!HT: can be put from temporaty storage in permanent storage. -!!HT: -!!HT: Should require no modifications for newer grids ... -!!HT: ... unless more data is needed than for old grids ..... + !!HT: Now that all temporary data is stored, and all mosks are set, all + !!HT: can be put from temporaty storage in permanent storage. + !!HT: + !!HT: Should require no modifications for newer grids ... + !!HT: ... unless more data is needed than for old grids ..... -! -! 2.d Set up mapping for staging data -! 2.d.1 Set counters / required array sizes -! + ! + ! 2.d Set up mapping for staging data + ! 2.d.1 Set counters / required array sizes + ! #ifdef W3_SHRD - ISPROC = 1 - ISPRO2 = 1 + ISPROC = 1 + ISPRO2 = 1 #endif - I1 = 0 - I2 = 0 - I3 = 0 - I4 = 0 + I1 = 0 + I2 = 0 + I3 = 0 + I4 = 0 - DO ILOC=1, NRTOT + DO ILOC=1, NRTOT - JJ = TMPINT(ILOC,-1) - HGSTGE(GDST,JJ)%NTOT = HGSTGE(GDST,JJ)%NTOT + 1 - ISEA = TMPINT(ILOC,-2) - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + JJ = TMPINT(ILOC,-1) + HGSTGE(GDST,JJ)%NTOT = HGSTGE(GDST,JJ)%NTOT + 1 + ISEA = TMPINT(ILOC,-2) + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) #ifdef W3_DIST - ISPROC = ISPROC + CROOT - 1 -#endif -! - I1(JJ,ISPROC) = I1(JJ,ISPROC) + 1 - IF ( TMPLOG(ILOC) ) I2(JJ,ISPROC) = I2(JJ,ISPROC) + 1 - IF ( IMPROC .EQ. ISPROC ) THEN - HGSTGE(GDST,JJ)%NSMX = MAX(HGSTGE(GDST,JJ)%NSMX,TMPINT(ILOC,0)) - END IF - - DO JR=1, TMPINT(ILOC,0) - ISEA = TMPINT(ILOC,JR) - CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, JJ, JSEA, ISPRO2) - IF ( ISPRO2 .EQ. IMPROC ) THEN - HGSTGE(GDST,JJ)%NSND = HGSTGE(GDST,JJ)%NSND + 1 - IF ( TMPLOG(ILOC) ) HGSTGE(GDST,JJ)%NSN1 = & - HGSTGE(GDST,JJ)%NSN1 + 1 - END IF - END DO -! - END DO + ISPROC = ISPROC + CROOT - 1 +#endif + ! + I1(JJ,ISPROC) = I1(JJ,ISPROC) + 1 + IF ( TMPLOG(ILOC) ) I2(JJ,ISPROC) = I2(JJ,ISPROC) + 1 + IF ( IMPROC .EQ. ISPROC ) THEN + HGSTGE(GDST,JJ)%NSMX = MAX(HGSTGE(GDST,JJ)%NSMX,TMPINT(ILOC,0)) + END IF + + DO JR=1, TMPINT(ILOC,0) + ISEA = TMPINT(ILOC,JR) + CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, JJ, JSEA, ISPRO2) + IF ( ISPRO2 .EQ. IMPROC ) THEN + HGSTGE(GDST,JJ)%NSND = HGSTGE(GDST,JJ)%NSND + 1 + IF ( TMPLOG(ILOC) ) HGSTGE(GDST,JJ)%NSN1 = & + HGSTGE(GDST,JJ)%NSN1 + 1 + END IF + END DO + ! + END DO - HGSTGE(GDST,:)%NREC = I1(:,IMPROC) - HGSTGE(GDST,:)%NRC1 = I2(:,IMPROC) -! -! 2.d.2 ALLOCATE (DEALLOCATE in section 0 as needed) -! - DO GSRC=1, NRGRD - IF ( HGSTGE(GDST,GSRC)%NREC .GT. 0 ) THEN - ALLOCATE ( & - HGSTGE(GDST,GSRC)%LJSEA (HGSTGE(GDST,GSRC)%NREC), & - HGSTGE(GDST,GSRC)%NRAVG (HGSTGE(GDST,GSRC)%NREC), & - HGSTGE(GDST,GSRC)%IMPSRC(HGSTGE(GDST,GSRC)%NREC, & - HGSTGE(GDST,GSRC)%NSMX), & - HGSTGE(GDST,GSRC)%ITAG (HGSTGE(GDST,GSRC)%NREC, & - HGSTGE(GDST,GSRC)%NSMX), & - HGSTGE(GDST,GSRC)%WGTH (HGSTGE(GDST,GSRC)%NREC, & - HGSTGE(GDST,GSRC)%NSMX), & - HGSTGE(GDST,GSRC)%SHGH (SGRDS(GSRC)%NSPEC, & - HGSTGE(GDST,GSRC)%NSMX, & - HGSTGE(GDST,GSRC)%NREC), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + HGSTGE(GDST,:)%NREC = I1(:,IMPROC) + HGSTGE(GDST,:)%NRC1 = I2(:,IMPROC) + ! + ! 2.d.2 ALLOCATE (DEALLOCATE in section 0 as needed) + ! + DO GSRC=1, NRGRD + IF ( HGSTGE(GDST,GSRC)%NREC .GT. 0 ) THEN + ALLOCATE ( & + HGSTGE(GDST,GSRC)%LJSEA (HGSTGE(GDST,GSRC)%NREC), & + HGSTGE(GDST,GSRC)%NRAVG (HGSTGE(GDST,GSRC)%NREC), & + HGSTGE(GDST,GSRC)%IMPSRC(HGSTGE(GDST,GSRC)%NREC, & + HGSTGE(GDST,GSRC)%NSMX), & + HGSTGE(GDST,GSRC)%ITAG (HGSTGE(GDST,GSRC)%NREC, & + HGSTGE(GDST,GSRC)%NSMX), & + HGSTGE(GDST,GSRC)%WGTH (HGSTGE(GDST,GSRC)%NREC, & + HGSTGE(GDST,GSRC)%NSMX), & + HGSTGE(GDST,GSRC)%SHGH (SGRDS(GSRC)%NSPEC, & + HGSTGE(GDST,GSRC)%NSMX, & + HGSTGE(GDST,GSRC)%NREC), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_T3 - HGSTGE(GDST,GSRC)%LJSEA = -1 - HGSTGE(GDST,GSRC)%NRAVG = -1 - HGSTGE(GDST,GSRC)%IMPSRC = -1 - HGSTGE(GDST,GSRC)%ITAG = -1 - HGSTGE(GDST,GSRC)%WGTH = -1. -#endif - END IF - IF ( HGSTGE(GDST,GSRC)%NSND .GT. 0 ) THEN - ALLOCATE ( HGSTGE(GDST,GSRC)%ISEND (HGSTGE(GDST,GSRC)%NSND,5), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + HGSTGE(GDST,GSRC)%LJSEA = -1 + HGSTGE(GDST,GSRC)%NRAVG = -1 + HGSTGE(GDST,GSRC)%IMPSRC = -1 + HGSTGE(GDST,GSRC)%ITAG = -1 + HGSTGE(GDST,GSRC)%WGTH = -1. +#endif + END IF + IF ( HGSTGE(GDST,GSRC)%NSND .GT. 0 ) THEN + ALLOCATE ( HGSTGE(GDST,GSRC)%ISEND (HGSTGE(GDST,GSRC)%NSND,5), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_T4 - HGSTGE(GDST,GSRC)%ISEND = -1 + HGSTGE(GDST,GSRC)%ISEND = -1 #endif - END IF - HGSTGE(GDST,GSRC)%INIT = .TRUE. - END DO -! -! 2.d.3 Fill allocated arrays -! - FLGREC = .TRUE. - I2 = I1 + 1 - I1 = 0 - I4 = HGSTGE(GDST,:)%NSND + 1 - I3 = 0 - - DO ILOC=1, NRTOT - - ISEA = TMPINT(ILOC,-2) - JJ = TMPINT(ILOC,-1) - NR0 = TMPINT(ILOC, 0) - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + END IF + HGSTGE(GDST,GSRC)%INIT = .TRUE. + END DO + ! + ! 2.d.3 Fill allocated arrays + ! + FLGREC = .TRUE. + I2 = I1 + 1 + I1 = 0 + I4 = HGSTGE(GDST,:)%NSND + 1 + I3 = 0 + + DO ILOC=1, NRTOT + + ISEA = TMPINT(ILOC,-2) + JJ = TMPINT(ILOC,-1) + NR0 = TMPINT(ILOC, 0) + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) #ifdef W3_DIST - ISPROC = ISPROC + CROOT - 1 - FLGREC = ISPROC .EQ. IMPROC -#endif -! - IF ( TMPLOG(ILOC) ) THEN - I1(JJ,ISPROC) = I1(JJ,ISPROC) + 1 - IREC = I1(JJ,ISPROC) - ELSE - I2(JJ,ISPROC) = I2(JJ,ISPROC) - 1 - IREC = I2(JJ,ISPROC) - END IF - - IF ( FLGREC ) THEN - HGSTGE(GDST,JJ)%LJSEA(IREC) = JSEA - HGSTGE(GDST,JJ)%NRAVG(IREC) = NR0 - HGSTGE(GDST,JJ)%WGTH(IREC,:NR0) = TMPRL(ILOC,1:NR0) + ISPROC = ISPROC + CROOT - 1 + FLGREC = ISPROC .EQ. IMPROC +#endif + ! + IF ( TMPLOG(ILOC) ) THEN + I1(JJ,ISPROC) = I1(JJ,ISPROC) + 1 + IREC = I1(JJ,ISPROC) + ELSE + I2(JJ,ISPROC) = I2(JJ,ISPROC) - 1 + IREC = I2(JJ,ISPROC) + END IF + + IF ( FLGREC ) THEN + HGSTGE(GDST,JJ)%LJSEA(IREC) = JSEA + HGSTGE(GDST,JJ)%NRAVG(IREC) = NR0 + HGSTGE(GDST,JJ)%WGTH(IREC,:NR0) = TMPRL(ILOC,1:NR0) #ifdef W3_DIST - HGSTGE(GDST,JJ)%ITAG(IREC,:NR0) = LTAG(:NR0) + HGSTGE(GDST,JJ)%ITAG(IREC,:NR0) = LTAG(:NR0) #endif - END IF + END IF - DO IJ=1, NR0 + DO IJ=1, NR0 - ISEA = TMPINT(ILOC,IJ) - CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, JJ, JSEA, ISPRO2) - IF ( FLGREC ) HGSTGE(GDST,JJ)%IMPSRC(IREC,IJ) = ISPRO2 + ISEA = TMPINT(ILOC,IJ) + CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, JJ, JSEA, ISPRO2) + IF ( FLGREC ) HGSTGE(GDST,JJ)%IMPSRC(IREC,IJ) = ISPRO2 - IF ( ISPRO2 .EQ. IMPROC ) THEN - IF ( TMPLOG(ILOC) ) THEN - I3(JJ) = I3(JJ) + 1 - ISND = I3(JJ) - ELSE - I4(JJ) = I4(JJ) - 1 - ISND = I4(JJ) - END IF - HGSTGE(GDST,JJ)%ISEND(ISND,1) = JSEA + IF ( ISPRO2 .EQ. IMPROC ) THEN + IF ( TMPLOG(ILOC) ) THEN + I3(JJ) = I3(JJ) + 1 + ISND = I3(JJ) + ELSE + I4(JJ) = I4(JJ) - 1 + ISND = I4(JJ) + END IF + HGSTGE(GDST,JJ)%ISEND(ISND,1) = JSEA #ifdef W3_DIST - HGSTGE(GDST,JJ)%ISEND(ISND,2) = ISPROC + HGSTGE(GDST,JJ)%ISEND(ISND,2) = ISPROC #endif - HGSTGE(GDST,JJ)%ISEND(ISND,3) = IREC - HGSTGE(GDST,JJ)%ISEND(ISND,4) = IJ + HGSTGE(GDST,JJ)%ISEND(ISND,3) = IREC + HGSTGE(GDST,JJ)%ISEND(ISND,4) = IJ #ifdef W3_DIST - HGSTGE(GDST,JJ)%ISEND(ISND,5) = LTAG(IJ) + HGSTGE(GDST,JJ)%ISEND(ISND,5) = LTAG(IJ) #endif - END IF + END IF - END DO -! + END DO + ! #ifdef W3_DIST - LTAG = LTAG + NR0 - LTAG0 = LTAG0 + NR0 + LTAG = LTAG + NR0 + LTAG0 = LTAG0 + NR0 #endif -! - END DO -! -! 2.e Adjust FLAGST using MAPTST -! + ! + END DO + ! + ! 2.e Adjust FLAGST using MAPTST + ! #ifdef W3_T - ALLOCATE ( MAPST(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - MAPST = '-' + ALLOCATE ( MAPST(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + MAPST = '-' #endif -! - DO ISEA=1, NSEA - IDST = MAPSF(ISEA,1) - JDST = MAPSF(ISEA,2) - IF ( MAPTST(JDST,IDST) .GT. 0 ) FLAGST(ISEA) = .NOT. FLGHG1 + ! + DO ISEA=1, NSEA + IDST = MAPSF(ISEA,1) + JDST = MAPSF(ISEA,2) + IF ( MAPTST(JDST,IDST) .GT. 0 ) FLAGST(ISEA) = .NOT. FLGHG1 #ifdef W3_T - IF ( FLAGST(ISEA) ) THEN - MAPST(JDST,IDST) = 'O' - ELSE - MAPST(JDST,IDST) = 'X' - END IF + IF ( FLAGST(ISEA) ) THEN + MAPST(JDST,IDST) = 'O' + ELSE + MAPST(JDST,IDST) = 'X' + END IF #endif - END DO -! -! 2.f Test output map -! + END DO + ! + ! 2.f Test output map + ! #ifdef W3_T - WRITE (MDST,9025) 'MAPTST' - DO JDST=NY,1 , -1 - WRITE (MDST,9026) MAPTST(JDST,:) + 88*INFLND(JDST,:) - END DO + WRITE (MDST,9025) 'MAPTST' + DO JDST=NY,1 , -1 + WRITE (MDST,9026) MAPTST(JDST,:) + 88*INFLND(JDST,:) + END DO #endif -! + ! #ifdef W3_T - WRITE (MDST,9025) 'MAPSTA' - DO JDST=NY,1 , -1 - WRITE (MDST,9026) MAPSTA(JDST,:) - END DO + WRITE (MDST,9025) 'MAPSTA' + DO JDST=NY,1 , -1 + WRITE (MDST,9026) MAPSTA(JDST,:) + END DO #endif -! + ! #ifdef W3_T - WRITE (MDST,9025) 'MAPST2' - DO JDST=NY,1 , -1 - WRITE (MDST,9026) MAPST2(JDST,:) - END DO + WRITE (MDST,9025) 'MAPST2' + DO JDST=NY,1 , -1 + WRITE (MDST,9026) MAPST2(JDST,:) + END DO #endif -! + ! #ifdef W3_T - WRITE (MDST,9025) 'FLAGST' - DO JDST=NY,1 , -1 - WRITE (MDST,9027) MAPST(JDST,:) - END DO + WRITE (MDST,9025) 'FLAGST' + DO JDST=NY,1 , -1 + WRITE (MDST,9027) MAPST(JDST,:) + END DO #endif -! - DEALLOCATE ( MAPTST, INFLND, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + ! + DEALLOCATE ( MAPTST, INFLND, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) #ifdef W3_T - DEALLOCATE ( MAPST, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE ( MAPST, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) #endif -! -! 2.g Test output receiving -! + ! + ! 2.g Test output receiving + ! #ifdef W3_T3 - DO GSRC=1, NRGRD - NR0 = HGSTGE(GDST,GSRC)%NREC - IF ( NR0 .EQ. 0 ) THEN - WRITE (MDST,9030) GSRC - ELSE - WRITE (MDST,9031) GSRC, NR0 - DO IREC=1, NR0 - JSEA = HGSTGE(GDST,GSRC)%LJSEA(IREC) - NRTOT = HGSTGE(GDST,GSRC)%NRAVG(IREC) - IF ( NRTOT .LE. 15 ) THEN - WRITE (MDST,9032) JSEA, NRTOT, & - HGSTGE(GDST,GSRC)%WGTH(IREC,:NRTOT) - ELSE - WRITE (MDST,9032) JSEA, NRTOT, & - HGSTGE(GDST,GSRC)%WGTH(IREC,1:15) - WRITE (MDST,9033) & - HGSTGE(GDST,GSRC)%WGTH(IREC,16:NRTOT) - END IF - WRITE (MDST,9034) & - HGSTGE(GDST,GSRC)%IMPSRC(IREC,1:NRTOT) - WRITE (MDST,9034) & - HGSTGE(GDST,GSRC)%ITAG(IREC,1:NRTOT) - END DO - END IF - END DO -#endif -! -! 2.h Test output sending -! -#ifdef W3_T4 - DO GSRC=1, NRGRD - NR0 = HGSTGE(GDST,GSRC)%NSND - IF ( NR0 .EQ. 0 ) THEN - WRITE (MDST,9040) GSRC - ELSE - WRITE (MDST,9041) GSRC, NR0 - DO ISND=1, NR0 - WRITE (MDST,9042) HGSTGE(GDST,GSRC)%ISEND(ISND,:) - END DO - END IF - END DO + DO GSRC=1, NRGRD + NR0 = HGSTGE(GDST,GSRC)%NREC + IF ( NR0 .EQ. 0 ) THEN + WRITE (MDST,9030) GSRC + ELSE + WRITE (MDST,9031) GSRC, NR0 + DO IREC=1, NR0 + JSEA = HGSTGE(GDST,GSRC)%LJSEA(IREC) + NRTOT = HGSTGE(GDST,GSRC)%NRAVG(IREC) + IF ( NRTOT .LE. 15 ) THEN + WRITE (MDST,9032) JSEA, NRTOT, & + HGSTGE(GDST,GSRC)%WGTH(IREC,:NRTOT) + ELSE + WRITE (MDST,9032) JSEA, NRTOT, & + HGSTGE(GDST,GSRC)%WGTH(IREC,1:15) + WRITE (MDST,9033) & + HGSTGE(GDST,GSRC)%WGTH(IREC,16:NRTOT) + END IF + WRITE (MDST,9034) & + HGSTGE(GDST,GSRC)%IMPSRC(IREC,1:NRTOT) + WRITE (MDST,9034) & + HGSTGE(GDST,GSRC)%ITAG(IREC,1:NRTOT) + END DO + END IF + END DO #endif -! -! 2.i Final clean up -! - DEALLOCATE ( IDSTL, IDSTH, JDSTL, JDSTH, GRIDOK, BDIST, & - TMPINT, TMPRL, TMPLOG, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + ! + ! 2.h Test output sending + ! +#ifdef W3_T4 + DO GSRC=1, NRGRD + NR0 = HGSTGE(GDST,GSRC)%NSND + IF ( NR0 .EQ. 0 ) THEN + WRITE (MDST,9040) GSRC + ELSE + WRITE (MDST,9041) GSRC, NR0 + DO ISND=1, NR0 + WRITE (MDST,9042) HGSTGE(GDST,GSRC)%ISEND(ISND,:) + END DO + END IF + END DO +#endif + ! + ! 2.i Final clean up + ! + DEALLOCATE ( IDSTL, IDSTH, JDSTL, JDSTH, GRIDOK, BDIST, & + TMPINT, TMPRL, TMPLOG, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) - IF (OLD_METHOD) THEN - DEALLOCATE ( BDIST_OM, TMPINT_OM, TMPRL_OM, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END IF + IF (OLD_METHOD) THEN + DEALLOCATE ( BDIST_OM, TMPINT_OM, TMPRL_OM, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF #ifdef W3_DIST - DEALLOCATE ( LTAG, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE ( LTAG, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) #endif -! + ! -! Notes: We are done with this dst (low rank) grid, so we deallocate ALLWGTS . -! This is important because ALLWGTS will be allocated again for the next -! dst grid. + ! Notes: We are done with this dst (low rank) grid, so we deallocate ALLWGTS . + ! This is important because ALLWGTS will be allocated again for the next + ! dst grid. #ifdef W3_SCRIP - DO JJ=1, GRDHGH(GDST,0) - GSRC = GRDHGH(GDST,JJ) - DO KDST=1,DST_GRID_SIZE - DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%W, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%K, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END DO - DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END DO - DEALLOCATE ( ALLWGTS, STAT=ISTAT ) + DO JJ=1, GRDHGH(GDST,0) + GSRC = GRDHGH(GDST,JJ) + DO KDST=1,DST_GRID_SIZE + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%W, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%K, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END DO + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END DO + DEALLOCATE ( ALLWGTS, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) #endif - END IF ! IF ( GRDHGH(GDST,0) ... + END IF ! IF ( GRDHGH(GDST,0) ... #ifdef W3_T38 - CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) - ELAPSED_TIME = END_TIME - BEG_TIME(2) - WRITE(NMYOUT,*) "WMGHGH, LOOP LOWRANK_GRID, GDST= ", GDST, " TOOK ", ELAPSED_TIME, " MSEC" + CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = END_TIME - BEG_TIME(2) + WRITE(NMYOUT,*) "WMGHGH, LOOP LOWRANK_GRID, GDST= ", GDST, " TOOK ", ELAPSED_TIME, " MSEC" #endif - END DO LOWRANK_GRID + END DO LOWRANK_GRID -! If SCRIPNC and L_STOP, then we are done - IF ( LSCRIPNC .AND. L_STOP ) THEN - ! WW3 processes wait here till all have finished + ! If SCRIPNC and L_STOP, then we are done + IF ( LSCRIPNC .AND. L_STOP ) THEN + ! WW3 processes wait here till all have finished #ifdef W3_MPI - CALL MPI_BARRIER( MPI_COMM_MWAVE, IERR_MPI ) + CALL MPI_BARRIER( MPI_COMM_MWAVE, IERR_MPI ) #endif - ! This is not a true error, so exit code is zero - WRITE( MDSE, '(A,I4.4,A)' ) 'IMPROC=',IMPROC, & - ': STOP_SCRIP option invoked: '// & - 'non-error exit after writing remap netcdf files' - CALL EXTCDE( 0 ) - END IF + ! This is not a true error, so exit code is zero + WRITE( MDSE, '(A,I4.4,A)' ) 'IMPROC=',IMPROC, & + ': STOP_SCRIP option invoked: '// & + 'non-error exit after writing remap netcdf files' + CALL EXTCDE( 0 ) + END IF - DEALLOCATE ( I1, I2, I3, I4, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE ( I1, I2, I3, I4, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) #ifdef W3_MPIBDI - DEALLOCATE ( NX_SIZE, IRQ, MSTAT, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE ( NX_SIZE, IRQ, MSTAT, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) #endif - DEALLOCATE ( NX_BEG, NX_END, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE ( NX_BEG, NX_END, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) -! -! 2.j Test output counters -! + ! + ! 2.j Test output counters + ! #ifdef W3_T - WRITE (MDST,9028) 'NTOT' - DO JJ=1, NRGRD - WRITE (MDST,9029) HGSTGE(JJ,:)%NTOT - END DO + WRITE (MDST,9028) 'NTOT' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NTOT + END DO #endif -! + ! #ifdef W3_T - WRITE (MDST,9028) 'NREC' - DO JJ=1, NRGRD - WRITE (MDST,9029) HGSTGE(JJ,:)%NREC - END DO + WRITE (MDST,9028) 'NREC' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NREC + END DO #endif -! + ! #ifdef W3_T - WRITE (MDST,9028) 'NRC1' - DO JJ=1, NRGRD - WRITE (MDST,9029) HGSTGE(JJ,:)%NRC1 - END DO + WRITE (MDST,9028) 'NRC1' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NRC1 + END DO #endif -! + ! #ifdef W3_T - WRITE (MDST,9028) 'NSND' - DO JJ=1, NRGRD - WRITE (MDST,9029) HGSTGE(JJ,:)%NSND - END DO + WRITE (MDST,9028) 'NSND' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NSND + END DO #endif -! + ! #ifdef W3_T - WRITE (MDST,9028) 'NSN1' - DO JJ=1, NRGRD - WRITE (MDST,9029) HGSTGE(JJ,:)%NSN1 - END DO + WRITE (MDST,9028) 'NSN1' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NSN1 + END DO #endif -! + ! #ifdef W3_T - WRITE (MDST,9028) 'NSMX' - DO JJ=1, NRGRD - WRITE (MDST,9029) HGSTGE(JJ,:)%NSMX - END DO + WRITE (MDST,9028) 'NSMX' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NSMX + END DO #endif -! + ! #ifdef W3_T38 - CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) - ELAPSED_TIME = END_TIME - BEG_TIME(1) - WRITE(NMYOUT,*) "WMGHGH, ALL TOOK ", ELAPSED_TIME, " MSEC" -#endif - - RETURN -! -! Formats -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMGHGH : *** '/ & - ' GRDHGH NOT YET ALLOCATED, CALL WMGLOW FIRST'/) - 1020 FORMAT (/' *** WAVEWATCH III ERROR IN WMGHGH : *** '/ & - ' TMPINT AND TMPRL TOO SMALL (w/out SCRIP)'/) + CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = END_TIME - BEG_TIME(1) + WRITE(NMYOUT,*) "WMGHGH, ALL TOOK ", ELAPSED_TIME, " MSEC" +#endif + + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMGHGH : *** '/ & + ' GRDHGH NOT YET ALLOCATED, CALL WMGLOW FIRST'/) +1020 FORMAT (/' *** WAVEWATCH III ERROR IN WMGHGH : *** '/ & + ' TMPINT AND TMPRL TOO SMALL (w/out SCRIP)'/) #ifdef W3_SCRIP - 1021 FORMAT (/' *** WAVEWATCH III ERROR IN WMGHGH : *** '/ & - ' TMPINT AND TMPRL TOO SMALL (w/SCRIP) '/) +1021 FORMAT (/' *** WAVEWATCH III ERROR IN WMGHGH : *** '/ & + ' TMPINT AND TMPRL TOO SMALL (w/SCRIP) '/) #endif -! + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMGHGH : INITIALIZE BOUNDARY DISTANCE MAPS') - 9011 FORMAT ( ' GRID = ',I3,' RANK = ',I3, & - ' NBI = ',I6) - 9012 FORMAT ( ' *** MAP NOT NEEDED ***') - 9013 FORMAT ( ' TEST WMGHGH : FINAL MAP ') - 9014 FORMAT (2x,65I2) -#endif -!/ +9010 FORMAT ( ' TEST WMGHGH : INITIALIZE BOUNDARY DISTANCE MAPS') +9011 FORMAT ( ' GRID = ',I3,' RANK = ',I3, & + ' NBI = ',I6) +9012 FORMAT ( ' *** MAP NOT NEEDED ***') +9013 FORMAT ( ' TEST WMGHGH : FINAL MAP ') +9014 FORMAT (2x,65I2) +#endif + !/ #ifdef W3_T - 9020 FORMAT ( ' TEST WMGHGH : GRID',I3,' HAS',I3,' DATA SOURCES') - 9021 FORMAT ( ' NO PROCESSING REQUIRED') - 9022 FORMAT ( ' TEST WMGHGH : GRID',I3,' COVERS ',4I8) - 9023 FORMAT ( ' TEST WMGHGH : GRID',I3, & - ', NR OF POINTS TO PROCESS:',I5) - 9025 FORMAT ( ' TEST WMGHGH : FINAL ',A) - 9026 FORMAT (2X,65I2) - 9027 FORMAT (2X,65A2) -#endif -! +9020 FORMAT ( ' TEST WMGHGH : GRID',I3,' HAS',I3,' DATA SOURCES') +9021 FORMAT ( ' NO PROCESSING REQUIRED') +9022 FORMAT ( ' TEST WMGHGH : GRID',I3,' COVERS ',4I8) +9023 FORMAT ( ' TEST WMGHGH : GRID',I3, & + ', NR OF POINTS TO PROCESS:',I5) +9025 FORMAT ( ' TEST WMGHGH : FINAL ',A) +9026 FORMAT (2X,65I2) +9027 FORMAT (2X,65A2) +#endif + ! #ifdef W3_T - 9028 FORMAT ( ' TEST WMGHGH : COUNTERS ',A) - 9029 FORMAT (2x,20I6) +9028 FORMAT ( ' TEST WMGHGH : COUNTERS ',A) +9029 FORMAT (2x,20I6) #endif -! + ! #ifdef W3_T3 - 9030 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', NO DATA TO RECEIVE') - 9031 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', RECEIVING ',I6) - 9032 FORMAT ( 2X,I10,I6,15F6.2) - 9033 FORMAT ( 18X,15F6.2) - 9034 FORMAT ( 18X,15I6) +9030 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', NO DATA TO RECEIVE') +9031 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', RECEIVING ',I6) +9032 FORMAT ( 2X,I10,I6,15F6.2) +9033 FORMAT ( 18X,15F6.2) +9034 FORMAT ( 18X,15I6) #endif -! + ! #ifdef W3_T4 - 9040 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', NO DATA TO SEND') - 9041 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', SENDING ',I6) - 9042 FORMAT ( 12X,I10,4I6) -#endif -!/ -!/ End of WMGHGH ----------------------------------------------------- / -!/ - END SUBROUTINE WMGHGH -!/ ------------------------------------------------------------------- / -!> -!> @brief Determine relations to same ranked grids for each grid. -!> -!> @details Cross mapping of grid points, determine boundary distance -!> data and interpolation weights. -!> -!> @author H. L. Tolman @date 10-Dec-2014 -!> - SUBROUTINE WMGEQL -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 24-Apr-2006 : Origination. ( version 3.09 ) -!/ 23-Dec-2006 : Adding group test. ( version 3.10 ) -!/ 28-Dec-2006 : Simplify NIT for partial comm. ( version 3.10 ) -!/ 22-Jan-2007 : Add saving og NAVMAX. ( version 3.10 ) -!/ 02-Feb-2007 : Setting FLAGST for replaced points. ( version 3.10 ) -!/ 15-Feb-2007 : Tweaking MAPODI algorithm in WMGEQL.( version 3.10 ) -!/ 11-Apr-2008 : Big fix active edges (MAPSTA=2) ( version 3.13 ) -!/ 14-Apr-2008 : Big fix for global grids. ( version 3.13 ) -!/ 20-May-2009 : Linking FLAGST and FLGHG1. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) -!/ factor with DXDP and DXDQ terms. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 05-Aug-2013 : Change PR2/3 to UQ/UNO in distances.( version 4.12 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 28-Oct-2020 : Add SMCTYPE for SMC sub-grid. JGLi ( version 6.xx ) -!/ -! 1. Purpose : -! -! Determine relations to same ranked grids for each grid. -! -! 2. Method : -! -! Cross mapping of grid points, determine boundary distance data -! and interpolation weights. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG, W3SETO, WMSETM -! Subr. W3GDATMD Manage data structures. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! - In looking for compatable boundary points in overlapping grids -! two assumptions hav been made. -! a) No active boundary points exist in global grids. -! b) For a lower resolution grid an expanded sewarch area is -! required for corresponding active grid points. By limiting -! the resolution ratio to 2, only one extra grid point needs -! to be considered (JXL2 versus JXL etc.). -! -! 8. Structure : -! -! 9. Switches : -! -! !/PRn Propagation scheme. -! -! !/O12 Removed boundary points output (central). -! !/O13 Removed boundary points output (edge). - -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T5 Detailed test output 'receiving'. -! !/T6 Detailed test output 'sending'. -! !/T7 Detailed test output all. -! -! !/MPI Distribbuted memory management. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE CONSTANTS - USE W3GDATMD - USE W3ODATMD - USE W3ADATMD - USE WMMDATMD -! - USE W3SERVMD, ONLY: EXTCDE -! USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC_GLOB +9040 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', NO DATA TO SEND') +9041 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', SENDING ',I6) +9042 FORMAT ( 12X,I10,4I6) +#endif + !/ + !/ End of WMGHGH ----------------------------------------------------- / + !/ + END SUBROUTINE WMGHGH + !/ ------------------------------------------------------------------- / + !> + !> @brief Determine relations to same ranked grids for each grid. + !> + !> @details Cross mapping of grid points, determine boundary distance + !> data and interpolation weights. + !> + !> @author H. L. Tolman @date 10-Dec-2014 + !> + SUBROUTINE WMGEQL + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 24-Apr-2006 : Origination. ( version 3.09 ) + !/ 23-Dec-2006 : Adding group test. ( version 3.10 ) + !/ 28-Dec-2006 : Simplify NIT for partial comm. ( version 3.10 ) + !/ 22-Jan-2007 : Add saving og NAVMAX. ( version 3.10 ) + !/ 02-Feb-2007 : Setting FLAGST for replaced points. ( version 3.10 ) + !/ 15-Feb-2007 : Tweaking MAPODI algorithm in WMGEQL.( version 3.10 ) + !/ 11-Apr-2008 : Big fix active edges (MAPSTA=2) ( version 3.13 ) + !/ 14-Apr-2008 : Big fix for global grids. ( version 3.13 ) + !/ 20-May-2009 : Linking FLAGST and FLGHG1. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) + !/ factor with DXDP and DXDQ terms. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 05-Aug-2013 : Change PR2/3 to UQ/UNO in distances.( version 4.12 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 28-Oct-2020 : Add SMCTYPE for SMC sub-grid. JGLi ( version 6.xx ) + !/ + ! 1. Purpose : + ! + ! Determine relations to same ranked grids for each grid. + ! + ! 2. Method : + ! + ! Cross mapping of grid points, determine boundary distance data + ! and interpolation weights. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG, W3SETO, WMSETM + ! Subr. W3GDATMD Manage data structures. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - In looking for compatable boundary points in overlapping grids + ! two assumptions hav been made. + ! a) No active boundary points exist in global grids. + ! b) For a lower resolution grid an expanded sewarch area is + ! required for corresponding active grid points. By limiting + ! the resolution ratio to 2, only one extra grid point needs + ! to be considered (JXL2 versus JXL etc.). + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/PRn Propagation scheme. + ! + ! !/O12 Removed boundary points output (central). + ! !/O13 Removed boundary points output (edge). + + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/T5 Detailed test output 'receiving'. + ! !/T6 Detailed test output 'sending'. + ! !/T7 Detailed test output all. + ! + ! !/MPI Distribbuted memory management. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE CONSTANTS + USE W3GDATMD + USE W3ODATMD + USE W3ADATMD + USE WMMDATMD + ! + USE W3SERVMD, ONLY: EXTCDE + ! USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC_GLOB #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, J, IX, IXL, IXH, IY, IYL, IYH, & - JX, JXL, JXH, JXL2, JXH2, & - JY, JYL, JYH, JYL2, JYH2, & - NR, NT, NA, NTL, JJ, NIT, NG, NOUT, & - ISEA, JSEA, ISPROC, ITAG, TGRP, & - EXTRA, IP, NP + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, J, IX, IXL, IXH, IY, IYL, IYH, & + JX, JXL, JXH, JXL2, JXH2, & + JY, JYL, JYH, JYL2, JYH2, & + NR, NT, NA, NTL, JJ, NIT, NG, NOUT, & + ISEA, JSEA, ISPROC, ITAG, TGRP, & + EXTRA, IP, NP #ifdef W3_T7 - INTEGER :: IA + INTEGER :: IA #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER, ALLOCATABLE :: MAP3D(:,:,:), NREC(:), NSND(:), & - NTPP(:), MAPOUT(:,:) - REAL :: FACTOR, XSL, XSH, YSL, YSH, XA, YA, & - XR, YR, RX(2), RY(2), STX, STY, & - STXY, NEWVAL, WGTH - REAL, PARAMETER :: TODO = -9.99E25 - REAL, PARAMETER :: ODIMAX = 25. - REAL, PARAMETER :: FACMAX = 2.001 - REAL, ALLOCATABLE :: WGT3D(:,:,:) - LOGICAL :: CHANGE, XEXPND, YEXPND - LOGICAL, ALLOCATABLE :: SHRANK(:,:), DOGRID(:), & - MASKA(:,:), MASKI(:,:) + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER, ALLOCATABLE :: MAP3D(:,:,:), NREC(:), NSND(:), & + NTPP(:), MAPOUT(:,:) + REAL :: FACTOR, XSL, XSH, YSL, YSH, XA, YA, & + XR, YR, RX(2), RY(2), STX, STY, & + STXY, NEWVAL, WGTH + REAL, PARAMETER :: TODO = -9.99E25 + REAL, PARAMETER :: ODIMAX = 25. + REAL, PARAMETER :: FACMAX = 2.001 + REAL, ALLOCATABLE :: WGT3D(:,:,:) + LOGICAL :: CHANGE, XEXPND, YEXPND + LOGICAL, ALLOCATABLE :: SHRANK(:,:), DOGRID(:), & + MASKA(:,:), MASKI(:,:) #ifdef W3_T5 - CHARACTER(LEN=18), ALLOCATABLE :: TSTR(:) - CHARACTER(LEN=18) :: DSTR -#endif -! - TYPE STORE - INTEGER :: NTOT, NFIN - INTEGER, POINTER :: IX(:), IY(:), NAV(:), ISS(:,:), & - JSS(:,:), IPS(:,:), ITG(:,:) - REAL, POINTER :: AWG(:,:) - LOGICAL, POINTER :: FLA(:) - LOGICAL :: INIT - END TYPE STORE -! - TYPE(STORE), ALLOCATABLE :: STORES(:,:) -!/ + CHARACTER(LEN=18), ALLOCATABLE :: TSTR(:) + CHARACTER(LEN=18) :: DSTR +#endif + ! + TYPE STORE + INTEGER :: NTOT, NFIN + INTEGER, POINTER :: IX(:), IY(:), NAV(:), ISS(:,:), & + JSS(:,:), IPS(:,:), ITG(:,:) + REAL, POINTER :: AWG(:,:) + LOGICAL, POINTER :: FLA(:) + LOGICAL :: INIT + END TYPE STORE + ! + TYPE(STORE), ALLOCATABLE :: STORES(:,:) + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMGEQL') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! - - ALLOCATE ( SHRANK(NRGRD,NRGRD), STORES(NRGRD,NRGRD), & - DOGRID(NRGRD), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - SHRANK = .FALSE. -! - DO I=1, NRGRD - - DO J=1, NRGRD - STORES(I,J)%INIT = .FALSE. - STORES(I,J)%NTOT = 0 - STORES(I,J)%NFIN = 0 - END DO - END DO -! - IF ( FLAGLL ) THEN - FACTOR = RADIUS * DERA -!notes: was FACTOR = RADIUS / 360. (I don't know where this came from.... -! ...maybe it was supposed to be CIRCUMFERENCE/360) - ELSE - FACTOR = 1. - END IF - ITAG = 0 -! + CALL STRACE (IENT, 'WMGEQL') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! + + ALLOCATE ( SHRANK(NRGRD,NRGRD), STORES(NRGRD,NRGRD), & + DOGRID(NRGRD), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + SHRANK = .FALSE. + ! + DO I=1, NRGRD + + DO J=1, NRGRD + STORES(I,J)%INIT = .FALSE. + STORES(I,J)%NTOT = 0 + STORES(I,J)%NFIN = 0 + END DO + END DO + ! + IF ( FLAGLL ) THEN + FACTOR = RADIUS * DERA + !notes: was FACTOR = RADIUS / 360. (I don't know where this came from.... + ! ...maybe it was supposed to be CIRCUMFERENCE/360) + ELSE + FACTOR = 1. + END IF + ITAG = 0 + ! #ifdef W3_SMC - !! Check GTYPE for all grids. - IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " WMGEQL GTYPE:", & - ( GRIDS(I)%GTYPE, I=1, NRGRD ) -#endif -! -! -------------------------------------------------------------------- / -! 1. Grid point relations and temp data storage -! 1.a Outer loop over all grids -! + !! Check GTYPE for all grids. + IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " WMGEQL GTYPE:", & + ( GRIDS(I)%GTYPE, I=1, NRGRD ) +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Grid point relations and temp data storage + ! 1.a Outer loop over all grids + ! #ifdef W3_T - WRITE (MDST,9010) + WRITE (MDST,9010) #endif -! - DO I=1, NRGRD + ! + DO I=1, NRGRD #ifdef W3_T - WRITE (MDST,9011) I, GRANK(I) + WRITE (MDST,9011) I, GRANK(I) #endif -! -! 1.b Find grids with same rank -! - NR = 0 -! + ! + ! 1.b Find grids with same rank + ! + NR = 0 + ! #ifdef W3_SMC - !! SMC grids use WMSMCEQL for equal ranked grids. JGLi23Mar2021 - IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) CYCLE + !! SMC grids use WMSMCEQL for equal ranked grids. JGLi23Mar2021 + IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) CYCLE #endif -! - DO J=1, NRGRD + ! + DO J=1, NRGRD - IF ( GRANK(I).NE.GRANK(J) .OR. I.EQ.J ) CYCLE -! + IF ( GRANK(I).NE.GRANK(J) .OR. I.EQ.J ) CYCLE + ! #ifdef W3_SMC IF( GRIDS(J)%GTYPE .EQ. SMCTYPE ) CYCLE #endif -! + ! #ifdef W3_T - WRITE (MDST,9012) J + WRITE (MDST,9012) J #endif - SHRANK(I,J) = .TRUE. - NR = NR + 1 - END DO -! - CALL W3SETG ( I, MDSE, MDST ) -! - DOGRID(I) = NR .GT. 0 + SHRANK(I,J) = .TRUE. + NR = NR + 1 + END DO + ! + CALL W3SETG ( I, MDSE, MDST ) + ! + DOGRID(I) = NR .GT. 0 -!..notes: we will reach this point even if there are no equal rank grids + !..notes: we will reach this point even if there are no equal rank grids #ifdef W3_T - IF ( NR .EQ. 0 ) WRITE (MDST,9013) 'NO GRIDS WITH SAME RANK' + IF ( NR .EQ. 0 ) WRITE (MDST,9013) 'NO GRIDS WITH SAME RANK' #endif - IF ( NR .EQ. 0 ) CYCLE - -!..notes: we will not reach this point if are no equal rank grids. that makes it a good place to check against grid type - - IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN - IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,*)'SUBROUTINE WMGEQL IS'// & - ' NOT YET ADAPTED FOR TRIPOLE GRIDS. STOPPING NOW.' - CALL EXTCDE ( 1 ) - END IF + IF ( NR .EQ. 0 ) CYCLE -! Unresolved bug: this triggers even for 2 irregular grids that are not overlapping! -! We should only be checking for cases of 2 irregular grids of equal rank that -! are overlapping. Unfortunately, at this point in the routine, we don't know -! whether they are overlapping...requires more code to do this, since all code -! in this routine is for regular grids. Fortunately, there is really no -! disadvantage to making the two irregular grids to be different rank using -! ww3_multi.inp - - IF ( GTYPE .EQ. UNGTYPE ) THEN - IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/3A)') ' *** ERROR ', & - 'WMGEQL: UNSTRUCTURED GRID SUPPORT NOT YET ', & - 'IMPLEMENTED ***' - CALL EXTCDE ( 999 ) - END IF - IF ( GTYPE .EQ. CLGTYPE ) THEN - IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/3A)') ' *** ERROR ', & - 'WMGEQL: CURVILINEAR GRID SUPPORT NOT IMPLEMENTED ', & - 'FOR NRGRD > 1 ***' - CALL EXTCDE ( 999 ) - END IF + !..notes: we will not reach this point if are no equal rank grids. that makes it a good place to check against grid type -! -! 1.c Fill TMPMAP with raw relational data -! -! 1.c.1 Loop over grids, select same rank -! - DO J=1, NRGRD + IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN + IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,*)'SUBROUTINE WMGEQL IS'// & + ' NOT YET ADAPTED FOR TRIPOLE GRIDS. STOPPING NOW.' + CALL EXTCDE ( 1 ) + END IF - IF ( .NOT. SHRANK(I,J) ) CYCLE -! -! 1.c.2 Determine shared area -! Don't even try for X in LLG -! + ! Unresolved bug: this triggers even for 2 irregular grids that are not overlapping! + ! We should only be checking for cases of 2 irregular grids of equal rank that + ! are overlapping. Unfortunately, at this point in the routine, we don't know + ! whether they are overlapping...requires more code to do this, since all code + ! in this routine is for regular grids. Fortunately, there is really no + ! disadvantage to making the two irregular grids to be different rank using + ! ww3_multi.inp + + IF ( GTYPE .EQ. UNGTYPE ) THEN + IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/3A)') ' *** ERROR ', & + 'WMGEQL: UNSTRUCTURED GRID SUPPORT NOT YET ', & + 'IMPLEMENTED ***' + CALL EXTCDE ( 999 ) + END IF + IF ( GTYPE .EQ. CLGTYPE ) THEN + IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/3A)') ' *** ERROR ', & + 'WMGEQL: CURVILINEAR GRID SUPPORT NOT IMPLEMENTED ', & + 'FOR NRGRD > 1 ***' + CALL EXTCDE ( 999 ) + END IF -! Note: Check is against FLAGLL. Would it be more appropriate -! to check against ICLOSE? + ! + ! 1.c Fill TMPMAP with raw relational data + ! + ! 1.c.1 Loop over grids, select same rank + ! + DO J=1, NRGRD + + IF ( .NOT. SHRANK(I,J) ) CYCLE + ! + ! 1.c.2 Determine shared area + ! Don't even try for X in LLG + ! + + ! Note: Check is against FLAGLL. Would it be more appropriate + ! to check against ICLOSE? + IF ( FLAGLL ) THEN + IXL = 1 + IXH = NX + ELSE + XSL = ( GRIDS(J)%X0 - X0 ) / SX - 0.01 + XSH = ( GRIDS(J)%X0 + GRIDS(J)%SX*(GRIDS(J)%NX-1) & + - X0 ) / SX + 0.01 + IXL = MAX ( 1+NINT(XSL) , 1 ) + IXH = MIN ( 1+NINT(XSH) , NX ) + END IF + ! + YSL = ( GRIDS(J)%Y0 - Y0 ) / SY - 0.01 + YSH = ( GRIDS(J)%Y0 + GRIDS(J)%SY*(GRIDS(J)%NY-1) & + - Y0 ) / SY + 0.01 + IYL = MAX ( 1+NINT(YSL) , 1 ) + IYH = MIN ( 1+NINT(YSH) , NY ) + ! + NT = (1+IXH-IXL) * (1+IYH-IYL) + IF ( NT .EQ. 0 ) CYCLE + ! + STORES(I,J)%INIT = .TRUE. + ALLOCATE ( STORES(I,J)%IX(NT) , STORES(I,J)%IY(NT) , & + STORES(I,J)%NAV(NT) , STORES(I,J)%FLA(NT) , & + STORES(I,J)%ISS(NT,4), STORES(I,J)%JSS(NT,4), & + STORES(I,J)%IPS(NT,4), STORES(I,J)%ITG(NT,4), & + STORES(I,J)%AWG(NT,4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + STORES(I,J)%NAV = 0 + STORES(I,J)%FLA = .FALSE. + STORES(I,J)%ISS = 0 + STORES(I,J)%JSS = 0 + STORES(I,J)%IPS = 0 + STORES(I,J)%ITG = 0 + STORES(I,J)%AWG = 0. + ! + ! 1.c.3 Loops over shared area + ! + NT = 0 + ! + XEXPND = SX .GT. GRIDS(J)%SX + YEXPND = SY .GT. GRIDS(J)%SY + ! + DO IX=IXL, IXH + XA = X0 + REAL(IX-1)*SX IF ( FLAGLL ) THEN - IXL = 1 - IXH = NX + XR = 1. + MOD (1080. + XA - GRIDS(J)%X0 , 360. ) & + / GRIDS(J)%SX + ELSE + XR = 1. + (XA-GRIDS(J)%X0) / GRIDS(J)%SX + END IF + JXL = INT(XR) + JXH = JXL + 1 + RX(1) = 1. - MOD(XR,1.) + IF ( RX(1).GT.0.99 .OR. JXH.EQ.GRIDS(J)%NX+1 ) THEN + JXH = JXL + RX(1) = 1. + END IF + IF ( RX(1).LT.0.01 .OR. JXL.EQ.0 ) THEN + JXL = JXH + RX(1) = 1. + END IF + RX(2) = 1. - RX(1) + ! + IF ( JXL.LT.1 .OR. JXH.GT.GRIDS(J)%NX ) CYCLE + ! + IF ( XEXPND ) THEN + JXL2 = MAX ( 1 , JXL-1 ) + JXH2 = MIN ( GRIDS(J)%NX , JXH+1 ) + ELSE + JXL2 = JXL + JXH2 = JXH + END IF + ! + DO IY=IYL, IYH + YA = Y0 + REAL(IY-1)*SY + YR = 1. + (YA-GRIDS(J)%Y0) / GRIDS(J)%SY + JYL = INT(YR) + JYH = JYL + 1 + RY(1) = 1. - MOD(YR,1.) + IF ( RY(1).GT.0.99 .OR. JYH.EQ.GRIDS(J)%NY+1 ) THEN + JYH = JYL + RY(1) = 1. + END IF + IF ( RY(1).LT.0.01 .OR. JYL.EQ.0 ) THEN + JYL = JYH + RY(1) = 1. + END IF + IF ( RY(1) .GT. 0.99 ) JYH = JYL + RY(2) = 1. - RY(1) + ! + IF ( JYL.LT.1 .OR. JYH.GT.GRIDS(J)%NY ) CYCLE + ! + IF ( YEXPND ) THEN + JYL2 = MAX ( 1 , JYL-1 ) + JYH2 = MIN ( GRIDS(J)%NY , JYH+1 ) ELSE - XSL = ( GRIDS(J)%X0 - X0 ) / SX - 0.01 - XSH = ( GRIDS(J)%X0 + GRIDS(J)%SX*(GRIDS(J)%NX-1) & - - X0 ) / SX + 0.01 - IXL = MAX ( 1+NINT(XSL) , 1 ) - IXH = MIN ( 1+NINT(XSH) , NX ) + JYL2 = JYL + JYH2 = JYH END IF -! - YSL = ( GRIDS(J)%Y0 - Y0 ) / SY - 0.01 - YSH = ( GRIDS(J)%Y0 + GRIDS(J)%SY*(GRIDS(J)%NY-1) & - - Y0 ) / SY + 0.01 - IYL = MAX ( 1+NINT(YSL) , 1 ) - IYH = MIN ( 1+NINT(YSH) , NY ) -! - NT = (1+IXH-IXL) * (1+IYH-IYL) - IF ( NT .EQ. 0 ) CYCLE -! - STORES(I,J)%INIT = .TRUE. - ALLOCATE ( STORES(I,J)%IX(NT) , STORES(I,J)%IY(NT) , & - STORES(I,J)%NAV(NT) , STORES(I,J)%FLA(NT) , & - STORES(I,J)%ISS(NT,4), STORES(I,J)%JSS(NT,4), & - STORES(I,J)%IPS(NT,4), STORES(I,J)%ITG(NT,4), & - STORES(I,J)%AWG(NT,4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - STORES(I,J)%NAV = 0 - STORES(I,J)%FLA = .FALSE. - STORES(I,J)%ISS = 0 - STORES(I,J)%JSS = 0 - STORES(I,J)%IPS = 0 - STORES(I,J)%ITG = 0 - STORES(I,J)%AWG = 0. -! -! 1.c.3 Loops over shared area -! - NT = 0 -! - XEXPND = SX .GT. GRIDS(J)%SX - YEXPND = SY .GT. GRIDS(J)%SY -! - DO IX=IXL, IXH - XA = X0 + REAL(IX-1)*SX - IF ( FLAGLL ) THEN - XR = 1. + MOD (1080. + XA - GRIDS(J)%X0 , 360. ) & - / GRIDS(J)%SX - ELSE - XR = 1. + (XA-GRIDS(J)%X0) / GRIDS(J)%SX - END IF - JXL = INT(XR) - JXH = JXL + 1 - RX(1) = 1. - MOD(XR,1.) - IF ( RX(1).GT.0.99 .OR. JXH.EQ.GRIDS(J)%NX+1 ) THEN - JXH = JXL - RX(1) = 1. - END IF - IF ( RX(1).LT.0.01 .OR. JXL.EQ.0 ) THEN - JXL = JXH - RX(1) = 1. - END IF - RX(2) = 1. - RX(1) -! - IF ( JXL.LT.1 .OR. JXH.GT.GRIDS(J)%NX ) CYCLE -! - IF ( XEXPND ) THEN - JXL2 = MAX ( 1 , JXL-1 ) - JXH2 = MIN ( GRIDS(J)%NX , JXH+1 ) - ELSE - JXL2 = JXL - JXH2 = JXH - END IF -! - DO IY=IYL, IYH - YA = Y0 + REAL(IY-1)*SY - YR = 1. + (YA-GRIDS(J)%Y0) / GRIDS(J)%SY - JYL = INT(YR) - JYH = JYL + 1 - RY(1) = 1. - MOD(YR,1.) - IF ( RY(1).GT.0.99 .OR. JYH.EQ.GRIDS(J)%NY+1 ) THEN - JYH = JYL - RY(1) = 1. - END IF - IF ( RY(1).LT.0.01 .OR. JYL.EQ.0 ) THEN - JYL = JYH - RY(1) = 1. - END IF - IF ( RY(1) .GT. 0.99 ) JYH = JYL - RY(2) = 1. - RY(1) -! - IF ( JYL.LT.1 .OR. JYH.GT.GRIDS(J)%NY ) CYCLE -! - IF ( YEXPND ) THEN - JYL2 = MAX ( 1 , JYL-1 ) - JYH2 = MIN ( GRIDS(J)%NY , JYH+1 ) - ELSE - JYL2 = JYL - JYH2 = JYH - END IF -! -! 1.c.4 Temp storage of raw data -! - NT = NT + 1 - NA = 0 + ! + ! 1.c.4 Temp storage of raw data + ! + NT = NT + 1 + NA = 0 #ifdef W3_SHRD - ISPROC = 1 -#endif - STORES(I,J)%IX(NT) = IX - STORES(I,J)%IY(NT) = IY -! - DO JX = JXL, JXH - DO JY = JYL, JYH - IF ( GRIDS(J)%MAPSTA(JY,JX) .NE. 0 ) THEN - NA = NA + 1 - ITAG = ITAG + 1 - WGTH = RX(1+JX-JXL) * RY(1+JY-JYL) - ISEA = GRIDS(J)%MAPFS(JY,JX) - IF ( ISEA .EQ. 0 ) THEN - JSEA = 0 + ISPROC = 1 +#endif + STORES(I,J)%IX(NT) = IX + STORES(I,J)%IY(NT) = IY + ! + DO JX = JXL, JXH + DO JY = JYL, JYH + IF ( GRIDS(J)%MAPSTA(JY,JX) .NE. 0 ) THEN + NA = NA + 1 + ITAG = ITAG + 1 + WGTH = RX(1+JX-JXL) * RY(1+JY-JYL) + ISEA = GRIDS(J)%MAPFS(JY,JX) + IF ( ISEA .EQ. 0 ) THEN + JSEA = 0 #ifdef W3_MPI - ISPROC = 1 -#endif - ELSE - CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) - END IF - STORES(I,J)%AWG(NT,NA) = WGTH - STORES(I,J)%ISS(NT,NA) = ISEA - STORES(I,J)%JSS(NT,NA) = JSEA - STORES(I,J)%IPS(NT,NA) = ISPROC - STORES(I,J)%ITG(NT,NA) = ITAG - END IF - END DO - END DO -! - DO JX = JXL2, JXH2 - DO JY = JYL2, JYH2 - IF ( ABS(GRIDS(J)%MAPSTA(JY,JX)) .EQ. 2 ) & - STORES(I,J)%FLA(NT) = .TRUE. - END DO - END DO -! - WGTH = SUM ( STORES(I,J)%AWG(NT,1:NA) ) - IF ( WGTH .LT. 0.499 ) THEN - NA = 0 - ELSE - STORES(I,J)%AWG(NT,:) = STORES(I,J)%AWG(NT,:) / WGTH + ISPROC = 1 +#endif + ELSE + CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) + END IF + STORES(I,J)%AWG(NT,NA) = WGTH + STORES(I,J)%ISS(NT,NA) = ISEA + STORES(I,J)%JSS(NT,NA) = JSEA + STORES(I,J)%IPS(NT,NA) = ISPROC + STORES(I,J)%ITG(NT,NA) = ITAG END IF -! - STORES(I,J)%NAV(NT) = NA -! -! ... End of loops in 1.c -! END DO END DO -! - STORES(I,J)%NTOT = NT -! + ! + DO JX = JXL2, JXH2 + DO JY = JYL2, JYH2 + IF ( ABS(GRIDS(J)%MAPSTA(JY,JX)) .EQ. 2 ) & + STORES(I,J)%FLA(NT) = .TRUE. + END DO + END DO + ! + WGTH = SUM ( STORES(I,J)%AWG(NT,1:NA) ) + IF ( WGTH .LT. 0.499 ) THEN + NA = 0 + ELSE + STORES(I,J)%AWG(NT,:) = STORES(I,J)%AWG(NT,:) / WGTH + END IF + ! + STORES(I,J)%NAV(NT) = NA + ! + ! ... End of loops in 1.c + ! END DO -! -! -------------------------------------------------------------------- / -! 2. Generate open edge distance maps -! 2.a Base map based on MAPSTA only, time step not included. -! + END DO + ! + STORES(I,J)%NTOT = NT + ! + END DO + ! + ! -------------------------------------------------------------------- / + ! 2. Generate open edge distance maps + ! 2.a Base map based on MAPSTA only, time step not included. + ! #ifdef W3_T - WRITE (MDST,9020) I + WRITE (MDST,9020) I #endif -! - ALLOCATE ( MDATAS(I)%MAPODI(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - MAPODI => MDATAS(I)%MAPODI - MAPODI = 0. -! - DO IX=1, NX - DO IY=1, NY - IF ( ABS(MAPSTA(IY,IX)) .EQ. 1 ) THEN - MAPODI(IY,IX) = TODO - ELSE IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 ) THEN - MAPODI(IY,IX) = -2. / SIG(1) * DTMAX - ELSE - MAPODI(IY,IX) = -1. / SIG(1) * DTMAX - END IF - END DO - END DO -! -! 2.b Add in cross-grid information from STORES -! - ALLOCATE ( MASKA(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - MASKA = .FALSE. -! - DO J=1, NRGRD - IF ( .NOT. SHRANK(I,J) ) CYCLE - DO JJ=1, STORES(I,J)%NTOT - IX = STORES(I,J)%IX(JJ) - IY = STORES(I,J)%IY(JJ) - IF ( IX.EQ.1 .OR. IX.EQ.NX .OR. IY.EQ.1 .OR. IY.EQ.NY ) THEN - MASKA(IY,IX) = STORES(I,J)%FLA(JJ) .OR. & - STORES(I,J)%NAV(JJ).EQ.0 - IF ( ABS(MAPSTA(IY,IX)).EQ.2 .AND. & - .NOT.STORES(I,J)%FLA(JJ) .AND. & - STORES(I,J)%NAV(JJ).GT.0 ) THEN - MAPODI(IY,IX) = 0. + ! + ALLOCATE ( MDATAS(I)%MAPODI(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + MAPODI => MDATAS(I)%MAPODI + MAPODI = 0. + ! + DO IX=1, NX + DO IY=1, NY + IF ( ABS(MAPSTA(IY,IX)) .EQ. 1 ) THEN + MAPODI(IY,IX) = TODO + ELSE IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 ) THEN + MAPODI(IY,IX) = -2. / SIG(1) * DTMAX + ELSE + MAPODI(IY,IX) = -1. / SIG(1) * DTMAX + END IF + END DO + END DO + ! + ! 2.b Add in cross-grid information from STORES + ! + ALLOCATE ( MASKA(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + MASKA = .FALSE. + ! + DO J=1, NRGRD + IF ( .NOT. SHRANK(I,J) ) CYCLE + DO JJ=1, STORES(I,J)%NTOT + IX = STORES(I,J)%IX(JJ) + IY = STORES(I,J)%IY(JJ) + IF ( IX.EQ.1 .OR. IX.EQ.NX .OR. IY.EQ.1 .OR. IY.EQ.NY ) THEN + MASKA(IY,IX) = STORES(I,J)%FLA(JJ) .OR. & + STORES(I,J)%NAV(JJ).EQ.0 + IF ( ABS(MAPSTA(IY,IX)).EQ.2 .AND. & + .NOT.STORES(I,J)%FLA(JJ) .AND. & + STORES(I,J)%NAV(JJ).GT.0 ) THEN + MAPODI(IY,IX) = 0. #ifdef W3_O13 - IF ( IMPROC.EQ.NMPERR ) & - WRITE (MDSE,1020) I, IX, 1 + IF ( IMPROC.EQ.NMPERR ) & + WRITE (MDSE,1020) I, IX, 1 #endif - END IF - ELSE - MASKA(IY,IX) = STORES(I,J)%FLA(JJ) - END IF - IF ( MAPSTA(IY,IX).EQ.0 .AND. MAPST2(IY,IX) .EQ.1 .AND. & - STORES(I,J)%NAV(JJ).GT.0 ) MAPODI(IY,IX) = 0. - END DO - END DO -! -! 2.c Remove incompatable boundary points -! - ALLOCATE ( MASKI(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - MASKI = .FALSE. -! - DO IX=2, NX-1 - DO IY=2, NY-1 - IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 .AND. & - .NOT. MASKA(IY,IX) .AND. ( & - MAPODI(IY-1,IX ) .GE. 0. .OR. & - MAPODI(IY+1,IX ) .GE. 0. .OR. & - MAPODI(IY ,IX-1) .GE. 0. .OR. & - MAPODI(IY ,IX+1) .GE. 0. ) ) THEN - MASKI(IY,IX) = .TRUE. + END IF + ELSE + MASKA(IY,IX) = STORES(I,J)%FLA(JJ) + END IF + IF ( MAPSTA(IY,IX).EQ.0 .AND. MAPST2(IY,IX) .EQ.1 .AND. & + STORES(I,J)%NAV(JJ).GT.0 ) MAPODI(IY,IX) = 0. + END DO + END DO + ! + ! 2.c Remove incompatable boundary points + ! + ALLOCATE ( MASKI(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + MASKI = .FALSE. + ! + DO IX=2, NX-1 + DO IY=2, NY-1 + IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 .AND. & + .NOT. MASKA(IY,IX) .AND. ( & + MAPODI(IY-1,IX ) .GE. 0. .OR. & + MAPODI(IY+1,IX ) .GE. 0. .OR. & + MAPODI(IY ,IX-1) .GE. 0. .OR. & + MAPODI(IY ,IX+1) .GE. 0. ) ) THEN + MASKI(IY,IX) = .TRUE. #ifdef W3_O12 - IF ( IMPROC.EQ.NMPERR ) WRITE (MDSE,1020) I, IX, IY + IF ( IMPROC.EQ.NMPERR ) WRITE (MDSE,1020) I, IX, IY #endif - END IF - END DO - END DO -! - DEALLOCATE ( MASKA, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) -! - DO IX=1, NX - DO IY=1, NY - IF ( MASKI(IY,IX) ) MAPODI(IY,IX) = 0. - END DO - END DO -! -! 2.d Mask out influenced edge -! + END IF + END DO + END DO + ! + DEALLOCATE ( MASKA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + ! + DO IX=1, NX + DO IY=1, NY + IF ( MASKI(IY,IX) ) MAPODI(IY,IX) = 0. + END DO + END DO + ! + ! 2.d Mask out influenced edge + ! #ifdef W3_PR0 - NIT = 0 + NIT = 0 #endif #ifdef W3_PR1 - NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 #endif #ifdef W3_UQ - NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 #endif #ifdef W3_UNO - NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 #endif -! - IF ( ICLOSE.NE.ICLOSE_NONE ) THEN - IXL = 1 - IXH = NX + ! + IF ( ICLOSE.NE.ICLOSE_NONE ) THEN + IXL = 1 + IXH = NX + ELSE + IXL = 2 + IXH = NX - 1 + END IF + ! + DO J=1, NIT + ! + MASKI = .FALSE. + ! + DO IX=IXL, IXH + IF ( IX .EQ. 1 ) THEN + JXL = NX + JXH = 2 + ELSE IF ( IX .EQ. NX ) THEN + JXL = NX - 1 + JXH = 1 ELSE - IXL = 2 - IXH = NX - 1 + JXL = IX - 1 + JXH = IX + 1 END IF -! - DO J=1, NIT -! - MASKI = .FALSE. -! - DO IX=IXL, IXH - IF ( IX .EQ. 1 ) THEN - JXL = NX - JXH = 2 - ELSE IF ( IX .EQ. NX ) THEN - JXL = NX - 1 - JXH = 1 - ELSE - JXL = IX - 1 - JXH = IX + 1 - END IF -! - DO IY=2, NY-1 - IF ( MAPODI(IY,IX) .EQ. TODO .AND. ( & - MAPODI(IY+1,IX ) .GE. 0. .OR. & - MAPODI(IY ,JXL) .GE. 0. .OR. & - MAPODI(IY-1,IX ) .GE. 0. .OR. & - MAPODI(IY ,JXH) .GE. 0. .OR. & + ! + DO IY=2, NY-1 + IF ( MAPODI(IY,IX) .EQ. TODO .AND. ( & + MAPODI(IY+1,IX ) .GE. 0. .OR. & + MAPODI(IY ,JXL) .GE. 0. .OR. & + MAPODI(IY-1,IX ) .GE. 0. .OR. & + MAPODI(IY ,JXH) .GE. 0. .OR. & ( MAPODI(IY+1,JXH) .GE. 0. .AND. .NOT. & ( MAPSTA(IY+1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXH) .NE. 1 ) ) .OR. & + MAPSTA(IY ,JXH) .NE. 1 ) ) .OR. & ( MAPODI(IY+1,JXL) .GE. 0. .AND. .NOT. & ( MAPSTA(IY+1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXL) .NE. 1 ) ) .OR. & + MAPSTA(IY ,JXL) .NE. 1 ) ) .OR. & ( MAPODI(IY-1,JXL) .GE. 0. .AND. .NOT. & ( MAPSTA(IY-1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXL) .NE. 1 ) ) .OR. & + MAPSTA(IY ,JXL) .NE. 1 ) ) .OR. & ( MAPODI(IY-1,JXH) .GE. 0. .AND. .NOT. & ( MAPSTA(IY-1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXH) .NE. 1 ) ) ) ) & - MASKI(IY,IX) = .TRUE. - END DO -! - END DO -! - DO IX=IXL, IXH - DO IY=2, NY-1 - IF ( MASKI(IY,IX) ) MAPODI(IY,IX) = 0. - END DO - END DO -! + MAPSTA(IY ,JXH) .NE. 1 ) ) ) ) & + MASKI(IY,IX) = .TRUE. END DO -! -! 2.e Compute distances -! - DO - MASKI = .FALSE. -! - DO IX=IXL, IXH - IF ( IX .EQ. 1 ) THEN - JXL = NX - JXH = 2 - ELSE IF ( IX .EQ. NX ) THEN - JXL = NX - 1 - JXH = 1 - ELSE - JXL = IX - 1 - JXH = IX + 1 - END IF - DO IY=2, NY-1 - IF ( MAPODI(IY,IX) .EQ. TODO .AND. ( & - MAPODI(IY+1,IX ) .GE. 0. .OR. & - MAPODI(IY-1,IX ) .GE. 0. .OR. & - MAPODI(IY ,JXH) .GE. 0. .OR. & - MAPODI(IY ,JXL) .GE. 0. .OR. & + ! + END DO + ! + DO IX=IXL, IXH + DO IY=2, NY-1 + IF ( MASKI(IY,IX) ) MAPODI(IY,IX) = 0. + END DO + END DO + ! + END DO + ! + ! 2.e Compute distances + ! + DO + MASKI = .FALSE. + ! + DO IX=IXL, IXH + IF ( IX .EQ. 1 ) THEN + JXL = NX + JXH = 2 + ELSE IF ( IX .EQ. NX ) THEN + JXL = NX - 1 + JXH = 1 + ELSE + JXL = IX - 1 + JXH = IX + 1 + END IF + DO IY=2, NY-1 + IF ( MAPODI(IY,IX) .EQ. TODO .AND. ( & + MAPODI(IY+1,IX ) .GE. 0. .OR. & + MAPODI(IY-1,IX ) .GE. 0. .OR. & + MAPODI(IY ,JXH) .GE. 0. .OR. & + MAPODI(IY ,JXL) .GE. 0. .OR. & ( MAPODI(IY+1,JXH) .GE. 0. .AND. .NOT. & ( MAPSTA(IY+1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXH) .NE. 1 ) ) .OR. & + MAPSTA(IY ,JXH) .NE. 1 ) ) .OR. & ( MAPODI(IY+1,JXL) .GE. 0. .AND. .NOT. & ( MAPSTA(IY+1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXL) .NE. 1 ) ) .OR. & + MAPSTA(IY ,JXL) .NE. 1 ) ) .OR. & ( MAPODI(IY-1,JXL) .GE. 0. .AND. .NOT. & ( MAPSTA(IY-1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXL) .NE. 1 ) ) .OR. & + MAPSTA(IY ,JXL) .NE. 1 ) ) .OR. & ( MAPODI(IY-1,JXH) .GE. 0. .AND. .NOT. & ( MAPSTA(IY-1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXH) .NE. 1 ) ) ) ) & - MASKI(IY,IX) = .TRUE. - END DO - END DO -! - CHANGE = .FALSE. - DO IY=2, NY-1 - DO IX=IXL, IXH - IF ( IX .EQ. 1 ) THEN - JXL = NX - JXH = 2 - ELSE IF ( IX .EQ. NX ) THEN - JXL = NX - 1 - JXH = 1 - ELSE - JXL = IX - 1 - JXH = IX + 1 - END IF - ISEA = MAPFS(IY,IX) - STY = FACTOR * HQFAC(IY,IX) / ( 0.58 * GRAV ) - STX = FACTOR * HPFAC(IY,IX) & - / ( 0.58 * GRAV ) - STXY = SQRT ( STX**2 + STY**2 ) - IF ( MASKI(IY,IX) ) THEN - NEWVAL = ODIMAX / SIG(1) * DTMAX - IF ( MAPODI(IY+1,IX ).GE.0. .AND. .NOT. & - MASKI (IY+1,IX ) ) NEWVAL = MIN ( & - NEWVAL , MAPODI(IY+1,IX )+STY ) - IF ( MAPODI(IY-1,IX ).GE.0. .AND. .NOT. & - MASKI (IY-1,IX ) ) NEWVAL = MIN ( & - NEWVAL , MAPODI(IY-1,IX )+STY ) - IF ( MAPODI(IY ,JXH).GE.0. .AND. .NOT. & - MASKI (IY ,JXH) ) NEWVAL = MIN ( & - NEWVAL , MAPODI(IY ,JXH)+STX) - IF ( MAPODI(IY ,JXL).GE.0. .AND. .NOT. & - MASKI (IY ,JXL) ) NEWVAL = MIN ( & - NEWVAL , MAPODI(IY ,JXL)+STX) - IF ( MAPODI(IY+1,JXH).GE.0. .AND. .NOT. & - ( MAPSTA(IY+1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXH) .NE. 1 ) ) NEWVAL = & - MIN ( NEWVAL , MAPODI(IY+1,JXH)+STXY) - IF ( MAPODI(IY+1,JXL).GE.0. .AND. .NOT. & - ( MAPSTA(IY+1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXL) .NE. 1 ) ) NEWVAL = & - MIN ( NEWVAL , MAPODI(IY+1,JXL)+STXY) - IF ( MAPODI(IY-1,JXL).GE.0. .AND. .NOT. & - ( MAPSTA(IY-1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXL) .NE. 1 ) ) NEWVAL = & - MIN ( NEWVAL , MAPODI(IY-1,JXL)+STXY) - IF ( MAPODI(IY-1,JXH).GE.0. .AND. .NOT. & - ( MAPSTA(IY-1,IX ) .NE. 1 .AND. & - MAPSTA(IY ,JXH) .NE. 1 ) ) NEWVAL = & - MIN ( NEWVAL , MAPODI(IY-1,JXH)+STXY) - MAPODI(IY,IX) = NEWVAL - CHANGE = .TRUE. - END IF - END DO - END DO -! - IF ( .NOT. CHANGE ) EXIT - END DO -! - DO IX=2, NX-1 - DO IY=2, NY-1 - IF ( MAPODI(IY,IX) .EQ. TODO ) & - MAPODI(IY,IX) = 2. * ODIMAX / SIG(1) * DTMAX - END DO + MAPSTA(IY ,JXH) .NE. 1 ) ) ) ) & + MASKI(IY,IX) = .TRUE. END DO -! - DEALLOCATE ( MASKI, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) -! -! 2.f Update FLAGST -! - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF ( MAPODI(IY,IX) .EQ. 0. ) FLAGST(ISEA) = .NOT. FLGHG1 + END DO + ! + CHANGE = .FALSE. + DO IY=2, NY-1 + DO IX=IXL, IXH + IF ( IX .EQ. 1 ) THEN + JXL = NX + JXH = 2 + ELSE IF ( IX .EQ. NX ) THEN + JXL = NX - 1 + JXH = 1 + ELSE + JXL = IX - 1 + JXH = IX + 1 + END IF + ISEA = MAPFS(IY,IX) + STY = FACTOR * HQFAC(IY,IX) / ( 0.58 * GRAV ) + STX = FACTOR * HPFAC(IY,IX) & + / ( 0.58 * GRAV ) + STXY = SQRT ( STX**2 + STY**2 ) + IF ( MASKI(IY,IX) ) THEN + NEWVAL = ODIMAX / SIG(1) * DTMAX + IF ( MAPODI(IY+1,IX ).GE.0. .AND. .NOT. & + MASKI (IY+1,IX ) ) NEWVAL = MIN ( & + NEWVAL , MAPODI(IY+1,IX )+STY ) + IF ( MAPODI(IY-1,IX ).GE.0. .AND. .NOT. & + MASKI (IY-1,IX ) ) NEWVAL = MIN ( & + NEWVAL , MAPODI(IY-1,IX )+STY ) + IF ( MAPODI(IY ,JXH).GE.0. .AND. .NOT. & + MASKI (IY ,JXH) ) NEWVAL = MIN ( & + NEWVAL , MAPODI(IY ,JXH)+STX) + IF ( MAPODI(IY ,JXL).GE.0. .AND. .NOT. & + MASKI (IY ,JXL) ) NEWVAL = MIN ( & + NEWVAL , MAPODI(IY ,JXL)+STX) + IF ( MAPODI(IY+1,JXH).GE.0. .AND. .NOT. & + ( MAPSTA(IY+1,IX ) .NE. 1 .AND. & + MAPSTA(IY ,JXH) .NE. 1 ) ) NEWVAL = & + MIN ( NEWVAL , MAPODI(IY+1,JXH)+STXY) + IF ( MAPODI(IY+1,JXL).GE.0. .AND. .NOT. & + ( MAPSTA(IY+1,IX ) .NE. 1 .AND. & + MAPSTA(IY ,JXL) .NE. 1 ) ) NEWVAL = & + MIN ( NEWVAL , MAPODI(IY+1,JXL)+STXY) + IF ( MAPODI(IY-1,JXL).GE.0. .AND. .NOT. & + ( MAPSTA(IY-1,IX ) .NE. 1 .AND. & + MAPSTA(IY ,JXL) .NE. 1 ) ) NEWVAL = & + MIN ( NEWVAL , MAPODI(IY-1,JXL)+STXY) + IF ( MAPODI(IY-1,JXH).GE.0. .AND. .NOT. & + ( MAPSTA(IY-1,IX ) .NE. 1 .AND. & + MAPSTA(IY ,JXH) .NE. 1 ) ) NEWVAL = & + MIN ( NEWVAL , MAPODI(IY-1,JXH)+STXY) + MAPODI(IY,IX) = NEWVAL + CHANGE = .TRUE. + END IF END DO -! -! 2.g Test output -! + END DO + ! + IF ( .NOT. CHANGE ) EXIT + END DO + ! + DO IX=2, NX-1 + DO IY=2, NY-1 + IF ( MAPODI(IY,IX) .EQ. TODO ) & + MAPODI(IY,IX) = 2. * ODIMAX / SIG(1) * DTMAX + END DO + END DO + ! + DEALLOCATE ( MASKI, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + ! + ! 2.f Update FLAGST + ! + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF ( MAPODI(IY,IX) .EQ. 0. ) FLAGST(ISEA) = .NOT. FLGHG1 + END DO + ! + ! 2.g Test output + ! #ifdef W3_T - NP = 1 + (NX-1)/65 - DO IP=1, NP - IXL = 1 + (IP-1)*65 - IXH = MIN( NX, IP*65 ) - WRITE (MDST,9024) IXL, IXH - DO IY=NY,1 , -1 - WRITE (MDST,9025) NINT(MAPODI(IY,IXL:IXH)*SIG(1)/DTMAX) - END DO - END DO -#endif -! -! ... End of loop in 1.a -! + NP = 1 + (NX-1)/65 + DO IP=1, NP + IXL = 1 + (IP-1)*65 + IXH = MIN( NX, IP*65 ) + WRITE (MDST,9024) IXL, IXH + DO IY=NY,1 , -1 + WRITE (MDST,9025) NINT(MAPODI(IY,IXL:IXH)*SIG(1)/DTMAX) END DO -! -! -------------------------------------------------------------------- / -! 3. Final data base (full data base, scratched at end of routine) -! 3.a Loop over grids -! - ALLOCATE ( NREC(NRGRD), NSND(NRGRD), NTPP(NMPROC), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - DO I=1, NRGRD - IF ( .NOT. DOGRID(I) ) CYCLE + END DO +#endif + ! + ! ... End of loop in 1.a + ! + END DO + ! + ! -------------------------------------------------------------------- / + ! 3. Final data base (full data base, scratched at end of routine) + ! 3.a Loop over grids + ! + ALLOCATE ( NREC(NRGRD), NSND(NRGRD), NTPP(NMPROC), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + DO I=1, NRGRD + IF ( .NOT. DOGRID(I) ) CYCLE #ifdef W3_T - WRITE (MDST,9030) I -#endif -! - CALL W3SETG ( I, MDSE, MDST ) - CALL W3SETO ( I, MDSE, MDST ) - CALL WMSETM ( I, MDSE, MDST ) -! - ALLOCATE ( MAP3D(NY,NX,-4:NRGRD), WGT3D(NY,NX,0:NRGRD), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - MAP3D = 0 - WGT3D = 0. - NREC = 0 - NSND = 0 -! -! 3.b Filling MAP3D and WGT3D, as well as NREC and NSND -! - DO J=1, NRGRD - IF ( .NOT. SHRANK(I,J) ) CYCLE + WRITE (MDST,9030) I +#endif + ! + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + CALL WMSETM ( I, MDSE, MDST ) + ! + ALLOCATE ( MAP3D(NY,NX,-4:NRGRD), WGT3D(NY,NX,0:NRGRD), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + MAP3D = 0 + WGT3D = 0. + NREC = 0 + NSND = 0 + ! + ! 3.b Filling MAP3D and WGT3D, as well as NREC and NSND + ! + DO J=1, NRGRD + IF ( .NOT. SHRANK(I,J) ) CYCLE #ifdef W3_T - WRITE (MDST,9031) J -#endif - MAPODI => MDATAS(J)%MAPODI -! - DO JJ=1, STORES(I,J)%NTOT - IX = STORES(I,J)%IX(JJ) - IY = STORES(I,J)%IY(JJ) - WGT3D(IY,IX,0) = MDATAS(I)%MAPODI(IY,IX) - MAP3D(IY,IX,-2) = MAPFS(IY,IX) - IF ( MAP3D(IY,IX,-2) .NE. 0 ) THEN - MAP3D(IY,IX,-3) = 1 + (MAP3D(IY,IX,-2)-1)/NAPROC + WRITE (MDST,9031) J +#endif + MAPODI => MDATAS(J)%MAPODI + ! + DO JJ=1, STORES(I,J)%NTOT + IX = STORES(I,J)%IX(JJ) + IY = STORES(I,J)%IY(JJ) + WGT3D(IY,IX,0) = MDATAS(I)%MAPODI(IY,IX) + MAP3D(IY,IX,-2) = MAPFS(IY,IX) + IF ( MAP3D(IY,IX,-2) .NE. 0 ) THEN + MAP3D(IY,IX,-3) = 1 + (MAP3D(IY,IX,-2)-1)/NAPROC #ifdef W3_SHRD - MAP3D(IY,IX,-4) = 1 + MAP3D(IY,IX,-4) = 1 #endif #ifdef W3_MPI - MAP3D(IY,IX,-4) = MAP3D(IY,IX,-2) - & - (MAP3D(IY,IX,-3)-1)*NAPROC + CROOT - 1 + MAP3D(IY,IX,-4) = MAP3D(IY,IX,-2) - & + (MAP3D(IY,IX,-3)-1)*NAPROC + CROOT - 1 #endif + END IF + IF ( WGT3D(IY,IX,0).GE.0. .AND. MAPSTA(IY,IX).NE.0. .AND. & + STORES(I,J)%NAV(JJ).GT.0 ) THEN + WGT3D(IY,IX,J) = ODIMAX / SIG(1) * DTMAX + DO NA=1, STORES(I,J)%NAV(JJ) + JX = GRIDS(J)%MAPSF(STORES(I,J)%ISS(JJ,NA),1) + JY = GRIDS(J)%MAPSF(STORES(I,J)%ISS(JJ,NA),2) + IF ( MAPODI(JY,JX) .GE. 0. ) WGT3D(IY,IX,J) = & + MIN( WGT3D(IY,IX,J) , MAPODI(JY,JX) ) + END DO + IF ( WGT3D(IY,IX,J) .GT. 0. ) MAP3D(IY,IX,J) = 1 + END IF + END DO + ! + STORES(I,J)%NFIN = SUM(MAP3D(:,:,J)) +#ifdef W3_T + WRITE (MDST,9032) STORES(I,J)%NFIN, STORES(I,J)%NTOT +#endif + ! + END DO + ! + MAPODI => MDATAS(I)%MAPODI + DO IX=1, NX + DO IY=1, NY + MAP3D(IY,IX, 0) = MAXVAL(MAP3D(IY,IX,1:)) + MAP3D(IY,IX,-1) = SUM(MAP3D(IY,IX,1:)) + IF ( MAP3D(IY,IX,-1) .GT. 0 ) THEN + IF ( MAPODI(IY,IX)*SIG(1)/DTMAX .GT. 1.5*ODIMAX ) THEN + WGT3D(IY,IX, 0:) = 0. + MAP3D(IY,IX,-1:) = 0 + ELSE + WGTH = SUM(WGT3D(IY,IX,:)) + IF ( WGTH .GT. 1.E-25 ) THEN + WGT3D(IY,IX,:) = WGT3D(IY,IX,:) / WGTH + ELSE + WGT3D(IY,IX,:) = 0. END IF - IF ( WGT3D(IY,IX,0).GE.0. .AND. MAPSTA(IY,IX).NE.0. .AND. & - STORES(I,J)%NAV(JJ).GT.0 ) THEN - WGT3D(IY,IX,J) = ODIMAX / SIG(1) * DTMAX - DO NA=1, STORES(I,J)%NAV(JJ) - JX = GRIDS(J)%MAPSF(STORES(I,J)%ISS(JJ,NA),1) - JY = GRIDS(J)%MAPSF(STORES(I,J)%ISS(JJ,NA),2) - IF ( MAPODI(JY,JX) .GE. 0. ) WGT3D(IY,IX,J) = & - MIN( WGT3D(IY,IX,J) , MAPODI(JY,JX) ) - END DO - IF ( WGT3D(IY,IX,J) .GT. 0. ) MAP3D(IY,IX,J) = 1 + IF ( MAP3D(IY,IX,-4) .EQ. IMPROC ) THEN + NREC(I) = NREC(I) + 1 + DO JJ=1, NRGRD + IF ( MAP3D(IY,IX,JJ) .GT. 0 ) & + NREC(JJ) = NREC(JJ) + 1 + END DO END IF + END IF + END IF + END DO + END DO + ! + DO J=1, NRGRD + IF ( .NOT. SHRANK(I,J) ) CYCLE + DO JJ=1, STORES(I,J)%NTOT + IX = STORES(I,J)%IX(JJ) + IY = STORES(I,J)%IY(JJ) + IF ( MAP3D(IY,IX,J) .NE. 0 ) THEN + DO NA=1, STORES(I,J)%NAV(JJ) + IF ( STORES(I,J)%IPS(JJ,NA) .EQ. IMPROC ) & + NSND(J) = NSND(J) + 1 END DO -! - STORES(I,J)%NFIN = SUM(MAP3D(:,:,J)) + END IF + END DO + END DO + ! + NG = MAXVAL(MAP3D(:,:,-1)) + NTL = SUM(MAP3D(:,:,0)) + ! + ! 3.c Check for points with all ODI = 0 + ! + MAPODI => MDATAS(I)%MAPODI + NOUT = 0 + ! + JXL = NX + JXH = 1 + JYL = NY + JYH = 1 + ! + ALLOCATE ( MAPOUT(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + MAPOUT = MAPSTA + ! + DO IX=1, NX + DO IY=1, NY + IF ( ABS(MAPSTA(IY,IX)).EQ. 1 .AND. & + MAPODI(IY,IX) .EQ. 0. .AND. & + MAP3D(IY,IX,-1) .EQ. 0 ) THEN + NOUT = NOUT + 1 + IF ( IMPROC.EQ.NMPERR .AND. NOUT.EQ. 1 ) & + WRITE(MDSE,*) ' ' + IF ( IMPROC.EQ.NMPERR .AND. NOUT.LE.25 ) & + WRITE(MDSE,1001) I, IX, IY + IF ( IMPROC.EQ.NMPERR .AND. NOUT.EQ.25 ) & + WRITE(MDSE,1006) + JXL = MIN ( IX, JXL ) + JXH = MAX ( IX, JXH ) + JYL = MIN ( IY, JYL ) + JYH = MAX ( IY, JYH ) + MAPOUT(IY,IX) = 999 + END IF + END DO + END DO + ! + ! 3.d Test and error output + ! #ifdef W3_T - WRITE (MDST,9032) STORES(I,J)%NFIN, STORES(I,J)%NTOT + WRITE (MDST,9033) NTL, NG, NOUT + WRITE (MDST,9034) NREC + WRITE (MDST,9035) NSND + WRITE (MDST,9036) + DO IY=NY,1 , -1 + WRITE (MDST,9037) MAP3D(IY,:,-1) + END DO #endif -! - END DO -! - MAPODI => MDATAS(I)%MAPODI - DO IX=1, NX - DO IY=1, NY - MAP3D(IY,IX, 0) = MAXVAL(MAP3D(IY,IX,1:)) - MAP3D(IY,IX,-1) = SUM(MAP3D(IY,IX,1:)) - IF ( MAP3D(IY,IX,-1) .GT. 0 ) THEN - IF ( MAPODI(IY,IX)*SIG(1)/DTMAX .GT. 1.5*ODIMAX ) THEN - WGT3D(IY,IX, 0:) = 0. - MAP3D(IY,IX,-1:) = 0 - ELSE - WGTH = SUM(WGT3D(IY,IX,:)) - IF ( WGTH .GT. 1.E-25 ) THEN - WGT3D(IY,IX,:) = WGT3D(IY,IX,:) / WGTH - ELSE - WGT3D(IY,IX,:) = 0. - END IF - IF ( MAP3D(IY,IX,-4) .EQ. IMPROC ) THEN - NREC(I) = NREC(I) + 1 - DO JJ=1, NRGRD - IF ( MAP3D(IY,IX,JJ) .GT. 0 ) & - NREC(JJ) = NREC(JJ) + 1 - END DO - END IF - END IF - END IF + ! + IF ( NOUT .GT. 0 ) THEN + IF ( IMPROC.EQ.NMPERR ) THEN + WRITE(MDSE,1000) I, NOUT + EXTRA = 2 + JXL = MAX ( 1, JXL - EXTRA ) + JXH = MIN ( NX, JXH + EXTRA ) + JYL = MAX ( 1, JYL - EXTRA ) + JYH = MIN ( NY, JYH + EXTRA ) + WRITE (MDSE,1002) JXL, JXH, JYL, JYH + NP = 1 + (JXH-JXL)/65 + DO IP=1, NP + IXL = JXL + (IP-1)*65 + IXH = MIN( NX, IXL+64 ) + WRITE (MDSE,1005) IXL, IXH + WRITE (MDSE,1003) 'STATUS MAP MAPSTA' + DO IY=JYH, JYL, -1 + WRITE (MDSE,1004) MAPSTA(IY,IXL:IXH) END DO - END DO -! - DO J=1, NRGRD - IF ( .NOT. SHRANK(I,J) ) CYCLE - DO JJ=1, STORES(I,J)%NTOT - IX = STORES(I,J)%IX(JJ) - IY = STORES(I,J)%IY(JJ) - IF ( MAP3D(IY,IX,J) .NE. 0 ) THEN - DO NA=1, STORES(I,J)%NAV(JJ) - IF ( STORES(I,J)%IPS(JJ,NA) .EQ. IMPROC ) & - NSND(J) = NSND(J) + 1 - END DO - END IF + WRITE (MDSE,1003) 'MISSING POINTS IN MAPSTA (**)' + DO IY=JYH, JYL, -1 + WRITE (MDSE,1004) MAPOUT(IY,IXL:IXH) END DO - END DO -! - NG = MAXVAL(MAP3D(:,:,-1)) - NTL = SUM(MAP3D(:,:,0)) -! -! 3.c Check for points with all ODI = 0 -! - MAPODI => MDATAS(I)%MAPODI - NOUT = 0 -! - JXL = NX - JXH = 1 - JYL = NY - JYH = 1 -! - ALLOCATE ( MAPOUT(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - MAPOUT = MAPSTA -! - DO IX=1, NX - DO IY=1, NY - IF ( ABS(MAPSTA(IY,IX)).EQ. 1 .AND. & - MAPODI(IY,IX) .EQ. 0. .AND. & - MAP3D(IY,IX,-1) .EQ. 0 ) THEN - NOUT = NOUT + 1 - IF ( IMPROC.EQ.NMPERR .AND. NOUT.EQ. 1 ) & - WRITE(MDSE,*) ' ' - IF ( IMPROC.EQ.NMPERR .AND. NOUT.LE.25 ) & - WRITE(MDSE,1001) I, IX, IY - IF ( IMPROC.EQ.NMPERR .AND. NOUT.EQ.25 ) & - WRITE(MDSE,1006) - JXL = MIN ( IX, JXL ) - JXH = MAX ( IX, JXH ) - JYL = MIN ( IY, JYL ) - JYH = MAX ( IY, JYH ) - MAPOUT(IY,IX) = 999 - END IF + WRITE (MDSE,1003) 'OPEN BOUND. DISTANCE MAP MAPODI' + DO IY=JYH, JYL, -1 + WRITE (MDSE,1004) & + NINT(MAPODI(IY,IXL:IXH)*SIG(1)/DTMAX) END DO + WRITE (MDSE,1003) 'GRID COVERAGE MAP MAP3D' + DO IY=JYH, JYL, -1 + WRITE (MDSE,1004) MAP3D(IY,IXL:IXH,-1) + END DO + WRITE (MDSE,*) END DO -! -! 3.d Test and error output -! -#ifdef W3_T - WRITE (MDST,9033) NTL, NG, NOUT - WRITE (MDST,9034) NREC - WRITE (MDST,9035) NSND - WRITE (MDST,9036) - DO IY=NY,1 , -1 - WRITE (MDST,9037) MAP3D(IY,:,-1) - END DO -#endif -! - IF ( NOUT .GT. 0 ) THEN - IF ( IMPROC.EQ.NMPERR ) THEN - WRITE(MDSE,1000) I, NOUT - EXTRA = 2 - JXL = MAX ( 1, JXL - EXTRA ) - JXH = MIN ( NX, JXH + EXTRA ) - JYL = MAX ( 1, JYL - EXTRA ) - JYH = MIN ( NY, JYH + EXTRA ) - WRITE (MDSE,1002) JXL, JXH, JYL, JYH - NP = 1 + (JXH-JXL)/65 - DO IP=1, NP - IXL = JXL + (IP-1)*65 - IXH = MIN( NX, IXL+64 ) - WRITE (MDSE,1005) IXL, IXH - WRITE (MDSE,1003) 'STATUS MAP MAPSTA' - DO IY=JYH, JYL, -1 - WRITE (MDSE,1004) MAPSTA(IY,IXL:IXH) - END DO - WRITE (MDSE,1003) 'MISSING POINTS IN MAPSTA (**)' - DO IY=JYH, JYL, -1 - WRITE (MDSE,1004) MAPOUT(IY,IXL:IXH) - END DO - WRITE (MDSE,1003) 'OPEN BOUND. DISTANCE MAP MAPODI' - DO IY=JYH, JYL, -1 - WRITE (MDSE,1004) & - NINT(MAPODI(IY,IXL:IXH)*SIG(1)/DTMAX) - END DO - WRITE (MDSE,1003) 'GRID COVERAGE MAP MAP3D' - DO IY=JYH, JYL, -1 - WRITE (MDSE,1004) MAP3D(IY,IXL:IXH,-1) - END DO - WRITE (MDSE,*) - END DO - END IF - CALL EXTCDE (1000) - END IF -! - DEALLOCATE ( MAPOUT, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) -! + END IF + CALL EXTCDE (1000) + END IF + ! + DEALLOCATE ( MAPOUT, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + ! #ifdef W3_T7 - WRITE (MDST,9330) I - DO J=1, NRGRD - IF ( .NOT. SHRANK(I,J) ) THEN - IF ( I .NE. J ) WRITE (MDST,9331) J - CYCLE - END IF - WRITE (MDST,9332) J, STORES(I,J)%NFIN, I, J - IF ( STORES(I,J)%NFIN .EQ. 0 ) CYCLE - NTL = 0 - DO JJ=1, STORES(I,J)%NTOT - IX = STORES(I,J)%IX(JJ) - IY = STORES(I,J)%IY(JJ) - IF ( MAP3D(IY,IX,J) .EQ. 0 ) CYCLE - NTL = NTL + 1 - NA = STORES(I,J)%NAV(JJ) - WRITE (MDST,9333) NTL, IX, IY, MAP3D(IY,IX,-2), & - MAP3D(IY,IX,-3), MAP3D(IY,IX,-4), & - WGT3D(IY,IX,0), WGT3D(IY,IX,J), NA, & - STORES(I,J)%ISS(JJ,1), & - STORES(I,J)%JSS(JJ,1), & - STORES(I,J)%IPS(JJ,1), & - STORES(I,J)%AWG(JJ,1), & - STORES(I,J)%ITG(JJ,1) - DO IA=2, NA - WRITE (MDST,9334) STORES(I,J)%ISS(JJ,IA), & - STORES(I,J)%JSS(JJ,IA), & - STORES(I,J)%IPS(JJ,IA), & - STORES(I,J)%AWG(JJ,IA), & - STORES(I,J)%ITG(JJ,IA) - END DO - END DO + WRITE (MDST,9330) I + DO J=1, NRGRD + IF ( .NOT. SHRANK(I,J) ) THEN + IF ( I .NE. J ) WRITE (MDST,9331) J + CYCLE + END IF + WRITE (MDST,9332) J, STORES(I,J)%NFIN, I, J + IF ( STORES(I,J)%NFIN .EQ. 0 ) CYCLE + NTL = 0 + DO JJ=1, STORES(I,J)%NTOT + IX = STORES(I,J)%IX(JJ) + IY = STORES(I,J)%IY(JJ) + IF ( MAP3D(IY,IX,J) .EQ. 0 ) CYCLE + NTL = NTL + 1 + NA = STORES(I,J)%NAV(JJ) + WRITE (MDST,9333) NTL, IX, IY, MAP3D(IY,IX,-2), & + MAP3D(IY,IX,-3), MAP3D(IY,IX,-4), & + WGT3D(IY,IX,0), WGT3D(IY,IX,J), NA, & + STORES(I,J)%ISS(JJ,1), & + STORES(I,J)%JSS(JJ,1), & + STORES(I,J)%IPS(JJ,1), & + STORES(I,J)%AWG(JJ,1), & + STORES(I,J)%ITG(JJ,1) + DO IA=2, NA + WRITE (MDST,9334) STORES(I,J)%ISS(JJ,IA), & + STORES(I,J)%JSS(JJ,IA), & + STORES(I,J)%IPS(JJ,IA), & + STORES(I,J)%AWG(JJ,IA), & + STORES(I,J)%ITG(JJ,IA) END DO + END DO + END DO #endif -! -! -------------------------------------------------------------------- / -! 4. Save data base as needed in EQSTGE -! -! 4.a ALLOCATE storage -! 4.a.1 Local counters, weights and sea counters (grid 'I') -! - IF ( EQSTGE(I,I)%NREC .NE. 0 ) THEN - DEALLOCATE (EQSTGE(I,I)%ISEA , EQSTGE(I,I)%JSEA , & - EQSTGE(I,I)%WGHT, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - EQSTGE(I,I)%NREC = 0 + ! + ! -------------------------------------------------------------------- / + ! 4. Save data base as needed in EQSTGE + ! + ! 4.a ALLOCATE storage + ! 4.a.1 Local counters, weights and sea counters (grid 'I') + ! + IF ( EQSTGE(I,I)%NREC .NE. 0 ) THEN + DEALLOCATE (EQSTGE(I,I)%ISEA , EQSTGE(I,I)%JSEA , & + EQSTGE(I,I)%WGHT, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + EQSTGE(I,I)%NREC = 0 #ifdef W3_T - WRITE (MDST,9040) I, I + WRITE (MDST,9040) I, I #endif - END IF -! - IF ( NREC(I) .GT. 0 ) THEN - ALLOCATE ( EQSTGE(I,I)%ISEA(NREC(I)) , & - EQSTGE(I,I)%JSEA(NREC(I)) , & - EQSTGE(I,I)%WGHT(NREC(I)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - EQSTGE(I,I)%NREC = NREC(I) + END IF + ! + IF ( NREC(I) .GT. 0 ) THEN + ALLOCATE ( EQSTGE(I,I)%ISEA(NREC(I)) , & + EQSTGE(I,I)%JSEA(NREC(I)) , & + EQSTGE(I,I)%WGHT(NREC(I)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + EQSTGE(I,I)%NREC = NREC(I) #ifdef W3_T - WRITE (MDST,9041) I, I, NREC(I) + WRITE (MDST,9041) I, I, NREC(I) #endif - END IF -! -! 4.a.1 Local counters, arrays weights etc. (grid 'J' receive) -! - DO J=1, NRGRD - IF ( I .EQ. J ) CYCLE - EQSTGE(I,I)%NTOT = STORES(I,J)%NFIN -! - IF ( EQSTGE(I,J)%NREC .NE. 0 ) THEN - DEALLOCATE ( EQSTGE(I,J)%ISEA , EQSTGE(I,J)%JSEA , & - EQSTGE(I,J)%WGHT , EQSTGE(I,J)%SEQL , & - EQSTGE(I,J)%NAVG , EQSTGE(I,J)%WAVG , & - EQSTGE(I,J)%RIP , EQSTGE(I,J)%RTG, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - EQSTGE(I,J)%NREC = 0 - EQSTGE(I,J)%NAVMAX = 1 + END IF + ! + ! 4.a.1 Local counters, arrays weights etc. (grid 'J' receive) + ! + DO J=1, NRGRD + IF ( I .EQ. J ) CYCLE + EQSTGE(I,I)%NTOT = STORES(I,J)%NFIN + ! + IF ( EQSTGE(I,J)%NREC .NE. 0 ) THEN + DEALLOCATE ( EQSTGE(I,J)%ISEA , EQSTGE(I,J)%JSEA , & + EQSTGE(I,J)%WGHT , EQSTGE(I,J)%SEQL , & + EQSTGE(I,J)%NAVG , EQSTGE(I,J)%WAVG , & + EQSTGE(I,J)%RIP , EQSTGE(I,J)%RTG, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + EQSTGE(I,J)%NREC = 0 + EQSTGE(I,J)%NAVMAX = 1 #ifdef W3_T - WRITE (MDST,9042) I, J + WRITE (MDST,9042) I, J #endif - END IF -! - IF ( NREC(J) .GT. 0 ) THEN - NA = MAXVAL ( STORES(I,J)%NAV(1:STORES(I,J)%NTOT) ) - EQSTGE(I,J)%NAVMAX = NA - ALLOCATE ( EQSTGE(I,J)%ISEA(NREC(J)) , & - EQSTGE(I,J)%JSEA(NREC(J)) , & - EQSTGE(I,J)%WGHT(NREC(J)) , & - EQSTGE(I,J)%SEQL(SGRDS(J)%NSPEC,NREC(J),NA), & - EQSTGE(I,J)%NAVG(NREC(J)) , & - EQSTGE(I,J)%WAVG(NREC(J),NA), & - EQSTGE(I,J)%RIP(NREC(J),NA), & - EQSTGE(I,J)%RTG(NREC(J),NA), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - EQSTGE(I,J)%NREC = NREC(J) + END IF + ! + IF ( NREC(J) .GT. 0 ) THEN + NA = MAXVAL ( STORES(I,J)%NAV(1:STORES(I,J)%NTOT) ) + EQSTGE(I,J)%NAVMAX = NA + ALLOCATE ( EQSTGE(I,J)%ISEA(NREC(J)) , & + EQSTGE(I,J)%JSEA(NREC(J)) , & + EQSTGE(I,J)%WGHT(NREC(J)) , & + EQSTGE(I,J)%SEQL(SGRDS(J)%NSPEC,NREC(J),NA), & + EQSTGE(I,J)%NAVG(NREC(J)) , & + EQSTGE(I,J)%WAVG(NREC(J),NA), & + EQSTGE(I,J)%RIP(NREC(J),NA), & + EQSTGE(I,J)%RTG(NREC(J),NA), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + EQSTGE(I,J)%NREC = NREC(J) #ifdef W3_T - WRITE (MDST,9043) I, J, NREC(J), NA + WRITE (MDST,9043) I, J, NREC(J), NA #endif - END IF -! - IF ( EQSTGE(I,J)%NSND .NE. 0 ) THEN - DEALLOCATE ( EQSTGE(I,J)%SIS , EQSTGE(I,J)%SJS , & - EQSTGE(I,J)%SI1 , EQSTGE(I,J)%SI2 , & - EQSTGE(I,J)%SIP , EQSTGE(I,J)%STG, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - EQSTGE(I,J)%NSND = 0 + END IF + ! + IF ( EQSTGE(I,J)%NSND .NE. 0 ) THEN + DEALLOCATE ( EQSTGE(I,J)%SIS , EQSTGE(I,J)%SJS , & + EQSTGE(I,J)%SI1 , EQSTGE(I,J)%SI2 , & + EQSTGE(I,J)%SIP , EQSTGE(I,J)%STG, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + EQSTGE(I,J)%NSND = 0 #ifdef W3_T - WRITE (MDST,9044) I, J + WRITE (MDST,9044) I, J #endif - END IF -! - IF ( NSND(J) .GT. 0 ) THEN - ALLOCATE ( EQSTGE(I,J)%SIS(NSND(J)) , & - EQSTGE(I,J)%SJS(NSND(J)) , & - EQSTGE(I,J)%SI1(NSND(J)) , & - EQSTGE(I,J)%SI2(NSND(J)) , & - EQSTGE(I,J)%SIP(NSND(J)) , & - EQSTGE(I,J)%STG(NSND(J)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - EQSTGE(I,J)%NSND = NSND(J) + END IF + ! + IF ( NSND(J) .GT. 0 ) THEN + ALLOCATE ( EQSTGE(I,J)%SIS(NSND(J)) , & + EQSTGE(I,J)%SJS(NSND(J)) , & + EQSTGE(I,J)%SI1(NSND(J)) , & + EQSTGE(I,J)%SI2(NSND(J)) , & + EQSTGE(I,J)%SIP(NSND(J)) , & + EQSTGE(I,J)%STG(NSND(J)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + EQSTGE(I,J)%NSND = NSND(J) #ifdef W3_T - WRITE (MDST,9045) I, J, NSND(J) + WRITE (MDST,9045) I, J, NSND(J) #endif - END IF -! - END DO -! -! 4.b Store data in EQSTGE -! 4.b.1 Grid I (JSEA and weight only) -! - IF ( EQSTGE(I,I)%NREC .GT. 0 ) THEN - NTL = 0 - DO IX=1, NX - DO IY=1, NY - IF ( MAP3D(IY,IX,0) .EQ. 0 ) CYCLE - IF ( MAP3D(IY,IX,-4) .NE. IMPROC ) CYCLE - NTL = NTL + 1 - EQSTGE(I,I)%ISEA(NTL) = MAP3D(IY,IX,-2) - EQSTGE(I,I)%JSEA(NTL) = MAP3D(IY,IX,-3) - EQSTGE(I,I)%WGHT(NTL) = WGT3D(IY,IX,0) - END DO - END DO - END IF -! -! 4.b.2 All other grids, info for receiving -! - DO J=1, NRGRD - IF ( .NOT. SHRANK(I,J) ) CYCLE - IF ( EQSTGE(I,J)%NREC .EQ. 0 ) CYCLE - NTL = 0 -! - DO JJ=1, STORES(I,J)%NTOT - IX = STORES(I,J)%IX(JJ) - IY = STORES(I,J)%IY(JJ) - IF ( MAP3D(IY,IX,J) .EQ. 0 ) CYCLE + END IF + ! + END DO + ! + ! 4.b Store data in EQSTGE + ! 4.b.1 Grid I (JSEA and weight only) + ! + IF ( EQSTGE(I,I)%NREC .GT. 0 ) THEN + NTL = 0 + DO IX=1, NX + DO IY=1, NY + IF ( MAP3D(IY,IX,0) .EQ. 0 ) CYCLE IF ( MAP3D(IY,IX,-4) .NE. IMPROC ) CYCLE NTL = NTL + 1 - EQSTGE(I,J)%ISEA(NTL) = MAP3D(IY,IX,-2) - EQSTGE(I,J)%JSEA(NTL) = MAP3D(IY,IX,-3) - EQSTGE(I,J)%WGHT(NTL) = WGT3D(IY,IX,J) - NA = STORES(I,J)%NAV(JJ) - EQSTGE(I,J)%NAVG(NTL) = NA - EQSTGE(I,J)%WAVG(NTL,1:NA) = STORES(I,J)%AWG(JJ,1:NA) - EQSTGE(I,J)%RIP (NTL,1:NA) = STORES(I,J)%IPS(JJ,1:NA) - EQSTGE(I,J)%RTG (NTL,1:NA) = STORES(I,J)%ITG(JJ,1:NA) - END DO -! + EQSTGE(I,I)%ISEA(NTL) = MAP3D(IY,IX,-2) + EQSTGE(I,I)%JSEA(NTL) = MAP3D(IY,IX,-3) + EQSTGE(I,I)%WGHT(NTL) = WGT3D(IY,IX,0) END DO -! -! 4.b.3 All other grids, info for sending -! - DO J=1, NRGRD - IF ( .NOT. SHRANK(I,J) ) CYCLE - IF ( EQSTGE(I,J)%NSND .EQ. 0 ) CYCLE - NTPP = 0 - NTL = 0 -! - DO JJ=1, STORES(I,J)%NTOT - IX = STORES(I,J)%IX(JJ) - IY = STORES(I,J)%IY(JJ) - IF ( MAP3D(IY,IX,J) .NE. 0 ) THEN - NTPP(MAP3D(IY,IX,-4)) = NTPP(MAP3D(IY,IX,-4)) + 1 - DO NA=1, STORES(I,J)%NAV(JJ) - IF ( STORES(I,J)%IPS(JJ,NA) .EQ. IMPROC ) THEN - NTL = NTL + 1 - EQSTGE(I,J)%SIS(NTL) = STORES(I,J)%ISS(JJ,NA) - EQSTGE(I,J)%SJS(NTL) = STORES(I,J)%JSS(JJ,NA) - EQSTGE(I,J)%SI1(NTL) = NTPP(MAP3D(IY,IX,-4)) - EQSTGE(I,J)%SI2(NTL) = NA - EQSTGE(I,J)%SIP(NTL) = MAP3D(IY,IX,-4) - EQSTGE(I,J)%STG(NTL) = STORES(I,J)%ITG(JJ,NA) - END IF - END DO + END DO + END IF + ! + ! 4.b.2 All other grids, info for receiving + ! + DO J=1, NRGRD + IF ( .NOT. SHRANK(I,J) ) CYCLE + IF ( EQSTGE(I,J)%NREC .EQ. 0 ) CYCLE + NTL = 0 + ! + DO JJ=1, STORES(I,J)%NTOT + IX = STORES(I,J)%IX(JJ) + IY = STORES(I,J)%IY(JJ) + IF ( MAP3D(IY,IX,J) .EQ. 0 ) CYCLE + IF ( MAP3D(IY,IX,-4) .NE. IMPROC ) CYCLE + NTL = NTL + 1 + EQSTGE(I,J)%ISEA(NTL) = MAP3D(IY,IX,-2) + EQSTGE(I,J)%JSEA(NTL) = MAP3D(IY,IX,-3) + EQSTGE(I,J)%WGHT(NTL) = WGT3D(IY,IX,J) + NA = STORES(I,J)%NAV(JJ) + EQSTGE(I,J)%NAVG(NTL) = NA + EQSTGE(I,J)%WAVG(NTL,1:NA) = STORES(I,J)%AWG(JJ,1:NA) + EQSTGE(I,J)%RIP (NTL,1:NA) = STORES(I,J)%IPS(JJ,1:NA) + EQSTGE(I,J)%RTG (NTL,1:NA) = STORES(I,J)%ITG(JJ,1:NA) + END DO + ! + END DO + ! + ! 4.b.3 All other grids, info for sending + ! + DO J=1, NRGRD + IF ( .NOT. SHRANK(I,J) ) CYCLE + IF ( EQSTGE(I,J)%NSND .EQ. 0 ) CYCLE + NTPP = 0 + NTL = 0 + ! + DO JJ=1, STORES(I,J)%NTOT + IX = STORES(I,J)%IX(JJ) + IY = STORES(I,J)%IY(JJ) + IF ( MAP3D(IY,IX,J) .NE. 0 ) THEN + NTPP(MAP3D(IY,IX,-4)) = NTPP(MAP3D(IY,IX,-4)) + 1 + DO NA=1, STORES(I,J)%NAV(JJ) + IF ( STORES(I,J)%IPS(JJ,NA) .EQ. IMPROC ) THEN + NTL = NTL + 1 + EQSTGE(I,J)%SIS(NTL) = STORES(I,J)%ISS(JJ,NA) + EQSTGE(I,J)%SJS(NTL) = STORES(I,J)%JSS(JJ,NA) + EQSTGE(I,J)%SI1(NTL) = NTPP(MAP3D(IY,IX,-4)) + EQSTGE(I,J)%SI2(NTL) = NA + EQSTGE(I,J)%SIP(NTL) = MAP3D(IY,IX,-4) + EQSTGE(I,J)%STG(NTL) = STORES(I,J)%ITG(JJ,NA) END IF END DO -! - END DO -! -! 4.c Detailed test output -! -#ifdef W3_T5 - DSTR = ' ' -#endif -! -#ifdef W3_T5 - IF ( EQSTGE(I,I)%NREC .EQ. 0 ) THEN - WRITE (MDST,9140) I - ELSE - WRITE (MDST,9141) I - NA = 0 - DO J=1, NRGRD - IF ( I.EQ.J .OR. EQSTGE(I,J)%NREC.EQ.0 ) CYCLE - NA = NA + 1 - NSND(NA) = J - END DO - WRITE (MDST,9142) NSND(1:NA) - WRITE (MDST,9143) - ALLOCATE ( TSTR(NA), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - DO JJ=1, EQSTGE(I,I)%NREC - DO NG=1, NA - J = NSND(NG) - TSTR(NG) = DSTR - DO NTL=1, EQSTGE(I,J)%NREC - IF ( EQSTGE(I,I)%ISEA(JJ) .EQ. & - EQSTGE(I,J)%ISEA(NTL) ) THEN - WRITE (TSTR(NG),9144) NTL, & - EQSTGE(I,J)%WGHT(NTL), & - EQSTGE(I,J)%NAVG(NTL) - EXIT - END IF - END DO - END DO - WRITE (MDST,9145) JJ, EQSTGE(I,I)%ISEA(JJ), & - EQSTGE(I,I)%JSEA(JJ), & - EQSTGE(I,I)%WGHT(JJ), & - TSTR - END DO - DEALLOCATE ( TSTR, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) END IF + END DO + ! + END DO + ! + ! 4.c Detailed test output + ! +#ifdef W3_T5 + DSTR = ' ' #endif -! + ! #ifdef W3_T5 + IF ( EQSTGE(I,I)%NREC .EQ. 0 ) THEN + WRITE (MDST,9140) I + ELSE + WRITE (MDST,9141) I + NA = 0 DO J=1, NRGRD IF ( I.EQ.J .OR. EQSTGE(I,J)%NREC.EQ.0 ) CYCLE - WRITE (MDST,9146) J - DO JJ=1, EQSTGE(I,J)%NREC - WRITE (MDST,9147) JJ, EQSTGE(I,J)%NAVG(JJ), & - ( EQSTGE(I,J)%WAVG(JJ,NA), & - EQSTGE(I,J)%RIP (JJ,NA), & - EQSTGE(I,J)%RTG (JJ,NA), & - NA=1, EQSTGE(I,J)%NAVG(JJ) ) + NA = NA + 1 + NSND(NA) = J + END DO + WRITE (MDST,9142) NSND(1:NA) + WRITE (MDST,9143) + ALLOCATE ( TSTR(NA), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + DO JJ=1, EQSTGE(I,I)%NREC + DO NG=1, NA + J = NSND(NG) + TSTR(NG) = DSTR + DO NTL=1, EQSTGE(I,J)%NREC + IF ( EQSTGE(I,I)%ISEA(JJ) .EQ. & + EQSTGE(I,J)%ISEA(NTL) ) THEN + WRITE (TSTR(NG),9144) NTL, & + EQSTGE(I,J)%WGHT(NTL), & + EQSTGE(I,J)%NAVG(NTL) + EXIT + END IF END DO END DO + WRITE (MDST,9145) JJ, EQSTGE(I,I)%ISEA(JJ), & + EQSTGE(I,I)%JSEA(JJ), & + EQSTGE(I,I)%WGHT(JJ), & + TSTR + END DO + DEALLOCATE ( TSTR, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF +#endif + ! +#ifdef W3_T5 + DO J=1, NRGRD + IF ( I.EQ.J .OR. EQSTGE(I,J)%NREC.EQ.0 ) CYCLE + WRITE (MDST,9146) J + DO JJ=1, EQSTGE(I,J)%NREC + WRITE (MDST,9147) JJ, EQSTGE(I,J)%NAVG(JJ), & + ( EQSTGE(I,J)%WAVG(JJ,NA), & + EQSTGE(I,J)%RIP (JJ,NA), & + EQSTGE(I,J)%RTG (JJ,NA), & + NA=1, EQSTGE(I,J)%NAVG(JJ) ) + END DO + END DO #endif -! + ! #ifdef W3_T6 - DO J=1, NRGRD - IF ( I .EQ. J ) CYCLE - IF ( EQSTGE(I,J)%NSND .EQ. 0 ) THEN - WRITE (MDST,9240) J - ELSE - WRITE (MDST,9241) J - DO JJ=1, EQSTGE(I,J)%NSND - WRITE (MDST,9242) JJ, EQSTGE(I,J)%SIS(JJ), & - EQSTGE(I,J)%SJS(JJ), & - EQSTGE(I,J)%SI1(JJ), & - EQSTGE(I,J)%SI2(JJ), & - EQSTGE(I,J)%SIP(JJ), & - EQSTGE(I,J)%STG(JJ) - END DO - END IF + DO J=1, NRGRD + IF ( I .EQ. J ) CYCLE + IF ( EQSTGE(I,J)%NSND .EQ. 0 ) THEN + WRITE (MDST,9240) J + ELSE + WRITE (MDST,9241) J + DO JJ=1, EQSTGE(I,J)%NSND + WRITE (MDST,9242) JJ, EQSTGE(I,J)%SIS(JJ), & + EQSTGE(I,J)%SJS(JJ), & + EQSTGE(I,J)%SI1(JJ), & + EQSTGE(I,J)%SI2(JJ), & + EQSTGE(I,J)%SIP(JJ), & + EQSTGE(I,J)%STG(JJ) END DO + END IF + END DO #endif -! -! ... End of loop started in 3.a -! - DEALLOCATE ( MAP3D, WGT3D, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END DO -! -! -------------------------------------------------------------------- / -! 5. Generate GRDEQL -! 5.a Size of array -! - NREC = 0 -! - DO I=1, NRGRD - DO J=1, NRGRD - IF ( I.EQ.J .OR. STORES(I,J)%NFIN.EQ.0 ) CYCLE - NREC(I) = NREC(I) + 1 - END DO - END DO -! - NA = MAXVAL(NREC) - ALLOCATE ( GRDEQL(NRGRD,0:NA), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - GRDEQL = 0 -! + ! + ! ... End of loop started in 3.a + ! + DEALLOCATE ( MAP3D, WGT3D, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END DO + ! + ! -------------------------------------------------------------------- / + ! 5. Generate GRDEQL + ! 5.a Size of array + ! + NREC = 0 + ! + DO I=1, NRGRD + DO J=1, NRGRD + IF ( I.EQ.J .OR. STORES(I,J)%NFIN.EQ.0 ) CYCLE + NREC(I) = NREC(I) + 1 + END DO + END DO + ! + NA = MAXVAL(NREC) + ALLOCATE ( GRDEQL(NRGRD,0:NA), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + GRDEQL = 0 + ! #ifdef W3_T - WRITE (MDST,9050) NA -#endif -! -! 5.b Fill array -! - DO I=1, NRGRD - GRDEQL(I,0) = NREC(I) - JJ = 0 - DO J=1, NRGRD - IF ( I.EQ.J .OR. STORES(I,J)%NFIN.EQ.0 ) CYCLE - JJ = JJ + 1 - GRDEQL(I,JJ) = J - END DO - END DO -! + WRITE (MDST,9050) NA +#endif + ! + ! 5.b Fill array + ! + DO I=1, NRGRD + GRDEQL(I,0) = NREC(I) + JJ = 0 + DO J=1, NRGRD + IF ( I.EQ.J .OR. STORES(I,J)%NFIN.EQ.0 ) CYCLE + JJ = JJ + 1 + GRDEQL(I,JJ) = J + END DO + END DO + ! #ifdef W3_T - WRITE (MDST,9051) - DO I=1, NRGRD - WRITE (MDST,9052) I, GRDEQL(I,0:GRDEQL(I,0)) - END DO -#endif -! -! 5.c Resolution test -! - - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF -! -! notes: This resolution test, with FACMAX=2, is pretty strict, so -! it is not going to be appropriate for irregular grids. -! We'll just have to trust the judgement of the user in the -! case of irregular grids. But if we change our minds and do -! some kind of check for irregular grids, we could make -! a check against median(HPFAC) and median(HQFAC). - - DO I=1, NRGRD - CALL W3SETG ( I, MDSE, MDST ) - IF ( GTYPE.EQ.RLGTYPE ) THEN - DO JJ=1, GRDEQL(I,0) - J = GRDEQL(I,JJ) - IF ( GRIDS(J)%GTYPE.EQ.RLGTYPE ) THEN - IF ( SX/GRIDS(J)%SX .GT. FACMAX .OR. & - SX/GRIDS(J)%SX .LT. 1./FACMAX .OR. & - SY/GRIDS(J)%SY .GT. FACMAX .OR. & - SY/GRIDS(J)%SY .LT. 1./FACMAX ) THEN - IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,1050) I, FACTOR*SX, & - FACTOR*SY, J, FACTOR*GRIDS(J)%SX, FACTOR*GRIDS(J)%SY - CALL EXTCDE ( 1050 ) - END IF ! IF ( SX/GR ... - END IF ! IF ( GRIDS(J)%GTYPE... - END DO ! DO JJ=... - END IF ! IF ( GTYPE.... - END DO ! DO I=... -! -! 5.d Group number test -! - DO I=1, NRGRD - IF ( GRDEQL(I,0) .GE. 2 ) THEN - TGRP = GRGRP(GRDEQL(I,1)) - DO J=2, GRDEQL(I,0) - IF ( GRGRP(GRDEQL(I,J)) .NE. TGRP ) THEN - IF ( IMPROC .EQ. NMPERR ) WRITE(MDSE,1051) & - GRDEQL(I,1), GRGRP(GRDEQL(I,1)), & - GRDEQL(I,J), GRGRP(GRDEQL(I,J)) - CALL EXTCDE ( 1051 ) - END IF - END DO + WRITE (MDST,9051) + DO I=1, NRGRD + WRITE (MDST,9052) I, GRDEQL(I,0:GRDEQL(I,0)) + END DO +#endif + ! + ! 5.c Resolution test + ! + + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + ! + ! notes: This resolution test, with FACMAX=2, is pretty strict, so + ! it is not going to be appropriate for irregular grids. + ! We'll just have to trust the judgement of the user in the + ! case of irregular grids. But if we change our minds and do + ! some kind of check for irregular grids, we could make + ! a check against median(HPFAC) and median(HQFAC). + + DO I=1, NRGRD + CALL W3SETG ( I, MDSE, MDST ) + IF ( GTYPE.EQ.RLGTYPE ) THEN + DO JJ=1, GRDEQL(I,0) + J = GRDEQL(I,JJ) + IF ( GRIDS(J)%GTYPE.EQ.RLGTYPE ) THEN + IF ( SX/GRIDS(J)%SX .GT. FACMAX .OR. & + SX/GRIDS(J)%SX .LT. 1./FACMAX .OR. & + SY/GRIDS(J)%SY .GT. FACMAX .OR. & + SY/GRIDS(J)%SY .LT. 1./FACMAX ) THEN + IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,1050) I, FACTOR*SX, & + FACTOR*SY, J, FACTOR*GRIDS(J)%SX, FACTOR*GRIDS(J)%SY + CALL EXTCDE ( 1050 ) + END IF ! IF ( SX/GR ... + END IF ! IF ( GRIDS(J)%GTYPE... + END DO ! DO JJ=... + END IF ! IF ( GTYPE.... + END DO ! DO I=... + ! + ! 5.d Group number test + ! + DO I=1, NRGRD + IF ( GRDEQL(I,0) .GE. 2 ) THEN + TGRP = GRGRP(GRDEQL(I,1)) + DO J=2, GRDEQL(I,0) + IF ( GRGRP(GRDEQL(I,J)) .NE. TGRP ) THEN + IF ( IMPROC .EQ. NMPERR ) WRITE(MDSE,1051) & + GRDEQL(I,1), GRGRP(GRDEQL(I,1)), & + GRDEQL(I,J), GRGRP(GRDEQL(I,J)) + CALL EXTCDE ( 1051 ) END IF END DO -! -! -------------------------------------------------------------------- / -! 6. Final clean up -! - DO I=1, NRGRD - DO J=1, NRGRD - IF ( STORES(I,J)%INIT ) THEN - DEALLOCATE ( STORES(I,J)%IX , STORES(I,J)%IY , & - STORES(I,J)%NAV , STORES(I,J)%FLA , & - STORES(I,J)%ISS , STORES(I,J)%JSS , & - STORES(I,J)%IPS , STORES(I,J)%ITG , & - STORES(I,J)%AWG , STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - END IF - END DO - END DO -! - DEALLOCATE ( SHRANK, STORES, NREC, NSND, NTPP, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMGEQL : *** '/ & - ' UNCOVERED EDGE POINTS FOR GRID',I4,' (',I6,')'/) - 1001 FORMAT ( ' GRID',I4,' POINT',2I5,' NOT COVERED (WMGEQL)') - 1002 FORMAT ( ' DIAGNOSTICS IX AND IY RANGE:',4I6) - 1003 FORMAT (/' SHOWING ',A/) - 1004 FORMAT (2X,65I2) - 1005 FORMAT (/' SHOWING IX RANGE ',2I6) - 1006 FORMAT ( ' (WILL NOT PRINT ANY MORE UNCOVERED POINTS)') -! - 1020 FORMAT (/' *** WAVEWATCH III WARNING WMGEQL : *** '/ & - ' REMOVED BOUNDARY POINT FROM OPEN EDGE DISTANCE MAP'/ & - ' GRID, IX, IY :',3I6) -! - 1050 FORMAT (/' *** WAVEWATCH III ERROR IN WMGEQL : *** '/ & - ' GRID INCREMENTS TOO DIFFERENT '/ & - ' GRID',I4,' INCREMENTS ',2F8.2/ & - ' GRID',I4,' INCREMENTS ',2F8.2/) - 1051 FORMAT (/' *** WAVEWATCH III ERROR IN WMGEQL : *** '/ & - ' OVERLAPPING GRIDS NEED TO BE IN SAME GROUP '/ & - ' GRID',I4,' IN GROUP',I4/ & - ' GRID',I4,' IN GROUP',I4/) -! + END IF + END DO + ! + ! -------------------------------------------------------------------- / + ! 6. Final clean up + ! + DO I=1, NRGRD + DO J=1, NRGRD + IF ( STORES(I,J)%INIT ) THEN + DEALLOCATE ( STORES(I,J)%IX , STORES(I,J)%IY , & + STORES(I,J)%NAV , STORES(I,J)%FLA , & + STORES(I,J)%ISS , STORES(I,J)%JSS , & + STORES(I,J)%IPS , STORES(I,J)%ITG , & + STORES(I,J)%AWG , STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + END DO + END DO + ! + DEALLOCATE ( SHRANK, STORES, NREC, NSND, NTPP, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMGEQL : *** '/ & + ' UNCOVERED EDGE POINTS FOR GRID',I4,' (',I6,')'/) +1001 FORMAT ( ' GRID',I4,' POINT',2I5,' NOT COVERED (WMGEQL)') +1002 FORMAT ( ' DIAGNOSTICS IX AND IY RANGE:',4I6) +1003 FORMAT (/' SHOWING ',A/) +1004 FORMAT (2X,65I2) +1005 FORMAT (/' SHOWING IX RANGE ',2I6) +1006 FORMAT ( ' (WILL NOT PRINT ANY MORE UNCOVERED POINTS)') + ! +1020 FORMAT (/' *** WAVEWATCH III WARNING WMGEQL : *** '/ & + ' REMOVED BOUNDARY POINT FROM OPEN EDGE DISTANCE MAP'/ & + ' GRID, IX, IY :',3I6) + ! +1050 FORMAT (/' *** WAVEWATCH III ERROR IN WMGEQL : *** '/ & + ' GRID INCREMENTS TOO DIFFERENT '/ & + ' GRID',I4,' INCREMENTS ',2F8.2/ & + ' GRID',I4,' INCREMENTS ',2F8.2/) +1051 FORMAT (/' *** WAVEWATCH III ERROR IN WMGEQL : *** '/ & + ' OVERLAPPING GRIDS NEED TO BE IN SAME GROUP '/ & + ' GRID',I4,' IN GROUP',I4/ & + ' GRID',I4,' IN GROUP',I4/) + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMGEQL : STARTING LOOP OVER GRIDS') - 9011 FORMAT ( ' TEST WMGEQL : I, RANK :',2I4) - 9012 FORMAT ( ' GRID ',I3,' HAS SAME RANK') - 9013 FORMAT ( ' ',A) +9010 FORMAT ( ' TEST WMGEQL : STARTING LOOP OVER GRIDS') +9011 FORMAT ( ' TEST WMGEQL : I, RANK :',2I4) +9012 FORMAT ( ' GRID ',I3,' HAS SAME RANK') +9013 FORMAT ( ' ',A) #endif -! + ! #ifdef W3_T - 9020 FORMAT ( ' TEST WMGEQL : GENERATING DISTANCE MAP GRID ',I3) - 9024 FORMAT ( ' TEST WMGEQL : FINAL MAP FOR X RANGE ',2I6) - 9025 FORMAT (2X,65I2) +9020 FORMAT ( ' TEST WMGEQL : GENERATING DISTANCE MAP GRID ',I3) +9024 FORMAT ( ' TEST WMGEQL : FINAL MAP FOR X RANGE ',2I6) +9025 FORMAT (2X,65I2) #endif -! + ! #ifdef W3_T - 9030 FORMAT ( ' TEST WMGEQL : DEPENDENCE INFORMATION GRID ',I3) - 9031 FORMAT ( ' CHECKING GRID ',I3) - 9032 FORMAT ( ' POINTS USED/AVAIL :',2I6) - 9033 FORMAT ( ' TOTAL/GRIDS/OUT :',3I6) - 9034 FORMAT ( ' LOCAL PER GRID :',15I6) - 9035 FORMAT ( ' SENDING PER GRID :',15I6) - 9036 FORMAT ( ' TEST WMGEQL : NUMBER OF CONTRIBUTING GRIDS MAP') - 9037 FORMAT (2X,65I2) -#endif -! +9030 FORMAT ( ' TEST WMGEQL : DEPENDENCE INFORMATION GRID ',I3) +9031 FORMAT ( ' CHECKING GRID ',I3) +9032 FORMAT ( ' POINTS USED/AVAIL :',2I6) +9033 FORMAT ( ' TOTAL/GRIDS/OUT :',3I6) +9034 FORMAT ( ' LOCAL PER GRID :',15I6) +9035 FORMAT ( ' SENDING PER GRID :',15I6) +9036 FORMAT ( ' TEST WMGEQL : NUMBER OF CONTRIBUTING GRIDS MAP') +9037 FORMAT (2X,65I2) +#endif + ! #ifdef W3_T - 9040 FORMAT ( ' TEST WMGEQL : GRID ',I2,'-',I2,' CLEAR STORAGE') - 9041 FORMAT ( ' TEST WMGEQL : GRID ',I2,'-',I2,' STORAGE SIZE',I6) - 9042 FORMAT ( ' RECV ',I2,'-',I2,' CLEAR STORAGE') - 9043 FORMAT ( ' RECV ',I2,'-',I2,' STORAGE SIZE',2I6) - 9044 FORMAT ( ' SEND ',I2,'-',I2,' CLEAR STORAGE') - 9045 FORMAT ( ' SEND ',I2,'-',I2,' STORAGE SIZE',I6) -#endif -! +9040 FORMAT ( ' TEST WMGEQL : GRID ',I2,'-',I2,' CLEAR STORAGE') +9041 FORMAT ( ' TEST WMGEQL : GRID ',I2,'-',I2,' STORAGE SIZE',I6) +9042 FORMAT ( ' RECV ',I2,'-',I2,' CLEAR STORAGE') +9043 FORMAT ( ' RECV ',I2,'-',I2,' STORAGE SIZE',2I6) +9044 FORMAT ( ' SEND ',I2,'-',I2,' CLEAR STORAGE') +9045 FORMAT ( ' SEND ',I2,'-',I2,' STORAGE SIZE',I6) +#endif + ! #ifdef W3_T - 9050 FORMAT ( ' TEST WMGEQL : GRDEQL DIMENSIONED AT ',I2) - 9051 FORMAT ( ' TEST WMGEQL : GRDEQL :') - 9052 FORMAT ( ' ',2i4,' : ',20I3) +9050 FORMAT ( ' TEST WMGEQL : GRDEQL DIMENSIONED AT ',I2) +9051 FORMAT ( ' TEST WMGEQL : GRDEQL :') +9052 FORMAT ( ' ',2i4,' : ',20I3) #endif -! + ! #ifdef W3_T5 - 9140 FORMAT ( ' TEST WMGEQL : NO RECEIVING DATA FOR GRID ',I3, & - ' <=====================================') - 9141 FORMAT ( ' TEST WMGEQL : RECEIVING DATA GRID ',I3, & - ' <=====================================') - 9142 FORMAT ( ' RECEIVING FROM GRID(S) ',10I3) - 9143 FORMAT (16X,'COUNT, ISEA, JSEA, WEIGHT / ', & - 'COUNT WEIGHT NR PER GRID') - 9144 FORMAT (I6,F6.2,I6) - 9145 FORMAT (12X,3I6,F6.2,10(' - ',A)) - 9146 FORMAT ( ' TEST WMGEQL : RECEIVING DATA AVG. GRID ',I3) - 9147 FORMAT (12X,I6,I2,4(F8.2,I4,I6)) -#endif -! +9140 FORMAT ( ' TEST WMGEQL : NO RECEIVING DATA FOR GRID ',I3, & + ' <=====================================') +9141 FORMAT ( ' TEST WMGEQL : RECEIVING DATA GRID ',I3, & + ' <=====================================') +9142 FORMAT ( ' RECEIVING FROM GRID(S) ',10I3) +9143 FORMAT (16X,'COUNT, ISEA, JSEA, WEIGHT / ', & + 'COUNT WEIGHT NR PER GRID') +9144 FORMAT (I6,F6.2,I6) +9145 FORMAT (12X,3I6,F6.2,10(' - ',A)) +9146 FORMAT ( ' TEST WMGEQL : RECEIVING DATA AVG. GRID ',I3) +9147 FORMAT (12X,I6,I2,4(F8.2,I4,I6)) +#endif + ! #ifdef W3_T6 - 9240 FORMAT ( ' TEST WMGEQL : NO SENDING DATA FOR GRID ',I3, & - ' <=====================================') - 9241 FORMAT ( ' TEST WMGEQL : SENDING DATA GRID ',I3, & - ' <====================================='/ & - 11X,'COUNT, ISEA, JSEA, ARRAY IND., PROC, TAG') - 9242 FORMAT ( ' ',4I8,I4,2I8) -#endif -! +9240 FORMAT ( ' TEST WMGEQL : NO SENDING DATA FOR GRID ',I3, & + ' <=====================================') +9241 FORMAT ( ' TEST WMGEQL : SENDING DATA GRID ',I3, & + ' <====================================='/ & + 11X,'COUNT, ISEA, JSEA, ARRAY IND., PROC, TAG') +9242 FORMAT ( ' ',4I8,I4,2I8) +#endif + ! #ifdef W3_T7 - 9330 FORMAT ( ' TEST WMGEQL : FULL SOURCE INFO GRID ',I3, & - ' <=====================================') - 9331 FORMAT ( ' GRID ',I3,' IS NOT OF SAME RANK') - 9332 FORMAT ( ' GRID ',I3,' CONTRIBUTES TO',I6, & - ' GRID POINTS'/ & - 18X,'<---------- GRID',I6,' ---------->', & - 4X,'<----------- GRID',I6,' ----------->'/ & - 18X,'NR IX IY ISEA JSEA IP WGTH', & - 2X,' WGTH NA ISEA JSEA IP WGTH TAG' ) - 9333 FORMAT (15X,3I5,2I6,I4,F6.2,2X,F6.2,I4,2I6,I4,F6.2,I6) - 9334 FORMAT (64X,2I6,I4,F6.2,I6) -#endif -!/ -!/ End of WMGEQL ----------------------------------------------------- / -!/ - END SUBROUTINE WMGEQL -!/ ------------------------------------------------------------------- / -!> -!> @brief Generate map with flags for need of spectral grid conversion -!> between models. -!> -!> @details Test of parameters as introduced before in W3IOBC. -!> -!> @author H. L. Tolman @date 10-Dec-2014 -!> - SUBROUTINE WMRSPC -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 22-Sep-2005 : Origination. ( version 3.08 ) -!/ 25-Jul-2006 : Point output grid added. ( version 3.10 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Generate map with flogs for need of spectral grid conversion -! between models. -! -! 2. Method : -! -! Test of parameters as introduced before in W3IOBC. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINIT Subr WMINITMD Multi-grid model initialization. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3SERVMD, ONLY: EXTCDE +9330 FORMAT ( ' TEST WMGEQL : FULL SOURCE INFO GRID ',I3, & + ' <=====================================') +9331 FORMAT ( ' GRID ',I3,' IS NOT OF SAME RANK') +9332 FORMAT ( ' GRID ',I3,' CONTRIBUTES TO',I6, & + ' GRID POINTS'/ & + 18X,'<---------- GRID',I6,' ---------->', & + 4X,'<----------- GRID',I6,' ----------->'/ & + 18X,'NR IX IY ISEA JSEA IP WGTH', & + 2X,' WGTH NA ISEA JSEA IP WGTH TAG' ) +9333 FORMAT (15X,3I5,2I6,I4,F6.2,2X,F6.2,I4,2I6,I4,F6.2,I6) +9334 FORMAT (64X,2I6,I4,F6.2,I6) +#endif + !/ + !/ End of WMGEQL ----------------------------------------------------- / + !/ + END SUBROUTINE WMGEQL + !/ ------------------------------------------------------------------- / + !> + !> @brief Generate map with flags for need of spectral grid conversion + !> between models. + !> + !> @details Test of parameters as introduced before in W3IOBC. + !> + !> @author H. L. Tolman @date 10-Dec-2014 + !> + SUBROUTINE WMRSPC + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 22-Sep-2005 : Origination. ( version 3.08 ) + !/ 25-Jul-2006 : Point output grid added. ( version 3.10 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Generate map with flogs for need of spectral grid conversion + ! between models. + ! + ! 2. Method : + ! + ! Test of parameters as introduced before in W3IOBC. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINIT Subr WMINITMD Multi-grid model initialization. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD - USE W3ODATMD, ONLY: UNIPTS - USE WMMDATMD -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, J, LOW + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD + USE W3ODATMD, ONLY: UNIPTS + USE WMMDATMD + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, J, LOW #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMRSPC') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! - IF ( UNIPTS ) THEN - LOW = 0 - ELSE - LOW = 1 - END IF - IF ( .NOT. ALLOCATED(RESPEC) ) THEN - ALLOCATE ( RESPEC(LOW:NRGRD,LOW:NRGRD), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - RESPEC = .FALSE. -! -! -------------------------------------------------------------------- / -! 1. Fill map with flags -! - DO I=LOW, NRGRD - DO J=I+1, NRGRD - RESPEC(I,J) = SGRDS(I)%NK .NE. SGRDS(J)%NK .OR. & - SGRDS(I)%NTH .NE. SGRDS(J)%NTH .OR. & - SGRDS(I)%XFR .NE. SGRDS(J)%XFR .OR. & - SGRDS(I)%FR1 .NE. SGRDS(J)%FR1 .OR. & - SGRDS(I)%TH(1) .NE. SGRDS(J)%TH(1) - RESPEC(J,I) = RESPEC(I,J) - END DO - END DO -! -! -------------------------------------------------------------------- / -! 2. Test output -! + CALL STRACE (IENT, 'WMRSPC') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! + IF ( UNIPTS ) THEN + LOW = 0 + ELSE + LOW = 1 + END IF + IF ( .NOT. ALLOCATED(RESPEC) ) THEN + ALLOCATE ( RESPEC(LOW:NRGRD,LOW:NRGRD), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + RESPEC = .FALSE. + ! + ! -------------------------------------------------------------------- / + ! 1. Fill map with flags + ! + DO I=LOW, NRGRD + DO J=I+1, NRGRD + RESPEC(I,J) = SGRDS(I)%NK .NE. SGRDS(J)%NK .OR. & + SGRDS(I)%NTH .NE. SGRDS(J)%NTH .OR. & + SGRDS(I)%XFR .NE. SGRDS(J)%XFR .OR. & + SGRDS(I)%FR1 .NE. SGRDS(J)%FR1 .OR. & + SGRDS(I)%TH(1) .NE. SGRDS(J)%TH(1) + RESPEC(J,I) = RESPEC(I,J) + END DO + END DO + ! + ! -------------------------------------------------------------------- / + ! 2. Test output + ! #ifdef W3_T - WRITE (MDST,9000) - DO I=LOW, NRGRD - WRITE (MDST,9001) I, RESPEC(I,:) - END DO -#endif -! - RETURN -! -! Formats -! + WRITE (MDST,9000) + DO I=LOW, NRGRD + WRITE (MDST,9001) I, RESPEC(I,:) + END DO +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( 'TEST WMRSPC : MAP RESPEC FILLED ') - 9001 FORMAT ( ' ',I4,' : ',20L2) -#endif -!/ -!/ End of WMRSPC ----------------------------------------------------- / -!/ - END SUBROUTINE WMRSPC -!/ -!! -!> -!> @brief Determine relations to same ranked SMC grids for each grid. -!> -!> @details Set boundary points update for regular grid in same ranked group. -!> -!> Cross mapping of grid points, use nearest sea points and no -!> interpolation is required so far. -!> -!> @author J G Li @date 12-Apr-2021 -!> - SUBROUTINE WMSMCEQL -!! -!! Adapted from multi-grid sub WMGEQL for set up equal ranked SMC -!! grid boundary points. JGLi10Aug2020 -!! Move boundary point matching to sub-grid root PEs and broadcast to -!! all other PEs. JGLi02Dec2020 -!! Clear bugs for 3 sub-grids case and finalise output messages. -!! JGLi26Jan2021 -!! Add regular grid to SMC grid same ranked group. -!! JGLi12Apr2021 -!! -! 1. Purpose : -! -! Determine relations to same ranked SMC grids for each grid. -! Set boundary points update for regular grid in same ranked group. -! -! 2. Method : -! -! Cross mapping of grid points, use nearest sea points and no -! interpolation is required so far. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG, W3SETO, WMSETM -! Subr. W3GDATMD Manage data structures. -! W3SMCGMP, Subr. W3PSMCMD Mapping Lon-Lat points to SMC grid cells. -! W3SMCELL, Subr. W3PSMCMD Find Lon-Lat for SMC grid cell centre. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! SMC J sub-grid has own boundary cell number W3GDATMD's NBSMC and -! their ID list are stored in W3GDATMD's GRIDS(J)%ISMCBP(NBSMC), -! which are the global ISEA values of the NBSMC boundary cells. -! So there is no need to look for boundary points, but just -! fetching the boundary cell list from each SMC sub-grid. -! No interpolation is required as one to one correspondance is -! assumed among SMC sub-grid boundary points. JGLi06Nov2020 -! Sub WMIOEG and WMIOES are modified to use the new EQSTGE array -! for same ranked SMC sub-grids only. JGLi26Jan2021 -! -! 8. Structure : -! -! 9. Switches : -! -! !/PRn Propagation scheme. -! !/SMC For SMC grid. -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! !/MPI Distribbuted memory management. -! !/SHRD Shared memory case. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE CONSTANTS - USE W3GDATMD - USE W3ODATMD - USE W3ADATMD - USE WMMDATMD -! - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT ( 'TEST WMRSPC : MAP RESPEC FILLED ') +9001 FORMAT ( ' ',I4,' : ',20L2) +#endif + !/ + !/ End of WMRSPC ----------------------------------------------------- / + !/ + END SUBROUTINE WMRSPC + !/ + !! + !> + !> @brief Determine relations to same ranked SMC grids for each grid. + !> + !> @details Set boundary points update for regular grid in same ranked group. + !> + !> Cross mapping of grid points, use nearest sea points and no + !> interpolation is required so far. + !> + !> @author J G Li @date 12-Apr-2021 + !> + SUBROUTINE WMSMCEQL + !! + !! Adapted from multi-grid sub WMGEQL for set up equal ranked SMC + !! grid boundary points. JGLi10Aug2020 + !! Move boundary point matching to sub-grid root PEs and broadcast to + !! all other PEs. JGLi02Dec2020 + !! Clear bugs for 3 sub-grids case and finalise output messages. + !! JGLi26Jan2021 + !! Add regular grid to SMC grid same ranked group. + !! JGLi12Apr2021 + !! + ! 1. Purpose : + ! + ! Determine relations to same ranked SMC grids for each grid. + ! Set boundary points update for regular grid in same ranked group. + ! + ! 2. Method : + ! + ! Cross mapping of grid points, use nearest sea points and no + ! interpolation is required so far. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG, W3SETO, WMSETM + ! Subr. W3GDATMD Manage data structures. + ! W3SMCGMP, Subr. W3PSMCMD Mapping Lon-Lat points to SMC grid cells. + ! W3SMCELL, Subr. W3PSMCMD Find Lon-Lat for SMC grid cell centre. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! SMC J sub-grid has own boundary cell number W3GDATMD's NBSMC and + ! their ID list are stored in W3GDATMD's GRIDS(J)%ISMCBP(NBSMC), + ! which are the global ISEA values of the NBSMC boundary cells. + ! So there is no need to look for boundary points, but just + ! fetching the boundary cell list from each SMC sub-grid. + ! No interpolation is required as one to one correspondance is + ! assumed among SMC sub-grid boundary points. JGLi06Nov2020 + ! Sub WMIOEG and WMIOES are modified to use the new EQSTGE array + ! for same ranked SMC sub-grids only. JGLi26Jan2021 + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/PRn Propagation scheme. + ! !/SMC For SMC grid. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! !/MPI Distribbuted memory management. + ! !/SHRD Shared memory case. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE CONSTANTS + USE W3GDATMD + USE W3ODATMD + USE W3ADATMD + USE WMMDATMD + ! + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_SMC - USE W3PSMCMD, ONLY: W3SMCGMP, W3SMCELL + USE W3PSMCMD, ONLY: W3SMCGMP, W3SMCELL #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, J, IX, IY, IXY, JX, JY, NPJ, & - NR, NT, NA, NTL, JJ, NIT, NG, NOUT, & - ISEA, JSEA, IPRC, ITAG, TGRP, NPMX, & - IP, NP, ICROOT, JCROOT, IEER + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, J, IX, IY, IXY, JX, JY, NPJ, & + NR, NT, NA, NTL, JJ, NIT, NG, NOUT, & + ISEA, JSEA, IPRC, ITAG, TGRP, NPMX, & + IP, NP, ICROOT, JCROOT, IEER #ifdef W3_MPI - INTEGER, Dimension(MPI_STATUS_SIZE):: MPIState + INTEGER, Dimension(MPI_STATUS_SIZE):: MPIState #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER, ALLOCATABLE :: NREC(:), NSND(:), NTPP(:), & - IBPTS(:), JBPTS(:), IPBPT(:) - REAL, PARAMETER :: ODIMAX = 25. - REAL, ALLOCATABLE :: XLon(:), YLat(:) - LOGICAL :: CHANGE - LOGICAL, ALLOCATABLE :: SHRANK(:,:), DOGRID(:) + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER, ALLOCATABLE :: NREC(:), NSND(:), NTPP(:), & + IBPTS(:), JBPTS(:), IPBPT(:) + REAL, PARAMETER :: ODIMAX = 25. + REAL, ALLOCATABLE :: XLon(:), YLat(:) + LOGICAL :: CHANGE + LOGICAL, ALLOCATABLE :: SHRANK(:,:), DOGRID(:) #ifdef W3_T5 - CHARACTER(LEN=18), ALLOCATABLE :: TSTR(:) - CHARACTER(LEN=18) :: DSTR -#endif -! - TYPE STORE - INTEGER :: NTOT, NFIN - INTEGER, POINTER :: ICVBP(:), MSDBP(:), ISS(:), JSS(:), & - JCVBP(:), IPCVB(:), IPS(:), ITG(:) - LOGICAL, POINTER :: FLA(:) - LOGICAL :: INIT - END TYPE STORE -! - TYPE(STORE), ALLOCATABLE :: STORES(:,:) -!/ + CHARACTER(LEN=18), ALLOCATABLE :: TSTR(:) + CHARACTER(LEN=18) :: DSTR +#endif + ! + TYPE STORE + INTEGER :: NTOT, NFIN + INTEGER, POINTER :: ICVBP(:), MSDBP(:), ISS(:), JSS(:), & + JCVBP(:), IPCVB(:), IPS(:), ITG(:) + LOGICAL, POINTER :: FLA(:) + LOGICAL :: INIT + END TYPE STORE + ! + TYPE(STORE), ALLOCATABLE :: STORES(:,:) + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMSMCEQL ') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! - ALLOCATE ( SHRANK(NRGRD,NRGRD), STORES(NRGRD,NRGRD), & - DOGRID(NRGRD), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - SHRANK = .FALSE. -! - DO I=1, NRGRD - - DO J=1, NRGRD - STORES(I,J)%INIT = .FALSE. - STORES(I,J)%NTOT = 0 - STORES(I,J)%NFIN = 0 - END DO - END DO -! - ITAG = 0 -! -! -------------------------------------------------------------------- / -! 1. Grid point relations and temp data storage -! 1.a Outer loop over all grids -! + CALL STRACE (IENT, 'WMSMCEQL ') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! + ALLOCATE ( SHRANK(NRGRD,NRGRD), STORES(NRGRD,NRGRD), & + DOGRID(NRGRD), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + SHRANK = .FALSE. + ! + DO I=1, NRGRD + + DO J=1, NRGRD + STORES(I,J)%INIT = .FALSE. + STORES(I,J)%NTOT = 0 + STORES(I,J)%NFIN = 0 + END DO + END DO + ! + ITAG = 0 + ! + ! -------------------------------------------------------------------- / + ! 1. Grid point relations and temp data storage + ! 1.a Outer loop over all grids + ! #ifdef W3_T - WRITE (MDST,9010) + WRITE (MDST,9010) #endif -! - DO I=1, NRGRD + ! + DO I=1, NRGRD #ifdef W3_T - WRITE (MDST,9011) I, GRANK(I) -#endif -! -! 1.b Find sub grids with same rank -! - NR = 0 -! - DO J=1, NRGRD - IF( (GRANK(I).NE.GRANK(J)) .OR. (I.EQ.J) ) CYCLE - SHRANK(I,J) = .TRUE. - NR = NR + 1 - END DO -! - DOGRID(I) = NR .GT. 0 -! - IF( NR .EQ. 0 ) CYCLE -! - CALL W3SETG( I, MDSE, MDST ) -! -! Find local root PE and NAPROC for I grid. + WRITE (MDST,9011) I, GRANK(I) +#endif + ! + ! 1.b Find sub grids with same rank + ! + NR = 0 + ! + DO J=1, NRGRD + IF( (GRANK(I).NE.GRANK(J)) .OR. (I.EQ.J) ) CYCLE + SHRANK(I,J) = .TRUE. + NR = NR + 1 + END DO + ! + DOGRID(I) = NR .GT. 0 + ! + IF( NR .EQ. 0 ) CYCLE + ! + CALL W3SETG( I, MDSE, MDST ) + ! + ! Find local root PE and NAPROC for I grid. #ifdef W3_SHRD - ICROOT = 1 + ICROOT = 1 #endif #ifdef W3_MPI - ICROOT = MDATAS(I)%CROOT -#endif - NP = OUTPTS(I)%NAPROC -! -! 1.c Fetch Grid I boundary points. -! - NT = 0 - IF( GRIDS(I)%GTYPE .EQ. RLGTYPE ) THEN -! 1.c.1 Regular grid I boundary points are stored in NBI. - NT = OUTPTS(I)%OUT5%NBI + ICROOT = MDATAS(I)%CROOT +#endif + NP = OUTPTS(I)%NAPROC + ! + ! 1.c Fetch Grid I boundary points. + ! + NT = 0 + IF( GRIDS(I)%GTYPE .EQ. RLGTYPE ) THEN + ! 1.c.1 Regular grid I boundary points are stored in NBI. + NT = OUTPTS(I)%OUT5%NBI #ifdef W3_MPI - IF( IMPROC .EQ. ICROOT ) THEN + IF( IMPROC .EQ. ICROOT ) THEN #endif - WRITE(MDSE,*) "ICROOT, NT are", ICROOT, NT + WRITE(MDSE,*) "ICROOT, NT are", ICROOT, NT #ifdef W3_MPI - ENDIF + ENDIF #endif -! -! 1.c.2 SMC grid I boundary cell ids are saved in NBSMC. + ! + ! 1.c.2 SMC grid I boundary cell ids are saved in NBSMC. #ifdef W3_SMC - ELSEIF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN + ELSEIF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN #endif #ifdef W3_MPI #ifdef W3_SMC - IF( IMPROC .EQ. ICROOT ) THEN + IF( IMPROC .EQ. ICROOT ) THEN #endif #endif #ifdef W3_SMC - NT = GRIDS(I)%NBSMC - WRITE(MDSE,*) "ICROOT, NT are", ICROOT, NT + NT = GRIDS(I)%NBSMC + WRITE(MDSE,*) "ICROOT, NT are", ICROOT, NT #endif #ifdef W3_MPI #ifdef W3_SMC - ENDIF + ENDIF #endif #endif #ifdef W3_MPI #ifdef W3_SMC - CALL MPI_BCAST( NT, 1, MPI_INTEGER, & - ICROOT-1, MPI_COMM_MWAVE, IEER) + CALL MPI_BCAST( NT, 1, MPI_INTEGER, & + ICROOT-1, MPI_COMM_MWAVE, IEER) #endif #endif -! Need to wait for all PEs get these values. + ! Need to wait for all PEs get these values. #ifdef W3_MPI #ifdef W3_SMC - CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) + CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) #endif #endif -! - ENDIF !! GTYPE .EQ. RLGTYPE -! - IF( NT .EQ. 0 ) CYCLE + ! + ENDIF !! GTYPE .EQ. RLGTYPE + ! + IF( NT .EQ. 0 ) CYCLE - IF( NT > 0 ) THEN - ALLOCATE( IBPTS(NT), JBPTS(NT), IPBPT(NT), & - XLon(NT), YLat(NT), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + IF( NT > 0 ) THEN + ALLOCATE( IBPTS(NT), JBPTS(NT), IPBPT(NT), & + XLon(NT), YLat(NT), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) -! Use saved I-grid boundary cell list. + ! Use saved I-grid boundary cell list. #ifdef W3_MPI - IF( IMPROC .EQ. ICROOT ) THEN -#endif - IF( GRIDS(I)%GTYPE .EQ. RLGTYPE ) THEN -!! Loop over regular grid mesh to find boundary points. - IXY = 0 - DO ISEA=1, NSEA - IX = MAPSF(ISEA, 1) - IY = MAPSF(ISEA, 2) - IF( ABS(MAPSTA(IY,IX)) .EQ. 2 ) THEN - IXY = IXY + 1 - XLon (IXY) = REAL(XGRD(IY,IX)) - YLat (IXY) = REAL(YGRD(IY,IX)) - IBPTS(IXY) = ISEA - JBPTS(IXY) = 1 + (ISEA - 1)/NP - IPBPT(IXY) = ICROOT-1 + ISEA-(JBPTS(IXY)-1)*NP - ENDIF - ENDDO -! + IF( IMPROC .EQ. ICROOT ) THEN +#endif + IF( GRIDS(I)%GTYPE .EQ. RLGTYPE ) THEN + !! Loop over regular grid mesh to find boundary points. + IXY = 0 + DO ISEA=1, NSEA + IX = MAPSF(ISEA, 1) + IY = MAPSF(ISEA, 2) + IF( ABS(MAPSTA(IY,IX)) .EQ. 2 ) THEN + IXY = IXY + 1 + XLon (IXY) = REAL(XGRD(IY,IX)) + YLat (IXY) = REAL(YGRD(IY,IX)) + IBPTS(IXY) = ISEA + JBPTS(IXY) = 1 + (ISEA - 1)/NP + IPBPT(IXY) = ICROOT-1 + ISEA-(JBPTS(IXY)-1)*NP + ENDIF + ENDDO + ! #ifdef W3_SMC - ELSEIF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN + ELSEIF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN - IBPTS = GRIDS(I)%ISMCBP(1:NT) - CALL W3SMCELL( I, NT, IBPTS, XLon, YLat ) - DO IX = 1, NT + IBPTS = GRIDS(I)%ISMCBP(1:NT) + CALL W3SMCELL( I, NT, IBPTS, XLon, YLat ) + DO IX = 1, NT #endif -! Global processor IPBPT and local JSEA, for ISEA spectrum in I grid. + ! Global processor IPBPT and local JSEA, for ISEA spectrum in I grid. #ifdef W3_SMC - ISEA = IBPTS(IX) - JSEA = 1 + (ISEA - 1)/NP - IPBPT(IX) = ICROOT - 1 + ISEA - (JSEA - 1)*NP - JBPTS(IX) = JSEA - ENDDO -#endif -! - ENDIF !! RLGTYPE + ISEA = IBPTS(IX) + JSEA = 1 + (ISEA - 1)/NP + IPBPT(IX) = ICROOT - 1 + ISEA - (JSEA - 1)*NP + JBPTS(IX) = JSEA + ENDDO +#endif + ! + ENDIF !! RLGTYPE #ifdef W3_MPI - ENDIF !! ICROOT + ENDIF !! ICROOT #endif -! -! All have to wait for ICROOT finishes conversion of cell ids to XLon-YLat + ! + ! All have to wait for ICROOT finishes conversion of cell ids to XLon-YLat #ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) + CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) #endif -! -! Then broadcast IBPTS, IPBPT, XLon, and YLat to all PEs + ! + ! Then broadcast IBPTS, IPBPT, XLon, and YLat to all PEs #ifdef W3_MPI - CALL MPI_BCAST( IBPTS(1), NT, MPI_INTEGER, & - ICROOT-1, MPI_COMM_MWAVE, IEER) - CALL MPI_BCAST( JBPTS(1), NT, MPI_INTEGER, & - ICROOT-1, MPI_COMM_MWAVE, IEER) - CALL MPI_BCAST( IPBPT(1), NT, MPI_INTEGER, & - ICROOT-1, MPI_COMM_MWAVE, IEER) - CALL MPI_BCAST( XLon(1), NT, MPI_REAL, & - ICROOT-1, MPI_COMM_MWAVE, IEER) - CALL MPI_BCAST( YLat(1), NT, MPI_REAL, & - ICROOT-1, MPI_COMM_MWAVE, IEER) -#endif - -! 1.d Loop over J grids, select same rank -! - DO J=1, NRGRD - - IF( .NOT. SHRANK(I,J) ) CYCLE -!! Only SMC J-grid provides boundary spectra for I-Grid. - IF( GRIDS(J)%GTYPE .NE. SMCTYPE ) CYCLE -! -! Find local root PE and NAPROC for J grid. + CALL MPI_BCAST( IBPTS(1), NT, MPI_INTEGER, & + ICROOT-1, MPI_COMM_MWAVE, IEER) + CALL MPI_BCAST( JBPTS(1), NT, MPI_INTEGER, & + ICROOT-1, MPI_COMM_MWAVE, IEER) + CALL MPI_BCAST( IPBPT(1), NT, MPI_INTEGER, & + ICROOT-1, MPI_COMM_MWAVE, IEER) + CALL MPI_BCAST( XLon(1), NT, MPI_REAL, & + ICROOT-1, MPI_COMM_MWAVE, IEER) + CALL MPI_BCAST( YLat(1), NT, MPI_REAL, & + ICROOT-1, MPI_COMM_MWAVE, IEER) +#endif + + ! 1.d Loop over J grids, select same rank + ! + DO J=1, NRGRD + + IF( .NOT. SHRANK(I,J) ) CYCLE + !! Only SMC J-grid provides boundary spectra for I-Grid. + IF( GRIDS(J)%GTYPE .NE. SMCTYPE ) CYCLE + ! + ! Find local root PE and NAPROC for J grid. #ifdef W3_SHRD - JCROOT = 1 + JCROOT = 1 #endif #ifdef W3_MPI - JCROOT = MDATAS(J)%CROOT -#endif - NPJ = OUTPTS(J)%NAPROC -! -! Find out whether any I-grid boundary points matched in J-Grid. -! - STORES(I,J)%INIT = .TRUE. - ALLOCATE( STORES(I,J)%ICVBP(NT), STORES(I,J)%MSDBP(NT), & - STORES(I,J)%JCVBP(NT), STORES(I,J)%IPCVB(NT), & - STORES(I,J)%ISS(NT), STORES(I,J)%JSS(NT), & - STORES(I,J)%IPS(NT), STORES(I,J)%ITG(NT), & - STORES(I,J)%FLA(NT), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - STORES(I,J)%ICVBP = 0 - STORES(I,J)%JCVBP = 0 - STORES(I,J)%IPCVB = 0 - STORES(I,J)%MSDBP = 0 - STORES(I,J)%ISS = 0 - STORES(I,J)%JSS = 0 - STORES(I,J)%IPS = 0 - STORES(I,J)%ITG = 0 - STORES(I,J)%FLA = .FALSE. -! -! Work out which I-grid bounary points are matched in J-grid on JCROOT. + JCROOT = MDATAS(J)%CROOT +#endif + NPJ = OUTPTS(J)%NAPROC + ! + ! Find out whether any I-grid boundary points matched in J-Grid. + ! + STORES(I,J)%INIT = .TRUE. + ALLOCATE( STORES(I,J)%ICVBP(NT), STORES(I,J)%MSDBP(NT), & + STORES(I,J)%JCVBP(NT), STORES(I,J)%IPCVB(NT), & + STORES(I,J)%ISS(NT), STORES(I,J)%JSS(NT), & + STORES(I,J)%IPS(NT), STORES(I,J)%ITG(NT), & + STORES(I,J)%FLA(NT), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + STORES(I,J)%ICVBP = 0 + STORES(I,J)%JCVBP = 0 + STORES(I,J)%IPCVB = 0 + STORES(I,J)%MSDBP = 0 + STORES(I,J)%ISS = 0 + STORES(I,J)%JSS = 0 + STORES(I,J)%IPS = 0 + STORES(I,J)%ITG = 0 + STORES(I,J)%FLA = .FALSE. + ! + ! Work out which I-grid bounary points are matched in J-grid on JCROOT. #ifdef W3_MPI #ifdef W3_SMC IF( IMPROC .EQ. JCROOT ) THEN #endif #endif #ifdef W3_SMC - CALL W3SMCGMP( J, NT, XLon, YLat, STORES(I,J)%MSDBP ) + CALL W3SMCGMP( J, NT, XLon, YLat, STORES(I,J)%MSDBP ) #endif #ifdef W3_MPI #ifdef W3_SMC ENDIF #endif #endif -! -! Then broadcast the results to all PEs + ! + ! Then broadcast the results to all PEs #ifdef W3_MPI #ifdef W3_SMC CALL MPI_BCAST( STORES(I,J)%MSDBP(1), NT, MPI_INTEGER, & - JCROOT-1, MPI_COMM_MWAVE, IEER) + JCROOT-1, MPI_COMM_MWAVE, IEER) #endif #endif -! -! Need to wait for all PEs get these values. + ! + ! Need to wait for all PEs get these values. #ifdef W3_MPI #ifdef W3_SMC CALL MPI_BARRIER( MPI_COMM_MWAVE, IEER) #endif #endif -! + ! #ifdef W3_SMC - STORES(I,J)%ICVBP = IBPTS - STORES(I,J)%JCVBP = JBPTS - STORES(I,J)%IPCVB = IPBPT -#endif -! -! Check which I-grid boundary points matched inside J-Grid - NTL= 0 - DO JX=1, NT - IF( STORES(I,J)%MSDBP(JX) .EQ. 0 ) CYCLE - -! Process J-grid send point if it matches I-grid boundary point. - NTL = NTL + 1 - ITAG = ITAG + 1 - ISEA = STORES(I,J)%MSDBP(JX) -! Find global processor IPRC and local JSEA on J-grid, holding ISEA spectrum. - JSEA = 1 + (ISEA - 1)/NPJ - IPRC = JCROOT - 1 + ISEA - (JSEA - 1)*NPJ -! Store these spectral location info in STORES. - STORES(I,J)%ISS(JX) = ISEA - STORES(I,J)%JSS(JX) = JSEA - STORES(I,J)%IPS(JX) = IPRC - STORES(I,J)%ITG(JX) = ITAG - STORES(I,J)%FLA(JX) = .TRUE. - END DO -! -! SMC grid boundary points are supposed to be 1 to 1 correspondant -! so there is no need for interpolation. JGLi03Nov2020 -! - STORES(I,J)%NTOT = NT - STORES(I,J)%NFIN = NTL -! + STORES(I,J)%ICVBP = IBPTS + STORES(I,J)%JCVBP = JBPTS + STORES(I,J)%IPCVB = IPBPT +#endif + ! + ! Check which I-grid boundary points matched inside J-Grid + NTL= 0 + DO JX=1, NT + IF( STORES(I,J)%MSDBP(JX) .EQ. 0 ) CYCLE + + ! Process J-grid send point if it matches I-grid boundary point. + NTL = NTL + 1 + ITAG = ITAG + 1 + ISEA = STORES(I,J)%MSDBP(JX) + ! Find global processor IPRC and local JSEA on J-grid, holding ISEA spectrum. + JSEA = 1 + (ISEA - 1)/NPJ + IPRC = JCROOT - 1 + ISEA - (JSEA - 1)*NPJ + ! Store these spectral location info in STORES. + STORES(I,J)%ISS(JX) = ISEA + STORES(I,J)%JSS(JX) = JSEA + STORES(I,J)%IPS(JX) = IPRC + STORES(I,J)%ITG(JX) = ITAG + STORES(I,J)%FLA(JX) = .TRUE. + END DO + ! + ! SMC grid boundary points are supposed to be 1 to 1 correspondant + ! so there is no need for interpolation. JGLi03Nov2020 + ! + STORES(I,J)%NTOT = NT + STORES(I,J)%NFIN = NTL + ! #ifdef W3_MPI #ifdef W3_SMC IF( IMPROC .EQ. NMPERR ) & #endif #endif #ifdef W3_SMC - WRITE(MDSE,1060) I, NT, J, NTL + WRITE(MDSE,1060) I, NT, J, NTL #endif -! -! ... End of loops J in 1.c - END DO -! -!! Free temporary space for I-grid. - DEALLOCATE( IBPTS, JBPTS, IPBPT, XLon, YLat, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) + ! + ! ... End of loops J in 1.c + END DO + ! + !! Free temporary space for I-grid. + DEALLOCATE( IBPTS, JBPTS, IPBPT, XLon, YLat, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) - END IF ! NT > 0 -! -! ... End of 1.a loop I grid. - END DO -! -! -------------------------------------------------------------------- / -! 3. Final data base (full data base, scratched at end of routine) -! 3.a Loop over grids -! - ALLOCATE( NREC(NRGRD), NSND(NRGRD), NTPP(NMPROC), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - DO I=1, NRGRD - IF ( .NOT. DOGRID(I) ) CYCLE + END IF ! NT > 0 + ! + ! ... End of 1.a loop I grid. + END DO + ! + ! -------------------------------------------------------------------- / + ! 3. Final data base (full data base, scratched at end of routine) + ! 3.a Loop over grids + ! + ALLOCATE( NREC(NRGRD), NSND(NRGRD), NTPP(NMPROC), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + DO I=1, NRGRD + IF ( .NOT. DOGRID(I) ) CYCLE #ifdef W3_T - WRITE (MDST,9030) I -#endif -! - CALL W3SETG ( I, MDSE, MDST ) - CALL W3SETO ( I, MDSE, MDST ) - CALL WMSETM ( I, MDSE, MDST ) -! - NREC = 0 - NSND = 0 -! -! Find local root PE and maximum PE for I grid. + WRITE (MDST,9030) I +#endif + ! + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + CALL WMSETM ( I, MDSE, MDST ) + ! + NREC = 0 + NSND = 0 + ! + ! Find local root PE and maximum PE for I grid. #ifdef W3_SHRD - ICROOT = 1 + ICROOT = 1 #endif #ifdef W3_MPI - ICROOT = MDATAS(I)%CROOT -#endif - NPMX = OUTPTS(I)%NAPROC + ICROOT - 1 -! -! 3.b Filling NREC and NSND for grid I -! -!! Work out how many I-grid boundary points to be updated by other grids. -!! Use matched J-grid points to selected I-grid points. JGLi26Jan2021 - DO J=1, NRGRD - IF( .NOT. SHRANK(I,J) ) CYCLE - IF( STORES(I,J)%NFIN > 0 ) THEN - DO IX = 1, STORES(I,J)%NTOT - IF( STORES(I,J)%MSDBP(IX) > 0 .AND. & - STORES(I,J)%IPCVB(IX) .EQ. IMPROC ) THEN - NREC(I) = NREC(I) + 1 - NREC(J) = NREC(J) + 1 - END IF - END DO - END IF - END DO - -! Accumulate all related I-Grid points to be send to other sub-grids. -! Add IPRC range check to ensure sending from I-grid. JGLi22Jan2021 - DO J=1, NRGRD - IF( .NOT. SHRANK(J,I) ) CYCLE - IF( STORES(J,I)%NFIN > 0 ) THEN - DO IY=1, STORES(J,I)%NTOT - IF( STORES(J,I)%MSDBP(IY) > 0 .AND. & - STORES(J,I)%IPS( IY) .EQ. IMPROC ) THEN - NSND(J) = NSND(J) + 1 - ENDIF - END DO - END IF - END DO -! -! -------------------------------------------------------------------- / -! 4. Save data base as needed in EQSTGE -! -! 4.a ALLOCATE storage -! 4.a.1 Local counters, weights and sea counters (grid 'I') -! - IF( EQSTGE(I,I)%NREC .NE. 0 ) THEN - DEALLOCATE (EQSTGE(I,I)%ISEA, EQSTGE(I,I)%JSEA , & - EQSTGE(I,I)%WGHT, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - EQSTGE(I,I)%NREC = 0 + ICROOT = MDATAS(I)%CROOT +#endif + NPMX = OUTPTS(I)%NAPROC + ICROOT - 1 + ! + ! 3.b Filling NREC and NSND for grid I + ! + !! Work out how many I-grid boundary points to be updated by other grids. + !! Use matched J-grid points to selected I-grid points. JGLi26Jan2021 + DO J=1, NRGRD + IF( .NOT. SHRANK(I,J) ) CYCLE + IF( STORES(I,J)%NFIN > 0 ) THEN + DO IX = 1, STORES(I,J)%NTOT + IF( STORES(I,J)%MSDBP(IX) > 0 .AND. & + STORES(I,J)%IPCVB(IX) .EQ. IMPROC ) THEN + NREC(I) = NREC(I) + 1 + NREC(J) = NREC(J) + 1 + END IF + END DO + END IF + END DO + + ! Accumulate all related I-Grid points to be send to other sub-grids. + ! Add IPRC range check to ensure sending from I-grid. JGLi22Jan2021 + DO J=1, NRGRD + IF( .NOT. SHRANK(J,I) ) CYCLE + IF( STORES(J,I)%NFIN > 0 ) THEN + DO IY=1, STORES(J,I)%NTOT + IF( STORES(J,I)%MSDBP(IY) > 0 .AND. & + STORES(J,I)%IPS( IY) .EQ. IMPROC ) THEN + NSND(J) = NSND(J) + 1 + ENDIF + END DO + END IF + END DO + ! + ! -------------------------------------------------------------------- / + ! 4. Save data base as needed in EQSTGE + ! + ! 4.a ALLOCATE storage + ! 4.a.1 Local counters, weights and sea counters (grid 'I') + ! + IF( EQSTGE(I,I)%NREC .NE. 0 ) THEN + DEALLOCATE (EQSTGE(I,I)%ISEA, EQSTGE(I,I)%JSEA , & + EQSTGE(I,I)%WGHT, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + EQSTGE(I,I)%NREC = 0 #ifdef W3_T - WRITE (MDST,9040) I, I + WRITE (MDST,9040) I, I #endif - END IF -! - IF( NREC(I) .GT. 0 ) THEN - ALLOCATE( EQSTGE(I,I)%ISEA(NREC(I)), & - EQSTGE(I,I)%JSEA(NREC(I)), & - EQSTGE(I,I)%WGHT(NREC(I)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - EQSTGE(I,I)%NREC = NREC(I) + END IF + ! + IF( NREC(I) .GT. 0 ) THEN + ALLOCATE( EQSTGE(I,I)%ISEA(NREC(I)), & + EQSTGE(I,I)%JSEA(NREC(I)), & + EQSTGE(I,I)%WGHT(NREC(I)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + EQSTGE(I,I)%NREC = NREC(I) #ifdef W3_T - WRITE (MDST,9041) I, I, NREC(I) + WRITE (MDST,9041) I, I, NREC(I) #endif + END IF + ! + !! Initial NTOT for grid I before summing over other grids. JGLi18Jan2021 + EQSTGE(I,I)%NTOT = 0 + ! + ! 4.a.1 Local counters, arrays weights etc. (grid 'J' receive) + ! + DO J=1, NRGRD + IF( I .EQ. J ) CYCLE + ! + !! Looks strange to store in EQSTGE(I,I) as other J-grid may + !! overwrite the value. Should be suspended? JGLi30Dec2020 + ! EQSTGE(I,I)%NTOT = STORES(I,J)%NFIN + !! Changed to summation ove all other J-grids NFIN. Not sure where + !! NTOT is used but keep it anyway. JGLi18Jan2021 + EQSTGE(I,I)%NTOT = EQSTGE(I,I)%NTOT + STORES(I,J)%NFIN + ! + IF( EQSTGE(I,J)%NREC .NE. 0 ) THEN + DEALLOCATE( EQSTGE(I,J)%ISEA , EQSTGE(I,J)%JSEA , & + EQSTGE(I,J)%WGHT , EQSTGE(I,J)%SEQL , & + EQSTGE(I,J)%NAVG , EQSTGE(I,J)%WAVG , & + EQSTGE(I,J)%RIP , EQSTGE(I,J)%RTG, & + STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + EQSTGE(I,J)%NREC = 0 + EQSTGE(I,J)%NAVMAX = 1 END IF -! -!! Initial NTOT for grid I before summing over other grids. JGLi18Jan2021 - EQSTGE(I,I)%NTOT = 0 -! -! 4.a.1 Local counters, arrays weights etc. (grid 'J' receive) -! - DO J=1, NRGRD - IF( I .EQ. J ) CYCLE -! -!! Looks strange to store in EQSTGE(I,I) as other J-grid may -!! overwrite the value. Should be suspended? JGLi30Dec2020 -! EQSTGE(I,I)%NTOT = STORES(I,J)%NFIN -!! Changed to summation ove all other J-grids NFIN. Not sure where -!! NTOT is used but keep it anyway. JGLi18Jan2021 - EQSTGE(I,I)%NTOT = EQSTGE(I,I)%NTOT + STORES(I,J)%NFIN -! - IF( EQSTGE(I,J)%NREC .NE. 0 ) THEN - DEALLOCATE( EQSTGE(I,J)%ISEA , EQSTGE(I,J)%JSEA , & - EQSTGE(I,J)%WGHT , EQSTGE(I,J)%SEQL , & - EQSTGE(I,J)%NAVG , EQSTGE(I,J)%WAVG , & - EQSTGE(I,J)%RIP , EQSTGE(I,J)%RTG, & - STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) - EQSTGE(I,J)%NREC = 0 - EQSTGE(I,J)%NAVMAX = 1 - END IF -! - IF( NREC(J) .GT. 0 ) THEN - NA = 1 - EQSTGE(I,J)%NAVMAX = NA - ALLOCATE( EQSTGE(I,J)%ISEA(NREC(J)), & - EQSTGE(I,J)%JSEA(NREC(J)), & - EQSTGE(I,J)%WGHT(NREC(J)), & - EQSTGE(I,J)%SEQL(SGRDS(J)%NSPEC,NREC(J),NA), & - EQSTGE(I,J)%NAVG(NREC(J)), & - EQSTGE(I,J)%WAVG(NREC(J),NA), & - EQSTGE(I,J)%RIP( NREC(J),NA), & - EQSTGE(I,J)%RTG( NREC(J),NA), STAT=ISTAT ) - CHECK_ALLOC_STATUS( ISTAT ) - EQSTGE(I,J)%NREC = NREC(J) - END IF -! - IF( EQSTGE(J,I)%NSND .NE. 0 ) THEN - DEALLOCATE( EQSTGE(J,I)%SIS, EQSTGE(J,I)%SJS , & - EQSTGE(J,I)%SI1, EQSTGE(J,I)%SI2 , & - EQSTGE(J,I)%SIP, EQSTGE(J,I)%STG, STAT=ISTAT) - CHECK_DEALLOC_STATUS( ISTAT ) - EQSTGE(J,I)%NSND = 0 - END IF -! - IF( NSND(J) .GT. 0 ) THEN - ALLOCATE( EQSTGE(J,I)%SIS(NSND(J)), & - EQSTGE(J,I)%SJS(NSND(J)), & - EQSTGE(J,I)%SI1(NSND(J)), & - EQSTGE(J,I)%SI2(NSND(J)), & - EQSTGE(J,I)%SIP(NSND(J)), & - EQSTGE(J,I)%STG(NSND(J)), STAT=ISTAT ) - CHECK_ALLOC_STATUS( ISTAT ) - EQSTGE(J,I)%NSND = NSND(J) + ! + IF( NREC(J) .GT. 0 ) THEN + NA = 1 + EQSTGE(I,J)%NAVMAX = NA + ALLOCATE( EQSTGE(I,J)%ISEA(NREC(J)), & + EQSTGE(I,J)%JSEA(NREC(J)), & + EQSTGE(I,J)%WGHT(NREC(J)), & + EQSTGE(I,J)%SEQL(SGRDS(J)%NSPEC,NREC(J),NA), & + EQSTGE(I,J)%NAVG(NREC(J)), & + EQSTGE(I,J)%WAVG(NREC(J),NA), & + EQSTGE(I,J)%RIP( NREC(J),NA), & + EQSTGE(I,J)%RTG( NREC(J),NA), STAT=ISTAT ) + CHECK_ALLOC_STATUS( ISTAT ) + EQSTGE(I,J)%NREC = NREC(J) + END IF + ! + IF( EQSTGE(J,I)%NSND .NE. 0 ) THEN + DEALLOCATE( EQSTGE(J,I)%SIS, EQSTGE(J,I)%SJS , & + EQSTGE(J,I)%SI1, EQSTGE(J,I)%SI2 , & + EQSTGE(J,I)%SIP, EQSTGE(J,I)%STG, STAT=ISTAT) + CHECK_DEALLOC_STATUS( ISTAT ) + EQSTGE(J,I)%NSND = 0 + END IF + ! + IF( NSND(J) .GT. 0 ) THEN + ALLOCATE( EQSTGE(J,I)%SIS(NSND(J)), & + EQSTGE(J,I)%SJS(NSND(J)), & + EQSTGE(J,I)%SI1(NSND(J)), & + EQSTGE(J,I)%SI2(NSND(J)), & + EQSTGE(J,I)%SIP(NSND(J)), & + EQSTGE(J,I)%STG(NSND(J)), STAT=ISTAT ) + CHECK_ALLOC_STATUS( ISTAT ) + EQSTGE(J,I)%NSND = NSND(J) + END IF + ! + END DO + ! + ! 4.b Store data in EQSTGE + ! 4.b.1 Grid I (JSEA and weight only) also filled in J-Grid loop + ! but it accumulates all points received by I-grid. + NT = 0 + ! + ! 4.b.2 Info for I-grid receiving from all other grids + DO J=1, NRGRD + IF( .NOT. SHRANK(I,J) ) CYCLE + IF( EQSTGE(I,J)%NREC .EQ. 0 ) CYCLE + NTL = 0 + DO IX=1, STORES(I,J)%NTOT + IF( STORES(I,J)%MSDBP(IX) > 0 .AND. & + STORES(I,J)%IPCVB(IX) .EQ. IMPROC ) THEN + ! All points received by I-grid accumulated from each J-grid. + NT = NT + 1 + EQSTGE(I,I)%ISEA(NT) = STORES(I,J)%ICVBP(IX) + EQSTGE(I,I)%JSEA(NT) = STORES(I,J)%JCVBP(IX) + ! No need to alter local spectra for SMC grid. JGLi08Dec2020 + EQSTGE(I,I)%WGHT(NT) = 1.0 + + ! Boundary points received by I-grid from J-grid. + NTL = NTL + 1 + EQSTGE(I,J)%ISEA(NTL) = STORES(I,J)%ICVBP(IX) + EQSTGE(I,J)%JSEA(NTL) = STORES(I,J)%JCVBP(IX) + !! Boundary spectra will be substituted fully. JGLi08Dec2020 + EQSTGE(I,J)%WGHT(NTL) = 1.0 + EQSTGE(I,J)%NAVG(NTL) = 1 + EQSTGE(I,J)%WAVG(NTL,1) = 1.0 + EQSTGE(I,J)%RIP (NTL,1) = STORES(I,J)%IPS(IX) + EQSTGE(I,J)%RTG (NTL,1) = STORES(I,J)%ITG(IX) END IF -! END DO -! -! 4.b Store data in EQSTGE -! 4.b.1 Grid I (JSEA and weight only) also filled in J-Grid loop -! but it accumulates all points received by I-grid. - NT = 0 -! -! 4.b.2 Info for I-grid receiving from all other grids - DO J=1, NRGRD - IF( .NOT. SHRANK(I,J) ) CYCLE - IF( EQSTGE(I,J)%NREC .EQ. 0 ) CYCLE - NTL = 0 - DO IX=1, STORES(I,J)%NTOT - IF( STORES(I,J)%MSDBP(IX) > 0 .AND. & - STORES(I,J)%IPCVB(IX) .EQ. IMPROC ) THEN -! All points received by I-grid accumulated from each J-grid. - NT = NT + 1 - EQSTGE(I,I)%ISEA(NT) = STORES(I,J)%ICVBP(IX) - EQSTGE(I,I)%JSEA(NT) = STORES(I,J)%JCVBP(IX) -! No need to alter local spectra for SMC grid. JGLi08Dec2020 - EQSTGE(I,I)%WGHT(NT) = 1.0 - -! Boundary points received by I-grid from J-grid. - NTL = NTL + 1 - EQSTGE(I,J)%ISEA(NTL) = STORES(I,J)%ICVBP(IX) - EQSTGE(I,J)%JSEA(NTL) = STORES(I,J)%JCVBP(IX) -!! Boundary spectra will be substituted fully. JGLi08Dec2020 - EQSTGE(I,J)%WGHT(NTL) = 1.0 - EQSTGE(I,J)%NAVG(NTL) = 1 - EQSTGE(I,J)%WAVG(NTL,1) = 1.0 - EQSTGE(I,J)%RIP (NTL,1) = STORES(I,J)%IPS(IX) - EQSTGE(I,J)%RTG (NTL,1) = STORES(I,J)%ITG(IX) - END IF - END DO + END DO + ! + ! 4.b.3 All other grids, info for sending + ! + DO J=1, NRGRD + IF ( .NOT. SHRANK(J,I) ) CYCLE + IF ( EQSTGE(J,I)%NSND .EQ. 0 ) CYCLE + NTPP = 0 + NTL = 0 + DO IY =1, STORES(J,I)%NTOT + IF( STORES(J,I)%MSDBP(IY) > 0 ) THEN + IPRC=STORES(J,I)%IPS( IY) + NTPP(IPRC) = NTPP(IPRC) + 1 + IF( IPRC .EQ. IMPROC ) THEN + NTL = NTL + 1 + EQSTGE(J,I)%SIS(NTL) = STORES(J,I)%ISS(IY) + EQSTGE(J,I)%SJS(NTL) = STORES(J,I)%JSS(IY) + EQSTGE(J,I)%SI1(NTL) = NTPP(IPRC) + EQSTGE(J,I)%SI2(NTL) = 1 + EQSTGE(J,I)%SIP(NTL) = STORES(J,I)%IPCVB(IY) + EQSTGE(J,I)%STG(NTL) = STORES(J,I)%ITG(IY) + END IF + END IF END DO -! -! 4.b.3 All other grids, info for sending -! - DO J=1, NRGRD - IF ( .NOT. SHRANK(J,I) ) CYCLE - IF ( EQSTGE(J,I)%NSND .EQ. 0 ) CYCLE - NTPP = 0 - NTL = 0 - DO IY =1, STORES(J,I)%NTOT - IF( STORES(J,I)%MSDBP(IY) > 0 ) THEN - IPRC=STORES(J,I)%IPS( IY) - NTPP(IPRC) = NTPP(IPRC) + 1 - IF( IPRC .EQ. IMPROC ) THEN - NTL = NTL + 1 - EQSTGE(J,I)%SIS(NTL) = STORES(J,I)%ISS(IY) - EQSTGE(J,I)%SJS(NTL) = STORES(J,I)%JSS(IY) - EQSTGE(J,I)%SI1(NTL) = NTPP(IPRC) - EQSTGE(J,I)%SI2(NTL) = 1 - EQSTGE(J,I)%SIP(NTL) = STORES(J,I)%IPCVB(IY) - EQSTGE(J,I)%STG(NTL) = STORES(J,I)%ITG(IY) - END IF - END IF - END DO -! - END DO -! -! End of 3.a loop for I grid. + ! END DO -! -! -------------------------------------------------------------------- / -! 5. Generate GRDEQL -! 5.a Size of array -! - NREC = 0 -! - DO I=1, NRGRD - DO J=1, NRGRD - IF ( I.EQ.J .OR. STORES(I,J)%NFIN.EQ.0 ) CYCLE - NREC(I) = NREC(I) + 1 - END DO + ! + ! End of 3.a loop for I grid. + END DO + ! + ! -------------------------------------------------------------------- / + ! 5. Generate GRDEQL + ! 5.a Size of array + ! + NREC = 0 + ! + DO I=1, NRGRD + DO J=1, NRGRD + IF ( I.EQ.J .OR. STORES(I,J)%NFIN.EQ.0 ) CYCLE + NREC(I) = NREC(I) + 1 END DO -! - NA = MAXVAL(NREC) - ALLOCATE( GRDEQL(NRGRD,0:NA), STAT=ISTAT ) - CHECK_ALLOC_STATUS( ISTAT ) - GRDEQL = 0 -! + END DO + ! + NA = MAXVAL(NREC) + ALLOCATE( GRDEQL(NRGRD,0:NA), STAT=ISTAT ) + CHECK_ALLOC_STATUS( ISTAT ) + GRDEQL = 0 + ! #ifdef W3_T - WRITE (MDST,9050) NA -#endif -! -! 5.b Fill array -! - DO I=1, NRGRD - GRDEQL(I,0) = NREC(I) - JJ = 0 - DO J=1, NRGRD - IF ( I.EQ.J .OR. STORES(I,J)%NFIN.EQ.0 ) CYCLE - JJ = JJ + 1 - GRDEQL(I,JJ) = J - END DO + WRITE (MDST,9050) NA +#endif + ! + ! 5.b Fill array + ! + DO I=1, NRGRD + GRDEQL(I,0) = NREC(I) + JJ = 0 + DO J=1, NRGRD + IF ( I.EQ.J .OR. STORES(I,J)%NFIN.EQ.0 ) CYCLE + JJ = JJ + 1 + GRDEQL(I,JJ) = J END DO -! + END DO + ! #ifdef W3_T - WRITE (MDST,9051) - DO I=1, NRGRD - WRITE (MDST,9052) I, GRDEQL(I,0:GRDEQL(I,0)) + WRITE (MDST,9051) + DO I=1, NRGRD + WRITE (MDST,9052) I, GRDEQL(I,0:GRDEQL(I,0)) + END DO +#endif + ! + ! 5.d Group number test + ! + DO I=1, NRGRD + IF( GRDEQL(I,0) .GE. 2 ) THEN + TGRP = GRGRP(GRDEQL(I,1)) + DO J=2, GRDEQL(I,0) + IF( GRGRP(GRDEQL(I,J)) .NE. TGRP ) THEN + IF( IMPROC .EQ. NMPERR ) WRITE(MDSE,1051) & + GRDEQL(I,1), GRGRP(GRDEQL(I,1)), & + GRDEQL(I,J), GRGRP(GRDEQL(I,J)) + CALL EXTCDE ( 1051 ) + END IF END DO -#endif -! -! 5.d Group number test -! - DO I=1, NRGRD - IF( GRDEQL(I,0) .GE. 2 ) THEN - TGRP = GRGRP(GRDEQL(I,1)) - DO J=2, GRDEQL(I,0) - IF( GRGRP(GRDEQL(I,J)) .NE. TGRP ) THEN - IF( IMPROC .EQ. NMPERR ) WRITE(MDSE,1051) & - GRDEQL(I,1), GRGRP(GRDEQL(I,1)), & - GRDEQL(I,J), GRGRP(GRDEQL(I,J)) - CALL EXTCDE ( 1051 ) - END IF - END DO - END IF - END DO -! -! Wait all PEs finishing EQSTGE setup before clean up. JGLi20Jan2021 + END IF + END DO + ! + ! Wait all PEs finishing EQSTGE setup before clean up. JGLi20Jan2021 #ifdef W3_MPI #ifdef W3_SMC - CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) -#endif -#endif -! -------------------------------------------------------------------- / -! 6. Final clean up -! - DO I=1, NRGRD - DO J=1, NRGRD - IF( STORES(I,J)%INIT ) THEN - DEALLOCATE( STORES(I,J)%ICVBP, STORES(I,J)%MSDBP, & - STORES(I,J)%JCVBP, STORES(I,J)%IPCVB, & - STORES(I,J)%ISS , STORES(I,J)%JSS , & - STORES(I,J)%IPS , STORES(I,J)%ITG , & - STORES(I,J)%FLA , STAT=ISTAT ) - CHECK_DEALLOC_STATUS( ISTAT ) - END IF - END DO + CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) +#endif +#endif + ! -------------------------------------------------------------------- / + ! 6. Final clean up + ! + DO I=1, NRGRD + DO J=1, NRGRD + IF( STORES(I,J)%INIT ) THEN + DEALLOCATE( STORES(I,J)%ICVBP, STORES(I,J)%MSDBP, & + STORES(I,J)%JCVBP, STORES(I,J)%IPCVB, & + STORES(I,J)%ISS , STORES(I,J)%JSS , & + STORES(I,J)%IPS , STORES(I,J)%ITG , & + STORES(I,J)%FLA , STAT=ISTAT ) + CHECK_DEALLOC_STATUS( ISTAT ) + END IF END DO -! - DEALLOCATE( SHRANK, STORES, NREC, NSND, NTPP, STAT=ISTAT ) - CHECK_DEALLOC_STATUS( ISTAT ) -! + END DO + ! + DEALLOCATE( SHRANK, STORES, NREC, NSND, NTPP, STAT=ISTAT ) + CHECK_DEALLOC_STATUS( ISTAT ) + ! #ifdef W3_MPI #ifdef W3_SMC - IF( IMPROC .EQ. NMPERR ) & + IF( IMPROC .EQ. NMPERR ) & #endif #endif #ifdef W3_SMC - WRITE(MDSE,*) " *** WMSMCEQL completed from PE ", IMPROC -#endif - - RETURN -! -! Formats -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMSMCEQL : *** '/ & - ' UNCOVERED EDGE POINTS FOR GRID',I4,' (',I6,')'/) - 1001 FORMAT ( ' GRID',I4,' POINT',2I5,' NOT COVERED (WMGEQL)') - 1002 FORMAT ( ' DIAGNOSTICS IX AND IY RANGE:',4I6) - 1003 FORMAT (/' SHOWING ',A/) - 1004 FORMAT (2X,65I2) - 1005 FORMAT (/' SHOWING IX RANGE ',2I6) - 1006 FORMAT ( ' (WILL NOT PRINT ANY MORE UNCOVERED POINTS)') -! - 1020 FORMAT (/' *** WAVEWATCH III WARNING WMSMCEQL : *** '/ & - ' REMOVED BOUNDARY POINT FROM OPEN EDGE DISTANCE MAP'/ & - ' GRID, IX, IY :',3I6) -! - 1050 FORMAT (/' *** WAVEWATCH III ERROR IN WMSMCEQL : *** '/ & - ' GRID INCREMENTS TOO DIFFERENT '/ & - ' GRID',I4,' INCREMENTS ',2F8.2/ & - ' GRID',I4,' INCREMENTS ',2F8.2/) - 1051 FORMAT (/' *** WAVEWATCH III ERROR IN WMSMCEQL : *** '/ & - ' OVERLAPPING GRIDS NEED TO BE IN SAME GROUP '/ & - ' GRID',I4,' IN GROUP',I4/ & - ' GRID',I4,' IN GROUP',I4/) - 1060 FORMAT (' Grid NBPI from',2I6,' found in',2I6) - -! + WRITE(MDSE,*) " *** WMSMCEQL completed from PE ", IMPROC +#endif + + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMSMCEQL : *** '/ & + ' UNCOVERED EDGE POINTS FOR GRID',I4,' (',I6,')'/) +1001 FORMAT ( ' GRID',I4,' POINT',2I5,' NOT COVERED (WMGEQL)') +1002 FORMAT ( ' DIAGNOSTICS IX AND IY RANGE:',4I6) +1003 FORMAT (/' SHOWING ',A/) +1004 FORMAT (2X,65I2) +1005 FORMAT (/' SHOWING IX RANGE ',2I6) +1006 FORMAT ( ' (WILL NOT PRINT ANY MORE UNCOVERED POINTS)') + ! +1020 FORMAT (/' *** WAVEWATCH III WARNING WMSMCEQL : *** '/ & + ' REMOVED BOUNDARY POINT FROM OPEN EDGE DISTANCE MAP'/ & + ' GRID, IX, IY :',3I6) + ! +1050 FORMAT (/' *** WAVEWATCH III ERROR IN WMSMCEQL : *** '/ & + ' GRID INCREMENTS TOO DIFFERENT '/ & + ' GRID',I4,' INCREMENTS ',2F8.2/ & + ' GRID',I4,' INCREMENTS ',2F8.2/) +1051 FORMAT (/' *** WAVEWATCH III ERROR IN WMSMCEQL : *** '/ & + ' OVERLAPPING GRIDS NEED TO BE IN SAME GROUP '/ & + ' GRID',I4,' IN GROUP',I4/ & + ' GRID',I4,' IN GROUP',I4/) +1060 FORMAT (' Grid NBPI from',2I6,' found in',2I6) + + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMSMCEQL : STARTING LOOP OVER GRIDS') - 9011 FORMAT ( ' TEST WMSMCEQL : I, RANK :',2I4) - 9012 FORMAT ( ' GRID ',I3,' HAS SAME RANK') - 9013 FORMAT ( ' ',A) +9010 FORMAT ( ' TEST WMSMCEQL : STARTING LOOP OVER GRIDS') +9011 FORMAT ( ' TEST WMSMCEQL : I, RANK :',2I4) +9012 FORMAT ( ' GRID ',I3,' HAS SAME RANK') +9013 FORMAT ( ' ',A) #endif -! + ! #ifdef W3_T - 9020 FORMAT ( ' TEST WMSMCEQL : GENERATING DISTANCE MAP GRID ',I3) - 9024 FORMAT ( ' TEST WMSMCEQL : FINAL MAP FOR X RANGE ',2I6) - 9025 FORMAT (2X,65I2) +9020 FORMAT ( ' TEST WMSMCEQL : GENERATING DISTANCE MAP GRID ',I3) +9024 FORMAT ( ' TEST WMSMCEQL : FINAL MAP FOR X RANGE ',2I6) +9025 FORMAT (2X,65I2) #endif -! + ! #ifdef W3_T - 9030 FORMAT ( ' TEST WMSMCEQL : DEPENDENCE INFORMATION GRID ',I3) - 9031 FORMAT ( ' CHECKING GRID ',I3) - 9032 FORMAT ( ' POINTS USED/AVAIL :',2I6) - 9033 FORMAT ( ' TOTAL/GRIDS/OUT :',3I6) - 9034 FORMAT ( ' LOCAL PER GRID :',15I6) - 9035 FORMAT ( ' SENDING PER GRID :',15I6) - 9036 FORMAT ( ' TEST WMSMCEQL : NUMBER OF CONTRIBUTING GRIDS MAP') - 9037 FORMAT (2X,65I2) -#endif -! +9030 FORMAT ( ' TEST WMSMCEQL : DEPENDENCE INFORMATION GRID ',I3) +9031 FORMAT ( ' CHECKING GRID ',I3) +9032 FORMAT ( ' POINTS USED/AVAIL :',2I6) +9033 FORMAT ( ' TOTAL/GRIDS/OUT :',3I6) +9034 FORMAT ( ' LOCAL PER GRID :',15I6) +9035 FORMAT ( ' SENDING PER GRID :',15I6) +9036 FORMAT ( ' TEST WMSMCEQL : NUMBER OF CONTRIBUTING GRIDS MAP') +9037 FORMAT (2X,65I2) +#endif + ! #ifdef W3_T - 9040 FORMAT ( ' TEST WMSMCEQL : GRID ',I2,'-',I2,' CLEAR STORAGE') - 9041 FORMAT ( ' TEST WMSMCEQL : GRID ',I2,'-',I2,' STORAGE SIZE',I6) - 9042 FORMAT ( ' RECV ',I2,'-',I2,' CLEAR STORAGE') - 9043 FORMAT ( ' RECV ',I2,'-',I2,' STORAGE SIZE',2I6) - 9044 FORMAT ( ' SEND ',I2,'-',I2,' CLEAR STORAGE') - 9045 FORMAT ( ' SEND ',I2,'-',I2,' STORAGE SIZE',I6) -#endif -! +9040 FORMAT ( ' TEST WMSMCEQL : GRID ',I2,'-',I2,' CLEAR STORAGE') +9041 FORMAT ( ' TEST WMSMCEQL : GRID ',I2,'-',I2,' STORAGE SIZE',I6) +9042 FORMAT ( ' RECV ',I2,'-',I2,' CLEAR STORAGE') +9043 FORMAT ( ' RECV ',I2,'-',I2,' STORAGE SIZE',2I6) +9044 FORMAT ( ' SEND ',I2,'-',I2,' CLEAR STORAGE') +9045 FORMAT ( ' SEND ',I2,'-',I2,' STORAGE SIZE',I6) +#endif + ! #ifdef W3_T - 9050 FORMAT ( ' TEST WMSMCEQL : GRDEQL DIMENSIONED AT ',I2) - 9051 FORMAT ( ' TEST WMSMCEQL : GRDEQL :') - 9052 FORMAT ( ' ',2i4,' : ',20I3) -#endif -! -!/ -!/ End of WMSMCEQL -------------------------------------------------- / -!/ - END SUBROUTINE WMSMCEQL -!! - -!/ End of module WMGRIDMD -------------------------------------------- / -!/ - END MODULE WMGRIDMD +9050 FORMAT ( ' TEST WMSMCEQL : GRDEQL DIMENSIONED AT ',I2) +9051 FORMAT ( ' TEST WMSMCEQL : GRDEQL :') +9052 FORMAT ( ' ',2i4,' : ',20I3) +#endif + ! + !/ + !/ End of WMSMCEQL -------------------------------------------------- / + !/ + END SUBROUTINE WMSMCEQL + !! + + !/ End of module WMGRIDMD -------------------------------------------- / + !/ +END MODULE WMGRIDMD diff --git a/model/src/wminiomd.F90 b/model/src/wminiomd.F90 index b8d4742a8..dba1be9cc 100644 --- a/model/src/wminiomd.F90 +++ b/model/src/wminiomd.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains module WMINIOMD. -!> +!> !> @author H. L. Tolman @date 28-Sep-2016 !> @@ -11,3547 +11,3547 @@ !> !> @author H. L. Tolman @date 28-Sep-2016 !> - MODULE WMINIOMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 28-Sep-2016 | -!/ +-----------------------------------+ -!/ -!/ 29-May-2006 : Origination. ( version 3.09 ) -!/ 21-Dec-2006 : VTIME change in WMIOHx and WMIOEx. ( version 3.10 ) -!/ 22-Jan-2007 : Adding NAVMAX in WMIOEG. ( version 3.10 ) -!/ 30-Jan-2007 : Fix memory leak WMIOBS. ( version 3.10 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 ) -!/ 16-Dec-2020 : Modify WMIOES/G for SMC grid. JGLi ( version 7.13 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Internal IO routines for the multi-grid model. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WMIOBS Subr. Public Stage internal boundary data. -! WMIOBG Subr. Public Gather internal boundary data. -! WMIOBF Subr. Public Finalize WMIOBS. ( !/MPI ) -! WMIOHS Subr. Public Stage internal high to low data. -! WMIOHG Subr. Public Gather internal high to low data. -! WMIOHF Subr. Public Finalize WMIOHS. ( !/MPI ) -! WMIOES Subr. Public Stage internal same rank data. -! WMIOEG Subr. Public Gather internal same rank data. -! WMIOEF Subr. Public Finalize WMIOES. ( !/MPI ) -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM -! Subr. WxxDATMD Manage data structures. -! W3UBPT Subr. W3UBPTMD Update internal bounday spectra. -! W3IOBC Subr W3IOBCMD I/O of boundary data. -! W3CSPC Subr. W3CSPCMD Spectral grid conversion. -! STRACE Sur. W3SERVMD Subroutine tracing. -! -! MPI_ISEND, MPI_IRECV, MPI_TESTALL, MPI_WAITALL -! Subr. mpif.h MPI routines. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! !/SHRD Shared/distributed memory models. -! !/DIST -! !/MPI -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/MPIT -! -! 6. Switches : -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Stage internal boundary data in the data structure BPSTGE. -!> -!> @details For the shared memory version, arrays are initialized and -!> the data are copied. For the distributed memory version, the data -!> are moved using a non-blocking send. In this case, the arrays -!> are dimensioned on the receiving side. -!> -!> @param[in] IMOD Model number of grid from which data is to -!> be staged. -!> -!> @author H. L. Tolman @date 06-Jun-2018 -!> - SUBROUTINE WMIOBS ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018 ! -!/ +-----------------------------------+ -!/ -!/ 06-Oct-2005 : Origination. ( version 3.08 ) -!/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 ) -!/ 30-Jan-2007 : Fix memory leak. ( version 3.10 ) -!/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 ) -!/ 06-Jun-2018 : Use W3PARALL/add DEBUGIOBC/PDLIB ( version 6.04 ) -!/ -! 1. Purpose : -! -! Stage internal boundary data in the data structure BPSTGE. -! -! 2. Method : -! -! For the shared memory version, arrays are initialized and the -! data are copied. For the distributed memory version, the data -! are moved using a non-blocking send. in this case, the arrays -! are dimensioned on the recieving side. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number of grid from which data is to -! be staged. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM -! Subr. WxxDATMD Manage data structures. -! W3CSPC Subr. W3CSPCMD Spectral grid conversion. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Sur. Id. Program abort. -! -! MPI_ISEND -! Subr. mpif.h MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINIT Subr WMINITMD Multi-grid model initialization. -! WMWAVE Subr WMWAVEMD Multi-grid wave model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See FORMAT label 1001. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Shared/distributed memory models. -! !/DIST -! !/MPI -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/MPIT -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3GDATMD - USE W3WDATMD - USE W3ADATMD - USE W3ODATMD - USE WMMDATMD -! - USE W3CSPCMD, ONLY: W3CSPC - USE W3SERVMD, ONLY: EXTCDE - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC +MODULE WMINIOMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 28-Sep-2016 | + !/ +-----------------------------------+ + !/ + !/ 29-May-2006 : Origination. ( version 3.09 ) + !/ 21-Dec-2006 : VTIME change in WMIOHx and WMIOEx. ( version 3.10 ) + !/ 22-Jan-2007 : Adding NAVMAX in WMIOEG. ( version 3.10 ) + !/ 30-Jan-2007 : Fix memory leak WMIOBS. ( version 3.10 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 ) + !/ 16-Dec-2020 : Modify WMIOES/G for SMC grid. JGLi ( version 7.13 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Internal IO routines for the multi-grid model. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WMIOBS Subr. Public Stage internal boundary data. + ! WMIOBG Subr. Public Gather internal boundary data. + ! WMIOBF Subr. Public Finalize WMIOBS. ( !/MPI ) + ! WMIOHS Subr. Public Stage internal high to low data. + ! WMIOHG Subr. Public Gather internal high to low data. + ! WMIOHF Subr. Public Finalize WMIOHS. ( !/MPI ) + ! WMIOES Subr. Public Stage internal same rank data. + ! WMIOEG Subr. Public Gather internal same rank data. + ! WMIOEF Subr. Public Finalize WMIOES. ( !/MPI ) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM + ! Subr. WxxDATMD Manage data structures. + ! W3UBPT Subr. W3UBPTMD Update internal bounday spectra. + ! W3IOBC Subr W3IOBCMD I/O of boundary data. + ! W3CSPC Subr. W3CSPCMD Spectral grid conversion. + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! + ! MPI_ISEND, MPI_IRECV, MPI_TESTALL, MPI_WAITALL + ! Subr. mpif.h MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! !/SHRD Shared/distributed memory models. + ! !/DIST + ! !/MPI + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/MPIT + ! + ! 6. Switches : + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Stage internal boundary data in the data structure BPSTGE. + !> + !> @details For the shared memory version, arrays are initialized and + !> the data are copied. For the distributed memory version, the data + !> are moved using a non-blocking send. In this case, the arrays + !> are dimensioned on the receiving side. + !> + !> @param[in] IMOD Model number of grid from which data is to + !> be staged. + !> + !> @author H. L. Tolman @date 06-Jun-2018 + !> + SUBROUTINE WMIOBS ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018 ! + !/ +-----------------------------------+ + !/ + !/ 06-Oct-2005 : Origination. ( version 3.08 ) + !/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 ) + !/ 30-Jan-2007 : Fix memory leak. ( version 3.10 ) + !/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 ) + !/ 06-Jun-2018 : Use W3PARALL/add DEBUGIOBC/PDLIB ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Stage internal boundary data in the data structure BPSTGE. + ! + ! 2. Method : + ! + ! For the shared memory version, arrays are initialized and the + ! data are copied. For the distributed memory version, the data + ! are moved using a non-blocking send. in this case, the arrays + ! are dimensioned on the recieving side. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number of grid from which data is to + ! be staged. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM + ! Subr. WxxDATMD Manage data structures. + ! W3CSPC Subr. W3CSPCMD Spectral grid conversion. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Sur. Id. Program abort. + ! + ! MPI_ISEND + ! Subr. mpif.h MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINIT Subr WMINITMD Multi-grid model initialization. + ! WMWAVE Subr WMWAVEMD Multi-grid wave model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See FORMAT label 1001. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Shared/distributed memory models. + ! !/DIST + ! !/MPI + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/MPIT + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GDATMD + USE W3WDATMD + USE W3ADATMD + USE W3ODATMD + USE WMMDATMD + ! + USE W3CSPCMD, ONLY: W3CSPC + USE W3SERVMD, ONLY: EXTCDE + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, I, IOFF, ISEA, JSEA, IS + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, I, IOFF, ISEA, JSEA, IS #ifdef W3_DIST - INTEGER :: ISPROC + INTEGER :: ISPROC #endif #ifdef W3_MPI - INTEGER :: IP, IT0, ITAG, IERR_MPI - INTEGER, POINTER :: NRQ, IRQ(:) + INTEGER :: IP, IT0, ITAG, IERR_MPI + INTEGER, POINTER :: NRQ, IRQ(:) #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL, POINTER :: SBPI(:,:), TSTORE(:,:) -!/ + REAL, POINTER :: SBPI(:,:), TSTORE(:,:) + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOBS') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! -#ifdef W3_T - WRITE (MDST,9000) IMOD - WRITE (MDST,9001) NBI2G(:,IMOD) -#endif -! - IF ( SUM(NBI2G(:,IMOD)) .EQ. 0 ) RETURN -! - CALL W3SETO ( IMOD, MDSE, MDST ) - CALL W3SETG ( IMOD, MDSE, MDST ) - CALL W3SETW ( IMOD, MDSE, MDST ) - CALL W3SETA ( IMOD, MDSE, MDST ) -! -! -------------------------------------------------------------------- / -! 1. Loop over grids -! - DO J=1, NRGRD -! - IF ( NBI2G(J,IMOD) .EQ. 0 ) CYCLE -! - CALL WMSETM ( J , MDSE, MDST ) -! - IF ( IMOD .EQ. 1 ) THEN - IOFF = 0 - ELSE - IOFF = SUM(NBI2G(J,1:IMOD-1)) - END IF -! -#ifdef W3_T - WRITE (MDST,9010) NBI2G(J,IMOD),IMOD,J,IOFF+1,RESPEC(J,IMOD) -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! + CALL STRACE (IENT, 'WMIOBS') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! +#ifdef W3_T + WRITE (MDST,9000) IMOD + WRITE (MDST,9001) NBI2G(:,IMOD) +#endif + ! + IF ( SUM(NBI2G(:,IMOD)) .EQ. 0 ) RETURN + ! + CALL W3SETO ( IMOD, MDSE, MDST ) + CALL W3SETG ( IMOD, MDSE, MDST ) + CALL W3SETW ( IMOD, MDSE, MDST ) + CALL W3SETA ( IMOD, MDSE, MDST ) + ! + ! -------------------------------------------------------------------- / + ! 1. Loop over grids + ! + DO J=1, NRGRD + ! + IF ( NBI2G(J,IMOD) .EQ. 0 ) CYCLE + ! + CALL WMSETM ( J , MDSE, MDST ) + ! + IF ( IMOD .EQ. 1 ) THEN + IOFF = 0 + ELSE + IOFF = SUM(NBI2G(J,1:IMOD-1)) + END IF + ! +#ifdef W3_T + WRITE (MDST,9010) NBI2G(J,IMOD),IMOD,J,IOFF+1,RESPEC(J,IMOD) +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! #ifdef W3_SHRD - IF ( BPSTGE(J,IMOD)%INIT ) THEN - IF ( SIZE(BPSTGE(J,IMOD)%SBPI(:,1)) .NE. NSPEC .OR. & - SIZE(BPSTGE(J,IMOD)%SBPI(1,:)) & - .NE. NBI2G(J,IMOD) ) THEN - DEALLOCATE ( BPSTGE(J,IMOD)%SBPI ) - BPSTGE(J,IMOD)%INIT = .FALSE. - END IF - END IF + IF ( BPSTGE(J,IMOD)%INIT ) THEN + IF ( SIZE(BPSTGE(J,IMOD)%SBPI(:,1)) .NE. NSPEC .OR. & + SIZE(BPSTGE(J,IMOD)%SBPI(1,:)) & + .NE. NBI2G(J,IMOD) ) THEN + DEALLOCATE ( BPSTGE(J,IMOD)%SBPI ) + BPSTGE(J,IMOD)%INIT = .FALSE. + END IF + END IF #endif -! + ! #ifdef W3_SHRD - IF ( .NOT. BPSTGE(J,IMOD)%INIT ) THEN - NSPEC => SGRDS(J)%NSPEC - ALLOCATE ( BPSTGE(J,IMOD)%SBPI(NSPEC,NBI2G(J,IMOD)) ) - NSPEC => SGRDS(IMOD)%NSPEC - BPSTGE(J,IMOD)%INIT = .TRUE. - END IF -#endif -! + IF ( .NOT. BPSTGE(J,IMOD)%INIT ) THEN + NSPEC => SGRDS(J)%NSPEC + ALLOCATE ( BPSTGE(J,IMOD)%SBPI(NSPEC,NBI2G(J,IMOD)) ) + NSPEC => SGRDS(IMOD)%NSPEC + BPSTGE(J,IMOD)%INIT = .TRUE. + END IF +#endif + ! #ifdef W3_SHRD - IF ( RESPEC(J,IMOD) ) THEN - ALLOCATE ( TSTORE(NSPEC,NBI2G(J,IMOD)) ) - SBPI => TSTORE - ELSE - SBPI => BPSTGE(J,IMOD)%SBPI - END IF + IF ( RESPEC(J,IMOD) ) THEN + ALLOCATE ( TSTORE(NSPEC,NBI2G(J,IMOD)) ) + SBPI => TSTORE + ELSE + SBPI => BPSTGE(J,IMOD)%SBPI + END IF #endif -! + ! #ifdef W3_MPI - NAPROC => OUTPTS(J)%NAPROC - ALLOCATE ( IRQ(NBI2G(J,IMOD)*NAPROC+NAPROC) ) - ALLOCATE ( BPSTGE(J,IMOD)%TSTORE(NSPEC,NBI2G(J,IMOD)) ) - NAPROC => OUTPTS(IMOD)%NAPROC + NAPROC => OUTPTS(J)%NAPROC + ALLOCATE ( IRQ(NBI2G(J,IMOD)*NAPROC+NAPROC) ) + ALLOCATE ( BPSTGE(J,IMOD)%TSTORE(NSPEC,NBI2G(J,IMOD)) ) + NAPROC => OUTPTS(IMOD)%NAPROC #endif -! + ! #ifdef W3_MPI - NRQ => BPSTGE(J,IMOD)%NRQBPS - SBPI => BPSTGE(J,IMOD)%TSTORE + NRQ => BPSTGE(J,IMOD)%NRQBPS + SBPI => BPSTGE(J,IMOD)%TSTORE #endif -! + ! #ifdef W3_MPI - NRQ = 0 - IRQ = 0 + NRQ = 0 + IRQ = 0 #endif -! -! -------------------------------------------------------------------- / -! 3. Set the time -! Note that with MPI the send needs to be posted to the local -! processor too to make time management possible. -! + ! + ! -------------------------------------------------------------------- / + ! 3. Set the time + ! Note that with MPI the send needs to be posted to the local + ! processor too to make time management possible. + ! #ifdef W3_T - WRITE (MDST,9030) TIME + WRITE (MDST,9030) TIME #endif #ifdef W3_MPIT - WRITE (MDST,9080) + WRITE (MDST,9080) #endif -! + ! #ifdef W3_SHRD - BPSTGE(J,IMOD)%VTIME = TIME + BPSTGE(J,IMOD)%VTIME = TIME #endif -! + ! #ifdef W3_MPI - IF ( IAPROC .EQ. 1 ) THEN - BPSTGE(J,IMOD)%STIME = TIME - ITAG = MTAG0 + IMOD + (J-1)*NRGRD - IF ( ITAG .GT. MTAG1 ) THEN - WRITE (MDSE,1001) - CALL EXTCDE (1001) - END IF - DO IP=1, NMPROC - IF ( ALLPRC(IP,J) .NE. 0 .AND. & - ALLPRC(IP,J) .LE. OUTPTS(J)%NAPROC ) THEN - NRQ = NRQ + 1 - CALL MPI_ISEND ( BPSTGE(J,IMOD)%STIME, 2, & - MPI_INTEGER, IP-1, ITAG, & - MPI_COMM_MWAVE, IRQ(NRQ), & - IERR_MPI ) + IF ( IAPROC .EQ. 1 ) THEN + BPSTGE(J,IMOD)%STIME = TIME + ITAG = MTAG0 + IMOD + (J-1)*NRGRD + IF ( ITAG .GT. MTAG1 ) THEN + WRITE (MDSE,1001) + CALL EXTCDE (1001) + END IF + DO IP=1, NMPROC + IF ( ALLPRC(IP,J) .NE. 0 .AND. & + ALLPRC(IP,J) .LE. OUTPTS(J)%NAPROC ) THEN + NRQ = NRQ + 1 + CALL MPI_ISEND ( BPSTGE(J,IMOD)%STIME, 2, & + MPI_INTEGER, IP-1, ITAG, & + MPI_COMM_MWAVE, IRQ(NRQ), & + IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9081) NRQ, IP, ITAG-MTAG0, & - IRQ(NRQ), IERR_MPI + WRITE (MDST,9081) NRQ, IP, ITAG-MTAG0, & + IRQ(NRQ), IERR_MPI #endif #ifdef W3_MPI - END IF - END DO END IF -#endif -! -! -------------------------------------------------------------------- / -! 4. Stage the spectral data -! - DO I=1, NBI2G(J,IMOD) -! - ISEA = NBI2S(IOFF+I,2) + END DO + END IF +#endif + ! + ! -------------------------------------------------------------------- / + ! 4. Stage the spectral data + ! + DO I=1, NBI2G(J,IMOD) + ! + ISEA = NBI2S(IOFF+I,2) #ifdef W3_SHRD - JSEA = ISEA + JSEA = ISEA #endif #ifdef W3_DIST - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) - IF ( ISPROC .NE. IAPROC ) CYCLE + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + IF ( ISPROC .NE. IAPROC ) CYCLE #endif #ifdef W3_MPI - IT0 = MTAG0 + NRGRD**2 + SUM(NBI2G(1:J-1,:)) + & - SUM(NBI2G(J,1:IMOD-1)) + IT0 = MTAG0 + NRGRD**2 + SUM(NBI2G(1:J-1,:)) + & + SUM(NBI2G(J,1:IMOD-1)) #endif -! - DO IS=1, NSPEC - SBPI(IS,I) = VA(IS,JSEA) * SIG2(IS) / CG(1+(IS-1)/NTH,ISEA) - END DO -! + ! + DO IS=1, NSPEC + SBPI(IS,I) = VA(IS,JSEA) * SIG2(IS) / CG(1+(IS-1)/NTH,ISEA) + END DO + ! #ifdef W3_MPI - DO IP=1, NMPROC - IF ( ALLPRC(IP,J) .NE. 0 .AND. & - ALLPRC(IP,J) .LE. OUTPTS(J)%NAPROC ) THEN - NRQ = NRQ + 1 - ITAG = IT0 + I - IF ( ITAG .GT. MTAG1 ) THEN - WRITE (MDSE,1001) - CALL EXTCDE (1001) - END IF - CALL MPI_ISEND ( SBPI(1,I), NSPEC, MPI_REAL, & - IP-1, ITAG, MPI_COMM_MWAVE, & - IRQ(NRQ), IERR_MPI ) + DO IP=1, NMPROC + IF ( ALLPRC(IP,J) .NE. 0 .AND. & + ALLPRC(IP,J) .LE. OUTPTS(J)%NAPROC ) THEN + NRQ = NRQ + 1 + ITAG = IT0 + I + IF ( ITAG .GT. MTAG1 ) THEN + WRITE (MDSE,1001) + CALL EXTCDE (1001) + END IF + CALL MPI_ISEND ( SBPI(1,I), NSPEC, MPI_REAL, & + IP-1, ITAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG0, & - IRQ(NRQ), IERR_MPI + WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG0, & + IRQ(NRQ), IERR_MPI #endif #ifdef W3_MPI - END IF - END DO + END IF + END DO #endif -! - END DO -! + ! + END DO + ! #ifdef W3_MPIT - WRITE (MDST,9083) - WRITE (MDST,9084) NRQ + WRITE (MDST,9083) + WRITE (MDST,9084) NRQ #endif -! + ! #ifdef W3_MPI - IF ( NRQ .GT. 0 ) THEN - ALLOCATE ( BPSTGE(J,IMOD)%IRQBPS(NRQ) ) - BPSTGE(J,IMOD)%IRQBPS = IRQ(:NRQ) - ELSE - DEALLOCATE ( BPSTGE(J,IMOD)%TSTORE ) - END IF + IF ( NRQ .GT. 0 ) THEN + ALLOCATE ( BPSTGE(J,IMOD)%IRQBPS(NRQ) ) + BPSTGE(J,IMOD)%IRQBPS = IRQ(:NRQ) + ELSE + DEALLOCATE ( BPSTGE(J,IMOD)%TSTORE ) + END IF #endif -! + ! #ifdef W3_MPI - DEALLOCATE ( IRQ ) + DEALLOCATE ( IRQ ) #endif -! -! -------------------------------------------------------------------- / -! 5. Convert spectra ( !/SHRD only ) -! + ! + ! -------------------------------------------------------------------- / + ! 5. Convert spectra ( !/SHRD only ) + ! #ifdef W3_SHRD - IF ( RESPEC(J,IMOD) ) THEN - SBPI => BPSTGE(J,IMOD)%SBPI - CALL W3CSPC ( TSTORE, NK, NTH, XFR, FR1, TH(1), & - SBPI, SGRDS(J)%NK, SGRDS(J)%NTH, SGRDS(J)%XFR, & - SGRDS(J)%FR1, SGRDS(J)%TH(1), NBI2G(J,IMOD), & - MDST, MDSE, SGRDS(J)%FACHFE ) - DEALLOCATE ( TSTORE ) - END IF + IF ( RESPEC(J,IMOD) ) THEN + SBPI => BPSTGE(J,IMOD)%SBPI + CALL W3CSPC ( TSTORE, NK, NTH, XFR, FR1, TH(1), & + SBPI, SGRDS(J)%NK, SGRDS(J)%NTH, SGRDS(J)%XFR, & + SGRDS(J)%FR1, SGRDS(J)%TH(1), NBI2G(J,IMOD), & + MDST, MDSE, SGRDS(J)%FACHFE ) + DEALLOCATE ( TSTORE ) + END IF #endif -! -! ... End of loop over grids -! - END DO -! - RETURN -! -! Formats -! + ! + ! ... End of loop over grids + ! + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_MPI - 1001 FORMAT (/' *** ERROR WMIOBS : REQUESTED MPI TAG EXCEEDS', & - ' UPPER BOUND (MTAG1) ***') +1001 FORMAT (/' *** ERROR WMIOBS : REQUESTED MPI TAG EXCEEDS', & + ' UPPER BOUND (MTAG1) ***') #endif #ifdef W3_T - 9000 FORMAT ( ' TEST WMIOBS : STAGING DATA FROM GRID ',I3) - 9001 FORMAT ( ' TEST WMIOBS : NR. OF SPECTRA PER GRID : '/ & - ' ',25I4) +9000 FORMAT ( ' TEST WMIOBS : STAGING DATA FROM GRID ',I3) +9001 FORMAT ( ' TEST WMIOBS : NR. OF SPECTRA PER GRID : '/ & + ' ',25I4) #endif -! + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMIOBS : STAGING',I4,' SPECTRA FROM GRID ', & - I3,' TO GRID ',I3/ & - ' STARTING WITH SPECTRUM ',I4, & - ', RESPEC =',L2) +9010 FORMAT ( ' TEST WMIOBS : STAGING',I4,' SPECTRA FROM GRID ', & + I3,' TO GRID ',I3/ & + ' STARTING WITH SPECTRUM ',I4, & + ', RESPEC =',L2) #endif -! + ! #ifdef W3_T - 9030 FORMAT ( ' TEST WMIOBS : TIME :',I10.8,I7.6) +9030 FORMAT ( ' TEST WMIOBS : TIME :',I10.8,I7.6) #endif -! + ! #ifdef W3_MPIT - 9080 FORMAT (/' MPIT WMIOBS: COMMUNICATION CALLS '/ & - ' +------+------+------+------+--------------+'/ & - ' | IH | ID | TARG | TAG | handle err |'/ & - ' +------+------+------+------+--------------+') - 9081 FORMAT ( ' |',I5,' | TIME |',2(I5,' |'),I9,I4,' |') - 9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') - 9083 FORMAT ( ' +------+------+------+------+--------------+') - 9084 FORMAT ( ' MPIT WMIOBS: NRQBPT:',I10/) -#endif -!/ -!/ End of WMIOBS ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOBS -!/ ------------------------------------------------------------------- / -!> -!> @brief Gather internal boundary data for a given model. -!> -!> @details For the shared memory version, data are gathered from -!> the data structure BPSTGE. For the distributed memory version, -!> the gathering of the data are finished first. -!> -!> Gathering of data is triggered by the time stamp of the data -!> that is presently in the storage arrays. -!> -!> This routine preempts the data flow normally executed by -!> W3IOBC and W3UBPT, and hence bypasses both routines in W3WAVE. -!> -!> @param[in] IMOD Model number of grid from which data is to -!> be gathered. -!> @param[out] DONE Flag for completion of operation (opt). -!> -!> @author H. L. Tolman @date 29-May-2006 -!> - SUBROUTINE WMIOBG ( IMOD, DONE ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2006 ! -!/ +-----------------------------------+ -!/ -!/ 18-Oct-2005 : Origination. ( version 3.08 ) -!/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 ) -!/ -! 1. Purpose : -! -! Gather internal boundary data for a given model. -! -! 2. Method : -! -! For the shared memory version, datat are gathered from the data -! structure BPSTGE. For the distributed memeory version, the -! gathering of thee data are finished first. -! -! Gathering of data is triggered by the time stamp of the data -! that is presently in the storage arrays. -! -! This routine preempts the data flow normally executed by -! W3IOBC and W3UBPT, and hence bypasses both routines in W3WAVE. -! -! 2. Method : -! -! Using storage array BPSTAGE and time stamps. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number of grid from which data is to -! be gathered. -! DONE Log. O Flag for completion of operation (opt). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM -! Subr. WxxDATMD Manage data structures. -! W3CSPC Subr. W3CSPCMD Spectral grid conversion. -! W3UBPT Subr. W3UBPTMD Update internal bounday spectra. -! W3IOBC Subr W3IOBCMD I/O of boundary data. -! STRACE Sur. W3SERVMD Subroutine tracing. -! EXTCDE Sur. Id. Program abort. -! DSEC21 Func. W3TIMEMD Difference between times. -! -! MPI_IRECV, MPI_TESTALL, MPI_WAITALL -! Subr. mpif.h MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINIT Subr WMINITMD Multi-grid model initialization. -! WMWAVE Subr WMWAVEMD Multi-grid wave model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See FORMAT labels 1001-1002. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/SHRD Shared/distributed memory models. -! !/DIST -! !/MPI -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3GDATMD - USE W3WDATMD - USE W3ADATMD - USE W3ODATMD - USE WMMDATMD -! - USE W3CSPCMD, ONLY: W3CSPC - USE W3TIMEMD, ONLY: DSEC21 - USE W3UPDTMD, ONLY: W3UBPT - USE W3IOBCMD, ONLY: W3IOBC - USE W3SERVMD, ONLY: EXTCDE -! USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC_GLOB +9080 FORMAT (/' MPIT WMIOBS: COMMUNICATION CALLS '/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') +9081 FORMAT ( ' |',I5,' | TIME |',2(I5,' |'),I9,I4,' |') +9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') +9083 FORMAT ( ' +------+------+------+------+--------------+') +9084 FORMAT ( ' MPIT WMIOBS: NRQBPT:',I10/) +#endif + !/ + !/ End of WMIOBS ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOBS + !/ ------------------------------------------------------------------- / + !> + !> @brief Gather internal boundary data for a given model. + !> + !> @details For the shared memory version, data are gathered from + !> the data structure BPSTGE. For the distributed memory version, + !> the gathering of the data are finished first. + !> + !> Gathering of data is triggered by the time stamp of the data + !> that is presently in the storage arrays. + !> + !> This routine preempts the data flow normally executed by + !> W3IOBC and W3UBPT, and hence bypasses both routines in W3WAVE. + !> + !> @param[in] IMOD Model number of grid from which data is to + !> be gathered. + !> @param[out] DONE Flag for completion of operation (opt). + !> + !> @author H. L. Tolman @date 29-May-2006 + !> + SUBROUTINE WMIOBG ( IMOD, DONE ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2006 ! + !/ +-----------------------------------+ + !/ + !/ 18-Oct-2005 : Origination. ( version 3.08 ) + !/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 ) + !/ + ! 1. Purpose : + ! + ! Gather internal boundary data for a given model. + ! + ! 2. Method : + ! + ! For the shared memory version, datat are gathered from the data + ! structure BPSTGE. For the distributed memeory version, the + ! gathering of thee data are finished first. + ! + ! Gathering of data is triggered by the time stamp of the data + ! that is presently in the storage arrays. + ! + ! This routine preempts the data flow normally executed by + ! W3IOBC and W3UBPT, and hence bypasses both routines in W3WAVE. + ! + ! 2. Method : + ! + ! Using storage array BPSTAGE and time stamps. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number of grid from which data is to + ! be gathered. + ! DONE Log. O Flag for completion of operation (opt). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM + ! Subr. WxxDATMD Manage data structures. + ! W3CSPC Subr. W3CSPCMD Spectral grid conversion. + ! W3UBPT Subr. W3UBPTMD Update internal bounday spectra. + ! W3IOBC Subr W3IOBCMD I/O of boundary data. + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! EXTCDE Sur. Id. Program abort. + ! DSEC21 Func. W3TIMEMD Difference between times. + ! + ! MPI_IRECV, MPI_TESTALL, MPI_WAITALL + ! Subr. mpif.h MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINIT Subr WMINITMD Multi-grid model initialization. + ! WMWAVE Subr WMWAVEMD Multi-grid wave model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See FORMAT labels 1001-1002. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/SHRD Shared/distributed memory models. + ! !/DIST + ! !/MPI + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GDATMD + USE W3WDATMD + USE W3ADATMD + USE W3ODATMD + USE WMMDATMD + ! + USE W3CSPCMD, ONLY: W3CSPC + USE W3TIMEMD, ONLY: DSEC21 + USE W3UPDTMD, ONLY: W3UBPT + USE W3IOBCMD, ONLY: W3IOBC + USE W3SERVMD, ONLY: EXTCDE + ! USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC_GLOB #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD - LOGICAL, INTENT(OUT), OPTIONAL :: DONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, I, IOFF, TTEST(2), ITEST + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + LOGICAL, INTENT(OUT), OPTIONAL :: DONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, I, IOFF, TTEST(2), ITEST #ifdef W3_MPI - INTEGER :: IERR_MPI, IT0, ITAG, IFROM, & - ISEA, JSEA, ISPROC + INTEGER :: IERR_MPI, IT0, ITAG, IFROM, & + ISEA, JSEA, ISPROC #endif #ifdef W3_MPIT - INTEGER :: ICOUNT + INTEGER :: ICOUNT #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, POINTER :: VTIME(:) + INTEGER, POINTER :: VTIME(:) #ifdef W3_MPI - INTEGER, POINTER :: NRQ, IRQ(:) - INTEGER, ALLOCATABLE :: STATUS(:,:) + INTEGER, POINTER :: NRQ, IRQ(:) + INTEGER, ALLOCATABLE :: STATUS(:,:) #endif - REAL :: DTTST, DT1, DT2, W1, W2 - REAL, POINTER :: SBPI(:,:) + REAL :: DTTST, DT1, DT2, W1, W2 + REAL, POINTER :: SBPI(:,:) #ifdef W3_MPI - REAL, ALLOCATABLE :: TSTORE(:,:) - LOGICAL :: FLAGOK + REAL, ALLOCATABLE :: TSTORE(:,:) + LOGICAL :: FLAGOK #endif #ifdef W3_MPIT - LOGICAL :: FLAG + LOGICAL :: FLAG #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOBG') + CALL STRACE (IENT, 'WMIOBG') #endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! -#ifdef W3_T - WRITE (MDST,9000) IMOD - WRITE (MDST,9001) NBI2G(IMOD,:) -#endif -! - IF ( PRESENT(DONE) ) DONE = .FALSE. -! - CALL W3SETO ( IMOD, MDSE, MDST ) -! - IF ( IAPROC .GT. NAPROC ) THEN - IF ( PRESENT(DONE) ) DONE = .TRUE. -#ifdef W3_T - WRITE (MDST,9002) -#endif - RETURN - END IF -! - IF ( SUM(NBI2G(IMOD,:)) .EQ. 0 ) THEN - IF ( PRESENT(DONE) ) DONE = .TRUE. + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! +#ifdef W3_T + WRITE (MDST,9000) IMOD + WRITE (MDST,9001) NBI2G(IMOD,:) +#endif + ! + IF ( PRESENT(DONE) ) DONE = .FALSE. + ! + CALL W3SETO ( IMOD, MDSE, MDST ) + ! + IF ( IAPROC .GT. NAPROC ) THEN + IF ( PRESENT(DONE) ) DONE = .TRUE. #ifdef W3_T - WRITE (MDST,9003) + WRITE (MDST,9002) #endif - RETURN - END IF -! - CALL W3SETG ( IMOD, MDSE, MDST ) - CALL W3SETW ( IMOD, MDSE, MDST ) - CALL W3SETA ( IMOD, MDSE, MDST ) -! - IF ( TBPIN(1) .NE. -1 ) THEN - IF ( DSEC21(TIME,TBPIN) .GT. 0. ) THEN - IF ( PRESENT(DONE) ) DONE = .TRUE. -#ifdef W3_T - WRITE (MDST,9004) -#endif - RETURN - END IF - END IF -! -! -------------------------------------------------------------------- / -! 1. Testing / gathering data in staging arrays -! + RETURN + END IF + ! + IF ( SUM(NBI2G(IMOD,:)) .EQ. 0 ) THEN + IF ( PRESENT(DONE) ) DONE = .TRUE. #ifdef W3_T - WRITE (MDST,9010) + WRITE (MDST,9003) #endif -! -! 1.a Shared memory version, test valid times. - - - - - - - - - - - - / -! + RETURN + END IF + ! + CALL W3SETG ( IMOD, MDSE, MDST ) + CALL W3SETW ( IMOD, MDSE, MDST ) + CALL W3SETA ( IMOD, MDSE, MDST ) + ! + IF ( TBPIN(1) .NE. -1 ) THEN + IF ( DSEC21(TIME,TBPIN) .GT. 0. ) THEN + IF ( PRESENT(DONE) ) DONE = .TRUE. +#ifdef W3_T + WRITE (MDST,9004) +#endif + RETURN + END IF + END IF + ! + ! -------------------------------------------------------------------- / + ! 1. Testing / gathering data in staging arrays + ! +#ifdef W3_T + WRITE (MDST,9010) +#endif + ! + ! 1.a Shared memory version, test valid times. - - - - - - - - - - - - / + ! #ifdef W3_SHRD - DO J=1, NRGRD + DO J=1, NRGRD #endif -! + ! #ifdef W3_SHRD - IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE - VTIME => BPSTGE(IMOD,J)%VTIME + IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE + VTIME => BPSTGE(IMOD,J)%VTIME #endif -! + ! #ifdef W3_SHRD - IF ( VTIME(1) .EQ. -1 ) THEN - IF ( NMPROC .EQ. NMPERR ) WRITE (MDSE,1001) - CALL EXTCDE ( 1001 ) - END IF + IF ( VTIME(1) .EQ. -1 ) THEN + IF ( NMPROC .EQ. NMPERR ) WRITE (MDSE,1001) + CALL EXTCDE ( 1001 ) + END IF #endif -! + ! #ifdef W3_SHRD - DTTST = DSEC21 ( TIME, VTIME ) - IF ( DTTST.LE.0. .AND. TBPIN(1).NE.-1 ) RETURN + DTTST = DSEC21 ( TIME, VTIME ) + IF ( DTTST.LE.0. .AND. TBPIN(1).NE.-1 ) RETURN #endif -! + ! #ifdef W3_SHRD - END DO + END DO #endif -! -! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - / -! + ! + ! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - / + ! #ifdef W3_MPIT - WRITE (MDST,9011) NBISTA(IMOD) + WRITE (MDST,9011) NBISTA(IMOD) #endif -! -! 1.b.1 NBISTA = 0 -! Check if staging arrays are initialized. -! Post the proper receives. -! + ! + ! 1.b.1 NBISTA = 0 + ! Check if staging arrays are initialized. + ! Post the proper receives. + ! #ifdef W3_MPI - IF ( NBISTA(IMOD) .EQ. 0 ) THEN + IF ( NBISTA(IMOD) .EQ. 0 ) THEN #endif -! + ! #ifdef W3_MPI - NRQ => MDATAS(IMOD)%NRQBPG - NRQ = NRGRD + SUM(NBI2G(IMOD,:)) - ALLOCATE ( MDATAS(IMOD)%IRQBPG(NRQ) ) - IRQ => MDATAS(IMOD)%IRQBPG - IRQ = 0 - NRQ = 0 + NRQ => MDATAS(IMOD)%NRQBPG + NRQ = NRGRD + SUM(NBI2G(IMOD,:)) + ALLOCATE ( MDATAS(IMOD)%IRQBPG(NRQ) ) + IRQ => MDATAS(IMOD)%IRQBPG + IRQ = 0 + NRQ = 0 #endif -! + ! #ifdef W3_MPI - DO J=1, NRGRD - IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE + DO J=1, NRGRD + IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE #endif -! -! ..... Staging arrays -! + ! + ! ..... Staging arrays + ! #ifdef W3_MPI - IF ( BPSTGE(IMOD,J)%INIT ) THEN - IF ( RESPEC(IMOD,J) ) THEN - DEALLOCATE ( BPSTGE(IMOD,J)%SBPI ) - BPSTGE(IMOD,J)%INIT = .FALSE. + IF ( BPSTGE(IMOD,J)%INIT ) THEN + IF ( RESPEC(IMOD,J) ) THEN + DEALLOCATE ( BPSTGE(IMOD,J)%SBPI ) + BPSTGE(IMOD,J)%INIT = .FALSE. #endif #ifdef W3_MPIT - WRITE (MDST,9012) J, 'RESET' + WRITE (MDST,9012) J, 'RESET' #endif #ifdef W3_MPI - ELSE - IF ( SIZE(BPSTGE(IMOD,J)%SBPI(:,1)) .NE. & - SGRDS(J)%NSPEC .OR. & - SIZE(BPSTGE(IMOD,J)%SBPI(1,:)) .NE. & - NBI2G(IMOD,J) ) THEN - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1003) - CALL EXTCDE (1003) - END IF + ELSE + IF ( SIZE(BPSTGE(IMOD,J)%SBPI(:,1)) .NE. & + SGRDS(J)%NSPEC .OR. & + SIZE(BPSTGE(IMOD,J)%SBPI(1,:)) .NE. & + NBI2G(IMOD,J) ) THEN + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1003) + CALL EXTCDE (1003) + END IF #endif #ifdef W3_MPIT - WRITE (MDST,9012) J, 'TESTED' + WRITE (MDST,9012) J, 'TESTED' #endif #ifdef W3_MPI - END IF - END IF + END IF + END IF #endif -! + ! #ifdef W3_MPI - IF ( .NOT. BPSTGE(IMOD,J)%INIT ) THEN - NSPEC => SGRDS(J)%NSPEC - ALLOCATE (BPSTGE(IMOD,J)%SBPI(NSPEC,NBI2G(IMOD,J))) - NSPEC => SGRDS(IMOD)%NSPEC - BPSTGE(IMOD,J)%INIT = .TRUE. + IF ( .NOT. BPSTGE(IMOD,J)%INIT ) THEN + NSPEC => SGRDS(J)%NSPEC + ALLOCATE (BPSTGE(IMOD,J)%SBPI(NSPEC,NBI2G(IMOD,J))) + NSPEC => SGRDS(IMOD)%NSPEC + BPSTGE(IMOD,J)%INIT = .TRUE. #endif #ifdef W3_MPIT - WRITE (MDST,9012) J, 'INITIALIZED' + WRITE (MDST,9012) J, 'INITIALIZED' #endif #ifdef W3_MPI - END IF + END IF #endif -! -! ..... Check valid time to determine staging. -! + ! + ! ..... Check valid time to determine staging. + ! #ifdef W3_MPI - VTIME => BPSTGE(IMOD,J)%VTIME - IF ( VTIME(1) .EQ. -1 ) THEN - DTTST = 0. - ELSE - DTTST = DSEC21 ( TIME, VTIME ) - END IF + VTIME => BPSTGE(IMOD,J)%VTIME + IF ( VTIME(1) .EQ. -1 ) THEN + DTTST = 0. + ELSE + DTTST = DSEC21 ( TIME, VTIME ) + END IF #endif #ifdef W3_MPIT - WRITE (MDST,9013) VTIME, DTTST + WRITE (MDST,9013) VTIME, DTTST #endif -! -! ..... Post receives for data gather -! + ! + ! ..... Post receives for data gather + ! #ifdef W3_MPI - IF ( DTTST .LE. 0. ) THEN + IF ( DTTST .LE. 0. ) THEN #endif #ifdef W3_MPIT - WRITE (MDST,9014) J + WRITE (MDST,9014) J #endif -! -! ..... Time -! + ! + ! ..... Time + ! #ifdef W3_MPI - ITAG = MTAG0 + J + (IMOD-1)*NRGRD - IFROM = MDATAS(J)%CROOT - 1 - NRQ = NRQ + 1 - CALL MPI_IRECV ( BPSTGE(IMOD,J)%VTIME, 2, & - MPI_INTEGER, IFROM, ITAG, & - MPI_COMM_MWAVE, IRQ(NRQ), & - IERR_MPI ) + ITAG = MTAG0 + J + (IMOD-1)*NRGRD + IFROM = MDATAS(J)%CROOT - 1 + NRQ = NRQ + 1 + CALL MPI_IRECV ( BPSTGE(IMOD,J)%VTIME, 2, & + MPI_INTEGER, IFROM, ITAG, & + MPI_COMM_MWAVE, IRQ(NRQ), & + IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9015) NRQ, IFROM+1, ITAG-MTAG0, & - IRQ(NRQ), IERR_MPI + WRITE (MDST,9015) NRQ, IFROM+1, ITAG-MTAG0, & + IRQ(NRQ), IERR_MPI #endif -! -! ..... Spectra -! + ! + ! ..... Spectra + ! #ifdef W3_MPI - IF ( J .EQ. 1 ) THEN - IOFF = 0 - ELSE - IOFF = SUM(NBI2G(IMOD,1:J-1)) - END IF + IF ( J .EQ. 1 ) THEN + IOFF = 0 + ELSE + IOFF = SUM(NBI2G(IMOD,1:J-1)) + END IF #endif -! + ! #ifdef W3_MPI - IT0 = MTAG0 + NRGRD**2 + SUM(NBI2G(1:IMOD-1,:)) & - + SUM(NBI2G(IMOD,1:J-1)) + IT0 = MTAG0 + NRGRD**2 + SUM(NBI2G(1:IMOD-1,:)) & + + SUM(NBI2G(IMOD,1:J-1)) #endif -! + ! #ifdef W3_MPI - SBPI => BPSTGE(IMOD,J)%SBPI + SBPI => BPSTGE(IMOD,J)%SBPI #endif -! + ! #ifdef W3_MPI - NAPROC => OUTPTS(J)%NAPROC - NSPEC => SGRDS(J)%NSPEC - DO I=1, NBI2G(IMOD,J) - ISEA = NBI2S(IOFF+I,2) - CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) - NRQ = NRQ + 1 - ITAG = IT0 + I - CALL MPI_IRECV ( SBPI(1,I), NSPEC, & - MPI_REAL, ISPROC-1, & - ITAG, MPI_COMM_MWAVE, & - IRQ(NRQ), IERR_MPI ) + NAPROC => OUTPTS(J)%NAPROC + NSPEC => SGRDS(J)%NSPEC + DO I=1, NBI2G(IMOD,J) + ISEA = NBI2S(IOFF+I,2) + CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) + NRQ = NRQ + 1 + ITAG = IT0 + I + CALL MPI_IRECV ( SBPI(1,I), NSPEC, & + MPI_REAL, ISPROC-1, & + ITAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9016) NRQ, JSEA, ISPROC, & - ITAG-MTAG0, IRQ(NRQ), IERR_MPI + WRITE (MDST,9016) NRQ, JSEA, ISPROC, & + ITAG-MTAG0, IRQ(NRQ), IERR_MPI #endif #ifdef W3_MPI - END DO - NSPEC => SGRDS(IMOD)%NSPEC - NAPROC => OUTPTS(IMOD)%NAPROC + END DO + NSPEC => SGRDS(IMOD)%NSPEC + NAPROC => OUTPTS(IMOD)%NAPROC #endif -! -! ..... End IF for posting receives 1.b.1 -! + ! + ! ..... End IF for posting receives 1.b.1 + ! #ifdef W3_MPIT - WRITE (MDST,9017) + WRITE (MDST,9017) #endif #ifdef W3_MPI - END IF + END IF #endif -! -! ..... End grid loop J in 1.b.1 -! + ! + ! ..... End grid loop J in 1.b.1 + ! #ifdef W3_MPI - END DO + END DO #endif #ifdef W3_MPIT - WRITE (MDST,9018) NRQ + WRITE (MDST,9018) NRQ #endif -! -! ..... Reset status -! NOTE: if NBI.EQ.0 all times are already OK, skip to section 2 -! + ! + ! ..... Reset status + ! NOTE: if NBI.EQ.0 all times are already OK, skip to section 2 + ! #ifdef W3_MPI - IF ( NBI .GT. 0 ) THEN - NBISTA(IMOD) = 1 + IF ( NBI .GT. 0 ) THEN + NBISTA(IMOD) = 1 #endif #ifdef W3_MPIT - WRITE (MDST,9011) NBISTA(IMOD) + WRITE (MDST,9011) NBISTA(IMOD) #endif #ifdef W3_MPI - END IF + END IF #endif -! -! ..... End IF in 1.b.1 -! + ! + ! ..... End IF in 1.b.1 + ! #ifdef W3_MPI - END IF + END IF #endif -! -! 1.b.2 NBISTA = 1 -! Wait for communication to finish. -! If DONE defined, check if done, otherwise wait. -! + ! + ! 1.b.2 NBISTA = 1 + ! Wait for communication to finish. + ! If DONE defined, check if done, otherwise wait. + ! #ifdef W3_MPI - IF ( NBISTA(IMOD) .EQ. 1 ) THEN + IF ( NBISTA(IMOD) .EQ. 1 ) THEN #endif -! + ! #ifdef W3_MPI - NRQ => MDATAS(IMOD)%NRQBPG - IRQ => MDATAS(IMOD)%IRQBPG - ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) + NRQ => MDATAS(IMOD)%NRQBPG + IRQ => MDATAS(IMOD)%IRQBPG + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) #endif -! -! ..... Test communication if DONE is present, wait otherwise -! + ! + ! ..... Test communication if DONE is present, wait otherwise + ! #ifdef W3_MPI - IF ( PRESENT(DONE) ) THEN + IF ( PRESENT(DONE) ) THEN #endif -! + ! #ifdef W3_MPI - CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & - IERR_MPI ) + CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & + IERR_MPI ) #endif -! + ! #ifdef W3_MPIT - ICOUNT = 0 - DO I=1, NRQ - CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & - IERR_MPI ) - FLAGOK = FLAGOK .AND. FLAG - IF ( FLAG ) ICOUNT = ICOUNT + 1 - END DO - WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) + ICOUNT = 0 + DO I=1, NRQ + CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & + IERR_MPI ) + FLAGOK = FLAGOK .AND. FLAG + IF ( FLAG ) ICOUNT = ICOUNT + 1 + END DO + WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) #endif -! + ! #ifdef W3_MPI - ELSE + ELSE #endif -! + ! #ifdef W3_MPI - CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) - FLAGOK = .TRUE. + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + FLAGOK = .TRUE. #endif -! + ! #ifdef W3_MPI - END IF + END IF #endif -! + ! #ifdef W3_MPI - DEALLOCATE ( STATUS ) + DEALLOCATE ( STATUS ) #endif -! -! ..... Go on based on FLAGOK -! + ! + ! ..... Go on based on FLAGOK + ! #ifdef W3_MPI - IF ( FLAGOK ) THEN - DEALLOCATE ( MDATAS(IMOD)%IRQBPG ) - NRQ = 0 - ELSE - RETURN - END IF + IF ( FLAGOK ) THEN + DEALLOCATE ( MDATAS(IMOD)%IRQBPG ) + NRQ = 0 + ELSE + RETURN + END IF #endif -! + ! #ifdef W3_MPI - NBISTA(IMOD) = 2 + NBISTA(IMOD) = 2 #endif #ifdef W3_MPIT - WRITE (MDST,9011) NBISTA(IMOD) + WRITE (MDST,9011) NBISTA(IMOD) #endif -! -! 1.b.3 Convert spectra if needed -! + ! + ! 1.b.3 Convert spectra if needed + ! #ifdef W3_MPI - DO J=1, NRGRD + DO J=1, NRGRD #endif -! + ! #ifdef W3_MPI - IF ( RESPEC(IMOD,J) .AND. NBI2G(IMOD,J).NE.0 ) THEN + IF ( RESPEC(IMOD,J) .AND. NBI2G(IMOD,J).NE.0 ) THEN #endif -! + ! #ifdef W3_MPIT - WRITE (MDST,9100) J + WRITE (MDST,9100) J #endif #ifdef W3_MPI - NSPEC => SGRDS(J)%NSPEC - ALLOCATE ( TSTORE(NSPEC,NBI2G(IMOD,J))) - NSPEC => SGRDS(IMOD)%NSPEC - TSTORE = BPSTGE(IMOD,J)%SBPI - DEALLOCATE ( BPSTGE(IMOD,J)%SBPI ) - ALLOCATE (BPSTGE(IMOD,J)%SBPI(NSPEC,NBI2G(IMOD,J))) + NSPEC => SGRDS(J)%NSPEC + ALLOCATE ( TSTORE(NSPEC,NBI2G(IMOD,J))) + NSPEC => SGRDS(IMOD)%NSPEC + TSTORE = BPSTGE(IMOD,J)%SBPI + DEALLOCATE ( BPSTGE(IMOD,J)%SBPI ) + ALLOCATE (BPSTGE(IMOD,J)%SBPI(NSPEC,NBI2G(IMOD,J))) #endif -! + ! #ifdef W3_MPI - SBPI => BPSTGE(IMOD,J)%SBPI - CALL W3CSPC ( TSTORE, SGRDS(J)%NK, SGRDS(J)%NTH, & - SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), & - SBPI, NK, NTH, XFR, FR1, TH(1), & - NBI2G(IMOD,J), MDST, MDSE, SGRDS(IMOD)%FACHFE) + SBPI => BPSTGE(IMOD,J)%SBPI + CALL W3CSPC ( TSTORE, SGRDS(J)%NK, SGRDS(J)%NTH, & + SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), & + SBPI, NK, NTH, XFR, FR1, TH(1), & + NBI2G(IMOD,J), MDST, MDSE, SGRDS(IMOD)%FACHFE) #endif -! + ! #ifdef W3_MPI - DEALLOCATE ( TSTORE ) + DEALLOCATE ( TSTORE ) #endif -! + ! #ifdef W3_MPI - END IF + END IF #endif -! + ! #ifdef W3_MPI - END DO + END DO #endif -! + ! #ifdef W3_MPI - NBISTA(IMOD) = 0 + NBISTA(IMOD) = 0 #endif #ifdef W3_MPIT - WRITE (MDST,9011) NBISTA(IMOD) -#endif -! -#ifdef W3_MPI - END IF -#endif -! -! -------------------------------------------------------------------- / -! 2. Update arrays ABPI0/N and data times -! -#ifdef W3_T - WRITE (MDST,9020) -#endif -! -! 2.a Determine next valid time -! - TTEST = -1 - DO J=1, NRGRD - IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE - VTIME => BPSTGE(IMOD,J)%VTIME - IF ( TTEST(1) .EQ. -1 ) THEN - TTEST = VTIME - ELSE - DTTST = DSEC21(VTIME,TTEST) - IF ( DTTST .GT. 0. ) TTEST = VTIME - END IF - END DO -! -#ifdef W3_T - WRITE (MDST,9021) TTEST -#endif -! -! 2.b Shift data -! + WRITE (MDST,9011) NBISTA(IMOD) +#endif + ! +#ifdef W3_MPI + END IF +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Update arrays ABPI0/N and data times + ! +#ifdef W3_T + WRITE (MDST,9020) +#endif + ! + ! 2.a Determine next valid time + ! + TTEST = -1 + DO J=1, NRGRD + IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE + VTIME => BPSTGE(IMOD,J)%VTIME + IF ( TTEST(1) .EQ. -1 ) THEN + TTEST = VTIME + ELSE + DTTST = DSEC21(VTIME,TTEST) + IF ( DTTST .GT. 0. ) TTEST = VTIME + END IF + END DO + ! +#ifdef W3_T + WRITE (MDST,9021) TTEST +#endif + ! + ! 2.b Shift data + ! + IF ( TBPIN(1) .EQ. -1 ) THEN + DTTST = DSEC21(TTEST,TIME) + IF ( DTTST .NE. 0. ) THEN + IF ( NMPROC .EQ. NMPERR ) WRITE (MDSE,1002) + CALL EXTCDE(1002) + END IF + ABPI0 = 0. + ELSE + TBPI0 = TBPIN + ABPI0 = ABPIN + END IF + ! + ! 2.c Loop over grids for new spectra + ! + DO J=1, NRGRD + ! + IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE + VTIME => BPSTGE(IMOD,J)%VTIME + SBPI => BPSTGE(IMOD,J)%SBPI + ! + IF ( J .EQ. 1 ) THEN + IOFF = 0 + ELSE + IOFF = SUM(NBI2G(IMOD,1:J-1)) + END IF + ! IF ( TBPIN(1) .EQ. -1 ) THEN - DTTST = DSEC21(TTEST,TIME) - IF ( DTTST .NE. 0. ) THEN - IF ( NMPROC .EQ. NMPERR ) WRITE (MDSE,1002) - CALL EXTCDE(1002) - END IF - ABPI0 = 0. - ELSE - TBPI0 = TBPIN - ABPI0 = ABPIN - END IF -! -! 2.c Loop over grids for new spectra -! - DO J=1, NRGRD -! - IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE - VTIME => BPSTGE(IMOD,J)%VTIME - SBPI => BPSTGE(IMOD,J)%SBPI -! - IF ( J .EQ. 1 ) THEN - IOFF = 0 - ELSE - IOFF = SUM(NBI2G(IMOD,1:J-1)) - END IF -! - IF ( TBPIN(1) .EQ. -1 ) THEN - W1 = 0. - W2 = 1. - ELSE - DT1 = DSEC21(TBPI0,VTIME) - DT2 = DSEC21(TBPI0,TTEST) - W2 = DT2 / DT1 - W1 = 1. - W2 - END IF -#ifdef W3_T - WRITE (MDST,9022) NBI2G(IMOD,J), J, IOFF+1, W1, W2 -#endif -! - ABPIN(:,IOFF+1:IOFF+NBI2G(IMOD,J)) = & - W1 * ABPI0(:,IOFF+1:IOFF+NBI2G(IMOD,J)) + & - W2 * SBPI(:,1:NBI2G(IMOD,J)) -! - END DO -! -! 2.d New time -! - TBPIN = TTEST -! -! -------------------------------------------------------------------- / -! 3. Dump data to file if requested -! - IF ( IAPROC.EQ.NAPBPT .AND. BCDUMP(IMOD) ) THEN -#ifdef W3_T - WRITE (MDST,9030) -#endif - CALL W3IOBC ( 'DUMP', NDS(9), TBPIN, TBPIN, ITEST, IMOD ) - END IF -! -! -------------------------------------------------------------------- / -! 4. Update arrays BBPI0/N -! -#ifdef W3_T - WRITE (MDST,9040) -#endif -! - CALL W3UBPT -! -! -------------------------------------------------------------------- / -! 5. Successful update -! - IF ( PRESENT(DONE) ) DONE = .TRUE. -! - RETURN -! -! Formats -! + W1 = 0. + W2 = 1. + ELSE + DT1 = DSEC21(TBPI0,VTIME) + DT2 = DSEC21(TBPI0,TTEST) + W2 = DT2 / DT1 + W1 = 1. - W2 + END IF +#ifdef W3_T + WRITE (MDST,9022) NBI2G(IMOD,J), J, IOFF+1, W1, W2 +#endif + ! + ABPIN(:,IOFF+1:IOFF+NBI2G(IMOD,J)) = & + W1 * ABPI0(:,IOFF+1:IOFF+NBI2G(IMOD,J)) + & + W2 * SBPI(:,1:NBI2G(IMOD,J)) + ! + END DO + ! + ! 2.d New time + ! + TBPIN = TTEST + ! + ! -------------------------------------------------------------------- / + ! 3. Dump data to file if requested + ! + IF ( IAPROC.EQ.NAPBPT .AND. BCDUMP(IMOD) ) THEN +#ifdef W3_T + WRITE (MDST,9030) +#endif + CALL W3IOBC ( 'DUMP', NDS(9), TBPIN, TBPIN, ITEST, IMOD ) + END IF + ! + ! -------------------------------------------------------------------- / + ! 4. Update arrays BBPI0/N + ! +#ifdef W3_T + WRITE (MDST,9040) +#endif + ! + CALL W3UBPT + ! + ! -------------------------------------------------------------------- / + ! 5. Successful update + ! + IF ( PRESENT(DONE) ) DONE = .TRUE. + ! + RETURN + ! + ! Formats + ! #ifdef W3_SHRD - 1001 FORMAT (/' *** ERROR WMIOBG : NO DATA IN STAGING ARRAY ***'/ & - ' CALL WMIOBS FIRST '/) +1001 FORMAT (/' *** ERROR WMIOBG : NO DATA IN STAGING ARRAY ***'/ & + ' CALL WMIOBS FIRST '/) #endif - 1002 FORMAT (/' *** ERROR WMIOBG : INITIAL DATA NOT AT INITAL ', & - 'MODEL TIME ***'/) +1002 FORMAT (/' *** ERROR WMIOBG : INITIAL DATA NOT AT INITAL ', & + 'MODEL TIME ***'/) #ifdef W3_MPI - 1003 FORMAT (/' *** ERROR WMIOBG : UNEXPECTED SIZE OF STAGING', & - ' ARRAY ***') +1003 FORMAT (/' *** ERROR WMIOBG : UNEXPECTED SIZE OF STAGING', & + ' ARRAY ***') #endif -! + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMIOBG : GATHERING DATA FOR GRID ',I3) - 9001 FORMAT ( ' TEST WMIOBG : NR. OF SPECTRA PER SOURCE GRID : '/ & - ' ',25I4) - 9002 FORMAT ( ' TEST WMIOBG : NO DATA NEEDED ON PROCESSOR') - 9003 FORMAT ( ' TEST WMIOBG : NO DATA TO BE GATHERED') - 9004 FORMAT ( ' TEST WMIOBG : DATA UP TO DATE') +9000 FORMAT ( ' TEST WMIOBG : GATHERING DATA FOR GRID ',I3) +9001 FORMAT ( ' TEST WMIOBG : NR. OF SPECTRA PER SOURCE GRID : '/ & + ' ',25I4) +9002 FORMAT ( ' TEST WMIOBG : NO DATA NEEDED ON PROCESSOR') +9003 FORMAT ( ' TEST WMIOBG : NO DATA TO BE GATHERED') +9004 FORMAT ( ' TEST WMIOBG : DATA UP TO DATE') #endif -! + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMIOBG : TEST DATA AVAILABILITY') +9010 FORMAT ( ' TEST WMIOBG : TEST DATA AVAILABILITY') #endif #ifdef W3_MPIT - 9011 FORMAT ( ' MPIT WMIOBG : NBISTA =',I2) - 9012 FORMAT ( ' STAGING ARRAY FROM',I4,1X,A) - 9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) - 9014 FORMAT (/' MPIT WMIOBG : RECEIVE FROM GRID',I4/ & - ' +------+------+------+------+--------------+'/ & - ' | IH | ID | FROM | TAG | handle err |'/ & - ' +------+------+------+------+--------------+') - 9015 FORMAT ( ' |',I5,' | TIME |',2(I5,' |'),I9,I4,' |') - 9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') - 9017 FORMAT ( ' +------+------+------+------+--------------+'/) - 9018 FORMAT ( ' MPIT WMIOBG : NRQHGH:',I10/) - 9019 FORMAT ( ' MPIT WMIOBG : RECEIVES FINISHED :',F6.1,'%') - 9100 FORMAT ( ' MPIT WMIOBG : CONVERTING SPECTRA FROM GRID',I3) -#endif -! -#ifdef W3_T - 9020 FORMAT ( ' TEST WMIOBG : FILLING ABPI0/N AND TIMES') - 9021 FORMAT ( ' TEST WMIOBG : NEXT VALID TIME FOR ABPIN:',I9.8,I7.6) - 9022 FORMAT ( ' TEST WMIOBG : GETTING',I4,' SPECTRA FROM GRID ', & - I3,' STORING AT ',I3/ & - ' WEIGHTS : ',2F6.3) -#endif -! -#ifdef W3_T - 9030 FORMAT ( ' TEST WMIOBG : DUMP DATA TO FILE') -#endif -! -#ifdef W3_T - 9040 FORMAT ( ' TEST WMIOBG : FILLING BBPI0/N') -#endif -!/ -!/ End of WMIOBG ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOBG -!/ ------------------------------------------------------------------- / -!> -!> @brief Finalize staging of internal boundary data in the data -!> structure BPSTGE (MPI only). -!> -!> @details Post appropriate 'wait' functions to assure that the -!> communication has finished. -!> -!> @param[in] IMOD Model number of grid from which data has -!> been staged. -!> -!> @author H. L. Tolman @date 29-May-2006 -!> - SUBROUTINE WMIOBF ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2006 ! -!/ +-----------------------------------+ -!/ -!/ 18-Oct-2005 : Origination. ( version 3.08 ) -!/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 ) -!/ -! 1. Purpose : -! -! Finalize staging of internal boundary data in the data -! structure BPSTGE (MPI only). -! -! 2. Method : -! -! Post appropriate 'wait' functions to assure that the -! communication has finished. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number of grid from which data has -! been staged. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_WAITALL -! Subr. mpif.h MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINIT Subr WMINITMD Multi-grid model initialization. -! WMWAVE Subr WMWAVEMD Multi-grid wave model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Shared/distributed memory models. -! !/DIST -! !/MPI -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE WMMDATMD -! +9011 FORMAT ( ' MPIT WMIOBG : NBISTA =',I2) +9012 FORMAT ( ' STAGING ARRAY FROM',I4,1X,A) +9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) +9014 FORMAT (/' MPIT WMIOBG : RECEIVE FROM GRID',I4/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | FROM | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') +9015 FORMAT ( ' |',I5,' | TIME |',2(I5,' |'),I9,I4,' |') +9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') +9017 FORMAT ( ' +------+------+------+------+--------------+'/) +9018 FORMAT ( ' MPIT WMIOBG : NRQHGH:',I10/) +9019 FORMAT ( ' MPIT WMIOBG : RECEIVES FINISHED :',F6.1,'%') +9100 FORMAT ( ' MPIT WMIOBG : CONVERTING SPECTRA FROM GRID',I3) +#endif + ! +#ifdef W3_T +9020 FORMAT ( ' TEST WMIOBG : FILLING ABPI0/N AND TIMES') +9021 FORMAT ( ' TEST WMIOBG : NEXT VALID TIME FOR ABPIN:',I9.8,I7.6) +9022 FORMAT ( ' TEST WMIOBG : GETTING',I4,' SPECTRA FROM GRID ', & + I3,' STORING AT ',I3/ & + ' WEIGHTS : ',2F6.3) +#endif + ! +#ifdef W3_T +9030 FORMAT ( ' TEST WMIOBG : DUMP DATA TO FILE') +#endif + ! +#ifdef W3_T +9040 FORMAT ( ' TEST WMIOBG : FILLING BBPI0/N') +#endif + !/ + !/ End of WMIOBG ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOBG + !/ ------------------------------------------------------------------- / + !> + !> @brief Finalize staging of internal boundary data in the data + !> structure BPSTGE (MPI only). + !> + !> @details Post appropriate 'wait' functions to assure that the + !> communication has finished. + !> + !> @param[in] IMOD Model number of grid from which data has + !> been staged. + !> + !> @author H. L. Tolman @date 29-May-2006 + !> + SUBROUTINE WMIOBF ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2006 ! + !/ +-----------------------------------+ + !/ + !/ 18-Oct-2005 : Origination. ( version 3.08 ) + !/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 ) + !/ + ! 1. Purpose : + ! + ! Finalize staging of internal boundary data in the data + ! structure BPSTGE (MPI only). + ! + ! 2. Method : + ! + ! Post appropriate 'wait' functions to assure that the + ! communication has finished. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number of grid from which data has + ! been staged. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_WAITALL + ! Subr. mpif.h MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINIT Subr WMINITMD Multi-grid model initialization. + ! WMWAVE Subr WMWAVEMD Multi-grid wave model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Shared/distributed memory models. + ! !/DIST + ! !/MPI + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE WMMDATMD + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J #ifdef W3_MPI - INTEGER :: IERR_MPI - INTEGER, POINTER :: NRQ, IRQ(:) - INTEGER, ALLOCATABLE :: STATUS(:,:) + INTEGER :: IERR_MPI + INTEGER, POINTER :: NRQ, IRQ(:) + INTEGER, ALLOCATABLE :: STATUS(:,:) #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOBF') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! -#ifdef W3_T - WRITE (MDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 1. Loop over grids -! - DO J=1, NRGRD -! -#ifdef W3_MPI - NRQ => BPSTGE(J,IMOD)%NRQBPS -#endif -! -! 1.a Nothing to finalize -! -#ifdef W3_MPI - IF ( NRQ .EQ. 0 ) CYCLE - IRQ => BPSTGE(J,IMOD)%IRQBPS -#endif -! -! 1.b Wait for communication to end -! -#ifdef W3_MPI - ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) - CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) - DEALLOCATE ( STATUS ) -#endif -! -! 1.c Reset arrays and counter -! -#ifdef W3_MPI - NRQ = 0 - DEALLOCATE ( BPSTGE(J,IMOD)%IRQBPS , & - BPSTGE(J,IMOD)%TSTORE ) -#endif -! -#ifdef W3_T - WRITE (MDST,9010) J -#endif -! - END DO -! - RETURN -! -! Formats -! -#ifdef W3_T - 9000 FORMAT ( ' TEST WMIOBF : FINALIZE STAGING DATA FROM GRID ',I3) - 9010 FORMAT ( ' TEST WMIOBF : FINISHED WITH TARGET ',I3) -#endif -!/ -!/ End of WMIOBF ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOBF -!/ ------------------------------------------------------------------- / -!> -!> @brief Stage internal high-to-low data in the data structure HGSTGE. -!> -!> @details Directly fill staging arrays in shared memory version, or post -!> the corresponding sends in distributed memory version. -!> -!> @param[in] IMOD Model number of grid from which data is to -!> be staged. -!> -!> @author H. L. Tolman @date 28-Sep-2016 -!> - SUBROUTINE WMIOHS ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 28-Sep-2016 ! -!/ +-----------------------------------+ -!/ -!/ 27-Jan-2006 : Origination. ( version 3.08 ) -!/ 20-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 ) -!/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 ) -!/ -! 1. Purpose : -! -! Stage internal high-to-low data in the data structure HGSTGE. -! -! 2. Method : -! -! Directly fill staging arrays in shared memory version, or post -! the corresponding sends in distributed memory version. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number of grid from which data is to -! be staged. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM -! Subr. WxxDATMD Manage data structures. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Sur. Id. Program abort. -! DSEC21 Func. W3TIMEMD Difference between times. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Subr WMWAVEMD Multi-grid wave model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See FORMAT label 1001. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Shared/distributed memory models. -! !/DIST -! !/MPI -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/MPIT -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3GDATMD - USE W3WDATMD - USE W3ADATMD - USE W3ODATMD - USE WMMDATMD -! - USE W3SERVMD, ONLY: EXTCDE + CALL STRACE (IENT, 'WMIOBF') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! +#ifdef W3_T + WRITE (MDST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Loop over grids + ! + DO J=1, NRGRD + ! +#ifdef W3_MPI + NRQ => BPSTGE(J,IMOD)%NRQBPS +#endif + ! + ! 1.a Nothing to finalize + ! +#ifdef W3_MPI + IF ( NRQ .EQ. 0 ) CYCLE + IRQ => BPSTGE(J,IMOD)%IRQBPS +#endif + ! + ! 1.b Wait for communication to end + ! +#ifdef W3_MPI + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + DEALLOCATE ( STATUS ) +#endif + ! + ! 1.c Reset arrays and counter + ! +#ifdef W3_MPI + NRQ = 0 + DEALLOCATE ( BPSTGE(J,IMOD)%IRQBPS , & + BPSTGE(J,IMOD)%TSTORE ) +#endif + ! +#ifdef W3_T + WRITE (MDST,9010) J +#endif + ! + END DO + ! + RETURN + ! + ! Formats + ! +#ifdef W3_T +9000 FORMAT ( ' TEST WMIOBF : FINALIZE STAGING DATA FROM GRID ',I3) +9010 FORMAT ( ' TEST WMIOBF : FINISHED WITH TARGET ',I3) +#endif + !/ + !/ End of WMIOBF ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOBF + !/ ------------------------------------------------------------------- / + !> + !> @brief Stage internal high-to-low data in the data structure HGSTGE. + !> + !> @details Directly fill staging arrays in shared memory version, or post + !> the corresponding sends in distributed memory version. + !> + !> @param[in] IMOD Model number of grid from which data is to + !> be staged. + !> + !> @author H. L. Tolman @date 28-Sep-2016 + !> + SUBROUTINE WMIOHS ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 28-Sep-2016 ! + !/ +-----------------------------------+ + !/ + !/ 27-Jan-2006 : Origination. ( version 3.08 ) + !/ 20-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 ) + !/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 ) + !/ + ! 1. Purpose : + ! + ! Stage internal high-to-low data in the data structure HGSTGE. + ! + ! 2. Method : + ! + ! Directly fill staging arrays in shared memory version, or post + ! the corresponding sends in distributed memory version. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number of grid from which data is to + ! be staged. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM + ! Subr. WxxDATMD Manage data structures. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Sur. Id. Program abort. + ! DSEC21 Func. W3TIMEMD Difference between times. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr WMWAVEMD Multi-grid wave model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See FORMAT label 1001. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Shared/distributed memory models. + ! !/DIST + ! !/MPI + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/MPIT + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GDATMD + USE W3WDATMD + USE W3ADATMD + USE W3ODATMD + USE WMMDATMD + ! + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3TIMEMD, ONLY: DSEC21 - USE W3PARALL, ONLY: INIT_GET_ISEA -! - IMPLICIT NONE -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, NR, I, JSEA, ISEA, IS -#ifdef W3_MPI - INTEGER :: ITAG, IP, IT0, IERR_MPI -#endif - INTEGER :: I1, I2 + USE W3SERVMD, ONLY: STRACE +#endif + USE W3TIMEMD, ONLY: DSEC21 + USE W3PARALL, ONLY: INIT_GET_ISEA + ! + IMPLICIT NONE + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, NR, I, JSEA, ISEA, IS +#ifdef W3_MPI + INTEGER :: ITAG, IP, IT0, IERR_MPI +#endif + INTEGER :: I1, I2 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_MPI - INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:) + INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:) #endif - REAL :: DTOUTP + REAL :: DTOUTP #ifdef W3_SHRD - REAL, POINTER :: SHGH(:,:,:) + REAL, POINTER :: SHGH(:,:,:) #endif #ifdef W3_MPI - REAL, POINTER :: SHGH(:,:) + REAL, POINTER :: SHGH(:,:) #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOHS') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! -#ifdef W3_T - WRITE (MDST,9000) IMOD, FLGHG1 -#endif -! + CALL STRACE (IENT, 'WMIOHS') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! +#ifdef W3_T + WRITE (MDST,9000) IMOD, FLGHG1 +#endif + ! + IF ( .NOT. FLGHG1 ) THEN +#ifdef W3_T + WRITE (MDST,9001) HGSTGE(:,IMOD)%NSND +#endif + IF ( SUM(HGSTGE(:,IMOD)%NSND) .EQ. 0 ) RETURN + ELSE +#ifdef W3_T + WRITE (MDST,9001) HGSTGE(:,IMOD)%NSN1 +#endif + IF ( SUM(HGSTGE(:,IMOD)%NSN1) .EQ. 0 ) RETURN + END IF + ! + CALL W3SETO ( IMOD, MDSE, MDST ) + CALL W3SETG ( IMOD, MDSE, MDST ) + CALL W3SETW ( IMOD, MDSE, MDST ) + CALL W3SETA ( IMOD, MDSE, MDST ) + ! + ! -------------------------------------------------------------------- / + ! 1. Loop over grids + ! + DO J=1, NRGRD + ! + IF ( J .EQ. IMOD ) CYCLE + ! IF ( .NOT. FLGHG1 ) THEN -#ifdef W3_T - WRITE (MDST,9001) HGSTGE(:,IMOD)%NSND -#endif - IF ( SUM(HGSTGE(:,IMOD)%NSND) .EQ. 0 ) RETURN + NR = HGSTGE(J,IMOD)%NSND + ELSE IF ( FLGHG2 ) THEN + NR = HGSTGE(J,IMOD)%NSN1 + ELSE + IF ( TOUTP(1,J) .EQ. -1 ) THEN + DTOUTP = 1. ELSE -#ifdef W3_T - WRITE (MDST,9001) HGSTGE(:,IMOD)%NSN1 -#endif - IF ( SUM(HGSTGE(:,IMOD)%NSN1) .EQ. 0 ) RETURN + DTOUTP = DSEC21(TIME,TOUTP(:,J)) END IF -! - CALL W3SETO ( IMOD, MDSE, MDST ) - CALL W3SETG ( IMOD, MDSE, MDST ) - CALL W3SETW ( IMOD, MDSE, MDST ) - CALL W3SETA ( IMOD, MDSE, MDST ) -! -! -------------------------------------------------------------------- / -! 1. Loop over grids -! - DO J=1, NRGRD -! - IF ( J .EQ. IMOD ) CYCLE -! - IF ( .NOT. FLGHG1 ) THEN - NR = HGSTGE(J,IMOD)%NSND - ELSE IF ( FLGHG2 ) THEN - NR = HGSTGE(J,IMOD)%NSN1 - ELSE - IF ( TOUTP(1,J) .EQ. -1 ) THEN - DTOUTP = 1. - ELSE - DTOUTP = DSEC21(TIME,TOUTP(:,J)) - END IF - IF ( DTOUTP .EQ. 0. ) THEN - NR = HGSTGE(J,IMOD)%NSND - ELSE - NR = HGSTGE(J,IMOD)%NSN1 - END IF - END IF -! -#ifdef W3_T - IF ( NR .EQ. 0 ) THEN - WRITE (MDST,9010) J, NR - ELSE - WRITE (MDST,9011) J, NR, DSEC21(TIME,TSYNC(:,J)), DTOUTP - END IF -#endif -! - IF ( NR .EQ. 0 ) CYCLE - IF ( DSEC21(TIME,TSYNC(:,J)) .NE. 0. ) CYCLE -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays and/or point pointers -! + IF ( DTOUTP .EQ. 0. ) THEN + NR = HGSTGE(J,IMOD)%NSND + ELSE + NR = HGSTGE(J,IMOD)%NSN1 + END IF + END IF + ! +#ifdef W3_T + IF ( NR .EQ. 0 ) THEN + WRITE (MDST,9010) J, NR + ELSE + WRITE (MDST,9011) J, NR, DSEC21(TIME,TSYNC(:,J)), DTOUTP + END IF +#endif + ! + IF ( NR .EQ. 0 ) CYCLE + IF ( DSEC21(TIME,TSYNC(:,J)) .NE. 0. ) CYCLE + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays and/or point pointers + ! #ifdef W3_SHRD - SHGH => HGSTGE(J,IMOD)%SHGH + SHGH => HGSTGE(J,IMOD)%SHGH #endif #ifdef W3_MPI - ALLOCATE ( HGSTGE(J,IMOD)%TSTORE(NSPEC,NR) ) - SHGH => HGSTGE(J,IMOD)%TSTORE + ALLOCATE ( HGSTGE(J,IMOD)%TSTORE(NSPEC,NR) ) + SHGH => HGSTGE(J,IMOD)%TSTORE #endif -! + ! #ifdef W3_MPI - ALLOCATE ( HGSTGE(J,IMOD)%IRQHGS(NR) ) - ALLOCATE ( HGSTGE(J,IMOD)%OUTDAT(NR,3) ) + ALLOCATE ( HGSTGE(J,IMOD)%IRQHGS(NR) ) + ALLOCATE ( HGSTGE(J,IMOD)%OUTDAT(NR,3) ) #endif -! + ! #ifdef W3_MPI - NRQ => HGSTGE(J,IMOD)%NRQHGS - NRQOUT => HGSTGE(J,IMOD)%NRQOUT - IRQ => HGSTGE(J,IMOD)%IRQHGS - OUTDAT => HGSTGE(J,IMOD)%OUTDAT - NRQ = 0 - NRQOUT = 0 - IRQ = 0 + NRQ => HGSTGE(J,IMOD)%NRQHGS + NRQOUT => HGSTGE(J,IMOD)%NRQOUT + IRQ => HGSTGE(J,IMOD)%IRQHGS + OUTDAT => HGSTGE(J,IMOD)%OUTDAT + NRQ = 0 + NRQOUT = 0 + IRQ = 0 #endif -! -! -------------------------------------------------------------------- / -! 3. Set the time -! !/SHRD only. -! + ! + ! -------------------------------------------------------------------- / + ! 3. Set the time + ! !/SHRD only. + ! #ifdef W3_T - WRITE (MDST,9030) TIME + WRITE (MDST,9030) TIME #endif -! + ! #ifdef W3_SHRD - HGSTGE(J,IMOD)%VTIME = TIME + HGSTGE(J,IMOD)%VTIME = TIME #endif -! -! -------------------------------------------------------------------- / -! 4. Stage the spectral data -! + ! + ! -------------------------------------------------------------------- / + ! 4. Stage the spectral data + ! #ifdef W3_MPIT - WRITE (MDST,9080) + WRITE (MDST,9080) #endif #ifdef W3_MPI - IT0 = MTAG1 + 1 + IT0 = MTAG1 + 1 #endif -! - DO I=1, NR -! - JSEA = HGSTGE(J,IMOD)%ISEND(I,1) - CALL INIT_GET_ISEA(ISEA, JSEA) + ! + DO I=1, NR + ! + JSEA = HGSTGE(J,IMOD)%ISEND(I,1) + CALL INIT_GET_ISEA(ISEA, JSEA) #ifdef W3_DIST - IP = HGSTGE(J,IMOD)%ISEND(I,2) + IP = HGSTGE(J,IMOD)%ISEND(I,2) #endif - I1 = HGSTGE(J,IMOD)%ISEND(I,3) - I2 = HGSTGE(J,IMOD)%ISEND(I,4) + I1 = HGSTGE(J,IMOD)%ISEND(I,3) + I2 = HGSTGE(J,IMOD)%ISEND(I,4) #ifdef W3_MPI - ITAG = HGSTGE(J,IMOD)%ISEND(I,5) + IT0 - IF ( ITAG .GT. MTAG2 ) THEN - WRITE (MDSE,1001) - CALL EXTCDE (1001) - END IF + ITAG = HGSTGE(J,IMOD)%ISEND(I,5) + IT0 + IF ( ITAG .GT. MTAG2 ) THEN + WRITE (MDSE,1001) + CALL EXTCDE (1001) + END IF #endif -! - DO IS=1, NSPEC + ! + DO IS=1, NSPEC #ifdef W3_SHRD - SHGH(IS,I2,I1) = VA(IS,JSEA) * SIG2(IS) & - / CG(1+(IS-1)/NTH,ISEA) + SHGH(IS,I2,I1) = VA(IS,JSEA) * SIG2(IS) & + / CG(1+(IS-1)/NTH,ISEA) #endif #ifdef W3_MPI - SHGH( IS,I ) = VA(IS,JSEA) * SIG2(IS) & - / CG(1+(IS-1)/NTH,ISEA) + SHGH( IS,I ) = VA(IS,JSEA) * SIG2(IS) & + / CG(1+(IS-1)/NTH,ISEA) #endif - END DO -! + END DO + ! #ifdef W3_MPI - IF ( IP .NE. IMPROC ) THEN - NRQ = NRQ + 1 - CALL MPI_ISEND ( SHGH(1,I), NSPEC, MPI_REAL, IP-1, & - ITAG, MPI_COMM_MWAVE, IRQ(NRQ), IERR_MPI ) + IF ( IP .NE. IMPROC ) THEN + NRQ = NRQ + 1 + CALL MPI_ISEND ( SHGH(1,I), NSPEC, MPI_REAL, IP-1, & + ITAG, MPI_COMM_MWAVE, IRQ(NRQ), IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG1, & - IRQ(NRQ), IERR_MPI + WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG1, & + IRQ(NRQ), IERR_MPI #endif #ifdef W3_MPI - ELSE - NRQOUT = NRQOUT + 1 - OUTDAT(NRQOUT,1) = I - OUTDAT(NRQOUT,2) = I2 - OUTDAT(NRQOUT,3) = I1 - END IF + ELSE + NRQOUT = NRQOUT + 1 + OUTDAT(NRQOUT,1) = I + OUTDAT(NRQOUT,2) = I2 + OUTDAT(NRQOUT,3) = I1 + END IF #endif -! - END DO -! + ! + END DO + ! #ifdef W3_MPIT - WRITE (MDST,9083) - WRITE (MDST,9084) NRQ + WRITE (MDST,9083) + WRITE (MDST,9084) NRQ #endif -! - END DO -! - RETURN -! -! Formats -! + ! + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_MPI - 1001 FORMAT (/' *** ERROR WMIOHS : REQUESTED MPI TAG EXCEEDS', & - ' UPPER BOUND (MTAG2) ***') +1001 FORMAT (/' *** ERROR WMIOHS : REQUESTED MPI TAG EXCEEDS', & + ' UPPER BOUND (MTAG2) ***') #endif #ifdef W3_T - 9000 FORMAT ( ' TEST WMIOHS : STAGING DATA FROM GRID ',I3, & - ' FLGHG1 = ',L1) - 9001 FORMAT ( ' TEST WMIOHS : NR. OF SPECTRA PER GRID : '/ & - ' ',15I6) +9000 FORMAT ( ' TEST WMIOHS : STAGING DATA FROM GRID ',I3, & + ' FLGHG1 = ',L1) +9001 FORMAT ( ' TEST WMIOHS : NR. OF SPECTRA PER GRID : '/ & + ' ',15I6) #endif -! + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',I3, & - ' NR = ',I6) - 9011 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',I3, & - ' NR = ',I6,' TIME GAP = ',2F8.1) +9010 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',I3, & + ' NR = ',I6) +9011 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',I3, & + ' NR = ',I6,' TIME GAP = ',2F8.1) #endif -! + ! #ifdef W3_T - 9030 FORMAT ( ' TEST WMIOHS : TIME :',I10.8,I7.6) +9030 FORMAT ( ' TEST WMIOHS : TIME :',I10.8,I7.6) #endif -! + ! #ifdef W3_MPIT - 9080 FORMAT (/' MPIT WMIOHS: COMMUNICATION CALLS '/ & - ' +------+------+------+------+--------------+'/ & - ' | IH | ID | TARG | TAG | handle err |'/ & - ' +------+------+------+------+--------------+') - 9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') - 9083 FORMAT ( ' +------+------+------+------+--------------+') - 9084 FORMAT ( ' MPIT WMIOHS: NRQHGS:',I10/) -#endif -!/ -!/ End of WMIOHS ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOHS -!/ ------------------------------------------------------------------- / -!> -!> @brief Gather internal high-to-low data for a given model. -!> -!> @details For distributed memory version first receive all staged data. -!> After staged data is present, average, convert as necessary, -!> and store in basic spectral arrays. -!> -!> Using storage array HGSTAGE and time stamps. -!> -!> @param[in] IMOD Model number of grid from which data is to -!> be gathered. -!> @param[out] DONE Flag for completion of operation (opt). -!> -!> @author H. L. Tolman @date 20-Dec-2006 -!> - SUBROUTINE WMIOHG ( IMOD, DONE ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 20-Dec-2006 ! -!/ +-----------------------------------+ -!/ -!/ 27-Jan-2006 : Origination. ( version 3.08 ) -!/ 20-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 ) -!/ -! 1. Purpose : -! -! Gather internal high-to-low data for a given model. -! -! 2. Method : -! -! For distributed memory version first receive all staged data. -! After staged data is present, average, convert as necessary, -! and store in basic spectral arrays. -! -! 2. Method : -! -! Using storage array HGSTAGE and time stamps. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number of grid from which data is to -! be gathered. -! DONE Log. O Flag for completion of operation (opt). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG, W3SETW, W3SETA, W3SETO -! Subr. WxxDATMD Manage data structures. -! W3CSPC Subr. W3CSPCMD Spectral grid conversion. -! STRACE Sur. W3SERVMD Subroutine tracing. -! DSEC21 Func. W3TIMEMD Difference between times. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Subr WMWAVEMD Multi-grid wave model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See FORMAT labels 1001-1002. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/SHRD Shared/distributed memory models. -! !/DIST -! !/MPI -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/MPIT -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3GDATMD - USE W3WDATMD - USE W3ADATMD - USE W3ODATMD - USE WMMDATMD -! - USE W3CSPCMD, ONLY: W3CSPC - USE W3TIMEMD, ONLY: DSEC21 -! USE W3SERVMD, ONLY: EXTCDE +9080 FORMAT (/' MPIT WMIOHS: COMMUNICATION CALLS '/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') +9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') +9083 FORMAT ( ' +------+------+------+------+--------------+') +9084 FORMAT ( ' MPIT WMIOHS: NRQHGS:',I10/) +#endif + !/ + !/ End of WMIOHS ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOHS + !/ ------------------------------------------------------------------- / + !> + !> @brief Gather internal high-to-low data for a given model. + !> + !> @details For distributed memory version first receive all staged data. + !> After staged data is present, average, convert as necessary, + !> and store in basic spectral arrays. + !> + !> Using storage array HGSTAGE and time stamps. + !> + !> @param[in] IMOD Model number of grid from which data is to + !> be gathered. + !> @param[out] DONE Flag for completion of operation (opt). + !> + !> @author H. L. Tolman @date 20-Dec-2006 + !> + SUBROUTINE WMIOHG ( IMOD, DONE ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 20-Dec-2006 ! + !/ +-----------------------------------+ + !/ + !/ 27-Jan-2006 : Origination. ( version 3.08 ) + !/ 20-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 ) + !/ + ! 1. Purpose : + ! + ! Gather internal high-to-low data for a given model. + ! + ! 2. Method : + ! + ! For distributed memory version first receive all staged data. + ! After staged data is present, average, convert as necessary, + ! and store in basic spectral arrays. + ! + ! 2. Method : + ! + ! Using storage array HGSTAGE and time stamps. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number of grid from which data is to + ! be gathered. + ! DONE Log. O Flag for completion of operation (opt). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG, W3SETW, W3SETA, W3SETO + ! Subr. WxxDATMD Manage data structures. + ! W3CSPC Subr. W3CSPCMD Spectral grid conversion. + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! DSEC21 Func. W3TIMEMD Difference between times. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr WMWAVEMD Multi-grid wave model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See FORMAT labels 1001-1002. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/SHRD Shared/distributed memory models. + ! !/DIST + ! !/MPI + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/MPIT + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GDATMD + USE W3WDATMD + USE W3ADATMD + USE W3ODATMD + USE WMMDATMD + ! + USE W3CSPCMD, ONLY: W3CSPC + USE W3TIMEMD, ONLY: DSEC21 + ! USE W3SERVMD, ONLY: EXTCDE #ifdef W3_PDLIB - use yowNodepool, only: npa - USE yowExchangeModule, only : PDLIB_exchange2Dreal_zero + use yowNodepool, only: npa + USE yowExchangeModule, only : PDLIB_exchange2Dreal_zero #endif - USE W3PARALL, ONLY : INIT_GET_ISEA + USE W3PARALL, ONLY : INIT_GET_ISEA #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD - LOGICAL, INTENT(OUT), OPTIONAL :: DONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NTOT, J, IS, NA, IA, JSEA, ISEA, I -#ifdef W3_MPI - INTEGER :: ITAG, IT0, IFROM, ILOC, NLOC, & - ISPROC, IERR_MPI, ICOUNT, & - I0, I1, I2 + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + LOGICAL, INTENT(OUT), OPTIONAL :: DONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NTOT, J, IS, NA, IA, JSEA, ISEA, I +#ifdef W3_MPI + INTEGER :: ITAG, IT0, IFROM, ILOC, NLOC, & + ISPROC, IERR_MPI, ICOUNT, & + I0, I1, I2 #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, POINTER :: VTIME(:) + INTEGER, POINTER :: VTIME(:) #ifdef W3_MPI - INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:) + INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:) #endif - REAL :: DTTST, WGTH - REAL, POINTER :: SPEC1(:,:), SPEC2(:,:), SPEC(:,:) + REAL :: DTTST, WGTH + REAL, POINTER :: SPEC1(:,:), SPEC2(:,:), SPEC(:,:) #ifdef W3_MPI - REAL, POINTER :: SHGH(:,:,:) + REAL, POINTER :: SHGH(:,:,:) #endif - LOGICAL :: FLGALL + LOGICAL :: FLGALL #ifdef W3_MPI - LOGICAL :: FLAGOK + LOGICAL :: FLAGOK #endif #ifdef W3_MPIT - LOGICAL :: FLAG + LOGICAL :: FLAG #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOHG') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! - IF ( TOUTP(1,IMOD) .EQ. -1 ) THEN - DTTST = 1. - ELSE - DTTST = DSEC21 ( WDATAS(IMOD)%TIME , TOUTP(:,IMOD) ) - END IF -! - IF ( .NOT. FLGHG1 ) THEN - FLGALL = .TRUE. - ELSE IF ( FLGHG2 ) THEN - FLGALL = .FALSE. - ELSE IF ( DTTST .EQ. 0. ) THEN - FLGALL = .TRUE. - ELSE - FLGALL = .FALSE. - END IF -! -#ifdef W3_T - WRITE (MDST,9000) IMOD, DTTST, FLGALL -#endif -! - IF ( FLGALL ) THEN -#ifdef W3_T - WRITE (MDST,9001) HGSTGE(IMOD,:)%NREC -#endif - NTOT = SUM(HGSTGE(IMOD,:)%NREC) - ELSE -#ifdef W3_T - WRITE (MDST,9001) HGSTGE(IMOD,:)%NRC1 -#endif - NTOT = SUM(HGSTGE(IMOD,:)%NRC1) - END IF -! - IF ( PRESENT(DONE) ) DONE = .FALSE. -! - IF ( NTOT .EQ. 0 ) THEN - IF ( PRESENT(DONE) ) DONE = .TRUE. + CALL STRACE (IENT, 'WMIOHG') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! + IF ( TOUTP(1,IMOD) .EQ. -1 ) THEN + DTTST = 1. + ELSE + DTTST = DSEC21 ( WDATAS(IMOD)%TIME , TOUTP(:,IMOD) ) + END IF + ! + IF ( .NOT. FLGHG1 ) THEN + FLGALL = .TRUE. + ELSE IF ( FLGHG2 ) THEN + FLGALL = .FALSE. + ELSE IF ( DTTST .EQ. 0. ) THEN + FLGALL = .TRUE. + ELSE + FLGALL = .FALSE. + END IF + ! +#ifdef W3_T + WRITE (MDST,9000) IMOD, DTTST, FLGALL +#endif + ! + IF ( FLGALL ) THEN +#ifdef W3_T + WRITE (MDST,9001) HGSTGE(IMOD,:)%NREC +#endif + NTOT = SUM(HGSTGE(IMOD,:)%NREC) + ELSE +#ifdef W3_T + WRITE (MDST,9001) HGSTGE(IMOD,:)%NRC1 +#endif + NTOT = SUM(HGSTGE(IMOD,:)%NRC1) + END IF + ! + IF ( PRESENT(DONE) ) DONE = .FALSE. + ! + IF ( NTOT .EQ. 0 ) THEN + IF ( PRESENT(DONE) ) DONE = .TRUE. #ifdef W3_T - WRITE (MDST,9003) + WRITE (MDST,9003) #endif - RETURN - END IF -! - CALL W3SETO ( IMOD, MDSE, MDST ) - CALL W3SETG ( IMOD, MDSE, MDST ) - CALL W3SETW ( IMOD, MDSE, MDST ) - CALL W3SETA ( IMOD, MDSE, MDST ) -! -! -------------------------------------------------------------------- / -! 1. Testing / gathering data in staging arrays -! -#ifdef W3_T - WRITE (MDST,9010) TIME -#endif -! -! 1.a Shared memory version, test valid times. - - - - - - - - - - - - / -! + RETURN + END IF + ! + CALL W3SETO ( IMOD, MDSE, MDST ) + CALL W3SETG ( IMOD, MDSE, MDST ) + CALL W3SETW ( IMOD, MDSE, MDST ) + CALL W3SETA ( IMOD, MDSE, MDST ) + ! + ! -------------------------------------------------------------------- / + ! 1. Testing / gathering data in staging arrays + ! +#ifdef W3_T + WRITE (MDST,9010) TIME +#endif + ! + ! 1.a Shared memory version, test valid times. - - - - - - - - - - - - / + ! #ifdef W3_SHRD - DO J=1, NRGRD + DO J=1, NRGRD #endif -! + ! #ifdef W3_SHRD - IF ( FLGALL ) THEN - NTOT = HGSTGE(IMOD,J)%NREC - ELSE - NTOT = HGSTGE(IMOD,J)%NRC1 - END IF - IF ( NTOT .EQ. 0 ) CYCLE + IF ( FLGALL ) THEN + NTOT = HGSTGE(IMOD,J)%NREC + ELSE + NTOT = HGSTGE(IMOD,J)%NRC1 + END IF + IF ( NTOT .EQ. 0 ) CYCLE #endif -! + ! #ifdef W3_SHRD - VTIME => HGSTGE(IMOD,J)%VTIME - IF ( VTIME(1) .EQ. -1 ) RETURN - DTTST = DSEC21 ( TIME, VTIME ) - IF ( DTTST .NE. 0. ) RETURN + VTIME => HGSTGE(IMOD,J)%VTIME + IF ( VTIME(1) .EQ. -1 ) RETURN + DTTST = DSEC21 ( TIME, VTIME ) + IF ( DTTST .NE. 0. ) RETURN #endif -! + ! #ifdef W3_SHRD - END DO + END DO #endif -! -! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - / -! + ! + ! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - / + ! #ifdef W3_MPIT - WRITE (MDST,9011) HGHSTA(IMOD) + WRITE (MDST,9011) HGHSTA(IMOD) #endif -! -! 1.b.1 HGHSTA = 0 -! Check if staging arrays are initialized. -! Post the proper receives. -! -#ifdef W3_MPI - IF ( HGHSTA(IMOD) .EQ. 0 ) THEN -#endif -! -#ifdef W3_MPI - NRQ => MDATAS(IMOD)%NRQHGG - NRQ = 0 - DO J=1, NRGRD - IF ( FLGALL ) THEN - NRQ = NRQ + HGSTGE(IMOD,J)%NREC * & - HGSTGE(IMOD,J)%NSMX - ELSE - NRQ = NRQ + HGSTGE(IMOD,J)%NRC1 * & - HGSTGE(IMOD,J)%NSMX - END IF - END DO - NRQ = MAX(1,NRQ) - ALLOCATE ( IRQ(NRQ) ) - IRQ = 0 - NRQ = 0 + ! + ! 1.b.1 HGHSTA = 0 + ! Check if staging arrays are initialized. + ! Post the proper receives. + ! +#ifdef W3_MPI + IF ( HGHSTA(IMOD) .EQ. 0 ) THEN #endif -! + ! #ifdef W3_MPI - DO J=1, NRGRD - IF ( HGSTGE(IMOD,J)%NTOT .EQ. 0 ) CYCLE + NRQ => MDATAS(IMOD)%NRQHGG + NRQ = 0 + DO J=1, NRGRD + IF ( FLGALL ) THEN + NRQ = NRQ + HGSTGE(IMOD,J)%NREC * & + HGSTGE(IMOD,J)%NSMX + ELSE + NRQ = NRQ + HGSTGE(IMOD,J)%NRC1 * & + HGSTGE(IMOD,J)%NSMX + END IF + END DO + NRQ = MAX(1,NRQ) + ALLOCATE ( IRQ(NRQ) ) + IRQ = 0 + NRQ = 0 #endif -! -! ..... Check valid time to determine staging. -! + ! #ifdef W3_MPI - VTIME => HGSTGE(IMOD,J)%VTIME - IF ( VTIME(1) .EQ. -1 ) THEN - DTTST = 1. - ELSE - DTTST = DSEC21 ( TIME, VTIME ) - END IF + DO J=1, NRGRD + IF ( HGSTGE(IMOD,J)%NTOT .EQ. 0 ) CYCLE +#endif + ! + ! ..... Check valid time to determine staging. + ! +#ifdef W3_MPI + VTIME => HGSTGE(IMOD,J)%VTIME + IF ( VTIME(1) .EQ. -1 ) THEN + DTTST = 1. + ELSE + DTTST = DSEC21 ( TIME, VTIME ) + END IF #endif #ifdef W3_MPIT - WRITE (MDST,9013) VTIME, DTTST + WRITE (MDST,9013) VTIME, DTTST #endif -! -! ..... Post receives for data gather -! + ! + ! ..... Post receives for data gather + ! #ifdef W3_MPI - IF ( DTTST .NE. 0. ) THEN + IF ( DTTST .NE. 0. ) THEN #endif #ifdef W3_MPIT - WRITE (MDST,9014) J + WRITE (MDST,9014) J #endif -! -! ..... Spectra -! + ! + ! ..... Spectra + ! #ifdef W3_MPI - IT0 = MTAG1 + 1 - SHGH => HGSTGE(IMOD,J)%SHGH + IT0 = MTAG1 + 1 + SHGH => HGSTGE(IMOD,J)%SHGH #endif -! + ! #ifdef W3_MPI - IF ( FLGALL ) THEN - NTOT = HGSTGE(IMOD,J)%NREC - ELSE - NTOT = HGSTGE(IMOD,J)%NRC1 - END IF + IF ( FLGALL ) THEN + NTOT = HGSTGE(IMOD,J)%NREC + ELSE + NTOT = HGSTGE(IMOD,J)%NRC1 + END IF #endif -! + ! #ifdef W3_MPI - DO I=1, NTOT + DO I=1, NTOT #endif #ifdef W3_MPIT - JSEA = HGSTGE(IMOD,J)%LJSEA(I) + JSEA = HGSTGE(IMOD,J)%LJSEA(I) #endif #ifdef W3_MPI - NLOC = HGSTGE(IMOD,J)%NRAVG(I) - DO ILOC=1, NLOC - ISPROC = HGSTGE(IMOD,J)%IMPSRC(I,ILOC) - ITAG = HGSTGE(IMOD,J)%ITAG(I,ILOC) + IT0 - IF ( ISPROC .NE. IMPROC ) THEN - NRQ = NRQ + 1 - CALL MPI_IRECV ( SHGH(1,ILOC,I), & - SGRDS(J)%NSPEC, MPI_REAL, & - ISPROC-1, ITAG, MPI_COMM_MWAVE, & - IRQ(NRQ), IERR_MPI ) + NLOC = HGSTGE(IMOD,J)%NRAVG(I) + DO ILOC=1, NLOC + ISPROC = HGSTGE(IMOD,J)%IMPSRC(I,ILOC) + ITAG = HGSTGE(IMOD,J)%ITAG(I,ILOC) + IT0 + IF ( ISPROC .NE. IMPROC ) THEN + NRQ = NRQ + 1 + CALL MPI_IRECV ( SHGH(1,ILOC,I), & + SGRDS(J)%NSPEC, MPI_REAL, & + ISPROC-1, ITAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9016) NRQ, JSEA, ISPROC, & - ITAG-MTAG1, IRQ(NRQ), IERR_MPI + WRITE (MDST,9016) NRQ, JSEA, ISPROC, & + ITAG-MTAG1, IRQ(NRQ), IERR_MPI #endif #ifdef W3_MPI - END IF - END DO - END DO + END IF + END DO + END DO #endif -! -! ..... End IF for posting receives 1.b.1 -! + ! + ! ..... End IF for posting receives 1.b.1 + ! #ifdef W3_MPIT - WRITE (MDST,9017) + WRITE (MDST,9017) #endif #ifdef W3_MPI - END IF + END IF #endif -! -! ..... End grid loop J in 1.b.1 -! + ! + ! ..... End grid loop J in 1.b.1 + ! #ifdef W3_MPI - END DO + END DO #endif #ifdef W3_MPIT - WRITE (MDST,9018) NRQ + WRITE (MDST,9018) NRQ #endif -! + ! #ifdef W3_MPI - ALLOCATE ( MDATAS(IMOD)%IRQHGG(NRQ) ) - MDATAS(IMOD)%IRQHGG = IRQ(1:NRQ) - DEALLOCATE ( IRQ ) + ALLOCATE ( MDATAS(IMOD)%IRQHGG(NRQ) ) + MDATAS(IMOD)%IRQHGG = IRQ(1:NRQ) + DEALLOCATE ( IRQ ) #endif -! -! ..... Reset status -! + ! + ! ..... Reset status + ! #ifdef W3_MPI - IF ( NRQ .GT. 0 ) THEN - HGHSTA(IMOD) = 1 + IF ( NRQ .GT. 0 ) THEN + HGHSTA(IMOD) = 1 #endif #ifdef W3_MPIT - WRITE (MDST,9011) HGHSTA(IMOD) + WRITE (MDST,9011) HGHSTA(IMOD) #endif #ifdef W3_MPI - END IF + END IF #endif -! -! ..... End IF in 1.b.1 -! + ! + ! ..... End IF in 1.b.1 + ! #ifdef W3_MPI - END IF + END IF #endif -! -! 1.b.2 HGHSTA = 1 -! Wait for communication to finish. -! If DONE defined, check if done, otherwise wait. -! + ! + ! 1.b.2 HGHSTA = 1 + ! Wait for communication to finish. + ! If DONE defined, check if done, otherwise wait. + ! #ifdef W3_MPI - IF ( HGHSTA(IMOD) .EQ. 1 ) THEN + IF ( HGHSTA(IMOD) .EQ. 1 ) THEN #endif -! + ! #ifdef W3_MPI - NRQ => MDATAS(IMOD)%NRQHGG - IRQ => MDATAS(IMOD)%IRQHGG - ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) + NRQ => MDATAS(IMOD)%NRQHGG + IRQ => MDATAS(IMOD)%IRQHGG + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) #endif -! -! ..... Test communication if DONE is present, wait otherwise -! + ! + ! ..... Test communication if DONE is present, wait otherwise + ! #ifdef W3_MPI - IF ( PRESENT(DONE) ) THEN + IF ( PRESENT(DONE) ) THEN #endif -! + ! #ifdef W3_MPI - CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & - IERR_MPI ) + CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & + IERR_MPI ) #endif -! + ! #ifdef W3_MPIT - ICOUNT = 0 - DO I=1, NRQ - CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & - IERR_MPI ) - FLAGOK = FLAGOK .AND. FLAG - IF ( FLAG ) ICOUNT = ICOUNT + 1 - END DO - WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) + ICOUNT = 0 + DO I=1, NRQ + CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & + IERR_MPI ) + FLAGOK = FLAGOK .AND. FLAG + IF ( FLAG ) ICOUNT = ICOUNT + 1 + END DO + WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) #endif -! + ! #ifdef W3_MPI - ELSE + ELSE #endif -! + ! #ifdef W3_MPI - CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) - FLAGOK = .TRUE. + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + FLAGOK = .TRUE. #endif #ifdef W3_MPIT - WRITE (MDST,9019) 100. + WRITE (MDST,9019) 100. #endif -! + ! #ifdef W3_MPI - END IF + END IF #endif -! + ! #ifdef W3_MPI - DEALLOCATE ( STATUS ) + DEALLOCATE ( STATUS ) #endif -! -! ..... Go on based on FLAGOK -! + ! + ! ..... Go on based on FLAGOK + ! #ifdef W3_MPI - IF ( FLAGOK ) THEN - NRQ = 0 - DEALLOCATE ( MDATAS(IMOD)%IRQHGG ) - ELSE - RETURN - END IF + IF ( FLAGOK ) THEN + NRQ = 0 + DEALLOCATE ( MDATAS(IMOD)%IRQHGG ) + ELSE + RETURN + END IF #endif -! + ! #ifdef W3_MPI - HGHSTA(IMOD) = 0 + HGHSTA(IMOD) = 0 #endif #ifdef W3_MPIT - WRITE (MDST,9011) HGHSTA(IMOD) + WRITE (MDST,9011) HGHSTA(IMOD) #endif -! + ! #ifdef W3_MPI - END IF + END IF #endif -! -! ..... process locally stored data -! + ! + ! ..... process locally stored data + ! #ifdef W3_MPI - DO J=1, NRGRD - HGSTGE(IMOD,J)%VTIME = TIME - IF ( J .EQ. IMOD ) CYCLE - DO IS=1, HGSTGE(IMOD,J)%NRQOUT - I0 = HGSTGE(IMOD,J)%OUTDAT(IS,1) - I2 = HGSTGE(IMOD,J)%OUTDAT(IS,2) - I1 = HGSTGE(IMOD,J)%OUTDAT(IS,3) - HGSTGE(IMOD,J)%SHGH(:,I2,I1) = HGSTGE(IMOD,J)%TSTORE(:,I0) - END DO + DO J=1, NRGRD + HGSTGE(IMOD,J)%VTIME = TIME + IF ( J .EQ. IMOD ) CYCLE + DO IS=1, HGSTGE(IMOD,J)%NRQOUT + I0 = HGSTGE(IMOD,J)%OUTDAT(IS,1) + I2 = HGSTGE(IMOD,J)%OUTDAT(IS,2) + I1 = HGSTGE(IMOD,J)%OUTDAT(IS,3) + HGSTGE(IMOD,J)%SHGH(:,I2,I1) = HGSTGE(IMOD,J)%TSTORE(:,I0) END DO + END DO #endif -! -! -------------------------------------------------------------------- / -! 2. Data available, process grid by grid -! + ! + ! -------------------------------------------------------------------- / + ! 2. Data available, process grid by grid + ! #ifdef W3_T - WRITE (MDST,9020) + WRITE (MDST,9020) #endif -! -! 2.a Loop over grids -! - DO J=1, NRGRD -! - IF ( FLGALL ) THEN - NTOT = HGSTGE(IMOD,J)%NREC - ELSE - NTOT = HGSTGE(IMOD,J)%NRC1 - END IF - IF ( NTOT .EQ. 0 ) CYCLE -! -#ifdef W3_T - WRITE (MDST,9021) J, NTOT -#endif -! -! 2.b Set up temp data structures -! - IF ( RESPEC(IMOD,J) ) THEN - ALLOCATE ( SPEC1(SGRDS(J)%NSPEC,NTOT), SPEC2(NSPEC,NTOT) ) - SPEC => SPEC1 - ELSE - ALLOCATE ( SPEC2(NSPEC,NTOT) ) - SPEC => SPEC2 - END IF -! -! 2.c Average spectra to temp storage -! -#ifdef W3_T - WRITE (MDST,9022) -#endif -! - DO IS=1, NTOT - NA = HGSTGE(IMOD,J)%NRAVG(IS) - WGTH = HGSTGE(IMOD,J)%WGTH(IS,1) - SPEC(:,IS) = WGTH * HGSTGE(IMOD,J)%SHGH(:,1,IS) - DO IA=2, NA - WGTH = HGSTGE(IMOD,J)%WGTH(IS,IA) - SPEC(:,IS) = SPEC(:,IS) + WGTH*HGSTGE(IMOD,J)%SHGH(:,IA,IS) - END DO - END DO -! -! 2.d Convert spectral grid as needed -! - IF ( RESPEC(IMOD,J) ) THEN -! + ! + ! 2.a Loop over grids + ! + DO J=1, NRGRD + ! + IF ( FLGALL ) THEN + NTOT = HGSTGE(IMOD,J)%NREC + ELSE + NTOT = HGSTGE(IMOD,J)%NRC1 + END IF + IF ( NTOT .EQ. 0 ) CYCLE + ! +#ifdef W3_T + WRITE (MDST,9021) J, NTOT +#endif + ! + ! 2.b Set up temp data structures + ! + IF ( RESPEC(IMOD,J) ) THEN + ALLOCATE ( SPEC1(SGRDS(J)%NSPEC,NTOT), SPEC2(NSPEC,NTOT) ) + SPEC => SPEC1 + ELSE + ALLOCATE ( SPEC2(NSPEC,NTOT) ) + SPEC => SPEC2 + END IF + ! + ! 2.c Average spectra to temp storage + ! +#ifdef W3_T + WRITE (MDST,9022) +#endif + ! + DO IS=1, NTOT + NA = HGSTGE(IMOD,J)%NRAVG(IS) + WGTH = HGSTGE(IMOD,J)%WGTH(IS,1) + SPEC(:,IS) = WGTH * HGSTGE(IMOD,J)%SHGH(:,1,IS) + DO IA=2, NA + WGTH = HGSTGE(IMOD,J)%WGTH(IS,IA) + SPEC(:,IS) = SPEC(:,IS) + WGTH*HGSTGE(IMOD,J)%SHGH(:,IA,IS) + END DO + END DO + ! + ! 2.d Convert spectral grid as needed + ! + IF ( RESPEC(IMOD,J) ) THEN + ! #ifdef W3_T - WRITE (MDST,9023) + WRITE (MDST,9023) #endif -! - CALL W3CSPC ( SPEC1, SGRDS(J)%NK, SGRDS(J)%NTH, & - SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), & - SPEC2 , NK, NTH, XFR, FR1, TH(1), & - NTOT, MDST, MDSE, FACHFE) - DEALLOCATE ( SPEC1 ) -! - END IF -! -! 2.e Move spectra to model -! -#ifdef W3_T - WRITE (MDST,9024) -#endif -! - DO IS=1, NTOT - JSEA = HGSTGE(IMOD,J)%LJSEA(IS) - CALL INIT_GET_ISEA(ISEA, JSEA) - DO I=1, NSPEC - VA(I,JSEA) = SPEC2(I,IS) / SIG2(I) * CG(1+(I-1)/NTH,ISEA) - END DO - END DO -! - DEALLOCATE ( SPEC2 ) -! + ! + CALL W3CSPC ( SPEC1, SGRDS(J)%NK, SGRDS(J)%NTH, & + SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), & + SPEC2 , NK, NTH, XFR, FR1, TH(1), & + NTOT, MDST, MDSE, FACHFE) + DEALLOCATE ( SPEC1 ) + ! + END IF + ! + ! 2.e Move spectra to model + ! +#ifdef W3_T + WRITE (MDST,9024) +#endif + ! + DO IS=1, NTOT + JSEA = HGSTGE(IMOD,J)%LJSEA(IS) + CALL INIT_GET_ISEA(ISEA, JSEA) + DO I=1, NSPEC + VA(I,JSEA) = SPEC2(I,IS) / SIG2(I) * CG(1+(I-1)/NTH,ISEA) END DO -! -! -------------------------------------------------------------------- / -! 3. Set flag if reqeusted -! - IF ( PRESENT(DONE) ) DONE = .TRUE. -! + END DO + ! + DEALLOCATE ( SPEC2 ) + ! + END DO + ! + ! -------------------------------------------------------------------- / + ! 3. Set flag if reqeusted + ! + IF ( PRESENT(DONE) ) DONE = .TRUE. + ! #ifdef W3_PDLIB - CALL PDLIB_exchange2Dreal_zero(VA) + CALL PDLIB_exchange2Dreal_zero(VA) #endif -! -! Formats -! + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMIOHG : GATHERING DATA FOR GRID ',I3/ & - ' DTOUTP, FLGALL :',F8.1,L4) - 9001 FORMAT ( ' TEST WMIOHG : NR. OF SPECTRA PER SOURCE GRID : '/ & - ' ',25I4) - 9003 FORMAT ( ' TEST WMIOHG : NO DATA TO BE GATHERED') +9000 FORMAT ( ' TEST WMIOHG : GATHERING DATA FOR GRID ',I3/ & + ' DTOUTP, FLGALL :',F8.1,L4) +9001 FORMAT ( ' TEST WMIOHG : NR. OF SPECTRA PER SOURCE GRID : '/ & + ' ',25I4) +9003 FORMAT ( ' TEST WMIOHG : NO DATA TO BE GATHERED') #endif -! + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMIOHG : TEST DATA AVAILABILITY FOR',I9.8,I7.6) +9010 FORMAT ( ' TEST WMIOHG : TEST DATA AVAILABILITY FOR',I9.8,I7.6) #endif #ifdef W3_MPIT - 9011 FORMAT ( ' MPIT WMIOHG : HGHSTA =',I2) - 9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) - 9014 FORMAT (/' MPIT WMIOHG : RECEIVE FROM GRID',I4/ & - ' +------+------+------+------+--------------+'/ & - ' | IH | ID | FROM | TAG | handle err |'/ & - ' +------+------+------+------+--------------+') - 9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') - 9017 FORMAT ( ' +------+------+------+------+--------------+'/) - 9018 FORMAT ( ' MPIT WMIOHG : NRQBPT:',I10/) - 9019 FORMAT ( ' MPIT WMIOHG : RECEIVES FINISHED :',F6.1,'%') -#endif -! -#ifdef W3_T - 9020 FORMAT ( ' TEST WMIOHG : PROCESSING DATA GRID BY GRID') - 9021 FORMAT ( ' FROM GRID ',I3,' NR OF SPECTRA :',I6) - 9022 FORMAT ( ' AVERAGE SPECTRA TO TEMP STORAGE') - 9023 FORMAT ( ' CONVERT SPECTRAL GRID') - 9024 FORMAT ( ' MOVE SPECTRA TO PERMANENT STORAGE') -#endif -!/ -!/ End of WMIOHG ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOHG -!/ ------------------------------------------------------------------- / -!> -!> @brief Finalize staging of internal high-to-low data in the data -!> structure HGSTGE (MPI only). -!> -!> @details Post appropriate 'wait' functions to assure that the -!> communication has finished. -!> -!> @param[in] IMOD Model number of grid from which data has -!> been staged. -!> -!> @author H. L. Tolman @date 16-Jan-2006 -!> - SUBROUTINE WMIOHF ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 16-Jan-2006 ! -!/ +-----------------------------------+ -!/ -!/ 16-Jan-2006 : Origination. ( version 3.08 ) -!/ -! 1. Purpose : -! -! Finalize staging of internal high-to-low data in the data -! structure HGSTGE (MPI only). -! -! 2. Method : -! -! Post appropriate 'wait' functions to assure that the -! communication has finished. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number of grid from which data has -! been staged. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Subr WMWAVEMD Multi-grid wave model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Shared/distributed memory models. -! !/DIST -! !/MPI -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE WMMDATMD -! +9011 FORMAT ( ' MPIT WMIOHG : HGHSTA =',I2) +9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) +9014 FORMAT (/' MPIT WMIOHG : RECEIVE FROM GRID',I4/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | FROM | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') +9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') +9017 FORMAT ( ' +------+------+------+------+--------------+'/) +9018 FORMAT ( ' MPIT WMIOHG : NRQBPT:',I10/) +9019 FORMAT ( ' MPIT WMIOHG : RECEIVES FINISHED :',F6.1,'%') +#endif + ! +#ifdef W3_T +9020 FORMAT ( ' TEST WMIOHG : PROCESSING DATA GRID BY GRID') +9021 FORMAT ( ' FROM GRID ',I3,' NR OF SPECTRA :',I6) +9022 FORMAT ( ' AVERAGE SPECTRA TO TEMP STORAGE') +9023 FORMAT ( ' CONVERT SPECTRAL GRID') +9024 FORMAT ( ' MOVE SPECTRA TO PERMANENT STORAGE') +#endif + !/ + !/ End of WMIOHG ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOHG + !/ ------------------------------------------------------------------- / + !> + !> @brief Finalize staging of internal high-to-low data in the data + !> structure HGSTGE (MPI only). + !> + !> @details Post appropriate 'wait' functions to assure that the + !> communication has finished. + !> + !> @param[in] IMOD Model number of grid from which data has + !> been staged. + !> + !> @author H. L. Tolman @date 16-Jan-2006 + !> + SUBROUTINE WMIOHF ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 16-Jan-2006 ! + !/ +-----------------------------------+ + !/ + !/ 16-Jan-2006 : Origination. ( version 3.08 ) + !/ + ! 1. Purpose : + ! + ! Finalize staging of internal high-to-low data in the data + ! structure HGSTGE (MPI only). + ! + ! 2. Method : + ! + ! Post appropriate 'wait' functions to assure that the + ! communication has finished. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number of grid from which data has + ! been staged. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr WMWAVEMD Multi-grid wave model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Shared/distributed memory models. + ! !/DIST + ! !/MPI + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE WMMDATMD + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J #ifdef W3_MPI - INTEGER :: IERR_MPI - INTEGER, POINTER :: NRQ, IRQ(:) - INTEGER, ALLOCATABLE :: STATUS(:,:) + INTEGER :: IERR_MPI + INTEGER, POINTER :: NRQ, IRQ(:) + INTEGER, ALLOCATABLE :: STATUS(:,:) #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOHF') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! -#ifdef W3_T - WRITE (MDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 1. Loop over grids -! - DO J=1, NRGRD -! -#ifdef W3_MPI - NRQ => HGSTGE(J,IMOD)%NRQHGS -#endif -! -! 1.a Nothing to finalize -! -#ifdef W3_MPI - IF ( NRQ .EQ. 0 ) CYCLE - IRQ => HGSTGE(J,IMOD)%IRQHGS -#endif -! -! 1.b Wait for communication to end -! -#ifdef W3_MPI - ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) - CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) - DEALLOCATE ( STATUS ) -#endif -! -! 1.c Reset arrays and counter -! -#ifdef W3_MPI - NRQ = 0 - DEALLOCATE ( HGSTGE(J,IMOD)%IRQHGS, & - HGSTGE(J,IMOD)%TSTORE, & - HGSTGE(J,IMOD)%OUTDAT ) -#endif -! -#ifdef W3_T - WRITE (MDST,9010) J -#endif -! - END DO -! - RETURN -! -! Formats -! -#ifdef W3_T - 9000 FORMAT ( ' TEST WMIOHF : FINALIZE STAGING DATA FROM GRID ',I3) - 9010 FORMAT ( ' TEST WMIOHF : FINISHED WITH TARGET ',I3) -#endif -!/ -!/ End of WMIOHF ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOHF -!/ ------------------------------------------------------------------- / -!> -!> @brief Stage internal same-rank data in the data structure EQSTGE. -!> -!> @details Directly fill staging arrays in shared memory version, or post -!> the corresponding sends in distributed memory version. -!> -!> @param[in] IMOD Model number of grid from which data is to -!> be staged. -!> -!> @author H. L. Tolman @date 28-Sep-2016 -!> - SUBROUTINE WMIOES ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 28-Sep-2016 ! -!/ +-----------------------------------+ -!/ -!/ 25-May-2006 : Origination. ( version 3.09 ) -!/ 21-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 ) -!/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 ) -!/ 16-Dec-2020 : SMC grid use 1-1 spectral exchanges.( version 7.13 ) -!/ -! 1. Purpose : -! -! Stage internal same-rank data in the data structure EQSTGE. -! -! 2. Method : -! -! Directly fill staging arrays in shared memory version, or post -! the corresponding sends in distributed memory version. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number of grid from which data is to -! be staged. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM -! Subr. WxxDATMD Manage data structures. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Sur. Id. Program abort. -! DSEC21 Func. W3TIMEMD Difference between times. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Subr WMWAVEMD Multi-grid wave model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See FORMAT label 1001. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Shared/distributed memory models. -! !/DIST -! !/MPI -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/MPIT -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3GDATMD - USE W3WDATMD - USE W3ADATMD - USE W3ODATMD - USE WMMDATMD -! - USE W3SERVMD, ONLY: EXTCDE + CALL STRACE (IENT, 'WMIOHF') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! +#ifdef W3_T + WRITE (MDST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Loop over grids + ! + DO J=1, NRGRD + ! +#ifdef W3_MPI + NRQ => HGSTGE(J,IMOD)%NRQHGS +#endif + ! + ! 1.a Nothing to finalize + ! +#ifdef W3_MPI + IF ( NRQ .EQ. 0 ) CYCLE + IRQ => HGSTGE(J,IMOD)%IRQHGS +#endif + ! + ! 1.b Wait for communication to end + ! +#ifdef W3_MPI + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + DEALLOCATE ( STATUS ) +#endif + ! + ! 1.c Reset arrays and counter + ! +#ifdef W3_MPI + NRQ = 0 + DEALLOCATE ( HGSTGE(J,IMOD)%IRQHGS, & + HGSTGE(J,IMOD)%TSTORE, & + HGSTGE(J,IMOD)%OUTDAT ) +#endif + ! +#ifdef W3_T + WRITE (MDST,9010) J +#endif + ! + END DO + ! + RETURN + ! + ! Formats + ! +#ifdef W3_T +9000 FORMAT ( ' TEST WMIOHF : FINALIZE STAGING DATA FROM GRID ',I3) +9010 FORMAT ( ' TEST WMIOHF : FINISHED WITH TARGET ',I3) +#endif + !/ + !/ End of WMIOHF ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOHF + !/ ------------------------------------------------------------------- / + !> + !> @brief Stage internal same-rank data in the data structure EQSTGE. + !> + !> @details Directly fill staging arrays in shared memory version, or post + !> the corresponding sends in distributed memory version. + !> + !> @param[in] IMOD Model number of grid from which data is to + !> be staged. + !> + !> @author H. L. Tolman @date 28-Sep-2016 + !> + SUBROUTINE WMIOES ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 28-Sep-2016 ! + !/ +-----------------------------------+ + !/ + !/ 25-May-2006 : Origination. ( version 3.09 ) + !/ 21-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 ) + !/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 ) + !/ 16-Dec-2020 : SMC grid use 1-1 spectral exchanges.( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Stage internal same-rank data in the data structure EQSTGE. + ! + ! 2. Method : + ! + ! Directly fill staging arrays in shared memory version, or post + ! the corresponding sends in distributed memory version. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number of grid from which data is to + ! be staged. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM + ! Subr. WxxDATMD Manage data structures. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Sur. Id. Program abort. + ! DSEC21 Func. W3TIMEMD Difference between times. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr WMWAVEMD Multi-grid wave model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See FORMAT label 1001. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Shared/distributed memory models. + ! !/DIST + ! !/MPI + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/MPIT + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GDATMD + USE W3WDATMD + USE W3ADATMD + USE W3ODATMD + USE WMMDATMD + ! + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3TIMEMD, ONLY: DSEC21 -! - IMPLICIT NONE -! + USE W3TIMEMD, ONLY: DSEC21 + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, NR, I, ISEA, JSEA, IS, I1, I2 + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, NR, I, ISEA, JSEA, IS, I1, I2 #ifdef W3_MPI - INTEGER :: IT0, ITAG, IP, IERR_MPI + INTEGER :: IT0, ITAG, IP, IERR_MPI #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_MPI - INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:) + INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:) #endif #ifdef W3_SHRD - REAL, POINTER :: SEQL(:,:,:) + REAL, POINTER :: SEQL(:,:,:) #endif #ifdef W3_MPI - REAL, POINTER :: SEQL(:,:) + REAL, POINTER :: SEQL(:,:) #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOES') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! -#ifdef W3_T - WRITE (MDST,9000) IMOD - WRITE (MDST,9001) EQSTGE(:,IMOD)%NSND -#endif -! - CALL W3SETO ( IMOD, MDSE, MDST ) - CALL W3SETG ( IMOD, MDSE, MDST ) - CALL W3SETW ( IMOD, MDSE, MDST ) - CALL W3SETA ( IMOD, MDSE, MDST ) -! -! -------------------------------------------------------------------- / -! 1. Loop over grids -! - DO J=1, NRGRD -! - IF ( J .EQ. IMOD ) CYCLE - NR = EQSTGE(J,IMOD)%NSND -! -#ifdef W3_T - IF ( NR .EQ. 0 ) THEN - WRITE (MDST,9010) J, NR - ELSE - WRITE (MDST,9011) J, NR, DSEC21(TIME,TSYNC(:,J)) - END IF -#endif -! - IF ( NR .EQ. 0 ) CYCLE - IF ( DSEC21(TIME,TSYNC(:,J)) .NE. 0. ) STOP -! -!!Li Report sending for test. JGLi22Dec2020 -! WRITE (MDSE,*) ' ***WMIOES: Send to GRID', J, & -! ' from', IMOD, ' NS=', NR, ' on IP', IMPROC -! -------------------------------------------------------------------- / -! 2. Allocate arrays and/or point pointers -! + CALL STRACE (IENT, 'WMIOES') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! +#ifdef W3_T + WRITE (MDST,9000) IMOD + WRITE (MDST,9001) EQSTGE(:,IMOD)%NSND +#endif + ! + CALL W3SETO ( IMOD, MDSE, MDST ) + CALL W3SETG ( IMOD, MDSE, MDST ) + CALL W3SETW ( IMOD, MDSE, MDST ) + CALL W3SETA ( IMOD, MDSE, MDST ) + ! + ! -------------------------------------------------------------------- / + ! 1. Loop over grids + ! + DO J=1, NRGRD + ! + IF ( J .EQ. IMOD ) CYCLE + NR = EQSTGE(J,IMOD)%NSND + ! +#ifdef W3_T + IF ( NR .EQ. 0 ) THEN + WRITE (MDST,9010) J, NR + ELSE + WRITE (MDST,9011) J, NR, DSEC21(TIME,TSYNC(:,J)) + END IF +#endif + ! + IF ( NR .EQ. 0 ) CYCLE + IF ( DSEC21(TIME,TSYNC(:,J)) .NE. 0. ) STOP + ! + !!Li Report sending for test. JGLi22Dec2020 + ! WRITE (MDSE,*) ' ***WMIOES: Send to GRID', J, & + ! ' from', IMOD, ' NS=', NR, ' on IP', IMPROC + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays and/or point pointers + ! #ifdef W3_SHRD - SEQL => EQSTGE(J,IMOD)%SEQL + SEQL => EQSTGE(J,IMOD)%SEQL #endif #ifdef W3_MPI - ALLOCATE ( EQSTGE(J,IMOD)%TSTORE(NSPEC,NR) ) - SEQL => EQSTGE(J,IMOD)%TSTORE + ALLOCATE ( EQSTGE(J,IMOD)%TSTORE(NSPEC,NR) ) + SEQL => EQSTGE(J,IMOD)%TSTORE #endif -! + ! #ifdef W3_MPI - ALLOCATE ( EQSTGE(J,IMOD)%IRQEQS(NR) , & - EQSTGE(J,IMOD)%OUTDAT(NR,3) ) + ALLOCATE ( EQSTGE(J,IMOD)%IRQEQS(NR) , & + EQSTGE(J,IMOD)%OUTDAT(NR,3) ) #endif -! + ! #ifdef W3_MPI - NRQ => EQSTGE(J,IMOD)%NRQEQS - NRQOUT => EQSTGE(J,IMOD)%NRQOUT - IRQ => EQSTGE(J,IMOD)%IRQEQS - OUTDAT => EQSTGE(J,IMOD)%OUTDAT - NRQ = 0 - NRQOUT = 0 - IRQ = 0 + NRQ => EQSTGE(J,IMOD)%NRQEQS + NRQOUT => EQSTGE(J,IMOD)%NRQOUT + IRQ => EQSTGE(J,IMOD)%IRQEQS + OUTDAT => EQSTGE(J,IMOD)%OUTDAT + NRQ = 0 + NRQOUT = 0 + IRQ = 0 #endif -! -! -------------------------------------------------------------------- / -! 3. Set the time -! Note that with MPI the send needs to be posted to the local -! processor too to make time management possible. -! + ! + ! -------------------------------------------------------------------- / + ! 3. Set the time + ! Note that with MPI the send needs to be posted to the local + ! processor too to make time management possible. + ! #ifdef W3_T - WRITE (MDST,9030) TIME + WRITE (MDST,9030) TIME #endif -! + ! #ifdef W3_SHRD - EQSTGE(J,IMOD)%VTIME = TIME + EQSTGE(J,IMOD)%VTIME = TIME #endif -! -! -------------------------------------------------------------------- / -! 4. Stage the spectral data -! + ! + ! -------------------------------------------------------------------- / + ! 4. Stage the spectral data + ! #ifdef W3_MPIT - WRITE (MDST,9080) + WRITE (MDST,9080) #endif #ifdef W3_MPI - IT0 = MTAG2 + 1 + IT0 = MTAG2 + 1 #endif -! - DO I=1, NR -! - ISEA = EQSTGE(J,IMOD)%SIS(I) - JSEA = EQSTGE(J,IMOD)%SJS(I) - I1 = EQSTGE(J,IMOD)%SI1(I) - I2 = EQSTGE(J,IMOD)%SI2(I) + ! + DO I=1, NR + ! + ISEA = EQSTGE(J,IMOD)%SIS(I) + JSEA = EQSTGE(J,IMOD)%SJS(I) + I1 = EQSTGE(J,IMOD)%SI1(I) + I2 = EQSTGE(J,IMOD)%SI2(I) #ifdef W3_MPI - IP = EQSTGE(J,IMOD)%SIP(I) - ITAG = EQSTGE(J,IMOD)%STG(I) + IT0 - IF ( ITAG .GT. MTAG_UB ) THEN - WRITE (MDSE,1001) - CALL EXTCDE (1001) - END IF + IP = EQSTGE(J,IMOD)%SIP(I) + ITAG = EQSTGE(J,IMOD)%STG(I) + IT0 + IF ( ITAG .GT. MTAG_UB ) THEN + WRITE (MDSE,1001) + CALL EXTCDE (1001) + END IF #endif -! + ! #ifdef W3_SMC - !! Equal ranked SMC grids simply pass the wave action. JGLi16Dec2020 + !! Equal ranked SMC grids simply pass the wave action. JGLi16Dec2020 #endif #ifdef W3_MPI #ifdef W3_SMC - IF( GTYPE .EQ. SMCTYPE ) THEN - SEQL(:, I) = VA(:, JSEA) - ELSE + IF( GTYPE .EQ. SMCTYPE ) THEN + SEQL(:, I) = VA(:, JSEA) + ELSE #endif #endif DO IS=1, NSPEC #ifdef W3_SHRD SEQL(IS,I1,I2) = VA(IS,JSEA) * SIG2(IS) & - / CG(1+(IS-1)/NTH,ISEA) + / CG(1+(IS-1)/NTH,ISEA) #endif #ifdef W3_MPI SEQL( IS,I ) = VA(IS,JSEA) * SIG2(IS) & - / CG(1+(IS-1)/NTH,ISEA) + / CG(1+(IS-1)/NTH,ISEA) #endif - END DO + END DO #ifdef W3_MPI #ifdef W3_SMC - ENDIF + ENDIF #endif #endif -! + ! #ifdef W3_MPI - IF ( IP .NE. IMPROC ) THEN - NRQ = NRQ + 1 - CALL MPI_ISEND ( SEQL(1,I), NSPEC, MPI_REAL, IP-1, & - ITAG, MPI_COMM_MWAVE, IRQ(NRQ), IERR_MPI ) + IF ( IP .NE. IMPROC ) THEN + NRQ = NRQ + 1 + CALL MPI_ISEND ( SEQL(1,I), NSPEC, MPI_REAL, IP-1, & + ITAG, MPI_COMM_MWAVE, IRQ(NRQ), IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG2, & - IRQ(NRQ), IERR_MPI + WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG2, & + IRQ(NRQ), IERR_MPI #endif #ifdef W3_MPI - ELSE - NRQOUT = NRQOUT + 1 - OUTDAT(NRQOUT,1) = I - OUTDAT(NRQOUT,2) = I1 - OUTDAT(NRQOUT,3) = I2 - END IF + ELSE + NRQOUT = NRQOUT + 1 + OUTDAT(NRQOUT,1) = I + OUTDAT(NRQOUT,2) = I1 + OUTDAT(NRQOUT,3) = I2 + END IF #endif -! - END DO -! + ! + END DO + ! #ifdef W3_MPIT - WRITE (MDST,9083) - WRITE (MDST,9084) NRQ + WRITE (MDST,9083) + WRITE (MDST,9084) NRQ #endif -! - END DO -! - RETURN -! -! Formats -! + ! + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_MPI - 1001 FORMAT (/' *** ERROR WMIOES : REQUESTED MPI TAG EXCEEDS', & - ' UPPER BOUND (MTAG_UB) ***') +1001 FORMAT (/' *** ERROR WMIOES : REQUESTED MPI TAG EXCEEDS', & + ' UPPER BOUND (MTAG_UB) ***') #endif #ifdef W3_T - 9000 FORMAT ( ' TEST WMIOES : STAGING DATA FROM GRID ',I3) - 9001 FORMAT ( ' TEST WMIOES : NR. OF SPECTRA PER GRID : '/ & - ' ',15I6) +9000 FORMAT ( ' TEST WMIOES : STAGING DATA FROM GRID ',I3) +9001 FORMAT ( ' TEST WMIOES : NR. OF SPECTRA PER GRID : '/ & + ' ',15I6) #endif -! + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',I3, & - ' NR = ',I6) - 9011 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',I3, & - ' NR = ',I6,' TIME GAP = ',F8.1) +9010 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',I3, & + ' NR = ',I6) +9011 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',I3, & + ' NR = ',I6,' TIME GAP = ',F8.1) #endif -! + ! #ifdef W3_T - 9030 FORMAT ( ' TEST WMIOES : TIME :',I10.8,I7.6) +9030 FORMAT ( ' TEST WMIOES : TIME :',I10.8,I7.6) #endif -!/ + !/ #ifdef W3_MPIT - 9080 FORMAT (/' MPIT WMIOES: COMMUNICATION CALLS '/ & - ' +------+------+------+------+--------------+'/ & - ' | IH | ID | TARG | TAG | handle err |'/ & - ' +------+------+------+------+--------------+') - 9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') - 9083 FORMAT ( ' +------+------+------+------+--------------+') - 9084 FORMAT ( ' MPIT WMIOES: NRQEQS:',I10/) -#endif -!/ -!/ End of WMIOES ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOES -!/ ------------------------------------------------------------------- / -!> -!> @brief Gather internal same-rank data for a given model. -!> -!> @details For distributed memory version first receive all staged -!> data. After staged data is present, average, convert as necessary, -!> and store in basic spectral arrays. -!> -!> Using storage array EQSTGE and time stamps. -!> -!> @param[in] IMOD Model number of grid from which data is to -!> be gathered. -!> @param[out] DONE Flag for completion of operation (opt). -!> -!> @author H. L. Tolman @date 22-Jan-2007 -!> - SUBROUTINE WMIOEG ( IMOD, DONE ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Jan-2007 ! -!/ +-----------------------------------+ -!/ -!/ 25-May-2006 : Origination. ( version 3.09 ) -!/ 21-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 ) -!/ 22-Jan-2007 : Adding NAVMAX. ( version 3.10 ) -!/ -! 1. Purpose : -! -! Gather internal same-rank data for a given model. -! -! 2. Method : -! -! For distributed memory version first receive all staged data. -! After staged data is present, average, convert as necessary, -! and store in basic spectral arrays. -! -! 2. Method : -! -! Using storage array EQSTGE and time stamps. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number of grid from which data is to -! be gathered. -! DONE Log. O Flag for completion of operation (opt). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG, W3SETW, W3SETA, W3SETO -! Subr. WxxDATMD Manage data structures. -! W3CSPC Subr. W3CSPCMD Spectral grid conversion. -! STRACE Sur. W3SERVMD Subroutine tracing. -! DSEC21 Func. W3TIMEMD Difference between times. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Subr WMWAVEMD Multi-grid wave model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See FORMAT labels 1001-1002. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/SHRD Shared/distributed memory models. -! !/DIST -! !/MPI -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/MPIT -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3GDATMD - USE W3WDATMD - USE W3ADATMD - USE W3ODATMD - USE WMMDATMD -! - USE W3CSPCMD, ONLY: W3CSPC - USE W3TIMEMD, ONLY: DSEC21 - USE W3SERVMD, ONLY: EXTCDE +9080 FORMAT (/' MPIT WMIOES: COMMUNICATION CALLS '/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') +9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') +9083 FORMAT ( ' +------+------+------+------+--------------+') +9084 FORMAT ( ' MPIT WMIOES: NRQEQS:',I10/) +#endif + !/ + !/ End of WMIOES ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOES + !/ ------------------------------------------------------------------- / + !> + !> @brief Gather internal same-rank data for a given model. + !> + !> @details For distributed memory version first receive all staged + !> data. After staged data is present, average, convert as necessary, + !> and store in basic spectral arrays. + !> + !> Using storage array EQSTGE and time stamps. + !> + !> @param[in] IMOD Model number of grid from which data is to + !> be gathered. + !> @param[out] DONE Flag for completion of operation (opt). + !> + !> @author H. L. Tolman @date 22-Jan-2007 + !> + SUBROUTINE WMIOEG ( IMOD, DONE ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Jan-2007 ! + !/ +-----------------------------------+ + !/ + !/ 25-May-2006 : Origination. ( version 3.09 ) + !/ 21-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 ) + !/ 22-Jan-2007 : Adding NAVMAX. ( version 3.10 ) + !/ + ! 1. Purpose : + ! + ! Gather internal same-rank data for a given model. + ! + ! 2. Method : + ! + ! For distributed memory version first receive all staged data. + ! After staged data is present, average, convert as necessary, + ! and store in basic spectral arrays. + ! + ! 2. Method : + ! + ! Using storage array EQSTGE and time stamps. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number of grid from which data is to + ! be gathered. + ! DONE Log. O Flag for completion of operation (opt). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG, W3SETW, W3SETA, W3SETO + ! Subr. WxxDATMD Manage data structures. + ! W3CSPC Subr. W3CSPCMD Spectral grid conversion. + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! DSEC21 Func. W3TIMEMD Difference between times. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr WMWAVEMD Multi-grid wave model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See FORMAT labels 1001-1002. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/SHRD Shared/distributed memory models. + ! !/DIST + ! !/MPI + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/MPIT + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GDATMD + USE W3WDATMD + USE W3ADATMD + USE W3ODATMD + USE WMMDATMD + ! + USE W3CSPCMD, ONLY: W3CSPC + USE W3TIMEMD, ONLY: DSEC21 + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_PDLIB - use yowNodepool, only: npa - USE yowExchangeModule, only : PDLIB_exchange2Dreal_zero + use yowNodepool, only: npa + USE yowExchangeModule, only : PDLIB_exchange2Dreal_zero #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD - LOGICAL, INTENT(OUT), OPTIONAL :: DONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, I, ISEA, JSEA, IA, IS + USE W3SERVMD, ONLY: STRACE +#endif + ! + IMPLICIT NONE + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + LOGICAL, INTENT(OUT), OPTIONAL :: DONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, I, ISEA, JSEA, IA, IS #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_MPI - INTEGER :: IT0, ITAG, IFROM, IERR_MPI, & - NA, IP, I1, I2 + INTEGER :: IT0, ITAG, IFROM, IERR_MPI, & + NA, IP, I1, I2 #endif #ifdef W3_MPIT - INTEGER :: ICOUNT + INTEGER :: ICOUNT #endif - INTEGER, POINTER :: VTIME(:) + INTEGER, POINTER :: VTIME(:) #ifdef W3_MPI - INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:) + INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:) #endif - REAL :: DTTST, WGHT - REAL, POINTER :: SPEC1(:,:), SPEC2(:,:), SPEC(:,:) + REAL :: DTTST, WGHT + REAL, POINTER :: SPEC1(:,:), SPEC2(:,:), SPEC(:,:) #ifdef W3_MPI - REAL, POINTER :: SEQL(:,:,:) - LOGICAL :: FLAGOK - LOGICAL :: FLAG + REAL, POINTER :: SEQL(:,:,:) + LOGICAL :: FLAGOK + LOGICAL :: FLAG #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOEG') + CALL STRACE (IENT, 'WMIOEG') #endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! #ifdef W3_T - WRITE (MDST,9000) IMOD - WRITE (MDST,9001) 'NREC', EQSTGE(IMOD,:)%NREC + WRITE (MDST,9000) IMOD + WRITE (MDST,9001) 'NREC', EQSTGE(IMOD,:)%NREC #endif -! - IF ( PRESENT(DONE) ) DONE = .FALSE. -! - IF ( EQSTGE(IMOD,IMOD)%NREC .EQ. 0 ) THEN - IF ( PRESENT(DONE) ) DONE = .TRUE. + ! + IF ( PRESENT(DONE) ) DONE = .FALSE. + ! + IF ( EQSTGE(IMOD,IMOD)%NREC .EQ. 0 ) THEN + IF ( PRESENT(DONE) ) DONE = .TRUE. #ifdef W3_T - WRITE (MDST,9002) + WRITE (MDST,9002) #endif - RETURN - END IF -! - CALL W3SETO ( IMOD, MDSE, MDST ) - CALL W3SETG ( IMOD, MDSE, MDST ) - CALL W3SETW ( IMOD, MDSE, MDST ) - CALL W3SETA ( IMOD, MDSE, MDST ) -! -! -------------------------------------------------------------------- / -! 1. Testing / gathering data in staging arrays -! -#ifdef W3_T - WRITE (MDST,9010) TIME -#endif -! -! 1.a Shared memory version, test valid times. - - - - - - - - - - - - / -! + RETURN + END IF + ! + CALL W3SETO ( IMOD, MDSE, MDST ) + CALL W3SETG ( IMOD, MDSE, MDST ) + CALL W3SETW ( IMOD, MDSE, MDST ) + CALL W3SETA ( IMOD, MDSE, MDST ) + ! + ! -------------------------------------------------------------------- / + ! 1. Testing / gathering data in staging arrays + ! +#ifdef W3_T + WRITE (MDST,9010) TIME +#endif + ! + ! 1.a Shared memory version, test valid times. - - - - - - - - - - - - / + ! #ifdef W3_SHRD - DO J=1, NRGRD + DO J=1, NRGRD #endif -! + ! #ifdef W3_SHRD - IF ( IMOD .EQ. J ) CYCLE - IF ( EQSTGE(IMOD,J)%NREC .EQ. 0 ) CYCLE + IF ( IMOD .EQ. J ) CYCLE + IF ( EQSTGE(IMOD,J)%NREC .EQ. 0 ) CYCLE #endif -! + ! #ifdef W3_SHRD - VTIME => EQSTGE(IMOD,J)%VTIME - IF ( VTIME(1) .EQ. -1 ) RETURN - DTTST = DSEC21 ( TIME, VTIME ) - IF ( DTTST .NE. 0. ) RETURN + VTIME => EQSTGE(IMOD,J)%VTIME + IF ( VTIME(1) .EQ. -1 ) RETURN + DTTST = DSEC21 ( TIME, VTIME ) + IF ( DTTST .NE. 0. ) RETURN #endif -! + ! #ifdef W3_SHRD - END DO + END DO #endif -! -! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - / -! + ! + ! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - / + ! #ifdef W3_MPIT - WRITE (MDST,9011) EQLSTA(IMOD) + WRITE (MDST,9011) EQLSTA(IMOD) #endif -! -! 1.b.1 EQLSTA = 0 -! Check if staging arrays are initialized. -! Post the proper receives. -! + ! + ! 1.b.1 EQLSTA = 0 + ! Check if staging arrays are initialized. + ! Post the proper receives. + ! #ifdef W3_MPI - IF ( EQLSTA(IMOD) .EQ. 0 ) THEN + IF ( EQLSTA(IMOD) .EQ. 0 ) THEN #endif -! + ! #ifdef W3_MPI - NRQ => MDATAS(IMOD)%NRQEQG - NRQ = 0 - DO J=1, NRGRD - IF ( J .EQ. IMOD ) CYCLE - NRQ = NRQ + EQSTGE(IMOD,J)%NREC * & - EQSTGE(IMOD,J)%NAVMAX - END DO - ALLOCATE ( IRQ(NRQ) ) - IRQ = 0 - NRQ = 0 + NRQ => MDATAS(IMOD)%NRQEQG + NRQ = 0 + DO J=1, NRGRD + IF ( J .EQ. IMOD ) CYCLE + NRQ = NRQ + EQSTGE(IMOD,J)%NREC * & + EQSTGE(IMOD,J)%NAVMAX + END DO + ALLOCATE ( IRQ(NRQ) ) + IRQ = 0 + NRQ = 0 #endif -! + ! #ifdef W3_MPI - DO J=1, NRGRD - IF ( IMOD .EQ. J ) CYCLE - IF ( EQSTGE(IMOD,J)%NREC .EQ. 0 ) CYCLE + DO J=1, NRGRD + IF ( IMOD .EQ. J ) CYCLE + IF ( EQSTGE(IMOD,J)%NREC .EQ. 0 ) CYCLE #endif -! -! ..... Check valid time to determine staging. -! + ! + ! ..... Check valid time to determine staging. + ! #ifdef W3_MPI - VTIME => EQSTGE(IMOD,J)%VTIME - IF ( VTIME(1) .EQ. -1 ) THEN - DTTST = 1. - ELSE - DTTST = DSEC21 ( TIME, VTIME ) - END IF + VTIME => EQSTGE(IMOD,J)%VTIME + IF ( VTIME(1) .EQ. -1 ) THEN + DTTST = 1. + ELSE + DTTST = DSEC21 ( TIME, VTIME ) + END IF #endif #ifdef W3_MPIT - WRITE (MDST,9013) VTIME, DTTST + WRITE (MDST,9013) VTIME, DTTST #endif -! -! ..... Post receives for data gather -! + ! + ! ..... Post receives for data gather + ! #ifdef W3_MPI - IF ( DTTST .NE. 0. ) THEN + IF ( DTTST .NE. 0. ) THEN #endif #ifdef W3_MPIT - WRITE (MDST,9014) J -#endif -! -! ..... Spectra -! -#ifdef W3_MPI - IT0 = MTAG2 + 1 - SEQL => EQSTGE(IMOD,J)%SEQL -#endif -! -#ifdef W3_MPI - DO I=1, EQSTGE(IMOD,J)%NREC - JSEA = EQSTGE(IMOD,J)%JSEA(I) - NA = EQSTGE(IMOD,J)%NAVG(I) - DO IA=1, NA - IP = EQSTGE(IMOD,J)%RIP(I,IA) - ITAG = EQSTGE(IMOD,J)%RTG(I,IA) + IT0 - IF ( IP .NE. IMPROC ) THEN - NRQ = NRQ + 1 - CALL MPI_IRECV ( SEQL(1,I,IA), & - SGRDS(J)%NSPEC, MPI_REAL, & - IP-1, ITAG, MPI_COMM_MWAVE, & - IRQ(NRQ), IERR_MPI ) + WRITE (MDST,9014) J #endif -#ifdef W3_MPIT - WRITE (MDST,9016) NRQ, JSEA, IP, & - ITAG-MTAG2, IRQ(NRQ), IERR_MPI + ! + ! ..... Spectra + ! +#ifdef W3_MPI + IT0 = MTAG2 + 1 + SEQL => EQSTGE(IMOD,J)%SEQL #endif + ! #ifdef W3_MPI - END IF - END DO - END DO + DO I=1, EQSTGE(IMOD,J)%NREC + JSEA = EQSTGE(IMOD,J)%JSEA(I) + NA = EQSTGE(IMOD,J)%NAVG(I) + DO IA=1, NA + IP = EQSTGE(IMOD,J)%RIP(I,IA) + ITAG = EQSTGE(IMOD,J)%RTG(I,IA) + IT0 + IF ( IP .NE. IMPROC ) THEN + NRQ = NRQ + 1 + CALL MPI_IRECV ( SEQL(1,I,IA), & + SGRDS(J)%NSPEC, MPI_REAL, & + IP-1, ITAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) #endif -! -! ..... End IF for posting receives 1.b.1 -! #ifdef W3_MPIT - WRITE (MDST,9017) + WRITE (MDST,9016) NRQ, JSEA, IP, & + ITAG-MTAG2, IRQ(NRQ), IERR_MPI #endif #ifdef W3_MPI END IF + END DO + END DO +#endif + ! + ! ..... End IF for posting receives 1.b.1 + ! +#ifdef W3_MPIT + WRITE (MDST,9017) #endif -! -! ..... End grid loop J in 1.b.1 -! #ifdef W3_MPI - END DO + END IF +#endif + ! + ! ..... End grid loop J in 1.b.1 + ! +#ifdef W3_MPI + END DO #endif #ifdef W3_MPIT - WRITE (MDST,9018) NRQ + WRITE (MDST,9018) NRQ #endif -! + ! #ifdef W3_MPI - IF ( NRQ .NE. 0 ) THEN - ALLOCATE ( MDATAS(IMOD)%IRQEQG(NRQ) ) - MDATAS(IMOD)%IRQEQG = IRQ(1:NRQ) - END IF + IF ( NRQ .NE. 0 ) THEN + ALLOCATE ( MDATAS(IMOD)%IRQEQG(NRQ) ) + MDATAS(IMOD)%IRQEQG = IRQ(1:NRQ) + END IF #endif -! + ! #ifdef W3_MPI - DEALLOCATE ( IRQ ) + DEALLOCATE ( IRQ ) #endif -! -! ..... Reset status -! + ! + ! ..... Reset status + ! #ifdef W3_MPI - IF ( NRQ .GT. 0 ) THEN - EQLSTA(IMOD) = 1 + IF ( NRQ .GT. 0 ) THEN + EQLSTA(IMOD) = 1 #endif #ifdef W3_MPIT - WRITE (MDST,9011) EQLSTA(IMOD) + WRITE (MDST,9011) EQLSTA(IMOD) #endif #ifdef W3_MPI - END IF + END IF #endif -! -! ..... End IF in 1.b.1 -! + ! + ! ..... End IF in 1.b.1 + ! #ifdef W3_MPI - END IF + END IF #endif -! -! 1.b.2 EQLSTA = 1 -! Wait for communication to finish. -! If DONE defined, check if done, otherwise wait. -! + ! + ! 1.b.2 EQLSTA = 1 + ! Wait for communication to finish. + ! If DONE defined, check if done, otherwise wait. + ! #ifdef W3_MPI - IF ( EQLSTA(IMOD) .EQ. 1 ) THEN + IF ( EQLSTA(IMOD) .EQ. 1 ) THEN #endif -! + ! #ifdef W3_MPI - NRQ => MDATAS(IMOD)%NRQEQG - IRQ => MDATAS(IMOD)%IRQEQG - ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) + NRQ => MDATAS(IMOD)%NRQEQG + IRQ => MDATAS(IMOD)%IRQEQG + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) #endif -! -! ..... Test communication if DONE is present, wait otherwise -! + ! + ! ..... Test communication if DONE is present, wait otherwise + ! #ifdef W3_MPI - IF ( PRESENT(DONE) ) THEN + IF ( PRESENT(DONE) ) THEN #endif -! + ! #ifdef W3_MPI - CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & - IERR_MPI ) + CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & + IERR_MPI ) #endif -! + ! #ifdef W3_MPIT - ICOUNT = 0 - DO I=1, NRQ - CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & - IERR_MPI ) - FLAGOK = FLAGOK .AND. FLAG - IF ( FLAG ) ICOUNT = ICOUNT + 1 - END DO - WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) + ICOUNT = 0 + DO I=1, NRQ + CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & + IERR_MPI ) + FLAGOK = FLAGOK .AND. FLAG + IF ( FLAG ) ICOUNT = ICOUNT + 1 + END DO + WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) #endif -! + ! #ifdef W3_MPI - ELSE + ELSE #endif -! + ! #ifdef W3_MPI - CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) - FLAGOK = .TRUE. + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + FLAGOK = .TRUE. #endif #ifdef W3_MPIT - WRITE (MDST,9019) 100. + WRITE (MDST,9019) 100. #endif -! + ! #ifdef W3_MPI - END IF + END IF #endif -! + ! #ifdef W3_MPI - DEALLOCATE ( STATUS ) + DEALLOCATE ( STATUS ) #endif -! -! ..... Go on based on FLAGOK -! + ! + ! ..... Go on based on FLAGOK + ! #ifdef W3_MPI - IF ( FLAGOK ) THEN - IF ( NRQ.NE.0 ) DEALLOCATE ( MDATAS(IMOD)%IRQEQG ) - NRQ = 0 - ELSE - RETURN - END IF + IF ( FLAGOK ) THEN + IF ( NRQ.NE.0 ) DEALLOCATE ( MDATAS(IMOD)%IRQEQG ) + NRQ = 0 + ELSE + RETURN + END IF #endif -! + ! #ifdef W3_MPI - EQLSTA(IMOD) = 0 + EQLSTA(IMOD) = 0 #endif #ifdef W3_MPIT - WRITE (MDST,9011) EQLSTA(IMOD) + WRITE (MDST,9011) EQLSTA(IMOD) #endif -! + ! #ifdef W3_MPI - END IF + END IF #endif -! -! ..... process locally stored data -! + ! + ! ..... process locally stored data + ! #ifdef W3_MPI - DO J=1, NRGRD - EQSTGE(IMOD,J)%VTIME = TIME - IF ( J .EQ. IMOD ) CYCLE - DO IS=1, EQSTGE(IMOD,J)%NRQOUT - I = EQSTGE(IMOD,J)%OUTDAT(IS,1) - I1 = EQSTGE(IMOD,J)%OUTDAT(IS,2) - I2 = EQSTGE(IMOD,J)%OUTDAT(IS,3) - EQSTGE(IMOD,J)%SEQL(:,I1,I2) = EQSTGE(IMOD,J)%TSTORE(:,I) - END DO + DO J=1, NRGRD + EQSTGE(IMOD,J)%VTIME = TIME + IF ( J .EQ. IMOD ) CYCLE + DO IS=1, EQSTGE(IMOD,J)%NRQOUT + I = EQSTGE(IMOD,J)%OUTDAT(IS,1) + I1 = EQSTGE(IMOD,J)%OUTDAT(IS,2) + I2 = EQSTGE(IMOD,J)%OUTDAT(IS,3) + EQSTGE(IMOD,J)%SEQL(:,I1,I2) = EQSTGE(IMOD,J)%TSTORE(:,I) END DO + END DO #endif -! -! -------------------------------------------------------------------- / -! 2. Data available, process grid by grid -! + ! + ! -------------------------------------------------------------------- / + ! 2. Data available, process grid by grid + ! #ifdef W3_T - WRITE (MDST,9020) + WRITE (MDST,9020) #endif -! -! 2.a Do 'native' grid IMOD -! + ! + ! 2.a Do 'native' grid IMOD + ! #ifdef W3_T - WRITE (MDST,9021) IMOD, EQSTGE(IMOD,IMOD)%NREC + WRITE (MDST,9021) IMOD, EQSTGE(IMOD,IMOD)%NREC #endif -! - DO I=1, EQSTGE(IMOD,IMOD)%NREC - JSEA = EQSTGE(IMOD,IMOD)%JSEA(I) - WGHT = EQSTGE(IMOD,IMOD)%WGHT(I) - VA(:,JSEA) = WGHT * VA(:,JSEA) - END DO -! -! 2.b Loop over other grids -! - DO J=1, NRGRD - IF ( IMOD.EQ.J .OR. EQSTGE(IMOD,J)%NREC.EQ.0 ) CYCLE -! + ! + DO I=1, EQSTGE(IMOD,IMOD)%NREC + JSEA = EQSTGE(IMOD,IMOD)%JSEA(I) + WGHT = EQSTGE(IMOD,IMOD)%WGHT(I) + VA(:,JSEA) = WGHT * VA(:,JSEA) + END DO + ! + ! 2.b Loop over other grids + ! + DO J=1, NRGRD + IF ( IMOD.EQ.J .OR. EQSTGE(IMOD,J)%NREC.EQ.0 ) CYCLE + ! #ifdef W3_T - WRITE (MDST,9022) J, EQSTGE(IMOD,J)%NREC + WRITE (MDST,9022) J, EQSTGE(IMOD,J)%NREC #endif -! + ! #ifdef W3_SMC - !! Use 1-1 full boundary spectra without modification. JGLi16Dec2020 - IF( GTYPE .EQ. SMCTYPE ) THEN - DO I=1, EQSTGE(IMOD,J)%NREC - JSEA = EQSTGE(IMOD,J)%JSEA(I) - VA(:,JSEA) = EQSTGE(IMOD,J)%SEQL(:,I,1) - END DO - ELSE - !! Other grid boundary spectra may need conversion. JGLi12Apr2021 + !! Use 1-1 full boundary spectra without modification. JGLi16Dec2020 + IF( GTYPE .EQ. SMCTYPE ) THEN + DO I=1, EQSTGE(IMOD,J)%NREC + JSEA = EQSTGE(IMOD,J)%JSEA(I) + VA(:,JSEA) = EQSTGE(IMOD,J)%SEQL(:,I,1) + END DO + ELSE + !! Other grid boundary spectra may need conversion. JGLi12Apr2021 #endif -! -! 2.c Average spectra -! + ! + ! 2.c Average spectra + ! #ifdef W3_T WRITE (MDST,9023) #endif ALLOCATE ( SPEC1(SGRDS(J)%NSPEC,EQSTGE(IMOD,J)%NREC) ) SPEC1 = 0. -! + ! DO I=1, EQSTGE(IMOD,J)%NREC DO IA=1, EQSTGE(IMOD,J)%NAVG(I) SPEC1(:,I) = SPEC1(:,I) + EQSTGE(IMOD,J)%SEQL(:,I,IA) * & - EQSTGE(IMOD,J)%WAVG(I,IA) - END DO + EQSTGE(IMOD,J)%WAVG(I,IA) END DO -! -! 2.d Convert spectra -! + END DO + ! + ! 2.d Convert spectra + ! IF ( RESPEC(IMOD,J) ) THEN #ifdef W3_T - WRITE (MDST,9024) + WRITE (MDST,9024) #endif - ALLOCATE ( SPEC2(NSPEC,EQSTGE(IMOD,J)%NREC) ) -! - CALL W3CSPC ( SPEC1, SGRDS(J)%NK, SGRDS(J)%NTH, & - SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), & - SPEC2 , NK, NTH, XFR, FR1, TH(1), & - EQSTGE(IMOD,J)%NREC, MDST, MDSE, FACHFE) -! - SPEC => SPEC2 - ELSE - SPEC => SPEC1 - END IF -! -! 2.e Apply to native grid -! + ALLOCATE ( SPEC2(NSPEC,EQSTGE(IMOD,J)%NREC) ) + ! + CALL W3CSPC ( SPEC1, SGRDS(J)%NK, SGRDS(J)%NTH, & + SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), & + SPEC2 , NK, NTH, XFR, FR1, TH(1), & + EQSTGE(IMOD,J)%NREC, MDST, MDSE, FACHFE) + ! + SPEC => SPEC2 + ELSE + SPEC => SPEC1 + END IF + ! + ! 2.e Apply to native grid + ! DO I=1, EQSTGE(IMOD,J)%NREC ISEA = EQSTGE(IMOD,J)%ISEA(I) JSEA = EQSTGE(IMOD,J)%JSEA(I) WGHT = EQSTGE(IMOD,J)%WGHT(I) #ifdef W3_SMC - !! Regular grid in same ranked SMC group uses 1-1 mapping. JGLi12Apr2021 + !! Regular grid in same ranked SMC group uses 1-1 mapping. JGLi12Apr2021 IF( NGRPSMC .GT. 0 ) THEN - VA(:,JSEA) = SPEC(:,I) - ELSE + VA(:,JSEA) = SPEC(:,I) + ELSE #endif - DO IS=1, NSPEC - VA(IS,JSEA) = VA(IS,JSEA) + WGHT * & - SPEC(IS,I) / SIG2(IS) * CG(1+(IS-1)/NTH,ISEA) + DO IS=1, NSPEC + VA(IS,JSEA) = VA(IS,JSEA) + WGHT * & + SPEC(IS,I) / SIG2(IS) * CG(1+(IS-1)/NTH,ISEA) END DO #ifdef W3_SMC ENDIF !! NGRPSMC .GT. 0 #endif - END DO -! -! 2.f Final clean up -! + END DO + ! + ! 2.f Final clean up + ! DEALLOCATE ( SPEC1 ) IF ( RESPEC(IMOD,J) ) DEALLOCATE ( SPEC2 ) #ifdef W3_SMC - !! End GTYPE .EQ. SMCTYPE - ENDIF + !! End GTYPE .EQ. SMCTYPE + ENDIF #endif -!! End 2.b J grid loop. - END DO -! -! -------------------------------------------------------------------- / -! 3. Set flag if requested -! - IF ( PRESENT(DONE) ) DONE = .TRUE. -! + !! End 2.b J grid loop. + END DO + ! + ! -------------------------------------------------------------------- / + ! 3. Set flag if requested + ! + IF ( PRESENT(DONE) ) DONE = .TRUE. + ! #ifdef W3_PDLIB - CALL PDLIB_exchange2Dreal_zero(VA) + CALL PDLIB_exchange2Dreal_zero(VA) #endif -! -! Formats -! + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMIOEG : GATHERING DATA FOR GRID ',I4) - 9001 FORMAT ( ' TEST WMIOEG : ',A,' PER SOURCE GRID : '/13X,20I5) - 9002 FORMAT ( ' TEST WMIOEG : NO DATA TO BE GATHERED') +9000 FORMAT ( ' TEST WMIOEG : GATHERING DATA FOR GRID ',I4) +9001 FORMAT ( ' TEST WMIOEG : ',A,' PER SOURCE GRID : '/13X,20I5) +9002 FORMAT ( ' TEST WMIOEG : NO DATA TO BE GATHERED') #endif -! + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMIOEG : TEST DATA AVAILABILITY FOR',I9.8,I7.6) +9010 FORMAT ( ' TEST WMIOEG : TEST DATA AVAILABILITY FOR',I9.8,I7.6) #endif #ifdef W3_MPIT - 9011 FORMAT ( ' MPIT WMIOEG : EQLSTA =',I2) - 9012 FORMAT ( ' STAGING ARRAY FROM',I4,1X,A) - 9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) - 9014 FORMAT (/' MPIT WMIOEG : RECEIVE FROM GRID',I4/ & - ' +------+------+------+------+--------------+'/ & - ' | IH | ID | FROM | TAG | handle err |'/ & - ' +------+------+------+------+--------------+') - 9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') - 9017 FORMAT ( ' +------+------+------+------+--------------+'/) - 9018 FORMAT ( ' MPIT WMIOEG : NRQBPT:',I10/) - 9019 FORMAT ( ' MPIT WMIOEG : RECEIVES FINISHED :',F6.1,'%') -#endif -! -#ifdef W3_T - 9020 FORMAT ( ' TEST WMIOEG : PROCESSING DATA GRID BY GRID') - 9021 FORMAT ( ' NATIVE GRID ',I3,' DATA :',I6) - 9022 FORMAT ( ' RECEIVING GRID ',I3,' DATA :',I6) - 9023 FORMAT ( ' AVERAGE SPECTRA') - 9024 FORMAT ( ' CONVERTING SPECTRA') -#endif -!/ -!/ End of WMIOEG ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOEG -!/ ------------------------------------------------------------------- / -!> -!> @brief Finalize staging of internal same-rank data in the data -!> structure EQSTGE (MPI only). -!> -!> @details Post appropriate 'wait' functions to assure that the -!> communication has finished. -!> -!> @param[in] IMOD Model number of grid from which data has -!> been staged. -!> -!> @author H. L. Tolman @date 25-May-2006 -!> - SUBROUTINE WMIOEF ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-May-2006 ! -!/ +-----------------------------------+ -!/ -!/ 25-May-2006 : Origination. ( version 3.09 ) -!/ -! 1. Purpose : -! -! Finalize staging of internal same-rank data in the data -! structure EQSTGE (MPI only). -! -! 2. Method : -! -! Post appropriate 'wait' functions to assure that the -! communication has finished. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number of grid from which data has -! been staged. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Subr WMWAVEMD Multi-grid wave model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Shared/distributed memory models. -! !/DIST -! !/MPI -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE WMMDATMD -! +9011 FORMAT ( ' MPIT WMIOEG : EQLSTA =',I2) +9012 FORMAT ( ' STAGING ARRAY FROM',I4,1X,A) +9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) +9014 FORMAT (/' MPIT WMIOEG : RECEIVE FROM GRID',I4/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | FROM | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') +9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') +9017 FORMAT ( ' +------+------+------+------+--------------+'/) +9018 FORMAT ( ' MPIT WMIOEG : NRQBPT:',I10/) +9019 FORMAT ( ' MPIT WMIOEG : RECEIVES FINISHED :',F6.1,'%') +#endif + ! +#ifdef W3_T +9020 FORMAT ( ' TEST WMIOEG : PROCESSING DATA GRID BY GRID') +9021 FORMAT ( ' NATIVE GRID ',I3,' DATA :',I6) +9022 FORMAT ( ' RECEIVING GRID ',I3,' DATA :',I6) +9023 FORMAT ( ' AVERAGE SPECTRA') +9024 FORMAT ( ' CONVERTING SPECTRA') +#endif + !/ + !/ End of WMIOEG ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOEG + !/ ------------------------------------------------------------------- / + !> + !> @brief Finalize staging of internal same-rank data in the data + !> structure EQSTGE (MPI only). + !> + !> @details Post appropriate 'wait' functions to assure that the + !> communication has finished. + !> + !> @param[in] IMOD Model number of grid from which data has + !> been staged. + !> + !> @author H. L. Tolman @date 25-May-2006 + !> + SUBROUTINE WMIOEF ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-May-2006 ! + !/ +-----------------------------------+ + !/ + !/ 25-May-2006 : Origination. ( version 3.09 ) + !/ + ! 1. Purpose : + ! + ! Finalize staging of internal same-rank data in the data + ! structure EQSTGE (MPI only). + ! + ! 2. Method : + ! + ! Post appropriate 'wait' functions to assure that the + ! communication has finished. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number of grid from which data has + ! been staged. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr WMWAVEMD Multi-grid wave model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Shared/distributed memory models. + ! !/DIST + ! !/MPI + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE WMMDATMD + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J #ifdef W3_MPI - INTEGER :: IERR_MPI - INTEGER, POINTER :: NRQ, IRQ(:) - INTEGER, ALLOCATABLE :: STATUS(:,:) + INTEGER :: IERR_MPI + INTEGER, POINTER :: NRQ, IRQ(:) + INTEGER, ALLOCATABLE :: STATUS(:,:) #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOEF') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! -#ifdef W3_T - WRITE (MDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 1. Loop over grids -! - DO J=1, NRGRD -! -#ifdef W3_MPI - NRQ => EQSTGE(J,IMOD)%NRQEQS -#endif -! -! 1.a Nothing to finalize -! -#ifdef W3_MPI - IF ( NRQ .EQ. 0 ) CYCLE - IRQ => EQSTGE(J,IMOD)%IRQEQS -#endif -! -! 1.b Wait for communication to end -! -#ifdef W3_MPI - ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) - CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) - DEALLOCATE ( STATUS ) -#endif -! -! 1.c Reset arrays and counter -! -#ifdef W3_MPI - DEALLOCATE ( EQSTGE(J,IMOD)%IRQEQS, & - EQSTGE(J,IMOD)%TSTORE, & - EQSTGE(J,IMOD)%OUTDAT ) - NRQ = 0 -#endif -! -#ifdef W3_T - WRITE (MDST,9010) J -#endif -! - END DO -! - RETURN -! -! Formats -! -#ifdef W3_T - 9000 FORMAT ( ' TEST WMIOEF : FINALIZE STAGING DATA FROM GRID ',I3) - 9010 FORMAT ( ' TEST WMIOEF : FINISHED WITH TARGET ',I3) -#endif -!/ -!/ End of WMIOEF ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOEF -!/ -!/ End of module WMINIOMD -------------------------------------------- / -!/ - END MODULE WMINIOMD + CALL STRACE (IENT, 'WMIOEF') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! +#ifdef W3_T + WRITE (MDST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Loop over grids + ! + DO J=1, NRGRD + ! +#ifdef W3_MPI + NRQ => EQSTGE(J,IMOD)%NRQEQS +#endif + ! + ! 1.a Nothing to finalize + ! +#ifdef W3_MPI + IF ( NRQ .EQ. 0 ) CYCLE + IRQ => EQSTGE(J,IMOD)%IRQEQS +#endif + ! + ! 1.b Wait for communication to end + ! +#ifdef W3_MPI + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + DEALLOCATE ( STATUS ) +#endif + ! + ! 1.c Reset arrays and counter + ! +#ifdef W3_MPI + DEALLOCATE ( EQSTGE(J,IMOD)%IRQEQS, & + EQSTGE(J,IMOD)%TSTORE, & + EQSTGE(J,IMOD)%OUTDAT ) + NRQ = 0 +#endif + ! +#ifdef W3_T + WRITE (MDST,9010) J +#endif + ! + END DO + ! + RETURN + ! + ! Formats + ! +#ifdef W3_T +9000 FORMAT ( ' TEST WMIOEF : FINALIZE STAGING DATA FROM GRID ',I3) +9010 FORMAT ( ' TEST WMIOEF : FINISHED WITH TARGET ',I3) +#endif + !/ + !/ End of WMIOEF ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOEF + !/ + !/ End of module WMINIOMD -------------------------------------------- / + !/ +END MODULE WMINIOMD diff --git a/model/src/wminitmd.F90 b/model/src/wminitmd.F90 index 8be77ec81..293b74848 100644 --- a/model/src/wminitmd.F90 +++ b/model/src/wminitmd.F90 @@ -1,6559 +1,6559 @@ !> @file !> @brief Contains module WMINITMD. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / !> !> @brief Initialization of the multi-grid wave model. -!> +!> !> @details As a preparation for coupled modeling, all initialization, !> including the processing of the input file has ben included in the !> routine. !> !> @author H. L. Tolman @date 22-Mar-2021 !> - MODULE WMINITMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 13-Jun-2005 : Origination. ( version 3.07 ) -!/ See subroutine for update log. -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 16-Aug-2010 : Adding NTRMAX to unify NTRACE. ( version 3.14 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 05-Sep-2011 : Distribute HQFAC anf HPFAC to idle processors for -!/ use in WMGRIDMD. ( version 4.05 ) -!/ 07-Mar-2012 : Adding TNAMES to avoid read warn. ( version 4.07 ) -!/ Adjust allocation INPMAP and IDINP. -!/ 12-Mar-2012 : Fixing format 9061. ( version 3.14 ) -!/ Use MPI_COMM_NULL for checks instead of fixed '-1'. -!/ 28-Jul-2012 : Initialize FLGR2 properly. ( version 4.08 ) -!/ Tom Durrant's fix, but moved to allocation. -!/ 28-Nov-2012 : Bug fix: Distribute to idle processors the grid data -!/ required for regridding. ( version 4.08 ) -!/ (T. J. Campbell, NRL) -!/ 02-Sep-2012 : Set up for > 999 test files. ( version 4.10 ) -!/ Set up output for > 999 procs. -!/ 03-Sep-2012 : Output of initilization time. ( version 4.10 ) -!/ Switch test file on/off (TSTOUT) -!/ 18-Dec-2013 : Adding error checking for FLAGLL ( version 4.16 ) -!/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) -!/ 04-Feb-2014 : Switched clock to DATE_AND_TIME ( version 4.18 ) -!/ (A. Chawla and Mark Szyszka) -!/ 27-May-2014 : Bug fix prf file name. ( version 5.02 ) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ 20-Jan-2017 : Modify input forcing flags to support coupler input. -!/ Add ESMF override for STIME & ETIME ( version 6.02 ) -!/ (T. J. Campbell, NRL) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Initialization of the multi-grid wave model. As a preparation -! for coupled modeling, all initialization, including the -! processing of the input file has ben included in the routine. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NTRMAX Int. Local Maximum number of subroutine trace -! printouts (NTRACE in subr. ITRACE). -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WMINIT Subr. Public Wave model initialization. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - !< NTRMAX Maximum number - !< of subroutine trace - !< printouts (NTRACE in - !< subr. ITRACE). - INTEGER, PRIVATE :: NTRMAX = 1000 - - -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize multi-grid version of WAVEWATCH III. -!> -!> @param[in] IDSI Unit number for input file. -!> @param[in] IDSO Unit number for output file. -!> @param[in] IDSS Unit number for "screen" output. Switch off -!> by setting equal to IDSO. -!> @param[in] IDST Unit number for test output. -!> @param[in] IDSE Unit number for error output. -!> @param[in] IFNAME File name for input file. -!> @param[in] MPI_COMM MPI communicator to be used. -!> @param[in] PREAMB File name preamble (optional). -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & - MPI_COMM, PREAMB ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 13-Jun-2005 : Origination. ( version 3.07 ) -!/ 28-Dec-2005 : Add static nesting. ( version 3.08 ) -!/ 25-May-2006 : Add overlapping grids. ( version 3.09 ) -!/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) -!/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 09-Aug-2006 : Unified point output added. ( version 3.10 ) -!/ 14-Oct-2006 : Adding separate input grids. ( version 3.10 ) -!/ 03-Nov-2006 : Adding wave field separation. ( version 3.10 ) -!/ 02-Feb-2007 : Adding FLAGST initialization. ( version 3.10 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 16-Aug-2010 : Adding NTRMAX to unify NTRACE. ( version 3.14.5 ) -!/ 21-Sep-2010 : Adding coupling output ( version 3.14-Ifremer) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 28-Jul-2012 : Initialize FLGR2 properly. ( version 4.08 ) -!/ Tom Durant's fix, but moved to allocation. -!/ 28-Nov-2012 : Bug fix: Distribute to idle processors the grid data -!/ required for regridding. ( version 4.08 ) -!/ (T. J. Campbell, NRL) -!/ 02-Sep-2012 : Set up for > 999 test files. ( version 4.10 ) -!/ Set up output for > 999 procs. -!/ 03-Sep-2012 : Output of initilization time. ( version 4.10 ) -!/ Switch test file on/off (TSTOUT) -!/ 28-Nov-2012 : Bug fix: Distribute to idle processors the grid data -!/ required for regridding. ( version 4.08 ) -!/ (T. J. Campbell, NRL) -!/ 15-Apr-2013 : Changes the reading of output fields( version 4.10 ) -!/ (F. Ardhuin) -!/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) -!/ 27-May-2014 : Bug fix prf file name. ( version 5.02 ) -!/ 17-Sep-2014 : Read mod_def before inp file ( version 5.03 ) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ 20-Jan-2017 : Modify input forcing flags to support coupler input. -!/ Add ESMF override for STIME & ETIME ( version 6.02 ) -!/ (T. J. Campbell, NRL) -!/ 28-Oct-2020 : Add SMCTYPE for SMC sub-grid. JGLi ( version 7.13 ) -!/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Initialize multi-grid version of WAVEWATCH III. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IDSI Int. I Unit number for input file. -! IDSO Int. I Unit number for output file. -! IDSS Int. I Unit number for "screen" output. Switch off -! by setting equal to IDSO. -! IDST Int. I Unit number for test output. -! IDSE Int. I Unit number for error output. -! IFNAME Char I File name for input file. -! MPI_COMM Int. I MPI communicator to be used. -! PREAMB Char I File name preamble (optional). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Data structure initialization. -! W3DIMX Subr. Id. Set grid arrays. -! W3DIMS Subr. Id. Set grid arrays. -! W3SETG Subr. Id. Point to grid/model. -! W3NDAT Subr. W3WDATMD Data structure initialization. -! W3SETW Subr. Id. Point to grid/model. -! W3NAUX Subr. W3ADATMD Data structure initialization. -! W3SETA Subr. Id. Point to grid/model. -! W3NOUT Subr. W3ODATMD Data structure initialization. -! W3SETO Subr. Id. Point to grid/model. -! W3NINP Subr. W3IDATMD Data structure initialization. -! W3SETI Subr. Id. Point to grid/model. -! W3DIMI Subr. Id. Allocate grid/model. -! WMNDAT Subr. WMMDATMD Data structure initialization. -! WMSETM Subr. Id. Point to grid/model. -! WMDIMD Subr. Id. Allocate array space. -! W3FLDO Subr. W3FLDSMD Open input data file. -! W3IOGR Subr. W3IOGRMD Reading of model definition file. -! W3INIT Subr. W3INITMD Model intiailization. -! WMGLOW Subr. WMGRIDMD Lower rank grid dependencies. -! WMGEQL Subr. Id. Same rank grid dependencies. -! WMGHGH Subr. Id. Higher rank grid dependencies. -! RESPEC Subr. Id. Spectral conversion flags. -! WMIOBS Subr. WMINIOMD Stage boundary data. -! WMIOBG Subr. Id. Gather boundary data. -! WMIOBF Subr. Id. Finalize staging in WMIOBS. -! WMUINI Subr. WMUNITMD Initialize dynamic unit assignment, -! WMUDMP Subr. Id. Dump dynamic unit data, -! WMUSET Subr. Id. Set unit number data. -! WMUGET Subr. Id. Get a unit number. -! WMUINQ Subr. Id. Update unit number info. -! WMIOPP Subr. WMIOPOMD Initialize unified point output. -! ITRACE Subr. W3SERVMD Initialize subroutine tracing. -! STRACE Subr. Id. Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! WWDATE Subr. Id. System date. -! WWTIME Subr. Id. System time. -! NEXTLN Subr. Id. Find next input line in file. -! PRINIT Subr. Id. Profiling routine ( !/MPRF ) -! PRTIME Subr. Id. Profiling routine ( !/MPRF ) -! STME21 Subr. W3TIMEMD Convert time to string. -! DSEC21 Func. Id. Difference between times. -! TICK21 Subr. Id. Advance the clock. -! W3READFLGRD Subr. W3IOGOMD Reads flags or namelist for output fields -! -! MPI_COMM_SIZE, CALL MPI_COMM_RANK, MPI_BARRIER, MPI_COMM_GROUP, -! MPI_GROUP_INCLUDE, MPI_COMM_CREATE, MPI_GROUP_FREE, MPI_BCAST -! Subr. mpif.h Standard MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3MLTI Prog. N/A Multi-grid model driver. -! .... Any coupled model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See formats 1000 and following, or escape locations 2000 and -! following. -! -! 7. Remarks : -! -! - When running regtests in cases where disk is non-local -! (i.e. NFS used), there can be a huge improvment in compute -! time by using /var/tmp/ for log files. -! See commented line at "OPEN (MDSO,FILE=..." -! -! - IDFLDS dimensioning is hardwired as IDFLDS(-7:9) where lowest possible -! value of JFIRST is JFIRST=-7 -! -! 8. Structure : -! -! -------------------------------------------------------------- -! 1. Multi-grid model intializations -! a Unit numbers -! b Subroutine tracing ( ITRACE ) -! c Input file -! d Log and test files -! e Initial and test output -! 2. Set-up of data structures and I/O -! a Get number of grids -! b Set up data structures -! ( W3NMOD, W3NDAT, W3NAUX, W3NOUT, W3NINP, WMNDAT ) -! c Set up I/O for individual models -! 3. Get individual grid information -! a Read data -! b Assign input file numbers. -! c Set rank and group data -! d Unified point output file. ( W3IOGR ) -! e Output -! 4. Model run time information and settings -! 5. Output requests -! a Loop over types for unified output -! --------------------------------------------------- -! b Process standard line -! c Type 1: fields of mean wave parameters -! d Type 2: point output -! e Type 3: track output -! f Type 4: restart files (no additional data) -! g Type 5: nesting data (no additional data) -! h Type 6: wave field data (dummy for now) -! i Set all grids to unified output -! --------------------------------------------------- -! j Endless loop for correcting output per grid -! --------------------------------------------------- -! Test grid name and output number -! k Process standard line -! l Type 1: fields of mean wave parameters -! m Type 2: point output -! n Type 3: track output -! o Type 6: partitioning output -! p Type 7: coupling output -! --------------------------------------------------- -! 6. Read moving grid data -! 7. Work load distribution -! a Initialize arrays -! b Set communicators and ALLPRC array -! c Set MODMAP and LOADMP arrays -! d Warnings -! 8. Actual initializations -! a Loop over models for per-model initialization -! 1 Wave model ( W3INIT ) -! 2 Data files ( W3FLDO ) -! 3 Grid status indicator and model times -! 3 Grid data for processors that are NOT used. -! 5 Test output -! b Input data files. -! c Inter model initialization -! 1 Set spectral conversion flags ( WMRSPC ) -! 2 Prepare unified point output ( WMIOPO ) -! 3 Relation to lower ranked grids -! ( WMGLOW, WMIOBS, WMIOBG, WMIOBF ) -! 4 Relation to same ranked grids ( WMGEQL ) -! 5 Relation to higher ranked grids ( WMGHGH ) -! 6 Output -! -------------------------------------------------------------- -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/MGW Moving grid wind correction. -! !/MGP Moving grid propagation correction. -! -! !/O10 Enable output identifying start and end of routine -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/MPRF Profiling. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ - USE W3GDATMD, ONLY: W3NMOD, W3DIMX, W3DIMS, W3SETG - USE W3WDATMD, ONLY: W3NDAT, W3SETW - USE W3ADATMD, ONLY: W3NAUX, W3SETA - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3IDATMD, ONLY: W3NINP, W3SETI, W3DIMI - USE WMMDATMD, ONLY: WMNDAT, WMSETM, WMDIMD -! - USE W3FLDSMD, ONLY: W3FLDO - USE W3IOGOMD, ONLY: W3READFLGRD - USE W3IOGRMD, ONLY: W3IOGR - USE W3INITMD, ONLY: W3INIT - USE WMGRIDMD, ONLY: WMRSPC, WMGLOW, WMGEQL, WMGHGH, WMSMCEQL - USE WMINIOMD, ONLY: WMIOBS, WMIOBG, WMIOBF - USE WMIOPOMD, ONLY: WMIOPP -!/ - USE W3SERVMD, ONLY: ITRACE, EXTCDE, WWDATE, WWTIME, NEXTLN +MODULE WMINITMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 13-Jun-2005 : Origination. ( version 3.07 ) + !/ See subroutine for update log. + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 16-Aug-2010 : Adding NTRMAX to unify NTRACE. ( version 3.14 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 05-Sep-2011 : Distribute HQFAC anf HPFAC to idle processors for + !/ use in WMGRIDMD. ( version 4.05 ) + !/ 07-Mar-2012 : Adding TNAMES to avoid read warn. ( version 4.07 ) + !/ Adjust allocation INPMAP and IDINP. + !/ 12-Mar-2012 : Fixing format 9061. ( version 3.14 ) + !/ Use MPI_COMM_NULL for checks instead of fixed '-1'. + !/ 28-Jul-2012 : Initialize FLGR2 properly. ( version 4.08 ) + !/ Tom Durrant's fix, but moved to allocation. + !/ 28-Nov-2012 : Bug fix: Distribute to idle processors the grid data + !/ required for regridding. ( version 4.08 ) + !/ (T. J. Campbell, NRL) + !/ 02-Sep-2012 : Set up for > 999 test files. ( version 4.10 ) + !/ Set up output for > 999 procs. + !/ 03-Sep-2012 : Output of initilization time. ( version 4.10 ) + !/ Switch test file on/off (TSTOUT) + !/ 18-Dec-2013 : Adding error checking for FLAGLL ( version 4.16 ) + !/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) + !/ 04-Feb-2014 : Switched clock to DATE_AND_TIME ( version 4.18 ) + !/ (A. Chawla and Mark Szyszka) + !/ 27-May-2014 : Bug fix prf file name. ( version 5.02 ) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ 20-Jan-2017 : Modify input forcing flags to support coupler input. + !/ Add ESMF override for STIME & ETIME ( version 6.02 ) + !/ (T. J. Campbell, NRL) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Initialization of the multi-grid wave model. As a preparation + ! for coupled modeling, all initialization, including the + ! processing of the input file has ben included in the routine. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NTRMAX Int. Local Maximum number of subroutine trace + ! printouts (NTRACE in subr. ITRACE). + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WMINIT Subr. Public Wave model initialization. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + !< NTRMAX Maximum number + !< of subroutine trace + !< printouts (NTRACE in + !< subr. ITRACE). + INTEGER, PRIVATE :: NTRMAX = 1000 + + + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize multi-grid version of WAVEWATCH III. + !> + !> @param[in] IDSI Unit number for input file. + !> @param[in] IDSO Unit number for output file. + !> @param[in] IDSS Unit number for "screen" output. Switch off + !> by setting equal to IDSO. + !> @param[in] IDST Unit number for test output. + !> @param[in] IDSE Unit number for error output. + !> @param[in] IFNAME File name for input file. + !> @param[in] MPI_COMM MPI communicator to be used. + !> @param[in] PREAMB File name preamble (optional). + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & + MPI_COMM, PREAMB ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 13-Jun-2005 : Origination. ( version 3.07 ) + !/ 28-Dec-2005 : Add static nesting. ( version 3.08 ) + !/ 25-May-2006 : Add overlapping grids. ( version 3.09 ) + !/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) + !/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 09-Aug-2006 : Unified point output added. ( version 3.10 ) + !/ 14-Oct-2006 : Adding separate input grids. ( version 3.10 ) + !/ 03-Nov-2006 : Adding wave field separation. ( version 3.10 ) + !/ 02-Feb-2007 : Adding FLAGST initialization. ( version 3.10 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 16-Aug-2010 : Adding NTRMAX to unify NTRACE. ( version 3.14.5 ) + !/ 21-Sep-2010 : Adding coupling output ( version 3.14-Ifremer) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 28-Jul-2012 : Initialize FLGR2 properly. ( version 4.08 ) + !/ Tom Durant's fix, but moved to allocation. + !/ 28-Nov-2012 : Bug fix: Distribute to idle processors the grid data + !/ required for regridding. ( version 4.08 ) + !/ (T. J. Campbell, NRL) + !/ 02-Sep-2012 : Set up for > 999 test files. ( version 4.10 ) + !/ Set up output for > 999 procs. + !/ 03-Sep-2012 : Output of initilization time. ( version 4.10 ) + !/ Switch test file on/off (TSTOUT) + !/ 28-Nov-2012 : Bug fix: Distribute to idle processors the grid data + !/ required for regridding. ( version 4.08 ) + !/ (T. J. Campbell, NRL) + !/ 15-Apr-2013 : Changes the reading of output fields( version 4.10 ) + !/ (F. Ardhuin) + !/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) + !/ 27-May-2014 : Bug fix prf file name. ( version 5.02 ) + !/ 17-Sep-2014 : Read mod_def before inp file ( version 5.03 ) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ 20-Jan-2017 : Modify input forcing flags to support coupler input. + !/ Add ESMF override for STIME & ETIME ( version 6.02 ) + !/ (T. J. Campbell, NRL) + !/ 28-Oct-2020 : Add SMCTYPE for SMC sub-grid. JGLi ( version 7.13 ) + !/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Initialize multi-grid version of WAVEWATCH III. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IDSI Int. I Unit number for input file. + ! IDSO Int. I Unit number for output file. + ! IDSS Int. I Unit number for "screen" output. Switch off + ! by setting equal to IDSO. + ! IDST Int. I Unit number for test output. + ! IDSE Int. I Unit number for error output. + ! IFNAME Char I File name for input file. + ! MPI_COMM Int. I MPI communicator to be used. + ! PREAMB Char I File name preamble (optional). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Data structure initialization. + ! W3DIMX Subr. Id. Set grid arrays. + ! W3DIMS Subr. Id. Set grid arrays. + ! W3SETG Subr. Id. Point to grid/model. + ! W3NDAT Subr. W3WDATMD Data structure initialization. + ! W3SETW Subr. Id. Point to grid/model. + ! W3NAUX Subr. W3ADATMD Data structure initialization. + ! W3SETA Subr. Id. Point to grid/model. + ! W3NOUT Subr. W3ODATMD Data structure initialization. + ! W3SETO Subr. Id. Point to grid/model. + ! W3NINP Subr. W3IDATMD Data structure initialization. + ! W3SETI Subr. Id. Point to grid/model. + ! W3DIMI Subr. Id. Allocate grid/model. + ! WMNDAT Subr. WMMDATMD Data structure initialization. + ! WMSETM Subr. Id. Point to grid/model. + ! WMDIMD Subr. Id. Allocate array space. + ! W3FLDO Subr. W3FLDSMD Open input data file. + ! W3IOGR Subr. W3IOGRMD Reading of model definition file. + ! W3INIT Subr. W3INITMD Model intiailization. + ! WMGLOW Subr. WMGRIDMD Lower rank grid dependencies. + ! WMGEQL Subr. Id. Same rank grid dependencies. + ! WMGHGH Subr. Id. Higher rank grid dependencies. + ! RESPEC Subr. Id. Spectral conversion flags. + ! WMIOBS Subr. WMINIOMD Stage boundary data. + ! WMIOBG Subr. Id. Gather boundary data. + ! WMIOBF Subr. Id. Finalize staging in WMIOBS. + ! WMUINI Subr. WMUNITMD Initialize dynamic unit assignment, + ! WMUDMP Subr. Id. Dump dynamic unit data, + ! WMUSET Subr. Id. Set unit number data. + ! WMUGET Subr. Id. Get a unit number. + ! WMUINQ Subr. Id. Update unit number info. + ! WMIOPP Subr. WMIOPOMD Initialize unified point output. + ! ITRACE Subr. W3SERVMD Initialize subroutine tracing. + ! STRACE Subr. Id. Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! WWDATE Subr. Id. System date. + ! WWTIME Subr. Id. System time. + ! NEXTLN Subr. Id. Find next input line in file. + ! PRINIT Subr. Id. Profiling routine ( !/MPRF ) + ! PRTIME Subr. Id. Profiling routine ( !/MPRF ) + ! STME21 Subr. W3TIMEMD Convert time to string. + ! DSEC21 Func. Id. Difference between times. + ! TICK21 Subr. Id. Advance the clock. + ! W3READFLGRD Subr. W3IOGOMD Reads flags or namelist for output fields + ! + ! MPI_COMM_SIZE, CALL MPI_COMM_RANK, MPI_BARRIER, MPI_COMM_GROUP, + ! MPI_GROUP_INCLUDE, MPI_COMM_CREATE, MPI_GROUP_FREE, MPI_BCAST + ! Subr. mpif.h Standard MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3MLTI Prog. N/A Multi-grid model driver. + ! .... Any coupled model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See formats 1000 and following, or escape locations 2000 and + ! following. + ! + ! 7. Remarks : + ! + ! - When running regtests in cases where disk is non-local + ! (i.e. NFS used), there can be a huge improvment in compute + ! time by using /var/tmp/ for log files. + ! See commented line at "OPEN (MDSO,FILE=..." + ! + ! - IDFLDS dimensioning is hardwired as IDFLDS(-7:9) where lowest possible + ! value of JFIRST is JFIRST=-7 + ! + ! 8. Structure : + ! + ! -------------------------------------------------------------- + ! 1. Multi-grid model intializations + ! a Unit numbers + ! b Subroutine tracing ( ITRACE ) + ! c Input file + ! d Log and test files + ! e Initial and test output + ! 2. Set-up of data structures and I/O + ! a Get number of grids + ! b Set up data structures + ! ( W3NMOD, W3NDAT, W3NAUX, W3NOUT, W3NINP, WMNDAT ) + ! c Set up I/O for individual models + ! 3. Get individual grid information + ! a Read data + ! b Assign input file numbers. + ! c Set rank and group data + ! d Unified point output file. ( W3IOGR ) + ! e Output + ! 4. Model run time information and settings + ! 5. Output requests + ! a Loop over types for unified output + ! --------------------------------------------------- + ! b Process standard line + ! c Type 1: fields of mean wave parameters + ! d Type 2: point output + ! e Type 3: track output + ! f Type 4: restart files (no additional data) + ! g Type 5: nesting data (no additional data) + ! h Type 6: wave field data (dummy for now) + ! i Set all grids to unified output + ! --------------------------------------------------- + ! j Endless loop for correcting output per grid + ! --------------------------------------------------- + ! Test grid name and output number + ! k Process standard line + ! l Type 1: fields of mean wave parameters + ! m Type 2: point output + ! n Type 3: track output + ! o Type 6: partitioning output + ! p Type 7: coupling output + ! --------------------------------------------------- + ! 6. Read moving grid data + ! 7. Work load distribution + ! a Initialize arrays + ! b Set communicators and ALLPRC array + ! c Set MODMAP and LOADMP arrays + ! d Warnings + ! 8. Actual initializations + ! a Loop over models for per-model initialization + ! 1 Wave model ( W3INIT ) + ! 2 Data files ( W3FLDO ) + ! 3 Grid status indicator and model times + ! 3 Grid data for processors that are NOT used. + ! 5 Test output + ! b Input data files. + ! c Inter model initialization + ! 1 Set spectral conversion flags ( WMRSPC ) + ! 2 Prepare unified point output ( WMIOPO ) + ! 3 Relation to lower ranked grids + ! ( WMGLOW, WMIOBS, WMIOBG, WMIOBF ) + ! 4 Relation to same ranked grids ( WMGEQL ) + ! 5 Relation to higher ranked grids ( WMGHGH ) + ! 6 Output + ! -------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! + ! !/MGW Moving grid wind correction. + ! !/MGP Moving grid propagation correction. + ! + ! !/O10 Enable output identifying start and end of routine + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/MPRF Profiling. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + USE W3GDATMD, ONLY: W3NMOD, W3DIMX, W3DIMS, W3SETG + USE W3WDATMD, ONLY: W3NDAT, W3SETW + USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3IDATMD, ONLY: W3NINP, W3SETI, W3DIMI + USE WMMDATMD, ONLY: WMNDAT, WMSETM, WMDIMD + ! + USE W3FLDSMD, ONLY: W3FLDO + USE W3IOGOMD, ONLY: W3READFLGRD + USE W3IOGRMD, ONLY: W3IOGR + USE W3INITMD, ONLY: W3INIT + USE WMGRIDMD, ONLY: WMRSPC, WMGLOW, WMGEQL, WMGHGH, WMSMCEQL + USE WMINIOMD, ONLY: WMIOBS, WMIOBG, WMIOBF + USE WMIOPOMD, ONLY: WMIOPP + !/ + USE W3SERVMD, ONLY: ITRACE, EXTCDE, WWDATE, WWTIME, NEXTLN #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_MPRF - USE W3TIMEMD, ONLY: PRINIT, PRTIME + USE W3TIMEMD, ONLY: PRINIT, PRTIME #endif - USE W3TIMEMD, ONLY: STME21, DSEC21, TICK21, TDIFF - USE WMUNITMD, ONLY: WMUINI, WMUDMP, WMUSET, WMUGET, WMUINQ -!/ - USE W3GDATMD, ONLY: GTYPE, NX, NY, FILEXT, NSEA, FLAGST, GRIDS + USE W3TIMEMD, ONLY: STME21, DSEC21, TICK21, TDIFF + USE WMUNITMD, ONLY: WMUINI, WMUDMP, WMUSET, WMUGET, WMUINQ + !/ + USE W3GDATMD, ONLY: GTYPE, NX, NY, FILEXT, NSEA, FLAGST, GRIDS #ifdef W3_SMC - USE W3GDATMD, ONLY: NCel, NUFc, NVFc, NRLv, NBSMC - USE W3GDATMD, ONLY: NARC, NBAC, NSPEC, SMCTYPE + USE W3GDATMD, ONLY: NCel, NUFc, NVFc, NRLv, NBSMC + USE W3GDATMD, ONLY: NARC, NBAC, NSPEC, SMCTYPE #endif #ifdef W3_MPI - USE W3GDATMD, ONLY: FLAGLL, ICLOSE, GSU, X0, Y0, SX, SY, & - XGRD, YGRD, DXDP, DXDQ, DYDP, DYDQ, & - HQFAC, HPFAC, MAPSTA, MAPST2, & - GRIDSHIFT, NSEAL, NK, NTH, XFR, FR1, & - TH, DTMAX, DTCFL - USE W3GSRUMD -#endif - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: WADATS - USE W3IDATMD, ONLY: INFLAGS1, INFLAGS2, INPUTS, IINIT, & - JFIRST - USE W3ODATMD, ONLY: NOGRP, NGRPP, FLOUT, TONEXT, FLBPI, & - FLBPO, NFBPO, NBI, NDS, IAPROC, & - NAPFLD, NAPPNT, NAPTRK, NAPBPT, & - NAPPRT, NAPROC, FNMPRE, OUTPTS, NDST, NDSE, & - NOPTS, IOSTYP, UNIPTS, UPPROC, DTOUT, & - TOLAST, NOTYPE - USE WMMDATMD, ONLY: MDSI, MDSO, MDSS, MDST, MDSE, MDSF, MDSUP, & - IMPROC, NMPROC, NMPSCR, NMPERR, & - NMPLOG, NMPUPT, STIME, ETIME, NMV, NMVMAX, & - TMV, AMV, DMV, NRGRD, NRINP, NRGRP, GRANK, & - GRGRP, INGRP, GRDHGH, GRDEQL, GRDLOW, & - ALLPRC, MODMAP, TSYNC, TMAX, TOUTP, TDATA, & - GRSTAT, DTRES, BCDUMP, FLGHG1, FLGHG2, & - INPMAP, IDINP, NGRPSMC - USE WMMDATMD, ONLY: CLKDT1, CLKDT2, CLKFIN + USE W3GDATMD, ONLY: FLAGLL, ICLOSE, GSU, X0, Y0, SX, SY, & + XGRD, YGRD, DXDP, DXDQ, DYDP, DYDQ, & + HQFAC, HPFAC, MAPSTA, MAPST2, & + GRIDSHIFT, NSEAL, NK, NTH, XFR, FR1, & + TH, DTMAX, DTCFL + USE W3GSRUMD +#endif + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: WADATS + USE W3IDATMD, ONLY: INFLAGS1, INFLAGS2, INPUTS, IINIT, & + JFIRST + USE W3ODATMD, ONLY: NOGRP, NGRPP, FLOUT, TONEXT, FLBPI, & + FLBPO, NFBPO, NBI, NDS, IAPROC, & + NAPFLD, NAPPNT, NAPTRK, NAPBPT, & + NAPPRT, NAPROC, FNMPRE, OUTPTS, NDST, NDSE, & + NOPTS, IOSTYP, UNIPTS, UPPROC, DTOUT, & + TOLAST, NOTYPE + USE WMMDATMD, ONLY: MDSI, MDSO, MDSS, MDST, MDSE, MDSF, MDSUP, & + IMPROC, NMPROC, NMPSCR, NMPERR, & + NMPLOG, NMPUPT, STIME, ETIME, NMV, NMVMAX, & + TMV, AMV, DMV, NRGRD, NRINP, NRGRP, GRANK, & + GRGRP, INGRP, GRDHGH, GRDEQL, GRDLOW, & + ALLPRC, MODMAP, TSYNC, TMAX, TOUTP, TDATA, & + GRSTAT, DTRES, BCDUMP, FLGHG1, FLGHG2, & + INPMAP, IDINP, NGRPSMC + USE WMMDATMD, ONLY: CLKDT1, CLKDT2, CLKFIN #ifdef W3_MPI - USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & - MPI_COMM_BCT, CROOT, FBCAST + USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & + MPI_COMM_BCT, CROOT, FBCAST #endif #ifdef W3_MPRF - USE WMMDATMD, ONLY: MDSP -#endif - USE W3INITMD, ONLY: WWVER - USE W3ODATMD, ONLY: OFILES -! -!/ - IMPLICIT NONE -! + USE WMMDATMD, ONLY: MDSP +#endif + USE W3INITMD, ONLY: WWVER + USE W3ODATMD, ONLY: OFILES + ! + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IDSI, IDSO, IDSS, IDST, IDSE, & - MPI_COMM - CHARACTER*(*), INTENT(IN) :: IFNAME - CHARACTER*(*), INTENT(IN), OPTIONAL :: PREAMB -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: MDSE2, IERR, I, J, NMOVE, TTIME(2), & - ILOOP, MDSI2, SCRATCH, RNKMIN, & - RNKMAX, RNKTMP, GRPMIN, GRPMAX, II, & - NDSREC, NDSFND, NPTS, JJ, IP1, IPN, & - MPI_COMM_LOC, NMPSC2, JJJ, TOUT(2), & - TLST(2), NCPROC, NPOUTT, NAPLOC, & - NAPRES, NAPADD, NAPBCT, IFI, IFJ, IW,& - IFT - INTEGER :: STMPT(2), ETMPT(2) + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IDSI, IDSO, IDSS, IDST, IDSE, & + MPI_COMM + CHARACTER*(*), INTENT(IN) :: IFNAME + CHARACTER*(*), INTENT(IN), OPTIONAL :: PREAMB + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: MDSE2, IERR, I, J, NMOVE, TTIME(2), & + ILOOP, MDSI2, SCRATCH, RNKMIN, & + RNKMAX, RNKTMP, GRPMIN, GRPMAX, II, & + NDSREC, NDSFND, NPTS, JJ, IP1, IPN, & + MPI_COMM_LOC, NMPSC2, JJJ, TOUT(2), & + TLST(2), NCPROC, NPOUTT, NAPLOC, & + NAPRES, NAPADD, NAPBCT, IFI, IFJ, IW,& + IFT + INTEGER :: STMPT(2), ETMPT(2) #ifdef W3_MPI - INTEGER :: IERR_MPI, BGROUP, LGROUP, IROOT + INTEGER :: IERR_MPI, BGROUP, LGROUP, IROOT #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, ALLOCATABLE :: MDS(:,:), NTRACE(:,:), ODAT(:,:), & - TMPRNK(:), TMPGRP(:), NINGRP(:), & - TMOVE(:,:), LOADMP(:,:), IPRT(:,:), & - NDPOUT(:), OUTFF(:,:) - REAL :: DTTST, XX, YY + INTEGER, ALLOCATABLE :: MDS(:,:), NTRACE(:,:), ODAT(:,:), & + TMPRNK(:), TMPGRP(:), NINGRP(:), & + TMOVE(:,:), LOADMP(:,:), IPRT(:,:), & + NDPOUT(:), OUTFF(:,:) + REAL :: DTTST, XX, YY #ifdef W3_MPRF - REAL :: PRFT0, PRFTN - REAL(KIND=8) :: get_memory -#endif - REAL, ALLOCATABLE :: X(:), Y(:), AMOVE(:), DMOVE(:), & - RP1(:), RPN(:) - LOGICAL :: FLT, TFLAGI, TFLAGS(-7:14), PSHARE - LOGICAL, ALLOCATABLE :: FLGRD(:,:,:), FLRBPI(:), BCDTMP(:), & - USEINP(:), LPRT(:), FLGR2(:,:,:), & - FLGD(:,:), FLG2(:,:), FLG2D(:,:), & - FLG1D(:), CPLINP(:) - CHARACTER(LEN=1) :: COMSTR - CHARACTER(LEN=3) :: IDSTR(9), IDTST - CHARACTER(LEN=5) :: STOUT, OUTSTR(6) - CHARACTER(LEN=6) :: ACTION(11), YESXX, XXXNO - CHARACTER(LEN=8) :: LFILE, STTIME + REAL :: PRFT0, PRFTN + REAL(KIND=8) :: get_memory +#endif + REAL, ALLOCATABLE :: X(:), Y(:), AMOVE(:), DMOVE(:), & + RP1(:), RPN(:) + LOGICAL :: FLT, TFLAGI, TFLAGS(-7:14), PSHARE + LOGICAL, ALLOCATABLE :: FLGRD(:,:,:), FLRBPI(:), BCDTMP(:), & + USEINP(:), LPRT(:), FLGR2(:,:,:), & + FLGD(:,:), FLG2(:,:), FLG2D(:,:), & + FLG1D(:), CPLINP(:) + CHARACTER(LEN=1) :: COMSTR + CHARACTER(LEN=3) :: IDSTR(9), IDTST + CHARACTER(LEN=5) :: STOUT, OUTSTR(6) + CHARACTER(LEN=6) :: ACTION(11), YESXX, XXXNO + CHARACTER(LEN=8) :: LFILE, STTIME #ifdef W3_SHRD - CHARACTER(LEN=9) :: TFILE -#endif - CHARACTER(LEN=13) :: STDATE, MN, TNAMES(9) - CHARACTER(LEN=40) :: PN - CHARACTER(LEN=13), & - ALLOCATABLE :: INAMES(:,:), MNAMES(:) - CHARACTER(LEN=40), & - ALLOCATABLE :: PNAMES(:) - CHARACTER(LEN=12) :: FORMAT + CHARACTER(LEN=9) :: TFILE +#endif + CHARACTER(LEN=13) :: STDATE, MN, TNAMES(9) + CHARACTER(LEN=40) :: PN + CHARACTER(LEN=13), & + ALLOCATABLE :: INAMES(:,:), MNAMES(:) + CHARACTER(LEN=40), & + ALLOCATABLE :: PNAMES(:) + CHARACTER(LEN=12) :: FORMAT #ifdef W3_DIST - CHARACTER(LEN=18) :: TFILE + CHARACTER(LEN=18) :: TFILE #endif #ifdef W3_MPRF - CHARACTER(LEN=18) :: PFILE + CHARACTER(LEN=18) :: PFILE #endif - CHARACTER(LEN=13) :: IDFLDS(-7:9) - CHARACTER(LEN=23) :: DTME21 - CHARACTER(LEN=30) :: IDOTYP(8) - CHARACTER(LEN=80) :: TNAME - CHARACTER(LEN=80) :: LINE - CHARACTER(LEN=80) :: LINEIN - CHARACTER(LEN=8) :: WORDS(6) + CHARACTER(LEN=13) :: IDFLDS(-7:9) + CHARACTER(LEN=23) :: DTME21 + CHARACTER(LEN=30) :: IDOTYP(8) + CHARACTER(LEN=80) :: TNAME + CHARACTER(LEN=80) :: LINE + CHARACTER(LEN=80) :: LINEIN + CHARACTER(LEN=8) :: WORDS(6) - TYPE OT2TPE - INTEGER :: NPTS - REAL, POINTER :: X(:), Y(:) - CHARACTER(LEN=40), POINTER :: PNAMES(:) - END TYPE OT2TPE -! - TYPE(OT2TPE), ALLOCATABLE :: OT2(:) -!/ -!/ ------------------------------------------------------------------- / -!/ + TYPE OT2TPE + INTEGER :: NPTS + REAL, POINTER :: X(:), Y(:) + CHARACTER(LEN=40), POINTER :: PNAMES(:) + END TYPE OT2TPE + ! + TYPE(OT2TPE), ALLOCATABLE :: OT2(:) + !/ + !/ ------------------------------------------------------------------- / + !/ - DATA IDFLDS / 'ice param. 1 ' , 'ice param. 2 ' , & - 'ice param. 3 ' , 'ice param. 4 ' , & - 'ice param. 5 ' , & - 'mud density ' , 'mud thkness ' , & - 'mud viscos. ' , & - 'water levels ' , 'currents ' , & - 'winds ' , 'ice fields ' , & - 'momentum ' , 'air density ' , & - 'mean param. ' , '1D spectra ' , & - '2D spectra ' / -! - DATA IDOTYP / 'Fields of mean wave parameters' , & - 'Point output ' , & - 'Track point output ' , & - 'Restart files ' , & - 'Nesting data ' , & - 'Separated wave field data ' , & - 'Fields for coupling ' , & - 'Restart files second request '/ -! - DATA IDSTR / 'LEV', 'CUR', 'WND', 'ICE', 'TAU', 'RHO', & - 'DT0', 'DT1', 'DT2' / -! - DATA YESXX / 'YES/--' / - DATA XXXNO / '---/NO' / -! + DATA IDFLDS / 'ice param. 1 ' , 'ice param. 2 ' , & + 'ice param. 3 ' , 'ice param. 4 ' , & + 'ice param. 5 ' , & + 'mud density ' , 'mud thkness ' , & + 'mud viscos. ' , & + 'water levels ' , 'currents ' , & + 'winds ' , 'ice fields ' , & + 'momentum ' , 'air density ' , & + 'mean param. ' , '1D spectra ' , & + '2D spectra ' / + ! + DATA IDOTYP / 'Fields of mean wave parameters' , & + 'Point output ' , & + 'Track point output ' , & + 'Restart files ' , & + 'Nesting data ' , & + 'Separated wave field data ' , & + 'Fields for coupling ' , & + 'Restart files second request '/ + ! + DATA IDSTR / 'LEV', 'CUR', 'WND', 'ICE', 'TAU', 'RHO', & + 'DT0', 'DT1', 'DT2' / + ! + DATA YESXX / 'YES/--' / + DATA XXXNO / '---/NO' / + ! #ifdef W3_MPRF - CALL PRINIT - CALL PRTIME ( PRFT0 ) + CALL PRINIT + CALL PRTIME ( PRFT0 ) #endif -! - CALL DATE_AND_TIME ( VALUES=CLKDT1 ) -! - MPI_COMM_LOC = MPI_COMM + ! + CALL DATE_AND_TIME ( VALUES=CLKDT1 ) + ! + MPI_COMM_LOC = MPI_COMM #ifdef W3_MPI - MPI_COMM_MWAVE = MPI_COMM - CALL MPI_COMM_SIZE ( MPI_COMM_MWAVE, NMPROC, IERR_MPI ) - CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) - IMPROC = IMPROC + 1 -#endif -! - IF ( PRESENT(PREAMB) ) FNMPRE = PREAMB -!/ -!/ ------------------------------------------------------------------- / -! 1. Multi-grid model intializations -! 1.a Unit numbers -! Initialize dynamic assignment, errors and test to stdout -! - CALL WMUINI ( 6, 6 ) -! -! ... Identify reserved unit numbers -! - CALL WMUSET ( 6,6, 5, .TRUE., 'SYS', 'stdin', 'Standart input' ) - CALL WMUSET ( 6,6, 6, .TRUE., 'SYS', 'stdout','Standart output') -! + MPI_COMM_MWAVE = MPI_COMM + CALL MPI_COMM_SIZE ( MPI_COMM_MWAVE, NMPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 +#endif + ! + IF ( PRESENT(PREAMB) ) FNMPRE = PREAMB + !/ + !/ ------------------------------------------------------------------- / + ! 1. Multi-grid model intializations + ! 1.a Unit numbers + ! Initialize dynamic assignment, errors and test to stdout + ! + CALL WMUINI ( 6, 6 ) + ! + ! ... Identify reserved unit numbers + ! + CALL WMUSET ( 6,6, 5, .TRUE., 'SYS', 'stdin', 'Standart input' ) + CALL WMUSET ( 6,6, 6, .TRUE., 'SYS', 'stdout','Standart output') + ! #ifdef W3_NL2 - CALL WMUSET (6,6,103, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,104, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,105, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,106, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,107, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,108, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,109, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,110, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,111, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,112, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,113, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,114, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,117, .TRUE., 'FIX', DESC='Reserved SNL2' ) -#endif -! -! ... Unit numbers from parameter list -! Dynamic scripture updated per file -! - MDSI = IDSI - MDSO = IDSO - MDSS = IDSS - MDST = IDST - MDSE = IDSE -! - IF ( IMPROC .EQ. NMPERR ) THEN - MDSE2 = MDSE - ELSE - MDSE2 = -1 - END IF -! -! 1.b Subroutine tracing -! - CALL ITRACE ( MDST, NTRMAX ) -! + CALL WMUSET (6,6,103, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,104, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,105, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,106, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,107, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,108, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,109, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,110, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,111, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,112, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,113, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,114, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,117, .TRUE., 'FIX', DESC='Reserved SNL2' ) +#endif + ! + ! ... Unit numbers from parameter list + ! Dynamic scripture updated per file + ! + MDSI = IDSI + MDSO = IDSO + MDSS = IDSS + MDST = IDST + MDSE = IDSE + ! + IF ( IMPROC .EQ. NMPERR ) THEN + MDSE2 = MDSE + ELSE + MDSE2 = -1 + END IF + ! + ! 1.b Subroutine tracing + ! + CALL ITRACE ( MDST, NTRMAX ) + ! #ifdef W3_O10 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) -#endif -! -! 1.c Input file -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,910) IFNAME, MDSI -! - OPEN (MDSI,FILE=TRIM(FNMPRE)//IFNAME,STATUS='OLD',ERR=2000, & - IOSTAT=IERR) - REWIND (MDSI) - READ (MDSI,'(A)',END=2001,ERR=2002) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - CALL WMUSET ( MDSS, MDSS, MDSI, .TRUE., 'INP', & - TRIM(FNMPRE)//IFNAME, 'Model control input file') -! -! 1.d Log and test files -! - LFILE = 'log.mww3' - IW = 1 + INT ( LOG10 ( REAL(NMPROC) + 0.5 ) ) - IW = MAX ( 3 , MIN ( 9 , IW ) ) - WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') '(A4,I',IW,'.',IW,',A5)' + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#endif + ! + ! 1.c Input file + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,910) IFNAME, MDSI + ! + OPEN (MDSI,FILE=TRIM(FNMPRE)//IFNAME,STATUS='OLD',ERR=2000, & + IOSTAT=IERR) + REWIND (MDSI) + READ (MDSI,'(A)',END=2001,ERR=2002) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + CALL WMUSET ( MDSS, MDSS, MDSI, .TRUE., 'INP', & + TRIM(FNMPRE)//IFNAME, 'Model control input file') + ! + ! 1.d Log and test files + ! + LFILE = 'log.mww3' + IW = 1 + INT ( LOG10 ( REAL(NMPROC) + 0.5 ) ) + IW = MAX ( 3 , MIN ( 9 , IW ) ) + WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') '(A4,I',IW,'.',IW,',A5)' #ifdef W3_SHRD - TFILE = 'test.mww3' + TFILE = 'test.mww3' #endif #ifdef W3_DIST - WRITE (TFILE,FORMAT) 'test', IMPROC, '.mww3' + WRITE (TFILE,FORMAT) 'test', IMPROC, '.mww3' #endif #ifdef W3_MPRF - WRITE (PFILE,FORMAT) 'prf.', IMPROC, '.mww3' -#endif -! - IF ( IMPROC .EQ. NMPLOG ) THEN - OPEN (MDSO,FILE=TRIM(FNMPRE)//LFILE,ERR=2010,IOSTAT=IERR) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,911) LFILE, MDSO - CALL WMUSET ( MDSS, MDSS, MDSO, .TRUE., 'OUT', & - TRIM(FNMPRE)//LFILE, 'Log file') - ELSE - CALL WMUSET ( MDSS, MDSS, MDSO, .TRUE., 'XXX', & - 'Log file on other processors') - END IF -! - IF ( MDST.NE.MDSO .AND. MDST.NE.MDSS .AND. TSTOUT ) THEN - IFT = LEN_TRIM(TFILE) - OPEN (MDST,FILE=TRIM(FNMPRE)//TFILE(:IFT),ERR=2011,IOSTAT=IERR) - CALL WMUSET ( MDSS, MDST, MDST, .TRUE., 'OUT', & - TRIM(FNMPRE)//TFILE(:IFT), 'Test output file') - END IF -! + WRITE (PFILE,FORMAT) 'prf.', IMPROC, '.mww3' +#endif + ! + IF ( IMPROC .EQ. NMPLOG ) THEN + OPEN (MDSO,FILE=TRIM(FNMPRE)//LFILE,ERR=2010,IOSTAT=IERR) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,911) LFILE, MDSO + CALL WMUSET ( MDSS, MDSS, MDSO, .TRUE., 'OUT', & + TRIM(FNMPRE)//LFILE, 'Log file') + ELSE + CALL WMUSET ( MDSS, MDSS, MDSO, .TRUE., 'XXX', & + 'Log file on other processors') + END IF + ! + IF ( MDST.NE.MDSO .AND. MDST.NE.MDSS .AND. TSTOUT ) THEN + IFT = LEN_TRIM(TFILE) + OPEN (MDST,FILE=TRIM(FNMPRE)//TFILE(:IFT),ERR=2011,IOSTAT=IERR) + CALL WMUSET ( MDSS, MDST, MDST, .TRUE., 'OUT', & + TRIM(FNMPRE)//TFILE(:IFT), 'Test output file') + END IF + ! #ifdef W3_MPRF - IFT = LEN_TRIM(PFILE) - CALL WMUGET ( MDSS, MDST, MDSP, 'OUT' ) - CALL WMUSET ( MDSS, MDST, MDSP, .TRUE., 'OUT', & - TRIM(FNMPRE)//PFILE(:IFT), 'Profiling file') - OPEN (MDSP,FILE=TRIM(FNMPRE)//PFILE(:IFT),ERR=2011,IOSTAT=IERR) -#endif -! -! 1.e Initial and test output -! + IFT = LEN_TRIM(PFILE) + CALL WMUGET ( MDSS, MDST, MDSP, 'OUT' ) + CALL WMUSET ( MDSS, MDST, MDSP, .TRUE., 'OUT', & + TRIM(FNMPRE)//PFILE(:IFT), 'Profiling file') + OPEN (MDSP,FILE=TRIM(FNMPRE)//PFILE(:IFT),ERR=2011,IOSTAT=IERR) +#endif + ! + ! 1.e Initial and test output + ! #ifdef W3_S - CALL STRACE (IENT, 'WMINIT') -#endif -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,912) COMSTR -! - IF ( IMPROC .EQ. NMPLOG ) THEN - CALL WWDATE ( STDATE ) - CALL WWTIME ( STTIME ) - WRITE (MDSO,901) WWVER, STDATE, STTIME - END IF -! + CALL STRACE (IENT, 'WMINIT') +#endif + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,912) COMSTR + ! + IF ( IMPROC .EQ. NMPLOG ) THEN + CALL WWDATE ( STDATE ) + CALL WWTIME ( STTIME ) + WRITE (MDSO,901) WWVER, STDATE, STTIME + END IF + ! #ifdef W3_T - WRITE(MDST,9000) IDSI, IDSO, IDSS, IDST, IDSE, IFNAME -#endif -! -! 2. Set-up of data structures and I/O ----------------------------- / -! 2.a Get number of grids -! Note: grid for consolidated point output always generated. -! Processor set as in W3INIT to minimize communication in WMIOPO -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - READ (MDSI,*,END=2001,ERR=2002) NRGRD, NRINP, UNIPTS, & - IOSTYP, UPPROC, PSHARE - IOSTYP = MAX ( 0 , MIN ( 3 , IOSTYP ) ) -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,920) NRGRD - IF ( NRINP .EQ. 0 ) THEN - WRITE (MDSS,921) - ELSE - WRITE (MDSS,922) NRINP - END IF - IF ( UNIPTS ) THEN - WRITE (MDSS,923) YESXX - ELSE - WRITE (MDSS,923) XXXNO - END IF - WRITE (MDSS,1923) IOSTYP - IF ( UNIPTS ) THEN - IF ( UPPROC ) THEN - WRITE (MDSS,2923) YESXX - ELSE - WRITE (MDSS,2923) XXXNO - END IF - END IF - IF ( IOSTYP.GT.1 .AND. PSHARE ) THEN - WRITE (MDSS,3923) YESXX - ELSE IF ( IOSTYP.GT. 1 ) THEN - WRITE (MDSS,3923) XXXNO - END IF + WRITE(MDST,9000) IDSI, IDSO, IDSS, IDST, IDSE, IFNAME +#endif + ! + ! 2. Set-up of data structures and I/O ----------------------------- / + ! 2.a Get number of grids + ! Note: grid for consolidated point output always generated. + ! Processor set as in W3INIT to minimize communication in WMIOPO + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + READ (MDSI,*,END=2001,ERR=2002) NRGRD, NRINP, UNIPTS, & + IOSTYP, UPPROC, PSHARE + IOSTYP = MAX ( 0 , MIN ( 3 , IOSTYP ) ) + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,920) NRGRD + IF ( NRINP .EQ. 0 ) THEN + WRITE (MDSS,921) + ELSE + WRITE (MDSS,922) NRINP + END IF + IF ( UNIPTS ) THEN + WRITE (MDSS,923) YESXX + ELSE + WRITE (MDSS,923) XXXNO + END IF + WRITE (MDSS,1923) IOSTYP + IF ( UNIPTS ) THEN + IF ( UPPROC ) THEN + WRITE (MDSS,2923) YESXX + ELSE + WRITE (MDSS,2923) XXXNO END IF -! - IF ( NRGRD .LT. 1 ) GOTO 2020 - IF ( NRINP .LT. 0 ) GOTO 2021 - IF ( NRINP.EQ.0 .AND. .NOT.UNIPTS ) NRINP = -1 -! -! 2.b Set up data structures -! - CALL W3NMOD ( NRGRD, MDSE2, MDST, NRINP ) - CALL W3NDAT ( MDSE2, MDST ) - CALL W3NAUX ( MDSE2, MDST ) - CALL W3NOUT ( MDSE2, MDST ) - CALL W3NINP ( MDSE2, MDST ) - CALL WMNDAT ( MDSE2, MDST ) -! -! 2.c Set up I/O for individual models (initial) -! - ALLOCATE ( MDS(13,NRGRD), NTRACE(2,NRGRD), ODAT(40,0:NRGRD), & - FLGRD(NOGRP,NGRPP,NRGRD), OT2(0:NRGRD), FLGD(NOGRP,NRGRD), & - MDSF(-NRINP:NRGRD,JFIRST:9), IPRT(6,NRGRD), LPRT(NRGRD), & - FLGR2(NOGRP,NGRPP,NRGRD),FLG2D(NOGRP,NGRPP), FLG1D(NOGRP), & - FLG2(NOGRP,NRGRD),OUTFF(7,0:NRGRD)) -! - MDS = -1 - MDSF = -1 - FLGR2 = .FALSE. - FLG2 = .FALSE. - LPRT = .FALSE. - IPRT = 0 -! -! ... Fixed and recycleable unit numbers. -! - CALL WMUGET ( MDSE, MDST, NDSREC, 'INP' ) - CALL WMUSET ( MDSE, MDST, NDSREC, .TRUE., 'I/O', NAME='...', & - DESC='Recyclable I/O (mod_def etc.)' ) - CALL WMUGET ( MDSE, MDST, SCRATCH, 'SCR' ) - CALL WMUSET ( MDSE, MDST, SCRATCH, .TRUE., DESC='Scratch file', & - NAME=TRIM(FNMPRE)//'ww3_multi.scratch' ) -! - IF(MDST.EQ.NDSREC)THEN - IF ( IMPROC .EQ. NMPERR ) & - WRITE(MDSE,'(A,I8)')'RECYCLABLE UNIT NUMBERS AND '& - //'TEST OUTPUT UNIT NUMBER ARE THE SAME : ',MDST - CALL EXTCDE ( 15 ) - ENDIF + END IF + IF ( IOSTYP.GT.1 .AND. PSHARE ) THEN + WRITE (MDSS,3923) YESXX + ELSE IF ( IOSTYP.GT. 1 ) THEN + WRITE (MDSS,3923) XXXNO + END IF + END IF + ! + IF ( NRGRD .LT. 1 ) GOTO 2020 + IF ( NRINP .LT. 0 ) GOTO 2021 + IF ( NRINP.EQ.0 .AND. .NOT.UNIPTS ) NRINP = -1 + ! + ! 2.b Set up data structures + ! + CALL W3NMOD ( NRGRD, MDSE2, MDST, NRINP ) + CALL W3NDAT ( MDSE2, MDST ) + CALL W3NAUX ( MDSE2, MDST ) + CALL W3NOUT ( MDSE2, MDST ) + CALL W3NINP ( MDSE2, MDST ) + CALL WMNDAT ( MDSE2, MDST ) + ! + ! 2.c Set up I/O for individual models (initial) + ! + ALLOCATE ( MDS(13,NRGRD), NTRACE(2,NRGRD), ODAT(40,0:NRGRD), & + FLGRD(NOGRP,NGRPP,NRGRD), OT2(0:NRGRD), FLGD(NOGRP,NRGRD), & + MDSF(-NRINP:NRGRD,JFIRST:9), IPRT(6,NRGRD), LPRT(NRGRD), & + FLGR2(NOGRP,NGRPP,NRGRD),FLG2D(NOGRP,NGRPP), FLG1D(NOGRP), & + FLG2(NOGRP,NRGRD),OUTFF(7,0:NRGRD)) + ! + MDS = -1 + MDSF = -1 + FLGR2 = .FALSE. + FLG2 = .FALSE. + LPRT = .FALSE. + IPRT = 0 + ! + ! ... Fixed and recycleable unit numbers. + ! + CALL WMUGET ( MDSE, MDST, NDSREC, 'INP' ) + CALL WMUSET ( MDSE, MDST, NDSREC, .TRUE., 'I/O', NAME='...', & + DESC='Recyclable I/O (mod_def etc.)' ) + CALL WMUGET ( MDSE, MDST, SCRATCH, 'SCR' ) + CALL WMUSET ( MDSE, MDST, SCRATCH, .TRUE., DESC='Scratch file', & + NAME=TRIM(FNMPRE)//'ww3_multi.scratch' ) + ! + IF(MDST.EQ.NDSREC)THEN + IF ( IMPROC .EQ. NMPERR ) & + WRITE(MDSE,'(A,I8)')'RECYCLABLE UNIT NUMBERS AND '& + //'TEST OUTPUT UNIT NUMBER ARE THE SAME : ',MDST + CALL EXTCDE ( 15 ) + ENDIF - DO I=1, NRGRD - MDS ( 2,I) = 6 - MDS ( 3,I) = MDST - MDS ( 4,I) = 6 - MDS ( 5,I) = NDSREC - MDS ( 6,I) = NDSREC - NTRACE( 1,I) = MDST - NTRACE( 2,I) = NTRMAX - END DO -! + DO I=1, NRGRD + MDS ( 2,I) = 6 + MDS ( 3,I) = MDST + MDS ( 4,I) = 6 + MDS ( 5,I) = NDSREC + MDS ( 6,I) = NDSREC + NTRACE( 1,I) = MDST + NTRACE( 2,I) = NTRMAX + END DO + ! #ifdef W3_T - WRITE (MDST,9020) 'INITIAL' - DO I=1, NRGRD - WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) - END DO -#endif -! -! 3. Get individual grid information -------------------------------- / -! -! Version 3.07: For now we simply read the input data flags, -! skip the homogeneous option. Later on, we want -! to have the options to use input from common -! sources, and from communication rather than -! files. -! - ALLOCATE ( INAMES(2*NRGRD,JFIRST:9), MNAMES(-NRINP:2*NRGRD), & - TMPRNK(2*NRGRD), TMPGRP(2*NRGRD), NINGRP(2*NRGRD), & - RP1(2*NRGRD), RPN(2*NRGRD), BCDTMP(NRGRD+1:2*NRGRD) ) - ALLOCATE ( GRANK(NRGRD), GRGRP(NRGRD), USEINP(NRINP) ) - ALLOCATE ( CPLINP(NRINP) ) - GRANK = -1 - GRGRP = -1 - USEINP = .FALSE. - CPLINP = .FALSE. -! -! 3.a Read data -! + WRITE (MDST,9020) 'INITIAL' + DO I=1, NRGRD + WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) + END DO +#endif + ! + ! 3. Get individual grid information -------------------------------- / + ! + ! Version 3.07: For now we simply read the input data flags, + ! skip the homogeneous option. Later on, we want + ! to have the options to use input from common + ! sources, and from communication rather than + ! files. + ! + ALLOCATE ( INAMES(2*NRGRD,JFIRST:9), MNAMES(-NRINP:2*NRGRD), & + TMPRNK(2*NRGRD), TMPGRP(2*NRGRD), NINGRP(2*NRGRD), & + RP1(2*NRGRD), RPN(2*NRGRD), BCDTMP(NRGRD+1:2*NRGRD) ) + ALLOCATE ( GRANK(NRGRD), GRGRP(NRGRD), USEINP(NRINP) ) + ALLOCATE ( CPLINP(NRINP) ) + GRANK = -1 + GRGRP = -1 + USEINP = .FALSE. + CPLINP = .FALSE. + ! + ! 3.a Read data + ! #ifdef W3_T - WRITE (MDST,9030) + WRITE (MDST,9030) #endif -! -! 3.a.1 Input grids -! - DO I=1, NRINP -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - CALL W3SETI ( -I, MDSE, MDST ) - INFLAGS1 = .FALSE. - READ (MDSI,*,END=2001,ERR=2002) MNAMES(-I), INFLAGS1(JFIRST:9) -! - END DO -! -! 3.a.2 Unified point output grid. -! - IF ( UNIPTS ) THEN -! - CALL W3SETI ( 0, MDSE, MDST ) - CALL W3SETO ( 0, MDSE, MDST ) - INFLAGS1 = .FALSE. - NDST = MDST - NDSE = MDSE -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - READ (MDSI,*,END=2001,ERR=2002) MNAMES(0) -! - IF ( IOSTYP .LE. 1 ) THEN - NMPUPT = MAX(1,NMPROC-2) - ELSE - NMPUPT = NMPROC - END IF -! - END IF -! -! 3.a.3 Read wave grids -! - DO I=NRGRD+1, 2*NRGRD - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - READ (MDSI,*,END=2001,ERR=2002) MNAMES(I), TNAMES(:), & - TMPRNK(I), TMPGRP(I), RP1(I), RPN(I), BCDTMP(I) - INAMES(I,:) = TNAMES(:) - RP1(I) = MAX ( 0. , MIN ( 1. , RP1(I) ) ) - RPN(I) = MAX ( RP1(I) , MIN ( 1. , RPN(I) ) ) - END DO -! -! 3.a.4 Sort wave grids -! - RNKTMP = MINVAL ( TMPRNK(NRGRD+1:2*NRGRD) ) - I = 0 -! - DO - DO J=NRGRD+1, 2*NRGRD - IF ( TMPRNK(J) .EQ. RNKTMP ) THEN - I = I + 1 - CALL W3SETI ( I, MDSE, MDST ) - INFLAGS1 = .FALSE. + ! + ! 3.a.1 Input grids + ! + DO I=1, NRINP + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + CALL W3SETI ( -I, MDSE, MDST ) + INFLAGS1 = .FALSE. + READ (MDSI,*,END=2001,ERR=2002) MNAMES(-I), INFLAGS1(JFIRST:9) + ! + END DO + ! + ! 3.a.2 Unified point output grid. + ! + IF ( UNIPTS ) THEN + ! + CALL W3SETI ( 0, MDSE, MDST ) + CALL W3SETO ( 0, MDSE, MDST ) + INFLAGS1 = .FALSE. + NDST = MDST + NDSE = MDSE + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + READ (MDSI,*,END=2001,ERR=2002) MNAMES(0) + ! + IF ( IOSTYP .LE. 1 ) THEN + NMPUPT = MAX(1,NMPROC-2) + ELSE + NMPUPT = NMPROC + END IF + ! + END IF + ! + ! 3.a.3 Read wave grids + ! + DO I=NRGRD+1, 2*NRGRD + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + READ (MDSI,*,END=2001,ERR=2002) MNAMES(I), TNAMES(:), & + TMPRNK(I), TMPGRP(I), RP1(I), RPN(I), BCDTMP(I) + INAMES(I,:) = TNAMES(:) + RP1(I) = MAX ( 0. , MIN ( 1. , RP1(I) ) ) + RPN(I) = MAX ( RP1(I) , MIN ( 1. , RPN(I) ) ) + END DO + ! + ! 3.a.4 Sort wave grids + ! + RNKTMP = MINVAL ( TMPRNK(NRGRD+1:2*NRGRD) ) + I = 0 + ! + DO + DO J=NRGRD+1, 2*NRGRD + IF ( TMPRNK(J) .EQ. RNKTMP ) THEN + I = I + 1 + CALL W3SETI ( I, MDSE, MDST ) + INFLAGS1 = .FALSE. #ifdef W3_MGW - INFLAGS1(10) = .TRUE. + INFLAGS1(10) = .TRUE. #endif #ifdef W3_MGP - INFLAGS1(10) = .TRUE. -#endif - INAMES(I,:)= INAMES(J,:) - MNAMES(I) = MNAMES(J) - TMPRNK(I) = TMPRNK(J) - TMPGRP(I) = TMPGRP(J) - RP1(I) = RP1(J) - RPN(I) = RPN(J) - BCDUMP(I) = BCDTMP(J) + INFLAGS1(10) = .TRUE. +#endif + INAMES(I,:)= INAMES(J,:) + MNAMES(I) = MNAMES(J) + TMPRNK(I) = TMPRNK(J) + TMPGRP(I) = TMPGRP(J) + RP1(I) = RP1(J) + RPN(I) = RPN(J) + BCDUMP(I) = BCDTMP(J) #ifdef W3_T - WRITE (MDST,9031) I, MNAMES(I), INFLAGS1, TMPRNK(I), & - TMPGRP(I), RP1(I), RPN(I) + WRITE (MDST,9031) I, MNAMES(I), INFLAGS1, TMPRNK(I), & + TMPGRP(I), RP1(I), RPN(I) #endif + END IF + END DO + IF ( I .EQ. NRGRD ) EXIT + RNKTMP = RNKTMP + 1 + END DO + ! + ! 3.a.5 Set input flags + ! + ALLOCATE ( INPMAP(NRGRD,JFIRST:10), IDINP(-NRINP:NRGRD,JFIRST:10) ) + INPMAP = 0 + IDINP = '---' + ! + DO I=1, NRGRD + CALL W3SETI ( I, MDSE, MDST ) + DO J=JFIRST, 9 + IF ( INAMES(I,J) .EQ. 'native' ) THEN + ! *** forcing input from file & defined on the native grid *** + INFLAGS1(J) = .TRUE. + ELSE + INFLAGS1(J) = .FALSE. + IF ( INAMES(I,J)(1:4) .EQ. 'CPL:' ) THEN + IF ( INAMES(I,J)(5:) .EQ. 'native' ) THEN + ! *** forcing input from CPL & defined on the native grid *** + INFLAGS1(J) = .TRUE. + INPMAP(I,J) = -999 + ELSE + ! *** forcing input from CPL & defined on an input grid *** + DO JJ=1, NRINP + IF ( MNAMES(-JJ) .EQ. INAMES(I,J)(5:) ) THEN + INPMAP(I,J) = -JJ + EXIT + END IF + END DO + IF ( INPMAP(I,J) .EQ. 0 ) GOTO 2030 + IF ( .NOT. INPUTS(INPMAP(I,J))%INFLAGS1(J) ) GOTO 2031 + USEINP(-INPMAP(I,J)) = .TRUE. + CPLINP(-INPMAP(I,J)) = .TRUE. END IF - END DO - IF ( I .EQ. NRGRD ) EXIT - RNKTMP = RNKTMP + 1 - END DO -! -! 3.a.5 Set input flags -! - ALLOCATE ( INPMAP(NRGRD,JFIRST:10), IDINP(-NRINP:NRGRD,JFIRST:10) ) - INPMAP = 0 - IDINP = '---' -! - DO I=1, NRGRD - CALL W3SETI ( I, MDSE, MDST ) - DO J=JFIRST, 9 - IF ( INAMES(I,J) .EQ. 'native' ) THEN - ! *** forcing input from file & defined on the native grid *** - INFLAGS1(J) = .TRUE. - ELSE - INFLAGS1(J) = .FALSE. - IF ( INAMES(I,J)(1:4) .EQ. 'CPL:' ) THEN - IF ( INAMES(I,J)(5:) .EQ. 'native' ) THEN - ! *** forcing input from CPL & defined on the native grid *** - INFLAGS1(J) = .TRUE. - INPMAP(I,J) = -999 - ELSE - ! *** forcing input from CPL & defined on an input grid *** - DO JJ=1, NRINP - IF ( MNAMES(-JJ) .EQ. INAMES(I,J)(5:) ) THEN - INPMAP(I,J) = -JJ - EXIT - END IF - END DO - IF ( INPMAP(I,J) .EQ. 0 ) GOTO 2030 - IF ( .NOT. INPUTS(INPMAP(I,J))%INFLAGS1(J) ) GOTO 2031 - USEINP(-INPMAP(I,J)) = .TRUE. - CPLINP(-INPMAP(I,J)) = .TRUE. - END IF - ELSE IF ( INAMES(I,J) .NE. 'no' ) THEN - ! *** forcing input from file & defined on an input grid *** - DO JJ=1, NRINP - IF ( MNAMES(-JJ) .EQ. INAMES(I,J) ) THEN - INPMAP(I,J) = JJ - INFLAGS2(J) = .TRUE. - EXIT - END IF - END DO - IF ( INPMAP(I,J) .EQ. 0 ) GOTO 2030 - IF ( .NOT. INPUTS(-INPMAP(I,J))%INFLAGS1(J) ) GOTO 2031 - USEINP(INPMAP(I,J)) = .TRUE. - END IF + ELSE IF ( INAMES(I,J) .NE. 'no' ) THEN + ! *** forcing input from file & defined on an input grid *** + DO JJ=1, NRINP + IF ( MNAMES(-JJ) .EQ. INAMES(I,J) ) THEN + INPMAP(I,J) = JJ + INFLAGS2(J) = .TRUE. + EXIT END IF -! INFLAGS2 is initial value of INFLAGS1. Unlike INFLAGS1, -! it does not change during the simulation - IF(.NOT. INFLAGS2(J)) INFLAGS2(J)=INFLAGS1(J) - END DO ! DO J=JFIRST, 9 - END DO ! DO I=1, NRGRD -! - DO I=1, NRINP - IF ( .NOT.USEINP(I) .AND. & - MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - II = LEN_TRIM(MNAMES(-I)) - WRITE (MDSE,1032) MNAMES(-I)(1:II) + END DO + IF ( INPMAP(I,J) .EQ. 0 ) GOTO 2030 + IF ( .NOT. INPUTS(-INPMAP(I,J))%INFLAGS1(J) ) GOTO 2031 + USEINP(INPMAP(I,J)) = .TRUE. END IF - END DO -! -! 3.b Assign input file unit numbers -! - DO I=-NRINP, NRGRD - IF ( I .EQ. 0 ) CYCLE - CALL W3SETI ( I, MDSE, MDST ) - DO J=JFIRST, 9 - IF ( I .GE. 1 ) THEN - IF ( INPMAP(I,J) .LT. 0 ) CYCLE - END IF - IF ( INFLAGS1(J) ) THEN - CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) - CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & - DESC='Input data file' ) - MDSF(I,J) = NDSFND - END IF - END DO - END DO -! + END IF + ! INFLAGS2 is initial value of INFLAGS1. Unlike INFLAGS1, + ! it does not change during the simulation + IF(.NOT. INFLAGS2(J)) INFLAGS2(J)=INFLAGS1(J) + END DO ! DO J=JFIRST, 9 + END DO ! DO I=1, NRGRD + ! + DO I=1, NRINP + IF ( .NOT.USEINP(I) .AND. & + MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + II = LEN_TRIM(MNAMES(-I)) + WRITE (MDSE,1032) MNAMES(-I)(1:II) + END IF + END DO + ! + ! 3.b Assign input file unit numbers + ! + DO I=-NRINP, NRGRD + IF ( I .EQ. 0 ) CYCLE + CALL W3SETI ( I, MDSE, MDST ) + DO J=JFIRST, 9 + IF ( I .GE. 1 ) THEN + IF ( INPMAP(I,J) .LT. 0 ) CYCLE + END IF + IF ( INFLAGS1(J) ) THEN + CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) + CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & + DESC='Input data file' ) + MDSF(I,J) = NDSFND + END IF + END DO + END DO + ! #ifdef W3_T - WRITE (MDST,9022) - DO I=-NRINP, NRGRD - IF ( I .EQ. 0 ) CYCLE - WRITE (MDST,9021) I, MDSF(I,JFIRST:9) - END DO -#endif -! -! 3.c Set rank and group data -! + WRITE (MDST,9022) + DO I=-NRINP, NRGRD + IF ( I .EQ. 0 ) CYCLE + WRITE (MDST,9021) I, MDSF(I,JFIRST:9) + END DO +#endif + ! + ! 3.c Set rank and group data + ! #ifdef W3_T - WRITE (MDST,9032) -#endif -! - RNKMAX = MAXVAL ( TMPRNK(1:NRGRD) ) + 1 - RNKTMP = 0 -! + WRITE (MDST,9032) +#endif + ! + RNKMAX = MAXVAL ( TMPRNK(1:NRGRD) ) + 1 + RNKTMP = 0 + ! + DO + RNKMIN = MINVAL ( TMPRNK(1:NRGRD) ) + IF ( RNKMIN .EQ. RNKMAX ) EXIT + RNKTMP = RNKTMP + 1 + DO I=1, NRGRD + IF ( TMPRNK(I) .EQ. RNKMIN ) THEN + GRANK(I) = RNKTMP + TMPRNK(I) = RNKMAX + END IF + END DO + END DO + ! +#ifdef W3_T + DO I=1, NRGRD + WRITE (MDST,9033) I, MNAMES(I), GRANK(I) + END DO +#endif + ! + RNKMAX = RNKTMP + GRPMAX = MAXVAL ( TMPGRP(1:NRGRD) ) + 1 + NRGRP = 0 + NINGRP = 0 + ! + DO RNKTMP=1, RNKMAX DO - RNKMIN = MINVAL ( TMPRNK(1:NRGRD) ) - IF ( RNKMIN .EQ. RNKMAX ) EXIT - RNKTMP = RNKTMP + 1 + GRPMIN = GRPMAX DO I=1, NRGRD - IF ( TMPRNK(I) .EQ. RNKMIN ) THEN - GRANK(I) = RNKTMP - TMPRNK(I) = RNKMAX - END IF - END DO - END DO -! -#ifdef W3_T - DO I=1, NRGRD - WRITE (MDST,9033) I, MNAMES(I), GRANK(I) + IF ( GRANK(I) .EQ. RNKTMP ) & + GRPMIN = MIN ( GRPMIN , TMPGRP(I) ) END DO -#endif -! - RNKMAX = RNKTMP - GRPMAX = MAXVAL ( TMPGRP(1:NRGRD) ) + 1 - NRGRP = 0 - NINGRP = 0 -! - DO RNKTMP=1, RNKMAX - DO - GRPMIN = GRPMAX - DO I=1, NRGRD - IF ( GRANK(I) .EQ. RNKTMP ) & - GRPMIN = MIN ( GRPMIN , TMPGRP(I) ) - END DO - IF ( GRPMIN .EQ. GRPMAX ) EXIT - NRGRP = NRGRP + 1 - DO I=1, NRGRD - IF ( GRANK(I).EQ.RNKTMP .AND. GRPMIN.EQ.TMPGRP(I) ) THEN - GRGRP(I) = NRGRP - TMPGRP(I) = GRPMAX - NINGRP(NRGRP) = NINGRP(NRGRP) + 1 - END IF - END DO - END DO + IF ( GRPMIN .EQ. GRPMAX ) EXIT + NRGRP = NRGRP + 1 + DO I=1, NRGRD + IF ( GRANK(I).EQ.RNKTMP .AND. GRPMIN.EQ.TMPGRP(I) ) THEN + GRGRP(I) = NRGRP + TMPGRP(I) = GRPMAX + NINGRP(NRGRP) = NINGRP(NRGRP) + 1 + END IF END DO -! + END DO + END DO + ! #ifdef W3_T - WRITE (MDST,9034) NRGRP - DO I=1, NRGRD - WRITE (MDST,9033) I, MNAMES(I), GRGRP(I) - END DO - WRITE (MDST,9035) NINGRP(1:NRGRP) -#endif -! - ALLOCATE ( INGRP(NRGRP,0:MAXVAL(NINGRP(:NRGRP))) ) - DEALLOCATE ( TMPRNK, TMPGRP, NINGRP, BCDTMP ) - INGRP = 0 -! - DO I=1, NRGRD - INGRP(GRGRP(I),0) = INGRP(GRGRP(I),0) + 1 - INGRP(GRGRP(I),INGRP(GRGRP(I),0)) = I - END DO -! + WRITE (MDST,9034) NRGRP + DO I=1, NRGRD + WRITE (MDST,9033) I, MNAMES(I), GRGRP(I) + END DO + WRITE (MDST,9035) NINGRP(1:NRGRP) +#endif + ! + ALLOCATE ( INGRP(NRGRP,0:MAXVAL(NINGRP(:NRGRP))) ) + DEALLOCATE ( TMPRNK, TMPGRP, NINGRP, BCDTMP ) + INGRP = 0 + ! + DO I=1, NRGRD + INGRP(GRGRP(I),0) = INGRP(GRGRP(I),0) + 1 + INGRP(GRGRP(I),INGRP(GRGRP(I),0)) = I + END DO + ! #ifdef W3_T - WRITE (MDST,9036) - DO J=1, NRGRP - WRITE (MDST,9037) J, INGRP(J,:INGRP(J,0)) - END DO -#endif -! -! -! 3.d Unified point output -! + WRITE (MDST,9036) + DO J=1, NRGRP + WRITE (MDST,9037) J, INGRP(J,:INGRP(J,0)) + END DO +#endif + ! + ! + ! 3.d Unified point output + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.b' - PRFT0 = PRFTN -#endif -! - IF ( UNIPTS ) THEN -! - J = LEN_TRIM(MNAMES(0)) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,986) MNAMES(0)(1:J) - WRITE (MDSS,987) - END IF -! - CALL W3IOGR ( 'GRID', NDSREC, 0, MNAMES(0)(1:J) ) -! - END IF -! -! 3.e Output -! - IF ( NRINP .GT. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,924) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,924) - DO I=1, NRINP - IF ( .NOT. USEINP(I) ) CYCLE - CALL W3SETI ( -I, MDSE, MDST ) - ACTION(1:6) = '--- ' - DO J=JFIRST, 6 - IF ( INFLAGS1(J) ) ACTION(J) = ' X ' - END DO - ACTION(7:9) = '- ' - IF ( INFLAGS1(7) ) ACTION(7) = '1 ' - IF ( INFLAGS1(8) ) ACTION(8) = '2 ' - IF ( INFLAGS1(9) ) ACTION(9) = '3 ' - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,925) I, MNAMES(-I), ACTION(JFIRST:9) - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,925) I, MNAMES(-I), ACTION(JFIRST:9) - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,926) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,926) - END IF -! - IF ( UNIPTS ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,927) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,927) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,928) MNAMES(0) - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,928) MNAMES(0) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,929) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,929) - END IF -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,930) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,930) - DO I=1, NRGRD - CALL W3SETI ( I, MDSE, MDST ) + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.b' + PRFT0 = PRFTN +#endif + ! + IF ( UNIPTS ) THEN + ! + J = LEN_TRIM(MNAMES(0)) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,986) MNAMES(0)(1:J) + WRITE (MDSS,987) + END IF + ! + CALL W3IOGR ( 'GRID', NDSREC, 0, MNAMES(0)(1:J) ) + ! + END IF + ! + ! 3.e Output + ! + IF ( NRINP .GT. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,924) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,924) + DO I=1, NRINP + IF ( .NOT. USEINP(I) ) CYCLE + CALL W3SETI ( -I, MDSE, MDST ) ACTION(1:6) = '--- ' DO J=JFIRST, 6 - IF ( INFLAGS1(J) .AND. INPMAP(I,J) .EQ. 0 ) THEN - ACTION(J) = 'native' - ELSE IF ( INFLAGS1(J) .AND. INPMAP(I,J) .EQ. -999 ) THEN - ACTION(J) = 'native' - ELSE IF ( INPMAP(I,J) .GT. 0 ) THEN - ACTION(J) = MNAMES(-INPMAP(I,J)) - ELSE IF ( INPMAP(I,J) .LT. 0 ) THEN - ACTION(J) = MNAMES( INPMAP(I,J)) - END IF - END DO - ACTION(7:11) = '- ' + IF ( INFLAGS1(J) ) ACTION(J) = ' X ' + END DO + ACTION(7:9) = '- ' IF ( INFLAGS1(7) ) ACTION(7) = '1 ' IF ( INFLAGS1(8) ) ACTION(8) = '2 ' IF ( INFLAGS1(9) ) ACTION(9) = '3 ' - IF ( INFLAGS1(10) ) THEN - ACTION(10) = 'yes ' - ELSE - ACTION(10) = 'no ' - END IF - IF ( BCDUMP(I) ) ACTION(11) = 'y ' - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,931) I, MNAMES(I), ACTION(1:10), GRANK(I), & - GRGRP(I), ACTION(11) - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,931) I, MNAMES(I), ACTION(1:10), GRANK(I), & - GRGRP(I), ACTION(11) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,925) I, MNAMES(-I), ACTION(JFIRST:9) + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,925) I, MNAMES(-I), ACTION(JFIRST:9) END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,932) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,932) -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,933) 'Group information' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,933) 'Group information' - DO J=1, NRGRP - WRITE (LINE(1:6),'(1X,I3,2X)') J - JJJ = 6 - DO JJ=1, INGRP(J,0) - IF ( JJJ .GT. 60 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,934) LINE(1:JJJ) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,934) LINE(1:JJJ) - LINE(1:6) = ' ' - JJJ = 6 - END IF - WRITE (LINE(JJJ+1:JJJ+3),'(I3)') INGRP(J,JJ) -! - LINE(JJJ+4:JJJ+5) = ' (' - WRITE (LINE(JJJ+6:JJJ+11),'(F6.4)') RP1(INGRP(J,JJ)) - LINE(JJJ+12:JJJ+12) = '-' - WRITE (LINE(JJJ+13:JJJ+18),'(F6.4)') RPN(INGRP(J,JJ)) - LINE(JJJ+19:JJJ+19) = ')' - JJJ = JJJ + 19 -! - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,934) LINE(1:JJJ) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,934) LINE(1:JJJ) - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) -! -! 4. Model run time information etc. -------------------------------- / -! -! Version 3.07: Same for all grids, diversify later .... -! If invoked as ESMF Component, then STIME and ETIME are set -! in WMESMFMD from the external clock. -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,940) -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - IF (IS_ESMF_COMPONENT) THEN - READ (MDSI,*,END=2001,ERR=2002) STMPT, ETMPT - ELSE - READ (MDSI,*,END=2001,ERR=2002) STIME, ETIME + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,926) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,926) + END IF + ! + IF ( UNIPTS ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,927) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,927) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,928) MNAMES(0) + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,928) MNAMES(0) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,929) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,929) + END IF + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,930) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,930) + DO I=1, NRGRD + CALL W3SETI ( I, MDSE, MDST ) + ACTION(1:6) = '--- ' + DO J=JFIRST, 6 + IF ( INFLAGS1(J) .AND. INPMAP(I,J) .EQ. 0 ) THEN + ACTION(J) = 'native' + ELSE IF ( INFLAGS1(J) .AND. INPMAP(I,J) .EQ. -999 ) THEN + ACTION(J) = 'native' + ELSE IF ( INPMAP(I,J) .GT. 0 ) THEN + ACTION(J) = MNAMES(-INPMAP(I,J)) + ELSE IF ( INPMAP(I,J) .LT. 0 ) THEN + ACTION(J) = MNAMES( INPMAP(I,J)) END IF -! - CALL STME21 ( STIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,941) DTME21 - CALL STME21 ( ETIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,942) DTME21 -! - DO I=1, NRGRD - CALL W3SETW ( I, MDSE, MDST ) - TIME = STIME - END DO -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,943) -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - READ (MDSI,*,END=2001,ERR=2002) FLGHG1, FLGHG2 - FLGHG2 = FLGHG1 .AND. FLGHG2 -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - IF ( FLGHG1 ) THEN - WRITE (MDSS,944) YESXX - ELSE - WRITE (MDSS,944) XXXNO - END IF - IF ( FLGHG2 ) THEN - WRITE (MDSS,945) YESXX - ELSE - WRITE (MDSS,945) XXXNO - END IF + END DO + ACTION(7:11) = '- ' + IF ( INFLAGS1(7) ) ACTION(7) = '1 ' + IF ( INFLAGS1(8) ) ACTION(8) = '2 ' + IF ( INFLAGS1(9) ) ACTION(9) = '3 ' + IF ( INFLAGS1(10) ) THEN + ACTION(10) = 'yes ' + ELSE + ACTION(10) = 'no ' + END IF + IF ( BCDUMP(I) ) ACTION(11) = 'y ' + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,931) I, MNAMES(I), ACTION(1:10), GRANK(I), & + GRGRP(I), ACTION(11) + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,931) I, MNAMES(I), ACTION(1:10), GRANK(I), & + GRGRP(I), ACTION(11) + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,932) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,932) + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,933) 'Group information' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,933) 'Group information' + DO J=1, NRGRP + WRITE (LINE(1:6),'(1X,I3,2X)') J + JJJ = 6 + DO JJ=1, INGRP(J,0) + IF ( JJJ .GT. 60 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,934) LINE(1:JJJ) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,934) LINE(1:JJJ) + LINE(1:6) = ' ' + JJJ = 6 END IF -! -! 5. Output requests ------------------------------------------------ / -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,950) - NPTS = 0 -! -! 5.a Loop over types for unified output -! - NOTYPE = 6 - DO J=1, NOTYPE -! -! 5.b Process standard line -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) -! - IF(J .LE. 2) THEN - WORDS(1:6)='' - READ (MDSI,'(A)') LINEIN - READ(LINEIN,*,iostat=ierr) WORDS -! - IF(J .LE. 1) THEN - READ(WORDS( 1 ), * ) ODAT(1,1) - READ(WORDS( 2 ), * ) ODAT(2,1) - READ(WORDS( 3 ), * ) ODAT(3,1) - READ(WORDS( 4 ), * ) ODAT(4,1) - READ(WORDS( 5 ), * ) ODAT(5,1) - ELSE - READ(WORDS( 1 ), * ) ODAT(6,1) - READ(WORDS( 2 ), * ) ODAT(7,1) - READ(WORDS( 3 ), * ) ODAT(8,1) - READ(WORDS( 4 ), * ) ODAT(9,1) - READ(WORDS( 5 ), * ) ODAT(10,1) - END IF - - IF (WORDS(6) .NE. '0' .AND. WORDS(6) .NE. '1') THEN - OUTFF(J,1)=0 - ELSE - READ(WORDS( 6 ), * ) OUTFF(J,1) -! print*,' Number of data: ', 6 - END IF -! CHECKPOINT - ELSE IF(J .EQ. 4) THEN - WORDS(1:6)='' - READ (MDSI,'(A)') LINEIN - READ(LINEIN,*,iostat=ierr) WORDS -! - READ(WORDS( 1 ), * ) ODAT(16,1) - READ(WORDS( 2 ), * ) ODAT(17,1) - READ(WORDS( 3 ), * ) ODAT(18,1) - READ(WORDS( 4 ), * ) ODAT(19,1) - READ(WORDS( 5 ), * ) ODAT(20,1) - IF (WORDS(6) .EQ. 'T') THEN - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - READ (MDSI,*,END=2001,ERR=2002)(ODAT(I,1),I=5*(8-1)+1,5*8) - END IF + WRITE (LINE(JJJ+1:JJJ+3),'(I3)') INGRP(J,JJ) + ! + LINE(JJJ+4:JJJ+5) = ' (' + WRITE (LINE(JJJ+6:JJJ+11),'(F6.4)') RP1(INGRP(J,JJ)) + LINE(JJJ+12:JJJ+12) = '-' + WRITE (LINE(JJJ+13:JJJ+18),'(F6.4)') RPN(INGRP(J,JJ)) + LINE(JJJ+19:JJJ+19) = ')' + JJJ = JJJ + 19 + ! + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,934) LINE(1:JJJ) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,934) LINE(1:JJJ) + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + ! + ! 4. Model run time information etc. -------------------------------- / + ! + ! Version 3.07: Same for all grids, diversify later .... + ! If invoked as ESMF Component, then STIME and ETIME are set + ! in WMESMFMD from the external clock. + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,940) + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + IF (IS_ESMF_COMPONENT) THEN + READ (MDSI,*,END=2001,ERR=2002) STMPT, ETMPT + ELSE + READ (MDSI,*,END=2001,ERR=2002) STIME, ETIME + END IF + ! + CALL STME21 ( STIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,941) DTME21 + CALL STME21 ( ETIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,942) DTME21 + ! + DO I=1, NRGRD + CALL W3SETW ( I, MDSE, MDST ) + TIME = STIME + END DO + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,943) + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + READ (MDSI,*,END=2001,ERR=2002) FLGHG1, FLGHG2 + FLGHG2 = FLGHG1 .AND. FLGHG2 + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + IF ( FLGHG1 ) THEN + WRITE (MDSS,944) YESXX + ELSE + WRITE (MDSS,944) XXXNO + END IF + IF ( FLGHG2 ) THEN + WRITE (MDSS,945) YESXX + ELSE + WRITE (MDSS,945) XXXNO + END IF + END IF + ! + ! 5. Output requests ------------------------------------------------ / + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,950) + NPTS = 0 + ! + ! 5.a Loop over types for unified output + ! + NOTYPE = 6 + DO J=1, NOTYPE + ! + ! 5.b Process standard line + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + ! + IF(J .LE. 2) THEN + WORDS(1:6)='' + READ (MDSI,'(A)') LINEIN + READ(LINEIN,*,iostat=ierr) WORDS + ! + IF(J .LE. 1) THEN + READ(WORDS( 1 ), * ) ODAT(1,1) + READ(WORDS( 2 ), * ) ODAT(2,1) + READ(WORDS( 3 ), * ) ODAT(3,1) + READ(WORDS( 4 ), * ) ODAT(4,1) + READ(WORDS( 5 ), * ) ODAT(5,1) ELSE - READ (MDSI,*,END=2001,ERR=2002)(ODAT(I,1),I=5*(J-1)+1,5*J) - OUTFF(J,1) = 0 + READ(WORDS( 1 ), * ) ODAT(6,1) + READ(WORDS( 2 ), * ) ODAT(7,1) + READ(WORDS( 3 ), * ) ODAT(8,1) + READ(WORDS( 4 ), * ) ODAT(9,1) + READ(WORDS( 5 ), * ) ODAT(10,1) END IF -! - OUTPTS(1)%OFILES(J)=OUTFF(J,1) -! -! - ODAT(5*(J-1)+3,1) = MAX ( 0 , ODAT(5*(J-1)+3,1) ) -! - IF ( ODAT(5*(J-1)+3,1) .NE. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,951) J, IDOTYP(J) - TTIME(1) = ODAT(5*(J-1)+1,1) - TTIME(2) = ODAT(5*(J-1)+2,1) - CALL STME21 ( TTIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,952) DTME21 - TTIME(1) = ODAT(5*(J-1)+4,1) - TTIME(2) = ODAT(5*(J-1)+5,1) - CALL STME21 ( TTIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,953) DTME21 - TTIME(1) = 0 - TTIME(2) = 0 - DTTST = REAL ( ODAT(5*(J-1)+3,1) ) - CALL TICK21 ( TTIME , DTTST ) - CALL STME21 ( TTIME , DTME21 ) - IF ( ( ODAT(5*(J-1)+1,1) .NE. ODAT(5*(J-1)+4,1) .OR. & - ODAT(5*(J-1)+2,1) .NE. ODAT(5*(J-1)+5,1) ) .AND. & - MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - DO I=1, 18 - IF ( DTME21(I:I).NE.'0' .AND. & - DTME21(I:I).NE.'/' .AND. & - DTME21(I:I).NE.' ' .AND. & - DTME21(I:I).NE.':' ) EXIT - DTME21(I:I) = ' ' - END DO - WRITE (MDSS,954) DTME21(1:19) - END IF - IF ( J .EQ. 1 ) THEN -! -! 5.c Type 1: fields of mean wave parameters -! - FLGRD(:,:,:)=.FALSE. ! Initialize FLGRD - CALL W3READFLGRD ( MDSI, MDSS, MDSO, MDSE2, COMSTR, FLG1D, & - FLG2D, IMPROC, NMPSCR, IERR ) - FLGRD(:,:,1)=FLG2D - FLGD(:,1) =FLG1D -! - ELSE IF ( J .EQ. 2 ) THEN -! -! 5.d Type 2: point output -! - DO ILOOP=1, 2 - IF ( ILOOP .EQ. 1 ) THEN - MDSI2 = MDSI - IF ( IMPROC .EQ. 1 ) OPEN & - (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') - ELSE - MDSI2 = SCRATCH -#ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) -#endif - OPEN & - (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') - REWIND (SCRATCH) - IF (NPTS.GT.0) THEN - ALLOCATE ( X(NPTS), Y(NPTS), PNAMES(NPTS) ) - ELSE - GOTO 2054 - END IF - END IF -! - NPTS = 0 - DO - CALL NEXTLN ( COMSTR , MDSI2 , MDSE2 ) - READ (MDSI2,*,END=2001,ERR=2002) XX, YY, PN -! - IF ( ILOOP.EQ.1 .AND. IMPROC.EQ.1 ) THEN - BACKSPACE (MDSI) - READ (MDSI,'(A)') LINE - WRITE (SCRATCH,'(A)') LINE - END IF -! - IF ( PN .EQ. 'STOPSTRING' ) EXIT -! - NPTS = NPTS + 1 - IF ( ILOOP .EQ. 1 ) CYCLE -! - X(NPTS) = XX - Y(NPTS) = YY - PNAMES(NPTS) = PN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - IF ( NPTS .EQ. 1 ) THEN - WRITE (MDSS,957) XX, YY, PN - ELSE - WRITE (MDSS,958) NPTS, XX, YY, PN - END IF - END IF -! - END DO -! - IF ( IMPROC.EQ.1 .AND. ILOOP.EQ.1 ) CLOSE (SCRATCH) - END DO -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC .AND. & - NPTS.EQ.0 ) WRITE (MDSS,959) - IF ( IMPROC .EQ. 1 ) THEN -#ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) -#endif - CLOSE (SCRATCH,STATUS='DELETE') - ELSE - CLOSE (SCRATCH) -#ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) -#endif - END IF -! - ELSE IF ( J .EQ. 3 ) THEN -! -! 5.e Type 3: track output -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - READ (MDSI,*,END=2001,ERR=2002) TFLAGI - IF ( .NOT. TFLAGI ) MDS(11,:) = -MDS(11,:) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - IF ( .NOT. TFLAGI ) THEN - WRITE (MDSS,960) 'input', 'UNFORMATTED' - ELSE - WRITE (MDSS,960) 'input', 'FORMATTED' - END IF - END IF -! - ELSE IF ( J .EQ. 4 ) THEN -! -! 5.f Type 4: restart files (no additional data) -! - ELSE IF ( J .EQ. 5 ) THEN -! -! 5.g Type 5: nesting data (no additional data) -! - ELSE IF ( J .EQ. 6 ) THEN -! -! 5.h Type 6: partitioned wave field data -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - READ (MDSI,*,END=2001,ERR=2002) IPRT(:,1), LPRT(1) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,961) IPRT(:,1) - IF ( .NOT. LPRT(1) ) THEN - WRITE (MDSS,960) 'output', 'UNFORMATTED' - ELSE - WRITE (MDSS,960) 'output', 'FORMATTED' - END IF - END IF -! -! ... End of output type selecttion ELSE IF -! - END IF -! -! ... End of IF in 5.b -! - END IF -! -! ... End of loop in 5.a -! - END DO -!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -! Checkpoint - J=8 - IF ( ODAT(5*(J-1)+3,1) .NE. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,951) J, IDOTYP(J) - TTIME(1) = ODAT(5*(J-1)+1,1) - TTIME(2) = ODAT(5*(J-1)+2,1) - CALL STME21 ( TTIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,952) DTME21 - TTIME(1) = ODAT(5*(J-1)+4,1) - TTIME(2) = ODAT(5*(J-1)+5,1) - CALL STME21 ( TTIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,953) DTME21 - TTIME(1) = 0 - TTIME(2) = 0 - DTTST = REAL ( ODAT(5*(J-1)+3,1) ) - CALL TICK21 ( TTIME , DTTST ) - CALL STME21 ( TTIME , DTME21 ) - IF ( ( ODAT(5*(J-1)+1,1) .NE. ODAT(5*(J-1)+4,1) .OR. & - ODAT(5*(J-1)+2,1) .NE. ODAT(5*(J-1)+5,1) ) .AND. & - MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - DO I=1, 18 - IF ( DTME21(I:I).NE.'0' .AND. & - DTME21(I:I).NE.'/' .AND. & - DTME21(I:I).NE.' ' .AND. & - DTME21(I:I).NE.':' ) EXIT - DTME21(I:I) = ' ' - END DO - WRITE (MDSS,954) DTME21(1:19) - END IF - END IF -!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -! -! 5.i Set all grids to unified output -! - IF ( UNIPTS ) THEN - ODAT(6:10,0) = ODAT(6:10,1) - ODAT( 8 , 1) = 0 - OUTPTS(1)%OFILES(1) = OUTFF(1,1) - END IF -! - DO I=2, NRGRD - ODAT(:,I) = ODAT(:,1) - OUTFF(:,I) = OUTFF(:,1) - OUTPTS(I)%OFILES(:)=OUTFF(:,1) - FLGD(:,I) = FLGD(:,1) - FLGRD(:,:,I) = FLGRD(:,:,1) - FLG2(:,I) = FLG2(:,1) - FLGR2(:,:,I) = FLGR2(:,:,1) - IPRT(:,I) = IPRT(:,1) - LPRT(I) = LPRT(1) - END DO -! - IF ( NPTS.EQ.0 .OR. ODAT(8,0).EQ.0 ) UNIPTS = .FALSE. - IF ( UNIPTS ) THEN - IF ( ( NPTS.EQ.0 .OR. ODAT(8,0).EQ.0 ) .AND. & - IMPROC.EQ.NMPERR ) WRITE (MDSE,1050) - IF ( NPTS.EQ.0 .OR. ODAT(8,0).EQ.0 ) UNIPTS = .FALSE. - OT2(0)%NPTS = NPTS - ALLOCATE (OT2(0)%X(NPTS),OT2(0)%Y(NPTS),OT2(0)%PNAMES(NPTS)) - OT2(0)%X = X - OT2(0)%Y = Y - OT2(0)%PNAMES = PNAMES - DO I=1, NRGRD - OT2(I)%NPTS = 0 - ALLOCATE (OT2(I)%X(1),OT2(I)%Y(1),OT2(I)%PNAMES(1)) - END DO + IF (WORDS(6) .NE. '0' .AND. WORDS(6) .NE. '1') THEN + OUTFF(J,1)=0 ELSE - DO I=1, NRGRD - OT2(I)%NPTS = NPTS - IF ( NPTS .EQ. 0 ) THEN - ALLOCATE (OT2(I)%X(1),OT2(I)%Y(1),OT2(I)%PNAMES(1)) - ELSE - ALLOCATE (OT2(I)%X(NPTS),OT2(I)%Y(NPTS), & - OT2(I)%PNAMES(NPTS)) - OT2(I)%X = X - OT2(I)%Y = Y - OT2(I)%PNAMES = PNAMES - END IF - END DO + READ(WORDS( 6 ), * ) OUTFF(J,1) + ! print*,' Number of data: ', 6 END IF -! -! 5.j Endless loop for correcting output per grid -! - DO - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - READ (MDSI,*,END=2001,ERR=2002) MN, J -! -! 5.j.1 Bail out loop for output type 0 -! - IF ( J .EQ. 0 ) EXIT -! -! 5.j.2 Find the grid number -! - II = LEN_TRIM(MN) - DO I=1, NRGRD - IF ( MN(:II) .EQ. MNAMES(I)(1:II) ) EXIT + ! CHECKPOINT + ELSE IF(J .EQ. 4) THEN + WORDS(1:6)='' + READ (MDSI,'(A)') LINEIN + READ(LINEIN,*,iostat=ierr) WORDS + ! + READ(WORDS( 1 ), * ) ODAT(16,1) + READ(WORDS( 2 ), * ) ODAT(17,1) + READ(WORDS( 3 ), * ) ODAT(18,1) + READ(WORDS( 4 ), * ) ODAT(19,1) + READ(WORDS( 5 ), * ) ODAT(20,1) + IF (WORDS(6) .EQ. 'T') THEN + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + READ (MDSI,*,END=2001,ERR=2002)(ODAT(I,1),I=5*(8-1)+1,5*8) + END IF + ELSE + READ (MDSI,*,END=2001,ERR=2002)(ODAT(I,1),I=5*(J-1)+1,5*J) + OUTFF(J,1) = 0 + END IF + ! + OUTPTS(1)%OFILES(J)=OUTFF(J,1) + ! + ! + ODAT(5*(J-1)+3,1) = MAX ( 0 , ODAT(5*(J-1)+3,1) ) + ! + IF ( ODAT(5*(J-1)+3,1) .NE. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,951) J, IDOTYP(J) + TTIME(1) = ODAT(5*(J-1)+1,1) + TTIME(2) = ODAT(5*(J-1)+2,1) + CALL STME21 ( TTIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,952) DTME21 + TTIME(1) = ODAT(5*(J-1)+4,1) + TTIME(2) = ODAT(5*(J-1)+5,1) + CALL STME21 ( TTIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,953) DTME21 + TTIME(1) = 0 + TTIME(2) = 0 + DTTST = REAL ( ODAT(5*(J-1)+3,1) ) + CALL TICK21 ( TTIME , DTTST ) + CALL STME21 ( TTIME , DTME21 ) + IF ( ( ODAT(5*(J-1)+1,1) .NE. ODAT(5*(J-1)+4,1) .OR. & + ODAT(5*(J-1)+2,1) .NE. ODAT(5*(J-1)+5,1) ) .AND. & + MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + DO I=1, 18 + IF ( DTME21(I:I).NE.'0' .AND. & + DTME21(I:I).NE.'/' .AND. & + DTME21(I:I).NE.' ' .AND. & + DTME21(I:I).NE.':' ) EXIT + DTME21(I:I) = ' ' END DO -! - IF ( I .GT. NRGRD ) GOTO 2051 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,962) MN(1:II), I -! -! 5.j.3 Check the output type -! - IF ( J.LT.0 .OR. J.GT. NOTYPE ) GOTO 2052 - IF ( J.EQ.2 .AND. UNIPTS ) GOTO 2053 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,951) J, IDOTYP(J) -! -! 5.k Process standard line -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - IF(J .LE. 2) THEN - OUTFF(J,I)=0 - WORDS(1:6) ='' - READ (MDSI,'(A)') LINEIN - READ(LINEIN,*,iostat=ierr) WORDS - IF(J .EQ. 1) THEN - READ(WORDS( 1 ), * ) ODAT(1,I) - READ(WORDS( 2 ), * ) ODAT(2,I) - READ(WORDS( 3 ), * ) ODAT(3,I) - READ(WORDS( 4 ), * ) ODAT(4,I) - READ(WORDS( 5 ), * ) ODAT(5,I) - ELSE - READ(WORDS( 1 ), * ) ODAT(6,I) - READ(WORDS( 2 ), * ) ODAT(7,I) - READ(WORDS( 3 ), * ) ODAT(8,I) - READ(WORDS( 4 ), * ) ODAT(9,I) - READ(WORDS( 5 ), * ) ODAT(10,I) - END IF - IF (WORDS(6) .NE. '0' .AND. WORDS(6) .NE. '1') THEN - OUTFF(J,I)=0 - ELSE - READ(WORDS( 6 ), * ) OUTFF(J,I) - END IF -! - ELSE - READ (MDSI,*,END=2001,ERR=2002)(ODAT(II,I),II=5*(J-1)+1,5*J) - OUTFF(J,I) = 0 + WRITE (MDSS,954) DTME21(1:19) + END IF -! - OUTPTS(I)%OFILES(J)=OUTFF(J,I) -! - ODAT(5*(J-1)+3,I) = MAX ( 0 , ODAT(5*(J-1)+3,I) ) -! - IF ( ODAT(5*(J-1)+3,I) .NE. 0 ) THEN - TTIME(1) = ODAT(5*(J-1)+1,I) - TTIME(2) = ODAT(5*(J-1)+2,I) - CALL STME21 ( TTIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,952) DTME21 - TTIME(1) = ODAT(5*(J-1)+4,I) - TTIME(2) = ODAT(5*(J-1)+5,I) - CALL STME21 ( TTIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,953) DTME21 - TTIME(1) = 0 - TTIME(2) = 0 - DTTST = REAL ( ODAT(5*(J-1)+3,I) ) - CALL TICK21 ( TTIME , DTTST ) - CALL STME21 ( TTIME , DTME21 ) - IF ( ( ODAT(5*(J-1)+1,I) .NE. ODAT(5*(J-1)+4,I) .OR. & - ODAT(5*(J-1)+2,I) .NE. ODAT(5*(J-1)+5,I) ) .AND. & - MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - DO II=1, 18 - IF ( DTME21(II:II).NE.'0' .AND. & - DTME21(II:II).NE.'/' .AND. & - DTME21(II:II).NE.' ' .AND. & - DTME21(II:II).NE.':' ) EXIT - DTME21(II:II) = ' ' - END DO - WRITE (MDSS,954) DTME21(1:19) - END IF -! - IF ( J .EQ. 1 ) THEN -! -! 5.l Type 1: fields of mean wave parameters -! - CALL W3READFLGRD ( MDSI, MDSS, MDSO, MDSE2, COMSTR, & - FLG1D, FLG2D, IMPROC, NMPSCR, IERR ) - FLGD(:,I) = FLG1D - FLGRD(:,:,I) = FLG2D -! - ELSE IF ( J .EQ. 2 ) THEN -! -! 5.m Type 2: point output -! - DO ILOOP=1, 2 - IF ( ILOOP .EQ. 1 ) THEN - MDSI2 = MDSI - IF ( IMPROC .EQ. 1 ) OPEN & - (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') - ELSE - MDSI2 = SCRATCH -#ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) -#endif - OPEN & - (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') - REWIND (SCRATCH) - DEALLOCATE ( OT2(I)%X, OT2(I)%Y, OT2(I)%PNAMES ) - ALLOCATE ( OT2(I)%X(OT2(I)%NPTS), & - OT2(I)%Y(OT2(I)%NPTS), & - OT2(I)%PNAMES(OT2(I)%NPTS) ) - END IF -! - OT2(I)%NPTS = 0 - DO - CALL NEXTLN ( COMSTR , MDSI2 , MDSE2 ) - READ (MDSI2,*,END=2001,ERR=2002) XX, YY, PN -! - IF ( ILOOP.EQ.1 .AND. IMPROC.EQ.1 ) THEN - BACKSPACE (MDSI) - READ (MDSI,'(A)') LINE - WRITE (SCRATCH,'(A)') LINE - END IF -! - IF ( PN .EQ. 'STOPSTRING' ) EXIT -! - OT2(I)%NPTS = OT2(I)%NPTS + 1 - IF ( ILOOP .EQ. 1 ) CYCLE -! - OT2(I)%X(OT2(I)%NPTS) = XX - OT2(I)%Y(OT2(I)%NPTS) = YY - OT2(I)%PNAMES(OT2(I)%NPTS) = PN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - IF ( OT2(I)%NPTS .EQ. 1 ) THEN - WRITE (MDSS,957) XX, YY, PN - ELSE - WRITE (MDSS,958) OT2(I)%NPTS, XX, YY, PN - END IF - END IF -! - END DO -! - IF ( IMPROC.EQ.1 .AND. ILOOP.EQ.1 ) CLOSE (SCRATCH) - END DO -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC .AND. & - OT2(I)%NPTS.EQ.0 ) WRITE (MDSS,959) - IF ( IMPROC .EQ. 1 ) THEN -#ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) -#endif - CLOSE (SCRATCH,STATUS='DELETE') - ELSE - CLOSE (SCRATCH) -#ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) -#endif - END IF -! - ELSE IF ( J .EQ. 3 ) THEN -! -! 5.n Type 3: track output -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - READ (MDSI,*,END=2001,ERR=2002) TFLAGI - IF ( TFLAGI ) THEN - MDS(11,I) = ABS(MDS(11,I)) - ELSE - MDS(11,I) = -ABS(MDS(11,I)) - END IF - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - IF ( .NOT. TFLAGI ) THEN - WRITE (MDSS,960) 'input', 'UNFORMATTED' - ELSE - WRITE (MDSS,960) 'input', 'FORMATTED' - END IF - END IF -! - ELSE IF ( J .EQ. 6 ) THEN -! -! 5.o Type 6: partitioned wave field data -! - CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) - READ (MDSI,*,END=2001,ERR=2002) IPRT(:,I), LPRT(I) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,961) IPRT(:,I) - IF ( .NOT. LPRT(I) ) THEN - WRITE (MDSS,960) 'output', 'UNFORMATTED' - ELSE - WRITE (MDSS,960) 'output', 'FORMATTED' - END IF - END IF -! - END IF - ELSE IF ( J .EQ. 7 ) THEN -! -! 5.p Type 7: coupling fields -! - CALL W3READFLGRD ( MDSI, MDSS, MDSO, MDSE2, COMSTR, & - FLG1D, FLG2D, IMPROC, NMPSCR, IERR ) - FLG2(:,I) = FLG1D - FLGR2(:,:,I) = FLG2D -! - ELSE - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,963) - END IF -! -! ... End of loop in 5.j -! - END DO -! -#ifdef W3_T - DO I=1, NRGRD - WRITE (MDST,9050) I - WRITE (MDST,9051) ODAT(:,I) - WRITE (MDST,9051) OUTFF(:,I) - WRITE (MDST,9052) FLGRD(:,:,I) - END DO -#endif -! -! 6. Read moving grid data ------------------------------------------ / -! -! Only a single set of data are provided to be applied to all -! the grids, because this is only intended for test cases. -! For true implementations, the jumping grid will be used. -! - IF ( INFLAGS1(10) ) THEN -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,965) - WRITE (MDSS,966) 'Continuous grid movement data' - END IF -! -#ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) -#endif + IF ( J .EQ. 1 ) THEN + ! + ! 5.c Type 1: fields of mean wave parameters + ! + FLGRD(:,:,:)=.FALSE. ! Initialize FLGRD + CALL W3READFLGRD ( MDSI, MDSS, MDSO, MDSE2, COMSTR, FLG1D, & + FLG2D, IMPROC, NMPSCR, IERR ) + FLGRD(:,:,1)=FLG2D + FLGD(:,1) =FLG1D + ! + ELSE IF ( J .EQ. 2 ) THEN + ! + ! 5.d Type 2: point output + ! DO ILOOP=1, 2 IF ( ILOOP .EQ. 1 ) THEN - MDSI2 = MDSI - IF ( IMPROC .EQ. 1 ) & - OPEN (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') - ELSE - MDSI2 = SCRATCH + MDSI2 = MDSI + IF ( IMPROC .EQ. 1 ) OPEN & + (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') + ELSE + MDSI2 = SCRATCH #ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) #endif - OPEN (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') - REWIND (SCRATCH) - ALLOCATE ( TMOVE(2,NMOVE), AMOVE(NMOVE), DMOVE(NMOVE) ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,967) NMOVE, 'MOV' + OPEN & + (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') + REWIND (SCRATCH) + IF (NPTS.GT.0) THEN + ALLOCATE ( X(NPTS), Y(NPTS), PNAMES(NPTS) ) + ELSE + GOTO 2054 END IF -! - NMOVE = 0 + END IF + ! + NPTS = 0 DO CALL NEXTLN ( COMSTR , MDSI2 , MDSE2 ) - READ (MDSI2,*,END=2001,ERR=2002) IDTST -! + READ (MDSI2,*,END=2001,ERR=2002) XX, YY, PN + ! IF ( ILOOP.EQ.1 .AND. IMPROC.EQ.1 ) THEN - BACKSPACE (MDSI) - READ (MDSI,'(A)') LINE - WRITE (SCRATCH,'(A)') LINE - END IF -! - IF ( IDTST .EQ. 'STP' ) EXIT - IF ( IDTST .NE. 'MOV' ) CYCLE -! - NMOVE = NMOVE + 1 + BACKSPACE (MDSI) + READ (MDSI,'(A)') LINE + WRITE (SCRATCH,'(A)') LINE + END IF + ! + IF ( PN .EQ. 'STOPSTRING' ) EXIT + ! + NPTS = NPTS + 1 IF ( ILOOP .EQ. 1 ) CYCLE -! - BACKSPACE (MDSI2) - READ (MDSI2,*,END=2001,ERR=2002) IDTST, TTIME, XX, YY - TMOVE(:,NMOVE) = TTIME - AMOVE(NMOVE) = XX - DMOVE(NMOVE) = YY - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,968) NMOVE, TMOVE(:,NMOVE), & - AMOVE(NMOVE), DMOVE(NMOVE) -! - END DO -! - IF ( IMPROC.EQ.1 .AND. ILOOP.EQ.1 ) CLOSE (SCRATCH) + ! + X(NPTS) = XX + Y(NPTS) = YY + PNAMES(NPTS) = PN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + IF ( NPTS .EQ. 1 ) THEN + WRITE (MDSS,957) XX, YY, PN + ELSE + WRITE (MDSS,958) NPTS, XX, YY, PN + END IF + END IF + ! END DO -! + ! + IF ( IMPROC.EQ.1 .AND. ILOOP.EQ.1 ) CLOSE (SCRATCH) + END DO + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC .AND. & + NPTS.EQ.0 ) WRITE (MDSS,959) IF ( IMPROC .EQ. 1 ) THEN #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) #endif - CLOSE (SCRATCH,STATUS='DELETE') - ELSE - CLOSE (SCRATCH) + CLOSE (SCRATCH,STATUS='DELETE') + ELSE + CLOSE (SCRATCH) #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) #endif - END IF -! -#ifdef W3_T - WRITE (MDST,9060) - DO I=1, NMOVE - WRITE (MDST,9061) I, TMOVE(:,I), AMOVE(I), DMOVE(I) - END DO -#endif -! - IF ( NMOVE .EQ. 0 ) GOTO 2060 -! - NMVMAX = NMOVE - DO I=1, NRGRD - CALL W3SETG ( I, MDSE, MDST ) - CALL WMSETM ( I, MDSE, MDST ) - NMV = NMOVE - CALL WMDIMD ( I, MDSE, MDST, 0 ) - DO II=1, NMV - TMV(:,4,II) = TMOVE(:,II) - AMV(II,4) = AMOVE(II) - DMV(II,4) = DMOVE(II) - END DO - END DO -! - END IF -! -! 7. Work load distribution ----------------------------------------- / -! 7.a Initialize arrays -! -! ******************************************************* -! *** NOTE : OUTPUT PROCESSOR ASSIGNMENT NEEDS TO BE *** -! *** CONSISTENT WITH ASSIGNMENT IN W3INIT. *** -! ******************************************************* -! - ALLOCATE ( ALLPRC(NMPROC,NRGRD) , MODMAP(NMPROC,NRGRP) , & - LOADMP(NMPROC,NRGRP) ) -! - ALLPRC = 0 - MODMAP = 0 - LOADMP = 0 -! -! 7.b Determine number of output processors -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,970) -! - NCPROC = NMPROC - UPPROC = UPPROC .AND. UNIPTS .AND. IOSTYP.GT.1 -! -! 7.b.1 Unified point output -! - IF ( UNIPTS ) THEN - IF ( NMPROC.GE.10 .AND. UPPROC ) THEN - NCPROC = NMPROC - 1 + END IF + ! + ELSE IF ( J .EQ. 3 ) THEN + ! + ! 5.e Type 3: track output + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + READ (MDSI,*,END=2001,ERR=2002) TFLAGI + IF ( .NOT. TFLAGI ) MDS(11,:) = -MDS(11,:) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + IF ( .NOT. TFLAGI ) THEN + WRITE (MDSS,960) 'input', 'UNFORMATTED' ELSE - IF ( UPPROC .AND. MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,971) 'Separate process for point' // & - ' output disabled.' - UPPROC = .FALSE. + WRITE (MDSS,960) 'input', 'FORMATTED' END IF - IF ( NMPUPT .EQ. IMPROC ) THEN - II = LEN_TRIM(MNAMES(0)) - CALL WMUGET ( MDSS, MDST, MDSUP, 'OUT' ) - CALL WMUSET ( MDSS, MDST, MDSUP, .TRUE., 'OUT', & - TRIM(FNMPRE)//'out_pnt.'//MNAMES(0)(1:II), & - 'Unified point output') + END IF + ! + ELSE IF ( J .EQ. 4 ) THEN + ! + ! 5.f Type 4: restart files (no additional data) + ! + ELSE IF ( J .EQ. 5 ) THEN + ! + ! 5.g Type 5: nesting data (no additional data) + ! + ELSE IF ( J .EQ. 6 ) THEN + ! + ! 5.h Type 6: partitioned wave field data + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + READ (MDSI,*,END=2001,ERR=2002) IPRT(:,1), LPRT(1) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,961) IPRT(:,1) + IF ( .NOT. LPRT(1) ) THEN + WRITE (MDSS,960) 'output', 'UNFORMATTED' + ELSE + WRITE (MDSS,960) 'output', 'FORMATTED' END IF + END IF + ! + ! ... End of output type selecttion ELSE IF + ! END IF -! - IF ( UPPROC .AND. MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,972) NMPUPT -! -! 7.b.2 Other output -! - ALLOCATE ( NDPOUT(NRGRD) ) - NDPOUT = 0 -! - IF ( IOSTYP .GT. 1 ) THEN - DO I=1, NRGRD - IF ( ODAT( 3,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 - IF ( ODAT(13,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 - IF ( ODAT(28,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 - IF ( ODAT( 8,I) .GT. 0 .OR. ODAT(18,I) .GT. 0 .OR. & - ODAT(23,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 - IF ( IOSTYP .EQ. 2 ) NDPOUT(I) = MIN ( 1 , NDPOUT(I) ) - END DO + ! + ! ... End of IF in 5.b + ! + END IF + ! + ! ... End of loop in 5.a + ! + END DO + !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + ! Checkpoint + J=8 + IF ( ODAT(5*(J-1)+3,1) .NE. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,951) J, IDOTYP(J) + TTIME(1) = ODAT(5*(J-1)+1,1) + TTIME(2) = ODAT(5*(J-1)+2,1) + CALL STME21 ( TTIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,952) DTME21 + TTIME(1) = ODAT(5*(J-1)+4,1) + TTIME(2) = ODAT(5*(J-1)+5,1) + CALL STME21 ( TTIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,953) DTME21 + TTIME(1) = 0 + TTIME(2) = 0 + DTTST = REAL ( ODAT(5*(J-1)+3,1) ) + CALL TICK21 ( TTIME , DTTST ) + CALL STME21 ( TTIME , DTME21 ) + IF ( ( ODAT(5*(J-1)+1,1) .NE. ODAT(5*(J-1)+4,1) .OR. & + ODAT(5*(J-1)+2,1) .NE. ODAT(5*(J-1)+5,1) ) .AND. & + MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + DO I=1, 18 + IF ( DTME21(I:I).NE.'0' .AND. & + DTME21(I:I).NE.'/' .AND. & + DTME21(I:I).NE.' ' .AND. & + DTME21(I:I).NE.':' ) EXIT + DTME21(I:I) = ' ' + END DO + WRITE (MDSS,954) DTME21(1:19) + END IF + END IF + !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + ! + ! 5.i Set all grids to unified output + ! + IF ( UNIPTS ) THEN + ODAT(6:10,0) = ODAT(6:10,1) + ODAT( 8 , 1) = 0 + OUTPTS(1)%OFILES(1) = OUTFF(1,1) + END IF + ! + DO I=2, NRGRD + ODAT(:,I) = ODAT(:,1) + OUTFF(:,I) = OUTFF(:,1) + OUTPTS(I)%OFILES(:)=OUTFF(:,1) + FLGD(:,I) = FLGD(:,1) + FLGRD(:,:,I) = FLGRD(:,:,1) + FLG2(:,I) = FLG2(:,1) + FLGR2(:,:,I) = FLGR2(:,:,1) + IPRT(:,I) = IPRT(:,1) + LPRT(I) = LPRT(1) + END DO + ! + IF ( NPTS.EQ.0 .OR. ODAT(8,0).EQ.0 ) UNIPTS = .FALSE. + IF ( UNIPTS ) THEN + IF ( ( NPTS.EQ.0 .OR. ODAT(8,0).EQ.0 ) .AND. & + IMPROC.EQ.NMPERR ) WRITE (MDSE,1050) + IF ( NPTS.EQ.0 .OR. ODAT(8,0).EQ.0 ) UNIPTS = .FALSE. + OT2(0)%NPTS = NPTS + ALLOCATE (OT2(0)%X(NPTS),OT2(0)%Y(NPTS),OT2(0)%PNAMES(NPTS)) + OT2(0)%X = X + OT2(0)%Y = Y + OT2(0)%PNAMES = PNAMES + DO I=1, NRGRD + OT2(I)%NPTS = 0 + ALLOCATE (OT2(I)%X(1),OT2(I)%Y(1),OT2(I)%PNAMES(1)) + END DO + ELSE + DO I=1, NRGRD + OT2(I)%NPTS = NPTS + IF ( NPTS .EQ. 0 ) THEN + ALLOCATE (OT2(I)%X(1),OT2(I)%Y(1),OT2(I)%PNAMES(1)) + ELSE + ALLOCATE (OT2(I)%X(NPTS),OT2(I)%Y(NPTS), & + OT2(I)%PNAMES(NPTS)) + OT2(I)%X = X + OT2(I)%Y = Y + OT2(I)%PNAMES = PNAMES END IF -! -! ..... Reduce IOSTYP if not enough resources to run IOSTYP = 3 -! - IF ( IOSTYP.EQ.3 .AND. & - ( ( .NOT.PSHARE .AND. 4*SUM(NDPOUT).GT.NCPROC ) & - .OR.( PSHARE .AND. 4*MAXVAL(NDPOUT).GT.NCPROC ) ) ) THEN - DO I=1, NRGRD - NDPOUT(I) = MIN ( 1 , NDPOUT(I) ) - END DO - IOSTYP = 2 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,971) 'Separate processes for output' // & - ' types disabled.' + END DO + END IF + ! + ! 5.j Endless loop for correcting output per grid + ! + DO + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + READ (MDSI,*,END=2001,ERR=2002) MN, J + ! + ! 5.j.1 Bail out loop for output type 0 + ! + IF ( J .EQ. 0 ) EXIT + ! + ! 5.j.2 Find the grid number + ! + II = LEN_TRIM(MN) + DO I=1, NRGRD + IF ( MN(:II) .EQ. MNAMES(I)(1:II) ) EXIT + END DO + ! + IF ( I .GT. NRGRD ) GOTO 2051 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,962) MN(1:II), I + ! + ! 5.j.3 Check the output type + ! + IF ( J.LT.0 .OR. J.GT. NOTYPE ) GOTO 2052 + IF ( J.EQ.2 .AND. UNIPTS ) GOTO 2053 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,951) J, IDOTYP(J) + ! + ! 5.k Process standard line + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + IF(J .LE. 2) THEN + OUTFF(J,I)=0 + WORDS(1:6) ='' + READ (MDSI,'(A)') LINEIN + READ(LINEIN,*,iostat=ierr) WORDS + IF(J .EQ. 1) THEN + READ(WORDS( 1 ), * ) ODAT(1,I) + READ(WORDS( 2 ), * ) ODAT(2,I) + READ(WORDS( 3 ), * ) ODAT(3,I) + READ(WORDS( 4 ), * ) ODAT(4,I) + READ(WORDS( 5 ), * ) ODAT(5,I) + ELSE + READ(WORDS( 1 ), * ) ODAT(6,I) + READ(WORDS( 2 ), * ) ODAT(7,I) + READ(WORDS( 3 ), * ) ODAT(8,I) + READ(WORDS( 4 ), * ) ODAT(9,I) + READ(WORDS( 5 ), * ) ODAT(10,I) END IF -! -! ..... Force sharing of output processes if not enough resources -! - IF ( IOSTYP.GT.1 .AND. .NOT.PSHARE .AND. & - 4*SUM(NDPOUT).GT.NCPROC ) THEN - PSHARE = .TRUE. - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,971) 'Grids sharing output processes.' + IF (WORDS(6) .NE. '0' .AND. WORDS(6) .NE. '1') THEN + OUTFF(J,I)=0 + ELSE + READ(WORDS( 6 ), * ) OUTFF(J,I) END IF -! -! ..... Disable output processes if not enough resources -! - IF ( IOSTYP.GT.1 .AND. 4*MAXVAL(NDPOUT).GT.NCPROC ) THEN - NDPOUT = 0 - IOSTYP = 1 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,971) 'Separate processes for output' // & - ' disabled.' + ! + ELSE + READ (MDSI,*,END=2001,ERR=2002)(ODAT(II,I),II=5*(J-1)+1,5*J) + OUTFF(J,I) = 0 + END IF + ! + OUTPTS(I)%OFILES(J)=OUTFF(J,I) + ! + ODAT(5*(J-1)+3,I) = MAX ( 0 , ODAT(5*(J-1)+3,I) ) + ! + IF ( ODAT(5*(J-1)+3,I) .NE. 0 ) THEN + TTIME(1) = ODAT(5*(J-1)+1,I) + TTIME(2) = ODAT(5*(J-1)+2,I) + CALL STME21 ( TTIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,952) DTME21 + TTIME(1) = ODAT(5*(J-1)+4,I) + TTIME(2) = ODAT(5*(J-1)+5,I) + CALL STME21 ( TTIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,953) DTME21 + TTIME(1) = 0 + TTIME(2) = 0 + DTTST = REAL ( ODAT(5*(J-1)+3,I) ) + CALL TICK21 ( TTIME , DTTST ) + CALL STME21 ( TTIME , DTME21 ) + IF ( ( ODAT(5*(J-1)+1,I) .NE. ODAT(5*(J-1)+4,I) .OR. & + ODAT(5*(J-1)+2,I) .NE. ODAT(5*(J-1)+5,I) ) .AND. & + MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + DO II=1, 18 + IF ( DTME21(II:II).NE.'0' .AND. & + DTME21(II:II).NE.'/' .AND. & + DTME21(II:II).NE.' ' .AND. & + DTME21(II:II).NE.':' ) EXIT + DTME21(II:II) = ' ' + END DO + WRITE (MDSS,954) DTME21(1:19) END IF -! -! ..... Number of output processes (except for unified point output) -! - NPOUTT = 0 - IF ( IOSTYP .GT. 1 ) THEN - IF ( PSHARE ) THEN - NPOUTT = MAXVAL(NDPOUT) + ! + IF ( J .EQ. 1 ) THEN + ! + ! 5.l Type 1: fields of mean wave parameters + ! + CALL W3READFLGRD ( MDSI, MDSS, MDSO, MDSE2, COMSTR, & + FLG1D, FLG2D, IMPROC, NMPSCR, IERR ) + FLGD(:,I) = FLG1D + FLGRD(:,:,I) = FLG2D + ! + ELSE IF ( J .EQ. 2 ) THEN + ! + ! 5.m Type 2: point output + ! + DO ILOOP=1, 2 + IF ( ILOOP .EQ. 1 ) THEN + MDSI2 = MDSI + IF ( IMPROC .EQ. 1 ) OPEN & + (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') ELSE - NPOUTT = SUM(NDPOUT) + MDSI2 = SCRATCH +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif + OPEN & + (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') + REWIND (SCRATCH) + DEALLOCATE ( OT2(I)%X, OT2(I)%Y, OT2(I)%PNAMES ) + ALLOCATE ( OT2(I)%X(OT2(I)%NPTS), & + OT2(I)%Y(OT2(I)%NPTS), & + OT2(I)%PNAMES(OT2(I)%NPTS) ) END IF - END IF - NCPROC = NCPROC - NPOUTT - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - IF ( NPOUTT .EQ. 0 ) THEN - WRITE (MDSS,971) 'No (other) dedicated output processes.' + ! + OT2(I)%NPTS = 0 + DO + CALL NEXTLN ( COMSTR , MDSI2 , MDSE2 ) + READ (MDSI2,*,END=2001,ERR=2002) XX, YY, PN + ! + IF ( ILOOP.EQ.1 .AND. IMPROC.EQ.1 ) THEN + BACKSPACE (MDSI) + READ (MDSI,'(A)') LINE + WRITE (SCRATCH,'(A)') LINE + END IF + ! + IF ( PN .EQ. 'STOPSTRING' ) EXIT + ! + OT2(I)%NPTS = OT2(I)%NPTS + 1 + IF ( ILOOP .EQ. 1 ) CYCLE + ! + OT2(I)%X(OT2(I)%NPTS) = XX + OT2(I)%Y(OT2(I)%NPTS) = YY + OT2(I)%PNAMES(OT2(I)%NPTS) = PN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + IF ( OT2(I)%NPTS .EQ. 1 ) THEN + WRITE (MDSS,957) XX, YY, PN + ELSE + WRITE (MDSS,958) OT2(I)%NPTS, XX, YY, PN + END IF + END IF + ! + END DO + ! + IF ( IMPROC.EQ.1 .AND. ILOOP.EQ.1 ) CLOSE (SCRATCH) + END DO + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC .AND. & + OT2(I)%NPTS.EQ.0 ) WRITE (MDSS,959) + IF ( IMPROC .EQ. 1 ) THEN +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif + CLOSE (SCRATCH,STATUS='DELETE') + ELSE + CLOSE (SCRATCH) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif + END IF + ! + ELSE IF ( J .EQ. 3 ) THEN + ! + ! 5.n Type 3: track output + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + READ (MDSI,*,END=2001,ERR=2002) TFLAGI + IF ( TFLAGI ) THEN + MDS(11,I) = ABS(MDS(11,I)) + ELSE + MDS(11,I) = -ABS(MDS(11,I)) + END IF + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + IF ( .NOT. TFLAGI ) THEN + WRITE (MDSS,960) 'input', 'UNFORMATTED' + ELSE + WRITE (MDSS,960) 'input', 'FORMATTED' + END IF + END IF + ! + ELSE IF ( J .EQ. 6 ) THEN + ! + ! 5.o Type 6: partitioned wave field data + ! + CALL NEXTLN ( COMSTR , MDSI , MDSE2 ) + READ (MDSI,*,END=2001,ERR=2002) IPRT(:,I), LPRT(I) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,961) IPRT(:,I) + IF ( .NOT. LPRT(I) ) THEN + WRITE (MDSS,960) 'output', 'UNFORMATTED' ELSE - WRITE (MDSS,973) NCPROC+1, NCPROC+NPOUTT, NPOUTT + WRITE (MDSS,960) 'output', 'FORMATTED' END IF + END IF + ! END IF -! -! 7.c Set communicators and ALLPRC array -! + ELSE IF ( J .EQ. 7 ) THEN + ! + ! 5.p Type 7: coupling fields + ! + CALL W3READFLGRD ( MDSI, MDSS, MDSO, MDSE2, COMSTR, & + FLG1D, FLG2D, IMPROC, NMPSCR, IERR ) + FLG2(:,I) = FLG1D + FLGR2(:,:,I) = FLG2D + ! + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,963) + END IF + ! + ! ... End of loop in 5.j + ! + END DO + ! #ifdef W3_T - WRITE (MDST,9070) + DO I=1, NRGRD + WRITE (MDST,9050) I + WRITE (MDST,9051) ODAT(:,I) + WRITE (MDST,9051) OUTFF(:,I) + WRITE (MDST,9052) FLGRD(:,:,I) + END DO +#endif + ! + ! 6. Read moving grid data ------------------------------------------ / + ! + ! Only a single set of data are provided to be applied to all + ! the grids, because this is only intended for test cases. + ! For true implementations, the jumping grid will be used. + ! + IF ( INFLAGS1(10) ) THEN + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,965) + WRITE (MDSS,966) 'Continuous grid movement data' + END IF + ! +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif + DO ILOOP=1, 2 + IF ( ILOOP .EQ. 1 ) THEN + MDSI2 = MDSI + IF ( IMPROC .EQ. 1 ) & + OPEN (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') + ELSE + MDSI2 = SCRATCH +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif + OPEN (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') + REWIND (SCRATCH) + ALLOCATE ( TMOVE(2,NMOVE), AMOVE(NMOVE), DMOVE(NMOVE) ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,967) NMOVE, 'MOV' + END IF + ! + NMOVE = 0 + DO + CALL NEXTLN ( COMSTR , MDSI2 , MDSE2 ) + READ (MDSI2,*,END=2001,ERR=2002) IDTST + ! + IF ( ILOOP.EQ.1 .AND. IMPROC.EQ.1 ) THEN + BACKSPACE (MDSI) + READ (MDSI,'(A)') LINE + WRITE (SCRATCH,'(A)') LINE + END IF + ! + IF ( IDTST .EQ. 'STP' ) EXIT + IF ( IDTST .NE. 'MOV' ) CYCLE + ! + NMOVE = NMOVE + 1 + IF ( ILOOP .EQ. 1 ) CYCLE + ! + BACKSPACE (MDSI2) + READ (MDSI2,*,END=2001,ERR=2002) IDTST, TTIME, XX, YY + TMOVE(:,NMOVE) = TTIME + AMOVE(NMOVE) = XX + DMOVE(NMOVE) = YY + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,968) NMOVE, TMOVE(:,NMOVE), & + AMOVE(NMOVE), DMOVE(NMOVE) + ! + END DO + ! + IF ( IMPROC.EQ.1 .AND. ILOOP.EQ.1 ) CLOSE (SCRATCH) + END DO + ! + IF ( IMPROC .EQ. 1 ) THEN +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) #endif - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,974) - IF ( NMPLOG.EQ.IMPROC ) WRITE (MDSO,1974) -! + CLOSE (SCRATCH,STATUS='DELETE') + ELSE + CLOSE (SCRATCH) #ifdef W3_MPI - CALL MPI_COMM_GROUP ( MPI_COMM_MWAVE, BGROUP, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif + END IF + ! +#ifdef W3_T + WRITE (MDST,9060) + DO I=1, NMOVE + WRITE (MDST,9061) I, TMOVE(:,I), AMOVE(I), DMOVE(I) + END DO #endif - ALLOCATE ( TMPRNK(NMPROC) ) - NAPRES = NCPROC -! + ! + IF ( NMOVE .EQ. 0 ) GOTO 2060 + ! + NMVMAX = NMOVE DO I=1, NRGRD -! - IP1 = MAX( 1 , MIN ( NCPROC , 1+NINT(REAL(NCPROC)*RP1(I)) ) ) - IPN = MAX( IP1 , MIN ( NCPROC , NINT(REAL(NCPROC)*RPN(I)) ) ) - OUTSTR = '-----' -! + CALL W3SETG ( I, MDSE, MDST ) CALL WMSETM ( I, MDSE, MDST ) - NAPLOC = 1 + IPN - IP1 - NAPADD = NAPLOC -#ifdef W3_MPI - CROOT = IP1 - FBCAST = NAPLOC .NE. NCPROC - FBCAST = NAPLOC .NE. NCPROC .OR. & - ( IOSTYP.GT.1 .AND. .NOT.PSHARE ) + NMV = NMOVE + CALL WMDIMD ( I, MDSE, MDST, 0 ) + DO II=1, NMV + TMV(:,4,II) = TMOVE(:,II) + AMV(II,4) = AMOVE(II) + DMV(II,4) = DMOVE(II) + END DO + END DO + ! + END IF + ! + ! 7. Work load distribution ----------------------------------------- / + ! 7.a Initialize arrays + ! + ! ******************************************************* + ! *** NOTE : OUTPUT PROCESSOR ASSIGNMENT NEEDS TO BE *** + ! *** CONSISTENT WITH ASSIGNMENT IN W3INIT. *** + ! ******************************************************* + ! + ALLOCATE ( ALLPRC(NMPROC,NRGRD) , MODMAP(NMPROC,NRGRP) , & + LOADMP(NMPROC,NRGRP) ) + ! + ALLPRC = 0 + MODMAP = 0 + LOADMP = 0 + ! + ! 7.b Determine number of output processors + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,970) + ! + NCPROC = NMPROC + UPPROC = UPPROC .AND. UNIPTS .AND. IOSTYP.GT.1 + ! + ! 7.b.1 Unified point output + ! + IF ( UNIPTS ) THEN + IF ( NMPROC.GE.10 .AND. UPPROC ) THEN + NCPROC = NMPROC - 1 + ELSE + IF ( UPPROC .AND. MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,971) 'Separate process for point' // & + ' output disabled.' + UPPROC = .FALSE. + END IF + IF ( NMPUPT .EQ. IMPROC ) THEN + II = LEN_TRIM(MNAMES(0)) + CALL WMUGET ( MDSS, MDST, MDSUP, 'OUT' ) + CALL WMUSET ( MDSS, MDST, MDSUP, .TRUE., 'OUT', & + TRIM(FNMPRE)//'out_pnt.'//MNAMES(0)(1:II), & + 'Unified point output') + END IF + END IF + ! + IF ( UPPROC .AND. MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,972) NMPUPT + ! + ! 7.b.2 Other output + ! + ALLOCATE ( NDPOUT(NRGRD) ) + NDPOUT = 0 + ! + IF ( IOSTYP .GT. 1 ) THEN + DO I=1, NRGRD + IF ( ODAT( 3,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 + IF ( ODAT(13,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 + IF ( ODAT(28,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 + IF ( ODAT( 8,I) .GT. 0 .OR. ODAT(18,I) .GT. 0 .OR. & + ODAT(23,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 + IF ( IOSTYP .EQ. 2 ) NDPOUT(I) = MIN ( 1 , NDPOUT(I) ) + END DO + END IF + ! + ! ..... Reduce IOSTYP if not enough resources to run IOSTYP = 3 + ! + IF ( IOSTYP.EQ.3 .AND. & + ( ( .NOT.PSHARE .AND. 4*SUM(NDPOUT).GT.NCPROC ) & + .OR.( PSHARE .AND. 4*MAXVAL(NDPOUT).GT.NCPROC ) ) ) THEN + DO I=1, NRGRD + NDPOUT(I) = MIN ( 1 , NDPOUT(I) ) + END DO + IOSTYP = 2 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,971) 'Separate processes for output' // & + ' types disabled.' + END IF + ! + ! ..... Force sharing of output processes if not enough resources + ! + IF ( IOSTYP.GT.1 .AND. .NOT.PSHARE .AND. & + 4*SUM(NDPOUT).GT.NCPROC ) THEN + PSHARE = .TRUE. + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,971) 'Grids sharing output processes.' + END IF + ! + ! ..... Disable output processes if not enough resources + ! + IF ( IOSTYP.GT.1 .AND. 4*MAXVAL(NDPOUT).GT.NCPROC ) THEN + NDPOUT = 0 + IOSTYP = 1 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,971) 'Separate processes for output' // & + ' disabled.' + END IF + ! + ! ..... Number of output processes (except for unified point output) + ! + NPOUTT = 0 + IF ( IOSTYP .GT. 1 ) THEN + IF ( PSHARE ) THEN + NPOUTT = MAXVAL(NDPOUT) + ELSE + NPOUTT = SUM(NDPOUT) + END IF + END IF + NCPROC = NCPROC - NPOUTT + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + IF ( NPOUTT .EQ. 0 ) THEN + WRITE (MDSS,971) 'No (other) dedicated output processes.' + ELSE + WRITE (MDSS,973) NCPROC+1, NCPROC+NPOUTT, NPOUTT + END IF + END IF + ! + ! 7.c Set communicators and ALLPRC array + ! +#ifdef W3_T + WRITE (MDST,9070) #endif - DO J=IP1, IPN - TMPRNK(1+J-IP1) = J - 1 - END DO -! - IF ( IOSTYP .GT. 1 ) THEN - IF ( PSHARE ) NAPRES = NCPROC - DO J=1, NDPOUT(I) - NAPADD = NAPADD + 1 - TMPRNK(NAPADD) = NAPRES - NAPRES = NAPRES + 1 - END DO - END IF -! - IF ( UPPROC ) THEN - NAPADD = NAPADD + 1 - TMPRNK(NAPADD) = NMPROC - 1 - END IF -! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,974) + IF ( NMPLOG.EQ.IMPROC ) WRITE (MDSO,1974) + ! #ifdef W3_MPI - CALL MPI_GROUP_INCL ( BGROUP, NAPADD, TMPRNK, LGROUP, & - IERR_MPI ) - CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & - MPI_COMM_GRD, IERR_MPI ) - CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) + CALL MPI_COMM_GROUP ( MPI_COMM_MWAVE, BGROUP, IERR_MPI ) +#endif + ALLOCATE ( TMPRNK(NMPROC) ) + NAPRES = NCPROC + ! + DO I=1, NRGRD + ! + IP1 = MAX( 1 , MIN ( NCPROC , 1+NINT(REAL(NCPROC)*RP1(I)) ) ) + IPN = MAX( IP1 , MIN ( NCPROC , NINT(REAL(NCPROC)*RPN(I)) ) ) + OUTSTR = '-----' + ! + CALL WMSETM ( I, MDSE, MDST ) + NAPLOC = 1 + IPN - IP1 + NAPADD = NAPLOC +#ifdef W3_MPI + CROOT = IP1 + FBCAST = NAPLOC .NE. NCPROC + FBCAST = NAPLOC .NE. NCPROC .OR. & + ( IOSTYP.GT.1 .AND. .NOT.PSHARE ) #endif -! - DO II=IP1, IPN - ALLPRC(II,I) = 1 + II - IP1 - END DO - II = II - IP1 -! - IF ( PSHARE .OR. I.EQ.1 ) THEN - NAPADD = NCPROC - ELSE - NAPADD = NCPROC + SUM(NDPOUT(1:I-1)) - END IF - IF ( IOSTYP .GT. 1 ) THEN - DO J=1, NDPOUT(I) - NAPADD = NAPADD + 1 - II = II + 1 - ALLPRC(NAPADD,I) = II - END DO + DO J=IP1, IPN + TMPRNK(1+J-IP1) = J - 1 + END DO + ! + IF ( IOSTYP .GT. 1 ) THEN + IF ( PSHARE ) NAPRES = NCPROC + DO J=1, NDPOUT(I) + NAPADD = NAPADD + 1 + TMPRNK(NAPADD) = NAPRES + NAPRES = NAPRES + 1 + END DO + END IF + ! + IF ( UPPROC ) THEN + NAPADD = NAPADD + 1 + TMPRNK(NAPADD) = NMPROC - 1 + END IF + ! +#ifdef W3_MPI + CALL MPI_GROUP_INCL ( BGROUP, NAPADD, TMPRNK, LGROUP, & + IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & + MPI_COMM_GRD, IERR_MPI ) + CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) +#endif + ! + DO II=IP1, IPN + ALLPRC(II,I) = 1 + II - IP1 + END DO + II = II - IP1 + ! + IF ( PSHARE .OR. I.EQ.1 ) THEN + NAPADD = NCPROC + ELSE + NAPADD = NCPROC + SUM(NDPOUT(1:I-1)) + END IF + IF ( IOSTYP .GT. 1 ) THEN + DO J=1, NDPOUT(I) + NAPADD = NAPADD + 1 + II = II + 1 + ALLPRC(NAPADD,I) = II + END DO + END IF + ! + IF ( UPPROC ) THEN + II = II + 1 + ALLPRC(NMPROC,I) = II + END IF + ! +#ifdef W3_T + WRITE (MDST,9071) I, ALLPRC(:,I) +#endif + ! + ! ... output + ! + ! + IF ( IOSTYP .LE. 1 ) THEN + ! + IF ( ODAT( 3,I) .GT. 0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-1))+1 + OUTSTR(1) = STOUT + END IF + IF ( ODAT( 8,I) .GT. 0 .OR. UNIPTS ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-2))+1 + OUTSTR(2) = STOUT + END IF + IF ( ODAT(13,I) .GT. 0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-5))+1 + OUTSTR(3) = STOUT + END IF + IF ( ODAT(18,I) .GT. 0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(NAPLOC)+1 + OUTSTR(4) = STOUT + END IF + IF ( ODAT(23,I) .GT. 0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-3))+1 + OUTSTR(5) = STOUT + END IF + IF ( ODAT(28,I) .GT. 0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-4))+1 + OUTSTR(6) = STOUT + END IF + ! + ELSE + ! + IF ( UNIPTS ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + OUTSTR(2) = STOUT + IF ( UPPROC ) II = II - 1 + END IF + ! + IF ( IOSTYP .EQ. 2 ) THEN + ! + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + IF ( ODAT( 3,I) .GT. 0 ) OUTSTR(1) = STOUT + IF ( ODAT( 8,I) .GT. 0 .OR. & + ( UNIPTS .AND. .NOT.UPPROC ) ) & + OUTSTR(2) = STOUT + IF ( ODAT(13,I) .GT. 0 ) OUTSTR(3) = STOUT + IF ( ODAT(18,I) .GT. 0 ) OUTSTR(4) = STOUT + IF ( ODAT(23,I) .GT. 0 ) OUTSTR(5) = STOUT + IF ( ODAT(28,I) .GT. 0 ) OUTSTR(6) = STOUT + ! + ELSE IF ( IOSTYP .EQ. 3 ) THEN + ! + IF ( ODAT( 3,I).GT.0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + OUTSTR(1) = STOUT + II = II - 1 END IF -! - IF ( UPPROC ) THEN - II = II + 1 - ALLPRC(NMPROC,I) = II + IF ( ODAT(13,I).GT.0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + OUTSTR(3) = STOUT + II = II - 1 END IF -! -#ifdef W3_T - WRITE (MDST,9071) I, ALLPRC(:,I) -#endif -! -! ... output -! -! - IF ( IOSTYP .LE. 1 ) THEN -! - IF ( ODAT( 3,I) .GT. 0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-1))+1 - OUTSTR(1) = STOUT - END IF - IF ( ODAT( 8,I) .GT. 0 .OR. UNIPTS ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-2))+1 - OUTSTR(2) = STOUT - END IF - IF ( ODAT(13,I) .GT. 0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-5))+1 - OUTSTR(3) = STOUT - END IF - IF ( ODAT(18,I) .GT. 0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(NAPLOC)+1 - OUTSTR(4) = STOUT - END IF - IF ( ODAT(23,I) .GT. 0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-3))+1 - OUTSTR(5) = STOUT - END IF - IF ( ODAT(28,I) .GT. 0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-4))+1 - OUTSTR(6) = STOUT - END IF -! - ELSE -! - IF ( UNIPTS ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - OUTSTR(2) = STOUT - IF ( UPPROC ) II = II - 1 - END IF -! - IF ( IOSTYP .EQ. 2 ) THEN -! - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - IF ( ODAT( 3,I) .GT. 0 ) OUTSTR(1) = STOUT - IF ( ODAT( 8,I) .GT. 0 .OR. & - ( UNIPTS .AND. .NOT.UPPROC ) ) & - OUTSTR(2) = STOUT - IF ( ODAT(13,I) .GT. 0 ) OUTSTR(3) = STOUT - IF ( ODAT(18,I) .GT. 0 ) OUTSTR(4) = STOUT - IF ( ODAT(23,I) .GT. 0 ) OUTSTR(5) = STOUT - IF ( ODAT(28,I) .GT. 0 ) OUTSTR(6) = STOUT -! - ELSE IF ( IOSTYP .EQ. 3 ) THEN -! - IF ( ODAT( 3,I).GT.0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - OUTSTR(1) = STOUT - II = II - 1 - END IF - IF ( ODAT(13,I).GT.0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - OUTSTR(3) = STOUT - II = II - 1 - END IF - IF ( ODAT(28,I).GT.0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - OUTSTR(6) = STOUT - II = II - 1 - END IF - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - IF ( ODAT( 8,I) .GT. 0 ) OUTSTR(2) = STOUT - IF ( ODAT(18,I) .GT. 0 ) OUTSTR(4) = STOUT - IF ( ODAT(23,I) .GT. 0 ) OUTSTR(5) = STOUT -! - END IF -! + IF ( ODAT(28,I).GT.0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + OUTSTR(6) = STOUT + II = II - 1 END IF -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,975) MNAMES(I), IP1, IPN, OUTSTR - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,1975)MNAMES(I), IP1, IPN, OUTSTR -! + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + IF ( ODAT( 8,I) .GT. 0 ) OUTSTR(2) = STOUT + IF ( ODAT(18,I) .GT. 0 ) OUTSTR(4) = STOUT + IF ( ODAT(23,I) .GT. 0 ) OUTSTR(5) = STOUT + ! + END IF + ! + END IF + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,975) MNAMES(I), IP1, IPN, OUTSTR + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,1975)MNAMES(I), IP1, IPN, OUTSTR + ! #ifdef W3_MPI - IF ( FBCAST ) THEN - TMPRNK(1) = IP1 - 1 - NAPBCT = 1 - DO J=1, NMPROC - IF ( ALLPRC(J,I) .EQ. 0 ) THEN - NAPBCT = NAPBCT + 1 - TMPRNK(NAPBCT) = J - 1 - END IF - END DO - CALL MPI_GROUP_INCL ( BGROUP, NAPBCT, TMPRNK, & - LGROUP, IERR_MPI ) - CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) - END IF -#endif -! + IF ( FBCAST ) THEN + TMPRNK(1) = IP1 - 1 + NAPBCT = 1 + DO J=1, NMPROC + IF ( ALLPRC(J,I) .EQ. 0 ) THEN + NAPBCT = NAPBCT + 1 + TMPRNK(NAPBCT) = J - 1 + END IF END DO -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,976) - IF ( UNIPTS ) WRITE (MDSS,977) NMPUPT - WRITE (MDSS,*) - END IF -! - IF ( NMPLOG .EQ. IMPROC ) THEN - WRITE (MDSO,1976) - IF ( UNIPTS ) WRITE (MDSO,1977) NMPUPT - WRITE (MDSO,*) - END IF -! - DEALLOCATE ( TMPRNK, NDPOUT ) -! -! 7.d Set MODMAP and LOADMP arrays -! - DO JJ=1, NRGRP - DO II=1, INGRP(JJ,0) - I = INGRP(JJ,II) - DO J=1, NMPROC - IF ( ALLPRC(J,I) .NE. 0 ) THEN - LOADMP(J,JJ) = LOADMP(J,JJ) + 1 - IF ( LOADMP(J,JJ) .EQ. 1 ) THEN - MODMAP(J,JJ) = I - ELSE - MODMAP(J,JJ) = -1 - END IF - END IF - END DO - END DO + CALL MPI_GROUP_INCL ( BGROUP, NAPBCT, TMPRNK, & + LGROUP, IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) + END IF +#endif + ! + END DO + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,976) + IF ( UNIPTS ) WRITE (MDSS,977) NMPUPT + WRITE (MDSS,*) + END IF + ! + IF ( NMPLOG .EQ. IMPROC ) THEN + WRITE (MDSO,1976) + IF ( UNIPTS ) WRITE (MDSO,1977) NMPUPT + WRITE (MDSO,*) + END IF + ! + DEALLOCATE ( TMPRNK, NDPOUT ) + ! + ! 7.d Set MODMAP and LOADMP arrays + ! + DO JJ=1, NRGRP + DO II=1, INGRP(JJ,0) + I = INGRP(JJ,II) + DO J=1, NMPROC + IF ( ALLPRC(J,I) .NE. 0 ) THEN + LOADMP(J,JJ) = LOADMP(J,JJ) + 1 + IF ( LOADMP(J,JJ) .EQ. 1 ) THEN + MODMAP(J,JJ) = I + ELSE + MODMAP(J,JJ) = -1 + END IF + END IF END DO -! + END DO + END DO + ! #ifdef W3_T - WRITE (MDST,8042) - DO J=1, NRGRP - WRITE (MDST,8044) J, MODMAP(:,J) - END DO - WRITE (MDST,8043) - DO J=1, NRGRP - WRITE (MDST,8044) J, LOADMP(:,J) - END DO -#endif -! -! 7.e Warnings -! - IF ( NMPROC .GT. 1 ) THEN - DO I=1, NRGRP - IP1 = MINVAL ( LOADMP(:NCPROC,I) ) - IPN = MAXVAL ( LOADMP(:NCPROC,I) ) - IF ( IP1.NE.IPN .AND. IMPROC.EQ.NMPERR ) & - WRITE (MDSE,1040) I, IP1, IPN - END DO - END IF -! - DEALLOCATE ( RP1, RPN, LOADMP ) -! -! 7.f Reset NMPSCR to first processor of first rank 1 grid -! + WRITE (MDST,8042) + DO J=1, NRGRP + WRITE (MDST,8044) J, MODMAP(:,J) + END DO + WRITE (MDST,8043) + DO J=1, NRGRP + WRITE (MDST,8044) J, LOADMP(:,J) + END DO +#endif + ! + ! 7.e Warnings + ! + IF ( NMPROC .GT. 1 ) THEN + DO I=1, NRGRP + IP1 = MINVAL ( LOADMP(:NCPROC,I) ) + IPN = MAXVAL ( LOADMP(:NCPROC,I) ) + IF ( IP1.NE.IPN .AND. IMPROC.EQ.NMPERR ) & + WRITE (MDSE,1040) I, IP1, IPN + END DO + END IF + ! + DEALLOCATE ( RP1, RPN, LOADMP ) + ! + ! 7.f Reset NMPSCR to first processor of first rank 1 grid + ! #ifdef W3_MPI - CALL WMSETM ( INGRP(1,1), MDSE, MDST ) - NMPSCR = CROOT + CALL WMSETM ( INGRP(1,1), MDSE, MDST ) + NMPSCR = CROOT #endif -! + ! #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) #endif -! -! 8. Actual initializations ----------------------------------------- / -! + ! + ! 8. Actual initializations ----------------------------------------- / + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8' - PRFT0 = PRFTN -#endif -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,980) - ALLOCATE ( TSYNC(2,0:NRGRD), TMAX(2,NRGRD), TOUTP(2,0:NRGRD), & - TDATA(2,NRGRD), GRSTAT(NRGRD), DTRES(NRGRD) ) -! - TSYNC(1,:) = -1 - TSYNC(2,:) = 0 - TMAX (1,:) = -1 - TMAX (2,:) = 0 - TOUTP(1,:) = -1 - TOUTP(2,:) = 0 - TDATA(1,:) = -1 - TDATA(2,:) = 0 - GRSTAT = 99 -! -! 8.a Loop over models for per-model initialization -! + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8' + PRFT0 = PRFTN +#endif + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,980) + ALLOCATE ( TSYNC(2,0:NRGRD), TMAX(2,NRGRD), TOUTP(2,0:NRGRD), & + TDATA(2,NRGRD), GRSTAT(NRGRD), DTRES(NRGRD) ) + ! + TSYNC(1,:) = -1 + TSYNC(2,:) = 0 + TMAX (1,:) = -1 + TMAX (2,:) = 0 + TOUTP(1,:) = -1 + TOUTP(2,:) = 0 + TDATA(1,:) = -1 + TDATA(2,:) = 0 + GRSTAT = 99 + ! + ! 8.a Loop over models for per-model initialization + ! #ifdef W3_T - WRITE (MDST,9080) + WRITE (MDST,9080) #endif #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.a' - PRFT0 = PRFTN -#endif -! - DO I=1, NRGRD - J = LEN_TRIM(MNAMES(I)) - DO NMPSC2=1, NMPROC - IF ( ALLPRC(NMPSC2,I) .EQ. 1 ) EXIT - END DO - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & - WRITE (MDSS,981) I, MNAMES(I)(1:J) -! + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.a' + PRFT0 = PRFTN +#endif + ! + DO I=1, NRGRD + J = LEN_TRIM(MNAMES(I)) + DO NMPSC2=1, NMPROC + IF ( ALLPRC(NMPSC2,I) .EQ. 1 ) EXIT + END DO + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & + WRITE (MDSS,981) I, MNAMES(I)(1:J) + ! #ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) #endif -! -! 8.a.1 Wave model initialization (NOTE: sets all grid pointers) -! ..... Initial output file hook up -! - CALL WMSETM ( I, MDSE, MDST ) + ! + ! 8.a.1 Wave model initialization (NOTE: sets all grid pointers) + ! ..... Initial output file hook up + ! + CALL WMSETM ( I, MDSE, MDST ) #ifdef W3_MPI - MPI_COMM_LOC = MPI_COMM_GRD - IF ( MPI_COMM_LOC .EQ. MPI_COMM_NULL ) CYCLE -#endif -! - CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) - CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., DESC='Log file' ) - MDS( 1,I) = NDSFND -! -! ... this one overwrites the combined setting MDS( 3,I) = MDST above -! -! CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) -! CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., DESC='Test output' ) -! MDS( 3,I) = NDSFND -! - DO J=1, 6 - IF ( J.EQ.4 .OR. J.EQ.5 ) CYCLE - IF ( ODAT(5*(J-1)+3,I) .GT. 0 ) THEN - CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) - CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & - DESC='Raw output file' ) - SELECT CASE (J) - CASE (1) - MDS(7,I) = NDSFND - CASE (2) - MDS(8,I) = NDSFND - CASE (3) - MDS(12,I) = NDSFND - CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) - CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & - DESC='Input data file' ) - MDS(11,I) = NDSFND - CASE (6) - MDS(13,I) = NDSFND - END SELECT - END IF - END DO -! - CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) - CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & - DESC='Input data file' ) - MDS(9,I) = NDSFND -! - IF ( ODAT(5*(5-1)+3,I) .GT. 0 ) THEN - CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT', 9 ) - MDS(10,I) = NDSFND - DO II=0, 8 - CALL WMUSET ( MDSE, MDST, NDSFND+II, .TRUE., & - DESC='Raw output file' ) - END DO - END IF -! -! ..... Model initialization -! - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,982) + MPI_COMM_LOC = MPI_COMM_GRD + IF ( MPI_COMM_LOC .EQ. MPI_COMM_NULL ) CYCLE +#endif + ! + CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) + CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., DESC='Log file' ) + MDS( 1,I) = NDSFND + ! + ! ... this one overwrites the combined setting MDS( 3,I) = MDST above + ! + ! CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) + ! CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., DESC='Test output' ) + ! MDS( 3,I) = NDSFND + ! + DO J=1, 6 + IF ( J.EQ.4 .OR. J.EQ.5 ) CYCLE + IF ( ODAT(5*(J-1)+3,I) .GT. 0 ) THEN + CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) + CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & + DESC='Raw output file' ) + SELECT CASE (J) + CASE (1) + MDS(7,I) = NDSFND + CASE (2) + MDS(8,I) = NDSFND + CASE (3) + MDS(12,I) = NDSFND + CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) + CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & + DESC='Input data file' ) + MDS(11,I) = NDSFND + CASE (6) + MDS(13,I) = NDSFND + END SELECT + END IF + END DO + ! + CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) + CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & + DESC='Input data file' ) + MDS(9,I) = NDSFND + ! + IF ( ODAT(5*(5-1)+3,I) .GT. 0 ) THEN + CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT', 9 ) + MDS(10,I) = NDSFND + DO II=0, 8 + CALL WMUSET ( MDSE, MDST, NDSFND+II, .TRUE., & + DESC='Raw output file' ) + END DO + END IF + ! + ! ..... Model initialization + ! + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,982) - CALL W3INIT ( I, .TRUE., MNAMES(I), MDS(:,I), NTRACE(:,I), & - ODAT(:,I), & - FLGRD(:,:,I),FLGR2(:,:,I),FLGD(:,I),FLG2(:,I), & - OT2(I)%NPTS, OT2(I)%X, OT2(I)%Y, OT2(I)%PNAMES, & - IPRT(:,I), LPRT(I), MPI_COMM_LOC) -! -! ..... Finalize I/O file hook up -! - II = LEN_TRIM(FILEXT) - JJ = LEN_TRIM(FNMPRE) - CALL WMUINQ ( MDSE, MDST, MDS(1,I) ) - IF ( MDS(3,I) .NE. MDST ) CALL WMUINQ ( MDSE, MDST, MDS(3,I) ) -! - IF ( MDS(7,I) .NE. -1 ) THEN - IF ( IAPROC .EQ. NAPFLD ) THEN - TNAME = TRIM(FNMPRE)//'out_grd.' // FILEXT(:II) - CALL WMUSET ( MDSE,MDST, MDS(7,I), .TRUE., NAME=TNAME ) - ELSE - CALL WMUSET ( MDSE,MDST, MDS(7,I), .FALSE. ) - MDS(7,I) = -1 - END IF - END IF -! - IF ( MDS(8,I) .NE. -1 ) THEN - IF ( IAPROC .EQ. NAPPNT ) THEN - TNAME = TRIM(FNMPRE)//'out_pnt.' // FILEXT(:II) - CALL WMUSET ( MDSE,MDST, MDS(8,I), .TRUE., NAME=TNAME ) - ELSE - CALL WMUSET ( MDSE,MDST, MDS(8,I), .FALSE. ) - MDS(8,I) = -1 - END IF - END IF -! - IF ( MDS(9,I) .NE. -1 ) THEN - IF ( FLBPI ) THEN - TNAME = TRIM(FNMPRE)//'nest.' // FILEXT(:II) - CALL WMUSET ( MDSE, MDST, MDS(9,I), .TRUE., NAME=TNAME ) - ELSE - CALL WMUSET ( MDSE, MDST, MDS(9,I), .FALSE. ) - MDS(9,I) = -1 - END IF - END IF -! - IF ( MDS(10,I) .NE. -1 ) THEN - IF ( FLBPO .AND. IAPROC.EQ.NAPBPT ) THEN - TNAME = TRIM(FNMPRE)//'nestN.' // FILEXT(:II) - DO J=0, NFBPO-1 - WRITE (TNAME(JJ+5:JJ+5),'(I1)') J + 1 - CALL WMUSET ( MDSE, MDST, MDS(10,I)+J, .TRUE., & - NAME=TNAME ) - END DO - DO J=NFBPO, 8 - CALL WMUSET ( MDSE,MDST, MDS(10,I)+J, .FALSE. ) - END DO - ELSE - DO J=0, 8 - CALL WMUSET ( MDSE,MDST, MDS(10,I)+J, .FALSE. ) - END DO - MDS(10,I) = -1 - END IF - END IF -! - IF ( MDS(11,I) .NE. -1 ) THEN - TNAME = TRIM(FNMPRE)//'track_i.' // FILEXT(:II) - CALL WMUSET ( MDSE,MDST, MDS(11,I), .TRUE., NAME=TNAME ) - END IF -! - IF ( MDS(12,I) .NE. -1 ) THEN - IF ( IAPROC .EQ. NAPTRK ) THEN - TNAME = TRIM(FNMPRE)//'track_o.' // FILEXT(:II) - CALL WMUSET ( MDSE,MDST, MDS(12,I), .TRUE., NAME=TNAME ) - ELSE - CALL WMUSET ( MDSE,MDST, MDS(12,I), .FALSE. ) - MDS(12,I) = -1 - END IF - END IF -! - IF ( MDS(13,I) .NE. -1 ) THEN - IF ( IAPROC .EQ. NAPPRT ) THEN - TNAME = TRIM(FNMPRE)//'partition.' // FILEXT(:II) - CALL WMUSET ( MDSE,MDST, MDS(13,I), .TRUE., NAME=TNAME ) - ELSE - CALL WMUSET ( MDSE,MDST, MDS(13,I), .FALSE. ) - MDS(13,I) = -1 - END IF - END IF -! -#ifdef W3_T - WRITE (MDST,9081) I, TIME -#endif -! -! 8.a.2 Data file initialization (forcing) -! - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,983) - CALL W3SETI ( I, MDSE, MDST ) -! -!!Li Stop modifying GTYPE from input forcing file. JGLi08Apr2021. - JJJ = GTYPE -! -! ..... regular input files -! - DO J=JFIRST, 6 - IF ( INFLAGS1(J) ) THEN - IDINP(I,J) = IDSTR(J) - IF ( INPMAP(I,J) .LT. 0 ) CYCLE - CALL W3FLDO ('READ', IDINP(I,J), MDSF(I,J), MDST, MDSE2,& -!!Li NX, NY, GTYPE, IERR, MNAMES(I), & - NX, NY, JJJ, IERR, MNAMES(I), & - TRIM(FNMPRE) ) - IF ( IERR .NE. 0 ) GOTO 2080 -! -!!Li Print a warning message when GTYPE not matching forcing field one. - IF ( (JJJ .NE. GTYPE) .AND. (IMPROC .EQ. NMPSC2) ) & - WRITE (MDSE, *) ' *** Warning: grid', I, ' GTYPE=', & - GTYPE, ' not matching field', J, ' grid type', JJJ -! - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & - WRITE (MDSS,985) IDFLDS(J) - ELSE - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & - WRITE (MDSS,984) IDFLDS(J) - END IF + CALL W3INIT ( I, .TRUE., MNAMES(I), MDS(:,I), NTRACE(:,I), & + ODAT(:,I), & + FLGRD(:,:,I),FLGR2(:,:,I),FLGD(:,I),FLG2(:,I), & + OT2(I)%NPTS, OT2(I)%X, OT2(I)%Y, OT2(I)%PNAMES, & + IPRT(:,I), LPRT(I), MPI_COMM_LOC) + ! + ! ..... Finalize I/O file hook up + ! + II = LEN_TRIM(FILEXT) + JJ = LEN_TRIM(FNMPRE) + CALL WMUINQ ( MDSE, MDST, MDS(1,I) ) + IF ( MDS(3,I) .NE. MDST ) CALL WMUINQ ( MDSE, MDST, MDS(3,I) ) + ! + IF ( MDS(7,I) .NE. -1 ) THEN + IF ( IAPROC .EQ. NAPFLD ) THEN + TNAME = TRIM(FNMPRE)//'out_grd.' // FILEXT(:II) + CALL WMUSET ( MDSE,MDST, MDS(7,I), .TRUE., NAME=TNAME ) + ELSE + CALL WMUSET ( MDSE,MDST, MDS(7,I), .FALSE. ) + MDS(7,I) = -1 + END IF + END IF + ! + IF ( MDS(8,I) .NE. -1 ) THEN + IF ( IAPROC .EQ. NAPPNT ) THEN + TNAME = TRIM(FNMPRE)//'out_pnt.' // FILEXT(:II) + CALL WMUSET ( MDSE,MDST, MDS(8,I), .TRUE., NAME=TNAME ) + ELSE + CALL WMUSET ( MDSE,MDST, MDS(8,I), .FALSE. ) + MDS(8,I) = -1 + END IF + END IF + ! + IF ( MDS(9,I) .NE. -1 ) THEN + IF ( FLBPI ) THEN + TNAME = TRIM(FNMPRE)//'nest.' // FILEXT(:II) + CALL WMUSET ( MDSE, MDST, MDS(9,I), .TRUE., NAME=TNAME ) + ELSE + CALL WMUSET ( MDSE, MDST, MDS(9,I), .FALSE. ) + MDS(9,I) = -1 + END IF + END IF + ! + IF ( MDS(10,I) .NE. -1 ) THEN + IF ( FLBPO .AND. IAPROC.EQ.NAPBPT ) THEN + TNAME = TRIM(FNMPRE)//'nestN.' // FILEXT(:II) + DO J=0, NFBPO-1 + WRITE (TNAME(JJ+5:JJ+5),'(I1)') J + 1 + CALL WMUSET ( MDSE, MDST, MDS(10,I)+J, .TRUE., & + NAME=TNAME ) END DO -! -! ..... assimilation data files -! -! version 3.07: Data assimilation part ignored for now .... -! -! ..... finalize file info data base -! - DO J=JFIRST, 9 - IF ( MDSF(I,J) .NE. -1 ) CALL WMUINQ ( MDSE, MDST, MDSF(I,J) ) + DO J=NFBPO, 8 + CALL WMUSET ( MDSE,MDST, MDS(10,I)+J, .FALSE. ) END DO -! -! ..... Adjust input flags for other than native or CPL input, -! and initialize input arrays one set at a time as needed. -! - IF ( SIZE(INFLAGS1) .NE. SIZE(TFLAGS) ) THEN - WRITE (MDSE,'(/2A)') ' *** ERROR WMINIT: ', & - 'SIZE(INFLAGS1).NE.SIZE(TFLAGS) ***' - CALL EXTCDE ( 999 ) + ELSE + DO J=0, 8 + CALL WMUSET ( MDSE,MDST, MDS(10,I)+J, .FALSE. ) + END DO + MDS(10,I) = -1 END IF - IF ( SIZE(INFLAGS2) .NE. SIZE(TFLAGS) ) THEN - WRITE (MDSE,'(/2A)') ' *** ERROR WMINIT: ', & - 'SIZE(INFLAGS2).NE.SIZE(TFLAGS) ***' - CALL EXTCDE ( 999 ) + END IF + ! + IF ( MDS(11,I) .NE. -1 ) THEN + TNAME = TRIM(FNMPRE)//'track_i.' // FILEXT(:II) + CALL WMUSET ( MDSE,MDST, MDS(11,I), .TRUE., NAME=TNAME ) + END IF + ! + IF ( MDS(12,I) .NE. -1 ) THEN + IF ( IAPROC .EQ. NAPTRK ) THEN + TNAME = TRIM(FNMPRE)//'track_o.' // FILEXT(:II) + CALL WMUSET ( MDSE,MDST, MDS(12,I), .TRUE., NAME=TNAME ) + ELSE + CALL WMUSET ( MDSE,MDST, MDS(12,I), .FALSE. ) + MDS(12,I) = -1 END IF + END IF + ! + IF ( MDS(13,I) .NE. -1 ) THEN + IF ( IAPROC .EQ. NAPPRT ) THEN + TNAME = TRIM(FNMPRE)//'partition.' // FILEXT(:II) + CALL WMUSET ( MDSE,MDST, MDS(13,I), .TRUE., NAME=TNAME ) + ELSE + CALL WMUSET ( MDSE,MDST, MDS(13,I), .FALSE. ) + MDS(13,I) = -1 + END IF + END IF + ! +#ifdef W3_T + WRITE (MDST,9081) I, TIME +#endif + ! + ! 8.a.2 Data file initialization (forcing) + ! + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,983) + CALL W3SETI ( I, MDSE, MDST ) + ! + !!Li Stop modifying GTYPE from input forcing file. JGLi08Apr2021. + JJJ = GTYPE + ! + ! ..... regular input files + ! + DO J=JFIRST, 6 + IF ( INFLAGS1(J) ) THEN + IDINP(I,J) = IDSTR(J) + IF ( INPMAP(I,J) .LT. 0 ) CYCLE + CALL W3FLDO ('READ', IDINP(I,J), MDSF(I,J), MDST, MDSE2,& + !!Li NX, NY, GTYPE, IERR, MNAMES(I), & + NX, NY, JJJ, IERR, MNAMES(I), & + TRIM(FNMPRE) ) + IF ( IERR .NE. 0 ) GOTO 2080 + ! + !!Li Print a warning message when GTYPE not matching forcing field one. + IF ( (JJJ .NE. GTYPE) .AND. (IMPROC .EQ. NMPSC2) ) & + WRITE (MDSE, *) ' *** Warning: grid', I, ' GTYPE=', & + GTYPE, ' not matching field', J, ' grid type', JJJ + ! + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & + WRITE (MDSS,985) IDFLDS(J) + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & + WRITE (MDSS,984) IDFLDS(J) + END IF + END DO + ! + ! ..... assimilation data files + ! + ! version 3.07: Data assimilation part ignored for now .... + ! + ! ..... finalize file info data base + ! + DO J=JFIRST, 9 + IF ( MDSF(I,J) .NE. -1 ) CALL WMUINQ ( MDSE, MDST, MDSF(I,J) ) + END DO + ! + ! ..... Adjust input flags for other than native or CPL input, + ! and initialize input arrays one set at a time as needed. + ! + IF ( SIZE(INFLAGS1) .NE. SIZE(TFLAGS) ) THEN + WRITE (MDSE,'(/2A)') ' *** ERROR WMINIT: ', & + 'SIZE(INFLAGS1).NE.SIZE(TFLAGS) ***' + CALL EXTCDE ( 999 ) + END IF + IF ( SIZE(INFLAGS2) .NE. SIZE(TFLAGS) ) THEN + WRITE (MDSE,'(/2A)') ' *** ERROR WMINIT: ', & + 'SIZE(INFLAGS2).NE.SIZE(TFLAGS) ***' + CALL EXTCDE ( 999 ) + END IF - TFLAGS = INFLAGS1 -! - DO J=JFIRST, 9 - IF ( INPMAP(I,J) .NE. 0 ) THEN -! - TFLAGS(J) = .TRUE. - INFLAGS1 = .FALSE. - INFLAGS1(J) = .TRUE. - IINIT = .FALSE. - CALL W3DIMI ( I, MDSE, MDST ) -! - IF ( J.EQ.2 ) ALLOCATE ( WADATS(I)%CA0(NSEA) , & - WADATS(I)%CAI(NSEA) , & - WADATS(I)%CD0(NSEA) , & - WADATS(I)%CDI(NSEA) ) -! - IF ( J.EQ.3 ) ALLOCATE ( WADATS(I)%UA0(NSEA) , & - WADATS(I)%UAI(NSEA) , & - WADATS(I)%UD0(NSEA) , & - WADATS(I)%UDI(NSEA) , & - WADATS(I)%AS0(NSEA) , & - WADATS(I)%ASI(NSEA) ) -! - IF ( J.EQ.5 ) ALLOCATE ( WADATS(I)%MA0(NSEA) , & - WADATS(I)%MAI(NSEA) , & - WADATS(I)%MD0(NSEA) , & - WADATS(I)%MDI(NSEA) ) -! - IF ( J.EQ.6 ) ALLOCATE ( WADATS(I)%RA0(NSEA) , & - WADATS(I)%RAI(NSEA) ) -! - END IF ! IF ( INPMAP(I,J) .NE. 0 ) THEN - END DO ! DO J=JFIRST, 9 -! - INFLAGS1 = TFLAGS - CALL W3SETI ( I, MDSE, MDST ) - CALL W3SETA ( I, MDSE, MDST ) -! -! 8.a.3 Status indicator and model times -! - DO J=1, NOTYPE - IF ( FLOUT(J) ) THEN - IF ( TOUTP(1,I) .EQ. -1 ) THEN - TOUTP(:,I) = TONEXT(:,J) - ELSE - DTTST = DSEC21 ( TOUTP(:,I), TONEXT(:,J) ) - IF ( DTTST .LT. 0. ) TOUTP(:,I) = TONEXT(:,J) - ENDIF - END IF - END DO -! -! CHECKPOINT - J=8 + TFLAGS = INFLAGS1 + ! + DO J=JFIRST, 9 + IF ( INPMAP(I,J) .NE. 0 ) THEN + ! + TFLAGS(J) = .TRUE. + INFLAGS1 = .FALSE. + INFLAGS1(J) = .TRUE. + IINIT = .FALSE. + CALL W3DIMI ( I, MDSE, MDST ) + ! + IF ( J.EQ.2 ) ALLOCATE ( WADATS(I)%CA0(NSEA) , & + WADATS(I)%CAI(NSEA) , & + WADATS(I)%CD0(NSEA) , & + WADATS(I)%CDI(NSEA) ) + ! + IF ( J.EQ.3 ) ALLOCATE ( WADATS(I)%UA0(NSEA) , & + WADATS(I)%UAI(NSEA) , & + WADATS(I)%UD0(NSEA) , & + WADATS(I)%UDI(NSEA) , & + WADATS(I)%AS0(NSEA) , & + WADATS(I)%ASI(NSEA) ) + ! + IF ( J.EQ.5 ) ALLOCATE ( WADATS(I)%MA0(NSEA) , & + WADATS(I)%MAI(NSEA) , & + WADATS(I)%MD0(NSEA) , & + WADATS(I)%MDI(NSEA) ) + ! + IF ( J.EQ.6 ) ALLOCATE ( WADATS(I)%RA0(NSEA) , & + WADATS(I)%RAI(NSEA) ) + ! + END IF ! IF ( INPMAP(I,J) .NE. 0 ) THEN + END DO ! DO J=JFIRST, 9 + ! + INFLAGS1 = TFLAGS + CALL W3SETI ( I, MDSE, MDST ) + CALL W3SETA ( I, MDSE, MDST ) + ! + ! 8.a.3 Status indicator and model times + ! + DO J=1, NOTYPE IF ( FLOUT(J) ) THEN - IF ( TOUTP(1,I) .EQ. -1 ) THEN - TOUTP(:,I) = TONEXT(:,J) - ELSE - DTTST = DSEC21 ( TOUTP(:,I), TONEXT(:,J) ) - IF ( DTTST .LT. 0. ) TOUTP(:,I) = TONEXT(:,J) - ENDIF + IF ( TOUTP(1,I) .EQ. -1 ) THEN + TOUTP(:,I) = TONEXT(:,J) + ELSE + DTTST = DSEC21 ( TOUTP(:,I), TONEXT(:,J) ) + IF ( DTTST .LT. 0. ) TOUTP(:,I) = TONEXT(:,J) + ENDIF END IF -! -! - GRSTAT(I) = 0 - TSYNC(:,I) = TIME(:) -! + END DO + ! + ! CHECKPOINT + J=8 + IF ( FLOUT(J) ) THEN + IF ( TOUTP(1,I) .EQ. -1 ) THEN + TOUTP(:,I) = TONEXT(:,J) + ELSE + DTTST = DSEC21 ( TOUTP(:,I), TONEXT(:,J) ) + IF ( DTTST .LT. 0. ) TOUTP(:,I) = TONEXT(:,J) + ENDIF + END IF + ! + ! + GRSTAT(I) = 0 + TSYNC(:,I) = TIME(:) + ! #ifdef W3_SMC -! Check GTYPE values after initialization - IF ( IMPROC .EQ. NMPERR ) WRITE(MDSE,*) "GRID IMPROC GTYPE", & - I, IMPROC, GRIDS(I)%GTYPE + ! Check GTYPE values after initialization + IF ( IMPROC .EQ. NMPERR ) WRITE(MDSE,*) "GRID IMPROC GTYPE", & + I, IMPROC, GRIDS(I)%GTYPE #endif -! + ! #ifdef W3_T - WRITE (MDST,9082) GRSTAT(I), TOUTP(:,I), TSYNC(:,I) + WRITE (MDST,9082) GRSTAT(I), TOUTP(:,I), TSYNC(:,I) #endif -! - END DO !! 8.a I-NRGRD loop -! + ! + END DO !! 8.a I-NRGRD loop + ! #ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) - DO I=1, NRGRD - CALL WMSETM ( I, MDSE, MDST ) - CALL W3SETG ( I, MDSE, MDST ) - CALL W3SETO ( I, MDSE, MDST ) - IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN - CALL MPI_BCAST ( TOUTP(1,I), 2, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( TSYNC(1,I), 2, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( GRSTAT(I), 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) -#endif -! -! 8.a.4 Grid sizes etc. for processors that are not used. -! + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN + CALL MPI_BCAST ( TOUTP(1,I), 2, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TSYNC(1,I), 2, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRSTAT(I), 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif + ! + ! 8.a.4 Grid sizes etc. for processors that are not used. + ! #ifdef W3_MPI - CALL MPI_BCAST ( FLAGLL,1, MPI_LOGICAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( GTYPE, 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( ICLOSE,1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NX , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NY , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( X0 , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( SX , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( Y0 , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( SY , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NSEA , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NSEAL, 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DTMAX, 1, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DTCFL, 1, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( FILEXT, 10, MPI_CHARACTER, 0, & - MPI_COMM_BCT, IERR_MPI ) - IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & - CALL W3DIMX ( I, NX, NY, NSEA, MDSE, MDST & + CALL MPI_BCAST ( FLAGLL,1, MPI_LOGICAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GTYPE, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( ICLOSE,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NX , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NY , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( X0 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( SX , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( Y0 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( SY , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NSEA , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NSEAL, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTMAX, 1, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTCFL, 1, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( FILEXT, 10, MPI_CHARACTER, 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + CALL W3DIMX ( I, NX, NY, NSEA, MDSE, MDST & #endif #ifdef W3_SMC - !! SMC grid related variables are not needed beyond MPI_COMM_GRD - !! so all dimensions are minimised to 1. JGLi29Mar2021 + !! SMC grid related variables are not needed beyond MPI_COMM_GRD + !! so all dimensions are minimised to 1. JGLi29Mar2021 #endif #ifdef W3_MPI #ifdef W3_SMC - !!Li , NCel, NUFc, NVFc, NRLv, NBSMC & - !!Li , NARC, NBAC, NSPEC & + !!Li , NCel, NUFc, NVFc, NRLv, NBSMC & + !!Li , NARC, NBAC, NSPEC & , 1, 1, 1, 1, 1, 1, 1, 1 & #endif - ) - CALL MPI_BCAST ( HQFAC, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( HPFAC, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( XGRD, NX*NY, MPI_DOUBLE_PRECISION, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( YGRD, NX*NY, MPI_DOUBLE_PRECISION, 0, & - MPI_COMM_BCT, IERR_MPI ) - IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & - GSU = W3GSUC( .FALSE., FLAGLL, ICLOSE, & - XGRD, YGRD ) - CALL MPI_BCAST ( DXDP, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DXDQ, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DYDP, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DYDQ, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( MAPSTA, NX*NY, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( MAPST2, NX*NY, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( GRIDSHIFT, 1, MPI_DOUBLE_PRECISION, 0, & - MPI_COMM_BCT, IERR_MPI ) -#endif -! + ) + CALL MPI_BCAST ( HQFAC, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( HPFAC, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( XGRD, NX*NY, MPI_DOUBLE_PRECISION, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( YGRD, NX*NY, MPI_DOUBLE_PRECISION, 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + GSU = W3GSUC( .FALSE., FLAGLL, ICLOSE, & + XGRD, YGRD ) + CALL MPI_BCAST ( DXDP, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DXDQ, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DYDP, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DYDQ, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( MAPSTA, NX*NY, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( MAPST2, NX*NY, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRIDSHIFT, 1, MPI_DOUBLE_PRECISION, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif + ! #ifdef W3_MPI - CALL MPI_BCAST ( NK , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NTH , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( XFR , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( FR1 , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & - CALL W3DIMS ( I, NK, NTH, MDSE, MDST ) - CALL MPI_BCAST ( TH , NTH, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) -#endif -! + CALL MPI_BCAST ( NK , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NTH , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( XFR , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( FR1 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + CALL W3DIMS ( I, NK, NTH, MDSE, MDST ) + CALL MPI_BCAST ( TH , NTH, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif + ! #ifdef W3_MPI - CALL MPI_BCAST ( NAPROC,1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NAPPNT,1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NBI , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) -#endif -! + CALL MPI_BCAST ( NAPROC,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NAPPNT,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NBI , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif + ! #ifdef W3_MPI - CALL MPI_BCAST ( FLOUT, 8, MPI_LOGICAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DTOUT , 8, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( TONEXT,16, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( TOLAST,16, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) -#endif -! + CALL MPI_BCAST ( FLOUT, 8, MPI_LOGICAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTOUT , 8, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TONEXT,16, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TOLAST,16, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif + ! #ifdef W3_MPI - END IF - END DO - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) + END IF + END DO + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) #endif -! - DO I=1, NRGRD - IF ( ALLPRC(IMPROC,I) .EQ. 0 ) THEN - CALL W3SETO ( I, MDSE, MDST ) - IAPROC = -1 - END IF - END DO -! -! 8.a.5 Test output -! + ! + DO I=1, NRGRD + IF ( ALLPRC(IMPROC,I) .EQ. 0 ) THEN + CALL W3SETO ( I, MDSE, MDST ) + IAPROC = -1 + END IF + END DO + ! + ! 8.a.5 Test output + ! #ifdef W3_T - WRITE (MDST,9020) 'AFTER SETUP' - DO I=1, NRGRD - WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) - END DO -#endif -! -! 8.a.6 Check for coordinate system -! - DO I=1, NRGRD-1 - IF ( GRIDS(I)%FLAGLL .NEQV. GRIDS(I+1)%FLAGLL ) GOTO 2070 - END DO -! -! 8.b Input files -! + WRITE (MDST,9020) 'AFTER SETUP' + DO I=1, NRGRD + WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) + END DO +#endif + ! + ! 8.a.6 Check for coordinate system + ! + DO I=1, NRGRD-1 + IF ( GRIDS(I)%FLAGLL .NEQV. GRIDS(I+1)%FLAGLL ) GOTO 2070 + END DO + ! + ! 8.b Input files + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.c' - PRFT0 = PRFTN -#endif -! - DO I=1, NRINP -! - IF ( .NOT. USEINP(I) ) CYCLE -! - J = LEN_TRIM(MNAMES(-I)) - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) THEN - WRITE (MDSS,988) I, MNAMES(-I)(1:J) - WRITE (MDSS,987) - END IF -! - CALL W3IOGR ( 'GRID', NDSREC, -I, MNAMES(-I)(1:J) ) - CALL W3DIMI ( -I, MDSE, MDST ) -! - IF ( CPLINP(I) ) CYCLE -! - DO J=JFIRST, 6 - IF ( INFLAGS1(J) ) THEN - IDINP(-I,J) = IDSTR(J) - CALL W3FLDO ('READ', IDINP(-I,J), MDSF(-I,J), MDST, & - MDSE2, NX, NY, GTYPE, IERR, & - MNAMES(-I), TRIM(FNMPRE) ) - IF ( IERR .NE. 0 ) GOTO 2080 - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & - WRITE (MDSS,985) IDFLDS(J) - ELSE - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & - WRITE (MDSS,984) IDFLDS(J) - END IF - END DO -! -! Skipping assimilation input files for now. -! - DO J=JFIRST, 9 - IF ( MDSF(-I,J) .NE. -1 ) CALL WMUINQ & - ( MDSE, MDST, MDSF(-I,J) ) - END DO -! - END DO -! - DO I=1, NRGRD - DO J=JFIRST, 9 - IF ( INPMAP(I,J).LT.0 .AND. INPMAP(I,J).NE.-999) IDINP(I,J) = IDINP( INPMAP(I,J),J) - !IF ( INPMAP(I,J) .LT. 0 ) IDINP(I,J) = IDINP( INPMAP(I,J),J) - IF ( INPMAP(I,J) .GT. 0 ) IDINP(I,J) = IDINP(-INPMAP(I,J),J) - END DO - END DO -! - DEALLOCATE ( USEINP ) - DEALLOCATE ( CPLINP ) -! -! 8.c Inter model initialization -! + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.c' + PRFT0 = PRFTN +#endif + ! + DO I=1, NRINP + ! + IF ( .NOT. USEINP(I) ) CYCLE + ! + J = LEN_TRIM(MNAMES(-I)) + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) THEN + WRITE (MDSS,988) I, MNAMES(-I)(1:J) + WRITE (MDSS,987) + END IF + ! + CALL W3IOGR ( 'GRID', NDSREC, -I, MNAMES(-I)(1:J) ) + CALL W3DIMI ( -I, MDSE, MDST ) + ! + IF ( CPLINP(I) ) CYCLE + ! + DO J=JFIRST, 6 + IF ( INFLAGS1(J) ) THEN + IDINP(-I,J) = IDSTR(J) + CALL W3FLDO ('READ', IDINP(-I,J), MDSF(-I,J), MDST, & + MDSE2, NX, NY, GTYPE, IERR, & + MNAMES(-I), TRIM(FNMPRE) ) + IF ( IERR .NE. 0 ) GOTO 2080 + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & + WRITE (MDSS,985) IDFLDS(J) + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & + WRITE (MDSS,984) IDFLDS(J) + END IF + END DO + ! + ! Skipping assimilation input files for now. + ! + DO J=JFIRST, 9 + IF ( MDSF(-I,J) .NE. -1 ) CALL WMUINQ & + ( MDSE, MDST, MDSF(-I,J) ) + END DO + ! + END DO + ! + DO I=1, NRGRD + DO J=JFIRST, 9 + IF ( INPMAP(I,J).LT.0 .AND. INPMAP(I,J).NE.-999) IDINP(I,J) = IDINP( INPMAP(I,J),J) + !IF ( INPMAP(I,J) .LT. 0 ) IDINP(I,J) = IDINP( INPMAP(I,J),J) + IF ( INPMAP(I,J) .GT. 0 ) IDINP(I,J) = IDINP(-INPMAP(I,J),J) + END DO + END DO + ! + DEALLOCATE ( USEINP ) + DEALLOCATE ( CPLINP ) + ! + ! 8.c Inter model initialization + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.d' - PRFT0 = PRFTN + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.d' + PRFT0 = PRFTN #endif -! 8.c.1 Spectral conversion flags and source term flags -! - CALL WMRSPC -! - DO I=1, NRGRD - CALL W3SETG ( I, MDSE, MDST ) - FLAGST = .TRUE. - END DO -! -! 8.c.2 Relation to lower ranked grids -! Includes update of unit numbers, and bound. data initialization. -! - ALLOCATE ( FLRBPI(NRGRD) ) - CALL WMGLOW ( FLRBPI ) -! -! ..... At this point the grid-search-utility (GSU) object for grids -! that do not belong to this processor is no longer needed. -! + ! 8.c.1 Spectral conversion flags and source term flags + ! + CALL WMRSPC + ! + DO I=1, NRGRD + CALL W3SETG ( I, MDSE, MDST ) + FLAGST = .TRUE. + END DO + ! + ! 8.c.2 Relation to lower ranked grids + ! Includes update of unit numbers, and bound. data initialization. + ! + ALLOCATE ( FLRBPI(NRGRD) ) + CALL WMGLOW ( FLRBPI ) + ! + ! ..... At this point the grid-search-utility (GSU) object for grids + ! that do not belong to this processor is no longer needed. + ! #ifdef W3_MPI - DO I=1, NRGRD - CALL WMSETM ( I, MDSE, MDST ) - CALL W3SETG ( I, MDSE, MDST ) -#endif -! the next line (with the W3GSUD call) removed Jan 8 2013. -! ...ref: personal communication, -! ...email from Rogers to Alves, Campbell, Tolman, Chawla Dec 13 2012. -! REMOVED !/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) CALL W3GSUD( GSU ) + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) +#endif + ! the next line (with the W3GSUD call) removed Jan 8 2013. + ! ...ref: personal communication, + ! ...email from Rogers to Alves, Campbell, Tolman, Chawla Dec 13 2012. + ! REMOVED !/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) CALL W3GSUD( GSU ) #ifdef W3_MPI - END DO + END DO #endif -! -! ..... Unit numbers -! + ! + ! ..... Unit numbers + ! - DO I=1, NRGRD -! - CALL W3SETG ( I, MDSE, MDST ) - CALL W3SETO ( I, MDSE, MDST ) -! - IF ( BCDUMP(I) .AND. FLRBPI(I) ) THEN - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1080) I - IF ( IMPROC .EQ. NMPLOG ) WRITE (MDSO,1082) I - BCDUMP(I) = .FALSE. - END IF -! - IF ( BCDUMP(I) .AND. NBI.EQ.0 ) THEN - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1081) I - IF ( IMPROC .EQ. NMPLOG ) WRITE (MDSO,1082) I - BCDUMP(I) = .FALSE. - END IF -! + DO I=1, NRGRD + ! + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + ! + IF ( BCDUMP(I) .AND. FLRBPI(I) ) THEN + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1080) I + IF ( IMPROC .EQ. NMPLOG ) WRITE (MDSO,1082) I + BCDUMP(I) = .FALSE. + END IF + ! + IF ( BCDUMP(I) .AND. NBI.EQ.0 ) THEN + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1081) I + IF ( IMPROC .EQ. NMPLOG ) WRITE (MDSO,1082) I + BCDUMP(I) = .FALSE. + END IF + ! #ifdef W3_SHRD - IF ( .NOT. FLRBPI(I) .AND. FLBPI ) THEN + IF ( .NOT. FLRBPI(I) .AND. FLBPI ) THEN #endif #ifdef W3_MPI IF ( .NOT. FLRBPI(I) .AND. FLBPI .AND. & - MPI_COMM_GRD .NE. MPI_COMM_NULL) THEN -#endif - CALL WMUSET ( MDSE, MDST, NDS(9), .FALSE. ) - IF ( BCDUMP(I) .AND. IAPROC.EQ.NAPBPT ) THEN - J = LEN_TRIM(FILEXT) - TNAME(1:5) = 'nest.' - TNAME(6:5+J) = FILEXT(1:J) - J = J + 5 - CALL WMUGET ( MDSE, MDST, NDS(9), 'OUT' ) - CALL WMUSET ( MDSE, MDST, NDS(9), .TRUE., & - NAME=TRIM(FNMPRE)//TNAME(1:J), & - DESC='Output data file (nest dump)' ) - MDS(9,I) = NDSFND - ELSE - NDS(9) = -1 - END IF -#ifdef W3_MPI + MPI_COMM_GRD .NE. MPI_COMM_NULL) THEN +#endif + CALL WMUSET ( MDSE, MDST, NDS(9), .FALSE. ) + IF ( BCDUMP(I) .AND. IAPROC.EQ.NAPBPT ) THEN + J = LEN_TRIM(FILEXT) + TNAME(1:5) = 'nest.' + TNAME(6:5+J) = FILEXT(1:J) + J = J + 5 + CALL WMUGET ( MDSE, MDST, NDS(9), 'OUT' ) + CALL WMUSET ( MDSE, MDST, NDS(9), .TRUE., & + NAME=TRIM(FNMPRE)//TNAME(1:J), & + DESC='Output data file (nest dump)' ) + MDS(9,I) = NDSFND + ELSE + NDS(9) = -1 END IF +#ifdef W3_MPI + END IF #endif #ifdef W3_SHRD - END IF + END IF #endif -! - END DO -! -! ..... Data initialization -! - DO I=1, NRGRD + ! + END DO + ! + ! ..... Data initialization + ! + DO I=1, NRGRD #ifdef W3_MPI - CALL WMSETM ( I, MDSE, MDST ) - IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBS ( I ) + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBS ( I ) #endif #ifdef W3_SHRD - CALL WMIOBS ( I ) + CALL WMIOBS ( I ) #endif - END DO -! - DO I=1, NRGRD + END DO + ! + DO I=1, NRGRD #ifdef W3_MPI - CALL WMSETM ( I, MDSE, MDST ) - IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBG ( I ) + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBG ( I ) #endif #ifdef W3_SHRD - CALL WMIOBG ( I ) + CALL WMIOBG ( I ) #endif - END DO -! + END DO + ! #ifdef W3_MPI - DO I=1, NRGRD - CALL WMSETM ( I, MDSE, MDST ) - IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBF ( I ) - END DO -#endif -! -! 8.c.3 Relation to same ranked grids -! + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBF ( I ) + END DO +#endif + ! + ! 8.c.3 Relation to same ranked grids + ! #ifdef W3_SMC - !! Check whether there is a SMC grid group. JGLi12Apr2021 - NGRPSMC = 0 - DO JJ=1, NRGRP - J = 0 - DO II=1, INGRP(JJ,0) - I = INGRP(JJ,II) - IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) J = J + 1 - ENDDO - IF( J .GT. 1 ) NGRPSMC = JJ + !! Check whether there is a SMC grid group. JGLi12Apr2021 + NGRPSMC = 0 + DO JJ=1, NRGRP + J = 0 + DO II=1, INGRP(JJ,0) + I = INGRP(JJ,II) + IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) J = J + 1 ENDDO - IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " NGRPSMC =", NGRPSMC - - !! Equal ranked SMC grid group uses its own sub. JGLi12Apr2021 - IF( NGRPSMC .GT. 0 ) THEN - CALL WMSMCEQL - ELSE + IF( J .GT. 1 ) NGRPSMC = JJ + ENDDO + IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " NGRPSMC =", NGRPSMC + + !! Equal ranked SMC grid group uses its own sub. JGLi12Apr2021 + IF( NGRPSMC .GT. 0 ) THEN + CALL WMSMCEQL + ELSE #endif -! + ! CALL WMGEQL -! + ! #ifdef W3_SMC - ENDIF -#endif -! -! 8.c.4 Relation to higher ranked grids -! - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,938) & - 'Computing relation to higher ranked grids' - CALL WMGHGH - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,938) & - 'Finished computing relation to higher ranked grids' -! -! 8.c.5 Unified point output -! - IF ( UNIPTS ) THEN -! - OUTPTS(0)%TONEXT(1,2) = ODAT( 6,0) - OUTPTS(0)%TONEXT(2,2) = ODAT( 7,0) - OUTPTS(0)%DTOUT ( 2) = REAL ( ODAT( 8,0) ) - OUTPTS(0)%TOLAST(1,2) = ODAT( 9,0) - OUTPTS(0)%TOLAST(2,2) = ODAT(10,0) - OUTPTS(0)%OFILES(1) = OUTFF(1,1) - OUTPTS(0)%OFILES(2) = OUTFF(2,1) -! - TOUT = OUTPTS(0)%TONEXT(:,2) - TLST = OUTPTS(0)%TOLAST(:,2) -! - DO - DTTST = DSEC21 ( STIME , TOUT ) - IF ( DTTST .LT. 0 ) THEN - CALL TICK21 ( TOUT, OUTPTS(0)%DTOUT(2) ) - ELSE - EXIT - END IF - END DO -! - OUTPTS(0)%TONEXT(:,2) = TOUT -! - DTTST = DSEC21 ( TOUT , TLST ) - IF ( DTTST .LT. 0. ) THEN - UNIPTS = .FALSE. - ELSE - CALL WMIOPP ( OT2(0)%NPTS, OT2(0)%X, OT2(0)%Y, & - OT2(0)%PNAMES ) - END IF -! + ENDIF +#endif + ! + ! 8.c.4 Relation to higher ranked grids + ! + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,938) & + 'Computing relation to higher ranked grids' + CALL WMGHGH + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,938) & + 'Finished computing relation to higher ranked grids' + ! + ! 8.c.5 Unified point output + ! + IF ( UNIPTS ) THEN + ! + OUTPTS(0)%TONEXT(1,2) = ODAT( 6,0) + OUTPTS(0)%TONEXT(2,2) = ODAT( 7,0) + OUTPTS(0)%DTOUT ( 2) = REAL ( ODAT( 8,0) ) + OUTPTS(0)%TOLAST(1,2) = ODAT( 9,0) + OUTPTS(0)%TOLAST(2,2) = ODAT(10,0) + OUTPTS(0)%OFILES(1) = OUTFF(1,1) + OUTPTS(0)%OFILES(2) = OUTFF(2,1) + ! + TOUT = OUTPTS(0)%TONEXT(:,2) + TLST = OUTPTS(0)%TOLAST(:,2) + ! + DO + DTTST = DSEC21 ( STIME , TOUT ) + IF ( DTTST .LT. 0 ) THEN + CALL TICK21 ( TOUT, OUTPTS(0)%DTOUT(2) ) + ELSE + EXIT + END IF + END DO + ! + OUTPTS(0)%TONEXT(:,2) = TOUT + ! + DTTST = DSEC21 ( TOUT , TLST ) + IF ( DTTST .LT. 0. ) THEN + UNIPTS = .FALSE. + ELSE + CALL WMIOPP ( OT2(0)%NPTS, OT2(0)%X, OT2(0)%Y, & + OT2(0)%PNAMES ) + END IF + ! #ifdef W3_MPI - DO I=1, NRGRD - CALL WMSETM ( I, MDSE, MDST ) - CALL W3SETG ( I, MDSE, MDST ) - CALL W3SETO ( I, MDSE, MDST ) - IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN - CALL MPI_BCAST ( NOPTS, 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - END IF - END DO -#endif -! + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN + CALL MPI_BCAST ( NOPTS, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) END IF -! -! 8.c.6 Output -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,938) 'Additional group information' -! - IF ( MAXVAL(GRDLOW(:,0)) .GT. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,933) 'Lower rank grid dependence' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,933) 'Lower rank grid dependence' - DO I=1, NRGRD - WRITE (LINE(1:6),'(1X,I3,2X)') I - JJJ = 6 - IF ( GRDLOW(I,0) .NE. 0 ) THEN - DO J=1, GRDLOW(I,0) - WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDLOW(I,J) - JJJ = JJJ + 3 - END DO - ELSE IF ( FLRBPI(I) ) THEN - JJJ = 21 - LINE(7:JJJ) = ' Data from file' - ELSE - JJJ = 22 - LINE(7:JJJ) = ' No dependencies' - END IF - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE(MDSS,934) LINE(1:JJJ) - IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + END DO +#endif + ! + END IF + ! + ! 8.c.6 Output + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,938) 'Additional group information' + ! + IF ( MAXVAL(GRDLOW(:,0)) .GT. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,933) 'Lower rank grid dependence' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,933) 'Lower rank grid dependence' + DO I=1, NRGRD + WRITE (LINE(1:6),'(1X,I3,2X)') I + JJJ = 6 + IF ( GRDLOW(I,0) .NE. 0 ) THEN + DO J=1, GRDLOW(I,0) + WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDLOW(I,J) + JJJ = JJJ + 3 + END DO + ELSE IF ( FLRBPI(I) ) THEN + JJJ = 21 + LINE(7:JJJ) = ' Data from file' ELSE - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,937) 'No lower rank grid dependencies' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,937) 'No lower rank grid dependencies' + JJJ = 22 + LINE(7:JJJ) = ' No dependencies' END IF - DEALLOCATE ( FLRBPI ) -! - IF ( MAXVAL(GRDEQL(:,0)) .GT. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,933) 'Same rank grid dependence' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,933) 'Same rank grid dependence' - DO I=1, NRGRD - WRITE (LINE(1:6),'(1X,I3,2X)') I - JJJ = 6 - IF ( GRDEQL(I,0) .NE. 0 ) THEN - DO J=1, GRDEQL(I,0) - WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDEQL(I,J) - JJJ = JJJ + 3 - END DO - ELSE - JJJ = 22 - LINE(7:JJJ) = ' No dependencies' - END IF - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE(MDSS,934) LINE(1:JJJ) - IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE(MDSS,934) LINE(1:JJJ) + IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,937) 'No lower rank grid dependencies' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,937) 'No lower rank grid dependencies' + END IF + DEALLOCATE ( FLRBPI ) + ! + IF ( MAXVAL(GRDEQL(:,0)) .GT. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,933) 'Same rank grid dependence' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,933) 'Same rank grid dependence' + DO I=1, NRGRD + WRITE (LINE(1:6),'(1X,I3,2X)') I + JJJ = 6 + IF ( GRDEQL(I,0) .NE. 0 ) THEN + DO J=1, GRDEQL(I,0) + WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDEQL(I,J) + JJJ = JJJ + 3 + END DO ELSE - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,937) 'No same rank grid dependencies' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,937) 'No same rank grid dependencies' + JJJ = 22 + LINE(7:JJJ) = ' No dependencies' END IF -! - IF ( MAXVAL(GRDHGH(:,0)) .GT. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,933) 'Higher rank grid dependence' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,933) 'Higher rank grid dependence' - DO I=1, NRGRD - WRITE (LINE(1:6),'(1X,I3,2X)') I - JJJ = 6 - IF ( GRDHGH(I,0) .NE. 0 ) THEN - DO J=1, GRDHGH(I,0) - WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDHGH(I,J) - JJJ = JJJ + 3 - END DO - ELSE - JJJ = 22 - LINE(7:JJJ) = ' No dependencies' - END IF - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE(MDSS,934) LINE(1:JJJ) - IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE(MDSS,934) LINE(1:JJJ) + IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,937) 'No same rank grid dependencies' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,937) 'No same rank grid dependencies' + END IF + ! + IF ( MAXVAL(GRDHGH(:,0)) .GT. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,933) 'Higher rank grid dependence' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,933) 'Higher rank grid dependence' + DO I=1, NRGRD + WRITE (LINE(1:6),'(1X,I3,2X)') I + JJJ = 6 + IF ( GRDHGH(I,0) .NE. 0 ) THEN + DO J=1, GRDHGH(I,0) + WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDHGH(I,J) + JJJ = JJJ + 3 + END DO ELSE - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,937) 'No higher rank grid dependencies' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,937) 'No higher rank grid dependencies' + JJJ = 22 + LINE(7:JJJ) = ' No dependencies' END IF -! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE(MDSS,934) LINE(1:JJJ) + IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,937) 'No higher rank grid dependencies' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,937) 'No higher rank grid dependencies' + END IF + ! #ifdef W3_T - WRITE (MDST,9083) - DO I=-NRINP, NRGRD - WRITE (MDST,9084) I, IDINP(I,:) - END DO -#endif -! -! Test output of connected units (always) -! - CALL WMUSET ( MDSE, MDST, SCRATCH, .FALSE. ) - IF ( TSTOUT ) CALL WMUDMP ( MDST, 0 ) -! - DEALLOCATE ( MDS, NTRACE, ODAT, FLGRD, FLGR2, FLGD, FLG2, INAMES,& - MNAMES & - ,OUTFF ) -! + WRITE (MDST,9083) + DO I=-NRINP, NRGRD + WRITE (MDST,9084) I, IDINP(I,:) + END DO +#endif + ! + ! Test output of connected units (always) + ! + CALL WMUSET ( MDSE, MDST, SCRATCH, .FALSE. ) + IF ( TSTOUT ) CALL WMUDMP ( MDST, 0 ) + ! + DEALLOCATE ( MDS, NTRACE, ODAT, FLGRD, FLGR2, FLGD, FLG2, INAMES,& + MNAMES & + ,OUTFF ) + ! #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) #endif -! - CALL DATE_AND_TIME ( VALUES=CLKDT2 ) - CLKFIN = TDIFF ( CLKDT1,CLKDT2 ) -! + ! + CALL DATE_AND_TIME ( VALUES=CLKDT2 ) + CLKFIN = TDIFF ( CLKDT1,CLKDT2 ) + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'END' + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'END' #endif -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,998) + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,998) #ifdef W3_O10 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) -#endif -! - RETURN -! -! Escape locations read errors : -! - 2000 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1000) IFNAME, IERR - CALL EXTCDE ( 2000 ) - RETURN -! - 2001 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1001) - CALL EXTCDE ( 2001 ) - RETURN -! - 2002 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1002) IERR - CALL EXTCDE ( 2002 ) - RETURN -! - 2010 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1010) IERR - CALL EXTCDE ( 2010 ) - RETURN -! - 2011 CONTINUE -! === no process number filtering for test file !!! === - WRITE (MDSE,1011) IERR - CALL EXTCDE ( 2011 ) - RETURN -! - 2020 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1020) - CALL EXTCDE ( 2020 ) - RETURN -! - 2021 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1021) - CALL EXTCDE ( 2021 ) - RETURN -! - 2030 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1030) MNAMES(I), INAMES(I,J) - CALL EXTCDE ( 2030 ) - RETURN -! - 2031 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1031) INAMES(I,J), J - CALL EXTCDE ( 2031 ) - RETURN -! -!2050 CONTINUE -! IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1040) -! CALL EXTCDE ( 2050 ) -! RETURN -! - 2051 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1051) MN(:II) - CALL EXTCDE ( 2051 ) - RETURN -! - 2052 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1052) J - CALL EXTCDE ( 2052 ) - RETURN -! - 2053 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1053) - CALL EXTCDE ( 2053 ) - RETURN -! - 2054 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1054) - CALL EXTCDE ( 2054 ) - RETURN -! - 2060 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1060) - CALL EXTCDE ( 2060 ) - RETURN -! - 2070 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1070) - CALL EXTCDE ( 2070 ) - RETURN -! - 2080 CONTINUE - CALL EXTCDE ( 2080 ) - RETURN -! -! Formats -! - 900 FORMAT ( ' ========== STARTING MWW3 INITIALIZATION (WMINIT) =', & - '============================'/) - 901 FORMAT ( ' WAVEWATCH III log file ', & - ' version ',A/ & - ' ==================================', & - '==================================='/ & - ' multi-grid model driver ', & - 'date : ',A10/50X,'time : ',A8) -! - 910 FORMAT ( ' Opening input file ',A,' (unit number',I3,')') - 911 FORMAT ( ' Opening output file ',A,' (unit number',I3,')') - 912 FORMAT (/' Comment character : ''',A,'''') -! - 920 FORMAT (/' Number of grids :',I3) - 921 FORMAT ( ' No input data grids.') - 922 FORMAT ( ' Input data grids :',I3) - 923 FORMAT ( ' Single point output file : ',A) - 1923 FORMAT (/' Output server type :',I3) - 2923 FORMAT ( ' Single point output proc : ',A) - 3923 FORMAT ( ' Grids share output procs : ',A) -! - 924 FORMAT (/' Input grid information : '/ & - ' nr extension lev. cur. wind ice tau', & - ' rho data'/ & - ' ----------------------------------------------', & - '--------------') - 925 FORMAT (1X,I3,1X,A10,6(1X,A6),3(1X,A1)) - 926 FORMAT ( ' ----------------------------------------------', & - '--------------') -! - 927 FORMAT (/' Grid for point output : '/ & - ' nr extension '/ ' ---------------') - 928 FORMAT (5X,A10) - 929 FORMAT ( ' ---------------') -! - 930 FORMAT (/' Wave grid information : '/ & - ' nr extension lev. cur. wind ice tau', & - ' rho data move1 rnk grp dmp'/ & - ' ----------------------------------------------', & - '-----------------------------------') - 931 FORMAT (1X,I3,1X,A10,6(1X,A6),3(1X,A1),2X,A4,2I4,3X,A1) - 932 FORMAT ( ' -----------------------------------------------', & - '-----------------------------------'/) - 933 FORMAT ( ' ',A,' : '/ & - ' nr grids (part of comm.)'/ & - ' -----------------------------------------------', & - '---------------------') - 934 FORMAT (A) - 935 FORMAT ( ' -----------------------------------------------', & - '---------------------'/) - 936 FORMAT (/' ',A,' : '/ & - ' nr Depends on '/ & - ' -----------------------------------------------', & - '---------------------') - 937 FORMAT ( ' ',A/) - 938 FORMAT (/' ',A/) -! - 940 FORMAT (/' Time interval : '/ & - ' --------------------------------------------------') - 941 FORMAT ( ' Starting time : ',A) - 942 FORMAT ( ' Ending time : ',A/) - 943 FORMAT (/' Model settings : '/ & - ' --------------------------------------------------') - 944 FORMAT ( ' Masking computation in nesting : ',A) - 945 FORMAT ( ' Masking output in nesting : ',A/) -! - 950 FORMAT (/' Output requests : (ALL GRIDS) '/ & - ' ==================================================') - 951 FORMAT (/' Type',I2,' : ',A/ & - ' -----------------------------------------') - 952 FORMAT ( ' From : ',A) - 953 FORMAT ( ' To : ',A) - 954 FORMAT ( ' Interval : ',A/) - 955 FORMAT ( ' Fields : ',A) - 956 FORMAT ( ' ',A) - 957 FORMAT ( ' Point 1 : ',2E14.6,2X,A) - 958 FORMAT ( ' ',I6,' : ',2E14.6,2X,A) - 959 FORMAT ( ' No points defined') - 960 FORMAT ( ' The file with ',A,' data is ',A,'.') - 961 FORMAT ( ' IX fls : ',3I6/ & - ' IY fls : ',3I6) - 962 FORMAT (/' Output request for model ',A,' (nr',I3,') '/ & - ' ==================================================') - 963 FORMAT ( ' Output disabled') -! - 965 FORMAT (/' Grid movement data (!/MGP, !/MGW): '/ & - ' --------------------------------------------------') - 966 FORMAT ( ' ',A) - 967 FORMAT ( ' ',I6,2X,A) - 968 FORMAT ( ' ',I6,I11.8,I7.6,2F8.2) -! - 970 FORMAT(//' Assigning resources : '/ & - ' --------------------------------------------------') - 971 FORMAT ( ' ',A) - 972 FORMAT ( ' Process ',I5.5,' reserved for all point output.') - 973 FORMAT ( ' Processes ',I5.5,' through ',I5.5,' [',I3,']', & - ' reserved for output.') - 974 FORMAT (/ & - 5X,' grid comp. grd pnt trk rst bpt prt'/ & - 5X,' ------------------------------------------------------', & - '-------------') - 975 FORMAT (5X,' ',A10,2X,I5.5,'-',I5.5,6(2x,A5)) - 976 FORMAT(5X,' -------------------------------------------------', & - '------------------') - 977 FORMAT (5X,' Unified point output at ',I5.5) - 1974 FORMAT (' Resource assignement (processes) : '/ & - ' grid comp. grd pnt trk rst bpt prt'/ & - ' ------------------------------------------------------', & - '-------------') - 1975 FORMAT (' ',A10,2X,I5.5,'-',I5.5,6(2x,A5)) - 1976 FORMAT (' ---------------------------------------------------', & - '----------------') - 1977 FORMAT (' Unified point output at ',I5.5) -! - 980 FORMAT(//' Initializations :'/ & - ' --------------------------------------------------') - 981 FORMAT ( ' Model number',I3,' [',A,']') - 982 FORMAT ( ' Initializing wave model ...') - 983 FORMAT ( ' Initializing model input ...') - 984 FORMAT ( ' ',A,': file not needed') - 985 FORMAT ( ' ',A,': file OK') - 986 FORMAT ( ' Unified point output [',A,']') - 987 FORMAT ( ' Initializing grids ...') - 988 FORMAT ( ' Input data grid',I3,' [',A,']') -! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) +#endif + ! + RETURN + ! + ! Escape locations read errors : + ! +2000 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1000) IFNAME, IERR + CALL EXTCDE ( 2000 ) + RETURN + ! +2001 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1001) + CALL EXTCDE ( 2001 ) + RETURN + ! +2002 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1002) IERR + CALL EXTCDE ( 2002 ) + RETURN + ! +2010 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1010) IERR + CALL EXTCDE ( 2010 ) + RETURN + ! +2011 CONTINUE + ! === no process number filtering for test file !!! === + WRITE (MDSE,1011) IERR + CALL EXTCDE ( 2011 ) + RETURN + ! +2020 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1020) + CALL EXTCDE ( 2020 ) + RETURN + ! +2021 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1021) + CALL EXTCDE ( 2021 ) + RETURN + ! +2030 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1030) MNAMES(I), INAMES(I,J) + CALL EXTCDE ( 2030 ) + RETURN + ! +2031 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1031) INAMES(I,J), J + CALL EXTCDE ( 2031 ) + RETURN + ! + !2050 CONTINUE + ! IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1040) + ! CALL EXTCDE ( 2050 ) + ! RETURN + ! +2051 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1051) MN(:II) + CALL EXTCDE ( 2051 ) + RETURN + ! +2052 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1052) J + CALL EXTCDE ( 2052 ) + RETURN + ! +2053 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1053) + CALL EXTCDE ( 2053 ) + RETURN + ! +2054 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1054) + CALL EXTCDE ( 2054 ) + RETURN + ! +2060 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1060) + CALL EXTCDE ( 2060 ) + RETURN + ! +2070 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1070) + CALL EXTCDE ( 2070 ) + RETURN + ! +2080 CONTINUE + CALL EXTCDE ( 2080 ) + RETURN + ! + ! Formats + ! +900 FORMAT ( ' ========== STARTING MWW3 INITIALIZATION (WMINIT) =', & + '============================'/) +901 FORMAT ( ' WAVEWATCH III log file ', & + ' version ',A/ & + ' ==================================', & + '==================================='/ & + ' multi-grid model driver ', & + 'date : ',A10/50X,'time : ',A8) + ! +910 FORMAT ( ' Opening input file ',A,' (unit number',I3,')') +911 FORMAT ( ' Opening output file ',A,' (unit number',I3,')') +912 FORMAT (/' Comment character : ''',A,'''') + ! +920 FORMAT (/' Number of grids :',I3) +921 FORMAT ( ' No input data grids.') +922 FORMAT ( ' Input data grids :',I3) +923 FORMAT ( ' Single point output file : ',A) +1923 FORMAT (/' Output server type :',I3) +2923 FORMAT ( ' Single point output proc : ',A) +3923 FORMAT ( ' Grids share output procs : ',A) + ! +924 FORMAT (/' Input grid information : '/ & + ' nr extension lev. cur. wind ice tau', & + ' rho data'/ & + ' ----------------------------------------------', & + '--------------') +925 FORMAT (1X,I3,1X,A10,6(1X,A6),3(1X,A1)) +926 FORMAT ( ' ----------------------------------------------', & + '--------------') + ! +927 FORMAT (/' Grid for point output : '/ & + ' nr extension '/ ' ---------------') +928 FORMAT (5X,A10) +929 FORMAT ( ' ---------------') + ! +930 FORMAT (/' Wave grid information : '/ & + ' nr extension lev. cur. wind ice tau', & + ' rho data move1 rnk grp dmp'/ & + ' ----------------------------------------------', & + '-----------------------------------') +931 FORMAT (1X,I3,1X,A10,6(1X,A6),3(1X,A1),2X,A4,2I4,3X,A1) +932 FORMAT ( ' -----------------------------------------------', & + '-----------------------------------'/) +933 FORMAT ( ' ',A,' : '/ & + ' nr grids (part of comm.)'/ & + ' -----------------------------------------------', & + '---------------------') +934 FORMAT (A) +935 FORMAT ( ' -----------------------------------------------', & + '---------------------'/) +936 FORMAT (/' ',A,' : '/ & + ' nr Depends on '/ & + ' -----------------------------------------------', & + '---------------------') +937 FORMAT ( ' ',A/) +938 FORMAT (/' ',A/) + ! +940 FORMAT (/' Time interval : '/ & + ' --------------------------------------------------') +941 FORMAT ( ' Starting time : ',A) +942 FORMAT ( ' Ending time : ',A/) +943 FORMAT (/' Model settings : '/ & + ' --------------------------------------------------') +944 FORMAT ( ' Masking computation in nesting : ',A) +945 FORMAT ( ' Masking output in nesting : ',A/) + ! +950 FORMAT (/' Output requests : (ALL GRIDS) '/ & + ' ==================================================') +951 FORMAT (/' Type',I2,' : ',A/ & + ' -----------------------------------------') +952 FORMAT ( ' From : ',A) +953 FORMAT ( ' To : ',A) +954 FORMAT ( ' Interval : ',A/) +955 FORMAT ( ' Fields : ',A) +956 FORMAT ( ' ',A) +957 FORMAT ( ' Point 1 : ',2E14.6,2X,A) +958 FORMAT ( ' ',I6,' : ',2E14.6,2X,A) +959 FORMAT ( ' No points defined') +960 FORMAT ( ' The file with ',A,' data is ',A,'.') +961 FORMAT ( ' IX fls : ',3I6/ & + ' IY fls : ',3I6) +962 FORMAT (/' Output request for model ',A,' (nr',I3,') '/ & + ' ==================================================') +963 FORMAT ( ' Output disabled') + ! +965 FORMAT (/' Grid movement data (!/MGP, !/MGW): '/ & + ' --------------------------------------------------') +966 FORMAT ( ' ',A) +967 FORMAT ( ' ',I6,2X,A) +968 FORMAT ( ' ',I6,I11.8,I7.6,2F8.2) + ! +970 FORMAT(//' Assigning resources : '/ & + ' --------------------------------------------------') +971 FORMAT ( ' ',A) +972 FORMAT ( ' Process ',I5.5,' reserved for all point output.') +973 FORMAT ( ' Processes ',I5.5,' through ',I5.5,' [',I3,']', & + ' reserved for output.') +974 FORMAT (/ & + 5X,' grid comp. grd pnt trk rst bpt prt'/ & + 5X,' ------------------------------------------------------', & + '-------------') +975 FORMAT (5X,' ',A10,2X,I5.5,'-',I5.5,6(2x,A5)) +976 FORMAT(5X,' -------------------------------------------------', & + '------------------') +977 FORMAT (5X,' Unified point output at ',I5.5) +1974 FORMAT (' Resource assignement (processes) : '/ & + ' grid comp. grd pnt trk rst bpt prt'/ & + ' ------------------------------------------------------', & + '-------------') +1975 FORMAT (' ',A10,2X,I5.5,'-',I5.5,6(2x,A5)) +1976 FORMAT (' ---------------------------------------------------', & + '----------------') +1977 FORMAT (' Unified point output at ',I5.5) + ! +980 FORMAT(//' Initializations :'/ & + ' --------------------------------------------------') +981 FORMAT ( ' Model number',I3,' [',A,']') +982 FORMAT ( ' Initializing wave model ...') +983 FORMAT ( ' Initializing model input ...') +984 FORMAT ( ' ',A,': file not needed') +985 FORMAT ( ' ',A,': file OK') +986 FORMAT ( ' Unified point output [',A,']') +987 FORMAT ( ' Initializing grids ...') +988 FORMAT ( ' Input data grid',I3,' [',A,']') + ! #ifdef W3_MPRF - 990 FORMAT (1X,3F12.3,' WMINIT',1X,A) -#endif -! - 998 FORMAT ( ' Running the model :'/ & - ' --------------------------------------------------'/) - 999 FORMAT ( ' ========== END OF MWW3 INITIALIZATION (WMINIT) ===', & - '============================'/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & - ' ERROR IN OPENING INPUT FILE ',A/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & - ' ERROR IN OPENING LOG FILE'/ & - ' IOSTAT =',I5/) - 1011 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & - ' ERROR IN OPENING TEST FILE'/ & - ' IOSTAT =',I5/) - 1020 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & - ' ILLEGAL NUMBER OF GRIDS ( < 1 ) '/) - 1021 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & - ' ILLEGAL NUMBER OF INPUT GRIDS ( < 0 ) '/) - 1030 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & - ' INPUT GRID NAME NOT FOUND '/ & - ' WAVE GRID : ',A/ & - ' INPUT NAME : ',A/) - 1031 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & - ' REQUESTED INPUT TYPE NOT FOUND IN INPUT GRID '/ & - ' INPUT GRID : ',A/ & - ' INPUT TYPE : ',I8/) - 1032 FORMAT (/' *** WAVEWATCH III WARNING IN WMINIT : *** '/ & - ' INPUT GRID ',A,' NOT USED '/) - 1040 FORMAT ( ' *** WAVEWATCH III WARNING IN W3MLTI : ***'/ & - ' POSSIBLE LOAD IMBALANCE GROUP',I3,' :',2I6/) -!1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & -! ' ILLEGAL TIME INTERVAL'/) - 1050 FORMAT (/' *** WAVEWATCH III WARNING IN W3MLTI : ***'/ & - ' UNIFIED POINT OUTPUT BUT NO OUTPUT'/ & - ' UNIFIED POINT OUTPUT DISABLED'/) - 1051 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & - ' ILLEGAL MODEL ID [',A,']'/) - 1052 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & - ' ILLEGAL OUTPUT TYPE',I10/) - 1053 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & +990 FORMAT (1X,3F12.3,' WMINIT',1X,A) +#endif + ! +998 FORMAT ( ' Running the model :'/ & + ' --------------------------------------------------'/) +999 FORMAT ( ' ========== END OF MWW3 INITIALIZATION (WMINIT) ===', & + '============================'/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & + ' ERROR IN OPENING INPUT FILE ',A/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) +1010 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & + ' ERROR IN OPENING LOG FILE'/ & + ' IOSTAT =',I5/) +1011 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & + ' ERROR IN OPENING TEST FILE'/ & + ' IOSTAT =',I5/) +1020 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & + ' ILLEGAL NUMBER OF GRIDS ( < 1 ) '/) +1021 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & + ' ILLEGAL NUMBER OF INPUT GRIDS ( < 0 ) '/) +1030 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & + ' INPUT GRID NAME NOT FOUND '/ & + ' WAVE GRID : ',A/ & + ' INPUT NAME : ',A/) +1031 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : *** '/ & + ' REQUESTED INPUT TYPE NOT FOUND IN INPUT GRID '/ & + ' INPUT GRID : ',A/ & + ' INPUT TYPE : ',I8/) +1032 FORMAT (/' *** WAVEWATCH III WARNING IN WMINIT : *** '/ & + ' INPUT GRID ',A,' NOT USED '/) +1040 FORMAT ( ' *** WAVEWATCH III WARNING IN W3MLTI : ***'/ & + ' POSSIBLE LOAD IMBALANCE GROUP',I3,' :',2I6/) + !1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ! ' ILLEGAL TIME INTERVAL'/) +1050 FORMAT (/' *** WAVEWATCH III WARNING IN W3MLTI : ***'/ & + ' UNIFIED POINT OUTPUT BUT NO OUTPUT'/ & + ' UNIFIED POINT OUTPUT DISABLED'/) +1051 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ' ILLEGAL MODEL ID [',A,']'/) +1052 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ' ILLEGAL OUTPUT TYPE',I10/) +1053 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & ' OUTPUT POINTS FOR INDIVIDUAL GRIDS CANNOT BE DEFINED'/ & - ' WHEN UNIFIED POINT OUTPUT IS REQUESTED'/) - 1054 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ' WHEN UNIFIED POINT OUTPUT IS REQUESTED'/) +1054 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & ' POINT OUTPUT ACTIVATED, BUT NO POINTS DEFINED'/) - 1060 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & - ' NO MOVING GRID DATA PRESENT'/) - 1070 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : ***'/ & - ' ALL GRIDS ARE NOT USING THE SAME COORDINATE SYSTEM'/) - 1080 FORMAT (/' *** BOUNDARY DATA READ, WILL NOT DUMP, GRID :',I4, & - ' ***') - 1081 FORMAT (/' *** NO BOUNDARY DATA TO DUMP, GRID :',I4,' ***') - 1082 FORMAT ( ' No boundary data dump for grid',I3/) -! +1060 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ' NO MOVING GRID DATA PRESENT'/) +1070 FORMAT (/' *** WAVEWATCH III ERROR IN WMINIT : ***'/ & + ' ALL GRIDS ARE NOT USING THE SAME COORDINATE SYSTEM'/) +1080 FORMAT (/' *** BOUNDARY DATA READ, WILL NOT DUMP, GRID :',I4, & + ' ***') +1081 FORMAT (/' *** NO BOUNDARY DATA TO DUMP, GRID :',I4,' ***') +1082 FORMAT ( ' No boundary data dump for grid',I3/) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMINIT : UNIT NUMBERS : ',5I6/ & - ' INPUT FILE NAME : ',A) +9000 FORMAT ( ' TEST WMINIT : UNIT NUMBERS : ',5I6/ & + ' INPUT FILE NAME : ',A) #endif -! + ! #ifdef W3_T - 9020 FORMAT ( ' TEST WMINIT : UNIT NUMBERS FOR GRIDS (',A,')'/ & - 15X,'GRID MDS(1-13)',43X,'NTRACE') - 9021 FORMAT (14X,16I4) - 9022 FORMAT ( ' TEST WMINIT : UNIT NUMBERS FOR INTPUT FILES'/ & - 15X,'GRID MDSF(JFIRST-9)') - 9030 FORMAT ( ' TEST WMINIT : FILE EXTENSIONS, INPUT FLAGS,', & - ' RANK AND GROUP, PROC RANGE') - 9031 FORMAT ( ' ',I3,1X,A,20L2,2I4,2F6.2) - 9032 FORMAT ( ' TEST WMINIT : PROCESSED RANK NUMBERS') - 9033 FORMAT ( ' ',I3,1X,A,1X,I4) - 9034 FORMAT ( ' TEST WMINIT : NUMBER OF GROUPS :',I4) - 9035 FORMAT ( ' TEST WMINIT : SIZE OF GROUPS :',20I3) - 9036 FORMAT ( ' TEST WMINIT : GROUP SIZE AND COMPONENTS :') - 9037 FORMAT ( ' ',2I3,':',20I3) -#endif -! +9020 FORMAT ( ' TEST WMINIT : UNIT NUMBERS FOR GRIDS (',A,')'/ & + 15X,'GRID MDS(1-13)',43X,'NTRACE') +9021 FORMAT (14X,16I4) +9022 FORMAT ( ' TEST WMINIT : UNIT NUMBERS FOR INTPUT FILES'/ & + 15X,'GRID MDSF(JFIRST-9)') +9030 FORMAT ( ' TEST WMINIT : FILE EXTENSIONS, INPUT FLAGS,', & + ' RANK AND GROUP, PROC RANGE') +9031 FORMAT ( ' ',I3,1X,A,20L2,2I4,2F6.2) +9032 FORMAT ( ' TEST WMINIT : PROCESSED RANK NUMBERS') +9033 FORMAT ( ' ',I3,1X,A,1X,I4) +9034 FORMAT ( ' TEST WMINIT : NUMBER OF GROUPS :',I4) +9035 FORMAT ( ' TEST WMINIT : SIZE OF GROUPS :',20I3) +9036 FORMAT ( ' TEST WMINIT : GROUP SIZE AND COMPONENTS :') +9037 FORMAT ( ' ',2I3,':',20I3) +#endif + ! #ifdef W3_T - 9050 FORMAT ( ' TEST WMINIT : GRID NUMBER',I3,' =================') - 9051 FORMAT ( ' TEST WMINIT : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & - 5(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) - 9052 FORMAT ( ' TEST WMINIT : FLGRD : ',5(5L2,1X)/24X,5(5L2,1X)) +9050 FORMAT ( ' TEST WMINIT : GRID NUMBER',I3,' =================') +9051 FORMAT ( ' TEST WMINIT : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & + 5(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) +9052 FORMAT ( ' TEST WMINIT : FLGRD : ',5(5L2,1X)/24X,5(5L2,1X)) #endif -! + ! #ifdef W3_T - 9060 FORMAT ( ' TEST WMINIT : GRID MOVEMENT DATA') - 9061 FORMAT ( ' ',I8.8,I7,1X,2F8.2) +9060 FORMAT ( ' TEST WMINIT : GRID MOVEMENT DATA') +9061 FORMAT ( ' ',I8.8,I7,1X,2F8.2) #endif -! + ! #ifdef W3_T - 9070 FORMAT ( ' TEST WMINIT : ALLPRC ') - 9071 FORMAT ( ' ',I3,' : ',250I3) - 8042 FORMAT ( ' TEST WMINIT : MODMAP ') - 8043 FORMAT ( ' TEST WMINIT : LOADMP ') - 8044 FORMAT ( ' ',I3,' : ',250I2) +9070 FORMAT ( ' TEST WMINIT : ALLPRC ') +9071 FORMAT ( ' ',I3,' : ',250I3) +8042 FORMAT ( ' TEST WMINIT : MODMAP ') +8043 FORMAT ( ' TEST WMINIT : LOADMP ') +8044 FORMAT ( ' ',I3,' : ',250I2) #endif -! + ! #ifdef W3_T - 9080 FORMAT ( ' TEST WMINIT : MODEL INITIALIZATION') - 9081 FORMAT ( ' MODEL AND TIME :',I4,I10.8,I8.6) - 9082 FORMAT ( ' STATUS AND TIMES :',I4,3(I10.8,I8.6)) - 9083 FORMAT ( ' TEST WMINIT : IDINP AFTER INITIALIZATION :') - 9084 FORMAT ( ' ',I4,17(2X,A3)) -#endif -!/ -!/ End of WMINIT ----------------------------------------------------- / -!/ - END SUBROUTINE WMINIT +9080 FORMAT ( ' TEST WMINIT : MODEL INITIALIZATION') +9081 FORMAT ( ' MODEL AND TIME :',I4,I10.8,I8.6) +9082 FORMAT ( ' STATUS AND TIMES :',I4,3(I10.8,I8.6)) +9083 FORMAT ( ' TEST WMINIT : IDINP AFTER INITIALIZATION :') +9084 FORMAT ( ' ',I4,17(2X,A3)) +#endif + !/ + !/ End of WMINIT ----------------------------------------------------- / + !/ + END SUBROUTINE WMINIT -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize multi-grid version of WAVEWATCH III. -!> -!> @param[in] IDSI Unit number for input file. -!> @param[in] IDSO Unit number for output file. -!> @param[in] IDSS Unit number for "screen" output. Switch off -!> by setting equal to IDSO. -!> @param[in] IDST Unit number for test output. -!> @param[in] IDSE Unit number for error output. -!> @param[in] IFNAME File name for input file. -!> @param[in] MPI_COMM MPI communicator to be used. -!> @param[in] PREAMB File name preamble (optional). -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & - MPI_COMM, PREAMB ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 13-Jun-2005 : Origination. ( version 3.07 ) -!/ 28-Dec-2005 : Add static nesting. ( version 3.08 ) -!/ 25-May-2006 : Add overlapping grids. ( version 3.09 ) -!/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) -!/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 09-Aug-2006 : Unified point output added. ( version 3.10 ) -!/ 14-Oct-2006 : Adding separate input grids. ( version 3.10 ) -!/ 03-Nov-2006 : Adding wave field separation. ( version 3.10 ) -!/ 02-Feb-2007 : Adding FLAGST initialization. ( version 3.10 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 16-Aug-2010 : Adding NTRMAX to unify NTRACE. ( version 3.14.5 ) -!/ 21-Sep-2010 : Adding coupling output ( version 3.14-Ifremer) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 28-Jul-2012 : Initialize FLGR2 properly. ( version 4.08 ) -!/ Tom Durant's fix, but moved to allocation. -!/ 28-Nov-2012 : Bug fix: Distribute to idle processors the grid data -!/ required for regridding. ( version 4.08 ) -!/ (T. J. Campbell, NRL) -!/ 02-Sep-2012 : Set up for > 999 test files. ( version 4.10 ) -!/ Set up output for > 999 procs. -!/ 03-Sep-2012 : Output of initilization time. ( version 4.10 ) -!/ Switch test file on/off (TSTOUT) -!/ 28-Nov-2012 : Bug fix: Distribute to idle processors the grid data -!/ required for regridding. ( version 4.08 ) -!/ (T. J. Campbell, NRL) -!/ 15-Apr-2013 : Changes the reading of output fields( version 4.10 ) -!/ (F. Ardhuin) -!/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) -!/ 27-May-2014 : Bug fix prf file name. ( version 5.02 ) -!/ 17-Sep-2014 : Read mod_def before inp file ( version 5.03 ) -!/ 17-Feb-2016 : New version from namelist use ( version 5.11 ) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ 20-Jan-2017 : Modify input forcing flags to support coupler input. -!/ Add ESMF override for STIME & ETIME ( version 6.02 ) -!/ (T. J. Campbell, NRL) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Initialize multi-grid version of WAVEWATCH III. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IDSI Int. I Unit number for input file. -! IDSO Int. I Unit number for output file. -! IDSS Int. I Unit number for "screen" output. Switch off -! by setting equal to IDSO. -! IDST Int. I Unit number for test output. -! IDSE Int. I Unit number for error output. -! IFNAME Char I File name for input file. -! MPI_COMM Int. I MPI communicator to be used. -! PREAMB Char I File name preamble (optiona). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Data structure initialization. -! W3DIMX Subr. Id. Set grid arrays. -! W3DIMS Subr. Id. Set grid arrays. -! W3SETG Subr. Id. Point to grid/model. -! W3NDAT Subr. W3WDATMD Data structure initialization. -! W3SETW Subr. Id. Point to grid/model. -! W3NAUX Subr. W3ADATMD Data structure initialization. -! W3SETA Subr. Id. Point to grid/model. -! W3NOUT Subr. W3ODATMD Data structure initialization. -! W3SETO Subr. Id. Point to grid/model. -! W3NINP Subr. W3IDATMD Data structure initialization. -! W3SETI Subr. Id. Point to grid/model. -! W3DIMI Subr. Id. Allocate grid/model. -! WMNDAT Subr. WMMDATMD Data structure initialization. -! WMSETM Subr. Id. Point to grid/model. -! WMDIMD Subr. Id. Allocate array space. -! W3FLDO Subr. W3FLDSMD Open input data file. -! W3IOGR Subr. W3IOGRMD Reading of model definition file. -! W3INIT Subr. W3INITMD Model intiailization. -! WMGLOW Subr. WMGRIDMD Lower rank grid dependencies. -! WMGEQL Subr. Id. Same rank grid dependencies. -! WMGHGH Subr. Id. Higher rank grid dependencies. -! RESPEC Subr. Id. Spectral conversion flags. -! WMIOBS Subr. WMINIOMD Stage boundary data. -! WMIOBG Subr. Id. Gather boundary data. -! WMIOBF Subr. Id. Finalize staging in WMIOBS. -! WMUINI Subr. WMUNITMD Initialize dynamic unit assignment, -! WMUDMP Subr. Id. Dump dynamic unit data, -! WMUSET Subr. Id. Set unit number data. -! WMUGET Subr. Id. Get a unit number. -! WMUINQ Subr. Id. Update unit number info. -! WMIOPP Subr. WMIOPOMD Initialize unified point output. -! ITRACE Subr. W3SERVMD Initialize subroutine tracing. -! STRACE Subr. Id. Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! WWDATE Subr. Id. System date. -! WWTIME Subr. Id. System time. -! PRINIT Subr. Id. Profiling routine ( !/MPRF ) -! PRTIME Subr. Id. Profiling routine ( !/MPRF ) -! STME21 Subr. W3TIMEMD Convert time to string. -! DSEC21 Func. Id. Difference between times. -! TICK21 Subr. Id. Advance the clock. -! W3READFLGRD Subr. W3IOGOMD Reads flags or namelist for output fields -! -! MPI_COMM_SIZE, CALL MPI_COMM_RANK, MPI_BARRIER, MPI_COMM_GROUP, -! MPI_GROUP_INCLUDE, MPI_COMM_CREATE, MPI_GROUP_FREE, MPI_BCAST -! Subr. mpif.h Standard MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3MLTI Prog. N/A Multi-grid model driver. -! .... Any coupled model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See formats 1000 and following, or escape locations 2000 and -! following. -! -! 7. Remarks : -! -! - When running regtests in cases where disk is non-local -! (i.e. NFS used), there can be a huge improvment in compute -! time by using /var/tmp/ for log files. -! See commented line at "OPEN (MDSO,FILE=..." -! -! - IDFLDS dimensioning is hardwired as IDFLDS(-7:9) where lowest possible -! value of JFIRST is JFIRST=-7 -! -! 8. Structure : -! -! -------------------------------------------------------------- -! 1. Multi-grid model intializations -! a Unit numbers -! b Subroutine tracing ( ITRACE ) -! c Input file -! d Log and test files -! e Initial and test output -! 2. Set-up of data structures and I/O -! a Get number of grids -! b Set up data structures -! ( W3NMOD, W3NDAT, W3NAUX, W3NOUT, W3NINP, WMNDAT ) -! c Set up I/O for individual models -! 3. Get individual grid information -! a Read data -! b Assign input file numbers. -! c Set rank and group data -! d Unified point output file. ( W3IOGR ) -! e Output -! 4. Model run time information and settings -! 5. Output requests -! a Loop over types for unified output -! --------------------------------------------------- -! b Process standard line -! c Type 1: fields of mean wave parameters -! d Type 2: point output -! e Type 3: track output -! f Type 4: restart files (no additional data) -! g Type 5: nesting data (no additional data) -! h Type 6: wave field data (dummy for now) -! i Set all grids to unified output -! --------------------------------------------------- -! j Endless loop for correcting output per grid -! --------------------------------------------------- -! Test grid name and output number -! k Process standard line -! l Type 1: fields of mean wave parameters -! m Type 2: point output -! n Type 3: track output -! o Type 6: partitioning output -! p Type 7: coupling output -! --------------------------------------------------- -! 6. Read moving grid data -! 7. Work load distribution -! a Initialize arrays -! b Set communicators and ALLPRC array -! c Set MODMAP and LOADMP arrays -! d Warnings -! 8. Actual initializations -! a Loop over models for per-model initialization -! 1 Wave model ( W3INIT ) -! 2 Data files ( W3FLDO ) -! 3 Grid status indicator and model times -! 3 Grid data for processors that are NOT used. -! 5 Test output -! b Input data files. -! c Inter model initialization -! 1 Set spectral conversion flags ( WMRSPC ) -! 2 Prepare unified point output ( WMIOPO ) -! 3 Relation to lower ranked grids -! ( WMGLOW, WMIOBS, WMIOBG, WMIOBF ) -! 4 Relation to same ranked grids ( WMGEQL ) -! 5 Relation to higher ranked grids ( WMGHGH ) -! 6 Output -! -------------------------------------------------------------- -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/MGW Moving grid wind correction. -! !/MGP Moving grid propagation correction. -! -! !/O10 Enable output identifying start and end of routine -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/MPRF Profiling. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ - USE W3GDATMD, ONLY: W3NMOD, W3DIMX, W3DIMS, W3SETG - USE W3WDATMD, ONLY: W3NDAT, W3SETW - USE W3ADATMD, ONLY: W3NAUX, W3SETA - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3ODATMD, ONLY: OFILES - USE W3IDATMD, ONLY: W3NINP, W3SETI, W3DIMI - USE WMMDATMD, ONLY: WMNDAT, WMSETM, WMDIMD -! - USE W3FLDSMD, ONLY: W3FLDO - USE W3IOGOMD, ONLY: W3READFLGRD, W3FLGRDFLAG - USE W3IOGRMD, ONLY: W3IOGR - USE W3INITMD, ONLY: W3INIT - USE WMGRIDMD, ONLY: WMRSPC, WMGLOW, WMGEQL, WMGHGH, WMSMCEQL - USE WMINIOMD, ONLY: WMIOBS, WMIOBG, WMIOBF - USE WMIOPOMD, ONLY: WMIOPP -!/ - USE W3SERVMD, ONLY: ITRACE, EXTCDE, NEXTLN, WWDATE, WWTIME + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize multi-grid version of WAVEWATCH III. + !> + !> @param[in] IDSI Unit number for input file. + !> @param[in] IDSO Unit number for output file. + !> @param[in] IDSS Unit number for "screen" output. Switch off + !> by setting equal to IDSO. + !> @param[in] IDST Unit number for test output. + !> @param[in] IDSE Unit number for error output. + !> @param[in] IFNAME File name for input file. + !> @param[in] MPI_COMM MPI communicator to be used. + !> @param[in] PREAMB File name preamble (optional). + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & + MPI_COMM, PREAMB ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 13-Jun-2005 : Origination. ( version 3.07 ) + !/ 28-Dec-2005 : Add static nesting. ( version 3.08 ) + !/ 25-May-2006 : Add overlapping grids. ( version 3.09 ) + !/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) + !/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 09-Aug-2006 : Unified point output added. ( version 3.10 ) + !/ 14-Oct-2006 : Adding separate input grids. ( version 3.10 ) + !/ 03-Nov-2006 : Adding wave field separation. ( version 3.10 ) + !/ 02-Feb-2007 : Adding FLAGST initialization. ( version 3.10 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 16-Aug-2010 : Adding NTRMAX to unify NTRACE. ( version 3.14.5 ) + !/ 21-Sep-2010 : Adding coupling output ( version 3.14-Ifremer) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 28-Jul-2012 : Initialize FLGR2 properly. ( version 4.08 ) + !/ Tom Durant's fix, but moved to allocation. + !/ 28-Nov-2012 : Bug fix: Distribute to idle processors the grid data + !/ required for regridding. ( version 4.08 ) + !/ (T. J. Campbell, NRL) + !/ 02-Sep-2012 : Set up for > 999 test files. ( version 4.10 ) + !/ Set up output for > 999 procs. + !/ 03-Sep-2012 : Output of initilization time. ( version 4.10 ) + !/ Switch test file on/off (TSTOUT) + !/ 28-Nov-2012 : Bug fix: Distribute to idle processors the grid data + !/ required for regridding. ( version 4.08 ) + !/ (T. J. Campbell, NRL) + !/ 15-Apr-2013 : Changes the reading of output fields( version 4.10 ) + !/ (F. Ardhuin) + !/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) + !/ 27-May-2014 : Bug fix prf file name. ( version 5.02 ) + !/ 17-Sep-2014 : Read mod_def before inp file ( version 5.03 ) + !/ 17-Feb-2016 : New version from namelist use ( version 5.11 ) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ 20-Jan-2017 : Modify input forcing flags to support coupler input. + !/ Add ESMF override for STIME & ETIME ( version 6.02 ) + !/ (T. J. Campbell, NRL) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Initialize multi-grid version of WAVEWATCH III. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IDSI Int. I Unit number for input file. + ! IDSO Int. I Unit number for output file. + ! IDSS Int. I Unit number for "screen" output. Switch off + ! by setting equal to IDSO. + ! IDST Int. I Unit number for test output. + ! IDSE Int. I Unit number for error output. + ! IFNAME Char I File name for input file. + ! MPI_COMM Int. I MPI communicator to be used. + ! PREAMB Char I File name preamble (optiona). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Data structure initialization. + ! W3DIMX Subr. Id. Set grid arrays. + ! W3DIMS Subr. Id. Set grid arrays. + ! W3SETG Subr. Id. Point to grid/model. + ! W3NDAT Subr. W3WDATMD Data structure initialization. + ! W3SETW Subr. Id. Point to grid/model. + ! W3NAUX Subr. W3ADATMD Data structure initialization. + ! W3SETA Subr. Id. Point to grid/model. + ! W3NOUT Subr. W3ODATMD Data structure initialization. + ! W3SETO Subr. Id. Point to grid/model. + ! W3NINP Subr. W3IDATMD Data structure initialization. + ! W3SETI Subr. Id. Point to grid/model. + ! W3DIMI Subr. Id. Allocate grid/model. + ! WMNDAT Subr. WMMDATMD Data structure initialization. + ! WMSETM Subr. Id. Point to grid/model. + ! WMDIMD Subr. Id. Allocate array space. + ! W3FLDO Subr. W3FLDSMD Open input data file. + ! W3IOGR Subr. W3IOGRMD Reading of model definition file. + ! W3INIT Subr. W3INITMD Model intiailization. + ! WMGLOW Subr. WMGRIDMD Lower rank grid dependencies. + ! WMGEQL Subr. Id. Same rank grid dependencies. + ! WMGHGH Subr. Id. Higher rank grid dependencies. + ! RESPEC Subr. Id. Spectral conversion flags. + ! WMIOBS Subr. WMINIOMD Stage boundary data. + ! WMIOBG Subr. Id. Gather boundary data. + ! WMIOBF Subr. Id. Finalize staging in WMIOBS. + ! WMUINI Subr. WMUNITMD Initialize dynamic unit assignment, + ! WMUDMP Subr. Id. Dump dynamic unit data, + ! WMUSET Subr. Id. Set unit number data. + ! WMUGET Subr. Id. Get a unit number. + ! WMUINQ Subr. Id. Update unit number info. + ! WMIOPP Subr. WMIOPOMD Initialize unified point output. + ! ITRACE Subr. W3SERVMD Initialize subroutine tracing. + ! STRACE Subr. Id. Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! WWDATE Subr. Id. System date. + ! WWTIME Subr. Id. System time. + ! PRINIT Subr. Id. Profiling routine ( !/MPRF ) + ! PRTIME Subr. Id. Profiling routine ( !/MPRF ) + ! STME21 Subr. W3TIMEMD Convert time to string. + ! DSEC21 Func. Id. Difference between times. + ! TICK21 Subr. Id. Advance the clock. + ! W3READFLGRD Subr. W3IOGOMD Reads flags or namelist for output fields + ! + ! MPI_COMM_SIZE, CALL MPI_COMM_RANK, MPI_BARRIER, MPI_COMM_GROUP, + ! MPI_GROUP_INCLUDE, MPI_COMM_CREATE, MPI_GROUP_FREE, MPI_BCAST + ! Subr. mpif.h Standard MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3MLTI Prog. N/A Multi-grid model driver. + ! .... Any coupled model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See formats 1000 and following, or escape locations 2000 and + ! following. + ! + ! 7. Remarks : + ! + ! - When running regtests in cases where disk is non-local + ! (i.e. NFS used), there can be a huge improvment in compute + ! time by using /var/tmp/ for log files. + ! See commented line at "OPEN (MDSO,FILE=..." + ! + ! - IDFLDS dimensioning is hardwired as IDFLDS(-7:9) where lowest possible + ! value of JFIRST is JFIRST=-7 + ! + ! 8. Structure : + ! + ! -------------------------------------------------------------- + ! 1. Multi-grid model intializations + ! a Unit numbers + ! b Subroutine tracing ( ITRACE ) + ! c Input file + ! d Log and test files + ! e Initial and test output + ! 2. Set-up of data structures and I/O + ! a Get number of grids + ! b Set up data structures + ! ( W3NMOD, W3NDAT, W3NAUX, W3NOUT, W3NINP, WMNDAT ) + ! c Set up I/O for individual models + ! 3. Get individual grid information + ! a Read data + ! b Assign input file numbers. + ! c Set rank and group data + ! d Unified point output file. ( W3IOGR ) + ! e Output + ! 4. Model run time information and settings + ! 5. Output requests + ! a Loop over types for unified output + ! --------------------------------------------------- + ! b Process standard line + ! c Type 1: fields of mean wave parameters + ! d Type 2: point output + ! e Type 3: track output + ! f Type 4: restart files (no additional data) + ! g Type 5: nesting data (no additional data) + ! h Type 6: wave field data (dummy for now) + ! i Set all grids to unified output + ! --------------------------------------------------- + ! j Endless loop for correcting output per grid + ! --------------------------------------------------- + ! Test grid name and output number + ! k Process standard line + ! l Type 1: fields of mean wave parameters + ! m Type 2: point output + ! n Type 3: track output + ! o Type 6: partitioning output + ! p Type 7: coupling output + ! --------------------------------------------------- + ! 6. Read moving grid data + ! 7. Work load distribution + ! a Initialize arrays + ! b Set communicators and ALLPRC array + ! c Set MODMAP and LOADMP arrays + ! d Warnings + ! 8. Actual initializations + ! a Loop over models for per-model initialization + ! 1 Wave model ( W3INIT ) + ! 2 Data files ( W3FLDO ) + ! 3 Grid status indicator and model times + ! 3 Grid data for processors that are NOT used. + ! 5 Test output + ! b Input data files. + ! c Inter model initialization + ! 1 Set spectral conversion flags ( WMRSPC ) + ! 2 Prepare unified point output ( WMIOPO ) + ! 3 Relation to lower ranked grids + ! ( WMGLOW, WMIOBS, WMIOBG, WMIOBF ) + ! 4 Relation to same ranked grids ( WMGEQL ) + ! 5 Relation to higher ranked grids ( WMGHGH ) + ! 6 Output + ! -------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! + ! !/MGW Moving grid wind correction. + ! !/MGP Moving grid propagation correction. + ! + ! !/O10 Enable output identifying start and end of routine + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/MPRF Profiling. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + USE W3GDATMD, ONLY: W3NMOD, W3DIMX, W3DIMS, W3SETG + USE W3WDATMD, ONLY: W3NDAT, W3SETW + USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3ODATMD, ONLY: OFILES + USE W3IDATMD, ONLY: W3NINP, W3SETI, W3DIMI + USE WMMDATMD, ONLY: WMNDAT, WMSETM, WMDIMD + ! + USE W3FLDSMD, ONLY: W3FLDO + USE W3IOGOMD, ONLY: W3READFLGRD, W3FLGRDFLAG + USE W3IOGRMD, ONLY: W3IOGR + USE W3INITMD, ONLY: W3INIT + USE WMGRIDMD, ONLY: WMRSPC, WMGLOW, WMGEQL, WMGHGH, WMSMCEQL + USE WMINIOMD, ONLY: WMIOBS, WMIOBG, WMIOBF + USE WMIOPOMD, ONLY: WMIOPP + !/ + USE W3SERVMD, ONLY: ITRACE, EXTCDE, NEXTLN, WWDATE, WWTIME #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_MPRF - USE W3TIMEMD, ONLY: PRINIT, PRTIME + USE W3TIMEMD, ONLY: PRINIT, PRTIME #endif - USE W3TIMEMD, ONLY: STME21, DSEC21, TICK21, TDIFF - USE WMUNITMD, ONLY: WMUINI, WMUDMP, WMUSET, WMUGET, WMUINQ -!/ - USE W3GDATMD, ONLY: GTYPE, NX, NY, FILEXT, NSEA, FLAGST, GRIDS + USE W3TIMEMD, ONLY: STME21, DSEC21, TICK21, TDIFF + USE WMUNITMD, ONLY: WMUINI, WMUDMP, WMUSET, WMUGET, WMUINQ + !/ + USE W3GDATMD, ONLY: GTYPE, NX, NY, FILEXT, NSEA, FLAGST, GRIDS #ifdef W3_SMC - USE W3GDATMD, ONLY: NCel, NUFc, NVFc, NRLv, NBSMC - USE W3GDATMD, ONLY: NARC, NBAC, NSPEC, SMCTYPE + USE W3GDATMD, ONLY: NCel, NUFc, NVFc, NRLv, NBSMC + USE W3GDATMD, ONLY: NARC, NBAC, NSPEC, SMCTYPE #endif #ifdef W3_MPI - USE W3GDATMD, ONLY: FLAGLL, ICLOSE, GSU, X0, Y0, SX, SY, & - XGRD, YGRD, DXDP, DXDQ, DYDP, DYDQ, & - HQFAC, HPFAC, MAPSTA, MAPST2, & - GRIDSHIFT, NSEAL, NK, NTH, XFR, FR1, & - TH, DTMAX, DTCFL - USE W3GSRUMD -#endif - USE W3WDATMD, ONLY: TIME - USE W3ADATMD, ONLY: WADATS - USE W3IDATMD, ONLY: INFLAGS1, INPUTS, IINIT, & - JFIRST, INFLAGS2 - USE W3ODATMD, ONLY: NOGRP, NGRPP, FLOUT, TONEXT, FLBPI, & - FLBPO, NFBPO, NBI, NDS, IAPROC, & - NAPFLD, NAPPNT, NAPTRK, NAPBPT, & - NAPPRT, NAPROC, FNMPRE, OUTPTS, NDST, NDSE, & - NOPTS, IOSTYP, UNIPTS, UPPROC, DTOUT, & - TOLAST, NOTYPE - USE WMMDATMD, ONLY: MDSI, MDSO, MDSS, MDST, MDSE, MDSF, MDSUP, & - IMPROC, NMPROC, NMPSCR, NMPERR, & - NMPLOG, NMPUPT, STIME, ETIME, NMV, NMVMAX, & - TMV, AMV, DMV, NRGRD, NRINP, NRGRP, GRANK, & - GRGRP, INGRP, GRDHGH, GRDEQL, GRDLOW, & - ALLPRC, MODMAP, TSYNC, TMAX, TOUTP, TDATA, & - GRSTAT, DTRES, BCDUMP, FLGHG1, FLGHG2, & - INPMAP, IDINP, NGRPSMC - USE WMMDATMD, ONLY: CLKDT1, CLKDT2, CLKFIN + USE W3GDATMD, ONLY: FLAGLL, ICLOSE, GSU, X0, Y0, SX, SY, & + XGRD, YGRD, DXDP, DXDQ, DYDP, DYDQ, & + HQFAC, HPFAC, MAPSTA, MAPST2, & + GRIDSHIFT, NSEAL, NK, NTH, XFR, FR1, & + TH, DTMAX, DTCFL + USE W3GSRUMD +#endif + USE W3WDATMD, ONLY: TIME + USE W3ADATMD, ONLY: WADATS + USE W3IDATMD, ONLY: INFLAGS1, INPUTS, IINIT, & + JFIRST, INFLAGS2 + USE W3ODATMD, ONLY: NOGRP, NGRPP, FLOUT, TONEXT, FLBPI, & + FLBPO, NFBPO, NBI, NDS, IAPROC, & + NAPFLD, NAPPNT, NAPTRK, NAPBPT, & + NAPPRT, NAPROC, FNMPRE, OUTPTS, NDST, NDSE, & + NOPTS, IOSTYP, UNIPTS, UPPROC, DTOUT, & + TOLAST, NOTYPE + USE WMMDATMD, ONLY: MDSI, MDSO, MDSS, MDST, MDSE, MDSF, MDSUP, & + IMPROC, NMPROC, NMPSCR, NMPERR, & + NMPLOG, NMPUPT, STIME, ETIME, NMV, NMVMAX, & + TMV, AMV, DMV, NRGRD, NRINP, NRGRP, GRANK, & + GRGRP, INGRP, GRDHGH, GRDEQL, GRDLOW, & + ALLPRC, MODMAP, TSYNC, TMAX, TOUTP, TDATA, & + GRSTAT, DTRES, BCDUMP, FLGHG1, FLGHG2, & + INPMAP, IDINP, NGRPSMC + USE WMMDATMD, ONLY: CLKDT1, CLKDT2, CLKFIN #ifdef W3_MPI - USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & - MPI_COMM_BCT, CROOT, FBCAST + USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & + MPI_COMM_BCT, CROOT, FBCAST #endif #ifdef W3_MPRF - USE WMMDATMD, ONLY: MDSP + USE WMMDATMD, ONLY: MDSP #endif - USE W3INITMD, ONLY: WWVER - USE W3NMLMULTIMD -!/ - IMPLICIT NONE -! + USE W3INITMD, ONLY: WWVER + USE W3NMLMULTIMD + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IDSI, IDSO, IDSS, IDST, IDSE, & - MPI_COMM - CHARACTER*(*), INTENT(IN) :: IFNAME - CHARACTER*(*), INTENT(IN), OPTIONAL :: PREAMB -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(NML_DOMAIN_T) :: NML_DOMAIN - TYPE(NML_INPUT_GRID_T), ALLOCATABLE :: NML_INPUT_GRID(:) - TYPE(NML_MODEL_GRID_T), ALLOCATABLE :: NML_MODEL_GRID(:) - TYPE(NML_OUTPUT_TYPE_T), ALLOCATABLE :: NML_OUTPUT_TYPE(:) - TYPE(NML_OUTPUT_DATE_T), ALLOCATABLE :: NML_OUTPUT_DATE(:) - TYPE(NML_HOMOG_COUNT_T) :: NML_HOMOG_COUNT - TYPE(NML_HOMOG_INPUT_T), ALLOCATABLE :: NML_HOMOG_INPUT(:) -! - TYPE OT2TPE - INTEGER :: NPTS - REAL, POINTER :: X(:), Y(:) - CHARACTER(LEN=40), POINTER :: PNAMES(:) - END TYPE OT2TPE -! - TYPE(OT2TPE), ALLOCATABLE :: OT2(:) -! - INTEGER :: MDSE2, IERR, I,J,K, N_MOV, N_TOT, & - SCRATCH, RNKMIN, RNKMAX, RNKTMP, & - GRPMIN, GRPMAX, II, NDSREC, NDSFND, & - NPTS, JJ, IP1, IPN, MPI_COMM_LOC, & - NMPSC2, JJJ, NCPROC, NPOUTT, NAPLOC, & - NAPRES, NAPADD, NAPBCT, IFI, IFJ, IW, & - IFT, ILOOP -! - INTEGER :: TTIME(2), TOUT(2), STMPT(2), ETMPT(2),& - TLST(2) + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IDSI, IDSO, IDSS, IDST, IDSE, & + MPI_COMM + CHARACTER*(*), INTENT(IN) :: IFNAME + CHARACTER*(*), INTENT(IN), OPTIONAL :: PREAMB + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(NML_DOMAIN_T) :: NML_DOMAIN + TYPE(NML_INPUT_GRID_T), ALLOCATABLE :: NML_INPUT_GRID(:) + TYPE(NML_MODEL_GRID_T), ALLOCATABLE :: NML_MODEL_GRID(:) + TYPE(NML_OUTPUT_TYPE_T), ALLOCATABLE :: NML_OUTPUT_TYPE(:) + TYPE(NML_OUTPUT_DATE_T), ALLOCATABLE :: NML_OUTPUT_DATE(:) + TYPE(NML_HOMOG_COUNT_T) :: NML_HOMOG_COUNT + TYPE(NML_HOMOG_INPUT_T), ALLOCATABLE :: NML_HOMOG_INPUT(:) + ! + TYPE OT2TPE + INTEGER :: NPTS + REAL, POINTER :: X(:), Y(:) + CHARACTER(LEN=40), POINTER :: PNAMES(:) + END TYPE OT2TPE + ! + TYPE(OT2TPE), ALLOCATABLE :: OT2(:) + ! + INTEGER :: MDSE2, IERR, I,J,K, N_MOV, N_TOT, & + SCRATCH, RNKMIN, RNKMAX, RNKTMP, & + GRPMIN, GRPMAX, II, NDSREC, NDSFND, & + NPTS, JJ, IP1, IPN, MPI_COMM_LOC, & + NMPSC2, JJJ, NCPROC, NPOUTT, NAPLOC, & + NAPRES, NAPADD, NAPBCT, IFI, IFJ, IW, & + IFT, ILOOP + ! + INTEGER :: TTIME(2), TOUT(2), STMPT(2), ETMPT(2),& + TLST(2) #ifdef W3_MPI - INTEGER :: IERR_MPI, BGROUP, LGROUP, IROOT + INTEGER :: IERR_MPI, BGROUP, LGROUP, IROOT #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -! - INTEGER, ALLOCATABLE :: MDS(:,:), NTRACE(:,:), ODAT(:,:), & - TMPRNK(:), TMPGRP(:), NINGRP(:), & - TMOVE(:,:), LOADMP(:,:), IPRT(:,:), & - NDPOUT(:) & - ,OUTFF(:,:) -! - REAL :: DTTST, XX, YY + INTEGER, SAVE :: IENT = 0 +#endif + ! + INTEGER, ALLOCATABLE :: MDS(:,:), NTRACE(:,:), ODAT(:,:), & + TMPRNK(:), TMPGRP(:), NINGRP(:), & + TMOVE(:,:), LOADMP(:,:), IPRT(:,:), & + NDPOUT(:) & + ,OUTFF(:,:) + ! + REAL :: DTTST, XX, YY #ifdef W3_MPRF - REAL :: PRFT0, PRFTN - REAL(KIND=8) :: get_memory -#endif -! - REAL, ALLOCATABLE :: X(:), Y(:), AMOVE(:), DMOVE(:), & - RP1(:), RPN(:) -! - LOGICAL :: FLT, TFLAGI, TFLAGS(-7:14), PSHARE - LOGICAL, ALLOCATABLE :: FLGRD(:,:,:), FLRBPI(:), BCDTMP(:), & - USEINP(:), LPRT(:), FLGR2(:,:,:), & - FLGD(:,:), FLG2(:,:), FLG2D(:,:), & - FLG1D(:), CPLINP(:) -! - CHARACTER(LEN=1) :: COMSTR - CHARACTER(LEN=256) :: TMPLINE, TEST - CHARACTER(LEN=3) :: IDSTR(-7:9), IDTST - CHARACTER(LEN=5) :: STOUT, OUTSTR(6) - CHARACTER(LEN=6) :: YESXX, XXXNO - CHARACTER(LEN=6), & - ALLOCATABLE :: ACTION(:) - CHARACTER(LEN=8) :: LFILE, STTIME + REAL :: PRFT0, PRFTN + REAL(KIND=8) :: get_memory +#endif + ! + REAL, ALLOCATABLE :: X(:), Y(:), AMOVE(:), DMOVE(:), & + RP1(:), RPN(:) + ! + LOGICAL :: FLT, TFLAGI, TFLAGS(-7:14), PSHARE + LOGICAL, ALLOCATABLE :: FLGRD(:,:,:), FLRBPI(:), BCDTMP(:), & + USEINP(:), LPRT(:), FLGR2(:,:,:), & + FLGD(:,:), FLG2(:,:), FLG2D(:,:), & + FLG1D(:), CPLINP(:) + ! + CHARACTER(LEN=1) :: COMSTR + CHARACTER(LEN=256) :: TMPLINE, TEST + CHARACTER(LEN=3) :: IDSTR(-7:9), IDTST + CHARACTER(LEN=5) :: STOUT, OUTSTR(6) + CHARACTER(LEN=6) :: YESXX, XXXNO + CHARACTER(LEN=6), & + ALLOCATABLE :: ACTION(:) + CHARACTER(LEN=8) :: LFILE, STTIME #ifdef W3_SHRD - CHARACTER(LEN=9) :: TFILE -#endif - CHARACTER(LEN=13) :: STDATE, MN, TNAMES(9) - CHARACTER(LEN=40) :: PN - CHARACTER(LEN=13), & - ALLOCATABLE :: INAMES(:,:), MNAMES(:) - CHARACTER(LEN=40), & - ALLOCATABLE :: PNAMES(:) - CHARACTER(LEN=12) :: FORMAT + CHARACTER(LEN=9) :: TFILE +#endif + CHARACTER(LEN=13) :: STDATE, MN, TNAMES(9) + CHARACTER(LEN=40) :: PN + CHARACTER(LEN=13), & + ALLOCATABLE :: INAMES(:,:), MNAMES(:) + CHARACTER(LEN=40), & + ALLOCATABLE :: PNAMES(:) + CHARACTER(LEN=12) :: FORMAT #ifdef W3_DIST - CHARACTER(LEN=18) :: TFILE + CHARACTER(LEN=18) :: TFILE #endif #ifdef W3_MPRF - CHARACTER(LEN=18) :: PFILE -#endif - CHARACTER(LEN=13) :: IDFLDS(-7:9) - CHARACTER(LEN=23) :: DTME21 - CHARACTER(LEN=30) :: IDOTYP(8) - CHARACTER(LEN=80) :: TNAME, LINE - CHARACTER(LEN=1024) :: FLDOUT -! + CHARACTER(LEN=18) :: PFILE +#endif + CHARACTER(LEN=13) :: IDFLDS(-7:9) + CHARACTER(LEN=23) :: DTME21 + CHARACTER(LEN=30) :: IDOTYP(8) + CHARACTER(LEN=80) :: TNAME, LINE + CHARACTER(LEN=1024) :: FLDOUT + ! -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ - DATA IDFLDS / 'ice param. 1 ' , 'ice param. 2 ' , & - 'ice param. 3 ' , 'ice param. 4 ' , & - 'ice param. 5 ' , & - 'mud density ' , 'mud thkness ' , & - 'mud viscos. ' , & - 'water levels ' , 'currents ' , & - 'winds ' , 'ice fields ' , & - 'momentum ' , 'air density ' , & - 'mean param. ' , '1D spectra ' , & - '2D spectra ' / -! - DATA IDOTYP / 'Fields of mean wave parameters' , & - 'Point output ' , & - 'Track point output ' , & - 'Restart files ' , & - 'Nesting data ' , & - 'Separated wave field data ' , & - 'Fields for coupling ' , & - 'Restart files second request '/ -! - DATA IDSTR / 'IC1', 'IC2', 'IC3', 'IC4', 'IC5', & - 'MDN', 'MTH', 'MVS', 'LEV', 'CUR', & - 'WND', 'ICE', 'TAU', 'RHO', 'DT0', & - 'DT1', 'DT2' / -! - DATA YESXX / 'YES/--' / - DATA XXXNO / '---/NO' / -! + DATA IDFLDS / 'ice param. 1 ' , 'ice param. 2 ' , & + 'ice param. 3 ' , 'ice param. 4 ' , & + 'ice param. 5 ' , & + 'mud density ' , 'mud thkness ' , & + 'mud viscos. ' , & + 'water levels ' , 'currents ' , & + 'winds ' , 'ice fields ' , & + 'momentum ' , 'air density ' , & + 'mean param. ' , '1D spectra ' , & + '2D spectra ' / + ! + DATA IDOTYP / 'Fields of mean wave parameters' , & + 'Point output ' , & + 'Track point output ' , & + 'Restart files ' , & + 'Nesting data ' , & + 'Separated wave field data ' , & + 'Fields for coupling ' , & + 'Restart files second request '/ + ! + DATA IDSTR / 'IC1', 'IC2', 'IC3', 'IC4', 'IC5', & + 'MDN', 'MTH', 'MVS', 'LEV', 'CUR', & + 'WND', 'ICE', 'TAU', 'RHO', 'DT0', & + 'DT1', 'DT2' / + ! + DATA YESXX / 'YES/--' / + DATA XXXNO / '---/NO' / + ! #ifdef W3_MPRF - CALL PRINIT - CALL PRTIME ( PRFT0 ) + CALL PRINIT + CALL PRTIME ( PRFT0 ) #endif -! - CALL DATE_AND_TIME ( VALUES=CLKDT1 ) -! - MPI_COMM_LOC = MPI_COMM + ! + CALL DATE_AND_TIME ( VALUES=CLKDT1 ) + ! + MPI_COMM_LOC = MPI_COMM #ifdef W3_MPI - MPI_COMM_MWAVE = MPI_COMM - CALL MPI_COMM_SIZE ( MPI_COMM_MWAVE, NMPROC, IERR_MPI ) - CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) - IMPROC = IMPROC + 1 -#endif -! - IF ( PRESENT(PREAMB) ) FNMPRE = PREAMB -!/ -!/ ------------------------------------------------------------------- / -! 1. Multi-grid model intializations -! 1.a Unit numbers -! Initialize dynamic assignment, errors and test to stdout -! - CALL WMUINI ( 6, 6 ) -! -! ... Identify reserved unit numbers -! - CALL WMUSET ( 6,6, 5, .TRUE., 'SYS', 'stdin', 'Standart input' ) - CALL WMUSET ( 6,6, 6, .TRUE., 'SYS', 'stdout','Standart output') -! + MPI_COMM_MWAVE = MPI_COMM + CALL MPI_COMM_SIZE ( MPI_COMM_MWAVE, NMPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 +#endif + ! + IF ( PRESENT(PREAMB) ) FNMPRE = PREAMB + !/ + !/ ------------------------------------------------------------------- / + ! 1. Multi-grid model intializations + ! 1.a Unit numbers + ! Initialize dynamic assignment, errors and test to stdout + ! + CALL WMUINI ( 6, 6 ) + ! + ! ... Identify reserved unit numbers + ! + CALL WMUSET ( 6,6, 5, .TRUE., 'SYS', 'stdin', 'Standart input' ) + CALL WMUSET ( 6,6, 6, .TRUE., 'SYS', 'stdout','Standart output') + ! #ifdef W3_NL2 - CALL WMUSET (6,6,103, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,104, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,105, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,106, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,107, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,108, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,109, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,110, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,111, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,112, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,113, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,114, .TRUE., 'FIX', DESC='Reserved SNL2' ) - CALL WMUSET (6,6,117, .TRUE., 'FIX', DESC='Reserved SNL2' ) -#endif -! -! ... Unit numbers from parameter list -! Dynamic scripture updated per file -! - MDSI = IDSI - MDSO = IDSO - MDSS = IDSS - MDST = IDST - MDSE = IDSE -! - COMSTR = '$' -! - IF ( IMPROC .EQ. NMPERR ) THEN - MDSE2 = MDSE - ELSE - MDSE2 = -1 - END IF -! -! 1.b Subroutine tracing -! - CALL ITRACE ( MDST, NTRMAX ) -! + CALL WMUSET (6,6,103, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,104, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,105, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,106, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,107, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,108, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,109, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,110, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,111, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,112, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,113, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,114, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,117, .TRUE., 'FIX', DESC='Reserved SNL2' ) +#endif + ! + ! ... Unit numbers from parameter list + ! Dynamic scripture updated per file + ! + MDSI = IDSI + MDSO = IDSO + MDSS = IDSS + MDST = IDST + MDSE = IDSE + ! + COMSTR = '$' + ! + IF ( IMPROC .EQ. NMPERR ) THEN + MDSE2 = MDSE + ELSE + MDSE2 = -1 + END IF + ! + ! 1.b Subroutine tracing + ! + CALL ITRACE ( MDST, NTRMAX ) + ! #ifdef W3_O10 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) -#endif -! -! 1.c Input file -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,910) IFNAME, MDSI -! - ! process ww3_multi namelist input - CALL W3NMLMULTIDEF (MPI_COMM, MDSI, TRIM(FNMPRE)//IFNAME, NML_DOMAIN, IERR) - ALLOCATE(NML_INPUT_GRID(NML_DOMAIN%NRINP)) - ALLOCATE(NML_MODEL_GRID(NML_DOMAIN%NRGRD)) - ALLOCATE(NML_OUTPUT_TYPE(NML_DOMAIN%NRGRD)) - ALLOCATE(NML_OUTPUT_DATE(NML_DOMAIN%NRGRD)) -! - CALL W3NMLMULTICONF (MPI_COMM, MDSI, TRIM(FNMPRE)//IFNAME, & - NML_DOMAIN, NML_INPUT_GRID, NML_MODEL_GRID, NML_OUTPUT_TYPE, & - NML_OUTPUT_DATE, NML_HOMOG_COUNT, NML_HOMOG_INPUT, IERR) - IF (IERR.NE.0) THEN - WRITE (*,'(2A)') 'ERROR: error occured while processing ', IFNAME - CALL EXIT (IERR) - END IF + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#endif + ! + ! 1.c Input file + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,910) IFNAME, MDSI + ! + ! process ww3_multi namelist input + CALL W3NMLMULTIDEF (MPI_COMM, MDSI, TRIM(FNMPRE)//IFNAME, NML_DOMAIN, IERR) + ALLOCATE(NML_INPUT_GRID(NML_DOMAIN%NRINP)) + ALLOCATE(NML_MODEL_GRID(NML_DOMAIN%NRGRD)) + ALLOCATE(NML_OUTPUT_TYPE(NML_DOMAIN%NRGRD)) + ALLOCATE(NML_OUTPUT_DATE(NML_DOMAIN%NRGRD)) + ! + CALL W3NMLMULTICONF (MPI_COMM, MDSI, TRIM(FNMPRE)//IFNAME, & + NML_DOMAIN, NML_INPUT_GRID, NML_MODEL_GRID, NML_OUTPUT_TYPE, & + NML_OUTPUT_DATE, NML_HOMOG_COUNT, NML_HOMOG_INPUT, IERR) + IF (IERR.NE.0) THEN + WRITE (*,'(2A)') 'ERROR: error occured while processing ', IFNAME + CALL EXIT (IERR) + END IF - CALL WMUSET ( MDSS, MDSS, MDSI, .TRUE., 'INP', & - TRIM(FNMPRE)//IFNAME, 'Model control input file') -! -! 1.d Log and test files -! - LFILE = 'log.mww3' - IW = 1 + INT ( LOG10 ( REAL(NMPROC) + 0.5 ) ) - IW = MAX ( 3 , MIN ( 9 , IW ) ) - WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') '(A4,I',IW,'.',IW,',A5)' + CALL WMUSET ( MDSS, MDSS, MDSI, .TRUE., 'INP', & + TRIM(FNMPRE)//IFNAME, 'Model control input file') + ! + ! 1.d Log and test files + ! + LFILE = 'log.mww3' + IW = 1 + INT ( LOG10 ( REAL(NMPROC) + 0.5 ) ) + IW = MAX ( 3 , MIN ( 9 , IW ) ) + WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') '(A4,I',IW,'.',IW,',A5)' #ifdef W3_SHRD - TFILE = 'test.mww3' + TFILE = 'test.mww3' #endif #ifdef W3_DIST - WRITE (TFILE,FORMAT) 'test', IMPROC, '.mww3' + WRITE (TFILE,FORMAT) 'test', IMPROC, '.mww3' #endif #ifdef W3_MPRF - WRITE (PFILE,FORMAT) 'prf.', IMPROC, '.mww3' -#endif -! - IF ( IMPROC .EQ. NMPLOG ) THEN - OPEN (MDSO,FILE=TRIM(FNMPRE)//LFILE,ERR=2010,IOSTAT=IERR) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,911) LFILE, MDSO - CALL WMUSET ( MDSS, MDSS, MDSO, .TRUE., 'OUT', & - TRIM(FNMPRE)//LFILE, 'Log file') - ELSE - CALL WMUSET ( MDSS, MDSS, MDSO, .TRUE., 'XXX', & - 'Log file on other processors') - END IF -! - IF ( MDST.NE.MDSO .AND. MDST.NE.MDSS .AND. TSTOUT ) THEN - IFT = LEN_TRIM(TFILE) - OPEN (MDST,FILE=TRIM(FNMPRE)//TFILE(:IFT),ERR=2011,IOSTAT=IERR) - CALL WMUSET ( MDSS, MDST, MDST, .TRUE., 'OUT', & - TRIM(FNMPRE)//TFILE(:IFT), 'Test output file') - END IF -! + WRITE (PFILE,FORMAT) 'prf.', IMPROC, '.mww3' +#endif + ! + IF ( IMPROC .EQ. NMPLOG ) THEN + OPEN (MDSO,FILE=TRIM(FNMPRE)//LFILE,ERR=2010,IOSTAT=IERR) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,911) LFILE, MDSO + CALL WMUSET ( MDSS, MDSS, MDSO, .TRUE., 'OUT', & + TRIM(FNMPRE)//LFILE, 'Log file') + ELSE + CALL WMUSET ( MDSS, MDSS, MDSO, .TRUE., 'XXX', & + 'Log file on other processors') + END IF + ! + IF ( MDST.NE.MDSO .AND. MDST.NE.MDSS .AND. TSTOUT ) THEN + IFT = LEN_TRIM(TFILE) + OPEN (MDST,FILE=TRIM(FNMPRE)//TFILE(:IFT),ERR=2011,IOSTAT=IERR) + CALL WMUSET ( MDSS, MDST, MDST, .TRUE., 'OUT', & + TRIM(FNMPRE)//TFILE(:IFT), 'Test output file') + END IF + ! #ifdef W3_MPRF - IFT = LEN_TRIM(PFILE) - CALL WMUGET ( MDSS, MDST, MDSP, 'OUT' ) - CALL WMUSET ( MDSS, MDST, MDSP, .TRUE., 'OUT', & - TRIM(FNMPRE)//PFILE(:IFT), 'Profiling file') - OPEN (MDSP,FILE=TRIM(FNMPRE)//PFILE(:IFT),ERR=2011,IOSTAT=IERR) -#endif -! -! 1.e Initial and test output -! + IFT = LEN_TRIM(PFILE) + CALL WMUGET ( MDSS, MDST, MDSP, 'OUT' ) + CALL WMUSET ( MDSS, MDST, MDSP, .TRUE., 'OUT', & + TRIM(FNMPRE)//PFILE(:IFT), 'Profiling file') + OPEN (MDSP,FILE=TRIM(FNMPRE)//PFILE(:IFT),ERR=2011,IOSTAT=IERR) +#endif + ! + ! 1.e Initial and test output + ! #ifdef W3_S - CALL STRACE (IENT, 'WMINITNML') -#endif -! - IF ( IMPROC .EQ. NMPLOG ) THEN - CALL WWDATE ( STDATE ) - CALL WWTIME ( STTIME ) - WRITE (MDSO,901) WWVER, STDATE, STTIME - END IF -! + CALL STRACE (IENT, 'WMINITNML') +#endif + ! + IF ( IMPROC .EQ. NMPLOG ) THEN + CALL WWDATE ( STDATE ) + CALL WWTIME ( STTIME ) + WRITE (MDSO,901) WWVER, STDATE, STTIME + END IF + ! #ifdef W3_T - WRITE(MDST,9000) IDSI, IDSO, IDSS, IDST, IDSE, IFNAME -#endif -! -! 2. Set-up of data structures and I/O ----------------------------- / -! 2.a Get number of grids -! Note: grid for consolidated point output always generated. -! Processor set as in W3INIT to minimize communication in WMIOPO -! - NRINP = NML_DOMAIN%NRINP - NRGRD = NML_DOMAIN%NRGRD - UNIPTS = NML_DOMAIN%UNIPTS - IOSTYP = NML_DOMAIN%IOSTYP - UPPROC = NML_DOMAIN%UPPROC - PSHARE = NML_DOMAIN%PSHARE + WRITE(MDST,9000) IDSI, IDSO, IDSS, IDST, IDSE, IFNAME +#endif + ! + ! 2. Set-up of data structures and I/O ----------------------------- / + ! 2.a Get number of grids + ! Note: grid for consolidated point output always generated. + ! Processor set as in W3INIT to minimize communication in WMIOPO + ! + NRINP = NML_DOMAIN%NRINP + NRGRD = NML_DOMAIN%NRGRD + UNIPTS = NML_DOMAIN%UNIPTS + IOSTYP = NML_DOMAIN%IOSTYP + UPPROC = NML_DOMAIN%UPPROC + PSHARE = NML_DOMAIN%PSHARE - IOSTYP = MAX ( 0 , MIN ( 3 , IOSTYP ) ) -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,920) NRGRD - IF ( NRINP .EQ. 0 ) THEN - WRITE (MDSS,921) - ELSE - WRITE (MDSS,922) NRINP - END IF - IF ( UNIPTS ) THEN - WRITE (MDSS,923) YESXX - ELSE - WRITE (MDSS,923) XXXNO - END IF - WRITE (MDSS,1923) IOSTYP - IF ( UNIPTS ) THEN - IF ( UPPROC ) THEN - WRITE (MDSS,2923) YESXX - ELSE - WRITE (MDSS,2923) XXXNO - END IF - END IF - IF ( IOSTYP.GT.1 .AND. PSHARE ) THEN - WRITE (MDSS,3923) YESXX - ELSE IF ( IOSTYP.GT. 1 ) THEN - WRITE (MDSS,3923) XXXNO - END IF + IOSTYP = MAX ( 0 , MIN ( 3 , IOSTYP ) ) + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,920) NRGRD + IF ( NRINP .EQ. 0 ) THEN + WRITE (MDSS,921) + ELSE + WRITE (MDSS,922) NRINP + END IF + IF ( UNIPTS ) THEN + WRITE (MDSS,923) YESXX + ELSE + WRITE (MDSS,923) XXXNO + END IF + WRITE (MDSS,1923) IOSTYP + IF ( UNIPTS ) THEN + IF ( UPPROC ) THEN + WRITE (MDSS,2923) YESXX + ELSE + WRITE (MDSS,2923) XXXNO END IF -! - IF ( NRGRD .LT. 1 ) GOTO 2020 - IF ( NRINP .LT. 0 ) GOTO 2021 - IF ( NRINP.EQ.0 .AND. .NOT.UNIPTS ) NRINP = -1 -! -! 2.b Set up data structures -! - CALL W3NMOD ( NRGRD, MDSE2, MDST, NRINP ) - CALL W3NDAT ( MDSE2, MDST ) - CALL W3NAUX ( MDSE2, MDST ) - CALL W3NOUT ( MDSE2, MDST ) - CALL W3NINP ( MDSE2, MDST ) - CALL WMNDAT ( MDSE2, MDST ) -! -! 2.c Set up I/O for individual models (initial) -! - ALLOCATE ( MDS(13,NRGRD), NTRACE(2,NRGRD), ODAT(40,0:NRGRD), & - FLGRD(NOGRP,NGRPP,NRGRD), OT2(0:NRGRD), FLGD(NOGRP,NRGRD), & - MDSF(-NRINP:NRGRD,JFIRST:9), IPRT(6,NRGRD), LPRT(NRGRD), & - FLGR2(NOGRP,NGRPP,NRGRD),FLG2D(NOGRP,NGRPP), FLG1D(NOGRP), & - FLG2(NOGRP,NRGRD) & - ,OUTFF(7,0:NRGRD)) -! - MDS = -1 - MDSF = -1 - FLGR2 = .FALSE. - IPRT = 0 -! -! ... Fixed and recycleable unit numbers. -! - CALL WMUGET ( MDSE, MDST, NDSREC, 'INP' ) - CALL WMUSET ( MDSE, MDST, NDSREC, .TRUE., 'I/O', NAME='...', & - DESC='Recyclable I/O (mod_def etc.)' ) - CALL WMUGET ( MDSE, MDST, SCRATCH, 'SCR' ) - CALL WMUSET ( MDSE, MDST, SCRATCH, .TRUE., DESC='Scratch file', & - NAME=TRIM(FNMPRE)//'ww3_multi.scratch' ) -! - IF(MDST.EQ.NDSREC)THEN - IF ( IMPROC .EQ. NMPERR ) & - WRITE(MDSE,'(A,I8)')'RECYCLABLE UNIT NUMBERS AND '& - //'TEST OUTPUT UNIT NUMBER ARE THE SAME : ',MDST - CALL EXTCDE ( 15 ) - ENDIF + END IF + IF ( IOSTYP.GT.1 .AND. PSHARE ) THEN + WRITE (MDSS,3923) YESXX + ELSE IF ( IOSTYP.GT. 1 ) THEN + WRITE (MDSS,3923) XXXNO + END IF + END IF + ! + IF ( NRGRD .LT. 1 ) GOTO 2020 + IF ( NRINP .LT. 0 ) GOTO 2021 + IF ( NRINP.EQ.0 .AND. .NOT.UNIPTS ) NRINP = -1 + ! + ! 2.b Set up data structures + ! + CALL W3NMOD ( NRGRD, MDSE2, MDST, NRINP ) + CALL W3NDAT ( MDSE2, MDST ) + CALL W3NAUX ( MDSE2, MDST ) + CALL W3NOUT ( MDSE2, MDST ) + CALL W3NINP ( MDSE2, MDST ) + CALL WMNDAT ( MDSE2, MDST ) + ! + ! 2.c Set up I/O for individual models (initial) + ! + ALLOCATE ( MDS(13,NRGRD), NTRACE(2,NRGRD), ODAT(40,0:NRGRD), & + FLGRD(NOGRP,NGRPP,NRGRD), OT2(0:NRGRD), FLGD(NOGRP,NRGRD), & + MDSF(-NRINP:NRGRD,JFIRST:9), IPRT(6,NRGRD), LPRT(NRGRD), & + FLGR2(NOGRP,NGRPP,NRGRD),FLG2D(NOGRP,NGRPP), FLG1D(NOGRP), & + FLG2(NOGRP,NRGRD) & + ,OUTFF(7,0:NRGRD)) + ! + MDS = -1 + MDSF = -1 + FLGR2 = .FALSE. + IPRT = 0 + ! + ! ... Fixed and recycleable unit numbers. + ! + CALL WMUGET ( MDSE, MDST, NDSREC, 'INP' ) + CALL WMUSET ( MDSE, MDST, NDSREC, .TRUE., 'I/O', NAME='...', & + DESC='Recyclable I/O (mod_def etc.)' ) + CALL WMUGET ( MDSE, MDST, SCRATCH, 'SCR' ) + CALL WMUSET ( MDSE, MDST, SCRATCH, .TRUE., DESC='Scratch file', & + NAME=TRIM(FNMPRE)//'ww3_multi.scratch' ) + ! + IF(MDST.EQ.NDSREC)THEN + IF ( IMPROC .EQ. NMPERR ) & + WRITE(MDSE,'(A,I8)')'RECYCLABLE UNIT NUMBERS AND '& + //'TEST OUTPUT UNIT NUMBER ARE THE SAME : ',MDST + CALL EXTCDE ( 15 ) + ENDIF - DO I=1, NRGRD - MDS ( 2,I) = 6 - MDS ( 3,I) = MDST - MDS ( 4,I) = 6 - MDS ( 5,I) = NDSREC - MDS ( 6,I) = NDSREC - NTRACE( 1,I) = MDST - NTRACE( 2,I) = NTRMAX - END DO -! + DO I=1, NRGRD + MDS ( 2,I) = 6 + MDS ( 3,I) = MDST + MDS ( 4,I) = 6 + MDS ( 5,I) = NDSREC + MDS ( 6,I) = NDSREC + NTRACE( 1,I) = MDST + NTRACE( 2,I) = NTRMAX + END DO + ! #ifdef W3_T - WRITE (MDST,9020) 'INITIAL' - DO I=1, NRGRD - WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) - END DO -#endif -! -! 3. Get individual grid information -------------------------------- / -! -! Version 3.07: For now we simply read the input data flags, -! skip the homogeneous option. Later on, we want -! to have the options to use input from common -! sources, and from communication rather than -! files. -! - ALLOCATE ( INAMES(2*NRGRD,-7:9), MNAMES(-NRINP:2*NRGRD), & - TMPRNK(2*NRGRD), TMPGRP(2*NRGRD), NINGRP(2*NRGRD), & - RP1(2*NRGRD), RPN(2*NRGRD), BCDTMP(NRGRD+1:2*NRGRD)) - ALLOCATE ( GRANK(NRGRD), GRGRP(NRGRD), USEINP(NRINP) ) - ALLOCATE ( CPLINP(NRINP) ) - GRANK = -1 - GRGRP = -1 - USEINP = .FALSE. - CPLINP = .FALSE. -! -! 3.a Read data -! + WRITE (MDST,9020) 'INITIAL' + DO I=1, NRGRD + WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) + END DO +#endif + ! + ! 3. Get individual grid information -------------------------------- / + ! + ! Version 3.07: For now we simply read the input data flags, + ! skip the homogeneous option. Later on, we want + ! to have the options to use input from common + ! sources, and from communication rather than + ! files. + ! + ALLOCATE ( INAMES(2*NRGRD,-7:9), MNAMES(-NRINP:2*NRGRD), & + TMPRNK(2*NRGRD), TMPGRP(2*NRGRD), NINGRP(2*NRGRD), & + RP1(2*NRGRD), RPN(2*NRGRD), BCDTMP(NRGRD+1:2*NRGRD)) + ALLOCATE ( GRANK(NRGRD), GRGRP(NRGRD), USEINP(NRINP) ) + ALLOCATE ( CPLINP(NRINP) ) + GRANK = -1 + GRGRP = -1 + USEINP = .FALSE. + CPLINP = .FALSE. + ! + ! 3.a Read data + ! #ifdef W3_T - WRITE (MDST,9030) -#endif -! -! 3.a.1 Input grids -! - DO I=1, NRINP -! - CALL W3SETI ( -I, MDSE, MDST ) - INFLAGS1 = .FALSE. - MNAMES(-I) = NML_INPUT_GRID(I)%NAME - INFLAGS1(-7) = NML_INPUT_GRID(I)%FORCING%ICE_PARAM1 - INFLAGS1(-6) = NML_INPUT_GRID(I)%FORCING%ICE_PARAM2 - INFLAGS1(-5) = NML_INPUT_GRID(I)%FORCING%ICE_PARAM3 - INFLAGS1(-4) = NML_INPUT_GRID(I)%FORCING%ICE_PARAM4 - INFLAGS1(-3) = NML_INPUT_GRID(I)%FORCING%ICE_PARAM5 - INFLAGS1(-2) = NML_INPUT_GRID(I)%FORCING%MUD_DENSITY - INFLAGS1(-1) = NML_INPUT_GRID(I)%FORCING%MUD_THICKNESS - INFLAGS1(0) = NML_INPUT_GRID(I)%FORCING%MUD_VISCOSITY - INFLAGS1(1) = NML_INPUT_GRID(I)%FORCING%WATER_LEVELS - INFLAGS1(2) = NML_INPUT_GRID(I)%FORCING%CURRENTS - INFLAGS1(3) = NML_INPUT_GRID(I)%FORCING%WINDS - INFLAGS1(4) = NML_INPUT_GRID(I)%FORCING%ICE_CONC - INFLAGS1(5) = NML_INPUT_GRID(I)%FORCING%ATM_MOMENTUM - INFLAGS1(6) = NML_INPUT_GRID(I)%FORCING%AIR_DENSITY - INFLAGS1(7) = NML_INPUT_GRID(I)%ASSIM%MEAN - INFLAGS1(8) = NML_INPUT_GRID(I)%ASSIM%SPEC1D - INFLAGS1(9) = NML_INPUT_GRID(I)%ASSIM%SPEC2D - END DO -! -! 3.a.2 Unified point output grid. -! - IF ( UNIPTS ) THEN -! - CALL W3SETI ( 0, MDSE, MDST ) - CALL W3SETO ( 0, MDSE, MDST ) - INFLAGS1 = .FALSE. - NDST = MDST - NDSE = MDSE -! - MNAMES(0) = NML_OUTPUT_TYPE(1)%POINT%NAME -! - IF ( IOSTYP .LE. 1 ) THEN - NMPUPT = MAX(1,NMPROC-2) - ELSE - NMPUPT = NMPROC - END IF -! - END IF -! -! 3.a.3 Read wave grids -! - DO I=1,NRGRD - MNAMES(NRGRD+I) = NML_MODEL_GRID(I)%NAME - INAMES(NRGRD+I,-7) = NML_MODEL_GRID(I)%FORCING%ICE_PARAM1 - INAMES(NRGRD+I,-6) = NML_MODEL_GRID(I)%FORCING%ICE_PARAM2 - INAMES(NRGRD+I,-5) = NML_MODEL_GRID(I)%FORCING%ICE_PARAM3 - INAMES(NRGRD+I,-4) = NML_MODEL_GRID(I)%FORCING%ICE_PARAM4 - INAMES(NRGRD+I,-3) = NML_MODEL_GRID(I)%FORCING%ICE_PARAM5 - INAMES(NRGRD+I,-2) = NML_MODEL_GRID(I)%FORCING%MUD_DENSITY - INAMES(NRGRD+I,-1) = NML_MODEL_GRID(I)%FORCING%MUD_THICKNESS - INAMES(NRGRD+I,0) = NML_MODEL_GRID(I)%FORCING%MUD_VISCOSITY - INAMES(NRGRD+I,1) = NML_MODEL_GRID(I)%FORCING%WATER_LEVELS - INAMES(NRGRD+I,2) = NML_MODEL_GRID(I)%FORCING%CURRENTS - INAMES(NRGRD+I,3) = NML_MODEL_GRID(I)%FORCING%WINDS - INAMES(NRGRD+I,4) = NML_MODEL_GRID(I)%FORCING%ICE_CONC - INAMES(NRGRD+I,5) = NML_MODEL_GRID(I)%FORCING%ATM_MOMENTUM - INAMES(NRGRD+I,6) = NML_MODEL_GRID(I)%FORCING%AIR_DENSITY - INAMES(NRGRD+I,7) = NML_MODEL_GRID(I)%ASSIM%MEAN - INAMES(NRGRD+I,8) = NML_MODEL_GRID(I)%ASSIM%SPEC1D - INAMES(NRGRD+I,9) = NML_MODEL_GRID(I)%ASSIM%SPEC2D - TMPRNK(NRGRD+I) = NML_MODEL_GRID(I)%RESOURCE%RANK_ID - TMPGRP(NRGRD+I) = NML_MODEL_GRID(I)%RESOURCE%GROUP_ID - RP1(NRGRD+I) = NML_MODEL_GRID(I)%RESOURCE%COMM_FRAC(1) - RPN(NRGRD+I) = NML_MODEL_GRID(I)%RESOURCE%COMM_FRAC(2) - BCDTMP(NRGRD+I) = NML_MODEL_GRID(I)%RESOURCE%BOUND_FLAG -! - RP1(NRGRD+I) = MAX ( 0. , MIN ( 1. , RP1(NRGRD+I) ) ) - RPN(NRGRD+I) = MAX ( RP1(NRGRD+I) , MIN ( 1. , RPN(NRGRD+I) ) ) - END DO -! -! 3.a.4 Sort wave grids -! - RNKTMP = MINVAL ( TMPRNK(NRGRD+1:2*NRGRD) ) - I = 0 -! - DO - DO J=NRGRD+1, 2*NRGRD - IF ( TMPRNK(J) .EQ. RNKTMP ) THEN - I = I + 1 - CALL W3SETI ( I, MDSE, MDST ) - INFLAGS1 = .FALSE. + WRITE (MDST,9030) +#endif + ! + ! 3.a.1 Input grids + ! + DO I=1, NRINP + ! + CALL W3SETI ( -I, MDSE, MDST ) + INFLAGS1 = .FALSE. + MNAMES(-I) = NML_INPUT_GRID(I)%NAME + INFLAGS1(-7) = NML_INPUT_GRID(I)%FORCING%ICE_PARAM1 + INFLAGS1(-6) = NML_INPUT_GRID(I)%FORCING%ICE_PARAM2 + INFLAGS1(-5) = NML_INPUT_GRID(I)%FORCING%ICE_PARAM3 + INFLAGS1(-4) = NML_INPUT_GRID(I)%FORCING%ICE_PARAM4 + INFLAGS1(-3) = NML_INPUT_GRID(I)%FORCING%ICE_PARAM5 + INFLAGS1(-2) = NML_INPUT_GRID(I)%FORCING%MUD_DENSITY + INFLAGS1(-1) = NML_INPUT_GRID(I)%FORCING%MUD_THICKNESS + INFLAGS1(0) = NML_INPUT_GRID(I)%FORCING%MUD_VISCOSITY + INFLAGS1(1) = NML_INPUT_GRID(I)%FORCING%WATER_LEVELS + INFLAGS1(2) = NML_INPUT_GRID(I)%FORCING%CURRENTS + INFLAGS1(3) = NML_INPUT_GRID(I)%FORCING%WINDS + INFLAGS1(4) = NML_INPUT_GRID(I)%FORCING%ICE_CONC + INFLAGS1(5) = NML_INPUT_GRID(I)%FORCING%ATM_MOMENTUM + INFLAGS1(6) = NML_INPUT_GRID(I)%FORCING%AIR_DENSITY + INFLAGS1(7) = NML_INPUT_GRID(I)%ASSIM%MEAN + INFLAGS1(8) = NML_INPUT_GRID(I)%ASSIM%SPEC1D + INFLAGS1(9) = NML_INPUT_GRID(I)%ASSIM%SPEC2D + END DO + ! + ! 3.a.2 Unified point output grid. + ! + IF ( UNIPTS ) THEN + ! + CALL W3SETI ( 0, MDSE, MDST ) + CALL W3SETO ( 0, MDSE, MDST ) + INFLAGS1 = .FALSE. + NDST = MDST + NDSE = MDSE + ! + MNAMES(0) = NML_OUTPUT_TYPE(1)%POINT%NAME + ! + IF ( IOSTYP .LE. 1 ) THEN + NMPUPT = MAX(1,NMPROC-2) + ELSE + NMPUPT = NMPROC + END IF + ! + END IF + ! + ! 3.a.3 Read wave grids + ! + DO I=1,NRGRD + MNAMES(NRGRD+I) = NML_MODEL_GRID(I)%NAME + INAMES(NRGRD+I,-7) = NML_MODEL_GRID(I)%FORCING%ICE_PARAM1 + INAMES(NRGRD+I,-6) = NML_MODEL_GRID(I)%FORCING%ICE_PARAM2 + INAMES(NRGRD+I,-5) = NML_MODEL_GRID(I)%FORCING%ICE_PARAM3 + INAMES(NRGRD+I,-4) = NML_MODEL_GRID(I)%FORCING%ICE_PARAM4 + INAMES(NRGRD+I,-3) = NML_MODEL_GRID(I)%FORCING%ICE_PARAM5 + INAMES(NRGRD+I,-2) = NML_MODEL_GRID(I)%FORCING%MUD_DENSITY + INAMES(NRGRD+I,-1) = NML_MODEL_GRID(I)%FORCING%MUD_THICKNESS + INAMES(NRGRD+I,0) = NML_MODEL_GRID(I)%FORCING%MUD_VISCOSITY + INAMES(NRGRD+I,1) = NML_MODEL_GRID(I)%FORCING%WATER_LEVELS + INAMES(NRGRD+I,2) = NML_MODEL_GRID(I)%FORCING%CURRENTS + INAMES(NRGRD+I,3) = NML_MODEL_GRID(I)%FORCING%WINDS + INAMES(NRGRD+I,4) = NML_MODEL_GRID(I)%FORCING%ICE_CONC + INAMES(NRGRD+I,5) = NML_MODEL_GRID(I)%FORCING%ATM_MOMENTUM + INAMES(NRGRD+I,6) = NML_MODEL_GRID(I)%FORCING%AIR_DENSITY + INAMES(NRGRD+I,7) = NML_MODEL_GRID(I)%ASSIM%MEAN + INAMES(NRGRD+I,8) = NML_MODEL_GRID(I)%ASSIM%SPEC1D + INAMES(NRGRD+I,9) = NML_MODEL_GRID(I)%ASSIM%SPEC2D + TMPRNK(NRGRD+I) = NML_MODEL_GRID(I)%RESOURCE%RANK_ID + TMPGRP(NRGRD+I) = NML_MODEL_GRID(I)%RESOURCE%GROUP_ID + RP1(NRGRD+I) = NML_MODEL_GRID(I)%RESOURCE%COMM_FRAC(1) + RPN(NRGRD+I) = NML_MODEL_GRID(I)%RESOURCE%COMM_FRAC(2) + BCDTMP(NRGRD+I) = NML_MODEL_GRID(I)%RESOURCE%BOUND_FLAG + ! + RP1(NRGRD+I) = MAX ( 0. , MIN ( 1. , RP1(NRGRD+I) ) ) + RPN(NRGRD+I) = MAX ( RP1(NRGRD+I) , MIN ( 1. , RPN(NRGRD+I) ) ) + END DO + ! + ! 3.a.4 Sort wave grids + ! + RNKTMP = MINVAL ( TMPRNK(NRGRD+1:2*NRGRD) ) + I = 0 + ! + DO + DO J=NRGRD+1, 2*NRGRD + IF ( TMPRNK(J) .EQ. RNKTMP ) THEN + I = I + 1 + CALL W3SETI ( I, MDSE, MDST ) + INFLAGS1 = .FALSE. #ifdef W3_MGW - INFLAGS1(10) = .TRUE. + INFLAGS1(10) = .TRUE. #endif #ifdef W3_MGP - INFLAGS1(10) = .TRUE. -#endif - INAMES(I,:)= INAMES(J,:) - MNAMES(I) = MNAMES(J) - TMPRNK(I) = TMPRNK(J) - TMPGRP(I) = TMPGRP(J) - RP1(I) = RP1(J) - RPN(I) = RPN(J) - BCDUMP(I) = BCDTMP(J) + INFLAGS1(10) = .TRUE. +#endif + INAMES(I,:)= INAMES(J,:) + MNAMES(I) = MNAMES(J) + TMPRNK(I) = TMPRNK(J) + TMPGRP(I) = TMPGRP(J) + RP1(I) = RP1(J) + RPN(I) = RPN(J) + BCDUMP(I) = BCDTMP(J) #ifdef W3_T - WRITE (MDST,9031) I, MNAMES(I), INFLAGS1, TMPRNK(I), & - TMPGRP(I), RP1(I), RPN(I) + WRITE (MDST,9031) I, MNAMES(I), INFLAGS1, TMPRNK(I), & + TMPGRP(I), RP1(I), RPN(I) #endif + END IF + END DO + IF ( I .EQ. NRGRD ) EXIT + RNKTMP = RNKTMP + 1 + END DO + ! + ! 3.a.5 Set input flags + ! + ALLOCATE ( INPMAP(NRGRD,JFIRST:10), IDINP(-NRINP:NRGRD,JFIRST:10) ) + INPMAP = 0 + IDINP = '---' + ! + DO I=1, NRGRD + CALL W3SETI ( I, MDSE, MDST ) + DO J=JFIRST, 9 + IF ( INAMES(I,J) .EQ. 'native' ) THEN + ! *** forcing input from file & defined on the native grid *** + INFLAGS1(J) = .TRUE. + ELSE + INFLAGS1(J) = .FALSE. + IF ( INAMES(I,J)(1:4) .EQ. 'CPL:' ) THEN + IF ( INAMES(I,J)(5:) .EQ. 'native' ) THEN + ! *** forcing input from CPL & defined on the native grid *** + INFLAGS1(J) = .TRUE. + INPMAP(I,J) = -999 + ELSE + ! *** forcing input from CPL & defined on an input grid *** + DO JJ=1, NRINP + IF ( MNAMES(-JJ) .EQ. INAMES(I,J)(5:) ) THEN + INPMAP(I,J) = -JJ + EXIT + END IF + END DO + IF ( INPMAP(I,J) .EQ. 0 ) GOTO 2030 + IF ( .NOT. INPUTS(INPMAP(I,J))%INFLAGS1(J) ) GOTO 2031 + USEINP(-INPMAP(I,J)) = .TRUE. + CPLINP(-INPMAP(I,J)) = .TRUE. END IF - END DO - IF ( I .EQ. NRGRD ) EXIT - RNKTMP = RNKTMP + 1 - END DO -! -! 3.a.5 Set input flags -! - ALLOCATE ( INPMAP(NRGRD,JFIRST:10), IDINP(-NRINP:NRGRD,JFIRST:10) ) - INPMAP = 0 - IDINP = '---' -! - DO I=1, NRGRD - CALL W3SETI ( I, MDSE, MDST ) - DO J=JFIRST, 9 - IF ( INAMES(I,J) .EQ. 'native' ) THEN - ! *** forcing input from file & defined on the native grid *** - INFLAGS1(J) = .TRUE. - ELSE - INFLAGS1(J) = .FALSE. - IF ( INAMES(I,J)(1:4) .EQ. 'CPL:' ) THEN - IF ( INAMES(I,J)(5:) .EQ. 'native' ) THEN - ! *** forcing input from CPL & defined on the native grid *** - INFLAGS1(J) = .TRUE. - INPMAP(I,J) = -999 - ELSE - ! *** forcing input from CPL & defined on an input grid *** - DO JJ=1, NRINP - IF ( MNAMES(-JJ) .EQ. INAMES(I,J)(5:) ) THEN - INPMAP(I,J) = -JJ - EXIT - END IF - END DO - IF ( INPMAP(I,J) .EQ. 0 ) GOTO 2030 - IF ( .NOT. INPUTS(INPMAP(I,J))%INFLAGS1(J) ) GOTO 2031 - USEINP(-INPMAP(I,J)) = .TRUE. - CPLINP(-INPMAP(I,J)) = .TRUE. - END IF - ELSE IF ( INAMES(I,J) .NE. 'no' ) THEN - ! *** forcing input from file & defined on an input grid *** - DO JJ=1, NRINP - IF ( MNAMES(-JJ) .EQ. INAMES(I,J) ) THEN - INPMAP(I,J) = JJ - INFLAGS2(J) = .TRUE. - EXIT - END IF - END DO - IF ( INPMAP(I,J) .EQ. 0 ) GOTO 2030 - IF ( .NOT. INPUTS(-INPMAP(I,J))%INFLAGS1(J) ) GOTO 2031 - USEINP(INPMAP(I,J)) = .TRUE. - END IF + ELSE IF ( INAMES(I,J) .NE. 'no' ) THEN + ! *** forcing input from file & defined on an input grid *** + DO JJ=1, NRINP + IF ( MNAMES(-JJ) .EQ. INAMES(I,J) ) THEN + INPMAP(I,J) = JJ + INFLAGS2(J) = .TRUE. + EXIT END IF -! INFLAGS2 is initial value of INFLAGS1. Unlike INFLAGS1, -! it does not change during the simulation - IF(.NOT. INFLAGS2(J)) INFLAGS2(J)=INFLAGS1(J) - END DO ! DO J=JFIRST, 9 - END DO ! DO I=1, NRGRD -! - DO I=1, NRINP - IF ( .NOT.USEINP(I) .AND. & - MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - II = LEN_TRIM(MNAMES(-I)) - WRITE (MDSE,1032) MNAMES(-I)(1:II) + END DO + IF ( INPMAP(I,J) .EQ. 0 ) GOTO 2030 + IF ( .NOT. INPUTS(-INPMAP(I,J))%INFLAGS1(J) ) GOTO 2031 + USEINP(INPMAP(I,J)) = .TRUE. END IF - END DO -! -! 3.b Assign input file unit numbers -! - DO I=-NRINP, NRGRD - IF ( I .EQ. 0 ) CYCLE - CALL W3SETI ( I, MDSE, MDST ) - DO J=JFIRST, 9 - IF ( I .GE. 1 ) THEN - IF ( INPMAP(I,J) .LT. 0 ) CYCLE - END IF - IF ( INFLAGS1(J) ) THEN - CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) - CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & - DESC='Input data file' ) - MDSF(I,J) = NDSFND - END IF - END DO - END DO -! + END IF + ! INFLAGS2 is initial value of INFLAGS1. Unlike INFLAGS1, + ! it does not change during the simulation + IF(.NOT. INFLAGS2(J)) INFLAGS2(J)=INFLAGS1(J) + END DO ! DO J=JFIRST, 9 + END DO ! DO I=1, NRGRD + ! + DO I=1, NRINP + IF ( .NOT.USEINP(I) .AND. & + MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + II = LEN_TRIM(MNAMES(-I)) + WRITE (MDSE,1032) MNAMES(-I)(1:II) + END IF + END DO + ! + ! 3.b Assign input file unit numbers + ! + DO I=-NRINP, NRGRD + IF ( I .EQ. 0 ) CYCLE + CALL W3SETI ( I, MDSE, MDST ) + DO J=JFIRST, 9 + IF ( I .GE. 1 ) THEN + IF ( INPMAP(I,J) .LT. 0 ) CYCLE + END IF + IF ( INFLAGS1(J) ) THEN + CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) + CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & + DESC='Input data file' ) + MDSF(I,J) = NDSFND + END IF + END DO + END DO + ! #ifdef W3_T - WRITE (MDST,9022) - DO I=-NRINP, NRGRD - IF ( I .EQ. 0 ) CYCLE - WRITE (MDST,9021) I, MDSF(I,JFIRST:9) - END DO -#endif -! -! 3.c Set rank and group data -! + WRITE (MDST,9022) + DO I=-NRINP, NRGRD + IF ( I .EQ. 0 ) CYCLE + WRITE (MDST,9021) I, MDSF(I,JFIRST:9) + END DO +#endif + ! + ! 3.c Set rank and group data + ! #ifdef W3_T - WRITE (MDST,9032) -#endif -! - RNKMAX = MAXVAL ( TMPRNK(1:NRGRD) ) + 1 - RNKTMP = 0 -! + WRITE (MDST,9032) +#endif + ! + RNKMAX = MAXVAL ( TMPRNK(1:NRGRD) ) + 1 + RNKTMP = 0 + ! + DO + RNKMIN = MINVAL ( TMPRNK(1:NRGRD) ) + IF ( RNKMIN .EQ. RNKMAX ) EXIT + RNKTMP = RNKTMP + 1 + DO I=1, NRGRD + IF ( TMPRNK(I) .EQ. RNKMIN ) THEN + GRANK(I) = RNKTMP + TMPRNK(I) = RNKMAX + END IF + END DO + END DO + ! +#ifdef W3_T + DO I=1, NRGRD + WRITE (MDST,9033) I, MNAMES(I), GRANK(I) + END DO +#endif + ! + RNKMAX = RNKTMP + GRPMAX = MAXVAL ( TMPGRP(1:NRGRD) ) + 1 + NRGRP = 0 + NINGRP = 0 + ! + DO RNKTMP=1, RNKMAX DO - RNKMIN = MINVAL ( TMPRNK(1:NRGRD) ) - IF ( RNKMIN .EQ. RNKMAX ) EXIT - RNKTMP = RNKTMP + 1 + GRPMIN = GRPMAX DO I=1, NRGRD - IF ( TMPRNK(I) .EQ. RNKMIN ) THEN - GRANK(I) = RNKTMP - TMPRNK(I) = RNKMAX - END IF - END DO - END DO -! -#ifdef W3_T - DO I=1, NRGRD - WRITE (MDST,9033) I, MNAMES(I), GRANK(I) + IF ( GRANK(I) .EQ. RNKTMP ) & + GRPMIN = MIN ( GRPMIN , TMPGRP(I) ) END DO -#endif -! - RNKMAX = RNKTMP - GRPMAX = MAXVAL ( TMPGRP(1:NRGRD) ) + 1 - NRGRP = 0 - NINGRP = 0 -! - DO RNKTMP=1, RNKMAX - DO - GRPMIN = GRPMAX - DO I=1, NRGRD - IF ( GRANK(I) .EQ. RNKTMP ) & - GRPMIN = MIN ( GRPMIN , TMPGRP(I) ) - END DO - IF ( GRPMIN .EQ. GRPMAX ) EXIT - NRGRP = NRGRP + 1 - DO I=1, NRGRD - IF ( GRANK(I).EQ.RNKTMP .AND. GRPMIN.EQ.TMPGRP(I) ) THEN - GRGRP(I) = NRGRP - TMPGRP(I) = GRPMAX - NINGRP(NRGRP) = NINGRP(NRGRP) + 1 - END IF - END DO - END DO + IF ( GRPMIN .EQ. GRPMAX ) EXIT + NRGRP = NRGRP + 1 + DO I=1, NRGRD + IF ( GRANK(I).EQ.RNKTMP .AND. GRPMIN.EQ.TMPGRP(I) ) THEN + GRGRP(I) = NRGRP + TMPGRP(I) = GRPMAX + NINGRP(NRGRP) = NINGRP(NRGRP) + 1 + END IF END DO -! + END DO + END DO + ! #ifdef W3_T - WRITE (MDST,9034) NRGRP - DO I=1, NRGRD - WRITE (MDST,9033) I, MNAMES(I), GRGRP(I) - END DO - WRITE (MDST,9035) NINGRP(1:NRGRP) -#endif -! - ALLOCATE ( ACTION(JFIRST:11) ) - ALLOCATE ( INGRP(NRGRP,0:MAXVAL(NINGRP(:NRGRP))) ) - DEALLOCATE ( TMPRNK, TMPGRP, NINGRP, BCDTMP ) - INGRP = 0 -! - DO I=1, NRGRD - INGRP(GRGRP(I),0) = INGRP(GRGRP(I),0) + 1 - INGRP(GRGRP(I),INGRP(GRGRP(I),0)) = I - END DO -! + WRITE (MDST,9034) NRGRP + DO I=1, NRGRD + WRITE (MDST,9033) I, MNAMES(I), GRGRP(I) + END DO + WRITE (MDST,9035) NINGRP(1:NRGRP) +#endif + ! + ALLOCATE ( ACTION(JFIRST:11) ) + ALLOCATE ( INGRP(NRGRP,0:MAXVAL(NINGRP(:NRGRP))) ) + DEALLOCATE ( TMPRNK, TMPGRP, NINGRP, BCDTMP ) + INGRP = 0 + ! + DO I=1, NRGRD + INGRP(GRGRP(I),0) = INGRP(GRGRP(I),0) + 1 + INGRP(GRGRP(I),INGRP(GRGRP(I),0)) = I + END DO + ! #ifdef W3_T - WRITE (MDST,9036) - DO J=1, NRGRP - WRITE (MDST,9037) J, INGRP(J,:INGRP(J,0)) - END DO -#endif -! -! -! 3.d Unified point output -! + WRITE (MDST,9036) + DO J=1, NRGRP + WRITE (MDST,9037) J, INGRP(J,:INGRP(J,0)) + END DO +#endif + ! + ! + ! 3.d Unified point output + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.b' - PRFT0 = PRFTN -#endif -! - IF ( UNIPTS ) THEN -! - J = LEN_TRIM(MNAMES(0)) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,986) MNAMES(0)(1:J) - WRITE (MDSS,987) - END IF -! - CALL W3IOGR ( 'GRID', NDSREC, 0, MNAMES(0)(1:J) ) -! - END IF -! -! 3.e Output -! - IF ( NRINP .GT. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,924) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,924) - DO I=1, NRINP - IF ( .NOT. USEINP(I) ) CYCLE - CALL W3SETI ( -I, MDSE, MDST ) - ACTION(1:6) = '--- ' - DO J=JFIRST, 6 - IF ( INFLAGS1(J) ) ACTION(J) = ' X ' - END DO - ACTION(7:9) = '- ' - IF ( INFLAGS1(7) ) ACTION(7) = '1 ' - IF ( INFLAGS1(8) ) ACTION(8) = '2 ' - IF ( INFLAGS1(9) ) ACTION(9) = '3 ' - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,925) I, MNAMES(-I), ACTION(JFIRST:9) - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,925) I, MNAMES(-I), ACTION(JFIRST:9) - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,926) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,926) - END IF -! - IF ( UNIPTS ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,927) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,927) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,928) MNAMES(0) - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,928) MNAMES(0) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,929) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,929) - END IF -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,930) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,930) - DO I=1, NRGRD - CALL W3SETI ( I, MDSE, MDST ) + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.b' + PRFT0 = PRFTN +#endif + ! + IF ( UNIPTS ) THEN + ! + J = LEN_TRIM(MNAMES(0)) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,986) MNAMES(0)(1:J) + WRITE (MDSS,987) + END IF + ! + CALL W3IOGR ( 'GRID', NDSREC, 0, MNAMES(0)(1:J) ) + ! + END IF + ! + ! 3.e Output + ! + IF ( NRINP .GT. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,924) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,924) + DO I=1, NRINP + IF ( .NOT. USEINP(I) ) CYCLE + CALL W3SETI ( -I, MDSE, MDST ) ACTION(1:6) = '--- ' DO J=JFIRST, 6 - IF ( INFLAGS1(J) .AND. INPMAP(I,J) .EQ. 0 ) THEN - ACTION(J) = 'native' - ELSE IF ( INFLAGS1(J) .AND. INPMAP(I,J) .EQ. -999 ) THEN - ACTION(J) = 'native' - ELSE IF ( INPMAP(I,J) .GT. 0 ) THEN - ACTION(J) = MNAMES(-INPMAP(I,J)) - ELSE IF ( INPMAP(I,J) .LT. 0 ) THEN - ACTION(J) = MNAMES( INPMAP(I,J)) - END IF - END DO - ACTION(7:11) = '- ' + IF ( INFLAGS1(J) ) ACTION(J) = ' X ' + END DO + ACTION(7:9) = '- ' IF ( INFLAGS1(7) ) ACTION(7) = '1 ' IF ( INFLAGS1(8) ) ACTION(8) = '2 ' IF ( INFLAGS1(9) ) ACTION(9) = '3 ' - IF ( INFLAGS1(10) ) THEN - ACTION(10) = 'yes ' - ELSE - ACTION(10) = 'no ' - END IF - IF ( BCDUMP(I) ) ACTION(11) = 'y ' - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,931) I, MNAMES(I), ACTION(1:10), GRANK(I), & - GRGRP(I), ACTION(11) - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,931) I, MNAMES(I), ACTION(1:10), GRANK(I), & - GRGRP(I), ACTION(11) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,925) I, MNAMES(-I), ACTION(JFIRST:9) + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,925) I, MNAMES(-I), ACTION(JFIRST:9) END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,932) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,932) -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,933) 'Group information' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,933) 'Group information' - DO J=1, NRGRP - WRITE (LINE(1:6),'(1X,I3,2X)') J - JJJ = 6 - DO JJ=1, INGRP(J,0) - IF ( JJJ .GT. 60 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,934) LINE(1:JJJ) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,934) LINE(1:JJJ) - LINE(1:6) = ' ' - JJJ = 6 - END IF - WRITE (LINE(JJJ+1:JJJ+3),'(I3)') INGRP(J,JJ) -! - LINE(JJJ+4:JJJ+5) = ' (' - WRITE (LINE(JJJ+6:JJJ+11),'(F6.4)') RP1(INGRP(J,JJ)) - LINE(JJJ+12:JJJ+12) = '-' - WRITE (LINE(JJJ+13:JJJ+18),'(F6.4)') RPN(INGRP(J,JJ)) - LINE(JJJ+19:JJJ+19) = ')' - JJJ = JJJ + 19 -! - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,934) LINE(1:JJJ) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,934) LINE(1:JJJ) - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) -! -! 4. Model run time information etc. -------------------------------- / -! -! Version 3.07: Same for all grids, diversify later .... -! If invoked as ESMF Component, then STIME and ETIME are set -! in WMESMFMD from the external clock. -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,940) -! - IF (IS_ESMF_COMPONENT) THEN - READ(NML_DOMAIN%START, *) STMPT - READ(NML_DOMAIN%STOP, *) ETMPT - ELSE - READ(NML_DOMAIN%START, *) STIME - READ(NML_DOMAIN%STOP, *) ETIME + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,926) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,926) + END IF + ! + IF ( UNIPTS ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,927) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,927) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,928) MNAMES(0) + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,928) MNAMES(0) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,929) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,929) + END IF + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,930) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,930) + DO I=1, NRGRD + CALL W3SETI ( I, MDSE, MDST ) + ACTION(1:6) = '--- ' + DO J=JFIRST, 6 + IF ( INFLAGS1(J) .AND. INPMAP(I,J) .EQ. 0 ) THEN + ACTION(J) = 'native' + ELSE IF ( INFLAGS1(J) .AND. INPMAP(I,J) .EQ. -999 ) THEN + ACTION(J) = 'native' + ELSE IF ( INPMAP(I,J) .GT. 0 ) THEN + ACTION(J) = MNAMES(-INPMAP(I,J)) + ELSE IF ( INPMAP(I,J) .LT. 0 ) THEN + ACTION(J) = MNAMES( INPMAP(I,J)) END IF - CALL STME21 ( STIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,941) DTME21 - CALL STME21 ( ETIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,942) DTME21 -! - DO I=1, NRGRD - CALL W3SETW ( I, MDSE, MDST ) - TIME = STIME - END DO -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,943) -! - FLGHG1 = NML_DOMAIN%FLGHG1 - FLGHG2 = NML_DOMAIN%FLGHG2 - FLGHG2 = FLGHG1 .AND. FLGHG2 -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - IF ( FLGHG1 ) THEN - WRITE (MDSS,944) YESXX - ELSE - WRITE (MDSS,944) XXXNO - END IF - IF ( FLGHG2 ) THEN - WRITE (MDSS,945) YESXX - ELSE - WRITE (MDSS,945) XXXNO - END IF + END DO + ACTION(7:11) = '- ' + IF ( INFLAGS1(7) ) ACTION(7) = '1 ' + IF ( INFLAGS1(8) ) ACTION(8) = '2 ' + IF ( INFLAGS1(9) ) ACTION(9) = '3 ' + IF ( INFLAGS1(10) ) THEN + ACTION(10) = 'yes ' + ELSE + ACTION(10) = 'no ' + END IF + IF ( BCDUMP(I) ) ACTION(11) = 'y ' + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,931) I, MNAMES(I), ACTION(1:10), GRANK(I), & + GRGRP(I), ACTION(11) + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,931) I, MNAMES(I), ACTION(1:10), GRANK(I), & + GRGRP(I), ACTION(11) + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,932) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,932) + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,933) 'Group information' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,933) 'Group information' + DO J=1, NRGRP + WRITE (LINE(1:6),'(1X,I3,2X)') J + JJJ = 6 + DO JJ=1, INGRP(J,0) + IF ( JJJ .GT. 60 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,934) LINE(1:JJJ) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,934) LINE(1:JJJ) + LINE(1:6) = ' ' + JJJ = 6 END IF -! -! 5. Output requests ------------------------------------------------ / -! - OT2(:)%NPTS = 0 - ILOOP = 0 -! -! 5.a Loop over types -! - DO I=1, NRGRD - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,950) TRIM(MNAMES(NRGRD+I)) - NOTYPE = 6 + WRITE (LINE(JJJ+1:JJJ+3),'(I3)') INGRP(J,JJ) + ! + LINE(JJJ+4:JJJ+5) = ' (' + WRITE (LINE(JJJ+6:JJJ+11),'(F6.4)') RP1(INGRP(J,JJ)) + LINE(JJJ+12:JJJ+12) = '-' + WRITE (LINE(JJJ+13:JJJ+18),'(F6.4)') RPN(INGRP(J,JJ)) + LINE(JJJ+19:JJJ+19) = ')' + JJJ = JJJ + 19 + ! + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,934) LINE(1:JJJ) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,934) LINE(1:JJJ) + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + ! + ! 4. Model run time information etc. -------------------------------- / + ! + ! Version 3.07: Same for all grids, diversify later .... + ! If invoked as ESMF Component, then STIME and ETIME are set + ! in WMESMFMD from the external clock. + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,940) + ! + IF (IS_ESMF_COMPONENT) THEN + READ(NML_DOMAIN%START, *) STMPT + READ(NML_DOMAIN%STOP, *) ETMPT + ELSE + READ(NML_DOMAIN%START, *) STIME + READ(NML_DOMAIN%STOP, *) ETIME + END IF + CALL STME21 ( STIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,941) DTME21 + CALL STME21 ( ETIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,942) DTME21 + ! + DO I=1, NRGRD + CALL W3SETW ( I, MDSE, MDST ) + TIME = STIME + END DO + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,943) + ! + FLGHG1 = NML_DOMAIN%FLGHG1 + FLGHG2 = NML_DOMAIN%FLGHG2 + FLGHG2 = FLGHG1 .AND. FLGHG2 + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + IF ( FLGHG1 ) THEN + WRITE (MDSS,944) YESXX + ELSE + WRITE (MDSS,944) XXXNO + END IF + IF ( FLGHG2 ) THEN + WRITE (MDSS,945) YESXX + ELSE + WRITE (MDSS,945) XXXNO + END IF + END IF + ! + ! 5. Output requests ------------------------------------------------ / + ! + OT2(:)%NPTS = 0 + ILOOP = 0 + ! + ! 5.a Loop over types + ! + DO I=1, NRGRD + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,950) TRIM(MNAMES(NRGRD+I)) + NOTYPE = 6 - READ(NML_OUTPUT_DATE(I)%FIELD%START, *) ODAT(1,I), ODAT(2,I) - READ(NML_OUTPUT_DATE(I)%FIELD%STRIDE, *) ODAT(3,I) - READ(NML_OUTPUT_DATE(I)%FIELD%STOP, *) ODAT(4,I), ODAT(5,I) - READ(NML_OUTPUT_DATE(I)%FIELD%OUTFFILE, *) OUTFF(1,I) - READ(NML_OUTPUT_DATE(I)%POINT%START, *) ODAT(6,I), ODAT(7,I) - READ(NML_OUTPUT_DATE(I)%POINT%STRIDE, *) ODAT(8,I) - READ(NML_OUTPUT_DATE(I)%POINT%STOP, *) ODAT(9,I), ODAT(10,I) - READ(NML_OUTPUT_DATE(I)%POINT%OUTFFILE, *) OUTFF(2,I) - READ(NML_OUTPUT_DATE(I)%TRACK%START, *) ODAT(11,I), ODAT(12,I) - READ(NML_OUTPUT_DATE(I)%TRACK%STRIDE, *) ODAT(13,I) - READ(NML_OUTPUT_DATE(I)%TRACK%STOP, *) ODAT(14,I), ODAT(15,I) - READ(NML_OUTPUT_DATE(I)%RESTART%START, *) ODAT(16,I), ODAT(17,I) - READ(NML_OUTPUT_DATE(I)%RESTART%STRIDE, *) ODAT(18,I) - READ(NML_OUTPUT_DATE(I)%RESTART%STOP, *) ODAT(19,I), ODAT(20,I) - READ(NML_OUTPUT_DATE(I)%RESTART2%START, *) ODAT(36,I), ODAT(37,I) - READ(NML_OUTPUT_DATE(I)%RESTART2%STRIDE, *) ODAT(38,I) - READ(NML_OUTPUT_DATE(I)%RESTART2%STOP, *) ODAT(39,I), ODAT(40,I) - READ(NML_OUTPUT_DATE(I)%BOUNDARY%START, *) ODAT(21,I), ODAT(22,I) - READ(NML_OUTPUT_DATE(I)%BOUNDARY%STRIDE, *) ODAT(23,I) - READ(NML_OUTPUT_DATE(I)%BOUNDARY%STOP, *) ODAT(24,I), ODAT(25,I) - READ(NML_OUTPUT_DATE(I)%PARTITION%START, *) ODAT(26,I), ODAT(27,I) - READ(NML_OUTPUT_DATE(I)%PARTITION%STRIDE, *) ODAT(28,I) - READ(NML_OUTPUT_DATE(I)%PARTITION%STOP, *) ODAT(29,I), ODAT(30,I) + READ(NML_OUTPUT_DATE(I)%FIELD%START, *) ODAT(1,I), ODAT(2,I) + READ(NML_OUTPUT_DATE(I)%FIELD%STRIDE, *) ODAT(3,I) + READ(NML_OUTPUT_DATE(I)%FIELD%STOP, *) ODAT(4,I), ODAT(5,I) + READ(NML_OUTPUT_DATE(I)%FIELD%OUTFFILE, *) OUTFF(1,I) + READ(NML_OUTPUT_DATE(I)%POINT%START, *) ODAT(6,I), ODAT(7,I) + READ(NML_OUTPUT_DATE(I)%POINT%STRIDE, *) ODAT(8,I) + READ(NML_OUTPUT_DATE(I)%POINT%STOP, *) ODAT(9,I), ODAT(10,I) + READ(NML_OUTPUT_DATE(I)%POINT%OUTFFILE, *) OUTFF(2,I) + READ(NML_OUTPUT_DATE(I)%TRACK%START, *) ODAT(11,I), ODAT(12,I) + READ(NML_OUTPUT_DATE(I)%TRACK%STRIDE, *) ODAT(13,I) + READ(NML_OUTPUT_DATE(I)%TRACK%STOP, *) ODAT(14,I), ODAT(15,I) + READ(NML_OUTPUT_DATE(I)%RESTART%START, *) ODAT(16,I), ODAT(17,I) + READ(NML_OUTPUT_DATE(I)%RESTART%STRIDE, *) ODAT(18,I) + READ(NML_OUTPUT_DATE(I)%RESTART%STOP, *) ODAT(19,I), ODAT(20,I) + READ(NML_OUTPUT_DATE(I)%RESTART2%START, *) ODAT(36,I), ODAT(37,I) + READ(NML_OUTPUT_DATE(I)%RESTART2%STRIDE, *) ODAT(38,I) + READ(NML_OUTPUT_DATE(I)%RESTART2%STOP, *) ODAT(39,I), ODAT(40,I) + READ(NML_OUTPUT_DATE(I)%BOUNDARY%START, *) ODAT(21,I), ODAT(22,I) + READ(NML_OUTPUT_DATE(I)%BOUNDARY%STRIDE, *) ODAT(23,I) + READ(NML_OUTPUT_DATE(I)%BOUNDARY%STOP, *) ODAT(24,I), ODAT(25,I) + READ(NML_OUTPUT_DATE(I)%PARTITION%START, *) ODAT(26,I), ODAT(27,I) + READ(NML_OUTPUT_DATE(I)%PARTITION%STRIDE, *) ODAT(28,I) + READ(NML_OUTPUT_DATE(I)%PARTITION%STOP, *) ODAT(29,I), ODAT(30,I) - ! set the time stride at 0 or more - ODAT(3,I) = MAX ( 0 , ODAT(3,I) ) - ODAT(8,I) = MAX ( 0 , ODAT(8,I) ) - ODAT(13,I) = MAX ( 0 , ODAT(13,I) ) - ODAT(18,I) = MAX ( 0 , ODAT(18,I) ) - ODAT(23,I) = MAX ( 0 , ODAT(23,I) ) - ODAT(28,I) = MAX ( 0 , ODAT(28,I) ) - ODAT(38,I) = MAX ( 0 , ODAT(38,I) ) + ! set the time stride at 0 or more + ODAT(3,I) = MAX ( 0 , ODAT(3,I) ) + ODAT(8,I) = MAX ( 0 , ODAT(8,I) ) + ODAT(13,I) = MAX ( 0 , ODAT(13,I) ) + ODAT(18,I) = MAX ( 0 , ODAT(18,I) ) + ODAT(23,I) = MAX ( 0 , ODAT(23,I) ) + ODAT(28,I) = MAX ( 0 , ODAT(28,I) ) + ODAT(38,I) = MAX ( 0 , ODAT(38,I) ) - ! define the time of the output point grid (index 0) as the & - ! time of the first grid which should be the larger one by convention - ODAT(6:10,0) = ODAT(6:10,1) + ! define the time of the output point grid (index 0) as the & + ! time of the first grid which should be the larger one by convention + ODAT(6:10,0) = ODAT(6:10,1) - ! allocate pointers to minimum value if no output point - IF ( ODAT(8,I) .EQ. 0 ) THEN - ALLOCATE ( OT2(I)%X(1), OT2(I)%Y(1), OT2(I)%PNAMES(1) ) - END IF + ! allocate pointers to minimum value if no output point + IF ( ODAT(8,I) .EQ. 0 ) THEN + ALLOCATE ( OT2(I)%X(1), OT2(I)%Y(1), OT2(I)%PNAMES(1) ) + END IF - DO J=1, NOTYPE -! -! 5.b Process standard line -! - OUTPTS(I)%OFILES(J)=OUTFF(J,I) - IF ( ODAT(5*(J-1)+3,I) .NE. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,951) J, IDOTYP(J) - TTIME(1) = ODAT(5*(J-1)+1,I) - TTIME(2) = ODAT(5*(J-1)+2,I) - CALL STME21 ( TTIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,952) DTME21 - TTIME(1) = ODAT(5*(J-1)+4,I) - TTIME(2) = ODAT(5*(J-1)+5,I) - CALL STME21 ( TTIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,953) DTME21 - TTIME(1) = 0 - TTIME(2) = 0 - DTTST = REAL ( ODAT(5*(J-1)+3,I) ) - CALL TICK21 ( TTIME , DTTST ) - CALL STME21 ( TTIME , DTME21 ) - IF ( ( ODAT(5*(J-1)+1,I) .NE. ODAT(5*(J-1)+4,I) .OR. & - ODAT(5*(J-1)+2,I) .NE. ODAT(5*(J-1)+5,I) ) .AND. & - MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - DO II=1, 18 - IF ( DTME21(II:II).NE.'0' .AND. & - DTME21(II:II).NE.'/' .AND. & - DTME21(II:II).NE.' ' .AND. & - DTME21(II:II).NE.':' ) EXIT - DTME21(II:II) = ' ' - END DO - WRITE (MDSS,954) DTME21(1:19) - END IF -! - IF ( J .EQ. 1 ) THEN -! -! 5.c Type 1: fields of mean wave parameters -! - FLGRD(:,:,I)=.FALSE. ! Initialize FLGRD - FLDOUT = NML_OUTPUT_TYPE(I)%FIELD%LIST - CALL W3FLGRDFLAG ( MDSS, MDSO, MDSE2, FLDOUT, FLG1D, & - FLG2D, IMPROC, NMPSCR, IERR ) - FLGRD(:,:,I)=FLG2D - FLGD(:,I) =FLG1D -! - ELSE IF ( J .EQ. 2 ) THEN -! -! 5.d Type 2: point output -! - ! if the output is 0, the output is disabled - IF (UNIPTS) THEN - IF ( ODAT(8,0).EQ.0 .AND. IMPROC.EQ.NMPERR ) WRITE (MDSE,1050) - IF ( ODAT(8,0).EQ.0 ) UNIPTS = .FALSE. - END IF + DO J=1, NOTYPE + ! + ! 5.b Process standard line + ! + OUTPTS(I)%OFILES(J)=OUTFF(J,I) + IF ( ODAT(5*(J-1)+3,I) .NE. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,951) J, IDOTYP(J) + TTIME(1) = ODAT(5*(J-1)+1,I) + TTIME(2) = ODAT(5*(J-1)+2,I) + CALL STME21 ( TTIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,952) DTME21 + TTIME(1) = ODAT(5*(J-1)+4,I) + TTIME(2) = ODAT(5*(J-1)+5,I) + CALL STME21 ( TTIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,953) DTME21 + TTIME(1) = 0 + TTIME(2) = 0 + DTTST = REAL ( ODAT(5*(J-1)+3,I) ) + CALL TICK21 ( TTIME , DTTST ) + CALL STME21 ( TTIME , DTME21 ) + IF ( ( ODAT(5*(J-1)+1,I) .NE. ODAT(5*(J-1)+4,I) .OR. & + ODAT(5*(J-1)+2,I) .NE. ODAT(5*(J-1)+5,I) ) .AND. & + MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + DO II=1, 18 + IF ( DTME21(II:II).NE.'0' .AND. & + DTME21(II:II).NE.'/' .AND. & + DTME21(II:II).NE.' ' .AND. & + DTME21(II:II).NE.':' ) EXIT + DTME21(II:II) = ' ' + END DO + WRITE (MDSS,954) DTME21(1:19) + END IF + ! + IF ( J .EQ. 1 ) THEN + ! + ! 5.c Type 1: fields of mean wave parameters + ! + FLGRD(:,:,I)=.FALSE. ! Initialize FLGRD + FLDOUT = NML_OUTPUT_TYPE(I)%FIELD%LIST + CALL W3FLGRDFLAG ( MDSS, MDSO, MDSE2, FLDOUT, FLG1D, & + FLG2D, IMPROC, NMPSCR, IERR ) + FLGRD(:,:,I)=FLG2D + FLGD(:,I) =FLG1D + ! + ELSE IF ( J .EQ. 2 ) THEN + ! + ! 5.d Type 2: point output + ! + ! if the output is 0, the output is disabled + IF (UNIPTS) THEN + IF ( ODAT(8,0).EQ.0 .AND. IMPROC.EQ.NMPERR ) WRITE (MDSE,1050) + IF ( ODAT(8,0).EQ.0 ) UNIPTS = .FALSE. + END IF - ! if the point file is not set - IF ( TRIM(NML_OUTPUT_TYPE(I)%POINT%FILE).EQ.'unset' ) THEN - ! and if output also disabled, cycle to the next output type J - IF ( ODAT(8,I).EQ.0 ) THEN - ALLOCATE ( OT2(I)%X(1), OT2(I)%Y(1), OT2(I)%PNAMES(1) ) - CYCLE - ! and if output still enabled, stop - ELSE - GOTO 2055 - END IF - END IF + ! if the point file is not set + IF ( TRIM(NML_OUTPUT_TYPE(I)%POINT%FILE).EQ.'unset' ) THEN + ! and if output also disabled, cycle to the next output type J + IF ( ODAT(8,I).EQ.0 ) THEN + ALLOCATE ( OT2(I)%X(1), OT2(I)%Y(1), OT2(I)%PNAMES(1) ) + CYCLE + ! and if output still enabled, stop + ELSE + GOTO 2055 + END IF + END IF - ! if the unified point is already defined, cycle to the next output type J - IF ( UNIPTS .AND. ILOOP.NE.0 ) CYCLE -! - IF ( UNIPTS .AND. I.GE.2 ) THEN - DO K=1,I-1 - IF ( NML_OUTPUT_TYPE(K)%POINT%FILE.NE.NML_OUTPUT_TYPE(I)%POINT%FILE ) GOTO 2053 - END DO - END IF - OPEN (MDSI, file=TRIM(FNMPRE)//TRIM(NML_OUTPUT_TYPE(I)%POINT%FILE), & - FORM='FORMATTED', STATUS='OLD', ERR=2104, IOSTAT=IERR) + ! if the unified point is already defined, cycle to the next output type J + IF ( UNIPTS .AND. ILOOP.NE.0 ) CYCLE + ! + IF ( UNIPTS .AND. I.GE.2 ) THEN + DO K=1,I-1 + IF ( NML_OUTPUT_TYPE(K)%POINT%FILE.NE.NML_OUTPUT_TYPE(I)%POINT%FILE ) GOTO 2053 + END DO + END IF + OPEN (MDSI, file=TRIM(FNMPRE)//TRIM(NML_OUTPUT_TYPE(I)%POINT%FILE), & + FORM='FORMATTED', STATUS='OLD', ERR=2104, IOSTAT=IERR) - ! first loop to count the number of points - ! second loop to allocate the array and store the points - OT2(I)%NPTS = 0 - DO ILOOP=1,2 - REWIND (MDSI) -! - IF ( ILOOP.EQ.2) THEN - IF ( OT2(I)%NPTS.GT.0 ) THEN - ALLOCATE ( OT2(I)%X(OT2(I)%NPTS), & - OT2(I)%Y(OT2(I)%NPTS), & - OT2(I)%PNAMES(OT2(I)%NPTS) ) - OT2(I)%NPTS = 0 ! reset it to use it as a counter for loop 2 + ! first loop to count the number of points + ! second loop to allocate the array and store the points + OT2(I)%NPTS = 0 + DO ILOOP=1,2 + REWIND (MDSI) + ! + IF ( ILOOP.EQ.2) THEN + IF ( OT2(I)%NPTS.GT.0 ) THEN + ALLOCATE ( OT2(I)%X(OT2(I)%NPTS), & + OT2(I)%Y(OT2(I)%NPTS), & + OT2(I)%PNAMES(OT2(I)%NPTS) ) + OT2(I)%NPTS = 0 ! reset it to use it as a counter for loop 2 + ELSE + ALLOCATE ( OT2(I)%X(1), OT2(I)%Y(1), OT2(I)%PNAMES(1) ) + GOTO 2054 + END IF + END IF + ! + DO + READ (MDSI,*,ERR=2004,IOSTAT=IERR) TMPLINE + ! if end of file or stopstring, then exit + IF ( IERR.NE.0 .OR. INDEX(TMPLINE,"STOPSTRING").NE.0 ) EXIT + ! leading blanks removed and placed on the right + TEST = ADJUSTL ( TMPLINE ) + IF ( TEST(1:1).EQ.COMSTR .OR. LEN_TRIM(TEST).EQ.0 ) THEN + ! if comment or blank line, then skip + CYCLE + ELSE + ! otherwise, backup to beginning of line + BACKSPACE ( MDSI, ERR=2004, IOSTAT=IERR) + READ (MDSI,*,ERR=2004,IOSTAT=IERR) XX, YY, PN + ENDIF + OT2(I)%NPTS = OT2(I)%NPTS + 1 + IF ( ILOOP .EQ. 1 ) CYCLE + IF ( ILOOP .EQ. 2 ) THEN + OT2(I)%X(OT2(I)%NPTS) = XX + OT2(I)%Y(OT2(I)%NPTS) = YY + OT2(I)%PNAMES(OT2(I)%NPTS) = PN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + IF ( OT2(I)%NPTS .EQ. 1 ) THEN + WRITE (MDSS,957) XX, YY, PN ELSE - ALLOCATE ( OT2(I)%X(1), OT2(I)%Y(1), OT2(I)%PNAMES(1) ) - GOTO 2054 + WRITE (MDSS,958) OT2(I)%NPTS, XX, YY, PN END IF END IF -! - DO - READ (MDSI,*,ERR=2004,IOSTAT=IERR) TMPLINE - ! if end of file or stopstring, then exit - IF ( IERR.NE.0 .OR. INDEX(TMPLINE,"STOPSTRING").NE.0 ) EXIT - ! leading blanks removed and placed on the right - TEST = ADJUSTL ( TMPLINE ) - IF ( TEST(1:1).EQ.COMSTR .OR. LEN_TRIM(TEST).EQ.0 ) THEN - ! if comment or blank line, then skip - CYCLE - ELSE - ! otherwise, backup to beginning of line - BACKSPACE ( MDSI, ERR=2004, IOSTAT=IERR) - READ (MDSI,*,ERR=2004,IOSTAT=IERR) XX, YY, PN - ENDIF - OT2(I)%NPTS = OT2(I)%NPTS + 1 - IF ( ILOOP .EQ. 1 ) CYCLE - IF ( ILOOP .EQ. 2 ) THEN - OT2(I)%X(OT2(I)%NPTS) = XX - OT2(I)%Y(OT2(I)%NPTS) = YY - OT2(I)%PNAMES(OT2(I)%NPTS) = PN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - IF ( OT2(I)%NPTS .EQ. 1 ) THEN - WRITE (MDSS,957) XX, YY, PN - ELSE - WRITE (MDSS,958) OT2(I)%NPTS, XX, YY, PN - END IF - END IF - END IF ! ILOOP.EQ.2 - END DO ! end of file - END DO ! ILOOP - CLOSE(MDSI) -! - IF ( UNIPTS .AND. OT2(0)%NPTS.EQ.0 .AND. OT2(I)%NPTS.GT.0 ) THEN - ! copy points to point grid number 0 - OT2(0)%NPTS = OT2(I)%NPTS - ALLOCATE (OT2(0)%X(OT2(0)%NPTS), OT2(0)%Y(OT2(0)%NPTS), OT2(0)%PNAMES(OT2(0)%NPTS)) - OT2(0)%X(:) = OT2(I)%X(:) - OT2(0)%Y(:) = OT2(I)%Y(:) - OT2(0)%PNAMES(:) = OT2(I)%PNAMES(:) - ! define all the other grids to empty output point - DO K=1, NRGRD - OT2(K)%NPTS = 0 - ALLOCATE (OT2(K)%X(1),OT2(K)%Y(1),OT2(K)%PNAMES(1)) - END DO - END IF -! - ELSE IF ( J .EQ. 3 ) THEN -! -! 5.e Type 3: track output -! - TFLAGI = NML_OUTPUT_TYPE(I)%TRACK%FORMAT - IF ( TFLAGI ) THEN - MDS(11,I) = ABS(MDS(11,I)) - ELSE - MDS(11,I) = -ABS(MDS(11,I)) - END IF - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - IF ( .NOT. TFLAGI ) THEN - WRITE (MDSS,960) 'input', 'UNFORMATTED' - ELSE - WRITE (MDSS,960) 'input', 'FORMATTED' - END IF - END IF -! - ELSE IF ( J .EQ. 4 ) THEN -! -! 5.f Type 4: restart files (no additional data) -! - ELSE IF ( J .EQ. 5 ) THEN -! -! 5.g Type 5: nesting data (no additional data) -! - ELSE IF ( J .EQ. 6 ) THEN -! -! 5.h Type 6: partitioned wave field data -! - IPRT(1,I) = NML_OUTPUT_TYPE(I)%PARTITION%X0 - IPRT(2,I) = NML_OUTPUT_TYPE(I)%PARTITION%XN - IPRT(3,I) = NML_OUTPUT_TYPE(I)%PARTITION%NX - IPRT(4,I) = NML_OUTPUT_TYPE(I)%PARTITION%Y0 - IPRT(5,I) = NML_OUTPUT_TYPE(I)%PARTITION%YN - IPRT(6,I) = NML_OUTPUT_TYPE(I)%PARTITION%NY - LPRT(I) = NML_OUTPUT_TYPE(I)%PARTITION%FORMAT - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,961) IPRT(:,I) - IF ( .NOT. LPRT(I) ) THEN - WRITE (MDSS,960) 'output', 'UNFORMATTED' - ELSE - WRITE (MDSS,960) 'output', 'FORMATTED' - END IF - END IF -! -! ... End of output type selecttion ELSE IF -! + END IF ! ILOOP.EQ.2 + END DO ! end of file + END DO ! ILOOP + CLOSE(MDSI) + ! + IF ( UNIPTS .AND. OT2(0)%NPTS.EQ.0 .AND. OT2(I)%NPTS.GT.0 ) THEN + ! copy points to point grid number 0 + OT2(0)%NPTS = OT2(I)%NPTS + ALLOCATE (OT2(0)%X(OT2(0)%NPTS), OT2(0)%Y(OT2(0)%NPTS), OT2(0)%PNAMES(OT2(0)%NPTS)) + OT2(0)%X(:) = OT2(I)%X(:) + OT2(0)%Y(:) = OT2(I)%Y(:) + OT2(0)%PNAMES(:) = OT2(I)%PNAMES(:) + ! define all the other grids to empty output point + DO K=1, NRGRD + OT2(K)%NPTS = 0 + ALLOCATE (OT2(K)%X(1),OT2(K)%Y(1),OT2(K)%PNAMES(1)) + END DO + END IF + ! + ELSE IF ( J .EQ. 3 ) THEN + ! + ! 5.e Type 3: track output + ! + TFLAGI = NML_OUTPUT_TYPE(I)%TRACK%FORMAT + IF ( TFLAGI ) THEN + MDS(11,I) = ABS(MDS(11,I)) + ELSE + MDS(11,I) = -ABS(MDS(11,I)) + END IF + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + IF ( .NOT. TFLAGI ) THEN + WRITE (MDSS,960) 'input', 'UNFORMATTED' + ELSE + WRITE (MDSS,960) 'input', 'FORMATTED' END IF -! -! ... End of IF in 5.b -! - END IF -! -! ... End of loop J on NOTYPE in 5.a -! - END DO -!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -! Checkpoint - J=8 - !OUTPTS(I)%FLOUT(8)=.FALSE. - IF ( ODAT(5*(J-1)+3,I) .NE. 0 ) THEN - !OUTPTS(I)%FLOUT(8)=.TRUE. - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,951) J, IDOTYP(J) - TTIME(1) = ODAT(5*(J-1)+1,I) - TTIME(2) = ODAT(5*(J-1)+2,I) - CALL STME21 ( TTIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,952) DTME21 - TTIME(1) = ODAT(5*(J-1)+4,I) - TTIME(2) = ODAT(5*(J-1)+5,I) - CALL STME21 ( TTIME , DTME21 ) - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,953) DTME21 - TTIME(1) = 0 - TTIME(2) = 0 - DTTST = REAL ( ODAT(5*(J-1)+3,I) ) - CALL TICK21 ( TTIME , DTTST ) - CALL STME21 ( TTIME , DTME21 ) - IF ( ( ODAT(5*(J-1)+1,I) .NE. ODAT(5*(J-1)+4,I) .OR. & - ODAT(5*(J-1)+2,I) .NE. ODAT(5*(J-1)+5,I) ) .AND. & - MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - DO II=1, 18 - IF ( DTME21(II:II).NE.'0' .AND. & - DTME21(II:II).NE.'/' .AND. & - DTME21(II:II).NE.' ' .AND. & - DTME21(II:II).NE.':' ) EXIT - DTME21(II:II) = ' ' - END DO - WRITE (MDSS,954) DTME21(1:19) - END IF - !ELSE - !OUTPTS(I)%FLOUT(8) = .FALSE. + END IF + ! + ELSE IF ( J .EQ. 4 ) THEN + ! + ! 5.f Type 4: restart files (no additional data) + ! + ELSE IF ( J .EQ. 5 ) THEN + ! + ! 5.g Type 5: nesting data (no additional data) + ! + ELSE IF ( J .EQ. 6 ) THEN + ! + ! 5.h Type 6: partitioned wave field data + ! + IPRT(1,I) = NML_OUTPUT_TYPE(I)%PARTITION%X0 + IPRT(2,I) = NML_OUTPUT_TYPE(I)%PARTITION%XN + IPRT(3,I) = NML_OUTPUT_TYPE(I)%PARTITION%NX + IPRT(4,I) = NML_OUTPUT_TYPE(I)%PARTITION%Y0 + IPRT(5,I) = NML_OUTPUT_TYPE(I)%PARTITION%YN + IPRT(6,I) = NML_OUTPUT_TYPE(I)%PARTITION%NY + LPRT(I) = NML_OUTPUT_TYPE(I)%PARTITION%FORMAT + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,961) IPRT(:,I) + IF ( .NOT. LPRT(I) ) THEN + WRITE (MDSS,960) 'output', 'UNFORMATTED' + ELSE + WRITE (MDSS,960) 'output', 'FORMATTED' + END IF + END IF + ! + ! ... End of output type selecttion ELSE IF + ! END IF -!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -! -! ... End of loop I on NRGRD in 5.a -! + ! + ! ... End of IF in 5.b + ! + END IF + ! + ! ... End of loop J on NOTYPE in 5.a + ! END DO -! + !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + ! Checkpoint + J=8 + !OUTPTS(I)%FLOUT(8)=.FALSE. + IF ( ODAT(5*(J-1)+3,I) .NE. 0 ) THEN + !OUTPTS(I)%FLOUT(8)=.TRUE. + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,951) J, IDOTYP(J) + TTIME(1) = ODAT(5*(J-1)+1,I) + TTIME(2) = ODAT(5*(J-1)+2,I) + CALL STME21 ( TTIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,952) DTME21 + TTIME(1) = ODAT(5*(J-1)+4,I) + TTIME(2) = ODAT(5*(J-1)+5,I) + CALL STME21 ( TTIME , DTME21 ) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,953) DTME21 + TTIME(1) = 0 + TTIME(2) = 0 + DTTST = REAL ( ODAT(5*(J-1)+3,I) ) + CALL TICK21 ( TTIME , DTTST ) + CALL STME21 ( TTIME , DTME21 ) + IF ( ( ODAT(5*(J-1)+1,I) .NE. ODAT(5*(J-1)+4,I) .OR. & + ODAT(5*(J-1)+2,I) .NE. ODAT(5*(J-1)+5,I) ) .AND. & + MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + DO II=1, 18 + IF ( DTME21(II:II).NE.'0' .AND. & + DTME21(II:II).NE.'/' .AND. & + DTME21(II:II).NE.' ' .AND. & + DTME21(II:II).NE.':' ) EXIT + DTME21(II:II) = ' ' + END DO + WRITE (MDSS,954) DTME21(1:19) + END IF + !ELSE + !OUTPTS(I)%FLOUT(8) = .FALSE. + END IF + !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + ! + ! ... End of loop I on NRGRD in 5.a + ! + END DO + ! #ifdef W3_T - DO I=1, NRGRD - WRITE (MDST,9050) I - WRITE (MDST,9053) ODAT(:,I) - WRITE (MDST,9052) FLGRD(:,:,I) - END DO -#endif -! -! 6. Read moving grid data ------------------------------------------ / -! -! Only a single set of data are provided to be applied to all -! the grids, because this is only intended for test cases. -! For true implementations, the jumping grid will be used. -! - IF ( INFLAGS1(10) ) THEN -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,965) - WRITE (MDSS,966) 'Continuous grid movement data' - END IF -! - N_MOV = NML_HOMOG_COUNT%N_MOV - N_TOT = NML_HOMOG_COUNT%N_TOT + DO I=1, NRGRD + WRITE (MDST,9050) I + WRITE (MDST,9053) ODAT(:,I) + WRITE (MDST,9052) FLGRD(:,:,I) + END DO +#endif + ! + ! 6. Read moving grid data ------------------------------------------ / + ! + ! Only a single set of data are provided to be applied to all + ! the grids, because this is only intended for test cases. + ! For true implementations, the jumping grid will be used. + ! + IF ( INFLAGS1(10) ) THEN + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,965) + WRITE (MDSS,966) 'Continuous grid movement data' + END IF + ! + N_MOV = NML_HOMOG_COUNT%N_MOV + N_TOT = NML_HOMOG_COUNT%N_TOT - IF ( N_MOV .EQ. 0 ) GOTO 2060 - IF ( N_MOV .GT. 99 ) GOTO 2061 + IF ( N_MOV .EQ. 0 ) GOTO 2060 + IF ( N_MOV .GT. 99 ) GOTO 2061 - ALLOCATE ( TMOVE(2,N_MOV), AMOVE(N_MOV), DMOVE(N_MOV) ) -! - DO I=1,N_TOT - READ(NML_HOMOG_INPUT(I)%NAME,*) IDTST - SELECT CASE (IDTST) - CASE ('MOV') - READ(NML_HOMOG_INPUT(I)%DATE,*) TMOVE(:,I) - AMOVE(I) = NML_HOMOG_INPUT(I)%VALUE1 - DMOVE(I) = NML_HOMOG_INPUT(I)%VALUE2 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,968) I, TMOVE(:,I), AMOVE(I), DMOVE(I) - CASE DEFAULT - GOTO 2062 - END SELECT - END DO -! - NMVMAX = N_MOV - DO I=1, NRGRD - CALL W3SETG ( I, MDSE, MDST ) - CALL WMSETM ( I, MDSE, MDST ) - NMV = N_MOV - CALL WMDIMD ( I, MDSE, MDST, 0 ) - DO II=1, NMV - TMV(:,4,II) = TMOVE(:,II) - AMV(II,4) = AMOVE(II) - DMV(II,4) = DMOVE(II) - END DO - END DO -! - END IF -! -! 7. Work load distribution ----------------------------------------- / -! 7.a Initialize arrays -! -! ******************************************************* -! *** NOTE : OUTPUT PROCESSOR ASSIGNMENT NEEDS TO BE *** -! *** CONSISTENT WITH ASSIGNMENT IN W3INIT. *** -! ******************************************************* -! - ALLOCATE ( ALLPRC(NMPROC,NRGRD) , MODMAP(NMPROC,NRGRP) , & - LOADMP(NMPROC,NRGRP) ) -! - ALLPRC = 0 - MODMAP = 0 - LOADMP = 0 -! -! 7.b Determine number of output processors -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,970) -! - NCPROC = NMPROC - UPPROC = UPPROC .AND. UNIPTS .AND. IOSTYP.GT.1 -! -! 7.b.1 Unified point output -! - IF ( UNIPTS ) THEN - IF ( NMPROC.GE.10 .AND. UPPROC ) THEN - NCPROC = NMPROC - 1 - ELSE - IF ( UPPROC .AND. MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,971) 'Separate process for point' // & - ' output disabled.' - UPPROC = .FALSE. - END IF - IF ( NMPUPT .EQ. IMPROC ) THEN - II = LEN_TRIM(MNAMES(0)) - CALL WMUGET ( MDSS, MDST, MDSUP, 'OUT' ) - CALL WMUSET ( MDSS, MDST, MDSUP, .TRUE., 'OUT', & - TRIM(FNMPRE)//'out_pnt.'//MNAMES(0)(1:II), & - 'Unified point output') - END IF - END IF -! - IF ( UPPROC .AND. MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,972) NMPUPT -! -! 7.b.2 Other output -! - ALLOCATE ( NDPOUT(NRGRD) ) + ALLOCATE ( TMOVE(2,N_MOV), AMOVE(N_MOV), DMOVE(N_MOV) ) + ! + DO I=1,N_TOT + READ(NML_HOMOG_INPUT(I)%NAME,*) IDTST + SELECT CASE (IDTST) + CASE ('MOV') + READ(NML_HOMOG_INPUT(I)%DATE,*) TMOVE(:,I) + AMOVE(I) = NML_HOMOG_INPUT(I)%VALUE1 + DMOVE(I) = NML_HOMOG_INPUT(I)%VALUE2 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,968) I, TMOVE(:,I), AMOVE(I), DMOVE(I) + CASE DEFAULT + GOTO 2062 + END SELECT + END DO + ! + NMVMAX = N_MOV + DO I=1, NRGRD + CALL W3SETG ( I, MDSE, MDST ) + CALL WMSETM ( I, MDSE, MDST ) + NMV = N_MOV + CALL WMDIMD ( I, MDSE, MDST, 0 ) + DO II=1, NMV + TMV(:,4,II) = TMOVE(:,II) + AMV(II,4) = AMOVE(II) + DMV(II,4) = DMOVE(II) + END DO + END DO + ! + END IF + ! + ! 7. Work load distribution ----------------------------------------- / + ! 7.a Initialize arrays + ! + ! ******************************************************* + ! *** NOTE : OUTPUT PROCESSOR ASSIGNMENT NEEDS TO BE *** + ! *** CONSISTENT WITH ASSIGNMENT IN W3INIT. *** + ! ******************************************************* + ! + ALLOCATE ( ALLPRC(NMPROC,NRGRD) , MODMAP(NMPROC,NRGRP) , & + LOADMP(NMPROC,NRGRP) ) + ! + ALLPRC = 0 + MODMAP = 0 + LOADMP = 0 + ! + ! 7.b Determine number of output processors + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,970) + ! + NCPROC = NMPROC + UPPROC = UPPROC .AND. UNIPTS .AND. IOSTYP.GT.1 + ! + ! 7.b.1 Unified point output + ! + IF ( UNIPTS ) THEN + IF ( NMPROC.GE.10 .AND. UPPROC ) THEN + NCPROC = NMPROC - 1 + ELSE + IF ( UPPROC .AND. MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,971) 'Separate process for point' // & + ' output disabled.' + UPPROC = .FALSE. + END IF + IF ( NMPUPT .EQ. IMPROC ) THEN + II = LEN_TRIM(MNAMES(0)) + CALL WMUGET ( MDSS, MDST, MDSUP, 'OUT' ) + CALL WMUSET ( MDSS, MDST, MDSUP, .TRUE., 'OUT', & + TRIM(FNMPRE)//'out_pnt.'//MNAMES(0)(1:II), & + 'Unified point output') + END IF + END IF + ! + IF ( UPPROC .AND. MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,972) NMPUPT + ! + ! 7.b.2 Other output + ! + ALLOCATE ( NDPOUT(NRGRD) ) + NDPOUT = 0 + ! + IF ( IOSTYP .GT. 1 ) THEN + DO I=1, NRGRD + IF ( ODAT( 3,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 + IF ( ODAT(13,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 + IF ( ODAT(28,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 + !xxx + ! Checkpoint + IF ( ODAT(38,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 + !xxx + IF ( ODAT( 8,I) .GT. 0 .OR. ODAT(18,I) .GT. 0 .OR. & + ODAT(23,I) .GT. 0 ) & + NDPOUT(I) = NDPOUT(I) + 1 + IF ( IOSTYP .EQ. 2 ) NDPOUT(I) = MIN ( 1 , NDPOUT(I) ) + END DO + END IF + ! + ! ..... Reduce IOSTYP if not enough resources to run IOSTYP = 3 + ! + IF ( IOSTYP.EQ.3 .AND. & + ( ( .NOT.PSHARE .AND. 4*SUM(NDPOUT).GT.NCPROC ) & + .OR.( PSHARE .AND. 4*MAXVAL(NDPOUT).GT.NCPROC ) ) ) THEN + DO I=1, NRGRD + NDPOUT(I) = MIN ( 1 , NDPOUT(I) ) + END DO + IOSTYP = 2 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,971) 'Separate processes for output' // & + ' types disabled.' + END IF + ! + ! ..... Force sharing of output processes if not enough resources + ! + IF ( IOSTYP.GT.1 .AND. .NOT.PSHARE .AND. & + 4*SUM(NDPOUT).GT.NCPROC ) THEN + PSHARE = .TRUE. + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,971) 'Grids sharing output processes.' + END IF + ! + ! ..... Disable output processes if not enough resources + ! + IF ( IOSTYP.GT.1 .AND. 4*MAXVAL(NDPOUT).GT.NCPROC ) THEN NDPOUT = 0 -! + IOSTYP = 1 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,971) 'Separate processes for output' // & + ' disabled.' + END IF + ! + ! ..... Number of output processes (except for unified point output) + ! + NPOUTT = 0 + IF ( IOSTYP .GT. 1 ) THEN + IF ( PSHARE ) THEN + NPOUTT = MAXVAL(NDPOUT) + ELSE + NPOUTT = SUM(NDPOUT) + END IF + END IF + NCPROC = NCPROC - NPOUTT + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + IF ( NPOUTT .EQ. 0 ) THEN + WRITE (MDSS,971) 'No (other) dedicated output processes.' + ELSE + WRITE (MDSS,973) NCPROC+1, NCPROC+NPOUTT, NPOUTT + END IF + END IF + ! + ! 7.c Set communicators and ALLPRC array + ! +#ifdef W3_T + WRITE (MDST,9070) +#endif + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,974) + IF ( NMPLOG.EQ.IMPROC ) WRITE (MDSO,1974) + ! +#ifdef W3_MPI + CALL MPI_COMM_GROUP ( MPI_COMM_MWAVE, BGROUP, IERR_MPI ) +#endif + ALLOCATE ( TMPRNK(NMPROC) ) + NAPRES = NCPROC + ! + DO I=1, NRGRD + ! + IP1 = MAX( 1 , MIN ( NCPROC , 1+NINT(REAL(NCPROC)*RP1(I)) ) ) + IPN = MAX( IP1 , MIN ( NCPROC , NINT(REAL(NCPROC)*RPN(I)) ) ) + OUTSTR = '-----' + ! + CALL WMSETM ( I, MDSE, MDST ) + NAPLOC = 1 + IPN - IP1 + NAPADD = NAPLOC +#ifdef W3_MPI + CROOT = IP1 + FBCAST = NAPLOC .NE. NCPROC + FBCAST = NAPLOC .NE. NCPROC .OR. & + ( IOSTYP.GT.1 .AND. .NOT.PSHARE ) +#endif + DO J=IP1, IPN + TMPRNK(1+J-IP1) = J - 1 + END DO + ! IF ( IOSTYP .GT. 1 ) THEN - DO I=1, NRGRD - IF ( ODAT( 3,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 - IF ( ODAT(13,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 - IF ( ODAT(28,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 -!xxx -! Checkpoint - IF ( ODAT(38,I) .GT. 0 ) NDPOUT(I) = NDPOUT(I) + 1 -!xxx - IF ( ODAT( 8,I) .GT. 0 .OR. ODAT(18,I) .GT. 0 .OR. & - ODAT(23,I) .GT. 0 ) & - NDPOUT(I) = NDPOUT(I) + 1 - IF ( IOSTYP .EQ. 2 ) NDPOUT(I) = MIN ( 1 , NDPOUT(I) ) - END DO - END IF -! -! ..... Reduce IOSTYP if not enough resources to run IOSTYP = 3 -! - IF ( IOSTYP.EQ.3 .AND. & - ( ( .NOT.PSHARE .AND. 4*SUM(NDPOUT).GT.NCPROC ) & - .OR.( PSHARE .AND. 4*MAXVAL(NDPOUT).GT.NCPROC ) ) ) THEN - DO I=1, NRGRD - NDPOUT(I) = MIN ( 1 , NDPOUT(I) ) - END DO - IOSTYP = 2 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,971) 'Separate processes for output' // & - ' types disabled.' + IF ( PSHARE ) NAPRES = NCPROC + DO J=1, NDPOUT(I) + NAPADD = NAPADD + 1 + TMPRNK(NAPADD) = NAPRES + NAPRES = NAPRES + 1 + END DO + END IF + ! + IF ( UPPROC ) THEN + NAPADD = NAPADD + 1 + TMPRNK(NAPADD) = NMPROC - 1 + END IF + ! +#ifdef W3_MPI + CALL MPI_GROUP_INCL ( BGROUP, NAPADD, TMPRNK, LGROUP, & + IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & + MPI_COMM_GRD, IERR_MPI ) + CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) +#endif + ! + DO II=IP1, IPN + ALLPRC(II,I) = 1 + II - IP1 + END DO + II = II - IP1 + ! + IF ( PSHARE .OR. I.EQ.1 ) THEN + NAPADD = NCPROC + ELSE + NAPADD = NCPROC + SUM(NDPOUT(1:I-1)) + END IF + IF ( IOSTYP .GT. 1 ) THEN + DO J=1, NDPOUT(I) + NAPADD = NAPADD + 1 + II = II + 1 + ALLPRC(NAPADD,I) = II + END DO + END IF + ! + IF ( UPPROC ) THEN + II = II + 1 + ALLPRC(NMPROC,I) = II + END IF + ! +#ifdef W3_T + WRITE (MDST,9071) I, ALLPRC(:,I) +#endif + ! + ! ... output + ! + ! + IF ( IOSTYP .LE. 1 ) THEN + ! + IF ( ODAT( 3,I) .GT. 0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-1))+1 + OUTSTR(1) = STOUT END IF -! -! ..... Force sharing of output processes if not enough resources -! - IF ( IOSTYP.GT.1 .AND. .NOT.PSHARE .AND. & - 4*SUM(NDPOUT).GT.NCPROC ) THEN - PSHARE = .TRUE. - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,971) 'Grids sharing output processes.' + IF ( ODAT( 8,I) .GT. 0 .OR. UNIPTS ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-2))+1 + OUTSTR(2) = STOUT END IF -! -! ..... Disable output processes if not enough resources -! - IF ( IOSTYP.GT.1 .AND. 4*MAXVAL(NDPOUT).GT.NCPROC ) THEN - NDPOUT = 0 - IOSTYP = 1 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,971) 'Separate processes for output' // & - ' disabled.' + IF ( ODAT(13,I) .GT. 0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-5))+1 + OUTSTR(3) = STOUT END IF -! -! ..... Number of output processes (except for unified point output) -! - NPOUTT = 0 - IF ( IOSTYP .GT. 1 ) THEN - IF ( PSHARE ) THEN - NPOUTT = MAXVAL(NDPOUT) - ELSE - NPOUTT = SUM(NDPOUT) - END IF + IF ( ODAT(18,I) .GT. 0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(NAPLOC)+1 + OUTSTR(4) = STOUT END IF - NCPROC = NCPROC - NPOUTT - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - IF ( NPOUTT .EQ. 0 ) THEN - WRITE (MDSS,971) 'No (other) dedicated output processes.' - ELSE - WRITE (MDSS,973) NCPROC+1, NCPROC+NPOUTT, NPOUTT - END IF + IF ( ODAT(23,I) .GT. 0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-3))+1 + OUTSTR(5) = STOUT END IF -! -! 7.c Set communicators and ALLPRC array -! -#ifdef W3_T - WRITE (MDST,9070) -#endif - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,974) - IF ( NMPLOG.EQ.IMPROC ) WRITE (MDSO,1974) -! -#ifdef W3_MPI - CALL MPI_COMM_GROUP ( MPI_COMM_MWAVE, BGROUP, IERR_MPI ) -#endif - ALLOCATE ( TMPRNK(NMPROC) ) - NAPRES = NCPROC -! - DO I=1, NRGRD -! - IP1 = MAX( 1 , MIN ( NCPROC , 1+NINT(REAL(NCPROC)*RP1(I)) ) ) - IPN = MAX( IP1 , MIN ( NCPROC , NINT(REAL(NCPROC)*RPN(I)) ) ) - OUTSTR = '-----' -! - CALL WMSETM ( I, MDSE, MDST ) - NAPLOC = 1 + IPN - IP1 - NAPADD = NAPLOC -#ifdef W3_MPI - CROOT = IP1 - FBCAST = NAPLOC .NE. NCPROC - FBCAST = NAPLOC .NE. NCPROC .OR. & - ( IOSTYP.GT.1 .AND. .NOT.PSHARE ) -#endif - DO J=IP1, IPN - TMPRNK(1+J-IP1) = J - 1 - END DO -! - IF ( IOSTYP .GT. 1 ) THEN - IF ( PSHARE ) NAPRES = NCPROC - DO J=1, NDPOUT(I) - NAPADD = NAPADD + 1 - TMPRNK(NAPADD) = NAPRES - NAPRES = NAPRES + 1 - END DO + IF ( ODAT(28,I) .GT. 0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-4))+1 + OUTSTR(6) = STOUT + END IF + ! + ELSE + ! + ! set last proc for point and disable point for the grid + IF ( UNIPTS ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + OUTSTR(2) = STOUT + ODAT(8,I) = 0 + IF ( UPPROC ) II = II - 1 + END IF + ! + IF ( IOSTYP .EQ. 2 ) THEN + ! + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + IF ( ODAT( 3,I) .GT. 0 ) OUTSTR(1) = STOUT + IF ( ODAT( 8,I) .GT. 0 .OR. & + ( UNIPTS .AND. .NOT.UPPROC ) ) & + OUTSTR(2) = STOUT + IF ( ODAT(13,I) .GT. 0 ) OUTSTR(3) = STOUT + IF ( ODAT(18,I) .GT. 0 ) OUTSTR(4) = STOUT + IF ( ODAT(23,I) .GT. 0 ) OUTSTR(5) = STOUT + IF ( ODAT(28,I) .GT. 0 ) OUTSTR(6) = STOUT + ! + ELSE IF ( IOSTYP .EQ. 3 ) THEN + ! + IF ( ODAT( 3,I).GT.0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + OUTSTR(1) = STOUT + II = II - 1 END IF -! - IF ( UPPROC ) THEN - NAPADD = NAPADD + 1 - TMPRNK(NAPADD) = NMPROC - 1 + IF ( ODAT(13,I).GT.0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + OUTSTR(3) = STOUT + II = II - 1 END IF -! + IF ( ODAT(28,I).GT.0 ) THEN + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + OUTSTR(6) = STOUT + II = II - 1 + END IF + WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 + IF ( ODAT( 8,I) .GT. 0 ) OUTSTR(2) = STOUT + IF ( ODAT(18,I) .GT. 0 ) OUTSTR(4) = STOUT + IF ( ODAT(23,I) .GT. 0 ) OUTSTR(5) = STOUT + ! + END IF + ! + END IF + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,975) MNAMES(I), IP1, IPN, OUTSTR + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,1975)MNAMES(I), IP1, IPN, OUTSTR + ! #ifdef W3_MPI - CALL MPI_GROUP_INCL ( BGROUP, NAPADD, TMPRNK, LGROUP, & - IERR_MPI ) - CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & - MPI_COMM_GRD, IERR_MPI ) + IF ( FBCAST ) THEN + TMPRNK(1) = IP1 - 1 + NAPBCT = 1 + DO J=1, NMPROC + IF ( ALLPRC(J,I) .EQ. 0 ) THEN + NAPBCT = NAPBCT + 1 + TMPRNK(NAPBCT) = J - 1 + END IF + END DO + CALL MPI_GROUP_INCL ( BGROUP, NAPBCT, TMPRNK, & + LGROUP, IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & + MPI_COMM_BCT, IERR_MPI ) CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) + END IF #endif -! - DO II=IP1, IPN - ALLPRC(II,I) = 1 + II - IP1 - END DO - II = II - IP1 -! - IF ( PSHARE .OR. I.EQ.1 ) THEN - NAPADD = NCPROC - ELSE - NAPADD = NCPROC + SUM(NDPOUT(1:I-1)) - END IF - IF ( IOSTYP .GT. 1 ) THEN - DO J=1, NDPOUT(I) - NAPADD = NAPADD + 1 - II = II + 1 - ALLPRC(NAPADD,I) = II - END DO - END IF -! - IF ( UPPROC ) THEN - II = II + 1 - ALLPRC(NMPROC,I) = II - END IF -! -#ifdef W3_T - WRITE (MDST,9071) I, ALLPRC(:,I) -#endif -! -! ... output -! -! - IF ( IOSTYP .LE. 1 ) THEN -! - IF ( ODAT( 3,I) .GT. 0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-1))+1 - OUTSTR(1) = STOUT - END IF - IF ( ODAT( 8,I) .GT. 0 .OR. UNIPTS ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-2))+1 - OUTSTR(2) = STOUT - END IF - IF ( ODAT(13,I) .GT. 0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-5))+1 - OUTSTR(3) = STOUT - END IF - IF ( ODAT(18,I) .GT. 0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(NAPLOC)+1 - OUTSTR(4) = STOUT - END IF - IF ( ODAT(23,I) .GT. 0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-3))+1 - OUTSTR(5) = STOUT - END IF - IF ( ODAT(28,I) .GT. 0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(MAX(1,NAPLOC-4))+1 - OUTSTR(6) = STOUT - END IF -! - ELSE -! - ! set last proc for point and disable point for the grid - IF ( UNIPTS ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - OUTSTR(2) = STOUT - ODAT(8,I) = 0 - IF ( UPPROC ) II = II - 1 - END IF -! - IF ( IOSTYP .EQ. 2 ) THEN -! - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - IF ( ODAT( 3,I) .GT. 0 ) OUTSTR(1) = STOUT - IF ( ODAT( 8,I) .GT. 0 .OR. & - ( UNIPTS .AND. .NOT.UPPROC ) ) & - OUTSTR(2) = STOUT - IF ( ODAT(13,I) .GT. 0 ) OUTSTR(3) = STOUT - IF ( ODAT(18,I) .GT. 0 ) OUTSTR(4) = STOUT - IF ( ODAT(23,I) .GT. 0 ) OUTSTR(5) = STOUT - IF ( ODAT(28,I) .GT. 0 ) OUTSTR(6) = STOUT -! - ELSE IF ( IOSTYP .EQ. 3 ) THEN -! - IF ( ODAT( 3,I).GT.0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - OUTSTR(1) = STOUT - II = II - 1 - END IF - IF ( ODAT(13,I).GT.0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - OUTSTR(3) = STOUT - II = II - 1 - END IF - IF ( ODAT(28,I).GT.0 ) THEN - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - OUTSTR(6) = STOUT - II = II - 1 - END IF - WRITE (STOUT,'(I5.5)') TMPRNK(II) + 1 - IF ( ODAT( 8,I) .GT. 0 ) OUTSTR(2) = STOUT - IF ( ODAT(18,I) .GT. 0 ) OUTSTR(4) = STOUT - IF ( ODAT(23,I) .GT. 0 ) OUTSTR(5) = STOUT -! - END IF -! + ! + END DO + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + WRITE (MDSS,976) + IF ( UNIPTS ) WRITE (MDSS,977) NMPUPT + WRITE (MDSS,*) + END IF + ! + IF ( NMPLOG .EQ. IMPROC ) THEN + WRITE (MDSO,1976) + IF ( UNIPTS ) WRITE (MDSO,1977) NMPUPT + WRITE (MDSO,*) + END IF + ! + DEALLOCATE ( TMPRNK, NDPOUT ) + ! + ! 7.d Set MODMAP and LOADMP arrays + ! + DO JJ=1, NRGRP + DO II=1, INGRP(JJ,0) + I = INGRP(JJ,II) + DO J=1, NMPROC + IF ( ALLPRC(J,I) .NE. 0 ) THEN + LOADMP(J,JJ) = LOADMP(J,JJ) + 1 + IF ( LOADMP(J,JJ) .EQ. 1 ) THEN + MODMAP(J,JJ) = I + ELSE + MODMAP(J,JJ) = -1 + END IF END IF -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,975) MNAMES(I), IP1, IPN, OUTSTR - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,1975)MNAMES(I), IP1, IPN, OUTSTR -! -#ifdef W3_MPI - IF ( FBCAST ) THEN - TMPRNK(1) = IP1 - 1 - NAPBCT = 1 - DO J=1, NMPROC - IF ( ALLPRC(J,I) .EQ. 0 ) THEN - NAPBCT = NAPBCT + 1 - TMPRNK(NAPBCT) = J - 1 - END IF - END DO - CALL MPI_GROUP_INCL ( BGROUP, NAPBCT, TMPRNK, & - LGROUP, IERR_MPI ) - CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) - END IF -#endif -! - END DO -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - WRITE (MDSS,976) - IF ( UNIPTS ) WRITE (MDSS,977) NMPUPT - WRITE (MDSS,*) - END IF -! - IF ( NMPLOG .EQ. IMPROC ) THEN - WRITE (MDSO,1976) - IF ( UNIPTS ) WRITE (MDSO,1977) NMPUPT - WRITE (MDSO,*) - END IF -! - DEALLOCATE ( TMPRNK, NDPOUT ) -! -! 7.d Set MODMAP and LOADMP arrays -! - DO JJ=1, NRGRP - DO II=1, INGRP(JJ,0) - I = INGRP(JJ,II) - DO J=1, NMPROC - IF ( ALLPRC(J,I) .NE. 0 ) THEN - LOADMP(J,JJ) = LOADMP(J,JJ) + 1 - IF ( LOADMP(J,JJ) .EQ. 1 ) THEN - MODMAP(J,JJ) = I - ELSE - MODMAP(J,JJ) = -1 - END IF - END IF - END DO - END DO END DO -! + END DO + END DO + ! #ifdef W3_T - WRITE (MDST,8042) - DO J=1, NRGRP - WRITE (MDST,8044) J, MODMAP(:,J) - END DO - WRITE (MDST,8043) - DO J=1, NRGRP - WRITE (MDST,8044) J, LOADMP(:,J) - END DO -#endif -! -! 7.e Warnings -! - IF ( NMPROC .GT. 1 ) THEN - DO I=1, NRGRP - IP1 = MINVAL ( LOADMP(:NCPROC,I) ) - IPN = MAXVAL ( LOADMP(:NCPROC,I) ) - IF ( IP1.NE.IPN .AND. IMPROC.EQ.NMPERR ) & - WRITE (MDSE,1040) I, IP1, IPN - END DO - END IF -! - DEALLOCATE ( RP1, RPN, LOADMP ) -! -! 7.f Reset NMPSCR to first processor of first rank 1 grid -! + WRITE (MDST,8042) + DO J=1, NRGRP + WRITE (MDST,8044) J, MODMAP(:,J) + END DO + WRITE (MDST,8043) + DO J=1, NRGRP + WRITE (MDST,8044) J, LOADMP(:,J) + END DO +#endif + ! + ! 7.e Warnings + ! + IF ( NMPROC .GT. 1 ) THEN + DO I=1, NRGRP + IP1 = MINVAL ( LOADMP(:NCPROC,I) ) + IPN = MAXVAL ( LOADMP(:NCPROC,I) ) + IF ( IP1.NE.IPN .AND. IMPROC.EQ.NMPERR ) & + WRITE (MDSE,1040) I, IP1, IPN + END DO + END IF + ! + DEALLOCATE ( RP1, RPN, LOADMP ) + ! + ! 7.f Reset NMPSCR to first processor of first rank 1 grid + ! #ifdef W3_MPI - CALL WMSETM ( INGRP(1,1), MDSE, MDST ) - NMPSCR = CROOT + CALL WMSETM ( INGRP(1,1), MDSE, MDST ) + NMPSCR = CROOT #endif -! + ! #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) #endif -! -! 8. Actual initializations ----------------------------------------- / -! + ! + ! 8. Actual initializations ----------------------------------------- / + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8' - PRFT0 = PRFTN -#endif -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,980) - ALLOCATE ( TSYNC(2,0:NRGRD), TMAX(2,NRGRD), TOUTP(2,0:NRGRD), & - TDATA(2,NRGRD), GRSTAT(NRGRD), DTRES(NRGRD) ) -! - TSYNC(1,:) = -1 - TSYNC(2,:) = 0 - TMAX (1,:) = -1 - TMAX (2,:) = 0 - TOUTP(1,:) = -1 - TOUTP(2,:) = 0 - TDATA(1,:) = -1 - TDATA(2,:) = 0 - GRSTAT = 99 -! -! 8.a Loop over models for per-model initialization -! + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8' + PRFT0 = PRFTN +#endif + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,980) + ALLOCATE ( TSYNC(2,0:NRGRD), TMAX(2,NRGRD), TOUTP(2,0:NRGRD), & + TDATA(2,NRGRD), GRSTAT(NRGRD), DTRES(NRGRD) ) + ! + TSYNC(1,:) = -1 + TSYNC(2,:) = 0 + TMAX (1,:) = -1 + TMAX (2,:) = 0 + TOUTP(1,:) = -1 + TOUTP(2,:) = 0 + TDATA(1,:) = -1 + TDATA(2,:) = 0 + GRSTAT = 99 + ! + ! 8.a Loop over models for per-model initialization + ! #ifdef W3_T - WRITE (MDST,9080) + WRITE (MDST,9080) #endif #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.a' - PRFT0 = PRFTN -#endif -! - DO I=1, NRGRD - J = LEN_TRIM(MNAMES(I)) - DO NMPSC2=1, NMPROC - IF ( ALLPRC(NMPSC2,I) .EQ. 1 ) EXIT - END DO - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & - WRITE (MDSS,981) I, MNAMES(I)(1:J) -! + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.a' + PRFT0 = PRFTN +#endif + ! + DO I=1, NRGRD + J = LEN_TRIM(MNAMES(I)) + DO NMPSC2=1, NMPROC + IF ( ALLPRC(NMPSC2,I) .EQ. 1 ) EXIT + END DO + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & + WRITE (MDSS,981) I, MNAMES(I)(1:J) + ! #ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) #endif -! -! 8.a.1 Wave model initialization (NOTE: sets all grid pointers) -! ..... Initial output file hook up -! - CALL WMSETM ( I, MDSE, MDST ) + ! + ! 8.a.1 Wave model initialization (NOTE: sets all grid pointers) + ! ..... Initial output file hook up + ! + CALL WMSETM ( I, MDSE, MDST ) #ifdef W3_MPI - MPI_COMM_LOC = MPI_COMM_GRD - IF ( MPI_COMM_LOC .EQ. MPI_COMM_NULL ) CYCLE -#endif -! - CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) - CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., DESC='Log file' ) - MDS( 1,I) = NDSFND -! -! ... this one overwrites the combined setting MDS( 3,I) = MDST above -! -! CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) -! CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., DESC='Test output' ) -! MDS( 3,I) = NDSFND -! - DO J=1, 6 - IF ( J.EQ.4 .OR. J.EQ.5 ) CYCLE - IF ( ODAT(5*(J-1)+3,I) .GT. 0 ) THEN - CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) - CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & - DESC='Raw output file' ) - SELECT CASE (J) - CASE (1) - MDS(7,I) = NDSFND - CASE (2) - MDS(8,I) = NDSFND - CASE (3) - MDS(12,I) = NDSFND - CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) - CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & - DESC='Input data file' ) - MDS(11,I) = NDSFND - CASE (6) - MDS(13,I) = NDSFND - END SELECT - END IF + MPI_COMM_LOC = MPI_COMM_GRD + IF ( MPI_COMM_LOC .EQ. MPI_COMM_NULL ) CYCLE +#endif + ! + CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) + CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., DESC='Log file' ) + MDS( 1,I) = NDSFND + ! + ! ... this one overwrites the combined setting MDS( 3,I) = MDST above + ! + ! CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) + ! CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., DESC='Test output' ) + ! MDS( 3,I) = NDSFND + ! + DO J=1, 6 + IF ( J.EQ.4 .OR. J.EQ.5 ) CYCLE + IF ( ODAT(5*(J-1)+3,I) .GT. 0 ) THEN + CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) + CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & + DESC='Raw output file' ) + SELECT CASE (J) + CASE (1) + MDS(7,I) = NDSFND + CASE (2) + MDS(8,I) = NDSFND + CASE (3) + MDS(12,I) = NDSFND + CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) + CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & + DESC='Input data file' ) + MDS(11,I) = NDSFND + CASE (6) + MDS(13,I) = NDSFND + END SELECT + END IF + END DO + ! + CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) + CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & + DESC='Input data file' ) + MDS(9,I) = NDSFND + ! + IF ( ODAT(5*(5-1)+3,I) .GT. 0 ) THEN + CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT', 9 ) + MDS(10,I) = NDSFND + DO II=0, 8 + CALL WMUSET ( MDSE, MDST, NDSFND+II, .TRUE., & + DESC='Raw output file' ) + END DO + END IF + ! + ! ..... Model initialization + ! + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,982) + ! + CALL W3INIT ( I, .TRUE., MNAMES(I), MDS(:,I), NTRACE(:,I), ODAT(:,I), & + FLGRD(:,:,I),FLGR2(:,:,I),FLGD(:,I),FLG2(:,I), & + OT2(I)%NPTS, OT2(I)%X, OT2(I)%Y, OT2(I)%PNAMES, & + IPRT(:,I), LPRT(I), MPI_COMM_LOC ) + ! + ! ..... Finalize I/O file hook up + ! + II = LEN_TRIM(FILEXT) + JJ = LEN_TRIM(FNMPRE) + CALL WMUINQ ( MDSE, MDST, MDS(1,I) ) + IF ( MDS(3,I) .NE. MDST ) CALL WMUINQ ( MDSE, MDST, MDS(3,I) ) + ! + IF ( MDS(7,I) .NE. -1 ) THEN + IF ( IAPROC .EQ. NAPFLD ) THEN + TNAME = TRIM(FNMPRE)//'out_grd.' // FILEXT(:II) + CALL WMUSET ( MDSE,MDST, MDS(7,I), .TRUE., NAME=TNAME ) + ELSE + CALL WMUSET ( MDSE,MDST, MDS(7,I), .FALSE. ) + MDS(7,I) = -1 + END IF + END IF + ! + IF ( MDS(8,I) .NE. -1 ) THEN + IF ( IAPROC .EQ. NAPPNT ) THEN + TNAME = TRIM(FNMPRE)//'out_pnt.' // FILEXT(:II) + CALL WMUSET ( MDSE,MDST, MDS(8,I), .TRUE., NAME=TNAME ) + ELSE + CALL WMUSET ( MDSE,MDST, MDS(8,I), .FALSE. ) + MDS(8,I) = -1 + END IF + END IF + ! + IF ( MDS(9,I) .NE. -1 ) THEN + IF ( FLBPI ) THEN + TNAME = TRIM(FNMPRE)//'nest.' // FILEXT(:II) + CALL WMUSET ( MDSE, MDST, MDS(9,I), .TRUE., NAME=TNAME ) + ELSE + CALL WMUSET ( MDSE, MDST, MDS(9,I), .FALSE. ) + MDS(9,I) = -1 + END IF + END IF + ! + IF ( MDS(10,I) .NE. -1 ) THEN + IF ( FLBPO .AND. IAPROC.EQ.NAPBPT ) THEN + TNAME = TRIM(FNMPRE)//'nestN.' // FILEXT(:II) + DO J=0, NFBPO-1 + WRITE (TNAME(JJ+5:JJ+5),'(I1)') J + 1 + CALL WMUSET ( MDSE, MDST, MDS(10,I)+J, .TRUE., & + NAME=TNAME ) END DO -! - CALL WMUGET ( MDSE, MDST, NDSFND, 'INP' ) - CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., & - DESC='Input data file' ) - MDS(9,I) = NDSFND -! - IF ( ODAT(5*(5-1)+3,I) .GT. 0 ) THEN - CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT', 9 ) - MDS(10,I) = NDSFND - DO II=0, 8 - CALL WMUSET ( MDSE, MDST, NDSFND+II, .TRUE., & - DESC='Raw output file' ) - END DO - END IF -! -! ..... Model initialization -! - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,982) -! - CALL W3INIT ( I, .TRUE., MNAMES(I), MDS(:,I), NTRACE(:,I), ODAT(:,I), & - FLGRD(:,:,I),FLGR2(:,:,I),FLGD(:,I),FLG2(:,I), & - OT2(I)%NPTS, OT2(I)%X, OT2(I)%Y, OT2(I)%PNAMES, & - IPRT(:,I), LPRT(I), MPI_COMM_LOC ) -! -! ..... Finalize I/O file hook up -! - II = LEN_TRIM(FILEXT) - JJ = LEN_TRIM(FNMPRE) - CALL WMUINQ ( MDSE, MDST, MDS(1,I) ) - IF ( MDS(3,I) .NE. MDST ) CALL WMUINQ ( MDSE, MDST, MDS(3,I) ) -! - IF ( MDS(7,I) .NE. -1 ) THEN - IF ( IAPROC .EQ. NAPFLD ) THEN - TNAME = TRIM(FNMPRE)//'out_grd.' // FILEXT(:II) - CALL WMUSET ( MDSE,MDST, MDS(7,I), .TRUE., NAME=TNAME ) - ELSE - CALL WMUSET ( MDSE,MDST, MDS(7,I), .FALSE. ) - MDS(7,I) = -1 - END IF - END IF -! - IF ( MDS(8,I) .NE. -1 ) THEN - IF ( IAPROC .EQ. NAPPNT ) THEN - TNAME = TRIM(FNMPRE)//'out_pnt.' // FILEXT(:II) - CALL WMUSET ( MDSE,MDST, MDS(8,I), .TRUE., NAME=TNAME ) - ELSE - CALL WMUSET ( MDSE,MDST, MDS(8,I), .FALSE. ) - MDS(8,I) = -1 - END IF - END IF -! - IF ( MDS(9,I) .NE. -1 ) THEN - IF ( FLBPI ) THEN - TNAME = TRIM(FNMPRE)//'nest.' // FILEXT(:II) - CALL WMUSET ( MDSE, MDST, MDS(9,I), .TRUE., NAME=TNAME ) - ELSE - CALL WMUSET ( MDSE, MDST, MDS(9,I), .FALSE. ) - MDS(9,I) = -1 - END IF - END IF -! - IF ( MDS(10,I) .NE. -1 ) THEN - IF ( FLBPO .AND. IAPROC.EQ.NAPBPT ) THEN - TNAME = TRIM(FNMPRE)//'nestN.' // FILEXT(:II) - DO J=0, NFBPO-1 - WRITE (TNAME(JJ+5:JJ+5),'(I1)') J + 1 - CALL WMUSET ( MDSE, MDST, MDS(10,I)+J, .TRUE., & - NAME=TNAME ) - END DO - DO J=NFBPO, 8 - CALL WMUSET ( MDSE,MDST, MDS(10,I)+J, .FALSE. ) - END DO - ELSE - DO J=0, 8 - CALL WMUSET ( MDSE,MDST, MDS(10,I)+J, .FALSE. ) - END DO - MDS(10,I) = -1 - END IF - END IF -! - IF ( MDS(11,I) .NE. -1 ) THEN - TNAME = TRIM(FNMPRE)//'track_i.' // FILEXT(:II) - CALL WMUSET ( MDSE,MDST, MDS(11,I), .TRUE., NAME=TNAME ) - END IF -! - IF ( MDS(12,I) .NE. -1 ) THEN - IF ( IAPROC .EQ. NAPTRK ) THEN - TNAME = TRIM(FNMPRE)//'track_o.' // FILEXT(:II) - CALL WMUSET ( MDSE,MDST, MDS(12,I), .TRUE., NAME=TNAME ) - ELSE - CALL WMUSET ( MDSE,MDST, MDS(12,I), .FALSE. ) - MDS(12,I) = -1 - END IF - END IF -! - IF ( MDS(13,I) .NE. -1 ) THEN - IF ( IAPROC .EQ. NAPPRT ) THEN - TNAME = TRIM(FNMPRE)//'partition.' // FILEXT(:II) - CALL WMUSET ( MDSE,MDST, MDS(13,I), .TRUE., NAME=TNAME ) - ELSE - CALL WMUSET ( MDSE,MDST, MDS(13,I), .FALSE. ) - MDS(13,I) = -1 - END IF - END IF -! -#ifdef W3_T - WRITE (MDST,9081) I, TIME -#endif -! -! 8.a.2 Data file initialization (forcing) -! - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,983) - CALL W3SETI ( I, MDSE, MDST ) -! -! ..... regular input files -! - DO J=JFIRST, 6 - IF ( INFLAGS1(J) ) THEN - IDINP(I,J) = IDSTR(J) - IF ( INPMAP(I,J) .LT. 0 ) CYCLE - CALL W3FLDO ('READ', IDINP(I,J), MDSF(I,J), MDST, MDSE2,& - NX, NY, GTYPE, IERR, MNAMES(I), & - TRIM(FNMPRE) ) - IF ( IERR .NE. 0 ) GOTO 2080 - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & - WRITE (MDSS,985) IDFLDS(J) - ELSE - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & - WRITE (MDSS,984) IDFLDS(J) - END IF + DO J=NFBPO, 8 + CALL WMUSET ( MDSE,MDST, MDS(10,I)+J, .FALSE. ) END DO -! -! ..... assimilation data files -! -! version 3.07: Data assimilation part ignored for now .... -! -! ..... finalize file info data base -! - DO J=JFIRST, 9 - IF ( MDSF(I,J) .NE. -1 ) CALL WMUINQ ( MDSE, MDST, MDSF(I,J) ) + ELSE + DO J=0, 8 + CALL WMUSET ( MDSE,MDST, MDS(10,I)+J, .FALSE. ) END DO -! -! ..... Adjust input flags for other than native or CPL input, -! and initialize input arrays one set at a time as needed. -! - IF ( SIZE(INFLAGS1) .NE. SIZE(TFLAGS) ) THEN - WRITE (MDSE,'(/2A)') ' *** ERROR WMINITNML: ', & - 'SIZE(INFLAGS1).NE.SIZE(TFLAGS) ***' - CALL EXTCDE ( 999 ) + MDS(10,I) = -1 END IF - IF ( SIZE(INFLAGS2) .NE. SIZE(TFLAGS) ) THEN - WRITE (MDSE,'(/2A)') ' *** ERROR WMINITNML: ', & - 'SIZE(INFLAGS2).NE.SIZE(TFLAGS) ***' - CALL EXTCDE ( 999 ) + END IF + ! + IF ( MDS(11,I) .NE. -1 ) THEN + TNAME = TRIM(FNMPRE)//'track_i.' // FILEXT(:II) + CALL WMUSET ( MDSE,MDST, MDS(11,I), .TRUE., NAME=TNAME ) + END IF + ! + IF ( MDS(12,I) .NE. -1 ) THEN + IF ( IAPROC .EQ. NAPTRK ) THEN + TNAME = TRIM(FNMPRE)//'track_o.' // FILEXT(:II) + CALL WMUSET ( MDSE,MDST, MDS(12,I), .TRUE., NAME=TNAME ) + ELSE + CALL WMUSET ( MDSE,MDST, MDS(12,I), .FALSE. ) + MDS(12,I) = -1 + END IF + END IF + ! + IF ( MDS(13,I) .NE. -1 ) THEN + IF ( IAPROC .EQ. NAPPRT ) THEN + TNAME = TRIM(FNMPRE)//'partition.' // FILEXT(:II) + CALL WMUSET ( MDSE,MDST, MDS(13,I), .TRUE., NAME=TNAME ) + ELSE + CALL WMUSET ( MDSE,MDST, MDS(13,I), .FALSE. ) + MDS(13,I) = -1 + END IF + END IF + ! +#ifdef W3_T + WRITE (MDST,9081) I, TIME +#endif + ! + ! 8.a.2 Data file initialization (forcing) + ! + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,983) + CALL W3SETI ( I, MDSE, MDST ) + ! + ! ..... regular input files + ! + DO J=JFIRST, 6 + IF ( INFLAGS1(J) ) THEN + IDINP(I,J) = IDSTR(J) + IF ( INPMAP(I,J) .LT. 0 ) CYCLE + CALL W3FLDO ('READ', IDINP(I,J), MDSF(I,J), MDST, MDSE2,& + NX, NY, GTYPE, IERR, MNAMES(I), & + TRIM(FNMPRE) ) + IF ( IERR .NE. 0 ) GOTO 2080 + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & + WRITE (MDSS,985) IDFLDS(J) + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & + WRITE (MDSS,984) IDFLDS(J) END IF + END DO + ! + ! ..... assimilation data files + ! + ! version 3.07: Data assimilation part ignored for now .... + ! + ! ..... finalize file info data base + ! + DO J=JFIRST, 9 + IF ( MDSF(I,J) .NE. -1 ) CALL WMUINQ ( MDSE, MDST, MDSF(I,J) ) + END DO + ! + ! ..... Adjust input flags for other than native or CPL input, + ! and initialize input arrays one set at a time as needed. + ! + IF ( SIZE(INFLAGS1) .NE. SIZE(TFLAGS) ) THEN + WRITE (MDSE,'(/2A)') ' *** ERROR WMINITNML: ', & + 'SIZE(INFLAGS1).NE.SIZE(TFLAGS) ***' + CALL EXTCDE ( 999 ) + END IF + IF ( SIZE(INFLAGS2) .NE. SIZE(TFLAGS) ) THEN + WRITE (MDSE,'(/2A)') ' *** ERROR WMINITNML: ', & + 'SIZE(INFLAGS2).NE.SIZE(TFLAGS) ***' + CALL EXTCDE ( 999 ) + END IF - TFLAGS = INFLAGS1 -! - DO J=JFIRST, 9 - IF ( INPMAP(I,J) .NE. 0 ) THEN -! - TFLAGS(J) = .TRUE. - INFLAGS1 = .FALSE. - INFLAGS1(J) = .TRUE. - IINIT = .FALSE. - CALL W3DIMI ( I, MDSE, MDST ) -! - IF ( J.EQ.2 ) ALLOCATE ( WADATS(I)%CA0(NSEA) , & - WADATS(I)%CAI(NSEA) , & - WADATS(I)%CD0(NSEA) , & - WADATS(I)%CDI(NSEA) ) -! - IF ( J.EQ.3 ) ALLOCATE ( WADATS(I)%UA0(NSEA) , & - WADATS(I)%UAI(NSEA) , & - WADATS(I)%UD0(NSEA) , & - WADATS(I)%UDI(NSEA) , & - WADATS(I)%AS0(NSEA) , & - WADATS(I)%ASI(NSEA) ) -! - IF ( J.EQ.5 ) ALLOCATE ( WADATS(I)%MA0(NSEA) , & - WADATS(I)%MAI(NSEA) , & - WADATS(I)%MD0(NSEA) , & - WADATS(I)%MDI(NSEA) ) -! - IF ( J.EQ.6 ) ALLOCATE ( WADATS(I)%RA0(NSEA) , & - WADATS(I)%RAI(NSEA) ) -! - END IF - END DO -! - INFLAGS1 = TFLAGS - CALL W3SETI ( I, MDSE, MDST ) - CALL W3SETA ( I, MDSE, MDST ) -! -! 8.a.3 Status indicator and model times -! - DO J=1, NOTYPE - IF ( FLOUT(J) ) THEN - IF ( TOUTP(1,I) .EQ. -1 ) THEN - TOUTP(:,I) = TONEXT(:,J) - ELSE - DTTST = DSEC21 ( TOUTP(:,I), TONEXT(:,J) ) - IF ( DTTST .LT. 0. ) TOUTP(:,I) = TONEXT(:,J) - ENDIF - END IF - END DO -! -! Checkpoint - J=8 - OUTPTS(I)%FLOUT(8)=.FALSE. - IF ( ODAT(5*(J-1)+3,I) .NE. 0 ) THEN - OUTPTS(I)%FLOUT(8)=.TRUE. + TFLAGS = INFLAGS1 + ! + DO J=JFIRST, 9 + IF ( INPMAP(I,J) .NE. 0 ) THEN + ! + TFLAGS(J) = .TRUE. + INFLAGS1 = .FALSE. + INFLAGS1(J) = .TRUE. + IINIT = .FALSE. + CALL W3DIMI ( I, MDSE, MDST ) + ! + IF ( J.EQ.2 ) ALLOCATE ( WADATS(I)%CA0(NSEA) , & + WADATS(I)%CAI(NSEA) , & + WADATS(I)%CD0(NSEA) , & + WADATS(I)%CDI(NSEA) ) + ! + IF ( J.EQ.3 ) ALLOCATE ( WADATS(I)%UA0(NSEA) , & + WADATS(I)%UAI(NSEA) , & + WADATS(I)%UD0(NSEA) , & + WADATS(I)%UDI(NSEA) , & + WADATS(I)%AS0(NSEA) , & + WADATS(I)%ASI(NSEA) ) + ! + IF ( J.EQ.5 ) ALLOCATE ( WADATS(I)%MA0(NSEA) , & + WADATS(I)%MAI(NSEA) , & + WADATS(I)%MD0(NSEA) , & + WADATS(I)%MDI(NSEA) ) + ! + IF ( J.EQ.6 ) ALLOCATE ( WADATS(I)%RA0(NSEA) , & + WADATS(I)%RAI(NSEA) ) + ! + END IF + END DO + ! + INFLAGS1 = TFLAGS + CALL W3SETI ( I, MDSE, MDST ) + CALL W3SETA ( I, MDSE, MDST ) + ! + ! 8.a.3 Status indicator and model times + ! + DO J=1, NOTYPE + IF ( FLOUT(J) ) THEN + IF ( TOUTP(1,I) .EQ. -1 ) THEN + TOUTP(:,I) = TONEXT(:,J) ELSE - OUTPTS(I)%FLOUT(8)=.FALSE. + DTTST = DSEC21 ( TOUTP(:,I), TONEXT(:,J) ) + IF ( DTTST .LT. 0. ) TOUTP(:,I) = TONEXT(:,J) ENDIF + END IF + END DO + ! + ! Checkpoint + J=8 + OUTPTS(I)%FLOUT(8)=.FALSE. + IF ( ODAT(5*(J-1)+3,I) .NE. 0 ) THEN + OUTPTS(I)%FLOUT(8)=.TRUE. + ELSE + OUTPTS(I)%FLOUT(8)=.FALSE. + ENDIF - IF ( FLOUT(J) ) THEN - IF ( TOUTP(1,I) .EQ. -1 ) THEN - TOUTP(:,I) = TONEXT(:,J) - ELSE - DTTST = DSEC21 ( TOUTP(:,I), TONEXT(:,J) ) - IF ( DTTST .LT. 0. ) TOUTP(:,I) = TONEXT(:,J) - ENDIF - END IF -! -! - GRSTAT(I) = 0 - TSYNC(:,I) = TIME(:) -! + IF ( FLOUT(J) ) THEN + IF ( TOUTP(1,I) .EQ. -1 ) THEN + TOUTP(:,I) = TONEXT(:,J) + ELSE + DTTST = DSEC21 ( TOUTP(:,I), TONEXT(:,J) ) + IF ( DTTST .LT. 0. ) TOUTP(:,I) = TONEXT(:,J) + ENDIF + END IF + ! + ! + GRSTAT(I) = 0 + TSYNC(:,I) = TIME(:) + ! #ifdef W3_T - WRITE (MDST,9082) GRSTAT(I), TOUTP(:,I), TSYNC(:,I) + WRITE (MDST,9082) GRSTAT(I), TOUTP(:,I), TSYNC(:,I) #endif -! + ! END DO ! DO I=1, NRGRD -! + ! #ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) - DO I=1, NRGRD - CALL WMSETM ( I, MDSE, MDST ) - CALL W3SETG ( I, MDSE, MDST ) - CALL W3SETO ( I, MDSE, MDST ) - IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN - CALL MPI_BCAST ( TOUTP(1,I), 2, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( TSYNC(1,I), 2, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( GRSTAT(I), 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) -#endif -! -! 8.a.4 Grid sizes etc. for processors that are not used. -! + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN + CALL MPI_BCAST ( TOUTP(1,I), 2, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TSYNC(1,I), 2, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRSTAT(I), 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif + ! + ! 8.a.4 Grid sizes etc. for processors that are not used. + ! #ifdef W3_MPI - CALL MPI_BCAST ( FLAGLL,1, MPI_LOGICAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( GTYPE, 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( ICLOSE,1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NX , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NY , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( X0 , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( SX , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( Y0 , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( SY , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NSEA , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NSEAL, 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DTMAX, 1, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DTCFL, 1, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( FILEXT, 10, MPI_CHARACTER, 0, & - MPI_COMM_BCT, IERR_MPI ) - IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & - CALL W3DIMX ( I, NX, NY, NSEA, MDSE, MDST & + CALL MPI_BCAST ( FLAGLL,1, MPI_LOGICAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GTYPE, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( ICLOSE,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NX , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NY , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( X0 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( SX , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( Y0 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( SY , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NSEA , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NSEAL, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTMAX, 1, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTCFL, 1, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( FILEXT, 10, MPI_CHARACTER, 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + CALL W3DIMX ( I, NX, NY, NSEA, MDSE, MDST & #endif #ifdef W3_SMC - !! SMC grid related variables are not needed beyond MPI_COMM_GRD - !! so all dimensions are minimised to 1. JGLi29Mar2021 + !! SMC grid related variables are not needed beyond MPI_COMM_GRD + !! so all dimensions are minimised to 1. JGLi29Mar2021 #endif #ifdef W3_MPI #ifdef W3_SMC - !!Li , NCel, NUFc, NVFc, NRLv, NBSMC & - !!Li , NARC, NBAC, NSPEC & + !!Li , NCel, NUFc, NVFc, NRLv, NBSMC & + !!Li , NARC, NBAC, NSPEC & , 1, 1, 1, 1, 1, 1, 1, 1 & #endif - ) - CALL MPI_BCAST ( HQFAC, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( HPFAC, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( XGRD, NX*NY, MPI_DOUBLE_PRECISION, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( YGRD, NX*NY, MPI_DOUBLE_PRECISION, 0, & - MPI_COMM_BCT, IERR_MPI ) - IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & - GSU = W3GSUC( .FALSE., FLAGLL, ICLOSE, & - XGRD, YGRD) - CALL MPI_BCAST ( DXDP, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DXDQ, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DYDP, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DYDQ, NX*NY, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( MAPSTA, NX*NY, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( MAPST2, NX*NY, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( GRIDSHIFT, 1, MPI_DOUBLE_PRECISION, 0, & - MPI_COMM_BCT, IERR_MPI ) -#endif -! + ) + CALL MPI_BCAST ( HQFAC, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( HPFAC, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( XGRD, NX*NY, MPI_DOUBLE_PRECISION, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( YGRD, NX*NY, MPI_DOUBLE_PRECISION, 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + GSU = W3GSUC( .FALSE., FLAGLL, ICLOSE, & + XGRD, YGRD) + CALL MPI_BCAST ( DXDP, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DXDQ, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DYDP, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DYDQ, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( MAPSTA, NX*NY, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( MAPST2, NX*NY, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRIDSHIFT, 1, MPI_DOUBLE_PRECISION, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif + ! #ifdef W3_MPI - CALL MPI_BCAST ( NK , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NTH , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( XFR , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( FR1 , 1, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) - IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & - CALL W3DIMS ( I, NK, NTH, MDSE, MDST ) - CALL MPI_BCAST ( TH , NTH, MPI_REAL , 0, & - MPI_COMM_BCT, IERR_MPI ) -#endif -! + CALL MPI_BCAST ( NK , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NTH , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( XFR , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( FR1 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + CALL W3DIMS ( I, NK, NTH, MDSE, MDST ) + CALL MPI_BCAST ( TH , NTH, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif + ! #ifdef W3_MPI - CALL MPI_BCAST ( NAPROC,1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NAPPNT,1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( NBI , 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) -#endif -! + CALL MPI_BCAST ( NAPROC,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NAPPNT,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NBI , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif + ! #ifdef W3_MPI - CALL MPI_BCAST ( FLOUT, 8, MPI_LOGICAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( DTOUT , 8, MPI_REAL, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( TONEXT,16, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - CALL MPI_BCAST ( TOLAST,16, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) -#endif -! + CALL MPI_BCAST ( FLOUT, 8, MPI_LOGICAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTOUT , 8, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TONEXT,16, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TOLAST,16, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif + ! #ifdef W3_MPI - END IF - END DO - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) + END IF + END DO + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) #endif -! - DO I=1, NRGRD - IF ( ALLPRC(IMPROC,I) .EQ. 0 ) THEN - CALL W3SETO ( I, MDSE, MDST ) - IAPROC = -1 - END IF - END DO -! -! 8.a.5 Test output -! + ! + DO I=1, NRGRD + IF ( ALLPRC(IMPROC,I) .EQ. 0 ) THEN + CALL W3SETO ( I, MDSE, MDST ) + IAPROC = -1 + END IF + END DO + ! + ! 8.a.5 Test output + ! #ifdef W3_T - WRITE (MDST,9020) 'AFTER SETUP' - DO I=1, NRGRD - WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) - END DO -#endif -! -! 8.a.6 Check for coordinate system -! - DO I=1, NRGRD-1 - IF ( GRIDS(I)%FLAGLL .NEQV. GRIDS(I+1)%FLAGLL ) GOTO 2070 - END DO -! -! 8.b Input files -! + WRITE (MDST,9020) 'AFTER SETUP' + DO I=1, NRGRD + WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) + END DO +#endif + ! + ! 8.a.6 Check for coordinate system + ! + DO I=1, NRGRD-1 + IF ( GRIDS(I)%FLAGLL .NEQV. GRIDS(I+1)%FLAGLL ) GOTO 2070 + END DO + ! + ! 8.b Input files + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.c' - PRFT0 = PRFTN -#endif -! - DO I=1, NRINP -! - IF ( .NOT. USEINP(I) ) CYCLE -! - J = LEN_TRIM(MNAMES(-I)) - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) THEN - WRITE (MDSS,988) I, MNAMES(-I)(1:J) - WRITE (MDSS,987) - END IF -! - CALL W3IOGR ( 'GRID', NDSREC, -I, MNAMES(-I)(1:J) ) - CALL W3DIMI ( -I, MDSE, MDST ) -! - IF ( CPLINP(I) ) CYCLE -! - DO J=JFIRST, 6 - IF ( INFLAGS1(J) ) THEN - IDINP(-I,J) = IDSTR(J) - CALL W3FLDO ('READ', IDINP(-I,J), MDSF(-I,J), MDST, & - MDSE2, NX, NY, GTYPE, IERR, & - MNAMES(-I), TRIM(FNMPRE) ) - IF ( IERR .NE. 0 ) GOTO 2080 - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & - WRITE (MDSS,985) IDFLDS(J) - ELSE - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & - WRITE (MDSS,984) IDFLDS(J) - END IF - END DO -! -! Skipping assimilation input files for now. -! - DO J=JFIRST, 9 - IF ( MDSF(-I,J) .NE. -1 ) CALL WMUINQ & - ( MDSE, MDST, MDSF(-I,J) ) - END DO -! - END DO -! - DO I=1, NRGRD - DO J=JFIRST, 9 - IF ( INPMAP(I,J) .LT. 0 ) IDINP(I,J) = IDINP( INPMAP(I,J),J) - IF ( INPMAP(I,J) .GT. 0 ) IDINP(I,J) = IDINP(-INPMAP(I,J),J) - END DO - END DO -! - DEALLOCATE ( USEINP ) - DEALLOCATE ( CPLINP ) -! -! 8.c Inter model initialization -! + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.c' + PRFT0 = PRFTN +#endif + ! + DO I=1, NRINP + ! + IF ( .NOT. USEINP(I) ) CYCLE + ! + J = LEN_TRIM(MNAMES(-I)) + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) THEN + WRITE (MDSS,988) I, MNAMES(-I)(1:J) + WRITE (MDSS,987) + END IF + ! + CALL W3IOGR ( 'GRID', NDSREC, -I, MNAMES(-I)(1:J) ) + CALL W3DIMI ( -I, MDSE, MDST ) + ! + IF ( CPLINP(I) ) CYCLE + ! + DO J=JFIRST, 6 + IF ( INFLAGS1(J) ) THEN + IDINP(-I,J) = IDSTR(J) + CALL W3FLDO ('READ', IDINP(-I,J), MDSF(-I,J), MDST, & + MDSE2, NX, NY, GTYPE, IERR, & + MNAMES(-I), TRIM(FNMPRE) ) + IF ( IERR .NE. 0 ) GOTO 2080 + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & + WRITE (MDSS,985) IDFLDS(J) + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & + WRITE (MDSS,984) IDFLDS(J) + END IF + END DO + ! + ! Skipping assimilation input files for now. + ! + DO J=JFIRST, 9 + IF ( MDSF(-I,J) .NE. -1 ) CALL WMUINQ & + ( MDSE, MDST, MDSF(-I,J) ) + END DO + ! + END DO + ! + DO I=1, NRGRD + DO J=JFIRST, 9 + IF ( INPMAP(I,J) .LT. 0 ) IDINP(I,J) = IDINP( INPMAP(I,J),J) + IF ( INPMAP(I,J) .GT. 0 ) IDINP(I,J) = IDINP(-INPMAP(I,J),J) + END DO + END DO + ! + DEALLOCATE ( USEINP ) + DEALLOCATE ( CPLINP ) + ! + ! 8.c Inter model initialization + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.d' - PRFT0 = PRFTN + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.d' + PRFT0 = PRFTN #endif -! 8.c.1 Spectral conversion flags and source term flags -! - CALL WMRSPC -! - DO I=1, NRGRD - CALL W3SETG ( I, MDSE, MDST ) - FLAGST = .TRUE. - END DO -! -! 8.c.2 Relation to lower ranked grids -! Includes update of unit numbers, and bound. data initialization. -! - ALLOCATE ( FLRBPI(NRGRD) ) - CALL WMGLOW ( FLRBPI ) -! -! ..... At this point the grid-search-utility (GSU) object for grids -! that do not belong to this processor is no longer needed. -! + ! 8.c.1 Spectral conversion flags and source term flags + ! + CALL WMRSPC + ! + DO I=1, NRGRD + CALL W3SETG ( I, MDSE, MDST ) + FLAGST = .TRUE. + END DO + ! + ! 8.c.2 Relation to lower ranked grids + ! Includes update of unit numbers, and bound. data initialization. + ! + ALLOCATE ( FLRBPI(NRGRD) ) + CALL WMGLOW ( FLRBPI ) + ! + ! ..... At this point the grid-search-utility (GSU) object for grids + ! that do not belong to this processor is no longer needed. + ! #ifdef W3_MPI - DO I=1, NRGRD - CALL WMSETM ( I, MDSE, MDST ) - CALL W3SETG ( I, MDSE, MDST ) -#endif -! the next line (with the W3GSUD call) removed Jan 8 2013. -! ...ref: personal communication, -! ...email from Rogers to Alves, Campbell, Tolman, Chawla Dec 13 2012. -! REMOVED !/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) CALL W3GSUD( GSU ) + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) +#endif + ! the next line (with the W3GSUD call) removed Jan 8 2013. + ! ...ref: personal communication, + ! ...email from Rogers to Alves, Campbell, Tolman, Chawla Dec 13 2012. + ! REMOVED !/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) CALL W3GSUD( GSU ) #ifdef W3_MPI - END DO + END DO #endif -! -! ..... Unit numbers -! + ! + ! ..... Unit numbers + ! - DO I=1, NRGRD -! - CALL W3SETG ( I, MDSE, MDST ) - CALL W3SETO ( I, MDSE, MDST ) -! - IF ( BCDUMP(I) .AND. FLRBPI(I) ) THEN - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1080) I - IF ( IMPROC .EQ. NMPLOG ) WRITE (MDSO,1082) I - BCDUMP(I) = .FALSE. - END IF -! - IF ( BCDUMP(I) .AND. NBI.EQ.0 ) THEN - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1081) I - IF ( IMPROC .EQ. NMPLOG ) WRITE (MDSO,1082) I - BCDUMP(I) = .FALSE. - END IF -! + DO I=1, NRGRD + ! + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + ! + IF ( BCDUMP(I) .AND. FLRBPI(I) ) THEN + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1080) I + IF ( IMPROC .EQ. NMPLOG ) WRITE (MDSO,1082) I + BCDUMP(I) = .FALSE. + END IF + ! + IF ( BCDUMP(I) .AND. NBI.EQ.0 ) THEN + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1081) I + IF ( IMPROC .EQ. NMPLOG ) WRITE (MDSO,1082) I + BCDUMP(I) = .FALSE. + END IF + ! #ifdef W3_SHRD - IF ( .NOT. FLRBPI(I) .AND. FLBPI ) THEN + IF ( .NOT. FLRBPI(I) .AND. FLBPI ) THEN #endif #ifdef W3_MPI IF ( .NOT. FLRBPI(I) .AND. FLBPI .AND. & - MPI_COMM_GRD .NE. MPI_COMM_NULL) THEN -#endif - CALL WMUSET ( MDSE, MDST, NDS(9), .FALSE. ) - IF ( BCDUMP(I) .AND. IAPROC.EQ.NAPBPT ) THEN - J = LEN_TRIM(FILEXT) - TNAME(1:5) = 'nest.' - TNAME(6:5+J) = FILEXT(1:J) - J = J + 5 - CALL WMUGET ( MDSE, MDST, NDS(9), 'OUT' ) - CALL WMUSET ( MDSE, MDST, NDS(9), .TRUE., & - NAME=TRIM(FNMPRE)//TNAME(1:J), & - DESC='Output data file (nest dump)' ) - MDS(9,I) = NDSFND - ELSE - NDS(9) = -1 - END IF + MPI_COMM_GRD .NE. MPI_COMM_NULL) THEN +#endif + CALL WMUSET ( MDSE, MDST, NDS(9), .FALSE. ) + IF ( BCDUMP(I) .AND. IAPROC.EQ.NAPBPT ) THEN + J = LEN_TRIM(FILEXT) + TNAME(1:5) = 'nest.' + TNAME(6:5+J) = FILEXT(1:J) + J = J + 5 + CALL WMUGET ( MDSE, MDST, NDS(9), 'OUT' ) + CALL WMUSET ( MDSE, MDST, NDS(9), .TRUE., & + NAME=TRIM(FNMPRE)//TNAME(1:J), & + DESC='Output data file (nest dump)' ) + MDS(9,I) = NDSFND + ELSE + NDS(9) = -1 + END IF #ifdef W3_MPI - END IF ! IF ( .NOT. FLRBPI(I) .AND. FLBPI .AND. MPI_COMM_GRD .NE. MPI_COMM_NULL) + END IF ! IF ( .NOT. FLRBPI(I) .AND. FLBPI .AND. MPI_COMM_GRD .NE. MPI_COMM_NULL) #endif #ifdef W3_SHRD - END IF ! IF ( .NOT. FLRBPI(I) .AND. FLBPI ) -#endif -! - END DO -! -! ..... Data initialization -! - DO I=1, NRGRD + END IF ! IF ( .NOT. FLRBPI(I) .AND. FLBPI ) +#endif + ! + END DO + ! + ! ..... Data initialization + ! + DO I=1, NRGRD #ifdef W3_MPI - CALL WMSETM ( I, MDSE, MDST ) - IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBS ( I ) + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBS ( I ) #endif #ifdef W3_SHRD - CALL WMIOBS ( I ) + CALL WMIOBS ( I ) #endif - END DO -! - DO I=1, NRGRD + END DO + ! + DO I=1, NRGRD #ifdef W3_MPI - CALL WMSETM ( I, MDSE, MDST ) - IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBG ( I ) + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBG ( I ) #endif #ifdef W3_SHRD - CALL WMIOBG ( I ) + CALL WMIOBG ( I ) #endif - END DO -! + END DO + ! #ifdef W3_MPI - DO I=1, NRGRD - CALL WMSETM ( I, MDSE, MDST ) - IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBF ( I ) - END DO -#endif -! -! 8.c.3 Relation to same ranked grids -! + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBF ( I ) + END DO +#endif + ! + ! 8.c.3 Relation to same ranked grids + ! #ifdef W3_SMC - !! Check whether there is a SMC grid group. JGLi12Apr2021 - NGRPSMC = 0 - DO JJ=1, NRGRP - J = 0 - DO II=1, INGRP(JJ,0) - I = INGRP(JJ,II) - IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) J = J + 1 - ENDDO - IF( J .GT. 1 ) NGRPSMC = JJ + !! Check whether there is a SMC grid group. JGLi12Apr2021 + NGRPSMC = 0 + DO JJ=1, NRGRP + J = 0 + DO II=1, INGRP(JJ,0) + I = INGRP(JJ,II) + IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) J = J + 1 ENDDO - IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " NGRPSMC =", NGRPSMC - - !! Equal ranked SMC grid group uses its own sub. JGLi12Apr2021 - IF( NGRPSMC .GT. 0 ) THEN - CALL WMSMCEQL - ELSE + IF( J .GT. 1 ) NGRPSMC = JJ + ENDDO + IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " NGRPSMC =", NGRPSMC + + !! Equal ranked SMC grid group uses its own sub. JGLi12Apr2021 + IF( NGRPSMC .GT. 0 ) THEN + CALL WMSMCEQL + ELSE #endif -! + ! CALL WMGEQL -! + ! #ifdef W3_SMC - ENDIF -#endif -! -! 8.c.4 Relation to higher ranked grids -! - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,938) & - 'Computing relation to higher ranked grids' - CALL WMGHGH - IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,938) & - 'Finished computing relation to higher ranked grids' -! -! 8.c.5 Unified point output -! - IF ( UNIPTS ) THEN -! - OUTPTS(0)%TONEXT(1,2) = ODAT( 6,0) - OUTPTS(0)%TONEXT(2,2) = ODAT( 7,0) - OUTPTS(0)%DTOUT ( 2) = REAL ( ODAT( 8,0) ) - OUTPTS(0)%TOLAST(1,2) = ODAT( 9,0) - OUTPTS(0)%TOLAST(2,2) = ODAT(10,0) -! - TOUT = OUTPTS(0)%TONEXT(:,2) - TLST = OUTPTS(0)%TOLAST(:,2) -! - DO - DTTST = DSEC21 ( STIME , TOUT ) - IF ( DTTST .LT. 0 ) THEN - CALL TICK21 ( TOUT, OUTPTS(0)%DTOUT(2) ) - ELSE - EXIT - END IF - END DO -! - OUTPTS(0)%TONEXT(:,2) = TOUT -! - DTTST = DSEC21 ( TOUT , TLST ) - IF (( DTTST .LT. 0. ) .OR. ( ODAT(8,0) .EQ. 0 )) THEN - UNIPTS = .FALSE. - ELSE - CALL WMIOPP ( OT2(0)%NPTS, OT2(0)%X, OT2(0)%Y, & - OT2(0)%PNAMES ) - END IF -! + ENDIF +#endif + ! + ! 8.c.4 Relation to higher ranked grids + ! + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,938) & + 'Computing relation to higher ranked grids' + CALL WMGHGH + IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) WRITE (MDSS,938) & + 'Finished computing relation to higher ranked grids' + ! + ! 8.c.5 Unified point output + ! + IF ( UNIPTS ) THEN + ! + OUTPTS(0)%TONEXT(1,2) = ODAT( 6,0) + OUTPTS(0)%TONEXT(2,2) = ODAT( 7,0) + OUTPTS(0)%DTOUT ( 2) = REAL ( ODAT( 8,0) ) + OUTPTS(0)%TOLAST(1,2) = ODAT( 9,0) + OUTPTS(0)%TOLAST(2,2) = ODAT(10,0) + ! + TOUT = OUTPTS(0)%TONEXT(:,2) + TLST = OUTPTS(0)%TOLAST(:,2) + ! + DO + DTTST = DSEC21 ( STIME , TOUT ) + IF ( DTTST .LT. 0 ) THEN + CALL TICK21 ( TOUT, OUTPTS(0)%DTOUT(2) ) + ELSE + EXIT + END IF + END DO + ! + OUTPTS(0)%TONEXT(:,2) = TOUT + ! + DTTST = DSEC21 ( TOUT , TLST ) + IF (( DTTST .LT. 0. ) .OR. ( ODAT(8,0) .EQ. 0 )) THEN + UNIPTS = .FALSE. + ELSE + CALL WMIOPP ( OT2(0)%NPTS, OT2(0)%X, OT2(0)%Y, & + OT2(0)%PNAMES ) + END IF + ! #ifdef W3_MPI - DO I=1, NRGRD - CALL WMSETM ( I, MDSE, MDST ) - CALL W3SETG ( I, MDSE, MDST ) - CALL W3SETO ( I, MDSE, MDST ) - IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN - CALL MPI_BCAST ( NOPTS, 1, MPI_INTEGER, 0, & - MPI_COMM_BCT, IERR_MPI ) - END IF - END DO + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN + CALL MPI_BCAST ( NOPTS, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + END IF + END DO #endif -! + ! END IF ! IF ( UNIPTS ) -! -! 8.c.6 Output -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,938) 'Additional group information' -! - IF ( MAXVAL(GRDLOW(:,0)) .GT. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,933) 'Lower rank grid dependence' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,933) 'Lower rank grid dependence' - DO I=1, NRGRD - WRITE (LINE(1:6),'(1X,I3,2X)') I - JJJ = 6 - IF ( GRDLOW(I,0) .NE. 0 ) THEN - DO J=1, GRDLOW(I,0) - WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDLOW(I,J) - JJJ = JJJ + 3 - END DO - ELSE IF ( FLRBPI(I) ) THEN - JJJ = 21 - LINE(7:JJJ) = ' Data from file' - ELSE - JJJ = 22 - LINE(7:JJJ) = ' No dependencies' - END IF - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE(MDSS,934) LINE(1:JJJ) - IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + ! + ! 8.c.6 Output + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,938) 'Additional group information' + ! + IF ( MAXVAL(GRDLOW(:,0)) .GT. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,933) 'Lower rank grid dependence' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,933) 'Lower rank grid dependence' + DO I=1, NRGRD + WRITE (LINE(1:6),'(1X,I3,2X)') I + JJJ = 6 + IF ( GRDLOW(I,0) .NE. 0 ) THEN + DO J=1, GRDLOW(I,0) + WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDLOW(I,J) + JJJ = JJJ + 3 + END DO + ELSE IF ( FLRBPI(I) ) THEN + JJJ = 21 + LINE(7:JJJ) = ' Data from file' ELSE - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,937) 'No lower rank grid dependencies' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,937) 'No lower rank grid dependencies' + JJJ = 22 + LINE(7:JJJ) = ' No dependencies' + END IF + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE(MDSS,934) LINE(1:JJJ) + IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,937) 'No lower rank grid dependencies' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,937) 'No lower rank grid dependencies' END IF ! IF ( MAXVAL(GRDLOW(:,0)) .GT. 0 ) - DEALLOCATE ( FLRBPI ) -! - IF ( MAXVAL(GRDEQL(:,0)) .GT. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,933) 'Same rank grid dependence' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,933) 'Same rank grid dependence' - DO I=1, NRGRD - WRITE (LINE(1:6),'(1X,I3,2X)') I - JJJ = 6 - IF ( GRDEQL(I,0) .NE. 0 ) THEN - DO J=1, GRDEQL(I,0) - WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDEQL(I,J) - JJJ = JJJ + 3 - END DO - ELSE - JJJ = 22 - LINE(7:JJJ) = ' No dependencies' - END IF - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE(MDSS,934) LINE(1:JJJ) - IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + DEALLOCATE ( FLRBPI ) + ! + IF ( MAXVAL(GRDEQL(:,0)) .GT. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,933) 'Same rank grid dependence' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,933) 'Same rank grid dependence' + DO I=1, NRGRD + WRITE (LINE(1:6),'(1X,I3,2X)') I + JJJ = 6 + IF ( GRDEQL(I,0) .NE. 0 ) THEN + DO J=1, GRDEQL(I,0) + WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDEQL(I,J) + JJJ = JJJ + 3 + END DO ELSE - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,937) 'No same rank grid dependencies' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,937) 'No same rank grid dependencies' + JJJ = 22 + LINE(7:JJJ) = ' No dependencies' + END IF + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE(MDSS,934) LINE(1:JJJ) + IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,937) 'No same rank grid dependencies' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,937) 'No same rank grid dependencies' END IF ! IF ( MAXVAL(GRDEQL(:,0)) .GT. 0 ) -! - IF ( MAXVAL(GRDHGH(:,0)) .GT. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,933) 'Higher rank grid dependence' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,933) 'Higher rank grid dependence' - DO I=1, NRGRD - WRITE (LINE(1:6),'(1X,I3,2X)') I - JJJ = 6 - IF ( GRDHGH(I,0) .NE. 0 ) THEN - DO J=1, GRDHGH(I,0) - WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDHGH(I,J) - JJJ = JJJ + 3 - END DO - ELSE - JJJ = 22 - LINE(7:JJJ) = ' No dependencies' - END IF - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE(MDSS,934) LINE(1:JJJ) - IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) - END DO - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) - IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + ! + IF ( MAXVAL(GRDHGH(:,0)) .GT. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,933) 'Higher rank grid dependence' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,933) 'Higher rank grid dependence' + DO I=1, NRGRD + WRITE (LINE(1:6),'(1X,I3,2X)') I + JJJ = 6 + IF ( GRDHGH(I,0) .NE. 0 ) THEN + DO J=1, GRDHGH(I,0) + WRITE (LINE(JJJ+1:JJJ+3),'(I3)') GRDHGH(I,J) + JJJ = JJJ + 3 + END DO ELSE - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,937) 'No higher rank grid dependencies' - IF ( NMPLOG .EQ. IMPROC ) & - WRITE (MDSO,937) 'No higher rank grid dependencies' + JJJ = 22 + LINE(7:JJJ) = ' No dependencies' + END IF + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE(MDSS,934) LINE(1:JJJ) + IF ( NMPLOG .EQ. IMPROC ) WRITE(MDSO,934) LINE(1:JJJ) + END DO + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,935) + IF ( NMPLOG .EQ. IMPROC ) WRITE (MDSO,935) + ELSE + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,937) 'No higher rank grid dependencies' + IF ( NMPLOG .EQ. IMPROC ) & + WRITE (MDSO,937) 'No higher rank grid dependencies' END IF ! IF ( MAXVAL(GRDHGH(:,0)) .GT. 0 ) -! + ! #ifdef W3_T - WRITE (MDST,9083) - DO I=-NRINP, NRGRD - WRITE (MDST,9084) I, IDINP(I,:) - END DO -#endif -! -! Test output of connected units (always) -! - CALL WMUSET ( MDSE, MDST, SCRATCH, .FALSE. ) - IF ( TSTOUT ) CALL WMUDMP ( MDST, 0 ) -! - DEALLOCATE ( MDS, NTRACE, ODAT, FLGRD, FLGR2, FLGD, FLG2, INAMES,& - MNAMES ) -! + WRITE (MDST,9083) + DO I=-NRINP, NRGRD + WRITE (MDST,9084) I, IDINP(I,:) + END DO +#endif + ! + ! Test output of connected units (always) + ! + CALL WMUSET ( MDSE, MDST, SCRATCH, .FALSE. ) + IF ( TSTOUT ) CALL WMUDMP ( MDST, 0 ) + ! + DEALLOCATE ( MDS, NTRACE, ODAT, FLGRD, FLGR2, FLGD, FLG2, INAMES,& + MNAMES ) + ! #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) #endif -! - CALL DATE_AND_TIME ( VALUES=CLKDT2 ) - CLKFIN = TDIFF ( CLKDT1,CLKDT2 ) -! + ! + CALL DATE_AND_TIME ( VALUES=CLKDT2 ) + CLKFIN = TDIFF ( CLKDT1,CLKDT2 ) + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'END' + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'END' #endif -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,998) + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,998) #ifdef W3_O10 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) -#endif -! - RETURN -! -! Escape locations read errors : -! - 2003 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1003) - CALL EXTCDE ( 2003 ) - RETURN -! - 2104 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1104) IERR - CALL EXTCDE ( 1104 ) - RETURN -! - 2004 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1004) IERR - CALL EXTCDE ( 2004 ) - RETURN -! - 2010 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1010) IERR - CALL EXTCDE ( 2010 ) - RETURN -! - 2011 CONTINUE -! === no process number filtering for test file !!! === - WRITE (MDSE,1011) IERR - CALL EXTCDE ( 2011 ) - RETURN -! - 2020 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1020) - CALL EXTCDE ( 2020 ) - RETURN -! - 2021 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1021) - CALL EXTCDE ( 2021 ) - RETURN -! - 2030 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1030) MNAMES(I), INAMES(I,J) - CALL EXTCDE ( 2030 ) - RETURN -! - 2031 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1031) INAMES(I,J), J - CALL EXTCDE ( 2031 ) - RETURN -! -!2050 CONTINUE -! IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1040) -! CALL EXTCDE ( 2050 ) -! RETURN -! - 2051 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1051) MN(:II) - CALL EXTCDE ( 2051 ) - RETURN -! - 2052 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1052) J - CALL EXTCDE ( 2052 ) - RETURN -! - 2053 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1053) - CALL EXTCDE ( 2053 ) - RETURN -! - 2054 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1054) - CALL EXTCDE ( 2054 ) - RETURN -! - 2055 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1055) - CALL EXTCDE ( 2055 ) - RETURN -! - 2060 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1060) - CALL EXTCDE ( 2060 ) - RETURN -! - 2061 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1061) IDTST, N_MOV - CALL EXTCDE ( 2061 ) - RETURN -! - 2062 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1062) IDTST - CALL EXTCDE ( 2062 ) - RETURN -! - 2070 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1070) - CALL EXTCDE ( 2070 ) - RETURN -! - 2080 CONTINUE - CALL EXTCDE ( 2080 ) - RETURN -! -! Formats -! - 900 FORMAT ( ' ========== STARTING MWW3 INITIALIZATION (WMINITNML) =', & - '============================'/) - 901 FORMAT ( ' WAVEWATCH III log file ', & - ' version ',A/ & - ' ==================================', & - '==================================='/ & - ' multi-grid model driver ', & - 'date : ',A10/50X,'time : ',A8) -! - 910 FORMAT ( ' Opening input file ',A,' (unit number',I3,')') - 911 FORMAT ( ' Opening output file ',A,' (unit number',I3,')') - 912 FORMAT (/' Comment character : ''',A,'''') -! - 920 FORMAT (/' Number of grids :',I3) - 921 FORMAT ( ' No input data grids.') - 922 FORMAT ( ' Input data grids :',I3) - 923 FORMAT ( ' Single point output file : ',A) - 1923 FORMAT (/' Output server type :',I3) - 2923 FORMAT ( ' Single point output proc : ',A) - 3923 FORMAT ( ' Grids share output procs : ',A) -! - 924 FORMAT (/' Input grid information : '/ & - ' nr extension lev. cur. wind ice tau', & - ' rho data'/ & - ' ----------------------------------------------', & - '---------------') - 925 FORMAT (1X,I3,1X,A10,6(1X,A6),3(1X,A1)) - 926 FORMAT ( ' ----------------------------------------------', & - '---------------') -! - 927 FORMAT (/' Grid for point output : '/ & - ' nr extension '/ ' ---------------') - 928 FORMAT (5X,A10) - 929 FORMAT ( ' ---------------') -! - 930 FORMAT (/' Wave grid information : '/ & - ' nr extension lev. cur. wind ice tau', & - ' rho data move1 rnk grp dmp'/ & - ' -----------------------------------------------', & - '-----------------------------------') - 931 FORMAT (1X,I3,1X,A10,6(1X,A6),3(1X,A1),2X,A4,2I4,3X,A1) - 932 FORMAT ( ' -----------------------------------------------', & - '-----------------------------------'/) - 933 FORMAT ( ' ',A,' : '/ & - ' nr grids (part of comm.)'/ & - ' -----------------------------------------------', & - '---------------------') - 934 FORMAT (A) - 935 FORMAT ( ' -----------------------------------------------', & - '---------------------'/) - 936 FORMAT (/' ',A,' : '/ & - ' nr Depends on '/ & - ' -----------------------------------------------', & - '---------------------') - 937 FORMAT ( ' ',A/) - 938 FORMAT (/' ',A/) -! - 940 FORMAT (/' Time interval : '/ & - ' --------------------------------------------------') - 941 FORMAT ( ' Starting time : ',A) - 942 FORMAT ( ' Ending time : ',A/) - 943 FORMAT (/' Model settings : '/ & - ' --------------------------------------------------') - 944 FORMAT ( ' Masking computation in nesting : ',A) - 945 FORMAT ( ' Masking output in nesting : ',A/) -! - 950 FORMAT (/' Output requests : (',A,') '/ & - ' ==================================================') - 951 FORMAT (/' Type',I2,' : ',A/ & - ' -----------------------------------------') - 952 FORMAT ( ' From : ',A) - 953 FORMAT ( ' To : ',A) - 954 FORMAT ( ' Interval : ',A/) - 955 FORMAT ( ' Fields : ',A) - 956 FORMAT ( ' ',A) - 957 FORMAT ( ' Point 1 : ',2E14.6,2X,A) - 958 FORMAT ( ' ',I6,' : ',2E14.6,2X,A) - 959 FORMAT ( ' No points defined') - 960 FORMAT ( ' The file with ',A,' data is ',A,'.') - 961 FORMAT ( ' IX fls : ',3I6/ & - ' IY fls : ',3I6) - 962 FORMAT (/' Output request for model ',A,' (nr',I3,') '/ & - ' ==================================================') - 963 FORMAT ( ' Output disabled') -! - 965 FORMAT (/' Grid movement data (!/MGP, !/MGW): '/ & - ' --------------------------------------------------') - 966 FORMAT ( ' ',A) - 967 FORMAT ( ' ',I6,2X,A) - 968 FORMAT ( ' ',I6,I11.8,I7.6,2F8.2) -! - 970 FORMAT(//' Assigning resources : '/ & - ' --------------------------------------------------') - 971 FORMAT ( ' ',A) - 972 FORMAT ( ' Process ',I5.5,' reserved for all point output.') - 973 FORMAT ( ' Processes ',I5.5,' through ',I5.5,' [',I3,']', & - ' reserved for output.') - 974 FORMAT (/ & - 5X,' grid comp. grd pnt trk rst bpt prt'/ & - 5X,' ------------------------------------------------------', & - '-------------') - 975 FORMAT (5X,' ',A10,2X,I5.5,'-',I5.5,6(2x,A5)) - 976 FORMAT(5X,' -------------------------------------------------', & - '------------------') - 977 FORMAT (5X,' Unified point output at ',I5.5) - 1974 FORMAT (' Resource assignement (processes) : '/ & - ' grid comp. grd pnt trk rst bpt prt'/ & - ' ------------------------------------------------------', & - '-------------') - 1975 FORMAT (' ',A10,2X,I5.5,'-',I5.5,6(2x,A5)) - 1976 FORMAT (' ---------------------------------------------------', & - '----------------') - 1977 FORMAT (' Unified point output at ',I5.5) -! - 980 FORMAT(//' Initializations :'/ & - ' --------------------------------------------------') - 981 FORMAT ( ' Model number',I3,' [',A,']') - 982 FORMAT ( ' Initializing wave model ...') - 983 FORMAT ( ' Initializing model input ...') - 984 FORMAT ( ' ',A,': file not needed') - 985 FORMAT ( ' ',A,': file OK') - 986 FORMAT ( ' Unified point output [',A,']') - 987 FORMAT ( ' Initializing grids ...') - 988 FORMAT ( ' Input data grid',I3,' [',A,']') -! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) +#endif + ! + RETURN + ! + ! Escape locations read errors : + ! +2003 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1003) + CALL EXTCDE ( 2003 ) + RETURN + ! +2104 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1104) IERR + CALL EXTCDE ( 1104 ) + RETURN + ! +2004 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1004) IERR + CALL EXTCDE ( 2004 ) + RETURN + ! +2010 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1010) IERR + CALL EXTCDE ( 2010 ) + RETURN + ! +2011 CONTINUE + ! === no process number filtering for test file !!! === + WRITE (MDSE,1011) IERR + CALL EXTCDE ( 2011 ) + RETURN + ! +2020 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1020) + CALL EXTCDE ( 2020 ) + RETURN + ! +2021 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1021) + CALL EXTCDE ( 2021 ) + RETURN + ! +2030 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1030) MNAMES(I), INAMES(I,J) + CALL EXTCDE ( 2030 ) + RETURN + ! +2031 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1031) INAMES(I,J), J + CALL EXTCDE ( 2031 ) + RETURN + ! + !2050 CONTINUE + ! IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1040) + ! CALL EXTCDE ( 2050 ) + ! RETURN + ! +2051 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1051) MN(:II) + CALL EXTCDE ( 2051 ) + RETURN + ! +2052 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1052) J + CALL EXTCDE ( 2052 ) + RETURN + ! +2053 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1053) + CALL EXTCDE ( 2053 ) + RETURN + ! +2054 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1054) + CALL EXTCDE ( 2054 ) + RETURN + ! +2055 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1055) + CALL EXTCDE ( 2055 ) + RETURN + ! +2060 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1060) + CALL EXTCDE ( 2060 ) + RETURN + ! +2061 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1061) IDTST, N_MOV + CALL EXTCDE ( 2061 ) + RETURN + ! +2062 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1062) IDTST + CALL EXTCDE ( 2062 ) + RETURN + ! +2070 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1070) + CALL EXTCDE ( 2070 ) + RETURN + ! +2080 CONTINUE + CALL EXTCDE ( 2080 ) + RETURN + ! + ! Formats + ! +900 FORMAT ( ' ========== STARTING MWW3 INITIALIZATION (WMINITNML) =', & + '============================'/) +901 FORMAT ( ' WAVEWATCH III log file ', & + ' version ',A/ & + ' ==================================', & + '==================================='/ & + ' multi-grid model driver ', & + 'date : ',A10/50X,'time : ',A8) + ! +910 FORMAT ( ' Opening input file ',A,' (unit number',I3,')') +911 FORMAT ( ' Opening output file ',A,' (unit number',I3,')') +912 FORMAT (/' Comment character : ''',A,'''') + ! +920 FORMAT (/' Number of grids :',I3) +921 FORMAT ( ' No input data grids.') +922 FORMAT ( ' Input data grids :',I3) +923 FORMAT ( ' Single point output file : ',A) +1923 FORMAT (/' Output server type :',I3) +2923 FORMAT ( ' Single point output proc : ',A) +3923 FORMAT ( ' Grids share output procs : ',A) + ! +924 FORMAT (/' Input grid information : '/ & + ' nr extension lev. cur. wind ice tau', & + ' rho data'/ & + ' ----------------------------------------------', & + '---------------') +925 FORMAT (1X,I3,1X,A10,6(1X,A6),3(1X,A1)) +926 FORMAT ( ' ----------------------------------------------', & + '---------------') + ! +927 FORMAT (/' Grid for point output : '/ & + ' nr extension '/ ' ---------------') +928 FORMAT (5X,A10) +929 FORMAT ( ' ---------------') + ! +930 FORMAT (/' Wave grid information : '/ & + ' nr extension lev. cur. wind ice tau', & + ' rho data move1 rnk grp dmp'/ & + ' -----------------------------------------------', & + '-----------------------------------') +931 FORMAT (1X,I3,1X,A10,6(1X,A6),3(1X,A1),2X,A4,2I4,3X,A1) +932 FORMAT ( ' -----------------------------------------------', & + '-----------------------------------'/) +933 FORMAT ( ' ',A,' : '/ & + ' nr grids (part of comm.)'/ & + ' -----------------------------------------------', & + '---------------------') +934 FORMAT (A) +935 FORMAT ( ' -----------------------------------------------', & + '---------------------'/) +936 FORMAT (/' ',A,' : '/ & + ' nr Depends on '/ & + ' -----------------------------------------------', & + '---------------------') +937 FORMAT ( ' ',A/) +938 FORMAT (/' ',A/) + ! +940 FORMAT (/' Time interval : '/ & + ' --------------------------------------------------') +941 FORMAT ( ' Starting time : ',A) +942 FORMAT ( ' Ending time : ',A/) +943 FORMAT (/' Model settings : '/ & + ' --------------------------------------------------') +944 FORMAT ( ' Masking computation in nesting : ',A) +945 FORMAT ( ' Masking output in nesting : ',A/) + ! +950 FORMAT (/' Output requests : (',A,') '/ & + ' ==================================================') +951 FORMAT (/' Type',I2,' : ',A/ & + ' -----------------------------------------') +952 FORMAT ( ' From : ',A) +953 FORMAT ( ' To : ',A) +954 FORMAT ( ' Interval : ',A/) +955 FORMAT ( ' Fields : ',A) +956 FORMAT ( ' ',A) +957 FORMAT ( ' Point 1 : ',2E14.6,2X,A) +958 FORMAT ( ' ',I6,' : ',2E14.6,2X,A) +959 FORMAT ( ' No points defined') +960 FORMAT ( ' The file with ',A,' data is ',A,'.') +961 FORMAT ( ' IX fls : ',3I6/ & + ' IY fls : ',3I6) +962 FORMAT (/' Output request for model ',A,' (nr',I3,') '/ & + ' ==================================================') +963 FORMAT ( ' Output disabled') + ! +965 FORMAT (/' Grid movement data (!/MGP, !/MGW): '/ & + ' --------------------------------------------------') +966 FORMAT ( ' ',A) +967 FORMAT ( ' ',I6,2X,A) +968 FORMAT ( ' ',I6,I11.8,I7.6,2F8.2) + ! +970 FORMAT(//' Assigning resources : '/ & + ' --------------------------------------------------') +971 FORMAT ( ' ',A) +972 FORMAT ( ' Process ',I5.5,' reserved for all point output.') +973 FORMAT ( ' Processes ',I5.5,' through ',I5.5,' [',I3,']', & + ' reserved for output.') +974 FORMAT (/ & + 5X,' grid comp. grd pnt trk rst bpt prt'/ & + 5X,' ------------------------------------------------------', & + '-------------') +975 FORMAT (5X,' ',A10,2X,I5.5,'-',I5.5,6(2x,A5)) +976 FORMAT(5X,' -------------------------------------------------', & + '------------------') +977 FORMAT (5X,' Unified point output at ',I5.5) +1974 FORMAT (' Resource assignement (processes) : '/ & + ' grid comp. grd pnt trk rst bpt prt'/ & + ' ------------------------------------------------------', & + '-------------') +1975 FORMAT (' ',A10,2X,I5.5,'-',I5.5,6(2x,A5)) +1976 FORMAT (' ---------------------------------------------------', & + '----------------') +1977 FORMAT (' Unified point output at ',I5.5) + ! +980 FORMAT(//' Initializations :'/ & + ' --------------------------------------------------') +981 FORMAT ( ' Model number',I3,' [',A,']') +982 FORMAT ( ' Initializing wave model ...') +983 FORMAT ( ' Initializing model input ...') +984 FORMAT ( ' ',A,': file not needed') +985 FORMAT ( ' ',A,': file OK') +986 FORMAT ( ' Unified point output [',A,']') +987 FORMAT ( ' Initializing grids ...') +988 FORMAT ( ' Input data grid',I3,' [',A,']') + ! #ifdef W3_MPRF - 990 FORMAT (1X,3F12.3,' WMINITNML',1X,A) -#endif -! - 998 FORMAT ( ' Running the model :'/ & - ' --------------------------------------------------'/) - 999 FORMAT ( ' ========== END OF MWW3 INITIALIZATION (WMINITNML) ===', & - '============================'/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & - ' PREMATURE END OF POINT FILE'/) -! - 1104 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & - ' ERROR IN OPENING POINT FILE'/ & - ' IOSTAT =',I5/) -! - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & - ' ERROR IN READING FROM POINT FILE'/ & - ' IOSTAT =',I5/) - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & - ' ERROR IN OPENING LOG FILE'/ & - ' IOSTAT =',I5/) - 1011 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & - ' ERROR IN OPENING TEST FILE'/ & - ' IOSTAT =',I5/) - 1020 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & - ' ILLEGAL NUMBER OF GRIDS ( < 1 ) '/) - 1021 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & - ' ILLEGAL NUMBER OF INPUT GRIDS ( < 0 ) '/) - 1030 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & - ' INPUT GRID NAME NOT FOUND '/ & - ' WAVE GRID : ',A/ & - ' INPUT NAME : ',A/) - 1031 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & - ' REQUESTED INPUT TYPE NOT FOUND IN INPUT GRID '/ & - ' INPUT GRID : ',A/ & - ' INPUT TYPE : ',I8/) - 1032 FORMAT (/' *** WAVEWATCH III WARNING IN WMINITNML : *** '/ & - ' INPUT GRID ',A,' NOT USED '/) - 1040 FORMAT ( ' *** WAVEWATCH III WARNING IN W3MLTI : ***'/ & - ' POSSIBLE LOAD IMBALANCE GROUP',I3,' :',2I6/) -!1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & -! ' ILLEGAL TIME INTERVAL'/) - 1050 FORMAT (/' *** WAVEWATCH III WARNING IN W3MLTI : ***'/ & - ' UNIFIED POINT OUTPUT BUT NO OUTPUT'/ & - ' UNIFIED POINT OUTPUT DISABLED'/) - 1051 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & - ' ILLEGAL MODEL ID [',A,']'/) - 1052 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & - ' ILLEGAL OUTPUT TYPE',I10/) - 1053 FORMAT (/' *** WAVEWATCH III WARNING IN W3MLTI : ***'/ & +990 FORMAT (1X,3F12.3,' WMINITNML',1X,A) +#endif + ! +998 FORMAT ( ' Running the model :'/ & + ' --------------------------------------------------'/) +999 FORMAT ( ' ========== END OF MWW3 INITIALIZATION (WMINITNML) ===', & + '============================'/) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & + ' PREMATURE END OF POINT FILE'/) + ! +1104 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & + ' ERROR IN OPENING POINT FILE'/ & + ' IOSTAT =',I5/) + ! +1004 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & + ' ERROR IN READING FROM POINT FILE'/ & + ' IOSTAT =',I5/) +1010 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & + ' ERROR IN OPENING LOG FILE'/ & + ' IOSTAT =',I5/) +1011 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & + ' ERROR IN OPENING TEST FILE'/ & + ' IOSTAT =',I5/) +1020 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & + ' ILLEGAL NUMBER OF GRIDS ( < 1 ) '/) +1021 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & + ' ILLEGAL NUMBER OF INPUT GRIDS ( < 0 ) '/) +1030 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & + ' INPUT GRID NAME NOT FOUND '/ & + ' WAVE GRID : ',A/ & + ' INPUT NAME : ',A/) +1031 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : *** '/ & + ' REQUESTED INPUT TYPE NOT FOUND IN INPUT GRID '/ & + ' INPUT GRID : ',A/ & + ' INPUT TYPE : ',I8/) +1032 FORMAT (/' *** WAVEWATCH III WARNING IN WMINITNML : *** '/ & + ' INPUT GRID ',A,' NOT USED '/) +1040 FORMAT ( ' *** WAVEWATCH III WARNING IN W3MLTI : ***'/ & + ' POSSIBLE LOAD IMBALANCE GROUP',I3,' :',2I6/) + !1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ! ' ILLEGAL TIME INTERVAL'/) +1050 FORMAT (/' *** WAVEWATCH III WARNING IN W3MLTI : ***'/ & + ' UNIFIED POINT OUTPUT BUT NO OUTPUT'/ & + ' UNIFIED POINT OUTPUT DISABLED'/) +1051 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ' ILLEGAL MODEL ID [',A,']'/) +1052 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ' ILLEGAL OUTPUT TYPE',I10/) +1053 FORMAT (/' *** WAVEWATCH III WARNING IN W3MLTI : ***'/ & ' OUTPUT POINTS FOR INDIVIDUAL GRIDS CANNOT BE DEFINED'/ & - ' WHEN UNIFIED POINT OUTPUT IS REQUESTED'/) - 1054 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ' WHEN UNIFIED POINT OUTPUT IS REQUESTED'/) +1054 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & ' POINT OUTPUT ACTIVATED, BUT NO POINTS DEFINED'/) - 1055 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & +1055 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & ' POINT OUTPUT ACTIVATED, BUT NO FILE DEFINED'/) - 1060 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & - ' NO MOVING GRID DATA PRESENT'/) - 1061 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & - ' TOO MANY HOMOGENEOUS FIELDS : ',A,1X,I4/) - 1062 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & - ' HOMOGENEOUS NAME NOT RECOGNIZED : ', A/) - 1070 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : ***'/ & - ' ALL GRIDS ARE NOT USING THE SAME COORDINATE SYSTEM'/) - 1080 FORMAT (/' *** BOUNDARY DATA READ, WILL NOT DUMP, GRID :',I4, & - ' ***') - 1081 FORMAT (/' *** NO BOUNDARY DATA TO DUMP, GRID :',I4,' ***') - 1082 FORMAT ( ' No boundary data dump for grid',I3/) -! +1060 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ' NO MOVING GRID DATA PRESENT'/) +1061 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ' TOO MANY HOMOGENEOUS FIELDS : ',A,1X,I4/) +1062 FORMAT (/' *** WAVEWATCH III ERROR IN W3MLTI : ***'/ & + ' HOMOGENEOUS NAME NOT RECOGNIZED : ', A/) +1070 FORMAT (/' *** WAVEWATCH III ERROR IN WMINITNML : ***'/ & + ' ALL GRIDS ARE NOT USING THE SAME COORDINATE SYSTEM'/) +1080 FORMAT (/' *** BOUNDARY DATA READ, WILL NOT DUMP, GRID :',I4, & + ' ***') +1081 FORMAT (/' *** NO BOUNDARY DATA TO DUMP, GRID :',I4,' ***') +1082 FORMAT ( ' No boundary data dump for grid',I3/) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS : ',5I6/ & - ' INPUT FILE NAME : ',A) +9000 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS : ',5I6/ & + ' INPUT FILE NAME : ',A) #endif -! + ! #ifdef W3_T - 9020 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS FOR GRIDS (',A,')'/ & - 15X,'GRID MDS(1-13)',43X,'NTRACE') - 9021 FORMAT (14X,16I4) - 9022 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS FOR INTPUT FILES'/ & - 15X,'GRID MDSF(JFIRST-9)') - 9030 FORMAT ( ' TEST WMINITNML : FILE EXTENSIONS, INPUT FLAGS,', & - ' RANK AND GROUP, PROC RANGE') - 9031 FORMAT ( ' ',I3,1X,A,20L2,2I4,2F6.2) - 9032 FORMAT ( ' TEST WMINITNML : PROCESSED RANK NUMBERS') - 9033 FORMAT ( ' ',I3,1X,A,1X,I4) - 9034 FORMAT ( ' TEST WMINITNML : NUMBER OF GROUPS :',I4) - 9035 FORMAT ( ' TEST WMINITNML : SIZE OF GROUPS :',20I3) - 9036 FORMAT ( ' TEST WMINITNML : GROUP SIZE AND COMPONENTS :') - 9037 FORMAT ( ' ',2I3,':',20I3) -#endif -! +9020 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS FOR GRIDS (',A,')'/ & + 15X,'GRID MDS(1-13)',43X,'NTRACE') +9021 FORMAT (14X,16I4) +9022 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS FOR INTPUT FILES'/ & + 15X,'GRID MDSF(JFIRST-9)') +9030 FORMAT ( ' TEST WMINITNML : FILE EXTENSIONS, INPUT FLAGS,', & + ' RANK AND GROUP, PROC RANGE') +9031 FORMAT ( ' ',I3,1X,A,20L2,2I4,2F6.2) +9032 FORMAT ( ' TEST WMINITNML : PROCESSED RANK NUMBERS') +9033 FORMAT ( ' ',I3,1X,A,1X,I4) +9034 FORMAT ( ' TEST WMINITNML : NUMBER OF GROUPS :',I4) +9035 FORMAT ( ' TEST WMINITNML : SIZE OF GROUPS :',20I3) +9036 FORMAT ( ' TEST WMINITNML : GROUP SIZE AND COMPONENTS :') +9037 FORMAT ( ' ',2I3,':',20I3) +#endif + ! #ifdef W3_T - 9050 FORMAT ( ' TEST WMINITNML : GRID NUMBER',I3,' =================') - 9051 FORMAT ( ' TEST WMINITNML : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & - 5(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) - 9052 FORMAT ( ' TEST WMINITNML : FLGRD : ',5(5L2,1X)/24X,5(5L2,1X)) - 9053 FORMAT ( ' TEST WMINITNML : OUTFF : ',I9.8 & - 5(/24X,I9.8) ) -#endif -! +9050 FORMAT ( ' TEST WMINITNML : GRID NUMBER',I3,' =================') +9051 FORMAT ( ' TEST WMINITNML : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & + 5(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) +9052 FORMAT ( ' TEST WMINITNML : FLGRD : ',5(5L2,1X)/24X,5(5L2,1X)) +9053 FORMAT ( ' TEST WMINITNML : OUTFF : ',I9.8 & + 5(/24X,I9.8) ) +#endif + ! #ifdef W3_T - 9060 FORMAT ( ' TEST WMINITNML : GRID MOVEMENT DATA') - 9061 FORMAT ( ' ',I8.8,I7,1X,2F8.2) +9060 FORMAT ( ' TEST WMINITNML : GRID MOVEMENT DATA') +9061 FORMAT ( ' ',I8.8,I7,1X,2F8.2) #endif -! + ! #ifdef W3_T - 9070 FORMAT ( ' TEST WMINITNML : ALLPRC ') - 9071 FORMAT ( ' ',I3,' : ',250I3) - 8042 FORMAT ( ' TEST WMINITNML : MODMAP ') - 8043 FORMAT ( ' TEST WMINITNML : LOADMP ') - 8044 FORMAT ( ' ',I3,' : ',250I2) +9070 FORMAT ( ' TEST WMINITNML : ALLPRC ') +9071 FORMAT ( ' ',I3,' : ',250I3) +8042 FORMAT ( ' TEST WMINITNML : MODMAP ') +8043 FORMAT ( ' TEST WMINITNML : LOADMP ') +8044 FORMAT ( ' ',I3,' : ',250I2) #endif -! + ! #ifdef W3_T - 9080 FORMAT ( ' TEST WMINITNML : MODEL INITIALIZATION') - 9081 FORMAT ( ' MODEL AND TIME :',I4,I10.8,I8.6) - 9082 FORMAT ( ' STATUS AND TIMES :',I4,3(I10.8,I8.6)) - 9083 FORMAT ( ' TEST WMINITNML : IDINP AFTER INITIALIZATION :') - 9084 FORMAT ( ' ',I4,17(2X,A3)) -#endif -!/ -!/ End of WMINITNML ----------------------------------------------------- / -!/ - END SUBROUTINE WMINITNML +9080 FORMAT ( ' TEST WMINITNML : MODEL INITIALIZATION') +9081 FORMAT ( ' MODEL AND TIME :',I4,I10.8,I8.6) +9082 FORMAT ( ' STATUS AND TIMES :',I4,3(I10.8,I8.6)) +9083 FORMAT ( ' TEST WMINITNML : IDINP AFTER INITIALIZATION :') +9084 FORMAT ( ' ',I4,17(2X,A3)) +#endif + !/ + !/ End of WMINITNML ----------------------------------------------------- / + !/ + END SUBROUTINE WMINITNML -!/ -!/ End of module WMINITMD -------------------------------------------- / -!/ - END MODULE WMINITMD + !/ + !/ End of module WMINITMD -------------------------------------------- / + !/ +END MODULE WMINITMD diff --git a/model/src/wmiopomd.F90 b/model/src/wmiopomd.F90 index b319a22d2..071f7e051 100644 --- a/model/src/wmiopomd.F90 +++ b/model/src/wmiopomd.F90 @@ -1,8 +1,8 @@ !> @file !> @brief Contains module WMIOPOMD. -!> +!> !> @author H. L. Tolman @date 06-Jun-2012 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / @@ -12,1209 +12,1209 @@ !> !> @author H. L. Tolman @date 06-Jun-2012 !> - MODULE WMIOPOMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2012 | -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2006 : Origination. ( version 3.10 ) -!/ 01-May-2007 : Addd diagnostic output O7a/b. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 06-Mar-2012 : Using MPI_COMM_NULL in checks. ( version 4.07 ) -!/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Module for generating a single point output file for a multi- -! grid model implementation. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WMIOPP Subr Public Initialization routine. -! WMIOPO Subr Public Gather and write routine. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr W3GDATMD Point to model grid. -! W3SETW Subr W3WDATMD Point to model grid. -! W3SETA Subr W3ADATMD Point to model grid. -! W3SETO Subr W3ODATMD Point to model grid. -! W3DMO2 Subr Id. Dimention model grids output 2. -! WMSETM Subr WMMDATMD Point to model grid. -! W3MPIP Subr W3INITMD Model intiailization. -! W3IOPP Sunr W3IOPOMD Prepare point output for single model. -! W3IOPO Sunr Id. Point output for single model. -! W3CSPC Subr. W3CSPCMD Spectral grid conversion. -! STRACE Subr W3SERVMD Subroutine tracing. -! EXTCDE Subr Id. Program abort. -! MPI_SEND, MPI_RECV -! Subr. mpif.h Standard MPI library routines. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/SHRD Distributed memory model. -! !/MPI -! -! !O7a Disgnostic output to NMPSCR. -! !O7b -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/MPIT -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialization for unified point output. -!> -!> @details Find highest resolution grid for each point. -!> -!> @param[in] NPT Number of output points in input. -!> @param[in] XPT (longitude) coordinates of output points. -!> @param[in] YPT (latitude) coordinates of output points. -!> @param[in] PNAMES Names of output points. -!> -!> @author H. L. Tolman @date 01-Sep-2012 -!> - SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Sep-2012 ! -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2006 : Origination. ( version 3.10 ) -!/ 01-May-2007 : Addd diagnostic output O7a,b ( version 3.11 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 16-Mar-2012 : Using MPI_COMM_NULL in checks. ( version 4.07 ) -!/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) -!/ 01-Sep-2012 : Added tests for unstructured grid ( version 4.07 ) -!/ (M. Dutour Sikiric, IRB & Aron Roland, Z&P) -!/ -! 1. Purpose : -! -! Initialization for unified point output. -! -! 2. Method : -! -! Find highest resolution grid for each point. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NPT Int. I Number of output points in input. -! XPT R.A. I X (longitude) coordinates of output points. -! YPT R.A. I Id. Y. -! PNAMES C*40 I Names of output points. -! ---------------------------------------------------------------- -! Note: all are optional, and should be given on the first call -! only, will be taken from storage after that. -! NPT needs to be ginve always, but can be dummy after -! first call. -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr W3GDATMD Point to model grid. -! W3SETW Subr W3WDATMD Point to model grid. -! W3SETA Subr W3ADATMD Point to model grid. -! W3SETO Subr W3ODATMD Point to model grid. -! W3DMO2 Subr Id. Dimension model grids output 2. -! WMSETM Subr WMMDATMD Point to model grid. -! W3MPIP Subr W3INITMD Model intiailization. -! W3IOPP Sunr W3IOPOMD Point output for single model. -! STRACE Subr W3SERVMD Subroutine tracing. -! EXTCDE Subr Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINIT Subr. WMINITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - The algorithm used to decide if the pont is in the grid needs -! to be strictly consistent with W3IOPP. -! - MPI communication is set up separately from W3MPIO to assure -! that data are gathered in a single processor even if this -! procesor is not part of the communicator of the individual -! model. -! - In section 2.b the soring of the grids by rand is utilized. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Distributed memory model. -! !/MPI -! -! !O7a Disgnostic output to NMPSCR. -! !O7b -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3GSRUMD - USE W3GDATMD, ONLY: W3SETG - USE W3ADATMD, ONLY: W3SETA - USE W3WDATMD, ONLY: W3SETW - USE W3ODATMD, ONLY: W3SETO, W3DMO2 - USE WMMDATMD, ONLY: WMSETM +MODULE WMIOPOMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2012 | + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2006 : Origination. ( version 3.10 ) + !/ 01-May-2007 : Addd diagnostic output O7a/b. ( version 3.11 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 06-Mar-2012 : Using MPI_COMM_NULL in checks. ( version 4.07 ) + !/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Module for generating a single point output file for a multi- + ! grid model implementation. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WMIOPP Subr Public Initialization routine. + ! WMIOPO Subr Public Gather and write routine. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr W3GDATMD Point to model grid. + ! W3SETW Subr W3WDATMD Point to model grid. + ! W3SETA Subr W3ADATMD Point to model grid. + ! W3SETO Subr W3ODATMD Point to model grid. + ! W3DMO2 Subr Id. Dimention model grids output 2. + ! WMSETM Subr WMMDATMD Point to model grid. + ! W3MPIP Subr W3INITMD Model intiailization. + ! W3IOPP Sunr W3IOPOMD Prepare point output for single model. + ! W3IOPO Sunr Id. Point output for single model. + ! W3CSPC Subr. W3CSPCMD Spectral grid conversion. + ! STRACE Subr W3SERVMD Subroutine tracing. + ! EXTCDE Subr Id. Program abort. + ! MPI_SEND, MPI_RECV + ! Subr. mpif.h Standard MPI library routines. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/SHRD Distributed memory model. + ! !/MPI + ! + ! !O7a Disgnostic output to NMPSCR. + ! !O7b + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/MPIT + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialization for unified point output. + !> + !> @details Find highest resolution grid for each point. + !> + !> @param[in] NPT Number of output points in input. + !> @param[in] XPT (longitude) coordinates of output points. + !> @param[in] YPT (latitude) coordinates of output points. + !> @param[in] PNAMES Names of output points. + !> + !> @author H. L. Tolman @date 01-Sep-2012 + !> + SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Sep-2012 ! + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2006 : Origination. ( version 3.10 ) + !/ 01-May-2007 : Addd diagnostic output O7a,b ( version 3.11 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 16-Mar-2012 : Using MPI_COMM_NULL in checks. ( version 4.07 ) + !/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) + !/ 01-Sep-2012 : Added tests for unstructured grid ( version 4.07 ) + !/ (M. Dutour Sikiric, IRB & Aron Roland, Z&P) + !/ + ! 1. Purpose : + ! + ! Initialization for unified point output. + ! + ! 2. Method : + ! + ! Find highest resolution grid for each point. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NPT Int. I Number of output points in input. + ! XPT R.A. I X (longitude) coordinates of output points. + ! YPT R.A. I Id. Y. + ! PNAMES C*40 I Names of output points. + ! ---------------------------------------------------------------- + ! Note: all are optional, and should be given on the first call + ! only, will be taken from storage after that. + ! NPT needs to be ginve always, but can be dummy after + ! first call. + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr W3GDATMD Point to model grid. + ! W3SETW Subr W3WDATMD Point to model grid. + ! W3SETA Subr W3ADATMD Point to model grid. + ! W3SETO Subr W3ODATMD Point to model grid. + ! W3DMO2 Subr Id. Dimension model grids output 2. + ! WMSETM Subr WMMDATMD Point to model grid. + ! W3MPIP Subr W3INITMD Model intiailization. + ! W3IOPP Sunr W3IOPOMD Point output for single model. + ! STRACE Subr W3SERVMD Subroutine tracing. + ! EXTCDE Subr Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINIT Subr. WMINITMD Wave model initialization routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - The algorithm used to decide if the pont is in the grid needs + ! to be strictly consistent with W3IOPP. + ! - MPI communication is set up separately from W3MPIO to assure + ! that data are gathered in a single processor even if this + ! procesor is not part of the communicator of the individual + ! model. + ! - In section 2.b the soring of the grids by rand is utilized. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Distributed memory model. + ! !/MPI + ! + ! !O7a Disgnostic output to NMPSCR. + ! !O7b + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GSRUMD + USE W3GDATMD, ONLY: W3SETG + USE W3ADATMD, ONLY: W3SETA + USE W3WDATMD, ONLY: W3SETW + USE W3ODATMD, ONLY: W3SETO, W3DMO2 + USE WMMDATMD, ONLY: WMSETM #ifdef W3_MPI - USE W3INITMD, ONLY: W3MPIP + USE W3INITMD, ONLY: W3MPIP #endif - USE W3IOPOMD, ONLY: W3IOPP - USE W3SERVMD, ONLY: EXTCDE + USE W3IOPOMD, ONLY: W3IOPP + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NX, NY, X0, Y0, SX, MAPSTA, GRIDS, & - FLAGLL, ICLOSE, ICLOSE_NONE, GTYPE, UNGTYPE, & - CLGTYPE, GSU - USE W3GDATMD, ONLY: TRIGP, MAXX, MAXY, DXYMAX ! unstructured grids - USE W3ODATMD, ONLY: O2INIT, NOPTS, PTLOC, PTNME, GRDID, OUTPTS + USE W3SERVMD, ONLY: STRACE +#endif + ! + USE W3GDATMD, ONLY: NX, NY, X0, Y0, SX, MAPSTA, GRIDS, & + FLAGLL, ICLOSE, ICLOSE_NONE, GTYPE, UNGTYPE, & + CLGTYPE, GSU + USE W3GDATMD, ONLY: TRIGP, MAXX, MAXY, DXYMAX ! unstructured grids + USE W3ODATMD, ONLY: O2INIT, NOPTS, PTLOC, PTNME, GRDID, OUTPTS #ifdef W3_MPI - USE W3ODATMD, ONLY: O2IRQI + USE W3ODATMD, ONLY: O2IRQI #endif - USE WMMDATMD, ONLY: MDSE, MDST, NRGRD, MDATAS, IMPROC, NMPSCR, & - NMPERR, MDSS - USE W3TRIAMD + USE WMMDATMD, ONLY: MDSE, MDST, NRGRD, MDATAS, IMPROC, NMPSCR, & + NMPERR, MDSS + USE W3TRIAMD #ifdef W3_MPI - USE WMMDATMD, ONLY: MPI_COMM_GRD, MPI_COMM_MWAVE + USE WMMDATMD, ONLY: MPI_COMM_GRD, MPI_COMM_MWAVE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NPT - REAL, INTENT(IN), OPTIONAL :: XPT(NPT), YPT(NPT) - CHARACTER(LEN=40),INTENT(IN), OPTIONAL :: PNAMES(NPT) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IPT, J, II - INTEGER :: IX(4), IY(4) ! created by w3grmp - REAL :: RD(4) ! created by w3grmp - INTEGER :: itout, I1, I2, I3 ! unstructured grids + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NPT + REAL, INTENT(IN), OPTIONAL :: XPT(NPT), YPT(NPT) + CHARACTER(LEN=40),INTENT(IN), OPTIONAL :: PNAMES(NPT) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IPT, J, II + INTEGER :: IX(4), IY(4) ! created by w3grmp + REAL :: RD(4) ! created by w3grmp + INTEGER :: itout, I1, I2, I3 ! unstructured grids #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER :: IERR_MPI - REAL :: RX, RY, RDX, RDY - REAL, PARAMETER :: ACC = 0.05 - REAL, ALLOCATABLE :: XP(:), YP(:) - REAL :: FACTOR - LOGICAL, ALLOCATABLE :: INGRID(:,:) - LOGICAL, SAVE :: SETUP = .FALSE., FLGO7a = .FALSE. - CHARACTER(LEN=40), ALLOCATABLE :: PN(:) -!/ + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER :: IERR_MPI + REAL :: RX, RY, RDX, RDY + REAL, PARAMETER :: ACC = 0.05 + REAL, ALLOCATABLE :: XP(:), YP(:) + REAL :: FACTOR + LOGICAL, ALLOCATABLE :: INGRID(:,:) + LOGICAL, SAVE :: SETUP = .FALSE., FLGO7a = .FALSE. + CHARACTER(LEN=40), ALLOCATABLE :: PN(:) + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOPP') -#endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! - CALL W3SETO ( 0, MDSE, MDST ) -! + CALL STRACE (IENT, 'WMIOPP') +#endif + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! + CALL W3SETO ( 0, MDSE, MDST ) + ! #ifdef W3_T - WRITE (MDST,9000) O2INIT, NPT, PRESENT(XPT), & - PRESENT(YPT), PRESENT(PNAMES) + WRITE (MDST,9000) O2INIT, NPT, PRESENT(XPT), & + PRESENT(YPT), PRESENT(PNAMES) #endif #ifdef W3_O7a - FLGO7a = .TRUE. -#endif -! -! -------------------------------------------------------------------- / -! 1. Initialize if necessary and possible -! - IF ( .NOT. O2INIT ) THEN -! + FLGO7a = .TRUE. +#endif + ! + ! -------------------------------------------------------------------- / + ! 1. Initialize if necessary and possible + ! + IF ( .NOT. O2INIT ) THEN + ! #ifdef W3_T - WRITE (MDST,9010) -#endif -! - IF ( .NOT.PRESENT(XPT) .OR. .NOT.PRESENT(YPT) .OR. & - .NOT.PRESENT(PNAMES) ) THEN - WRITE (MDSE,1000) - CALL EXTCDE (1) - END IF -! - CALL W3DMO2 ( 0, MDSE, MDST, NPT ) -! - NOPTS = NPT - PTLOC(1,:) = XPT - PTLOC(2,:) = YPT - PTNME = PNAMES - GRDID = 'none' -! - END IF -! -! -------------------------------------------------------------------- / -! 2. Locate points in grids -! 2.a Check all points for all grids -! + WRITE (MDST,9010) +#endif + ! + IF ( .NOT.PRESENT(XPT) .OR. .NOT.PRESENT(YPT) .OR. & + .NOT.PRESENT(PNAMES) ) THEN + WRITE (MDSE,1000) + CALL EXTCDE (1) + END IF + ! + CALL W3DMO2 ( 0, MDSE, MDST, NPT ) + ! + NOPTS = NPT + PTLOC(1,:) = XPT + PTLOC(2,:) = YPT + PTNME = PNAMES + GRDID = 'none' + ! + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Locate points in grids + ! 2.a Check all points for all grids + ! #ifdef W3_T - WRITE (MDST,9020) -#endif -! - IF ( FLAGLL ) THEN - FACTOR = 1. + WRITE (MDST,9020) +#endif + ! + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + ! + ALLOCATE ( INGRID(NRGRD,NOPTS), XP(NOPTS), YP(NOPTS) ) + ! + INGRID = .FALSE. + XP = PTLOC(1,:) + YP = PTLOC(2,:) + ! + DO J=1, NRGRD + ! + CALL W3SETG ( J, MDSE, MDST ) + ! + ! Loop over output points + ! + ! notes.....Here, we have pulled coding for UNGTYPE and CLGTYPE from w3iopomd.ftn + ! ..........in w3iopomd.ftn, it is "DO IPT=1, NPT" but otherwise very similar + DO IPT=1, NOPTS + ! + ! Check if point within grid + ! + IF (GTYPE .NE. UNGTYPE) THEN + INGRID(J,IPT) = W3GRMP( GSU, XPT(IPT), YPT(IPT), IX, IY, RD ) + IF ( .NOT.INGRID(J,IPT) ) THEN + CYCLE + END IF ELSE - FACTOR = 1.E-3 + CALL IS_IN_UNGRID(J, DBLE(XPT(IPT)), DBLE(YPT(IPT)), itout, IX, IY, RD ) + IF (itout.eq.0) THEN + INGRID(J,IPT)=.FALSE. + END IF + END IF + ! + ! Check if point not on land + ! + IF ( MAPSTA(IY(1),IX(1)) .EQ. 0 .AND. & + MAPSTA(IY(2),IX(2)) .EQ. 0 .AND. & + MAPSTA(IY(3),IX(3)) .EQ. 0 .AND. & + MAPSTA(IY(4),IX(4)) .EQ. 0 ) THEN + INGRID(J,IPT) = .FALSE. + CYCLE END IF -! - ALLOCATE ( INGRID(NRGRD,NOPTS), XP(NOPTS), YP(NOPTS) ) -! - INGRID = .FALSE. - XP = PTLOC(1,:) - YP = PTLOC(2,:) -! - DO J=1, NRGRD -! - CALL W3SETG ( J, MDSE, MDST ) -! -! Loop over output points -! -! notes.....Here, we have pulled coding for UNGTYPE and CLGTYPE from w3iopomd.ftn -! ..........in w3iopomd.ftn, it is "DO IPT=1, NPT" but otherwise very similar - DO IPT=1, NOPTS -! -! Check if point within grid -! - IF (GTYPE .NE. UNGTYPE) THEN - INGRID(J,IPT) = W3GRMP( GSU, XPT(IPT), YPT(IPT), IX, IY, RD ) - IF ( .NOT.INGRID(J,IPT) ) THEN - CYCLE - END IF - ELSE - CALL IS_IN_UNGRID(J, DBLE(XPT(IPT)), DBLE(YPT(IPT)), itout, IX, IY, RD ) - IF (itout.eq.0) THEN - INGRID(J,IPT)=.FALSE. - END IF - END IF -! -! Check if point not on land -! - IF ( MAPSTA(IY(1),IX(1)) .EQ. 0 .AND. & - MAPSTA(IY(2),IX(2)) .EQ. 0 .AND. & - MAPSTA(IY(3),IX(3)) .EQ. 0 .AND. & - MAPSTA(IY(4),IX(4)) .EQ. 0 ) THEN - INGRID(J,IPT) = .FALSE. - CYCLE - END IF -!.........If we've gotten to this point, then we are satisfied that -!................the point is in this grid. + !.........If we've gotten to this point, then we are satisfied that + !................the point is in this grid. - END DO ! DO IPT=1, NOPTS -! - END DO ! DO J=1, NRGRD -! - DEALLOCATE ( XP, YP ) -! -! 2.b Select a grid for each point -! start from last, which is supposedly higher resolution -! - MDATAS(:)%NRUPTS = 0 -! + END DO ! DO IPT=1, NOPTS + ! + END DO ! DO J=1, NRGRD + ! + DEALLOCATE ( XP, YP ) + ! + ! 2.b Select a grid for each point + ! start from last, which is supposedly higher resolution + ! + MDATAS(:)%NRUPTS = 0 + ! + DO IPT=1, NOPTS + GRDID(IPT) = '...none...' + DO J= NRGRD, 1, -1 + IF ( INGRID(J,IPT) ) THEN + GRDID(IPT) = GRIDS(J)%FILEXT + MDATAS(J)%NRUPTS = MDATAS(J)%NRUPTS + 1 + EXIT + END IF + END DO + END DO + ! + ! 2.c Diagnostic output + ! +#ifdef W3_O7b + IF ( IMPROC .EQ. NMPSCR ) THEN + WRITE (MDSS,920) DO IPT=1, NOPTS - GRDID(IPT) = '...none...' - DO J= NRGRD, 1, -1 - IF ( INGRID(J,IPT) ) THEN - GRDID(IPT) = GRIDS(J)%FILEXT - MDATAS(J)%NRUPTS = MDATAS(J)%NRUPTS + 1 - EXIT - END IF - END DO + DO J=1, NRGRD + IF ( GRIDS(J)%FILEXT .EQ. GRDID(IPT) ) EXIT END DO -! -! 2.c Diagnostic output -! -#ifdef W3_O7b - IF ( IMPROC .EQ. NMPSCR ) THEN - WRITE (MDSS,920) - DO IPT=1, NOPTS - DO J=1, NRGRD - IF ( GRIDS(J)%FILEXT .EQ. GRDID(IPT) ) EXIT - END DO - IF ( J .GT. NRGRD ) THEN - WRITE (MDSS,921) PTNME(IPT), PTLOC(:,IPT)*FACTOR - ELSE - WRITE (MDSS,922) PTNME(IPT), PTLOC(:,IPT)*FACTOR, & - GRIDS(J)%FILEXT - END IF - END DO - WRITE (MDSS,929) + IF ( J .GT. NRGRD ) THEN + WRITE (MDSS,921) PTNME(IPT), PTLOC(:,IPT)*FACTOR + ELSE + WRITE (MDSS,922) PTNME(IPT), PTLOC(:,IPT)*FACTOR, & + GRIDS(J)%FILEXT END IF + END DO + WRITE (MDSS,929) + END IF #endif -! -! 2.d Test output -! + ! + ! 2.d Test output + ! #ifdef W3_T - DO IPT=1, NOPTS - WRITE (MDST,9021) IPT, PTNME(IPT), GRDID(IPT) - END DO + DO IPT=1, NOPTS + WRITE (MDST,9021) IPT, PTNME(IPT), GRDID(IPT) + END DO #endif -! + ! #ifdef W3_T - IPT = NOPTS - WRITE (MDST,9022) - DO J=1, NRGRD - WRITE (MDST,9023) J, MDATAS(J)%NRUPTS, GRIDS(J)%FILEXT - IPT = IPT - MDATAS(J)%NRUPTS - END DO - WRITE (MDST,9024) IPT -#endif -! - DEALLOCATE ( INGRID ) -! -! -------------------------------------------------------------------- / -! 3. Initialize individual grids -! 3.a Loop over grids -! - DO J=1, NRGRD -! + IPT = NOPTS + WRITE (MDST,9022) + DO J=1, NRGRD + WRITE (MDST,9023) J, MDATAS(J)%NRUPTS, GRIDS(J)%FILEXT + IPT = IPT - MDATAS(J)%NRUPTS + END DO + WRITE (MDST,9024) IPT +#endif + ! + DEALLOCATE ( INGRID ) + ! + ! -------------------------------------------------------------------- / + ! 3. Initialize individual grids + ! 3.a Loop over grids + ! + DO J=1, NRGRD + ! #ifdef W3_T - WRITE (MDST,9030) J -#endif -! -! 3.b (De)allocate map arrays -! - IPT = MAX ( 1 , MDATAS(J)%NRUPTS ) - IF ( SETUP ) DEALLOCATE ( MDATAS(J)%UPTMAP ) - ALLOCATE ( MDATAS(J)%UPTMAP(IPT) ) -! - IF ( MDATAS(J)%NRUPTS .EQ. 0 ) CYCLE -! - ALLOCATE ( XP(IPT), YP(IPT), PN(IPT) ) -! -! 3.c Set up mapping and point arrays -! - IPT = 0 - DO II=1, NOPTS - IF ( GRDID(II) .NE. GRIDS(J)%FILEXT ) CYCLE - IPT = IPT + 1 - MDATAS(J)%UPTMAP(IPT) = II - XP(IPT) = PTLOC(1,II) - YP(IPT) = PTLOC(2,II) - PN(IPT) = PTNME(II) - END DO -! + WRITE (MDST,9030) J +#endif + ! + ! 3.b (De)allocate map arrays + ! + IPT = MAX ( 1 , MDATAS(J)%NRUPTS ) + IF ( SETUP ) DEALLOCATE ( MDATAS(J)%UPTMAP ) + ALLOCATE ( MDATAS(J)%UPTMAP(IPT) ) + ! + IF ( MDATAS(J)%NRUPTS .EQ. 0 ) CYCLE + ! + ALLOCATE ( XP(IPT), YP(IPT), PN(IPT) ) + ! + ! 3.c Set up mapping and point arrays + ! + IPT = 0 + DO II=1, NOPTS + IF ( GRDID(II) .NE. GRIDS(J)%FILEXT ) CYCLE + IPT = IPT + 1 + MDATAS(J)%UPTMAP(IPT) = II + XP(IPT) = PTLOC(1,II) + YP(IPT) = PTLOC(2,II) + PN(IPT) = PTNME(II) + END DO + ! #ifdef W3_T - DO IPT=1, MDATAS(J)%NRUPTS - WRITE (MDST,9031) IPT, MDATAS(J)%UPTMAP(IPT),XP(IPT),YP(IPT),PN(IPT) - END DO + DO IPT=1, MDATAS(J)%NRUPTS + WRITE (MDST,9031) IPT, MDATAS(J)%UPTMAP(IPT),XP(IPT),YP(IPT),PN(IPT) + END DO #endif -! + ! #ifdef W3_MPI - IF ( FLGO7a ) CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) + IF ( FLGO7a ) CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) #endif #ifdef W3_O7a - IF ( IMPROC.EQ.NMPSCR ) WRITE (MDSS,930) & - J, GRIDS(J)%FILEXT, IPT + IF ( IMPROC.EQ.NMPSCR ) WRITE (MDSS,930) & + J, GRIDS(J)%FILEXT, IPT #endif -! -! 3.d Preprocessing for output -! + ! + ! 3.d Preprocessing for output + ! #ifdef W3_T - WRITE (MDST,9032) + WRITE (MDST,9032) #endif -! -! 3.d.1 Shared memory version -! + ! + ! 3.d.1 Shared memory version + ! #ifdef W3_SHRD - CALL W3SETO ( J, MDSE, MDST ) - CALL W3SETG ( J, MDSE, MDST ) + CALL W3SETO ( J, MDSE, MDST ) + CALL W3SETG ( J, MDSE, MDST ) #endif -! + ! #ifdef W3_SHRD - IF ( O2INIT ) THEN - DEALLOCATE ( OUTPTS(J)%OUT2%IPTINT, & - OUTPTS(J)%OUT2%IL , OUTPTS(J)%OUT2%IW , & - OUTPTS(J)%OUT2%II , OUTPTS(J)%OUT2%PTIFAC, & - OUTPTS(J)%OUT2%PTNME, OUTPTS(J)%OUT2%GRDID , & - OUTPTS(J)%OUT2%DPO , OUTPTS(J)%OUT2%WAO , & - OUTPTS(J)%OUT2%WDO , OUTPTS(J)%OUT2%ASO , & - OUTPTS(J)%OUT2%CAO , OUTPTS(J)%OUT2%CDO , & - OUTPTS(J)%OUT2%SPCO , OUTPTS(J)%OUT2%PTLOC ) - O2INIT = .FALSE. - END IF -#endif -! + IF ( O2INIT ) THEN + DEALLOCATE ( OUTPTS(J)%OUT2%IPTINT, & + OUTPTS(J)%OUT2%IL , OUTPTS(J)%OUT2%IW , & + OUTPTS(J)%OUT2%II , OUTPTS(J)%OUT2%PTIFAC, & + OUTPTS(J)%OUT2%PTNME, OUTPTS(J)%OUT2%GRDID , & + OUTPTS(J)%OUT2%DPO , OUTPTS(J)%OUT2%WAO , & + OUTPTS(J)%OUT2%WDO , OUTPTS(J)%OUT2%ASO , & + OUTPTS(J)%OUT2%CAO , OUTPTS(J)%OUT2%CDO , & + OUTPTS(J)%OUT2%SPCO , OUTPTS(J)%OUT2%PTLOC ) + O2INIT = .FALSE. + END IF +#endif + ! #ifdef W3_SHRD - CALL W3IOPP ( MDATAS(J)%NRUPTS, XP, YP, PN, J ) + CALL W3IOPP ( MDATAS(J)%NRUPTS, XP, YP, PN, J ) #endif -! -! 3.d.2 Distributed memory version -! + ! + ! 3.d.2 Distributed memory version + ! #ifdef W3_MPI - CALL WMSETM ( J, MDSE, MDST ) + CALL WMSETM ( J, MDSE, MDST ) #endif -! + ! #ifdef W3_MPI - IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN #endif -! + ! #ifdef W3_MPI - CALL W3SETO ( J, MDSE, MDST ) - CALL W3SETG ( J, MDSE, MDST ) - CALL W3SETA ( J, MDSE, MDST ) - CALL W3SETW ( J, MDSE, MDST ) + CALL W3SETO ( J, MDSE, MDST ) + CALL W3SETG ( J, MDSE, MDST ) + CALL W3SETA ( J, MDSE, MDST ) + CALL W3SETW ( J, MDSE, MDST ) #endif -! + ! #ifdef W3_MPI - IF ( O2INIT ) THEN - DEALLOCATE ( OUTPTS(J)%OUT2%IPTINT, & - OUTPTS(J)%OUT2%IL , OUTPTS(J)%OUT2%IW , & - OUTPTS(J)%OUT2%II , OUTPTS(J)%OUT2%PTIFAC, & - OUTPTS(J)%OUT2%PTNME, OUTPTS(J)%OUT2%GRDID , & - OUTPTS(J)%OUT2%DPO , OUTPTS(J)%OUT2%WAO , & - OUTPTS(J)%OUT2%WDO , OUTPTS(J)%OUT2%ASO , & - OUTPTS(J)%OUT2%CAO , OUTPTS(J)%OUT2%CDO , & - OUTPTS(J)%OUT2%SPCO , OUTPTS(J)%OUT2%PTLOC ) - O2INIT = .FALSE. - END IF -#endif -! + IF ( O2INIT ) THEN + DEALLOCATE ( OUTPTS(J)%OUT2%IPTINT, & + OUTPTS(J)%OUT2%IL , OUTPTS(J)%OUT2%IW , & + OUTPTS(J)%OUT2%II , OUTPTS(J)%OUT2%PTIFAC, & + OUTPTS(J)%OUT2%PTNME, OUTPTS(J)%OUT2%GRDID , & + OUTPTS(J)%OUT2%DPO , OUTPTS(J)%OUT2%WAO , & + OUTPTS(J)%OUT2%WDO , OUTPTS(J)%OUT2%ASO , & + OUTPTS(J)%OUT2%CAO , OUTPTS(J)%OUT2%CDO , & + OUTPTS(J)%OUT2%SPCO , OUTPTS(J)%OUT2%PTLOC ) + O2INIT = .FALSE. + END IF +#endif + ! #ifdef W3_MPI - CALL W3IOPP ( MDATAS(J)%NRUPTS, XP, YP, PN, J ) + CALL W3IOPP ( MDATAS(J)%NRUPTS, XP, YP, PN, J ) #endif -! + ! #ifdef W3_MPI - IF ( O2IRQI ) THEN - DEALLOCATE (OUTPTS(J)%OUT2%IRQPO1, & - OUTPTS(J)%OUT2%IRQPO2 ) - O2IRQI = .FALSE. - END IF + IF ( O2IRQI ) THEN + DEALLOCATE (OUTPTS(J)%OUT2%IRQPO1, & + OUTPTS(J)%OUT2%IRQPO2 ) + O2IRQI = .FALSE. + END IF #endif -! + ! #ifdef W3_MPI - CALL W3MPIP ( J ) + CALL W3MPIP ( J ) #endif -! + ! #ifdef W3_MPI - END IF + END IF #endif -! -! This barrier is needed to straighten out output. -! + ! + ! This barrier is needed to straighten out output. + ! #ifdef W3_O7a - IF ( IMPROC.EQ.NMPSCR ) WRITE (MDSS,939) -#endif -! -! 3.e Reset pointers and clean up -! - CALL W3SETO ( 0, MDSE, MDST ) - DEALLOCATE ( XP, YP, PN ) -! - END DO -! -#ifdef W3_MPI - IF ( FLGO7a ) CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) + IF ( IMPROC.EQ.NMPSCR ) WRITE (MDSS,939) #endif -! -! -------------------------------------------------------------------- / -! 4. Finalize -! - SETUP = .TRUE. -! - RETURN -! -! Formats -! + ! + ! 3.e Reset pointers and clean up + ! + CALL W3SETO ( 0, MDSE, MDST ) + DEALLOCATE ( XP, YP, PN ) + ! + END DO + ! +#ifdef W3_MPI + IF ( FLGO7a ) CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif + ! + ! -------------------------------------------------------------------- / + ! 4. Finalize + ! + SETUP = .TRUE. + ! + RETURN + ! + ! Formats + ! #ifdef W3_O7b - 920 FORMAT (/' Diagnostic test output for output points :'/ & - ' -------------------------------------------------') - 921 FORMAT ( ' ',A,' (',2F8.2,') NO GRID FOUND') - 922 FORMAT ( ' ',A,' (',2F8.2,') grid ',A) - 929 FORMAT ( ' ') +920 FORMAT (/' Diagnostic test output for output points :'/ & + ' -------------------------------------------------') +921 FORMAT ( ' ',A,' (',2F8.2,') NO GRID FOUND') +922 FORMAT ( ' ',A,' (',2F8.2,') grid ',A) +929 FORMAT ( ' ') #endif -! + ! #ifdef W3_O7a - 930 FORMAT (/' Grid ',I3,' [',A,']',I4,' points :'/ & - ' -------------------------------------------------') - 939 FORMAT ( ' ') -#endif -! - 1000 FORMAT (/' *** ERROR WMIOPP : INITALIZATION DATA NOT', & - ' AVAILABLE *** '/) -! +930 FORMAT (/' Grid ',I3,' [',A,']',I4,' points :'/ & + ' -------------------------------------------------') +939 FORMAT ( ' ') +#endif + ! +1000 FORMAT (/' *** ERROR WMIOPP : INITALIZATION DATA NOT', & + ' AVAILABLE *** '/) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMIOPP : O2INIT :',L2/ & - ' PAR LIST :',I4,3L2) +9000 FORMAT ( ' TEST WMIOPP : O2INIT :',L2/ & + ' PAR LIST :',I4,3L2) #endif -! + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMIOPP : INITIALIZING DATA GRID 0') +9010 FORMAT ( ' TEST WMIOPP : INITIALIZING DATA GRID 0') #endif -! + ! #ifdef W3_T - 9020 FORMAT ( ' TEST WMIOPP : FINDING POINTS IN GRID') - 9021 FORMAT ( ' ',I4,2X,A,2X,A) - 9022 FORMAT ( ' TEST WMIOPP : OUTPUT POINTS PER GRID') - 9023 FORMAT ( ' GRID',I3,' HAS',I4,' OUTPUT ', & - 'POINTS, NAME = ',A) - 9024 FORMAT ( ' UNALLOCATED POINTS :',I4) -#endif -! +9020 FORMAT ( ' TEST WMIOPP : FINDING POINTS IN GRID') +9021 FORMAT ( ' ',I4,2X,A,2X,A) +9022 FORMAT ( ' TEST WMIOPP : OUTPUT POINTS PER GRID') +9023 FORMAT ( ' GRID',I3,' HAS',I4,' OUTPUT ', & + 'POINTS, NAME = ',A) +9024 FORMAT ( ' UNALLOCATED POINTS :',I4) +#endif + ! #ifdef W3_T - 9030 FORMAT ( ' TEST WMIOPP : PREPPING GRID',I3) - 9031 FORMAT ( ' ',2I5,2E12.3,2X,A) - 9032 FORMAT ( ' TEST WMIOPP : RUNNING W3IOPP / W3MPIP') -#endif -!/ -!/ End of WMIOPP ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOPP -!/ ------------------------------------------------------------------- / -!> -!> @brief Gather and write unified point output. -!> -!> @details Per-grid point output is already gathered. All data are -!> gathered in the proper storage, and written using the standard -!> W3IOPO routint from grid number 0. -!> -!> @param[in] TOUT Time for output file. -!> -!> @author H. L. Tolman @date 16-Mar-2012 -!> - SUBROUTINE WMIOPO ( TOUT ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 16-Mar-2012 ! -!/ +-----------------------------------+ -!/ -!/ 09-Aug-2006 : Origination. ( version 3.10 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 16-Mar-2012 : Using MPI_COMM_NULL in checks. ( version 3.14 ) -!/ -! 1. Purpose : -! -! Gather and write unified point output. -! -! 2. Method : -! -! Per-grid point output is already gathered. All data are gathered -! in the porper storage, and writen using the standard W3IOPO -! routint from grid number 0. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! TOUT I.A. I Time for output file. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to model grid. -! W3SETW Subr. W3WDATMD Point to model grid. -! W3SETO Subr. W3ODATMD Point to model grid. -! WMSETM Subr. WMMDATMD Point to model grid. -! W3CSPC Subr. W3CSPCMD Spectral grid conversion. -! W3IOPO Subr. W3IOPOMD Point output for single model. -! STRACE Subr. W3SERVMD Subroutine tracing. -! MPI_SEND, MPI_RECV -! Subr. mpif.h Standard MPI library routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Prog. WMWAVEMD Multi-grid wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI Distributed memory model. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/MPIT -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! USE CONSTANTS -! - USE W3GDATMD, ONLY: W3SETG - USE W3WDATMD, ONLY: W3SETW - USE W3ODATMD, ONLY: W3SETO - USE WMMDATMD, ONLY: WMSETM - USE W3CSPCMD, ONLY: W3CSPC - USE W3IOPOMD, ONLY: W3IOPO -! - USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, FR1, TH, SGRDS - USE W3WDATMD, ONLY: TIME - USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPPNT, NOPTS, SPCO, DPO, & - WAO, WDO, ASO, CAO, CDO, OUTPTS, & - ICEO,ICEHO,ICEFO - USE WMMDATMD, ONLY: MDST, MDSE, IMPROC, NMPROC, NMPUPT, NRGRD, & - RESPEC, UPTMAP, MDSUP +9030 FORMAT ( ' TEST WMIOPP : PREPPING GRID',I3) +9031 FORMAT ( ' ',2I5,2E12.3,2X,A) +9032 FORMAT ( ' TEST WMIOPP : RUNNING W3IOPP / W3MPIP') +#endif + !/ + !/ End of WMIOPP ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOPP + !/ ------------------------------------------------------------------- / + !> + !> @brief Gather and write unified point output. + !> + !> @details Per-grid point output is already gathered. All data are + !> gathered in the proper storage, and written using the standard + !> W3IOPO routint from grid number 0. + !> + !> @param[in] TOUT Time for output file. + !> + !> @author H. L. Tolman @date 16-Mar-2012 + !> + SUBROUTINE WMIOPO ( TOUT ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 16-Mar-2012 ! + !/ +-----------------------------------+ + !/ + !/ 09-Aug-2006 : Origination. ( version 3.10 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 16-Mar-2012 : Using MPI_COMM_NULL in checks. ( version 3.14 ) + !/ + ! 1. Purpose : + ! + ! Gather and write unified point output. + ! + ! 2. Method : + ! + ! Per-grid point output is already gathered. All data are gathered + ! in the porper storage, and writen using the standard W3IOPO + ! routint from grid number 0. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! TOUT I.A. I Time for output file. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to model grid. + ! W3SETW Subr. W3WDATMD Point to model grid. + ! W3SETO Subr. W3ODATMD Point to model grid. + ! WMSETM Subr. WMMDATMD Point to model grid. + ! W3CSPC Subr. W3CSPCMD Spectral grid conversion. + ! W3IOPO Subr. W3IOPOMD Point output for single model. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! MPI_SEND, MPI_RECV + ! Subr. mpif.h Standard MPI library routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Prog. WMWAVEMD Multi-grid wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI Distributed memory model. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/MPIT + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! USE CONSTANTS + ! + USE W3GDATMD, ONLY: W3SETG + USE W3WDATMD, ONLY: W3SETW + USE W3ODATMD, ONLY: W3SETO + USE WMMDATMD, ONLY: WMSETM + USE W3CSPCMD, ONLY: W3CSPC + USE W3IOPOMD, ONLY: W3IOPO + ! + USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, FR1, TH, SGRDS + USE W3WDATMD, ONLY: TIME + USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPPNT, NOPTS, SPCO, DPO, & + WAO, WDO, ASO, CAO, CDO, OUTPTS, & + ICEO,ICEHO,ICEFO + USE WMMDATMD, ONLY: MDST, MDSE, IMPROC, NMPROC, NMPUPT, NRGRD, & + RESPEC, UPTMAP, MDSUP #ifdef W3_MPI - USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, ALLPRC, & - MTAG0 + USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, ALLPRC, & + MTAG0 #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: TOUT(2) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, I, II, IT0, IT, ITARG, IFROM + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: TOUT(2) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, I, II, IT0, IT, ITARG, IFROM #ifdef W3_SHRD - INTEGER :: MPI_COMM_GRD = 1, CROOT = 1 - INTEGER, PARAMETER :: MPI_COMM_NULL = -1 + INTEGER :: MPI_COMM_GRD = 1, CROOT = 1 + INTEGER, PARAMETER :: MPI_COMM_NULL = -1 #endif #ifdef W3_MPI - INTEGER :: IERR_MPI, NMPPNT - INTEGER, ALLOCATABLE :: STATUS(:,:) + INTEGER :: IERR_MPI, NMPPNT + INTEGER, ALLOCATABLE :: STATUS(:,:) #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL, POINTER :: SPEC(:,:) + REAL, POINTER :: SPEC(:,:) #ifdef W3_MPI - REAL, POINTER :: SPCR(:,:), DPR(:), WAR(:), & - WDR(:), ASR(:), CAR(:), CDR(:) - REAL, POINTER :: ICRO(:), ICRFO(:), ICRHO(:) + REAL, POINTER :: SPCR(:,:), DPR(:), WAR(:), & + WDR(:), ASR(:), CAR(:), CDR(:) + REAL, POINTER :: ICRO(:), ICRFO(:), ICRHO(:) #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMIOPO') + CALL STRACE (IENT, 'WMIOPO') #endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! #ifdef W3_T - WRITE (MDST,9000) NMPUPT, IMPROC -#endif -! - IF ( IMPROC .EQ. NMPUPT ) THEN - OUTPTS(0)%OUT2%SPCO = 0. - OUTPTS(0)%OUT2%DPO = 1. - OUTPTS(0)%OUT2%WAO = 0. - OUTPTS(0)%OUT2%WDO = 0. - OUTPTS(0)%OUT2%ASO = 0. - OUTPTS(0)%OUT2%CAO = 0. - OUTPTS(0)%OUT2%CDO = 0. - OUTPTS(0)%OUT2%ICEO = 0. - OUTPTS(0)%OUT2%ICEFO = 0. - OUTPTS(0)%OUT2%ICEHO = 0. - END IF -! -! -------------------------------------------------------------------- / -! 1. Loop over grids for processing local data -! - DO J=1, NRGRD -! -! 1.a Set up loop -! - CALL W3SETO ( J, MDSE, MDST ) - CALL W3SETG ( J, MDSE, MDST ) - CALL WMSETM ( J, MDSE, MDST ) -! + WRITE (MDST,9000) NMPUPT, IMPROC +#endif + ! + IF ( IMPROC .EQ. NMPUPT ) THEN + OUTPTS(0)%OUT2%SPCO = 0. + OUTPTS(0)%OUT2%DPO = 1. + OUTPTS(0)%OUT2%WAO = 0. + OUTPTS(0)%OUT2%WDO = 0. + OUTPTS(0)%OUT2%ASO = 0. + OUTPTS(0)%OUT2%CAO = 0. + OUTPTS(0)%OUT2%CDO = 0. + OUTPTS(0)%OUT2%ICEO = 0. + OUTPTS(0)%OUT2%ICEFO = 0. + OUTPTS(0)%OUT2%ICEHO = 0. + END IF + ! + ! -------------------------------------------------------------------- / + ! 1. Loop over grids for processing local data + ! + DO J=1, NRGRD + ! + ! 1.a Set up loop + ! + CALL W3SETO ( J, MDSE, MDST ) + CALL W3SETG ( J, MDSE, MDST ) + CALL WMSETM ( J, MDSE, MDST ) + ! #ifdef W3_T - WRITE (MDST,9010) J, NOPTS, IAPROC, NAPPNT + WRITE (MDST,9010) J, NOPTS, IAPROC, NAPPNT #endif -! -! 1.b Determine if action -! - IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) THEN + ! + ! 1.b Determine if action + ! + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) THEN #ifdef W3_T - WRITE (MDST,9011) + WRITE (MDST,9011) #endif - CYCLE - END IF -! - IF ( NOPTS .EQ. 0 ) THEN + CYCLE + END IF + ! + IF ( NOPTS .EQ. 0 ) THEN #ifdef W3_T - WRITE (MDST,9012) + WRITE (MDST,9012) #endif - CYCLE - END IF -! - IF ( IAPROC .NE. NAPPNT ) THEN + CYCLE + END IF + ! + IF ( IAPROC .NE. NAPPNT ) THEN #ifdef W3_T - WRITE (MDST,9014) + WRITE (MDST,9014) #endif - CYCLE - END IF -! -! 1.c Data here, and to remain on present processor. -! - IF ( IMPROC .EQ. NMPUPT ) THEN + CYCLE + END IF + ! + ! 1.c Data here, and to remain on present processor. + ! + IF ( IMPROC .EQ. NMPUPT ) THEN #ifdef W3_T - WRITE (MDST,9015) + WRITE (MDST,9015) #endif -! -! 1.c.1 Spectral conversion if needed -! - IF ( RESPEC(0,J) ) THEN + ! + ! 1.c.1 Spectral conversion if needed + ! + IF ( RESPEC(0,J) ) THEN #ifdef W3_T - WRITE (MDST,9016) 'YES' -#endif - ALLOCATE ( SPEC(SGRDS(0)%NSPEC,NOPTS) ) - CALL W3CSPC ( SPCO, NK, NTH, XFR, FR1, TH(1), SPEC, & - SGRDS(0)%NK, SGRDS(0)%NTH, SGRDS(0)%XFR, & - SGRDS(0)%FR1, SGRDS(0)%TH(1), NOPTS, MDST, MDSE, & - SGRDS(0)%FACHFE ) -! -! 1.c.2 Spectral conversion not needed -! - ELSE + WRITE (MDST,9016) 'YES' +#endif + ALLOCATE ( SPEC(SGRDS(0)%NSPEC,NOPTS) ) + CALL W3CSPC ( SPCO, NK, NTH, XFR, FR1, TH(1), SPEC, & + SGRDS(0)%NK, SGRDS(0)%NTH, SGRDS(0)%XFR, & + SGRDS(0)%FR1, SGRDS(0)%TH(1), NOPTS, MDST, MDSE, & + SGRDS(0)%FACHFE ) + ! + ! 1.c.2 Spectral conversion not needed + ! + ELSE #ifdef W3_T - WRITE (MDST,9016) 'NO' + WRITE (MDST,9016) 'NO' #endif - SPEC => SPCO - END IF -! -! 1.d Store data at grid 0 -! + SPEC => SPCO + END IF + ! + ! 1.d Store data at grid 0 + ! #ifdef W3_T - WRITE (MDST,9017) J -#endif -! - DO I=1, NOPTS - II = UPTMAP(I) - OUTPTS(0)%OUT2%SPCO(:,II) = SPEC(:,I) - OUTPTS(0)%OUT2%DPO(II) = DPO(I) - OUTPTS(0)%OUT2%WAO(II) = WAO(I) - OUTPTS(0)%OUT2%WDO(II) = WDO(I) - OUTPTS(0)%OUT2%ASO(II) = ASO(I) - OUTPTS(0)%OUT2%CAO(II) = CAO(I) - OUTPTS(0)%OUT2%CDO(II) = CDO(I) - OUTPTS(0)%OUT2%ICEO(II) = ICEO(I) - OUTPTS(0)%OUT2%ICEFO(II) = ICEFO(I) - OUTPTS(0)%OUT2%ICEHO(II) = ICEHO(I) - END DO -! - IF ( RESPEC(0,J) ) DEALLOCATE ( SPEC ) -! -! 1.e Data here, and to be sent to other processor. -! + WRITE (MDST,9017) J +#endif + ! + DO I=1, NOPTS + II = UPTMAP(I) + OUTPTS(0)%OUT2%SPCO(:,II) = SPEC(:,I) + OUTPTS(0)%OUT2%DPO(II) = DPO(I) + OUTPTS(0)%OUT2%WAO(II) = WAO(I) + OUTPTS(0)%OUT2%WDO(II) = WDO(I) + OUTPTS(0)%OUT2%ASO(II) = ASO(I) + OUTPTS(0)%OUT2%CAO(II) = CAO(I) + OUTPTS(0)%OUT2%CDO(II) = CDO(I) + OUTPTS(0)%OUT2%ICEO(II) = ICEO(I) + OUTPTS(0)%OUT2%ICEFO(II) = ICEFO(I) + OUTPTS(0)%OUT2%ICEHO(II) = ICEHO(I) + END DO + ! + IF ( RESPEC(0,J) ) DEALLOCATE ( SPEC ) + ! + ! 1.e Data here, and to be sent to other processor. + ! #ifdef W3_MPI - ELSE + ELSE #endif -! + ! #ifdef W3_MPIT - WRITE (MDST,9018) J, IMPROC, NMPUPT + WRITE (MDST,9018) J, IMPROC, NMPUPT #endif -! + ! #ifdef W3_MPI - IT0 = MTAG0 - 7*NRGRD - 1 - IT = IT0 + (J-1)*7 - ITARG = NMPUPT - 1 + IT0 = MTAG0 - 7*NRGRD - 1 + IT = IT0 + (J-1)*7 + ITARG = NMPUPT - 1 #endif -! + ! #ifdef W3_MPI - IT = IT + 1 - CALL MPI_SEND ( SPCO(1,1), NSPEC*NOPTS, MPI_REAL, & - ITARG, IT, MPI_COMM_MWAVE, IERR_MPI ) + IT = IT + 1 + CALL MPI_SEND ( SPCO(1,1), NSPEC*NOPTS, MPI_REAL, & + ITARG, IT, MPI_COMM_MWAVE, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'SPECTRA' + WRITE (MDST,9019) IT-IT0, 'SPECTRA' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_SEND ( DPO(1), NOPTS, MPI_REAL, ITARG, IT, & - MPI_COMM_MWAVE, IERR_MPI ) + IT = IT + 1 + CALL MPI_SEND ( DPO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'WATER DEPTHS' + WRITE (MDST,9019) IT-IT0, 'WATER DEPTHS' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_SEND ( WAO(1), NOPTS, MPI_REAL, ITARG, IT, & - MPI_COMM_MWAVE, IERR_MPI ) + IT = IT + 1 + CALL MPI_SEND ( WAO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'WIND SPEED' + WRITE (MDST,9019) IT-IT0, 'WIND SPEED' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_SEND ( WDO(1), NOPTS, MPI_REAL, ITARG, IT, & - MPI_COMM_MWAVE, IERR_MPI ) + IT = IT + 1 + CALL MPI_SEND ( WDO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'WIND DIRECTION' + WRITE (MDST,9019) IT-IT0, 'WIND DIRECTION' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_SEND ( ASO(1), NOPTS, MPI_REAL, ITARG, IT, & - MPI_COMM_MWAVE, IERR_MPI ) + IT = IT + 1 + CALL MPI_SEND ( ASO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'AIR_SEA TEMP DIFF' + WRITE (MDST,9019) IT-IT0, 'AIR_SEA TEMP DIFF' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_SEND ( CAO(1), NOPTS, MPI_REAL, ITARG, IT, & - MPI_COMM_MWAVE, IERR_MPI ) + IT = IT + 1 + CALL MPI_SEND ( CAO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'CURRENT VELOCITY' + WRITE (MDST,9019) IT-IT0, 'CURRENT VELOCITY' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_SEND ( CDO(1), NOPTS, MPI_REAL, ITARG, IT, & - MPI_COMM_MWAVE, IERR_MPI ) + IT = IT + 1 + CALL MPI_SEND ( CDO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'CURRENT DIRECTION' -#endif -!JDM: The below should be added for points using partitioned processors -! for multigrid, however I am unsure if the IT0 (7 to 10?) should be changed so -! this is being left here commented out for now. -! There is a corresponding section to this below -!!/MPI IT = IT + 1 -!!/MPI CALL MPI_SEND ( ICEO(1), NOPTS, MPI_REAL, ITARG, IT, & -!!/MPI MPI_COMM_MWAVE, IERR_MPI ) -!!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEO' -!!/MPI IT = IT + 1 -!!/MPI CALL MPI_SEND ( ICEFO(1), NOPTS, MPI_REAL, ITARG, IT, & -!!/MPI MPI_COMM_MWAVE, IERR_MPI ) -!!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEFO' -!!/MPI IT = IT + 1 -!!/MPI CALL MPI_SEND ( ICEHO(1), NOPTS, MPI_REAL, ITARG, IT, & -!!/MPI MPI_COMM_MWAVE, IERR_MPI ) -!!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEHO' -! - END IF -! - END DO -! -! -------------------------------------------------------------------- / -! 2. Check if this is output processor, otherwise exit -! - IF ( IMPROC .NE. NMPUPT ) THEN + WRITE (MDST,9019) IT-IT0, 'CURRENT DIRECTION' +#endif + !JDM: The below should be added for points using partitioned processors + ! for multigrid, however I am unsure if the IT0 (7 to 10?) should be changed so + ! this is being left here commented out for now. + ! There is a corresponding section to this below + !!/MPI IT = IT + 1 + !!/MPI CALL MPI_SEND ( ICEO(1), NOPTS, MPI_REAL, ITARG, IT, & + !!/MPI MPI_COMM_MWAVE, IERR_MPI ) + !!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEO' + !!/MPI IT = IT + 1 + !!/MPI CALL MPI_SEND ( ICEFO(1), NOPTS, MPI_REAL, ITARG, IT, & + !!/MPI MPI_COMM_MWAVE, IERR_MPI ) + !!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEFO' + !!/MPI IT = IT + 1 + !!/MPI CALL MPI_SEND ( ICEHO(1), NOPTS, MPI_REAL, ITARG, IT, & + !!/MPI MPI_COMM_MWAVE, IERR_MPI ) + !!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEHO' + ! + END IF + ! + END DO + ! + ! -------------------------------------------------------------------- / + ! 2. Check if this is output processor, otherwise exit + ! + IF ( IMPROC .NE. NMPUPT ) THEN #ifdef W3_T - WRITE (MDST,9020) -#endif - RETURN - END IF -! -! -------------------------------------------------------------------- / -! 3. Loop over grids for processing remote data -! + WRITE (MDST,9020) +#endif + RETURN + END IF + ! + ! -------------------------------------------------------------------- / + ! 3. Loop over grids for processing remote data + ! #ifdef W3_MPIT - WRITE (MDST,9030) + WRITE (MDST,9030) #endif -! -! 3.a Loop setup -! + ! + ! 3.a Loop setup + ! #ifdef W3_MPI - DO J=1, NRGRD + DO J=1, NRGRD #endif -! + ! #ifdef W3_MPI - CALL W3SETO ( J, MDSE, MDST ) - CALL W3SETG ( J, MDSE, MDST ) - CALL WMSETM ( J, MDSE, MDST ) + CALL W3SETO ( J, MDSE, MDST ) + CALL W3SETG ( J, MDSE, MDST ) + CALL WMSETM ( J, MDSE, MDST ) #endif -! + ! #ifdef W3_MPI - DO NMPPNT= NMPROC, 1, -1 - IF ( ALLPRC(NMPPNT,J) .EQ. NAPPNT ) EXIT - END DO + DO NMPPNT= NMPROC, 1, -1 + IF ( ALLPRC(NMPPNT,J) .EQ. NAPPNT ) EXIT + END DO #endif -! + ! #ifdef W3_MPIT - WRITE (MDST,9031) J, NOPTS, NMPPNT + WRITE (MDST,9031) J, NOPTS, NMPPNT #endif #ifdef W3_MPI - IF ( NMPPNT.EQ.NMPUPT .OR. NOPTS.EQ.0 ) THEN + IF ( NMPPNT.EQ.NMPUPT .OR. NOPTS.EQ.0 ) THEN #endif #ifdef W3_MPIT - WRITE (MDST,9032) + WRITE (MDST,9032) #endif #ifdef W3_MPI - CYCLE - END IF + CYCLE + END IF #endif -! -! 3.b Receive data -! + ! + ! 3.b Receive data + ! #ifdef W3_MPI - IT0 = MTAG0 - 7*NRGRD - 1 - IT = IT0 + (J-1)*7 - IFROM = NMPPNT - 1 - ALLOCATE ( SPCR(NSPEC,NOPTS), STATUS(MPI_STATUS_SIZE,1), & - DPR(NOPTS), WAR(NOPTS), WDR(NOPTS), ASR(NOPTS),& - CAR(NOPTS), CDR(NOPTS), ICRO(NOPTS), & - ICRFO(NOPTS), ICRHO(NOPTS) ) -#endif -! + IT0 = MTAG0 - 7*NRGRD - 1 + IT = IT0 + (J-1)*7 + IFROM = NMPPNT - 1 + ALLOCATE ( SPCR(NSPEC,NOPTS), STATUS(MPI_STATUS_SIZE,1), & + DPR(NOPTS), WAR(NOPTS), WDR(NOPTS), ASR(NOPTS),& + CAR(NOPTS), CDR(NOPTS), ICRO(NOPTS), & + ICRFO(NOPTS), ICRHO(NOPTS) ) +#endif + ! #ifdef W3_MPI - IT = IT + 1 - CALL MPI_RECV ( SPCR(1,1), NSPEC*NOPTS, MPI_REAL, IFROM, & - IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) + IT = IT + 1 + CALL MPI_RECV ( SPCR(1,1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'SPECTRA' + WRITE (MDST,9019) IT-IT0, 'SPECTRA' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_RECV ( DPR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & - IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) + IT = IT + 1 + CALL MPI_RECV ( DPR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'WATER DEPTHS' + WRITE (MDST,9019) IT-IT0, 'WATER DEPTHS' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_RECV ( WAR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & - IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) + IT = IT + 1 + CALL MPI_RECV ( WAR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'WIND SPEED' + WRITE (MDST,9019) IT-IT0, 'WIND SPEED' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_RECV ( WDR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & - IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) + IT = IT + 1 + CALL MPI_RECV ( WDR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'WIND DIRECTION' + WRITE (MDST,9019) IT-IT0, 'WIND DIRECTION' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_RECV ( ASR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & - IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) + IT = IT + 1 + CALL MPI_RECV ( ASR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'AIR_SEA TEMP DIFF' + WRITE (MDST,9019) IT-IT0, 'AIR_SEA TEMP DIFF' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_RECV ( CAR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & - IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) + IT = IT + 1 + CALL MPI_RECV ( CAR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'CURRENT VELOCITY' + WRITE (MDST,9019) IT-IT0, 'CURRENT VELOCITY' #endif #ifdef W3_MPI - IT = IT + 1 - CALL MPI_RECV ( CDR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & - IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) + IT = IT + 1 + CALL MPI_RECV ( CDR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) #endif #ifdef W3_MPIT - WRITE (MDST,9019) IT-IT0, 'CURRENT DIRECTION' -#endif -!JDM: The below should be added for points using partitioned processors -! for multigrid, however I am unsure if the IT0 (7 to 10?) should be changed so -! this is being left here commented out for now. -! There is a corresponding section to this above -!!/MPI IT = IT + 1 -!!/MPI CALL MPI_RECV ( ICRO(1), NSPEC*NOPTS, MPI_REAL, IFROM, & -!!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) -!!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEO' -!!/MPI IT = IT + 1 -!!/MPI CALL MPI_RECV (ICRFO(1), NSPEC*NOPTS, MPI_REAL, IFROM, & -!!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) -!!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEFO' -!!/MPI IT = IT + 1 -!!/MPI CALL MPI_SEND (ICRHO(1), NSPEC*NOPTS, MPI_REAL, IFROM, & -!!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) -!!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEHO' -! -! 3.c Convert if necessary -! + WRITE (MDST,9019) IT-IT0, 'CURRENT DIRECTION' +#endif + !JDM: The below should be added for points using partitioned processors + ! for multigrid, however I am unsure if the IT0 (7 to 10?) should be changed so + ! this is being left here commented out for now. + ! There is a corresponding section to this above + !!/MPI IT = IT + 1 + !!/MPI CALL MPI_RECV ( ICRO(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + !!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) + !!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEO' + !!/MPI IT = IT + 1 + !!/MPI CALL MPI_RECV (ICRFO(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + !!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) + !!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEFO' + !!/MPI IT = IT + 1 + !!/MPI CALL MPI_SEND (ICRHO(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + !!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) + !!/MPIT WRITE (MDST,9019) IT-IT0, 'ICEHO' + ! + ! 3.c Convert if necessary + ! #ifdef W3_MPI - IF ( RESPEC(0,J) ) THEN + IF ( RESPEC(0,J) ) THEN #endif #ifdef W3_MPIT - WRITE (MDST,9016) 'YES' + WRITE (MDST,9016) 'YES' #endif #ifdef W3_MPI - ALLOCATE ( SPEC(SGRDS(0)%NSPEC,NOPTS) ) - CALL W3CSPC ( SPCR, NK, NTH, XFR, FR1, TH(1), SPEC, & - SGRDS(0)%NK, SGRDS(0)%NTH, SGRDS(0)%XFR, & - SGRDS(0)%FR1, SGRDS(0)%TH(1), NOPTS, MDST, MDSE, & - SGRDS(0)%FACHFE ) - ELSE + ALLOCATE ( SPEC(SGRDS(0)%NSPEC,NOPTS) ) + CALL W3CSPC ( SPCR, NK, NTH, XFR, FR1, TH(1), SPEC, & + SGRDS(0)%NK, SGRDS(0)%NTH, SGRDS(0)%XFR, & + SGRDS(0)%FR1, SGRDS(0)%TH(1), NOPTS, MDST, MDSE, & + SGRDS(0)%FACHFE ) + ELSE #endif #ifdef W3_MPIT - WRITE (MDST,9016) 'NO' + WRITE (MDST,9016) 'NO' #endif #ifdef W3_MPI - SPEC => SPCR - END IF + SPEC => SPCR + END IF #endif -! -! 3.d Store data at grid 0 -! + ! + ! 3.d Store data at grid 0 + ! #ifdef W3_MPIT - WRITE (MDST,9117) J + WRITE (MDST,9117) J #endif -! + ! #ifdef W3_MPI - DO I=1, NOPTS - II = UPTMAP(I) - OUTPTS(0)%OUT2%SPCO(:,II) = SPEC(:,I) - OUTPTS(0)%OUT2%DPO(II) = DPR(I) - OUTPTS(0)%OUT2%WAO(II) = WAR(I) - OUTPTS(0)%OUT2%WDO(II) = WDR(I) - OUTPTS(0)%OUT2%ASO(II) = ASR(I) - OUTPTS(0)%OUT2%CAO(II) = CAR(I) - OUTPTS(0)%OUT2%CDO(II) = CDR(I) - OUTPTS(0)%OUT2%ICEO(II) = ICEO(I) - OUTPTS(0)%OUT2%ICEFO(II) = ICEFO(I) - OUTPTS(0)%OUT2%ICEHO(II) = ICEHO(I) - END DO -#endif -! + DO I=1, NOPTS + II = UPTMAP(I) + OUTPTS(0)%OUT2%SPCO(:,II) = SPEC(:,I) + OUTPTS(0)%OUT2%DPO(II) = DPR(I) + OUTPTS(0)%OUT2%WAO(II) = WAR(I) + OUTPTS(0)%OUT2%WDO(II) = WDR(I) + OUTPTS(0)%OUT2%ASO(II) = ASR(I) + OUTPTS(0)%OUT2%CAO(II) = CAR(I) + OUTPTS(0)%OUT2%CDO(II) = CDR(I) + OUTPTS(0)%OUT2%ICEO(II) = ICEO(I) + OUTPTS(0)%OUT2%ICEFO(II) = ICEFO(I) + OUTPTS(0)%OUT2%ICEHO(II) = ICEHO(I) + END DO +#endif + ! #ifdef W3_MPI - IF ( RESPEC(0,J) ) DEALLOCATE ( SPEC ) - DEALLOCATE ( SPCR, DPR, WAR, WDR, ASR, CAR, CDR, STATUS ) + IF ( RESPEC(0,J) ) DEALLOCATE ( SPEC ) + DEALLOCATE ( SPCR, DPR, WAR, WDR, ASR, CAR, CDR, STATUS ) #endif -! !JDM add deallocates here and check the itag stuff.. really not -! sure aabout that + ! !JDM add deallocates here and check the itag stuff.. really not + ! sure aabout that #ifdef W3_MPI - DEALLOCATE (ICRO, ICRFO, ICRHO) - END DO + DEALLOCATE (ICRO, ICRFO, ICRHO) + END DO #endif -! -! -------------------------------------------------------------------- / -! 4. Output data -! + ! + ! -------------------------------------------------------------------- / + ! 4. Output data + ! #ifdef W3_T - WRITE (MDST,9040) -#endif -! - CALL W3SETO ( 0, MDSE, MDST ) - CALL W3SETG ( 0, MDSE, MDST ) - CALL W3SETW ( 0, MDSE, MDST ) -! - TIME = TOUT -! - CALL W3IOPO ( 'WRITE', MDSUP, II, 0 ) -! - RETURN -! -! Formats -! + WRITE (MDST,9040) +#endif + ! + CALL W3SETO ( 0, MDSE, MDST ) + CALL W3SETG ( 0, MDSE, MDST ) + CALL W3SETW ( 0, MDSE, MDST ) + ! + TIME = TOUT + ! + CALL W3IOPO ( 'WRITE', MDSUP, II, 0 ) + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMIOPO : OUTPUT/ACTUAL PROCESS : ',2I6) - 9010 FORMAT ( ' TEST WMIOPO : PROCESSING GRID : ',I6/ & - ' OUTPUT POINTS : ',I6/ & - ' ACTUAL/OUTPUT PROCESS : ',2I6) - 9011 FORMAT ( ' CYCLE : GRID NOT ON PROCESS') - 9012 FORMAT ( ' CYCLE : GRID WITHOUT OUTPUT POINTS') - 9014 FORMAT ( ' CYCLE : DATA NOT ON PRESENT PROCESS') - 9015 FORMAT ( ' TEST WMIOPO : PROCESSING DATA LOCALLY') - 9016 FORMAT ( ' TEST WMIOPO : NEED FOR SPECTRAL CONVERSION : ',A) - 9017 FORMAT ( ' TEST WMIOPO : STORING DATA FROM GRID',I4, & - ' IN GRID 0') +9000 FORMAT ( ' TEST WMIOPO : OUTPUT/ACTUAL PROCESS : ',2I6) +9010 FORMAT ( ' TEST WMIOPO : PROCESSING GRID : ',I6/ & + ' OUTPUT POINTS : ',I6/ & + ' ACTUAL/OUTPUT PROCESS : ',2I6) +9011 FORMAT ( ' CYCLE : GRID NOT ON PROCESS') +9012 FORMAT ( ' CYCLE : GRID WITHOUT OUTPUT POINTS') +9014 FORMAT ( ' CYCLE : DATA NOT ON PRESENT PROCESS') +9015 FORMAT ( ' TEST WMIOPO : PROCESSING DATA LOCALLY') +9016 FORMAT ( ' TEST WMIOPO : NEED FOR SPECTRAL CONVERSION : ',A) +9017 FORMAT ( ' TEST WMIOPO : STORING DATA FROM GRID',I4, & + ' IN GRID 0') #endif #ifdef W3_MPIT - 9117 FORMAT ( ' TEST WMIOPO : STORING DATA FROM GRID',I4, & - ' IN GRID 0') - 9018 FORMAT ( ' TEST WMIOPO : GRID',I4,' SEND FROM',I4,' TO',I4) - 9019 FORMAT ( ' IT = ',I4,' PAR = ',A) +9117 FORMAT ( ' TEST WMIOPO : STORING DATA FROM GRID',I4, & + ' IN GRID 0') +9018 FORMAT ( ' TEST WMIOPO : GRID',I4,' SEND FROM',I4,' TO',I4) +9019 FORMAT ( ' IT = ',I4,' PAR = ',A) #endif -! + ! #ifdef W3_T - 9020 FORMAT ( ' TEST WMIOPO : DONE AT THIS PROCESSOR') +9020 FORMAT ( ' TEST WMIOPO : DONE AT THIS PROCESSOR') #endif -! + ! #ifdef W3_MPIT - 9030 FORMAT ( ' TEST WMIOPO : LOOP OVER GRIDS FOR REMOTE DATA') - 9031 FORMAT ( ' TEST WMIOPO : GRID',I4,',',I4,' POINTS FROM',I4) - 9032 FORMAT ( ' NOTHING TO RECEIVE') -#endif -! - 9040 FORMAT ( ' TEST WMIOPO : PERFORM OUTPUT') -!/ -!/ End of WMIOPO ----------------------------------------------------- / -!/ - END SUBROUTINE WMIOPO -!/ -!/ End of module WMIOPOMD -------------------------------------------- / -!/ - END MODULE WMIOPOMD +9030 FORMAT ( ' TEST WMIOPO : LOOP OVER GRIDS FOR REMOTE DATA') +9031 FORMAT ( ' TEST WMIOPO : GRID',I4,',',I4,' POINTS FROM',I4) +9032 FORMAT ( ' NOTHING TO RECEIVE') +#endif + ! +9040 FORMAT ( ' TEST WMIOPO : PERFORM OUTPUT') + !/ + !/ End of WMIOPO ----------------------------------------------------- / + !/ + END SUBROUTINE WMIOPO + !/ + !/ End of module WMIOPOMD -------------------------------------------- / + !/ +END MODULE WMIOPOMD diff --git a/model/src/wmmdatmd.F90 b/model/src/wmmdatmd.F90 index ba219cb0b..26daa8f78 100644 --- a/model/src/wmmdatmd.F90 +++ b/model/src/wmmdatmd.F90 @@ -1,8 +1,8 @@ !> @file !> @brief Contains module WMMDATMD. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 -!> +!> #include "w3macros.h" ! @@ -10,1400 +10,1400 @@ !> !> @brief Define data structures to set up wave model dynamic data for !> several models simultaneously. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 !> - MODULE WMMDATMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 13-Jun-2005 : Origination. ( version 3.07 ) -!/ 16-Dec-2005 : Add staging of boundary data. ( version 3.08 ) -!/ Add HGSTGE data. ( version 3.08 ) -!/ 27-Jan-2006 : Adding static nests. ( version 3.08 ) -!/ 24-Mar-2006 : Add EQSTGE data. ( version 3.09 ) -!/ 25-May-2006 : Add STIME in BPSTGE. ( version 3.09 ) -!/ 29-May-2006 : Adding overlapping grids. ( version 3.09 ) -!/ Fixing boundary data (buffering). -!/ 18-Jul-2006 : Adding input grids. ( version 3.09 ) -!/ 09-Aug-2006 : Adding unified point output. ( version 3.10 ) -!/ 06-Oct-2006 : Adding separate input grids. ( version 3.10 ) -!/ 12-Jan-2007 : Add FLSTI and FLLSTL. ( version 3.10 ) -!/ 22-Jan-2007 : Add NAVMAX. ( version 3.10 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 03-Sep-2012 : Add clock parameters (init.). ( version 4.10 ) -!/ 04-Feb-2014 : Switched to DATE_AND_TIME param. ( version 4.18 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 28-Sep-2016 : Adjust MTAG? values so that MPI tags used fit -!/ within allowed bounds. ( version 5.15 ) -!/ 06-Jun-2018 : add subroutine INIT_GET_JSEA_ISPROC_GLOB/add PDLIB -!/ ( version 6.04 ) -!/ 22-Mar-2021 : Support for air density input ( version 7.13 ) -!/ 28-Oct-2021 : Add SMC grid group indicator. JGLi ( version 7.13 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Define data structures to set up wave model dynamic data for -! several models simultaneously. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NMDATA Int. Public Number of models in array dim. -! IMDATA Int. Public Selected model for output, init. at -1. -! -! MDSI Int. Public Unit number for input file. -! MDSO Int. Public Unit number for output (log file). -! MDSS Int. Public Unit number for output (screen). -! MDST Int. Public Unit number for test output. -! MDSE Int. Public Unit number for error output. -! These outputs correspond to similar -! unit numbers as defined per grid, but -! are used for multi-grid routines -! only. -! MDSP Int. Public Unit number for profiling. -! MDSUP Int. Public Unit number for unified point output. -! MDSF I.A. Public Unit numbers for input files. -! -! NMPROC Int. Public Number of processors (for total multi- -! grid model). -! IMPROC Int. Public Corresponding actual processor number. -! NMPLOG, NMPSCR, NMPTST, NMPERR, NMPUPT -! Int. Public Processors in NMPROC designated for -! the above output units numbers. -! -! STIME I.A. Public Model run starting time. -! ETIME I.A. Public Model run ending time. -! TSYNC I.A. Public Synchronization time for grids. -! TMAX I.A. Public Maximum next time per grid. -! TOUTP I.A. Public Next output time for grids. -! TDATA I.A. Public Time for which data is available. -! -! NRGRD Int. Public Number of grids. -! NRINP Int. Public Number of input grids. -! NRGRP Int. Public Number of groups. -! NGRPSMC Int. Public SMC grid group number, one of 0:NRGRP. -! NMVMAX Int. Public Number of moving grid data. -! GRANK I.A. Public Rank number for grid. -! GRGRP I.A. Public Group number for grid. -! INGRP I.A. Public Grids in group, element 0 is number. -! GRDHGH, GRDEQL, GRDLOW -! I.A. Public Dependent grids with higher, same or -! lower rank number, element 0 is number. -! ALLPRC I.A. Public Map of processors in MPI_COMM_MWAVE for -! all individual grids. -! MODMAP I.A. Public Map which model is running where in -! MPI_COMM_MWAVE each group. -! GRSTAT I.A. Public Grid computation status indicator. -! DTRES R.A. Public Residual of time step. -! NBI2G I.A. Public Map cross-referencing how many spectra -! echo grid provides to boundary cond. for -! other grids. -! RESPEC L.A. Public Map for need to convert spectra between -! grids. -! BCDUMP L.A. Public Flag for dumping internal bound. data. -! INPMAP I.A. Public Map for expternal input grids. -! IDINP C.A. Public Input field identifiers. -! -! CLKDT1, CLKDT2, CLKDT3, CLKFIN -! Int. Public Global wall clock parameters, -! -! MPI_COMM_MWAVE -! Int. Public MPI communicator. ( !/MPI ) -! MTAGn Int. Public "Zero" tag number for MPI ( !/MPI ) -! MTAG_UB Int. Public Upper-bound for MPI tags ( !/MPI ) -! NBISTA I.A. Public Status for gathering input boundary -! data. ( !/MPI ) -! HGHSTA I.A. Public Status for gathering high resolution -! data. ( !/MPI ) -! EQLSTA I.A. Public Status for gathering data fro equally -! ranked grids. ( !/MPI ) -! -! FLGBDI Log. Public Flag for intitialization of boundry -! distance maps. -! FLGHGn Log. Public Flags for using mask for computations -! and output for areas of grid overlap. -! IFLSTI L.A. Public FLags for last ice per grid. -! IFLSTL L.A. Public FLags for last level per grid. -! IFLSTR L.A. Public FLags for last air density per grid. -! -! MDATA TYPE Public Data structure for grid dependent data. -! MDATAS MDATA Public Array of data structures. -! -! BPST TYPE Public Data structure for staging boundary -! data. -! BPSTGE BPST Public Array of data structures. -! -! HGST TYPE Public Data structure for staging 2-way -! nesting data. -! HGSTGE HGST Public Array of data structures. -! -! EQST TYPE Public Data structure for staging equal grid -! reconcilliation data. -! EQSTGE EQST Public Array of data structures. -! ---------------------------------------------------------------- -! -! All elements of MDATA are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NBI2S I.A. Public Source information of boundary input -! data (grid number and sea counter). -! MAPBDI R.A. Public Map with distances to boundary. -! MAPODI R.A. Public idem, open edges of grids. -! NRUPTS Int. Public Number of unified output points. -! UPTMAP I.A. Public Mapping of unified points to grids. -! MAPMSK I.A. Public Mask corresponding to FLGHGn above. -! MINIT, MSKINI, FLDATn -! Log. Public Flags for array initializations. -! FLLSTI Log. Public FLag for last ice per grid. -! FLLSTL Log. Public FLag for last level per grid. -! FLLSTR Log. Public FLag for last air density per grid. -! -! NMV Int. Public Number of moving grid data. -! TMV I.A. Public Moving grid times. -! AMV R.A. Public Moving grid velocities. -! DMV R.A. Public Moving grid directions. -! -! RCLD I.A. Public Record length for data assimilation. -! NDT I.A. Public Number of data for data assimilation. -! DATAn R.A. Public Assimilation data. -! -! MPI_COMM_GRD Int. Public Communicator for grid ( !/MPI ) -! MPI_COMM_BCT Int. Public Communicator for broadcast ( !/MPI ) -! CROOT Int. Public "root" for MPI_COMM_GRD in -! MPI_COMM_MWAVE ( !/MPI ) -! FBCAST Log. Public FLag for need of broadcasting data -! to processors that are not in the -! communicator ( !/MPI ) -! NRQBPG Int. Public Number of request handles ( !/MPI ) -! IRQBPG I.A. Public Request handles. ( !/MPI ) -! NRQHGG Int. Public Number of request handles ( !/MPI ) -! IRQHGG I.A. Public Request handles. ( !/MPI ) -! NRQEQG Int. Public Number of request handles ( !/MPI ) -! IRQEQG I.A. Public Request handles. ( !/MPI ) -! ---------------------------------------------------------------- -! -! Elements of the structure BPTS are -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NRQBPS Int. Public Number of request handles ( !/MPI ) -! IRQBPS I.A. Public Request handles. ( !/MPI ) -! VTIME I.A. Public Valid time of data. -! STIME I.A. Public Buffer for time for sending. ( !/MPI ) -! SBPI R.A. Public Spectral data storage. -! TSTORE R.A. Public Spectral data buffer. ( !/MPI ) -! INIT Log. Public Flag for array allocation. -! ---------------------------------------------------------------- -! -! Elements of the structure HGST are -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NRQHGS Int. Public Number of request handles ( !/MPI ) -! IRQHGS I.A. Public Request handles. ( !/MPI ) -! NRQOUT Int. Public Number of local spectra. ( !/MPI ) -! OUTDAT I.A. Public Corresponding data. ( !/MPI ) -! NTOT, NREC, NRC1, NSND, NSN1, NSMX -! Int. Public Counters for total data, send and -! received data with and without -! masking. -! VTIME I.A. Public Valid time of data. -! LJSEA I.A. Public Local sea point counters. -! NRAVG I.A. Public Number of points in averaging. -! IMPSRC I.A. Public Source processor for data, -! ITAG I.A. Public Communication tag. -! ISEND I.A. Public Composite of all deta needed for send. -! WGHT R.A. Public Weihts in averaging. -! SHGH R.A. Public Staging area for spectra. -! TSTORE R.A. Public Staging area for spectra to be send -! out ( !/MPI ) -! INIT Log. Public Flag for array allocation. -! ---------------------------------------------------------------- -! -! Elements of the structure EQST are -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NRQEQS Int. Public Number of request handles ( !/MPI ) -! IRQEQS I.A. Public Request handles. ( !/MPI ) -! NRQOUT Int. Public Number of local spectra. ( !/MPI ) -! OUTDAT I.A. Public Corresponding data. ( !/MPI ) -! NTOT, NREC, NSND, NAVMAX -! Int. Public Counters for total data, send and -! received data. -! VTIME I.A. Public Valid time of data. -! I/JSEA I.A. Public Sea point counters. -! NAVG I.A. Public Number of spectra in averaging. -! RIP I.A. Public Processor (receiving). -! RTG I.A. Public Tag number (receiving). -! SIS,SJS I.A. Public Sea point counter (sending). -! SI1/2 I.A. Public Storage array counters (sending). -! SIP I.A. Public Processor (sending). -! STG I.A. Public Tag (sending). -! SEQL R.A. Public Staging array. -! WGHT R.A. Public Weight between grids. -! WAVG R.A. Public Weight within grid. -! TSTORE R.A. Public Staging area for spectra to be send -! out ( !/MPI ) -! INIT Log. Public Flag for array allocation. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WMNDAT Subr. Public Set number of grids/models. -! WMDIMD Subr. Public Set dimensions of arrays (data). -! WMDIMM Subr. Public Set dimensions of arrays. -! WMSETM Subr. Public Point to selected grid / model. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to proper model grid. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - The number of grids is taken from W3GDATMD, and needs to be -! set first with W3DIMG. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ Specify default accessibility -!/ - PUBLIC -!/ -!/ Module private variable for checking error returns -!/ - INTEGER, PRIVATE :: ISTAT !< ISTAT check error returns -!/ -!/ Conventional declarations -!/ - INTEGER :: NMDATA = -1 !< NMDATA - INTEGER :: IMDATA = -1 !< IMDATA - INTEGER :: MDSI = 8 !< MDSI - INTEGER :: MDSO = 9 !< MDSO - INTEGER :: MDSS = 6 !< MDSS - INTEGER :: MDST = 6 !< MDST - INTEGER :: MDSE = 6 !< MDSE - INTEGER :: MDSUP !< MDSUP - INTEGER :: NMPROC = 1 !< NMPROC - INTEGER :: IMPROC = 1 !< IMPROC - INTEGER :: NMPLOG = 1 !< NMPLOG - INTEGER :: NMPSCR = 1 !< NMPSCR - INTEGER :: NMPTST = 1 !< NMPTST - INTEGER :: NMPERR = 1 !< NMPERR - INTEGER :: NMPUPT = 1 !< NMPUPT - INTEGER :: STIME(2) !< STIME - INTEGER :: ETIME(2) !< ETIME - INTEGER :: NRGRD !< NRGRD - INTEGER :: NRINP !< NRINP - INTEGER :: NRGRP !< NRGRP - INTEGER :: NMVMAX !< NMVMAX - INTEGER :: NGRPSMC !< NGRPSMC - - INTEGER :: CLKDT1(8) !< CLKDT1 - INTEGER :: CLKDT2(8) !< CLKDT2 - INTEGER :: CLKDT3(8) !< CLKDT3 - +MODULE WMMDATMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 13-Jun-2005 : Origination. ( version 3.07 ) + !/ 16-Dec-2005 : Add staging of boundary data. ( version 3.08 ) + !/ Add HGSTGE data. ( version 3.08 ) + !/ 27-Jan-2006 : Adding static nests. ( version 3.08 ) + !/ 24-Mar-2006 : Add EQSTGE data. ( version 3.09 ) + !/ 25-May-2006 : Add STIME in BPSTGE. ( version 3.09 ) + !/ 29-May-2006 : Adding overlapping grids. ( version 3.09 ) + !/ Fixing boundary data (buffering). + !/ 18-Jul-2006 : Adding input grids. ( version 3.09 ) + !/ 09-Aug-2006 : Adding unified point output. ( version 3.10 ) + !/ 06-Oct-2006 : Adding separate input grids. ( version 3.10 ) + !/ 12-Jan-2007 : Add FLSTI and FLLSTL. ( version 3.10 ) + !/ 22-Jan-2007 : Add NAVMAX. ( version 3.10 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 03-Sep-2012 : Add clock parameters (init.). ( version 4.10 ) + !/ 04-Feb-2014 : Switched to DATE_AND_TIME param. ( version 4.18 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 28-Sep-2016 : Adjust MTAG? values so that MPI tags used fit + !/ within allowed bounds. ( version 5.15 ) + !/ 06-Jun-2018 : add subroutine INIT_GET_JSEA_ISPROC_GLOB/add PDLIB + !/ ( version 6.04 ) + !/ 22-Mar-2021 : Support for air density input ( version 7.13 ) + !/ 28-Oct-2021 : Add SMC grid group indicator. JGLi ( version 7.13 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Define data structures to set up wave model dynamic data for + ! several models simultaneously. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NMDATA Int. Public Number of models in array dim. + ! IMDATA Int. Public Selected model for output, init. at -1. + ! + ! MDSI Int. Public Unit number for input file. + ! MDSO Int. Public Unit number for output (log file). + ! MDSS Int. Public Unit number for output (screen). + ! MDST Int. Public Unit number for test output. + ! MDSE Int. Public Unit number for error output. + ! These outputs correspond to similar + ! unit numbers as defined per grid, but + ! are used for multi-grid routines + ! only. + ! MDSP Int. Public Unit number for profiling. + ! MDSUP Int. Public Unit number for unified point output. + ! MDSF I.A. Public Unit numbers for input files. + ! + ! NMPROC Int. Public Number of processors (for total multi- + ! grid model). + ! IMPROC Int. Public Corresponding actual processor number. + ! NMPLOG, NMPSCR, NMPTST, NMPERR, NMPUPT + ! Int. Public Processors in NMPROC designated for + ! the above output units numbers. + ! + ! STIME I.A. Public Model run starting time. + ! ETIME I.A. Public Model run ending time. + ! TSYNC I.A. Public Synchronization time for grids. + ! TMAX I.A. Public Maximum next time per grid. + ! TOUTP I.A. Public Next output time for grids. + ! TDATA I.A. Public Time for which data is available. + ! + ! NRGRD Int. Public Number of grids. + ! NRINP Int. Public Number of input grids. + ! NRGRP Int. Public Number of groups. + ! NGRPSMC Int. Public SMC grid group number, one of 0:NRGRP. + ! NMVMAX Int. Public Number of moving grid data. + ! GRANK I.A. Public Rank number for grid. + ! GRGRP I.A. Public Group number for grid. + ! INGRP I.A. Public Grids in group, element 0 is number. + ! GRDHGH, GRDEQL, GRDLOW + ! I.A. Public Dependent grids with higher, same or + ! lower rank number, element 0 is number. + ! ALLPRC I.A. Public Map of processors in MPI_COMM_MWAVE for + ! all individual grids. + ! MODMAP I.A. Public Map which model is running where in + ! MPI_COMM_MWAVE each group. + ! GRSTAT I.A. Public Grid computation status indicator. + ! DTRES R.A. Public Residual of time step. + ! NBI2G I.A. Public Map cross-referencing how many spectra + ! echo grid provides to boundary cond. for + ! other grids. + ! RESPEC L.A. Public Map for need to convert spectra between + ! grids. + ! BCDUMP L.A. Public Flag for dumping internal bound. data. + ! INPMAP I.A. Public Map for expternal input grids. + ! IDINP C.A. Public Input field identifiers. + ! + ! CLKDT1, CLKDT2, CLKDT3, CLKFIN + ! Int. Public Global wall clock parameters, + ! + ! MPI_COMM_MWAVE + ! Int. Public MPI communicator. ( !/MPI ) + ! MTAGn Int. Public "Zero" tag number for MPI ( !/MPI ) + ! MTAG_UB Int. Public Upper-bound for MPI tags ( !/MPI ) + ! NBISTA I.A. Public Status for gathering input boundary + ! data. ( !/MPI ) + ! HGHSTA I.A. Public Status for gathering high resolution + ! data. ( !/MPI ) + ! EQLSTA I.A. Public Status for gathering data fro equally + ! ranked grids. ( !/MPI ) + ! + ! FLGBDI Log. Public Flag for intitialization of boundry + ! distance maps. + ! FLGHGn Log. Public Flags for using mask for computations + ! and output for areas of grid overlap. + ! IFLSTI L.A. Public FLags for last ice per grid. + ! IFLSTL L.A. Public FLags for last level per grid. + ! IFLSTR L.A. Public FLags for last air density per grid. + ! + ! MDATA TYPE Public Data structure for grid dependent data. + ! MDATAS MDATA Public Array of data structures. + ! + ! BPST TYPE Public Data structure for staging boundary + ! data. + ! BPSTGE BPST Public Array of data structures. + ! + ! HGST TYPE Public Data structure for staging 2-way + ! nesting data. + ! HGSTGE HGST Public Array of data structures. + ! + ! EQST TYPE Public Data structure for staging equal grid + ! reconcilliation data. + ! EQSTGE EQST Public Array of data structures. + ! ---------------------------------------------------------------- + ! + ! All elements of MDATA are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NBI2S I.A. Public Source information of boundary input + ! data (grid number and sea counter). + ! MAPBDI R.A. Public Map with distances to boundary. + ! MAPODI R.A. Public idem, open edges of grids. + ! NRUPTS Int. Public Number of unified output points. + ! UPTMAP I.A. Public Mapping of unified points to grids. + ! MAPMSK I.A. Public Mask corresponding to FLGHGn above. + ! MINIT, MSKINI, FLDATn + ! Log. Public Flags for array initializations. + ! FLLSTI Log. Public FLag for last ice per grid. + ! FLLSTL Log. Public FLag for last level per grid. + ! FLLSTR Log. Public FLag for last air density per grid. + ! + ! NMV Int. Public Number of moving grid data. + ! TMV I.A. Public Moving grid times. + ! AMV R.A. Public Moving grid velocities. + ! DMV R.A. Public Moving grid directions. + ! + ! RCLD I.A. Public Record length for data assimilation. + ! NDT I.A. Public Number of data for data assimilation. + ! DATAn R.A. Public Assimilation data. + ! + ! MPI_COMM_GRD Int. Public Communicator for grid ( !/MPI ) + ! MPI_COMM_BCT Int. Public Communicator for broadcast ( !/MPI ) + ! CROOT Int. Public "root" for MPI_COMM_GRD in + ! MPI_COMM_MWAVE ( !/MPI ) + ! FBCAST Log. Public FLag for need of broadcasting data + ! to processors that are not in the + ! communicator ( !/MPI ) + ! NRQBPG Int. Public Number of request handles ( !/MPI ) + ! IRQBPG I.A. Public Request handles. ( !/MPI ) + ! NRQHGG Int. Public Number of request handles ( !/MPI ) + ! IRQHGG I.A. Public Request handles. ( !/MPI ) + ! NRQEQG Int. Public Number of request handles ( !/MPI ) + ! IRQEQG I.A. Public Request handles. ( !/MPI ) + ! ---------------------------------------------------------------- + ! + ! Elements of the structure BPTS are + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NRQBPS Int. Public Number of request handles ( !/MPI ) + ! IRQBPS I.A. Public Request handles. ( !/MPI ) + ! VTIME I.A. Public Valid time of data. + ! STIME I.A. Public Buffer for time for sending. ( !/MPI ) + ! SBPI R.A. Public Spectral data storage. + ! TSTORE R.A. Public Spectral data buffer. ( !/MPI ) + ! INIT Log. Public Flag for array allocation. + ! ---------------------------------------------------------------- + ! + ! Elements of the structure HGST are + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NRQHGS Int. Public Number of request handles ( !/MPI ) + ! IRQHGS I.A. Public Request handles. ( !/MPI ) + ! NRQOUT Int. Public Number of local spectra. ( !/MPI ) + ! OUTDAT I.A. Public Corresponding data. ( !/MPI ) + ! NTOT, NREC, NRC1, NSND, NSN1, NSMX + ! Int. Public Counters for total data, send and + ! received data with and without + ! masking. + ! VTIME I.A. Public Valid time of data. + ! LJSEA I.A. Public Local sea point counters. + ! NRAVG I.A. Public Number of points in averaging. + ! IMPSRC I.A. Public Source processor for data, + ! ITAG I.A. Public Communication tag. + ! ISEND I.A. Public Composite of all deta needed for send. + ! WGHT R.A. Public Weihts in averaging. + ! SHGH R.A. Public Staging area for spectra. + ! TSTORE R.A. Public Staging area for spectra to be send + ! out ( !/MPI ) + ! INIT Log. Public Flag for array allocation. + ! ---------------------------------------------------------------- + ! + ! Elements of the structure EQST are + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NRQEQS Int. Public Number of request handles ( !/MPI ) + ! IRQEQS I.A. Public Request handles. ( !/MPI ) + ! NRQOUT Int. Public Number of local spectra. ( !/MPI ) + ! OUTDAT I.A. Public Corresponding data. ( !/MPI ) + ! NTOT, NREC, NSND, NAVMAX + ! Int. Public Counters for total data, send and + ! received data. + ! VTIME I.A. Public Valid time of data. + ! I/JSEA I.A. Public Sea point counters. + ! NAVG I.A. Public Number of spectra in averaging. + ! RIP I.A. Public Processor (receiving). + ! RTG I.A. Public Tag number (receiving). + ! SIS,SJS I.A. Public Sea point counter (sending). + ! SI1/2 I.A. Public Storage array counters (sending). + ! SIP I.A. Public Processor (sending). + ! STG I.A. Public Tag (sending). + ! SEQL R.A. Public Staging array. + ! WGHT R.A. Public Weight between grids. + ! WAVG R.A. Public Weight within grid. + ! TSTORE R.A. Public Staging area for spectra to be send + ! out ( !/MPI ) + ! INIT Log. Public Flag for array allocation. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WMNDAT Subr. Public Set number of grids/models. + ! WMDIMD Subr. Public Set dimensions of arrays (data). + ! WMDIMM Subr. Public Set dimensions of arrays. + ! WMSETM Subr. Public Point to selected grid / model. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to proper model grid. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - The number of grids is taken from W3GDATMD, and needs to be + ! set first with W3DIMG. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ Specify default accessibility + !/ + PUBLIC + !/ + !/ Module private variable for checking error returns + !/ + INTEGER, PRIVATE :: ISTAT !< ISTAT check error returns + !/ + !/ Conventional declarations + !/ + INTEGER :: NMDATA = -1 !< NMDATA + INTEGER :: IMDATA = -1 !< IMDATA + INTEGER :: MDSI = 8 !< MDSI + INTEGER :: MDSO = 9 !< MDSO + INTEGER :: MDSS = 6 !< MDSS + INTEGER :: MDST = 6 !< MDST + INTEGER :: MDSE = 6 !< MDSE + INTEGER :: MDSUP !< MDSUP + INTEGER :: NMPROC = 1 !< NMPROC + INTEGER :: IMPROC = 1 !< IMPROC + INTEGER :: NMPLOG = 1 !< NMPLOG + INTEGER :: NMPSCR = 1 !< NMPSCR + INTEGER :: NMPTST = 1 !< NMPTST + INTEGER :: NMPERR = 1 !< NMPERR + INTEGER :: NMPUPT = 1 !< NMPUPT + INTEGER :: STIME(2) !< STIME + INTEGER :: ETIME(2) !< ETIME + INTEGER :: NRGRD !< NRGRD + INTEGER :: NRINP !< NRINP + INTEGER :: NRGRP !< NRGRP + INTEGER :: NMVMAX !< NMVMAX + INTEGER :: NGRPSMC !< NGRPSMC + + INTEGER :: CLKDT1(8) !< CLKDT1 + INTEGER :: CLKDT2(8) !< CLKDT2 + INTEGER :: CLKDT3(8) !< CLKDT3 + #ifdef W3_MPRF - INTEGER :: MDSP !< MDSP + INTEGER :: MDSP !< MDSP #endif #ifdef W3_MPI - INTEGER :: MPI_COMM_MWAVE !< MPI_COMM_MWAVE - INTEGER, PARAMETER :: MTAGB = 0 !< MTAGB - INTEGER, PARAMETER :: MTAG0 = 1000 !< MTAG0 - INTEGER, PARAMETER :: MTAG1 = 100000 !< MTAG1 - INTEGER, PARAMETER :: MTAG2 = 1500000 !< MTAG2 - INTEGER, PARAMETER :: MTAG_UB = 2**21-1 !< MPI_TAG_UB on Cray XC40 + INTEGER :: MPI_COMM_MWAVE !< MPI_COMM_MWAVE + INTEGER, PARAMETER :: MTAGB = 0 !< MTAGB + INTEGER, PARAMETER :: MTAG0 = 1000 !< MTAG0 + INTEGER, PARAMETER :: MTAG1 = 100000 !< MTAG1 + INTEGER, PARAMETER :: MTAG2 = 1500000 !< MTAG2 + INTEGER, PARAMETER :: MTAG_UB = 2**21-1 !< MPI_TAG_UB on Cray XC40 #endif - - INTEGER, ALLOCATABLE :: MDSF(:,:) !< MDSF - INTEGER, ALLOCATABLE :: GRANK(:) !< GRANK - INTEGER, ALLOCATABLE :: GRGRP(:) !< GRGRP - INTEGER, ALLOCATABLE :: INGRP(:,:) !< INGRP - INTEGER, ALLOCATABLE :: GRDHGH(:,:) !< GRDHGH - INTEGER, ALLOCATABLE :: GRDEQL(:,:) !< GRDEQL - INTEGER, ALLOCATABLE :: GRDLOW(:,:) !< GRDLOW - INTEGER, ALLOCATABLE :: ALLPRC(:,:) !< ALLPRC - INTEGER, ALLOCATABLE :: MODMAP(:,:) !< MODMAP - INTEGER, ALLOCATABLE :: TSYNC(:,:) !< TSYNC - INTEGER, ALLOCATABLE :: TMAX(:,:) !< TMAX - INTEGER, ALLOCATABLE :: TOUTP(:,:) !< TOUTP - INTEGER, ALLOCATABLE :: TDATA(:,:) !< TDATA - INTEGER, ALLOCATABLE :: GRSTAT(:) !< GRSTAT - INTEGER, ALLOCATABLE :: NBI2G(:,:) !< NBI2G - INTEGER, ALLOCATABLE :: INPMAP(:,:) !< INPMAP - + INTEGER, ALLOCATABLE :: MDSF(:,:) !< MDSF + INTEGER, ALLOCATABLE :: GRANK(:) !< GRANK + INTEGER, ALLOCATABLE :: GRGRP(:) !< GRGRP + INTEGER, ALLOCATABLE :: INGRP(:,:) !< INGRP + INTEGER, ALLOCATABLE :: GRDHGH(:,:) !< GRDHGH + INTEGER, ALLOCATABLE :: GRDEQL(:,:) !< GRDEQL + + INTEGER, ALLOCATABLE :: GRDLOW(:,:) !< GRDLOW + INTEGER, ALLOCATABLE :: ALLPRC(:,:) !< ALLPRC + INTEGER, ALLOCATABLE :: MODMAP(:,:) !< MODMAP + INTEGER, ALLOCATABLE :: TSYNC(:,:) !< TSYNC + INTEGER, ALLOCATABLE :: TMAX(:,:) !< TMAX + INTEGER, ALLOCATABLE :: TOUTP(:,:) !< TOUTP + INTEGER, ALLOCATABLE :: TDATA(:,:) !< TDATA + INTEGER, ALLOCATABLE :: GRSTAT(:) !< GRSTAT + INTEGER, ALLOCATABLE :: NBI2G(:,:) !< NBI2G + INTEGER, ALLOCATABLE :: INPMAP(:,:) !< INPMAP + #ifdef W3_MPI - INTEGER, ALLOCATABLE :: NBISTA(:) !< NBISTA - INTEGER, ALLOCATABLE :: HGHSTA(:) !< HGHSTA - INTEGER, ALLOCATABLE :: EQLSTA(:) !< EQLSTA + INTEGER, ALLOCATABLE :: NBISTA(:) !< NBISTA + INTEGER, ALLOCATABLE :: HGHSTA(:) !< HGHSTA + INTEGER, ALLOCATABLE :: EQLSTA(:) !< EQLSTA #endif - - REAL :: CLKFIN !< CLKFIN - REAL, ALLOCATABLE :: DTRES(:) !< DTRES - LOGICAL :: FLGBDI=.FALSE. !< FLGBDI - LOGICAL :: FLGHG1 !< FLGHG1 - LOGICAL :: FLGHG2 !< FLGHG2 - LOGICAL, ALLOCATABLE :: RESPEC(:,:) !< RESPEC - LOGICAL, ALLOCATABLE :: BCDUMP(:) !< BCDUMP - LOGICAL, ALLOCATABLE :: IFLSTI(:) !< IFLSTI - LOGICAL, ALLOCATABLE :: IFLSTL(:) !< IFLSTL - LOGICAL, ALLOCATABLE :: IFLSTR(:) !< IFLSTR - CHARACTER(LEN=3), ALLOCATABLE :: IDINP(:,:) !< IDINP -!/ -!/ Data structures -!/ - TYPE MDATA - INTEGER :: RCLD(3) !< RCLD - INTEGER :: NDT(3) !< NDT - INTEGER :: NMV !< NMV - INTEGER :: NRUPTS !< NRUPTS - + + REAL :: CLKFIN !< CLKFIN + REAL, ALLOCATABLE :: DTRES(:) !< DTRES + LOGICAL :: FLGBDI=.FALSE. !< FLGBDI + LOGICAL :: FLGHG1 !< FLGHG1 + LOGICAL :: FLGHG2 !< FLGHG2 + LOGICAL, ALLOCATABLE :: RESPEC(:,:) !< RESPEC + LOGICAL, ALLOCATABLE :: BCDUMP(:) !< BCDUMP + LOGICAL, ALLOCATABLE :: IFLSTI(:) !< IFLSTI + LOGICAL, ALLOCATABLE :: IFLSTL(:) !< IFLSTL + LOGICAL, ALLOCATABLE :: IFLSTR(:) !< IFLSTR + CHARACTER(LEN=3), ALLOCATABLE :: IDINP(:,:) !< IDINP + !/ + !/ Data structures + !/ + TYPE MDATA + INTEGER :: RCLD(3) !< RCLD + INTEGER :: NDT(3) !< NDT + INTEGER :: NMV !< NMV + INTEGER :: NRUPTS !< NRUPTS + #ifdef W3_MPI - INTEGER :: MPI_COMM_GRD !< MPI_COMM_GRD - INTEGER :: MPI_COMM_BCT !< MPI_COMM_BCT - INTEGER :: CROOT !< CROOT - INTEGER :: NRQBPG !< NRQBPG - INTEGER :: NRQHGG !< NRQHGG - INTEGER :: NRQEQG !< NRQEQG + INTEGER :: MPI_COMM_GRD !< MPI_COMM_GRD + INTEGER :: MPI_COMM_BCT !< MPI_COMM_BCT + INTEGER :: CROOT !< CROOT + INTEGER :: NRQBPG !< NRQBPG + INTEGER :: NRQHGG !< NRQHGG + INTEGER :: NRQEQG !< NRQEQG #endif - INTEGER, POINTER :: TMV(:,:,:) !< TMV - INTEGER, POINTER :: NBI2S(:,:) !< NBI2S - INTEGER, POINTER :: MAPMSK(:,:) !< MAPMSK - INTEGER, POINTER :: UPTMAP(:) !< UPTMAP - + INTEGER, POINTER :: TMV(:,:,:) !< TMV + INTEGER, POINTER :: NBI2S(:,:) !< NBI2S + INTEGER, POINTER :: MAPMSK(:,:) !< MAPMSK + INTEGER, POINTER :: UPTMAP(:) !< UPTMAP + #ifdef W3_MPI - INTEGER, POINTER :: IRQBPG(:) !< IRQBPG - INTEGER, POINTER :: IRQHGG(:) !< IRQHGG - INTEGER, POINTER :: IRQEQG(:) !< IRQEQG + INTEGER, POINTER :: IRQBPG(:) !< IRQBPG + INTEGER, POINTER :: IRQHGG(:) !< IRQHGG + INTEGER, POINTER :: IRQEQG(:) !< IRQEQG #endif - REAL, POINTER :: DATA0(:,:) !< DATA0 - REAL, POINTER :: DATA1(:,:) !< DATA1 - REAL, POINTER :: DATA2(:,:) !< DATA2 - REAL, POINTER :: AMV(:,:) !< AMV - REAL, POINTER :: DMV(:,:) !< DMV - - REAL, POINTER :: MAPBDI(:,:) !< MAPBDI - REAL, POINTER :: MAPODI(:,:) !< MAPODI + REAL, POINTER :: DATA0(:,:) !< DATA0 + REAL, POINTER :: DATA1(:,:) !< DATA1 + REAL, POINTER :: DATA2(:,:) !< DATA2 + REAL, POINTER :: AMV(:,:) !< AMV + REAL, POINTER :: DMV(:,:) !< DMV + + REAL, POINTER :: MAPBDI(:,:) !< MAPBDI + REAL, POINTER :: MAPODI(:,:) !< MAPODI #ifdef W3_PDLIB - INTEGER, POINTER :: SEA_IPGL(:) !< SEA_IPGL - INTEGER, POINTER :: SEA_IPGL_TO_PROC(:) !< SEA_IPGL_TO_PROC + INTEGER, POINTER :: SEA_IPGL(:) !< SEA_IPGL + INTEGER, POINTER :: SEA_IPGL_TO_PROC(:) !< SEA_IPGL_TO_PROC #endif - LOGICAL :: MINIT !< MINIT - LOGICAL :: MSKINI !< MSKINI - LOGICAL :: FLLSTL !< FLLSTL - LOGICAL :: FLLSTR !< FLLSTR - LOGICAL :: FLLSTI !< FLLSTI - LOGICAL :: FLDAT0 !< FLDAT0 - LOGICAL :: FLDAT1 !< FLDAT1 - LOGICAL :: FLDAT2 !< FLDAT2 - + LOGICAL :: MINIT !< MINIT + LOGICAL :: MSKINI !< MSKINI + LOGICAL :: FLLSTL !< FLLSTL + LOGICAL :: FLLSTR !< FLLSTR + LOGICAL :: FLLSTI !< FLLSTI + LOGICAL :: FLDAT0 !< FLDAT0 + LOGICAL :: FLDAT1 !< FLDAT1 + LOGICAL :: FLDAT2 !< FLDAT2 + #ifdef W3_MPI - LOGICAL :: FBCAST !< FBCAST + LOGICAL :: FBCAST !< FBCAST #endif - END TYPE MDATA - -! - - TYPE BPST + END TYPE MDATA + + ! + + TYPE BPST #ifdef W3_MPI - INTEGER :: NRQBPS !< NRQBPS - INTEGER :: STIME(2) !< STIME + INTEGER :: NRQBPS !< NRQBPS + INTEGER :: STIME(2) !< STIME #endif - INTEGER :: VTIME(2) !< VTIME + INTEGER :: VTIME(2) !< VTIME #ifdef W3_MPI - INTEGER, POINTER :: IRQBPS(:) !< IRQBPS + INTEGER, POINTER :: IRQBPS(:) !< IRQBPS #endif - REAL, POINTER :: SBPI(:,:) !< SBPI + REAL, POINTER :: SBPI(:,:) !< SBPI #ifdef W3_MPI - REAL, POINTER :: TSTORE(:,:) !< TSTORE + REAL, POINTER :: TSTORE(:,:) !< TSTORE #endif - LOGICAL :: INIT !< INIT - END TYPE BPST -! - TYPE HGST - INTEGER :: VTIME(2) !< VTIME - INTEGER :: NTOT !< NTOT - INTEGER :: NREC !< NREC - INTEGER :: NRC1 !< NRC1 - INTEGER :: NSND !< NSND - INTEGER :: NSN1 !< NSN1 - INTEGER :: NSMX !< NSMX - INTEGER :: XTIME(2) !< XTIME - + LOGICAL :: INIT !< INIT + END TYPE BPST + ! + TYPE HGST + INTEGER :: VTIME(2) !< VTIME + INTEGER :: NTOT !< NTOT + INTEGER :: NREC !< NREC + INTEGER :: NRC1 !< NRC1 + INTEGER :: NSND !< NSND + INTEGER :: NSN1 !< NSN1 + INTEGER :: NSMX !< NSMX + INTEGER :: XTIME(2) !< XTIME + #ifdef W3_MPI - INTEGER :: NRQHGS !< NRQHGS - INTEGER :: NRQOUT !< NRQOUT + INTEGER :: NRQHGS !< NRQHGS + INTEGER :: NRQOUT !< NRQOUT #endif - INTEGER, POINTER :: LJSEA(:) !< LJSEA - INTEGER, POINTER :: NRAVG(:) !< NRAVG - INTEGER, POINTER :: IMPSRC(:,:) !< IMPSRC - INTEGER, POINTER :: ITAG(:,:) !< ITAG - INTEGER, POINTER :: ISEND(:,:) !< ISEND + INTEGER, POINTER :: LJSEA(:) !< LJSEA + INTEGER, POINTER :: NRAVG(:) !< NRAVG + INTEGER, POINTER :: IMPSRC(:,:) !< IMPSRC + INTEGER, POINTER :: ITAG(:,:) !< ITAG + INTEGER, POINTER :: ISEND(:,:) !< ISEND #ifdef W3_MPI - INTEGER, POINTER :: IRQHGS(:) !< IRQHGS - INTEGER, POINTER :: OUTDAT(:,:) !< OUTDAT + INTEGER, POINTER :: IRQHGS(:) !< IRQHGS + INTEGER, POINTER :: OUTDAT(:,:) !< OUTDAT #endif - REAL, POINTER :: WGTH(:,:) !< WGTH - REAL, POINTER :: SHGH(:,:,:) !< SHGH + REAL, POINTER :: WGTH(:,:) !< WGTH + REAL, POINTER :: SHGH(:,:,:) !< SHGH #ifdef W3_MPI - REAL, POINTER :: TSTORE(:,:) !< TSTORE + REAL, POINTER :: TSTORE(:,:) !< TSTORE #endif - LOGICAL :: INIT !< INIT - END TYPE HGST - -! - - TYPE EQST - INTEGER :: VTIME(2) !< VTIME - INTEGER :: NTOT !< NTOT - INTEGER :: NREC !< NREC - INTEGER :: NSND !< NSND - INTEGER :: NAVMAX !< NAVMAX + LOGICAL :: INIT !< INIT + END TYPE HGST + + ! + + TYPE EQST + INTEGER :: VTIME(2) !< VTIME + INTEGER :: NTOT !< NTOT + INTEGER :: NREC !< NREC + INTEGER :: NSND !< NSND + INTEGER :: NAVMAX !< NAVMAX #ifdef W3_MPI - INTEGER :: NRQEQS !< NRQEQS - INTEGER :: NRQOUT !< NRQOUT + INTEGER :: NRQEQS !< NRQEQS + INTEGER :: NRQOUT !< NRQOUT #endif - INTEGER, POINTER :: ISEA(:) !< ISEA - INTEGER, POINTER :: JSEA(:) !< JSEA - INTEGER, POINTER :: NAVG(:) !< NAVG - INTEGER, POINTER :: RIP(:,:) !< RIP - INTEGER, POINTER :: RTG(:,:) !< RTG - INTEGER, POINTER :: SIS(:) !< SIS - INTEGER, POINTER :: SJS(:) !< SJS - INTEGER, POINTER :: SI1(:) !< SI1 - INTEGER, POINTER :: SI2(:) !< SI2 - INTEGER, POINTER :: SIP(:) !< SIP - INTEGER, POINTER :: STG(:) !< STG - + INTEGER, POINTER :: ISEA(:) !< ISEA + INTEGER, POINTER :: JSEA(:) !< JSEA + INTEGER, POINTER :: NAVG(:) !< NAVG + INTEGER, POINTER :: RIP(:,:) !< RIP + INTEGER, POINTER :: RTG(:,:) !< RTG + INTEGER, POINTER :: SIS(:) !< SIS + INTEGER, POINTER :: SJS(:) !< SJS + INTEGER, POINTER :: SI1(:) !< SI1 + INTEGER, POINTER :: SI2(:) !< SI2 + INTEGER, POINTER :: SIP(:) !< SIP + INTEGER, POINTER :: STG(:) !< STG + #ifdef W3_MPI - INTEGER, POINTER :: IRQEQS(:) !< IRQEQS - INTEGER, POINTER :: OUTDAT(:,:) !< OUTDAT + INTEGER, POINTER :: IRQEQS(:) !< IRQEQS + INTEGER, POINTER :: OUTDAT(:,:) !< OUTDAT #endif - REAL, POINTER :: SEQL(:,:,:) !< SEQL - REAL, POINTER :: WGHT(:) !< WGHT - REAL, POINTER :: WAVG(:,:) !< WAVG + REAL, POINTER :: SEQL(:,:,:) !< SEQL + REAL, POINTER :: WGHT(:) !< WGHT + REAL, POINTER :: WAVG(:,:) !< WAVG #ifdef W3_MPI - REAL, POINTER :: TSTORE(:,:) !< TSTORE + REAL, POINTER :: TSTORE(:,:) !< TSTORE #endif - LOGICAL :: INIT !< INIT - END TYPE EQST -!/ -!/ Data storage -!/ - TYPE(MDATA), TARGET, ALLOCATABLE :: MDATAS(:) !< MDATAS - TYPE(BPST), TARGET, ALLOCATABLE :: BPSTGE(:,:) !< BPSTGE - TYPE(HGST), TARGET, ALLOCATABLE :: HGSTGE(:,:) !< HGSTGE - TYPE(EQST), TARGET, ALLOCATABLE :: EQSTGE(:,:) !< EQSTGE -!/ -!/ Data aliasses for structure MDATA(S) -!/ - INTEGER, POINTER :: RCLD(:) !< RCLD - INTEGER, POINTER :: NDT(:) !< NDT - INTEGER, POINTER :: NMV !< NMV - INTEGER, POINTER :: TMV(:,:,:) !< TMV - INTEGER, POINTER :: NBI2S(:,:) !< NBI2S - INTEGER, POINTER :: MAPMSK(:,:) !< MAPMSK - INTEGER, POINTER :: UPTMAP(:) !< UPTMAP + LOGICAL :: INIT !< INIT + END TYPE EQST + !/ + !/ Data storage + !/ + TYPE(MDATA), TARGET, ALLOCATABLE :: MDATAS(:) !< MDATAS + TYPE(BPST), TARGET, ALLOCATABLE :: BPSTGE(:,:) !< BPSTGE + TYPE(HGST), TARGET, ALLOCATABLE :: HGSTGE(:,:) !< HGSTGE + TYPE(EQST), TARGET, ALLOCATABLE :: EQSTGE(:,:) !< EQSTGE + !/ + !/ Data aliasses for structure MDATA(S) + !/ + INTEGER, POINTER :: RCLD(:) !< RCLD + INTEGER, POINTER :: NDT(:) !< NDT + INTEGER, POINTER :: NMV !< NMV + INTEGER, POINTER :: TMV(:,:,:) !< TMV + INTEGER, POINTER :: NBI2S(:,:) !< NBI2S + INTEGER, POINTER :: MAPMSK(:,:) !< MAPMSK + INTEGER, POINTER :: UPTMAP(:) !< UPTMAP #ifdef W3_MPI - INTEGER, POINTER :: MPI_COMM_GRD !< MPI_COMM_GRD - INTEGER, POINTER :: MPI_COMM_BCT !< MPI_COMM_BCT - INTEGER, POINTER :: CROOT !< CROOT + INTEGER, POINTER :: MPI_COMM_GRD !< MPI_COMM_GRD + INTEGER, POINTER :: MPI_COMM_BCT !< MPI_COMM_BCT + INTEGER, POINTER :: CROOT !< CROOT #endif - REAL, POINTER :: DATA0(:,:) !< DATA0 - REAL, POINTER :: DATA1(:,:) !< DATA1 - REAL, POINTER :: DATA2(:,:) !< DATA2 - REAL, POINTER :: AMV(:,:) !< AMV - REAL, POINTER :: DMV(:,:) !< DMV - - REAL, POINTER :: MAPBDI(:,:) !< MAPBDI - REAL, POINTER :: MAPODI(:,:) !< MAPODI + REAL, POINTER :: DATA0(:,:) !< DATA0 + REAL, POINTER :: DATA1(:,:) !< DATA1 + REAL, POINTER :: DATA2(:,:) !< DATA2 + REAL, POINTER :: AMV(:,:) !< AMV + REAL, POINTER :: DMV(:,:) !< DMV + + REAL, POINTER :: MAPBDI(:,:) !< MAPBDI + REAL, POINTER :: MAPODI(:,:) !< MAPODI #ifdef W3_PDLIB - INTEGER, POINTER :: SEA_IPGL(:) !< SEA_IPGL - INTEGER, POINTER :: SEA_IPGL_TO_PROC(:) !< SEA_IPGL_TO_PROC + INTEGER, POINTER :: SEA_IPGL(:) !< SEA_IPGL + INTEGER, POINTER :: SEA_IPGL_TO_PROC(:) !< SEA_IPGL_TO_PROC #endif - LOGICAL, POINTER :: MINIT !< MINIT - LOGICAL, POINTER :: FLLSTL !< FLLSTL - LOGICAL, POINTER :: FLLSTR !< FLLSTR - LOGICAL, POINTER :: FLLSTI !< FLLSTI - LOGICAL, POINTER :: FLDAT0 !< FLDAT0 - LOGICAL, POINTER :: FLDAT1 !< FLDAT1 - LOGICAL, POINTER :: FLDAT2 !< FLDAT2 - + LOGICAL, POINTER :: MINIT !< MINIT + LOGICAL, POINTER :: FLLSTL !< FLLSTL + LOGICAL, POINTER :: FLLSTR !< FLLSTR + LOGICAL, POINTER :: FLLSTI !< FLLSTI + LOGICAL, POINTER :: FLDAT0 !< FLDAT0 + LOGICAL, POINTER :: FLDAT1 !< FLDAT1 + LOGICAL, POINTER :: FLDAT2 !< FLDAT2 + #ifdef W3_MPI - LOGICAL, POINTER :: FBCAST !< FBCAST + LOGICAL, POINTER :: FBCAST !< FBCAST #endif -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Set up the number of grids to be used. -!> -!> @details Use data stored in NGRIDS in W3GDATMD. -!> -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE WMNDAT ( NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 22-Feb-2005 : Origination. ( version 3.07 ) -!/ 16-Dec-2005 : Add staging of boundary data. ( version 3.08 ) -!/ Add HGSTGE data. ( version 3.08 ) -!/ 24-Mar-2006 : Add EQSTGE data. ( version 3.09 ) -!/ 25-May-2006 : Add STIME in BPSTGE. ( version 3.09 ) -!/ 12-Jan-2007 : Add FLSTI and FLLSTL. ( version 3.10 ) -!/ 22-Jan-2007 : Add NAVMAX. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 22-Mar-2021 : Support for air density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Set up the number of grids to be used. -! -! 2. Method : -! -! Use data stored in NGRIDS in W3GDATMD. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program that uses this grid structure. -! -! 6. Error messages : -! -! - Error checks on previous setting of variable NGRIDS. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS - USE W3SERVMD, ONLY: EXTCDE + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Set up the number of grids to be used. + !> + !> @details Use data stored in NGRIDS in W3GDATMD. + !> + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE WMNDAT ( NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 22-Feb-2005 : Origination. ( version 3.07 ) + !/ 16-Dec-2005 : Add staging of boundary data. ( version 3.08 ) + !/ Add HGSTGE data. ( version 3.08 ) + !/ 24-Mar-2006 : Add EQSTGE data. ( version 3.09 ) + !/ 25-May-2006 : Add STIME in BPSTGE. ( version 3.09 ) + !/ 12-Jan-2007 : Add FLSTI and FLLSTL. ( version 3.10 ) + !/ 22-Jan-2007 : Add NAVMAX. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 22-Mar-2021 : Support for air density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Set up the number of grids to be used. + ! + ! 2. Method : + ! + ! Use data stored in NGRIDS in W3GDATMD. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program that uses this grid structure. + ! + ! 6. Error messages : + ! + ! - Error checks on previous setting of variable NGRIDS. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, J + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, J #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMNDAT') + CALL STRACE (IENT, 'WMNDAT') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) NGRIDS - CALL EXTCDE (1) - END IF -! -! -------------------------------------------------------------------- / -! 2. Set variable and allocate arrays -! - ALLOCATE ( MDATAS(NGRIDS), BPSTGE(NGRIDS,NGRIDS), & - HGSTGE(NGRIDS,NGRIDS), EQSTGE(NGRIDS,NGRIDS), & - BCDUMP(NRGRD), IFLSTI(NRINP), IFLSTL(NRINP), & - IFLSTR(NRINP), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) NGRIDS + CALL EXTCDE (1) + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Set variable and allocate arrays + ! + ALLOCATE ( MDATAS(NGRIDS), BPSTGE(NGRIDS,NGRIDS), & + HGSTGE(NGRIDS,NGRIDS), EQSTGE(NGRIDS,NGRIDS), & + BCDUMP(NRGRD), IFLSTI(NRINP), IFLSTL(NRINP), & + IFLSTR(NRINP), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_MPI - ALLOCATE ( NBISTA(NGRIDS), HGHSTA(NGRIDS), EQLSTA(NGRIDS), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( NBISTA(NGRIDS), HGHSTA(NGRIDS), EQLSTA(NGRIDS), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif - NMDATA = NGRIDS -! -! -------------------------------------------------------------------- / -! 3. Initialize parameters -! + NMDATA = NGRIDS + ! + ! -------------------------------------------------------------------- / + ! 3. Initialize parameters + ! #ifdef W3_MPI - NBISTA = 0 - HGHSTA = 0 - EQLSTA = 0 + NBISTA = 0 + HGHSTA = 0 + EQLSTA = 0 #endif -! - IFLSTI = .FALSE. - IFLSTL = .FALSE. - IFLSTR = .FALSE. -! - DO I=1, NGRIDS - MDATAS(I)%MINIT = .FALSE. - MDATAS(I)%MSKINI = .FALSE. - MDATAS(I)%FLDAT0 = .FALSE. - MDATAS(I)%FLDAT1 = .FALSE. - MDATAS(I)%FLDAT2 = .FALSE. + ! + IFLSTI = .FALSE. + IFLSTL = .FALSE. + IFLSTR = .FALSE. + ! + DO I=1, NGRIDS + MDATAS(I)%MINIT = .FALSE. + MDATAS(I)%MSKINI = .FALSE. + MDATAS(I)%FLDAT0 = .FALSE. + MDATAS(I)%FLDAT1 = .FALSE. + MDATAS(I)%FLDAT2 = .FALSE. #ifdef W3_MPI - MDATAS(I)%MPI_COMM_GRD = -99 - MDATAS(I)%MPI_COMM_BCT = -99 + MDATAS(I)%MPI_COMM_GRD = -99 + MDATAS(I)%MPI_COMM_BCT = -99 #endif - DO J=1, NGRIDS - BPSTGE(I,J)%VTIME(1) = -1 - BPSTGE(I,J)%VTIME(2) = 0 + DO J=1, NGRIDS + BPSTGE(I,J)%VTIME(1) = -1 + BPSTGE(I,J)%VTIME(2) = 0 #ifdef W3_MPI - BPSTGE(I,J)%STIME(1) = -1 - BPSTGE(I,J)%STIME(2) = 0 + BPSTGE(I,J)%STIME(1) = -1 + BPSTGE(I,J)%STIME(2) = 0 #endif - BPSTGE(I,J)%INIT = .FALSE. + BPSTGE(I,J)%INIT = .FALSE. #ifdef W3_MPI - BPSTGE(I,J)%NRQBPS = 0 + BPSTGE(I,J)%NRQBPS = 0 #endif - HGSTGE(I,J)%VTIME(1) = -1 - HGSTGE(I,J)%VTIME(2) = 0 - HGSTGE(I,J)%XTIME(1) = -1 - HGSTGE(I,J)%XTIME(2) = 0 - HGSTGE(I,J)%NTOT = 0 - HGSTGE(I,J)%NREC = 0 - HGSTGE(I,J)%NRC1 = 0 - HGSTGE(I,J)%NSND = 0 - HGSTGE(I,J)%NSN1 = 0 - HGSTGE(I,J)%NSMX = 0 + HGSTGE(I,J)%VTIME(1) = -1 + HGSTGE(I,J)%VTIME(2) = 0 + HGSTGE(I,J)%XTIME(1) = -1 + HGSTGE(I,J)%XTIME(2) = 0 + HGSTGE(I,J)%NTOT = 0 + HGSTGE(I,J)%NREC = 0 + HGSTGE(I,J)%NRC1 = 0 + HGSTGE(I,J)%NSND = 0 + HGSTGE(I,J)%NSN1 = 0 + HGSTGE(I,J)%NSMX = 0 #ifdef W3_MPI - HGSTGE(I,J)%NRQHGS = 0 - HGSTGE(I,J)%NRQOUT = 0 + HGSTGE(I,J)%NRQHGS = 0 + HGSTGE(I,J)%NRQOUT = 0 #endif - HGSTGE(I,J)%INIT = .FALSE. - EQSTGE(I,J)%VTIME(1) = -1 - EQSTGE(I,J)%VTIME(2) = 0 - EQSTGE(I,J)%NTOT = 0 - EQSTGE(I,J)%NREC = 0 - EQSTGE(I,J)%NSND = 0 - EQSTGE(I,J)%NAVMAX = 1 + HGSTGE(I,J)%INIT = .FALSE. + EQSTGE(I,J)%VTIME(1) = -1 + EQSTGE(I,J)%VTIME(2) = 0 + EQSTGE(I,J)%NTOT = 0 + EQSTGE(I,J)%NREC = 0 + EQSTGE(I,J)%NSND = 0 + EQSTGE(I,J)%NAVMAX = 1 #ifdef W3_MPI - EQSTGE(I,J)%NRQEQS = 0 - EQSTGE(I,J)%NRQOUT = 0 + EQSTGE(I,J)%NRQEQS = 0 + EQSTGE(I,J)%NRQOUT = 0 #endif - EQSTGE(I,J)%INIT = .FALSE. - END DO - END DO -! + EQSTGE(I,J)%INIT = .FALSE. + END DO + END DO + ! #ifdef W3_T - WRITE (NDST,9000) NGRIDS + WRITE (NDST,9000) NGRIDS #endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR WMNDAT : NGRIDS NOT YET SET *** '/ & - ' NGRIDS = ',I10/ & - ' RUN W3NMOD FIRST'/) -! + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR WMNDAT : NGRIDS NOT YET SET *** '/ & + ' NGRIDS = ',I10/ & + ' RUN W3NMOD FIRST'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST WMNDAT : SETTING UP FOR ',I4,' GRIDS') +9000 FORMAT (' TEST WMNDAT : SETTING UP FOR ',I4,' GRIDS') #endif -!/ -!/ End of WMNDAT ----------------------------------------------------- / -!/ - END SUBROUTINE WMNDAT -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize an individual data grid at the proper dimensions. -!> -!> @details Allocate directly into the structure array. Note that -!> this cannot be done through the pointer alias! -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> @param[in] J Data set [1,2,3]. -!> -!> @author H. L. Tolman @date 10-Dec-2014 -!> - SUBROUTINE WMDIMD ( IMOD, NDSE, NDST, J ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 22-Feb-2005 : Origination. ( version 3.07 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Initialize an individual data grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! J Int. I Data set [1,2,3]. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - WMSETM needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG - USE W3ODATMD, ONLY: NAPROC - USE W3SERVMD, ONLY: EXTCDE + !/ + !/ End of WMNDAT ----------------------------------------------------- / + !/ + END SUBROUTINE WMNDAT + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize an individual data grid at the proper dimensions. + !> + !> @details Allocate directly into the structure array. Note that + !> this cannot be done through the pointer alias! + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> @param[in] J Data set [1,2,3]. + !> + !> @author H. L. Tolman @date 10-Dec-2014 + !> + SUBROUTINE WMDIMD ( IMOD, NDSE, NDST, J ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 22-Feb-2005 : Origination. ( version 3.07 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! J Int. I Data set [1,2,3]. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - WMSETM needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG + USE W3ODATMD, ONLY: NAPROC + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST, J -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID + ! + IMPLICIT NONE + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST, J + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMDIMD') + CALL STRACE (IENT, 'WMDIMD') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NMDATA ) THEN - WRITE (NDSE,1002) IMOD, NMDATA - CALL EXTCDE (2) - END IF -! - IF ( MDATAS(IMOD)%MINIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NMDATA ) THEN + WRITE (NDSE,1002) IMOD, NMDATA + CALL EXTCDE (2) + END IF + ! + IF ( MDATAS(IMOD)%MINIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD + WRITE (NDST,9000) IMOD #endif -! - JGRID = IGRID - IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! - IF ( J .EQ. 0 ) THEN - ALLOCATE ( MDATAS(IMOD)%TMV(2,-7:4,NMV) , & - MDATAS(IMOD)%AMV(NMV,-7:4) , & - MDATAS(IMOD)%DMV(NMV,-7:4) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( J .EQ. 1 ) THEN - IF ( FLDAT0 ) DEALLOCATE ( MDATAS(IMOD)%DATA0 ) - ALLOCATE ( MDATAS(IMOD)%DATA0(RCLD(J),NDT(J)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - FLDAT0 = .TRUE. - END IF -! - IF ( J .EQ. 2 ) THEN - IF ( FLDAT1 ) DEALLOCATE ( MDATAS(IMOD)%DATA1 ) - ALLOCATE ( MDATAS(IMOD)%DATA1(RCLD(J),NDT(J)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - FLDAT1 = .TRUE. - END IF -! - IF ( J .EQ. 3 ) THEN - IF ( FLDAT2 ) DEALLOCATE ( MDATAS(IMOD)%DATA2 ) - ALLOCATE ( MDATAS(IMOD)%DATA2(RCLD(J),NDT(J)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - FLDAT2 = .TRUE. - END IF -! + ! + JGRID = IGRID + IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + IF ( J .EQ. 0 ) THEN + ALLOCATE ( MDATAS(IMOD)%TMV(2,-7:4,NMV) , & + MDATAS(IMOD)%AMV(NMV,-7:4) , & + MDATAS(IMOD)%DMV(NMV,-7:4) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( J .EQ. 1 ) THEN + IF ( FLDAT0 ) DEALLOCATE ( MDATAS(IMOD)%DATA0 ) + ALLOCATE ( MDATAS(IMOD)%DATA0(RCLD(J),NDT(J)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + FLDAT0 = .TRUE. + END IF + ! + IF ( J .EQ. 2 ) THEN + IF ( FLDAT1 ) DEALLOCATE ( MDATAS(IMOD)%DATA1 ) + ALLOCATE ( MDATAS(IMOD)%DATA1(RCLD(J),NDT(J)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + FLDAT1 = .TRUE. + END IF + ! + IF ( J .EQ. 3 ) THEN + IF ( FLDAT2 ) DEALLOCATE ( MDATAS(IMOD)%DATA2 ) + ALLOCATE ( MDATAS(IMOD)%DATA2(RCLD(J),NDT(J)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + FLDAT2 = .TRUE. + END IF + ! #ifdef W3_T - WRITE (NDST,9001) + WRITE (NDST,9001) #endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL WMSETM ( IMOD, NDSE, NDST ) -! - IF ( J .EQ. 0 ) THEN - TMV = 0 - AMV = 0. - DMV = 0. - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL WMSETM ( IMOD, NDSE, NDST ) + ! + IF ( J .EQ. 0 ) THEN + TMV = 0 + AMV = 0. + DMV = 0. + END IF + ! #ifdef W3_T - WRITE (NDST,9002) + WRITE (NDST,9002) #endif -! -! -------------------------------------------------------------------- / -! 5. Restore previous grid setting if necessary -! - IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR WMDIMD : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR WMDIMD : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NMDATA = ',I10/) - 1003 FORMAT (/' *** ERROR WMDIMD : ARRAY(S) ALREADY ALLOCATED *** ') -! + ! + ! -------------------------------------------------------------------- / + ! 5. Restore previous grid setting if necessary + ! + IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR WMDIMD : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR WMDIMD : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NMDATA = ',I10/) +1003 FORMAT (/' *** ERROR WMDIMD : ARRAY(S) ALREADY ALLOCATED *** ') + ! #ifdef W3_T - 9000 FORMAT (' TEST WMDIMD : MODEL ',I4,' DIM. AT ',2I5,I7) - 9001 FORMAT (' TEST WMDIMD : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST WMDIMD : POINTERS RESET') +9000 FORMAT (' TEST WMDIMD : MODEL ',I4,' DIM. AT ',2I5,I7) +9001 FORMAT (' TEST WMDIMD : ARRAYS ALLOCATED') +9002 FORMAT (' TEST WMDIMD : POINTERS RESET') #endif -!/ -!/ End of WMDIMD ----------------------------------------------------- / -!/ - END SUBROUTINE WMDIMD -!/ ------------------------------------------------------------------- / -!> -!> @brief Initialize an individual data grid at the proper dimensions. -!> -!> @details Allocate directly into the structure array. Note that -!> this cannot be done through the pointer alias! -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author H. L. Tolman @date 22-Feb-2005 -!> - SUBROUTINE WMDIMM ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Feb-2005 ! -!/ +-----------------------------------+ -!/ -!/ 22-Feb-2005 : Origination. ( version 3.07 ) -!/ -! 1. Purpose : -! -! Initialize an individual data grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - WMSETM needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG - USE W3ODATMD, ONLY: NAPROC - USE W3SERVMD, ONLY: EXTCDE + !/ + !/ End of WMDIMD ----------------------------------------------------- / + !/ + END SUBROUTINE WMDIMD + !/ ------------------------------------------------------------------- / + !> + !> @brief Initialize an individual data grid at the proper dimensions. + !> + !> @details Allocate directly into the structure array. Note that + !> this cannot be done through the pointer alias! + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author H. L. Tolman @date 22-Feb-2005 + !> + SUBROUTINE WMDIMM ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Feb-2005 ! + !/ +-----------------------------------+ + !/ + !/ 22-Feb-2005 : Origination. ( version 3.07 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - WMSETM needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG + USE W3ODATMD, ONLY: NAPROC + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID + ! + IMPLICIT NONE + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMDIMM') + CALL STRACE (IENT, 'WMDIMM') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NMDATA ) THEN - WRITE (NDSE,1002) IMOD, NMDATA - CALL EXTCDE (2) - END IF -! - IF ( MDATAS(IMOD)%MINIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NMDATA ) THEN + WRITE (NDSE,1002) IMOD, NMDATA + CALL EXTCDE (2) + END IF + ! + IF ( MDATAS(IMOD)%MINIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD + WRITE (NDST,9000) IMOD #endif -! - JGRID = IGRID - IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! -! ALLOCATE ( MDATAS(IMOD)%... -! + ! + JGRID = IGRID + IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + ! ALLOCATE ( MDATAS(IMOD)%... + ! #ifdef W3_T - WRITE (NDST,9001) + WRITE (NDST,9001) #endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL WMSETM ( IMOD, NDSE, NDST ) -! + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL WMSETM ( IMOD, NDSE, NDST ) + ! #ifdef W3_T - WRITE (NDST,9002) + WRITE (NDST,9002) #endif -! -! -------------------------------------------------------------------- / -! 4. Update flag -! - MINIT = .TRUE. -! + ! + ! -------------------------------------------------------------------- / + ! 4. Update flag + ! + MINIT = .TRUE. + ! #ifdef W3_T - WRITE (NDST,9003) + WRITE (NDST,9003) #endif -! -! -------------------------------------------------------------------- / -! 5. Restore previous grid setting if necessary -! - IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR WMDIMM : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR WMDIMM : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NMDATA = ',I10/) - 1003 FORMAT (/' *** ERROR WMDIMM : ARRAY(S) ALREADY ALLOCATED *** ') -! + ! + ! -------------------------------------------------------------------- / + ! 5. Restore previous grid setting if necessary + ! + IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR WMDIMM : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR WMDIMM : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NMDATA = ',I10/) +1003 FORMAT (/' *** ERROR WMDIMM : ARRAY(S) ALREADY ALLOCATED *** ') + ! #ifdef W3_T - 9000 FORMAT (' TEST WMDIMM : MODEL ',I4,' DIM. AT ',2I5,I7) - 9001 FORMAT (' TEST WMDIMM : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST WMDIMM : POINTERS RESET') - 9003 FORMAT (' TEST WMDIMM : FLAGS SET') +9000 FORMAT (' TEST WMDIMM : MODEL ',I4,' DIM. AT ',2I5,I7) +9001 FORMAT (' TEST WMDIMM : ARRAYS ALLOCATED') +9002 FORMAT (' TEST WMDIMM : POINTERS RESET') +9003 FORMAT (' TEST WMDIMM : FLAGS SET') #endif -!/ -!/ End of WMDIMM ----------------------------------------------------- / -!/ - END SUBROUTINE WMDIMM -!/ ------------------------------------------------------------------- / -!> -!> @brief Select one of the WAVEWATCH III grids / models. -!> -!> @details Point pointers to the proper variables in the proper element of -!> the GRIDS array. -!> -!> @param[in] IMOD Model number to point to. -!> @param[in] NDSE Error output unit number. -!> @param[in] NDST Test output unit number. -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE WMSETM ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 13-Jun-2005 : Origination. ( version 3.07 ) -!/ 22-Mar-2021 : Support for air density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Select one of the WAVEWATCH III grids / models. -! -! 2. Method : -! -! Point pointers to the proper variables in the proper element of -! the GRIDS array. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Many subroutines in the WAVEWATCH system. -! -! 6. Error messages : -! -! Checks on parameter list IMOD. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE + !/ + !/ End of WMDIMM ----------------------------------------------------- / + !/ + END SUBROUTINE WMDIMM + !/ ------------------------------------------------------------------- / + !> + !> @brief Select one of the WAVEWATCH III grids / models. + !> + !> @details Point pointers to the proper variables in the proper element of + !> the GRIDS array. + !> + !> @param[in] IMOD Model number to point to. + !> @param[in] NDSE Error output unit number. + !> @param[in] NDST Test output unit number. + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE WMSETM ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 13-Jun-2005 : Origination. ( version 3.07 ) + !/ 22-Mar-2021 : Support for air density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Select one of the WAVEWATCH III grids / models. + ! + ! 2. Method : + ! + ! Point pointers to the proper variables in the proper element of + ! the GRIDS array. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Many subroutines in the WAVEWATCH system. + ! + ! 6. Error messages : + ! + ! Checks on parameter list IMOD. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMSETM') + CALL STRACE (IENT, 'WMSETM') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NMDATA .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NMDATA ) THEN - WRITE (NDSE,1002) IMOD, NMDATA - CALL EXTCDE (2) - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NMDATA .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NMDATA ) THEN + WRITE (NDSE,1002) IMOD, NMDATA + CALL EXTCDE (2) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) IMOD + WRITE (NDST,9000) IMOD #endif -! -! -------------------------------------------------------------------- / -! 2. Set model numbers -! - IMDATA = IMOD -! -! -------------------------------------------------------------------- / -! 3. Set pointers -! -! - NMV => MDATAS(IMOD)%NMV - TMV => MDATAS(IMOD)%TMV - AMV => MDATAS(IMOD)%AMV - DMV => MDATAS(IMOD)%DMV + ! + ! -------------------------------------------------------------------- / + ! 2. Set model numbers + ! + IMDATA = IMOD + ! + ! -------------------------------------------------------------------- / + ! 3. Set pointers + ! + ! + NMV => MDATAS(IMOD)%NMV + TMV => MDATAS(IMOD)%TMV + AMV => MDATAS(IMOD)%AMV + DMV => MDATAS(IMOD)%DMV #ifdef W3_MPI - MPI_COMM_GRD => MDATAS(IMOD)%MPI_COMM_GRD - MPI_COMM_BCT => MDATAS(IMOD)%MPI_COMM_BCT - CROOT => MDATAS(IMOD)%CROOT - FBCAST => MDATAS(IMOD)%FBCAST + MPI_COMM_GRD => MDATAS(IMOD)%MPI_COMM_GRD + MPI_COMM_BCT => MDATAS(IMOD)%MPI_COMM_BCT + CROOT => MDATAS(IMOD)%CROOT + FBCAST => MDATAS(IMOD)%FBCAST #endif - RCLD => MDATAS(IMOD)%RCLD - NDT => MDATAS(IMOD)%NDT - DATA0 => MDATAS(IMOD)%DATA0 - DATA1 => MDATAS(IMOD)%DATA1 - DATA2 => MDATAS(IMOD)%DATA2 - NBI2S => MDATAS(IMOD)%NBI2S - MAPMSK => MDATAS(IMOD)%MAPMSK - MINIT => MDATAS(IMOD)%MINIT - FLLSTL => MDATAS(IMOD)%FLLSTL - FLLSTI => MDATAS(IMOD)%FLLSTI - FLLSTR => MDATAS(IMOD)%FLLSTR - MAPBDI => MDATAS(IMOD)%MAPBDI - MAPODI => MDATAS(IMOD)%MAPODI + RCLD => MDATAS(IMOD)%RCLD + NDT => MDATAS(IMOD)%NDT + DATA0 => MDATAS(IMOD)%DATA0 + DATA1 => MDATAS(IMOD)%DATA1 + DATA2 => MDATAS(IMOD)%DATA2 + NBI2S => MDATAS(IMOD)%NBI2S + MAPMSK => MDATAS(IMOD)%MAPMSK + MINIT => MDATAS(IMOD)%MINIT + FLLSTL => MDATAS(IMOD)%FLLSTL + FLLSTI => MDATAS(IMOD)%FLLSTI + FLLSTR => MDATAS(IMOD)%FLLSTR + MAPBDI => MDATAS(IMOD)%MAPBDI + MAPODI => MDATAS(IMOD)%MAPODI #ifdef W3_PDLIB - SEA_IPGL => MDATAS(IMOD)%SEA_IPGL - SEA_IPGL_TO_PROC => MDATAS(IMOD)%SEA_IPGL_TO_PROC + SEA_IPGL => MDATAS(IMOD)%SEA_IPGL + SEA_IPGL_TO_PROC => MDATAS(IMOD)%SEA_IPGL_TO_PROC #endif - UPTMAP => MDATAS(IMOD)%UPTMAP -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR WMSETM : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR WMSETM : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NMDATA = ',I10/) -! + UPTMAP => MDATAS(IMOD)%UPTMAP + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR WMSETM : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR WMSETM : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NMDATA = ',I10/) + ! #ifdef W3_T - 9000 FORMAT (' TEST WMSETM : MODEL ',I4,' SELECTED') +9000 FORMAT (' TEST WMSETM : MODEL ',I4,' SELECTED') #endif -!/ -!/ End of WMSETM ----------------------------------------------------- / -!/ - END SUBROUTINE WMSETM -!********************************************************************** -!* * -!********************************************************************** -!/ ------------------------------------------------------------------- / -!> -!> @brief Introduce mapping for ISPROC and JSEA when using PDLIB -!> in the Multigrid approach. -!> -!> @param[in] ISEA -!> @param[in] J -!> @param[out] JSEA -!> @param[out] ISPROC -!> -!> @author Aron Roland @date 14-Jun-2018 -!> - SUBROUTINE INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Aron Roland | -!/ | FORTRAN 90 | -!/ | Last update : 14-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 06-Jun-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Introduce mapping for ISPROC and JSEA when using PDLIB -! in the Multigrid approach -! -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! - USE CONSTANTS, ONLY: LPDLIB - USE W3ODATMD, ONLY: OUTPTS - USE W3GDATMD, ONLY: GTYPE, GRIDS, UNGTYPE + !/ + !/ End of WMSETM ----------------------------------------------------- / + !/ + END SUBROUTINE WMSETM + !********************************************************************** + !* * + !********************************************************************** + !/ ------------------------------------------------------------------- / + !> + !> @brief Introduce mapping for ISPROC and JSEA when using PDLIB + !> in the Multigrid approach. + !> + !> @param[in] ISEA + !> @param[in] J + !> @param[out] JSEA + !> @param[out] ISPROC + !> + !> @author Aron Roland @date 14-Jun-2018 + !> + SUBROUTINE INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Aron Roland | + !/ | FORTRAN 90 | + !/ | Last update : 14-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 06-Jun-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Introduce mapping for ISPROC and JSEA when using PDLIB + ! in the Multigrid approach + ! + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + USE CONSTANTS, ONLY: LPDLIB + USE W3ODATMD, ONLY: OUTPTS + USE W3GDATMD, ONLY: GTYPE, GRIDS, UNGTYPE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - integer, intent(in) :: ISEA, J - integer, intent(out) :: JSEA, ISPROC - integer nb -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + IMPLICIT NONE + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + integer, intent(in) :: ISEA, J + integer, intent(out) :: JSEA, ISPROC + integer nb + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'INIT_GET_JSEA_ISPROC_GLOB') + CALL STRACE (IENT, 'INIT_GET_JSEA_ISPROC_GLOB') #endif - IF (.NOT. LPDLIB) THEN - nb=OUTPTS(J)%NAPROC - JSEA = 1 + (ISEA-1)/nb - ISPROC=1 + IF (.NOT. LPDLIB) THEN + nb=OUTPTS(J)%NAPROC + JSEA = 1 + (ISEA-1)/nb + ISPROC=1 #ifdef W3_DIST - ISPROC = MDATAS(J)%CROOT - 1 + ISEA - (JSEA-1)*nb + ISPROC = MDATAS(J)%CROOT - 1 + ISEA - (JSEA-1)*nb #endif - ELSE + ELSE #ifdef W3_PDLIB - IF (GRIDS(J)%GTYPE .ne. UNGTYPE) THEN + IF (GRIDS(J)%GTYPE .ne. UNGTYPE) THEN nb=OUTPTS(J)%NAPROC JSEA = 1 + (ISEA-1)/nb ISPROC = MDATAS(J)%CROOT - 1 + ISEA - (JSEA-1)*nb @@ -1412,12 +1412,12 @@ SUBROUTINE INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) ISPROC = MDATAS(J)%SEA_IPGL_TO_PROC(ISEA) ENDIF #endif - ENDIF -!/ -!/ End of INIT_GET_JSEA_ISPROC_GLOB ---------------------------------- / -!/ - END SUBROUTINE INIT_GET_JSEA_ISPROC_GLOB -!/ -!/ End of module WMMDATMD -------------------------------------------- / -!/ - END MODULE WMMDATMD + ENDIF + !/ + !/ End of INIT_GET_JSEA_ISPROC_GLOB ---------------------------------- / + !/ + END SUBROUTINE INIT_GET_JSEA_ISPROC_GLOB + !/ + !/ End of module WMMDATMD -------------------------------------------- / + !/ +END MODULE WMMDATMD diff --git a/model/src/wmscrpmd.F90 b/model/src/wmscrpmd.F90 index e66ebade2..d5ab2545f 100644 --- a/model/src/wmscrpmd.F90 +++ b/model/src/wmscrpmd.F90 @@ -1,277 +1,277 @@ !> @file !> @brief Contains module WMSCRPMD. -!> +!> !> @author E. Rogers !> @author M. Dutour !> @author A. Roland !> @author F. Ardhuin !> @date 10-Dec-2014 -!> +!> #include "w3macros.h" !/ ------------------------------------------------------------------- / !> -!> @brief Routines to determine and process grid dependencies in the +!> @brief Routines to determine and process grid dependencies in the !> multi-grid wave model. -!> +!> !> @author E. Rogers !> @author M. Dutour !> @author A. Roland !> @author F. Ardhuin !> @date 10-Dec-2014 !> - MODULE WMSCRPMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III | -!/ | E. Rogers, M. Dutour, | -!/ | A. Roland, F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 | -!/ +-----------------------------------+ -!/ -!/ 06-Sep-2012 : Origination, transfer from WMGRIDMD ( version 4.08 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -!/ Copyright 2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Routines to determine and process grid dependencies in the -! multi-grid wave model. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! scrip_wrapper Subr. Public as the name says ... -! get_scrip_info_structured Subr. Public as the name says ... -! get_scrip_info_unstructured Subr. Public as the name says ... -! get_scrip_info Subr. Public as the name says ... -! scrip_info_renormalization Subr. Public as the name says ... -! TRIANG_INDEXES Subr. Public as the name says ... -! get_unstructured_vertex_degree Subr. Public as the name says ... -! GET_BOUNDARY Subr. Public as the name says ... -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! get_unstructured_vertex_degree Subr. W3TRIAMD Manage data structures -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - The subroutines TRIANG_INDEXES, get_unstructured_vertex_degree, and -! GET_BOUNDARY should probably be renamed and moved to the module w3triamd -! -! 6. Switches : -! -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ Specify default accessibility -!/ - PUBLIC -!/ -!/ Module private variable for checking error returns -!/ - INTEGER, PRIVATE :: ISTAT !< ISTAT Check error returns -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Compute grid information required by SCRIP. -!> -!> @param[in] ID_SRC -!> @param[in] ID_DST -!> @param[in] MAPSTA_SRC -!> @param[in] MAPST2_SRC -!> @param[in] FLAGLL -!> @param[in] GRIDSHIFT -!> @param[in] L_MASTER -!> @param[in] L_READ -!> @param[in] L_TEST -!> -!> @author E. Rogers -!> @author M. Dutour -!> @author A. Roland -!> @date 10-Dec-2014 -!> - SUBROUTINE SCRIP_WRAPPER (ID_SRC, ID_DST, & - MAPSTA_SRC,MAPST2_SRC,FLAGLL,GRIDSHIFT,L_MASTER, & - L_READ,L_TEST) -!/ +-----------------------------------+ -!/ | WAVEWATCH III | -!/ | E. Rogers, M. Dutour, A. Roland | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -! 1. Original author : -! -! Erick Rogers, NRL -! -! 2. Last update : -! -! See revisions. -! -! 3. Revisions : -! -! 29-Apr-2011 : Origination ( version 4.01 ) -! 20-Feb-2012 : Mathieu Dutour Sikiric, Aron Roland Z&P -! Modification is to split the code into several -! subroutines -! ---get_scrip_info_structured (the structured case) -! ---get_scrip_info (chooses according to FD/FE) -! ---scrip_info_renormalization (conv_x and all that) -! 11-Apr-2013 Kevin Lind -! Added code for reading/writing SCRIP remap files -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -! -! 4. Copyright : -! -! 5. Purpose : -! -! Compute grid information required by SCRIP -! -! 6. Method : -! -! 7. Parameters, Variables and types : -! -! 8. Called by : -! -! Subroutine WMGHGH -! -! 9. Subroutines and functions used : -! -! Subroutine SCRIP -! -! 10. Error messages: -! -! 11. Remarks : -! -! 12. Structure : -! -! 13. Switches : -! -! 14. Source code : - - USE SCRIP_GRIDS - USE SCRIP_REMAP_VARS - USE SCRIP_CONSTANTS - USE SCRIP_KINDSMOD - USE SCRIP_INTERFACE - USE W3SERVMD, ONLY: EXTCDE -! USE W3GDATMD, ONLY : GRIDS - - IMPLICIT NONE - INTEGER(SCRIP_I4), INTENT(IN) :: ID_SRC, ID_DST - INTEGER(SCRIP_I4), INTENT(IN) :: MAPSTA_SRC(:,:) - INTEGER(SCRIP_I4), INTENT(IN) :: MAPST2_SRC(:,:) - LOGICAL(SCRIP_LOGICAL), INTENT(IN) :: FLAGLL - REAL (SCRIP_R8), INTENT(IN) :: GRIDSHIFT - LOGICAL(SCRIP_LOGICAL), INTENT(IN) :: L_MASTER ! Am I the master processor (do I/O)? - LOGICAL(SCRIP_LOGICAL), INTENT(IN) :: L_READ ! Do I read the remap file? - LOGICAL(SCRIP_LOGICAL), INTENT(IN) :: L_TEST ! Whether to include test output - ! in subroutines -!/ ------------------------------------------------------------------- / -!/ local variables -!/ - INTEGER(SCRIP_I4) :: IREC,I,J,NI,NJ,IDUM,NK,K, & - ILINK,IW,ICORNER,NGOODPNTS, & - NBADPNTS - INTEGER(SCRIP_I4) :: ISRC,JSRC,KSRC,IPNT,KDST, & - NI_SRC - REAL (SCRIP_R8) :: LAT_CONVERSION,OFFSET - REAL (SCRIP_R8) :: CONV_DX,CONV_DY,WEIGHT - REAL (SCRIP_R8) :: WTSUM +MODULE WMSCRPMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III | + !/ | E. Rogers, M. Dutour, | + !/ | A. Roland, F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 | + !/ +-----------------------------------+ + !/ + !/ 06-Sep-2012 : Origination, transfer from WMGRIDMD ( version 4.08 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + !/ Copyright 2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Routines to determine and process grid dependencies in the + ! multi-grid wave model. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! scrip_wrapper Subr. Public as the name says ... + ! get_scrip_info_structured Subr. Public as the name says ... + ! get_scrip_info_unstructured Subr. Public as the name says ... + ! get_scrip_info Subr. Public as the name says ... + ! scrip_info_renormalization Subr. Public as the name says ... + ! TRIANG_INDEXES Subr. Public as the name says ... + ! get_unstructured_vertex_degree Subr. Public as the name says ... + ! GET_BOUNDARY Subr. Public as the name says ... + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! get_unstructured_vertex_degree Subr. W3TRIAMD Manage data structures + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - The subroutines TRIANG_INDEXES, get_unstructured_vertex_degree, and + ! GET_BOUNDARY should probably be renamed and moved to the module w3triamd + ! + ! 6. Switches : + ! + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ Specify default accessibility + !/ + PUBLIC + !/ + !/ Module private variable for checking error returns + !/ + INTEGER, PRIVATE :: ISTAT !< ISTAT Check error returns + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Compute grid information required by SCRIP. + !> + !> @param[in] ID_SRC + !> @param[in] ID_DST + !> @param[in] MAPSTA_SRC + !> @param[in] MAPST2_SRC + !> @param[in] FLAGLL + !> @param[in] GRIDSHIFT + !> @param[in] L_MASTER + !> @param[in] L_READ + !> @param[in] L_TEST + !> + !> @author E. Rogers + !> @author M. Dutour + !> @author A. Roland + !> @date 10-Dec-2014 + !> + SUBROUTINE SCRIP_WRAPPER (ID_SRC, ID_DST, & + MAPSTA_SRC,MAPST2_SRC,FLAGLL,GRIDSHIFT,L_MASTER, & + L_READ,L_TEST) + !/ +-----------------------------------+ + !/ | WAVEWATCH III | + !/ | E. Rogers, M. Dutour, A. Roland | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + ! 1. Original author : + ! + ! Erick Rogers, NRL + ! + ! 2. Last update : + ! + ! See revisions. + ! + ! 3. Revisions : + ! + ! 29-Apr-2011 : Origination ( version 4.01 ) + ! 20-Feb-2012 : Mathieu Dutour Sikiric, Aron Roland Z&P + ! Modification is to split the code into several + ! subroutines + ! ---get_scrip_info_structured (the structured case) + ! ---get_scrip_info (chooses according to FD/FE) + ! ---scrip_info_renormalization (conv_x and all that) + ! 11-Apr-2013 Kevin Lind + ! Added code for reading/writing SCRIP remap files + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + ! + ! 4. Copyright : + ! + ! 5. Purpose : + ! + ! Compute grid information required by SCRIP + ! + ! 6. Method : + ! + ! 7. Parameters, Variables and types : + ! + ! 8. Called by : + ! + ! Subroutine WMGHGH + ! + ! 9. Subroutines and functions used : + ! + ! Subroutine SCRIP + ! + ! 10. Error messages: + ! + ! 11. Remarks : + ! + ! 12. Structure : + ! + ! 13. Switches : + ! + ! 14. Source code : + + USE SCRIP_GRIDS + USE SCRIP_REMAP_VARS + USE SCRIP_CONSTANTS + USE SCRIP_KINDSMOD + USE SCRIP_INTERFACE + USE W3SERVMD, ONLY: EXTCDE + ! USE W3GDATMD, ONLY : GRIDS + + IMPLICIT NONE + INTEGER(SCRIP_I4), INTENT(IN) :: ID_SRC, ID_DST + INTEGER(SCRIP_I4), INTENT(IN) :: MAPSTA_SRC(:,:) + INTEGER(SCRIP_I4), INTENT(IN) :: MAPST2_SRC(:,:) + LOGICAL(SCRIP_LOGICAL), INTENT(IN) :: FLAGLL + REAL (SCRIP_R8), INTENT(IN) :: GRIDSHIFT + LOGICAL(SCRIP_LOGICAL), INTENT(IN) :: L_MASTER ! Am I the master processor (do I/O)? + LOGICAL(SCRIP_LOGICAL), INTENT(IN) :: L_READ ! Do I read the remap file? + LOGICAL(SCRIP_LOGICAL), INTENT(IN) :: L_TEST ! Whether to include test output + ! in subroutines + !/ ------------------------------------------------------------------- / + !/ local variables + !/ + INTEGER(SCRIP_I4) :: IREC,I,J,NI,NJ,IDUM,NK,K, & + ILINK,IW,ICORNER,NGOODPNTS, & + NBADPNTS + INTEGER(SCRIP_I4) :: ISRC,JSRC,KSRC,IPNT,KDST, & + NI_SRC + REAL (SCRIP_R8) :: LAT_CONVERSION,OFFSET + REAL (SCRIP_R8) :: CONV_DX,CONV_DY,WEIGHT + REAL (SCRIP_R8) :: WTSUM #ifdef W3_T38 - CHARACTER (LEN=10) :: CDATE_TIME(3) - INTEGER :: DATE_TIME(8) - INTEGER :: ELAPSED_TIME, BEG_TIME, & - END_TIME + CHARACTER (LEN=10) :: CDATE_TIME(3) + INTEGER :: DATE_TIME(8) + INTEGER :: ELAPSED_TIME, BEG_TIME, & + END_TIME #endif -! test output for input variables + ! test output for input variables #ifdef W3_T38 - if(l_master)write(*,*)'flagll = ',flagll - if(l_master)write(*,*)'gridshift = ',gridshift + if(l_master)write(*,*)'flagll = ',flagll + if(l_master)write(*,*)'gridshift = ',gridshift #endif -! -! START: universal settings -! - -! Set variables for converting to degrees -! notes: SCRIP only operates on spherical coordinates, so for the case -! where the problem is specified by the user as in a -! meters/cartesian coordinate system, it is necessary to make -! a temporary conversion to a "fake" spherical coordinate grid, -! to keep SCRIP happy. The good news here is that multi-grid -! meters-grid simulations will be very rare: we will probably only -! encounter them in the context of simple test cases. Strictly -! speaking, this conversion does not even need to be physically -! correct, e.g. we could say that 1000 km is 1 deg....as long as -! we are consistent between grids. -! Potential future improvement: make conv_dy and offset such that dst grid -! covers a specific longitude range, e.g. 1 deg east to 2 deg east - -! -! START: set up src grid -! - -!notes: when we work out how to interface with an unstructured grid, -! we will need to revisit this issue of how to set grid1_rank, etc. -! strategy: declare variables in grid module, but allocate them here. -! - GRID1_UNITS='degrees' ! the other option is radians...we don't use this - GRID1_NAME='src' ! this is not used, except for netcdf output - CALL GET_SCRIP_INFO(ID_SRC, & - & GRID1_CENTER_LON, GRID1_CENTER_LAT, & - & GRID1_CORNER_LON, GRID1_CORNER_LAT, GRID1_MASK, & - & GRID1_DIMS, GRID1_SIZE, GRID1_CORNERS, GRID1_RANK) - GRID2_UNITS='degrees' - GRID2_NAME='dst' - CALL GET_SCRIP_INFO(ID_DST, & - & GRID2_CENTER_LON, GRID2_CENTER_LAT, & - & GRID2_CORNER_LON, GRID2_CORNER_LAT, GRID2_MASK, & - & GRID2_DIMS, GRID2_SIZE, GRID2_CORNERS, GRID2_RANK) - - IF(FLAGLL)THEN - CONV_DX=ONE - CONV_DY=ONE - OFFSET=ZERO - ELSE - LAT_CONVERSION=ZERO ! lat_conversion -! notes: this is the latitude used for conversion everywhere -! in the grid (approximation) -! (in radians) -! conv_dy=92.6*1200.0 ! physical, =92.6/(3/3600)=111000 m = 111 km - CONV_DY=1.0E+6_SCRIP_R8 ! non-physical, 1e+6=1 deg - CONV_DX=COS(LAT_CONVERSION)*CONV_DY -! notes: offset (in meters), is necessary so that our grid does -! not lie on the branch cut - OFFSET=75000.0_SCRIP_R8-MIN(MINVAL(GRID1_CENTER_LON), & - & MINVAL(GRID2_CENTER_LON)) - ENDIF - -!.....test output + ! + ! START: universal settings + ! + + ! Set variables for converting to degrees + ! notes: SCRIP only operates on spherical coordinates, so for the case + ! where the problem is specified by the user as in a + ! meters/cartesian coordinate system, it is necessary to make + ! a temporary conversion to a "fake" spherical coordinate grid, + ! to keep SCRIP happy. The good news here is that multi-grid + ! meters-grid simulations will be very rare: we will probably only + ! encounter them in the context of simple test cases. Strictly + ! speaking, this conversion does not even need to be physically + ! correct, e.g. we could say that 1000 km is 1 deg....as long as + ! we are consistent between grids. + ! Potential future improvement: make conv_dy and offset such that dst grid + ! covers a specific longitude range, e.g. 1 deg east to 2 deg east + + ! + ! START: set up src grid + ! + + !notes: when we work out how to interface with an unstructured grid, + ! we will need to revisit this issue of how to set grid1_rank, etc. + ! strategy: declare variables in grid module, but allocate them here. + ! + GRID1_UNITS='degrees' ! the other option is radians...we don't use this + GRID1_NAME='src' ! this is not used, except for netcdf output + CALL GET_SCRIP_INFO(ID_SRC, & + & GRID1_CENTER_LON, GRID1_CENTER_LAT, & + & GRID1_CORNER_LON, GRID1_CORNER_LAT, GRID1_MASK, & + & GRID1_DIMS, GRID1_SIZE, GRID1_CORNERS, GRID1_RANK) + GRID2_UNITS='degrees' + GRID2_NAME='dst' + CALL GET_SCRIP_INFO(ID_DST, & + & GRID2_CENTER_LON, GRID2_CENTER_LAT, & + & GRID2_CORNER_LON, GRID2_CORNER_LAT, GRID2_MASK, & + & GRID2_DIMS, GRID2_SIZE, GRID2_CORNERS, GRID2_RANK) + + IF(FLAGLL)THEN + CONV_DX=ONE + CONV_DY=ONE + OFFSET=ZERO + ELSE + LAT_CONVERSION=ZERO ! lat_conversion + ! notes: this is the latitude used for conversion everywhere + ! in the grid (approximation) + ! (in radians) + ! conv_dy=92.6*1200.0 ! physical, =92.6/(3/3600)=111000 m = 111 km + CONV_DY=1.0E+6_SCRIP_R8 ! non-physical, 1e+6=1 deg + CONV_DX=COS(LAT_CONVERSION)*CONV_DY + ! notes: offset (in meters), is necessary so that our grid does + ! not lie on the branch cut + OFFSET=75000.0_SCRIP_R8-MIN(MINVAL(GRID1_CENTER_LON), & + & MINVAL(GRID2_CENTER_LON)) + ENDIF + + !.....test output #ifdef W3_T38 - write(*,*)'l_master = ',l_master - if(l_master)then + write(*,*)'l_master = ',l_master + if(l_master)then write(*,*)'conv_dx=', conv_dx write(*,*)'conv_dy=', conv_dy write(*,*)'offset = ',offset @@ -286,1508 +286,1508 @@ SUBROUTINE SCRIP_WRAPPER (ID_SRC, ID_DST, & write(*,*)'maxval(grid2_center_lon) = ',maxval(grid2_center_lon) write(*,*)'minval(grid2_center_lat) = ',minval(grid2_center_lat) write(*,*)'maxval(grid2_center_lat) = ',maxval(grid2_center_lat) - endif + endif #endif - CALL SCRIP_INFO_RENORMALIZATION( & - & GRID1_CENTER_LON, GRID1_CENTER_LAT, & - & GRID1_CORNER_LON, GRID1_CORNER_LAT, GRID1_MASK, & - & GRID1_DIMS, GRID1_SIZE, GRID1_CORNERS, GRID1_RANK, & - & CONV_DX, CONV_DY, OFFSET, GRIDSHIFT) - CALL SCRIP_INFO_RENORMALIZATION( & - & GRID2_CENTER_LON, GRID2_CENTER_LAT, & - & GRID2_CORNER_LON, GRID2_CORNER_LAT, GRID2_MASK, & - & GRID2_DIMS, GRID2_SIZE, GRID2_CORNERS, GRID2_RANK, & - & CONV_DX, CONV_DY, OFFSET, ZERO) - -!.....Set constants for thresholding weights: - FRAC_LOWEST =1.E-3_SCRIP_R8 - FRAC_HIGHEST=ONE+1.E-3_SCRIP_R8 - WT_LOWEST =ZERO - WT_HIGHEST =ONE+1.E-7_SCRIP_R8 + CALL SCRIP_INFO_RENORMALIZATION( & + & GRID1_CENTER_LON, GRID1_CENTER_LAT, & + & GRID1_CORNER_LON, GRID1_CORNER_LAT, GRID1_MASK, & + & GRID1_DIMS, GRID1_SIZE, GRID1_CORNERS, GRID1_RANK, & + & CONV_DX, CONV_DY, OFFSET, GRIDSHIFT) + CALL SCRIP_INFO_RENORMALIZATION( & + & GRID2_CENTER_LON, GRID2_CENTER_LAT, & + & GRID2_CORNER_LON, GRID2_CORNER_LAT, GRID2_MASK, & + & GRID2_DIMS, GRID2_SIZE, GRID2_CORNERS, GRID2_RANK, & + & CONV_DX, CONV_DY, OFFSET, ZERO) + + !.....Set constants for thresholding weights: + FRAC_LOWEST =1.E-3_SCRIP_R8 + FRAC_HIGHEST=ONE+1.E-3_SCRIP_R8 + WT_LOWEST =ZERO + WT_HIGHEST =ONE+1.E-7_SCRIP_R8 #ifdef W3_T38 - call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) #endif - CALL SCRIP(ID_SRC, ID_DST, L_MASTER, L_READ, L_TEST) + CALL SCRIP(ID_SRC, ID_DST, L_MASTER, L_READ, L_TEST) #ifdef W3_T38 - call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) - end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) - elapsed_time = end_time - beg_time - write(0,*) "SCRIP: ", elapsed_time, " MSEC" + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + elapsed_time = end_time - beg_time + write(0,*) "SCRIP: ", elapsed_time, " MSEC" #endif #ifdef W3_T38 - if(l_master)write(*,*)'new minval(grid1_center_lon) = ',minval(grid1_center_lon) - if(l_master)write(*,*)'new maxval(grid1_center_lon) = ',maxval(grid1_center_lon) + if(l_master)write(*,*)'new minval(grid1_center_lon) = ',minval(grid1_center_lon) + if(l_master)write(*,*)'new maxval(grid1_center_lon) = ',maxval(grid1_center_lon) #endif -!.....notes: at this point we have the following useful variables: -! num_wts, e.g. num_wts=3....for first order conservative remapping, -! only the first one is relevant, the other two are for second-order -! remapping. -! max_links_map1, e.g. max_links_map1=1369, -! grid2_size, e.g. grid2_size=1849, -! wts_map1(num_wts,max_links_map1), e.g. wts_map1(3,1369), -! grid1_add_map1(max_links_map1), e.g. grid1_add_map1(1369), -! grid2_add_map1(max_links_map1), e.g. grid2_add_map1(1369), -! grid2_frac(grid2_size), e.g. grid2_frac(1849), -! (see earlier versions for notes re: equivalency in netcdf/matlab) -! -!.....test output (optional) -! -!.....note re: notation: I use k for the combined i/j array, similar to isea, -! but not necessarily the same as isea since some points may -! be land etc. + !.....notes: at this point we have the following useful variables: + ! num_wts, e.g. num_wts=3....for first order conservative remapping, + ! only the first one is relevant, the other two are for second-order + ! remapping. + ! max_links_map1, e.g. max_links_map1=1369, + ! grid2_size, e.g. grid2_size=1849, + ! wts_map1(num_wts,max_links_map1), e.g. wts_map1(3,1369), + ! grid1_add_map1(max_links_map1), e.g. grid1_add_map1(1369), + ! grid2_add_map1(max_links_map1), e.g. grid2_add_map1(1369), + ! grid2_frac(grid2_size), e.g. grid2_frac(1849), + ! (see earlier versions for notes re: equivalency in netcdf/matlab) + ! + !.....test output (optional) + ! + !.....note re: notation: I use k for the combined i/j array, similar to isea, + ! but not necessarily the same as isea since some points may + ! be land etc. #ifdef W3_T38 - if(l_master)then - do k=1,grid2_size + if(l_master)then + do k=1,grid2_size write(403,*)grid2_frac(k) - end do - do ilink=1,max_links_map1 + end do + do ilink=1,max_links_map1 write(405,'(999(1x,f20.7))')(wts_map1(iw,ilink),iw=1,num_wts) - end do - do ilink=1,max_links_map1 + end do + do ilink=1,max_links_map1 write(406,'(i20)')grid1_add_map1(ilink) ! equivalent to - ! my "src_address" - write(407,'(i20)')grid2_add_map1(ilink) ! equivalent to - ! my "dst_address" - end do - endif + ! my "src_address" + write(407,'(i20)')grid2_add_map1(ilink) ! equivalent to + ! my "dst_address" + end do + endif #endif -!.....organize results and return to wmghgh. - -! what we need, for purpose of feeding back to ww3, for each dst grid node: -! a) the set of src grid nodes, in terms of isea, for which -! weights are available -! b) the corresponding set of weights - - ALLOCATE ( WGTDATA(GRID2_SIZE), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - -!.....step 1: count up NR0, NR1, NR2, NRL, NLOC (NR1 and NLOC are denoted -! "n" here) -! It is especially important to determine how large npnts gets, -! so that we can allocate arrays properly - WGTDATA%NR0=0 - WGTDATA%NR2=0 - WGTDATA%NRL=0 - WGTDATA%N=0 - - NI_SRC=GRID1_DIMS(1) - NGOODPNTS=0 - NBADPNTS=0 - - DO ILINK=1,MAX_LINKS_MAP1 - -!........note that this pair of if-thens *must* be consistent with the -!........single if-then below - IF ((GRID2_FRAC(GRID2_ADD_MAP1(ILINK))>FRAC_LOWEST) .AND. & - (GRID2_FRAC(GRID2_ADD_MAP1(ILINK))=WT_LOWEST) .AND. & - (WTS_MAP1(1,ILINK)<=WT_HIGHEST) ) THEN - KSRC=GRID1_ADD_MAP1(ILINK) - JSRC=INT((KSRC-1)/NI_SRC)+1 - ISRC=KSRC-(JSRC-1)*NI_SRC - - IF (MAPSTA_SRC(JSRC,ISRC).EQ.0) THEN ! excluded point - WGTDATA(GRID2_ADD_MAP1(ILINK))%NR0 = & - WGTDATA(GRID2_ADD_MAP1(ILINK))%NR0 + 1 - IF (MAPST2_SRC(JSRC,ISRC).EQ.0)THEN - WGTDATA(GRID2_ADD_MAP1(ILINK))%NRL = & - WGTDATA(GRID2_ADD_MAP1(ILINK))%NRL + 1 - ENDIF - ELSE IF (ABS(MAPSTA_SRC(JSRC,ISRC)).EQ.1) THEN - ! sea point - WGTDATA(GRID2_ADD_MAP1(ILINK))%N= & - WGTDATA(GRID2_ADD_MAP1(ILINK))%N+1 - ELSE IF (ABS(MAPSTA_SRC(JSRC,ISRC)).EQ.2) THEN - ! bnd point - WGTDATA(GRID2_ADD_MAP1(ILINK))%NR2 = & - WGTDATA(GRID2_ADD_MAP1(ILINK))%NR2 + 1 - END IF - NGOODPNTS=NGOODPNTS+1 - ELSEIF ( (GRID1_FRAC(GRID1_ADD_MAP1(ILINK))>FRAC_LOWEST) & - .AND. (GRID1_FRAC(GRID1_ADD_MAP1(ILINK))FRAC_LOWEST) .AND. & + (GRID2_FRAC(GRID2_ADD_MAP1(ILINK))=WT_LOWEST) .AND. & + (WTS_MAP1(1,ILINK)<=WT_HIGHEST) ) THEN + KSRC=GRID1_ADD_MAP1(ILINK) + JSRC=INT((KSRC-1)/NI_SRC)+1 + ISRC=KSRC-(JSRC-1)*NI_SRC + + IF (MAPSTA_SRC(JSRC,ISRC).EQ.0) THEN ! excluded point + WGTDATA(GRID2_ADD_MAP1(ILINK))%NR0 = & + WGTDATA(GRID2_ADD_MAP1(ILINK))%NR0 + 1 + IF (MAPST2_SRC(JSRC,ISRC).EQ.0)THEN + WGTDATA(GRID2_ADD_MAP1(ILINK))%NRL = & + WGTDATA(GRID2_ADD_MAP1(ILINK))%NRL + 1 ENDIF - ENDIF - END DO - IF((NBADPNTS.GT.0).AND.L_MASTER)THEN - WRITE(*,'(4x,A,I5,A)')'We had problems in ',NBADPNTS, & - ' points.' - WRITE(*,'(4x,I8,A)')NGOODPNTS,' points appear to be OK.' + ELSE IF (ABS(MAPSTA_SRC(JSRC,ISRC)).EQ.1) THEN + ! sea point + WGTDATA(GRID2_ADD_MAP1(ILINK))%N= & + WGTDATA(GRID2_ADD_MAP1(ILINK))%N+1 + ELSE IF (ABS(MAPSTA_SRC(JSRC,ISRC)).EQ.2) THEN + ! bnd point + WGTDATA(GRID2_ADD_MAP1(ILINK))%NR2 = & + WGTDATA(GRID2_ADD_MAP1(ILINK))%NR2 + 1 + END IF + NGOODPNTS=NGOODPNTS+1 + ELSEIF ( (GRID1_FRAC(GRID1_ADD_MAP1(ILINK))>FRAC_LOWEST) & + .AND. (GRID1_FRAC(GRID1_ADD_MAP1(ILINK))FRAC_LOWEST) .AND. & + & (GRID2_FRAC(GRID2_ADD_MAP1(ILINK))=WT_LOWEST) .AND. & + & (WTS_MAP1(1,ILINK)<=WT_HIGHEST))THEN + IF (ABS(MAPSTA_SRC(JSRC,ISRC)).EQ.1) THEN ! sea point + WGTDATA(GRID2_ADD_MAP1(ILINK))%N= & + & WGTDATA(GRID2_ADD_MAP1(ILINK))%N+1 + WGTDATA(GRID2_ADD_MAP1(ILINK))%W(WGTDATA( & + & GRID2_ADD_MAP1(ILINK))%N)=WTS_MAP1(1,ILINK) + WGTDATA(GRID2_ADD_MAP1(ILINK))%K(WGTDATA( & + & GRID2_ADD_MAP1(ILINK))%N)=GRID1_ADD_MAP1(ILINK) + ENDIF ENDIF - -!.....step 2: allocate according to the size "n" determined above - DO KDST=1,GRID2_SIZE - ALLOCATE ( WGTDATA(KDST)%W(WGTDATA(KDST)%N), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WGTDATA(KDST)%K(WGTDATA(KDST)%N), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - WGTDATA(KDST)%N=0 + END DO + + !.....step 4: re-normalize weights. This is necessary because we called + !.....scrip without the mask. Now that we have the mask in place, we need + !.....to re-normalize the weights. + DO KDST=1,GRID2_SIZE + IF (WGTDATA(KDST)%N > 0) THEN + WTSUM=ZERO + DO IPNT=1,WGTDATA(KDST)%N + WTSUM=WTSUM+WGTDATA(KDST)%W(IPNT) + END DO + DO IPNT=1,WGTDATA(KDST)%N + WGTDATA(KDST)%W(IPNT)=WGTDATA(KDST)%W(IPNT)/WTSUM + END DO + END IF + END DO + + CALL SCRIP_CLEAR + END SUBROUTINE SCRIP_WRAPPER + + !/ ------------------------------------------------------------------- / + !> + !> @brief Compute grid arrays for scrip for a specific unstructured grid. + !> + !> @details For interior vertices, we select for every triangle the barycenter + !> of the triangle. So to every node contained in N triangles we associate + !> a domain with N corners. Every one of those corners is contained + !> in 3 different domains. + !> + !> For nodes that are on the boundary, we have to proceed differently. + !> For every such node, we have NEIGHBOR_PREV and NEIGHBOR_NEXT which + !> are the neighbor on each side of the boundary. + !> We put a corner on the middle of the edge. We also put a corner + !> on the node itself. + !> + !> Note that instead of taking barycenters, we could have taken + !> Voronoi vertices, but this carries danger since Voronoi vertices + !> can be outside of the triangle. And it leaves open how to treat + !> the boundary. + !> + !> @param[in] ID_GRD + !> @param[out] GRID_CENTER_LON + !> @param[out] GRID_CENTER_LAT + !> @param[out] GRID_CORNER_LON + !> @param[out] GRID_CORNER_LAT + !> @param[out] GRID_MASK + !> @param[out] GRID_DIMS + !> @param[out] GRID_SIZE + !> @param[out] GRID_CORNERS + !> @param[out] GRID_RANK + !> + !> @author M. Dutour + !> @author A. Roland + !> @date 10-Dec-2014 + !> + SUBROUTINE GET_SCRIP_INFO_UNSTRUCTURED (ID_GRD, & + & GRID_CENTER_LON, GRID_CENTER_LAT, & + & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & + & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK) + !/ +-----------------------------------+ + !/ | WAVEWATCH III | + !/ | M. Dutour, A. Roland | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + ! 1. Original author : + ! + ! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P + ! + ! 2. Last update : + ! + ! See revisions. + ! + ! 3. Revisions : + ! + ! 20-Feb-2012 : Origination + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + ! + ! 4. Copyright : + ! + ! 5. Purpose : + ! + ! Compute grid arrays for scrip for a specific unstructured grid + ! For interior vertices, we select for every triangle the barycenter + ! of the triangle. So to every node contained in N triangles we associate + ! a domain with N corners. Every one of those corners is contained + ! in 3 different domains. + ! For nodes that are on the boundary, we have to proceed differently. + ! For every such node, we have NEIGHBOR_PREV and NEIGHBOR_NEXT which + ! are the neighbor on each side of the boundary. + ! We put a corner on the middle of the edge. We also put a corner + ! on the node itself. + ! Note that instead of taking barycenters, we could have taken + ! Voronoi vertices, but this carries danger since Voronoi vertices + ! can be outside of the triangle. And it leaves open how to treat + ! the boundary. + ! + ! 6. Method : + ! + ! 7. Parameters, Variables and types : + ! + ! 8. Called by : + ! + ! Subroutine get_scrip_info + ! + ! 9. Subroutines and functions used : + ! + ! 10. Error messages: + ! + ! 11. Remarks : + ! + ! 12. Structure : + ! + ! 13. Switches : + ! + ! 14. Source code : + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY : GRIDS + IMPLICIT NONE + INTEGER, INTENT(IN) :: ID_GRD + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LON(:) + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LAT(:) + LOGICAL, INTENT(OUT), ALLOCATABLE :: GRID_MASK(:) + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LON(:,:) + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LAT(:,:) + INTEGER, INTENT(OUT), ALLOCATABLE :: GRID_DIMS(:) + INTEGER, INTENT(OUT) :: GRID_SIZE, GRID_CORNERS, GRID_RANK + + INTEGER DIRAPPROACH, DUALAPPROACH, THEAPPROACH + INTEGER MNE, MNP, IE, IP, I + INTEGER NBPLUS, NBMINUS + INTEGER I1, I2, I3 + REAL*8 :: ELON1, ELON2, ELON3, ELON, ELONC + REAL*8 :: ELAT1, ELAT2, ELAT3, ELAT, ELATC + REAL *8 :: DELTALON12, DELTALON13, DELTALAT12, DELTALAT13 + REAL *8 :: THEDET + REAL*8 :: PT(3,2) + INTEGER, POINTER :: IOBP(:), TRIGINCD(:) + INTEGER, POINTER :: NEIGHBOR_PREV(:), NEIGHBOR_NEXT(:) + INTEGER, POINTER :: NBASSIGNEDCORNER(:), LISTNBCORNER(:) + INTEGER, POINTER :: STATUS(:), NEXTVERT(:), PREVVERT(:), FINALVERT(:) + INTEGER :: MAXCORNER, NBCORNER + INTEGER :: IDX, IPNEXT, IPPREV, NB, INEXT, IPREV + REAL*8, POINTER :: LON_CENT_TRIG(:), LAT_CENT_TRIG(:) + REAL*8 :: ELONIP, ELONNEXT, ELONPREV, ELONN, ELONP + REAL*8 :: ELATIP, ELATNEXT, ELATPREV, ELATN, ELATP + INTEGER :: ISFINISHED, ZPREV + INTEGER :: DODEBUG + GRID_RANK=2 + DIRAPPROACH=1 + DUALAPPROACH=2 + THEAPPROACH=DUALAPPROACH + MNE=GRIDS(ID_GRD)%NTRI + MNP=GRIDS(ID_GRD)%NX + IF (THEAPPROACH .EQ. DIRAPPROACH) THEN + ALLOCATE(GRID_CENTER_LON(MNE), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_CENTER_LAT(MNE), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_CORNER_LON(3,MNE), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_CORNER_LAT(3,MNE), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_MASK(MNE), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + DO IE=1,MNE + I1=GRIDS(ID_GRD)%TRIGP(1,IE) + I2=GRIDS(ID_GRD)%TRIGP(2,IE) + I3=GRIDS(ID_GRD)%TRIGP(3,IE) + ELON1=GRIDS(ID_GRD)%XGRD(1,I1) + ELON2=GRIDS(ID_GRD)%XGRD(1,I2) + ELON3=GRIDS(ID_GRD)%XGRD(1,I3) + ELAT1=GRIDS(ID_GRD)%YGRD(1,I1) + ELAT2=GRIDS(ID_GRD)%YGRD(1,I2) + ELAT3=GRIDS(ID_GRD)%YGRD(1,I3) + ELON=(ELON1 + ELON2 + ELON3)/3 + ELAT=(ELAT1 + ELAT2 + ELAT3)/3 + GRID_CENTER_LON(IE)=ELON + GRID_CENTER_LAT(IE)=ELAT + GRID_CORNER_LON(1,IE)=ELON1 + GRID_CORNER_LON(2,IE)=ELON2 + GRID_CORNER_LON(3,IE)=ELON3 + GRID_CORNER_LAT(1,IE)=ELAT1 + GRID_CORNER_LAT(2,IE)=ELAT2 + GRID_CORNER_LAT(3,IE)=ELAT3 + GRID_MASK(IE)=.TRUE. END DO + GRID_CORNERS=3 + END IF + IF (THEAPPROACH .EQ. DUALAPPROACH) THEN + ALLOCATE(TRIGINCD(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(IOBP(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(NEIGHBOR_NEXT(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(NEIGHBOR_PREV(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(NBASSIGNEDCORNER(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(LISTNBCORNER(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) -!.....step 3: save weights - DO ILINK=1,MAX_LINKS_MAP1 - - KSRC=GRID1_ADD_MAP1(ILINK) - JSRC=INT((KSRC-1)/NI_SRC)+1 - ISRC=KSRC-(JSRC-1)*NI_SRC - -!........note that this single if-then *must* be consistent with the -!........pair of if-thens above - IF ((GRID2_FRAC(GRID2_ADD_MAP1(ILINK))>FRAC_LOWEST) .AND. & - & (GRID2_FRAC(GRID2_ADD_MAP1(ILINK))=WT_LOWEST) .AND. & - & (WTS_MAP1(1,ILINK)<=WT_HIGHEST))THEN - IF (ABS(MAPSTA_SRC(JSRC,ISRC)).EQ.1) THEN ! sea point - WGTDATA(GRID2_ADD_MAP1(ILINK))%N= & - & WGTDATA(GRID2_ADD_MAP1(ILINK))%N+1 - WGTDATA(GRID2_ADD_MAP1(ILINK))%W(WGTDATA( & - & GRID2_ADD_MAP1(ILINK))%N)=WTS_MAP1(1,ILINK) - WGTDATA(GRID2_ADD_MAP1(ILINK))%K(WGTDATA( & - & GRID2_ADD_MAP1(ILINK))%N)=GRID1_ADD_MAP1(ILINK) - ENDIF - ENDIF - END DO + ALLOCATE(STATUS(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(NEXTVERT(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(PREVVERT(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(FINALVERT(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(LON_CENT_TRIG(MNE), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(LAT_CENT_TRIG(MNE), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + + CALL GET_UNSTRUCTURED_VERTEX_DEGREE (MNP, MNE, & + GRIDS(ID_GRD)%TRIGP, TRIGINCD) + CALL GET_BOUNDARY(MNP, MNE, GRIDS(id_grd)%TRIGP, IOBP, & + NEIGHBOR_PREV, NEIGHBOR_NEXT) -!.....step 4: re-normalize weights. This is necessary because we called -!.....scrip without the mask. Now that we have the mask in place, we need -!.....to re-normalize the weights. - DO KDST=1,GRID2_SIZE - IF (WGTDATA(KDST)%N > 0) THEN - WTSUM=ZERO - DO IPNT=1,WGTDATA(KDST)%N - WTSUM=WTSUM+WGTDATA(KDST)%W(IPNT) - END DO - DO IPNT=1,WGTDATA(KDST)%N - WGTDATA(KDST)%W(IPNT)=WGTDATA(KDST)%W(IPNT)/WTSUM - END DO - END IF + ! Find max number of corners + MAXCORNER=0 + DO IP=1,MNP + IF (NEIGHBOR_NEXT(IP) .EQ. 0) THEN + NBCORNER=TRIGINCD(IP) + ELSE + NBCORNER=TRIGINCD(IP) + 3 + END IF + LISTNBCORNER(IP)=NBCORNER + IF (NBCORNER .GT. MAXCORNER) THEN + MAXCORNER=NBCORNER + END IF END DO + GRID_CORNERS=MAXCORNER - CALL SCRIP_CLEAR - END SUBROUTINE SCRIP_WRAPPER + ALLOCATE(GRID_CENTER_LON(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_CENTER_LAT(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_CORNER_LON(MAXCORNER,MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_CORNER_LAT(MAXCORNER,MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_MASK(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) -!/ ------------------------------------------------------------------- / -!> -!> @brief Compute grid arrays for scrip for a specific unstructured grid. -!> -!> @details For interior vertices, we select for every triangle the barycenter -!> of the triangle. So to every node contained in N triangles we associate -!> a domain with N corners. Every one of those corners is contained -!> in 3 different domains. -!> -!> For nodes that are on the boundary, we have to proceed differently. -!> For every such node, we have NEIGHBOR_PREV and NEIGHBOR_NEXT which -!> are the neighbor on each side of the boundary. -!> We put a corner on the middle of the edge. We also put a corner -!> on the node itself. -!> -!> Note that instead of taking barycenters, we could have taken -!> Voronoi vertices, but this carries danger since Voronoi vertices -!> can be outside of the triangle. And it leaves open how to treat -!> the boundary. -!> -!> @param[in] ID_GRD -!> @param[out] GRID_CENTER_LON -!> @param[out] GRID_CENTER_LAT -!> @param[out] GRID_CORNER_LON -!> @param[out] GRID_CORNER_LAT -!> @param[out] GRID_MASK -!> @param[out] GRID_DIMS -!> @param[out] GRID_SIZE -!> @param[out] GRID_CORNERS -!> @param[out] GRID_RANK -!> -!> @author M. Dutour -!> @author A. Roland -!> @date 10-Dec-2014 -!> - SUBROUTINE GET_SCRIP_INFO_UNSTRUCTURED (ID_GRD, & - & GRID_CENTER_LON, GRID_CENTER_LAT, & - & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & - & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK) -!/ +-----------------------------------+ -!/ | WAVEWATCH III | -!/ | M. Dutour, A. Roland | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -! 1. Original author : -! -! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P -! -! 2. Last update : -! -! See revisions. -! -! 3. Revisions : -! -! 20-Feb-2012 : Origination -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -! -! 4. Copyright : -! -! 5. Purpose : -! -! Compute grid arrays for scrip for a specific unstructured grid -! For interior vertices, we select for every triangle the barycenter -! of the triangle. So to every node contained in N triangles we associate -! a domain with N corners. Every one of those corners is contained -! in 3 different domains. -! For nodes that are on the boundary, we have to proceed differently. -! For every such node, we have NEIGHBOR_PREV and NEIGHBOR_NEXT which -! are the neighbor on each side of the boundary. -! We put a corner on the middle of the edge. We also put a corner -! on the node itself. -! Note that instead of taking barycenters, we could have taken -! Voronoi vertices, but this carries danger since Voronoi vertices -! can be outside of the triangle. And it leaves open how to treat -! the boundary. -! -! 6. Method : -! -! 7. Parameters, Variables and types : -! -! 8. Called by : -! -! Subroutine get_scrip_info -! -! 9. Subroutines and functions used : -! -! 10. Error messages: -! -! 11. Remarks : -! -! 12. Structure : -! -! 13. Switches : -! -! 14. Source code : - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY : GRIDS - IMPLICIT NONE - INTEGER, INTENT(IN) :: ID_GRD - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LON(:) - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LAT(:) - LOGICAL, INTENT(OUT), ALLOCATABLE :: GRID_MASK(:) - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LON(:,:) - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LAT(:,:) - INTEGER, INTENT(OUT), ALLOCATABLE :: GRID_DIMS(:) - INTEGER, INTENT(OUT) :: GRID_SIZE, GRID_CORNERS, GRID_RANK - - INTEGER DIRAPPROACH, DUALAPPROACH, THEAPPROACH - INTEGER MNE, MNP, IE, IP, I - INTEGER NBPLUS, NBMINUS - INTEGER I1, I2, I3 - REAL*8 :: ELON1, ELON2, ELON3, ELON, ELONC - REAL*8 :: ELAT1, ELAT2, ELAT3, ELAT, ELATC - REAL *8 :: DELTALON12, DELTALON13, DELTALAT12, DELTALAT13 - REAL *8 :: THEDET - REAL*8 :: PT(3,2) - INTEGER, POINTER :: IOBP(:), TRIGINCD(:) - INTEGER, POINTER :: NEIGHBOR_PREV(:), NEIGHBOR_NEXT(:) - INTEGER, POINTER :: NBASSIGNEDCORNER(:), LISTNBCORNER(:) - INTEGER, POINTER :: STATUS(:), NEXTVERT(:), PREVVERT(:), FINALVERT(:) - INTEGER :: MAXCORNER, NBCORNER - INTEGER :: IDX, IPNEXT, IPPREV, NB, INEXT, IPREV - REAL*8, POINTER :: LON_CENT_TRIG(:), LAT_CENT_TRIG(:) - REAL*8 :: ELONIP, ELONNEXT, ELONPREV, ELONN, ELONP - REAL*8 :: ELATIP, ELATNEXT, ELATPREV, ELATN, ELATP - INTEGER :: ISFINISHED, ZPREV - INTEGER :: DODEBUG - GRID_RANK=2 - DIRAPPROACH=1 - DUALAPPROACH=2 - THEAPPROACH=DUALAPPROACH - MNE=GRIDS(ID_GRD)%NTRI - MNP=GRIDS(ID_GRD)%NX - IF (THEAPPROACH .EQ. DIRAPPROACH) THEN - ALLOCATE(GRID_CENTER_LON(MNE), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_CENTER_LAT(MNE), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_CORNER_LON(3,MNE), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_CORNER_LAT(3,MNE), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_MASK(MNE), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - DO IE=1,MNE - I1=GRIDS(ID_GRD)%TRIGP(1,IE) - I2=GRIDS(ID_GRD)%TRIGP(2,IE) - I3=GRIDS(ID_GRD)%TRIGP(3,IE) - ELON1=GRIDS(ID_GRD)%XGRD(1,I1) - ELON2=GRIDS(ID_GRD)%XGRD(1,I2) - ELON3=GRIDS(ID_GRD)%XGRD(1,I3) - ELAT1=GRIDS(ID_GRD)%YGRD(1,I1) - ELAT2=GRIDS(ID_GRD)%YGRD(1,I2) - ELAT3=GRIDS(ID_GRD)%YGRD(1,I3) - ELON=(ELON1 + ELON2 + ELON3)/3 - ELAT=(ELAT1 + ELAT2 + ELAT3)/3 - GRID_CENTER_LON(IE)=ELON - GRID_CENTER_LAT(IE)=ELAT - GRID_CORNER_LON(1,IE)=ELON1 - GRID_CORNER_LON(2,IE)=ELON2 - GRID_CORNER_LON(3,IE)=ELON3 - GRID_CORNER_LAT(1,IE)=ELAT1 - GRID_CORNER_LAT(2,IE)=ELAT2 - GRID_CORNER_LAT(3,IE)=ELAT3 - GRID_MASK(IE)=.TRUE. - END DO - GRID_CORNERS=3 - END IF - IF (THEAPPROACH .EQ. DUALAPPROACH) THEN - ALLOCATE(TRIGINCD(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(IOBP(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(NEIGHBOR_NEXT(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(NEIGHBOR_PREV(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(NBASSIGNEDCORNER(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(LISTNBCORNER(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - - ALLOCATE(STATUS(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(NEXTVERT(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(PREVVERT(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(FINALVERT(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(LON_CENT_TRIG(MNE), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(LAT_CENT_TRIG(MNE), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - - CALL GET_UNSTRUCTURED_VERTEX_DEGREE (MNP, MNE, & - GRIDS(ID_GRD)%TRIGP, TRIGINCD) - CALL GET_BOUNDARY(MNP, MNE, GRIDS(id_grd)%TRIGP, IOBP, & - NEIGHBOR_PREV, NEIGHBOR_NEXT) - - ! Find max number of corners - MAXCORNER=0 - DO IP=1,MNP - IF (NEIGHBOR_NEXT(IP) .EQ. 0) THEN - NBCORNER=TRIGINCD(IP) - ELSE - NBCORNER=TRIGINCD(IP) + 3 - END IF - LISTNBCORNER(IP)=NBCORNER - IF (NBCORNER .GT. MAXCORNER) THEN - MAXCORNER=NBCORNER - END IF - END DO - GRID_CORNERS=MAXCORNER - - ALLOCATE(GRID_CENTER_LON(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_CENTER_LAT(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_CORNER_LON(MAXCORNER,MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_CORNER_LAT(MAXCORNER,MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_MASK(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - - ! Add first three corners for boundaries - NBASSIGNEDCORNER(:)=0 - DO IP=1,MNP - GRID_MASK(IP)=.TRUE. - IF (NEIGHBOR_NEXT(IP) .GT. 0) THEN - IPNEXT=NEIGHBOR_NEXT(IP) - IPPREV=NEIGHBOR_PREV(IP) - ELONIP=DBLE(GRIDS(ID_GRD)%XGRD(1,IP)) - ELATIP=DBLE(GRIDS(ID_GRD)%YGRD(1,IP)) - ELONNEXT=DBLE(GRIDS(ID_GRD)%XGRD(1,IPNEXT)) - ELATNEXT=DBLE(GRIDS(ID_GRD)%YGRD(1,IPNEXT)) - ELONPREV=DBLE(GRIDS(ID_GRD)%XGRD(1,IPPREV)) - ELATPREV=DBLE(GRIDS(ID_GRD)%YGRD(1,IPPREV)) - - ! Periodicity fix for corner node - IF ( ABS(ELONIP - ELONNEXT) .GT. 180.0 ) THEN - ELONNEXT = ELONNEXT -SIGN(360.0d0,(ELONIP - ELONNEXT)) - ENDIF - IF ( ABS(ELONIP - ELONPREV) .GT. 180.0 ) THEN - ELONPREV = ELONPREV -SIGN(360.0d0,(ELONIP - ELONPREV)) - ENDIF + ! Add first three corners for boundaries + NBASSIGNEDCORNER(:)=0 + DO IP=1,MNP + GRID_MASK(IP)=.TRUE. + IF (NEIGHBOR_NEXT(IP) .GT. 0) THEN + IPNEXT=NEIGHBOR_NEXT(IP) + IPPREV=NEIGHBOR_PREV(IP) + ELONIP=DBLE(GRIDS(ID_GRD)%XGRD(1,IP)) + ELATIP=DBLE(GRIDS(ID_GRD)%YGRD(1,IP)) + ELONNEXT=DBLE(GRIDS(ID_GRD)%XGRD(1,IPNEXT)) + ELATNEXT=DBLE(GRIDS(ID_GRD)%YGRD(1,IPNEXT)) + ELONPREV=DBLE(GRIDS(ID_GRD)%XGRD(1,IPPREV)) + ELATPREV=DBLE(GRIDS(ID_GRD)%YGRD(1,IPPREV)) + + ! Periodicity fix for corner node + IF ( ABS(ELONIP - ELONNEXT) .GT. 180.0 ) THEN + ELONNEXT = ELONNEXT -SIGN(360.0d0,(ELONIP - ELONNEXT)) + ENDIF + IF ( ABS(ELONIP - ELONPREV) .GT. 180.0 ) THEN + ELONPREV = ELONPREV -SIGN(360.0d0,(ELONIP - ELONPREV)) + ENDIF + + ELONN=(ELONIP+ELONNEXT)/2.0 + ELATN=(ELATIP+ELATNEXT)/2.0 + ELONP=(ELONIP+ELONPREV)/2.0 + ELATP=(ELATIP+ELATPREV)/2.0 + + + GRID_CORNER_LON(1,IP)=ELONN + GRID_CORNER_LAT(1,IP)=ELATN + GRID_CORNER_LON(2,IP)=ELONIP + GRID_CORNER_LAT(2,IP)=ELATIP + GRID_CORNER_LON(3,IP)=ELONP + GRID_CORNER_LAT(3,IP)=ELATP + NBASSIGNEDCORNER(IP)=3 + END IF + END DO - ELONN=(ELONIP+ELONNEXT)/2.0 - ELATN=(ELATIP+ELATNEXT)/2.0 - ELONP=(ELONIP+ELONPREV)/2.0 - ELATP=(ELATIP+ELATPREV)/2.0 - - - GRID_CORNER_LON(1,IP)=ELONN - GRID_CORNER_LAT(1,IP)=ELATN - GRID_CORNER_LON(2,IP)=ELONIP - GRID_CORNER_LAT(2,IP)=ELATIP - GRID_CORNER_LON(3,IP)=ELONP - GRID_CORNER_LAT(3,IP)=ELATP - NBASSIGNEDCORNER(IP)=3 - END IF - END DO + ! Compute centers + DO IP=1,MNP + GRID_CENTER_LON(IP)=DBLE(GRIDS(ID_GRD)%XGRD(1,IP)) + GRID_CENTER_LAT(IP)=DBLE(GRIDS(ID_GRD)%YGRD(1,IP)) + END DO - ! Compute centers - DO IP=1,MNP - GRID_CENTER_LON(IP)=DBLE(GRIDS(ID_GRD)%XGRD(1,IP)) - GRID_CENTER_LAT(IP)=DBLE(GRIDS(ID_GRD)%YGRD(1,IP)) - END DO + ! Check triangle node orientation + ! Compute triangle centers + NBPLUS=0 + NBMINUS=0 + DO IE=1,MNE + I1=GRIDS(ID_GRD)%TRIGP(1,IE) + I2=GRIDS(ID_GRD)%TRIGP(2,IE) + I3=GRIDS(ID_GRD)%TRIGP(3,IE) + PT(1,1)=DBLE(GRIDS(ID_GRD)%XGRD(1,I1)) + PT(2,1)=DBLE(GRIDS(ID_GRD)%XGRD(1,I2)) + PT(3,1)=DBLE(GRIDS(ID_GRD)%XGRD(1,I3)) + PT(1,2)=DBLE(GRIDS(ID_GRD)%YGRD(1,I1)) + PT(2,2)=DBLE(GRIDS(ID_GRD)%YGRD(1,I2)) + PT(3,2)=DBLE(GRIDS(ID_GRD)%YGRD(1,I3)) + + CALL FIX_PERIODCITY(PT) + + ELON1 = PT(1,1) + ELON2 = PT(2,1) + ELON3 = PT(3,1) + ELAT1 = PT(1,2) + ELAT2 = PT(2,2) + ELAT3 = PT(3,2) + + DELTALON12=ELON2 - ELON1 + DELTALON13=ELON3 - ELON1 + DELTALAT12=ELAT2 - ELAT1 + DELTALAT13=ELAT3 - ELAT1 + THEDET=DELTALON12*DELTALAT13 - DELTALON13*DELTALAT12 + IF (THEDET.GT.0) THEN + NBPLUS=NBPLUS+1 + END IF + IF (THEDET.LT.0) THEN + NBMINUS=NBMINUS+1 + END IF + ELON=(ELON1 + ELON2 + ELON3)/3.0 + ELAT=(ELAT1 + ELAT2 + ELAT3)/3.0 - ! Check triangle node orientation - ! Compute triangle centers - NBPLUS=0 - NBMINUS=0 - DO IE=1,MNE - I1=GRIDS(ID_GRD)%TRIGP(1,IE) - I2=GRIDS(ID_GRD)%TRIGP(2,IE) - I3=GRIDS(ID_GRD)%TRIGP(3,IE) - PT(1,1)=DBLE(GRIDS(ID_GRD)%XGRD(1,I1)) - PT(2,1)=DBLE(GRIDS(ID_GRD)%XGRD(1,I2)) - PT(3,1)=DBLE(GRIDS(ID_GRD)%XGRD(1,I3)) - PT(1,2)=DBLE(GRIDS(ID_GRD)%YGRD(1,I1)) - PT(2,2)=DBLE(GRIDS(ID_GRD)%YGRD(1,I2)) - PT(3,2)=DBLE(GRIDS(ID_GRD)%YGRD(1,I3)) - CALL FIX_PERIODCITY(PT) + LON_CENT_TRIG(IE)=ELON + LAT_CENT_TRIG(IE)=ELAT - ELON1 = PT(1,1) - ELON2 = PT(2,1) - ELON3 = PT(3,1) - ELAT1 = PT(1,2) - ELAT2 = PT(2,2) - ELAT3 = PT(3,2) - - DELTALON12=ELON2 - ELON1 - DELTALON13=ELON3 - ELON1 - DELTALAT12=ELAT2 - ELAT1 - DELTALAT13=ELAT3 - ELAT1 - THEDET=DELTALON12*DELTALAT13 - DELTALON13*DELTALAT12 - IF (THEDET.GT.0) THEN - NBPLUS=NBPLUS+1 - END IF - IF (THEDET.LT.0) THEN - NBMINUS=NBMINUS+1 - END IF - ELON=(ELON1 + ELON2 + ELON3)/3.0 - ELAT=(ELAT1 + ELAT2 + ELAT3)/3.0 - - - LON_CENT_TRIG(IE)=ELON - LAT_CENT_TRIG(IE)=ELAT + END DO + DODEBUG=0 + IF (DODEBUG.EQ.1) THEN + print *, 'nbplus=', nbplus, ' nbminus=', nbminus + END IF + STATUS(:) = 0 + NEXTVERT(:) = 0 + PREVVERT(:) = 0 + DO IE=1,MNE + DO I=1,3 + CALL TRIANG_INDEXES(I, INEXT, IPREV) + IP=GRIDS(ID_GRD)%TRIGP(I,IE) + IPNEXT=GRIDS(ID_GRD)%TRIGP(INEXT,IE) + IPPREV=GRIDS(ID_GRD)%TRIGP(IPREV,IE) + IF (STATUS(IP).EQ.0) THEN + IF (NEIGHBOR_NEXT(IP).EQ.0) THEN + STATUS(IP)=1 + FINALVERT(IP)=IPPREV + PREVVERT(IP)=IPPREV + NEXTVERT(IP)=IPNEXT + ELSE + IF (NEIGHBOR_PREV(IP).EQ.IPPREV) THEN + STATUS(IP)=1 + PREVVERT(IP)=IPPREV + NEXTVERT(IP)=IPNEXT + FINALVERT(IP)=NEIGHBOR_NEXT(IP) + END IF + END IF + END IF END DO - DODEBUG=0 - IF (DODEBUG.EQ.1) THEN - print *, 'nbplus=', nbplus, ' nbminus=', nbminus - END IF - - STATUS(:) = 0 - NEXTVERT(:) = 0 - PREVVERT(:) = 0 + END DO + STATUS(:)=0 + DO + ISFINISHED=1 DO IE=1,MNE + ELON=LON_CENT_TRIG(IE) + ELAT=LAT_CENT_TRIG(IE) DO I=1,3 CALL TRIANG_INDEXES(I, INEXT, IPREV) IP=GRIDS(ID_GRD)%TRIGP(I,IE) IPNEXT=GRIDS(ID_GRD)%TRIGP(INEXT,IE) IPPREV=GRIDS(ID_GRD)%TRIGP(IPREV,IE) IF (STATUS(IP).EQ.0) THEN - IF (NEIGHBOR_NEXT(IP).EQ.0) THEN - STATUS(IP)=1 - FINALVERT(IP)=IPPREV - PREVVERT(IP)=IPPREV - NEXTVERT(IP)=IPNEXT - ELSE - IF (NEIGHBOR_PREV(IP).EQ.IPPREV) THEN + ISFINISHED=0 + ZPREV=PREVVERT(IP) + IF (ZPREV.EQ.IPPREV) THEN + IDX=NBASSIGNEDCORNER(IP) + IDX=IDX+1 + GRID_CORNER_LON(IDX,IP)=ELON + GRID_CORNER_LAT(IDX,IP)=ELAT + NBASSIGNEDCORNER(IP)=IDX + PREVVERT(IP)=IPNEXT + IF (IPNEXT.EQ.FINALVERT(IP)) THEN STATUS(IP)=1 - PREVVERT(IP)=IPPREV - NEXTVERT(IP)=IPNEXT - FINALVERT(IP)=NEIGHBOR_NEXT(IP) END IF END IF END IF END DO END DO - STATUS(:)=0 - DO - ISFINISHED=1 - DO IE=1,MNE - ELON=LON_CENT_TRIG(IE) - ELAT=LAT_CENT_TRIG(IE) - DO I=1,3 - CALL TRIANG_INDEXES(I, INEXT, IPREV) - IP=GRIDS(ID_GRD)%TRIGP(I,IE) - IPNEXT=GRIDS(ID_GRD)%TRIGP(INEXT,IE) - IPPREV=GRIDS(ID_GRD)%TRIGP(IPREV,IE) - IF (STATUS(IP).EQ.0) THEN - ISFINISHED=0 - ZPREV=PREVVERT(IP) - IF (ZPREV.EQ.IPPREV) THEN - IDX=NBASSIGNEDCORNER(IP) - IDX=IDX+1 - GRID_CORNER_LON(IDX,IP)=ELON - GRID_CORNER_LAT(IDX,IP)=ELAT - NBASSIGNEDCORNER(IP)=IDX - PREVVERT(IP)=IPNEXT - IF (IPNEXT.EQ.FINALVERT(IP)) THEN - STATUS(IP)=1 - END IF - END IF - END IF - END DO - END DO - IF (ISFINISHED.EQ.1) THEN - EXIT - END IF - END DO - DO IP=1,MNP - IF (NBASSIGNEDCORNER(IP).NE.LISTNBCORNER(IP)) THEN - WRITE(*,*) 'Incoherent number at IP=', IP - WRITE(*,*) ' NbAssignedCorner(IP)=', NbAssignedCorner(IP) - WRITE(*,*) ' ListNbCorner(IP)=', ListNbCorner(IP) - WRITE(*,*) ' N_N=', NEIGHBOR_NEXT(IP), 'N_P=', NEIGHBOR_PREV(IP) - WRITE(*,*) ' TrigIncd=', TrigIncd(IP) - STOP 'wmscrpmd, case 2' - END IF - END DO - - ! if the number of corner is below threshold, we have to - ! add some more. - DO IP=1,MNP - NB=NBASSIGNEDCORNER(IP) - IF (NB .LT. MAXCORNER) THEN - ELON=GRID_CORNER_LON(NB,IP) - ELAT=GRID_CORNER_LAT(NB,IP) - DO IDX=NB+1,MAXCORNER - GRID_CORNER_LON(IDX,IP)=ELON - GRID_CORNER_LAT(IDX,IP)=ELAT - END DO - END IF - END DO - DEALLOCATE(NBASSIGNEDCORNER, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(LISTNBCORNER, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(TRIGINCD, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(IOBP, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(NEIGHBOR_PREV, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(NEIGHBOR_NEXT, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(STATUS, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(NEXTVERT, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(PREVVERT, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(FINALVERT, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(LON_CENT_TRIG, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(LAT_CENT_TRIG, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - - ALLOCATE(GRID_DIMS(2), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - GRID_DIMS(1)=MNP - GRID_DIMS(2)=1 - GRID_SIZE=MNP - END IF - END SUBROUTINE GET_SCRIP_INFO_UNSTRUCTURED - -!/ ------------------------------------------------------------------- / -!> -!> @brief Compute grid arrays needed for scrip for a specific -!> structured grid. -!> -!> @details This is adapted from Erick Rogers original code by -!> splitting the original scrip_wrapper function. -!> -!> @param[in] ID_GRD -!> @param[out] GRID_CENTER_LON -!> @param[out] GRID_CENTER_LAT -!> @param[out] GRID_CORNER_LON -!> @param[out] GRID_CORNER_LAT -!> @param[out] GRID_MASK -!> @param[out] GRID_DIMS -!> @param[out] GRID_SIZE -!> @param[out] GRID_CORNERS -!> @param[out] GRID_RANK -!> -!> @author M. Dutour -!> @author A. Roland -!> @date 10-Dec-2014 -!> - SUBROUTINE GET_SCRIP_INFO_STRUCTURED (ID_GRD, & - & GRID_CENTER_LON, GRID_CENTER_LAT, & - & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & - & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK) -!/ +-----------------------------------+ -!/ | WAVEWATCH III | -!/ | M. Dutour, A. Roland | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -! 1. Original author : -! -! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P -! -! 2. Last update : -! -! See revisions. -! -! 3. Revisions : -! -! 20-Feb-2012 : Origination, this is adapted from Erick Rogers -! code by splitting the code into sections. -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -! -! 4. Copyright : -! -! 5. Purpose : -! -! Compute grid arrays needed for scrip for a specific structured grid. -! This is adapted from Erick Rogers original code by splitting -! the original scrip_wrapper function -! -! 6. Method : -! -! 7. Parameters, Variables and types : -! -! 8. Called by : -! -! Subroutine get_scrip_info -! -! 9. Subroutines and functions used : -! -! 10. Error messages: -! -! 11. Remarks : -! -! 12. Structure : -! -! 13. Switches : -! -! 14. Source code : - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY : GRIDS - USE SCRIP_CONSTANTS, ONLY : HALF - IMPLICIT NONE - INTEGER, INTENT(IN) :: ID_GRD - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LON(:) - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LAT(:) - LOGICAL, INTENT(OUT), ALLOCATABLE :: GRID_MASK(:) - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LON(:,:) - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LAT(:,:) - INTEGER, INTENT(OUT), ALLOCATABLE :: GRID_DIMS(:) - INTEGER, INTENT(OUT) :: GRID_SIZE, GRID_CORNERS, GRID_RANK -! - REAL*8, ALLOCATABLE :: XIN_GRD(:,:), YIN_GRD(:,:) - REAL*8, ALLOCATABLE :: DXDP_GRD(:,:), DXDQ_GRD(:,:) - REAL*8, ALLOCATABLE :: DYDP_GRD(:,:), DYDQ_GRD(:,:) - INTEGER :: N1, N2, NI, NJ - INTEGER :: IREC, J, I - GRID_RANK=2 - N1=SIZE(GRIDS(ID_GRD)%XGRD,1) - N2=SIZE(GRIDS(ID_GRD)%XGRD,2) - ALLOCATE(XIN_GRD(N1,N2), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(YIN_GRD(N1,N2), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(DXDP_GRD(N1,N2), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(DXDQ_GRD(N1,N2), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(DYDP_GRD(N1,N2), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(DYDQ_GRD(N1,N2), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - - XIN_GRD=DBLE(GRIDS(ID_GRD)%XGRD) - YIN_GRD=DBLE(GRIDS(ID_GRD)%YGRD) - DXDP_GRD=DBLE(GRIDS(ID_GRD)%DXDP) - DXDQ_GRD=DBLE(GRIDS(ID_GRD)%DXDQ) - DYDP_GRD=DBLE(GRIDS(ID_GRD)%DYDP) - DYDQ_GRD=DBLE(GRIDS(ID_GRD)%DYDQ) - - ALLOCATE(GRID_DIMS(GRID_RANK), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - GRID_DIMS(1)=N2 - NI=N2 - GRID_DIMS(2)=N1 - NJ=N1 - - GRID_SIZE=NI*NJ ! hardwired: logically rectangular grid - GRID_CORNERS=4 ! hardwired: each cell has 4 corners - -!.....notes: unfortunately, scrip only works for spherical coordinates. -! thus, if we want to have a multi-grid case in meters, we have to -! fake it. fortunately, it should be pretty rare to have a multi-grid -! case in meters. + IF (ISFINISHED.EQ.1) THEN + EXIT + END IF + END DO + DO IP=1,MNP + IF (NBASSIGNEDCORNER(IP).NE.LISTNBCORNER(IP)) THEN + WRITE(*,*) 'Incoherent number at IP=', IP + WRITE(*,*) ' NbAssignedCorner(IP)=', NbAssignedCorner(IP) + WRITE(*,*) ' ListNbCorner(IP)=', ListNbCorner(IP) + WRITE(*,*) ' N_N=', NEIGHBOR_NEXT(IP), 'N_P=', NEIGHBOR_PREV(IP) + WRITE(*,*) ' TrigIncd=', TrigIncd(IP) + STOP 'wmscrpmd, case 2' + END IF + END DO - ALLOCATE(GRID_CENTER_LON(NI*NJ), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_CENTER_LAT(NI*NJ), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_CORNER_LON(4,NI*NJ), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_CORNER_LAT(4,NI*NJ), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(GRID_MASK(NI*NJ), STAT=ISTAT) + ! if the number of corner is below threshold, we have to + ! add some more. + DO IP=1,MNP + NB=NBASSIGNEDCORNER(IP) + IF (NB .LT. MAXCORNER) THEN + ELON=GRID_CORNER_LON(NB,IP) + ELAT=GRID_CORNER_LAT(NB,IP) + DO IDX=NB+1,MAXCORNER + GRID_CORNER_LON(IDX,IP)=ELON + GRID_CORNER_LAT(IDX,IP)=ELAT + END DO + END IF + END DO + DEALLOCATE(NBASSIGNEDCORNER, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(LISTNBCORNER, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(TRIGINCD, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(IOBP, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(NEIGHBOR_PREV, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(NEIGHBOR_NEXT, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(STATUS, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(NEXTVERT, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(PREVVERT, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(FINALVERT, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(LON_CENT_TRIG, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(LAT_CENT_TRIG, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + + ALLOCATE(GRID_DIMS(2), STAT=ISTAT) CHECK_ALLOC_STATUS ( ISTAT ) - -!.....notes: this "gridshift" variable is included because SCRIP sometimes -! has trouble when grids cell locations are identical between -! the two grids. Thus we apply this to one of the two grids. - -!.....notes: The following block of code could be converted to a subroutine. -! Since it is called twice, this would save a little space. - IREC=0 - DO J=1,NJ - DO I=1,NI - IREC=IREC+1 - GRID_CENTER_LON(IREC)=XIN_GRD(J,I) - GRID_CENTER_LAT(IREC)=YIN_GRD(J,I) - GRID_MASK(IREC)=.TRUE. - -!..notes: normally, we'd apply the mask like this: -! if(abs(mapsta_src(j,i)).eq.1)then -! grid1_mask(irec)=.true. -! else -! grid1_mask(irec)=.false. -! endif -!..but unfortunately, WMGHGH needs information about the overlaying high-res -! cells, even those that are masked, for calculating -! NRL, NR0, NR1, NR2. - -!...........corner 1 : halfway to i-1,j-1 - GRID_CORNER_LON(1,IREC)=GRID_CENTER_LON(IREC)- & - & HALF*DXDP_GRD(J,I)-HALF*DXDQ_GRD(J,I) - GRID_CORNER_LAT(1,IREC)=GRID_CENTER_LAT(IREC)- & - & HALF*DYDP_GRD(J,I)-HALF*DYDQ_GRD(J,I) - -!...........corner 2: halfway to i+1,j-1 - GRID_CORNER_LON(2,IREC)=GRID_CENTER_LON(IREC)+ & - & HALF*DXDP_GRD(J,I)-HALF*DXDQ_GRD(J,I) - GRID_CORNER_LAT(2,IREC)=GRID_CENTER_LAT(IREC)+ & - & HALF*DYDP_GRD(J,I)-HALF*DYDQ_GRD(J,I) - -!...........corner 3: halfway to i+1,j+1 - GRID_CORNER_LON(3,IREC)=GRID_CENTER_LON(IREC)+ & - & HALF*DXDP_GRD(J,I)+HALF*DXDQ_GRD(J,I) - GRID_CORNER_LAT(3,IREC)=GRID_CENTER_LAT(IREC)+ & - & HALF*DYDP_GRD(J,I)+HALF*DYDQ_GRD(J,I) - -!...........corner 4: halfway to i-1,j+1 - GRID_CORNER_LON(4,IREC)=GRID_CENTER_LON(IREC)- & - & HALF*DXDP_GRD(J,I)+HALF*DXDQ_GRD(J,I) - GRID_CORNER_LAT(4,IREC)=GRID_CENTER_LAT(IREC)- & - & HALF*DYDP_GRD(J,I)+HALF*DYDQ_GRD(J,I) - END DO + GRID_DIMS(1)=MNP + GRID_DIMS(2)=1 + GRID_SIZE=MNP + END IF + END SUBROUTINE GET_SCRIP_INFO_UNSTRUCTURED + + !/ ------------------------------------------------------------------- / + !> + !> @brief Compute grid arrays needed for scrip for a specific + !> structured grid. + !> + !> @details This is adapted from Erick Rogers original code by + !> splitting the original scrip_wrapper function. + !> + !> @param[in] ID_GRD + !> @param[out] GRID_CENTER_LON + !> @param[out] GRID_CENTER_LAT + !> @param[out] GRID_CORNER_LON + !> @param[out] GRID_CORNER_LAT + !> @param[out] GRID_MASK + !> @param[out] GRID_DIMS + !> @param[out] GRID_SIZE + !> @param[out] GRID_CORNERS + !> @param[out] GRID_RANK + !> + !> @author M. Dutour + !> @author A. Roland + !> @date 10-Dec-2014 + !> + SUBROUTINE GET_SCRIP_INFO_STRUCTURED (ID_GRD, & + & GRID_CENTER_LON, GRID_CENTER_LAT, & + & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & + & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK) + !/ +-----------------------------------+ + !/ | WAVEWATCH III | + !/ | M. Dutour, A. Roland | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + ! 1. Original author : + ! + ! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P + ! + ! 2. Last update : + ! + ! See revisions. + ! + ! 3. Revisions : + ! + ! 20-Feb-2012 : Origination, this is adapted from Erick Rogers + ! code by splitting the code into sections. + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + ! + ! 4. Copyright : + ! + ! 5. Purpose : + ! + ! Compute grid arrays needed for scrip for a specific structured grid. + ! This is adapted from Erick Rogers original code by splitting + ! the original scrip_wrapper function + ! + ! 6. Method : + ! + ! 7. Parameters, Variables and types : + ! + ! 8. Called by : + ! + ! Subroutine get_scrip_info + ! + ! 9. Subroutines and functions used : + ! + ! 10. Error messages: + ! + ! 11. Remarks : + ! + ! 12. Structure : + ! + ! 13. Switches : + ! + ! 14. Source code : + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY : GRIDS + USE SCRIP_CONSTANTS, ONLY : HALF + IMPLICIT NONE + INTEGER, INTENT(IN) :: ID_GRD + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LON(:) + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LAT(:) + LOGICAL, INTENT(OUT), ALLOCATABLE :: GRID_MASK(:) + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LON(:,:) + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LAT(:,:) + INTEGER, INTENT(OUT), ALLOCATABLE :: GRID_DIMS(:) + INTEGER, INTENT(OUT) :: GRID_SIZE, GRID_CORNERS, GRID_RANK + ! + REAL*8, ALLOCATABLE :: XIN_GRD(:,:), YIN_GRD(:,:) + REAL*8, ALLOCATABLE :: DXDP_GRD(:,:), DXDQ_GRD(:,:) + REAL*8, ALLOCATABLE :: DYDP_GRD(:,:), DYDQ_GRD(:,:) + INTEGER :: N1, N2, NI, NJ + INTEGER :: IREC, J, I + GRID_RANK=2 + N1=SIZE(GRIDS(ID_GRD)%XGRD,1) + N2=SIZE(GRIDS(ID_GRD)%XGRD,2) + ALLOCATE(XIN_GRD(N1,N2), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(YIN_GRD(N1,N2), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(DXDP_GRD(N1,N2), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(DXDQ_GRD(N1,N2), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(DYDP_GRD(N1,N2), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(DYDQ_GRD(N1,N2), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + + XIN_GRD=DBLE(GRIDS(ID_GRD)%XGRD) + YIN_GRD=DBLE(GRIDS(ID_GRD)%YGRD) + DXDP_GRD=DBLE(GRIDS(ID_GRD)%DXDP) + DXDQ_GRD=DBLE(GRIDS(ID_GRD)%DXDQ) + DYDP_GRD=DBLE(GRIDS(ID_GRD)%DYDP) + DYDQ_GRD=DBLE(GRIDS(ID_GRD)%DYDQ) + + ALLOCATE(GRID_DIMS(GRID_RANK), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + GRID_DIMS(1)=N2 + NI=N2 + GRID_DIMS(2)=N1 + NJ=N1 + + GRID_SIZE=NI*NJ ! hardwired: logically rectangular grid + GRID_CORNERS=4 ! hardwired: each cell has 4 corners + + !.....notes: unfortunately, scrip only works for spherical coordinates. + ! thus, if we want to have a multi-grid case in meters, we have to + ! fake it. fortunately, it should be pretty rare to have a multi-grid + ! case in meters. + + ALLOCATE(GRID_CENTER_LON(NI*NJ), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_CENTER_LAT(NI*NJ), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_CORNER_LON(4,NI*NJ), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_CORNER_LAT(4,NI*NJ), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(GRID_MASK(NI*NJ), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + + !.....notes: this "gridshift" variable is included because SCRIP sometimes + ! has trouble when grids cell locations are identical between + ! the two grids. Thus we apply this to one of the two grids. + + !.....notes: The following block of code could be converted to a subroutine. + ! Since it is called twice, this would save a little space. + IREC=0 + DO J=1,NJ + DO I=1,NI + IREC=IREC+1 + GRID_CENTER_LON(IREC)=XIN_GRD(J,I) + GRID_CENTER_LAT(IREC)=YIN_GRD(J,I) + GRID_MASK(IREC)=.TRUE. + + !..notes: normally, we'd apply the mask like this: + ! if(abs(mapsta_src(j,i)).eq.1)then + ! grid1_mask(irec)=.true. + ! else + ! grid1_mask(irec)=.false. + ! endif + !..but unfortunately, WMGHGH needs information about the overlaying high-res + ! cells, even those that are masked, for calculating + ! NRL, NR0, NR1, NR2. + + !...........corner 1 : halfway to i-1,j-1 + GRID_CORNER_LON(1,IREC)=GRID_CENTER_LON(IREC)- & + & HALF*DXDP_GRD(J,I)-HALF*DXDQ_GRD(J,I) + GRID_CORNER_LAT(1,IREC)=GRID_CENTER_LAT(IREC)- & + & HALF*DYDP_GRD(J,I)-HALF*DYDQ_GRD(J,I) + + !...........corner 2: halfway to i+1,j-1 + GRID_CORNER_LON(2,IREC)=GRID_CENTER_LON(IREC)+ & + & HALF*DXDP_GRD(J,I)-HALF*DXDQ_GRD(J,I) + GRID_CORNER_LAT(2,IREC)=GRID_CENTER_LAT(IREC)+ & + & HALF*DYDP_GRD(J,I)-HALF*DYDQ_GRD(J,I) + + !...........corner 3: halfway to i+1,j+1 + GRID_CORNER_LON(3,IREC)=GRID_CENTER_LON(IREC)+ & + & HALF*DXDP_GRD(J,I)+HALF*DXDQ_GRD(J,I) + GRID_CORNER_LAT(3,IREC)=GRID_CENTER_LAT(IREC)+ & + & HALF*DYDP_GRD(J,I)+HALF*DYDQ_GRD(J,I) + + !...........corner 4: halfway to i-1,j+1 + GRID_CORNER_LON(4,IREC)=GRID_CENTER_LON(IREC)- & + & HALF*DXDP_GRD(J,I)+HALF*DXDQ_GRD(J,I) + GRID_CORNER_LAT(4,IREC)=GRID_CENTER_LAT(IREC)- & + & HALF*DYDP_GRD(J,I)+HALF*DYDQ_GRD(J,I) END DO - END SUBROUTINE GET_SCRIP_INFO_STRUCTURED - -!/ ------------------------------------------------------------------- / -!> -!> @brief Compute grid for scrip for a specific structured grid. -!> -!> @details This is adapted from Erick Rogers code by making it cleaner. -!> -!> @param[in] ID_GRD -!> @param[out] GRID_CENTER_LON -!> @param[out] GRID_CENTER_LAT -!> @param[out] GRID_CORNER_LON -!> @param[out] GRID_CORNER_LAT -!> @param[out] GRID_MASK -!> @param[out] GRID_DIMS -!> @param[out] GRID_SIZE -!> @param[out] GRID_CORNERS -!> @param[out] GRID_RANK -!> -!> @author M. Dutour -!> @author A. Roland -!> @date 20-Feb-2012 -!> - SUBROUTINE GET_SCRIP_INFO(ID_GRD, & - & GRID_CENTER_LON, GRID_CENTER_LAT, & - & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & - & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK) -! 1. Original author : -! -! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P -! -! 2. Last update : -! -! See revisions. -! -! 3. Revisions : -! -! 20-Feb-2012 : Origination, this is adapted from Erick Rogers -! code by splitting the code into sections. -! -! 4. Copyright : -! -! 5. Purpose : -! -! Compute grid for scrip for a specific structured grid. -! This is adapted from Erick Rogers code by making it cleaner. -! -! 6. Method : -! -! 7. Parameters, Variables and types : -! -! 8. Called by : -! -! Subroutine scrip_wrapper -! -! 9. Subroutines and functions used : -! -! 10. Error messages: -! -! 11. Remarks : -! -! 12. Structure : -! -! 13. Switches : -! -! 14. Source code : - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY : GRIDS, UNGTYPE - IMPLICIT NONE - INTEGER, INTENT(IN) :: ID_GRD - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LON(:) - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LAT(:) - LOGICAL, INTENT(OUT), ALLOCATABLE :: GRID_MASK(:) - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LON(:,:) - REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LAT(:,:) - INTEGER, INTENT(OUT), ALLOCATABLE :: GRID_DIMS(:) - INTEGER, INTENT(OUT) :: GRID_SIZE, GRID_CORNERS, GRID_RANK - REAL*8 :: DLON1, DLAT1, DLON2, DLAT2, THEDET - INTEGER :: I, J - INTEGER :: IC, JC, IP, CHECKSIGNS, NBPLUS, NBMINUS, NBZERO - INTEGER :: PRINTDATA, PRINTMINMAX - REAL*8 :: MINLON, MINLAT, MAXLON, MAXLAT - REAL*8 :: MINLONCORNER, MAXLONCORNER, MINLATCORNER, MAXLATCORNER - REAL*8 :: PT(3,2) - IF (GRIDS(ID_GRD)%GTYPE .EQ. UNGTYPE) THEN - CALL GET_SCRIP_INFO_UNSTRUCTURED (ID_GRD, & - & GRID_CENTER_LON, GRID_CENTER_LAT, & - & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & - & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK) - ELSE - CALL GET_SCRIP_INFO_STRUCTURED (ID_GRD, & - & GRID_CENTER_LON, GRID_CENTER_LAT, & - & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & - & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK) - END IF - CHECKSIGNS=1 - IF (CHECKSIGNS.EQ.1) THEN - NBPLUS=0 - NBMINUS=0 - NBZERO=0 - DO IP=1,GRID_SIZE - DO IC=1,GRID_CORNERS - IF (IC.EQ.GRID_CORNERS) THEN - JC=1 - ELSE - JC=IC+1 - END IF + END DO + END SUBROUTINE GET_SCRIP_INFO_STRUCTURED + + !/ ------------------------------------------------------------------- / + !> + !> @brief Compute grid for scrip for a specific structured grid. + !> + !> @details This is adapted from Erick Rogers code by making it cleaner. + !> + !> @param[in] ID_GRD + !> @param[out] GRID_CENTER_LON + !> @param[out] GRID_CENTER_LAT + !> @param[out] GRID_CORNER_LON + !> @param[out] GRID_CORNER_LAT + !> @param[out] GRID_MASK + !> @param[out] GRID_DIMS + !> @param[out] GRID_SIZE + !> @param[out] GRID_CORNERS + !> @param[out] GRID_RANK + !> + !> @author M. Dutour + !> @author A. Roland + !> @date 20-Feb-2012 + !> + SUBROUTINE GET_SCRIP_INFO(ID_GRD, & + & GRID_CENTER_LON, GRID_CENTER_LAT, & + & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & + & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK) + ! 1. Original author : + ! + ! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P + ! + ! 2. Last update : + ! + ! See revisions. + ! + ! 3. Revisions : + ! + ! 20-Feb-2012 : Origination, this is adapted from Erick Rogers + ! code by splitting the code into sections. + ! + ! 4. Copyright : + ! + ! 5. Purpose : + ! + ! Compute grid for scrip for a specific structured grid. + ! This is adapted from Erick Rogers code by making it cleaner. + ! + ! 6. Method : + ! + ! 7. Parameters, Variables and types : + ! + ! 8. Called by : + ! + ! Subroutine scrip_wrapper + ! + ! 9. Subroutines and functions used : + ! + ! 10. Error messages: + ! + ! 11. Remarks : + ! + ! 12. Structure : + ! + ! 13. Switches : + ! + ! 14. Source code : + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY : GRIDS, UNGTYPE + IMPLICIT NONE + INTEGER, INTENT(IN) :: ID_GRD + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LON(:) + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CENTER_LAT(:) + LOGICAL, INTENT(OUT), ALLOCATABLE :: GRID_MASK(:) + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LON(:,:) + REAL*8, INTENT(OUT), ALLOCATABLE :: GRID_CORNER_LAT(:,:) + INTEGER, INTENT(OUT), ALLOCATABLE :: GRID_DIMS(:) + INTEGER, INTENT(OUT) :: GRID_SIZE, GRID_CORNERS, GRID_RANK + REAL*8 :: DLON1, DLAT1, DLON2, DLAT2, THEDET + INTEGER :: I, J + INTEGER :: IC, JC, IP, CHECKSIGNS, NBPLUS, NBMINUS, NBZERO + INTEGER :: PRINTDATA, PRINTMINMAX + REAL*8 :: MINLON, MINLAT, MAXLON, MAXLAT + REAL*8 :: MINLONCORNER, MAXLONCORNER, MINLATCORNER, MAXLATCORNER + REAL*8 :: PT(3,2) + IF (GRIDS(ID_GRD)%GTYPE .EQ. UNGTYPE) THEN + CALL GET_SCRIP_INFO_UNSTRUCTURED (ID_GRD, & + & GRID_CENTER_LON, GRID_CENTER_LAT, & + & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & + & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK) + ELSE + CALL GET_SCRIP_INFO_STRUCTURED (ID_GRD, & + & GRID_CENTER_LON, GRID_CENTER_LAT, & + & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & + & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK) + END IF + CHECKSIGNS=1 + IF (CHECKSIGNS.EQ.1) THEN + NBPLUS=0 + NBMINUS=0 + NBZERO=0 + DO IP=1,GRID_SIZE + DO IC=1,GRID_CORNERS + IF (IC.EQ.GRID_CORNERS) THEN + JC=1 + ELSE + JC=IC+1 + END IF - PT(1,1) = GRID_CENTER_LON(IP) - PT(1,2) = GRID_CENTER_LAT(IP) - PT(2,1) = GRID_CORNER_LON(IC,IP) - PT(2,2) = GRID_CORNER_LAT(IC,IP) - PT(3,1) = GRID_CORNER_LON(JC,IP) - PT(3,2) = GRID_CORNER_LAT(JC,IP) - - CALL FIX_PERIODCITY(PT) - - DLON1=PT(2,1)-PT(1,1) - DLON2=PT(3,1)-PT(1,1) - DLAT1=PT(2,2)-PT(1,2) - DLAT2=PT(3,2)-PT(1,2) - - THEDET=DLON1*DLAT2 - DLON2*DLAT1 - IF (THEDET.GT.1d-8) THEN - NBPLUS=NBPLUS+1 - ELSE IF (THEDET.LT.-1d-8) THEN - NBMINUS=NBMINUS+1 - ELSE - NBZERO=NBZERO+1 - END IF - END DO - END DO + PT(1,1) = GRID_CENTER_LON(IP) + PT(1,2) = GRID_CENTER_LAT(IP) + PT(2,1) = GRID_CORNER_LON(IC,IP) + PT(2,2) = GRID_CORNER_LAT(IC,IP) + PT(3,1) = GRID_CORNER_LON(JC,IP) + PT(3,2) = GRID_CORNER_LAT(JC,IP) - WRITE(*,*) 'SI nbPlus=', nbPlus, ' nbMinus=', nbMinus, ' nbZero=', nbZero + CALL FIX_PERIODCITY(PT) - END IF - END SUBROUTINE GET_SCRIP_INFO + DLON1=PT(2,1)-PT(1,1) + DLON2=PT(3,1)-PT(1,1) + DLAT1=PT(2,2)-PT(1,2) + DLAT2=PT(3,2)-PT(1,2) -!/ ------------------------------------------------------------------- / -!> -!> @brief Rescale according to whether the grid is spherical or not. -!> -!> @details This is adapted from Erick Rogers scrip_wrapper. -!> -!> Purpose is to rescale according to whether the grid is spherical -!> or not and to adjust by some small shift to keep SCRIP happy -!> in situations where nodes of different grids overlay. -!> -!> We apply various transformations to the longitude latitude -!> following here the transformations that were done only in -!> finite difference meshes. -!> -!> @param[inout] GRID_CENTER_LON -!> @param[inout] GRID_CENTER_LAT -!> @param[inout] GRID_CORNER_LON -!> @param[inout] GRID_CORNER_LAT -!> @param[in] GRID_MASK -!> @param[in] GRID_DIMS -!> @param[in] GRID_SIZE -!> @param[in] GRID_CORNERS -!> @param[in] GRID_RANK -!> @param CONV_DX -!> @param CONV_DY -!> @param OFFSET -!> @param GRIDSHIFT -!> -!> @author M. Dutour -!> @author A. Roland -!> @date 20-Feb-2012 -!> - SUBROUTINE SCRIP_INFO_RENORMALIZATION( & - & GRID_CENTER_LON, GRID_CENTER_LAT, & - & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & - & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK, & - & CONV_DX, CONV_DY, OFFSET, GRIDSHIFT) -! 1. Original author : -! -! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P -! Adapted from Erick Rogers scrip_wrapper -! -! 2. Last update : -! -! See revisions. -! -! 3. Revisions : -! -! 20-Feb-2012 : Origination -! -! 4. Copyright : -! -! 5. Purpose : -! -! This is adapted from Erick Rogers scrip_wrapper -! Purpose is to rescale according to whether the grid is spherical -! or not and to adjust by some small shift to keep SCRIP happy -! in situations where nodes of different grids overlay -! -! 6. Method : -! -! We apply various transformations to the longitude latitude -! following here the transformations that were done only in -! finite difference meshes. -! -! 7. Parameters, Variables and types : -! -! 8. Called by : -! -! Subroutine WMGHGH -! -! 9. Subroutines and functions used : -! -! 10. Error messages: -! -! 11. Remarks : -! -! 12. Structure : -! -! 13. Switches : -! -! 14. Source code : - IMPLICIT NONE - REAL*8, INTENT(INOUT) :: GRID_CENTER_LON(:) - REAL*8, INTENT(INOUT) :: GRID_CENTER_LAT(:) - LOGICAL, INTENT(IN) :: GRID_MASK(:) - REAL*8, INTENT(INOUT) :: GRID_CORNER_LON(:,:) - REAL*8, INTENT(INOUT) :: GRID_CORNER_LAT(:,:) - INTEGER, INTENT(IN) :: GRID_DIMS(:) - INTEGER, INTENT(IN) :: GRID_SIZE, GRID_CORNERS, GRID_RANK - REAL*8 :: CONV_DX, CONV_DY, OFFSET, GRIDSHIFT - REAL*8 DEG2RAD - ! - INTEGER :: I, J, IP - REAL*8 :: MINLON, MINLAT, MAXLON, MAXLAT, HLON, HLAT - REAL*8 :: MINLONCORNER, MAXLONCORNER, MINLATCORNER, MAXLATCORNER - - DO I=1,GRID_SIZE - GRID_CENTER_LON(I)=(GRID_CENTER_LON(I)+OFFSET)/CONV_DX + & - & GRIDSHIFT - GRID_CENTER_LAT(I)=GRID_CENTER_LAT(I)/CONV_DY + & - & GRIDSHIFT - IF(GRID_CENTER_LON(I)>360.0) THEN - GRID_CENTER_LON(I)=GRID_CENTER_LON(I)-360.0 - END IF - IF(GRID_CENTER_LON(I)<000.0) THEN - GRID_CENTER_LON(I)=GRID_CENTER_LON(I)+360.0 - END IF - DO J=1,GRID_CORNERS - GRID_CORNER_LON(J, I)=(GRID_CORNER_LON(J, I)+OFFSET)/CONV_DX+ & - & GRIDSHIFT - GRID_CORNER_LAT(J, I)=GRID_CORNER_LAT(J, I)/CONV_DY + & - & GRIDSHIFT - IF(GRID_CORNER_LON(J,I)>360.0) THEN - GRID_CORNER_LON(J,I)=GRID_CORNER_LON(J,I)-360.0 - END IF - IF(GRID_CORNER_LON(J,I)<000.0) THEN - GRID_CORNER_LON(J,I)=GRID_CORNER_LON(J,I)+360.0 + THEDET=DLON1*DLAT2 - DLON2*DLAT1 + IF (THEDET.GT.1d-8) THEN + NBPLUS=NBPLUS+1 + ELSE IF (THEDET.LT.-1d-8) THEN + NBMINUS=NBMINUS+1 + ELSE + NBZERO=NBZERO+1 END IF END DO END DO - END SUBROUTINE SCRIP_INFO_RENORMALIZATION - -!/ ------------------------------------------------------------------- / -!> -!> @brief Desc not available. -!> -!> @param[in] I -!> @param[out] INEXT -!> @param[out] IPREV -!> -!> @author M. Dutour -!> @author A. Roland -!> @date NA -!> - SUBROUTINE TRIANG_INDEXES(I, INEXT, IPREV) -! 1. Original author : -! -! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P -! - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(OUT) :: INEXT, IPREV - IF (I.EQ.1) THEN - INEXT=3 - ELSE - INEXT=I-1 + WRITE(*,*) 'SI nbPlus=', nbPlus, ' nbMinus=', nbMinus, ' nbZero=', nbZero + + END IF + END SUBROUTINE GET_SCRIP_INFO + + !/ ------------------------------------------------------------------- / + !> + !> @brief Rescale according to whether the grid is spherical or not. + !> + !> @details This is adapted from Erick Rogers scrip_wrapper. + !> + !> Purpose is to rescale according to whether the grid is spherical + !> or not and to adjust by some small shift to keep SCRIP happy + !> in situations where nodes of different grids overlay. + !> + !> We apply various transformations to the longitude latitude + !> following here the transformations that were done only in + !> finite difference meshes. + !> + !> @param[inout] GRID_CENTER_LON + !> @param[inout] GRID_CENTER_LAT + !> @param[inout] GRID_CORNER_LON + !> @param[inout] GRID_CORNER_LAT + !> @param[in] GRID_MASK + !> @param[in] GRID_DIMS + !> @param[in] GRID_SIZE + !> @param[in] GRID_CORNERS + !> @param[in] GRID_RANK + !> @param CONV_DX + !> @param CONV_DY + !> @param OFFSET + !> @param GRIDSHIFT + !> + !> @author M. Dutour + !> @author A. Roland + !> @date 20-Feb-2012 + !> + SUBROUTINE SCRIP_INFO_RENORMALIZATION( & + & GRID_CENTER_LON, GRID_CENTER_LAT, & + & GRID_CORNER_LON, GRID_CORNER_LAT, GRID_MASK, & + & GRID_DIMS, GRID_SIZE, GRID_CORNERS, GRID_RANK, & + & CONV_DX, CONV_DY, OFFSET, GRIDSHIFT) + ! 1. Original author : + ! + ! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P + ! Adapted from Erick Rogers scrip_wrapper + ! + ! 2. Last update : + ! + ! See revisions. + ! + ! 3. Revisions : + ! + ! 20-Feb-2012 : Origination + ! + ! 4. Copyright : + ! + ! 5. Purpose : + ! + ! This is adapted from Erick Rogers scrip_wrapper + ! Purpose is to rescale according to whether the grid is spherical + ! or not and to adjust by some small shift to keep SCRIP happy + ! in situations where nodes of different grids overlay + ! + ! 6. Method : + ! + ! We apply various transformations to the longitude latitude + ! following here the transformations that were done only in + ! finite difference meshes. + ! + ! 7. Parameters, Variables and types : + ! + ! 8. Called by : + ! + ! Subroutine WMGHGH + ! + ! 9. Subroutines and functions used : + ! + ! 10. Error messages: + ! + ! 11. Remarks : + ! + ! 12. Structure : + ! + ! 13. Switches : + ! + ! 14. Source code : + IMPLICIT NONE + REAL*8, INTENT(INOUT) :: GRID_CENTER_LON(:) + REAL*8, INTENT(INOUT) :: GRID_CENTER_LAT(:) + LOGICAL, INTENT(IN) :: GRID_MASK(:) + REAL*8, INTENT(INOUT) :: GRID_CORNER_LON(:,:) + REAL*8, INTENT(INOUT) :: GRID_CORNER_LAT(:,:) + INTEGER, INTENT(IN) :: GRID_DIMS(:) + INTEGER, INTENT(IN) :: GRID_SIZE, GRID_CORNERS, GRID_RANK + REAL*8 :: CONV_DX, CONV_DY, OFFSET, GRIDSHIFT + REAL*8 DEG2RAD + ! + INTEGER :: I, J, IP + REAL*8 :: MINLON, MINLAT, MAXLON, MAXLAT, HLON, HLAT + REAL*8 :: MINLONCORNER, MAXLONCORNER, MINLATCORNER, MAXLATCORNER + + DO I=1,GRID_SIZE + GRID_CENTER_LON(I)=(GRID_CENTER_LON(I)+OFFSET)/CONV_DX + & + & GRIDSHIFT + GRID_CENTER_LAT(I)=GRID_CENTER_LAT(I)/CONV_DY + & + & GRIDSHIFT + IF(GRID_CENTER_LON(I)>360.0) THEN + GRID_CENTER_LON(I)=GRID_CENTER_LON(I)-360.0 + END IF + IF(GRID_CENTER_LON(I)<000.0) THEN + GRID_CENTER_LON(I)=GRID_CENTER_LON(I)+360.0 + END IF + DO J=1,GRID_CORNERS + GRID_CORNER_LON(J, I)=(GRID_CORNER_LON(J, I)+OFFSET)/CONV_DX+ & + & GRIDSHIFT + GRID_CORNER_LAT(J, I)=GRID_CORNER_LAT(J, I)/CONV_DY + & + & GRIDSHIFT + IF(GRID_CORNER_LON(J,I)>360.0) THEN + GRID_CORNER_LON(J,I)=GRID_CORNER_LON(J,I)-360.0 END IF - IF (I.EQ.3) THEN - IPREV=1 - ELSE - IPREV=I+1 + IF(GRID_CORNER_LON(J,I)<000.0) THEN + GRID_CORNER_LON(J,I)=GRID_CORNER_LON(J,I)+360.0 END IF + END DO + END DO + + END SUBROUTINE SCRIP_INFO_RENORMALIZATION + + !/ ------------------------------------------------------------------- / + !> + !> @brief Desc not available. + !> + !> @param[in] I + !> @param[out] INEXT + !> @param[out] IPREV + !> + !> @author M. Dutour + !> @author A. Roland + !> @date NA + !> + SUBROUTINE TRIANG_INDEXES(I, INEXT, IPREV) + ! 1. Original author : + ! + ! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P + ! + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(OUT) :: INEXT, IPREV + IF (I.EQ.1) THEN + INEXT=3 + ELSE + INEXT=I-1 + END IF + IF (I.EQ.3) THEN + IPREV=1 + ELSE + IPREV=I+1 + END IF END SUBROUTINE TRIANG_INDEXES -!/ ------------------------------------------------------------------- / -!> -!> @brief This function returns the list of incidences. -!> -!> @details Output: TrigIncd - number of triangles contained by vertices. -!> -!> @param[in] MNP Number of nodes -!> @param[in] MNE List of nodes -!> @param[in] TRIGP Number of triangles -!> @param[out] TRIGINCD Number of triangles contained by vertices. -!> -!> @author M. Dutour -!> @author A. Roland -!> @date 20-Feb-2012 -!> - SUBROUTINE GET_UNSTRUCTURED_VERTEX_DEGREE (MNP, MNE, TRIGP, & - & TRIGINCD) -! Written: -! -! 20-Feb-2012 -! -! Author: -! -! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P -! -! Parameters: -! Input: -! MNP: number of nodes -! INE: list of nodes -! MNE: number of triangles -! Output: -! TrigIncd (number of triangles contained by vertices -! -! Description: -! this function returns the list of incidences -! - IMPLICIT NONE - INTEGER, INTENT(IN) :: MNP, MNE - INTEGER, INTENT(IN) :: TRIGP(:,:) - INTEGER, INTENT(OUT) :: TRIGINCD(:) - INTEGER :: IP, IE, I - TRIGINCD=0 + !/ ------------------------------------------------------------------- / + !> + !> @brief This function returns the list of incidences. + !> + !> @details Output: TrigIncd - number of triangles contained by vertices. + !> + !> @param[in] MNP Number of nodes + !> @param[in] MNE List of nodes + !> @param[in] TRIGP Number of triangles + !> @param[out] TRIGINCD Number of triangles contained by vertices. + !> + !> @author M. Dutour + !> @author A. Roland + !> @date 20-Feb-2012 + !> + SUBROUTINE GET_UNSTRUCTURED_VERTEX_DEGREE (MNP, MNE, TRIGP, & + & TRIGINCD) + ! Written: + ! + ! 20-Feb-2012 + ! + ! Author: + ! + ! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P + ! + ! Parameters: + ! Input: + ! MNP: number of nodes + ! INE: list of nodes + ! MNE: number of triangles + ! Output: + ! TrigIncd (number of triangles contained by vertices + ! + ! Description: + ! this function returns the list of incidences + ! + IMPLICIT NONE + INTEGER, INTENT(IN) :: MNP, MNE + INTEGER, INTENT(IN) :: TRIGP(:,:) + INTEGER, INTENT(OUT) :: TRIGINCD(:) + INTEGER :: IP, IE, I + TRIGINCD=0 + DO IE=1,MNE + DO I=1,3 + IP=TRIGP(I,IE) + TRIGINCD(IP)=TRIGINCD(IP) + 1 + END DO + END DO + END SUBROUTINE GET_UNSTRUCTURED_VERTEX_DEGREE + + !/ ------------------------------------------------------------------- / + !> + !> @brief Returns neighbor of a boundary node. + !> + !> @details If a node belong to a boundary, the function + !> returns the neighbor of this point on one side. + !> If the point is interior then the value 0 is set. + !> + !> @param[in] MNP Number of nodes. + !> @param[in] MNE Number of triangles. + !> @param[in] TRIGP List of nodes. + !> @param[inout] IOBP + !> @param[inout] NEIGHBOR_PREV + !> @param[inout] NEIGHBOR_NEXT + !> + !> @author M. Dutour + !> @author A. Roland + !> @date 10-Dec-2014 + !> + SUBROUTINE GET_BOUNDARY(MNP, MNE, TRIGP, IOBP, NEIGHBOR_PREV, & + & NEIGHBOR_NEXT) + !/ +-----------------------------------+ + !/ | WAVEWATCH III | + !/ | M. Dutour, A. Roland | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + ! Written: + ! + ! 20-Feb-2012 + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + ! + ! Author: + ! + ! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P + ! + ! Parameters: + ! Input: + ! MNP: number of nodes + ! TRIGP: list of nodes + ! MNE: number of triangles + ! Output: + ! NEIGHBOR + ! + ! Description: + ! if a node belong to a boundary, the function + ! returns the neighbor of this point on one side. + ! if the point is interior then the value 0 is set. + ! + USE W3SERVMD, ONLY: EXTCDE + IMPLICIT NONE + + INTEGER, INTENT(IN) :: MNP, MNE, TRIGP(3,MNE) + INTEGER, INTENT(INOUT) :: IOBP(MNP) + INTEGER, INTENT(INOUT) :: NEIGHBOR_PREV(MNP) + INTEGER, INTENT(INOUT) :: NEIGHBOR_NEXT(MNP) + + INTEGER, POINTER :: STATUS(:) + INTEGER, POINTER :: COLLECTED(:) + INTEGER, POINTER :: NEXTVERT(:) + INTEGER, POINTER :: PREVVERT(:) + + INTEGER :: IE, I, IP, IP2, IP3 + INTEGER :: ISFINISHED, INEXT, IPREV + INTEGER :: IPNEXT, IPPREV, ZNEXT, ZPREV + + ALLOCATE(STATUS(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(COLLECTED(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(PREVVERT(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(NEXTVERT(MNP), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + IOBP = 0 + NEIGHBOR_NEXT = 0 + NEIGHBOR_PREV = 0 + + ! Now computing the next items + STATUS = 0 + NEXTVERT = 0 + PREVVERT = 0 + DO IE=1,MNE + DO I=1,3 + CALL TRIANG_INDEXES(I, INEXT, IPREV) + IP=TRIGP(I,IE) + IPNEXT=TRIGP(INEXT,IE) + IPPREV=TRIGP(IPREV,IE) + IF (STATUS(IP).EQ.0) THEN + STATUS(IP)=1 + PREVVERT(IP)=IPPREV + NEXTVERT(IP)=IPNEXT + END IF + END DO + END DO + STATUS(:)=0 + DO + COLLECTED(:)=0 DO IE=1,MNE DO I=1,3 + CALL TRIANG_INDEXES(I, INEXT, IPREV) IP=TRIGP(I,IE) - TRIGINCD(IP)=TRIGINCD(IP) + 1 - END DO - END DO - END SUBROUTINE GET_UNSTRUCTURED_VERTEX_DEGREE - -!/ ------------------------------------------------------------------- / -!> -!> @brief Returns neighbor of a boundary node. -!> -!> @details If a node belong to a boundary, the function -!> returns the neighbor of this point on one side. -!> If the point is interior then the value 0 is set. -!> -!> @param[in] MNP Number of nodes. -!> @param[in] MNE Number of triangles. -!> @param[in] TRIGP List of nodes. -!> @param[inout] IOBP -!> @param[inout] NEIGHBOR_PREV -!> @param[inout] NEIGHBOR_NEXT -!> -!> @author M. Dutour -!> @author A. Roland -!> @date 10-Dec-2014 -!> - SUBROUTINE GET_BOUNDARY(MNP, MNE, TRIGP, IOBP, NEIGHBOR_PREV, & - & NEIGHBOR_NEXT) -!/ +-----------------------------------+ -!/ | WAVEWATCH III | -!/ | M. Dutour, A. Roland | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -! Written: -! -! 20-Feb-2012 -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -! -! Author: -! -! Mathieu Dutour Sikiric, IRB & Aron Roland, Z&P -! -! Parameters: -! Input: -! MNP: number of nodes -! TRIGP: list of nodes -! MNE: number of triangles -! Output: -! NEIGHBOR -! -! Description: -! if a node belong to a boundary, the function -! returns the neighbor of this point on one side. -! if the point is interior then the value 0 is set. -! - USE W3SERVMD, ONLY: EXTCDE - IMPLICIT NONE - - INTEGER, INTENT(IN) :: MNP, MNE, TRIGP(3,MNE) - INTEGER, INTENT(INOUT) :: IOBP(MNP) - INTEGER, INTENT(INOUT) :: NEIGHBOR_PREV(MNP) - INTEGER, INTENT(INOUT) :: NEIGHBOR_NEXT(MNP) - - INTEGER, POINTER :: STATUS(:) - INTEGER, POINTER :: COLLECTED(:) - INTEGER, POINTER :: NEXTVERT(:) - INTEGER, POINTER :: PREVVERT(:) - - INTEGER :: IE, I, IP, IP2, IP3 - INTEGER :: ISFINISHED, INEXT, IPREV - INTEGER :: IPNEXT, IPPREV, ZNEXT, ZPREV - - ALLOCATE(STATUS(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(COLLECTED(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(PREVVERT(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE(NEXTVERT(MNP), STAT=ISTAT) - CHECK_ALLOC_STATUS ( ISTAT ) - IOBP = 0 - NEIGHBOR_NEXT = 0 - NEIGHBOR_PREV = 0 - -! Now computing the next items - STATUS = 0 - NEXTVERT = 0 - PREVVERT = 0 - DO IE=1,MNE - DO I=1,3 - CALL TRIANG_INDEXES(I, INEXT, IPREV) - IP=TRIGP(I,IE) - IPNEXT=TRIGP(INEXT,IE) - IPPREV=TRIGP(IPREV,IE) - IF (STATUS(IP).EQ.0) THEN - STATUS(IP)=1 - PREVVERT(IP)=IPPREV + IPNEXT=TRIGP(INEXT,IE) + IPPREV=TRIGP(IPREV,IE) + IF (STATUS(IP).EQ.0) THEN + ZNEXT=NEXTVERT(IP) + IF (ZNEXT.EQ.IPPREV) THEN + COLLECTED(IP)=1 NEXTVERT(IP)=IPNEXT - END IF - END DO - END DO - STATUS(:)=0 - DO - COLLECTED(:)=0 - DO IE=1,MNE - DO I=1,3 - CALL TRIANG_INDEXES(I, INEXT, IPREV) - IP=TRIGP(I,IE) - IPNEXT=TRIGP(INEXT,IE) - IPPREV=TRIGP(IPREV,IE) - IF (STATUS(IP).EQ.0) THEN - ZNEXT=NEXTVERT(IP) - IF (ZNEXT.EQ.IPPREV) THEN - COLLECTED(IP)=1 - NEXTVERT(IP)=IPNEXT - IF (NEXTVERT(IP).EQ.PREVVERT(IP)) THEN - STATUS(IP)=1 - END IF - END IF + IF (NEXTVERT(IP).EQ.PREVVERT(IP)) THEN + STATUS(IP)=1 END IF - END DO - END DO - - ISFINISHED=1 - DO IP=1,MNP - IF ((COLLECTED(IP).EQ.0).AND.(STATUS(IP).EQ.0)) THEN - STATUS(IP)=-1 - NEIGHBOR_NEXT(IP)=NEXTVERT(IP) - END IF - IF (STATUS(IP).EQ.0) THEN - ISFINISHED=0 END IF - END DO - IF (ISFINISHED.EQ.1) THEN - EXIT END IF END DO + END DO -! Now computing the prev items - STATUS = 0 - NEXTVERT = 0 - PREVVERT = 0 - DO IE=1,MNE - DO I=1,3 - CALL TRIANG_INDEXES(I, INEXT, IPREV) - IP=TRIGP(I,IE) - IPNEXT=TRIGP(INEXT,IE) - IPPREV=TRIGP(IPREV,IE) - IF (STATUS(IP).EQ.0) THEN - STATUS(IP)=1 + ISFINISHED=1 + DO IP=1,MNP + IF ((COLLECTED(IP).EQ.0).AND.(STATUS(IP).EQ.0)) THEN + STATUS(IP)=-1 + NEIGHBOR_NEXT(IP)=NEXTVERT(IP) + END IF + IF (STATUS(IP).EQ.0) THEN + ISFINISHED=0 + END IF + END DO + IF (ISFINISHED.EQ.1) THEN + EXIT + END IF + END DO + + ! Now computing the prev items + STATUS = 0 + NEXTVERT = 0 + PREVVERT = 0 + DO IE=1,MNE + DO I=1,3 + CALL TRIANG_INDEXES(I, INEXT, IPREV) + IP=TRIGP(I,IE) + IPNEXT=TRIGP(INEXT,IE) + IPPREV=TRIGP(IPREV,IE) + IF (STATUS(IP).EQ.0) THEN + STATUS(IP)=1 + PREVVERT(IP)=IPPREV + NEXTVERT(IP)=IPNEXT + END IF + END DO + END DO + STATUS(:)=0 + DO + COLLECTED(:)=0 + DO IE=1,MNE + DO I=1,3 + CALL TRIANG_INDEXES(I, INEXT, IPREV) + IP=TRIGP(I,IE) + IPNEXT=TRIGP(INEXT,IE) + IPPREV=TRIGP(IPREV,IE) + IF (STATUS(IP).EQ.0) THEN + ZPREV=PREVVERT(IP) + IF (ZPREV.EQ.IPNEXT) THEN + COLLECTED(IP)=1 PREVVERT(IP)=IPPREV - NEXTVERT(IP)=IPNEXT - END IF - END DO - END DO - STATUS(:)=0 - DO - COLLECTED(:)=0 - DO IE=1,MNE - DO I=1,3 - CALL TRIANG_INDEXES(I, INEXT, IPREV) - IP=TRIGP(I,IE) - IPNEXT=TRIGP(INEXT,IE) - IPPREV=TRIGP(IPREV,IE) - IF (STATUS(IP).EQ.0) THEN - ZPREV=PREVVERT(IP) - IF (ZPREV.EQ.IPNEXT) THEN - COLLECTED(IP)=1 - PREVVERT(IP)=IPPREV - IF (PREVVERT(IP).EQ.NEXTVERT(IP)) THEN - STATUS(IP)=1 - END IF - END IF + IF (PREVVERT(IP).EQ.NEXTVERT(IP)) THEN + STATUS(IP)=1 END IF - END DO - END DO - - ISFINISHED=1 - DO IP=1,MNP - IF ((COLLECTED(IP).EQ.0).AND.(STATUS(IP).EQ.0)) THEN - STATUS(IP)=-1 - NEIGHBOR_PREV(IP)=PREVVERT(IP) ! new code - END IF - IF (STATUS(IP).EQ.0) THEN - ISFINISHED=0 END IF - END DO - IF (ISFINISHED.EQ.1) THEN - EXIT - END IF - END DO -! Now making checks - DO IP=1,MNP - IP2=NEIGHBOR_NEXT(IP) - IF (IP2.GT.0) THEN - IP3=NEIGHBOR_PREV(IP2) - IF (ABS(IP3 - IP).GT.0) THEN - WRITE(*,*) 'IP=', IP, ' IP2=', IP2, ' IP3=', IP3 - WRITE(*,*) 'We have a dramatic inconsistency' - STOP 'wmscrpmd, case 3' - END IF - END IF - END DO -! Now assigning the boundary IOBP array - DO IP=1,MNP - IF (STATUS(IP).EQ.-1 .AND. IOBP(IP) .EQ. 0) THEN - IOBP(IP)=1 END IF END DO + END DO - DEALLOCATE(STATUS, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(COLLECTED, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(NEXTVERT, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - DEALLOCATE(PREVVERT, STAT=ISTAT) - CHECK_DEALLOC_STATUS ( ISTAT ) - - END SUBROUTINE GET_BOUNDARY -!/ ------------------------------------------------------------------- / -!> -!> @brief Adjust element longitude coordinates for elements straddling the -!> dateline with distance of ~360 degrees. -!> -!> @details Detect if element has nodes on both sides of dateline and adjust -!> coordinates so that all nodes have the same sign. -!> -!> @param[inout] PT -!> -!> @author Steven Brus -!> @author Ali Abdolali -!> @date 21-May-2020 -!> - SUBROUTINE FIX_PERIODCITY(PT) - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Steven Brus | -!/ | Ali Abdolali | -!/ | FORTRAN 90 | -!/ | Last update : 21-May-2020 | -!/ +-----------------------------------+ -!/ -!/ 21-May-2020 : Origination. ( version 6.07 ) -!/ -!/ -! 1. Purpose : -! -! Adjust element longitude coordinates for elements straddling the -! dateline with distance of ~360 degrees -! -! 2. Method : -! -! Detect if element has nodes on both sides of dateline and adjust -! coordinates so that all nodes have the same sign -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- - IMPLICIT NONE - REAL*8, INTENT(INOUT) :: PT(3,2) -! ---------------------------------------------------------------- -! -! Local variables. -! ---------------------------------------------------------------- - INTEGER :: I - INTEGER :: R1GT180, R2GT180, R3GT180 -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! - -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! GET_SCRIP_INFO_UNSTRUCTURED Subr. WMSCRPMD Element center calculation -! GET_SCRIP_INFO Subr. WMSCRPMD Check signs -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -!/ ------------------------------------------------------------------- / + ISFINISHED=1 + DO IP=1,MNP + IF ((COLLECTED(IP).EQ.0).AND.(STATUS(IP).EQ.0)) THEN + STATUS(IP)=-1 + NEIGHBOR_PREV(IP)=PREVVERT(IP) ! new code + END IF + IF (STATUS(IP).EQ.0) THEN + ISFINISHED=0 + END IF + END DO + IF (ISFINISHED.EQ.1) THEN + EXIT + END IF + END DO + ! Now making checks + DO IP=1,MNP + IP2=NEIGHBOR_NEXT(IP) + IF (IP2.GT.0) THEN + IP3=NEIGHBOR_PREV(IP2) + IF (ABS(IP3 - IP).GT.0) THEN + WRITE(*,*) 'IP=', IP, ' IP2=', IP2, ' IP3=', IP3 + WRITE(*,*) 'We have a dramatic inconsistency' + STOP 'wmscrpmd, case 3' + END IF + END IF + END DO + ! Now assigning the boundary IOBP array + DO IP=1,MNP + IF (STATUS(IP).EQ.-1 .AND. IOBP(IP) .EQ. 0) THEN + IOBP(IP)=1 + END IF + END DO - R1GT180 = MERGE(1, 0, ABS(PT(3,1)-PT(2,1)).GT.180) - R2GT180 = MERGE(1, 0, ABS(PT(1,1)-PT(3,1)).GT.180) - R3GT180 = MERGE(1, 0, ABS(PT(2,1)-PT(1,1)).GT.180) -! if R1GT180+R2GT180+R3GT180 .eq. 0 the element does not cross the -! dateline -! if R1GT180+R2GT180+R3GT180 .eq. 1 the element contains the pole -! if R1GT180+R2GT180+R3GT180 .eq. 2 the element crosses the dateline - - IF ( R1GT180 + R2GT180 == 2 ) THEN - PT(3,1)=PT(3,1)-SIGN(360.0d0,(PT(3,1)-PT(2,1))) - ELSE IF ( R2GT180 + R3GT180 == 2 ) THEN - PT(1,1)=PT(1,1)-SIGN(360.0d0,(PT(1,1)-PT(2,1))) - ELSE IF ( R1GT180 + R3GT180 == 2 ) THEN - PT(2,1)=PT(2,1)-SIGN(360.0d0,(PT(2,1)-PT(3,1))) - ENDIF + DEALLOCATE(STATUS, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(COLLECTED, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(NEXTVERT, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(PREVVERT, STAT=ISTAT) + CHECK_DEALLOC_STATUS ( ISTAT ) - RETURN - END SUBROUTINE FIX_PERIODCITY -!/ -!/ End of module WMSCRPMD -------------------------------------------- / -!/ - END MODULE WMSCRPMD + END SUBROUTINE GET_BOUNDARY + !/ ------------------------------------------------------------------- / + !> + !> @brief Adjust element longitude coordinates for elements straddling the + !> dateline with distance of ~360 degrees. + !> + !> @details Detect if element has nodes on both sides of dateline and adjust + !> coordinates so that all nodes have the same sign. + !> + !> @param[inout] PT + !> + !> @author Steven Brus + !> @author Ali Abdolali + !> @date 21-May-2020 + !> + SUBROUTINE FIX_PERIODCITY(PT) + + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Steven Brus | + !/ | Ali Abdolali | + !/ | FORTRAN 90 | + !/ | Last update : 21-May-2020 | + !/ +-----------------------------------+ + !/ + !/ 21-May-2020 : Origination. ( version 6.07 ) + !/ + !/ + ! 1. Purpose : + ! + ! Adjust element longitude coordinates for elements straddling the + ! dateline with distance of ~360 degrees + ! + ! 2. Method : + ! + ! Detect if element has nodes on both sides of dateline and adjust + ! coordinates so that all nodes have the same sign + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + IMPLICIT NONE + REAL*8, INTENT(INOUT) :: PT(3,2) + ! ---------------------------------------------------------------- + ! + ! Local variables. + ! ---------------------------------------------------------------- + INTEGER :: I + INTEGER :: R1GT180, R2GT180, R3GT180 + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! GET_SCRIP_INFO_UNSTRUCTURED Subr. WMSCRPMD Element center calculation + ! GET_SCRIP_INFO Subr. WMSCRPMD Check signs + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! 10. Source code : + !/ ------------------------------------------------------------------- / + + R1GT180 = MERGE(1, 0, ABS(PT(3,1)-PT(2,1)).GT.180) + R2GT180 = MERGE(1, 0, ABS(PT(1,1)-PT(3,1)).GT.180) + R3GT180 = MERGE(1, 0, ABS(PT(2,1)-PT(1,1)).GT.180) + ! if R1GT180+R2GT180+R3GT180 .eq. 0 the element does not cross the + ! dateline + ! if R1GT180+R2GT180+R3GT180 .eq. 1 the element contains the pole + ! if R1GT180+R2GT180+R3GT180 .eq. 2 the element crosses the dateline + + IF ( R1GT180 + R2GT180 == 2 ) THEN + PT(3,1)=PT(3,1)-SIGN(360.0d0,(PT(3,1)-PT(2,1))) + ELSE IF ( R2GT180 + R3GT180 == 2 ) THEN + PT(1,1)=PT(1,1)-SIGN(360.0d0,(PT(1,1)-PT(2,1))) + ELSE IF ( R1GT180 + R3GT180 == 2 ) THEN + PT(2,1)=PT(2,1)-SIGN(360.0d0,(PT(2,1)-PT(3,1))) + ENDIF + + RETURN + END SUBROUTINE FIX_PERIODCITY + !/ + !/ End of module WMSCRPMD -------------------------------------------- / + !/ +END MODULE WMSCRPMD diff --git a/model/src/wmunitmd.F90 b/model/src/wmunitmd.F90 index f51246717..def961092 100644 --- a/model/src/wmunitmd.F90 +++ b/model/src/wmunitmd.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains module WMUNITMD. -!> +!> !> @author H. L. Tolman @date 29-May-2009 !> @@ -10,971 +10,971 @@ !> !> @brief Dynamic assignement of unit numbers for the multi-grid wave !> model. -!> +!> !> @details Allowed range of unit numbers is set in parameter statements. !> !> @author H. L. Tolman @date 29-May-2009 !> - MODULE WMUNITMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 29-Mar-2005 : Origination. ( version 3.07 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Dynamic assignement of unit numbers for the multi-grid wave -! model. -! -! Allowed range of unit numbers is set in parameter statements. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! UNITLW I.P. Private Lowest unit number. -! UNITHG I.P. Private Highest unit number. -! INPLOW, INPHGH, OUTLOW, OUTHGH, SCRLOW, SCRHGH -! I.P. Private Low and high for input, output and -! scratch files. -! FLINIT Log. Private Flag for intialization. -! -! U_USED L.A. Private Flag for use/assignement. -! U_TYPE C.A. Private Type of unit. -! 'RES' : Reserved. -! 'INP' : Input file. -! 'OUT' : Output file. -! 'SCR' : Scratch file. -! U_NAME C.A. Private File name of unit. -! U_DESC C.A. Private Decription of file. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WMUINI Subr. Public Initialize data structures. -! WMUDMP Subr. Public Dump contents of data structures. -! WMUSET Subr. Public Put data directly in structure. -! WMUGET Subr. Public Get a unit number. -! WMUINQ Subr. Public Update ansilary info automatically. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - All parameters are private. Dump data using WMUDMP routine. -! -! 6. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Define acceptable ranges of unit numbers -!/ - INTEGER, PARAMETER, PRIVATE :: UNITLW = 1 !< UNITLW - INTEGER, PARAMETER, PRIVATE :: UNITHG = 120 !< UNITHG - INTEGER, PARAMETER, PRIVATE :: INPLOW = 10 !< INPLOW - INTEGER, PARAMETER, PRIVATE :: INPHGH = 49 !< INPHGH - INTEGER, PARAMETER, PRIVATE :: OUTLOW = 50 !< OUTLOW - INTEGER, PARAMETER, PRIVATE :: OUTHGH = 98 !< OUTHGH - INTEGER, PARAMETER, PRIVATE :: SCRLOW = 99 !< SCRLOW - INTEGER, PARAMETER, PRIVATE :: SCRHGH = 100 !< SCRHGH - ! - LOGICAL, PRIVATE :: FLINIT = .FALSE. !< FLINIT - - LOGICAL, PRIVATE, ALLOCATABLE :: U_USED(:) !< U_USED - CHARACTER(LEN= 3), PRIVATE, ALLOCATABLE :: U_TYPE(:) !< U_TYPE - CHARACTER(LEN=30), PRIVATE, ALLOCATABLE :: U_NAME(:) !< U_NAME - CHARACTER(LEN=30), PRIVATE, ALLOCATABLE :: U_DESC(:) !< U_DESC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Allocate and initialize arrays of module. -!> -!> @details Allocate and test parameter setting. -!> -!> @param[in] NDSE Unit number for error output. -!> @param[in] NDST Unit number for test output. -!> @author H. L. Tolman @date 25-Mar-2005 -!> - SUBROUTINE WMUINI ( NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-Mar-2005 ! -!/ +-----------------------------------+ -!/ -!/ 25-Mar-2005 : Origination. ( version 3.07 ) -!/ -! 1. Purpose : -! -! Allocate and initialize arrays of module. -! -! 2. Method : -! -! Allocate and test parameter setting. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSE Int. I Unit number for error output. -! NDST Int. I Unit number for test output. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! See source code. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE +MODULE WMUNITMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 29-Mar-2005 : Origination. ( version 3.07 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Dynamic assignement of unit numbers for the multi-grid wave + ! model. + ! + ! Allowed range of unit numbers is set in parameter statements. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! UNITLW I.P. Private Lowest unit number. + ! UNITHG I.P. Private Highest unit number. + ! INPLOW, INPHGH, OUTLOW, OUTHGH, SCRLOW, SCRHGH + ! I.P. Private Low and high for input, output and + ! scratch files. + ! FLINIT Log. Private Flag for intialization. + ! + ! U_USED L.A. Private Flag for use/assignement. + ! U_TYPE C.A. Private Type of unit. + ! 'RES' : Reserved. + ! 'INP' : Input file. + ! 'OUT' : Output file. + ! 'SCR' : Scratch file. + ! U_NAME C.A. Private File name of unit. + ! U_DESC C.A. Private Decription of file. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WMUINI Subr. Public Initialize data structures. + ! WMUDMP Subr. Public Dump contents of data structures. + ! WMUSET Subr. Public Put data directly in structure. + ! WMUGET Subr. Public Get a unit number. + ! WMUINQ Subr. Public Update ansilary info automatically. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - All parameters are private. Dump data using WMUDMP routine. + ! + ! 6. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + !/ Define acceptable ranges of unit numbers + !/ + INTEGER, PARAMETER, PRIVATE :: UNITLW = 1 !< UNITLW + INTEGER, PARAMETER, PRIVATE :: UNITHG = 120 !< UNITHG + INTEGER, PARAMETER, PRIVATE :: INPLOW = 10 !< INPLOW + INTEGER, PARAMETER, PRIVATE :: INPHGH = 49 !< INPHGH + INTEGER, PARAMETER, PRIVATE :: OUTLOW = 50 !< OUTLOW + INTEGER, PARAMETER, PRIVATE :: OUTHGH = 98 !< OUTHGH + INTEGER, PARAMETER, PRIVATE :: SCRLOW = 99 !< SCRLOW + INTEGER, PARAMETER, PRIVATE :: SCRHGH = 100 !< SCRHGH + ! + LOGICAL, PRIVATE :: FLINIT = .FALSE. !< FLINIT + + LOGICAL, PRIVATE, ALLOCATABLE :: U_USED(:) !< U_USED + CHARACTER(LEN= 3), PRIVATE, ALLOCATABLE :: U_TYPE(:) !< U_TYPE + CHARACTER(LEN=30), PRIVATE, ALLOCATABLE :: U_NAME(:) !< U_NAME + CHARACTER(LEN=30), PRIVATE, ALLOCATABLE :: U_DESC(:) !< U_DESC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Allocate and initialize arrays of module. + !> + !> @details Allocate and test parameter setting. + !> + !> @param[in] NDSE Unit number for error output. + !> @param[in] NDST Unit number for test output. + !> @author H. L. Tolman @date 25-Mar-2005 + !> + SUBROUTINE WMUINI ( NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-Mar-2005 ! + !/ +-----------------------------------+ + !/ + !/ 25-Mar-2005 : Origination. ( version 3.07 ) + !/ + ! 1. Purpose : + ! + ! Allocate and initialize arrays of module. + ! + ! 2. Method : + ! + ! Allocate and test parameter setting. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSE Int. I Unit number for error output. + ! NDST Int. I Unit number for test output. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! See source code. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, I1, IN, I + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, I1, IN, I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - CHARACTER(LEN=3) :: STRING -!/ + CHARACTER(LEN=3) :: STRING + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMUINI') + CALL STRACE (IENT, 'WMUINI') #endif -! -! -------------------------------------------------------------------- / -! 1. Test parameter settings -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test parameter settings + ! #ifdef W3_T - WRITE (NDST,9000) + WRITE (NDST,9000) #endif -! - IF ( UNITLW .GE. UNITHG ) THEN - WRITE (NDSE,1000) UNITLW, UNITHG - CALL EXTCDE ( 1000 ) - END IF -! - IF ( UNITLW .GT. INPLOW .OR. & - UNITLW .GT. OUTLOW .OR. & - UNITLW .GT. SCRLOW ) THEN - WRITE (NDSE,1001) UNITLW, INPLOW, OUTLOW, SCRLOW - CALL EXTCDE ( 1001 ) - END IF -! - IF ( UNITHG .LT. INPHGH .OR. & - UNITHG .LT. OUTHGH .OR. & - UNITHG .LT. SCRHGH ) THEN - WRITE (NDSE,1002) UNITHG, INPHGH, OUTHGH, SCRHGH - CALL EXTCDE ( 1002 ) - END IF -! - IF ( FLINIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE ( 1003 ) - END IF -! -! -------------------------------------------------------------------- / -! 1. Allocate and initialize arrays -! + ! + IF ( UNITLW .GE. UNITHG ) THEN + WRITE (NDSE,1000) UNITLW, UNITHG + CALL EXTCDE ( 1000 ) + END IF + ! + IF ( UNITLW .GT. INPLOW .OR. & + UNITLW .GT. OUTLOW .OR. & + UNITLW .GT. SCRLOW ) THEN + WRITE (NDSE,1001) UNITLW, INPLOW, OUTLOW, SCRLOW + CALL EXTCDE ( 1001 ) + END IF + ! + IF ( UNITHG .LT. INPHGH .OR. & + UNITHG .LT. OUTHGH .OR. & + UNITHG .LT. SCRHGH ) THEN + WRITE (NDSE,1002) UNITHG, INPHGH, OUTHGH, SCRHGH + CALL EXTCDE ( 1002 ) + END IF + ! + IF ( FLINIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE ( 1003 ) + END IF + ! + ! -------------------------------------------------------------------- / + ! 1. Allocate and initialize arrays + ! #ifdef W3_T - WRITE (NDST,9010) UNITLW, UNITHG + WRITE (NDST,9010) UNITLW, UNITHG #endif -! - ALLOCATE ( U_USED(UNITLW:UNITHG) , U_TYPE(UNITLW:UNITHG) , & - U_NAME(UNITLW:UNITHG) , U_DESC(UNITLW:UNITHG) ) -! - U_USED = .FALSE. - U_TYPE = 'RES' - U_NAME = 'unknown' - U_DESC = 'unknown' -! -! -------------------------------------------------------------------- / -! 2. Designate file types -! + ! + ALLOCATE ( U_USED(UNITLW:UNITHG) , U_TYPE(UNITLW:UNITHG) , & + U_NAME(UNITLW:UNITHG) , U_DESC(UNITLW:UNITHG) ) + ! + U_USED = .FALSE. + U_TYPE = 'RES' + U_NAME = 'unknown' + U_DESC = 'unknown' + ! + ! -------------------------------------------------------------------- / + ! 2. Designate file types + ! #ifdef W3_T - WRITE (NDST,9020) + WRITE (NDST,9020) #endif -! - DO J=1, 3 -! - SELECT CASE(J) - CASE(1) - STRING = 'INP' - I1 = INPLOW - IN = INPHGH - CASE(2) - STRING = 'OUT' - I1 = OUTLOW - IN = OUTHGH - CASE DEFAULT - STRING = 'SCR' - I1 = SCRLOW - IN = SCRHGH - END SELECT -! - DO I=I1, IN - IF ( U_TYPE(I) .NE. 'RES' ) THEN - WRITE (NDSE,1020) I, U_TYPE(I) - END IF - U_TYPE(I) = STRING - END DO - END DO -! -! -------------------------------------------------------------------- / -! 3. Set flags -! + ! + DO J=1, 3 + ! + SELECT CASE(J) + CASE(1) + STRING = 'INP' + I1 = INPLOW + IN = INPHGH + CASE(2) + STRING = 'OUT' + I1 = OUTLOW + IN = OUTHGH + CASE DEFAULT + STRING = 'SCR' + I1 = SCRLOW + IN = SCRHGH + END SELECT + ! + DO I=I1, IN + IF ( U_TYPE(I) .NE. 'RES' ) THEN + WRITE (NDSE,1020) I, U_TYPE(I) + END IF + U_TYPE(I) = STRING + END DO + END DO + ! + ! -------------------------------------------------------------------- / + ! 3. Set flags + ! #ifdef W3_T - WRITE (NDST,9030) + WRITE (NDST,9030) #endif -! - FLINIT = .TRUE. -! -! -------------------------------------------------------------------- / -! 4. Test output -! + ! + FLINIT = .TRUE. + ! + ! -------------------------------------------------------------------- / + ! 4. Test output + ! #ifdef W3_T - WRITE (NDST,9040) - DO I=UNITLW, UNITHG - WRITE (NDST,9041) I,U_USED(I),U_TYPE(I),U_NAME(I),U_DESC(I) - END DO + WRITE (NDST,9040) + DO I=UNITLW, UNITHG + WRITE (NDST,9041) I,U_USED(I),U_TYPE(I),U_NAME(I),U_DESC(I) + END DO #endif -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** ERROR WMUINI: ILLEGAL UNIT RANGE ***'/ & - ' LOW - HIGH : ',2I10/) - 1001 FORMAT (/' *** ERROR WMUINI: ILLEGAL LOWER LIMITS ***'/ & - ' ',4I10/) - 1002 FORMAT (/' *** ERROR WMUINI: ILLEGAL HIGHER LIMITS ***'/ & - ' ',4I10/) - 1003 FORMAT (/' *** ERROR WMUINI: DATA ALREADY INITIALIZED ***'/) - 1020 FORMAT (/' *** WARNING WMUINI: UNIT',I4,' ALREADY ASSIGNED [', & - A,'] ***') -! + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** ERROR WMUINI: ILLEGAL UNIT RANGE ***'/ & + ' LOW - HIGH : ',2I10/) +1001 FORMAT (/' *** ERROR WMUINI: ILLEGAL LOWER LIMITS ***'/ & + ' ',4I10/) +1002 FORMAT (/' *** ERROR WMUINI: ILLEGAL HIGHER LIMITS ***'/ & + ' ',4I10/) +1003 FORMAT (/' *** ERROR WMUINI: DATA ALREADY INITIALIZED ***'/) +1020 FORMAT (/' *** WARNING WMUINI: UNIT',I4,' ALREADY ASSIGNED [', & + A,'] ***') + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMUNINI: STARTING ROUTINE') - 9010 FORMAT ( ' TEST WMUNINI: ALLOCATING ARRAYS ',2I6) - 9020 FORMAT ( ' TEST WMUNINI: INITALIZING ARRAYS') - 9030 FORMAT ( ' TEST WMUNINI: SETTING FLAGS') - 9040 FORMAT ( ' TEST WMUNINI: DATA STRUCTURE AFTER INITIALIZATION') - 9041 FORMAT ( 5X,I4,L4,3(2X,A)) +9000 FORMAT ( ' TEST WMUNINI: STARTING ROUTINE') +9010 FORMAT ( ' TEST WMUNINI: ALLOCATING ARRAYS ',2I6) +9020 FORMAT ( ' TEST WMUNINI: INITALIZING ARRAYS') +9030 FORMAT ( ' TEST WMUNINI: SETTING FLAGS') +9040 FORMAT ( ' TEST WMUNINI: DATA STRUCTURE AFTER INITIALIZATION') +9041 FORMAT ( 5X,I4,L4,3(2X,A)) #endif -!/ -!/ End of WMUINI ----------------------------------------------------- / -!/ - END SUBROUTINE WMUINI -!/ ------------------------------------------------------------------- / -!> -!> @brief Display assigned unit number information from private data base. -!> -!> @param[in] NDS Unit number for output. -!> @param[in] IREQ Request identifier. -!> -!> @author H. L. Tolman @date 25-Mar-2005 -!> - - SUBROUTINE WMUDMP ( NDS, IREQ ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-Mar-2005 ! -!/ +-----------------------------------+ -!/ -!/ 25-Mar-2005 : Origination. ( version 3.07 ) -!/ -! 1. Purpose : -! -! Display assigned unit number information from private data base. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Unit number for output. -! IREQ Int. I Request identifier. -! < 0 : Dump all data. -! 0 : Dump assigned units only. -! > 0 : Dump this unit only. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE + !/ + !/ End of WMUINI ----------------------------------------------------- / + !/ + END SUBROUTINE WMUINI + !/ ------------------------------------------------------------------- / + !> + !> @brief Display assigned unit number information from private data base. + !> + !> @param[in] NDS Unit number for output. + !> @param[in] IREQ Request identifier. + !> + !> @author H. L. Tolman @date 25-Mar-2005 + !> + + SUBROUTINE WMUDMP ( NDS, IREQ ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-Mar-2005 ! + !/ +-----------------------------------+ + !/ + !/ 25-Mar-2005 : Origination. ( version 3.07 ) + !/ + ! 1. Purpose : + ! + ! Display assigned unit number information from private data base. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Unit number for output. + ! IREQ Int. I Request identifier. + ! < 0 : Dump all data. + ! 0 : Dump assigned units only. + ! > 0 : Dump this unit only. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, IREQ -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, IREQ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMUDMP') + CALL STRACE (IENT, 'WMUDMP') #endif -! -! -------------------------------------------------------------------- / -! 1. Test request and intialization -! - IF ( .NOT. FLINIT ) THEN - WRITE (NDS,1000) - CALL EXTCDE ( 1000 ) - END IF -! - IF ( IREQ.GT.0 .AND. ( IREQ.LT.UNITLW .OR. IREQ.GT.UNITHG) ) THEN - WRITE (NDS,1001) IREQ, UNITLW, UNITHG - CALL EXTCDE ( 1001 ) - END IF -! -! -------------------------------------------------------------------- / -! 2. Single unit request -! - IF ( IREQ .GT. 0 ) THEN - WRITE (NDS,920) IREQ, U_USED(IREQ), U_TYPE(IREQ), & - U_NAME(IREQ), U_DESC(IREQ) -! -! -------------------------------------------------------------------- / -! 3. Multiple unit request -! - ELSE -! - IF ( IREQ .LT. 0 ) THEN - WRITE (NDS,930) - ELSE - WRITE (NDS,931) - END IF -! - DO I=UNITLW, UNITHG - IF ( IREQ.LT.0 .OR. U_USED(I) ) & - WRITE (NDS,932) I, U_USED(I), U_TYPE(I), & - U_NAME(I), U_DESC(I) - END DO - WRITE (NDS,*) -! - END IF -! - RETURN -! -! Formats -! - 920 FORMAT (/' WMUDMP: Unit number : ',I6/ & - ' Assigned : ',L6/ & - ' Type : ',A/ & - ' Name : ',A/ & - ' Description : ',A/) -! - 930 FORMAT (/' WMUDMP: Unit information '// & - ' Nr Flg Type Name Description '/ & - ' -------------------------------------------------', & - '---------------------') - 931 FORMAT (/' WMUDMP: Unit information (assigned only)'// & - ' Nr Flg Type Name Description '/ & - ' -------------------------------------------------', & - '---------------------') - 932 FORMAT ( 2X,I4,L4,2X,A3,2X,A20,2X,A) -! - 1000 FORMAT (/' *** ERROR WMUDMP: DATA STRUCTURE READY ***'/ & - /' RUN WMUINI FIRST '/) - 1001 FORMAT (/' *** ERROR WMUDMP: UNIT NUMBER OUT OF RANGE ***' & - /' REQ/RANG :',3I6/) -!/ -!/ End of WMUDMP ----------------------------------------------------- / -!/ - END SUBROUTINE WMUDMP -!/ ------------------------------------------------------------------- / -!> -!> @brief Directly set information for a unit number in the data structure. -!> -!> @param[in] NDSE Unit number for error output. -!> @param[in] NDST Unit number for test output. -!> @param[in] NDS Unit number to be assigned. -!> @param[in] FLAG Flag for assigning unit. -!> @param[in] TYPE Type identifier to be used. -!> @param[in] NAME Name of file. -!> @param[in] DESC Description of file. -!> -!> @author H. L. Tolman @date 25-Mar-2005 -!> - SUBROUTINE WMUSET ( NDSE, NDST, NDS, FLAG, TYPE, NAME, DESC ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-Mar-2005 ! -!/ +-----------------------------------+ -!/ -!/ 25-Mar-2005 : Origination. ( version 3.07 ) -!/ -! 1. Purpose : -! -! Directly set information for a unit number in the data structure. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSE Int. I Unit number for error output. -! NDST Int. I Unit number for test output. -! NDS Int. I Unit number to be assigned. -! FLAG Log. I Flag for assigning unit. -! TYPE C*3 I Type identifier to be used. -! NAME C* I Name of file. -! DESC C* I Description of file. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! EXCTDE Sur. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE + ! + ! -------------------------------------------------------------------- / + ! 1. Test request and intialization + ! + IF ( .NOT. FLINIT ) THEN + WRITE (NDS,1000) + CALL EXTCDE ( 1000 ) + END IF + ! + IF ( IREQ.GT.0 .AND. ( IREQ.LT.UNITLW .OR. IREQ.GT.UNITHG) ) THEN + WRITE (NDS,1001) IREQ, UNITLW, UNITHG + CALL EXTCDE ( 1001 ) + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Single unit request + ! + IF ( IREQ .GT. 0 ) THEN + WRITE (NDS,920) IREQ, U_USED(IREQ), U_TYPE(IREQ), & + U_NAME(IREQ), U_DESC(IREQ) + ! + ! -------------------------------------------------------------------- / + ! 3. Multiple unit request + ! + ELSE + ! + IF ( IREQ .LT. 0 ) THEN + WRITE (NDS,930) + ELSE + WRITE (NDS,931) + END IF + ! + DO I=UNITLW, UNITHG + IF ( IREQ.LT.0 .OR. U_USED(I) ) & + WRITE (NDS,932) I, U_USED(I), U_TYPE(I), & + U_NAME(I), U_DESC(I) + END DO + WRITE (NDS,*) + ! + END IF + ! + RETURN + ! + ! Formats + ! +920 FORMAT (/' WMUDMP: Unit number : ',I6/ & + ' Assigned : ',L6/ & + ' Type : ',A/ & + ' Name : ',A/ & + ' Description : ',A/) + ! +930 FORMAT (/' WMUDMP: Unit information '// & + ' Nr Flg Type Name Description '/ & + ' -------------------------------------------------', & + '---------------------') +931 FORMAT (/' WMUDMP: Unit information (assigned only)'// & + ' Nr Flg Type Name Description '/ & + ' -------------------------------------------------', & + '---------------------') +932 FORMAT ( 2X,I4,L4,2X,A3,2X,A20,2X,A) + ! +1000 FORMAT (/' *** ERROR WMUDMP: DATA STRUCTURE READY ***'/ & + /' RUN WMUINI FIRST '/) +1001 FORMAT (/' *** ERROR WMUDMP: UNIT NUMBER OUT OF RANGE ***' & + /' REQ/RANG :',3I6/) + !/ + !/ End of WMUDMP ----------------------------------------------------- / + !/ + END SUBROUTINE WMUDMP + !/ ------------------------------------------------------------------- / + !> + !> @brief Directly set information for a unit number in the data structure. + !> + !> @param[in] NDSE Unit number for error output. + !> @param[in] NDST Unit number for test output. + !> @param[in] NDS Unit number to be assigned. + !> @param[in] FLAG Flag for assigning unit. + !> @param[in] TYPE Type identifier to be used. + !> @param[in] NAME Name of file. + !> @param[in] DESC Description of file. + !> + !> @author H. L. Tolman @date 25-Mar-2005 + !> + SUBROUTINE WMUSET ( NDSE, NDST, NDS, FLAG, TYPE, NAME, DESC ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-Mar-2005 ! + !/ +-----------------------------------+ + !/ + !/ 25-Mar-2005 : Origination. ( version 3.07 ) + !/ + ! 1. Purpose : + ! + ! Directly set information for a unit number in the data structure. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSE Int. I Unit number for error output. + ! NDST Int. I Unit number for test output. + ! NDS Int. I Unit number to be assigned. + ! FLAG Log. I Flag for assigning unit. + ! TYPE C*3 I Type identifier to be used. + ! NAME C* I Name of file. + ! DESC C* I Description of file. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! EXCTDE Sur. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSE, NDST, NDS - LOGICAL, INTENT(IN) :: FLAG - CHARACTER(LEN=3), INTENT(IN), OPTIONAL :: & - TYPE - CHARACTER*(*), INTENT(IN), OPTIONAL :: & - NAME, DESC -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSE, NDST, NDS + LOGICAL, INTENT(IN) :: FLAG + CHARACTER(LEN=3), INTENT(IN), OPTIONAL :: & + TYPE + CHARACTER*(*), INTENT(IN), OPTIONAL :: & + NAME, DESC + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMUSET') + CALL STRACE (IENT, 'WMUSET') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input -! - IF ( .NOT. FLINIT ) THEN - WRITE (NDSE,1000) - CALL EXTCDE ( 1000 ) - END IF -! - IF ( NDS.LT.UNITLW .OR. NDS.GT.UNITHG ) THEN - WRITE (NDSE,1001) NDS, UNITLW, UNITHG - CALL EXTCDE ( 1001 ) - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input + ! + IF ( .NOT. FLINIT ) THEN + WRITE (NDSE,1000) + CALL EXTCDE ( 1000 ) + END IF + ! + IF ( NDS.LT.UNITLW .OR. NDS.GT.UNITHG ) THEN + WRITE (NDSE,1001) NDS, UNITLW, UNITHG + CALL EXTCDE ( 1001 ) + END IF + ! #ifdef W3_T - WRITE (NDST,9000) NDS, U_USED(NDS), U_TYPE(NDS), & - U_NAME(NDS), U_DESC(NDS) + WRITE (NDST,9000) NDS, U_USED(NDS), U_TYPE(NDS), & + U_NAME(NDS), U_DESC(NDS) #endif -! -! -------------------------------------------------------------------- / -! 2. Set data -! 2.a Flag -! - U_USED(NDS) = FLAG -! -! 2.b Type -! - IF ( PRESENT(TYPE) ) U_TYPE(NDS) = TYPE -! -! 2.c Name -! - IF ( PRESENT(NAME) ) THEN - U_NAME(NDS) = NAME - ELSE IF ( .NOT. FLAG ) THEN - U_NAME(NDS) = 'unknown' - END IF -! -! 2.d Description -! - IF ( PRESENT(DESC) ) THEN - U_DESC(NDS) = DESC - ELSE IF ( .NOT. FLAG ) THEN - U_DESC(NDS) = 'unknown' - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 2. Set data + ! 2.a Flag + ! + U_USED(NDS) = FLAG + ! + ! 2.b Type + ! + IF ( PRESENT(TYPE) ) U_TYPE(NDS) = TYPE + ! + ! 2.c Name + ! + IF ( PRESENT(NAME) ) THEN + U_NAME(NDS) = NAME + ELSE IF ( .NOT. FLAG ) THEN + U_NAME(NDS) = 'unknown' + END IF + ! + ! 2.d Description + ! + IF ( PRESENT(DESC) ) THEN + U_DESC(NDS) = DESC + ELSE IF ( .NOT. FLAG ) THEN + U_DESC(NDS) = 'unknown' + END IF + ! #ifdef W3_T - WRITE (NDST,9001) NDS, U_USED(NDS), U_TYPE(NDS), & - U_NAME(NDS), U_DESC(NDS) + WRITE (NDST,9001) NDS, U_USED(NDS), U_TYPE(NDS), & + U_NAME(NDS), U_DESC(NDS) #endif -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** ERROR WMUSET: INITIALIZE FIRST !!! ***') - 1001 FORMAT (/' *** ERROR WMUSET: UNIT NUMBER OUT OF RANGE ***' & - /' REQ/RANG :',3I6/) -! + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** ERROR WMUSET: INITIALIZE FIRST !!! ***') +1001 FORMAT (/' *** ERROR WMUSET: UNIT NUMBER OUT OF RANGE ***' & + /' REQ/RANG :',3I6/) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMUSET: UNIT ',I4', ON SUBROUTINE ENTRY :'/ & - ' FLAG : ',L4/ & - ' TYPE : ',A/ & - ' NAME : ',A/ & - ' DESC : ' A) - 9001 FORMAT ( ' TEST WMUSET: UNIT ',I4', ON SUBROUTINE EXIT :'/ & - ' FLAG : ',L4/ & - ' TYPE : ',A/ & - ' NAME : ',A/ & - ' DESC : ' A) +9000 FORMAT ( ' TEST WMUSET: UNIT ',I4', ON SUBROUTINE ENTRY :'/ & + ' FLAG : ',L4/ & + ' TYPE : ',A/ & + ' NAME : ',A/ & + ' DESC : ' A) +9001 FORMAT ( ' TEST WMUSET: UNIT ',I4', ON SUBROUTINE EXIT :'/ & + ' FLAG : ',L4/ & + ' TYPE : ',A/ & + ' NAME : ',A/ & + ' DESC : ' A) #endif -!/ -!/ End of WMUSET ----------------------------------------------------- / -!/ - END SUBROUTINE WMUSET -!/ ------------------------------------------------------------------- / -!> -!> @brief Find a free unit number for a given file type. -!> -!> @details Search the data base. -!> -!> @param[in] NDSE Unit number for error output. -!> @param[in] NDST Unit number for test output. -!> @param[out] NDS Unit number to be assigned. -!> @param[in] TYPE Type identifier to be used. -!> @param[in] NR Number of consecutive units needed for output -!> bounday data files. -!> -!> @author H. L. Tolman @date 20-Jan-2017 -!> - SUBROUTINE WMUGET ( NDSE, NDST, NDS, TYPE, NR ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 ! -!/ +-----------------------------------+ -!/ -!/ 28-Mar-2005 : Origination. ( version 3.07 ) -!/ 20-Jan-2017 : Add INQUIRE OPENED check. ( version 6.02 ) -!/ (T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! Find a free unit number for a given file type. -! -! 2. Method : -! -! Search the data base. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSE Int. I Unit number for error output. -! NDST Int. I Unit number for test output. -! NDS Int. O Unit number to be assigned. -! TYPE C*3 I Type identifier to be used. -! NR Int. I Number of consecutive units needed. -! Needed for output bounday data files. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! EXCTDE Sur. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE + !/ + !/ End of WMUSET ----------------------------------------------------- / + !/ + END SUBROUTINE WMUSET + !/ ------------------------------------------------------------------- / + !> + !> @brief Find a free unit number for a given file type. + !> + !> @details Search the data base. + !> + !> @param[in] NDSE Unit number for error output. + !> @param[in] NDST Unit number for test output. + !> @param[out] NDS Unit number to be assigned. + !> @param[in] TYPE Type identifier to be used. + !> @param[in] NR Number of consecutive units needed for output + !> bounday data files. + !> + !> @author H. L. Tolman @date 20-Jan-2017 + !> + SUBROUTINE WMUGET ( NDSE, NDST, NDS, TYPE, NR ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 ! + !/ +-----------------------------------+ + !/ + !/ 28-Mar-2005 : Origination. ( version 3.07 ) + !/ 20-Jan-2017 : Add INQUIRE OPENED check. ( version 6.02 ) + !/ (T. J. Campbell, NRL) + !/ + ! 1. Purpose : + ! + ! Find a free unit number for a given file type. + ! + ! 2. Method : + ! + ! Search the data base. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSE Int. I Unit number for error output. + ! NDST Int. I Unit number for test output. + ! NDS Int. O Unit number to be assigned. + ! TYPE C*3 I Type identifier to be used. + ! NR Int. I Number of consecutive units needed. + ! Needed for output bounday data files. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! EXCTDE Sur. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSE, NDST - INTEGER, INTENT(OUT) :: NDS - CHARACTER(LEN=3), INTENT(IN) :: TYPE - INTEGER, INTENT(IN), OPTIONAL :: NR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NRC, I, J + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSE, NDST + INTEGER, INTENT(OUT) :: NDS + CHARACTER(LEN=3), INTENT(IN) :: TYPE + INTEGER, INTENT(IN), OPTIONAL :: NR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NRC, I, J #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - LOGICAL :: OK - LOGICAL :: OPND -!/ + LOGICAL :: OK + LOGICAL :: OPND + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMUGET') + CALL STRACE (IENT, 'WMUGET') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input / output -! - IF ( .NOT. FLINIT ) THEN - WRITE (NDSE,1010) - CALL EXTCDE ( 1010 ) - END IF -! - IF ( PRESENT(NR) ) THEN - NRC = MAX ( 1 , NR ) - ELSE - NRC = 1 - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input / output + ! + IF ( .NOT. FLINIT ) THEN + WRITE (NDSE,1010) + CALL EXTCDE ( 1010 ) + END IF + ! + IF ( PRESENT(NR) ) THEN + NRC = MAX ( 1 , NR ) + ELSE + NRC = 1 + END IF + ! #ifdef W3_T - WRITE (NDST,9010) TYPE, NRC + WRITE (NDST,9010) TYPE, NRC #endif -! -! -------------------------------------------------------------------- / -! 2. Find first free unit number and reset flag -! - NDS = -1 -! - DO I=UNITLW, UNITHG - NRC + 1 -! new: We do not allow I=NDST (unit number for test output). -! NDST (aka MDST or IDST) is set to 10 in call to WMINIT -! (4th argument) - OK = .NOT.U_USED(I) .AND. U_TYPE(I).EQ.TYPE & - .AND. I.NE.NDST - INQUIRE ( I, OPENED=OPND ) - OK = OK .AND. .NOT.OPND - IF ( OK ) THEN - DO J=1, NRC-1 - OK = OK .AND. (.NOT.U_USED(I+J) .AND. & - U_TYPE(I+J).EQ.TYPE ) - INQUIRE ( I+J, OPENED=OPND ) - OK = OK .AND. .NOT.OPND - END DO - END IF - IF ( OK ) THEN - NDS = I - DO J=0, NRC-1 - U_USED(I+J) = .TRUE. - END DO - EXIT - END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Find first free unit number and reset flag + ! + NDS = -1 + ! + DO I=UNITLW, UNITHG - NRC + 1 + ! new: We do not allow I=NDST (unit number for test output). + ! NDST (aka MDST or IDST) is set to 10 in call to WMINIT + ! (4th argument) + OK = .NOT.U_USED(I) .AND. U_TYPE(I).EQ.TYPE & + .AND. I.NE.NDST + INQUIRE ( I, OPENED=OPND ) + OK = OK .AND. .NOT.OPND + IF ( OK ) THEN + DO J=1, NRC-1 + OK = OK .AND. (.NOT.U_USED(I+J) .AND. & + U_TYPE(I+J).EQ.TYPE ) + INQUIRE ( I+J, OPENED=OPND ) + OK = OK .AND. .NOT.OPND END DO -! - IF ( NDS .EQ. -1 ) THEN - WRITE (NDSE,1020) TYPE - CALL EXTCDE ( 1020 ) - END IF -! + END IF + IF ( OK ) THEN + NDS = I + DO J=0, NRC-1 + U_USED(I+J) = .TRUE. + END DO + EXIT + END IF + END DO + ! + IF ( NDS .EQ. -1 ) THEN + WRITE (NDSE,1020) TYPE + CALL EXTCDE ( 1020 ) + END IF + ! #ifdef W3_T - WRITE (NDST,9020) NDS + WRITE (NDST,9020) NDS #endif -! - RETURN -! -! Formats -! - 1010 FORMAT (/' *** ERROR WMUGET: INITIALIZE FIRST !!! ***') - 1020 FORMAT (/' *** ERROR WMUGET: CANNOT FIND FREE UNIT FOR TYPE ', & - A,' ***'/) -! + ! + RETURN + ! + ! Formats + ! +1010 FORMAT (/' *** ERROR WMUGET: INITIALIZE FIRST !!! ***') +1020 FORMAT (/' *** ERROR WMUGET: CANNOT FIND FREE UNIT FOR TYPE ', & + A,' ***'/) + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMUGET: LOOKING FOR UNIT FOR TYPE ',A,' [', & - I2,']') - 9020 FORMAT ( ' TEST WMUGET: UNIT NUMBER SET TO',I4) +9010 FORMAT ( ' TEST WMUGET: LOOKING FOR UNIT FOR TYPE ',A,' [', & + I2,']') +9020 FORMAT ( ' TEST WMUGET: UNIT NUMBER SET TO',I4) #endif -!/ -!/ End of WMUGET ----------------------------------------------------- / -!/ - END SUBROUTINE WMUGET -!/ ------------------------------------------------------------------- / -!> -!> @brief Update data base information for a given unit number. -!> -!> @details FORTRAN INQUIRE statement. -!> -!> @param[in] NDSE Unit number for error output. -!> @param[in] NDST Unit number for test output. -!> @param[in] NDS Unit number to be assigned. -!> -!> @author H. L. Tolman @date 29-Mar-2005 -!> - SUBROUTINE WMUINQ ( NDSE, NDST, NDS ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Mar-2005 ! -!/ +-----------------------------------+ -!/ -!/ 29-Mar-2005 : Origination. ( version 3.07 ) -!/ -! 1. Purpose : -! -! Update data base information for a given unit number. -! -! 2. Method : -! -! FORTRAN INQUIRE statement. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSE Int. I Unit number for error output. -! NDST Int. I Unit number for test output. -! NDS Int. I Unit number to be assigned. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! EXCTDE Sur. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE + !/ + !/ End of WMUGET ----------------------------------------------------- / + !/ + END SUBROUTINE WMUGET + !/ ------------------------------------------------------------------- / + !> + !> @brief Update data base information for a given unit number. + !> + !> @details FORTRAN INQUIRE statement. + !> + !> @param[in] NDSE Unit number for error output. + !> @param[in] NDST Unit number for test output. + !> @param[in] NDS Unit number to be assigned. + !> + !> @author H. L. Tolman @date 29-Mar-2005 + !> + SUBROUTINE WMUINQ ( NDSE, NDST, NDS ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Mar-2005 ! + !/ +-----------------------------------+ + !/ + !/ 29-Mar-2005 : Origination. ( version 3.07 ) + !/ + ! 1. Purpose : + ! + ! Update data base information for a given unit number. + ! + ! 2. Method : + ! + ! FORTRAN INQUIRE statement. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSE Int. I Unit number for error output. + ! NDST Int. I Unit number for test output. + ! NDS Int. I Unit number to be assigned. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! EXCTDE Sur. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSE, NDST, NDS -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSE, NDST, NDS + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - LOGICAL :: CHECK -!/ + LOGICAL :: CHECK + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMUINQ') + CALL STRACE (IENT, 'WMUINQ') #endif -! -! -------------------------------------------------------------------- / -! 1. Test input / output -! - IF ( .NOT. FLINIT ) THEN - WRITE (NDSE,1010) - CALL EXTCDE ( 1010 ) - END IF -! - IF ( NDS.LT.UNITLW .OR. NDS.GT.UNITHG ) THEN - WRITE (NDSE,1011) NDS, UNITLW, UNITHG - CALL EXTCDE ( 1011 ) - END IF -! + ! + ! -------------------------------------------------------------------- / + ! 1. Test input / output + ! + IF ( .NOT. FLINIT ) THEN + WRITE (NDSE,1010) + CALL EXTCDE ( 1010 ) + END IF + ! + IF ( NDS.LT.UNITLW .OR. NDS.GT.UNITHG ) THEN + WRITE (NDSE,1011) NDS, UNITLW, UNITHG + CALL EXTCDE ( 1011 ) + END IF + ! #ifdef W3_T - WRITE (NDST,9010) NDS + WRITE (NDST,9010) NDS #endif -! -! -------------------------------------------------------------------- / -! 2. Check out file -! 2.a Check if opened : -! - INQUIRE (NDS,OPENED=CHECK) -! + ! + ! -------------------------------------------------------------------- / + ! 2. Check out file + ! 2.a Check if opened : + ! + INQUIRE (NDS,OPENED=CHECK) + ! #ifdef W3_T - WRITE (NDST,9020) CHECK + WRITE (NDST,9020) CHECK #endif -! -! 2.b File not opened, release to pool -! - IF ( .NOT. CHECK ) THEN - CALL WMUSET ( NDSE, NDST, NDS, .FALSE. ) - ELSE -! -! 2.c File is opened, get the name -! - INQUIRE (NDS,NAME=U_NAME(NDS)) -! + ! + ! 2.b File not opened, release to pool + ! + IF ( .NOT. CHECK ) THEN + CALL WMUSET ( NDSE, NDST, NDS, .FALSE. ) + ELSE + ! + ! 2.c File is opened, get the name + ! + INQUIRE (NDS,NAME=U_NAME(NDS)) + ! #ifdef W3_T - WRITE (NDST,9021) U_NAME(NDS) + WRITE (NDST,9021) U_NAME(NDS) #endif -! - END IF -! - RETURN -! -! Escape locations read errors --------------------------------------- * -! -! -! Formats -! - 1010 FORMAT (/' *** ERROR WMUINQ: INITIALIZE FIRST !!! ***') - 1011 FORMAT (/' *** ERROR WMUINQ: UNIT NUMBER OUT OF RANGE ***' & - /' REQ/RANG :',3I6/) -! + ! + END IF + ! + RETURN + ! + ! Escape locations read errors --------------------------------------- * + ! + ! + ! Formats + ! +1010 FORMAT (/' *** ERROR WMUINQ: INITIALIZE FIRST !!! ***') +1011 FORMAT (/' *** ERROR WMUINQ: UNIT NUMBER OUT OF RANGE ***' & + /' REQ/RANG :',3I6/) + ! #ifdef W3_T - 9010 FORMAT ( ' TEST WMUINQ: TESTING UNIT NUMBER',I4) - 9020 FORMAT ( ' INQUIRE ON OPENED : ',L2) - 9021 FORMAT ( ' NAME OF FILE : ',A) +9010 FORMAT ( ' TEST WMUINQ: TESTING UNIT NUMBER',I4) +9020 FORMAT ( ' INQUIRE ON OPENED : ',L2) +9021 FORMAT ( ' NAME OF FILE : ',A) #endif -!/ -!/ End of WMUINQ ----------------------------------------------------- / -!/ - END SUBROUTINE WMUINQ -!/ -!/ End of module WMUNITMD -------------------------------------------- / -!/ - END MODULE WMUNITMD + !/ + !/ End of WMUINQ ----------------------------------------------------- / + !/ + END SUBROUTINE WMUINQ + !/ + !/ End of module WMUNITMD -------------------------------------------- / + !/ +END MODULE WMUNITMD diff --git a/model/src/wmupdtmd.F90 b/model/src/wmupdtmd.F90 index 9f9b1e5a8..4bb33df54 100644 --- a/model/src/wmupdtmd.F90 +++ b/model/src/wmupdtmd.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains module WMUPDTMD. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 #include "w3macros.h" @@ -8,1616 +8,1616 @@ !> !> @brief Update model input at the driver level of the multi-grid !> version of WAVEWATCH III. -!> -!> @author H. L. Tolman @date 22-Mar-2021 !> - MODULE WMUPDTMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 22-Feb-2005 : Origination. ( version 3.07 ) -!/ 14-Oct-2006 : Adding separate input grids. ( version 3.10 ) -!/ 10-Dec-2006 : Bug fix WMUPD2 initial fields. ( version 3.10 ) -!/ 12-Jan-2007 : General clean-up and bug fixes. ( version 3.10 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 20-Jan-2017 : Enable using input from coupler ( version 6.02 ) -!/ (T. J. Campbell, NRL) -!/ 01-Jul-2019 : Generalize output to curv grids ( version 7.13 ) -!/ (R. Padilla-Hernandez, J.H. Alves, EMC/NOAA) -!/ 08-Feb-2021 : Add FSWND option for SMC grid. JGLi ( version 7.13 ) -!/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Update model input at the driver level of the multi-grid -! version of WAVEWATCH III. -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WMUPDT Subr. Public Updating of all model inputs. -! WMUPD1 Subr. Public Native inputs. -! WMUPD2 Subr. Public From input grids. -! WMUPDV Subr. Public For WMUPD2 vector fields. -! WMUPDS Subr. Public For WMUPD2 scalar fields. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! !/CRX0 Current vector component conservation. -! !/CRX1 Current speed conservation. -! !/CRX2 Current exenrgy conservation. -! -! !/WNX0 Wind vector component conservation. -! !/WNX1 Wind speed conservation. -! !/WNX2 Wind exenrgy conservation. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/T1 Test output interpolation data. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - INTEGER, PARAMETER :: SWPMAX = 5 !< SWPMAX -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Update inputs for selected wave model grid. -!> -!> @details Reading from native grid files if update is needed based -!> on time of data. +!> @author H. L. Tolman @date 22-Mar-2021 !> -!> @param[in] IMOD Model number -!> @param[inout] TDATA Time for which all is data available. -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE WMUPDT ( IMOD ,TDATA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 22-Feb-2005 : Origination. ( version 3.07 ) -!/ 14-Oct-2006 : Adding separate input grids. ( version 3.10 ) -!/ 12-Jan-2007 : General clean-up and bug fixes. ( version 3.10 ) -!/ 20-Jan-2017 : Enable using input from coupler ( version 6.02 ) -!/ (T. J. Campbell, NRL) -!/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Update inputs for seleceted wave model grid. -! -! 2. Method : -! -! Reading from native grid files if update is needed based on -! time of data. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number, -! TDATA I.A. I Time for which all is data available. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to grid/model. -! W3SETW Subr. W3WDATMD Point to grid/model. -! W3SETI Subr. W3IDATMD Point to grid/model. -! WMSETM Subr. WMMDATMD Point to grid/model. -! STRACE Subr. W3ERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! DSEC21 Func. W3TIMEMD Time difference. -! STME21 Subr. Id. Write time string. -! TICK21 Subr. Id. Advancing time. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Subr. WMWAVEMD Multi-grid model main routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - IDFLDS dimensioning is hardwired as IDFLDS(-7:9) where -! lowest possible value of JFIRST is JFIRST=-7 -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3GDATMD, ONLY: W3SETG - USE W3WDATMD, ONLY: W3SETW - USE W3IDATMD, ONLY: W3SETI - USE WMMDATMD, ONLY: WMSETM - USE W3SERVMD, ONLY: EXTCDE +MODULE WMUPDTMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 22-Feb-2005 : Origination. ( version 3.07 ) + !/ 14-Oct-2006 : Adding separate input grids. ( version 3.10 ) + !/ 10-Dec-2006 : Bug fix WMUPD2 initial fields. ( version 3.10 ) + !/ 12-Jan-2007 : General clean-up and bug fixes. ( version 3.10 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 20-Jan-2017 : Enable using input from coupler ( version 6.02 ) + !/ (T. J. Campbell, NRL) + !/ 01-Jul-2019 : Generalize output to curv grids ( version 7.13 ) + !/ (R. Padilla-Hernandez, J.H. Alves, EMC/NOAA) + !/ 08-Feb-2021 : Add FSWND option for SMC grid. JGLi ( version 7.13 ) + !/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Update model input at the driver level of the multi-grid + ! version of WAVEWATCH III. + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WMUPDT Subr. Public Updating of all model inputs. + ! WMUPD1 Subr. Public Native inputs. + ! WMUPD2 Subr. Public From input grids. + ! WMUPDV Subr. Public For WMUPD2 vector fields. + ! WMUPDS Subr. Public For WMUPD2 scalar fields. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/CRX0 Current vector component conservation. + ! !/CRX1 Current speed conservation. + ! !/CRX2 Current exenrgy conservation. + ! + ! !/WNX0 Wind vector component conservation. + ! !/WNX1 Wind speed conservation. + ! !/WNX2 Wind exenrgy conservation. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/T1 Test output interpolation data. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ + INTEGER, PARAMETER :: SWPMAX = 5 !< SWPMAX + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Update inputs for selected wave model grid. + !> + !> @details Reading from native grid files if update is needed based + !> on time of data. + !> + !> @param[in] IMOD Model number + !> @param[inout] TDATA Time for which all is data available. + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE WMUPDT ( IMOD ,TDATA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 22-Feb-2005 : Origination. ( version 3.07 ) + !/ 14-Oct-2006 : Adding separate input grids. ( version 3.10 ) + !/ 12-Jan-2007 : General clean-up and bug fixes. ( version 3.10 ) + !/ 20-Jan-2017 : Enable using input from coupler ( version 6.02 ) + !/ (T. J. Campbell, NRL) + !/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Update inputs for seleceted wave model grid. + ! + ! 2. Method : + ! + ! Reading from native grid files if update is needed based on + ! time of data. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number, + ! TDATA I.A. I Time for which all is data available. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to grid/model. + ! W3SETW Subr. W3WDATMD Point to grid/model. + ! W3SETI Subr. W3IDATMD Point to grid/model. + ! WMSETM Subr. WMMDATMD Point to grid/model. + ! STRACE Subr. W3ERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! DSEC21 Func. W3TIMEMD Time difference. + ! STME21 Subr. Id. Write time string. + ! TICK21 Subr. Id. Advancing time. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr. WMWAVEMD Multi-grid model main routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - IDFLDS dimensioning is hardwired as IDFLDS(-7:9) where + ! lowest possible value of JFIRST is JFIRST=-7 + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD, ONLY: W3SETG + USE W3WDATMD, ONLY: W3SETW + USE W3IDATMD, ONLY: W3SETI + USE WMMDATMD, ONLY: WMSETM + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif - USE W3TIMEMD, ONLY: DSEC21, STME21, TICK21 -!/ - USE W3GDATMD, ONLY: NX, NY, FILEXT - USE W3WDATMD, ONLY: TIME + USE W3TIMEMD, ONLY: DSEC21, STME21, TICK21 + !/ + USE W3GDATMD, ONLY: NX, NY, FILEXT + USE W3WDATMD, ONLY: TIME - USE W3IDATMD, ONLY: INFLAGS1, TLN, TC0, TCN, TW0, TWN, TU0, & - TUN, TR0, TRN, TIN, T0N, T1N, T2N, TG0, & - TGN, TFN, TDN, TTN, TVN, TZN, TI1, TI2, & - TI3, TI4, TI5, JFIRST + USE W3IDATMD, ONLY: INFLAGS1, TLN, TC0, TCN, TW0, TWN, TU0, & + TUN, TR0, TRN, TIN, T0N, T1N, T2N, TG0, & + TGN, TFN, TDN, TTN, TVN, TZN, TI1, TI2, & + TI3, TI4, TI5, JFIRST - USE WMMDATMD, ONLY: IMPROC, MDSO, MDSS, MDST, MDSE, NMPSCR, & - NMPERR, ETIME, FLLSTL, FLLSTR, FLLSTI, & - INPMAP, IDINP, IFLSTI, IFLSTL, IFLSTR -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD - INTEGER, INTENT(INOUT) :: TDATA(2) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: MDSEN, J, DTIME(2), IERR, NDTNEW, JJ + USE WMMDATMD, ONLY: IMPROC, MDSO, MDSS, MDST, MDSE, NMPSCR, & + NMPERR, ETIME, FLLSTL, FLLSTR, FLLSTI, & + INPMAP, IDINP, IFLSTI, IFLSTL, IFLSTR + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + INTEGER, INTENT(INOUT) :: TDATA(2) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: MDSEN, J, DTIME(2), IERR, NDTNEW, JJ #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: DTTST - LOGICAL :: FIRST - CHARACTER(LEN=13) :: IDFLDS(-7:10) - CHARACTER(LEN=23) :: DTME21 -! - DATA IDFLDS / 'ice param. 1 ' , 'ice param. 2 ' , & - 'ice param. 3 ' , 'ice param. 4 ' , & - 'ice param. 5 ' , & - 'mud density ' , 'mud thkness ' , & - 'mud viscos. ' , & - 'water levels ' , 'currents ' , & - 'winds ' , 'ice fields ' , & - 'momentum ' , 'air density ' , & - 'mean param. ' , '1D spectra ' , & - '2D spectra ' , 'grid speed ' / -!/ -!/ ------------------------------------------------------------------- / -! 0. Initialization -! 0.a Subroutine tracing and echo of input -! + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: DTTST + LOGICAL :: FIRST + CHARACTER(LEN=13) :: IDFLDS(-7:10) + CHARACTER(LEN=23) :: DTME21 + ! + DATA IDFLDS / 'ice param. 1 ' , 'ice param. 2 ' , & + 'ice param. 3 ' , 'ice param. 4 ' , & + 'ice param. 5 ' , & + 'mud density ' , 'mud thkness ' , & + 'mud viscos. ' , & + 'water levels ' , 'currents ' , & + 'winds ' , 'ice fields ' , & + 'momentum ' , 'air density ' , & + 'mean param. ' , '1D spectra ' , & + '2D spectra ' , 'grid speed ' / + !/ + !/ ------------------------------------------------------------------- / + ! 0. Initialization + ! 0.a Subroutine tracing and echo of input + ! #ifdef W3_S - CALL STRACE (IENT, 'WMUPDT') + CALL STRACE (IENT, 'WMUPDT') #endif #ifdef W3_T - WRITE (MDST,9000) IMOD, TDATA -#endif -! - IF ( IMPROC .EQ. NMPERR ) THEN - MDSEN = MDSE - ELSE - MDSEN = -1 - END IF -! -! 0.b Point to proper grids and initialize -! - CALL W3SETG ( IMOD, MDSE, MDST ) - CALL W3SETW ( IMOD, MDSE, MDST ) - CALL W3SETI ( IMOD, MDSE, MDST ) - CALL WMSETM ( IMOD, MDSE, MDST ) -! - FLLSTL = .FALSE. - FLLSTI = .FALSE. - FLLSTR = .FALSE. - IERR = 0 -! -! 0.c Output -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - CALL STME21 ( TIME , DTME21 ) - WRITE (MDSS,900) IMOD, DTME21 - END IF -! + WRITE (MDST,9000) IMOD, TDATA +#endif + ! + IF ( IMPROC .EQ. NMPERR ) THEN + MDSEN = MDSE + ELSE + MDSEN = -1 + END IF + ! + ! 0.b Point to proper grids and initialize + ! + CALL W3SETG ( IMOD, MDSE, MDST ) + CALL W3SETW ( IMOD, MDSE, MDST ) + CALL W3SETI ( IMOD, MDSE, MDST ) + CALL WMSETM ( IMOD, MDSE, MDST ) + ! + FLLSTL = .FALSE. + FLLSTI = .FALSE. + FLLSTR = .FALSE. + IERR = 0 + ! + ! 0.c Output + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + CALL STME21 ( TIME , DTME21 ) + WRITE (MDSS,900) IMOD, DTME21 + END IF + ! #ifdef W3_T - WRITE (MDST,9001) ' J', '0-N', TIME, ETIME - IF (LBOUND(IDINP,2).LE.-7) WRITE (MDST,9002) -7, IDINP(IMOD,-7), INFLAGS1(-7), TI1 - IF (LBOUND(IDINP,2).LE.-6) WRITE (MDST,9002) -6, IDINP(IMOD,-6), INFLAGS1(-6), TI2 - IF (LBOUND(IDINP,2).LE.-5) WRITE (MDST,9002) -5, IDINP(IMOD,-5), INFLAGS1(-5), TI3 - IF (LBOUND(IDINP,2).LE.-4) WRITE (MDST,9002) -4, IDINP(IMOD,-4), INFLAGS1(-4), TI4 - IF (LBOUND(IDINP,2).LE.-3) WRITE (MDST,9002) -3, IDINP(IMOD,-3), INFLAGS1(-3), TI5 - IF (LBOUND(IDINP,2).LE.-2) WRITE (MDST,9002) -2, IDINP(IMOD,-2), INFLAGS1(-2), TZN - IF (LBOUND(IDINP,2).LE.-1) WRITE (MDST,9002) -1, IDINP(IMOD,-1), INFLAGS1(-1), TTN - IF (LBOUND(IDINP,2).LE. 0) WRITE (MDST,9002) 0, IDINP(IMOD, 0), INFLAGS1( 0), TVN - WRITE (MDST,9002) 1, IDINP(IMOD,1), INFLAGS1(1), TLN - WRITE (MDST,9003) 2, IDINP(IMOD,2), INFLAGS1(2), TC0, TCN - WRITE (MDST,9003) 3, IDINP(IMOD,3), INFLAGS1(3), TW0, TWN - WRITE (MDST,9002) 4, IDINP(IMOD,4), INFLAGS1(4), TIN - WRITE (MDST,9003) 5, IDINP(IMOD,5), INFLAGS1(5), TU0, TUN - WRITE (MDST,9003) 6, IDINP(IMOD,6), INFLAGS1(6), TR0, TRN - WRITE (MDST,9002) 7, IDINP(IMOD,7), INFLAGS1(7), T0N - WRITE (MDST,9002) 8, IDINP(IMOD,8), INFLAGS1(8), T1N - WRITE (MDST,9002) 9, IDINP(IMOD,9), INFLAGS1(9), T2N - WRITE (MDST,9003) 10, 'MOV' , INFLAGS1(10), TG0, TGN - WRITE (MDST,9004) 'GRD', NX, NY -#endif -! -! 1. Loop over input types ------------------------------------------ / -! - DO J=JFIRST, 10 -! -! 1.a Check if update needed -! - IF ( .NOT. INFLAGS1(J) ) CYCLE -! + WRITE (MDST,9001) ' J', '0-N', TIME, ETIME + IF (LBOUND(IDINP,2).LE.-7) WRITE (MDST,9002) -7, IDINP(IMOD,-7), INFLAGS1(-7), TI1 + IF (LBOUND(IDINP,2).LE.-6) WRITE (MDST,9002) -6, IDINP(IMOD,-6), INFLAGS1(-6), TI2 + IF (LBOUND(IDINP,2).LE.-5) WRITE (MDST,9002) -5, IDINP(IMOD,-5), INFLAGS1(-5), TI3 + IF (LBOUND(IDINP,2).LE.-4) WRITE (MDST,9002) -4, IDINP(IMOD,-4), INFLAGS1(-4), TI4 + IF (LBOUND(IDINP,2).LE.-3) WRITE (MDST,9002) -3, IDINP(IMOD,-3), INFLAGS1(-3), TI5 + IF (LBOUND(IDINP,2).LE.-2) WRITE (MDST,9002) -2, IDINP(IMOD,-2), INFLAGS1(-2), TZN + IF (LBOUND(IDINP,2).LE.-1) WRITE (MDST,9002) -1, IDINP(IMOD,-1), INFLAGS1(-1), TTN + IF (LBOUND(IDINP,2).LE. 0) WRITE (MDST,9002) 0, IDINP(IMOD, 0), INFLAGS1( 0), TVN + WRITE (MDST,9002) 1, IDINP(IMOD,1), INFLAGS1(1), TLN + WRITE (MDST,9003) 2, IDINP(IMOD,2), INFLAGS1(2), TC0, TCN + WRITE (MDST,9003) 3, IDINP(IMOD,3), INFLAGS1(3), TW0, TWN + WRITE (MDST,9002) 4, IDINP(IMOD,4), INFLAGS1(4), TIN + WRITE (MDST,9003) 5, IDINP(IMOD,5), INFLAGS1(5), TU0, TUN + WRITE (MDST,9003) 6, IDINP(IMOD,6), INFLAGS1(6), TR0, TRN + WRITE (MDST,9002) 7, IDINP(IMOD,7), INFLAGS1(7), T0N + WRITE (MDST,9002) 8, IDINP(IMOD,8), INFLAGS1(8), T1N + WRITE (MDST,9002) 9, IDINP(IMOD,9), INFLAGS1(9), T2N + WRITE (MDST,9003) 10, 'MOV' , INFLAGS1(10), TG0, TGN + WRITE (MDST,9004) 'GRD', NX, NY +#endif + ! + ! 1. Loop over input types ------------------------------------------ / + ! + DO J=JFIRST, 10 + ! + ! 1.a Check if update needed + ! + IF ( .NOT. INFLAGS1(J) ) CYCLE + ! #ifdef W3_T - WRITE (MDST,9010) J, INFLAGS1(J), INPMAP(IMOD,J) -#endif -! -! 1.b Test time -! + WRITE (MDST,9010) J, INFLAGS1(J), INPMAP(IMOD,J) +#endif + ! + ! 1.b Test time + ! + IF ( TFN(1,J) .EQ. -1 ) THEN + FIRST = .TRUE. + DTTST = 0. + ELSE + FIRST = .FALSE. + DTTST = DSEC21 ( TIME , TFN(:,J) ) + END IF + ! +#ifdef W3_T + WRITE (MDST,9011) IDINP(IMOD,J), DTTST, TFN(:,J) +#endif + ! + IF ( DTTST .GT. 0. ) CYCLE + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,901) IDFLDS(J) + ! + ! 2. Forcing input from file & defined on the native grid ----------- / + ! + IF ( INPMAP(IMOD,J) .EQ. 0 ) THEN + ! +#ifdef W3_T + WRITE (MDST,9020) +#endif + ! + CALL WMUPD1 ( IMOD, IDINP(IMOD,J), J, IERR ) + ! + ! 3. Forcing input from file & defined on an input grid ------------- / + ! + ELSE IF ( INPMAP(IMOD,J) .GT. 0 ) THEN + ! +#ifdef W3_T + WRITE (MDST,9030) INPMAP(IMOD,J) +#endif + ! + ! 3.a Check if input grid is available + ! + JJ = -INPMAP(IMOD,J) + CALL W3SETG ( JJ, MDSE, MDST ) + CALL W3SETI ( JJ, MDSE, MDST ) + ! IF ( TFN(1,J) .EQ. -1 ) THEN - FIRST = .TRUE. - DTTST = 0. + DTTST = 0. + ELSE + IF ( FIRST .OR. ( J.EQ.1 .AND. IFLSTL(-JJ) ) & + .OR. ( J.EQ.4 .AND. IFLSTI(-JJ) ) & + .OR. ( J.EQ.6 .AND. IFLSTR(-JJ) ) ) THEN + DTTST = 1. ELSE - FIRST = .FALSE. DTTST = DSEC21 ( TIME , TFN(:,J) ) END IF -! -#ifdef W3_T - WRITE (MDST,9011) IDINP(IMOD,J), DTTST, TFN(:,J) -#endif -! - IF ( DTTST .GT. 0. ) CYCLE - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,901) IDFLDS(J) -! -! 2. Forcing input from file & defined on the native grid ----------- / -! - IF ( INPMAP(IMOD,J) .EQ. 0 ) THEN -! -#ifdef W3_T - WRITE (MDST,9020) -#endif -! - CALL WMUPD1 ( IMOD, IDINP(IMOD,J), J, IERR ) -! -! 3. Forcing input from file & defined on an input grid ------------- / -! - ELSE IF ( INPMAP(IMOD,J) .GT. 0 ) THEN -! -#ifdef W3_T - WRITE (MDST,9030) INPMAP(IMOD,J) -#endif -! -! 3.a Check if input grid is available -! - JJ = -INPMAP(IMOD,J) - CALL W3SETG ( JJ, MDSE, MDST ) - CALL W3SETI ( JJ, MDSE, MDST ) -! - IF ( TFN(1,J) .EQ. -1 ) THEN - DTTST = 0. - ELSE - IF ( FIRST .OR. ( J.EQ.1 .AND. IFLSTL(-JJ) ) & - .OR. ( J.EQ.4 .AND. IFLSTI(-JJ) ) & - .OR. ( J.EQ.6 .AND. IFLSTR(-JJ) ) ) THEN - DTTST = 1. - ELSE - DTTST = DSEC21 ( TIME , TFN(:,J) ) - END IF - END IF -! - IF ( J .EQ. 1 ) FLLSTL = IFLSTL(-JJ) - IF ( J .EQ. 4 ) FLLSTI = IFLSTI(-JJ) - IF ( J .EQ. 6 ) FLLSTR = IFLSTR(-JJ) -! + END IF + ! + IF ( J .EQ. 1 ) FLLSTL = IFLSTL(-JJ) + IF ( J .EQ. 4 ) FLLSTI = IFLSTI(-JJ) + IF ( J .EQ. 6 ) FLLSTR = IFLSTR(-JJ) + ! #ifdef W3_T - WRITE (MDST,9031) J, IDINP(JJ,J), DTTST, TFN(:,J) -#endif -! -! 3.b If needed, update input grid -! Note: flags in WMMDATMD set for grid IMOD ! -! - IF ( DTTST .LE. 0. ) THEN -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,930) FILEXT -! - CALL WMUPD1 ( JJ, IDINP(JJ,J), J, IERR ) -! - IF ( J .EQ. 1 ) IFLSTL(-JJ) = FLLSTL - IF ( J .EQ. 4 ) IFLSTI(-JJ) = FLLSTI - IF ( J .EQ. 6 ) IFLSTR(-JJ) = FLLSTR -! - END IF -! -! 3.c Set up for update, and call updating routine -! - CALL W3SETG ( IMOD, MDSE, MDST ) - CALL W3SETI ( IMOD, MDSE, MDST ) -! - CALL WMUPD2 ( IMOD, J, JJ, IERR ) -! -! 4. Forcing input from CPL ----------------------------------------- / -! - ELSE ! INPMAP(IMOD,J) .LT. 0 - ! Data input and time stamp settings for forcing input from - ! CPL are handled in wmesmfmd.ftn:GetImport -! + WRITE (MDST,9031) J, IDINP(JJ,J), DTTST, TFN(:,J) +#endif + ! + ! 3.b If needed, update input grid + ! Note: flags in WMMDATMD set for grid IMOD ! + ! + IF ( DTTST .LE. 0. ) THEN + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,930) FILEXT + ! + CALL WMUPD1 ( JJ, IDINP(JJ,J), J, IERR ) + ! + IF ( J .EQ. 1 ) IFLSTL(-JJ) = FLLSTL + IF ( J .EQ. 4 ) IFLSTI(-JJ) = FLLSTI + IF ( J .EQ. 6 ) IFLSTR(-JJ) = FLLSTR + ! + END IF + ! + ! 3.c Set up for update, and call updating routine + ! + CALL W3SETG ( IMOD, MDSE, MDST ) + CALL W3SETI ( IMOD, MDSE, MDST ) + ! + CALL WMUPD2 ( IMOD, J, JJ, IERR ) + ! + ! 4. Forcing input from CPL ----------------------------------------- / + ! + ELSE ! INPMAP(IMOD,J) .LT. 0 + ! Data input and time stamp settings for forcing input from + ! CPL are handled in wmesmfmd.ftn:GetImport + ! #ifdef W3_T - IF ( INPMAP(IMOD,J) .EQ. -999 ) THEN - ! *** Forcing input from CPL & defined on native grid *** - WRITE (MDST,9040) - ELSE - ! *** Forcing input from CPL & defined on an input grid *** - WRITE (MDST,9050) -INPMAP(IMOD,J) - END IF + IF ( INPMAP(IMOD,J) .EQ. -999 ) THEN + ! *** Forcing input from CPL & defined on native grid *** + WRITE (MDST,9040) + ELSE + ! *** Forcing input from CPL & defined on an input grid *** + WRITE (MDST,9050) -INPMAP(IMOD,J) + END IF #endif -! - END IF -! -! 5. Finalize for each type ----------------------------------------- / -! 5.a Process IERR output -! - IF ( IERR.GT.0 ) GOTO 2000 - IF ( IERR.LT.0 .AND. MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,950) IDFLDS(J) -! -! 5.b End of master loop -! - END DO -! -! 6. Compute TDATA -------------------------------------------------- / -! - TDATA = ETIME -! - DO J=JFIRST, 10 - IF ( .NOT. INFLAGS1(J) ) CYCLE - DTTST = DSEC21 ( TFN(:,J) , TDATA ) - IF ( DTTST.GT.0. .AND. .NOT. ( (FLLSTL .AND. J.EQ.1) .OR. & - (FLLSTI .AND. J.EQ.4) .OR. & - (FLLSTR .AND. J.EQ.6) ) ) THEN - TDATA = TFN(:,J) - END IF - END DO -! -! 6. Compute TDN ---------------------------------------------------- / -! - TDN = TDATA - CALL TICK21 ( TDN, 1. ) - DO J=7, 9 - IF ( INFLAGS1(J) ) THEN - DTTST = DSEC21 ( TFN(:,J) , TDN ) - IF ( DTTST.GT.0. ) TDN = TFN(:,J) - END IF - END DO -! -! 7. Final test output ---------------------------------------------- / -! + ! + END IF + ! + ! 5. Finalize for each type ----------------------------------------- / + ! 5.a Process IERR output + ! + IF ( IERR.GT.0 ) GOTO 2000 + IF ( IERR.LT.0 .AND. MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,950) IDFLDS(J) + ! + ! 5.b End of master loop + ! + END DO + ! + ! 6. Compute TDATA -------------------------------------------------- / + ! + TDATA = ETIME + ! + DO J=JFIRST, 10 + IF ( .NOT. INFLAGS1(J) ) CYCLE + DTTST = DSEC21 ( TFN(:,J) , TDATA ) + IF ( DTTST.GT.0. .AND. .NOT. ( (FLLSTL .AND. J.EQ.1) .OR. & + (FLLSTI .AND. J.EQ.4) .OR. & + (FLLSTR .AND. J.EQ.6) ) ) THEN + TDATA = TFN(:,J) + END IF + END DO + ! + ! 6. Compute TDN ---------------------------------------------------- / + ! + TDN = TDATA + CALL TICK21 ( TDN, 1. ) + DO J=7, 9 + IF ( INFLAGS1(J) ) THEN + DTTST = DSEC21 ( TFN(:,J) , TDN ) + IF ( DTTST.GT.0. ) TDN = TFN(:,J) + END IF + END DO + ! + ! 7. Final test output ---------------------------------------------- / + ! #ifdef W3_T - WRITE (MDST,9070) ' J', '0-N', TIME, ETIME, TDATA - IF (LBOUND(IDINP,2).LE.-7) WRITE (MDST,9071) -7, IDINP(IMOD,-7), INFLAGS1(-7), TI1 - IF (LBOUND(IDINP,2).LE.-6) WRITE (MDST,9071) -6, IDINP(IMOD,-6), INFLAGS1(-6), TI2 - IF (LBOUND(IDINP,2).LE.-5) WRITE (MDST,9071) -5, IDINP(IMOD,-5), INFLAGS1(-5), TI3 - IF (LBOUND(IDINP,2).LE.-4) WRITE (MDST,9071) -4, IDINP(IMOD,-4), INFLAGS1(-4), TI4 - IF (LBOUND(IDINP,2).LE.-3) WRITE (MDST,9071) -3, IDINP(IMOD,-3), INFLAGS1(-3), TI5 - IF (LBOUND(IDINP,2).LE.-2) WRITE (MDST,9071) -2, IDINP(IMOD,-2), INFLAGS1(-2), TZN - IF (LBOUND(IDINP,2).LE.-1) WRITE (MDST,9071) -1, IDINP(IMOD,-1), INFLAGS1(-1), TTN - IF (LBOUND(IDINP,2).LE. 0) WRITE (MDST,9071) 0, IDINP(IMOD, 0), INFLAGS1( 0), TVN - WRITE (MDST,9071) 1, IDINP(IMOD,1), INFLAGS1(1), TLN - WRITE (MDST,9072) 2, IDINP(IMOD,2), INFLAGS1(2), TC0, TCN - WRITE (MDST,9072) 3, IDINP(IMOD,3), INFLAGS1(3), TW0, TWN - WRITE (MDST,9071) 4, IDINP(IMOD,4), INFLAGS1(4), TIN - WRITE (MDST,9072) 5, IDINP(IMOD,5), INFLAGS1(5), TU0, TUN - WRITE (MDST,9072) 6, IDINP(IMOD,6), INFLAGS1(6), TR0, TRN - WRITE (MDST,9071) 7, IDINP(IMOD,7), INFLAGS1(7), T0N - WRITE (MDST,9071) 8, IDINP(IMOD,8), INFLAGS1(8), T1N - WRITE (MDST,9073) 9, IDINP(IMOD,9), INFLAGS1(9), T2N, TDN - WRITE (MDST,9072) 10, 'MOV' , INFLAGS1(10), TG0, TGN -#endif -! - RETURN -! -! Error escape locations -! - 2000 CONTINUE - CALL EXTCDE ( 2000 ) - RETURN -! -! Formats -! - 900 FORMAT ( ' Updating input for grid',I3,' at ',A) - 901 FORMAT ( ' Updating ',A) - 930 FORMAT ( ' First updating ',A) - 950 FORMAT ( ' Past last ',A) -! + WRITE (MDST,9070) ' J', '0-N', TIME, ETIME, TDATA + IF (LBOUND(IDINP,2).LE.-7) WRITE (MDST,9071) -7, IDINP(IMOD,-7), INFLAGS1(-7), TI1 + IF (LBOUND(IDINP,2).LE.-6) WRITE (MDST,9071) -6, IDINP(IMOD,-6), INFLAGS1(-6), TI2 + IF (LBOUND(IDINP,2).LE.-5) WRITE (MDST,9071) -5, IDINP(IMOD,-5), INFLAGS1(-5), TI3 + IF (LBOUND(IDINP,2).LE.-4) WRITE (MDST,9071) -4, IDINP(IMOD,-4), INFLAGS1(-4), TI4 + IF (LBOUND(IDINP,2).LE.-3) WRITE (MDST,9071) -3, IDINP(IMOD,-3), INFLAGS1(-3), TI5 + IF (LBOUND(IDINP,2).LE.-2) WRITE (MDST,9071) -2, IDINP(IMOD,-2), INFLAGS1(-2), TZN + IF (LBOUND(IDINP,2).LE.-1) WRITE (MDST,9071) -1, IDINP(IMOD,-1), INFLAGS1(-1), TTN + IF (LBOUND(IDINP,2).LE. 0) WRITE (MDST,9071) 0, IDINP(IMOD, 0), INFLAGS1( 0), TVN + WRITE (MDST,9071) 1, IDINP(IMOD,1), INFLAGS1(1), TLN + WRITE (MDST,9072) 2, IDINP(IMOD,2), INFLAGS1(2), TC0, TCN + WRITE (MDST,9072) 3, IDINP(IMOD,3), INFLAGS1(3), TW0, TWN + WRITE (MDST,9071) 4, IDINP(IMOD,4), INFLAGS1(4), TIN + WRITE (MDST,9072) 5, IDINP(IMOD,5), INFLAGS1(5), TU0, TUN + WRITE (MDST,9072) 6, IDINP(IMOD,6), INFLAGS1(6), TR0, TRN + WRITE (MDST,9071) 7, IDINP(IMOD,7), INFLAGS1(7), T0N + WRITE (MDST,9071) 8, IDINP(IMOD,8), INFLAGS1(8), T1N + WRITE (MDST,9073) 9, IDINP(IMOD,9), INFLAGS1(9), T2N, TDN + WRITE (MDST,9072) 10, 'MOV' , INFLAGS1(10), TG0, TGN +#endif + ! + RETURN + ! + ! Error escape locations + ! +2000 CONTINUE + CALL EXTCDE ( 2000 ) + RETURN + ! + ! Formats + ! +900 FORMAT ( ' Updating input for grid',I3,' at ',A) +901 FORMAT ( ' Updating ',A) +930 FORMAT ( ' First updating ',A) +950 FORMAT ( ' Past last ',A) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMUPDT : INPUT : ',I4,I10.8,I7.6, & - ' <============================') - 9001 FORMAT ( ' TEST WMUPDT : ',A2,1X,A3,3X, 2(I10.8,I7.6)) - 9002 FORMAT ( ' ',I2,1X,A3,L3,17X,1(I10.8,I7.6)) - 9003 FORMAT ( ' ',I2,1X,A3,L3, 2(I10.8,I7.6)) - 9004 FORMAT ( ' ',2X,1X,A3,3X,2I10 ) - 9010 FORMAT ( ' TEST WMUPDT : J, FLAG, INPMAP : ',I2,L2,I4) - 9011 FORMAT ( ' TEST WMUPDT : ',A,', DTTST = ',E10.3,2X,I9.8,I7.6) - 9020 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM FILE & DEFINED ON THE NATIVE GRID') - 9030 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM FILE & DEFINED ON INPUT GRID',I4) - 9031 FORMAT ( ' TEST WMUPDT : J =',I4,3XA,', DTTST = ', & - E10.3,2X,I9.8,I7.6) - 9040 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM CPL & DEFINED ON THE NATIVE GRID') - 9050 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM CPL & DEFINED ON INPUT GRID',I4) - 9070 FORMAT ( ' TEST WMUPDT : ',A2,1X,A3,3X, 3(I10.8,I7.6)) - 9071 FORMAT ( ' ',I2,1X,A3,L3,17X,1(I10.8,I7.6)) - 9072 FORMAT ( ' ',I2,1X,A3,L3, 2(I10.8,I7.6)) - 9073 FORMAT ( ' ',I2,1X,A3,L3,17X,2(I10.8,I7.6)) -#endif -!/ -!/ End of WMUPDT ----------------------------------------------------- / -!/ - END SUBROUTINE WMUPDT -!/ ------------------------------------------------------------------- / -!> -!> @brief Update selected input using native input files. -!> -!> @details Reading from native grid files. -!> -!> @param[in] IMOD Model number. -!> @param[in] IDSTR ID string corresponding to J. -!> @param[in] J Input type. -!> @param[out] IERR Error indicator. -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE WMUPD1 ( IMOD, IDSTR, J, IERR ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 07-Oct-2006 : Origination. ( version 3.10 ) -!/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Update selected input using native input files. -! -! 2. Method : -! -! Reading from native grid files. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number, -! IDSTR C*3 I ID string corresponding to J. -! J Int. I Input type. -! IERR Int. O Error indicator. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMDIMD Subr. WMMDATMD Set dimension of data grids. -! W3FLDG Subr. W3FLDSMD Get input field. -! W3FLDD Subr. Id. Get input data. -! W3FLDM Subr. Id. Get grid speed data. -! STRACE Subr. W3ERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMUPDT Subr. WMUPDTMD Master inpu update routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Pointers set in calling routine. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE WMMDATMD, ONLY: WMDIMD - USE W3FLDSMD, ONLY: W3FLDG, W3FLDD, W3FLDM +9000 FORMAT ( ' TEST WMUPDT : INPUT : ',I4,I10.8,I7.6, & + ' <============================') +9001 FORMAT ( ' TEST WMUPDT : ',A2,1X,A3,3X, 2(I10.8,I7.6)) +9002 FORMAT ( ' ',I2,1X,A3,L3,17X,1(I10.8,I7.6)) +9003 FORMAT ( ' ',I2,1X,A3,L3, 2(I10.8,I7.6)) +9004 FORMAT ( ' ',2X,1X,A3,3X,2I10 ) +9010 FORMAT ( ' TEST WMUPDT : J, FLAG, INPMAP : ',I2,L2,I4) +9011 FORMAT ( ' TEST WMUPDT : ',A,', DTTST = ',E10.3,2X,I9.8,I7.6) +9020 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM FILE & DEFINED ON THE NATIVE GRID') +9030 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM FILE & DEFINED ON INPUT GRID',I4) +9031 FORMAT ( ' TEST WMUPDT : J =',I4,3XA,', DTTST = ', & + E10.3,2X,I9.8,I7.6) +9040 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM CPL & DEFINED ON THE NATIVE GRID') +9050 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM CPL & DEFINED ON INPUT GRID',I4) +9070 FORMAT ( ' TEST WMUPDT : ',A2,1X,A3,3X, 3(I10.8,I7.6)) +9071 FORMAT ( ' ',I2,1X,A3,L3,17X,1(I10.8,I7.6)) +9072 FORMAT ( ' ',I2,1X,A3,L3, 2(I10.8,I7.6)) +9073 FORMAT ( ' ',I2,1X,A3,L3,17X,2(I10.8,I7.6)) +#endif + !/ + !/ End of WMUPDT ----------------------------------------------------- / + !/ + END SUBROUTINE WMUPDT + !/ ------------------------------------------------------------------- / + !> + !> @brief Update selected input using native input files. + !> + !> @details Reading from native grid files. + !> + !> @param[in] IMOD Model number. + !> @param[in] IDSTR ID string corresponding to J. + !> @param[in] J Input type. + !> @param[out] IERR Error indicator. + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE WMUPD1 ( IMOD, IDSTR, J, IERR ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 07-Oct-2006 : Origination. ( version 3.10 ) + !/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Update selected input using native input files. + ! + ! 2. Method : + ! + ! Reading from native grid files. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number, + ! IDSTR C*3 I ID string corresponding to J. + ! J Int. I Input type. + ! IERR Int. O Error indicator. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMDIMD Subr. WMMDATMD Set dimension of data grids. + ! W3FLDG Subr. W3FLDSMD Get input field. + ! W3FLDD Subr. Id. Get input data. + ! W3FLDM Subr. Id. Get grid speed data. + ! STRACE Subr. W3ERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMUPDT Subr. WMUPDTMD Master inpu update routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Pointers set in calling routine. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE WMMDATMD, ONLY: WMDIMD + USE W3FLDSMD, ONLY: W3FLDG, W3FLDD, W3FLDM #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -!/ - USE W3GDATMD, ONLY: NX, NY + !/ + USE W3GDATMD, ONLY: NX, NY #ifdef W3_SMC - USE W3GDATMD, ONLY: FSWND, NSEA -#endif - USE W3WDATMD, ONLY: TIME - USE W3IDATMD, ONLY: TLN, WLEV, TC0, TCN, CX0, CXN, CY0, CYN, & - TW0, TWN, TU0, TUN, TR0, TRN, WX0, WXN, & - WY0, WYN, DT0, DTN, TIN, TRN, ICEI, UX0, & - UXN, UY0, UYN, RH0, RHN, T0N, T1N, T2N, & - TDN, INFLAGS1, TG0, TGN, GA0, GD0, GAN, & - GDN, BERGI, TTN, MUDT, TVN, MUDV, TZN, & - MUDD, TI1, TI2, TI3, TI4, TI5, ICEP1, & - ICEP2, ICEP3, ICEP4, ICEP5 - USE WMMDATMD, ONLY: IMPROC, NMPERR, MDST, MDSE, MDSF, ETIME, & - FLLSTL, FLLSTI, FLLSTR, RCLD, NDT, DATA0, & - DATA1, DATA2, NMV, NMVMAX, TMV, AMV, DMV -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, J - INTEGER, INTENT(OUT) :: IERR - CHARACTER(LEN=3), INTENT(IN) :: IDSTR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: MDSEN, DTIME(2), NDTNEW - REAL :: XXX(NY,NX) + USE W3GDATMD, ONLY: FSWND, NSEA +#endif + USE W3WDATMD, ONLY: TIME + USE W3IDATMD, ONLY: TLN, WLEV, TC0, TCN, CX0, CXN, CY0, CYN, & + TW0, TWN, TU0, TUN, TR0, TRN, WX0, WXN, & + WY0, WYN, DT0, DTN, TIN, TRN, ICEI, UX0, & + UXN, UY0, UYN, RH0, RHN, T0N, T1N, T2N, & + TDN, INFLAGS1, TG0, TGN, GA0, GD0, GAN, & + GDN, BERGI, TTN, MUDT, TVN, MUDV, TZN, & + MUDD, TI1, TI2, TI3, TI4, TI5, ICEP1, & + ICEP2, ICEP3, ICEP4, ICEP5 + USE WMMDATMD, ONLY: IMPROC, NMPERR, MDST, MDSE, MDSF, ETIME, & + FLLSTL, FLLSTI, FLLSTR, RCLD, NDT, DATA0, & + DATA1, DATA2, NMV, NMVMAX, TMV, AMV, DMV + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, J + INTEGER, INTENT(OUT) :: IERR + CHARACTER(LEN=3), INTENT(IN) :: IDSTR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: MDSEN, DTIME(2), NDTNEW + REAL :: XXX(NY,NX) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -! 0. Initialization -! 0.a Subroutine tracing and echo of input -! + !/ + !/ ------------------------------------------------------------------- / + ! 0. Initialization + ! 0.a Subroutine tracing and echo of input + ! #ifdef W3_S - CALL STRACE (IENT, 'WMUPD1') + CALL STRACE (IENT, 'WMUPD1') #endif #ifdef W3_T - WRITE (MDST,9000) IMOD, J -#endif -! - IF ( IMPROC .EQ. NMPERR ) THEN - MDSEN = MDSE - ELSE - MDSEN = -1 - END IF -! -! 0.b Start case selection -! - SELECT CASE (J) -! -! -7. Ice parameter 1 ---------------------------------------------- / -! - CASE (-7) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, DTIME, & - XXX, XXX, XXX, TI1, XXX, XXX, ICEP1, IERR) -! -! -6. Ice parameter 2 ---------------------------------------------- / -! - CASE (-6) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, DTIME, & - XXX, XXX, XXX, TI2, XXX, XXX, ICEP2, IERR) -! -! -5. Ice parameter 3 ---------------------------------------------- / -! - CASE (-5) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, DTIME, & - XXX, XXX, XXX, TI3, XXX, XXX, ICEP3, IERR) -! -! -4. Ice parameter 4 ---------------------------------------------- / -! - CASE (-4) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, DTIME, & - XXX, XXX, XXX, TI4, XXX, XXX, ICEP4, IERR) -! -! -3. Ice parameter 5 ---------------------------------------------- / -! - CASE (-3) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, DTIME, & - XXX, XXX, XXX, TI5, XXX, XXX, ICEP5, IERR) -! -! -2. Mud Density -------------------------------------------------- / -! - CASE (-2) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, DTIME, & - XXX, XXX, XXX, TZN, XXX, XXX, MUDD, IERR) -! -! -1. Mud Thickness -------------------------------------------------- / -! - CASE (-1) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, DTIME, & - XXX, XXX, XXX, TTN, XXX, XXX, MUDT, IERR) -! -! 0. Mud Viscosity -------------------------------------------------- / -! - CASE (0) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, DTIME, & - XXX, XXX, XXX, TVN, XXX, XXX, MUDV, IERR) -! -! 1. Water levels --------------------------------------------------- / -! - CASE (1) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, DTIME, & - XXX, XXX, XXX, TLN, XXX, XXX, WLEV, IERR) - IF ( IERR .LT. 0 ) FLLSTL = .TRUE. -! -! 2. Currents ------------------------------------------------------- / -! - CASE (2) + WRITE (MDST,9000) IMOD, J +#endif + ! + IF ( IMPROC .EQ. NMPERR ) THEN + MDSEN = MDSE + ELSE + MDSEN = -1 + END IF + ! + ! 0.b Start case selection + ! + SELECT CASE (J) + ! + ! -7. Ice parameter 1 ---------------------------------------------- / + ! + CASE (-7) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, DTIME, & + XXX, XXX, XXX, TI1, XXX, XXX, ICEP1, IERR) + ! + ! -6. Ice parameter 2 ---------------------------------------------- / + ! + CASE (-6) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, DTIME, & + XXX, XXX, XXX, TI2, XXX, XXX, ICEP2, IERR) + ! + ! -5. Ice parameter 3 ---------------------------------------------- / + ! + CASE (-5) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, DTIME, & + XXX, XXX, XXX, TI3, XXX, XXX, ICEP3, IERR) + ! + ! -4. Ice parameter 4 ---------------------------------------------- / + ! + CASE (-4) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, DTIME, & + XXX, XXX, XXX, TI4, XXX, XXX, ICEP4, IERR) + ! + ! -3. Ice parameter 5 ---------------------------------------------- / + ! + CASE (-3) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, DTIME, & + XXX, XXX, XXX, TI5, XXX, XXX, ICEP5, IERR) + ! + ! -2. Mud Density -------------------------------------------------- / + ! + CASE (-2) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, DTIME, & + XXX, XXX, XXX, TZN, XXX, XXX, MUDD, IERR) + ! + ! -1. Mud Thickness -------------------------------------------------- / + ! + CASE (-1) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, DTIME, & + XXX, XXX, XXX, TTN, XXX, XXX, MUDT, IERR) + ! + ! 0. Mud Viscosity -------------------------------------------------- / + ! + CASE (0) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, DTIME, & + XXX, XXX, XXX, TVN, XXX, XXX, MUDV, IERR) + ! + ! 1. Water levels --------------------------------------------------- / + ! + CASE (1) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, DTIME, & + XXX, XXX, XXX, TLN, XXX, XXX, WLEV, IERR) + IF ( IERR .LT. 0 ) FLLSTL = .TRUE. + ! + ! 2. Currents ------------------------------------------------------- / + ! + CASE (2) #ifdef W3_SMC - !!Li For sea point current option FSWND. JGLi08Feb2021 - IF( FSWND ) THEN - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NSEA, 1, NSEA, 1, TIME, ETIME, TC0, & - CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) - ELSE -#endif - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, TC0, & - CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) + !!Li For sea point current option FSWND. JGLi08Feb2021 + IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NSEA, 1, NSEA, 1, TIME, ETIME, TC0, & + CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) + ELSE +#endif + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, TC0, & + CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) #ifdef W3_SMC - END IF + END IF #endif -! -! 3. Winds ---------------------------------------------------------- / -! - CASE (3) + ! + ! 3. Winds ---------------------------------------------------------- / + ! + CASE (3) #ifdef W3_SMC - !!Li For sea point wind option FSWND. JGLi08Feb2021 - IF( FSWND ) THEN - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NSEA, 1, NSEA, 1, TIME, ETIME, TW0, & - WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) - ELSE -#endif - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, TW0, & - WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) + !!Li For sea point wind option FSWND. JGLi08Feb2021 + IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NSEA, 1, NSEA, 1, TIME, ETIME, TW0, & + WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) + ELSE +#endif + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, TW0, & + WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) #ifdef W3_SMC - END IF -#endif -! -! 4. Ice ------------------------------------------------------------ / -! - CASE (4) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, DTIME, & - XXX, XXX, XXX, TIN, XXX , BERGI, ICEI, IERR) - IF ( IERR .LT. 0 ) FLLSTI = .TRUE. -! -! 5. Momentum ------------------------------------------------------- / -! - CASE (5) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, TU0, & - UX0, UY0, XXX, TUN, UXN, UYN, XXX, IERR) -! -! 6. Air density ---------------------------------------------------- / -! - CASE (6) - CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - NX, NY, NX, NY, TIME, ETIME, TR0, & - XXX, XXX, RH0, TRN, XXX, XXX, RHN, IERR) - IF ( IERR .LT. 0 ) FLLSTR = .TRUE. -! -! 7. Data type 0 ---------------------------------------------------- / -! - CASE (7) - CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - TIME, T0N, RCLD(1), NDT(1), NDTNEW, & - DATA0, IERR ) - IF ( IERR .LT. 0 ) THEN - INFLAGS1(J) = .FALSE. - RCLD(1) = 1 - NDT(1) = 1 - CALL WMDIMD ( IMOD, MDSE, MDST, 1 ) - ELSE - NDT(J) = NDTNEW - CALL WMDIMD ( IMOD, MDSE, MDST, 1 ) - CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, & - MDSEN, TIME, T0N, RCLD(1), NDT(1), & - NDTNEW, DATA0, IERR ) - END IF -! -! 8. Data type 1 ---------------------------------------------------- / -! - CASE ( 8 ) - CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - TIME, T1N, RCLD(2), NDT(2), NDTNEW, & - DATA1, IERR ) - IF ( IERR .LT. 0 ) THEN - INFLAGS1(J) = .FALSE. - RCLD(2) = 1 - NDT(2) = 1 - CALL WMDIMD ( IMOD, MDSE, MDST, 2 ) - ELSE - NDT(J) = NDTNEW - CALL WMDIMD ( IMOD, MDSE, MDST, 2 ) - CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, & - MDSEN, TIME, T1N, RCLD(2), NDT(2), & - NDTNEW, DATA1, IERR ) - END IF -! -! 9. Data type 2 ---------------------------------------------------- / -! - CASE ( 9 ) - CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & - TIME, T2N, RCLD(3), NDT(3), NDTNEW, & - DATA2, IERR ) - IF ( IERR .LT. 0 ) THEN - INFLAGS1(J) = .FALSE. - RCLD(3) = 1 - NDT(3) = 1 - CALL WMDIMD ( IMOD, MDSE, MDST, 3 ) - ELSE - NDT(J) = NDTNEW - CALL WMDIMD ( IMOD, MDSE, MDST, 3 ) - CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, & - MDSEN, TIME, T2N, RCLD(3), NDT(3), & - NDTNEW, DATA2, IERR ) - END IF -! -! 10. Moving grid data ---------------------------------------------- / -! - CASE ( 10 ) -! notes: -! SUBROUTINE W3FLDM in w3fldsmd.ftn : -! INTEGER, INTENT(INOUT) :: NH, THO(2,6,NHM), TF0(2), TFN(2) -! INTEGER, INTENT(INOUT) :: NH, THO(2,-7:6,NHM), TF0(2), TFN(2) -! REAL, INTENT(INOUT) :: HA(NHM,6), HD(NHM,6), A0, AN, D0, DN -! REAL, INTENT(INOUT) :: HA(NHM,-7:6), HD(NHM,-7:6), A0, AN, D0, DN -! Arguments # -! THO 8 -! HA 9 -! HD 10 -! Here, that is TMV AMV DMV - CALL W3FLDM ( 4, MDST, MDSEN, TIME, ETIME, NMV, NMVMAX, TMV,& - AMV, DMV, TG0, GA0, GD0, TGN, GAN, GDN, IERR ) -! - END SELECT -! -! 9. End of routine -------------------------------------------------- / -! - RETURN -! -! Formats -! -#ifdef W3_T - 9000 FORMAT ( ' TEST WMUPD1 : INPUT : ',2I4) + END IF #endif -!/ -!/ End of WMUPD1 ----------------------------------------------------- / -!/ - END SUBROUTINE WMUPD1 -!/ ------------------------------------------------------------------- / -!> -!> @brief Update selected input using input grids. -!> -!> @details Managing data, interpolation done in other routines. -!> -!> @param[in] IMOD Model number. -!> @param[in] J Input type. -!> @param[in] JMOD Model number source grid. -!> @param[out] IERR Error indicator. -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 14-Oct-2006 : Origination. ( version 3.10 ) -!/ 10-Dec-2006 : Bug fix WMUPD2 initial fields. ( version 3.10 ) -!/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Update selected input using input grids. -! -! 2. Method : -! -! Managing data, interpolation done inother routines. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number, -! J Int. I Input type. -! JMOD Int. I Model number source grid. -! IERR Int. O Error indicator. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3ERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! WMUPDV Subr. local Interpolation of vector fields. -! WMUPDS Subr. local Interpolation of scalar fields. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMUPDT Subr. WMUPDTMD Master input update routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/CRX0 Current vector component conservation. -! !/CRX1 Current speed conservation. -! !/CRX2 Current exenrgy conservation. -! -! !/WNX0 Wind vector component conservation. -! !/WNX1 Wind speed conservation. -! !/WNX2 Wind exenrgy conservation. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3SERVMD, ONLY: EXTCDE + ! + ! 4. Ice ------------------------------------------------------------ / + ! + CASE (4) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, DTIME, & + XXX, XXX, XXX, TIN, XXX , BERGI, ICEI, IERR) + IF ( IERR .LT. 0 ) FLLSTI = .TRUE. + ! + ! 5. Momentum ------------------------------------------------------- / + ! + CASE (5) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, TU0, & + UX0, UY0, XXX, TUN, UXN, UYN, XXX, IERR) + ! + ! 6. Air density ---------------------------------------------------- / + ! + CASE (6) + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NX, NY, NX, NY, TIME, ETIME, TR0, & + XXX, XXX, RH0, TRN, XXX, XXX, RHN, IERR) + IF ( IERR .LT. 0 ) FLLSTR = .TRUE. + ! + ! 7. Data type 0 ---------------------------------------------------- / + ! + CASE (7) + CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + TIME, T0N, RCLD(1), NDT(1), NDTNEW, & + DATA0, IERR ) + IF ( IERR .LT. 0 ) THEN + INFLAGS1(J) = .FALSE. + RCLD(1) = 1 + NDT(1) = 1 + CALL WMDIMD ( IMOD, MDSE, MDST, 1 ) + ELSE + NDT(J) = NDTNEW + CALL WMDIMD ( IMOD, MDSE, MDST, 1 ) + CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, & + MDSEN, TIME, T0N, RCLD(1), NDT(1), & + NDTNEW, DATA0, IERR ) + END IF + ! + ! 8. Data type 1 ---------------------------------------------------- / + ! + CASE ( 8 ) + CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + TIME, T1N, RCLD(2), NDT(2), NDTNEW, & + DATA1, IERR ) + IF ( IERR .LT. 0 ) THEN + INFLAGS1(J) = .FALSE. + RCLD(2) = 1 + NDT(2) = 1 + CALL WMDIMD ( IMOD, MDSE, MDST, 2 ) + ELSE + NDT(J) = NDTNEW + CALL WMDIMD ( IMOD, MDSE, MDST, 2 ) + CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, & + MDSEN, TIME, T1N, RCLD(2), NDT(2), & + NDTNEW, DATA1, IERR ) + END IF + ! + ! 9. Data type 2 ---------------------------------------------------- / + ! + CASE ( 9 ) + CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + TIME, T2N, RCLD(3), NDT(3), NDTNEW, & + DATA2, IERR ) + IF ( IERR .LT. 0 ) THEN + INFLAGS1(J) = .FALSE. + RCLD(3) = 1 + NDT(3) = 1 + CALL WMDIMD ( IMOD, MDSE, MDST, 3 ) + ELSE + NDT(J) = NDTNEW + CALL WMDIMD ( IMOD, MDSE, MDST, 3 ) + CALL W3FLDD ('SIZE', IDSTR, MDSF(IMOD,J), MDST, & + MDSEN, TIME, T2N, RCLD(3), NDT(3), & + NDTNEW, DATA2, IERR ) + END IF + ! + ! 10. Moving grid data ---------------------------------------------- / + ! + CASE ( 10 ) + ! notes: + ! SUBROUTINE W3FLDM in w3fldsmd.ftn : + ! INTEGER, INTENT(INOUT) :: NH, THO(2,6,NHM), TF0(2), TFN(2) + ! INTEGER, INTENT(INOUT) :: NH, THO(2,-7:6,NHM), TF0(2), TFN(2) + ! REAL, INTENT(INOUT) :: HA(NHM,6), HD(NHM,6), A0, AN, D0, DN + ! REAL, INTENT(INOUT) :: HA(NHM,-7:6), HD(NHM,-7:6), A0, AN, D0, DN + ! Arguments # + ! THO 8 + ! HA 9 + ! HD 10 + ! Here, that is TMV AMV DMV + CALL W3FLDM ( 4, MDST, MDSEN, TIME, ETIME, NMV, NMVMAX, TMV,& + AMV, DMV, TG0, GA0, GD0, TGN, GAN, GDN, IERR ) + ! + END SELECT + ! + ! 9. End of routine -------------------------------------------------- / + ! + RETURN + ! + ! Formats + ! +#ifdef W3_T +9000 FORMAT ( ' TEST WMUPD1 : INPUT : ',2I4) +#endif + !/ + !/ End of WMUPD1 ----------------------------------------------------- / + !/ + END SUBROUTINE WMUPD1 + !/ ------------------------------------------------------------------- / + !> + !> @brief Update selected input using input grids. + !> + !> @details Managing data, interpolation done in other routines. + !> + !> @param[in] IMOD Model number. + !> @param[in] J Input type. + !> @param[in] JMOD Model number source grid. + !> @param[out] IERR Error indicator. + !> + !> @author H. L. Tolman @date 22-Mar-2021 + !> + SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 14-Oct-2006 : Origination. ( version 3.10 ) + !/ 10-Dec-2006 : Bug fix WMUPD2 initial fields. ( version 3.10 ) + !/ 22-Mar-2021 : Add momentum and air density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Update selected input using input grids. + ! + ! 2. Method : + ! + ! Managing data, interpolation done inother routines. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number, + ! J Int. I Input type. + ! JMOD Int. I Model number source grid. + ! IERR Int. O Error indicator. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3ERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! WMUPDV Subr. local Interpolation of vector fields. + ! WMUPDS Subr. local Interpolation of scalar fields. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMUPDT Subr. WMUPDTMD Master input update routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/CRX0 Current vector component conservation. + ! !/CRX1 Current speed conservation. + ! !/CRX2 Current exenrgy conservation. + ! + ! !/WNX0 Wind vector component conservation. + ! !/WNX1 Wind speed conservation. + ! !/WNX2 Wind exenrgy conservation. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - USE W3WDATMD, ONLY: TIME - USE W3IDATMD, ONLY: INPUTS - USE WMMDATMD, ONLY: IMPROC, NMPERR, NMPSCR, MDST, MDSE, MDSS, & - MDSO, ETIME, IDINP - USE CONSTANTS, ONLY: DAIR -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, J, JMOD - INTEGER, INTENT(OUT) :: IERR -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ICONSC, ICONSW, ICONSU + USE W3SERVMD, ONLY: STRACE +#endif + !/ + USE W3WDATMD, ONLY: TIME + USE W3IDATMD, ONLY: INPUTS + USE WMMDATMD, ONLY: IMPROC, NMPERR, NMPSCR, MDST, MDSE, MDSS, & + MDSO, ETIME, IDINP + USE CONSTANTS, ONLY: DAIR + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, J, JMOD + INTEGER, INTENT(OUT) :: IERR + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ICONSC, ICONSW, ICONSU #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -! 0. Initialization -! 0.a Subroutine tracing and echo of input -! + !/ + !/ ------------------------------------------------------------------- / + ! 0. Initialization + ! 0.a Subroutine tracing and echo of input + ! #ifdef W3_S - CALL STRACE (IENT, 'WMUPD2') + CALL STRACE (IENT, 'WMUPD2') #endif -! + ! #ifdef W3_T - WRITE (MDST,9000) IMOD, J, JMOD - WRITE (MDST,9001) INPUTS(IMOD)%TFN(:,J), & - INPUTS(JMOD)%TFN(:,J), ETIME + WRITE (MDST,9000) IMOD, J, JMOD + WRITE (MDST,9001) INPUTS(IMOD)%TFN(:,J), & + INPUTS(JMOD)%TFN(:,J), ETIME #endif -! - IERR = 0 + ! + IERR = 0 #ifdef W3_CRX0 - ICONSC = 0 + ICONSC = 0 #endif #ifdef W3_CRX1 - ICONSC = 1 + ICONSC = 1 #endif #ifdef W3_CRX2 - ICONSC = 2 + ICONSC = 2 #endif #ifdef W3_WNX0 - ICONSW = 0 + ICONSW = 0 #endif #ifdef W3_WNX1 - ICONSW = 1 + ICONSW = 1 #endif #ifdef W3_WNX2 - ICONSW = 2 + ICONSW = 2 #endif #ifdef W3_WNX0 - ICONSU = 0 + ICONSU = 0 #endif #ifdef W3_WNX1 - ICONSU = 1 + ICONSU = 1 #endif #ifdef W3_WNX2 - ICONSU = 2 -#endif -! -! 1. Shift fields ( currents and winds only ) ------------------------ / -! - SELECT CASE (J) -! -! 1.a Currents -! - CASE (2) - IF ( INPUTS(IMOD)%TFN(1,J) .GT. 0 ) THEN - INPUTS(IMOD)%TC0(:) = INPUTS(IMOD)%TFN(:,J) - INPUTS(IMOD)%CX0 = INPUTS(IMOD)%CXN - INPUTS(IMOD)%CY0 = INPUTS(IMOD)%CYN + ICONSU = 2 +#endif + ! + ! 1. Shift fields ( currents and winds only ) ------------------------ / + ! + SELECT CASE (J) + ! + ! 1.a Currents + ! + CASE (2) + IF ( INPUTS(IMOD)%TFN(1,J) .GT. 0 ) THEN + INPUTS(IMOD)%TC0(:) = INPUTS(IMOD)%TFN(:,J) + INPUTS(IMOD)%CX0 = INPUTS(IMOD)%CXN + INPUTS(IMOD)%CY0 = INPUTS(IMOD)%CYN #ifdef W3_T - WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) - ELSE - WRITE (MDST,9011) J + WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) + ELSE + WRITE (MDST,9011) J #endif - END IF -! -! 1.b Winds -! - CASE (3) - IF ( INPUTS(IMOD)%TFN(1,J) .GT. 0 ) THEN - INPUTS(IMOD)%TW0(:) = INPUTS(IMOD)%TFN(:,J) - INPUTS(IMOD)%WX0 = INPUTS(IMOD)%WXN - INPUTS(IMOD)%WY0 = INPUTS(IMOD)%WYN - INPUTS(IMOD)%DT0 = INPUTS(IMOD)%DTN + END IF + ! + ! 1.b Winds + ! + CASE (3) + IF ( INPUTS(IMOD)%TFN(1,J) .GT. 0 ) THEN + INPUTS(IMOD)%TW0(:) = INPUTS(IMOD)%TFN(:,J) + INPUTS(IMOD)%WX0 = INPUTS(IMOD)%WXN + INPUTS(IMOD)%WY0 = INPUTS(IMOD)%WYN + INPUTS(IMOD)%DT0 = INPUTS(IMOD)%DTN #ifdef W3_T - WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) - ELSE - WRITE (MDST,9011) J + WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) + ELSE + WRITE (MDST,9011) J #endif - END IF -! -! 1.c Momentum -! - CASE (5) - IF ( INPUTS(IMOD)%TFN(1,J) .GT. 0 ) THEN - INPUTS(IMOD)%TU0(:) = INPUTS(IMOD)%TFN(:,J) - INPUTS(IMOD)%UX0 = INPUTS(IMOD)%UXN - INPUTS(IMOD)%UY0 = INPUTS(IMOD)%UYN + END IF + ! + ! 1.c Momentum + ! + CASE (5) + IF ( INPUTS(IMOD)%TFN(1,J) .GT. 0 ) THEN + INPUTS(IMOD)%TU0(:) = INPUTS(IMOD)%TFN(:,J) + INPUTS(IMOD)%UX0 = INPUTS(IMOD)%UXN + INPUTS(IMOD)%UY0 = INPUTS(IMOD)%UYN #ifdef W3_T - WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) - ELSE - WRITE (MDST,9011) J + WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) + ELSE + WRITE (MDST,9011) J #endif - END IF -! - END SELECT -! -! 2. Process fields at ending time ----------------------------------- / -! + END IF + ! + END SELECT + ! + ! 2. Process fields at ending time ----------------------------------- / + ! #ifdef W3_T - WRITE (MDST,9020) J, INPUTS(JMOD)%TFN(:,J) -#endif - INPUTS(IMOD)%TFN(:,J) = INPUTS(JMOD)%TFN(:,J) -! - SELECT CASE (J) -! -! 2.a-3 Ice parameter 1 -! - CASE (-7) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEP1, & - JMOD, INPUTS(JMOD)%ICEP1, 0. ) -! -! 2.a-3 Ice parameter 2 -! - CASE (-6) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEP2, & - JMOD, INPUTS(JMOD)%ICEP2, 0. ) -! -! 2.a-3 Ice parameter 3 -! - CASE (-5) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEP3, & - JMOD, INPUTS(JMOD)%ICEP3, 0. ) -! -! 2.a-3 Ice parameter 4 -! - CASE (-4) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEP4, & - JMOD, INPUTS(JMOD)%ICEP4, 0. ) -! -! 2.a-3 Ice parameter 5 -! - CASE (-3) + WRITE (MDST,9020) J, INPUTS(JMOD)%TFN(:,J) +#endif + INPUTS(IMOD)%TFN(:,J) = INPUTS(JMOD)%TFN(:,J) + ! + SELECT CASE (J) + ! + ! 2.a-3 Ice parameter 1 + ! + CASE (-7) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEP1, & + JMOD, INPUTS(JMOD)%ICEP1, 0. ) + ! + ! 2.a-3 Ice parameter 2 + ! + CASE (-6) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEP2, & + JMOD, INPUTS(JMOD)%ICEP2, 0. ) + ! + ! 2.a-3 Ice parameter 3 + ! + CASE (-5) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEP3, & + JMOD, INPUTS(JMOD)%ICEP3, 0. ) + ! + ! 2.a-3 Ice parameter 4 + ! + CASE (-4) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEP4, & + JMOD, INPUTS(JMOD)%ICEP4, 0. ) + ! + ! 2.a-3 Ice parameter 5 + ! + CASE (-3) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEP5, & - JMOD, INPUTS(JMOD)%ICEP5, 0. ) -! -! 2.a-2 Mud densities -! - CASE (-2) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%MUDD, & - JMOD, INPUTS(JMOD)%MUDD, 0. ) -! -! 2.a-1 Mud viscosities -! - CASE (-1) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%MUDT, & - JMOD, INPUTS(JMOD)%MUDT, 0. ) -! -! 2.a-0 Mud thicknesses -! - CASE (0) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%MUDV, & - JMOD, INPUTS(JMOD)%MUDV, 0. ) -! -! 2.a Water levels -! - CASE (1) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%WLEV, & - JMOD, INPUTS(JMOD)%WLEV, 0. ) -! -! 2.b Curents -! - CASE (2) - CALL WMUPDV ( IMOD, INPUTS(IMOD)%CXN, INPUTS(IMOD)%CYN, & - JMOD, INPUTS(JMOD)%CXN, INPUTS(JMOD)%CYN, & - 0., ICONSC ) -! -! 2.c Wind speeds -! - CASE (3) - CALL WMUPDV ( IMOD, INPUTS(IMOD)%WXN, INPUTS(IMOD)%WYN, & - JMOD, INPUTS(JMOD)%WXN, INPUTS(JMOD)%WYN, & - 0., ICONSW ) -! - IF ( IDINP(IMOD,J) .EQ. 'WNS' ) CALL WMUPDS & - ( IMOD, INPUTS(IMOD)%DTN, & - JMOD, INPUTS(JMOD)%DTN, 0. ) -! -! 2.d Ice concentrations -! - CASE (4) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEI, & - JMOD, INPUTS(JMOD)%ICEI, 0. ) - IF ( IDINP(IMOD,J) .EQ. 'ISI' ) CALL WMUPDS & - ( IMOD, INPUTS(IMOD)%BERGI, & - JMOD, INPUTS(JMOD)%BERGI, 0. ) -! -! 2.e Momentum -! - CASE (5) - CALL WMUPDV ( IMOD, INPUTS(IMOD)%UXN, INPUTS(IMOD)%UYN, & - JMOD, INPUTS(JMOD)%UXN, INPUTS(JMOD)%UYN, & - 0., ICONSU ) -! -! 2.f Air density -! - CASE (6) - CALL WMUPDS ( IMOD, INPUTS(IMOD)%RHN, & - JMOD, INPUTS(JMOD)%RHN, DAIR ) -! -! 2.g Assimilation data 0 -! - CASE (7) - GOTO 2999 -! -! 2.h Assimilation data 1 -! - CASE (8) - GOTO 2999 -! -! 2.i Assimilation data 2 -! - CASE (9) - GOTO 2999 -! - END SELECT -! -! 3. Check and update first fields ( currents and winds only ) ------- / -! - SELECT CASE (J) -! -! 3.a Currents -! - CASE (2) - IF ( INPUTS(IMOD)%TC0(1) .LT. 0 ) THEN - INPUTS(IMOD)%TC0(:) = INPUTS(JMOD)%TC0(:) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEP5, & + JMOD, INPUTS(JMOD)%ICEP5, 0. ) + ! + ! 2.a-2 Mud densities + ! + CASE (-2) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%MUDD, & + JMOD, INPUTS(JMOD)%MUDD, 0. ) + ! + ! 2.a-1 Mud viscosities + ! + CASE (-1) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%MUDT, & + JMOD, INPUTS(JMOD)%MUDT, 0. ) + ! + ! 2.a-0 Mud thicknesses + ! + CASE (0) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%MUDV, & + JMOD, INPUTS(JMOD)%MUDV, 0. ) + ! + ! 2.a Water levels + ! + CASE (1) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%WLEV, & + JMOD, INPUTS(JMOD)%WLEV, 0. ) + ! + ! 2.b Curents + ! + CASE (2) + CALL WMUPDV ( IMOD, INPUTS(IMOD)%CXN, INPUTS(IMOD)%CYN, & + JMOD, INPUTS(JMOD)%CXN, INPUTS(JMOD)%CYN, & + 0., ICONSC ) + ! + ! 2.c Wind speeds + ! + CASE (3) + CALL WMUPDV ( IMOD, INPUTS(IMOD)%WXN, INPUTS(IMOD)%WYN, & + JMOD, INPUTS(JMOD)%WXN, INPUTS(JMOD)%WYN, & + 0., ICONSW ) + ! + IF ( IDINP(IMOD,J) .EQ. 'WNS' ) CALL WMUPDS & + ( IMOD, INPUTS(IMOD)%DTN, & + JMOD, INPUTS(JMOD)%DTN, 0. ) + ! + ! 2.d Ice concentrations + ! + CASE (4) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%ICEI, & + JMOD, INPUTS(JMOD)%ICEI, 0. ) + IF ( IDINP(IMOD,J) .EQ. 'ISI' ) CALL WMUPDS & + ( IMOD, INPUTS(IMOD)%BERGI, & + JMOD, INPUTS(JMOD)%BERGI, 0. ) + ! + ! 2.e Momentum + ! + CASE (5) + CALL WMUPDV ( IMOD, INPUTS(IMOD)%UXN, INPUTS(IMOD)%UYN, & + JMOD, INPUTS(JMOD)%UXN, INPUTS(JMOD)%UYN, & + 0., ICONSU ) + ! + ! 2.f Air density + ! + CASE (6) + CALL WMUPDS ( IMOD, INPUTS(IMOD)%RHN, & + JMOD, INPUTS(JMOD)%RHN, DAIR ) + ! + ! 2.g Assimilation data 0 + ! + CASE (7) + GOTO 2999 + ! + ! 2.h Assimilation data 1 + ! + CASE (8) + GOTO 2999 + ! + ! 2.i Assimilation data 2 + ! + CASE (9) + GOTO 2999 + ! + END SELECT + ! + ! 3. Check and update first fields ( currents and winds only ) ------- / + ! + SELECT CASE (J) + ! + ! 3.a Currents + ! + CASE (2) + IF ( INPUTS(IMOD)%TC0(1) .LT. 0 ) THEN + INPUTS(IMOD)%TC0(:) = INPUTS(JMOD)%TC0(:) #ifdef W3_T - WRITE (MDST,9030) J, INPUTS(IMOD)%TC0(:) + WRITE (MDST,9030) J, INPUTS(IMOD)%TC0(:) #endif #ifdef W3_CRX0 - ICONSC = 0 + ICONSC = 0 #endif #ifdef W3_CRX1 - ICONSC = 1 + ICONSC = 1 #endif #ifdef W3_CRX2 - ICONSC = 2 + ICONSC = 2 #endif - CALL WMUPDV ( IMOD, INPUTS(IMOD)%CX0, INPUTS(IMOD)%CY0, & - JMOD, INPUTS(JMOD)%CX0, INPUTS(JMOD)%CY0, & - 0., ICONSC ) - END IF -! -! 3.b Winds -! - CASE (3) - IF ( INPUTS(IMOD)%TW0(1) .LT. 0 ) THEN - INPUTS(IMOD)%TW0(:) = INPUTS(JMOD)%TW0(:) + CALL WMUPDV ( IMOD, INPUTS(IMOD)%CX0, INPUTS(IMOD)%CY0, & + JMOD, INPUTS(JMOD)%CX0, INPUTS(JMOD)%CY0, & + 0., ICONSC ) + END IF + ! + ! 3.b Winds + ! + CASE (3) + IF ( INPUTS(IMOD)%TW0(1) .LT. 0 ) THEN + INPUTS(IMOD)%TW0(:) = INPUTS(JMOD)%TW0(:) #ifdef W3_T - WRITE (MDST,9030) J, INPUTS(IMOD)%TW0(:) + WRITE (MDST,9030) J, INPUTS(IMOD)%TW0(:) #endif #ifdef W3_WNX0 - ICONSW = 0 + ICONSW = 0 #endif #ifdef W3_WNX1 - ICONSW = 1 + ICONSW = 1 #endif #ifdef W3_WNX2 - ICONSW = 2 -#endif - CALL WMUPDV ( IMOD, INPUTS(IMOD)%WX0, INPUTS(IMOD)%WY0, & - JMOD, INPUTS(JMOD)%WX0, INPUTS(JMOD)%WY0, & - 0., ICONSW ) - IF ( IDINP(IMOD,J) .EQ. 'WNS' ) CALL WMUPDS & - ( IMOD, INPUTS(IMOD)%DT0, & - JMOD, INPUTS(JMOD)%DT0, 0. ) - END IF -! -! 3.c Momentum -! - CASE (5) - IF ( INPUTS(IMOD)%TU0(1) .LT. 0 ) THEN - INPUTS(IMOD)%TU0(:) = INPUTS(JMOD)%TU0(:) + ICONSW = 2 +#endif + CALL WMUPDV ( IMOD, INPUTS(IMOD)%WX0, INPUTS(IMOD)%WY0, & + JMOD, INPUTS(JMOD)%WX0, INPUTS(JMOD)%WY0, & + 0., ICONSW ) + IF ( IDINP(IMOD,J) .EQ. 'WNS' ) CALL WMUPDS & + ( IMOD, INPUTS(IMOD)%DT0, & + JMOD, INPUTS(JMOD)%DT0, 0. ) + END IF + ! + ! 3.c Momentum + ! + CASE (5) + IF ( INPUTS(IMOD)%TU0(1) .LT. 0 ) THEN + INPUTS(IMOD)%TU0(:) = INPUTS(JMOD)%TU0(:) #ifdef W3_T - WRITE (MDST,9030) J, INPUTS(IMOD)%TU0(:) + WRITE (MDST,9030) J, INPUTS(IMOD)%TU0(:) #endif #ifdef W3_WNX0 - ICONSU = 0 + ICONSU = 0 #endif #ifdef W3_WNX1 - ICONSU = 1 + ICONSU = 1 #endif #ifdef W3_WNX2 - ICONSU = 2 + ICONSU = 2 #endif - CALL WMUPDV ( IMOD, INPUTS(IMOD)%UX0, INPUTS(IMOD)%UY0, & - JMOD, INPUTS(JMOD)%UX0, INPUTS(JMOD)%UY0, & - 0., ICONSU ) - END IF -! - END SELECT -! -! 4. End of routine -------------------------------------------------- / -! - RETURN -! -! Error escape locations -! - 2999 CONTINUE - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSE,1999) - CALL EXTCDE ( 2999 ) - RETURN -! -! Formats -! - 1999 FORMAT (/' *** ERROR WMUPD2: OPTION NOT YET IMPLEMENTED ***'/) -! + CALL WMUPDV ( IMOD, INPUTS(IMOD)%UX0, INPUTS(IMOD)%UY0, & + JMOD, INPUTS(JMOD)%UX0, INPUTS(JMOD)%UY0, & + 0., ICONSU ) + END IF + ! + END SELECT + ! + ! 4. End of routine -------------------------------------------------- / + ! + RETURN + ! + ! Error escape locations + ! +2999 CONTINUE + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSE,1999) + CALL EXTCDE ( 2999 ) + RETURN + ! + ! Formats + ! +1999 FORMAT (/' *** ERROR WMUPD2: OPTION NOT YET IMPLEMENTED ***'/) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMUPD2 : INPUT : ',3I4) - 9001 FORMAT ( ' TEST WMUPD2 : TIME OF IMOD : ',I9.8,1X,I6.6/ & - ' TIME OF JMOD : ',I9.8,1X,I6.6/ & - ' ENDING TIME : ',I9.8,1X,I6.6) - 9010 FORMAT ( ' TEST WMUPD2 : SHIFTING ',I1,' TIME = ',I8.8,I7.6) - 9011 FORMAT ( ' TEST WMUPD2 : NO DATA FOR ',I1,' TO SHIFT') - 9020 FORMAT ( ' TEST WMUPD2 : PROCESSING ',I1,' TIME = ',I8.8,I7.6) - 9030 FORMAT ( ' TEST WMUPD2 : INITIAL FIELD FOR ',I1, & - ' TIME = ',I8.8,I7.6) -#endif -!/ -!/ End of WMUPD2 ----------------------------------------------------- / -!/ - END SUBROUTINE WMUPD2 -!/ ------------------------------------------------------------------- / -!> -!> @brief Interpolate vector field from input grid to model grid. -!> -!> @details Interpolating or averaging from input grid. -!> -!> @param[in] IMOD Output model number -!> @param[out] VX Output vector field -!> @param[out] VY Output vector field -!> @param[in] JMOD Input model number -!> @param[in] VXI Input vector field -!> @param[in] VYI Input vector field -!> @param[in] UNDEF Value for mapped out point and points not covered. -!> @param[in] CONSTP Convervation type -!> -!> @author H. L. Tolman @date 06-Dec-2010 -!> - SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Dec-2010 | -!/ +-----------------------------------+ -!/ -!/ 14-Oct-2006 : Origination. ( version 3.10 ) -!/ 12-Jan-2007 : General clean-up and bug fixes. ( version 3.10 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 01-Jul-2019 : Generalize output to curv grids ( version 7.13 ) -!/ (R. Padilla-Hernandez, J.H. Alves, EMC/NOAA) -!/ -! 1. Purpose : -! -! Interpolate vector field from input grid to model grid. -! -! 2. Method : -! -! Interpolating or averaging from input grid. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Output model number, -! VX/Y Int. O Output vector field. -! JMOD Int. I Input model number, -! VX/YI Int. I Input vector field. -! UNDEF Int. I Value for mapped out point and points not -! covered. -! CONSTP Int. I Conservation type : -! 1: Vector speed. -! 2: Vector speed squared. -! *: Vector components. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3ERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMUPD2 Subr. WMUPDTMD Input update routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Grid pointers for output grid need to be set externally. -! - If input grid does not cover point of target grid, target grid -! values are set to UNDEF. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/T1 Test output interpolation data. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3SERVMD, ONLY: EXTCDE +9000 FORMAT ( ' TEST WMUPD2 : INPUT : ',3I4) +9001 FORMAT ( ' TEST WMUPD2 : TIME OF IMOD : ',I9.8,1X,I6.6/ & + ' TIME OF JMOD : ',I9.8,1X,I6.6/ & + ' ENDING TIME : ',I9.8,1X,I6.6) +9010 FORMAT ( ' TEST WMUPD2 : SHIFTING ',I1,' TIME = ',I8.8,I7.6) +9011 FORMAT ( ' TEST WMUPD2 : NO DATA FOR ',I1,' TO SHIFT') +9020 FORMAT ( ' TEST WMUPD2 : PROCESSING ',I1,' TIME = ',I8.8,I7.6) +9030 FORMAT ( ' TEST WMUPD2 : INITIAL FIELD FOR ',I1, & + ' TIME = ',I8.8,I7.6) +#endif + !/ + !/ End of WMUPD2 ----------------------------------------------------- / + !/ + END SUBROUTINE WMUPD2 + !/ ------------------------------------------------------------------- / + !> + !> @brief Interpolate vector field from input grid to model grid. + !> + !> @details Interpolating or averaging from input grid. + !> + !> @param[in] IMOD Output model number + !> @param[out] VX Output vector field + !> @param[out] VY Output vector field + !> @param[in] JMOD Input model number + !> @param[in] VXI Input vector field + !> @param[in] VYI Input vector field + !> @param[in] UNDEF Value for mapped out point and points not covered. + !> @param[in] CONSTP Convervation type + !> + !> @author H. L. Tolman @date 06-Dec-2010 + !> + SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Dec-2010 | + !/ +-----------------------------------+ + !/ + !/ 14-Oct-2006 : Origination. ( version 3.10 ) + !/ 12-Jan-2007 : General clean-up and bug fixes. ( version 3.10 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 01-Jul-2019 : Generalize output to curv grids ( version 7.13 ) + !/ (R. Padilla-Hernandez, J.H. Alves, EMC/NOAA) + !/ + ! 1. Purpose : + ! + ! Interpolate vector field from input grid to model grid. + ! + ! 2. Method : + ! + ! Interpolating or averaging from input grid. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Output model number, + ! VX/Y Int. O Output vector field. + ! JMOD Int. I Input model number, + ! VX/YI Int. I Input vector field. + ! UNDEF Int. I Value for mapped out point and points not + ! covered. + ! CONSTP Int. I Conservation type : + ! 1: Vector speed. + ! 2: Vector speed squared. + ! *: Vector components. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3ERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMUPD2 Subr. WMUPDTMD Input update routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Grid pointers for output grid need to be set externally. + ! - If input grid does not cover point of target grid, target grid + ! values are set to UNDEF. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/T1 Test output interpolation data. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - USE W3GDATMD, ONLY: NX, NY, X0, Y0, SX, SY, GRIDS, FLAGLL, & - GTYPE, RLGTYPE, CLGTYPE, UNGTYPE, & - ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & - HPFAC, HQFAC, XGRD, YGRD - USE WMMDATMD, ONLY: IMPROC, NMPERR, NMPSCR, MDST, MDSE, MDSO, & - MDSS -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, JMOD, CONSTP - REAL, INTENT(OUT) :: VX(NX,NY), VY(NX,NY) - REAL, INTENT(IN) :: VXI(GRIDS(JMOD)%NX,GRIDS(JMOD)%NY), & - VYI(GRIDS(JMOD)%NX,GRIDS(JMOD)%NY), & - UNDEF -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IXO, IYO, IX, IY, IXF0, IXFN, IYF0, & - IYFN, IXS0, IXSN, IYS0, IYSN, IXS, & - MXA, MYA, J, J1, J2, IXC, IYC, JJ, & - JX, JY - INTEGER :: NPOIX, NPOIY, I, IFIELDS,CURVI !RP + USE W3SERVMD, ONLY: STRACE +#endif + !/ + USE W3GDATMD, ONLY: NX, NY, X0, Y0, SX, SY, GRIDS, FLAGLL, & + GTYPE, RLGTYPE, CLGTYPE, UNGTYPE, & + ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & + HPFAC, HQFAC, XGRD, YGRD + USE WMMDATMD, ONLY: IMPROC, NMPERR, NMPSCR, MDST, MDSE, MDSO, & + MDSS + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, JMOD, CONSTP + REAL, INTENT(OUT) :: VX(NX,NY), VY(NX,NY) + REAL, INTENT(IN) :: VXI(GRIDS(JMOD)%NX,GRIDS(JMOD)%NY), & + VYI(GRIDS(JMOD)%NX,GRIDS(JMOD)%NY), & + UNDEF + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IXO, IYO, IX, IY, IXF0, IXFN, IYF0, & + IYFN, IXS0, IXSN, IYS0, IYSN, IXS, & + MXA, MYA, J, J1, J2, IXC, IYC, JJ, & + JX, JY + INTEGER :: NPOIX, NPOIY, I, IFIELDS,CURVI !RP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, ALLOCATABLE :: NXA(:,:), NYA(:,:) - REAL :: XR, YR, R1, R2, RT, XFL, XFR, XSL, & - XSR, YFL, YFR, YSL, YSR - REAL :: VXL, VYL, VA0, VA, VA2, FACTOR, & - WTOT, WL + INTEGER, ALLOCATABLE :: NXA(:,:), NYA(:,:) + REAL :: XR, YR, R1, R2, RT, XFL, XFR, XSL, & + XSR, YFL, YFR, YSL, YSR + REAL :: VXL, VYL, VA0, VA, VA2, FACTOR, & + WTOT, WL - REAL :: LONC, LATC, SXYC, & - XDI, DTOLER, VALUEX, VALUEY + REAL :: LONC, LATC, SXYC, & + XDI, DTOLER, VALUEX, VALUEY - REAL, ALLOCATABLE :: RXA(:,:), RYA(:,:) + REAL, ALLOCATABLE :: RXA(:,:), RYA(:,:) -! REAL, ALLOCATABLE :: VARIN(:,:) !RP + ! REAL, ALLOCATABLE :: VARIN(:,:) !RP - LOGICAL :: MAP1(NX,NY), MAP2(NX,NY), & - MAP3(NX,NY), FLAGUP -! - INTEGER, POINTER :: NXI, NYI, MAP(:,:), MAPI(:,:) - REAL, POINTER :: X0I, Y0I, SXI, SYI !RP , HPFACI, HQFACI + LOGICAL :: MAP1(NX,NY), MAP2(NX,NY), & + MAP3(NX,NY), FLAGUP + ! + INTEGER, POINTER :: NXI, NYI, MAP(:,:), MAPI(:,:) + REAL, POINTER :: X0I, Y0I, SXI, SYI !RP , HPFACI, HQFACI - REAL, POINTER :: HPFACI(:,:), HQFACI(:,:) - DOUBLE PRECISION, POINTER :: XGRDI(:,:), YGRDI(:,:), XGRDC(:,:), YGRDC(:,:) + REAL, POINTER :: HPFACI(:,:), HQFACI(:,:) + DOUBLE PRECISION, POINTER :: XGRDI(:,:), YGRDI(:,:), XGRDC(:,:), YGRDC(:,:) - INTEGER, POINTER :: ICLOSE - REAL, ALLOCATABLE :: XGRTMP(:),YGRTMP(:) + INTEGER, POINTER :: ICLOSE + REAL, ALLOCATABLE :: XGRTMP(:),YGRTMP(:) #ifdef W3_T1 - CHARACTER(LEN=17) :: FORMAT1 + CHARACTER(LEN=17) :: FORMAT1 #endif -!/ -!/ ------------------------------------------------------------------- / -! 0. Initialization -! 0.a Subroutine tracing and test output -! + !/ + !/ ------------------------------------------------------------------- / + ! 0. Initialization + ! 0.a Subroutine tracing and test output + ! #ifdef W3_S - CALL STRACE (IENT, 'WMUPDV') -#endif -! - IF ( GRIDS(IMOD)%GTYPE .EQ. UNGTYPE .OR. & - GRIDS(JMOD)%GTYPE .EQ. UNGTYPE ) THEN - WRITE (MDSE,'(/2A)') ' *** ERROR WMUPDV: ', & - 'UNSTRUCTURED GRID SUPPORT NOT YET IMPLEMENTED ***' - CALL EXTCDE ( 999 ) - END IF -! - NXI => GRIDS(JMOD)%NX - NYI => GRIDS(JMOD)%NY - X0I => GRIDS(JMOD)%X0 - Y0I => GRIDS(JMOD)%Y0 - SXI => GRIDS(JMOD)%SX - SYI => GRIDS(JMOD)%SY - HPFACI => GRIDS(JMOD)%HPFAC - HQFACI => GRIDS(JMOD)%HQFAC - MAP => GRIDS(IMOD)%MAPSTA - MAPI => GRIDS(JMOD)%MAPSTA - ICLOSE => GRIDS(JMOD)%ICLOSE -! - IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN - IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,*)'SUBROUTINE WMUPDV IS'// & - ' NOT YET ADAPTED FOR TRIPOLE GRIDS. STOPPING NOW.' - CALL EXTCDE ( 1 ) - END IF + CALL STRACE (IENT, 'WMUPDV') +#endif + ! + IF ( GRIDS(IMOD)%GTYPE .EQ. UNGTYPE .OR. & + GRIDS(JMOD)%GTYPE .EQ. UNGTYPE ) THEN + WRITE (MDSE,'(/2A)') ' *** ERROR WMUPDV: ', & + 'UNSTRUCTURED GRID SUPPORT NOT YET IMPLEMENTED ***' + CALL EXTCDE ( 999 ) + END IF + ! + NXI => GRIDS(JMOD)%NX + NYI => GRIDS(JMOD)%NY + X0I => GRIDS(JMOD)%X0 + Y0I => GRIDS(JMOD)%Y0 + SXI => GRIDS(JMOD)%SX + SYI => GRIDS(JMOD)%SY + HPFACI => GRIDS(JMOD)%HPFAC + HQFACI => GRIDS(JMOD)%HQFAC + MAP => GRIDS(IMOD)%MAPSTA + MAPI => GRIDS(JMOD)%MAPSTA + ICLOSE => GRIDS(JMOD)%ICLOSE + ! + IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN + IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,*)'SUBROUTINE WMUPDV IS'// & + ' NOT YET ADAPTED FOR TRIPOLE GRIDS. STOPPING NOW.' + CALL EXTCDE ( 1 ) + END IF -! + ! #ifdef W3_T - WRITE (MDST,9000) IMOD, NX, NY, X0, Y0, SX, SY, & - JMOD, NXI, NYI, X0I, Y0I, SXI, SYI, UNDEF -#endif -! -! 0.b Initialize fields -! - VX = UNDEF - VY = UNDEF -! - CURVI=0 - IF ( GRIDS(IMOD)%GTYPE .EQ. CLGTYPE .OR. & - GRIDS(JMOD)%GTYPE .EQ. CLGTYPE ) THEN - CURVI=1 - END IF + WRITE (MDST,9000) IMOD, NX, NY, X0, Y0, SX, SY, & + JMOD, NXI, NYI, X0I, Y0I, SXI, SYI, UNDEF +#endif + ! + ! 0.b Initialize fields + ! + VX = UNDEF + VY = UNDEF + ! + CURVI=0 + IF ( GRIDS(IMOD)%GTYPE .EQ. CLGTYPE .OR. & + GRIDS(JMOD)%GTYPE .EQ. CLGTYPE ) THEN + CURVI=1 + END IF -! 1. Case of identical resolution and coinciding grids --------------- / - IF(CURVI .EQ. 0) THEN -! + ! 1. Case of identical resolution and coinciding grids --------------- / + IF(CURVI .EQ. 0) THEN + ! IF ( ABS(SX/SXI-1.) .LT. 1.E-3 .AND. & ABS(SY/SYI-1.) .LT. 1.E-3 .AND. & ABS(MOD((ABS(X0-X0I))/SX+0.5,1.)-0.5) .LT. 1.E-2 .AND. & ABS(MOD((ABS(Y0-Y0I))/SY+0.5,1.)-0.5) .LT. 1.E-2 ) THEN -! -! 1.a Offsets -! + ! + ! 1.a Offsets + ! - IXO = NINT((X0-X0I)/SX) -! - IF ( FLAGLL ) THEN - IXF0 = 1 - IXFN = NX - IXS0 = -999 - IXSN = -999 - ELSE - IXF0 = MAX ( 1 , 1-IXO ) - IXFN = MIN ( NX , NXI-IXO ) - IXS0 = MAX ( 1 , 1+IXO ) - IXSN = IXS0 + IXFN - IXF0 - END IF -! - IYO = NINT((Y0-Y0I)/SY) -! - IYF0 = MAX ( 1 , 1-IYO ) - IYFN = MIN ( NY , NYI-IYO ) - IYS0 = MAX ( 1 , 1+IYO ) - IYSN = IYS0 + IYFN - IYF0 -! + IXO = NINT((X0-X0I)/SX) + ! + IF ( FLAGLL ) THEN + IXF0 = 1 + IXFN = NX + IXS0 = -999 + IXSN = -999 + ELSE + IXF0 = MAX ( 1 , 1-IXO ) + IXFN = MIN ( NX , NXI-IXO ) + IXS0 = MAX ( 1 , 1+IXO ) + IXSN = IXS0 + IXFN - IXF0 + END IF + ! + IYO = NINT((Y0-Y0I)/SY) + ! + IYF0 = MAX ( 1 , 1-IYO ) + IYFN = MIN ( NY , NYI-IYO ) + IYS0 = MAX ( 1 , 1+IYO ) + IYSN = IYS0 + IYFN - IYF0 + ! #ifdef W3_T - WRITE (MDST,9010) IXO, IYO, IXF0, IXFN, IYF0, IYFN, & - IXS0, IXSN, IYS0, IYSN + WRITE (MDST,9010) IXO, IYO, IXF0, IXFN, IYF0, IYFN, & + IXS0, IXSN, IYS0, IYSN #endif -! -! 1.b Fill arrays for sea points only -! + ! + ! 1.b Fill arrays for sea points only + ! - DO IX=IXF0, IXFN - IF ( FLAGLL ) THEN - IXS = 1 + NINT ( MOD ( & - 1080.+X0+(REAL(IX)-0.5)*SX-X0I , 360. ) / SX - 0.5 ) - IF ( IXS .GT. NXI ) CYCLE - ELSE - IXS = IX + IXO - END IF - VX(IX,IYF0:IYFN) = VXI(IXS,IYS0:IYSN) - VY(IX,IYF0:IYFN) = VYI(IXS,IYS0:IYSN) - END DO -! -! 1.c Return to calling routine -! - RETURN -! - END IF - END IF !CURVI -! -! 2. General case --------------------------------------------------- / -! -! 2.a Curvilinear grids -! - IF ( GRIDS(IMOD)%GTYPE .EQ. CLGTYPE .OR. & - GRIDS(JMOD)%GTYPE .EQ. CLGTYPE ) THEN + DO IX=IXF0, IXFN + IF ( FLAGLL ) THEN + IXS = 1 + NINT ( MOD ( & + 1080.+X0+(REAL(IX)-0.5)*SX-X0I , 360. ) / SX - 0.5 ) + IF ( IXS .GT. NXI ) CYCLE + ELSE + IXS = IX + IXO + END IF + VX(IX,IYF0:IYFN) = VXI(IXS,IYS0:IYSN) + VY(IX,IYF0:IYFN) = VYI(IXS,IYS0:IYSN) + END DO + ! + ! 1.c Return to calling routine + ! + RETURN + ! + END IF + END IF !CURVI + ! + ! 2. General case --------------------------------------------------- / + ! + ! 2.a Curvilinear grids + ! + IF ( GRIDS(IMOD)%GTYPE .EQ. CLGTYPE .OR. & + GRIDS(JMOD)%GTYPE .EQ. CLGTYPE ) THEN - XGRDI => GRIDS(JMOD)%XGRD !LONS FOR INPUT FIELD - YGRDI => GRIDS(JMOD)%YGRD !LATS FOR INPUT FIELD + XGRDI => GRIDS(JMOD)%XGRD !LONS FOR INPUT FIELD + YGRDI => GRIDS(JMOD)%YGRD !LATS FOR INPUT FIELD -! GETTING THE INFO FOR THE CURVILINEAR GRID - XGRDC => GRIDS(IMOD)%XGRD !LONS FOR CURVI GRID - YGRDC => GRIDS(IMOD)%YGRD !LATS FOR CURVI GRID - !HPFAC => GRIDS(IMOD)%HPFAC !DELTAS IN LON FOR CURVI GRID - !HQFAC => GRIDS(IMOD)%HQFAC !DELTAS IN LAT FOR CURVI GRID -! -! -! FOR NOW ONLY INTERPOLATION NOT AVERAGING THEN MXA=2 - MXA=2 - MYA=2 - ALLOCATE ( NXA(NX,0:MXA) , RXA(NX,MXA) ) - NXA = 0 - RXA = 0. - ALLOCATE ( NYA(NY,0:MYA) , RYA(NY,MYA) ) - NYA = 0 - RYA = 0. + ! GETTING THE INFO FOR THE CURVILINEAR GRID + XGRDC => GRIDS(IMOD)%XGRD !LONS FOR CURVI GRID + YGRDC => GRIDS(IMOD)%YGRD !LATS FOR CURVI GRID + !HPFAC => GRIDS(IMOD)%HPFAC !DELTAS IN LON FOR CURVI GRID + !HQFAC => GRIDS(IMOD)%HQFAC !DELTAS IN LAT FOR CURVI GRID + ! + ! + ! FOR NOW ONLY INTERPOLATION NOT AVERAGING THEN MXA=2 + MXA=2 + MYA=2 + ALLOCATE ( NXA(NX,0:MXA) , RXA(NX,MXA) ) + NXA = 0 + RXA = 0. + ALLOCATE ( NYA(NY,0:MYA) , RYA(NY,MYA) ) + NYA = 0 + RYA = 0. -!IS THE TOLERANCE USED TO DETERMINE IF TWO VALUES ARE EQUAL IN LOCATION - DTOLER = 1E-5 -! 2.a.1 running over the curvilinear grid - ALLOCATE (XGRTMP(NXI),YGRTMP(NYI)) - XGRTMP=REAL(XGRDI(1,:)) - YGRTMP=REAL(YGRDI(:,1)) + !IS THE TOLERANCE USED TO DETERMINE IF TWO VALUES ARE EQUAL IN LOCATION + DTOLER = 1E-5 + ! 2.a.1 running over the curvilinear grid + ALLOCATE (XGRTMP(NXI),YGRTMP(NYI)) + XGRTMP=REAL(XGRDI(1,:)) + YGRTMP=REAL(YGRDI(:,1)) #ifdef W3_OMPH -!$OMP PARALLEL DO PRIVATE(J,I,LONC,LATC,VALUEX,VALUEY) + !$OMP PARALLEL DO PRIVATE(J,I,LONC,LATC,VALUEX,VALUEY) #endif - DO J=1,NY - DO I=1,NX - LONC=REAL(XGRDC(J,I)) !LON FOR EVERY CURVL GRID POINT - LATC=REAL(YGRDC(J,I)) !LAT FOR EVERY CURVL GRID POINT + DO J=1,NY + DO I=1,NX + LONC=REAL(XGRDC(J,I)) !LON FOR EVERY CURVL GRID POINT + LATC=REAL(YGRDC(J,I)) !LAT FOR EVERY CURVL GRID POINT - CALL INTERPOLATE2D(NXI,REAL(XGRTMP),NYI,REAL(YGRTMP), & - VXI,VYI,LONC,LATC,DTOLER,VALUEX,VALUEY) - VX(I,J)=VALUEX - VY(I,J)=VALUEY + CALL INTERPOLATE2D(NXI,REAL(XGRTMP),NYI,REAL(YGRTMP), & + VXI,VYI,LONC,LATC,DTOLER,VALUEX,VALUEY) + VX(I,J)=VALUEX + VY(I,J)=VALUEY - END DO !END I - END DO !END J + END DO !END I + END DO !END J #ifdef W3_OMPH -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO #endif - DEALLOCATE (XGRTMP, YGRTMP) + DEALLOCATE (XGRTMP, YGRTMP) + ELSE + ! + ! 2.b Rectilinear grids + ! + ! 2.b.1 Interpolation / averaging data for X axis + ! + IF ( SX/SXI .LT. 1.0001 ) THEN + MXA = 2 ELSE -! -! 2.b Rectilinear grids -! -! 2.b.1 Interpolation / averaging data for X axis -! - IF ( SX/SXI .LT. 1.0001 ) THEN - MXA = 2 - ELSE - MXA = 2 + INT(SX/SXI) - END IF -! + MXA = 2 + INT(SX/SXI) + END IF + ! #ifdef W3_T WRITE (MDST,9020) 'X' #endif @@ -1625,87 +1625,39 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MXA+1,'I5,',MXA+1,"F6.2)'" WRITE (MDST,9021) NX, MXA #endif -! - ALLOCATE ( NXA(NX,0:MXA) , RXA(NX,MXA) ) - NXA = 0 - RXA = 0. -! - IF ( MXA .EQ. 2 ) THEN -! - DO IX=1, NX - IF ( FLAGLL ) THEN - XR = 1. + MOD & - ( 1080.+X0+REAL(IX-1)*SX-X0I , 360. ) / SXI - ELSE - XR = 1. + ( X0+REAL(IX-1)*SX - X0I ) / SXI + ! + ALLOCATE ( NXA(NX,0:MXA) , RXA(NX,MXA) ) + NXA = 0 + RXA = 0. + ! + IF ( MXA .EQ. 2 ) THEN + ! + DO IX=1, NX + IF ( FLAGLL ) THEN + XR = 1. + MOD & + ( 1080.+X0+REAL(IX-1)*SX-X0I , 360. ) / SXI + ELSE + XR = 1. + ( X0+REAL(IX-1)*SX - X0I ) / SXI + END IF + IF ( XR.GT.0. ) THEN + J1 = INT(XR) + J2 = J1 + 1 + R2 = MAX ( 0. , XR-REAL(J1) ) + R1 = 1. - R2 + IF ( FLAGLL .AND. ICLOSE.NE.ICLOSE_NONE ) THEN + J1 = 1 + MOD(J1-1,NXI) + J2 = 1 + MOD(J2-1,NXI) END IF - IF ( XR.GT.0. ) THEN - J1 = INT(XR) - J2 = J1 + 1 - R2 = MAX ( 0. , XR-REAL(J1) ) - R1 = 1. - R2 - IF ( FLAGLL .AND. ICLOSE.NE.ICLOSE_NONE ) THEN - J1 = 1 + MOD(J1-1,NXI) - J2 = 1 + MOD(J2-1,NXI) - END IF - IF ( J1.GE.1 .AND. J1.LE.NXI .AND. R1.GT.0.05 ) THEN - NXA(IX,0) = NXA(IX,0) + 1 - NXA(IX,NXA(IX,0)) = J1 - RXA(IX,NXA(IX,0)) = R1 - END IF - IF ( J2.GE.1 .AND. J2.LE.NXI .AND. R2.GT.0.05 ) THEN - NXA(IX,0) = NXA(IX,0) + 1 - NXA(IX,NXA(IX,0)) = J2 - RXA(IX,NXA(IX,0)) = R2 - END IF - IF ( NXA(IX,0) .GT. 0 ) THEN - RT = SUM ( RXA(IX,:) ) - IF ( RT .LT. 0.7 ) THEN - NXA(IX,:) = 0 - RXA(IX,:) = 0. - END IF - END IF + IF ( J1.GE.1 .AND. J1.LE.NXI .AND. R1.GT.0.05 ) THEN + NXA(IX,0) = NXA(IX,0) + 1 + NXA(IX,NXA(IX,0)) = J1 + RXA(IX,NXA(IX,0)) = R1 END IF - END DO -! - ELSE -! - DO IX=1, NX -! - XFL = X0 + REAL(IX-1)*SX - 0.5*SX - XFR = X0 + REAL(IX-1)*SX + 0.5*SX - IF ( FLAGLL ) THEN - IXC = 1 + NINT ( MOD ( & - 1080.+X0+REAL(IX-1)*SX-X0I , 360. ) / SXI ) - IXS0 = IXC - 1 - MXA/2 - IXSN = IXC + 1 + MXA/2 - ELSE - IXC = NINT ( 1. + ( X0+REAL(IX-1)*SX - X0I ) / SXI ) - IXS0 = MAX ( 1 , IXC - 1 - MXA/2 ) - IXSN = MIN ( NXI , IXC + 1 + MXA/2 ) + IF ( J2.GE.1 .AND. J2.LE.NXI .AND. R2.GT.0.05 ) THEN + NXA(IX,0) = NXA(IX,0) + 1 + NXA(IX,NXA(IX,0)) = J2 + RXA(IX,NXA(IX,0)) = R2 END IF - DO J=IXS0, IXSN - JJ=J - IF ( FLAGLL ) THEN - IF ( ICLOSE.NE.ICLOSE_NONE ) JJ = 1 + MOD(J-1+NXI,NXI) - IF ( JJ.LT.1 .OR. JJ.GT. NXI ) CYCLE - IXC = NINT((0.5*(XFL+XFR)-X0I-REAL(JJ-1)*SXI)/360.) - IF ( IXC .NE. 0 ) THEN - XFL = XFL - REAL(IXC) * 360. - XFR = XFR - REAL(IXC) * 360. - END IF - ELSE - JJ = J - END IF - XSL = MAX ( XFL , X0I + REAL(JJ-1)*SXI - 0.5*SXI ) - XSR = MIN ( XFR , X0I + REAL(JJ-1)*SXI + 0.5*SXI ) - R1 = MAX ( 0. , XSR - XSL ) / SX - IF ( R1 .GT. 0 ) THEN - NXA(IX,0) = NXA(IX,0) + 1 - NXA(IX,NXA(IX,0)) = JJ - RXA(IX,NXA(IX,0)) = R1 - END IF - END DO IF ( NXA(IX,0) .GT. 0 ) THEN RT = SUM ( RXA(IX,:) ) IF ( RT .LT. 0.7 ) THEN @@ -1713,25 +1665,73 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) RXA(IX,:) = 0. END IF END IF + END IF + END DO + ! + ELSE + ! + DO IX=1, NX + ! + XFL = X0 + REAL(IX-1)*SX - 0.5*SX + XFR = X0 + REAL(IX-1)*SX + 0.5*SX + IF ( FLAGLL ) THEN + IXC = 1 + NINT ( MOD ( & + 1080.+X0+REAL(IX-1)*SX-X0I , 360. ) / SXI ) + IXS0 = IXC - 1 - MXA/2 + IXSN = IXC + 1 + MXA/2 + ELSE + IXC = NINT ( 1. + ( X0+REAL(IX-1)*SX - X0I ) / SXI ) + IXS0 = MAX ( 1 , IXC - 1 - MXA/2 ) + IXSN = MIN ( NXI , IXC + 1 + MXA/2 ) + END IF + DO J=IXS0, IXSN + JJ=J + IF ( FLAGLL ) THEN + IF ( ICLOSE.NE.ICLOSE_NONE ) JJ = 1 + MOD(J-1+NXI,NXI) + IF ( JJ.LT.1 .OR. JJ.GT. NXI ) CYCLE + IXC = NINT((0.5*(XFL+XFR)-X0I-REAL(JJ-1)*SXI)/360.) + IF ( IXC .NE. 0 ) THEN + XFL = XFL - REAL(IXC) * 360. + XFR = XFR - REAL(IXC) * 360. + END IF + ELSE + JJ = J + END IF + XSL = MAX ( XFL , X0I + REAL(JJ-1)*SXI - 0.5*SXI ) + XSR = MIN ( XFR , X0I + REAL(JJ-1)*SXI + 0.5*SXI ) + R1 = MAX ( 0. , XSR - XSL ) / SX + IF ( R1 .GT. 0 ) THEN + NXA(IX,0) = NXA(IX,0) + 1 + NXA(IX,NXA(IX,0)) = JJ + RXA(IX,NXA(IX,0)) = R1 + END IF END DO -! - END IF -! + IF ( NXA(IX,0) .GT. 0 ) THEN + RT = SUM ( RXA(IX,:) ) + IF ( RT .LT. 0.7 ) THEN + NXA(IX,:) = 0 + RXA(IX,:) = 0. + END IF + END IF + END DO + ! + END IF + ! #ifdef W3_T1 DO, IX=1, NX IF ( NXA(IX,0) .GT. 0 ) WRITE (MDST,FORMAT1) & - IX, NXA(IX,1:MXA), RXA(IX,1:MXA), SUM(RXA(IX,1:MXA)) - END DO + IX, NXA(IX,1:MXA), RXA(IX,1:MXA), SUM(RXA(IX,1:MXA)) + END DO #endif -! -! 2.b.2 Interpolation / averaging data for Y axis -! - IF ( SY/SYI .LT. 1.0001 ) THEN - MYA = 2 - ELSE - MYA = 2 + INT(SY/SYI) - END IF -! + ! + ! 2.b.2 Interpolation / averaging data for Y axis + ! + IF ( SY/SYI .LT. 1.0001 ) THEN + MYA = 2 + ELSE + MYA = 2 + INT(SY/SYI) + END IF + ! #ifdef W3_T WRITE (MDST,9020) 'Y' #endif @@ -1740,58 +1740,30 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MYA+1,'I5,',MYA+1,"F6.2)'" WRITE (MDST,9021) NY, MYA #endif -! - ALLOCATE ( NYA(NY,0:MYA) , RYA(NY,MYA) ) - NYA = 0 - RYA = 0. -! - IF ( MYA .EQ. 2 ) THEN -! - DO IY=1, NY - YR = 1. + ( Y0+REAL(IY-1)*SY - Y0I ) / SYI - IF ( YR.GT.0. ) THEN - J1 = INT(YR) - J2 = J1 + 1 - R2 = MAX ( 0. , YR-REAL(J1) ) - R1 = 1. - R2 - IF ( J1.GE.1 .AND. J1.LE.NYI .AND. R1.GT.0.05 ) THEN - NYA(IY,0) = NYA(IY,0) + 1 - NYA(IY,NYA(IY,0)) = J1 - RYA(IY,NYA(IY,0)) = R1 - END IF - IF ( J2.GE.1 .AND. J2.LE.NYI .AND. R2.GT.0.05 ) THEN - NYA(IY,0) = NYA(IY,0) + 1 - NYA(IY,NYA(IY,0)) = J2 - RYA(IY,NYA(IY,0)) = R2 - END IF - IF ( NYA(IY,0) .GT. 0 ) THEN - RT = SUM ( RYA(IY,:) ) - IF ( RT .LT. 0.7 ) THEN - NYA(IY,:) = 0 - RYA(IY,:) = 0. - END IF - END IF + ! + ALLOCATE ( NYA(NY,0:MYA) , RYA(NY,MYA) ) + NYA = 0 + RYA = 0. + ! + IF ( MYA .EQ. 2 ) THEN + ! + DO IY=1, NY + YR = 1. + ( Y0+REAL(IY-1)*SY - Y0I ) / SYI + IF ( YR.GT.0. ) THEN + J1 = INT(YR) + J2 = J1 + 1 + R2 = MAX ( 0. , YR-REAL(J1) ) + R1 = 1. - R2 + IF ( J1.GE.1 .AND. J1.LE.NYI .AND. R1.GT.0.05 ) THEN + NYA(IY,0) = NYA(IY,0) + 1 + NYA(IY,NYA(IY,0)) = J1 + RYA(IY,NYA(IY,0)) = R1 + END IF + IF ( J2.GE.1 .AND. J2.LE.NYI .AND. R2.GT.0.05 ) THEN + NYA(IY,0) = NYA(IY,0) + 1 + NYA(IY,NYA(IY,0)) = J2 + RYA(IY,NYA(IY,0)) = R2 END IF - END DO -! - ELSE -! - DO IY=1, NY - YFL = Y0 + REAL(IY-1)*SY - 0.5*SY - YFR = Y0 + REAL(IY-1)*SY + 0.5*SY - IYC = NINT ( 1. + ( Y0+REAL(IY-1)*SY - Y0I ) / SYI ) - IYS0 = MAX ( 1 , IYC - 1 - MYA/2 ) - IYSN = MIN ( NYI , IYC + 1 + MYA/2 ) - DO J=IYS0, IYSN - YSL = MAX ( YFL , Y0I + REAL(J-1)*SYI - 0.5*SYI ) - YSR = MIN ( YFR , Y0I + REAL(J-1)*SYI + 0.5*SYI ) - R1 = MAX ( 0. , YSR - YSL ) / SY - IF ( R1 .GT. 0 ) THEN - NYA(IY,0) = NYA(IY,0) + 1 - NYA(IY,NYA(IY,0)) = J - RYA(IY,NYA(IY,0)) = R1 - END IF - END DO IF ( NYA(IY,0) .GT. 0 ) THEN RT = SUM ( RYA(IY,:) ) IF ( RT .LT. 0.7 ) THEN @@ -1799,379 +1771,407 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) RYA(IY,:) = 0. END IF END IF + END IF + END DO + ! + ELSE + ! + DO IY=1, NY + YFL = Y0 + REAL(IY-1)*SY - 0.5*SY + YFR = Y0 + REAL(IY-1)*SY + 0.5*SY + IYC = NINT ( 1. + ( Y0+REAL(IY-1)*SY - Y0I ) / SYI ) + IYS0 = MAX ( 1 , IYC - 1 - MYA/2 ) + IYSN = MIN ( NYI , IYC + 1 + MYA/2 ) + DO J=IYS0, IYSN + YSL = MAX ( YFL , Y0I + REAL(J-1)*SYI - 0.5*SYI ) + YSR = MIN ( YFR , Y0I + REAL(J-1)*SYI + 0.5*SYI ) + R1 = MAX ( 0. , YSR - YSL ) / SY + IF ( R1 .GT. 0 ) THEN + NYA(IY,0) = NYA(IY,0) + 1 + NYA(IY,NYA(IY,0)) = J + RYA(IY,NYA(IY,0)) = R1 + END IF END DO -! - END IF -! + IF ( NYA(IY,0) .GT. 0 ) THEN + RT = SUM ( RYA(IY,:) ) + IF ( RT .LT. 0.7 ) THEN + NYA(IY,:) = 0 + RYA(IY,:) = 0. + END IF + END IF + END DO + ! END IF + ! + END IF -! + ! #ifdef W3_T1 - DO, IY=1, NY - IF ( NYA(IY,0) .GT. 0 ) WRITE (MDST,FORMAT1) & - IY, NYA(IY,1:MYA), RYA(IY,1:MYA), SUM(RYA(IY,1:MYA)) - END DO -#endif -! -! 2.c Process grid -! - MAP1 = .FALSE. - MAP2 = .FALSE. - FACTOR = 1. -! + DO, IY=1, NY + IF ( NYA(IY,0) .GT. 0 ) WRITE (MDST,FORMAT1) & + IY, NYA(IY,1:MYA), RYA(IY,1:MYA), SUM(RYA(IY,1:MYA)) + END DO +#endif + ! + ! 2.c Process grid + ! + MAP1 = .FALSE. + MAP2 = .FALSE. + FACTOR = 1. + ! + + DO IX=1, NX + IF ( NXA(IX,0) .EQ. 0 ) CYCLE + DO IY=1, NY + IF ( NYA(IY,0) .EQ. 0 ) CYCLE + IF ( MAP(IY,IX).NE.0 ) THEN + VXL = 0. + VYL = 0. + VA = 0. + VA2 = 0. + WTOT = 0. + DO J1=1, NXA(IX,0) + JX = NXA(IX,J1) + DO J2=1, NYA(IY,0) + JY = NYA(IY,J2) + IF ( MAPI(JY,JX) .NE. 0 ) THEN + WL = RXA(IX,J1) * RYA(IY,J2) + WTOT = WTOT + WL + VXL = VXL + WL * VXI(JX,JY) + VYL = VYL + WL * VYI(JX,JY) + VA = VA + WL * SQRT & + ( VXI(JX,JY)**2 + VYI(JX,JY)**2 ) + VA2 = VA2 + WL * & + ( VXI(JX,JY)**2 + VYI(JX,JY)**2 ) + END IF + END DO + END DO + IF ( WTOT .LT. 0.05 ) THEN + MAP1(IX,IY) = .TRUE. + ELSE + MAP2(IX,IY) = .TRUE. + VXL = VXL / WTOT + VYL = VYL / WTOT + VA = VA / WTOT + VA2 = SQRT ( VA2 / WTOT ) + VA0 = SQRT ( VXL**2 + VYL**2 ) + IF ( CONSTP .EQ. 1 ) THEN + FACTOR = MIN ( 1.25 , VA/MAX(1.E-7,VA0) ) + ELSE IF ( CONSTP .EQ. 2 ) THEN + FACTOR = MIN ( 1.25 , VA2/MAX(1.E-7,VA0) ) + END IF + VX(IX,IY) = FACTOR * VXL + VY(IX,IY) = FACTOR * VYL + END IF + END IF + END DO + END DO + ! + ! 2.d Reconcile mask differences + ! +#ifdef W3_T + WRITE (MDST,9022) +#endif + ! + JJ = 0 + ICLOSE => GRIDS(IMOD)%ICLOSE + ! + DO + IF ( JJ .GT. SWPMAX ) EXIT + FLAGUP = .FALSE. + MAP3 = .FALSE. + JJ = JJ + 1 +#ifdef W3_T + WRITE (MDST,9023) JJ +#endif DO IX=1, NX - IF ( NXA(IX,0) .EQ. 0 ) CYCLE DO IY=1, NY - IF ( NYA(IY,0) .EQ. 0 ) CYCLE - IF ( MAP(IY,IX).NE.0 ) THEN - VXL = 0. - VYL = 0. - VA = 0. - VA2 = 0. - WTOT = 0. - DO J1=1, NXA(IX,0) - JX = NXA(IX,J1) - DO J2=1, NYA(IY,0) - JY = NYA(IY,J2) - IF ( MAPI(JY,JX) .NE. 0 ) THEN - WL = RXA(IX,J1) * RYA(IY,J2) - WTOT = WTOT + WL - VXL = VXL + WL * VXI(JX,JY) - VYL = VYL + WL * VYI(JX,JY) - VA = VA + WL * SQRT & - ( VXI(JX,JY)**2 + VYI(JX,JY)**2 ) - VA2 = VA2 + WL * & - ( VXI(JX,JY)**2 + VYI(JX,JY)**2 ) + IF ( MAP1(IX,IY) ) THEN + VXL = 0. + VYL = 0. + J1 = 0 + IF ( FLAGLL ) THEN + DO J2=IX-1, IX+1 + IF ( (J2.GT.1 .AND. J2.LE.NX) .OR. ICLOSE.NE.ICLOSE_NONE ) THEN + JX = 1 + MOD(NX+J2-1,NX) + DO JY=IY-1, IY+1 + IF ( JY.GT.1 .AND. JY.LE.NY ) THEN + IF ( MAP2(JX,JY) ) THEN + VXL = VXL + VX(JX,JY) + VYL = VYL + VY(JX,JY) + J1 = J1 + 1 + END IF END IF END DO - END DO - IF ( WTOT .LT. 0.05 ) THEN - MAP1(IX,IY) = .TRUE. - ELSE - MAP2(IX,IY) = .TRUE. - VXL = VXL / WTOT - VYL = VYL / WTOT - VA = VA / WTOT - VA2 = SQRT ( VA2 / WTOT ) - VA0 = SQRT ( VXL**2 + VYL**2 ) - IF ( CONSTP .EQ. 1 ) THEN - FACTOR = MIN ( 1.25 , VA/MAX(1.E-7,VA0) ) - ELSE IF ( CONSTP .EQ. 2 ) THEN - FACTOR = MIN ( 1.25 , VA2/MAX(1.E-7,VA0) ) + END IF + END DO + ELSE + DO JX=IX-1, IX+1 + IF ( JX.GT.1 .AND. JX.LE.NX ) THEN + DO JY=IY-1, IY+1 + IF ( JY.GT.1 .AND. JY.LE.NY ) THEN + IF ( MAP2(JX,JY) ) THEN + VXL = VXL + VX(JX,JY) + VYL = VYL + VY(JX,JY) + J1 = J1 + 1 + END IF END IF - VX(IX,IY) = FACTOR * VXL - VY(IX,IY) = FACTOR * VYL + END DO END IF + END DO + END IF !FLAGLL + IF ( J1 .GT. 0 ) THEN + VX(IX,IY) = VXL / REAL(J1) + VY(IX,IY) = VYL / REAL(J1) + MAP1(IX,IY) = .FALSE. + MAP3(IX,IY) = .TRUE. + FLAGUP = .TRUE. END IF - END DO - END DO - -! -! 2.d Reconcile mask differences -! -#ifdef W3_T - WRITE (MDST,9022) -#endif -! - JJ = 0 - ICLOSE => GRIDS(IMOD)%ICLOSE -! - DO - IF ( JJ .GT. SWPMAX ) EXIT - FLAGUP = .FALSE. - MAP3 = .FALSE. - JJ = JJ + 1 -#ifdef W3_T - WRITE (MDST,9023) JJ -#endif - DO IX=1, NX - DO IY=1, NY - IF ( MAP1(IX,IY) ) THEN - VXL = 0. - VYL = 0. - J1 = 0 - IF ( FLAGLL ) THEN - DO J2=IX-1, IX+1 - IF ( (J2.GT.1 .AND. J2.LE.NX) .OR. ICLOSE.NE.ICLOSE_NONE ) THEN - JX = 1 + MOD(NX+J2-1,NX) - DO JY=IY-1, IY+1 - IF ( JY.GT.1 .AND. JY.LE.NY ) THEN - IF ( MAP2(JX,JY) ) THEN - VXL = VXL + VX(JX,JY) - VYL = VYL + VY(JX,JY) - J1 = J1 + 1 - END IF - END IF - END DO - END IF - END DO - ELSE - DO JX=IX-1, IX+1 - IF ( JX.GT.1 .AND. JX.LE.NX ) THEN - DO JY=IY-1, IY+1 - IF ( JY.GT.1 .AND. JY.LE.NY ) THEN - IF ( MAP2(JX,JY) ) THEN - VXL = VXL + VX(JX,JY) - VYL = VYL + VY(JX,JY) - J1 = J1 + 1 - END IF - END IF - END DO - END IF - END DO - END IF !FLAGLL - IF ( J1 .GT. 0 ) THEN - VX(IX,IY) = VXL / REAL(J1) - VY(IX,IY) = VYL / REAL(J1) - MAP1(IX,IY) = .FALSE. - MAP3(IX,IY) = .TRUE. - FLAGUP = .TRUE. - END IF - END IF - END DO - END DO - IF ( FLAGUP ) THEN - MAP2 = MAP2 .OR. MAP3 - ELSE - EXIT END IF END DO + END DO + IF ( FLAGUP ) THEN + MAP2 = MAP2 .OR. MAP3 + ELSE + EXIT + END IF + END DO -! -! 3. End of routine -------------------------------------------------- / -! - DEALLOCATE ( NXA, NYA, RXA, RYA ) -! - RETURN -! -! Formats -! + ! + ! 3. End of routine -------------------------------------------------- / + ! + DEALLOCATE ( NXA, NYA, RXA, RYA ) + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMUPDV : GRID INFORMATION : '/ & - ' ',3I5,4E11.3/ & - ' ',3I5,4E11.3/ & - ' UNDEFINED = ',E10.3) - 9010 FORMAT ( ' TEST WMUPDV : COINCIDING GRIDS, OFFSETS :',2I6/ & - ' TARGET GRID RANGES :',4I6/ & - ' SOURCE GRID RANGES :',4I6) - 9020 FORMAT ( ' TEST WMUPDV : WEIGHTS FOR ',A,' INTERPOATION') +9000 FORMAT ( ' TEST WMUPDV : GRID INFORMATION : '/ & + ' ',3I5,4E11.3/ & + ' ',3I5,4E11.3/ & + ' UNDEFINED = ',E10.3) +9010 FORMAT ( ' TEST WMUPDV : COINCIDING GRIDS, OFFSETS :',2I6/ & + ' TARGET GRID RANGES :',4I6/ & + ' SOURCE GRID RANGES :',4I6) +9020 FORMAT ( ' TEST WMUPDV : WEIGHTS FOR ',A,' INTERPOATION') #endif #ifdef W3_T1 - 9021 FORMAT ( ' TEST WMUPDV : ARAY DIMENSIONED AS : ',2I6) +9021 FORMAT ( ' TEST WMUPDV : ARAY DIMENSIONED AS : ',2I6) #endif #ifdef W3_T - 9022 FORMAT ( ' TEST WMUPDV : RECONCILING MASKS') - 9023 FORMAT ( ' SWEEP NR ',I4) -#endif -!/ -!/ End of WMUPDV ----------------------------------------------------- / -!/ - END SUBROUTINE WMUPDV -!/ ------------------------------------------------------------------- / -!> -!> @brief Interpolate scalar field from input grid to model grid. -!> -!> @details Interpolating or averaging from input grid. -!> -!> @param[in] IMOD Output model number -!> @param[out] FD Output scalar field -!> @param[in] JMOD Input model number -!> @param[in] FDI Input scalar field -!> @param[in] UNDEF Value for mapped out point and points not covered. -!> -!> @author H. L. Tolman @date 06-Dec-2010 -!> - SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Dec-2010 | -!/ +-----------------------------------+ -!/ -!/ 14-Oct-2006 : Origination. ( version 3.10 ) -!/ 12-Jan-2007 : General clean-up and bug fixes. ( version 3.10 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 11-May-2015 : Updates to 2-ways nestings for UG ( version 5.08 ) -!/ 01-Jul-2019 : Generalize output to curv grids ( version 7.13 ) -!/ (R. Padilla-Hernandez, J.H. Alves, EMC/NOAA) -!/ -! 1. Purpose : -! -! Interpolate scalar field from input grid to model grid. -! -! 2. Method : -! -! Interpolating or averaging from input grid. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Output model number, -! FD Int. O Output scaler field. -! JMOD Int. I Input model number, -! FDI Int. I Input scaler field. -! UNDEF Int. I Value for mapped out point and points not -! covered. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3ERVMD Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMUPD2 Subr. WMUPDTMD Input update routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Grid pointers for output grid need to be set externally. -! - If input grid does not cover point of target grid, target grid -! values are set to UNDEF. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! !/T1 Test output interpolation data. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - USE W3SERVMD, ONLY: EXTCDE +9022 FORMAT ( ' TEST WMUPDV : RECONCILING MASKS') +9023 FORMAT ( ' SWEEP NR ',I4) +#endif + !/ + !/ End of WMUPDV ----------------------------------------------------- / + !/ + END SUBROUTINE WMUPDV + !/ ------------------------------------------------------------------- / + !> + !> @brief Interpolate scalar field from input grid to model grid. + !> + !> @details Interpolating or averaging from input grid. + !> + !> @param[in] IMOD Output model number + !> @param[out] FD Output scalar field + !> @param[in] JMOD Input model number + !> @param[in] FDI Input scalar field + !> @param[in] UNDEF Value for mapped out point and points not covered. + !> + !> @author H. L. Tolman @date 06-Dec-2010 + !> + SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Dec-2010 | + !/ +-----------------------------------+ + !/ + !/ 14-Oct-2006 : Origination. ( version 3.10 ) + !/ 12-Jan-2007 : General clean-up and bug fixes. ( version 3.10 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 11-May-2015 : Updates to 2-ways nestings for UG ( version 5.08 ) + !/ 01-Jul-2019 : Generalize output to curv grids ( version 7.13 ) + !/ (R. Padilla-Hernandez, J.H. Alves, EMC/NOAA) + !/ + ! 1. Purpose : + ! + ! Interpolate scalar field from input grid to model grid. + ! + ! 2. Method : + ! + ! Interpolating or averaging from input grid. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Output model number, + ! FD Int. O Output scaler field. + ! JMOD Int. I Input model number, + ! FDI Int. I Input scaler field. + ! UNDEF Int. I Value for mapped out point and points not + ! covered. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3ERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMUPD2 Subr. WMUPDTMD Input update routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Grid pointers for output grid need to be set externally. + ! - If input grid does not cover point of target grid, target grid + ! values are set to UNDEF. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! !/T1 Test output interpolation data. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3SERVMD, ONLY: EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - USE W3GDATMD, ONLY: NX, NY, X0, Y0, SX, SY, GRIDS, FLAGLL, & - GTYPE, RLGTYPE, CLGTYPE, UNGTYPE, & - ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & - HPFAC, HQFAC, XGRD, YGRD - USE WMMDATMD, ONLY: IMPROC, NMPERR, NMPSCR, MDST, MDSE, MDSO, & - MDSS -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, JMOD - REAL, INTENT(OUT) :: FD(NX,NY) - REAL, INTENT(IN) :: FDI(GRIDS(JMOD)%NX,GRIDS(JMOD)%NY), & - UNDEF -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IXO, IYO, IX, IY, IXF0, IXFN, IYF0, & - IYFN, IXS0, IXSN, IYS0, IYSN, IXS, & - MXA, MYA, J, J1, J2, IXC, IYC, JJ, & - JX, JY + USE W3SERVMD, ONLY: STRACE +#endif + !/ + USE W3GDATMD, ONLY: NX, NY, X0, Y0, SX, SY, GRIDS, FLAGLL, & + GTYPE, RLGTYPE, CLGTYPE, UNGTYPE, & + ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & + HPFAC, HQFAC, XGRD, YGRD + USE WMMDATMD, ONLY: IMPROC, NMPERR, NMPSCR, MDST, MDSE, MDSO, & + MDSS + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, JMOD + REAL, INTENT(OUT) :: FD(NX,NY) + REAL, INTENT(IN) :: FDI(GRIDS(JMOD)%NX,GRIDS(JMOD)%NY), & + UNDEF + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IXO, IYO, IX, IY, IXF0, IXFN, IYF0, & + IYFN, IXS0, IXSN, IYS0, IYSN, IXS, & + MXA, MYA, J, J1, J2, IXC, IYC, JJ, & + JX, JY - INTEGER :: NPOIX, NPOIY, I, CURVI !RP + INTEGER :: NPOIX, NPOIY, I, CURVI !RP #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER, ALLOCATABLE :: NXA(:,:), NYA(:,:) - REAL :: XR, YR, R1, R2, RT, XFL, XFR, XSL, & - XSR, YFL, YFR, YSL, YSR - REAL :: FDL, WTOT, WL + INTEGER, ALLOCATABLE :: NXA(:,:), NYA(:,:) + REAL :: XR, YR, R1, R2, RT, XFL, XFR, XSL, & + XSR, YFL, YFR, YSL, YSR + REAL :: FDL, WTOT, WL - REAL :: LONC, LATC, SXYC, & - XDI, DTOLER, VALUEINTER + REAL :: LONC, LATC, SXYC, & + XDI, DTOLER, VALUEINTER - REAL, ALLOCATABLE :: RXA(:,:), RYA(:,:) + REAL, ALLOCATABLE :: RXA(:,:), RYA(:,:) - LOGICAL :: MAP1(NX,NY), MAP2(NX,NY), & - MAP3(NX,NY), FLAGUP -! - INTEGER, POINTER :: NXI, NYI, MAP(:,:), MAPI(:,:) + LOGICAL :: MAP1(NX,NY), MAP2(NX,NY), & + MAP3(NX,NY), FLAGUP + ! + INTEGER, POINTER :: NXI, NYI, MAP(:,:), MAPI(:,:) - DOUBLE PRECISION, POINTER :: XGRDI(:,:), YGRDI(:,:), XGRDC(:,:), YGRDC(:,:) - REAL, POINTER :: HPFACI(:,:), HQFACI(:,:) !RP + DOUBLE PRECISION, POINTER :: XGRDI(:,:), YGRDI(:,:), XGRDC(:,:), YGRDC(:,:) + REAL, POINTER :: HPFACI(:,:), HQFACI(:,:) !RP - REAL, POINTER :: X0I, Y0I, SXI, SYI !RPXXX , HPFACI, HQFACI - INTEGER, POINTER :: ICLOSE + REAL, POINTER :: X0I, Y0I, SXI, SYI !RPXXX , HPFACI, HQFACI + INTEGER, POINTER :: ICLOSE #ifdef W3_T1 - CHARACTER(LEN=17) :: FORMAT1 + CHARACTER(LEN=17) :: FORMAT1 #endif -!/ -!/ ------------------------------------------------------------------- / -! 0. Initialization -! 0.a Subroutine tracing and test output -! + !/ + !/ ------------------------------------------------------------------- / + ! 0. Initialization + ! 0.a Subroutine tracing and test output + ! #ifdef W3_S - CALL STRACE (IENT, 'WMUPDS') -#endif -! - NXI => GRIDS(JMOD)%NX - NYI => GRIDS(JMOD)%NY - X0I => GRIDS(JMOD)%X0 - Y0I => GRIDS(JMOD)%Y0 - SXI => GRIDS(JMOD)%SX - SYI => GRIDS(JMOD)%SY - HPFACI => GRIDS(JMOD)%HPFAC - HQFACI => GRIDS(JMOD)%HQFAC - MAP => GRIDS(IMOD)%MAPSTA - MAPI => GRIDS(JMOD)%MAPSTA - ICLOSE => GRIDS(JMOD)%ICLOSE -! - IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN - IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,*)'SUBROUTINE WMUPDS IS'// & - ' NOT YET ADAPTED FOR TRIPOLE GRIDS. STOPPING NOW.' - CALL EXTCDE ( 1 ) - END IF -! + CALL STRACE (IENT, 'WMUPDS') +#endif + ! + NXI => GRIDS(JMOD)%NX + NYI => GRIDS(JMOD)%NY + X0I => GRIDS(JMOD)%X0 + Y0I => GRIDS(JMOD)%Y0 + SXI => GRIDS(JMOD)%SX + SYI => GRIDS(JMOD)%SY + HPFACI => GRIDS(JMOD)%HPFAC + HQFACI => GRIDS(JMOD)%HQFAC + MAP => GRIDS(IMOD)%MAPSTA + MAPI => GRIDS(JMOD)%MAPSTA + ICLOSE => GRIDS(JMOD)%ICLOSE + ! + IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN + IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,*)'SUBROUTINE WMUPDS IS'// & + ' NOT YET ADAPTED FOR TRIPOLE GRIDS. STOPPING NOW.' + CALL EXTCDE ( 1 ) + END IF + ! #ifdef W3_T - WRITE (MDST,9000) IMOD, NX, NY, X0, Y0, SX, SY, & - JMOD, NXI, NYI, X0I, Y0I, SXI, SYI, UNDEF -#endif -! -! 0.b Initialize fields -! - FD = UNDEF -! - CURVI=0 - IF ( GRIDS(IMOD)%GTYPE .EQ. CLGTYPE .OR. & - GRIDS(JMOD)%GTYPE .EQ. CLGTYPE ) THEN - CURVI=1 - END IF + WRITE (MDST,9000) IMOD, NX, NY, X0, Y0, SX, SY, & + JMOD, NXI, NYI, X0I, Y0I, SXI, SYI, UNDEF +#endif + ! + ! 0.b Initialize fields + ! + FD = UNDEF + ! + CURVI=0 + IF ( GRIDS(IMOD)%GTYPE .EQ. CLGTYPE .OR. & + GRIDS(JMOD)%GTYPE .EQ. CLGTYPE ) THEN + CURVI=1 + END IF -! 1. Case of identical resolution and coinciding grids --------------- / -! - IF(CURVI .EQ. 0) THEN + ! 1. Case of identical resolution and coinciding grids --------------- / + ! + IF(CURVI .EQ. 0) THEN IF ( ABS(SX/SXI-1.) .LT. 1.E-3 .AND. & ABS(SY/SYI-1.) .LT. 1.E-3 .AND. & ABS(MOD((ABS(X0-X0I))/SX+0.5,1.)-0.5) .LT. 1.E-2 .AND. & ABS(MOD((ABS(Y0-Y0I))/SY+0.5,1.)-0.5) .LT. 1.E-2 ) THEN -! -! 1.a Offsets -! + ! + ! 1.a Offsets + ! IXO = NINT((X0-X0I)/SX) -! + ! IF ( FLAGLL ) THEN IXF0 = 1 IXFN = NX @@ -2183,27 +2183,27 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) IXS0 = MAX ( 1 , 1+IXO ) IXSN = IXS0 + IXFN - IXF0 END IF -! + ! IYO = NINT((Y0-Y0I)/SY) -! + ! IYF0 = MAX ( 1 , 1-IYO ) IYFN = MIN ( NY , NYI-IYO ) IYS0 = MAX ( 1 , 1+IYO ) IYSN = IYS0 + IYFN - IYF0 -! + ! #ifdef W3_T - WRITE (MDST,9010) IXO, IYO, IXF0, IXFN, IYF0, IYFN, & - IXS0, IXSN, IYS0, IYSN + WRITE (MDST,9010) IXO, IYO, IXF0, IXFN, IYF0, IYFN, & + IXS0, IXSN, IYS0, IYSN #endif -! -! 1.b Fill arrays for sea points only -! + ! + ! 1.b Fill arrays for sea points only + ! IF ( FLAGLL ) THEN DO IX=IXF0, IXFN - IXS = 1 + NINT ( MOD ( & - 1080.+X0+(REAL(IX)-0.5)*SX-X0I , 360. ) / SX - 0.5 ) + IXS = 1 + NINT ( MOD ( & + 1080.+X0+(REAL(IX)-0.5)*SX-X0I , 360. ) / SX - 0.5 ) IF ( IXS .GT. NXI ) CYCLE - FD(IX,IYF0:IYFN) = FDI(IXS,IYS0:IYSN) + FD(IX,IYF0:IYFN) = FDI(IXS,IYS0:IYSN) END DO ELSE DO IX=IXF0, IXFN @@ -2211,45 +2211,45 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) FD(IX,IYF0:IYFN) = FDI(IXS,IYS0:IYSN) END DO END IF -! -! 1.c Return to calling routine -! + ! + ! 1.c Return to calling routine + ! RETURN -! + ! END IF - END IF !CURVI -! -! 2. General case --------------------------------------------------- / -! -! -! 2.a Curvilinear grids -! - IF ( GRIDS(IMOD)%GTYPE .EQ. CLGTYPE .OR. & - GRIDS(JMOD)%GTYPE .EQ. CLGTYPE ) THEN + END IF !CURVI + ! + ! 2. General case --------------------------------------------------- / + ! + ! + ! 2.a Curvilinear grids + ! + IF ( GRIDS(IMOD)%GTYPE .EQ. CLGTYPE .OR. & + GRIDS(JMOD)%GTYPE .EQ. CLGTYPE ) THEN -! 2.a.1 Getting the info for reg and curvi grids - XGRDI => GRIDS(JMOD)%XGRD !LONS FOR INPUT FIELD - YGRDI => GRIDS(JMOD)%YGRD !LATS FOR INPUT FIELD + ! 2.a.1 Getting the info for reg and curvi grids + XGRDI => GRIDS(JMOD)%XGRD !LONS FOR INPUT FIELD + YGRDI => GRIDS(JMOD)%YGRD !LATS FOR INPUT FIELD -! GETTING THE INFO FOR THE CURVILINEAR GRID - XGRDC => GRIDS(IMOD)%XGRD !LONS FOR CURVI GRID - YGRDC => GRIDS(IMOD)%YGRD !LATS FOR CURVI GRID - !HPFAC => GRIDS(IMOD)%HPFAC !DELTAYGRDC(:,:)YGRDC(:,:)YGRDC(:,:)YGRDC(:,:)S IN LON FOR CURVI GRID - !HQFAC => GRIDS(IMOD)%HQFAC !DELTAS IN LAT FOR CURVI GRID + ! GETTING THE INFO FOR THE CURVILINEAR GRID + XGRDC => GRIDS(IMOD)%XGRD !LONS FOR CURVI GRID + YGRDC => GRIDS(IMOD)%YGRD !LATS FOR CURVI GRID + !HPFAC => GRIDS(IMOD)%HPFAC !DELTAYGRDC(:,:)YGRDC(:,:)YGRDC(:,:)YGRDC(:,:)S IN LON FOR CURVI GRID + !HQFAC => GRIDS(IMOD)%HQFAC !DELTAS IN LAT FOR CURVI GRID -! FOR NOW ONLY INTERPOLATION NOT AVERAGING THEN MXA=2 - MXA=2 - MYA=2 - ALLOCATE ( NXA(NX,0:MXA) , RXA(NX,MXA) ) - NXA = 0 - RXA = 0. - ALLOCATE ( NYA(NY,0:MYA) , RYA(NY,MYA) ) - NYA = 0 - RYA = 0. -! -!IS THE TOLERANCE USED TO DETERMINE IF TWO VALUES ARE EQUAL IN LOCATION - DTOLER = 1E-5 -! 2.a.2 running over the curvilinear grid + ! FOR NOW ONLY INTERPOLATION NOT AVERAGING THEN MXA=2 + MXA=2 + MYA=2 + ALLOCATE ( NXA(NX,0:MXA) , RXA(NX,MXA) ) + NXA = 0 + RXA = 0. + ALLOCATE ( NYA(NY,0:MYA) , RYA(NY,MYA) ) + NYA = 0 + RYA = 0. + ! + !IS THE TOLERANCE USED TO DETERMINE IF TWO VALUES ARE EQUAL IN LOCATION + DTOLER = 1E-5 + ! 2.a.2 running over the curvilinear grid DO J=1,NY DO I=1,NX LONC=REAL(XGRDC(J,I)) !LON FOR EVERY CURVL GRID POINT @@ -2258,23 +2258,23 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) !SYC =HQFAC(J,I) !DELTA IN LAT FOR CURVI GRID VALUEINTER=INTERPOLATE(NXI,REAL(XGRDI(1,:)),NYI,REAL(YGRDI(:,1)), & - FDI,LONC,LATC,DTOLER) + FDI,LONC,LATC,DTOLER) FD(I,J)=VALUEINTER END DO !END I END DO !END J + ELSE + ! + ! 2.b Rectilinear grids + ! + ! 2.b.1 Interpolation / averaging data for X axis + ! + IF ( SX/SXI .LT. 1.0001 ) THEN + MXA = 2 ELSE -! -! 2.b Rectilinear grids -! -! 2.b.1 Interpolation / averaging data for X axis -! - IF ( SX/SXI .LT. 1.0001 ) THEN - MXA = 2 - ELSE - MXA = 2 + INT(SX/SXI) - END IF -! + MXA = 2 + INT(SX/SXI) + END IF + ! #ifdef W3_T WRITE (MDST,9020) 'X' #endif @@ -2283,87 +2283,40 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MXA+1,'I5,',MXA+1,"F6.2)'" WRITE (MDST,9021) NX, MXA #endif -! - ALLOCATE ( NXA(NX,0:MXA) , RXA(NX,MXA) ) - NXA = 0 - RXA = 0. -! -! - IF ( MXA .EQ. 2 ) THEN -! - DO IX=1, NX - IF ( FLAGLL ) THEN - XR = 1. + MOD & - ( 1080.+X0+REAL(IX-1)*SX-X0I , 360. ) / SXI - ELSE - XR = 1. + ( X0+REAL(IX-1)*SX - X0I ) / SXI + ! + ALLOCATE ( NXA(NX,0:MXA) , RXA(NX,MXA) ) + NXA = 0 + RXA = 0. + ! + ! + IF ( MXA .EQ. 2 ) THEN + ! + DO IX=1, NX + IF ( FLAGLL ) THEN + XR = 1. + MOD & + ( 1080.+X0+REAL(IX-1)*SX-X0I , 360. ) / SXI + ELSE + XR = 1. + ( X0+REAL(IX-1)*SX - X0I ) / SXI + END IF + IF ( XR.GT.0. ) THEN + J1 = INT(XR) + J2 = J1 + 1 + R2 = MAX ( 0. , XR-REAL(J1) ) + R1 = 1. - R2 + IF ( FLAGLL .AND. ICLOSE.NE.ICLOSE_NONE ) THEN + J1 = 1 + MOD(J1-1,NXI) + J2 = 1 + MOD(J2-1,NXI) END IF - IF ( XR.GT.0. ) THEN - J1 = INT(XR) - J2 = J1 + 1 - R2 = MAX ( 0. , XR-REAL(J1) ) - R1 = 1. - R2 - IF ( FLAGLL .AND. ICLOSE.NE.ICLOSE_NONE ) THEN - J1 = 1 + MOD(J1-1,NXI) - J2 = 1 + MOD(J2-1,NXI) - END IF - IF ( J1.GE.1 .AND. J1.LE.NXI .AND. R1.GT.0.05 ) THEN - NXA(IX,0) = NXA(IX,0) + 1 - NXA(IX,NXA(IX,0)) = J1 - RXA(IX,NXA(IX,0)) = R1 - END IF - IF ( J2.GE.1 .AND. J2.LE.NXI .AND. R2.GT.0.05 ) THEN - NXA(IX,0) = NXA(IX,0) + 1 - NXA(IX,NXA(IX,0)) = J2 - RXA(IX,NXA(IX,0)) = R2 - END IF - IF ( NXA(IX,0) .GT. 0 ) THEN - RT = SUM ( RXA(IX,:) ) - IF ( RT .LT. 0.7 ) THEN - NXA(IX,:) = 0 - RXA(IX,:) = 0. - END IF - END IF + IF ( J1.GE.1 .AND. J1.LE.NXI .AND. R1.GT.0.05 ) THEN + NXA(IX,0) = NXA(IX,0) + 1 + NXA(IX,NXA(IX,0)) = J1 + RXA(IX,NXA(IX,0)) = R1 END IF - END DO -! - ELSE -! - DO IX=1, NX -! - XFL = X0 + REAL(IX-1)*SX - 0.5*SX - XFR = X0 + REAL(IX-1)*SX + 0.5*SX - IF ( FLAGLL ) THEN - IXC = 1 + NINT ( MOD ( & - 1080.+X0+REAL(IX-1)*SX-X0I , 360. ) / SXI ) - IXS0 = IXC - 1 - MXA/2 - IXSN = IXC + 1 + MXA/2 - ELSE - IXC = NINT ( 1. + ( X0+REAL(IX-1)*SX - X0I ) / SXI ) - IXS0 = MAX ( 1 , IXC - 1 - MXA/2 ) - IXSN = MIN ( NXI , IXC + 1 + MXA/2 ) + IF ( J2.GE.1 .AND. J2.LE.NXI .AND. R2.GT.0.05 ) THEN + NXA(IX,0) = NXA(IX,0) + 1 + NXA(IX,NXA(IX,0)) = J2 + RXA(IX,NXA(IX,0)) = R2 END IF - DO J=IXS0, IXSN - IF ( FLAGLL ) THEN - IF ( ICLOSE.NE.ICLOSE_NONE ) JJ = 1 + MOD(J-1+NXI,NXI) - IF ( JJ.LT.1 .OR. JJ.GT. NXI ) CYCLE - IXC = NINT((0.5*(XFL+XFR)-X0I-REAL(JJ-1)*SXI)/360.) - IF ( IXC .NE. 0 ) THEN - XFL = XFL - REAL(IXC) * 360. - XFR = XFR - REAL(IXC) * 360. - END IF - ELSE - JJ = J - END IF - XSL = MAX ( XFL , X0I + REAL(JJ-1)*SXI - 0.5*SXI ) - XSR = MIN ( XFR , X0I + REAL(JJ-1)*SXI + 0.5*SXI ) - R1 = MAX ( 0. , XSR - XSL ) / SX - IF ( R1 .GT. 0 ) THEN - NXA(IX,0) = NXA(IX,0) + 1 - NXA(IX,NXA(IX,0)) = JJ - RXA(IX,NXA(IX,0)) = R1 - END IF - END DO IF ( NXA(IX,0) .GT. 0 ) THEN RT = SUM ( RXA(IX,:) ) IF ( RT .LT. 0.7 ) THEN @@ -2371,25 +2324,72 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) RXA(IX,:) = 0. END IF END IF + END IF + END DO + ! + ELSE + ! + DO IX=1, NX + ! + XFL = X0 + REAL(IX-1)*SX - 0.5*SX + XFR = X0 + REAL(IX-1)*SX + 0.5*SX + IF ( FLAGLL ) THEN + IXC = 1 + NINT ( MOD ( & + 1080.+X0+REAL(IX-1)*SX-X0I , 360. ) / SXI ) + IXS0 = IXC - 1 - MXA/2 + IXSN = IXC + 1 + MXA/2 + ELSE + IXC = NINT ( 1. + ( X0+REAL(IX-1)*SX - X0I ) / SXI ) + IXS0 = MAX ( 1 , IXC - 1 - MXA/2 ) + IXSN = MIN ( NXI , IXC + 1 + MXA/2 ) + END IF + DO J=IXS0, IXSN + IF ( FLAGLL ) THEN + IF ( ICLOSE.NE.ICLOSE_NONE ) JJ = 1 + MOD(J-1+NXI,NXI) + IF ( JJ.LT.1 .OR. JJ.GT. NXI ) CYCLE + IXC = NINT((0.5*(XFL+XFR)-X0I-REAL(JJ-1)*SXI)/360.) + IF ( IXC .NE. 0 ) THEN + XFL = XFL - REAL(IXC) * 360. + XFR = XFR - REAL(IXC) * 360. + END IF + ELSE + JJ = J + END IF + XSL = MAX ( XFL , X0I + REAL(JJ-1)*SXI - 0.5*SXI ) + XSR = MIN ( XFR , X0I + REAL(JJ-1)*SXI + 0.5*SXI ) + R1 = MAX ( 0. , XSR - XSL ) / SX + IF ( R1 .GT. 0 ) THEN + NXA(IX,0) = NXA(IX,0) + 1 + NXA(IX,NXA(IX,0)) = JJ + RXA(IX,NXA(IX,0)) = R1 + END IF END DO -! - END IF -! + IF ( NXA(IX,0) .GT. 0 ) THEN + RT = SUM ( RXA(IX,:) ) + IF ( RT .LT. 0.7 ) THEN + NXA(IX,:) = 0 + RXA(IX,:) = 0. + END IF + END IF + END DO + ! + END IF + ! #ifdef W3_T1 DO, IX=1, NX IF ( NXA(IX,0) .GT. 0 ) WRITE (MDST,FORMAT1) & - IX, NXA(IX,1:MXA), RXA(IX,1:MXA), SUM(RXA(IX,1:MXA)) - END DO + IX, NXA(IX,1:MXA), RXA(IX,1:MXA), SUM(RXA(IX,1:MXA)) + END DO #endif -! -! 2.b.2 Interpolation / averaging data for Y axis -! - IF ( SY/SYI .LT. 1.0001 ) THEN - MYA = 2 - ELSE - MYA = 2 + INT(SY/SYI) - END IF -! + ! + ! 2.b.2 Interpolation / averaging data for Y axis + ! + IF ( SY/SYI .LT. 1.0001 ) THEN + MYA = 2 + ELSE + MYA = 2 + INT(SY/SYI) + END IF + ! #ifdef W3_T WRITE (MDST,9020) 'Y' #endif @@ -2397,59 +2397,31 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MYA+1,'I5,',MYA+1,"F6.2)'" WRITE (MDST,9021) NY, MYA #endif -! - ALLOCATE ( NYA(NY,0:MYA) , RYA(NY,MYA) ) - NYA = 0 - RYA = 0. -! -! - IF ( MYA .EQ. 2 ) THEN -! - DO IY=1, NY - YR = 1. + ( Y0+REAL(IY-1)*SY - Y0I ) / SYI - IF ( YR.GT.0. ) THEN - J1 = INT(YR) - J2 = J1 + 1 - R2 = MAX ( 0. , YR-REAL(J1) ) - R1 = 1. - R2 - IF ( J1.GE.1 .AND. J1.LE.NYI .AND. R1.GT.0.05 ) THEN - NYA(IY,0) = NYA(IY,0) + 1 - NYA(IY,NYA(IY,0)) = J1 - RYA(IY,NYA(IY,0)) = R1 - END IF - IF ( J2.GE.1 .AND. J2.LE.NYI .AND. R2.GT.0.05 ) THEN - NYA(IY,0) = NYA(IY,0) + 1 - NYA(IY,NYA(IY,0)) = J2 - RYA(IY,NYA(IY,0)) = R2 - END IF - IF ( NYA(IY,0) .GT. 0 ) THEN - RT = SUM ( RYA(IY,:) ) - IF ( RT .LT. 0.7 ) THEN - NYA(IY,:) = 0 - RYA(IY,:) = 0. - END IF - END IF - END IF - END DO -! - ELSE -! - DO IY=1, NY - YFL = Y0 + REAL(IY-1)*SY - 0.5*SY - YFR = Y0 + REAL(IY-1)*SY + 0.5*SY - IYC = NINT ( 1. + ( Y0+REAL(IY-1)*SY - Y0I ) / SYI ) - IYS0 = MAX ( 1 , IYC - 1 - MYA/2 ) - IYSN = MIN ( NYI , IYC + 1 + MYA/2 ) - DO J=IYS0, IYSN - YSL = MAX ( YFL , Y0I + REAL(J-1)*SYI - 0.5*SYI ) - YSR = MIN ( YFR , Y0I + REAL(J-1)*SYI + 0.5*SYI ) - R1 = MAX ( 0. , YSR - YSL ) / SY - IF ( R1 .GT. 0 ) THEN + ! + ALLOCATE ( NYA(NY,0:MYA) , RYA(NY,MYA) ) + NYA = 0 + RYA = 0. + ! + ! + IF ( MYA .EQ. 2 ) THEN + ! + DO IY=1, NY + YR = 1. + ( Y0+REAL(IY-1)*SY - Y0I ) / SYI + IF ( YR.GT.0. ) THEN + J1 = INT(YR) + J2 = J1 + 1 + R2 = MAX ( 0. , YR-REAL(J1) ) + R1 = 1. - R2 + IF ( J1.GE.1 .AND. J1.LE.NYI .AND. R1.GT.0.05 ) THEN NYA(IY,0) = NYA(IY,0) + 1 - NYA(IY,NYA(IY,0)) = J + NYA(IY,NYA(IY,0)) = J1 RYA(IY,NYA(IY,0)) = R1 END IF - END DO + IF ( J2.GE.1 .AND. J2.LE.NYI .AND. R2.GT.0.05 ) THEN + NYA(IY,0) = NYA(IY,0) + 1 + NYA(IY,NYA(IY,0)) = J2 + RYA(IY,NYA(IY,0)) = R2 + END IF IF ( NYA(IY,0) .GT. 0 ) THEN RT = SUM ( RYA(IY,:) ) IF ( RT .LT. 0.7 ) THEN @@ -2457,658 +2429,686 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) RYA(IY,:) = 0. END IF END IF + END IF + END DO + ! + ELSE + ! + DO IY=1, NY + YFL = Y0 + REAL(IY-1)*SY - 0.5*SY + YFR = Y0 + REAL(IY-1)*SY + 0.5*SY + IYC = NINT ( 1. + ( Y0+REAL(IY-1)*SY - Y0I ) / SYI ) + IYS0 = MAX ( 1 , IYC - 1 - MYA/2 ) + IYSN = MIN ( NYI , IYC + 1 + MYA/2 ) + DO J=IYS0, IYSN + YSL = MAX ( YFL , Y0I + REAL(J-1)*SYI - 0.5*SYI ) + YSR = MIN ( YFR , Y0I + REAL(J-1)*SYI + 0.5*SYI ) + R1 = MAX ( 0. , YSR - YSL ) / SY + IF ( R1 .GT. 0 ) THEN + NYA(IY,0) = NYA(IY,0) + 1 + NYA(IY,NYA(IY,0)) = J + RYA(IY,NYA(IY,0)) = R1 + END IF END DO -! - END IF -! + IF ( NYA(IY,0) .GT. 0 ) THEN + RT = SUM ( RYA(IY,:) ) + IF ( RT .LT. 0.7 ) THEN + NYA(IY,:) = 0 + RYA(IY,:) = 0. + END IF + END IF + END DO + ! END IF -! + ! + END IF + ! #ifdef W3_T1 - DO, IY=1, NY - IF ( NYA(IY,0) .GT. 0 ) WRITE (MDST,FORMAT1) & - IY, NYA(IY,1:MYA), RYA(IY,1:MYA), SUM(RYA(IY,1:MYA)) - END DO + DO, IY=1, NY + IF ( NYA(IY,0) .GT. 0 ) WRITE (MDST,FORMAT1) & + IY, NYA(IY,1:MYA), RYA(IY,1:MYA), SUM(RYA(IY,1:MYA)) + END DO +#endif + ! + ! 2.c Process grid + ! + MAP1 = .FALSE. + MAP2 = .FALSE. + ! + DO IX=1, NX + IF ( NXA(IX,0) .EQ. 0 ) CYCLE + DO IY=1, NY + IF ( NYA(IY,0) .EQ. 0 ) CYCLE + IF ( MAP(IY,IX).NE.0 ) THEN + FDL = 0. + WTOT = 0. + DO J1=1, NXA(IX,0) + JX = NXA(IX,J1) + DO J2=1, NYA(IY,0) + JY = NYA(IY,J2) + IF ( MAPI(JY,JX) .NE. 0 ) THEN + WL = RXA(IX,J1) * RYA(IY,J2) + WTOT = WTOT + WL + FDL = FDL + WL * FDI(JX,JY) + END IF + END DO + END DO + IF ( WTOT .LT. 0.05 ) THEN + MAP1(IX,IY) = .TRUE. + ELSE + MAP2(IX,IY) = .TRUE. + FDL = FDL / WTOT + FD(IX,IY) = FDL + END IF + END IF + END DO + END DO + ! + ! 2.d Reconcile mask differences + ! +#ifdef W3_T + WRITE (MDST,9022) +#endif + ! + JJ = 0 + ICLOSE => GRIDS(IMOD)%ICLOSE + ! + DO + IF ( JJ .GT. SWPMAX ) EXIT + FLAGUP = .FALSE. + MAP3 = .FALSE. + JJ = JJ + 1 +#ifdef W3_T + WRITE (MDST,9023) JJ #endif -! -! 2.c Process grid -! - MAP1 = .FALSE. - MAP2 = .FALSE. -! DO IX=1, NX - IF ( NXA(IX,0) .EQ. 0 ) CYCLE DO IY=1, NY - IF ( NYA(IY,0) .EQ. 0 ) CYCLE - IF ( MAP(IY,IX).NE.0 ) THEN - FDL = 0. - WTOT = 0. - DO J1=1, NXA(IX,0) - JX = NXA(IX,J1) - DO J2=1, NYA(IY,0) - JY = NYA(IY,J2) - IF ( MAPI(JY,JX) .NE. 0 ) THEN - WL = RXA(IX,J1) * RYA(IY,J2) - WTOT = WTOT + WL - FDL = FDL + WL * FDI(JX,JY) + IF ( MAP1(IX,IY) ) THEN + FDL = 0. + J1 = 0 + IF ( FLAGLL ) THEN + DO J2=IX-1, IX+1 + IF ( (J2.GT.1 .AND. J2.LE.NX) .OR. ICLOSE.NE.ICLOSE_NONE ) THEN + JX = 1 + MOD(NX+J2-1,NX) + DO JY=IY-1, IY+1 + IF ( JY.GT.1 .AND. JY.LE.NY ) THEN + IF ( MAP2(JX,JY) ) THEN + FDL = FDL + FD(JX,JY) + J1 = J1 + 1 + END IF END IF END DO - END DO - IF ( WTOT .LT. 0.05 ) THEN - MAP1(IX,IY) = .TRUE. - ELSE - MAP2(IX,IY) = .TRUE. - FDL = FDL / WTOT - FD(IX,IY) = FDL END IF + END DO + ELSE + DO JX=IX-1, IX+1 + IF ( JX.GT.1 .AND. JX.LE.NX ) THEN + DO JY=IY-1, IY+1 + IF ( JY.GT.1 .AND. JY.LE.NY ) THEN + IF ( MAP2(JX,JY) ) THEN + FDL = FDL + FD(JX,JY) + J1 = J1 + 1 + END IF + END IF + END DO + END IF + END DO + END IF !FLAGLL + IF ( J1 .GT. 0 ) THEN + FD(IX,IY) = FDL / REAL(J1) + MAP1(IX,IY) = .FALSE. + MAP3(IX,IY) = .TRUE. + FLAGUP = .TRUE. END IF - END DO - END DO -! -! 2.d Reconcile mask differences -! -#ifdef W3_T - WRITE (MDST,9022) -#endif -! - JJ = 0 - ICLOSE => GRIDS(IMOD)%ICLOSE -! - DO - IF ( JJ .GT. SWPMAX ) EXIT - FLAGUP = .FALSE. - MAP3 = .FALSE. - JJ = JJ + 1 -#ifdef W3_T - WRITE (MDST,9023) JJ -#endif - DO IX=1, NX - DO IY=1, NY - IF ( MAP1(IX,IY) ) THEN - FDL = 0. - J1 = 0 - IF ( FLAGLL ) THEN - DO J2=IX-1, IX+1 - IF ( (J2.GT.1 .AND. J2.LE.NX) .OR. ICLOSE.NE.ICLOSE_NONE ) THEN - JX = 1 + MOD(NX+J2-1,NX) - DO JY=IY-1, IY+1 - IF ( JY.GT.1 .AND. JY.LE.NY ) THEN - IF ( MAP2(JX,JY) ) THEN - FDL = FDL + FD(JX,JY) - J1 = J1 + 1 - END IF - END IF - END DO - END IF - END DO - ELSE - DO JX=IX-1, IX+1 - IF ( JX.GT.1 .AND. JX.LE.NX ) THEN - DO JY=IY-1, IY+1 - IF ( JY.GT.1 .AND. JY.LE.NY ) THEN - IF ( MAP2(JX,JY) ) THEN - FDL = FDL + FD(JX,JY) - J1 = J1 + 1 - END IF - END IF - END DO - END IF - END DO - END IF !FLAGLL - IF ( J1 .GT. 0 ) THEN - FD(IX,IY) = FDL / REAL(J1) - MAP1(IX,IY) = .FALSE. - MAP3(IX,IY) = .TRUE. - FLAGUP = .TRUE. - END IF - END IF - END DO - END DO - IF ( FLAGUP ) THEN - MAP2 = MAP2 .OR. MAP3 - ELSE - EXIT END IF END DO -! -! 3. End of routine -------------------------------------------------- / -! - DEALLOCATE ( NXA, NYA, RXA, RYA ) -! - RETURN -! -! Formats -! + END DO + IF ( FLAGUP ) THEN + MAP2 = MAP2 .OR. MAP3 + ELSE + EXIT + END IF + END DO + ! + ! 3. End of routine -------------------------------------------------- / + ! + DEALLOCATE ( NXA, NYA, RXA, RYA ) + ! + RETURN + ! + ! Formats + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMUPDS : GRID INFORMATION : '/ & - ' ',3I5,4E11.3/ & - ' ',3I5,4E11.3/ & - ' UNDEFINED = ',E10.3) - 9010 FORMAT ( ' TEST WMUPDS : COINCIDING GRIDS, OFFSETS :',2I6/ & - ' TARGET GRID RANGES :',4I6/ & - ' SOURCE GRID RANGES :',4I6) - 9020 FORMAT ( ' TEST WMUPDS : WEIGHTS FOR ',A,' INTERPOATION') +9000 FORMAT ( ' TEST WMUPDS : GRID INFORMATION : '/ & + ' ',3I5,4E11.3/ & + ' ',3I5,4E11.3/ & + ' UNDEFINED = ',E10.3) +9010 FORMAT ( ' TEST WMUPDS : COINCIDING GRIDS, OFFSETS :',2I6/ & + ' TARGET GRID RANGES :',4I6/ & + ' SOURCE GRID RANGES :',4I6) +9020 FORMAT ( ' TEST WMUPDS : WEIGHTS FOR ',A,' INTERPOATION') #endif #ifdef W3_T1 - 9021 FORMAT ( ' TEST WMUPDS : ARAY DIMENSIONED AS : ',2I6) +9021 FORMAT ( ' TEST WMUPDS : ARAY DIMENSIONED AS : ',2I6) #endif #ifdef W3_T - 9022 FORMAT ( ' TEST WMUPDS : RECONCILING MASKS') - 9023 FORMAT ( ' SWEEP NR ',I4) -#endif -!/ -!/ End of WMUPDS ----------------------------------------------------- / -!/ - END SUBROUTINE WMUPDS -!======================================================================= -!> -!> @brief Search the location of a point(XC,YC) in a regular grid. -!> -!> @details Given an array and a value to search, it returns the index of -!> the element on the rectilinear grid that is closest to, but less -!> than, the given value. "delta" is the threshold used to determine -!> if two values are equal. -!> @verbatim -!> if ( abs(x1 - x2) <= delta) then -!> assume x1 = x2 -!> endif -!> @endverbatim -!> -!> @param LENGTH Dimension of input array -!> @param ARRAY 1D array for lats or longs -!> @param VALUE Value to located in ARRAY -!> @param DELTA Threshold to determine if two values are equal -!> @returns XYCURVISEARCH -!> -!> @author H. L. Tolman @date 20-Jan-2017 -!> - FUNCTION XYCURVISEARCH(LENGTH, ARRAY, VALUE, DELTA) -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jan-2017 | -!/ +-----------------------------------+ -!/ (R. Padilla-Hernandez, EMC/NOAA) -!/ -!/ 01-Jul-2019 : Origination. ( version 7.13 ) -!/ 01-Jul-2019 : Generalize output to curv grids ( version 7.13 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Search the location of a point(XC,YC) in a regular grid -! -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! LENGTH Int. Input Dimension of input array -! ARRAY Int. Input 1D array for lats or longs -! VALUE Real Input Value to be located in ARRAY -! DELTA Real Input Threshold to determine if two values -! are equal -! ---------------------------------------------------------------- -! -! Internal parameters -! ---------------------------------------------------------------- -! -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! XYCURVISEARCH Function Find indexes See bellow -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! - -! -! 5. Remarks : -! GIVEN AN ARRAY AND A VALUE TO SEARCH, IT RETURNS THE INDEX OF -! THE ELEMENT ON THE RECTILINEAR GRID THAT IS CLOSEST TO, BUT -! LESS THAN, THE GIVEN VALUE. -! "DELTA" IS THE THERSHOLD USED TO DETERMINE IF TWO VALUES ARE EQUAL -! IF ( ABS(X1 - X2) <= DELTA) THEN -! ASSUME X1 = X2 -! ENDIF -! -! 6. Switches : -! - -! -! 7. Source code : +9022 FORMAT ( ' TEST WMUPDS : RECONCILING MASKS') +9023 FORMAT ( ' SWEEP NR ',I4) +#endif + !/ + !/ End of WMUPDS ----------------------------------------------------- / + !/ + END SUBROUTINE WMUPDS + !======================================================================= + !> + !> @brief Search the location of a point(XC,YC) in a regular grid. + !> + !> @details Given an array and a value to search, it returns the index of + !> the element on the rectilinear grid that is closest to, but less + !> than, the given value. "delta" is the threshold used to determine + !> if two values are equal. + !> @verbatim + !> if ( abs(x1 - x2) <= delta) then + !> assume x1 = x2 + !> endif + !> @endverbatim + !> + !> @param LENGTH Dimension of input array + !> @param ARRAY 1D array for lats or longs + !> @param VALUE Value to located in ARRAY + !> @param DELTA Threshold to determine if two values are equal + !> @returns XYCURVISEARCH + !> + !> @author H. L. Tolman @date 20-Jan-2017 + !> + FUNCTION XYCURVISEARCH(LENGTH, ARRAY, VALUE, DELTA) + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jan-2017 | + !/ +-----------------------------------+ + !/ (R. Padilla-Hernandez, EMC/NOAA) + !/ + !/ 01-Jul-2019 : Origination. ( version 7.13 ) + !/ 01-Jul-2019 : Generalize output to curv grids ( version 7.13 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Search the location of a point(XC,YC) in a regular grid + ! + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! LENGTH Int. Input Dimension of input array + ! ARRAY Int. Input 1D array for lats or longs + ! VALUE Real Input Value to be located in ARRAY + ! DELTA Real Input Threshold to determine if two values + ! are equal + ! ---------------------------------------------------------------- + ! + ! Internal parameters + ! ---------------------------------------------------------------- + ! + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! XYCURVISEARCH Function Find indexes See bellow + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! - + ! + ! 5. Remarks : + ! GIVEN AN ARRAY AND A VALUE TO SEARCH, IT RETURNS THE INDEX OF + ! THE ELEMENT ON THE RECTILINEAR GRID THAT IS CLOSEST TO, BUT + ! LESS THAN, THE GIVEN VALUE. + ! "DELTA" IS THE THERSHOLD USED TO DETERMINE IF TWO VALUES ARE EQUAL + ! IF ( ABS(X1 - X2) <= DELTA) THEN + ! ASSUME X1 = X2 + ! ENDIF + ! + ! 6. Switches : + ! - + ! + ! 7. Source code : - INTEGER, INTENT(IN) :: LENGTH - REAL, DIMENSION(LENGTH), INTENT(IN) :: ARRAY - REAL, INTENT(IN) :: VALUE - REAL, INTENT(IN), OPTIONAL :: DELTA + INTEGER, INTENT(IN) :: LENGTH + REAL, DIMENSION(LENGTH), INTENT(IN) :: ARRAY + REAL, INTENT(IN) :: VALUE + REAL, INTENT(IN), OPTIONAL :: DELTA - INTEGER :: XYCURVISEARCH + INTEGER :: XYCURVISEARCH - INTEGER :: LEFT, MIDDLE, RIGHT - - - LEFT = 1 - RIGHT = LENGTH - DO - IF (LEFT > RIGHT) THEN - EXIT - ENDIF - MIDDLE = NINT((LEFT+RIGHT) / 2.0) - IF ( ABS(ARRAY(MIDDLE) - VALUE) <= DELTA) THEN - XYCURVISEARCH = MIDDLE - RETURN - ELSE IF (ARRAY(MIDDLE) > VALUE) THEN - RIGHT = MIDDLE - 1 - ELSE - LEFT = MIDDLE + 1 - END IF - END DO - XYCURVISEARCH = RIGHT + INTEGER :: LEFT, MIDDLE, RIGHT - END FUNCTION XYCURVISEARCH -! End of function -------------------------------------------------- / -! - -!> -!> @brief Perform interpolation from regular to curvilinear grid -!> for a scalar field. -!> -!> @details This function uses bilinear interpolation to -!> estimate the value of a function f at point (x,y). f is assumed -!> to be on a regular grid, with the grid x values specified by -!> xarray with dimension x_len and the grid y values specified by -!> yarray with dimension y_len. -!> -!> @param X_LEN Dimension in X -!> @param XARRAY 1D array for Longitudes -!> @param Y_LEN Dimension in Y -!> @param YARRAY 1D array for Latitudes -!> @param FUNC 1D Field -!> @param X Long for point in the curv grid -!> @param Y Lat for point in the curv grid -!> @param DELTA Threshold to determine if two values are equal -!> -!> @returns INTERPOLATE -!> -!> @author H. L. Tolman @date 25-Jul-2019 -!> - REAL FUNCTION INTERPOLATE(X_LEN,XARRAY,Y_LEN,YARRAY,FUNC, & - X,Y,DELTA) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-July-2019 | -!/ +-----------------------------------+ -!/ -!/ (R. Padilla-Hernandez, EMC/NOAA) -!/ -!/ 29-July-2019 : ( version 7.13 ) -!/ -! 1. Purpose : -! -! Perform interpolation from regular to curvilinear grid for a -! scalar field. THIS FUNCTION USES BILINEAR INTERPOLATION TO -! ESTIMATE THE VALUE OF A FUNCTION F AT POINT (X,Y) F IS ASSUMED -! TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED BY -! XARRAY WITH DIMENSION X_LEN AND THE GRID Y VALUES SPECIFIED BY -! YARRAY WITH DIMENSION Y_LEN -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! X_LEN Int. Dimension in X -! XARRAY Int. 1D array for Longitudes -! Y_LEN Int. Dimension in Y -! YARRAY Int. 1D array for Latitudes -! FUNC Int. 1D Field -! X,Y Real Long-Lat for point in the curv grid -! DELTA Real Threshold to determine if two values are equal -! ---------------------------------------------------------------- -! -! Internal parameters -! ---------------------------------------------------------------- -! INX Int. Index in X on the rectiliniear grid that is -! closest to, but less than, the given value for a -! point in the curvilinear grid. -! JNX Int. Idem INX for for Y. -! X1,Y1 Real (Long, Lat) left-bottom corner for the square in -! regular grid, where the given value for the point -! in the curvilinear grid lies -! X2,Y2 Real (Long, Lat) right-upper corner for the square in -! regular grid, where the given value for the point -! in the curvilinear grid lies -! ---------------------------------------------------------------- -! -! 3. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! XYCURVISEARCH Func. wmupdtmd Look for indexes in 1D array. -! ---------------------------------------------------------------- -! -! 4. Called by : -! -! Main program in which it is contained. -! -! 5. Error messages : -! -! None. -! -! 6. Remarks : -! -! - -! -! 7. Structure : -! -! See source code. -! -! 8. Switches : -! -! - -! -! 9. Source code : - ! THIS FUNCTION USES BILINEAR INTERPOLATION TO ESTIMATE THE VALUE - ! OF A FUNCTION F AT POINT (X,Y) - ! F IS ASSUMED TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED - ! BY XARRAY WITH DIMENSION X_LEN - ! AND THE GRID Y VALUES SPECIFIED BY YARRAY WITH DIMENSION Y_LEN -! - INTEGER, INTENT(IN) :: X_LEN, Y_LEN - REAL, DIMENSION(X_LEN), INTENT(IN) :: XARRAY - REAL, DIMENSION(Y_LEN), INTENT(IN) :: YARRAY - REAL, DIMENSION(X_LEN, Y_LEN), INTENT(IN) :: FUNC - REAL, INTENT(IN) :: X,Y - REAL, INTENT(IN), OPTIONAL :: DELTA - REAL :: DENOM, X1, X2, Y1, Y2 - INTEGER :: INX,JNX - INX = XYCURVISEARCH(X_LEN, XARRAY, X, DELTA) - JNX = XYCURVISEARCH(Y_LEN, YARRAY, Y, DELTA) -! - IF (INX .GE. X_LEN) THEN - INX=INX-1 - END IF - IF (JNX .GE. Y_LEN) THEN - JNX=JNX-1 + LEFT = 1 + RIGHT = LENGTH + DO + IF (LEFT > RIGHT) THEN + EXIT + ENDIF + MIDDLE = NINT((LEFT+RIGHT) / 2.0) + IF ( ABS(ARRAY(MIDDLE) - VALUE) <= DELTA) THEN + XYCURVISEARCH = MIDDLE + RETURN + ELSE IF (ARRAY(MIDDLE) > VALUE) THEN + RIGHT = MIDDLE - 1 + ELSE + LEFT = MIDDLE + 1 END IF -! - X1 = XARRAY(INX) - X2 = XARRAY(INX+1) - Y1 = YARRAY(JNX) - Y2 = YARRAY(JNX+1) -! - DENOM = (X2 - X1)*(Y2 - Y1) -! - INTERPOLATE = (FUNC(INX,JNX)*(X2-X)*(Y2-Y) + & - FUNC(INX+1,JNX)*(X-X1)*(Y2-Y) + & - FUNC(INX,JNX+1)*(X2-X)*(Y-Y1)+ & - FUNC(INX+1, JNX+1)*(X-X1)*(Y-Y1))/DENOM -! - END FUNCTION INTERPOLATE + END DO + XYCURVISEARCH = RIGHT -!======================================================================== -!> -!> @brief Perform interpolation from regular to curvilinear grid for a -!> vector field. -!> -!> @details This function uses bilinear interpolation to -!> estimate the value of a function f at point (x,y). f is assumed -!> to be on a regular grid, with the grid x values specified by -!> xarray with dimension x_len and the grid y values specified by -!> yarray with dimension y_len. -!> -!> @param[in] X_LEN Dimension in X -!> @param[in] XARRAY 1D array for Longitudes -!> @param[in] Y_LEN Dimension in Y -!> @param[in] YARRAY 1D array for Latitudes -!> @param[in] FUNC1 First component of the 2D array -!> @param[in] FUNC2 Second component of the 2D array -!> @param[in] X Long for point the curv grid -!> @param[in] Y Lat for point the curv grid -!> @param[in] DELTA Threshold to determine if two values are equal -!> @param[out] VAL1 Interpolated value at a point in curv grid -!> @param[out] VAL2 Interpolated value at a point in curv grid -!> -!> @author H. L. Tolman @date 25-Jul-2019 -!> - SUBROUTINE INTERPOLATE2D(X_LEN,XARRAY,Y_LEN,YARRAY,FUNC1, & - FUNC2,X,Y,DELTA,VAL1,VAL2) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-July-2019 | -!/ +-----------------------------------+ -!/ -!/ (R. Padilla-Hernandez, EMC/NOAA) -!/ -!/ 29-July-2019 : ( version 7.13 ) -!/ -! 1. Purpose : -! -! Perform interpolation from regular to curvilinear grid for a -! Vector field. THIS FUNCTION USES BILINEAR INTERPOLATION TO -! ESTIMATE THE VALUE OF A FUNCTION F AT POINT (X,Y) F IS ASSUMED -! TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED BY -! XARRAY WITH DIMENSION X_LEN AND THE GRID Y VALUES SPECIFIED BY -! YARRAY WITH DIMENSION Y_LEN -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! X_LEN Int. Dimension in X -! XARRAY Int. 1D array for Longitudes -! Y_LEN Int. Dimension in Y -! YARRAY Int. 1D array for Latitudes -! FUNC1 Int. First componen of the 2D array -! FUNC2 Int. Second component of the 2D array -! X,Y Real Long-Lat for point in the curv grid -! DELTA Real Threshold to determine if two values are equal -! VAL1,VAL2 Real Interpolated values at a point in curvi grid -! ---------------------------------------------------------------- -! -! Internal parameters -! ---------------------------------------------------------------- -! INX Int. Index in X on the rectiliniear grid that is -! closest to, but less than, the given value for a -! point in the curvilinear grid. -! JNX Int. Idem INX for for Y. -! X1,Y1 Real (Long, Lat) left-bottom corner for the square in -! regular grid, where the given value for the point -! in the curvilinear grid lies -! X2,Y2 Real (Long, Lat) right-upper corner for the square in -! regular grid, where the given value for the point -! in the curvilinear grid lies -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! XYCURVISEARCH Func. wmupdtmd Look for indexes in 1D array. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Main program in which it is contained. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! - -! -! 10. Source code : -! - INTEGER, INTENT(IN) :: X_LEN, Y_LEN - REAL, DIMENSION(X_LEN), INTENT(IN) :: XARRAY - REAL, DIMENSION(Y_LEN), INTENT(IN) :: YARRAY - REAL, DIMENSION(X_LEN, Y_LEN), INTENT(IN) :: FUNC1, FUNC2 - REAL, INTENT(IN) :: X,Y - REAL, INTENT(IN), OPTIONAL :: DELTA - REAL, INTENT(OUT) :: VAL1,VAL2 + END FUNCTION XYCURVISEARCH + ! End of function -------------------------------------------------- / + ! - REAL :: DENOM, X1, X2, Y1, Y2,C1,C2,C3,C4 - INTEGER :: INX,JNX + !> + !> @brief Perform interpolation from regular to curvilinear grid + !> for a scalar field. + !> + !> @details This function uses bilinear interpolation to + !> estimate the value of a function f at point (x,y). f is assumed + !> to be on a regular grid, with the grid x values specified by + !> xarray with dimension x_len and the grid y values specified by + !> yarray with dimension y_len. + !> + !> @param X_LEN Dimension in X + !> @param XARRAY 1D array for Longitudes + !> @param Y_LEN Dimension in Y + !> @param YARRAY 1D array for Latitudes + !> @param FUNC 1D Field + !> @param X Long for point in the curv grid + !> @param Y Lat for point in the curv grid + !> @param DELTA Threshold to determine if two values are equal + !> + !> @returns INTERPOLATE + !> + !> @author H. L. Tolman @date 25-Jul-2019 + !> + REAL FUNCTION INTERPOLATE(X_LEN,XARRAY,Y_LEN,YARRAY,FUNC, & + X,Y,DELTA) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-July-2019 | + !/ +-----------------------------------+ + !/ + !/ (R. Padilla-Hernandez, EMC/NOAA) + !/ + !/ 29-July-2019 : ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Perform interpolation from regular to curvilinear grid for a + ! scalar field. THIS FUNCTION USES BILINEAR INTERPOLATION TO + ! ESTIMATE THE VALUE OF A FUNCTION F AT POINT (X,Y) F IS ASSUMED + ! TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED BY + ! XARRAY WITH DIMENSION X_LEN AND THE GRID Y VALUES SPECIFIED BY + ! YARRAY WITH DIMENSION Y_LEN + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! X_LEN Int. Dimension in X + ! XARRAY Int. 1D array for Longitudes + ! Y_LEN Int. Dimension in Y + ! YARRAY Int. 1D array for Latitudes + ! FUNC Int. 1D Field + ! X,Y Real Long-Lat for point in the curv grid + ! DELTA Real Threshold to determine if two values are equal + ! ---------------------------------------------------------------- + ! + ! Internal parameters + ! ---------------------------------------------------------------- + ! INX Int. Index in X on the rectiliniear grid that is + ! closest to, but less than, the given value for a + ! point in the curvilinear grid. + ! JNX Int. Idem INX for for Y. + ! X1,Y1 Real (Long, Lat) left-bottom corner for the square in + ! regular grid, where the given value for the point + ! in the curvilinear grid lies + ! X2,Y2 Real (Long, Lat) right-upper corner for the square in + ! regular grid, where the given value for the point + ! in the curvilinear grid lies + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! XYCURVISEARCH Func. wmupdtmd Look for indexes in 1D array. + ! ---------------------------------------------------------------- + ! + ! 4. Called by : + ! + ! Main program in which it is contained. + ! + ! 5. Error messages : + ! + ! None. + ! + ! 6. Remarks : + ! + ! - + ! + ! 7. Structure : + ! + ! See source code. + ! + ! 8. Switches : + ! + ! - + ! + ! 9. Source code : + ! THIS FUNCTION USES BILINEAR INTERPOLATION TO ESTIMATE THE VALUE + ! OF A FUNCTION F AT POINT (X,Y) + ! F IS ASSUMED TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED + ! BY XARRAY WITH DIMENSION X_LEN + ! AND THE GRID Y VALUES SPECIFIED BY YARRAY WITH DIMENSION Y_LEN + ! + INTEGER, INTENT(IN) :: X_LEN, Y_LEN + REAL, DIMENSION(X_LEN), INTENT(IN) :: XARRAY + REAL, DIMENSION(Y_LEN), INTENT(IN) :: YARRAY + REAL, DIMENSION(X_LEN, Y_LEN), INTENT(IN) :: FUNC + REAL, INTENT(IN) :: X,Y + REAL, INTENT(IN), OPTIONAL :: DELTA + REAL :: DENOM, X1, X2, Y1, Y2 + INTEGER :: INX,JNX - INX = XYCURVISEARCH(X_LEN, XARRAY, X, DELTA) - JNX = XYCURVISEARCH(Y_LEN, YARRAY, Y, DELTA) -! - IF (INX .GE. X_LEN) THEN - INX=INX-1 - END IF - IF (JNX .GE. Y_LEN) THEN - JNX=JNX-1 - END IF -! - X1 = XARRAY(INX) - X2 = XARRAY(INX+1) - Y1 = YARRAY(JNX) - Y2 = YARRAY(JNX+1) -! - DENOM = (X2 - X1)*(Y2 - Y1) - C1=(X2-X)*(Y2-Y) - C2=(X-X1)*(Y2-Y) - C3=(X2-X)*(Y-Y1) - C4=(X-X1)*(Y-Y1) - VAL1 = (FUNC1(INX,JNX) *C1 + FUNC1(INX+1,JNX) *C2 + & - FUNC1(INX,JNX+1)*C3 + FUNC1(INX+1,JNX+1)*C4)/DENOM + INX = XYCURVISEARCH(X_LEN, XARRAY, X, DELTA) + JNX = XYCURVISEARCH(Y_LEN, YARRAY, Y, DELTA) + ! + IF (INX .GE. X_LEN) THEN + INX=INX-1 + END IF + IF (JNX .GE. Y_LEN) THEN + JNX=JNX-1 + END IF + ! + X1 = XARRAY(INX) + X2 = XARRAY(INX+1) + Y1 = YARRAY(JNX) + Y2 = YARRAY(JNX+1) + ! + DENOM = (X2 - X1)*(Y2 - Y1) + ! + INTERPOLATE = (FUNC(INX,JNX)*(X2-X)*(Y2-Y) + & + FUNC(INX+1,JNX)*(X-X1)*(Y2-Y) + & + FUNC(INX,JNX+1)*(X2-X)*(Y-Y1)+ & + FUNC(INX+1, JNX+1)*(X-X1)*(Y-Y1))/DENOM + ! + END FUNCTION INTERPOLATE - VAL2 = (FUNC2(INX,JNX) *C1 + FUNC2(INX+1,JNX) *C2 + & - FUNC2(INX,JNX+1)*C3 + FUNC2(INX+1,JNX+1)*C4)/DENOM -! - END SUBROUTINE INTERPOLATE2D -!==================================================================== -!> -!> @brief This function uses averaging to estimate the value -!> of a function f at point (x,y). -!> -!> @details f is assumed to be on a regular grid, with the grid x values specified -!> by xarray with dimension x_len -!> and the grid y values specified by yarray with dimension y_len, -!> the number of point to be taken into account in x and y. -!> -!> @param X_LEN -!> @param XARRAY -!> @param Y_LEN -!> @param YARRAY -!> @param FUNC -!> @param X -!> @param Y -!> @param NPX -!> @param NPY -!> @returns AVERAGING -!> -!> @author H. L. Tolman @date 25-Jul-2019 -!> - REAL FUNCTION AVERAGING(X_LEN,XARRAY,Y_LEN,YARRAY,FUNC, & - X,Y,NPX,NPY) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-July-2019 | -!/ +-----------------------------------+ -!/ -!/ (R. Padilla-Hernandez, EMC/NOAA) -!/ -!/ 29-July-2019 : ( version 7.13 ) -!/ + !======================================================================== + !> + !> @brief Perform interpolation from regular to curvilinear grid for a + !> vector field. + !> + !> @details This function uses bilinear interpolation to + !> estimate the value of a function f at point (x,y). f is assumed + !> to be on a regular grid, with the grid x values specified by + !> xarray with dimension x_len and the grid y values specified by + !> yarray with dimension y_len. + !> + !> @param[in] X_LEN Dimension in X + !> @param[in] XARRAY 1D array for Longitudes + !> @param[in] Y_LEN Dimension in Y + !> @param[in] YARRAY 1D array for Latitudes + !> @param[in] FUNC1 First component of the 2D array + !> @param[in] FUNC2 Second component of the 2D array + !> @param[in] X Long for point the curv grid + !> @param[in] Y Lat for point the curv grid + !> @param[in] DELTA Threshold to determine if two values are equal + !> @param[out] VAL1 Interpolated value at a point in curv grid + !> @param[out] VAL2 Interpolated value at a point in curv grid + !> + !> @author H. L. Tolman @date 25-Jul-2019 + !> + SUBROUTINE INTERPOLATE2D(X_LEN,XARRAY,Y_LEN,YARRAY,FUNC1, & + FUNC2,X,Y,DELTA,VAL1,VAL2) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-July-2019 | + !/ +-----------------------------------+ + !/ + !/ (R. Padilla-Hernandez, EMC/NOAA) + !/ + !/ 29-July-2019 : ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Perform interpolation from regular to curvilinear grid for a + ! Vector field. THIS FUNCTION USES BILINEAR INTERPOLATION TO + ! ESTIMATE THE VALUE OF A FUNCTION F AT POINT (X,Y) F IS ASSUMED + ! TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED BY + ! XARRAY WITH DIMENSION X_LEN AND THE GRID Y VALUES SPECIFIED BY + ! YARRAY WITH DIMENSION Y_LEN + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! X_LEN Int. Dimension in X + ! XARRAY Int. 1D array for Longitudes + ! Y_LEN Int. Dimension in Y + ! YARRAY Int. 1D array for Latitudes + ! FUNC1 Int. First componen of the 2D array + ! FUNC2 Int. Second component of the 2D array + ! X,Y Real Long-Lat for point in the curv grid + ! DELTA Real Threshold to determine if two values are equal + ! VAL1,VAL2 Real Interpolated values at a point in curvi grid + ! ---------------------------------------------------------------- + ! + ! Internal parameters + ! ---------------------------------------------------------------- + ! INX Int. Index in X on the rectiliniear grid that is + ! closest to, but less than, the given value for a + ! point in the curvilinear grid. + ! JNX Int. Idem INX for for Y. + ! X1,Y1 Real (Long, Lat) left-bottom corner for the square in + ! regular grid, where the given value for the point + ! in the curvilinear grid lies + ! X2,Y2 Real (Long, Lat) right-upper corner for the square in + ! regular grid, where the given value for the point + ! in the curvilinear grid lies + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! XYCURVISEARCH Func. wmupdtmd Look for indexes in 1D array. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Main program in which it is contained. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! - + ! + ! 10. Source code : + ! + INTEGER, INTENT(IN) :: X_LEN, Y_LEN + REAL, DIMENSION(X_LEN), INTENT(IN) :: XARRAY + REAL, DIMENSION(Y_LEN), INTENT(IN) :: YARRAY + REAL, DIMENSION(X_LEN, Y_LEN), INTENT(IN) :: FUNC1, FUNC2 + REAL, INTENT(IN) :: X,Y + REAL, INTENT(IN), OPTIONAL :: DELTA + REAL, INTENT(OUT) :: VAL1,VAL2 - ! THIS FUNCTION USES AVERAGING TO ESTIMATE THE VALUE - ! OF A FUNCTION F AT POINT (X,Y) - ! F IS ASSUMED TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED - ! BY XARRAY WITH DIMENSION X_LEN - ! AND THE GRID Y VALUES SPECIFIED BY YARRAY WITH DIMENSION Y_LEN - ! ININI AND INEND, THE NUMBER OF POINT TO BE TAKEN INTO ACCOUNT - ! IN X AND Y + REAL :: DENOM, X1, X2, Y1, Y2,C1,C2,C3,C4 + INTEGER :: INX,JNX - !IMPLICIT NONE - INTEGER X_LEN, Y_LEN, INXEND, INYEND, NPX,NPY - REAL, DIMENSION(X_LEN) :: XARRAY - REAL, DIMENSION(Y_LEN) :: YARRAY - REAL, DIMENSION(X_LEN, Y_LEN) :: FUNC - REAL :: X,Y - - REAL :: X1, X2, Y1, Y2, SUM - INTEGER :: INX,INY, INITIALX, INITIALY - INTEGER :: INFINX, INFINY,ICOUNT,I,J + INX = XYCURVISEARCH(X_LEN, XARRAY, X, DELTA) + JNX = XYCURVISEARCH(Y_LEN, YARRAY, Y, DELTA) + ! + IF (INX .GE. X_LEN) THEN + INX=INX-1 + END IF + IF (JNX .GE. Y_LEN) THEN + JNX=JNX-1 + END IF + ! + X1 = XARRAY(INX) + X2 = XARRAY(INX+1) + Y1 = YARRAY(JNX) + Y2 = YARRAY(JNX+1) + ! + DENOM = (X2 - X1)*(Y2 - Y1) + C1=(X2-X)*(Y2-Y) + C2=(X-X1)*(Y2-Y) + C3=(X2-X)*(Y-Y1) + C4=(X-X1)*(Y-Y1) + VAL1 = (FUNC1(INX,JNX) *C1 + FUNC1(INX+1,JNX) *C2 + & + FUNC1(INX,JNX+1)*C3 + FUNC1(INX+1,JNX+1)*C4)/DENOM - INX = XYCURVISEARCH(X_LEN, XARRAY, X) - INY = XYCURVISEARCH(Y_LEN, YARRAY, Y) + VAL2 = (FUNC2(INX,JNX) *C1 + FUNC2(INX+1,JNX) *C2 + & + FUNC2(INX,JNX+1)*C3 + FUNC2(INX+1,JNX+1)*C4)/DENOM + ! + END SUBROUTINE INTERPOLATE2D + !==================================================================== + !> + !> @brief This function uses averaging to estimate the value + !> of a function f at point (x,y). + !> + !> @details f is assumed to be on a regular grid, with the grid x values specified + !> by xarray with dimension x_len + !> and the grid y values specified by yarray with dimension y_len, + !> the number of point to be taken into account in x and y. + !> + !> @param X_LEN + !> @param XARRAY + !> @param Y_LEN + !> @param YARRAY + !> @param FUNC + !> @param X + !> @param Y + !> @param NPX + !> @param NPY + !> @returns AVERAGING + !> + !> @author H. L. Tolman @date 25-Jul-2019 + !> + REAL FUNCTION AVERAGING(X_LEN,XARRAY,Y_LEN,YARRAY,FUNC, & + X,Y,NPX,NPY) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-July-2019 | + !/ +-----------------------------------+ + !/ + !/ (R. Padilla-Hernandez, EMC/NOAA) + !/ + !/ 29-July-2019 : ( version 7.13 ) + !/ - X1 = XARRAY(INX) - !X2 = XARRAY(INX+1) + ! THIS FUNCTION USES AVERAGING TO ESTIMATE THE VALUE + ! OF A FUNCTION F AT POINT (X,Y) + ! F IS ASSUMED TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED + ! BY XARRAY WITH DIMENSION X_LEN + ! AND THE GRID Y VALUES SPECIFIED BY YARRAY WITH DIMENSION Y_LEN + ! ININI AND INEND, THE NUMBER OF POINT TO BE TAKEN INTO ACCOUNT + ! IN X AND Y - Y1 = YARRAY(INY) - !Y2 = YARRAY(INY+1) + !IMPLICIT NONE + INTEGER X_LEN, Y_LEN, INXEND, INYEND, NPX,NPY + REAL, DIMENSION(X_LEN) :: XARRAY + REAL, DIMENSION(Y_LEN) :: YARRAY + REAL, DIMENSION(X_LEN, Y_LEN) :: FUNC + REAL :: X,Y - INXEND=NPX+1 - INYEND=NPY+1 - ! LETS FIX THE INITIAL INDEX =1 NEGATIVE INDEXES IN LONG - IF (INX-NPX .LT. 1) THEN - INITIALX=1 - ELSE - INITIALX=INX-NPX - END IF - ! LETS FIX THE FINAL INDEX =NX IF LOOKING FOR INDEXES > NX - IF (INX+INXEND .GT. X_LEN) THEN - INFINX=X_LEN - ELSE - INFINX=INX+INXEND - END IF - ! LETS FIX THE INITIAL INDEX =1 FOR NEGATIVE INDEXES FOR LAT - IF (INY-NPY .LT. 1) THEN - INITIALY=1 - ELSE - INITIALY=INY-NPY - END IF - ! LETS FIX THE FINAL INDEX =NX IF LOOKING FOR INDEXES > NX - IF (INY+INYEND .GT. Y_LEN) THEN - INFINY=Y_LEN - ELSE - INFINY=INY+INYEND - END IF + REAL :: X1, X2, Y1, Y2, SUM + INTEGER :: INX,INY, INITIALX, INITIALY + INTEGER :: INFINX, INFINY,ICOUNT,I,J + INX = XYCURVISEARCH(X_LEN, XARRAY, X) + INY = XYCURVISEARCH(Y_LEN, YARRAY, Y) - SUM=0.0 - ICOUNT=0 - DO J=INITIALY,INFINY - DO I=INITIALX,INFINX - ICOUNT=ICOUNT+1 - SUM=SUM+FUNC(I,J) - END DO + X1 = XARRAY(INX) + !X2 = XARRAY(INX+1) + + Y1 = YARRAY(INY) + !Y2 = YARRAY(INY+1) + + INXEND=NPX+1 + INYEND=NPY+1 + ! LETS FIX THE INITIAL INDEX =1 NEGATIVE INDEXES IN LONG + IF (INX-NPX .LT. 1) THEN + INITIALX=1 + ELSE + INITIALX=INX-NPX + END IF + ! LETS FIX THE FINAL INDEX =NX IF LOOKING FOR INDEXES > NX + IF (INX+INXEND .GT. X_LEN) THEN + INFINX=X_LEN + ELSE + INFINX=INX+INXEND + END IF + ! LETS FIX THE INITIAL INDEX =1 FOR NEGATIVE INDEXES FOR LAT + IF (INY-NPY .LT. 1) THEN + INITIALY=1 + ELSE + INITIALY=INY-NPY + END IF + ! LETS FIX THE FINAL INDEX =NX IF LOOKING FOR INDEXES > NX + IF (INY+INYEND .GT. Y_LEN) THEN + INFINY=Y_LEN + ELSE + INFINY=INY+INYEND + END IF + + + SUM=0.0 + ICOUNT=0 + DO J=INITIALY,INFINY + DO I=INITIALX,INFINX + ICOUNT=ICOUNT+1 + SUM=SUM+FUNC(I,J) END DO - AVERAGING=SUM/REAL(ICOUNT) + END DO + AVERAGING=SUM/REAL(ICOUNT) - END FUNCTION AVERAGING + END FUNCTION AVERAGING -!======================================================================= + !======================================================================= -!/ -!/ End of module WMUPDTMD -------------------------------------------- / -!/ - END MODULE WMUPDTMD + !/ + !/ End of module WMUPDTMD -------------------------------------------- / + !/ +END MODULE WMUPDTMD diff --git a/model/src/wmwavemd.F90 b/model/src/wmwavemd.F90 index a64353774..99eec5eca 100644 --- a/model/src/wmwavemd.F90 +++ b/model/src/wmwavemd.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains module WMWAVEMD. -!> +!> !> @author H. L. Tolman @date 22-Mar-2021 #include "w3macros.h" @@ -8,2309 +8,2309 @@ !> !> @brief Running the multi-grid version of WAVEWATCH III up to a !> given ending time for each grid. -!> -!> @author H. L. Tolman @date 22-Mar-2021 -!> - MODULE WMWAVEMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 13-Jun-2005 : Origination. ( version 3.07 ) -!/ 30-Jan-2006 : Add static nesting. ( version 3.08 ) -!/ 25-May-2006 : Add overlapping grids. ( version 3.09 ) -!/ 09-Aug-2006 : Unified point output added. ( version 3.10 ) -!/ 22-Dec-2006 : Final algorith changes for tests. ( version 3.10 ) -!/ 25-Jan-2007 : Tweaking algorithm. ( version 3.10 ) -!/ 02-Feb-2007 : Replacing MPI_BCAST with WMBCST. ( version 3.10 ) -!/ 07-Feb-2007 : Reintroduce pre-fetching. ( version 3.10 ) -!/ 10-May-2007 : Removing / streamlining WMBCST. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 20-Sep-2007 : Fix reset of GRSTAT in 0.b ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 20-Aug-2010 : Fix MAPSTA/MAPST2 bug. ( version 3.14.6 ) -!/ 12-Mar-2012 : Use MPI_COMM_NULL for checks. ( version 3.14 ) -!/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) -!/ 22-Mar-2021 : Support for air density input ( version 7.13 ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Running the multi-grid version of WAVEWATCH III up to a given -! ending time for each grid. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WMWAVE Subr. Public Wave model initialization. -! WMPRNT Subr. Public Print action table to log file. -! WMBCST Subr. Public Non-blocking MPI broadcast. -! WMWOUT Subr. Public Non-blocking MPI broadcast. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! See subroutine documentation. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / !> -!> @brief Run multi-grid version of WAVEWATCH III. -!> -!> @param[in] TEND Ending time for calculations for each grid. !> @author H. L. Tolman @date 22-Mar-2021 -!> - - SUBROUTINE WMWAVE ( TEND ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 13-Jun-2005 : Origination. ( version 3.07 ) -!/ 30-Jan-2006 : Add static nesting. ( version 3.08 ) -!/ 25-May-2006 : Add overlapping grids. ( version 3.09 ) -!/ 09-Aug-2006 : Unified point output added. ( version 3.10 ) -!/ 22-Dec-2006 : Final algorith changes for tests. ( version 3.10 ) -!/ 25-Jan-2007 : Tweaking algorithm. ( version 3.10 ) -!/ 02-Feb-2007 : Replacing MPI_BCAST with WMBCST. ( version 3.10 ) -!/ 07-Feb-2007 : Reintroduce pre-fetching. ( version 3.10 ) -!/ 10-May-2007 : Removing / streamlining WMBCST. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 20-Sep-2007 : Fix reset of GRSTAT in 0.b ( version 3.13 ) -!/ 20-Aug-2010 : Fix MAPSTA/MAPST2 bug sec. 9.a. ( version 3.14.6 ) -!/ 12-Mar-2012 : Use MPI_COMM_NULL for checks. ( version 3.14 ) -!/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) -!/ 22-Mar-2021 : Support for air density input ( version 7.13 ) -!/ -! 1. Purpose : -! -! Run multi-grid version of WAVEWATCH III. -! -! 2. Method : -! -! See manual. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! TEND I.A. I Ending time for calculations for each grid. -! ---------------------------------------------------------------- -! -! Local variables -! ---------------------------------------------------------------- -! J Int. Group counter. -! JJ Int. Grid in group counter. -! I Int. Grid counter. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr W3GDATMD Point to grid/model. -! W3SETW Subr W3WDATMD Point to grid/model. -! W3SETA Subr W3ADATMD Point to grid/model. -! W3SETO Subr W3ODATMD Point to grid/model. -! W3IOPE Subr W3IOPOMD Extracting point output. -! W3WAVE Subr W3WAVEMD Actual ave model routine. -! STRACE Subr W3SERVMD Subroutine tracing. -! EXTCDE Subr Id. Abort program with exit code. -! WWTIME Subr Id. System time in readable format. -! PRTIME Subr Id. Profiling routine ( !/MPRF ) -! STME21 Subr W3TIMEMD Print date and time readable. -! DSEC21 Func Id. Difference between times. -! TICK21 Subr Id. Advance time. -! WMSETM Subr WMMDATMD Point to grid/model. -! WMUPDT Subr WMUPDTMD Update input fields at driver level. -! WMIOBG Subr WMINIOMD Gather staged boundary data. -! WMIOBS Subr Id. Stage boundary data. -! WMIOBF Subr Id. Finalize WMIOBS. ( !/MPI ) -! WMIOHS Subr Id. Stage high-to-low data. -! WMIOHG Subr Id. Gather staged high-to-low data. -! WMIOHF Subr Id. Finalize WMIOHS. ( !/MPI ) -! WMIOES Subr Id. Stage same-rank data. -! WMIOEG Subr Id. Gather staged same-rank data. -! WMIOEF Subr Id. Finalize WMIOES. ( !/MPI ) -! WMIOPO Subr WMIOPOMD Unified point output. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3MLTI Prog. N/A Multi-grid model driver. -! .... Any coupled model. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! See formats 1000 and following, or escape locations 2000 and -! following. -! -! 7. Remarks : -! -! - If no action is taken in the endless loop, an error is -! assumed (code 2099). This should never take place in the -! default driver, but may be a problem in a coupled model. -! - If output is requested for the initial model time, TSYNC -! is set to TIME instead of (-1,0) for GRSTAT = 0. In this case -! input is updated, after which GRSTAT is set to 6 instead -! of 1. This assures that restarts do not impact model results -! by spurious double reconciliations. -! -! 8. Structure : -! -! See source code and manual. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/MPIT Enable test output (use with !/MPI only). -! !/MPRF Profiling. -! -! !/SHRD, !/DIST, !/MPI -! Shared / distributed program model. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ - USE W3GDATMD, ONLY: W3SETG - USE W3WDATMD, ONLY: W3SETW - USE W3ADATMD, ONLY: W3SETA - USE W3ODATMD, ONLY: W3SETO, NOTYPE - USE W3IOPOMD, ONLY: W3IOPE - USE W3WAVEMD, ONLY: W3WAVE - USE W3SERVMD, ONLY: EXTCDE, WWTIME +!> +MODULE WMWAVEMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 13-Jun-2005 : Origination. ( version 3.07 ) + !/ 30-Jan-2006 : Add static nesting. ( version 3.08 ) + !/ 25-May-2006 : Add overlapping grids. ( version 3.09 ) + !/ 09-Aug-2006 : Unified point output added. ( version 3.10 ) + !/ 22-Dec-2006 : Final algorith changes for tests. ( version 3.10 ) + !/ 25-Jan-2007 : Tweaking algorithm. ( version 3.10 ) + !/ 02-Feb-2007 : Replacing MPI_BCAST with WMBCST. ( version 3.10 ) + !/ 07-Feb-2007 : Reintroduce pre-fetching. ( version 3.10 ) + !/ 10-May-2007 : Removing / streamlining WMBCST. ( version 3.11 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 20-Sep-2007 : Fix reset of GRSTAT in 0.b ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 20-Aug-2010 : Fix MAPSTA/MAPST2 bug. ( version 3.14.6 ) + !/ 12-Mar-2012 : Use MPI_COMM_NULL for checks. ( version 3.14 ) + !/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) + !/ 22-Mar-2021 : Support for air density input ( version 7.13 ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Running the multi-grid version of WAVEWATCH III up to a given + ! ending time for each grid. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr. Public Wave model initialization. + ! WMPRNT Subr. Public Print action table to log file. + ! WMBCST Subr. Public Non-blocking MPI broadcast. + ! WMWOUT Subr. Public Non-blocking MPI broadcast. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Run multi-grid version of WAVEWATCH III. + !> + !> @param[in] TEND Ending time for calculations for each grid. + !> @author H. L. Tolman @date 22-Mar-2021 + !> + + SUBROUTINE WMWAVE ( TEND ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 13-Jun-2005 : Origination. ( version 3.07 ) + !/ 30-Jan-2006 : Add static nesting. ( version 3.08 ) + !/ 25-May-2006 : Add overlapping grids. ( version 3.09 ) + !/ 09-Aug-2006 : Unified point output added. ( version 3.10 ) + !/ 22-Dec-2006 : Final algorith changes for tests. ( version 3.10 ) + !/ 25-Jan-2007 : Tweaking algorithm. ( version 3.10 ) + !/ 02-Feb-2007 : Replacing MPI_BCAST with WMBCST. ( version 3.10 ) + !/ 07-Feb-2007 : Reintroduce pre-fetching. ( version 3.10 ) + !/ 10-May-2007 : Removing / streamlining WMBCST. ( version 3.11 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 20-Sep-2007 : Fix reset of GRSTAT in 0.b ( version 3.13 ) + !/ 20-Aug-2010 : Fix MAPSTA/MAPST2 bug sec. 9.a. ( version 3.14.6 ) + !/ 12-Mar-2012 : Use MPI_COMM_NULL for checks. ( version 3.14 ) + !/ 28-Jan-2014 : Add memory hwm to profiling. ( version 5.00 ) + !/ 22-Mar-2021 : Support for air density input ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Run multi-grid version of WAVEWATCH III. + ! + ! 2. Method : + ! + ! See manual. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! TEND I.A. I Ending time for calculations for each grid. + ! ---------------------------------------------------------------- + ! + ! Local variables + ! ---------------------------------------------------------------- + ! J Int. Group counter. + ! JJ Int. Grid in group counter. + ! I Int. Grid counter. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr W3GDATMD Point to grid/model. + ! W3SETW Subr W3WDATMD Point to grid/model. + ! W3SETA Subr W3ADATMD Point to grid/model. + ! W3SETO Subr W3ODATMD Point to grid/model. + ! W3IOPE Subr W3IOPOMD Extracting point output. + ! W3WAVE Subr W3WAVEMD Actual ave model routine. + ! STRACE Subr W3SERVMD Subroutine tracing. + ! EXTCDE Subr Id. Abort program with exit code. + ! WWTIME Subr Id. System time in readable format. + ! PRTIME Subr Id. Profiling routine ( !/MPRF ) + ! STME21 Subr W3TIMEMD Print date and time readable. + ! DSEC21 Func Id. Difference between times. + ! TICK21 Subr Id. Advance time. + ! WMSETM Subr WMMDATMD Point to grid/model. + ! WMUPDT Subr WMUPDTMD Update input fields at driver level. + ! WMIOBG Subr WMINIOMD Gather staged boundary data. + ! WMIOBS Subr Id. Stage boundary data. + ! WMIOBF Subr Id. Finalize WMIOBS. ( !/MPI ) + ! WMIOHS Subr Id. Stage high-to-low data. + ! WMIOHG Subr Id. Gather staged high-to-low data. + ! WMIOHF Subr Id. Finalize WMIOHS. ( !/MPI ) + ! WMIOES Subr Id. Stage same-rank data. + ! WMIOEG Subr Id. Gather staged same-rank data. + ! WMIOEF Subr Id. Finalize WMIOES. ( !/MPI ) + ! WMIOPO Subr WMIOPOMD Unified point output. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3MLTI Prog. N/A Multi-grid model driver. + ! .... Any coupled model. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! See formats 1000 and following, or escape locations 2000 and + ! following. + ! + ! 7. Remarks : + ! + ! - If no action is taken in the endless loop, an error is + ! assumed (code 2099). This should never take place in the + ! default driver, but may be a problem in a coupled model. + ! - If output is requested for the initial model time, TSYNC + ! is set to TIME instead of (-1,0) for GRSTAT = 0. In this case + ! input is updated, after which GRSTAT is set to 6 instead + ! of 1. This assures that restarts do not impact model results + ! by spurious double reconciliations. + ! + ! 8. Structure : + ! + ! See source code and manual. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/MPIT Enable test output (use with !/MPI only). + ! !/MPRF Profiling. + ! + ! !/SHRD, !/DIST, !/MPI + ! Shared / distributed program model. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + USE W3GDATMD, ONLY: W3SETG + USE W3WDATMD, ONLY: W3SETW + USE W3ADATMD, ONLY: W3SETA + USE W3ODATMD, ONLY: W3SETO, NOTYPE + USE W3IOPOMD, ONLY: W3IOPE + USE W3WAVEMD, ONLY: W3WAVE + USE W3SERVMD, ONLY: EXTCDE, WWTIME #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif #ifdef W3_MPRF - USE W3TIMEMD, ONLY: PRTIME -#endif - USE W3TIMEMD, ONLY: DSEC21, STME21, TICK21 - USE WMMDATMD, ONLY: WMSETM - USE WMUPDTMD, ONLY: WMUPDT - USE WMINIOMD, ONLY: WMIOBG, WMIOBS, WMIOBF, WMIOHG, WMIOHS, & - WMIOHF, WMIOEG, WMIOES, WMIOEF - USE WMIOPOMD, ONLY: WMIOPO -!/ - USE W3GDATMD, ONLY: DTMAX, NX, NY, MAPSTA, MAPST2 - USE W3WDATMD, ONLY: TIME, VA - USE W3ODATMD, ONLY: FLOUT, TONEXT, DTOUT, TOLAST, IAPROC, & - NAPPNT, NOPTS, UNIPTS -#ifdef W3_MPI - USE W3ODATMD, ONLY: NRQPO, IRQPO1 -#endif - USE W3IDATMD, ONLY: INFLAGS1 - USE WMMDATMD, ONLY: MDSO, MDSS, MDST, MDSE, IMPROC, & - NMPROC, NMPSCR, NMPERR, NMPTST, NMPLOG, & - STIME, ETIME, NMV, TMV, AMV, DMV, & - NRGRD, NRGRP, GRANK, INGRP, GRDHGH, GRDEQL, & - GRDLOW, TSYNC, TMAX, TOUTP, TDATA, GRSTAT, & - FLLSTL, FLLSTI, FLLSTR, DTRES, FLGHG1, & - FLGHG2, MAPMSK -#ifdef W3_MPI - USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & - MPI_COMM_BCT, CROOT, FBCAST + USE W3TIMEMD, ONLY: PRTIME +#endif + USE W3TIMEMD, ONLY: DSEC21, STME21, TICK21 + USE WMMDATMD, ONLY: WMSETM + USE WMUPDTMD, ONLY: WMUPDT + USE WMINIOMD, ONLY: WMIOBG, WMIOBS, WMIOBF, WMIOHG, WMIOHS, & + WMIOHF, WMIOEG, WMIOES, WMIOEF + USE WMIOPOMD, ONLY: WMIOPO + !/ + USE W3GDATMD, ONLY: DTMAX, NX, NY, MAPSTA, MAPST2 + USE W3WDATMD, ONLY: TIME, VA + USE W3ODATMD, ONLY: FLOUT, TONEXT, DTOUT, TOLAST, IAPROC, & + NAPPNT, NOPTS, UNIPTS +#ifdef W3_MPI + USE W3ODATMD, ONLY: NRQPO, IRQPO1 +#endif + USE W3IDATMD, ONLY: INFLAGS1 + USE WMMDATMD, ONLY: MDSO, MDSS, MDST, MDSE, IMPROC, & + NMPROC, NMPSCR, NMPERR, NMPTST, NMPLOG, & + STIME, ETIME, NMV, TMV, AMV, DMV, & + NRGRD, NRGRP, GRANK, INGRP, GRDHGH, GRDEQL, & + GRDLOW, TSYNC, TMAX, TOUTP, TDATA, GRSTAT, & + FLLSTL, FLLSTI, FLLSTR, DTRES, FLGHG1, & + FLGHG2, MAPMSK +#ifdef W3_MPI + USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & + MPI_COMM_BCT, CROOT, FBCAST #endif #ifdef W3_MPRF - USE WMMDATMD, ONLY: MDSP -#endif -!/ - IMPLICIT NONE -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: TEND(2,NRGRD) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, JJ, I, JO, TPRNT(2), TAUX(2), & - II, JJJ, IX, IY, UPNEXT(2), UPLAST(2) - INTEGER :: DUMMY2(35)=0 + USE WMMDATMD, ONLY: MDSP +#endif + !/ + IMPLICIT NONE + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: TEND(2,NRGRD) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, JJ, I, JO, TPRNT(2), TAUX(2), & + II, JJJ, IX, IY, UPNEXT(2), UPLAST(2) + INTEGER :: DUMMY2(35)=0 #ifdef W3_T - INTEGER :: ILOOP + INTEGER :: ILOOP #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_MPI - INTEGER :: IERR_MPI, NMPSCS - INTEGER, ALLOCATABLE :: STATUS(:,:) + INTEGER :: IERR_MPI, NMPSCS + INTEGER, ALLOCATABLE :: STATUS(:,:) #endif - REAL :: DTTST, DTMAXI + REAL :: DTTST, DTMAXI #ifdef W3_MPRF - REAL :: PRFT0, PRFTN, PRFTS - REAL(KIND=8) :: get_memory + REAL :: PRFT0, PRFTN, PRFTS + REAL(KIND=8) :: get_memory #endif - CHARACTER(LEN=8) :: WTIME - CHARACTER(LEN=23) :: MTIME - LOGICAL :: DONE, TSTAMP, FLAGOK, DO_UPT, & - FLG_O1, FLG_O2 + CHARACTER(LEN=8) :: WTIME + CHARACTER(LEN=23) :: MTIME + LOGICAL :: DONE, TSTAMP, FLAGOK, DO_UPT, & + FLG_O1, FLG_O2 #ifdef W3_MPI - LOGICAL :: FLAG + LOGICAL :: FLAG #endif - LOGICAL, ALLOCATABLE :: FLSYNC(:), GRSYNC(:), TMSYNC(:), & - FLEQOK(:) + LOGICAL, ALLOCATABLE :: FLSYNC(:), GRSYNC(:), TMSYNC(:), & + FLEQOK(:) #ifdef W3_MPI - LOGICAL, ALLOCATABLE :: PREGTB(:), PREGTH(:), PREGTE(:) + LOGICAL, ALLOCATABLE :: PREGTB(:), PREGTH(:), PREGTE(:) #endif -!/ -!/ ------------------------------------------------------------------- / -! + !/ + !/ ------------------------------------------------------------------- / + ! #ifdef W3_S - CALL STRACE (IENT, 'WMWAVE') + CALL STRACE (IENT, 'WMWAVE') #endif -! + ! #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) + CALL PRTIME ( PRFT0 ) #endif -! + ! #ifdef W3_O10 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) -#endif -! -! 0. Initializations ------------------------------------------------ / -! 0.a Initial testing -! Test GRSTAT -! - DO I=1, NRGRD - IF ( ( GRSTAT(I).LT.0 .OR. GRSTAT(I).GT.7 ) .AND. & - GRSTAT(I).NE.99 ) GOTO 2000 -! -! Consistency of times for grids -! - IF ( TSYNC(1,I) .NE. -1 ) THEN - DTTST = DSEC21 ( TSYNC(:,I), TEND(:,I) ) - IF ( DTTST .LT. 0. ) GOTO 2001 - END IF - END DO -! -! Consistency of times within groups, set global TSYNC(:,0) -! - DO J=1, NRGRP - DO JJ=2, INGRP(J,0) - IF ( DSEC21(TSYNC(:,INGRP(J,1)),TSYNC(:,INGRP(J,JJ))).NE.0. & - .OR. DSEC21(TEND(:,INGRP(J,1)),TEND(:,INGRP(J,JJ))).NE.0. ) & - GOTO 2002 - END DO - IF ( GRANK(INGRP(J,1)).EQ.1 .AND. TSYNC(1,0).EQ.-1 ) & - TSYNC(:,0) = TSYNC(:,INGRP(J,1)) - END DO -! -! Check if FLSYNC initialized -! - IF ( .NOT. ALLOCATED(FLSYNC) ) THEN - ALLOCATE ( FLSYNC(NRGRD), GRSYNC(NRGRP), TMSYNC(NRGRD), & - FLEQOK(NRGRD) ) -#ifdef W3_MPI - ALLOCATE ( PREGTB(NRGRD), PREGTH(NRGRD), PREGTE(NRGRD) ) -#endif - FLSYNC = .FALSE. - GRSYNC = .FALSE. - TMSYNC = .TRUE. - FLEQOK = .FALSE. -#ifdef W3_MPI - PREGTB = .FALSE. - PREGTH = .FALSE. - PREGTE = .FALSE. -#endif - END IF -! -! 0.b Reset GRSTAT as needed -! - DO I=1, NRGRD - CALL W3SETW ( I, MDSE, MDST ) - DTTST = DSEC21 ( TIME, TEND(:,I) ) - IF ( GRSTAT(I).EQ.99 .AND. DTTST.GT.0. ) GRSTAT(I) = 0 - END DO -! -! 0.c Other initializations -! - DTRES = 0. -#ifdef W3_MPI - NMPSCS = NMPSCR -#endif -! - IF ( UNIPTS ) THEN - CALL W3SETO ( 0, MDSE, MDST ) - UPNEXT = TONEXT(:,2) - UPLAST = TOLAST(:,2) - DO_UPT = .TRUE. - ELSE - UPNEXT(1) = -1 - UPNEXT(2) = 0 - DO_UPT = .FALSE. - END IF -! -! 0.d Output -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - CALL WMPRNT ( MDSO, NRGRD, TSYNC(:,0), GRSTAT ) - CALL STME21 ( TSYNC(:,0), MTIME ) - CALL WWTIME ( WTIME ) - WRITE (MDSS,901) MTIME, WTIME, MINVAL(GRSTAT), MAXVAL(GRSTAT) - TPRNT = TSYNC(:,0) - TSTAMP = .TRUE. - ENDIF -! -#ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) -#endif -! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#endif + ! + ! 0. Initializations ------------------------------------------------ / + ! 0.a Initial testing + ! Test GRSTAT + ! + DO I=1, NRGRD + IF ( ( GRSTAT(I).LT.0 .OR. GRSTAT(I).GT.7 ) .AND. & + GRSTAT(I).NE.99 ) GOTO 2000 + ! + ! Consistency of times for grids + ! + IF ( TSYNC(1,I) .NE. -1 ) THEN + DTTST = DSEC21 ( TSYNC(:,I), TEND(:,I) ) + IF ( DTTST .LT. 0. ) GOTO 2001 + END IF + END DO + ! + ! Consistency of times within groups, set global TSYNC(:,0) + ! + DO J=1, NRGRP + DO JJ=2, INGRP(J,0) + IF ( DSEC21(TSYNC(:,INGRP(J,1)),TSYNC(:,INGRP(J,JJ))).NE.0. & + .OR. DSEC21(TEND(:,INGRP(J,1)),TEND(:,INGRP(J,JJ))).NE.0. ) & + GOTO 2002 + END DO + IF ( GRANK(INGRP(J,1)).EQ.1 .AND. TSYNC(1,0).EQ.-1 ) & + TSYNC(:,0) = TSYNC(:,INGRP(J,1)) + END DO + ! + ! Check if FLSYNC initialized + ! + IF ( .NOT. ALLOCATED(FLSYNC) ) THEN + ALLOCATE ( FLSYNC(NRGRD), GRSYNC(NRGRP), TMSYNC(NRGRD), & + FLEQOK(NRGRD) ) +#ifdef W3_MPI + ALLOCATE ( PREGTB(NRGRD), PREGTH(NRGRD), PREGTE(NRGRD) ) +#endif + FLSYNC = .FALSE. + GRSYNC = .FALSE. + TMSYNC = .TRUE. + FLEQOK = .FALSE. +#ifdef W3_MPI + PREGTB = .FALSE. + PREGTH = .FALSE. + PREGTE = .FALSE. +#endif + END IF + ! + ! 0.b Reset GRSTAT as needed + ! + DO I=1, NRGRD + CALL W3SETW ( I, MDSE, MDST ) + DTTST = DSEC21 ( TIME, TEND(:,I) ) + IF ( GRSTAT(I).EQ.99 .AND. DTTST.GT.0. ) GRSTAT(I) = 0 + END DO + ! + ! 0.c Other initializations + ! + DTRES = 0. +#ifdef W3_MPI + NMPSCS = NMPSCR +#endif + ! + IF ( UNIPTS ) THEN + CALL W3SETO ( 0, MDSE, MDST ) + UPNEXT = TONEXT(:,2) + UPLAST = TOLAST(:,2) + DO_UPT = .TRUE. + ELSE + UPNEXT(1) = -1 + UPNEXT(2) = 0 + DO_UPT = .FALSE. + END IF + ! + ! 0.d Output + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + CALL WMPRNT ( MDSO, NRGRD, TSYNC(:,0), GRSTAT ) + CALL STME21 ( TSYNC(:,0), MTIME ) + CALL WWTIME ( WTIME ) + WRITE (MDSS,901) MTIME, WTIME, MINVAL(GRSTAT), MAXVAL(GRSTAT) + TPRNT = TSYNC(:,0) + TSTAMP = .TRUE. + ENDIF + ! +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,990) PRFT0, PRFTN, get_memory() + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory() #endif -! -! 1. Setting up loop structure -------------------------------------- / -! + ! + ! 1. Setting up loop structure -------------------------------------- / + ! #ifdef W3_T - ILOOP = 0 -#endif -! - LOOP_OUTER: DO -! - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC .AND. & - DSEC21(TPRNT,TSYNC(:,0)).NE.0. ) THEN - IF ( .NOT. TSTAMP ) WRITE (MDSS,*) - CALL WMPRNT ( MDSO, NRGRD, TSYNC(:,0), GRSTAT ) - CALL STME21 ( TSYNC(:,0), MTIME ) - CALL WWTIME ( WTIME ) - WRITE (MDSS,901) MTIME, WTIME, MINVAL(GRSTAT), MAXVAL(GRSTAT) + ILOOP = 0 +#endif + ! + LOOP_OUTER: DO + ! + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC .AND. & + DSEC21(TPRNT,TSYNC(:,0)).NE.0. ) THEN + IF ( .NOT. TSTAMP ) WRITE (MDSS,*) + CALL WMPRNT ( MDSO, NRGRD, TSYNC(:,0), GRSTAT ) + CALL STME21 ( TSYNC(:,0), MTIME ) + CALL WWTIME ( WTIME ) + WRITE (MDSS,901) MTIME, WTIME, MINVAL(GRSTAT), MAXVAL(GRSTAT) -! - TPRNT = TSYNC(:,0) - TSTAMP = .TRUE. - ENDIF -! -#ifdef W3_T - ILOOP = ILOOP + 1 - WRITE (MDST,9000) ILOOP, TSYNC(:,0) - DO I=1, NRGRD - CALL W3SETW ( I, MDSE, MDST ) - WRITE (MDST,9001) I, GRSTAT(I), TIME, TSYNC(:,I), TEND(:,I) - END DO - IF ( ILOOP .EQ. -1 ) CALL EXTCDE ( 508 ) -#endif -! - DONE = .FALSE. + ! TPRNT = TSYNC(:,0) -! - LOOP_J: DO J=1, NRGRP -! -#ifdef W3_MPI - GRSYNC(J) = .FALSE. - DO JJ=1, INGRP(J,0) - I = INGRP(J,JJ) - CALL WMSETM ( I, MDSE, MDST ) - GRSYNC(J) = GRSYNC(J) .OR. FBCAST - END DO + TSTAMP = .TRUE. + ENDIF + ! +#ifdef W3_T + ILOOP = ILOOP + 1 + WRITE (MDST,9000) ILOOP, TSYNC(:,0) + DO I=1, NRGRD + CALL W3SETW ( I, MDSE, MDST ) + WRITE (MDST,9001) I, GRSTAT(I), TIME, TSYNC(:,I), TEND(:,I) + END DO + IF ( ILOOP .EQ. -1 ) CALL EXTCDE ( 508 ) +#endif + ! + DONE = .FALSE. + TPRNT = TSYNC(:,0) + ! + LOOP_J: DO J=1, NRGRP + ! +#ifdef W3_MPI + GRSYNC(J) = .FALSE. + DO JJ=1, INGRP(J,0) + I = INGRP(J,JJ) + CALL WMSETM ( I, MDSE, MDST ) + GRSYNC(J) = GRSYNC(J) .OR. FBCAST + END DO #endif -! - LOOP_JJ: DO JJ=1, INGRP(J,0) - I = INGRP(J,JJ) - CALL WMSETM ( I, MDSE, MDST ) -! -#ifdef W3_MPI - IF ( GRSTAT(I).EQ.0 ) TMSYNC(I) = .NOT. FBCAST - IF ( FBCAST ) THEN - NMPSCR = CROOT - ELSE - NMPSCR = NMPSCS - END IF + ! + LOOP_JJ: DO JJ=1, INGRP(J,0) + I = INGRP(J,JJ) + CALL WMSETM ( I, MDSE, MDST ) + ! +#ifdef W3_MPI + IF ( GRSTAT(I).EQ.0 ) TMSYNC(I) = .NOT. FBCAST + IF ( FBCAST ) THEN + NMPSCR = CROOT + ELSE + NMPSCR = NMPSCS + END IF #endif -! -! 2. Update input fields -------------------------------------------- / -! ( GRSTAT = 0 ) -! -! 2.a Check TDATA and finish step if data is still OK -! + ! + ! 2. Update input fields -------------------------------------------- / + ! ( GRSTAT = 0 ) + ! + ! 2.a Check TDATA and finish step if data is still OK + ! #ifdef W3_SHRD - IF ( GRSTAT(I) .EQ. 0 ) THEN + IF ( GRSTAT(I) .EQ. 0 ) THEN #endif #ifdef W3_MPI IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) ) THEN #endif -! + ! #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I), ' ' -#endif -! - IF ( TDATA(1,I) .EQ. -1 ) THEN - DTTST = 0. - ELSE - CALL W3SETW ( I, MDSE, MDST ) - DTTST = DSEC21 ( TIME , TDATA(:,I) ) - END IF + WRITE (MDST,9002) I, GRSTAT(I), ' ' +#endif + ! + IF ( TDATA(1,I) .EQ. -1 ) THEN + DTTST = 0. + ELSE + CALL W3SETW ( I, MDSE, MDST ) + DTTST = DSEC21 ( TIME , TDATA(:,I) ) + END IF #ifdef W3_T - WRITE (MDST,9020) DTTST + WRITE (MDST,9020) DTTST #endif -! - IF ( DTTST .GT. 0. ) THEN - GRSTAT(I) = 1 + ! + IF ( DTTST .GT. 0. ) THEN + GRSTAT(I) = 1 #ifdef W3_T - WRITE (MDST,9003) I, GRSTAT(I) + WRITE (MDST,9003) I, GRSTAT(I) #endif - DONE = .TRUE. - END IF -! + DONE = .TRUE. + END IF + ! #ifdef W3_MPI - END IF ! IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) + END IF ! IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) #endif #ifdef W3_SHRD - END IF ! IF ( GRSTAT(I) .EQ. 0 ) + END IF ! IF ( GRSTAT(I) .EQ. 0 ) #endif -! -! 2.b Update input and TDATA -! + ! + ! 2.b Update input and TDATA + ! #ifdef W3_SHRD - IF ( GRSTAT(I) .EQ. 0 ) THEN + IF ( GRSTAT(I) .EQ. 0 ) THEN #endif #ifdef W3_MPI IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) .AND. & - MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN + MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN #endif -! + ! #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) + CALL PRTIME ( PRFT0 ) #endif - IF ( DTTST .LE. 0 ) THEN - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - WRITE (MDSS,*) - TSTAMP = .FALSE. - CALL WMUPDT ( I, TDATA(:,I) ) + IF ( DTTST .LE. 0 ) THEN + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + WRITE (MDSS,*) + TSTAMP = .FALSE. + CALL WMUPDT ( I, TDATA(:,I) ) #ifdef W3_T - WRITE (MDST,9021) TIME, TDATA(:,I), TEND(:,I) + WRITE (MDST,9021) TIME, TDATA(:,I), TEND(:,I) #endif - END IF -! -! 2.c Finish up if possible ( !/SHRD or .NOT. FBCAST or no update ) -! + END IF + ! + ! 2.c Finish up if possible ( !/SHRD or .NOT. FBCAST or no update ) + ! #ifdef W3_SHRD - GRSTAT(I) = 1 - DONE = .TRUE. + GRSTAT(I) = 1 + DONE = .TRUE. #endif -! + ! #ifdef W3_MPI - IF ( .NOT. GRSYNC(J) ) THEN + IF ( .NOT. GRSYNC(J) ) THEN #endif #ifdef W3_MPIT - WRITE (MDST,9902) I, GRSTAT(I), & - 'NO SYNC FOR TDATA NEEDED' + WRITE (MDST,9902) I, GRSTAT(I), & + 'NO SYNC FOR TDATA NEEDED' #endif #ifdef W3_MPI - GRSTAT(I) = 1 - DONE = .TRUE. - END IF ! IF ( .NOT. GRSYNC(J) ) + GRSTAT(I) = 1 + DONE = .TRUE. + END IF ! IF ( .NOT. GRSYNC(J) ) #endif -! + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & - 'ST00', I + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & + 'ST00', I #endif -! + ! #ifdef W3_MPI - END IF ! IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) .AND. MPI_COMM_GRD .NE. MPI_COMM_NULL ) + END IF ! IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) .AND. MPI_COMM_GRD .NE. MPI_COMM_NULL ) #endif #ifdef W3_SHRD - END IF ! IF ( GRSTAT(I) .EQ. 0 ) + END IF ! IF ( GRSTAT(I) .EQ. 0 ) #endif -! -! 2.d Synchronize in parts ( !/MPI ) -! + ! + ! 2.d Synchronize in parts ( !/MPI ) + ! #ifdef W3_MPI - IF ( GRSTAT(I).EQ.0 .AND. GRSYNC(J) ) THEN - DONE = .TRUE. + IF ( GRSTAT(I).EQ.0 .AND. GRSYNC(J) ) THEN + DONE = .TRUE. #endif -! + ! #ifdef W3_MPI - IF ( FLSYNC(I) ) THEN + IF ( FLSYNC(I) ) THEN #endif #ifdef W3_MPIT - WRITE (MDST,9902) I, GRSTAT(I), & - 'SYNCING TDATA' + WRITE (MDST,9902) I, GRSTAT(I), & + 'SYNCING TDATA' #endif #ifdef W3_MPRF - IF (FLSYNC(I)) CALL PRTIME ( PRFT0 ) + IF (FLSYNC(I)) CALL PRTIME ( PRFT0 ) #endif #ifdef W3_MPI - IF ( FBCAST ) CALL WMBCST & - ( TDATA(1,I), 2, I, NRGRD, 1 ) + IF ( FBCAST ) CALL WMBCST & + ( TDATA(1,I), 2, I, NRGRD, 1 ) #endif #ifdef W3_MPRF - IF (FLSYNC(I)) CALL PRTIME ( PRFTN ) - IF (FLSYNC(I)) WRITE (MDSP,991) & - PRFT0, PRFTN, get_memory(), 'BCST',I + IF (FLSYNC(I)) CALL PRTIME ( PRFTN ) + IF (FLSYNC(I)) WRITE (MDSP,991) & + PRFT0, PRFTN, get_memory(), 'BCST',I #endif #ifdef W3_MPIT - WRITE (MDST,9902) I, GRSTAT(I), 'SYNCING DONE' + WRITE (MDST,9902) I, GRSTAT(I), 'SYNCING DONE' #endif #ifdef W3_MPI - GRSTAT(I) = 1 - FLSYNC(I) = .FALSE. - IF ( GRSYNC(J) ) CYCLE LOOP_JJ - ELSE + GRSTAT(I) = 1 + FLSYNC(I) = .FALSE. + IF ( GRSYNC(J) ) CYCLE LOOP_JJ + ELSE #endif #ifdef W3_MPIT - WRITE (MDST,9902) I, GRSTAT(I), & - 'CYCLE BEFORE SYNCING TDATA' + WRITE (MDST,9902) I, GRSTAT(I), & + 'CYCLE BEFORE SYNCING TDATA' #endif #ifdef W3_MPI - FLSYNC(I) = .TRUE. - CYCLE LOOP_JJ - END IF ! IF ( FLSYNC(I) ) + FLSYNC(I) = .TRUE. + CYCLE LOOP_JJ + END IF ! IF ( FLSYNC(I) ) #endif -! + ! #ifdef W3_MPI - END IF ! IF ( GRSTAT(I).EQ.0 .AND. GRSYNC(J) + END IF ! IF ( GRSTAT(I).EQ.0 .AND. GRSYNC(J) #endif -! -! 3. Update data from lower ranked grids ---------------------------- / -! ( GRSTAT = 1 ) -! -! 3.a Skip for initial output only -! - IF ( GRSTAT(I) .EQ. 1 .AND. TSYNC(1,I) .NE. -1 ) THEN + ! + ! 3. Update data from lower ranked grids ---------------------------- / + ! ( GRSTAT = 1 ) + ! + ! 3.a Skip for initial output only + ! + IF ( GRSTAT(I) .EQ. 1 .AND. TSYNC(1,I) .NE. -1 ) THEN #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I), 'FIRST PART' + WRITE (MDST,9002) I, GRSTAT(I), 'FIRST PART' #endif - CALL W3SETW ( I, MDSE, MDST ) - DTTST = DSEC21 ( TIME, TSYNC(:,I) ) - IF ( DTTST .EQ. 0. ) THEN - GRSTAT(I) = 7 + CALL W3SETW ( I, MDSE, MDST ) + DTTST = DSEC21 ( TIME, TSYNC(:,I) ) + IF ( DTTST .EQ. 0. ) THEN + GRSTAT(I) = 7 #ifdef W3_T - WRITE (MDST,9003) I, GRSTAT(I) -#endif - DONE = .TRUE. - END IF - END IF ! IF ( GRSTAT(I) .EQ. 1 .AND. TSYNC(1,I) .NE. -1 ) -! -! 3.b Normal processing -! + WRITE (MDST,9003) I, GRSTAT(I) +#endif + DONE = .TRUE. + END IF + END IF ! IF ( GRSTAT(I) .EQ. 1 .AND. TSYNC(1,I) .NE. -1 ) + ! + ! 3.b Normal processing + ! - IF ( GRSTAT(I) .EQ. 1 ) THEN + IF ( GRSTAT(I) .EQ. 1 ) THEN #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I), 'SECOND PART' + WRITE (MDST,9002) I, GRSTAT(I), 'SECOND PART' #endif #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) -#endif -! -! 3.b.1 Test if data is there -! - FLAGOK = .TRUE. - CALL W3SETW ( I, MDSE, MDST ) - TAUX = TIME - DO JJJ=1, GRDLOW(I,0) - CALL W3SETW ( GRDLOW(I,JJJ), MDSE, MDST ) - FLAGOK = FLAGOK .AND. DSEC21(TAUX,TIME).GT.0. & - .AND. GRSTAT(GRDLOW(I,JJJ)).EQ.5 - END DO - CALL W3SETW ( I, MDSE, MDST ) -! + CALL PRTIME ( PRFT0 ) +#endif + ! + ! 3.b.1 Test if data is there + ! + FLAGOK = .TRUE. + CALL W3SETW ( I, MDSE, MDST ) + TAUX = TIME + DO JJJ=1, GRDLOW(I,0) + CALL W3SETW ( GRDLOW(I,JJJ), MDSE, MDST ) + FLAGOK = FLAGOK .AND. DSEC21(TAUX,TIME).GT.0. & + .AND. GRSTAT(GRDLOW(I,JJJ)).EQ.5 + END DO + CALL W3SETW ( I, MDSE, MDST ) + ! #ifdef W3_T - WRITE (MDST,9004) FLAGOK + WRITE (MDST,9004) FLAGOK #endif -! -! 3.b.1 Get the data -! + ! + ! 3.b.1 Get the data + ! #ifdef W3_MPI - IF ( .NOT.FLAGOK .AND. .NOT.PREGTB(I) ) THEN - IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & - CALL WMIOBG (I,FLAG) - PREGTB(I) = .TRUE. - END IF + IF ( .NOT.FLAGOK .AND. .NOT.PREGTB(I) ) THEN + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOBG (I,FLAG) + PREGTB(I) = .TRUE. + END IF #endif -! - IF ( FLAGOK ) THEN + ! + IF ( FLAGOK ) THEN #ifdef W3_SHRD - CALL WMIOBG ( I, FLAGOK ) + CALL WMIOBG ( I, FLAGOK ) #endif #ifdef W3_MPI - IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & - CALL WMIOBG ( I ) - PREGTB(I) = .FALSE. + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOBG ( I ) + PREGTB(I) = .FALSE. #endif - GRSTAT(I) = 2 - DONE = .TRUE. - END IF ! IF ( FLAGOK ) -! + GRSTAT(I) = 2 + DONE = .TRUE. + END IF ! IF ( FLAGOK ) + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & - 'ST01', I -#endif - END IF ! IF ( GRSTAT(I) .EQ. 1 ) -! -! 4. Update model time step ----------------------------------------- / -! ( GRSTAT = 2 ) -! - IF ( GRSTAT(I) .EQ. 2 ) THEN + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & + 'ST01', I +#endif + END IF ! IF ( GRSTAT(I) .EQ. 1 ) + ! + ! 4. Update model time step ----------------------------------------- / + ! ( GRSTAT = 2 ) + ! + IF ( GRSTAT(I) .EQ. 2 ) THEN #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I), ' ' + WRITE (MDST,9002) I, GRSTAT(I), ' ' #endif #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) -#endif -! -! 4.a Check TMAX and update as necessary ( needs !/MPI synchronizaion ) -! - CALL W3SETW ( I, MDSE, MDST ) - IF ( TMAX(1,I) .EQ. -1 ) THEN - TMAX(:,I) = TIME - DTTST = 0. - ELSE - DTTST = DSEC21(TIME,TMAX(:,I)) - END IF -! - IF ( DTTST .LE. 0 ) THEN - CALL W3SETG ( I, MDSE, MDST ) - DTMAXI = REAL(NINT(DTMAX+DTRES(I)+0.0001)) - DTRES(I)= DTRES(I)+ DTMAX - DTMAXI - IF ( ABS(DTRES(I)) .LT. 0.001 ) DTRES(I) = 0. - TMAX(:,I) = TIME - CALL TICK21 ( TMAX(:,I), DTMAXI ) - TAUX = TMAX(:,I) - IF ( TDATA(1,I) .NE. -1 ) THEN - IF ( DSEC21(TDATA(:,I),TMAX(:,I)) .GT. 0 ) & - TMAX(:,I) = TDATA(:,I) - END IF - IF ( TOUTP(1,I) .NE. -1 ) THEN - IF ( DSEC21(TOUTP(:,I),TMAX(:,I)) .GT. 0 ) & - TMAX(:,I) = TOUTP(:,I) - END IF - IF ( UNIPTS ) THEN - IF ( DSEC21(UPNEXT,TMAX(:,I)) .GT. 0 ) & - TMAX(:,I) = UPNEXT(:) - END IF + CALL PRTIME ( PRFT0 ) +#endif + ! + ! 4.a Check TMAX and update as necessary ( needs !/MPI synchronizaion ) + ! + CALL W3SETW ( I, MDSE, MDST ) + IF ( TMAX(1,I) .EQ. -1 ) THEN + TMAX(:,I) = TIME + DTTST = 0. + ELSE + DTTST = DSEC21(TIME,TMAX(:,I)) + END IF + ! + IF ( DTTST .LE. 0 ) THEN + CALL W3SETG ( I, MDSE, MDST ) + DTMAXI = REAL(NINT(DTMAX+DTRES(I)+0.0001)) + DTRES(I)= DTRES(I)+ DTMAX - DTMAXI + IF ( ABS(DTRES(I)) .LT. 0.001 ) DTRES(I) = 0. + TMAX(:,I) = TIME + CALL TICK21 ( TMAX(:,I), DTMAXI ) + TAUX = TMAX(:,I) + IF ( TDATA(1,I) .NE. -1 ) THEN + IF ( DSEC21(TDATA(:,I),TMAX(:,I)) .GT. 0 ) & + TMAX(:,I) = TDATA(:,I) + END IF + IF ( TOUTP(1,I) .NE. -1 ) THEN + IF ( DSEC21(TOUTP(:,I),TMAX(:,I)) .GT. 0 ) & + TMAX(:,I) = TOUTP(:,I) + END IF + IF ( UNIPTS ) THEN + IF ( DSEC21(UPNEXT,TMAX(:,I)) .GT. 0 ) & + TMAX(:,I) = UPNEXT(:) + END IF #ifdef W3_T - WRITE (MDST,9040) TMAX(:,I), DTRES(I), TAUX, & - TDATA(:,I), TOUTP(:,I), UPNEXT + WRITE (MDST,9040) TMAX(:,I), DTRES(I), TAUX, & + TDATA(:,I), TOUTP(:,I), UPNEXT #endif - DONE = .TRUE. - CYCLE LOOP_JJ + DONE = .TRUE. + CYCLE LOOP_JJ #ifdef W3_T - ELSE - WRITE (MDST,9041) TMAX(:,I) + ELSE + WRITE (MDST,9041) TMAX(:,I) #endif - END IF ! IF ( DTTST .LE. 0 ) -! -! 4.b Lowest ranked grids, minimum of all TMAXes -! + END IF ! IF ( DTTST .LE. 0 ) + ! + ! 4.b Lowest ranked grids, minimum of all TMAXes + ! #ifdef W3_T - WRITE (MDST,9042) GRANK(I) -#endif -! - IF ( GRANK(I) .EQ. 1 ) THEN -! - TAUX = TMAX(:,I) - FLAGOK = .TRUE. -! -! 4.b.1 Check if all grids have reached previous sync point -! - DO II=1, NRGRD - CALL W3SETW ( II, MDSE, MDST ) + WRITE (MDST,9042) GRANK(I) +#endif + ! + IF ( GRANK(I) .EQ. 1 ) THEN + ! + TAUX = TMAX(:,I) + FLAGOK = .TRUE. + ! + ! 4.b.1 Check if all grids have reached previous sync point + ! + DO II=1, NRGRD + CALL W3SETW ( II, MDSE, MDST ) #ifdef W3_SHRD - IF ( TIME(1) .NE. -1 ) THEN + IF ( TIME(1) .NE. -1 ) THEN #endif #ifdef W3_MPI - IF ( TIME(1).NE.-1 .AND. & - MPI_COMM_GRD.NE.MPI_COMM_NULL ) THEN + IF ( TIME(1).NE.-1 .AND. & + MPI_COMM_GRD.NE.MPI_COMM_NULL ) THEN #endif - IF ( DSEC21(TIME,TSYNC(:,0)) .NE. 0 ) THEN - FLAGOK = .FALSE. - EXIT - END IF + IF ( DSEC21(TIME,TSYNC(:,0)) .NE. 0 ) THEN + FLAGOK = .FALSE. + EXIT + END IF #ifdef W3_MPI - END IF ! IF ( TIME(1).NE.-1 .AND. MPI_COMM_GRD.NE.MPI_COMM_NULL ) + END IF ! IF ( TIME(1).NE.-1 .AND. MPI_COMM_GRD.NE.MPI_COMM_NULL ) #endif #ifdef W3_SHRD - END IF ! IF ( TIME(1) .NE. -1 ) THEN -#endif - END DO -! -! 4.b.2 Check availability of data -! - DO II=1, NRGRD - IF ( GRANK(II) .EQ. 1 ) THEN - IF ( TMAX(1,II) .EQ. -1 ) THEN - FLAGOK = .FALSE. - EXIT - ELSE - IF ( DSEC21 (TAUX,TMAX(:,II)) .LT. 0. ) & - TAUX = TMAX(:,II) - END IF - END IF - END DO -! - CALL W3SETW ( I, MDSE, MDST ) - FLAGOK = FLAGOK .AND. DSEC21(TIME,TAUX).GT.0. -! -! 4.b.3 Update TSYNC for all grids -! - IF ( FLAGOK ) THEN -! - TSYNC(:,0) = TAUX - DO_UPT = .TRUE. - DO II=1, NRGRD - IF ( GRANK(II) .EQ. 1 ) THEN - TSYNC(:,II) = TAUX - IF ( GRSTAT(II) .EQ. 2 ) GRSTAT(II) = 3 + END IF ! IF ( TIME(1) .NE. -1 ) THEN +#endif + END DO + ! + ! 4.b.2 Check availability of data + ! + DO II=1, NRGRD + IF ( GRANK(II) .EQ. 1 ) THEN + IF ( TMAX(1,II) .EQ. -1 ) THEN + FLAGOK = .FALSE. + EXIT + ELSE + IF ( DSEC21 (TAUX,TMAX(:,II)) .LT. 0. ) & + TAUX = TMAX(:,II) + END IF + END IF + END DO + ! + CALL W3SETW ( I, MDSE, MDST ) + FLAGOK = FLAGOK .AND. DSEC21(TIME,TAUX).GT.0. + ! + ! 4.b.3 Update TSYNC for all grids + ! + IF ( FLAGOK ) THEN + ! + TSYNC(:,0) = TAUX + DO_UPT = .TRUE. + DO II=1, NRGRD + IF ( GRANK(II) .EQ. 1 ) THEN + TSYNC(:,II) = TAUX + IF ( GRSTAT(II) .EQ. 2 ) GRSTAT(II) = 3 #ifdef W3_T - IF ( GRSTAT(II) .EQ. 3 ) & - WRITE (MDST,9003) II, GRSTAT(II) + IF ( GRSTAT(II) .EQ. 3 ) & + WRITE (MDST,9003) II, GRSTAT(II) #endif - END IF - END DO - DONE = .TRUE. + END IF + END DO + DONE = .TRUE. #ifdef W3_MPRF - CALL PRTIME ( PRFTS ) - WRITE (MDSP,992) PRFTS, PRFTS, & - get_memory(), 'TIME', TSYNC(:,0) + CALL PRTIME ( PRFTS ) + WRITE (MDSP,992) PRFTS, PRFTS, & + get_memory(), 'TIME', TSYNC(:,0) #endif -! -! 4.b.4 Output -! + ! + ! 4.b.4 Output + ! #ifdef W3_T - WRITE (MDST,9043) TSYNC(:,0) - WRITE (MDST,9045) - WRITE (MDST,9046) (II,TSYNC(:,II),II=0,NRGRD) -#endif -! -! 4.b.5 Skip computations so that all grids start processing -! simultaneously. -! + WRITE (MDST,9043) TSYNC(:,0) + WRITE (MDST,9045) + WRITE (MDST,9046) (II,TSYNC(:,II),II=0,NRGRD) +#endif + ! + ! 4.b.5 Skip computations so that all grids start processing + ! simultaneously. + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, & - get_memory(), 'ST02', I + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'ST02', I #endif #ifdef W3_T - IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) -#endif - IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 -! - END IF ! IF ( FLAGOK ) -! -! 4.c Other grids, logical from relations and TMAXes -! - ELSE IF ( TSYNC(1,0) .NE. -1 ) THEN -! - TAUX = TSYNC(:,0) - FLAGOK = .TRUE. -! -! 4.c.1 Check availability of data within group -! Time within group needs to be the same for load balancing. -! - DO JJJ=1, INGRP(J,0) - II = INGRP(J,JJJ) - IF ( TMAX(1,II) .EQ. -1 ) THEN - FLAGOK = .FALSE. - EXIT - ELSE - IF ( DSEC21 (TAUX,TMAX(:,II)) .LT. 0. ) & - TAUX = TMAX(:,II) - END IF - END DO -! -! 4.c.2 Check with dependent lower rank grids ( TSYNC ) -! - DO JJJ=1, GRDLOW(I,0) - II = GRDLOW(I,JJJ) - IF ( TSYNC(1,II) .EQ. -1 ) THEN - FLAGOK = .FALSE. - EXIT - ELSE - IF ( DSEC21 (TAUX,TSYNC(:,II)) .LT. 0. ) & - TAUX = TSYNC(:,II) - END IF - END DO -! -! 4.c.3 Check with dependent higher rank grids ( TSYNC ) -! No check needed -! -! 4.c.4 Final check against grid time -! - CALL W3SETW ( I, MDSE, MDST ) - FLAGOK = FLAGOK .AND. DSEC21(TIME,TAUX).GT.0. -! -! 4.c.5 Update TSYNC throughout group -! - IF ( FLAGOK ) THEN -! - DO JJJ=1, INGRP(J,0) - II = INGRP(J,JJJ) - TSYNC(:,II) = TAUX - IF ( GRSTAT(II) .EQ. 2 ) GRSTAT(II) = 3 + IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) +#endif + IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 + ! + END IF ! IF ( FLAGOK ) + ! + ! 4.c Other grids, logical from relations and TMAXes + ! + ELSE IF ( TSYNC(1,0) .NE. -1 ) THEN + ! + TAUX = TSYNC(:,0) + FLAGOK = .TRUE. + ! + ! 4.c.1 Check availability of data within group + ! Time within group needs to be the same for load balancing. + ! + DO JJJ=1, INGRP(J,0) + II = INGRP(J,JJJ) + IF ( TMAX(1,II) .EQ. -1 ) THEN + FLAGOK = .FALSE. + EXIT + ELSE + IF ( DSEC21 (TAUX,TMAX(:,II)) .LT. 0. ) & + TAUX = TMAX(:,II) + END IF + END DO + ! + ! 4.c.2 Check with dependent lower rank grids ( TSYNC ) + ! + DO JJJ=1, GRDLOW(I,0) + II = GRDLOW(I,JJJ) + IF ( TSYNC(1,II) .EQ. -1 ) THEN + FLAGOK = .FALSE. + EXIT + ELSE + IF ( DSEC21 (TAUX,TSYNC(:,II)) .LT. 0. ) & + TAUX = TSYNC(:,II) + END IF + END DO + ! + ! 4.c.3 Check with dependent higher rank grids ( TSYNC ) + ! No check needed + ! + ! 4.c.4 Final check against grid time + ! + CALL W3SETW ( I, MDSE, MDST ) + FLAGOK = FLAGOK .AND. DSEC21(TIME,TAUX).GT.0. + ! + ! 4.c.5 Update TSYNC throughout group + ! + IF ( FLAGOK ) THEN + ! + DO JJJ=1, INGRP(J,0) + II = INGRP(J,JJJ) + TSYNC(:,II) = TAUX + IF ( GRSTAT(II) .EQ. 2 ) GRSTAT(II) = 3 #ifdef W3_T - IF ( GRSTAT(II) .EQ. 3 ) & - WRITE (MDST,9003) II, GRSTAT(II) + IF ( GRSTAT(II) .EQ. 3 ) & + WRITE (MDST,9003) II, GRSTAT(II) #endif - END DO - DONE = .TRUE. -! + END DO + DONE = .TRUE. + ! #ifdef W3_T - WRITE (MDST,9044) TSYNC(:,I), TAUX - WRITE (MDST,9045) - WRITE (MDST,9046) (II,TSYNC(:,II),II=0,NRGRD) + WRITE (MDST,9044) TSYNC(:,I), TAUX + WRITE (MDST,9045) + WRITE (MDST,9046) (II,TSYNC(:,II),II=0,NRGRD) #endif -! -! 4.c.6 Skip computations so that all grids in group are advanced -! simultaneously. + ! + ! 4.c.6 Skip computations so that all grids in group are advanced + ! simultaneously. #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, & - get_memory(), 'ST02', I + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'ST02', I #endif #ifdef W3_T - IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) -#endif - IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 -! - END IF ! IF ( FLAGOK ) -! - END IF ! 4.b IF ( GRANK(I) .EQ. 1 ) -! - END IF ! 4. IF ( GRSTAT(I) .EQ. 2 ) -! -! 5. Run the wave model --------------------------------------------- / -! ( GRSTAT = 3 ) w3xdatmd data structures set in W3WAVE -! -! 5.a Run model -! + IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) +#endif + IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 + ! + END IF ! IF ( FLAGOK ) + ! + END IF ! 4.b IF ( GRANK(I) .EQ. 1 ) + ! + END IF ! 4. IF ( GRSTAT(I) .EQ. 2 ) + ! + ! 5. Run the wave model --------------------------------------------- / + ! ( GRSTAT = 3 ) w3xdatmd data structures set in W3WAVE + ! + ! 5.a Run model + ! #ifdef W3_SHRD - IF ( GRSTAT(I) .EQ. 3 ) THEN + IF ( GRSTAT(I) .EQ. 3 ) THEN #endif -! + ! #ifdef W3_MPI IF ( GRSTAT(I).EQ.3 .AND. & MPI_COMM_GRD .EQ. MPI_COMM_NULL ) THEN - CALL W3SETW ( I, MDSE, MDST ) - TIME = TSYNC(:,I) - GRSTAT(I) = 4 - DONE = .TRUE. - ELSE IF ( GRSTAT(I).EQ.3 .AND. & - MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN -#endif -! + CALL W3SETW ( I, MDSE, MDST ) + TIME = TSYNC(:,I) + GRSTAT(I) = 4 + DONE = .TRUE. + ELSE IF ( GRSTAT(I).EQ.3 .AND. & + MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN +#endif + ! #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I), 'RUNNING MODEL' + WRITE (MDST,9002) I, GRSTAT(I), 'RUNNING MODEL' #endif #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) -#endif -! - CALL WMSETM ( I, MDSE, MDST ) - CALL W3WAVE ( I, DUMMY2, TSYNC(:,I), .FALSE., .TRUE. ) - IF ( FLLSTL ) INFLAGS1(1) = .FALSE. - IF ( FLLSTI ) INFLAGS1(4) = .FALSE. - IF ( FLLSTR ) INFLAGS1(6) = .FALSE. -! -! 5.b Stage data for grids with equal rank -! -#ifdef W3_MPI - CALL WMIOEF ( I ) -#endif - CALL WMIOES ( I ) -! -! 5.c Finish up -! - GRSTAT(I) = 4 - DONE = .TRUE. -! + CALL PRTIME ( PRFT0 ) +#endif + ! + CALL WMSETM ( I, MDSE, MDST ) + CALL W3WAVE ( I, DUMMY2, TSYNC(:,I), .FALSE., .TRUE. ) + IF ( FLLSTL ) INFLAGS1(1) = .FALSE. + IF ( FLLSTI ) INFLAGS1(4) = .FALSE. + IF ( FLLSTR ) INFLAGS1(6) = .FALSE. + ! + ! 5.b Stage data for grids with equal rank + ! +#ifdef W3_MPI + CALL WMIOEF ( I ) +#endif + CALL WMIOES ( I ) + ! + ! 5.c Finish up + ! + GRSTAT(I) = 4 + DONE = .TRUE. + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & - 'ST03', I + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & + 'ST03', I #endif -! + ! #ifdef W3_MPI - END IF ! IF ( GRSTAT(I).EQ.3 .AND. MPI_COMM_GRD .EQ. MPI_COMM_NULL ) + END IF ! IF ( GRSTAT(I).EQ.3 .AND. MPI_COMM_GRD .EQ. MPI_COMM_NULL ) #endif #ifdef W3_SHRD - END IF ! IF ( GRSTAT(I) .EQ. 3 ) -#endif -! -! 6. Reconcile grids with same rank --------------------------------- / -! and stage data transfer to higher and lower ranked grids. -! ( GRSTAT = 4 ) -! - IF ( GRSTAT(I) .EQ. 4 ) THEN + END IF ! IF ( GRSTAT(I) .EQ. 3 ) +#endif + ! + ! 6. Reconcile grids with same rank --------------------------------- / + ! and stage data transfer to higher and lower ranked grids. + ! ( GRSTAT = 4 ) + ! + IF ( GRSTAT(I) .EQ. 4 ) THEN #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) -#endif -! -! 6.a Test against times and statuses of dependent grids -! Note: This is done per GROUP, not per local equal grid dependence -! Therefore, it is essential that sync times per group are -! equal (4.c.1) and that all equal grid dependences are a -! subset of groups (WMGEQL 5.d) -! + CALL PRTIME ( PRFT0 ) +#endif + ! + ! 6.a Test against times and statuses of dependent grids + ! Note: This is done per GROUP, not per local equal grid dependence + ! Therefore, it is essential that sync times per group are + ! equal (4.c.1) and that all equal grid dependences are a + ! subset of groups (WMGEQL 5.d) + ! #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I), 'FIRST PART' - WRITE (MDST,9005) FLEQOK(I) -#endif -! -! 6.a.1 Check if sync point is reached -! - IF ( .NOT. FLEQOK(I) ) THEN -! - FLAGOK = .TRUE. - CALL W3SETW ( I, MDSE, MDST ) - TAUX = TIME - DO JJJ=1, INGRP(J,0) - CALL W3SETW ( INGRP(J,JJJ), MDSE, MDST ) - FLAGOK = FLAGOK .AND. DSEC21(TAUX,TIME).EQ.0. & - .AND. GRSTAT(INGRP(J,JJJ)).EQ.4 - END DO - CALL W3SETW ( I, MDSE, MDST ) + WRITE (MDST,9002) I, GRSTAT(I), 'FIRST PART' + WRITE (MDST,9005) FLEQOK(I) +#endif + ! + ! 6.a.1 Check if sync point is reached + ! + IF ( .NOT. FLEQOK(I) ) THEN + ! + FLAGOK = .TRUE. + CALL W3SETW ( I, MDSE, MDST ) + TAUX = TIME + DO JJJ=1, INGRP(J,0) + CALL W3SETW ( INGRP(J,JJJ), MDSE, MDST ) + FLAGOK = FLAGOK .AND. DSEC21(TAUX,TIME).EQ.0. & + .AND. GRSTAT(INGRP(J,JJJ)).EQ.4 + END DO + CALL W3SETW ( I, MDSE, MDST ) #ifdef W3_T - WRITE (MDST,9004) FLAGOK -#endif -! -! 6.a.2 Point reached, set flag for all in group and cycle -! - IF ( FLAGOK ) THEN - DO JJJ=1, INGRP(J,0) - FLEQOK(INGRP(J,JJJ)) = .TRUE. + WRITE (MDST,9004) FLAGOK +#endif + ! + ! 6.a.2 Point reached, set flag for all in group and cycle + ! + IF ( FLAGOK ) THEN + DO JJJ=1, INGRP(J,0) + FLEQOK(INGRP(J,JJJ)) = .TRUE. #ifdef W3_T - WRITE (MDST,9061) INGRP(J,JJJ), & - FLEQOK(INGRP(J,JJJ)) + WRITE (MDST,9061) INGRP(J,JJJ), & + FLEQOK(INGRP(J,JJJ)) #endif - END DO - DONE = .TRUE. + END DO + DONE = .TRUE. #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, & - get_memory(), 'ST04', I + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'ST04', I #endif -! + ! #ifdef W3_T - IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) -#endif - IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 - END IF ! IF ( FLAGOK ) -! - END IF ! IF ( .NOT. FLEQOK(I) ) -! -! 6.b Call gathering routine, reset FLEQOK and cycle -! -#ifdef W3_MPI - IF ( .NOT.FLEQOK(I) .AND. .NOT.PREGTE(I) ) THEN - IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & - CALL WMIOEG (I,FLAG) - PREGTE(I) = .TRUE. - END IF -#endif -! - IF ( FLEQOK(I) ) THEN + IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) +#endif + IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 + END IF ! IF ( FLAGOK ) + ! + END IF ! IF ( .NOT. FLEQOK(I) ) + ! + ! 6.b Call gathering routine, reset FLEQOK and cycle + ! +#ifdef W3_MPI + IF ( .NOT.FLEQOK(I) .AND. .NOT.PREGTE(I) ) THEN + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOEG (I,FLAG) + PREGTE(I) = .TRUE. + END IF +#endif + ! + IF ( FLEQOK(I) ) THEN #ifdef W3_SHRD - CALL WMIOEG ( I ) + CALL WMIOEG ( I ) #endif #ifdef W3_MPI - IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & - CALL WMIOEG ( I ) - PREGTE(I) = .FALSE. + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOEG ( I ) + PREGTE(I) = .FALSE. #endif - GRSTAT(I) = 5 - FLEQOK(I) = .FALSE. - DONE = .TRUE. - END IF -! -! 6.c Stage data -! - IF ( GRSTAT(I) .EQ. 5 ) THEN -! + GRSTAT(I) = 5 + FLEQOK(I) = .FALSE. + DONE = .TRUE. + END IF + ! + ! 6.c Stage data + ! + IF ( GRSTAT(I) .EQ. 5 ) THEN + ! #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I)-1, 'SECOND PART' + WRITE (MDST,9002) I, GRSTAT(I)-1, 'SECOND PART' #endif -! + ! #ifdef W3_SHRD - CALL WMIOBS ( I ) + CALL WMIOBS ( I ) #endif -! + ! #ifdef W3_MPI - IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN - CALL WMIOBF ( I ) - CALL WMIOBS ( I ) - END IF + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN + CALL WMIOBF ( I ) + CALL WMIOBS ( I ) + END IF #endif -! + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, & - get_memory(), 'ST04', I -#endif - CYCLE LOOP_JJ -! - END IF ! IF ( GRSTAT(I) .EQ. 5 ) -! + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'ST04', I +#endif + CYCLE LOOP_JJ + ! + END IF ! IF ( GRSTAT(I) .EQ. 5 ) + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, & - get_memory(), 'ST04', I -#endif -! - END IF ! 6. IF ( GRSTAT(I) .EQ. 4 ) -! -! 7. Reconcile with higher ranked grids ----------------------------- / -! ( GRSTAT = 5 ) -! -! This needs to be a little more complicated than with boundary -! data to assure proper logic in cases where data providing -! data does not get data back (e.g., as for the boundary grid -! in mww3_test_04) -! - IF ( GRSTAT(I) .EQ. 5 ) THEN + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'ST04', I +#endif + ! + END IF ! 6. IF ( GRSTAT(I) .EQ. 4 ) + ! + ! 7. Reconcile with higher ranked grids ----------------------------- / + ! ( GRSTAT = 5 ) + ! + ! This needs to be a little more complicated than with boundary + ! data to assure proper logic in cases where data providing + ! data does not get data back (e.g., as for the boundary grid + ! in mww3_test_04) + ! + IF ( GRSTAT(I) .EQ. 5 ) THEN #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) + CALL PRTIME ( PRFT0 ) #endif #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I), ' ' -#endif -! -! 7.a Test against times and statuses of dependent grids -! - IF ( GRDHGH(I,0) .EQ. 0 ) THEN - GRSTAT(I) = 6 - DONE = .TRUE. - ELSE -! - FLAGOK = .TRUE. - CALL W3SETW ( I, MDSE, MDST ) - TAUX = TIME - DO JJJ=1, GRDHGH(I,0) - CALL W3SETW ( GRDHGH(I,JJJ), MDSE, MDST ) - IF ( .NOT. ( DSEC21(TAUX,TIME).EQ.0. .AND. & - ( GRSTAT(GRDHGH(I,JJJ)).GE.7 .OR. & - GRSTAT(GRDHGH(I,JJJ)).LE.2 ) ) ) & - FLAGOK = .FALSE. - END DO - CALL W3SETW ( I, MDSE, MDST ) -! + WRITE (MDST,9002) I, GRSTAT(I), ' ' +#endif + ! + ! 7.a Test against times and statuses of dependent grids + ! + IF ( GRDHGH(I,0) .EQ. 0 ) THEN + GRSTAT(I) = 6 + DONE = .TRUE. + ELSE + ! + FLAGOK = .TRUE. + CALL W3SETW ( I, MDSE, MDST ) + TAUX = TIME + DO JJJ=1, GRDHGH(I,0) + CALL W3SETW ( GRDHGH(I,JJJ), MDSE, MDST ) + IF ( .NOT. ( DSEC21(TAUX,TIME).EQ.0. .AND. & + ( GRSTAT(GRDHGH(I,JJJ)).GE.7 .OR. & + GRSTAT(GRDHGH(I,JJJ)).LE.2 ) ) ) & + FLAGOK = .FALSE. + END DO + CALL W3SETW ( I, MDSE, MDST ) + ! #ifdef W3_T - WRITE (MDST,9004) FLAGOK + WRITE (MDST,9004) FLAGOK #endif -! -! 7.b Call gathering routine -! + ! + ! 7.b Call gathering routine + ! #ifdef W3_MPI - IF ( .NOT.FLAGOK .AND. .NOT.PREGTH(I) ) THEN - IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & - CALL WMIOHG ( I, FLAG ) - PREGTH(I) = .TRUE. - END IF + IF ( .NOT.FLAGOK .AND. .NOT.PREGTH(I) ) THEN + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOHG ( I, FLAG ) + PREGTH(I) = .TRUE. + END IF #endif -! - IF ( FLAGOK ) THEN + ! + IF ( FLAGOK ) THEN #ifdef W3_SHRD - CALL WMIOHG ( I, FLAGOK ) + CALL WMIOHG ( I, FLAGOK ) #endif #ifdef W3_MPI - IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & - CALL WMIOHG ( I ) - PREGTH(I) = .FALSE. + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOHG ( I ) + PREGTH(I) = .FALSE. #endif - GRSTAT(I) = 6 - DONE = .TRUE. - END IF ! IF ( FLAGOK ) -! - END IF ! IF ( GRDHGH(I,0) .EQ. 0 ) + GRSTAT(I) = 6 + DONE = .TRUE. + END IF ! IF ( FLAGOK ) + ! + END IF ! IF ( GRDHGH(I,0) .EQ. 0 ) -! -! 7.c Stage data -! + ! + ! 7.c Stage data + ! #ifdef W3_SHRD - IF ( GRSTAT(I) .EQ. 6 ) CALL WMIOHS ( I ) + IF ( GRSTAT(I) .EQ. 6 ) CALL WMIOHS ( I ) #endif -! + ! #ifdef W3_MPI - IF ( GRSTAT(I) .EQ. 6 .AND. & - MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN - CALL WMIOHF ( I ) - CALL WMIOHS ( I ) - END IF + IF ( GRSTAT(I) .EQ. 6 .AND. & + MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN + CALL WMIOHF ( I ) + CALL WMIOHS ( I ) + END IF #endif -! + ! #ifdef W3_T - IF (GRSTAT(I).EQ.6) WRITE(MDST,9003) I, GRSTAT(I) + IF (GRSTAT(I).EQ.6) WRITE(MDST,9003) I, GRSTAT(I) #endif #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & - 'ST05', I -#endif - END IF ! 7. IF ( GRSTAT(I) .EQ. 5 ) -! -! 8. Perform data assimmilation ------------------------------------- / -! ( GRSTAT = 6 ) Placeholder only ..... -! - IF ( GRSTAT(I) .EQ. 6 ) THEN + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & + 'ST05', I +#endif + END IF ! 7. IF ( GRSTAT(I) .EQ. 5 ) + ! + ! 8. Perform data assimmilation ------------------------------------- / + ! ( GRSTAT = 6 ) Placeholder only ..... + ! + IF ( GRSTAT(I) .EQ. 6 ) THEN #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) + CALL PRTIME ( PRFT0 ) #endif #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I), ' ' + WRITE (MDST,9002) I, GRSTAT(I), ' ' #endif - GRSTAT(I) = 7 + GRSTAT(I) = 7 #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & - 'ST06', I -#endif - DONE = .TRUE. - END IF ! IF ( GRSTAT(I) .EQ. 6 ) -! -! 9. Perform output ------------------------------------------------- / -! ( GRSTAT = 7 ) w3xdatmd data structures set in W3WAVE -! -! -! 9.a Check times and finish step if no output to be made -! + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & + 'ST06', I +#endif + DONE = .TRUE. + END IF ! IF ( GRSTAT(I) .EQ. 6 ) + ! + ! 9. Perform output ------------------------------------------------- / + ! ( GRSTAT = 7 ) w3xdatmd data structures set in W3WAVE + ! + ! + ! 9.a Check times and finish step if no output to be made + ! #ifdef W3_SHRD - IF ( GRSTAT(I) .EQ. 7 ) THEN + IF ( GRSTAT(I) .EQ. 7 ) THEN #endif #ifdef W3_MPI IF ( GRSTAT(I).EQ.7 .AND. .NOT.FLSYNC(I) ) THEN #endif -! + ! #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I), ' ' + WRITE (MDST,9002) I, GRSTAT(I), ' ' #endif -! - IF ( TOUTP(1,I) .EQ. -1 ) THEN - DTTST = 1. - ELSE - CALL W3SETW ( I, MDSE, MDST ) - DTTST = DSEC21 ( TIME , TOUTP(:,I) ) - END IF + ! + IF ( TOUTP(1,I) .EQ. -1 ) THEN + DTTST = 1. + ELSE + CALL W3SETW ( I, MDSE, MDST ) + DTTST = DSEC21 ( TIME , TOUTP(:,I) ) + END IF #ifdef W3_T - WRITE (MDST,9090) DTTST -#endif - FLG_O1 = DTTST .EQ. 0. -! - IF ( UNIPTS ) THEN - CALL W3SETW ( I, MDSE, MDST ) - DTTST = DSEC21 ( TIME , UPNEXT ) - FLG_O2 = DTTST .EQ. 0. - ELSE - FLG_O2 = .FALSE. - END IF -! - IF ( .NOT.FLG_O1 .AND. .NOT.FLG_O2 ) THEN - GRSTAT(I) = 8 + WRITE (MDST,9090) DTTST +#endif + FLG_O1 = DTTST .EQ. 0. + ! + IF ( UNIPTS ) THEN + CALL W3SETW ( I, MDSE, MDST ) + DTTST = DSEC21 ( TIME , UPNEXT ) + FLG_O2 = DTTST .EQ. 0. + ELSE + FLG_O2 = .FALSE. + END IF + ! + IF ( .NOT.FLG_O1 .AND. .NOT.FLG_O2 ) THEN + GRSTAT(I) = 8 #ifdef W3_T - WRITE (MDST,9003) I, GRSTAT(I) + WRITE (MDST,9003) I, GRSTAT(I) #endif - DONE = .TRUE. - END IF -! + DONE = .TRUE. + END IF + ! #ifdef W3_MPI - END IF ! IF ( GRSTAT(I).EQ.7 .AND. .NOT.FLSYNC(I) ) + END IF ! IF ( GRSTAT(I).EQ.7 .AND. .NOT.FLSYNC(I) ) #endif #ifdef W3_SHRD - END IF ! IF ( GRSTAT(I) .EQ. 7 ) + END IF ! IF ( GRSTAT(I) .EQ. 7 ) #endif -! -! 9.b Perform output -! - IF ( GRSTAT(I) .EQ. 7 ) THEN + ! + ! 9.b Perform output + ! + IF ( GRSTAT(I) .EQ. 7 ) THEN #ifdef W3_MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN #endif -! + ! #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) + CALL PRTIME ( PRFT0 ) #endif -! - IF ( FLG_O1 ) THEN - CALL W3SETG ( I, MDSE, MDST ) - CALL WMSETM ( I, MDSE, MDST ) - IF ( FLGHG1 .AND. .NOT.FLGHG2 .AND. & - GRDHGH(I,0).GT.0 ) THEN - MAPST2 = MAPST2 - 8*MAPMSK - MAPSTA = ABS(MAPSTA) - DO IX=1, NX - DO IY=1, NY - IF ( MAPST2(IY,IX) .GT. 0 ) & - MAPSTA(IY,IX) = - MAPSTA(IY,IX) - END DO - END DO -! - END IF -! - CALL W3WAVE ( I, DUMMY2, TSYNC(:,I), .FALSE. ) -! - IF ( FLGHG1 .AND. .NOT.FLGHG2 .AND. & - GRDHGH(I,0).GT.0 ) THEN - MAPST2 = MAPST2 + 8*MAPMSK - MAPSTA = ABS(MAPSTA) - DO IX=1, NX - DO IY=1, NY - IF ( MAPST2(IY,IX) .GT. 0 ) & - MAPSTA(IY,IX) = - MAPSTA(IY,IX) - END DO - END DO - END IF -! - IF ( FLLSTL ) INFLAGS1(1) = .FALSE. - IF ( FLLSTI ) INFLAGS1(4) = .FALSE. - IF ( FLLSTR ) INFLAGS1(6) = .FALSE. -! -! 9.c Update TOUPT -! - TOUTP(1,I) = -1 - TOUTP(2,I) = 0 -! - DO JO=1, NOTYPE - IF ( .NOT.FLOUT(JO) ) CYCLE - IF ( TOUTP(1,I) .EQ. -1 ) THEN - TOUTP(:,I) = TONEXT(:,JO) - ELSE - DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) - IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) - ENDIF - END DO -! CHECKPOINT - JO=8 - IF ( .NOT.FLOUT(JO) ) CYCLE - IF ( TOUTP(1,I) .EQ. -1 ) THEN - TOUTP(:,I) = TONEXT(:,JO) - ELSE - DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) - IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) - ENDIF -! END CHECKPOINT -! + ! + IF ( FLG_O1 ) THEN + CALL W3SETG ( I, MDSE, MDST ) + CALL WMSETM ( I, MDSE, MDST ) + IF ( FLGHG1 .AND. .NOT.FLGHG2 .AND. & + GRDHGH(I,0).GT.0 ) THEN + MAPST2 = MAPST2 - 8*MAPMSK + MAPSTA = ABS(MAPSTA) + DO IX=1, NX + DO IY=1, NY + IF ( MAPST2(IY,IX) .GT. 0 ) & + MAPSTA(IY,IX) = - MAPSTA(IY,IX) + END DO + END DO + ! + END IF + ! + CALL W3WAVE ( I, DUMMY2, TSYNC(:,I), .FALSE. ) + ! + IF ( FLGHG1 .AND. .NOT.FLGHG2 .AND. & + GRDHGH(I,0).GT.0 ) THEN + MAPST2 = MAPST2 + 8*MAPMSK + MAPSTA = ABS(MAPSTA) + DO IX=1, NX + DO IY=1, NY + IF ( MAPST2(IY,IX) .GT. 0 ) & + MAPSTA(IY,IX) = - MAPSTA(IY,IX) + END DO + END DO + END IF + ! + IF ( FLLSTL ) INFLAGS1(1) = .FALSE. + IF ( FLLSTI ) INFLAGS1(4) = .FALSE. + IF ( FLLSTR ) INFLAGS1(6) = .FALSE. + ! + ! 9.c Update TOUPT + ! + TOUTP(1,I) = -1 + TOUTP(2,I) = 0 + ! + DO JO=1, NOTYPE + IF ( .NOT.FLOUT(JO) ) CYCLE + IF ( TOUTP(1,I) .EQ. -1 ) THEN + TOUTP(:,I) = TONEXT(:,JO) + ELSE + DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) + IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) + ENDIF + END DO + ! CHECKPOINT + JO=8 + IF ( .NOT.FLOUT(JO) ) CYCLE + IF ( TOUTP(1,I) .EQ. -1 ) THEN + TOUTP(:,I) = TONEXT(:,JO) + ELSE + DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) + IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) + ENDIF + ! END CHECKPOINT + ! #ifdef W3_T - WRITE (MDST,9091) TOUTP(:,I) + WRITE (MDST,9091) TOUTP(:,I) #endif -! - END IF ! IF ( FLG_O1 ) + ! + END IF ! IF ( FLG_O1 ) -! -! 9.d Process unified point output for selected grid -! - IF ( UNIPTS ) THEN - IF ( FLG_O2 ) THEN - CALL W3SETO ( I, MDSE, MDST ) -! -#ifdef W3_MPI - IF ( NRQPO.NE.0 ) CALL MPI_STARTALL & - ( NRQPO, IRQPO1, IERR_MPI ) -#endif -! - IF ( NOPTS.NE.0 .AND. IAPROC.EQ.NAPPNT ) THEN - CALL W3SETG ( I, MDSE, MDST ) - CALL W3SETA ( I, MDSE, MDST ) - CALL W3IOPE ( VA ) - END IF -! -#ifdef W3_MPI - IF ( NRQPO .NE. 0 ) THEN - ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQPO) ) - CALL MPI_WAITALL & - ( NRQPO, IRQPO1, STATUS, IERR_MPI ) - DEALLOCATE ( STATUS ) - END IF -#endif -! + ! + ! 9.d Process unified point output for selected grid + ! + IF ( UNIPTS ) THEN + IF ( FLG_O2 ) THEN + CALL W3SETO ( I, MDSE, MDST ) + ! +#ifdef W3_MPI + IF ( NRQPO.NE.0 ) CALL MPI_STARTALL & + ( NRQPO, IRQPO1, IERR_MPI ) +#endif + ! + IF ( NOPTS.NE.0 .AND. IAPROC.EQ.NAPPNT ) THEN + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETA ( I, MDSE, MDST ) + CALL W3IOPE ( VA ) + END IF + ! +#ifdef W3_MPI + IF ( NRQPO .NE. 0 ) THEN + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQPO) ) + CALL MPI_WAITALL & + ( NRQPO, IRQPO1, STATUS, IERR_MPI ) + DEALLOCATE ( STATUS ) + END IF +#endif + ! #ifdef W3_T - WRITE (MDST,9092) NOPTS + WRITE (MDST,9092) NOPTS #endif -! - END IF ! IF ( FLG_O2 ) -! - END IF ! IF ( UNIPTS ) -! + ! + END IF ! IF ( FLG_O2 ) + ! + END IF ! IF ( UNIPTS ) + ! #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN,get_memory(), & - 'ST07', I + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN,get_memory(), & + 'ST07', I #endif -! -! 9.e Update TOUPT outside communicator -! + ! + ! 9.e Update TOUPT outside communicator + ! #ifdef W3_MPI - ELSE IF ( FLG_O1 ) THEN + ELSE IF ( FLG_O1 ) THEN #endif -! + ! #ifdef W3_MPI - CALL W3SETO ( I, MDSE, MDST ) - CALL W3SETW ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + CALL W3SETW ( I, MDSE, MDST ) #endif -! + ! #ifdef W3_MPI - TIME = TOUTP(:,I) - TOUTP(1,I) = -1 - TOUTP(2,I) = 0 + TIME = TOUTP(:,I) + TOUTP(1,I) = -1 + TOUTP(2,I) = 0 #endif -! + ! #ifdef W3_MPI - DO JO=1, NOTYPE + DO JO=1, NOTYPE #endif -! -#ifdef W3_MPI - IF ( FLOUT(JO) ) THEN - DO - DTTST = DSEC21 ( TIME, TONEXT(:,JO) ) - IF ( DTTST .LE. 0. ) THEN - CALL TICK21 ( TONEXT(:,JO), DTOUT(JO) ) - DTTST = DSEC21 ( TONEXT(:,JO), TOLAST(:,JO) ) - IF ( DTTST .LT. 0. ) THEN - FLOUT(JO) = .FALSE. - EXIT - END IF - ELSE - EXIT - END IF - END DO - END IF ! IF ( FLOUT(JO) ) -#endif -! + ! #ifdef W3_MPI - IF ( .NOT.FLOUT(JO) ) CYCLE - IF ( TOUTP(1,I) .EQ. -1 ) THEN - TOUTP(:,I) = TONEXT(:,JO) + IF ( FLOUT(JO) ) THEN + DO + DTTST = DSEC21 ( TIME, TONEXT(:,JO) ) + IF ( DTTST .LE. 0. ) THEN + CALL TICK21 ( TONEXT(:,JO), DTOUT(JO) ) + DTTST = DSEC21 ( TONEXT(:,JO), TOLAST(:,JO) ) + IF ( DTTST .LT. 0. ) THEN + FLOUT(JO) = .FALSE. + EXIT + END IF ELSE - DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) - IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) - ENDIF -#endif -! -#ifdef W3_MPI - END DO ! DO JO=1, NOTYPE + EXIT + END IF + END DO + END IF ! IF ( FLOUT(JO) ) #endif -! -! Checkpoint -! + ! #ifdef W3_MPI - JO=8 + IF ( .NOT.FLOUT(JO) ) CYCLE + IF ( TOUTP(1,I) .EQ. -1 ) THEN + TOUTP(:,I) = TONEXT(:,JO) + ELSE + DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) + IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) + ENDIF +#endif + ! +#ifdef W3_MPI + END DO ! DO JO=1, NOTYPE +#endif + ! + ! Checkpoint + ! +#ifdef W3_MPI + JO=8 +#endif + ! +#ifdef W3_MPI + IF ( FLOUT(JO) ) THEN + DO + DTTST = DSEC21 ( TIME, TONEXT(:,JO) ) + IF ( DTTST .LE. 0. ) THEN + CALL TICK21 ( TONEXT(:,JO), DTOUT(JO) ) + DTTST = DSEC21 ( TONEXT(:,JO), TOLAST(:,JO) ) + IF ( DTTST .LT. 0. ) THEN + FLOUT(JO) = .FALSE. + EXIT + END IF + ELSE + EXIT + END IF + END DO + END IF ! IF ( FLOUT(JO) ) #endif -! -#ifdef W3_MPI - IF ( FLOUT(JO) ) THEN - DO - DTTST = DSEC21 ( TIME, TONEXT(:,JO) ) - IF ( DTTST .LE. 0. ) THEN - CALL TICK21 ( TONEXT(:,JO), DTOUT(JO) ) - DTTST = DSEC21 ( TONEXT(:,JO), TOLAST(:,JO) ) - IF ( DTTST .LT. 0. ) THEN - FLOUT(JO) = .FALSE. - EXIT - END IF - ELSE - EXIT - END IF - END DO - END IF ! IF ( FLOUT(JO) ) -#endif -! + ! #ifdef W3_MPI - IF ( .NOT.FLOUT(JO) ) CYCLE - IF ( TOUTP(1,I) .EQ. -1 ) THEN - TOUTP(:,I) = TONEXT(:,JO) - ELSE - DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) - IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) - ENDIF + IF ( .NOT.FLOUT(JO) ) CYCLE + IF ( TOUTP(1,I) .EQ. -1 ) THEN + TOUTP(:,I) = TONEXT(:,JO) + ELSE + DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) + IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) + ENDIF #endif -! + ! -! End Checkpoint + ! End Checkpoint #ifdef W3_MPIT - WRITE (MDST,9991) TOUTP(:,I) -#endif -#ifdef W3_MPI - END IF ! 9.b IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) -#endif -! -! 9.f Finish up -! - GRSTAT(I) = 8 - DONE = .TRUE. -! - END IF ! 9.b IF ( GRSTAT(I) .EQ. 7 ) -! -! 10. Go to next time step ------------------------------------------- / -! ( GRSTAT = 8 ) ( 9 added for diagnostic output only ... ) -! ( Unified point output and synchronization added ) -! - IF ( GRSTAT(I) .EQ. 8 ) THEN -! + WRITE (MDST,9991) TOUTP(:,I) +#endif +#ifdef W3_MPI + END IF ! 9.b IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) +#endif + ! + ! 9.f Finish up + ! + GRSTAT(I) = 8 + DONE = .TRUE. + ! + END IF ! 9.b IF ( GRSTAT(I) .EQ. 7 ) + ! + ! 10. Go to next time step ------------------------------------------- / + ! ( GRSTAT = 8 ) ( 9 added for diagnostic output only ... ) + ! ( Unified point output and synchronization added ) + ! + IF ( GRSTAT(I) .EQ. 8 ) THEN + ! #ifdef W3_T - WRITE (MDST,9002) I, GRSTAT(I), ' ' -#endif -! -! 10.a Processing unified point output -! - IF ( UNIPTS .AND. DO_UPT ) THEN - CALL W3SETW ( I, MDSE, MDST ) - FLAGOK = DSEC21 ( TIME, UPNEXT ) .EQ. 0. + WRITE (MDST,9002) I, GRSTAT(I), ' ' +#endif + ! + ! 10.a Processing unified point output + ! + IF ( UNIPTS .AND. DO_UPT ) THEN + CALL W3SETW ( I, MDSE, MDST ) + FLAGOK = DSEC21 ( TIME, UPNEXT ) .EQ. 0. #ifdef W3_T - WRITE (MDST,9095) FLAGOK -#endif - ELSE - FLAGOK = .FALSE. - END IF -! - IF ( FLAGOK ) THEN -! - DO II=1, NRGRD - CALL W3SETW ( II, MDSE, MDST ) - FLAGOK = FLAGOK .AND. GRSTAT(II).EQ.8 .AND. & - DSEC21(TIME,UPNEXT).EQ.0. - END DO + WRITE (MDST,9095) FLAGOK +#endif + ELSE + FLAGOK = .FALSE. + END IF + ! + IF ( FLAGOK ) THEN + ! + DO II=1, NRGRD + CALL W3SETW ( II, MDSE, MDST ) + FLAGOK = FLAGOK .AND. GRSTAT(II).EQ.8 .AND. & + DSEC21(TIME,UPNEXT).EQ.0. + END DO #ifdef W3_T - WRITE (MDST,9096) FLAGOK + WRITE (MDST,9096) FLAGOK #endif -! - IF ( FLAGOK ) THEN -! + ! + IF ( FLAGOK ) THEN + ! #ifdef W3_MPRF - CALL PRTIME ( PRFT0 ) -#endif - CALL WMIOPO ( UPNEXT ) - DO_UPT = .FALSE. -! - CALL W3SETO ( 0, MDSE, MDST ) - CALL TICK21 ( UPNEXT, DTOUT(2) ) - IF ( DSEC21(UPNEXT,UPLAST) .GE. 0. ) THEN - TONEXT(:,2) = UPNEXT - ELSE - UNIPTS = .FALSE. - UPNEXT(1) = -1 - UPNEXT(2) = 0 - END IF -! - DO II=1, NRGRD - CALL W3SETW ( II, MDSE, MDST ) - DTTST = DSEC21 ( TIME, TEND(:,II) ) - IF ( DTTST .GT. 0. ) THEN - GRSTAT(II) = 9 - ELSE IF ( DTTST .EQ. 0 ) THEN - GRSTAT(II) = 99 - END IF - TSYNC(1,II) = -1 - TSYNC(2,II) = 0 + CALL PRTIME ( PRFT0 ) +#endif + CALL WMIOPO ( UPNEXT ) + DO_UPT = .FALSE. + ! + CALL W3SETO ( 0, MDSE, MDST ) + CALL TICK21 ( UPNEXT, DTOUT(2) ) + IF ( DSEC21(UPNEXT,UPLAST) .GE. 0. ) THEN + TONEXT(:,2) = UPNEXT + ELSE + UNIPTS = .FALSE. + UPNEXT(1) = -1 + UPNEXT(2) = 0 + END IF + ! + DO II=1, NRGRD + CALL W3SETW ( II, MDSE, MDST ) + DTTST = DSEC21 ( TIME, TEND(:,II) ) + IF ( DTTST .GT. 0. ) THEN + GRSTAT(II) = 9 + ELSE IF ( DTTST .EQ. 0 ) THEN + GRSTAT(II) = 99 + END IF + TSYNC(1,II) = -1 + TSYNC(2,II) = 0 #ifdef W3_T - IF ( I .NE. II ) & - WRITE (MDST,9003) II, GRSTAT(II) + IF ( I .NE. II ) & + WRITE (MDST,9003) II, GRSTAT(II) #endif - END DO -! - DONE = .TRUE. + END DO + ! + DONE = .TRUE. #ifdef W3_MPRF - CALL PRTIME ( PRFTN ) - WRITE (MDSP,991) PRFT0, PRFTN, & - get_memory(), 'UPTS',I -#endif - END IF ! IF ( FLAGOK ) -! - ELSE - FLAGOK = .TRUE. - END IF ! IF ( FLAGOK ) -! -! 10.b Regular processing -! - IF ( FLAGOK ) THEN - CALL W3SETW ( I, MDSE, MDST ) - DTTST = DSEC21 ( TIME, TEND(:,I) ) - IF ( DTTST .GT. 0. ) THEN - GRSTAT(I) = 9 - DONE = .TRUE. - ELSE IF ( DTTST .EQ. 0 ) THEN - GRSTAT(I) = 99 - DONE = .TRUE. - END IF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'UPTS',I +#endif + END IF ! IF ( FLAGOK ) + ! + ELSE + FLAGOK = .TRUE. + END IF ! IF ( FLAGOK ) + ! + ! 10.b Regular processing + ! + IF ( FLAGOK ) THEN + CALL W3SETW ( I, MDSE, MDST ) + DTTST = DSEC21 ( TIME, TEND(:,I) ) + IF ( DTTST .GT. 0. ) THEN + GRSTAT(I) = 9 + DONE = .TRUE. + ELSE IF ( DTTST .EQ. 0 ) THEN + GRSTAT(I) = 99 + DONE = .TRUE. + END IF #ifdef W3_T - WRITE (MDST,9003) I, GRSTAT(I) -#endif - END IF ! IF ( FLAGOK ) -! - IF ( GRSTAT(I).EQ.9 .OR. GRSTAT(I).EQ.99 ) THEN - TSYNC(1,I) = -1 - TSYNC(2,I) = 0 - END IF -! - END IF ! 10. IF ( GRSTAT(I) .EQ. 8 ) -! -! ... End of loops started in 1. ------------------------------------- / -! - END DO LOOP_JJ -! - 1111 CONTINUE -! - END DO LOOP_J -! -#ifdef W3_MPI - NMPSCR = NMPSCS -#endif - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & - CALL WMPRNT ( MDSO, NRGRD, TSYNC(:,0), GRSTAT ) -! - DO I=1, NRGRD - IF ( GRSTAT(I) .EQ. 9 ) GRSTAT(I) = 0 - END DO -! - IF ( .NOT. DONE ) GOTO 2099 - IF ( MINVAL(GRSTAT) .EQ. 99 ) EXIT LOOP_OUTER - END DO LOOP_OUTER -! -! End of routine -------------------------------------------------- / - - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN - CALL WWTIME ( WTIME ) - WRITE (MDSS,902) WTIME - ENDIF -! -#ifdef W3_MPI + WRITE (MDST,9003) I, GRSTAT(I) +#endif + END IF ! IF ( FLAGOK ) + ! + IF ( GRSTAT(I).EQ.9 .OR. GRSTAT(I).EQ.99 ) THEN + TSYNC(1,I) = -1 + TSYNC(2,I) = 0 + END IF + ! + END IF ! 10. IF ( GRSTAT(I) .EQ. 8 ) + ! + ! ... End of loops started in 1. ------------------------------------- / + ! + END DO LOOP_JJ + ! +1111 CONTINUE + ! + END DO LOOP_J + ! +#ifdef W3_MPI + NMPSCR = NMPSCS +#endif + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & + CALL WMPRNT ( MDSO, NRGRD, TSYNC(:,0), GRSTAT ) + ! DO I=1, NRGRD - CALL WMSETM ( I, MDSE, MDST ) - IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN - CALL WMIOBF ( I ) - CALL WMIOHF ( I ) - CALL WMIOEF ( I ) - END IF - END DO -#endif -! + IF ( GRSTAT(I) .EQ. 9 ) GRSTAT(I) = 0 + END DO + ! + IF ( .NOT. DONE ) GOTO 2099 + IF ( MINVAL(GRSTAT) .EQ. 99 ) EXIT LOOP_OUTER + END DO LOOP_OUTER + ! + ! End of routine -------------------------------------------------- / + + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) THEN + CALL WWTIME ( WTIME ) + WRITE (MDSS,902) WTIME + ENDIF + ! +#ifdef W3_MPI + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN + CALL WMIOBF ( I ) + CALL WMIOHF ( I ) + CALL WMIOEF ( I ) + END IF + END DO +#endif + ! #ifdef W3_O10 - IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) #endif -! + ! #ifdef W3_T - WRITE (MDST,9100) -#endif -! - RETURN -! -! Escape locations -! - 2000 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1000) I, GRSTAT(I) - CALL EXTCDE ( 2000 ) - RETURN -! - 2001 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1001) I, TSYNC(:,I), & - TEND(:,I) - CALL EXTCDE ( 2001 ) - RETURN -! - 2002 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1002) J, INGRP(J,1), & - INGRP(J,JJ), TSYNC(:,INGRP(J,1)), TSYNC(:,INGRP(J,JJ)), & - TEND(:,INGRP(J,1)), TEND(:,INGRP(J,JJ)) - CALL EXTCDE ( 2002 ) - RETURN -! - 2099 CONTINUE - IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1099) - CALL EXTCDE ( 2099 ) - RETURN -! -! Formats -! - 900 FORMAT ( ' ========== STARTING WAVE MODEL (WMWAVE) ==========', & - '============================'/) - 901 FORMAT (' MWW3 calculating for ',A,' at ',A,' status [', & - I2,'-',I2,']') - 902 FORMAT (' MWW3 reached the end of the computation loop at ',A) + WRITE (MDST,9100) +#endif + ! + RETURN + ! + ! Escape locations + ! +2000 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1000) I, GRSTAT(I) + CALL EXTCDE ( 2000 ) + RETURN + ! +2001 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1001) I, TSYNC(:,I), & + TEND(:,I) + CALL EXTCDE ( 2001 ) + RETURN + ! +2002 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1002) J, INGRP(J,1), & + INGRP(J,JJ), TSYNC(:,INGRP(J,1)), TSYNC(:,INGRP(J,JJ)), & + TEND(:,INGRP(J,1)), TEND(:,INGRP(J,JJ)) + CALL EXTCDE ( 2002 ) + RETURN + ! +2099 CONTINUE + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1099) + CALL EXTCDE ( 2099 ) + RETURN + ! + ! Formats + ! +900 FORMAT ( ' ========== STARTING WAVE MODEL (WMWAVE) ==========', & + '============================'/) +901 FORMAT (' MWW3 calculating for ',A,' at ',A,' status [', & + I2,'-',I2,']') +902 FORMAT (' MWW3 reached the end of the computation loop at ',A) #ifdef W3_MPRF - 990 FORMAT (1X,3F12.3,' WMWAVE INIT') - 991 FORMAT (1X,3F12.3,' WMWAVE ',A4,I6) - 992 FORMAT (1X,3F12.3,' WMWAVE ',A4,I9.8,I7.6) -#endif - 999 FORMAT (/' ========== END OF WAVE MODEL (WMWAVE) ============', & - '============================'/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMWAVE : *** '/ & - ' GRID',I3,' HAS ILLEGAL GRSTAT :',I8/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN WMWAVE : *** '/ & - ' GRID',I3,' HAS ILLEGAL TSYNC / TEND '/ & - ' TSYNC :',I9.8,I7.6/ & - ' TEND :',I9.8,I7.6/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN WMWAVE : *** '/ & - ' GROUP',I3,' HAS INCOMPATIBLE TIMES ', & - 'IN GRIDS ',I3,' AND ',I3/ & - ' TSYNC :',I9.8,I7.6,1X,I9.8,I7.6/ & - ' TEND :',I9.8,I7.6,1X,I9.8,I7.6/) -! -! Note: This 1099 error can occur when multi-grid time steps are not -! compatible. - 1099 FORMAT (/' *** WAVEWATCH III ERROR IN WMWAVE : *** '/ & - ' ABORT FOR POSSIBLE ENDLESS LOOP '/) -! +990 FORMAT (1X,3F12.3,' WMWAVE INIT') +991 FORMAT (1X,3F12.3,' WMWAVE ',A4,I6) +992 FORMAT (1X,3F12.3,' WMWAVE ',A4,I9.8,I7.6) +#endif +999 FORMAT (/' ========== END OF WAVE MODEL (WMWAVE) ============', & + '============================'/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN WMWAVE : *** '/ & + ' GRID',I3,' HAS ILLEGAL GRSTAT :',I8/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN WMWAVE : *** '/ & + ' GRID',I3,' HAS ILLEGAL TSYNC / TEND '/ & + ' TSYNC :',I9.8,I7.6/ & + ' TEND :',I9.8,I7.6/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN WMWAVE : *** '/ & + ' GROUP',I3,' HAS INCOMPATIBLE TIMES ', & + 'IN GRIDS ',I3,' AND ',I3/ & + ' TSYNC :',I9.8,I7.6,1X,I9.8,I7.6/ & + ' TEND :',I9.8,I7.6,1X,I9.8,I7.6/) + ! + ! Note: This 1099 error can occur when multi-grid time steps are not + ! compatible. +1099 FORMAT (/' *** WAVEWATCH III ERROR IN WMWAVE : *** '/ & + ' ABORT FOR POSSIBLE ENDLESS LOOP '/) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST WMWAVE : LOOP',I8,' ======================', & - '===== (',I9.8,I7.6,' ) =='/ & - ' GRID, GRSTAT, TIME, TSYNC, TEND') - 9001 FORMAT ( ' ',I3,I3,3(I10.8,I7.6)) - 9002 FORMAT ( ' TEST WMWAVE : PROCESSING GRID',I3, & - ' STATUS',I3,' ',A) +9000 FORMAT ( ' TEST WMWAVE : LOOP',I8,' ======================', & + '===== (',I9.8,I7.6,' ) =='/ & + ' GRID, GRSTAT, TIME, TSYNC, TEND') +9001 FORMAT ( ' ',I3,I3,3(I10.8,I7.6)) +9002 FORMAT ( ' TEST WMWAVE : PROCESSING GRID',I3, & + ' STATUS',I3,' ',A) #endif #ifdef W3_MPIT - 9902 FORMAT ( ' MPIT WMWAVE : PROCESSING GRID',I3, & - ' STATUS',I3,' ',A) +9902 FORMAT ( ' MPIT WMWAVE : PROCESSING GRID',I3, & + ' STATUS',I3,' ',A) #endif #ifdef W3_T - 9003 FORMAT ( ' TEST WMWAVE : GRID',I3,' STATUS RESET TO',I3) - 9004 FORMAT ( ' TEST WMWAVE : FLAGOK = ',L1) - 9005 FORMAT ( ' TEST WMWAVE : FLEQOK = ',L1) - 9006 FORMAT ( ' TEST WMWAVE : CYCLE GROUP') +9003 FORMAT ( ' TEST WMWAVE : GRID',I3,' STATUS RESET TO',I3) +9004 FORMAT ( ' TEST WMWAVE : FLAGOK = ',L1) +9005 FORMAT ( ' TEST WMWAVE : FLEQOK = ',L1) +9006 FORMAT ( ' TEST WMWAVE : CYCLE GROUP') #endif -! + ! #ifdef W3_T - 9020 FORMAT ( ' TEST WMWAVE : DTTST ',E10.3) - 9021 FORMAT ( ' TEST WMWAVE : TIME :',I10.8,I7.6/ & - ' TDATA :',I10.8,I7.6/ & - ' TEND :',I10.8,I7.6) +9020 FORMAT ( ' TEST WMWAVE : DTTST ',E10.3) +9021 FORMAT ( ' TEST WMWAVE : TIME :',I10.8,I7.6/ & + ' TDATA :',I10.8,I7.6/ & + ' TEND :',I10.8,I7.6) #endif -! + ! #ifdef W3_T - 9040 FORMAT ( ' TEST WMWAVE : TMAX :',I10.8,I7.6,F8.2/ & - ' DTMAX :',I10.8,I7.6/ & - ' TDATA :',I10.8,I7.6/ & - ' TOUTP :',I10.8,I7.6/ & - ' UPNEXT:',I10.8,I7.6) - 9041 FORMAT ( ' TEST WMWAVE : TMAX :',I10.8,I7.6) +9040 FORMAT ( ' TEST WMWAVE : TMAX :',I10.8,I7.6,F8.2/ & + ' DTMAX :',I10.8,I7.6/ & + ' TDATA :',I10.8,I7.6/ & + ' TOUTP :',I10.8,I7.6/ & + ' UPNEXT:',I10.8,I7.6) +9041 FORMAT ( ' TEST WMWAVE : TMAX :',I10.8,I7.6) #endif #ifdef W3_MPIT - 9941 FORMAT ( ' MPIT WMWAVE : TMAX :',I10.8,I7.6) +9941 FORMAT ( ' MPIT WMWAVE : TMAX :',I10.8,I7.6) #endif #ifdef W3_T - 9042 FORMAT ( ' TEST WMWAVE : GRANK :',I4,' FOR GRSTAT = 2') - 9043 FORMAT ( ' TEST WMWAVE : GLOBAL TSYNC :',I10.8,I7.6) - 9044 FORMAT ( ' TEST WMWAVE : LOCAL TSYNC :',I10.8,I7.6, & - ' (',I8.8,I7.6,')') - 9045 FORMAT ( ' TEST WMWAVE : GRID TSYNC') - 9046 FORMAT ( ' ',I5,I10.8,I7.6) -#endif -! +9042 FORMAT ( ' TEST WMWAVE : GRANK :',I4,' FOR GRSTAT = 2') +9043 FORMAT ( ' TEST WMWAVE : GLOBAL TSYNC :',I10.8,I7.6) +9044 FORMAT ( ' TEST WMWAVE : LOCAL TSYNC :',I10.8,I7.6, & + ' (',I8.8,I7.6,')') +9045 FORMAT ( ' TEST WMWAVE : GRID TSYNC') +9046 FORMAT ( ' ',I5,I10.8,I7.6) +#endif + ! #ifdef W3_T - 9061 FORMAT ( ' GRID',I4,', FLEQOK = ',L1) +9061 FORMAT ( ' GRID',I4,', FLEQOK = ',L1) #endif -! + ! #ifdef W3_T - 9090 FORMAT ( ' TEST WMWAVE : DTTST ',E10.3) - 9091 FORMAT ( ' TEST WMWAVE : NEXT TOUTP :',I10.8,I7.6) +9090 FORMAT ( ' TEST WMWAVE : DTTST ',E10.3) +9091 FORMAT ( ' TEST WMWAVE : NEXT TOUTP :',I10.8,I7.6) #endif #ifdef W3_MPIT - 9991 FORMAT ( ' MPIT WMWAVE : NEXT TOUTP :',I10.8,I7.6) +9991 FORMAT ( ' MPIT WMWAVE : NEXT TOUTP :',I10.8,I7.6) #endif #ifdef W3_T - 9092 FORMAT ( ' TEST WMWAVE : UNIFIED POINT OUTPUT PREP DONE',I6) +9092 FORMAT ( ' TEST WMWAVE : UNIFIED POINT OUTPUT PREP DONE',I6) #endif -! + ! #ifdef W3_T - 9095 FORMAT ( ' TEST WMWAVE : UNIFIED POINT OUTPUT, FLAGOK = ',L1) - 9096 FORMAT ( ' ALL GRIDS, FLAGOK = ',L1) +9095 FORMAT ( ' TEST WMWAVE : UNIFIED POINT OUTPUT, FLAGOK = ',L1) +9096 FORMAT ( ' ALL GRIDS, FLAGOK = ',L1) #endif -! + ! #ifdef W3_T - 9100 FORMAT ( ' TEST WMWAVE : LOOP DONE ======================', & - '==============================') -#endif -!/ -!/ End of WMWAVE ----------------------------------------------------- / -!/ - END SUBROUTINE WMWAVE -!/ ------------------------------------------------------------------- / -!> -!> @brief Print out action table in the log file log.\ mww3. -!> -!> @param[in] MDSO -!> @param[in] NRGRD Number of grids. -!> @param[in] TSYNC Synchronization time. -!> @param[in] GRSTAT Status array per grid. -!> -!> @author H. L. Tolman @date 22-Feb-2005 -!> - SUBROUTINE WMPRNT ( MDSO, NRGRD, TSYNC, GRSTAT ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Feb-2005 | -!/ +-----------------------------------+ -!/ -!/ 22-Feb-2005 : Origination. ( version 3.07 ) -!/ -! 1. Purpose : -! -! Print out action table in the log file log.ww3m -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NRGRD Int. I Number of grids. -! TSYN I.A. I Synchronization time. -! GRSTAT I.A. I Status array per grid. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! STME21 Subr. W3TIMEMD Print date and time readable. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Subr. WMWAVEMD Multi-grid wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +9100 FORMAT ( ' TEST WMWAVE : LOOP DONE ======================', & + '==============================') +#endif + !/ + !/ End of WMWAVE ----------------------------------------------------- / + !/ + END SUBROUTINE WMWAVE + !/ ------------------------------------------------------------------- / + !> + !> @brief Print out action table in the log file log.\ mww3. + !> + !> @param[in] MDSO + !> @param[in] NRGRD Number of grids. + !> @param[in] TSYNC Synchronization time. + !> @param[in] GRSTAT Status array per grid. + !> + !> @author H. L. Tolman @date 22-Feb-2005 + !> + SUBROUTINE WMPRNT ( MDSO, NRGRD, TSYNC, GRSTAT ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Feb-2005 | + !/ +-----------------------------------+ + !/ + !/ 22-Feb-2005 : Origination. ( version 3.07 ) + !/ + ! 1. Purpose : + ! + ! Print out action table in the log file log.ww3m + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NRGRD Int. I Number of grids. + ! TSYN I.A. I Synchronization time. + ! GRSTAT I.A. I Status array per grid. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! STME21 Subr. W3TIMEMD Print date and time readable. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr. WMWAVEMD Multi-grid wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3TIMEMD, ONLY: STME21 -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MDSO, NRGRD, TSYNC(2), GRSTAT(NRGRD) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, PARAMETER :: IW = 15 - INTEGER :: I, I0, IN + USE W3SERVMD, ONLY: STRACE +#endif + USE W3TIMEMD, ONLY: STME21 + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MDSO, NRGRD, TSYNC(2), GRSTAT(NRGRD) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, PARAMETER :: IW = 15 + INTEGER :: I, I0, IN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER, SAVE :: IDLAST(2) - LOGICAL, SAVE :: FIRST = .TRUE. - CHARACTER(LEN=23) :: IDTIME - CHARACTER(LEN=3) :: STR(IW), LNE(IW) -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER, SAVE :: IDLAST(2) + LOGICAL, SAVE :: FIRST = .TRUE. + CHARACTER(LEN=23) :: IDTIME + CHARACTER(LEN=3) :: STR(IW), LNE(IW) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMPRNT') -#endif -! - DO I=1, IW - LNE(I) = '---' - END DO -! - IF ( FIRST ) THEN - WRITE (MDSO,900) NRGRD, LNE, '-+' - FIRST = .FALSE. - IDLAST(1) = -1 - IDLAST(2) = 0 - ELSE - BACKSPACE (MDSO) - END IF -! - CALL STME21 ( TSYNC, IDTIME ) -! - DO I=1, MIN(IW,NRGRD) - WRITE (STR(I),'(I3)') GRSTAT(I) + CALL STRACE (IENT, 'WMPRNT') +#endif + ! + DO I=1, IW + LNE(I) = '---' + END DO + ! + IF ( FIRST ) THEN + WRITE (MDSO,900) NRGRD, LNE, '-+' + FIRST = .FALSE. + IDLAST(1) = -1 + IDLAST(2) = 0 + ELSE + BACKSPACE (MDSO) + END IF + ! + CALL STME21 ( TSYNC, IDTIME ) + ! + DO I=1, MIN(IW,NRGRD) + WRITE (STR(I),'(I3)') GRSTAT(I) + END DO + DO I=1+MIN(IW,NRGRD), IW + STR(I) = ' ' + END DO + ! + IF ( IDLAST(1).EQ.TSYNC(1) .AND. IDLAST(2).EQ.TSYNC(2) ) THEN +#ifdef W3_O11 + WRITE (MDSO,903) STR, ' |' +#endif + ELSE IF ( IDLAST(1) .EQ. TSYNC(1) ) THEN + WRITE (MDSO,902) IDTIME(12:19), STR, ' |' + ELSE + WRITE (MDSO,901) IDTIME(01:19), STR, ' |' + END IF + IDLAST = TSYNC + ! + IF ( NRGRD .GT. IW ) THEN + I0 = 1 + IN = IW + DO + I0 = I0 + IW + IN = IN + IW + DO I=I0, MIN(IN,NRGRD) + WRITE (STR(I-I0+1),'(I3)') GRSTAT(I) END DO - DO I=1+MIN(IW,NRGRD), IW - STR(I) = ' ' + DO I=1+MIN(IN,NRGRD), IN + STR(I-I0+1) = ' ' END DO -! - IF ( IDLAST(1).EQ.TSYNC(1) .AND. IDLAST(2).EQ.TSYNC(2) ) THEN -#ifdef W3_O11 - WRITE (MDSO,903) STR, ' |' -#endif - ELSE IF ( IDLAST(1) .EQ. TSYNC(1) ) THEN - WRITE (MDSO,902) IDTIME(12:19), STR, ' |' - ELSE - WRITE (MDSO,901) IDTIME(01:19), STR, ' |' - END IF - IDLAST = TSYNC -! - IF ( NRGRD .GT. IW ) THEN - I0 = 1 - IN = IW - DO - I0 = I0 + IW - IN = IN + IW - DO I=I0, MIN(IN,NRGRD) - WRITE (STR(I-I0+1),'(I3)') GRSTAT(I) - END DO - DO I=1+MIN(IN,NRGRD), IN - STR(I-I0+1) = ' ' - END DO - WRITE (MDSO,903) STR, ' |' - IF ( IN .GE. NRGRD ) EXIT - END DO - END IF -! - WRITE (MDSO,904) LNE, '-+' -! - RETURN -! -! Formats -! - 900 FORMAT (1X,' Time (sync rank 1) | Status for',I3,' grids'/ & - 1X,'---------------------+',16A) - 901 FORMAT (2X,A19,' |',16A) - 902 FORMAT (2X,11X,A8,' |',16A) - 903 FORMAT (21X,' |',16A) - 904 FORMAT (1X,'---------------------+',16A) -!/ -!/ End of WMPRNT ----------------------------------------------------- / -!/ - END SUBROUTINE WMPRNT -!/ ------------------------------------------------------------------- / -!> -!> @brief Non-blocking broadcast for integer arrays. -!> -!> @details Non-blocking broadcast, initially for times only, -!> but made for any integer array. Sending data from first process -!> in the model communicator to all processes that are in the overall -!> communicator but not in the model communicator. -!> -!> Standard send and receives using defined communicator. Send -!> form first processor in communicator. -!> -!> @param[inout] DATA Data to be send/received. -!> @param[in] NR Size of array. -!> @param[in] IMOD Model number. -!> @param[in] NMOD Number of models. -!> @param[in] ID ID number, used with NMOD for ITAG. -!> @author H. L. Tolman @date 02-Feb-2007 -!> - SUBROUTINE WMBCST ( DATA, NR, IMOD, NMOD, ID ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 02-Feb-2007 ! -!/ +-----------------------------------+ -!/ -!/ 02-Feb-2007 : Origination. ( version 3.10 ) -!/ -! 1. Purpose : -! -! Non-blocking broadcast, initially for times only, but made for -! any integer array. Sending data from first process in the -! model cummunicator to all processes that are in the overall -! communicator but not in the model communicator. -! -! 2. Method : -! -! Standard send and receives using defined communicator. Send -! form first processor in communicator. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! DATA I.A. I/O Data to be send/received. -! NR Int. I Size of array. -! IMOD Int. I Model number. -! NMOD Int. I Number of models. -! ID Int. I ID number, used with NMOD for ITAG. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Subr. WMWAVEMD Multi-grid wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/MPIT Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -#ifdef W3_MPI - USE WMMDATMD, ONLY: MDST, MTAGB, IMPROC, NMPROC, ALLPRC, & - CROOT, MPI_COMM_MWAVE -#endif -! + WRITE (MDSO,903) STR, ' |' + IF ( IN .GE. NRGRD ) EXIT + END DO + END IF + ! + WRITE (MDSO,904) LNE, '-+' + ! + RETURN + ! + ! Formats + ! +900 FORMAT (1X,' Time (sync rank 1) | Status for',I3,' grids'/ & + 1X,'---------------------+',16A) +901 FORMAT (2X,A19,' |',16A) +902 FORMAT (2X,11X,A8,' |',16A) +903 FORMAT (21X,' |',16A) +904 FORMAT (1X,'---------------------+',16A) + !/ + !/ End of WMPRNT ----------------------------------------------------- / + !/ + END SUBROUTINE WMPRNT + !/ ------------------------------------------------------------------- / + !> + !> @brief Non-blocking broadcast for integer arrays. + !> + !> @details Non-blocking broadcast, initially for times only, + !> but made for any integer array. Sending data from first process + !> in the model communicator to all processes that are in the overall + !> communicator but not in the model communicator. + !> + !> Standard send and receives using defined communicator. Send + !> form first processor in communicator. + !> + !> @param[inout] DATA Data to be send/received. + !> @param[in] NR Size of array. + !> @param[in] IMOD Model number. + !> @param[in] NMOD Number of models. + !> @param[in] ID ID number, used with NMOD for ITAG. + !> @author H. L. Tolman @date 02-Feb-2007 + !> + SUBROUTINE WMBCST ( DATA, NR, IMOD, NMOD, ID ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 02-Feb-2007 ! + !/ +-----------------------------------+ + !/ + !/ 02-Feb-2007 : Origination. ( version 3.10 ) + !/ + ! 1. Purpose : + ! + ! Non-blocking broadcast, initially for times only, but made for + ! any integer array. Sending data from first process in the + ! model cummunicator to all processes that are in the overall + ! communicator but not in the model communicator. + ! + ! 2. Method : + ! + ! Standard send and receives using defined communicator. Send + ! form first processor in communicator. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! DATA I.A. I/O Data to be send/received. + ! NR Int. I Size of array. + ! IMOD Int. I Model number. + ! NMOD Int. I Number of models. + ! ID Int. I ID number, used with NMOD for ITAG. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr. WMWAVEMD Multi-grid wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/MPIT Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! +#ifdef W3_MPI + USE WMMDATMD, ONLY: MDST, MTAGB, IMPROC, NMPROC, ALLPRC, & + CROOT, MPI_COMM_MWAVE +#endif + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NR, IMOD, NMOD, ID - INTEGER, INTENT(INOUT) :: DATA(NR) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NR, IMOD, NMOD, ID + INTEGER, INTENT(INOUT) :: DATA(NR) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_MPI - INTEGER :: ITAG, IP, IERR_MPI, & - STATUS(MPI_STATUS_SIZE) + INTEGER :: ITAG, IP, IERR_MPI, & + STATUS(MPI_STATUS_SIZE) #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMBCST') + CALL STRACE (IENT, 'WMBCST') #endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! #ifdef W3_MPI - ITAG = MTAGB + IMOD + ID*NMOD + ITAG = MTAGB + IMOD + ID*NMOD #endif -! -! -------------------------------------------------------------------- / -! 1. Processor to send data from -! + ! + ! -------------------------------------------------------------------- / + ! 1. Processor to send data from + ! #ifdef W3_MPI - IF ( ALLPRC(IMPROC,IMOD) .EQ. 1 ) THEN - DO IP=1, NMPROC - IF ( ALLPRC(IP,IMOD) .EQ. 0 ) THEN + IF ( ALLPRC(IMPROC,IMOD) .EQ. 1 ) THEN + DO IP=1, NMPROC + IF ( ALLPRC(IP,IMOD) .EQ. 0 ) THEN #endif #ifdef W3_MPI - CALL MPI_SEND ( DATA, NR, MPI_INTEGER, IP-1, & - ITAG, MPI_COMM_MWAVE, IERR_MPI ) - END IF - END DO + CALL MPI_SEND ( DATA, NR, MPI_INTEGER, IP-1, & + ITAG, MPI_COMM_MWAVE, IERR_MPI ) + END IF + END DO #endif -! -! -------------------------------------------------------------------- / -! 2. Processor to receive data at -! + ! + ! -------------------------------------------------------------------- / + ! 2. Processor to receive data at + ! #ifdef W3_MPI - ELSE IF ( ALLPRC(IMPROC,IMOD) .EQ. 0 ) THEN + ELSE IF ( ALLPRC(IMPROC,IMOD) .EQ. 0 ) THEN #endif #ifdef W3_MPI - CALL MPI_RECV ( DATA, NR, MPI_INTEGER, CROOT-1, ITAG, & - MPI_COMM_MWAVE, STATUS, IERR_MPI ) + CALL MPI_RECV ( DATA, NR, MPI_INTEGER, CROOT-1, ITAG, & + MPI_COMM_MWAVE, STATUS, IERR_MPI ) #endif -! -! -------------------------------------------------------------------- / -! 3. Processor with no action -! -#ifdef W3_MPI - END IF -#endif -! - RETURN -! -! Formats -! + ! + ! -------------------------------------------------------------------- / + ! 3. Processor with no action + ! +#ifdef W3_MPI + END IF +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_MPIT - 9000 FORMAT ( ' TEST WMBCST : INPUTS :',4I4) - 9001 FORMAT ( ' TEST WMBCST : IMPROC, NMPROC:',2I5,' ALLPRC :') - 9002 FORMAT (14X,13I5) +9000 FORMAT ( ' TEST WMBCST : INPUTS :',4I4) +9001 FORMAT ( ' TEST WMBCST : IMPROC, NMPROC:',2I5,' ALLPRC :') +9002 FORMAT (14X,13I5) #endif -! + ! #ifdef W3_MPIT - 9010 FORMAT ( ' TEST WMBCST : IAPROC =',I5,' SENDING TO ',I5) +9010 FORMAT ( ' TEST WMBCST : IAPROC =',I5,' SENDING TO ',I5) #endif -! + ! #ifdef W3_MPIT - 9020 FORMAT ( ' TEST WMBCST : IAPROC =',I5, & - ' RECEIVING FROM ',I5) +9020 FORMAT ( ' TEST WMBCST : IAPROC =',I5, & + ' RECEIVING FROM ',I5) #endif -! + ! #ifdef W3_MPIT - 9030 FORMAT ( ' TEST WMBCST : IAPROC =',I5,' NO ACTION') -#endif -!/ -!/ End of WMBCST ----------------------------------------------------- / -!/ - END SUBROUTINE WMBCST -!/ ------------------------------------------------------------------- / -!> -!> @brief Non-blocking broadcast using dummy parameter to have output. -!> -!> @details Processes wait for computations on first node to be finished. -!> Needed for profiling purposes only. -!> -!> Standard send and recieves using defined communicator. Send -!> form first processor in communicator. -!> -!> @param[in] IMOD Model number. -!> @param[in] NMOD Number of models. -!> @param[in] ID ID number, used with NMOD for ITAG. -!> -!> @author H. L. Tolman @date 21-Jun-2007 -!> - SUBROUTINE WMWOUT ( IMOD, NMOD, ID ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 21-Jun-2007 ! -!/ +-----------------------------------+ -!/ -!/ 21-Jun-2007 : Origination. ( version 3.11 ) -!/ -! 1. Purpose : -! -! Non-blocking broadcast using dummy parameter to have output! -! processes wait for computations on first node to be finished. -! Neede for profiling purposes only. -! -! 2. Method : -! -! Standard send and recieves using defined communicator. Send -! form first processor in communicator. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! NMOD Int. I Number of models. -! ID Int. I ID number, used with NMOD for ITAG. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Sur. W3SERVMD Subroutine tracing. -! W3SETO Subr. W3ODATMD Point to data structure -! W3SETA Subr. W3ADATMD Point to data structure -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMWAVE Subr. WMWAVEMD Multi-grid wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/MPIT Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -#ifdef W3_MPI - USE W3ODATMD, ONLY: W3SETO - USE W3ADATMD, ONLY: W3SETA -#endif -! -#ifdef W3_MPI - USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC - USE W3ADATMD, ONLY: MPI_COMM_WAVE - USE WMMDATMD, ONLY: MDST, MDSE, MTAGB -#endif -! +9030 FORMAT ( ' TEST WMBCST : IAPROC =',I5,' NO ACTION') +#endif + !/ + !/ End of WMBCST ----------------------------------------------------- / + !/ + END SUBROUTINE WMBCST + !/ ------------------------------------------------------------------- / + !> + !> @brief Non-blocking broadcast using dummy parameter to have output. + !> + !> @details Processes wait for computations on first node to be finished. + !> Needed for profiling purposes only. + !> + !> Standard send and recieves using defined communicator. Send + !> form first processor in communicator. + !> + !> @param[in] IMOD Model number. + !> @param[in] NMOD Number of models. + !> @param[in] ID ID number, used with NMOD for ITAG. + !> + !> @author H. L. Tolman @date 21-Jun-2007 + !> + SUBROUTINE WMWOUT ( IMOD, NMOD, ID ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 21-Jun-2007 ! + !/ +-----------------------------------+ + !/ + !/ 21-Jun-2007 : Origination. ( version 3.11 ) + !/ + ! 1. Purpose : + ! + ! Non-blocking broadcast using dummy parameter to have output! + ! processes wait for computations on first node to be finished. + ! Neede for profiling purposes only. + ! + ! 2. Method : + ! + ! Standard send and recieves using defined communicator. Send + ! form first processor in communicator. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! NMOD Int. I Number of models. + ! ID Int. I ID number, used with NMOD for ITAG. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Sur. W3SERVMD Subroutine tracing. + ! W3SETO Subr. W3ODATMD Point to data structure + ! W3SETA Subr. W3ADATMD Point to data structure + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMWAVE Subr. WMWAVEMD Multi-grid wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/MPIT Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! +#ifdef W3_MPI + USE W3ODATMD, ONLY: W3SETO + USE W3ADATMD, ONLY: W3SETA +#endif + ! +#ifdef W3_MPI + USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC + USE W3ADATMD, ONLY: MPI_COMM_WAVE + USE WMMDATMD, ONLY: MDST, MDSE, MTAGB +#endif + ! #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NMOD, ID -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NMOD, ID + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_MPI - INTEGER :: ITAG, IP, IERR_MPI, & - STATUS(MPI_STATUS_SIZE) + INTEGER :: ITAG, IP, IERR_MPI, & + STATUS(MPI_STATUS_SIZE) #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_MPI - REAL, SAVE :: DUMMY = 999. + REAL, SAVE :: DUMMY = 999. #endif -!/ + !/ #ifdef W3_S - CALL STRACE (IENT, 'WMWOUT') + CALL STRACE (IENT, 'WMWOUT') #endif -! -! -------------------------------------------------------------------- / -! 0. Initializations -! + ! + ! -------------------------------------------------------------------- / + ! 0. Initializations + ! #ifdef W3_MPI - CALL W3SETO ( IMOD, MDSE, MDST ) - CALL W3SETA ( IMOD, MDSE, MDST ) - ITAG = MTAGB + IMOD + ID*NMOD + CALL W3SETO ( IMOD, MDSE, MDST ) + CALL W3SETA ( IMOD, MDSE, MDST ) + ITAG = MTAGB + IMOD + ID*NMOD #endif -! + ! #ifdef W3_MPI - IF ( IAPROC .LT. 1 ) THEN + IF ( IAPROC .LT. 1 ) THEN #endif #ifdef W3_MPI - RETURN - END IF + RETURN + END IF #endif -! -! -------------------------------------------------------------------- / -! 1. Processor to send data from -! + ! + ! -------------------------------------------------------------------- / + ! 1. Processor to send data from + ! #ifdef W3_MPI - IF ( IAPROC .EQ. 1 ) THEN - DO IP=NAPROC+1, NTPROC + IF ( IAPROC .EQ. 1 ) THEN + DO IP=NAPROC+1, NTPROC #endif #ifdef W3_MPI - CALL MPI_SEND ( DUMMY, 1, MPI_INTEGER, IP-1, & - ITAG, MPI_COMM_WAVE, IERR_MPI ) - END DO + CALL MPI_SEND ( DUMMY, 1, MPI_INTEGER, IP-1, & + ITAG, MPI_COMM_WAVE, IERR_MPI ) + END DO #endif -! -! -------------------------------------------------------------------- / -! 2. Processor to receive data at -! + ! + ! -------------------------------------------------------------------- / + ! 2. Processor to receive data at + ! #ifdef W3_MPI - ELSE IF ( IAPROC .GT. NAPROC ) THEN + ELSE IF ( IAPROC .GT. NAPROC ) THEN #endif #ifdef W3_MPI - CALL MPI_RECV ( DUMMY, 1, MPI_INTEGER, 0, ITAG, & - MPI_COMM_WAVE, STATUS, IERR_MPI ) + CALL MPI_RECV ( DUMMY, 1, MPI_INTEGER, 0, ITAG, & + MPI_COMM_WAVE, STATUS, IERR_MPI ) #endif -! -! -------------------------------------------------------------------- / -! 3. Processor with no action -! + ! + ! -------------------------------------------------------------------- / + ! 3. Processor with no action + ! #ifdef W3_MPI - END IF + END IF #endif -! - RETURN -! -! Formats -! + ! + RETURN + ! + ! Formats + ! #ifdef W3_MPIT - 9000 FORMAT ( ' TEST WMWOUT : INPUTS :',4I4) - 9001 FORMAT ( ' TEST WMWOUT : IAPROC, NAPROC, NTPROC :',3I5) - 9002 FORMAT ( ' TEST WMWOUT : NOT IN COMMUNICATOR') +9000 FORMAT ( ' TEST WMWOUT : INPUTS :',4I4) +9001 FORMAT ( ' TEST WMWOUT : IAPROC, NAPROC, NTPROC :',3I5) +9002 FORMAT ( ' TEST WMWOUT : NOT IN COMMUNICATOR') #endif -! + ! #ifdef W3_MPIT - 9010 FORMAT ( ' TEST WMWOUT : IAPROC =',I5,' SENDING TO ',I5) +9010 FORMAT ( ' TEST WMWOUT : IAPROC =',I5,' SENDING TO ',I5) #endif -! + ! #ifdef W3_MPIT - 9020 FORMAT ( ' TEST WMWOUT : IAPROC =',I5, & - ' RECEIVING FROM ',I5) +9020 FORMAT ( ' TEST WMWOUT : IAPROC =',I5, & + ' RECEIVING FROM ',I5) #endif -! + ! #ifdef W3_MPIT - 9030 FORMAT ( ' TEST WMWOUT : IAPROC =',I5,' NO ACTION') -#endif -!/ -!/ End of WMWOUT ----------------------------------------------------- / -!/ - END SUBROUTINE WMWOUT -!/ -!/ End of module WMWAVEMD -------------------------------------------- / -!/ - END MODULE WMWAVEMD +9030 FORMAT ( ' TEST WMWOUT : IAPROC =',I5,' NO ACTION') +#endif + !/ + !/ End of WMWOUT ----------------------------------------------------- / + !/ + END SUBROUTINE WMWOUT + !/ + !/ End of module WMWAVEMD -------------------------------------------- / + !/ +END MODULE WMWAVEMD diff --git a/model/src/ww3_bounc.F90 b/model/src/ww3_bounc.F90 index bb24ba672..549f027d5 100644 --- a/model/src/ww3_bounc.F90 +++ b/model/src/ww3_bounc.F90 @@ -19,830 +19,830 @@ !> @author M Accensi !> @date 21-Jul-2020 ! - PROGRAM W3BOUNC -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 21-Jul-2020 | -!/ +-----------------------------------+ -!/ -!/ 24-May-2013 : Adaptation from ww3_bound.ftn ( version 4.08 ) -!/ 1-Apr-2015 : Add checks on lat lon xfr ( version 5.05 ) -!/ 11-May-2015 : Allow use of cartesian grids ( version 5.08 ) -!/ 17-Aug-2016 : Bug correction on RDBPO ( version 5.10 ) -!/ 20-Oct-2016 : Error statement updates ( version 5.15 ) -!/ 20-Mar-2018 : Improve netcdf file reading ( version 6.02 ) -!/ 15-May-2018 : Add namelist feature ( version 6.05 ) -!/ 04-May-2020 : Update spectral conversion ( version 7.11 ) -!/ 21-Jul-2020 : Support rotated pole grid ( version 7.11 ) -!/ -!/ -!/ Copyright 2012-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Combines spectra files into a nest.ww3 file for boundary conditions -! -! 2. Method : -! -! Finds nearest points and performs linear interpolation -! -! The initial conditions are written to the restart.ww3 using the -! subroutine W3IORS. Note that the name of the restart file is set -! in W3IORS. -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! NDSI Int. Input unit number ("ww3_assm.inp"). -! ITYPE Int. Type of data -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! WAVNU1 Subr. W3DISPMD Solve dispersion relation. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3EQTOLL Subr W3SERVMD Convert coordinates from rotated pole. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Can be used also to diagnose contents of nest.ww3 file -! in read mode -! -! - Input spectra are assumed to be formulated on a standard -! pole. However, the model grid can be on a rotated pole. -! -! 8. Structure : -! -! ---------------------------------------------------- -! 1.a Set up data structures. -! ( W3NMOD , W3NDAT , W3NOUT -! W3SETG , W3SETW , W3SETO ) -! b I-O setup. -! .... -! 9. Convert energy to action -! 10. Write restart file. ( W3IORS ) -! ---------------------------------------------------- -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! -! !/O4 Output normalized 1-D energy spectrum. -! !/O5 Output normalized 2-D energy spectrum. -! !/O6 Output normalized wave heights (not MPP adapted). -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3WDATMD, ONLY: W3NDAT, W3SETW - USE W3ADATMD, ONLY: W3NAUX, W3SETA - USE W3ODATMD, ONLY: W3NOUT, W3SETO, FNMPRE, NDST, NDSE - USE W3CSPCMD, ONLY: W3CSPC - - - USE W3GDATMD, ONLY: NK, NTH, XFR, FR1, DTH, TH, FACHFE, & - GNAME, W3NMOD, W3SETG,& - NSEA, MAPSTA, GTYPE, XGRD, YGRD, X0, Y0, & - SX, SY, MAPSF, UNGTYPE, CLGTYPE, RLGTYPE, FLAGLL +PROGRAM W3BOUNC + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 21-Jul-2020 | + !/ +-----------------------------------+ + !/ + !/ 24-May-2013 : Adaptation from ww3_bound.ftn ( version 4.08 ) + !/ 1-Apr-2015 : Add checks on lat lon xfr ( version 5.05 ) + !/ 11-May-2015 : Allow use of cartesian grids ( version 5.08 ) + !/ 17-Aug-2016 : Bug correction on RDBPO ( version 5.10 ) + !/ 20-Oct-2016 : Error statement updates ( version 5.15 ) + !/ 20-Mar-2018 : Improve netcdf file reading ( version 6.02 ) + !/ 15-May-2018 : Add namelist feature ( version 6.05 ) + !/ 04-May-2020 : Update spectral conversion ( version 7.11 ) + !/ 21-Jul-2020 : Support rotated pole grid ( version 7.11 ) + !/ + !/ + !/ Copyright 2012-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Combines spectra files into a nest.ww3 file for boundary conditions + ! + ! 2. Method : + ! + ! Finds nearest points and performs linear interpolation + ! + ! The initial conditions are written to the restart.ww3 using the + ! subroutine W3IORS. Note that the name of the restart file is set + ! in W3IORS. + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! NDSI Int. Input unit number ("ww3_assm.inp"). + ! ITYPE Int. Type of data + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! WAVNU1 Subr. W3DISPMD Solve dispersion relation. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3EQTOLL Subr W3SERVMD Convert coordinates from rotated pole. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Can be used also to diagnose contents of nest.ww3 file + ! in read mode + ! + ! - Input spectra are assumed to be formulated on a standard + ! pole. However, the model grid can be on a rotated pole. + ! + ! 8. Structure : + ! + ! ---------------------------------------------------- + ! 1.a Set up data structures. + ! ( W3NMOD , W3NDAT , W3NOUT + ! W3SETG , W3SETW , W3SETO ) + ! b I-O setup. + ! .... + ! 9. Convert energy to action + ! 10. Write restart file. ( W3IORS ) + ! ---------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/SHRD Switch for message passing method. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! + ! !/O4 Output normalized 1-D energy spectrum. + ! !/O5 Output normalized 2-D energy spectrum. + ! !/O6 Output normalized wave heights (not MPP adapted). + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3WDATMD, ONLY: W3NDAT, W3SETW + USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ODATMD, ONLY: W3NOUT, W3SETO, FNMPRE, NDST, NDSE + USE W3CSPCMD, ONLY: W3CSPC + + + USE W3GDATMD, ONLY: NK, NTH, XFR, FR1, DTH, TH, FACHFE, & + GNAME, W3NMOD, W3SETG,& + NSEA, MAPSTA, GTYPE, XGRD, YGRD, X0, Y0, & + SX, SY, MAPSF, UNGTYPE, CLGTYPE, RLGTYPE, FLAGLL #ifdef W3_RTD - USE W3GDATMD, ONLY : POLAT, POLON + USE W3GDATMD, ONLY : POLAT, POLON #endif - USE W3ODATMD, ONLY: NDSO, NDSE - USE W3IOBCMD, ONLY: VERBPTBC, IDSTRBC - USE W3IOGRMD, ONLY: W3IOGR - USE W3TIMEMD - USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE, DIST_SPHERE + USE W3ODATMD, ONLY: NDSO, NDSE + USE W3IOBCMD, ONLY: VERBPTBC, IDSTRBC + USE W3IOGRMD, ONLY: W3IOGR + USE W3TIMEMD + USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE, DIST_SPHERE #ifdef W3_RTD - USE W3SERVMD, ONLY: W3EQTOLL + USE W3SERVMD, ONLY: W3EQTOLL #endif - USE W3NMLBOUNCMD - USE NETCDF + USE W3NMLBOUNCMD + USE NETCDF #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif -!/ - IMPLICIT NONE -! + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - - TYPE(NML_BOUND_T) :: NML_BOUND -! - INTEGER :: IX, IY, ISEA, I,JJ,IP,IP1,J,IT, & - NDSI,NDSM, NDSI2,NDSS,NDSB, NDSC, & - NDSTRC, NTRACE, NK1,NTH1,NT1, NSPEC1, & - NBI, NBI2, NKI, NTHI, NTI, NBO, NBO2, & - IERR, INTERP, ILOOP, VERBOSE, IBO, & - IRET, ICODE, NDSL - INTEGER :: TIME(2), TIME2(2), VARID(12), & - REFDATE(8), CURDATE(8), VARTYPE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + + TYPE(NML_BOUND_T) :: NML_BOUND + ! + INTEGER :: IX, IY, ISEA, I,JJ,IP,IP1,J,IT, & + NDSI,NDSM, NDSI2,NDSS,NDSB, NDSC, & + NDSTRC, NTRACE, NK1,NTH1,NT1, NSPEC1, & + NBI, NBI2, NKI, NTHI, NTI, NBO, NBO2, & + IERR, INTERP, ILOOP, VERBOSE, IBO, & + IRET, ICODE, NDSL + INTEGER :: TIME(2), TIME2(2), VARID(12), & + REFDATE(8), CURDATE(8), VARTYPE #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! - INTEGER, ALLOCATABLE :: IPBPI(:,:), IPBPO(:,:), NCID(:), & - DIMID(:,:), DIMLN(:,:) -! - REAL :: FR1I, XFRI, TH1I, FACTOR, OFFSET, DMIN,& - DIST, DMIN2, COS1, DLON, DLAT, DLO, & - FILLVAL -! - REAL, ALLOCATABLE :: SPEC2D(:,:,:,:), LATS(:), LONS(:), & - FREQ(:), THETA(:), & - XBPI(:), YBPI(:), RDBPI(:,:), & - XBPO(:), YBPO(:), RDBPO(:,:), & - ABPIN(:,:), ABPIN2(:,:,:) + ! + INTEGER, ALLOCATABLE :: IPBPI(:,:), IPBPO(:,:), NCID(:), & + DIMID(:,:), DIMLN(:,:) + ! + REAL :: FR1I, XFRI, TH1I, FACTOR, OFFSET, DMIN,& + DIST, DMIN2, COS1, DLON, DLAT, DLO, & + FILLVAL + ! + REAL, ALLOCATABLE :: SPEC2D(:,:,:,:), LATS(:), LONS(:), & + FREQ(:), THETA(:), & + XBPI(:), YBPI(:), RDBPI(:,:), & + XBPO(:), YBPO(:), RDBPO(:,:), & + ABPIN(:,:), ABPIN2(:,:,:) #ifdef W3_RTD - REAL, ALLOCATABLE :: XTMP(:), YTMP(:), ANGTMP(:) - LOGICAL :: ISRTD + REAL, ALLOCATABLE :: XTMP(:), YTMP(:), ANGTMP(:) + LOGICAL :: ISRTD #endif -! - REAL, ALLOCATABLE :: TMPSPCI(:,:),TMPSPCO(:,:) - -! - DOUBLE PRECISION :: REFJULDAY, CURJULDAY - DOUBLE PRECISION, ALLOCATABLE :: TIMES(:) -! - CHARACTER :: COMSTR*1, LINE*512, FILENAME*512, & - INXOUT*5, FILE*128 - CHARACTER*50 :: TIMEUNITS, CALENDAR - CHARACTER*10 :: VERTEST ! = '2018-03-01' - CHARACTER*32 :: IDTST != 'WAVEWATCH III BOUNDARY DATA FILE' - CHARACTER*512, ALLOCATABLE :: SPECFILES(:) - CHARACTER, ALLOCATABLE :: STATION(:,:) -! - LOGICAL :: FLGNML, SPCONV -! -!/ -!/ ------------------------------------------------------------------- / - - -!/ -! 1. IO set-up. -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! - NDSI = 10 - NDSB = 33 - NDSC = 44 - NDSM = 20 - NDSS = 30 - NDSL = 50 - NDSO = 6 - NDSE = 6 -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + ! + REAL, ALLOCATABLE :: TMPSPCI(:,:),TMPSPCO(:,:) + + ! + DOUBLE PRECISION :: REFJULDAY, CURJULDAY + DOUBLE PRECISION, ALLOCATABLE :: TIMES(:) + ! + CHARACTER :: COMSTR*1, LINE*512, FILENAME*512, & + INXOUT*5, FILE*128 + CHARACTER*50 :: TIMEUNITS, CALENDAR + CHARACTER*10 :: VERTEST ! = '2018-03-01' + CHARACTER*32 :: IDTST != 'WAVEWATCH III BOUNDARY DATA FILE' + CHARACTER*512, ALLOCATABLE :: SPECFILES(:) + CHARACTER, ALLOCATABLE :: STATION(:,:) + ! + LOGICAL :: FLGNML, SPCONV + ! + !/ + !/ ------------------------------------------------------------------- / + + + !/ + ! 1. IO set-up. + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + NDSI = 10 + NDSB = 33 + NDSC = 44 + NDSM = 20 + NDSS = 30 + NDSL = 50 + NDSO = 6 + NDSE = 6 + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_S - CALL STRACE (IENT, 'W3BOUNC') + CALL STRACE (IENT, 'W3BOUNC') #endif -! - WRITE (NDSO,900) -! - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - WRITE (NDSO,920) GNAME + ! + WRITE (NDSO,900) + ! + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + WRITE (NDSO,920) GNAME #ifdef W3_RTD -! - ISRTD = POLAT .LT. 90.0 -! + ! + ISRTD = POLAT .LT. 90.0 + ! #endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read requests from input file. -! - -! -! process ww3_bounc namelist -! - INQUIRE(FILE=TRIM(FNMPRE)//"ww3_bounc.nml", EXIST=FLGNML) - IF (FLGNML) THEN - ! Read namelist - CALL W3NMLBOUNC (NDSI, TRIM(FNMPRE)//'ww3_bounc.nml', NML_BOUND, IERR) - - INXOUT = NML_BOUND%MODE - INTERP = NML_BOUND%INTERP - VERBOSE = NML_BOUND%VERBOSE - FILE = NML_BOUND%FILE - - NBO2 = 0 - OPEN(NDSL,FILE=TRIM(FILE),STATUS='OLD',ERR=809,IOSTAT=IERR) - REWIND (NDSL) - DO - READ (NDSL,*,END=400,ERR=802) - NBO2 = NBO2 + 1 - END DO - 400 CONTINUE + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read requests from input file. + ! + + ! + ! process ww3_bounc namelist + ! + INQUIRE(FILE=TRIM(FNMPRE)//"ww3_bounc.nml", EXIST=FLGNML) + IF (FLGNML) THEN + ! Read namelist + CALL W3NMLBOUNC (NDSI, TRIM(FNMPRE)//'ww3_bounc.nml', NML_BOUND, IERR) + + INXOUT = NML_BOUND%MODE + INTERP = NML_BOUND%INTERP + VERBOSE = NML_BOUND%VERBOSE + FILE = NML_BOUND%FILE + + NBO2 = 0 + OPEN(NDSL,FILE=TRIM(FILE),STATUS='OLD',ERR=809,IOSTAT=IERR) + REWIND (NDSL) + DO + READ (NDSL,*,END=400,ERR=802) + NBO2 = NBO2 + 1 + END DO +400 CONTINUE + ALLOCATE(SPECFILES(NBO2)) + REWIND (NDSL) + DO I=1,NBO2 + READ (NDSL,'(A512)',END=801,ERR=802) SPECFILES(I) + END DO + CLOSE(NDSL) + + END IF ! FLGNML + + ! + ! process old ww3_bounc.inp format + ! + IF (.NOT. FLGNML) THEN + OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_bounc.inp',STATUS='OLD',ERR=805,IOSTAT=IERR) + REWIND (NDSI) + + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) INXOUT + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) INTERP + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) VERBOSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ! + NBO2 = 0 + ! + ! ILOOP = 1 to count NBO2 + ! ILOOP = 2 to read the file names + ! + DO ILOOP = 1, 2 + OPEN (NDSS,FILE='ww3_bounc.scratch',FORM='FORMATTED', & + status='UNKNOWN') + IF ( ILOOP .EQ. 1 ) THEN + NDSI2 = NDSI + ELSE + NDSI2 = NDSS ALLOCATE(SPECFILES(NBO2)) - REWIND (NDSL) - DO I=1,NBO2 - READ (NDSL,'(A512)',END=801,ERR=802) SPECFILES(I) + NBO2=0 + ENDIF + + NBO2=0 + ! Read input file names + DO + CALL NEXTLN ( COMSTR , NDSI2 , NDSE ) + READ (NDSI2,'(A512)') FILENAME + JJ = LEN_TRIM(FILENAME) + IF ( ILOOP .EQ. 1 ) THEN + BACKSPACE (NDSI) + READ (NDSI,'(A)') LINE + WRITE (NDSS,'(A)') LINE + END IF + IF (FILENAME(:JJ).EQ."'STOPSTRING'") EXIT + NBO2=NBO2+1 + IF (ILOOP.EQ.1) CYCLE + SPECFILES(NBO2)=FILENAME + END DO + ! + IF ( ILOOP .EQ. 1 ) CLOSE ( NDSS) + ! + IF ( ILOOP .EQ. 2 ) CLOSE ( NDSS, STATUS='DELETE' ) + END DO ! ILOOP = 1, 2 + CLOSE(NDSI) + + END IF ! .NOT. FLGNML + + + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Tests the reading of the file + ! + IF ( INXOUT.EQ.'READ') THEN + OPEN(NDSB,FILE='nest.ww3',form='UNFORMATTED', convert=file_endian,status='old') + READ(NDSB) IDTST, VERTEST, NK1, NTH1, XFR, FR1I, TH1I, NBI + NSPEC1 = NK1 * NTH1 + IF ( IDTST .NE. IDSTRBC ) GOTO 803 + WRITE(NDSO,940) VERTEST + WRITE(NDSO,941) IDTST + IF (VERBOSE.EQ.1) WRITE(NDSO,'(A,2I5,3F12.6,I5)') 'NK,NTH,XFR, FR1I, TH1I, NBI :', & + NK1,NTH1,XFR, FR1I, TH1I, NBI + ALLOCATE (XBPI(NBI),YBPI(NBI)) + ALLOCATE (IPBPI(NBI,4),RDBPI(NBI,4)) + READ(NDSB) (XBPI(I),I=1,NBI), & + (YBPI(I),I=1,NBI), & + ((IPBPI(I,J),I=1,NBI),J=1,4), & + ((RDBPI(I,J),I=1,NBI),J=1,4) + IF (VERBOSE.GE.1) WRITE(NDSO,*) 'XBPI:',XBPI + IF (VERBOSE.GE.1) WRITE(NDSO,*) 'YBPI:',YBPI + IF (VERBOSE.GE.1) WRITE(NDSO,*) 'IPBPI:' + DO I=1,NBI + IF (VERBOSE.GE.1) WRITE(NDSO,*) I,' interpolated from:',IPBPI(I,1:4) + IF (VERBOSE.GE.1) WRITE(NDSO,*) I,' with coefficient :',RDBPI(I,1:4) + END DO + ! + READ (NDSB) TIME2, NBI2 + BACKSPACE (NDSB) + ALLOCATE (ABPIN(NSPEC1,NBI2)) + IERR=0 + DO WHILE (IERR.EQ.0) + READ (NDSB,IOSTAT=IERR) TIME2, NBI2 + IF (IERR.EQ.0) THEN + IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'TIME2,NBI2:',TIME2, NBI2,IERR + DO IP=1, NBI2 + READ (NDSB,END=803,ERR=804) ABPIN(:,IP) END DO - CLOSE(NDSL) - - END IF ! FLGNML - -! -! process old ww3_bounc.inp format -! - IF (.NOT. FLGNML) THEN - OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_bounc.inp',STATUS='OLD',ERR=805,IOSTAT=IERR) - REWIND (NDSI) - - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR - - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) INXOUT - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) INTERP - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) VERBOSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) -! - NBO2 = 0 -! -! ILOOP = 1 to count NBO2 -! ILOOP = 2 to read the file names -! - DO ILOOP = 1, 2 - OPEN (NDSS,FILE='ww3_bounc.scratch',FORM='FORMATTED', & - status='UNKNOWN') - IF ( ILOOP .EQ. 1 ) THEN - NDSI2 = NDSI - ELSE - NDSI2 = NDSS - ALLOCATE(SPECFILES(NBO2)) - NBO2=0 - ENDIF - - NBO2=0 -! Read input file names - DO - CALL NEXTLN ( COMSTR , NDSI2 , NDSE ) - READ (NDSI2,'(A512)') FILENAME - JJ = LEN_TRIM(FILENAME) - IF ( ILOOP .EQ. 1 ) THEN - BACKSPACE (NDSI) - READ (NDSI,'(A)') LINE - WRITE (NDSS,'(A)') LINE - END IF - IF (FILENAME(:JJ).EQ."'STOPSTRING'") EXIT - NBO2=NBO2+1 - IF (ILOOP.EQ.1) CYCLE - SPECFILES(NBO2)=FILENAME - END DO -! - IF ( ILOOP .EQ. 1 ) CLOSE ( NDSS) -! - IF ( ILOOP .EQ. 2 ) CLOSE ( NDSS, STATUS='DELETE' ) - END DO ! ILOOP = 1, 2 - CLOSE(NDSI) - - END IF ! .NOT. FLGNML - - - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Tests the reading of the file -! - IF ( INXOUT.EQ.'READ') THEN - OPEN(NDSB,FILE='nest.ww3',form='UNFORMATTED', convert=file_endian,status='old') - READ(NDSB) IDTST, VERTEST, NK1, NTH1, XFR, FR1I, TH1I, NBI - NSPEC1 = NK1 * NTH1 - IF ( IDTST .NE. IDSTRBC ) GOTO 803 - WRITE(NDSO,940) VERTEST - WRITE(NDSO,941) IDTST - IF (VERBOSE.EQ.1) WRITE(NDSO,'(A,2I5,3F12.6,I5)') 'NK,NTH,XFR, FR1I, TH1I, NBI :', & - NK1,NTH1,XFR, FR1I, TH1I, NBI - ALLOCATE (XBPI(NBI),YBPI(NBI)) - ALLOCATE (IPBPI(NBI,4),RDBPI(NBI,4)) - READ(NDSB) (XBPI(I),I=1,NBI), & - (YBPI(I),I=1,NBI), & - ((IPBPI(I,J),I=1,NBI),J=1,4), & - ((RDBPI(I,J),I=1,NBI),J=1,4) - IF (VERBOSE.GE.1) WRITE(NDSO,*) 'XBPI:',XBPI - IF (VERBOSE.GE.1) WRITE(NDSO,*) 'YBPI:',YBPI - IF (VERBOSE.GE.1) WRITE(NDSO,*) 'IPBPI:' - DO I=1,NBI - IF (VERBOSE.GE.1) WRITE(NDSO,*) I,' interpolated from:',IPBPI(I,1:4) - IF (VERBOSE.GE.1) WRITE(NDSO,*) I,' with coefficient :',RDBPI(I,1:4) - END DO -! - READ (NDSB) TIME2, NBI2 - BACKSPACE (NDSB) - ALLOCATE (ABPIN(NSPEC1,NBI2)) - IERR=0 - DO WHILE (IERR.EQ.0) - READ (NDSB,IOSTAT=IERR) TIME2, NBI2 - IF (IERR.EQ.0) THEN - IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'TIME2,NBI2:',TIME2, NBI2,IERR - DO IP=1, NBI2 - READ (NDSB,END=803,ERR=804) ABPIN(:,IP) - END DO - END IF - END DO - CLOSE(NDSB) - END IF ! INXOUT.EQ.'READ' -! -! - IF ( INXOUT.EQ.'WRITE') THEN -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Defines position of active boundary points -! - NBO = 0 - DO ISEA=1,NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF (MAPSTA(IY,IX).EQ.2) THEN - NBO=NBO+1 - END IF - END DO - ALLOCATE(XBPO(NBO),YBPO(NBO)) + END IF + END DO + CLOSE(NDSB) + END IF ! INXOUT.EQ.'READ' + ! + ! + IF ( INXOUT.EQ.'WRITE') THEN + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Defines position of active boundary points + ! + NBO = 0 + DO ISEA=1,NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF (MAPSTA(IY,IX).EQ.2) THEN + NBO=NBO+1 + END IF + END DO + ALLOCATE(XBPO(NBO),YBPO(NBO)) #ifdef W3_RTD - IF (ISRTD) ALLOCATE(XTMP(NBO), YTMP(NBO), ANGTMP(NBO)) + IF (ISRTD) ALLOCATE(XTMP(NBO), YTMP(NBO), ANGTMP(NBO)) #endif - ALLOCATE (IPBPO(NBO,4),RDBPO(NBO,4)) - IBO=0 - DO ISEA=1,NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF (MAPSTA(IY,IX).EQ.2) THEN - IBO=IBO+1 - SELECT CASE ( GTYPE ) - CASE ( RLGTYPE ) - XBPO(IBO)=X0+SX*(IX-1) - YBPO(IBO)=Y0+SY*(IY-1) - CASE ( CLGTYPE ) - XBPO(IBO)= XGRD(IY,IX) - YBPO(IBO)= YGRD(IY,IX) - CASE (UNGTYPE) - XBPO(IBO)= XGRD(1,IX) - YBPO(IBO)= YGRD(1,IX) - END SELECT !GTYPE - END IF - END DO + ALLOCATE (IPBPO(NBO,4),RDBPO(NBO,4)) + IBO=0 + DO ISEA=1,NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF (MAPSTA(IY,IX).EQ.2) THEN + IBO=IBO+1 + SELECT CASE ( GTYPE ) + CASE ( RLGTYPE ) + XBPO(IBO)=X0+SX*(IX-1) + YBPO(IBO)=Y0+SY*(IY-1) + CASE ( CLGTYPE ) + XBPO(IBO)= XGRD(IY,IX) + YBPO(IBO)= YGRD(IY,IX) + CASE (UNGTYPE) + XBPO(IBO)= XGRD(1,IX) + YBPO(IBO)= YGRD(1,IX) + END SELECT !GTYPE + END IF + END DO #ifdef W3_RTD -! - IF (ISRTD) THEN - ! Convert grid boundary cell locations to standard pole - XTMP = XBPO - YTMP = YBPO - CALL W3EQTOLL(YTMP, XTMP, YBPO, XBPO, ANGTMP, POLAT, POLON, NBO) - DEALLOCATE(XTMP, YTMP, ANGTMP) - ENDIF -! + ! + IF (ISRTD) THEN + ! Convert grid boundary cell locations to standard pole + XTMP = XBPO + YTMP = YBPO + CALL W3EQTOLL(YTMP, XTMP, YBPO, XBPO, ANGTMP, POLAT, POLON, NBO) + DEALLOCATE(XTMP, YTMP, ANGTMP) + ENDIF + ! #endif -! - OPEN(NDSB,FILE='nest.ww3',form='UNFORMATTED', convert=file_endian,status='unknown') - ALLOCATE(DIMID(NBO2,3),DIMLN(NBO2,3),NCID(NBO2)) - - ALLOCATE(LATS(NBO2),LONS(NBO2),STATION(16,NBO2)) - - DO IP=1,NBO2 - ! open file - OPEN(NDSC,FILE=TRIM(SPECFILES(IP)),form='UNFORMATTED', convert=file_endian, & - status='old',iostat=ICODE) - IF (ICODE.NE.0) THEN - LONS(IP)=-999. - LATS(IP)=-999. - WRITE (NDSE,1010) TRIM(SPECFILES(IP)) - CALL EXTCDE ( 70 ) - END IF - - IRET=NF90_OPEN(TRIM(SPECFILES(IP)),NF90_NOWRITE,NCID(IP)) - WRITE(6,*) 'Opening file:',TRIM(SPECFILES(IP)) - CALL CHECK_ERR(IRET) - - ! dimensions - IRET=NF90_INQ_DIMID(NCID(IP),'time',DIMID(IP,1)) - CALL CHECK_ERR(IRET) - IRET=NF90_INQ_DIMID(NCID(IP),'frequency',DIMID(IP,2)) - CALL CHECK_ERR(IRET) - IRET=NF90_INQ_DIMID(NCID(IP),'direction',DIMID(IP,3)) - CALL CHECK_ERR(IRET) - IRET=NF90_INQUIRE_DIMENSION(NCID(IP),DIMID(IP,1),len=DIMLN(IP,1)) - CALL CHECK_ERR(IRET) - IRET=NF90_INQUIRE_DIMENSION(NCID(IP),DIMID(IP,2),len=DIMLN(IP,2)) - CALL CHECK_ERR(IRET) - IRET=NF90_INQUIRE_DIMENSION(NCID(IP),DIMID(IP,3),len=DIMLN(IP,3)) - CALL CHECK_ERR(IRET) - - NTI=DIMLN(IP,1) - NKI=DIMLN(IP,2) - NTHI=DIMLN(IP,3) - - IF (IP.EQ.1) THEN - NT1=NTI - NK1=NKI - NTH1=NTHI - NSPEC1 = NK1 * NTH1 - ALLOCATE(TIMES(NT1)) - ALLOCATE (FREQ(NK1),THETA(NTH1)) - ALLOCATE (SPEC2D(NTH1,NK1,NT1,NBO2)) - ALLOCATE (ABPIN2(NK*NTH,NT1,NBO2)) - - ! instanciates time - REFDATE(:)=0. - IRET=NF90_INQ_VARID(NCID(IP),"time",VARID(1)) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID(IP), VARID(1), TIMES(:)) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_ATT(NCID(IP),VARID(1),"calendar",CALENDAR) - IF ( IRET/=NF90_NOERR ) THEN - WRITE(NDSE,951) - ELSE IF ((INDEX(CALENDAR, "standard").EQ.0) .AND. & - (INDEX(CALENDAR, "gregorian").EQ.0)) THEN - WRITE(NDSE,952) - END IF - IRET=NF90_GET_ATT(NCID(IP),VARID(1),"units",TIMEUNITS) - CALL U2D(TIMEUNITS,REFDATE,IERR) - CALL D2J(REFDATE,REFJULDAY,IERR) - - ELSE - IF (NKI.NE.NK1.OR.NTHI.NE.NTH1.OR.NT1.NE.NTI & - ) GOTO 805 - END IF - - ! position variables : lon/lat or x/y - IF ( FLAGLL ) THEN - IRET=NF90_INQ_VARID(NCID(IP), 'latitude', VARID(2)) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID(IP), VARID(2), LATS(IP)) - CALL CHECK_ERR(IRET) - IRET=NF90_INQ_VARID(NCID(IP), 'longitude', VARID(3)) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID(IP), VARID(3), LONS(IP)) - CALL CHECK_ERR(IRET) - ELSE - IRET=NF90_INQ_VARID(NCID(IP), 'y', VARID(2)) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID(IP), VARID(2), LATS(IP)) - CALL CHECK_ERR(IRET) - IRET=NF90_INQ_VARID(NCID(IP), 'x', VARID(3)) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID(IP), VARID(3), LONS(IP)) - CALL CHECK_ERR(IRET) - END IF - - ! freq and dir variables - IRET=NF90_INQ_VARID(NCID(IP),"frequency",VARID(4)) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID(IP),VARID(4),FREQ) - CALL CHECK_ERR(IRET) - IRET=NF90_INQ_VARID(NCID(IP),"direction",VARID(5)) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID(IP),VARID(5),THETA) - CALL CHECK_ERR(IRET) - THETA=MOD(2.5*PI-(PI/180)*THETA,TPI) - - ! 2D spectra depending on station name or lat/lon - IRET=NF90_INQ_VARID(NCID(IP),"efth",VARID(7)) - IF (IRET.NE.0) IRET=NF90_INQ_VARID(NCID(IP),"Efth",VARID(7)) - CALL CHECK_ERR(IRET) - IRET=NF90_INQUIRE_VARIABLE(NCID(IP),VARID(7),XTYPE=VARTYPE) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_ATT(NCID(IP),VARID(7),"_FillValue",FILLVAL) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_ATT(NCID(IP),VARID(7),"scale_factor",FACTOR) - IF (IRET.NE.0) FACTOR=1. - IRET=NF90_GET_ATT(NCID(IP),VARID(7),"add_offset",OFFSET) - IF (IRET.NE.0) OFFSET=0. - IRET = NF90_INQ_VARID(NCID(IP), 'station_name', VARID(6)) - IF (IRET.NE.0) THEN - ! efth(time, frequency, direction, latitude, longitude) - IRET=NF90_GET_VAR(NCID(IP),VARID(7),SPEC2D(:,:,:,IP), & - start=(/1,1,1,1/),count=(/1,1,NTHI,NKI,NTI/)) - CALL CHECK_ERR(IRET) - ELSE - ! efth(time, station, frequency, direction) - IRET=NF90_GET_VAR(NCID(IP),VARID(7),SPEC2D(:,:,:,IP), & - start=(/1,1,1,1/),count=(/NTHI,NKI,1,NTI/)) - CALL CHECK_ERR(IRET) - END IF - ! apply scale_factor and add_offset - IF (VARTYPE.EQ.NF90_SHORT) THEN - WHERE(SPEC2D(:,:,:,IP).NE.FILLVAL) SPEC2D(:,:,:,IP)=(EXP(SPEC2D(:,:,:,IP)*FACTOR*LOG(10.)))-1e-12 - ELSE - WHERE(SPEC2D(:,:,:,IP).NE.FILLVAL) SPEC2D(:,:,:,IP)=(SPEC2D(:,:,:,IP)*FACTOR)+OFFSET - END IF - - ! close spectra file - IRET=NF90_CLOSE(NCID(IP)) - CALL CHECK_ERR(IRET) -! - END DO ! IP=1,NBO2 - + ! + OPEN(NDSB,FILE='nest.ww3',form='UNFORMATTED', convert=file_endian,status='unknown') + ALLOCATE(DIMID(NBO2,3),DIMLN(NBO2,3),NCID(NBO2)) + + ALLOCATE(LATS(NBO2),LONS(NBO2),STATION(16,NBO2)) + + DO IP=1,NBO2 + ! open file + OPEN(NDSC,FILE=TRIM(SPECFILES(IP)),form='UNFORMATTED', convert=file_endian, & + status='old',iostat=ICODE) + IF (ICODE.NE.0) THEN + LONS(IP)=-999. + LATS(IP)=-999. + WRITE (NDSE,1010) TRIM(SPECFILES(IP)) + CALL EXTCDE ( 70 ) + END IF + IRET=NF90_OPEN(TRIM(SPECFILES(IP)),NF90_NOWRITE,NCID(IP)) + WRITE(6,*) 'Opening file:',TRIM(SPECFILES(IP)) + CALL CHECK_ERR(IRET) + + ! dimensions + IRET=NF90_INQ_DIMID(NCID(IP),'time',DIMID(IP,1)) + CALL CHECK_ERR(IRET) + IRET=NF90_INQ_DIMID(NCID(IP),'frequency',DIMID(IP,2)) + CALL CHECK_ERR(IRET) + IRET=NF90_INQ_DIMID(NCID(IP),'direction',DIMID(IP,3)) + CALL CHECK_ERR(IRET) + IRET=NF90_INQUIRE_DIMENSION(NCID(IP),DIMID(IP,1),len=DIMLN(IP,1)) + CALL CHECK_ERR(IRET) + IRET=NF90_INQUIRE_DIMENSION(NCID(IP),DIMID(IP,2),len=DIMLN(IP,2)) + CALL CHECK_ERR(IRET) + IRET=NF90_INQUIRE_DIMENSION(NCID(IP),DIMID(IP,3),len=DIMLN(IP,3)) + CALL CHECK_ERR(IRET) + + NTI=DIMLN(IP,1) + NKI=DIMLN(IP,2) + NTHI=DIMLN(IP,3) + + IF (IP.EQ.1) THEN + NT1=NTI + NK1=NKI + NTH1=NTHI + NSPEC1 = NK1 * NTH1 + ALLOCATE(TIMES(NT1)) + ALLOCATE (FREQ(NK1),THETA(NTH1)) + ALLOCATE (SPEC2D(NTH1,NK1,NT1,NBO2)) + ALLOCATE (ABPIN2(NK*NTH,NT1,NBO2)) + + ! instanciates time + REFDATE(:)=0. + IRET=NF90_INQ_VARID(NCID(IP),"time",VARID(1)) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID(IP), VARID(1), TIMES(:)) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_ATT(NCID(IP),VARID(1),"calendar",CALENDAR) + IF ( IRET/=NF90_NOERR ) THEN + WRITE(NDSE,951) + ELSE IF ((INDEX(CALENDAR, "standard").EQ.0) .AND. & + (INDEX(CALENDAR, "gregorian").EQ.0)) THEN + WRITE(NDSE,952) + END IF + IRET=NF90_GET_ATT(NCID(IP),VARID(1),"units",TIMEUNITS) + CALL U2D(TIMEUNITS,REFDATE,IERR) + CALL D2J(REFDATE,REFJULDAY,IERR) + + ELSE + IF (NKI.NE.NK1.OR.NTHI.NE.NTH1.OR.NT1.NE.NTI & + ) GOTO 805 + END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6. Checks on spectral discretization -! reminder: fr(NK)=fr1*XFR**(NK-1) -! - FR1I=FREQ(1) - XFRI=EXP(ALOG(FREQ(NKI)/FREQ(1))/(NKI-1)) - TH1I=THETA(1) + ! position variables : lon/lat or x/y + IF ( FLAGLL ) THEN + IRET=NF90_INQ_VARID(NCID(IP), 'latitude', VARID(2)) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID(IP), VARID(2), LATS(IP)) + CALL CHECK_ERR(IRET) + IRET=NF90_INQ_VARID(NCID(IP), 'longitude', VARID(3)) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID(IP), VARID(3), LONS(IP)) + CALL CHECK_ERR(IRET) + ELSE + IRET=NF90_INQ_VARID(NCID(IP), 'y', VARID(2)) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID(IP), VARID(2), LATS(IP)) + CALL CHECK_ERR(IRET) + IRET=NF90_INQ_VARID(NCID(IP), 'x', VARID(3)) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID(IP), VARID(3), LONS(IP)) + CALL CHECK_ERR(IRET) + END IF - SPCONV = NKI.NE.NK .OR. NTHI.NE.NTH .OR. & - ABS(XFRI/XFR-1.).GT.0.01 .OR. & - ABS(FR1I/FR1-1.).GT.0.01 .OR. & - ABS(TH1I-TH(1)).GT.0.01*DTH + ! freq and dir variables + IRET=NF90_INQ_VARID(NCID(IP),"frequency",VARID(4)) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID(IP),VARID(4),FREQ) + CALL CHECK_ERR(IRET) + IRET=NF90_INQ_VARID(NCID(IP),"direction",VARID(5)) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID(IP),VARID(5),THETA) + CALL CHECK_ERR(IRET) + THETA=MOD(2.5*PI-(PI/180)*THETA,TPI) + + ! 2D spectra depending on station name or lat/lon + IRET=NF90_INQ_VARID(NCID(IP),"efth",VARID(7)) + IF (IRET.NE.0) IRET=NF90_INQ_VARID(NCID(IP),"Efth",VARID(7)) + CALL CHECK_ERR(IRET) + IRET=NF90_INQUIRE_VARIABLE(NCID(IP),VARID(7),XTYPE=VARTYPE) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_ATT(NCID(IP),VARID(7),"_FillValue",FILLVAL) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_ATT(NCID(IP),VARID(7),"scale_factor",FACTOR) + IF (IRET.NE.0) FACTOR=1. + IRET=NF90_GET_ATT(NCID(IP),VARID(7),"add_offset",OFFSET) + IF (IRET.NE.0) OFFSET=0. + IRET = NF90_INQ_VARID(NCID(IP), 'station_name', VARID(6)) + IF (IRET.NE.0) THEN + ! efth(time, frequency, direction, latitude, longitude) + IRET=NF90_GET_VAR(NCID(IP),VARID(7),SPEC2D(:,:,:,IP), & + start=(/1,1,1,1/),count=(/1,1,NTHI,NKI,NTI/)) + CALL CHECK_ERR(IRET) + ELSE + ! efth(time, station, frequency, direction) + IRET=NF90_GET_VAR(NCID(IP),VARID(7),SPEC2D(:,:,:,IP), & + start=(/1,1,1,1/),count=(/NTHI,NKI,1,NTI/)) + CALL CHECK_ERR(IRET) + END IF + ! apply scale_factor and add_offset + IF (VARTYPE.EQ.NF90_SHORT) THEN + WHERE(SPEC2D(:,:,:,IP).NE.FILLVAL) SPEC2D(:,:,:,IP)=(EXP(SPEC2D(:,:,:,IP)*FACTOR*LOG(10.)))-1e-12 + ELSE + WHERE(SPEC2D(:,:,:,IP).NE.FILLVAL) SPEC2D(:,:,:,IP)=(SPEC2D(:,:,:,IP)*FACTOR)+OFFSET + END IF - IF (VERBOSE.GE.1) WRITE(NDSO,*) 'SPCONV:', SPCONV, NKI, NK, NTHI, NTH -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 7. Loops on files and instanciate ABPIN2 -! - IF ( .NOT. SPCONV ) THEN - - DO IP=1,NBO2 -! Copies spectrum in frequency and direction ranges - DO I=1,NK - DO J=1,NTH - ABPIN2((I-1)*NTH+J,:,IP)=SPEC2D(J,I,:,IP)*tpiinv - END DO - END DO - END DO ! IP=1,NBO2 -! + ! close spectra file + IRET=NF90_CLOSE(NCID(IP)) + CALL CHECK_ERR(IRET) + ! + END DO ! IP=1,NBO2 + + + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6. Checks on spectral discretization + ! reminder: fr(NK)=fr1*XFR**(NK-1) + ! + FR1I=FREQ(1) + XFRI=EXP(ALOG(FREQ(NKI)/FREQ(1))/(NKI-1)) + TH1I=THETA(1) + + SPCONV = NKI.NE.NK .OR. NTHI.NE.NTH .OR. & + ABS(XFRI/XFR-1.).GT.0.01 .OR. & + ABS(FR1I/FR1-1.).GT.0.01 .OR. & + ABS(TH1I-TH(1)).GT.0.01*DTH + + IF (VERBOSE.GE.1) WRITE(NDSO,*) 'SPCONV:', SPCONV, NKI, NK, NTHI, NTH + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 7. Loops on files and instanciate ABPIN2 + ! + IF ( .NOT. SPCONV ) THEN + + DO IP=1,NBO2 + ! Copies spectrum in frequency and direction ranges + DO I=1,NK + DO J=1,NTH + ABPIN2((I-1)*NTH+J,:,IP)=SPEC2D(J,I,:,IP)*tpiinv + END DO + END DO + END DO ! IP=1,NBO2 + ! + ELSE + ALLOCATE(TMPSPCI(NKI*NTHI,NTI)) + ALLOCATE(TMPSPCO(NK*NTH, NTI)) + DO IP=1,NBO2 + DO I=1,NKI + DO J=1,NTHI + TMPSPCI((I-1)*NTHI+J,:)=SPEC2D(J,I,:,IP)*tpiinv + END DO + END DO + CALL W3CSPC ( TMPSPCI, NKI, NTHI, XFRI, FR1I, TH1I, & + TMPSPCO, NK, NTH, XFR, FR1, TH(1),& + NTI, NDST, NDSE, FACHFE ) + ABPIN2(:,:,IP)=TMPSPCO(:,:) + END DO + ! + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 8. Writes header + ! + ! Writes header in nest.ww3 file + WRITE(NDSB) IDSTRBC, VERBPTBC, NK, NTH, XFR, FR1, & + TH(1), NBO + IPBPO(:,:)=1 + RDBPO(:,1)=1. + RDBPO(:,2:4)=0. + + ! Loops on points + DO IP1=1,NBO + DMIN=360.+180. + DMIN2=360.+180. + ! Loops on files + DO IP=1,NBO2 + ! Searches for the nearest 2 points where spectra are available + IF (FLAGLL) THEN + DIST=DIST_SPHERE ( LONS(IP),LATS(IP),XBPO(IP1),YBPO(IP1) ) ELSE - ALLOCATE(TMPSPCI(NKI*NTHI,NTI)) - ALLOCATE(TMPSPCO(NK*NTH, NTI)) - DO IP=1,NBO2 - DO I=1,NKI - DO J=1,NTHI - TMPSPCI((I-1)*NTHI+J,:)=SPEC2D(J,I,:,IP)*tpiinv - END DO - END DO - CALL W3CSPC ( TMPSPCI, NKI, NTHI, XFRI, FR1I, TH1I, & - TMPSPCO, NK, NTH, XFR, FR1, TH(1),& - NTI, NDST, NDSE, FACHFE ) - ABPIN2(:,:,IP)=TMPSPCO(:,:) - END DO -! - END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 8. Writes header -! -! Writes header in nest.ww3 file - WRITE(NDSB) IDSTRBC, VERBPTBC, NK, NTH, XFR, FR1, & - TH(1), NBO - IPBPO(:,:)=1 - RDBPO(:,1)=1. - RDBPO(:,2:4)=0. - -! Loops on points - DO IP1=1,NBO - DMIN=360.+180. - DMIN2=360.+180. -! Loops on files - DO IP=1,NBO2 -! Searches for the nearest 2 points where spectra are available - IF (FLAGLL) THEN - DIST=DIST_SPHERE ( LONS(IP),LATS(IP),XBPO(IP1),YBPO(IP1) ) - ELSE - DIST=SQRT((LONS(IP)-XBPO(IP1))**2+(LATS(IP)-YBPO(IP1))**2) - END IF - IF (DMIN.EQ.(360.+180.)) THEN - IF(DIST.LT.DMIN) THEN - IPBPO(IP1,1)=IP - DMIN=DIST - END IF + DIST=SQRT((LONS(IP)-XBPO(IP1))**2+(LATS(IP)-YBPO(IP1))**2) + END IF + IF (DMIN.EQ.(360.+180.)) THEN + IF(DIST.LT.DMIN) THEN + IPBPO(IP1,1)=IP + DMIN=DIST + END IF + ELSE + IF(DIST.LT.DMIN2) THEN + IF(DIST.LT.DMIN) THEN + IPBPO(IP1,2)=IPBPO(IP1,1) + DMIN2=DMIN + IPBPO(IP1,1)=IP + DMIN=DIST ELSE - IF(DIST.LT.DMIN2) THEN - IF(DIST.LT.DMIN) THEN - IPBPO(IP1,2)=IPBPO(IP1,1) - DMIN2=DMIN - IPBPO(IP1,1)=IP - DMIN=DIST - ELSE - IPBPO(IP1,2)=IP - DMIN2=DIST - END IF - END IF - END IF - END DO ! IP1=1,NBO2 - IF (VERBOSE.GE.1) WRITE(NDSO,*) 'DIST:',DMIN,DMIN2,IP1,IPBPO(IP1,1),IPBPO(IP1,2), & - LONS(IPBPO(IP1,1)),LONS(IPBPO(IP1,2)),XBPO(IP1), & - LATS(IPBPO(IP1,1)),LATS(IPBPO(IP1,2)),YBPO(IP1) - - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 9. Computes linear interpolation coefficient between the nearest 2 points -! - IF (INTERP.GT.1.AND.NBO2.GT.1) THEN - IF (FLAGLL) THEN - DLON=LONS(IPBPO(IP1,2))-LONS(IPBPO(IP1,1)) - DLAT=LATS(IPBPO(IP1,2))-LATS(IPBPO(IP1,1)) - DLO=XBPO(IP1)-LONS(IPBPO(IP1,1)) - IF (DLON.GT.180.) DLON=DLON-360 - IF (DLON.LT.-180.) DLON=DLON+360 - IF (DLO.GT.180.) DLO=DLO-360 - IF (DLO.LT.-180.) DLO=DLO+360 - DIST=SQRT(DLON**2+DLAT**2) - COS1=( DLO*DLON & - + (YBPO(IP1)-LATS(IPBPO(IP1,1))) & - *DLAT )/(DIST**2) - ELSE - DIST=SQRT((LONS(IPBPO(IP1,1))-LONS(IPBPO(IP1,2)))**2 & - +(LATS(IPBPO(IP1,1))-LATS(IPBPO(IP1,2)))**2) - COS1=( (XBPO(IP1)-LONS(IPBPO(IP1,1))) & - *(LONS(IPBPO(IP1,2))-LONS(IPBPO(IP1,1))) & - + (YBPO(IP1)-LATS(IPBPO(IP1,1))) & - *(LATS(IPBPO(IP1,2))-LATS(IPBPO(IP1,1))) )/(DIST**2) + IPBPO(IP1,2)=IP + DMIN2=DIST END IF - !COS2=( (XBPO(IP1)-LONS(IPBPO(IP1,2))) & - ! *(LONS(IPBPO(IP1,1))-LONS(IPBPO(IP1,2))) - ! + (YBPO(IP1)-LATS(IPBPO(IP1,2))) & - ! *(LATS(IPBPO(IP1,1))-LATS(IPBPO(IP1,2))))/(DIST**2) - RDBPO(IP1,1)=1-MIN(1.,MAX(0.,COS1)) - RDBPO(IP1,2)=MIN(1.,MAX(0.,COS1)) - ELSE - ! in this case: nearest point - RDBPO(IP1,1)=1. - RDBPO(IP1,2:4)=0. END IF - IF (VERBOSE.GE.1) WRITE(NDSO,*) 'IPBP:',IP1,(IPBPO(IP1,J),J=1,4) - IF (VERBOSE.GE.1) WRITE(NDSO,*) 'RDBP:',IP1,(RDBPO(IP1,J),J=1,4) - !IF (VERBOSE.GE.1) WRITE(NDSO,*) 'RDBP:',COS1,DIST,DLON,DLO,DLAT,XBPO(IP1)-360.,LONS(IPBPO(IP1,1)),LONS(IPBPO(IP1,2)) - END DO ! IP1=1,NBO - - WRITE(NDSB) (XBPO(I),I=1,NBO), & - (YBPO(I),I=1,NBO), & - ((IPBPO(I,J),I=1,NBO),J=1,4), & - ((RDBPO(I,J),I=1,NBO),J=1,4) - - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 10. Loops on times and files and write to nest.ww3 -! - DO IT=1,NT1 - CURJULDAY=TIMES(IT) - IF (INDEX(TIMEUNITS, "seconds").NE.0) CURJULDAY=CURJULDAY/86400. - IF (INDEX(TIMEUNITS, "minutes").NE.0) CURJULDAY=CURJULDAY/1440. - IF (INDEX(TIMEUNITS, "hours").NE.0) CURJULDAY=CURJULDAY/24. - CURJULDAY=REFJULDAY+CURJULDAY - - ! convert julday to date and time - CALL J2D(CURJULDAY,CURDATE,IERR) - CALL D2T(CURDATE,TIME,IERR) - - ! write to output file nest.ww3 - WRITE(NDSO,'(A,2I9,A,I6,A,G16.5)') 'Writing boundary data for time:', & - TIME, ' at ',NBO2,' points. Max.: ', MAXVAL(ABPIN2(:,IT,:)) - WRITE(NDSB,IOSTAT=IERR) TIME, NBO2 - DO IP=1, NBO2 - WRITE(NDSB) ABPIN2(:,IT,IP) - END DO - END DO ! IT=0,NT1 - CLOSE(NDSB) - - END IF ! INXOUT.EQ.'WRITE' - - GOTO 888 - -! -! Escape locations read errors : -! - - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 61 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 62 ) -! - 803 CONTINUE - WRITE (NDSE,1003) IDTST, IDSTRBC - CALL EXTCDE ( 63 ) -! - 804 CONTINUE - WRITE (NDSE,1004) - CALL EXTCDE ( 64 ) -! - 805 CONTINUE - WRITE (NDSE,1005) TRIM(SPECFILES(IP)), NKI, NK1, NTHI, NTH1, NTI, NT1 - CALL EXTCDE ( 65 ) -! - 809 CONTINUE - WRITE (NDSE,1009) FILE, IERR - CALL EXTCDE ( 69 ) -! - 888 CONTINUE - WRITE (NDSO,999) - - -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Bounday input prep. *** '/ & - 15X,'==============================================='/) -! - 901 FORMAT ( ' Comment character is ''',A,''''/) -! - 920 FORMAT ( ' Grid name : ',A/) -! - 940 FORMAT ( ' Format version : ',A/) -! - 941 FORMAT ( ' File type : ',A/) -! - 951 FORMAT (/' *** WAVEWATCH III WARNING IN W3BOUNC : '/ & - ' CALENDAR ATTRIBUTE NOT DEFINED'/ & - ' IT MUST RESPECT STANDARD OR GREGORIAN CALENDAR') -! - 952 FORMAT (/' *** WAVEWATCH III WARNING IN W3BOUNC : '/ & - ' CALENDAR ATTRIBUTE NOT MATCH'/ & - ' IT MUST RESPECT STANDARD OR GREGORIAN CALENDAR') -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Boundary input '/) -! - 1001 FORMAT (/' *** WAVEWATCH-III ERROR IN W3BOUNC : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUNC: '/ & - ' ERROR IN READING ',A,' FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH-III ERROR IN W3IOBC :'/ & - ' ILLEGAL IDSTR, READ : ',A/ & - ' CHECK : ',A/) -! - 1004 FORMAT (/' *** WAVEWATCH-III ERROR IN W3BOUNC : '/ & - ' PREMATURE END OF NEST FILE'/) -! - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUNC: '/ & - ' INCONSISTENT SPECTRAL DIMENSION FOR FILE ',A/ & - ' NKI =',I3,' DIFFERS FROM NK1 =',I3/ & - ' OR NTHI =',I3,' DIFFERS FROM NTH1 =',I3/ & - ' OR NTI =',I5,' DIFFERS FROM NT1 =',I5 /) -! - 1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUNC : '/ & - ' ERROR IN OPENING SPEC FILE: ', A/ & - ' IOSTAT =',I5/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUNC : '/ & - ' SPEC FILE DOES NOT EXIST : ',A/) -! -! -!/ -!/ End of W3BOUNC ---------------------------------------------------- / -!/ - END PROGRAM W3BOUNC + END IF + END DO ! IP1=1,NBO2 + IF (VERBOSE.GE.1) WRITE(NDSO,*) 'DIST:',DMIN,DMIN2,IP1,IPBPO(IP1,1),IPBPO(IP1,2), & + LONS(IPBPO(IP1,1)),LONS(IPBPO(IP1,2)),XBPO(IP1), & + LATS(IPBPO(IP1,1)),LATS(IPBPO(IP1,2)),YBPO(IP1) + + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 9. Computes linear interpolation coefficient between the nearest 2 points + ! + IF (INTERP.GT.1.AND.NBO2.GT.1) THEN + IF (FLAGLL) THEN + DLON=LONS(IPBPO(IP1,2))-LONS(IPBPO(IP1,1)) + DLAT=LATS(IPBPO(IP1,2))-LATS(IPBPO(IP1,1)) + DLO=XBPO(IP1)-LONS(IPBPO(IP1,1)) + IF (DLON.GT.180.) DLON=DLON-360 + IF (DLON.LT.-180.) DLON=DLON+360 + IF (DLO.GT.180.) DLO=DLO-360 + IF (DLO.LT.-180.) DLO=DLO+360 + DIST=SQRT(DLON**2+DLAT**2) + COS1=( DLO*DLON & + + (YBPO(IP1)-LATS(IPBPO(IP1,1))) & + *DLAT )/(DIST**2) + ELSE + DIST=SQRT((LONS(IPBPO(IP1,1))-LONS(IPBPO(IP1,2)))**2 & + +(LATS(IPBPO(IP1,1))-LATS(IPBPO(IP1,2)))**2) + COS1=( (XBPO(IP1)-LONS(IPBPO(IP1,1))) & + *(LONS(IPBPO(IP1,2))-LONS(IPBPO(IP1,1))) & + + (YBPO(IP1)-LATS(IPBPO(IP1,1))) & + *(LATS(IPBPO(IP1,2))-LATS(IPBPO(IP1,1))) )/(DIST**2) + END IF + !COS2=( (XBPO(IP1)-LONS(IPBPO(IP1,2))) & + ! *(LONS(IPBPO(IP1,1))-LONS(IPBPO(IP1,2))) + ! + (YBPO(IP1)-LATS(IPBPO(IP1,2))) & + ! *(LATS(IPBPO(IP1,1))-LATS(IPBPO(IP1,2))))/(DIST**2) + RDBPO(IP1,1)=1-MIN(1.,MAX(0.,COS1)) + RDBPO(IP1,2)=MIN(1.,MAX(0.,COS1)) + ELSE + ! in this case: nearest point + RDBPO(IP1,1)=1. + RDBPO(IP1,2:4)=0. + END IF + IF (VERBOSE.GE.1) WRITE(NDSO,*) 'IPBP:',IP1,(IPBPO(IP1,J),J=1,4) + IF (VERBOSE.GE.1) WRITE(NDSO,*) 'RDBP:',IP1,(RDBPO(IP1,J),J=1,4) + !IF (VERBOSE.GE.1) WRITE(NDSO,*) 'RDBP:',COS1,DIST,DLON,DLO,DLAT,XBPO(IP1)-360.,LONS(IPBPO(IP1,1)),LONS(IPBPO(IP1,2)) + END DO ! IP1=1,NBO + + WRITE(NDSB) (XBPO(I),I=1,NBO), & + (YBPO(I),I=1,NBO), & + ((IPBPO(I,J),I=1,NBO),J=1,4), & + ((RDBPO(I,J),I=1,NBO),J=1,4) + + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 10. Loops on times and files and write to nest.ww3 + ! + DO IT=1,NT1 + CURJULDAY=TIMES(IT) + IF (INDEX(TIMEUNITS, "seconds").NE.0) CURJULDAY=CURJULDAY/86400. + IF (INDEX(TIMEUNITS, "minutes").NE.0) CURJULDAY=CURJULDAY/1440. + IF (INDEX(TIMEUNITS, "hours").NE.0) CURJULDAY=CURJULDAY/24. + CURJULDAY=REFJULDAY+CURJULDAY + + ! convert julday to date and time + CALL J2D(CURJULDAY,CURDATE,IERR) + CALL D2T(CURDATE,TIME,IERR) + + ! write to output file nest.ww3 + WRITE(NDSO,'(A,2I9,A,I6,A,G16.5)') 'Writing boundary data for time:', & + TIME, ' at ',NBO2,' points. Max.: ', MAXVAL(ABPIN2(:,IT,:)) + WRITE(NDSB,IOSTAT=IERR) TIME, NBO2 + DO IP=1, NBO2 + WRITE(NDSB) ABPIN2(:,IT,IP) + END DO + END DO ! IT=0,NT1 + CLOSE(NDSB) + + END IF ! INXOUT.EQ.'WRITE' + + GOTO 888 + + ! + ! Escape locations read errors : + ! + +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 61 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 62 ) + ! +803 CONTINUE + WRITE (NDSE,1003) IDTST, IDSTRBC + CALL EXTCDE ( 63 ) + ! +804 CONTINUE + WRITE (NDSE,1004) + CALL EXTCDE ( 64 ) + ! +805 CONTINUE + WRITE (NDSE,1005) TRIM(SPECFILES(IP)), NKI, NK1, NTHI, NTH1, NTI, NT1 + CALL EXTCDE ( 65 ) + ! +809 CONTINUE + WRITE (NDSE,1009) FILE, IERR + CALL EXTCDE ( 69 ) + ! +888 CONTINUE + WRITE (NDSO,999) + + + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Bounday input prep. *** '/ & + 15X,'==============================================='/) + ! +901 FORMAT ( ' Comment character is ''',A,''''/) + ! +920 FORMAT ( ' Grid name : ',A/) + ! +940 FORMAT ( ' Format version : ',A/) + ! +941 FORMAT ( ' File type : ',A/) + ! +951 FORMAT (/' *** WAVEWATCH III WARNING IN W3BOUNC : '/ & + ' CALENDAR ATTRIBUTE NOT DEFINED'/ & + ' IT MUST RESPECT STANDARD OR GREGORIAN CALENDAR') + ! +952 FORMAT (/' *** WAVEWATCH III WARNING IN W3BOUNC : '/ & + ' CALENDAR ATTRIBUTE NOT MATCH'/ & + ' IT MUST RESPECT STANDARD OR GREGORIAN CALENDAR') + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Boundary input '/) + ! +1001 FORMAT (/' *** WAVEWATCH-III ERROR IN W3BOUNC : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUNC: '/ & + ' ERROR IN READING ',A,' FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1003 FORMAT (/' *** WAVEWATCH-III ERROR IN W3IOBC :'/ & + ' ILLEGAL IDSTR, READ : ',A/ & + ' CHECK : ',A/) + ! +1004 FORMAT (/' *** WAVEWATCH-III ERROR IN W3BOUNC : '/ & + ' PREMATURE END OF NEST FILE'/) + ! +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUNC: '/ & + ' INCONSISTENT SPECTRAL DIMENSION FOR FILE ',A/ & + ' NKI =',I3,' DIFFERS FROM NK1 =',I3/ & + ' OR NTHI =',I3,' DIFFERS FROM NTH1 =',I3/ & + ' OR NTI =',I5,' DIFFERS FROM NT1 =',I5 /) + ! +1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUNC : '/ & + ' ERROR IN OPENING SPEC FILE: ', A/ & + ' IOSTAT =',I5/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUNC : '/ & + ' SPEC FILE DOES NOT EXIST : ',A/) + ! + ! + !/ + !/ End of W3BOUNC ---------------------------------------------------- / + !/ +END PROGRAM W3BOUNC !/ ------------------------------------------------------------------- / @@ -852,25 +852,24 @@ END PROGRAM W3BOUNC !> @param IRET return status to check !> !> @author NA @date NA - SUBROUTINE CHECK_ERR(IRET) +SUBROUTINE CHECK_ERR(IRET) - USE NETCDF - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE + USE NETCDF + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE - IMPLICIT NONE + IMPLICIT NONE - INTEGER IRET + INTEGER IRET - IF (IRET .NE. NF90_NOERR) THEN - WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN BOUNC :' - WRITE(NDSE,*) ' NETCDF ERROR MESSAGE: ' - WRITE(NDSE,*) NF90_STRERROR(IRET) - CALL EXTCDE ( 59 ) - END IF - RETURN + IF (IRET .NE. NF90_NOERR) THEN + WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN BOUNC :' + WRITE(NDSE,*) ' NETCDF ERROR MESSAGE: ' + WRITE(NDSE,*) NF90_STRERROR(IRET) + CALL EXTCDE ( 59 ) + END IF + RETURN - END SUBROUTINE CHECK_ERR +END SUBROUTINE CHECK_ERR !============================================================================== - diff --git a/model/src/ww3_bound.F90 b/model/src/ww3_bound.F90 index ae9db26b6..74e363fa9 100644 --- a/model/src/ww3_bound.F90 +++ b/model/src/ww3_bound.F90 @@ -12,490 +12,490 @@ !> subroutine W3IORS. Note that the name of the restart file is set !> in W3IORS. !> @author F. Ardhuin @date 21-Jul-2020 - PROGRAM W3BOUND -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2021 | -!/ +-----------------------------------+ -!/ -!/ 28-Aug-2012 : adaptation from SHOM/Ifremer code ( version 4.08 ) -!/ 01-Nov-2012 : Bug correction for NKI != NK ( version 4.08 ) -!/ 20-Oct-2016 : Error statement updates ( version 5.15 ) -!/ 21-Jul-2020 : Support rotated pole grid ( version 7.11 ) -!/ Chris Bunney, UKMO. -!/ 27-May-2021 : Add namelist feature ( version 7.XX ) -!/ -!/ Copyright 2012-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Combines spectra files into a nest.ww3 file for boundary conditions -! -! 2. Method : -! -! Finds nearest points and performs linear interpolation -! -! The initial conditions are written to the restart.ww3 using the -! subroutine W3IORS. Note that the name of the restart file is set -! in W3IORS. -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! NDSI Int. Input unit number ("ww3_bound.inp"). -! ITYPE Int. Type of data -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! WAVNU1 Subr. W3DISPMD Solve dispersion relation. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3EQTOLL Subr W3SERVMD Convert coordinates from rotated pole. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Can be used also to diagnose contents of nest.ww3 file -! in read mode -! -! - Input spectra are assumed to be formulated on a standard -! pole. However, the model grid can be on a rotated pole. -! -! 8. Structure : -! -! ---------------------------------------------------- -! 1.a Set up data structures. -! ( W3NMOD , W3NDAT , W3NOUT -! W3SETG , W3SETW , W3SETO ) -! b I-O setup. -! .... -! 9. Convert energy to action -! 10. Write restart file. ( W3IORS ) -! ---------------------------------------------------- -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! -! !/O4 Output normalized 1-D energy spectrum. -! !/O5 Output normalized 2-D energy spectrum. -! !/O6 Output normalized wave heights (not MPP adapted). -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3WDATMD, ONLY: W3NDAT, W3SETW - USE W3ADATMD, ONLY: W3NAUX, W3SETA - USE W3ODATMD, ONLY: W3NOUT, W3SETO, FLBPI +PROGRAM W3BOUND + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2021 | + !/ +-----------------------------------+ + !/ + !/ 28-Aug-2012 : adaptation from SHOM/Ifremer code ( version 4.08 ) + !/ 01-Nov-2012 : Bug correction for NKI != NK ( version 4.08 ) + !/ 20-Oct-2016 : Error statement updates ( version 5.15 ) + !/ 21-Jul-2020 : Support rotated pole grid ( version 7.11 ) + !/ Chris Bunney, UKMO. + !/ 27-May-2021 : Add namelist feature ( version 7.XX ) + !/ + !/ Copyright 2012-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Combines spectra files into a nest.ww3 file for boundary conditions + ! + ! 2. Method : + ! + ! Finds nearest points and performs linear interpolation + ! + ! The initial conditions are written to the restart.ww3 using the + ! subroutine W3IORS. Note that the name of the restart file is set + ! in W3IORS. + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! NDSI Int. Input unit number ("ww3_bound.inp"). + ! ITYPE Int. Type of data + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! WAVNU1 Subr. W3DISPMD Solve dispersion relation. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3EQTOLL Subr W3SERVMD Convert coordinates from rotated pole. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Can be used also to diagnose contents of nest.ww3 file + ! in read mode + ! + ! - Input spectra are assumed to be formulated on a standard + ! pole. However, the model grid can be on a rotated pole. + ! + ! 8. Structure : + ! + ! ---------------------------------------------------- + ! 1.a Set up data structures. + ! ( W3NMOD , W3NDAT , W3NOUT + ! W3SETG , W3SETW , W3SETO ) + ! b I-O setup. + ! .... + ! 9. Convert energy to action + ! 10. Write restart file. ( W3IORS ) + ! ---------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/SHRD Switch for message passing method. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! + ! !/O4 Output normalized 1-D energy spectrum. + ! !/O5 Output normalized 2-D energy spectrum. + ! !/O6 Output normalized wave heights (not MPP adapted). + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3WDATMD, ONLY: W3NDAT, W3SETW + USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ODATMD, ONLY: W3NOUT, W3SETO, FLBPI - USE W3GDATMD, ONLY: NK, NTH, XFR, FR1, GNAME, W3NMOD, W3SETG, & - NSEA, MAPSTA, GTYPE, XGRD, YGRD, X0, Y0, & - SX, SY, MAPSF, UNGTYPE, CLGTYPE, RLGTYPE + USE W3GDATMD, ONLY: NK, NTH, XFR, FR1, GNAME, W3NMOD, W3SETG, & + NSEA, MAPSTA, GTYPE, XGRD, YGRD, X0, Y0, & + SX, SY, MAPSF, UNGTYPE, CLGTYPE, RLGTYPE #ifdef W3_RTD - USE W3GDATMD, ONLY : POLAT, POLON + USE W3GDATMD, ONLY : POLAT, POLON #endif - USE W3ODATMD, ONLY: NDSO, NDSE, FNMPRE - USE W3IOBCMD, ONLY: VERBPTBC, IDSTRBC - USE W3IOGRMD, ONLY: W3IOGR - USE W3TIMEMD - USE W3NMLBOUNDMD - USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE + USE W3ODATMD, ONLY: NDSO, NDSE, FNMPRE + USE W3IOBCMD, ONLY: VERBPTBC, IDSTRBC + USE W3IOGRMD, ONLY: W3IOGR + USE W3TIMEMD + USE W3NMLBOUNDMD + USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE #ifdef W3_RTD - USE W3SERVMD, ONLY: W3EQTOLL + USE W3SERVMD, ONLY: W3EQTOLL #endif #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif -!/ - IMPLICIT NONE -! + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(NML_BOUND_T) :: NML_BOUND -! - INTEGER :: TIME1(2) !< initial time - INTEGER :: TIME2(2) !< next time - INTEGER :: IX !< x index - INTEGER :: IY !< y index - INTEGER :: ISEA !< isea index - INTEGER :: I !< i index - INTEGER :: JJ !< jj index - INTEGER :: IP !< boundary index - INTEGER :: IP1 !< boundary index - INTEGER :: J !< j index - INTEGER :: K !< k index - INTEGER :: ITIME !< time index - INTEGER :: NDSI !< input file unit - INTEGER :: NDSM !< mod_def file unit - INTEGER :: NDSI2 !< tmp input file unit - INTEGER :: NDSS !< scratch file unit - INTEGER :: NDSB !< nest file unit - INTEGER :: NDSTRC !< trace file unit - INTEGER :: NTRACE !< trace file unit - INTEGER :: NK1 !< frequency bins number - INTEGER :: NTH1 !< direction bins number - INTEGER :: NSPEC1 !< spectral bins number - INTEGER :: NBI !< number of input boundary points - INTEGER :: NBI2 !< number of input boundary points - INTEGER :: NKI !< frequency bins number from input spec file - INTEGER :: NTHI !< direction bins number from input spec file - INTEGER :: NBO !< number of boundary outputs - INTEGER :: NBO2 !< number of boundary outputs - INTEGER :: IERR !< error code - INTEGER :: INTERP !< interpolation method - INTEGER :: ILOOP !< loop indice - INTEGER :: IFMIN !< min freq value from input spec file - INTEGER :: IFMIN2 !< min freq value for output spectra - INTEGER :: IFMAX !< max freq value from input spec file - INTEGER :: VERBOSE !< verbose flag - INTEGER :: NDSL !< input spec listing file unit + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(NML_BOUND_T) :: NML_BOUND + ! + INTEGER :: TIME1(2) !< initial time + INTEGER :: TIME2(2) !< next time + INTEGER :: IX !< x index + INTEGER :: IY !< y index + INTEGER :: ISEA !< isea index + INTEGER :: I !< i index + INTEGER :: JJ !< jj index + INTEGER :: IP !< boundary index + INTEGER :: IP1 !< boundary index + INTEGER :: J !< j index + INTEGER :: K !< k index + INTEGER :: ITIME !< time index + INTEGER :: NDSI !< input file unit + INTEGER :: NDSM !< mod_def file unit + INTEGER :: NDSI2 !< tmp input file unit + INTEGER :: NDSS !< scratch file unit + INTEGER :: NDSB !< nest file unit + INTEGER :: NDSTRC !< trace file unit + INTEGER :: NTRACE !< trace file unit + INTEGER :: NK1 !< frequency bins number + INTEGER :: NTH1 !< direction bins number + INTEGER :: NSPEC1 !< spectral bins number + INTEGER :: NBI !< number of input boundary points + INTEGER :: NBI2 !< number of input boundary points + INTEGER :: NKI !< frequency bins number from input spec file + INTEGER :: NTHI !< direction bins number from input spec file + INTEGER :: NBO !< number of boundary outputs + INTEGER :: NBO2 !< number of boundary outputs + INTEGER :: IERR !< error code + INTEGER :: INTERP !< interpolation method + INTEGER :: ILOOP !< loop indice + INTEGER :: IFMIN !< min freq value from input spec file + INTEGER :: IFMIN2 !< min freq value for output spectra + INTEGER :: IFMAX !< max freq value from input spec file + INTEGER :: VERBOSE !< verbose flag + INTEGER :: NDSL !< input spec listing file unit #ifdef W3_S - INTEGER, SAVE :: IENT = 0 !< strace error code + INTEGER, SAVE :: IENT = 0 !< strace error code #endif - INTEGER :: IBO !< indice of boundary output - INTEGER, ALLOCATABLE :: IPBPI(:,:) !< interp. data input bound. point - INTEGER, ALLOCATABLE :: IPBPO(:,:) !< interp. data output bound. point -! - REAL :: FR1I !< first freq from mod_def - REAL :: TH1I !< first dir. from mod_def - REAL :: depth !< depth from input spec - REAL :: U10 !< wind speed from input spec - REAL :: Udir !< wind dir. from input spec - REAL :: Curr !< cur. speed from input spec - REAL :: Currdir !< cur. dir. from input spec - REAL :: DMIN !< min. dist from grid point to spec - REAL :: DIST !< dist from grid point to spec - REAL :: DMIN2 !< second min. dist from grid point to spec - REAL :: COS1 !< cosine for linear interpolation -! - REAL, ALLOCATABLE :: LATS(:) !< latitude coordinates of spec - REAL, ALLOCATABLE :: LONS(:) !< longitude coordiantes of spec - REAL, ALLOCATABLE :: SPEC2D(:,:) !< spectrum from input spec - REAL, ALLOCATABLE :: FREQ(:) !< frequency array from input spec - REAL, ALLOCATABLE :: THETA(:) !< direction array from input spec - REAL, ALLOCATABLE :: XBPI(:) !< x position of input boundary - REAL, ALLOCATABLE :: YBPI(:) !< y position of input boundary - REAL, ALLOCATABLE :: RDBPI(:,:) !< interpolation factor input boundray point - REAL, ALLOCATABLE :: XBPO(:) !< x position of output bound. point - REAL, ALLOCATABLE :: YBPO(:) !< y position of output bound. point - REAL, ALLOCATABLE :: RDBPO(:,:) !< interp. factor output bound. point - REAL, ALLOCATABLE :: ABPIN(:,:) !< intepolated spectrum + INTEGER :: IBO !< indice of boundary output + INTEGER, ALLOCATABLE :: IPBPI(:,:) !< interp. data input bound. point + INTEGER, ALLOCATABLE :: IPBPO(:,:) !< interp. data output bound. point + ! + REAL :: FR1I !< first freq from mod_def + REAL :: TH1I !< first dir. from mod_def + REAL :: depth !< depth from input spec + REAL :: U10 !< wind speed from input spec + REAL :: Udir !< wind dir. from input spec + REAL :: Curr !< cur. speed from input spec + REAL :: Currdir !< cur. dir. from input spec + REAL :: DMIN !< min. dist from grid point to spec + REAL :: DIST !< dist from grid point to spec + REAL :: DMIN2 !< second min. dist from grid point to spec + REAL :: COS1 !< cosine for linear interpolation + ! + REAL, ALLOCATABLE :: LATS(:) !< latitude coordinates of spec + REAL, ALLOCATABLE :: LONS(:) !< longitude coordiantes of spec + REAL, ALLOCATABLE :: SPEC2D(:,:) !< spectrum from input spec + REAL, ALLOCATABLE :: FREQ(:) !< frequency array from input spec + REAL, ALLOCATABLE :: THETA(:) !< direction array from input spec + REAL, ALLOCATABLE :: XBPI(:) !< x position of input boundary + REAL, ALLOCATABLE :: YBPI(:) !< y position of input boundary + REAL, ALLOCATABLE :: RDBPI(:,:) !< interpolation factor input boundray point + REAL, ALLOCATABLE :: XBPO(:) !< x position of output bound. point + REAL, ALLOCATABLE :: YBPO(:) !< y position of output bound. point + REAL, ALLOCATABLE :: RDBPO(:,:) !< interp. factor output bound. point + REAL, ALLOCATABLE :: ABPIN(:,:) !< intepolated spectrum #ifdef W3_RTD - REAL, ALLOCATABLE :: XTMP(:) !< temporary x position - REAL, ALLOCATABLE :: YTMP(:) !< temporary y position - REAL, ALLOCATABLE :: ANGTMP(:) !< temporary angle - LOGICAL :: ISRTD !< rotated grid flag + REAL, ALLOCATABLE :: XTMP(:) !< temporary x position + REAL, ALLOCATABLE :: YTMP(:) !< temporary y position + REAL, ALLOCATABLE :: ANGTMP(:) !< temporary angle + LOGICAL :: ISRTD !< rotated grid flag #endif - CHARACTER :: COMSTR !< comment character - CHARACTER(LEN=80) :: LINE !< input file line - CHARACTER(LEN=128) :: BNDFILE !< input boundary file name - CHARACTER(LEN=5) :: INXOUT !< read/write mode - CHARACTER(LEN=10) :: VERTEST !< date of last nest.ww3 change - CHARACTER(LEN=32) :: IDTST !< 'WAVEWATCH III BOUNDARY DATA FILE' - CHARACTER(LEN=120) :: FILENAME !< input boundary file name - CHARACTER(LEN=120) :: string1 !< temporary string - CHARACTER(LEN=120) :: buoyname !< input boundary point name - CHARACTER :: space !< space character -! - CHARACTER(LEN=120), ALLOCATABLE :: SPECFILES(:) !< list of input boundary points file names -! - LOGICAL :: FLGNML !< flag for namelist use -!/ -!/ ------------------------------------------------------------------- / + CHARACTER :: COMSTR !< comment character + CHARACTER(LEN=80) :: LINE !< input file line + CHARACTER(LEN=128) :: BNDFILE !< input boundary file name + CHARACTER(LEN=5) :: INXOUT !< read/write mode + CHARACTER(LEN=10) :: VERTEST !< date of last nest.ww3 change + CHARACTER(LEN=32) :: IDTST !< 'WAVEWATCH III BOUNDARY DATA FILE' + CHARACTER(LEN=120) :: FILENAME !< input boundary file name + CHARACTER(LEN=120) :: string1 !< temporary string + CHARACTER(LEN=120) :: buoyname !< input boundary point name + CHARACTER :: space !< space character + ! + CHARACTER(LEN=120), ALLOCATABLE :: SPECFILES(:) !< list of input boundary points file names + ! + LOGICAL :: FLGNML !< flag for namelist use + !/ + !/ ------------------------------------------------------------------- / -!/ -! 1. IO set-up. -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! - NDSI = 10 - NDSB = 33 - NDSM = 20 - NDSS = 40 - NDSL = 50 -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + !/ + ! 1. IO set-up. + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + NDSI = 10 + NDSB = 33 + NDSM = 20 + NDSS = 40 + NDSL = 50 + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_S - CALL STRACE (IENT, 'W3BOUND') + CALL STRACE (IENT, 'W3BOUND') #endif -! + ! -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - WRITE (NDSO,920) GNAME + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + WRITE (NDSO,920) GNAME #ifdef W3_RTD -! - ISRTD = POLAT .LT. 90.0 -! + ! + ISRTD = POLAT .LT. 90.0 + ! #endif -! -! 3. Read input file -! -! process ww3_bound namelist -! - INQUIRE(FILE=TRIM(FNMPRE)//"ww3_bound.nml", EXIST=FLGNML) - IF (FLGNML) THEN - ! Read namelist - CALL W3NMLBOUND (NDSI, TRIM(FNMPRE)//'ww3_bound.nml', NML_BOUND, IERR) + ! + ! 3. Read input file + ! + ! process ww3_bound namelist + ! + INQUIRE(FILE=TRIM(FNMPRE)//"ww3_bound.nml", EXIST=FLGNML) + IF (FLGNML) THEN + ! Read namelist + CALL W3NMLBOUND (NDSI, TRIM(FNMPRE)//'ww3_bound.nml', NML_BOUND, IERR) - INXOUT = NML_BOUND%MODE - INTERP = NML_BOUND%INTERP - VERBOSE = NML_BOUND%VERBOSE - BNDFILE = NML_BOUND%FILE + INXOUT = NML_BOUND%MODE + INTERP = NML_BOUND%INTERP + VERBOSE = NML_BOUND%VERBOSE + BNDFILE = NML_BOUND%FILE - NBO2 = 0 - OPEN(NDSL,FILE=TRIM(BNDFILE),STATUS='OLD',ERR=809,IOSTAT=IERR) - REWIND (NDSL) - DO - READ (NDSL,*,END=400,ERR=802) - NBO2 = NBO2 + 1 - END DO - 400 CONTINUE - ALLOCATE(SPECFILES(NBO2)) - REWIND (NDSL) - DO I=1,NBO2 - READ (NDSL,'(A120)',END=801,ERR=802) SPECFILES(I) - END DO - CLOSE(NDSL) + NBO2 = 0 + OPEN(NDSL,FILE=TRIM(BNDFILE),STATUS='OLD',ERR=809,IOSTAT=IERR) + REWIND (NDSL) + DO + READ (NDSL,*,END=400,ERR=802) + NBO2 = NBO2 + 1 + END DO +400 CONTINUE + ALLOCATE(SPECFILES(NBO2)) + REWIND (NDSL) + DO I=1,NBO2 + READ (NDSL,'(A120)',END=801,ERR=802) SPECFILES(I) + END DO + CLOSE(NDSL) - END IF ! FLGNML + END IF ! FLGNML -! -! process old ww3_bound.inp format -! - IF (.NOT. FLGNML) THEN - OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_bound.inp',STATUS='OLD',ERR=803,IOSTAT=IERR) - REWIND (NDSI) + ! + ! process old ww3_bound.inp format + ! + IF (.NOT. FLGNML) THEN + OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_bound.inp',STATUS='OLD',ERR=803,IOSTAT=IERR) + REWIND (NDSI) - READ (NDSI,'(A)',END=801,ERR=802) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' + READ (NDSI,'(A)',END=801,ERR=802) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*) INXOUT - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*) INTERP - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*) VERBOSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) -! - NBO2 = 0 -! -! ILOOP = 1 to count NBO2 -! ILOOP = 2 to read the file names -! - DO ILOOP = 1, 2 - OPEN (NDSS,FILE='ww3_bound.scratch',FORM='FORMATTED', & - status='UNKNOWN') - IF ( ILOOP .EQ. 1 ) THEN - NDSI2 = NDSI - ELSE - NDSI2 = NDSS - ALLOCATE(SPECFILES(NBO2)) - NBO2=0 - ENDIF - - NBO2=0 -! Read input file names - DO - CALL NEXTLN ( COMSTR , NDSI2 , NDSE ) - READ (NDSI2,'(A120)') FILENAME - JJ = LEN_TRIM(FILENAME) - IF ( ILOOP .EQ. 1 ) THEN - BACKSPACE (NDSI) - READ (NDSI,'(A)') LINE - WRITE (NDSS,'(A)') LINE - END IF - IF (FILENAME(:JJ).EQ."'STOPSTRING'") EXIT - NBO2=NBO2+1 - IF (ILOOP.EQ.1) CYCLE - SPECFILES(NBO2)=FILENAME - END DO + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*) INXOUT + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*) INTERP + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*) VERBOSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ! + NBO2 = 0 + ! + ! ILOOP = 1 to count NBO2 + ! ILOOP = 2 to read the file names + ! + DO ILOOP = 1, 2 + OPEN (NDSS,FILE='ww3_bound.scratch',FORM='FORMATTED', & + status='UNKNOWN') + IF ( ILOOP .EQ. 1 ) THEN + NDSI2 = NDSI + ELSE + NDSI2 = NDSS + ALLOCATE(SPECFILES(NBO2)) + NBO2=0 + ENDIF - IF ( ILOOP .EQ. 1 ) CLOSE ( NDSS) + NBO2=0 + ! Read input file names + DO + CALL NEXTLN ( COMSTR , NDSI2 , NDSE ) + READ (NDSI2,'(A120)') FILENAME + JJ = LEN_TRIM(FILENAME) + IF ( ILOOP .EQ. 1 ) THEN + BACKSPACE (NDSI) + READ (NDSI,'(A)') LINE + WRITE (NDSS,'(A)') LINE + END IF + IF (FILENAME(:JJ).EQ."'STOPSTRING'") EXIT + NBO2=NBO2+1 + IF (ILOOP.EQ.1) CYCLE + SPECFILES(NBO2)=FILENAME + END DO - IF ( ILOOP .EQ. 2 ) CLOSE ( NDSS, STATUS='DELETE' ) - END DO ! ILOOP = 1, 2 - CLOSE(NDSI) - END IF ! .NOT. FLGNML + IF ( ILOOP .EQ. 1 ) CLOSE ( NDSS) + IF ( ILOOP .EQ. 2 ) CLOSE ( NDSS, STATUS='DELETE' ) + END DO ! ILOOP = 1, 2 + CLOSE(NDSI) + END IF ! .NOT. FLGNML -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Tests the reading of the file -! - IF ( INXOUT.EQ.'READ') THEN - OPEN(NDSB,FILE='nest.ww3',form='UNFORMATTED', convert=file_endian,status='old') - READ(NDSB) IDTST, VERTEST, NK1, NTH1, XFR, FR1I, TH1I, NBI - NSPEC1 = NK1 * NTH1 - IF ( IDTST .NE. IDSTRBC ) THEN - WRITE (NDSO,901) IDTST, IDSTRBC - END IF - WRITE(NDSO,*) "FORMAT VERSION: '",VERTEST,"'" - WRITE(NDSO,*) "FILE TYPE: '",IDTST,"'" - IF (VERBOSE.EQ.1) WRITE(NDSO,'(A,2I5,3F12.6,I5)') 'NK,NTH,XFR, FR1I, TH1I, NBI :', & - NK1,NTH1,XFR, FR1I, TH1I, NBI - ALLOCATE (XBPI(NBI),YBPI(NBI)) - ALLOCATE (IPBPI(NBI,4),RDBPI(NBI,4)) - READ(NDSB) (XBPI(I),I=1,NBI), & - (YBPI(I),I=1,NBI), & - ((IPBPI(I,J),I=1,NBI),J=1,4), & - ((RDBPI(I,J),I=1,NBI),J=1,4) - IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'XBPI:',XBPI - IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'YBPI:',YBPI - IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'IPBPI:' - DO I=1,NBI - IF (VERBOSE.EQ.1) WRITE(NDSO,*) I,' interpolated from:',IPBPI(I,1:4) - IF (VERBOSE.EQ.1) WRITE(NDSO,*) I,' with coefficient :',RDBPI(I,1:4) - END DO -! - READ (NDSB) TIME2, NBI2 - BACKSPACE (NDSB) - ALLOCATE (ABPIN(NSPEC1,NBI2)) - IERR=0 - DO WHILE (IERR.EQ.0) - READ (NDSB,IOSTAT=IERR) TIME2, NBI2 - IF (IERR.EQ.0) THEN - IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'TIME2,NBI2:',TIME2, NBI2,IERR - DO IP=1, NBI2 - READ (NDSB,IOSTAT=IERR) ABPIN(:,IP) - END DO - END IF + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Tests the reading of the file + ! + IF ( INXOUT.EQ.'READ') THEN + OPEN(NDSB,FILE='nest.ww3',form='UNFORMATTED', convert=file_endian,status='old') + READ(NDSB) IDTST, VERTEST, NK1, NTH1, XFR, FR1I, TH1I, NBI + NSPEC1 = NK1 * NTH1 + IF ( IDTST .NE. IDSTRBC ) THEN + WRITE (NDSO,901) IDTST, IDSTRBC + END IF + WRITE(NDSO,*) "FORMAT VERSION: '",VERTEST,"'" + WRITE(NDSO,*) "FILE TYPE: '",IDTST,"'" + IF (VERBOSE.EQ.1) WRITE(NDSO,'(A,2I5,3F12.6,I5)') 'NK,NTH,XFR, FR1I, TH1I, NBI :', & + NK1,NTH1,XFR, FR1I, TH1I, NBI + ALLOCATE (XBPI(NBI),YBPI(NBI)) + ALLOCATE (IPBPI(NBI,4),RDBPI(NBI,4)) + READ(NDSB) (XBPI(I),I=1,NBI), & + (YBPI(I),I=1,NBI), & + ((IPBPI(I,J),I=1,NBI),J=1,4), & + ((RDBPI(I,J),I=1,NBI),J=1,4) + IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'XBPI:',XBPI + IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'YBPI:',YBPI + IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'IPBPI:' + DO I=1,NBI + IF (VERBOSE.EQ.1) WRITE(NDSO,*) I,' interpolated from:',IPBPI(I,1:4) + IF (VERBOSE.EQ.1) WRITE(NDSO,*) I,' with coefficient :',RDBPI(I,1:4) + END DO + ! + READ (NDSB) TIME2, NBI2 + BACKSPACE (NDSB) + ALLOCATE (ABPIN(NSPEC1,NBI2)) + IERR=0 + DO WHILE (IERR.EQ.0) + READ (NDSB,IOSTAT=IERR) TIME2, NBI2 + IF (IERR.EQ.0) THEN + IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'TIME2,NBI2:',TIME2, NBI2,IERR + DO IP=1, NBI2 + READ (NDSB,IOSTAT=IERR) ABPIN(:,IP) END DO - CLOSE(NDSB) + END IF + END DO + CLOSE(NDSB) + END IF + ! + ! + IF ( INXOUT.EQ.'WRITE') THEN + IF ( FLBPI) THEN + ! + ! Defines position of active boundary points + ! + NBO = 0 + DO ISEA=1,NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF (MAPSTA(IY,IX).EQ.2) THEN + NBO=NBO+1 END IF -! -! - IF ( INXOUT.EQ.'WRITE') THEN - IF ( FLBPI) THEN -! -! Defines position of active boundary points -! - NBO = 0 - DO ISEA=1,NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF (MAPSTA(IY,IX).EQ.2) THEN - NBO=NBO+1 - END IF - END DO - ALLOCATE(XBPO(NBO),YBPO(NBO)) + END DO + ALLOCATE(XBPO(NBO),YBPO(NBO)) #ifdef W3_RTD - IF (ISRTD) ALLOCATE(XTMP(NBO), YTMP(NBO), ANGTMP(NBO)) + IF (ISRTD) ALLOCATE(XTMP(NBO), YTMP(NBO), ANGTMP(NBO)) #endif - ALLOCATE (IPBPO(NBO,4),RDBPO(NBO,4)) - IBO=0 - DO ISEA=1,NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF (MAPSTA(IY,IX).EQ.2) THEN - IBO=IBO+1 - SELECT CASE ( GTYPE ) - CASE ( RLGTYPE ) - XBPO(IBO)=X0+SX*(IX-1) - YBPO(IBO)=Y0+SY*(IY-1) - CASE ( CLGTYPE ) - XBPO(IBO)= XGRD(IY,IX) - YBPO(IBO)= YGRD(IY,IX) - CASE (UNGTYPE) - XBPO(IBO)= XGRD(1,IX) - YBPO(IBO)= YGRD(1,IX) - END SELECT !GTYPE - END IF - END DO + ALLOCATE (IPBPO(NBO,4),RDBPO(NBO,4)) + IBO=0 + DO ISEA=1,NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF (MAPSTA(IY,IX).EQ.2) THEN + IBO=IBO+1 + SELECT CASE ( GTYPE ) + CASE ( RLGTYPE ) + XBPO(IBO)=X0+SX*(IX-1) + YBPO(IBO)=Y0+SY*(IY-1) + CASE ( CLGTYPE ) + XBPO(IBO)= XGRD(IY,IX) + YBPO(IBO)= YGRD(IY,IX) + CASE (UNGTYPE) + XBPO(IBO)= XGRD(1,IX) + YBPO(IBO)= YGRD(1,IX) + END SELECT !GTYPE + END IF + END DO #ifdef W3_RTD - ! Convert grid boundary cell locations to standard pole - IF( ISRTD ) THEN - XTMP = XBPO - YTMP = YBPO - CALL W3EQTOLL(YTMP, XTMP, YBPO, XBPO, ANGTMP, POLAT, POLON, NBO) - DEALLOCATE(XTMP, YTMP, ANGTMP) - ENDIF + ! Convert grid boundary cell locations to standard pole + IF( ISRTD ) THEN + XTMP = XBPO + YTMP = YBPO + CALL W3EQTOLL(YTMP, XTMP, YBPO, XBPO, ANGTMP, POLAT, POLON, NBO) + DEALLOCATE(XTMP, YTMP, ANGTMP) + ENDIF #endif - OPEN(NDSB,FILE='nest.ww3',form='UNFORMATTED', convert=file_endian,status='unknown') - ALLOCATE(LATS(NBO2),LONS(NBO2)) - DO IP=1,NBO2 - OPEN(200+IP,FILE=SPECFILES(IP),status='old',iostat=IERR) - IF (VERBOSE.EQ.1) WRITE(NDSO,'(A,I5,3A,I5)') & - 'IP, file, I/O stat:',IP,', ', & - TRIM(SPECFILES(IP)), ', ',IERR - IF (IERR.NE.0) GOTO 810 - READ(200+IP,'(A1,A22,A1,X,2I6)',iostat=IERR) & + OPEN(NDSB,FILE='nest.ww3',form='UNFORMATTED', convert=file_endian,status='unknown') + ALLOCATE(LATS(NBO2),LONS(NBO2)) + DO IP=1,NBO2 + OPEN(200+IP,FILE=SPECFILES(IP),status='old',iostat=IERR) + IF (VERBOSE.EQ.1) WRITE(NDSO,'(A,I5,3A,I5)') & + 'IP, file, I/O stat:',IP,', ', & + TRIM(SPECFILES(IP)), ', ',IERR + IF (IERR.NE.0) GOTO 810 + READ(200+IP,'(A1,A22,A1,X,2I6)',iostat=IERR) & space,string1,space,NKI,NTHI - IF (VERBOSE.EQ.1) WRITE(NDSO,'(A,3I5)') 'IP and spectral dimensions:',IP, NKI,NTHI - IF (IP.EQ.1) THEN - NK1=NKI - NTH1=NTHI - NSPEC1 = NK1 * NTH1 - ALLOCATE (FREQ(NK1),THETA(NTH1)) - ALLOCATE (SPEC2D(NK1,NTH1)) - ALLOCATE (ABPIN(NK*NTH1,NBO2)) - ELSE -! -! To be cleaned up later ... -! - IF (NK1.NE.NKI.OR.NTH1.NE.NTHI) THEN - WRITE(NDSE,'(A,A,4I5)') 'ERROR, SPECTRAL GRID IN FILE:', & - TRIM(SPECFILES(IP)),NK1,NKI,NTH1,NTHI - STOP - END IF - END IF -! - READ(200+IP,*) FREQ(1:NK1) - READ(200+IP,*) THETA(1:NTH1) - END DO + IF (VERBOSE.EQ.1) WRITE(NDSO,'(A,3I5)') 'IP and spectral dimensions:',IP, NKI,NTHI + IF (IP.EQ.1) THEN + NK1=NKI + NTH1=NTHI + NSPEC1 = NK1 * NTH1 + ALLOCATE (FREQ(NK1),THETA(NTH1)) + ALLOCATE (SPEC2D(NK1,NTH1)) + ALLOCATE (ABPIN(NK*NTH1,NBO2)) + ELSE + ! + ! To be cleaned up later ... + ! + IF (NK1.NE.NKI.OR.NTH1.NE.NTHI) THEN + WRITE(NDSE,'(A,A,4I5)') 'ERROR, SPECTRAL GRID IN FILE:', & + TRIM(SPECFILES(IP)),NK1,NKI,NTH1,NTHI + STOP + END IF + END IF + ! + READ(200+IP,*) FREQ(1:NK1) + READ(200+IP,*) THETA(1:NTH1) + END DO -! -! Defines frequency range in spectra -! + ! + ! Defines frequency range in spectra + ! ! Checks consistency of NK IF (NKI.GT.NK) GOTO 808 -! + ! ! HERE we define IFMIN IFMIN2 IFMAX and IFMAX2 frequency indices ! such that source spec SPEC (read in input) links with output spec ! APBIN with APBIN(IFMIN2:IFMAX2) = SPEC(IFMIN:IFMAX) @@ -503,62 +503,62 @@ PROGRAM W3BOUND IFMIN=1 ! index of first freq. in source spectrum IFMIN2=1 ! index of first freq. in output spectrum IFMAX=NK1 ! index of last freq. in source spectrum -! IFMAX2=NK ! index of last freq. in output spectrum -! + ! IFMAX2=NK ! index of last freq. in output spectrum + ! ! Checks consistency of XFR IF (ABS((FREQ(IFMIN+1)/FREQ(IFMIN))-XFR).GT.0.005) GOTO 806 -! + ! ! Checks consistency of NTH - ! WARNING: check is only done on number of directions, no check - ! is done on the relative offset of first direction in terms of - ! the directional increment [-0.5,0.5] (last parameter of the - ! spectral definition in ww3_grid.inp, on second active line) + ! WARNING: check is only done on number of directions, no check + ! is done on the relative offset of first direction in terms of + ! the directional increment [-0.5,0.5] (last parameter of the + ! spectral definition in ww3_grid.inp, on second active line) IF (NTHI.NE.NTH) GOTO 807 - IF ((FR1-FREQ(1))/FR1.GT. 0.03) THEN + IF ((FR1-FREQ(1))/FR1.GT. 0.03) THEN DO J=1,MIN(NK1,NK) - IF (ABS(FREQ(J)-FR1) .LT. ABS(FREQ(IFMIN)-FR1)) THEN + IF (ABS(FREQ(J)-FR1) .LT. ABS(FREQ(IFMIN)-FR1)) THEN IFMIN=J - END IF - END DO - END IF -! - IF ((FREQ(1)-FR1)/FR1.GT. 0.03) THEN + END IF + END DO + END IF + ! + IF ((FREQ(1)-FR1)/FR1.GT. 0.03) THEN DO J=1,MIN(NK,NK1) - IF (ABS(FREQ(J)-FR1*XFR**(J-1)) .LT. ABS(FREQ(IFMIN2)-FR1)) THEN + IF (ABS(FREQ(J)-FR1*XFR**(J-1)) .LT. ABS(FREQ(IFMIN2)-FR1)) THEN IFMIN2=J - END IF - END DO - END IF -! - IF ((FREQ(NK1)-FR1*XFR**(NK-1))/FREQ(NK1) .GT.0.03) THEN + END IF + END DO + END IF + ! + IF ((FREQ(NK1)-FR1*XFR**(NK-1))/FREQ(NK1) .GT.0.03) THEN DO J=1,NK - IF (ABS(FREQ(J)-FR1*XFR**(NK1-1)) .LT. ABS(FREQ(IFMAX)-FR1*XFR**(NK1-1))) THEN + IF (ABS(FREQ(J)-FR1*XFR**(NK1-1)) .LT. ABS(FREQ(IFMAX)-FR1*XFR**(NK1-1))) THEN IFMAX=J - END IF - END DO - END IF -! + END IF + END DO + END IF + ! IERR=0 ITIME=0 -! -! Loop on times -! + ! + ! Loop on times + ! DO WHILE (IERR.EQ.0) DO IP=1,NBO2 READ(200+IP,*,IOSTAT=IERR) TIME2 - IF (IERR.EQ.0) THEN -! - IF (IP.EQ.1) THEN + IF (IERR.EQ.0) THEN + ! + IF (IP.EQ.1) THEN TIME1=TIME2 ELSE - IF (TIME1(1).NE.TIME2(1).OR.TIME1(2).NE.TIME2(2)) THEN - WRITE(NDSE,*) 'AT POINT ',IP,', BAD TIMES:',TIME1, TIME2 - END IF - END IF -! + IF (TIME1(1).NE.TIME2(1).OR.TIME1(2).NE.TIME2(2)) THEN + WRITE(NDSE,*) 'AT POINT ',IP,', BAD TIMES:',TIME1, TIME2 + END IF + END IF + ! READ(200+IP,'(A1,A10,A1,2F7.2,F10.1,F7.2,F6.1,F7.2,F6.1)') & - space,buoyname,space,LATS(IP),LONS(IP),depth,U10,Udir,Curr,Currdir + space,buoyname,space,LATS(IP),LONS(IP),depth,U10,Udir,Curr,Currdir #ifdef W3_RTD IF (ISRTD) THEN ! Rotated coordinates are scaled in range 0 - 360 @@ -566,188 +566,186 @@ PROGRAM W3BOUND IF(LONS(IP) .GT. 360) LONS(IP) = LONS(IP) - 360.0 ENDIF #endif - READ(200+IP,*,IOSTAT=IERR) SPEC2D - IF (IFMIN2.GT.1) THEN -! -! Fills in the low frequency end of the spectrum -! + READ(200+IP,*,IOSTAT=IERR) SPEC2D + IF (IFMIN2.GT.1) THEN + ! + ! Fills in the low frequency end of the spectrum + ! ABPIN(1:(IFMIN2-1)*NTH,IP)=0. - END IF + END IF DO I=IFMIN,IFMAX DO J=1,NTH ABPIN((I-IFMIN+(IFMIN2-1))*NTH+J,IP)=SPEC2D(I,J)*tpiinv - END DO END DO - IF (IFMAX-IFMIN+IFMIN2.LT.NK1) THEN - !IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'FILLING TAIL',IFMAX-IFMIN,NK1,IFMAX-IFMIN+(IFMIN2-1) - ABPIN((IFMAX-IFMIN+IFMIN2)*NTH+1:NK1*NTH,IP)=0. - END IF - END IF ! ned of test on IERR - END DO -! -! Writes header -! - IF (IERR.EQ.0) THEN - IF (ITIME.EQ.0) THEN -! Correction for rounding error in ASCII files ... - IF (ABS(THETA(1)-0.5*PI).LT.0.01) THETA(1)=0.5*PI -! Writes header in nest.ww3 file - WRITE(NDSB) IDSTRBC, VERBPTBC, NK1, NTH, XFR, FREQ(1), & - MOD(2.5*PI-THETA(1),TPI), NBO - IPBPO(:,:)=1 - RDBPO(:,1)=1. - RDBPO(:,2:4)=0. -! - DO IP1=1,NBO - DMIN=360.+180. - DMIN2=360.+180. - DO IP=1,NBO2 -! -! Searches for the nearest 2 points where spectra are available -! - DIST=SQRT((LONS(IP)-XBPO(IP1))**2+(LATS(IP)-YBPO(IP1))**2) - IF (DMIN.EQ.(360.+180.)) THEN - IF(DIST.LT.DMIN) THEN - IPBPO(IP1,1)=IP - DMIN=DIST + END DO + IF (IFMAX-IFMIN+IFMIN2.LT.NK1) THEN + !IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'FILLING TAIL',IFMAX-IFMIN,NK1,IFMAX-IFMIN+(IFMIN2-1) + ABPIN((IFMAX-IFMIN+IFMIN2)*NTH+1:NK1*NTH,IP)=0. END IF - ELSE - IF(DIST.LT.DMIN2) THEN - IF(DIST.LT.DMIN) THEN - IPBPO(IP1,2)=IPBPO(IP1,1) - DMIN2=DMIN - IPBPO(IP1,1)=IP - DMIN=DIST - ELSE - IPBPO(IP1,2)=IP - DMIN2=DIST - END IF - ENDIF - END IF + END IF ! ned of test on IERR END DO - !IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'DIST:',DMIN,DMIN2,IP1,IPBPO(IP1,1),IPBPO(IP1,2), & - ! LONS(IPBPO(IP1,1)),LONS(IPBPO(IP1,2)),XBPO(IP1), & - ! LATS(IPBPO(IP1,1)),LATS(IPBPO(IP1,2)),YBPO(IP1) -! -! Computes linear interpolation coefficient between the nearest 2 points -! - IF (INTERP.GT.1.AND.NBO2.GT.1) THEN + ! + ! Writes header + ! + IF (IERR.EQ.0) THEN + IF (ITIME.EQ.0) THEN + ! Correction for rounding error in ASCII files ... + IF (ABS(THETA(1)-0.5*PI).LT.0.01) THETA(1)=0.5*PI + ! Writes header in nest.ww3 file + WRITE(NDSB) IDSTRBC, VERBPTBC, NK1, NTH, XFR, FREQ(1), & + MOD(2.5*PI-THETA(1),TPI), NBO + IPBPO(:,:)=1 + RDBPO(:,1)=1. + RDBPO(:,2:4)=0. + ! + DO IP1=1,NBO + DMIN=360.+180. + DMIN2=360.+180. + DO IP=1,NBO2 + ! + ! Searches for the nearest 2 points where spectra are available + ! + DIST=SQRT((LONS(IP)-XBPO(IP1))**2+(LATS(IP)-YBPO(IP1))**2) + IF (DMIN.EQ.(360.+180.)) THEN + IF(DIST.LT.DMIN) THEN + IPBPO(IP1,1)=IP + DMIN=DIST + END IF + ELSE + IF(DIST.LT.DMIN2) THEN + IF(DIST.LT.DMIN) THEN + IPBPO(IP1,2)=IPBPO(IP1,1) + DMIN2=DMIN + IPBPO(IP1,1)=IP + DMIN=DIST + ELSE + IPBPO(IP1,2)=IP + DMIN2=DIST + END IF + ENDIF + END IF + END DO + !IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'DIST:',DMIN,DMIN2,IP1,IPBPO(IP1,1),IPBPO(IP1,2), & + ! LONS(IPBPO(IP1,1)),LONS(IPBPO(IP1,2)),XBPO(IP1), & + ! LATS(IPBPO(IP1,1)),LATS(IPBPO(IP1,2)),YBPO(IP1) + ! + ! Computes linear interpolation coefficient between the nearest 2 points + ! + IF (INTERP.GT.1.AND.NBO2.GT.1) THEN DIST=SQRT((LONS(IPBPO(IP1,1))-LONS(IPBPO(IP1,2)))**2 & - +(LATS(IPBPO(IP1,1))-LATS(IPBPO(IP1,2)))**2) - COS1=( (XBPO(IP1)-LONS(IPBPO(IP1,1))) & - *(LONS(IPBPO(IP1,2))-LONS(IPBPO(IP1,1))) & - + (YBPO(IP1)-LATS(IPBPO(IP1,1))) & - *(LATS(IPBPO(IP1,2))-LATS(IPBPO(IP1,1))))/(DIST**2) - !COS2=( (XBPO(IP1)-LONS(IPBPO(IP1,2))) & - ! *(LONS(IPBPO(IP1,1))-LONS(IPBPO(IP1,2))) - ! + (YBPO(IP1)-LATS(IPBPO(IP1,2))) & - ! *(LATS(IPBPO(IP1,1))-LATS(IPBPO(IP1,2))))/(DIST**2) - RDBPO(IP1,1)=1-MIN(1.,MAX(0.,COS1)) - RDBPO(IP1,2)=MIN(1.,MAX(0.,COS1)) - END IF -! - IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'IPBP:',IP1,(IPBPO(IP1,J),J=1,4) - IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'RDBP:',IP1,(RDBPO(IP1,J),J=1,4) -! - END DO - WRITE(NDSB) (XBPO(I),I=1,NBO), & - (YBPO(I),I=1,NBO), & - ((IPBPO(I,J),I=1,NBO),J=1,4),& - ((RDBPO(I,J),I=1,NBO),J=1,4) - END IF - - WRITE(NDSO,*) 'Writing boundary data for time:', TIME2, NBO2 - WRITE(NDSB,IOSTAT=IERR) TIME2, NBO2 - DO IP=1, NBO2 - WRITE (NDSB) ABPIN(:,IP) - END DO - - ITIME=ITIME+1 - END IF - END DO - CLOSE(NDSB) - END IF - END IF -STOP -! -! Escape locations read errors : -! + +(LATS(IPBPO(IP1,1))-LATS(IPBPO(IP1,2)))**2) + COS1=( (XBPO(IP1)-LONS(IPBPO(IP1,1))) & + *(LONS(IPBPO(IP1,2))-LONS(IPBPO(IP1,1))) & + + (YBPO(IP1)-LATS(IPBPO(IP1,1))) & + *(LATS(IPBPO(IP1,2))-LATS(IPBPO(IP1,1))))/(DIST**2) + !COS2=( (XBPO(IP1)-LONS(IPBPO(IP1,2))) & + ! *(LONS(IPBPO(IP1,1))-LONS(IPBPO(IP1,2))) + ! + (YBPO(IP1)-LATS(IPBPO(IP1,2))) & + ! *(LATS(IPBPO(IP1,1))-LATS(IPBPO(IP1,2))))/(DIST**2) + RDBPO(IP1,1)=1-MIN(1.,MAX(0.,COS1)) + RDBPO(IP1,2)=MIN(1.,MAX(0.,COS1)) + END IF + ! + IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'IPBP:',IP1,(IPBPO(IP1,J),J=1,4) + IF (VERBOSE.EQ.1) WRITE(NDSO,*) 'RDBP:',IP1,(RDBPO(IP1,J),J=1,4) + ! + END DO + WRITE(NDSB) (XBPO(I),I=1,NBO), & + (YBPO(I),I=1,NBO), & + ((IPBPO(I,J),I=1,NBO),J=1,4),& + ((RDBPO(I,J),I=1,NBO),J=1,4) + END IF - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 61 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 62 ) -! - 803 CONTINUE - WRITE (NDSE,1003) - CALL EXTCDE ( 63 ) -! - 806 CONTINUE - WRITE (NDSE,1006) XFR - CALL EXTCDE ( 66 ) -! - 807 CONTINUE - WRITE (NDSE,1007) NTH, NTHI - CALL EXTCDE ( 67 ) -! - 808 CONTINUE - WRITE (NDSE,1008) NK, NKI - CALL EXTCDE ( 68 ) -! - 809 CONTINUE - WRITE (NDSE,1009) BNDFILE, IERR - CALL EXTCDE ( 69 ) -! - 810 CONTINUE - WRITE (NDSE,1010) SPECFILES(IP) - CALL EXTCDE ( 70 ) + WRITE(NDSO,*) 'Writing boundary data for time:', TIME2, NBO2 + WRITE(NDSB,IOSTAT=IERR) TIME2, NBO2 + DO IP=1, NBO2 + WRITE (NDSB) ABPIN(:,IP) + END DO -! -! Formats -! - 901 FORMAT (/' *** WAVEWATCH-III ERROR IN W3IOBC :'/ & - ' ILEGAL IDSTR, READ : ',A/ & - ' CHECK : ',A/) -! - 920 FORMAT ( ' Grid name : ',A/) -! - 1001 FORMAT (/' *** WAVEWATCH-III ERROR IN W3BOUND : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND: '/ & - ' ERROR IN READING ',A,' FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUNC : '/ & - ' ERROR IN OPENING INPUT FILE: ', A/ & - ' IOSTAT =',I5/) -! - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND: '/ & - ' ILLEGAL XFR, XFR =',F12.6/) -! - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND: '/ & - ' ILLEGAL NTH, NTH =',I3,' DIFFERS FROM NTHI =',I3/) -! - 1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND: '/ & - ' ILLEGAL NK, NK =',I3,' DIFFERS FROM NKI =',I3/ & - ' IT WILL BE MANAGED SOON BY SPCONV') -! - 1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND : '/ & - ' ERROR IN OPENING SPEC FILE: ', A/ & - ' IOSTAT =',I5/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND : '/ & - ' SPEC FILE NOT EXISTING: ', A/) + ITIME=ITIME+1 + END IF + END DO + CLOSE(NDSB) + END IF + END IF + STOP + ! + ! Escape locations read errors : + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 61 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 62 ) + ! +803 CONTINUE + WRITE (NDSE,1003) + CALL EXTCDE ( 63 ) + ! +806 CONTINUE + WRITE (NDSE,1006) XFR + CALL EXTCDE ( 66 ) + ! +807 CONTINUE + WRITE (NDSE,1007) NTH, NTHI + CALL EXTCDE ( 67 ) + ! +808 CONTINUE + WRITE (NDSE,1008) NK, NKI + CALL EXTCDE ( 68 ) + ! +809 CONTINUE + WRITE (NDSE,1009) BNDFILE, IERR + CALL EXTCDE ( 69 ) + ! +810 CONTINUE + WRITE (NDSE,1010) SPECFILES(IP) + CALL EXTCDE ( 70 ) -! -!/ -!/ End of W3BOUND ---------------------------------------------------- / -!/ - END PROGRAM W3BOUND -!/ ------------------------------------------------------------------- / + ! + ! Formats + ! +901 FORMAT (/' *** WAVEWATCH-III ERROR IN W3IOBC :'/ & + ' ILEGAL IDSTR, READ : ',A/ & + ' CHECK : ',A/) + ! +920 FORMAT ( ' Grid name : ',A/) + ! +1001 FORMAT (/' *** WAVEWATCH-III ERROR IN W3BOUND : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND: '/ & + ' ERROR IN READING ',A,' FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUNC : '/ & + ' ERROR IN OPENING INPUT FILE: ', A/ & + ' IOSTAT =',I5/) + ! +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND: '/ & + ' ILLEGAL XFR, XFR =',F12.6/) + ! +1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND: '/ & + ' ILLEGAL NTH, NTH =',I3,' DIFFERS FROM NTHI =',I3/) + ! +1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND: '/ & + ' ILLEGAL NK, NK =',I3,' DIFFERS FROM NKI =',I3/ & + ' IT WILL BE MANAGED SOON BY SPCONV') + ! +1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND : '/ & + ' ERROR IN OPENING SPEC FILE: ', A/ & + ' IOSTAT =',I5/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3BOUND : '/ & + ' SPEC FILE NOT EXISTING: ', A/) + ! + !/ + !/ End of W3BOUND ---------------------------------------------------- / + !/ +END PROGRAM W3BOUND +!/ ------------------------------------------------------------------- / diff --git a/model/src/ww3_gint.F90 b/model/src/ww3_gint.F90 index d3530a79f..859c1e653 100644 --- a/model/src/ww3_gint.F90 +++ b/model/src/ww3_gint.F90 @@ -8,3354 +8,3354 @@ !> @brief Re-gridding binary output (out_grd.\ * files) to another grid. !> !> @details Data is interpolated from a combination of base grids to the -!> target grid. For each grid, if resolution is coarser or similar to +!> target grid. For each grid, if resolution is coarser or similar to !> target grid then a linear interpolation approach is used. On the other -!> hand if resolution is much higher then an averaging technique based on +!> hand if resolution is much higher then an averaging technique based on !> cell areas. !> !> Total number of base grids to be used for interpolation together with -!> their (and target grid) file extns are read from 'ww3_gint.inp'. -!> Base grids can be arranged in any order but the target grid should +!> their (and target grid) file extns are read from 'ww3_gint.inp'. +!> Base grids can be arranged in any order but the target grid should !> always be the last grid. !> !> @author A. Chawla @date 02-Jun-2021 ! - PROGRAM W3GRID_INTERP -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | A. Chawla |SX -!/ | FORTRAN 90 | -!/ | Last update : 02-Jun-2021 | -!/ +-----------------------------------+ -!/ -!/ 15-Mar-2007 : Origination. ( version 3.13 ) -!/ 24-Sep-2007 : Original code ( version 3.14 ) -!/ 01-Aug-2011 : Modified to match grid output ( version 4.01 ) -!/ 20-Feb-2013 : Modified for new output fields ( version 4.11 ) -!/ 11-Nov-2013 : Update for curvilinear grids ( version 4.13 ) -!/ 22-Jan-2014 : Update for UNST grids (F. Ardhuin) ( version 4.18 ) -!/ 30-Apr-2014 : Add group 3 (M. Accensi) ( version 5.00 ) -!/ 26-Jul-2018 : Write weights file WHTGRIDINT.bin -!/ (F.Ardhuin, M.Accensi, J.H.Alves) ( version 6.05 ) -!/ 31-Aug-2018 : Update groups 2,4,6,8 (S. Zieger) ( version 6.05 ) -!/ 26-Jan-2021 : Added TP field (derived from FP) ( version 7.12 ) -!/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) -!/ 02-Jun-2021 : Bug fix (*SUMGRD; Q. Liu) ( version 7.13 ) -!/ -! 1. Purpose : -! -! Re-gridding binary output (out_grd.* files) to another grid -! -! 2. Method : -! -! Data is interpolated from a combination of base grids to the target -! grid. For each grid, if resolution is coarser or similar to target -! grid then a linear interpolation approach is used. On the other hand -! if resolution is much higher then an averaging technique based on -! cell areas. -! Total number of base grids to be used for interpolation together with -! their (and target grid) file extns are read from 'ww3_gint.inp'. -! Base grids can be arranged in any order but the target grid should -! always be the last grid. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! NEXTLN Subr. W3SERVMD Get next line from input file -! EXTCDE Subr. Id. Abort program as graceful as possible. -! ITRACE Subr. Id. Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. W3WDATMD Point to selected model for wave data. -! W3NAUX Subr. W3ADATMD Set number of model for aux data. -! W3SETA Subr. Id. Point to selected model for aux data. -! W3DIMA Subr. Id. Assign memory for aux data. -! W3GRMP Func. W3GSRUMD Compute interpolation coeff. from grid. -! W3CKCL Func. Id. Check if point lies within grid cell. -! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! Checks on input, checks on determining the interpolation weights -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ - USE W3IOGRMD - USE W3TIMEMD - USE W3IOGOMD, ONLY : W3IOGO - USE W3ADATMD, ONLY : W3DIMA, W3NAUX, W3SETA - USE W3GDATMD - USE W3ODATMD, ONLY : FNMPRE, NOGRP, NGRPP, OUTPTS, UNDEF, FLOGRD, & - NAPROC, NOSWLL, IDOUT - USE W3ODATMD, ONLY : W3NOUT, W3SETO - USE W3IDATMD - USE W3WDATMD, ONLY : W3NDAT, W3DIMW, W3SETW - USE W3WDATMD, ONLY : WDATAS, TIME, WLV, ICE, ICEH, ICEF, & - UST, USTDIR, ASF, RHOAIR - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE +PROGRAM W3GRID_INTERP + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | A. Chawla |SX + !/ | FORTRAN 90 | + !/ | Last update : 02-Jun-2021 | + !/ +-----------------------------------+ + !/ + !/ 15-Mar-2007 : Origination. ( version 3.13 ) + !/ 24-Sep-2007 : Original code ( version 3.14 ) + !/ 01-Aug-2011 : Modified to match grid output ( version 4.01 ) + !/ 20-Feb-2013 : Modified for new output fields ( version 4.11 ) + !/ 11-Nov-2013 : Update for curvilinear grids ( version 4.13 ) + !/ 22-Jan-2014 : Update for UNST grids (F. Ardhuin) ( version 4.18 ) + !/ 30-Apr-2014 : Add group 3 (M. Accensi) ( version 5.00 ) + !/ 26-Jul-2018 : Write weights file WHTGRIDINT.bin + !/ (F.Ardhuin, M.Accensi, J.H.Alves) ( version 6.05 ) + !/ 31-Aug-2018 : Update groups 2,4,6,8 (S. Zieger) ( version 6.05 ) + !/ 26-Jan-2021 : Added TP field (derived from FP) ( version 7.12 ) + !/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) + !/ 02-Jun-2021 : Bug fix (*SUMGRD; Q. Liu) ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Re-gridding binary output (out_grd.* files) to another grid + ! + ! 2. Method : + ! + ! Data is interpolated from a combination of base grids to the target + ! grid. For each grid, if resolution is coarser or similar to target + ! grid then a linear interpolation approach is used. On the other hand + ! if resolution is much higher then an averaging technique based on + ! cell areas. + ! Total number of base grids to be used for interpolation together with + ! their (and target grid) file extns are read from 'ww3_gint.inp'. + ! Base grids can be arranged in any order but the target grid should + ! always be the last grid. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! NEXTLN Subr. W3SERVMD Get next line from input file + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! ITRACE Subr. Id. Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! W3SETO Subr. Id. Point to selected model for output. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. W3WDATMD Point to selected model for wave data. + ! W3NAUX Subr. W3ADATMD Set number of model for aux data. + ! W3SETA Subr. Id. Point to selected model for aux data. + ! W3DIMA Subr. Id. Assign memory for aux data. + ! W3GRMP Func. W3GSRUMD Compute interpolation coeff. from grid. + ! W3CKCL Func. Id. Check if point lies within grid cell. + ! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! Checks on input, checks on determining the interpolation weights + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + USE W3IOGRMD + USE W3TIMEMD + USE W3IOGOMD, ONLY : W3IOGO + USE W3ADATMD, ONLY : W3DIMA, W3NAUX, W3SETA + USE W3GDATMD + USE W3ODATMD, ONLY : FNMPRE, NOGRP, NGRPP, OUTPTS, UNDEF, FLOGRD, & + NAPROC, NOSWLL, IDOUT + USE W3ODATMD, ONLY : W3NOUT, W3SETO + USE W3IDATMD + USE W3WDATMD, ONLY : W3NDAT, W3DIMW, W3SETW + USE W3WDATMD, ONLY : WDATAS, TIME, WLV, ICE, ICEH, ICEF, & + UST, USTDIR, ASF, RHOAIR + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif - USE W3ARRYMD, ONLY : PRTBLK - USE W3GSRUMD - USE W3TRIAMD -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local data structure -!/ - TYPE GR_WT - INTEGER :: NP - INTEGER, ALLOCATABLE :: IP(:), JP(:) - REAL, ALLOCATABLE :: WT(:) - REAL :: AR - END TYPE GR_WT -! - TYPE GR_INT - INTEGER :: NGRDS - INTEGER, ALLOCATABLE :: GDID(:) - TYPE(GR_WT), ALLOCATABLE :: IND_WTS(:) - END TYPE GR_INT -!/ -!/ Local variables -!/ + USE W3ARRYMD, ONLY : PRTBLK + USE W3GSRUMD + USE W3TRIAMD + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local data structure + !/ + TYPE GR_WT + INTEGER :: NP + INTEGER, ALLOCATABLE :: IP(:), JP(:) + REAL, ALLOCATABLE :: WT(:) + REAL :: AR + END TYPE GR_WT + ! + TYPE GR_INT + INTEGER :: NGRDS + INTEGER, ALLOCATABLE :: GDID(:) + TYPE(GR_WT), ALLOCATABLE :: IND_WTS(:) + END TYPE GR_INT + !/ + !/ Local variables + !/ - TYPE(GR_INT), TARGET, ALLOCATABLE :: GR_INTS(:) - INTEGER :: I, J, IERR, NG, IG, JG, ISEA, IX, IY, IXT - INTEGER :: IYT, NS, COUNTF, COUNTG, NOSWLL_MIN, ITOUT - INTEGER :: NDSM, NDSI, NDSE, NDSO, NDSTRC, NTRACE, IOTST - INTEGER :: INTMETHOD, NSEA_FILE - INTEGER, ALLOCATABLE :: FIDOUT(:), MAP(:,:), TMP_INDX(:) - REAL :: SXT, SYT, XT, YT, XTT - DOUBLE PRECISION :: DAREA, SAREA - REAL :: XCRNR(5),YCRNR(5),DT(4),DX,DY,XSUB,YSUB - INTEGER :: TOUT(2), NOUT, IOUT - REAL :: DTREQ, DTEST - INTEGER :: IS(4), JS(4) - INTEGER :: MAPINT - REAL :: RW(4), SUMWT + TYPE(GR_INT), TARGET, ALLOCATABLE :: GR_INTS(:) + INTEGER :: I, J, IERR, NG, IG, JG, ISEA, IX, IY, IXT + INTEGER :: IYT, NS, COUNTF, COUNTG, NOSWLL_MIN, ITOUT + INTEGER :: NDSM, NDSI, NDSE, NDSO, NDSTRC, NTRACE, IOTST + INTEGER :: INTMETHOD, NSEA_FILE + INTEGER, ALLOCATABLE :: FIDOUT(:), MAP(:,:), TMP_INDX(:) + REAL :: SXT, SYT, XT, YT, XTT + DOUBLE PRECISION :: DAREA, SAREA + REAL :: XCRNR(5),YCRNR(5),DT(4),DX,DY,XSUB,YSUB + INTEGER :: TOUT(2), NOUT, IOUT + REAL :: DTREQ, DTEST + INTEGER :: IS(4), JS(4) + INTEGER :: MAPINT + REAL :: RW(4), SUMWT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL, ALLOCATABLE :: INT_MAP(:,:) - LOGICAL :: L360=.FALSE., LPLC, INGRD, BRNCHCL, BRNCHCR, INGRID - CHARACTER :: COMSTR*1, IDTIME*23, FNAMEWHT*32 -! -!--------------------------------------------------------------------------- -! 1. Initialization -! - NDSM = 20 - NDSI = 10 - NDSE = 6 - NDSO = 6 -! - NDSTRC = 6 - NTRACE = 10 + REAL, ALLOCATABLE :: INT_MAP(:,:) + LOGICAL :: L360=.FALSE., LPLC, INGRD, BRNCHCL, BRNCHCR, INGRID + CHARACTER :: COMSTR*1, IDTIME*23, FNAMEWHT*32 + ! + !--------------------------------------------------------------------------- + ! 1. Initialization + ! + NDSM = 20 + NDSI = 10 + NDSE = 6 + NDSO = 6 + ! + NDSTRC = 6 + NTRACE = 10 -! -!--------------------------------------------------------------------------- -! 2. I/O Setup -! -! - J = LEN_TRIM(FNMPRE) - OPEN(NDSI,FILE=FNMPRE(:J)//'ww3_gint.inp',STATUS='OLD', ERR=2000, & - IOSTAT=IERR) - WRITE (NDSO,900) -! - CALL ITRACE ( NDSTRC, NTRACE ) + ! + !--------------------------------------------------------------------------- + ! 2. I/O Setup + ! + ! + J = LEN_TRIM(FNMPRE) + OPEN(NDSI,FILE=FNMPRE(:J)//'ww3_gint.inp',STATUS='OLD', ERR=2000, & + IOSTAT=IERR) + WRITE (NDSO,900) + ! + CALL ITRACE ( NDSTRC, NTRACE ) #ifdef W3_S - CALL STRACE (IENT, 'W3GRIDINT') + CALL STRACE (IENT, 'W3GRIDINT') #endif -!--------------------------------------------------------------------------- -! 3. Read and process input file upto number of grids -! 3.a Get comment character -! - REWIND (NDSI) - READ (NDSI,'(A)',END=2001,ERR=2002) COMSTR - IF ( COMSTR .EQ. ' ' ) COMSTR = '$' - WRITE (NDSO,901) COMSTR -! -! 3.b Read starting time, time step and number of outputs -! - CALL NEXTLN ( COMSTR, NDSI, NDSE ) - READ (NDSI,*,END=2001,ERR=2002) TOUT, DTREQ, NOUT - DTREQ = MAX ( 0. , DTREQ ) - IF ( DTREQ.EQ.0 ) NOUT = 1 - NOUT = MAX ( 1 , NOUT ) -! - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,902) IDTIME, DTREQ, NOUT -! -! 3.c Read number of grids and allocate memory -! - CALL NEXTLN ( COMSTR, NDSI, NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NG - WRITE (NDSO,903) NG -! - CALL W3NMOD (NG, 6, 6) - CALL W3NDAT ( 6, 6) - CALL W3NAUX ( 6, 6) - CALL W3NINP ( 6, 6) - CALL W3NOUT( 6, 6) -! -! 3.d Read file extensions for each of the grids and -! the grid information from the corresponding mod_def files -! - NOSWLL_MIN = 9999999 - CALL NEXTLN ( COMSTR, NDSI, NDSE ) -! - DO IG = 1,NG - READ (NDSI,*,END=2001,ERR=2002) GRIDS(IG)%FILEXT - WRITE (NDSO,904) IG,GRIDS(IG)%FILEXT -! - CALL W3SETO( IG, 6, 6) - CALL W3SETA( IG, 6, 6) - CALL W3SETW( IG, 6, 6) - CALL W3SETG( IG, 6, 6) - CALL W3IOGR ('READ', NDSM, IG, GRIDS(IG)%FILEXT) - WRITE (NDSO,905) NX, NY, GTYPE, ICLOSE + !--------------------------------------------------------------------------- + ! 3. Read and process input file upto number of grids + ! 3.a Get comment character + ! + REWIND (NDSI) + READ (NDSI,'(A)',END=2001,ERR=2002) COMSTR + IF ( COMSTR .EQ. ' ' ) COMSTR = '$' + WRITE (NDSO,901) COMSTR + ! + ! 3.b Read starting time, time step and number of outputs + ! + CALL NEXTLN ( COMSTR, NDSI, NDSE ) + READ (NDSI,*,END=2001,ERR=2002) TOUT, DTREQ, NOUT + DTREQ = MAX ( 0. , DTREQ ) + IF ( DTREQ.EQ.0 ) NOUT = 1 + NOUT = MAX ( 1 , NOUT ) + ! + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,902) IDTIME, DTREQ, NOUT + ! + ! 3.c Read number of grids and allocate memory + ! + CALL NEXTLN ( COMSTR, NDSI, NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NG + WRITE (NDSO,903) NG + ! + CALL W3NMOD (NG, 6, 6) + CALL W3NDAT ( 6, 6) + CALL W3NAUX ( 6, 6) + CALL W3NINP ( 6, 6) + CALL W3NOUT( 6, 6) + ! + ! 3.d Read file extensions for each of the grids and + ! the grid information from the corresponding mod_def files + ! + NOSWLL_MIN = 9999999 + CALL NEXTLN ( COMSTR, NDSI, NDSE ) + ! + DO IG = 1,NG + READ (NDSI,*,END=2001,ERR=2002) GRIDS(IG)%FILEXT + WRITE (NDSO,904) IG,GRIDS(IG)%FILEXT + ! + CALL W3SETO( IG, 6, 6) + CALL W3SETA( IG, 6, 6) + CALL W3SETW( IG, 6, 6) + CALL W3SETG( IG, 6, 6) + CALL W3IOGR ('READ', NDSM, IG, GRIDS(IG)%FILEXT) + WRITE (NDSO,905) NX, NY, GTYPE, ICLOSE - IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN - WRITE(NDSE,*)'PROGRAM W3GRID_INTERP HAS NOT BEEN '// & - 'TESTED WITH TRIPOLE GRIDS. STOPPING NOW.' - CALL EXTCDE ( 1 ) - END IF + IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN + WRITE(NDSE,*)'PROGRAM W3GRID_INTERP HAS NOT BEEN '// & + 'TESTED WITH TRIPOLE GRIDS. STOPPING NOW.' + CALL EXTCDE ( 1 ) + END IF - IF ( IG .NE. NG .AND. NOSWLL_MIN .GE. OUTPTS(IG)%NOSWLL ) THEN - NOSWLL_MIN = OUTPTS(IG)%NOSWLL - END IF -! - END DO -! - IF ( NOSWLL_MIN .NE. OUTPTS(NG)%NOSWLL ) THEN - WRITE (NDSO,907) NOSWLL_MIN, OUTPTS(NG)%NOSWLL - NOSWLL_MIN = MIN (NOSWLL_MIN,OUTPTS(NG)%NOSWLL) - END IF + IF ( IG .NE. NG .AND. NOSWLL_MIN .GE. OUTPTS(IG)%NOSWLL ) THEN + NOSWLL_MIN = OUTPTS(IG)%NOSWLL + END IF + ! + END DO + ! + IF ( NOSWLL_MIN .NE. OUTPTS(NG)%NOSWLL ) THEN + WRITE (NDSO,907) NOSWLL_MIN, OUTPTS(NG)%NOSWLL + NOSWLL_MIN = MIN (NOSWLL_MIN,OUTPTS(NG)%NOSWLL) + END IF - CALL NEXTLN ( COMSTR, NDSI, NDSE ) - READ (NDSI,'(I1)',END=2001,ERR=2002) INTMETHOD - WRITE (NDSO,917) INTMETHOD + CALL NEXTLN ( COMSTR, NDSI, NDSE ) + READ (NDSI,'(I1)',END=2001,ERR=2002) INTMETHOD + WRITE (NDSO,917) INTMETHOD -! -! 3.e Allocate memory for integration map and initialize with grid status map -! - ALLOCATE(INT_MAP(NX,NY),MAP(NX,NY)) - INT_MAP = 0.0 -! MAP = TRANSPOSE(MAPSTA) - DO IX = 1,NX - DO IY = 1,NY - IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN - MAP(IX,IY) = -1 - END IF - END DO + ! + ! 3.e Allocate memory for integration map and initialize with grid status map + ! + ALLOCATE(INT_MAP(NX,NY),MAP(NX,NY)) + INT_MAP = 0.0 + ! MAP = TRANSPOSE(MAPSTA) + DO IX = 1,NX + DO IY = 1,NY + IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN + MAP(IX,IY) = -1 + END IF + END DO + END DO + ! + !--------------------------------------------------------------------------- + ! 4. Determine interpolation weights for output grids + ! + ! + ! 4.a Point to output grid and allocate space for interpolation weights + ! + CALL W3SETG( NG, 6, 6) + WRITE (NDSO,908) NSEA + ! + ALLOCATE ( GR_INTS(NSEA) ) + ! + IF ( FLAGLL ) THEN + IF ( MINVAL ( XGRD ) .LT. 0 .OR. & + MAXVAL ( XGRD ) .GT. 180.0 ) L360 = .TRUE. + END IF + ! + ! 4.b Check if weight files exist or create it + ! + FNAMEWHT='WHTGRIDINT.bin' + OPEN (994,FILE=FNMPRE(:J)//TRIM(FNAMEWHT),form='UNFORMATTED', convert=file_endian,IOSTAT=IERR,STATUS='OLD') + NSEA_FILE = 0 + IF (IERR.EQ.0) READ(994) NSEA_FILE ! basic consistency check ... + IF (NSEA_FILE.EQ.NSEA) THEN + DO ISEA = 1, NSEA + READ(994) COUNTG + ALLOCATE ( GR_INTS(ISEA)%IND_WTS(COUNTG),GR_INTS(ISEA)%GDID(COUNTG) ) + DO IG = 1,COUNTG + READ(994) GR_INTS(ISEA)%IND_WTS(IG)%AR + READ(994) GR_INTS(ISEA)%GDID(IG) + READ(994) COUNTF + ALLOCATE ( GR_INTS(ISEA)%IND_WTS(IG)%IP(COUNTF), & + GR_INTS(ISEA)%IND_WTS(IG)%JP(COUNTF), & + GR_INTS(ISEA)%IND_WTS(IG)%WT(COUNTF) ) + DO I = 1,COUNTF + READ(994) GR_INTS(ISEA)%IND_WTS(IG)%IP(I) + READ(994) GR_INTS(ISEA)%IND_WTS(IG)%JP(I) + READ(994) GR_INTS(ISEA)%IND_WTS(IG)%WT(I) END DO -! -!--------------------------------------------------------------------------- -! 4. Determine interpolation weights for output grids -! -! -! 4.a Point to output grid and allocate space for interpolation weights -! - CALL W3SETG( NG, 6, 6) - WRITE (NDSO,908) NSEA -! - ALLOCATE ( GR_INTS(NSEA) ) -! - IF ( FLAGLL ) THEN - IF ( MINVAL ( XGRD ) .LT. 0 .OR. & - MAXVAL ( XGRD ) .GT. 180.0 ) L360 = .TRUE. - END IF -! -! 4.b Check if weight files exist or create it -! - FNAMEWHT='WHTGRIDINT.bin' - OPEN (994,FILE=FNMPRE(:J)//TRIM(FNAMEWHT),form='UNFORMATTED', convert=file_endian,IOSTAT=IERR,STATUS='OLD') - NSEA_FILE = 0 - IF (IERR.EQ.0) READ(994) NSEA_FILE ! basic consistency check ... - IF (NSEA_FILE.EQ.NSEA) THEN - DO ISEA = 1, NSEA - READ(994) COUNTG - ALLOCATE ( GR_INTS(ISEA)%IND_WTS(COUNTG),GR_INTS(ISEA)%GDID(COUNTG) ) - DO IG = 1,COUNTG - READ(994) GR_INTS(ISEA)%IND_WTS(IG)%AR - READ(994) GR_INTS(ISEA)%GDID(IG) - READ(994) COUNTF - ALLOCATE ( GR_INTS(ISEA)%IND_WTS(IG)%IP(COUNTF), & - GR_INTS(ISEA)%IND_WTS(IG)%JP(COUNTF), & - GR_INTS(ISEA)%IND_WTS(IG)%WT(COUNTF) ) - DO I = 1,COUNTF - READ(994) GR_INTS(ISEA)%IND_WTS(IG)%IP(I) - READ(994) GR_INTS(ISEA)%IND_WTS(IG)%JP(I) - READ(994) GR_INTS(ISEA)%IND_WTS(IG)%WT(I) - END DO - READ(994) GR_INTS(ISEA)%IND_WTS(IG)%NP - END DO ! IG - READ(994) GR_INTS(ISEA)%NGRDS - END DO ! ISEA - - ELSE - OPEN (994,FILE=FNMPRE(:J)//TRIM(FNAMEWHT),form='UNFORMATTED', convert=file_endian,IOSTAT=IERR) - -! -! 4.b Loop through the wet points -! - DO ISEA = 1, NSEA -! -! IF (MOD(ISEA,NINT(REAL(NSEA)/100)).EQ.1) & -! WRITE(6,*) 'Treating point ',ISEA,' out of ', NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - DAREA = ABS(GSQRT(IY,IX)) -! - ALLOCATE ( GR_INTS(ISEA)%IND_WTS(NG-1),GR_INTS(ISEA)%GDID(NG-1) ) -! -! 4.b.i Loop through the input grids for each wet point -! - COUNTG = 0 - DO IG = 1,NG-1 -! -! 4.b.ii Check if point is enclosed in grid domain -! - INGRID=.FALSE. - IF (GRIDS(IG)%GTYPE .EQ. UNGTYPE) THEN - ! Look for a triangle at the coarse cell center - CALL IS_IN_UNGRID(IG, XGRD(IY,IX), YGRD(IY,IX), & - ITOUT, IS, JS, RW) - IF (ITOUT.GT.0) INGRID=.TRUE. -! ! If extrapolation activated, force to find if a triangles is inside -! ! the coarse grid cell even if there is no triangle in the cell center - IF (INTMETHOD.EQ.1) THEN - WRITE(991,'(2I6,2F9.4,I8,3I8,3F5.3)') IX,IY,XGRD(IY,IX), YGRD(IY,IX), ITOUT, IS(1:3), RW(1:3) - IF (ITOUT.EQ.0) WRITE(992,*) IX,IY,ISEA,XGRD(IY,IX), YGRD(IY,IX) - IF (ITOUT.EQ.0) THEN - CALL IS_IN_UNGRID2(IG, XGRD(IY,IX), YGRD(IY,IX), INTMETHOD, & - ITOUT, IS, JS, RW) - WRITE(993,'(2I6,2F9.4,I8,3I8,3F6.3)') IX,IY,XGRD(IY,IX), YGRD(IY,IX), ITOUT, IS(1:3), RW(1:3) - ENDIF - !IF (ITOUT.EQ.0) CALL IS_IN_UNGRID(IG, XGRD(IY,IX)+DX, YGRD(IY,IX), ITOUT, IS, JS, RW) - !IF (ITOUT.GT.0) INGRID=.TRUE. - !IF (ITOUT.EQ.0) CALL IS_IN_UNGRID(IG, XGRD(IY,IX)-DX, YGRD(IY,IX), ITOUT, IS, JS, RW) - !IF (ITOUT.GT.0) INGRID=.TRUE. - !IF (ITOUT.EQ.0) CALL IS_IN_UNGRID(IG, XGRD(IY,IX), YGRD(IY,IX)+DY, ITOUT, IS, JS, RW) - !IF (ITOUT.GT.0) INGRID=.TRUE. - !IF (ITOUT.EQ.0) CALL IS_IN_UNGRID(IG, XGRD(IY,IX), YGRD(IY,IX)-DY, ITOUT, IS, JS, RW) - !IF (ITOUT.GT.0) INGRID=.TRUE. - END IF - ELSE - IF ( W3GRMP ( GRIDS(IG)%GSU, REAL(XGRD(IY,IX)), REAL(YGRD(IY,IX)), IS, & - JS, RW ) ) INGRID=.TRUE. - END IF - IF (INGRID) THEN -! -! 4.b.iii Check source grid resolution vs target grid resolution -! (averaging used for finer resolution source grids) -! - IF (GRIDS(IG)%GTYPE .EQ. UNGTYPE) THEN - SAREA = GRIDS(IG)%TRIA(ITOUT) - ELSE - DO I = 1,4 - XCRNR(I) = GRIDS(IG)%XGRD(JS(I),IS(I)) - YCRNR(I) = GRIDS(IG)%YGRD(JS(I),IS(I)) - END DO - XCRNR(5) = XCRNR(1) - YCRNR(5) = YCRNR(1) - DO I = 1,4 - IF ( ABS (XCRNR(I+1)-XCRNR(I)) .GT. 180. .AND. & - GRIDS(IG)%ICLOSE .EQ. ICLOSE_SMPL ) THEN - DT(I) = SQRT ( (ABS(XCRNR(I+1)-XCRNR(I))-360.)**2 + & - (YCRNR(I+1)-YCRNR(I))**2 ) - ELSE - DT(I) = SQRT ( (XCRNR(I+1)-XCRNR(I))**2 + & - (YCRNR(I+1)-YCRNR(I))**2 ) - END IF - END DO - SXT = 0.5*(DT(1)+DT(3)) - SYT = 0.5*(DT(2)+DT(4)) - SAREA = (SXT*SYT) - END IF - NS = NINT(DAREA/SAREA) -! - IF ( NS .LE. 2 .OR. GRIDS(IG)%GTYPE .EQ. UNGTYPE ) THEN -! FA: Quick fix for UNST type grids: always perform interpolation -! To be updated later ... -! -! 4.b.iv Counting the contributing nodes to re-normalize the weights RW -! - ALLOCATE ( TMP_INDX(4) ) - COUNTF = 0 - SUMWT = 0.0 - DO I = 1,4 -! The following two IF tests are separated because for triangles, JS(4)=IS(4)=0 - IF ( RW(I) .GT. 0.0 ) THEN - ! MAPSTA == 0 indicated excluded point (either land - ! or truly excluded) - IF ( GRIDS(IG)%MAPSTA(JS(I),IS(I)) .NE. 0) THEN - COUNTF = COUNTF+1 - TMP_INDX(COUNTF) = I - SUMWT = SUMWT + RW(I) - END IF - END IF - END DO -! -! 4.b.v Interpolating to target grid -! - IF ( COUNTF .GT. 0 ) THEN -! Should use SAREA info to prevent the increment of COUNTG ... -! what about islands / land in triangle meshes? they are not part of the triangles... - COUNTG = COUNTG + 1 - IF (COUNTG.GT.1) THEN - IF (SAREA.LT.0.5*GR_INTS(ISEA)%IND_WTS(COUNTG-1)%AR) THEN - DO JG=1,COUNTG-1 - DEALLOCATE (GR_INTS(ISEA)%IND_WTS(JG)%IP) - DEALLOCATE (GR_INTS(ISEA)%IND_WTS(JG)%JP) - DEALLOCATE (GR_INTS(ISEA)%IND_WTS(JG)%WT) - END DO - COUNTG=1 - END IF - END IF - - GR_INTS(ISEA)%IND_WTS(COUNTG)%AR = SAREA - GR_INTS(ISEA)%GDID(COUNTG) = IG - INT_MAP(IX,IY) = REAL( IG ) + READ(994) GR_INTS(ISEA)%IND_WTS(IG)%NP + END DO ! IG + READ(994) GR_INTS(ISEA)%NGRDS + END DO ! ISEA - ALLOCATE ( GR_INTS(ISEA)%IND_WTS(COUNTG)%IP(COUNTF), & - GR_INTS(ISEA)%IND_WTS(COUNTG)%JP(COUNTF), & - GR_INTS(ISEA)%IND_WTS(COUNTG)%WT(COUNTF) ) - DO I = 1,COUNTF - GR_INTS(ISEA)%IND_WTS(COUNTG)%IP(I) = IS(TMP_INDX(I)) - GR_INTS(ISEA)%IND_WTS(COUNTG)%JP(I) = JS(TMP_INDX(I)) - GR_INTS(ISEA)%IND_WTS(COUNTG)%WT(I) = RW(TMP_INDX(I))/SUMWT - END DO - GR_INTS(ISEA)%IND_WTS(COUNTG)%NP = COUNTF - END IF - DEALLOCATE ( TMP_INDX ) -! - ELSE -! -! 4.b.vi Find the averaging points for higher resolution grid -! Step 1 : Compute the corners of the cell -! - X0 = XGRD(IY,IX) - Y0 = YGRD(IY,IX) - IF ( IX .GT. 1 .AND. IX .LT. NX .AND. IY .GT. 1 & - .AND. IY .LT. NY ) THEN - XT = XGRD(IY-1,IX+1) - YT = YGRD(IY-1,IX+1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(1) = 0.5*(XT+X0) - YCRNR(1) = 0.5*(YT+Y0) - XT = XGRD(IY+1,IX+1) - YT = YGRD(IY+1,IX+1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(2) = 0.5*(XT+X0) - YCRNR(2) = 0.5*(YT+Y0) - XT = XGRD(IY+1,IX-1) - YT = YGRD(IY+1,IX-1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(3) = 0.5*(XT+X0) - YCRNR(3) = 0.5*(YT+Y0) - XT = XGRD(IY-1,IX-1) - YT = YGRD(IY-1,IX-1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(4) = 0.5*(XT+X0) - YCRNR(4) = 0.5*(YT+Y0) - ELSEIF ( IX .EQ. 1 ) THEN - IF ( IY .EQ. 1 ) THEN - XT = XGRD(IY+1,IX+1) - YT = YGRD(IY+1,IX+1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(2) = 0.5*(XT+X0) - YCRNR(2) = 0.5*(YT+Y0) - XCRNR(4) = 2*X0 - XCRNR(2) - YCRNR(4) = 2*Y0 - YCRNR(2) - XCRNR(3) = X0 - (YCRNR(2)-Y0) - YCRNR(3) = Y0 + (XCRNR(2)-X0) - XCRNR(1) = 2*X0 - XCRNR(3) - YCRNR(1) = 2*Y0 - YCRNR(3) - ELSEIF ( IY .EQ. NY ) THEN - XT = XGRD(IY-1,IX+1) - YT = YGRD(IY-1,IX+1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(1) = 0.5*(XT+X0) - YCRNR(1) = 0.5*(YT+Y0) - XCRNR(3) = 2*X0 - XCRNR(1) - YCRNR(3) = 2*Y0 - YCRNR(1) - XCRNR(2) = X0 - (Y0-YCRNR(1)) - YCRNR(2) = Y0 + (X0-XCRNR(1)) - XCRNR(4) = 2*X0 - XCRNR(2) - YCRNR(4) = 2*Y0 - YCRNR(2) - ELSE - XT = XGRD(IY-1,IX+1) - YT = YGRD(IY-1,IX+1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(1) = 0.5*(XT+X0) - YCRNR(1) = 0.5*(YT+Y0) - XT = XGRD(IY+1,IX+1) - YT = YGRD(IY+1,IX+1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(2) = 0.5*(XT+X0) - YCRNR(2) = 0.5*(YT+Y0) - XCRNR(3) = 2*X0 - XCRNR(1) - YCRNR(3) = 2*Y0 - YCRNR(1) - XCRNR(4) = 2*X0 - XCRNR(2) - YCRNR(4) = 2*Y0 - YCRNR(2) - ENDIF - ELSEIF ( IX .EQ. NX ) THEN - IF ( IY .EQ. 1 ) THEN - XT = XGRD(IY+1,IX-1) - YT = YGRD(IY+1,IX-1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(3) = 0.5*(XT+X0) - YCRNR(3) = 0.5*(YT+Y0) - XCRNR(2) = X0 - (YCRNR(3)-Y0) - YCRNR(2) = Y0 + (XCRNR(3)-X0) - XCRNR(1) = 2*X0 - XCRNR(3) - YCRNR(1) = 2*Y0 - YCRNR(3) - XCRNR(4) = 2*X0 - XCRNR(2) - YCRNR(4) = 2*Y0 - YCRNR(2) - ELSEIF ( IY .EQ. NY ) THEN - XT = XGRD(IY-1,IX-1) - YT = YGRD(IY-1,IX-1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(4) = 0.5*(XT+X0) - YCRNR(4) = 0.5*(YT+Y0) - XCRNR(3) = X0 - (YCRNR(4)-Y0) - YCRNR(3) = Y0 + (XCRNR(4)-X0) - XCRNR(1) = 2*X0 - XCRNR(3) - YCRNR(1) = 2*Y0 - YCRNR(3) - XCRNR(2) = 2*X0 - XCRNR(4) - YCRNR(2) = 2*Y0 - YCRNR(4) - ELSE - XT = XGRD(IY+1,IX-1) - YT = YGRD(IY+1,IX-1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(3) = 0.5*(XT+X0) - YCRNR(3) = 0.5*(YT+Y0) - XT = XGRD(IY-1,IX-1) - YT = YGRD(IY-1,IX-1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(4) = 0.5*(XT+X0) - YCRNR(4) = 0.5*(YT+Y0) - XCRNR(1) = 2*X0 - XCRNR(3) - YCRNR(1) = 2*Y0 - YCRNR(3) - XCRNR(2) = 2*X0 - XCRNR(4) - YCRNR(2) = 2*Y0 - YCRNR(4) - ENDIF - ELSE - IF ( IY .EQ. 1 ) THEN - XT = XGRD(IY+1,IX+1) - YT = YGRD(IY+1,IX+1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(2) = 0.5*(XT+X0) - YCRNR(2) = 0.5*(YT+Y0) - XT = XGRD(IY+1,IX-1) - YT = YGRD(IY+1,IX-1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(3) = 0.5*(XT+X0) - YCRNR(3) = 0.5*(YT+Y0) - XCRNR(4) = 2*X0 - XCRNR(2) - YCRNR(4) = 2*Y0 - YCRNR(2) - XCRNR(1) = 2*X0 - XCRNR(3) - YCRNR(1) = 2*Y0 - YCRNR(3) - ELSE - XT = XGRD(IY-1,IX-1) - YT = YGRD(IY-1,IX-1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(4) = 0.5*(XT+X0) - YCRNR(4) = 0.5*(YT+Y0) - XT = XGRD(IY-1,IX+1) - YT = YGRD(IY-1,IX+1) - IF ( ABS(XT-X0) .GT. 270 ) THEN - XT = XT - SIGN(360.,XT-X0) - END IF - XCRNR(1) = 0.5*(XT+X0) - YCRNR(1) = 0.5*(YT+Y0) - XCRNR(2) = 2*X0 - XCRNR(4) - YCRNR(2) = 2*Y0 - YCRNR(4) - XCRNR(3) = 2*X0 - XCRNR(1) - YCRNR(3) = 2*Y0 - YCRNR(1) - END IF - END IF - BRNCHCL = .FALSE. - BRNCHCR = .FALSE. - IF ( FLAGLL .AND. ICLOSE .EQ. ICLOSE_SMPL ) THEN - IF ( L360 ) THEN - IF ( MINVAL ( XCRNR(1:4) ) .LT. 0.0 ) BRNCHCL = .TRUE. - IF ( MAXVAL ( XCRNR(1:4) ) .GT. 360.0 ) BRNCHCR = .TRUE. - ELSE - IF ( MINVAL ( XCRNR(1:4) ) .LT. -180.0 ) BRNCHCL = .TRUE. - IF ( MAXVAL ( XCRNR(1:4) ) .GT. 180.0 ) BRNCHCR = .TRUE. - END IF - END IF -! -! Step 2 : Loop through source grid to find all active points in cell -! -!FA : why only *5 ???... -! - ALLOCATE ( TMP_INDX(NS*5) ) - COUNTF = 0 - DO I = 1, GRIDS(IG)%NSEA - IXT = GRIDS(IG)%MAPSF(I,1) - IYT = GRIDS(IG)%MAPSF(I,2) - XT = GRIDS(IG)%XGRD(IYT,IXT) - YT = GRIDS(IG)%YGRD(IYT,IXT) -! - IF ( FLAGLL ) THEN - IF ( L360 ) THEN - IF ( XT .LT. 0 ) XT = XT + 360. - ELSE - IF ( XT .GT. 180. ) XT = XT - 360. - END IF - END IF - INGRD = W3CKCL (FLAGLL,XT,YT,4,XCRNR,YCRNR,LPLC) - IF ( INGRD ) THEN - COUNTF = COUNTF+1 - TMP_INDX(COUNTF) = I - ELSEIF ( BRNCHCL .AND. GRIDS(IG)%ICLOSE & - .EQ. ICLOSE_SMPL ) THEN - XTT = XT - 360.0 - INGRD = W3CKCL (FLAGLL,XTT,YT,4,XCRNR,YCRNR,LPLC) - IF ( INGRD ) THEN - COUNTF = COUNTF+1 - TMP_INDX(COUNTF) = I - END IF - ELSEIF ( BRNCHCR .AND. GRIDS(IG)%ICLOSE & - .EQ. ICLOSE_SMPL ) THEN - XTT = XT + 360.0 - INGRD = W3CKCL (FLAGLL,XTT,YT,4,XCRNR,YCRNR,LPLC) - IF ( INGRD ) THEN - COUNTF = COUNTF+1 - TMP_INDX(COUNTF) = I - END IF - END IF - END DO -! -! Step 3 : Save interior points for equal wt. interpolation (averaging) -! - IF ( COUNTF .NE. 0 ) THEN - COUNTG = COUNTG + 1 - GR_INTS(ISEA)%GDID(COUNTG) = IG - INT_MAP(IX,IY) = REAL( IG ) - ALLOCATE ( GR_INTS(ISEA)%IND_WTS(COUNTG)%IP(COUNTF), & - GR_INTS(ISEA)%IND_WTS(COUNTG)%JP(COUNTF), & - GR_INTS(ISEA)%IND_WTS(COUNTG)%WT(COUNTF) ) - DO I = 1,COUNTF - IXT = GRIDS(IG)%MAPSF(TMP_INDX(I),1) - IYT = GRIDS(IG)%MAPSF(TMP_INDX(I),2) - GR_INTS(ISEA)%IND_WTS(COUNTG)%IP(I) = IXT - GR_INTS(ISEA)%IND_WTS(COUNTG)%JP(I) = IYT - GR_INTS(ISEA)%IND_WTS(COUNTG)%WT(I) = 1./( REAL(COUNTF) ) - END DO - GR_INTS(ISEA)%IND_WTS(COUNTG)%NP = COUNTF - END IF - DEALLOCATE ( TMP_INDX ) -! - END IF ! End of check for grid resolution -! - END IF ! End of check for point inside grid -! - END DO ! End of loop through all input grids -! - GR_INTS(ISEA)%NGRDS = COUNTG -! -! 4.b.vii Check to see if interpolation weights found. -! Status of output points with / without weights set in MAPST2 -! using the next available bit -! - IF ( GR_INTS(ISEA)%NGRDS .EQ. 0 ) THEN -#ifdef W3_T - WRITE (NDSO,909)IX, IY -#endif - MAPINT = 1 - MAPST2(IY,IX) = MAPST2(IY,IX) + MAPINT*16 - MAPSTA(IY,IX) = -ABS ( MAPSTA(IY,IX) ) - END IF -! - END DO ! End of loop through all wet points -! -! Now dumps the coefficients to file ... - WRITE(994) NSEA - DO ISEA = 1, NSEA - COUNTG = GR_INTS(ISEA)%NGRDS - WRITE(994) COUNTG - DO IG = 1,COUNTG - WRITE(994) GR_INTS(ISEA)%IND_WTS(IG)%AR - WRITE(994) GR_INTS(ISEA)%GDID(IG) - COUNTF = GR_INTS(ISEA)%IND_WTS(IG)%NP - WRITE(994) COUNTF - DO I = 1,COUNTF - WRITE(994) GR_INTS(ISEA)%IND_WTS(IG)%IP(I) - WRITE(994) GR_INTS(ISEA)%IND_WTS(IG)%JP(I) - WRITE(994) GR_INTS(ISEA)%IND_WTS(IG)%WT(I) - END DO - WRITE(994) GR_INTS(ISEA)%IND_WTS(IG)%NP - END DO ! IG - WRITE(994) GR_INTS(ISEA)%NGRDS - END DO ! ISEA - END IF ! NSEA.EQ.NSEA_FILE - CLOSE(994) -! -! 4.c Print Interpolation grids map -! - IX = 1+NX/24 - IY = 1+NY/24 - CALL PRTBLK ( NDSO, NX, NY, NX, INT_MAP, MAP, -1, 1., 1, NX, IX, 1, & - NY, IY, 'Grid Interpolation Map', ' ' ) -! -!--------------------------------------------------------------------------- -! 5 Output interpolations -! -! 5.a Set-up dimensions for target grid outputs and allocate file pointers -! - CALL W3SETA(NG, 6, 6) - CALL W3DIMA(NG, 6, 6, .TRUE. ) - CALL W3DIMW(NG, 6, 6, .TRUE. ) - ALLOCATE(FIDOUT(NG)) - DO IG = 1,NG - FIDOUT(IG) = 30 + (IG-1)*10 - END DO -! -! 5.b Initialize and read the first set of fields for base grids -! - DO IG = 1,NG-1 - CALL W3SETO( IG, 6, 6) - CALL W3IOGO('READ',FIDOUT(IG),IOTST,IG) - IF ( IOTST .NE. 0 ) THEN - GO TO 2111 - ENDIF - END DO -! -! 5.c Setup the output flag options for the target grid -! - WRITE (NDSO,910) - DO I = 1, NOGRP - OUTPTS(NG)%OUT1%FLOGRD(I,:) = OUTPTS(1)%OUT1%FLOGRD(I,:) - WRITE (NDSO,911) I - IF (I.LT.9) THEN - WRITE (NDSO, 912) (OUTPTS(NG)%OUT1%FLOGRD(I,J),J=1,NGRPP) - ELSE - WRITE (NDSO, 913) - END IF - END DO - WRITE (NDSO, 915) -! -! Print output flags in human readable from. Mark -! groups that do not make sense to interpolate to -! target grid (e.g. Groups 9, 10). -! - DO I=1, NOGRP - DO J=1, NGRPP - IF ( OUTPTS(NG)%OUT1%FLOGRD(I,J) ) THEN - IF ( I .EQ. 4 .AND. J .EQ. 8 ) THEN - WRITE (NDSO, 916) I,IDOUT(I,J), '*** NOT IMPLEMENTED ***' - OUTPTS(NG)%OUT1%FLOGRD(I,J) = .FALSE. - ELSE IF ( I .LE. 8 ) THEN - WRITE (NDSO, 916) I,IDOUT(I,J), ' ' - ELSE - WRITE (NDSO, 916) I,IDOUT(I,J), '*** NOT IMPLEMENTED ***' - OUTPTS(NG)%OUT1%FLOGRD(I,J) = .FALSE. - END IF - END IF - END DO - END DO - WRITE (NDSO, 915) -! -! 5.d Carry out interpolation in an infinite loop till appropriate -! time steps are interpolated -! - IOUT = 0 -! - DO - DTEST = DSEC21 ( WDATAS(1)%TIME, TOUT ) - IF ( DTEST .GT. 0. ) THEN - DO IG = 1,NG-1 - CALL W3IOGO('READ',FIDOUT(IG),IOTST,IG) - IF ( IOTST .NE. 0 ) THEN - GO TO 2111 - ENDIF - END DO - CYCLE - ENDIF - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF -! - IOUT = IOUT + 1 - CALL STME21 ( TOUT, IDTIME) - WRITE (NDSO,914) IDTIME -! - WDATAS(NG)%TIME = WDATAS(1)%TIME - CALL W3SETO(NG, 6, 6) - CALL W3SETG(NG, 6, 6) - CALL W3SETA(NG, 6, 6) - CALL W3SETW(NG, 6, 6) -! - CALL W3EXGI ( NG-1, NSEA, NOSWLL_MIN, INTMETHOD ) -! - CALL TICK21 ( TOUT , DTREQ ) - IF ( IOUT .GE. NOUT ) EXIT - END DO - GOTO 2222 -! -!--------------------------------------------------------------------------- -! Escape locations read errors : -! - 2000 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 1 ) -! - 2001 CONTINUE - WRITE(NDSE,1001) - CALL EXTCDE ( 2 ) -! - 2002 CONTINUE - WRITE(NDSE,1002) IERR - CALL EXTCDE ( 3 ) -! - 2111 CONTINUE - WRITE(NDSO,950) - 2222 CONTINUE - WRITE(NDSO,999) -! -!--------------------------------------------------------------------------- -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Grid interpolation *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) - 902 FORMAT ( ' Time Information : '/ & - '---------------------------------------------'/ & - ' Starting Time : ',A/ & - ' Interval (in sec) : ',F10.2/ & - ' Number of requests : ',I4/ & - '---------------------------------------------') - 903 FORMAT ( ' Number of grids (including output grid) =',I3/) - 904 FORMAT ( /' Extension for grid ',I3,' is --> ',A10/) - 905 FORMAT ( ' Grid Particulars are : '/ & - ' Dimensions = ',2(I9,2X)/ & - ' Grid Type = ',I3,' ==> 1 Rect, 2 Curv, 3 Unstr'/ & - ' Grid Closure = ',I3,' ==> -1 None, 2 Simple, 8 Tripolar') - 907 FORMAT ( /' NOTE : The no. of swell partitions from input and', & - ' target grids do not match',/ & - ' The Min. no. of partitions from input grids =',I5/ & - ' The no. of partitions for target grid =',I5/ & - ' Interpolation will be limited to the smaller', & - ' number of the partitions,',/ & - ' rest will be marked undefined.' ) - 908 FORMAT (/' Preparing interpolation weights for output grid ' / & - ' Total number of wet points for interpolation ',I7/) - 909 FORMAT (/' *** WARNING !! No interpolation points at ',2(I5)/) - 910 FORMAT (/' Interpolating fields .... '/) - 911 FORMAT (' Output group ', I5) - 912 FORMAT (' Output variable flags are -> ',7(5L2,1X)) - 913 FORMAT (' Output variables skipped') - 914 FORMAT ( ' OUTPUT TIME : ',A) - 915 FORMAT ( ' ------------------------------------------------') - 916 FORMAT ( I5,A,2X,A) - 917 FORMAT (/' Interpolation scheme = ',I1,' ==> 0 linear, ', & - '1 extrapolate unstructured, 2 nearest'/) - 950 FORMAT (/' End of file reached'/) - 999 FORMAT (/15X,' *** End of Grid interpolation Routine *** '/ & - 15X,'==============================================='/) -! - 1000 FORMAT (/' *** ERROR IN WAVEGRID_INTERP : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) - 1001 FORMAT (/' *** ERROR IN WAVEGRID_INTERP : '/ & - ' PREMATURE END IN INPUT FILE'/) - 1002 FORMAT (/' *** ERROR IN WAVEGRID_INTERP : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! -!/ -!/ Internal Subroutine -!/ -!/ Internal Subroutine W3EXGI ----------------------------------------------/ -!/ - CONTAINS -!/ -----------------------------------------------------------------------/ -!> @brief Perform actual output of interpolated data. -!> -!> @param[in] NGRD -!> @param[in] NSEA -!> @param[in] NOSWLL_MIN -!> @param[in] INTMETHOD -!> @author A. Chawla @date 22-Mar-2021 -! - SUBROUTINE W3EXGI ( NGRD, NSEA, NOSWLL_MIN, INTMETHOD ) -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | A. Chawla | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 09-Jul-2009 : Original code ( version 3.14 ) -!/ 21-Feb-2013 : Modified to new output structure ( version 4.11 ) -!/ 30-Apr-2014 : Add group 3 ( version 5.00 ) -!/ 27-Aug-2015 : ice thick. and floe added as output ( version 5.10 ) -!/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) -!/ -! 1. Purpose : -! -! Perform actual output of interpolated data. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Subroutine it resides in -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ -------------------------------------------------------------------------/ - USE W3ADATMD - USE W3WDATMD - USE W3ODATMD, ONLY: NOGE - USE W3IOGOMD, ONLY: W3IOGO - USE W3GDATMD, ONLY: E3DF, NK -!/ -------------------------------------------------------------------------/ -!/ Parameter List -!/ - INTEGER, INTENT(IN) :: NGRD, NSEA, NOSWLL_MIN, INTMETHOD -!/ -!/ Local Parameters -!/ - INTEGER :: ISEA, GSEA, IG, IGRID, IPTS, IGX, IGY, IX, & - IY, ISWLL, ICAP, IBED, IFREQ, IK, INRST - INTEGER :: MAPINT, MAPICE, MAPDRY, MAPMSK, MAPLND, & - NMAPICE, NMAPDRY, NMAPMSK, NMAPLND, & - LMAPICE, LMAPDRY, LMAPMSK, LMAPLND, & - MAPICET, MAPDRYT, MAPMSKT, MAPLNDT - INTEGER :: SUMGRD - REAL :: VAR1, VAR2, WT -! Local group 1 variables - REAL :: DWAUX, CXAUX, CYAUX, UAAUX, UDAUX, ASAUX, & - WLVAUX, ICEAUX, ICEHAUX, ICEFAUX, BERGAUX, & - SED_D50AUX, RHOAIRAUX, TAUAAUX, TAUADIRAUX, & - SUMWT1(NOGE(1)) -! Local group 2 variables - REAL :: HSAUX, WLMAUX, T02AUX, T0M1AUX, T01AUX, & - FP0AUX, THMAUX1, THMAUX2, THSAUX, THP0AUX1, & - THP0AUX2, HSIGAUX, STMAXEAUX,STMAXDAUX, & - HMAXEAUX, HCMAXEAUX, HMAXDAUX, HCMAXDAUX, & - WBTAUX, WNMEANAUX, SUMWT2(NOGE(2)) -! Local group 3 variables - REAL :: EFAUX(E3DF(2,1):E3DF(3,1)), & - TH1MAUX(E3DF(2,2):E3DF(3,2)), & - STH1MAUX(E3DF(2,3):E3DF(3,3)), & - TH2MAUX(E3DF(2,4):E3DF(3,4)), & - STH2MAUX(E3DF(2,5):E3DF(3,5)), WNAUX(1:NK), & - SUMWT3A(E3DF(2,1):E3DF(3,1)), & - SUMWT3B(E3DF(2,2):E3DF(3,2)), & - SUMWT3C(E3DF(2,3):E3DF(3,3)), & - SUMWT3D(E3DF(2,4):E3DF(3,4)), & - SUMWT3E(E3DF(2,5):E3DF(3,5)), & - SUMWT3F(1:NK) -! Local group 4 variables - REAL :: PHSAUX(0:NOSWLL_MIN), PTPAUX(0:NOSWLL_MIN), & - PLPAUX(0:NOSWLL_MIN), PSIAUX(0:NOSWLL_MIN), & - PWSAUX(0:NOSWLL_MIN), PDIRAUX1(0:NOSWLL_MIN), & - PWSTAUX, PDIRAUX2(0:NOSWLL_MIN), & - PTHP0AUX1(0:NOSWLL_MIN), & - PTHP0AUX2(0:NOSWLL_MIN), & - PQPAUX(0:NOSWLL_MIN), PPEAUX(0:NOSWLL_MIN), & - PGWAUX(0:NOSWLL_MIN), PSWAUX(0:NOSWLL_MIN), & - PTM1AUX(0:NOSWLL_MIN), PT1AUX(0:NOSWLL_MIN), & - PT2AUX(0:NOSWLL_MIN), PEPAUX(0:NOSWLL_MIN), & - SUMWT4(NOGE(4),0:NOSWLL_MIN) -! Local group 5 variables - REAL :: USTAUX1, USTAUX2, CHARNAUX, CGEAUX, & - PHIAWAUX, TAUWIXAUX, TAUWIYAUX, TAUWNXAUX, & - TAUWNYAUX, WHITECAPAUX(4), SUMWT5(NOGE(5)), & - SUMWTC(4) -! Local group 6 variables - REAL :: SXXAUX, SYYAUX, SXYAUX, TAUOXAUX, TAUOYAUX, & - BHDAUX, PHIOCAUX, TUSXAUX, TUSYAUX, USSXAUX, & - USSYAUX, PRMSAUX, TPMSAUX, SUMWT6(NOGE(6)), & - TAUICEAUX(2), PHICEAUX, & - TAUOCXAUX, TAUOCYAUX, & - US3DAUX(2*NK), SUMWT68(2*NK), & - P2SMSAUX(P2MSF(2):P2MSF(3)), & - SUMWT69(P2MSF(2):P2MSF(3)), & - USSPAUX(2*NK), SUMWT612(2*NK) -! Local Group 7 variables - REAL :: ABAAUX, ABDAUX, UBAAUX, UBDAUX, PHIBBLAUX, & - BEDFORMSAUX(3), TAUBBLAUX(2), & - SUMWT7(NOGE(7)), SUMWTB(3) -! Local group 8 variables - REAL :: MSSXAUX, MSSYAUX, MSCXAUX, MSCYAUX, MSSDAUX1, & - MSSDAUX2, MSCDAUX1, MSCDAUX2, QPAUX, & - SUMWT8(NOGE(8)) -!/ - LOGICAL :: ACTIVE - LOGICAL :: USEGRID(NGRD) -!/ -! -!------------------------------------------------------------------- -! 1. Preparations -! -! Group 1 Variables -! - DW = UNDEF - CX = UNDEF - CY = UNDEF - UA = UNDEF - UD = UNDEF - AS = UNDEF - WLV = UNDEF - ICE = UNDEF - BERG = UNDEF - RHOAIR = UNDEF - TAUA = UNDEF - TAUADIR = UNDEF -#ifdef W3_BT4 - SED_D50 = UNDEF -#endif -#ifdef W3_IS2 - ICEH = UNDEF - ICEF = UNDEF -#endif -! -! Group 2 variables -! - HS = UNDEF - WLM = UNDEF - T02 = UNDEF - T0M1 = UNDEF - T01 = UNDEF - FP0 = UNDEF - THM = UNDEF - THS = UNDEF - THP0 = UNDEF - HSIG = UNDEF - STMAXE = UNDEF - STMAXD = UNDEF - HMAXE = UNDEF - HCMAXE = UNDEF - HMAXD = UNDEF - HCMAXD = UNDEF - WBT = UNDEF - WNMEAN = UNDEF -! -! Group 3 variables -! - IF ( E3DF(1,1).GT.0 ) EF = UNDEF - IF ( E3DF(1,2).GT.0 ) TH1M = UNDEF - IF ( E3DF(1,3).GT.0 ) STH1M = UNDEF - IF ( E3DF(1,4).GT.0 ) TH2M = UNDEF - IF ( E3DF(1,5).GT.0 ) STH2M = UNDEF - WN = UNDEF -! -! Group 4 variables -! - PHS = UNDEF - PTP = UNDEF - PLP = UNDEF - PDIR = UNDEF - PSI = UNDEF - PWS = UNDEF - PWST = UNDEF - PNR = UNDEF - PTHP0 = UNDEF - PQP = UNDEF - PPE = UNDEF - PGW = UNDEF - PSW = UNDEF - PTM1 = UNDEF - PT1 = UNDEF - PT2 = UNDEF - PEP = UNDEF -! -! Group 5 variables -! - UST = UNDEF - USTDIR = UNDEF - CHARN = UNDEF - CGE = UNDEF - PHIAW = UNDEF - TAUWIX = UNDEF - TAUWIY = UNDEF - TAUWNX = UNDEF - TAUWNY = UNDEF - WHITECAP = UNDEF -! -! Group 6 variables -! - SXX = UNDEF - SXY = UNDEF - SYY = UNDEF - TAUOX = UNDEF - TAUOY = UNDEF - BHD = UNDEF - PHIOC = UNDEF - TUSX = UNDEF - TUSY = UNDEF - USSX = UNDEF - USSY = UNDEF - TAUOCX = UNDEF - TAUOCY = UNDEF - PRMS = UNDEF - TPMS = UNDEF - IF ( US3DF(1).GT.0 ) THEN - US3D = UNDEF - ENDIF - IF ( P2MSF(1).GT.0) THEN - P2SMS = UNDEF - ENDIF - TAUICE = UNDEF - PHICE = UNDEF - IF ( USSPF(1).GT.0 ) THEN - USSP = UNDEF - ENDIF -! -! Group 7 variables -! - ABA = UNDEF - ABD = UNDEF - UBA = UNDEF - UBD = UNDEF - BEDFORMS = UNDEF - PHIBBL = UNDEF - TAUBBL = UNDEF -! -! Group 8 variables -! - MSSX = UNDEF - MSSY = UNDEF - MSCX = UNDEF - MSCY = UNDEF - MSSD = UNDEF - MSCD = UNDEF - QP = UNDEF -! -!------------------------------------------------------------------- -! 2. Loop through output points -! - DO ISEA = 1, NSEA -! - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - MAPICE = MOD(MAPST2(IY,IX),2) - MAPDRY = MOD(MAPST2(IY,IX)/2,2) - MAPLND = MOD(MAPST2(IY,IX)/4,2) - MAPMSK = MOD(MAPST2(IY,IX)/8,2) - MAPINT = MOD(MAPST2(IY,IX)/16,2) - MAPST2(IY,IX) = MAPST2(IY,IX) - MAPICE - 2*MAPDRY - 4*MAPLND & - - 8*MAPMSK - ACTIVE = (MAPICE .NE. 1 .AND. MAPDRY .NE. 1) -! - IF ( MAPINT .EQ. 0 ) THEN -! -! Initial loop to determine status map -! Initialize by setting it to be ice free and wet -! - MAPICE = 0 - MAPDRY = 0 - MAPMSK = 0 - MAPLND = 0 - ACTIVE = .TRUE. - MAPSTA(IY,IX) = ABS ( MAPSTA(IY,IX) ) - SUMGRD = 0 - DO IG = 1,GR_INTS(ISEA)%NGRDS - IGRID = GR_INTS(ISEA)%GDID(IG) - NMAPICE = 0 - NMAPDRY = 0 - NMAPLND = 0 - NMAPMSK = 0 - MAPICET = 0 - MAPDRYT = 0 - MAPLNDT = 0 - MAPMSKT = 0 - IF ( INTMETHOD == 2 ) THEN - ! Nearest neighbour is the one with the most weight - INRST = MAXLOC(GR_INTS(ISEA)%IND_WTS(IG)%WT, DIM=1) - GR_INTS(ISEA)%IND_WTS(IG)%WT(:) = -1. - GR_INTS(ISEA)%IND_WTS(IG)%WT(INRST) = 1. - END IF - DO IPTS = 1,GR_INTS(ISEA)%IND_WTS(IG)%NP - IGX = GR_INTS(ISEA)%IND_WTS(IG)%IP(IPTS) - IGY = GR_INTS(ISEA)%IND_WTS(IG)%JP(IPTS) - LMAPICE = MOD ( GRIDS(IGRID)%MAPST2(IGY,IGX),2 ) - LMAPDRY = MOD ( GRIDS(IGRID)%MAPST2(IGY,IGX)/2,2 ) - LMAPLND = MOD ( GRIDS(IGRID)%MAPST2(IGY,IGX)/4,2 ) - LMAPMSK = MOD ( GRIDS(IGRID)%MAPST2(IGY,IGX)/8,2 ) - IF ( LMAPICE .EQ. 1 ) NMAPICE = NMAPICE + 1 - IF ( LMAPDRY .EQ. 1 ) NMAPDRY = NMAPDRY + 1 - IF ( LMAPLND .EQ. 1 ) NMAPLND = NMAPLND + 1 - IF ( LMAPMSK .EQ. 1 ) NMAPMSK = NMAPMSK + 1 - END DO - NMAPICE = NMAPICE*100/GR_INTS(ISEA)%IND_WTS(IG)%NP - NMAPDRY = NMAPDRY*100/GR_INTS(ISEA)%IND_WTS(IG)%NP - NMAPLND = NMAPLND*100/GR_INTS(ISEA)%IND_WTS(IG)%NP - NMAPMSK = NMAPMSK*100/GR_INTS(ISEA)%IND_WTS(IG)%NP - IF ( NMAPICE .GT. 50 ) MAPICET = 1 - IF ( NMAPDRY .GT. 50 ) MAPDRYT = 1 - IF ( NMAPLND .GT. 50 ) MAPLNDT = 1 - IF ( NMAPMSK .GT. 50 ) MAPMSKT = 1 - ACTIVE = (MAPICET .NE. 1 .AND. MAPDRYT .NE. 1 .AND. & - MAPLNDT .NE. 1 .AND. MAPMSKT .NE. 1) - IF ( ACTIVE ) THEN - USEGRID(IG) = .TRUE. - SUMGRD = SUMGRD+1 - MAPICE = MAPICET - MAPDRY = MAPDRYT - MAPLND = MAPLNDT - MAPMSK = MAPMSKT - ELSE - USEGRID(IG) = .FALSE. - END IF - END DO - IF ( SUMGRD .EQ. 0 ) THEN - MAPICE = MAPICET - MAPDRY = MAPDRYT - MAPLND = MAPLNDT - MAPMSK = MAPMSKT - END IF -! -! Reset the status map -! - MAPST2(IY,IX) = MAPST2(IY,IX) + MAPICE + 2*MAPDRY + 4*MAPLND + & - 8*MAPMSK - ACTIVE = (MAPICE .NE. 1 .AND. MAPDRY .NE. 1 .AND. MAPLND .NE. 1 & - .AND. MAPMSK .NE. 1) - IF ( .NOT. ACTIVE ) MAPSTA(IY,IX) = -ABS ( MAPSTA(IY,IX) ) -! -! Second loop to do the actual interpolation -! - DO IG = 1,GR_INTS(ISEA)%NGRDS -! - IF ( USEGRID(IG) ) THEN -! - IGRID = GR_INTS(ISEA)%GDID(IG) -! -! Initialize temporary variables used -! - SUMWT = 0.0 -! -! Group 1 variables -! - DWAUX = UNDEF - CXAUX = UNDEF - CYAUX = UNDEF - UAAUX = UNDEF - UDAUX = UNDEF - ASAUX = UNDEF - WLVAUX = UNDEF - ICEAUX = UNDEF - BERGAUX = UNDEF - SED_D50AUX = UNDEF - ICEHAUX = UNDEF - ICEFAUX = UNDEF - RHOAIRAUX = UNDEF - TAUAAUX = UNDEF - TAUADIRAUX = UNDEF - SUMWT1 = 0 -! -! Group 2 variables -! - HSAUX = UNDEF - WLMAUX = UNDEF - T02AUX = UNDEF - T0M1AUX = UNDEF - T01AUX = UNDEF - FP0AUX = UNDEF - THMAUX1 = UNDEF - THMAUX2 = UNDEF - THSAUX = UNDEF - THP0AUX1 = UNDEF - THP0AUX2 = UNDEF - HSIGAUX = UNDEF - STMAXEAUX = UNDEF - STMAXDAUX = UNDEF - HMAXEAUX = UNDEF - HCMAXEAUX = UNDEF - HMAXDAUX = UNDEF - HCMAXDAUX = UNDEF - WBTAUX = UNDEF - WNMEANAUX = UNDEF - SUMWT2 = 0 -! -! Group 3 variables -! - EFAUX = UNDEF - TH1MAUX = UNDEF - STH1MAUX = UNDEF - TH2MAUX = UNDEF - STH2MAUX = UNDEF - WNAUX = UNDEF - SUMWT3A = 0 - SUMWT3B = 0 - SUMWT3C = 0 - SUMWT3D = 0 - SUMWT3E = 0 - SUMWT3F = 0 -! -! Group 4 variables -! - PHSAUX = UNDEF - PTPAUX = UNDEF - PLPAUX = UNDEF - PDIRAUX1 = UNDEF - PDIRAUX2 = UNDEF - PSIAUX = UNDEF - PWSAUX = UNDEF - PWSTAUX = UNDEF - PTHP0AUX1 = UNDEF - PTHP0AUX2 = UNDEF - PQPAUX = UNDEF - PPEAUX = UNDEF - PGWAUX = UNDEF - PSWAUX = UNDEF - PTM1AUX = UNDEF - PT1AUX = UNDEF - PT2AUX = UNDEF - PEPAUX = UNDEF - SUMWT4 = 0 -! -! Group 5 variables -! - USTAUX1 = UNDEF - USTAUX2 = UNDEF - CHARNAUX = UNDEF - CGEAUX = UNDEF - PHIAWAUX = UNDEF - TAUWIXAUX = UNDEF - TAUWIYAUX = UNDEF - TAUWNXAUX = UNDEF - TAUWNYAUX = UNDEF - WHITECAPAUX = UNDEF - SUMWT5 = 0 - SUMWTC = 0 -! -! Group 6 variables -! - SXXAUX = UNDEF - SXYAUX = UNDEF - SYYAUX = UNDEF - TAUOXAUX = UNDEF - TAUOYAUX = UNDEF - BHDAUX = UNDEF - PHIOCAUX = UNDEF - TUSXAUX = UNDEF - TUSYAUX = UNDEF - USSXAUX = UNDEF - USSYAUX = UNDEF - TAUOCXAUX = UNDEF - TAUOCYAUX = UNDEF - PRMSAUX = UNDEF - TPMSAUX = UNDEF - P2SMSAUX = UNDEF - US3DAUX = UNDEF - PHICEAUX = UNDEF - TAUICEAUX = UNDEF - USSPAUX = UNDEF - SUMWT69 = 0 - SUMWT68 = 0 - SUMWT612 = 0 - SUMWT6 = 0 -! -! Group 7 variables -! - ABAAUX = UNDEF - ABDAUX = UNDEF - UBAAUX = UNDEF - UBDAUX = UNDEF - BEDFORMSAUX = UNDEF - PHIBBLAUX = UNDEF - TAUBBLAUX = UNDEF - SUMWT7 = 0 - SUMWTB = 0 -! -! Group 8 variables -! - MSSXAUX = UNDEF - MSSYAUX = UNDEF - MSCXAUX = UNDEF - MSCYAUX = UNDEF - MSSDAUX1 = UNDEF - MSSDAUX2 = UNDEF - MSCDAUX1 = UNDEF - MSCDAUX2 = UNDEF - QPAUX = UNDEF - SUMWT8 = 0 -! -! Loop through the points per grid to obtain interpolated values -! - DO IPTS = 1,GR_INTS(ISEA)%IND_WTS(IG)%NP - IGX = GR_INTS(ISEA)%IND_WTS(IG)%IP(IPTS) - IGY = GR_INTS(ISEA)%IND_WTS(IG)%JP(IPTS) - WT = GR_INTS(ISEA)%IND_WTS(IG)%WT(IPTS) - IF ( WT < 0. ) THEN - ! Point is not nearest - CYCLE - END IF - GSEA = GRIDS(IGRID)%MAPFS(IGY,IGX) -! -! Group 1 variables -! - IF ( FLOGRD(1,1) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%DW(GSEA) .NE. UNDEF ) THEN - SUMWT1(1) = SUMWT1(1) + WT - IF ( DWAUX .EQ. UNDEF ) THEN - DWAUX = WADATS(IGRID)%DW(GSEA)*WT - ELSE - DWAUX = DWAUX + WADATS(IGRID)%DW(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(1,2) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%CX(GSEA) .NE. UNDEF ) THEN - SUMWT1(2) = SUMWT1(2) + WT - IF ( CXAUX .EQ. UNDEF ) THEN - CXAUX = WADATS(IGRID)%CX(GSEA)*WT - CYAUX = WADATS(IGRID)%CY(GSEA)*WT - ELSE - CXAUX = CXAUX + WADATS(IGRID)%CX(GSEA)*WT - CYAUX = CYAUX + WADATS(IGRID)%CY(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(1,3) ) THEN - IF ( WADATS(IGRID)%UA(GSEA) .NE. UNDEF ) THEN - SUMWT1(3) = SUMWT1(3) + WT - IF ( UAAUX .EQ. UNDEF ) THEN - UAAUX = WADATS(IGRID)%UA(GSEA)*WT - UDAUX = WADATS(IGRID)%UD(GSEA)*WT - ELSE - UAAUX = UAAUX + WADATS(IGRID)%UA(GSEA)*WT - UDAUX = UDAUX + WADATS(IGRID)%UD(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(1,4) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%AS(GSEA) .NE. UNDEF ) THEN - SUMWT1(4) = SUMWT1(4) + WT - IF ( ASAUX .EQ. UNDEF ) THEN - ASAUX = WADATS(IGRID)%AS(GSEA)*WT - ELSE - ASAUX = ASAUX + WADATS(IGRID)%AS(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(1,5) .AND. ACTIVE ) THEN - IF ( WDATAS(IGRID)%WLV(GSEA) .NE. UNDEF ) THEN - SUMWT1(5) = SUMWT1(5) + WT - IF ( WLVAUX .EQ. UNDEF ) THEN - WLVAUX = WDATAS(IGRID)%WLV(GSEA)*WT - ELSE - WLVAUX = WLVAUX + WDATAS(IGRID)%WLV(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(1,6) ) THEN - IF ( WDATAS(IGRID)%ICE(GSEA) .NE. UNDEF ) THEN - SUMWT1(6) = SUMWT1(6) + WT - IF ( ICEAUX .EQ. UNDEF ) THEN - ICEAUX = WDATAS(IGRID)%ICE(GSEA)*WT - ELSE - ICEAUX = ICEAUX + WDATAS(IGRID)%ICE(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(1,7) .AND. ACTIVE ) THEN - IF ( WDATAS(IGRID)%BERG(GSEA) .NE. UNDEF ) THEN - SUMWT1(7) = SUMWT1(7) + WT - IF ( BERGAUX .EQ. UNDEF ) THEN - BERGAUX = WDATAS(IGRID)%BERG(GSEA)*WT - ELSE - BERGAUX = BERGAUX + WDATAS(IGRID)%BERG(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(1,8) ) THEN - IF ( WADATS(IGRID)%TAUA(GSEA) .NE. UNDEF ) THEN - SUMWT1(8) = SUMWT1(8) + WT - IF ( TAUAAUX .EQ. UNDEF ) THEN - TAUAAUX = WADATS(IGRID)%TAUA(GSEA)*WT - TAUADIRAUX = WADATS(IGRID)%TAUADIR(GSEA)*WT - ELSE - TAUAAUX = TAUAAUX + WADATS(IGRID)%TAUA(GSEA)*WT - TAUADIRAUX = TAUADIRAUX + WADATS(IGRID)%TAUADIR(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(1,9) .AND. ACTIVE ) THEN - IF ( WDATAS(IGRID)%RHOAIR(GSEA) .NE. UNDEF ) THEN - SUMWT1(9) = SUMWT1(9) + WT - IF ( RHOAIRAUX .EQ. UNDEF ) THEN - RHOAIRAUX = WDATAS(IGRID)%RHOAIR(GSEA)*WT - ELSE - RHOAIRAUX = RHOAIRAUX + WDATAS(IGRID)%RHOAIR(GSEA)*WT - END IF - END IF - END IF -! -#ifdef W3_BT4 - IF ( FLOGRD(1,10) ) THEN - IF ( GRIDS(IGRID)%SED_D50(GSEA) .NE. UNDEF ) THEN - SUMWT1(10) = SUMWT1(10) + WT - IF ( SED_D50AUX .EQ. UNDEF ) THEN - SED_D50AUX = GRIDS(IGRID)%SED_D50(GSEA)*WT - ELSE - SED_D50AUX = SED_D50AUX + GRIDS(IGRID)%SED_D50(GSEA)*WT - END IF - END IF - END IF -#endif -! -#ifdef W3_IS2 - IF ( FLOGRD(1,11) ) THEN - IF ( WDATAS(IGRID)%ICEH(GSEA) .NE. UNDEF ) THEN - SUMWT1(11) = SUMWT1(11) + WT - IF (ICEHAUX .EQ. UNDEF) THEN - ICEHAUX = WDATAS(IGRID)%ICEH(GSEA)*WT - ELSE - ICEHAUX = ICEHAUX + WDATAS(IGRID)%ICEH(GSEA)*WT - END IF - END IF - END IF -#endif -! -#ifdef W3_IS2 - IF ( FLOGRD(1,12) ) THEN - IF ( WDATAS(IGRID)%ICEF(GSEA) .NE. UNDEF ) THEN - SUMWT1(12) = SUMWT1(12) + WT - IF (ICEFAUX .EQ. UNDEF) THEN - ICEFAUX = WDATAS(IGRID)%ICEF(GSEA)*WT - ELSE - ICEFAUX = ICEFAUX + WDATAS(IGRID)%ICEF(GSEA)*WT - END IF - END IF - END IF -#endif -! -! Group 2 variables -! - IF ( FLOGRD(2,1) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%HS(GSEA) .NE. UNDEF ) THEN - SUMWT2(1) = SUMWT2(1) + WT - IF ( HSAUX .EQ. UNDEF ) THEN - HSAUX = WADATS(IGRID)%HS(GSEA)*WT - ELSE - HSAUX = HSAUX + WADATS(IGRID)%HS(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(2,2) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%WLM(GSEA) .NE. UNDEF ) THEN - SUMWT2(2) = SUMWT2(2) + WT - IF ( WLMAUX .EQ. UNDEF ) THEN - WLMAUX = WADATS(IGRID)%WLM(GSEA)*WT - ELSE - WLMAUX = WLMAUX + WADATS(IGRID)%WLM(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(2,3) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%T02(GSEA) .NE. UNDEF ) THEN - SUMWT2(3) = SUMWT2(3) + WT - IF ( T02AUX .EQ. UNDEF ) THEN - T02AUX = WADATS(IGRID)%T02(GSEA)*WT - ELSE - T02AUX = T02AUX + WADATS(IGRID)%T02(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(2,4) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%T0M1(GSEA) .NE. UNDEF ) THEN - SUMWT2(4) = SUMWT2(4) + WT - IF ( T0M1AUX .EQ. UNDEF ) THEN - T0M1AUX = WADATS(IGRID)%T0M1(GSEA)*WT - ELSE - T0M1AUX = T0M1AUX + WADATS(IGRID)%T0M1(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(2,5) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%T01(GSEA) .NE. UNDEF ) THEN - SUMWT2(5) = SUMWT2(5) + WT - IF ( T01AUX .EQ. UNDEF ) THEN - T01AUX = WADATS(IGRID)%T01(GSEA)*WT - ELSE - T01AUX = T01AUX + WADATS(IGRID)%T01(GSEA)*WT - END IF - END IF - END IF -! - IF ( (FLOGRD(2,6) .OR. FLOGRD(2,18)) .AND. ACTIVE ) THEN - ! Note: Output TP [FLOGRD(2,18)] is derived from FP0 - IF ( WADATS(IGRID)%FP0(GSEA) .NE. UNDEF ) THEN - SUMWT2(6) = SUMWT2(6) + WT - IF ( FP0AUX .EQ. UNDEF ) THEN - FP0AUX = WADATS(IGRID)%FP0(GSEA)*WT - ELSE - FP0AUX = FP0AUX + WADATS(IGRID)%FP0(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(2,7) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%THM(GSEA) .NE. UNDEF ) THEN - SUMWT2(7) = SUMWT2(7) + WT - IF ( THMAUX1 .EQ. UNDEF ) THEN - THMAUX1 = COS ( WADATS(IGRID)%THM(GSEA) )*WT - THMAUX2 = SIN ( WADATS(IGRID)%THM(GSEA) )*WT - ELSE - THMAUX1 = THMAUX1 + COS ( WADATS(IGRID)%THM(GSEA) )*WT - THMAUX2 = THMAUX2 + SIN ( WADATS(IGRID)%THM(GSEA) )*WT - END IF - END IF - END IF -! - IF ( FLOGRD(2,8) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%THS(GSEA) .NE. UNDEF ) THEN - SUMWT2(8) = SUMWT2(8) + WT - IF ( THSAUX .EQ. UNDEF ) THEN - THSAUX = WADATS(IGRID)%THS(GSEA)*WT - ELSE - THSAUX = THSAUX + WADATS(IGRID)%THS(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(2,9) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%THP0(GSEA) .NE. UNDEF ) THEN - SUMWT2(9) = SUMWT2(9) + WT - IF ( THP0AUX1 .EQ. UNDEF ) THEN - THP0AUX1 = COS ( WADATS(IGRID)%THP0(GSEA) )*WT - THP0AUX2 = SIN ( WADATS(IGRID)%THP0(GSEA) )*WT - ELSE - THP0AUX1 = THP0AUX1 + & - COS ( WADATS(IGRID)%THP0(GSEA) )*WT - THP0AUX2 = THP0AUX2 + & - SIN ( WADATS(IGRID)%THP0(GSEA) )*WT - END IF - END IF - END IF -! - IF ( FLOGRD(2,10) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%HSIG(GSEA) .NE. UNDEF ) THEN - SUMWT2(10) = SUMWT2(10) + WT - IF ( HSIGAUX .EQ. UNDEF ) HSIGAUX = 0. - HSIGAUX = HSIGAUX + WADATS(IGRID)%HSIG(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(2,11) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%STMAXE(GSEA) .NE. UNDEF ) THEN - SUMWT2(11) = SUMWT2(11) + WT - IF ( STMAXEAUX .EQ. UNDEF ) STMAXEAUX = 0. - STMAXEAUX = STMAXEAUX + WADATS(IGRID)%STMAXE(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(2,12) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%STMAXD(GSEA) .NE. UNDEF ) THEN - SUMWT2(12) = SUMWT2(12) + WT - IF ( STMAXDAUX .EQ. UNDEF ) STMAXDAUX = 0. - STMAXDAUX = STMAXDAUX + WADATS(IGRID)%STMAXD(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(2,13) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%HMAXE(GSEA) .NE. UNDEF ) THEN - SUMWT2(13) = SUMWT2(13) + WT - IF ( HMAXEAUX .EQ. UNDEF ) HMAXEAUX = 0. - HMAXEAUX = HMAXEAUX + WADATS(IGRID)%HMAXE(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(2,14) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%HCMAXE(GSEA) .NE. UNDEF ) THEN - SUMWT2(14) = SUMWT2(14) + WT - IF ( HCMAXEAUX .EQ. UNDEF ) HCMAXEAUX = 0. - HCMAXEAUX = HCMAXEAUX + WADATS(IGRID)%HCMAXE(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(2,15) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%HMAXD(GSEA) .NE. UNDEF ) THEN - SUMWT2(15) = SUMWT2(15) + WT - IF ( HMAXDAUX .EQ. UNDEF ) HMAXDAUX = 0. - HMAXDAUX = HMAXDAUX + WADATS(IGRID)%HMAXD(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(2,16) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%HCMAXD(GSEA) .NE. UNDEF ) THEN - SUMWT2(16) = SUMWT2(16) + WT - IF ( HCMAXDAUX .EQ. UNDEF ) HCMAXDAUX = 0. - HCMAXDAUX = HCMAXDAUX + WADATS(IGRID)%HCMAXD(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(2,17) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%WBT(GSEA) .NE. UNDEF ) THEN - SUMWT2(17) = SUMWT2(17) + WT - IF ( WBTAUX .EQ. UNDEF ) WBTAUX = 0. - WBTAUX = WBTAUX + WADATS(IGRID)%WBT(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(2,19) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%WNMEAN(GSEA) .NE. UNDEF ) THEN - SUMWT2(19) = SUMWT2(19) + WT - IF ( WNMEANAUX .EQ. UNDEF ) WNMEANAUX = 0. - WNMEANAUX = WNMEANAUX + WADATS(IGRID)%WNMEAN(GSEA)*WT - END IF - END IF -! -! Group 3 variables -! - IF ( FLOGRD(3,1) .AND. ACTIVE ) THEN - DO IFREQ = E3DF(2,1),E3DF(3,1) - IF ( WADATS(IGRID)%EF(GSEA,IFREQ) .NE. UNDEF ) THEN - SUMWT3A(IFREQ) = SUMWT3A(IFREQ) + WT - IF ( EFAUX(IFREQ) .EQ. UNDEF ) THEN - EFAUX(IFREQ) = WADATS(IGRID)%EF(GSEA,IFREQ)*WT - ELSE - EFAUX(IFREQ) = EFAUX(IFREQ) + WADATS(IGRID)%EF(GSEA,IFREQ)*WT - END IF - END IF - END DO - END IF -! - IF ( FLOGRD(3,2) .AND. ACTIVE ) THEN - DO IFREQ = E3DF(2,2),E3DF(3,2) - IF ( WADATS(IGRID)%TH1M(GSEA,IFREQ) .NE. UNDEF ) THEN - SUMWT3B(IFREQ) = SUMWT3B(IFREQ) + WT - IF ( TH1MAUX(IFREQ) .EQ. UNDEF ) THEN - TH1MAUX(IFREQ) = WADATS(IGRID)%TH1M(GSEA,IFREQ)*WT - ELSE - TH1MAUX(IFREQ) = TH1MAUX(IFREQ) + WADATS(IGRID)%TH1M(GSEA,IFREQ)*WT - END IF - END IF - END DO - END IF -! - IF ( FLOGRD(3,3) .AND. ACTIVE ) THEN - DO IFREQ = E3DF(2,3),E3DF(3,3) - IF ( WADATS(IGRID)%STH1M(GSEA,IFREQ) .NE. UNDEF ) THEN - SUMWT3C(IFREQ) = SUMWT3C(IFREQ) + WT - IF ( STH1MAUX(IFREQ) .EQ. UNDEF ) THEN - STH1MAUX(IFREQ) = WADATS(IGRID)%STH1M(GSEA,IFREQ)*WT - ELSE - STH1MAUX(IFREQ) = STH1MAUX(IFREQ) + WADATS(IGRID)%STH1M(GSEA,IFREQ)*WT - END IF - END IF - END DO - END IF -! - IF ( FLOGRD(3,4) .AND. ACTIVE ) THEN - DO IFREQ = E3DF(2,4),E3DF(3,4) - IF ( WADATS(IGRID)%TH2M(GSEA,IFREQ) .NE. UNDEF ) THEN - SUMWT3D(IFREQ) = SUMWT3D(IFREQ) + WT - IF ( TH2MAUX(IFREQ) .EQ. UNDEF ) THEN - TH2MAUX(IFREQ) = WADATS(IGRID)%TH2M(GSEA,IFREQ)*WT - ELSE - TH2MAUX(IFREQ) = TH2MAUX(IFREQ) + WADATS(IGRID)%TH2M(GSEA,IFREQ)*WT - END IF - END IF - END DO - END IF -! - IF ( FLOGRD(3,5) .AND. ACTIVE ) THEN - DO IFREQ = E3DF(2,5),E3DF(3,5) - IF ( WADATS(IGRID)%STH2M(GSEA,IFREQ) .NE. UNDEF ) THEN - SUMWT3E(IFREQ) = SUMWT3E(IFREQ) + WT - IF ( STH2MAUX(IFREQ) .EQ. UNDEF ) THEN - STH2MAUX(IFREQ) = WADATS(IGRID)%STH2M(GSEA,IFREQ)*WT - ELSE - STH2MAUX(IFREQ) = STH2MAUX(IFREQ) + WADATS(IGRID)%STH2M(GSEA,IFREQ)*WT - END IF - END IF - END DO - END IF + ELSE + OPEN (994,FILE=FNMPRE(:J)//TRIM(FNAMEWHT),form='UNFORMATTED', convert=file_endian,IOSTAT=IERR) -! - IF ( FLOGRD(3,6) .AND. ACTIVE ) THEN - DO IK = 1,NK - IF ( WADATS(IGRID)%WN(IK,GSEA) .NE. UNDEF ) THEN - SUMWT3F(IK) = SUMWT3F(IK) + WT - IF ( WNAUX(IK) .EQ. UNDEF ) THEN - WNAUX(IK) = WADATS(IGRID)%WN(IK,GSEA)*WT - ELSE - WNAUX(IK) = WNAUX(IK) + WADATS(IGRID)%WN(IK,GSEA)*WT - END IF - END IF - END DO - END IF -! -! Group 4 variables -! - DO ISWLL = 0, NOSWLL_MIN -! - IF ( FLOGRD(4,1) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PHS(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(1,ISWLL) = SUMWT4(1,ISWLL) + WT - IF ( PHSAUX(ISWLL) .EQ. UNDEF ) THEN - PHSAUX(ISWLL) = WADATS(IGRID)%PHS(GSEA,ISWLL)*WT - ELSE - PHSAUX(ISWLL) = PHSAUX(ISWLL) + & - WADATS(IGRID)%PHS(GSEA,ISWLL)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(4,2) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PTP(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(2,ISWLL) = SUMWT4(2,ISWLL) + WT - IF ( PTPAUX(ISWLL) .EQ. UNDEF ) THEN - PTPAUX(ISWLL) = WADATS(IGRID)%PTP(GSEA,ISWLL)*WT - ELSE - PTPAUX(ISWLL) = PTPAUX(ISWLL) + & - WADATS(IGRID)%PTP(GSEA,ISWLL)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(4,3) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PLP(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(3,ISWLL) = SUMWT4(3,ISWLL) + WT - IF ( PLPAUX(ISWLL) .EQ. UNDEF ) THEN - PLPAUX(ISWLL) = WADATS(IGRID)%PLP(GSEA,ISWLL)*WT - ELSE - PLPAUX(ISWLL) = PLPAUX(ISWLL) + & - WADATS(IGRID)%PLP(GSEA,ISWLL)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(4,4) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PDIR(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(4,ISWLL) = SUMWT4(4,ISWLL) + WT - IF ( PDIRAUX1(ISWLL) .EQ. UNDEF ) THEN - PDIRAUX1(ISWLL) = & - COS ( WADATS(IGRID)%PDIR(GSEA,ISWLL) )*WT - PDIRAUX2(ISWLL) = & - SIN ( WADATS(IGRID)%PDIR(GSEA,ISWLL) )*WT - ELSE - PDIRAUX1(ISWLL) = PDIRAUX1(ISWLL) + & - COS ( WADATS(IGRID)%PDIR(GSEA,ISWLL) )*WT - PDIRAUX2(ISWLL) = PDIRAUX2(ISWLL) + & - SIN ( WADATS(IGRID)%PDIR(GSEA,ISWLL) )*WT - END IF - END IF - END IF -! - IF ( FLOGRD(4,5) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PSI(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(5,ISWLL) = SUMWT4(5,ISWLL) + WT - IF ( PSIAUX(ISWLL) .EQ. UNDEF ) THEN - PSIAUX(ISWLL) = WADATS(IGRID)%PSI(GSEA,ISWLL)*WT - ELSE - PSIAUX(ISWLL) = PSIAUX(ISWLL) + & - WADATS(IGRID)%PSI(GSEA,ISWLL)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(4,6) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PWS(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(6,ISWLL) = SUMWT4(6,ISWLL) + WT - IF ( PWSAUX(ISWLL) .EQ. UNDEF ) THEN - PWSAUX(ISWLL) = WADATS(IGRID)%PWS(GSEA,ISWLL)*WT - ELSE - PWSAUX(ISWLL) = PWSAUX(ISWLL) + & - WADATS(IGRID)%PWS(GSEA,ISWLL)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(4,7) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PTHP0(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(7,ISWLL) = SUMWT4(7,ISWLL) + WT - IF (PTHP0AUX1(ISWLL).EQ.UNDEF) & - PTHP0AUX1(ISWLL) = 0. - IF (PTHP0AUX2(ISWLL).EQ.UNDEF) & - PTHP0AUX2(ISWLL) = 0. - PTHP0AUX1(ISWLL) = PTHP0AUX1(ISWLL) + & - COS ( WADATS(IGRID)%PTHP0(GSEA,ISWLL) )*WT - PTHP0AUX2(ISWLL) = PTHP0AUX2(ISWLL) + & - SIN ( WADATS(IGRID)%PTHP0(GSEA,ISWLL) )*WT - END IF - END IF -! - IF ( FLOGRD(4,8) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PQP(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(8,ISWLL) = SUMWT4(8,ISWLL) + WT - IF ( PQPAUX(ISWLL).EQ.UNDEF ) PQPAUX(ISWLL) = 0. - PQPAUX(ISWLL) = PQPAUX(ISWLL) + & - WADATS(IGRID)%PQP(GSEA,ISWLL)*WT - END IF - END IF -! - IF ( FLOGRD(4,9) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PPE(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(9,ISWLL) = SUMWT4(9,ISWLL) + WT - IF ( PPEAUX(ISWLL).EQ.UNDEF ) PPEAUX(ISWLL) = 0. - PPEAUX(ISWLL) = PPEAUX(ISWLL) + & - WADATS(IGRID)%PPE(GSEA,ISWLL)*WT - END IF - END IF -! - IF ( FLOGRD(4,10) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PGW(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(10,ISWLL) = SUMWT4(10,ISWLL) + WT - IF ( PGWAUX(ISWLL).EQ.UNDEF ) PGWAUX(ISWLL) = 0. - PGWAUX(ISWLL) = PGWAUX(ISWLL) + & - WADATS(IGRID)%PGW(GSEA,ISWLL)*WT - END IF - END IF -! - IF ( FLOGRD(4,11) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PSW(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(11,ISWLL) = SUMWT4(11,ISWLL) + WT - IF ( PSWAUX(ISWLL).EQ.UNDEF ) PSWAUX(ISWLL) = 0. - PSWAUX(ISWLL) = PSWAUX(ISWLL) + & - WADATS(IGRID)%PSW(GSEA,ISWLL)*WT - END IF - END IF -! - IF ( FLOGRD(4,12) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PTM1(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(12,ISWLL) = SUMWT4(12,ISWLL) + WT - IF ( PTM1AUX(ISWLL).EQ.UNDEF ) & - PTM1AUX(ISWLL) = 0. - PTM1AUX(ISWLL) = PTM1AUX(ISWLL) + & - WADATS(IGRID)%PTM1(GSEA,ISWLL)*WT - END IF - END IF -! - IF ( FLOGRD(4,13) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PT1(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(13,ISWLL) = SUMWT4(13,ISWLL) + WT - IF ( PT1AUX(ISWLL).EQ.UNDEF ) PT1AUX(ISWLL) = 0. - PT1AUX(ISWLL) = PT1AUX(ISWLL) + & - WADATS(IGRID)%PT1(GSEA,ISWLL)*WT - END IF - END IF -! - IF ( FLOGRD(4,14) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PT2(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(14,ISWLL) = SUMWT4(14,ISWLL) + WT - IF ( PT2AUX(ISWLL).EQ.UNDEF ) PT2AUX(ISWLL) = 0. - PT2AUX(ISWLL) = PT2AUX(ISWLL) + & - WADATS(IGRID)%PT2(GSEA,ISWLL)*WT - END IF - END IF -! - IF ( FLOGRD(4,15) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PEP(GSEA,ISWLL) .NE. UNDEF ) THEN - SUMWT4(15,ISWLL) = SUMWT4(15,ISWLL) + WT - IF ( PEPAUX(ISWLL).EQ.UNDEF ) PEPAUX(ISWLL) = 0. - PEPAUX(ISWLL) = PEPAUX(ISWLL) + & - WADATS(IGRID)%PEP(GSEA,ISWLL)*WT - END IF - END IF -! - END DO !/ ISWLL = 0, NOSWLL_MIN -! - IF ( FLOGRD(4,16) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PWST(GSEA) .NE. UNDEF ) THEN - SUMWT4(16,0) = SUMWT4(16,0) + WT - IF ( PWSTAUX .EQ. UNDEF ) THEN - PWSTAUX = WADATS(IGRID)%PWST(GSEA)*WT - ELSE - PWSTAUX = PWSTAUX + WADATS(IGRID)%PWST(GSEA)*WT - END IF - END IF - END IF -! -! Group 5 variables -! - IF ( FLOGRD(5,1) ) THEN - IF ( WDATAS(IGRID)%UST(GSEA) .NE. UNDEF ) THEN - SUMWT5(1) = SUMWT5(1) + WT - IF ( USTAUX1 .EQ. UNDEF ) THEN - USTAUX1 = WDATAS(IGRID)%UST(GSEA)*WT - USTAUX2 = WDATAS(IGRID)%USTDIR(GSEA)*WT - ELSE - USTAUX1 = USTAUX1 + WDATAS(IGRID)%UST(GSEA)*WT - USTAUX2 = USTAUX2 + WDATAS(IGRID)%USTDIR(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(5,2) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%CHARN(GSEA) .NE. UNDEF ) THEN - SUMWT5(2) = SUMWT5(2) + WT - IF ( CHARNAUX .EQ. UNDEF ) THEN - CHARNAUX = WADATS(IGRID)%CHARN(GSEA)*WT - ELSE - CHARNAUX = CHARNAUX + WADATS(IGRID)%CHARN(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(5,3) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%CGE(GSEA) .NE. UNDEF ) THEN - SUMWT5(3) = SUMWT5(3) + WT - IF ( CGEAUX .EQ. UNDEF ) THEN - CGEAUX = WADATS(IGRID)%CGE(GSEA)*WT - ELSE - CGEAUX = CGEAUX + WADATS(IGRID)%CGE(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(5,4) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PHIAW(GSEA) .NE. UNDEF ) THEN - SUMWT5(4) = SUMWT5(4) + WT - IF ( PHIAWAUX .EQ. UNDEF ) THEN - PHIAWAUX = WADATS(IGRID)%PHIAW(GSEA)*WT - ELSE - PHIAWAUX = PHIAWAUX + WADATS(IGRID)%PHIAW(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(5,5) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%TAUWIX(GSEA) .NE. UNDEF ) THEN - SUMWT5(5) = SUMWT5(5) + WT - IF ( TAUWIXAUX .EQ. UNDEF ) THEN - TAUWIXAUX = WADATS(IGRID)%TAUWIX(GSEA)*WT - TAUWIYAUX = WADATS(IGRID)%TAUWIY(GSEA)*WT - ELSE - TAUWIXAUX = TAUWIXAUX + WADATS(IGRID)%TAUWIX(GSEA)*WT - TAUWIYAUX = TAUWIYAUX + WADATS(IGRID)%TAUWIY(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(5,6) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%TAUWNX(GSEA) .NE. UNDEF ) THEN - SUMWT5(6) = SUMWT5(6) + WT - IF ( TAUWNXAUX .EQ. UNDEF ) THEN - TAUWNXAUX = WADATS(IGRID)%TAUWNX(GSEA)*WT - TAUWNYAUX = WADATS(IGRID)%TAUWNY(GSEA)*WT - ELSE - TAUWNXAUX = TAUWNXAUX + WADATS(IGRID)%TAUWNX(GSEA)*WT - TAUWNYAUX = TAUWNYAUX + WADATS(IGRID)%TAUWNY(GSEA)*WT - END IF - END IF - END IF -! - DO ICAP = 1,4 -! - IF ( FLOGRD(5,ICAP+6) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%WHITECAP(GSEA,ICAP) .NE. UNDEF ) THEN - SUMWTC(ICAP) = SUMWTC(ICAP) + WT - IF ( WHITECAPAUX(ICAP) .EQ. UNDEF ) THEN - WHITECAPAUX(ICAP) = WADATS(IGRID)%WHITECAP(GSEA,ICAP)& - *WT - ELSE - WHITECAPAUX(ICAP) = WHITECAPAUX(ICAP) + & - WADATS(IGRID)%WHITECAP(GSEA,ICAP)*WT - END IF - END IF - END IF -! - END DO -! -! Group 6 variables -! - IF ( FLOGRD(6,1) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%SXX(GSEA) .NE. UNDEF ) THEN - SUMWT6(1) = SUMWT6(1) + WT - IF ( SXXAUX .EQ. UNDEF ) THEN - SXXAUX = WADATS(IGRID)%SXX(GSEA)*WT - SXYAUX = WADATS(IGRID)%SXY(GSEA)*WT - SYYAUX = WADATS(IGRID)%SYY(GSEA)*WT - ELSE - SXXAUX = SXXAUX + WADATS(IGRID)%SXX(GSEA)*WT - SXYAUX = SXYAUX + WADATS(IGRID)%SXY(GSEA)*WT - SYYAUX = SYYAUX + WADATS(IGRID)%SYY(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(6,2) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%TAUOX(GSEA) .NE. UNDEF ) THEN - SUMWT6(2) = SUMWT6(2) + WT - IF ( TAUOXAUX .EQ. UNDEF ) THEN - TAUOXAUX = WADATS(IGRID)%TAUOX(GSEA)*WT - TAUOYAUX = WADATS(IGRID)%TAUOY(GSEA)*WT - ELSE - TAUOXAUX = TAUOXAUX + WADATS(IGRID)%TAUOX(GSEA)*WT - TAUOYAUX = TAUOYAUX + WADATS(IGRID)%TAUOY(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(6,3) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%BHD(GSEA) .NE. UNDEF ) THEN - SUMWT6(3) = SUMWT6(3) + WT - IF ( BHDAUX .EQ. UNDEF ) THEN - BHDAUX = WADATS(IGRID)%BHD(GSEA)*WT - ELSE - BHDAUX = BHDAUX + WADATS(IGRID)%BHD(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(6,4) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PHIOC(GSEA) .NE. UNDEF ) THEN - SUMWT6(4) = SUMWT6(4) + WT - IF ( PHIOCAUX .EQ. UNDEF ) THEN - PHIOCAUX = WADATS(IGRID)%PHIOC(GSEA)*WT - ELSE - PHIOCAUX = PHIOCAUX + WADATS(IGRID)%PHIOC(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(6,5) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%TUSX(GSEA) .NE. UNDEF ) THEN - SUMWT6(5) = SUMWT6(5) + WT - IF ( TUSXAUX .EQ. UNDEF ) THEN - TUSXAUX = WADATS(IGRID)%TUSX(GSEA)*WT - TUSYAUX = WADATS(IGRID)%TUSY(GSEA)*WT - ELSE - TUSXAUX = TUSXAUX + WADATS(IGRID)%TUSX(GSEA)*WT - TUSYAUX = TUSYAUX + WADATS(IGRID)%TUSY(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(6,6) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%USSX(GSEA) .NE. UNDEF ) THEN - SUMWT6(6) = SUMWT6(6) + WT - IF ( USSXAUX .EQ. UNDEF ) THEN - USSXAUX = WADATS(IGRID)%USSX(GSEA)*WT - USSYAUX = WADATS(IGRID)%USSY(GSEA)*WT - ELSE - USSXAUX = USSXAUX + WADATS(IGRID)%USSX(GSEA)*WT - USSYAUX = USSYAUX + WADATS(IGRID)%USSY(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(6,7) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PRMS(GSEA) .NE. UNDEF ) THEN - SUMWT6(7) = SUMWT6(7) + WT - IF ( PRMSAUX .EQ. UNDEF ) THEN - PRMSAUX = WADATS(IGRID)%PRMS(GSEA)*WT - TPMSAUX = WADATS(IGRID)%TPMS(GSEA)*WT - ELSE - PRMSAUX = PRMSAUX + WADATS(IGRID)%PRMS(GSEA)*WT - TPMSAUX = TPMSAUX + WADATS(IGRID)%TPMS(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(6,8) .AND. ACTIVE .AND. US3DF(1).GT.0 ) THEN - DO IK = US3DF(2),US3DF(3) - IF ( WADATS(IGRID)%US3D(GSEA,IK) .NE. UNDEF ) THEN - SUMWT68(IK) = SUMWT68(IK) + WT - IF ( US3DAUX(IK) .EQ. UNDEF ) US3DAUX(IK) = 0. - US3DAUX(IK) = US3DAUX(IK) + & - WADATS(IGRID)%US3D(GSEA,IK)*WT - END IF - IF ( WADATS(IGRID)%US3D(GSEA,NK+IK) .NE. UNDEF ) THEN - SUMWT68(NK+IK) = SUMWT68(NK+IK) + WT - IF ( US3DAUX(NK+IK) .EQ. UNDEF ) & - US3DAUX(NK+IK) = 0. - US3DAUX(NK+IK) = US3DAUX(NK+IK) + & - WADATS(IGRID)%US3D(GSEA,NK+IK)*WT - END IF - END DO - END IF -! - IF ( FLOGRD(6,9) .AND. ACTIVE .AND. P2MSF(1).GT.0) THEN - DO IK = P2MSF(2),P2MSF(3) - IF ( WADATS(IGRID)%P2SMS(GSEA,IK) .NE. UNDEF ) THEN - SUMWT69(IK) = SUMWT69(IK) + WT - IF ( P2SMSAUX(IK) .EQ. UNDEF ) P2SMSAUX(IK) = 0. - P2SMSAUX(IK) = P2SMSAUX(IK) + & - WADATS(IGRID)%P2SMS(GSEA,IK)*WT - END IF - END DO - END IF -! - IF ( FLOGRD(6,10) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%TAUICE(GSEA,1) .NE. UNDEF ) THEN - SUMWT6(10) = SUMWT6(10) + WT - IF ( TAUICEAUX(1) .EQ. UNDEF ) TAUICEAUX(1) = 0. - IF ( TAUICEAUX(2) .EQ. UNDEF ) TAUICEAUX(2) = 0. - TAUICEAUX(1) = TAUICEAUX(1) + & - WADATS(IGRID)%TAUICE(GSEA,1)*WT - TAUICEAUX(2) = TAUICEAUX(2) + & - WADATS(IGRID)%TAUICE(GSEA,2)*WT - END IF - END IF -! - IF ( FLOGRD(6,11) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PHICE(GSEA) .NE. UNDEF ) THEN - SUMWT6(11) = SUMWT6(11) + WT - IF ( PHICEAUX.EQ.UNDEF ) PHICEAUX = 0. - PHICEAUX = PHICEAUX + WADATS(IGRID)%PHICE(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(6,12) .AND. ACTIVE .AND. USSPF(1).GT.0 ) THEN - DO IK = 1,USSPF(2) - IF ( WADATS(IGRID)%USSP(GSEA,IK) .NE. UNDEF ) THEN - SUMWT612(IK) = SUMWT612(IK) + WT - IF ( USSPAUX(IK) .EQ. UNDEF ) USSPAUX(IK) = 0. - USSPAUX(IK) = USSPAUX(IK) + & - WADATS(IGRID)%USSP(GSEA,IK)*WT - END IF - IF ( WADATS(IGRID)%USSP(GSEA,NK+IK) .NE. UNDEF ) THEN - SUMWT612(NK+IK) = SUMWT612(NK+IK) + WT - IF ( USSPAUX(NK+IK) .EQ. UNDEF ) & - USSPAUX(NK+IK) = 0. - USSPAUX(NK+IK) = USSPAUX(NK+IK) + & - WADATS(IGRID)%USSP(GSEA,NK+IK)*WT - END IF - END DO - END IF -! - IF ( FLOGRD(6,13) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%TAUOCX(GSEA) .NE. UNDEF ) THEN - SUMWT6(13) = SUMWT6(13) + WT - IF ( TAUOCXAUX .EQ. UNDEF ) THEN - TAUOCXAUX = WADATS(IGRID)%TAUOCX(GSEA)*WT - TAUOCYAUX = WADATS(IGRID)%TAUOCY(GSEA)*WT - ELSE - TAUOCXAUX = TAUOCXAUX + WADATS(IGRID)%TAUOCX(GSEA)*WT - TAUOCYAUX = TAUOCYAUX + WADATS(IGRID)%TAUOCY(GSEA)*WT - END IF - END IF - END IF -! -! Group 7 variables -! - IF ( FLOGRD(7,1) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%ABA(GSEA) .NE. UNDEF ) THEN - SUMWT7(1) = SUMWT7(1) + WT - IF ( ABAAUX .EQ. UNDEF ) THEN - ABAAUX = WADATS(IGRID)%ABA(GSEA)*WT - ABDAUX = WADATS(IGRID)%ABD(GSEA)*WT - ELSE - ABAAUX = ABAAUX + WADATS(IGRID)%ABA(GSEA)*WT - ABDAUX = ABDAUX + WADATS(IGRID)%ABD(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(7,2) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%ABA(GSEA) .NE. UNDEF ) THEN - SUMWT7(2) = SUMWT7(2) + WT - IF ( UBAAUX .EQ. UNDEF ) THEN - UBAAUX = WADATS(IGRID)%UBA(GSEA)*WT - UBDAUX = WADATS(IGRID)%UBD(GSEA)*WT - ELSE - UBAAUX = UBAAUX + WADATS(IGRID)%UBA(GSEA)*WT - UBDAUX = UBDAUX + WADATS(IGRID)%UBD(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(7,3) .AND. ACTIVE ) THEN - DO IBED = 1, 3 - IF ( WADATS(IGRID)%BEDFORMS(GSEA,IBED) .NE. UNDEF ) THEN - SUMWTB(IBED) = SUMWTB(IBED) + WT - IF ( BEDFORMSAUX(IBED) .EQ. UNDEF ) THEN - BEDFORMSAUX(IBED) = WADATS(IGRID)%BEDFORMS(GSEA,IBED)& - *WT - ELSE - BEDFORMSAUX(IBED) = BEDFORMSAUX(IBED) + & - WADATS(IGRID)%BEDFORMS(GSEA,IBED)*WT - END IF - END IF - END DO - END IF -! - IF ( FLOGRD(7,4) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%PHIBBL(GSEA) .NE. UNDEF ) THEN - SUMWT7(4) = SUMWT7(4) + WT - IF ( PHIBBLAUX .EQ. UNDEF ) THEN - PHIBBLAUX = WADATS(IGRID)%PHIBBL(GSEA)*WT - ELSE - PHIBBLAUX = PHIBBLAUX + WADATS(IGRID)%PHIBBL(GSEA)*WT - END IF - END IF - END IF -! - IF ( FLOGRD(7,5) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%TAUBBL(GSEA,1) .NE. UNDEF ) THEN - SUMWT7(5) = SUMWT7(5) + WT - IF ( TAUBBLAUX(1) .EQ. UNDEF ) THEN - TAUBBLAUX(1) = WADATS(IGRID)%TAUBBL(GSEA,1)*WT - TAUBBLAUX(2) = WADATS(IGRID)%TAUBBL(GSEA,2)*WT - ELSE - TAUBBLAUX(1) = TAUBBLAUX(1) + & - WADATS(IGRID)%TAUBBL(GSEA,1)*WT - TAUBBLAUX(2) = TAUBBLAUX(2) + & - WADATS(IGRID)%TAUBBL(GSEA,2)*WT - END IF - END IF - END IF -! -! Group 8 variables -! - IF ( FLOGRD(8,1) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%MSSX(GSEA) .NE. UNDEF ) THEN - SUMWT8(1) = SUMWT8(1) + WT - IF ( MSSXAUX .EQ. UNDEF ) MSSXAUX = 0. - IF ( MSSYAUX .EQ. UNDEF ) MSSYAUX = 0. - MSSXAUX = MSSXAUX + WADATS(IGRID)%MSSX(GSEA)*WT - MSSYAUX = MSSYAUX + WADATS(IGRID)%MSSY(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(8,2) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%MSCX(GSEA) .NE. UNDEF ) THEN - SUMWT8(2) = SUMWT8(2) + WT - IF ( MSCXAUX .EQ. UNDEF ) MSCXAUX = 0. - IF ( MSCYAUX .EQ. UNDEF ) MSCYAUX = 0. - MSCXAUX = MSCXAUX + WADATS(IGRID)%MSCX(GSEA)*WT - MSCYAUX = MSCYAUX + WADATS(IGRID)%MSCY(GSEA)*WT - END IF - END IF -! - IF ( FLOGRD(8,3) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%MSSD(GSEA) .NE. UNDEF ) THEN - SUMWT8(3) = SUMWT8(3) + WT - IF ( MSSDAUX1 .EQ. UNDEF ) MSSDAUX1 = 0. - IF ( MSSDAUX2 .EQ. UNDEF ) MSSDAUX2 = 0. - MSSDAUX1 = MSSDAUX1 + & - COS ( WADATS(IGRID)%MSSD(GSEA) )*WT - MSSDAUX2 = MSSDAUX2 + & - SIN ( WADATS(IGRID)%MSSD(GSEA) )*WT - END IF - END IF -! - IF ( FLOGRD(8,4) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%MSCD(GSEA) .NE. UNDEF ) THEN - SUMWT8(4) = SUMWT8(4) + WT - IF ( MSCDAUX1 .EQ. UNDEF ) MSCDAUX1 = 0. - IF ( MSCDAUX2 .EQ. UNDEF ) MSCDAUX2 = 0. - MSCDAUX1 = MSCDAUX1 + & - COS ( WADATS(IGRID)%MSCD(GSEA) )*WT - MSCDAUX2 = MSCDAUX2 + & - SIN ( WADATS(IGRID)%MSCD(GSEA) )*WT - END IF - END IF -! - IF ( FLOGRD(8,5) .AND. ACTIVE ) THEN - IF ( WADATS(IGRID)%QP(GSEA) .NE. UNDEF ) THEN - SUMWT8(5) = SUMWT8(5) + WT - IF ( QPAUX .EQ. UNDEF ) QPAUX = 0. - QPAUX = QPAUX + WADATS(IGRID)%QP(GSEA)*WT - END IF - END IF -! -! End of loop through the points per grid to obtain interpolated values - END DO !/ IPTS = 1, ... -! -! Save temp. interpolated variables in proper variables -! (weighted by the number of grids) -! -! -! Group 1 variables -! - IF ( DWAUX .NE. UNDEF ) THEN - DWAUX = DWAUX / SUMWT1(1) - IF ( DW(ISEA) .EQ. UNDEF ) THEN - DW(ISEA) = DWAUX / REAL( SUMGRD ) + ! + ! 4.b Loop through the wet points + ! + DO ISEA = 1, NSEA + ! + ! IF (MOD(ISEA,NINT(REAL(NSEA)/100)).EQ.1) & + ! WRITE(6,*) 'Treating point ',ISEA,' out of ', NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + DAREA = ABS(GSQRT(IY,IX)) + ! + ALLOCATE ( GR_INTS(ISEA)%IND_WTS(NG-1),GR_INTS(ISEA)%GDID(NG-1) ) + ! + ! 4.b.i Loop through the input grids for each wet point + ! + COUNTG = 0 + DO IG = 1,NG-1 + ! + ! 4.b.ii Check if point is enclosed in grid domain + ! + INGRID=.FALSE. + IF (GRIDS(IG)%GTYPE .EQ. UNGTYPE) THEN + ! Look for a triangle at the coarse cell center + CALL IS_IN_UNGRID(IG, XGRD(IY,IX), YGRD(IY,IX), & + ITOUT, IS, JS, RW) + IF (ITOUT.GT.0) INGRID=.TRUE. + ! ! If extrapolation activated, force to find if a triangles is inside + ! ! the coarse grid cell even if there is no triangle in the cell center + IF (INTMETHOD.EQ.1) THEN + WRITE(991,'(2I6,2F9.4,I8,3I8,3F5.3)') IX,IY,XGRD(IY,IX), YGRD(IY,IX), ITOUT, IS(1:3), RW(1:3) + IF (ITOUT.EQ.0) WRITE(992,*) IX,IY,ISEA,XGRD(IY,IX), YGRD(IY,IX) + IF (ITOUT.EQ.0) THEN + CALL IS_IN_UNGRID2(IG, XGRD(IY,IX), YGRD(IY,IX), INTMETHOD, & + ITOUT, IS, JS, RW) + WRITE(993,'(2I6,2F9.4,I8,3I8,3F6.3)') IX,IY,XGRD(IY,IX), YGRD(IY,IX), ITOUT, IS(1:3), RW(1:3) + ENDIF + !IF (ITOUT.EQ.0) CALL IS_IN_UNGRID(IG, XGRD(IY,IX)+DX, YGRD(IY,IX), ITOUT, IS, JS, RW) + !IF (ITOUT.GT.0) INGRID=.TRUE. + !IF (ITOUT.EQ.0) CALL IS_IN_UNGRID(IG, XGRD(IY,IX)-DX, YGRD(IY,IX), ITOUT, IS, JS, RW) + !IF (ITOUT.GT.0) INGRID=.TRUE. + !IF (ITOUT.EQ.0) CALL IS_IN_UNGRID(IG, XGRD(IY,IX), YGRD(IY,IX)+DY, ITOUT, IS, JS, RW) + !IF (ITOUT.GT.0) INGRID=.TRUE. + !IF (ITOUT.EQ.0) CALL IS_IN_UNGRID(IG, XGRD(IY,IX), YGRD(IY,IX)-DY, ITOUT, IS, JS, RW) + !IF (ITOUT.GT.0) INGRID=.TRUE. + END IF + ELSE + IF ( W3GRMP ( GRIDS(IG)%GSU, REAL(XGRD(IY,IX)), REAL(YGRD(IY,IX)), IS, & + JS, RW ) ) INGRID=.TRUE. + END IF + IF (INGRID) THEN + ! + ! 4.b.iii Check source grid resolution vs target grid resolution + ! (averaging used for finer resolution source grids) + ! + IF (GRIDS(IG)%GTYPE .EQ. UNGTYPE) THEN + SAREA = GRIDS(IG)%TRIA(ITOUT) + ELSE + DO I = 1,4 + XCRNR(I) = GRIDS(IG)%XGRD(JS(I),IS(I)) + YCRNR(I) = GRIDS(IG)%YGRD(JS(I),IS(I)) + END DO + XCRNR(5) = XCRNR(1) + YCRNR(5) = YCRNR(1) + DO I = 1,4 + IF ( ABS (XCRNR(I+1)-XCRNR(I)) .GT. 180. .AND. & + GRIDS(IG)%ICLOSE .EQ. ICLOSE_SMPL ) THEN + DT(I) = SQRT ( (ABS(XCRNR(I+1)-XCRNR(I))-360.)**2 + & + (YCRNR(I+1)-YCRNR(I))**2 ) + ELSE + DT(I) = SQRT ( (XCRNR(I+1)-XCRNR(I))**2 + & + (YCRNR(I+1)-YCRNR(I))**2 ) + END IF + END DO + SXT = 0.5*(DT(1)+DT(3)) + SYT = 0.5*(DT(2)+DT(4)) + SAREA = (SXT*SYT) + END IF + NS = NINT(DAREA/SAREA) + ! + IF ( NS .LE. 2 .OR. GRIDS(IG)%GTYPE .EQ. UNGTYPE ) THEN + ! FA: Quick fix for UNST type grids: always perform interpolation + ! To be updated later ... + ! + ! 4.b.iv Counting the contributing nodes to re-normalize the weights RW + ! + ALLOCATE ( TMP_INDX(4) ) + COUNTF = 0 + SUMWT = 0.0 + DO I = 1,4 + ! The following two IF tests are separated because for triangles, JS(4)=IS(4)=0 + IF ( RW(I) .GT. 0.0 ) THEN + ! MAPSTA == 0 indicated excluded point (either land + ! or truly excluded) + IF ( GRIDS(IG)%MAPSTA(JS(I),IS(I)) .NE. 0) THEN + COUNTF = COUNTF+1 + TMP_INDX(COUNTF) = I + SUMWT = SUMWT + RW(I) + END IF + END IF + END DO + ! + ! 4.b.v Interpolating to target grid + ! + IF ( COUNTF .GT. 0 ) THEN + ! Should use SAREA info to prevent the increment of COUNTG ... + ! what about islands / land in triangle meshes? they are not part of the triangles... + COUNTG = COUNTG + 1 + IF (COUNTG.GT.1) THEN + IF (SAREA.LT.0.5*GR_INTS(ISEA)%IND_WTS(COUNTG-1)%AR) THEN + DO JG=1,COUNTG-1 + DEALLOCATE (GR_INTS(ISEA)%IND_WTS(JG)%IP) + DEALLOCATE (GR_INTS(ISEA)%IND_WTS(JG)%JP) + DEALLOCATE (GR_INTS(ISEA)%IND_WTS(JG)%WT) + END DO + COUNTG=1 + END IF + END IF + + GR_INTS(ISEA)%IND_WTS(COUNTG)%AR = SAREA + GR_INTS(ISEA)%GDID(COUNTG) = IG + INT_MAP(IX,IY) = REAL( IG ) + + ALLOCATE ( GR_INTS(ISEA)%IND_WTS(COUNTG)%IP(COUNTF), & + GR_INTS(ISEA)%IND_WTS(COUNTG)%JP(COUNTF), & + GR_INTS(ISEA)%IND_WTS(COUNTG)%WT(COUNTF) ) + DO I = 1,COUNTF + GR_INTS(ISEA)%IND_WTS(COUNTG)%IP(I) = IS(TMP_INDX(I)) + GR_INTS(ISEA)%IND_WTS(COUNTG)%JP(I) = JS(TMP_INDX(I)) + GR_INTS(ISEA)%IND_WTS(COUNTG)%WT(I) = RW(TMP_INDX(I))/SUMWT + END DO + GR_INTS(ISEA)%IND_WTS(COUNTG)%NP = COUNTF + END IF + DEALLOCATE ( TMP_INDX ) + ! + ELSE + ! + ! 4.b.vi Find the averaging points for higher resolution grid + ! Step 1 : Compute the corners of the cell + ! + X0 = XGRD(IY,IX) + Y0 = YGRD(IY,IX) + IF ( IX .GT. 1 .AND. IX .LT. NX .AND. IY .GT. 1 & + .AND. IY .LT. NY ) THEN + XT = XGRD(IY-1,IX+1) + YT = YGRD(IY-1,IX+1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(1) = 0.5*(XT+X0) + YCRNR(1) = 0.5*(YT+Y0) + XT = XGRD(IY+1,IX+1) + YT = YGRD(IY+1,IX+1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(2) = 0.5*(XT+X0) + YCRNR(2) = 0.5*(YT+Y0) + XT = XGRD(IY+1,IX-1) + YT = YGRD(IY+1,IX-1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(3) = 0.5*(XT+X0) + YCRNR(3) = 0.5*(YT+Y0) + XT = XGRD(IY-1,IX-1) + YT = YGRD(IY-1,IX-1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(4) = 0.5*(XT+X0) + YCRNR(4) = 0.5*(YT+Y0) + ELSEIF ( IX .EQ. 1 ) THEN + IF ( IY .EQ. 1 ) THEN + XT = XGRD(IY+1,IX+1) + YT = YGRD(IY+1,IX+1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(2) = 0.5*(XT+X0) + YCRNR(2) = 0.5*(YT+Y0) + XCRNR(4) = 2*X0 - XCRNR(2) + YCRNR(4) = 2*Y0 - YCRNR(2) + XCRNR(3) = X0 - (YCRNR(2)-Y0) + YCRNR(3) = Y0 + (XCRNR(2)-X0) + XCRNR(1) = 2*X0 - XCRNR(3) + YCRNR(1) = 2*Y0 - YCRNR(3) + ELSEIF ( IY .EQ. NY ) THEN + XT = XGRD(IY-1,IX+1) + YT = YGRD(IY-1,IX+1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(1) = 0.5*(XT+X0) + YCRNR(1) = 0.5*(YT+Y0) + XCRNR(3) = 2*X0 - XCRNR(1) + YCRNR(3) = 2*Y0 - YCRNR(1) + XCRNR(2) = X0 - (Y0-YCRNR(1)) + YCRNR(2) = Y0 + (X0-XCRNR(1)) + XCRNR(4) = 2*X0 - XCRNR(2) + YCRNR(4) = 2*Y0 - YCRNR(2) + ELSE + XT = XGRD(IY-1,IX+1) + YT = YGRD(IY-1,IX+1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(1) = 0.5*(XT+X0) + YCRNR(1) = 0.5*(YT+Y0) + XT = XGRD(IY+1,IX+1) + YT = YGRD(IY+1,IX+1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(2) = 0.5*(XT+X0) + YCRNR(2) = 0.5*(YT+Y0) + XCRNR(3) = 2*X0 - XCRNR(1) + YCRNR(3) = 2*Y0 - YCRNR(1) + XCRNR(4) = 2*X0 - XCRNR(2) + YCRNR(4) = 2*Y0 - YCRNR(2) + ENDIF + ELSEIF ( IX .EQ. NX ) THEN + IF ( IY .EQ. 1 ) THEN + XT = XGRD(IY+1,IX-1) + YT = YGRD(IY+1,IX-1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(3) = 0.5*(XT+X0) + YCRNR(3) = 0.5*(YT+Y0) + XCRNR(2) = X0 - (YCRNR(3)-Y0) + YCRNR(2) = Y0 + (XCRNR(3)-X0) + XCRNR(1) = 2*X0 - XCRNR(3) + YCRNR(1) = 2*Y0 - YCRNR(3) + XCRNR(4) = 2*X0 - XCRNR(2) + YCRNR(4) = 2*Y0 - YCRNR(2) + ELSEIF ( IY .EQ. NY ) THEN + XT = XGRD(IY-1,IX-1) + YT = YGRD(IY-1,IX-1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(4) = 0.5*(XT+X0) + YCRNR(4) = 0.5*(YT+Y0) + XCRNR(3) = X0 - (YCRNR(4)-Y0) + YCRNR(3) = Y0 + (XCRNR(4)-X0) + XCRNR(1) = 2*X0 - XCRNR(3) + YCRNR(1) = 2*Y0 - YCRNR(3) + XCRNR(2) = 2*X0 - XCRNR(4) + YCRNR(2) = 2*Y0 - YCRNR(4) + ELSE + XT = XGRD(IY+1,IX-1) + YT = YGRD(IY+1,IX-1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(3) = 0.5*(XT+X0) + YCRNR(3) = 0.5*(YT+Y0) + XT = XGRD(IY-1,IX-1) + YT = YGRD(IY-1,IX-1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(4) = 0.5*(XT+X0) + YCRNR(4) = 0.5*(YT+Y0) + XCRNR(1) = 2*X0 - XCRNR(3) + YCRNR(1) = 2*Y0 - YCRNR(3) + XCRNR(2) = 2*X0 - XCRNR(4) + YCRNR(2) = 2*Y0 - YCRNR(4) + ENDIF + ELSE + IF ( IY .EQ. 1 ) THEN + XT = XGRD(IY+1,IX+1) + YT = YGRD(IY+1,IX+1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(2) = 0.5*(XT+X0) + YCRNR(2) = 0.5*(YT+Y0) + XT = XGRD(IY+1,IX-1) + YT = YGRD(IY+1,IX-1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(3) = 0.5*(XT+X0) + YCRNR(3) = 0.5*(YT+Y0) + XCRNR(4) = 2*X0 - XCRNR(2) + YCRNR(4) = 2*Y0 - YCRNR(2) + XCRNR(1) = 2*X0 - XCRNR(3) + YCRNR(1) = 2*Y0 - YCRNR(3) + ELSE + XT = XGRD(IY-1,IX-1) + YT = YGRD(IY-1,IX-1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(4) = 0.5*(XT+X0) + YCRNR(4) = 0.5*(YT+Y0) + XT = XGRD(IY-1,IX+1) + YT = YGRD(IY-1,IX+1) + IF ( ABS(XT-X0) .GT. 270 ) THEN + XT = XT - SIGN(360.,XT-X0) + END IF + XCRNR(1) = 0.5*(XT+X0) + YCRNR(1) = 0.5*(YT+Y0) + XCRNR(2) = 2*X0 - XCRNR(4) + YCRNR(2) = 2*Y0 - YCRNR(4) + XCRNR(3) = 2*X0 - XCRNR(1) + YCRNR(3) = 2*Y0 - YCRNR(1) + END IF + END IF + BRNCHCL = .FALSE. + BRNCHCR = .FALSE. + IF ( FLAGLL .AND. ICLOSE .EQ. ICLOSE_SMPL ) THEN + IF ( L360 ) THEN + IF ( MINVAL ( XCRNR(1:4) ) .LT. 0.0 ) BRNCHCL = .TRUE. + IF ( MAXVAL ( XCRNR(1:4) ) .GT. 360.0 ) BRNCHCR = .TRUE. + ELSE + IF ( MINVAL ( XCRNR(1:4) ) .LT. -180.0 ) BRNCHCL = .TRUE. + IF ( MAXVAL ( XCRNR(1:4) ) .GT. 180.0 ) BRNCHCR = .TRUE. + END IF + END IF + ! + ! Step 2 : Loop through source grid to find all active points in cell + ! + !FA : why only *5 ???... + ! + ALLOCATE ( TMP_INDX(NS*5) ) + COUNTF = 0 + DO I = 1, GRIDS(IG)%NSEA + IXT = GRIDS(IG)%MAPSF(I,1) + IYT = GRIDS(IG)%MAPSF(I,2) + XT = GRIDS(IG)%XGRD(IYT,IXT) + YT = GRIDS(IG)%YGRD(IYT,IXT) + ! + IF ( FLAGLL ) THEN + IF ( L360 ) THEN + IF ( XT .LT. 0 ) XT = XT + 360. + ELSE + IF ( XT .GT. 180. ) XT = XT - 360. + END IF + END IF + INGRD = W3CKCL (FLAGLL,XT,YT,4,XCRNR,YCRNR,LPLC) + IF ( INGRD ) THEN + COUNTF = COUNTF+1 + TMP_INDX(COUNTF) = I + ELSEIF ( BRNCHCL .AND. GRIDS(IG)%ICLOSE & + .EQ. ICLOSE_SMPL ) THEN + XTT = XT - 360.0 + INGRD = W3CKCL (FLAGLL,XTT,YT,4,XCRNR,YCRNR,LPLC) + IF ( INGRD ) THEN + COUNTF = COUNTF+1 + TMP_INDX(COUNTF) = I + END IF + ELSEIF ( BRNCHCR .AND. GRIDS(IG)%ICLOSE & + .EQ. ICLOSE_SMPL ) THEN + XTT = XT + 360.0 + INGRD = W3CKCL (FLAGLL,XTT,YT,4,XCRNR,YCRNR,LPLC) + IF ( INGRD ) THEN + COUNTF = COUNTF+1 + TMP_INDX(COUNTF) = I + END IF + END IF + END DO + ! + ! Step 3 : Save interior points for equal wt. interpolation (averaging) + ! + IF ( COUNTF .NE. 0 ) THEN + COUNTG = COUNTG + 1 + GR_INTS(ISEA)%GDID(COUNTG) = IG + INT_MAP(IX,IY) = REAL( IG ) + ALLOCATE ( GR_INTS(ISEA)%IND_WTS(COUNTG)%IP(COUNTF), & + GR_INTS(ISEA)%IND_WTS(COUNTG)%JP(COUNTF), & + GR_INTS(ISEA)%IND_WTS(COUNTG)%WT(COUNTF) ) + DO I = 1,COUNTF + IXT = GRIDS(IG)%MAPSF(TMP_INDX(I),1) + IYT = GRIDS(IG)%MAPSF(TMP_INDX(I),2) + GR_INTS(ISEA)%IND_WTS(COUNTG)%IP(I) = IXT + GR_INTS(ISEA)%IND_WTS(COUNTG)%JP(I) = IYT + GR_INTS(ISEA)%IND_WTS(COUNTG)%WT(I) = 1./( REAL(COUNTF) ) + END DO + GR_INTS(ISEA)%IND_WTS(COUNTG)%NP = COUNTF + END IF + DEALLOCATE ( TMP_INDX ) + ! + END IF ! End of check for grid resolution + ! + END IF ! End of check for point inside grid + ! + END DO ! End of loop through all input grids + ! + GR_INTS(ISEA)%NGRDS = COUNTG + ! + ! 4.b.vii Check to see if interpolation weights found. + ! Status of output points with / without weights set in MAPST2 + ! using the next available bit + ! + IF ( GR_INTS(ISEA)%NGRDS .EQ. 0 ) THEN +#ifdef W3_T + WRITE (NDSO,909)IX, IY +#endif + MAPINT = 1 + MAPST2(IY,IX) = MAPST2(IY,IX) + MAPINT*16 + MAPSTA(IY,IX) = -ABS ( MAPSTA(IY,IX) ) + END IF + ! + END DO ! End of loop through all wet points + ! + ! Now dumps the coefficients to file ... + WRITE(994) NSEA + DO ISEA = 1, NSEA + COUNTG = GR_INTS(ISEA)%NGRDS + WRITE(994) COUNTG + DO IG = 1,COUNTG + WRITE(994) GR_INTS(ISEA)%IND_WTS(IG)%AR + WRITE(994) GR_INTS(ISEA)%GDID(IG) + COUNTF = GR_INTS(ISEA)%IND_WTS(IG)%NP + WRITE(994) COUNTF + DO I = 1,COUNTF + WRITE(994) GR_INTS(ISEA)%IND_WTS(IG)%IP(I) + WRITE(994) GR_INTS(ISEA)%IND_WTS(IG)%JP(I) + WRITE(994) GR_INTS(ISEA)%IND_WTS(IG)%WT(I) + END DO + WRITE(994) GR_INTS(ISEA)%IND_WTS(IG)%NP + END DO ! IG + WRITE(994) GR_INTS(ISEA)%NGRDS + END DO ! ISEA + END IF ! NSEA.EQ.NSEA_FILE + CLOSE(994) + ! + ! 4.c Print Interpolation grids map + ! + IX = 1+NX/24 + IY = 1+NY/24 + CALL PRTBLK ( NDSO, NX, NY, NX, INT_MAP, MAP, -1, 1., 1, NX, IX, 1, & + NY, IY, 'Grid Interpolation Map', ' ' ) + ! + !--------------------------------------------------------------------------- + ! 5 Output interpolations + ! + ! 5.a Set-up dimensions for target grid outputs and allocate file pointers + ! + CALL W3SETA(NG, 6, 6) + CALL W3DIMA(NG, 6, 6, .TRUE. ) + CALL W3DIMW(NG, 6, 6, .TRUE. ) + ALLOCATE(FIDOUT(NG)) + DO IG = 1,NG + FIDOUT(IG) = 30 + (IG-1)*10 + END DO + ! + ! 5.b Initialize and read the first set of fields for base grids + ! + DO IG = 1,NG-1 + CALL W3SETO( IG, 6, 6) + CALL W3IOGO('READ',FIDOUT(IG),IOTST,IG) + IF ( IOTST .NE. 0 ) THEN + GO TO 2111 + ENDIF + END DO + ! + ! 5.c Setup the output flag options for the target grid + ! + WRITE (NDSO,910) + DO I = 1, NOGRP + OUTPTS(NG)%OUT1%FLOGRD(I,:) = OUTPTS(1)%OUT1%FLOGRD(I,:) + WRITE (NDSO,911) I + IF (I.LT.9) THEN + WRITE (NDSO, 912) (OUTPTS(NG)%OUT1%FLOGRD(I,J),J=1,NGRPP) + ELSE + WRITE (NDSO, 913) + END IF + END DO + WRITE (NDSO, 915) + ! + ! Print output flags in human readable from. Mark + ! groups that do not make sense to interpolate to + ! target grid (e.g. Groups 9, 10). + ! + DO I=1, NOGRP + DO J=1, NGRPP + IF ( OUTPTS(NG)%OUT1%FLOGRD(I,J) ) THEN + IF ( I .EQ. 4 .AND. J .EQ. 8 ) THEN + WRITE (NDSO, 916) I,IDOUT(I,J), '*** NOT IMPLEMENTED ***' + OUTPTS(NG)%OUT1%FLOGRD(I,J) = .FALSE. + ELSE IF ( I .LE. 8 ) THEN + WRITE (NDSO, 916) I,IDOUT(I,J), ' ' + ELSE + WRITE (NDSO, 916) I,IDOUT(I,J), '*** NOT IMPLEMENTED ***' + OUTPTS(NG)%OUT1%FLOGRD(I,J) = .FALSE. + END IF + END IF + END DO + END DO + WRITE (NDSO, 915) + ! + ! 5.d Carry out interpolation in an infinite loop till appropriate + ! time steps are interpolated + ! + IOUT = 0 + ! + DO + DTEST = DSEC21 ( WDATAS(1)%TIME, TOUT ) + IF ( DTEST .GT. 0. ) THEN + DO IG = 1,NG-1 + CALL W3IOGO('READ',FIDOUT(IG),IOTST,IG) + IF ( IOTST .NE. 0 ) THEN + GO TO 2111 + ENDIF + END DO + CYCLE + ENDIF + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF + ! + IOUT = IOUT + 1 + CALL STME21 ( TOUT, IDTIME) + WRITE (NDSO,914) IDTIME + ! + WDATAS(NG)%TIME = WDATAS(1)%TIME + CALL W3SETO(NG, 6, 6) + CALL W3SETG(NG, 6, 6) + CALL W3SETA(NG, 6, 6) + CALL W3SETW(NG, 6, 6) + ! + CALL W3EXGI ( NG-1, NSEA, NOSWLL_MIN, INTMETHOD ) + ! + CALL TICK21 ( TOUT , DTREQ ) + IF ( IOUT .GE. NOUT ) EXIT + END DO + GOTO 2222 + ! + !--------------------------------------------------------------------------- + ! Escape locations read errors : + ! +2000 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 1 ) + ! +2001 CONTINUE + WRITE(NDSE,1001) + CALL EXTCDE ( 2 ) + ! +2002 CONTINUE + WRITE(NDSE,1002) IERR + CALL EXTCDE ( 3 ) + ! +2111 CONTINUE + WRITE(NDSO,950) +2222 CONTINUE + WRITE(NDSO,999) + ! + !--------------------------------------------------------------------------- + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Grid interpolation *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) +902 FORMAT ( ' Time Information : '/ & + '---------------------------------------------'/ & + ' Starting Time : ',A/ & + ' Interval (in sec) : ',F10.2/ & + ' Number of requests : ',I4/ & + '---------------------------------------------') +903 FORMAT ( ' Number of grids (including output grid) =',I3/) +904 FORMAT ( /' Extension for grid ',I3,' is --> ',A10/) +905 FORMAT ( ' Grid Particulars are : '/ & + ' Dimensions = ',2(I9,2X)/ & + ' Grid Type = ',I3,' ==> 1 Rect, 2 Curv, 3 Unstr'/ & + ' Grid Closure = ',I3,' ==> -1 None, 2 Simple, 8 Tripolar') +907 FORMAT ( /' NOTE : The no. of swell partitions from input and', & + ' target grids do not match',/ & + ' The Min. no. of partitions from input grids =',I5/ & + ' The no. of partitions for target grid =',I5/ & + ' Interpolation will be limited to the smaller', & + ' number of the partitions,',/ & + ' rest will be marked undefined.' ) +908 FORMAT (/' Preparing interpolation weights for output grid ' / & + ' Total number of wet points for interpolation ',I7/) +909 FORMAT (/' *** WARNING !! No interpolation points at ',2(I5)/) +910 FORMAT (/' Interpolating fields .... '/) +911 FORMAT (' Output group ', I5) +912 FORMAT (' Output variable flags are -> ',7(5L2,1X)) +913 FORMAT (' Output variables skipped') +914 FORMAT ( ' OUTPUT TIME : ',A) +915 FORMAT ( ' ------------------------------------------------') +916 FORMAT ( I5,A,2X,A) +917 FORMAT (/' Interpolation scheme = ',I1,' ==> 0 linear, ', & + '1 extrapolate unstructured, 2 nearest'/) +950 FORMAT (/' End of file reached'/) +999 FORMAT (/15X,' *** End of Grid interpolation Routine *** '/ & + 15X,'==============================================='/) + ! +1000 FORMAT (/' *** ERROR IN WAVEGRID_INTERP : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) +1001 FORMAT (/' *** ERROR IN WAVEGRID_INTERP : '/ & + ' PREMATURE END IN INPUT FILE'/) +1002 FORMAT (/' *** ERROR IN WAVEGRID_INTERP : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! + !/ + !/ Internal Subroutine + !/ + !/ Internal Subroutine W3EXGI ----------------------------------------------/ + !/ +CONTAINS + !/ -----------------------------------------------------------------------/ + !> @brief Perform actual output of interpolated data. + !> + !> @param[in] NGRD + !> @param[in] NSEA + !> @param[in] NOSWLL_MIN + !> @param[in] INTMETHOD + !> @author A. Chawla @date 22-Mar-2021 + ! + SUBROUTINE W3EXGI ( NGRD, NSEA, NOSWLL_MIN, INTMETHOD ) + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | A. Chawla | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 09-Jul-2009 : Original code ( version 3.14 ) + !/ 21-Feb-2013 : Modified to new output structure ( version 4.11 ) + !/ 30-Apr-2014 : Add group 3 ( version 5.00 ) + !/ 27-Aug-2015 : ice thick. and floe added as output ( version 5.10 ) + !/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Perform actual output of interpolated data. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Subroutine it resides in + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ -------------------------------------------------------------------------/ + USE W3ADATMD + USE W3WDATMD + USE W3ODATMD, ONLY: NOGE + USE W3IOGOMD, ONLY: W3IOGO + USE W3GDATMD, ONLY: E3DF, NK + !/ -------------------------------------------------------------------------/ + !/ Parameter List + !/ + INTEGER, INTENT(IN) :: NGRD, NSEA, NOSWLL_MIN, INTMETHOD + !/ + !/ Local Parameters + !/ + INTEGER :: ISEA, GSEA, IG, IGRID, IPTS, IGX, IGY, IX, & + IY, ISWLL, ICAP, IBED, IFREQ, IK, INRST + INTEGER :: MAPINT, MAPICE, MAPDRY, MAPMSK, MAPLND, & + NMAPICE, NMAPDRY, NMAPMSK, NMAPLND, & + LMAPICE, LMAPDRY, LMAPMSK, LMAPLND, & + MAPICET, MAPDRYT, MAPMSKT, MAPLNDT + INTEGER :: SUMGRD + REAL :: VAR1, VAR2, WT + ! Local group 1 variables + REAL :: DWAUX, CXAUX, CYAUX, UAAUX, UDAUX, ASAUX, & + WLVAUX, ICEAUX, ICEHAUX, ICEFAUX, BERGAUX, & + SED_D50AUX, RHOAIRAUX, TAUAAUX, TAUADIRAUX, & + SUMWT1(NOGE(1)) + ! Local group 2 variables + REAL :: HSAUX, WLMAUX, T02AUX, T0M1AUX, T01AUX, & + FP0AUX, THMAUX1, THMAUX2, THSAUX, THP0AUX1, & + THP0AUX2, HSIGAUX, STMAXEAUX,STMAXDAUX, & + HMAXEAUX, HCMAXEAUX, HMAXDAUX, HCMAXDAUX, & + WBTAUX, WNMEANAUX, SUMWT2(NOGE(2)) + ! Local group 3 variables + REAL :: EFAUX(E3DF(2,1):E3DF(3,1)), & + TH1MAUX(E3DF(2,2):E3DF(3,2)), & + STH1MAUX(E3DF(2,3):E3DF(3,3)), & + TH2MAUX(E3DF(2,4):E3DF(3,4)), & + STH2MAUX(E3DF(2,5):E3DF(3,5)), WNAUX(1:NK), & + SUMWT3A(E3DF(2,1):E3DF(3,1)), & + SUMWT3B(E3DF(2,2):E3DF(3,2)), & + SUMWT3C(E3DF(2,3):E3DF(3,3)), & + SUMWT3D(E3DF(2,4):E3DF(3,4)), & + SUMWT3E(E3DF(2,5):E3DF(3,5)), & + SUMWT3F(1:NK) + ! Local group 4 variables + REAL :: PHSAUX(0:NOSWLL_MIN), PTPAUX(0:NOSWLL_MIN), & + PLPAUX(0:NOSWLL_MIN), PSIAUX(0:NOSWLL_MIN), & + PWSAUX(0:NOSWLL_MIN), PDIRAUX1(0:NOSWLL_MIN), & + PWSTAUX, PDIRAUX2(0:NOSWLL_MIN), & + PTHP0AUX1(0:NOSWLL_MIN), & + PTHP0AUX2(0:NOSWLL_MIN), & + PQPAUX(0:NOSWLL_MIN), PPEAUX(0:NOSWLL_MIN), & + PGWAUX(0:NOSWLL_MIN), PSWAUX(0:NOSWLL_MIN), & + PTM1AUX(0:NOSWLL_MIN), PT1AUX(0:NOSWLL_MIN), & + PT2AUX(0:NOSWLL_MIN), PEPAUX(0:NOSWLL_MIN), & + SUMWT4(NOGE(4),0:NOSWLL_MIN) + ! Local group 5 variables + REAL :: USTAUX1, USTAUX2, CHARNAUX, CGEAUX, & + PHIAWAUX, TAUWIXAUX, TAUWIYAUX, TAUWNXAUX, & + TAUWNYAUX, WHITECAPAUX(4), SUMWT5(NOGE(5)), & + SUMWTC(4) + ! Local group 6 variables + REAL :: SXXAUX, SYYAUX, SXYAUX, TAUOXAUX, TAUOYAUX, & + BHDAUX, PHIOCAUX, TUSXAUX, TUSYAUX, USSXAUX, & + USSYAUX, PRMSAUX, TPMSAUX, SUMWT6(NOGE(6)), & + TAUICEAUX(2), PHICEAUX, & + TAUOCXAUX, TAUOCYAUX, & + US3DAUX(2*NK), SUMWT68(2*NK), & + P2SMSAUX(P2MSF(2):P2MSF(3)), & + SUMWT69(P2MSF(2):P2MSF(3)), & + USSPAUX(2*NK), SUMWT612(2*NK) + ! Local Group 7 variables + REAL :: ABAAUX, ABDAUX, UBAAUX, UBDAUX, PHIBBLAUX, & + BEDFORMSAUX(3), TAUBBLAUX(2), & + SUMWT7(NOGE(7)), SUMWTB(3) + ! Local group 8 variables + REAL :: MSSXAUX, MSSYAUX, MSCXAUX, MSCYAUX, MSSDAUX1, & + MSSDAUX2, MSCDAUX1, MSCDAUX2, QPAUX, & + SUMWT8(NOGE(8)) + !/ + LOGICAL :: ACTIVE + LOGICAL :: USEGRID(NGRD) + !/ + ! + !------------------------------------------------------------------- + ! 1. Preparations + ! + ! Group 1 Variables + ! + DW = UNDEF + CX = UNDEF + CY = UNDEF + UA = UNDEF + UD = UNDEF + AS = UNDEF + WLV = UNDEF + ICE = UNDEF + BERG = UNDEF + RHOAIR = UNDEF + TAUA = UNDEF + TAUADIR = UNDEF +#ifdef W3_BT4 + SED_D50 = UNDEF +#endif +#ifdef W3_IS2 + ICEH = UNDEF + ICEF = UNDEF +#endif + ! + ! Group 2 variables + ! + HS = UNDEF + WLM = UNDEF + T02 = UNDEF + T0M1 = UNDEF + T01 = UNDEF + FP0 = UNDEF + THM = UNDEF + THS = UNDEF + THP0 = UNDEF + HSIG = UNDEF + STMAXE = UNDEF + STMAXD = UNDEF + HMAXE = UNDEF + HCMAXE = UNDEF + HMAXD = UNDEF + HCMAXD = UNDEF + WBT = UNDEF + WNMEAN = UNDEF + ! + ! Group 3 variables + ! + IF ( E3DF(1,1).GT.0 ) EF = UNDEF + IF ( E3DF(1,2).GT.0 ) TH1M = UNDEF + IF ( E3DF(1,3).GT.0 ) STH1M = UNDEF + IF ( E3DF(1,4).GT.0 ) TH2M = UNDEF + IF ( E3DF(1,5).GT.0 ) STH2M = UNDEF + WN = UNDEF + ! + ! Group 4 variables + ! + PHS = UNDEF + PTP = UNDEF + PLP = UNDEF + PDIR = UNDEF + PSI = UNDEF + PWS = UNDEF + PWST = UNDEF + PNR = UNDEF + PTHP0 = UNDEF + PQP = UNDEF + PPE = UNDEF + PGW = UNDEF + PSW = UNDEF + PTM1 = UNDEF + PT1 = UNDEF + PT2 = UNDEF + PEP = UNDEF + ! + ! Group 5 variables + ! + UST = UNDEF + USTDIR = UNDEF + CHARN = UNDEF + CGE = UNDEF + PHIAW = UNDEF + TAUWIX = UNDEF + TAUWIY = UNDEF + TAUWNX = UNDEF + TAUWNY = UNDEF + WHITECAP = UNDEF + ! + ! Group 6 variables + ! + SXX = UNDEF + SXY = UNDEF + SYY = UNDEF + TAUOX = UNDEF + TAUOY = UNDEF + BHD = UNDEF + PHIOC = UNDEF + TUSX = UNDEF + TUSY = UNDEF + USSX = UNDEF + USSY = UNDEF + TAUOCX = UNDEF + TAUOCY = UNDEF + PRMS = UNDEF + TPMS = UNDEF + IF ( US3DF(1).GT.0 ) THEN + US3D = UNDEF + ENDIF + IF ( P2MSF(1).GT.0) THEN + P2SMS = UNDEF + ENDIF + TAUICE = UNDEF + PHICE = UNDEF + IF ( USSPF(1).GT.0 ) THEN + USSP = UNDEF + ENDIF + ! + ! Group 7 variables + ! + ABA = UNDEF + ABD = UNDEF + UBA = UNDEF + UBD = UNDEF + BEDFORMS = UNDEF + PHIBBL = UNDEF + TAUBBL = UNDEF + ! + ! Group 8 variables + ! + MSSX = UNDEF + MSSY = UNDEF + MSCX = UNDEF + MSCY = UNDEF + MSSD = UNDEF + MSCD = UNDEF + QP = UNDEF + ! + !------------------------------------------------------------------- + ! 2. Loop through output points + ! + DO ISEA = 1, NSEA + ! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + MAPICE = MOD(MAPST2(IY,IX),2) + MAPDRY = MOD(MAPST2(IY,IX)/2,2) + MAPLND = MOD(MAPST2(IY,IX)/4,2) + MAPMSK = MOD(MAPST2(IY,IX)/8,2) + MAPINT = MOD(MAPST2(IY,IX)/16,2) + MAPST2(IY,IX) = MAPST2(IY,IX) - MAPICE - 2*MAPDRY - 4*MAPLND & + - 8*MAPMSK + ACTIVE = (MAPICE .NE. 1 .AND. MAPDRY .NE. 1) + ! + IF ( MAPINT .EQ. 0 ) THEN + ! + ! Initial loop to determine status map + ! Initialize by setting it to be ice free and wet + ! + MAPICE = 0 + MAPDRY = 0 + MAPMSK = 0 + MAPLND = 0 + ACTIVE = .TRUE. + MAPSTA(IY,IX) = ABS ( MAPSTA(IY,IX) ) + SUMGRD = 0 + DO IG = 1,GR_INTS(ISEA)%NGRDS + IGRID = GR_INTS(ISEA)%GDID(IG) + NMAPICE = 0 + NMAPDRY = 0 + NMAPLND = 0 + NMAPMSK = 0 + MAPICET = 0 + MAPDRYT = 0 + MAPLNDT = 0 + MAPMSKT = 0 + IF ( INTMETHOD == 2 ) THEN + ! Nearest neighbour is the one with the most weight + INRST = MAXLOC(GR_INTS(ISEA)%IND_WTS(IG)%WT, DIM=1) + GR_INTS(ISEA)%IND_WTS(IG)%WT(:) = -1. + GR_INTS(ISEA)%IND_WTS(IG)%WT(INRST) = 1. + END IF + DO IPTS = 1,GR_INTS(ISEA)%IND_WTS(IG)%NP + IGX = GR_INTS(ISEA)%IND_WTS(IG)%IP(IPTS) + IGY = GR_INTS(ISEA)%IND_WTS(IG)%JP(IPTS) + LMAPICE = MOD ( GRIDS(IGRID)%MAPST2(IGY,IGX),2 ) + LMAPDRY = MOD ( GRIDS(IGRID)%MAPST2(IGY,IGX)/2,2 ) + LMAPLND = MOD ( GRIDS(IGRID)%MAPST2(IGY,IGX)/4,2 ) + LMAPMSK = MOD ( GRIDS(IGRID)%MAPST2(IGY,IGX)/8,2 ) + IF ( LMAPICE .EQ. 1 ) NMAPICE = NMAPICE + 1 + IF ( LMAPDRY .EQ. 1 ) NMAPDRY = NMAPDRY + 1 + IF ( LMAPLND .EQ. 1 ) NMAPLND = NMAPLND + 1 + IF ( LMAPMSK .EQ. 1 ) NMAPMSK = NMAPMSK + 1 + END DO + NMAPICE = NMAPICE*100/GR_INTS(ISEA)%IND_WTS(IG)%NP + NMAPDRY = NMAPDRY*100/GR_INTS(ISEA)%IND_WTS(IG)%NP + NMAPLND = NMAPLND*100/GR_INTS(ISEA)%IND_WTS(IG)%NP + NMAPMSK = NMAPMSK*100/GR_INTS(ISEA)%IND_WTS(IG)%NP + IF ( NMAPICE .GT. 50 ) MAPICET = 1 + IF ( NMAPDRY .GT. 50 ) MAPDRYT = 1 + IF ( NMAPLND .GT. 50 ) MAPLNDT = 1 + IF ( NMAPMSK .GT. 50 ) MAPMSKT = 1 + ACTIVE = (MAPICET .NE. 1 .AND. MAPDRYT .NE. 1 .AND. & + MAPLNDT .NE. 1 .AND. MAPMSKT .NE. 1) + IF ( ACTIVE ) THEN + USEGRID(IG) = .TRUE. + SUMGRD = SUMGRD+1 + MAPICE = MAPICET + MAPDRY = MAPDRYT + MAPLND = MAPLNDT + MAPMSK = MAPMSKT + ELSE + USEGRID(IG) = .FALSE. + END IF + END DO + IF ( SUMGRD .EQ. 0 ) THEN + MAPICE = MAPICET + MAPDRY = MAPDRYT + MAPLND = MAPLNDT + MAPMSK = MAPMSKT + END IF + ! + ! Reset the status map + ! + MAPST2(IY,IX) = MAPST2(IY,IX) + MAPICE + 2*MAPDRY + 4*MAPLND + & + 8*MAPMSK + ACTIVE = (MAPICE .NE. 1 .AND. MAPDRY .NE. 1 .AND. MAPLND .NE. 1 & + .AND. MAPMSK .NE. 1) + IF ( .NOT. ACTIVE ) MAPSTA(IY,IX) = -ABS ( MAPSTA(IY,IX) ) + ! + ! Second loop to do the actual interpolation + ! + DO IG = 1,GR_INTS(ISEA)%NGRDS + ! + IF ( USEGRID(IG) ) THEN + ! + IGRID = GR_INTS(ISEA)%GDID(IG) + ! + ! Initialize temporary variables used + ! + SUMWT = 0.0 + ! + ! Group 1 variables + ! + DWAUX = UNDEF + CXAUX = UNDEF + CYAUX = UNDEF + UAAUX = UNDEF + UDAUX = UNDEF + ASAUX = UNDEF + WLVAUX = UNDEF + ICEAUX = UNDEF + BERGAUX = UNDEF + SED_D50AUX = UNDEF + ICEHAUX = UNDEF + ICEFAUX = UNDEF + RHOAIRAUX = UNDEF + TAUAAUX = UNDEF + TAUADIRAUX = UNDEF + SUMWT1 = 0 + ! + ! Group 2 variables + ! + HSAUX = UNDEF + WLMAUX = UNDEF + T02AUX = UNDEF + T0M1AUX = UNDEF + T01AUX = UNDEF + FP0AUX = UNDEF + THMAUX1 = UNDEF + THMAUX2 = UNDEF + THSAUX = UNDEF + THP0AUX1 = UNDEF + THP0AUX2 = UNDEF + HSIGAUX = UNDEF + STMAXEAUX = UNDEF + STMAXDAUX = UNDEF + HMAXEAUX = UNDEF + HCMAXEAUX = UNDEF + HMAXDAUX = UNDEF + HCMAXDAUX = UNDEF + WBTAUX = UNDEF + WNMEANAUX = UNDEF + SUMWT2 = 0 + ! + ! Group 3 variables + ! + EFAUX = UNDEF + TH1MAUX = UNDEF + STH1MAUX = UNDEF + TH2MAUX = UNDEF + STH2MAUX = UNDEF + WNAUX = UNDEF + SUMWT3A = 0 + SUMWT3B = 0 + SUMWT3C = 0 + SUMWT3D = 0 + SUMWT3E = 0 + SUMWT3F = 0 + ! + ! Group 4 variables + ! + PHSAUX = UNDEF + PTPAUX = UNDEF + PLPAUX = UNDEF + PDIRAUX1 = UNDEF + PDIRAUX2 = UNDEF + PSIAUX = UNDEF + PWSAUX = UNDEF + PWSTAUX = UNDEF + PTHP0AUX1 = UNDEF + PTHP0AUX2 = UNDEF + PQPAUX = UNDEF + PPEAUX = UNDEF + PGWAUX = UNDEF + PSWAUX = UNDEF + PTM1AUX = UNDEF + PT1AUX = UNDEF + PT2AUX = UNDEF + PEPAUX = UNDEF + SUMWT4 = 0 + ! + ! Group 5 variables + ! + USTAUX1 = UNDEF + USTAUX2 = UNDEF + CHARNAUX = UNDEF + CGEAUX = UNDEF + PHIAWAUX = UNDEF + TAUWIXAUX = UNDEF + TAUWIYAUX = UNDEF + TAUWNXAUX = UNDEF + TAUWNYAUX = UNDEF + WHITECAPAUX = UNDEF + SUMWT5 = 0 + SUMWTC = 0 + ! + ! Group 6 variables + ! + SXXAUX = UNDEF + SXYAUX = UNDEF + SYYAUX = UNDEF + TAUOXAUX = UNDEF + TAUOYAUX = UNDEF + BHDAUX = UNDEF + PHIOCAUX = UNDEF + TUSXAUX = UNDEF + TUSYAUX = UNDEF + USSXAUX = UNDEF + USSYAUX = UNDEF + TAUOCXAUX = UNDEF + TAUOCYAUX = UNDEF + PRMSAUX = UNDEF + TPMSAUX = UNDEF + P2SMSAUX = UNDEF + US3DAUX = UNDEF + PHICEAUX = UNDEF + TAUICEAUX = UNDEF + USSPAUX = UNDEF + SUMWT69 = 0 + SUMWT68 = 0 + SUMWT612 = 0 + SUMWT6 = 0 + ! + ! Group 7 variables + ! + ABAAUX = UNDEF + ABDAUX = UNDEF + UBAAUX = UNDEF + UBDAUX = UNDEF + BEDFORMSAUX = UNDEF + PHIBBLAUX = UNDEF + TAUBBLAUX = UNDEF + SUMWT7 = 0 + SUMWTB = 0 + ! + ! Group 8 variables + ! + MSSXAUX = UNDEF + MSSYAUX = UNDEF + MSCXAUX = UNDEF + MSCYAUX = UNDEF + MSSDAUX1 = UNDEF + MSSDAUX2 = UNDEF + MSCDAUX1 = UNDEF + MSCDAUX2 = UNDEF + QPAUX = UNDEF + SUMWT8 = 0 + ! + ! Loop through the points per grid to obtain interpolated values + ! + DO IPTS = 1,GR_INTS(ISEA)%IND_WTS(IG)%NP + IGX = GR_INTS(ISEA)%IND_WTS(IG)%IP(IPTS) + IGY = GR_INTS(ISEA)%IND_WTS(IG)%JP(IPTS) + WT = GR_INTS(ISEA)%IND_WTS(IG)%WT(IPTS) + IF ( WT < 0. ) THEN + ! Point is not nearest + CYCLE + END IF + GSEA = GRIDS(IGRID)%MAPFS(IGY,IGX) + ! + ! Group 1 variables + ! + IF ( FLOGRD(1,1) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%DW(GSEA) .NE. UNDEF ) THEN + SUMWT1(1) = SUMWT1(1) + WT + IF ( DWAUX .EQ. UNDEF ) THEN + DWAUX = WADATS(IGRID)%DW(GSEA)*WT ELSE - DW(ISEA) = DW(ISEA) + DWAUX / REAL( SUMGRD ) + DWAUX = DWAUX + WADATS(IGRID)%DW(GSEA)*WT END IF END IF -! - IF ( CXAUX .NE. UNDEF ) THEN - CXAUX = CXAUX / SUMWT1(2) - CYAUX = CYAUX / SUMWT1(2) - IF ( CX(ISEA) .EQ. UNDEF ) THEN - CX(ISEA) = CXAUX / REAL( SUMGRD ) - CY(ISEA) = CYAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(1,2) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%CX(GSEA) .NE. UNDEF ) THEN + SUMWT1(2) = SUMWT1(2) + WT + IF ( CXAUX .EQ. UNDEF ) THEN + CXAUX = WADATS(IGRID)%CX(GSEA)*WT + CYAUX = WADATS(IGRID)%CY(GSEA)*WT ELSE - CX(ISEA) = CX(ISEA) + CXAUX / REAL( SUMGRD ) - CY(ISEA) = CY(ISEA) + CYAUX / REAL( SUMGRD ) + CXAUX = CXAUX + WADATS(IGRID)%CX(GSEA)*WT + CYAUX = CYAUX + WADATS(IGRID)%CY(GSEA)*WT END IF END IF -! - IF ( UAAUX .NE. UNDEF ) THEN - UAAUX = UAAUX / SUMWT1(3) - UDAUX = UDAUX / SUMWT1(3) - IF ( UA(ISEA) .EQ. UNDEF ) THEN - UA(ISEA) = UAAUX / REAL( SUMGRD ) - UD(ISEA) = UDAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(1,3) ) THEN + IF ( WADATS(IGRID)%UA(GSEA) .NE. UNDEF ) THEN + SUMWT1(3) = SUMWT1(3) + WT + IF ( UAAUX .EQ. UNDEF ) THEN + UAAUX = WADATS(IGRID)%UA(GSEA)*WT + UDAUX = WADATS(IGRID)%UD(GSEA)*WT ELSE - UA(ISEA) = UA(ISEA) + UAAUX / REAL( SUMGRD ) - UD(ISEA) = UD(ISEA) + UDAUX / REAL( SUMGRD ) + UAAUX = UAAUX + WADATS(IGRID)%UA(GSEA)*WT + UDAUX = UDAUX + WADATS(IGRID)%UD(GSEA)*WT END IF END IF -! - IF ( ASAUX .NE. UNDEF ) THEN - ASAUX = ASAUX / SUMWT1(4) - IF ( AS(ISEA) .EQ. UNDEF ) THEN - AS(ISEA) = ASAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(1,4) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%AS(GSEA) .NE. UNDEF ) THEN + SUMWT1(4) = SUMWT1(4) + WT + IF ( ASAUX .EQ. UNDEF ) THEN + ASAUX = WADATS(IGRID)%AS(GSEA)*WT ELSE - AS(ISEA) = AS(ISEA) + ASAUX / REAL( SUMGRD ) + ASAUX = ASAUX + WADATS(IGRID)%AS(GSEA)*WT END IF END IF -! - IF ( WLVAUX .NE. UNDEF ) THEN - WLVAUX = WLVAUX / SUMWT1(5) - IF ( WLV(ISEA) .EQ. UNDEF ) THEN - WLV(ISEA) = WLVAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(1,5) .AND. ACTIVE ) THEN + IF ( WDATAS(IGRID)%WLV(GSEA) .NE. UNDEF ) THEN + SUMWT1(5) = SUMWT1(5) + WT + IF ( WLVAUX .EQ. UNDEF ) THEN + WLVAUX = WDATAS(IGRID)%WLV(GSEA)*WT ELSE - WLV(ISEA) = WLV(ISEA) + WLVAUX / REAL( SUMGRD ) + WLVAUX = WLVAUX + WDATAS(IGRID)%WLV(GSEA)*WT END IF END IF -! - IF ( ICEAUX .NE. UNDEF ) THEN - ICEAUX = ICEAUX / SUMWT1(6) - IF ( ICE(ISEA) .EQ. UNDEF ) THEN - ICE(ISEA) = ICEAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(1,6) ) THEN + IF ( WDATAS(IGRID)%ICE(GSEA) .NE. UNDEF ) THEN + SUMWT1(6) = SUMWT1(6) + WT + IF ( ICEAUX .EQ. UNDEF ) THEN + ICEAUX = WDATAS(IGRID)%ICE(GSEA)*WT ELSE - ICE(ISEA) = ICE(ISEA) + ICEAUX / REAL( SUMGRD ) + ICEAUX = ICEAUX + WDATAS(IGRID)%ICE(GSEA)*WT END IF END IF -! - IF ( BERGAUX .NE. UNDEF ) THEN - BERGAUX = BERGAUX / SUMWT1(7) - IF ( BERG(ISEA) .EQ. UNDEF ) THEN - BERG(ISEA) = BERGAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(1,7) .AND. ACTIVE ) THEN + IF ( WDATAS(IGRID)%BERG(GSEA) .NE. UNDEF ) THEN + SUMWT1(7) = SUMWT1(7) + WT + IF ( BERGAUX .EQ. UNDEF ) THEN + BERGAUX = WDATAS(IGRID)%BERG(GSEA)*WT ELSE - BERG(ISEA) = BERG(ISEA) + BERGAUX / REAL( SUMGRD ) + BERGAUX = BERGAUX + WDATAS(IGRID)%BERG(GSEA)*WT END IF END IF -! - IF ( TAUAAUX .NE. UNDEF ) THEN - TAUAAUX = TAUAAUX / SUMWT1(8) - TAUADIRAUX = TAUADIRAUX / SUMWT1(8) - IF ( TAUA(ISEA) .EQ. UNDEF ) THEN - TAUA(ISEA) = TAUAAUX / REAL( SUMGRD ) - TAUADIR(ISEA) = TAUADIRAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(1,8) ) THEN + IF ( WADATS(IGRID)%TAUA(GSEA) .NE. UNDEF ) THEN + SUMWT1(8) = SUMWT1(8) + WT + IF ( TAUAAUX .EQ. UNDEF ) THEN + TAUAAUX = WADATS(IGRID)%TAUA(GSEA)*WT + TAUADIRAUX = WADATS(IGRID)%TAUADIR(GSEA)*WT ELSE - TAUA(ISEA) = TAUA(ISEA) + TAUAAUX / REAL( SUMGRD ) - TAUADIR(ISEA) = TAUADIR(ISEA) + TAUADIRAUX / REAL( SUMGRD ) + TAUAAUX = TAUAAUX + WADATS(IGRID)%TAUA(GSEA)*WT + TAUADIRAUX = TAUADIRAUX + WADATS(IGRID)%TAUADIR(GSEA)*WT END IF END IF -! - IF ( RHOAIRAUX .NE. UNDEF ) THEN - RHOAIRAUX = RHOAIRAUX / SUMWT1(9) - IF ( RHOAIR(ISEA) .EQ. UNDEF ) THEN - RHOAIR(ISEA) = RHOAIRAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(1,9) .AND. ACTIVE ) THEN + IF ( WDATAS(IGRID)%RHOAIR(GSEA) .NE. UNDEF ) THEN + SUMWT1(9) = SUMWT1(9) + WT + IF ( RHOAIRAUX .EQ. UNDEF ) THEN + RHOAIRAUX = WDATAS(IGRID)%RHOAIR(GSEA)*WT ELSE - RHOAIR(ISEA) = RHOAIR(ISEA) + RHOAIRAUX / REAL( SUMGRD ) + RHOAIRAUX = RHOAIRAUX + WDATAS(IGRID)%RHOAIR(GSEA)*WT END IF END IF -! + END IF + ! #ifdef W3_BT4 - IF ( SED_D50AUX .NE. UNDEF ) THEN - SED_D50AUX = SED_D50AUX / SUMWT1(10) - IF ( SED_D50(ISEA) .EQ. UNDEF ) THEN - SED_D50(ISEA) = SED_D50AUX / REAL( SUMGRD ) + IF ( FLOGRD(1,10) ) THEN + IF ( GRIDS(IGRID)%SED_D50(GSEA) .NE. UNDEF ) THEN + SUMWT1(10) = SUMWT1(10) + WT + IF ( SED_D50AUX .EQ. UNDEF ) THEN + SED_D50AUX = GRIDS(IGRID)%SED_D50(GSEA)*WT ELSE - SED_D50(ISEA) = SED_D50(ISEA) + SED_D50AUX / REAL( SUMGRD ) + SED_D50AUX = SED_D50AUX + GRIDS(IGRID)%SED_D50(GSEA)*WT END IF END IF + END IF #endif -! + ! #ifdef W3_IS2 - IF ( ICEHAUX .NE. UNDEF ) THEN - ICEHAUX = ICEHAUX / SUMWT1(11) - IF ( ICEH(ISEA) .EQ. UNDEF ) THEN - ICEH(ISEA) = ICEHAUX / REAL( SUMGRD ) + IF ( FLOGRD(1,11) ) THEN + IF ( WDATAS(IGRID)%ICEH(GSEA) .NE. UNDEF ) THEN + SUMWT1(11) = SUMWT1(11) + WT + IF (ICEHAUX .EQ. UNDEF) THEN + ICEHAUX = WDATAS(IGRID)%ICEH(GSEA)*WT ELSE - ICEH(ISEA) = ICEH(ISEA) + ICEHAUX / REAL( SUMGRD ) + ICEHAUX = ICEHAUX + WDATAS(IGRID)%ICEH(GSEA)*WT END IF END IF + END IF #endif -! + ! #ifdef W3_IS2 - IF ( ICEFAUX .NE. UNDEF ) THEN - ICEFAUX = ICEFAUX / SUMWT1(12) - IF ( ICEF(ISEA) .EQ. UNDEF ) THEN - ICEF(ISEA) = ICEFAUX / REAL( SUMGRD ) + IF ( FLOGRD(1,12) ) THEN + IF ( WDATAS(IGRID)%ICEF(GSEA) .NE. UNDEF ) THEN + SUMWT1(12) = SUMWT1(12) + WT + IF (ICEFAUX .EQ. UNDEF) THEN + ICEFAUX = WDATAS(IGRID)%ICEF(GSEA)*WT ELSE - ICEF(ISEA) = ICEF(ISEA) + ICEFAUX / REAL( SUMGRD ) + ICEFAUX = ICEFAUX + WDATAS(IGRID)%ICEF(GSEA)*WT END IF END IF + END IF #endif -! -! Group 2 variables -! - IF ( HSAUX .NE. UNDEF ) THEN - HSAUX = HSAUX / SUMWT2(1) - IF ( HS(ISEA) .EQ. UNDEF ) THEN - HS(ISEA) = HSAUX / REAL( SUMGRD ) + ! + ! Group 2 variables + ! + IF ( FLOGRD(2,1) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%HS(GSEA) .NE. UNDEF ) THEN + SUMWT2(1) = SUMWT2(1) + WT + IF ( HSAUX .EQ. UNDEF ) THEN + HSAUX = WADATS(IGRID)%HS(GSEA)*WT ELSE - HS(ISEA) = HS(ISEA) + HSAUX / REAL( SUMGRD ) + HSAUX = HSAUX + WADATS(IGRID)%HS(GSEA)*WT END IF END IF -! - IF ( WLMAUX .NE. UNDEF ) THEN - WLMAUX = WLMAUX / SUMWT2(2) - IF ( WLM(ISEA) .EQ. UNDEF ) THEN - WLM(ISEA) = WLMAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(2,2) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%WLM(GSEA) .NE. UNDEF ) THEN + SUMWT2(2) = SUMWT2(2) + WT + IF ( WLMAUX .EQ. UNDEF ) THEN + WLMAUX = WADATS(IGRID)%WLM(GSEA)*WT ELSE - WLM(ISEA) = WLM(ISEA) + WLMAUX / REAL( SUMGRD ) + WLMAUX = WLMAUX + WADATS(IGRID)%WLM(GSEA)*WT END IF END IF -! - IF ( T02AUX .NE. UNDEF ) THEN - T02AUX = T02AUX / SUMWT2(3) - IF ( T02(ISEA) .EQ. UNDEF ) THEN - T02(ISEA) = T02AUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(2,3) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%T02(GSEA) .NE. UNDEF ) THEN + SUMWT2(3) = SUMWT2(3) + WT + IF ( T02AUX .EQ. UNDEF ) THEN + T02AUX = WADATS(IGRID)%T02(GSEA)*WT ELSE - T02(ISEA) = T02(ISEA) + T02AUX / REAL( SUMGRD ) + T02AUX = T02AUX + WADATS(IGRID)%T02(GSEA)*WT END IF END IF -! - IF ( T0M1AUX .NE. UNDEF ) THEN - T0M1AUX = T0M1AUX / SUMWT2(4) - IF ( T0M1(ISEA) .EQ. UNDEF ) THEN - T0M1(ISEA) = T0M1AUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(2,4) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%T0M1(GSEA) .NE. UNDEF ) THEN + SUMWT2(4) = SUMWT2(4) + WT + IF ( T0M1AUX .EQ. UNDEF ) THEN + T0M1AUX = WADATS(IGRID)%T0M1(GSEA)*WT ELSE - T0M1(ISEA) = T0M1(ISEA) + T0M1AUX / REAL( SUMGRD ) + T0M1AUX = T0M1AUX + WADATS(IGRID)%T0M1(GSEA)*WT END IF END IF -! - IF ( T01AUX .NE. UNDEF ) THEN - T01AUX = T01AUX / SUMWT2(5) - IF ( T01(ISEA) .EQ. UNDEF ) THEN - T01(ISEA) = T01AUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(2,5) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%T01(GSEA) .NE. UNDEF ) THEN + SUMWT2(5) = SUMWT2(5) + WT + IF ( T01AUX .EQ. UNDEF ) THEN + T01AUX = WADATS(IGRID)%T01(GSEA)*WT ELSE - T01(ISEA) = T01(ISEA) + T01AUX / REAL( SUMGRD ) + T01AUX = T01AUX + WADATS(IGRID)%T01(GSEA)*WT END IF END IF -! - IF ( FP0AUX .NE. UNDEF ) THEN - FP0AUX = FP0AUX / SUMWT2(6) - IF ( FP0(ISEA) .EQ. UNDEF ) THEN - FP0(ISEA) = FP0AUX / REAL( SUMGRD ) + END IF + ! + IF ( (FLOGRD(2,6) .OR. FLOGRD(2,18)) .AND. ACTIVE ) THEN + ! Note: Output TP [FLOGRD(2,18)] is derived from FP0 + IF ( WADATS(IGRID)%FP0(GSEA) .NE. UNDEF ) THEN + SUMWT2(6) = SUMWT2(6) + WT + IF ( FP0AUX .EQ. UNDEF ) THEN + FP0AUX = WADATS(IGRID)%FP0(GSEA)*WT ELSE - FP0(ISEA) = FP0(ISEA) + FP0AUX / REAL( SUMGRD ) + FP0AUX = FP0AUX + WADATS(IGRID)%FP0(GSEA)*WT END IF END IF -! - IF ( THMAUX1 .NE. UNDEF ) THEN - THMAUX1 = THMAUX1 / SUMWT2(7) - THMAUX2 = THMAUX2 / SUMWT2(7) - IF ( THM(ISEA) .EQ. UNDEF ) THEN - THMAUX1 = THMAUX1 / REAL( SUMGRD ) - THMAUX2 = THMAUX2 / REAL( SUMGRD ) - THM(ISEA) = ATAN2 ( THMAUX2, THMAUX1 ) + END IF + ! + IF ( FLOGRD(2,7) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%THM(GSEA) .NE. UNDEF ) THEN + SUMWT2(7) = SUMWT2(7) + WT + IF ( THMAUX1 .EQ. UNDEF ) THEN + THMAUX1 = COS ( WADATS(IGRID)%THM(GSEA) )*WT + THMAUX2 = SIN ( WADATS(IGRID)%THM(GSEA) )*WT ELSE - THMAUX1 = THMAUX1 / REAL( SUMGRD ) + COS ( THM(ISEA) ) - THMAUX2 = THMAUX2 / REAL( SUMGRD ) + SIN ( THM(ISEA) ) - THM(ISEA) = ATAN2 ( THMAUX2, THMAUX1 ) + THMAUX1 = THMAUX1 + COS ( WADATS(IGRID)%THM(GSEA) )*WT + THMAUX2 = THMAUX2 + SIN ( WADATS(IGRID)%THM(GSEA) )*WT END IF END IF -! - IF ( THSAUX .NE. UNDEF ) THEN - THSAUX = THSAUX / SUMWT2(8) - IF ( THS(ISEA) .EQ. UNDEF ) THEN - THS(ISEA) = THSAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(2,8) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%THS(GSEA) .NE. UNDEF ) THEN + SUMWT2(8) = SUMWT2(8) + WT + IF ( THSAUX .EQ. UNDEF ) THEN + THSAUX = WADATS(IGRID)%THS(GSEA)*WT ELSE - THS(ISEA) = THS(ISEA) + THSAUX / REAL( SUMGRD ) + THSAUX = THSAUX + WADATS(IGRID)%THS(GSEA)*WT END IF END IF -! - IF ( THP0AUX1 .NE. UNDEF ) THEN - THP0AUX1 = THP0AUX1 / SUMWT2(9) - THP0AUX2 = THP0AUX2 / SUMWT2(9) - IF ( THP0(ISEA) .EQ. UNDEF ) THEN - THP0AUX1 = THP0AUX1 / REAL( SUMGRD ) - THP0AUX2 = THP0AUX2 / REAL( SUMGRD ) - THP0(ISEA) = ATAN2 ( THP0AUX2, THP0AUX1 ) + END IF + ! + IF ( FLOGRD(2,9) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%THP0(GSEA) .NE. UNDEF ) THEN + SUMWT2(9) = SUMWT2(9) + WT + IF ( THP0AUX1 .EQ. UNDEF ) THEN + THP0AUX1 = COS ( WADATS(IGRID)%THP0(GSEA) )*WT + THP0AUX2 = SIN ( WADATS(IGRID)%THP0(GSEA) )*WT ELSE - THP0AUX1 = THP0AUX1 / REAL( SUMGRD ) + COS ( THP0(ISEA) ) - THP0AUX2 = THP0AUX2 / REAL( SUMGRD ) + SIN ( THP0(ISEA) ) - THP0(ISEA) = ATAN2 ( THP0AUX2, THP0AUX1 ) + THP0AUX1 = THP0AUX1 + & + COS ( WADATS(IGRID)%THP0(GSEA) )*WT + THP0AUX2 = THP0AUX2 + & + SIN ( WADATS(IGRID)%THP0(GSEA) )*WT END IF END IF -! - IF ( HSIGAUX .NE. UNDEF ) THEN - IF ( HSIG(ISEA) .EQ. UNDEF ) HSIG(ISEA) = 0. - HSIG(ISEA) = HSIG(ISEA) + & - HSIGAUX / REAL( SUMWT2(10)*SUMGRD ) - END IF -! - IF ( STMAXEAUX .NE. UNDEF ) THEN - IF ( STMAXE(ISEA) .EQ. UNDEF ) STMAXE(ISEA) = 0. - STMAXE(ISEA) = STMAXE(ISEA) + & - STMAXEAUX / REAL( SUMWT2(11) * SUMGRD ) - END IF -! - IF ( STMAXDAUX .NE. UNDEF ) THEN - IF ( STMAXD(ISEA) .EQ. UNDEF ) STMAXD(ISEA) = 0. - STMAXD(ISEA) = STMAXD(ISEA) + & - STMAXDAUX / REAL( SUMWT2(12) * SUMGRD ) + END IF + ! + IF ( FLOGRD(2,10) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%HSIG(GSEA) .NE. UNDEF ) THEN + SUMWT2(10) = SUMWT2(10) + WT + IF ( HSIGAUX .EQ. UNDEF ) HSIGAUX = 0. + HSIGAUX = HSIGAUX + WADATS(IGRID)%HSIG(GSEA)*WT END IF -! - IF ( HMAXEAUX .NE. UNDEF ) THEN - IF ( HMAXE(ISEA) .EQ. UNDEF ) HMAXE(ISEA) = 0. - HMAXE(ISEA) = HMAXE(ISEA) + & - HMAXEAUX / REAL( SUMWT2(13) * SUMGRD ) + END IF + ! + IF ( FLOGRD(2,11) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%STMAXE(GSEA) .NE. UNDEF ) THEN + SUMWT2(11) = SUMWT2(11) + WT + IF ( STMAXEAUX .EQ. UNDEF ) STMAXEAUX = 0. + STMAXEAUX = STMAXEAUX + WADATS(IGRID)%STMAXE(GSEA)*WT END IF -! - IF ( HCMAXEAUX .NE. UNDEF ) THEN - IF ( HCMAXE(ISEA) .EQ. UNDEF ) HCMAXE(ISEA) = 0. - HCMAXE(ISEA) = HCMAXE(ISEA) + & - HCMAXEAUX / REAL( SUMWT2(14) * SUMGRD ) + END IF + ! + IF ( FLOGRD(2,12) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%STMAXD(GSEA) .NE. UNDEF ) THEN + SUMWT2(12) = SUMWT2(12) + WT + IF ( STMAXDAUX .EQ. UNDEF ) STMAXDAUX = 0. + STMAXDAUX = STMAXDAUX + WADATS(IGRID)%STMAXD(GSEA)*WT END IF -! - IF ( HMAXDAUX .NE. UNDEF ) THEN - IF ( HMAXD(ISEA) .EQ. UNDEF ) HMAXD(ISEA) = 0. - HMAXD(ISEA) = HMAXD(ISEA) + & - HMAXDAUX / REAL( SUMWT2(15) * SUMGRD ) + END IF + ! + IF ( FLOGRD(2,13) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%HMAXE(GSEA) .NE. UNDEF ) THEN + SUMWT2(13) = SUMWT2(13) + WT + IF ( HMAXEAUX .EQ. UNDEF ) HMAXEAUX = 0. + HMAXEAUX = HMAXEAUX + WADATS(IGRID)%HMAXE(GSEA)*WT END IF -! - IF ( HCMAXDAUX .NE. UNDEF ) THEN - IF ( HCMAXD(ISEA) .EQ. UNDEF ) HCMAXD(ISEA) = 0. - HCMAXD(ISEA) = HCMAXD(ISEA) + & - HCMAXDAUX / REAL( SUMWT2(16) * SUMGRD ) + END IF + ! + IF ( FLOGRD(2,14) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%HCMAXE(GSEA) .NE. UNDEF ) THEN + SUMWT2(14) = SUMWT2(14) + WT + IF ( HCMAXEAUX .EQ. UNDEF ) HCMAXEAUX = 0. + HCMAXEAUX = HCMAXEAUX + WADATS(IGRID)%HCMAXE(GSEA)*WT END IF -! - IF ( WBTAUX .NE. UNDEF ) THEN - IF ( WBT(ISEA) .EQ. UNDEF ) WBT(ISEA) = 0. - WBT(ISEA) = WBT(ISEA) + & - WBTAUX / REAL( SUMWT2(17)*SUMGRD ) + END IF + ! + IF ( FLOGRD(2,15) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%HMAXD(GSEA) .NE. UNDEF ) THEN + SUMWT2(15) = SUMWT2(15) + WT + IF ( HMAXDAUX .EQ. UNDEF ) HMAXDAUX = 0. + HMAXDAUX = HMAXDAUX + WADATS(IGRID)%HMAXD(GSEA)*WT END IF -! - IF ( WNMEANAUX .NE. UNDEF ) THEN - IF ( WNMEAN(ISEA) .EQ. UNDEF ) WNMEAN(ISEA) = 0. - WNMEAN(ISEA) = WNMEAN(ISEA) + & - WNMEANAUX / REAL( SUMWT2(19)*SUMGRD ) + END IF + ! + IF ( FLOGRD(2,16) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%HCMAXD(GSEA) .NE. UNDEF ) THEN + SUMWT2(16) = SUMWT2(16) + WT + IF ( HCMAXDAUX .EQ. UNDEF ) HCMAXDAUX = 0. + HCMAXDAUX = HCMAXDAUX + WADATS(IGRID)%HCMAXD(GSEA)*WT END IF -! -! Group 3 variables -! - IF ( E3DF(1,1).GT.0 ) THEN - DO IFREQ = E3DF(2,1),E3DF(3,1) - IF ( EFAUX(IFREQ) .NE. UNDEF ) THEN - EFAUX(IFREQ) = EFAUX(IFREQ) / SUMWT3A(IFREQ) - IF ( EF(ISEA,IFREQ) .EQ. UNDEF ) THEN - EF(ISEA,IFREQ) = EFAUX(IFREQ) / REAL( SUMGRD ) - ELSE - EF(ISEA,IFREQ) = EF(ISEA,IFREQ) + & - EFAUX(IFREQ) / REAL( SUMGRD ) - END IF - END IF - END DO + END IF + ! + IF ( FLOGRD(2,17) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%WBT(GSEA) .NE. UNDEF ) THEN + SUMWT2(17) = SUMWT2(17) + WT + IF ( WBTAUX .EQ. UNDEF ) WBTAUX = 0. + WBTAUX = WBTAUX + WADATS(IGRID)%WBT(GSEA)*WT END IF -! - IF ( E3DF(1,2).GT.0 ) THEN - DO IFREQ = E3DF(2,2),E3DF(3,2) - IF ( TH1MAUX(IFREQ) .NE. UNDEF ) THEN - TH1MAUX(IFREQ) = TH1MAUX(IFREQ) / SUMWT3B(IFREQ) - IF ( TH1M(ISEA,IFREQ) .EQ. UNDEF ) THEN - TH1M(ISEA,IFREQ) = TH1MAUX(IFREQ) / REAL( SUMGRD ) - ELSE - TH1M(ISEA,IFREQ) = TH1M(ISEA,IFREQ) + & - TH1MAUX(IFREQ) / REAL( SUMGRD ) - END IF - END IF - END DO + END IF + ! + IF ( FLOGRD(2,19) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%WNMEAN(GSEA) .NE. UNDEF ) THEN + SUMWT2(19) = SUMWT2(19) + WT + IF ( WNMEANAUX .EQ. UNDEF ) WNMEANAUX = 0. + WNMEANAUX = WNMEANAUX + WADATS(IGRID)%WNMEAN(GSEA)*WT END IF -! - IF ( E3DF(1,3).GT.0 ) THEN - DO IFREQ = E3DF(2,3),E3DF(3,3) - IF ( STH1MAUX(IFREQ) .NE. UNDEF ) THEN - STH1MAUX(IFREQ) = STH1MAUX(IFREQ) / SUMWT3C(IFREQ) - IF ( STH1M(ISEA,IFREQ) .EQ. UNDEF ) THEN - STH1M(ISEA,IFREQ) = STH1MAUX(IFREQ) / REAL( SUMGRD ) - ELSE - STH1M(ISEA,IFREQ) = STH1M(ISEA,IFREQ) + & - STH1MAUX(IFREQ) / REAL( SUMGRD ) - END IF + END IF + ! + ! Group 3 variables + ! + IF ( FLOGRD(3,1) .AND. ACTIVE ) THEN + DO IFREQ = E3DF(2,1),E3DF(3,1) + IF ( WADATS(IGRID)%EF(GSEA,IFREQ) .NE. UNDEF ) THEN + SUMWT3A(IFREQ) = SUMWT3A(IFREQ) + WT + IF ( EFAUX(IFREQ) .EQ. UNDEF ) THEN + EFAUX(IFREQ) = WADATS(IGRID)%EF(GSEA,IFREQ)*WT + ELSE + EFAUX(IFREQ) = EFAUX(IFREQ) + WADATS(IGRID)%EF(GSEA,IFREQ)*WT END IF - END DO - END IF -! - IF ( E3DF(1,4).GT.0 ) THEN - DO IFREQ = E3DF(2,4),E3DF(3,4) - IF ( TH2MAUX(IFREQ) .NE. UNDEF ) THEN - TH2MAUX(IFREQ) = TH2MAUX(IFREQ) / SUMWT3D(IFREQ) - IF ( TH2M(ISEA,IFREQ) .EQ. UNDEF ) THEN - TH2M(ISEA,IFREQ) = TH2MAUX(IFREQ) / REAL( SUMGRD ) - ELSE - TH2M(ISEA,IFREQ) = TH2M(ISEA,IFREQ) + & - TH2MAUX(IFREQ) / REAL( SUMGRD ) - END IF + END IF + END DO + END IF + ! + IF ( FLOGRD(3,2) .AND. ACTIVE ) THEN + DO IFREQ = E3DF(2,2),E3DF(3,2) + IF ( WADATS(IGRID)%TH1M(GSEA,IFREQ) .NE. UNDEF ) THEN + SUMWT3B(IFREQ) = SUMWT3B(IFREQ) + WT + IF ( TH1MAUX(IFREQ) .EQ. UNDEF ) THEN + TH1MAUX(IFREQ) = WADATS(IGRID)%TH1M(GSEA,IFREQ)*WT + ELSE + TH1MAUX(IFREQ) = TH1MAUX(IFREQ) + WADATS(IGRID)%TH1M(GSEA,IFREQ)*WT END IF - END DO - END IF -! - IF ( E3DF(1,5).GT.0 ) THEN - DO IFREQ = E3DF(2,5),E3DF(3,5) - IF ( STH2MAUX(IFREQ) .NE. UNDEF ) THEN - STH2MAUX(IFREQ) = STH2MAUX(IFREQ) / SUMWT3E(IFREQ) - IF ( STH2M(ISEA,IFREQ) .EQ. UNDEF ) THEN - STH2M(ISEA,IFREQ) = STH2MAUX(IFREQ) / REAL( SUMGRD ) - ELSE - STH2M(ISEA,IFREQ) = STH2M(ISEA,IFREQ) + & - STH2MAUX(IFREQ) / REAL( SUMGRD ) - END IF + END IF + END DO + END IF + ! + IF ( FLOGRD(3,3) .AND. ACTIVE ) THEN + DO IFREQ = E3DF(2,3),E3DF(3,3) + IF ( WADATS(IGRID)%STH1M(GSEA,IFREQ) .NE. UNDEF ) THEN + SUMWT3C(IFREQ) = SUMWT3C(IFREQ) + WT + IF ( STH1MAUX(IFREQ) .EQ. UNDEF ) THEN + STH1MAUX(IFREQ) = WADATS(IGRID)%STH1M(GSEA,IFREQ)*WT + ELSE + STH1MAUX(IFREQ) = STH1MAUX(IFREQ) + WADATS(IGRID)%STH1M(GSEA,IFREQ)*WT END IF - END DO - END IF -! - DO IK = 1,NK - IF ( WNAUX(IK) .NE. UNDEF ) THEN - WNAUX(IK) = WNAUX(IK) / SUMWT3F(IK) - IF ( WN(IK,ISEA) .EQ. UNDEF ) THEN - WN(IK,ISEA) = WNAUX(IK) / REAL( SUMGRD ) + END IF + END DO + END IF + ! + IF ( FLOGRD(3,4) .AND. ACTIVE ) THEN + DO IFREQ = E3DF(2,4),E3DF(3,4) + IF ( WADATS(IGRID)%TH2M(GSEA,IFREQ) .NE. UNDEF ) THEN + SUMWT3D(IFREQ) = SUMWT3D(IFREQ) + WT + IF ( TH2MAUX(IFREQ) .EQ. UNDEF ) THEN + TH2MAUX(IFREQ) = WADATS(IGRID)%TH2M(GSEA,IFREQ)*WT ELSE - WN(IK,ISEA) = WN(IK,ISEA) + & - WNAUX(IK) / REAL( SUMGRD ) + TH2MAUX(IFREQ) = TH2MAUX(IFREQ) + WADATS(IGRID)%TH2M(GSEA,IFREQ)*WT END IF END IF END DO -! -! Group 4 variables -! - DO ISWLL = 0, NOSWLL_MIN -! - IF ( PHSAUX(ISWLL) .NE. UNDEF ) THEN - PHSAUX(ISWLL) = PHSAUX(ISWLL) / SUMWT4(1,ISWLL) - IF ( PHS(ISEA,ISWLL) .EQ. UNDEF ) THEN - PHS(ISEA,ISWLL) = PHSAUX(ISWLL) / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(3,5) .AND. ACTIVE ) THEN + DO IFREQ = E3DF(2,5),E3DF(3,5) + IF ( WADATS(IGRID)%STH2M(GSEA,IFREQ) .NE. UNDEF ) THEN + SUMWT3E(IFREQ) = SUMWT3E(IFREQ) + WT + IF ( STH2MAUX(IFREQ) .EQ. UNDEF ) THEN + STH2MAUX(IFREQ) = WADATS(IGRID)%STH2M(GSEA,IFREQ)*WT ELSE - PHS(ISEA,ISWLL) = PHS(ISEA,ISWLL) + & - PHSAUX(ISWLL) / REAL( SUMGRD ) + STH2MAUX(IFREQ) = STH2MAUX(IFREQ) + WADATS(IGRID)%STH2M(GSEA,IFREQ)*WT END IF END IF -! - IF ( PTPAUX(ISWLL) .NE. UNDEF ) THEN - PTPAUX(ISWLL) = PTPAUX(ISWLL) / SUMWT4(2,ISWLL) - IF ( PTP(ISEA,ISWLL) .EQ. UNDEF ) THEN - PTP(ISEA,ISWLL) = PTPAUX(ISWLL) / REAL( SUMGRD ) + END DO + END IF + + ! + IF ( FLOGRD(3,6) .AND. ACTIVE ) THEN + DO IK = 1,NK + IF ( WADATS(IGRID)%WN(IK,GSEA) .NE. UNDEF ) THEN + SUMWT3F(IK) = SUMWT3F(IK) + WT + IF ( WNAUX(IK) .EQ. UNDEF ) THEN + WNAUX(IK) = WADATS(IGRID)%WN(IK,GSEA)*WT ELSE - PTP(ISEA,ISWLL) = PTP(ISEA,ISWLL) + & - PTPAUX(ISWLL) / REAL( SUMGRD ) + WNAUX(IK) = WNAUX(IK) + WADATS(IGRID)%WN(IK,GSEA)*WT END IF END IF -! - IF ( PLPAUX(ISWLL) .NE. UNDEF ) THEN - PLPAUX(ISWLL) = PLPAUX(ISWLL) / SUMWT4(3,ISWLL) - IF ( PLP(ISEA,ISWLL) .EQ. UNDEF ) THEN - PLP(ISEA,ISWLL) = PLPAUX(ISWLL) / REAL( SUMGRD ) + END DO + END IF + ! + ! Group 4 variables + ! + DO ISWLL = 0, NOSWLL_MIN + ! + IF ( FLOGRD(4,1) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PHS(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(1,ISWLL) = SUMWT4(1,ISWLL) + WT + IF ( PHSAUX(ISWLL) .EQ. UNDEF ) THEN + PHSAUX(ISWLL) = WADATS(IGRID)%PHS(GSEA,ISWLL)*WT ELSE - PLP(ISEA,ISWLL) = PLP(ISEA,ISWLL) + & - PLPAUX(ISWLL) / REAL( SUMGRD ) + PHSAUX(ISWLL) = PHSAUX(ISWLL) + & + WADATS(IGRID)%PHS(GSEA,ISWLL)*WT END IF END IF -! - IF ( PDIRAUX1(ISWLL) .NE. UNDEF ) THEN - PDIRAUX1(ISWLL) = PDIRAUX1(ISWLL) / SUMWT4(4,ISWLL) - PDIRAUX2(ISWLL) = PDIRAUX2(ISWLL) / SUMWT4(4,ISWLL) - IF ( PDIR(ISEA,ISWLL) .EQ. UNDEF ) THEN - PDIRAUX1(ISWLL) = PDIRAUX1(ISWLL) / REAL( SUMGRD ) - PDIRAUX2(ISWLL) = PDIRAUX2(ISWLL) / REAL( SUMGRD ) - PDIR(ISEA,ISWLL) = ATAN2 ( PDIRAUX2(ISWLL), PDIRAUX1(ISWLL) ) + END IF + ! + IF ( FLOGRD(4,2) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PTP(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(2,ISWLL) = SUMWT4(2,ISWLL) + WT + IF ( PTPAUX(ISWLL) .EQ. UNDEF ) THEN + PTPAUX(ISWLL) = WADATS(IGRID)%PTP(GSEA,ISWLL)*WT ELSE - PDIRAUX1(ISWLL) = PDIRAUX1(ISWLL) / REAL( SUMGRD ) + & - COS ( PDIR(ISEA,ISWLL) ) - PDIRAUX2(ISWLL) = PDIRAUX2(ISWLL) / REAL( SUMGRD ) + & - SIN ( PDIR(ISEA,ISWLL) ) - PDIR(ISEA,ISWLL) = ATAN2 ( PDIRAUX2(ISWLL), PDIRAUX1(ISWLL) ) + PTPAUX(ISWLL) = PTPAUX(ISWLL) + & + WADATS(IGRID)%PTP(GSEA,ISWLL)*WT END IF END IF -! - IF ( PSIAUX(ISWLL) .NE. UNDEF ) THEN - PSIAUX(ISWLL) = PSIAUX(ISWLL) / SUMWT4(5,ISWLL) - IF ( PSI(ISEA,ISWLL) .EQ. UNDEF ) THEN - PSI(ISEA,ISWLL) = PSIAUX(ISWLL) / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(4,3) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PLP(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(3,ISWLL) = SUMWT4(3,ISWLL) + WT + IF ( PLPAUX(ISWLL) .EQ. UNDEF ) THEN + PLPAUX(ISWLL) = WADATS(IGRID)%PLP(GSEA,ISWLL)*WT ELSE - PSI(ISEA,ISWLL) = PSI(ISEA,ISWLL) + & - PSIAUX(ISWLL) / REAL( SUMGRD ) + PLPAUX(ISWLL) = PLPAUX(ISWLL) + & + WADATS(IGRID)%PLP(GSEA,ISWLL)*WT END IF END IF -! - IF ( PWSAUX(ISWLL) .NE. UNDEF ) THEN - PWSAUX(ISWLL) = PWSAUX(ISWLL) / SUMWT4(6,ISWLL) - IF ( PWS(ISEA,ISWLL) .EQ. UNDEF ) THEN - PWS(ISEA,ISWLL) = PWSAUX(ISWLL) / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(4,4) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PDIR(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(4,ISWLL) = SUMWT4(4,ISWLL) + WT + IF ( PDIRAUX1(ISWLL) .EQ. UNDEF ) THEN + PDIRAUX1(ISWLL) = & + COS ( WADATS(IGRID)%PDIR(GSEA,ISWLL) )*WT + PDIRAUX2(ISWLL) = & + SIN ( WADATS(IGRID)%PDIR(GSEA,ISWLL) )*WT ELSE - PWS(ISEA,ISWLL) = PWS(ISEA,ISWLL) + & - PWSAUX(ISWLL) / REAL( SUMGRD ) + PDIRAUX1(ISWLL) = PDIRAUX1(ISWLL) + & + COS ( WADATS(IGRID)%PDIR(GSEA,ISWLL) )*WT + PDIRAUX2(ISWLL) = PDIRAUX2(ISWLL) + & + SIN ( WADATS(IGRID)%PDIR(GSEA,ISWLL) )*WT END IF END IF -! - IF ( PTHP0AUX1(ISWLL) .NE. UNDEF ) THEN - PTHP0AUX1(ISWLL) = PTHP0AUX1(ISWLL) & - / REAL( SUMWT4(7,ISWLL)*SUMGRD ) - PTHP0AUX2(ISWLL) = PTHP0AUX2(ISWLL) & - / REAL( SUMWT4(7,ISWLL)*SUMGRD ) - IF ( PTHP0(ISEA,ISWLL) .NE. UNDEF ) THEN - PTHP0AUX1(ISWLL) = PTHP0AUX1(ISWLL) + & - COS ( PTHP0(ISEA,ISWLL) ) - PTHP0AUX2(ISWLL) = PTHP0AUX2(ISWLL) + & - SIN ( PTHP0(ISEA,ISWLL) ) + END IF + ! + IF ( FLOGRD(4,5) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PSI(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(5,ISWLL) = SUMWT4(5,ISWLL) + WT + IF ( PSIAUX(ISWLL) .EQ. UNDEF ) THEN + PSIAUX(ISWLL) = WADATS(IGRID)%PSI(GSEA,ISWLL)*WT + ELSE + PSIAUX(ISWLL) = PSIAUX(ISWLL) + & + WADATS(IGRID)%PSI(GSEA,ISWLL)*WT END IF - PTHP0(ISEA,ISWLL) = & - ATAN2 ( PTHP0AUX2(ISWLL), PTHP0AUX1(ISWLL) ) END IF -! - IF ( PQPAUX(ISWLL) .NE. UNDEF ) THEN - IF ( PQP(ISEA,ISWLL) .EQ. UNDEF ) & - PQP(ISEA,ISWLL) = 0. - PQP(ISEA,ISWLL) = PQP(ISEA,ISWLL) + & - PQPAUX(ISWLL) / REAL( SUMWT4(8,ISWLL)*SUMGRD ) + END IF + ! + IF ( FLOGRD(4,6) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PWS(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(6,ISWLL) = SUMWT4(6,ISWLL) + WT + IF ( PWSAUX(ISWLL) .EQ. UNDEF ) THEN + PWSAUX(ISWLL) = WADATS(IGRID)%PWS(GSEA,ISWLL)*WT + ELSE + PWSAUX(ISWLL) = PWSAUX(ISWLL) + & + WADATS(IGRID)%PWS(GSEA,ISWLL)*WT + END IF + END IF + END IF + ! + IF ( FLOGRD(4,7) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PTHP0(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(7,ISWLL) = SUMWT4(7,ISWLL) + WT + IF (PTHP0AUX1(ISWLL).EQ.UNDEF) & + PTHP0AUX1(ISWLL) = 0. + IF (PTHP0AUX2(ISWLL).EQ.UNDEF) & + PTHP0AUX2(ISWLL) = 0. + PTHP0AUX1(ISWLL) = PTHP0AUX1(ISWLL) + & + COS ( WADATS(IGRID)%PTHP0(GSEA,ISWLL) )*WT + PTHP0AUX2(ISWLL) = PTHP0AUX2(ISWLL) + & + SIN ( WADATS(IGRID)%PTHP0(GSEA,ISWLL) )*WT + END IF + END IF + ! + IF ( FLOGRD(4,8) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PQP(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(8,ISWLL) = SUMWT4(8,ISWLL) + WT + IF ( PQPAUX(ISWLL).EQ.UNDEF ) PQPAUX(ISWLL) = 0. + PQPAUX(ISWLL) = PQPAUX(ISWLL) + & + WADATS(IGRID)%PQP(GSEA,ISWLL)*WT + END IF + END IF + ! + IF ( FLOGRD(4,9) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PPE(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(9,ISWLL) = SUMWT4(9,ISWLL) + WT + IF ( PPEAUX(ISWLL).EQ.UNDEF ) PPEAUX(ISWLL) = 0. + PPEAUX(ISWLL) = PPEAUX(ISWLL) + & + WADATS(IGRID)%PPE(GSEA,ISWLL)*WT + END IF + END IF + ! + IF ( FLOGRD(4,10) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PGW(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(10,ISWLL) = SUMWT4(10,ISWLL) + WT + IF ( PGWAUX(ISWLL).EQ.UNDEF ) PGWAUX(ISWLL) = 0. + PGWAUX(ISWLL) = PGWAUX(ISWLL) + & + WADATS(IGRID)%PGW(GSEA,ISWLL)*WT + END IF + END IF + ! + IF ( FLOGRD(4,11) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PSW(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(11,ISWLL) = SUMWT4(11,ISWLL) + WT + IF ( PSWAUX(ISWLL).EQ.UNDEF ) PSWAUX(ISWLL) = 0. + PSWAUX(ISWLL) = PSWAUX(ISWLL) + & + WADATS(IGRID)%PSW(GSEA,ISWLL)*WT + END IF + END IF + ! + IF ( FLOGRD(4,12) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PTM1(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(12,ISWLL) = SUMWT4(12,ISWLL) + WT + IF ( PTM1AUX(ISWLL).EQ.UNDEF ) & + PTM1AUX(ISWLL) = 0. + PTM1AUX(ISWLL) = PTM1AUX(ISWLL) + & + WADATS(IGRID)%PTM1(GSEA,ISWLL)*WT + END IF + END IF + ! + IF ( FLOGRD(4,13) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PT1(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(13,ISWLL) = SUMWT4(13,ISWLL) + WT + IF ( PT1AUX(ISWLL).EQ.UNDEF ) PT1AUX(ISWLL) = 0. + PT1AUX(ISWLL) = PT1AUX(ISWLL) + & + WADATS(IGRID)%PT1(GSEA,ISWLL)*WT + END IF + END IF + ! + IF ( FLOGRD(4,14) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PT2(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(14,ISWLL) = SUMWT4(14,ISWLL) + WT + IF ( PT2AUX(ISWLL).EQ.UNDEF ) PT2AUX(ISWLL) = 0. + PT2AUX(ISWLL) = PT2AUX(ISWLL) + & + WADATS(IGRID)%PT2(GSEA,ISWLL)*WT + END IF + END IF + ! + IF ( FLOGRD(4,15) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PEP(GSEA,ISWLL) .NE. UNDEF ) THEN + SUMWT4(15,ISWLL) = SUMWT4(15,ISWLL) + WT + IF ( PEPAUX(ISWLL).EQ.UNDEF ) PEPAUX(ISWLL) = 0. + PEPAUX(ISWLL) = PEPAUX(ISWLL) + & + WADATS(IGRID)%PEP(GSEA,ISWLL)*WT + END IF + END IF + ! + END DO !/ ISWLL = 0, NOSWLL_MIN + ! + IF ( FLOGRD(4,16) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PWST(GSEA) .NE. UNDEF ) THEN + SUMWT4(16,0) = SUMWT4(16,0) + WT + IF ( PWSTAUX .EQ. UNDEF ) THEN + PWSTAUX = WADATS(IGRID)%PWST(GSEA)*WT + ELSE + PWSTAUX = PWSTAUX + WADATS(IGRID)%PWST(GSEA)*WT END IF -! - IF ( PPEAUX(ISWLL) .NE. UNDEF ) THEN - IF ( PPE(ISEA,ISWLL) .EQ. UNDEF ) & - PPE(ISEA,ISWLL) = 0. - PPE(ISEA,ISWLL) = PPE(ISEA,ISWLL) + & - PPEAUX(ISWLL) / REAL( SUMWT4(9,ISWLL)*SUMGRD ) - + END IF + END IF + ! + ! Group 5 variables + ! + IF ( FLOGRD(5,1) ) THEN + IF ( WDATAS(IGRID)%UST(GSEA) .NE. UNDEF ) THEN + SUMWT5(1) = SUMWT5(1) + WT + IF ( USTAUX1 .EQ. UNDEF ) THEN + USTAUX1 = WDATAS(IGRID)%UST(GSEA)*WT + USTAUX2 = WDATAS(IGRID)%USTDIR(GSEA)*WT + ELSE + USTAUX1 = USTAUX1 + WDATAS(IGRID)%UST(GSEA)*WT + USTAUX2 = USTAUX2 + WDATAS(IGRID)%USTDIR(GSEA)*WT END IF -! - IF ( PGWAUX(ISWLL) .NE. UNDEF ) THEN - IF ( PGW(ISEA,ISWLL) .EQ. UNDEF ) & - PGW(ISEA,ISWLL) = 0. - PGW(ISEA,ISWLL) = PGW(ISEA,ISWLL) + & - PGWAUX(ISWLL) / REAL( SUMWT4(10,ISWLL)*SUMGRD ) + END IF + END IF + ! + IF ( FLOGRD(5,2) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%CHARN(GSEA) .NE. UNDEF ) THEN + SUMWT5(2) = SUMWT5(2) + WT + IF ( CHARNAUX .EQ. UNDEF ) THEN + CHARNAUX = WADATS(IGRID)%CHARN(GSEA)*WT + ELSE + CHARNAUX = CHARNAUX + WADATS(IGRID)%CHARN(GSEA)*WT END IF -! - IF ( PSWAUX(ISWLL) .NE. UNDEF ) THEN - IF ( PSW(ISEA,ISWLL) .EQ. UNDEF ) & - PSW(ISEA,ISWLL) = 0. - PSW(ISEA,ISWLL) = PSW(ISEA,ISWLL) + & - PSWAUX(ISWLL) / REAL( SUMWT4(11,ISWLL)*SUMGRD ) + END IF + END IF + ! + IF ( FLOGRD(5,3) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%CGE(GSEA) .NE. UNDEF ) THEN + SUMWT5(3) = SUMWT5(3) + WT + IF ( CGEAUX .EQ. UNDEF ) THEN + CGEAUX = WADATS(IGRID)%CGE(GSEA)*WT + ELSE + CGEAUX = CGEAUX + WADATS(IGRID)%CGE(GSEA)*WT END IF -! - IF ( PTM1AUX(ISWLL) .NE. UNDEF ) THEN - IF ( PTM1(ISEA,ISWLL) .EQ. UNDEF ) & - PTM1(ISEA,ISWLL) = 0. - PTM1(ISEA,ISWLL) = PTM1(ISEA,ISWLL) + & - PTM1AUX(ISWLL) / REAL( SUMWT4(12,ISWLL)*SUMGRD ) + END IF + END IF + ! + IF ( FLOGRD(5,4) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PHIAW(GSEA) .NE. UNDEF ) THEN + SUMWT5(4) = SUMWT5(4) + WT + IF ( PHIAWAUX .EQ. UNDEF ) THEN + PHIAWAUX = WADATS(IGRID)%PHIAW(GSEA)*WT + ELSE + PHIAWAUX = PHIAWAUX + WADATS(IGRID)%PHIAW(GSEA)*WT END IF -! - IF ( PT1AUX(ISWLL) .NE. UNDEF ) THEN - IF ( PT1(ISEA,ISWLL) .EQ. UNDEF ) & - PT1(ISEA,ISWLL) = 0. - PT1(ISEA,ISWLL) = PT1(ISEA,ISWLL) + & - PT1AUX(ISWLL) / REAL( SUMWT4(13,ISWLL)*SUMGRD ) + END IF + END IF + ! + IF ( FLOGRD(5,5) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%TAUWIX(GSEA) .NE. UNDEF ) THEN + SUMWT5(5) = SUMWT5(5) + WT + IF ( TAUWIXAUX .EQ. UNDEF ) THEN + TAUWIXAUX = WADATS(IGRID)%TAUWIX(GSEA)*WT + TAUWIYAUX = WADATS(IGRID)%TAUWIY(GSEA)*WT + ELSE + TAUWIXAUX = TAUWIXAUX + WADATS(IGRID)%TAUWIX(GSEA)*WT + TAUWIYAUX = TAUWIYAUX + WADATS(IGRID)%TAUWIY(GSEA)*WT END IF -! - IF ( PT2AUX(ISWLL) .NE. UNDEF ) THEN - IF ( PT2(ISEA,ISWLL) .EQ. UNDEF ) & - PT2(ISEA,ISWLL) = 0. - PT2(ISEA,ISWLL) = PT2(ISEA,ISWLL) + & - PT2AUX(ISWLL) / REAL( SUMWT4(14,ISWLL)*SUMGRD ) + END IF + END IF + ! + IF ( FLOGRD(5,6) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%TAUWNX(GSEA) .NE. UNDEF ) THEN + SUMWT5(6) = SUMWT5(6) + WT + IF ( TAUWNXAUX .EQ. UNDEF ) THEN + TAUWNXAUX = WADATS(IGRID)%TAUWNX(GSEA)*WT + TAUWNYAUX = WADATS(IGRID)%TAUWNY(GSEA)*WT + ELSE + TAUWNXAUX = TAUWNXAUX + WADATS(IGRID)%TAUWNX(GSEA)*WT + TAUWNYAUX = TAUWNYAUX + WADATS(IGRID)%TAUWNY(GSEA)*WT END IF -! - IF ( PEPAUX(ISWLL) .NE. UNDEF ) THEN - IF ( PEP(ISEA,ISWLL) .EQ. UNDEF ) & - PEP(ISEA,ISWLL) = 0. - PEP(ISEA,ISWLL) = PEP(ISEA,ISWLL) + & - PEPAUX(ISWLL) / REAL( SUMWT4(15,ISWLL)*SUMGRD ) + END IF + END IF + ! + DO ICAP = 1,4 + ! + IF ( FLOGRD(5,ICAP+6) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%WHITECAP(GSEA,ICAP) .NE. UNDEF ) THEN + SUMWTC(ICAP) = SUMWTC(ICAP) + WT + IF ( WHITECAPAUX(ICAP) .EQ. UNDEF ) THEN + WHITECAPAUX(ICAP) = WADATS(IGRID)%WHITECAP(GSEA,ICAP)& + *WT + ELSE + WHITECAPAUX(ICAP) = WHITECAPAUX(ICAP) + & + WADATS(IGRID)%WHITECAP(GSEA,ICAP)*WT + END IF END IF -! - END DO !/ ISWLL = 0, NOSWLL_MIN -! - IF ( PWSTAUX .NE. UNDEF ) THEN - PWSTAUX = PWSTAUX / SUMWT4(16,0) - IF ( PWST(ISEA) .EQ. UNDEF ) THEN - PWST(ISEA) = PWSTAUX / REAL( SUMGRD ) + END IF + ! + END DO + ! + ! Group 6 variables + ! + IF ( FLOGRD(6,1) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%SXX(GSEA) .NE. UNDEF ) THEN + SUMWT6(1) = SUMWT6(1) + WT + IF ( SXXAUX .EQ. UNDEF ) THEN + SXXAUX = WADATS(IGRID)%SXX(GSEA)*WT + SXYAUX = WADATS(IGRID)%SXY(GSEA)*WT + SYYAUX = WADATS(IGRID)%SYY(GSEA)*WT ELSE - PWST(ISEA) = PWST(ISEA) + PWSTAUX / REAL( SUMGRD ) + SXXAUX = SXXAUX + WADATS(IGRID)%SXX(GSEA)*WT + SXYAUX = SXYAUX + WADATS(IGRID)%SXY(GSEA)*WT + SYYAUX = SYYAUX + WADATS(IGRID)%SYY(GSEA)*WT END IF END IF -! -! Group 5 variables -! - IF ( USTAUX1 .NE. UNDEF ) THEN - USTAUX1 = USTAUX1 / SUMWT5(1) - USTAUX2 = USTAUX2 / SUMWT5(1) - IF ( UST(ISEA) .EQ. UNDEF ) THEN - UST(ISEA) = USTAUX1 / REAL( SUMGRD ) - USTDIR(ISEA) = USTAUX2 / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(6,2) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%TAUOX(GSEA) .NE. UNDEF ) THEN + SUMWT6(2) = SUMWT6(2) + WT + IF ( TAUOXAUX .EQ. UNDEF ) THEN + TAUOXAUX = WADATS(IGRID)%TAUOX(GSEA)*WT + TAUOYAUX = WADATS(IGRID)%TAUOY(GSEA)*WT ELSE - UST(ISEA) = UST(ISEA) + USTAUX1 / REAL( SUMGRD ) - USTDIR(ISEA) = USTDIR(ISEA) + USTAUX2 / REAL( SUMGRD ) + TAUOXAUX = TAUOXAUX + WADATS(IGRID)%TAUOX(GSEA)*WT + TAUOYAUX = TAUOYAUX + WADATS(IGRID)%TAUOY(GSEA)*WT END IF END IF -! - IF ( CHARNAUX .NE. UNDEF ) THEN - CHARNAUX = CHARNAUX / SUMWT5(2) - IF ( CHARN(ISEA) .EQ. UNDEF ) THEN - CHARN(ISEA) = CHARNAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(6,3) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%BHD(GSEA) .NE. UNDEF ) THEN + SUMWT6(3) = SUMWT6(3) + WT + IF ( BHDAUX .EQ. UNDEF ) THEN + BHDAUX = WADATS(IGRID)%BHD(GSEA)*WT ELSE - CHARN(ISEA) = CHARN(ISEA) + CHARNAUX / REAL( SUMGRD ) + BHDAUX = BHDAUX + WADATS(IGRID)%BHD(GSEA)*WT END IF END IF -! - IF ( CGEAUX .NE. UNDEF ) THEN - CGEAUX = CGEAUX / SUMWT5(3) - IF ( CGE(ISEA) .EQ. UNDEF ) THEN - CGE(ISEA) = CGEAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(6,4) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PHIOC(GSEA) .NE. UNDEF ) THEN + SUMWT6(4) = SUMWT6(4) + WT + IF ( PHIOCAUX .EQ. UNDEF ) THEN + PHIOCAUX = WADATS(IGRID)%PHIOC(GSEA)*WT ELSE - CGE(ISEA) = CGE(ISEA) + CGEAUX / REAL( SUMGRD ) + PHIOCAUX = PHIOCAUX + WADATS(IGRID)%PHIOC(GSEA)*WT END IF END IF -! - IF ( PHIAWAUX .NE. UNDEF ) THEN - PHIAWAUX = PHIAWAUX / SUMWT5(4) - IF ( PHIAW(ISEA) .EQ. UNDEF ) THEN - PHIAW(ISEA) = PHIAWAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(6,5) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%TUSX(GSEA) .NE. UNDEF ) THEN + SUMWT6(5) = SUMWT6(5) + WT + IF ( TUSXAUX .EQ. UNDEF ) THEN + TUSXAUX = WADATS(IGRID)%TUSX(GSEA)*WT + TUSYAUX = WADATS(IGRID)%TUSY(GSEA)*WT ELSE - PHIAW(ISEA) = PHIAW(ISEA) + PHIAWAUX / REAL( SUMGRD ) + TUSXAUX = TUSXAUX + WADATS(IGRID)%TUSX(GSEA)*WT + TUSYAUX = TUSYAUX + WADATS(IGRID)%TUSY(GSEA)*WT END IF END IF -! - IF ( TAUWIXAUX .NE. UNDEF ) THEN - TAUWIXAUX = TAUWIXAUX / SUMWT5(5) - TAUWIYAUX = TAUWIYAUX / SUMWT5(5) - IF ( TAUWIX(ISEA) .EQ. UNDEF ) THEN - TAUWIX(ISEA) = TAUWIXAUX / REAL( SUMGRD ) - TAUWIY(ISEA) = TAUWIYAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(6,6) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%USSX(GSEA) .NE. UNDEF ) THEN + SUMWT6(6) = SUMWT6(6) + WT + IF ( USSXAUX .EQ. UNDEF ) THEN + USSXAUX = WADATS(IGRID)%USSX(GSEA)*WT + USSYAUX = WADATS(IGRID)%USSY(GSEA)*WT ELSE - TAUWIX(ISEA) = TAUWIX(ISEA) + TAUWIXAUX / REAL( SUMGRD ) - TAUWIY(ISEA) = TAUWIY(ISEA) + TAUWIYAUX / REAL( SUMGRD ) + USSXAUX = USSXAUX + WADATS(IGRID)%USSX(GSEA)*WT + USSYAUX = USSYAUX + WADATS(IGRID)%USSY(GSEA)*WT END IF END IF -! - IF ( TAUWNXAUX .NE. UNDEF ) THEN - TAUWNXAUX = TAUWNXAUX / SUMWT5(6) - TAUWNYAUX = TAUWNYAUX / SUMWT5(6) - IF ( TAUWNX(ISEA) .EQ. UNDEF ) THEN - TAUWNX(ISEA) = TAUWNXAUX / REAL( SUMGRD ) - TAUWNY(ISEA) = TAUWNYAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(6,7) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PRMS(GSEA) .NE. UNDEF ) THEN + SUMWT6(7) = SUMWT6(7) + WT + IF ( PRMSAUX .EQ. UNDEF ) THEN + PRMSAUX = WADATS(IGRID)%PRMS(GSEA)*WT + TPMSAUX = WADATS(IGRID)%TPMS(GSEA)*WT ELSE - TAUWNX(ISEA) = TAUWNX(ISEA) + TAUWNXAUX / REAL( SUMGRD ) - TAUWNY(ISEA) = TAUWNY(ISEA) + TAUWNYAUX / REAL( SUMGRD ) + PRMSAUX = PRMSAUX + WADATS(IGRID)%PRMS(GSEA)*WT + TPMSAUX = TPMSAUX + WADATS(IGRID)%TPMS(GSEA)*WT END IF END IF -! - DO ICAP = 1,4 - IF ( WHITECAPAUX(ICAP) .NE. UNDEF ) THEN - WHITECAPAUX(ICAP) = WHITECAPAUX(ICAP) / SUMWTC(ICAP) - IF ( WHITECAP(ISEA,ICAP) .EQ. UNDEF ) THEN - WHITECAP(ISEA,ICAP) = WHITECAPAUX(ICAP) / REAL( SUMGRD ) - ELSE - WHITECAP(ISEA,ICAP) = WHITECAP(ISEA,ICAP) + & - WHITECAPAUX(ICAP) / REAL( SUMGRD ) - END IF + END IF + ! + IF ( FLOGRD(6,8) .AND. ACTIVE .AND. US3DF(1).GT.0 ) THEN + DO IK = US3DF(2),US3DF(3) + IF ( WADATS(IGRID)%US3D(GSEA,IK) .NE. UNDEF ) THEN + SUMWT68(IK) = SUMWT68(IK) + WT + IF ( US3DAUX(IK) .EQ. UNDEF ) US3DAUX(IK) = 0. + US3DAUX(IK) = US3DAUX(IK) + & + WADATS(IGRID)%US3D(GSEA,IK)*WT + END IF + IF ( WADATS(IGRID)%US3D(GSEA,NK+IK) .NE. UNDEF ) THEN + SUMWT68(NK+IK) = SUMWT68(NK+IK) + WT + IF ( US3DAUX(NK+IK) .EQ. UNDEF ) & + US3DAUX(NK+IK) = 0. + US3DAUX(NK+IK) = US3DAUX(NK+IK) + & + WADATS(IGRID)%US3D(GSEA,NK+IK)*WT END IF END DO -! -! Group 6 variables -! - IF ( SXXAUX .NE. UNDEF ) THEN - SXXAUX = SXXAUX / SUMWT6(1) - SXYAUX = SXYAUX / SUMWT6(1) - SYYAUX = SYYAUX / SUMWT6(1) - IF ( SXX(ISEA) .EQ. UNDEF ) THEN - SXX(ISEA) = SXXAUX / REAL( SUMGRD ) - SXY(ISEA) = SXYAUX / REAL( SUMGRD ) - SYY(ISEA) = SYYAUX / REAL( SUMGRD ) - ELSE - SXX(ISEA) = SXX(ISEA) + SXXAUX / REAL( SUMGRD ) - SXY(ISEA) = SXY(ISEA) + SXYAUX / REAL( SUMGRD ) - SYY(ISEA) = SYY(ISEA) + SYYAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(6,9) .AND. ACTIVE .AND. P2MSF(1).GT.0) THEN + DO IK = P2MSF(2),P2MSF(3) + IF ( WADATS(IGRID)%P2SMS(GSEA,IK) .NE. UNDEF ) THEN + SUMWT69(IK) = SUMWT69(IK) + WT + IF ( P2SMSAUX(IK) .EQ. UNDEF ) P2SMSAUX(IK) = 0. + P2SMSAUX(IK) = P2SMSAUX(IK) + & + WADATS(IGRID)%P2SMS(GSEA,IK)*WT END IF + END DO + END IF + ! + IF ( FLOGRD(6,10) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%TAUICE(GSEA,1) .NE. UNDEF ) THEN + SUMWT6(10) = SUMWT6(10) + WT + IF ( TAUICEAUX(1) .EQ. UNDEF ) TAUICEAUX(1) = 0. + IF ( TAUICEAUX(2) .EQ. UNDEF ) TAUICEAUX(2) = 0. + TAUICEAUX(1) = TAUICEAUX(1) + & + WADATS(IGRID)%TAUICE(GSEA,1)*WT + TAUICEAUX(2) = TAUICEAUX(2) + & + WADATS(IGRID)%TAUICE(GSEA,2)*WT END IF -! - IF ( TAUOXAUX .NE. UNDEF ) THEN - TAUOXAUX = TAUOXAUX / SUMWT6(2) - TAUOYAUX = TAUOYAUX / SUMWT6(2) - IF ( TAUOX(ISEA) .EQ. UNDEF ) THEN - TAUOX(ISEA) = TAUOXAUX / REAL( SUMGRD ) - TAUOY(ISEA) = TAUOYAUX / REAL( SUMGRD ) - ELSE - TAUOX(ISEA) = TAUOX(ISEA) + TAUOXAUX / REAL( SUMGRD ) - TAUOY(ISEA) = TAUOY(ISEA) + TAUOYAUX / REAL( SUMGRD ) - END IF + END IF + ! + IF ( FLOGRD(6,11) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PHICE(GSEA) .NE. UNDEF ) THEN + SUMWT6(11) = SUMWT6(11) + WT + IF ( PHICEAUX.EQ.UNDEF ) PHICEAUX = 0. + PHICEAUX = PHICEAUX + WADATS(IGRID)%PHICE(GSEA)*WT END IF -! - IF ( BHDAUX .NE. UNDEF ) THEN - BHDAUX = BHDAUX / SUMWT6(3) - IF ( BHD(ISEA) .EQ. UNDEF ) THEN - BHD(ISEA) = BHDAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(6,12) .AND. ACTIVE .AND. USSPF(1).GT.0 ) THEN + DO IK = 1,USSPF(2) + IF ( WADATS(IGRID)%USSP(GSEA,IK) .NE. UNDEF ) THEN + SUMWT612(IK) = SUMWT612(IK) + WT + IF ( USSPAUX(IK) .EQ. UNDEF ) USSPAUX(IK) = 0. + USSPAUX(IK) = USSPAUX(IK) + & + WADATS(IGRID)%USSP(GSEA,IK)*WT + END IF + IF ( WADATS(IGRID)%USSP(GSEA,NK+IK) .NE. UNDEF ) THEN + SUMWT612(NK+IK) = SUMWT612(NK+IK) + WT + IF ( USSPAUX(NK+IK) .EQ. UNDEF ) & + USSPAUX(NK+IK) = 0. + USSPAUX(NK+IK) = USSPAUX(NK+IK) + & + WADATS(IGRID)%USSP(GSEA,NK+IK)*WT + END IF + END DO + END IF + ! + IF ( FLOGRD(6,13) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%TAUOCX(GSEA) .NE. UNDEF ) THEN + SUMWT6(13) = SUMWT6(13) + WT + IF ( TAUOCXAUX .EQ. UNDEF ) THEN + TAUOCXAUX = WADATS(IGRID)%TAUOCX(GSEA)*WT + TAUOCYAUX = WADATS(IGRID)%TAUOCY(GSEA)*WT ELSE - BHD(ISEA) = BHD(ISEA) + BHDAUX / REAL( SUMGRD ) + TAUOCXAUX = TAUOCXAUX + WADATS(IGRID)%TAUOCX(GSEA)*WT + TAUOCYAUX = TAUOCYAUX + WADATS(IGRID)%TAUOCY(GSEA)*WT END IF END IF -! - IF ( PHIOCAUX .NE. UNDEF ) THEN - PHIOCAUX = PHIOCAUX / SUMWT6(4) - IF ( PHIOC(ISEA) .EQ. UNDEF ) THEN - PHIOC(ISEA) = PHIOCAUX / REAL( SUMGRD ) + END IF + ! + ! Group 7 variables + ! + IF ( FLOGRD(7,1) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%ABA(GSEA) .NE. UNDEF ) THEN + SUMWT7(1) = SUMWT7(1) + WT + IF ( ABAAUX .EQ. UNDEF ) THEN + ABAAUX = WADATS(IGRID)%ABA(GSEA)*WT + ABDAUX = WADATS(IGRID)%ABD(GSEA)*WT ELSE - PHIOC(ISEA) = PHIOC(ISEA) + PHIOCAUX / REAL( SUMGRD ) + ABAAUX = ABAAUX + WADATS(IGRID)%ABA(GSEA)*WT + ABDAUX = ABDAUX + WADATS(IGRID)%ABD(GSEA)*WT END IF END IF -! - IF ( TUSXAUX .NE. UNDEF ) THEN - TUSXAUX = TUSXAUX / SUMWT6(5) - TUSYAUX = TUSYAUX / SUMWT6(5) - IF ( TUSX(ISEA) .EQ. UNDEF ) THEN - TUSX(ISEA) = TUSXAUX / REAL( SUMGRD ) - TUSY(ISEA) = TUSYAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(7,2) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%ABA(GSEA) .NE. UNDEF ) THEN + SUMWT7(2) = SUMWT7(2) + WT + IF ( UBAAUX .EQ. UNDEF ) THEN + UBAAUX = WADATS(IGRID)%UBA(GSEA)*WT + UBDAUX = WADATS(IGRID)%UBD(GSEA)*WT ELSE - TUSX(ISEA) = TUSX(ISEA) + TUSXAUX / REAL( SUMGRD ) - TUSY(ISEA) = TUSY(ISEA) + TUSYAUX / REAL( SUMGRD ) + UBAAUX = UBAAUX + WADATS(IGRID)%UBA(GSEA)*WT + UBDAUX = UBDAUX + WADATS(IGRID)%UBD(GSEA)*WT END IF END IF -! - IF ( USSXAUX .NE. UNDEF ) THEN - USSXAUX = USSXAUX / SUMWT6(6) - USSYAUX = USSYAUX / SUMWT6(6) - IF ( USSX(ISEA) .EQ. UNDEF ) THEN - USSX(ISEA) = USSXAUX / REAL( SUMGRD ) - USSY(ISEA) = USSYAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(7,3) .AND. ACTIVE ) THEN + DO IBED = 1, 3 + IF ( WADATS(IGRID)%BEDFORMS(GSEA,IBED) .NE. UNDEF ) THEN + SUMWTB(IBED) = SUMWTB(IBED) + WT + IF ( BEDFORMSAUX(IBED) .EQ. UNDEF ) THEN + BEDFORMSAUX(IBED) = WADATS(IGRID)%BEDFORMS(GSEA,IBED)& + *WT + ELSE + BEDFORMSAUX(IBED) = BEDFORMSAUX(IBED) + & + WADATS(IGRID)%BEDFORMS(GSEA,IBED)*WT + END IF + END IF + END DO + END IF + ! + IF ( FLOGRD(7,4) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%PHIBBL(GSEA) .NE. UNDEF ) THEN + SUMWT7(4) = SUMWT7(4) + WT + IF ( PHIBBLAUX .EQ. UNDEF ) THEN + PHIBBLAUX = WADATS(IGRID)%PHIBBL(GSEA)*WT ELSE - USSX(ISEA) = USSX(ISEA) + USSXAUX / REAL( SUMGRD ) - USSY(ISEA) = USSY(ISEA) + USSYAUX / REAL( SUMGRD ) + PHIBBLAUX = PHIBBLAUX + WADATS(IGRID)%PHIBBL(GSEA)*WT END IF END IF -! - IF ( PRMSAUX .NE. UNDEF ) THEN - PRMSAUX = PRMSAUX / SUMWT6(7) - TPMSAUX = TPMSAUX / SUMWT6(7) - IF ( PRMS(ISEA) .EQ. UNDEF ) THEN - PRMS(ISEA) = PRMSAUX / REAL( SUMGRD ) - TPMS(ISEA) = TPMSAUX / REAL( SUMGRD ) + END IF + ! + IF ( FLOGRD(7,5) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%TAUBBL(GSEA,1) .NE. UNDEF ) THEN + SUMWT7(5) = SUMWT7(5) + WT + IF ( TAUBBLAUX(1) .EQ. UNDEF ) THEN + TAUBBLAUX(1) = WADATS(IGRID)%TAUBBL(GSEA,1)*WT + TAUBBLAUX(2) = WADATS(IGRID)%TAUBBL(GSEA,2)*WT ELSE - PRMS(ISEA) = PRMS(ISEA) + PRMSAUX / REAL( SUMGRD ) - TPMS(ISEA) = TPMS(ISEA) + TPMSAUX / REAL( SUMGRD ) + TAUBBLAUX(1) = TAUBBLAUX(1) + & + WADATS(IGRID)%TAUBBL(GSEA,1)*WT + TAUBBLAUX(2) = TAUBBLAUX(2) + & + WADATS(IGRID)%TAUBBL(GSEA,2)*WT END IF END IF -! - IF ( US3DF(1).GT.0 ) THEN - DO IK = US3DF(2),US3DF(3) - IF ( US3DAUX(IK) .NE. UNDEF ) THEN - IF ( US3D(ISEA,IK) .EQ. UNDEF ) US3D(ISEA,IK) = 0. - US3D(ISEA,IK) = US3D(ISEA,IK) + & - US3DAUX(IK) / REAL( SUMWT68(IK) * SUMGRD ) - END IF - IF ( US3DAUX(NK+IK) .NE. UNDEF ) THEN - IF ( US3D(ISEA,NK+IK) .EQ. UNDEF ) & - US3D(ISEA,NK+IK) = 0. - US3D(ISEA,NK+IK) = US3D(ISEA,NK+IK) + & - US3DAUX(NK+IK) / REAL( SUMWT68(NK+IK) * SUMGRD ) - END IF - END DO + END IF + ! + ! Group 8 variables + ! + IF ( FLOGRD(8,1) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%MSSX(GSEA) .NE. UNDEF ) THEN + SUMWT8(1) = SUMWT8(1) + WT + IF ( MSSXAUX .EQ. UNDEF ) MSSXAUX = 0. + IF ( MSSYAUX .EQ. UNDEF ) MSSYAUX = 0. + MSSXAUX = MSSXAUX + WADATS(IGRID)%MSSX(GSEA)*WT + MSSYAUX = MSSYAUX + WADATS(IGRID)%MSSY(GSEA)*WT END IF -! - IF ( P2MSF(1).GT.0 ) THEN - DO IK = P2MSF(2),P2MSF(3) - IF ( P2SMSAUX(IK) .NE. UNDEF ) THEN - IF ( P2SMS(ISEA,IK).EQ.UNDEF ) P2SMS(ISEA,IK) = 0. - P2SMS(ISEA,IK) = P2SMS(ISEA,IK) + & - P2SMSAUX(IK) / REAL( SUMWT69(IK) * SUMGRD ) - END IF - END DO + END IF + ! + IF ( FLOGRD(8,2) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%MSCX(GSEA) .NE. UNDEF ) THEN + SUMWT8(2) = SUMWT8(2) + WT + IF ( MSCXAUX .EQ. UNDEF ) MSCXAUX = 0. + IF ( MSCYAUX .EQ. UNDEF ) MSCYAUX = 0. + MSCXAUX = MSCXAUX + WADATS(IGRID)%MSCX(GSEA)*WT + MSCYAUX = MSCYAUX + WADATS(IGRID)%MSCY(GSEA)*WT END IF -! - IF ( TAUICEAUX(1) .NE. UNDEF ) THEN - IF ( TAUICE(ISEA,1) .EQ. UNDEF ) TAUICE(ISEA,1) = 0. - IF ( TAUICE(ISEA,2) .EQ. UNDEF ) TAUICE(ISEA,2) = 0. - TAUICE(ISEA,1) = TAUICE(ISEA,1) + & - TAUICEAUX(1) / REAL( SUMWT6(10) * SUMGRD ) - TAUICE(ISEA,2) = TAUICE(ISEA,2) + & - TAUICEAUX(2) / REAL( SUMWT6(10) * SUMGRD ) + END IF + ! + IF ( FLOGRD(8,3) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%MSSD(GSEA) .NE. UNDEF ) THEN + SUMWT8(3) = SUMWT8(3) + WT + IF ( MSSDAUX1 .EQ. UNDEF ) MSSDAUX1 = 0. + IF ( MSSDAUX2 .EQ. UNDEF ) MSSDAUX2 = 0. + MSSDAUX1 = MSSDAUX1 + & + COS ( WADATS(IGRID)%MSSD(GSEA) )*WT + MSSDAUX2 = MSSDAUX2 + & + SIN ( WADATS(IGRID)%MSSD(GSEA) )*WT END IF -! - IF ( PHICEAUX .NE. UNDEF ) THEN - IF ( PHICE(ISEA) .EQ. UNDEF ) PHICE(ISEA) = 0. - PHICE(ISEA) = PHICE(ISEA) + & - PHICEAUX / REAL( SUMWT6(11) * SUMGRD ) + END IF + ! + IF ( FLOGRD(8,4) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%MSCD(GSEA) .NE. UNDEF ) THEN + SUMWT8(4) = SUMWT8(4) + WT + IF ( MSCDAUX1 .EQ. UNDEF ) MSCDAUX1 = 0. + IF ( MSCDAUX2 .EQ. UNDEF ) MSCDAUX2 = 0. + MSCDAUX1 = MSCDAUX1 + & + COS ( WADATS(IGRID)%MSCD(GSEA) )*WT + MSCDAUX2 = MSCDAUX2 + & + SIN ( WADATS(IGRID)%MSCD(GSEA) )*WT END IF -! - IF ( USSPF(1).GT.0 ) THEN - DO IK = 1,USSPF(2) - IF ( USSPAUX(IK) .NE. UNDEF ) THEN - IF ( USSP(ISEA,IK) .EQ. UNDEF ) USSP(ISEA,IK) = 0. - USSP(ISEA,IK) = USSP(ISEA,IK) + & - USSPAUX(IK) / REAL( SUMWT612(IK) * SUMGRD ) - END IF - IF ( USSPAUX(NK+IK) .NE. UNDEF ) THEN - IF ( USSP(ISEA,NK+IK) .EQ. UNDEF ) & - USSP(ISEA,NK+IK) = 0. - USSP(ISEA,NK+IK) = USSP(ISEA,NK+IK) + & - USSPAUX(NK+IK) / REAL( SUMWT612(NK+IK) * SUMGRD ) - END IF - END DO + END IF + ! + IF ( FLOGRD(8,5) .AND. ACTIVE ) THEN + IF ( WADATS(IGRID)%QP(GSEA) .NE. UNDEF ) THEN + SUMWT8(5) = SUMWT8(5) + WT + IF ( QPAUX .EQ. UNDEF ) QPAUX = 0. + QPAUX = QPAUX + WADATS(IGRID)%QP(GSEA)*WT END IF -! - IF ( TAUOCXAUX .NE. UNDEF ) THEN - TAUOCXAUX = TAUOCXAUX / SUMWT6(13) - TAUOCYAUX = TAUOCYAUX / SUMWT6(13) - IF ( TAUOCX(ISEA) .EQ. UNDEF ) THEN - TAUOCX(ISEA) = TAUOCXAUX / REAL( SUMGRD ) - TAUOCY(ISEA) = TAUOCYAUX / REAL( SUMGRD ) + END IF + ! + ! End of loop through the points per grid to obtain interpolated values + END DO !/ IPTS = 1, ... + ! + ! Save temp. interpolated variables in proper variables + ! (weighted by the number of grids) + ! + ! + ! Group 1 variables + ! + IF ( DWAUX .NE. UNDEF ) THEN + DWAUX = DWAUX / SUMWT1(1) + IF ( DW(ISEA) .EQ. UNDEF ) THEN + DW(ISEA) = DWAUX / REAL( SUMGRD ) + ELSE + DW(ISEA) = DW(ISEA) + DWAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( CXAUX .NE. UNDEF ) THEN + CXAUX = CXAUX / SUMWT1(2) + CYAUX = CYAUX / SUMWT1(2) + IF ( CX(ISEA) .EQ. UNDEF ) THEN + CX(ISEA) = CXAUX / REAL( SUMGRD ) + CY(ISEA) = CYAUX / REAL( SUMGRD ) + ELSE + CX(ISEA) = CX(ISEA) + CXAUX / REAL( SUMGRD ) + CY(ISEA) = CY(ISEA) + CYAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( UAAUX .NE. UNDEF ) THEN + UAAUX = UAAUX / SUMWT1(3) + UDAUX = UDAUX / SUMWT1(3) + IF ( UA(ISEA) .EQ. UNDEF ) THEN + UA(ISEA) = UAAUX / REAL( SUMGRD ) + UD(ISEA) = UDAUX / REAL( SUMGRD ) + ELSE + UA(ISEA) = UA(ISEA) + UAAUX / REAL( SUMGRD ) + UD(ISEA) = UD(ISEA) + UDAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( ASAUX .NE. UNDEF ) THEN + ASAUX = ASAUX / SUMWT1(4) + IF ( AS(ISEA) .EQ. UNDEF ) THEN + AS(ISEA) = ASAUX / REAL( SUMGRD ) + ELSE + AS(ISEA) = AS(ISEA) + ASAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( WLVAUX .NE. UNDEF ) THEN + WLVAUX = WLVAUX / SUMWT1(5) + IF ( WLV(ISEA) .EQ. UNDEF ) THEN + WLV(ISEA) = WLVAUX / REAL( SUMGRD ) + ELSE + WLV(ISEA) = WLV(ISEA) + WLVAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( ICEAUX .NE. UNDEF ) THEN + ICEAUX = ICEAUX / SUMWT1(6) + IF ( ICE(ISEA) .EQ. UNDEF ) THEN + ICE(ISEA) = ICEAUX / REAL( SUMGRD ) + ELSE + ICE(ISEA) = ICE(ISEA) + ICEAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( BERGAUX .NE. UNDEF ) THEN + BERGAUX = BERGAUX / SUMWT1(7) + IF ( BERG(ISEA) .EQ. UNDEF ) THEN + BERG(ISEA) = BERGAUX / REAL( SUMGRD ) + ELSE + BERG(ISEA) = BERG(ISEA) + BERGAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( TAUAAUX .NE. UNDEF ) THEN + TAUAAUX = TAUAAUX / SUMWT1(8) + TAUADIRAUX = TAUADIRAUX / SUMWT1(8) + IF ( TAUA(ISEA) .EQ. UNDEF ) THEN + TAUA(ISEA) = TAUAAUX / REAL( SUMGRD ) + TAUADIR(ISEA) = TAUADIRAUX / REAL( SUMGRD ) + ELSE + TAUA(ISEA) = TAUA(ISEA) + TAUAAUX / REAL( SUMGRD ) + TAUADIR(ISEA) = TAUADIR(ISEA) + TAUADIRAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( RHOAIRAUX .NE. UNDEF ) THEN + RHOAIRAUX = RHOAIRAUX / SUMWT1(9) + IF ( RHOAIR(ISEA) .EQ. UNDEF ) THEN + RHOAIR(ISEA) = RHOAIRAUX / REAL( SUMGRD ) + ELSE + RHOAIR(ISEA) = RHOAIR(ISEA) + RHOAIRAUX / REAL( SUMGRD ) + END IF + END IF + ! +#ifdef W3_BT4 + IF ( SED_D50AUX .NE. UNDEF ) THEN + SED_D50AUX = SED_D50AUX / SUMWT1(10) + IF ( SED_D50(ISEA) .EQ. UNDEF ) THEN + SED_D50(ISEA) = SED_D50AUX / REAL( SUMGRD ) + ELSE + SED_D50(ISEA) = SED_D50(ISEA) + SED_D50AUX / REAL( SUMGRD ) + END IF + END IF +#endif + ! +#ifdef W3_IS2 + IF ( ICEHAUX .NE. UNDEF ) THEN + ICEHAUX = ICEHAUX / SUMWT1(11) + IF ( ICEH(ISEA) .EQ. UNDEF ) THEN + ICEH(ISEA) = ICEHAUX / REAL( SUMGRD ) + ELSE + ICEH(ISEA) = ICEH(ISEA) + ICEHAUX / REAL( SUMGRD ) + END IF + END IF +#endif + ! +#ifdef W3_IS2 + IF ( ICEFAUX .NE. UNDEF ) THEN + ICEFAUX = ICEFAUX / SUMWT1(12) + IF ( ICEF(ISEA) .EQ. UNDEF ) THEN + ICEF(ISEA) = ICEFAUX / REAL( SUMGRD ) + ELSE + ICEF(ISEA) = ICEF(ISEA) + ICEFAUX / REAL( SUMGRD ) + END IF + END IF +#endif + ! + ! Group 2 variables + ! + IF ( HSAUX .NE. UNDEF ) THEN + HSAUX = HSAUX / SUMWT2(1) + IF ( HS(ISEA) .EQ. UNDEF ) THEN + HS(ISEA) = HSAUX / REAL( SUMGRD ) + ELSE + HS(ISEA) = HS(ISEA) + HSAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( WLMAUX .NE. UNDEF ) THEN + WLMAUX = WLMAUX / SUMWT2(2) + IF ( WLM(ISEA) .EQ. UNDEF ) THEN + WLM(ISEA) = WLMAUX / REAL( SUMGRD ) + ELSE + WLM(ISEA) = WLM(ISEA) + WLMAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( T02AUX .NE. UNDEF ) THEN + T02AUX = T02AUX / SUMWT2(3) + IF ( T02(ISEA) .EQ. UNDEF ) THEN + T02(ISEA) = T02AUX / REAL( SUMGRD ) + ELSE + T02(ISEA) = T02(ISEA) + T02AUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( T0M1AUX .NE. UNDEF ) THEN + T0M1AUX = T0M1AUX / SUMWT2(4) + IF ( T0M1(ISEA) .EQ. UNDEF ) THEN + T0M1(ISEA) = T0M1AUX / REAL( SUMGRD ) + ELSE + T0M1(ISEA) = T0M1(ISEA) + T0M1AUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( T01AUX .NE. UNDEF ) THEN + T01AUX = T01AUX / SUMWT2(5) + IF ( T01(ISEA) .EQ. UNDEF ) THEN + T01(ISEA) = T01AUX / REAL( SUMGRD ) + ELSE + T01(ISEA) = T01(ISEA) + T01AUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( FP0AUX .NE. UNDEF ) THEN + FP0AUX = FP0AUX / SUMWT2(6) + IF ( FP0(ISEA) .EQ. UNDEF ) THEN + FP0(ISEA) = FP0AUX / REAL( SUMGRD ) + ELSE + FP0(ISEA) = FP0(ISEA) + FP0AUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( THMAUX1 .NE. UNDEF ) THEN + THMAUX1 = THMAUX1 / SUMWT2(7) + THMAUX2 = THMAUX2 / SUMWT2(7) + IF ( THM(ISEA) .EQ. UNDEF ) THEN + THMAUX1 = THMAUX1 / REAL( SUMGRD ) + THMAUX2 = THMAUX2 / REAL( SUMGRD ) + THM(ISEA) = ATAN2 ( THMAUX2, THMAUX1 ) + ELSE + THMAUX1 = THMAUX1 / REAL( SUMGRD ) + COS ( THM(ISEA) ) + THMAUX2 = THMAUX2 / REAL( SUMGRD ) + SIN ( THM(ISEA) ) + THM(ISEA) = ATAN2 ( THMAUX2, THMAUX1 ) + END IF + END IF + ! + IF ( THSAUX .NE. UNDEF ) THEN + THSAUX = THSAUX / SUMWT2(8) + IF ( THS(ISEA) .EQ. UNDEF ) THEN + THS(ISEA) = THSAUX / REAL( SUMGRD ) + ELSE + THS(ISEA) = THS(ISEA) + THSAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( THP0AUX1 .NE. UNDEF ) THEN + THP0AUX1 = THP0AUX1 / SUMWT2(9) + THP0AUX2 = THP0AUX2 / SUMWT2(9) + IF ( THP0(ISEA) .EQ. UNDEF ) THEN + THP0AUX1 = THP0AUX1 / REAL( SUMGRD ) + THP0AUX2 = THP0AUX2 / REAL( SUMGRD ) + THP0(ISEA) = ATAN2 ( THP0AUX2, THP0AUX1 ) + ELSE + THP0AUX1 = THP0AUX1 / REAL( SUMGRD ) + COS ( THP0(ISEA) ) + THP0AUX2 = THP0AUX2 / REAL( SUMGRD ) + SIN ( THP0(ISEA) ) + THP0(ISEA) = ATAN2 ( THP0AUX2, THP0AUX1 ) + END IF + END IF + ! + IF ( HSIGAUX .NE. UNDEF ) THEN + IF ( HSIG(ISEA) .EQ. UNDEF ) HSIG(ISEA) = 0. + HSIG(ISEA) = HSIG(ISEA) + & + HSIGAUX / REAL( SUMWT2(10)*SUMGRD ) + END IF + ! + IF ( STMAXEAUX .NE. UNDEF ) THEN + IF ( STMAXE(ISEA) .EQ. UNDEF ) STMAXE(ISEA) = 0. + STMAXE(ISEA) = STMAXE(ISEA) + & + STMAXEAUX / REAL( SUMWT2(11) * SUMGRD ) + END IF + ! + IF ( STMAXDAUX .NE. UNDEF ) THEN + IF ( STMAXD(ISEA) .EQ. UNDEF ) STMAXD(ISEA) = 0. + STMAXD(ISEA) = STMAXD(ISEA) + & + STMAXDAUX / REAL( SUMWT2(12) * SUMGRD ) + END IF + ! + IF ( HMAXEAUX .NE. UNDEF ) THEN + IF ( HMAXE(ISEA) .EQ. UNDEF ) HMAXE(ISEA) = 0. + HMAXE(ISEA) = HMAXE(ISEA) + & + HMAXEAUX / REAL( SUMWT2(13) * SUMGRD ) + END IF + ! + IF ( HCMAXEAUX .NE. UNDEF ) THEN + IF ( HCMAXE(ISEA) .EQ. UNDEF ) HCMAXE(ISEA) = 0. + HCMAXE(ISEA) = HCMAXE(ISEA) + & + HCMAXEAUX / REAL( SUMWT2(14) * SUMGRD ) + END IF + ! + IF ( HMAXDAUX .NE. UNDEF ) THEN + IF ( HMAXD(ISEA) .EQ. UNDEF ) HMAXD(ISEA) = 0. + HMAXD(ISEA) = HMAXD(ISEA) + & + HMAXDAUX / REAL( SUMWT2(15) * SUMGRD ) + END IF + ! + IF ( HCMAXDAUX .NE. UNDEF ) THEN + IF ( HCMAXD(ISEA) .EQ. UNDEF ) HCMAXD(ISEA) = 0. + HCMAXD(ISEA) = HCMAXD(ISEA) + & + HCMAXDAUX / REAL( SUMWT2(16) * SUMGRD ) + END IF + ! + IF ( WBTAUX .NE. UNDEF ) THEN + IF ( WBT(ISEA) .EQ. UNDEF ) WBT(ISEA) = 0. + WBT(ISEA) = WBT(ISEA) + & + WBTAUX / REAL( SUMWT2(17)*SUMGRD ) + END IF + ! + IF ( WNMEANAUX .NE. UNDEF ) THEN + IF ( WNMEAN(ISEA) .EQ. UNDEF ) WNMEAN(ISEA) = 0. + WNMEAN(ISEA) = WNMEAN(ISEA) + & + WNMEANAUX / REAL( SUMWT2(19)*SUMGRD ) + END IF + ! + ! Group 3 variables + ! + IF ( E3DF(1,1).GT.0 ) THEN + DO IFREQ = E3DF(2,1),E3DF(3,1) + IF ( EFAUX(IFREQ) .NE. UNDEF ) THEN + EFAUX(IFREQ) = EFAUX(IFREQ) / SUMWT3A(IFREQ) + IF ( EF(ISEA,IFREQ) .EQ. UNDEF ) THEN + EF(ISEA,IFREQ) = EFAUX(IFREQ) / REAL( SUMGRD ) ELSE - TAUOCX(ISEA) = TAUOCX(ISEA) + TAUOCXAUX / REAL( SUMGRD ) - TAUOCY(ISEA) = TAUOCY(ISEA) + TAUOCYAUX / REAL( SUMGRD ) + EF(ISEA,IFREQ) = EF(ISEA,IFREQ) + & + EFAUX(IFREQ) / REAL( SUMGRD ) END IF END IF -! -! Group 7 variables -! - IF ( ABAAUX .NE. UNDEF ) THEN - ABAAUX = ABAAUX / SUMWT7(1) - ABDAUX = ABDAUX / SUMWT7(1) - IF ( ABA(ISEA) .EQ. UNDEF ) THEN - ABA(ISEA) = ABAAUX / REAL( SUMGRD ) - ABD(ISEA) = ABDAUX / REAL( SUMGRD ) + END DO + END IF + ! + IF ( E3DF(1,2).GT.0 ) THEN + DO IFREQ = E3DF(2,2),E3DF(3,2) + IF ( TH1MAUX(IFREQ) .NE. UNDEF ) THEN + TH1MAUX(IFREQ) = TH1MAUX(IFREQ) / SUMWT3B(IFREQ) + IF ( TH1M(ISEA,IFREQ) .EQ. UNDEF ) THEN + TH1M(ISEA,IFREQ) = TH1MAUX(IFREQ) / REAL( SUMGRD ) ELSE - ABA(ISEA) = ABA(ISEA) + ABAAUX / REAL( SUMGRD ) - ABD(ISEA) = ABD(ISEA) + ABDAUX / REAL( SUMGRD ) + TH1M(ISEA,IFREQ) = TH1M(ISEA,IFREQ) + & + TH1MAUX(IFREQ) / REAL( SUMGRD ) END IF END IF -! - IF ( UBAAUX .NE. UNDEF ) THEN - UBAAUX = UBAAUX / SUMWT7(2) - UBDAUX = UBDAUX / SUMWT7(2) - IF ( UBA(ISEA) .EQ. UNDEF ) THEN - UBA(ISEA) = UBAAUX / REAL( SUMGRD ) - UBD(ISEA) = UBDAUX / REAL( SUMGRD ) + END DO + END IF + ! + IF ( E3DF(1,3).GT.0 ) THEN + DO IFREQ = E3DF(2,3),E3DF(3,3) + IF ( STH1MAUX(IFREQ) .NE. UNDEF ) THEN + STH1MAUX(IFREQ) = STH1MAUX(IFREQ) / SUMWT3C(IFREQ) + IF ( STH1M(ISEA,IFREQ) .EQ. UNDEF ) THEN + STH1M(ISEA,IFREQ) = STH1MAUX(IFREQ) / REAL( SUMGRD ) ELSE - UBA(ISEA) = UBA(ISEA) + UBAAUX / REAL( SUMGRD ) - UBD(ISEA) = UBD(ISEA) + UBDAUX / REAL( SUMGRD ) + STH1M(ISEA,IFREQ) = STH1M(ISEA,IFREQ) + & + STH1MAUX(IFREQ) / REAL( SUMGRD ) END IF END IF -! - DO IBED = 1,3 - IF ( BEDFORMSAUX(IBED) .NE. UNDEF ) THEN - BEDFORMSAUX(IBED) = BEDFORMSAUX(IBED) / SUMWTB(IBED) - IF ( BEDFORMS(ISEA,IBED) .EQ. UNDEF ) THEN - BEDFORMS(ISEA,IBED) = BEDFORMSAUX(IBED) / REAL( SUMGRD ) - ELSE - BEDFORMS(ISEA,IBED) = BEDFORMS(ISEA,IBED) + & - BEDFORMSAUX(IBED) / REAL( SUMGRD ) - END IF - END IF - END DO -! - IF ( PHIBBLAUX .NE. UNDEF ) THEN - PHIBBLAUX = PHIBBLAUX / SUMWT7(4) - IF ( PHIBBL(ISEA) .EQ. UNDEF ) THEN - PHIBBL(ISEA) = PHIBBLAUX / REAL( SUMGRD ) + END DO + END IF + ! + IF ( E3DF(1,4).GT.0 ) THEN + DO IFREQ = E3DF(2,4),E3DF(3,4) + IF ( TH2MAUX(IFREQ) .NE. UNDEF ) THEN + TH2MAUX(IFREQ) = TH2MAUX(IFREQ) / SUMWT3D(IFREQ) + IF ( TH2M(ISEA,IFREQ) .EQ. UNDEF ) THEN + TH2M(ISEA,IFREQ) = TH2MAUX(IFREQ) / REAL( SUMGRD ) ELSE - PHIBBL(ISEA) = PHIBBL(ISEA) + PHIBBLAUX / REAL( SUMGRD ) + TH2M(ISEA,IFREQ) = TH2M(ISEA,IFREQ) + & + TH2MAUX(IFREQ) / REAL( SUMGRD ) END IF END IF -! - IF ( TAUBBLAUX(1) .NE. UNDEF ) THEN - TAUBBLAUX(1) = TAUBBLAUX(1) / SUMWT7(5) - TAUBBLAUX(2) = TAUBBLAUX(2) / SUMWT7(5) - IF ( TAUBBL(ISEA,1) .EQ. UNDEF ) THEN - TAUBBL(ISEA,1) = TAUBBLAUX(1) / REAL( SUMGRD ) - TAUBBL(ISEA,2) = TAUBBLAUX(2) / REAL( SUMGRD ) + END DO + END IF + ! + IF ( E3DF(1,5).GT.0 ) THEN + DO IFREQ = E3DF(2,5),E3DF(3,5) + IF ( STH2MAUX(IFREQ) .NE. UNDEF ) THEN + STH2MAUX(IFREQ) = STH2MAUX(IFREQ) / SUMWT3E(IFREQ) + IF ( STH2M(ISEA,IFREQ) .EQ. UNDEF ) THEN + STH2M(ISEA,IFREQ) = STH2MAUX(IFREQ) / REAL( SUMGRD ) ELSE - TAUBBL(ISEA,1) = TAUBBL(ISEA,1) + & - TAUBBLAUX(1) / REAL( SUMGRD ) - TAUBBL(ISEA,2) = TAUBBL(ISEA,2) + & - TAUBBLAUX(2) / REAL( SUMGRD ) + STH2M(ISEA,IFREQ) = STH2M(ISEA,IFREQ) + & + STH2MAUX(IFREQ) / REAL( SUMGRD ) END IF END IF -! -! Group 8 variables -! - IF ( MSSXAUX .NE. UNDEF ) THEN - IF ( MSSX(ISEA) .EQ. UNDEF ) MSSX(ISEA) = 0. - MSSX(ISEA) = MSSX(ISEA) + & - MSSXAUX / REAL( SUMWT8(1)*SUMGRD ) + END DO + END IF + ! + DO IK = 1,NK + IF ( WNAUX(IK) .NE. UNDEF ) THEN + WNAUX(IK) = WNAUX(IK) / SUMWT3F(IK) + IF ( WN(IK,ISEA) .EQ. UNDEF ) THEN + WN(IK,ISEA) = WNAUX(IK) / REAL( SUMGRD ) + ELSE + WN(IK,ISEA) = WN(IK,ISEA) + & + WNAUX(IK) / REAL( SUMGRD ) END IF -! - IF ( MSSYAUX .NE. UNDEF ) THEN - IF ( MSSY(ISEA) .EQ. UNDEF ) MSSY(ISEA) = 0. - MSSY(ISEA) = MSSY(ISEA) + & - MSSYAUX / REAL( SUMWT8(1)*SUMGRD ) + END IF + END DO + ! + ! Group 4 variables + ! + DO ISWLL = 0, NOSWLL_MIN + ! + IF ( PHSAUX(ISWLL) .NE. UNDEF ) THEN + PHSAUX(ISWLL) = PHSAUX(ISWLL) / SUMWT4(1,ISWLL) + IF ( PHS(ISEA,ISWLL) .EQ. UNDEF ) THEN + PHS(ISEA,ISWLL) = PHSAUX(ISWLL) / REAL( SUMGRD ) + ELSE + PHS(ISEA,ISWLL) = PHS(ISEA,ISWLL) + & + PHSAUX(ISWLL) / REAL( SUMGRD ) END IF -! - IF ( MSCXAUX .NE. UNDEF ) THEN - IF ( MSCX(ISEA) .EQ. UNDEF ) MSCX(ISEA) = 0. - MSCX(ISEA) = MSCX(ISEA) + & - MSCXAUX / REAL( SUMWT8(2)*SUMGRD ) + END IF + ! + IF ( PTPAUX(ISWLL) .NE. UNDEF ) THEN + PTPAUX(ISWLL) = PTPAUX(ISWLL) / SUMWT4(2,ISWLL) + IF ( PTP(ISEA,ISWLL) .EQ. UNDEF ) THEN + PTP(ISEA,ISWLL) = PTPAUX(ISWLL) / REAL( SUMGRD ) + ELSE + PTP(ISEA,ISWLL) = PTP(ISEA,ISWLL) + & + PTPAUX(ISWLL) / REAL( SUMGRD ) END IF -! - IF ( MSCYAUX .NE. UNDEF ) THEN - IF ( MSCY(ISEA) .EQ. UNDEF ) MSCY(ISEA) = 0. - MSCY(ISEA) = MSCY(ISEA) + & - MSCYAUX / REAL( SUMWT8(2)*SUMGRD ) + END IF + ! + IF ( PLPAUX(ISWLL) .NE. UNDEF ) THEN + PLPAUX(ISWLL) = PLPAUX(ISWLL) / SUMWT4(3,ISWLL) + IF ( PLP(ISEA,ISWLL) .EQ. UNDEF ) THEN + PLP(ISEA,ISWLL) = PLPAUX(ISWLL) / REAL( SUMGRD ) + ELSE + PLP(ISEA,ISWLL) = PLP(ISEA,ISWLL) + & + PLPAUX(ISWLL) / REAL( SUMGRD ) END IF -! - IF ( MSSDAUX1 .NE. UNDEF .AND. MSSDAUX2 .NE. UNDEF ) THEN - MSSDAUX1 = MSSDAUX1 / REAL( SUMWT8(3)*SUMGRD ) - MSSDAUX2 = MSSDAUX2 / REAL( SUMWT8(3)*SUMGRD ) - IF ( MSSD(ISEA) .NE. UNDEF ) THEN - MSSDAUX1 = MSSDAUX1 + COS ( MSSD(ISEA) ) - MSSDAUX2 = MSSDAUX2 + SIN ( MSSD(ISEA) ) - END IF - MSSD(ISEA) = ATAN2 ( MSSDAUX2, MSSDAUX1 ) + END IF + ! + IF ( PDIRAUX1(ISWLL) .NE. UNDEF ) THEN + PDIRAUX1(ISWLL) = PDIRAUX1(ISWLL) / SUMWT4(4,ISWLL) + PDIRAUX2(ISWLL) = PDIRAUX2(ISWLL) / SUMWT4(4,ISWLL) + IF ( PDIR(ISEA,ISWLL) .EQ. UNDEF ) THEN + PDIRAUX1(ISWLL) = PDIRAUX1(ISWLL) / REAL( SUMGRD ) + PDIRAUX2(ISWLL) = PDIRAUX2(ISWLL) / REAL( SUMGRD ) + PDIR(ISEA,ISWLL) = ATAN2 ( PDIRAUX2(ISWLL), PDIRAUX1(ISWLL) ) + ELSE + PDIRAUX1(ISWLL) = PDIRAUX1(ISWLL) / REAL( SUMGRD ) + & + COS ( PDIR(ISEA,ISWLL) ) + PDIRAUX2(ISWLL) = PDIRAUX2(ISWLL) / REAL( SUMGRD ) + & + SIN ( PDIR(ISEA,ISWLL) ) + PDIR(ISEA,ISWLL) = ATAN2 ( PDIRAUX2(ISWLL), PDIRAUX1(ISWLL) ) END IF -! - IF ( MSCDAUX1 .NE. UNDEF .AND. MSCDAUX2 .NE. UNDEF ) THEN - MSCDAUX1 = MSCDAUX1 / REAL( SUMWT8(4)*SUMGRD ) - MSCDAUX2 = MSCDAUX2 / REAL( SUMWT8(4)*SUMGRD ) - IF ( MSCD(ISEA) .NE. UNDEF ) THEN - MSCDAUX1 = MSCDAUX1 + COS ( MSCD(ISEA) ) - MSCDAUX2 = MSCDAUX2 + SIN ( MSCD(ISEA) ) - END IF - MSCD(ISEA) = ATAN2 ( MSCDAUX2, MSCDAUX1 ) + END IF + ! + IF ( PSIAUX(ISWLL) .NE. UNDEF ) THEN + PSIAUX(ISWLL) = PSIAUX(ISWLL) / SUMWT4(5,ISWLL) + IF ( PSI(ISEA,ISWLL) .EQ. UNDEF ) THEN + PSI(ISEA,ISWLL) = PSIAUX(ISWLL) / REAL( SUMGRD ) + ELSE + PSI(ISEA,ISWLL) = PSI(ISEA,ISWLL) + & + PSIAUX(ISWLL) / REAL( SUMGRD ) END IF -! - IF ( QPAUX .NE. UNDEF ) THEN - IF ( QP(ISEA) .EQ. UNDEF ) QP(ISEA) = 0. - QP(ISEA) = QP(ISEA) + QPAUX / REAL( SUMWT8(5)*SUMGRD ) + END IF + ! + IF ( PWSAUX(ISWLL) .NE. UNDEF ) THEN + PWSAUX(ISWLL) = PWSAUX(ISWLL) / SUMWT4(6,ISWLL) + IF ( PWS(ISEA,ISWLL) .EQ. UNDEF ) THEN + PWS(ISEA,ISWLL) = PWSAUX(ISWLL) / REAL( SUMGRD ) + ELSE + PWS(ISEA,ISWLL) = PWS(ISEA,ISWLL) + & + PWSAUX(ISWLL) / REAL( SUMGRD ) END IF -! - END IF !/ ( USEGRID(IG) ) -! -! End of Second loop - END DO !/ IG = 1, GR_INTS -! -! Convert select variables back to polar notation. This is done because just -! prior to writing to file the w3iogo routine converts these variables -! from polar to cartesian coordinates -! - IF ( UA(ISEA) .NE. UNDEF ) THEN - VAR1 = UA(ISEA) - VAR2 = UD(ISEA) - UA(ISEA) = SQRT ( VAR1**2 + VAR2**2 ) - UD(ISEA) = ATAN2 ( VAR2, VAR1 ) - END IF -! - IF ( UST(ISEA) .NE. UNDEF ) THEN - VAR1 = UST(ISEA) - VAR2 = USTDIR(ISEA) - UST(ISEA) = SQRT ( VAR1**2 + VAR2**2 ) - USTDIR(ISEA) = ATAN2 ( VAR2, VAR1 ) + END IF + ! + IF ( PTHP0AUX1(ISWLL) .NE. UNDEF ) THEN + PTHP0AUX1(ISWLL) = PTHP0AUX1(ISWLL) & + / REAL( SUMWT4(7,ISWLL)*SUMGRD ) + PTHP0AUX2(ISWLL) = PTHP0AUX2(ISWLL) & + / REAL( SUMWT4(7,ISWLL)*SUMGRD ) + IF ( PTHP0(ISEA,ISWLL) .NE. UNDEF ) THEN + PTHP0AUX1(ISWLL) = PTHP0AUX1(ISWLL) + & + COS ( PTHP0(ISEA,ISWLL) ) + PTHP0AUX2(ISWLL) = PTHP0AUX2(ISWLL) + & + SIN ( PTHP0(ISEA,ISWLL) ) + END IF + PTHP0(ISEA,ISWLL) = & + ATAN2 ( PTHP0AUX2(ISWLL), PTHP0AUX1(ISWLL) ) + END IF + ! + IF ( PQPAUX(ISWLL) .NE. UNDEF ) THEN + IF ( PQP(ISEA,ISWLL) .EQ. UNDEF ) & + PQP(ISEA,ISWLL) = 0. + PQP(ISEA,ISWLL) = PQP(ISEA,ISWLL) + & + PQPAUX(ISWLL) / REAL( SUMWT4(8,ISWLL)*SUMGRD ) + END IF + ! + IF ( PPEAUX(ISWLL) .NE. UNDEF ) THEN + IF ( PPE(ISEA,ISWLL) .EQ. UNDEF ) & + PPE(ISEA,ISWLL) = 0. + PPE(ISEA,ISWLL) = PPE(ISEA,ISWLL) + & + PPEAUX(ISWLL) / REAL( SUMWT4(9,ISWLL)*SUMGRD ) + + END IF + ! + IF ( PGWAUX(ISWLL) .NE. UNDEF ) THEN + IF ( PGW(ISEA,ISWLL) .EQ. UNDEF ) & + PGW(ISEA,ISWLL) = 0. + PGW(ISEA,ISWLL) = PGW(ISEA,ISWLL) + & + PGWAUX(ISWLL) / REAL( SUMWT4(10,ISWLL)*SUMGRD ) + END IF + ! + IF ( PSWAUX(ISWLL) .NE. UNDEF ) THEN + IF ( PSW(ISEA,ISWLL) .EQ. UNDEF ) & + PSW(ISEA,ISWLL) = 0. + PSW(ISEA,ISWLL) = PSW(ISEA,ISWLL) + & + PSWAUX(ISWLL) / REAL( SUMWT4(11,ISWLL)*SUMGRD ) + END IF + ! + IF ( PTM1AUX(ISWLL) .NE. UNDEF ) THEN + IF ( PTM1(ISEA,ISWLL) .EQ. UNDEF ) & + PTM1(ISEA,ISWLL) = 0. + PTM1(ISEA,ISWLL) = PTM1(ISEA,ISWLL) + & + PTM1AUX(ISWLL) / REAL( SUMWT4(12,ISWLL)*SUMGRD ) + END IF + ! + IF ( PT1AUX(ISWLL) .NE. UNDEF ) THEN + IF ( PT1(ISEA,ISWLL) .EQ. UNDEF ) & + PT1(ISEA,ISWLL) = 0. + PT1(ISEA,ISWLL) = PT1(ISEA,ISWLL) + & + PT1AUX(ISWLL) / REAL( SUMWT4(13,ISWLL)*SUMGRD ) + END IF + ! + IF ( PT2AUX(ISWLL) .NE. UNDEF ) THEN + IF ( PT2(ISEA,ISWLL) .EQ. UNDEF ) & + PT2(ISEA,ISWLL) = 0. + PT2(ISEA,ISWLL) = PT2(ISEA,ISWLL) + & + PT2AUX(ISWLL) / REAL( SUMWT4(14,ISWLL)*SUMGRD ) + END IF + ! + IF ( PEPAUX(ISWLL) .NE. UNDEF ) THEN + IF ( PEP(ISEA,ISWLL) .EQ. UNDEF ) & + PEP(ISEA,ISWLL) = 0. + PEP(ISEA,ISWLL) = PEP(ISEA,ISWLL) + & + PEPAUX(ISWLL) / REAL( SUMWT4(15,ISWLL)*SUMGRD ) + END IF + ! + END DO !/ ISWLL = 0, NOSWLL_MIN + ! + IF ( PWSTAUX .NE. UNDEF ) THEN + PWSTAUX = PWSTAUX / SUMWT4(16,0) + IF ( PWST(ISEA) .EQ. UNDEF ) THEN + PWST(ISEA) = PWSTAUX / REAL( SUMGRD ) + ELSE + PWST(ISEA) = PWST(ISEA) + PWSTAUX / REAL( SUMGRD ) + END IF END IF -! - IF ( ABA(ISEA) .NE. UNDEF ) THEN - VAR1 = ABA(ISEA) - VAR2 = ABD(ISEA) - ABA(ISEA) = SQRT ( VAR1**2 + VAR2**2 ) - ABD(ISEA) = ATAN2 ( VAR2, VAR1 ) + ! + ! Group 5 variables + ! + IF ( USTAUX1 .NE. UNDEF ) THEN + USTAUX1 = USTAUX1 / SUMWT5(1) + USTAUX2 = USTAUX2 / SUMWT5(1) + IF ( UST(ISEA) .EQ. UNDEF ) THEN + UST(ISEA) = USTAUX1 / REAL( SUMGRD ) + USTDIR(ISEA) = USTAUX2 / REAL( SUMGRD ) + ELSE + UST(ISEA) = UST(ISEA) + USTAUX1 / REAL( SUMGRD ) + USTDIR(ISEA) = USTDIR(ISEA) + USTAUX2 / REAL( SUMGRD ) + END IF END IF -! - IF ( UBA(ISEA) .NE. UNDEF ) THEN - VAR1 = UBA(ISEA) - VAR2 = UBD(ISEA) - UBA(ISEA) = SQRT ( VAR1**2 + VAR2**2 ) - UBD(ISEA) = ATAN2 ( VAR2, VAR1 ) + ! + IF ( CHARNAUX .NE. UNDEF ) THEN + CHARNAUX = CHARNAUX / SUMWT5(2) + IF ( CHARN(ISEA) .EQ. UNDEF ) THEN + CHARN(ISEA) = CHARNAUX / REAL( SUMGRD ) + ELSE + CHARN(ISEA) = CHARN(ISEA) + CHARNAUX / REAL( SUMGRD ) + END IF END IF -! - END IF -! -!/ End of main loop through output points - END DO !/ ISEA = 1, NSEA -! -!------------------------------------------------------------------------------ -! 3. Write out interpolated data to target output file -! - CALL W3IOGO('WRITE',FIDOUT(NG),IOTST,NG) -! - RETURN -! -! Error escape locations -! -!/ -!/ End of W3EXGI ------------------------------------------------------------/ -!/ - END SUBROUTINE W3EXGI -!/ -!/ End of W3GRID_INTERP -----------------------------------------------------/ -!/ - END PROGRAM W3GRID_INTERP + ! + IF ( CGEAUX .NE. UNDEF ) THEN + CGEAUX = CGEAUX / SUMWT5(3) + IF ( CGE(ISEA) .EQ. UNDEF ) THEN + CGE(ISEA) = CGEAUX / REAL( SUMGRD ) + ELSE + CGE(ISEA) = CGE(ISEA) + CGEAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( PHIAWAUX .NE. UNDEF ) THEN + PHIAWAUX = PHIAWAUX / SUMWT5(4) + IF ( PHIAW(ISEA) .EQ. UNDEF ) THEN + PHIAW(ISEA) = PHIAWAUX / REAL( SUMGRD ) + ELSE + PHIAW(ISEA) = PHIAW(ISEA) + PHIAWAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( TAUWIXAUX .NE. UNDEF ) THEN + TAUWIXAUX = TAUWIXAUX / SUMWT5(5) + TAUWIYAUX = TAUWIYAUX / SUMWT5(5) + IF ( TAUWIX(ISEA) .EQ. UNDEF ) THEN + TAUWIX(ISEA) = TAUWIXAUX / REAL( SUMGRD ) + TAUWIY(ISEA) = TAUWIYAUX / REAL( SUMGRD ) + ELSE + TAUWIX(ISEA) = TAUWIX(ISEA) + TAUWIXAUX / REAL( SUMGRD ) + TAUWIY(ISEA) = TAUWIY(ISEA) + TAUWIYAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( TAUWNXAUX .NE. UNDEF ) THEN + TAUWNXAUX = TAUWNXAUX / SUMWT5(6) + TAUWNYAUX = TAUWNYAUX / SUMWT5(6) + IF ( TAUWNX(ISEA) .EQ. UNDEF ) THEN + TAUWNX(ISEA) = TAUWNXAUX / REAL( SUMGRD ) + TAUWNY(ISEA) = TAUWNYAUX / REAL( SUMGRD ) + ELSE + TAUWNX(ISEA) = TAUWNX(ISEA) + TAUWNXAUX / REAL( SUMGRD ) + TAUWNY(ISEA) = TAUWNY(ISEA) + TAUWNYAUX / REAL( SUMGRD ) + END IF + END IF + ! + DO ICAP = 1,4 + IF ( WHITECAPAUX(ICAP) .NE. UNDEF ) THEN + WHITECAPAUX(ICAP) = WHITECAPAUX(ICAP) / SUMWTC(ICAP) + IF ( WHITECAP(ISEA,ICAP) .EQ. UNDEF ) THEN + WHITECAP(ISEA,ICAP) = WHITECAPAUX(ICAP) / REAL( SUMGRD ) + ELSE + WHITECAP(ISEA,ICAP) = WHITECAP(ISEA,ICAP) + & + WHITECAPAUX(ICAP) / REAL( SUMGRD ) + END IF + END IF + END DO + ! + ! Group 6 variables + ! + IF ( SXXAUX .NE. UNDEF ) THEN + SXXAUX = SXXAUX / SUMWT6(1) + SXYAUX = SXYAUX / SUMWT6(1) + SYYAUX = SYYAUX / SUMWT6(1) + IF ( SXX(ISEA) .EQ. UNDEF ) THEN + SXX(ISEA) = SXXAUX / REAL( SUMGRD ) + SXY(ISEA) = SXYAUX / REAL( SUMGRD ) + SYY(ISEA) = SYYAUX / REAL( SUMGRD ) + ELSE + SXX(ISEA) = SXX(ISEA) + SXXAUX / REAL( SUMGRD ) + SXY(ISEA) = SXY(ISEA) + SXYAUX / REAL( SUMGRD ) + SYY(ISEA) = SYY(ISEA) + SYYAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( TAUOXAUX .NE. UNDEF ) THEN + TAUOXAUX = TAUOXAUX / SUMWT6(2) + TAUOYAUX = TAUOYAUX / SUMWT6(2) + IF ( TAUOX(ISEA) .EQ. UNDEF ) THEN + TAUOX(ISEA) = TAUOXAUX / REAL( SUMGRD ) + TAUOY(ISEA) = TAUOYAUX / REAL( SUMGRD ) + ELSE + TAUOX(ISEA) = TAUOX(ISEA) + TAUOXAUX / REAL( SUMGRD ) + TAUOY(ISEA) = TAUOY(ISEA) + TAUOYAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( BHDAUX .NE. UNDEF ) THEN + BHDAUX = BHDAUX / SUMWT6(3) + IF ( BHD(ISEA) .EQ. UNDEF ) THEN + BHD(ISEA) = BHDAUX / REAL( SUMGRD ) + ELSE + BHD(ISEA) = BHD(ISEA) + BHDAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( PHIOCAUX .NE. UNDEF ) THEN + PHIOCAUX = PHIOCAUX / SUMWT6(4) + IF ( PHIOC(ISEA) .EQ. UNDEF ) THEN + PHIOC(ISEA) = PHIOCAUX / REAL( SUMGRD ) + ELSE + PHIOC(ISEA) = PHIOC(ISEA) + PHIOCAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( TUSXAUX .NE. UNDEF ) THEN + TUSXAUX = TUSXAUX / SUMWT6(5) + TUSYAUX = TUSYAUX / SUMWT6(5) + IF ( TUSX(ISEA) .EQ. UNDEF ) THEN + TUSX(ISEA) = TUSXAUX / REAL( SUMGRD ) + TUSY(ISEA) = TUSYAUX / REAL( SUMGRD ) + ELSE + TUSX(ISEA) = TUSX(ISEA) + TUSXAUX / REAL( SUMGRD ) + TUSY(ISEA) = TUSY(ISEA) + TUSYAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( USSXAUX .NE. UNDEF ) THEN + USSXAUX = USSXAUX / SUMWT6(6) + USSYAUX = USSYAUX / SUMWT6(6) + IF ( USSX(ISEA) .EQ. UNDEF ) THEN + USSX(ISEA) = USSXAUX / REAL( SUMGRD ) + USSY(ISEA) = USSYAUX / REAL( SUMGRD ) + ELSE + USSX(ISEA) = USSX(ISEA) + USSXAUX / REAL( SUMGRD ) + USSY(ISEA) = USSY(ISEA) + USSYAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( PRMSAUX .NE. UNDEF ) THEN + PRMSAUX = PRMSAUX / SUMWT6(7) + TPMSAUX = TPMSAUX / SUMWT6(7) + IF ( PRMS(ISEA) .EQ. UNDEF ) THEN + PRMS(ISEA) = PRMSAUX / REAL( SUMGRD ) + TPMS(ISEA) = TPMSAUX / REAL( SUMGRD ) + ELSE + PRMS(ISEA) = PRMS(ISEA) + PRMSAUX / REAL( SUMGRD ) + TPMS(ISEA) = TPMS(ISEA) + TPMSAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( US3DF(1).GT.0 ) THEN + DO IK = US3DF(2),US3DF(3) + IF ( US3DAUX(IK) .NE. UNDEF ) THEN + IF ( US3D(ISEA,IK) .EQ. UNDEF ) US3D(ISEA,IK) = 0. + US3D(ISEA,IK) = US3D(ISEA,IK) + & + US3DAUX(IK) / REAL( SUMWT68(IK) * SUMGRD ) + END IF + IF ( US3DAUX(NK+IK) .NE. UNDEF ) THEN + IF ( US3D(ISEA,NK+IK) .EQ. UNDEF ) & + US3D(ISEA,NK+IK) = 0. + US3D(ISEA,NK+IK) = US3D(ISEA,NK+IK) + & + US3DAUX(NK+IK) / REAL( SUMWT68(NK+IK) * SUMGRD ) + END IF + END DO + END IF + ! + IF ( P2MSF(1).GT.0 ) THEN + DO IK = P2MSF(2),P2MSF(3) + IF ( P2SMSAUX(IK) .NE. UNDEF ) THEN + IF ( P2SMS(ISEA,IK).EQ.UNDEF ) P2SMS(ISEA,IK) = 0. + P2SMS(ISEA,IK) = P2SMS(ISEA,IK) + & + P2SMSAUX(IK) / REAL( SUMWT69(IK) * SUMGRD ) + END IF + END DO + END IF + ! + IF ( TAUICEAUX(1) .NE. UNDEF ) THEN + IF ( TAUICE(ISEA,1) .EQ. UNDEF ) TAUICE(ISEA,1) = 0. + IF ( TAUICE(ISEA,2) .EQ. UNDEF ) TAUICE(ISEA,2) = 0. + TAUICE(ISEA,1) = TAUICE(ISEA,1) + & + TAUICEAUX(1) / REAL( SUMWT6(10) * SUMGRD ) + TAUICE(ISEA,2) = TAUICE(ISEA,2) + & + TAUICEAUX(2) / REAL( SUMWT6(10) * SUMGRD ) + END IF + ! + IF ( PHICEAUX .NE. UNDEF ) THEN + IF ( PHICE(ISEA) .EQ. UNDEF ) PHICE(ISEA) = 0. + PHICE(ISEA) = PHICE(ISEA) + & + PHICEAUX / REAL( SUMWT6(11) * SUMGRD ) + END IF + ! + IF ( USSPF(1).GT.0 ) THEN + DO IK = 1,USSPF(2) + IF ( USSPAUX(IK) .NE. UNDEF ) THEN + IF ( USSP(ISEA,IK) .EQ. UNDEF ) USSP(ISEA,IK) = 0. + USSP(ISEA,IK) = USSP(ISEA,IK) + & + USSPAUX(IK) / REAL( SUMWT612(IK) * SUMGRD ) + END IF + IF ( USSPAUX(NK+IK) .NE. UNDEF ) THEN + IF ( USSP(ISEA,NK+IK) .EQ. UNDEF ) & + USSP(ISEA,NK+IK) = 0. + USSP(ISEA,NK+IK) = USSP(ISEA,NK+IK) + & + USSPAUX(NK+IK) / REAL( SUMWT612(NK+IK) * SUMGRD ) + END IF + END DO + END IF + ! + IF ( TAUOCXAUX .NE. UNDEF ) THEN + TAUOCXAUX = TAUOCXAUX / SUMWT6(13) + TAUOCYAUX = TAUOCYAUX / SUMWT6(13) + IF ( TAUOCX(ISEA) .EQ. UNDEF ) THEN + TAUOCX(ISEA) = TAUOCXAUX / REAL( SUMGRD ) + TAUOCY(ISEA) = TAUOCYAUX / REAL( SUMGRD ) + ELSE + TAUOCX(ISEA) = TAUOCX(ISEA) + TAUOCXAUX / REAL( SUMGRD ) + TAUOCY(ISEA) = TAUOCY(ISEA) + TAUOCYAUX / REAL( SUMGRD ) + END IF + END IF + ! + ! Group 7 variables + ! + IF ( ABAAUX .NE. UNDEF ) THEN + ABAAUX = ABAAUX / SUMWT7(1) + ABDAUX = ABDAUX / SUMWT7(1) + IF ( ABA(ISEA) .EQ. UNDEF ) THEN + ABA(ISEA) = ABAAUX / REAL( SUMGRD ) + ABD(ISEA) = ABDAUX / REAL( SUMGRD ) + ELSE + ABA(ISEA) = ABA(ISEA) + ABAAUX / REAL( SUMGRD ) + ABD(ISEA) = ABD(ISEA) + ABDAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( UBAAUX .NE. UNDEF ) THEN + UBAAUX = UBAAUX / SUMWT7(2) + UBDAUX = UBDAUX / SUMWT7(2) + IF ( UBA(ISEA) .EQ. UNDEF ) THEN + UBA(ISEA) = UBAAUX / REAL( SUMGRD ) + UBD(ISEA) = UBDAUX / REAL( SUMGRD ) + ELSE + UBA(ISEA) = UBA(ISEA) + UBAAUX / REAL( SUMGRD ) + UBD(ISEA) = UBD(ISEA) + UBDAUX / REAL( SUMGRD ) + END IF + END IF + ! + DO IBED = 1,3 + IF ( BEDFORMSAUX(IBED) .NE. UNDEF ) THEN + BEDFORMSAUX(IBED) = BEDFORMSAUX(IBED) / SUMWTB(IBED) + IF ( BEDFORMS(ISEA,IBED) .EQ. UNDEF ) THEN + BEDFORMS(ISEA,IBED) = BEDFORMSAUX(IBED) / REAL( SUMGRD ) + ELSE + BEDFORMS(ISEA,IBED) = BEDFORMS(ISEA,IBED) + & + BEDFORMSAUX(IBED) / REAL( SUMGRD ) + END IF + END IF + END DO + ! + IF ( PHIBBLAUX .NE. UNDEF ) THEN + PHIBBLAUX = PHIBBLAUX / SUMWT7(4) + IF ( PHIBBL(ISEA) .EQ. UNDEF ) THEN + PHIBBL(ISEA) = PHIBBLAUX / REAL( SUMGRD ) + ELSE + PHIBBL(ISEA) = PHIBBL(ISEA) + PHIBBLAUX / REAL( SUMGRD ) + END IF + END IF + ! + IF ( TAUBBLAUX(1) .NE. UNDEF ) THEN + TAUBBLAUX(1) = TAUBBLAUX(1) / SUMWT7(5) + TAUBBLAUX(2) = TAUBBLAUX(2) / SUMWT7(5) + IF ( TAUBBL(ISEA,1) .EQ. UNDEF ) THEN + TAUBBL(ISEA,1) = TAUBBLAUX(1) / REAL( SUMGRD ) + TAUBBL(ISEA,2) = TAUBBLAUX(2) / REAL( SUMGRD ) + ELSE + TAUBBL(ISEA,1) = TAUBBL(ISEA,1) + & + TAUBBLAUX(1) / REAL( SUMGRD ) + TAUBBL(ISEA,2) = TAUBBL(ISEA,2) + & + TAUBBLAUX(2) / REAL( SUMGRD ) + END IF + END IF + ! + ! Group 8 variables + ! + IF ( MSSXAUX .NE. UNDEF ) THEN + IF ( MSSX(ISEA) .EQ. UNDEF ) MSSX(ISEA) = 0. + MSSX(ISEA) = MSSX(ISEA) + & + MSSXAUX / REAL( SUMWT8(1)*SUMGRD ) + END IF + ! + IF ( MSSYAUX .NE. UNDEF ) THEN + IF ( MSSY(ISEA) .EQ. UNDEF ) MSSY(ISEA) = 0. + MSSY(ISEA) = MSSY(ISEA) + & + MSSYAUX / REAL( SUMWT8(1)*SUMGRD ) + END IF + ! + IF ( MSCXAUX .NE. UNDEF ) THEN + IF ( MSCX(ISEA) .EQ. UNDEF ) MSCX(ISEA) = 0. + MSCX(ISEA) = MSCX(ISEA) + & + MSCXAUX / REAL( SUMWT8(2)*SUMGRD ) + END IF + ! + IF ( MSCYAUX .NE. UNDEF ) THEN + IF ( MSCY(ISEA) .EQ. UNDEF ) MSCY(ISEA) = 0. + MSCY(ISEA) = MSCY(ISEA) + & + MSCYAUX / REAL( SUMWT8(2)*SUMGRD ) + END IF + ! + IF ( MSSDAUX1 .NE. UNDEF .AND. MSSDAUX2 .NE. UNDEF ) THEN + MSSDAUX1 = MSSDAUX1 / REAL( SUMWT8(3)*SUMGRD ) + MSSDAUX2 = MSSDAUX2 / REAL( SUMWT8(3)*SUMGRD ) + IF ( MSSD(ISEA) .NE. UNDEF ) THEN + MSSDAUX1 = MSSDAUX1 + COS ( MSSD(ISEA) ) + MSSDAUX2 = MSSDAUX2 + SIN ( MSSD(ISEA) ) + END IF + MSSD(ISEA) = ATAN2 ( MSSDAUX2, MSSDAUX1 ) + END IF + ! + IF ( MSCDAUX1 .NE. UNDEF .AND. MSCDAUX2 .NE. UNDEF ) THEN + MSCDAUX1 = MSCDAUX1 / REAL( SUMWT8(4)*SUMGRD ) + MSCDAUX2 = MSCDAUX2 / REAL( SUMWT8(4)*SUMGRD ) + IF ( MSCD(ISEA) .NE. UNDEF ) THEN + MSCDAUX1 = MSCDAUX1 + COS ( MSCD(ISEA) ) + MSCDAUX2 = MSCDAUX2 + SIN ( MSCD(ISEA) ) + END IF + MSCD(ISEA) = ATAN2 ( MSCDAUX2, MSCDAUX1 ) + END IF + ! + IF ( QPAUX .NE. UNDEF ) THEN + IF ( QP(ISEA) .EQ. UNDEF ) QP(ISEA) = 0. + QP(ISEA) = QP(ISEA) + QPAUX / REAL( SUMWT8(5)*SUMGRD ) + END IF + ! + END IF !/ ( USEGRID(IG) ) + ! + ! End of Second loop + END DO !/ IG = 1, GR_INTS + ! + ! Convert select variables back to polar notation. This is done because just + ! prior to writing to file the w3iogo routine converts these variables + ! from polar to cartesian coordinates + ! + IF ( UA(ISEA) .NE. UNDEF ) THEN + VAR1 = UA(ISEA) + VAR2 = UD(ISEA) + UA(ISEA) = SQRT ( VAR1**2 + VAR2**2 ) + UD(ISEA) = ATAN2 ( VAR2, VAR1 ) + END IF + ! + IF ( UST(ISEA) .NE. UNDEF ) THEN + VAR1 = UST(ISEA) + VAR2 = USTDIR(ISEA) + UST(ISEA) = SQRT ( VAR1**2 + VAR2**2 ) + USTDIR(ISEA) = ATAN2 ( VAR2, VAR1 ) + END IF + ! + IF ( ABA(ISEA) .NE. UNDEF ) THEN + VAR1 = ABA(ISEA) + VAR2 = ABD(ISEA) + ABA(ISEA) = SQRT ( VAR1**2 + VAR2**2 ) + ABD(ISEA) = ATAN2 ( VAR2, VAR1 ) + END IF + ! + IF ( UBA(ISEA) .NE. UNDEF ) THEN + VAR1 = UBA(ISEA) + VAR2 = UBD(ISEA) + UBA(ISEA) = SQRT ( VAR1**2 + VAR2**2 ) + UBD(ISEA) = ATAN2 ( VAR2, VAR1 ) + END IF + ! + END IF + ! + !/ End of main loop through output points + END DO !/ ISEA = 1, NSEA + ! + !------------------------------------------------------------------------------ + ! 3. Write out interpolated data to target output file + ! + CALL W3IOGO('WRITE',FIDOUT(NG),IOTST,NG) + ! + RETURN + ! + ! Error escape locations + ! + !/ + !/ End of W3EXGI ------------------------------------------------------------/ + !/ + END SUBROUTINE W3EXGI + !/ + !/ End of W3GRID_INTERP -----------------------------------------------------/ + !/ +END PROGRAM W3GRID_INTERP diff --git a/model/src/ww3_grib.F90 b/model/src/ww3_grib.F90 index c5270a96a..5df59b1d3 100644 --- a/model/src/ww3_grib.F90 +++ b/model/src/ww3_grib.F90 @@ -24,1662 +24,1662 @@ !> @author J.-H. Alves !> @date 22-Mar-2021 ! - PROGRAM W3GRIB -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | A. Chawla | -!/ | J.-H. Alves | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 01-Nov-1999 : Final FORTRAN 77 ( version 1.18 + error fix ) -!/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 25-Jan-2001 : Flat grid error exit added ( version 2.06 ) -!/ 29-Apr-2002 : Adding output fields 17-18. ( version 2.20 ) -!/ 08-May-2002 : Replace XLF switch with NCEP1. ( version 2.21 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 20-Jul-2005 : Additional output parameters. ( version 3.07 ) -!/ 11-Apr-2007 : Additional output parameters. ( version 3.11 ) -!/ 18-May-2007 : Update GRIB1 for partitioning. ( version 3.11 ) -!/ 16-Jul-2007 : Adding GRIB2 capability. ( version 3.11 ) -!/ (A. Chawla) -!/ 01-Aug-2007 : Update FLGRIB for GRIB2. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 05-Oct-2011 : Updating to the 53 output parameter ( version 4.05 ) -!/ (Arun Chawla) -!/ 01-Mar-2013 : Adding double-index output fields ( version 4.11 ) -!/ (J-Henrique Alves) -!/ 01-Dec-2016 : Adding lambert conformal grid ( version 6.01 ) -!/ (J.H. Alves) -!/ 26-Jul-2018 : Adding polar stereographic grid ( version 6.05 ) -!/ (J.H. Alves) -!/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) -!/ 09-Jun-2021 : remove grib1 support (NCEP1) ( version 7.14 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Post-processing of grid output. -! -! 2. Method : -! -! Data is read from the grid output file out_grd.ww3 (raw data) -! and from the file ww3_grib.inp ( NDSI, output requests ). -! Model definition and raw data files are read using WAVEWATCH III -! subroutines. -! GRIB packing is performed using NCEP's W3 library (not supplied). -! -! When adding new parameters to GRIB packing, keep in mind that -! packing is done differently for scalar and vector quantities -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W3NAUX Subr. W3ADATMD Set number of model for aux data. -! W3SETA Subr. Id. Point to selected model for aux data. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! STME21 Subr. W3TIMEMD Convert time to string. -! TICK21 Subr. Id. Advance time. -! DSEC21 Func. Id. Difference between times. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. -! W3READFLGRD Subr. W3IOGOMD Reading output fields flags. -! W3EXGB Subr. Internal Execute grib output. -! BAOPEN Subr. NCEP library routine. -! BAOPENW Subr. NCEP library routine. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! Checks on input, checks in W3IOxx. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! !/NCO NCEP NCO modifications for operational implementation. -! -! !/NOGRB No GRIB package included. -! !/NCEP2 NCEP IBM links to GRIB2 packing routines. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -! -! USE W3GDATMD, ONLY: W3NMOD, W3SETG - USE W3WDATMD, ONLY: W3NDAT, W3SETW -! USE W3ADATMD, ONLY: W3NAUX, W3SETA - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3IOGRMD, ONLY: W3IOGR - USE W3IOGOMD, ONLY: W3READFLGRD, W3IOGO - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE +PROGRAM W3GRIB + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | A. Chawla | + !/ | J.-H. Alves | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 01-Nov-1999 : Final FORTRAN 77 ( version 1.18 + error fix ) + !/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 25-Jan-2001 : Flat grid error exit added ( version 2.06 ) + !/ 29-Apr-2002 : Adding output fields 17-18. ( version 2.20 ) + !/ 08-May-2002 : Replace XLF switch with NCEP1. ( version 2.21 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 20-Jul-2005 : Additional output parameters. ( version 3.07 ) + !/ 11-Apr-2007 : Additional output parameters. ( version 3.11 ) + !/ 18-May-2007 : Update GRIB1 for partitioning. ( version 3.11 ) + !/ 16-Jul-2007 : Adding GRIB2 capability. ( version 3.11 ) + !/ (A. Chawla) + !/ 01-Aug-2007 : Update FLGRIB for GRIB2. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 05-Oct-2011 : Updating to the 53 output parameter ( version 4.05 ) + !/ (Arun Chawla) + !/ 01-Mar-2013 : Adding double-index output fields ( version 4.11 ) + !/ (J-Henrique Alves) + !/ 01-Dec-2016 : Adding lambert conformal grid ( version 6.01 ) + !/ (J.H. Alves) + !/ 26-Jul-2018 : Adding polar stereographic grid ( version 6.05 ) + !/ (J.H. Alves) + !/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) + !/ 09-Jun-2021 : remove grib1 support (NCEP1) ( version 7.14 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Post-processing of grid output. + ! + ! 2. Method : + ! + ! Data is read from the grid output file out_grd.ww3 (raw data) + ! and from the file ww3_grib.inp ( NDSI, output requests ). + ! Model definition and raw data files are read using WAVEWATCH III + ! subroutines. + ! GRIB packing is performed using NCEP's W3 library (not supplied). + ! + ! When adding new parameters to GRIB packing, keep in mind that + ! packing is done differently for scalar and vector quantities + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W3NAUX Subr. W3ADATMD Set number of model for aux data. + ! W3SETA Subr. Id. Point to selected model for aux data. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! TICK21 Subr. Id. Advance time. + ! DSEC21 Func. Id. Difference between times. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. + ! W3READFLGRD Subr. W3IOGOMD Reading output fields flags. + ! W3EXGB Subr. Internal Execute grib output. + ! BAOPEN Subr. NCEP library routine. + ! BAOPENW Subr. NCEP library routine. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! Checks on input, checks in W3IOxx. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! !/NCO NCEP NCO modifications for operational implementation. + ! + ! !/NOGRB No GRIB package included. + ! !/NCEP2 NCEP IBM links to GRIB2 packing routines. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + ! + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG + USE W3WDATMD, ONLY: W3NDAT, W3SETW + ! USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3IOGRMD, ONLY: W3IOGR + USE W3IOGOMD, ONLY: W3READFLGRD, W3IOGO + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY : STRACE -#endif - USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 -! - USE W3GDATMD - USE W3WDATMD, ONLY: TIME, WLV, ICE, UST, USTDIR, RHOAIR - USE W3ADATMD - USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOGRP, NGRPP, IDOUT, UNDEF,& - FLOGRD, FNMPRE, NOSWLL, NOGE, FLOGD -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local variables -!/ - INTEGER :: NDSI, NDSM, NDSOG, NDSDAT, NDSTRC, & - NTRACE, IERR, IOTEST, I,J,K, IFI,IFJ,& - ISEA, IX, IY, TOUT(2), NOUT, TDUM(2),& - FTIME(2), CID, PID, GID, GDS, IOUT, & - GDTN - INTEGER, ALLOCATABLE :: IFIA(:),IFJA(:) + USE W3SERVMD, ONLY : STRACE +#endif + USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 + ! + USE W3GDATMD + USE W3WDATMD, ONLY: TIME, WLV, ICE, UST, USTDIR, RHOAIR + USE W3ADATMD + USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOGRP, NGRPP, IDOUT, UNDEF,& + FLOGRD, FNMPRE, NOSWLL, NOGE, FLOGD + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local variables + !/ + INTEGER :: NDSI, NDSM, NDSOG, NDSDAT, NDSTRC, & + NTRACE, IERR, IOTEST, I,J,K, IFI,IFJ,& + ISEA, IX, IY, TOUT(2), NOUT, TDUM(2),& + FTIME(2), CID, PID, GID, GDS, IOUT, & + GDTN + INTEGER, ALLOCATABLE :: IFIA(:),IFJA(:) #ifdef W3_NOGRB - INTEGER :: KPDS(1), KGDS(1) + INTEGER :: KPDS(1), KGDS(1) #endif -! GRIB2 specific variables + ! GRIB2 specific variables #ifdef W3_NCEP2 - INTEGER :: KPDS(200), KGDS(200), IDRS(200) - INTEGER :: LISTSEC0(3), LISTSEC1(13),IGDS(5) - INTEGER :: IDEFLIST, IDEFNUM, KPDSNUM, NUMCOORD - INTEGER :: IBMP, LCGRIB, LENGRIB, IDRSNUM - REAL :: COORDLIST, XN - CHARACTER(LEN=1), ALLOCATABLE :: CGRIB(:) - INTEGER :: LATAN1, LONV, SCNMOD, LATIN1, & - LATIN2, LATSP, LONSP - REAL :: DSX, DSY - REAL :: YN, X0N, Y0N + INTEGER :: KPDS(200), KGDS(200), IDRS(200) + INTEGER :: LISTSEC0(3), LISTSEC1(13),IGDS(5) + INTEGER :: IDEFLIST, IDEFNUM, KPDSNUM, NUMCOORD + INTEGER :: IBMP, LCGRIB, LENGRIB, IDRSNUM + REAL :: COORDLIST, XN + CHARACTER(LEN=1), ALLOCATABLE :: CGRIB(:) + INTEGER :: LATAN1, LONV, SCNMOD, LATIN1, & + LATIN2, LATSP, LONSP + REAL :: DSX, DSY + REAL :: YN, X0N, Y0N #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: DTREQ, DTEST, RFTIME - LOGICAL :: FLREQ(NOGRP,NGRPP), FLGRIB(NOGRP,NGRPP) - CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11 - CHARACTER(LEN=80) :: LINEIN - CHARACTER(LEN=8) :: WORDS(5) - INTEGER :: GEN_PRO + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: DTREQ, DTEST, RFTIME + LOGICAL :: FLREQ(NOGRP,NGRPP), FLGRIB(NOGRP,NGRPP) + CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11 + CHARACTER(LEN=80) :: LINEIN + CHARACTER(LEN=8) :: WORDS(5) + INTEGER :: GEN_PRO -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_NCO -! CALL W3TAGB('WAVEGRIB',1998,0007,0050,'NP21 ') -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. IO set-up. -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! - NDSI = 10 - NDSM = 20 - NDSOG = 20 - NDSDAT = 50 -! - NDSTRC = 6 - NTRACE = 10 -! + ! CALL W3TAGB('WAVEGRIB',1998,0007,0050,'NP21 ') +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1. IO set-up. + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + NDSI = 10 + NDSM = 20 + NDSOG = 20 + NDSDAT = 50 + ! + NDSTRC = 6 + NTRACE = 10 + ! #ifdef W3_NCO -! -! Redo according to NCO -! - NDSI = 11 - NDSO = 6 - NDSE = NDSO - NDST = NDSO - NDSM = 12 - NDSOG = 13 - NDSDAT = 51 - NDSTRC = NDSO -#endif -! - WRITE (NDSO,900) -! - CALL ITRACE ( NDSTRC, NTRACE ) + ! + ! Redo according to NCO + ! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSOG = 13 + NDSDAT = 51 + NDSTRC = NDSO +#endif + ! + WRITE (NDSO,900) + ! + CALL ITRACE ( NDSTRC, NTRACE ) #ifdef W3_S - CALL STRACE (IENT, 'W3GRIB') -#endif -! - OPEN (NDSI,FILE='ww3_grib.inp',STATUS='OLD',ERR=800,IOSTAT=IERR) - READ (NDSI,'(A)',END=801,ERR=802) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR -! + CALL STRACE (IENT, 'W3GRIB') +#endif + ! + OPEN (NDSI,FILE='ww3_grib.inp',STATUS='OLD',ERR=800,IOSTAT=IERR) + READ (NDSI,'(A)',END=801,ERR=802) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + ! #ifdef W3_NOGRB - WRITE (NDSE,902) -#endif -#ifdef W3_NCEP2 - CALL BAOPENW (NDSDAT,'gribfile',IERR) -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - WRITE (NDSO,920) GNAME -! - IF ( .NOT. FLAGLL ) GOTO 810 -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read requests from input file. -! Output times -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,'(A)') LINEIN - WRITE(NDSO,*)' LINEIN: ',LINEIN - READ(LINEIN,*,iostat=ierr) WORDS - WRITE (NDSO,*) WORDS - READ(WORDS( 1 ), * ) TOUT(1) - READ(WORDS( 2 ), * ) TOUT(2) - READ(WORDS( 3 ), * ) DTREQ - READ(WORDS( 4 ), * ) NOUT - IF (WORDS(5) .NE. '0' .AND. WORDS(5) .NE. '1') THEN - GEN_PRO=-99999 - ELSE - READ(WORDS( 5 ), * ) GEN_PRO - ENDIF - WRITE(NDSO,*) 'GEN_PRO ',GEN_PRO - DTREQ = MAX ( 0. , DTREQ ) - IF ( DTREQ.EQ.0 ) NOUT = 1 - NOUT = MAX ( 1 , NOUT ) -! - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,940) IDTIME -! - TDUM(1) = 0 - TDUM(2) = 0 - CALL TICK21 ( TDUM , DTREQ ) - CALL STME21 ( TDUM , IDTIME ) - IF ( DTREQ .GE. 86400. ) THEN - WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) - ELSE - IDDDAY = ' ' - END IF - IDTIME(1:11) = IDDDAY - IDTIME(21:23) = ' ' - WRITE (NDSO,941) IDTIME, NOUT -! -! ... Initialize FLGRD array -! - FLREQ(:,:)=.FALSE. -! -! ... Call to interface for reading flags or namelists -! - CALL W3READFLGRD ( NDSI, NDSO, 9, NDSE, COMSTR, FLOGD, FLREQ, & - 1, 1, IERR ) -! -! Inform user of parameters that were requested but failed to make the -! grade, as they are not available for grib encoding, or are not -! included presently -! - WRITE (NDSO,944) -! Reset flags for variables not yet implemented in grib output -! interface -! -! - IFI = 3 ! Entire group Frequency-dependent parameters - DO IFJ = 1,NOGE(IFI) - IF ( FLREQ(IFI,IFJ) ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ), & - '*** NOT YET CODED INTO WW3_GRIB ***' - FLREQ(IFI,IFJ) = .FALSE. - END IF - END DO -! - IFI = 5 ! Atm-waves layer, all except for friction velocity - DO IFJ = 2,10 - IF ( FLREQ(IFI,IFJ) ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ), & - '*** NOT YET CODED INTO WW3_GRIB ***' - FLREQ(IFI,IFJ) = .FALSE. - END IF - END DO - DO IFI = 6,8 ! Entire groups wave-ocean interaction, wave-bottom - ! layer and spectrum parameters - DO IFJ = 1,NOGE(IFI) - IF ( FLREQ(IFI,IFJ) ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ), & - '*** NOT YET CODED INTO WW3_GRIB ***' - FLREQ(IFI,IFJ) = .FALSE. - END IF - END DO - END DO - IF ( FLREQ(9,5) ) THEN ! CFL number for K advection - WRITE (NDSO,946) IDOUT(9,5),'*** NOT YET CODED INTO WW3_GRIB ***' - FLREQ(9,5) = .FALSE. + WRITE (NDSE,902) +#endif +#ifdef W3_NCEP2 + CALL BAOPENW (NDSDAT,'gribfile',IERR) +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + WRITE (NDSO,920) GNAME + ! + IF ( .NOT. FLAGLL ) GOTO 810 + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read requests from input file. + ! Output times + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,'(A)') LINEIN + WRITE(NDSO,*)' LINEIN: ',LINEIN + READ(LINEIN,*,iostat=ierr) WORDS + WRITE (NDSO,*) WORDS + READ(WORDS( 1 ), * ) TOUT(1) + READ(WORDS( 2 ), * ) TOUT(2) + READ(WORDS( 3 ), * ) DTREQ + READ(WORDS( 4 ), * ) NOUT + IF (WORDS(5) .NE. '0' .AND. WORDS(5) .NE. '1') THEN + GEN_PRO=-99999 + ELSE + READ(WORDS( 5 ), * ) GEN_PRO + ENDIF + WRITE(NDSO,*) 'GEN_PRO ',GEN_PRO + DTREQ = MAX ( 0. , DTREQ ) + IF ( DTREQ.EQ.0 ) NOUT = 1 + NOUT = MAX ( 1 , NOUT ) + ! + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,940) IDTIME + ! + TDUM(1) = 0 + TDUM(2) = 0 + CALL TICK21 ( TDUM , DTREQ ) + CALL STME21 ( TDUM , IDTIME ) + IF ( DTREQ .GE. 86400. ) THEN + WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) + ELSE + IDDDAY = ' ' + END IF + IDTIME(1:11) = IDDDAY + IDTIME(21:23) = ' ' + WRITE (NDSO,941) IDTIME, NOUT + ! + ! ... Initialize FLGRD array + ! + FLREQ(:,:)=.FALSE. + ! + ! ... Call to interface for reading flags or namelists + ! + CALL W3READFLGRD ( NDSI, NDSO, 9, NDSE, COMSTR, FLOGD, FLREQ, & + 1, 1, IERR ) + ! + ! Inform user of parameters that were requested but failed to make the + ! grade, as they are not available for grib encoding, or are not + ! included presently + ! + WRITE (NDSO,944) + ! Reset flags for variables not yet implemented in grib output + ! interface + ! + ! + IFI = 3 ! Entire group Frequency-dependent parameters + DO IFJ = 1,NOGE(IFI) + IF ( FLREQ(IFI,IFJ) ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ), & + '*** NOT YET CODED INTO WW3_GRIB ***' + FLREQ(IFI,IFJ) = .FALSE. + END IF + END DO + ! + IFI = 5 ! Atm-waves layer, all except for friction velocity + DO IFJ = 2,10 + IF ( FLREQ(IFI,IFJ) ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ), & + '*** NOT YET CODED INTO WW3_GRIB ***' + FLREQ(IFI,IFJ) = .FALSE. + END IF + END DO + DO IFI = 6,8 ! Entire groups wave-ocean interaction, wave-bottom + ! layer and spectrum parameters + DO IFJ = 1,NOGE(IFI) + IF ( FLREQ(IFI,IFJ) ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ), & + '*** NOT YET CODED INTO WW3_GRIB ***' + FLREQ(IFI,IFJ) = .FALSE. END IF - IFI = 10 ! User defined parameters - DO IFJ = 1,NOGE(IFI) - IF ( FLREQ(IFI,IFJ) ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ), & - '*** NOT YET CODED INTO WW3_GRIB ***' - FLREQ(IFI,IFJ) = .FALSE. - END IF - END DO -! -! Compatibility with NCEP operational codes, same effect as old FLGRIB -! lists variables that have no code for variable names (not 100% -! correct in old codes... ) -! -! Chage this as parameters become available in grib2 tables -! - ALLOCATE ( IFIA (13), IFJA(13) ) + END DO + END DO + IF ( FLREQ(9,5) ) THEN ! CFL number for K advection + WRITE (NDSO,946) IDOUT(9,5),'*** NOT YET CODED INTO WW3_GRIB ***' + FLREQ(9,5) = .FALSE. + END IF + IFI = 10 ! User defined parameters + DO IFJ = 1,NOGE(IFI) + IF ( FLREQ(IFI,IFJ) ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ), & + '*** NOT YET CODED INTO WW3_GRIB ***' + FLREQ(IFI,IFJ) = .FALSE. + END IF + END DO + ! + ! Compatibility with NCEP operational codes, same effect as old FLGRIB + ! lists variables that have no code for variable names (not 100% + ! correct in old codes... ) + ! + ! Chage this as parameters become available in grib2 tables + ! + ALLOCATE ( IFIA (13), IFJA(13) ) - IFIA = (/ 1, 2, 2, 4, 4, 4, 4, 4, 5, 9, 9, 9, 9 /) - IFJA = (/ 4, 2, 8, 3, 5, 6, 7, 8, 1, 1, 2, 3, 4 /) - DO I = 1, 13 - IF ( FLREQ(IFIA(I),IFJA(I)) ) THEN - FLREQ(IFIA(I),IFJA(I)) = .FALSE. - WRITE(NDSO,946) IDOUT(IFIA(I),IFJA(I)), & - '*** EXCLUDED FROM GRIB OUTPUT ***' - END IF - END DO -! -! Write to stdout parameters that have successfully been requested -! - WRITE (NDSO,945) - DO I=1, NOGRP - DO J=1, NGRPP - IF ( FLREQ(I,J) ) WRITE (NDSO,931) IDOUT(I,J) - END DO - END DO -! -! -! -! ... GRIB specific parameters -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) FTIME, CID, PID, GID, GDS, GDTN -! -! Check if grid type is curvilinear, and only go on if Lambert conformal -! or PolarStereo -! - IF ( GTYPE .EQ. CLGTYPE ) THEN -#ifdef W3_NCEP2 -! Allowing code to work with Lambert conformal grids - IF ( GDTN .NE. 30 .AND. GDTN .NE. 20 ) THEN -#endif - WRITE(NDSE,*)'PROGRAM W3GRIB: CURVILINEAR GRID SUPPORT '// & - 'FOR GRIB OUTPUT IS NOT YET IMPLEMENTED. NOW STOPPING' - CALL EXTCDE ( 1 ) -#ifdef W3_NCEP2 - ENDIF -#endif - END IF -! -! -! Coded up to now only for Lamber conformal grids (GDTN=30) or -! PolarStereo (GDTN=20). For regular grids use GDTN=0 -! -#ifdef W3_NCEP2 - IF ( GDTN .EQ. 30 ) THEN -! This is a Lambert conformal grid, read projection parameters - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & - SCNMOD, LATIN1, LATIN2, LATSP, LONSP - ELSEIF ( GDTN .EQ. 20 ) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & - SCNMOD + IFIA = (/ 1, 2, 2, 4, 4, 4, 4, 4, 5, 9, 9, 9, 9 /) + IFJA = (/ 4, 2, 8, 3, 5, 6, 7, 8, 1, 1, 2, 3, 4 /) + DO I = 1, 13 + IF ( FLREQ(IFIA(I),IFJA(I)) ) THEN + FLREQ(IFIA(I),IFJA(I)) = .FALSE. + WRITE(NDSO,946) IDOUT(IFIA(I),IFJA(I)), & + '*** EXCLUDED FROM GRIB OUTPUT ***' + END IF + END DO + ! + ! Write to stdout parameters that have successfully been requested + ! + WRITE (NDSO,945) + DO I=1, NOGRP + DO J=1, NGRPP + IF ( FLREQ(I,J) ) WRITE (NDSO,931) IDOUT(I,J) + END DO + END DO + ! + ! + ! + ! ... GRIB specific parameters + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) FTIME, CID, PID, GID, GDS, GDTN + ! + ! Check if grid type is curvilinear, and only go on if Lambert conformal + ! or PolarStereo + ! + IF ( GTYPE .EQ. CLGTYPE ) THEN +#ifdef W3_NCEP2 + ! Allowing code to work with Lambert conformal grids + IF ( GDTN .NE. 30 .AND. GDTN .NE. 20 ) THEN +#endif + WRITE(NDSE,*)'PROGRAM W3GRIB: CURVILINEAR GRID SUPPORT '// & + 'FOR GRIB OUTPUT IS NOT YET IMPLEMENTED. NOW STOPPING' + CALL EXTCDE ( 1 ) +#ifdef W3_NCEP2 + ENDIF +#endif + END IF + ! + ! + ! Coded up to now only for Lamber conformal grids (GDTN=30) or + ! PolarStereo (GDTN=20). For regular grids use GDTN=0 + ! +#ifdef W3_NCEP2 + IF ( GDTN .EQ. 30 ) THEN + ! This is a Lambert conformal grid, read projection parameters + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & + SCNMOD, LATIN1, LATIN2, LATSP, LONSP + ELSEIF ( GDTN .EQ. 20 ) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & + SCNMOD #endif #ifdef W3_NCEP2 - ENDIF -#endif -! - CALL STME21 ( FTIME , IDTIME ) - WRITE (NDSO,948) IDTIME, CID, PID, GID, GDS -! -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Read general data and first fields from file -! 4.a Read file. -! - CALL W3IOGO ( 'READ', NDSOG, IOTEST ) -! -! 4.b Output fields in file -! -! - WRITE (NDSO,930) - DO I=1, NOGRP - DO J=1, NGRPP - IF ( FLOGRD(I,J) ) WRITE (NDSO,931) IDOUT(I,J) - END DO - END DO -! -#ifdef W3_NCEP2 -! - IF ( GDTN .EQ. 0 ) THEN -! -#endif -! 4.c Flip MAPSF for REGULAR/RECTILINEAR grids -! - DO ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - MAPSF(ISEA,2) = NY + 1 - IY - MAPSF(ISEA,3) = IY +( IX-1)*NY - END DO -#ifdef W3_NCEP2 -! - ENDIF -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Set grib encoding parameter Sections -! -! ... Initialize KPDS and KGDS (for NCEP2) -! - KPDS = 0 - KGDS = 0 -! -! ... Set GRIB2 packing arrays -! -#ifdef W3_NCEP2 - LCGRIB = 4*NX*NY - ALLOCATE(CGRIB(LCGRIB)) -#endif -! -! ... Set GRIB2 Indicator Section -! ( 1) Discipline-GRIB Master Table Number (see Code Table 0.0) -! 0 = Metereological; 10 = Oceanographic -! ( 2) GRIB Edition Number -! ( 3) -#ifdef W3_NCEP2 - LISTSEC0 = 0 - LISTSEC0(1) = 10 - LISTSEC0(2) = 2 -#endif -! -! ... Set GRIB2 Identification Section -! ( 1) ID OF CENTER -! ( 2) ID OF SUB-CENTER -! ( 3) GRIB Master Tables Version Number (Code Table 1.0) -! ( 4) GRIB Local Tables Version Number (Code Table 1.0) -! ( 5) Significance of Reference Time (Code Table 1.2) -! * ( 6) YEAR (4 digits) -! * ( 7) MONTH OF YEAR -! * ( 8) DAY OF MONTH -! * ( 9) HOUR OF DAY -! (10) MINUTE OF HOUR -! (11) SECOND OF MINUTE -! (12) Production status of data (Code Table 1.3) -! (13) Type of processed data (Code Table 1.4) -! -#ifdef W3_NCEP2 - LISTSEC1 = 0 - LISTSEC1(1) = CID - LISTSEC1(3) = 2 - LISTSEC1(4) = 1 - LISTSEC1(5) = 1 - LISTSEC1(13) = 1 -#endif -! -! ... Set GRIB2 IGDS elements -! ( 1) Source of grid definition (Code Table 3.0) -! ( 2) Number of grid points -! ( 3) Number of octets needed for each additional grid points definition -! ( 4) Interpretation of list for optional points definition (Code Table 3.11) -! ( 5) Grid definition template number (Code Table 3.1) -! -#ifdef W3_NCEP2 - IGDS = 0 ! Defined in code - IGDS(2) = NX*NY - IDEFNUM = 0 - IDEFLIST = 0 - IGDS(5)=GDTN - IF ( GDTN .EQ. 30 .AND. GTYPE .EQ. CLGTYPE ) THEN - IDEFNUM = 1 - WRITE (NDSO,1011) 'LAMBERTCONF' - ELSEIF ( GDTN .EQ. 20 .AND. GTYPE .EQ. CLGTYPE ) THEN - WRITE (NDSO,1011) 'POLARSTEREO' - ELSEIF ( GDTN .EQ. 0 ) THEN - WRITE (NDSO,1011) 'LLRECTILINEAR' - ELSE - WRITE(NDSE,*)'PROGRAM WAVEGRIB2: SUPPORT FOR CHOSEN '// & + ENDIF +#endif + ! + CALL STME21 ( FTIME , IDTIME ) + WRITE (NDSO,948) IDTIME, CID, PID, GID, GDS + ! + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Read general data and first fields from file + ! 4.a Read file. + ! + CALL W3IOGO ( 'READ', NDSOG, IOTEST ) + ! + ! 4.b Output fields in file + ! + ! + WRITE (NDSO,930) + DO I=1, NOGRP + DO J=1, NGRPP + IF ( FLOGRD(I,J) ) WRITE (NDSO,931) IDOUT(I,J) + END DO + END DO + ! +#ifdef W3_NCEP2 + ! + IF ( GDTN .EQ. 0 ) THEN + ! +#endif + ! 4.c Flip MAPSF for REGULAR/RECTILINEAR grids + ! + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + MAPSF(ISEA,2) = NY + 1 - IY + MAPSF(ISEA,3) = IY +( IX-1)*NY + END DO +#ifdef W3_NCEP2 + ! + ENDIF +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Set grib encoding parameter Sections + ! + ! ... Initialize KPDS and KGDS (for NCEP2) + ! + KPDS = 0 + KGDS = 0 + ! + ! ... Set GRIB2 packing arrays + ! +#ifdef W3_NCEP2 + LCGRIB = 4*NX*NY + ALLOCATE(CGRIB(LCGRIB)) +#endif + ! + ! ... Set GRIB2 Indicator Section + ! ( 1) Discipline-GRIB Master Table Number (see Code Table 0.0) + ! 0 = Metereological; 10 = Oceanographic + ! ( 2) GRIB Edition Number + ! ( 3) +#ifdef W3_NCEP2 + LISTSEC0 = 0 + LISTSEC0(1) = 10 + LISTSEC0(2) = 2 +#endif + ! + ! ... Set GRIB2 Identification Section + ! ( 1) ID OF CENTER + ! ( 2) ID OF SUB-CENTER + ! ( 3) GRIB Master Tables Version Number (Code Table 1.0) + ! ( 4) GRIB Local Tables Version Number (Code Table 1.0) + ! ( 5) Significance of Reference Time (Code Table 1.2) + ! * ( 6) YEAR (4 digits) + ! * ( 7) MONTH OF YEAR + ! * ( 8) DAY OF MONTH + ! * ( 9) HOUR OF DAY + ! (10) MINUTE OF HOUR + ! (11) SECOND OF MINUTE + ! (12) Production status of data (Code Table 1.3) + ! (13) Type of processed data (Code Table 1.4) + ! +#ifdef W3_NCEP2 + LISTSEC1 = 0 + LISTSEC1(1) = CID + LISTSEC1(3) = 2 + LISTSEC1(4) = 1 + LISTSEC1(5) = 1 + LISTSEC1(13) = 1 +#endif + ! + ! ... Set GRIB2 IGDS elements + ! ( 1) Source of grid definition (Code Table 3.0) + ! ( 2) Number of grid points + ! ( 3) Number of octets needed for each additional grid points definition + ! ( 4) Interpretation of list for optional points definition (Code Table 3.11) + ! ( 5) Grid definition template number (Code Table 3.1) + ! +#ifdef W3_NCEP2 + IGDS = 0 ! Defined in code + IGDS(2) = NX*NY + IDEFNUM = 0 + IDEFLIST = 0 + IGDS(5)=GDTN + IF ( GDTN .EQ. 30 .AND. GTYPE .EQ. CLGTYPE ) THEN + IDEFNUM = 1 + WRITE (NDSO,1011) 'LAMBERTCONF' + ELSEIF ( GDTN .EQ. 20 .AND. GTYPE .EQ. CLGTYPE ) THEN + WRITE (NDSO,1011) 'POLARSTEREO' + ELSEIF ( GDTN .EQ. 0 ) THEN + WRITE (NDSO,1011) 'LLRECTILINEAR' + ELSE + WRITE(NDSE,*)'PROGRAM WAVEGRIB2: SUPPORT FOR CHOSEN '// & 'GRIB2 GRID DEFINITION TEMPLATE NOT YET IMPLEMENTED' - CALL EXTCDE ( 2 ) - ENDIF -#endif -! -! ... Set GRIB2 KGDS elements -! -! General parameters for all grids -! ( 1) Coordinate system (6 = spherical coordinate system with radius of 6,371,229 m) -! ( 2) -! ( 3) -! ( 4) -! ( 5) -! ( 6) -! ( 7) -! ( 8) Number of points along parallel -! ( 9) Number of points along meridian -#ifdef W3_NCEP2 - KGDS( 1) = 6 - KGDS( 8) = NX - KGDS( 9) = NY -#endif -! -#ifdef W3_NCEP2 - IF ( GDTN .EQ. 30 ) THEN -#endif -! -! Lambert Conformal grid -! (10) Latitude of first grid point -! (11) Longitude of first grid point -! (12) Resolution and component flags -! (13) Latitude where DX and DY are specified -! (14) Longitude of orientation -! (15) Increment of longitude -! (16) Increment of latitude -! (17) Projection center flag -! (18) Scanning mode -! (19) First latitude of secant cone -! (20) Second latitude of secant cone -! (21) Latitude of southern pole -! (22) Longitude of southern pole -! -#ifdef W3_NCEP2 - X0 = MOD(XGRD(1,1) + 360.,360.) - XN = MOD(XGRD(NY,NX) + 360., 360.) - X0N = MOD(XGRD(NY,1) + 360., 360.) - KGDS(11)=NINT(1000000.*X0) - Y0 = YGRD(1,1) - YN = YGRD(NY,NX) - Y0N = YGRD(NY,1) - KGDS(10)=NINT(1000000.*Y0) - KGDS(12)=0 - KGDS(13)=DBLE(1000000.*LATAN1) - KGDS(14)=DBLE(1000000.*LONV) - KGDS(15)=NINT(1000000*DSX) - KGDS(16)=NINT(1000000*DSY) - KGDS(17)=0 - KGDS(18)=SCNMOD - KGDS(19)=DBLE(1000000.*LATIN1) - KGDS(20)=DBLE(1000000.*LATIN2) - KGDS(21)=DBLE(1000000.*LATSP) - KGDS(22)=DBLE(1000000.*LONSP) -#endif -! -#ifdef W3_NCEP2 - ELSEIF (GDTN .EQ. 20 ) THEN -#endif -! -! PolarStereo grid -! (10) Latitude of first grid point -! (11) Longitude of first grid point -! (12) Res and component flags -! (13) Latitude where DX and DY are specified -! (14) Longitude of orientation -! (15) Increment of longitude -! (16) Increment of latitude -! (17) Projection center flag -! (18) Scanning mode -! -! Projection for PolarStereo grid was changed from -! KGDS( 1) = 6 to KGDS( 1) = 5 (Earth assumed represented by WGS84 - -! Octet No 15 Table 3.2) -#ifdef W3_NCEP2 - KGDS( 1) = 5 - X0 = MOD(XGRD(1,1) + 360.,360.) - XN = MOD(XGRD(NY,NX) + 360., 360.) - X0N = MOD(XGRD(NY,1) + 360., 360.) - KGDS(11)=NINT(1000000.*X0) - Y0 = YGRD(1,1) - YN = YGRD(NY,NX) - Y0N = YGRD(NY,1) - KGDS(10)=NINT(1000000.*Y0) - KGDS(12)=0 - KGDS(13)=DBLE(1000000.*LATAN1) - KGDS(14)=DBLE(1000000.*LONV) - KGDS(15)=NINT(1000000*DSX) - KGDS(16)=NINT(1000000*DSY) - KGDS(17)=0 - KGDS(18)=SCNMOD -#endif -! -#ifdef W3_NCEP2 - ELSEIF (GDTN .EQ. 0 ) THEN -#endif -! -! Lat Lon rectilinear grid -! (10) -! (11) -! (12) Latitude of first grid point -! (13) Longitude of first grid point -! (14) Res and component flags -! (15) Latitude of last grid point -! (16) Longitude of last grid point -! (17) Increment of longitude -! (18) Increment of latitude -! (19) Scanning mode -! -#ifdef W3_NCEP2 - KGDS(12) = NINT(1000000.*(Y0+(REAL(NY-1)*SY))) - X0 = MOD(X0 + 360.,360.) - KGDS(13) = NINT(1000000.*X0) - KGDS(14) = 48 - KGDS(15) = NINT(1000000.*Y0) - XN = MOD(X0+REAL(NX-1)*SX + 360., 360.) - KGDS(16) = NINT(1000000.*XN) - KGDS(17) = NINT(1000000.*SX) - KGDS(18) = NINT(1000000.*SY) - ENDIF -#endif -! -! ... Set GRIB2 PDS elements -! KPDSNUM (0 indicates forecast at a horizontal level) -! ( 1) Parameter category (Code Table 4.1) -! For oceanographic products -- 0 = waves; 1 = currents; 2 = ice -! For atmospheric products -- 2 = momentum -! ( 2) Parameter number (Code Table 4.2) -! ( 3) Generating process (Code Table 4.3) -! ( 4) Background generating process identifier (center specific) -! ( 5) Process or model number -! ( 6) Hours of observational data cutoff after reference time -! ( 7) Minutes of observational data cutoff after reference time -! ( 8) Indicator of forecast time unit (Code Table 4.4) -! ( 9) Time range -! (10) Type of level (Code Table 4.5) 1st level -! (11) Scaled factor of (10) -! (12) Scaled value of (10) -! (13) Type of level (Code Table 4.5) 2nd level -! (14) Scaled factor of (13) -! (15) Scaled value of (13) -! -! -! KPDS(3)=4 ensemble forecast:ww3_grib.inp has gen_pro set to 1 -! =2 deterministic forecast: ww3_grib.inp gen_pro set to 0 -! =2 legacy :with no gen_pro set in ww3_grib.inp -! (in the case of legacy the params revert back to old names) -#ifdef W3_NCEP2 - KPDSNUM = 0 - if ( gen_pro.eq.1 ) then - KPDS( 3) = 4 - else - KPDS(3)=2 - endif - KPDS( 4) = 0 - KPDS( 5) = PID - KPDS( 8) = 1 - KPDS(10) = 1 - KPDS(12) = 1 - KPDS(13) = 255 -#endif -! -! ... Set GRIB2 vertical layer information -! -#ifdef W3_NCEP2 - NUMCOORD = 0 - COORDLIST = 0.0 -#endif -! -! ... Set GRIB2 bitmap information -! 0 Bitmap is provided -! -#ifdef W3_NCEP2 - IBMP = GDS -#endif -! -! ... Set GRIB2 Data Representation Template Number (Code Table 5.0) -! -#ifdef W3_NCEP2 - IDRSNUM = 40 !jpeg2000 *** SEGFAULTS in some linux -#endif -! clusters with Intel compiler *** -#ifdef W3_NCEP2 - !IDRSNUM = 0 !simple packing - !IDRSNUM = 41 !png packing - !IDRSNUM = 2 !Complex Packing (Grid Point Data) -#endif -! -! ... Set GRIB2 IDRS elements -! ( 1) Reference value (R) (IEEE 32-bit floating-point value) -! ( 2) Binary Scale Factor (E) -! ( 3) Decimal Scale Factor (D) -! ( 4) Number of bits used for each packed value -! ( 5) Type of original field values (Code Table 5.1) -! -#ifdef W3_NCEP2 - IDRS = 0 - IDRS(3) = 2 -#endif -! + CALL EXTCDE ( 2 ) + ENDIF +#endif + ! + ! ... Set GRIB2 KGDS elements + ! + ! General parameters for all grids + ! ( 1) Coordinate system (6 = spherical coordinate system with radius of 6,371,229 m) + ! ( 2) + ! ( 3) + ! ( 4) + ! ( 5) + ! ( 6) + ! ( 7) + ! ( 8) Number of points along parallel + ! ( 9) Number of points along meridian +#ifdef W3_NCEP2 + KGDS( 1) = 6 + KGDS( 8) = NX + KGDS( 9) = NY +#endif + ! +#ifdef W3_NCEP2 + IF ( GDTN .EQ. 30 ) THEN +#endif + ! + ! Lambert Conformal grid + ! (10) Latitude of first grid point + ! (11) Longitude of first grid point + ! (12) Resolution and component flags + ! (13) Latitude where DX and DY are specified + ! (14) Longitude of orientation + ! (15) Increment of longitude + ! (16) Increment of latitude + ! (17) Projection center flag + ! (18) Scanning mode + ! (19) First latitude of secant cone + ! (20) Second latitude of secant cone + ! (21) Latitude of southern pole + ! (22) Longitude of southern pole + ! +#ifdef W3_NCEP2 + X0 = MOD(XGRD(1,1) + 360.,360.) + XN = MOD(XGRD(NY,NX) + 360., 360.) + X0N = MOD(XGRD(NY,1) + 360., 360.) + KGDS(11)=NINT(1000000.*X0) + Y0 = YGRD(1,1) + YN = YGRD(NY,NX) + Y0N = YGRD(NY,1) + KGDS(10)=NINT(1000000.*Y0) + KGDS(12)=0 + KGDS(13)=DBLE(1000000.*LATAN1) + KGDS(14)=DBLE(1000000.*LONV) + KGDS(15)=NINT(1000000*DSX) + KGDS(16)=NINT(1000000*DSY) + KGDS(17)=0 + KGDS(18)=SCNMOD + KGDS(19)=DBLE(1000000.*LATIN1) + KGDS(20)=DBLE(1000000.*LATIN2) + KGDS(21)=DBLE(1000000.*LATSP) + KGDS(22)=DBLE(1000000.*LONSP) +#endif + ! +#ifdef W3_NCEP2 + ELSEIF (GDTN .EQ. 20 ) THEN +#endif + ! + ! PolarStereo grid + ! (10) Latitude of first grid point + ! (11) Longitude of first grid point + ! (12) Res and component flags + ! (13) Latitude where DX and DY are specified + ! (14) Longitude of orientation + ! (15) Increment of longitude + ! (16) Increment of latitude + ! (17) Projection center flag + ! (18) Scanning mode + ! + ! Projection for PolarStereo grid was changed from + ! KGDS( 1) = 6 to KGDS( 1) = 5 (Earth assumed represented by WGS84 - + ! Octet No 15 Table 3.2) +#ifdef W3_NCEP2 + KGDS( 1) = 5 + X0 = MOD(XGRD(1,1) + 360.,360.) + XN = MOD(XGRD(NY,NX) + 360., 360.) + X0N = MOD(XGRD(NY,1) + 360., 360.) + KGDS(11)=NINT(1000000.*X0) + Y0 = YGRD(1,1) + YN = YGRD(NY,NX) + Y0N = YGRD(NY,1) + KGDS(10)=NINT(1000000.*Y0) + KGDS(12)=0 + KGDS(13)=DBLE(1000000.*LATAN1) + KGDS(14)=DBLE(1000000.*LONV) + KGDS(15)=NINT(1000000*DSX) + KGDS(16)=NINT(1000000*DSY) + KGDS(17)=0 + KGDS(18)=SCNMOD +#endif + ! +#ifdef W3_NCEP2 + ELSEIF (GDTN .EQ. 0 ) THEN +#endif + ! + ! Lat Lon rectilinear grid + ! (10) + ! (11) + ! (12) Latitude of first grid point + ! (13) Longitude of first grid point + ! (14) Res and component flags + ! (15) Latitude of last grid point + ! (16) Longitude of last grid point + ! (17) Increment of longitude + ! (18) Increment of latitude + ! (19) Scanning mode + ! +#ifdef W3_NCEP2 + KGDS(12) = NINT(1000000.*(Y0+(REAL(NY-1)*SY))) + X0 = MOD(X0 + 360.,360.) + KGDS(13) = NINT(1000000.*X0) + KGDS(14) = 48 + KGDS(15) = NINT(1000000.*Y0) + XN = MOD(X0+REAL(NX-1)*SX + 360., 360.) + KGDS(16) = NINT(1000000.*XN) + KGDS(17) = NINT(1000000.*SX) + KGDS(18) = NINT(1000000.*SY) + ENDIF +#endif + ! + ! ... Set GRIB2 PDS elements + ! KPDSNUM (0 indicates forecast at a horizontal level) + ! ( 1) Parameter category (Code Table 4.1) + ! For oceanographic products -- 0 = waves; 1 = currents; 2 = ice + ! For atmospheric products -- 2 = momentum + ! ( 2) Parameter number (Code Table 4.2) + ! ( 3) Generating process (Code Table 4.3) + ! ( 4) Background generating process identifier (center specific) + ! ( 5) Process or model number + ! ( 6) Hours of observational data cutoff after reference time + ! ( 7) Minutes of observational data cutoff after reference time + ! ( 8) Indicator of forecast time unit (Code Table 4.4) + ! ( 9) Time range + ! (10) Type of level (Code Table 4.5) 1st level + ! (11) Scaled factor of (10) + ! (12) Scaled value of (10) + ! (13) Type of level (Code Table 4.5) 2nd level + ! (14) Scaled factor of (13) + ! (15) Scaled value of (13) + ! + ! + ! KPDS(3)=4 ensemble forecast:ww3_grib.inp has gen_pro set to 1 + ! =2 deterministic forecast: ww3_grib.inp gen_pro set to 0 + ! =2 legacy :with no gen_pro set in ww3_grib.inp + ! (in the case of legacy the params revert back to old names) +#ifdef W3_NCEP2 + KPDSNUM = 0 + if ( gen_pro.eq.1 ) then + KPDS( 3) = 4 + else + KPDS(3)=2 + endif + KPDS( 4) = 0 + KPDS( 5) = PID + KPDS( 8) = 1 + KPDS(10) = 1 + KPDS(12) = 1 + KPDS(13) = 255 +#endif + ! + ! ... Set GRIB2 vertical layer information + ! +#ifdef W3_NCEP2 + NUMCOORD = 0 + COORDLIST = 0.0 +#endif + ! + ! ... Set GRIB2 bitmap information + ! 0 Bitmap is provided + ! +#ifdef W3_NCEP2 + IBMP = GDS +#endif + ! + ! ... Set GRIB2 Data Representation Template Number (Code Table 5.0) + ! +#ifdef W3_NCEP2 + IDRSNUM = 40 !jpeg2000 *** SEGFAULTS in some linux +#endif + ! clusters with Intel compiler *** +#ifdef W3_NCEP2 + !IDRSNUM = 0 !simple packing + !IDRSNUM = 41 !png packing + !IDRSNUM = 2 !Complex Packing (Grid Point Data) +#endif + ! + ! ... Set GRIB2 IDRS elements + ! ( 1) Reference value (R) (IEEE 32-bit floating-point value) + ! ( 2) Binary Scale Factor (E) + ! ( 3) Decimal Scale Factor (D) + ! ( 4) Number of bits used for each packed value + ! ( 5) Type of original field values (Code Table 5.1) + ! +#ifdef W3_NCEP2 + IDRS = 0 + IDRS(3) = 2 +#endif + ! #ifdef W3_T - WRITE (NDST,9050) KPDS - WRITE (NDST,9051) KGDS -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6. Time management. -! - IOUT = 0 - WRITE (NDSO,970) -! - DO - DTEST = DSEC21 ( TIME , TOUT ) - IF ( DTEST .GT. 0. ) THEN - CALL W3IOGO ( 'READ', NDSOG, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - WRITE (NDSO,942) - GOTO 888 - END IF - CYCLE - END IF - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF -! - IOUT = IOUT + 1 - CALL STME21 ( TOUT , IDTIME ) -! - RFTIME = DSEC21 ( FTIME , TIME ) / 3600. - IF ( RFTIME .LT. 0. ) THEN -#ifdef W3_NCEP2 - LISTSEC1( 6) = TIME(1)/10000 - LISTSEC1( 7) = MOD(TIME(1),10000) / 100 - LISTSEC1( 8) = MOD(TIME(1),100) - LISTSEC1( 9) = TIME(2) / 10000 - KPDS( 9) = 0 -#endif - WRITE (NDSO,972) IDTIME - ELSE -#ifdef W3_NCEP2 - LISTSEC1( 6) = FTIME(1)/10000 - LISTSEC1( 7) = MOD(FTIME(1),10000) / 100 - LISTSEC1( 8) = MOD(FTIME(1),100) - LISTSEC1( 9) = FTIME(2) / 10000 - KPDS( 9) = NINT(RFTIME) -#endif - WRITE (NDSO,971) IDTIME, NINT(RFTIME) - END IF -! - CALL W3EXGB ( NX, NY, NSEA ) - CALL TICK21 ( TOUT , DTREQ ) - IF ( IOUT .GE. NOUT ) EXIT - END DO -! - GOTO 888 -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 3 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 4 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 5 ) -! - 810 CONTINUE - IF ( .NOT. FLAGLL ) THEN - WRITE (NDSE,1010) - CALL EXTCDE ( 10 ) - END IF -! - 888 CONTINUE - WRITE (NDSO,999) -! + WRITE (NDST,9050) KPDS + WRITE (NDST,9051) KGDS +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6. Time management. + ! + IOUT = 0 + WRITE (NDSO,970) + ! + DO + DTEST = DSEC21 ( TIME , TOUT ) + IF ( DTEST .GT. 0. ) THEN + CALL W3IOGO ( 'READ', NDSOG, IOTEST ) + IF ( IOTEST .EQ. -1 ) THEN + WRITE (NDSO,942) + GOTO 888 + END IF + CYCLE + END IF + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF + ! + IOUT = IOUT + 1 + CALL STME21 ( TOUT , IDTIME ) + ! + RFTIME = DSEC21 ( FTIME , TIME ) / 3600. + IF ( RFTIME .LT. 0. ) THEN +#ifdef W3_NCEP2 + LISTSEC1( 6) = TIME(1)/10000 + LISTSEC1( 7) = MOD(TIME(1),10000) / 100 + LISTSEC1( 8) = MOD(TIME(1),100) + LISTSEC1( 9) = TIME(2) / 10000 + KPDS( 9) = 0 +#endif + WRITE (NDSO,972) IDTIME + ELSE +#ifdef W3_NCEP2 + LISTSEC1( 6) = FTIME(1)/10000 + LISTSEC1( 7) = MOD(FTIME(1),10000) / 100 + LISTSEC1( 8) = MOD(FTIME(1),100) + LISTSEC1( 9) = FTIME(2) / 10000 + KPDS( 9) = NINT(RFTIME) +#endif + WRITE (NDSO,971) IDTIME, NINT(RFTIME) + END IF + ! + CALL W3EXGB ( NX, NY, NSEA ) + CALL TICK21 ( TOUT , DTREQ ) + IF ( IOUT .GE. NOUT ) EXIT + END DO + ! + GOTO 888 + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 3 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 4 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 5 ) + ! +810 CONTINUE + IF ( .NOT. FLAGLL ) THEN + WRITE (NDSE,1010) + CALL EXTCDE ( 10 ) + END IF + ! +888 CONTINUE + WRITE (NDSO,999) + ! #ifdef W3_NCO -! CALL W3TAGE('WAVEGRIB') -#endif -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III GRIB output postp. *** '/ & - 15X,'=============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) - 902 FORMAT (/' *** WARNING : NO GRIB PACKAGE LINKED ***'/) -! - 920 FORMAT ( ' Grid name : ',A/) -! - 930 FORMAT ( ' Fields in file : '/ & - ' --------------------------') - 931 FORMAT ( ' ',A) -! - 940 FORMAT (/' Output time data : '/ & - ' -----------------------------------------------------'/ & - ' First time : ',A) - 941 FORMAT ( ' Interval : ',A/ & - ' Number of requests : ',I4) - 942 FORMAT (/' End of file reached '/) -! - 944 FORMAT (/' Requested output fields not yet available: '/ & - ' -----------------------------------------------------') -! - 945 FORMAT (/' Successfully requested output fields : '/ & - ' -----------------------------------------------------') - 946 FORMAT ( ' ',A,1X,A) -! - 948 FORMAT (/' Additional GRIB parameters : '/ & - ' -----------------------------------------------------'/ & - ' Run time : ',A/ & - ' GRIB center ID : ',I4/ & - ' GRIB gen. proc. ID : ',I4/ & - ' GRIB grid ID : ',I4/ & - ' GRIB GDS parameter : ',I4) -! - 970 FORMAT (//' Generating file '/ & - ' -----------------------------------------------------') - 971 FORMAT ( ' Data for ',A,' ',I3,'H forecast.') - 972 FORMAT ( ' Data for ',A,' hindcast.') -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III GRIB output '/) -! + ! CALL W3TAGE('WAVEGRIB') +#endif + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III GRIB output postp. *** '/ & + 15X,'=============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) +902 FORMAT (/' *** WARNING : NO GRIB PACKAGE LINKED ***'/) + ! +920 FORMAT ( ' Grid name : ',A/) + ! +930 FORMAT ( ' Fields in file : '/ & + ' --------------------------') +931 FORMAT ( ' ',A) + ! +940 FORMAT (/' Output time data : '/ & + ' -----------------------------------------------------'/ & + ' First time : ',A) +941 FORMAT ( ' Interval : ',A/ & + ' Number of requests : ',I4) +942 FORMAT (/' End of file reached '/) + ! +944 FORMAT (/' Requested output fields not yet available: '/ & + ' -----------------------------------------------------') + ! +945 FORMAT (/' Successfully requested output fields : '/ & + ' -----------------------------------------------------') +946 FORMAT ( ' ',A,1X,A) + ! +948 FORMAT (/' Additional GRIB parameters : '/ & + ' -----------------------------------------------------'/ & + ' Run time : ',A/ & + ' GRIB center ID : ',I4/ & + ' GRIB gen. proc. ID : ',I4/ & + ' GRIB grid ID : ',I4/ & + ' GRIB GDS parameter : ',I4) + ! +970 FORMAT (//' Generating file '/ & + ' -----------------------------------------------------') +971 FORMAT ( ' Data for ',A,' ',I3,'H forecast.') +972 FORMAT ( ' Data for ',A,' hindcast.') + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III GRIB output '/) + ! #ifdef W3_T - 9050 FORMAT ( ' TEST W3GRIB : KPDS : ',13I4/ & - ' ',12I4) - 9051 FORMAT ( ' TEST W3GRIB : KGDS : ',8I6/ & - ' ',8I6/ & - ' ',6I6) -#endif -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRIB : '/ & - ' GRIB REQUIRES SPHERICAL GRID'/) -#ifdef W3_NCEP2 - 1011 FORMAT (/' CHOSEN GRID TYPE: : ',A/) -#endif -!/ -!/ Internal subroutine W3EXGB ---------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> @brief Perform actual GRIB output. -!> -!> @param[in] NX X array dimension -!> @param[in] NY Y array dimension -!> @param[in] NSEA Seapoint array dimension -!> -!> @author H. L. Tolman -!> @author A. Chawla -!> @date 22-Mar-2021 - SUBROUTINE W3EXGB ( NX, NY, NSEA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | A. Chawla | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 10-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Massive changes to logistics. -!/ 29-Apr-2002 : Adding output fields 17-18. ( version 2.20 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 18-May-2007 : Update GRIB1 for partitioning. ( version 3.11 ) -!/ 16-Jul-2007 : Adding GRIB2 capability ( version 3.11 ) -!/ (A. Chawla) -!/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) -!/ -! 1. Purpose : -! -! Perform actual GRIB output. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NX, NY, NSEA -! Int. I Array dimensions. -! ---------------------------------------------------------------- -! -! Internal parameters -! ---------------------------------------------------------------- -! X1, X2, XX, XY -! R.A. Output fields -! BITMAP L.A. Data / no data bitmap -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Abort program as graceful as possible. -! W3S2XY Subr. Id. Convert from storage to spatial grid. -! PUTGB Subr. NCEP GRIB1 library routine. -! GRIBCREATE Subr. NCEP GRIB2 library routine. -! ADDGRID Subr. NCEP GRIB2 library routine. -! ADDFIELD Subr. NCEP GRIB2 library routine. -! GRIBEND Subr. NCEP GRIB2 library routine. -! WRYTE Subr. NCEP GRIB2 library routine. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Program in which it is contained. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Note that arrays CX and CY of the main program now contain -! the absolute current speed and direction respectively. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/NCEP2 NCEP IBM calls to GRIB2 packer (follows updated grib2 -! tables under verification as of 02/10/2012). -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY : W3S2XY +9050 FORMAT ( ' TEST W3GRIB : KPDS : ',13I4/ & + ' ',12I4) +9051 FORMAT ( ' TEST W3GRIB : KGDS : ',8I6/ & + ' ',8I6/ & + ' ',6I6) +#endif + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRIB : '/ & + ' GRIB REQUIRES SPHERICAL GRID'/) +#ifdef W3_NCEP2 +1011 FORMAT (/' CHOSEN GRID TYPE: : ',A/) +#endif + !/ + !/ Internal subroutine W3EXGB ---------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> @brief Perform actual GRIB output. + !> + !> @param[in] NX X array dimension + !> @param[in] NY Y array dimension + !> @param[in] NSEA Seapoint array dimension + !> + !> @author H. L. Tolman + !> @author A. Chawla + !> @date 22-Mar-2021 + SUBROUTINE W3EXGB ( NX, NY, NSEA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | A. Chawla | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 10-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Massive changes to logistics. + !/ 29-Apr-2002 : Adding output fields 17-18. ( version 2.20 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 18-May-2007 : Update GRIB1 for partitioning. ( version 3.11 ) + !/ 16-Jul-2007 : Adding GRIB2 capability ( version 3.11 ) + !/ (A. Chawla) + !/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Perform actual GRIB output. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NX, NY, NSEA + ! Int. I Array dimensions. + ! ---------------------------------------------------------------- + ! + ! Internal parameters + ! ---------------------------------------------------------------- + ! X1, X2, XX, XY + ! R.A. Output fields + ! BITMAP L.A. Data / no data bitmap + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! W3S2XY Subr. Id. Convert from storage to spatial grid. + ! PUTGB Subr. NCEP GRIB1 library routine. + ! GRIBCREATE Subr. NCEP GRIB2 library routine. + ! ADDGRID Subr. NCEP GRIB2 library routine. + ! ADDFIELD Subr. NCEP GRIB2 library routine. + ! GRIBEND Subr. NCEP GRIB2 library routine. + ! WRYTE Subr. NCEP GRIB2 library routine. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Program in which it is contained. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Note that arrays CX and CY of the main program now contain + ! the absolute current speed and direction respectively. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! !/NCEP2 NCEP IBM calls to GRIB2 packer (follows updated grib2 + ! tables under verification as of 02/10/2012). + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY : W3S2XY #ifdef W3_RTD - USE W3SERVMD, ONLY : W3THRTN, W3XYRTN -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NX, NY, NSEA -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, IXY, NDATA - INTEGER :: IO + USE W3SERVMD, ONLY : W3THRTN, W3XYRTN +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NX, NY, NSEA + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, IXY, NDATA + INTEGER :: IO #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: X1(NX*NY), X2(NX*NY), XX(NX*NY), & - XY(NX*NY), CABS, UABS, & - YY(NX*NY,0:NOSWLL), KPDS5A, KPDS5B, & - KPDS5A1(3) - LOGICAL*1 :: BITMAP(NX*NY) - LOGICAL :: FLONE, FLTWO, FLDIR, FLTRI, FLPRT -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: X1(NX*NY), X2(NX*NY), XX(NX*NY), & + XY(NX*NY), CABS, UABS, & + YY(NX*NY,0:NOSWLL), KPDS5A, KPDS5B, & + KPDS5A1(3) + LOGICAL*1 :: BITMAP(NX*NY) + LOGICAL :: FLONE, FLTWO, FLDIR, FLTRI, FLPRT + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3EXGB') + CALL STRACE (IENT, 'W3EXGB') #endif -! + ! #ifdef W3_T - WRITE (NDST,9000) ((FLREQ(IFI,IFJ),IFJ=1,NGRPP), IFI=1,NOGRP) - WRITE (NDST,9001) NDSDAT, KPDS, KGDS -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. Preparations -! - X1 = UNDEF - X2 = UNDEF - XX = UNDEF - XY = UNDEF - YY = UNDEF -! -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Loop over output fields. -! - DO IFI=1, NOGRP - DO IFJ=1, NGRPP + WRITE (NDST,9000) ((FLREQ(IFI,IFJ),IFJ=1,NGRPP), IFI=1,NOGRP) + WRITE (NDST,9001) NDSDAT, KPDS, KGDS +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1. Preparations + ! + X1 = UNDEF + X2 = UNDEF + XX = UNDEF + XY = UNDEF + YY = UNDEF + ! + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Loop over output fields. + ! + DO IFI=1, NOGRP + DO IFJ=1, NGRPP IF ( FLREQ(IFI,IFJ) ) THEN -! -! Initialize array dimension flags -! - FLONE = .FALSE. - FLTWO = .FALSE. - FLDIR = .FALSE. - FLTRI = .FALSE. - FLPRT = .FALSE. -! + ! + ! Initialize array dimension flags + ! + FLONE = .FALSE. + FLTWO = .FALSE. + FLDIR = .FALSE. + FLTRI = .FALSE. + FLPRT = .FALSE. + ! #ifdef W3_T - WRITE (NDST,9020) IDOUT(IFI,IFJ) -#endif -! -! 2.a Set output arrays and parameters -! -! Water depth -! - IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 14 - KPDS(1) = 4 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, DW(1:NSEA) & - , MAPSF, X1 ) -! -! Current -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN - FLTWO = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 1 - KPDS(1) = 1 + WRITE (NDST,9020) IDOUT(IFI,IFJ) +#endif + ! + ! 2.a Set output arrays and parameters + ! + ! Water depth + ! + IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 14 + KPDS(1) = 4 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, DW(1:NSEA) & + , MAPSF, X1 ) + ! + ! Current + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN + FLTWO = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 1 + KPDS(1) = 1 #endif #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX, CY, AnglD) -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, CX(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, CY(1:NSEA) & - , MAPSF, XY ) - DO ISEA=1, NSEA - IF (CX(ISEA) .NE. UNDEF) THEN - CABS = SQRT(CX(ISEA)**2+CY(ISEA)**2) - IF ( CABS .GT. 0.001 ) THEN - CY(ISEA) = MOD ( 630. - & - RADE*ATAN2(CY(ISEA),CX(ISEA)) , 360. ) - ELSE - CY(ISEA) = 0. - END IF - ELSE - CABS = UNDEF - CY(ISEA) = UNDEF - END IF - CX(ISEA) = CABS - END DO - CALL W3S2XY ( NSEA, NSEA, NX, NY, CX(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, CY(1:NSEA) & - , MAPSF, X2 ) -! -! Wind speed -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN - FLTWO = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 1 - KPDS(1) = 2 - LISTSEC0(1) = 0 + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX, CY, AnglD) +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, CX(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, CY(1:NSEA) & + , MAPSF, XY ) + DO ISEA=1, NSEA + IF (CX(ISEA) .NE. UNDEF) THEN + CABS = SQRT(CX(ISEA)**2+CY(ISEA)**2) + IF ( CABS .GT. 0.001 ) THEN + CY(ISEA) = MOD ( 630. - & + RADE*ATAN2(CY(ISEA),CX(ISEA)) , 360. ) + ELSE + CY(ISEA) = 0. + END IF + ELSE + CABS = UNDEF + CY(ISEA) = UNDEF + END IF + CX(ISEA) = CABS + END DO + CALL W3S2XY ( NSEA, NSEA, NX, NY, CX(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, CY(1:NSEA) & + , MAPSF, X2 ) + ! + ! Wind speed + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN + FLTWO = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 1 + KPDS(1) = 2 + LISTSEC0(1) = 0 #endif #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA, UD, AnglD) -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, UA(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, UD(1:NSEA) & - , MAPSF, XY ) - DO ISEA=1, NSEA - IF (UA(ISEA) .NE. UNDEF) THEN - UABS = SQRT(UA(ISEA)**2+UD(ISEA)**2) - IF ( UABS .GT. 0.001 ) THEN - UD(ISEA) = MOD ( 630. - & - RADE*ATAN2(UD(ISEA),UA(ISEA)) , 360. ) - ELSE - UD(ISEA) = 0. - END IF - ELSE - UABS = UNDEF - UD(ISEA) = UNDEF - END IF - UA(ISEA) = UABS - END DO - CALL W3S2XY ( NSEA, NSEA, NX, NY, UA(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, UD(1:NSEA) & - , MAPSF, X2 ) -! -! Air-sea temp. dif. -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 255 - KPDS(1) = 3 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, AS(1:NSEA) & - , MAPSF, X1 ) -! -! Water level -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 1 - KPDS(1) = 3 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, WLV , MAPSF, X1 ) -! -! Ice concentration -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 0 - KPDS(1) = 2 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, ICE , MAPSF, X1 ) -! -! Atmospheric momentum -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN - FLTWO = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 1 - KPDS(1) = 2 - LISTSEC0(1) = 0 + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA, UD, AnglD) +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, UA(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, UD(1:NSEA) & + , MAPSF, XY ) + DO ISEA=1, NSEA + IF (UA(ISEA) .NE. UNDEF) THEN + UABS = SQRT(UA(ISEA)**2+UD(ISEA)**2) + IF ( UABS .GT. 0.001 ) THEN + UD(ISEA) = MOD ( 630. - & + RADE*ATAN2(UD(ISEA),UA(ISEA)) , 360. ) + ELSE + UD(ISEA) = 0. + END IF + ELSE + UABS = UNDEF + UD(ISEA) = UNDEF + END IF + UA(ISEA) = UABS + END DO + CALL W3S2XY ( NSEA, NSEA, NX, NY, UA(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, UD(1:NSEA) & + , MAPSF, X2 ) + ! + ! Air-sea temp. dif. + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 255 + KPDS(1) = 3 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, AS(1:NSEA) & + , MAPSF, X1 ) + ! + ! Water level + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 1 + KPDS(1) = 3 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, WLV , MAPSF, X1 ) + ! + ! Ice concentration + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 0 + KPDS(1) = 2 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, ICE , MAPSF, X1 ) + ! + ! Atmospheric momentum + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN + FLTWO = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 1 + KPDS(1) = 2 + LISTSEC0(1) = 0 #endif #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUA, TAUADIR, AnglD) -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUA(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUADIR(1:NSEA) & - , MAPSF, XY ) - DO ISEA=1, NSEA - IF (TAUA(ISEA) .NE. UNDEF) THEN - UABS = SQRT(TAUA(ISEA)**2+TAUADIR(ISEA)**2) - IF ( UABS .GT. 0.001 ) THEN - TAUADIR(ISEA) = MOD ( 630. - & - RADE*ATAN2(TAUADIR(ISEA),TAUA(ISEA)) , 360. ) - ELSE - TAUADIR(ISEA) = 0. - END IF - ELSE - UABS = UNDEF - TAUADIR(ISEA) = UNDEF - END IF - TAUA(ISEA) = UABS - END DO - CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUA(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUADIR(1:NSEA) & - , MAPSF, X2 ) -! -! Air density -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 0 - KPDS(1) = 2 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, RHOAIR, MAPSF, X1 ) -! -! Significant wave height -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 3 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, HS , MAPSF, X1 ) -! -! Mean wave length -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 193 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, WLM , MAPSF, X1 ) -! -! Mean wave period (based on second moment) -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then - KPDS(2) = 28 - else - KPDS(2) = 25 - endif + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUA, TAUADIR, AnglD) +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUA(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUADIR(1:NSEA) & + , MAPSF, XY ) + DO ISEA=1, NSEA + IF (TAUA(ISEA) .NE. UNDEF) THEN + UABS = SQRT(TAUA(ISEA)**2+TAUADIR(ISEA)**2) + IF ( UABS .GT. 0.001 ) THEN + TAUADIR(ISEA) = MOD ( 630. - & + RADE*ATAN2(TAUADIR(ISEA),TAUA(ISEA)) , 360. ) + ELSE + TAUADIR(ISEA) = 0. + END IF + ELSE + UABS = UNDEF + TAUADIR(ISEA) = UNDEF + END IF + TAUA(ISEA) = UABS + END DO + CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUA(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUADIR(1:NSEA) & + , MAPSF, X2 ) + ! + ! Air density + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 0 + KPDS(1) = 2 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, RHOAIR, MAPSF, X1 ) + ! + ! Significant wave height + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 3 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, HS , MAPSF, X1 ) + ! + ! Mean wave length + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 193 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, WLM , MAPSF, X1 ) + ! + ! Mean wave period (based on second moment) + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS(2) = 28 + else + KPDS(2) = 25 + endif #endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, T02 , MAPSF, X1 ) -! -! Mean wave period (based on first moment) -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 15 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, T0M1 , MAPSF, X1 ) -! -! Mean wave period (based on first inverse moment) -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then - KPDS(2) = 34 - else - KPDS(2) = 15 - endif -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, T01 , MAPSF, X1 ) -! -! Peak frequency -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 6 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 11 -#endif - DO ISEA=1, NSEA - IF ( FP0(ISEA) .NE. UNDEF .AND. FP0(ISEA) .NE. 0 ) THEN - FP0(ISEA) = 1. / MAX(FR1,FP0(ISEA)) ! Limit FP to lowest discrete frequency - END IF - END DO - CALL W3S2XY ( NSEA, NSEA, NX, NY, FP0 , MAPSF, X1 ) -! -! -! Mean wave direction -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN - FLONE = .TRUE. + CALL W3S2XY ( NSEA, NSEA, NX, NY, T02 , MAPSF, X1 ) + ! + ! Mean wave period (based on first moment) + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 15 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, T0M1 , MAPSF, X1 ) + ! + ! Mean wave period (based on first inverse moment) + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS(2) = 34 + else + KPDS(2) = 15 + endif +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, T01 , MAPSF, X1 ) + ! + ! Peak frequency + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 6 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 11 +#endif + DO ISEA=1, NSEA + IF ( FP0(ISEA) .NE. UNDEF .AND. FP0(ISEA) .NE. 0 ) THEN + FP0(ISEA) = 1. / MAX(FR1,FP0(ISEA)) ! Limit FP to lowest discrete frequency + END IF + END DO + CALL W3S2XY ( NSEA, NSEA, NX, NY, FP0 , MAPSF, X1 ) + ! + ! + ! Mean wave direction + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN + FLONE = .TRUE. #ifdef W3_NCEP2 - KPDS(2) = 14 + KPDS(2) = 14 #endif #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) -#endif - DO ISEA=1, NSEA - IF ( THM(ISEA) .NE. UNDEF ) & - THM(ISEA) = MOD ( 630. - RADE*THM(ISEA) , 360. ) - END DO - CALL W3S2XY ( NSEA, NSEA, NX, NY, THM , MAPSF, X1 ) -! -! Directional spread -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 31 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, THS , MAPSF, X1 ) -! -! Peak direction -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then - KPDS(2) = 46 - else - KPDS(2) = 10 - endif + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) +#endif + DO ISEA=1, NSEA + IF ( THM(ISEA) .NE. UNDEF ) & + THM(ISEA) = MOD ( 630. - RADE*THM(ISEA) , 360. ) + END DO + CALL W3S2XY ( NSEA, NSEA, NX, NY, THM , MAPSF, X1 ) + ! + ! Directional spread + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 31 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, THS , MAPSF, X1 ) + ! + ! Peak direction + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS(2) = 46 + else + KPDS(2) = 10 + endif #endif #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) -#endif - DO ISEA=1, NSEA - IF ( THP0(ISEA) .NE. UNDEF ) THEN - THP0(ISEA) = MOD ( 630-RADE*THP0(ISEA) , 360. ) - END IF - END DO - CALL W3S2XY ( NSEA, NSEA, NX, NY, THP0 , MAPSF, X1 ) -! -! Mean wave number -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 255 + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) #endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, WNMEAN, MAPSF, X1 ) -! -! Partitioned wave height -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN - FLPRT = .TRUE. -#ifdef W3_NCEP2 - KPDS5A = 5 - KPDS5B = 8 - if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then - KPDS5A1(1) =47 - KPDS5A1(2) =48 - KPDS5A1(3) =49 - else - KPDS5B = 8 - endif -#endif - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PHS(:,0), MAPSF, YY(:,0) ) - DO I=1, NOSWLL - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PHS(:,I), MAPSF, YY(:,I) ) - END DO -! -! Partitioned peak period -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN - FLPRT = .TRUE. -#ifdef W3_NCEP2 - KPDS5A = 6 - KPDS5B = 9 - if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then - KPDS5A1(1) = 50 - KPDS5A1(2) = 51 - KPDS5A1(3) = 52 - else - KPDS5B = 9 - endif -#endif - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PTP(:,0), MAPSF, YY(:,0) ) - DO I=1, NOSWLL - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PTP(:,I), MAPSF, YY(:,I) ) - END DO -! -! Partitioned peak wave length -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN - FLPRT = .TRUE. -#ifdef W3_NCEP2 - KPDS5A = 193 - KPDS5B = 193 -#endif - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PLP(:,0), MAPSF, YY(:,0) ) - DO I=1, NOSWLL - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PLP(:,I), MAPSF, YY(:,I) ) - END DO -! -! Partitioned mean direction -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN - FLPRT = .TRUE. -#ifdef W3_NCEP2 - KPDS5A = 4 - KPDS5B = 7 - if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then - KPDS5A1(1) = 53 - KPDS5A1(2) = 54 - KPDS5A1(3) = 55 - else - KPDS5B = 7 - endif + DO ISEA=1, NSEA + IF ( THP0(ISEA) .NE. UNDEF ) THEN + THP0(ISEA) = MOD ( 630-RADE*THP0(ISEA) , 360. ) + END IF + END DO + CALL W3S2XY ( NSEA, NSEA, NX, NY, THP0 , MAPSF, X1 ) + ! + ! Mean wave number + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, WNMEAN, MAPSF, X1 ) + ! + ! Partitioned wave height + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN + FLPRT = .TRUE. +#ifdef W3_NCEP2 + KPDS5A = 5 + KPDS5B = 8 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS5A1(1) =47 + KPDS5A1(2) =48 + KPDS5A1(3) =49 + else + KPDS5B = 8 + endif +#endif + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PHS(:,0), MAPSF, YY(:,0) ) + DO I=1, NOSWLL + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PHS(:,I), MAPSF, YY(:,I) ) + END DO + ! + ! Partitioned peak period + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN + FLPRT = .TRUE. +#ifdef W3_NCEP2 + KPDS5A = 6 + KPDS5B = 9 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS5A1(1) = 50 + KPDS5A1(2) = 51 + KPDS5A1(3) = 52 + else + KPDS5B = 9 + endif +#endif + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PTP(:,0), MAPSF, YY(:,0) ) + DO I=1, NOSWLL + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PTP(:,I), MAPSF, YY(:,I) ) + END DO + ! + ! Partitioned peak wave length + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN + FLPRT = .TRUE. +#ifdef W3_NCEP2 + KPDS5A = 193 + KPDS5B = 193 +#endif + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PLP(:,0), MAPSF, YY(:,0) ) + DO I=1, NOSWLL + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PLP(:,I), MAPSF, YY(:,I) ) + END DO + ! + ! Partitioned mean direction + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN + FLPRT = .TRUE. +#ifdef W3_NCEP2 + KPDS5A = 4 + KPDS5B = 7 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS5A1(1) = 53 + KPDS5A1(2) = 54 + KPDS5A1(3) = 55 + else + KPDS5B = 7 + endif #endif #ifdef W3_RTD - DO I = 0,NOSWLL - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,I), AnglD, .FALSE.) - END DO -#endif - DO ISEA = 1,NSEA - DO I = 0,NOSWLL - IF ( PDIR(ISEA,I) .NE. UNDEF ) THEN - PDIR(ISEA,I) = MOD ( 630 - RADE*PDIR(ISEA,I) , 360. ) - END IF - END DO - END DO - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PDIR(:,0), MAPSF, YY(:,0) ) - DO I=1, NOSWLL - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PDIR(:,I), MAPSF, YY(:,I) ) - END DO -! -! Partitioned Directional spread -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN - FLPRT = .TRUE. -#ifdef W3_NCEP2 - KPDS5A = 32 - KPDS5B = 33 -#endif - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PSI(:,0), MAPSF, YY(:,0) ) - DO I=1, NOSWLL - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PSI(:,I), MAPSF, YY(:,I) ) - END DO -! -! Partitioned wind sea fraction -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN - FLPRT = .TRUE. -#ifdef W3_NCEP2 - KPDS5A = 255 - KPDS5B = 255 -#endif - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PWS(:,0), MAPSF, YY(:,0) ) - DO I=1, NOSWLL - CALL W3S2XY & - ( NSEA, NSEA, NX, NY, PWS(:,I), MAPSF, YY(:,I) ) - END DO -! -! Total wind sea fraction -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 255 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, PWST , MAPSF, X1 ) -! -! Number of fields in partition -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17 ) THEN - FLONE = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 255 -#endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, PNR , MAPSF, X1 ) -! -! Friction velocity -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN - FLTWO = .TRUE. -#ifdef W3_NCEP2 - KPDS(2) = 17 - KPDS(1) = 1 + DO I = 0,NOSWLL + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,I), AnglD, .FALSE.) + END DO +#endif + DO ISEA = 1,NSEA + DO I = 0,NOSWLL + IF ( PDIR(ISEA,I) .NE. UNDEF ) THEN + PDIR(ISEA,I) = MOD ( 630 - RADE*PDIR(ISEA,I) , 360. ) + END IF + END DO + END DO + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PDIR(:,0), MAPSF, YY(:,0) ) + DO I=1, NOSWLL + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PDIR(:,I), MAPSF, YY(:,I) ) + END DO + ! + ! Partitioned Directional spread + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN + FLPRT = .TRUE. +#ifdef W3_NCEP2 + KPDS5A = 32 + KPDS5B = 33 +#endif + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PSI(:,0), MAPSF, YY(:,0) ) + DO I=1, NOSWLL + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PSI(:,I), MAPSF, YY(:,I) ) + END DO + ! + ! Partitioned wind sea fraction + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN + FLPRT = .TRUE. +#ifdef W3_NCEP2 + KPDS5A = 255 + KPDS5B = 255 +#endif + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PWS(:,0), MAPSF, YY(:,0) ) + DO I=1, NOSWLL + CALL W3S2XY & + ( NSEA, NSEA, NX, NY, PWS(:,I), MAPSF, YY(:,I) ) + END DO + ! + ! Total wind sea fraction + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, PWST , MAPSF, X1 ) + ! + ! Number of fields in partition + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, PNR , MAPSF, X1 ) + ! + ! Friction velocity + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN + FLTWO = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 17 + KPDS(1) = 1 #endif #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST, USTDIR, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST, USTDIR, AnglD) +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, UST(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX, NY, USTDIR(1:NSEA) & + , MAPSF, X2 ) + ! + ! Average source term time step + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif + DO ISEA=1, NSEA + IF ( DTDYN(ISEA) .NE. UNDEF ) & + DTDYN(ISEA) = DTDYN(ISEA) / 60. + END DO + CALL W3S2XY ( NSEA, NSEA, NX, NY, DTDYN , MAPSF, X1 ) + ! + ! Cut-off frequency + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, FCUT , MAPSF, X1 ) + ! + ! CFL Maximum (in spatial space) + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLXYMAX , MAPSF, X1 ) + ! + ! CFL Maximum (in spectral space) + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif + CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLTHMAX , MAPSF, X1 ) + ! + ELSE + WRITE (NDSE,999) + CALL EXTCDE ( 1 ) + ! + END IF + ! + ! 3 Perform output + ! + NDATA = NX*NY + ! + ! 3.a Partitioned data + ! + IF ( FLPRT ) THEN + ! +#ifdef W3_NCEP2 + KPDS(2) = KPDS5A +#endif + DO IXY=1, NX*NY + BITMAP(IXY) = YY(IXY,0) .NE. UNDEF + END DO +#ifdef W3_NCEP2 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,YY(:,0), NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) #endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, UST(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX, NY, USTDIR(1:NSEA) & - , MAPSF, X2 ) -! -! Average source term time step -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN - FLONE = .TRUE. + ! #ifdef W3_NCEP2 - KPDS(2) = 255 + if ((gen_pro.eq.0) .or. (gen_pro.eq.1)) then + KPDS(10) = 241 #endif - DO ISEA=1, NSEA - IF ( DTDYN(ISEA) .NE. UNDEF ) & - DTDYN(ISEA) = DTDYN(ISEA) / 60. - END DO - CALL W3S2XY ( NSEA, NSEA, NX, NY, DTDYN , MAPSF, X1 ) -! -! Cut-off frequency -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN - FLONE = .TRUE. + DO I=1, NOSWLL #ifdef W3_NCEP2 - KPDS(2) = 255 + KPDS(2) = KPDS5A1(I) + KPDS(12) = I #endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, FCUT , MAPSF, X1 ) -! -! CFL Maximum (in spatial space) -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN - FLONE = .TRUE. + DO IXY=1, NX*NY + BITMAP(IXY) = YY(IXY,I) .NE. UNDEF + END DO #ifdef W3_NCEP2 - KPDS(2) = 255 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,YY(:,I), NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) #endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLXYMAX , MAPSF, X1 ) -! -! CFL Maximum (in spectral space) -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. + END DO #ifdef W3_NCEP2 - KPDS(2) = 255 + ELSE + KPDS(2) = KPDS5B + KPDS(10) = 241 #endif - CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLTHMAX , MAPSF, X1 ) -! - ELSE - WRITE (NDSE,999) - CALL EXTCDE ( 1 ) -! - END IF -! -! 3 Perform output -! - NDATA = NX*NY -! -! 3.a Partitioned data -! - IF ( FLPRT ) THEN -! + DO I=1, NOSWLL #ifdef W3_NCEP2 - KPDS(2) = KPDS5A + KPDS(12) = I #endif DO IXY=1, NX*NY - BITMAP(IXY) = YY(IXY,0) .NE. UNDEF - END DO + BITMAP(IXY) = YY(IXY,I) .NE. UNDEF + END DO #ifdef W3_NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) IF (IO .NE. 0) GOTO 810 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & - IDEFNUM, IO) + IDEFNUM, IO) IF (IO .NE. 0) GOTO 820 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & - COORDLIST, NUMCOORD, IDRSNUM, IDRS, & - 200,YY(:,0), NDATA, IBMP, BITMAP, IO) + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,YY(:,I), NDATA, IBMP, BITMAP, IO) IF (IO .NE. 0) GOTO 820 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) IF (IO .NE. 0) GOTO 830 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) #endif -! + END DO #ifdef W3_NCEP2 - if ((gen_pro.eq.0) .or. (gen_pro.eq.1)) then - KPDS(10) = 241 + ENDIF + KPDS(10) = 1 + KPDS(12) = 1 #endif - DO I=1, NOSWLL -#ifdef W3_NCEP2 - KPDS(2) = KPDS5A1(I) - KPDS(12) = I -#endif - DO IXY=1, NX*NY - BITMAP(IXY) = YY(IXY,I) .NE. UNDEF - END DO -#ifdef W3_NCEP2 - CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) - IF (IO .NE. 0) GOTO 810 - CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & - IDEFNUM, IO) - IF (IO .NE. 0) GOTO 820 - CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & - COORDLIST, NUMCOORD, IDRSNUM, IDRS, & - 200,YY(:,I), NDATA, IBMP, BITMAP, IO) - IF (IO .NE. 0) GOTO 820 - CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) - IF (IO .NE. 0) GOTO 830 - CALL WRYTE (NDSDAT, LENGRIB, CGRIB) -#endif - END DO -#ifdef W3_NCEP2 - ELSE - KPDS(2) = KPDS5B - KPDS(10) = 241 -#endif - DO I=1, NOSWLL -#ifdef W3_NCEP2 - KPDS(12) = I -#endif - DO IXY=1, NX*NY - BITMAP(IXY) = YY(IXY,I) .NE. UNDEF - END DO -#ifdef W3_NCEP2 - CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) - IF (IO .NE. 0) GOTO 810 - CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & - IDEFNUM, IO) - IF (IO .NE. 0) GOTO 820 - CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & - COORDLIST, NUMCOORD, IDRSNUM, IDRS, & - 200,YY(:,I), NDATA, IBMP, BITMAP, IO) - IF (IO .NE. 0) GOTO 820 - CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) - IF (IO .NE. 0) GOTO 830 - CALL WRYTE (NDSDAT, LENGRIB, CGRIB) -#endif - END DO -#ifdef W3_NCEP2 - ENDIF - KPDS(10) = 1 - KPDS(12) = 1 -#endif -! -! 3.b Other data -! - ELSE IF (FLONE) THEN -! - DO IXY=1, NX*NY - BITMAP(IXY) = X1(IXY) .NE. UNDEF - END DO -! + ! + ! 3.b Other data + ! + ELSE IF (FLONE) THEN + ! + DO IXY=1, NX*NY + BITMAP(IXY) = X1(IXY) .NE. UNDEF + END DO + ! #ifdef W3_NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) IF (IO .NE. 0) GOTO 810 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & - IDEFNUM, IO) + IDEFNUM, IO) IF (IO .NE. 0) GOTO 820 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & - COORDLIST, NUMCOORD, IDRSNUM, IDRS, & - 200,X1, NDATA, IBMP, BITMAP, IO) + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,X1, NDATA, IBMP, BITMAP, IO) IF (IO .NE. 0) GOTO 820 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) IF (IO .NE. 0) GOTO 830 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) #endif -! - ELSE IF ( FLTWO ) THEN -! - DO IXY=1, NX*NY - BITMAP(IXY) = X1(IXY) .NE. UNDEF - END DO + ! + ELSE IF ( FLTWO ) THEN + ! + DO IXY=1, NX*NY + BITMAP(IXY) = X1(IXY) .NE. UNDEF + END DO #ifdef W3_NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) IF (IO .NE. 0) GOTO 810 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & - IDEFNUM, IO) + IDEFNUM, IO) IF (IO .NE. 0) GOTO 820 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & - COORDLIST, NUMCOORD, IDRSNUM, IDRS, & - 200,X1, NDATA, IBMP, BITMAP, IO) + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,X1, NDATA, IBMP, BITMAP, IO) IF (IO .NE. 0) GOTO 820 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) IF (IO .NE. 0) GOTO 830 @@ -1687,127 +1687,127 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) #endif #ifdef W3_NCEP2 - KPDS(2) = 0 - CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) - IF (IO .NE. 0) GOTO 810 - CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & - IDEFNUM, IO) - IF (IO .NE. 0) GOTO 820 - CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & - COORDLIST, NUMCOORD, IDRSNUM, IDRS, & - 200,X2, NDATA, IBMP, BITMAP, IO) - IF (IO .NE. 0) GOTO 820 - CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) - IF (IO .NE. 0) GOTO 830 - CALL WRYTE (NDSDAT, LENGRIB, CGRIB) - KPDS(2) = 2 - CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) - IF (IO .NE. 0) GOTO 810 - CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & - IDEFNUM, IO) - IF (IO .NE. 0) GOTO 820 - CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & - COORDLIST, NUMCOORD, IDRSNUM, IDRS, & - 200,XX, NDATA, IBMP, BITMAP, IO) - IF (IO .NE. 0) GOTO 820 - CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) - IF (IO .NE. 0) GOTO 830 - CALL WRYTE (NDSDAT, LENGRIB, CGRIB) - KPDS(2) = 3 - CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) - IF (IO .NE. 0) GOTO 810 - CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & - IDEFNUM, IO) - IF (IO .NE. 0) GOTO 820 - CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & - COORDLIST, NUMCOORD, IDRSNUM, IDRS, & - 200,XY, NDATA, IBMP, BITMAP, IO) - IF (IO .NE. 0) GOTO 820 - CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) - IF (IO .NE. 0) GOTO 830 - CALL WRYTE (NDSDAT, LENGRIB, CGRIB) -#endif -! - END IF -#ifdef W3_NCEP2 - LISTSEC0(1) = 10 - KPDS(1) = 0 + KPDS(2) = 0 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,X2, NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) + KPDS(2) = 2 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,XX, NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) + KPDS(2) = 3 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,XY, NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) #endif -! -! ... End of fields loop -! + ! END IF - END DO - END DO -! - RETURN -! -! Error escape locations -! #ifdef W3_NCEP2 - 810 CONTINUE - WRITE (NDSE,1010) IO - CALL EXTCDE ( 20 ) - 820 CONTINUE - WRITE (NDSE,1020) IO - CALL EXTCDE ( 30 ) - 830 CONTINUE - WRITE (NDSE,1030) IO - CALL EXTCDE ( 40 ) + LISTSEC0(1) = 10 + KPDS(1) = 0 #endif -! -! Formats -! - 999 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB :'/ & - ' PLEASE UPDATE FIELDS !!! '/) -! -#ifdef W3_NCEP2 - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & - ' ERROR IN OPENING OUTPUT FILE'/ & - ' IOSTAT =',I5/) -#endif -! -#ifdef W3_NCEP2 - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & - ' ERROR CREATING NEW GRIB2 FIELD'/ & - ' IOSTAT =',I5/) -#endif -! -#ifdef W3_NCEP2 - 1020 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & - ' ERROR ADDING GRIB2 FIELD'/ & - ' IOSTAT =',I5/) -#endif -! -#ifdef W3_NCEP2 - 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & - ' ERROR ENDING GRIB2 MESSAGE'/ & - ' IOSTAT =',I5/) -#endif -! + ! + ! ... End of fields loop + ! + END IF + END DO + END DO + ! + RETURN + ! + ! Error escape locations + ! +#ifdef W3_NCEP2 +810 CONTINUE + WRITE (NDSE,1010) IO + CALL EXTCDE ( 20 ) +820 CONTINUE + WRITE (NDSE,1020) IO + CALL EXTCDE ( 30 ) +830 CONTINUE + WRITE (NDSE,1030) IO + CALL EXTCDE ( 40 ) +#endif + ! + ! Formats + ! +999 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB :'/ & + ' PLEASE UPDATE FIELDS !!! '/) + ! +#ifdef W3_NCEP2 +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & + ' ERROR IN OPENING OUTPUT FILE'/ & + ' IOSTAT =',I5/) +#endif + ! +#ifdef W3_NCEP2 +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & + ' ERROR CREATING NEW GRIB2 FIELD'/ & + ' IOSTAT =',I5/) +#endif + ! +#ifdef W3_NCEP2 +1020 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & + ' ERROR ADDING GRIB2 FIELD'/ & + ' IOSTAT =',I5/) +#endif + ! +#ifdef W3_NCEP2 +1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & + ' ERROR ENDING GRIB2 MESSAGE'/ & + ' IOSTAT =',I5/) +#endif + ! #ifdef W3_T - 9000 FORMAT (' TEST W3EXGB : FLAGS :',40L2) - 9001 FORMAT (' TEST W3EXGB : NDSDAT :',I4/ & - ' KPDS :',13I4/ & - ' ',12I4/ & - ' KGDS :',8I6/ & - ' ',8I6/ & - ' ',6I6) -#endif -! +9000 FORMAT (' TEST W3EXGB : FLAGS :',40L2) +9001 FORMAT (' TEST W3EXGB : NDSDAT :',I4/ & + ' KPDS :',13I4/ & + ' ',12I4/ & + ' KGDS :',8I6/ & + ' ',8I6/ & + ' ',6I6) +#endif + ! #ifdef W3_T - 9012 FORMAT (' TEST W3EXGB : BLOK PARS : ',3I4) - 9014 FORMAT (' BASE NAME : ',A) +9012 FORMAT (' TEST W3EXGB : BLOK PARS : ',3I4) +9014 FORMAT (' BASE NAME : ',A) #endif -! + ! #ifdef W3_T - 9020 FORMAT (' TEST W3EXGB : OUTPUT FIELD : ',A) -#endif -!/ -!/ End of W3EXGB ----------------------------------------------------- / -!/ - END SUBROUTINE W3EXGB -!/ -!/ End of W3GRIB ----------------------------------------------------- / -!/ - END PROGRAM W3GRIB +9020 FORMAT (' TEST W3EXGB : OUTPUT FIELD : ',A) +#endif + !/ + !/ End of W3EXGB ----------------------------------------------------- / + !/ + END SUBROUTINE W3EXGB + !/ + !/ End of W3GRIB ----------------------------------------------------- / + !/ +END PROGRAM W3GRIB diff --git a/model/src/ww3_grid.F90 b/model/src/ww3_grid.F90 index bab1b6b20..8a70c9b8a 100644 --- a/model/src/ww3_grid.F90 +++ b/model/src/ww3_grid.F90 @@ -15,64 +15,63 @@ !> !> @author No author listed @date 27-May-2021 !/ ------------------------------------------------------------------- / - PROGRAM WW3GRID -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2021 | -!/ +-----------------------------------+ -!/ 27-May-2021 : Seperated subroutine to w3grid ( version 7.13 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! "Grid" preprocessing program, which writes a model definition -! file containing the model parameter settigs and grid data. -! -! 2. Method : -! -! Information is read from the file ww3_grid.inp/nml. -! A model definition file mod_def.ww3 is then produced by W3IOGR. -! Note that the name of the model definition file is set in W3IOGR. -! This is now all done in the subroutine W3GRID -! -! 3. Parameters : -! none -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3GRID Subr. W3GRIDMD creates mod_def file -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! 7. Remarks : -! See w3gridmd.ftn for details -! -! 8. Structure : -! Call subroutine W3GRID -! -! 9. Switches : -! none -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - - USE W3GRIDMD, ONLY: W3GRID - IMPLICIT NONE +PROGRAM WW3GRID + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 27-May-2021 | + !/ +-----------------------------------+ + !/ 27-May-2021 : Seperated subroutine to w3grid ( version 7.13 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! "Grid" preprocessing program, which writes a model definition + ! file containing the model parameter settigs and grid data. + ! + ! 2. Method : + ! + ! Information is read from the file ww3_grid.inp/nml. + ! A model definition file mod_def.ww3 is then produced by W3IOGR. + ! Note that the name of the model definition file is set in W3IOGR. + ! This is now all done in the subroutine W3GRID + ! + ! 3. Parameters : + ! none + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3GRID Subr. W3GRIDMD creates mod_def file + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! See w3gridmd.ftn for details + ! + ! 8. Structure : + ! Call subroutine W3GRID + ! + ! 9. Switches : + ! none + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / - CALL W3GRID + USE W3GRIDMD, ONLY: W3GRID + IMPLICIT NONE - END PROGRAM WW3GRID + CALL W3GRID +END PROGRAM WW3GRID diff --git a/model/src/ww3_gspl.F90 b/model/src/ww3_gspl.F90 index d1af64d30..344e38f6b 100644 --- a/model/src/ww3_gspl.F90 +++ b/model/src/ww3_gspl.F90 @@ -7,3459 +7,3459 @@ !> @brief Grid splitting program !> -!> @details Take an existing grid and create from this the grid data -!> for a set of overlapping grids to be used in the ww3_multi code +!> @details Take an existing grid and create from this the grid data +!> for a set of overlapping grids to be used in the ww3_multi code !> for hybid paralellization. !> !> @author H. L. Tolman @date 18-Nov-2013 !/ ------------------------------------------------------------------- / - PROGRAM W3GSPL -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 18-Nov-2013 | -!/ +-----------------------------------+ -!/ -!/ 24-Sep-2012 : Origination. ( version 4.10 ) -!/ 16-Jan-2013 : Add output of mask file (no halo). ( version 4.10 ) -!/ 19-Jan-2013 : Tweaking the template file. ( version 4.10 ) -!/ 24-Jan-2013 : Set up for minimum of 2 grids. ( version 4.10 ) -!/ Add XOFF to grid origin in X. -!/ Fix IDCLSE for partial grids. -!/ Add FRFLAG option to disable side-by-side -!/ running of grids in ww3_multi. -!/ 29-Jan-2013 : Add error code on stop. ( version 4.10 ) -!/ 31-Jan-2013 : Add routine GRLOST. ( version 4.10 ) -!/ 01-Feb-2013 : Speed up GRSEPA. ( version 4.10 ) -!/ Add dynamic trim range in GRTRIM. -!/ Speed up GRFILL. -!/ Add small grid merge (GRFSML) early in loop. -!/ 04-Feb-2013 : Testing on zero grid size added. ( version 4.10 ) -!/ Corner point in halo for GR1GRD. -!/ 04-Mar-2013 : Adding GrADS output. ( version 4.10 ) -!/ 05-Aug-2013 : Add UQ/UNO for distances. ( version 4.12 ) -!/ 18-Nov-2013 : Add user-defined halo extension. ( version 4.14 ) -!/ -!/ Copyright 2012-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Take an existing grid and create from this the grid data for a set -! of overlapping grids to be used in the ww3_multi code for hybid -! paralellization. -! -! 2. Method : -! -! See Section 8. -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! NDSI Int. Input unit number ("ww3_prep.inp"). -! NDSO Int. Output unit number. -! NDSE Int. Error unit number. -! NDST Int. Test output unit number. -! NDSM Int. Unit number for mod_def file. -! NG Int. Number of grids to be generated. -! NITMAX Int. Maximum number of iterations on grid ref. -! STARG Real std target in percent. -! GLOBAL Log. Closure flag. -! SEA L.A. Sea point map. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! -! GRINFO Subr. Internal Compile info on all grids. -! GRTRIM Subr. Internal Trim edges of grids. -! GRFILL Subr. Internal Fill unassigned space in grid. -! GRLOST Subr. Internal Assign "lost points". -! GRSQRG Subr. Internal Attempt to square-up grid. -! GRSNGL Subr. Internal Remove grid points that stick out. -! GRSEPA Subr. Internal Remove separated grid pieces. -! GRFSML Subr. Internal Deal with fixed minimum size. -! GRFLRG Subr. Internal Deal with fixed maximum size. -! GR1GRD Subr. Internal Extract single grid from map. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! ---------------------------------------------------- -! 1.a Number of models. -! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) -! b I-O setup. -! c Print heading(s). -! 2. Read model definition file. ( W3IOGR ) -! 3. Read options from file. -! 4. Generate first-guess map of sub-grids -! a Set up array -! b First cut with regular grid set up -! 1 Set up 'checkerboard' -! 2 Fill checkerboard -! 3 Remove smallest grids as necessary -! 4 Store first guess in MSPLIT -! 5. Refine map of sub-grids (no halo). -! a Set up loop. ( GRINFO ) -! b Remove small grids. ( GRFSML ) -! c Trim edges of grids ( GRTRIM ) -! ( GRFILL, GRLOST ) -! d Attempt to square-up grid ( GRINFO ) -! ( GRSQRG ) -! ( GRFILL, GRLOST ) -! e Remove mid-sea points sticking out of grid -! ( GRSNGL ) -! f Remove detached grid parts. ( GRSEPA ) -! g Recompute stats ( GRINFO ) -! h Optional GrADS output. -! i Test convergence -! Check if stuck on min or max. ( GRFSML ) -! ( GRFLRG ) -! j Test output -! 6. Output info for all sub grids. -! a Set up loop. ( GRINFO ) -! b Extract grid including halo. ( GR1GRD ) -! 7. End of program. -! ---------------------------------------------------- -! -! 9. Switches : -! -! !/PRn Select propgation scheme. -! -! !/O16 Generate GrADS output of grid partitioning. -! -! !/S Enable subroutine tracing. -! !/T Enable test output (main). -! !/T1 Enable test output (GRINFO). -! !/T2 Enable test output (GRFILL). -! !/T3 Enable test output (GRSNGL). -! !/T4 Enable test output (GRSEPA). -! !/T5 Enable test output (GRFSML). -! !/T6 Enable test output (GRFLRG). -! !/T7 Enable test output (GR1GRD). -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ -! USE W3GDATMD, ONLY: W3NMOD, W3SETG - USE W3ADATMD, ONLY: W3NAUX, W3SETA - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE - USE W3ARRYMD, ONLY : OUTA2I, OUTA2R +PROGRAM W3GSPL + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 18-Nov-2013 | + !/ +-----------------------------------+ + !/ + !/ 24-Sep-2012 : Origination. ( version 4.10 ) + !/ 16-Jan-2013 : Add output of mask file (no halo). ( version 4.10 ) + !/ 19-Jan-2013 : Tweaking the template file. ( version 4.10 ) + !/ 24-Jan-2013 : Set up for minimum of 2 grids. ( version 4.10 ) + !/ Add XOFF to grid origin in X. + !/ Fix IDCLSE for partial grids. + !/ Add FRFLAG option to disable side-by-side + !/ running of grids in ww3_multi. + !/ 29-Jan-2013 : Add error code on stop. ( version 4.10 ) + !/ 31-Jan-2013 : Add routine GRLOST. ( version 4.10 ) + !/ 01-Feb-2013 : Speed up GRSEPA. ( version 4.10 ) + !/ Add dynamic trim range in GRTRIM. + !/ Speed up GRFILL. + !/ Add small grid merge (GRFSML) early in loop. + !/ 04-Feb-2013 : Testing on zero grid size added. ( version 4.10 ) + !/ Corner point in halo for GR1GRD. + !/ 04-Mar-2013 : Adding GrADS output. ( version 4.10 ) + !/ 05-Aug-2013 : Add UQ/UNO for distances. ( version 4.12 ) + !/ 18-Nov-2013 : Add user-defined halo extension. ( version 4.14 ) + !/ + !/ Copyright 2012-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Take an existing grid and create from this the grid data for a set + ! of overlapping grids to be used in the ww3_multi code for hybid + ! paralellization. + ! + ! 2. Method : + ! + ! See Section 8. + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! NDSI Int. Input unit number ("ww3_prep.inp"). + ! NDSO Int. Output unit number. + ! NDSE Int. Error unit number. + ! NDST Int. Test output unit number. + ! NDSM Int. Unit number for mod_def file. + ! NG Int. Number of grids to be generated. + ! NITMAX Int. Maximum number of iterations on grid ref. + ! STARG Real std target in percent. + ! GLOBAL Log. Closure flag. + ! SEA L.A. Sea point map. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! W3SETO Subr. Id. Point to selected model for output. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! + ! GRINFO Subr. Internal Compile info on all grids. + ! GRTRIM Subr. Internal Trim edges of grids. + ! GRFILL Subr. Internal Fill unassigned space in grid. + ! GRLOST Subr. Internal Assign "lost points". + ! GRSQRG Subr. Internal Attempt to square-up grid. + ! GRSNGL Subr. Internal Remove grid points that stick out. + ! GRSEPA Subr. Internal Remove separated grid pieces. + ! GRFSML Subr. Internal Deal with fixed minimum size. + ! GRFLRG Subr. Internal Deal with fixed maximum size. + ! GR1GRD Subr. Internal Extract single grid from map. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! ---------------------------------------------------- + ! 1.a Number of models. + ! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) + ! b I-O setup. + ! c Print heading(s). + ! 2. Read model definition file. ( W3IOGR ) + ! 3. Read options from file. + ! 4. Generate first-guess map of sub-grids + ! a Set up array + ! b First cut with regular grid set up + ! 1 Set up 'checkerboard' + ! 2 Fill checkerboard + ! 3 Remove smallest grids as necessary + ! 4 Store first guess in MSPLIT + ! 5. Refine map of sub-grids (no halo). + ! a Set up loop. ( GRINFO ) + ! b Remove small grids. ( GRFSML ) + ! c Trim edges of grids ( GRTRIM ) + ! ( GRFILL, GRLOST ) + ! d Attempt to square-up grid ( GRINFO ) + ! ( GRSQRG ) + ! ( GRFILL, GRLOST ) + ! e Remove mid-sea points sticking out of grid + ! ( GRSNGL ) + ! f Remove detached grid parts. ( GRSEPA ) + ! g Recompute stats ( GRINFO ) + ! h Optional GrADS output. + ! i Test convergence + ! Check if stuck on min or max. ( GRFSML ) + ! ( GRFLRG ) + ! j Test output + ! 6. Output info for all sub grids. + ! a Set up loop. ( GRINFO ) + ! b Extract grid including halo. ( GR1GRD ) + ! 7. End of program. + ! ---------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/PRn Select propgation scheme. + ! + ! !/O16 Generate GrADS output of grid partitioning. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output (main). + ! !/T1 Enable test output (GRINFO). + ! !/T2 Enable test output (GRFILL). + ! !/T3 Enable test output (GRSNGL). + ! !/T4 Enable test output (GRSEPA). + ! !/T5 Enable test output (GRFSML). + ! !/T6 Enable test output (GRFLRG). + ! !/T7 Enable test output (GR1GRD). + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG + USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE + USE W3ARRYMD, ONLY : OUTA2I, OUTA2R #ifdef W3_S - USE W3SERVMD, ONLY : STRACE -#endif - USE W3IOGRMD, ONLY: W3IOGR -!/ - USE W3GDATMD - USE W3ODATMD, ONLY: NDSE, NDST, NDSO, FNMPRE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NDSI, NDSM, NDSTRC, NTRACE, J, IERR, & - NG, IX, IY, NGB, NGX, NGY, IG, IGG, & - IGX, IGY, IGY0, IGYN, IGX0, IGXN, & - MINGRD, MINNR, MINNXT, MINNNR, & - NITMAX, IIT, INGMIN, INGMAX, & - INGMNC, INGMXC, INGLAG, JJ, & - NSTDLG, MSTDLG = 5, NSEAT, J1, J2, & - J3, J4, J5, IDFM1, IDFM2, IDFM3, & - IDLA1, IDLA2, IDLA3, VSC3, NHEXT + USE W3SERVMD, ONLY : STRACE +#endif + USE W3IOGRMD, ONLY: W3IOGR + !/ + USE W3GDATMD + USE W3ODATMD, ONLY: NDSE, NDST, NDSO, FNMPRE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NDSI, NDSM, NDSTRC, NTRACE, J, IERR, & + NG, IX, IY, NGB, NGX, NGY, IG, IGG, & + IGX, IGY, IGY0, IGYN, IGX0, IGXN, & + MINGRD, MINNR, MINNXT, MINNNR, & + NITMAX, IIT, INGMIN, INGMAX, & + INGMNC, INGMXC, INGLAG, JJ, & + NSTDLG, MSTDLG = 5, NSEAT, J1, J2, & + J3, J4, J5, IDFM1, IDFM2, IDFM3, & + IDLA1, IDLA2, IDLA3, VSC3, NHEXT #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_O16 - INTEGER :: NDSG = 35, NTGRDS = 0 -#endif - INTEGER, ALLOCATABLE :: MSPLIT(:,:), MTEMP(:,:), INGRD(:) - REAL :: RATIO1, XMEAN, STARG, STDMIN, & - ZBDUM, ZBMIN, VSC1, VSC2, FRACL, FRACH - LOGICAL :: GLOBAL, OK, DONE, FRFLAG - LOGICAL, ALLOCATABLE :: ISNEXT(:), SEA(:,:) - CHARACTER(LEN=1) :: COMSTR - CHARACTER(LEN=3) :: G0ID - CHARACTER(LEN=4) :: IDGRID, IDCLSE, PTCLSE - CHARACTER(LEN=6) :: NRFMT - CHARACTER(LEN=11) :: FEXT, AEXT - CHARACTER(LEN=16) :: RFORM1, RFORM2, RFORM3 - CHARACTER(LEN=20) :: FNAME, INAME -! - TYPE STATS_GRID - LOGICAL :: STRADLE, INSTAT - INTEGER :: NPTS, NYL, NYH, NXL, NXH - END TYPE STATS_GRID -! - TYPE STATS_MEAN - INTEGER :: NMIN, NMAX - REAL :: RSTD - END TYPE STATS_MEAN -! - TYPE PART_GRID - INTEGER :: NX, NY, NSEA - INTEGER, POINTER :: MASK(:,:) - REAL :: X0, Y0, SX, SY - REAL, POINTER :: ZBIN(:,:), OBSX(:,:), OBSY(:,:) - LOGICAL :: GLOBAL - END TYPE PART_GRID -! - TYPE(STATS_GRID), POINTER :: GSTATS(:), GSTOLD(:) - TYPE(STATS_MEAN) :: MSTATS , MSTOLD - TYPE(PART_GRID), POINTER :: PGRID(:) -!/ -!/ ------------------------------------------------------------------- / -!/ -! 1.a Set number of models -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! -! 1.b IO set-up. -! - NDSI = 10 - NDSO = 6 - NDSE = 6 - NDST = 6 - NDSM = 11 -! - NDSTRC = 6 - NTRACE = 100 - CALL ITRACE ( NDSTRC, NTRACE ) -! + INTEGER :: NDSG = 35, NTGRDS = 0 +#endif + INTEGER, ALLOCATABLE :: MSPLIT(:,:), MTEMP(:,:), INGRD(:) + REAL :: RATIO1, XMEAN, STARG, STDMIN, & + ZBDUM, ZBMIN, VSC1, VSC2, FRACL, FRACH + LOGICAL :: GLOBAL, OK, DONE, FRFLAG + LOGICAL, ALLOCATABLE :: ISNEXT(:), SEA(:,:) + CHARACTER(LEN=1) :: COMSTR + CHARACTER(LEN=3) :: G0ID + CHARACTER(LEN=4) :: IDGRID, IDCLSE, PTCLSE + CHARACTER(LEN=6) :: NRFMT + CHARACTER(LEN=11) :: FEXT, AEXT + CHARACTER(LEN=16) :: RFORM1, RFORM2, RFORM3 + CHARACTER(LEN=20) :: FNAME, INAME + ! + TYPE STATS_GRID + LOGICAL :: STRADLE, INSTAT + INTEGER :: NPTS, NYL, NYH, NXL, NXH + END TYPE STATS_GRID + ! + TYPE STATS_MEAN + INTEGER :: NMIN, NMAX + REAL :: RSTD + END TYPE STATS_MEAN + ! + TYPE PART_GRID + INTEGER :: NX, NY, NSEA + INTEGER, POINTER :: MASK(:,:) + REAL :: X0, Y0, SX, SY + REAL, POINTER :: ZBIN(:,:), OBSX(:,:), OBSY(:,:) + LOGICAL :: GLOBAL + END TYPE PART_GRID + ! + TYPE(STATS_GRID), POINTER :: GSTATS(:), GSTOLD(:) + TYPE(STATS_MEAN) :: MSTATS , MSTOLD + TYPE(PART_GRID), POINTER :: PGRID(:) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! 1.a Set number of models + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + ! 1.b IO set-up. + ! + NDSI = 10 + NDSO = 6 + NDSE = 6 + NDST = 6 + NDSM = 11 + ! + NDSTRC = 6 + NTRACE = 100 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_O16 - OPEN ( NDSG, FILE='./ww3.ww3_gspl', form='UNFORMATTED', convert=file_endian) + OPEN ( NDSG, FILE='./ww3.ww3_gspl', form='UNFORMATTED', convert=file_endian) #endif -! -! 1.c Print header -! - WRITE (NDSO,900) + ! + ! 1.c Print header + ! + WRITE (NDSO,900) #ifdef W3_S - CALL STRACE (IENT, 'W3GSPL') -#endif -! - J = LEN_TRIM(FNMPRE) - OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_gspl.inp',STATUS='OLD', & - ERR=800,IOSTAT=IERR) - REWIND (NDSI) - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) FEXT -! - CALL W3IOGR ( 'READ', NDSM, 1, FEXT ) - CLOSE (NDSM) -! - WRITE (NDSO,902) FEXT, GNAME -! - SELECT CASE (GTYPE) - CASE (RLGTYPE) - WRITE ( NDSO,903) 'rectilinear' - IDGRID = 'RECT' - CASE (CLGTYPE) - WRITE ( NDSO,903) 'curvictilinear' - IDGRID = 'CURV' - CASE (UNGTYPE) - WRITE ( NDSO,903) 'unstructured' - IDGRID = 'UNST' - GOTO 820 - CASE DEFAULT - WRITE ( NDSO,903) 'not recognized' - GOTO 821 - END SELECT -! - SELECT CASE (ICLOSE) - CASE (ICLOSE_NONE) - WRITE ( NDSO,904) 'none' - IDCLSE = 'NONE' - GLOBAL = .FALSE. - CASE (ICLOSE_SMPL) - WRITE ( NDSO,904) 'global (simple)' - IDCLSE = 'SMPL' - GLOBAL = .TRUE. - CASE (ICLOSE_TRPL) - WRITE ( NDSO,904) 'global (tripolar)' - IDCLSE = 'TRPL' - GLOBAL = .TRUE. - GOTO 822 - CASE DEFAULT - WRITE ( NDSO,904) 'not recognized' - GOTO 823 - END SELECT -! - WRITE (NDSO,905) NX, NY, NSEA - IF ( NSEA .EQ. 0 ) GOTO 824 -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read options from input file. -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NG, NITMAX, STARG, NHEXT - NG = MAX ( 2, NG ) - NITMAX = MAX ( 1, NITMAX ) - STARG = MAX ( 0. , STARG ) - NHEXT = MAX ( 0, NHEXT ) - WRITE (NDSO,930) NG, NITMAX, STARG, NHEXT -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDLA1, IDFM1, & - VSC1, RFORM1 - IF (IDLA1.LT.1 .OR. IDLA1.GT.4) IDLA1 = 1 - IF (IDFM1.LT.1 .OR. IDFM1.GT.3) IDFM1 = 1 - IF ( ABS(VSC1) .LT. 1.E-15 ) VSC1 = 1. + CALL STRACE (IENT, 'W3GSPL') +#endif + ! + J = LEN_TRIM(FNMPRE) + OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_gspl.inp',STATUS='OLD', & + ERR=800,IOSTAT=IERR) + REWIND (NDSI) + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) FEXT + ! + CALL W3IOGR ( 'READ', NDSM, 1, FEXT ) + CLOSE (NDSM) + ! + WRITE (NDSO,902) FEXT, GNAME + ! + SELECT CASE (GTYPE) + CASE (RLGTYPE) + WRITE ( NDSO,903) 'rectilinear' + IDGRID = 'RECT' + CASE (CLGTYPE) + WRITE ( NDSO,903) 'curvictilinear' + IDGRID = 'CURV' + CASE (UNGTYPE) + WRITE ( NDSO,903) 'unstructured' + IDGRID = 'UNST' + GOTO 820 + CASE DEFAULT + WRITE ( NDSO,903) 'not recognized' + GOTO 821 + END SELECT + ! + SELECT CASE (ICLOSE) + CASE (ICLOSE_NONE) + WRITE ( NDSO,904) 'none' + IDCLSE = 'NONE' + GLOBAL = .FALSE. + CASE (ICLOSE_SMPL) + WRITE ( NDSO,904) 'global (simple)' + IDCLSE = 'SMPL' + GLOBAL = .TRUE. + CASE (ICLOSE_TRPL) + WRITE ( NDSO,904) 'global (tripolar)' + IDCLSE = 'TRPL' + GLOBAL = .TRUE. + GOTO 822 + CASE DEFAULT + WRITE ( NDSO,904) 'not recognized' + GOTO 823 + END SELECT + ! + WRITE (NDSO,905) NX, NY, NSEA + IF ( NSEA .EQ. 0 ) GOTO 824 + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read options from input file. + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NG, NITMAX, STARG, NHEXT + NG = MAX ( 2, NG ) + NITMAX = MAX ( 1, NITMAX ) + STARG = MAX ( 0. , STARG ) + NHEXT = MAX ( 0, NHEXT ) + WRITE (NDSO,930) NG, NITMAX, STARG, NHEXT + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDLA1, IDFM1, & + VSC1, RFORM1 + IF (IDLA1.LT.1 .OR. IDLA1.GT.4) IDLA1 = 1 + IF (IDFM1.LT.1 .OR. IDFM1.GT.3) IDFM1 = 1 + IF ( ABS(VSC1) .LT. 1.E-15 ) VSC1 = 1. + + WRITE (NDSO,931) IDLA1, IDFM1, VSC1, RFORM1 + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDLA2, IDFM2, & + VSC2, RFORM2 + IF (IDLA2.LT.1 .OR. IDLA2.GT.4) IDLA2 = 1 + IF (IDFM2.LT.1 .OR. IDFM2.GT.3) IDFM2 = 1 + IF ( ABS(VSC2) .LT. 1.E-15 ) VSC2 = 1. + IF ( TRFLAG .EQ. 0 ) THEN + WRITE (NDSO,932) + ELSE + WRITE (NDSO,933) IDLA2, IDFM2, VSC2, RFORM2 + END IF + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDLA3, IDFM3, & + VSC3, RFORM3 + IF (IDLA3.LT.1 .OR. IDLA3.GT.4) IDLA3 = 1 + IF (IDFM3.LT.1 .OR. IDFM3.GT.3) IDFM3 = 1 + IF ( VSC3 .EQ. 0 ) VSC3 = 1 + WRITE (NDSO,934) IDLA3, IDFM3, VSC3, RFORM3 + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) FRACL, FRACH, FRFLAG + FRACL = MAX ( 0. , FRACL ) + FRACH = MIN ( 1. , FRACH ) + WRITE (NDSO,935) FRACL, FRACH + IF ( FRACL .GT. FRACH ) GOTO 830 + IF ( .NOT. FRFLAG ) WRITE (NDSO,936) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Generate map of sub-grids (no halo) + ! 4.a Set up array + ! + ALLOCATE ( MSPLIT(NY,NX) , MTEMP(NY,NX), SEA(NY,NX) ) + ! + DO IY=1, NY + DO IX=1, NX + IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN + MSPLIT(IY,IX) = 0 + SEA (IY,IX) = .FALSE. + ELSE + MSPLIT(IY,IX) = -1 + SEA (IY,IX) = .TRUE. + END IF + END DO + END DO - WRITE (NDSO,931) IDLA1, IDFM1, VSC1, RFORM1 -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDLA2, IDFM2, & - VSC2, RFORM2 - IF (IDLA2.LT.1 .OR. IDLA2.GT.4) IDLA2 = 1 - IF (IDFM2.LT.1 .OR. IDFM2.GT.3) IDFM2 = 1 - IF ( ABS(VSC2) .LT. 1.E-15 ) VSC2 = 1. - IF ( TRFLAG .EQ. 0 ) THEN - WRITE (NDSO,932) + ! + ! 4.b First cut with regular grid set up + ! 4.b.1 Set up 'checkerboard' + ! + RATIO1 = REAL(NX) / REAL(NY) + ! + NGX = 1 + NGY = 1 + ! + DO + IF ( NGX*NGY .GE. NG ) EXIT + IF ( REAL(NGX)/REAL(NGY) .GT. RATIO1 ) THEN + NGY = NGY + 1 + ELSE + NGX = NGX + 1 + END IF + END DO + ! + IF ( NGX .GT. NGY ) THEN + IF ( (NGY-1)*NGX .GE. NG ) NGY = NGY - 1 + IF ( (NGX-1)*NGY .GE. NG ) NGX = NGX - 1 + ELSE + IF ( (NGY-1)*NGX .GE. NG ) NGY = NGY - 1 + IF ( (NGX-1)*NGY .GE. NG ) NGX = NGX - 1 + END IF + ! +#ifdef W3_T + WRITE (NDST,9040) NGX, NGY +#endif + ! + ! 4.b.2 Fill checkerboard + ! + J = 0 + DO + ! + MTEMP = MSPLIT + IG = 1 + IGYN = 0 + J = J + 1 + ALLOCATE ( INGRD(NGX*NGY) ) + INGRD = 0 + ! +#ifdef W3_T + WRITE (NDST,9041) J +#endif + ! + DO IGY=1, NGY + ! + IGY0 = IGYN + 1 + IF ( IGY .EQ. NGY ) THEN + IGYN = NY + ELSE + IGYN = NINT ( REAL(NY*IGY) / REAL(NGY) ) + END IF + IGXN = 0 + ! + DO IGX=1, NGX + ! + IGX0 = IGXN + 1 + IF ( IGX .EQ. NGX ) THEN + IGXN = NX ELSE - WRITE (NDSO,933) IDLA2, IDFM2, VSC2, RFORM2 + IGXN = NINT ( REAL(NX*IGX) / REAL(NGX) ) END IF -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDLA3, IDFM3, & - VSC3, RFORM3 - IF (IDLA3.LT.1 .OR. IDLA3.GT.4) IDLA3 = 1 - IF (IDFM3.LT.1 .OR. IDFM3.GT.3) IDFM3 = 1 - IF ( VSC3 .EQ. 0 ) VSC3 = 1 - WRITE (NDSO,934) IDLA3, IDFM3, VSC3, RFORM3 -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) FRACL, FRACH, FRFLAG - FRACL = MAX ( 0. , FRACL ) - FRACH = MIN ( 1. , FRACH ) - WRITE (NDSO,935) FRACL, FRACH - IF ( FRACL .GT. FRACH ) GOTO 830 - IF ( .NOT. FRFLAG ) WRITE (NDSO,936) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Generate map of sub-grids (no halo) -! 4.a Set up array -! - ALLOCATE ( MSPLIT(NY,NX) , MTEMP(NY,NX), SEA(NY,NX) ) -! - DO IY=1, NY - DO IX=1, NX - IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN - MSPLIT(IY,IX) = 0 - SEA (IY,IX) = .FALSE. - ELSE - MSPLIT(IY,IX) = -1 - SEA (IY,IX) = .TRUE. + ! + DO IX=IGX0, IGXN + DO IY=IGY0, IGYN + IF ( MTEMP(IY,IX) .EQ. -1 ) THEN + MTEMP(IY,IX) = IG + INGRD(IG) = INGRD(IG) + 1 END IF END DO END DO - -! -! 4.b First cut with regular grid set up -! 4.b.1 Set up 'checkerboard' -! - RATIO1 = REAL(NX) / REAL(NY) -! - NGX = 1 - NGY = 1 -! - DO - IF ( NGX*NGY .GE. NG ) EXIT - IF ( REAL(NGX)/REAL(NGY) .GT. RATIO1 ) THEN - NGY = NGY + 1 - ELSE - NGX = NGX + 1 - END IF - END DO -! - IF ( NGX .GT. NGY ) THEN - IF ( (NGY-1)*NGX .GE. NG ) NGY = NGY - 1 - IF ( (NGX-1)*NGY .GE. NG ) NGX = NGX - 1 + ! + IF ( INGRD(IG) .GT. 0 ) THEN +#ifdef W3_T + WRITE (NDST,9042) IG, IGX0, IGXN, IGY0, IGYN, & + INGRD(IG), 'OK' +#endif + IG = IG + 1 +#ifdef W3_T ELSE - IF ( (NGY-1)*NGX .GE. NG ) NGY = NGY - 1 - IF ( (NGX-1)*NGY .GE. NG ) NGX = NGX - 1 + WRITE (NDST,9042) IG, IGX0, IGXN, IGY0, IGYN, & + INGRD(IG), 'EMPTY (SKIPPED)' +#endif END IF -! + ! + END DO + ! + END DO + ! + IG = IG - 1 + IF ( IG .LT. NG ) THEN + IF ( NGX .LT. NGY ) THEN + NGY = NGY + 1 + ELSE + NGX = NGX + 1 + END IF + DEALLOCATE ( INGRD ) #ifdef W3_T WRITE (NDST,9040) NGX, NGY #endif -! -! 4.b.2 Fill checkerboard -! - J = 0 - DO -! - MTEMP = MSPLIT - IG = 1 - IGYN = 0 - J = J + 1 - ALLOCATE ( INGRD(NGX*NGY) ) - INGRD = 0 -! -#ifdef W3_T - WRITE (NDST,9041) J -#endif -! - DO IGY=1, NGY -! - IGY0 = IGYN + 1 - IF ( IGY .EQ. NGY ) THEN - IGYN = NY - ELSE - IGYN = NINT ( REAL(NY*IGY) / REAL(NGY) ) - END IF - IGXN = 0 -! - DO IGX=1, NGX -! - IGX0 = IGXN + 1 - IF ( IGX .EQ. NGX ) THEN - IGXN = NX - ELSE - IGXN = NINT ( REAL(NX*IGX) / REAL(NGX) ) - END IF -! - DO IX=IGX0, IGXN - DO IY=IGY0, IGYN - IF ( MTEMP(IY,IX) .EQ. -1 ) THEN - MTEMP(IY,IX) = IG - INGRD(IG) = INGRD(IG) + 1 - END IF - END DO - END DO -! - IF ( INGRD(IG) .GT. 0 ) THEN + ELSE + EXIT + END IF + ! + END DO + ! + MINGRD = 0 + DO J=1, IG + MINGRD = MINGRD + INGRD(J) + END DO + IF ( MINGRD .NE. NSEA ) GOTO 825 + ! #ifdef W3_T - WRITE (NDST,9042) IG, IGX0, IGXN, IGY0, IGYN, & - INGRD(IG), 'OK' -#endif - IG = IG + 1 + WRITE (NDST,9043) IG, NG +#endif + ! + ! 4.b.3 Merge smallest grids as necessary + ! + IGG = IG + ! + DO + ! + IF ( IGG .EQ. NG ) EXIT + ! + MINGRD = NSEA + MINNR = 0 + DO J=1, IG + IF ( INGRD(J) .LT. MINGRD ) THEN + MINGRD = INGRD(J) + MINNR = J + END IF + END DO + INGRD(MINNR) = NSEA + 1 + ! #ifdef W3_T - ELSE - WRITE (NDST,9042) IG, IGX0, IGXN, IGY0, IGYN, & - INGRD(IG), 'EMPTY (SKIPPED)' + WRITE (NDST,9044) MINGRD, MINNR #endif - END IF -! - END DO -! - END DO -! - IG = IG - 1 - IF ( IG .LT. NG ) THEN - IF ( NGX .LT. NGY ) THEN - NGY = NGY + 1 - ELSE - NGX = NGX + 1 - END IF - DEALLOCATE ( INGRD ) + ! + ALLOCATE ( ISNEXT(0:IG) ) + ISNEXT = .FALSE. + ! + DO IY=1, NY-1 + DO IX=1, NX-1 + IF ( ( MTEMP(IY ,IX ) - MINNR ) * & + ( MTEMP(IY+1,IX ) - MINNR ) * & + ( MTEMP(IY ,IX+1) - MINNR ) * & + ( MTEMP(IY+1,IX+1) - MINNR ) .EQ. 0 ) THEN + ISNEXT(MTEMP(IY ,IX )) = .TRUE. + ISNEXT(MTEMP(IY+1,IX )) = .TRUE. + ISNEXT(MTEMP(IY ,IX+1)) = .TRUE. + ISNEXT(MTEMP(IY+1,IX+1)) = .TRUE. + END IF + END DO + END DO + ! + IF ( GLOBAL ) THEN + DO IY=1, NY-1 + IF ( ( MTEMP(IY ,NX) - MINNR ) * & + ( MTEMP(IY+1,NX) - MINNR ) * & + ( MTEMP(IY , 1) - MINNR ) * & + ( MTEMP(IY+1, 1) - MINNR ) .EQ. 0 ) THEN + ISNEXT(MTEMP(IY ,NX)) = .TRUE. + ISNEXT(MTEMP(IY+1,NX)) = .TRUE. + ISNEXT(MTEMP(IY , 1)) = .TRUE. + ISNEXT(MTEMP(IY+1, 1)) = .TRUE. + END IF + END DO + END IF + ! + MINNXT = NSEA + MINNNR = 0 + DO J=1, IG + IF ( ISNEXT(J) .AND. ( INGRD(J) .LT. MINNXT ) ) THEN + MINNXT = INGRD(J) + MINNNR = J + END IF + END DO + ! #ifdef W3_T - WRITE (NDST,9040) NGX, NGY + WRITE (NDST,9045) MINNXT, MINNNR #endif - ELSE - EXIT + ! + IF ( MINNNR .GT. 0 ) THEN + DO IY=1, NY + DO IX=1, NX + IF ( MTEMP(IY,IX) .EQ. MINNR ) THEN + MTEMP(IY,IX) = MINNNR + INGRD(MINNNR) = INGRD(MINNNR) + 1 END IF -! - END DO -! - MINGRD = 0 - DO J=1, IG - MINGRD = MINGRD + INGRD(J) END DO - IF ( MINGRD .NE. NSEA ) GOTO 825 -! -#ifdef W3_T - WRITE (NDST,9043) IG, NG -#endif -! -! 4.b.3 Merge smallest grids as necessary -! - IGG = IG -! - DO -! - IF ( IGG .EQ. NG ) EXIT -! - MINGRD = NSEA - MINNR = 0 - DO J=1, IG - IF ( INGRD(J) .LT. MINGRD ) THEN - MINGRD = INGRD(J) - MINNR = J - END IF - END DO - INGRD(MINNR) = NSEA + 1 -! + END DO + IGG = IGG - 1 #ifdef W3_T - WRITE (NDST,9044) MINGRD, MINNR -#endif -! - ALLOCATE ( ISNEXT(0:IG) ) - ISNEXT = .FALSE. -! - DO IY=1, NY-1 - DO IX=1, NX-1 - IF ( ( MTEMP(IY ,IX ) - MINNR ) * & - ( MTEMP(IY+1,IX ) - MINNR ) * & - ( MTEMP(IY ,IX+1) - MINNR ) * & - ( MTEMP(IY+1,IX+1) - MINNR ) .EQ. 0 ) THEN - ISNEXT(MTEMP(IY ,IX )) = .TRUE. - ISNEXT(MTEMP(IY+1,IX )) = .TRUE. - ISNEXT(MTEMP(IY ,IX+1)) = .TRUE. - ISNEXT(MTEMP(IY+1,IX+1)) = .TRUE. - END IF - END DO - END DO -! - IF ( GLOBAL ) THEN - DO IY=1, NY-1 - IF ( ( MTEMP(IY ,NX) - MINNR ) * & - ( MTEMP(IY+1,NX) - MINNR ) * & - ( MTEMP(IY , 1) - MINNR ) * & - ( MTEMP(IY+1, 1) - MINNR ) .EQ. 0 ) THEN - ISNEXT(MTEMP(IY ,NX)) = .TRUE. - ISNEXT(MTEMP(IY+1,NX)) = .TRUE. - ISNEXT(MTEMP(IY , 1)) = .TRUE. - ISNEXT(MTEMP(IY+1, 1)) = .TRUE. - END IF - END DO - END IF -! - MINNXT = NSEA - MINNNR = 0 - DO J=1, IG - IF ( ISNEXT(J) .AND. ( INGRD(J) .LT. MINNXT ) ) THEN - MINNXT = INGRD(J) - MINNNR = J - END IF - END DO -! -#ifdef W3_T - WRITE (NDST,9045) MINNXT, MINNNR -#endif -! - IF ( MINNNR .GT. 0 ) THEN - DO IY=1, NY - DO IX=1, NX - IF ( MTEMP(IY,IX) .EQ. MINNR ) THEN - MTEMP(IY,IX) = MINNNR - INGRD(MINNNR) = INGRD(MINNNR) + 1 - END IF - END DO - END DO - IGG = IGG - 1 -#ifdef W3_T - WRITE (NDST,9046) MINNR, MINNNR - DO J=1, IG - WRITE (NDST,9047) J, INGRD(J) - END DO - ELSE - WRITE (NDST,9048) MINNR -#endif - END IF -! - DEALLOCATE ( ISNEXT) + WRITE (NDST,9046) MINNR, MINNNR + DO J=1, IG + WRITE (NDST,9047) J, INGRD(J) + END DO + ELSE + WRITE (NDST,9048) MINNR +#endif + END IF + ! + DEALLOCATE ( ISNEXT) #ifdef W3_T - WRITE (NDST,9043) IGG, NG + WRITE (NDST,9043) IGG, NG #endif -! - END DO -! + ! + END DO + ! #ifdef W3_T - WRITE (NDST,9049) NG + WRITE (NDST,9049) NG #endif -! - DO J=1, IG - IF ( INGRD(J) .GT. NSEA ) INGRD(J) = 0 + ! + DO J=1, IG + IF ( INGRD(J) .GT. NSEA ) INGRD(J) = 0 #ifdef W3_T - WRITE (NDSO,9047) J, INGRD(J) -#endif - END DO -! -! 4.b.4 Store first guess in MSPLT -! - IGG = 0 - DO J=1, IG - IF ( INGRD(J) .NE. 0 ) THEN - IGG = IGG + 1 - DO IY=1, NY - DO IX=1, NX - IF ( MTEMP(IY,IX) .EQ. J ) MSPLIT(IY,IX) = IGG - END DO - END DO - END IF + WRITE (NDSO,9047) J, INGRD(J) +#endif + END DO + ! + ! 4.b.4 Store first guess in MSPLT + ! + IGG = 0 + DO J=1, IG + IF ( INGRD(J) .NE. 0 ) THEN + IGG = IGG + 1 + DO IY=1, NY + DO IX=1, NX + IF ( MTEMP(IY,IX) .EQ. J ) MSPLIT(IY,IX) = IGG END DO -! -! 5.b.5 Optional GrADS output -! + END DO + END IF + END DO + ! + ! 5.b.5 Optional GrADS output + ! #ifdef W3_O16 - WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) - NTGRDS = NTGRDS + 1 -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Refine grids -! 5.a Set up loop -! - ALLOCATE ( GSTATS(NG), GSTOLD(NG), PGRID(NG) ) - GSTATS(:)%INSTAT = .TRUE. - WRITE (NDSO,950) - DONE = .FALSE. -! - CALL GRINFO - WRITE (NDSO,951) 0, MSTATS%NMIN, MSTATS%NMAX, & - 100.*MSTATS%RSTD/XMEAN - G0ID = '5.a' - IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 - INGMIN = MSTATS%NMIN - INGMAX = MSTATS%NMAX - INGMNC = 0 - INGMXC = 0 - INGLAG = 3 - STDMIN = 100.*MSTATS%RSTD/XMEAN - NSTDLG = 0 -! - DO IIT=1, NITMAX -! - IF ( NG .EQ. 1 ) EXIT -! - MSTOLD = MSTATS - GSTOLD = GSTATS -! + WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) + NTGRDS = NTGRDS + 1 +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Refine grids + ! 5.a Set up loop + ! + ALLOCATE ( GSTATS(NG), GSTOLD(NG), PGRID(NG) ) + GSTATS(:)%INSTAT = .TRUE. + WRITE (NDSO,950) + DONE = .FALSE. + ! + CALL GRINFO + WRITE (NDSO,951) 0, MSTATS%NMIN, MSTATS%NMAX, & + 100.*MSTATS%RSTD/XMEAN + G0ID = '5.a' + IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 + INGMIN = MSTATS%NMIN + INGMAX = MSTATS%NMAX + INGMNC = 0 + INGMXC = 0 + INGLAG = 3 + STDMIN = 100.*MSTATS%RSTD/XMEAN + NSTDLG = 0 + ! + DO IIT=1, NITMAX + ! + IF ( NG .EQ. 1 ) EXIT + ! + MSTOLD = MSTATS + GSTOLD = GSTATS + ! #ifdef W3_T - WRITE (NDST,9050) 'a', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD -#endif -! -! 5.b Small grid attempt to merge -! - IF ( MSTATS%NMIN .LT. NINT(0.45*XMEAN) ) THEN -! - CALL GRFSML - CALL GRINFO -! - G0ID = '5.b' - IF ( MSTOLD%NMIN .NE. MSTATS%NMIN ) THEN - WRITE (NDSO,951) IIT, MSTATS%NMIN, MSTATS%NMAX, & - 100.*MSTATS%RSTD/XMEAN - IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 + WRITE (NDST,9050) 'a', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#endif + ! + ! 5.b Small grid attempt to merge + ! + IF ( MSTATS%NMIN .LT. NINT(0.45*XMEAN) ) THEN + ! + CALL GRFSML + CALL GRINFO + ! + G0ID = '5.b' + IF ( MSTOLD%NMIN .NE. MSTATS%NMIN ) THEN + WRITE (NDSO,951) IIT, MSTATS%NMIN, MSTATS%NMAX, & + 100.*MSTATS%RSTD/XMEAN + IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 #ifdef W3_O16 - WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) - NTGRDS = NTGRDS + 1 + WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) + NTGRDS = NTGRDS + 1 #endif - CYCLE - ELSE - WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & - 100.*MSTATS%RSTD/XMEAN - IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 - END IF -! - END IF -! -! 5.c Trim edges of grids and reassign -! - CALL GRTRIM - CALL GRFILL ( 2 ) -! -! 5.d Attempt to quare-up grid -! - CALL GRINFO ! call needed as GRSQRG uses grid ranges + CYCLE + ELSE + WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & + 100.*MSTATS%RSTD/XMEAN + IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 + END IF + ! + END IF + ! + ! 5.c Trim edges of grids and reassign + ! + CALL GRTRIM + CALL GRFILL ( 2 ) + ! + ! 5.d Attempt to quare-up grid + ! + CALL GRINFO ! call needed as GRSQRG uses grid ranges #ifdef W3_T - WRITE (NDST,9051) 'd', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD -#endif - CALL GRSQRG - CALL GRFILL ( 1 ) -! -! 5.e Remove mid-sea points sticking out of grid -! Call more than once to remove most ..... -! - OK = .TRUE. -! - DO JJ=1, 4 - CALL GRSNGL ( OK ) - END DO -! -! 5.f Remove parts of grid separated from main body, and attachable to -! other grids. -! - CALL GRSEPA ( OK , 0.10 ) - IF ( .NOT. OK ) THEN - CALL GRFILL ( 1 ) - OK = .TRUE. - END IF -! -! 5.g Re-compute grid stats -! - CALL GRINFO - WRITE (NDSO,951) IIT, MSTATS%NMIN, MSTATS%NMAX, & - 100.*MSTATS%RSTD/XMEAN + WRITE (NDST,9051) 'd', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#endif + CALL GRSQRG + CALL GRFILL ( 1 ) + ! + ! 5.e Remove mid-sea points sticking out of grid + ! Call more than once to remove most ..... + ! + OK = .TRUE. + ! + DO JJ=1, 4 + CALL GRSNGL ( OK ) + END DO + ! + ! 5.f Remove parts of grid separated from main body, and attachable to + ! other grids. + ! + CALL GRSEPA ( OK , 0.10 ) + IF ( .NOT. OK ) THEN + CALL GRFILL ( 1 ) + OK = .TRUE. + END IF + ! + ! 5.g Re-compute grid stats + ! + CALL GRINFO + WRITE (NDSO,951) IIT, MSTATS%NMIN, MSTATS%NMAX, & + 100.*MSTATS%RSTD/XMEAN #ifdef W3_T - WRITE (NDST,9051) 'g', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD -#endif -! - G0ID = '5.g' - IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 -! -! 5.h Optional GrADS output -! + WRITE (NDST,9051) 'g', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#endif + ! + G0ID = '5.g' + IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 + ! + ! 5.h Optional GrADS output + ! #ifdef W3_O16 - WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) - NTGRDS = NTGRDS + 1 -#endif -! -! 5.i Convergence tests -! ... The quick one -! - IF ( 100.*MSTATS%RSTD/XMEAN .LE. STARG ) THEN - WRITE (NDSO,959) - EXIT - END IF -! -! ... Monitoring convergence .... -! - IF ( 100.*MSTATS%RSTD/XMEAN .LT. 1.0001*STDMIN ) THEN - IF ( NSTDLG .LT. MSTDLG ) THEN - NSTDLG = 0 - ELSE - WRITE (NDSO,959) - EXIT - END IF - STDMIN = 100.*MSTATS%RSTD/XMEAN - ELSE - NSTDLG = NSTDLG + 1 - IF ( NSTDLG .GT. MSTDLG ) STDMIN = 1.01*STDMIN - END IF -! -! ... Check if stuck on min or max -! - IF ( MSTATS%NMAX .LT. INGMAX ) THEN - INGMAX = MSTATS%NMAX - INGMXC = 0 - ELSE - INGMXC = INGMXC + 1 - END IF -! - IF ( MSTATS%NMIN .GT. INGMIN ) THEN - INGMIN = MSTATS%NMIN - INGMNC = 0 - ELSE - INGMNC = INGMNC + 1 - END IF -! -! ... Stuck in min ... -! - IF ( INGMNC .GE. INGLAG ) THEN -! + WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) + NTGRDS = NTGRDS + 1 +#endif + ! + ! 5.i Convergence tests + ! ... The quick one + ! + IF ( 100.*MSTATS%RSTD/XMEAN .LE. STARG ) THEN + WRITE (NDSO,959) + EXIT + END IF + ! + ! ... Monitoring convergence .... + ! + IF ( 100.*MSTATS%RSTD/XMEAN .LT. 1.0001*STDMIN ) THEN + IF ( NSTDLG .LT. MSTDLG ) THEN + NSTDLG = 0 + ELSE + WRITE (NDSO,959) + EXIT + END IF + STDMIN = 100.*MSTATS%RSTD/XMEAN + ELSE + NSTDLG = NSTDLG + 1 + IF ( NSTDLG .GT. MSTDLG ) STDMIN = 1.01*STDMIN + END IF + ! + ! ... Check if stuck on min or max + ! + IF ( MSTATS%NMAX .LT. INGMAX ) THEN + INGMAX = MSTATS%NMAX + INGMXC = 0 + ELSE + INGMXC = INGMXC + 1 + END IF + ! + IF ( MSTATS%NMIN .GT. INGMIN ) THEN + INGMIN = MSTATS%NMIN + INGMNC = 0 + ELSE + INGMNC = INGMNC + 1 + END IF + ! + ! ... Stuck in min ... + ! + IF ( INGMNC .GE. INGLAG ) THEN + ! #ifdef W3_T - WRITE (NDST,9052) 'MINIMUM' + WRITE (NDST,9052) 'MINIMUM' #endif -! - IF ( REAL(INGMIN) .LT. 0.85*XMEAN ) THEN -! + ! + IF ( REAL(INGMIN) .LT. 0.85*XMEAN ) THEN + ! #ifdef W3_T - WRITE (NDST,9053) 0.85*XMEAN / REAL(INGMIN) -#endif - CALL GRFSML - CALL GRINFO - WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & - 100.*MSTATS%RSTD/XMEAN - INGMIN = MSTATS%NMIN - INGMAX = MSTATS%NMAX - INGMNC = 0 - INGMXC = 0 - IF ( DONE ) EXIT -! + WRITE (NDST,9053) 0.85*XMEAN / REAL(INGMIN) +#endif + CALL GRFSML + CALL GRINFO + WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & + 100.*MSTATS%RSTD/XMEAN + INGMIN = MSTATS%NMIN + INGMAX = MSTATS%NMAX + INGMNC = 0 + INGMXC = 0 + IF ( DONE ) EXIT + ! #ifdef W3_T - ELSE - WRITE (NDST,9054) + ELSE + WRITE (NDST,9054) #endif - END IF -! - END IF -! -! ... Stuck in max ... -! - IF ( INGMXC .GE. INGLAG ) THEN -! + END IF + ! + END IF + ! + ! ... Stuck in max ... + ! + IF ( INGMXC .GE. INGLAG ) THEN + ! #ifdef W3_T - WRITE (NDST,9052) 'MAXIMUM' + WRITE (NDST,9052) 'MAXIMUM' #endif -! - IF ( REAL(INGMAX) .GT. 1.075*XMEAN ) THEN -! + ! + IF ( REAL(INGMAX) .GT. 1.075*XMEAN ) THEN + ! #ifdef W3_T - WRITE (NDST,9053) REAL(INGMAX) / ( 1.075*XMEAN ) -#endif - CALL GRINFO - WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & - 100.*MSTATS%RSTD/XMEAN - INGMIN = MSTATS%NMIN - INGMAX = MSTATS%NMAX - INGMNC = 0 - INGMXC = 0 - IF ( DONE ) EXIT -! + WRITE (NDST,9053) REAL(INGMAX) / ( 1.075*XMEAN ) +#endif + CALL GRINFO + WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & + 100.*MSTATS%RSTD/XMEAN + INGMIN = MSTATS%NMIN + INGMAX = MSTATS%NMAX + INGMNC = 0 + INGMXC = 0 + IF ( DONE ) EXIT + ! #ifdef W3_T - ELSE - WRITE (NDST,9054) + ELSE + WRITE (NDST,9054) #endif - END IF -! - END IF -! - END DO -! -! 5.j Test output -! - WRITE (NDSO,955) - ALLOCATE ( ISNEXT(NG) ) - ISNEXT = .TRUE. - CALL GRINFO -! - DO JJ=1, NG - MINNR = NSEA + 1 - DO J=1, NG - IF ( ISNEXT(J) .AND. GSTATS(J)%NPTS.LT.MINNR ) THEN - MINNR = GSTATS(J)%NPTS - IG = J - END IF - END DO - ISNEXT(IG) = .FALSE. - WRITE (NDST,956) IG, GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & - GSTATS(IG)%NXL, GSTATS(IG)%NXH, & - GSTATS(IG)%NYL, GSTATS(IG)%NYH - END DO -! - DEALLOCATE ( ISNEXT ) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6. Generate output to make separate grids -! 6.a Set up loop -! - WRITE (NDSO,960) -! - ZBDUM = 999. - IF ( MAXVAL(ZB) .LT. -0.11 ) THEN - ZBMIN = -0.1 - ELSE - ZBMIN = MAXVAL(ZB) + 1. - ZBDUM = MAX ( ZBDUM , ZBMIN+1 ) - END IF -! - J1 = LEN_TRIM(FEXT) - J2 = 1 + INT(LOG10(REAL(NG)+0.5)) - WRITE (NRFMT,'(A2,I1,A1,I1,A1)') '(I', J2, '.', J2, ')' -! - IF ( J1 + J2 + 2 .LE. 10 ) THEN - FNAME = FEXT(:J1) // '_p' - J3 = J1 + 3 - ELSE - FNAME = 'part_' - J3 = 6 - END IF - J4 = J3 + J2 - 1 -! - NSEAT = 0 -! - DO IG=1, NG -! -! -! 6.b Extract grid including halo -! - WRITE (NDSO,961) IG - CALL GR1GRD - NSEAT = NSEAT + PGRID(IG)%NSEA -! - WRITE (AEXT,NRFMT) IG - FNAME(J3:J4) = AEXT(:J2) - J = LEN_TRIM(FNMPRE) -! -! 6.c Writing bottom file -! - J5 = J4 + 4 - FNAME(J4+1:J5) = '.bot' - WRITE (NDSO,962) FNAME(:J5) -! - IF ( IDFM1 .EQ. 3 ) THEN - OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & - form='UNFORMATTED', convert=file_endian,ERR=860,IOSTAT=IERR) - ELSE - OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), ERR=860,IOSTAT=IERR) - END IF - REWIND (NDSM) - CALL OUTA2R ( PGRID(IG)%ZBIN, PGRID(IG)%NX, PGRID(IG)%NY, & - 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, NDST, & - NDSE, IDFM1, RFORM1, IDLA1, VSC1, 0.0 ) - CLOSE (NDSM) -! -! 6.d Writing obstruction file -! - J5 = J4 + 5 - FNAME(J4+1:J5) = '.obst' -! - IF ( TRFLAG .EQ. 0 ) THEN - WRITE (NDSO,963) FNAME(:J5) - ELSE - WRITE (NDSO,962) FNAME(:J5) -! - IF ( IDFM2 .EQ. 3 ) THEN - OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & - form='UNFORMATTED', convert=file_endian,ERR=860,IOSTAT=IERR) - ELSE - OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & - ERR=860,IOSTAT=IERR) - END IF - REWIND (NDSM) - CALL OUTA2R ( PGRID(IG)%OBSX, PGRID(IG)%NX, PGRID(IG)%NY, & - 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, & - NDST, NDSE, IDFM2, RFORM2, IDLA2, VSC2, 0.0 ) - CALL OUTA2R ( PGRID(IG)%OBSY, PGRID(IG)%NX, PGRID(IG)%NY, & - 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, & - NDST, NDSE, IDFM2, RFORM2, IDLA2, VSC2, 0.0 ) - CLOSE (NDSM) -! - END IF -! -! 6.e Writing mask file -! - J5 = J4 + 5 - FNAME(J4+1:J5) = '.mask' - WRITE (NDSO,962) FNAME(:J5) -! - IF ( IDFM3 .EQ. 3 ) THEN - OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & - form='UNFORMATTED', convert=file_endian,ERR=860,IOSTAT=IERR) - ELSE - OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), ERR=860,IOSTAT=IERR) - END IF - REWIND (NDSM) - CALL OUTA2I ( PGRID(IG)%MASK, PGRID(IG)%NX, PGRID(IG)%NY, & - 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, NDST, & - NDSE, IDFM3, RFORM3, IDLA3, VSC3, 0 ) - CLOSE (NDSM) -! -! 6.f Writing input file -! - J5 = J4 + 5 - FNAME(J4+1:J5) = '.tmpl' - WRITE (NDSO,962) FNAME(:J5) -! - OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), ERR=860,IOSTAT=IERR) -! - GNAME(31-J2:30) = AEXT - GNAME(30-J2:30-J2) = 'p' - WRITE (NDSM,965) GNAME, SIG(2)/SIG(1), TPIINV*SIG(1), NK, & - NTH, TH(1)/DTH, FLDRY, FLCX, FLCY, FLCTH, & - FLCK, FLSOU, DTMAX, DTCFL, DTCFLI, DTMIN - J5 = LEN_TRIM(RFORM1) - IF ( REAL(PGRID(IG)%NX) * PGRID(IG)%SX .LT. 359.9 ) THEN - PTCLSE = 'NONE' - ELSE - PTCLSE = IDCLSE - END IF - WRITE (NDSM,966) IDGRID, FLAGLL, PTCLSE, & - PGRID(IG)%NX, PGRID(IG)%NY, & - PGRID(IG)%SX, PGRID(IG)%SY, & - PGRID(IG)%X0, PGRID(IG)%Y0, & - ZBMIN, DMIN, VSC1, IDLA1, IDFM1, & - RFORM1(:J5), FNAME(:J4)//'.bot' - IF ( TRFLAG .NE. 0 ) THEN - J5 = LEN_TRIM(RFORM2) - WRITE (NDSM,967) VSC2,IDLA2, IDFM2, RFORM2(:J5), & - FNAME(:J4)//'.obst' - END IF - J5 = LEN_TRIM(RFORM3) - WRITE (NDSM,968) IDLA3, IDFM3, RFORM3(:J5), FNAME(:J4)//'.mask' - CLOSE (NDSM) -! - END DO -! - WRITE (NDSO,969) 100. * (REAL(NSEAT)/REAL(NSEA)-1.) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 7. Write part of ww3_multi.inp -! - J5 = 11+J1+J2 - INAME(:J5) = 'ww3_multi.'//FEXT(:J1)//'.'//AEXT(:J2) - OPEN (NDSM,FILE=FNMPRE(:J)//INAME(:J5), ERR=870,IOSTAT=IERR) -! - DO IG=1, NG - WRITE (AEXT,NRFMT) IG - FNAME(J3:J4) = AEXT(:J2) - IF ( FRFLAG ) THEN - WRITE (NDSM,970) FNAME(:J4), & - FRACL + REAL(IG-1)*(FRACH-FRACL)/REAL(NG), & - FRACL + REAL( IG )*(FRACH-FRACL)/REAL(NG) - ELSE - WRITE (NDSM,970) FNAME(:J4), FRACL, FRACH - END IF - END DO -! + END IF + ! + END IF + ! + END DO + ! + ! 5.j Test output + ! + WRITE (NDSO,955) + ALLOCATE ( ISNEXT(NG) ) + ISNEXT = .TRUE. + CALL GRINFO + ! + DO JJ=1, NG + MINNR = NSEA + 1 + DO J=1, NG + IF ( ISNEXT(J) .AND. GSTATS(J)%NPTS.LT.MINNR ) THEN + MINNR = GSTATS(J)%NPTS + IG = J + END IF + END DO + ISNEXT(IG) = .FALSE. + WRITE (NDST,956) IG, GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & + GSTATS(IG)%NXL, GSTATS(IG)%NXH, & + GSTATS(IG)%NYL, GSTATS(IG)%NYH + END DO + ! + DEALLOCATE ( ISNEXT ) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6. Generate output to make separate grids + ! 6.a Set up loop + ! + WRITE (NDSO,960) + ! + ZBDUM = 999. + IF ( MAXVAL(ZB) .LT. -0.11 ) THEN + ZBMIN = -0.1 + ELSE + ZBMIN = MAXVAL(ZB) + 1. + ZBDUM = MAX ( ZBDUM , ZBMIN+1 ) + END IF + ! + J1 = LEN_TRIM(FEXT) + J2 = 1 + INT(LOG10(REAL(NG)+0.5)) + WRITE (NRFMT,'(A2,I1,A1,I1,A1)') '(I', J2, '.', J2, ')' + ! + IF ( J1 + J2 + 2 .LE. 10 ) THEN + FNAME = FEXT(:J1) // '_p' + J3 = J1 + 3 + ELSE + FNAME = 'part_' + J3 = 6 + END IF + J4 = J3 + J2 - 1 + ! + NSEAT = 0 + ! + DO IG=1, NG + ! + ! + ! 6.b Extract grid including halo + ! + WRITE (NDSO,961) IG + CALL GR1GRD + NSEAT = NSEAT + PGRID(IG)%NSEA + ! + WRITE (AEXT,NRFMT) IG + FNAME(J3:J4) = AEXT(:J2) + J = LEN_TRIM(FNMPRE) + ! + ! 6.c Writing bottom file + ! + J5 = J4 + 4 + FNAME(J4+1:J5) = '.bot' + WRITE (NDSO,962) FNAME(:J5) + ! + IF ( IDFM1 .EQ. 3 ) THEN + OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & + form='UNFORMATTED', convert=file_endian,ERR=860,IOSTAT=IERR) + ELSE + OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), ERR=860,IOSTAT=IERR) + END IF + REWIND (NDSM) + CALL OUTA2R ( PGRID(IG)%ZBIN, PGRID(IG)%NX, PGRID(IG)%NY, & + 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, NDST, & + NDSE, IDFM1, RFORM1, IDLA1, VSC1, 0.0 ) + CLOSE (NDSM) + ! + ! 6.d Writing obstruction file + ! + J5 = J4 + 5 + FNAME(J4+1:J5) = '.obst' + ! + IF ( TRFLAG .EQ. 0 ) THEN + WRITE (NDSO,963) FNAME(:J5) + ELSE + WRITE (NDSO,962) FNAME(:J5) + ! + IF ( IDFM2 .EQ. 3 ) THEN + OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & + form='UNFORMATTED', convert=file_endian,ERR=860,IOSTAT=IERR) + ELSE + OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & + ERR=860,IOSTAT=IERR) + END IF + REWIND (NDSM) + CALL OUTA2R ( PGRID(IG)%OBSX, PGRID(IG)%NX, PGRID(IG)%NY, & + 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, & + NDST, NDSE, IDFM2, RFORM2, IDLA2, VSC2, 0.0 ) + CALL OUTA2R ( PGRID(IG)%OBSY, PGRID(IG)%NX, PGRID(IG)%NY, & + 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, & + NDST, NDSE, IDFM2, RFORM2, IDLA2, VSC2, 0.0 ) CLOSE (NDSM) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 8. Write mask file (no halo) -! - J5 = 10+J1+J2 - INAME(:J5) = 'ww3_mask.'//FEXT(:J1)//'.'//AEXT(:J2) - OPEN (NDSM,FILE=FNMPRE(:J)//INAME(:J5), ERR=870,IOSTAT=IERR) -! - DO IY=1, NY - WRITE (NDSM,980) MSPLIT(IY,:) - END DO -! + ! + END IF + ! + ! 6.e Writing mask file + ! + J5 = J4 + 5 + FNAME(J4+1:J5) = '.mask' + WRITE (NDSO,962) FNAME(:J5) + ! + IF ( IDFM3 .EQ. 3 ) THEN + OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & + form='UNFORMATTED', convert=file_endian,ERR=860,IOSTAT=IERR) + ELSE + OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), ERR=860,IOSTAT=IERR) + END IF + REWIND (NDSM) + CALL OUTA2I ( PGRID(IG)%MASK, PGRID(IG)%NX, PGRID(IG)%NY, & + 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, NDST, & + NDSE, IDFM3, RFORM3, IDLA3, VSC3, 0 ) + CLOSE (NDSM) + ! + ! 6.f Writing input file + ! + J5 = J4 + 5 + FNAME(J4+1:J5) = '.tmpl' + WRITE (NDSO,962) FNAME(:J5) + ! + OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), ERR=860,IOSTAT=IERR) + ! + GNAME(31-J2:30) = AEXT + GNAME(30-J2:30-J2) = 'p' + WRITE (NDSM,965) GNAME, SIG(2)/SIG(1), TPIINV*SIG(1), NK, & + NTH, TH(1)/DTH, FLDRY, FLCX, FLCY, FLCTH, & + FLCK, FLSOU, DTMAX, DTCFL, DTCFLI, DTMIN + J5 = LEN_TRIM(RFORM1) + IF ( REAL(PGRID(IG)%NX) * PGRID(IG)%SX .LT. 359.9 ) THEN + PTCLSE = 'NONE' + ELSE + PTCLSE = IDCLSE + END IF + WRITE (NDSM,966) IDGRID, FLAGLL, PTCLSE, & + PGRID(IG)%NX, PGRID(IG)%NY, & + PGRID(IG)%SX, PGRID(IG)%SY, & + PGRID(IG)%X0, PGRID(IG)%Y0, & + ZBMIN, DMIN, VSC1, IDLA1, IDFM1, & + RFORM1(:J5), FNAME(:J4)//'.bot' + IF ( TRFLAG .NE. 0 ) THEN + J5 = LEN_TRIM(RFORM2) + WRITE (NDSM,967) VSC2,IDLA2, IDFM2, RFORM2(:J5), & + FNAME(:J4)//'.obst' + END IF + J5 = LEN_TRIM(RFORM3) + WRITE (NDSM,968) IDLA3, IDFM3, RFORM3(:J5), FNAME(:J4)//'.mask' + CLOSE (NDSM) + ! + END DO + ! + WRITE (NDSO,969) 100. * (REAL(NSEAT)/REAL(NSEA)-1.) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 7. Write part of ww3_multi.inp + ! + J5 = 11+J1+J2 + INAME(:J5) = 'ww3_multi.'//FEXT(:J1)//'.'//AEXT(:J2) + OPEN (NDSM,FILE=FNMPRE(:J)//INAME(:J5), ERR=870,IOSTAT=IERR) + ! + DO IG=1, NG + WRITE (AEXT,NRFMT) IG + FNAME(J3:J4) = AEXT(:J2) + IF ( FRFLAG ) THEN + WRITE (NDSM,970) FNAME(:J4), & + FRACL + REAL(IG-1)*(FRACH-FRACL)/REAL(NG), & + FRACL + REAL( IG )*(FRACH-FRACL)/REAL(NG) + ELSE + WRITE (NDSM,970) FNAME(:J4), FRACL, FRACH + END IF + END DO + ! + CLOSE (NDSM) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 8. Write mask file (no halo) + ! + J5 = 10+J1+J2 + INAME(:J5) = 'ww3_mask.'//FEXT(:J1)//'.'//AEXT(:J2) + OPEN (NDSM,FILE=FNMPRE(:J)//INAME(:J5), ERR=870,IOSTAT=IERR) + ! + DO IY=1, NY + WRITE (NDSM,980) MSPLIT(IY,:) + END DO + ! #ifdef W3_O16 - CLOSE ( NDSG ) + CLOSE ( NDSG ) #endif -! + ! #ifdef W3_O16 - OPEN ( NDSG,FILE='ww3.ctl') - WRITE (NDSG,985) NX, X0, SX, NY, Y0, SY, NTGRDS - CLOSE ( NDSG ) -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 9. End of program -! - GOTO 888 -! -! Error escape locations -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 40 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 41 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 42 ) -! - 820 CONTINUE - WRITE (NDSE,1020) GTYPE - CALL EXTCDE ( 20 ) -! - 821 CONTINUE - WRITE (NDSE,1021) GTYPE - CALL EXTCDE ( 21 ) -! - 822 CONTINUE - WRITE (NDSE,1022) ICLOSE - CALL EXTCDE ( 22 ) -! - 823 CONTINUE - WRITE (NDSE,1023) ICLOSE - CALL EXTCDE ( 23 ) -! - 824 CONTINUE - WRITE (NDSE,1024) - CALL EXTCDE ( 24 ) -! - 825 CONTINUE - WRITE (NDSE,1025) MINGRD, NSEA - CALL EXTCDE ( 25 ) -! - 830 CONTINUE - WRITE (NDSE,1030) - CALL EXTCDE ( 30 ) -! - 850 CONTINUE - WRITE (NDSE,1050) G0ID - CALL EXTCDE ( 50 ) -! - 860 CONTINUE - WRITE (NDSE,1060) FNMPRE(:J)//FNAME(:J5), IERR - CALL EXTCDE ( 60 ) -! - 870 CONTINUE - WRITE (NDSE,1070) FNMPRE(:J)//INAME(:J5), IERR - CALL EXTCDE ( 70 ) -! - 888 CONTINUE - WRITE (NDSO,999) -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Grid splitting *** '/ & - 15X,'=========================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) - 902 FORMAT ( ' Grid ID : ',A/ & - ' Grid name : ',A) - 903 FORMAT ( ' Grid type : ',A) - 904 FORMAT ( ' Closure : ',A) - 905 FORMAT ( ' Grid size : ',I4,' x',I4,' (',I8,')'/) -! - 930 FORMAT ( ' Generating ',I3,' grids'/ & - ' No more than',I4,' refinement iterations'/ & - ' Grid point count std target (%) :',F6.2/ & - ' Halo per sub grid extended by',I3,' grid point.') - 931 FORMAT ( ' Format info for bottom file :',2I2,F12.4,2X,A) - 932 FORMAT ( ' Format info for obstruction file not used') - 933 FORMAT ( ' Format info for obstruction file :',2I2,F12.4,2X,A) - 934 FORMAT ( ' Format info for mask file :',2I2,I7,7X,A) - 935 FORMAT ( ' Part of cummunicator to be used :',2F7.4) - 936 FORMAT ( ' Not running grids side-by-side'/ & - ' *** NON CONVENTIONAL OPERATION ***'/) -! - 950 FORMAT (/' Iterations:'/ & - ' nr min max std (%) '/ & - ' ---------------------------------') - 951 FORMAT (2X,I5,2I8,2F10.2) - 952 FORMAT (2X,5x,2I8,2F10.2) - 955 FORMAT (/' Resulting grids:'/ & - ' grid stradle points range X range Y '/ & - ' ---------------------------------------------') - 956 FORMAT ( ' ',I4,5X,L1,2X,I7,4I5) - 959 FORMAT ( ' Convergence reached') -! - 960 FORMAT (/' Generating grid data:'/ & - ' ---------------------------------------------') - 961 FORMAT ( ' Extracting data for grid',I4) - 962 FORMAT ( ' Writing file ',A) - 963 FORMAT ( ' File ',A,' not requested') -! - 970 FORMAT ( ' ''',A,''' ''LEV'' ''CUR'' ''WND'' ''ICE''', & - ' ''D1'' ''D2'' ''D3'' RANK GROUP',2F10.7,' BFLAG') -! - 980 FORMAT (1X,360I2) -! + OPEN ( NDSG,FILE='ww3.ctl') + WRITE (NDSG,985) NX, X0, SX, NY, Y0, SY, NTGRDS + CLOSE ( NDSG ) +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 9. End of program + ! + GOTO 888 + ! + ! Error escape locations + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 40 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 41 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 42 ) + ! +820 CONTINUE + WRITE (NDSE,1020) GTYPE + CALL EXTCDE ( 20 ) + ! +821 CONTINUE + WRITE (NDSE,1021) GTYPE + CALL EXTCDE ( 21 ) + ! +822 CONTINUE + WRITE (NDSE,1022) ICLOSE + CALL EXTCDE ( 22 ) + ! +823 CONTINUE + WRITE (NDSE,1023) ICLOSE + CALL EXTCDE ( 23 ) + ! +824 CONTINUE + WRITE (NDSE,1024) + CALL EXTCDE ( 24 ) + ! +825 CONTINUE + WRITE (NDSE,1025) MINGRD, NSEA + CALL EXTCDE ( 25 ) + ! +830 CONTINUE + WRITE (NDSE,1030) + CALL EXTCDE ( 30 ) + ! +850 CONTINUE + WRITE (NDSE,1050) G0ID + CALL EXTCDE ( 50 ) + ! +860 CONTINUE + WRITE (NDSE,1060) FNMPRE(:J)//FNAME(:J5), IERR + CALL EXTCDE ( 60 ) + ! +870 CONTINUE + WRITE (NDSE,1070) FNMPRE(:J)//INAME(:J5), IERR + CALL EXTCDE ( 70 ) + ! +888 CONTINUE + WRITE (NDSO,999) + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Grid splitting *** '/ & + 15X,'=========================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) +902 FORMAT ( ' Grid ID : ',A/ & + ' Grid name : ',A) +903 FORMAT ( ' Grid type : ',A) +904 FORMAT ( ' Closure : ',A) +905 FORMAT ( ' Grid size : ',I4,' x',I4,' (',I8,')'/) + ! +930 FORMAT ( ' Generating ',I3,' grids'/ & + ' No more than',I4,' refinement iterations'/ & + ' Grid point count std target (%) :',F6.2/ & + ' Halo per sub grid extended by',I3,' grid point.') +931 FORMAT ( ' Format info for bottom file :',2I2,F12.4,2X,A) +932 FORMAT ( ' Format info for obstruction file not used') +933 FORMAT ( ' Format info for obstruction file :',2I2,F12.4,2X,A) +934 FORMAT ( ' Format info for mask file :',2I2,I7,7X,A) +935 FORMAT ( ' Part of cummunicator to be used :',2F7.4) +936 FORMAT ( ' Not running grids side-by-side'/ & + ' *** NON CONVENTIONAL OPERATION ***'/) + ! +950 FORMAT (/' Iterations:'/ & + ' nr min max std (%) '/ & + ' ---------------------------------') +951 FORMAT (2X,I5,2I8,2F10.2) +952 FORMAT (2X,5x,2I8,2F10.2) +955 FORMAT (/' Resulting grids:'/ & + ' grid stradle points range X range Y '/ & + ' ---------------------------------------------') +956 FORMAT ( ' ',I4,5X,L1,2X,I7,4I5) +959 FORMAT ( ' Convergence reached') + ! +960 FORMAT (/' Generating grid data:'/ & + ' ---------------------------------------------') +961 FORMAT ( ' Extracting data for grid',I4) +962 FORMAT ( ' Writing file ',A) +963 FORMAT ( ' File ',A,' not requested') + ! +970 FORMAT ( ' ''',A,''' ''LEV'' ''CUR'' ''WND'' ''ICE''', & + ' ''D1'' ''D2'' ''D3'' RANK GROUP',2F10.7,' BFLAG') + ! +980 FORMAT (1X,360I2) + ! #ifdef W3_O16 - 985 FORMAT ( 'DSET ww3.ww3_gspl'/ & - 'TITLE WAVEWATCH III grid splitting data'/ & - 'OPTIONS sequential'/ & - 'UNDEF -999.9'/ & - 'XDEF ',I6,' LINEAR ',2F12.5/ & - 'YDEF ',I6,' LINEAR ',2F12.5/ & - 'ZDEF 1 LINEAR 1000.00000 1.00000'/ & - 'TDEF ',I6,' LINEAR 00:00 06JUN1968 1HR'/ & - 'VARS 1'/ & - 'MAP 0 99 grid use map '/ & - 'ENDVARS') -#endif -! - 965 FORMAT ( '$ -------------------------------------', & - '------------------------------- $'/ & - '$ WAVEWATCH III Grid preprocessor input', & - ' file $'/ & - '$ -------------------------------------', & - '------------------------------- $'/ & - ' ''',A,''''/'$'/ & - ' ',F8.4,F10.6,2I6,F8.4/' ',6L2/' ',4F12.4/ & - '$ NAMELISTS'/'$') - 966 FORMAT ( ' ''',A4,''' ',L1,' ''',A4,''''/1X,I8,I12/ & - 4X,2F12.6,' 1.0'/4X,2F12.6,' 1.0'/2F8.2,' 20', & - F12.6,2I2,' ''',A,''' ''NAME'' ''',A,'''') - 967 FORMAT ( 18X,'30',F12.6,2I2,' ''',A,''' ''NAME'' ''',A,'''' ) - 968 FORMAT ( 18X,'40',12X,2I2,' ''',A,''' ''NAME'' ''',A,''''/'$'/ & - '$ Note: cannot make output boundary points here'/'$'/ & - ' 0. 0. 0. 0. 0'/ & - '$ -------------------------------------', & - '------------------------------- $'/ & - '$ End of input file ', & - ' $'/ & - '$ -------------------------------------', & - '------------------------------- $') -! - 969 FORMAT (/' Grid point inflation',F7.2,'%') -! - 999 FORMAT(//' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Grid splitting '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1020 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' SPLITTING NOT AVAILABLE FOR GRID TYPE'/ & - ' GTYPE =',I5/) -! - 1021 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' GRID TYPE NOT RECOGNIZED'/ & - ' GTYPE =',I5/) -! - 1022 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' SPLITTING NOT AVAILABLE FOR CLOSURE TYPE'/ & - ' ICLOSE =',I5/) -! - 1023 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' CLOSURE TYPE NOT RECOGNIZED'/ & - ' ICLOSE =',I5/) -! - 1024 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' NO ACTIVE SEA POINT IN GRID'/) -! - 1025 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' WRONG NUMBER OF SEA POINTS'/ & - ' MINGRD, NSEA =',2I7/) -! - 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' ILLEGAL PART OF COMMUNICATOR REQUESTED'/) -! - 1050 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' SHOULD NOT HAVE ZERO GRID SIZE (',A,') ...'/) -! - 1060 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' ERROR IN OPENING FILE ',A/ & - ' IOSTAT =',I5/) -! - 1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & - ' ERROR IN OPENING FILE ',A/ & - ' IOSTAT =',I5/) -! +985 FORMAT ( 'DSET ww3.ww3_gspl'/ & + 'TITLE WAVEWATCH III grid splitting data'/ & + 'OPTIONS sequential'/ & + 'UNDEF -999.9'/ & + 'XDEF ',I6,' LINEAR ',2F12.5/ & + 'YDEF ',I6,' LINEAR ',2F12.5/ & + 'ZDEF 1 LINEAR 1000.00000 1.00000'/ & + 'TDEF ',I6,' LINEAR 00:00 06JUN1968 1HR'/ & + 'VARS 1'/ & + 'MAP 0 99 grid use map '/ & + 'ENDVARS') +#endif + ! +965 FORMAT ( '$ -------------------------------------', & + '------------------------------- $'/ & + '$ WAVEWATCH III Grid preprocessor input', & + ' file $'/ & + '$ -------------------------------------', & + '------------------------------- $'/ & + ' ''',A,''''/'$'/ & + ' ',F8.4,F10.6,2I6,F8.4/' ',6L2/' ',4F12.4/ & + '$ NAMELISTS'/'$') +966 FORMAT ( ' ''',A4,''' ',L1,' ''',A4,''''/1X,I8,I12/ & + 4X,2F12.6,' 1.0'/4X,2F12.6,' 1.0'/2F8.2,' 20', & + F12.6,2I2,' ''',A,''' ''NAME'' ''',A,'''') +967 FORMAT ( 18X,'30',F12.6,2I2,' ''',A,''' ''NAME'' ''',A,'''' ) +968 FORMAT ( 18X,'40',12X,2I2,' ''',A,''' ''NAME'' ''',A,''''/'$'/ & + '$ Note: cannot make output boundary points here'/'$'/ & + ' 0. 0. 0. 0. 0'/ & + '$ -------------------------------------', & + '------------------------------- $'/ & + '$ End of input file ', & + ' $'/ & + '$ -------------------------------------', & + '------------------------------- $') + ! +969 FORMAT (/' Grid point inflation',F7.2,'%') + ! +999 FORMAT(//' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Grid splitting '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1020 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' SPLITTING NOT AVAILABLE FOR GRID TYPE'/ & + ' GTYPE =',I5/) + ! +1021 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' GRID TYPE NOT RECOGNIZED'/ & + ' GTYPE =',I5/) + ! +1022 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' SPLITTING NOT AVAILABLE FOR CLOSURE TYPE'/ & + ' ICLOSE =',I5/) + ! +1023 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' CLOSURE TYPE NOT RECOGNIZED'/ & + ' ICLOSE =',I5/) + ! +1024 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' NO ACTIVE SEA POINT IN GRID'/) + ! +1025 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' WRONG NUMBER OF SEA POINTS'/ & + ' MINGRD, NSEA =',2I7/) + ! +1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' ILLEGAL PART OF COMMUNICATOR REQUESTED'/) + ! +1050 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' SHOULD NOT HAVE ZERO GRID SIZE (',A,') ...'/) + ! +1060 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' ERROR IN OPENING FILE ',A/ & + ' IOSTAT =',I5/) + ! +1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & + ' ERROR IN OPENING FILE ',A/ & + ' IOSTAT =',I5/) + ! #ifdef W3_T - 9040 FORMAT ( 'TEST W3GSPL: CHECKERBOARD X-Y:',2I8) - 9041 FORMAT ( 'TEST W3GSPL: FILLING CHECKERBOARD TRY:',I3/ & - ' GRID, IGX0, IGXN, IGY0, IGYN, POINTS ') - 9042 FORMAT ( ' ',I6,2(2I8), I8,2X,A) - 9043 FORMAT ( 'TEST W3GSPL: CHECKERBOARD GRIDS:',I4,' (',I4,')') - 9044 FORMAT ( ' SMALLEST SIZE/GRID:',I8,I4) - 9045 FORMAT ( ' SMALLEST NEIGHBOR :',I8,I4) - 9046 FORMAT ( ' GRID',I4', MERGED WITH GRID',I4) - 9047 FORMAT ( ' ',I6,I8) - 9048 FORMAT ( ' GRID',I4', IS ISOLATED, LEFT UNCHANGED') - 9049 FORMAT ( 'TEST W3GSPL: CHECKERBOARD CONSOLIDATED ON',I4,' GRIDS') -#endif -! +9040 FORMAT ( 'TEST W3GSPL: CHECKERBOARD X-Y:',2I8) +9041 FORMAT ( 'TEST W3GSPL: FILLING CHECKERBOARD TRY:',I3/ & + ' GRID, IGX0, IGXN, IGY0, IGYN, POINTS ') +9042 FORMAT ( ' ',I6,2(2I8), I8,2X,A) +9043 FORMAT ( 'TEST W3GSPL: CHECKERBOARD GRIDS:',I4,' (',I4,')') +9044 FORMAT ( ' SMALLEST SIZE/GRID:',I8,I4) +9045 FORMAT ( ' SMALLEST NEIGHBOR :',I8,I4) +9046 FORMAT ( ' GRID',I4', MERGED WITH GRID',I4) +9047 FORMAT ( ' ',I6,I8) +9048 FORMAT ( ' GRID',I4', IS ISOLATED, LEFT UNCHANGED') +9049 FORMAT ( 'TEST W3GSPL: CHECKERBOARD CONSOLIDATED ON',I4,' GRIDS') +#endif + ! #ifdef W3_T - 9050 FORMAT ( 'TEST W3GSPL',A,': MIN, MAX, STD:',2I8,F10.2) - 9051 FORMAT ( ' ',A,': MIN, MAX, STD:',2I8,F10.2) -#endif - 9052 FORMAT ( 'TEST W3GSPL: STUCK ON ',A,' GRID SIZE') - 9053 FORMAT ( ' OUT OF RANGE, PROCESSING (',F6.3,')') - 9054 FORMAT ( ' IN RANGE, NO ACTION') -!/ -!/ Embedded subroutines ---------------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / +9050 FORMAT ( 'TEST W3GSPL',A,': MIN, MAX, STD:',2I8,F10.2) +9051 FORMAT ( ' ',A,': MIN, MAX, STD:',2I8,F10.2) +#endif +9052 FORMAT ( 'TEST W3GSPL: STUCK ON ',A,' GRID SIZE') +9053 FORMAT ( ' OUT OF RANGE, PROCESSING (',F6.3,')') +9054 FORMAT ( ' IN RANGE, NO ACTION') + !/ + !/ Embedded subroutines ---------------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / -!> @brief Compile statistical info on all sub grids (no halo). -!> -!> @author H. L. Tolman @date 13-Sep-2012 - SUBROUTINE GRINFO -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 06-Sep-2012 : Origination. ( version 4.10 ) -!/ 13-Sep-2012 : Option to exclude grids from stats. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Compile statistical info on all sub grids (no halo). -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NOCNT, NOCNTM, NOCNTL, NGC, NSEAC + !> @brief Compile statistical info on all sub grids (no halo). + !> + !> @author H. L. Tolman @date 13-Sep-2012 + SUBROUTINE GRINFO + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 06-Sep-2012 : Origination. ( version 4.10 ) + !/ 13-Sep-2012 : Option to exclude grids from stats. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Compile statistical info on all sub grids (no halo). + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NOCNT, NOCNTM, NOCNTL, NGC, NSEAC #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: SUMSQR - LOGICAL :: LEFT, RIGHT, THERE -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: SUMSQR + LOGICAL :: LEFT, RIGHT, THERE + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GRINFO') -#endif -! -! 1. Initialization ------------------------------------------------- * -! - GSTATS(:)%STRADLE = .FALSE. - GSTATS(:)%NPTS = 0 - GSTATS(:)%NXL = NX - GSTATS(:)%NXH = 1 - GSTATS(:)%NYL = NY - GSTATS(:)%NYH = 1 -! -! 2. Get STRADLE, NGC ----------------------------------------------- * -! - NGC = 0 -! - DO IG=1, NG - LEFT = .FALSE. - RIGHT = .FALSE. - IF ( GSTATS(IG)%INSTAT ) NGC = NGC + 1 - DO IY=1, NY - IF ( MSPLIT(IY, 1) .EQ. IG ) LEFT = .TRUE. - IF ( MSPLIT(IY,NX) .EQ. IG ) RIGHT = .TRUE. - END DO - GSTATS(IG)%STRADLE = LEFT .AND. RIGHT - END DO -! - IF ( NGC .EQ. 0 ) THEN - NGC = 1 - DONE = .TRUE. - END IF -! -! 3. Run grid stats ------------------------------------------------- * -! 3.a General -! + CALL STRACE (IENT, 'GRINFO') +#endif + ! + ! 1. Initialization ------------------------------------------------- * + ! + GSTATS(:)%STRADLE = .FALSE. + GSTATS(:)%NPTS = 0 + GSTATS(:)%NXL = NX + GSTATS(:)%NXH = 1 + GSTATS(:)%NYL = NY + GSTATS(:)%NYH = 1 + ! + ! 2. Get STRADLE, NGC ----------------------------------------------- * + ! + NGC = 0 + ! + DO IG=1, NG + LEFT = .FALSE. + RIGHT = .FALSE. + IF ( GSTATS(IG)%INSTAT ) NGC = NGC + 1 DO IY=1, NY - DO IX=1, NX - IG = MSPLIT(IY,IX) - IF ( MSPLIT(IY,IX) .GT. 0 ) THEN - GSTATS(IG)%NPTS = GSTATS(IG)%NPTS + 1 - GSTATS(IG)%NXL = MIN ( GSTATS(IG)%NXL , IX ) - GSTATS(IG)%NXH = MAX ( GSTATS(IG)%NXH , IX ) - GSTATS(IG)%NYL = MIN ( GSTATS(IG)%NYL , IY ) - GSTATS(IG)%NYH = MAX ( GSTATS(IG)%NYH , IY ) - END IF - END DO - END DO -! -! 3.b Stradled grids -! - IF ( NG .GT. 1) THEN - DO IG=1, NG - IF ( GSTATS(IG)%STRADLE ) THEN - NOCNT = 0 - NOCNTM = 0 - NOCNTL = 0 - DO IX=1, NX - THERE = .FALSE. - DO IY=1, NY - IF ( MSPLIT(IY,IX) .EQ. IG ) THEN - THERE = .TRUE. - EXIT - END IF - END DO - IF ( THERE ) THEN - NOCNT = 0 - ELSE - NOCNT = NOCNT + 1 - IF ( NOCNT .GT. NOCNTM ) THEN - NOCNTM = NOCNT - NOCNTL = IX - END IF - END IF - END DO - GSTATS(IG)%NXL = NOCNTL + 1 - GSTATS(IG)%NXH = NOCNTL - NOCNTM + IF ( MSPLIT(IY, 1) .EQ. IG ) LEFT = .TRUE. + IF ( MSPLIT(IY,NX) .EQ. IG ) RIGHT = .TRUE. + END DO + GSTATS(IG)%STRADLE = LEFT .AND. RIGHT + END DO + ! + IF ( NGC .EQ. 0 ) THEN + NGC = 1 + DONE = .TRUE. + END IF + ! + ! 3. Run grid stats ------------------------------------------------- * + ! 3.a General + ! + DO IY=1, NY + DO IX=1, NX + IG = MSPLIT(IY,IX) + IF ( MSPLIT(IY,IX) .GT. 0 ) THEN + GSTATS(IG)%NPTS = GSTATS(IG)%NPTS + 1 + GSTATS(IG)%NXL = MIN ( GSTATS(IG)%NXL , IX ) + GSTATS(IG)%NXH = MAX ( GSTATS(IG)%NXH , IX ) + GSTATS(IG)%NYL = MIN ( GSTATS(IG)%NYL , IY ) + GSTATS(IG)%NYH = MAX ( GSTATS(IG)%NYH , IY ) + END IF + END DO + END DO + ! + ! 3.b Stradled grids + ! + IF ( NG .GT. 1) THEN + DO IG=1, NG + IF ( GSTATS(IG)%STRADLE ) THEN + NOCNT = 0 + NOCNTM = 0 + NOCNTL = 0 + DO IX=1, NX + THERE = .FALSE. + DO IY=1, NY + IF ( MSPLIT(IY,IX) .EQ. IG ) THEN + THERE = .TRUE. + EXIT + END IF + END DO + IF ( THERE ) THEN + NOCNT = 0 + ELSE + NOCNT = NOCNT + 1 + IF ( NOCNT .GT. NOCNTM ) THEN + NOCNTM = NOCNT + NOCNTL = IX + END IF END IF END DO - ELSE - GSTATS(1)%STRADLE = .FALSE. + GSTATS(IG)%NXL = NOCNTL + 1 + GSTATS(IG)%NXH = NOCNTL - NOCNTM END IF -! -! 3.c Corrected NSEA -! - NSEAC = 0 -! - DO IG=1, NG - IF ( GSTATS(IG)%INSTAT ) NSEAC = NSEAC + GSTATS(IG)%NPTS - END DO -! -! 4. Run overall stats ---------------------------------------------- * -! - MSTATS%NMIN = NSEA + 1 - MSTATS%NMAX = 0 - XMEAN = REAL(NSEAC) / REAL(NGC) - SUMSQR = 0. -! - DO IG=1, NG - IF ( .NOT. GSTATS(IG)%INSTAT ) CYCLE - MSTATS%NMIN = MIN ( MSTATS%NMIN , GSTATS(IG)%NPTS ) - MSTATS%NMAX = MAX ( MSTATS%NMAX , GSTATS(IG)%NPTS ) - SUMSQR = SUMSQR + ( REAL(GSTATS(IG)%NPTS) - XMEAN )**2 - END DO -! - MSTATS%RSTD = SQRT ( SUMSQR / REAL(NGC) ) -! -! 5. Test output ---------------------------------------------------- * -! + END DO + ELSE + GSTATS(1)%STRADLE = .FALSE. + END IF + ! + ! 3.c Corrected NSEA + ! + NSEAC = 0 + ! + DO IG=1, NG + IF ( GSTATS(IG)%INSTAT ) NSEAC = NSEAC + GSTATS(IG)%NPTS + END DO + ! + ! 4. Run overall stats ---------------------------------------------- * + ! + MSTATS%NMIN = NSEA + 1 + MSTATS%NMAX = 0 + XMEAN = REAL(NSEAC) / REAL(NGC) + SUMSQR = 0. + ! + DO IG=1, NG + IF ( .NOT. GSTATS(IG)%INSTAT ) CYCLE + MSTATS%NMIN = MIN ( MSTATS%NMIN , GSTATS(IG)%NPTS ) + MSTATS%NMAX = MAX ( MSTATS%NMAX , GSTATS(IG)%NPTS ) + SUMSQR = SUMSQR + ( REAL(GSTATS(IG)%NPTS) - XMEAN )**2 + END DO + ! + MSTATS%RSTD = SQRT ( SUMSQR / REAL(NGC) ) + ! + ! 5. Test output ---------------------------------------------------- * + ! #ifdef W3_T1 - WRITE (NDST,9000) - DO IG=1, NG - WRITE (NDST,9001) IG, GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & - GSTATS(IG)%NXL, GSTATS(IG)%NXH, & - GSTATS(IG)%NYL, GSTATS(IG)%NYH - END DO - WRITE (NDST,9010) MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD -#endif -! - RETURN -! -! Formats -! + WRITE (NDST,9000) + DO IG=1, NG + WRITE (NDST,9001) IG, GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & + GSTATS(IG)%NXL, GSTATS(IG)%NXH, & + GSTATS(IG)%NYL, GSTATS(IG)%NYH + END DO + WRITE (NDST,9010) MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#endif + ! + RETURN + ! + ! Formats + ! #ifdef W3_T1 - 9000 FORMAT ( 'TEST GRINFO: J, STRADLE, NPTS,NXL-H, NYL-H') - 9001 FORMAT ( ' ',I4,2X,L1,2X,I7,4I5) - 9010 FORMAT ( 'TEST GRINFO: MIN, MAX, STD:',2I8,F10.2) -#endif -! -!/ End of GRINFO ----------------------------------------------------- / -!/ - END SUBROUTINE GRINFO -!/ ------------------------------------------------------------------- / +9000 FORMAT ( 'TEST GRINFO: J, STRADLE, NPTS,NXL-H, NYL-H') +9001 FORMAT ( ' ',I4,2X,L1,2X,I7,4I5) +9010 FORMAT ( 'TEST GRINFO: MIN, MAX, STD:',2I8,F10.2) +#endif + ! + !/ End of GRINFO ----------------------------------------------------- / + !/ + END SUBROUTINE GRINFO + !/ ------------------------------------------------------------------- / -!> @brief Trim edges of all grids where they are next to another grid -!> or next to unassigned grid points. -!> -!> @details This trimming is done in preparation for reassigning edges -!> of grids to smaller adjacent grids. -!> -!> @author H. L. Tolman @date 01-Feb-2013 - SUBROUTINE GRTRIM -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Feb-2013 | -!/ +-----------------------------------+ -!/ -!/ 07-Sep-2012 : Origination. ( version 4.10 ) -!/ 18-Sep-2012 : Include edge points of grid. ( version 4.10 ) -!/ 01-Feb-2013 : Add dynamic trim range. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Trim edges of all grids where they are next to another grid or next -! to unassigned grid points. This is done in preparation for -! reassigning edges of grids to smaller adjacent grids. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ITARG, ITL, IPTS, MX, MY, ICIRC, NWDTH + !> @brief Trim edges of all grids where they are next to another grid + !> or next to unassigned grid points. + !> + !> @details This trimming is done in preparation for reassigning edges + !> of grids to smaller adjacent grids. + !> + !> @author H. L. Tolman @date 01-Feb-2013 + SUBROUTINE GRTRIM + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Feb-2013 | + !/ +-----------------------------------+ + !/ + !/ 07-Sep-2012 : Origination. ( version 4.10 ) + !/ 18-Sep-2012 : Include edge points of grid. ( version 4.10 ) + !/ 01-Feb-2013 : Add dynamic trim range. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Trim edges of all grids where they are next to another grid or next + ! to unassigned grid points. This is done in preparation for + ! reassigning edges of grids to smaller adjacent grids. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ITARG, ITL, IPTS, MX, MY, ICIRC, NWDTH #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - LOGICAL :: MASK(NY,NX) -!/ -!/ ------------------------------------------------------------------- / -!/ + LOGICAL :: MASK(NY,NX) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GRTRIM') -#endif -! - ITARG = NSEA / NG -! -! 1. Loop over grids ------------------------------------------------ * -! - DO IG=1, NG -! - IPTS = GSTATS(IG)%NPTS - MY = 1 + GSTATS(IG)%NYH - GSTATS(IG)%NYL - MX = 1 + GSTATS(IG)%NXH - GSTATS(IG)%NXL - IF ( GSTATS(IG)%STRADLE ) MX = MX + NX - ICIRC = 2 * ( MX + MY ) -! - NWDTH = 1 -! - ITL = MIN ( ITARG , MAX ( ITARG-2*ICIRC , 3*ICIRC ) ) - IF ( IPTS .LT. ITL ) NWDTH = 0 -! - IF ( IPTS.GT.ITARG ) THEN - NWDTH = 1 + & - MAX(0,+NINT((REAL((IPTS-ITARG))/REAL(ICIRC)-1.)/3.)) - ENDIF -! - DO J=1, NWDTH -! - MASK = .FALSE. -! -! 2. Mark points to be removed -------------------------------------- * -! - DO IX=2, NX-1 - IF ( MSPLIT( 1,IX) .EQ. IG ) MASK( 1,IX) = & - (SEA( 2,IX ).AND.(MSPLIT( 2,IX ).NE.IG)) & - .OR. (SEA( 1,IX+1).AND.(MSPLIT( 1,IX+1).NE.IG)) & - .OR. (SEA( 1,IX-1).AND.(MSPLIT( 1,IX-1).NE.IG)) - DO IY=2, NY-1 - IF ( MSPLIT(IY,IX) .EQ. IG ) MASK(IY,IX) = & - (SEA(IY+1,IX ).AND.(MSPLIT(IY+1,IX ).NE.IG)) & - .OR. (SEA(IY-1,IX ).AND.(MSPLIT(IY-1,IX ).NE.IG)) & - .OR. (SEA(IY ,IX+1).AND.(MSPLIT(IY ,IX+1).NE.IG)) & - .OR. (SEA(IY ,IX-1).AND.(MSPLIT(IY ,IX-1).NE.IG)) - END DO - IF ( MSPLIT(NY,IX) .EQ. IG ) MASK(NY,IX) = & - (SEA(NY-1,IX ).AND.(MSPLIT(NY-1,IX ).NE.IG)) & - .OR. (SEA(NY ,IX+1).AND.(MSPLIT(NY ,IX+1).NE.IG)) & - .OR. (SEA(NY ,IX-1).AND.(MSPLIT(NY ,IX-1).NE.IG)) - END DO -! - IF ( GLOBAL ) THEN - IF ( MSPLIT( 1, 1) .EQ. IG ) MASK( 1, 1) = & - (SEA( 2, 1).AND.(MSPLIT( 2, 1).NE.IG)) & - .OR. (SEA( 1, 2).AND.(MSPLIT( 1, 2).NE.IG)) & - .OR. (SEA( 1,NX).AND.(MSPLIT( 1,NX).NE.IG)) - IF ( MSPLIT( 1,NX) .EQ. IG ) MASK( 1,NX) = & - (SEA( 2,NX ).AND.(MSPLIT( 2,NX ).NE.IG)) & - .OR. (SEA( 1, 1 ).AND.(MSPLIT( 1, 1 ).NE.IG)) & - .OR. (SEA( 1,NX-1).AND.(MSPLIT( 1,NX-1).NE.IG)) - DO IY=2, NY-1 - IF ( MSPLIT(IY, 1) .EQ. IG ) MASK(IY, 1) = & - (SEA(IY+1, 1).AND.(MSPLIT(IY+1, 1).NE.IG)) & - .OR. (SEA(IY-1, 1).AND.(MSPLIT(IY-1, 1).NE.IG)) & - .OR. (SEA(IY , 2).AND.(MSPLIT(IY , 2).NE.IG)) & - .OR. (SEA(IY ,NX).AND.(MSPLIT(IY ,NX).NE.IG)) - IF ( MSPLIT(IY,NX) .EQ. IG ) MASK(IY,NX) = & - (SEA(IY+1,NX).AND.(MSPLIT(IY+1,NX).NE.IG)) & - .OR. (SEA(IY-1,NX).AND.(MSPLIT(IY-1,NX).NE.IG)) & - .OR. (SEA(IY , 1).AND.(MSPLIT(IY , 1).NE.IG)) & - .OR. (SEA(IY,NX-1).AND.(MSPLIT(IY,NX-1).NE.IG)) - END DO - IF ( MSPLIT(NY, 1) .EQ. IG ) MASK(NY, 1) = & - (SEA(NY-1, 1).AND.(MSPLIT(NY-1, 1).NE.IG)) & - .OR. (SEA(NY , 2).AND.(MSPLIT(NY , 2).NE.IG)) & - .OR. (SEA(NY ,NX).AND.(MSPLIT(NY ,NX).NE.IG)) - IF ( MSPLIT(NY,NX) .EQ. IG ) MASK(NY,NX) = & - (SEA(NY-1,NX).AND.(MSPLIT(NY-1,NX).NE.IG)) & - .OR. (SEA(NY , 1).AND.(MSPLIT(NY , 1).NE.IG)) & - .OR. (SEA(NY,NX-1).AND.(MSPLIT(NY,NX-1).NE.IG)) - ELSE - IF ( MSPLIT( 1, 1) .EQ. IG ) MASK( 1, 1) = & - (SEA( 2, 1).AND.(MSPLIT( 2, 1).NE.IG)) & - .OR. (SEA( 1, 2).AND.(MSPLIT( 1, 2).NE.IG)) - IF ( MSPLIT( 1,NX) .EQ. IG ) MASK( 1,NX) = & - (SEA( 2,NX ).AND.(MSPLIT( 2,NX ).NE.IG)) & - .OR. (SEA( 1,NX-1).AND.(MSPLIT( 1,NX-1).NE.IG)) - DO IY=2, NY-1 - IF ( MSPLIT(IY, 1) .EQ. IG ) MASK(IY, 1) = & - (SEA(IY+1, 1).AND.(MSPLIT(IY+1, 1).NE.IG)) & - .OR. (SEA(IY-1, 1).AND.(MSPLIT(IY-1, 1).NE.IG)) & - .OR. (SEA(IY , 2).AND.(MSPLIT(IY , 2).NE.IG)) - IF ( MSPLIT(IY,NX) .EQ. IG ) MASK(IY,NX) = & - (SEA(IY+1,NX).AND.(MSPLIT(IY+1,NX).NE.IG)) & - .OR. (SEA(IY-1,NX).AND.(MSPLIT(IY-1,NX).NE.IG)) & - .OR. (SEA(IY,NX-1).AND.(MSPLIT(IY,NX-1).NE.IG)) - END DO - IF ( MSPLIT(NY, 1) .EQ. IG ) MASK(NY, 1) = & - (SEA(NY-1, 1).AND.(MSPLIT(NY-1, 1).NE.IG)) & - .OR. (SEA(NY , 2).AND.(MSPLIT(NY , 2).NE.IG)) - IF ( MSPLIT(NY,NX) .EQ. IG ) MASK(NY,NX) = & - (SEA(NY-1,NX).AND.(MSPLIT(NY-1,NX).NE.IG)) & - .OR. (SEA(NY,NX-1).AND.(MSPLIT(NY,NX-1).NE.IG)) + CALL STRACE (IENT, 'GRTRIM') +#endif + ! + ITARG = NSEA / NG + ! + ! 1. Loop over grids ------------------------------------------------ * + ! + DO IG=1, NG + ! + IPTS = GSTATS(IG)%NPTS + MY = 1 + GSTATS(IG)%NYH - GSTATS(IG)%NYL + MX = 1 + GSTATS(IG)%NXH - GSTATS(IG)%NXL + IF ( GSTATS(IG)%STRADLE ) MX = MX + NX + ICIRC = 2 * ( MX + MY ) + ! + NWDTH = 1 + ! + ITL = MIN ( ITARG , MAX ( ITARG-2*ICIRC , 3*ICIRC ) ) + IF ( IPTS .LT. ITL ) NWDTH = 0 + ! + IF ( IPTS.GT.ITARG ) THEN + NWDTH = 1 + & + MAX(0,+NINT((REAL((IPTS-ITARG))/REAL(ICIRC)-1.)/3.)) + ENDIF + ! + DO J=1, NWDTH + ! + MASK = .FALSE. + ! + ! 2. Mark points to be removed -------------------------------------- * + ! + DO IX=2, NX-1 + IF ( MSPLIT( 1,IX) .EQ. IG ) MASK( 1,IX) = & + (SEA( 2,IX ).AND.(MSPLIT( 2,IX ).NE.IG)) & + .OR. (SEA( 1,IX+1).AND.(MSPLIT( 1,IX+1).NE.IG)) & + .OR. (SEA( 1,IX-1).AND.(MSPLIT( 1,IX-1).NE.IG)) + DO IY=2, NY-1 + IF ( MSPLIT(IY,IX) .EQ. IG ) MASK(IY,IX) = & + (SEA(IY+1,IX ).AND.(MSPLIT(IY+1,IX ).NE.IG)) & + .OR. (SEA(IY-1,IX ).AND.(MSPLIT(IY-1,IX ).NE.IG)) & + .OR. (SEA(IY ,IX+1).AND.(MSPLIT(IY ,IX+1).NE.IG)) & + .OR. (SEA(IY ,IX-1).AND.(MSPLIT(IY ,IX-1).NE.IG)) + END DO + IF ( MSPLIT(NY,IX) .EQ. IG ) MASK(NY,IX) = & + (SEA(NY-1,IX ).AND.(MSPLIT(NY-1,IX ).NE.IG)) & + .OR. (SEA(NY ,IX+1).AND.(MSPLIT(NY ,IX+1).NE.IG)) & + .OR. (SEA(NY ,IX-1).AND.(MSPLIT(NY ,IX-1).NE.IG)) + END DO + ! + IF ( GLOBAL ) THEN + IF ( MSPLIT( 1, 1) .EQ. IG ) MASK( 1, 1) = & + (SEA( 2, 1).AND.(MSPLIT( 2, 1).NE.IG)) & + .OR. (SEA( 1, 2).AND.(MSPLIT( 1, 2).NE.IG)) & + .OR. (SEA( 1,NX).AND.(MSPLIT( 1,NX).NE.IG)) + IF ( MSPLIT( 1,NX) .EQ. IG ) MASK( 1,NX) = & + (SEA( 2,NX ).AND.(MSPLIT( 2,NX ).NE.IG)) & + .OR. (SEA( 1, 1 ).AND.(MSPLIT( 1, 1 ).NE.IG)) & + .OR. (SEA( 1,NX-1).AND.(MSPLIT( 1,NX-1).NE.IG)) + DO IY=2, NY-1 + IF ( MSPLIT(IY, 1) .EQ. IG ) MASK(IY, 1) = & + (SEA(IY+1, 1).AND.(MSPLIT(IY+1, 1).NE.IG)) & + .OR. (SEA(IY-1, 1).AND.(MSPLIT(IY-1, 1).NE.IG)) & + .OR. (SEA(IY , 2).AND.(MSPLIT(IY , 2).NE.IG)) & + .OR. (SEA(IY ,NX).AND.(MSPLIT(IY ,NX).NE.IG)) + IF ( MSPLIT(IY,NX) .EQ. IG ) MASK(IY,NX) = & + (SEA(IY+1,NX).AND.(MSPLIT(IY+1,NX).NE.IG)) & + .OR. (SEA(IY-1,NX).AND.(MSPLIT(IY-1,NX).NE.IG)) & + .OR. (SEA(IY , 1).AND.(MSPLIT(IY , 1).NE.IG)) & + .OR. (SEA(IY,NX-1).AND.(MSPLIT(IY,NX-1).NE.IG)) + END DO + IF ( MSPLIT(NY, 1) .EQ. IG ) MASK(NY, 1) = & + (SEA(NY-1, 1).AND.(MSPLIT(NY-1, 1).NE.IG)) & + .OR. (SEA(NY , 2).AND.(MSPLIT(NY , 2).NE.IG)) & + .OR. (SEA(NY ,NX).AND.(MSPLIT(NY ,NX).NE.IG)) + IF ( MSPLIT(NY,NX) .EQ. IG ) MASK(NY,NX) = & + (SEA(NY-1,NX).AND.(MSPLIT(NY-1,NX).NE.IG)) & + .OR. (SEA(NY , 1).AND.(MSPLIT(NY , 1).NE.IG)) & + .OR. (SEA(NY,NX-1).AND.(MSPLIT(NY,NX-1).NE.IG)) + ELSE + IF ( MSPLIT( 1, 1) .EQ. IG ) MASK( 1, 1) = & + (SEA( 2, 1).AND.(MSPLIT( 2, 1).NE.IG)) & + .OR. (SEA( 1, 2).AND.(MSPLIT( 1, 2).NE.IG)) + IF ( MSPLIT( 1,NX) .EQ. IG ) MASK( 1,NX) = & + (SEA( 2,NX ).AND.(MSPLIT( 2,NX ).NE.IG)) & + .OR. (SEA( 1,NX-1).AND.(MSPLIT( 1,NX-1).NE.IG)) + DO IY=2, NY-1 + IF ( MSPLIT(IY, 1) .EQ. IG ) MASK(IY, 1) = & + (SEA(IY+1, 1).AND.(MSPLIT(IY+1, 1).NE.IG)) & + .OR. (SEA(IY-1, 1).AND.(MSPLIT(IY-1, 1).NE.IG)) & + .OR. (SEA(IY , 2).AND.(MSPLIT(IY , 2).NE.IG)) + IF ( MSPLIT(IY,NX) .EQ. IG ) MASK(IY,NX) = & + (SEA(IY+1,NX).AND.(MSPLIT(IY+1,NX).NE.IG)) & + .OR. (SEA(IY-1,NX).AND.(MSPLIT(IY-1,NX).NE.IG)) & + .OR. (SEA(IY,NX-1).AND.(MSPLIT(IY,NX-1).NE.IG)) + END DO + IF ( MSPLIT(NY, 1) .EQ. IG ) MASK(NY, 1) = & + (SEA(NY-1, 1).AND.(MSPLIT(NY-1, 1).NE.IG)) & + .OR. (SEA(NY , 2).AND.(MSPLIT(NY , 2).NE.IG)) + IF ( MSPLIT(NY,NX) .EQ. IG ) MASK(NY,NX) = & + (SEA(NY-1,NX).AND.(MSPLIT(NY-1,NX).NE.IG)) & + .OR. (SEA(NY,NX-1).AND.(MSPLIT(NY,NX-1).NE.IG)) + END IF + ! + ! 3. Remove marked points ------------------------------------------- * + ! + DO IX=1, NX + DO IY=1, NY + IF ( MASK(IY,IX) ) THEN + MSPLIT(IY,IX) = -1 END IF -! -! 3. Remove marked points ------------------------------------------- * -! - DO IX=1, NX - DO IY=1, NY - IF ( MASK(IY,IX) ) THEN - MSPLIT(IY,IX) = -1 - END IF - END DO - END DO -! -! ... End loops started in 1. -! END DO END DO -! - RETURN -! -! Formats -! -!/ End of GRTRIM ----------------------------------------------------- / -!/ - END SUBROUTINE GRTRIM -!/ ------------------------------------------------------------------- / + ! + ! ... End loops started in 1. + ! + END DO + END DO + ! + RETURN + ! + ! Formats + ! + !/ End of GRTRIM ----------------------------------------------------- / + !/ + END SUBROUTINE GRTRIM + !/ ------------------------------------------------------------------- / -!> @brief Reassign unassigned grid points to grids, starting with the -!> smallest grids. -!> -!> @param[in] ND Depth of halo for first sweep. -!> @author H. L. Tolman @date 01-Feb-2013 - SUBROUTINE GRFILL ( ND ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Feb-2013 | -!/ +-----------------------------------+ -!/ -!/ 07-Sep-2012 : Origination. ( version 4.10 ) -!/ 18-Sep-2012 : Include edge points of grid. ( version 4.10 ) -!/ Add convergence check. -!/ 29-Jan-2013 : Add error code on stop. ( version 4.10 ) -!/ 29-Jan-2013 : Add error test output. ( version 4.10 ) -!/ 01-Feb-2013 : Loop over selected sea points only. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Reassign unassigned grid points to grids, starting with the -! smallest grids. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ND Int. I Depth of halo for first sweep. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ND -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NMIN, I, NDEPTH, NITT, NADD, IXL, IXR,& - NLEFT, NRIGHT, NXL, NXH, NYL, NYH - INTEGER :: NXYOFF = 3 - INTEGER :: IIX(NSEA), IIY(NSEA), ISEA, NSEAL + !> @brief Reassign unassigned grid points to grids, starting with the + !> smallest grids. + !> + !> @param[in] ND Depth of halo for first sweep. + !> @author H. L. Tolman @date 01-Feb-2013 + SUBROUTINE GRFILL ( ND ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Feb-2013 | + !/ +-----------------------------------+ + !/ + !/ 07-Sep-2012 : Origination. ( version 4.10 ) + !/ 18-Sep-2012 : Include edge points of grid. ( version 4.10 ) + !/ Add convergence check. + !/ 29-Jan-2013 : Add error code on stop. ( version 4.10 ) + !/ 29-Jan-2013 : Add error test output. ( version 4.10 ) + !/ 01-Feb-2013 : Loop over selected sea points only. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Reassign unassigned grid points to grids, starting with the + ! smallest grids. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ND Int. I Depth of halo for first sweep. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: ND + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NMIN, I, NDEPTH, NITT, NADD, IXL, IXR,& + NLEFT, NRIGHT, NXL, NXH, NYL, NYH + INTEGER :: NXYOFF = 3 + INTEGER :: IIX(NSEA), IIY(NSEA), ISEA, NSEAL #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - LOGICAL :: DONE(NG), MASK(NY,NX), FLOST(NG), & - XFL(NX), YFL(NY) -!/ -!/ ------------------------------------------------------------------- / -!/ + LOGICAL :: DONE(NG), MASK(NY,NX), FLOST(NG), & + XFL(NX), YFL(NY) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GRFILL') -#endif -! -! 1. Loop to assure all reassigned ---------------------------------- * -! - NDEPTH = ND - NITT = 0 - NLEFT = -1 - FLOST = .FALSE. -! - NSEAL = 0 - DO IX=1, NX - DO IY=1, NY - IF ( MSPLIT(IY,IX) .EQ. -1 ) THEN - NSEAL = NSEAL + 1 - IIX(NSEAL) = IX - IIY(NSEAL) = IY + CALL STRACE (IENT, 'GRFILL') +#endif + ! + ! 1. Loop to assure all reassigned ---------------------------------- * + ! + NDEPTH = ND + NITT = 0 + NLEFT = -1 + FLOST = .FALSE. + ! + NSEAL = 0 + DO IX=1, NX + DO IY=1, NY + IF ( MSPLIT(IY,IX) .EQ. -1 ) THEN + NSEAL = NSEAL + 1 + IIX(NSEAL) = IX + IIY(NSEAL) = IY + END IF + END DO + END DO + ! + DO + NITT = NITT + 1 + ! + ! 2. Loop over all grids -------------------------------------------- * + ! + DONE = .FALSE. + ! + DO J=1, NG + ! + ! 3. Find smallest unprocessed grid --------------------------------- * + ! + NMIN = NSEA + 1 + IG = 0 + ! + DO I=1, NG + IF ( .NOT.DONE(I) .AND. GSTATS(I)%NPTS.LT.NMIN ) THEN + IG = I + NMIN = GSTATS(I)%NPTS + END IF + END DO + ! + DONE(IG) = .TRUE. + ! +#ifdef W3_T2 + WRITE (NDST,9030) IG, J, NMIN +#endif + ! + ! 4. Loop for halos per grid ---------------------------------------- * + ! + DO, I=1, NDEPTH + ! + MASK = .FALSE. + ! + ! 5. Mark grid point for adding ------------------------------------- * + ! + DO ISEA=1, NSEAL + IX = IIX(ISEA) + IY = IIY(ISEA) + IXL = 1 + MOD(IX-2+NX,NX) + IXR = 1 + MOD(IX,NX) + IF ( MSPLIT(IY,IX) .EQ. -1 ) MASK(IY,IX) = & + ( MSPLIT(IY+1,IX ) .EQ. IG ) & + .OR. ( MSPLIT(IY-1,IX ) .EQ. IG ) & + .OR. ( MSPLIT(IY ,IXR) .EQ. IG ) & + .OR. ( MSPLIT(IY ,IXL) .EQ. IG ) + END DO + ! + ! 6. Add marked grid point ------------------------------------------ * + ! + NADD = 0 + ! + DO ISEA=1, NSEAL + IX = IIX(ISEA) + IY = IIY(ISEA) + IF ( MASK(IY,IX) ) THEN + MSPLIT(IY,IX) = IG + NADD = NADD + 1 END IF END DO + ! + IF ( NADD .EQ. 0 ) EXIT + ! + ! ... End loop started in 4. + ! END DO -! - DO - NITT = NITT + 1 -! -! 2. Loop over all grids -------------------------------------------- * -! - DONE = .FALSE. -! - DO J=1, NG -! -! 3. Find smallest unprocessed grid --------------------------------- * -! - NMIN = NSEA + 1 - IG = 0 -! - DO I=1, NG - IF ( .NOT.DONE(I) .AND. GSTATS(I)%NPTS.LT.NMIN ) THEN - IG = I - NMIN = GSTATS(I)%NPTS - END IF - END DO -! - DONE(IG) = .TRUE. -! + ! + ! ... End loop started in 2. + ! + END DO + ! + NDEPTH = 1 + ! + ! 7. Check convergence ---------------------------------------------- * + ! 7.a Find number of points left + ! + NRIGHT = NLEFT + NLEFT = 0 + ! + DO ISEA=1, NSEAL + IX = IIX(ISEA) + IY = IIY(ISEA) + IF ( MSPLIT(IY,IX) .EQ. -1 ) NLEFT = NLEFT + 1 + END DO + ! #ifdef W3_T2 - WRITE (NDST,9030) IG, J, NMIN -#endif -! -! 4. Loop for halos per grid ---------------------------------------- * -! - DO, I=1, NDEPTH -! - MASK = .FALSE. -! -! 5. Mark grid point for adding ------------------------------------- * -! - DO ISEA=1, NSEAL - IX = IIX(ISEA) - IY = IIY(ISEA) - IXL = 1 + MOD(IX-2+NX,NX) - IXR = 1 + MOD(IX,NX) - IF ( MSPLIT(IY,IX) .EQ. -1 ) MASK(IY,IX) = & - ( MSPLIT(IY+1,IX ) .EQ. IG ) & - .OR. ( MSPLIT(IY-1,IX ) .EQ. IG ) & - .OR. ( MSPLIT(IY ,IXR) .EQ. IG ) & - .OR. ( MSPLIT(IY ,IXL) .EQ. IG ) - END DO -! -! 6. Add marked grid point ------------------------------------------ * -! - NADD = 0 -! + WRITE (NDST,9070) NITT, NLEFT +#endif + ! + ! 7.b No point left, exit loop + ! + IF ( NLEFT .EQ. 0 ) EXIT + ! + ! 7.c Stuck with points left + ! + IF ( NRIGHT .GT. 0 ) THEN + IF ( NLEFT .EQ. NRIGHT ) THEN + ! + ! 7.d Do lost point correction once + ! + IF ( .NOT. FLOST(IG) ) THEN + CALL GRLOST + FLOST(IG) = .TRUE. + ELSE + ! + ! 7.e Got stuck for good, error message and ouput + ! + WRITE (NDSE,1000) IG, NITT, NLEFT + ! + XFL = .FALSE. + YFL = .FALSE. + ! DO ISEA=1, NSEAL IX = IIX(ISEA) IY = IIY(ISEA) - IF ( MASK(IY,IX) ) THEN - MSPLIT(IY,IX) = IG - NADD = NADD + 1 - END IF - END DO -! - IF ( NADD .EQ. 0 ) EXIT -! -! ... End loop started in 4. -! + IF ( MSPLIT(IY,IX) .EQ. -1 ) THEN + XFL(MAX(1,IX-NXYOFF):MIN(NX,IX+NXYOFF)) = .TRUE. + YFL(MAX(1,IY-NXYOFF):MIN(NY,IY+NXYOFF)) = .TRUE. + END IF END DO -! -! ... End loop started in 2. -! - END DO -! - NDEPTH = 1 -! -! 7. Check convergence ---------------------------------------------- * -! 7.a Find number of points left -! - NRIGHT = NLEFT - NLEFT = 0 -! - DO ISEA=1, NSEAL - IX = IIX(ISEA) - IY = IIY(ISEA) - IF ( MSPLIT(IY,IX) .EQ. -1 ) NLEFT = NLEFT + 1 - END DO -! -#ifdef W3_T2 - WRITE (NDST,9070) NITT, NLEFT -#endif -! -! 7.b No point left, exit loop -! - IF ( NLEFT .EQ. 0 ) EXIT -! -! 7.c Stuck with points left -! - IF ( NRIGHT .GT. 0 ) THEN - IF ( NLEFT .EQ. NRIGHT ) THEN -! -! 7.d Do lost point correction once -! - IF ( .NOT. FLOST(IG) ) THEN - CALL GRLOST - FLOST(IG) = .TRUE. - ELSE -! -! 7.e Got stuck for good, error message and ouput -! - WRITE (NDSE,1000) IG, NITT, NLEFT -! - XFL = .FALSE. - YFL = .FALSE. -! - DO ISEA=1, NSEAL - IX = IIX(ISEA) - IY = IIY(ISEA) - IF ( MSPLIT(IY,IX) .EQ. -1 ) THEN - XFL(MAX(1,IX-NXYOFF):MIN(NX,IX+NXYOFF)) = .TRUE. - YFL(MAX(1,IY-NXYOFF):MIN(NY,IY+NXYOFF)) = .TRUE. - END IF - END DO -! - NXL = 0 - NXH = 0 - DO IX=1, NX - IF ( XFL(IX) .AND. NXL.EQ. 0 ) NXL = IX - IF ( XFL(IX) .AND. IX.EQ. NX ) NXH = IX - IF ( .NOT. XFL(IX) .AND. NXL.NE. 0 ) NXH = IX-1 - IF ( NXH .NE. 0 ) THEN - NYL = 0 - NYH = 0 - DO IY=1, NY - IF ( YFL(IY) .AND. NYL.EQ. 0 ) NYL = IY - IF ( YFL(IY) .AND. IY.EQ. NY ) NYH = IY - IF ( .NOT. YFL(IY) .AND. NYL.NE. 0 ) & - NYH = IY-1 - IF ( NYH .NE. 0 ) THEN - WRITE (NDST,1001) NXL, NXH, NYH, NYL - DO I=NYH, NYL, -1 - WRITE (NDST,1002) MSPLIT(I,NXL:NXH) - END DO - NYL = 0 - NYH = 0 - END IF - END DO - NXL = 0 - NXH = 0 - END IF - END DO -! -! ... Stop program with error output ... -! - STOP 01 - ENDIF -! + ! + NXL = 0 + NXH = 0 + DO IX=1, NX + IF ( XFL(IX) .AND. NXL.EQ. 0 ) NXL = IX + IF ( XFL(IX) .AND. IX.EQ. NX ) NXH = IX + IF ( .NOT. XFL(IX) .AND. NXL.NE. 0 ) NXH = IX-1 + IF ( NXH .NE. 0 ) THEN + NYL = 0 + NYH = 0 + DO IY=1, NY + IF ( YFL(IY) .AND. NYL.EQ. 0 ) NYL = IY + IF ( YFL(IY) .AND. IY.EQ. NY ) NYH = IY + IF ( .NOT. YFL(IY) .AND. NYL.NE. 0 ) & + NYH = IY-1 + IF ( NYH .NE. 0 ) THEN + WRITE (NDST,1001) NXL, NXH, NYH, NYL + DO I=NYH, NYL, -1 + WRITE (NDST,1002) MSPLIT(I,NXL:NXH) + END DO + NYL = 0 + NYH = 0 + END IF + END DO + NXL = 0 + NXH = 0 END IF - END IF -! -! ... End loop started in 1. -! - END DO -! - RETURN -! -! Formats -! - 1000 FORMAT (/' *** ERROR GRFILL : NO MORE CONVERGENCE, ', & - 'NITT, NLEFT:',2I8,' ***'/) - 1001 FORMAT ( ' MAP OUTPUT FOR GRID',I3,' AND X AND Y RANGE :',4I6/) - 1002 FORMAT ( ' ',60I2) -! + END DO + ! + ! ... Stop program with error output ... + ! + STOP 01 + ENDIF + ! + END IF + END IF + ! + ! ... End loop started in 1. + ! + END DO + ! + RETURN + ! + ! Formats + ! +1000 FORMAT (/' *** ERROR GRFILL : NO MORE CONVERGENCE, ', & + 'NITT, NLEFT:',2I8,' ***'/) +1001 FORMAT ( ' MAP OUTPUT FOR GRID',I3,' AND X AND Y RANGE :',4I6/) +1002 FORMAT ( ' ',60I2) + ! #ifdef W3_T2 - 9030 FORMAT ( 'TEST GRFILL: PROCESSING GRID',I5,' (',I5,')',I8) - 9060 FORMAT ( 'TEST GRFILL: GRID, HALO, NADD :',I5,I2,I8) - 9070 FORMAT ( 'TEST GRFILL: NITT, NLEFT :',2I6) -#endif -! -!/ End of GRFILL ----------------------------------------------------- / -!/ - END SUBROUTINE GRFILL -!/ ------------------------------------------------------------------- / +9030 FORMAT ( 'TEST GRFILL: PROCESSING GRID',I5,' (',I5,')',I8) +9060 FORMAT ( 'TEST GRFILL: GRID, HALO, NADD :',I5,I2,I8) +9070 FORMAT ( 'TEST GRFILL: NITT, NLEFT :',2I6) +#endif + ! + !/ End of GRFILL ----------------------------------------------------- / + !/ + END SUBROUTINE GRFILL + !/ ------------------------------------------------------------------- / -!> @brief Reassign unassigned grid points to grids. -!> -!> @details Dealing with lost point by finding closest grids. -!> -!> @author H. L. Tolman @date 09-Jan-2013 - SUBROUTINE GRLOST -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : .9-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 31-Jan-2013 : Origination. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Reassign unassigned grid points to grids. Dealing with lost -! point by finding closest grids. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IX, IY, IOFF, JJX, JX, JY, IG, I + !> @brief Reassign unassigned grid points to grids. + !> + !> @details Dealing with lost point by finding closest grids. + !> + !> @author H. L. Tolman @date 09-Jan-2013 + SUBROUTINE GRLOST + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : .9-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 31-Jan-2013 : Origination. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Reassign unassigned grid points to grids. Dealing with lost + ! point by finding closest grids. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IX, IY, IOFF, JJX, JX, JY, IG, I #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: IFOUND(-1:NG) -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER :: IFOUND(-1:NG) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GRLOST') + CALL STRACE (IENT, 'GRLOST') #endif -! -! 1. Loop over all grid points -------------------------------------- * -! - DO IX=1, NX - DO IY=1, NY -! - IF ( MSPLIT(IY,IX) .EQ. -1 ) THEN -! -! 2. Find nearest grid(s) ------------------------------------------- * -! - IOFF = 1 -! - DO -! - IFOUND = 0 - DO JJX=IX-IOFF, IX+IOFF - IF ( GLOBAL ) THEN - JX = 1 + MOD(JJX-1+2*NX,NX) - ELSE - JX = JJX - END IF - IF ( JX.LT.1 .OR. JX.GT.NX ) CYCLE - DO JY=IY-IOFF, IY+IOFF - IF ( JY.LT.1 .OR. JY.GT.NY ) CYCLE - IFOUND(MSPLIT(JY,JX)) = IFOUND(MSPLIT(JY,JX)) + 1 - END DO - END DO -! - IG = 0 - DO I=1, NG - IF ( IFOUND(I) .GT. 0 ) THEN - IG = I - EXIT - END IF - END DO -! - IF ( IG .NE. 0 ) THEN - MSPLIT(IY,IX) = IG - EXIT - END IF -! - IOFF = IOFF + 1 - IF ( IOFF .GT. NX .AND. IOFF.GT.NY ) EXIT - END DO -! -! ... End of loops and logic started in 1. -! + ! + ! 1. Loop over all grid points -------------------------------------- * + ! + DO IX=1, NX + DO IY=1, NY + ! + IF ( MSPLIT(IY,IX) .EQ. -1 ) THEN + ! + ! 2. Find nearest grid(s) ------------------------------------------- * + ! + IOFF = 1 + ! + DO + ! + IFOUND = 0 + DO JJX=IX-IOFF, IX+IOFF + IF ( GLOBAL ) THEN + JX = 1 + MOD(JJX-1+2*NX,NX) + ELSE + JX = JJX + END IF + IF ( JX.LT.1 .OR. JX.GT.NX ) CYCLE + DO JY=IY-IOFF, IY+IOFF + IF ( JY.LT.1 .OR. JY.GT.NY ) CYCLE + IFOUND(MSPLIT(JY,JX)) = IFOUND(MSPLIT(JY,JX)) + 1 + END DO + END DO + ! + IG = 0 + DO I=1, NG + IF ( IFOUND(I) .GT. 0 ) THEN + IG = I + EXIT + END IF + END DO + ! + IF ( IG .NE. 0 ) THEN + MSPLIT(IY,IX) = IG + EXIT END IF -! + ! + IOFF = IOFF + 1 + IF ( IOFF .GT. NX .AND. IOFF.GT.NY ) EXIT END DO - END DO -! - RETURN -! -! Formats -! -!/ End of GRLOST ----------------------------------------------------- / -!/ - END SUBROUTINE GRLOST -!/ ------------------------------------------------------------------- / + ! + ! ... End of loops and logic started in 1. + ! + END IF + ! + END DO + END DO + ! + RETURN + ! + ! Formats + ! + !/ End of GRLOST ----------------------------------------------------- / + !/ + END SUBROUTINE GRLOST + !/ ------------------------------------------------------------------- / -!> @brief Attempt to square-up grid. -!> -!> @details Attempt to square-up grid by taking off grid point in -!> outermost grid point in X and Y only, after which GRFILL is to be -!> run to re-assign grid points. -!> -!> @author H. L. Tolman @date 07-Sep-2012 - SUBROUTINE GRSQRG -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 07-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 07-Sep-2012 : Origination. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Attemp to square-up grid by taking off grid point in outermost -! grid point in X and Y only, after which GRFILL is to be run to -! re-assign grid points, -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: MX, MY + !> @brief Attempt to square-up grid. + !> + !> @details Attempt to square-up grid by taking off grid point in + !> outermost grid point in X and Y only, after which GRFILL is to be + !> run to re-assign grid points. + !> + !> @author H. L. Tolman @date 07-Sep-2012 + SUBROUTINE GRSQRG + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 07-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 07-Sep-2012 : Origination. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Attemp to square-up grid by taking off grid point in outermost + ! grid point in X and Y only, after which GRFILL is to be run to + ! re-assign grid points, + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: MX, MY #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GRSQRG') -#endif -! -! 1. Loop over grids ------------------------------------------------ * -! - DO IG=1, NG -! - MY = 1 + GSTATS(IG)%NYH - GSTATS(IG)%NYL - MX = 1 + GSTATS(IG)%NXH - GSTATS(IG)%NXL - IF ( GSTATS(IG)%STRADLE ) MX = MX + NX -! -! 2. Top ------------------------------------------------------------ * -! - IF ( MY .GE. 5 ) THEN -! - DO IX=1, NX - IF (MSPLIT(GSTATS(IG)%NYH,IX) .EQ. IG ) & - MSPLIT(GSTATS(IG)%NYH,IX) = -1 - END DO -! -! 3. Bottom --------------------------------------------------------- * -! - DO IX=1, NX - IF (MSPLIT(GSTATS(IG)%NYL,IX) .EQ. IG ) & - MSPLIT(GSTATS(IG)%NYL,IX) = -1 - END DO -! - END IF -! -! 4. Left ----------------------------------------------------------- * -! - IF ( MX .GE. 5 ) THEN -! - DO IY=GSTATS(IG)%NYL, GSTATS(IG)%NYH - IF (MSPLIT(IY,GSTATS(IG)%NXL) .EQ. IG ) & - MSPLIT(IY,GSTATS(IG)%NXL) = -1 - END DO -! -! 5. Right ---------------------------------------------------------- * -! - DO IY=GSTATS(IG)%NYH, GSTATS(IG)%NYH - IF (MSPLIT(IY,GSTATS(IG)%NXH) .EQ. IG ) & - MSPLIT(IY,GSTATS(IG)%NXH) = -1 - END DO -! - END IF -! -! ... End loop started in 1. -! + CALL STRACE (IENT, 'GRSQRG') +#endif + ! + ! 1. Loop over grids ------------------------------------------------ * + ! + DO IG=1, NG + ! + MY = 1 + GSTATS(IG)%NYH - GSTATS(IG)%NYL + MX = 1 + GSTATS(IG)%NXH - GSTATS(IG)%NXL + IF ( GSTATS(IG)%STRADLE ) MX = MX + NX + ! + ! 2. Top ------------------------------------------------------------ * + ! + IF ( MY .GE. 5 ) THEN + ! + DO IX=1, NX + IF (MSPLIT(GSTATS(IG)%NYH,IX) .EQ. IG ) & + MSPLIT(GSTATS(IG)%NYH,IX) = -1 END DO -! - RETURN -! -! Formats -! -!/ End of GRSQRG ----------------------------------------------------- / -!/ - END SUBROUTINE GRSQRG -!/ ------------------------------------------------------------------- / - -!> @brief Remove seapoints with only one adjacent point in same grid. -!> -!> @details Remove points from a grid that are in the middle of the -!> sea, but that have omly one adjacent point in the same grid. Directly -!> select a new grid for this point rather than deactivate and use -!> GRFILL. -!> -!> @param[inout] OK Flag for grid status -!> @author H. L. Tolman @date 09-Sep-2012 - SUBROUTINE GRSNGL ( OK ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 09-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 09-Sep-2012 : Origination. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Remove points from a grid that are in the middle of the sea, but -! that have omly one adjacent point in the same grid. Directly -! select a new grid for this point rather than deactivate and use -! GRFILL. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! OK Log. I/O Flag for grid status, .F. if values of -! -1 are left in MSPLIT. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - LOGICAL, INTENT(INOUT) :: OK -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NX0, NXN, IXL, IXH, COUNT(-1:NG), & - INEW1, INEW2, INEW + ! + ! 3. Bottom --------------------------------------------------------- * + ! + DO IX=1, NX + IF (MSPLIT(GSTATS(IG)%NYL,IX) .EQ. IG ) & + MSPLIT(GSTATS(IG)%NYL,IX) = -1 + END DO + ! + END IF + ! + ! 4. Left ----------------------------------------------------------- * + ! + IF ( MX .GE. 5 ) THEN + ! + DO IY=GSTATS(IG)%NYL, GSTATS(IG)%NYH + IF (MSPLIT(IY,GSTATS(IG)%NXL) .EQ. IG ) & + MSPLIT(IY,GSTATS(IG)%NXL) = -1 + END DO + ! + ! 5. Right ---------------------------------------------------------- * + ! + DO IY=GSTATS(IG)%NYH, GSTATS(IG)%NYH + IF (MSPLIT(IY,GSTATS(IG)%NXH) .EQ. IG ) & + MSPLIT(IY,GSTATS(IG)%NXH) = -1 + END DO + ! + END IF + ! + ! ... End loop started in 1. + ! + END DO + ! + RETURN + ! + ! Formats + ! + !/ End of GRSQRG ----------------------------------------------------- / + !/ + END SUBROUTINE GRSQRG + !/ ------------------------------------------------------------------- / + + !> @brief Remove seapoints with only one adjacent point in same grid. + !> + !> @details Remove points from a grid that are in the middle of the + !> sea, but that have omly one adjacent point in the same grid. Directly + !> select a new grid for this point rather than deactivate and use + !> GRFILL. + !> + !> @param[inout] OK Flag for grid status + !> @author H. L. Tolman @date 09-Sep-2012 + SUBROUTINE GRSNGL ( OK ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 09-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 09-Sep-2012 : Origination. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Remove points from a grid that are in the middle of the sea, but + ! that have omly one adjacent point in the same grid. Directly + ! select a new grid for this point rather than deactivate and use + ! GRFILL. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! OK Log. I/O Flag for grid status, .F. if values of + ! -1 are left in MSPLIT. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + LOGICAL, INTENT(INOUT) :: OK + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NX0, NXN, IXL, IXH, COUNT(-1:NG), & + INEW1, INEW2, INEW #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GRSNGL') -#endif -! -! 1. Set up looping ------------------------------------------------- * -! - IF ( GLOBAL ) THEN - NX0 = 1 - NXN = NX - ELSE - NX0 = 2 - NXN = NX-1 - END IF -! -! 2. Loops over 2D grid --------------------------------------------- * -! - DO IX=NX0, NXN -! - IXL = IX - 1 - IXH = IX + 1 - IF ( IX .EQ. 1 ) IXL = NX - IF ( IX .EQ. NX ) IXH = 1 -! - DO IY=2, NY-1 -! -! 3. Central sea points only ---------------------------------------- * -! - IF ( SEA(IY,IX) .AND. SEA(IY-1,IX ) .AND. SEA(IY+1,IX ) & - .AND. SEA(IY ,IXL) .AND. SEA(IY ,IXH) ) THEN -! -! 4. Check for 'lost points' ---------------------------------------- * -! - COUNT = 0 - IG = MSPLIT(IY,IX) -! - COUNT(IG) = 1 - COUNT(MSPLIT(IY-1,IX )) = COUNT(MSPLIT(IY-1,IX )) + 1 - COUNT(MSPLIT(IY+1,IX )) = COUNT(MSPLIT(IY+1,IX )) + 1 - COUNT(MSPLIT(IY ,IXL)) = COUNT(MSPLIT(IY ,IXL)) + 1 - COUNT(MSPLIT(IY ,IXH)) = COUNT(MSPLIT(IY ,IXH)) + 1 -! - IF ( COUNT(IG) .LE. 2 ) THEN -! + CALL STRACE (IENT, 'GRSNGL') +#endif + ! + ! 1. Set up looping ------------------------------------------------- * + ! + IF ( GLOBAL ) THEN + NX0 = 1 + NXN = NX + ELSE + NX0 = 2 + NXN = NX-1 + END IF + ! + ! 2. Loops over 2D grid --------------------------------------------- * + ! + DO IX=NX0, NXN + ! + IXL = IX - 1 + IXH = IX + 1 + IF ( IX .EQ. 1 ) IXL = NX + IF ( IX .EQ. NX ) IXH = 1 + ! + DO IY=2, NY-1 + ! + ! 3. Central sea points only ---------------------------------------- * + ! + IF ( SEA(IY,IX) .AND. SEA(IY-1,IX ) .AND. SEA(IY+1,IX ) & + .AND. SEA(IY ,IXL) .AND. SEA(IY ,IXH) ) THEN + ! + ! 4. Check for 'lost points' ---------------------------------------- * + ! + COUNT = 0 + IG = MSPLIT(IY,IX) + ! + COUNT(IG) = 1 + COUNT(MSPLIT(IY-1,IX )) = COUNT(MSPLIT(IY-1,IX )) + 1 + COUNT(MSPLIT(IY+1,IX )) = COUNT(MSPLIT(IY+1,IX )) + 1 + COUNT(MSPLIT(IY ,IXL)) = COUNT(MSPLIT(IY ,IXL)) + 1 + COUNT(MSPLIT(IY ,IXH)) = COUNT(MSPLIT(IY ,IXH)) + 1 + ! + IF ( COUNT(IG) .LE. 2 ) THEN + ! #ifdef W3_T3 - WRITE (NDST,9040) IX, IY, IG -#endif -! - INEW1 = -1 - INEW2 = -1 -! - DO J=1, NG - IF ( COUNT(J) .GE. 2 ) THEN + WRITE (NDST,9040) IX, IY, IG +#endif + ! + INEW1 = -1 + INEW2 = -1 + ! + DO J=1, NG + IF ( COUNT(J) .GE. 2 ) THEN #ifdef W3_T3 - WRITE (NDST,9041) J -#endif - IF ( INEW1 .EQ. -1 ) THEN - INEW1 = J - ELSE - INEW2 = J - EXIT - END IF - END IF - END DO -! - IF ( INEW1 .EQ. -1 ) THEN - INEW = -1 - OK = .FALSE. + WRITE (NDST,9041) J +#endif + IF ( INEW1 .EQ. -1 ) THEN + INEW1 = J + ELSE + INEW2 = J + EXIT + END IF + END IF + END DO + ! + IF ( INEW1 .EQ. -1 ) THEN + INEW = -1 + OK = .FALSE. #ifdef W3_T3 - WRITE (NDST,9043) + WRITE (NDST,9043) #endif - ELSE IF ( INEW2 .EQ. -1 ) THEN - INEW = INEW1 + ELSE IF ( INEW2 .EQ. -1 ) THEN + INEW = INEW1 #ifdef W3_T3 - WRITE (NDST,9042) INEW -#endif - ELSE - IF ( GSTATS(INEW1)%NPTS .GT. & - GSTATS(INEW2)%NPTS ) THEN - INEW = INEW2 - ELSE - INEW = INEW1 - END IF + WRITE (NDST,9042) INEW +#endif + ELSE + IF ( GSTATS(INEW1)%NPTS .GT. & + GSTATS(INEW2)%NPTS ) THEN + INEW = INEW2 + ELSE + INEW = INEW1 + END IF #ifdef W3_T3 - WRITE (NDST,9042) INEW + WRITE (NDST,9042) INEW #endif - END IF -! - MSPLIT(IY,IX) = INEW -! - END IF -! END IF -! -! ... End loops started in 2. -! - END DO -! - END DO -! - RETURN -! -! Formats -! + ! + MSPLIT(IY,IX) = INEW + ! + END IF + ! + END IF + ! + ! ... End loops started in 2. + ! + END DO + ! + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T3 - 9040 FORMAT ( 'TEST GRSNGL: POINT FOUND, IX, IY, IG:',2I5,I4) - 9041 FORMAT ( ' CANDIDATE GRID :',10X,I4) - 9042 FORMAT ( ' GRID USED :',10X,I4) - 9043 FORMAT ( ' GRID LEFT UNDIFINED') -#endif -! -!/ End of GRSNGL ----------------------------------------------------- / -!/ - END SUBROUTINE GRSNGL -!/ ------------------------------------------------------------------- / +9040 FORMAT ( 'TEST GRSNGL: POINT FOUND, IX, IY, IG:',2I5,I4) +9041 FORMAT ( ' CANDIDATE GRID :',10X,I4) +9042 FORMAT ( ' GRID USED :',10X,I4) +9043 FORMAT ( ' GRID LEFT UNDIFINED') +#endif + ! + !/ End of GRSNGL ----------------------------------------------------- / + !/ + END SUBROUTINE GRSNGL + !/ ------------------------------------------------------------------- / -!> @brief Remove smaller grid parts. -!> -!> @details Remove smller parts of a grid that are separated from -!> the main body, and that can be attached to other grids. -!> -!> @param[inout] OK -!> @param[inout] FRAC Fraction of average size used to remove grid part. -!> @author H. L. Tolman @date 01-Feb-2013 - SUBROUTINE GRSEPA ( OK, FRAC ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Feb-2013 | -!/ +-----------------------------------+ -!/ -!/ 10-Sep-2012 : Origination. ( version 4.10 ) -!/ 18-Sep-2012 : Include edge points of grid. ( version 4.10 ) -!/ 01-Feb-2013 : Much faster algorithms. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Remove smller parts of a grid that are separated from the main -! body, and that can be attached to other grids. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! OK Log. I/O Flag for grid status, .F. if values of -! -1 are left in MSPLIT. -! FRAC Real I Fraction of average size used to remove grid -! part. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: FRAC - LOGICAL, INTENT(INOUT) :: OK -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IPAVG, IPCHCK, ID, IPTOT, IX, IY, & - IXL, IYL, IDL, JX, JY, KY, IPT, & - IXH, IYH, I, J, K, L, IMIN, LMIN + !> @brief Remove smaller grid parts. + !> + !> @details Remove smller parts of a grid that are separated from + !> the main body, and that can be attached to other grids. + !> + !> @param[inout] OK + !> @param[inout] FRAC Fraction of average size used to remove grid part. + !> @author H. L. Tolman @date 01-Feb-2013 + SUBROUTINE GRSEPA ( OK, FRAC ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 01-Feb-2013 | + !/ +-----------------------------------+ + !/ + !/ 10-Sep-2012 : Origination. ( version 4.10 ) + !/ 18-Sep-2012 : Include edge points of grid. ( version 4.10 ) + !/ 01-Feb-2013 : Much faster algorithms. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Remove smller parts of a grid that are separated from the main + ! body, and that can be attached to other grids. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! OK Log. I/O Flag for grid status, .F. if values of + ! -1 are left in MSPLIT. + ! FRAC Real I Fraction of average size used to remove grid + ! part. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: FRAC + LOGICAL, INTENT(INOUT) :: OK + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IPAVG, IPCHCK, ID, IPTOT, IX, IY, & + IXL, IYL, IDL, JX, JY, KY, IPT, & + IXH, IYH, I, J, K, L, IMIN, LMIN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER :: GMASK(NY,NX), IIX(NSEA), IIY(NSEA) - INTEGER, ALLOCATABLE :: PMAP(:), INGRD(:) - LOGICAL :: PREV - LOGICAL,ALLOCATABLE :: FLNEXT(:), NEXTTO(:,:) -!/ -!/ ------------------------------------------------------------------- / -!/ + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER :: GMASK(NY,NX), IIX(NSEA), IIY(NSEA) + INTEGER, ALLOCATABLE :: PMAP(:), INGRD(:) + LOGICAL :: PREV + LOGICAL,ALLOCATABLE :: FLNEXT(:), NEXTTO(:,:) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GRSEPA') -#endif -! - IPAVG = NINT ( REAL(NSEA) / REAL(NG) ) - IPCHCK = NINT ( FRAC * REAL(NSEA) / REAL(NG) ) -! -#ifdef W3_T4 - WRITE (NDST,9000) IPAVG, IPCHCK + CALL STRACE (IENT, 'GRSEPA') #endif -! -! 1. Loop over grids ------------------------------------------------ * -! - DO IG=1, NG -! - GMASK = 0 - ID = 0 -! + ! + IPAVG = NINT ( REAL(NSEA) / REAL(NG) ) + IPCHCK = NINT ( FRAC * REAL(NSEA) / REAL(NG) ) + ! #ifdef W3_T4 - WRITE (NDST,9010) IG -#endif -! -! 2. Find all parts ------------------------------------------------- * -! 2.a First loop, partial parts -! - IPTOT = 0 -! - DO IX=1, NX -! - IXL = 1 + MOD(IX-2+NX,NX) - PREV = .FALSE. -! - DO IY=1, NY - IF (MSPLIT(IY,IX) .EQ. IG ) THEN - IPTOT = IPTOT + 1 - IIX(IPTOT) = IX - IIY(IPTOT) = IY - IF ( .NOT. PREV) THEN - ID = ID + 1 - PREV = .TRUE. - END IF - GMASK(IY,IX) = ID - ELSE IF ( PREV ) THEN - PREV = .FALSE. - IDL = 0 - DO JY=IY-1, 1, -1 - IF ( GMASK(JY,IX) .EQ. 0 ) EXIT - IF ( GMASK(JY,IXL).NE.0 .AND. IDL.EQ.0 ) & - IDL = GMASK(JY,IXL) - END DO - IF ( IDL .NE. 0 ) THEN - DO KY=JY+1, IY-1 - IF ( GMASK(KY,IX).EQ.ID ) GMASK(KY,IX) = IDL - END DO - ID = ID - 1 - END IF -! - END IF - END DO - END DO -! -! 2.b Grid too small, do not cut -! - IF ( IPTOT .LE. IPAVG ) THEN + WRITE (NDST,9000) IPAVG, IPCHCK +#endif + ! + ! 1. Loop over grids ------------------------------------------------ * + ! + DO IG=1, NG + ! + GMASK = 0 + ID = 0 + ! #ifdef W3_T4 - WRITE (NDST,9020) IPTOT, IPAVG -#endif - CYCLE - END IF -! -! 2.c Neighbouring grid parts -! Raw data -! - ALLOCATE ( NEXTTO(0:ID,0:ID), PMAP(0:ID) ) - NEXTTO = .FALSE. -! - DO IPT=1, IPTOT - IX = IIX(IPT) - IY = IIY(IPT) - IXL = 1 + MOD(IX-2+NX,NX) - IYL = IY - 1 - IXH = 1 + MOD(IX,NX) - IYH = IY + 1 - NEXTTO( GMASK(IY,IX) , GMASK(IY ,IXL) ) = .TRUE. - NEXTTO( GMASK(IY,IX) , GMASK(IY ,IXH) ) = .TRUE. - NEXTTO( GMASK(IY,IX) , GMASK(IYL,IX ) ) = .TRUE. - NEXTTO( GMASK(IY,IX) , GMASK(IYH,IX ) ) = .TRUE. - END DO -! -! Make symmetric -! - DO I=1, ID - DO J=1, ID - NEXTTO(I,J) = NEXTTO(I,J) .OR. NEXTTO(J,I) - END DO - END DO -! -! Connect accross neighbours -! - DO I=1, ID - DO J=1, ID - IF ( NEXTTO(I,J) ) THEN - DO K=1, ID - IF ( NEXTTO(K,J) ) THEN - NEXTTO(K,I) = .TRUE. - NEXTTO(I,K) = .TRUE. - END IF - END DO - END IF - END DO - END DO -! -! Map the parts -! - IDL = ID - PMAP = 0 - ID = 0 -! - DO I=1, IDL - IF ( PMAP(I) .EQ. 0 ) THEN + WRITE (NDST,9010) IG +#endif + ! + ! 2. Find all parts ------------------------------------------------- * + ! 2.a First loop, partial parts + ! + IPTOT = 0 + ! + DO IX=1, NX + ! + IXL = 1 + MOD(IX-2+NX,NX) + PREV = .FALSE. + ! + DO IY=1, NY + IF (MSPLIT(IY,IX) .EQ. IG ) THEN + IPTOT = IPTOT + 1 + IIX(IPTOT) = IX + IIY(IPTOT) = IY + IF ( .NOT. PREV) THEN ID = ID + 1 - DO J=1, IDL - IF ( NEXTTO(J,I) ) EXIT - END DO - IF ( J .GT. IDL ) THEN - PMAP(I) = ID - ELSE - DO K=I, IDL - IF ( PMAP(K).EQ.0 .AND. NEXTTO(J,K) ) PMAP(K) = ID - END DO - END IF + PREV = .TRUE. END IF - END DO -! - DEALLOCATE ( NEXTTO ) -! -! 3. Grid is contiguous --------------------------------------------- * -! - IF ( ID .EQ. 1 ) THEN -#ifdef W3_T4 - WRITE (NDST,9030) IG -#endif - DEALLOCATE ( PMAP ) - CYCLE - END IF -! -! 4. Grid is split, get stats --------------------------------------- * -! -#ifdef W3_T4 - WRITE (NDST,9040) IG -#endif -! -! 4.a Construct final map for grid -! - DO IPT=1, IPTOT - IX = IIX(IPT) - IY = IIY(IPT) - GMASK(IY,IX) = PMAP(GMASK(IY,IX)) - END DO -! - DEALLOCATE ( PMAP ) -! -! 4.b Run stats -! - ALLOCATE ( INGRD(ID), FLNEXT(ID) ) - INGRD = 0 - FLNEXT = .FALSE. - IPTOT = 0 -! - DO JX=1, NX - DO JY=1, NY - IF ( GMASK(JY,JX) .GT. 0 ) THEN - INGRD(GMASK(JY,JX)) = INGRD(GMASK(JY,JX)) + 1 - IPTOT = IPTOT + 1 - END IF - END DO - END DO -! - DO JX=1, NX - DO JY=1, NY-1 - IF ( ( GMASK(JY ,JX) .GT. 0 ) .AND. & - ( SEA(JY+1,JX) .AND. MSPLIT(JY+1,JX).NE.IG ) ) & - FLNEXT(GMASK(JY ,JX)) = .TRUE. - IF ( ( GMASK(JY+1,JX) .GT. 0 ) .AND. & - ( SEA(JY ,JX) .AND. MSPLIT(JY ,JX).NE.IG ) ) & - FLNEXT(GMASK(JY+1,JX)) = .TRUE. - END DO - END DO -! - DO JY=1, NY - DO JX=1, NX-1 - IF ( ( GMASK(JY,JX ) .GT. 0 ) .AND. & - ( SEA(JY,JX+1) .AND. MSPLIT(JY,JX+1).NE.IG ) ) & - FLNEXT(GMASK(JY,JX )) = .TRUE. - IF ( ( GMASK(JY,JX+1) .GT. 0 ) .AND. & - ( SEA(JY,JX ) .AND. MSPLIT(JY,JX ).NE.IG ) ) & - FLNEXT(GMASK(JY,JX+1)) = .TRUE. + GMASK(IY,IX) = ID + ELSE IF ( PREV ) THEN + PREV = .FALSE. + IDL = 0 + DO JY=IY-1, 1, -1 + IF ( GMASK(JY,IX) .EQ. 0 ) EXIT + IF ( GMASK(JY,IXL).NE.0 .AND. IDL.EQ.0 ) & + IDL = GMASK(JY,IXL) END DO - IF ( GLOBAL ) THEN - IF ( ( GMASK(JY,NX) .GT. 0 ) .AND. & - ( SEA(JY, 1) .AND. MSPLIT(JY, 1).NE.IG ) ) & - FLNEXT(GMASK(JY,NX)) = .TRUE. - IF ( ( GMASK(JY, 1) .GT. 0 ) .AND. & - ( SEA(JY,NX) .AND. MSPLIT(JY,NX).NE.IG ) ) & - FLNEXT(GMASK(JY, 1)) = .TRUE. + IF ( IDL .NE. 0 ) THEN + DO KY=JY+1, IY-1 + IF ( GMASK(KY,IX).EQ.ID ) GMASK(KY,IX) = IDL + END DO + ID = ID - 1 END IF - END DO -! + ! + END IF + END DO + END DO + ! + ! 2.b Grid too small, do not cut + ! + IF ( IPTOT .LE. IPAVG ) THEN #ifdef W3_T4 + WRITE (NDST,9020) IPTOT, IPAVG +#endif + CYCLE + END IF + ! + ! 2.c Neighbouring grid parts + ! Raw data + ! + ALLOCATE ( NEXTTO(0:ID,0:ID), PMAP(0:ID) ) + NEXTTO = .FALSE. + ! + DO IPT=1, IPTOT + IX = IIX(IPT) + IY = IIY(IPT) + IXL = 1 + MOD(IX-2+NX,NX) + IYL = IY - 1 + IXH = 1 + MOD(IX,NX) + IYH = IY + 1 + NEXTTO( GMASK(IY,IX) , GMASK(IY ,IXL) ) = .TRUE. + NEXTTO( GMASK(IY,IX) , GMASK(IY ,IXH) ) = .TRUE. + NEXTTO( GMASK(IY,IX) , GMASK(IYL,IX ) ) = .TRUE. + NEXTTO( GMASK(IY,IX) , GMASK(IYH,IX ) ) = .TRUE. + END DO + ! + ! Make symmetric + ! + DO I=1, ID DO J=1, ID - WRITE (NDST,9041) J, INGRD(J), FLNEXT(J) - END DO -#endif -! -! 5. Grid large enough, find smallest part -------------------------- * -! - IMIN = NSEA - LMIN = 0 -! + NEXTTO(I,J) = NEXTTO(I,J) .OR. NEXTTO(J,I) + END DO + END DO + ! + ! Connect accross neighbours + ! + DO I=1, ID DO J=1, ID - IF ( FLNEXT(J) .AND. INGRD(J).LT.IMIN ) THEN - IMIN = INGRD(J) - LMIN = J - END IF + IF ( NEXTTO(I,J) ) THEN + DO K=1, ID + IF ( NEXTTO(K,J) ) THEN + NEXTTO(K,I) = .TRUE. + NEXTTO(I,K) = .TRUE. + END IF + END DO + END IF + END DO + END DO + ! + ! Map the parts + ! + IDL = ID + PMAP = 0 + ID = 0 + ! + DO I=1, IDL + IF ( PMAP(I) .EQ. 0 ) THEN + ID = ID + 1 + DO J=1, IDL + IF ( NEXTTO(J,I) ) EXIT END DO -! - IF ( LMIN .EQ. 0 ) THEN + IF ( J .GT. IDL ) THEN + PMAP(I) = ID + ELSE + DO K=I, IDL + IF ( PMAP(K).EQ.0 .AND. NEXTTO(J,K) ) PMAP(K) = ID + END DO + END IF + END IF + END DO + ! + DEALLOCATE ( NEXTTO ) + ! + ! 3. Grid is contiguous --------------------------------------------- * + ! + IF ( ID .EQ. 1 ) THEN #ifdef W3_T4 - WRITE (NDST,9050) + WRITE (NDST,9030) IG #endif - DEALLOCATE ( INGRD, FLNEXT ) - CYCLE + DEALLOCATE ( PMAP ) + CYCLE + END IF + ! + ! 4. Grid is split, get stats --------------------------------------- * + ! +#ifdef W3_T4 + WRITE (NDST,9040) IG +#endif + ! + ! 4.a Construct final map for grid + ! + DO IPT=1, IPTOT + IX = IIX(IPT) + IY = IIY(IPT) + GMASK(IY,IX) = PMAP(GMASK(IY,IX)) + END DO + ! + DEALLOCATE ( PMAP ) + ! + ! 4.b Run stats + ! + ALLOCATE ( INGRD(ID), FLNEXT(ID) ) + INGRD = 0 + FLNEXT = .FALSE. + IPTOT = 0 + ! + DO JX=1, NX + DO JY=1, NY + IF ( GMASK(JY,JX) .GT. 0 ) THEN + INGRD(GMASK(JY,JX)) = INGRD(GMASK(JY,JX)) + 1 + IPTOT = IPTOT + 1 END IF -! - IF ( IMIN .GT. IPCHCK ) THEN + END DO + END DO + ! + DO JX=1, NX + DO JY=1, NY-1 + IF ( ( GMASK(JY ,JX) .GT. 0 ) .AND. & + ( SEA(JY+1,JX) .AND. MSPLIT(JY+1,JX).NE.IG ) ) & + FLNEXT(GMASK(JY ,JX)) = .TRUE. + IF ( ( GMASK(JY+1,JX) .GT. 0 ) .AND. & + ( SEA(JY ,JX) .AND. MSPLIT(JY ,JX).NE.IG ) ) & + FLNEXT(GMASK(JY+1,JX)) = .TRUE. + END DO + END DO + ! + DO JY=1, NY + DO JX=1, NX-1 + IF ( ( GMASK(JY,JX ) .GT. 0 ) .AND. & + ( SEA(JY,JX+1) .AND. MSPLIT(JY,JX+1).NE.IG ) ) & + FLNEXT(GMASK(JY,JX )) = .TRUE. + IF ( ( GMASK(JY,JX+1) .GT. 0 ) .AND. & + ( SEA(JY,JX ) .AND. MSPLIT(JY,JX ).NE.IG ) ) & + FLNEXT(GMASK(JY,JX+1)) = .TRUE. + END DO + IF ( GLOBAL ) THEN + IF ( ( GMASK(JY,NX) .GT. 0 ) .AND. & + ( SEA(JY, 1) .AND. MSPLIT(JY, 1).NE.IG ) ) & + FLNEXT(GMASK(JY,NX)) = .TRUE. + IF ( ( GMASK(JY, 1) .GT. 0 ) .AND. & + ( SEA(JY,NX) .AND. MSPLIT(JY,NX).NE.IG ) ) & + FLNEXT(GMASK(JY, 1)) = .TRUE. + END IF + END DO + ! +#ifdef W3_T4 + DO J=1, ID + WRITE (NDST,9041) J, INGRD(J), FLNEXT(J) + END DO +#endif + ! + ! 5. Grid large enough, find smallest part -------------------------- * + ! + IMIN = NSEA + LMIN = 0 + ! + DO J=1, ID + IF ( FLNEXT(J) .AND. INGRD(J).LT.IMIN ) THEN + IMIN = INGRD(J) + LMIN = J + END IF + END DO + ! + IF ( LMIN .EQ. 0 ) THEN #ifdef W3_T4 - WRITE (NDST,9051) + WRITE (NDST,9050) #endif - DEALLOCATE ( INGRD, FLNEXT ) - CYCLE - END IF -! -! 6. Part to cut has been identified -------------------------------- * -! + DEALLOCATE ( INGRD, FLNEXT ) + CYCLE + END IF + ! + IF ( IMIN .GT. IPCHCK ) THEN #ifdef W3_T4 - WRITE (NDST,9060) LMIN + WRITE (NDST,9051) #endif -! - DO JX=1, NX - DO JY=1, NY - IF ( GMASK(JY,JX) .EQ. LMIN ) MSPLIT(JY,JX) = -1 - END DO - END DO -! DEALLOCATE ( INGRD, FLNEXT ) - OK = .FALSE. -! -! ... End loops started in 1. -! + CYCLE + END IF + ! + ! 6. Part to cut has been identified -------------------------------- * + ! +#ifdef W3_T4 + WRITE (NDST,9060) LMIN +#endif + ! + DO JX=1, NX + DO JY=1, NY + IF ( GMASK(JY,JX) .EQ. LMIN ) MSPLIT(JY,JX) = -1 END DO -! - RETURN -! -! Formats -! + END DO + ! + DEALLOCATE ( INGRD, FLNEXT ) + OK = .FALSE. + ! + ! ... End loops started in 1. + ! + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T4 - 9000 FORMAT ( 'TEST GRSEPA: IPAVG/CHCK:',2I8) - 9010 FORMAT ( 'TEST GRSEPA: WORKING ON GRID'I4) - 9020 FORMAT ( ' GRID TOO SMALL TO CUT',2I8) - 9030 FORMAT ( 'TEST GRSEPA: GRID',I4,' IS CONTIGUOUS') - 9040 FORMAT ( 'TEST GRSEPA: GRID',I4,' CONTAINS PARTS') - 9041 FORMAT ( ' PART, SIZE, NEIGHBOUR:',I4,I8,L4) - 9050 FORMAT ( ' NO PART NEXT TO OTHER') - 9051 FORMAT ( ' NO PART SMALL ENOUGH') - 9060 FORMAT ( ' CUTTING PART',I4) -#endif -! -!/ End of GRSEPA ----------------------------------------------------- / -!/ - END SUBROUTINE GRSEPA -!/ ------------------------------------------------------------------- / - -!> @brief Subroutine called when lowest grid size is stuck. -!> -!> @details Attempting to joint to neighbor grid, otherwise mark -!> as accepted small grid. note that small grid does not influence -!> parallel scaling like a big grid does ..... -!> -!> @author H. L. Tolman @date 04-Feb-2013 - SUBROUTINE GRFSML -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 04-Feb-2013 | -!/ +-----------------------------------+ -!/ -!/ 13-Sep-2012 : Origination. ( version 4.10 ) -!/ 04-Feb-2013 : Bug fix grid splitting. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Subroutine called when lowest grid size is stuck. Attempting to -! joint to neighbor grid, otherwise mark as accepted small grid. -! note that small grid does not influence parallel scaling like a -! big grid does ..... -! -! 1-Feb-2013: Also used for early small-grid merging. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NSMALL, IGMIN(NG), NNEXT, JG, IGADD, & - IGTEST, FREE(NG), NFREE, NBIG, IGB, & - MX, MY, NX0, NXN, NY0, NYN, JX +9000 FORMAT ( 'TEST GRSEPA: IPAVG/CHCK:',2I8) +9010 FORMAT ( 'TEST GRSEPA: WORKING ON GRID'I4) +9020 FORMAT ( ' GRID TOO SMALL TO CUT',2I8) +9030 FORMAT ( 'TEST GRSEPA: GRID',I4,' IS CONTIGUOUS') +9040 FORMAT ( 'TEST GRSEPA: GRID',I4,' CONTAINS PARTS') +9041 FORMAT ( ' PART, SIZE, NEIGHBOUR:',I4,I8,L4) +9050 FORMAT ( ' NO PART NEXT TO OTHER') +9051 FORMAT ( ' NO PART SMALL ENOUGH') +9060 FORMAT ( ' CUTTING PART',I4) +#endif + ! + !/ End of GRSEPA ----------------------------------------------------- / + !/ + END SUBROUTINE GRSEPA + !/ ------------------------------------------------------------------- / + + !> @brief Subroutine called when lowest grid size is stuck. + !> + !> @details Attempting to joint to neighbor grid, otherwise mark + !> as accepted small grid. note that small grid does not influence + !> parallel scaling like a big grid does ..... + !> + !> @author H. L. Tolman @date 04-Feb-2013 + SUBROUTINE GRFSML + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 04-Feb-2013 | + !/ +-----------------------------------+ + !/ + !/ 13-Sep-2012 : Origination. ( version 4.10 ) + !/ 04-Feb-2013 : Bug fix grid splitting. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Subroutine called when lowest grid size is stuck. Attempting to + ! joint to neighbor grid, otherwise mark as accepted small grid. + ! note that small grid does not influence parallel scaling like a + ! big grid does ..... + ! + ! 1-Feb-2013: Also used for early small-grid merging. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NSMALL, IGMIN(NG), NNEXT, JG, IGADD, & + IGTEST, FREE(NG), NFREE, NBIG, IGB, & + MX, MY, NX0, NXN, NY0, NYN, JX #ifdef W3_T5 - INTEGER :: NXNT + INTEGER :: NXNT #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - CHARACTER(LEN=1) :: NEXTTO(0:NG,0:NG), TEMP(NG) -!/ -!/ ------------------------------------------------------------------- / -!/ + CHARACTER(LEN=1) :: NEXTTO(0:NG,0:NG), TEMP(NG) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GRFSML') -#endif -! -! 1. Find small(s) -------------------------------------------------- * -! - NSMALL = 0 - IGMIN = 0 -! - DO IG=1,NG - IF ( GSTATS(IG)%INSTAT .AND. & - GSTATS(IG)%NPTS .EQ. MSTATS%NMIN ) THEN - NSMALL = NSMALL + 1 - IGMIN(NSMALL) = IG - END IF - END DO -! + CALL STRACE (IENT, 'GRFSML') +#endif + ! + ! 1. Find small(s) -------------------------------------------------- * + ! + NSMALL = 0 + IGMIN = 0 + ! + DO IG=1,NG + IF ( GSTATS(IG)%INSTAT .AND. & + GSTATS(IG)%NPTS .EQ. MSTATS%NMIN ) THEN + NSMALL = NSMALL + 1 + IGMIN(NSMALL) = IG + END IF + END DO + ! #ifdef W3_T5 - WRITE (NDST,9010) NSMALL, IGMIN(:NSMALL) -#endif -! -! 2. Find neighbours ------------------------------------------------ * -! - NEXTTO = '.' -! - DO IX=1, NX-1 - DO IY=1, NY-1 - NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY+1,IX )) = 'X' - NEXTTO(MSPLIT(IY+1,IX ),MSPLIT(IY ,IX )) = 'X' - NEXTTO(MSPLIT(IY ,IX+1),MSPLIT(IY ,IX )) = 'X' - NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY ,IX+1)) = 'X' - END DO - END DO -! - IF ( GLOBAL ) THEN - DO IY=1, NY-1 - NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY+1,NX)) = 'X' - NEXTTO(MSPLIT(IY+1,NX),MSPLIT(IY ,NX)) = 'X' - NEXTTO(MSPLIT(IY , 1),MSPLIT(IY ,NX)) = 'X' - NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY , 1)) = 'X' - END DO - END IF -! - DO IG=0,NG - NEXTTO(IG,IG) = '-' - END DO -! + WRITE (NDST,9010) NSMALL, IGMIN(:NSMALL) +#endif + ! + ! 2. Find neighbours ------------------------------------------------ * + ! + NEXTTO = '.' + ! + DO IX=1, NX-1 + DO IY=1, NY-1 + NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY+1,IX )) = 'X' + NEXTTO(MSPLIT(IY+1,IX ),MSPLIT(IY ,IX )) = 'X' + NEXTTO(MSPLIT(IY ,IX+1),MSPLIT(IY ,IX )) = 'X' + NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY ,IX+1)) = 'X' + END DO + END DO + ! + IF ( GLOBAL ) THEN + DO IY=1, NY-1 + NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY+1,NX)) = 'X' + NEXTTO(MSPLIT(IY+1,NX),MSPLIT(IY ,NX)) = 'X' + NEXTTO(MSPLIT(IY , 1),MSPLIT(IY ,NX)) = 'X' + NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY , 1)) = 'X' + END DO + END IF + ! + DO IG=0,NG + NEXTTO(IG,IG) = '-' + END DO + ! #ifdef W3_T5 - WRITE (NDST,9020) - DO IG=1, NG - TEMP = NEXTTO(IG,1:) - WRITE (NDST,9021) IG, TEMP - END DO -#endif -! -! 3. Loop over small grids ------------------------------------------ * -! - FREE = 0 - NFREE = 0 -! - DO J=1, NSMALL -! + WRITE (NDST,9020) + DO IG=1, NG + TEMP = NEXTTO(IG,1:) + WRITE (NDST,9021) IG, TEMP + END DO +#endif + ! + ! 3. Loop over small grids ------------------------------------------ * + ! + FREE = 0 + NFREE = 0 + ! + DO J=1, NSMALL + ! #ifdef W3_T5 - WRITE (NDST,9030) IGMIN(J) -#endif -! -! 3.a Find neighbours -! - IG = IGMIN(J) - IGADD = 0 - IGTEST = NSEA + 1 - NNEXT = 0 - DO JG=1, NG - IF ( NEXTTO(IG,JG) .EQ. 'X' ) THEN - NNEXT = NNEXT + 1 - IF ( GSTATS(JG)%NPTS .LT. IGTEST ) THEN - IGTEST = GSTATS(JG)%NPTS - IGADD = JG - END IF - END IF - END DO -! + WRITE (NDST,9030) IGMIN(J) +#endif + ! + ! 3.a Find neighbours + ! + IG = IGMIN(J) + IGADD = 0 + IGTEST = NSEA + 1 + NNEXT = 0 + DO JG=1, NG + IF ( NEXTTO(IG,JG) .EQ. 'X' ) THEN + NNEXT = NNEXT + 1 + IF ( GSTATS(JG)%NPTS .LT. IGTEST ) THEN + IGTEST = GSTATS(JG)%NPTS + IGADD = JG + END IF + END IF + END DO + ! #ifdef W3_T5 - WRITE (NDST,9031) NNEXT + WRITE (NDST,9031) NNEXT #endif -! -! 3.b No neighbours found, mark as 'not to be processed further' -! - IF ( NNEXT .EQ. 0 ) THEN - GSTATS(IG)%INSTAT = .FALSE. + ! + ! 3.b No neighbours found, mark as 'not to be processed further' + ! + IF ( NNEXT .EQ. 0 ) THEN + GSTATS(IG)%INSTAT = .FALSE. #ifdef W3_T5 - WRITE (NDST,9032) IG + WRITE (NDST,9032) IG #endif - ELSE -! -! 3.c Check smallest neighbor -! + ELSE + ! + ! 3.c Check smallest neighbor + ! #ifdef W3_T5 - WRITE (NDST,9033) IGADD, IGTEST, IGTEST+INGMIN, NINT(XMEAN) -#endif -! - IF ( IGTEST + INGMIN .LT. NINT(XMEAN) ) THEN -! -! ... Merge grids -! - DO IX=1, NX - DO IY=1, NY - IF ( MSPLIT(IY,IX) .EQ. IG ) MSPLIT(IY,IX) = IGADD - END DO - END DO -! - NFREE = NFREE + 1 - FREE(NFREE) = IG -! - ELSE -! -! ... Remove grid(s) from stats -! + WRITE (NDST,9033) IGADD, IGTEST, IGTEST+INGMIN, NINT(XMEAN) +#endif + ! + IF ( IGTEST + INGMIN .LT. NINT(XMEAN) ) THEN + ! + ! ... Merge grids + ! + DO IX=1, NX + DO IY=1, NY + IF ( MSPLIT(IY,IX) .EQ. IG ) MSPLIT(IY,IX) = IGADD + END DO + END DO + ! + NFREE = NFREE + 1 + FREE(NFREE) = IG + ! + ELSE + ! + ! ... Remove grid(s) from stats + ! #ifdef W3_T5 - WRITE (NDST,9034) + WRITE (NDST,9034) #endif -! - GSTATS(IG)%INSTAT = .FALSE. + ! + GSTATS(IG)%INSTAT = .FALSE. #ifdef W3_T5 - WRITE (NDST,9032) IG -#endif - NNEXT = 0 - DO JG=1, NG - IF ( NEXTTO(IGADD,JG) .EQ. 'X' ) NNEXT = NNEXT + 1 - END DO - IF ( NNEXT .EQ. 1 ) THEN - GSTATS(IGADD)%INSTAT = .FALSE. + WRITE (NDST,9032) IG +#endif + NNEXT = 0 + DO JG=1, NG + IF ( NEXTTO(IGADD,JG) .EQ. 'X' ) NNEXT = NNEXT + 1 + END DO + IF ( NNEXT .EQ. 1 ) THEN + GSTATS(IGADD)%INSTAT = .FALSE. #ifdef W3_T5 - WRITE (NDST,9032) IGADD + WRITE (NDST,9032) IGADD #endif - END IF -! - END IF -! END IF -! - END DO -! -! 4. Make new grids as needed --------------------------------------- * -! + ! + END IF + ! + END IF + ! + END DO + ! + ! 4. Make new grids as needed --------------------------------------- * + ! #ifdef W3_T5 - WRITE (NDST,9040) NFREE + WRITE (NDST,9040) NFREE #endif -! - DO J=1, NFREE -! + ! + DO J=1, NFREE + ! #ifdef W3_T5 - WRITE (NDST,9041) FREE(J) -#endif -! -! 4.a Find biggest grid -! - NBIG = 0 - IGB = 0 -! - DO IG=1, NG - IF ( GSTATS(IG)%NPTS .GT. NBIG ) THEN - NBIG = GSTATS(IG)%NPTS - IGB = IG - END IF - END DO -! -! 4.a Split biggest grid -! - NX0 = GSTATS(IGB)%NXL - NXN = GSTATS(IGB)%NXH - NY0 = GSTATS(IGB)%NYL - NYN = GSTATS(IGB)%NYH -! - MY = 1 + GSTATS(IGB)%NYH - GSTATS(IGB)%NYL - MX = 1 + GSTATS(IGB)%NXH - GSTATS(IGB)%NXL - IF ( GSTATS(IGB)%STRADLE ) MX = MX + NX -! - IF ( MY .GE. MX ) THEN + WRITE (NDST,9041) FREE(J) +#endif + ! + ! 4.a Find biggest grid + ! + NBIG = 0 + IGB = 0 + ! + DO IG=1, NG + IF ( GSTATS(IG)%NPTS .GT. NBIG ) THEN + NBIG = GSTATS(IG)%NPTS + IGB = IG + END IF + END DO + ! + ! 4.a Split biggest grid + ! + NX0 = GSTATS(IGB)%NXL + NXN = GSTATS(IGB)%NXH + NY0 = GSTATS(IGB)%NYL + NYN = GSTATS(IGB)%NYH + ! + MY = 1 + GSTATS(IGB)%NYH - GSTATS(IGB)%NYL + MX = 1 + GSTATS(IGB)%NXH - GSTATS(IGB)%NXL + IF ( GSTATS(IGB)%STRADLE ) MX = MX + NX + ! + IF ( MY .GE. MX ) THEN #ifdef W3_T5 - WRITE (NDST,9042) IGB, 'VERTICAL', MX, MY + WRITE (NDST,9042) IGB, 'VERTICAL', MX, MY #endif - NYN = NY0 + MY/2 - ELSE + NYN = NY0 + MY/2 + ELSE #ifdef W3_T5 - WRITE (NDST,9042) IGB, 'HORIZONTAL', MX, MY + WRITE (NDST,9042) IGB, 'HORIZONTAL', MX, MY #endif - NXN = NX0 + MX/2 + NXN = NX0 + MX/2 #ifdef W3_T5 - NXNT = 1 + MOD(NXN-1,NX) + NXNT = 1 + MOD(NXN-1,NX) #endif - END IF + END IF #ifdef W3_T5 - WRITE (NDST,9043) GSTATS(IGB)%NXL, GSTATS(IGB)%NXH, & - GSTATS(IGB)%NYL, GSTATS(IGB)%NYH, & - GSTATS(IGB)%STRADLE, NX0, NXN, NY0, NYN -#endif -! - DO IX=NX0, NXN - JX = 1 + MOD(IX-1,NX) - DO IY=NY0, NYN - IF ( MSPLIT(IY,JX) .EQ. IGB ) MSPLIT(IY,JX) = FREE(J) - END DO - END DO -! - GSTATS(IGB)%NPTS = 0 - GSTATS(FREE(J))%NPTS = 0 -! + WRITE (NDST,9043) GSTATS(IGB)%NXL, GSTATS(IGB)%NXH, & + GSTATS(IGB)%NYL, GSTATS(IGB)%NYH, & + GSTATS(IGB)%STRADLE, NX0, NXN, NY0, NYN +#endif + ! + DO IX=NX0, NXN + JX = 1 + MOD(IX-1,NX) + DO IY=NY0, NYN + IF ( MSPLIT(IY,JX) .EQ. IGB ) MSPLIT(IY,JX) = FREE(J) END DO -! - RETURN -! -! Formats -! + END DO + ! + GSTATS(IGB)%NPTS = 0 + GSTATS(FREE(J))%NPTS = 0 + ! + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T5 - 9010 FORMAT ( 'TEST GRFSML:',I2,' SMALL GRIDS:',10I4) - 9020 FORMAT ( 'TEST GRFSML: NEIGHBOUR MAP PER GRID') - 9021 FORMAT (2X,I3,2X,120A1) - 9030 FORMAT ( 'TEST GRFSML: PROCESSING SMALL GRID',I4) - 9031 FORMAT ( ' GRID HAS',I3,' NEIGHBOURS') - 9032 FORMAT ( ' REMOVED GRID',I4,' FROM STATS') - 9033 FORMAT ( ' SMALLEST NEIGHBOUR AND SIZE',I4,I6/ & - ' SIZE OF COMBINED GRIDS',I8,' (',I8,')') - 9034 FORMAT ( ' GRIDS TOO LARGE TO MERGE') - 9040 FORMAT ( 'TEST GRFSML: GENERATING',I3,' NEW GRIDS') - 9041 FORMAT ( ' MAKING GRID NR.:',I4) - 9042 FORMAT ( ' SPLITTING GRID',I3,' ',A,', MX,MY:',2I6) - 9043 FORMAT ( ' OLD RANGE :',4I6,L4/ & - ' NEW RANGE :',4I6) -#endif -! -!/ End of GRFSML ----------------------------------------------------- / -!/ - END SUBROUTINE GRFSML +9010 FORMAT ( 'TEST GRFSML:',I2,' SMALL GRIDS:',10I4) +9020 FORMAT ( 'TEST GRFSML: NEIGHBOUR MAP PER GRID') +9021 FORMAT (2X,I3,2X,120A1) +9030 FORMAT ( 'TEST GRFSML: PROCESSING SMALL GRID',I4) +9031 FORMAT ( ' GRID HAS',I3,' NEIGHBOURS') +9032 FORMAT ( ' REMOVED GRID',I4,' FROM STATS') +9033 FORMAT ( ' SMALLEST NEIGHBOUR AND SIZE',I4,I6/ & + ' SIZE OF COMBINED GRIDS',I8,' (',I8,')') +9034 FORMAT ( ' GRIDS TOO LARGE TO MERGE') +9040 FORMAT ( 'TEST GRFSML: GENERATING',I3,' NEW GRIDS') +9041 FORMAT ( ' MAKING GRID NR.:',I4) +9042 FORMAT ( ' SPLITTING GRID',I3,' ',A,', MX,MY:',2I6) +9043 FORMAT ( ' OLD RANGE :',4I6,L4/ & + ' NEW RANGE :',4I6) +#endif + ! + !/ End of GRFSML ----------------------------------------------------- / + !/ + END SUBROUTINE GRFSML -!> @brief Like GRFSML for largest grid ... -!> -!> @author H. L. Tolman @date 29-Jan-2013 -!/ ------------------------------------------------------------------- / - SUBROUTINE GRFLRG -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-Jan-2013 | -!/ +-----------------------------------+ -!/ -!/ 19-Sep-2012 : Origination. ( version 4.10 ) -!/ 29-Jan-2013 : Add error code on stop. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Like GRFSML for largest grid ... -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NBIG, IGMAX(NG), NNEXT, JG + !> @brief Like GRFSML for largest grid ... + !> + !> @author H. L. Tolman @date 29-Jan-2013 + !/ ------------------------------------------------------------------- / + SUBROUTINE GRFLRG + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-Jan-2013 | + !/ +-----------------------------------+ + !/ + !/ 19-Sep-2012 : Origination. ( version 4.10 ) + !/ 29-Jan-2013 : Add error code on stop. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Like GRFSML for largest grid ... + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NBIG, IGMAX(NG), NNEXT, JG !!! INTEGER :: NSMALL, IGMIN(NG), NNEXT, JG, IGADD, & !!! IGTEST, FREE(NG), NFREE, NBIG, IGB, & !!! MX, MY, NX0, NXN, NY0, NYN #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - CHARACTER(LEN=1) :: NEXTTO(0:NG,0:NG), TEMP(NG) -!/ -!/ ------------------------------------------------------------------- / -!/ + CHARACTER(LEN=1) :: NEXTTO(0:NG,0:NG), TEMP(NG) + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GRFLRG') -#endif -! -! 1. Find big(s) ---------------------------------------------------- * -! - NBIG = 0 - IGMAX = 0 -! - DO IG=1,NG - IF ( GSTATS(IG)%INSTAT .AND. & - GSTATS(IG)%NPTS .EQ. MSTATS%NMAX ) THEN - NBIG = NBIG + 1 - IGMAX(NBIG) = IG - END IF - END DO -! + CALL STRACE (IENT, 'GRFLRG') +#endif + ! + ! 1. Find big(s) ---------------------------------------------------- * + ! + NBIG = 0 + IGMAX = 0 + ! + DO IG=1,NG + IF ( GSTATS(IG)%INSTAT .AND. & + GSTATS(IG)%NPTS .EQ. MSTATS%NMAX ) THEN + NBIG = NBIG + 1 + IGMAX(NBIG) = IG + END IF + END DO + ! #ifdef W3_T6 - WRITE (NDST,9010) NBIG, IGMAX(:NBIG) -#endif -! -! 2. Find neighbours ------------------------------------------------ * -! - NEXTTO = '.' -! - DO IX=1, NX-1 - DO IY=1, NY-1 - NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY+1,IX )) = 'X' - NEXTTO(MSPLIT(IY+1,IX ),MSPLIT(IY ,IX )) = 'X' - NEXTTO(MSPLIT(IY ,IX+1),MSPLIT(IY ,IX )) = 'X' - NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY ,IX+1)) = 'X' - END DO - END DO -! - IF ( GLOBAL ) THEN - DO IY=1, NY-1 - NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY+1,NX)) = 'X' - NEXTTO(MSPLIT(IY+1,NX),MSPLIT(IY ,NX)) = 'X' - NEXTTO(MSPLIT(IY , 1),MSPLIT(IY ,NX)) = 'X' - NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY , 1)) = 'X' - END DO - END IF -! - DO IG=0,NG - NEXTTO(IG,IG) = '-' - END DO -! + WRITE (NDST,9010) NBIG, IGMAX(:NBIG) +#endif + ! + ! 2. Find neighbours ------------------------------------------------ * + ! + NEXTTO = '.' + ! + DO IX=1, NX-1 + DO IY=1, NY-1 + NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY+1,IX )) = 'X' + NEXTTO(MSPLIT(IY+1,IX ),MSPLIT(IY ,IX )) = 'X' + NEXTTO(MSPLIT(IY ,IX+1),MSPLIT(IY ,IX )) = 'X' + NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY ,IX+1)) = 'X' + END DO + END DO + ! + IF ( GLOBAL ) THEN + DO IY=1, NY-1 + NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY+1,NX)) = 'X' + NEXTTO(MSPLIT(IY+1,NX),MSPLIT(IY ,NX)) = 'X' + NEXTTO(MSPLIT(IY , 1),MSPLIT(IY ,NX)) = 'X' + NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY , 1)) = 'X' + END DO + END IF + ! + DO IG=0,NG + NEXTTO(IG,IG) = '-' + END DO + ! #ifdef W3_T6 - WRITE (NDST,9020) - DO IG=1, NG - TEMP = NEXTTO(IG,1:) - WRITE (NDST,9021) IG, TEMP - END DO -#endif -! -! 3. Loop over big grids -------------------------------------------- * -! - DO J=1, NBIG -! + WRITE (NDST,9020) + DO IG=1, NG + TEMP = NEXTTO(IG,1:) + WRITE (NDST,9021) IG, TEMP + END DO +#endif + ! + ! 3. Loop over big grids -------------------------------------------- * + ! + DO J=1, NBIG + ! #ifdef W3_T6 - WRITE (NDST,9030) IGMAX(J) -#endif -! -! 3.a Find neighbours -! - IG = IGMAX(J) - NNEXT = 0 - DO JG=1, NG - IF ( NEXTTO(IG,JG) .EQ. 'X' ) NNEXT = NNEXT + 1 - END DO -! + WRITE (NDST,9030) IGMAX(J) +#endif + ! + ! 3.a Find neighbours + ! + IG = IGMAX(J) + NNEXT = 0 + DO JG=1, NG + IF ( NEXTTO(IG,JG) .EQ. 'X' ) NNEXT = NNEXT + 1 + END DO + ! #ifdef W3_T6 - WRITE (NDST,9031) NNEXT + WRITE (NDST,9031) NNEXT #endif -! -! 3.b Enough neighbours found, mark as 'not to be processed further' -! - IF ( NNEXT .GE. 1 ) THEN - GSTATS(IG)%INSTAT = .FALSE. + ! + ! 3.b Enough neighbours found, mark as 'not to be processed further' + ! + IF ( NNEXT .GE. 1 ) THEN + GSTATS(IG)%INSTAT = .FALSE. #ifdef W3_T6 - WRITE (NDST,9032) -#endif - ELSE -! -! 3.c Biggest grid is isolated, should split -! - WRITE (NDSE,930) - STOP 11 -! - END IF -! - END DO -! - RETURN -! -! Formats -! - 930 FORMAT ( ' *** ERROR GRFLRG: LARGEST GRID IS ISOLATED ***' & - ' SPLITTING NOT YET IMPLEMENTED '/) -! + WRITE (NDST,9032) +#endif + ELSE + ! + ! 3.c Biggest grid is isolated, should split + ! + WRITE (NDSE,930) + STOP 11 + ! + END IF + ! + END DO + ! + RETURN + ! + ! Formats + ! +930 FORMAT ( ' *** ERROR GRFLRG: LARGEST GRID IS ISOLATED ***' & + ' SPLITTING NOT YET IMPLEMENTED '/) + ! #ifdef W3_T6 - 9010 FORMAT ( 'TEST GRFLRG:',I2,' BIG GRIDS:',10I4) - 9020 FORMAT ( 'TEST GRFLRG: NEIGHBOUR MAP PER GRID') - 9021 FORMAT (2X,I3,2X,120A1) - 9030 FORMAT ( 'TEST GRFLRG: PROCESSING BIG GRID',I4) - 9031 FORMAT ( ' GRID HAS',I3,' NEIGHBOURS') - 9032 FORMAT ( ' NO ACTION') -#endif -! -!/ End of GRFLRG ----------------------------------------------------- / -!/ - END SUBROUTINE GRFLRG -!/ ------------------------------------------------------------------- / +9010 FORMAT ( 'TEST GRFLRG:',I2,' BIG GRIDS:',10I4) +9020 FORMAT ( 'TEST GRFLRG: NEIGHBOUR MAP PER GRID') +9021 FORMAT (2X,I3,2X,120A1) +9030 FORMAT ( 'TEST GRFLRG: PROCESSING BIG GRID',I4) +9031 FORMAT ( ' GRID HAS',I3,' NEIGHBOURS') +9032 FORMAT ( ' NO ACTION') +#endif + ! + !/ End of GRFLRG ----------------------------------------------------- / + !/ + END SUBROUTINE GRFLRG + !/ ------------------------------------------------------------------- / -!> @brief Extract single grid from master map. -!> -!> @details Extract single grid from master map, including halo needed -!> for grid overlap in ww3_multi. -!> -!> @author H. L. Tolman @date 18-Nov-2012 - SUBROUTINE GR1GRD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 18-Nov-2012 | -!/ +-----------------------------------+ -!/ -!/ 23-Sep-2012 : Origination. ( version 4.10 ) -!/ 24-Jan-2013 : Correct X0 to be in range. ( version 4.10 ) -!/ 04-Feb-2013 : Add corner point to halo. ( version 4.10 ) -!/ 18-Nov-2012 : Add user-defined halo extension. ( version 4.14 ) -!/ -! 1. Purpose : -! -! Extract single grid from master map, including halo needed for -! grid overlap in ww3_multi. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NIT, IIT, IXL, IXH, IYL, IYH, NOCNT,& - NOCNTM, NOCNTL, JX, JY, ISEA, MX, MY - INTEGER :: MTMP2(NY,NX) + !> @brief Extract single grid from master map. + !> + !> @details Extract single grid from master map, including halo needed + !> for grid overlap in ww3_multi. + !> + !> @author H. L. Tolman @date 18-Nov-2012 + SUBROUTINE GR1GRD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 18-Nov-2012 | + !/ +-----------------------------------+ + !/ + !/ 23-Sep-2012 : Origination. ( version 4.10 ) + !/ 24-Jan-2013 : Correct X0 to be in range. ( version 4.10 ) + !/ 04-Feb-2013 : Add corner point to halo. ( version 4.10 ) + !/ 18-Nov-2012 : Add user-defined halo extension. ( version 4.14 ) + !/ + ! 1. Purpose : + ! + ! Extract single grid from master map, including halo needed for + ! grid overlap in ww3_multi. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NIT, IIT, IXL, IXH, IYL, IYH, NOCNT,& + NOCNTM, NOCNTL, JX, JY, ISEA, MX, MY + INTEGER :: MTMP2(NY,NX) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: XOFF - LOGICAL :: MASK(NY,NX), LEFT, RIGHT, THERE -!/ -!/ ------------------------------------------------------------------- / -!/ + REAL :: XOFF + LOGICAL :: MASK(NY,NX), LEFT, RIGHT, THERE + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'GR1GRD') + CALL STRACE (IENT, 'GR1GRD') #endif -! + ! #ifdef W3_T7 - WRITE (NDST,9000) IG + WRITE (NDST,9000) IG #endif -! -! 1. Set up MTEMP with MAPSTA 0,1,3 for grid ------------------------ * -! - DO IX=1, NX - DO IY=1, NY - IF ( MSPLIT(IY,IX) .EQ. IG ) THEN - MTEMP(IY,IX) = 1 - ELSE IF ( MSPLIT(IY,IX) .GT. 0 ) THEN - MTEMP(IY,IX) = 3 - ELSE - MTEMP(IY,IX) = 0 - END IF - END DO - END DO -! -! 2. Add ALL MAPSTA = 2 points to grid ------------------------------ * -! - DO IX=1, NX - DO IY=1, NY - IF ( MAPSTA(IY,IX) .EQ. 2 ) THEN - MTEMP(IY,IX) = 2 - END IF - END DO - END DO -! -! 3. Add halo ------------------------------------------------------- * -! 3.a Set up halo width depending on scheme and time steps -! NEEDED TO SET UP A LITTLE WIDER. NOT SURE WHY. NEED TO CHECK WITH -! WMEQL SUBROUTINE. -! + ! + ! 1. Set up MTEMP with MAPSTA 0,1,3 for grid ------------------------ * + ! + DO IX=1, NX + DO IY=1, NY + IF ( MSPLIT(IY,IX) .EQ. IG ) THEN + MTEMP(IY,IX) = 1 + ELSE IF ( MSPLIT(IY,IX) .GT. 0 ) THEN + MTEMP(IY,IX) = 3 + ELSE + MTEMP(IY,IX) = 0 + END IF + END DO + END DO + ! + ! 2. Add ALL MAPSTA = 2 points to grid ------------------------------ * + ! + DO IX=1, NX + DO IY=1, NY + IF ( MAPSTA(IY,IX) .EQ. 2 ) THEN + MTEMP(IY,IX) = 2 + END IF + END DO + END DO + ! + ! 3. Add halo ------------------------------------------------------- * + ! 3.a Set up halo width depending on scheme and time steps + ! NEEDED TO SET UP A LITTLE WIDER. NOT SURE WHY. NEED TO CHECK WITH + ! WMEQL SUBROUTINE. + ! #ifdef W3_PR0 - NIT = 0 + NIT = 0 #endif #ifdef W3_PR1 - NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 + NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 #endif #ifdef W3_UQ - NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 + NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 #endif #ifdef W3_UNO - NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 -#endif -! -! 3.b Exand halo -! - DO IIT=1, NIT -! - MASK = .FALSE. -! - DO IX=1, NX - IXL = 1 + MOD(IX-2+NX,NX) - IXH = 1 + MOD(IX,NX) - DO IY=2, NY-1 - IF ( MTEMP(IY,IX) .EQ. 3 ) MASK(IY,IX) = & - ( ( MTEMP(IY+1,IX ) .EQ. 1 ) .OR. & - ( MTEMP(IY-1,IX ) .EQ. 1 ) .OR. & - ( MTEMP(IY ,IXH) .EQ. 1 ) .OR. & - ( MTEMP(IY ,IXL) .EQ. 1 ) ) & - .OR. ( ( MTEMP(IY+1,IXL) .EQ. 1 ) .AND. & - ( ( MTEMP(IY ,IXL) .EQ. 1 ) .OR. & - ( MTEMP(IY+1,IX ) .EQ. 1 ) ) ) & - .OR. ( ( MTEMP(IY+1,IXH) .EQ. 1 ) .AND. & - ( ( MTEMP(IY ,IXH) .EQ. 1 ) .OR. & - ( MTEMP(IY+1,IX ) .EQ. 1 ) ) ) & - .OR. ( ( MTEMP(IY-1,IXH) .EQ. 1 ) .AND. & - ( ( MTEMP(IY ,IXH) .EQ. 1 ) .OR. & - ( MTEMP(IY-1,IX ) .EQ. 1 ) ) ) & - .OR. ( ( MTEMP(IY-1,IXL) .EQ. 1 ) .AND. & - ( ( MTEMP(IY ,IXL) .EQ. 1 ) .OR. & - ( MTEMP(IY-1,IX ) .EQ. 1 ) ) ) - END DO - END DO -! - DO IX=1, NX - DO IY=1, NY - IF ( MASK(IY,IX) ) MTEMP(IY,IX) = 1 - END DO - END DO -! + NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 +#endif + ! + ! 3.b Exand halo + ! + DO IIT=1, NIT + ! + MASK = .FALSE. + ! + DO IX=1, NX + IXL = 1 + MOD(IX-2+NX,NX) + IXH = 1 + MOD(IX,NX) + DO IY=2, NY-1 + IF ( MTEMP(IY,IX) .EQ. 3 ) MASK(IY,IX) = & + ( ( MTEMP(IY+1,IX ) .EQ. 1 ) .OR. & + ( MTEMP(IY-1,IX ) .EQ. 1 ) .OR. & + ( MTEMP(IY ,IXH) .EQ. 1 ) .OR. & + ( MTEMP(IY ,IXL) .EQ. 1 ) ) & + .OR. ( ( MTEMP(IY+1,IXL) .EQ. 1 ) .AND. & + ( ( MTEMP(IY ,IXL) .EQ. 1 ) .OR. & + ( MTEMP(IY+1,IX ) .EQ. 1 ) ) ) & + .OR. ( ( MTEMP(IY+1,IXH) .EQ. 1 ) .AND. & + ( ( MTEMP(IY ,IXH) .EQ. 1 ) .OR. & + ( MTEMP(IY+1,IX ) .EQ. 1 ) ) ) & + .OR. ( ( MTEMP(IY-1,IXH) .EQ. 1 ) .AND. & + ( ( MTEMP(IY ,IXH) .EQ. 1 ) .OR. & + ( MTEMP(IY-1,IX ) .EQ. 1 ) ) ) & + .OR. ( ( MTEMP(IY-1,IXL) .EQ. 1 ) .AND. & + ( ( MTEMP(IY ,IXL) .EQ. 1 ) .OR. & + ( MTEMP(IY-1,IX ) .EQ. 1 ) ) ) END DO -! -! 3.c Contract halo -! -! MTMP2 = MTEMP -! -! DO IIT=1, NIT -! -! MASK = .FALSE. -! -! DO IX=1, NX -! IXL = 1 + MOD(IX-2+NX,NX) -! IXH = 1 + MOD(IX,NX) -! DO IY=2, NY-1 -! IF ( MTMP2(IY,IX) .EQ. 1 ) MASK(IY,IX) = & -! ( ( MTMP2(IY+1,IX ) .EQ. 3 ) .OR. & -! ( MTMP2(IY-1,IX ) .EQ. 3 ) .OR. & -! ( MTMP2(IY ,IXH) .EQ. 3 ) .OR. & -! ( MTMP2(IY ,IXL) .EQ. 3 ) ) & -! .OR. ( ( MTMP2(IY+1,IXL) .EQ. 3 ) .AND. & -! ( ( MTMP2(IY ,IXL) .EQ. 3 ) .OR. & -! ( MTMP2(IY+1,IX ) .EQ. 3 ) ) ) & -! .OR. ( ( MTMP2(IY+1,IXH) .EQ. 3 ) .AND. & -! ( ( MTMP2(IY ,IXH) .EQ. 3 ) .OR. & -! ( MTMP2(IY+1,IX ) .EQ. 3 ) ) ) & -! .OR. ( ( MTMP2(IY-1,IXH) .EQ. 3 ) .AND. & -! ( ( MTMP2(IY ,IXH) .EQ. 3 ) .OR. & -! ( MTMP2(IY-1,IX ) .EQ. 3 ) ) ) & -! .OR. ( ( MTMP2(IY-1,IXL) .EQ. 3 ) .AND. & -! ( ( MTMP2(IY ,IXL) .EQ. 3 ) .OR. & -! ( MTMP2(IY-1,IX ) .EQ. 3 ) ) ) -! END DO -! END DO -! -! DO IX=1, NX -! DO IY=1, NY -! IF ( MASK(IY,IX) ) MTMP2(IY,IX) = 3 -! END DO -! END DO -! -! END DO -! -! 3.d Check if consistent ..... -! -! DO IX=1, NX -! DO IY=1, NY -! IF ( MSPLIT(IY,IX).EQ.IG .OR. MTMP2(IY,IX).EQ.1 ) THEN -! IF ( MSPLIT(IY,IX).EQ.IG .AND. MTMP2(IY,IX).NE.1 ) THEN -! write (ndst,*) ix, iy, ' in grid, not in e-c grid' -! END IF -! IF ( MSPLIT(IY,IX).NE.IG .AND. MTMP2(IY,IX).EQ.1 ) THEN -! write (ndst,*) ix, iy, ' in e-c grid, not in grid' -! END IF -! END IF -! END DO -! END DO -! -! 4. Remove extraeneous MAPSTA = 2 ---------------------------------- * -! + END DO + ! DO IX=1, NX -! - IF ( GLOBAL ) THEN - IXL = 1 + MOD(IX-2+NX,NX) - IXH = 1 + MOD(IX,NX) - ELSE - IXL = MAX ( 1 , IX-1 ) - IXH = MIN ( NX , IX+1 ) - END IF -! DO IY=1, NY - IF ( MTEMP(IY,IX) .EQ. 2 ) THEN - IYL = MAX ( 1 , IY-1 ) - IYH = MIN ( NY , IY+1 ) - IF ( .NOT. ( ( MTEMP(IYL,IX ) .EQ. 1 ) .OR. & - ( MTEMP(IYH,IX ) .EQ. 1 ) .OR. & - ( MTEMP(IY ,IXL) .EQ. 1 ) .OR. & - ( MTEMP(IY ,IXH) .EQ. 1 ) ) ) & - MTEMP(IY,IX) = 3 - END IF - END DO -! + IF ( MASK(IY,IX) ) MTEMP(IY,IX) = 1 END DO -! -#ifdef W3_T7 - WRITE (NDST,9040) -#endif -! -! 5. Recompute grid range ------------------------------------------- * -! Using GSTOLD to store info for modified grid -! -#ifdef W3_T7 - WRITE (NDST,9050) GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & - GSTATS(IG)%NXL, GSTATS(IG)%NXH, & - GSTATS(IG)%NYL, GSTATS(IG)%NYH -#endif -! - GSTOLD(IG)%STRADLE = .FALSE. - GSTOLD(IG)%NPTS = 0 - GSTOLD(IG)%NXL = NX - GSTOLD(IG)%NXH = 1 - GSTOLD(IG)%NYL = NY - GSTOLD(IG)%NYH = 1 -! + END DO + ! + END DO + ! + ! 3.c Contract halo + ! + ! MTMP2 = MTEMP + ! + ! DO IIT=1, NIT + ! + ! MASK = .FALSE. + ! + ! DO IX=1, NX + ! IXL = 1 + MOD(IX-2+NX,NX) + ! IXH = 1 + MOD(IX,NX) + ! DO IY=2, NY-1 + ! IF ( MTMP2(IY,IX) .EQ. 1 ) MASK(IY,IX) = & + ! ( ( MTMP2(IY+1,IX ) .EQ. 3 ) .OR. & + ! ( MTMP2(IY-1,IX ) .EQ. 3 ) .OR. & + ! ( MTMP2(IY ,IXH) .EQ. 3 ) .OR. & + ! ( MTMP2(IY ,IXL) .EQ. 3 ) ) & + ! .OR. ( ( MTMP2(IY+1,IXL) .EQ. 3 ) .AND. & + ! ( ( MTMP2(IY ,IXL) .EQ. 3 ) .OR. & + ! ( MTMP2(IY+1,IX ) .EQ. 3 ) ) ) & + ! .OR. ( ( MTMP2(IY+1,IXH) .EQ. 3 ) .AND. & + ! ( ( MTMP2(IY ,IXH) .EQ. 3 ) .OR. & + ! ( MTMP2(IY+1,IX ) .EQ. 3 ) ) ) & + ! .OR. ( ( MTMP2(IY-1,IXH) .EQ. 3 ) .AND. & + ! ( ( MTMP2(IY ,IXH) .EQ. 3 ) .OR. & + ! ( MTMP2(IY-1,IX ) .EQ. 3 ) ) ) & + ! .OR. ( ( MTMP2(IY-1,IXL) .EQ. 3 ) .AND. & + ! ( ( MTMP2(IY ,IXL) .EQ. 3 ) .OR. & + ! ( MTMP2(IY-1,IX ) .EQ. 3 ) ) ) + ! END DO + ! END DO + ! + ! DO IX=1, NX + ! DO IY=1, NY + ! IF ( MASK(IY,IX) ) MTMP2(IY,IX) = 3 + ! END DO + ! END DO + ! + ! END DO + ! + ! 3.d Check if consistent ..... + ! + ! DO IX=1, NX + ! DO IY=1, NY + ! IF ( MSPLIT(IY,IX).EQ.IG .OR. MTMP2(IY,IX).EQ.1 ) THEN + ! IF ( MSPLIT(IY,IX).EQ.IG .AND. MTMP2(IY,IX).NE.1 ) THEN + ! write (ndst,*) ix, iy, ' in grid, not in e-c grid' + ! END IF + ! IF ( MSPLIT(IY,IX).NE.IG .AND. MTMP2(IY,IX).EQ.1 ) THEN + ! write (ndst,*) ix, iy, ' in e-c grid, not in grid' + ! END IF + ! END IF + ! END DO + ! END DO + ! + ! 4. Remove extraeneous MAPSTA = 2 ---------------------------------- * + ! + DO IX=1, NX + ! IF ( GLOBAL ) THEN -! - LEFT = .FALSE. - RIGHT = .FALSE. -! - DO IY=1, NY - IF ( MTEMP(IY, 1).EQ.1 .OR. MTEMP(IY, 1).EQ.2 ) LEFT = .TRUE. - IF ( MTEMP(IY,NX).EQ.1 .OR. MTEMP(IY,NX).EQ.2 ) RIGHT = .TRUE. - END DO - GSTOLD(IG)%STRADLE = LEFT .AND. RIGHT -! - END IF -! + IXL = 1 + MOD(IX-2+NX,NX) + IXH = 1 + MOD(IX,NX) + ELSE + IXL = MAX ( 1 , IX-1 ) + IXH = MIN ( NX , IX+1 ) + END IF + ! DO IY=1, NY - DO IX=1, NX - IF ( MTEMP(IY,IX).EQ.1 .OR. MTEMP(IY,IX).EQ.2 ) THEN - GSTOLD(IG)%NPTS = GSTOLD(IG)%NPTS + 1 - GSTOLD(IG)%NXL = MIN ( GSTOLD(IG)%NXL , IX ) - GSTOLD(IG)%NXH = MAX ( GSTOLD(IG)%NXH , IX ) - GSTOLD(IG)%NYL = MIN ( GSTOLD(IG)%NYL , IY ) - GSTOLD(IG)%NYH = MAX ( GSTOLD(IG)%NYH , IY ) - END IF - END DO - END DO -! - IF ( GSTOLD(IG)%STRADLE ) THEN - NOCNT = 0 - NOCNTM = 0 - NOCNTL = 0 - DO IX=1, NX - THERE = .FALSE. - DO IY=1, NY - IF ( MTEMP(IY,IX).EQ.1 .OR. MTEMP(IY,IX).EQ.2 ) THEN - THERE = .TRUE. - EXIT - END IF - END DO - IF ( THERE ) THEN - NOCNT = 0 - ELSE - NOCNT = NOCNT + 1 - IF ( NOCNT .GT. NOCNTM ) THEN - NOCNTM = NOCNT - NOCNTL = IX - END IF - END IF - END DO - GSTOLD(IG)%NXL = NOCNTL + 1 - GSTOLD(IG)%NXH = NOCNTL - NOCNTM + IF ( MTEMP(IY,IX) .EQ. 2 ) THEN + IYL = MAX ( 1 , IY-1 ) + IYH = MIN ( NY , IY+1 ) + IF ( .NOT. ( ( MTEMP(IYL,IX ) .EQ. 1 ) .OR. & + ( MTEMP(IYH,IX ) .EQ. 1 ) .OR. & + ( MTEMP(IY ,IXL) .EQ. 1 ) .OR. & + ( MTEMP(IY ,IXH) .EQ. 1 ) ) ) & + MTEMP(IY,IX) = 3 END IF -! -! ... Make sure outside of grid is 2 or 3 -! + END DO + ! + END DO + ! #ifdef W3_T7 - WRITE (NDST,9051) GSTOLD(IG)%STRADLE, GSTOLD(IG)%NPTS, & - GSTOLD(IG)%NXL, GSTOLD(IG)%NXH, & - GSTOLD(IG)%NYL, GSTOLD(IG)%NYH + WRITE (NDST,9040) #endif + ! + ! 5. Recompute grid range ------------------------------------------- * + ! Using GSTOLD to store info for modified grid + ! +#ifdef W3_T7 + WRITE (NDST,9050) GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & + GSTATS(IG)%NXL, GSTATS(IG)%NXH, & + GSTATS(IG)%NYL, GSTATS(IG)%NYH +#endif + ! + GSTOLD(IG)%STRADLE = .FALSE. + GSTOLD(IG)%NPTS = 0 + GSTOLD(IG)%NXL = NX + GSTOLD(IG)%NXH = 1 + GSTOLD(IG)%NYL = NY + GSTOLD(IG)%NYH = 1 + ! + IF ( GLOBAL ) THEN + ! LEFT = .FALSE. RIGHT = .FALSE. -! - DO IX=1, NX - LEFT = LEFT .OR. ( MTEMP(GSTOLD(IG)%NYL,IX) .EQ. 1 ) - RIGHT = RIGHT .OR. ( MTEMP(GSTOLD(IG)%NYH,IX) .EQ. 1 ) - END DO -! - IF ( LEFT ) GSTOLD(IG)%NYL = GSTOLD(IG)%NYL - 1 - IF ( RIGHT ) GSTOLD(IG)%NYH = GSTOLD(IG)%NYH + 1 -! + ! DO IY=1, NY - LEFT = LEFT .OR. ( MTEMP(IY,GSTOLD(IG)%NXL) .EQ. 1 ) - RIGHT = RIGHT .OR. ( MTEMP(IY,GSTOLD(IG)%NXH) .EQ. 1 ) - END DO -! - IF ( LEFT ) GSTOLD(IG)%NXL = GSTOLD(IG)%NXL - 1 - IF ( RIGHT ) GSTOLD(IG)%NXH = GSTOLD(IG)%NXH + 1 -! - IF ( GLOBAL .AND. GSTOLD(IG)%NXL.EQ.0 ) THEN - GSTOLD(IG)%NXL = NX - GSTOLD(IG)%STRADLE = .TRUE. + IF ( MTEMP(IY, 1).EQ.1 .OR. MTEMP(IY, 1).EQ.2 ) LEFT = .TRUE. + IF ( MTEMP(IY,NX).EQ.1 .OR. MTEMP(IY,NX).EQ.2 ) RIGHT = .TRUE. + END DO + GSTOLD(IG)%STRADLE = LEFT .AND. RIGHT + ! + END IF + ! + DO IY=1, NY + DO IX=1, NX + IF ( MTEMP(IY,IX).EQ.1 .OR. MTEMP(IY,IX).EQ.2 ) THEN + GSTOLD(IG)%NPTS = GSTOLD(IG)%NPTS + 1 + GSTOLD(IG)%NXL = MIN ( GSTOLD(IG)%NXL , IX ) + GSTOLD(IG)%NXH = MAX ( GSTOLD(IG)%NXH , IX ) + GSTOLD(IG)%NYL = MIN ( GSTOLD(IG)%NYL , IY ) + GSTOLD(IG)%NYH = MAX ( GSTOLD(IG)%NYH , IY ) END IF -! - IF ( GLOBAL .AND. GSTOLD(IG)%NXH.EQ.NX+1 ) THEN - GSTOLD(IG)%NXH = 1 - GSTOLD(IG)%STRADLE = .TRUE. + END DO + END DO + ! + IF ( GSTOLD(IG)%STRADLE ) THEN + NOCNT = 0 + NOCNTM = 0 + NOCNTL = 0 + DO IX=1, NX + THERE = .FALSE. + DO IY=1, NY + IF ( MTEMP(IY,IX).EQ.1 .OR. MTEMP(IY,IX).EQ.2 ) THEN + THERE = .TRUE. + EXIT + END IF + END DO + IF ( THERE ) THEN + NOCNT = 0 + ELSE + NOCNT = NOCNT + 1 + IF ( NOCNT .GT. NOCNTM ) THEN + NOCNTM = NOCNT + NOCNTL = IX + END IF END IF -! + END DO + GSTOLD(IG)%NXL = NOCNTL + 1 + GSTOLD(IG)%NXH = NOCNTL - NOCNTM + END IF + ! + ! ... Make sure outside of grid is 2 or 3 + ! +#ifdef W3_T7 + WRITE (NDST,9051) GSTOLD(IG)%STRADLE, GSTOLD(IG)%NPTS, & + GSTOLD(IG)%NXL, GSTOLD(IG)%NXH, & + GSTOLD(IG)%NYL, GSTOLD(IG)%NYH +#endif + LEFT = .FALSE. + RIGHT = .FALSE. + ! + DO IX=1, NX + LEFT = LEFT .OR. ( MTEMP(GSTOLD(IG)%NYL,IX) .EQ. 1 ) + RIGHT = RIGHT .OR. ( MTEMP(GSTOLD(IG)%NYH,IX) .EQ. 1 ) + END DO + ! + IF ( LEFT ) GSTOLD(IG)%NYL = GSTOLD(IG)%NYL - 1 + IF ( RIGHT ) GSTOLD(IG)%NYH = GSTOLD(IG)%NYH + 1 + ! + DO IY=1, NY + LEFT = LEFT .OR. ( MTEMP(IY,GSTOLD(IG)%NXL) .EQ. 1 ) + RIGHT = RIGHT .OR. ( MTEMP(IY,GSTOLD(IG)%NXH) .EQ. 1 ) + END DO + ! + IF ( LEFT ) GSTOLD(IG)%NXL = GSTOLD(IG)%NXL - 1 + IF ( RIGHT ) GSTOLD(IG)%NXH = GSTOLD(IG)%NXH + 1 + ! + IF ( GLOBAL .AND. GSTOLD(IG)%NXL.EQ.0 ) THEN + GSTOLD(IG)%NXL = NX + GSTOLD(IG)%STRADLE = .TRUE. + END IF + ! + IF ( GLOBAL .AND. GSTOLD(IG)%NXH.EQ.NX+1 ) THEN + GSTOLD(IG)%NXH = 1 + GSTOLD(IG)%STRADLE = .TRUE. + END IF + ! #ifdef W3_T7 - WRITE (NDST,9052) GSTOLD(IG)%STRADLE, GSTOLD(IG)%NPTS, & - GSTOLD(IG)%NXL, GSTOLD(IG)%NXH, & - GSTOLD(IG)%NYL, GSTOLD(IG)%NYH -#endif -! -! 6. Extract reduced grid data -------------------------------------- * -! - MY = 1 + GSTOLD(IG)%NYH - GSTOLD(IG)%NYL - MX = 1 + GSTOLD(IG)%NXH - GSTOLD(IG)%NXL - IF ( GSTOLD(IG)%STRADLE ) MX = MX + NX - PGRID(IG)%NY = MY - PGRID(IG)%NX = MX - PGRID(IG)%NSEA = GSTOLD(IG)%NPTS - PGRID(IG)%X0 = X0 + REAL(GSTOLD(IG)%NXL-1)*SX - PGRID(IG)%Y0 = Y0 + REAL(GSTOLD(IG)%NYL-1)*SY - PGRID(IG)%SX = SX - PGRID(IG)%SY = SY -! - XOFF = 360. * REAL ( NINT((PGRID(IG)%X0+0.5*REAL(MX-1)*SX)/360.) ) - PGRID(IG)%X0 = PGRID(IG)%X0 - XOFF -! + WRITE (NDST,9052) GSTOLD(IG)%STRADLE, GSTOLD(IG)%NPTS, & + GSTOLD(IG)%NXL, GSTOLD(IG)%NXH, & + GSTOLD(IG)%NYL, GSTOLD(IG)%NYH +#endif + ! + ! 6. Extract reduced grid data -------------------------------------- * + ! + MY = 1 + GSTOLD(IG)%NYH - GSTOLD(IG)%NYL + MX = 1 + GSTOLD(IG)%NXH - GSTOLD(IG)%NXL + IF ( GSTOLD(IG)%STRADLE ) MX = MX + NX + PGRID(IG)%NY = MY + PGRID(IG)%NX = MX + PGRID(IG)%NSEA = GSTOLD(IG)%NPTS + PGRID(IG)%X0 = X0 + REAL(GSTOLD(IG)%NXL-1)*SX + PGRID(IG)%Y0 = Y0 + REAL(GSTOLD(IG)%NYL-1)*SY + PGRID(IG)%SX = SX + PGRID(IG)%SY = SY + ! + XOFF = 360. * REAL ( NINT((PGRID(IG)%X0+0.5*REAL(MX-1)*SX)/360.) ) + PGRID(IG)%X0 = PGRID(IG)%X0 - XOFF + ! #ifdef W3_T7 - WRITE (NDST,9060) PGRID(IG)%NX, PGRID(IG)%NY, PGRID(IG)%NSEA, & - PGRID(IG)%X0, PGRID(IG)%Y0, PGRID(IG)%SX, PGRID(IG)%SY -#endif -! - ALLOCATE ( PGRID(IG)%ZBIN(MX,MY) , & - PGRID(IG)%OBSX(MX,MY) , & - PGRID(IG)%OBSY(MX,MY) , & - PGRID(IG)%MASK(MX,MY) ) -! - PGRID(IG)%ZBIN = ZBDUM - PGRID(IG)%OBSX = 0. - PGRID(IG)%OBSY = 0. - PGRID(IG)%MASK = 99 -! - DO IX=1, PGRID(IG)%NX - JX = 1 + MOD ( IX+GSTOLD(IG)%NXL-2 , NX ) - DO IY=1, PGRID(IG)%NY - JY = IY + GSTOLD(IG)%NYL - 1 - ISEA = MAPFS(JY,JX) - IF ( MTEMP(JY,JX) .NE. 0 ) THEN - PGRID(IG)%ZBIN(IX,IY) = ZB(ISEA) - END IF - IF ( TRFLAG .NE. 0 ) THEN - PGRID(IG)%OBSX(IX,IY) = 1. - TRNX(JY,JX) - PGRID(IG)%OBSY(IX,IY) = 1. - TRNY(JY,JX) - END IF - PGRID(IG)%MASK(IX,IY) = MTEMP(JY,JX) - END DO - END DO -! - RETURN -! -! Formats -! + WRITE (NDST,9060) PGRID(IG)%NX, PGRID(IG)%NY, PGRID(IG)%NSEA, & + PGRID(IG)%X0, PGRID(IG)%Y0, PGRID(IG)%SX, PGRID(IG)%SY +#endif + ! + ALLOCATE ( PGRID(IG)%ZBIN(MX,MY) , & + PGRID(IG)%OBSX(MX,MY) , & + PGRID(IG)%OBSY(MX,MY) , & + PGRID(IG)%MASK(MX,MY) ) + ! + PGRID(IG)%ZBIN = ZBDUM + PGRID(IG)%OBSX = 0. + PGRID(IG)%OBSY = 0. + PGRID(IG)%MASK = 99 + ! + DO IX=1, PGRID(IG)%NX + JX = 1 + MOD ( IX+GSTOLD(IG)%NXL-2 , NX ) + DO IY=1, PGRID(IG)%NY + JY = IY + GSTOLD(IG)%NYL - 1 + ISEA = MAPFS(JY,JX) + IF ( MTEMP(JY,JX) .NE. 0 ) THEN + PGRID(IG)%ZBIN(IX,IY) = ZB(ISEA) + END IF + IF ( TRFLAG .NE. 0 ) THEN + PGRID(IG)%OBSX(IX,IY) = 1. - TRNX(JY,JX) + PGRID(IG)%OBSY(IX,IY) = 1. - TRNY(JY,JX) + END IF + PGRID(IG)%MASK(IX,IY) = MTEMP(JY,JX) + END DO + END DO + ! + RETURN + ! + ! Formats + ! #ifdef W3_T7 - 9000 FORMAT ( 'TEST GR1GRD: EXTRACTING GRID:',I4) - 9040 FORMAT ( ' MASK ON FULL GRID COMPUTED') - 9050 FORMAT ( 'TEST GR1GRD: GRID STATS :'/ & - ' GRID MAP :',L2,2X,I8,4I5) - 9051 FORMAT ( ' HALO ADDED :',L2,2X,I8,4I5) - 9052 FORMAT ( ' BORDER ADDED :',L2,2X,I8,4I5) - 9060 FORMAT ( 'TEST GR1GRD: EXTRACTED GRID :',2I5,I8/ & - ' ',4E12.5) -#endif -! -!/ End of GR1GRD ----------------------------------------------------- / -!/ - END SUBROUTINE GR1GRD -!/ -!/ End of W3GSPL ----------------------------------------------------- / -!/ - END PROGRAM W3GSPL +9000 FORMAT ( 'TEST GR1GRD: EXTRACTING GRID:',I4) +9040 FORMAT ( ' MASK ON FULL GRID COMPUTED') +9050 FORMAT ( 'TEST GR1GRD: GRID STATS :'/ & + ' GRID MAP :',L2,2X,I8,4I5) +9051 FORMAT ( ' HALO ADDED :',L2,2X,I8,4I5) +9052 FORMAT ( ' BORDER ADDED :',L2,2X,I8,4I5) +9060 FORMAT ( 'TEST GR1GRD: EXTRACTED GRID :',2I5,I8/ & + ' ',4E12.5) +#endif + ! + !/ End of GR1GRD ----------------------------------------------------- / + !/ + END SUBROUTINE GR1GRD + !/ + !/ End of W3GSPL ----------------------------------------------------- / + !/ +END PROGRAM W3GSPL diff --git a/model/src/ww3_multi.F90 b/model/src/ww3_multi.F90 index 866b72962..39a6b5bf3 100644 --- a/model/src/ww3_multi.F90 +++ b/model/src/ww3_multi.F90 @@ -11,211 +11,211 @@ !> (uncoupled). !> !> @author H. L. Tolman @date 29-May-2009 - PROGRAM W3MLTI -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 29-May-2009 | -!/ +-----------------------------------+ -!/ -!/ 04-May-2005 : Origination. ( version 3.07 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 17-Feb-2016 : New version from namelist use ( version 5.11 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Program shell or driver to run the multi-grid wave model -! (uncoupled). -! -! 2. Method : -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINIT Subr. WMINITMD Multi-grid model initialization. -! WMFINL Subr. WMFINLMD Multi-grid model finalization. -! -! MPI_INIT, MPI_COMM_SIZE, MPI_COMM_RANK, MPI_BARRIER, -! MPI_FINALIZE -! Subr. Standard MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! - This is he third version, version 1 and 2 were use for proof -! of concept only, and were not retained. -! -! 8. Structure : -! -! ---------------------------------------------------------------- -! 0. Initialization necessary for driver -! a General I/O: (implicit in wmmdatmd) -! b MPI environment -! c Identifying output to "screen" unit -! 1. Initialization of all wave models / grids ( WMINIT ) -! 2. Run the multi-grid models ( WMWAVE ) -! 3. Finalization of wave model ( WMFINL ) -! 4. Finalization of driver -! ---------------------------------------------------------------- -! -! 9. Switches : -! -! !/MPI Including MPI routines / environment. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE WMINITMD, ONLY: WMINIT, WMINITNML - USE WMWAVEMD, ONLY: WMWAVE - USE WMFINLMD, ONLY: WMFINL -!/ - USE WMMDATMD, ONLY: MDSI, MDSO, MDSS, MDST, MDSE, & - NMPROC, IMPROC, NMPSCR, NRGRD, ETIME -!/ - IMPLICIT NONE -! +PROGRAM W3MLTI + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 29-May-2009 | + !/ +-----------------------------------+ + !/ + !/ 04-May-2005 : Origination. ( version 3.07 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 17-Feb-2016 : New version from namelist use ( version 5.11 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Program shell or driver to run the multi-grid wave model + ! (uncoupled). + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINIT Subr. WMINITMD Multi-grid model initialization. + ! WMFINL Subr. WMFINLMD Multi-grid model finalization. + ! + ! MPI_INIT, MPI_COMM_SIZE, MPI_COMM_RANK, MPI_BARRIER, + ! MPI_FINALIZE + ! Subr. Standard MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - This is he third version, version 1 and 2 were use for proof + ! of concept only, and were not retained. + ! + ! 8. Structure : + ! + ! ---------------------------------------------------------------- + ! 0. Initialization necessary for driver + ! a General I/O: (implicit in wmmdatmd) + ! b MPI environment + ! c Identifying output to "screen" unit + ! 1. Initialization of all wave models / grids ( WMINIT ) + ! 2. Run the multi-grid models ( WMWAVE ) + ! 3. Finalization of wave model ( WMFINL ) + ! 4. Finalization of driver + ! ---------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/MPI Including MPI routines / environment. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE WMINITMD, ONLY: WMINIT, WMINITNML + USE WMWAVEMD, ONLY: WMWAVE + USE WMFINLMD, ONLY: WMFINL + !/ + USE WMMDATMD, ONLY: MDSI, MDSO, MDSS, MDST, MDSE, & + NMPROC, IMPROC, NMPSCR, NRGRD, ETIME + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, MPI_COMM = -99 - INTEGER, ALLOCATABLE :: TEND(:,:) - LOGICAL :: FLGNML + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, MPI_COMM = -99 + INTEGER, ALLOCATABLE :: TEND(:,:) + LOGICAL :: FLGNML #ifdef W3_MPI - INTEGER :: IERR_MPI - LOGICAL :: FLHYBR = .FALSE. + INTEGER :: IERR_MPI + LOGICAL :: FLHYBR = .FALSE. #endif #ifdef W3_OMPH - INTEGER :: THRLEV + INTEGER :: THRLEV #endif -!/ -!/ ------------------------------------------------------------------- / -! 0. Initialization necessary for driver -! 0.a General I/O: all can start with initialization in wmmdatmd -! -! 0.b MPI environment: Here, we use MPI_COMM_WORLD -! + !/ + !/ ------------------------------------------------------------------- / + ! 0. Initialization necessary for driver + ! 0.a General I/O: all can start with initialization in wmmdatmd + ! + ! 0.b MPI environment: Here, we use MPI_COMM_WORLD + ! #ifdef W3_OMPH - FLHYBR = .TRUE. - ! For hybrid MPI-OpenMP specify required thread level: - IF( FLHYBR ) THEN - CALL MPI_INIT_THREAD(MPI_THREAD_FUNNELED, THRLEV, IERR_MPI) - ELSE + FLHYBR = .TRUE. + ! For hybrid MPI-OpenMP specify required thread level: + IF( FLHYBR ) THEN + CALL MPI_INIT_THREAD(MPI_THREAD_FUNNELED, THRLEV, IERR_MPI) + ELSE #endif #ifdef W3_MPI - CALL MPI_INIT ( IERR_MPI ) + CALL MPI_INIT ( IERR_MPI ) #endif #ifdef W3_OMPH - ENDIF + ENDIF #endif #ifdef W3_MPI - MPI_COMM = MPI_COMM_WORLD - CALL MPI_COMM_SIZE ( MPI_COMM, NMPROC, IERR_MPI ) - CALL MPI_COMM_RANK ( MPI_COMM, IMPROC, IERR_MPI ) - IMPROC = IMPROC + 1 + MPI_COMM = MPI_COMM_WORLD + CALL MPI_COMM_SIZE ( MPI_COMM, NMPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 #endif -! -! 0.c Identifying output to "screen" unit -! - IF ( IMPROC .EQ. NMPSCR ) WRITE (*,900) + ! + ! 0.c Identifying output to "screen" unit + ! + IF ( IMPROC .EQ. NMPSCR ) WRITE (*,900) #ifdef W3_OMPH - IF ( IMPROC .EQ. NMPSCR ) WRITE (*,905) & - MPI_THREAD_FUNNELED, THRLEV + IF ( IMPROC .EQ. NMPSCR ) WRITE (*,905) & + MPI_THREAD_FUNNELED, THRLEV #endif -! -!/ ------------------------------------------------------------------- / -! 1. Initialization of all wave models / grids -! Use only one of the calls .... -! -! ... Log and screen output, no separate test output file -! -! CALL WMINIT ( MDSI, MDSO, MDSS, MDST, MDSE, 'ww3_multi.inp', MPI_COMM ) -! -! ... Screen output disabled -! -! CALL WMINIT ( MDSI, MDSO, MDSO, MDST, MDSE, 'ww3_multi.inp', MPI_COMM ) -! -! ... Separate test output file and file preamble defined -! -! CALL WMINIT ( MDSI, MDSO, MDSS, 10, MDSE, 'ww3_multi.inp', MPI_COMM, & -! './data/' ) -! -! ... Separate test output file -! - INQUIRE(FILE="ww3_multi.nml", EXIST=FLGNML) - IF (FLGNML) THEN - CALL WMINITNML ( MDSI, MDSO, MDSS, 10, MDSE, 'ww3_multi.nml', MPI_COMM ) - ELSE - CALL WMINIT ( MDSI, MDSO, MDSS, 10, MDSE, 'ww3_multi.inp', MPI_COMM ) - END IF -! + ! + !/ ------------------------------------------------------------------- / + ! 1. Initialization of all wave models / grids + ! Use only one of the calls .... + ! + ! ... Log and screen output, no separate test output file + ! + ! CALL WMINIT ( MDSI, MDSO, MDSS, MDST, MDSE, 'ww3_multi.inp', MPI_COMM ) + ! + ! ... Screen output disabled + ! + ! CALL WMINIT ( MDSI, MDSO, MDSO, MDST, MDSE, 'ww3_multi.inp', MPI_COMM ) + ! + ! ... Separate test output file and file preamble defined + ! + ! CALL WMINIT ( MDSI, MDSO, MDSS, 10, MDSE, 'ww3_multi.inp', MPI_COMM, & + ! './data/' ) + ! + ! ... Separate test output file + ! + INQUIRE(FILE="ww3_multi.nml", EXIST=FLGNML) + IF (FLGNML) THEN + CALL WMINITNML ( MDSI, MDSO, MDSS, 10, MDSE, 'ww3_multi.nml', MPI_COMM ) + ELSE + CALL WMINIT ( MDSI, MDSO, MDSS, 10, MDSE, 'ww3_multi.inp', MPI_COMM ) + END IF + ! -! -!/ ------------------------------------------------------------------- / -! 2. Run the wave model -! - ALLOCATE ( TEND(2,NRGRD) ) -! - DO I=1, NRGRD - TEND(:,I) = ETIME(:) - END DO -! - CALL WMWAVE ( TEND ) -! - DEALLOCATE ( TEND ) -! -!/ ------------------------------------------------------------------- / -! 3. Finalize the wave model -! - CALL WMFINL -! -!/ ------------------------------------------------------------------- / -! 4 Finalize the driver -! - IF ( IMPROC .EQ. NMPSCR ) WRITE (*,999) -! + ! + !/ ------------------------------------------------------------------- / + ! 2. Run the wave model + ! + ALLOCATE ( TEND(2,NRGRD) ) + ! + DO I=1, NRGRD + TEND(:,I) = ETIME(:) + END DO + ! + CALL WMWAVE ( TEND ) + ! + DEALLOCATE ( TEND ) + ! + !/ ------------------------------------------------------------------- / + ! 3. Finalize the wave model + ! + CALL WMFINL + ! + !/ ------------------------------------------------------------------- / + ! 4 Finalize the driver + ! + IF ( IMPROC .EQ. NMPSCR ) WRITE (*,999) + ! #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) - CALL MPI_FINALIZE ( IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) + CALL MPI_FINALIZE ( IERR_MPI ) #endif -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Multi-grid shell *** '/ & - 15X,'================================================='/) + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Multi-grid shell *** '/ & + 15X,'================================================='/) #ifdef W3_OMPH - 905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & - ' Requested: ', I2/ & - ' Provided: ', I2/ ) +905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & + ' Requested: ', I2/ & + ' Provided: ', I2/ ) #endif -! - 999 FORMAT(//' End of program '/ & - ' ========================================'/ & - ' WAVEWATCH III Multi-grid shell '/) -!/ -!/ End of W3MLTI ----------------------------------------------------- / -!/ - END PROGRAM W3MLTI + ! +999 FORMAT(//' End of program '/ & + ' ========================================'/ & + ' WAVEWATCH III Multi-grid shell '/) + !/ + !/ End of W3MLTI ----------------------------------------------------- / + !/ +END PROGRAM W3MLTI diff --git a/model/src/ww3_ounf.F90 b/model/src/ww3_ounf.F90 index 9963bf16f..0a2cadfca 100644 --- a/model/src/ww3_ounf.F90 +++ b/model/src/ww3_ounf.F90 @@ -18,1988 +18,1987 @@ !> @author F. Ardhuin !> @author M. Accensi !> @date 02-Sep-2021 - PROGRAM W3OUNF -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 02-Sep-2021 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-2010 : Creation ( version 3.14_SHOM ) -!/ 07-Nov-2011 : Debug for spectral output on UNST ( version 4.04 ) -!/ 13-Mar-2012 : Update of NC attributes ( version 4.04 ) -!/ 02-Apr-2013 : New structure of output fields. ( version 4.10 ) -!/ 02-Jul-2013 : Bug correction for lat in unst grid ( version 4.11 ) -!/ 02-Nov-2013 : Removes unnecessary IDFM ( version 4.12 ) -!/ 30-Apr-2014 : Correct group3 freq dim. ( version 5.00 ) -!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) -!/ 14-Oct-2014 : Keep the output files opened ( version 5.01 ) -!/ 27-Aug-2015 : ICEH and ICEF added as output ( version 5.10 ) -!/ 10-Jan-2017 : Changes for US3D and USSP output ( version 6.01 ) -!/ 01-May-2017 : Adds directional MSS parameters ( version 6.04 ) -!/ 01-Mar-2018 : RTD option add variable de-rotation,( version 6.02 ) -!/ standard lat-lons and rotated grid -!/ metadata -!/ 15-May-2018 : Add namelist feature ( version 6.05 ) -!/ 06-Jun-2018 : Add DEBUG/SETUP ( version 6.04 ) -!/ 27-Jun-2018 : Updated to handle SMC output. ( version 6.05 ) -!/ 26-Jul-2018 : Changed reading of TABIPART ( version 6.05 ) -!/ 12-Sep-2018 : Added extra partitioned fields ( version 6.06 ) -!/ 25-Sep-2018 : Add WBT parameter ( version 6.06 ) -!/ 28-Mar-2019 : Bugfix to NBIPART check. ( version 6.07 ) -!/ 18-Jun-2020 : Support for 360-day calendar. ( version 7.08 ) -!/ 07-Oct-2019 : RTD option with standard lat-lon -!/ grid when nesting to rotated grid ( version 7.11 ) -!/ 03-Nov-2020 : Moved NetCDF metadata to separate ( version 7.12 ) -!/ module. -!/ 09-Dec-2020 : Set fixed values for VARID indices ( version 7.12 ) -!/ 06-Jan-2021 : Added forecast_period and ( version 7.12 ) -!/ forecast_reference_time variables. -!/ 12-Jan-2021 : Alternative vartype and units for ( version 7.12 ) -!/ time variables. -!/ 26-Jan-2021 : Added TP output (derived from fp) ( version 7.12 ) -!/ and alternative dir/mag output. -!/ 02-Feb-2021 : Make default global meta optional ( version 7.12 ) -!/ 22-Mar-2021 : New coupling fields output ( version 7.12 ) -!/ 02-Sep-2021 : Added coordinates attribute ( version 7.12 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Post-processing of grid output to NetCDF files -! -! 2. Method : -! -! Data is read from the grid output file out_grd.ww3 (raw data) -! and from the file ww3_ounf.nml or ww3_ounf.inp (NDSI) -! Model definition and raw data files are read using WAVEWATCH III -! subroutines. Extra global NetCDF attributes may be read from -! ASCII file NC_globatt.inp. -! -! Output types : -! 4 : NetCDF files -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W2NAUX Subr. W3ADATMD Set number of model for aux data. -! W3SETA Subr. Id. Point to selected model for aux data. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! STME21 Subr. W3TIMEMD Convert time to string. -! TICK21 Subr. Id. Advance time. -! DSEC21 Func. Id. Difference between times. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. -! W3EXNC Subr. Internal Execute grid netcdf output. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! Checks on input, checks in W3IOxx. -! -! 7. Remarks : -! -! The VARID array stores netCDF variable IDs for all variables in -! file. The first 20 elements are reserved for dimension/auxiliary -! variables as defined below: -! -! Index Variable -! ===== ======== -! 1 Lon -! 2 Lat -! 3 Time -! 4 Tri (UGRD) -! 5 SMC CX (SMC) -! 6 SMC CY (SMC) -! 7 Standard longitude (SMC/RTD) -! 8 Standard latitude (SMC/RTD) -! 9 Coordinate reference system (upcoming feature / RTD) -! 10 Freq (extradim) -! 11 Forecast period (upcoming feature) -! 12 Forecast reference time (upcoming feature) -! 13-19 [Reserved for future use] -! 20 MAPSTA -! -! Indices 21 - 300 are for storage of field output variable IDs. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - -!/ - USE W3WDATMD, ONLY: W3NDAT, W3SETW - USE W3ADATMD, ONLY: W3NAUX, W3SETA - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STR_TO_UPPER +PROGRAM W3OUNF + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 02-Sep-2021 | + !/ +-----------------------------------+ + !/ + !/ 17-Mar-2010 : Creation ( version 3.14_SHOM ) + !/ 07-Nov-2011 : Debug for spectral output on UNST ( version 4.04 ) + !/ 13-Mar-2012 : Update of NC attributes ( version 4.04 ) + !/ 02-Apr-2013 : New structure of output fields. ( version 4.10 ) + !/ 02-Jul-2013 : Bug correction for lat in unst grid ( version 4.11 ) + !/ 02-Nov-2013 : Removes unnecessary IDFM ( version 4.12 ) + !/ 30-Apr-2014 : Correct group3 freq dim. ( version 5.00 ) + !/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) + !/ 14-Oct-2014 : Keep the output files opened ( version 5.01 ) + !/ 27-Aug-2015 : ICEH and ICEF added as output ( version 5.10 ) + !/ 10-Jan-2017 : Changes for US3D and USSP output ( version 6.01 ) + !/ 01-May-2017 : Adds directional MSS parameters ( version 6.04 ) + !/ 01-Mar-2018 : RTD option add variable de-rotation,( version 6.02 ) + !/ standard lat-lons and rotated grid + !/ metadata + !/ 15-May-2018 : Add namelist feature ( version 6.05 ) + !/ 06-Jun-2018 : Add DEBUG/SETUP ( version 6.04 ) + !/ 27-Jun-2018 : Updated to handle SMC output. ( version 6.05 ) + !/ 26-Jul-2018 : Changed reading of TABIPART ( version 6.05 ) + !/ 12-Sep-2018 : Added extra partitioned fields ( version 6.06 ) + !/ 25-Sep-2018 : Add WBT parameter ( version 6.06 ) + !/ 28-Mar-2019 : Bugfix to NBIPART check. ( version 6.07 ) + !/ 18-Jun-2020 : Support for 360-day calendar. ( version 7.08 ) + !/ 07-Oct-2019 : RTD option with standard lat-lon + !/ grid when nesting to rotated grid ( version 7.11 ) + !/ 03-Nov-2020 : Moved NetCDF metadata to separate ( version 7.12 ) + !/ module. + !/ 09-Dec-2020 : Set fixed values for VARID indices ( version 7.12 ) + !/ 06-Jan-2021 : Added forecast_period and ( version 7.12 ) + !/ forecast_reference_time variables. + !/ 12-Jan-2021 : Alternative vartype and units for ( version 7.12 ) + !/ time variables. + !/ 26-Jan-2021 : Added TP output (derived from fp) ( version 7.12 ) + !/ and alternative dir/mag output. + !/ 02-Feb-2021 : Make default global meta optional ( version 7.12 ) + !/ 22-Mar-2021 : New coupling fields output ( version 7.12 ) + !/ 02-Sep-2021 : Added coordinates attribute ( version 7.12 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Post-processing of grid output to NetCDF files + ! + ! 2. Method : + ! + ! Data is read from the grid output file out_grd.ww3 (raw data) + ! and from the file ww3_ounf.nml or ww3_ounf.inp (NDSI) + ! Model definition and raw data files are read using WAVEWATCH III + ! subroutines. Extra global NetCDF attributes may be read from + ! ASCII file NC_globatt.inp. + ! + ! Output types : + ! 4 : NetCDF files + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W2NAUX Subr. W3ADATMD Set number of model for aux data. + ! W3SETA Subr. Id. Point to selected model for aux data. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! TICK21 Subr. Id. Advance time. + ! DSEC21 Func. Id. Difference between times. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. + ! W3EXNC Subr. Internal Execute grid netcdf output. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! Checks on input, checks in W3IOxx. + ! + ! 7. Remarks : + ! + ! The VARID array stores netCDF variable IDs for all variables in + ! file. The first 20 elements are reserved for dimension/auxiliary + ! variables as defined below: + ! + ! Index Variable + ! ===== ======== + ! 1 Lon + ! 2 Lat + ! 3 Time + ! 4 Tri (UGRD) + ! 5 SMC CX (SMC) + ! 6 SMC CY (SMC) + ! 7 Standard longitude (SMC/RTD) + ! 8 Standard latitude (SMC/RTD) + ! 9 Coordinate reference system (upcoming feature / RTD) + ! 10 Freq (extradim) + ! 11 Forecast period (upcoming feature) + ! 12 Forecast reference time (upcoming feature) + ! 13-19 [Reserved for future use] + ! 20 MAPSTA + ! + ! Indices 21 - 300 are for storage of field output variable IDs. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + + !/ + USE W3WDATMD, ONLY: W3NDAT, W3SETW + USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STR_TO_UPPER #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif - USE W3TIMEMD - USE W3IOGRMD, ONLY: W3IOGR - USE W3IOGOMD, ONLY: W3IOGO, W3READFLGRD, W3FLGRDFLAG - USE W3INITMD, ONLY: WWVER, SWITCHES - USE W3ODATMD, ONLY: NAPROC, NOSWLL, PTMETH, PTFCUT - USE W3ODATMD, only : IAPROC -!/ - USE W3GDATMD - USE W3WDATMD, ONLY: TIME, WLV, ICE, ICEH, ICEF, BERG, & - UST, USTDIR, RHOAIR + USE W3TIMEMD + USE W3IOGRMD, ONLY: W3IOGR + USE W3IOGOMD, ONLY: W3IOGO, W3READFLGRD, W3FLGRDFLAG + USE W3INITMD, ONLY: WWVER, SWITCHES + USE W3ODATMD, ONLY: NAPROC, NOSWLL, PTMETH, PTFCUT + USE W3ODATMD, only : IAPROC + !/ + USE W3GDATMD + USE W3WDATMD, ONLY: TIME, WLV, ICE, ICEH, ICEF, BERG, & + UST, USTDIR, RHOAIR #ifdef W3_SETUP - USE W3WDATMD, ONLY: ZETA_SETUP + USE W3WDATMD, ONLY: ZETA_SETUP #endif - USE W3ADATMD, ONLY: DW, UA, UD, AS, CX, CY, HS, WLM, T0M1, THM, & - THS, FP0, THP0, DTDYN, FCUT, & - ABA, ABD, UBA, UBD, SXX, SYY, SXY, USERO, & - PHS, PTP, PLP, PDIR, PSI, PWS, PWST, PNR, & - PTM1, PT1, PT2, PEP, TAUOCX, TAUOCY, & - PTHP0, PQP, PSW, PPE, PGW, QP, & - TAUOX, TAUOY, TAUWIX, & - TAUWIY, PHIAW, PHIOC, TUSX, TUSY, PRMS, TPMS,& - USSX, USSY, MSSX, MSSY, MSSD, MSCX, MSCY, & - MSCD, CHARN, TWS, TAUA, TAUADIR, & - TAUWNX, TAUWNY, BHD, T02, HSIG, CGE, & - T01, BEDFORMS, WHITECAP, TAUBBL, PHIBBL, & - CFLTHMAX, CFLXYMAX, CFLKMAX, TAUICE, PHICE, & - STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD, HCMAXD,& - P2SMS, EF, US3D, TH1M, STH1M, TH2M, STH2M, & - WN, USSP, WBT, WNMEAN - USE W3ODATMD, ONLY: NDSO, NDSE, SCREEN, NOGRP, NGRPP, IDOUT, & - UNDEF, FLOGRD, FNMPRE, NOSWLL, NOGE -! - USE W3NMLOUNFMD -! - USE W3OUNFMETAMD, ONLY: INIT_META, TEARDOWN_META, GETMETA, & - WRITE_META, WRITE_GLOBAL_META, & - WRITE_FREEFORM_META_LIST, & - META_T, NCVARTYPE, CRS_META, CRS_NAME, & - FL_DEFAULT_GBL_META, COORDS_ATTR -! - USE NETCDF + USE W3ADATMD, ONLY: DW, UA, UD, AS, CX, CY, HS, WLM, T0M1, THM, & + THS, FP0, THP0, DTDYN, FCUT, & + ABA, ABD, UBA, UBD, SXX, SYY, SXY, USERO, & + PHS, PTP, PLP, PDIR, PSI, PWS, PWST, PNR, & + PTM1, PT1, PT2, PEP, TAUOCX, TAUOCY, & + PTHP0, PQP, PSW, PPE, PGW, QP, & + TAUOX, TAUOY, TAUWIX, & + TAUWIY, PHIAW, PHIOC, TUSX, TUSY, PRMS, TPMS,& + USSX, USSY, MSSX, MSSY, MSSD, MSCX, MSCY, & + MSCD, CHARN, TWS, TAUA, TAUADIR, & + TAUWNX, TAUWNY, BHD, T02, HSIG, CGE, & + T01, BEDFORMS, WHITECAP, TAUBBL, PHIBBL, & + CFLTHMAX, CFLXYMAX, CFLKMAX, TAUICE, PHICE, & + STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD, HCMAXD,& + P2SMS, EF, US3D, TH1M, STH1M, TH2M, STH2M, & + WN, USSP, WBT, WNMEAN + USE W3ODATMD, ONLY: NDSO, NDSE, SCREEN, NOGRP, NGRPP, IDOUT, & + UNDEF, FLOGRD, FNMPRE, NOSWLL, NOGE + ! + USE W3NMLOUNFMD + ! + USE W3OUNFMETAMD, ONLY: INIT_META, TEARDOWN_META, GETMETA, & + WRITE_META, WRITE_GLOBAL_META, & + WRITE_FREEFORM_META_LIST, & + META_T, NCVARTYPE, CRS_META, CRS_NAME, & + FL_DEFAULT_GBL_META, COORDS_ATTR + ! + USE NETCDF #ifdef W3_SMC - USE W3SMCOMD, SMCNOVAL=>NOVAL + USE W3SMCOMD, SMCNOVAL=>NOVAL #endif - IMPLICIT NONE - -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(NML_FIELD_T) :: NML_FIELD - TYPE(NML_FILE_T) :: NML_FILE - TYPE(NML_SMC_T) :: NML_SMC -! - INTEGER :: NDSI, NDSM, NDSOG, & - NDSTRC, NTRACE, IERR, I, I1F, I2F, & - IOTEST, NOUT, & - IFI, IFJ, NCTYPE, IX1, IXN, IY1, IYN, & - IOUT, S3, IRET, & - NBIPART, CNTIPART, NCVARTYPEI, IPART, & - RTDNX, RTDNY - INTEGER :: TOUT(2), TDUM(2), TREF(2), TEPOCH(2), & - STOPDATE(8), REFDATE(8) -! - INTEGER, ALLOCATABLE :: TABIPART(:), NCIDS(:,:,:) -! + IMPLICIT NONE + + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(NML_FIELD_T) :: NML_FIELD + TYPE(NML_FILE_T) :: NML_FILE + TYPE(NML_SMC_T) :: NML_SMC + ! + INTEGER :: NDSI, NDSM, NDSOG, & + NDSTRC, NTRACE, IERR, I, I1F, I2F, & + IOTEST, NOUT, & + IFI, IFJ, NCTYPE, IX1, IXN, IY1, IYN, & + IOUT, S3, IRET, & + NBIPART, CNTIPART, NCVARTYPEI, IPART, & + RTDNX, RTDNY + INTEGER :: TOUT(2), TDUM(2), TREF(2), TEPOCH(2), & + STOPDATE(8), REFDATE(8) + ! + INTEGER, ALLOCATABLE :: TABIPART(:), NCIDS(:,:,:) + ! #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! - REAL :: DTREQ, DTEST -! - CHARACTER*30 :: STRSTOPDATE, FILEPREFIX, STRINGIPART - CHARACTER*1024 :: FLDOUT - CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, TTYPE*1 -! - LOGICAL :: FLG2D(NOGRP,NGRPP), FLG1D(NOGRP), & - VECTOR, TOGETHER, FLGNML, FLGFC - LOGICAL :: MAPSTAOUT = .TRUE. - LOGICAL :: SMCGRD = .FALSE. + ! + REAL :: DTREQ, DTEST + ! + CHARACTER*30 :: STRSTOPDATE, FILEPREFIX, STRINGIPART + CHARACTER*1024 :: FLDOUT + CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, TTYPE*1 + ! + LOGICAL :: FLG2D(NOGRP,NGRPP), FLG1D(NOGRP), & + VECTOR, TOGETHER, FLGNML, FLGFC + LOGICAL :: MAPSTAOUT = .TRUE. + LOGICAL :: SMCGRD = .FALSE. #ifdef W3_RTD - LOGICAL :: RTDL = .FALSE. + LOGICAL :: RTDL = .FALSE. #endif - INTEGER :: TVARTYPE = NF90_DOUBLE - CHARACTER(LEN=32) :: EPOCH_ISO - CHARACTER(LEN=64) :: EPOCH - CHARACTER :: TIMEUNIT*1 ! 'D' = days, or 'S' for seconds -! - REAL :: NOVAL ! Fill value for seapoints with no value -!/ -!/ ------------------------------------------------------------------- / -!/ -! 1. IO set-up. -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! - NDSI = 10 - NDSM = 20 - NDSOG = 20 -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + INTEGER :: TVARTYPE = NF90_DOUBLE + CHARACTER(LEN=32) :: EPOCH_ISO + CHARACTER(LEN=64) :: EPOCH + CHARACTER :: TIMEUNIT*1 ! 'D' = days, or 'S' for seconds + ! + REAL :: NOVAL ! Fill value for seapoints with no value + !/ + !/ ------------------------------------------------------------------- / + !/ + ! 1. IO set-up. + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + NDSI = 10 + NDSM = 20 + NDSOG = 20 + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_S - CALL STRACE (IENT, 'W3OUNF') + CALL STRACE (IENT, 'W3OUNF') #endif -! - WRITE (NDSO,900) -! - ! Default epoch time: - TEPOCH(1) = 19900101 - TEPOCH(2) = 0 -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - WRITE (NDSO,920) GNAME -! + ! + WRITE (NDSO,900) + ! + ! Default epoch time: + TEPOCH(1) = 19900101 + TEPOCH(2) = 0 + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + WRITE (NDSO,920) GNAME + ! #ifdef W3_RTD - ! Is the grid really rotated? - IF ( Polat < 90. ) RTDL = .True. - ! + ! Is the grid really rotated? + IF ( Polat < 90. ) RTDL = .True. + ! #endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read general data and first fields from file -! - CALL W3IOGO ( 'READ', NDSOG, IOTEST ) -! - WRITE (NDSO,930) - DO IFI=1, NOGRP - DO IFJ=1, NGRPP - IF ( FLOGRD(IFI,IFJ) ) WRITE (NDSO,931) IDOUT(IFI,IFJ) - END DO - END DO -! + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read general data and first fields from file + ! + CALL W3IOGO ( 'READ', NDSOG, IOTEST ) + ! + WRITE (NDSO,930) + DO IFI=1, NOGRP + DO IFJ=1, NGRPP + IF ( FLOGRD(IFI,IFJ) ) WRITE (NDSO,931) IDOUT(IFI,IFJ) + END DO + END DO + ! #ifdef W3_SMC - IF( GTYPE .EQ. SMCTYPE ) THEN - SMCGRD = .TRUE. - WRITE (NDSO, *) " Conversion for SMCTYPE:", GTYPE - ENDIF + IF( GTYPE .EQ. SMCTYPE ) THEN + SMCGRD = .TRUE. + WRITE (NDSO, *) " Conversion for SMCTYPE:", GTYPE + ENDIF #endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Read requests from input file. -! -! process ww3_ounf namelist -! - INQUIRE(FILE=TRIM(FNMPRE)//"ww3_ounf.nml", EXIST=FLGNML) - IF (FLGNML) THEN - ! Read namelist - CALL W3NMLOUNF (NDSI, TRIM(FNMPRE)//'ww3_ounf.nml', NML_FIELD, & - NML_FILE, NML_SMC, IERR) - -! 4.1 Time setup - READ(NML_FIELD%TIMESTRIDE, *) DTREQ - READ(NML_FIELD%TIMECOUNT, *) NOUT - READ(NML_FIELD%TIMESTART, *) TOUT(1), TOUT(2) - READ(NML_FIELD%TIMEREF, *) TREF(1), TREF(2) - READ(NML_FIELD%TIMEEPOCH, *) TEPOCH(1), TEPOCH(2) - -! 4.2 Output fields - FLDOUT = NML_FIELD%LIST - CALL W3FLGRDFLAG ( NDSO, SCREEN, NDSE, FLDOUT, FLG1D, & - FLG2D, 1, 1, IERR ) - IF (IERR.NE.0) GOTO 800 - -! 4.3 Output type - NCTYPE = NML_FILE%NETCDF - NCVARTYPE = NML_FIELD%TYPE - STRINGIPART = NML_FIELD%PARTITION - TOGETHER = NML_FIELD%SAMEFILE - VECTOR = NML_FIELD%VECTOR - FILEPREFIX = NML_FILE%PREFIX - FLGFC = NML_FIELD%FCVARS - S3 = NML_FIELD%TIMESPLIT - TTYPE = NML_FIELD%TIMEVAR - TIMEUNIT = NML_FIELD%TIMEUNIT - NOVAL = NML_FIELD%NOVAL - MAPSTAOUT = NML_FIELD%MAPSTA - IF(SMCGRD) THEN + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Read requests from input file. + ! + ! process ww3_ounf namelist + ! + INQUIRE(FILE=TRIM(FNMPRE)//"ww3_ounf.nml", EXIST=FLGNML) + IF (FLGNML) THEN + ! Read namelist + CALL W3NMLOUNF (NDSI, TRIM(FNMPRE)//'ww3_ounf.nml', NML_FIELD, & + NML_FILE, NML_SMC, IERR) + + ! 4.1 Time setup + READ(NML_FIELD%TIMESTRIDE, *) DTREQ + READ(NML_FIELD%TIMECOUNT, *) NOUT + READ(NML_FIELD%TIMESTART, *) TOUT(1), TOUT(2) + READ(NML_FIELD%TIMEREF, *) TREF(1), TREF(2) + READ(NML_FIELD%TIMEEPOCH, *) TEPOCH(1), TEPOCH(2) + + ! 4.2 Output fields + FLDOUT = NML_FIELD%LIST + CALL W3FLGRDFLAG ( NDSO, SCREEN, NDSE, FLDOUT, FLG1D, & + FLG2D, 1, 1, IERR ) + IF (IERR.NE.0) GOTO 800 + + ! 4.3 Output type + NCTYPE = NML_FILE%NETCDF + NCVARTYPE = NML_FIELD%TYPE + STRINGIPART = NML_FIELD%PARTITION + TOGETHER = NML_FIELD%SAMEFILE + VECTOR = NML_FIELD%VECTOR + FILEPREFIX = NML_FILE%PREFIX + FLGFC = NML_FIELD%FCVARS + S3 = NML_FIELD%TIMESPLIT + TTYPE = NML_FIELD%TIMEVAR + TIMEUNIT = NML_FIELD%TIMEUNIT + NOVAL = NML_FIELD%NOVAL + MAPSTAOUT = NML_FIELD%MAPSTA + IF(SMCGRD) THEN #ifdef W3_SMC - SMCOTYPE = NML_SMC%TYPE - SXO = NML_SMC%SXO - SYO = NML_SMC%SYO - EXO = NML_SMC%EXO - EYO = NML_SMC%EYO - CELFAC = NML_SMC%CELFAC - SMCNOVAL = NOVAL + SMCOTYPE = NML_SMC%TYPE + SXO = NML_SMC%SXO + SYO = NML_SMC%SYO + EXO = NML_SMC%EXO + EYO = NML_SMC%EYO + CELFAC = NML_SMC%CELFAC + SMCNOVAL = NOVAL #endif - ELSE - IX1 = NML_FILE%IX0 - IXN = NML_FILE%IXN - IY1 = NML_FILE%IY0 - IYN = NML_FILE%IYN - ENDIF ! SMCGRD - END IF ! FLGNML -! -! process old ww3_ounf.inp format -! - IF (.NOT. FLGNML) THEN - OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_ounf.inp',STATUS='OLD',ERR=800,IOSTAT=IERR) - REWIND (NDSI) - - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - -! 4.1 Time setup - READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT - -! 4.1.1 Forecast period and forecast reference time -! CALL NEXTLN ( COMSTR , NDSI , NDSE ) -! READ (NDSI,*,END=801,ERR=802) FLGFC -! IF( FLGFC ) READ(NDSI,*,END=801,ERR=802) TREF -! - ! ChrisB: Forecast variables flag and reference time - ! only configurable via namelist input. Set forecast - ! reference time to first time here: - TREF = TOUT - -! 4.2 Output fields - CALL W3READFLGRD ( NDSI, NDSO, SCREEN, NDSE, COMSTR, FLG1D, & - FLG2D, 1, 1, IERR ) - IF (IERR.NE.0) GOTO 800 - -! 4.3 Output type - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) NCTYPE, NCVARTYPE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,'(A)',END=801,ERR=802) STRINGIPART - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) TOGETHER - -! The following are only configurable via the namelist input -! and are hardcoded for .inp files: - TTYPE = "D" - TIMEUNIT = "D" - NOVAL = UNDEF - VECTOR = .TRUE. - - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - FILEPREFIX= 'ww3.' - READ (NDSI,*,END=801,ERR=802) FILEPREFIX + ELSE + IX1 = NML_FILE%IX0 + IXN = NML_FILE%IXN + IY1 = NML_FILE%IY0 + IYN = NML_FILE%IYN + ENDIF ! SMCGRD + END IF ! FLGNML + ! + ! process old ww3_ounf.inp format + ! + IF (.NOT. FLGNML) THEN + OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_ounf.inp',STATUS='OLD',ERR=800,IOSTAT=IERR) + REWIND (NDSI) + + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + + ! 4.1 Time setup + READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT + + ! 4.1.1 Forecast period and forecast reference time + ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ! READ (NDSI,*,END=801,ERR=802) FLGFC + ! IF( FLGFC ) READ(NDSI,*,END=801,ERR=802) TREF + ! + ! ChrisB: Forecast variables flag and reference time + ! only configurable via namelist input. Set forecast + ! reference time to first time here: + TREF = TOUT + + ! 4.2 Output fields + CALL W3READFLGRD ( NDSI, NDSO, SCREEN, NDSE, COMSTR, FLG1D, & + FLG2D, 1, 1, IERR ) + IF (IERR.NE.0) GOTO 800 + + ! 4.3 Output type + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) NCTYPE, NCVARTYPE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,'(A)',END=801,ERR=802) STRINGIPART + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) TOGETHER + + ! The following are only configurable via the namelist input + ! and are hardcoded for .inp files: + TTYPE = "D" + TIMEUNIT = "D" + NOVAL = UNDEF + VECTOR = .TRUE. + + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + FILEPREFIX= 'ww3.' + READ (NDSI,*,END=801,ERR=802) FILEPREFIX + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) S3 + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + + IF(SMCGRD) THEN +#ifdef W3_SMC + ! SMC output type (1 or 2) + READ (NDSI,*,END=801,ERR=802) SMCOTYPE + IF(SMCOTYPE .EQ. 1) THEN ! Flat sea point output CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) S3 + READ (NDSI,*,END=801,ERR=802) SXO, SYO, EXO, EYO + ELSE IF(SMCOTYPE .EQ. 2) THEN ! Regular grid output CALL NEXTLN ( COMSTR , NDSI , NDSE ) - - IF(SMCGRD) THEN -#ifdef W3_SMC - ! SMC output type (1 or 2) - READ (NDSI,*,END=801,ERR=802) SMCOTYPE - IF(SMCOTYPE .EQ. 1) THEN ! Flat sea point output - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) SXO, SYO, EXO, EYO - ELSE IF(SMCOTYPE .EQ. 2) THEN ! Regular grid output - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) SXO, SYO, EXO, EYO, CELFAC - ENDIF - SMCNOVAL = NOVAL -#endif - ELSE - READ (NDSI,*,END=801,ERR=802) IX1, IXN, IY1, IYN - ENDIF - - CLOSE(NDSI,ERR=800,IOSTAT=IERR) - END IF ! .NOT. FLGNML - - CALL STR_TO_UPPER(TTYPE) - CALL STR_TO_UPPER(TIMEUNIT) - - IF(TIMEUNIT /= 'S' .AND. TIMEUNIT /= 'D') THEN - WRITE(NDSE, 1013) TIMEUNIT - CALL EXTCDE(14) - ENDIF - - SELECT CASE(TTYPE) - CASE('D') - TVARTYPE = NF90_DOUBLE - CASE('I') - TVARTYPE = NF90_INT64 - CASE DEFAULT - WRITE(NDSE, 1014) TTYPE - CALL EXTCDE(14) - END SELECT - - IF(TTYPE .EQ. 'I' .AND. TIMEUNIT .EQ. 'D') THEN - WRITE(NDSE, 1015) - CALL EXTCDE(14) - ENDIF - - ! If TVARTPE is INT64 check that we are using netCDF4: - IF(TVARTYPE .EQ. NF90_INT64 .AND. NCTYPE .LT. 4) THEN - WRITE(NDSE, 1016) - CALL EXTCDE(14) - ENDIF - - ! Keep track of original NCVARTYPE, as it may change - NCVARTYPEI = NCVARTYPE - - ! Get forecast reference time from TREF - CALL T2D(TREF, REFDATE, IERR) -! - -! 4.1 Time setup - DTREQ = MAX ( 0. , DTREQ ) - IF ( DTREQ.EQ.0. ) NOUT = 1 - NOUT = MAX ( 1 , NOUT ) - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,940) IDTIME - TDUM = 0 - CALL TICK21 ( TDUM , DTREQ ) - CALL STME21 ( TDUM , IDTIME ) - IF ( DTREQ .GE. 86400. ) THEN - WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) - ELSE - IDDDAY = ' ' - END IF - IDTIME(1:11) = IDDDAY - IDTIME(21:23) = ' ' - WRITE (NDSO,941) IDTIME, NOUT - - IF(FLGFC) THEN - CALL STME21 ( TREF , IDTIME ) - WRITE(NDSO,942) IDTIME + READ (NDSI,*,END=801,ERR=802) SXO, SYO, EXO, EYO, CELFAC ENDIF - -! 4.2 Output fields - DO IFI=1, NOGRP - DO IFJ=1, NGRPP - IF ( FLG2D(IFI,IFJ) ) THEN - IF ( FLOGRD(IFI,IFJ) ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ), ' ' - ELSE - WRITE (NDSO,946) IDOUT(IFI,IFJ), '*** NOT AVAILABLE ***' - FLG2D(IFI,IFJ) = .FALSE. - END IF - END IF - END DO - END DO - - -! 4.3 Output type - ALLOCATE(TABIPART(NOSWLL + 1)) - ALLOCATE(NCIDS(NOGRP,NGRPP,NOSWLL + 1)) - NBIPART=0 - DO I=1,30 - IF(STRINGIPART(I:I) .EQ. ' ') CYCLE - READ(STRINGIPART(I:I),'(I1)') IPART - IF(IPART .GT. NOSWLL) THEN - WRITE(NDSO, 1500) IPART, NOSWLL - CYCLE - ENDIF - NBIPART = NBIPART + 1 - IF(NBIPART .GT. NOSWLL + 1) THEN - GOTO 803 - ENDIF - TABIPART(NBIPART) = IPART - ENDDO -! - IF ( NCTYPE.LT.3 .OR. NCTYPE.GT.4 ) THEN - WRITE (NDSE,1010) NCTYPE - CALL EXTCDE ( 1 ) + SMCNOVAL = NOVAL +#endif + ELSE + READ (NDSI,*,END=801,ERR=802) IX1, IXN, IY1, IYN + ENDIF + + CLOSE(NDSI,ERR=800,IOSTAT=IERR) + END IF ! .NOT. FLGNML + + CALL STR_TO_UPPER(TTYPE) + CALL STR_TO_UPPER(TIMEUNIT) + + IF(TIMEUNIT /= 'S' .AND. TIMEUNIT /= 'D') THEN + WRITE(NDSE, 1013) TIMEUNIT + CALL EXTCDE(14) + ENDIF + + SELECT CASE(TTYPE) + CASE('D') + TVARTYPE = NF90_DOUBLE + CASE('I') + TVARTYPE = NF90_INT64 + CASE DEFAULT + WRITE(NDSE, 1014) TTYPE + CALL EXTCDE(14) + END SELECT + + IF(TTYPE .EQ. 'I' .AND. TIMEUNIT .EQ. 'D') THEN + WRITE(NDSE, 1015) + CALL EXTCDE(14) + ENDIF + + ! If TVARTPE is INT64 check that we are using netCDF4: + IF(TVARTYPE .EQ. NF90_INT64 .AND. NCTYPE .LT. 4) THEN + WRITE(NDSE, 1016) + CALL EXTCDE(14) + ENDIF + + ! Keep track of original NCVARTYPE, as it may change + NCVARTYPEI = NCVARTYPE + + ! Get forecast reference time from TREF + CALL T2D(TREF, REFDATE, IERR) + ! + + ! 4.1 Time setup + DTREQ = MAX ( 0. , DTREQ ) + IF ( DTREQ.EQ.0. ) NOUT = 1 + NOUT = MAX ( 1 , NOUT ) + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,940) IDTIME + TDUM = 0 + CALL TICK21 ( TDUM , DTREQ ) + CALL STME21 ( TDUM , IDTIME ) + IF ( DTREQ .GE. 86400. ) THEN + WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) + ELSE + IDDDAY = ' ' + END IF + IDTIME(1:11) = IDDDAY + IDTIME(21:23) = ' ' + WRITE (NDSO,941) IDTIME, NOUT + + IF(FLGFC) THEN + CALL STME21 ( TREF , IDTIME ) + WRITE(NDSO,942) IDTIME + ENDIF + + ! 4.2 Output fields + DO IFI=1, NOGRP + DO IFJ=1, NGRPP + IF ( FLG2D(IFI,IFJ) ) THEN + IF ( FLOGRD(IFI,IFJ) ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ), ' ' + ELSE + WRITE (NDSO,946) IDOUT(IFI,IFJ), '*** NOT AVAILABLE ***' + FLG2D(IFI,IFJ) = .FALSE. + END IF END IF - - IF(SMCGRD) THEN + END DO + END DO + + + ! 4.3 Output type + ALLOCATE(TABIPART(NOSWLL + 1)) + ALLOCATE(NCIDS(NOGRP,NGRPP,NOSWLL + 1)) + NBIPART=0 + DO I=1,30 + IF(STRINGIPART(I:I) .EQ. ' ') CYCLE + READ(STRINGIPART(I:I),'(I1)') IPART + IF(IPART .GT. NOSWLL) THEN + WRITE(NDSO, 1500) IPART, NOSWLL + CYCLE + ENDIF + NBIPART = NBIPART + 1 + IF(NBIPART .GT. NOSWLL + 1) THEN + GOTO 803 + ENDIF + TABIPART(NBIPART) = IPART + ENDDO + ! + IF ( NCTYPE.LT.3 .OR. NCTYPE.GT.4 ) THEN + WRITE (NDSE,1010) NCTYPE + CALL EXTCDE ( 1 ) + END IF + + IF(SMCGRD) THEN #ifdef W3_SMC - WRITE(NDSO, 4100) - IF(SMCOTYPE .EQ. 1) THEN ! Flat sea point output - ALLOCATE(SMCMASK(NSEA)) - ALLOCATE(SMCIDX(NSEA)) - SMCMASK(:) = .FALSE. - CALL SMC_INTERP() - SMCNOUT = COUNT(SMCMASK) - NXO = SMCNOUT - NYO = 1 - WRITE(NDSO, 4120) SMCNOUT - ELSE IF(SMCOTYPE .EQ. 2) THEN ! Regular grid output - ! Calculate regridding weights: - ALLOCATE(XIDX(NSEA), YIDX(NSEA), XSPAN(NSEA), & - YSPAN(NSEA), WTS(NSEA), SMCIDX(NSEA)) - CALL SMC_INTERP() - WRITE(NDSO, 4110) NXO, NYO, SXO, SYO, DXO, DYO - - ! Allocate space for coverage array and new MAPSTA array - ALLOCATE(COV(NXO,NYO), MAPSMC(NXO,NYO)) - ELSE IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) THEN ! Nearest neighbour interpolation - CALL READ_SMCINT() - ENDIF - - ! CB: IXN and IXY are calculated by SMC_INTERP for SMC GRID - IX1 = 1 - IXN = NXO - IY1 = 1 - IYN = NYO - - ! Also store NXO and NYO in __local__ RTDNX and RTDNY variables. - ! This avoids compilation errors when the RTD switch is enabled - ! but the SMC switch is not. TODO: Remove this when C-preprocessor - ! is used in preference to switches. - RTDNX = NXO - RTDNY = NYO + WRITE(NDSO, 4100) + IF(SMCOTYPE .EQ. 1) THEN ! Flat sea point output + ALLOCATE(SMCMASK(NSEA)) + ALLOCATE(SMCIDX(NSEA)) + SMCMASK(:) = .FALSE. + CALL SMC_INTERP() + SMCNOUT = COUNT(SMCMASK) + NXO = SMCNOUT + NYO = 1 + WRITE(NDSO, 4120) SMCNOUT + ELSE IF(SMCOTYPE .EQ. 2) THEN ! Regular grid output + ! Calculate regridding weights: + ALLOCATE(XIDX(NSEA), YIDX(NSEA), XSPAN(NSEA), & + YSPAN(NSEA), WTS(NSEA), SMCIDX(NSEA)) + CALL SMC_INTERP() + WRITE(NDSO, 4110) NXO, NYO, SXO, SYO, DXO, DYO + + ! Allocate space for coverage array and new MAPSTA array + ALLOCATE(COV(NXO,NYO), MAPSMC(NXO,NYO)) + ELSE IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) THEN ! Nearest neighbour interpolation + CALL READ_SMCINT() + ENDIF + + ! CB: IXN and IXY are calculated by SMC_INTERP for SMC GRID + IX1 = 1 + IXN = NXO + IY1 = 1 + IYN = NYO + + ! Also store NXO and NYO in __local__ RTDNX and RTDNY variables. + ! This avoids compilation errors when the RTD switch is enabled + ! but the SMC switch is not. TODO: Remove this when C-preprocessor + ! is used in preference to switches. + RTDNX = NXO + RTDNY = NYO #ifdef W3_RTD - ! SMC type 3/4 outputs are currently on standard pole grid only - IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) RTDL = .FALSE. + ! SMC type 3/4 outputs are currently on standard pole grid only + IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) RTDL = .FALSE. #endif #endif - ELSE - IX1 = MAX ( IX1 , 1 ) - IXN = MIN ( IXN , NX ) - IY1 = MAX ( IY1 , 1 ) - IYN = MIN ( IYN , NY ) - WRITE (NDSO,3940) IX1, IXN, IY1, IYN - ENDIF ! SMCGRD -! -! 4.4 Initialise meta-data - CALL INIT_META(VECTOR) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Time management. -! - IOUT = 0 - NCIDS(:,:,:) = 0 - WRITE (NDSO,970) - -! 5.1 Loops on out_grd.ww3 to read the time and data - DO - DTEST = DSEC21 ( TIME , TOUT ) - IF ( DTEST .GT. 0. ) THEN - CALL W3IOGO ( 'READ', NDSOG, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - WRITE (NDSO,944) - EXIT - END IF - CYCLE - END IF - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF + ELSE + IX1 = MAX ( IX1 , 1 ) + IXN = MIN ( IXN , NX ) + IY1 = MAX ( IY1 , 1 ) + IYN = MIN ( IYN , NY ) + WRITE (NDSO,3940) IX1, IXN, IY1, IYN + ENDIF ! SMCGRD + ! + ! 4.4 Initialise meta-data + CALL INIT_META(VECTOR) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Time management. + ! + IOUT = 0 + NCIDS(:,:,:) = 0 + WRITE (NDSO,970) + + ! 5.1 Loops on out_grd.ww3 to read the time and data + DO + DTEST = DSEC21 ( TIME , TOUT ) + IF ( DTEST .GT. 0. ) THEN + CALL W3IOGO ( 'READ', NDSOG, IOTEST ) + IF ( IOTEST .EQ. -1 ) THEN + WRITE (NDSO,944) + EXIT + END IF + CYCLE + END IF + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF -! 5.1.1 Increments the time counter IOUT - IOUT = IOUT + 1 - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,971) IDTIME + ! 5.1.1 Increments the time counter IOUT + IOUT = IOUT + 1 + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,971) IDTIME -! 5.1.2 Processes the variable value for the time step IOUT - CALL W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, FILEPREFIX, & - E3DF, P2MSF, US3DF, USSPF, NCTYPE, TOGETHER, NCVARTYPEI,& - FLG2D, NCIDS, S3, STRSTOPDATE ) + ! 5.1.2 Processes the variable value for the time step IOUT + CALL W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, FILEPREFIX, & + E3DF, P2MSF, US3DF, USSPF, NCTYPE, TOGETHER, NCVARTYPEI,& + FLG2D, NCIDS, S3, STRSTOPDATE ) -! 5.1.3 Defines the stop date - CALL T2D(TOUT,STOPDATE,IERR) - WRITE(STRSTOPDATE,'(I4.4,A,4(I2.2,A),I2.2)') STOPDATE(1),'-',STOPDATE(2), & - '-',STOPDATE(3),' ',STOPDATE(5),':',STOPDATE(6),':',STOPDATE(7) + ! 5.1.3 Defines the stop date + CALL T2D(TOUT,STOPDATE,IERR) + WRITE(STRSTOPDATE,'(I4.4,A,4(I2.2,A),I2.2)') STOPDATE(1),'-',STOPDATE(2), & + '-',STOPDATE(3),' ',STOPDATE(5),':',STOPDATE(6),':',STOPDATE(7) - CALL TICK21 ( TOUT , DTREQ ) - IF ( IOUT .GE. NOUT ) EXIT - END DO + CALL TICK21 ( TOUT , DTREQ ) + IF ( IOUT .GE. NOUT ) EXIT + END DO - CALL TEARDOWN_META() + CALL TEARDOWN_META() -! 5.2 Closes the netCDF file - IF (TOGETHER .AND. NCIDS(1,1,1).NE.0) THEN - IRET = NF90_REDEF(NCIDS(1,1,1)) - CALL CHECK_ERR(IRET) - IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(NCIDS(1,1,1),NF90_GLOBAL,'stop_date',STRSTOPDATE) - CALL CHECK_ERR(IRET) - ENDIF - IRET=NF90_CLOSE(NCIDS(1,1,1)) - CALL CHECK_ERR(IRET) - END IF -! - DO IFI=1, NOGRP - DO IFJ=1, NGRPP - IF ( FLG2D(IFI,IFJ) ) THEN - IF ( FLOGRD(IFI,IFJ) ) THEN - IF (.NOT. TOGETHER) THEN - IF (NCIDS(IFI,IFJ,1).NE.0) THEN - IRET = NF90_REDEF(NCIDS(IFI,IFJ,1)) + ! 5.2 Closes the netCDF file + IF (TOGETHER .AND. NCIDS(1,1,1).NE.0) THEN + IRET = NF90_REDEF(NCIDS(1,1,1)) + CALL CHECK_ERR(IRET) + IF(FL_DEFAULT_GBL_META) THEN + IRET=NF90_PUT_ATT(NCIDS(1,1,1),NF90_GLOBAL,'stop_date',STRSTOPDATE) + CALL CHECK_ERR(IRET) + ENDIF + IRET=NF90_CLOSE(NCIDS(1,1,1)) + CALL CHECK_ERR(IRET) + END IF + ! + DO IFI=1, NOGRP + DO IFJ=1, NGRPP + IF ( FLG2D(IFI,IFJ) ) THEN + IF ( FLOGRD(IFI,IFJ) ) THEN + IF (.NOT. TOGETHER) THEN + IF (NCIDS(IFI,IFJ,1).NE.0) THEN + IRET = NF90_REDEF(NCIDS(IFI,IFJ,1)) + CALL CHECK_ERR(IRET) + IF(FL_DEFAULT_GBL_META) THEN + IRET=NF90_PUT_ATT(NCIDS(IFI,IFJ,1),NF90_GLOBAL,'stop_date',STRSTOPDATE) + CALL CHECK_ERR(IRET) + ENDIF + IRET=NF90_CLOSE(NCIDS(IFI,IFJ,1)) + CALL CHECK_ERR(IRET) + END IF ! NCIDS + ! close partition files (except part 0 which is already closed by (IFI,IFJ,1) + IF ((IFI.EQ.4).AND.(IFJ.LE.NOGE(IFI))) THEN + DO IPART=1,NOSWLL + IF (NCIDS(IFI,IFJ,IPART+1).NE.0) THEN + IRET = NF90_REDEF(NCIDS(IFI,IFJ,IPART+1)) CALL CHECK_ERR(IRET) IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(NCIDS(IFI,IFJ,1),NF90_GLOBAL,'stop_date',STRSTOPDATE) + IRET=NF90_PUT_ATT(NCIDS(IFI,IFJ,IPART+1),NF90_GLOBAL,'stop_date',STRSTOPDATE) CALL CHECK_ERR(IRET) ENDIF - IRET=NF90_CLOSE(NCIDS(IFI,IFJ,1)) + IRET=NF90_CLOSE(NCIDS(IFI,IFJ,IPART+1)) CALL CHECK_ERR(IRET) END IF ! NCIDS - ! close partition files (except part 0 which is already closed by (IFI,IFJ,1) - IF ((IFI.EQ.4).AND.(IFJ.LE.NOGE(IFI))) THEN - DO IPART=1,NOSWLL - IF (NCIDS(IFI,IFJ,IPART+1).NE.0) THEN - IRET = NF90_REDEF(NCIDS(IFI,IFJ,IPART+1)) - CALL CHECK_ERR(IRET) - IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(NCIDS(IFI,IFJ,IPART+1),NF90_GLOBAL,'stop_date',STRSTOPDATE) - CALL CHECK_ERR(IRET) - ENDIF - IRET=NF90_CLOSE(NCIDS(IFI,IFJ,IPART+1)) - CALL CHECK_ERR(IRET) - END IF ! NCIDS - END DO ! IPART - END IF ! partition - ! else if together - ELSE - ! close frequency file - IF ( ((IFI.EQ.6).AND.(IFJ.EQ.8)) .OR. & - ((IFI.EQ.6).AND.(IFJ.EQ.9)) .OR. & - (IFI.EQ.3) ) THEN - IF (NCIDS(IFI,IFJ,1).NE.0) THEN - IRET = NF90_REDEF(NCIDS(IFI,IFJ,1)) - CALL CHECK_ERR(IRET) - IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(NCIDS(IFI,IFJ,1),NF90_GLOBAL,'stop_date',STRSTOPDATE) - CALL CHECK_ERR(IRET) - ENDIF - IRET=NF90_CLOSE(NCIDS(IFI,IFJ,1)) - CALL CHECK_ERR(IRET) - END IF ! NCIDS - END IF ! IFI - END IF ! TOGETHER - END IF ! FLOGRD - END IF ! FLG2D - END DO ! IFJ - END DO ! IFI - -! - GOTO 888 -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 10 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 11 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 12 ) -! - 803 CONTINUE - WRITE (NDSE,1003) NBIPART, NOSWLL - CALL EXTCDE (13) -! - 888 CONTINUE - WRITE (NDSO,999) -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Field output postp. *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) -! - 920 FORMAT ( ' Grid name : ',A/) -! - 930 FORMAT ( ' Fields in file : '/ & - ' --------------------------') - 931 FORMAT ( ' ',A) -! - 940 FORMAT (/' Output time data : '/ & - ' --------------------------------------------------'/ & - ' First time : ',A) - 941 FORMAT ( ' Interval : ',A/ & - ' Number of requests : ',I10) - 942 FORMAT ( ' Reference time : ',A) - 944 FORMAT (/' End of file reached '/) - 946 FORMAT ( ' ',A,2X,A) -! - 3940 FORMAT ( ' X range : ',2I7/ & - ' Y range : ',2I7) -! + END DO ! IPART + END IF ! partition + ! else if together + ELSE + ! close frequency file + IF ( ((IFI.EQ.6).AND.(IFJ.EQ.8)) .OR. & + ((IFI.EQ.6).AND.(IFJ.EQ.9)) .OR. & + (IFI.EQ.3) ) THEN + IF (NCIDS(IFI,IFJ,1).NE.0) THEN + IRET = NF90_REDEF(NCIDS(IFI,IFJ,1)) + CALL CHECK_ERR(IRET) + IF(FL_DEFAULT_GBL_META) THEN + IRET=NF90_PUT_ATT(NCIDS(IFI,IFJ,1),NF90_GLOBAL,'stop_date',STRSTOPDATE) + CALL CHECK_ERR(IRET) + ENDIF + IRET=NF90_CLOSE(NCIDS(IFI,IFJ,1)) + CALL CHECK_ERR(IRET) + END IF ! NCIDS + END IF ! IFI + END IF ! TOGETHER + END IF ! FLOGRD + END IF ! FLG2D + END DO ! IFJ + END DO ! IFI + + ! + GOTO 888 + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 10 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 11 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 12 ) + ! +803 CONTINUE + WRITE (NDSE,1003) NBIPART, NOSWLL + CALL EXTCDE (13) + ! +888 CONTINUE + WRITE (NDSO,999) + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Field output postp. *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) + ! +920 FORMAT ( ' Grid name : ',A/) + ! +930 FORMAT ( ' Fields in file : '/ & + ' --------------------------') +931 FORMAT ( ' ',A) + ! +940 FORMAT (/' Output time data : '/ & + ' --------------------------------------------------'/ & + ' First time : ',A) +941 FORMAT ( ' Interval : ',A/ & + ' Number of requests : ',I10) +942 FORMAT ( ' Reference time : ',A) +944 FORMAT (/' End of file reached '/) +946 FORMAT ( ' ',A,2X,A) + ! +3940 FORMAT ( ' X range : ',2I7/ & + ' Y range : ',2I7) + ! #ifdef W3_SMC - 4100 FORMAT (//' SMC grid output :' / & -! - ' --------------------------------------------------') - 4110 FORMAT ( ' SMC to regular lat/lon grid using cell averaging' /& - ' Aligned output grid definition: ' / & - ' NX, NY : ', 2I8 / & - ' X0, Y0 : ', 2F8.3 / & - ' DX, DY : ', 2F8.5 ) - 4120 FORMAT ( ' Flat seapoint dimensioned SMC output file' / & - ' Num seapoints : ',I9 ) -! - 4130 FORMAT ( ' SMC regridding to regular lat/lon grid.' / & - ' Output grid definition: ' / & - ' NX, NY : ', 2I8 / & - ' X0, Y0 : ', 2F8.3 / & - ' DX, DY : ', 2F8.5 / & - ' Interpolate ? : ', L ) +4100 FORMAT (//' SMC grid output :' / & + ' --------------------------------------------------') +4110 FORMAT ( ' SMC to regular lat/lon grid using cell averaging' /& + ' Aligned output grid definition: ' / & + ' NX, NY : ', 2I8 / & + ' X0, Y0 : ', 2F8.3 / & + ' DX, DY : ', 2F8.5 ) +4120 FORMAT ( ' Flat seapoint dimensioned SMC output file' / & + ' Num seapoints : ',I9 ) + ! +4130 FORMAT ( ' SMC regridding to regular lat/lon grid.' / & + ' Output grid definition: ' / & + ' NX, NY : ', 2I8 / & + ' X0, Y0 : ', 2F8.3 / & + ' DX, DY : ', 2F8.5 / & + ' Interpolate ? : ', L ) #endif -! - 970 FORMAT (/' Generating files '/ & - ' --------------------------------------------------') - 971 FORMAT ( ' Files for ',A) -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Field output '/) -! -! Error format strings -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH III WERROR IN W3OUNF : '/ & - ' OUT OF RANGE REQUEST FOR NBIPART =',I2, / & - ' MAX SWELL PARTITIONS (NOSW) =',I2 /) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & - ' ILLEGAL TYPE, NCTYPE =',I4/) -! - 1013 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & - ' TIMEUNITS MUST BE ONE OF "S" OR "D"' / & - ' GOT: ',A /) -! - 1014 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & - ' TIMEVAR TYPE MUST BE ONE OF "I" OR "D"' / & - ' GOT: ',A /) -! - 1015 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & - ' CANNONT HAVE TIME UNITS OF DAYS WITH'/ & - ' TIME VARYTPE OF INT64' /) -! - 1016 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & - ' INT64 TIME ENCODING REQUIRES NETCDF4' / & - ' FILE FORMAT' /) -! -! Warning format strings -! - 1500 FORMAT (/' *** WAVEWATCH III WARNING IN W3OUNF : '/ & - ' IGNORING REQUEST FOR IPART =',I2, / & - ' MAX SWELL PARTITIONS (NOSW) =',I2 /) -! -!/ -!/ Internal subroutine W3EXNC ---------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> @brief Perform actual grid output in NetCDF file. -!> -!> @param[in] NX Grid dimension X -!> @param[in] NY Grid dimension Y -!> @param[in] IX1 Grid index along X -!> @param[in] IXN Grid index along X -!> @param[in] IY1 Grid index along Y -!> @param[in] IYN Grid index along Y -!> @param[in] NSEA Number of sea points -!> @param[inout] FILEPREFIX -!> @param[in] E3DF -!> @param[in] P2MSF -!> @param[in] US3DF -!> @param[in] USSPF -!> @param[in] NCTYPE -!> @param[in] TOGETHER -!> @param[in] NCVARTYPEI -!> @param[in] FLG2D -!> @param[inout] NCIDS -!> @param[inout] S3 -!> @param[in] STRSTOPDATE -!> @author F. Ardhuin -!> @author M. Accensi -!> @date 22-Mar-2021 -!> - SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & - FILEPREFIX, E3DF, P2MSF, US3DF, USSPF,NCTYPE, & - TOGETHER, NCVARTYPEI, FLG2D, NCIDS, S3, STRSTOPDATE ) -!/ -!/ +-----------------------------------+ -!/ | F. Ardhuin | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-2010 : Creation ( version 3.14_SHOM ) -!/ 28-Feb-2013 : New option for float output ( version 4.08 ) -!/ 02-Apr-2013 : New structure of output fields. ( version 4.09 ) -!/ 12-Apr-2013 : Allows curvilinear grids ( version 4.10 ) -!/ 30-Apr-2014 : Correct group3 freq dim. ( version 5.00 ) -!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) -!/ 14-Oct-2014 : Keep the output files opened ( version 5.01 ) -!/ 03-Nov-2020 : NetCDF metadata moved to separate ( version 7.12 ) -!/ module. -!/ 09-Dec-2020 : Set fixed values for VARID indices ( version 7.12 ) -!/ 26-Jan-2021 : Added TP output (derived from fp) ( version 7.12 ) -!/ and alternative dir/mag output. -!/ 02-Feb-2021 : Make default global meta optional ( version 7.12 ) -!/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) -!/ -! 1. Purpose : -! -! Perform actual grid output in NetCDF file. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NX/Y Int. I Grid dimensions. -! IX1/IXN Int. I Grid indexes along X -! IY1/IYN Int. I Grid indexes along Y -! NSEA Int. I Number of sea points. -! ---------------------------------------------------------------- -! -! Internal parameters -! ---------------------------------------------------------------- -! FLTWO Log. Flags for two-dimensional field X Y. -! FLDIR Log. Flags for two-dimensional, directional field. -! FLFRQ Log. Flags for frequency array (3D field) -! X1, X2, XX, XY -! R.A. Output fields -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Abort program as graceful as possible. -! W3S2XY Subr. Id. Convert from storage to spatial grid. -! PRTBLK Subr. W3ARRYMD Print plot of array. -! OUTA2I Subr. Id. Print array of INTEGERS. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Main program in which it is contained. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Note that arrays CX and CY of the main program now contain -! the absolute current speed and direction respectively. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY : W3S2XY, UV_TO_MAG_DIR + ! +970 FORMAT (/' Generating files '/ & + ' --------------------------------------------------') +971 FORMAT ( ' Files for ',A) + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Field output '/) + ! + ! Error format strings + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1003 FORMAT (/' *** WAVEWATCH III WERROR IN W3OUNF : '/ & + ' OUT OF RANGE REQUEST FOR NBIPART =',I2, / & + ' MAX SWELL PARTITIONS (NOSW) =',I2 /) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & + ' ILLEGAL TYPE, NCTYPE =',I4/) + ! +1013 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & + ' TIMEUNITS MUST BE ONE OF "S" OR "D"' / & + ' GOT: ',A /) + ! +1014 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & + ' TIMEVAR TYPE MUST BE ONE OF "I" OR "D"' / & + ' GOT: ',A /) + ! +1015 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & + ' CANNONT HAVE TIME UNITS OF DAYS WITH'/ & + ' TIME VARYTPE OF INT64' /) + ! +1016 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNF : '/ & + ' INT64 TIME ENCODING REQUIRES NETCDF4' / & + ' FILE FORMAT' /) + ! + ! Warning format strings + ! +1500 FORMAT (/' *** WAVEWATCH III WARNING IN W3OUNF : '/ & + ' IGNORING REQUEST FOR IPART =',I2, / & + ' MAX SWELL PARTITIONS (NOSW) =',I2 /) + ! + !/ + !/ Internal subroutine W3EXNC ---------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> @brief Perform actual grid output in NetCDF file. + !> + !> @param[in] NX Grid dimension X + !> @param[in] NY Grid dimension Y + !> @param[in] IX1 Grid index along X + !> @param[in] IXN Grid index along X + !> @param[in] IY1 Grid index along Y + !> @param[in] IYN Grid index along Y + !> @param[in] NSEA Number of sea points + !> @param[inout] FILEPREFIX + !> @param[in] E3DF + !> @param[in] P2MSF + !> @param[in] US3DF + !> @param[in] USSPF + !> @param[in] NCTYPE + !> @param[in] TOGETHER + !> @param[in] NCVARTYPEI + !> @param[in] FLG2D + !> @param[inout] NCIDS + !> @param[inout] S3 + !> @param[in] STRSTOPDATE + !> @author F. Ardhuin + !> @author M. Accensi + !> @date 22-Mar-2021 + !> + SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & + FILEPREFIX, E3DF, P2MSF, US3DF, USSPF,NCTYPE, & + TOGETHER, NCVARTYPEI, FLG2D, NCIDS, S3, STRSTOPDATE ) + !/ + !/ +-----------------------------------+ + !/ | F. Ardhuin | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 17-Mar-2010 : Creation ( version 3.14_SHOM ) + !/ 28-Feb-2013 : New option for float output ( version 4.08 ) + !/ 02-Apr-2013 : New structure of output fields. ( version 4.09 ) + !/ 12-Apr-2013 : Allows curvilinear grids ( version 4.10 ) + !/ 30-Apr-2014 : Correct group3 freq dim. ( version 5.00 ) + !/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) + !/ 14-Oct-2014 : Keep the output files opened ( version 5.01 ) + !/ 03-Nov-2020 : NetCDF metadata moved to separate ( version 7.12 ) + !/ module. + !/ 09-Dec-2020 : Set fixed values for VARID indices ( version 7.12 ) + !/ 26-Jan-2021 : Added TP output (derived from fp) ( version 7.12 ) + !/ and alternative dir/mag output. + !/ 02-Feb-2021 : Make default global meta optional ( version 7.12 ) + !/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Perform actual grid output in NetCDF file. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NX/Y Int. I Grid dimensions. + ! IX1/IXN Int. I Grid indexes along X + ! IY1/IYN Int. I Grid indexes along Y + ! NSEA Int. I Number of sea points. + ! ---------------------------------------------------------------- + ! + ! Internal parameters + ! ---------------------------------------------------------------- + ! FLTWO Log. Flags for two-dimensional field X Y. + ! FLDIR Log. Flags for two-dimensional, directional field. + ! FLFRQ Log. Flags for frequency array (3D field) + ! X1, X2, XX, XY + ! R.A. Output fields + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! W3S2XY Subr. Id. Convert from storage to spatial grid. + ! PRTBLK Subr. W3ARRYMD Print plot of array. + ! OUTA2I Subr. Id. Print array of INTEGERS. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Main program in which it is contained. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Note that arrays CX and CY of the main program now contain + ! the absolute current speed and direction respectively. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY : W3S2XY, UV_TO_MAG_DIR #ifdef W3_RTD - USE W3SERVMD, ONLY : W3THRTN, W3XYRTN, W3EQTOLL + USE W3SERVMD, ONLY : W3THRTN, W3XYRTN, W3EQTOLL #endif - USE W3ARRYMD, ONLY : OUTA2I, PRTBLK - USE W3GDATMD, ONLY : SIG, GTYPE, FLAGLL, MAPSTA, MAPST2 - USE W3GDATMD, ONLY : NK, UNGTYPE, MAPSF, NTRI, CLGTYPE, RLGTYPE, & - XGRD, YGRD, SX, SY, X0, Y0, TRIGP, USSP_WN + USE W3ARRYMD, ONLY : OUTA2I, PRTBLK + USE W3GDATMD, ONLY : SIG, GTYPE, FLAGLL, MAPSTA, MAPST2 + USE W3GDATMD, ONLY : NK, UNGTYPE, MAPSF, NTRI, CLGTYPE, RLGTYPE, & + XGRD, YGRD, SX, SY, X0, Y0, TRIGP, USSP_WN #ifdef W3_RTD - ! Rotated pole data from the mod_def file - USE W3GDATMD, ONLY : POLAT, POLON, FLAGUNR, AnglD + ! Rotated pole data from the mod_def file + USE W3GDATMD, ONLY : POLAT, POLON, FLAGUNR, AnglD #endif #ifdef W3_T - USE W3ODATMD, ONLY : NDST + USE W3ODATMD, ONLY : NDST #endif - USE NETCDF - IMPLICIT NONE - -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NX, NY, IX1, IXN, IY1, IYN, NSEA, & - E3DF(3,5), P2MSF(3), US3DF(3), & - USSPF(2), NCTYPE, NCVARTYPEI - CHARACTER(30) :: FILEPREFIX - LOGICAL, INTENT(IN) :: TOGETHER - LOGICAL, INTENT(IN) :: FLG2D(NOGRP,NGRPP) - INTEGER, INTENT(INOUT) :: NCIDS(NOGRP,NGRPP,NOSWLL + 1), S3 - CHARACTER*30,INTENT(IN) :: STRSTOPDATE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IFI, IFJ, MFILL, I, J, ISEA, IX, IY, & - I1, J1, IPART, INDEXIPART, COORDTYPE - INTEGER :: S1, S2, S4, S5, NCID, OLDNCID, NDSDAT,& - NFIELD, N, IRET, IK, EXTRADIM, IVAR, & - IVAR1 - INTEGER :: DIMID(6), VARID(300), START(4), & - COUNT(4), DIMLN(6),START1D(2), & - COUNT1D(2), DIMFIELD(3), & - STARTDATE(8), CURDATE(8), & - EPOCHDATE(8), & - MAP(NX+1,NY), MP2(NX+1,NY) -! - INTEGER :: DEFLATE=1 + USE NETCDF + IMPLICIT NONE + + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NX, NY, IX1, IXN, IY1, IYN, NSEA, & + E3DF(3,5), P2MSF(3), US3DF(3), & + USSPF(2), NCTYPE, NCVARTYPEI + CHARACTER(30) :: FILEPREFIX + LOGICAL, INTENT(IN) :: TOGETHER + LOGICAL, INTENT(IN) :: FLG2D(NOGRP,NGRPP) + INTEGER, INTENT(INOUT) :: NCIDS(NOGRP,NGRPP,NOSWLL + 1), S3 + CHARACTER*30,INTENT(IN) :: STRSTOPDATE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IFI, IFJ, MFILL, I, J, ISEA, IX, IY, & + I1, J1, IPART, INDEXIPART, COORDTYPE + INTEGER :: S1, S2, S4, S5, NCID, OLDNCID, NDSDAT,& + NFIELD, N, IRET, IK, EXTRADIM, IVAR, & + IVAR1 + INTEGER :: DIMID(6), VARID(300), START(4), & + COUNT(4), DIMLN(6),START1D(2), & + COUNT1D(2), DIMFIELD(3), & + STARTDATE(8), CURDATE(8), & + EPOCHDATE(8), & + MAP(NX+1,NY), MP2(NX+1,NY) + ! + INTEGER :: DEFLATE=1 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! - ! Make the below allocatable to avoid stack overflow on some machines - INTEGER(KIND=2), ALLOCATABLE :: MX1(:,:), MXX(:,:), MYY(:,:), & - MXY(:,:), MAPOUT(:,:) -! - REAL :: CABS, UABS, MFILLR + ! + ! Make the below allocatable to avoid stack overflow on some machines + INTEGER(KIND=2), ALLOCATABLE :: MX1(:,:), MXX(:,:), MYY(:,:), & + MXY(:,:), MAPOUT(:,:) + ! + REAL :: CABS, UABS, MFILLR #ifdef W3_BT4 - REAL, PARAMETER :: LOG2=LOG(2.) + REAL, PARAMETER :: LOG2=LOG(2.) #endif -! - REAL,DIMENSION(:), ALLOCATABLE :: LON, LAT, FREQ - REAL,DIMENSION(:,:), ALLOCATABLE :: LON2D, LAT2D, ANGLD2D + ! + REAL,DIMENSION(:), ALLOCATABLE :: LON, LAT, FREQ + REAL,DIMENSION(:,:), ALLOCATABLE :: LON2D, LAT2D, ANGLD2D #ifdef W3_RTD - REAL,DIMENSION(:,:), ALLOCATABLE :: LON2DEQ, LAT2DEQ + REAL,DIMENSION(:,:), ALLOCATABLE :: LON2DEQ, LAT2DEQ #endif - ! Make the below allocatable to avoid stack overflow on some machines - REAL, ALLOCATABLE :: X1(:,:), X2(:,:), XX(:,:), XY(:,:), & - XK(:,:,:), XXK(:,:,:), XYK(:,:,:), & - MX1R(:,:), MXXR(:,:), MYYR(:,:), & - MXYR(:,:), AUX1(:) -! - DOUBLE PRECISION :: OUTJULDAY - INTEGER(KIND=8) :: OUTSECS - DOUBLE PRECISION :: SXD, SYD, X0D, Y0D -! - CHARACTER*120 :: STR2 - CHARACTER*512 :: PARTCOM - !CHARACTER*30 :: UNITVAR(3),FORMAT1 - CHARACTER*30 :: FORMAT1 - CHARACTER*30 :: STRSTARTDATE - CHARACTER :: FNAMENC*128, & - FORMF*11 - CHARACTER, SAVE :: OLDTIMEID*16 = '0000000000000000' - CHARACTER, SAVE :: TIMEID*16 = '0000000000000000' -! - LOGICAL :: FLFRQ, FLDIR, FEXIST, FREMOVE - LOGICAL :: CUSTOMFRQ=.FALSE. + ! Make the below allocatable to avoid stack overflow on some machines + REAL, ALLOCATABLE :: X1(:,:), X2(:,:), XX(:,:), XY(:,:), & + XK(:,:,:), XXK(:,:,:), XYK(:,:,:), & + MX1R(:,:), MXXR(:,:), MYYR(:,:), & + MXYR(:,:), AUX1(:) + ! + DOUBLE PRECISION :: OUTJULDAY + INTEGER(KIND=8) :: OUTSECS + DOUBLE PRECISION :: SXD, SYD, X0D, Y0D + ! + CHARACTER*120 :: STR2 + CHARACTER*512 :: PARTCOM + !CHARACTER*30 :: UNITVAR(3),FORMAT1 + CHARACTER*30 :: FORMAT1 + CHARACTER*30 :: STRSTARTDATE + CHARACTER :: FNAMENC*128, & + FORMF*11 + CHARACTER, SAVE :: OLDTIMEID*16 = '0000000000000000' + CHARACTER, SAVE :: TIMEID*16 = '0000000000000000' + ! + LOGICAL :: FLFRQ, FLDIR, FEXIST, FREMOVE + LOGICAL :: CUSTOMFRQ=.FALSE. #ifdef W3_T - LOGICAL :: LTEMP(NGRPP) + LOGICAL :: LTEMP(NGRPP) #endif - TYPE(META_T) :: META(3) - !TYPE(META_T) :: META -!/ -!/ ------------------------------------------------------------------- / -!/ -! + TYPE(META_T) :: META(3) + !TYPE(META_T) :: META + !/ + !/ ------------------------------------------------------------------- / + !/ + ! #ifdef W3_S - CALL STRACE (IENT, 'W3EXNC') + CALL STRACE (IENT, 'W3EXNC') #endif -! + ! #ifdef W3_T - DO IFI=1, NOGRP - LTEMP = FLG2D(IFI,:) - WRITE (NDST,9000) IFI, LTEMP - END DO - WRITE (NDST,9001) NCTYPE, IX1, IXN, IY1, IYN, VECTOR + DO IFI=1, NOGRP + LTEMP = FLG2D(IFI,:) + WRITE (NDST,9000) IFI, LTEMP + END DO + WRITE (NDST,9001) NCTYPE, IX1, IXN, IY1, IYN, VECTOR #endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. Preparations -! - ! Allocate output storage. This is required with the introduction - ! of the SMC grid output as the regridded output grid dimensions could - ! conceivably be larger than the NX and NY values. Making these (large) - ! arrays allocatable also moves them to the heap and avoids stack - ! overflow issues that can occur on some architectures. (Chris Bunney) - IF(SMCGRD) THEN + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1. Preparations + ! + ! Allocate output storage. This is required with the introduction + ! of the SMC grid output as the regridded output grid dimensions could + ! conceivably be larger than the NX and NY values. Making these (large) + ! arrays allocatable also moves them to the heap and avoids stack + ! overflow issues that can occur on some architectures. (Chris Bunney) + IF(SMCGRD) THEN #ifdef W3_SMC - ALLOCATE(X1(NXO,NYO), X2(NXO,NYO), XX(NXO,NYO), XY(NXO,NYO)) - ALLOCATE(XK(NXO,NYO,NK), XXK(NXO,NYO,NK), XYK(NXO,NYO,NK)) + ALLOCATE(X1(NXO,NYO), X2(NXO,NYO), XX(NXO,NYO), XY(NXO,NYO)) + ALLOCATE(XK(NXO,NYO,NK), XXK(NXO,NYO,NK), XYK(NXO,NYO,NK)) - ALLOCATE(MX1(NXO,NYO), MXX(NXO,NYO), MYY(NXO,NYO), & - MXY(NXO,NYO), MAPOUT(NXO,NYO)) - ALLOCATE(MX1R(NXO,NYO), MXXR(NXO,NYO), MYYR(NXO,NYO), MXYR(NXO,NYO)) + ALLOCATE(MX1(NXO,NYO), MXX(NXO,NYO), MYY(NXO,NYO), & + MXY(NXO,NYO), MAPOUT(NXO,NYO)) + ALLOCATE(MX1R(NXO,NYO), MXXR(NXO,NYO), MYYR(NXO,NYO), MXYR(NXO,NYO)) #endif - ELSE - ALLOCATE(X1(NX+1,NY),X2(NX+1,NY),XX(NX+1,NY),XY(NX+1,NY)) - ALLOCATE(XK(NX+1,NY,NK), XXK(NX+1,NY,NK), XYK(NX+1,NY,NK)) - ALLOCATE(MX1(NX,NY), MXX(NX,NY), MYY(NX,NY), MXY(NX,NY), MAPOUT(NX,NY)) - ALLOCATE(MX1R(NX,NY), MXXR(NX,NY), MYYR(NX,NY), MXYR(NX,NY)) - ENDIF ! SMCGRD - ALLOCATE(AUX1(NSEA)) - - X1 = UNDEF - X2 = UNDEF - XX = UNDEF - XY = UNDEF - ! CB: Dont output MAPSTA for SMC grid - it does not make sense - IF( SMCGRD .AND. MAPSTAOUT) THEN - WRITE(NDSO,*) "MAPSTA output disabled for SMC grids" - MAPSTAOUT = .FALSE. - ENDIF - NCVARTYPE = NCVARTYPEI - NDSDAT=30 - NCID = 0 -! -! - !CHRISB: Allow alternative time units: - CALL T2ISO(TEPOCH, EPOCH_ISO) - SELECT CASE(TIMEUNIT) - CASE('D') - EPOCH = 'days since ' // EPOCH_ISO - CASE('S') - EPOCH = 'seconds since ' // EPOCH_ISO - CASE DEFAULT - PRINT*,'Unknown time units: ', TIMEUNIT - CALL EXTCDE(10) - END SELECT - - CALL U2D(EPOCH, EPOCHDATE, IERR) - -! 1.1 Set-up transfer files - MFILL = NF90_FILL_SHORT - MFILLR = NF90_FILL_FLOAT - IF (GTYPE.NE.UNGTYPE) THEN - COORDTYPE=1 - ELSE - COORDTYPE=2 - ENDIF - -! 1.2 Sets the date as ISO8601 convention - ! S3 defines the number of characters in the date for the filename - ! S3=0 -> field, S3=4-> YYYY, S3=6 -> YYYYMM, S3=10 -> YYYYMMDDHH - ! Setups min and max date format - IF (S3.GT.0 .AND. S3.LT.4) S3=4 - IF (S3.GT.10) S3=10 -! - ! Defines the format of FILETIME - S5=S3-8 - S4=S3 - OLDTIMEID=TIMEID - ! if S3=>nodate then filetime='field' - IF (S3.EQ.0) THEN - S4=5 - TIMEID="field" + ELSE + ALLOCATE(X1(NX+1,NY),X2(NX+1,NY),XX(NX+1,NY),XY(NX+1,NY)) + ALLOCATE(XK(NX+1,NY,NK), XXK(NX+1,NY,NK), XYK(NX+1,NY,NK)) + ALLOCATE(MX1(NX,NY), MXX(NX,NY), MYY(NX,NY), MXY(NX,NY), MAPOUT(NX,NY)) + ALLOCATE(MX1R(NX,NY), MXXR(NX,NY), MYYR(NX,NY), MXYR(NX,NY)) + ENDIF ! SMCGRD + ALLOCATE(AUX1(NSEA)) + + X1 = UNDEF + X2 = UNDEF + XX = UNDEF + XY = UNDEF + ! CB: Dont output MAPSTA for SMC grid - it does not make sense + IF( SMCGRD .AND. MAPSTAOUT) THEN + WRITE(NDSO,*) "MAPSTA output disabled for SMC grids" + MAPSTAOUT = .FALSE. + ENDIF + NCVARTYPE = NCVARTYPEI + NDSDAT=30 + NCID = 0 + ! + ! + !CHRISB: Allow alternative time units: + CALL T2ISO(TEPOCH, EPOCH_ISO) + SELECT CASE(TIMEUNIT) + CASE('D') + EPOCH = 'days since ' // EPOCH_ISO + CASE('S') + EPOCH = 'seconds since ' // EPOCH_ISO + CASE DEFAULT + PRINT*,'Unknown time units: ', TIMEUNIT + CALL EXTCDE(10) + END SELECT + + CALL U2D(EPOCH, EPOCHDATE, IERR) + + ! 1.1 Set-up transfer files + MFILL = NF90_FILL_SHORT + MFILLR = NF90_FILL_FLOAT + IF (GTYPE.NE.UNGTYPE) THEN + COORDTYPE=1 + ELSE + COORDTYPE=2 + ENDIF + + ! 1.2 Sets the date as ISO8601 convention + ! S3 defines the number of characters in the date for the filename + ! S3=0 -> field, S3=4-> YYYY, S3=6 -> YYYYMM, S3=10 -> YYYYMMDDHH + ! Setups min and max date format + IF (S3.GT.0 .AND. S3.LT.4) S3=4 + IF (S3.GT.10) S3=10 + ! + ! Defines the format of FILETIME + S5=S3-8 + S4=S3 + OLDTIMEID=TIMEID + ! if S3=>nodate then filetime='field' + IF (S3.EQ.0) THEN + S4=5 + TIMEID="field" ! if S3=>YYYYMMDDHH then filetime='YYYYMMDDTHHZ' - ELSE IF (S3.EQ.10) THEN - S4=S4+2 ! add chars for ISO8601 : day T hours Z - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I8.8,A1,I',S5,'.',S5,',A1)' - WRITE (TIMEID,FORMAT1) TIME(1), 'T', & - FLOOR(REAL(TIME(2))/NINT(10.**(6-S5))), 'Z' + ELSE IF (S3.EQ.10) THEN + S4=S4+2 ! add chars for ISO8601 : day T hours Z + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I8.8,A1,I',S5,'.',S5,',A1)' + WRITE (TIMEID,FORMAT1) TIME(1), 'T', & + FLOOR(REAL(TIME(2))/NINT(10.**(6-S5))), 'Z' ! if S3=>YYYYMMDD then filetime='YYYYMMDD' - ELSE IF (S3.EQ.8) THEN - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' - WRITE (TIMEID,FORMAT1) TIME(1) + ELSE IF (S3.EQ.8) THEN + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' + WRITE (TIMEID,FORMAT1) TIME(1) ! if S3=>YYYYMM then filetime='YYYYMM' ! or S3=>YYYY then filetime='YYYY' - ELSE - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' - WRITE (TIMEID,FORMAT1) FLOOR(REAL(TIME(1))/NINT(10.**(8-S3))) - END IF - ! redefines filename with updated date format - S1=LEN_TRIM(FILEPREFIX) - FNAMENC='' - FNAMENC(1:S1)=FILEPREFIX(1:S1) - FNAMENC(S1+1:S1+S4) = TIMEID(1:S4) - - ! + ELSE + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' + WRITE (TIMEID,FORMAT1) FLOOR(REAL(TIME(1))/NINT(10.**(8-S3))) + END IF + ! redefines filename with updated date format + S1=LEN_TRIM(FILEPREFIX) + FNAMENC='' + FNAMENC(1:S1)=FILEPREFIX(1:S1) + FNAMENC(S1+1:S1+S4) = TIMEID(1:S4) + + ! #ifdef W3_SMC -! -!--- Update MAPSMC for SMC type 2 output. This needs to be -! done at each timestep as MAPSTA could change if there -! are water level or ice input chagnes. -! - IF( SMCGRD .AND. (SMCOTYPE .EQ. 2) ) CALL MAPSTA_SMC() + ! + !--- Update MAPSMC for SMC type 2 output. This needs to be + ! done at each timestep as MAPSTA could change if there + ! are water level or ice input chagnes. + ! + IF( SMCGRD .AND. (SMCOTYPE .EQ. 2) ) CALL MAPSTA_SMC() #endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Loop over output fields. -! - - ! Instanciates the field and group indexes - I1=0 - J1=0 -! - DO IFI=1, NOGRP - DO IFJ=1, NGRPP - ! If the flag for the variable IFI of the group IFJ is .TRUE. - IF ( FLG2D(IFI,IFJ) ) THEN - ! Instanciates the partition array - INDEXIPART=1 - IPART=TABIPART(INDEXIPART) - NFIELD=1 ! Default is one field - - -! Loop over IPART for partition variables -555 CONTINUE - - ! Initializes the index of field and group at the first flag FLG2D at .TRUE. - IF (I1.EQ.0) I1=IFI - IF (J1.EQ.0) J1=IFJ - FORMF = '(1X,32I5)' + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Loop over output fields. + ! + + ! Instanciates the field and group indexes + I1=0 + J1=0 + ! + DO IFI=1, NOGRP + DO IFJ=1, NGRPP + ! If the flag for the variable IFI of the group IFJ is .TRUE. + IF ( FLG2D(IFI,IFJ) ) THEN + ! Instanciates the partition array + INDEXIPART=1 + IPART=TABIPART(INDEXIPART) + NFIELD=1 ! Default is one field + + + ! Loop over IPART for partition variables +555 CONTINUE + + ! Initializes the index of field and group at the first flag FLG2D at .TRUE. + IF (I1.EQ.0) I1=IFI + IF (J1.EQ.0) J1=IFJ + FORMF = '(1X,32I5)' #ifdef W3_T - WRITE (NDST,9020) IDOUT(IFI,IFJ) + WRITE (NDST,9020) IDOUT(IFI,IFJ) #endif -! -! 2.1 Set output arrays and parameters -! - ! Initializes the flags for freq and direction dimensions - FLFRQ = .FALSE. - FLDIR = .FALSE. - IF (NCVARTYPEI.EQ.3) NCVARTYPE=2 -! - ! Depth - IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN - CALL S2GRID(DW(1:NSEA), X1) + ! + ! 2.1 Set output arrays and parameters + ! + ! Initializes the flags for freq and direction dimensions + FLFRQ = .FALSE. + FLDIR = .FALSE. + IF (NCVARTYPEI.EQ.3) NCVARTYPE=2 + ! + ! Depth + IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN + CALL S2GRID(DW(1:NSEA), X1) ! Surface current - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN - !! Note - CX and CY read in from .ww3 file are X-Y vectors + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN + !! Note - CX and CY read in from .ww3 file are X-Y vectors #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX(1:NSEA), CY(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX(1:NSEA), CY(1:NSEA), AnglD) #endif -! - IF( .NOT. VECTOR ) THEN - CALL UV_TO_MAG_DIR(CX(1:NSEA), CY(1:NSEA), NSEA, & - TOLERANCE=0.05, CONV='O') - ENDIF -! - CALL S2GRID(CX(1:NSEA), XX) - CALL S2GRID(CY(1:NSEA), XY) - NFIELD=2 -! + ! + IF( .NOT. VECTOR ) THEN + CALL UV_TO_MAG_DIR(CX(1:NSEA), CY(1:NSEA), NSEA, & + TOLERANCE=0.05, CONV='O') + ENDIF + ! + CALL S2GRID(CX(1:NSEA), XX) + CALL S2GRID(CY(1:NSEA), XY) + NFIELD=2 + ! ! Wind - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN - !! Note - UA and UD read in from .ww3 file are UX,UY + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN + !! Note - UA and UD read in from .ww3 file are UX,UY #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA(1:NSEA), UD(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA(1:NSEA), UD(1:NSEA), AnglD) #endif -! - IF( .NOT. VECTOR ) THEN - CALL UV_TO_MAG_DIR(UA(1:NSEA), UD(1:NSEA), NSEA, & - TOLERANCE=1.0, CONV='N') - ENDIF -! - CALL S2GRID(UA(1:NSEA), XX) - CALL S2GRID(UD(1:NSEA), XY) - NFIELD=2 -! + ! + IF( .NOT. VECTOR ) THEN + CALL UV_TO_MAG_DIR(UA(1:NSEA), UD(1:NSEA), NSEA, & + TOLERANCE=1.0, CONV='N') + ENDIF + ! + CALL S2GRID(UA(1:NSEA), XX) + CALL S2GRID(UD(1:NSEA), XY) + NFIELD=2 + ! ! Air-sea temperature difference - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN - CALL S2GRID(AS(1:NSEA), X1) -! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN + CALL S2GRID(AS(1:NSEA), X1) + ! ! Sea surface height above sea level - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN - CALL S2GRID(WLV, X1) -! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN + CALL S2GRID(WLV, X1) + ! ! Sea ice area fraction - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN - CALL S2GRID(ICE(1:NSEA), X1) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN + CALL S2GRID(ICE(1:NSEA), X1) ! Icebergs_damping - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 7 ) THEN - CALL S2GRID(BERG, X1) - WHERE ( X1.NE.UNDEF) X1 = X1*0.1 -! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 7 ) THEN + CALL S2GRID(BERG, X1) + WHERE ( X1.NE.UNDEF) X1 = X1*0.1 + ! ! Atmospheric momentum - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN - !! Note - TAUA and TAUADIR read in from .ww3 file are TAUAX,TAUAY + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN + !! Note - TAUA and TAUADIR read in from .ww3 file are TAUAX,TAUAY #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUA(1:NSEA), TAUADIR(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUA(1:NSEA), TAUADIR(1:NSEA), AnglD) #endif - IF( SMCGRD ) THEN + IF( SMCGRD ) THEN #ifdef W3_SMC - CALL W3S2XY_SMC( TAUA (1:NSEA), XX ) - CALL W3S2XY_SMC( TAUADIR(1:NSEA), XY ) + CALL W3S2XY_SMC( TAUA (1:NSEA), XX ) + CALL W3S2XY_SMC( TAUADIR(1:NSEA), XY ) #endif - ELSE ! IF(SMCGRD) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUA(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUADIR(1:NSEA) & - , MAPSF, XY ) - ENDIF - NFIELD=2 -! + ELSE ! IF(SMCGRD) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUA(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUADIR(1:NSEA) & + , MAPSF, XY ) + ENDIF + NFIELD=2 + ! ! Air density - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN - IF( SMCGRD ) THEN + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN + IF( SMCGRD ) THEN #ifdef W3_SMC - CALL W3S2XY_SMC(RHOAIR, X1) + CALL W3S2XY_SMC(RHOAIR, X1) #endif - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, RHOAIR, MAPSF, X1 ) - ENDIF -! + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, RHOAIR, MAPSF, X1 ) + ENDIF + ! #ifdef W3_BT4 - ! Krumbein phi scale - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN - CALL S2GRID(SED_D50, X1) - WHERE ( X1.NE.UNDEF) X1 = -LOG(X1/0.001)/LOG2 - NFIELD=1 + ! Krumbein phi scale + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN + CALL S2GRID(SED_D50, X1) + WHERE ( X1.NE.UNDEF) X1 = -LOG(X1/0.001)/LOG2 + NFIELD=1 #endif -! + ! #ifdef W3_IS2 - ! Ice thickness - ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN - CALL S2GRID(ICEH(1:NSEA), X1) - NFIELD=1 + ! Ice thickness + ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN + CALL S2GRID(ICEH(1:NSEA), X1) + NFIELD=1 #endif -! + ! #ifdef W3_IS2 - ! Maximum ice floe diameter - ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN - CALL S2GRID(ICEF(1:NSEA), X1) - NFIELD=1 + ! Maximum ice floe diameter + ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN + CALL S2GRID(ICEF(1:NSEA), X1) + NFIELD=1 #endif ! Significant wave height - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN - IF (NCVARTYPEI.EQ.3) NCVARTYPE=2 - CALL S2GRID(HS, X1) + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN + IF (NCVARTYPEI.EQ.3) NCVARTYPE=2 + CALL S2GRID(HS, X1) ! Mean wave length - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN - CALL S2GRID(WLM, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN + CALL S2GRID(WLM, X1) + ! ! Mean period T02 - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN - CALL S2GRID(T02, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN + CALL S2GRID(T02, X1) + ! ! Mean period T0m1 - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN - CALL S2GRID(T0M1, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN + CALL S2GRID(T0M1, X1) + ! ! Mean period T01 - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN - CALL S2GRID(T01, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN + CALL S2GRID(T01, X1) + ! ! Wave peak frequency - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 6 ) THEN - CALL S2GRID(FP0, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 6 ) THEN + CALL S2GRID(FP0, X1) + ! ! Wave mean direction - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) #endif - CALL S2GRID(THM, X1, .TRUE.) -! + CALL S2GRID(THM, X1, .TRUE.) + ! ! Directional spread - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN - CALL S2GRID(THS, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN + CALL S2GRID(THS, X1) + ! ! Peak direction - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) #endif - CALL S2GRID(THP0, X1, .TRUE.) -! + CALL S2GRID(THP0, X1, .TRUE.) + ! ! Infragravity wave height - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 10 ) THEN - CALL S2GRID(HSIG, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 10 ) THEN + CALL S2GRID(HSIG, X1) + ! ! Expected maximum sea surface elevation - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 11 ) THEN - CALL S2GRID(STMAXE, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 11 ) THEN + CALL S2GRID(STMAXE, X1) + ! ! Standard deviation of maximum sea surface elevation - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 12 ) THEN - CALL S2GRID(STMAXD, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 12 ) THEN + CALL S2GRID(STMAXD, X1) + ! ! Expected maximum wave height - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 13 ) THEN - CALL S2GRID(HMAXE, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 13 ) THEN + CALL S2GRID(HMAXE, X1) + ! ! Expected maximum wave height from crest - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 14 ) THEN - CALL S2GRID(HCMAXE, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 14 ) THEN + CALL S2GRID(HCMAXE, X1) + ! ! STD of maximum wave height - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 15 ) THEN - CALL S2GRID(HMAXD, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 15 ) THEN + CALL S2GRID(HMAXD, X1) + ! ! STD of maximum wave height from crest - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 16 ) THEN - CALL S2GRID(HCMAXD, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 16 ) THEN + CALL S2GRID(HCMAXD, X1) + ! ! Dominant wave breaking probability - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 17 ) THEN - CALL S2GRID(WBT, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 17 ) THEN + CALL S2GRID(WBT, X1) + ! ! Wave peak period (derived from peak freq field) - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 18 ) THEN - DO I=1,NSEA - IF(FP0(I) .NE. UNDEF) THEN - AUX1(I) = 1.0 / FP0(I) - ELSE - AUX1(I) = UNDEF - ENDIF - ENDDO -! - CALL S2GRID(AUX1, X1) -! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 18 ) THEN + DO I=1,NSEA + IF(FP0(I) .NE. UNDEF) THEN + AUX1(I) = 1.0 / FP0(I) + ELSE + AUX1(I) = UNDEF + ENDIF + ENDDO + ! + CALL S2GRID(AUX1, X1) + ! ! Mean wave number - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN - IF( SMCGRD ) THEN + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN + IF( SMCGRD ) THEN #ifdef W3_SMC - CALL W3S2XY_SMC( WNMEAN, X1 ) + CALL W3S2XY_SMC( WNMEAN, X1 ) #endif - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WNMEAN, MAPSF, X1 ) - END IF -! + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WNMEAN, MAPSF, X1 ) + END IF + ! ! Wave elevation spectrum - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 1 ) THEN - ! Information for spectral - FLFRQ = .TRUE. - I1F=E3DF(2,1) - I2F=E3DF(3,1) - DO IK=I1F,I2F - CALL S2GRID(EF(:,IK), XX) - IF (NCVARTYPE.EQ.2) WHERE ( XX.GE.0.) XX = ALOG10(XX+1E-12) - XK(:,:,IK)=XX - END DO -! + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 1 ) THEN + ! Information for spectral + FLFRQ = .TRUE. + I1F=E3DF(2,1) + I2F=E3DF(3,1) + DO IK=I1F,I2F + CALL S2GRID(EF(:,IK), XX) + IF (NCVARTYPE.EQ.2) WHERE ( XX.GE.0.) XX = ALOG10(XX+1E-12) + XK(:,:,IK)=XX + END DO + ! ! Mean wave direction frequency spectrum - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 2 ) THEN - ! Information for spectral - FLFRQ = .TRUE. - I1F=E3DF(2,2) - I2F=E3DF(3,2) - DO IK=I1F,I2F + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 2 ) THEN + ! Information for spectral + FLFRQ = .TRUE. + I1F=E3DF(2,2) + I2F=E3DF(3,2) + DO IK=I1F,I2F #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, TH1M(:,IK), AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, TH1M(:,IK), AnglD, .FALSE.) #endif - CALL S2GRID(TH1M(:,IK), XX) - XK(:,:,IK)=XX - END DO -! + CALL S2GRID(TH1M(:,IK), XX) + XK(:,:,IK)=XX + END DO + ! ! Spreading frequency spectrum - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 3 ) THEN - ! Information for spectral - FLFRQ = .TRUE. - I1F=E3DF(2,3) - I2F=E3DF(3,3) - DO IK=I1F,I2F - CALL S2GRID(STH1M(:,IK), XX) - XK(:,:,IK)=XX - END DO -! + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 3 ) THEN + ! Information for spectral + FLFRQ = .TRUE. + I1F=E3DF(2,3) + I2F=E3DF(3,3) + DO IK=I1F,I2F + CALL S2GRID(STH1M(:,IK), XX) + XK(:,:,IK)=XX + END DO + ! ! Second mean wave direction frequency spectrum - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 4 ) THEN - ! Information for spectral - FLFRQ = .TRUE. - I1F=E3DF(2,4) - I2F=E3DF(3,4) - DO IK=I1F,I2F + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 4 ) THEN + ! Information for spectral + FLFRQ = .TRUE. + I1F=E3DF(2,4) + I2F=E3DF(3,4) + DO IK=I1F,I2F #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, TH2M(:,IK), AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, TH2M(:,IK), AnglD, .FALSE.) #endif - CALL S2GRID(TH2M(:,IK), XX) - XK(:,:,IK)=XX - END DO -! + CALL S2GRID(TH2M(:,IK), XX) + XK(:,:,IK)=XX + END DO + ! ! Second spreading frequency spectrum - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 5 ) THEN - ! Information for spectral - FLFRQ = .TRUE. - I1F=E3DF(2,5) - I2F=E3DF(3,5) - DO IK=I1F,I2F - CALL S2GRID(STH2M(:,IK), XX) - XK(:,:,IK)=XX - END DO -! + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 5 ) THEN + ! Information for spectral + FLFRQ = .TRUE. + I1F=E3DF(2,5) + I2F=E3DF(3,5) + DO IK=I1F,I2F + CALL S2GRID(STH2M(:,IK), XX) + XK(:,:,IK)=XX + END DO + ! ! Wave numbers - ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 6 ) THEN - ! Information for spectral - FLFRQ = .TRUE. - I1F=1 - I2F=NK - DO IK=1,NK - CALL S2GRID(WN(IK,:), XX) - XK(:,:,IK)=XX - END DO -! + ELSE IF ( IFI .EQ. 3 .AND. IFJ .EQ. 6 ) THEN + ! Information for spectral + FLFRQ = .TRUE. + I1F=1 + I2F=NK + DO IK=1,NK + CALL S2GRID(WN(IK,:), XX) + XK(:,:,IK)=XX + END DO + ! ! Partition wave significant height - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN - CALL S2GRID(PHS(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN + CALL S2GRID(PHS(:,IPART), X1) + ! ! Partition peak period - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN - CALL S2GRID(PTP(:,IPART), X1) + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN + CALL S2GRID(PTP(:,IPART), X1) ! Partition peak wave length - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN - CALL S2GRID(PLP(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN + CALL S2GRID(PLP(:,IPART), X1) + ! ! Partition wave mean direction - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,IPART), AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,IPART), AnglD, .FALSE.) #endif - CALL S2GRID(PDIR(:,IPART), X1, .TRUE.) -! + CALL S2GRID(PDIR(:,IPART), X1, .TRUE.) + ! ! Partition directional spread - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN - CALL S2GRID(PSI(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN + CALL S2GRID(PSI(:,IPART), X1) + ! ! Partition wind sea fraction - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN - CALL S2GRID(PWS(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN + CALL S2GRID(PWS(:,IPART), X1) + ! ! Partition peak direction - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 7 ) THEN + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 7 ) THEN #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, PTHP0(:,IPART), AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, PTHP0(:,IPART), AnglD, .FALSE.) #endif - CALL S2GRID(PTHP0(:,IPART), X1, .TRUE.) -! + CALL S2GRID(PTHP0(:,IPART), X1, .TRUE.) + ! ! Partition peakedness - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 8 ) THEN - CALL S2GRID(PQP(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 8 ) THEN + CALL S2GRID(PQP(:,IPART), X1) + ! ! Partition peak enhancement factor - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 9 ) THEN - CALL S2GRID(PPE(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 9 ) THEN + CALL S2GRID(PPE(:,IPART), X1) + ! ! Partition frequency width - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 10 ) THEN - CALL S2GRID(PGW(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 10 ) THEN + CALL S2GRID(PGW(:,IPART), X1) + ! ! Partition spectral width - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 11 ) THEN - CALL S2GRID(PSW(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 11 ) THEN + CALL S2GRID(PSW(:,IPART), X1) + ! ! Partition mean period Tm10 - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 12 ) THEN - CALL S2GRID(PTM1(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 12 ) THEN + CALL S2GRID(PTM1(:,IPART), X1) + ! ! Partition mean period T01 - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 13 ) THEN - CALL S2GRID(PT1(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 13 ) THEN + CALL S2GRID(PT1(:,IPART), X1) + ! ! Partition mean period T02 - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 14 ) THEN - CALL S2GRID(PT2(:,IPART), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 14 ) THEN + CALL S2GRID(PT2(:,IPART), X1) + ! ! Partition energy at peak frequency - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 15 ) THEN - CALL S2GRID(PEP(:,IPART), X1) - NFIELD=1 -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 15 ) THEN + CALL S2GRID(PEP(:,IPART), X1) + NFIELD=1 + ! ! Partition wind sea fraction - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16 ) THEN - CALL S2GRID(PWST(:), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16 ) THEN + CALL S2GRID(PWST(:), X1) + ! ! Number of wave partitions - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17 ) THEN - CALL S2GRID(PNR(:), X1) -! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17 ) THEN + CALL S2GRID(PNR(:), X1) + ! ! Friction velocity - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN - !! Note - UST and USTDIR read in from .ww3 file are X-Y vectors - DO ISEA=1, NSEA - UABS = SQRT(UST(ISEA)**2+USTDIR(ISEA)**2) - IF (UABS.GE.10.) THEN - UST(ISEA)=UNDEF - USTDIR(ISEA)=UNDEF - END IF - END DO + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN + !! Note - UST and USTDIR read in from .ww3 file are X-Y vectors + DO ISEA=1, NSEA + UABS = SQRT(UST(ISEA)**2+USTDIR(ISEA)**2) + IF (UABS.GE.10.) THEN + UST(ISEA)=UNDEF + USTDIR(ISEA)=UNDEF + END IF + END DO #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST(1:NSEA), USTDIR(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST(1:NSEA), USTDIR(1:NSEA), AnglD) #endif - CALL S2GRID(UST(1:NSEA), XX) - CALL S2GRID(USTDIR(1:NSEA), XY) - !! Commented out unnecessary statements below for time being - !! UST,USTDIR are in north-east convention and X1,X2 - !! are not actually written out below - !DO ISEA=1, NSEA - ! UABS = SQRT(UST(ISEA)**2+USTDIR(ISEA)**2) - ! IF ( UST(ISEA) .EQ. UNDEF ) THEN - ! USTDIR(ISEA) = UNDEF - ! UABS = UNDEF - ! ELSE IF ( UABS .GT. 0.05 ) THEN - ! USTDIR(ISEA) = MOD ( 630. - & - ! RADE*ATAN2(USTDIR(ISEA),UST(ISEA)) , 360. ) - ! ELSE - ! USTDIR(ISEA) = UNDEF - ! END IF - ! UST(ISEA) = UABS - ! END DO - !CALL W3S2XY (NSEA,NSEA,NX+1,NY, UST (1:NSEA) , MAPSF, X1 ) - !CALL W3S2XY (NSEA,NSEA,NX+1,NY, USTDIR(1:NSEA) , MAPSF, X2 ) - NFIELD=2 -! + CALL S2GRID(UST(1:NSEA), XX) + CALL S2GRID(USTDIR(1:NSEA), XY) + !! Commented out unnecessary statements below for time being + !! UST,USTDIR are in north-east convention and X1,X2 + !! are not actually written out below + !DO ISEA=1, NSEA + ! UABS = SQRT(UST(ISEA)**2+USTDIR(ISEA)**2) + ! IF ( UST(ISEA) .EQ. UNDEF ) THEN + ! USTDIR(ISEA) = UNDEF + ! UABS = UNDEF + ! ELSE IF ( UABS .GT. 0.05 ) THEN + ! USTDIR(ISEA) = MOD ( 630. - & + ! RADE*ATAN2(USTDIR(ISEA),UST(ISEA)) , 360. ) + ! ELSE + ! USTDIR(ISEA) = UNDEF + ! END IF + ! UST(ISEA) = UABS + ! END DO + !CALL W3S2XY (NSEA,NSEA,NX+1,NY, UST (1:NSEA) , MAPSF, X1 ) + !CALL W3S2XY (NSEA,NSEA,NX+1,NY, USTDIR(1:NSEA) , MAPSF, X2 ) + NFIELD=2 + ! ! Charnock coefficient - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 2 ) THEN - CALL S2GRID(CHARN(1:NSEA), X1) -! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 2 ) THEN + CALL S2GRID(CHARN(1:NSEA), X1) + ! ! Wave energy flux - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 3 ) THEN - CGE=CGE*0.001 ! from W / m to kW / m - CALL S2GRID(CGE(1:NSEA), X1) -! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 3 ) THEN + CGE=CGE*0.001 ! from W / m to kW / m + CALL S2GRID(CGE(1:NSEA), X1) + ! ! Wind to wave energy flux - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 4 ) THEN - IF (NCVARTYPEI.EQ.3) NCVARTYPE=4 - CALL S2GRID(PHIAW(1:NSEA), X1) -! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 4 ) THEN + IF (NCVARTYPEI.EQ.3) NCVARTYPE=4 + CALL S2GRID(PHIAW(1:NSEA), X1) + ! ! Wave supported wind stress - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 5 ) THEN + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 5 ) THEN #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWIX(1:NSEA), TAUWIY(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWIX(1:NSEA), TAUWIY(1:NSEA), AnglD) #endif - CALL S2GRID(TAUWIX(1:NSEA), XX) - CALL S2GRID(TAUWIY(1:NSEA), XY) - - !! Commented out unnecessary statements below for time being - !! TAUWIX, TAUWIY are in north-east convention and X1,X2 - !! are not actually written out below - !DO ISEA=1, NSEA - ! CABS = SQRT(TAUWIX(ISEA)**2+TAUWIY(ISEA)**2) - ! IF ( CABS .NE. UNDEF ) THEN - ! TAUWIY(ISEA) = MOD ( 630. - & - ! RADE*ATAN2(TAUWIY(ISEA),TAUWIX(ISEA)) , 360. ) - ! ELSE - ! TAUWIY(ISEA) = UNDEF - ! END IF - ! TAUWIX(ISEA) = CABS - ! END DO - !CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIX, MAPSF, X1 ) - !CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIY, MAPSF, X2 ) - NFIELD=2 -! + CALL S2GRID(TAUWIX(1:NSEA), XX) + CALL S2GRID(TAUWIY(1:NSEA), XY) + + !! Commented out unnecessary statements below for time being + !! TAUWIX, TAUWIY are in north-east convention and X1,X2 + !! are not actually written out below + !DO ISEA=1, NSEA + ! CABS = SQRT(TAUWIX(ISEA)**2+TAUWIY(ISEA)**2) + ! IF ( CABS .NE. UNDEF ) THEN + ! TAUWIY(ISEA) = MOD ( 630. - & + ! RADE*ATAN2(TAUWIY(ISEA),TAUWIX(ISEA)) , 360. ) + ! ELSE + ! TAUWIY(ISEA) = UNDEF + ! END IF + ! TAUWIX(ISEA) = CABS + ! END DO + !CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIX, MAPSF, X1 ) + !CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIY, MAPSF, X2 ) + NFIELD=2 + ! ! Wave to wind stress - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 6 ) THEN + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 6 ) THEN #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWNX(1:NSEA), TAUWNY(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWNX(1:NSEA), TAUWNY(1:NSEA), AnglD) #endif - CALL S2GRID(TAUWNX(1:NSEA), XX) - CALL S2GRID(TAUWNY(1:NSEA), XY) - NFIELD=2 -! + CALL S2GRID(TAUWNX(1:NSEA), XX) + CALL S2GRID(TAUWNY(1:NSEA), XY) + NFIELD=2 + ! ! Whitecap coverage - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 7 ) THEN - CALL S2GRID(WHITECAP(1:NSEA,1), X1) -! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 7 ) THEN + CALL S2GRID(WHITECAP(1:NSEA,1), X1) + ! ! Whitecap foam thickness - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 8 ) THEN - CALL S2GRID(WHITECAP(1:NSEA,2), X1) -! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 8 ) THEN + CALL S2GRID(WHITECAP(1:NSEA,2), X1) + ! ! Significant breaking wave height - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 9 ) THEN - CALL S2GRID(WHITECAP(1:NSEA,3), X1) -! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 9 ) THEN + CALL S2GRID(WHITECAP(1:NSEA,3), X1) + ! ! Whitecap moment - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 10 ) THEN - CALL S2GRID(WHITECAP(1:NSEA,4), X1) -! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 10 ) THEN + CALL S2GRID(WHITECAP(1:NSEA,4), X1) + ! ! Wind sea mean period T0M1 - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 11 ) THEN - CALL S2GRID(TWS(1:NSEA), X1) -! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 11 ) THEN + CALL S2GRID(TWS(1:NSEA), X1) + ! ! Radiation stress - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 1 ) THEN + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 1 ) THEN #ifdef W3_RTD - ! Radition stress components are always left on rotated pole - ! at present - need to confirm how to de-rotate + ! Radition stress components are always left on rotated pole + ! at present - need to confirm how to de-rotate #endif - CALL S2GRID(SXX(1:NSEA), X1) - CALL S2GRID(SYY(1:NSEA), X2) - CALL S2GRID(SXY(1:NSEA), XY) - NFIELD=3 -! + CALL S2GRID(SXX(1:NSEA), X1) + CALL S2GRID(SYY(1:NSEA), X2) + CALL S2GRID(SXY(1:NSEA), XY) + NFIELD=3 + ! ! Wave to ocean stress - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 2 ) THEN + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 2 ) THEN #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOX(1:NSEA), TAUOY(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOX(1:NSEA), TAUOY(1:NSEA), AnglD) #endif - CALL S2GRID(TAUOX(1:NSEA), XX) - CALL S2GRID(TAUOY(1:NSEA), XY) - NFIELD=2 -! + CALL S2GRID(TAUOX(1:NSEA), XX) + CALL S2GRID(TAUOY(1:NSEA), XY) + NFIELD=2 + ! ! Radiation pressure (Bernouilli Head) - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 3 ) THEN - CALL S2GRID(BHD(1:NSEA), X1) -! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 3 ) THEN + CALL S2GRID(BHD(1:NSEA), X1) + ! ! Wave to ocean energy flux - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 4 ) THEN - IF (NCVARTYPEI.EQ.3) NCVARTYPE=4 - DO ISEA=1, NSEA - PHIOC(ISEA)=MIN(3000.,PHIOC(ISEA)) - END DO - CALL S2GRID(PHIOC(1:NSEA), X1) -! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 4 ) THEN + IF (NCVARTYPEI.EQ.3) NCVARTYPE=4 + DO ISEA=1, NSEA + PHIOC(ISEA)=MIN(3000.,PHIOC(ISEA)) + END DO + CALL S2GRID(PHIOC(1:NSEA), X1) + ! ! Stokes transport - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 5 ) THEN + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 5 ) THEN #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TUSX(1:NSEA), TUSY(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TUSX(1:NSEA), TUSY(1:NSEA), AnglD) #endif - CALL S2GRID(TUSX(1:NSEA), XX) - CALL S2GRID(TUSY(1:NSEA), XY) -! X1, X2 will not be output when NFIELD == 2 -! ( Like for .cur, .wnd, .ust, .taw, and .uss ) (CHA at FCOO 2019-06-13): - !! Commented out unnecessary statements below for time being - !! (...) X1,X2 are not actually written out below - !DO ISEA=1, NSEA - ! CABS = SQRT(TUSX(ISEA)**2+TUSY(ISEA)**2) - ! IF ( CABS .NE. UNDEF ) THEN - ! TUSY(ISEA) = MOD ( 630. - & - ! RADE*ATAN2(TUSY(ISEA),TUSX(ISEA)) , 360. ) - ! ELSE - ! TUSY(ISEA) = UNDEF - ! END IF - ! TUSX(ISEA) = CABS - ! END DO - !IF( SMCGRD ) THEN + CALL S2GRID(TUSX(1:NSEA), XX) + CALL S2GRID(TUSY(1:NSEA), XY) + ! X1, X2 will not be output when NFIELD == 2 + ! ( Like for .cur, .wnd, .ust, .taw, and .uss ) (CHA at FCOO 2019-06-13): + !! Commented out unnecessary statements below for time being + !! (...) X1,X2 are not actually written out below + !DO ISEA=1, NSEA + ! CABS = SQRT(TUSX(ISEA)**2+TUSY(ISEA)**2) + ! IF ( CABS .NE. UNDEF ) THEN + ! TUSY(ISEA) = MOD ( 630. - & + ! RADE*ATAN2(TUSY(ISEA),TUSX(ISEA)) , 360. ) + ! ELSE + ! TUSY(ISEA) = UNDEF + ! END IF + ! TUSX(ISEA) = CABS + ! END DO + !IF( SMCGRD ) THEN #ifdef W3_SMC - !CALL W3S2XY_SMC( TUSX(:), X1 ) - !CALL W3S2XY_SMC( TUSY(:), X2 ) ! TODO: CHRISB: TUSY is in degrees....W3S2XY_SMC expects radians... + !CALL W3S2XY_SMC( TUSX(:), X1 ) + !CALL W3S2XY_SMC( TUSY(:), X2 ) ! TODO: CHRISB: TUSY is in degrees....W3S2XY_SMC expects radians... #endif - !ELSE - ! CALL W3S2XY ( NSEA, NSEA, NX+1, NY,TUSX,MAPSF, X1 ) - ! CALL W3S2XY ( NSEA, NSEA, NX+1, NY,TUSY,MAPSF, X2 ) - !ENDIF ! SMCGRD - NFIELD=2 -! + !ELSE + ! CALL W3S2XY ( NSEA, NSEA, NX+1, NY,TUSX,MAPSF, X1 ) + ! CALL W3S2XY ( NSEA, NSEA, NX+1, NY,TUSY,MAPSF, X2 ) + !ENDIF ! SMCGRD + NFIELD=2 + ! ! Surface stokes drift - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 6 ) THEN - DO ISEA=1, NSEA - USSX(ISEA)=MAX(-0.9998,MIN(0.9998,USSX(ISEA))) - USSY(ISEA)=MAX(-0.9998,MIN(0.9998,USSY(ISEA))) - END DO + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 6 ) THEN + DO ISEA=1, NSEA + USSX(ISEA)=MAX(-0.9998,MIN(0.9998,USSX(ISEA))) + USSY(ISEA)=MAX(-0.9998,MIN(0.9998,USSY(ISEA))) + END DO #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSX(1:NSEA), USSY(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSX(1:NSEA), USSY(1:NSEA), AnglD) #endif - CALL S2GRID(USSX(1:NSEA), XX) - CALL S2GRID(USSY(1:NSEA), XY) - !! Commented out unnecessary statements below for time being - !! TAUWIX, TAUWIY are in north-east convention and X1,X2 - !! are not actually written out below - !DO ISEA=1, NSEA - ! CABS = SQRT(USSX(ISEA)**2+USSY(ISEA)**2) - ! IF ( CABS .NE. UNDEF ) THEN - ! USSY(ISEA) = MOD ( 630. - & - ! RADE*ATAN2(USSY(ISEA),USSX(ISEA)) , 360. ) - ! ELSE - ! USSY(ISEA) = UNDEF - ! END IF - ! USSX(ISEA) = CABS - ! END DO - !CALL W3S2XY ( NSEA, NSEA, NX+1, NY,USSX,MAPSF, X1 ) - !CALL W3S2XY ( NSEA, NSEA, NX+1, NY,USSY,MAPSF, X2 ) - NFIELD=2 -! + CALL S2GRID(USSX(1:NSEA), XX) + CALL S2GRID(USSY(1:NSEA), XY) + !! Commented out unnecessary statements below for time being + !! TAUWIX, TAUWIY are in north-east convention and X1,X2 + !! are not actually written out below + !DO ISEA=1, NSEA + ! CABS = SQRT(USSX(ISEA)**2+USSY(ISEA)**2) + ! IF ( CABS .NE. UNDEF ) THEN + ! USSY(ISEA) = MOD ( 630. - & + ! RADE*ATAN2(USSY(ISEA),USSX(ISEA)) , 360. ) + ! ELSE + ! USSY(ISEA) = UNDEF + ! END IF + ! USSX(ISEA) = CABS + ! END DO + !CALL W3S2XY ( NSEA, NSEA, NX+1, NY,USSX,MAPSF, X1 ) + !CALL W3S2XY ( NSEA, NSEA, NX+1, NY,USSY,MAPSF, X2 ) + NFIELD=2 + ! ! Power spectral density of equivalent surface pressure - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 7 ) THEN - NFIELD=2 - CALL S2GRID(PRMS(1:NSEA), XX) - CALL S2GRID(TPMS(1:NSEA), XY) -! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 7 ) THEN + NFIELD=2 + CALL S2GRID(PRMS(1:NSEA), XX) + CALL S2GRID(TPMS(1:NSEA), XY) + ! ! Spectral variance of surface stokes drift - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 8 ) THEN - ! Information for spectral distribution of surface Stokes drift (2nd file) - FLFRQ=.TRUE. - NFIELD=2 - I1F=US3DF(2) - I2F=US3DF(3) - DO IK= I1F,I2F + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 8 ) THEN + ! Information for spectral distribution of surface Stokes drift (2nd file) + FLFRQ=.TRUE. + NFIELD=2 + I1F=US3DF(2) + I2F=US3DF(3) + DO IK= I1F,I2F #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, US3D(:,IK), US3D(:,NK+IK), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, US3D(:,IK), US3D(:,NK+IK), AnglD) #endif - CALL S2GRID(US3D(:,IK), XX) - CALL S2GRID(US3D(:,NK+IK), XY) - XXK(:,:,IK)=XX - XYK(:,:,IK)=XY - END DO -! + CALL S2GRID(US3D(:,IK), XX) + CALL S2GRID(US3D(:,NK+IK), XY) + XXK(:,:,IK)=XX + XYK(:,:,IK)=XY + END DO + ! ! Base10 logarithm of power spectral density of equivalent surface pressure - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 9 ) THEN - ! Information for spectral microseismic generation data (2nd file) - FLFRQ=.TRUE. - I1F=P2MSF(2) - I2F=P2MSF(3) - DO IK=I1F,I2F - CALL S2GRID(P2SMS(:,IK), XX) - - IF (NCVARTYPE.EQ.2) THEN - WHERE ( XX.GE.0.) XX = ALOG10(XX*(DWAT*GRAV)**2+1E-12) - ELSE - WHERE ( XX.GE.0.) XX = XX*(DWAT*GRAV)**2 - END IF + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 9 ) THEN + ! Information for spectral microseismic generation data (2nd file) + FLFRQ=.TRUE. + I1F=P2MSF(2) + I2F=P2MSF(3) + DO IK=I1F,I2F + CALL S2GRID(P2SMS(:,IK), XX) + + IF (NCVARTYPE.EQ.2) THEN + WHERE ( XX.GE.0.) XX = ALOG10(XX*(DWAT*GRAV)**2+1E-12) + ELSE + WHERE ( XX.GE.0.) XX = XX*(DWAT*GRAV)**2 + END IF - XK(:,:,IK)=XX - END DO -! + XK(:,:,IK)=XX + END DO + ! ! Wave to sea ice stress - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 10 ) THEN + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 10 ) THEN #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUICE(1:NSEA,1), TAUICE(1:NSEA,2), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUICE(1:NSEA,1), TAUICE(1:NSEA,2), AnglD) #endif - CALL S2GRID(TAUICE(1:NSEA,1), XX) - CALL S2GRID(TAUICE(1:NSEA,2), XY) - NFIELD=2 -! + CALL S2GRID(TAUICE(1:NSEA,1), XX) + CALL S2GRID(TAUICE(1:NSEA,2), XY) + NFIELD=2 + ! ! Wave to sea ice energy flux - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 11 ) THEN - IF (NCVARTYPEI.EQ.3) NCVARTYPE=4 - DO ISEA=1, NSEA - PHIOC(ISEA)=MIN(3000.,PHIOC(ISEA)) - END DO - CALL S2GRID(PHICE(1:NSEA), X1) -! - ! Partitioned surface stokes drift - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 12 ) THEN - ! Information for spectral distribution of surface Stokes drift (2nd file) - FLFRQ=.TRUE. - IF (USSPF(1)==1) THEN - CUSTOMFRQ=.TRUE. - ENDIF - NFIELD=2 - I1F=1 - I2F=USSPF(2) - DO IK= I1F,I2F + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 11 ) THEN + IF (NCVARTYPEI.EQ.3) NCVARTYPE=4 + DO ISEA=1, NSEA + PHIOC(ISEA)=MIN(3000.,PHIOC(ISEA)) + END DO + CALL S2GRID(PHICE(1:NSEA), X1) + ! + ! Partitioned surface stokes drift + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 12 ) THEN + ! Information for spectral distribution of surface Stokes drift (2nd file) + FLFRQ=.TRUE. + IF (USSPF(1)==1) THEN + CUSTOMFRQ=.TRUE. + ENDIF + NFIELD=2 + I1F=1 + I2F=USSPF(2) + DO IK= I1F,I2F #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSP(:,IK), USSP(:,NK+IK), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSP(:,IK), USSP(:,NK+IK), AnglD) #endif - CALL S2GRID(USSP(:,IK), XX) - CALL S2GRID(USSP(:,NK+IK), XY) - XXK(:,:,IK) = XX - XYK(:,:,IK) = XY - END DO -! + CALL S2GRID(USSP(:,IK), XX) + CALL S2GRID(USSP(:,NK+IK), XY) + XXK(:,:,IK) = XX + XYK(:,:,IK) = XY + END DO + ! ! Total momentum to the ocean - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 13 ) THEN + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 13 ) THEN #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOCX(1:NSEA), TAUOCY(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOCX(1:NSEA), TAUOCY(1:NSEA), AnglD) #endif - IF( SMCGRD ) THEN + IF( SMCGRD ) THEN #ifdef W3_SMC - CALL W3S2XY_SMC( TAUOCX(1:NSEA), XX ) - CALL W3S2XY_SMC( TAUOCY(1:NSEA), XY ) + CALL W3S2XY_SMC( TAUOCX(1:NSEA), XX ) + CALL W3S2XY_SMC( TAUOCY(1:NSEA), XY ) #endif - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOCX(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOCY(1:NSEA) & - , MAPSF, XY ) - ENDIF ! SMCGRD - NFIELD=2 -! + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOCX(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOCY(1:NSEA) & + , MAPSF, XY ) + ENDIF ! SMCGRD + NFIELD=2 + ! ! RMS of bottom displacement amplitude - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 1 ) THEN - ! NB: ABA and ABD are the X and Y components of the bottom displacement + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 1 ) THEN + ! NB: ABA and ABD are the X and Y components of the bottom displacement #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, ABA(1:NSEA), ABD(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, ABA(1:NSEA), ABD(1:NSEA), AnglD) #endif - CALL S2GRID(ABA(1:NSEA), XX) - CALL S2GRID(ABD(1:NSEA), XY) - NFIELD=2 -! + CALL S2GRID(ABA(1:NSEA), XX) + CALL S2GRID(ABD(1:NSEA), XY) + NFIELD=2 + ! ! RMS of bottom velocity amplitude - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 2 ) THEN - ! NB: UBA and UBD are the X and Y components of the bottom velocity + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 2 ) THEN + ! NB: UBA and UBD are the X and Y components of the bottom velocity #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UBA(1:NSEA), UBD(1:NSEA), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UBA(1:NSEA), UBD(1:NSEA), AnglD) #endif - CALL S2GRID(UBA(1:NSEA), XX) - CALL S2GRID(UBD(1:NSEA), XY) - NFIELD=2 -! + CALL S2GRID(UBA(1:NSEA), XX) + CALL S2GRID(UBD(1:NSEA), XY) + NFIELD=2 + ! ! Bottom roughness - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 3 ) THEN + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 3 ) THEN #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, BEDFORMS(1:NSEA,2), & - BEDFORMS(1:NSEA,3), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, BEDFORMS(1:NSEA,2), & + BEDFORMS(1:NSEA,3), AnglD) #endif - CALL S2GRID(BEDFORMS(1:NSEA,1), X1) - CALL S2GRID(BEDFORMS(1:NSEA,2), X2) - CALL S2GRID(BEDFORMS(1:NSEA,3), XY) - NFIELD=3 -! + CALL S2GRID(BEDFORMS(1:NSEA,1), X1) + CALL S2GRID(BEDFORMS(1:NSEA,2), X2) + CALL S2GRID(BEDFORMS(1:NSEA,3), XY) + NFIELD=3 + ! ! Wave dissipation in bottom boundary layer - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 4 ) THEN - CALL S2GRID(PHIBBL(1:NSEA), X1) -! + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 4 ) THEN + CALL S2GRID(PHIBBL(1:NSEA), X1) + ! ! Wave to bottom boundary layer stress - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 5 ) THEN + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 5 ) THEN #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUBBL(1:NSEA,1), & - TAUBBL(1:NSEA,2), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUBBL(1:NSEA,1), & + TAUBBL(1:NSEA,2), AnglD) #endif - CALL S2GRID(TAUBBL(1:NSEA,1), XX) - CALL S2GRID(TAUBBL(1:NSEA,2), XY) - NFIELD=2 -! + CALL S2GRID(TAUBBL(1:NSEA,1), XX) + CALL S2GRID(TAUBBL(1:NSEA,2), XY) + NFIELD=2 + ! ! Mean square slope - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 1 ) THEN + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 1 ) THEN #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSSX, MSSY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSSX, MSSY, AnglD) #endif - CALL S2GRID(MSSX, XX) - CALL S2GRID(MSSY, XY) - NFIELD=2 -! + CALL S2GRID(MSSX, XX) + CALL S2GRID(MSSY, XY) + NFIELD=2 + ! ! Phillips constant - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 2 ) THEN + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 2 ) THEN #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSCX, MSCY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSCX, MSCY, AnglD) #endif - CALL S2GRID(MSCX, XX) - CALL S2GRID(MSCY, XY) - NFIELD=2 -! + CALL S2GRID(MSCX, XX) + CALL S2GRID(MSCY, XY) + NFIELD=2 + ! ! u direction for mss - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 3 ) THEN + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 3 ) THEN #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSSD, AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSSD, AnglD, .FALSE.) #endif - DO ISEA=1, NSEA - IF ( MSSD(ISEA) .NE. UNDEF ) THEN - MSSD(ISEA) = MOD ( 630. - RADE*MSSD(ISEA) , 180. ) - END IF - END DO - CALL S2GRID(MSSD, X1) -! + DO ISEA=1, NSEA + IF ( MSSD(ISEA) .NE. UNDEF ) THEN + MSSD(ISEA) = MOD ( 630. - RADE*MSSD(ISEA) , 180. ) + END IF + END DO + CALL S2GRID(MSSD, X1) + ! ! x direction for msc - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 4 ) THEN + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 4 ) THEN #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSCD, AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSCD, AnglD, .FALSE.) #endif - DO ISEA=1, NSEA - IF ( MSCD(ISEA) .NE. UNDEF ) THEN - MSCD(ISEA) = MOD ( 630. - RADE*MSCD(ISEA) , 180. ) - END IF - END DO - CALL S2GRID(MSCD, X1) -! - ! Peakedness - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 5 ) THEN - CALL S2GRID(QP, X1) -! + DO ISEA=1, NSEA + IF ( MSCD(ISEA) .NE. UNDEF ) THEN + MSCD(ISEA) = MOD ( 630. - RADE*MSCD(ISEA) , 180. ) + END IF + END DO + CALL S2GRID(MSCD, X1) + ! + ! Peakedness + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 5 ) THEN + CALL S2GRID(QP, X1) + ! ! Dynamic time step - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN - DO ISEA=1, NSEA - IF ( DTDYN(ISEA) .NE. UNDEF ) THEN - DTDYN(ISEA) = DTDYN(ISEA) / 60. - END IF - END DO - CALL S2GRID(DTDYN, X1) -! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN + DO ISEA=1, NSEA + IF ( DTDYN(ISEA) .NE. UNDEF ) THEN + DTDYN(ISEA) = DTDYN(ISEA) / 60. + END IF + END DO + CALL S2GRID(DTDYN, X1) + ! ! Cut off frequency - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN - CALL S2GRID(FCUT, X1) -! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN + CALL S2GRID(FCUT, X1) + ! ! Maximum CFL for spatial advection - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN - CALL S2GRID(CFLXYMAX, X1) -! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN + CALL S2GRID(CFLXYMAX, X1) + ! ! Maximum CFL for direction advection - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN - CALL S2GRID(CFLTHMAX, X1) -! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN + CALL S2GRID(CFLTHMAX, X1) + ! ! Maximum CFL for frequency advection - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 5 ) THEN - CALL S2GRID(CFLKMAX, X1) -! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 5 ) THEN + CALL S2GRID(CFLKMAX, X1) + ! ! User defined... - ELSE IF ( IFI .EQ. 10 ) THEN - !CB WRITE (ENAME,'(A2,I2.2)') '.u', IFJ - CALL S2GRID(USERO(:,IFJ), X1) - ELSE - WRITE (NDSE,999) IFI, IFJ - CALL EXTCDE ( 1 ) -! - END IF ! IFI AND IFJ + ELSE IF ( IFI .EQ. 10 ) THEN + !CB WRITE (ENAME,'(A2,I2.2)') '.u', IFJ + CALL S2GRID(USERO(:,IFJ), X1) + ELSE + WRITE (NDSE,999) IFI, IFJ + CALL EXTCDE ( 1 ) + ! + END IF ! IFI AND IFJ - ! CB Get netCDF metadata for IFI, IFJ combination (all components). - DO I=1,NFIELD - META(I) = GETMETA(IFI, IFJ, ICOMP=I, IPART=IPART) - ENDDO + ! CB Get netCDF metadata for IFI, IFJ combination (all components). + DO I=1,NFIELD + META(I) = GETMETA(IFI, IFJ, ICOMP=I, IPART=IPART) + ENDDO -! 2.2 Make map + ! 2.2 Make map - ! CB: TODO - need to handle MAPSTA differently for SMC grid output. - IF( .NOT. SMCGRD ) THEN + ! CB: TODO - need to handle MAPSTA differently for SMC grid output. + IF( .NOT. SMCGRD ) THEN DO IX=1, NX DO IY=1, NY MAPOUT(IX,IY)=INT2(MAPSTA(IY,IX) + 8*MAPST2(IY,IX)) @@ -2021,533 +2020,687 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & END IF END DO END DO - ENDIF ! CB + ENDIF ! CB -! 2.3 Setups the output type 4 ( NetCDF file ) + ! 2.3 Setups the output type 4 ( NetCDF file ) - S2=LEN_TRIM(META(1)%ENAME) - S1=LEN_TRIM(FILEPREFIX)+S4 - FNAMENC(S1+1:128)=' ' - FNAMENC(S1+1:S1+1) = '_' + S2=LEN_TRIM(META(1)%ENAME) + S1=LEN_TRIM(FILEPREFIX)+S4 + FNAMENC(S1+1:128)=' ' + FNAMENC(S1+1:S1+1) = '_' - ! If flag TOGETHER and not variable with freq dim & - ! (ef, p2l, ...), no variable name in file name - IF (TOGETHER.AND.(.NOT.FLFRQ)) THEN - S2=0 + ! If flag TOGETHER and not variable with freq dim & + ! (ef, p2l, ...), no variable name in file name + IF (TOGETHER.AND.(.NOT.FLFRQ)) THEN + S2=0 ! If NOT flag TOGETHER or variable with freq dim & ! (ef, p2l, ...), add variable name in file name - ELSE - FNAMENC(S1+2:S1+S2) = META(1)%ENAME(2:S2) - ENDIF - ! Defines the netcdf extension - FNAMENC(S1+S2+1:S1+S2+3) = '.nc' - FNAMENC(S1+S2+4:S1+S2+6) = ' ' - ! If the flag frequency is .TRUE., defines the fourth dimension - IF (FLFRQ) THEN - DIMLN(4)=I2F-I1F+1 - EXTRADIM=1 - ELSE - DIMLN(4)=0 - EXTRADIM=0 - END IF + ELSE + FNAMENC(S1+2:S1+S2) = META(1)%ENAME(2:S2) + ENDIF + ! Defines the netcdf extension + FNAMENC(S1+S2+1:S1+S2+3) = '.nc' + FNAMENC(S1+S2+4:S1+S2+6) = ' ' + ! If the flag frequency is .TRUE., defines the fourth dimension + IF (FLFRQ) THEN + DIMLN(4)=I2F-I1F+1 + EXTRADIM=1 + ELSE + DIMLN(4)=0 + EXTRADIM=0 + END IF - ! If regular grid, initializes the lat/lon or x/y dimension lengths - IF (GTYPE.NE.UNGTYPE) THEN - IF( SMCGRD ) THEN + ! If regular grid, initializes the lat/lon or x/y dimension lengths + IF (GTYPE.NE.UNGTYPE) THEN + IF( SMCGRD ) THEN #ifdef W3_SMC - IF( SMCOTYPE .EQ. 1 ) THEN - ! Flat seapoints file - !dimln(2) = NSEA - dimln(2) = SMCNOUT - dimln(3) = -1 ! not used - ELSE - ! Regular gridded lat/lon file: - dimln(2) = NXO - dimln(3) = NYO - ENDIF ! SMCOTYPE + IF( SMCOTYPE .EQ. 1 ) THEN + ! Flat seapoints file + !dimln(2) = NSEA + dimln(2) = SMCNOUT + dimln(3) = -1 ! not used + ELSE + ! Regular gridded lat/lon file: + dimln(2) = NXO + dimln(3) = NYO + ENDIF ! SMCOTYPE #endif - ELSE ! SMCGRD - DIMLN(2)=IXN-IX1+1 - DIMLN(3)=IYN-IY1+1 - ENDIF ! SMCGRD - ! If unstructured mesh, initializes the nelem,tri dimension lengths - ELSE + ELSE ! SMCGRD DIMLN(2)=IXN-IX1+1 - DIMLN(3)=NTRI - ENDIF + DIMLN(3)=IYN-IY1+1 + ENDIF ! SMCGRD + ! If unstructured mesh, initializes the nelem,tri dimension lengths + ELSE + DIMLN(2)=IXN-IX1+1 + DIMLN(3)=NTRI + ENDIF - ! Defines index of first field variable - IVAR1=21 + ! Defines index of first field variable + IVAR1=21 -! 2.4.1 Save the id of the previous file + ! 2.4.1 Save the id of the previous file - IF (TOGETHER.AND.(.NOT.FLFRQ)) THEN - OLDNCID = NCIDS(1,1,1) - ELSE - OLDNCID = NCIDS(IFI,IFJ,IPART+1) - END IF + IF (TOGETHER.AND.(.NOT.FLFRQ)) THEN + OLDNCID = NCIDS(1,1,1) + ELSE + OLDNCID = NCIDS(IFI,IFJ,IPART+1) + END IF -! 2.4.2 Remove the new file (if not created by the run) + ! 2.4.2 Remove the new file (if not created by the run) - INQUIRE(FILE=FNAMENC, EXIST=FEXIST) - IF (FEXIST) THEN - FREMOVE = .FALSE. - ! time splitted condition - IF (INDEX(TIMEID,OLDTIMEID).EQ.0) THEN - ! all variables in the samefile - IF (TOGETHER.AND.(.NOT.FLFRQ).AND.NCID.EQ.0) FREMOVE = .TRUE. - ! a file per variable - IF (.NOT.TOGETHER.OR.FLFRQ) FREMOVE = .TRUE. - END IF + INQUIRE(FILE=FNAMENC, EXIST=FEXIST) + IF (FEXIST) THEN + FREMOVE = .FALSE. + ! time splitted condition + IF (INDEX(TIMEID,OLDTIMEID).EQ.0) THEN + ! all variables in the samefile + IF (TOGETHER.AND.(.NOT.FLFRQ).AND.NCID.EQ.0) FREMOVE = .TRUE. + ! a file per variable + IF (.NOT.TOGETHER.OR.FLFRQ) FREMOVE = .TRUE. + END IF - IF (FREMOVE) THEN - OPEN(UNIT=1234, IOSTAT=IRET, FILE=FNAMENC, STATUS='old') - IF (IRET == 0) CLOSE(1234, STATUS='delete') - FEXIST=.FALSE. - ELSE - NCID = OLDNCID - END IF + IF (FREMOVE) THEN + OPEN(UNIT=1234, IOSTAT=IRET, FILE=FNAMENC, STATUS='old') + IF (IRET == 0) CLOSE(1234, STATUS='delete') + FEXIST=.FALSE. + ELSE + NCID = OLDNCID END IF + END IF -! 2.4.3 Finalize the previous file (if a new one will be created) + ! 2.4.3 Finalize the previous file (if a new one will be created) - IF (.NOT.FEXIST) THEN - IF (INDEX('0000000000000000',OLDTIMEID).EQ.0 .AND. INDEX(TIMEID,OLDTIMEID).EQ.0) THEN - IRET = NF90_REDEF(OLDNCID) + IF (.NOT.FEXIST) THEN + IF (INDEX('0000000000000000',OLDTIMEID).EQ.0 .AND. INDEX(TIMEID,OLDTIMEID).EQ.0) THEN + IRET = NF90_REDEF(OLDNCID) + CALL CHECK_ERR(IRET) + IF(FL_DEFAULT_GBL_META) THEN + IRET=NF90_PUT_ATT(OLDNCID,NF90_GLOBAL,'stop_date',STRSTOPDATE) CALL CHECK_ERR(IRET) - IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(OLDNCID,NF90_GLOBAL,'stop_date',STRSTOPDATE) - CALL CHECK_ERR(IRET) - ENDIF - IRET=NF90_CLOSE(OLDNCID) - CALL CHECK_ERR(IRET) - END IF + ENDIF + IRET=NF90_CLOSE(OLDNCID) + CALL CHECK_ERR(IRET) END IF + END IF -! 2.5 Creates the netcdf file + ! 2.5 Creates the netcdf file - IF (.NOT.FEXIST) THEN + IF (.NOT.FEXIST) THEN - ! Initializes the time dimension length - DIMLN(1)=1 + ! Initializes the time dimension length + DIMLN(1)=1 - ! If NOT unstructure mesh (i.e. regular grid) -!! CHRISB: VARNM for lat/lon not actually used below. -! IF (GTYPE.NE.UNGTYPE) THEN -! ! If spherical coordinate -! IF (FLAGLL) THEN -! VARNM(NFIELD+1)='Longitude' -! VARNM(NFIELD+2)='Latitude' -! ! If cartesian coordinate -! ELSE -! VARNM(NFIELD+1)='x' -! VARNM(NFIELD+2)='y' -! END IF -! END IF + ! If NOT unstructure mesh (i.e. regular grid) + !! CHRISB: VARNM for lat/lon not actually used below. + ! IF (GTYPE.NE.UNGTYPE) THEN + ! ! If spherical coordinate + ! IF (FLAGLL) THEN + ! VARNM(NFIELD+1)='Longitude' + ! VARNM(NFIELD+2)='Latitude' + ! ! If cartesian coordinate + ! ELSE + ! VARNM(NFIELD+1)='x' + ! VARNM(NFIELD+2)='y' + ! END IF + ! END IF - ! Initializes the time iteration counter n - N=1 + ! Initializes the time iteration counter n + N=1 -! 2.5.1 Creates the NetCDF file - CALL W3CRNC(FNAMENC,NCID,DIMID,DIMLN,VARID, & - EXTRADIM,NCTYPE,MAPSTAOUT) + ! 2.5.1 Creates the NetCDF file + CALL W3CRNC(FNAMENC,NCID,DIMID,DIMLN,VARID, & + EXTRADIM,NCTYPE,MAPSTAOUT) - ! Saves the NCID to keep the file opened to write all the variables - ! and open/close at each time step - IF (TOGETHER.AND.(.NOT.FLFRQ)) THEN - NCIDS(1,1,1)=NCID - ELSE - NCIDS(IFI,IFJ,IPART+1)=NCID - END IF + ! Saves the NCID to keep the file opened to write all the variables + ! and open/close at each time step + IF (TOGETHER.AND.(.NOT.FLFRQ)) THEN + NCIDS(1,1,1)=NCID + ELSE + NCIDS(IFI,IFJ,IPART+1)=NCID + END IF - ! If curvilinear grid, instanciates lat / lon - IF (GTYPE.EQ.CLGTYPE) THEN - IF (.NOT.ALLOCATED(LON2D)) ALLOCATE(LON2D(NX,NY),LAT2D(NX,NY)) - LON2D=TRANSPOSE(XGRD) - LAT2D=TRANSPOSE(YGRD) - IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'latitude_resolution','n/a') - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'longitude_resolution','n/a') - CALL CHECK_ERR(IRET) - ENDIF + ! If curvilinear grid, instanciates lat / lon + IF (GTYPE.EQ.CLGTYPE) THEN + IF (.NOT.ALLOCATED(LON2D)) ALLOCATE(LON2D(NX,NY),LAT2D(NX,NY)) + LON2D=TRANSPOSE(XGRD) + LAT2D=TRANSPOSE(YGRD) + IF(FL_DEFAULT_GBL_META) THEN + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'latitude_resolution','n/a') + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'longitude_resolution','n/a') + CALL CHECK_ERR(IRET) + ENDIF ! If NOT curvilinear grid, - ELSE - IF( SMCGRD ) THEN + ELSE + IF( SMCGRD ) THEN #ifdef W3_SMC - IF(SMCOTYPE .EQ. 1) THEN - ! Flat seapoints file - IF(.NOT.ALLOCATED(lon)) ALLOCATE(lon(SMCNOUT)) - IF(.NOT.ALLOCATED(lat)) ALLOCATE(lat(SMCNOUT)) - IF(.NOT.ALLOCATED(smccx)) ALLOCATE(smccx(SMCNOUT)) - IF(.NOT.ALLOCATED(smccy)) ALLOCATE(smccy(SMCNOUT)) - ELSE - ! Regular gridded file - IF(.NOT.ALLOCATED(lon)) ALLOCATE(lon(NXO)) - IF(.NOT.ALLOCATED(lat)) ALLOCATE(lat(NYO)) + IF(SMCOTYPE .EQ. 1) THEN + ! Flat seapoints file + IF(.NOT.ALLOCATED(lon)) ALLOCATE(lon(SMCNOUT)) + IF(.NOT.ALLOCATED(lat)) ALLOCATE(lat(SMCNOUT)) + IF(.NOT.ALLOCATED(smccx)) ALLOCATE(smccx(SMCNOUT)) + IF(.NOT.ALLOCATED(smccy)) ALLOCATE(smccy(SMCNOUT)) + ELSE + ! Regular gridded file + IF(.NOT.ALLOCATED(lon)) ALLOCATE(lon(NXO)) + IF(.NOT.ALLOCATED(lat)) ALLOCATE(lat(NYO)) #endif #ifdef W3_RTD - ! Intermediate EQUatorial lat/lon arrays for de-rotation - ! of rotated pole coordinates: - !!IF(.NOT.ALLOCATED(LON2DEQ)) ALLOCATE(LON2DEQ(NXO,NYO)) - !!IF(.NOT.ALLOCATED(LAT2DEQ)) ALLOCATE(LAT2DEQ(NXO,NYO)) - ! - ! Use local RTDNX/RTDNY variables until CPP implemented to - ! avoid compile error when SMC switch not enabled (C.Bunney): - IF(.NOT.ALLOCATED(LON2DEQ)) ALLOCATE(LON2DEQ(RTDNX,RTDNY)) - IF(.NOT.ALLOCATED(LAT2DEQ)) ALLOCATE(LAT2DEQ(RTDNX,RTDNY)) + ! Intermediate EQUatorial lat/lon arrays for de-rotation + ! of rotated pole coordinates: + !!IF(.NOT.ALLOCATED(LON2DEQ)) ALLOCATE(LON2DEQ(NXO,NYO)) + !!IF(.NOT.ALLOCATED(LAT2DEQ)) ALLOCATE(LAT2DEQ(NXO,NYO)) + ! + ! Use local RTDNX/RTDNY variables until CPP implemented to + ! avoid compile error when SMC switch not enabled (C.Bunney): + IF(.NOT.ALLOCATED(LON2DEQ)) ALLOCATE(LON2DEQ(RTDNX,RTDNY)) + IF(.NOT.ALLOCATED(LAT2DEQ)) ALLOCATE(LAT2DEQ(RTDNX,RTDNY)) #endif #ifdef W3_SMC - ENDIF + ENDIF #endif #ifdef W3_RTD - ! Arrays for de-rotated lat/lon coordinates: - IF(.NOT.ALLOCATED(LON2D)) THEN - !!ALLOCATE(LON2D(NXO,NYO), LAT2D(NXO,NYO)) - !!ALLOCATE(ANGLD2D(NXO,NYO)) - ! - ! Use local RTDNX/RTDNY variables until CPP implemented to - ! avoid compile error when SMC switch not enabled (C.Bunney): - ALLOCATE(LON2D(RTDNX,RTDNY), LAT2D(RTDNX,RTDNY)) - ALLOCATE(ANGLD2D(RTDNX,RTDNY)) - ENDIF + ! Arrays for de-rotated lat/lon coordinates: + IF(.NOT.ALLOCATED(LON2D)) THEN + !!ALLOCATE(LON2D(NXO,NYO), LAT2D(NXO,NYO)) + !!ALLOCATE(ANGLD2D(NXO,NYO)) + ! + ! Use local RTDNX/RTDNY variables until CPP implemented to + ! avoid compile error when SMC switch not enabled (C.Bunney): + ALLOCATE(LON2D(RTDNX,RTDNY), LAT2D(RTDNX,RTDNY)) + ALLOCATE(ANGLD2D(RTDNX,RTDNY)) + ENDIF #endif - ELSE ! SMCGRD - ! instanciates lon with x/lon for regular grid or nodes for unstructured mesh - IF (.NOT.ALLOCATED(LON)) ALLOCATE(LON(NX)) + ELSE ! SMCGRD + ! instanciates lon with x/lon for regular grid or nodes for unstructured mesh + IF (.NOT.ALLOCATED(LON)) ALLOCATE(LON(NX)) #ifdef W3_RTD - ! 2d longitude array for standard grid coordinates - IF ( RTDL .AND. .NOT.ALLOCATED(LON2D)) & - ALLOCATE(LON2D(NX,NY),LON2DEQ(NX,NY),ANGLD2D(NX,NY)) + ! 2d longitude array for standard grid coordinates + IF ( RTDL .AND. .NOT.ALLOCATED(LON2D)) & + ALLOCATE(LON2D(NX,NY),LON2DEQ(NX,NY),ANGLD2D(NX,NY)) #endif - IF (.NOT.ALLOCATED(LAT)) THEN - ! If regular grid, instanciates lat with y/lat - IF (GTYPE.EQ.RLGTYPE) THEN - ALLOCATE(LAT(NY)) + IF (.NOT.ALLOCATED(LAT)) THEN + ! If regular grid, instanciates lat with y/lat + IF (GTYPE.EQ.RLGTYPE) THEN + ALLOCATE(LAT(NY)) #ifdef W3_RTD - ! 2d latitude array for standard grid coordinates - IF ( RTDL .AND. .NOT.ALLOCATED(LAT2D)) & - ALLOCATE(LAT2D(NX,NY),LAT2DEQ(NX,NY)) + ! 2d latitude array for standard grid coordinates + IF ( RTDL .AND. .NOT.ALLOCATED(LAT2D)) & + ALLOCATE(LAT2D(NX,NY),LAT2DEQ(NX,NY)) #endif ! If unstructured mesh, instanciates lat with nodes - ELSE - ALLOCATE(LAT(NX)) - END IF + ELSE + ALLOCATE(LAT(NX)) END IF - END IF ! SMCGRD - END IF + END IF + END IF ! SMCGRD + END IF -! 2.5.2 Generates Lat-Lon arrays + ! 2.5.2 Generates Lat-Lon arrays - ! If regular grid - IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN - IF( SMCGRD ) THEN + ! If regular grid + IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN + IF( SMCGRD ) THEN #ifdef W3_SMC - ! CB: Calculate lat/lons of SMC grid - IF( SMCOTYPE .EQ. 1 ) THEN - ! CB: Flat seapoints file - DO i=1,SMCNOUT - j = SMCIDX(i) - lon(i) = (X0-0.5*SX) + (IJKCel(1,j) + 0.5 * IJKCel(3,j)) * dlon - lat(i) = (Y0-0.5*SY) + (IJKCel(2,j) + 0.5 * IJKCel(4,j)) * dlat - smccx(i) = IJKCel(3,j) - smccy(i) = IJKCel(4,j) - ENDDO + ! CB: Calculate lat/lons of SMC grid + IF( SMCOTYPE .EQ. 1 ) THEN + ! CB: Flat seapoints file + DO i=1,SMCNOUT + j = SMCIDX(i) + lon(i) = (X0-0.5*SX) + (IJKCel(1,j) + 0.5 * IJKCel(3,j)) * dlon + lat(i) = (Y0-0.5*SY) + (IJKCel(2,j) + 0.5 * IJKCel(4,j)) * dlat + smccx(i) = IJKCel(3,j) + smccy(i) = IJKCel(4,j) + ENDDO #endif #ifdef W3_RTD - !!CALL W3EQTOLL(lat, lon, LAT2D(:,1), LON2D(:,1), & - !! ANGLD2D(:,1), POLAT, POLON, NYO*NXO) - ! - ! Use local RTDNX/RTDNY variables until CPP implemented to - ! avoid compile error when SMC switch not enabled (C.Bunney): - CALL W3EQTOLL(lat, lon, LAT2D(:,1), LON2D(:,1), & - ANGLD2D(:,1), POLAT, POLON, RTDNY*RTDNX) + !!CALL W3EQTOLL(lat, lon, LAT2D(:,1), LON2D(:,1), & + !! ANGLD2D(:,1), POLAT, POLON, NYO*NXO) + ! + ! Use local RTDNX/RTDNY variables until CPP implemented to + ! avoid compile error when SMC switch not enabled (C.Bunney): + CALL W3EQTOLL(lat, lon, LAT2D(:,1), LON2D(:,1), & + ANGLD2D(:,1), POLAT, POLON, RTDNY*RTDNX) #endif #ifdef W3_SMC - ELSE - ! CB: Regridded SMC data - SXD=DBLE(0.000001d0*DNINT(1d6*(DBLE(DXO)) )) - SYD=DBLE(0.000001d0*DNINT(1d6*(DBLE(DYO)) )) - X0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(SXO)) )) - Y0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(SYO)) )) - DO i=1,NXO - lon(i)=REAL(X0D+SXD*DBLE(i-1)) + ELSE + ! CB: Regridded SMC data + SXD=DBLE(0.000001d0*DNINT(1d6*(DBLE(DXO)) )) + SYD=DBLE(0.000001d0*DNINT(1d6*(DBLE(DYO)) )) + X0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(SXO)) )) + Y0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(SYO)) )) + DO i=1,NXO + lon(i)=REAL(X0D+SXD*DBLE(i-1)) #endif #ifdef W3_RTD - LON2DEQ(i,:) = lon(i) + LON2DEQ(i,:) = lon(i) #endif #ifdef W3_SMC - END DO - DO i=1,NYO - lat(i)=REAL(Y0D+SYD*DBLE(i-1)) + END DO + DO i=1,NYO + lat(i)=REAL(Y0D+SYD*DBLE(i-1)) #endif #ifdef W3_RTD - LAT2DEQ(:,i) = lat(i) + LAT2DEQ(:,i) = lat(i) #endif #ifdef W3_SMC - END DO - WRITE(STR2,'(F12.7)') DYO + END DO + WRITE(STR2,'(F12.7)') DYO + STR2=ADJUSTL(STR2) + IF(FL_DEFAULT_GBL_META) THEN + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'latitude_resolution', TRIM(str2)) + WRITE(STR2,'(F12.7)') DXO STR2=ADJUSTL(STR2) - IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'latitude_resolution', TRIM(str2)) - WRITE(STR2,'(F12.7)') DXO - STR2=ADJUSTL(STR2) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'longitude_resolution',TRIM(str2)) - ENDIF + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'longitude_resolution',TRIM(str2)) + ENDIF #endif #ifdef W3_RTD - !!CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & - !! ANGLD2D, POLAT, POLON, NYO*NXO) - ! - ! Use local RTDNX/RTDNY variables until CPP implemented to - ! avoid compile error when SMC switch not enabled (C.Bunney): - CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & - ANGLD2D, POLAT, POLON, RTDNY*RTDNX) + !!CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & + !! ANGLD2D, POLAT, POLON, NYO*NXO) + ! + ! Use local RTDNX/RTDNY variables until CPP implemented to + ! avoid compile error when SMC switch not enabled (C.Bunney): + CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & + ANGLD2D, POLAT, POLON, RTDNY*RTDNX) #endif #ifdef W3_SMC - ENDIF ! SMCOTYPE + ENDIF ! SMCOTYPE #endif - ELSE ! SMCGRD - SXD=DBLE(0.000001d0*DNINT(1d6*(DBLE(SX)) )) - SYD=DBLE(0.000001d0*DNINT(1d6*(DBLE(SY)) )) - X0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(X0)) )) - Y0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(Y0)) )) - DO I=1,NX - LON(I)=REAL(X0D+SXD*DBLE(I-1)) - END DO - DO I=1,NY - LAT(I)=REAL(Y0D+SYD*DBLE(I-1)) - END DO + ELSE ! SMCGRD + SXD=DBLE(0.000001d0*DNINT(1d6*(DBLE(SX)) )) + SYD=DBLE(0.000001d0*DNINT(1d6*(DBLE(SY)) )) + X0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(X0)) )) + Y0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(Y0)) )) + DO I=1,NX + LON(I)=REAL(X0D+SXD*DBLE(I-1)) + END DO + DO I=1,NY + LAT(I)=REAL(Y0D+SYD*DBLE(I-1)) + END DO #ifdef W3_RTD - IF ( RTDL ) THEN - ! Calculate the standard grid coordinates - DO I=1,NX - LON2DEQ(I,:)=LON(I) - END DO - DO I=1,NY - LAT2DEQ(:,I)=LAT(I) - END DO - CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & - ANGLD2D, POLAT, POLON, NY*NX) - END IF ! RTDL + IF ( RTDL ) THEN + ! Calculate the standard grid coordinates + DO I=1,NX + LON2DEQ(I,:)=LON(I) + END DO + DO I=1,NY + LAT2DEQ(:,I)=LAT(I) + END DO + CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & + ANGLD2D, POLAT, POLON, NY*NX) + END IF ! RTDL #endif - IF(FL_DEFAULT_GBL_META) THEN - WRITE(STR2,'(F12.0)') SY - STR2=ADJUSTL(STR2) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'latitude_resolution', TRIM(STR2)) - CALL CHECK_ERR(IRET) - WRITE(STR2,'(F12.0)') SX - STR2=ADJUSTL(STR2) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'longitude_resolution',TRIM(STR2)) - CALL CHECK_ERR(IRET) - ENDIF - END IF ! SMCGRD - END IF - - ! If unstructured mesh - IF (GTYPE.EQ.UNGTYPE) THEN - LON(:)=XGRD(1,:) - LAT(:)=YGRD(1,:) - DIMLN(2)=NX - DIMLN(3)=NTRI IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'latitude_resolution','n/a') + WRITE(STR2,'(F12.0)') SY + STR2=ADJUSTL(STR2) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'latitude_resolution', TRIM(STR2)) CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'longitude_resolution','n/a') + WRITE(STR2,'(F12.0)') SX + STR2=ADJUSTL(STR2) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'longitude_resolution',TRIM(STR2)) CALL CHECK_ERR(IRET) ENDIF - END IF + END IF ! SMCGRD + END IF - ! Finishes declaration part in file by adding geographical bounds + ! If unstructured mesh + IF (GTYPE.EQ.UNGTYPE) THEN + LON(:)=XGRD(1,:) + LAT(:)=YGRD(1,:) + DIMLN(2)=NX + DIMLN(3)=NTRI IF(FL_DEFAULT_GBL_META) THEN - IF(SMCGRD) THEN - WRITE(STR2,'(F12.0)') MINVAL(LAT) - ELSE - WRITE(STR2,'(F12.0)') MINVAL(YGRD) - ENDIF - STR2=ADJUSTL(STR2) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'southernmost_latitude',TRIM(STR2)) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'latitude_resolution','n/a') CALL CHECK_ERR(IRET) - - IF(SMCGRD) THEN - WRITE(STR2,'(F12.0)') MAXVAL(LAT) - ELSE - WRITE(STR2,'(F12.0)') MAXVAL(YGRD) - ENDIF - STR2=ADJUSTL(STR2) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'northernmost_latitude',TRIM(STR2)) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'longitude_resolution','n/a') CALL CHECK_ERR(IRET) + ENDIF + END IF - IF(SMCGRD) THEN - WRITE(STR2,'(F12.0)') MINVAL(LON) - ELSE - WRITE(STR2,'(F12.0)') MINVAL(XGRD) - ENDIF - STR2=ADJUSTL(STR2) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'westernmost_longitude',TRIM(STR2)) - CALL CHECK_ERR(IRET) + ! Finishes declaration part in file by adding geographical bounds + IF(FL_DEFAULT_GBL_META) THEN + IF(SMCGRD) THEN + WRITE(STR2,'(F12.0)') MINVAL(LAT) + ELSE + WRITE(STR2,'(F12.0)') MINVAL(YGRD) + ENDIF + STR2=ADJUSTL(STR2) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'southernmost_latitude',TRIM(STR2)) + CALL CHECK_ERR(IRET) + IF(SMCGRD) THEN + WRITE(STR2,'(F12.0)') MAXVAL(LAT) + ELSE + WRITE(STR2,'(F12.0)') MAXVAL(YGRD) + ENDIF + STR2=ADJUSTL(STR2) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'northernmost_latitude',TRIM(STR2)) + CALL CHECK_ERR(IRET) - IF(SMCGRD) THEN - WRITE(STR2,'(F12.0)') MAXVAL(LON) - ELSE - WRITE(STR2,'(F12.0)') MAXVAL(XGRD) - ENDIF - STR2=ADJUSTL(STR2) + IF(SMCGRD) THEN + WRITE(STR2,'(F12.0)') MINVAL(LON) + ELSE + WRITE(STR2,'(F12.0)') MINVAL(XGRD) + ENDIF + STR2=ADJUSTL(STR2) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'westernmost_longitude',TRIM(STR2)) + CALL CHECK_ERR(IRET) + + + IF(SMCGRD) THEN + WRITE(STR2,'(F12.0)') MAXVAL(LON) + ELSE + WRITE(STR2,'(F12.0)') MAXVAL(XGRD) + ENDIF + STR2=ADJUSTL(STR2) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'easternmost_longitude',TRIM(STR2)) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'minimum_altitude','-12000 m') + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'maximum_altitude','9000 m') + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'altitude_resolution','n/a') + CALL CHECK_ERR(IRET) + +#ifdef W3_RTD + IF ( RTDL ) THEN IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'easternmost_longitude',TRIM(STR2)) - CALL CHECK_ERR(IRET) + 'grid_north_pole_latitude',POLAT) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'minimum_altitude','-12000 m') + 'grid_north_pole_longitude',POLON) + END IF +#endif + ENDIF ! FL_DEFAULT_GBL_META + + CALL T2D(TIME,STARTDATE,IERR) + WRITE(STRSTARTDATE,'(I4.4,A,4(I2.2,A),I2.2)') STARTDATE(1),'-',STARTDATE(2),'-', & + STARTDATE(3),' ',STARTDATE(5),':',STARTDATE(6),':',STARTDATE(7) + + ! End of define mode of NetCDF file + IRET = NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET) + + ! 2.5.3 Writes longitudes, latitudes, triangles, frequency and status map (mapsta) to netcdf file + + ! If regular grid + IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN + IF(SMCGRD) THEN ! CB: shelter original code from SMC grid +#ifdef W3_SMC + IRET=NF90_PUT_VAR(NCID,VARID(1),LON(:)) CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'maximum_altitude','9000 m') + IRET=NF90_PUT_VAR(NCID,VARID(2),LAT(:)) CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'altitude_resolution','n/a') + IF(SMCOTYPE .EQ. 1) THEN + ! For type 1 SCM file also put lat/lons and cell sizes: + IRET=NF90_PUT_VAR(NCID,VARID(5),SMCCX) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(6),SMCCY) + CALL CHECK_ERR(IRET) + ENDIF +#endif + ELSE ! SMCGRD + IRET=NF90_PUT_VAR(NCID,VARID(1),LON(IX1:IXN)) CALL CHECK_ERR(IRET) - + IRET=NF90_PUT_VAR(NCID,VARID(2),LAT(IY1:IYN)) + CALL CHECK_ERR(IRET) + ENDIF ! SMCGRD #ifdef W3_RTD - IF ( RTDL ) THEN - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'grid_north_pole_latitude',POLAT) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & - 'grid_north_pole_longitude',POLON) - END IF + IF ( RTDL ) THEN + IRET=NF90_PUT_VAR(NCID,VARID(7),LON2D(IX1:IXN,IY1:IYN)) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(8),LAT2D(IX1:IXN,IY1:IYN)) + CALL CHECK_ERR(IRET) + END IF #endif - ENDIF ! FL_DEFAULT_GBL_META + END IF - CALL T2D(TIME,STARTDATE,IERR) - WRITE(STRSTARTDATE,'(I4.4,A,4(I2.2,A),I2.2)') STARTDATE(1),'-',STARTDATE(2),'-', & - STARTDATE(3),' ',STARTDATE(5),':',STARTDATE(6),':',STARTDATE(7) + ! If curvilinear grid + IF (GTYPE.EQ.CLGTYPE) THEN + IRET=NF90_PUT_VAR(NCID,VARID(1),LON2D(IX1:IXN,IY1:IYN)) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(2),LAT2D(IX1:IXN,IY1:IYN)) + CALL CHECK_ERR(IRET) + END IF - ! End of define mode of NetCDF file - IRET = NF90_ENDDEF(NCID) + ! If unstructured mesh + IF (GTYPE.EQ.UNGTYPE) THEN + IRET=NF90_PUT_VAR(NCID,VARID(1),LON(IX1:IXN)) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(2),LAT(IX1:IXN)) + CALL CHECK_ERR(IRET) + END IF + + ! Writes frequencies to netcdf file + IF (EXTRADIM.EQ.1) THEN + ALLOCATE(FREQ(I2F-I1F+1)) + !BGR Here is where we should tell it what frequencies are. + IF (CUSTOMFRQ) THEN + DO i=1,usspf(2) + FREQ(i)=sqrt(GRAV*USSP_WN(i))*TPIINV + ENDDO + ELSE + DO i=1,I2F-I1F+1 + FREQ(i)=SIG(I1F-1+i)*TPIINV + END DO + ENDIF + IRET=NF90_PUT_VAR(NCID,VARID(10),FREQ) + CALL CHECK_ERR(IRET) + DEALLOCATE(FREQ) + END IF + + ! Writes triangles to netcdf file + IF (GTYPE.EQ.UNGTYPE) THEN + IRET=NF90_PUT_VAR(NCID,VARID(4),TRIGP) + CALL CHECK_ERR(IRET) + END IF + + ! Writes status map array at variable index 2+1+coordtype+idim-4 + IF (MAPSTAOUT) THEN + START(1)=1 + START(2)=1 + COUNT(1)=IXN-IX1+1 + COUNT(2)=IYN-IY1+1 + IF (GTYPE.NE.UNGTYPE) THEN + IRET=NF90_PUT_VAR(NCID,VARID(20),MAPOUT(IX1:IXN,IY1:IYN), & + (/START(1:2)/),(/COUNT(1:2)/)) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(20),MAPOUT(IX1:IXN,1),(/START(1)/),(/COUNT(1)/)) + ENDIF CALL CHECK_ERR(IRET) + END IF -! 2.5.3 Writes longitudes, latitudes, triangles, frequency and status map (mapsta) to netcdf file + ! Write forecast reference time, if requested: + IF (FLGFC) THEN + IF(TIMEUNIT .EQ. 'S') THEN + OUTSECS = TSUBSEC(EPOCHDATE, REFDATE) + IRET = NF90_PUT_VAR(NCID, VARID(12), OUTSECS) + ELSE + OUTJULDAY = TSUB(EPOCHDATE, REFDATE) + IRET = NF90_PUT_VAR(NCID, VARID(12), OUTJULDAY) + ENDIF + CALL CHECK_ERR(IRET) + ENDIF - ! If regular grid - IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN - IF(SMCGRD) THEN ! CB: shelter original code from SMC grid + WRITE (NDSO,973) FNAMENC + + ! 2.5.4 Defines the field(LON,LAT,time) of the variable (i.e. ucur,vcur for current variable) + + IRET = NF90_REDEF(NCID) + CALL CHECK_ERR(IRET) + DO I=1,NFIELD + IVAR=IVAR1+I + IF (COORDTYPE.EQ.1) THEN + IF (NCVARTYPE.EQ.2) THEN + IF( SMCGRD ) THEN #ifdef W3_SMC - IRET=NF90_PUT_VAR(NCID,VARID(1),LON(:)) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(2),LAT(:)) - CALL CHECK_ERR(IRET) - IF(SMCOTYPE .EQ. 1) THEN - ! For type 1 SCM file also put lat/lons and cell sizes: - IRET=NF90_PUT_VAR(NCID,VARID(5),SMCCX) + IF( SMCOTYPE .EQ. 1 ) THEN + ! SMC Flat file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) + ELSE + ! SMC Regridded file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) + ENDIF CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(6),SMCCY) +#endif + ELSE ! SMCGRD + IRET=NF90_DEF_VAR(NCID,META(I)%VARNM, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) + CALL CHECK_ERR(IRET) + ENDIF ! SMCGRD + IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) + IF (NCTYPE.EQ.4) CALL CHECK_ERR(IRET) + ELSE + IF( SMCGRD ) THEN +#ifdef W3_SMC + IF( SMCOTYPE .EQ. 1 ) THEN + ! SMC Flat file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) + ELSE + ! SMC Regridded file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) + ENDIF CALL CHECK_ERR(IRET) - ENDIF #endif - ELSE ! SMCGRD - IRET=NF90_PUT_VAR(NCID,VARID(1),LON(IX1:IXN)) + ELSE ! SMCGRD + IRET=NF90_DEF_VAR(NCID,META(I)%VARNM, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) + CALL CHECK_ERR(IRET) + ENDIF ! SMCGRD + IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) + IF (NCTYPE.EQ.4) CALL CHECK_ERR(IRET) + END IF + ELSE + DIMFIELD(1)=DIMID(2) + DIMFIELD(2)=DIMID(4) + DIMFIELD(3)=DIMID(5) + IF (NCVARTYPE.EQ.2) THEN + IRET = NF90_DEF_VAR(NCID,META(I)%VARNM, NF90_SHORT, DIMFIELD(1:2+EXTRADIM), VARID(IVAR)) CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(2),LAT(IY1:IYN)) + IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) + IF (NCTYPE.EQ.4) CALL CHECK_ERR(IRET) + ELSE + IRET = NF90_DEF_VAR(NCID,META(I)%VARNM, NF90_FLOAT, DIMFIELD(1:2+EXTRADIM), VARID(IVAR)) CALL CHECK_ERR(IRET) - ENDIF ! SMCGRD + IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) + IF (NCTYPE.EQ.4) CALL CHECK_ERR(IRET) + END IF + END IF + + ! Set scale factor to 1.0 if using FLOAT variables for output + IF(NCVARTYPE .GT. 2) META(I)%FSC = 1.0 + + !! CB - USE NEW W3META MODULE + CALL WRITE_META(NCID, VARID(IVAR), META(I), IRET) ! CB + CALL CHECK_ERR(IRET) ! CB + ! + !! CHRISB: Commenting out below - will be handled by w3oundmeta module #ifdef W3_RTD - IF ( RTDL ) THEN - IRET=NF90_PUT_VAR(NCID,VARID(7),LON2D(IX1:IXN,IY1:IYN)) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(8),LAT2D(IX1:IXN,IY1:IYN)) - CALL CHECK_ERR(IRET) - END IF + + ! IF ( RTDL ) THEN + ! ! Add grid mapping attribute for rotated pole grids: + ! IRET=NF90_PUT_ATT(NCID,VARID(IVAR),'grid_mapping', & + ! 'rotated_pole') + ! CALL CHECK_ERR(IRET) + ! END IF + #endif - END IF + END DO + ! + ! put START date in global attribute + IF(FL_DEFAULT_GBL_META) THEN + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'start_date',STRSTARTDATE) + CALL CHECK_ERR(IRET) + ENDIF + ! + IRET = NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET) - ! If curvilinear grid - IF (GTYPE.EQ.CLGTYPE) THEN - IRET=NF90_PUT_VAR(NCID,VARID(1),LON2D(IX1:IXN,IY1:IYN)) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(2),LAT2D(IX1:IXN,IY1:IYN)) - CALL CHECK_ERR(IRET) - END IF - ! If unstructured mesh - IF (GTYPE.EQ.UNGTYPE) THEN - IRET=NF90_PUT_VAR(NCID,VARID(1),LON(IX1:IXN)) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(2),LAT(IX1:IXN)) - CALL CHECK_ERR(IRET) - END IF + ! 2.6 Append data to the existing file - ! Writes frequencies to netcdf file - IF (EXTRADIM.EQ.1) THEN - ALLOCATE(FREQ(I2F-I1F+1)) - !BGR Here is where we should tell it what frequencies are. - IF (CUSTOMFRQ) THEN - DO i=1,usspf(2) - FREQ(i)=sqrt(GRAV*USSP_WN(i))*TPIINV - ENDDO - ELSE - DO i=1,I2F-I1F+1 - FREQ(i)=SIG(I1F-1+i)*TPIINV - END DO - ENDIF - IRET=NF90_PUT_VAR(NCID,VARID(10),FREQ) - CALL CHECK_ERR(IRET) - DEALLOCATE(FREQ) - END IF + ELSE ! FEXIST - ! Writes triangles to netcdf file - IF (GTYPE.EQ.UNGTYPE) THEN - IRET=NF90_PUT_VAR(NCID,VARID(4),TRIGP) - CALL CHECK_ERR(IRET) - END IF + ! 2.6.1 Get the dimensions from the netcdf header - ! Writes status map array at variable index 2+1+coordtype+idim-4 - IF (MAPSTAOUT) THEN - START(1)=1 - START(2)=1 - COUNT(1)=IXN-IX1+1 - COUNT(2)=IYN-IY1+1 - IF (GTYPE.NE.UNGTYPE) THEN - IRET=NF90_PUT_VAR(NCID,VARID(20),MAPOUT(IX1:IXN,IY1:IYN), & - (/START(1:2)/),(/COUNT(1:2)/)) + ! If it is an unstructured mesh + IF (GTYPE.EQ.UNGTYPE) THEN + IRET=NF90_INQ_VARID (NCID, 'tri', VARID(4)) + CALL CHECK_ERR(IRET) + ! If it is a regular grid + ELSE + ! If it is spherical coordinate + IF (FLAGLL) THEN + IF(SMCGRD) THEN +#ifdef W3_SMC + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_INQ_DIMID (NCID, 'seapoint', DIMID(2)) + ELSE + IRET=NF90_INQ_DIMID (NCID, 'longitude', DIMID(2)) + IRET=NF90_INQ_DIMID (NCID, 'latitude', DIMID(3)) + ENDIF +#endif ELSE - IRET=NF90_PUT_VAR(NCID,VARID(20),MAPOUT(IX1:IXN,1),(/START(1)/),(/COUNT(1)/)) - ENDIF - CALL CHECK_ERR(IRET) + IRET=NF90_INQ_DIMID (NCID, 'longitude', DIMID(2)) + IRET=NF90_INQ_DIMID (NCID, 'latitude', DIMID(3)) + ENDIF ! SMCGRD + IRET=NF90_INQ_VARID (NCID, 'longitude', VARID(1)) + IRET=NF90_INQ_VARID (NCID, 'latitude', VARID(2)) + ! If it is cartesian coordinate + ELSE + IRET=NF90_INQ_DIMID (NCID, 'x', DIMID(2)) + IRET=NF90_INQ_VARID (NCID, 'x', VARID(1)) + IRET=NF90_INQ_DIMID (NCID, 'y', DIMID(3)) + IRET=NF90_INQ_VARID (NCID, 'y', VARID(2)) END IF + CALL CHECK_ERR(IRET) + END IF + ! Get the dimension time + IRET=NF90_INQ_DIMID (NCID, 'time', DIMID(4+EXTRADIM)) + IRET=NF90_INQUIRE_DIMENSION (NCID, DIMID(4+EXTRADIM),len=N) + CALL CHECK_ERR(IRET) + IRET=NF90_INQ_VARID (NCID, 'time', VARID(3)) + IF( FLGFC ) THEN + IRET = NF90_INQ_VARID(NCID, 'forecast_period', VARID(11)) + CALL CHECK_ERR(IRET) + ENDIF + ! Get the dimension f + IF (EXTRADIM.EQ.1) IRET=NF90_INQ_DIMID (NCID, 'f', DIMID(4)) - ! Write forecast reference time, if requested: - IF (FLGFC) THEN - IF(TIMEUNIT .EQ. 'S') THEN - OUTSECS = TSUBSEC(EPOCHDATE, REFDATE) - IRET = NF90_PUT_VAR(NCID, VARID(12), OUTSECS) - ELSE - OUTJULDAY = TSUB(EPOCHDATE, REFDATE) - IRET = NF90_PUT_VAR(NCID, VARID(12), OUTJULDAY) - ENDIF - CALL CHECK_ERR(IRET) - ENDIF + ! 2.6.2 Increments the time step for existing file - WRITE (NDSO,973) FNAMENC + ! If it is the first field of the file in mode together + ! or NOT together or variable with freq dim (ef or p2l) + ! ChrisBunney: Also - check IPART=TABIPART in case first + ! requested output is a partitioned field. + IF((TOGETHER .AND. IFI.EQ.I1 .AND. IFJ.EQ.J1 .AND. IPART.EQ.TABIPART(1)) & + .OR.(.NOT.TOGETHER).OR.FLFRQ) n=n+1 -! 2.5.4 Defines the field(LON,LAT,time) of the variable (i.e. ucur,vcur for current variable) + ! 2.6.3 Defines or gets the variables identifiers + ! If it is the first time step, define all the variables and attributes + IF (N.EQ.1) THEN IRET = NF90_REDEF(NCID) CALL CHECK_ERR(IRET) + + ! Loops on all the fields of the variable (i.e. ucur/vcur for current) DO I=1,NFIELD IVAR=IVAR1+I IF (COORDTYPE.EQ.1) THEN @@ -2561,14 +2714,12 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! SMC Regridded file IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) ENDIF - CALL CHECK_ERR(IRET) #endif - ELSE ! SMCGRD - IRET=NF90_DEF_VAR(NCID,META(I)%VARNM, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) + ELSE + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) CALL CHECK_ERR(IRET) ENDIF ! SMCGRD IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) - IF (NCTYPE.EQ.4) CALL CHECK_ERR(IRET) ELSE IF( SMCGRD ) THEN #ifdef W3_SMC @@ -2579,10 +2730,9 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! SMC Regridded file IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) ENDIF - CALL CHECK_ERR(IRET) #endif - ELSE ! SMCGRD - IRET=NF90_DEF_VAR(NCID,META(I)%VARNM, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) + ELSE + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) CALL CHECK_ERR(IRET) ENDIF ! SMCGRD IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) @@ -2593,1104 +2743,953 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & DIMFIELD(2)=DIMID(4) DIMFIELD(3)=DIMID(5) IF (NCVARTYPE.EQ.2) THEN - IRET = NF90_DEF_VAR(NCID,META(I)%VARNM, NF90_SHORT, DIMFIELD(1:2+EXTRADIM), VARID(IVAR)) + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMFIELD(1:2+EXTRADIM), VARID(IVAR)) CALL CHECK_ERR(IRET) IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) IF (NCTYPE.EQ.4) CALL CHECK_ERR(IRET) - ELSE - IRET = NF90_DEF_VAR(NCID,META(I)%VARNM, NF90_FLOAT, DIMFIELD(1:2+EXTRADIM), VARID(IVAR)) + ELSE + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMFIELD(1:2+EXTRADIM), VARID(IVAR)) CALL CHECK_ERR(IRET) IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) - IF (NCTYPE.EQ.4) CALL CHECK_ERR(IRET) - END IF + CALL CHECK_ERR(IRET) + END IF END IF - + ! ! Set scale factor to 1.0 if using FLOAT variables for output IF(NCVARTYPE .GT. 2) META(I)%FSC = 1.0 !! CB - USE NEW W3META MODULE CALL WRITE_META(NCID, VARID(IVAR), META(I), IRET) ! CB CALL CHECK_ERR(IRET) ! CB -! - !! CHRISB: Commenting out below - will be handled by w3oundmeta module + ! + !! CHRISB: Commenting out below - will be handled by w3oundmeta module #ifdef W3_RTD - ! IF ( RTDL ) THEN - ! ! Add grid mapping attribute for rotated pole grids: - ! IRET=NF90_PUT_ATT(NCID,VARID(IVAR),'grid_mapping', & - ! 'rotated_pole') - ! CALL CHECK_ERR(IRET) - ! END IF + ! IF ( RTDL ) THEN + ! ! Add grid mapping attribute for rotated pole grids: + ! IRET=NF90_PUT_ATT(NCID,VARID(IVAR),'grid_mapping', & + ! 'rotated_pole') + ! CALL CHECK_ERR(IRET) + ! END IF #endif END DO -! - ! put START date in global attribute - IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'start_date',STRSTARTDATE) - CALL CHECK_ERR(IRET) - ENDIF -! IRET = NF90_ENDDEF(NCID) CALL CHECK_ERR(IRET) - -! 2.6 Append data to the existing file - - ELSE ! FEXIST - -! 2.6.1 Get the dimensions from the netcdf header - - ! If it is an unstructured mesh - IF (GTYPE.EQ.UNGTYPE) THEN - IRET=NF90_INQ_VARID (NCID, 'tri', VARID(4)) - CALL CHECK_ERR(IRET) - ! If it is a regular grid - ELSE - ! If it is spherical coordinate - IF (FLAGLL) THEN - IF(SMCGRD) THEN -#ifdef W3_SMC - IF(SMCOTYPE .EQ. 1) THEN - IRET=NF90_INQ_DIMID (NCID, 'seapoint', DIMID(2)) - ELSE - IRET=NF90_INQ_DIMID (NCID, 'longitude', DIMID(2)) - IRET=NF90_INQ_DIMID (NCID, 'latitude', DIMID(3)) - ENDIF -#endif - ELSE - IRET=NF90_INQ_DIMID (NCID, 'longitude', DIMID(2)) - IRET=NF90_INQ_DIMID (NCID, 'latitude', DIMID(3)) - ENDIF ! SMCGRD - IRET=NF90_INQ_VARID (NCID, 'longitude', VARID(1)) - IRET=NF90_INQ_VARID (NCID, 'latitude', VARID(2)) - ! If it is cartesian coordinate - ELSE - IRET=NF90_INQ_DIMID (NCID, 'x', DIMID(2)) - IRET=NF90_INQ_VARID (NCID, 'x', VARID(1)) - IRET=NF90_INQ_DIMID (NCID, 'y', DIMID(3)) - IRET=NF90_INQ_VARID (NCID, 'y', VARID(2)) - END IF - CALL CHECK_ERR(IRET) - END IF - ! Get the dimension time - IRET=NF90_INQ_DIMID (NCID, 'time', DIMID(4+EXTRADIM)) - IRET=NF90_INQUIRE_DIMENSION (NCID, DIMID(4+EXTRADIM),len=N) + ! If it is not the first time step, get all VARID from the netcdf file opened + ELSE + IRET=NF90_REDEF(NCID) CALL CHECK_ERR(IRET) - IRET=NF90_INQ_VARID (NCID, 'time', VARID(3)) - IF( FLGFC ) THEN - IRET = NF90_INQ_VARID(NCID, 'forecast_period', VARID(11)) + DO I=1,NFIELD + ! Get meta-data for field + !META = GETMETA(IFI, IFJ, ICOMP=I, IPART=IPART) + IVAR=IVAR1+I + IRET=NF90_INQ_VARID (NCID, META(I)%VARNM, VARID(IVAR)) CALL CHECK_ERR(IRET) - ENDIF - ! Get the dimension f - IF (EXTRADIM.EQ.1) IRET=NF90_INQ_DIMID (NCID, 'f', DIMID(4)) - -! 2.6.2 Increments the time step for existing file - - ! If it is the first field of the file in mode together - ! or NOT together or variable with freq dim (ef or p2l) - ! ChrisBunney: Also - check IPART=TABIPART in case first - ! requested output is a partitioned field. - IF((TOGETHER .AND. IFI.EQ.I1 .AND. IFJ.EQ.J1 .AND. IPART.EQ.TABIPART(1)) & - .OR.(.NOT.TOGETHER).OR.FLFRQ) n=n+1 + END DO + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET) + END IF ! N.EQ.1 + END IF ! FEXIST + + ! 2.6.4 Defines the current time step and index + + CALL T2D(TIME,CURDATE,IERR) + WRITE(NDSO,'(A,A9,A,I6,A,I4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2,2A)') & + 'Writing new record ', META(1)%ENAME(2:) ,'number ',N, & + ' for ',CURDATE(1),':',CURDATE(2),':',CURDATE(3),'T',CURDATE(5),& + ':',CURDATE(6),':',CURDATE(7),' in file ',TRIM(FNAMENC) + + + + ! Defines starting point and size of arrays to be written + START(1)=1 + START(2)=1 + START(3)=1 + START(4)=1 + + ! Sets time index + START(3+1-COORDTYPE+EXTRADIM)=N + COUNT(1)=IXN-IX1+1 + COUNT(2)=IYN-IY1+1 + COUNT(3)=1 + COUNT(4)=1 + START1D(1)=1 + START1D(2)=N + COUNT1D(1)=IXN-IX1+1 + COUNT1D(2)=1 + + ! Puts time in NetCDF file + IF((IFI.EQ.I1.AND.IFJ.EQ.J1.AND.TOGETHER) & + .OR.(.NOT.TOGETHER).OR.FLFRQ) THEN + IVAR1 = 21 -! 2.6.3 Defines or gets the variables identifiers + IF(TIMEUNIT .EQ. 'S') THEN + ! Time in seconds + OUTSECS = TSUBSEC(EPOCHDATE,CURDATE) + IRET = NF90_PUT_VAR(NCID, VARID(3), OUTSECS, (/N/)) + ELSE + ! Time in days + OUTJULDAY = TSUB(EPOCHDATE,CURDATE) + IRET = NF90_PUT_VAR(NCID, VARID(3), OUTJULDAY, (/N/)) + ENDIF + CALL CHECK_ERR(IRET) - ! If it is the first time step, define all the variables and attributes - IF (N.EQ.1) THEN - IRET = NF90_REDEF(NCID) - CALL CHECK_ERR(IRET) + ! ChrisB: Calculate forecast period w.r.t. forecast reference time: + IF (FLGFC) THEN + OUTSECS = TSUBSEC(REFDATE, CURDATE) + IRET = NF90_PUT_VAR(NCID, VARID(11), OUTSECS, (/N/)) + CALL CHECK_ERR(IRET) + ENDIF + END IF + ! + ! 2.6.5 Puts field(s) in NetCDF file - ! Loops on all the fields of the variable (i.e. ucur/vcur for current) - DO I=1,NFIELD - IVAR=IVAR1+I - IF (COORDTYPE.EQ.1) THEN - IF (NCVARTYPE.EQ.2) THEN - IF( SMCGRD ) THEN + ! NFIELD=3 + IF (NCVARTYPE.EQ.2) THEN + IF ( NFIELD.EQ.3 ) THEN + IF (SMCGRD) THEN #ifdef W3_SMC - IF( SMCOTYPE .EQ. 1 ) THEN - ! SMC Flat file - IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) - ELSE - ! SMC Regridded file - IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) - ENDIF -#endif - ELSE - IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) - CALL CHECK_ERR(IRET) - ENDIF ! SMCGRD - IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( X1(IX,IY) .EQ. UNDEF ) THEN + MXX(IX,IY) = MFILL + MYY(IX,IY) = MFILL + MXY(IX,IY) = MFILL ELSE - IF( SMCGRD ) THEN -#ifdef W3_SMC - IF( SMCOTYPE .EQ. 1 ) THEN - ! SMC Flat file - IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) - ELSE - ! SMC Regridded file - IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) - ENDIF -#endif - ELSE - IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) - CALL CHECK_ERR(IRET) - ENDIF ! SMCGRD - IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) - IF (NCTYPE.EQ.4) CALL CHECK_ERR(IRET) + MXX(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) + MYY(IX,IY) = NINT(X2(IX,IY)/META(2)%FSC) + MXY(IX,IY) = NINT(XY(IX,IY)/META(3)%FSC) END IF - ELSE - DIMFIELD(1)=DIMID(2) - DIMFIELD(2)=DIMID(4) - DIMFIELD(3)=DIMID(5) - IF (NCVARTYPE.EQ.2) THEN - IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMFIELD(1:2+EXTRADIM), VARID(IVAR)) - CALL CHECK_ERR(IRET) - IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) - IF (NCTYPE.EQ.4) CALL CHECK_ERR(IRET) + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & + MXY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & + MXY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF +#endif + ELSE ! IF(SMCGRD) + DO IX=IX1, IXN + DO IY=IY1, IYN + IF ( MAPSTA(IY,IX) .LE. 0 .OR. X1(IX,IY) .EQ. UNDEF ) THEN + MXX(IX,IY) = MFILL + MYY(IX,IY) = MFILL + MXY(IX,IY) = MFILL ELSE - IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMFIELD(1:2+EXTRADIM), VARID(IVAR)) - CALL CHECK_ERR(IRET) - IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) - CALL CHECK_ERR(IRET) + MXX(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) + MYY(IX,IY) = NINT(X2(IX,IY)/META(2)%FSC) + MXY(IX,IY) = NINT(XY(IX,IY)/META(3)%FSC) END IF - END IF -! - ! Set scale factor to 1.0 if using FLOAT variables for output - IF(NCVARTYPE .GT. 2) META(I)%FSC = 1.0 - - !! CB - USE NEW W3META MODULE - CALL WRITE_META(NCID, VARID(IVAR), META(I), IRET) ! CB - CALL CHECK_ERR(IRET) ! CB -! - !! CHRISB: Commenting out below - will be handled by w3oundmeta module -#ifdef W3_RTD - - ! IF ( RTDL ) THEN - ! ! Add grid mapping attribute for rotated pole grids: - ! IRET=NF90_PUT_ATT(NCID,VARID(IVAR),'grid_mapping', & - ! 'rotated_pole') - ! CALL CHECK_ERR(IRET) - ! END IF - -#endif + END DO END DO - IRET = NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET) - ! If it is not the first time step, get all VARID from the netcdf file opened - ELSE - IRET=NF90_REDEF(NCID) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) CALL CHECK_ERR(IRET) - DO I=1,NFIELD - ! Get meta-data for field - !META = GETMETA(IFI, IFJ, ICOMP=I, IPART=IPART) - IVAR=IVAR1+I - IRET=NF90_INQ_VARID (NCID, META(I)%VARNM, VARID(IVAR)) - CALL CHECK_ERR(IRET) - END DO - IRET=NF90_ENDDEF(NCID) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) CALL CHECK_ERR(IRET) - END IF ! N.EQ.1 - END IF ! FEXIST - -! 2.6.4 Defines the current time step and index - - CALL T2D(TIME,CURDATE,IERR) - WRITE(NDSO,'(A,A9,A,I6,A,I4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2,2A)') & - 'Writing new record ', META(1)%ENAME(2:) ,'number ',N, & - ' for ',CURDATE(1),':',CURDATE(2),':',CURDATE(3),'T',CURDATE(5),& - ':',CURDATE(6),':',CURDATE(7),' in file ',TRIM(FNAMENC) - - - - ! Defines starting point and size of arrays to be written - START(1)=1 - START(2)=1 - START(3)=1 - START(4)=1 - - ! Sets time index - START(3+1-COORDTYPE+EXTRADIM)=N - COUNT(1)=IXN-IX1+1 - COUNT(2)=IYN-IY1+1 - COUNT(3)=1 - COUNT(4)=1 - START1D(1)=1 - START1D(2)=N - COUNT1D(1)=IXN-IX1+1 - COUNT1D(2)=1 - - ! Puts time in NetCDF file - IF((IFI.EQ.I1.AND.IFJ.EQ.J1.AND.TOGETHER) & - .OR.(.NOT.TOGETHER).OR.FLFRQ) THEN - IVAR1 = 21 - - IF(TIMEUNIT .EQ. 'S') THEN - ! Time in seconds - OUTSECS = TSUBSEC(EPOCHDATE,CURDATE) - IRET = NF90_PUT_VAR(NCID, VARID(3), OUTSECS, (/N/)) - ELSE - ! Time in days - OUTJULDAY = TSUB(EPOCHDATE,CURDATE) - IRET = NF90_PUT_VAR(NCID, VARID(3), OUTJULDAY, (/N/)) - ENDIF - CALL CHECK_ERR(IRET) - - ! ChrisB: Calculate forecast period w.r.t. forecast reference time: - IF (FLGFC) THEN - OUTSECS = TSUBSEC(REFDATE, CURDATE) - IRET = NF90_PUT_VAR(NCID, VARID(11), OUTSECS, (/N/)) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & + MXY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) CALL CHECK_ERR(IRET) - ENDIF - END IF -! -! 2.6.5 Puts field(s) in NetCDF file - -! NFIELD=3 - IF (NCVARTYPE.EQ.2) THEN - IF ( NFIELD.EQ.3 ) THEN + ENDIF ! SMCGRD + ! NFIELD=2 + ELSE IF (NFIELD.EQ.2 ) THEN + ! EXTRADIM=0 + IF (EXTRADIM.EQ.0) THEN IF (SMCGRD) THEN #ifdef W3_SMC DO IX=IX1, IXN DO IY=IY1, IYN ! TODO: Find some other way to access MAPSTA - IF ( X1(IX,IY) .EQ. UNDEF ) THEN + IF ( XX(IX,IY) .EQ. UNDEF ) THEN MXX(IX,IY) = MFILL MYY(IX,IY) = MFILL - MXY(IX,IY) = MFILL ELSE - MXX(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) - MYY(IX,IY) = NINT(X2(IX,IY)/META(2)%FSC) - MXY(IX,IY) = NINT(XY(IX,IY)/META(3)%FSC) + MXX(IX,IY) = NINT(XX(IX,IY)/META(1)%FSC) + MYY(IX,IY) = NINT(XY(IX,IY)/META(2)%FSC) END IF END DO END DO IF(SMCOTYPE .EQ. 1) THEN IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXX(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + MXX(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) call CHECK_ERR(IRET) IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) - call CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & - MXY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + MYY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) call CHECK_ERR(IRET) ELSE IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) call CHECK_ERR(IRET) IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - call CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & - MXY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) call CHECK_ERR(IRET) ENDIF #endif ELSE ! IF(SMCGRD) DO IX=IX1, IXN DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR. X1(IX,IY) .EQ. UNDEF ) THEN + IF ( MAPSTA(IY,IX) .LE. 0 .OR. XX(IX,IY) .EQ. UNDEF ) THEN MXX(IX,IY) = MFILL MYY(IX,IY) = MFILL - MXY(IX,IY) = MFILL ELSE - MXX(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) - MYY(IX,IY) = NINT(X2(IX,IY)/META(2)%FSC) - MXY(IX,IY) = NINT(XY(IX,IY)/META(3)%FSC) + !PRINT*,XX(IX,IY),XY(IX,IY) + !STOP + MXX(IX,IY) = NINT(XX(IX,IY)/META(1)%FSC) + MYY(IX,IY) = NINT(XY(IX,IY)/META(2)%FSC) END IF END DO END DO - - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & - MXY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) CALL CHECK_ERR(IRET) ENDIF ! SMCGRD -! NFIELD=2 - ELSE IF (NFIELD.EQ.2 ) THEN -! EXTRADIM=0 - IF (EXTRADIM.EQ.0) THEN + ! EXTRADIM=1 + ELSE + START(3+1-COORDTYPE)=0 + DO IK=I1F,I2F + START(3+1-COORDTYPE)=START(3+1-COORDTYPE)+1 + IF (SMCGRD) THEN #ifdef W3_SMC DO IX=IX1, IXN DO IY=IY1, IYN ! TODO: Find some other way to access MAPSTA - IF ( XX(IX,IY) .EQ. UNDEF ) THEN + IF ( XXK(IX,IY,IK) .EQ. UNDEF ) THEN MXX(IX,IY) = MFILL MYY(IX,IY) = MFILL ELSE - MXX(IX,IY) = NINT(XX(IX,IY)/META(1)%FSC) - MYY(IX,IY) = NINT(XY(IX,IY)/META(2)%FSC) + MXX(IX,IY) = NINT(XXK(IX,IY,IK)/META(1)%FSC) + MYY(IX,IY) = NINT(XYK(IX,IY,IK)/META(2)%FSC) END IF END DO END DO IF(SMCOTYPE .EQ. 1) THEN - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXX(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1), START(3), START(4)/), & + (/COUNT(1), COUNT(3), COUNT(4)/)) call CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MXY(IX1:IXN,IY1:IYN),(/START(1), START(3), START(4)/), & + (/COUNT(1), COUNT(3), COUNT(4)/)) call CHECK_ERR(IRET) ELSE IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MXX(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) call CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) call CHECK_ERR(IRET) ENDIF #endif ELSE ! IF(SMCGRD) DO IX=IX1, IXN DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR. XX(IX,IY) .EQ. UNDEF ) THEN + IF ( MAPSTA(IY,IX) .LE. 0 .OR.XXK(IX,IY,IK) .EQ. UNDEF ) THEN MXX(IX,IY) = MFILL MYY(IX,IY) = MFILL ELSE - !PRINT*,XX(IX,IY),XY(IX,IY) - !STOP - MXX(IX,IY) = NINT(XX(IX,IY)/META(1)%FSC) - MYY(IX,IY) = NINT(XY(IX,IY)/META(2)%FSC) + MXX(IX,IY) = NINT(XXK(IX,IY,IK)/META(1)%FSC) + MYY(IX,IY) = NINT(XYK(IX,IY,IK)/META(2)%FSC) END IF END DO END DO - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYY(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) ENDIF ! SMCGRD -! EXTRADIM=1 - ELSE - START(3+1-COORDTYPE)=0 - DO IK=I1F,I2F - START(3+1-COORDTYPE)=START(3+1-COORDTYPE)+1 - - IF (SMCGRD) THEN + END DO + END IF ! EXTRADIM + ! NFIELD=1 + ELSE + ! EXTRADIM=0 + IF (EXTRADIM.EQ.0) THEN + IF (SMCGRD) THEN #ifdef W3_SMC - DO IX=IX1, IXN - DO IY=IY1, IYN - ! TODO: Find some other way to access MAPSTA - IF ( XXK(IX,IY,IK) .EQ. UNDEF ) THEN - MXX(IX,IY) = MFILL - MYY(IX,IY) = MFILL - ELSE - MXX(IX,IY) = NINT(XXK(IX,IY,IK)/META(1)%FSC) - MYY(IX,IY) = NINT(XYK(IX,IY,IK)/META(2)%FSC) - END IF - END DO - END DO - IF(SMCOTYPE .EQ. 1) THEN - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXX(IX1:IXN,IY1:IYN),(/START(1), START(3), START(4)/), & - (/COUNT(1), COUNT(3), COUNT(4)/)) - call CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MXY(IX1:IXN,IY1:IYN),(/START(1), START(3), START(4)/), & - (/COUNT(1), COUNT(3), COUNT(4)/)) - call CHECK_ERR(IRET) + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( X1(IX,IY) .EQ. UNDEF ) THEN + MX1(IX,IY) = MFILL ELSE - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXX(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) - call CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXX(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) - call CHECK_ERR(IRET) - ENDIF + MX1(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF #endif - ELSE ! IF(SMCGRD) - DO IX=IX1, IXN - DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR.XXK(IX,IY,IK) .EQ. UNDEF ) THEN - MXX(IX,IY) = MFILL - MYY(IX,IY) = MFILL - ELSE - MXX(IX,IY) = NINT(XXK(IX,IY,IK)/META(1)%FSC) - MYY(IX,IY) = NINT(XYK(IX,IY,IK)/META(2)%FSC) - END IF - END DO - END DO - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXX(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYY(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) - ENDIF ! SMCGRD + ELSE ! IF(SMCGRD) + DO IX=IX1, IXN + DO IY=IY1, IYN + IF ( MAPSTA(IY,IX) .LE. 0 .OR.X1(IX,IY) .EQ. UNDEF ) THEN + MX1(IX,IY) = MFILL + ELSE + MX1(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) + END IF + END DO END DO - END IF ! EXTRADIM -! NFIELD=1 + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + CALL CHECK_ERR(IRET) + ENDIF ! SMCGRD + ! EXTRADIM=1 ELSE -! EXTRADIM=0 - IF (EXTRADIM.EQ.0) THEN + START(3+1-COORDTYPE)=0 + DO IK=I1F,I2F + START(3+1-COORDTYPE)=START(3+1-COORDTYPE)+1 + IF (SMCGRD) THEN #ifdef W3_SMC DO IX=IX1, IXN DO IY=IY1, IYN ! TODO: Find some other way to access MAPSTA - IF ( X1(IX,IY) .EQ. UNDEF ) THEN + IF ( XK(IX,IY,IK) .EQ. UNDEF ) THEN MX1(IX,IY) = MFILL ELSE - MX1(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) + MX1(IX,IY) = NINT(XK(IX,IY,IK)/META(1)%FSC) END IF END DO END DO IF(SMCOTYPE .EQ. 1) THEN IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + MX1(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) call CHECK_ERR(IRET) ELSE IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MX1(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) call CHECK_ERR(IRET) ENDIF #endif ELSE ! IF(SMCGRD) DO IX=IX1, IXN DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR.X1(IX,IY) .EQ. UNDEF ) THEN + IF ( MAPSTA(IY,IX) .LE. 0 .OR.XK(IX,IY,IK) .EQ. UNDEF ) THEN MX1(IX,IY) = MFILL ELSE - MX1(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) + MX1(IX,IY) = NINT(XK(IX,IY,IK)/META(1)%FSC) END IF END DO END DO IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MX1(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) CALL CHECK_ERR(IRET) ENDIF ! SMCGRD -! EXTRADIM=1 - ELSE - START(3+1-COORDTYPE)=0 - DO IK=I1F,I2F - START(3+1-COORDTYPE)=START(3+1-COORDTYPE)+1 - - IF (SMCGRD) THEN + END DO + END IF ! EXTRADIM + END IF ! NFIELD + ! + ! Real output (NCVARTYPE.GE.3) + ! + ELSE + IF ( NFIELD.EQ.3 ) THEN + IF (SMCGRD) THEN #ifdef W3_SMC - DO IX=IX1, IXN - DO IY=IY1, IYN - ! TODO: Find some other way to access MAPSTA - IF ( XK(IX,IY,IK) .EQ. UNDEF ) THEN - MX1(IX,IY) = MFILL - ELSE - MX1(IX,IY) = NINT(XK(IX,IY,IK)/META(1)%FSC) - END IF - END DO - END DO - IF(SMCOTYPE .EQ. 1) THEN - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) - call CHECK_ERR(IRET) - ELSE - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - call CHECK_ERR(IRET) - ENDIF + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( X1(IX,IY) .EQ. UNDEF ) THEN + MXXR(IX,IY) = MFILLR + MYYR(IX,IY) = MFILLR + MXYR(IX,IY) = MFILLR + ELSE + MXXR(IX,IY) = X1(IX,IY) + MYYR(IX,IY) = X2(IX,IY) + MXYR(IX,IY) = XY(IX,IY) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & + MXYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & + MXYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF #endif - ELSE ! IF(SMCGRD) - DO IX=IX1, IXN - DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR.XK(IX,IY,IK) .EQ. UNDEF ) THEN - MX1(IX,IY) = MFILL - ELSE - MX1(IX,IY) = NINT(XK(IX,IY,IK)/META(1)%FSC) - END IF - END DO - END DO - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) - CALL CHECK_ERR(IRET) - ENDIF ! SMCGRD + ELSE ! IF(SMCGRD) + DO IX=IX1, IXN + DO IY=IY1, IYN + IF ( MAPSTA(IY,IX) .LE. 0 .OR. X1(IX,IY) .EQ. UNDEF ) THEN + MXXR(IX,IY) = MFILLR + MYYR(IX,IY) = MFILLR + MXYR(IX,IY) = MFILLR + ELSE + MXXR(IX,IY) = X1(IX,IY) + MYYR(IX,IY) = X2(IX,IY) + MXYR(IX,IY) = XY(IX,IY) + END IF END DO - END IF ! EXTRADIM - END IF ! NFIELD -! -! Real output (NCVARTYPE.GE.3) -! - ELSE - IF ( NFIELD.EQ.3 ) THEN + END DO + + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & + MXYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + CALL CHECK_ERR(IRET) + ENDIF ! SMCGRD + ! NFIELD=2 + ELSE IF (NFIELD.EQ.2 ) THEN + ! EXTRADIM=0 + IF (EXTRADIM.EQ.0) THEN IF (SMCGRD) THEN #ifdef W3_SMC DO IX=IX1, IXN DO IY=IY1, IYN ! TODO: Find some other way to access MAPSTA - IF ( X1(IX,IY) .EQ. UNDEF ) THEN + IF ( XX(IX,IY) .EQ. UNDEF ) THEN MXXR(IX,IY) = MFILLR MYYR(IX,IY) = MFILLR - MXYR(IX,IY) = MFILLR ELSE - MXXR(IX,IY) = X1(IX,IY) - MYYR(IX,IY) = X2(IX,IY) - MXYR(IX,IY) = XY(IX,IY) + MXXR(IX,IY) = XX(IX,IY) + MYYR(IX,IY) = XY(IX,IY) END IF END DO END DO IF(SMCOTYPE .EQ. 1) THEN IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) call CHECK_ERR(IRET) IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) - call CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & - MXYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) call CHECK_ERR(IRET) ELSE IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) call CHECK_ERR(IRET) IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - call CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & - MXYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) call CHECK_ERR(IRET) ENDIF #endif - ELSE ! IF(SMCGRD) + ELSE ! IF SMCGRD DO IX=IX1, IXN DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR. X1(IX,IY) .EQ. UNDEF ) THEN + IF ( MAPSTA(IY,IX) .LE. 0 .OR. XX(IX,IY) .EQ. UNDEF ) THEN MXXR(IX,IY) = MFILLR MYYR(IX,IY) = MFILLR - MXYR(IX,IY) = MFILLR ELSE - MXXR(IX,IY) = X1(IX,IY) - MYYR(IX,IY) = X2(IX,IY) - MXYR(IX,IY) = XY(IX,IY) + MXXR(IX,IY) = XX(IX,IY) + MYYR(IX,IY) = XY(IX,IY) END IF END DO END DO - - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & - MXYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) CALL CHECK_ERR(IRET) ENDIF ! SMCGRD -! NFIELD=2 - ELSE IF (NFIELD.EQ.2 ) THEN -! EXTRADIM=0 - IF (EXTRADIM.EQ.0) THEN + ! EXTRADIM=1 + ELSE + START(4-COORDTYPE)=0 + DO IK=I1F,I2F + START(4-COORDTYPE)=START(4-COORDTYPE)+1 + IF (SMCGRD) THEN #ifdef W3_SMC DO IX=IX1, IXN DO IY=IY1, IYN ! TODO: Find some other way to access MAPSTA - IF ( XX(IX,IY) .EQ. UNDEF ) THEN + IF ( XXK(IX,IY,IK) .EQ. UNDEF ) THEN MXXR(IX,IY) = MFILLR MYYR(IX,IY) = MFILLR ELSE - MXXR(IX,IY) = XX(IX,IY) - MYYR(IX,IY) = XY(IX,IY) + MXXR(IX,IY) = XXK(IX,IY,IK) + MYYR(IX,IY) = XYK(IX,IY,IK) END IF END DO END DO IF(SMCOTYPE .EQ. 1) THEN IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) call CHECK_ERR(IRET) IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) call CHECK_ERR(IRET) ELSE IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) call CHECK_ERR(IRET) IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) call CHECK_ERR(IRET) ENDIF #endif ELSE ! IF SMCGRD DO IX=IX1, IXN DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR. XX(IX,IY) .EQ. UNDEF ) THEN + IF ( MAPSTA(IY,IX) .LE. 0 .OR.XXK(IX,IY,IK) .EQ. UNDEF ) THEN MXXR(IX,IY) = MFILLR MYYR(IX,IY) = MFILLR ELSE - MXXR(IX,IY) = XX(IX,IY) - MYYR(IX,IY) = XY(IX,IY) + MXXR(IX,IY) = XXK(IX,IY,IK) + MYYR(IX,IY) = XYK(IX,IY,IK) END IF END DO END DO - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) ENDIF ! SMCGRD - ! EXTRADIM=1 - ELSE - START(4-COORDTYPE)=0 - DO IK=I1F,I2F - START(4-COORDTYPE)=START(4-COORDTYPE)+1 - - IF (SMCGRD) THEN + END DO + END IF ! EXTRADIM + ! NFIELD=1 + ELSE + ! EXTRADIM=0 + IF (EXTRADIM.EQ.0) THEN + IF (SMCGRD) THEN #ifdef W3_SMC - DO IX=IX1, IXN - DO IY=IY1, IYN - ! TODO: Find some other way to access MAPSTA - IF ( XXK(IX,IY,IK) .EQ. UNDEF ) THEN - MXXR(IX,IY) = MFILLR - MYYR(IX,IY) = MFILLR - ELSE - MXXR(IX,IY) = XXK(IX,IY,IK) - MYYR(IX,IY) = XYK(IX,IY,IK) - END IF - END DO - END DO - IF(SMCOTYPE .EQ. 1) THEN - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) - call CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) - call CHECK_ERR(IRET) + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( X1(IX,IY) .EQ. UNDEF ) THEN + MX1R(IX,IY) = MFILLR ELSE - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - call CHECK_ERR(IRET) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - call CHECK_ERR(IRET) - ENDIF + MX1R(IX,IY) = X1(IX,IY) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1R(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1R(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF #endif - ELSE ! IF SMCGRD - DO IX=IX1, IXN - DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR.XXK(IX,IY,IK) .EQ. UNDEF ) THEN - MXXR(IX,IY) = MFILLR - MYYR(IX,IY) = MFILLR - ELSE - MXXR(IX,IY) = XXK(IX,IY,IK) - MYYR(IX,IY) = XYK(IX,IY,IK) - END IF - END DO - END DO - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MXXR(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & - MYYR(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) - ENDIF ! SMCGRD + ELSE ! IF SMCGRD + DO IX=IX1, IXN + DO IY=IY1, IYN + IF ( MAPSTA(IY,IX) .LE. 0 .OR.X1(IX,IY) .EQ. UNDEF ) THEN + MX1R(IX,IY) = MFILLR + ELSE + MX1R(IX,IY) = X1(IX,IY) + END IF + END DO END DO - END IF ! EXTRADIM -! NFIELD=1 + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1R(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + CALL CHECK_ERR(IRET) + ENDIF ! SMCGRD + ! EXTRADIM=1 ELSE -! EXTRADIM=0 - IF (EXTRADIM.EQ.0) THEN + START(4-COORDTYPE)=0 + DO IK=I1F,I2F + START(4-COORDTYPE)=START(4-COORDTYPE)+1 IF (SMCGRD) THEN #ifdef W3_SMC DO IX=IX1, IXN DO IY=IY1, IYN ! TODO: Find some other way to access MAPSTA - IF ( X1(IX,IY) .EQ. UNDEF ) THEN + IF ( XK(IX,IY,IK) .EQ. UNDEF ) THEN MX1R(IX,IY) = MFILLR ELSE - MX1R(IX,IY) = X1(IX,IY) + MX1R(IX,IY) = XK(IX,IY,IK) END IF END DO END DO IF(SMCOTYPE .EQ. 1) THEN IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1R(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + MX1R(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) call CHECK_ERR(IRET) ELSE IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1R(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MX1R(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) call CHECK_ERR(IRET) ENDIF #endif ELSE ! IF SMCGRD DO IX=IX1, IXN DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR.X1(IX,IY) .EQ. UNDEF ) THEN + IF ( MAPSTA(IY,IX) .LE. 0 .OR.XK(IX,IY,IK) .EQ. UNDEF ) THEN MX1R(IX,IY) = MFILLR ELSE - MX1R(IX,IY) = X1(IX,IY) + MX1R(IX,IY) = XK(IX,IY,IK) END IF END DO END DO IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1R(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + MX1R(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) CALL CHECK_ERR(IRET) - ENDIF ! SMCGRD -! EXTRADIM=1 - ELSE - START(4-COORDTYPE)=0 - DO IK=I1F,I2F - START(4-COORDTYPE)=START(4-COORDTYPE)+1 - IF (SMCGRD) THEN -#ifdef W3_SMC - DO IX=IX1, IXN - DO IY=IY1, IYN - ! TODO: Find some other way to access MAPSTA - IF ( XK(IX,IY,IK) .EQ. UNDEF ) THEN - MX1R(IX,IY) = MFILLR - ELSE - MX1R(IX,IY) = XK(IX,IY,IK) - END IF - END DO - END DO - IF(SMCOTYPE .EQ. 1) THEN - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1R(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) - call CHECK_ERR(IRET) - ELSE - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1R(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) - call CHECK_ERR(IRET) - ENDIF -#endif - ELSE ! IF SMCGRD - DO IX=IX1, IXN - DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR.XK(IX,IY,IK) .EQ. UNDEF ) THEN - MX1R(IX,IY) = MFILLR - ELSE - MX1R(IX,IY) = XK(IX,IY,IK) - END IF - END DO - END DO - IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & - MX1R(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) - CALL CHECK_ERR(IRET) - END IF ! SMCGRD - END DO - END IF ! EXTRADIM - END IF ! NFIELD - END IF ! NCVARTYPE - - ! updates the variable index - IVAR1=IVAR1+NFIELD - - - ! Loops over IPART for partition variables - ! ChrisBunney: Don't loop IPART for last two entries in section 4 - ! (16: total wind sea fraction, 17: number of parts) as these fields - ! do not have partitions. - IF (IFI .EQ. 4 .AND. IFJ .LE. NOGE(IFI) - 2) THEN -560 CONTINUE - IF (INDEXIPART.LT.NBIPART) THEN - INDEXIPART=INDEXIPART+1 - IF (TABIPART(INDEXIPART).EQ.-1) GOTO 560 - IPART=TABIPART(INDEXIPART) - GOTO 555 - END IF - ELSE - INDEXIPART=1 + END IF ! SMCGRD + END DO + END IF ! EXTRADIM + END IF ! NFIELD + END IF ! NCVARTYPE + + ! updates the variable index + IVAR1=IVAR1+NFIELD + + + ! Loops over IPART for partition variables + ! ChrisBunney: Don't loop IPART for last two entries in section 4 + ! (16: total wind sea fraction, 17: number of parts) as these fields + ! do not have partitions. + IF (IFI .EQ. 4 .AND. IFJ .LE. NOGE(IFI) - 2) THEN +560 CONTINUE + IF (INDEXIPART.LT.NBIPART) THEN + INDEXIPART=INDEXIPART+1 + IF (TABIPART(INDEXIPART).EQ.-1) GOTO 560 + IPART=TABIPART(INDEXIPART) + GOTO 555 END IF -! - END IF ! FLG2D(IFI,IFJ) - END DO ! IFI=1, NOGRP - END DO ! IFJ=1, NGRPP -! -! Clean up - DEALLOCATE(X1, X2, XX, XY, XK, XXK, XYK) - DEALLOCATE(MX1, MXX, MYY, MXY, MAPOUT) - DEALLOCATE(MX1R, MXXR, MYYR, MXYR) - DEALLOCATE(AUX1) - IF (ALLOCATED(LON)) DEALLOCATE(LON, LAT) - IF (ALLOCATED(LON2D)) DEALLOCATE(LON2D, LAT2D) + ELSE + INDEXIPART=1 + END IF + ! + END IF ! FLG2D(IFI,IFJ) + END DO ! IFI=1, NOGRP + END DO ! IFJ=1, NGRPP + ! + ! Clean up + DEALLOCATE(X1, X2, XX, XY, XK, XXK, XYK) + DEALLOCATE(MX1, MXX, MYY, MXY, MAPOUT) + DEALLOCATE(MX1R, MXXR, MYYR, MXYR) + DEALLOCATE(AUX1) + IF (ALLOCATED(LON)) DEALLOCATE(LON, LAT) + IF (ALLOCATED(LON2D)) DEALLOCATE(LON2D, LAT2D) #ifdef W3_RTD - IF (ALLOCATED(LON2DEQ)) DEALLOCATE(LAT2DEQ, LON2DEQ, ANGLD2D) + IF (ALLOCATED(LON2DEQ)) DEALLOCATE(LAT2DEQ, LON2DEQ, ANGLD2D) #endif -! - RETURN -! -! Error escape locations -! - -! -! Formats -! - 973 FORMAT ( 'NEW NETCDF FILE WAS CREATED ',A) - 999 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXNC :'/ & - ' PLEASE UPDATE FIELDS !!! '/ & - ' IFI = ',I2, '- IFJ = ',I2/) -! + ! + RETURN + ! + ! Error escape locations + ! + + ! + ! Formats + ! +973 FORMAT ( 'NEW NETCDF FILE WAS CREATED ',A) +999 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXNC :'/ & + ' PLEASE UPDATE FIELDS !!! '/ & + ' IFI = ',I2, '- IFJ = ',I2/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3EXNC : FLAGS :',I3,2X,20L2) - 9001 FORMAT (' TEST W3EXNC : ITPYE :',I4/ & - ' IX1/N :',2I7/ & - ' IY1/N :',2I7/ & - ' VECTOR :',1L2) +9000 FORMAT (' TEST W3EXNC : FLAGS :',I3,2X,20L2) +9001 FORMAT (' TEST W3EXNC : ITPYE :',I4/ & + ' IX1/N :',2I7/ & + ' IY1/N :',2I7/ & + ' VECTOR :',1L2) #endif -! + ! #ifdef W3_T - 9012 FORMAT (' TEST W3EXNC : BLOK PARS : ',3I4) - 9014 FORMAT (' BASE NAME : ',A) +9012 FORMAT (' TEST W3EXNC : BLOK PARS : ',3I4) +9014 FORMAT (' BASE NAME : ',A) #endif -! + ! #ifdef W3_T - 9020 FORMAT (' TEST W3EXNC : OUTPUT FIELD : ',A) +9020 FORMAT (' TEST W3EXNC : OUTPUT FIELD : ',A) #endif -!/ + !/ -!/ End of W3EXNC ----------------------------------------------------- / -!/ - END SUBROUTINE W3EXNC + !/ End of W3EXNC ----------------------------------------------------- / + !/ + END SUBROUTINE W3EXNC -!-------------------------------------------------------------------------- -!> -!> @brief Desc not available. -!> -!> @param[in] NCFILE -!> @param[out] NCID -!> @param[out] DIMID -!> @param[in] DIMLN -!> @param[out] VARID -!> @param[in] EXTRADIM -!> @param[in] NCTYPE -!> @param[in] MAPSTAOUT -!> -!> @author NA @date NA - SUBROUTINE W3CRNC (NCFILE, NCID, DIMID, DIMLN, VARID, & - EXTRADIM, NCTYPE, MAPSTAOUT ) -! - USE W3GDATMD, ONLY : GTYPE, FLAGLL, UNGTYPE, CLGTYPE, RLGTYPE + !-------------------------------------------------------------------------- + !> + !> @brief Desc not available. + !> + !> @param[in] NCFILE + !> @param[out] NCID + !> @param[out] DIMID + !> @param[in] DIMLN + !> @param[out] VARID + !> @param[in] EXTRADIM + !> @param[in] NCTYPE + !> @param[in] MAPSTAOUT + !> + !> @author NA @date NA + SUBROUTINE W3CRNC (NCFILE, NCID, DIMID, DIMLN, VARID, & + EXTRADIM, NCTYPE, MAPSTAOUT ) + ! + USE W3GDATMD, ONLY : GTYPE, FLAGLL, UNGTYPE, CLGTYPE, RLGTYPE #ifdef W3_RTD - ! Rotated pole parameters from the mod_def file - USE W3GDATMD, ONLY : POLAT, POLON + ! Rotated pole parameters from the mod_def file + USE W3GDATMD, ONLY : POLAT, POLON #endif - USE NETCDF - USE W3TIMEMD - - IMPLICIT NONE - - - - INTEGER, INTENT(IN) :: EXTRADIM - INTEGER, INTENT(IN) :: NCTYPE - CHARACTER*(*), INTENT(IN) :: NCFILE - INTEGER, INTENT(OUT) :: NCID - INTEGER, INTENT(OUT) :: DIMID(6) - INTEGER, INTENT(IN) :: DIMLN(6) - INTEGER, INTENT(OUT) :: VARID(300) - LOGICAL, INTENT(IN) :: MAPSTAOUT -! -!/ ------------------------------------------------------------------- / -! Local parameters -! - INTEGER :: IVAR,IRET,ICODE,STRL,STRL2 - INTEGER :: DIMTRI(2) - INTEGER :: DEFLATE=1 -! - CHARACTER :: ATTNAME*120,ATTVAL*120 -! - COORDS_ATTR = '' -! -! Creation in netCDF3 or netCDF4 -! - IF(NCTYPE.EQ.3) IRET = NF90_CREATE(TRIM(NCFILE), NF90_CLOBBER, NCID) - IF(NCTYPE.EQ.4) IRET = NF90_CREATE(TRIM(NCFILE), NF90_NETCDF4, NCID) - CALL CHECK_ERR(IRET) -! -! Define dimensions -! - IRET = NF90_DEF_DIM(NCID, 'level', DIMLN(1), DIMID(1)) - -! -! Regular structured case -! - IF (GTYPE.NE.UNGTYPE) THEN - IF (FLAGLL) THEN - IF (SMCGRD) THEN + USE NETCDF + USE W3TIMEMD + + IMPLICIT NONE + + + + INTEGER, INTENT(IN) :: EXTRADIM + INTEGER, INTENT(IN) :: NCTYPE + CHARACTER*(*), INTENT(IN) :: NCFILE + INTEGER, INTENT(OUT) :: NCID + INTEGER, INTENT(OUT) :: DIMID(6) + INTEGER, INTENT(IN) :: DIMLN(6) + INTEGER, INTENT(OUT) :: VARID(300) + LOGICAL, INTENT(IN) :: MAPSTAOUT + ! + !/ ------------------------------------------------------------------- / + ! Local parameters + ! + INTEGER :: IVAR,IRET,ICODE,STRL,STRL2 + INTEGER :: DIMTRI(2) + INTEGER :: DEFLATE=1 + ! + CHARACTER :: ATTNAME*120,ATTVAL*120 + ! + COORDS_ATTR = '' + ! + ! Creation in netCDF3 or netCDF4 + ! + IF(NCTYPE.EQ.3) IRET = NF90_CREATE(TRIM(NCFILE), NF90_CLOBBER, NCID) + IF(NCTYPE.EQ.4) IRET = NF90_CREATE(TRIM(NCFILE), NF90_NETCDF4, NCID) + CALL CHECK_ERR(IRET) + ! + ! Define dimensions + ! + IRET = NF90_DEF_DIM(NCID, 'level', DIMLN(1), DIMID(1)) + + ! + ! Regular structured case + ! + IF (GTYPE.NE.UNGTYPE) THEN + IF (FLAGLL) THEN + IF (SMCGRD) THEN #ifdef W3_SMC - IF(SMCOTYPE .EQ. 1) THEN - ! Flat seapoints file - IRET = NF90_DEF_DIM(NCID, 'seapoint', dimln(2), DIMID(2)) - ELSE - ! Regular gridded file: - IRET = NF90_DEF_DIM(NCID, 'longitude', dimln(2), DIMID(2)) - IRET = NF90_DEF_DIM(NCID, 'latitude', dimln(3), DIMID(3)) - ENDIF -#endif + IF(SMCOTYPE .EQ. 1) THEN + ! Flat seapoints file + IRET = NF90_DEF_DIM(NCID, 'seapoint', dimln(2), DIMID(2)) ELSE - IRET = NF90_DEF_DIM(NCID, 'longitude', DIMLN(2), DIMID(2)) - IRET = NF90_DEF_DIM(NCID, 'latitude', DIMLN(3), DIMID(3)) - ENDIF ! SMCGRD + ! Regular gridded file: + IRET = NF90_DEF_DIM(NCID, 'longitude', dimln(2), DIMID(2)) + IRET = NF90_DEF_DIM(NCID, 'latitude', dimln(3), DIMID(3)) + ENDIF +#endif ELSE - IRET = NF90_DEF_DIM(NCID, 'x', DIMLN(2), DIMID(2)) - IRET = NF90_DEF_DIM(NCID, 'y', DIMLN(3), DIMID(3)) - END IF - CALL CHECK_ERR(IRET) -! -! Unstructured case -! + IRET = NF90_DEF_DIM(NCID, 'longitude', DIMLN(2), DIMID(2)) + IRET = NF90_DEF_DIM(NCID, 'latitude', DIMLN(3), DIMID(3)) + ENDIF ! SMCGRD ELSE - IRET = NF90_DEF_DIM(NCID, 'node', DIMLN(2), DIMID(2)) - IRET = NF90_DEF_DIM(NCID, 'element', DIMLN(3), DIMID(3)) - CALL CHECK_ERR(IRET) - ENDIF -! -! - + IRET = NF90_DEF_DIM(NCID, 'x', DIMLN(2), DIMID(2)) + IRET = NF90_DEF_DIM(NCID, 'y', DIMLN(3), DIMID(3)) + END IF + CALL CHECK_ERR(IRET) + ! + ! Unstructured case + ! + ELSE + IRET = NF90_DEF_DIM(NCID, 'node', DIMLN(2), DIMID(2)) + IRET = NF90_DEF_DIM(NCID, 'element', DIMLN(3), DIMID(3)) + CALL CHECK_ERR(IRET) + ENDIF + ! + ! - IF (EXTRADIM.EQ.1) THEN - IRET = NF90_DEF_DIM(NCID, 'f', DIMLN(4), DIMID(4)) - CALL CHECK_ERR(IRET) - ENDIF - IRET = NF90_DEF_DIM(NCID, 'time',NF90_UNLIMITED, DIMID(4+EXTRADIM)) + IF (EXTRADIM.EQ.1) THEN + IRET = NF90_DEF_DIM(NCID, 'f', DIMLN(4), DIMID(4)) CALL CHECK_ERR(IRET) + ENDIF - IF (GTYPE.EQ.UNGTYPE) THEN - IRET = NF90_DEF_DIM(NCID, 'noel',3, DIMID(5+EXTRADIM)) - CALL CHECK_ERR(IRET) - ENDIF + IRET = NF90_DEF_DIM(NCID, 'time',NF90_UNLIMITED, DIMID(4+EXTRADIM)) + CALL CHECK_ERR(IRET) + + IF (GTYPE.EQ.UNGTYPE) THEN + IRET = NF90_DEF_DIM(NCID, 'noel',3, DIMID(5+EXTRADIM)) + CALL CHECK_ERR(IRET) + ENDIF -! -! define variables -! - IF (FLAGLL) THEN -!longitude - IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN - IF (SMCGRD) THEN + ! + ! define variables + ! + IF (FLAGLL) THEN + !longitude + IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN + IF (SMCGRD) THEN #ifdef W3_SMC - IF(SMCOTYPE .EQ. 1) THEN - ! Flat SMC grid - use seapoint dimension: - IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) - CALL CHECK_ERR(IRET) - IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(2), VARID(2)) - CALL CHECK_ERR(IRET) + IF(SMCOTYPE .EQ. 1) THEN + ! Flat SMC grid - use seapoint dimension: + IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) + CALL CHECK_ERR(IRET) + IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(2), VARID(2)) + CALL CHECK_ERR(IRET) - ! Latitude and longitude are auxililary variables in type 1 sea point - ! SMC file; add to "coordinates" attribute: - COORDS_ATTR = TRIM(COORDS_ATTR) // " latitude longitude" + ! Latitude and longitude are auxililary variables in type 1 sea point + ! SMC file; add to "coordinates" attribute: + COORDS_ATTR = TRIM(COORDS_ATTR) // " latitude longitude" - ! For seapoint style SMC grid, also define out cell size variables: - IRET = NF90_DEF_VAR(NCID, 'cx', NF90_SHORT, DIMID(2), VARID(5)) - CALL CHECK_ERR(IRET) - IRET = NF90_PUT_ATT(NCID, VARID(5), 'long_name', & - 'longitude cell size factor') - IRET = NF90_PUT_ATT(NCID, VARID(5), 'valid_min', 1) - IRET = NF90_PUT_ATT(NCID, VARID(5), 'valid_max', 256) - - IRET = NF90_DEF_VAR(NCID, 'cy', NF90_SHORT, DIMID(2), VARID(6)) - call CHECK_ERR(IRET) - IRET = NF90_PUT_ATT(NCID, VARID(6), 'long_name', & - 'latitude cell size factor') - IRET = NF90_PUT_ATT(NCID, VARID(6), 'valid_min', 1) - IRET = NF90_PUT_ATT(NCID, VARID(6), 'valid_max', 256) - ELSE - ! Regirdded regular SMC grid - use lon/lat dimensions: - IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) - call CHECK_ERR(IRET) - IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(3), VARID(2)) - call CHECK_ERR(IRET) - ENDIF -#endif + ! For seapoint style SMC grid, also define out cell size variables: + IRET = NF90_DEF_VAR(NCID, 'cx', NF90_SHORT, DIMID(2), VARID(5)) + CALL CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, VARID(5), 'long_name', & + 'longitude cell size factor') + IRET = NF90_PUT_ATT(NCID, VARID(5), 'valid_min', 1) + IRET = NF90_PUT_ATT(NCID, VARID(5), 'valid_max', 256) + + IRET = NF90_DEF_VAR(NCID, 'cy', NF90_SHORT, DIMID(2), VARID(6)) + call CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, VARID(6), 'long_name', & + 'latitude cell size factor') + IRET = NF90_PUT_ATT(NCID, VARID(6), 'valid_min', 1) + IRET = NF90_PUT_ATT(NCID, VARID(6), 'valid_max', 256) ELSE + ! Regirdded regular SMC grid - use lon/lat dimensions: IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) + call CHECK_ERR(IRET) IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(3), VARID(2)) - ENDIF ! SMCGRD - ELSE IF (GTYPE.EQ.CLGTYPE) THEN - IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & - VARID(1)) - IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & - VARID(2)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) - IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(2), VARID(2)) - END IF - IRET=NF90_PUT_ATT(NCID,VARID(1),'units','degree_east') + IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(3), VARID(2)) + ENDIF ! SMCGRD + ELSE IF (GTYPE.EQ.CLGTYPE) THEN + IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & + VARID(1)) + IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & + VARID(2)) + ELSE + IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) + IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(2), VARID(2)) + END IF + IRET=NF90_PUT_ATT(NCID,VARID(1),'units','degree_east') #ifdef W3_RTD - ! Is the grid really rotated - IF ( .NOT. RTDL ) THEN + ! Is the grid really rotated + IF ( .NOT. RTDL ) THEN #endif IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','longitude') IRET=NF90_PUT_ATT(NCID,VARID(1),'standard_name','longitude') #ifdef W3_RTD - ELSE + ELSE ! Override the above for RTD pole: - IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','longitude in rotated pole grid') - IRET=NF90_PUT_ATT(NCID,VARID(1),'standard_name','grid_longitude') - END IF + IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','longitude in rotated pole grid') + IRET=NF90_PUT_ATT(NCID,VARID(1),'standard_name','grid_longitude') + END IF #endif - IRET=NF90_PUT_ATT(NCID,VARID(1),'valid_min',-180.0) - IRET=NF90_PUT_ATT(NCID,VARID(1),'valid_max',360.) -! - IRET=NF90_PUT_ATT(NCID,VARID(2),'units','degree_north') + IRET=NF90_PUT_ATT(NCID,VARID(1),'valid_min',-180.0) + IRET=NF90_PUT_ATT(NCID,VARID(1),'valid_max',360.) + ! + IRET=NF90_PUT_ATT(NCID,VARID(2),'units','degree_north') #ifdef W3_RTD - IF ( .NOT. RTDL ) THEN + IF ( .NOT. RTDL ) THEN #endif IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','latitude') IRET=NF90_PUT_ATT(NCID,VARID(2),'standard_name','latitude') #ifdef W3_RTD - ELSE + ELSE ! Override the above for RTD pole: IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','latitude in rotated pole grid') IRET=NF90_PUT_ATT(NCID,VARID(2),'standard_name','grid_latitude') - END IF + END IF #endif - IRET=NF90_PUT_ATT(NCID,VARID(2),'valid_min',-90.0) - IRET=NF90_PUT_ATT(NCID,VARID(2),'valid_max',90.) -! - IF(SMCGRD) THEN + IRET=NF90_PUT_ATT(NCID,VARID(2),'valid_min',-90.0) + IRET=NF90_PUT_ATT(NCID,VARID(2),'valid_max',90.) + ! + IF(SMCGRD) THEN #ifdef W3_SMC - IF(SMCOTYPE .EQ. 1) THEN + IF(SMCOTYPE .EQ. 1) THEN #endif #ifdef W3_RTD - IF ( RTDL ) THEN - ! For SMC grid type 1, standard lat/lon variables are 1D: - IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, & - (/ DIMID(2) /), VARID(7)) - call CHECK_ERR(IRET) - - IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, & - (/ DIMID(2) /), VARID(8)) - call CHECK_ERR(IRET) - ENDIF ! RTDL + IF ( RTDL ) THEN + ! For SMC grid type 1, standard lat/lon variables are 1D: + IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, & + (/ DIMID(2) /), VARID(7)) + call CHECK_ERR(IRET) + + IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, & + (/ DIMID(2) /), VARID(8)) + call CHECK_ERR(IRET) + ENDIF ! RTDL #endif #ifdef W3_SMC - ELSE + ELSE #endif #ifdef W3_RTD - IF ( RTDL ) THEN - IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, & - (/ DIMID(2), DIMID(3)/), VARID(7)) - call CHECK_ERR(IRET) - - IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, & - (/ DIMID(2), DIMID(3)/), VARID(8)) - call CHECK_ERR(IRET) - ENDIF ! RTDL + IF ( RTDL ) THEN + IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, & + (/ DIMID(2), DIMID(3)/), VARID(7)) + call CHECK_ERR(IRET) + + IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, & + (/ DIMID(2), DIMID(3)/), VARID(8)) + call CHECK_ERR(IRET) + ENDIF ! RTDL #endif #ifdef W3_SMC - ENDIF + ENDIF #endif - ELSE + ELSE #ifdef W3_RTD - IF ( RTDL ) THEN - !Add secondary coordinate system linking rotated grid back to standard lat-lon - IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & - VARID(7)) - call CHECK_ERR(IRET) - - IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & - VARID(8)) - call CHECK_ERR(IRET) - END IF + IF ( RTDL ) THEN + !Add secondary coordinate system linking rotated grid back to standard lat-lon + IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & + VARID(7)) + call CHECK_ERR(IRET) + + IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & + VARID(8)) + call CHECK_ERR(IRET) + END IF #endif - ENDIF ! SMCGRD + ENDIF ! SMCGRD #ifdef W3_RTD IF ( RTDL ) THEN @@ -3715,7 +3714,7 @@ SUBROUTINE W3CRNC (NCFILE, NCID, DIMID, DIMLN, VARID, & ! HANDLED DIFFERENTLY. C. Bunney. #endif - !! CHRISB: Commenting out below - will be handled by w3oundmeta module + !! CHRISB: Commenting out below - will be handled by w3oundmeta module #ifdef W3_RTD !!IRET=NF90_DEF_VAR(NCID, 'rotated_pole', NF90_CHAR, VARID(12)) !!IRET=NF90_PUT_ATT(NCID, VARID(12), 'grid_north_pole_latitude',POLAT) @@ -3724,291 +3723,291 @@ SUBROUTINE W3CRNC (NCFILE, NCID, DIMID, DIMLN, VARID, & !! 'rotated_latitude_longitude') END IF #endif -! + ! + ELSE + IF (GTYPE.EQ.RLGTYPE) THEN + IRET = NF90_DEF_VAR(NCID, 'x', NF90_FLOAT, DIMID(2), VARID(1)) + IRET = NF90_DEF_VAR(NCID, 'y', NF90_FLOAT, DIMID(3), VARID(2)) + ELSE IF (GTYPE.EQ.CLGTYPE) THEN + IRET = NF90_DEF_VAR(NCID, 'x', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & + VARID(1)) + IRET = NF90_DEF_VAR(NCID, 'y', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & + VARID(2)) ELSE - IF (GTYPE.EQ.RLGTYPE) THEN - IRET = NF90_DEF_VAR(NCID, 'x', NF90_FLOAT, DIMID(2), VARID(1)) - IRET = NF90_DEF_VAR(NCID, 'y', NF90_FLOAT, DIMID(3), VARID(2)) - ELSE IF (GTYPE.EQ.CLGTYPE) THEN - IRET = NF90_DEF_VAR(NCID, 'x', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & - VARID(1)) - IRET = NF90_DEF_VAR(NCID, 'y', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & - VARID(2)) - ELSE - IRET = NF90_DEF_VAR(NCID, 'x', NF90_FLOAT, DIMID(2), VARID(1)) - IRET = NF90_DEF_VAR(NCID, 'y', NF90_FLOAT, DIMID(2), VARID(2)) - END IF -! - IRET=NF90_PUT_ATT(NCID,VARID(1),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','x') - IRET=NF90_PUT_ATT(NCID,VARID(2),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','y') -! - END IF ! FLAGLL -! - IRET=NF90_PUT_ATT(NCID,VARID(1),'axis','X') - IRET=NF90_PUT_ATT(NCID,VARID(2),'axis','Y') - IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(1), 1, 1, DEFLATE) - IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(2), 1, 1, DEFLATE) - -! -! frequency -! - if (EXTRADIM.EQ.1) THEN - IRET = NF90_DEF_VAR(NCID, 'f', NF90_FLOAT, DIMID(4), VARID(10)) - IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','wave_frequency') - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','wave_frequency') - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','s-1') - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,VARID(10),'axis','Hz') - CALL CHECK_ERR(IRET) + IRET = NF90_DEF_VAR(NCID, 'x', NF90_FLOAT, DIMID(2), VARID(1)) + IRET = NF90_DEF_VAR(NCID, 'y', NF90_FLOAT, DIMID(2), VARID(2)) END IF - - -! -! time -! - ! CHRISB: Allow different time variable types: - IRET = NF90_DEF_VAR(NCID, 'time', TVARTYPE, DIMID(4+EXTRADIM), VARID(3)) + ! + IRET=NF90_PUT_ATT(NCID,VARID(1),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','x') + IRET=NF90_PUT_ATT(NCID,VARID(2),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','y') + ! + END IF ! FLAGLL + ! + IRET=NF90_PUT_ATT(NCID,VARID(1),'axis','X') + IRET=NF90_PUT_ATT(NCID,VARID(2),'axis','Y') + IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(1), 1, 1, DEFLATE) + IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(2), 1, 1, DEFLATE) + + ! + ! frequency + ! + if (EXTRADIM.EQ.1) THEN + IRET = NF90_DEF_VAR(NCID, 'f', NF90_FLOAT, DIMID(4), VARID(10)) + IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) CALL CHECK_ERR(IRET) - IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(3), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','wave_frequency') CALL CHECK_ERR(IRET) - SELECT CASE (TRIM(CALTYPE)) - CASE ('360_day') - IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','time in 360 day calendar') - CASE ('365_day') - IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','time in 365 day calendar') - CASE ('standard') - !IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','julian day (UT)') ! CB - IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','time') - END SELECT + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','wave_frequency') CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,VARID(3),'standard_name','time') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','s-1') CALL CHECK_ERR(IRET) - ! CHRISB: Allow alternative time units: - !IRET=NF90_PUT_ATT(NCID,VARID(3),'units','days since 1990-01-01 00:00:00') - IRET=NF90_PUT_ATT(NCID,VARID(3),'units', EPOCH) + IRET=NF90_PUT_ATT(NCID,VARID(10),'axis','Hz') CALL CHECK_ERR(IRET) - ! CHRISB: Not sure this is useful - required information is in "units" - !IRET=NF90_PUT_ATT(NCID,VARID(3),'conventions', & - ! 'relative julian days with decimal part (as parts of the day )') - IRET=NF90_PUT_ATT(NCID,VARID(3),'axis','T') + END IF + + + ! + ! time + ! + ! CHRISB: Allow different time variable types: + IRET = NF90_DEF_VAR(NCID, 'time', TVARTYPE, DIMID(4+EXTRADIM), VARID(3)) + CALL CHECK_ERR(IRET) + IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(3), 1, 1, DEFLATE) + CALL CHECK_ERR(IRET) + SELECT CASE (TRIM(CALTYPE)) + CASE ('360_day') + IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','time in 360 day calendar') + CASE ('365_day') + IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','time in 365 day calendar') + CASE ('standard') + !IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','julian day (UT)') ! CB + IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','time') + END SELECT + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,VARID(3),'standard_name','time') + CALL CHECK_ERR(IRET) + ! CHRISB: Allow alternative time units: + !IRET=NF90_PUT_ATT(NCID,VARID(3),'units','days since 1990-01-01 00:00:00') + IRET=NF90_PUT_ATT(NCID,VARID(3),'units', EPOCH) + CALL CHECK_ERR(IRET) + ! CHRISB: Not sure this is useful - required information is in "units" + !IRET=NF90_PUT_ATT(NCID,VARID(3),'conventions', & + ! 'relative julian days with decimal part (as parts of the day )') + IRET=NF90_PUT_ATT(NCID,VARID(3),'axis','T') + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,VARID(3),'calendar',TRIM(CALTYPE)) + CALL CHECK_ERR(IRET) + ! + ! forecast period and (forecast reference time), if requested + ! + IF (FLGFC) THEN + IRET = NF90_DEF_VAR(NCID, 'forecast_period', NF90_INT, & + DIMID(4+EXTRADIM), VARID(11)) CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,VARID(3),'calendar',TRIM(CALTYPE)) + IRET = NF90_PUT_ATT(NCID, VARID(11), 'long_name', & + 'forecast period') CALL CHECK_ERR(IRET) -! -! forecast period and (forecast reference time), if requested -! - IF (FLGFC) THEN - IRET = NF90_DEF_VAR(NCID, 'forecast_period', NF90_INT, & - DIMID(4+EXTRADIM), VARID(11)) - CALL CHECK_ERR(IRET) - IRET = NF90_PUT_ATT(NCID, VARID(11), 'long_name', & - 'forecast period') - CALL CHECK_ERR(IRET) - IRET = NF90_PUT_ATT(NCID, VARID(11), 'standard_name', & - 'forecast_period') - CALL CHECK_ERR(IRET) - IRET = NF90_PUT_ATT(NCID, VARID(11), 'units', 's') - CALL CHECK_ERR(IRET) - - ! Forecast reference time is a scalar variable: - IRET = NF90_DEF_VAR(NCID, 'forecast_reference_time', & - TVARTYPE, varid=VARID(12)) - CALL CHECK_ERR(IRET) - - IRET = NF90_PUT_ATT(NCID, VARID(12), 'long_name', & - 'forecast reference time') - CALL CHECK_ERR(IRET) - - IRET = NF90_PUT_ATT(NCID, VARID(12), 'standard_name', & - 'forecast_reference_time') - CALL CHECK_ERR(IRET) - - IRET = NF90_PUT_ATT(NCID, VARID(12), 'units', EPOCH) - ! 'days since 1990-01-01 00:00:00') - CALL CHECK_ERR(IRET) - - IRET = NF90_PUT_ATT(NCID, VARID(12), 'calendar', 'gregorian') - CALL CHECK_ERR(IRET) - - ! Add these to auxiliary coordinates list: - COORDS_ATTR = TRIM(COORDS_ATTR) // " forecast_period forecast_reference_time" - ENDIF -! -! triangles for irregular grids -! + IRET = NF90_PUT_ATT(NCID, VARID(11), 'standard_name', & + 'forecast_period') + CALL CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, VARID(11), 'units', 's') + CALL CHECK_ERR(IRET) + + ! Forecast reference time is a scalar variable: + IRET = NF90_DEF_VAR(NCID, 'forecast_reference_time', & + TVARTYPE, varid=VARID(12)) + CALL CHECK_ERR(IRET) + + IRET = NF90_PUT_ATT(NCID, VARID(12), 'long_name', & + 'forecast reference time') + CALL CHECK_ERR(IRET) + + IRET = NF90_PUT_ATT(NCID, VARID(12), 'standard_name', & + 'forecast_reference_time') + CALL CHECK_ERR(IRET) + + IRET = NF90_PUT_ATT(NCID, VARID(12), 'units', EPOCH) + ! 'days since 1990-01-01 00:00:00') + CALL CHECK_ERR(IRET) + + IRET = NF90_PUT_ATT(NCID, VARID(12), 'calendar', 'gregorian') + CALL CHECK_ERR(IRET) + + ! Add these to auxiliary coordinates list: + COORDS_ATTR = TRIM(COORDS_ATTR) // " forecast_period forecast_reference_time" + ENDIF + ! + ! triangles for irregular grids + ! + IF (GTYPE.EQ.UNGTYPE) THEN + DIMTRI(1)=DIMID(4+EXTRADIM+1) + DIMTRI(2)=DIMID(3) + IRET = NF90_DEF_VAR(NCID, 'tri', NF90_INT, DIMTRI, VARID(4)) + IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(4), 1, 1, DEFLATE) + END IF + ! + ! Status map: useful for grid combination + ! + IF (MAPSTAOUT) THEN IF (GTYPE.EQ.UNGTYPE) THEN - DIMTRI(1)=DIMID(4+EXTRADIM+1) - DIMTRI(2)=DIMID(3) - IRET = NF90_DEF_VAR(NCID, 'tri', NF90_INT, DIMTRI, VARID(4)) - IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(4), 1, 1, DEFLATE) - END IF -! -! Status map: useful for grid combination -! - IF (MAPSTAOUT) THEN - IF (GTYPE.EQ.UNGTYPE) THEN - IRET = NF90_DEF_VAR(NCID,'MAPSTA', NF90_SHORT,(/ DIMID(2) /), VARID(20)) - ELSE - IRET = NF90_DEF_VAR(NCID,'MAPSTA', NF90_SHORT,(/ DIMID(2) , DIMID(3) /), & - VARID(20)) - ENDIF - IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(20), 1, 1, DEFLATE) -! - IRET=NF90_PUT_ATT(NCID,VARID(20),'long_name','status map') - IRET=NF90_PUT_ATT(NCID,VARID(20),'standard_name','status map') - IRET=NF90_PUT_ATT(NCID,VARID(20),'units','1') - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_min',-32) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_max',32) - CALL CHECK_ERR(IRET) - END IF -! -! Optional (user-defined) coordinate reference system (scalar variable) -! - IF(CRS_META%N .GT. 0) THEN - IRET = NF90_DEF_VAR(NCID, CRS_NAME, NF90_CHAR, varid=IVAR) - CALL CHECK_ERR(IRET) - - !CALL WRITE_FREEFORM_META(NCID, IVAR, CRS_META, N_CRSMETA, IERR) - CALL WRITE_FREEFORM_META_LIST(NCID, IVAR, CRS_META, IERR) - CALL CHECK_ERR(IRET) + IRET = NF90_DEF_VAR(NCID,'MAPSTA', NF90_SHORT,(/ DIMID(2) /), VARID(20)) + ELSE + IRET = NF90_DEF_VAR(NCID,'MAPSTA', NF90_SHORT,(/ DIMID(2) , DIMID(3) /), & + VARID(20)) ENDIF -! -! Global attributes -! - IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'WAVEWATCH_III_version_number' ,TRIM(WWVER)) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'WAVEWATCH_III_switches',TRIM(SWITCHES)) - CALL CHECK_ERR(IRET) + IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(20), 1, 1, DEFLATE) + ! + IRET=NF90_PUT_ATT(NCID,VARID(20),'long_name','status map') + IRET=NF90_PUT_ATT(NCID,VARID(20),'standard_name','status map') + IRET=NF90_PUT_ATT(NCID,VARID(20),'units','1') + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_min',-32) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_max',32) + CALL CHECK_ERR(IRET) + END IF + ! + ! Optional (user-defined) coordinate reference system (scalar variable) + ! + IF(CRS_META%N .GT. 0) THEN + IRET = NF90_DEF_VAR(NCID, CRS_NAME, NF90_CHAR, varid=IVAR) + CALL CHECK_ERR(IRET) + + !CALL WRITE_FREEFORM_META(NCID, IVAR, CRS_META, N_CRSMETA, IERR) + CALL WRITE_FREEFORM_META_LIST(NCID, IVAR, CRS_META, IERR) + CALL CHECK_ERR(IRET) + ENDIF + ! + ! Global attributes + ! + IF(FL_DEFAULT_GBL_META) THEN + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'WAVEWATCH_III_version_number' ,TRIM(WWVER)) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'WAVEWATCH_III_switches',TRIM(SWITCHES)) + CALL CHECK_ERR(IRET) #ifdef W3_ST4 IF (ZZWND.NE.10) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SIN4 namelist parameter ZWD',ZZWND) IF (AALPHA.NE.0.0095) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SIN4 namelist parameter ALPHA0',AALPHA) IF (BBETA.NE.1.43) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SIN4 namelist parameter BETAMAX',BBETA) IF(SSDSC(7).NE.0.3) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SDS4 namelist parameter WHITECAPWIDTH', SSDSC(7)) #endif -! ... TO BE CONTINUED ... + ! ... TO BE CONTINUED ... - IF(SMCGRD) THEN + IF(SMCGRD) THEN #ifdef W3_SMC - IF(SMCOTYPE .EQ. 1) THEN - IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'first_lat', Y0) - call CHECK_ERR(IRET) - IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'first_lon', X0) - call CHECK_ERR(IRET) - IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'base_lat_size', dlat) - call CHECK_ERR(IRET) - IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'base_lon_size', dlon) - call CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SMC_grid_type','seapoint') - call CHECK_ERR(IRET) - ELSE IF(SMCOTYPE .EQ. 2) THEN - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SMC_grid_type','regular_regridded') - call CHECK_ERR(IRET) - ENDIF -#endif + IF(SMCOTYPE .EQ. 1) THEN + IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'first_lat', Y0) + call CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'first_lon', X0) + call CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'base_lat_size', dlat) + call CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'base_lon_size', dlon) + call CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SMC_grid_type','seapoint') + call CHECK_ERR(IRET) + ELSE IF(SMCOTYPE .EQ. 2) THEN + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SMC_grid_type','regular_regridded') + call CHECK_ERR(IRET) ENDIF - ENDIF ! FL_DEFAULT_GBL_META - - ! ChrisB: Write user global attributes: - CALL WRITE_GLOBAL_META(NCID, IRET) - CALL CHECK_ERR(IRET) - - ! ChrisB: Below is the old way of writing Global attributes, this - ! is now deprecated, but still supported at the moment... - open(unit=994,file='NC_globatt.inp',status='old',iostat=ICODE) - IF (ICODE.EQ.0) THEN - DO WHILE (ICODE.EQ.0) - read(994,'(a)',iostat=ICODE) ATTNAME - read(994,'(a)',iostat=ICODE) ATTVAL - IF (ICODE.EQ.0) THEN - STRL=LEN_TRIM(ATTNAME) - STRL2=LEN_TRIM(ATTVAL) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,ATTNAME(1:STRL),ATTVAL(1:STRL2)) - CALL CHECK_ERR(IRET) - END IF - END DO - ENDIF - CLOSE(994) - IF(FL_DEFAULT_GBL_META) THEN - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'product_name' ,TRIM(NCFILE)) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'area',TRIM(GNAME)) - CALL CHECK_ERR(IRET) +#endif ENDIF - - RETURN - - END SUBROUTINE W3CRNC - - -!/ ------------------------------------------------------------------- / - -!> @brief Expand the seapoint array to full grid with handling of -!> SMC regridding. -!> -!> @details The FLDIRN flag should be set to true for -!> directional fields. In this case, they will be decomposed -!> into U/V components for SMC grid interpolation and converted -!> to oceanograhic convention. -!> -!> @param[inout] S Sea point array -!> @param[out] X Gridded array -!> @param[in] FLDIRN Directional field flag -!> @author C Bunney @date 03-Nov-2021 - SUBROUTINE S2GRID(S, X, FLDIRN) -!/ -!/ +-----------------------------------+ -!/ | C . Bunney | -!/ | FORTRAN 90 | -!/ | Last update : 03-Nov-2020 | -!/ +-----------------------------------+ -!/ -!/ 03-Nov-2020 : Creation ( version 7.13 ) -!/ -! 1. Purpose : -! -! Exapand the seapoint array to full grid with handling of -! SMC regridding. The FLDIRN flag should be set to true for -! directional fields. In this case, they will be decomposed -! into U/V components for SMC grid interpolation and converted -! to oceanograhic convention. -! -! 2. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! S Real. I Sea point array -! X Real. O Gridded array -! FLDIRN Bool. I Directional field flag -! ---------------------------------------------------------------- -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY : W3S2XY - - IMPLICIT NONE - - REAL, INTENT(INOUT) :: S(:) - REAL, INTENT(OUT) :: X(:,:) - LOGICAL, OPTIONAL, INTENT(IN) :: FLDIRN - - LOGICAL :: FLDR - INTEGER :: ISEA - - FLDR = .FALSE. - IF(PRESENT(FLDIRN)) FLDR = FLDIRN + ENDIF ! FL_DEFAULT_GBL_META + + ! ChrisB: Write user global attributes: + CALL WRITE_GLOBAL_META(NCID, IRET) + CALL CHECK_ERR(IRET) + + ! ChrisB: Below is the old way of writing Global attributes, this + ! is now deprecated, but still supported at the moment... + open(unit=994,file='NC_globatt.inp',status='old',iostat=ICODE) + IF (ICODE.EQ.0) THEN + DO WHILE (ICODE.EQ.0) + read(994,'(a)',iostat=ICODE) ATTNAME + read(994,'(a)',iostat=ICODE) ATTVAL + IF (ICODE.EQ.0) THEN + STRL=LEN_TRIM(ATTNAME) + STRL2=LEN_TRIM(ATTVAL) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,ATTNAME(1:STRL),ATTVAL(1:STRL2)) + CALL CHECK_ERR(IRET) + END IF + END DO + ENDIF + CLOSE(994) + IF(FL_DEFAULT_GBL_META) THEN + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'product_name' ,TRIM(NCFILE)) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'area',TRIM(GNAME)) + CALL CHECK_ERR(IRET) + ENDIF + + RETURN + + END SUBROUTINE W3CRNC + + + !/ ------------------------------------------------------------------- / + + !> @brief Expand the seapoint array to full grid with handling of + !> SMC regridding. + !> + !> @details The FLDIRN flag should be set to true for + !> directional fields. In this case, they will be decomposed + !> into U/V components for SMC grid interpolation and converted + !> to oceanograhic convention. + !> + !> @param[inout] S Sea point array + !> @param[out] X Gridded array + !> @param[in] FLDIRN Directional field flag + !> @author C Bunney @date 03-Nov-2021 + SUBROUTINE S2GRID(S, X, FLDIRN) + !/ + !/ +-----------------------------------+ + !/ | C . Bunney | + !/ | FORTRAN 90 | + !/ | Last update : 03-Nov-2020 | + !/ +-----------------------------------+ + !/ + !/ 03-Nov-2020 : Creation ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Exapand the seapoint array to full grid with handling of + ! SMC regridding. The FLDIRN flag should be set to true for + ! directional fields. In this case, they will be decomposed + ! into U/V components for SMC grid interpolation and converted + ! to oceanograhic convention. + ! + ! 2. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! S Real. I Sea point array + ! X Real. O Gridded array + ! FLDIRN Bool. I Directional field flag + ! ---------------------------------------------------------------- + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY : W3S2XY + + IMPLICIT NONE + + REAL, INTENT(INOUT) :: S(:) + REAL, INTENT(OUT) :: X(:,:) + LOGICAL, OPTIONAL, INTENT(IN) :: FLDIRN + + LOGICAL :: FLDR + INTEGER :: ISEA + + FLDR = .FALSE. + IF(PRESENT(FLDIRN)) FLDR = FLDIRN #ifdef W3_SMC - IF( SMCGRD ) THEN - CALL W3S2XY_SMC( S, X, FLDR ) - ELSE ! IF(SMCGRD) + IF( SMCGRD ) THEN + CALL W3S2XY_SMC( S, X, FLDR ) + ELSE ! IF(SMCGRD) #endif IF(FLDR) THEN DO ISEA=1, NSEA @@ -4023,87 +4022,87 @@ SUBROUTINE S2GRID(S, X, FLDIRN) CALL W3S2XY ( NSEA, NSEA, NX+1, NY, S, MAPSF, X ) #ifdef W3_SMC - ENDIF + ENDIF #endif - END SUBROUTINE S2GRID + END SUBROUTINE S2GRID + + + !> @brief Converts fields formulated as U/V vectors into + !> magnitude and direction fields. + !> + !> @details Conversion is + !> done in-place. U becomes magnitude, V becomes + !> direction. Optional TOLERANCE sets minimum + !> magnitude. + !> + !> @param[inout] U + !> @param[inout] V + !> @param[in] Tolerance + !> @author NA @date NA + SUBROUTINE UV_TO_MAG_DIR(U, V, TOLERANCE) + ! Converts fields formulated as U/V vectors into + ! magnitude and direction fields. Conversion is + ! done in-place. U becomes magnitude, V becomes + ! direction. Optional TOLERANCE sets minimum + ! magnitude. + IMPLICIT NONE + + REAL, INTENT(INOUT) :: U(:), V(:) + REAL, INTENT(IN), OPTIONAL :: TOLERANCE + + REAL :: TOL = 1.0 + REAL :: MAG ! Magnitude + INTEGER :: ISEA + + IF(PRESENT(TOLERANCE)) TOL = TOLERANCE + + DO ISEA=1, NSEA + MAG = SQRT(U(ISEA)**2 + V(ISEA)**2) + IF(MAG .GT. TOL) THEN + V(ISEA) = MOD( 630. - RADE * ATAN2(U(ISEA), V(ISEA)), 360. ) + ELSE + V(ISEA) = UNDEF + ! TODO - Setting V to undef does not work as later the write + ! function only checks the U value. Set both to udef? + END IF + U(ISEA) = MAG + END DO + END SUBROUTINE UV_TO_MAG_DIR -!> @brief Converts fields formulated as U/V vectors into -!> magnitude and direction fields. -!> -!> @details Conversion is -!> done in-place. U becomes magnitude, V becomes -!> direction. Optional TOLERANCE sets minimum -!> magnitude. -!> -!> @param[inout] U -!> @param[inout] V -!> @param[in] Tolerance -!> @author NA @date NA - SUBROUTINE UV_TO_MAG_DIR(U, V, TOLERANCE) - ! Converts fields formulated as U/V vectors into - ! magnitude and direction fields. Conversion is - ! done in-place. U becomes magnitude, V becomes - ! direction. Optional TOLERANCE sets minimum - ! magnitude. - IMPLICIT NONE - - REAL, INTENT(INOUT) :: U(:), V(:) - REAL, INTENT(IN), OPTIONAL :: TOLERANCE - - REAL :: TOL = 1.0 - REAL :: MAG ! Magnitude - INTEGER :: ISEA - - IF(PRESENT(TOLERANCE)) TOL = TOLERANCE - - DO ISEA=1, NSEA - MAG = SQRT(U(ISEA)**2 + V(ISEA)**2) - IF(MAG .GT. TOL) THEN - V(ISEA) = MOD( 630. - RADE * ATAN2(U(ISEA), V(ISEA)), 360. ) - ELSE - V(ISEA) = UNDEF - ! TODO - Setting V to undef does not work as later the write - ! function only checks the U value. Set both to udef? - END IF - U(ISEA) = MAG - END DO - - END SUBROUTINE UV_TO_MAG_DIR - -!============================================================================== - -!> @brief Desc not available. -!> -!> @param IRET -!> @param ILINE -!> @author NA @date NA - SUBROUTINE CHECK_ERROR(IRET, ILINE) + !============================================================================== - USE NETCDF - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE + !> @brief Desc not available. + !> + !> @param IRET + !> @param ILINE + !> @author NA @date NA + SUBROUTINE CHECK_ERROR(IRET, ILINE) - IMPLICIT NONE + USE NETCDF + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE - INTEGER IRET, ILINE + IMPLICIT NONE - IF (IRET .NE. NF90_NOERR) THEN - WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN OUNF :' - WRITE(NDSE,*) ' LINE NUMBER ', ILINE - WRITE(NDSE,*) ' NETCDF ERROR MESSAGE: ' - WRITE(NDSE,*) NF90_STRERROR(IRET) - CALL EXTCDE ( 59 ) - END IF - RETURN + INTEGER IRET, ILINE + + IF (IRET .NE. NF90_NOERR) THEN + WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN OUNF :' + WRITE(NDSE,*) ' LINE NUMBER ', ILINE + WRITE(NDSE,*) ' NETCDF ERROR MESSAGE: ' + WRITE(NDSE,*) NF90_STRERROR(IRET) + CALL EXTCDE ( 59 ) + END IF + RETURN - END SUBROUTINE CHECK_ERROR + END SUBROUTINE CHECK_ERROR -!============================================================================== + !============================================================================== -!/ -!/ End of W3OUNF ----------------------------------------------------- / -!/ - END PROGRAM W3OUNF + !/ + !/ End of W3OUNF ----------------------------------------------------- / + !/ +END PROGRAM W3OUNF diff --git a/model/src/ww3_ounp.F90 b/model/src/ww3_ounp.F90 index 794e31f05..8d726479d 100644 --- a/model/src/ww3_ounp.F90 +++ b/model/src/ww3_ounp.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains program W3OUNP. -!> +!> !> @author F Ardhuin !> @author M Accensi !> @date 06-Sep-2021 @@ -14,1885 +14,1890 @@ !> and from the file ww3_ounp.nml or ww3_ounp.inp ( NDSI). !> Model definition and raw data files are read using WAVEWATCH III !> subroutines. -!> +!> !> @author F. Ardhuin !> @author M. Accensi !> @date 06-Sep-2021 !> - PROGRAM W3OUNP -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 06-Sep-2021 | -!/ +-----------------------------------+ -!/ -!/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 14-Feb-2000 : Exact nonlinear interactions ( version 2.01 ) -!/ 09-Jan-2001 : U* bug fix in tabular output ( version 2.05 ) -!/ 25-Jan-2001 : Flat grid version ( version 2.06 ) -!/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) -!/ 11-Jun-2001 : Clean up ( version 2.11 ) -!/ 11-Oct-2001 : Clean up, X*, Y* in tables ( version 2.14 ) -!/ 13-Nov-2002 : Add stress vector ( version 3.00 ) -!/ 27-Nov-2002 : First version of VDIA and MDIA ( version 3.01 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 17-Apr-2006 : Filter for directional spread. ( version 3.09 ) -!/ 23-Jun-2006 : Linear input added. ( version 3.09 ) -!/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 03-Jul-2006 : Separate flux modules. ( version 3.09 ) -!/ 28-Oct-2006 : Add partitioning option. ( version 3.10 ) -!/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) -!/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) -!/ (J. H. Alves) -!/ 08-Aug-2007 : Creation of buoy log file added ( version 3.12 ) -!/ (switch O14 -- A. Chawla) -!/ 09-Oct-2007 : WAM 4+ Sin and Sds added. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 09-Oct-2007 : Experimental Sbs (BS1) added. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 09-Apr-2008 : Adding an additional output for ( version 3.12 ) -!/ WMO standard (A. Chawla) -!/ 29-Apr-2008 : Adjust format partition output. ( version 3.14 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 24-Mar-2011 : Adaptation to NetCDF (M. Accensi) ( version 4.04 ) -!/ 16-Jul-2011 : NC3 / NC4 switch (M. Accensi) ( version 4.05 ) -!/ 14-Mar-2013 : Writing optimization (M. Accensi) ( version 4.09 ) -!/ 04-Jun-2014 : Correct bug TOGETHER (M. Accensi) ( version 5.00 ) -!/ 04-Jun-2014 : Update use of date (M. Accensi) ( version 5.00 ) -!/ 13-Jun-2014 : Dimension order opt. (M. Accensi) ( version 5.00 ) -!/ 18-Jun-2014 : add mpi implementat. (M. Accensi) ( version 5.00 ) -!/ 27-Aug-2015 : Sice add as additional output ( version 5.10 ) -!/ (in source terms) -!/ 15-May-2018 : Add namelist feature ( version 6.05 ) -!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) -!/ 18-Jun-2020 : Support for 360-day calendar. ( version 7.08 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ 06-Sep-2021 : scale factor on spectra output ( version 7.12 ) -!/ 05-Jan-2022 : Added TIMESPLIT=0 (nodate) support ( version 7.14 ) -!/ 21-Jul-2022 : Correct FP0 calc for peak energy in ( version 7.14 ) -!/ min/max freq band (B. Pouliot, CMC) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Post-processing of point output. -! -! 2. Method : -! -! Data is read from the grid output file out_pnt.ww3 (raw data) -! and from the file ww3_ounp.nml or ww3_ounp.inp ( NDSI). -! Model definition and raw data files are read using WAVEWATCH III -! subroutines. -! -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W3NAUX Subr. W3ADATMD Set number of model for aux data. -! W3SETA Subr. Id. Point to selected model for aux data. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! STME21 Subr. W3TIMEMD Convert time to string. -! TICK21 Subr. Id. Advance time. -! DSEC21 Func. Id. Difference between times. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3IOPO Subr. W3IOPOMD Reading/writing raw point output file. -! W3EXNC Subr. Internal Execute point output. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! Checks on input, checks in W3IOxx. -! -! 7. Remarks : -! -! - Tables written to file 'tabNN.ww3', where NN is the -! unit umber (NDSTAB). -! - Transfer file written to ww3.yymmddhh.spc with multiple -! spectra and times in file. yymmddhh relates to first -! output (NDSTAB). -! - !/IC1 !/IC2 !/IC3 !/IC5 are not included in dissipation term -! FIXME: ICE is a dummy variable at the moment -! Include ice parameters in point output file out_pnt.ww3 -! Ice coupling to SIN, SDS and SIC similar to w3srcemd.ftn -! -! 8. Structure : -! -! See source code. -! -! TOUT is the time defined in the input file -! TIME is the time read from the out_pnt.ww3 file -! DTREQ is the stride used for the time steps -! at the beginning, if TOUT is after TIME, the program will read -! out_pnt.ww3 DTREQ by DTREQ until TIME is equal to TOUT -! /!\ if DTREQ is too big, it's possible to never have TIME=TOUT /!\ -! -! PASTDATE is the date of the last time step -! DATE is the date of the current time step -! IOUT is the counter of time iteration of a same file -! -! MFL is the number of stations processed in the 'time' loop -! NOPTS is the total number of stations defined in out_pnt.ww3 -! NFL is the number of bunch of MFL stations to loop on to -! process all the NOPTS stations -! NREQ is the number of valid stations to process, unvalid stations -! are duplicata or stations not specified in the input file -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! !/NCO NCEP NCO modifications for operational implementation. -! -! !/O14 Buoy log file generation. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ -! USE W3GDATMD, ONLY: W3NMOD, W3SETG - USE W3WDATMD, ONLY: W3SETW, W3NDAT +PROGRAM W3OUNP + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 06-Sep-2021 | + !/ +-----------------------------------+ + !/ + !/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 14-Feb-2000 : Exact nonlinear interactions ( version 2.01 ) + !/ 09-Jan-2001 : U* bug fix in tabular output ( version 2.05 ) + !/ 25-Jan-2001 : Flat grid version ( version 2.06 ) + !/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) + !/ 11-Jun-2001 : Clean up ( version 2.11 ) + !/ 11-Oct-2001 : Clean up, X*, Y* in tables ( version 2.14 ) + !/ 13-Nov-2002 : Add stress vector ( version 3.00 ) + !/ 27-Nov-2002 : First version of VDIA and MDIA ( version 3.01 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 17-Apr-2006 : Filter for directional spread. ( version 3.09 ) + !/ 23-Jun-2006 : Linear input added. ( version 3.09 ) + !/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 03-Jul-2006 : Separate flux modules. ( version 3.09 ) + !/ 28-Oct-2006 : Add partitioning option. ( version 3.10 ) + !/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) + !/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) + !/ (J. H. Alves) + !/ 08-Aug-2007 : Creation of buoy log file added ( version 3.12 ) + !/ (switch O14 -- A. Chawla) + !/ 09-Oct-2007 : WAM 4+ Sin and Sds added. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 09-Oct-2007 : Experimental Sbs (BS1) added. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 09-Apr-2008 : Adding an additional output for ( version 3.12 ) + !/ WMO standard (A. Chawla) + !/ 29-Apr-2008 : Adjust format partition output. ( version 3.14 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 24-Mar-2011 : Adaptation to NetCDF (M. Accensi) ( version 4.04 ) + !/ 16-Jul-2011 : NC3 / NC4 switch (M. Accensi) ( version 4.05 ) + !/ 14-Mar-2013 : Writing optimization (M. Accensi) ( version 4.09 ) + !/ 04-Jun-2014 : Correct bug TOGETHER (M. Accensi) ( version 5.00 ) + !/ 04-Jun-2014 : Update use of date (M. Accensi) ( version 5.00 ) + !/ 13-Jun-2014 : Dimension order opt. (M. Accensi) ( version 5.00 ) + !/ 18-Jun-2014 : add mpi implementat. (M. Accensi) ( version 5.00 ) + !/ 27-Aug-2015 : Sice add as additional output ( version 5.10 ) + !/ (in source terms) + !/ 15-May-2018 : Add namelist feature ( version 6.05 ) + !/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) + !/ 18-Jun-2020 : Support for 360-day calendar. ( version 7.08 ) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ 06-Sep-2021 : scale factor on spectra output ( version 7.12 ) + !/ 05-Jan-2022 : Added TIMESPLIT=0 (nodate) support ( version 7.14 ) + !/ 21-Jul-2022 : Correct FP0 calc for peak energy in ( version 7.14 ) + !/ min/max freq band (B. Pouliot, CMC) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Post-processing of point output. + ! + ! 2. Method : + ! + ! Data is read from the grid output file out_pnt.ww3 (raw data) + ! and from the file ww3_ounp.nml or ww3_ounp.inp ( NDSI). + ! Model definition and raw data files are read using WAVEWATCH III + ! subroutines. + ! + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W3NAUX Subr. W3ADATMD Set number of model for aux data. + ! W3SETA Subr. Id. Point to selected model for aux data. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! W3SETO Subr. Id. Point to selected model for output. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! TICK21 Subr. Id. Advance time. + ! DSEC21 Func. Id. Difference between times. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3IOPO Subr. W3IOPOMD Reading/writing raw point output file. + ! W3EXNC Subr. Internal Execute point output. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! Checks on input, checks in W3IOxx. + ! + ! 7. Remarks : + ! + ! - Tables written to file 'tabNN.ww3', where NN is the + ! unit umber (NDSTAB). + ! - Transfer file written to ww3.yymmddhh.spc with multiple + ! spectra and times in file. yymmddhh relates to first + ! output (NDSTAB). + ! - !/IC1 !/IC2 !/IC3 !/IC5 are not included in dissipation term + ! FIXME: ICE is a dummy variable at the moment + ! Include ice parameters in point output file out_pnt.ww3 + ! Ice coupling to SIN, SDS and SIC similar to w3srcemd.ftn + ! + ! 8. Structure : + ! + ! See source code. + ! + ! TOUT is the time defined in the input file + ! TIME is the time read from the out_pnt.ww3 file + ! DTREQ is the stride used for the time steps + ! at the beginning, if TOUT is after TIME, the program will read + ! out_pnt.ww3 DTREQ by DTREQ until TIME is equal to TOUT + ! /!\ if DTREQ is too big, it's possible to never have TIME=TOUT /!\ + ! + ! PASTDATE is the date of the last time step + ! DATE is the date of the current time step + ! IOUT is the counter of time iteration of a same file + ! + ! MFL is the number of stations processed in the 'time' loop + ! NOPTS is the total number of stations defined in out_pnt.ww3 + ! NFL is the number of bunch of MFL stations to loop on to + ! process all the NOPTS stations + ! NREQ is the number of valid stations to process, unvalid stations + ! are duplicata or stations not specified in the input file + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! !/NCO NCEP NCO modifications for operational implementation. + ! + ! !/O14 Buoy log file generation. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG + USE W3WDATMD, ONLY: W3SETW, W3NDAT #ifdef W3_NL1 - USE W3ADATMD, ONLY: W3SETA, W3NAUX + USE W3ADATMD, ONLY: W3SETA, W3NAUX #endif - USE W3ODATMD, ONLY: W3SETO, W3NOUT - USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT, DIMP - USE W3IOGRMD, ONLY: W3IOGR - USE W3IOPOMD, ONLY: W3IOPO - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STRSPLIT + USE W3ODATMD, ONLY: W3SETO, W3NOUT + USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT, DIMP + USE W3IOGRMD, ONLY: W3IOGR + USE W3IOPOMD, ONLY: W3IOPO + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STRSPLIT #ifdef W3_S - USE W3SERVMD, ONLY : STRACE -#endif - USE W3TIMEMD, ONLY: CALTYPE, STME21, TICK21, DSEC21, T2D, TSUB, U2D -!/ - USE W3GDATMD - USE W3WDATMD, ONLY: TIME - USE W3ODATMD, ONLY: NDSE, NDSO, NOPTS, PTLOC, PTNME, & - DPO, WAO, WDO, ASO, CAO, CDO, SPCO, FNMPRE,& - IPASS => IPASS2, ICEFO, ICEO, ICEHO + USE W3SERVMD, ONLY : STRACE +#endif + USE W3TIMEMD, ONLY: CALTYPE, STME21, TICK21, DSEC21, T2D, TSUB, U2D + !/ + USE W3GDATMD + USE W3WDATMD, ONLY: TIME + USE W3ODATMD, ONLY: NDSE, NDSO, NOPTS, PTLOC, PTNME, & + DPO, WAO, WDO, ASO, CAO, CDO, SPCO, FNMPRE,& + IPASS => IPASS2, ICEFO, ICEO, ICEHO #ifdef W3_FLX5 - USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO + USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO #endif #ifdef W3_T - USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST #endif #ifdef W3_SETUP - USE W3ODATMD, ONLY: ZET_SETO + USE W3ODATMD, ONLY: ZET_SETO #endif -! + ! #ifdef W3_O14 - USE W3ODATMD, ONLY: GRDID -#endif -! - USE W3NMLOUNPMD - USE NETCDF -! - IMPLICIT NONE -! + USE W3ODATMD, ONLY: GRDID +#endif + ! + USE W3NMLOUNPMD + USE NETCDF + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(NML_POINT_T) :: NML_POINT - TYPE(NML_FILE_T) :: NML_FILE - TYPE(NML_SPECTRA_T) :: NML_SPECTRA - TYPE(NML_PARAM_T) :: NML_PARAM - TYPE(NML_SOURCE_T) :: NML_SOURCE -! - INTEGER :: NDSI, NDSM, NDSOP, NDSTRC, NTRACE, & - IERR, I, NOUT, NREQ, ITYPE, OTYPE, & - IPOINT, IOTEST, ITH, IOUT, J, DIMXP, & - ICODE, STRL, STRL2, FLWW3, NBFILEOUT,& - S5, S3, NBSTATION, NCTYPE, & - NCFLUSH, NFL, MFL, IFL, NREQL, NOUTL,& - NDSEN, ONE, TWO, IRET, IP, NCVARTYPE - INTEGER :: ISCALE = 0 - INTEGER :: DIMID(7), DIMLN(5), VARID(28), & - STARTDATE(8), STOPDATE(8), & - TOUT(2), TDUM(2), TOUTL(2) + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(NML_POINT_T) :: NML_POINT + TYPE(NML_FILE_T) :: NML_FILE + TYPE(NML_SPECTRA_T) :: NML_SPECTRA + TYPE(NML_PARAM_T) :: NML_PARAM + TYPE(NML_SOURCE_T) :: NML_SOURCE + ! + INTEGER :: NDSI, NDSM, NDSOP, NDSTRC, NTRACE, & + IERR, I, NOUT, NREQ, ITYPE, OTYPE, & + IPOINT, IOTEST, ITH, IOUT, J, DIMXP, & + ICODE, STRL, STRL2, FLWW3, NBFILEOUT,& + S5, S3, NBSTATION, NCTYPE, & + NCFLUSH, NFL, MFL, IFL, NREQL, NOUTL,& + NDSEN, ONE, TWO, IRET, IP, NCVARTYPE + INTEGER :: ISCALE = 0 + INTEGER :: DIMID(7), DIMLN(5), VARID(28), & + STARTDATE(8), STOPDATE(8), & + TOUT(2), TDUM(2), TOUTL(2) #ifdef W3_MPI - INTEGER :: IERR_MPI + INTEGER :: IERR_MPI #endif #ifdef W3_O14 - INTEGER :: NDBO + INTEGER :: NDBO #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_NCO - INTEGER :: NDSTAB, NDST -#endif -! - INTEGER, ALLOCATABLE :: INDREQ(:), INDREQTMP(:) - INTEGER,ALLOCATABLE :: NCID(:) -! - REAL :: DTREQ, SCALE1, SCALE2, DTEST - REAL :: M2KM - REAL :: DTHD,RTH0 -! - REAL,ALLOCATABLE :: THD(:) - REAL, ALLOCATABLE :: XPART(:,:) -! - CHARACTER(LEN=16) :: DATE, PASTDATE - CHARACTER(LEN=30) :: FILEPREFIX, STRSTARTDATE, STRSTOPDATE - CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & - FILETIME*16, GLOBALATT*120, & - ATTNAME*120, ATTVAL*120 - CHARACTER(LEN=20) :: FORMAT1 - CHARACTER(LEN=8) :: EXT - CHARACTER(LEN=128) :: NCNAME - CHARACTER(LEN=25) :: IDSRCE(7) - CHARACTER :: SEP -! - CHARACTER(LEN=100),ALLOCATABLE :: POINTLIST(:) - CHARACTER(LEN=128),ALLOCATABLE :: NCFILE(:) -! - LOGICAL :: FLSRCE(7) - LOGICAL :: TOGETHER, ORDER, FLGNML - LOGICAL, ALLOCATABLE :: FLREQ(:) -! -!/ -!/ ------------------------------------------------------------------- / -!/ - DATA IDSRCE / 'Spectrum ' , & - 'Wind-wave interactions ' , & - 'Nonlinear interactions ' , & - 'Dissipation ' , & - 'Wave-bottom interactions ' , & - 'Wave-ice interactions ' , & - 'Sum of selected sources ' / - FLSRCE = .FALSE. -! + INTEGER :: NDSTAB +#endif +#if defined W3_NCO && !defined W3_T + INTEGER :: NDST +#endif + ! + INTEGER, ALLOCATABLE :: INDREQ(:), INDREQTMP(:) + INTEGER,ALLOCATABLE :: NCID(:) + ! + REAL :: DTREQ, SCALE1, SCALE2, DTEST + REAL :: M2KM + REAL :: DTHD,RTH0 + ! + REAL,ALLOCATABLE :: THD(:) + REAL, ALLOCATABLE :: XPART(:,:) + ! + CHARACTER(LEN=16) :: DATE, PASTDATE + CHARACTER(LEN=30) :: FILEPREFIX, STRSTARTDATE, STRSTOPDATE + CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & + FILETIME*16, GLOBALATT*120, & + ATTNAME*120, ATTVAL*120 + CHARACTER(LEN=20) :: FORMAT1 + CHARACTER(LEN=8) :: EXT + CHARACTER(LEN=128) :: NCNAME + CHARACTER(LEN=25) :: IDSRCE(7) + CHARACTER :: SEP + ! + CHARACTER(LEN=100),ALLOCATABLE :: POINTLIST(:) + CHARACTER(LEN=128),ALLOCATABLE :: NCFILE(:) + ! + LOGICAL :: FLSRCE(7) + LOGICAL :: TOGETHER, ORDER, FLGNML + LOGICAL, ALLOCATABLE :: FLREQ(:) + ! + !/ + !/ ------------------------------------------------------------------- / + !/ + DATA IDSRCE / 'Spectrum ' , & + 'Wind-wave interactions ' , & + 'Nonlinear interactions ' , & + 'Dissipation ' , & + 'Wave-bottom interactions ' , & + 'Wave-ice interactions ' , & + 'Sum of selected sources ' / + FLSRCE = .FALSE. + ! #ifdef W3_NCO -! CALL W3TAGB('WAVESPEC',1998,0007,0050,'NP21 ') -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1.a IO set-up. -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) + ! CALL W3TAGB('WAVESPEC',1998,0007,0050,'NP21 ') +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1.a IO set-up. + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) #ifdef W3_NL1 - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) -#endif - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! - NDSI = 10 - NDSM = 20 - NDSOP = 20 -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + NDSI = 10 + NDSM = 20 + NDSOP = 20 + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_S - CALL STRACE (IENT, 'W3OUNP') + CALL STRACE (IENT, 'W3OUNP') #endif -! + ! #ifdef W3_NCO -! -! Redo according to NCO -! - NDSI = 11 - NDSO = 6 - NDSE = NDSO - NDST = NDSO - NDSM = 12 - NDSOP = 13 + ! + ! Redo according to NCO + ! + NDSI = 11 + NDSO = 6 + NDSE = NDSO +# ifndef W3_T + NDST = NDSO +# endif + NDSM = 12 + NDSOP = 13 #endif #ifdef W3_O14 - NDBO = 14 + NDBO = 14 #endif #ifdef W3_NCO - NDSTRC = NDSO + NDSTRC = NDSO #endif -! -! -! 1.b MPP initializations -! + ! + ! + ! 1.b MPP initializations + ! #ifdef W3_SHRD - NAPROC = 1 - IAPROC = 1 + NAPROC = 1 + IAPROC = 1 #endif -! + ! #ifdef W3_MPI - CALL MPI_INIT ( IERR_MPI ) - CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) - CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) - IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC -#endif -! - IF ( IAPROC .EQ. NAPERR ) THEN - NDSEN = NDSE - ELSE - NDSEN = -1 - END IF -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,920) GNAME -! - IF ( FLAGLL ) THEN - M2KM = 1. - ELSE - M2KM = 1.E-3 - END IF -! - DIMXP = ((NK+1)/2) * ((NTH-1)/2) - ALLOCATE ( XPART(DIMP,0:DIMXP) ) - XPART = UNDEF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read general data and first fields from file -! - CALL W3IOPO ( 'READ', NDSOP, IOTEST ) -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,930) - DO I=1, NOPTS - IF ( FLAGLL ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,931) PTNME(I), M2KM*PTLOC(1,I), M2KM*PTLOC(2,I) - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,932) PTNME(I), M2KM*PTLOC(1,I), M2KM*PTLOC(2,I) + CALL MPI_INIT ( IERR_MPI ) + CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC +#endif + ! + IF ( IAPROC .EQ. NAPERR ) THEN + NDSEN = NDSE + ELSE + NDSEN = -1 + END IF + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,920) GNAME + ! + IF ( FLAGLL ) THEN + M2KM = 1. + ELSE + M2KM = 1.E-3 + END IF + ! + DIMXP = ((NK+1)/2) * ((NTH-1)/2) + ALLOCATE ( XPART(DIMP,0:DIMXP) ) + XPART = UNDEF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read general data and first fields from file + ! + CALL W3IOPO ( 'READ', NDSOP, IOTEST ) + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,930) + DO I=1, NOPTS + IF ( FLAGLL ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,931) PTNME(I), M2KM*PTLOC(1,I), M2KM*PTLOC(2,I) + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,932) PTNME(I), M2KM*PTLOC(1,I), M2KM*PTLOC(2,I) + END IF + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Read requests from input file. + ! + + ! + ! process ww3_ounp namelist + ! + INQUIRE(FILE=TRIM(FNMPRE)//"ww3_ounp.nml", EXIST=FLGNML) + IF (FLGNML) THEN + ! Read namelist + CALL W3NMLOUNP (NDSI, TRIM(FNMPRE)//'ww3_ounp.nml', NML_POINT, NML_FILE, & + NML_SPECTRA, NML_PARAM, NML_SOURCE, IERR) + + ! 4.1 Time setup IDTIME, DTREQ, NOUT + READ(NML_POINT%TIMESTRIDE, *) DTREQ + READ(NML_POINT%TIMECOUNT, *) NOUT + READ(NML_POINT%TIMESTART, *) TOUT(1), TOUT(2) + + ! 4.2 Output points NOPTS + ALLOCATE(POINTLIST(NOPTS+1)) + POINTLIST(:)='' + CALL STRSPLIT(NML_POINT%LIST,POINTLIST) + ! + ALLOCATE ( FLREQ(NOPTS) ) + ALLOCATE ( INDREQTMP(NOPTS) ) + FLREQ = .FALSE. + NREQ = 0 + ALLOCATE (NCFILE(NOPTS)) + ALLOCATE (NCID(NOPTS)) + NBSTATION = 1 + ! full list of point indexes + IF (TRIM(POINTLIST(1)).EQ.'all') THEN + FLREQ = .TRUE. + NREQ = NOPTS + INDREQTMP=(/(J,J=1,NREQ)/) + ! user defined list of point indexes + ELSE + IP=0 + DO WHILE (LEN_TRIM(POINTLIST(IP+1)).NE.0) + IP=IP+1 + READ(POINTLIST(IP),*) IPOINT + ! existing index in out_pnt.ww3 + IF ((IPOINT .LE. NOPTS) .AND. (NREQ .LT. NOPTS)) THEN + IF ( .NOT. FLREQ(IPOINT) ) THEN + NREQ = NREQ + 1 + INDREQTMP(NREQ)=IPOINT + END IF + FLREQ(IPOINT) = .TRUE. END IF END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Read requests from input file. -! - -! -! process ww3_ounp namelist -! - INQUIRE(FILE=TRIM(FNMPRE)//"ww3_ounp.nml", EXIST=FLGNML) - IF (FLGNML) THEN - ! Read namelist - CALL W3NMLOUNP (NDSI, TRIM(FNMPRE)//'ww3_ounp.nml', NML_POINT, NML_FILE, & - NML_SPECTRA, NML_PARAM, NML_SOURCE, IERR) - -! 4.1 Time setup IDTIME, DTREQ, NOUT - READ(NML_POINT%TIMESTRIDE, *) DTREQ - READ(NML_POINT%TIMECOUNT, *) NOUT - READ(NML_POINT%TIMESTART, *) TOUT(1), TOUT(2) - -! 4.2 Output points NOPTS - ALLOCATE(POINTLIST(NOPTS+1)) - POINTLIST(:)='' - CALL STRSPLIT(NML_POINT%LIST,POINTLIST) -! - ALLOCATE ( FLREQ(NOPTS) ) - ALLOCATE ( INDREQTMP(NOPTS) ) - FLREQ = .FALSE. - NREQ = 0 - ALLOCATE (NCFILE(NOPTS)) - ALLOCATE (NCID(NOPTS)) - NBSTATION = 1 - ! full list of point indexes - IF (TRIM(POINTLIST(1)).EQ.'all') THEN + END IF + + ! 4.3 Output type + FLWW3 = 0 + FILEPREFIX = NML_FILE%PREFIX + NCTYPE = NML_FILE%NETCDF + S3 = NML_POINT%TIMESPLIT + TOGETHER = NML_POINT%SAMEFILE + MFL = NML_POINT%BUFFER + ITYPE = NML_POINT%TYPE + ORDER = NML_POINT%DIMORDER + ! + IF (ITYPE .EQ. 1) THEN + OTYPE = NML_SPECTRA%OUTPUT + SCALE1 = NML_SPECTRA%SCALE_FAC + SCALE2 = NML_SPECTRA%OUTPUT_FAC + NCVARTYPE = NML_SPECTRA%TYPE + ELSE IF (ITYPE .EQ. 2) THEN + OTYPE = NML_PARAM%OUTPUT + ELSE IF (ITYPE .EQ. 3) THEN + OTYPE = NML_SOURCE%OUTPUT + SCALE1 = NML_SOURCE%SCALE_FAC + SCALE2 = NML_SOURCE%OUTPUT_FAC + FLSRCE(1) = NML_SOURCE%SPECTRUM + FLSRCE(2) = NML_SOURCE%INPUT + FLSRCE(3) = NML_SOURCE%INTERACTIONS + FLSRCE(4) = NML_SOURCE%DISSIPATION + FLSRCE(5) = NML_SOURCE%BOTTOM + FLSRCE(6) = NML_SOURCE%ICE + FLSRCE(7) = NML_SOURCE%TOTAL + ISCALE = NML_SOURCE%TABLE_FAC + END IF + + + END IF ! FLGNML + + ! + ! process old ww3_ounp.inp format + ! + IF (.NOT. FLGNML) THEN + OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_ounp.inp',STATUS='OLD',ERR=800,IOSTAT=IERR) + REWIND (NDSI) + + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + + ! 4.1 Time setup IDTIME, DTREQ, NOUT + READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT + + ! 4.2 Output points NOPTS + ALLOCATE ( FLREQ(NOPTS) ) + ALLOCATE ( INDREQTMP(NOPTS) ) + FLREQ = .FALSE. + NREQ = 0 + ALLOCATE (NCFILE(NOPTS)) + ALLOCATE (NCID(NOPTS)) + NBSTATION = 1 + ! + DO I=1, NOPTS + ! reads point index + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) IPOINT + ! last index + IF (IPOINT .LT. 0) THEN + IF (I.EQ.1) THEN FLREQ = .TRUE. NREQ = NOPTS INDREQTMP=(/(J,J=1,NREQ)/) - ! user defined list of point indexes - ELSE - IP=0 - DO WHILE (LEN_TRIM(POINTLIST(IP+1)).NE.0) - IP=IP+1 - READ(POINTLIST(IP),*) IPOINT - ! existing index in out_pnt.ww3 - IF ((IPOINT .LE. NOPTS) .AND. (NREQ .LT. NOPTS)) THEN - IF ( .NOT. FLREQ(IPOINT) ) THEN - NREQ = NREQ + 1 - INDREQTMP(NREQ)=IPOINT - END IF - FLREQ(IPOINT) = .TRUE. - END IF - END DO - END IF - -! 4.3 Output type - FLWW3 = 0 - FILEPREFIX = NML_FILE%PREFIX - NCTYPE = NML_FILE%NETCDF - S3 = NML_POINT%TIMESPLIT - TOGETHER = NML_POINT%SAMEFILE - MFL = NML_POINT%BUFFER - ITYPE = NML_POINT%TYPE - ORDER = NML_POINT%DIMORDER -! - IF (ITYPE .EQ. 1) THEN - OTYPE = NML_SPECTRA%OUTPUT - SCALE1 = NML_SPECTRA%SCALE_FAC - SCALE2 = NML_SPECTRA%OUTPUT_FAC - NCVARTYPE = NML_SPECTRA%TYPE - ELSE IF (ITYPE .EQ. 2) THEN - OTYPE = NML_PARAM%OUTPUT - ELSE IF (ITYPE .EQ. 3) THEN - OTYPE = NML_SOURCE%OUTPUT - SCALE1 = NML_SOURCE%SCALE_FAC - SCALE2 = NML_SOURCE%OUTPUT_FAC - FLSRCE(1) = NML_SOURCE%SPECTRUM - FLSRCE(2) = NML_SOURCE%INPUT - FLSRCE(3) = NML_SOURCE%INTERACTIONS - FLSRCE(4) = NML_SOURCE%DISSIPATION - FLSRCE(5) = NML_SOURCE%BOTTOM - FLSRCE(6) = NML_SOURCE%ICE - FLSRCE(7) = NML_SOURCE%TOTAL - ISCALE = NML_SOURCE%TABLE_FAC END IF - - - END IF ! FLGNML - -! -! process old ww3_ounp.inp format -! - IF (.NOT. FLGNML) THEN - OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_ounp.inp',STATUS='OLD',ERR=800,IOSTAT=IERR) - REWIND (NDSI) - - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - -! 4.1 Time setup IDTIME, DTREQ, NOUT - READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT - -! 4.2 Output points NOPTS - ALLOCATE ( FLREQ(NOPTS) ) - ALLOCATE ( INDREQTMP(NOPTS) ) - FLREQ = .FALSE. - NREQ = 0 - ALLOCATE (NCFILE(NOPTS)) - ALLOCATE (NCID(NOPTS)) - NBSTATION = 1 -! - DO I=1, NOPTS - ! reads point index - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) IPOINT - ! last index - IF (IPOINT .LT. 0) THEN - IF (I.EQ.1) THEN - FLREQ = .TRUE. - NREQ = NOPTS - INDREQTMP=(/(J,J=1,NREQ)/) - END IF - EXIT - END IF - ! existing index in out_pnt.ww3 - IF ( (IPOINT .GT. 0) .AND. (IPOINT .LE. NOPTS) ) THEN - IF ( .NOT. FLREQ(IPOINT) ) THEN - NREQ = NREQ + 1 - INDREQTMP(NREQ)=IPOINT - END IF - FLREQ(IPOINT) = .TRUE. - END IF - ! read the 'end of list' if nopts reached before it - IF ( (IPOINT .GT. 0) .AND. (NREQ .EQ. NOPTS) ) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) IPOINT - END IF - END DO - ! check if last point index is -1 - IF (IPOINT .NE. -1) THEN - WRITE (NDSE,1007) - CALL EXTCDE ( 47 ) + EXIT + END IF + ! existing index in out_pnt.ww3 + IF ( (IPOINT .GT. 0) .AND. (IPOINT .LE. NOPTS) ) THEN + IF ( .NOT. FLREQ(IPOINT) ) THEN + NREQ = NREQ + 1 + INDREQTMP(NREQ)=IPOINT END IF - -! 4.3 Output type - FILEPREFIX= 'ww3.' - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) FILEPREFIX - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) S3 - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) NCTYPE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) TOGETHER, MFL - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) ITYPE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) FLWW3 - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) ORDER + FLREQ(IPOINT) = .TRUE. + END IF + ! read the 'end of list' if nopts reached before it + IF ( (IPOINT .GT. 0) .AND. (NREQ .EQ. NOPTS) ) THEN CALL NEXTLN ( COMSTR , NDSI , NDSE ) -! - IF (ITYPE .EQ. 1) READ (NDSI,*,END=801,ERR=802) OTYPE, SCALE1, SCALE2, NCVARTYPE - IF (ITYPE .EQ. 2) READ (NDSI,*,END=801,ERR=802) OTYPE - IF (ITYPE .EQ. 3) READ (NDSI,*,END=801,ERR=802) OTYPE, SCALE1, SCALE2, FLSRCE, ISCALE - - CLOSE(NDSI,ERR=800,IOSTAT=IERR) - - END IF ! .NOT. FLGNML - -! - -! 4.1 Time setup IDTIME, DTREQ, NOUT - DTREQ = MAX ( 0. , DTREQ ) - IF ( DTREQ.EQ.0 ) NOUT = 1 - NOUT = MAX ( 1 , NOUT ) - NOUTL = NOUT - TOUTL = TOUT - CALL STME21 ( TOUT , IDTIME ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,940) IDTIME - TDUM = 0 - CALL TICK21 ( TDUM , DTREQ ) - CALL STME21 ( TDUM , IDTIME ) - IF ( DTREQ .GE. 86400. ) THEN - WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) - ELSE - IDDDAY = ' ' + READ (NDSI,*,END=801,ERR=802) IPOINT END IF - IDTIME(1:11) = IDDDAY - IDTIME(21:23) = ' ' - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,941) IDTIME, NOUT - - -! 4.1.2 Selects first time FILETIME between out_pnt.ww3 and ww3_ounp.nml - IF (TOUT(1).GT.TIME(1) .OR. (TOUT(1).EQ.TIME(1) .AND. TOUT(2).GT.TIME(2))) THEN - WRITE(DATE,'(I8.8,I6.6)') TOUT(1), TOUT(2) - ELSE - WRITE(DATE,'(I8.8,I6.6)') TIME(1), TIME(2) + END DO + ! check if last point index is -1 + IF (IPOINT .NE. -1) THEN + WRITE (NDSE,1007) + CALL EXTCDE ( 47 ) + END IF + + ! 4.3 Output type + FILEPREFIX= 'ww3.' + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) FILEPREFIX + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) S3 + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) NCTYPE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) TOGETHER, MFL + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) ITYPE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) FLWW3 + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) ORDER + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ! + IF (ITYPE .EQ. 1) READ (NDSI,*,END=801,ERR=802) OTYPE, SCALE1, SCALE2, NCVARTYPE + IF (ITYPE .EQ. 2) READ (NDSI,*,END=801,ERR=802) OTYPE + IF (ITYPE .EQ. 3) READ (NDSI,*,END=801,ERR=802) OTYPE, SCALE1, SCALE2, FLSRCE, ISCALE + + CLOSE(NDSI,ERR=800,IOSTAT=IERR) + + END IF ! .NOT. FLGNML + + ! + + ! 4.1 Time setup IDTIME, DTREQ, NOUT + DTREQ = MAX ( 0. , DTREQ ) + IF ( DTREQ.EQ.0 ) NOUT = 1 + NOUT = MAX ( 1 , NOUT ) + NOUTL = NOUT + TOUTL = TOUT + CALL STME21 ( TOUT , IDTIME ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,940) IDTIME + TDUM = 0 + CALL TICK21 ( TDUM , DTREQ ) + CALL STME21 ( TDUM , IDTIME ) + IF ( DTREQ .GE. 86400. ) THEN + WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) + ELSE + IDDDAY = ' ' + END IF + IDTIME(1:11) = IDDDAY + IDTIME(21:23) = ' ' + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,941) IDTIME, NOUT + + + ! 4.1.2 Selects first time FILETIME between out_pnt.ww3 and ww3_ounp.nml + IF (TOUT(1).GT.TIME(1) .OR. (TOUT(1).EQ.TIME(1) .AND. TOUT(2).GT.TIME(2))) THEN + WRITE(DATE,'(I8.8,I6.6)') TOUT(1), TOUT(2) + ELSE + WRITE(DATE,'(I8.8,I6.6)') TIME(1), TIME(2) + END IF + WRITE(FILETIME,'(8A)') DATE(1:4), DATE(5:6), DATE(7:8), 'T', DATE(9:10), 'Z' + + + ! 4.1.3 Loops on TIME from out_pnt file to reach the first time PASTDATE + DTEST = DSEC21 ( TIME , TOUT ) + DO WHILE (DTEST.NE.0) + DTEST = DSEC21 ( TIME , TOUT ) + IF ( DTEST .GT. 0. ) THEN + CALL W3IOPO ( 'READ', NDSOP, IOTEST ) + IF ( IOTEST .EQ. -1 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,949) + GOTO 888 END IF - WRITE(FILETIME,'(8A)') DATE(1:4), DATE(5:6), DATE(7:8), 'T', DATE(9:10), 'Z' - - -! 4.1.3 Loops on TIME from out_pnt file to reach the first time PASTDATE - DTEST = DSEC21 ( TIME , TOUT ) - DO WHILE (DTEST.NE.0) - DTEST = DSEC21 ( TIME , TOUT ) - IF ( DTEST .GT. 0. ) THEN - CALL W3IOPO ( 'READ', NDSOP, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,949) - GOTO 888 - END IF + CYCLE + END IF + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF + END DO + WRITE(PASTDATE,'(I8.8,I6.6)') TIME(1), TIME(2) + + + ! 4.2 Output points NOPTS + ALLOCATE ( INDREQ(NREQ) ) + INDREQ(:)=INDREQTMP(1:NREQ) + DEALLOCATE(INDREQTMP) + + + ! 4.3 Output type + ! + ! S3 defines the number of characters in the date for the filename + ! S3=0 -> empty, S3=4 -> YYYY, S3=6 -> YYYYMM, S3=10 -> YYYYMMDDHH + ! + ! Setups min and max date format + IF (S3.GT.0 .AND. S3.LT.4) S3=4 + IF (S3.GT.10) S3=10 + ! + ! Defines the format of FILETIME as ISO8601 convention + S5=S3-8 + ! if S3=>YYYYMMDDHH then filetime='YYYYMMDDTHHMMSSZ' + IF (S3.EQ.0) THEN + FILETIME = '' + ELSE IF (S3.EQ.10) THEN + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I8.8,A1,I',S5,'.',S5,',A1)' + WRITE (FILETIME,FORMAT1) TIME(1), 'T', & + FLOOR(REAL(TIME(2))/NINT(10.**(6-S5))), 'Z' + ! if S3=>YYYYMMDD then filetime='YYYYMMDD' + ELSE IF (S3.EQ.8) THEN + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' + WRITE (FILETIME,FORMAT1) TIME(1) + ! if S3=>YYYYMM then filetime='YYYYMM' + ! or S3=>YYYY then filetime='YYYY' + ELSE + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' + WRITE (FILETIME,FORMAT1) FLOOR(REAL(TIME(1))/NINT(10.**(8-S3))) + END IF + ! + ! order time,station + IF (ORDER) THEN + ONE=1 + TWO=2 + ! order station,time + ELSE + ONE=2 + TWO=1 + END IF + ! + IF ((NCTYPE.EQ.3) .AND. (.NOT.ORDER)) GOTO 803 + IF ((NCTYPE.EQ.4) .AND. INDEX(NF90_INQ_LIBVERS(),'"3.').NE.0) GOTO 804 + + + ! 4.4 Converts direction unit in degree + ALLOCATE(THD(NTH)) + DTHD=360./NTH + RTH0=TH(1)/DTH + DO ITH=1, NTH + THD(ITH)=DTHD*(RTH0+REAL(ITH-1)) + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Now creates files + ! If too many (memory problem) then makes several reads + ! + + + ! 5.1 Defines number of files/stations per file NFL + IF (TOGETHER) THEN + NFL=1 + ELSE + NFL=1+NOPTS/MFL + END IF + + + ! 5.2 Creates filename listing + SEP = '_' + IF(S3 .EQ. 0) SEP = '' ! No "_" separator if no datetime string. + WRITE(EXT,'(A)') '' + IF ((ITYPE .EQ. 1) .AND. (OTYPE.EQ.2)) WRITE(EXT,'(A,A)') TRIM(SEP), 'tab.nc' + IF ((ITYPE .EQ. 1) .AND. (OTYPE.EQ.3)) WRITE(EXT,'(A,A)') TRIM(SEP), 'spec.nc' + IF ((ITYPE .EQ. 1) .AND. (OTYPE.EQ.4)) WRITE(EXT,'(A,A)') TRIM(SEP), 'tab.nc' + IF (ITYPE .EQ. 2) WRITE(EXT,'(A,A)') TRIM(SEP), 'tab.nc' + IF ((ITYPE .EQ. 3) .AND. (OTYPE.EQ.2)) WRITE(EXT,'(A,A)') TRIM(SEP), 'tab.nc' + IF ((ITYPE .EQ. 3) .AND. (OTYPE.EQ.3)) WRITE(EXT,'(A,A)') TRIM(SEP), 'tab.nc' + IF ((ITYPE .EQ. 3) .AND. (OTYPE.EQ.4)) WRITE(EXT,'(A,A)') TRIM(SEP), 'src.nc' + ! checks if extension exists + IF (LEN_TRIM(EXT).EQ.0) THEN + WRITE (NDSE,1006) + CALL EXTCDE ( 46 ) + END IF + + ! 5.3 Redefines netCDF type + IF((NCTYPE.EQ.4).AND.(.NOT.TOGETHER).AND.(NFL.GT.300).AND.(NREQ.GT.9000)) THEN + WRITE(NDSO,'(A)') ' WARNING : Files will be generated in netCDF3 with NF90_share mode' + WRITE(NDSO,'(A)') ' WARNING : this is due to NF90_sync memory problem with netCDF4 library' + WRITE(NDSO,'(A)') ' WARNING : to convert in netCDF4, use ncks -h -a -4 -L 9 file.nc3 file.nc4' + WRITE(NDSO,'(A)') ' WARNING : or use option "Points in same file" with value TRUE in .inp file' + WRITE(NDSO,'(A)') ' WARNING : or limit the output points list to less than 300' + NCTYPE=3 + END IF + + + + ! 5.4 Defines periodic flushing of buffer (only available for netCDF3) + NCFLUSH=FLOOR(15E7/(FLOAT(NK)*FLOAT(NTH)*FLOAT(NREQ)/NFL)) + IF (NCTYPE.EQ.3.AND.NREQ.GT.10.AND.(.NOT.TOGETHER)) WRITE(NDSO,5940) NCFLUSH + + + ! 5.5 Removes the duplicata if "ONE file per station" mode + IF (.NOT.TOGETHER) THEN + ! defines a file name per station (NOT TOGETHER) + DO I=1,NOPTS + IF (FLREQ(I)) THEN + J = LEN_TRIM(FNMPRE) + WRITE (NCNAME, '(5A)') TRIM(FILEPREFIX), TRIM(PTNME(I)),'_', TRIM(FILETIME), TRIM(EXT) + WRITE(NCFILE(I),'(2A)') TRIM(FNMPRE(:J)), TRIM(NCNAME) ! filename + IF( SUM(index(NCFILE(:),NCFILE(I))).GT.1 ) THEN + FLREQ(I)=.FALSE. + WRITE(NDSO,5950) TRIM(PTNME(I)) CYCLE END IF - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF - END DO - WRITE(PASTDATE,'(I8.8,I6.6)') TIME(1), TIME(2) - - -! 4.2 Output points NOPTS - ALLOCATE ( INDREQ(NREQ) ) - INDREQ(:)=INDREQTMP(1:NREQ) - DEALLOCATE(INDREQTMP) - - -! 4.3 Output type -! - ! S3 defines the number of characters in the date for the filename - ! S3=0 -> empty, S3=4 -> YYYY, S3=6 -> YYYYMM, S3=10 -> YYYYMMDDHH -! - ! Setups min and max date format - IF (S3.GT.0 .AND. S3.LT.4) S3=4 - IF (S3.GT.10) S3=10 -! - ! Defines the format of FILETIME as ISO8601 convention - S5=S3-8 - ! if S3=>YYYYMMDDHH then filetime='YYYYMMDDTHHMMSSZ' - IF (S3.EQ.0) THEN - FILETIME = '' - ELSE IF (S3.EQ.10) THEN - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I8.8,A1,I',S5,'.',S5,',A1)' - WRITE (FILETIME,FORMAT1) TIME(1), 'T', & - FLOOR(REAL(TIME(2))/NINT(10.**(6-S5))), 'Z' + END IF ! FLREQ(I) + END DO ! I=1,NOPTS + END IF ! .NOT.TOGETHER + + + ! 5.6 Loops on bunch of stations NFL + DO IFL=IAPROC,NFL,NAPROC + ! + ! new file, so the time counter is initialized +560 CONTINUE + IOUT=0 + + + ! 5.6.1 Redefines the filetime when it's a new date defined by the date division S3 + ! if S3=>YYYYMMDDHH then filetime='YYYYMMDDTHHMMSSZ' + IF (S3.EQ.0) THEN + FILETIME = '' + ELSE IF (S3.EQ.10) THEN + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I8.8,A1,I',S5,'.',S5,',A1)' + WRITE (FILETIME,FORMAT1) TIME(1), 'T', & + NINT(REAL(TIME(2))/NINT(10.**(6-S5))), 'Z' ! if S3=>YYYYMMDD then filetime='YYYYMMDD' - ELSE IF (S3.EQ.8) THEN - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' - WRITE (FILETIME,FORMAT1) TIME(1) + ELSE IF (S3.EQ.8) THEN + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' + WRITE (FILETIME,FORMAT1) TIME(1) ! if S3=>YYYYMM then filetime='YYYYMM' ! or S3=>YYYY then filetime='YYYY' - ELSE - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' - WRITE (FILETIME,FORMAT1) FLOOR(REAL(TIME(1))/NINT(10.**(8-S3))) - END IF -! - ! order time,station - IF (ORDER) THEN - ONE=1 - TWO=2 - ! order station,time - ELSE - ONE=2 - TWO=1 - END IF -! - IF ((NCTYPE.EQ.3) .AND. (.NOT.ORDER)) GOTO 803 - IF ((NCTYPE.EQ.4) .AND. INDEX(NF90_INQ_LIBVERS(),'"3.').NE.0) GOTO 804 - - -! 4.4 Converts direction unit in degree - ALLOCATE(THD(NTH)) - DTHD=360./NTH - RTH0=TH(1)/DTH - DO ITH=1, NTH - THD(ITH)=DTHD*(RTH0+REAL(ITH-1)) + ELSE + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' + WRITE (FILETIME,FORMAT1) NINT(REAL(TIME(1))/NINT(10.**(8-S3))) + END IF + + + ! 5.6.2 Defines the file names + ! defines unique file name (TOGETHER) + IF (TOGETHER) THEN + WRITE (NCNAME, '(3A)') TRIM(FILEPREFIX), TRIM(FILETIME), TRIM(EXT) + !IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1947) TRIM(NCNAME) + J = LEN_TRIM(FNMPRE) + WRITE(NCFILE(1),'(2A)') TRIM(FNMPRE(:J)), TRIM(NCNAME) ! filename + ELSE + ! defines a file name per station (NOT TOGETHER) + DO I=1,NOPTS + IF (FLREQ(I)) THEN + WRITE (NCNAME, '(5A)') TRIM(FILEPREFIX), TRIM(PTNME(I)),'_', TRIM(FILETIME), TRIM(EXT) + !IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1947) TRIM(NCNAME) + J = LEN_TRIM(FNMPRE) + WRITE(NCFILE(I),'(2A)') TRIM(FNMPRE(:J)), TRIM(NCNAME) ! filename + END IF ! FLREQ(I) + END DO ! I=1,NOPTS + END IF ! TOGETHER + + + ! 5.6.3 Defines number of stations and files to CREATE + ! together + IF (TOGETHER) THEN + NBFILEOUT = 1 + NBSTATION = NREQ + NREQL=NBFILEOUT + ! not together + ELSE + NBFILEOUT=MIN(MFL,NOPTS-(IFL-1)*MFL) + NBSTATION = 1 + NREQL=0 + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + IF ( FLREQ(I) ) THEN + NREQL = NREQL + 1 + END IF END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Now creates files -! If too many (memory problem) then makes several reads -! - - -! 5.1 Defines number of files/stations per file NFL - IF (TOGETHER) THEN - NFL=1 - ELSE - NFL=1+NOPTS/MFL - END IF + END IF + ! cycle if no file to CREATE + IF (NREQL.EQ.0) CYCLE -! 5.2 Creates filename listing - SEP = '_' - IF(S3 .EQ. 0) SEP = '' ! No "_" separator if no datetime string. - WRITE(EXT,'(A)') '' - IF ((ITYPE .EQ. 1) .AND. (OTYPE.EQ.2)) WRITE(EXT,'(A,A)') TRIM(SEP), 'tab.nc' - IF ((ITYPE .EQ. 1) .AND. (OTYPE.EQ.3)) WRITE(EXT,'(A,A)') TRIM(SEP), 'spec.nc' - IF ((ITYPE .EQ. 1) .AND. (OTYPE.EQ.4)) WRITE(EXT,'(A,A)') TRIM(SEP), 'tab.nc' - IF (ITYPE .EQ. 2) WRITE(EXT,'(A,A)') TRIM(SEP), 'tab.nc' - IF ((ITYPE .EQ. 3) .AND. (OTYPE.EQ.2)) WRITE(EXT,'(A,A)') TRIM(SEP), 'tab.nc' - IF ((ITYPE .EQ. 3) .AND. (OTYPE.EQ.3)) WRITE(EXT,'(A,A)') TRIM(SEP), 'tab.nc' - IF ((ITYPE .EQ. 3) .AND. (OTYPE.EQ.4)) WRITE(EXT,'(A,A)') TRIM(SEP), 'src.nc' - ! checks if extension exists - IF (LEN_TRIM(EXT).EQ.0) THEN - WRITE (NDSE,1006) - CALL EXTCDE ( 46 ) - END IF - -! 5.3 Redefines netCDF type - IF((NCTYPE.EQ.4).AND.(.NOT.TOGETHER).AND.(NFL.GT.300).AND.(NREQ.GT.9000)) THEN - WRITE(NDSO,'(A)') ' WARNING : Files will be generated in netCDF3 with NF90_share mode' - WRITE(NDSO,'(A)') ' WARNING : this is due to NF90_sync memory problem with netCDF4 library' - WRITE(NDSO,'(A)') ' WARNING : to convert in netCDF4, use ncks -h -a -4 -L 9 file.nc3 file.nc4' - WRITE(NDSO,'(A)') ' WARNING : or use option "Points in same file" with value TRUE in .inp file' - WRITE(NDSO,'(A)') ' WARNING : or limit the output points list to less than 300' - NCTYPE=3 - END IF - + ! 5.6.4 Creates netcdf file + ! ... ITYPE = 1 + IF (ITYPE .EQ. 1) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) ITYPE, '1-D and/or 2-D spectra, pass #',IFL -! 5.4 Defines periodic flushing of buffer (only available for netCDF3) - NCFLUSH=FLOOR(15E7/(FLOAT(NK)*FLOAT(NTH)*FLOAT(NREQ)/NFL)) - IF (NCTYPE.EQ.3.AND.NREQ.GT.10.AND.(.NOT.TOGETHER)) WRITE(NDSO,5940) NCFLUSH - - -! 5.5 Removes the duplicata if "ONE file per station" mode - IF (.NOT.TOGETHER) THEN - ! defines a file name per station (NOT TOGETHER) - DO I=1,NOPTS - IF (FLREQ(I)) THEN - J = LEN_TRIM(FNMPRE) - WRITE (NCNAME, '(5A)') TRIM(FILEPREFIX), TRIM(PTNME(I)),'_', TRIM(FILETIME), TRIM(EXT) - WRITE(NCFILE(I),'(2A)') TRIM(FNMPRE(:J)), TRIM(NCNAME) ! filename - IF( SUM(index(NCFILE(:),NCFILE(I))).GT.1 ) THEN - FLREQ(I)=.FALSE. - WRITE(NDSO,5950) TRIM(PTNME(I)) - CYCLE - END IF - END IF ! FLREQ(I) - END DO ! I=1,NOPTS - END IF ! .NOT.TOGETHER - - -! 5.6 Loops on bunch of stations NFL - DO IFL=IAPROC,NFL,NAPROC -! - ! new file, so the time counter is initialized - 560 CONTINUE - IOUT=0 - - -! 5.6.1 Redefines the filetime when it's a new date defined by the date division S3 - ! if S3=>YYYYMMDDHH then filetime='YYYYMMDDTHHMMSSZ' - IF (S3.EQ.0) THEN - FILETIME = '' - ELSE IF (S3.EQ.10) THEN - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I8.8,A1,I',S5,'.',S5,',A1)' - WRITE (FILETIME,FORMAT1) TIME(1), 'T', & - NINT(REAL(TIME(2))/NINT(10.**(6-S5))), 'Z' - ! if S3=>YYYYMMDD then filetime='YYYYMMDD' - ELSE IF (S3.EQ.8) THEN - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' - WRITE (FILETIME,FORMAT1) TIME(1) - ! if S3=>YYYYMM then filetime='YYYYMM' - ! or S3=>YYYY then filetime='YYYY' + ! ... OTYPE = 1 + IF (OTYPE .EQ. 1) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'print plots' + IF ( SCALE1 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1940) '1-D' + ELSE IF ( SCALE1 .EQ. 0. ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1941) '1-D' ELSE - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' - WRITE (FILETIME,FORMAT1) NINT(REAL(TIME(1))/NINT(10.**(8-S3))) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1942) '1-D', SCALE1 END IF - - -! 5.6.2 Defines the file names - ! defines unique file name (TOGETHER) - IF (TOGETHER) THEN - WRITE (NCNAME, '(3A)') TRIM(FILEPREFIX), TRIM(FILETIME), TRIM(EXT) - !IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1947) TRIM(NCNAME) - J = LEN_TRIM(FNMPRE) - WRITE(NCFILE(1),'(2A)') TRIM(FNMPRE(:J)), TRIM(NCNAME) ! filename + IF ( SCALE2 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1940) '2-D' + ELSE IF ( SCALE2 .EQ. 0. ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1941) '2-D' ELSE - ! defines a file name per station (NOT TOGETHER) - DO I=1,NOPTS - IF (FLREQ(I)) THEN - WRITE (NCNAME, '(5A)') TRIM(FILEPREFIX), TRIM(PTNME(I)),'_', TRIM(FILETIME), TRIM(EXT) - !IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1947) TRIM(NCNAME) - J = LEN_TRIM(FNMPRE) - WRITE(NCFILE(I),'(2A)') TRIM(FNMPRE(:J)), TRIM(NCNAME) ! filename - END IF ! FLREQ(I) - END DO ! I=1,NOPTS - END IF ! TOGETHER - - -! 5.6.3 Defines number of stations and files to CREATE - ! together - IF (TOGETHER) THEN - NBFILEOUT = 1 - NBSTATION = NREQ - NREQL=NBFILEOUT - ! not together - ELSE - NBFILEOUT=MIN(MFL,NOPTS-(IFL-1)*MFL) - NBSTATION = 1 - NREQL=0 - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - IF ( FLREQ(I) ) THEN - NREQL = NREQL + 1 - END IF - END DO + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1942) '2-D', SCALE2 END IF - ! cycle if no file to CREATE - IF (NREQL.EQ.0) CYCLE - - -! 5.6.4 Creates netcdf file - -! ... ITYPE = 1 - IF (ITYPE .EQ. 1) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) ITYPE, '1-D and/or 2-D spectra, pass #',IFL - -! ... OTYPE = 1 - IF (OTYPE .EQ. 1) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'print plots' - IF ( SCALE1 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1940) '1-D' - ELSE IF ( SCALE1 .EQ. 0. ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1941) '1-D' - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1942) '1-D', SCALE1 - END IF - IF ( SCALE2 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1940) '2-D' - ELSE IF ( SCALE2 .EQ. 0. ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1941) '2-D' - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1942) '2-D', SCALE2 - END IF -! ... OTYPE = 2 - ELSE IF ( OTYPE .EQ. 2 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Table of 1-D spectral data' - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - IF (FLREQ(I) .OR. TOGETHER) THEN - ! Create the netCDF file - DIMLN(1)=NF90_UNLIMITED ! time - DIMLN(2)=NBSTATION ! station - DIMLN(3)=40 ! string station name length - DIMLN(4)=NK ! FREQ - CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO) - END IF - END DO + ! ... OTYPE = 2 + ELSE IF ( OTYPE .EQ. 2 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Table of 1-D spectral data' + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + IF (FLREQ(I) .OR. TOGETHER) THEN + ! Create the netCDF file + DIMLN(1)=NF90_UNLIMITED ! time + DIMLN(2)=NBSTATION ! station + DIMLN(3)=40 ! string station name length + DIMLN(4)=NK ! FREQ + CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO) + END IF + END DO -! ... OTYPE = 3 - ELSE IF ( OTYPE .EQ. 3 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Transfer file' - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - IF (FLREQ(I) .OR. TOGETHER) THEN - ! Create the netCDF file - DIMLN(1)=NF90_UNLIMITED !time - DIMLN(2)=NBSTATION ! station - DIMLN(3)=40 ! string station name length - DIMLN(4)=NK ! FREQ - DIMLN(5)=NTH ! DIR - CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO,NCVARTYPE=NCVARTYPE) - END IF - END DO + ! ... OTYPE = 3 + ELSE IF ( OTYPE .EQ. 3 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Transfer file' + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + IF (FLREQ(I) .OR. TOGETHER) THEN + ! Create the netCDF file + DIMLN(1)=NF90_UNLIMITED !time + DIMLN(2)=NBSTATION ! station + DIMLN(3)=40 ! string station name length + DIMLN(4)=NK ! FREQ + DIMLN(5)=NTH ! DIR + CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO,NCVARTYPE=NCVARTYPE) + END IF + END DO -! ... OTYPE = 4 - ELSE IF ( OTYPE .EQ. 4 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Partitioning of spectra' - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - IF (FLREQ(I) .OR. TOGETHER) THEN - ! Create the netCDF file - DIMLN(1)=NF90_UNLIMITED !time - DIMLN(2)=NBSTATION ! station - DIMLN(3)=40 ! string station name length - DIMLN(4)=DIMXP ! npart - CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO) - END IF - END DO - ELSE - WRITE (NDSE,1011) OTYPE - CALL EXTCDE ( 10 ) + ! ... OTYPE = 4 + ELSE IF ( OTYPE .EQ. 4 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Partitioning of spectra' + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + IF (FLREQ(I) .OR. TOGETHER) THEN + ! Create the netCDF file + DIMLN(1)=NF90_UNLIMITED !time + DIMLN(2)=NBSTATION ! station + DIMLN(3)=40 ! string station name length + DIMLN(4)=DIMXP ! npart + CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO) END IF + END DO + ELSE + WRITE (NDSE,1011) OTYPE + CALL EXTCDE ( 10 ) + END IF -! ... ITYPE = 2 - ELSE IF (ITYPE .EQ. 2) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) ITYPE, 'Table of mean wave parameters' - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - IF (FLREQ(I) .OR. TOGETHER) THEN - ! Create the netCDF file - DIMLN(1)=NF90_UNLIMITED !time - DIMLN(2)=NBSTATION ! station - DIMLN(3)=40 ! string station name length - CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO) - END IF - END DO + ! ... ITYPE = 2 + ELSE IF (ITYPE .EQ. 2) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) ITYPE, 'Table of mean wave parameters' + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + IF (FLREQ(I) .OR. TOGETHER) THEN + ! Create the netCDF file + DIMLN(1)=NF90_UNLIMITED !time + DIMLN(2)=NBSTATION ! station + DIMLN(3)=40 ! string station name length + CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO) + END IF + END DO -! ... OTYPE = 1 - IF ( OTYPE .EQ. 1 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'depth, current and wind', NCNAME + ! ... OTYPE = 1 + IF ( OTYPE .EQ. 1 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'depth, current and wind', NCNAME -! ... OTYPE = 2 - ELSE IF ( OTYPE .EQ. 2 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'Mean wave parameters', NCNAME + ! ... OTYPE = 2 + ELSE IF ( OTYPE .EQ. 2 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'Mean wave parameters', NCNAME -! ... OTYPE = 3 - ELSE IF ( OTYPE .EQ. 3 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'Nondimensional parameters (U*)', NCNAME + ! ... OTYPE = 3 + ELSE IF ( OTYPE .EQ. 3 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'Nondimensional parameters (U*)', NCNAME -! ... OTYPE = 4 - ELSE IF ( OTYPE .EQ. 4 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'Nondimensional parameters (U10)', NCNAME + ! ... OTYPE = 4 + ELSE IF ( OTYPE .EQ. 4 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'Nondimensional parameters (U10)', NCNAME -! ... OTYPE = 5 - ELSE IF ( OTYPE .EQ. 5 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'Validation parameters', NCNAME + ! ... OTYPE = 5 + ELSE IF ( OTYPE .EQ. 5 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'Validation parameters', NCNAME -! ... OTYPE = 6 - ELSE IF ( OTYPE .EQ. 6 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'WMO standard mean parameters', NCNAME -! ... OTYPE = ILLEGAL - ELSE - WRITE (NDSE,1011) OTYPE - CALL EXTCDE ( 30 ) - END IF -! - DO I=1,6 - IF ( FLSRCE(I) .AND. IAPROC .EQ. NAPOUT ) WRITE (NDSO,3940) IDSRCE(I) - END DO - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' + ! ... OTYPE = 6 + ELSE IF ( OTYPE .EQ. 6 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2940) 'WMO standard mean parameters', NCNAME + ! ... OTYPE = ILLEGAL + ELSE + WRITE (NDSE,1011) OTYPE + CALL EXTCDE ( 30 ) + END IF + ! + DO I=1,6 + IF ( FLSRCE(I) .AND. IAPROC .EQ. NAPOUT ) WRITE (NDSO,3940) IDSRCE(I) + END DO + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' -! ... ITYPE = 3 - ELSE IF (ITYPE .EQ. 3) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) ITYPE, 'Source terms' + ! ... ITYPE = 3 + ELSE IF (ITYPE .EQ. 3) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) ITYPE, 'Source terms' #ifdef W3_NCO - NDSTAB = 51 + NDSTAB = 51 #endif - ISCALE = MAX ( 0 , MIN ( 5 , ISCALE ) ) - -! ... OTYPE = 1 - IF ( OTYPE .EQ. 1 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Print plots' - IF ( SCALE1 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1940) '1-D' - ELSE IF ( SCALE1 .EQ. 0. ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1941) '1-D' - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1942) '1-D', SCALE1 - END IF - IF ( SCALE2 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1940) '2-D' - ELSE IF ( SCALE2 .EQ. 0. ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1941) '2-D' - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1942) '2-D', SCALE2 - END IF + ISCALE = MAX ( 0 , MIN ( 5 , ISCALE ) ) -! ... OTYPE = 2 -! or OTYPE = 3 - ELSE IF (( OTYPE .EQ. 2 ) .OR. ( OTYPE .EQ. 3 )) THEN - IF ( ISCALE .LE. 2) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Tables as a function of freq.' - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Tables as a function of f/fp.' - END IF - IF ( MOD(ISCALE,3) .EQ. 1 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,944) '(nondimensional based on U10)' - ELSE IF ( MOD(ISCALE,3) .EQ. 2) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,944) '(nondimensional based on U*)' - END IF + ! ... OTYPE = 1 + IF ( OTYPE .EQ. 1 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Print plots' + IF ( SCALE1 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1940) '1-D' + ELSE IF ( SCALE1 .EQ. 0. ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1941) '1-D' + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1942) '1-D', SCALE1 + END IF + IF ( SCALE2 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1940) '2-D' + ELSE IF ( SCALE2 .EQ. 0. ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1941) '2-D' + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1942) '2-D', SCALE2 + END IF - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - IF (FLREQ(I) .OR. TOGETHER) THEN - ! Create the netCDF file - DIMLN(1)=NF90_UNLIMITED !time - DIMLN(2)=NBSTATION ! station - DIMLN(3)=40 ! string station name length - DIMLN(4)=NK ! freq - CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO) - END IF - END DO + ! ... OTYPE = 2 + ! or OTYPE = 3 + ELSE IF (( OTYPE .EQ. 2 ) .OR. ( OTYPE .EQ. 3 )) THEN + IF ( ISCALE .LE. 2) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Tables as a function of freq.' + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Tables as a function of f/fp.' + END IF + IF ( MOD(ISCALE,3) .EQ. 1 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,944) '(nondimensional based on U10)' + ELSE IF ( MOD(ISCALE,3) .EQ. 2) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,944) '(nondimensional based on U*)' + END IF -! ... OTYPE = 4 - ELSE IF ( OTYPE .EQ. 4 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Transfer file' - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - IF (FLREQ(I) .OR. TOGETHER) THEN - ! Create the netCDF file - DIMLN(1)=NF90_UNLIMITED !time - DIMLN(2)=NBSTATION ! station - DIMLN(3)=40 ! string station name length - DIMLN(4)=NK ! freq - DIMLN(5)=NTH ! dir - CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO,FLSRCE=FLSRCE) - END IF - END DO + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + IF (FLREQ(I) .OR. TOGETHER) THEN + ! Create the netCDF file + DIMLN(1)=NF90_UNLIMITED !time + DIMLN(2)=NBSTATION ! station + DIMLN(3)=40 ! string station name length + DIMLN(4)=NK ! freq + CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO) + END IF + END DO -! ... OTYPE = ILLEGAL - ELSE - WRITE (NDSE,1011) OTYPE - CALL EXTCDE ( 20 ) + ! ... OTYPE = 4 + ELSE IF ( OTYPE .EQ. 4 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) 'Transfer file' + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + IF (FLREQ(I) .OR. TOGETHER) THEN + ! Create the netCDF file + DIMLN(1)=NF90_UNLIMITED !time + DIMLN(2)=NBSTATION ! station + DIMLN(3)=40 ! string station name length + DIMLN(4)=NK ! freq + DIMLN(5)=NTH ! dir + CALL W3CRNC(ITYPE,OTYPE,NCTYPE,NCFILE(I),NCID(I),DIMID,DIMLN,VARID,ONE,TWO,FLSRCE=FLSRCE) END IF + END DO + ! ... OTYPE = ILLEGAL + ELSE + WRITE (NDSE,1011) OTYPE + CALL EXTCDE ( 20 ) + END IF -! ... ITYPE = ILLEGAL - ELSE - WRITE (NDSE,1010) ITYPE - CALL EXTCDE ( 1 ) - END IF + ! ... ITYPE = ILLEGAL + ELSE + WRITE (NDSE,1010) ITYPE + CALL EXTCDE ( 1 ) + END IF -! 5.6.5 Output of output points - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,950) NREQ - ! together - IF (TOGETHER) THEN - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBSTATION - IF (FLREQ(I)) THEN - IF ( FLAGLL ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) PTNME(I), M2KM*PTLOC(1,I), & - M2KM*PTLOC(2,I) - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,953) PTNME(I), M2KM*PTLOC(1,I), & - M2KM*PTLOC(2,I) - END IF - END IF - END DO - ! not together - ELSE - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - IF (FLREQ(I)) THEN - IF ( FLAGLL ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) PTNME(I), M2KM*PTLOC(1,I), & - M2KM*PTLOC(2,I) - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,953) PTNME(I), M2KM*PTLOC(1,I), & - M2KM*PTLOC(2,I) - END IF - END IF - END DO + + ! 5.6.5 Output of output points + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,950) NREQ + ! together + IF (TOGETHER) THEN + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBSTATION + IF (FLREQ(I)) THEN + IF ( FLAGLL ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) PTNME(I), M2KM*PTLOC(1,I), & + M2KM*PTLOC(2,I) + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,953) PTNME(I), M2KM*PTLOC(1,I), & + M2KM*PTLOC(2,I) + END IF + END IF + END DO + ! not together + ELSE + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + IF (FLREQ(I)) THEN + IF ( FLAGLL ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) PTNME(I), M2KM*PTLOC(1,I), & + M2KM*PTLOC(2,I) + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,953) PTNME(I), M2KM*PTLOC(1,I), & + M2KM*PTLOC(2,I) + END IF END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6. Time management. -! + END DO + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6. Time management. + ! #ifdef W3_IC1 - WRITE(NDSO,3960) + WRITE(NDSO,3960) #endif #ifdef W3_IC2 - WRITE(NDSO,3960) + WRITE(NDSO,3960) #endif #ifdef W3_IC3 - WRITE(NDSO,3960) + WRITE(NDSO,3960) #endif #ifdef W3_IC5 - WRITE(NDSO,3960) + WRITE(NDSO,3960) #endif #ifdef W3_NL5 - WRITE(NDSO,3961) -#endif -! - CALL T2D(TIME,STARTDATE,IERR) - WRITE(STRSTARTDATE,'(I4.4,A,4(I2.2,A),I2.2)') STARTDATE(1),'-',STARTDATE(2), & - '-',STARTDATE(3),' ',STARTDATE(5),':',STARTDATE(6),':',STARTDATE(7) - - ! loops on TIME from out_pnt.ww3 till not reach TOUT from inp file - DO - DTEST = DSEC21 ( TIME , TOUT ) - IF ( DTEST .GT. 0. ) THEN - ! reads TIME from out_pnt.ww3 - CALL W3IOPO ( 'READ', NDSOP, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,949) - GOTO 700 - END IF - CYCLE - END IF - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF - ! increment the time counter IOUT - IOUT = IOUT + 1 - CALL STME21 ( TOUT , IDTIME ) - WRITE(DATE,'(I8.8,I6.6)') TOUT(1), TOUT(2) - - -! 6.1 Creates a new file if it is a new date defined by the date division S3 - IF ( (IOUT.GT.1) .AND. (INDEX(PASTDATE(1:S3),DATE(1:S3)).EQ.0) ) THEN - WRITE(NDSO,954) TRIM(DATE(1:S3)) - ! decrements timesteps already processed - NOUT=NOUT-(IOUT-1) - GOTO 700 - END IF - - -! 6.2 Writes out a progress message - IF (NREQ.GT.10.OR.NBFILEOUT.GT.10) WRITE(NDSO,955) TIME, & - NBFILEOUT, IOUT, NOUT, IFL - J=0 + WRITE(NDSO,3961) +#endif + ! + CALL T2D(TIME,STARTDATE,IERR) + WRITE(STRSTARTDATE,'(I4.4,A,4(I2.2,A),I2.2)') STARTDATE(1),'-',STARTDATE(2), & + '-',STARTDATE(3),' ',STARTDATE(5),':',STARTDATE(6),':',STARTDATE(7) + + ! loops on TIME from out_pnt.ww3 till not reach TOUT from inp file + DO + DTEST = DSEC21 ( TIME , TOUT ) + IF ( DTEST .GT. 0. ) THEN + ! reads TIME from out_pnt.ww3 + CALL W3IOPO ( 'READ', NDSOP, IOTEST ) + IF ( IOTEST .EQ. -1 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,949) + GOTO 700 + END IF + CYCLE + END IF + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF + ! increment the time counter IOUT + IOUT = IOUT + 1 + CALL STME21 ( TOUT , IDTIME ) + WRITE(DATE,'(I8.8,I6.6)') TOUT(1), TOUT(2) -! 6.3 Calls subroutine w3exnc for each file - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - IF (FLREQ(I) .OR. TOGETHER) THEN - ! together - IF ( TOGETHER ) THEN - CALL W3EXNC(I,NCID(I),NREQ,INDREQ,ORDER) - ! not together - ELSE - J=J+1 - CALL W3EXNC(I,NCID(I),1,(/ I /),ORDER) - ! flush buffer (only available in netcdf3) - IF (MOD(IOUT,NCFLUSH).EQ.0) THEN - IRET=NF90_SYNC(NCID(I)) - END IF - END IF ! TOGETHER - END IF ! (FLREQ(I) .OR. TOGETHER) - END DO ! I=1+ ... -! - WRITE(PASTDATE,'(I8.8,I6.6)') TOUT(1), TOUT(2) - CALL TICK21 ( TOUT , DTREQ ) - IF ( IOUT .GE. NOUT ) GOTO 700 -! - END DO -! - GOTO 888 + ! 6.1 Creates a new file if it is a new date defined by the date division S3 + IF ( (IOUT.GT.1) .AND. (INDEX(PASTDATE(1:S3),DATE(1:S3)).EQ.0) ) THEN + WRITE(NDSO,954) TRIM(DATE(1:S3)) + ! decrements timesteps already processed + NOUT=NOUT-(IOUT-1) + GOTO 700 + END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 7. Finalize file -! - 700 CONTINUE -! - CALL T2D(TIME,STOPDATE,IERR) - WRITE(STRSTOPDATE,'(I4.4,A,4(I2.2,A),I2.2)') STOPDATE(1),'-',STOPDATE(2), & - '-',STOPDATE(3),' ',STOPDATE(5),':',STOPDATE(6),':',STOPDATE(7) + ! 6.2 Writes out a progress message + IF (NREQ.GT.10.OR.NBFILEOUT.GT.10) WRITE(NDSO,955) TIME, & + NBFILEOUT, IOUT, NOUT, IFL + J=0 -! 7.1 Writes the global attributes to netCDF file - DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - IF ( FLREQ(I) .OR. TOGETHER ) THEN - IRET=NF90_REDEF(NCID(I)) - CALL CHECK_ERR(IRET,0) - IF (FLWW3.EQ.0) & - OPEN(unit=994,file='NC_globatt.inp',status='old',iostat=ICODE) - REWIND(994) - IF (ICODE.EQ.0) THEN - DO WHILE (ICODE.EQ.0) - READ(994,'(a)',iostat=ICODE) ATTNAME - READ(994,'(a)',iostat=ICODE) ATTVAL - IF (ICODE.EQ.0) THEN - STRL=LEN_TRIM(ATTNAME) - STRL2=LEN_TRIM(ATTVAL) - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,ATTNAME(1:STRL),ATTVAL(1:STRL2)) - CALL CHECK_ERR(IRET,1) - END IF - END DO + ! 6.3 Calls subroutine w3exnc for each file + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + IF (FLREQ(I) .OR. TOGETHER) THEN + ! together + IF ( TOGETHER ) THEN + CALL W3EXNC(I,NCID(I),NREQ,INDREQ,ORDER) + ! not together + ELSE + J=J+1 + CALL W3EXNC(I,NCID(I),1,(/ I /),ORDER) + ! flush buffer (only available in netcdf3) + IF (MOD(IOUT,NCFLUSH).EQ.0) THEN + IRET=NF90_SYNC(NCID(I)) END IF - CLOSE(994) -! - WRITE(GLOBALATT,'(A)') TRIM(NCFILE(I)) - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'product_name' ,GLOBALATT(3:)) - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'area',TRIM(GNAME)) - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'data_type','OCO spectra 2D') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'format_version','1.1') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'southernmost_latitude','n/a') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'northernmost_latitude','n/a') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'latitude_resolution','n/a') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'westernmost_longitude','n/a') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'easternmost_longitude','n/a') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'longitude_resolution','n/a') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'minimum_altitude','n/a') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'maximum_altitude','n/a') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'altitude_resolution','n/a') - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'start_date',STRSTARTDATE) - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'stop_date',STRSTOPDATE) - IF (DTREQ.EQ.3600) THEN - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','hourly') - ELSE IF (DTREQ.EQ.7200) THEN - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','2-hourly') - ELSE IF (DTREQ.EQ.10800) THEN - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','3-hourly') - ELSE IF (DTREQ.EQ.21600) THEN - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','6-hourly') - ELSE IF (DTREQ.EQ.32400) THEN - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','9-hourly') - ELSE IF (DTREQ.EQ.43200) THEN - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','12-hourly') - ELSE IF (DTREQ.EQ.86400) THEN - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','daily') - ELSE - IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','n/a') + END IF ! TOGETHER + END IF ! (FLREQ(I) .OR. TOGETHER) + END DO ! I=1+ ... + ! + WRITE(PASTDATE,'(I8.8,I6.6)') TOUT(1), TOUT(2) + CALL TICK21 ( TOUT , DTREQ ) + IF ( IOUT .GE. NOUT ) GOTO 700 + ! + END DO + ! + GOTO 888 + + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 7. Finalize file + ! +700 CONTINUE + ! + CALL T2D(TIME,STOPDATE,IERR) + WRITE(STRSTOPDATE,'(I4.4,A,4(I2.2,A),I2.2)') STOPDATE(1),'-',STOPDATE(2), & + '-',STOPDATE(3),' ',STOPDATE(5),':',STOPDATE(6),':',STOPDATE(7) + + + ! 7.1 Writes the global attributes to netCDF file + DO I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + IF ( FLREQ(I) .OR. TOGETHER ) THEN + IRET=NF90_REDEF(NCID(I)) + CALL CHECK_ERR(IRET,0) + IF (FLWW3.EQ.0) & + OPEN(unit=994,file='NC_globatt.inp',status='old',iostat=ICODE) + REWIND(994) + IF (ICODE.EQ.0) THEN + DO WHILE (ICODE.EQ.0) + READ(994,'(a)',iostat=ICODE) ATTNAME + READ(994,'(a)',iostat=ICODE) ATTVAL + IF (ICODE.EQ.0) THEN + STRL=LEN_TRIM(ATTNAME) + STRL2=LEN_TRIM(ATTVAL) + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,ATTNAME(1:STRL),ATTVAL(1:STRL2)) + CALL CHECK_ERR(IRET,1) END IF -! - ! Close netCDF file - IRET=NF90_ENDDEF(NCID(I)) - CALL CHECK_ERR(IRET,2) - IRET=NF90_CLOSE(NCID(I)) - CALL CHECK_ERR(IRET,3) -! - END IF ! FLREQ(I) .OR. TOGETHER - END DO ! I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT - - -! 7.2 Goes back to the start of the loop with the same points - ! but with a new date defined by the date division S3 - IF ( (IOUT.GT.1) .AND. (INDEX(PASTDATE(1:S3),DATE(1:S3)).EQ.0) ) THEN - GOTO 560 + END DO END IF - - -! 7.3 Reinitiazes TIME (close open out_pnt.ww3) and TOUT to process a new bunch of stations - CLOSE(NDSOP) ! closes binary file out_pnt* - IPASS = 0 ! resets time counter for binary file out_pnt* - CALL W3IOPO ( 'READ', NDSOP, IOTEST ) + CLOSE(994) + ! + WRITE(GLOBALATT,'(A)') TRIM(NCFILE(I)) + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'product_name' ,GLOBALATT(3:)) + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'area',TRIM(GNAME)) + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'data_type','OCO spectra 2D') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'format_version','1.1') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'southernmost_latitude','n/a') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'northernmost_latitude','n/a') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'latitude_resolution','n/a') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'westernmost_longitude','n/a') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'easternmost_longitude','n/a') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'longitude_resolution','n/a') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'minimum_altitude','n/a') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'maximum_altitude','n/a') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'altitude_resolution','n/a') + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'start_date',STRSTARTDATE) + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'stop_date',STRSTOPDATE) + IF (DTREQ.EQ.3600) THEN + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','hourly') + ELSE IF (DTREQ.EQ.7200) THEN + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','2-hourly') + ELSE IF (DTREQ.EQ.10800) THEN + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','3-hourly') + ELSE IF (DTREQ.EQ.21600) THEN + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','6-hourly') + ELSE IF (DTREQ.EQ.32400) THEN + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','9-hourly') + ELSE IF (DTREQ.EQ.43200) THEN + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','12-hourly') + ELSE IF (DTREQ.EQ.86400) THEN + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','daily') + ELSE + IRET=NF90_PUT_ATT(NCID(I),NF90_GLOBAL,'field_type','n/a') + END IF + ! + ! Close netCDF file + IRET=NF90_ENDDEF(NCID(I)) + CALL CHECK_ERR(IRET,2) + IRET=NF90_CLOSE(NCID(I)) + CALL CHECK_ERR(IRET,3) + ! + END IF ! FLREQ(I) .OR. TOGETHER + END DO ! I=1+(IFL-1)*MFL,(IFL-1)*MFL+NBFILEOUT + + + ! 7.2 Goes back to the start of the loop with the same points + ! but with a new date defined by the date division S3 + IF ( (IOUT.GT.1) .AND. (INDEX(PASTDATE(1:S3),DATE(1:S3)).EQ.0) ) THEN + GOTO 560 + END IF + + + ! 7.3 Reinitiazes TIME (close open out_pnt.ww3) and TOUT to process a new bunch of stations + CLOSE(NDSOP) ! closes binary file out_pnt* + IPASS = 0 ! resets time counter for binary file out_pnt* + CALL W3IOPO ( 'READ', NDSOP, IOTEST ) #ifdef W3_T - WRITE(NDSE,*) 'out_pnt* closed and reopened' + WRITE(NDSE,*) 'out_pnt* closed and reopened' #endif - TOUT=TOUTL - NOUT=NOUTL + TOUT=TOUTL + NOUT=NOUTL -! 7.4 Loops on TIME till it is equal to TOUT - DTEST = DSEC21 ( TIME , TOUT ) - DO WHILE (DTEST.NE.0) - DTEST = DSEC21 ( TIME , TOUT ) - IF ( DTEST .GT. 0. ) THEN - CALL W3IOPO ( 'READ', NDSOP, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,949) - GOTO 700 - END IF - CYCLE - END IF - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF - END DO -! - END DO ! IFL=1,NFL -! - GOTO 888 -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 40 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 41 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 42 ) -! - 803 CONTINUE - WRITE (NDSE,1003) - CALL EXTCDE ( 43 ) -! - 804 CONTINUE - WRITE (NDSE,1004) NF90_INQ_LIBVERS() - CALL EXTCDE ( 44 ) -! + ! 7.4 Loops on TIME till it is equal to TOUT + DTEST = DSEC21 ( TIME , TOUT ) + DO WHILE (DTEST.NE.0) + DTEST = DSEC21 ( TIME , TOUT ) + IF ( DTEST .GT. 0. ) THEN + CALL W3IOPO ( 'READ', NDSOP, IOTEST ) + IF ( IOTEST .EQ. -1 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,949) + GOTO 700 + END IF + CYCLE + END IF + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF + END DO + ! + END DO ! IFL=1,NFL + ! + GOTO 888 + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 40 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 41 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 42 ) + ! +803 CONTINUE + WRITE (NDSE,1003) + CALL EXTCDE ( 43 ) + ! +804 CONTINUE + WRITE (NDSE,1004) NF90_INQ_LIBVERS() + CALL EXTCDE ( 44 ) + ! #ifdef W3_O14 - 805 CONTINUE - WRITE (NDSE,1005) IERR - CALL EXTCDE ( 45 ) -#endif -! -! - 888 CONTINUE -! - IF(ALLOCATED(THD)) DEALLOCATE(THD) - IF(ALLOCATED(NCID)) DEALLOCATE(NCID) - IF(ALLOCATED(NCFILE)) DEALLOCATE(NCFILE) - IF(ALLOCATED(INDREQ)) DEALLOCATE(INDREQ) -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) +805 CONTINUE + WRITE (NDSE,1005) IERR + CALL EXTCDE ( 45 ) +#endif + ! + ! +888 CONTINUE + ! + IF(ALLOCATED(THD)) DEALLOCATE(THD) + IF(ALLOCATED(NCID)) DEALLOCATE(NCID) + IF(ALLOCATED(NCFILE)) DEALLOCATE(NCFILE) + IF(ALLOCATED(INDREQ)) DEALLOCATE(INDREQ) + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) #ifdef W3_MPI - CALL MPI_FINALIZE ( IERR_MPI ) + CALL MPI_FINALIZE ( IERR_MPI ) #endif -! + ! #ifdef W3_NCO -! CALL W3TAGE('WAVESPEC') -#endif -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Point output post.*** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) -! - 920 FORMAT ( ' Grid name : ',A/) -! - 930 FORMAT ( ' Points in file : '/ & - ' ------------------------------------') - 931 FORMAT ( ' ',A,2F10.2) - 932 FORMAT ( ' ',A,2(F8.1,'E3')) -! - 940 FORMAT (/' Output time data : '/ & - ' --------------------------------------------------'/ & - ' First time : ',A) - 941 FORMAT ( ' Interval : ',A/ & - ' Number of requests : ',I8) - 942 FORMAT (/' Output type ',I2,' :'/ & - ' --------------------------------------------------'/ & - ' ',A, I3 /) - 943 FORMAT ( ' Subtype : ',A) - 944 FORMAT ( ' ',A) + ! CALL W3TAGE('WAVESPEC') +#endif + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Point output post.*** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) + ! +920 FORMAT ( ' Grid name : ',A/) + ! +930 FORMAT ( ' Points in file : '/ & + ' ------------------------------------') +931 FORMAT ( ' ',A,2F10.2) +932 FORMAT ( ' ',A,2(F8.1,'E3')) + ! +940 FORMAT (/' Output time data : '/ & + ' --------------------------------------------------'/ & + ' First time : ',A) +941 FORMAT ( ' Interval : ',A/ & + ' Number of requests : ',I8) +942 FORMAT (/' Output type ',I2,' :'/ & + ' --------------------------------------------------'/ & + ' ',A, I3 /) +943 FORMAT ( ' Subtype : ',A) +944 FORMAT ( ' ',A) #ifdef W3_O14 - 945 FORMAT ( ' ',I5,3X,A,2F10.2,3X,A) -#endif - 949 FORMAT (/' End of file reached '/) -! - 950 FORMAT (/' Requested output for ',I6,' points : '/ & - ' --------------------------------------------------') - 951 FORMAT ( ' ',A,2F10.2) - 953 FORMAT ( ' ',A,2(F8.1,'E3')) - 954 FORMAT (/' New time step : ',A) - 955 FORMAT ( ' Processing time : ', 2I8, ' in ', I8, 'files. Step '& - I10, 'out of ', I10, ' pass ', I4) -! - 1940 FORMAT ( ' ',A,' print plots not requested.') - 1941 FORMAT ( ' ',A,' print plots normalized.') - 1942 FORMAT ( ' Scale factor ',A,' spectrum : ',E10.3) -! 1947 FORMAT ( ' File name : ',A) -! - 2940 FORMAT ( ' Table output : ',A/ & - ' File name : ',A) -! - 3940 FORMAT ( ' ',A) - 5940 FORMAT ( ' Buffer will be flushed every ',I6,' steps.') - 5950 FORMAT ( ' Point already exists, it will be skipped : ', A) -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Point output '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & - ' NCTYPE=3 IS INCOMPATIBLE WITH'/ & - ' THE OPTIMIZED DIMENSION ORDER'/) -! - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & - ' NCTYPE=4 IS INCOMPATIBLE WITH'/ & - ' NETCDF LIBRARY USED :',A/) -! +945 FORMAT ( ' ',I5,3X,A,2F10.2,3X,A) +#endif +949 FORMAT (/' End of file reached '/) + ! +950 FORMAT (/' Requested output for ',I6,' points : '/ & + ' --------------------------------------------------') +951 FORMAT ( ' ',A,2F10.2) +953 FORMAT ( ' ',A,2(F8.1,'E3')) +954 FORMAT (/' New time step : ',A) +955 FORMAT ( ' Processing time : ', 2I8, ' in ', I8, 'files. Step '& + I10, 'out of ', I10, ' pass ', I4) + ! +1940 FORMAT ( ' ',A,' print plots not requested.') +1941 FORMAT ( ' ',A,' print plots normalized.') +1942 FORMAT ( ' Scale factor ',A,' spectrum : ',E10.3) + ! 1947 FORMAT ( ' File name : ',A) + ! +2940 FORMAT ( ' Table output : ',A/ & + ' File name : ',A) + ! +3940 FORMAT ( ' ',A) +5940 FORMAT ( ' Buffer will be flushed every ',I6,' steps.') +5950 FORMAT ( ' Point already exists, it will be skipped : ', A) + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Point output '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' NCTYPE=3 IS INCOMPATIBLE WITH'/ & + ' THE OPTIMIZED DIMENSION ORDER'/) + ! +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' NCTYPE=4 IS INCOMPATIBLE WITH'/ & + ' NETCDF LIBRARY USED :',A/) + ! #ifdef W3_O14 - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & - ' ERROR IN OPENING BUOY LOG FILE'/ & - ' IOSTAT =',I5/) -#endif -! - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & - ' ITYPE AND OTYPE COMBINATION NOT RECOGNIZED'/) -! - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' LAST POINT INDEX IS NOT -1'/ & - ' OR TOO MANY POINT INDEXES DEFINED'/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & - ' ILLEGAL TYPE, ITYPE =',I4/) -! - 1011 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & - ' ILLEGAL TYPE, OTYPE =',I4/) -! +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' ERROR IN OPENING BUOY LOG FILE'/ & + ' IOSTAT =',I5/) +#endif + ! +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' ITYPE AND OTYPE COMBINATION NOT RECOGNIZED'/) + ! +1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' LAST POINT INDEX IS NOT -1'/ & + ' OR TOO MANY POINT INDEXES DEFINED'/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' ILLEGAL TYPE, ITYPE =',I4/) + ! +1011 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' ILLEGAL TYPE, OTYPE =',I4/) + ! #ifdef W3_IC1 - 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & - ' Ice source terms !/IC1 skipped'/ & - ' in dissipation term.'/) +3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & + ' Ice source terms !/IC1 skipped'/ & + ' in dissipation term.'/) #endif #ifdef W3_IC2 - 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & - ' Ice source terms !/IC2 skipped'/ & - ' in dissipation term.'/) +3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & + ' Ice source terms !/IC2 skipped'/ & + ' in dissipation term.'/) #endif #ifdef W3_IC3 - 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & - ' Ice source terms !/IC3 skipped'/ & - ' in dissipation term.'/) +3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & + ' Ice source terms !/IC3 skipped'/ & + ' in dissipation term.'/) #endif #ifdef W3_IC5 - 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & - ' Ice source terms !/IC5 skipped'/ & - ' in dissipation term.'/) +3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & + ' Ice source terms !/IC5 skipped'/ & + ' in dissipation term.'/) #endif #ifdef W3_NL5 - 3961 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & - ' Snl source terms !/NL5 skipped'/ & - ' in interaction term.'/) -#endif -!/ -!/ Internal subroutine W3EXNC ---------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Perform actual point output. -!> -!> @details Spectra are relative frequency energy spectra. -!> Note that arrays CX and CY of the main program now contain -!> the absolute sea water speed and direction respectively. -!> -!> @param[in] I -!> @param[in] NCID -!> @param[in] NREQ -!> @param[in] INDREQ -!> @param[in] ORDER -!> -!> @author F. Ardhuin -!> @author M. Accensi -!> @date 14-Mar-2013 -!> - SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 14-Mar-2013 | -!/ +-----------------------------------+ -!/ -!/ 01-Apr-2011 : Creation ( version 3.14 ) -!/ 14-Mar-2013 : Optimization and cleanup ( version 4.10 ) -!/ -! 1. Purpose : -! -! Perform actual point output. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SPRn Subr. W3SRCnMD Mean wave parameters for use in -! source terms. -! W3FLXn Subr. W3FLXnMD Flux/stress computation. -! W3SLNn Subr. W3SLNnMD Linear input. -! W3SINn Subr. W3SRCnMD Input source term. -! W3SDSn Subr. W3SRCnMD Whitecapping source term -! W3SNLn Subr. W3SNLnMD Nonlinear interactions. -! W3SBTn Subr. W3SBTnMD Bottom friction source term. -! W3SDBn Subr. W3SBTnMD Depth induced breaking source term. -! W3STRn Subr. W3STRnMD Triad interaction source term. -! W3SBSn Subr. W3SBSnMD Bottom scattering source term. -! W3SXXn Subr. W3SXXnMD Unclassified source term. -! W3PART Sunr. W3PARTMD Spectral partitioning routine. -! STRACE Subr. W3SERVMD Subroutine tracing. -! STME21 Subr. W3TIMEMD Convert time to string. -! PRT1DS Subr. W3ARRYMD Print plot of 1-D spectrum. -! PRT1DM Subr. Id. Print plot of several 1-D spectra. -! PRT2DS Subr. Id. Print plot of 2-D spectrum. -! WAVNU1 Subr. W3DISPMD Solve dispersion relation. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Main program in which it is contained, -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Spectra are relative frequency energy spectra. -! - Note that arrays CX and CY of the main program now contain -! the absolute sea water speed and direction respectively. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! !/FLXx Flux/stress computation. -! !/LNx Linear input package -! !/STx Source term package -! !/NLx Nonlinear interaction package -! !/BTx Bottom friction package -! !/ICx S_ice source term package -! !/DBx Depth-induced breaking package -! !/TRx Triad interaction package -! !/BSx Bottom scattering package -! -! !/STAB2 Stability correction for !/ST2 -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +3961 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & + ' Snl source terms !/NL5 skipped'/ & + ' in interaction term.'/) +#endif + !/ + !/ Internal subroutine W3EXNC ---------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Perform actual point output. + !> + !> @details Spectra are relative frequency energy spectra. + !> Note that arrays CX and CY of the main program now contain + !> the absolute sea water speed and direction respectively. + !> + !> @param[in] I + !> @param[in] NCID + !> @param[in] NREQ + !> @param[in] INDREQ + !> @param[in] ORDER + !> + !> @author F. Ardhuin + !> @author M. Accensi + !> @date 14-Mar-2013 + !> + SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 14-Mar-2013 | + !/ +-----------------------------------+ + !/ + !/ 01-Apr-2011 : Creation ( version 3.14 ) + !/ 14-Mar-2013 : Optimization and cleanup ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Perform actual point output. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SPRn Subr. W3SRCnMD Mean wave parameters for use in + ! source terms. + ! W3FLXn Subr. W3FLXnMD Flux/stress computation. + ! W3SLNn Subr. W3SLNnMD Linear input. + ! W3SINn Subr. W3SRCnMD Input source term. + ! W3SDSn Subr. W3SRCnMD Whitecapping source term + ! W3SNLn Subr. W3SNLnMD Nonlinear interactions. + ! W3SBTn Subr. W3SBTnMD Bottom friction source term. + ! W3SDBn Subr. W3SBTnMD Depth induced breaking source term. + ! W3STRn Subr. W3STRnMD Triad interaction source term. + ! W3SBSn Subr. W3SBSnMD Bottom scattering source term. + ! W3SXXn Subr. W3SXXnMD Unclassified source term. + ! W3PART Sunr. W3PARTMD Spectral partitioning routine. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! PRT1DS Subr. W3ARRYMD Print plot of 1-D spectrum. + ! PRT1DM Subr. Id. Print plot of several 1-D spectra. + ! PRT2DS Subr. Id. Print plot of 2-D spectrum. + ! WAVNU1 Subr. W3DISPMD Solve dispersion relation. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Main program in which it is contained, + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Spectra are relative frequency energy spectra. + ! - Note that arrays CX and CY of the main program now contain + ! the absolute sea water speed and direction respectively. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! !/FLXx Flux/stress computation. + ! !/LNx Linear input package + ! !/STx Source term package + ! !/NLx Nonlinear interaction package + ! !/BTx Bottom friction package + ! !/ICx S_ice source term package + ! !/DBx Depth-induced breaking package + ! !/TRx Triad interaction package + ! !/BSx Bottom scattering package + ! + ! !/STAB2 Stability correction for !/ST2 + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_FLX1 - USE W3FLX1MD + USE W3FLX1MD #endif #ifdef W3_FLX2 - USE W3FLX2MD + USE W3FLX2MD #endif #ifdef W3_FLX3 - USE W3FLX3MD + USE W3FLX3MD #endif #ifdef W3_FLX4 - USE W3FLX4MD + USE W3FLX4MD #endif #ifdef W3_FLX5 - USE W3FLX5MD + USE W3FLX5MD #endif #ifdef W3_LN1 - USE W3SLN1MD + USE W3SLN1MD #endif #ifdef W3_ST1 - USE W3SRC1MD + USE W3SRC1MD #endif #ifdef W3_ST2 - USE W3SRC2MD + USE W3SRC2MD #endif #ifdef W3_ST3 - USE W3SRC3MD + USE W3SRC3MD #endif #ifdef W3_ST4 - USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 + USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 #endif #ifdef W3_ST6 - USE W3SRC6MD - USE W3SWLDMD, ONLY : W3SWL6 - USE W3GDATMD, ONLY : SWL6S6 + USE W3SRC6MD + USE W3SWLDMD, ONLY : W3SWL6 + USE W3GDATMD, ONLY : SWL6S6 #endif #ifdef W3_NL1 - USE W3SNL1MD + USE W3SNL1MD #endif #ifdef W3_NL2 - USE W3SNL2MD + USE W3SNL2MD #endif #ifdef W3_NL3 - USE W3SNL3MD + USE W3SNL3MD #endif #ifdef W3_NL4 - USE W3SNL4MD + USE W3SNL4MD #endif #ifdef W3_BT1 - USE W3SBT1MD + USE W3SBT1MD #endif #ifdef W3_BT4 - USE W3SBT4MD + USE W3SBT4MD #endif #ifdef W3_BT8 - USE W3SBT8MD + USE W3SBT8MD #endif #ifdef W3_BT9 - USE W3SBT9MD + USE W3SBT9MD #endif #ifdef W3_DB1 - USE W3SDB1MD + USE W3SDB1MD #endif #ifdef W3_BS1 - USE W3SBS1MD + USE W3SBS1MD #endif #ifdef W3_IS2 - USE W3SIS2MD -#endif - USE W3PARTMD, ONLY: W3PART - USE W3DISPMD, ONLY: WAVNU1, LIU_FORWARD_DISPERSION - USE W3GDATMD, ONLY: IICEDISP -!/ - USE W3ARRYMD, ONLY: PRT1DS, PRT2DS, PRT1DM - USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE - USE NETCDF + USE W3SIS2MD +#endif + USE W3PARTMD, ONLY: W3PART + USE W3DISPMD, ONLY: WAVNU1, LIU_FORWARD_DISPERSION + USE W3GDATMD, ONLY: IICEDISP + !/ + USE W3ARRYMD, ONLY: PRT1DS, PRT2DS, PRT1DM + USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE + USE NETCDF #ifdef W3_IG1 - USE W3GIG1MD, ONLY: W3ADDIG - USE W3CANOMD, ONLY: W3ADD2NDORDER + USE W3GIG1MD, ONLY: W3ADDIG + USE W3CANOMD, ONLY: W3ADD2NDORDER #endif - IMPLICIT NONE + IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / - INTEGER, INTENT(IN) :: I, NCID, NREQ, INDREQ(NREQ) - LOGICAL, INTENT(IN) :: ORDER + INTEGER, INTENT(IN) :: I, NCID, NREQ, INDREQ(NREQ) + LOGICAL, INTENT(IN) :: ORDER -!/ Local parameters -!/ - INTEGER :: J, J1, I1, I2, ISP, IKM, & - ITH, IK, ITT, NPART, IX, IY, ISEA - INTEGER :: CURDATE(8), REFDATE(8) + !/ Local parameters + !/ + INTEGER :: J, J1, I1, I2, ISP, IKM, & + ITH, IK, ITT, NPART, IX, IY, ISEA + INTEGER :: CURDATE(8), REFDATE(8) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -! - REAL :: DEPTH, SQRTH, CDIR, SIX, R1, R2, & - UDIR, UDIRR, UABS, XL, XH, XL2, XH2, & - ET, EWN, ETR, ETX, ETY, EBND, EBX, & - EBY, HSIG, WLEN, TMEAN, THMEAN, & - THSPRD, EMAX, EL, EH, DENOM, FP, THP, & - SPP, CD, USTAR, FACTOR, UNORM, ESTAR, & - FPSTAR, FACF, FACE, FACS, HMAT, WNA, & - XYZ, AGE1, AFR, AGE2, FACT, XSTAR, & - YSTAR, FHIGH, ZWND, Z0, USTD, EMEAN, & - FMEAN, WNMEAN, UDIRCA, CHARN, M2KM, & - ICETHICK, ICECON + INTEGER, SAVE :: IENT = 0 +#endif + ! + REAL :: DEPTH, SQRTH, CDIR, SIX, R1, R2, & + UDIR, UDIRR, UABS, XL, XH, XL2, XH2, & + ET, EWN, ETR, ETX, ETY, EBND, EBX, & + EBY, HSIG, WLEN, TMEAN, THMEAN, & + THSPRD, EMAX, EL, EH, DENOM, FP, THP, & + SPP, CD, USTAR, FACTOR, UNORM, ESTAR, & + FPSTAR, FACF, FACE, FACS, HMAT, WNA, & + XYZ, AGE1, AFR, AGE2, FACT, XSTAR, & + YSTAR, FHIGH, ZWND, Z0, USTD, EMEAN, & + FMEAN, WNMEAN, UDIRCA, CHARN, M2KM, & + ICETHICK, ICECON #ifdef W3_FLX5 - REAL :: TAUA, TAUADIR, RHOAIR -#endif - REAL :: WN_R(NK),CG_ICE(NK), ALPHA_LIU(NK), & - R(NK), WN(NK), CG(NK), APM(NK), & - E3(NTH,NK,NREQ), E(NK,NTH), E1(NK), & - THBND(NK), SPBND(NK), A(NTH,NK), & - WN2(NTH,NK), & - STT(NK,NTH), SWN(NK,NTH), SNL(NK,NTH),& - SDS(NK,NTH), SBT(NK,NTH), SIS(NK,NTH),& - XIN(NTH,NK), XNL(NTH,NK), XTR(NTH,NK),& - XDS(NTH,NK), XDB(NTH,NK), XBT(NTH,NK),& - XBS(NTH,NK), XXX(NTH,NK), DIA(NTH,NK),& - XLN(NTH,NK), XWL(NTH,NK), XIS(NTH,NK),& - SIN1(NK), SNL1(NK), SDS1(NK), & - SBT1(NK), SIS1(NK), STT1(NK), & - E1ALL(NK,6), UDIR1(NREQ), CDIR1(NREQ) + REAL :: TAUA, TAUADIR, RHOAIR +#endif + REAL :: WN_R(NK),CG_ICE(NK), ALPHA_LIU(NK), & + R(NK), WN(NK), CG(NK), APM(NK), & + E3(NTH,NK,NREQ), E(NK,NTH), E1(NK), & + THBND(NK), SPBND(NK), A(NTH,NK), & + WN2(NTH,NK), & + STT(NK,NTH), SWN(NK,NTH), SNL(NK,NTH),& + SDS(NK,NTH), SBT(NK,NTH), SIS(NK,NTH),& + XIN(NTH,NK), XNL(NTH,NK), XTR(NTH,NK),& + XDS(NTH,NK), XDB(NTH,NK), XBT(NTH,NK),& + XBS(NTH,NK), XXX(NTH,NK), DIA(NTH,NK),& + XLN(NTH,NK), XWL(NTH,NK), XIS(NTH,NK),& + SIN1(NK), SNL1(NK), SDS1(NK), & + SBT1(NK), SIS1(NK), STT1(NK), & + E1ALL(NK,6), UDIR1(NREQ), CDIR1(NREQ) #ifdef W3_FLX5 - REAL :: TAUDIR1(NREQ) + REAL :: TAUDIR1(NREQ) #endif - REAL, SAVE :: HSMIN = 0.05 + REAL, SAVE :: HSMIN = 0.05 #ifdef W3_IS2 - REAL :: ICEF, ICEDMAX, DIA2(NTH,NK) + REAL :: ICEF, ICEDMAX, DIA2(NTH,NK) #endif #ifdef W3_ST1 - REAL :: AMAX, FH1, FH2 + REAL :: AMAX, FH1, FH2 #endif #ifdef W3_ST2 - REAL :: AMAX, ALPHA(NK), FPI + REAL :: AMAX, ALPHA(NK), FPI #endif #ifdef W3_ST3 - REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & - TAUWNX, TAUWNY + REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & + TAUWNX, TAUWNY #endif #ifdef W3_ST4 - REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & - TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4) - REAL :: LAMBDA(NSPEC), DLWMEAN + REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & + TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4) + REAL :: LAMBDA(NSPEC), DLWMEAN #endif #ifdef W3_ST6 - REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY + REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY #endif #ifdef W3_BS1 - REAL :: TAUSCX, TAUSCY + REAL :: TAUSCX, TAUSCY #endif #ifdef W3_BT4 - REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) + REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) #endif - REAL :: ICE + REAL :: ICE #ifdef W3_STAB2 - REAL :: STAB0, STAB, COR1, COR2, ASFAC, & - THARG1, THARG2 -#endif -! - DOUBLE PRECISION :: OUTJULDAY -! - CHARACTER*4 :: VAR1(6) -! - LOGICAL :: LASTSTATION=.FALSE. - LOGICAL :: SHORT=.TRUE. - LOGICAL :: LBREAK + REAL :: STAB0, STAB, COR1, COR2, ASFAC, & + THARG1, THARG2 +#endif + ! + DOUBLE PRECISION :: OUTJULDAY + ! + CHARACTER*4 :: VAR1(6) + ! + LOGICAL :: LASTSTATION=.FALSE. + LOGICAL :: SHORT=.TRUE. + LOGICAL :: LBREAK #ifdef W3_ST3 - LOGICAL :: LLWS(NSPEC) + LOGICAL :: LLWS(NSPEC) #endif #ifdef W3_ST4 - LOGICAL :: LLWS(NSPEC) + LOGICAL :: LLWS(NSPEC) #endif -! - DATA VAR1 / 'Sin ' , 'Snl ', 'Sds ' , 'Sbt ' , 'Sice', 'Stot' / + ! + DATA VAR1 / 'Sin ' , 'Snl ', 'Sds ' , 'Sbt ' , 'Sice', 'Stot' / -!/ -!/ ------------------------------------------------------------------- / -!/ -! 1. Initialisations -! + !/ + !/ ------------------------------------------------------------------- / + !/ + ! 1. Initialisations + ! #ifdef W3_S - CALL STRACE (IENT, 'W3EXNC') -#endif -! - IF ( FLAGLL ) THEN - M2KM = 1. - ELSE - M2KM = 1.E-3 - END IF -! - XL = 1./XFR - 1. - XH = XFR - 1. - XL2 = XL**2 - XH2 = XH**2 -! - IF ( ITYPE .EQ. 3 ) THEN - XLN = 0. - XIN = 0. - XNL = 0. - XTR = 0. - XDS = 0. - XDB = 0. - XBT = 0. - XBS = 0. - XWL = 0. - XIS = 0. - XXX = 0. - END IF -! - CALL U2D('days since 1990-01-01 00:00:00',REFDATE,IERR) -! + CALL STRACE (IENT, 'W3EXNC') +#endif + ! + IF ( FLAGLL ) THEN + M2KM = 1. + ELSE + M2KM = 1.E-3 + END IF + ! + XL = 1./XFR - 1. + XH = XFR - 1. + XL2 = XL**2 + XH2 = XH**2 + ! + IF ( ITYPE .EQ. 3 ) THEN + XLN = 0. + XIN = 0. + XNL = 0. + XTR = 0. + XDS = 0. + XDB = 0. + XBT = 0. + XBS = 0. + XWL = 0. + XIS = 0. + XXX = 0. + END IF + ! + CALL U2D('days since 1990-01-01 00:00:00',REFDATE,IERR) + ! #ifdef W3_T - WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) - WRITE (NDST,9001) ITYPE, OTYPE, NREQ, SCALE1, SCALE2, FLSRCE -#endif - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Loop over output points. -! - - - -! -! Selects first station index -! - IF (TOGETHER) THEN - J=1 - ELSE - J=I + WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) + WRITE (NDST,9001) ITYPE, OTYPE, NREQ, SCALE1, SCALE2, FLSRCE +#endif + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! Loop over output points. + ! + + + + ! + ! Selects first station index + ! + IF (TOGETHER) THEN + J=1 + ELSE + J=I + END IF + ! + ! Short version of the ww3_ounp code for ITYPE = 1 + ! and OTYPE = 3 + ! + IF (SHORT.AND.ITYPE.EQ.1.AND.OTYPE.EQ.3) THEN + + DEPTH = MAX ( DMIN, DPO(J) ) + SQRTH = SQRT ( DEPTH ) + DO IK=1, NK + SIX = SIG(IK) * SQRTH + I1 = INT(SIX/DSIE) + IF (I1.LE.N1MAX) THEN + I2 = I1 + 1 + R1 = SIX/DSIE - REAL(I1) + R2 = 1. - R1 + WN(IK) = ( R2*EWN1(I1) + R1*EWN1(I2) ) / DEPTH + CG(IK) = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH + ELSE + WN(IK) = SIG(IK)*SIG(IK)/GRAV + CG(IK) = 0.5 * GRAV / SIG(IK) END IF -! -! Short version of the ww3_ounp code for ITYPE = 1 -! and OTYPE = 3 -! - IF (SHORT.AND.ITYPE.EQ.1.AND.OTYPE.EQ.3) THEN - - DEPTH = MAX ( DMIN, DPO(J) ) - SQRTH = SQRT ( DEPTH ) - DO IK=1, NK - SIX = SIG(IK) * SQRTH - I1 = INT(SIX/DSIE) - IF (I1.LE.N1MAX) THEN - I2 = I1 + 1 - R1 = SIX/DSIE - REAL(I1) - R2 = 1. - R1 - WN(IK) = ( R2*EWN1(I1) + R1*EWN1(I2) ) / DEPTH - CG(IK) = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH - ELSE - WN(IK) = SIG(IK)*SIG(IK)/GRAV - CG(IK) = 0.5 * GRAV / SIG(IK) - END IF #ifdef W3_T - WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) + WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) #endif -! - END DO + ! + END DO -! -! Computes 2nd order spectrum -! + ! + ! Computes 2nd order spectrum + ! #ifdef W3_IG1 IF (IGPARS(2).EQ.1) THEN IF(IGPARS(1).EQ.1) THEN CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) ELSE CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) - END IF END IF + END IF #endif -! + ! - DO J1=1, NREQ - DO IK=1, NK - DO ITH=1, NTH - ISP = ITH + (IK-1)*NTH - E3(ITH,IK,J1) = SPCO(ISP,INDREQ(J1)) - END DO + DO J1=1, NREQ + DO IK=1, NK + DO ITH=1, NTH + ISP = ITH + (IK-1)*NTH + E3(ITH,IK,J1) = SPCO(ISP,INDREQ(J1)) END DO END DO + END DO - CALL T2D(TIME,CURDATE,IERR) - OUTJULDAY=TSUB(REFDATE,CURDATE) - IRET=NF90_PUT_VAR(NCID,VARID(1),OUTJULDAY,(/IOUT/)) - CALL CHECK_ERR(IRET,4) -! - IF (IOUT.EQ.1) THEN - DO J1=1, NREQ - IRET=NF90_PUT_VAR(NCID,VARID(27),INDREQ(J1),(/J1/)) - CALL CHECK_ERR(IRET,5) - IRET=NF90_PUT_VAR(NCID,VARID(2),PTNME(INDREQ(J1)), & - start=(/1,J1/),count=(/LEN_TRIM(PTNME(INDREQ(J1))) ,1/)) - CALL CHECK_ERR(IRET,6) - END DO - END IF -! + CALL T2D(TIME,CURDATE,IERR) + OUTJULDAY=TSUB(REFDATE,CURDATE) + IRET=NF90_PUT_VAR(NCID,VARID(1),OUTJULDAY,(/IOUT/)) + CALL CHECK_ERR(IRET,4) + ! + IF (IOUT.EQ.1) THEN DO J1=1, NREQ - IF ((FLWW3.NE.0).AND.(ORDER)) IRET=NF90_PUT_VAR(NCID,VARID(3),FLWW3,(/J1,IOUT/)) - IF ((FLWW3.NE.0).AND.(.NOT.ORDER)) IRET=NF90_PUT_VAR(NCID,VARID(3),FLWW3,(/IOUT,J1/)) - CALL CHECK_ERR(IRET,7) + IRET=NF90_PUT_VAR(NCID,VARID(27),INDREQ(J1),(/J1/)) + CALL CHECK_ERR(IRET,5) + IRET=NF90_PUT_VAR(NCID,VARID(2),PTNME(INDREQ(J1)), & + start=(/1,J1/),count=(/LEN_TRIM(PTNME(INDREQ(J1))) ,1/)) + CALL CHECK_ERR(IRET,6) END DO -! - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(4),M2KM*PTLOC(1,INDREQ(1:NREQ)),(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(4),M2KM*PTLOC(1,INDREQ(1:NREQ)),(/IOUT,1/)) - CALL CHECK_ERR(IRET,8) - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(5),M2KM*PTLOC(2,INDREQ(1:NREQ)),(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(5),M2KM*PTLOC(2,INDREQ(1:NREQ)),(/IOUT,1/)) - CALL CHECK_ERR(IRET,9) -! - DO J1=1,NREQ - UDIR1(J1) = MOD ( 270. - WDO(INDREQ(J1))*RADE , 360. ) - CDIR1(J1) = MOD ( 270. - CDO(INDREQ(J1))*RADE , 360. ) + END IF + ! + DO J1=1, NREQ + IF ((FLWW3.NE.0).AND.(ORDER)) IRET=NF90_PUT_VAR(NCID,VARID(3),FLWW3,(/J1,IOUT/)) + IF ((FLWW3.NE.0).AND.(.NOT.ORDER)) IRET=NF90_PUT_VAR(NCID,VARID(3),FLWW3,(/IOUT,J1/)) + CALL CHECK_ERR(IRET,7) + END DO + ! + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(4),M2KM*PTLOC(1,INDREQ(1:NREQ)),(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(4),M2KM*PTLOC(1,INDREQ(1:NREQ)),(/IOUT,1/)) + CALL CHECK_ERR(IRET,8) + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(5),M2KM*PTLOC(2,INDREQ(1:NREQ)),(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(5),M2KM*PTLOC(2,INDREQ(1:NREQ)),(/IOUT,1/)) + CALL CHECK_ERR(IRET,9) + ! + DO J1=1,NREQ + UDIR1(J1) = MOD ( 270. - WDO(INDREQ(J1))*RADE , 360. ) + CDIR1(J1) = MOD ( 270. - CDO(INDREQ(J1))*RADE , 360. ) #ifdef W3_FLX5 - TAUDIR1(J1) = MOD ( 270. - TAUDO(INDREQ(J1))*RADE , 360. ) + TAUDIR1(J1) = MOD ( 270. - TAUDO(INDREQ(J1))*RADE , 360. ) #endif - END DO -! - IF (NCVARTYPE.LE.3) THEN - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(11),NINT(DPO(INDREQ(1:NREQ))/0.5),(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(11),NINT(DPO(INDREQ(1:NREQ))/0.5),(/IOUT,1/)) - CALL CHECK_ERR(IRET,10) - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(12),NINT(WAO(INDREQ(1:NREQ))/0.1),(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(12),NINT(WAO(INDREQ(1:NREQ))/0.1),(/IOUT,1/)) - CALL CHECK_ERR(IRET,11) - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(13),NINT(UDIR1/0.1),(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(13),NINT(UDIR1/0.1),(/IOUT,1/)) - CALL CHECK_ERR(IRET,12) - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(14),NINT(CAO(INDREQ(1:NREQ))/0.1),(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(14),NINT(CAO(INDREQ(1:NREQ))/0.1),(/IOUT,1/)) - CALL CHECK_ERR(IRET,13) - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),NINT(CDIR1/0.1),(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),NINT(CDIR1/0.1),(/IOUT,1/)) - CALL CHECK_ERR(IRET,14) - ELSE - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(11),DPO(INDREQ(1:NREQ)),(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(11),DPO(INDREQ(1:NREQ)),(/IOUT,1/)) - CALL CHECK_ERR(IRET,10) - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(12),WAO(INDREQ(1:NREQ)),(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(12),WAO(INDREQ(1:NREQ)),(/IOUT,1/)) - CALL CHECK_ERR(IRET,11) - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(13),UDIR1,(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(13),UDIR1,(/IOUT,1/)) - CALL CHECK_ERR(IRET,12) - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(14),CAO(INDREQ(1:NREQ)),(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(14),CAO(INDREQ(1:NREQ)),(/IOUT,1/)) - CALL CHECK_ERR(IRET,13) - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),CDIR1,(/1,IOUT/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),CDIR1,(/IOUT,1/)) - CALL CHECK_ERR(IRET,14) - END IF -! - IF (NCVARTYPE.LE.3) THEN - WHERE(E3(:,:,:).GE.0) E3(:,:,:)=NINT(ALOG10(E3(:,:,:)+1E-12)/0.0004) - END IF - IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(10),E3(1:NTH,1:NK,:), & - start=(/1,1,1,IOUT/),count=(/NTH,NK,NREQ,1/)) - IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(10),E3(1:NTH,1:NK,1:NREQ), & - start=(/1,1,IOUT,1/),count=(/NTH,NK,1,NREQ/)) - CALL CHECK_ERR(IRET,15) -! -! End of short version -! + END DO + ! + IF (NCVARTYPE.LE.3) THEN + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(11),NINT(DPO(INDREQ(1:NREQ))/0.5),(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(11),NINT(DPO(INDREQ(1:NREQ))/0.5),(/IOUT,1/)) + CALL CHECK_ERR(IRET,10) + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(12),NINT(WAO(INDREQ(1:NREQ))/0.1),(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(12),NINT(WAO(INDREQ(1:NREQ))/0.1),(/IOUT,1/)) + CALL CHECK_ERR(IRET,11) + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(13),NINT(UDIR1/0.1),(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(13),NINT(UDIR1/0.1),(/IOUT,1/)) + CALL CHECK_ERR(IRET,12) + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(14),NINT(CAO(INDREQ(1:NREQ))/0.1),(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(14),NINT(CAO(INDREQ(1:NREQ))/0.1),(/IOUT,1/)) + CALL CHECK_ERR(IRET,13) + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),NINT(CDIR1/0.1),(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),NINT(CDIR1/0.1),(/IOUT,1/)) + CALL CHECK_ERR(IRET,14) ELSE -! -! And here is the full thing with all options ITYPE and OTYPE ... -! + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(11),DPO(INDREQ(1:NREQ)),(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(11),DPO(INDREQ(1:NREQ)),(/IOUT,1/)) + CALL CHECK_ERR(IRET,10) + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(12),WAO(INDREQ(1:NREQ)),(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(12),WAO(INDREQ(1:NREQ)),(/IOUT,1/)) + CALL CHECK_ERR(IRET,11) + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(13),UDIR1,(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(13),UDIR1,(/IOUT,1/)) + CALL CHECK_ERR(IRET,12) + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(14),CAO(INDREQ(1:NREQ)),(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(14),CAO(INDREQ(1:NREQ)),(/IOUT,1/)) + CALL CHECK_ERR(IRET,13) + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),CDIR1,(/1,IOUT/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),CDIR1,(/IOUT,1/)) + CALL CHECK_ERR(IRET,14) + END IF + ! + IF (NCVARTYPE.LE.3) THEN + WHERE(E3(:,:,:).GE.0) E3(:,:,:)=NINT(ALOG10(E3(:,:,:)+1E-12)/0.0004) + END IF + IF(ORDER) IRET=NF90_PUT_VAR(NCID,VARID(10),E3(1:NTH,1:NK,:), & + start=(/1,1,1,IOUT/),count=(/NTH,NK,NREQ,1/)) + IF(.NOT.ORDER) IRET=NF90_PUT_VAR(NCID,VARID(10),E3(1:NTH,1:NK,1:NREQ), & + start=(/1,1,IOUT,1/),count=(/NTH,NK,1,NREQ/)) + CALL CHECK_ERR(IRET,15) + ! + ! End of short version + ! + ELSE + ! + ! And here is the full thing with all options ITYPE and OTYPE ... + ! J1=1 LASTSTATION=.FALSE. -! + ! DO WHILE (.NOT.LASTSTATION) -! + ! IF ( FLREQ(J) ) THEN -! -! Open netCDF file -! + ! + ! Open netCDF file + ! #ifdef W3_T - WRITE (NDST,9002) PTNME(J) + WRITE (NDST,9002) PTNME(J) #endif -! -! 2. Calculate grid parameters using and inlined version of WAVNU1. -! + ! + ! 2. Calculate grid parameters using and inlined version of WAVNU1. + ! DEPTH = MAX ( DMIN, DPO(J) ) SQRTH = SQRT ( DEPTH ) UDIR = MOD ( 270. - WDO(J)*RADE , 360. ) @@ -1906,25 +1911,25 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) RHOAIR = MAX ( 0. , DAIRO(J)) #endif #ifdef W3_IS2 - ICEDMAX = MAX ( 0., ICEFO(J)) - ICEF = ICEDMAX + ICEDMAX = MAX ( 0., ICEFO(J)) + ICEF = ICEDMAX #endif ICETHICK = MAX (0., ICEHO(J)) ICECON = MAX (0., ICEO(J)) -! + ! #ifdef W3_STAB2 - STAB0 = ZWIND * GRAV / 273. - STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 - STAB = MAX ( -1. , MIN ( 1. , STAB ) ) - THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) - THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) - COR1 = CCNG * TANH(THARG1) - COR2 = CCPS * TANH(THARG2) - ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) -#endif -! + STAB0 = ZWIND * GRAV / 273. + STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 + STAB = MAX ( -1. , MIN ( 1. , STAB ) ) + THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) + THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) + COR1 = CCNG * TANH(THARG1) + COR2 = CCPS * TANH(THARG2) + ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) +#endif + ! #ifdef W3_T - WRITE (NDST,9010) DEPTH + WRITE (NDST,9010) DEPTH #endif DO IK=1, NK SIX = SIG(IK) * SQRTH @@ -1940,27 +1945,27 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) CG(IK) = 0.5 * GRAV / SIG(IK) END IF #ifdef W3_T - WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) + WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) #endif -! + ! END DO -! -! Computes 2nd order spectrum -! + ! + ! Computes 2nd order spectrum + ! #ifdef W3_IG1 - IF (IGPARS(2).EQ.1) THEN - IF(IGPARS(1).EQ.1) THEN - CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) - ELSE - CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) + IF (IGPARS(2).EQ.1) THEN + IF(IGPARS(1).EQ.1) THEN + CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) + ELSE + CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) + END IF END IF - END IF #endif -! -! -! 3. Prepare spectra etc. -! 3.a Mean wave parameters. -! + ! + ! + ! 3. Prepare spectra etc. + ! 3.a Mean wave parameters. + ! ET = 0. EWN = 0. ETR = 0. @@ -1982,7 +1987,7 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IF ( E1(IK) .GT. 1.E-5) THEN THBND(IK) = MOD(630.- RADE*ATAN2(EBY,EBX),360.) SPBND(IK) = RADE * SQRT ( MAX ( 0. , 2.*( 1. - & - SQRT( MAX(0.,(EBX**2+EBY**2)/EBND**2) ) ) ) ) + SQRT( MAX(0.,(EBX**2+EBY**2)/EBND**2) ) ) ) ) ELSE THBND(IK) = -999.9 SPBND(IK) = -999.9 @@ -1994,23 +1999,23 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) ETX = ETX + EBX * DSII(IK) ETY = ETY + EBY * DSII(IK) END DO -! -! tail factors for radian action etc ...! -! + ! + ! tail factors for radian action etc ...! + ! EBND = E1(NK) * TPIINV / ( SIG(NK) * DTH ) ET = ET + FTE *EBND EWN = EWN + FTWL*EBND ETR = ETR + FTTR*EBND ETX = DTH*ETX*TPIINV + FTE*EBX*TPIINV/SIG(NK) ETY = DTH*ETY*TPIINV + FTE*EBY*TPIINV/SIG(NK) -! + ! HSIG = 4. * SQRT ( ET ) IF ( HSIG .GT. HSMIN ) THEN WLEN = EWN / ET * TPI TMEAN = ETR / ET * TPI THMEAN = MOD ( 630. - RADE*ATAN2(ETY,ETX) , 360. ) THSPRD = RADE * SQRT ( MAX ( 0. , 2.*( 1. - SQRT( & - MAX(0.,(ETX**2+ETY**2)/ET**2) ) ) ) ) + MAX(0.,(ETX**2+ETY**2)/ET**2) ) ) ) ) IF ( THSPRD .LT. 0.01*RADE*DTH ) THSPRD = 0. ELSE WLEN = 0. @@ -2020,19 +2025,19 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) E1(1:NK) = 0. E(1:NK,1:NTH) = 0. END IF -! -! 3.b peak frequency -! + ! + ! 3.b peak frequency + ! EMAX = E1(NK) IKM = NK -! + ! DO IK=NK-1, 1, -1 IF ( E1(IK) .GT. EMAX ) THEN EMAX = E1(IK) IKM = IK END IF END DO -! + ! IF ( HSIG .GE. HSMIN .AND. IKM .NE. NK ) THEN IF ( IKM .EQ. 1 ) THEN EL = - E1(IKM) @@ -2043,9 +2048,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) EH = E1(IKM+1) - E1(IKM) DENOM = XL*EH - XH*EL -! + ! FP = SIG(IKM) * ( 1. + 0.5 * ( XL2*EH - XH2*EL ) & - / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) + / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) THP = THBND(IKM) SPP = SPBND(IKM) IF ( SPP .LT. 0.01*RADE*DTH ) SPP = 0. @@ -2054,19 +2059,19 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) THP = 0. SPP = 0. END IF -! -! 3.c spectral partitioning -! + ! + ! 3.c spectral partitioning + ! IF ( ITYPE.EQ.1 .AND. OTYPE.EQ.4 ) THEN CALL W3PART( E, UABS, UDIRCA, DEPTH, WN, NPART, XPART, & - DIMXP ) + DIMXP ) END IF -! -! 3.d nondimensional parameters -! + ! + ! 3.d nondimensional parameters + ! IF ( ( ITYPE.EQ.2 .AND. (OTYPE.EQ.3.OR.OTYPE.EQ.4) ) .OR. & - ( ITYPE.EQ.1 .AND. (OTYPE.EQ.2) ) ) THEN -! + ( ITYPE.EQ.1 .AND. (OTYPE.EQ.2) ) ) THEN + ! DO IK=1, NK FACTOR = TPIINV * CG(IK) / SIG(IK) DO ITH=1, NTH @@ -2075,133 +2080,133 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) WN2(ITH,IK) = WN(IK) END DO END DO -! + ! #ifdef W3_STAB2 - UABS = UABS / ASFAC + UABS = UABS / ASFAC #endif -! + ! #ifdef W3_ST0 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST1 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST2 - ZWND = ZWIND + ZWND = ZWIND #endif #ifdef W3_ST3 - ZWND = ZZWND - TAUWX = 0. - TAUWY = 0. - LLWS(:) = .TRUE. + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. + LLWS(:) = .TRUE. #endif #ifdef W3_ST4 - LLWS(:) = .TRUE. - ZWND = ZZWND - TAUWX = 0. - TAUWY = 0. + LLWS(:) = .TRUE. + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. #endif #ifdef W3_ST6 - ZWND = 10. + ZWND = 10. #endif -! + ! #ifdef W3_ST1 - CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) - FP = 0.85 * FMEAN + CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN #endif #ifdef W3_ST2 - CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) #endif #ifdef W3_ST4 - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) #endif #ifdef W3_ST6 - CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) + CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) #endif -! + ! #ifdef W3_FLX1 - CALL W3FLX1 ( ZWND, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX1 ( ZWND, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX4 - CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) + CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX5 - CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & - RHOAIR, USTAR, USTD, Z0, CD, CHARN ) + CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & + RHOAIR, USTAR, USTD, Z0, CD, CHARN ) #endif -! + ! DO ITT=1, 3 #ifdef W3_ST2 - CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & - FPI, XIN, DIA ) - CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XIN, DIA ) + CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - IX=1 - IY=1 - CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& - ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& - TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) - CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) + IX=1 + IY=1 + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& + TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) #endif #ifdef W3_ST4 - IX=1 - IY=1 - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + IX=1 + IY=1 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS,DLWMEAN ) - CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & - DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) - CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & - ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, TAUWNX, & - TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS,DLWMEAN ) + CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & + DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) + CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, TAUWNX, & + TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif END DO -! -! Add alternative flux calculations here as part of !/ST2 option .... -! Also add before actual source term calculation !!! -! + ! + ! Add alternative flux calculations here as part of !/ST2 option .... + ! Also add before actual source term calculation !!! + ! #ifdef W3_STAB2 - UABS = UABS * ASFAC + UABS = UABS * ASFAC #endif -! + ! IF ( WAO(J) .LT. 0.01 ) THEN UNORM = 0. ESTAR = 0. @@ -2218,18 +2223,18 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) YSTAR = PTLOC(2,J) * GRAV / UNORM**2 IF ( FLAGLL ) THEN XSTAR = XSTAR * DERA * RADIUS & - * COS(PTLOC(2,J)*DERA) + * COS(PTLOC(2,J)*DERA) YSTAR = YSTAR * DERA * RADIUS END IF END IF -! + ! END IF ! 3.d -! -! 3.e source terms -! + ! + ! 3.e source terms + ! IF ( ITYPE.EQ.3 ) THEN -! + ! DO IK=1, NK FACTOR = TPIINV * CG(IK) / SIG(IK) DO ITH=1, NTH @@ -2237,276 +2242,276 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) WN2(ITH,IK) = WN(IK) END DO END DO -! + ! #ifdef W3_STAB2 - UABS = UABS / ASFAC + UABS = UABS / ASFAC #endif -! + ! #ifdef W3_ST0 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST1 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST2 - ZWND = ZWIND + ZWND = ZWIND #endif #ifdef W3_ST3 - ZWND = ZZWND + ZWND = ZZWND #endif #ifdef W3_ST0 - USTAR = 1. + USTAR = 1. #endif #ifdef W3_ST1 - USTAR = 1. + USTAR = 1. #endif #ifdef W3_ST2 - USTAR = 1. + USTAR = 1. #endif #ifdef W3_ST3 - USTAR = 0. - USTD = 0. - TAUWX = 0. - TAUWY = 0. + USTAR = 0. + USTD = 0. + TAUWX = 0. + TAUWY = 0. #endif #ifdef W3_ST4 - ZWND = ZZWND - USTAR = 0. - USTD = 0. - TAUWX = 0. - TAUWY = 0. + ZWND = ZZWND + USTAR = 0. + USTD = 0. + TAUWX = 0. + TAUWY = 0. #endif #ifdef W3_ST6 - ZWND = 10. + ZWND = 10. #endif -! + ! #ifdef W3_ST0 - FHIGH = SIG(NK) + FHIGH = SIG(NK) #endif #ifdef W3_ST1 - CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) - FP = 0.85 * FMEAN - FH1 = FXFM * FMEAN - FH2 = FXPM / USTAR - FHIGH = MAX ( FH1 , FH2 ) + CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN + FH1 = FXFM * FMEAN + FH2 = FXPM / USTAR + FHIGH = MAX ( FH1 , FH2 ) #endif #ifdef W3_ST2 - CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) #endif #ifdef W3_ST4 - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) - CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & - DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) + CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & + DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) #endif #ifdef W3_ST6 - CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) - FHIGH = SIG(NK) + CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) + FHIGH = SIG(NK) #endif -! + ! #ifdef W3_FLX1 - CALL W3FLX1 ( ZWND, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX1 ( ZWND, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX4 - CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) + CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX5 - CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & - RHOAIR, USTAR, USTD, Z0, CD, CHARN ) + CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & + RHOAIR, USTAR, USTD, Z0, CD, CHARN ) #endif -! + ! DO ITT=1, 3 #ifdef W3_ST2 - CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & - FPI, XIN, DIA ) - CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XIN, DIA ) + CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) - CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& - ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & - TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & + TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) #endif #ifdef W3_ST4 - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) - CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & - ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,TAUWNX,& - TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) + CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,TAUWNX,& + TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif END DO -! + ! #ifdef W3_ST2 - FHIGH = XFC * FPI + FHIGH = XFC * FPI #endif -! + ! IF ( FLSRCE(2) ) THEN #ifdef W3_LN1 - CALL W3SLN1 (WN, FHIGH, USTAR, UDIRR, XLN ) + CALL W3SLN1 (WN, FHIGH, USTAR, UDIRR, XLN ) #endif -! + ! #ifdef W3_ST1 - CALL W3SIN1 (A, WN2, USTAR, UDIRR, XIN, DIA ) + CALL W3SIN1 (A, WN2, USTAR, UDIRR, XIN, DIA ) #endif #ifdef W3_ST2 - CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0,& - FPI, XIN, DIA ) + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0,& + FPI, XIN, DIA ) #endif #ifdef W3_ST3 - CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, & - DAIR/DWAT, ASO(J), UDIRR, & - Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & - ICE, XIN, DIA, LLWS, IX, IY ) + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, & + DAIR/DWAT, ASO(J), UDIRR, & + Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & + ICE, XIN, DIA, LLWS, IX, IY ) #endif -! + ! #ifdef W3_ST4 - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) - CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & - DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) - CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & - ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, TAUWNX, & - TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) + CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & + DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) + CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, TAUWNX, & + TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) #endif #ifdef W3_ST6 - CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, DAIR, & - TAUWX, TAUWY, TAUWNX, TAUWNY, XIN, DIA ) + CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, DAIR, & + TAUWX, TAUWY, TAUWNX, TAUWNY, XIN, DIA ) #endif END IF IF ( FLSRCE(3) ) THEN #ifdef W3_NL1 - CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) + CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) #endif #ifdef W3_NL2 - CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) + CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) #endif #ifdef W3_NL3 - CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) + CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) #endif #ifdef W3_NL4 - CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) + CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) #endif END IF IF ( FLSRCE(4) ) THEN #ifdef W3_ST1 - CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, & - XDS, DIA ) + CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, & + XDS, DIA ) #endif #ifdef W3_ST2 - CALL W3SDS2 ( A, CG, WN, FPI, USTAR, & - ALPHA, XDS, DIA ) + CALL W3SDS2 ( A, CG, WN, FPI, USTAR, & + ALPHA, XDS, DIA ) #endif #ifdef W3_ST3 - CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & - USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) + CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & + USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) #endif #ifdef W3_ST4 - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) - CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & - DIA, IX, IY, LAMBDA, WHITECAP , DLWMEAN) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) + CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & + DIA, IX, IY, LAMBDA, WHITECAP , DLWMEAN) #endif #ifdef W3_ST6 - CALL W3SDS6 ( A, CG, WN, XDS, DIA ) - IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) + CALL W3SDS6 ( A, CG, WN, XDS, DIA ) + IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) #endif -! + ! #ifdef W3_DB1 - CALL W3SDB1 ( I, A, DEPTH, EMEAN, FMEAN, & - WNMEAN, CG, LBREAK, XDB, DIA ) + CALL W3SDB1 ( I, A, DEPTH, EMEAN, FMEAN, & + WNMEAN, CG, LBREAK, XDB, DIA ) #endif END IF IF ( FLSRCE(5) ) THEN #ifdef W3_BT1 - CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) + CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) #endif #ifdef W3_BT4 - IX=1 ! to be fixed later - IY=1 ! to be fixed later - ISEA=1 ! to be fixed later - D50 = SED_D50(ISEA) - PSIC= SED_PSIC(ISEA) - CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & - BEDFORM, XBT, DIA, IX, IY ) + IX=1 ! to be fixed later + IY=1 ! to be fixed later + ISEA=1 ! to be fixed later + D50 = SED_D50(ISEA) + PSIC= SED_PSIC(ISEA) + CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & + BEDFORM, XBT, DIA, IX, IY ) #endif -! see remarks about BT8 and BT9 in ww3_outp.ftn -!....broken....!/BT8 CALL W3SBT8 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) -!....broken....!/BT9 CALL W3SBT9 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) + ! see remarks about BT8 and BT9 in ww3_outp.ftn + !....broken....!/BT8 CALL W3SBT8 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) + !....broken....!/BT9 CALL W3SBT9 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) -! + ! #ifdef W3_BS1 - CALL W3SBS1 ( A, CG, WN, DEPTH, & - CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & - TAUSCX, TAUSCY, XBS, DIA ) + CALL W3SBS1 ( A, CG, WN, DEPTH, & + CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & + TAUSCX, TAUSCY, XBS, DIA ) #endif -! + ! END IF IF ( FLSRCE(6) ) THEN IF (IICEDISP) THEN - CALL LIU_FORWARD_DISPERSION (ICETHICK,0.,DEPTH, & + CALL LIU_FORWARD_DISPERSION (ICETHICK,0.,DEPTH, & SIG,WN_R,CG_ICE,ALPHA_LIU) ELSE WN_R=WN CG_ICE=CG - END IF -! + END IF + ! #ifdef W3_IS2 CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, & - IX, IY, XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) + IX, IY, XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) #endif END IF -! + ! #ifdef W3_STAB2 - UABS = UABS * ASFAC + UABS = UABS * ASFAC #endif -! + ! IF ( ISCALE.EQ.0 .OR. ISCALE.EQ.3 ) THEN FACF = TPIINV FACE = 1. @@ -2520,7 +2525,7 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) FACE = GRAV**3 / USTAR**5 FACS = GRAV**2 / USTAR**4 END IF -! + ! DO IK=1, NK FACTOR = TPI / CG(IK) * SIG(IK) E1 (IK) = 0. @@ -2537,12 +2542,12 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) SNL(IK,ITH) = ( XNL(ITH,IK) + XTR(ITH,IK) ) * FACTOR SDS(IK,ITH) = ( XDS(ITH,IK) + XDB(ITH,IK) ) * FACTOR #ifdef W3_ST6 - SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) + SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) #endif SBT(IK,ITH) = ( XBT(ITH,IK) + XBS(ITH,IK) ) * FACTOR SIS(IK,ITH) = XIS(ITH,IK) * FACTOR STT(IK,ITH) = SWN(IK,ITH) + SNL(IK,ITH) + SDS(IK,ITH) + & - SBT(IK,ITH) + SIS(IK,ITH) + XXX(ITH,IK) * FACTOR + SBT(IK,ITH) + SIS(IK,ITH) + XXX(ITH,IK) * FACTOR E1 (IK) = E1 (IK) + E(IK,ITH) SIN1(IK) = SIN1(IK) + SWN(IK,ITH) SNL1(IK) = SNL1(IK) + SNL(IK,ITH) @@ -2557,7 +2562,7 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) SBT1(IK) = SBT1(IK) * DTH * FACS SIS1(IK) = SIS1(IK) * DTH * FACS END DO -! + ! STT1 = SIN1 + SNL1 + SDS1 + SBT1 + SIS1 E1ALL(:,1) = SIN1 E1ALL(:,2) = SNL1 @@ -2565,16 +2570,16 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) E1ALL(:,4) = SBT1 E1ALL(:,5) = SIS1 E1ALL(:,6) = STT1 -! + ! END IF ! 3.e -! -! 4.a Perform output type 1 ( print plots / tables / file ) -! + ! + ! 4.a Perform output type 1 ( print plots / tables / file ) + ! IF ( ITYPE .EQ. 1 ) THEN -! -! Format Time -! + ! + ! Format Time + ! IF ( OTYPE .NE. 1 ) THEN CALL T2D(TIME,CURDATE,IERR) @@ -2584,18 +2589,18 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) END IF -! -! Performs subtype 1 -! + ! + ! Performs subtype 1 + ! IF ( OTYPE .EQ. 1 ) THEN -! + ! IF ( SCALE1 .GE. 0. ) & - CALL PRT1DS (NDSO, NK, E1, SIG(1:NK), 'RAD/S',& - 17, SCALE1, 'E(f)', 'm^2s', PTNME(J) ) + CALL PRT1DS (NDSO, NK, E1, SIG(1:NK), 'RAD/S',& + 17, SCALE1, 'E(f)', 'm^2s', PTNME(J) ) IF ( SCALE2 .GE. 0. ) & - CALL PRT2DS (NDSO, NK, NK, NTH, E, SIG(1:NK), & - 'RAD/S', 1., SCALE2, 0.0001, 'E(f,th)', & - 'm^2s', PTNME(J) ) + CALL PRT2DS (NDSO, NK, NK, NTH, E, SIG(1:NK), & + 'RAD/S', 1., SCALE2, 0.0001, 'E(f,th)', & + 'm^2s', PTNME(J) ) IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,910) DPO(J), UABS IF ( (WAO(J) .GT. 0.) .AND. (IAPROC .EQ. NAPOUT) ) WRITE (NDSO,911) UDIR IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,912) ASO(J), CAO(J) @@ -2603,9 +2608,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,914) HSIG, WLEN, TMEAN, THMEAN, THSPRD -! -! Performs subtype 2 -! + ! + ! Performs subtype 2 + ! ELSE IF ( OTYPE .EQ. 2 ) THEN IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) @@ -2627,9 +2632,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),APM(1:NK),start=(/1,J1,IOUT /),count=(/NK,1,1/)) -! -! Performs subtype 3 -! + ! + ! Performs subtype 3 + ! ELSE IF ( OTYPE .EQ. 3 ) THEN IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) CALL CHECK_ERR(IRET,18) @@ -2654,12 +2659,12 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) WHERE(E.GE.0) E=NINT(ALOG10(E+1E-12)/0.0004) END IF IRET=NF90_PUT_VAR(NCID,VARID(10),TRANSPOSE(E(1:NK,1:NTH)), & - start=(/1,1,J1,IOUT/),count=(/NTH,NK,1,1/)) -! -! Performs subtype 4 -! + start=(/1,1,J1,IOUT/),count=(/NTH,NK,1,1/)) + ! + ! Performs subtype 4 + ! ELSE IF ( OTYPE .EQ. 4 ) THEN -! + ! IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) CALL CHECK_ERR(IRET,19) IRET=NF90_PUT_VAR(NCID,VARID(2),PTNME(J),start=(/1,J1/),count=(/LEN_TRIM(PTNME(J)) ,1/)) @@ -2674,9 +2679,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(11),CDIR,(/J1,IOUT/)) ! XPART infos - see w3partmd.ftn - SUBROUTINE PTMEAN IRET=NF90_PUT_VAR(NCID,VARID(12),XPART(1,0:NPART), & - start=(/1,J1,IOUT/),count=(/NPART,1,1/)) + start=(/1,J1,IOUT/),count=(/NPART,1,1/)) IRET=NF90_PUT_VAR(NCID,VARID(13),XPART(2,0:NPART), & - start=(/1,J1,IOUT/),count=(/NPART,1,1/)) + start=(/1,J1,IOUT/),count=(/NPART,1,1/)) IRET=NF90_PUT_VAR(NCID,VARID(14),XPART(3,0:NPART),start=(/1,J1,IOUT/),count=(/NPART,1,1/)) IRET=NF90_PUT_VAR(NCID,VARID(15),XPART(4,0:NPART),start=(/1,J1,IOUT/),count=(/NPART,1,1/)) IRET=NF90_PUT_VAR(NCID,VARID(16),XPART(5,0:NPART),start=(/1,J1,IOUT/),count=(/NPART,1,1/)) @@ -2684,22 +2689,22 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(18),XPART(12,0:NPART),start=(/1,J1,IOUT/),count=(/NPART,1,1/)) IRET=NF90_PUT_VAR(NCID,VARID(19),XPART(13,0:NPART),start=(/1,J1,IOUT/),count=(/NPART,1,1/)) IRET=NF90_PUT_VAR(NCID,VARID(20),XPART(14,0:NPART),start=(/1,J1,IOUT/),count=(/NPART,1,1/)) -! + ! END IF -! -! 4.b Perform output type 2 ( tables ) -! + ! + ! 4.b Perform output type 2 ( tables ) + ! ELSE IF ( ITYPE .EQ. 2 ) THEN -! Format Time + ! Format Time CALL T2D(TIME,CURDATE,IERR) OUTJULDAY=TSUB(REFDATE,CURDATE) IRET=NF90_PUT_VAR(NCID,VARID(1),OUTJULDAY,(/IOUT/)) -! -! Performs subtype 1 -! + ! + ! Performs subtype 1 + ! IF ( OTYPE .EQ. 1 ) THEN IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) @@ -2713,12 +2718,12 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(9),WAO(J),(/ J1,IOUT /)) IRET=NF90_PUT_VAR(NCID,VARID(10),UDIR,(/ J1,IOUT /)) #ifdef W3_SETUP - IRET=NF90_PUT_VAR(NCID,VARID(11),ZET_SETO,(/ J1,IOUT /)) + IRET=NF90_PUT_VAR(NCID,VARID(11),ZET_SETO,(/ J1,IOUT /)) #endif -! -! Performs subtype 2 -! + ! + ! Performs subtype 2 + ! ELSE IF ( OTYPE .EQ. 2 ) THEN IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) @@ -2735,9 +2740,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(12),THMEAN,(/ J1,IOUT /)) IRET=NF90_PUT_VAR(NCID,VARID(13),THSPRD,(/ J1,IOUT /)) -! -! Performs subtype 3 -! + ! + ! Performs subtype 3 + ! ELSE IF ( OTYPE .EQ. 3 ) THEN IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) @@ -2751,9 +2756,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(9),CD*1000.,(/ J1,IOUT /)) IRET=NF90_PUT_VAR(NCID,VARID(10),APM(NK)*100.,(/ J1,IOUT /)) -! -! Performs subtype 4 -! + ! + ! Performs subtype 4 + ! ELSE IF ( OTYPE .EQ. 4 ) THEN IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) @@ -2767,9 +2772,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(9),CD*1000.,(/ J1,IOUT /)) IRET=NF90_PUT_VAR(NCID,VARID(10),APM(NK)*100.,(/ J1,IOUT /)) -! -! Performs subtype 5 -! + ! + ! Performs subtype 5 + ! ELSE IF ( OTYPE .EQ. 5 ) THEN HMAT = MIN ( 100. , 3.33*GRAV*HSIG/UABS**2 ) IF ( HSIG .GE. HSMIN ) THEN @@ -2796,9 +2801,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(11),AGE2,(/ J1,IOUT /)) IRET=NF90_PUT_VAR(NCID,VARID(12),ASO(J),(/ J1,IOUT /)) -! -! Performs subtype 6 -! + ! + ! Performs subtype 6 + ! ELSE IF ( OTYPE .EQ. 6 ) THEN IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) @@ -2817,71 +2822,71 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) END IF END IF ! OTYPE -! -! 4.c Perform output type 3 ( source terms ) -! + ! + ! 4.c Perform output type 3 ( source terms ) + ! ELSE IF ( ITYPE .EQ. 3 ) THEN -! -! Format Time -! + ! + ! Format Time + ! IF ( OTYPE .NE. 1 ) THEN CALL T2D(TIME,CURDATE,IERR) OUTJULDAY=TSUB(REFDATE,CURDATE) IRET=NF90_PUT_VAR(NCID,VARID(1),OUTJULDAY,(/IOUT/)) END IF -! -! Performs subtype 1 -! + ! + ! Performs subtype 1 + ! IF ( OTYPE .EQ. 1 ) THEN -! + ! IF ( SCALE1 .GE. 0. ) THEN - IF ( FLSRCE(1) ) & - CALL PRT1DS (NDSO, NK, E1, SIG(1:NK), & - 'RAD/S', 17, 0., 'E(f)', 'm^2s', & - PTNME(J) ) - IF (FLSRCE(2) .OR. FLSRCE(3) .OR. & - FLSRCE(4) .OR. FLSRCE(5) .OR. & - FLSRCE(6) .OR. FLSRCE(7) ) & - CALL PRT1DM (NDSO, NK, 6, E1ALL, SIG(1:NK),& - 'RAD/S', 17, SCALE1, VAR1, 'M2', & - PTNME(J) ) + IF ( FLSRCE(1) ) & + CALL PRT1DS (NDSO, NK, E1, SIG(1:NK), & + 'RAD/S', 17, 0., 'E(f)', 'm^2s', & + PTNME(J) ) + IF (FLSRCE(2) .OR. FLSRCE(3) .OR. & + FLSRCE(4) .OR. FLSRCE(5) .OR. & + FLSRCE(6) .OR. FLSRCE(7) ) & + CALL PRT1DM (NDSO, NK, 6, E1ALL, SIG(1:NK),& + 'RAD/S', 17, SCALE1, VAR1, 'M2', & + PTNME(J) ) END IF IF ( SCALE2 .GE. 0. ) THEN - IF ( FLSRCE(1) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, E, & - SIG(1:NK), 'RAD/S', 1., 0., 0.0001, & - 'E(f,th)', 'm^2s', PTNME(J) ) - IF ( FLSRCE(2) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, SWN, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Sin(f,th)', 'm^2', PTNME(J) ) - IF ( FLSRCE(3) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, SNL, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Snl(f,th)', 'm^2', PTNME(J) ) - IF ( FLSRCE(4) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, SDS, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Sds(f,th)', 'm^2', PTNME(J) ) - IF ( FLSRCE(5) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, SBT, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Sbt(f,th)', 'm^2', PTNME(J) ) - IF ( FLSRCE(6) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, SIS, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Sice(f,th)', 'm^2', PTNME(J) ) - IF ( FLSRCE(7) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, STT, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Stot(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(1) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, E, & + SIG(1:NK), 'RAD/S', 1., 0., 0.0001, & + 'E(f,th)', 'm^2s', PTNME(J) ) + IF ( FLSRCE(2) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, SWN, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Sin(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(3) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, SNL, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Snl(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(4) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, SDS, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Sds(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(5) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, SBT, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Sbt(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(6) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, SIS, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Sice(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(7) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, STT, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Stot(f,th)', 'm^2', PTNME(J) ) END IF -! -! Performs subtype 2 -! + ! + ! Performs subtype 2 + ! ELSE IF ( OTYPE .EQ. 2 ) THEN -! + ! IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) IRET=NF90_PUT_VAR(NCID,VARID(2),PTNME(J),start=(/1,J1/),count=(/LEN_TRIM(PTNME(J)) ,1/)) IF (FLWW3.NE.0) IRET=NF90_PUT_VAR(NCID,VARID(3),FLWW3,(/J1,IOUT/)) @@ -2900,11 +2905,11 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),SIS1(1:NK),start=(/1,J1,IOUT /),count=(/NK,1,1/)) IRET=NF90_PUT_VAR(NCID,VARID(16),STT1(1:NK),start=(/1,J1,IOUT /),count=(/NK,1,1/)) -! -! Performs subtype 3 -! + ! + ! Performs subtype 3 + ! ELSE IF ( OTYPE .EQ. 3 ) THEN -! + ! IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) IRET=NF90_PUT_VAR(NCID,VARID(2),PTNME(J),start=(/1,J1/),count=(/LEN_TRIM(PTNME(J)) ,1/)) IF (FLWW3.NE.0) IRET=NF90_PUT_VAR(NCID,VARID(3),FLWW3,(/J1,IOUT/)) @@ -2935,11 +2940,11 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) END IF END DO -! -! Performs subtype 4 -! + ! + ! Performs subtype 4 + ! ELSE IF ( OTYPE .EQ. 4 ) THEN -! + ! IRET=NF90_PUT_VAR(NCID,VARID(27),J,(/J1/)) IRET=NF90_PUT_VAR(NCID,VARID(2),PTNME(J),start=(/1,J1/),count=(/LEN_TRIM(PTNME(J)) ,1/)) IF (FLWW3.NE.0) IRET=NF90_PUT_VAR(NCID,VARID(3),FLWW3,(/J1,IOUT/)) @@ -2953,40 +2958,40 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(15),USTAR,(/J1,IOUT/)) IF ( FLSRCE(1) ) IRET=NF90_PUT_VAR(NCID,VARID(16), & - TRANSPOSE(E(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & - count=(/NTH,NK,1,1/) ) + TRANSPOSE(E(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & + count=(/NTH,NK,1,1/) ) IF ( FLSRCE(2) ) IRET=NF90_PUT_VAR(NCID,VARID(17), & - TRANSPOSE(SWN(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & - count=(/NTH,NK,1,1/) ) + TRANSPOSE(SWN(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & + count=(/NTH,NK,1,1/) ) IF ( FLSRCE(3) ) IRET=NF90_PUT_VAR(NCID,VARID(18), & - TRANSPOSE(SNL(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & - count=(/NTH,NK,1,1/) ) + TRANSPOSE(SNL(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & + count=(/NTH,NK,1,1/) ) IF ( FLSRCE(4) ) IRET=NF90_PUT_VAR(NCID,VARID(19), & - TRANSPOSE(SDS(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & - count=(/NTH,NK,1,1/) ) + TRANSPOSE(SDS(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & + count=(/NTH,NK,1,1/) ) IF ( FLSRCE(5) ) IRET=NF90_PUT_VAR(NCID,VARID(20), & - TRANSPOSE(SBT(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & - count=(/NTH,NK,1,1/) ) + TRANSPOSE(SBT(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & + count=(/NTH,NK,1,1/) ) IF ( FLSRCE(6) ) IRET=NF90_PUT_VAR(NCID,VARID(21), & - TRANSPOSE(SIS(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & - count=(/NTH,NK,1,1/) ) + TRANSPOSE(SIS(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & + count=(/NTH,NK,1,1/) ) IF ( FLSRCE(7) ) IRET=NF90_PUT_VAR(NCID,VARID(22), & - TRANSPOSE(STT(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & - count=(/NTH,NK,1,1/) ) -! + TRANSPOSE(STT(1:NK,1:NTH)), start=(/1,1,J1,IOUT/), & + count=(/NTH,NK,1,1/) ) + ! END IF -! + ! END IF ! ITYPE -! -! ... End of fields loop -! + ! + ! ... End of fields loop + ! IF (TOGETHER) J1=J1+1 END IF ! FLREQ(J) -! -! Selects next station index or end up if not together -! + ! + ! Selects next station index or end up if not together + ! IF (TOGETHER) THEN J=J+1 IF (J.GT.NOPTS) LASTSTATION=.TRUE. @@ -2996,2572 +3001,2572 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) END DO ! DO WHILE (.NOT. LASTSTATION) - END IF ! NOT SHORT ... -! - RETURN -! -! Formats -! - 910 FORMAT (/15X,' Water depth :',F7.1,' (m)'/ & - 15X,' Wind speed :',F8.2,' (m/s)') - 911 FORMAT ( 15X,' Wind direction :',F7.1,' (degr)') - 912 FORMAT ( 15X,' Air-sea temp. dif.:',F7.1,' (degr)'/ & - 15X,' sea water speed :',F8.2,' (m/s)') - 913 FORMAT ( 15X,' direction of current (from) :',F7.1,' (degr)') - 914 FORMAT ( 15X,' Wave height :',F8.2,' (m)'/ & - 15X,' Mean wave length :',F6.0,' (m)'/ & - 15X,' Mean wave period :',F7.1,' (s)'/ & - 15X,' Mean wave direct. :',F7.1,' (degr)'/ & - 15X,' Direct. spread :',F7.1,' (degr)'/) -! + END IF ! NOT SHORT ... + ! + RETURN + ! + ! Formats + ! +910 FORMAT (/15X,' Water depth :',F7.1,' (m)'/ & + 15X,' Wind speed :',F8.2,' (m/s)') +911 FORMAT ( 15X,' Wind direction :',F7.1,' (degr)') +912 FORMAT ( 15X,' Air-sea temp. dif.:',F7.1,' (degr)'/ & + 15X,' sea water speed :',F8.2,' (m/s)') +913 FORMAT ( 15X,' direction of current (from) :',F7.1,' (degr)') +914 FORMAT ( 15X,' Wave height :',F8.2,' (m)'/ & + 15X,' Mean wave length :',F6.0,' (m)'/ & + 15X,' Mean wave period :',F7.1,' (s)'/ & + 15X,' Mean wave direct. :',F7.1,' (degr)'/ & + 15X,' Direct. spread :',F7.1,' (degr)'/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3EXNC : FLAGS :',40L2) - 9001 FORMAT (' TEST W3EXNC : ITPYE :',I4/ & - ' OTPYE :',I4/ & - ' NREQ :',I4/ & - ' SCALE1 :',E10.3/ & - ' SCALE2 :',E10.3/ & - ' FLSRCE :',6L2) - 9002 FORMAT (' TEST W3EXNC : OUTPUT POINT : ',A) - 9010 FORMAT (' TEST W3EXNC : DEPTH =',F7.1,' IK, T, K, CG :') - 9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) +9000 FORMAT (' TEST W3EXNC : FLAGS :',40L2) +9001 FORMAT (' TEST W3EXNC : ITPYE :',I4/ & + ' OTPYE :',I4/ & + ' NREQ :',I4/ & + ' SCALE1 :',E10.3/ & + ' SCALE2 :',E10.3/ & + ' FLSRCE :',6L2) +9002 FORMAT (' TEST W3EXNC : OUTPUT POINT : ',A) +9010 FORMAT (' TEST W3EXNC : DEPTH =',F7.1,' IK, T, K, CG :') +9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#endif + !/ + !/ End of W3EXNC ----------------------------------------------------- / + !/ + END SUBROUTINE W3EXNC + + + + + + !-------------------------------------------------------------------------- + !> @brief Desc not available. + !> + !> @param[in] ITYPE + !> @param[in] OTYPE + !> @param[in] NCTYPE + !> @param[in] NCFILE + !> @param[out] NCID + !> @param[out] DIMID + !> @param[in] DIMLN + !> @param[out] VARID + !> @param[in] ONE + !> @param[in] TWO + !> @param[in] FLSRCE + !> @param[in] NCVARTYPE + !> + !> @author NA @date NA + SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, TWO, FLSRCE, NCVARTYPE) + + + USE W3GDATMD + USE NETCDF + + implicit none + + + INTEGER, INTENT(IN) :: ITYPE,OTYPE,NCTYPE, ONE, TWO + CHARACTER*(128), INTENT(IN) :: NCFILE + INTEGER, INTENT(IN) :: DIMLN(5) + INTEGER, INTENT(OUT) :: DIMID(7), VARID(28),NCID + LOGICAL, INTENT(IN), OPTIONAL :: FLSRCE(7) + INTEGER, INTENT(IN), OPTIONAL :: NCVARTYPE + + ! local parameters + INTEGER :: IRET + INTEGER :: DEFLATE=1 + ! + REAL(kind=4) :: FREQ(NK), FREQ1(NK),FREQ2(NK), DIR(NTH) + + + ! + ! Creation in netCDF3 or netCDF4 + ! + IF(NCTYPE.EQ.3) IRET = NF90_CREATE(TRIM(NCFILE), NF90_CLOBBER, NCID) + IF(NCTYPE.EQ.4) IRET = NF90_CREATE(TRIM(NCFILE), NF90_NETCDF4, NCID) + CALL CHECK_ERR(IRET,20) + + ! + ! Define generals dimensions + ! + IRET = NF90_DEF_DIM(NCID, 'time', DIMLN(1), DIMID(1)) + CALL CHECK_ERR(IRET,21) + IRET = NF90_DEF_DIM(NCID, 'station', DIMLN(2), DIMID(2)) + CALL CHECK_ERR(IRET,22) + IRET = NF90_DEF_DIM(NCID, 'string40', DIMLN(3), DIMID(3)) + CALL CHECK_ERR(IRET,23) + + ! + ! define generals variables + ! + + ! time + IRET=NF90_DEF_VAR(NCID, 'time', NF90_DOUBLE, DIMID(1), VARID(1)) + CALL CHECK_ERR(IRET,24) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(1), 1, 1, DEFLATE) + SELECT CASE (TRIM(CALTYPE)) + CASE ('360_day') + IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','time in 360 day calendar') + CASE ('365_day') + IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','time in 365 day calendar') + CASE ('standard') + IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','julian day (UT)') + END SELECT + IRET=NF90_PUT_ATT(NCID,VARID(1),'standard_name','time') + IRET=NF90_PUT_ATT(NCID,VARID(1),'units','days since 1990-01-01 00:00:00') + IRET=NF90_PUT_ATT(NCID,VARID(1),'conventions','Relative julian days with decimal part (as parts of the day)') + IRET=NF90_PUT_ATT(NCID,VARID(1),'axis','T') + IRET=NF90_PUT_ATT(NCID,VARID(1),'calendar',TRIM(CALTYPE)) + + ! station + IRET=NF90_DEF_VAR(NCID, 'station', NF90_INT, (/DIMID(2)/), VARID(27)) + CALL CHECK_ERR(IRET,25) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(27), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(27),'long_name','station id') + IRET=NF90_PUT_ATT(NCID,VARID(27),'_FillValue',NF90_FILL_INT) + IRET=NF90_PUT_ATT(NCID,VARID(27),'axis','X') + + ! string40 + IRET=NF90_DEF_VAR(NCID, 'string40', NF90_INT, (/DIMID(3)/), VARID(28)) + CALL CHECK_ERR(IRET,26) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(28), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(28),'long_name','station_name number of characters') + IRET=NF90_PUT_ATT(NCID,VARID(28),'_FillValue',NF90_FILL_INT) + IRET=NF90_PUT_ATT(NCID,VARID(28),'axis','W') + + ! station_name + IRET=NF90_DEF_VAR(NCID, 'station_name', NF90_CHAR, (/DIMID(3),DIMID(2)/), VARID(2)) + CALL CHECK_ERR(IRET,27) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(2), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','station name') + IRET=NF90_PUT_ATT(NCID,VARID(2),'content','XW') + IRET=NF90_PUT_ATT(NCID,VARID(2),'associates','station string40') + + IF (FLWW3.NE.0) THEN + ! wwIII param version + IRET=NF90_DEF_VAR(NCID, 'WWIII_param_version', NF90_SHORT, (/DIMID(TWO),DIMID(ONE)/), VARID(3)) + CALL CHECK_ERR(IRET,28) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(3), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','WaveWatch III parameters version') + IRET=NF90_PUT_ATT(NCID,VARID(3),'standard_name','WWIII_param_version') + IRET=NF90_PUT_ATT(NCID,VARID(3),'globwave_name','WWIII_param_version') + IRET=NF90_PUT_ATT(NCID,VARID(3),'units','-') + IRET=NF90_PUT_ATT(NCID,VARID(3),'scale_factor',1) + IRET=NF90_PUT_ATT(NCID,VARID(3),'add_offset',0) + IRET=NF90_PUT_ATT(NCID,VARID(3),'valid_min',1) + IRET=NF90_PUT_ATT(NCID,VARID(3),'valid_max',999) + IRET=NF90_PUT_ATT(NCID,VARID(3),'_FillValue',NF90_FILL_SHORT) + IRET=NF90_PUT_ATT(NCID,VARID(3),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(3),'associates','time station') + END IF + + IF (FLAGLL) THEN + ! longitude + IRET=NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, (/DIMID(TWO),DIMID(ONE)/), VARID(4)) + CALL CHECK_ERR(IRET,29) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(4), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(4),'long_name','longitude') + IRET=NF90_PUT_ATT(NCID,VARID(4),'standard_name','longitude') + IRET=NF90_PUT_ATT(NCID,VARID(4),'globwave_name','longitude') + IRET=NF90_PUT_ATT(NCID,VARID(4),'units','degree_east') + IRET=NF90_PUT_ATT(NCID,VARID(4),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_min',-180.0) + IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(4),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(4),'associates','time station') + + ! latitude + IRET=NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, (/DIMID(TWO),DIMID(ONE)/), VARID(5)) + CALL CHECK_ERR(IRET,30) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(5), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(5),'long_name','latitude') + IRET=NF90_PUT_ATT(NCID,VARID(5),'standard_name','latitude') + IRET=NF90_PUT_ATT(NCID,VARID(5),'globwave_name','latitude') + IRET=NF90_PUT_ATT(NCID,VARID(5),'units','degree_north') + IRET=NF90_PUT_ATT(NCID,VARID(5),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_min',-90.0) + IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_max',180.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(5),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(5),'associates','time station') + + + ELSE + ! longitude + IRET=NF90_DEF_VAR(NCID, 'x', NF90_FLOAT, (/DIMID(TWO),DIMID(ONE)/), VARID(4)) + CALL CHECK_ERR(IRET,31) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(4), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(4),'long_name','x') + IRET=NF90_PUT_ATT(NCID,VARID(4),'standard_name','x') + IRET=NF90_PUT_ATT(NCID,VARID(4),'globwave_name','x') + IRET=NF90_PUT_ATT(NCID,VARID(4),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(4),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_max',10000.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(4),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(4),'associates','time station') + + + ! latitude + IRET=NF90_DEF_VAR(NCID, 'y', NF90_FLOAT, (/DIMID(TWO),DIMID(ONE)/), VARID(5)) + CALL CHECK_ERR(IRET,32) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(5), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(5),'long_name','y') + IRET=NF90_PUT_ATT(NCID,VARID(5),'standard_name','y') + IRET=NF90_PUT_ATT(NCID,VARID(5),'globwave_name','y') + IRET=NF90_PUT_ATT(NCID,VARID(5),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(5),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_max',10000.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(5),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(5),'associates','time station') + + END IF + + ! Process FREQ and DIR dimension values + FREQ(1:NK)=SIG(1:NK)*TPIINV + FREQ1(1:NK)=FREQ(1:NK)-0.5*(FREQ(1:NK)-(FREQ(1:NK)/XFR)) + FREQ2(1:NK)=FREQ(1:NK)+0.5*(-FREQ(1:NK)+(FREQ(1:NK)*XFR)) + FREQ1(1)=SIG(1)*TPIINV + FREQ2(NK)=SIG(NK)*TPIINV + DIR(1:NTH)=MOD(450-THD(1:NTH),360.) + + ! + ! ... ITYPE = 1 AND OTYPE = 2 + ! + + IF (ITYPE.EQ.1 .AND. OTYPE.EQ.2) THEN + ! + ! Define specifics dimensions + ! + IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(4), DIMID(4)) + CALL CHECK_ERR(IRET,33) + + ! + ! define specifics variables + ! + + ! frequency + IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, DIMID(4), VARID(6)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','frequency of center band') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','frequency') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') + !d + IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-100.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10000.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') + !Ust + IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','friction velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') + !U10 + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') + !Dir + IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','wind direction') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') + END IF #endif -!/ -!/ End of W3EXNC ----------------------------------------------------- / -!/ - END SUBROUTINE W3EXNC - - - -!-------------------------------------------------------------------------- -!> @brief Desc not available. -!> -!> @param[in] ITYPE -!> @param[in] OTYPE -!> @param[in] NCTYPE -!> @param[in] NCFILE -!> @param[out] NCID -!> @param[out] DIMID -!> @param[in] DIMLN -!> @param[out] VARID -!> @param[in] ONE -!> @param[in] TWO -!> @param[in] FLSRCE -!> @param[in] NCVARTYPE -!> -!> @author NA @date NA - SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, TWO, FLSRCE, NCVARTYPE) - - - USE W3GDATMD - USE NETCDF - - implicit none - - - INTEGER, INTENT(IN) :: ITYPE,OTYPE,NCTYPE, ONE, TWO - CHARACTER*(128), INTENT(IN) :: NCFILE - INTEGER, INTENT(IN) :: DIMLN(5) - INTEGER, INTENT(OUT) :: DIMID(7), VARID(28),NCID - LOGICAL, INTENT(IN), OPTIONAL :: FLSRCE(7) - INTEGER, INTENT(IN), OPTIONAL :: NCVARTYPE - - ! local parameters - INTEGER :: IRET - INTEGER :: DEFLATE=1 -! - REAL(kind=4) :: FREQ(NK), FREQ1(NK),FREQ2(NK), DIR(NTH) - - -! -! Creation in netCDF3 or netCDF4 -! - IF(NCTYPE.EQ.3) IRET = NF90_CREATE(TRIM(NCFILE), NF90_CLOBBER, NCID) - IF(NCTYPE.EQ.4) IRET = NF90_CREATE(TRIM(NCFILE), NF90_NETCDF4, NCID) - CALL CHECK_ERR(IRET,20) - -! -! Define generals dimensions -! - IRET = NF90_DEF_DIM(NCID, 'time', DIMLN(1), DIMID(1)) - CALL CHECK_ERR(IRET,21) - IRET = NF90_DEF_DIM(NCID, 'station', DIMLN(2), DIMID(2)) - CALL CHECK_ERR(IRET,22) - IRET = NF90_DEF_DIM(NCID, 'string40', DIMLN(3), DIMID(3)) - CALL CHECK_ERR(IRET,23) - -! -! define generals variables -! - -! time - IRET=NF90_DEF_VAR(NCID, 'time', NF90_DOUBLE, DIMID(1), VARID(1)) - CALL CHECK_ERR(IRET,24) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(1), 1, 1, DEFLATE) - SELECT CASE (TRIM(CALTYPE)) - CASE ('360_day') - IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','time in 360 day calendar') - CASE ('365_day') - IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','time in 365 day calendar') - CASE ('standard') - IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','julian day (UT)') - END SELECT - IRET=NF90_PUT_ATT(NCID,VARID(1),'standard_name','time') - IRET=NF90_PUT_ATT(NCID,VARID(1),'units','days since 1990-01-01 00:00:00') - IRET=NF90_PUT_ATT(NCID,VARID(1),'conventions','Relative julian days with decimal part (as parts of the day)') - IRET=NF90_PUT_ATT(NCID,VARID(1),'axis','T') - IRET=NF90_PUT_ATT(NCID,VARID(1),'calendar',TRIM(CALTYPE)) - -! station - IRET=NF90_DEF_VAR(NCID, 'station', NF90_INT, (/DIMID(2)/), VARID(27)) - CALL CHECK_ERR(IRET,25) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(27), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(27),'long_name','station id') - IRET=NF90_PUT_ATT(NCID,VARID(27),'_FillValue',NF90_FILL_INT) - IRET=NF90_PUT_ATT(NCID,VARID(27),'axis','X') - -! string40 - IRET=NF90_DEF_VAR(NCID, 'string40', NF90_INT, (/DIMID(3)/), VARID(28)) - CALL CHECK_ERR(IRET,26) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(28), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(28),'long_name','station_name number of characters') - IRET=NF90_PUT_ATT(NCID,VARID(28),'_FillValue',NF90_FILL_INT) - IRET=NF90_PUT_ATT(NCID,VARID(28),'axis','W') - -! station_name - IRET=NF90_DEF_VAR(NCID, 'station_name', NF90_CHAR, (/DIMID(3),DIMID(2)/), VARID(2)) - CALL CHECK_ERR(IRET,27) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(2), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','station name') - IRET=NF90_PUT_ATT(NCID,VARID(2),'content','XW') - IRET=NF90_PUT_ATT(NCID,VARID(2),'associates','station string40') - - IF (FLWW3.NE.0) THEN -! wwIII param version - IRET=NF90_DEF_VAR(NCID, 'WWIII_param_version', NF90_SHORT, (/DIMID(TWO),DIMID(ONE)/), VARID(3)) - CALL CHECK_ERR(IRET,28) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(3), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','WaveWatch III parameters version') - IRET=NF90_PUT_ATT(NCID,VARID(3),'standard_name','WWIII_param_version') - IRET=NF90_PUT_ATT(NCID,VARID(3),'globwave_name','WWIII_param_version') - IRET=NF90_PUT_ATT(NCID,VARID(3),'units','-') - IRET=NF90_PUT_ATT(NCID,VARID(3),'scale_factor',1) - IRET=NF90_PUT_ATT(NCID,VARID(3),'add_offset',0) - IRET=NF90_PUT_ATT(NCID,VARID(3),'valid_min',1) - IRET=NF90_PUT_ATT(NCID,VARID(3),'valid_max',999) - IRET=NF90_PUT_ATT(NCID,VARID(3),'_FillValue',NF90_FILL_SHORT) - IRET=NF90_PUT_ATT(NCID,VARID(3),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(3),'associates','time station') + !f/fp + IRET=NF90_DEF_VAR(NCID, 'ffp', NF90_FLOAT, (/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(11)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','ffp') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','ffp') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','ffp') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','1') + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station frequency') + !F + IRET=NF90_DEF_VAR(NCID, 'f', NF90_FLOAT, (/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(12)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(22), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','f') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','f') + IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','f') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','-') + IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station frequency') + !th1m + IRET=NF90_DEF_VAR(NCID, 'th1m', NF90_FLOAT, (/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(13)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','mean wave direction from spectral moments') + IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','mean_wave_direction') + IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','mean_wave_direction') + IRET=NF90_PUT_ATT(NCID,VARID(13),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequency') +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','Rotated Pole Grid North') END IF +#endif - IF (FLAGLL) THEN -! longitude - IRET=NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, (/DIMID(TWO),DIMID(ONE)/), VARID(4)) - CALL CHECK_ERR(IRET,29) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(4), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(4),'long_name','longitude') - IRET=NF90_PUT_ATT(NCID,VARID(4),'standard_name','longitude') - IRET=NF90_PUT_ATT(NCID,VARID(4),'globwave_name','longitude') - IRET=NF90_PUT_ATT(NCID,VARID(4),'units','degree_east') - IRET=NF90_PUT_ATT(NCID,VARID(4),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_min',-180.0) - IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(4),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(4),'associates','time station') - -! latitude - IRET=NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, (/DIMID(TWO),DIMID(ONE)/), VARID(5)) - CALL CHECK_ERR(IRET,30) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(5), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(5),'long_name','latitude') - IRET=NF90_PUT_ATT(NCID,VARID(5),'standard_name','latitude') - IRET=NF90_PUT_ATT(NCID,VARID(5),'globwave_name','latitude') - IRET=NF90_PUT_ATT(NCID,VARID(5),'units','degree_north') - IRET=NF90_PUT_ATT(NCID,VARID(5),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_min',-90.0) - IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_max',180.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(5),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(5),'associates','time station') - - + !sth1m + IRET=NF90_DEF_VAR(NCID, 'sth1m', NF90_FLOAT,(/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(14)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','directional spread from spectral moments') + IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','mean_wave_spreading') + IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','mean_wave_spreading') + IRET=NF90_PUT_ATT(NCID,VARID(14),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station frequency') + !alpha + IRET=NF90_DEF_VAR(NCID, 'alpha', NF90_FLOAT, (/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(15)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','spectral intensity coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','spectral_intensity_coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','spectral_intensity_coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(15),'units','-') + IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station frequency') + + + ! Add values in netCDF file + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,34) + IRET=NF90_PUT_VAR(NCID,VARID(6),FREQ(1:NK)) + CALL CHECK_ERR(IRET,35) + + + ! + ! ... ITYPE = 1 AND OTYPE = 3 + ! + + ELSE IF (ITYPE.EQ.1 .AND. OTYPE.EQ.3) THEN + ! + ! Define specifics dimensions + ! + IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(4), DIMID(4)) + CALL CHECK_ERR(IRET,36) + IRET = NF90_DEF_DIM(NCID, 'direction', DIMLN(5), DIMID(5)) + CALL CHECK_ERR(IRET,37) + + ! + ! define specifics variables + ! + + !frequency + IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, (/DIMID(4)/), VARID(6)) + CALL CHECK_ERR(IRET,38) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','frequency of center band') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','frequency') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') + + !frequency1 + IRET=NF90_DEF_VAR(NCID, 'frequency1', NF90_FLOAT, (/DIMID(4)/), VARID(7)) + CALL CHECK_ERR(IRET,39) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','frequency of lower band') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','frequency_of_lower_band') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','frequency_lower_band') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','Y') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','frequency') + + !frequency2 + IRET=NF90_DEF_VAR(NCID, 'frequency2', NF90_FLOAT, (/DIMID(4)/), VARID(8)) + CALL CHECK_ERR(IRET,40) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','frequency of upper band') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','frequency_of_upper_band') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','frequency_upper_band') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','Y') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','frequency') + + !direction + IRET=NF90_DEF_VAR(NCID, 'direction', NF90_FLOAT, (/DIMID(5)/), VARID(9)) + CALL CHECK_ERR(IRET,41) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','sea surface wave to direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','sea_surface_wave_to_direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'axis','Z') +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') ELSE -! longitude - IRET=NF90_DEF_VAR(NCID, 'x', NF90_FLOAT, (/DIMID(TWO),DIMID(ONE)/), VARID(4)) - CALL CHECK_ERR(IRET,31) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(4), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(4),'long_name','x') - IRET=NF90_PUT_ATT(NCID,VARID(4),'standard_name','x') - IRET=NF90_PUT_ATT(NCID,VARID(4),'globwave_name','x') - IRET=NF90_PUT_ATT(NCID,VARID(4),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(4),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_max',10000.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(4),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(4),'associates','time station') - - -! latitude - IRET=NF90_DEF_VAR(NCID, 'y', NF90_FLOAT, (/DIMID(TWO),DIMID(ONE)/), VARID(5)) - CALL CHECK_ERR(IRET,32) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(5), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(5),'long_name','y') - IRET=NF90_PUT_ATT(NCID,VARID(5),'standard_name','y') - IRET=NF90_PUT_ATT(NCID,VARID(5),'globwave_name','y') - IRET=NF90_PUT_ATT(NCID,VARID(5),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(5),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_max',10000.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(5),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(5),'associates','time station') - + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') END IF +#endif -! Process FREQ and DIR dimension values - FREQ(1:NK)=SIG(1:NK)*TPIINV - FREQ1(1:NK)=FREQ(1:NK)-0.5*(FREQ(1:NK)-(FREQ(1:NK)/XFR)) - FREQ2(1:NK)=FREQ(1:NK)+0.5*(-FREQ(1:NK)+(FREQ(1:NK)*XFR)) - FREQ1(1)=SIG(1)*TPIINV - FREQ2(NK)=SIG(NK)*TPIINV - DIR(1:NTH)=MOD(450-THD(1:NTH),360.) - -! -! ... ITYPE = 1 AND OTYPE = 2 -! - - IF (ITYPE.EQ.1 .AND. OTYPE.EQ.2) THEN -! -! Define specifics dimensions -! - IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(4), DIMID(4)) - CALL CHECK_ERR(IRET,33) - -! -! define specifics variables -! - -! frequency - IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, DIMID(4), VARID(6)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','frequency of center band') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','frequency') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') -!d - IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-100.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10000.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') -!Ust - IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','friction velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') -!U10 - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') -!Dir - IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','wind direction') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','degree') + !Efth + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_DEF_VAR(NCID,'efth',NF90_SHORT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(10)) + ELSE + IRET=NF90_DEF_VAR(NCID,'efth',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(10)) + END IF + CALL CHECK_ERR(IRET,42) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name',& + 'sea surface wave directional variance spectral density') + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name',& + 'base_ten_logarithm_of_sea_surface_wave_directional_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','directional_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','log10(m2 s rad-1 +1E-12)') + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',0.0004) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',1.E20) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_SHORT) + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name',& + 'sea_surface_wave_directional_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','directional_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m2 s rad-1') IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',1.E20) IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') + END IF + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TXYZ') + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequency direction') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') + END IF #endif - -!f/fp - IRET=NF90_DEF_VAR(NCID, 'ffp', NF90_FLOAT, (/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(11)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','ffp') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','ffp') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','ffp') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','1') + !d + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_SHORT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) + ELSE + IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) + END IF + CALL CHECK_ERR(IRET,43) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m') + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',0.5) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-200) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',200000) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_SHORT) + ELSE IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-100.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',10000.) IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station frequency') -!F - IRET=NF90_DEF_VAR(NCID, 'f', NF90_FLOAT, (/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(12)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(22), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','f') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','f') - IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','f') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','-') + END IF + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') + + !U10 + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_SHORT, (/ DIMID(TWO),DIMID(ONE) /), VARID(12)) + ELSE + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(12)) + END IF + CALL CHECK_ERR(IRET,44) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','m s-1') + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',0.1) + IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',1000) + IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_SHORT) + ELSE IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',100.) IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station frequency') -!th1m - IRET=NF90_DEF_VAR(NCID, 'th1m', NF90_FLOAT, (/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(13)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','mean wave direction from spectral moments') - IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','mean_wave_direction') - IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','mean_wave_direction') - IRET=NF90_PUT_ATT(NCID,VARID(13),'units','degree') + END IF + IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station') + !Dir + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_SHORT, (/ DIMID(TWO),DIMID(ONE) /), VARID(13)) + ELSE + IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(13)) + END IF + CALL CHECK_ERR(IRET,45) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','wind direction') + IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(13),'units','degree') + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',0.1) + IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',3600) + IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_SHORT) + ELSE IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0.) IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',360.) IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequency') + END IF + IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','Rotated Pole Grid North') + END IF #endif -!sth1m - IRET=NF90_DEF_VAR(NCID, 'sth1m', NF90_FLOAT,(/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(14)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','directional spread from spectral moments') - IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','mean_wave_spreading') - IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','mean_wave_spreading') - IRET=NF90_PUT_ATT(NCID,VARID(14),'units','degree') + !Uc + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_DEF_VAR(NCID, 'cur', NF90_SHORT, (/ DIMID(TWO),DIMID(ONE) /), VARID(14)) + ELSE + IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(14)) + END IF + CALL CHECK_ERR(IRET,46) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','sea water speed') + IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','sea_water_speed') + IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','sea_water_speed') + IRET=NF90_PUT_ATT(NCID,VARID(14),'units','m s-1') + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',0.1) + IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',0) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',1000) + IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_SHORT) + ELSE IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',100.) IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station frequency') -!alpha - IRET=NF90_DEF_VAR(NCID, 'alpha', NF90_FLOAT, (/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(15)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','spectral intensity coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','spectral_intensity_coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','spectral_intensity_coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(15),'units','-') + END IF + IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station') + + !Dir + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_SHORT, (/ DIMID(TWO),DIMID(ONE) /), VARID(15)) + ELSE + IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(15)) + END IF + CALL CHECK_ERR(IRET,47) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','direction from of sea water velocity') + IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','direction_of_sea_water_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','direction_of_sea_water_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(15),'units','degree') + IF (NCVARTYPE.LE.3) THEN + IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',0.1) + IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',0) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',3600) + IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_SHORT) + ELSE IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',360.) IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station frequency') - - - ! Add values in netCDF file - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,34) - IRET=NF90_PUT_VAR(NCID,VARID(6),FREQ(1:NK)) - CALL CHECK_ERR(IRET,35) - - -! -! ... ITYPE = 1 AND OTYPE = 3 -! - - ELSE IF (ITYPE.EQ.1 .AND. OTYPE.EQ.3) THEN -! -! Define specifics dimensions -! - IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(4), DIMID(4)) - CALL CHECK_ERR(IRET,36) - IRET = NF90_DEF_DIM(NCID, 'direction', DIMLN(5), DIMID(5)) - CALL CHECK_ERR(IRET,37) - -! -! define specifics variables -! - -!frequency - IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, (/DIMID(4)/), VARID(6)) - CALL CHECK_ERR(IRET,38) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','frequency of center band') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','frequency') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') - -!frequency1 - IRET=NF90_DEF_VAR(NCID, 'frequency1', NF90_FLOAT, (/DIMID(4)/), VARID(7)) - CALL CHECK_ERR(IRET,39) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','frequency of lower band') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','frequency_of_lower_band') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','frequency_lower_band') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','Y') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','frequency') - -!frequency2 - IRET=NF90_DEF_VAR(NCID, 'frequency2', NF90_FLOAT, (/DIMID(4)/), VARID(8)) - CALL CHECK_ERR(IRET,40) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','frequency of upper band') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','frequency_of_upper_band') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','frequency_upper_band') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','Y') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','frequency') - -!direction - IRET=NF90_DEF_VAR(NCID, 'direction', NF90_FLOAT, (/DIMID(5)/), VARID(9)) - CALL CHECK_ERR(IRET,41) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','sea surface wave to direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','sea_surface_wave_to_direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'axis','Z') -#ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') - END IF -#endif - -!Efth - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_DEF_VAR(NCID,'efth',NF90_SHORT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(10)) - ELSE - IRET=NF90_DEF_VAR(NCID,'efth',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(10)) - END IF - CALL CHECK_ERR(IRET,42) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name',& - 'sea surface wave directional variance spectral density') - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name',& - 'base_ten_logarithm_of_sea_surface_wave_directional_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','directional_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','log10(m2 s rad-1 +1E-12)') - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',0.0004) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',1.E20) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_SHORT) - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name',& - 'sea_surface_wave_directional_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','directional_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m2 s rad-1') - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',1.E20) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) - END IF - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TXYZ') - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequency direction') -#ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') - END IF -#endif - -!d - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_SHORT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) - ELSE - IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) - END IF - CALL CHECK_ERR(IRET,43) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m') - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',0.5) - IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-200) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',200000) - IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_SHORT) - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-100.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',10000.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) - END IF - IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') - -!U10 - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_SHORT, (/ DIMID(TWO),DIMID(ONE) /), VARID(12)) - ELSE - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(12)) - END IF - CALL CHECK_ERR(IRET,44) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','m s-1') - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',0.1) - IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',1000) - IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_SHORT) - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) - END IF - IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station') -!Dir - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_SHORT, (/ DIMID(TWO),DIMID(ONE) /), VARID(13)) - ELSE - IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(13)) - END IF - CALL CHECK_ERR(IRET,45) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','wind direction') - IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(13),'units','degree') - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',0.1) - IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',3600) - IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_SHORT) - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) - END IF - IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station') -#ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','Rotated Pole Grid North') - END IF -#endif - -!Uc - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_DEF_VAR(NCID, 'cur', NF90_SHORT, (/ DIMID(TWO),DIMID(ONE) /), VARID(14)) - ELSE - IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(14)) - END IF - CALL CHECK_ERR(IRET,46) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','sea water speed') - IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','sea_water_speed') - IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','sea_water_speed') - IRET=NF90_PUT_ATT(NCID,VARID(14),'units','m s-1') - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',0.1) - IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',0) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',1000) - IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_SHORT) - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_FLOAT) - END IF - IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station') - -!Dir - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_SHORT, (/ DIMID(TWO),DIMID(ONE) /), VARID(15)) - ELSE - IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(15)) - END IF - CALL CHECK_ERR(IRET,47) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','direction from of sea water velocity') - IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','direction_of_sea_water_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','direction_of_sea_water_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(15),'units','degree') - IF (NCVARTYPE.LE.3) THEN - IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',0.1) - IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',0) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',3600) - IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_SHORT) - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_FLOAT) - END IF - IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station') + END IF + IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','Rotated Pole Grid North') + END IF #endif - ! Add values in netCDF file - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,48) - IRET=NF90_PUT_VAR(NCID,VARID(6),FREQ(1:NK)) - CALL CHECK_ERR(IRET,49) - IRET=NF90_PUT_VAR(NCID,VARID(7),FREQ1(1:NK)) - CALL CHECK_ERR(IRET,50) - IRET=NF90_PUT_VAR(NCID,VARID(8),FREQ2(1:NK)) - CALL CHECK_ERR(IRET,51) - IRET=NF90_PUT_VAR(NCID,VARID(9),DIR(1:NTH)) - CALL CHECK_ERR(IRET,52) - - - - -! -! ... ITYPE = 1 AND OTYPE = 4 -! - - ELSE IF (ITYPE.EQ.1 .AND. OTYPE.EQ.4) THEN -! -! Define specifics dimensions -! - IRET = NF90_DEF_DIM(NCID, 'npart', DIMLN(4), DIMID(4)) - CALL CHECK_ERR(IRET,53) - -! -! define specifics variables -! - -!npart - IRET=NF90_DEF_VAR(NCID, 'npart', NF90_INT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','npart') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','npart') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','npart') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','1') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_INT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') -!d - IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-100.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10000.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') -!U10 - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') -!Dir - IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','wind direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') + ! Add values in netCDF file + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,48) + IRET=NF90_PUT_VAR(NCID,VARID(6),FREQ(1:NK)) + CALL CHECK_ERR(IRET,49) + IRET=NF90_PUT_VAR(NCID,VARID(7),FREQ1(1:NK)) + CALL CHECK_ERR(IRET,50) + IRET=NF90_PUT_VAR(NCID,VARID(8),FREQ2(1:NK)) + CALL CHECK_ERR(IRET,51) + IRET=NF90_PUT_VAR(NCID,VARID(9),DIR(1:NTH)) + CALL CHECK_ERR(IRET,52) + + + + + ! + ! ... ITYPE = 1 AND OTYPE = 4 + ! + + ELSE IF (ITYPE.EQ.1 .AND. OTYPE.EQ.4) THEN + ! + ! Define specifics dimensions + ! + IRET = NF90_DEF_DIM(NCID, 'npart', DIMLN(4), DIMID(4)) + CALL CHECK_ERR(IRET,53) + + ! + ! define specifics variables + ! + + !npart + IRET=NF90_DEF_VAR(NCID, 'npart', NF90_INT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','npart') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','npart') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','npart') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','1') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_INT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') + !d + IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-100.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10000.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') + !U10 + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') + !Dir + IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','wind direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') + END IF #endif -!Uc - IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','sea water speed') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','sea_water_speed') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','sea_water_speed') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') -!Dir - IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name',' direction from of sea water velocity') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','direction_of_sea_water_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','direction_of_sea_water_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') + !Uc + IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','sea water speed') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','sea_water_speed') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','sea_water_speed') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') + !Dir + IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name',' direction from of sea water velocity') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','direction_of_sea_water_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','direction_of_sea_water_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(11),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(11),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(11),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(11),'direction_reference','Rotated Pole Grid North') + END IF #endif -!Hs - IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(12)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','spectral estimate of significant wave height') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','sea_surface_wave_significant_height') - IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','significant_wave_height') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station npart') -!Tp - IRET=NF90_DEF_VAR(NCID, 'tp', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(13)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','dominant_wave_period') - IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','dominant_wave_period') - IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','dominant_wave_period') - IRET=NF90_PUT_ATT(NCID,VARID(13),'units','s') - IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station npart') -!L - IRET=NF90_DEF_VAR(NCID, 'lp', NF90_FLOAT, (/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(14)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','peak wave length') - IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','peak_wave_length') - IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','peak_wave_length') - IRET=NF90_PUT_ATT(NCID,VARID(14),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station npart') -!th1m - IRET=NF90_DEF_VAR(NCID, 'th1m', NF90_FLOAT, (/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(15)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','mean wave direction from spectral moments') - IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','mean_wave_direction') - IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','mean_wave_direction') - IRET=NF90_PUT_ATT(NCID,VARID(15),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station npart') + !Hs + IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(12)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','spectral estimate of significant wave height') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','sea_surface_wave_significant_height') + IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','significant_wave_height') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station npart') + !Tp + IRET=NF90_DEF_VAR(NCID, 'tp', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(13)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','dominant_wave_period') + IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','dominant_wave_period') + IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','dominant_wave_period') + IRET=NF90_PUT_ATT(NCID,VARID(13),'units','s') + IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station npart') + !L + IRET=NF90_DEF_VAR(NCID, 'lp', NF90_FLOAT, (/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(14)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','peak wave length') + IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','peak_wave_length') + IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','peak_wave_length') + IRET=NF90_PUT_ATT(NCID,VARID(14),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station npart') + !th1m + IRET=NF90_DEF_VAR(NCID, 'th1m', NF90_FLOAT, (/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(15)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','mean wave direction from spectral moments') + IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','mean_wave_direction') + IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','mean_wave_direction') + IRET=NF90_PUT_ATT(NCID,VARID(15),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station npart') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','Rotated Pole Grid North') + END IF #endif -!sth1m - IRET=NF90_DEF_VAR(NCID, 'sth1m', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(16)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(16), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','directional spread from spectral moments') - IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','mean_wave_spreading') - IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','mean_wave_spreading') - IRET=NF90_PUT_ATT(NCID,VARID(16),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(16),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(16),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station npart') -!ws - IRET=NF90_DEF_VAR(NCID, 'ws', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(17)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(17), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(17),'long_name','wind sea fraction') - IRET=NF90_PUT_ATT(NCID,VARID(17),'standard_name','wind_sea_fraction') - IRET=NF90_PUT_ATT(NCID,VARID(17),'globwave_name','wind_sea_fraction') - IRET=NF90_PUT_ATT(NCID,VARID(17),'units','%') - IRET=NF90_PUT_ATT(NCID,VARID(17),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(17),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(17),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(17),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(17),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(17),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(17),'associates','time station npart') -!TM10 - IRET=nf90_def_var(ncid, 'tm10', NF90_FLOAT,(/dimid(4),dimid(2),dimid(1)/),varid(18)) - IF (NCTYPE.EQ.4) IRET=nf90_def_var_deflate(ncid, varid(18), 1, 1, deflate) - IRET=NF90_PUT_ATT(NCID,VARID(18),'long_name','mean wave period from spectral moments (-1,0)') - IRET=NF90_PUT_ATT(NCID,VARID(18),'standard_name','mean_wave_period_tm10') - IRET=NF90_PUT_ATT(NCID,VARID(18),'globwave_name','mean_wave_period_tm10') - IRET=NF90_PUT_ATT(NCID,VARID(18),'units','seconds') - IRET=NF90_PUT_ATT(NCID,VARID(18),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(18),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(18),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(18),'valid_max',30.) - IRET=NF90_PUT_ATT(NCID,VARID(18),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(18),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(18),'associates','time station npart') -!T01 - IRET=nf90_def_var(ncid, 't01', NF90_FLOAT,(/dimid(4),dimid(2),dimid(1)/),varid(19)) - IF (NCTYPE.EQ.4) IRET=nf90_def_var_deflate(ncid, varid(19), 1, 1, deflate) - IRET=NF90_PUT_ATT(NCID,VARID(19),'long_name','mean wave period from spectral moments (0,1)') - IRET=NF90_PUT_ATT(NCID,VARID(19),'standard_name','mean_wave_period_t01') - IRET=NF90_PUT_ATT(NCID,VARID(19),'globwave_name','mean_wave_period_t01') - IRET=NF90_PUT_ATT(NCID,VARID(19),'units','seconds') - IRET=NF90_PUT_ATT(NCID,VARID(19),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(19),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(19),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(19),'valid_max',30.) - IRET=NF90_PUT_ATT(NCID,VARID(19),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(19),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(19),'associates','time station npart') -!T02 - IRET=nf90_def_var(ncid, 't02', NF90_FLOAT,(/dimid(4),dimid(2),dimid(1)/),varid(20)) - IF (NCTYPE.EQ.4) IRET=nf90_def_var_deflate(ncid, varid(20), 1, 1, deflate) - IRET=NF90_PUT_ATT(NCID,VARID(20),'long_name','mean wave period from spectral moments (0,2)') - IRET=NF90_PUT_ATT(NCID,VARID(20),'standard_name','mean_wave_period_t02') - IRET=NF90_PUT_ATT(NCID,VARID(20),'globwave_name','mean_wave_period_t02') - IRET=NF90_PUT_ATT(NCID,VARID(20),'units','seconds') - IRET=NF90_PUT_ATT(NCID,VARID(20),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(20),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_max',30.) - IRET=NF90_PUT_ATT(NCID,VARID(20),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(20),'content','TXY') - IRET=NF90_PUT_ATT(NCID,VARID(20),'associates','time station npart') - - ! NF90_ENDDEF function - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,54) - -! -! ... ITYPE = 2 AND OTYPE = 1 -! - - - ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.1) THEN -!d - IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',-100.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10000.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') - -!Uc - IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','sea water speed') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','sea_water_speed') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','sea_water_speed') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') -!Dir - IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','direction from of sea water velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','direction_of_sea_water_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','direction_of_sea_water_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') + !sth1m + IRET=NF90_DEF_VAR(NCID, 'sth1m', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(16)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(16), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','directional spread from spectral moments') + IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','mean_wave_spreading') + IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','mean_wave_spreading') + IRET=NF90_PUT_ATT(NCID,VARID(16),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(16),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(16),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station npart') + !ws + IRET=NF90_DEF_VAR(NCID, 'ws', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(17)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(17), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(17),'long_name','wind sea fraction') + IRET=NF90_PUT_ATT(NCID,VARID(17),'standard_name','wind_sea_fraction') + IRET=NF90_PUT_ATT(NCID,VARID(17),'globwave_name','wind_sea_fraction') + IRET=NF90_PUT_ATT(NCID,VARID(17),'units','%') + IRET=NF90_PUT_ATT(NCID,VARID(17),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(17),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(17),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(17),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(17),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(17),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(17),'associates','time station npart') + !TM10 + IRET=nf90_def_var(ncid, 'tm10', NF90_FLOAT,(/dimid(4),dimid(2),dimid(1)/),varid(18)) + IF (NCTYPE.EQ.4) IRET=nf90_def_var_deflate(ncid, varid(18), 1, 1, deflate) + IRET=NF90_PUT_ATT(NCID,VARID(18),'long_name','mean wave period from spectral moments (-1,0)') + IRET=NF90_PUT_ATT(NCID,VARID(18),'standard_name','mean_wave_period_tm10') + IRET=NF90_PUT_ATT(NCID,VARID(18),'globwave_name','mean_wave_period_tm10') + IRET=NF90_PUT_ATT(NCID,VARID(18),'units','seconds') + IRET=NF90_PUT_ATT(NCID,VARID(18),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(18),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(18),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(18),'valid_max',30.) + IRET=NF90_PUT_ATT(NCID,VARID(18),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(18),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(18),'associates','time station npart') + !T01 + IRET=nf90_def_var(ncid, 't01', NF90_FLOAT,(/dimid(4),dimid(2),dimid(1)/),varid(19)) + IF (NCTYPE.EQ.4) IRET=nf90_def_var_deflate(ncid, varid(19), 1, 1, deflate) + IRET=NF90_PUT_ATT(NCID,VARID(19),'long_name','mean wave period from spectral moments (0,1)') + IRET=NF90_PUT_ATT(NCID,VARID(19),'standard_name','mean_wave_period_t01') + IRET=NF90_PUT_ATT(NCID,VARID(19),'globwave_name','mean_wave_period_t01') + IRET=NF90_PUT_ATT(NCID,VARID(19),'units','seconds') + IRET=NF90_PUT_ATT(NCID,VARID(19),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(19),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(19),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(19),'valid_max',30.) + IRET=NF90_PUT_ATT(NCID,VARID(19),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(19),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(19),'associates','time station npart') + !T02 + IRET=nf90_def_var(ncid, 't02', NF90_FLOAT,(/dimid(4),dimid(2),dimid(1)/),varid(20)) + IF (NCTYPE.EQ.4) IRET=nf90_def_var_deflate(ncid, varid(20), 1, 1, deflate) + IRET=NF90_PUT_ATT(NCID,VARID(20),'long_name','mean wave period from spectral moments (0,2)') + IRET=NF90_PUT_ATT(NCID,VARID(20),'standard_name','mean_wave_period_t02') + IRET=NF90_PUT_ATT(NCID,VARID(20),'globwave_name','mean_wave_period_t02') + IRET=NF90_PUT_ATT(NCID,VARID(20),'units','seconds') + IRET=NF90_PUT_ATT(NCID,VARID(20),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(20),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_max',30.) + IRET=NF90_PUT_ATT(NCID,VARID(20),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(20),'content','TXY') + IRET=NF90_PUT_ATT(NCID,VARID(20),'associates','time station npart') + + ! NF90_ENDDEF function + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,54) + + ! + ! ... ITYPE = 2 AND OTYPE = 1 + ! + + + ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.1) THEN + !d + IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',-100.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10000.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') + + !Uc + IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','sea water speed') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','sea_water_speed') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','sea_water_speed') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') + !Dir + IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','direction from of sea water velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','direction_of_sea_water_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','direction_of_sea_water_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(8),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(8),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(8),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(8),'direction_reference','Rotated Pole Grid North') + END IF #endif -!U10 - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') -!Dir - IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','wind direction') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') + !U10 + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') + !Dir + IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','wind direction') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') + END IF #endif -!zeta_setup + !zeta_setup #ifdef W3_SETUP - IRET=NF90_DEF_VAR(NCID, 'wave_setup', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','wave setup') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','wave_induced_setup') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','wave_induced_setup') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-100.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') -#endif - - ! NF90_ENDDEF function - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,55) - -! -! ... ITYPE = 2 AND OTYPE = 2 -! - - ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.2) THEN -!Hs - IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','spectral estimate of significant wave height') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_significant_height') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','significant_wave_height') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') -!L - IRET=NF90_DEF_VAR(NCID, 'lm', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','mean wave length') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','mean_wave_length') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','mean_wave_length') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') -!Tr - IRET=NF90_DEF_VAR(NCID, 'tr', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','mean period normalised by the relative frequency') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','mean_period_normalised_by_the_relative_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','mean period normalised by the relative frequency') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','s') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') -!th1p - IRET=NF90_DEF_VAR(NCID, 'th1p', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','mean wave direction from spectral moments at spectral peak') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','dominant_wave_direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','dominant_wave_direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') + IRET=NF90_DEF_VAR(NCID, 'wave_setup', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','wave setup') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','wave_induced_setup') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','wave_induced_setup') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-100.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') +#endif + + ! NF90_ENDDEF function + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,55) + + ! + ! ... ITYPE = 2 AND OTYPE = 2 + ! + + ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.2) THEN + !Hs + IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','spectral estimate of significant wave height') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_significant_height') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','significant_wave_height') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') + !L + IRET=NF90_DEF_VAR(NCID, 'lm', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','mean wave length') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','mean_wave_length') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','mean_wave_length') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') + !Tr + IRET=NF90_DEF_VAR(NCID, 'tr', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','mean period normalised by the relative frequency') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','mean_period_normalised_by_the_relative_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','mean period normalised by the relative frequency') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','s') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') + !th1p + IRET=NF90_DEF_VAR(NCID, 'th1p', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','mean wave direction from spectral moments at spectral peak') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','dominant_wave_direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','dominant_wave_direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') + END IF #endif -!sth1p - IRET=NF90_DEF_VAR(NCID, 'sth1p', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','directional spread at spectral peak') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','dominant_wave_spreading') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','dominant_wave_spreading') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') -!fp - IRET=NF90_DEF_VAR(NCID, 'fp', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name',' peak frequency (Fp=1/Tp)') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','dominant_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','dominant_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') -!th1m - IRET=NF90_DEF_VAR(NCID, 'th1m', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(12)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','mean wave direction from spectral moments') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','mean_wave_direction') - IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','mean_wave_direction') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station') + !sth1p + IRET=NF90_DEF_VAR(NCID, 'sth1p', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','directional spread at spectral peak') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','dominant_wave_spreading') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','dominant_wave_spreading') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') + !fp + IRET=NF90_DEF_VAR(NCID, 'fp', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name',' peak frequency (Fp=1/Tp)') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','dominant_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','dominant_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') + !th1m + IRET=NF90_DEF_VAR(NCID, 'th1m', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(12)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','mean wave direction from spectral moments') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','mean_wave_direction') + IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','mean_wave_direction') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','Rotated Pole Grid North') + END IF #endif -!sth1m - IRET=NF90_DEF_VAR(NCID, 'sth1m', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(13)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','directional spread from spectral moments') - IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','mean_wave_spreading') - IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','mean_wave_spreading') - IRET=NF90_PUT_ATT(NCID,VARID(13),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station') - - ! NF90_ENDDEF function - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,56) - - -! -! ... ITYPE = 2 AND OTYPE = 3 -! - - ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.3) THEN -!Ust - IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','friction velocity') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') -!Efst - IRET=NF90_DEF_VAR(NCID, 'efst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name', & - 'nondimensionalized using surface elevation variance spectrum') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','sea_surface_wave_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','-') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') + !sth1m + IRET=NF90_DEF_VAR(NCID, 'sth1m', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(13)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','directional spread from spectral moments') + IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','mean_wave_spreading') + IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','mean_wave_spreading') + IRET=NF90_PUT_ATT(NCID,VARID(13),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station') + + ! NF90_ENDDEF function + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,56) + + + ! + ! ... ITYPE = 2 AND OTYPE = 3 + ! + + ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.3) THEN + !Ust + IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','friction velocity') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') + !Efst + IRET=NF90_DEF_VAR(NCID, 'efst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name', & + 'nondimensionalized using surface elevation variance spectrum') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','sea_surface_wave_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','-') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') + END IF #endif -!fpst - IRET=NF90_DEF_VAR(NCID, 'fpst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','nondimensionalized using peak frequency (Fp=1/Tp)') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','dominant_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','dominant_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','-') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') -!Cd - IRET=NF90_DEF_VAR(NCID, 'cd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','drag coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','drag_coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','drag_coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','*1000') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') -!alpha - IRET=NF90_DEF_VAR(NCID, 'alpha', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','alpha') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','alpha') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','alpha') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','*100') - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') - - - ! NF90_ENDDEF function - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,57) - - -! -! ... ITYPE = 2 AND OTYPE = 4 -! - - ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.4) THEN -!U10 - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') -!Efst - IRET=NF90_DEF_VAR(NCID, 'efst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name', & - 'nondimensionalized using surface elevation variance spectrum') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','sea_surface_wave_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','-') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') + !fpst + IRET=NF90_DEF_VAR(NCID, 'fpst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','nondimensionalized using peak frequency (Fp=1/Tp)') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','dominant_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','dominant_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','-') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') + !Cd + IRET=NF90_DEF_VAR(NCID, 'cd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','drag coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','drag_coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','drag_coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','*1000') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') + !alpha + IRET=NF90_DEF_VAR(NCID, 'alpha', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','alpha') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','alpha') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','alpha') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','*100') + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') + + + ! NF90_ENDDEF function + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,57) + + + ! + ! ... ITYPE = 2 AND OTYPE = 4 + ! + + ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.4) THEN + !U10 + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') + !Efst + IRET=NF90_DEF_VAR(NCID, 'efst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name', & + 'nondimensionalized using surface elevation variance spectrum') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','sea_surface_wave_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','-') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') + END IF #endif -!fpst - IRET=NF90_DEF_VAR(NCID, 'fpst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name', & - 'nondimensionalized using peak frequency (Fp=1/Tp)') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','dominant_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','dominant_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','-') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') -!Cd - IRET=NF90_DEF_VAR(NCID, 'cd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','drag coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','drag_coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','drag_coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','*1000') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') -!alpha - IRET=NF90_DEF_VAR(NCID, 'alpha', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','spectral intensity coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','spectral_intensity_coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','spectral_intensity_coefficient') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','*100') - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') - - ! NF90_ENDDEF function - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,58) - - -! -! ... ITYPE = 2 AND OTYPE = 5 -! - - ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.5) THEN -!U10 - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') -!Dir - IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','wind direction') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') + !fpst + IRET=NF90_DEF_VAR(NCID, 'fpst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name', & + 'nondimensionalized using peak frequency (Fp=1/Tp)') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','dominant_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','dominant_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','-') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') + !Cd + IRET=NF90_DEF_VAR(NCID, 'cd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','drag coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','drag_coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','drag_coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','*1000') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') + !alpha + IRET=NF90_DEF_VAR(NCID, 'alpha', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','spectral intensity coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','spectral_intensity_coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','spectral_intensity_coefficient') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','*100') + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') + + ! NF90_ENDDEF function + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,58) + + + ! + ! ... ITYPE = 2 AND OTYPE = 5 + ! + + ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.5) THEN + !U10 + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') + !Dir + IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','wind direction') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') + END IF #endif -!Hs - IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','spectral estimate of significant wave height') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','sea_surface_wave_significant_height') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','significant_wave_height') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') -!Hsst - IRET=NF90_DEF_VAR(NCID, 'hsst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name', & - 'nondimensionalized using spectral estimate of significant wave height') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','sea_surface_wave_significant_height') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','significant_wave_height') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','-') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') -!cp/U - IRET=NF90_DEF_VAR(NCID, 'cpu', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','phase speed at peak frequency on friction velocity') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','peak_wave_age') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','peak_wave_age') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','-') - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') -!cm/U - IRET=NF90_DEF_VAR(NCID, 'cmu', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','phase speed at mean frequency on friction velocity') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','mean_wave_age') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','mean_wave_age') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','-') - IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') -!Dt - IRET=NF90_DEF_VAR(NCID, 'ast', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(12)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','air sea temperature difference') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','air_sea_temperature_difference') - IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','air_sea_temperature_difference') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station') - - - ! NF90_ENDDEF function - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,59) - - -! -! ... ITYPE = 2 AND OTYPE = 6 -! - - ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.6) THEN -!U10 - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') -!Dir - IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','wind direction') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') + !Hs + IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','spectral estimate of significant wave height') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','sea_surface_wave_significant_height') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','significant_wave_height') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') + !Hsst + IRET=NF90_DEF_VAR(NCID, 'hsst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name', & + 'nondimensionalized using spectral estimate of significant wave height') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','sea_surface_wave_significant_height') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','significant_wave_height') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','-') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') + !cp/U + IRET=NF90_DEF_VAR(NCID, 'cpu', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','phase speed at peak frequency on friction velocity') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','peak_wave_age') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','peak_wave_age') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','-') + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') + !cm/U + IRET=NF90_DEF_VAR(NCID, 'cmu', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','phase speed at mean frequency on friction velocity') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','mean_wave_age') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','mean_wave_age') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','-') + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') + !Dt + IRET=NF90_DEF_VAR(NCID, 'ast', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(12)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','air sea temperature difference') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','air_sea_temperature_difference') + IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','air_sea_temperature_difference') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station') + + + ! NF90_ENDDEF function + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,59) + + + ! + ! ... ITYPE = 2 AND OTYPE = 6 + ! + + ELSE IF (ITYPE.EQ.2 .AND. OTYPE.EQ.6) THEN + !U10 + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(6)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(6),'associates','time station') + !Dir + IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','wind direction') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') + END IF #endif -!Hs - IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','spectral estimate of significant wave height') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','sea_surface_wave_significant_height') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','significant_wave_height') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') -!Tp - IRET=NF90_DEF_VAR(NCID, 'tp', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','dominant wave period') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','dominant_wave_period') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','dominant_wave_period') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','s') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') - - ! NF90_ENDDEF function - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,60) - -! -! ... ITYPE = 3 AND OTYPE = 2 -! - ELSE IF (ITYPE.EQ.3 .AND. OTYPE.EQ.2) THEN -! -! Define specifics dimensions -! - IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(4), DIMID(4)) - CALL CHECK_ERR(IRET,61) - -! -! define specifics variables -! - -! frequency / frequencyst / ffp - IF (ISCALE.EQ.0) THEN - IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, DIMID(4), VARID(6)) - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_DEF_VAR(NCID, 'frequencyst', NF90_FLOAT, DIMID(4), VARID(6)) - ELSE - IRET=NF90_DEF_VAR(NCID, 'ffp', NF90_FLOAT, DIMID(4), VARID(6)) - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','frequency of center band') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','frequency') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') - -!d - IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-100.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10000.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') - -!Ust - IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','friction velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') - -!U10 - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') - -!Ef / Efst - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'ef', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(10)) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','surface elevation variance spectrum') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','sea_surface_wave_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m2 s') - ELSE - IRET=NF90_DEF_VAR(NCID, 'efst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(10)) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name', & - 'nondimensionalized using surface elevation variance spectrum') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','sea_surface_wave_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station ffp') - END IF + !Hs + IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','spectral estimate of significant wave height') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','sea_surface_wave_significant_height') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','significant_wave_height') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') + !Tp + IRET=NF90_DEF_VAR(NCID, 'tp', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','dominant wave period') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','dominant_wave_period') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','dominant_wave_period') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','s') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') + + ! NF90_ENDDEF function + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,60) + + ! + ! ... ITYPE = 3 AND OTYPE = 2 + ! + ELSE IF (ITYPE.EQ.3 .AND. OTYPE.EQ.2) THEN + ! + ! Define specifics dimensions + ! + IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(4), DIMID(4)) + CALL CHECK_ERR(IRET,61) + + ! + ! define specifics variables + ! + + ! frequency / frequencyst / ffp + IF (ISCALE.EQ.0) THEN + IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, DIMID(4), VARID(6)) + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_DEF_VAR(NCID, 'frequencyst', NF90_FLOAT, DIMID(4), VARID(6)) + ELSE + IRET=NF90_DEF_VAR(NCID, 'ffp', NF90_FLOAT, DIMID(4), VARID(6)) + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','frequency of center band') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','frequency') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') + + !d + IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-100.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10000.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') + + !Ust + IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','friction velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') + + !U10 + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') + + !Ef / Efst + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'ef', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(10)) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','surface elevation variance spectrum') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','sea_surface_wave_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m2 s') + ELSE + IRET=NF90_DEF_VAR(NCID, 'efst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(10)) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name', & + 'nondimensionalized using surface elevation variance spectrum') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','sea_surface_wave_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station ffp') + END IF -!Sin / Sinst - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'sin', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(11)) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','wind input source term') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','wind_input_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','wind_input_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'sinst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(11)) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name', & - 'nondimensionalized using wind input source term') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','wind_input_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','wind_input_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station ffp') - END IF + !Sin / Sinst + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'sin', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(11)) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','wind input source term') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','wind_input_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','wind_input_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'sinst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(11)) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name', & + 'nondimensionalized using wind input source term') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','wind_input_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','wind_input_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station ffp') + END IF -!Snl / Snlst - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'snl', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(12)) - IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','nonlinear 4 wave source term') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','nonlinear_4_wave_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','nonlinear_4_wave_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'snlst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(12)) - IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name', & - 'nondimensionalized using nonlinear 4 wave source term') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','nonlinear_4_wave_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','nonlinear_4_wave_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station ffp') - END IF + !Snl / Snlst + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'snl', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(12)) + IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','nonlinear 4 wave source term') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','nonlinear_4_wave_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','nonlinear_4_wave_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'snlst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(12)) + IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name', & + 'nondimensionalized using nonlinear 4 wave source term') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','nonlinear_4_wave_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','nonlinear_4_wave_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station ffp') + END IF -!Sds / Sdsst - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'sds', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(13)) - IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','wave breaking source term') - IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','wave_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','wave_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(13),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'sdsst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(13)) - IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name', & - 'nondimensionalized using wave breaking source term') - IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','wave_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','wave_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(13),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station ffp') - END IF + !Sds / Sdsst + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'sds', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(13)) + IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','wave breaking source term') + IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','wave_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','wave_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(13),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'sdsst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(13)) + IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name', & + 'nondimensionalized using wave breaking source term') + IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','wave_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','wave_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(13),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station ffp') + END IF -!Sbt / Sbtst - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'sbt', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(14)) - IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','depth induced breaking source term') - IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','depth_induced_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','depth_induced_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(14),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'sbtst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(14)) - IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name', & - 'nondimensionalized using depth induced breaking source term') - IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','depth_induced_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','depth_induced_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(14),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station ffp') - END IF + !Sbt / Sbtst + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'sbt', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(14)) + IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','depth induced breaking source term') + IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','depth_induced_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','depth_induced_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(14),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'sbtst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(14)) + IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name', & + 'nondimensionalized using depth induced breaking source term') + IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','depth_induced_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','depth_induced_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(14),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station ffp') + END IF -!Sice / Sicest - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'sice', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(15)) - IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','wave-ice interactions source term') - IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','wave_ice_interactions_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','wave_ice_interactions_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(15),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'sicest', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(15)) - IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','nondimensionalized using wave-ice interactions source term') - IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','wave_ice_interactions_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','wave_ice_interactions_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(15),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station ffp') - END IF + !Sice / Sicest + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'sice', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(15)) + IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','wave-ice interactions source term') + IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','wave_ice_interactions_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','wave_ice_interactions_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(15),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'sicest', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(15)) + IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','nondimensionalized using wave-ice interactions source term') + IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','wave_ice_interactions_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','wave_ice_interactions_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(15),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station ffp') + END IF -!Stot / Stotst - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'stot', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(16)) - IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','total source term') - IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','total_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','total_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(16),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'stotst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(16)) - IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','nondimensionalized using total source term') - IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','total_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','total_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(16),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(16), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(16),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(16),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station ffp') - END IF + !Stot / Stotst + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'stot', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(16)) + IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','total source term') + IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','total_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','total_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(16),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'stotst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(16)) + IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','nondimensionalized using total source term') + IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','total_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','total_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(16),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(16), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(16),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(16),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station ffp') + END IF -! Add values in netCDF file - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,62) - IRET=NF90_PUT_VAR(NCID,VARID(6),FREQ(1:NK)) - CALL CHECK_ERR(IRET,63) - - -! -! ... ITYPE = 3 AND OTYPE = 3 -! - ELSE IF (ITYPE.EQ.3 .AND. OTYPE.EQ.3) THEN -! -! Define specifics dimensions -! - IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(4), DIMID(4)) - CALL CHECK_ERR(IRET,64) - -! -! define specifics variables -! - -! frequency / frequencyst / ffp - IF (ISCALE.EQ.0) THEN - IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, DIMID(4), VARID(6)) - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_DEF_VAR(NCID, 'frequencyst', NF90_FLOAT, DIMID(4), VARID(6)) - ELSE - IRET=NF90_DEF_VAR(NCID, 'ffp', NF90_FLOAT, DIMID(4), VARID(6)) - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','frequency of center band') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','frequency') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') - -!d - IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-100.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10000.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') - -!Ust - IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','friction velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') - -!U10 - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') - -!Ef / Efst - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'ef', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(10)) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','surface elevation variance spectrum') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','sea_surface_wave_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m2 s') - ELSE - IRET=NF90_DEF_VAR(NCID, 'efst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(10)) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name', & - 'nondimensionalized using surface elevation variance spectrum') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','sea_surface_wave_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station ffp') - END IF + ! Add values in netCDF file + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,62) + IRET=NF90_PUT_VAR(NCID,VARID(6),FREQ(1:NK)) + CALL CHECK_ERR(IRET,63) + + + ! + ! ... ITYPE = 3 AND OTYPE = 3 + ! + ELSE IF (ITYPE.EQ.3 .AND. OTYPE.EQ.3) THEN + ! + ! Define specifics dimensions + ! + IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(4), DIMID(4)) + CALL CHECK_ERR(IRET,64) + + ! + ! define specifics variables + ! + + ! frequency / frequencyst / ffp + IF (ISCALE.EQ.0) THEN + IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, DIMID(4), VARID(6)) + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_DEF_VAR(NCID, 'frequencyst', NF90_FLOAT, DIMID(4), VARID(6)) + ELSE + IRET=NF90_DEF_VAR(NCID, 'ffp', NF90_FLOAT, DIMID(4), VARID(6)) + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','frequency of center band') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','frequency') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') + + !d + IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-100.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10000.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') + + !Ust + IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','friction velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') + + !U10 + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') + + !Ef / Efst + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'ef', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(10)) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','surface elevation variance spectrum') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','sea_surface_wave_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m2 s') + ELSE + IRET=NF90_DEF_VAR(NCID, 'efst', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(10)) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name', & + 'nondimensionalized using surface elevation variance spectrum') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','sea_surface_wave_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station ffp') + END IF -!Tini / Tinist - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'tini', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(11)) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','wind input source term normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','inverse_time_scales_wind_input_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','inverse_time_scales_wind_input_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'tinist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(11)) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','nondimensionalized using wind input source term normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','inverse_time_scales_wind_input_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','inverse_time_scales_wind_input_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station ffp') - END IF + !Tini / Tinist + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'tini', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(11)) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','wind input source term normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','inverse_time_scales_wind_input_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','inverse_time_scales_wind_input_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'tinist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(11)) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','nondimensionalized using wind input source term normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','inverse_time_scales_wind_input_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','inverse_time_scales_wind_input_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station ffp') + END IF -!Tnli / Tnlist - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'tnli', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(12)) - IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','nonlinear 4 wave source term normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','inverse_time_scales_nonlinear_4_wave_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','inverse_time_scales_nonlinear_4_wave_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'tnlist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(12)) - IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','nondimensionalized using nonlinear 4 wave source term normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','inverse_time_scales_nonlinear_4_wave_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','inverse_time_scales_nonlinear_4_wave_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station ffp') - END IF + !Tnli / Tnlist + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'tnli', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(12)) + IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','nonlinear 4 wave source term normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','inverse_time_scales_nonlinear_4_wave_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','inverse_time_scales_nonlinear_4_wave_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'tnlist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(12)) + IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','nondimensionalized using nonlinear 4 wave source term normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','inverse_time_scales_nonlinear_4_wave_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','inverse_time_scales_nonlinear_4_wave_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station ffp') + END IF -!Tdsi / Tdsist - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'tdsi', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(13)) - IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','wave breaking source term normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','inverse_time_scales_wave_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','inverse_time_scales_wave_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(13),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'tdsist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(13)) - IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','nondimensionalized using wave breaking source term normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','inverse_time_scales_wave_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','inverse_time_scales_wave_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(13),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station ffp') - END IF + !Tdsi / Tdsist + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'tdsi', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(13)) + IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','wave breaking source term normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','inverse_time_scales_wave_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','inverse_time_scales_wave_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(13),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'tdsist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(13)) + IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','nondimensionalized using wave breaking source term normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','inverse_time_scales_wave_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','inverse_time_scales_wave_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(13),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station ffp') + END IF -!Tbti / Tbtist - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'tbti', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(14)) - IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','depth induced breaking source term normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','inverse_time_scales_depth_induced_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','inverse_time_scales_depth_induced_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(14),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'tbtist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(14)) - IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','nondimensionalized using depth induced breaking source term & - normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','inverse_time_scales_depth_induced_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','inverse_time_scales_depth_induced_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(14),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station ffp') - END IF + !Tbti / Tbtist + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'tbti', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(14)) + IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','depth induced breaking source term normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','inverse_time_scales_depth_induced_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','inverse_time_scales_depth_induced_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(14),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'tbtist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(14)) + IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','nondimensionalized using depth induced breaking source term & + normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','inverse_time_scales_depth_induced_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','inverse_time_scales_depth_induced_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(14),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station ffp') + END IF -!Ticei / Ticeist - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'ticei', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(15)) - IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','wave ice interactions source term normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','inverse_time_scales_wave_ice_interactions_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','inverse_time_scales_wave_ice_interactions_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(15),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'ticeist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(15)) - IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','nondimensionalized using wave ice interactions source term & - normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','inverse_time_scales_wave_ice_interactions_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','inverse_time_scales_wave_ice_interactions_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(15),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station ffp') - END IF + !Ticei / Ticeist + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'ticei', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(15)) + IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','wave ice interactions source term normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','inverse_time_scales_wave_ice_interactions_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','inverse_time_scales_wave_ice_interactions_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(15),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'ticeist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(15)) + IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','nondimensionalized using wave ice interactions source term & + normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','inverse_time_scales_wave_ice_interactions_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','inverse_time_scales_wave_ice_interactions_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(15),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station ffp') + END IF -!Ttoti / Ttotist - IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN - IRET=NF90_DEF_VAR(NCID, 'ttoti', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(16)) - IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','total source term normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','inverse_time_scales_total_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','inverse_time_scales_total_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(16),'units','m2') - ELSE - IRET=NF90_DEF_VAR(NCID, 'ttotist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(16)) - IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','nondimensionalized using total source term normalised by Ef') - IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','inverse_time_scales_total_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','inverse_time_scales_total_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(16),'units','-') - END IF - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(16), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(16),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue', NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(16),'content','TXY') - IF (ISCALE.EQ.0) THEN - IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequency') - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequencyst') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station ffp') - END IF + !Ttoti / Ttotist + IF (ISCALE.EQ.0 .OR. ISCALE.EQ.3) THEN + IRET=NF90_DEF_VAR(NCID, 'ttoti', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(16)) + IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','total source term normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','inverse_time_scales_total_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','inverse_time_scales_total_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(16),'units','m2') + ELSE + IRET=NF90_DEF_VAR(NCID, 'ttotist', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/), VARID(16)) + IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','nondimensionalized using total source term normalised by Ef') + IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','inverse_time_scales_total_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','inverse_time_scales_total_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(16),'units','-') + END IF + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(16), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(16),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue', NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(16),'content','TXY') + IF (ISCALE.EQ.0) THEN + IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequency') + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequencyst') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station ffp') + END IF -! Add values in netCDF file - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,65) - IRET=NF90_PUT_VAR(NCID,VARID(6),FREQ(1:NK)) - CALL CHECK_ERR(IRET,66) - - -! -! ... ITYPE = 3 AND OTYPE = 4 -! - ELSE IF (ITYPE.EQ.3 .AND. OTYPE.EQ.4) THEN -! -! Define specifics dimensions -! - IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(4), DIMID(4)) - IRET = NF90_DEF_DIM(NCID, 'direction', DIMLN(5), DIMID(5)) - CALL CHECK_ERR(IRET,67) - -! -! define specifics variables -! - -!frequency - IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, (/DIMID(4)/), VARID(6)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','frequency of center band') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_frequency') - IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','frequency') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') - -!frequency1 - IRET=NF90_DEF_VAR(NCID, 'frequency1', NF90_FLOAT, (/DIMID(4)/), VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','frequency of lower band') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','frequency_of_lower_band') - IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','frequency_lower_band') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','Y') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','frequency') - -!frequency2 - IRET=NF90_DEF_VAR(NCID, 'frequency2', NF90_FLOAT, (/DIMID(4)/), VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','frequency of upper band') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','frequency_of_upper_band') - IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','frequency_upper_band') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','Y') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','frequency') - - -!direction - IRET=NF90_DEF_VAR(NCID, 'direction', NF90_FLOAT, (/DIMID(5)/), VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','sea surface wave to direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','sea_surface_wave_to_direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','direction') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'axis','Z') + ! Add values in netCDF file + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,65) + IRET=NF90_PUT_VAR(NCID,VARID(6),FREQ(1:NK)) + CALL CHECK_ERR(IRET,66) + + + ! + ! ... ITYPE = 3 AND OTYPE = 4 + ! + ELSE IF (ITYPE.EQ.3 .AND. OTYPE.EQ.4) THEN + ! + ! Define specifics dimensions + ! + IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(4), DIMID(4)) + IRET = NF90_DEF_DIM(NCID, 'direction', DIMLN(5), DIMID(5)) + CALL CHECK_ERR(IRET,67) + + ! + ! define specifics variables + ! + + !frequency + IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, (/DIMID(4)/), VARID(6)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','frequency of center band') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_frequency') + IRET=NF90_PUT_ATT(NCID,VARID(6),'globwave_name','frequency') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Y') + + !frequency1 + IRET=NF90_DEF_VAR(NCID, 'frequency1', NF90_FLOAT, (/DIMID(4)/), VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','frequency of lower band') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','frequency_of_lower_band') + IRET=NF90_PUT_ATT(NCID,VARID(7),'globwave_name','frequency_lower_band') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(7),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','Y') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','frequency') + + !frequency2 + IRET=NF90_DEF_VAR(NCID, 'frequency2', NF90_FLOAT, (/DIMID(4)/), VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','frequency of upper band') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','frequency_of_upper_band') + IRET=NF90_PUT_ATT(NCID,VARID(8),'globwave_name','frequency_upper_band') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(8),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','Y') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','frequency') + + + !direction + IRET=NF90_DEF_VAR(NCID, 'direction', NF90_FLOAT, (/DIMID(5)/), VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name','sea surface wave to direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name','sea_surface_wave_to_direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name','direction') + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'axis','Z') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') + END IF #endif -!d - IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',-100.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',10000.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') - -!U10 - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') -!Dir - IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(12)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','wind direction') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station') + !d + IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_min',-100.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'valid_max',10000.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') + + !U10 + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') + !Dir + IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(12)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','wind direction') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','Rotated Pole Grid North') + END IF #endif -!Uc - IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(13)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','sea water speed') - IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','sea_water_speed') - IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','sea_water_speed') - IRET=NF90_PUT_ATT(NCID,VARID(13),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station') - -!Dir - IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(14)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','direction from of sea water velocity') - IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','direction_of_sea_water_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','direction_of_sea_water_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(14),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station') + !Uc + IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(13)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','sea water speed') + IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','sea_water_speed') + IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','sea_water_speed') + IRET=NF90_PUT_ATT(NCID,VARID(13),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station') + + !Dir + IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(14)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','direction from of sea water velocity') + IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','direction_of_sea_water_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','direction_of_sea_water_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(14),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(14),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(14),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(14),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(14),'direction_reference','Rotated Pole Grid North') + END IF #endif -!Ust - IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(15)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','friction velocity') - IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(15),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',100.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station') - -!Efth - IF ( PRESENT(FLSRCE) ) THEN - IF ( FLSRCE(1) ) THEN - IRET=NF90_DEF_VAR(NCID,'efth',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(16)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(16), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name',& - 'sea surface wave directional variance spectral density') - IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name',& - 'sea_surface_wave_directional_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','directional_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(16),'units','m2 s rad-1') - IRET=NF90_PUT_ATT(NCID,VARID(16),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_max',1.E20) - IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(16),'content','TXYZ') - IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequency direction') + !Ust + IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(15)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','friction velocity') + IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(15),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station') + + !Efth + IF ( PRESENT(FLSRCE) ) THEN + IF ( FLSRCE(1) ) THEN + IRET=NF90_DEF_VAR(NCID,'efth',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(16)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(16), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name',& + 'sea surface wave directional variance spectral density') + IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name',& + 'sea_surface_wave_directional_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','directional_variance_spectral_density') + IRET=NF90_PUT_ATT(NCID,VARID(16),'units','m2 s rad-1') + IRET=NF90_PUT_ATT(NCID,VARID(16),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'valid_max',1.E20) + IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(16),'content','TXYZ') + IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequency direction') #ifdef W3_RTD - IF ( FLAGUNR ) THEN - IRET=NF90_PUT_ATT(NCID,VARID(16),'direction_reference','True North') - ELSE - IRET=NF90_PUT_ATT(NCID,VARID(16),'direction_reference','Rotated Pole Grid North') - END IF + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(16),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(16),'direction_reference','Rotated Pole Grid North') + END IF #endif - ENDIF - -!Swn - IF ( FLSRCE(2) ) THEN - IRET=NF90_DEF_VAR(NCID,'sin',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(17)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(17), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(17),'long_name','wind input source term') - IRET=NF90_PUT_ATT(NCID,VARID(17),'standard_name','wind_input_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(17),'globwave_name','wind_input_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(17),'units','m2 rad-1') - IRET=NF90_PUT_ATT(NCID,VARID(17),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(17),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(17),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(17),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(17),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(17),'content','TXYZ') - IRET=NF90_PUT_ATT(NCID,VARID(17),'associates','time station frequency direction') -#ifdef W3_RTD - IRET=NF90_PUT_ATT(NCID,VARID(17),'direction_reference','Rotated Pole Grid North') -#endif - ENDIF - -!Snl - IF ( FLSRCE(3) ) THEN - IRET=NF90_DEF_VAR(NCID,'snl',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(18)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(18), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(18),'long_name','nonlinear 4 wave source term') - IRET=NF90_PUT_ATT(NCID,VARID(18),'standard_name','nonlinear_4_wave_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(18),'globwave_name','nonlinear_4_wave_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(18),'units','m2 rad-1') - IRET=NF90_PUT_ATT(NCID,VARID(18),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(18),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(18),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(18),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(18),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(18),'content','TXYZ') - IRET=NF90_PUT_ATT(NCID,VARID(18),'associates','time station frequency direction') -#ifdef W3_RTD - IRET=NF90_PUT_ATT(NCID,VARID(18),'direction_reference','Rotated Pole Grid North') -#endif - ENDIF - -!Sds - IF ( FLSRCE(4) ) THEN - IRET=NF90_DEF_VAR(NCID,'sds',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(19)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(19), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(19),'long_name','wave breaking source term') - IRET=NF90_PUT_ATT(NCID,VARID(19),'standard_name','wave_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(19),'globwave_name','wave_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(19),'units','m2 rad-1') - IRET=NF90_PUT_ATT(NCID,VARID(19),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(19),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(19),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(19),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(19),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(19),'content','TXYZ') - IRET=NF90_PUT_ATT(NCID,VARID(19),'associates','time station frequency direction') -#ifdef W3_RTD - IRET=NF90_PUT_ATT(NCID,VARID(19),'direction_reference','Rotated Pole Grid North') -#endif - ENDIF - -!Sbt - IF ( FLSRCE(5) ) THEN - IRET=NF90_DEF_VAR(NCID,'sbt',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(20)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(20), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(20),'long_name','depth induced breaking source term') - IRET=NF90_PUT_ATT(NCID,VARID(20),'standard_name','depth_induced_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(20),'globwave_name','depth_induced_breaking_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(20),'units','m2 rad-1') - IRET=NF90_PUT_ATT(NCID,VARID(20),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(20),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(20),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(20),'content','TXYZ') - IRET=NF90_PUT_ATT(NCID,VARID(20),'associates','time station frequency direction') -#ifdef W3_RTD - IRET=NF90_PUT_ATT(NCID,VARID(20),'direction_reference','Rotated Pole Grid North') -#endif - ENDIF - -!Sice - IF ( FLSRCE(6) ) THEN - IRET=NF90_DEF_VAR(NCID,'sice',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(21)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(21), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(21),'long_name','wave-ice interactions source term') - IRET=NF90_PUT_ATT(NCID,VARID(21),'standard_name','wave_ice_intercations_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(21),'globwave_name','wave_ice_intercations_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(21),'units','m2 rad-1') - IRET=NF90_PUT_ATT(NCID,VARID(21),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(21),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(21),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(21),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(21),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(21),'content','TXYZ') - IRET=NF90_PUT_ATT(NCID,VARID(21),'associates','time station frequency direction') -#ifdef W3_RTD - IRET=NF90_PUT_ATT(NCID,VARID(21),'direction_reference','Rotated Pole Grid North') -#endif - ENDIF - -!Stt - IF ( FLSRCE(7) ) THEN - IRET=NF90_DEF_VAR(NCID,'stt',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(22)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(22), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(22),'long_name','total source term') - IRET=NF90_PUT_ATT(NCID,VARID(22),'standard_name','total_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(22),'globwave_name','total_source_term') - IRET=NF90_PUT_ATT(NCID,VARID(22),'units','m2 rad-1') - IRET=NF90_PUT_ATT(NCID,VARID(22),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(22),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(22),'valid_min',-1.) - IRET=NF90_PUT_ATT(NCID,VARID(22),'valid_max',1.) - IRET=NF90_PUT_ATT(NCID,VARID(22),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(22),'content','TXYZ') - IRET=NF90_PUT_ATT(NCID,VARID(22),'associates','time station frequency direction') + ENDIF + + !Swn + IF ( FLSRCE(2) ) THEN + IRET=NF90_DEF_VAR(NCID,'sin',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(17)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(17), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(17),'long_name','wind input source term') + IRET=NF90_PUT_ATT(NCID,VARID(17),'standard_name','wind_input_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(17),'globwave_name','wind_input_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(17),'units','m2 rad-1') + IRET=NF90_PUT_ATT(NCID,VARID(17),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(17),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(17),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(17),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(17),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(17),'content','TXYZ') + IRET=NF90_PUT_ATT(NCID,VARID(17),'associates','time station frequency direction') #ifdef W3_RTD - IRET=NF90_PUT_ATT(NCID,VARID(22),'direction_reference','Rotated Pole Grid North') + IRET=NF90_PUT_ATT(NCID,VARID(17),'direction_reference','Rotated Pole Grid North') #endif - ENDIF ENDIF -! Add values in netCDF file - IRET=NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET,68) - IRET=NF90_PUT_VAR(NCID,VARID(6),FREQ(1:NK)) - CALL CHECK_ERR(IRET,69) - IRET=NF90_PUT_VAR(NCID,VARID(7),FREQ1(1:NK)) - CALL CHECK_ERR(IRET,70) - IRET=NF90_PUT_VAR(NCID,VARID(8),FREQ2(1:NK)) - CALL CHECK_ERR(IRET,71) - IRET=NF90_PUT_VAR(NCID,VARID(9),DIR(1:NTH)) - CALL CHECK_ERR(IRET,72) -! - END IF -! - RETURN - - END SUBROUTINE W3CRNC - -!============================================================================== -!> @brief Desc not available. -!> -!> @param IRET -!> @param ICODE -!> -!> @author NA @date NA - SUBROUTINE CHECK_ERR(IRET,ICODE) - - USE NETCDF - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - - IMPLICIT NONE - - INTEGER IRET, ICODE - - IF (IRET .NE. NF90_NOERR) THEN - WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN OUNP :' - WRITE(NDSE,*) ' NETCDF ERROR MESSAGE: ' - WRITE(NDSE,*) NF90_STRERROR(IRET) - WRITE(NDSE,*) ' ICODE: ' - WRITE(NDSE,*) ICODE - CALL EXTCDE ( ICODE ) - END IF - RETURN + !Snl + IF ( FLSRCE(3) ) THEN + IRET=NF90_DEF_VAR(NCID,'snl',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(18)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(18), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(18),'long_name','nonlinear 4 wave source term') + IRET=NF90_PUT_ATT(NCID,VARID(18),'standard_name','nonlinear_4_wave_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(18),'globwave_name','nonlinear_4_wave_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(18),'units','m2 rad-1') + IRET=NF90_PUT_ATT(NCID,VARID(18),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(18),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(18),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(18),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(18),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(18),'content','TXYZ') + IRET=NF90_PUT_ATT(NCID,VARID(18),'associates','time station frequency direction') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(18),'direction_reference','Rotated Pole Grid North') +#endif + ENDIF - END SUBROUTINE CHECK_ERR + !Sds + IF ( FLSRCE(4) ) THEN + IRET=NF90_DEF_VAR(NCID,'sds',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(19)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(19), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(19),'long_name','wave breaking source term') + IRET=NF90_PUT_ATT(NCID,VARID(19),'standard_name','wave_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(19),'globwave_name','wave_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(19),'units','m2 rad-1') + IRET=NF90_PUT_ATT(NCID,VARID(19),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(19),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(19),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(19),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(19),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(19),'content','TXYZ') + IRET=NF90_PUT_ATT(NCID,VARID(19),'associates','time station frequency direction') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(19),'direction_reference','Rotated Pole Grid North') +#endif + ENDIF -!============================================================================== + !Sbt + IF ( FLSRCE(5) ) THEN + IRET=NF90_DEF_VAR(NCID,'sbt',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(20)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(20), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(20),'long_name','depth induced breaking source term') + IRET=NF90_PUT_ATT(NCID,VARID(20),'standard_name','depth_induced_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(20),'globwave_name','depth_induced_breaking_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(20),'units','m2 rad-1') + IRET=NF90_PUT_ATT(NCID,VARID(20),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(20),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(20),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(20),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(20),'content','TXYZ') + IRET=NF90_PUT_ATT(NCID,VARID(20),'associates','time station frequency direction') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(20),'direction_reference','Rotated Pole Grid North') +#endif + ENDIF + !Sice + IF ( FLSRCE(6) ) THEN + IRET=NF90_DEF_VAR(NCID,'sice',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(21)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(21), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(21),'long_name','wave-ice interactions source term') + IRET=NF90_PUT_ATT(NCID,VARID(21),'standard_name','wave_ice_intercations_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(21),'globwave_name','wave_ice_intercations_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(21),'units','m2 rad-1') + IRET=NF90_PUT_ATT(NCID,VARID(21),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(21),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(21),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(21),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(21),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(21),'content','TXYZ') + IRET=NF90_PUT_ATT(NCID,VARID(21),'associates','time station frequency direction') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(21),'direction_reference','Rotated Pole Grid North') +#endif + ENDIF -!/ -!/ End of W3OUNP ----------------------------------------------------- / -!/ - END PROGRAM W3OUNP + !Stt + IF ( FLSRCE(7) ) THEN + IRET=NF90_DEF_VAR(NCID,'stt',NF90_FLOAT,(/DIMID(5),DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(22)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(22), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(22),'long_name','total source term') + IRET=NF90_PUT_ATT(NCID,VARID(22),'standard_name','total_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(22),'globwave_name','total_source_term') + IRET=NF90_PUT_ATT(NCID,VARID(22),'units','m2 rad-1') + IRET=NF90_PUT_ATT(NCID,VARID(22),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(22),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(22),'valid_min',-1.) + IRET=NF90_PUT_ATT(NCID,VARID(22),'valid_max',1.) + IRET=NF90_PUT_ATT(NCID,VARID(22),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(22),'content','TXYZ') + IRET=NF90_PUT_ATT(NCID,VARID(22),'associates','time station frequency direction') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(22),'direction_reference','Rotated Pole Grid North') +#endif + ENDIF + ENDIF + + ! Add values in netCDF file + IRET=NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET,68) + IRET=NF90_PUT_VAR(NCID,VARID(6),FREQ(1:NK)) + CALL CHECK_ERR(IRET,69) + IRET=NF90_PUT_VAR(NCID,VARID(7),FREQ1(1:NK)) + CALL CHECK_ERR(IRET,70) + IRET=NF90_PUT_VAR(NCID,VARID(8),FREQ2(1:NK)) + CALL CHECK_ERR(IRET,71) + IRET=NF90_PUT_VAR(NCID,VARID(9),DIR(1:NTH)) + CALL CHECK_ERR(IRET,72) + ! + END IF + ! + RETURN + + END SUBROUTINE W3CRNC + + !============================================================================== + !> @brief Desc not available. + !> + !> @param IRET + !> @param ICODE + !> + !> @author NA @date NA + SUBROUTINE CHECK_ERR(IRET,ICODE) + + USE NETCDF + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + + IMPLICIT NONE + + INTEGER IRET, ICODE + + IF (IRET .NE. NF90_NOERR) THEN + WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN OUNP :' + WRITE(NDSE,*) ' NETCDF ERROR MESSAGE: ' + WRITE(NDSE,*) NF90_STRERROR(IRET) + WRITE(NDSE,*) ' ICODE: ' + WRITE(NDSE,*) ICODE + CALL EXTCDE ( ICODE ) + END IF + RETURN + + END SUBROUTINE CHECK_ERR + + !============================================================================== + + + !/ + !/ End of W3OUNP ----------------------------------------------------- / + !/ +END PROGRAM W3OUNP diff --git a/model/src/ww3_outf.F90 b/model/src/ww3_outf.F90 index ab73c11f7..d8970978a 100644 --- a/model/src/ww3_outf.F90 +++ b/model/src/ww3_outf.F90 @@ -1,2625 +1,2624 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - PROGRAM W3OUTF -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 19-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 24-Jan-2001 : Flat grid version ( version 2.06 ) -!/ 23-Apr-2002 : Clean-up ( version 2.19 ) -!/ 29-Apr-2002 : Adding output fields 17-18. ( version 2.20 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 21-Jul-2005 : Adding output fields 19-21. ( version 3.07 ) -!/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 28-Mar-2007 : Adding partitioned output. ( version 3.11 ) -!/ Adding user slots for outputs. -!/ 31-Jul-2007 : Fix file extension errors. ( version 3.12 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 12-Dec-2012 : SMC grid sea-point text output.JG_Li( version 4.08 ) -!/ 25-Dec-2012 : New structure of output fields. ( version 4.11 ) -!/ Minor bug fixes and clean up. -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 27-Aug-2015 : ICEH and ICEF added as output ( version 5.10 ) -!/ 12-Sep-2018 : Added new partitioned output fields ( version 6.06 ) -!/ 26-Jan-2021 : Added TP field (derived from FP0) ( version 7.12 ) -!/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Post-processing of grid output. -! -! 2. Method : -! -! Data is read from the grid output file out_grd.ww3 (raw data) -! and from the file ww3_outf.inp ( NDSI, output requests ). -! Model definition and raw data files are read using WAVEWATCH III -! subroutines. -! -! Output types : -! 1 : print plots -! 2 : field statistics -! 3 : transfer file -! 4 : text output at sea points (1:NSEA). -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W2NAUX Subr. W3ADATMD Set number of model for aux data. -! W3SETA Subr. Id. Point to selected model for aux data. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input file. -! EXTCDE Subr. Id. Abort program as graceful as possible. -! STME21 Subr. W3TIMEMD Convert time to string. -! TICK21 Subr. Id. Advance time. -! DSEC21 Func. Id. Difference between times. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. -! W3EXGO Subr. Internal Execute grid output. -! W3TXTS Subr. Internal Text output at sea points only. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! Checks on input, checks in W3IOxx. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ -! USE W3GDATMD, ONLY: W3NMOD, W3SETG - USE W3WDATMD, ONLY: W3NDAT, W3SETW - USE W3ADATMD, ONLY: W3NAUX, W3SETA - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE +PROGRAM W3OUTF + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 19-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 24-Jan-2001 : Flat grid version ( version 2.06 ) + !/ 23-Apr-2002 : Clean-up ( version 2.19 ) + !/ 29-Apr-2002 : Adding output fields 17-18. ( version 2.20 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 21-Jul-2005 : Adding output fields 19-21. ( version 3.07 ) + !/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 28-Mar-2007 : Adding partitioned output. ( version 3.11 ) + !/ Adding user slots for outputs. + !/ 31-Jul-2007 : Fix file extension errors. ( version 3.12 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 12-Dec-2012 : SMC grid sea-point text output.JG_Li( version 4.08 ) + !/ 25-Dec-2012 : New structure of output fields. ( version 4.11 ) + !/ Minor bug fixes and clean up. + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 27-Aug-2015 : ICEH and ICEF added as output ( version 5.10 ) + !/ 12-Sep-2018 : Added new partitioned output fields ( version 6.06 ) + !/ 26-Jan-2021 : Added TP field (derived from FP0) ( version 7.12 ) + !/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Post-processing of grid output. + ! + ! 2. Method : + ! + ! Data is read from the grid output file out_grd.ww3 (raw data) + ! and from the file ww3_outf.inp ( NDSI, output requests ). + ! Model definition and raw data files are read using WAVEWATCH III + ! subroutines. + ! + ! Output types : + ! 1 : print plots + ! 2 : field statistics + ! 3 : transfer file + ! 4 : text output at sea points (1:NSEA). + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W2NAUX Subr. W3ADATMD Set number of model for aux data. + ! W3SETA Subr. Id. Point to selected model for aux data. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input file. + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! TICK21 Subr. Id. Advance time. + ! DSEC21 Func. Id. Difference between times. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. + ! W3EXGO Subr. Internal Execute grid output. + ! W3TXTS Subr. Internal Text output at sea points only. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! Checks on input, checks in W3IOxx. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG + USE W3WDATMD, ONLY: W3NDAT, W3SETW + USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif - USE W3TIMEMD - USE W3IOGRMD, ONLY: W3IOGR - USE W3IOGOMD, ONLY: W3IOGO, W3READFLGRD -!/ - USE W3GDATMD - USE W3WDATMD, ONLY: TIME, WLV, ICE, ICEH, ICEF, BERG, UST, & - USTDIR, RHOAIR - USE W3ADATMD, ONLY: DW, UA, UD, AS, CX, CY, HS, WLM, T0M1, THM, & - THS, FP0, THP0, DTDYN, FCUT, & - ABA, ABD, UBA, UBD, SXX, SYY, SXY, USERO, & - PHS, PTP, PLP, PDIR, PSI, PWS, PWST, PNR, & - PTM1, PT1, PT2, PEP, TAUOCX, TAUOCY, & - PTHP0, PQP, PSW, PPE, PGW, QP, & - TAUOX, TAUOY, TAUWIX,BHD, & - TAUWIY, PHIAW, PHIOC, TUSX, TUSY, PRMS, TPMS,& - USSX, USSY, MSSX, MSSY, MSCX, MSCY, CHARN, & - TAUWNX, TAUWNY, TAUBBL, PHIBBL, CFLXYMAX, & - CFLTHMAX, CFLKMAX, BEDFORMS, WHITECAP, T02, & - CGE, T01, HSIG, STMAXE, STMAXD, HMAXE, & - HCMAXE, HMAXD, HCMAXD, MSSD, MSCD, WBT, & - WNMEAN, TAUA, TAUADIR - USE W3ODATMD, ONLY: NDSO, NDSE, NDST, NOGRP, NGRPP, IDOUT, & - UNDEF, FLOGRD, FNMPRE, NOSWLL, NOGE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NDSI, NDSM, NDSOG, NDSDAT, NDSDT, & - NDSTRC, NTRACE, IERR, I, J, IFI, IFJ,& - TOUT(2), TDUM(2), IOTEST, NOUT, & - ITYPE, IX1, IXN, IXS, IY1, IYN, IYS, & - IDLA, IDFM, IOUT, IPART + USE W3TIMEMD + USE W3IOGRMD, ONLY: W3IOGR + USE W3IOGOMD, ONLY: W3IOGO, W3READFLGRD + !/ + USE W3GDATMD + USE W3WDATMD, ONLY: TIME, WLV, ICE, ICEH, ICEF, BERG, UST, & + USTDIR, RHOAIR + USE W3ADATMD, ONLY: DW, UA, UD, AS, CX, CY, HS, WLM, T0M1, THM, & + THS, FP0, THP0, DTDYN, FCUT, & + ABA, ABD, UBA, UBD, SXX, SYY, SXY, USERO, & + PHS, PTP, PLP, PDIR, PSI, PWS, PWST, PNR, & + PTM1, PT1, PT2, PEP, TAUOCX, TAUOCY, & + PTHP0, PQP, PSW, PPE, PGW, QP, & + TAUOX, TAUOY, TAUWIX,BHD, & + TAUWIY, PHIAW, PHIOC, TUSX, TUSY, PRMS, TPMS,& + USSX, USSY, MSSX, MSSY, MSCX, MSCY, CHARN, & + TAUWNX, TAUWNY, TAUBBL, PHIBBL, CFLXYMAX, & + CFLTHMAX, CFLKMAX, BEDFORMS, WHITECAP, T02, & + CGE, T01, HSIG, STMAXE, STMAXD, HMAXE, & + HCMAXE, HMAXD, HCMAXD, MSSD, MSCD, WBT, & + WNMEAN, TAUA, TAUADIR + USE W3ODATMD, ONLY: NDSO, NDSE, NDST, NOGRP, NGRPP, IDOUT, & + UNDEF, FLOGRD, FNMPRE, NOSWLL, NOGE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NDSI, NDSM, NDSOG, NDSDAT, NDSDT, & + NDSTRC, NTRACE, IERR, I, J, IFI, IFJ,& + TOUT(2), TDUM(2), IOTEST, NOUT, & + ITYPE, IX1, IXN, IXS, IY1, IYN, IYS, & + IDLA, IDFM, IOUT, IPART #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: DTREQ, DTEST - CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & - TABNME*9 - LOGICAL :: FLREQ(NOGRP,NGRPP), FLOG(NOGRP), & - SCALE, VECTOR, LTEMP(NGRPP) -!/ -!/ ------------------------------------------------------------------- / -!/ -! 1. IO set-up. -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! - NDSI = 10 - NDSM = 20 - NDSOG = 20 - NDSDAT = 50 -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + REAL :: DTREQ, DTEST + CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & + TABNME*9 + LOGICAL :: FLREQ(NOGRP,NGRPP), FLOG(NOGRP), & + SCALE, VECTOR, LTEMP(NGRPP) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! 1. IO set-up. + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + NDSI = 10 + NDSM = 20 + NDSOG = 20 + NDSDAT = 50 + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_S - CALL STRACE (IENT, 'W3OUTF') + CALL STRACE (IENT, 'W3OUTF') #endif -! - WRITE (NDSO,900) -! - J = LEN_TRIM(FNMPRE) - OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_outf.inp',STATUS='OLD', & - ERR=800,IOSTAT=IERR) - READ (NDSI,'(A)',END=801,ERR=802) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - WRITE (NDSO,920) GNAME -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read general data and first fields from file -! - CALL W3IOGO ( 'READ', NDSOG, IOTEST ) -! - WRITE (NDSO,930) - DO IFI=1, NOGRP - DO IFJ=1, NGRPP - IF ( FLOGRD(IFI,IFJ) ) WRITE (NDSO,931) IDOUT(IFI,IFJ) - END DO - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Read requests from input file. -! Output times -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT - DTREQ = MAX ( 0. , DTREQ ) - IF ( DTREQ.EQ.0. ) NOUT = 1 - NOUT = MAX ( 1 , NOUT ) -! - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,940) IDTIME -! - TDUM = 0 - CALL TICK21 ( TDUM , DTREQ ) - CALL STME21 ( TDUM , IDTIME ) - IF ( DTREQ .GE. 86400. ) THEN - WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) - ELSE - IDDDAY = ' ' - END IF - IDTIME(1:11) = IDDDAY - IDTIME(21:23) = ' ' - WRITE (NDSO,941) IDTIME, NOUT -! -! ... Output fields -! - CALL W3READFLGRD ( NDSI, NDSO, 9, NDSE, COMSTR, FLOG, & - FLREQ, 1, 1, IERR ) - IF (IERR.NE.0) GOTO 800 + ! + WRITE (NDSO,900) + ! + J = LEN_TRIM(FNMPRE) + OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_outf.inp',STATUS='OLD', & + ERR=800,IOSTAT=IERR) + READ (NDSI,'(A)',END=801,ERR=802) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + WRITE (NDSO,920) GNAME + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read general data and first fields from file + ! + CALL W3IOGO ( 'READ', NDSOG, IOTEST ) + ! + WRITE (NDSO,930) + DO IFI=1, NOGRP + DO IFJ=1, NGRPP + IF ( FLOGRD(IFI,IFJ) ) WRITE (NDSO,931) IDOUT(IFI,IFJ) + END DO + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Read requests from input file. + ! Output times + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT + DTREQ = MAX ( 0. , DTREQ ) + IF ( DTREQ.EQ.0. ) NOUT = 1 + NOUT = MAX ( 1 , NOUT ) + ! + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,940) IDTIME + ! + TDUM = 0 + CALL TICK21 ( TDUM , DTREQ ) + CALL STME21 ( TDUM , IDTIME ) + IF ( DTREQ .GE. 86400. ) THEN + WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) + ELSE + IDDDAY = ' ' + END IF + IDTIME(1:11) = IDDDAY + IDTIME(21:23) = ' ' + WRITE (NDSO,941) IDTIME, NOUT + ! + ! ... Output fields + ! + CALL W3READFLGRD ( NDSI, NDSO, 9, NDSE, COMSTR, FLOG, & + FLREQ, 1, 1, IERR ) + IF (IERR.NE.0) GOTO 800 -! -! ... Output type -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) ITYPE, IPART -!Li IF ( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN - IF ( ITYPE.LT.0 .OR. ITYPE.GT.4 ) THEN -!Li Type 4 for text output at sea points. JGLi12Dec2012 - WRITE (NDSE,1010) ITYPE - CALL EXTCDE ( 1 ) - END IF - IPART = MAX ( 0 , MIN ( NOSWLL , IPART ) ) -! -! ... ITYPE = 0 -! - IF ( ITYPE .EQ. 0 ) THEN - WRITE (NDSO,942) ITYPE, 'Checking contents of file' - DO - CALL STME21 ( TIME , IDTIME ) - WRITE (NDSO,943) IDTIME - CALL W3IOGO ( 'READ', NDSOG, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - WRITE (NDSO,944) - GOTO 888 - END IF - END DO -! -! ... ITYPE = 1 -! - ELSE IF (ITYPE .EQ. 1) THEN - WRITE (NDSO,942) ITYPE, 'Print plots' - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) & - IX1, IXN, IXS, IY1, IYN, IYS, SCALE, VECTOR - IX1 = MAX ( IX1 , 1 ) - IXN = MIN ( IXN , NX ) - IXS = MAX ( IXS , 1 ) - IY1 = MAX ( IY1 , 1 ) - IYN = MIN ( IYN , NY ) - IYS = MAX ( IYS , 1 ) - WRITE (NDSO,1940) IX1, IXN, IXS, IY1, IYN, IYS - IF ( SCALE ) WRITE (NDSO,1941) -! -! ... ITYPE = 2 -! - ELSE IF (ITYPE .EQ. 2) THEN - WRITE (NDSO,942) ITYPE, 'Field statistics' - NDSDT = NDSDAT - 1 - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) IX1, IXN, IY1, IYN - IX1 = MAX ( IX1 , 1 ) - IXN = MIN ( IXN , NX ) - IY1 = MAX ( IY1 , 1 ) - IYN = MIN ( IYN , NY ) - WRITE (NDSO,2940) IX1, IXN, IY1, IYN -! -! ... ITYPE = 3 -! - ELSE IF (ITYPE .EQ. 3) THEN - WRITE (NDSO,942) ITYPE, 'Transfer files' - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) & - IX1, IXN, IY1, IYN, IDLA, IDFM - IX1 = MAX ( IX1 , 1 ) - IXN = MIN ( IXN , NX ) - IY1 = MAX ( IY1 , 1 ) - IYN = MIN ( IYN , NY ) - IF (IDLA.LT.1 .OR. IDLA.GT.5) IDLA = 1 - IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 - VECTOR = .TRUE. - WRITE (NDSO,3940) IX1, IXN, IY1, IYN, IDLA, IDFM -! -!Li Added sea-point output type 4. JGLi12Dec2012 -! -! ... ITYPE = 4 -! - ELSE IF (ITYPE .EQ. 4) THEN - WRITE (NDSO,942) ITYPE, 'Full sea-point output.' - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) & - IX1, IXN, IY1, IYN, IDLA, IDFM -!Li -! - END IF -! -! ... Output of output fields -! - IF ( ITYPE.NE.2 ) THEN - WRITE (NDSO,945) - ELSE - WRITE (NDSO,2945) - END IF -! - DO IFI=1, NOGRP - DO IFJ=1, NGRPP - IF ( FLREQ(IFI,IFJ) ) THEN - IF ( FLOGRD(IFI,IFJ) ) THEN - IF ( ITYPE.NE.2 ) THEN - WRITE (NDSO,946) IDOUT(IFI,IFJ), ' ' - ELSE - J = LEN_TRIM(FNMPRE) - NDSDT = NDSDT + 1 - WRITE (TABNME,'(A3,I2.2,A4)') 'tab', NDSDT, '.ww3' - WRITE (NDSO,2946) TABNME, IDOUT(IFI,IFJ) - OPEN (NDSDT,FILE=FNMPRE(:J)//TABNME) - WRITE (NDSDT,2947) IDOUT(IFI,IFJ) - END IF - ELSE - WRITE (NDSO,946) IDOUT(IFI,IFJ), '*** NOT AVAILABLE ***' - FLREQ(IFI,IFJ) = .FALSE. - END IF + ! + ! ... Output type + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) ITYPE, IPART + !Li IF ( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN + IF ( ITYPE.LT.0 .OR. ITYPE.GT.4 ) THEN + !Li Type 4 for text output at sea points. JGLi12Dec2012 + WRITE (NDSE,1010) ITYPE + CALL EXTCDE ( 1 ) + END IF + IPART = MAX ( 0 , MIN ( NOSWLL , IPART ) ) + ! + ! ... ITYPE = 0 + ! + IF ( ITYPE .EQ. 0 ) THEN + WRITE (NDSO,942) ITYPE, 'Checking contents of file' + DO + CALL STME21 ( TIME , IDTIME ) + WRITE (NDSO,943) IDTIME + CALL W3IOGO ( 'READ', NDSOG, IOTEST ) + IF ( IOTEST .EQ. -1 ) THEN + WRITE (NDSO,944) + GOTO 888 + END IF + END DO + ! + ! ... ITYPE = 1 + ! + ELSE IF (ITYPE .EQ. 1) THEN + WRITE (NDSO,942) ITYPE, 'Print plots' + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) & + IX1, IXN, IXS, IY1, IYN, IYS, SCALE, VECTOR + IX1 = MAX ( IX1 , 1 ) + IXN = MIN ( IXN , NX ) + IXS = MAX ( IXS , 1 ) + IY1 = MAX ( IY1 , 1 ) + IYN = MIN ( IYN , NY ) + IYS = MAX ( IYS , 1 ) + WRITE (NDSO,1940) IX1, IXN, IXS, IY1, IYN, IYS + IF ( SCALE ) WRITE (NDSO,1941) + ! + ! ... ITYPE = 2 + ! + ELSE IF (ITYPE .EQ. 2) THEN + WRITE (NDSO,942) ITYPE, 'Field statistics' + NDSDT = NDSDAT - 1 + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) IX1, IXN, IY1, IYN + IX1 = MAX ( IX1 , 1 ) + IXN = MIN ( IXN , NX ) + IY1 = MAX ( IY1 , 1 ) + IYN = MIN ( IYN , NY ) + WRITE (NDSO,2940) IX1, IXN, IY1, IYN + ! + ! ... ITYPE = 3 + ! + ELSE IF (ITYPE .EQ. 3) THEN + WRITE (NDSO,942) ITYPE, 'Transfer files' + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) & + IX1, IXN, IY1, IYN, IDLA, IDFM + IX1 = MAX ( IX1 , 1 ) + IXN = MIN ( IXN , NX ) + IY1 = MAX ( IY1 , 1 ) + IYN = MIN ( IYN , NY ) + IF (IDLA.LT.1 .OR. IDLA.GT.5) IDLA = 1 + IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 + VECTOR = .TRUE. + WRITE (NDSO,3940) IX1, IXN, IY1, IYN, IDLA, IDFM + ! + !Li Added sea-point output type 4. JGLi12Dec2012 + ! + ! ... ITYPE = 4 + ! + ELSE IF (ITYPE .EQ. 4) THEN + WRITE (NDSO,942) ITYPE, 'Full sea-point output.' + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) & + IX1, IXN, IY1, IYN, IDLA, IDFM + !Li + ! + END IF + ! + ! ... Output of output fields + ! + IF ( ITYPE.NE.2 ) THEN + WRITE (NDSO,945) + ELSE + WRITE (NDSO,2945) + END IF + ! + DO IFI=1, NOGRP + DO IFJ=1, NGRPP + IF ( FLREQ(IFI,IFJ) ) THEN + IF ( FLOGRD(IFI,IFJ) ) THEN + IF ( ITYPE.NE.2 ) THEN + WRITE (NDSO,946) IDOUT(IFI,IFJ), ' ' + ELSE + J = LEN_TRIM(FNMPRE) + NDSDT = NDSDT + 1 + WRITE (TABNME,'(A3,I2.2,A4)') 'tab', NDSDT, '.ww3' + WRITE (NDSO,2946) TABNME, IDOUT(IFI,IFJ) + OPEN (NDSDT,FILE=FNMPRE(:J)//TABNME) + WRITE (NDSDT,2947) IDOUT(IFI,IFJ) END IF - END DO - END DO -! - IF ( FLOG(4) ) THEN - IF ( IPART .EQ. 0 ) THEN - WRITE (NDSO,948) - ELSE - WRITE (NDSO,949) IPART - END IF + ELSE + WRITE (NDSO,946) IDOUT(IFI,IFJ), '*** NOT AVAILABLE ***' + FLREQ(IFI,IFJ) = .FALSE. END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Time management. -! - IOUT = 0 - IF (ITYPE.EQ.3) WRITE (NDSO,970) -! - DO - DTEST = DSEC21 ( TIME , TOUT ) - IF ( DTEST .GT. 0. ) THEN - CALL W3IOGO ( 'READ', NDSOG, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - WRITE (NDSO,944) - GOTO 888 - END IF - CYCLE - END IF - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF -! - IOUT = IOUT + 1 - CALL STME21 ( TOUT , IDTIME ) - IF (ITYPE.EQ.1) THEN - WRITE (NDSO,950) IDTIME - ELSE IF (ITYPE.EQ.3) THEN - WRITE (NDSO,971) IDTIME - END IF -! - CALL W3EXGO ( NX, NY, NSEA ) -! - CALL TICK21 ( TOUT , DTREQ ) - IF ( IOUT .GE. NOUT ) EXIT - END DO -! - IF (ITYPE.EQ.3) WRITE (NDSO,972) -! - GOTO 888 -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 10 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 11 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 12 ) -! - 888 CONTINUE - WRITE (NDSO,999) -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Field output postp. *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) -! - 920 FORMAT ( ' Grid name : ',A/) -! - 930 FORMAT ( ' Fields in file : '/ & - ' --------------------------') - 931 FORMAT ( ' ',A) -! - 940 FORMAT (/' Output time data : '/ & - ' --------------------------------------------------'/ & - ' First time : ',A) - 941 FORMAT ( ' Interval : ',A/ & - ' Number of requests : ',I6) - 942 FORMAT (/' Output type ',I2,' :'/ & - ' --------------------------------------------------'/ & - ' ',A/) - 943 FORMAT ( ' Data for ',A) - 944 FORMAT (/' End of file reached '/) -! - 945 FORMAT (/' Requested output fields : '/ & - ' --------------------------------------------------') - 2945 FORMAT (/' Output files and fields : '/ & - ' --------------------------------------------------') - 946 FORMAT ( ' ',A,2X,A) - 2946 FORMAT ( ' ',A,' : ',A) - 2947 FORMAT ( ' Statitics of ',A/ & - ' (time, min, max, avg, std)'/) - 948 FORMAT (/' Partitioned field data for wind seas') - 949 FORMAT (/' Partitioned field data for swell field',I2) -! - 1940 FORMAT ( ' X range and interval : ',3I5/ & - ' Y range and interval : ',3I5) - 1941 FORMAT ( ' Data is normalized ') -! - 2940 FORMAT ( ' X range : ',2I5/ & - ' Y range : ',2I5) -! - 3940 FORMAT ( ' X range : ',2I5/ & - ' Y range : ',2I5/ & - ' Layout indicator : ',I5/ & - ' Format indicator : ',I5) -! - 950 FORMAT (//' Output for ',A/ & - ' --------------------------------------------------') -! - 970 FORMAT (//' Generating files '/ & - ' --------------------------------------------------') - 971 FORMAT ( ' Files for ',A) - 972 FORMAT ( ' ') -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Field output '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTF : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTF : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTF : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTF : '/ & - ' ILLEGAL TYPE, ITYPE =',I4/) -!/ -!/ Internal subroutine W3EXGO ---------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3EXGO ( NX, NY, NSEA ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 26-Sep-1997 : Final FORTRAN 77 ( version 1.18 ) -!/ 19-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Massive changes to logistics -!/ 24-Jan-2001 : Flat grid version ( version 2.06 ) -!/ 23-Apr-2002 : Clean-up ( version 2.19 ) -!/ 29-Apr-2002 : Adding output fields 17-18. ( version 2.20 ) -!/ 16-Oct-2002 : Fix bound. error for stress output. ( version 3.00 ) -!/ 16-Oct-2002 : Fix statistical output for UNDEF. ( version 3.00 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 21-Jul-2005 : Adding output fields 19-21. ( version 3.07 ) -!/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 28-Mar-2007 : Adding partitioned output. ( version 3.11 ) -!/ Adding user slots for outputs. -!/ 31-Jul-2007 : Fix file extension errors. ( version 3.12 ) -!/ 25-Dec-2012 : New structure of output fields. ( version 4.11 ) -!/ 25-Jun-2013 : Add type 4 sea point text output. ( version 4.11 ) -!/ 26-Jan-2021 : Added TP field (derived from FP0) ( version 7.12 ) -!/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) -!/ -! 1. Purpose : -! -! Perform actual grid output. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NX/Y Int. I Grid dimensions. -! NSEA Int. I Number of sea points. -! ---------------------------------------------------------------- -! -! Internal parameters -! ---------------------------------------------------------------- -! FLONE Log. Flags for one-dimensional field. -! FLTWO Log. Flags for two-dimensional field X Y. -! FLDIR Log. Flags for two-dimensional, directional field. -! FLTRI Log. Flags for three dimensional field. -! X1, X2, XX, XY -! R.A. Output fields -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Abort program as graceful as possible. -! W3S2XY Subr. Id. Convert from storage to spatial grid. -! PRTBLK Subr. W3ARRYMD Print plot of array. -! OUTA2I Subr. Id. Print array of INTEGERS. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Main program in which it is contained. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Note that arrays CX and CY of the main program now contain -! the absolute current speed and direction respectively. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY : W3S2XY + END IF + END DO + END DO + ! + IF ( FLOG(4) ) THEN + IF ( IPART .EQ. 0 ) THEN + WRITE (NDSO,948) + ELSE + WRITE (NDSO,949) IPART + END IF + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Time management. + ! + IOUT = 0 + IF (ITYPE.EQ.3) WRITE (NDSO,970) + ! + DO + DTEST = DSEC21 ( TIME , TOUT ) + IF ( DTEST .GT. 0. ) THEN + CALL W3IOGO ( 'READ', NDSOG, IOTEST ) + IF ( IOTEST .EQ. -1 ) THEN + WRITE (NDSO,944) + GOTO 888 + END IF + CYCLE + END IF + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF + ! + IOUT = IOUT + 1 + CALL STME21 ( TOUT , IDTIME ) + IF (ITYPE.EQ.1) THEN + WRITE (NDSO,950) IDTIME + ELSE IF (ITYPE.EQ.3) THEN + WRITE (NDSO,971) IDTIME + END IF + ! + CALL W3EXGO ( NX, NY, NSEA ) + ! + CALL TICK21 ( TOUT , DTREQ ) + IF ( IOUT .GE. NOUT ) EXIT + END DO + ! + IF (ITYPE.EQ.3) WRITE (NDSO,972) + ! + GOTO 888 + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 10 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 11 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 12 ) + ! +888 CONTINUE + WRITE (NDSO,999) + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Field output postp. *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) + ! +920 FORMAT ( ' Grid name : ',A/) + ! +930 FORMAT ( ' Fields in file : '/ & + ' --------------------------') +931 FORMAT ( ' ',A) + ! +940 FORMAT (/' Output time data : '/ & + ' --------------------------------------------------'/ & + ' First time : ',A) +941 FORMAT ( ' Interval : ',A/ & + ' Number of requests : ',I6) +942 FORMAT (/' Output type ',I2,' :'/ & + ' --------------------------------------------------'/ & + ' ',A/) +943 FORMAT ( ' Data for ',A) +944 FORMAT (/' End of file reached '/) + ! +945 FORMAT (/' Requested output fields : '/ & + ' --------------------------------------------------') +2945 FORMAT (/' Output files and fields : '/ & + ' --------------------------------------------------') +946 FORMAT ( ' ',A,2X,A) +2946 FORMAT ( ' ',A,' : ',A) +2947 FORMAT ( ' Statitics of ',A/ & + ' (time, min, max, avg, std)'/) +948 FORMAT (/' Partitioned field data for wind seas') +949 FORMAT (/' Partitioned field data for swell field',I2) + ! +1940 FORMAT ( ' X range and interval : ',3I5/ & + ' Y range and interval : ',3I5) +1941 FORMAT ( ' Data is normalized ') + ! +2940 FORMAT ( ' X range : ',2I5/ & + ' Y range : ',2I5) + ! +3940 FORMAT ( ' X range : ',2I5/ & + ' Y range : ',2I5/ & + ' Layout indicator : ',I5/ & + ' Format indicator : ',I5) + ! +950 FORMAT (//' Output for ',A/ & + ' --------------------------------------------------') + ! +970 FORMAT (//' Generating files '/ & + ' --------------------------------------------------') +971 FORMAT ( ' Files for ',A) +972 FORMAT ( ' ') + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Field output '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTF : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTF : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTF : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTF : '/ & + ' ILLEGAL TYPE, ITYPE =',I4/) + !/ + !/ Internal subroutine W3EXGO ---------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3EXGO ( NX, NY, NSEA ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 26-Sep-1997 : Final FORTRAN 77 ( version 1.18 ) + !/ 19-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Massive changes to logistics + !/ 24-Jan-2001 : Flat grid version ( version 2.06 ) + !/ 23-Apr-2002 : Clean-up ( version 2.19 ) + !/ 29-Apr-2002 : Adding output fields 17-18. ( version 2.20 ) + !/ 16-Oct-2002 : Fix bound. error for stress output. ( version 3.00 ) + !/ 16-Oct-2002 : Fix statistical output for UNDEF. ( version 3.00 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 21-Jul-2005 : Adding output fields 19-21. ( version 3.07 ) + !/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 28-Mar-2007 : Adding partitioned output. ( version 3.11 ) + !/ Adding user slots for outputs. + !/ 31-Jul-2007 : Fix file extension errors. ( version 3.12 ) + !/ 25-Dec-2012 : New structure of output fields. ( version 4.11 ) + !/ 25-Jun-2013 : Add type 4 sea point text output. ( version 4.11 ) + !/ 26-Jan-2021 : Added TP field (derived from FP0) ( version 7.12 ) + !/ 22-Mar-2021 : New coupling fields output ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Perform actual grid output. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NX/Y Int. I Grid dimensions. + ! NSEA Int. I Number of sea points. + ! ---------------------------------------------------------------- + ! + ! Internal parameters + ! ---------------------------------------------------------------- + ! FLONE Log. Flags for one-dimensional field. + ! FLTWO Log. Flags for two-dimensional field X Y. + ! FLDIR Log. Flags for two-dimensional, directional field. + ! FLTRI Log. Flags for three dimensional field. + ! X1, X2, XX, XY + ! R.A. Output fields + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! W3S2XY Subr. Id. Convert from storage to spatial grid. + ! PRTBLK Subr. W3ARRYMD Print plot of array. + ! OUTA2I Subr. Id. Print array of INTEGERS. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Main program in which it is contained. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Note that arrays CX and CY of the main program now contain + ! the absolute current speed and direction respectively. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY : W3S2XY #ifdef W3_RTD - USE W3SERVMD, ONLY : W3THRTN, W3XYRTN + USE W3SERVMD, ONLY : W3THRTN, W3XYRTN #endif - USE W3ARRYMD, ONLY : OUTA2I, PRTBLK -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER :: NX, NY, NSEA -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NXMAX, NXTOT, NBLOK, IH, IM, IS, & - MFILL, J, ISEA, IX, IY, IXB, IB, & - IXA, NINGRD, JJ, IFI, IFJ - INTEGER :: MAP(NX+1,NY), MP2(NX+1,NY), & - MX1(NX,NY), MXX(NX,NY), MYY(NX,NY), & - MXY(NX,NY) - INTEGER, SAVE :: IPASS -! INTEGER, SAVE :: NCOL = 80 - INTEGER, SAVE :: NCOL = 132 + USE W3ARRYMD, ONLY : OUTA2I, PRTBLK + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER :: NX, NY, NSEA + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NXMAX, NXTOT, NBLOK, IH, IM, IS, & + MFILL, J, ISEA, IX, IY, IXB, IB, & + IXA, NINGRD, JJ, IFI, IFJ + INTEGER :: MAP(NX+1,NY), MP2(NX+1,NY), & + MX1(NX,NY), MXX(NX,NY), MYY(NX,NY), & + MXY(NX,NY) + INTEGER, SAVE :: IPASS + ! INTEGER, SAVE :: NCOL = 80 + INTEGER, SAVE :: NCOL = 132 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - REAL :: FSC, CABS, UABS, FSCA, XMIN, XMAX, & - XAVG, XSTD, YGBX, XGBX, AABS - REAL :: X1(NX+1,NY), X2(NX+1,NY), & - XX(NX+1,NY), XY(NX+1,NY), DPTMAX(1) -!!Li Type 4 sea point only text output variables. JGLi25Jun2013 - REAL, Dimension(NSEA) :: XS1, XS2, XS3, XS4, AUX -!!Li - DOUBLE PRECISION :: XDS, XDSQ - LOGICAL :: FLONE, FLTWO, FLDIR, FLTRI + REAL :: FSC, CABS, UABS, FSCA, XMIN, XMAX, & + XAVG, XSTD, YGBX, XGBX, AABS + REAL :: X1(NX+1,NY), X2(NX+1,NY), & + XX(NX+1,NY), XY(NX+1,NY), DPTMAX(1) + !!Li Type 4 sea point only text output variables. JGLi25Jun2013 + REAL, Dimension(NSEA) :: XS1, XS2, XS3, XS4, AUX + !!Li + DOUBLE PRECISION :: XDS, XDSQ + LOGICAL :: FLONE, FLTWO, FLDIR, FLTRI #ifdef W3_T - LOGICAL :: LTEMP(NGRPP) + LOGICAL :: LTEMP(NGRPP) #endif - CHARACTER :: OLDTID*8, FNAME*32, ENAME*7, & - FORMG*12, FORMF*11, UNITS*10, FSCS*7 - CHARACTER, SAVE :: TIMEID*8 = '00000000' - CHARACTER, SAVE :: FILEID*13 = 'WAVEWATCH III' + CHARACTER :: OLDTID*8, FNAME*32, ENAME*7, & + FORMG*12, FORMF*11, UNITS*10, FSCS*7 + CHARACTER, SAVE :: TIMEID*8 = '00000000' + CHARACTER, SAVE :: FILEID*13 = 'WAVEWATCH III' #ifdef W3_BT4 - REAL, PARAMETER :: LOG2=LOG(2.) + REAL, PARAMETER :: LOG2=LOG(2.) #endif -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3EXGO') + CALL STRACE (IENT, 'W3EXGO') #endif -! + ! #ifdef W3_T - DO IFI=1, NOGRP - LTEMP = FLREQ(IFI,:) - WRITE (NDST,9000) IFI, LTEMP - END DO - WRITE (NDST,9001) ITYPE, IX1, IXN, IXS, IY1, IYN, IYS, & - SCALE, VECTOR, NDSDAT + DO IFI=1, NOGRP + LTEMP = FLREQ(IFI,:) + WRITE (NDST,9000) IFI, LTEMP + END DO + WRITE (NDST,9001) ITYPE, IX1, IXN, IXS, IY1, IYN, IYS, & + SCALE, VECTOR, NDSDAT #endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. Preparations -! - X1 = UNDEF - X2 = UNDEF - XX = UNDEF - XY = UNDEF -!!Li Type 4 sea point only variables - XS1 = UNDEF - XS2 = UNDEF - XS3 = UNDEF - XS4 = UNDEF -! -! Number of print-plots -! - IF ( ITYPE .EQ. 1 ) THEN - IF ( SCALE ) THEN - NXMAX = ( NCOL - 10 ) / 2 - ELSE - NXMAX = ( NCOL - 10 ) / 5 - END IF - NXTOT = 1 + (IXN-IX1)/IXS - NBLOK = 1 + (NXTOT-1)/NXMAX + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1. Preparations + ! + X1 = UNDEF + X2 = UNDEF + XX = UNDEF + XY = UNDEF + !!Li Type 4 sea point only variables + XS1 = UNDEF + XS2 = UNDEF + XS3 = UNDEF + XS4 = UNDEF + ! + ! Number of print-plots + ! + IF ( ITYPE .EQ. 1 ) THEN + IF ( SCALE ) THEN + NXMAX = ( NCOL - 10 ) / 2 + ELSE + NXMAX = ( NCOL - 10 ) / 5 + END IF + NXTOT = 1 + (IXN-IX1)/IXS + NBLOK = 1 + (NXTOT-1)/NXMAX #ifdef W3_T - WRITE (NDST,9012) NXMAX, NXTOT, NBLOK + WRITE (NDST,9012) NXMAX, NXTOT, NBLOK #endif - END IF -! -! Output file unit number -! - IF ( ITYPE .EQ. 2 ) THEN - NDSDT = NDSDAT - 1 - IH = TIME(2) / 10000 - IM = MOD ( TIME(2) , 10000 ) / 100 - IS = MOD ( TIME(2) , 100 ) - END IF -! -! Set-up transfer files -! -!!Li Type 4 share filename with type 3 JGLi25Jun2013 -!! IF ( ITYPE .EQ. 3 ) THEN - IF ( ITYPE .EQ. 3 .OR. ITYPE .EQ. 4 ) THEN - MFILL = -999 - OLDTID = TIMEID - WRITE (TIMEID,'(I6.6,I2.2)') MOD( TIME(1) , 1000000 ), & - TIME(2)/10000 - FNAME(05:12) = TIMEID - FNAME(13:13) = '.' - IF ( TIMEID .NE. OLDTID ) THEN - FNAME(1:4) = 'ww3.' - IPASS = 1 - ELSE - WRITE (ENAME,'(A1,I2.2,A1)') 'e', IPASS, '.' - FNAME(1:4) = ENAME - IPASS = IPASS + 1 - END IF + END IF + ! + ! Output file unit number + ! + IF ( ITYPE .EQ. 2 ) THEN + NDSDT = NDSDAT - 1 + IH = TIME(2) / 10000 + IM = MOD ( TIME(2) , 10000 ) / 100 + IS = MOD ( TIME(2) , 100 ) + END IF + ! + ! Set-up transfer files + ! + !!Li Type 4 share filename with type 3 JGLi25Jun2013 + !! IF ( ITYPE .EQ. 3 ) THEN + IF ( ITYPE .EQ. 3 .OR. ITYPE .EQ. 4 ) THEN + MFILL = -999 + OLDTID = TIMEID + WRITE (TIMEID,'(I6.6,I2.2)') MOD( TIME(1) , 1000000 ), & + TIME(2)/10000 + FNAME(05:12) = TIMEID + FNAME(13:13) = '.' + IF ( TIMEID .NE. OLDTID ) THEN + FNAME(1:4) = 'ww3.' + IPASS = 1 + ELSE + WRITE (ENAME,'(A1,I2.2,A1)') 'e', IPASS, '.' + FNAME(1:4) = ENAME + IPASS = IPASS + 1 + END IF #ifdef W3_T - WRITE (NDST,9014) FNAME(1:13) + WRITE (NDST,9014) FNAME(1:13) #endif - FORMG = '((10G12.2))' - END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Loop over output fields. -! - DO IFI=1, NOGRP + FORMG = '((10G12.2))' + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Loop over output fields. + ! + DO IFI=1, NOGRP DO IFJ=1, NGRPP IF ( FLREQ(IFI,IFJ) ) THEN -! - FORMF = '(1X,32I4)' + ! + FORMF = '(1X,32I4)' #ifdef W3_T - WRITE (NDST,9020) IDOUT(IFI,IFJ) + WRITE (NDST,9020) IDOUT(IFI,IFJ) #endif -! -! 2.a Set output arrays and parameters + ! + ! 2.a Set output arrays and parameters - FLONE = .FALSE. - FLTWO = .FALSE. - FLDIR = .FALSE. - FLTRI = .FALSE. -! - IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN - FLONE = .TRUE. - DPTMAX = MAXVAL ( DW(1:NSEA) ) - FSC = 1. - IF ( DPTMAX(1) .GT. 999. ) THEN - FSC = 0.1 - ELSE IF ( DPTMAX(1) .GT. 99.9 ) THEN - FSC = 0.1 - ELSE IF ( DPTMAX(1) .GT. 9.99 ) THEN - FSC = 0.01 - END IF - IF ( ITYPE .EQ. 3 ) FSC = 0.01 - UNITS = 'm' - ENAME = '.dpt' - FORMF = '(1X,17I7)' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = DW(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, DW(1:NSEA) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 0.01 - ENAME = '.cur' - UNITS = 'm s-1' - FORMF = '(1X,17I7)' + FLONE = .FALSE. + FLTWO = .FALSE. + FLDIR = .FALSE. + FLTRI = .FALSE. + ! + IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN + FLONE = .TRUE. + DPTMAX = MAXVAL ( DW(1:NSEA) ) + FSC = 1. + IF ( DPTMAX(1) .GT. 999. ) THEN + FSC = 0.1 + ELSE IF ( DPTMAX(1) .GT. 99.9 ) THEN + FSC = 0.1 + ELSE IF ( DPTMAX(1) .GT. 9.99 ) THEN + FSC = 0.01 + END IF + IF ( ITYPE .EQ. 3 ) FSC = 0.01 + UNITS = 'm' + ENAME = '.dpt' + FORMF = '(1X,17I7)' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = DW(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, DW(1:NSEA) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 0.01 + ENAME = '.cur' + UNITS = 'm s-1' + FORMF = '(1X,17I7)' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX, CY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX, CY, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = CX(1:NSEA) - XS2 = CY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CX(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CY(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - CABS = SQRT(CX(ISEA)**2+CY(ISEA)**2) - IF ( CABS .GT. 0.05 ) THEN - CY(ISEA) = MOD ( 630. - & - RADE*ATAN2(CY(ISEA),CX(ISEA)) , 360. ) - ELSE - CY(ISEA) = UNDEF - END IF - CX(ISEA) = CABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = CX(1:NSEA) - XS4 = CY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CX(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CY(1:NSEA) & - , MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 0.1 - ENAME = '.wnd' - UNITS = 'm s-1' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = CX(1:NSEA) + XS2 = CY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CX(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CY(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + CABS = SQRT(CX(ISEA)**2+CY(ISEA)**2) + IF ( CABS .GT. 0.05 ) THEN + CY(ISEA) = MOD ( 630. - & + RADE*ATAN2(CY(ISEA),CX(ISEA)) , 360. ) + ELSE + CY(ISEA) = UNDEF + END IF + CX(ISEA) = CABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = CX(1:NSEA) + XS4 = CY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CX(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CY(1:NSEA) & + , MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 0.1 + ENAME = '.wnd' + UNITS = 'm s-1' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA, UD, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA, UD, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = UA(1:NSEA) - XS2 = UD(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UA(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UD(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - UABS = SQRT(UA(ISEA)**2+UD(ISEA)**2) - IF ( UABS .GT. 1.0 ) THEN - UD(ISEA) = MOD ( 630. - & - RADE*ATAN2(UD(ISEA),UA(ISEA)) , 360. ) - ELSE - UD(ISEA) = UNDEF - END IF - UA(ISEA) = UABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = UA(1:NSEA) - XS4 = UD(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UA(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UD(1:NSEA) & - , MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. - FSC = 0.1 - ENAME = '.ast' - UNITS = 'K' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = AS(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, AS(1:NSEA) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 'm' - ENAME = '.wlv' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = WLV - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WLV , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = '1' - ENAME = '.ice' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = ICE - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, ICE , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 7 ) THEN - FLONE = .TRUE. - FSC = 0.0002 - UNITS = 'km-1' - ENAME = '.ibg' - WHERE ( BERG.NE.UNDEF) BERG = BERG*0.1 - IF ( ITYPE .EQ. 4 ) THEN - XS1 = BERG - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BERG , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN - !! Note - TAUA and TAUADIR read in from .ww3 file are TAUAX,TAUAY - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 0.01 - UNITS = 'Pa' - ENAME = '.taua' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = UA(1:NSEA) + XS2 = UD(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UA(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UD(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + UABS = SQRT(UA(ISEA)**2+UD(ISEA)**2) + IF ( UABS .GT. 1.0 ) THEN + UD(ISEA) = MOD ( 630. - & + RADE*ATAN2(UD(ISEA),UA(ISEA)) , 360. ) + ELSE + UD(ISEA) = UNDEF + END IF + UA(ISEA) = UABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = UA(1:NSEA) + XS4 = UD(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UA(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UD(1:NSEA) & + , MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. + FSC = 0.1 + ENAME = '.ast' + UNITS = 'K' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = AS(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, AS(1:NSEA) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 'm' + ENAME = '.wlv' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = WLV + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WLV , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = '1' + ENAME = '.ice' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = ICE + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, ICE , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 7 ) THEN + FLONE = .TRUE. + FSC = 0.0002 + UNITS = 'km-1' + ENAME = '.ibg' + WHERE ( BERG.NE.UNDEF) BERG = BERG*0.1 + IF ( ITYPE .EQ. 4 ) THEN + XS1 = BERG + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BERG , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN + !! Note - TAUA and TAUADIR read in from .ww3 file are TAUAX,TAUAY + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 0.01 + UNITS = 'Pa' + ENAME = '.taua' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) THEN - CALL W3XYRTN(NSEA, TAUA(1:NSEA), TAUADIR(1:NSEA), AnglD) - ENDIF + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) THEN + CALL W3XYRTN(NSEA, TAUA(1:NSEA), TAUADIR(1:NSEA), AnglD) + ENDIF #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = TAUA(1:NSEA) - XS2 = TAUADIR(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUA(1:NSEA), MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUADIR(1:NSEA), MAPSF, XY ) - ENDIF + IF ( ITYPE .EQ. 4 ) THEN + XS1 = TAUA(1:NSEA) + XS2 = TAUADIR(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUA(1:NSEA), MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUADIR(1:NSEA), MAPSF, XY ) + ENDIF - DO ISEA=1, NSEA - UABS = SQRT(TAUA(ISEA)**2+TAUADIR(ISEA)**2) - IF ( UABS .GT. 0.01 ) THEN - TAUADIR(ISEA) = MOD ( 630. - & - RADE*ATAN2(TAUA(ISEA),TAUADIR(ISEA)), 360.) - ELSE - TAUADIR(ISEA) = UNDEF - END IF - UA(ISEA) = UABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = TAUA(1:NSEA) - XS4 = TAUADIR(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUA(1:NSEA), MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUADIR(1:NSEA), MAPSF, X2) - ENDIF -! - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN - FLONE = .TRUE. - FSC = 0.0001 - UNITS = 'kg m-3' - ENAME = '.rhoa' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = RHOAIR - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, RHOAIR, MAPSF, X1 ) - ENDIF -! + DO ISEA=1, NSEA + UABS = SQRT(TAUA(ISEA)**2+TAUADIR(ISEA)**2) + IF ( UABS .GT. 0.01 ) THEN + TAUADIR(ISEA) = MOD ( 630. - & + RADE*ATAN2(TAUA(ISEA),TAUADIR(ISEA)), 360.) + ELSE + TAUADIR(ISEA) = UNDEF + END IF + UA(ISEA) = UABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = TAUA(1:NSEA) + XS4 = TAUADIR(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUA(1:NSEA), MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUADIR(1:NSEA), MAPSF, X2) + ENDIF + ! + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN + FLONE = .TRUE. + FSC = 0.0001 + UNITS = 'kg m-3' + ENAME = '.rhoa' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = RHOAIR + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, RHOAIR, MAPSF, X1 ) + ENDIF + ! #ifdef W3_BT4 - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 'Krumbein phi scale' - ENAME = '.d50' - WHERE ( SED_D50.NE.UNDEF) SED_D50 = -LOG(SED_D50/0.001)/LOG2 - IF ( ITYPE .EQ. 4 ) THEN - XS1 = SED_D50 - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, SED_D50 , MAPSF, X1 ) - ENDIF + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 'Krumbein phi scale' + ENAME = '.d50' + WHERE ( SED_D50.NE.UNDEF) SED_D50 = -LOG(SED_D50/0.001)/LOG2 + IF ( ITYPE .EQ. 4 ) THEN + XS1 = SED_D50 + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, SED_D50 , MAPSF, X1 ) + ENDIF #endif -! + ! #ifdef W3_IS2 - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = 'm' - ENAME = '.ic1' - IF ( ITYPE .EQ. 4) THEN - XS1 = ICEH - ELSE - CALL W3S2XY (NSEA, NSEA, NX+1, NY, ICEH, MAPSF, X1 ) - ENDIF + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = 'm' + ENAME = '.ic1' + IF ( ITYPE .EQ. 4) THEN + XS1 = ICEH + ELSE + CALL W3S2XY (NSEA, NSEA, NX+1, NY, ICEH, MAPSF, X1 ) + ENDIF #endif -! + ! #ifdef W3_IS2 - ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 12) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = 'm' - ENAME = '.ic5' - IF ( ITYPE .EQ. 4) THEN - XS1 = ICEF - ELSE - CALL W3S2XY (NSEA, NSEA, NX+1, NY, ICEF, MAPSF, X1 ) - ENDIF + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 12) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = 'm' + ENAME = '.ic5' + IF ( ITYPE .EQ. 4) THEN + XS1 = ICEF + ELSE + CALL W3S2XY (NSEA, NSEA, NX+1, NY, ICEF, MAPSF, X1 ) + ENDIF #endif - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 'm' - ENAME = '.hs' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = HS - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HS , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN - FLONE = .TRUE. - FSC = 1. - UNITS = 'm' - ENAME = '.lm' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = WLM - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WLM , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 's' - ENAME = '.t02' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = T02 - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, T02 , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 's' - ENAME = '.t0m1' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = T0M1 - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, T0M1 , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 's' - ENAME = '.t01' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = T01 - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, T01 , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 6 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = 's-1' - ENAME = '.fp' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = FP0 - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, FP0 , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN - FLONE = .TRUE. - FSC = 1. - UNITS = 'degree' - ENAME = '.dir' + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 'm' + ENAME = '.hs' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = HS + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HS , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN + FLONE = .TRUE. + FSC = 1. + UNITS = 'm' + ENAME = '.lm' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = WLM + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WLM , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 's' + ENAME = '.t02' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = T02 + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, T02 , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 's' + ENAME = '.t0m1' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = T0M1 + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, T0M1 , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 's' + ENAME = '.t01' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = T01 + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, T01 , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 6 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = 's-1' + ENAME = '.fp' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = FP0 + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, FP0 , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN + FLONE = .TRUE. + FSC = 1. + UNITS = 'degree' + ENAME = '.dir' #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) #endif - DO ISEA=1, NSEA - IF ( THM(ISEA) .NE. UNDEF ) & - THM(ISEA) = MOD ( 630. - RADE*THM(ISEA) , 360. ) - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = THM - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, THM , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN - FLONE = .TRUE. - FSC = 0.1 - UNITS = 'degree' - ENAME = '.spr' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = THS - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, THS , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN - FLONE = .TRUE. - FSC = 1. - UNITS = 'degree' - ENAME = '.dp' + DO ISEA=1, NSEA + IF ( THM(ISEA) .NE. UNDEF ) & + THM(ISEA) = MOD ( 630. - RADE*THM(ISEA) , 360. ) + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = THM + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, THM , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN + FLONE = .TRUE. + FSC = 0.1 + UNITS = 'degree' + ENAME = '.spr' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = THS + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, THS , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN + FLONE = .TRUE. + FSC = 1. + UNITS = 'degree' + ENAME = '.dp' #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) #endif - DO ISEA=1, NSEA - IF ( THP0(ISEA) .NE. UNDEF ) THEN - THP0(ISEA) = MOD ( 630-RADE*THP0(ISEA) , 360. ) - END IF - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = THP0 - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, THP0 , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 10 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = 'm' - ENAME = '.hig' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = HSIG - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HSIG , MAPSF, X1 ) - END IF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 11 ) THEN - FLONE = .TRUE. - FSC = 0.002 - UNITS = 'm' - ENAME = '.emc' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = STMAXE - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, STMAXE, MAPSF, X1 ) - END IF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 12 ) THEN - FLONE = .TRUE. - FSC = 0.002 - UNITS = 'm' - ENAME = '.smc' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = STMAXD - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, STMAXD, MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 13 ) THEN - FLONE = .TRUE. - FSC = 0.002 - UNITS = 'm' - ENAME = '.emh' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = HMAXE - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HMAXE, MAPSF, X1 ) - END IF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 14 ) THEN - FLONE = .TRUE. - FSC = 0.002 - UNITS = 'm' - ENAME = '.eml' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = HCMAXE - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HCMAXE, MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 15 ) THEN - FLONE = .TRUE. - FSC = 0.002 - UNITS = 'm' - ENAME = '.smh' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = HMAXD - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HMAXD, MAPSF, X1 ) - END IF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 16 ) THEN - FLONE = .TRUE. - FSC = 0.002 - UNITS = 'm' - ENAME = '.sml' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = HCMAXD - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HCMAXD, MAPSF, X1) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 17 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = '1' - ENAME = '.wbt' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = WBT - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WBT, MAPSF, X1) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 18 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 's' - ENAME = '.tp' - DO I=1,NSEA - IF(FP0(I) .NE. UNDEF) THEN - AUX(I) = 1.0 / FP0(I) - ELSE - AUX(I) = UNDEF - ENDIF - ENDDO + DO ISEA=1, NSEA + IF ( THP0(ISEA) .NE. UNDEF ) THEN + THP0(ISEA) = MOD ( 630-RADE*THP0(ISEA) , 360. ) + END IF + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = THP0 + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, THP0 , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 10 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = 'm' + ENAME = '.hig' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = HSIG + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HSIG , MAPSF, X1 ) + END IF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 11 ) THEN + FLONE = .TRUE. + FSC = 0.002 + UNITS = 'm' + ENAME = '.emc' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = STMAXE + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, STMAXE, MAPSF, X1 ) + END IF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 12 ) THEN + FLONE = .TRUE. + FSC = 0.002 + UNITS = 'm' + ENAME = '.smc' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = STMAXD + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, STMAXD, MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 13 ) THEN + FLONE = .TRUE. + FSC = 0.002 + UNITS = 'm' + ENAME = '.emh' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = HMAXE + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HMAXE, MAPSF, X1 ) + END IF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 14 ) THEN + FLONE = .TRUE. + FSC = 0.002 + UNITS = 'm' + ENAME = '.eml' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = HCMAXE + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HCMAXE, MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 15 ) THEN + FLONE = .TRUE. + FSC = 0.002 + UNITS = 'm' + ENAME = '.smh' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = HMAXD + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HMAXD, MAPSF, X1 ) + END IF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 16 ) THEN + FLONE = .TRUE. + FSC = 0.002 + UNITS = 'm' + ENAME = '.sml' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = HCMAXD + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, HCMAXD, MAPSF, X1) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 17 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = '1' + ENAME = '.wbt' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = WBT + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WBT, MAPSF, X1) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 18 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 's' + ENAME = '.tp' + DO I=1,NSEA + IF(FP0(I) .NE. UNDEF) THEN + AUX(I) = 1.0 / FP0(I) + ELSE + AUX(I) = UNDEF + ENDIF + ENDDO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = AUX - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, AUX, MAPSF, X1) - ENDIF -! - ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = 'm-1' - ENAME = '.wnm' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = WNMEAN - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WNMEAN, MAPSF, X1) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 'm' - ENAME = '.phs' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PHS(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PHS(:,IPART) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 's' - ENAME = '.ptp' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PTP(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PTP(:,IPART) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN - FLONE = .TRUE. - FSC = 1. - UNITS = 'm' - ENAME = '.plp' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PLP(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PLP(:,IPART) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. - FSC = 1. - UNITS = 'degree' - ENAME = '.pdir' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = AUX + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, AUX, MAPSF, X1) + ENDIF + ! + ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = 'm-1' + ENAME = '.wnm' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = WNMEAN + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WNMEAN, MAPSF, X1) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 'm' + ENAME = '.phs' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PHS(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PHS(:,IPART) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 's' + ENAME = '.ptp' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PTP(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PTP(:,IPART) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN + FLONE = .TRUE. + FSC = 1. + UNITS = 'm' + ENAME = '.plp' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PLP(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PLP(:,IPART) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. + FSC = 1. + UNITS = 'degree' + ENAME = '.pdir' #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,IPART), AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,IPART), AnglD, .FALSE.) #endif - DO ISEA=1, NSEA - IF ( PDIR(ISEA,IPART) .NE. UNDEF ) THEN - PDIR(ISEA,IPART) = & - MOD ( 630-RADE*PDIR(ISEA,IPART) , 360. ) - END IF - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PDIR(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PDIR(:,IPART) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN - FLONE = .TRUE. - FSC = 0.1 - UNITS = 'degree' - ENAME = '.pspr' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PSI(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PSI(:,IPART) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = '1' - ENAME = '.pws' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PWS(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PWS(:,IPART) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 7 ) THEN - FLONE = .TRUE. - FSC = 1.0 - UNITS = 'degree' - ENAME = '.pdp' + DO ISEA=1, NSEA + IF ( PDIR(ISEA,IPART) .NE. UNDEF ) THEN + PDIR(ISEA,IPART) = & + MOD ( 630-RADE*PDIR(ISEA,IPART) , 360. ) + END IF + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PDIR(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PDIR(:,IPART) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN + FLONE = .TRUE. + FSC = 0.1 + UNITS = 'degree' + ENAME = '.pspr' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PSI(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PSI(:,IPART) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = '1' + ENAME = '.pws' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PWS(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PWS(:,IPART) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 7 ) THEN + FLONE = .TRUE. + FSC = 1.0 + UNITS = 'degree' + ENAME = '.pdp' #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, PTHP0(:,IPART), AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, PTHP0(:,IPART), AnglD, .FALSE.) #endif - DO ISEA=1, NSEA - IF ( PTHP0(ISEA,IPART) .NE. UNDEF ) THEN - PTHP0(ISEA,IPART) = & - MOD ( 630-RADE*PTHP0(ISEA,IPART) , 360. ) - END IF - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PTHP0(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PTHP0(:,IPART), & - MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 8 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = '1' - ENAME = '.pqp' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PQP(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PQP(:,IPART), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 9 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = '1' - ENAME = '.ppe' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PPE(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PPE(:,IPART), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 10 ) THEN - FLONE = .TRUE. - FSC = 0.0001 - UNITS = 's-1' - ENAME = '.pgw' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PGW(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PGW(:,IPART), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 11 ) THEN - FLONE = .TRUE. - FSC = 0.0001 - UNITS = '1' - ENAME = '.psw' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PSW(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PSW(:,IPART), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 12 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 's' - ENAME = '.ptm10' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PTM1(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PTM1(:,IPART), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 13 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 's' - ENAME = '.pt01' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PT1(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PT1(:,IPART), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 14 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 's' - ENAME = '.pt02' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PT2(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PT2(:,IPART), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 15 ) THEN - FLONE = .TRUE. - FSC = 0.02 - UNITS = 'm2 s rad-1' - ENAME = '.pep' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PEP(:,IPART) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PEP(:,IPART), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = '1' - ENAME = '.tws' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PWST(:) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PWST(:), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17 ) THEN - FLONE = .TRUE. - FSC = 1. - UNITS = '1' - ENAME = '.pnr' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PNR(:) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PNR(:), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 0.001 - ENAME = '.ust' - FORMF = '(1X,20I6)' - UNITS = 'm s-1' + DO ISEA=1, NSEA + IF ( PTHP0(ISEA,IPART) .NE. UNDEF ) THEN + PTHP0(ISEA,IPART) = & + MOD ( 630-RADE*PTHP0(ISEA,IPART) , 360. ) + END IF + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PTHP0(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PTHP0(:,IPART), & + MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 8 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = '1' + ENAME = '.pqp' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PQP(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PQP(:,IPART), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 9 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = '1' + ENAME = '.ppe' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PPE(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PPE(:,IPART), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 10 ) THEN + FLONE = .TRUE. + FSC = 0.0001 + UNITS = 's-1' + ENAME = '.pgw' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PGW(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PGW(:,IPART), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 11 ) THEN + FLONE = .TRUE. + FSC = 0.0001 + UNITS = '1' + ENAME = '.psw' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PSW(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PSW(:,IPART), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 12 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 's' + ENAME = '.ptm10' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PTM1(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PTM1(:,IPART), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 13 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 's' + ENAME = '.pt01' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PT1(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PT1(:,IPART), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 14 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 's' + ENAME = '.pt02' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PT2(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PT2(:,IPART), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 15 ) THEN + FLONE = .TRUE. + FSC = 0.02 + UNITS = 'm2 s rad-1' + ENAME = '.pep' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PEP(:,IPART) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PEP(:,IPART), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = '1' + ENAME = '.tws' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PWST(:) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PWST(:), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17 ) THEN + FLONE = .TRUE. + FSC = 1. + UNITS = '1' + ENAME = '.pnr' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PNR(:) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PNR(:), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 0.001 + ENAME = '.ust' + FORMF = '(1X,20I6)' + UNITS = 'm s-1' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST, USTDIR, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST, USTDIR, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = UST (1:NSEA) - XS2 = USTDIR(1:NSEA) - ELSE - CALL W3S2XY (NSEA,NSEA,NX+1,NY, UST (1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY (NSEA,NSEA,NX+1,NY, USTDIR(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - UABS = SQRT(UST(ISEA)**2+USTDIR(ISEA)**2) - IF ( UST(ISEA) .EQ. UNDEF ) THEN - USTDIR(ISEA) = UNDEF - UABS = UNDEF - ELSE IF ( UABS .GT. 0.05 ) THEN - USTDIR(ISEA) = MOD ( 630. - & - RADE*ATAN2(USTDIR(ISEA),UST(ISEA)) , 360. ) - ELSE - USTDIR(ISEA) = UNDEF - END IF - UST(ISEA) = UABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = UST (1:NSEA) - XS4 = USTDIR(1:NSEA) - ELSE - CALL W3S2XY (NSEA,NSEA,NX+1,NY, UST (1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY (NSEA,NSEA,NX+1,NY, USTDIR(1:NSEA) & - , MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 2 ) THEN - FLONE = .TRUE. - FSC = 1.E-6 - UNITS = '1' - ENAME = '.cha' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = CHARN(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CHARN(1:NSEA) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 3 ) THEN - FLONE = .TRUE. - FSC = 0.1 !0.01 - UNITS = 'kW m-1' - ENAME = '.cge' - DO ISEA=1, NSEA - IF ( CGE(ISEA) .NE. UNDEF ) & - CGE(ISEA) = 0.001 * CGE(ISEA) - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = CGE(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CGE(1:NSEA) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = 'W m-2' - ENAME = '.faw' - DO ISEA=1, NSEA - PHIAW(ISEA)=MIN(99.98,PHIAW(ISEA)) - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PHIAW(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PHIAW(1:NSEA) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 5 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 1.E-6 - UNITS = 'm2 s-2' - ENAME = '.taw' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = UST (1:NSEA) + XS2 = USTDIR(1:NSEA) + ELSE + CALL W3S2XY (NSEA,NSEA,NX+1,NY, UST (1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY (NSEA,NSEA,NX+1,NY, USTDIR(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + UABS = SQRT(UST(ISEA)**2+USTDIR(ISEA)**2) + IF ( UST(ISEA) .EQ. UNDEF ) THEN + USTDIR(ISEA) = UNDEF + UABS = UNDEF + ELSE IF ( UABS .GT. 0.05 ) THEN + USTDIR(ISEA) = MOD ( 630. - & + RADE*ATAN2(USTDIR(ISEA),UST(ISEA)) , 360. ) + ELSE + USTDIR(ISEA) = UNDEF + END IF + UST(ISEA) = UABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = UST (1:NSEA) + XS4 = USTDIR(1:NSEA) + ELSE + CALL W3S2XY (NSEA,NSEA,NX+1,NY, UST (1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY (NSEA,NSEA,NX+1,NY, USTDIR(1:NSEA) & + , MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 2 ) THEN + FLONE = .TRUE. + FSC = 1.E-6 + UNITS = '1' + ENAME = '.cha' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = CHARN(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CHARN(1:NSEA) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 3 ) THEN + FLONE = .TRUE. + FSC = 0.1 !0.01 + UNITS = 'kW m-1' + ENAME = '.cge' + DO ISEA=1, NSEA + IF ( CGE(ISEA) .NE. UNDEF ) & + CGE(ISEA) = 0.001 * CGE(ISEA) + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = CGE(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CGE(1:NSEA) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 'W m-2' + ENAME = '.faw' + DO ISEA=1, NSEA + PHIAW(ISEA)=MIN(99.98,PHIAW(ISEA)) + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PHIAW(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PHIAW(1:NSEA) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 5 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 1.E-6 + UNITS = 'm2 s-2' + ENAME = '.taw' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWIX, TAUWIY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWIX, TAUWIY, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = TAUWIX(1:NSEA) - XS2 = TAUWIY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIX(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIY(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - CABS = SQRT(TAUWIX(ISEA)**2+TAUWIY(ISEA)**2) - IF ( TAUWIX(ISEA) .EQ. UNDEF ) THEN - TAUWIY(ISEA) = UNDEF - CABS = UNDEF - ELSE IF ( TAUWIX(ISEA) .EQ. 0. .AND. & - TAUWIY(ISEA) .EQ. 0. ) THEN - TAUWIY(ISEA) = UNDEF - ELSE - TAUWIY(ISEA) = MOD ( 630. - & - RADE*ATAN2(TAUWIY(ISEA),TAUWIX(ISEA)) , 360. ) - END IF - TAUWIX(ISEA) = CABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = TAUWIX(1:NSEA) - XS4 = TAUWIY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIX(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIY(1:NSEA) & - , MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 6 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 1.E-6 - UNITS = 'm2 s-2' - ENAME = '.twa' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = TAUWIX(1:NSEA) + XS2 = TAUWIY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIX(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIY(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + CABS = SQRT(TAUWIX(ISEA)**2+TAUWIY(ISEA)**2) + IF ( TAUWIX(ISEA) .EQ. UNDEF ) THEN + TAUWIY(ISEA) = UNDEF + CABS = UNDEF + ELSE IF ( TAUWIX(ISEA) .EQ. 0. .AND. & + TAUWIY(ISEA) .EQ. 0. ) THEN + TAUWIY(ISEA) = UNDEF + ELSE + TAUWIY(ISEA) = MOD ( 630. - & + RADE*ATAN2(TAUWIY(ISEA),TAUWIX(ISEA)) , 360. ) + END IF + TAUWIX(ISEA) = CABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = TAUWIX(1:NSEA) + XS4 = TAUWIY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIX(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWIY(1:NSEA) & + , MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 6 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 1.E-6 + UNITS = 'm2 s-2' + ENAME = '.twa' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWNX, TAUWNY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWNX, TAUWNY, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = TAUWNX(1:NSEA) - XS2 = TAUWNY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWNX(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWNY(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - CABS = SQRT(TAUWNX(ISEA)**2+TAUWNY(ISEA)**2) - IF ( TAUWNX(ISEA) .EQ. UNDEF ) THEN - TAUWNY(ISEA) = UNDEF - CABS = UNDEF - ELSE IF ( TAUWNX(ISEA) .EQ. 0. .AND. & - TAUWNY(ISEA) .EQ. 0. ) THEN - TAUWNY(ISEA) = UNDEF - ELSE - TAUWNY(ISEA) = MOD ( 630. - & - RADE*ATAN2(TAUWNY(ISEA),TAUWNX(ISEA)) , 360. ) - END IF - TAUWNX(ISEA) = CABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = TAUWNX(1:NSEA) - XS4 = TAUWNY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWNX(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWNY(1:NSEA) & - , MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 7 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = '1' - ENAME = '.wcc' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = WHITECAP(1:NSEA,1) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WHITECAP(1:NSEA,1) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 8 ) THEN - FLONE = .TRUE. - FSC = 0.1 - UNITS = 'm' - ENAME = '.wcf' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = WHITECAP(1:NSEA,2) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WHITECAP(1:NSEA,2) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 9 ) THEN - FLONE = .TRUE. - FSC = 0.1 - UNITS = 'm' - ENAME = '.wch' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = WHITECAP(1:NSEA,3) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WHITECAP(1:NSEA,3) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 10 ) THEN - FLONE = .TRUE. - FSC = 0.1 - UNITS = '1' - ENAME = '.wcm' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = WHITECAP(1:NSEA,4) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WHITECAP(1:NSEA,4) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 1 ) THEN - FLTRI = .TRUE. - FSC = 10. - UNITS = 'N m-1' - ENAME = '.sxy' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = TAUWNX(1:NSEA) + XS2 = TAUWNY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWNX(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWNY(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + CABS = SQRT(TAUWNX(ISEA)**2+TAUWNY(ISEA)**2) + IF ( TAUWNX(ISEA) .EQ. UNDEF ) THEN + TAUWNY(ISEA) = UNDEF + CABS = UNDEF + ELSE IF ( TAUWNX(ISEA) .EQ. 0. .AND. & + TAUWNY(ISEA) .EQ. 0. ) THEN + TAUWNY(ISEA) = UNDEF + ELSE + TAUWNY(ISEA) = MOD ( 630. - & + RADE*ATAN2(TAUWNY(ISEA),TAUWNX(ISEA)) , 360. ) + END IF + TAUWNX(ISEA) = CABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = TAUWNX(1:NSEA) + XS4 = TAUWNY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWNX(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUWNY(1:NSEA) & + , MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 7 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = '1' + ENAME = '.wcc' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = WHITECAP(1:NSEA,1) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WHITECAP(1:NSEA,1) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 8 ) THEN + FLONE = .TRUE. + FSC = 0.1 + UNITS = 'm' + ENAME = '.wcf' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = WHITECAP(1:NSEA,2) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WHITECAP(1:NSEA,2) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 9 ) THEN + FLONE = .TRUE. + FSC = 0.1 + UNITS = 'm' + ENAME = '.wch' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = WHITECAP(1:NSEA,3) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WHITECAP(1:NSEA,3) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 10 ) THEN + FLONE = .TRUE. + FSC = 0.1 + UNITS = '1' + ENAME = '.wcm' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = WHITECAP(1:NSEA,4) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WHITECAP(1:NSEA,4) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 1 ) THEN + FLTRI = .TRUE. + FSC = 10. + UNITS = 'N m-1' + ENAME = '.sxy' #ifdef W3_RTD - ! Radition stress components are always left on rotated pole - ! at present - need to confirm how to de-rotate (A. Saulter) + ! Radition stress components are always left on rotated pole + ! at present - need to confirm how to de-rotate (A. Saulter) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = SXX(1:NSEA) - XS2 = SYY(1:NSEA) - XS3 = SXY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, SXX(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, SYY(1:NSEA) & - , MAPSF, X2 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, SXY(1:NSEA) & - , MAPSF, XY ) - ENDIF -! - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 2 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 1.E-6 - UNITS = 'm2 s-2' - ENAME = '.two' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = SXX(1:NSEA) + XS2 = SYY(1:NSEA) + XS3 = SXY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, SXX(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, SYY(1:NSEA) & + , MAPSF, X2 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, SXY(1:NSEA) & + , MAPSF, XY ) + ENDIF + ! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 2 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 1.E-6 + UNITS = 'm2 s-2' + ENAME = '.two' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOX, TAUOY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOX, TAUOY, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = TAUOX(1:NSEA) - XS2 = TAUOY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOX(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOY(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - UABS = SQRT(TAUOX(ISEA)**2+TAUOY(ISEA)**2) - IF ( TAUOX(ISEA) .EQ. UNDEF ) THEN - TAUOY(ISEA) = UNDEF - UABS = UNDEF - ELSE IF ( UABS .GT. 1.E-8 ) THEN - TAUOY(ISEA) = MOD ( 630. - & - RADE*ATAN2(TAUOY(ISEA),TAUOX(ISEA)) , 360. ) - ELSE - TAUOY(ISEA) = UNDEF - END IF - TAUOX(ISEA) = UABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = TAUOX(1:NSEA) - XS4 = TAUOY(1:NSEA) - ELSE - CALL W3S2XY (NSEA,NSEA,NX+1,NY, TAUOX(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY (NSEA,NSEA,NX+1,NY, TAUOY(1:NSEA) & - , MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ.3 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = 'N m-1' - ENAME = '.bhd' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = BHD(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BHD(1:NSEA) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. - FSC = 0.1 - UNITS = 'W m-2' - ENAME = '.foc' - DO ISEA=1, NSEA - PHIOC(ISEA)=MIN(99.98,PHIOC(ISEA)) - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PHIOC(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PHIOC(1:NSEA) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 5 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 0.001 - UNITS = 'm2 s-1' - ENAME = '.tus' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = TAUOX(1:NSEA) + XS2 = TAUOY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOX(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOY(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + UABS = SQRT(TAUOX(ISEA)**2+TAUOY(ISEA)**2) + IF ( TAUOX(ISEA) .EQ. UNDEF ) THEN + TAUOY(ISEA) = UNDEF + UABS = UNDEF + ELSE IF ( UABS .GT. 1.E-8 ) THEN + TAUOY(ISEA) = MOD ( 630. - & + RADE*ATAN2(TAUOY(ISEA),TAUOX(ISEA)) , 360. ) + ELSE + TAUOY(ISEA) = UNDEF + END IF + TAUOX(ISEA) = UABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = TAUOX(1:NSEA) + XS4 = TAUOY(1:NSEA) + ELSE + CALL W3S2XY (NSEA,NSEA,NX+1,NY, TAUOX(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY (NSEA,NSEA,NX+1,NY, TAUOY(1:NSEA) & + , MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ.3 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = 'N m-1' + ENAME = '.bhd' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = BHD(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BHD(1:NSEA) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. + FSC = 0.1 + UNITS = 'W m-2' + ENAME = '.foc' + DO ISEA=1, NSEA + PHIOC(ISEA)=MIN(99.98,PHIOC(ISEA)) + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PHIOC(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PHIOC(1:NSEA) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 5 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 0.001 + UNITS = 'm2 s-1' + ENAME = '.tus' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TUSX, TUSY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TUSX, TUSY, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = TUSX(1:NSEA) - XS2 = TUSY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TUSX(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TUSY(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - CABS = SQRT(TUSX(ISEA)**2+TUSY(ISEA)**2) - IF ( TUSX(ISEA) .NE. UNDEF ) THEN - TUSY(ISEA) = MOD ( 630. - & - RADE*ATAN2(TUSY(ISEA),TUSX(ISEA)) , 360. ) - ELSE - TUSY(ISEA) = UNDEF - CABS = UNDEF - END IF - TUSX(ISEA) = CABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = TUSX(1:NSEA) - XS4 = TUSY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY,TUSX,MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY,TUSY,MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 6 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 0.001 - UNITS = 'm s-1' - ENAME = '.uss' - DO ISEA=1, NSEA - IF (USSX(ISEA) .NE. UNDEF ) THEN - USSX(ISEA)=MAX(-0.9998,MIN(0.9998,USSX(ISEA))) - USSY(ISEA)=MAX(-0.9998,MIN(0.9998,USSY(ISEA))) - END IF - END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = TUSX(1:NSEA) + XS2 = TUSY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TUSX(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TUSY(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + CABS = SQRT(TUSX(ISEA)**2+TUSY(ISEA)**2) + IF ( TUSX(ISEA) .NE. UNDEF ) THEN + TUSY(ISEA) = MOD ( 630. - & + RADE*ATAN2(TUSY(ISEA),TUSX(ISEA)) , 360. ) + ELSE + TUSY(ISEA) = UNDEF + CABS = UNDEF + END IF + TUSX(ISEA) = CABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = TUSX(1:NSEA) + XS4 = TUSY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY,TUSX,MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY,TUSY,MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 6 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 0.001 + UNITS = 'm s-1' + ENAME = '.uss' + DO ISEA=1, NSEA + IF (USSX(ISEA) .NE. UNDEF ) THEN + USSX(ISEA)=MAX(-0.9998,MIN(0.9998,USSX(ISEA))) + USSY(ISEA)=MAX(-0.9998,MIN(0.9998,USSY(ISEA))) + END IF + END DO #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSX, USSY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSX, USSY, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = USSX(1:NSEA) - XS2 = USSY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, USSX(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, USSY(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - CABS = SQRT(USSX(ISEA)**2+USSY(ISEA)**2) - IF ( USSX(ISEA) .NE. UNDEF ) THEN - USSY(ISEA) = MOD ( 630. - & - RADE*ATAN2(USSY(ISEA),USSX(ISEA)) , 360. ) - ELSE - USSY(ISEA) = UNDEF - CABS = UNDEF - END IF - USSX(ISEA) = CABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = USSX(1:NSEA) - XS4 = USSY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, USSX(1:NSEA), & - MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, USSY(1:NSEA), & - MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 7 ) THEN - FLTWO = .TRUE. - FSC = 0.01 - ENAME = '.p2s' - UNITS = 'm4' - DO ISEA=1, NSEA - PRMS(ISEA)=PRMS(ISEA) - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PRMS(1:NSEA) - XS2 = TPMS(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1,NY,PRMS,MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1,NY,TPMS,MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 13 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 1.E-6 - UNITS = 'm2 s-2' - ENAME = '.toc' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = USSX(1:NSEA) + XS2 = USSY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, USSX(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, USSY(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + CABS = SQRT(USSX(ISEA)**2+USSY(ISEA)**2) + IF ( USSX(ISEA) .NE. UNDEF ) THEN + USSY(ISEA) = MOD ( 630. - & + RADE*ATAN2(USSY(ISEA),USSX(ISEA)) , 360. ) + ELSE + USSY(ISEA) = UNDEF + CABS = UNDEF + END IF + USSX(ISEA) = CABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = USSX(1:NSEA) + XS4 = USSY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, USSX(1:NSEA), & + MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, USSY(1:NSEA), & + MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 7 ) THEN + FLTWO = .TRUE. + FSC = 0.01 + ENAME = '.p2s' + UNITS = 'm4' + DO ISEA=1, NSEA + PRMS(ISEA)=PRMS(ISEA) + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PRMS(1:NSEA) + XS2 = TPMS(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1,NY,PRMS,MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1,NY,TPMS,MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 13 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 1.E-6 + UNITS = 'm2 s-2' + ENAME = '.toc' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOCX, TAUOCY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOCX, TAUOCY, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = TAUOCX(1:NSEA) - XS2 = TAUOCY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOCX(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOCY(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - UABS = SQRT(TAUOCX(ISEA)**2+TAUOCY(ISEA)**2) - IF ( TAUOCX(ISEA) .EQ. UNDEF ) THEN - TAUOCY(ISEA) = UNDEF - UABS = UNDEF - ELSE IF ( UABS .GT. 1.E-8 ) THEN - TAUOCY(ISEA) = MOD ( 630. - & - RADE*ATAN2(TAUOCY(ISEA),TAUOCX(ISEA)) , 360. ) - ELSE - TAUOCY(ISEA) = UNDEF - END IF - TAUOCX(ISEA) = UABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = TAUOCX(1:NSEA) - XS4 = TAUOCY(1:NSEA) - ELSE - CALL W3S2XY (NSEA,NSEA,NX+1,NY, TAUOCX(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY (NSEA,NSEA,NX+1,NY, TAUOCY(1:NSEA) & - , MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 1 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 0.01 - ENAME = '.abr' - UNITS = 'm' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = TAUOCX(1:NSEA) + XS2 = TAUOCY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOCX(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOCY(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + UABS = SQRT(TAUOCX(ISEA)**2+TAUOCY(ISEA)**2) + IF ( TAUOCX(ISEA) .EQ. UNDEF ) THEN + TAUOCY(ISEA) = UNDEF + UABS = UNDEF + ELSE IF ( UABS .GT. 1.E-8 ) THEN + TAUOCY(ISEA) = MOD ( 630. - & + RADE*ATAN2(TAUOCY(ISEA),TAUOCX(ISEA)) , 360. ) + ELSE + TAUOCY(ISEA) = UNDEF + END IF + TAUOCX(ISEA) = UABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = TAUOCX(1:NSEA) + XS4 = TAUOCY(1:NSEA) + ELSE + CALL W3S2XY (NSEA,NSEA,NX+1,NY, TAUOCX(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY (NSEA,NSEA,NX+1,NY, TAUOCY(1:NSEA) & + , MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 1 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 0.01 + ENAME = '.abr' + UNITS = 'm' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, ABA, ABD, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, ABA, ABD, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = ABA(1:NSEA) - XS2 = ABD(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, ABA(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, ABD(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - IF ( ABA(ISEA) .NE. UNDEF ) THEN - AABS = SQRT(ABA(ISEA)**2+ABD(ISEA)**2) - IF ( AABS .GT. 0.005 ) THEN - ABD(ISEA) = MOD ( 630. - & - RADE*ATAN2(ABD(ISEA),ABA(ISEA)) , 360. ) - ELSE - ABD(ISEA) = UNDEF - END IF - ABA(ISEA) = AABS - END IF - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = ABA(1:NSEA) - XS4 = ABD(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, ABA(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, ABD(1:NSEA) & - , MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 2 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 0.01 - ENAME = '.ubr' - UNITS = 'm s-1' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = ABA(1:NSEA) + XS2 = ABD(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, ABA(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, ABD(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + IF ( ABA(ISEA) .NE. UNDEF ) THEN + AABS = SQRT(ABA(ISEA)**2+ABD(ISEA)**2) + IF ( AABS .GT. 0.005 ) THEN + ABD(ISEA) = MOD ( 630. - & + RADE*ATAN2(ABD(ISEA),ABA(ISEA)) , 360. ) + ELSE + ABD(ISEA) = UNDEF + END IF + ABA(ISEA) = AABS + END IF + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = ABA(1:NSEA) + XS4 = ABD(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, ABA(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, ABD(1:NSEA) & + , MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 2 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 0.01 + ENAME = '.ubr' + UNITS = 'm s-1' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UBA, UBD, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UBA, UBD, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = UBA(1:NSEA) - XS2 = UBD(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UBA(1:NSEA) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UBD(1:NSEA) & - , MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - IF ( UBA(ISEA) .NE. UNDEF ) THEN - UABS = SQRT(UBA(ISEA)**2+UBD(ISEA)**2) - IF ( UABS .GT. 0.005 ) THEN - UBD(ISEA) = MOD ( 630. - & - RADE*ATAN2(UBD(ISEA),UBA(ISEA)) , 360. ) - ELSE - UBD(ISEA) = UNDEF - END IF - UBA(ISEA) = UABS - END IF - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = UBA(1:NSEA) - XS4 = UBD(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UBA(1:NSEA) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UBD(1:NSEA) & - , MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 3 ) THEN - FLTRI = .TRUE. - FSC = 1.E-2 - UNITS = 'm' - ENAME = '.bed' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = UBA(1:NSEA) + XS2 = UBD(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UBA(1:NSEA) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UBD(1:NSEA) & + , MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + IF ( UBA(ISEA) .NE. UNDEF ) THEN + UABS = SQRT(UBA(ISEA)**2+UBD(ISEA)**2) + IF ( UABS .GT. 0.005 ) THEN + UBD(ISEA) = MOD ( 630. - & + RADE*ATAN2(UBD(ISEA),UBA(ISEA)) , 360. ) + ELSE + UBD(ISEA) = UNDEF + END IF + UBA(ISEA) = UABS + END IF + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = UBA(1:NSEA) + XS4 = UBD(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UBA(1:NSEA) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, UBD(1:NSEA) & + , MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 3 ) THEN + FLTRI = .TRUE. + FSC = 1.E-2 + UNITS = 'm' + ENAME = '.bed' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, BEDFORMS(1:NSEA,2), & - BEDFORMS(1:NSEA,3), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, BEDFORMS(1:NSEA,2), & + BEDFORMS(1:NSEA,3), AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = BEDFORMS(1:NSEA,1) - XS2 = BEDFORMS(1:NSEA,2) - XS3 = BEDFORMS(1:NSEA,3) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BEDFORMS(1:NSEA,1) & - , MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BEDFORMS(1:NSEA,2) & - , MAPSF, X2 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BEDFORMS(1:NSEA,3) & - , MAPSF, XY ) - ENDIF -! - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. - FSC = 0.1 - UNITS = 'W m-2' - ENAME = '.fbb' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = PHIBBL(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PHIBBL(1:NSEA) & - , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 5 ) THEN - FLTWO = .TRUE. - FSC = 1.E-6 - UNITS = 'm2 s-2' - ENAME = '.tbb' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = BEDFORMS(1:NSEA,1) + XS2 = BEDFORMS(1:NSEA,2) + XS3 = BEDFORMS(1:NSEA,3) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BEDFORMS(1:NSEA,1) & + , MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BEDFORMS(1:NSEA,2) & + , MAPSF, X2 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BEDFORMS(1:NSEA,3) & + , MAPSF, XY ) + ENDIF + ! + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. + FSC = 0.1 + UNITS = 'W m-2' + ENAME = '.fbb' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = PHIBBL(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, PHIBBL(1:NSEA) & + , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 5 ) THEN + FLTWO = .TRUE. + FSC = 1.E-6 + UNITS = 'm2 s-2' + ENAME = '.tbb' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUBBL(1:NSEA,1), & - TAUBBL(1:NSEA,2), AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUBBL(1:NSEA,1), & + TAUBBL(1:NSEA,2), AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = TAUBBL(1:NSEA,1) - XS2 = TAUBBL(1:NSEA,2) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUBBL(1:NSEA,1) & - , MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUBBL(1:NSEA,2) & - , MAPSF, XY ) - ENDIF -! - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 1 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 1.E-6 - ENAME = '.mss' - FORMF = '(1X,20I6)' - UNITS = '1' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = TAUBBL(1:NSEA,1) + XS2 = TAUBBL(1:NSEA,2) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUBBL(1:NSEA,1) & + , MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUBBL(1:NSEA,2) & + , MAPSF, XY ) + ENDIF + ! + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 1 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 1.E-6 + ENAME = '.mss' + FORMF = '(1X,20I6)' + UNITS = '1' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSSX, MSSY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSSX, MSSY, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = MSSX(1:NSEA) - XS2 = MSSY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSSX(1:NSEA), & - MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY ,MSSY(1:NSEA), & - MAPSF, XY ) - ENDIF -! - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 2 ) THEN - IF ( VECTOR ) THEN - FLTWO = .TRUE. - ELSE - FLDIR = .TRUE. - END IF - FSC = 0.00001 - ENAME = '.msc' - UNITS = '1' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = MSSX(1:NSEA) + XS2 = MSSY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSSX(1:NSEA), & + MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY ,MSSY(1:NSEA), & + MAPSF, XY ) + ENDIF + ! + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 2 ) THEN + IF ( VECTOR ) THEN + FLTWO = .TRUE. + ELSE + FLDIR = .TRUE. + END IF + FSC = 0.00001 + ENAME = '.msc' + UNITS = '1' #ifdef W3_RTD - ! Rotate x,y vector back to standard pole - IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSCX, MSCY, AnglD) + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSCX, MSCY, AnglD) #endif - IF ( ITYPE .EQ. 4 ) THEN - XS1 = MSCX(1:NSEA) - XS2 = MSCY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSCX(1:NSEA), & - MAPSF, XX ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSCY(1:NSEA), & - MAPSF, XY ) - ENDIF - DO ISEA=1, NSEA - CABS = SQRT(MSCX(ISEA)**2+MSCY(ISEA)**2) - IF ( MSCX(ISEA) .EQ. UNDEF ) THEN - MSCY(ISEA) = UNDEF - CABS = UNDEF - ELSE IF ( MSCX(ISEA) .EQ. 0. .AND. & - MSCY(ISEA) .EQ. 0. ) THEN - MSCY(ISEA) = UNDEF - ELSE - MSCY(ISEA) = MOD ( 630. - & - RADE*ATAN2(MSCY(ISEA),MSCX(ISEA)) , 360. ) - END IF - MSCX(ISEA) = CABS - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS3 = MSCX(1:NSEA) - XS4 = MSCY(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSCX(1:NSEA), & - MAPSF, X1 ) - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSCY(1:NSEA), & - MAPSF, X2 ) - ENDIF -! - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 3 ) THEN - FLONE = .TRUE. - FSC = 0.1 - UNITS = 'degree' - ENAME = '.msd' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = MSCX(1:NSEA) + XS2 = MSCY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSCX(1:NSEA), & + MAPSF, XX ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSCY(1:NSEA), & + MAPSF, XY ) + ENDIF + DO ISEA=1, NSEA + CABS = SQRT(MSCX(ISEA)**2+MSCY(ISEA)**2) + IF ( MSCX(ISEA) .EQ. UNDEF ) THEN + MSCY(ISEA) = UNDEF + CABS = UNDEF + ELSE IF ( MSCX(ISEA) .EQ. 0. .AND. & + MSCY(ISEA) .EQ. 0. ) THEN + MSCY(ISEA) = UNDEF + ELSE + MSCY(ISEA) = MOD ( 630. - & + RADE*ATAN2(MSCY(ISEA),MSCX(ISEA)) , 360. ) + END IF + MSCX(ISEA) = CABS + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS3 = MSCX(1:NSEA) + XS4 = MSCY(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSCX(1:NSEA), & + MAPSF, X1 ) + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSCY(1:NSEA), & + MAPSF, X2 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 3 ) THEN + FLONE = .TRUE. + FSC = 0.1 + UNITS = 'degree' + ENAME = '.msd' #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSSD, AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSSD, AnglD, .FALSE.) #endif - DO ISEA=1, NSEA - IF ( MSSD(ISEA) .NE. UNDEF ) THEN - MSSD(ISEA) = MOD ( 630. - RADE*MSSD(ISEA) , 180. ) - END IF - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = MSSD(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSSD(1:NSEA), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. - FSC = 0.1 - UNITS = 'degree' - ENAME = '.mcd' + DO ISEA=1, NSEA + IF ( MSSD(ISEA) .NE. UNDEF ) THEN + MSSD(ISEA) = MOD ( 630. - RADE*MSSD(ISEA) , 180. ) + END IF + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = MSSD(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSSD(1:NSEA), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. + FSC = 0.1 + UNITS = 'degree' + ENAME = '.mcd' #ifdef W3_RTD - ! Rotate direction back to standard pole - IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSCD, AnglD, .FALSE.) + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSCD, AnglD, .FALSE.) #endif - DO ISEA=1, NSEA - IF ( MSCD(ISEA) .NE. UNDEF ) THEN - MSCD(ISEA) = MOD ( 630. - RADE*MSCD(ISEA) , 180. ) - END IF - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = MSCD(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSCD(1:NSEA), MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 5 ) THEN - FLONE = .TRUE. - FSC = 0.01 - UNITS = '1' - ENAME = '.qp' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = QP - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, QP, MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN - FLONE = .TRUE. - FSC = 0.1 - UNITS = 'min.' - ENAME = '.dtd' - DO ISEA=1, NSEA - IF ( DTDYN(ISEA) .NE. UNDEF ) & - DTDYN(ISEA) = DTDYN(ISEA) / 60. - END DO - IF ( ITYPE .EQ. 4 ) THEN - XS1 = DTDYN(1:NSEA) - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, DTDYN , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = 's-1' - ENAME = '.fc' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = FCUT - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, FCUT , MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN - FLONE = .TRUE. - FSC = 0.001 - FSC = 1. - UNITS = '1' - ENAME = '.cfx' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = CFLXYMAX - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CFLXYMAX, MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = '1' - ENAME = '.cfd' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = CFLTHMAX - ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CFLTHMAX, MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 5 ) THEN - FLONE = .TRUE. - FSC = 0.001 - UNITS = '1' - ENAME = '.cfk' - IF ( ITYPE .EQ. 4 ) THEN - XS1 = CFLKMAX + DO ISEA=1, NSEA + IF ( MSCD(ISEA) .NE. UNDEF ) THEN + MSCD(ISEA) = MOD ( 630. - RADE*MSCD(ISEA) , 180. ) + END IF + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = MSCD(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, MSCD(1:NSEA), MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 5 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = '1' + ENAME = '.qp' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = QP + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, QP, MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN + FLONE = .TRUE. + FSC = 0.1 + UNITS = 'min.' + ENAME = '.dtd' + DO ISEA=1, NSEA + IF ( DTDYN(ISEA) .NE. UNDEF ) & + DTDYN(ISEA) = DTDYN(ISEA) / 60. + END DO + IF ( ITYPE .EQ. 4 ) THEN + XS1 = DTDYN(1:NSEA) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, DTDYN , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = 's-1' + ENAME = '.fc' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = FCUT + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, FCUT , MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN + FLONE = .TRUE. + FSC = 0.001 + FSC = 1. + UNITS = '1' + ENAME = '.cfx' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = CFLXYMAX + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CFLXYMAX, MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = '1' + ENAME = '.cfd' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = CFLTHMAX + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CFLTHMAX, MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 5 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = '1' + ENAME = '.cfk' + IF ( ITYPE .EQ. 4 ) THEN + XS1 = CFLKMAX + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CFLKMAX, MAPSF, X1 ) + ENDIF + ! + ELSE IF ( IFI .EQ. 10 ) THEN + FLONE = .TRUE. + FSC = 1. + UNITS = 'TBD' + WRITE (ENAME,'(A2,I2.2)') '.u', IFJ + IF ( ITYPE .EQ. 4 ) THEN + XS1 = USERO(:,IFJ) + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, USERO(:,IFJ) & + , MAPSF, X1 ) + ENDIF + ! + ELSE + WRITE (NDSE,990) IFI,IFJ + WRITE (NDSE,999) + CALL EXTCDE ( 1 ) + ! + END IF + ! + ! 2.b Make map + ! + DO IX=1, NX + DO IY=1, NY + IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN + X1(IX,IY) = UNDEF + X2(IX,IY) = UNDEF + XX(IX,IY) = UNDEF + XY(IX,IY) = UNDEF + END IF + IF ( X1(IX,IY) .EQ. UNDEF ) THEN + MAP(IX,IY) = 0 + ELSE + MAP(IX,IY) = 1 + END IF + IF ( X2(IX,IY) .EQ. UNDEF ) THEN + MP2(IX,IY) = 0 + ELSE + MP2(IX,IY) = 1 + END IF + END DO + END DO + ! + ! 2.c Perform output type 1 ( print plots ) + ! + IF ( ITYPE .EQ. 1 ) THEN + ! + IF ( SCALE ) THEN + FSC = 0. + FSCA = 0. + ELSE + FSCA = 1. + END IF + IXB = IX1 - IXS + ! + DO IB=1, NBLOK + IXA = IXB + IXS + IXB = IXA + (NXMAX-1)*IXS + IXB = MIN ( IXB , IXN ) + IF ( FLTRI ) THEN + CALL PRTBLK (NDSO, NX, NY, NX+1, X1, MAP, 0, & + FSC, IXA, IXB, IXS, IY1, IYN, IYS, & + IDOUT(IFI,IFJ), UNITS) + CALL PRTBLK (NDSO, NX, NY, NX+1, X2, MAP, 0, & + FSC, IXA, IXB, IXS, IY1, IYN, IYS, & + IDOUT(IFI,IFJ), UNITS) + CALL PRTBLK (NDSO, NX, NY, NX+1, XY, MAP, 0, & + FSC, IXA, IXB, IXS, IY1, IYN, IYS, & + IDOUT(IFI,IFJ), UNITS) + ELSE IF ( FLONE ) THEN + CALL PRTBLK (NDSO, NX, NY, NX+1, X1, MAP, 0, & + FSC, IXA, IXB, IXS, IY1, IYN, IYS, & + IDOUT(IFI,IFJ), UNITS) + ELSE IF ( FLTWO ) THEN + CALL PRTBLK (NDSO, NX, NY, NX+1, XX, MAP, 0, & + FSC, IXA, IXB, IXS, IY1, IYN, IYS, & + IDOUT(IFI,IFJ), UNITS) + CALL PRTBLK (NDSO, NX, NY, NX+1, XY, MAP, 0, & + FSC, IXA, IXB, IXS, IY1, IYN, IYS, & + IDOUT(IFI,IFJ), UNITS) + ELSE IF ( FLDIR ) THEN + CALL PRTBLK (NDSO, NX, NY, NX+1, X1, MAP, 0, & + FSC, IXA, IXB, IXS, IY1, IYN, IYS, & + IDOUT(IFI,IFJ), UNITS) + CALL PRTBLK (NDSO, NX, NY, NX+1, X2, MP2, 0, & + FSCA, IXA, IXB, IXS, IY1, IYN, IYS, & + IDOUT(IFI,IFJ), 'Deg.') + END IF + END DO + ! + ! 2.d Perform output type 2 ( statistics ) + ! + ELSE IF ( ITYPE .EQ. 2 ) THEN + XMIN = 1.E20 + XMAX = -1.E20 + XDS = 0.D0 + XDSQ = 0.D0 + NINGRD = 0 + ! + DO IX=IX1, IXN + DO IY=IY1, IYN + IF ( MAPSTA(IY,IX) .GT. 0 .AND. & + X1(IX,IY) .NE. UNDEF ) THEN + NINGRD = NINGRD + 1 + XMIN = MIN ( XMIN , X1(IX,IY) ) + XMAX = MAX ( XMAX , X1(IX,IY) ) + XDS = XDS + DBLE(X1(IX,IY)) + XDSQ = XDSQ + DBLE(X1(IX,IY))**2 + END IF + END DO + END DO + ! + NDSDT = NDSDT + 1 + ! + IF ( NINGRD .EQ. 0 ) THEN + WRITE (NDSDT,940) TIME(1), IH, IM, IS + ELSE IF ( NINGRD .LE. 2 ) THEN + XAVG = REAL ( XDS / DBLE(NINGRD) ) + WRITE (NDSDT,940) TIME(1), IH, IM, IS, & + XMIN, XMAX + ELSE + XAVG = REAL ( XDS / DBLE(NINGRD) ) + XSTD = REAL ( ( XDSQ - XDS**2/DBLE(NINGRD) ) & + / DBLE(NINGRD-1) ) + XSTD = SQRT ( MAX ( XSTD , 0. ) ) + WRITE (NDSDT,940) TIME(1), IH, IM, IS, & + XMIN, XMAX, XAVG, XSTD + END IF + ! + ! 2.e Perform output type 3 ( file ) + ! + ELSE IF ( ITYPE .EQ. 3 ) THEN + ! + FNAME(13:) = ENAME + IF ( IDFM .EQ. 3 ) THEN + IF(GTYPE .NE. UNGTYPE) THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSDAT,FILE=FNMPRE(:JJ)//FNAME, & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) + WRITE (NDSDAT) FILEID, TIME, & + MINVAL(XGRD(IY1:IYN,IX1:IXN)), & + MAXVAL(XGRD(IY1:IYN,IX1:IXN)), IXN-IX1+1, & + MINVAL(YGRD(IY1:IYN,IX1:IXN)), & + MAXVAL(YGRD(IY1:IYN,IX1:IXN)), IYN-IY1+1, & + ENAME, FSC, UNITS, IDLA, IDFM, FORMF, MFILL + ELSE + OPEN (NDSDAT,FILE=FNAME, & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) + WRITE (NDSDAT) FILEID, TIME, & + X0,MAXX,NX, & + Y0,MAXY,NY, & + ENAME, FSC, UNITS, IDLA, IDFM, FORMF, MFILL + ENDIF + ELSE + IF(GTYPE .NE. UNGTYPE) THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSDAT,FILE=FNMPRE(:JJ)//FNAME,ERR=800, & + IOSTAT=IERR) + IF (FSC.LT.1E-4) THEN + WRITE(FSCS,'(G7.1)') FSC ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, CFLKMAX, MAPSF, X1 ) - ENDIF -! - ELSE IF ( IFI .EQ. 10 ) THEN - FLONE = .TRUE. - FSC = 1. - UNITS = 'TBD' - WRITE (ENAME,'(A2,I2.2)') '.u', IFJ - IF ( ITYPE .EQ. 4 ) THEN - XS1 = USERO(:,IFJ) + WRITE(FSCS,'(F7.4)') FSC + END IF + IF ( FLAGLL ) THEN + WRITE (NDSDAT,950) FILEID, TIME, & + MINVAL(XGRD(IY1:IYN,IX1:IXN)), & + MAXVAL(XGRD(IY1:IYN,IX1:IXN)), IXN-IX1+1, & + MINVAL(YGRD(IY1:IYN,IX1:IXN)), & + MAXVAL(YGRD(IY1:IYN,IX1:IXN)), IYN-IY1+1, & + ENAME, FSCS, UNITS, IDLA, IDFM, FORMF, MFILL ELSE - CALL W3S2XY ( NSEA, NSEA, NX+1, NY, USERO(:,IFJ) & - , MAPSF, X1 ) - ENDIF -! + WRITE (NDSDAT,960) FILEID, TIME, & + MINVAL(XGRD(IY1:IYN,IX1:IXN)), & + MAXVAL(XGRD(IY1:IYN,IX1:IXN)), IXN-IX1+1, & + MINVAL(YGRD(IY1:IYN,IX1:IXN)), & + MAXVAL(YGRD(IY1:IYN,IX1:IXN)), IYN-IY1+1, & + ENAME, FSCS, UNITS, IDLA, IDFM, FORMF, MFILL + END IF ELSE - WRITE (NDSE,990) IFI,IFJ - WRITE (NDSE,999) - CALL EXTCDE ( 1 ) -! - END IF -! -! 2.b Make map -! - DO IX=1, NX - DO IY=1, NY - IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN - X1(IX,IY) = UNDEF - X2(IX,IY) = UNDEF - XX(IX,IY) = UNDEF - XY(IX,IY) = UNDEF - END IF - IF ( X1(IX,IY) .EQ. UNDEF ) THEN - MAP(IX,IY) = 0 - ELSE - MAP(IX,IY) = 1 - END IF - IF ( X2(IX,IY) .EQ. UNDEF ) THEN - MP2(IX,IY) = 0 + OPEN (NDSDAT,FILE=FNAME, & + ERR=800,IOSTAT=IERR) + WRITE (NDSDAT, 949) FILEID, TIME, & + X0,MAXX,NX, & + Y0,MAXY,NY, & + ENAME, FSC, UNITS, IDLA, IDFM, FORMF, MFILL + ENDIF + END IF + ! + IF ( FLTRI ) THEN + DO IX=IX1, IXN + DO IY=IY1, IYN + IF ( MAPSTA(IY,IX) .LE. 0 .OR. & + XX(IX,IY) .EQ. UNDEF ) THEN + MXX(IX,IY) = MFILL + MYY(IX,IY) = MFILL + MXY(IX,IY) = MFILL ELSE - MP2(IX,IY) = 1 + MXX(IX,IY) = NINT(X1(IX,IY)/FSC) + MYY(IX,IY) = NINT(X2(IX,IY)/FSC) + MXY(IX,IY) = NINT(XY(IX,IY)/FSC) END IF END DO END DO -! -! 2.c Perform output type 1 ( print plots ) -! - IF ( ITYPE .EQ. 1 ) THEN -! - IF ( SCALE ) THEN - FSC = 0. - FSCA = 0. - ELSE - FSCA = 1. - END IF - IXB = IX1 - IXS -! - DO IB=1, NBLOK - IXA = IXB + IXS - IXB = IXA + (NXMAX-1)*IXS - IXB = MIN ( IXB , IXN ) - IF ( FLTRI ) THEN - CALL PRTBLK (NDSO, NX, NY, NX+1, X1, MAP, 0, & - FSC, IXA, IXB, IXS, IY1, IYN, IYS, & - IDOUT(IFI,IFJ), UNITS) - CALL PRTBLK (NDSO, NX, NY, NX+1, X2, MAP, 0, & - FSC, IXA, IXB, IXS, IY1, IYN, IYS, & - IDOUT(IFI,IFJ), UNITS) - CALL PRTBLK (NDSO, NX, NY, NX+1, XY, MAP, 0, & - FSC, IXA, IXB, IXS, IY1, IYN, IYS, & - IDOUT(IFI,IFJ), UNITS) - ELSE IF ( FLONE ) THEN - CALL PRTBLK (NDSO, NX, NY, NX+1, X1, MAP, 0, & - FSC, IXA, IXB, IXS, IY1, IYN, IYS, & - IDOUT(IFI,IFJ), UNITS) - ELSE IF ( FLTWO ) THEN - CALL PRTBLK (NDSO, NX, NY, NX+1, XX, MAP, 0, & - FSC, IXA, IXB, IXS, IY1, IYN, IYS, & - IDOUT(IFI,IFJ), UNITS) - CALL PRTBLK (NDSO, NX, NY, NX+1, XY, MAP, 0, & - FSC, IXA, IXB, IXS, IY1, IYN, IYS, & - IDOUT(IFI,IFJ), UNITS) - ELSE IF ( FLDIR ) THEN - CALL PRTBLK (NDSO, NX, NY, NX+1, X1, MAP, 0, & - FSC, IXA, IXB, IXS, IY1, IYN, IYS, & - IDOUT(IFI,IFJ), UNITS) - CALL PRTBLK (NDSO, NX, NY, NX+1, X2, MP2, 0, & - FSCA, IXA, IXB, IXS, IY1, IYN, IYS, & - IDOUT(IFI,IFJ), 'Deg.') + IF ( IDLA .NE. 5 ) THEN + CALL OUTA2I ( MXX, NX, NY, IX1, IXN, IY1, IYN, & + NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1, 0 ) + CALL OUTA2I ( MYY, NX, NY, IX1, IXN, IY1, IYN, & + NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1, 0 ) + CALL OUTA2I ( MXY, NX, NY, IX1, IXN, IY1, IYN, & + NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1, 0 ) + ELSE + DO IY=IY1,IYN + YGBX = Y0 + REAL(IY-1)*SY + DO IX=IX1, IXN + XGBX = X0 + REAL(IX-1)*SX + IF ( MXX(IX,IY) .NE. MFILL ) THEN + IF ( IDFM .EQ. 3 ) THEN + WRITE (NDSDAT) & + XGBX, YGBX, MXX(IX,IY), MYY(IX,IY) + ELSE + WRITE (NDSDAT,951) & + XGBX, YGBX, MXX(IX,IY), MYY(IX,IY) + END IF END IF END DO -! -! 2.d Perform output type 2 ( statistics ) -! - ELSE IF ( ITYPE .EQ. 2 ) THEN - XMIN = 1.E20 - XMAX = -1.E20 - XDS = 0.D0 - XDSQ = 0.D0 - NINGRD = 0 -! + END DO + END IF + ELSE + IF ( FLTWO .OR. FLDIR ) THEN DO IX=IX1, IXN DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .GT. 0 .AND. & - X1(IX,IY) .NE. UNDEF ) THEN - NINGRD = NINGRD + 1 - XMIN = MIN ( XMIN , X1(IX,IY) ) - XMAX = MAX ( XMAX , X1(IX,IY) ) - XDS = XDS + DBLE(X1(IX,IY)) - XDSQ = XDSQ + DBLE(X1(IX,IY))**2 - END IF - END DO + IF ( MAPSTA(IY,IX) .LE. 0 .OR. & + XX(IX,IY) .EQ. UNDEF ) THEN + MXX(IX,IY) = MFILL + MYY(IX,IY) = MFILL + ELSE + MXX(IX,IY) = NINT(XX(IX,IY)/FSC) + MYY(IX,IY) = NINT(XY(IX,IY)/FSC) + END IF END DO -! - NDSDT = NDSDT + 1 -! - IF ( NINGRD .EQ. 0 ) THEN - WRITE (NDSDT,940) TIME(1), IH, IM, IS - ELSE IF ( NINGRD .LE. 2 ) THEN - XAVG = REAL ( XDS / DBLE(NINGRD) ) - WRITE (NDSDT,940) TIME(1), IH, IM, IS, & - XMIN, XMAX - ELSE - XAVG = REAL ( XDS / DBLE(NINGRD) ) - XSTD = REAL ( ( XDSQ - XDS**2/DBLE(NINGRD) ) & - / DBLE(NINGRD-1) ) - XSTD = SQRT ( MAX ( XSTD , 0. ) ) - WRITE (NDSDT,940) TIME(1), IH, IM, IS, & - XMIN, XMAX, XAVG, XSTD - END IF -! -! 2.e Perform output type 3 ( file ) -! - ELSE IF ( ITYPE .EQ. 3 ) THEN -! - FNAME(13:) = ENAME - IF ( IDFM .EQ. 3 ) THEN - IF(GTYPE .NE. UNGTYPE) THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSDAT,FILE=FNMPRE(:JJ)//FNAME, & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) - WRITE (NDSDAT) FILEID, TIME, & - MINVAL(XGRD(IY1:IYN,IX1:IXN)), & - MAXVAL(XGRD(IY1:IYN,IX1:IXN)), IXN-IX1+1, & - MINVAL(YGRD(IY1:IYN,IX1:IXN)), & - MAXVAL(YGRD(IY1:IYN,IX1:IXN)), IYN-IY1+1, & - ENAME, FSC, UNITS, IDLA, IDFM, FORMF, MFILL - ELSE - OPEN (NDSDAT,FILE=FNAME, & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) - WRITE (NDSDAT) FILEID, TIME, & - X0,MAXX,NX, & - Y0,MAXY,NY, & - ENAME, FSC, UNITS, IDLA, IDFM, FORMF, MFILL - ENDIF + END DO + IF ( IDLA .NE. 5 ) THEN + CALL OUTA2I ( MXX, NX, NY, IX1, IXN, IY1, IYN, & + NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1,0) + CALL OUTA2I ( MYY, NX, NY, IX1, IXN, IY1, IYN, & + NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1,0) ELSE - IF(GTYPE .NE. UNGTYPE) THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSDAT,FILE=FNMPRE(:JJ)//FNAME,ERR=800, & - IOSTAT=IERR) - IF (FSC.LT.1E-4) THEN - WRITE(FSCS,'(G7.1)') FSC - ELSE - WRITE(FSCS,'(F7.4)') FSC - END IF - IF ( FLAGLL ) THEN - WRITE (NDSDAT,950) FILEID, TIME, & - MINVAL(XGRD(IY1:IYN,IX1:IXN)), & - MAXVAL(XGRD(IY1:IYN,IX1:IXN)), IXN-IX1+1, & - MINVAL(YGRD(IY1:IYN,IX1:IXN)), & - MAXVAL(YGRD(IY1:IYN,IX1:IXN)), IYN-IY1+1, & - ENAME, FSCS, UNITS, IDLA, IDFM, FORMF, MFILL - ELSE - WRITE (NDSDAT,960) FILEID, TIME, & - MINVAL(XGRD(IY1:IYN,IX1:IXN)), & - MAXVAL(XGRD(IY1:IYN,IX1:IXN)), IXN-IX1+1, & - MINVAL(YGRD(IY1:IYN,IX1:IXN)), & - MAXVAL(YGRD(IY1:IYN,IX1:IXN)), IYN-IY1+1, & - ENAME, FSCS, UNITS, IDLA, IDFM, FORMF, MFILL - END IF - ELSE - OPEN (NDSDAT,FILE=FNAME, & - ERR=800,IOSTAT=IERR) - WRITE (NDSDAT, 949) FILEID, TIME, & - X0,MAXX,NX, & - Y0,MAXY,NY, & - ENAME, FSC, UNITS, IDLA, IDFM, FORMF, MFILL - ENDIF - END IF -! - IF ( FLTRI ) THEN - DO IX=IX1, IXN - DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR. & - XX(IX,IY) .EQ. UNDEF ) THEN - MXX(IX,IY) = MFILL - MYY(IX,IY) = MFILL - MXY(IX,IY) = MFILL - ELSE - MXX(IX,IY) = NINT(X1(IX,IY)/FSC) - MYY(IX,IY) = NINT(X2(IX,IY)/FSC) - MXY(IX,IY) = NINT(XY(IX,IY)/FSC) - END IF - END DO - END DO - IF ( IDLA .NE. 5 ) THEN - CALL OUTA2I ( MXX, NX, NY, IX1, IXN, IY1, IYN, & - NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1, 0 ) - CALL OUTA2I ( MYY, NX, NY, IX1, IXN, IY1, IYN, & - NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1, 0 ) - CALL OUTA2I ( MXY, NX, NY, IX1, IXN, IY1, IYN, & - NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1, 0 ) - ELSE - DO IY=IY1,IYN - YGBX = Y0 + REAL(IY-1)*SY - DO IX=IX1, IXN - XGBX = X0 + REAL(IX-1)*SX - IF ( MXX(IX,IY) .NE. MFILL ) THEN - IF ( IDFM .EQ. 3 ) THEN - WRITE (NDSDAT) & - XGBX, YGBX, MXX(IX,IY), MYY(IX,IY) - ELSE - WRITE (NDSDAT,951) & - XGBX, YGBX, MXX(IX,IY), MYY(IX,IY) - END IF - END IF - END DO - END DO - END IF - ELSE - IF ( FLTWO .OR. FLDIR ) THEN + DO IY=IY1,IYN DO IX=IX1, IXN - DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR. & - XX(IX,IY) .EQ. UNDEF ) THEN - MXX(IX,IY) = MFILL - MYY(IX,IY) = MFILL + YGBX = YGRD(IY,IX) + XGBX = XGRD(IY,IX) + IF ( MXX(IX,IY) .NE. MFILL ) THEN + IF ( IDFM .EQ. 3 ) THEN + WRITE (NDSDAT) & + XGBX, YGBX, MXX(IX,IY), MYY(IX,IY) + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSDAT,951) XGBX, YGBX, & + MXX(IX,IY), MYY(IX,IY) ELSE - MXX(IX,IY) = NINT(XX(IX,IY)/FSC) - MYY(IX,IY) = NINT(XY(IX,IY)/FSC) + WRITE (NDSDAT,961) XGBX, YGBX, & + MXX(IX,IY), MYY(IX,IY) END IF - END DO - END DO - IF ( IDLA .NE. 5 ) THEN - CALL OUTA2I ( MXX, NX, NY, IX1, IXN, IY1, IYN, & - NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1,0) - CALL OUTA2I ( MYY, NX, NY, IX1, IXN, IY1, IYN, & - NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1,0) - ELSE - DO IY=IY1,IYN - DO IX=IX1, IXN - YGBX = YGRD(IY,IX) - XGBX = XGRD(IY,IX) - IF ( MXX(IX,IY) .NE. MFILL ) THEN - IF ( IDFM .EQ. 3 ) THEN - WRITE (NDSDAT) & - XGBX, YGBX, MXX(IX,IY), MYY(IX,IY) - ELSE - IF ( FLAGLL ) THEN - WRITE (NDSDAT,951) XGBX, YGBX, & - MXX(IX,IY), MYY(IX,IY) - ELSE - WRITE (NDSDAT,961) XGBX, YGBX, & - MXX(IX,IY), MYY(IX,IY) - END IF - END IF - END IF - END DO - END DO + END IF END IF - ELSE + END DO + END DO + END IF + ELSE + DO IX=IX1, IXN + DO IY=IY1, IYN + IF ( MAPSTA(IY,IX) .LE. 0 .OR. & + X1(IX,IY) .EQ. UNDEF ) THEN + MX1(IX,IY) = MFILL + ELSE + MX1(IX,IY) = NINT(X1(IX,IY)/FSC) + END IF + END DO + END DO + IF ( IDLA .NE. 5 ) THEN + CALL OUTA2I ( MX1, NX, NY, IX1, IXN, IY1, IYN, & + NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1,0) + ELSE + DO IY=IY1,IYN DO IX=IX1, IXN - DO IY=IY1, IYN - IF ( MAPSTA(IY,IX) .LE. 0 .OR. & - X1(IX,IY) .EQ. UNDEF ) THEN - MX1(IX,IY) = MFILL + YGBX = YGRD(IY,IX) + XGBX = XGRD(IY,IX) + IF ( MX1(IX,IY) .NE. MFILL ) THEN + IF ( IDFM .EQ. 3 ) THEN + WRITE (NDSDAT) & + XGBX, YGBX, MX1(IX,IY) + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSDAT,951) XGBX, YGBX, & + MX1(IX,IY) ELSE - MX1(IX,IY) = NINT(X1(IX,IY)/FSC) + WRITE (NDSDAT,961) XGBX, YGBX, & + MX1(IX,IY) END IF - END DO - END DO - IF ( IDLA .NE. 5 ) THEN - CALL OUTA2I ( MX1, NX, NY, IX1, IXN, IY1, IYN, & - NDSDAT, NDST, NDSE, IDFM, FORMF, IDLA, 1,0) - ELSE - DO IY=IY1,IYN - DO IX=IX1, IXN - YGBX = YGRD(IY,IX) - XGBX = XGRD(IY,IX) - IF ( MX1(IX,IY) .NE. MFILL ) THEN - IF ( IDFM .EQ. 3 ) THEN - WRITE (NDSDAT) & - XGBX, YGBX, MX1(IX,IY) - ELSE - IF ( FLAGLL ) THEN - WRITE (NDSDAT,951) XGBX, YGBX, & - MX1(IX,IY) - ELSE - WRITE (NDSDAT,961) XGBX, YGBX, & - MX1(IX,IY) - END IF - END IF - END IF - END DO - END DO + END IF END IF - END IF - END IF -! - CLOSE (NDSDAT) -! - ELSE IF ( ITYPE .EQ. 4 ) THEN -! - FNAME(13:) = ENAME - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSDAT,FILE=FNMPRE(:JJ)//FNAME,ERR=800, & - IOSTAT=IERR) - WRITE (6,*) FNAME(1:16) -! - IF ( FLTRI ) THEN - WRITE (NDSDAT,980) FILEID, TIME, NSEA, 3, & - FSC, ENAME, UNITS, GNAME - WRITE(NDSDAT, 113) XS1 - WRITE(NDSDAT, 113) XS2 - WRITE(NDSDAT, 113) XS3 - ENDIF - IF ( FLTWO .OR. FLDIR ) THEN - WRITE (NDSDAT,980) FILEID, TIME, NSEA, 2, & - FSC, ENAME, UNITS, GNAME - WRITE(NDSDAT, 113) XS1 - WRITE(NDSDAT, 113) XS2 - ENDIF - IF ( FLONE ) THEN - WRITE (NDSDAT,980) FILEID, TIME, NSEA, 1, & - FSC, ENAME, UNITS, GNAME - WRITE(NDSDAT, 113) XS1 - ENDIF -! - CLOSE (NDSDAT) -! + END DO + END DO + END IF END IF -! -! ... End of fields loop -! + END IF + ! + CLOSE (NDSDAT) + ! + ELSE IF ( ITYPE .EQ. 4 ) THEN + ! + FNAME(13:) = ENAME + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSDAT,FILE=FNMPRE(:JJ)//FNAME,ERR=800, & + IOSTAT=IERR) + WRITE (6,*) FNAME(1:16) + ! + IF ( FLTRI ) THEN + WRITE (NDSDAT,980) FILEID, TIME, NSEA, 3, & + FSC, ENAME, UNITS, GNAME + WRITE(NDSDAT, 113) XS1 + WRITE(NDSDAT, 113) XS2 + WRITE(NDSDAT, 113) XS3 + ENDIF + IF ( FLTWO .OR. FLDIR ) THEN + WRITE (NDSDAT,980) FILEID, TIME, NSEA, 2, & + FSC, ENAME, UNITS, GNAME + WRITE(NDSDAT, 113) XS1 + WRITE(NDSDAT, 113) XS2 + ENDIF + IF ( FLONE ) THEN + WRITE (NDSDAT,980) FILEID, TIME, NSEA, 1, & + FSC, ENAME, UNITS, GNAME + WRITE(NDSDAT, 113) XS1 + ENDIF + ! + CLOSE (NDSDAT) + ! END IF - END DO - END DO -! - RETURN -! -! Error escape locations -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE (2) -! -! Formats -! - 113 FORMAT ((10ES11.3)) - 980 FORMAT (1X,A13,I9.8,I7.6,I9,I3,ES10.2,1X,A4,1X,A10,1X,A30) + ! + ! ... End of fields loop + ! + END IF + END DO + END DO + ! + RETURN + ! + ! Error escape locations + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE (2) + ! + ! Formats + ! +113 FORMAT ((10ES11.3)) +980 FORMAT (1X,A13,I9.8,I7.6,I9,I3,ES10.2,1X,A4,1X,A10,1X,A30) - 940 FORMAT (1X,I8,3I3.2,2X,4E12.4) - 949 FORMAT (1X,A13,I9.8,I7.6,2(2F8.2,I8), & - 1X,A4,F8.4,1X,A10,2I2,1X,A11,I4) - 950 FORMAT (1X,A13,1X,I9.8,1X,I7.6,2(1X,2F8.2,1X,I4), & - 1X,A4,1X,A7,1X,A10,1X,2I2,1X,A11,1X,I4) - 951 FORMAT (1X,2F10.5,2I8) - 960 FORMAT (1X,A13,I9.8,I7.6,2(2E11.3,I4), & - 1X,A4,1X,A7,1X,A10,2I2,1X,A11,I4) - 961 FORMAT (1X,2E12.4,2I8) -! - 990 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGO :'/ & - ' GROUP',I2,' PARAMETER',I3,' NOT LISTED ' ) - 999 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGO :'/ & - ' PLEASE UPDATE FIELDS !!! '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGO : '/ & - ' ERROR IN OPENING OUTPUT FILE'/ & - ' IOSTAT =',I5/) -! +940 FORMAT (1X,I8,3I3.2,2X,4E12.4) +949 FORMAT (1X,A13,I9.8,I7.6,2(2F8.2,I8), & + 1X,A4,F8.4,1X,A10,2I2,1X,A11,I4) +950 FORMAT (1X,A13,1X,I9.8,1X,I7.6,2(1X,2F8.2,1X,I4), & + 1X,A4,1X,A7,1X,A10,1X,2I2,1X,A11,1X,I4) +951 FORMAT (1X,2F10.5,2I8) +960 FORMAT (1X,A13,I9.8,I7.6,2(2E11.3,I4), & + 1X,A4,1X,A7,1X,A10,2I2,1X,A11,I4) +961 FORMAT (1X,2E12.4,2I8) + ! +990 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGO :'/ & + ' GROUP',I2,' PARAMETER',I3,' NOT LISTED ' ) +999 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGO :'/ & + ' PLEASE UPDATE FIELDS !!! '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGO : '/ & + ' ERROR IN OPENING OUTPUT FILE'/ & + ' IOSTAT =',I5/) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3EXGO : FLAGS :',I3,2X,20L2) - 9001 FORMAT (' TEST W3EXGO : ITPYE :',I4/ & - ' IX1/N/S :',3I4/ & - ' IY1/N/S :',3I4/ & - ' SCALE, VECTOR :',2L2/ & - ' NDSDAT :',I4) +9000 FORMAT (' TEST W3EXGO : FLAGS :',I3,2X,20L2) +9001 FORMAT (' TEST W3EXGO : ITPYE :',I4/ & + ' IX1/N/S :',3I4/ & + ' IY1/N/S :',3I4/ & + ' SCALE, VECTOR :',2L2/ & + ' NDSDAT :',I4) #endif -! + ! #ifdef W3_T - 9012 FORMAT (' TEST W3EXGO : BLOK PARS : ',3I4) - 9014 FORMAT (' BASE NAME : ',A) +9012 FORMAT (' TEST W3EXGO : BLOK PARS : ',3I4) +9014 FORMAT (' BASE NAME : ',A) #endif -! + ! #ifdef W3_T - 9020 FORMAT (' TEST W3EXGO : OUTPUT FIELD : ',A) +9020 FORMAT (' TEST W3EXGO : OUTPUT FIELD : ',A) #endif -!/ -!/ End of W3EXGO ----------------------------------------------------- / -!/ - END SUBROUTINE W3EXGO -!/ -! -!/ End of W3OUTF ----------------------------------------------------- / -!/ - END PROGRAM W3OUTF - + !/ + !/ End of W3EXGO ----------------------------------------------------- / + !/ + END SUBROUTINE W3EXGO + !/ + ! + !/ End of W3OUTF ----------------------------------------------------- / + !/ +END PROGRAM W3OUTF diff --git a/model/src/ww3_outp.F90 b/model/src/ww3_outp.F90 index cf6a2b1f5..8edf73a28 100644 --- a/model/src/ww3_outp.F90 +++ b/model/src/ww3_outp.F90 @@ -1,2805 +1,2805 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - PROGRAM W3OUTP -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | J.H. Alves | -!/ | A. Chawla | -!/ | F. Ardhuin | -!/ | E. Rogers | -!/ | T. Campbell | -!/ | FORTRAN 90 | -!/ | Last update : 27-Aug-2015 | -!/ +-----------------------------------+ -!/ -!/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 14-Feb-2000 : Exact nonlinear interactions ( version 2.01 ) -!/ 09-Jan-2001 : U* bug fix in tabular output ( version 2.05 ) -!/ 25-Jan-2001 : Flat grid version ( version 2.06 ) -!/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) -!/ 11-Jun-2001 : Clean up ( version 2.11 ) -!/ 11-Oct-2001 : Clean up, X*, Y* in tables ( version 2.14 ) -!/ 13-Nov-2002 : Add stress vector ( version 3.00 ) -!/ 27-Nov-2002 : First version of VDIA and MDIA ( version 3.01 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 17-Apr-2006 : Filter for directional spread. ( version 3.09 ) -!/ 23-Jun-2006 : Linear input added. ( version 3.09 ) -!/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 03-Jul-2006 : Separate flux modules. ( version 3.09 ) -!/ 28-Oct-2006 : Add partitioning option. ( version 3.10 ) -!/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) -!/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) -!/ (J. H. Alves) -!/ 08-Aug-2007 : Creation of buoy log file added ( version 3.12 ) -!/ (switch O14 -- A. Chawla) -!/ 09-Oct-2007 : WAM 4+ Sin and Sds added. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 09-Oct-2007 : Experimental Sbs (BS1) added. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 09-Apr-2008 : Adding an additional output for ( version 3.12 ) -!/ WMO standard (A. Chawla) -!/ 29-Apr-2008 : Adjust format partition output. ( version 3.14 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 04-Mar-2010 : Added partitions bulletin output. ( version 3.14 ) -!/ (J. H. Alves) -!/ 20-Apr-2010 : Fix initialization of USTAR. ( version 3.14.1 ) -!/ 16-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) -!/ from 3.15 (HLT). ( version 4.08 ) -!/ 23-Aug-2012 : Adding movable bed friction BT4 ( version 4.08 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ 10-Sep-2013 : Implement second order correction ( version 4.12 ) -!/ (F. Ardhuin) -!/ 06-Feb-2014 : Fix header format in part. files. ( version 4.18 ) -!/ 27-Aug-2015 : Sice add as additional output ( version 5.10 ) -!/ (in source terms) -!/ 27-Jun-2017 : Expanding WMO table to 2 digits JHA ( version 6.02 ) -!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ 21-Jul-2022 : Correct FP0 calc for peak energy in ( version 7.14 ) -!/ min/max freq band (B. Pouliot, CMC) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Post-processing of point output. -! -! 2. Method : -! -! Data is read from the grid output file out_pnt.ww3 (raw data) -! and from the file ww3_outp.inp ( NDSI, output requests ). -! Model definition and raw data files are read using WAVEWATCH III -! subroutines. -! -! Output types ITYPE : Sub-type OTYPE : -! -------------------- ----------------- -! 0 : Check file. -! 1 : Spectra. -! 1 : Print plots. -! 2 : Table of 1-D spectra -! 3 : Transfer file -! 2 : Table of mean wave parameters -! 1 : Depth, current, wind -! 2 : Mean wave pars. -! 3 : Nondimensional pars. (U*) -! 4 : Nondimensional pars. (U10) -! 5 : Validation table -! 6 : WMO standard output -! 3 : Source terms -! 1 : Print plots. -! 2 : Table of 1-D S(f). -! 3 : Table of 1-D time scales. -! 4 : Transfer file. -! -! 4 : Partitioning and bulletins -! 1 : Spectral partitions table -! 2 : Bulletins ASCII format -! 3 : Bulletins CSV format -! 4 : Bulletins CSV & ASCII format -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W3NAUX Subr. W3ADATMD Set number of model for aux data. -! W3SETA Subr. Id. Point to selected model for aux data. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! STME21 Subr. W3TIMEMD Convert time to string. -! TICK21 Subr. Id. Advance time. -! DSEC21 Func. Id. Difference between times. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3IOPO Subr. W3IOPOMD Reading/writing raw point output file. -! W3EXPO Subr. Internal Execute point output. -! W3BULL Subr. W3BULLMD Generate buletins from spectral part. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! Checks on input, checks in W3IOxx. -! -! 7. Remarks : -! -! - Tables written to file 'tabNN.ww3', where NN is the -! unit umber (NDSTAB). -! - Transfder file written to ww3.yymmddhh.spc with multiple -! spectra and times in file. yymmddhh relates to first -! output (NDSTAB). -! - !/IC1 !/IC2 !/IC3 !/IC4 !/IC5 are not included in dissipation term -! FIXME: ICE is a dummy variable at the moment -! Include ice parameters in point output file out_pnt.ww3 -! Ice coupling to SIN, SDS and SIC similar to w3srcemd.ftn -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! !/NCO NCEP NCO modifications for operational implementation. -! -! !/O14 Buoy log file generation. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ -! USE W3GDATMD, ONLY: W3NMOD, W3SETG - USE W3WDATMD, ONLY: W3SETW, W3NDAT +PROGRAM W3OUTP + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | J.H. Alves | + !/ | A. Chawla | + !/ | F. Ardhuin | + !/ | E. Rogers | + !/ | T. Campbell | + !/ | FORTRAN 90 | + !/ | Last update : 27-Aug-2015 | + !/ +-----------------------------------+ + !/ + !/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 14-Feb-2000 : Exact nonlinear interactions ( version 2.01 ) + !/ 09-Jan-2001 : U* bug fix in tabular output ( version 2.05 ) + !/ 25-Jan-2001 : Flat grid version ( version 2.06 ) + !/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) + !/ 11-Jun-2001 : Clean up ( version 2.11 ) + !/ 11-Oct-2001 : Clean up, X*, Y* in tables ( version 2.14 ) + !/ 13-Nov-2002 : Add stress vector ( version 3.00 ) + !/ 27-Nov-2002 : First version of VDIA and MDIA ( version 3.01 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 17-Apr-2006 : Filter for directional spread. ( version 3.09 ) + !/ 23-Jun-2006 : Linear input added. ( version 3.09 ) + !/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 03-Jul-2006 : Separate flux modules. ( version 3.09 ) + !/ 28-Oct-2006 : Add partitioning option. ( version 3.10 ) + !/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) + !/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) + !/ (J. H. Alves) + !/ 08-Aug-2007 : Creation of buoy log file added ( version 3.12 ) + !/ (switch O14 -- A. Chawla) + !/ 09-Oct-2007 : WAM 4+ Sin and Sds added. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 09-Oct-2007 : Experimental Sbs (BS1) added. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 09-Apr-2008 : Adding an additional output for ( version 3.12 ) + !/ WMO standard (A. Chawla) + !/ 29-Apr-2008 : Adjust format partition output. ( version 3.14 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 04-Mar-2010 : Added partitions bulletin output. ( version 3.14 ) + !/ (J. H. Alves) + !/ 20-Apr-2010 : Fix initialization of USTAR. ( version 3.14.1 ) + !/ 16-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) + !/ from 3.15 (HLT). ( version 4.08 ) + !/ 23-Aug-2012 : Adding movable bed friction BT4 ( version 4.08 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ 10-Sep-2013 : Implement second order correction ( version 4.12 ) + !/ (F. Ardhuin) + !/ 06-Feb-2014 : Fix header format in part. files. ( version 4.18 ) + !/ 27-Aug-2015 : Sice add as additional output ( version 5.10 ) + !/ (in source terms) + !/ 27-Jun-2017 : Expanding WMO table to 2 digits JHA ( version 6.02 ) + !/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ 21-Jul-2022 : Correct FP0 calc for peak energy in ( version 7.14 ) + !/ min/max freq band (B. Pouliot, CMC) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Post-processing of point output. + ! + ! 2. Method : + ! + ! Data is read from the grid output file out_pnt.ww3 (raw data) + ! and from the file ww3_outp.inp ( NDSI, output requests ). + ! Model definition and raw data files are read using WAVEWATCH III + ! subroutines. + ! + ! Output types ITYPE : Sub-type OTYPE : + ! -------------------- ----------------- + ! 0 : Check file. + ! 1 : Spectra. + ! 1 : Print plots. + ! 2 : Table of 1-D spectra + ! 3 : Transfer file + ! 2 : Table of mean wave parameters + ! 1 : Depth, current, wind + ! 2 : Mean wave pars. + ! 3 : Nondimensional pars. (U*) + ! 4 : Nondimensional pars. (U10) + ! 5 : Validation table + ! 6 : WMO standard output + ! 3 : Source terms + ! 1 : Print plots. + ! 2 : Table of 1-D S(f). + ! 3 : Table of 1-D time scales. + ! 4 : Transfer file. + ! + ! 4 : Partitioning and bulletins + ! 1 : Spectral partitions table + ! 2 : Bulletins ASCII format + ! 3 : Bulletins CSV format + ! 4 : Bulletins CSV & ASCII format + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W3NAUX Subr. W3ADATMD Set number of model for aux data. + ! W3SETA Subr. Id. Point to selected model for aux data. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! W3SETO Subr. Id. Point to selected model for output. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! TICK21 Subr. Id. Advance time. + ! DSEC21 Func. Id. Difference between times. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3IOPO Subr. W3IOPOMD Reading/writing raw point output file. + ! W3EXPO Subr. Internal Execute point output. + ! W3BULL Subr. W3BULLMD Generate buletins from spectral part. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! Checks on input, checks in W3IOxx. + ! + ! 7. Remarks : + ! + ! - Tables written to file 'tabNN.ww3', where NN is the + ! unit umber (NDSTAB). + ! - Transfder file written to ww3.yymmddhh.spc with multiple + ! spectra and times in file. yymmddhh relates to first + ! output (NDSTAB). + ! - !/IC1 !/IC2 !/IC3 !/IC4 !/IC5 are not included in dissipation term + ! FIXME: ICE is a dummy variable at the moment + ! Include ice parameters in point output file out_pnt.ww3 + ! Ice coupling to SIN, SDS and SIC similar to w3srcemd.ftn + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! !/NCO NCEP NCO modifications for operational implementation. + ! + ! !/O14 Buoy log file generation. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG + USE W3WDATMD, ONLY: W3SETW, W3NDAT #ifdef W3_NL1 - USE W3ADATMD, ONLY: W3SETA, W3NAUX + USE W3ADATMD, ONLY: W3SETA, W3NAUX #endif - USE W3ODATMD, ONLY: W3SETO, W3NOUT - USE W3IOGRMD, ONLY: W3IOGR - USE W3IOPOMD, ONLY: W3IOPO - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE + USE W3ODATMD, ONLY: W3SETO, W3NOUT + USE W3IOGRMD, ONLY: W3IOGR + USE W3IOPOMD, ONLY: W3IOPO + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY : STRACE -#endif - USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 -!/ - USE W3GDATMD - USE W3WDATMD, ONLY: TIME - USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOPTS, PTLOC, PTNME, & - DPO, WAO, WDO, ASO, CAO, CDO, SPCO, FNMPRE,& - ICEO, ICEHO, ICEFO, DIMP + USE W3SERVMD, ONLY : STRACE +#endif + USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 + !/ + USE W3GDATMD + USE W3WDATMD, ONLY: TIME + USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOPTS, PTLOC, PTNME, & + DPO, WAO, WDO, ASO, CAO, CDO, SPCO, FNMPRE,& + ICEO, ICEHO, ICEFO, DIMP #ifdef W3_FLX5 - USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO + USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO #endif - USE W3BULLMD, ONLY: NPTAB, NFLD, NPMAX, BHSMIN, BHSDROP, IYY, & - HST, TPT, DMT, ASCBLINE, CSVBLINE + USE W3BULLMD, ONLY: NPTAB, NFLD, NPMAX, BHSMIN, BHSDROP, IYY, & + HST, TPT, DMT, ASCBLINE, CSVBLINE #ifdef W3_NCO - USE W3BULLMD, ONLY: CASCBLINE + USE W3BULLMD, ONLY: CASCBLINE #endif #ifdef W3_O14 - USE W3ODATMD, ONLY: GRDID + USE W3ODATMD, ONLY: GRDID #endif #ifdef W3_IG1 - USE W3GIG1MD, ONLY: W3ADDIG - USE W3CANOMD, ONLY: W3ADD2NDORDER -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NDSI, NDSM, NDSOP, NDSTRC, NTRACE, & - IERR, I, TOUT(2), NOUT, TDUM(2), & - NREQ, IPOINT, ITYPE, OTYPE, NDSTAB, & - IOTEST, IK, ITH, IOUT, J, DIMXP, & - NDSBUL, NDSCSV, ICSV, IJ + USE W3GIG1MD, ONLY: W3ADDIG + USE W3CANOMD, ONLY: W3ADD2NDORDER +#endif + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NDSI, NDSM, NDSOP, NDSTRC, NTRACE, & + IERR, I, TOUT(2), NOUT, TDUM(2), & + NREQ, IPOINT, ITYPE, OTYPE, NDSTAB, & + IOTEST, IK, ITH, IOUT, J, DIMXP, & + NDSBUL, NDSCSV, ICSV, IJ #ifdef W3_NCO - INTEGER :: NDSCBUL + INTEGER :: NDSCBUL #endif - INTEGER :: ISCALE = 0 - INTEGER :: TIMEV(2) + INTEGER :: ISCALE = 0 + INTEGER :: TIMEV(2) #ifdef W3_O14 - INTEGER :: NDBO + INTEGER :: NDBO #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: DTREQ, SCALE1, SCALE2, DTEST - REAL :: M2KM - REAL, ALLOCATABLE :: XPART(:,:) - LOGICAL :: FLFORM, FLSRCE(7) - LOGICAL, ALLOCATABLE :: FLREQ(:) - CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & - TABNME*9, TFNAME*16 - CHARACTER(LEN=25) :: IDSRCE(7) - CHARACTER :: HSTR*6, HTYPE*3 -!/ -!/ ------------------------------------------------------------------- / -!/ - DATA IDSRCE / 'Spectrum ' , & - 'Wind-wave interactions ' , & - 'Nonlinear interactions ' , & - 'Dissipation ' , & - 'Wave-bottom interactions ' , & - 'Wave-ice interactions ' , & - 'Sum of selected sources ' / - FLSRCE = .FALSE. -! + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: DTREQ, SCALE1, SCALE2, DTEST + REAL :: M2KM + REAL, ALLOCATABLE :: XPART(:,:) + LOGICAL :: FLFORM, FLSRCE(7) + LOGICAL, ALLOCATABLE :: FLREQ(:) + CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & + TABNME*9, TFNAME*16 + CHARACTER(LEN=25) :: IDSRCE(7) + CHARACTER :: HSTR*6, HTYPE*3 + !/ + !/ ------------------------------------------------------------------- / + !/ + DATA IDSRCE / 'Spectrum ' , & + 'Wind-wave interactions ' , & + 'Nonlinear interactions ' , & + 'Dissipation ' , & + 'Wave-bottom interactions ' , & + 'Wave-ice interactions ' , & + 'Sum of selected sources ' / + FLSRCE = .FALSE. + ! #ifdef W3_NCO -! CALL W3TAGB('WAVESPEC',1998,0007,0050,'NP21 ') -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. IO set-up. -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) + ! CALL W3TAGB('WAVESPEC',1998,0007,0050,'NP21 ') +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1. IO set-up. + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) #ifdef W3_NL1 - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) -#endif - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! - NDSI = 10 - NDSM = 20 - NDSOP = 20 - NDSBUL = 0 + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + NDSI = 10 + NDSM = 20 + NDSOP = 20 + NDSBUL = 0 #ifdef W3_NCO - NDSCBUL = 0 + NDSCBUL = 0 #endif -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) -! + ! #ifdef W3_S - CALL STRACE (IENT, 'W3OUTP') + CALL STRACE (IENT, 'W3OUTP') #endif -! + ! #ifdef W3_NCO -! -! Redo according to NCO -! - NDSI = 11 - NDSO = 6 - NDSE = NDSO - NDST = NDSO - NDSM = 12 - NDSOP = 13 + ! + ! Redo according to NCO + ! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSOP = 13 #endif #ifdef W3_O14 - NDBO = 14 + NDBO = 14 #endif #ifdef W3_NCO - NDSTRC = NDSO -#endif -! - WRITE (NDSO,900) -! - J = LEN_TRIM(FNMPRE) - OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_outp.inp',STATUS='OLD', & - ERR=800,IOSTAT=IERR) - READ (NDSI,'(A)',END=801,ERR=802) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - WRITE (NDSO,920) GNAME -! - IF ( FLAGLL ) THEN - M2KM = 1. - ELSE - M2KM = 1.E-3 - END IF -! - DIMXP = ((NK+1)/2) * ((NTH-1)/2) - ALLOCATE ( XPART(DIMP,0:DIMXP) ) - XPART = UNDEF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read general data and first fields from file -! - CALL W3IOPO ( 'READ', NDSOP, IOTEST ) -! - WRITE (NDSO,930) - DO I=1, NOPTS - IF ( FLAGLL ) THEN - WRITE (NDSO,931) PTNME(I), M2KM*PTLOC(1,I), M2KM*PTLOC(2,I) - ELSE - WRITE (NDSO,932) PTNME(I), M2KM*PTLOC(1,I), M2KM*PTLOC(2,I) - END IF - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Read requests from input file. -! Output times -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT - DTREQ = MAX ( 0. , DTREQ ) - IF ( DTREQ.EQ.0 ) NOUT = 1 - NOUT = MAX ( 1 , NOUT ) -! - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,940) IDTIME -! - TDUM = 0 - CALL TICK21 ( TDUM , DTREQ ) - CALL STME21 ( TDUM , IDTIME ) - IF ( DTREQ .GE. 86400. ) THEN - WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) - ELSE - IDDDAY = ' ' - END IF - IDTIME(1:11) = IDDDAY - IDTIME(21:23) = ' ' - WRITE (NDSO,941) IDTIME, NOUT -! -! ... Output points -! - ALLOCATE ( FLREQ(NOPTS) ) - FLREQ = .FALSE. - NREQ = 0 -! - DO I=1, NOPTS - ! reads point index - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) IPOINT - ! last index - IF (IPOINT .LT. 0) THEN - IF (I.EQ.1) THEN - FLREQ = .TRUE. - NREQ = NOPTS - END IF - EXIT - END IF - ! existing index in out_pnt.ww3 - IF ( (IPOINT .GT. 0) .AND. (IPOINT .LE. NOPTS) ) THEN - IF ( .NOT. FLREQ(IPOINT) ) THEN - NREQ = NREQ + 1 - END IF - FLREQ(IPOINT) = .TRUE. - END IF - ! read the 'end of list' if nopts reached before it - IF ( (IPOINT .GT. 0) .AND. (NREQ .EQ. NOPTS) ) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) IPOINT - END IF - END DO - ! check if last point index is -1 - IF (IPOINT .NE. -1) THEN - WRITE (NDSE,1007) - CALL EXTCDE ( 47 ) + NDSTRC = NDSO +#endif + ! + WRITE (NDSO,900) + ! + J = LEN_TRIM(FNMPRE) + OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_outp.inp',STATUS='OLD', & + ERR=800,IOSTAT=IERR) + READ (NDSI,'(A)',END=801,ERR=802) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + WRITE (NDSO,920) GNAME + ! + IF ( FLAGLL ) THEN + M2KM = 1. + ELSE + M2KM = 1.E-3 + END IF + ! + DIMXP = ((NK+1)/2) * ((NTH-1)/2) + ALLOCATE ( XPART(DIMP,0:DIMXP) ) + XPART = UNDEF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read general data and first fields from file + ! + CALL W3IOPO ( 'READ', NDSOP, IOTEST ) + ! + WRITE (NDSO,930) + DO I=1, NOPTS + IF ( FLAGLL ) THEN + WRITE (NDSO,931) PTNME(I), M2KM*PTLOC(1,I), M2KM*PTLOC(2,I) + ELSE + WRITE (NDSO,932) PTNME(I), M2KM*PTLOC(1,I), M2KM*PTLOC(2,I) + END IF + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Read requests from input file. + ! Output times + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT + DTREQ = MAX ( 0. , DTREQ ) + IF ( DTREQ.EQ.0 ) NOUT = 1 + NOUT = MAX ( 1 , NOUT ) + ! + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,940) IDTIME + ! + TDUM = 0 + CALL TICK21 ( TDUM , DTREQ ) + CALL STME21 ( TDUM , IDTIME ) + IF ( DTREQ .GE. 86400. ) THEN + WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) + ELSE + IDDDAY = ' ' + END IF + IDTIME(1:11) = IDDDAY + IDTIME(21:23) = ' ' + WRITE (NDSO,941) IDTIME, NOUT + ! + ! ... Output points + ! + ALLOCATE ( FLREQ(NOPTS) ) + FLREQ = .FALSE. + NREQ = 0 + ! + DO I=1, NOPTS + ! reads point index + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) IPOINT + ! last index + IF (IPOINT .LT. 0) THEN + IF (I.EQ.1) THEN + FLREQ = .TRUE. + NREQ = NOPTS END IF - -! -! ... Output type -! + EXIT + END IF + ! existing index in out_pnt.ww3 + IF ( (IPOINT .GT. 0) .AND. (IPOINT .LE. NOPTS) ) THEN + IF ( .NOT. FLREQ(IPOINT) ) THEN + NREQ = NREQ + 1 + END IF + FLREQ(IPOINT) = .TRUE. + END IF + ! read the 'end of list' if nopts reached before it + IF ( (IPOINT .GT. 0) .AND. (NREQ .EQ. NOPTS) ) THEN CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) ITYPE -! -! ... ITYPE = 0 -! - IF ( ITYPE .EQ. 0 ) THEN -! + READ (NDSI,*,END=801,ERR=802) IPOINT + END IF + END DO + ! check if last point index is -1 + IF (IPOINT .NE. -1) THEN + WRITE (NDSE,1007) + CALL EXTCDE ( 47 ) + END IF + + ! + ! ... Output type + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) ITYPE + ! + ! ... ITYPE = 0 + ! + IF ( ITYPE .EQ. 0 ) THEN + ! #ifdef W3_O14 - WRITE (NDSO,942) ITYPE, 'Generating buoy log file' - OPEN (NDBO,FILE=FNMPRE(:J)//'buoy_log.ww3', & - STATUS='NEW',ERR=805,IOSTAT=IERR) - DO I = 1,NOPTS - WRITE(NDBO,945) I, PTNME(I), PTLOC(1,I), & - PTLOC(2,I), GRDID(I) - END DO - CLOSE(NDBO) -#endif -! - WRITE (NDSO,942) ITYPE, 'Checking contents of file' - DO - CALL STME21 ( TIME , IDTIME ) - WRITE (NDSO,948) IDTIME - CALL W3IOPO ( 'READ', NDSOP, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - WRITE (NDSO,949) - GOTO 888 - END IF - END DO -! -! ... ITYPE = 1 -! - ELSE IF (ITYPE .EQ. 1) THEN - WRITE (NDSO,942) ITYPE, '1-D and/or 2-D spectra' - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) OTYPE, SCALE1, SCALE2, & - NDSTAB, FLFORM + WRITE (NDSO,942) ITYPE, 'Generating buoy log file' + OPEN (NDBO,FILE=FNMPRE(:J)//'buoy_log.ww3', & + STATUS='NEW',ERR=805,IOSTAT=IERR) + DO I = 1,NOPTS + WRITE(NDBO,945) I, PTNME(I), PTLOC(1,I), & + PTLOC(2,I), GRDID(I) + END DO + CLOSE(NDBO) +#endif + ! + WRITE (NDSO,942) ITYPE, 'Checking contents of file' + DO + CALL STME21 ( TIME , IDTIME ) + WRITE (NDSO,948) IDTIME + CALL W3IOPO ( 'READ', NDSOP, IOTEST ) + IF ( IOTEST .EQ. -1 ) THEN + WRITE (NDSO,949) + GOTO 888 + END IF + END DO + ! + ! ... ITYPE = 1 + ! + ELSE IF (ITYPE .EQ. 1) THEN + WRITE (NDSO,942) ITYPE, '1-D and/or 2-D spectra' + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) OTYPE, SCALE1, SCALE2, & + NDSTAB, FLFORM #ifdef W3_NCO - NDSTAB = 51 -#endif - IF (OTYPE .EQ. 1) THEN - WRITE (NDSO,943) 'print plots' - IF ( SCALE1 .LT. 0. ) THEN - WRITE (NDSO,1940) '1-D' - ELSE IF ( SCALE1 .EQ. 0. ) THEN - WRITE (NDSO,1941) '1-D' - ELSE - WRITE (NDSO,1942) '1-D', SCALE1 - END IF - IF ( SCALE2 .LT. 0. ) THEN - WRITE (NDSO,1940) '2-D' - ELSE IF ( SCALE2 .EQ. 0. ) THEN - WRITE (NDSO,1941) '2-D' - ELSE - WRITE (NDSO,1942) '2-D', SCALE2 - END IF - ELSE IF ( OTYPE .EQ. 2 ) THEN - WRITE (NDSO,943) 'Table of 1-D spectral data' - TABNME = 'tab--.ww3' - IF ( NDSTAB.LE.0 .OR. NDSTAB.GT.99 ) NDSTAB = 51 - WRITE ( TABNME(4:5) , '(I2.2)' ) NDSTAB - J = LEN_TRIM(FNMPRE) - OPEN (NDSTAB,FILE=FNMPRE(:J)//TABNME,ERR=803,IOSTAT=IERR) - WRITE (NDSO,1947) TABNME - ELSE IF ( OTYPE .EQ. 3 ) THEN - TFNAME = 'ww3.--------.spc' - WRITE (TFNAME(5:12),'(I6.6,I2.2)') & - MOD(TOUT(1),1000000), TOUT(2)/10000 - WRITE (NDSO,943) 'Transfer file' - IF ( FLFORM ) THEN - WRITE (NDSO,1943) TFNAME, 'UNFORMATTED' - J = LEN_TRIM(FNMPRE) - OPEN (NDSTAB,FILE=FNMPRE(:J)//TFNAME,ERR=804, & - IOSTAT=IERR,form='UNFORMATTED', convert=file_endian) - WRITE (NDSTAB) 'WAVEWATCH III SPECTRA', & - NK, NTH, NREQ, GNAME - WRITE (NDSTAB) (SIG(IK)*TPIINV,IK=1,NK) -! -! conversion of directions from trignonmetric to nautical (still uses directions TO ) -! - WRITE (NDSTAB) (MOD(2.5*PI-TH(ITH),TPI),ITH=1,NTH) + NDSTAB = 51 +#endif + IF (OTYPE .EQ. 1) THEN + WRITE (NDSO,943) 'print plots' + IF ( SCALE1 .LT. 0. ) THEN + WRITE (NDSO,1940) '1-D' + ELSE IF ( SCALE1 .EQ. 0. ) THEN + WRITE (NDSO,1941) '1-D' + ELSE + WRITE (NDSO,1942) '1-D', SCALE1 + END IF + IF ( SCALE2 .LT. 0. ) THEN + WRITE (NDSO,1940) '2-D' + ELSE IF ( SCALE2 .EQ. 0. ) THEN + WRITE (NDSO,1941) '2-D' + ELSE + WRITE (NDSO,1942) '2-D', SCALE2 + END IF + ELSE IF ( OTYPE .EQ. 2 ) THEN + WRITE (NDSO,943) 'Table of 1-D spectral data' + TABNME = 'tab--.ww3' + IF ( NDSTAB.LE.0 .OR. NDSTAB.GT.99 ) NDSTAB = 51 + WRITE ( TABNME(4:5) , '(I2.2)' ) NDSTAB + J = LEN_TRIM(FNMPRE) + OPEN (NDSTAB,FILE=FNMPRE(:J)//TABNME,ERR=803,IOSTAT=IERR) + WRITE (NDSO,1947) TABNME + ELSE IF ( OTYPE .EQ. 3 ) THEN + TFNAME = 'ww3.--------.spc' + WRITE (TFNAME(5:12),'(I6.6,I2.2)') & + MOD(TOUT(1),1000000), TOUT(2)/10000 + WRITE (NDSO,943) 'Transfer file' + IF ( FLFORM ) THEN + WRITE (NDSO,1943) TFNAME, 'UNFORMATTED' + J = LEN_TRIM(FNMPRE) + OPEN (NDSTAB,FILE=FNMPRE(:J)//TFNAME,ERR=804, & + IOSTAT=IERR,form='UNFORMATTED', convert=file_endian) + WRITE (NDSTAB) 'WAVEWATCH III SPECTRA', & + NK, NTH, NREQ, GNAME + WRITE (NDSTAB) (SIG(IK)*TPIINV,IK=1,NK) + ! + ! conversion of directions from trignonmetric to nautical (still uses directions TO ) + ! + WRITE (NDSTAB) (MOD(2.5*PI-TH(ITH),TPI),ITH=1,NTH) - ELSE - WRITE (NDSO,1943) TFNAME, 'FORMATTED' - J = LEN_TRIM(FNMPRE) - OPEN (NDSTAB,FILE=FNMPRE(:J)//TFNAME,ERR=804, & - IOSTAT=IERR,FORM='FORMATTED') - WRITE (NDSTAB,1944) 'WAVEWATCH III SPECTRA', & - NK, NTH, NREQ, GNAME - WRITE (NDSTAB,1945) (SIG(IK)*TPIINV,IK=1,NK) - WRITE (NDSTAB,1946) & - (MOD(2.5*PI-TH(ITH),TPI),ITH=1,NTH) - END IF - ELSE - WRITE (NDSE,1011) OTYPE - CALL EXTCDE ( 10 ) - END IF -! -! ... ITYPE = 2 -! - ELSE IF (ITYPE .EQ. 2) THEN - WRITE (NDSO,942) ITYPE, 'Table of mean wave parameters' - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) OTYPE, NDSTAB + ELSE + WRITE (NDSO,1943) TFNAME, 'FORMATTED' + J = LEN_TRIM(FNMPRE) + OPEN (NDSTAB,FILE=FNMPRE(:J)//TFNAME,ERR=804, & + IOSTAT=IERR,FORM='FORMATTED') + WRITE (NDSTAB,1944) 'WAVEWATCH III SPECTRA', & + NK, NTH, NREQ, GNAME + WRITE (NDSTAB,1945) (SIG(IK)*TPIINV,IK=1,NK) + WRITE (NDSTAB,1946) & + (MOD(2.5*PI-TH(ITH),TPI),ITH=1,NTH) + END IF + ELSE + WRITE (NDSE,1011) OTYPE + CALL EXTCDE ( 10 ) + END IF + ! + ! ... ITYPE = 2 + ! + ELSE IF (ITYPE .EQ. 2) THEN + WRITE (NDSO,942) ITYPE, 'Table of mean wave parameters' + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) OTYPE, NDSTAB #ifdef W3_NCO - NDSTAB = 51 -#endif - TABNME = 'tab--.ww3' - IF ( NDSTAB.LE.0 .OR. NDSTAB.GT.99 ) NDSTAB = 51 - WRITE ( TABNME(4:5) , '(I2.2)' ) NDSTAB - J = LEN_TRIM(FNMPRE) - OPEN (NDSTAB,FILE=FNMPRE(:J)//TABNME,ERR=803,IOSTAT=IERR) - IF ( OTYPE .EQ. 1 ) THEN - WRITE (NDSO,2940) 'Depth, current and wind', TABNME - ELSE IF ( OTYPE .EQ. 2 ) THEN - WRITE (NDSO,2940) 'Mean wave parameters', TABNME - ELSE IF ( OTYPE .EQ. 3 ) THEN - WRITE (NDSO,2940) 'Nondimensional parameters (U*)', & - TABNME - ELSE IF ( OTYPE .EQ. 4 ) THEN - WRITE (NDSO,2940) 'Nondimensional parameters (U10)', & - TABNME - ELSE IF ( OTYPE .EQ. 5 ) THEN - WRITE (NDSO,2940) 'Validation parameters', TABNME - ELSE IF ( OTYPE .EQ. 6 ) THEN - WRITE (NDSO,2940) 'WMO standard mean parameters', TABNME - ELSE - WRITE (NDSE,1011) OTYPE - CALL EXTCDE ( 20 ) - END IF -! -! ... ITYPE = 3 -! - ELSE IF (ITYPE .EQ. 3) THEN - WRITE (NDSO,942) ITYPE, 'Source terms' - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) OTYPE, SCALE1, SCALE2, & - NDSTAB, FLSRCE, ISCALE, FLFORM + NDSTAB = 51 +#endif + TABNME = 'tab--.ww3' + IF ( NDSTAB.LE.0 .OR. NDSTAB.GT.99 ) NDSTAB = 51 + WRITE ( TABNME(4:5) , '(I2.2)' ) NDSTAB + J = LEN_TRIM(FNMPRE) + OPEN (NDSTAB,FILE=FNMPRE(:J)//TABNME,ERR=803,IOSTAT=IERR) + IF ( OTYPE .EQ. 1 ) THEN + WRITE (NDSO,2940) 'Depth, current and wind', TABNME + ELSE IF ( OTYPE .EQ. 2 ) THEN + WRITE (NDSO,2940) 'Mean wave parameters', TABNME + ELSE IF ( OTYPE .EQ. 3 ) THEN + WRITE (NDSO,2940) 'Nondimensional parameters (U*)', & + TABNME + ELSE IF ( OTYPE .EQ. 4 ) THEN + WRITE (NDSO,2940) 'Nondimensional parameters (U10)', & + TABNME + ELSE IF ( OTYPE .EQ. 5 ) THEN + WRITE (NDSO,2940) 'Validation parameters', TABNME + ELSE IF ( OTYPE .EQ. 6 ) THEN + WRITE (NDSO,2940) 'WMO standard mean parameters', TABNME + ELSE + WRITE (NDSE,1011) OTYPE + CALL EXTCDE ( 20 ) + END IF + ! + ! ... ITYPE = 3 + ! + ELSE IF (ITYPE .EQ. 3) THEN + WRITE (NDSO,942) ITYPE, 'Source terms' + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) OTYPE, SCALE1, SCALE2, & + NDSTAB, FLSRCE, ISCALE, FLFORM #ifdef W3_NCO - NDSTAB = 51 -#endif - ISCALE = MAX ( 0 , MIN ( 5 , ISCALE ) ) - IF ( OTYPE .EQ. 1 ) THEN - WRITE (NDSO,943) 'Print plots' - ELSE IF ( OTYPE .EQ. 2 ) THEN - IF ( ISCALE .LE. 2) THEN - WRITE (NDSO,943) 'Tables as a function of freq.' - ELSE - WRITE (NDSO,943) 'Tables as a function of f/fp.' - END IF - IF ( MOD(ISCALE,3) .EQ. 1 ) THEN - WRITE (NDSO,944) '(nondimensional based on U10)' - ELSE IF ( MOD(ISCALE,3) .EQ. 2) THEN - WRITE (NDSO,944) '(nondimensional based on U*)' - END IF - ELSE IF ( OTYPE .EQ. 3 ) THEN - IF ( ISCALE .LE. 2) THEN - WRITE (NDSO,943) 'Time scales as a function of freq.' - ELSE - WRITE (NDSO,943) 'Time scales as a function of f/fp.' - END IF - IF ( ISCALE .EQ. 1 ) THEN - WRITE (NDSO,944) '(nondimensional based on U10)' - ELSE IF ( ISCALE .EQ. 2) THEN - WRITE (NDSO,944) '(nondimensional based on U*)' - END IF - ELSE IF ( OTYPE .EQ. 4 ) THEN - TFNAME = 'ww3.--------.src' - WRITE (TFNAME(5:12),'(I6.6,I2.2)') & - MOD(TOUT(1),1000000), TOUT(2)/10000 - WRITE (NDSO,943) 'Transfer file' - IF ( FLFORM ) THEN - WRITE (NDSO,3943) TFNAME, 'UNFORMATTED' - J = LEN_TRIM(FNMPRE) - OPEN (NDSTAB,FILE=FNMPRE(:J)//TFNAME,ERR=804, & - IOSTAT=IERR,form='UNFORMATTED', convert=file_endian) - WRITE (NDSTAB) 'WAVEWATCH III SOURCES', & - NK, NTH, NREQ, FLSRCE - WRITE (NDSTAB) (SIG(IK)*TPIINV,IK=1,NK) - WRITE (NDSTAB) (MOD(2.5*PI-TH(ITH),TPI),ITH=1,NTH) + NDSTAB = 51 +#endif + ISCALE = MAX ( 0 , MIN ( 5 , ISCALE ) ) + IF ( OTYPE .EQ. 1 ) THEN + WRITE (NDSO,943) 'Print plots' + ELSE IF ( OTYPE .EQ. 2 ) THEN + IF ( ISCALE .LE. 2) THEN + WRITE (NDSO,943) 'Tables as a function of freq.' + ELSE + WRITE (NDSO,943) 'Tables as a function of f/fp.' + END IF + IF ( MOD(ISCALE,3) .EQ. 1 ) THEN + WRITE (NDSO,944) '(nondimensional based on U10)' + ELSE IF ( MOD(ISCALE,3) .EQ. 2) THEN + WRITE (NDSO,944) '(nondimensional based on U*)' + END IF + ELSE IF ( OTYPE .EQ. 3 ) THEN + IF ( ISCALE .LE. 2) THEN + WRITE (NDSO,943) 'Time scales as a function of freq.' + ELSE + WRITE (NDSO,943) 'Time scales as a function of f/fp.' + END IF + IF ( ISCALE .EQ. 1 ) THEN + WRITE (NDSO,944) '(nondimensional based on U10)' + ELSE IF ( ISCALE .EQ. 2) THEN + WRITE (NDSO,944) '(nondimensional based on U*)' + END IF + ELSE IF ( OTYPE .EQ. 4 ) THEN + TFNAME = 'ww3.--------.src' + WRITE (TFNAME(5:12),'(I6.6,I2.2)') & + MOD(TOUT(1),1000000), TOUT(2)/10000 + WRITE (NDSO,943) 'Transfer file' + IF ( FLFORM ) THEN + WRITE (NDSO,3943) TFNAME, 'UNFORMATTED' + J = LEN_TRIM(FNMPRE) + OPEN (NDSTAB,FILE=FNMPRE(:J)//TFNAME,ERR=804, & + IOSTAT=IERR,form='UNFORMATTED', convert=file_endian) + WRITE (NDSTAB) 'WAVEWATCH III SOURCES', & + NK, NTH, NREQ, FLSRCE + WRITE (NDSTAB) (SIG(IK)*TPIINV,IK=1,NK) + WRITE (NDSTAB) (MOD(2.5*PI-TH(ITH),TPI),ITH=1,NTH) - ELSE - WRITE (NDSO,3943) TFNAME, 'FORMATTED' - J = LEN_TRIM(FNMPRE) - OPEN (NDSTAB,FILE=FNMPRE(:J)//TFNAME,ERR=804, & - IOSTAT=IERR,FORM='FORMATTED') - WRITE (NDSTAB,3944) 'WAVEWATCH III SOURCES', & - NK, NTH, NREQ, FLSRCE - WRITE (NDSTAB,3945) (SIG(IK)*TPIINV,IK=1,NK) - WRITE (NDSTAB,3946) & - (MOD(2.5*PI-TH(ITH),TPI),ITH=1,NTH) - END IF - ELSE - WRITE (NDSE,1011) OTYPE - CALL EXTCDE ( 30 ) - END IF -! - DO I=1, 7 - IF ( FLSRCE(I) ) WRITE (NDSO,3940) IDSRCE(I) - END DO - WRITE (NDSO,*) ' ' -! - IF ( OTYPE .EQ. 1 ) THEN - IF ( SCALE1 .LT. 0. ) THEN - WRITE (NDSO,1940) '1-D' - ELSE IF ( SCALE1 .EQ. 0. ) THEN - WRITE (NDSO,1941) '1-D' - ELSE - WRITE (NDSO,1942) '1-D', SCALE1 - END IF - IF ( SCALE2 .LT. 0. ) THEN - WRITE (NDSO,1940) '2-D' - ELSE IF ( SCALE2 .EQ. 0. ) THEN - WRITE (NDSO,1941) '2-D' - ELSE - WRITE (NDSO,1942) '2-D', SCALE2 - END IF - END IF -! - IF ( OTYPE.EQ.2 .OR. OTYPE.EQ.3 ) THEN - TABNME = 'tab--.ww3' - IF ( NDSTAB.LE.0 .OR. NDSTAB.GT.99 ) NDSTAB = 51 - WRITE ( TABNME(4:5) , '(I2.2)' ) NDSTAB - J = LEN_TRIM(FNMPRE) - OPEN (NDSTAB,FILE=FNMPRE(:J)//TABNME,ERR=803,IOSTAT=IERR) - WRITE (NDSO,3941) TABNME - END IF -! -! ... ITYPE = 4 -! - ELSE IF (ITYPE .EQ. 4) THEN - WRITE (NDSO,942) ITYPE, 'Spectral partitions or bulletins' - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802) OTYPE, NDSTAB, TIMEV, HTYPE + ELSE + WRITE (NDSO,3943) TFNAME, 'FORMATTED' + J = LEN_TRIM(FNMPRE) + OPEN (NDSTAB,FILE=FNMPRE(:J)//TFNAME,ERR=804, & + IOSTAT=IERR,FORM='FORMATTED') + WRITE (NDSTAB,3944) 'WAVEWATCH III SOURCES', & + NK, NTH, NREQ, FLSRCE + WRITE (NDSTAB,3945) (SIG(IK)*TPIINV,IK=1,NK) + WRITE (NDSTAB,3946) & + (MOD(2.5*PI-TH(ITH),TPI),ITH=1,NTH) + END IF + ELSE + WRITE (NDSE,1011) OTYPE + CALL EXTCDE ( 30 ) + END IF + ! + DO I=1, 7 + IF ( FLSRCE(I) ) WRITE (NDSO,3940) IDSRCE(I) + END DO + WRITE (NDSO,*) ' ' + ! + IF ( OTYPE .EQ. 1 ) THEN + IF ( SCALE1 .LT. 0. ) THEN + WRITE (NDSO,1940) '1-D' + ELSE IF ( SCALE1 .EQ. 0. ) THEN + WRITE (NDSO,1941) '1-D' + ELSE + WRITE (NDSO,1942) '1-D', SCALE1 + END IF + IF ( SCALE2 .LT. 0. ) THEN + WRITE (NDSO,1940) '2-D' + ELSE IF ( SCALE2 .EQ. 0. ) THEN + WRITE (NDSO,1941) '2-D' + ELSE + WRITE (NDSO,1942) '2-D', SCALE2 + END IF + END IF + ! + IF ( OTYPE.EQ.2 .OR. OTYPE.EQ.3 ) THEN + TABNME = 'tab--.ww3' + IF ( NDSTAB.LE.0 .OR. NDSTAB.GT.99 ) NDSTAB = 51 + WRITE ( TABNME(4:5) , '(I2.2)' ) NDSTAB + J = LEN_TRIM(FNMPRE) + OPEN (NDSTAB,FILE=FNMPRE(:J)//TABNME,ERR=803,IOSTAT=IERR) + WRITE (NDSO,3941) TABNME + END IF + ! + ! ... ITYPE = 4 + ! + ELSE IF (ITYPE .EQ. 4) THEN + WRITE (NDSO,942) ITYPE, 'Spectral partitions or bulletins' + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) OTYPE, NDSTAB, TIMEV, HTYPE #ifdef W3_NCO - NDSTAB = 51 + NDSTAB = 51 #endif - IF ( OTYPE .EQ. 1 ) THEN - WRITE (NDSO,943) 'Partitioning of spectra' - TABNME = 'tab--.ww3' - IF ( NDSTAB.LE.0 .OR. NDSTAB.GT.99 ) NDSTAB = 51 - WRITE ( TABNME(4:5) , '(I2.2)' ) NDSTAB - J = LEN_TRIM(FNMPRE) - OPEN (NDSTAB,FILE=FNMPRE(:J)//TABNME,ERR=803,IOSTAT=IERR) - WRITE (NDSO,1947) TABNME + IF ( OTYPE .EQ. 1 ) THEN + WRITE (NDSO,943) 'Partitioning of spectra' + TABNME = 'tab--.ww3' + IF ( NDSTAB.LE.0 .OR. NDSTAB.GT.99 ) NDSTAB = 51 + WRITE ( TABNME(4:5) , '(I2.2)' ) NDSTAB + J = LEN_TRIM(FNMPRE) + OPEN (NDSTAB,FILE=FNMPRE(:J)//TABNME,ERR=803,IOSTAT=IERR) + WRITE (NDSO,1947) TABNME - ELSEIF ( OTYPE .GE. 2 ) THEN - IF (OTYPE .EQ. 2 .OR. OTYPE .EQ. 4 ) THEN - WRITE (NDSO,943) 'Bulletins, ASCII format' - J = LEN_TRIM(FNMPRE) - DO IJ = 1,NOPTS - IF ( COUNT(FLREQ) .GT. 1 ) THEN -! ... This version only allows single point output for bulletins - WRITE (NDSE,1012) OTYPE - CALL EXTCDE ( 45 ) - ENDIF - IF (FLREQ(IJ)) THEN - NDSBUL = NDSTAB + (IJ - 1) - OPEN(NDSBUL,FILE=TRIM(PTNME(IJ))//'.bull',ERR=803,IOSTAT=IERR) - WRITE (NDSO,1947) TRIM(PTNME(IJ))//'.bull' + ELSEIF ( OTYPE .GE. 2 ) THEN + IF (OTYPE .EQ. 2 .OR. OTYPE .EQ. 4 ) THEN + WRITE (NDSO,943) 'Bulletins, ASCII format' + J = LEN_TRIM(FNMPRE) + DO IJ = 1,NOPTS + IF ( COUNT(FLREQ) .GT. 1 ) THEN + ! ... This version only allows single point output for bulletins + WRITE (NDSE,1012) OTYPE + CALL EXTCDE ( 45 ) + ENDIF + IF (FLREQ(IJ)) THEN + NDSBUL = NDSTAB + (IJ - 1) + OPEN(NDSBUL,FILE=TRIM(PTNME(IJ))//'.bull',ERR=803,IOSTAT=IERR) + WRITE (NDSO,1947) TRIM(PTNME(IJ))//'.bull' #ifdef W3_NCO - NDSCBUL = NDSTAB + (IJ - 1) + NOPTS - OPEN(NDSCBUL,FILE=TRIM(PTNME(IJ))//'.cbull',ERR=803,IOSTAT=IERR) - WRITE (NDSO,1947) TRIM(PTNME(IJ))//'.cbull' + NDSCBUL = NDSTAB + (IJ - 1) + NOPTS + OPEN(NDSCBUL,FILE=TRIM(PTNME(IJ))//'.cbull',ERR=803,IOSTAT=IERR) + WRITE (NDSO,1947) TRIM(PTNME(IJ))//'.cbull' #endif - ENDIF - ENDDO - ENDIF - IF ( OTYPE .EQ. 3 .OR. OTYPE .EQ. 4 ) THEN - WRITE (NDSO,943) 'Bulletins, CSV format' - J = LEN_TRIM(FNMPRE) - DO IJ = 1,NOPTS - IF (FLREQ(IJ)) THEN - ICSV = 0 - IF ( NDSBUL .GT. 0 ) ICSV = NDSBUL + ENDIF + ENDDO + ENDIF + IF ( OTYPE .EQ. 3 .OR. OTYPE .EQ. 4 ) THEN + WRITE (NDSO,943) 'Bulletins, CSV format' + J = LEN_TRIM(FNMPRE) + DO IJ = 1,NOPTS + IF (FLREQ(IJ)) THEN + ICSV = 0 + IF ( NDSBUL .GT. 0 ) ICSV = NDSBUL #ifdef W3_NCO - IF ( NDSCBUL .GT. 0 ) ICSV = NDSCBUL + IF ( NDSCBUL .GT. 0 ) ICSV = NDSCBUL #endif - NDSCSV = NDSTAB + (IJ - 1) + ICSV - OPEN(NDSCSV,FILE=TRIM(PTNME(IJ))//'.csv',ERR=803,IOSTAT=IERR) - WRITE (NDSO,1947) TRIM(PTNME(IJ))//'.csv' - ENDIF - ENDDO - ENDIF - ELSE - WRITE (NDSE,1011) OTYPE - CALL EXTCDE ( 50 ) - END IF -! -! ... ITYPE = ILLEGAL -! - ELSE - WRITE (NDSE,1010) ITYPE - CALL EXTCDE ( 1 ) -! - END IF -! -! ... Output of output points -! - WRITE (NDSO,950) NREQ - DO I=1, NOPTS - IF (FLREQ(I)) THEN - IF ( FLAGLL ) THEN - WRITE (NDSO,951) PTNME(I), M2KM*PTLOC(1,I), & - M2KM*PTLOC(2,I) - ELSE - WRITE (NDSO,953) PTNME(I), M2KM*PTLOC(1,I), & - M2KM*PTLOC(2,I) - END IF - END IF - END DO -! - IF ( ITYPE.EQ.3 .AND. OTYPE.EQ.4 ) WRITE (NDSO,952) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Time management. -! - IOUT = 0 -! -! remark: it would be better to write these warnings only if source term -! output is requested + NDSCSV = NDSTAB + (IJ - 1) + ICSV + OPEN(NDSCSV,FILE=TRIM(PTNME(IJ))//'.csv',ERR=803,IOSTAT=IERR) + WRITE (NDSO,1947) TRIM(PTNME(IJ))//'.csv' + ENDIF + ENDDO + ENDIF + ELSE + WRITE (NDSE,1011) OTYPE + CALL EXTCDE ( 50 ) + END IF + ! + ! ... ITYPE = ILLEGAL + ! + ELSE + WRITE (NDSE,1010) ITYPE + CALL EXTCDE ( 1 ) + ! + END IF + ! + ! ... Output of output points + ! + WRITE (NDSO,950) NREQ + DO I=1, NOPTS + IF (FLREQ(I)) THEN + IF ( FLAGLL ) THEN + WRITE (NDSO,951) PTNME(I), M2KM*PTLOC(1,I), & + M2KM*PTLOC(2,I) + ELSE + WRITE (NDSO,953) PTNME(I), M2KM*PTLOC(1,I), & + M2KM*PTLOC(2,I) + END IF + END IF + END DO + ! + IF ( ITYPE.EQ.3 .AND. OTYPE.EQ.4 ) WRITE (NDSO,952) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Time management. + ! + IOUT = 0 + ! + ! remark: it would be better to write these warnings only if source term + ! output is requested #ifdef W3_IC1 - WRITE(NDSO,3960) + WRITE(NDSO,3960) #endif #ifdef W3_IC2 - WRITE(NDSO,3960) + WRITE(NDSO,3960) #endif #ifdef W3_IC3 - WRITE(NDSO,3960) + WRITE(NDSO,3960) #endif #ifdef W3_IC4 - WRITE(NDSO,3960) + WRITE(NDSO,3960) #endif #ifdef W3_IC5 - WRITE(NDSO,3960) + WRITE(NDSO,3960) #endif #ifdef W3_NL5 - WRITE(NDSO,3961) + WRITE(NDSO,3961) #endif - DO - DTEST = DSEC21 ( TIME , TOUT ) - IF ( DTEST .GT. 0. ) THEN - CALL W3IOPO ( 'READ', NDSOP, IOTEST ) - IF ( IOTEST .EQ. -1 ) THEN - WRITE (NDSO,949) - EXIT - END IF - CYCLE - END IF - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF -! - IOUT = IOUT + 1 - CALL STME21 ( TOUT , IDTIME ) - IF ( ( ITYPE.EQ.1 .AND. OTYPE.EQ.1 ) .OR. & - ( ITYPE.EQ.3 .AND. OTYPE.EQ.1 ) & - ) WRITE (NDSO,960) IDTIME - CALL W3EXPO - CALL TICK21 ( TOUT , DTREQ ) - IF ( IOUT .GE. NOUT ) EXIT - END DO -! -! ... ITYPE=4 & OTYPES=[2,4] requires adding lines at bottom of -! bulletin output for compatibility with version 2.22 -! - IF (ITYPE .EQ. 4 .AND. ( OTYPE .EQ. 2 .OR. OTYPE .EQ. 4 ) ) THEN - DO IJ = 1,NOPTS - IF (FLREQ(IJ)) THEN - NDSBUL = NDSTAB + (IJ - 1) - WRITE(NDSBUL,971) - WRITE(NDSBUL,974) BHSDROP, BHSMIN + DO + DTEST = DSEC21 ( TIME , TOUT ) + IF ( DTEST .GT. 0. ) THEN + CALL W3IOPO ( 'READ', NDSOP, IOTEST ) + IF ( IOTEST .EQ. -1 ) THEN + WRITE (NDSO,949) + EXIT + END IF + CYCLE + END IF + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF + ! + IOUT = IOUT + 1 + CALL STME21 ( TOUT , IDTIME ) + IF ( ( ITYPE.EQ.1 .AND. OTYPE.EQ.1 ) .OR. & + ( ITYPE.EQ.3 .AND. OTYPE.EQ.1 ) & + ) WRITE (NDSO,960) IDTIME + CALL W3EXPO + CALL TICK21 ( TOUT , DTREQ ) + IF ( IOUT .GE. NOUT ) EXIT + END DO + ! + ! ... ITYPE=4 & OTYPES=[2,4] requires adding lines at bottom of + ! bulletin output for compatibility with version 2.22 + ! + IF (ITYPE .EQ. 4 .AND. ( OTYPE .EQ. 2 .OR. OTYPE .EQ. 4 ) ) THEN + DO IJ = 1,NOPTS + IF (FLREQ(IJ)) THEN + NDSBUL = NDSTAB + (IJ - 1) + WRITE(NDSBUL,971) + WRITE(NDSBUL,974) BHSDROP, BHSMIN #ifdef W3_NCO - NDSCBUL = NDSTAB + (IJ - 1) + NOPTS - WRITE(NDSCBUL,961) - WRITE(NDSCBUL,962) + NDSCBUL = NDSTAB + (IJ - 1) + NOPTS + WRITE(NDSCBUL,961) + WRITE(NDSCBUL,962) #endif - ENDIF - ENDDO ENDIF -! - GOTO 888 -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 40 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 41 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 42 ) -! - 803 CONTINUE - WRITE (NDSE,1003) IERR - CALL EXTCDE ( 43 ) -! - 804 CONTINUE - WRITE (NDSE,1004) IERR - CALL EXTCDE ( 44 ) -! + ENDDO + ENDIF + ! + GOTO 888 + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 40 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 41 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 42 ) + ! +803 CONTINUE + WRITE (NDSE,1003) IERR + CALL EXTCDE ( 43 ) + ! +804 CONTINUE + WRITE (NDSE,1004) IERR + CALL EXTCDE ( 44 ) + ! #ifdef W3_O14 - 805 CONTINUE - WRITE (NDSE,1005) IERR - CALL EXTCDE ( 45 ) -#endif -! - 888 CONTINUE -! - WRITE (NDSO,999) -! +805 CONTINUE + WRITE (NDSE,1005) IERR + CALL EXTCDE ( 45 ) +#endif + ! +888 CONTINUE + ! + WRITE (NDSO,999) + ! #ifdef W3_NCO -! CALL W3TAGE('WAVESPEC') -#endif -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Point output post.*** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) -! - 920 FORMAT ( ' Grid name : ',A/) -! - 930 FORMAT ( ' Points in file : '/ & - ' ------------------------------------') - 931 FORMAT ( ' ',A,2F10.2) - 932 FORMAT ( ' ',A,2(F8.1,'E3')) -! - 940 FORMAT (/' Output time data : '/ & - ' --------------------------------------------------'/ & - ' First time : ',A) - 941 FORMAT ( ' Interval : ',A/ & - ' Number of requests : ',I6) - 942 FORMAT (/' Output type ',I2,' :'/ & - ' --------------------------------------------------'/ & - ' ',A/) - 943 FORMAT ( ' Subtype : ',A) - 944 FORMAT ( ' ',A) + ! CALL W3TAGE('WAVESPEC') +#endif + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Point output post.*** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) + ! +920 FORMAT ( ' Grid name : ',A/) + ! +930 FORMAT ( ' Points in file : '/ & + ' ------------------------------------') +931 FORMAT ( ' ',A,2F10.2) +932 FORMAT ( ' ',A,2(F8.1,'E3')) + ! +940 FORMAT (/' Output time data : '/ & + ' --------------------------------------------------'/ & + ' First time : ',A) +941 FORMAT ( ' Interval : ',A/ & + ' Number of requests : ',I6) +942 FORMAT (/' Output type ',I2,' :'/ & + ' --------------------------------------------------'/ & + ' ',A/) +943 FORMAT ( ' Subtype : ',A) +944 FORMAT ( ' ',A) #ifdef W3_O14 - 945 FORMAT ( ' ',I5,3X,A,2F10.2,3X,A) -#endif - 948 FORMAT ( ' Data for ',A) - 949 FORMAT (/' End of file reached '/) -! - 950 FORMAT (/' Requested output for',I3,' points : '/ & - ' --------------------------------------------------') - 951 FORMAT ( ' ',A,2F10.2) - 953 FORMAT ( ' ',A,2(F8.1,'E3')) - 952 FORMAT (/' Output times :'/ & - ' --------------------------------------------------') +945 FORMAT ( ' ',I5,3X,A,2F10.2,3X,A) +#endif +948 FORMAT ( ' Data for ',A) +949 FORMAT (/' End of file reached '/) + ! +950 FORMAT (/' Requested output for',I3,' points : '/ & + ' --------------------------------------------------') +951 FORMAT ( ' ',A,2F10.2) +953 FORMAT ( ' ',A,2(F8.1,'E3')) +952 FORMAT (/' Output times :'/ & + ' --------------------------------------------------') #ifdef W3_NCO - 961 FORMAT ('----------------------------------------', & - '---------------------------') - 962 FORMAT ( 'DD = Day of Month'/ & - 'HH = Hour of Day'/ & - 'HS = Total Significant Wave Height (feet)'/ & - 'SS = Significant Wave Height of separate system (feet)'/ & - 'PP = Peak Period of separate system (whole seconds)'/ & - 'DDD = Mean Direction of separate system (degrees,"from")') -#endif - 971 FORMAT (' +-------+-----------+-----------------+', & - '-----------------+-----------------+----', & - '-------------+-----------------+--------', & - '---------+')! - 974 FORMAT ( & +961 FORMAT ('----------------------------------------', & + '---------------------------') +962 FORMAT ( 'DD = Day of Month'/ & + 'HH = Hour of Day'/ & + 'HS = Total Significant Wave Height (feet)'/ & + 'SS = Significant Wave Height of separate system (feet)'/ & + 'PP = Peak Period of separate system (whole seconds)'/ & + 'DDD = Mean Direction of separate system (degrees,"from")') +#endif +971 FORMAT (' +-------+-----------+-----------------+', & + '-----------------+-----------------+----', & + '-------------+-----------------+--------', & + '---------+')! +974 FORMAT ( & 75X,'Hst : Total sigificant wave height.'/ & 75X,'n : Number of fields with Hs > ',f4.2, & - ' in 2-D spectrum.'/ & + ' in 2-D spectrum.'/ & 75X,'x : Number of fields with Hs > ',f4.2, & - ' not in table.'/ & + ' not in table.'/ & 75X,'Hs : Significant wave height of separate wave field.'/ & 75X,'Tp : Peak period of separate wave field.'/ & 75X,'dir : Mean direction of separate wave field.'/ & 75X,'* : Wave generation due to local wind probable.') - 1940 FORMAT ( ' ',A,' print plots not requested.') - 1941 FORMAT ( ' ',A,' print plots normalized.') - 1942 FORMAT ( ' Scale factor ',A,' spectrum : ',E10.3) - 1943 FORMAT ( ' File name : ',A,' (',A,')') - 1944 FORMAT ('''',A,'''',1X,3I6,1X,'''',A,'''') - 1945 FORMAT (8E10.3) - 1946 FORMAT (7E11.3) - 1947 FORMAT ( ' File name : ',A) -! - 2940 FORMAT ( ' Table output : ',A/ & - ' File name : ',A) -! - 3940 FORMAT ( ' ',A) - 3941 FORMAT ( ' File name : ',A) - 3943 FORMAT ( ' File name : ',A,' (',A,')') - 3944 FORMAT ('''',A,'''',1X,3I6,6L2) - 3945 FORMAT (8E10.3) - 3946 FORMAT (7E11.3) -! - 960 FORMAT (//' Output for ',A/ & - ' --------------------------------------------------') -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Point output '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & - ' ERROR IN OPENING TABLE FILE'/ & - ' IOSTAT =',I5/) -! - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & - ' ERROR IN OPENING IDL FILE'/ & - ' IOSTAT =',I5/) -! +1940 FORMAT ( ' ',A,' print plots not requested.') +1941 FORMAT ( ' ',A,' print plots normalized.') +1942 FORMAT ( ' Scale factor ',A,' spectrum : ',E10.3) +1943 FORMAT ( ' File name : ',A,' (',A,')') +1944 FORMAT ('''',A,'''',1X,3I6,1X,'''',A,'''') +1945 FORMAT (8E10.3) +1946 FORMAT (7E11.3) +1947 FORMAT ( ' File name : ',A) + ! +2940 FORMAT ( ' Table output : ',A/ & + ' File name : ',A) + ! +3940 FORMAT ( ' ',A) +3941 FORMAT ( ' File name : ',A) +3943 FORMAT ( ' File name : ',A,' (',A,')') +3944 FORMAT ('''',A,'''',1X,3I6,6L2) +3945 FORMAT (8E10.3) +3946 FORMAT (7E11.3) + ! +960 FORMAT (//' Output for ',A/ & + ' --------------------------------------------------') + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Point output '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' ERROR IN OPENING TABLE FILE'/ & + ' IOSTAT =',I5/) + ! +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' ERROR IN OPENING IDL FILE'/ & + ' IOSTAT =',I5/) + ! #ifdef W3_O14 - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & - ' ERROR IN OPENING BUOY LOG FILE'/ & - ' IOSTAT =',I5/) -#endif -! - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' LAST POINT INDEX IS NOT -1'/ & - ' OR TOO MANY POINT INDEXES DEFINED'/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & - ' ILLEGAL TYPE, ITYPE =',I4/) -! - 1011 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & - ' ILLEGAL TYPE, OTYPE =',I4/) -! - 1012 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & - ' MULTIPLE OUTPUT POINTS DEFINED, ITYPE =',I4,/ & - ' ONLY SINGLE POINT ALLOWED IN THIS VERSION'/) +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' ERROR IN OPENING BUOY LOG FILE'/ & + ' IOSTAT =',I5/) +#endif + ! +1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' LAST POINT INDEX IS NOT -1'/ & + ' OR TOO MANY POINT INDEXES DEFINED'/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' ILLEGAL TYPE, ITYPE =',I4/) + ! +1011 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' ILLEGAL TYPE, OTYPE =',I4/) + ! +1012 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' MULTIPLE OUTPUT POINTS DEFINED, ITYPE =',I4,/ & + ' ONLY SINGLE POINT ALLOWED IN THIS VERSION'/) #ifdef W3_IC1 - 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & - ' Ice source terms !/IC1 skipped'/ & - ' in dissipation term.'/) +3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Ice source terms !/IC1 skipped'/ & + ' in dissipation term.'/) #endif #ifdef W3_IC2 - 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & - ' Ice source terms !/IC2 skipped'/ & - ' in dissipation term.'/) +3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Ice source terms !/IC2 skipped'/ & + ' in dissipation term.'/) #endif #ifdef W3_IC3 - 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & - ' Ice source terms !/IC3 skipped'/ & - ' in dissipation term.'/) +3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Ice source terms !/IC3 skipped'/ & + ' in dissipation term.'/) #endif #ifdef W3_IC4 - 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & - ' Ice source terms !/IC4 skipped'/ & - ' in dissipation term.'/) +3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Ice source terms !/IC4 skipped'/ & + ' in dissipation term.'/) #endif #ifdef W3_IC5 - 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & - ' Ice source terms !/IC5 skipped'/ & - ' in dissipation term.'/) +3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Ice source terms !/IC5 skipped'/ & + ' in dissipation term.'/) #endif #ifdef W3_NL5 - 3961 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & - ' Snl source terms !/NL5 skipped'/ & - ' in interaction term.'/) -#endif -! -!/ -!/ Internal subroutine W3EXPO ---------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3EXPO -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | J.H. Alves | -!/ | F. Ardhuin | -!/ | A. Chawla | -!/ | FORTRAN 90 | -!/ | Last update : 06-Feb-2014 | -!/ +-----------------------------------+ -!/ -!/ 08-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Massive changes to logistics -!/ 09-Jan-2001 : U* bug fix in tabular output ( version 2.05 ) -!/ 25-Jan-2001 : Flat grid version ( version 2.06 ) -!/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) -!/ 11-Jun-2001 : Clean up ( version 2.11 ) -!/ 11-Oct-2001 : Clean up, X*, Y* in tables ( version 2.14 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 17-Apr-2006 : Filter for directional spread. ( version 3.09 ) -!/ 23-Jun-2006 : Linear input added. ( version 3.09 ) -!/ 03-Jul-2006 : Separate flux modules. ( version 3.09 ) -!/ 28-Oct-2006 : Add partitioning option. ( version 3.10 ) -!/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) -!/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) -!/ (J. H. Alves) -!/ 09-Oct-2007 : WAM 4+ Sin and Sds added. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 09-Oct-2007 : Experimental Sbs (BS1) added. ( version 3.13 ) -!/ (F. Ardhuin) -!/ 09-Apr-2008 : Adding an additional output for ( version 3.12 ) -!/ WMO standard (A. Chawla) -!/ 29-Apr-2008 : Adjust format partition output. ( version 3.14 ) -!/ 01-Jul-2011 : Adding BT4 ( version 4.01 ) -!/ 16-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) -!/ from 3.15 (HLT). ( version 4.08 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ 06-Feb-2014 : Fix header format in part. files. ( version 4.18 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ -! 1. Purpose : -! -! Perform actual point output. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SPRn Subr. W3SRCnMD Mean wave parameters for use in -! source terms. -! W3FLXn Subr. W3FLXnMD Flux/stress computation. -! W3SLNn Subr. W3SLNnMD Linear input. -! W3SINn Subr. W3SRCnMD Input source term. -! W3SDSn Subr. W3SRCnMD Whitecapping source term -! W3SNLn Subr. W3SNLnMD Nonlinear interactions. -! W3SBTn Subr. W3SBTnMD Bottom friction source term. -! W3SDBn Subr. W3SBTnMD Depth induced breaking source term. -! W3STRn Subr. W3STRnMD Triad interaction source term. -! W3SBSn Subr. W3SBSnMD Bottom scattering source term. -! W3PART Sunr. W3PARTMD Spectral partitioning routine. -! STRACE Subr. W3SERVMD Subroutine tracing. -! STME21 Subr. W3TIMEMD Convert time to string. -! PRT1DS Subr. W3ARRYMD Print plot of 1-D spectrum. -! PRT1DM Subr. Id. Print plot of several 1-D spectra. -! PRT2DS Subr. Id. Print plot of 2-D spectrum. -! WAVNU1 Subr. W3DISPMD Solve dispersion relation. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Main program in which it is contained, -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Spectra are relative frequency energy spectra. -! - Note that arrays CX and CY of the main program now contain -! the absolute current speed and direction respectively. -! -! - BT8&9 issues : -! -! Q: What is the problem? -! A: Point output of Sbot with BT8 or BT9 is not presently -! supported. -! -! Q: What can a user do now? -! A: When using BT8 or BT9 with ITYPE=3 , the -! user should set the 5th T/F value in ww3_outp.inp for -! ITYPE=3 to "F" like so : -! 2 1. 1. 51 T T T T F T 0 F -! $ ^ ^ ^ ^ ^ ^ Sum of selected sources -! $ | | | | ^ Wave-bottom interactions -! $ | | | ^ Dissipation -! $ | | ^ Nonlinear interactions -! $ | ^ Wind-wave interactions -! $ ^ Spectrum -! If the user really need this source function, he/she -! needs to add test output to the mud subroutine -! directly -! -! Q: Why doesn't this functionality exist? -! A: The Sbot source function in ww3_outp was originally written -! with the case of BT1 in mind. BT1 uses a uniform friction -! factor, so it does not need any special variable for the -! local friction factor. BT8 and BT9 allow non-uniform mud -! variables (thickness, density, viscosity) and the mud -! subroutines are written with ww3_shel in mind, where the -! source function is calculated on the computational grid -! point IX IY. +3961 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Snl source terms !/NL5 skipped'/ & + ' in interaction term.'/) +#endif + ! + !/ + !/ Internal subroutine W3EXPO ---------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3EXPO + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | J.H. Alves | + !/ | F. Ardhuin | + !/ | A. Chawla | + !/ | FORTRAN 90 | + !/ | Last update : 06-Feb-2014 | + !/ +-----------------------------------+ + !/ + !/ 08-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Massive changes to logistics + !/ 09-Jan-2001 : U* bug fix in tabular output ( version 2.05 ) + !/ 25-Jan-2001 : Flat grid version ( version 2.06 ) + !/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) + !/ 11-Jun-2001 : Clean up ( version 2.11 ) + !/ 11-Oct-2001 : Clean up, X*, Y* in tables ( version 2.14 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 17-Apr-2006 : Filter for directional spread. ( version 3.09 ) + !/ 23-Jun-2006 : Linear input added. ( version 3.09 ) + !/ 03-Jul-2006 : Separate flux modules. ( version 3.09 ) + !/ 28-Oct-2006 : Add partitioning option. ( version 3.10 ) + !/ 24-Mar-2007 : Add pars for entire spectrum. ( version 3.11 ) + !/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) + !/ (J. H. Alves) + !/ 09-Oct-2007 : WAM 4+ Sin and Sds added. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 09-Oct-2007 : Experimental Sbs (BS1) added. ( version 3.13 ) + !/ (F. Ardhuin) + !/ 09-Apr-2008 : Adding an additional output for ( version 3.12 ) + !/ WMO standard (A. Chawla) + !/ 29-Apr-2008 : Adjust format partition output. ( version 3.14 ) + !/ 01-Jul-2011 : Adding BT4 ( version 4.01 ) + !/ 16-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) + !/ from 3.15 (HLT). ( version 4.08 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ 06-Feb-2014 : Fix header format in part. files. ( version 4.18 ) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ + ! 1. Purpose : + ! + ! Perform actual point output. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SPRn Subr. W3SRCnMD Mean wave parameters for use in + ! source terms. + ! W3FLXn Subr. W3FLXnMD Flux/stress computation. + ! W3SLNn Subr. W3SLNnMD Linear input. + ! W3SINn Subr. W3SRCnMD Input source term. + ! W3SDSn Subr. W3SRCnMD Whitecapping source term + ! W3SNLn Subr. W3SNLnMD Nonlinear interactions. + ! W3SBTn Subr. W3SBTnMD Bottom friction source term. + ! W3SDBn Subr. W3SBTnMD Depth induced breaking source term. + ! W3STRn Subr. W3STRnMD Triad interaction source term. + ! W3SBSn Subr. W3SBSnMD Bottom scattering source term. + ! W3PART Sunr. W3PARTMD Spectral partitioning routine. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! PRT1DS Subr. W3ARRYMD Print plot of 1-D spectrum. + ! PRT1DM Subr. Id. Print plot of several 1-D spectra. + ! PRT2DS Subr. Id. Print plot of 2-D spectrum. + ! WAVNU1 Subr. W3DISPMD Solve dispersion relation. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Main program in which it is contained, + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Spectra are relative frequency energy spectra. + ! - Note that arrays CX and CY of the main program now contain + ! the absolute current speed and direction respectively. + ! + ! - BT8&9 issues : + ! + ! Q: What is the problem? + ! A: Point output of Sbot with BT8 or BT9 is not presently + ! supported. + ! + ! Q: What can a user do now? + ! A: When using BT8 or BT9 with ITYPE=3 , the + ! user should set the 5th T/F value in ww3_outp.inp for + ! ITYPE=3 to "F" like so : + ! 2 1. 1. 51 T T T T F T 0 F + ! $ ^ ^ ^ ^ ^ ^ Sum of selected sources + ! $ | | | | ^ Wave-bottom interactions + ! $ | | | ^ Dissipation + ! $ | | ^ Nonlinear interactions + ! $ | ^ Wind-wave interactions + ! $ ^ Spectrum + ! If the user really need this source function, he/she + ! needs to add test output to the mud subroutine + ! directly + ! + ! Q: Why doesn't this functionality exist? + ! A: The Sbot source function in ww3_outp was originally written + ! with the case of BT1 in mind. BT1 uses a uniform friction + ! factor, so it does not need any special variable for the + ! local friction factor. BT8 and BT9 allow non-uniform mud + ! variables (thickness, density, viscosity) and the mud + ! subroutines are written with ww3_shel in mind, where the + ! source function is calculated on the computational grid + ! point IX IY. -! Q: How can we add this functionality? -! A: To fix it, we would need to : -! 1) interpolate the mud variables from the computational -! grid point IX IY to the output points (this is already -! done now for wind, for example) (the same should probably -! be done for the ice properties also) This would be done -! in w3iopomd.ftn, analogous to what is done now for the -! wind variable WAO. -! 2) manage the arrays for the new variables (mud and ice -! properties on the output points) This would be done in -! w3odatmd.ftn, again analogous to what is done now for the -! wind variable WAO. -! 3) change the mud routines so that they take the local mud -! parameters through the subroutine arguments rather than -! taking IX IY as subroutine arguments. This would allow -! flexibility to call the mud routine from ww3_shel or -! ww3_outp (instead of just ww3_shel as is the case now). -! -!/---------------------------------------------------------------------/ -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! !/FLXx Flux/stress computation. -! !/LNx Linear input package -! !/STx Source term package -! !/NLx Nonlinear interaction package -! !/BTx Bottom friction package -! !/ICx S_ice source term package -! !/DBx Depth-induced breaking package -! !/TRx Triad interaction package -! !/BSx Bottom scattering package -! -! !/STAB2 Stability correction for !/ST2 -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! Q: How can we add this functionality? + ! A: To fix it, we would need to : + ! 1) interpolate the mud variables from the computational + ! grid point IX IY to the output points (this is already + ! done now for wind, for example) (the same should probably + ! be done for the ice properties also) This would be done + ! in w3iopomd.ftn, analogous to what is done now for the + ! wind variable WAO. + ! 2) manage the arrays for the new variables (mud and ice + ! properties on the output points) This would be done in + ! w3odatmd.ftn, again analogous to what is done now for the + ! wind variable WAO. + ! 3) change the mud routines so that they take the local mud + ! parameters through the subroutine arguments rather than + ! taking IX IY as subroutine arguments. This would allow + ! flexibility to call the mud routine from ww3_shel or + ! ww3_outp (instead of just ww3_shel as is the case now). + ! + !/---------------------------------------------------------------------/ + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! !/FLXx Flux/stress computation. + ! !/LNx Linear input package + ! !/STx Source term package + ! !/NLx Nonlinear interaction package + ! !/BTx Bottom friction package + ! !/ICx S_ice source term package + ! !/DBx Depth-induced breaking package + ! !/TRx Triad interaction package + ! !/BSx Bottom scattering package + ! + ! !/STAB2 Stability correction for !/ST2 + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_FLX1 - USE W3FLX1MD + USE W3FLX1MD #endif #ifdef W3_FLX2 - USE W3FLX2MD + USE W3FLX2MD #endif #ifdef W3_FLX3 - USE W3FLX3MD + USE W3FLX3MD #endif #ifdef W3_FLX4 - USE W3FLX4MD + USE W3FLX4MD #endif #ifdef W3_FLX5 - USE W3FLX5MD + USE W3FLX5MD #endif #ifdef W3_LN1 - USE W3SLN1MD + USE W3SLN1MD #endif #ifdef W3_ST1 - USE W3SRC1MD + USE W3SRC1MD #endif #ifdef W3_ST2 - USE W3SRC2MD + USE W3SRC2MD #endif #ifdef W3_ST3 - USE W3SRC3MD + USE W3SRC3MD #endif #ifdef W3_ST4 - USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 + USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 #endif #ifdef W3_ST6 - USE W3SRC6MD - USE W3SWLDMD, ONLY : W3SWL6 - USE W3GDATMD, ONLY : SWL6S6 + USE W3SRC6MD + USE W3SWLDMD, ONLY : W3SWL6 + USE W3GDATMD, ONLY : SWL6S6 #endif #ifdef W3_NL1 - USE W3SNL1MD + USE W3SNL1MD #endif #ifdef W3_NL2 - USE W3SNL2MD + USE W3SNL2MD #endif #ifdef W3_NL3 - USE W3SNL3MD + USE W3SNL3MD #endif #ifdef W3_NL4 - USE W3SNL4MD + USE W3SNL4MD #endif #ifdef W3_NLS - USE W3SNLSMD + USE W3SNLSMD #endif #ifdef W3_BT1 - USE W3SBT1MD + USE W3SBT1MD #endif #ifdef W3_BT4 - USE W3SBT4MD + USE W3SBT4MD #endif #ifdef W3_BT8 - USE W3SBT8MD + USE W3SBT8MD #endif #ifdef W3_BT9 - USE W3SBT9MD + USE W3SBT9MD #endif #ifdef W3_DB1 - USE W3SDB1MD + USE W3SDB1MD #endif #ifdef W3_BS1 - USE W3SBS1MD + USE W3SBS1MD #endif #ifdef W3_IS2 - USE W3SIS2MD - USE W3GDATMD, ONLY: IICEDISP -#endif - USE W3PARTMD, ONLY: W3PART - USE W3DISPMD, ONLY: WAVNU1, LIU_FORWARD_DISPERSION -!/ - USE W3ARRYMD, ONLY: PRT1DS, PRT2DS, PRT1DM - USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE - USE W3BULLMD, ONLY: W3BULL -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: J, I1, I2, ISP, IKM, ITH, & - IK, IH, IM, IS, IYR, IMTH, IDY, ITT, & - I, NPART, IP, IX, IY, ISEA - INTEGER, SAVE :: IPASS = 0 + USE W3SIS2MD + USE W3GDATMD, ONLY: IICEDISP +#endif + USE W3PARTMD, ONLY: W3PART + USE W3DISPMD, ONLY: WAVNU1, LIU_FORWARD_DISPERSION + !/ + USE W3ARRYMD, ONLY: PRT1DS, PRT2DS, PRT1DM + USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE + USE W3BULLMD, ONLY: W3BULL + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: J, I1, I2, ISP, IKM, ITH, & + IK, IH, IM, IS, IYR, IMTH, IDY, ITT, & + I, NPART, IP, IX, IY, ISEA + INTEGER, SAVE :: IPASS = 0 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL :: DEPTH, SQRTH, CDIR, SIX, R1, R2, & - UDIR, UDIRR, UABS, XL, XH, XL2, XH2, & - ET, EWN, ETR, ETX, ETY, EBND, EBX, & - EBY, HSIG, WLEN, TMEAN, THMEAN, & - THSPRD, EMAX, EL, EH, DENOM, FP, THP,& - SPP, CD, USTAR, FACTOR, UNORM, ESTAR,& - FPSTAR, FACF, FACE, FACS, HMAT, WNA, & - XYZ, AGE1, AFR, AGE2, FACT, XSTAR, & - YSTAR, FHIGH, ZWND, Z0, USTD, EMEAN, & - FMEAN, WNMEAN, UDIRCA, X, Y, CHARN, & - M2KM, ICEF, ICEDMAX, ICETHICK, & - ICECON + INTEGER, SAVE :: IENT = 0 +#endif + REAL :: DEPTH, SQRTH, CDIR, SIX, R1, R2, & + UDIR, UDIRR, UABS, XL, XH, XL2, XH2, & + ET, EWN, ETR, ETX, ETY, EBND, EBX, & + EBY, HSIG, WLEN, TMEAN, THMEAN, & + THSPRD, EMAX, EL, EH, DENOM, FP, THP,& + SPP, CD, USTAR, FACTOR, UNORM, ESTAR,& + FPSTAR, FACF, FACE, FACS, HMAT, WNA, & + XYZ, AGE1, AFR, AGE2, FACT, XSTAR, & + YSTAR, FHIGH, ZWND, Z0, USTD, EMEAN, & + FMEAN, WNMEAN, UDIRCA, X, Y, CHARN, & + M2KM, ICEF, ICEDMAX, ICETHICK, & + ICECON #ifdef W3_FLX5 - REAL ::TAUA, TAUADIR, RHOAIR + REAL ::TAUA, TAUADIR, RHOAIR #endif #ifdef W3_IS2 - REAL :: WN_R(NK),CG_ICE(NK), ALPHA_LIU(NK) + REAL :: WN_R(NK),CG_ICE(NK), ALPHA_LIU(NK) #endif #ifdef W3_ST1 - REAL :: AMAX, FH1, FH2 + REAL :: AMAX, FH1, FH2 #endif #ifdef W3_ST2 - REAL :: AMAX, ALPHA(NK), FPI + REAL :: AMAX, ALPHA(NK), FPI #endif #ifdef W3_ST3 - REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & - TAUWNX, TAUWNY + REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & + TAUWNX, TAUWNY #endif #ifdef W3_ST4 - REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & - TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4), DLWMEAN + REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & + TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4), DLWMEAN #endif #ifdef W3_ST6 - REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY + REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY #endif #ifdef W3_BS1 - REAL :: TAUSCX, TAUSCY + REAL :: TAUSCX, TAUSCY #endif #ifdef W3_BT4 - REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) + REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) #endif - REAL :: ICE + REAL :: ICE #ifdef W3_STAB2 - REAL :: STAB0, STAB, COR1, COR2, ASFAC, & - THARG1, THARG2 -#endif - REAL, SAVE :: HSMIN = 0.05 - REAL :: WN(NK), CG(NK), R(NK) - REAL :: E(NK,NTH), E1(NK), APM(NK), & - THBND(NK), SPBND(NK), A(NTH,NK), & - WN2(NTH,NK) - REAL :: DIA(NTH,NK), SWN(NK,NTH), SNL(NK,NTH),& - SDS(NK,NTH), SBT(NK,NTH), SIS(NK,NTH),& - STT(NK,NTH), DIA2(NTH,NK) - REAL :: XLN(NTH,NK), XIN(NTH,NK), XNL(NTH,NK),& - XTR(NTH,NK), XDS(NTH,NK), XDB(NTH,NK),& - XBT(NTH,NK), XBS(NTH,NK), XXX(NTH,NK),& - XIS(NTH,NK), XWL(NTH,NK) - REAL :: SIN1(NK), SNL1(NK), SDS1(NK), & - SBT1(NK), STT1(NK), SIS1(NK), & - E1ALL(NK,6) - LOGICAL :: LBREAK + REAL :: STAB0, STAB, COR1, COR2, ASFAC, & + THARG1, THARG2 +#endif + REAL, SAVE :: HSMIN = 0.05 + REAL :: WN(NK), CG(NK), R(NK) + REAL :: E(NK,NTH), E1(NK), APM(NK), & + THBND(NK), SPBND(NK), A(NTH,NK), & + WN2(NTH,NK) + REAL :: DIA(NTH,NK), SWN(NK,NTH), SNL(NK,NTH),& + SDS(NK,NTH), SBT(NK,NTH), SIS(NK,NTH),& + STT(NK,NTH), DIA2(NTH,NK) + REAL :: XLN(NTH,NK), XIN(NTH,NK), XNL(NTH,NK),& + XTR(NTH,NK), XDS(NTH,NK), XDB(NTH,NK),& + XBT(NTH,NK), XBS(NTH,NK), XXX(NTH,NK),& + XIS(NTH,NK), XWL(NTH,NK) + REAL :: SIN1(NK), SNL1(NK), SDS1(NK), & + SBT1(NK), STT1(NK), SIS1(NK), & + E1ALL(NK,6) + LOGICAL :: LBREAK #ifdef W3_ST3 - LOGICAL :: LLWS(NSPEC) + LOGICAL :: LLWS(NSPEC) #endif #ifdef W3_ST4 - LOGICAL :: LLWS(NSPEC) - REAL :: LAMBDA(NSPEC) -#endif - CHARACTER :: DTME21*23 - CHARACTER(LEN=4) VAR1(6) - CHARACTER(LEN=1) IDLAT, IDLON - CHARACTER(LEN=100) BT8MSG -! - DATA VAR1 / 'Sin ' , 'Snl ', 'Sds ' , 'Sbt ' , 'Sice', 'Stot' / -!/ -!/ ------------------------------------------------------------------- / -!/ -! 1. Initialisations -! + LOGICAL :: LLWS(NSPEC) + REAL :: LAMBDA(NSPEC) +#endif + CHARACTER :: DTME21*23 + CHARACTER(LEN=4) VAR1(6) + CHARACTER(LEN=1) IDLAT, IDLON + CHARACTER(LEN=100) BT8MSG + ! + DATA VAR1 / 'Sin ' , 'Snl ', 'Sds ' , 'Sbt ' , 'Sice', 'Stot' / + !/ + !/ ------------------------------------------------------------------- / + !/ + ! 1. Initialisations + ! #ifdef W3_S - CALL STRACE (IENT, 'W3EXPO') -#endif -! - IF ( FLAGLL ) THEN - M2KM = 1. - ELSE - M2KM = 1.E-3 - END IF -! - XL = 1./XFR - 1. - XH = XFR - 1. - XL2 = XL**2 - XH2 = XH**2 - IPASS = IPASS + 1 -! - IF ( ITYPE .EQ. 3 ) THEN - XLN = 0. - XIN = 0. - XNL = 0. - XTR = 0. - XDS = 0. - XDB = 0. - XBT = 0. - XBS = 0. - XWL = 0. - XXX = 0. - XIS = 0. - END IF -! + CALL STRACE (IENT, 'W3EXPO') +#endif + ! + IF ( FLAGLL ) THEN + M2KM = 1. + ELSE + M2KM = 1.E-3 + END IF + ! + XL = 1./XFR - 1. + XH = XFR - 1. + XL2 = XL**2 + XH2 = XH**2 + IPASS = IPASS + 1 + ! + IF ( ITYPE .EQ. 3 ) THEN + XLN = 0. + XIN = 0. + XNL = 0. + XTR = 0. + XDS = 0. + XDB = 0. + XBT = 0. + XBS = 0. + XWL = 0. + XXX = 0. + XIS = 0. + END IF + ! #ifdef W3_T - WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) - WRITE (NDST,9001) ITYPE, OTYPE, NREQ, SCALE1, SCALE2, FLSRCE -#endif -! -! Output of time -! - IF ( ( ITYPE.EQ.1 .AND. OTYPE.EQ.3 ) .OR. & - ( ITYPE.EQ.3 .AND. OTYPE.EQ.4 ) ) THEN - IF ( FLFORM ) THEN - WRITE (NDSTAB) TIME - ELSE - WRITE (NDSTAB,900) TIME - END IF - END IF -! - IF (ITYPE.EQ.2) THEN - IF ( NREQ.EQ.1 .AND. IPASS.EQ.1 ) THEN - IF ( OTYPE.EQ.1 ) THEN - WRITE (NDSTAB,1901) - ELSE IF ( OTYPE.EQ.2 ) THEN - WRITE (NDSTAB,1902) - ELSE IF ( OTYPE.EQ.3 ) THEN - WRITE (NDSTAB,1903) - ELSE IF ( OTYPE.EQ.4 ) THEN - WRITE (NDSTAB,1904) - ELSE IF ( OTYPE.EQ.5 ) THEN - WRITE (NDSTAB,1905) - ELSE IF ( OTYPE.EQ.6 ) THEN - WRITE (NDSTAB,1906) - END IF - END IF - IF ( NREQ.NE.1 ) THEN - CALL STME21 ( TIME , DTME21 ) - IF ( IPASS .NE. 1 ) WRITE (NDSTAB,1910) - IF ( OTYPE.EQ.1 ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSTAB,1911) DTME21 - ELSE - WRITE (NDSTAB,1711) DTME21 - END IF - ELSE IF ( OTYPE.EQ.2 ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSTAB,1912) DTME21 - ELSE - WRITE (NDSTAB,1712) DTME21 - END IF - ELSE IF ( OTYPE.EQ.3 ) THEN - WRITE (NDSTAB,1913) DTME21 - ELSE IF ( OTYPE.EQ.4 ) THEN - WRITE (NDSTAB,1914) DTME21 - ELSE IF ( OTYPE.EQ.5 ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSTAB,1915) DTME21 - ELSE - WRITE (NDSTAB,1715) DTME21 - END IF - ELSE IF ( OTYPE.EQ.6 ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSTAB,1916) DTME21 - ELSE - WRITE (NDSTAB,1716) DTME21 - END IF - END IF - END IF + WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) + WRITE (NDST,9001) ITYPE, OTYPE, NREQ, SCALE1, SCALE2, FLSRCE +#endif + ! + ! Output of time + ! + IF ( ( ITYPE.EQ.1 .AND. OTYPE.EQ.3 ) .OR. & + ( ITYPE.EQ.3 .AND. OTYPE.EQ.4 ) ) THEN + IF ( FLFORM ) THEN + WRITE (NDSTAB) TIME + ELSE + WRITE (NDSTAB,900) TIME + END IF + END IF + ! + IF (ITYPE.EQ.2) THEN + IF ( NREQ.EQ.1 .AND. IPASS.EQ.1 ) THEN + IF ( OTYPE.EQ.1 ) THEN + WRITE (NDSTAB,1901) + ELSE IF ( OTYPE.EQ.2 ) THEN + WRITE (NDSTAB,1902) + ELSE IF ( OTYPE.EQ.3 ) THEN + WRITE (NDSTAB,1903) + ELSE IF ( OTYPE.EQ.4 ) THEN + WRITE (NDSTAB,1904) + ELSE IF ( OTYPE.EQ.5 ) THEN + WRITE (NDSTAB,1905) + ELSE IF ( OTYPE.EQ.6 ) THEN + WRITE (NDSTAB,1906) END IF -! - IF (ITYPE.EQ.3) THEN - IF ( OTYPE .EQ. 4 ) THEN - CALL STME21 ( TIME , DTME21 ) - WRITE (NDSO,905) DTME21 - END IF + END IF + IF ( NREQ.NE.1 ) THEN + CALL STME21 ( TIME , DTME21 ) + IF ( IPASS .NE. 1 ) WRITE (NDSTAB,1910) + IF ( OTYPE.EQ.1 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSTAB,1911) DTME21 + ELSE + WRITE (NDSTAB,1711) DTME21 + END IF + ELSE IF ( OTYPE.EQ.2 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSTAB,1912) DTME21 + ELSE + WRITE (NDSTAB,1712) DTME21 + END IF + ELSE IF ( OTYPE.EQ.3 ) THEN + WRITE (NDSTAB,1913) DTME21 + ELSE IF ( OTYPE.EQ.4 ) THEN + WRITE (NDSTAB,1914) DTME21 + ELSE IF ( OTYPE.EQ.5 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSTAB,1915) DTME21 + ELSE + WRITE (NDSTAB,1715) DTME21 + END IF + ELSE IF ( OTYPE.EQ.6 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSTAB,1916) DTME21 + ELSE + WRITE (NDSTAB,1716) DTME21 + END IF END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Loop over output points. -! - DO J=1, NOPTS - IF ( FLREQ(J) ) THEN -! + END IF + END IF + ! + IF (ITYPE.EQ.3) THEN + IF ( OTYPE .EQ. 4 ) THEN + CALL STME21 ( TIME , DTME21 ) + WRITE (NDSO,905) DTME21 + END IF + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! Loop over output points. + ! + DO J=1, NOPTS + IF ( FLREQ(J) ) THEN + ! #ifdef W3_T - WRITE (NDST,9002) PTNME(J) -#endif -! -! 2. Calculate grid parameters using and inlined version of WAVNU1. -! - DEPTH = MAX ( DMIN, DPO(J) ) - SQRTH = SQRT ( DEPTH ) - UDIR = MOD ( 270. - WDO(J)*RADE , 360. ) - UDIRCA = WDO(J)*RADE - UDIRR = WDO(J) - UABS = MAX ( 0.001 , WAO(J) ) + WRITE (NDST,9002) PTNME(J) +#endif + ! + ! 2. Calculate grid parameters using and inlined version of WAVNU1. + ! + DEPTH = MAX ( DMIN, DPO(J) ) + SQRTH = SQRT ( DEPTH ) + UDIR = MOD ( 270. - WDO(J)*RADE , 360. ) + UDIRCA = WDO(J)*RADE + UDIRR = WDO(J) + UABS = MAX ( 0.001 , WAO(J) ) #ifdef W3_FLX5 - TAUA = MAX ( 0.001 , TAUAO(J)) - TAUADIR = MOD ( 270. - TAUDO(J)*RADE , 360. ) - RHOAIR = MAX ( 0. , DAIRO(J)) + TAUA = MAX ( 0.001 , TAUAO(J)) + TAUADIR = MOD ( 270. - TAUDO(J)*RADE , 360. ) + RHOAIR = MAX ( 0. , DAIRO(J)) #endif - CDIR = MOD ( 270. - CDO(J)*RADE , 360. ) + CDIR = MOD ( 270. - CDO(J)*RADE , 360. ) #ifdef W3_IS2 - ICEDMAX = MAX ( 0., ICEFO(J)) - ICEF = ICEDMAX - ICETHICK = MAX (0., ICEHO(J)) - ICECON = MAX (0., ICEO(J)) + ICEDMAX = MAX ( 0., ICEFO(J)) + ICEF = ICEDMAX + ICETHICK = MAX (0., ICEHO(J)) + ICECON = MAX (0., ICEO(J)) #endif -! + ! #ifdef W3_STAB2 - STAB0 = ZWIND * GRAV / 273. - STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 - STAB = MAX ( -1. , MIN ( 1. , STAB ) ) - THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) - THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) - COR1 = CCNG * TANH(THARG1) - COR2 = CCPS * TANH(THARG2) - ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) -#endif -! + STAB0 = ZWIND * GRAV / 273. + STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 + STAB = MAX ( -1. , MIN ( 1. , STAB ) ) + THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) + THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) + COR1 = CCNG * TANH(THARG1) + COR2 = CCPS * TANH(THARG2) + ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) +#endif + ! #ifdef W3_T - WRITE (NDST,9010) DEPTH -#endif - DO IK=1, NK - SIX = SIG(IK) * SQRTH - I1 = INT(SIX/DSIE) - IF (I1.LE.N1MAX) THEN - I2 = I1 + 1 - R1 = SIX/DSIE - REAL(I1) - R2 = 1. - R1 - WN(IK) = ( R2*EWN1(I1) + R1*EWN1(I2) ) / DEPTH - CG(IK) = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH - ELSE - WN(IK) = SIG(IK)*SIG(IK)/GRAV - CG(IK) = 0.5 * GRAV / SIG(IK) - END IF + WRITE (NDST,9010) DEPTH +#endif + DO IK=1, NK + SIX = SIG(IK) * SQRTH + I1 = INT(SIX/DSIE) + IF (I1.LE.N1MAX) THEN + I2 = I1 + 1 + R1 = SIX/DSIE - REAL(I1) + R2 = 1. - R1 + WN(IK) = ( R2*EWN1(I1) + R1*EWN1(I2) ) / DEPTH + CG(IK) = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH + ELSE + WN(IK) = SIG(IK)*SIG(IK)/GRAV + CG(IK) = 0.5 * GRAV / SIG(IK) + END IF #ifdef W3_T - WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) + WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) #endif -! - END DO + ! + END DO -! -! Computes 2nd order spectrum -! + ! + ! Computes 2nd order spectrum + ! #ifdef W3_IG1 - IF (IGPARS(2).EQ.1) THEN - IF(IGPARS(1).EQ.1) THEN - CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) - ELSE - CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) + IF (IGPARS(2).EQ.1) THEN + IF(IGPARS(1).EQ.1) THEN + CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) + ELSE + CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) END IF END IF #endif -! -! 3. Prepare spectra etc. -! 3.a Mean wave parameters. -! - ET = 0. - EWN = 0. - ETR = 0. - ETX = 0. - ETY = 0. - DO IK=1, NK - EBND = 0. - EBX = 0. - EBY = 0. - DO ITH=1, NTH - ISP = ITH + (IK-1)*NTH - E(IK,ITH) = SPCO(ISP,J) - EBND = EBND + SPCO(ISP,J) - EBX = EBX + SPCO(ISP,J)*ECOS(ITH) - EBY = EBY + SPCO(ISP,J)*ESIN(ITH) - END DO - E1(IK) = EBND * DTH - APM(IK)= E1(IK) / ( TPI * GRAV**2 / SIG(IK)**5 ) - IF ( E1(IK) .GT. 1.E-5) THEN - THBND(IK) = MOD(630.- RADE*ATAN2(EBY,EBX),360.) - SPBND(IK) = RADE * SQRT ( MAX ( 0. , 2.*( 1. - & - SQRT( MAX(0.,(EBX**2+EBY**2)/EBND**2) ) ) ) ) - ELSE - THBND(IK) = -999.9 - SPBND(IK) = -999.9 - END IF - EBND = E1(IK) * DSII(IK) * TPIINV - ET = ET + EBND - EWN = EWN + EBND / WN(IK) - ETR = ETR + EBND / SIG(IK) - ETX = ETX + EBX * DSII(IK) - ETY = ETY + EBY * DSII(IK) - END DO -! -! tail factors for radian action etc ...! -! - EBND = E1(NK) * TPIINV / ( SIG(NK) * DTH ) - ET = ET + FTE *EBND - EWN = EWN + FTWL*EBND - ETR = ETR + FTTR*EBND - ETX = DTH*ETX*TPIINV + FTE*EBX*TPIINV/SIG(NK) - ETY = DTH*ETY*TPIINV + FTE*EBY*TPIINV/SIG(NK) -! - HSIG = 4. * SQRT ( MAX(0.,ET) ) - IF ( HSIG .GT. HSMIN ) THEN - WLEN = EWN / ET * TPI - TMEAN = ETR / ET * TPI - THMEAN = MOD ( 630. - RADE*ATAN2(ETY,ETX) , 360. ) - THSPRD = RADE * SQRT ( MAX ( 0. , 2.*( 1. - SQRT( & - MAX(0.,(ETX**2+ETY**2)/ET**2) ) ) ) ) - IF ( THSPRD .LT. 0.01*RADE*DTH ) THSPRD = 0. - ELSE - WLEN = 0. - TMEAN = 0. - THMEAN = 0. - THSPRD = 0. - DO IK=1, NK - E1(IK) = 0. - DO ITH=1, NTH - E(IK,ITH) = 0. - END DO - END DO - END IF -! -! peak frequency -! - EMAX = E1(NK) - IKM = NK -! - DO IK=NK-1, 1, -1 - IF ( E1(IK) .GT. EMAX ) THEN - EMAX = E1(IK) - IKM = IK - END IF - END DO + ! + ! 3. Prepare spectra etc. + ! 3.a Mean wave parameters. + ! + ET = 0. + EWN = 0. + ETR = 0. + ETX = 0. + ETY = 0. + DO IK=1, NK + EBND = 0. + EBX = 0. + EBY = 0. + DO ITH=1, NTH + ISP = ITH + (IK-1)*NTH + E(IK,ITH) = SPCO(ISP,J) + EBND = EBND + SPCO(ISP,J) + EBX = EBX + SPCO(ISP,J)*ECOS(ITH) + EBY = EBY + SPCO(ISP,J)*ESIN(ITH) + END DO + E1(IK) = EBND * DTH + APM(IK)= E1(IK) / ( TPI * GRAV**2 / SIG(IK)**5 ) + IF ( E1(IK) .GT. 1.E-5) THEN + THBND(IK) = MOD(630.- RADE*ATAN2(EBY,EBX),360.) + SPBND(IK) = RADE * SQRT ( MAX ( 0. , 2.*( 1. - & + SQRT( MAX(0.,(EBX**2+EBY**2)/EBND**2) ) ) ) ) + ELSE + THBND(IK) = -999.9 + SPBND(IK) = -999.9 + END IF + EBND = E1(IK) * DSII(IK) * TPIINV + ET = ET + EBND + EWN = EWN + EBND / WN(IK) + ETR = ETR + EBND / SIG(IK) + ETX = ETX + EBX * DSII(IK) + ETY = ETY + EBY * DSII(IK) + END DO + ! + ! tail factors for radian action etc ...! + ! + EBND = E1(NK) * TPIINV / ( SIG(NK) * DTH ) + ET = ET + FTE *EBND + EWN = EWN + FTWL*EBND + ETR = ETR + FTTR*EBND + ETX = DTH*ETX*TPIINV + FTE*EBX*TPIINV/SIG(NK) + ETY = DTH*ETY*TPIINV + FTE*EBY*TPIINV/SIG(NK) + ! + HSIG = 4. * SQRT ( MAX(0.,ET) ) + IF ( HSIG .GT. HSMIN ) THEN + WLEN = EWN / ET * TPI + TMEAN = ETR / ET * TPI + THMEAN = MOD ( 630. - RADE*ATAN2(ETY,ETX) , 360. ) + THSPRD = RADE * SQRT ( MAX ( 0. , 2.*( 1. - SQRT( & + MAX(0.,(ETX**2+ETY**2)/ET**2) ) ) ) ) + IF ( THSPRD .LT. 0.01*RADE*DTH ) THSPRD = 0. + ELSE + WLEN = 0. + TMEAN = 0. + THMEAN = 0. + THSPRD = 0. + DO IK=1, NK + E1(IK) = 0. + DO ITH=1, NTH + E(IK,ITH) = 0. + END DO + END DO + END IF + ! + ! peak frequency + ! + EMAX = E1(NK) + IKM = NK + ! + DO IK=NK-1, 1, -1 + IF ( E1(IK) .GT. EMAX ) THEN + EMAX = E1(IK) + IKM = IK + END IF + END DO - IF ( HSIG .GE. HSMIN .AND. IKM .NE. NK ) THEN - IF ( IKM .EQ. 1 ) THEN - EL = - E1(IKM) - ELSE - EL = E1(IKM-1) - E1(IKM) - END IF + IF ( HSIG .GE. HSMIN .AND. IKM .NE. NK ) THEN + IF ( IKM .EQ. 1 ) THEN + EL = - E1(IKM) + ELSE + EL = E1(IKM-1) - E1(IKM) + END IF - EH = E1(IKM+1) - E1(IKM) + EH = E1(IKM+1) - E1(IKM) - DENOM = XL*EH - XH*EL -! - FP = SIG(IKM) * ( 1. + 0.5 * ( XL2*EH - XH2*EL ) & - / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) - THP = THBND(IKM) - SPP = SPBND(IKM) - IF ( SPP .LT. 0.01*RADE*DTH ) SPP = 0. - ELSE - FP = 0. - THP = 0. - SPP = 0. - END IF -! -! spectral partitioning -! - IF ( ITYPE.EQ.4 ) CALL W3PART & - ( E, UABS, UDIRCA, DEPTH, WN, NPART, XPART, DIMXP ) -! -! nondimensional parameters -! - IF ( ( ITYPE.EQ.2 .AND. (OTYPE.EQ.3.OR.OTYPE.EQ.4) ) .OR. & - ( ITYPE.EQ.1 .AND. (OTYPE.EQ.2) ) ) THEN -! - DO IK=1, NK - FACTOR = TPIINV * CG(IK) / SIG(IK) - DO ITH=1, NTH - ISP = ITH + (IK-1)*NTH - A(ITH,IK) = FACTOR * SPCO(ISP,J) - WN2(ITH,IK) = WN(IK) - END DO - END DO -! + DENOM = XL*EH - XH*EL + ! + FP = SIG(IKM) * ( 1. + 0.5 * ( XL2*EH - XH2*EL ) & + / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) + THP = THBND(IKM) + SPP = SPBND(IKM) + IF ( SPP .LT. 0.01*RADE*DTH ) SPP = 0. + ELSE + FP = 0. + THP = 0. + SPP = 0. + END IF + ! + ! spectral partitioning + ! + IF ( ITYPE.EQ.4 ) CALL W3PART & + ( E, UABS, UDIRCA, DEPTH, WN, NPART, XPART, DIMXP ) + ! + ! nondimensional parameters + ! + IF ( ( ITYPE.EQ.2 .AND. (OTYPE.EQ.3.OR.OTYPE.EQ.4) ) .OR. & + ( ITYPE.EQ.1 .AND. (OTYPE.EQ.2) ) ) THEN + ! + DO IK=1, NK + FACTOR = TPIINV * CG(IK) / SIG(IK) + DO ITH=1, NTH + ISP = ITH + (IK-1)*NTH + A(ITH,IK) = FACTOR * SPCO(ISP,J) + WN2(ITH,IK) = WN(IK) + END DO + END DO + ! #ifdef W3_STAB2 - UABS = UABS / ASFAC + UABS = UABS / ASFAC #endif -! + ! #ifdef W3_ST0 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST1 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST2 - ZWND = ZWIND + ZWND = ZWIND #endif #ifdef W3_ST3 - ZWND = ZZWND - TAUWX = 0. - TAUWY = 0. - LLWS(:) = .TRUE. + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. + LLWS(:) = .TRUE. #endif #ifdef W3_ST4 - LLWS(:) = .TRUE. - ZWND = ZZWND - TAUWX = 0. - TAUWY = 0. + LLWS(:) = .TRUE. + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. #endif #ifdef W3_ST6 - ZWND = 10. + ZWND = 10. #endif - USTAR = 1. -! + USTAR = 1. + ! #ifdef W3_ST1 - CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) - FP = 0.85 * FMEAN + CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN #endif #ifdef W3_ST2 - CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) #endif #ifdef W3_ST4 - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) #endif #ifdef W3_ST6 - CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) + CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) #endif -! + ! #ifdef W3_FLX1 - CALL W3FLX1 ( ZWND, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX1 ( ZWND, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX4 - CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) + CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX5 - CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & - RHOAIR, USTAR, USTD, Z0, CD, CHARN ) + CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & + RHOAIR, USTAR, USTD, Z0, CD, CHARN ) #endif -! - DO ITT=1, 3 + ! + DO ITT=1, 3 #ifdef W3_ST2 - CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & - FPI, XIN, DIA ) - CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XIN, DIA ) + CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - IX=1 - IY=1 - CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& - ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& - TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) - CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) + IX=1 + IY=1 + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& + TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) #endif #ifdef W3_ST4 - IX=1 - IY=1 - CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& - ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& - TAUWNX, TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + IX=1 + IY=1 + CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& + TAUWNX, TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) -#endif - END DO -! -! Add alternative flux calculations here as part of !/ST2 option .... -! Also add before actual source term calculation !!! -! + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif + END DO + ! + ! Add alternative flux calculations here as part of !/ST2 option .... + ! Also add before actual source term calculation !!! + ! #ifdef W3_STAB2 - UABS = UABS * ASFAC + UABS = UABS * ASFAC #endif -! - IF ( WAO(J) .LT. 0.01 ) THEN - UNORM = 0. - ESTAR = 0. - FPSTAR = 0. - ELSE - IF ( OTYPE.EQ.3 ) THEN - UNORM = USTAR - ELSE - UNORM = WAO(J) - END IF - ESTAR = ET * GRAV**2 / UNORM**4 - FPSTAR = FP * TPIINV * UNORM / GRAV - XSTAR = PTLOC(1,J) * GRAV / UNORM**2 - YSTAR = PTLOC(2,J) * GRAV / UNORM**2 - IF ( FLAGLL ) THEN - XSTAR = XSTAR * DERA * RADIUS & - * COS(PTLOC(2,J)*DERA) - YSTAR = YSTAR * DERA * RADIUS - END IF - END IF -! - END IF -! -! 3.4 source terms -! - IF ( ITYPE.EQ.3 ) THEN -! - DO IK=1, NK - FACTOR = TPIINV * CG(IK) / SIG(IK) - DO ITH=1, NTH - A(ITH,IK) = FACTOR * SPCO(ITH+(IK-1)*NTH,J) - WN2(ITH,IK) = WN(IK) - END DO - END DO -! + ! + IF ( WAO(J) .LT. 0.01 ) THEN + UNORM = 0. + ESTAR = 0. + FPSTAR = 0. + ELSE + IF ( OTYPE.EQ.3 ) THEN + UNORM = USTAR + ELSE + UNORM = WAO(J) + END IF + ESTAR = ET * GRAV**2 / UNORM**4 + FPSTAR = FP * TPIINV * UNORM / GRAV + XSTAR = PTLOC(1,J) * GRAV / UNORM**2 + YSTAR = PTLOC(2,J) * GRAV / UNORM**2 + IF ( FLAGLL ) THEN + XSTAR = XSTAR * DERA * RADIUS & + * COS(PTLOC(2,J)*DERA) + YSTAR = YSTAR * DERA * RADIUS + END IF + END IF + ! + END IF + ! + ! 3.4 source terms + ! + IF ( ITYPE.EQ.3 ) THEN + ! + DO IK=1, NK + FACTOR = TPIINV * CG(IK) / SIG(IK) + DO ITH=1, NTH + A(ITH,IK) = FACTOR * SPCO(ITH+(IK-1)*NTH,J) + WN2(ITH,IK) = WN(IK) + END DO + END DO + ! #ifdef W3_STAB2 - UABS = UABS / ASFAC + UABS = UABS / ASFAC #endif -! + ! #ifdef W3_ST0 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST1 - ZWND = 10. + ZWND = 10. #endif #ifdef W3_ST2 - ZWND = ZWIND + ZWND = ZWIND #endif #ifdef W3_ST3 - ZWND = ZZWND + ZWND = ZZWND #endif #ifdef W3_ST0 - USTAR = 1. + USTAR = 1. #endif #ifdef W3_ST1 - USTAR = 1. + USTAR = 1. #endif #ifdef W3_ST2 - USTAR = 1. + USTAR = 1. #endif #ifdef W3_ST3 - USTAR = 0. - USTD = 0. - TAUWX = 0. - TAUWY = 0. + USTAR = 0. + USTD = 0. + TAUWX = 0. + TAUWY = 0. #endif #ifdef W3_ST4 - ZWND = ZZWND - USTAR = 0. - USTD = 0. - TAUWX = 0. - TAUWY = 0. + ZWND = ZZWND + USTAR = 0. + USTD = 0. + TAUWX = 0. + TAUWY = 0. #endif #ifdef W3_ST6 - ZWND = 10. + ZWND = 10. #endif -! + ! #ifdef W3_ST0 - FHIGH = SIG(NK) + FHIGH = SIG(NK) #endif #ifdef W3_ST1 - CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) - FP = 0.85 * FMEAN - FH1 = FXFM * FMEAN - FH2 = FXPM / USTAR - FHIGH = MAX ( FH1 , FH2 ) + CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN + FH1 = FXFM * FMEAN + FH2 = FXPM / USTAR + FHIGH = MAX ( FH1 , FH2 ) #endif #ifdef W3_ST2 - CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) #endif #ifdef W3_ST4 - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) #endif #ifdef W3_ST6 - CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) - FHIGH = SIG(NK) + CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) + FHIGH = SIG(NK) #endif -! + ! #ifdef W3_FLX1 - CALL W3FLX1 ( ZWND, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX1 ( ZWND, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX4 - CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) + CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX5 - CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & - RHOAIR, USTAR, USTD, Z0, CD, CHARN ) + CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & + RHOAIR, USTAR, USTD, Z0, CD, CHARN ) #endif -! - DO ITT=1, 3 + ! + DO ITT=1, 3 #ifdef W3_ST2 - CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & - FPI, XIN, DIA ) - CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & - EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XIN, DIA ) + CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) #endif #ifdef W3_ST3 - CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & - WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& - TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) - CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& - ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & - TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & + TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) #endif #ifdef W3_ST4 - CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & - WNMEAN, AMAX, UABS, UDIRR, & + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & #ifdef W3_FLX5 - TAUA, TAUADIR, RHOAIR, & + TAUA, TAUADIR, RHOAIR, & #endif - USTAR, USTD, TAUWX, TAUWY, CD, Z0, & - CHARN, LLWS, FMEANWS, DLWMEAN ) - CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& - ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & - TAUWNX, TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) + CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & + TAUWNX, TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) #endif #ifdef W3_FLX2 - CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif #ifdef W3_FLX3 - CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & - USTAR, USTD, Z0, CD ) + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) #endif - END DO -! + END DO + ! #ifdef W3_ST2 - FHIGH = XFC * FPI + FHIGH = XFC * FPI #endif -! - IF ( FLSRCE(2) ) THEN + ! + IF ( FLSRCE(2) ) THEN #ifdef W3_LN1 - CALL W3SLN1 (WN, FHIGH, USTAR, UDIRR, XLN ) + CALL W3SLN1 (WN, FHIGH, USTAR, UDIRR, XLN ) #endif -! + ! #ifdef W3_ST1 - CALL W3SIN1 (A, WN2, USTAR, UDIRR, XIN, DIA ) + CALL W3SIN1 (A, WN2, USTAR, UDIRR, XIN, DIA ) #endif #ifdef W3_ST2 - CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0,& - FPI, XIN, DIA ) + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0,& + FPI, XIN, DIA ) #endif #ifdef W3_ST3 - CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, & - DAIR/DWAT, ASO(J), UDIRR, & - Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & - ICE, XIN, DIA, LLWS, IX, IY ) + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, & + DAIR/DWAT, ASO(J), UDIRR, & + Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & + ICE, XIN, DIA, LLWS, IX, IY ) #endif #ifdef W3_ST4 - CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, & - DAIR/DWAT, ASO(J), UDIRR, & - Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & - XIN, DIA, LLWS, IX, IY, LAMBDA ) + CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, & + DAIR/DWAT, ASO(J), UDIRR, & + Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & + XIN, DIA, LLWS, IX, IY, LAMBDA ) #endif #ifdef W3_ST6 - CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, DAIR, & - TAUWX, TAUWY, TAUWNX, TAUWNY, XIN, DIA ) + CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, DAIR, & + TAUWX, TAUWY, TAUWNX, TAUWNY, XIN, DIA ) #endif - END IF - IF ( FLSRCE(3) ) THEN + END IF + IF ( FLSRCE(3) ) THEN #ifdef W3_NL1 - CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) + CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) #endif #ifdef W3_NL2 - CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) + CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) #endif #ifdef W3_NL3 - CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) + CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) #endif #ifdef W3_NL4 - CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) + CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) #endif - END IF - IF ( FLSRCE(4) ) THEN + END IF + IF ( FLSRCE(4) ) THEN #ifdef W3_ST1 - CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, & - XDS, DIA ) + CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, & + XDS, DIA ) #endif #ifdef W3_ST2 - CALL W3SDS2 ( A, CG, WN, FPI, USTAR, & - ALPHA, XDS, DIA ) + CALL W3SDS2 ( A, CG, WN, FPI, USTAR, & + ALPHA, XDS, DIA ) #endif #ifdef W3_ST3 - CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & - USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) + CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & + USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) #endif #ifdef W3_ST4 - CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & - DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) + CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & + DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) #endif #ifdef W3_ST6 - CALL W3SDS6 ( A, CG, WN, XDS, DIA ) - IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) + CALL W3SDS6 ( A, CG, WN, XDS, DIA ) + IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) #endif -! + ! #ifdef W3_DB1 - CALL W3SDB1 ( I, A, DEPTH, EMEAN, FMEAN, & - WNMEAN, CG, LBREAK, XDB, DIA ) + CALL W3SDB1 ( I, A, DEPTH, EMEAN, FMEAN, & + WNMEAN, CG, LBREAK, XDB, DIA ) #endif - END IF - IF ( FLSRCE(5) ) THEN + END IF + IF ( FLSRCE(5) ) THEN #ifdef W3_BT1 - CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) + CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) #endif #ifdef W3_BT4 - IX=1 ! to be fixed later - IY=1 ! to be fixed later - ISEA=1 ! to be fixed later - D50 = SED_D50(ISEA) - PSIC= SED_PSIC(ISEA) + IX=1 ! to be fixed later + IY=1 ! to be fixed later + ISEA=1 ! to be fixed later + D50 = SED_D50(ISEA) + PSIC= SED_PSIC(ISEA) #endif #ifdef W3_BT4 - CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & - BEDFORM, XBT, DIA, IX, IY ) + CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & + BEDFORM, XBT, DIA, IX, IY ) #endif - BT8MSG='ww3_outp: ITYPE=3 with BT8 or BT9: Sbot out'//& - 'put is not yet supported. Use "F" for the 5'//& - 'th T/F flag.' + BT8MSG='ww3_outp: ITYPE=3 with BT8 or BT9: Sbot out'//& + 'put is not yet supported. Use "F" for the 5'//& + 'th T/F flag.' #ifdef W3_BT8 - CALL EXTCDE( 516,MSG=BT8MSG) + CALL EXTCDE( 516,MSG=BT8MSG) #endif #ifdef W3_BT9 - CALL EXTCDE( 516,MSG=BT8MSG) + CALL EXTCDE( 516,MSG=BT8MSG) #endif -! For info on this issue, see : "BT8&9 issues" in "Remarks" section above. + ! For info on this issue, see : "BT8&9 issues" in "Remarks" section above. -!...broken....!/BT8 CALL W3SBT8 ( A, DEPTH, XBT, DIA, IX, IY ) -!...broken....!/BT9 CALL W3SBT9 ( A, DEPTH, XBT, DIA, IX, IY ) + !...broken....!/BT8 CALL W3SBT8 ( A, DEPTH, XBT, DIA, IX, IY ) + !...broken....!/BT9 CALL W3SBT9 ( A, DEPTH, XBT, DIA, IX, IY ) -! + ! #ifdef W3_BS1 - CALL W3SBS1 ( A, CG, WN, DEPTH, & - CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & - TAUSCX, TAUSCY, XBS, DIA ) + CALL W3SBS1 ( A, CG, WN, DEPTH, & + CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & + TAUSCX, TAUSCY, XBS, DIA ) #endif - END IF -! - IF ( FLSRCE(6) ) THEN + END IF + ! + IF ( FLSRCE(6) ) THEN #ifdef W3_IS2 - IF (IICEDISP) THEN - CALL LIU_FORWARD_DISPERSION (ICETHICK,0.,DEPTH, & - SIG,WN_R,CG_ICE,ALPHA_LIU) - ELSE - WN_R=WN - CG_ICE=CG - END IF -#endif -! + IF (IICEDISP) THEN + CALL LIU_FORWARD_DISPERSION (ICETHICK,0.,DEPTH, & + SIG,WN_R,CG_ICE,ALPHA_LIU) + ELSE + WN_R=WN + CG_ICE=CG + END IF +#endif + ! #ifdef W3_IS2 - CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, & - IX, IY, XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) + CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, & + IX, IY, XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) #endif - END IF -! + END IF + ! #ifdef W3_STAB2 - UABS = UABS * ASFAC -#endif -! - IF ( ISCALE.EQ.0 .OR. ISCALE.EQ.3 ) THEN - FACF = TPIINV - FACE = 1. - FACS = 1. - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.4 ) THEN - FACF = TPIINV * UABS / GRAV - FACE = GRAV**3 / UABS**5 - FACS = GRAV**2 / UABS**4 - ELSE IF ( ISCALE.EQ.2 .OR. ISCALE.EQ.5 ) THEN - FACF = TPIINV * USTAR / GRAV - FACE = GRAV**3 / USTAR**5 - FACS = GRAV**2 / USTAR**4 - END IF -! - DO IK=1, NK - FACTOR = TPI / CG(IK) * SIG(IK) - E1 (IK) = 0. - SIN1(IK) = 0. - SNL1(IK) = 0. - SDS1(IK) = 0. - SBT1(IK) = 0. - STT1(IK) = 0. - SIS1(IK) = 0. - DO ITH=1, NTH - ISP = ITH + (IK-1)*NTH - E (IK,ITH) = SPCO(ISP,J) - SWN(IK,ITH) = ( XLN(ITH,IK) + XIN(ITH,IK) ) * FACTOR - SNL(IK,ITH) = ( XNL(ITH,IK) + XTR(ITH,IK) ) * FACTOR - SDS(IK,ITH) = ( XDS(ITH,IK) + XDB(ITH,IK) ) * FACTOR + UABS = UABS * ASFAC +#endif + ! + IF ( ISCALE.EQ.0 .OR. ISCALE.EQ.3 ) THEN + FACF = TPIINV + FACE = 1. + FACS = 1. + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.4 ) THEN + FACF = TPIINV * UABS / GRAV + FACE = GRAV**3 / UABS**5 + FACS = GRAV**2 / UABS**4 + ELSE IF ( ISCALE.EQ.2 .OR. ISCALE.EQ.5 ) THEN + FACF = TPIINV * USTAR / GRAV + FACE = GRAV**3 / USTAR**5 + FACS = GRAV**2 / USTAR**4 + END IF + ! + DO IK=1, NK + FACTOR = TPI / CG(IK) * SIG(IK) + E1 (IK) = 0. + SIN1(IK) = 0. + SNL1(IK) = 0. + SDS1(IK) = 0. + SBT1(IK) = 0. + STT1(IK) = 0. + SIS1(IK) = 0. + DO ITH=1, NTH + ISP = ITH + (IK-1)*NTH + E (IK,ITH) = SPCO(ISP,J) + SWN(IK,ITH) = ( XLN(ITH,IK) + XIN(ITH,IK) ) * FACTOR + SNL(IK,ITH) = ( XNL(ITH,IK) + XTR(ITH,IK) ) * FACTOR + SDS(IK,ITH) = ( XDS(ITH,IK) + XDB(ITH,IK) ) * FACTOR #ifdef W3_ST6 - SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) -#endif - SBT(IK,ITH) = ( XBT(ITH,IK) * XBS(ITH,IK) ) * FACTOR - SIS(IK,ITH) = XIS(ITH,IK) * FACTOR - STT(IK,ITH) = SWN(IK,ITH) + SNL(IK,ITH)+SDS(IK,ITH)& - + SBT(IK,ITH) + SIS(IK,ITH) & - + XXX(ITH,IK) * FACTOR - E1 (IK) = E1 (IK) + E(IK,ITH) - SIN1(IK) = SIN1(IK) + SWN(IK,ITH) - SNL1(IK) = SNL1(IK) + SNL(IK,ITH) - SDS1(IK) = SDS1(IK) + SDS(IK,ITH) - SBT1(IK) = SBT1(IK) + SBT(IK,ITH) - SIS1(IK) = SIS1(IK) + SIS(IK,ITH) - END DO - E1 (IK) = E1(IK) * DTH * FACE - SIN1(IK) = SIN1(IK) * DTH * FACS - SNL1(IK) = SNL1(IK) * DTH * FACS - SDS1(IK) = SDS1(IK) * DTH * FACS - SBT1(IK) = SBT1(IK) * DTH * FACS - SIS1(IK) = SIS1(IK) * DTH * FACS - END DO -! - STT1 = SIN1 + SNL1 + SDS1 + SBT1 + SIS1 - E1ALL(:,1) = SIN1 - E1ALL(:,2) = SNL1 - E1ALL(:,3) = SDS1 - E1ALL(:,4) = SBT1 - E1ALL(:,5) = SIS1 - E1ALL(:,6) = STT1 -! + SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) +#endif + SBT(IK,ITH) = ( XBT(ITH,IK) * XBS(ITH,IK) ) * FACTOR + SIS(IK,ITH) = XIS(ITH,IK) * FACTOR + STT(IK,ITH) = SWN(IK,ITH) + SNL(IK,ITH)+SDS(IK,ITH)& + + SBT(IK,ITH) + SIS(IK,ITH) & + + XXX(ITH,IK) * FACTOR + E1 (IK) = E1 (IK) + E(IK,ITH) + SIN1(IK) = SIN1(IK) + SWN(IK,ITH) + SNL1(IK) = SNL1(IK) + SNL(IK,ITH) + SDS1(IK) = SDS1(IK) + SDS(IK,ITH) + SBT1(IK) = SBT1(IK) + SBT(IK,ITH) + SIS1(IK) = SIS1(IK) + SIS(IK,ITH) + END DO + E1 (IK) = E1(IK) * DTH * FACE + SIN1(IK) = SIN1(IK) * DTH * FACS + SNL1(IK) = SNL1(IK) * DTH * FACS + SDS1(IK) = SDS1(IK) * DTH * FACS + SBT1(IK) = SBT1(IK) * DTH * FACS + SIS1(IK) = SIS1(IK) * DTH * FACS + END DO + ! + STT1 = SIN1 + SNL1 + SDS1 + SBT1 + SIS1 + E1ALL(:,1) = SIN1 + E1ALL(:,2) = SNL1 + E1ALL(:,3) = SDS1 + E1ALL(:,4) = SBT1 + E1ALL(:,5) = SIS1 + E1ALL(:,6) = STT1 + ! + END IF + ! + ! 4.a Perform output type 1 ( print plots / tables / file ) + ! + IF ( ITYPE .EQ. 1 ) THEN + ! + IF ( OTYPE .EQ. 1 ) THEN + ! + IF ( SCALE1 .GE. 0. ) & + CALL PRT1DS (NDSO, NK, E1, SIG(1:NK), 'RAD/S',& + 17, SCALE1, 'E(f)', 'm^2s', PTNME(J) ) + IF ( SCALE2 .GE. 0. ) & + CALL PRT2DS (NDSO, NK, NK, NTH, E, SIG(1:NK), & + 'RAD/S', 1., SCALE2, 0.0001, 'E(f,th)', & + 'm^2s', PTNME(J) ) + WRITE (NDSO,910) DPO(J), UABS + IF ( WAO(J) .GT. 0. ) WRITE (NDSO,911) UDIR + WRITE (NDSO,912) ASO(J), CAO(J) + IF ( CAO(J) .GT. 0. ) WRITE (NDSO,913) CDIR + WRITE (NDSO,914) HSIG, WLEN, TMEAN, THMEAN, THSPRD + ! + ELSE IF ( OTYPE .EQ. 2 ) THEN + ! + CALL STME21 ( TIME , DTME21 ) + IF ( FLAGLL ) THEN + WRITE (NDSTAB,920) DTME21, PTNME(J), & + M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & + DPO(J), USTAR, WAO(J), UDIR + ELSE + WRITE (NDSTAB,720) DTME21, PTNME(J), & + M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & + DPO(J), USTAR, WAO(J), UDIR + END IF + IF ( FP .EQ. 0. ) FP = SIG(NK) + DO IK=1, NK + WRITE (NDSTAB,921) TPIINV*SIG(IK), SIG(IK)/FP, & + E1(IK), THBND(IK), SPBND(IK), APM(IK) + END DO + IF ( FP .EQ. SIG(NK) ) FP = 0. + WRITE (NDSTAB,922) + ! + ELSE IF ( OTYPE .EQ. 3 ) THEN + ! + IF ( FLFORM ) THEN + WRITE (NDSTAB) PTNME(J), PTLOC(2,J), & + PTLOC(1,J), DPO(J), WAO(J), & + UDIR, CAO(J), CDIR + WRITE (NDSTAB) ((E(IK,ITH),IK=1,NK),ITH=1,NTH) + ELSE + WRITE (NDSTAB,901) PTNME(J), M2KM*PTLOC(2,J), & + M2KM*PTLOC(1,J), DPO(J), & + WAO(J), UDIR, CAO(J), CDIR + WRITE (NDSTAB,902) & + ((E(IK,ITH),IK=1,NK),ITH=1,NTH) + END IF + ! + END IF + ! + ! 4.b Perform output type 2 ( tables ) + ! + ELSE IF ( ITYPE .EQ. 2 ) THEN + ! + IF ( NREQ .EQ. 1 ) THEN + ! + IYR = TIME(1) / 10000 + IMTH = MOD ( TIME(1) , 10000 ) / 100 + IDY = MOD ( TIME(1) , 100 ) + IH = TIME(2) / 10000 + IM = MOD ( TIME(2) , 10000 ) / 100 + IS = MOD ( TIME(2) , 100 ) + IF ( OTYPE .EQ. 1 ) THEN + WRITE (NDSTAB,1921) TIME(1), IH, IM, IS, & + DPO(J), CAO(J), CDIR, WAO(J), UDIR + ELSE IF ( OTYPE .EQ. 2 ) THEN + WRITE (NDSTAB,1922) TIME(1), IH, IM, IS, & + HSIG, WLEN, TMEAN, THMEAN, THSPRD, & + FP*TPIINV, THP, SPP + ELSE IF ( OTYPE.EQ.3 ) THEN + WRITE (NDSTAB,1923) TIME(1), IH, IM, IS, & + UNORM, ESTAR, FPSTAR, CD*1000., APM(NK)*100. + ELSE IF ( OTYPE.EQ.4 ) THEN + WRITE (NDSTAB,1924) TIME(1), IH, IM, IS, & + UNORM, ESTAR, FPSTAR, CD*1000., APM(NK)*100. + ELSE IF ( OTYPE.EQ.5 ) THEN + HMAT = MIN ( 100. , 3.33*GRAV*HSIG/UABS**2 ) + IF ( HSIG .GE. HSMIN ) THEN + CALL WAVNU1 ( FP, DPO(J), WNA, XYZ ) + AGE1 = MIN ( 100. , FP / WNA / UABS ) + AFR = TPI / TMEAN + CALL WAVNU1 ( AFR, DPO(J), WNA, XYZ ) + AGE2 = MIN ( 100. , AFR / WNA / UABS ) + ELSE + AGE1 = -9.99 + AGE2 = -9.99 + END IF + WRITE (NDSTAB,1925) TIME(1), IH, IM, IS, & + WAO(J), UDIR, HSIG, HMAT, AGE1, AGE2, & + ASO(J) + ELSE IF ( OTYPE.EQ.6 ) THEN + IF ( HSIG .GE. HSMIN ) THEN + WRITE (NDSTAB,1926) IYR, IMTH, IDY, IH, & + WAO(J), NINT(UDIR), HSIG, TPI / FP + ELSE + WRITE (NDSTAB,1926) IYR, IMTH, IDY, IH, & + WAO(J), NINT(UDIR), HSIG, 0.0 END IF -! -! 4.a Perform output type 1 ( print plots / tables / file ) -! - IF ( ITYPE .EQ. 1 ) THEN -! - IF ( OTYPE .EQ. 1 ) THEN -! - IF ( SCALE1 .GE. 0. ) & - CALL PRT1DS (NDSO, NK, E1, SIG(1:NK), 'RAD/S',& - 17, SCALE1, 'E(f)', 'm^2s', PTNME(J) ) - IF ( SCALE2 .GE. 0. ) & - CALL PRT2DS (NDSO, NK, NK, NTH, E, SIG(1:NK), & - 'RAD/S', 1., SCALE2, 0.0001, 'E(f,th)', & - 'm^2s', PTNME(J) ) - WRITE (NDSO,910) DPO(J), UABS - IF ( WAO(J) .GT. 0. ) WRITE (NDSO,911) UDIR - WRITE (NDSO,912) ASO(J), CAO(J) - IF ( CAO(J) .GT. 0. ) WRITE (NDSO,913) CDIR - WRITE (NDSO,914) HSIG, WLEN, TMEAN, THMEAN, THSPRD -! - ELSE IF ( OTYPE .EQ. 2 ) THEN -! - CALL STME21 ( TIME , DTME21 ) - IF ( FLAGLL ) THEN - WRITE (NDSTAB,920) DTME21, PTNME(J), & - M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & - DPO(J), USTAR, WAO(J), UDIR - ELSE - WRITE (NDSTAB,720) DTME21, PTNME(J), & - M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & - DPO(J), USTAR, WAO(J), UDIR - END IF - IF ( FP .EQ. 0. ) FP = SIG(NK) - DO IK=1, NK - WRITE (NDSTAB,921) TPIINV*SIG(IK), SIG(IK)/FP, & - E1(IK), THBND(IK), SPBND(IK), APM(IK) - END DO - IF ( FP .EQ. SIG(NK) ) FP = 0. - WRITE (NDSTAB,922) -! - ELSE IF ( OTYPE .EQ. 3 ) THEN -! - IF ( FLFORM ) THEN - WRITE (NDSTAB) PTNME(J), PTLOC(2,J), & - PTLOC(1,J), DPO(J), WAO(J), & - UDIR, CAO(J), CDIR - WRITE (NDSTAB) ((E(IK,ITH),IK=1,NK),ITH=1,NTH) - ELSE - WRITE (NDSTAB,901) PTNME(J), M2KM*PTLOC(2,J), & - M2KM*PTLOC(1,J), DPO(J), & - WAO(J), UDIR, CAO(J), CDIR - WRITE (NDSTAB,902) & - ((E(IK,ITH),IK=1,NK),ITH=1,NTH) - END IF -! - END IF -! -! 4.b Perform output type 2 ( tables ) -! - ELSE IF ( ITYPE .EQ. 2 ) THEN -! - IF ( NREQ .EQ. 1 ) THEN -! - IYR = TIME(1) / 10000 - IMTH = MOD ( TIME(1) , 10000 ) / 100 - IDY = MOD ( TIME(1) , 100 ) - IH = TIME(2) / 10000 - IM = MOD ( TIME(2) , 10000 ) / 100 - IS = MOD ( TIME(2) , 100 ) - IF ( OTYPE .EQ. 1 ) THEN - WRITE (NDSTAB,1921) TIME(1), IH, IM, IS, & - DPO(J), CAO(J), CDIR, WAO(J), UDIR - ELSE IF ( OTYPE .EQ. 2 ) THEN - WRITE (NDSTAB,1922) TIME(1), IH, IM, IS, & - HSIG, WLEN, TMEAN, THMEAN, THSPRD, & - FP*TPIINV, THP, SPP - ELSE IF ( OTYPE.EQ.3 ) THEN - WRITE (NDSTAB,1923) TIME(1), IH, IM, IS, & - UNORM, ESTAR, FPSTAR, CD*1000., APM(NK)*100. - ELSE IF ( OTYPE.EQ.4 ) THEN - WRITE (NDSTAB,1924) TIME(1), IH, IM, IS, & - UNORM, ESTAR, FPSTAR, CD*1000., APM(NK)*100. - ELSE IF ( OTYPE.EQ.5 ) THEN - HMAT = MIN ( 100. , 3.33*GRAV*HSIG/UABS**2 ) - IF ( HSIG .GE. HSMIN ) THEN - CALL WAVNU1 ( FP, DPO(J), WNA, XYZ ) - AGE1 = MIN ( 100. , FP / WNA / UABS ) - AFR = TPI / TMEAN - CALL WAVNU1 ( AFR, DPO(J), WNA, XYZ ) - AGE2 = MIN ( 100. , AFR / WNA / UABS ) - ELSE - AGE1 = -9.99 - AGE2 = -9.99 - END IF - WRITE (NDSTAB,1925) TIME(1), IH, IM, IS, & - WAO(J), UDIR, HSIG, HMAT, AGE1, AGE2, & - ASO(J) - ELSE IF ( OTYPE.EQ.6 ) THEN - IF ( HSIG .GE. HSMIN ) THEN - WRITE (NDSTAB,1926) IYR, IMTH, IDY, IH, & - WAO(J), NINT(UDIR), HSIG, TPI / FP - ELSE - WRITE (NDSTAB,1926) IYR, IMTH, IDY, IH, & - WAO(J), NINT(UDIR), HSIG, 0.0 - END IF - END IF -! - ELSE -! - IF ( OTYPE .EQ. 1 ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSTAB,1931) M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), DPO(J), CAO(J), & - CDIR, WAO(J), UDIR - ELSE - WRITE (NDSTAB,1731) M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), DPO(J), CAO(J), & - CDIR, WAO(J), UDIR - END IF - ELSE IF ( OTYPE .EQ. 2 ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSTAB,1932) M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), HSIG, WLEN, & - TMEAN, THMEAN, THSPRD, FP*TPIINV, & - THP, SPP - ELSE - WRITE (NDSTAB,1732) M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), HSIG, WLEN, & - TMEAN, THMEAN, THSPRD, FP*TPIINV, & - THP, SPP - END IF - ELSE IF ( OTYPE .EQ. 3 ) THEN - WRITE (NDSTAB,1933) 1.E-4*XSTAR, & - 1.E-4*YSTAR, UNORM, ESTAR, FPSTAR, & - CD*1000., APM(NK)*100. - ELSE IF ( OTYPE .EQ. 4 ) THEN - WRITE (NDSTAB,1934) XSTAR, YSTAR, UNORM, & - ESTAR, FPSTAR, CD*1000., APM(NK)*100. - ELSE IF ( OTYPE .EQ. 5 ) THEN - HMAT = MIN ( 100. , 3.33*GRAV*HSIG/UABS**2 ) - CALL WAVNU1 ( FP, DPO(J), WNA, XYZ ) - AGE1 = MIN ( 100. , FP / WNA / UABS ) - AFR = TPI / TMEAN - CALL WAVNU1 ( AFR, DPO(J), WNA, XYZ ) - AGE2 = MIN ( 100. , AFR / WNA / UABS ) - IF ( FLAGLL ) THEN - WRITE (NDSTAB,1935) M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), WAO(J), UDIR, & - HSIG, HMAT, AGE1, AGE2, ASO(J) - ELSE - WRITE (NDSTAB,1735) M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), WAO(J), UDIR, & - HSIG, HMAT, AGE1, AGE2, ASO(J) - END IF - ELSE IF ( OTYPE .EQ. 6 ) THEN - IF ( HSIG .GE. HSMIN ) THEN - IF ( FLAGLL ) THEN - WRITE (NDSTAB,1936) M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), WAO(J), NINT(UDIR),& - HSIG, TPI / FP - ELSE - WRITE (NDSTAB,1736) M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), WAO(J), NINT(UDIR),& - HSIG, TPI / FP - END IF - ELSE - IF ( FLAGLL ) THEN - WRITE (NDSTAB,1936) M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), WAO(J), NINT(UDIR),& - HSIG, 0.0 - ELSE - WRITE (NDSTAB,1736) M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), WAO(J), NINT(UDIR),& - HSIG, 0.0 - END IF - END IF - END IF -! - END IF -! -! 4.c Perform output type 3 ( source terms ) -! - ELSE IF ( ITYPE .EQ. 3 ) THEN -! - IF ( OTYPE .EQ. 1 ) THEN -! - IF ( SCALE1 .GE. 0. ) THEN - IF ( FLSRCE(1) ) & - CALL PRT1DS (NDSO, NK, E1, SIG(1:NK), & - 'RAD/S', 17, 0., 'E(f)', 'm^2s', & - PTNME(J) ) - IF (FLSRCE(2) .OR. FLSRCE(3) .OR. & - FLSRCE(4) .OR. FLSRCE(5) .OR. & - FLSRCE(6) .OR. FLSRCE(7) ) & - CALL PRT1DM (NDSO, NK, 6, E1ALL, SIG(1:NK),& - 'RAD/S', 17, SCALE1, VAR1, 'M2', & - PTNME(J) ) - END IF - IF ( SCALE2 .GE. 0. ) THEN - IF ( FLSRCE(1) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, E, & - SIG(1:NK), 'RAD/S', 1., 0., 0.0001, & - 'E(f,th)', 'm^2s', PTNME(J) ) - IF ( FLSRCE(2) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, SWN, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Sin(f,th)', 'm^2', PTNME(J) ) - IF ( FLSRCE(3) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, SNL, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Snl(f,th)', 'm^2', PTNME(J) ) - IF ( FLSRCE(4) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, SDS, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Sds(f,th)', 'm^2', PTNME(J) ) - IF ( FLSRCE(5) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, SBT, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Sbt(f,th)', 'm^2', PTNME(J) ) - IF ( FLSRCE(6) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, SIS, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Sice(f,th)', 'm^2', PTNME(J) ) - IF ( FLSRCE(7) ) & - CALL PRT2DS (NDSO, NK, NK, NTH, STT, & - SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& - 'Stot(f,th)', 'm^2', PTNME(J) ) - END IF -! - ELSE IF ( OTYPE .EQ. 2 ) THEN -! - CALL STME21 ( TIME , DTME21 ) - IF ( FLAGLL ) THEN - WRITE (NDSTAB,2920) DTME21, PTNME(J), & - M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & - DPO(J), USTAR, WAO(J) - ELSE - WRITE (NDSTAB,2720) DTME21, PTNME(J), & - M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & - DPO(J), USTAR, WAO(J) - END IF - IF ( ISCALE.EQ.0 ) THEN - WRITE (NDSTAB,2921) - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - WRITE (NDSTAB,2922) - ELSE IF ( ISCALE.EQ.3 ) THEN - WRITE (NDSTAB,2923) - ELSE IF ( ISCALE.EQ.4 .OR. ISCALE.EQ.5 ) THEN - WRITE (NDSTAB,2924) - END IF - IF ( ISCALE.GE.3 ) FACF = 1. / FP - DO IK=1, NK - WRITE (NDSTAB,2930) FACF*SIG(IK), E1(IK), & - SIN1(IK), SNL1(IK), SDS1(IK), SBT1(IK), & - SIS1(IK), STT1(IK) + END IF + ! + ELSE + ! + IF ( OTYPE .EQ. 1 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSTAB,1931) M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), DPO(J), CAO(J), & + CDIR, WAO(J), UDIR + ELSE + WRITE (NDSTAB,1731) M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), DPO(J), CAO(J), & + CDIR, WAO(J), UDIR + END IF + ELSE IF ( OTYPE .EQ. 2 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSTAB,1932) M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), HSIG, WLEN, & + TMEAN, THMEAN, THSPRD, FP*TPIINV, & + THP, SPP + ELSE + WRITE (NDSTAB,1732) M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), HSIG, WLEN, & + TMEAN, THMEAN, THSPRD, FP*TPIINV, & + THP, SPP + END IF + ELSE IF ( OTYPE .EQ. 3 ) THEN + WRITE (NDSTAB,1933) 1.E-4*XSTAR, & + 1.E-4*YSTAR, UNORM, ESTAR, FPSTAR, & + CD*1000., APM(NK)*100. + ELSE IF ( OTYPE .EQ. 4 ) THEN + WRITE (NDSTAB,1934) XSTAR, YSTAR, UNORM, & + ESTAR, FPSTAR, CD*1000., APM(NK)*100. + ELSE IF ( OTYPE .EQ. 5 ) THEN + HMAT = MIN ( 100. , 3.33*GRAV*HSIG/UABS**2 ) + CALL WAVNU1 ( FP, DPO(J), WNA, XYZ ) + AGE1 = MIN ( 100. , FP / WNA / UABS ) + AFR = TPI / TMEAN + CALL WAVNU1 ( AFR, DPO(J), WNA, XYZ ) + AGE2 = MIN ( 100. , AFR / WNA / UABS ) + IF ( FLAGLL ) THEN + WRITE (NDSTAB,1935) M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), WAO(J), UDIR, & + HSIG, HMAT, AGE1, AGE2, ASO(J) + ELSE + WRITE (NDSTAB,1735) M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), WAO(J), UDIR, & + HSIG, HMAT, AGE1, AGE2, ASO(J) + END IF + ELSE IF ( OTYPE .EQ. 6 ) THEN + IF ( HSIG .GE. HSMIN ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSTAB,1936) M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), WAO(J), NINT(UDIR),& + HSIG, TPI / FP + ELSE + WRITE (NDSTAB,1736) M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), WAO(J), NINT(UDIR),& + HSIG, TPI / FP + END IF + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSTAB,1936) M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), WAO(J), NINT(UDIR),& + HSIG, 0.0 + ELSE + WRITE (NDSTAB,1736) M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), WAO(J), NINT(UDIR),& + HSIG, 0.0 + END IF + END IF + END IF + ! + END IF + ! + ! 4.c Perform output type 3 ( source terms ) + ! + ELSE IF ( ITYPE .EQ. 3 ) THEN + ! + IF ( OTYPE .EQ. 1 ) THEN + ! + IF ( SCALE1 .GE. 0. ) THEN + IF ( FLSRCE(1) ) & + CALL PRT1DS (NDSO, NK, E1, SIG(1:NK), & + 'RAD/S', 17, 0., 'E(f)', 'm^2s', & + PTNME(J) ) + IF (FLSRCE(2) .OR. FLSRCE(3) .OR. & + FLSRCE(4) .OR. FLSRCE(5) .OR. & + FLSRCE(6) .OR. FLSRCE(7) ) & + CALL PRT1DM (NDSO, NK, 6, E1ALL, SIG(1:NK),& + 'RAD/S', 17, SCALE1, VAR1, 'M2', & + PTNME(J) ) + END IF + IF ( SCALE2 .GE. 0. ) THEN + IF ( FLSRCE(1) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, E, & + SIG(1:NK), 'RAD/S', 1., 0., 0.0001, & + 'E(f,th)', 'm^2s', PTNME(J) ) + IF ( FLSRCE(2) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, SWN, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Sin(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(3) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, SNL, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Snl(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(4) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, SDS, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Sds(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(5) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, SBT, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Sbt(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(6) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, SIS, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Sice(f,th)', 'm^2', PTNME(J) ) + IF ( FLSRCE(7) ) & + CALL PRT2DS (NDSO, NK, NK, NTH, STT, & + SIG(1:NK), 'RAD/S', 1., SCALE2, 0.0001,& + 'Stot(f,th)', 'm^2', PTNME(J) ) + END IF + ! + ELSE IF ( OTYPE .EQ. 2 ) THEN + ! + CALL STME21 ( TIME , DTME21 ) + IF ( FLAGLL ) THEN + WRITE (NDSTAB,2920) DTME21, PTNME(J), & + M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & + DPO(J), USTAR, WAO(J) + ELSE + WRITE (NDSTAB,2720) DTME21, PTNME(J), & + M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & + DPO(J), USTAR, WAO(J) + END IF + IF ( ISCALE.EQ.0 ) THEN + WRITE (NDSTAB,2921) + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + WRITE (NDSTAB,2922) + ELSE IF ( ISCALE.EQ.3 ) THEN + WRITE (NDSTAB,2923) + ELSE IF ( ISCALE.EQ.4 .OR. ISCALE.EQ.5 ) THEN + WRITE (NDSTAB,2924) + END IF + IF ( ISCALE.GE.3 ) FACF = 1. / FP + DO IK=1, NK + WRITE (NDSTAB,2930) FACF*SIG(IK), E1(IK), & + SIN1(IK), SNL1(IK), SDS1(IK), SBT1(IK), & + SIS1(IK), STT1(IK) - END DO - WRITE (NDSTAB,2940) -! - ELSE IF ( OTYPE .EQ. 3 ) THEN -! - CALL STME21 ( TIME , DTME21 ) - IF ( FLAGLL ) THEN - WRITE (NDSTAB,2920) DTME21, PTNME(J), & - M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & - DPO(J), USTAR, WAO(J) - ELSE - WRITE (NDSTAB,2720) DTME21, PTNME(J), & - M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & - DPO(J), USTAR, WAO(J) - END IF - IF ( ISCALE.EQ.0 ) THEN - WRITE (NDSTAB,2925) - ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN - WRITE (NDSTAB,2926) - ELSE IF ( ISCALE.EQ.3 ) THEN - WRITE (NDSTAB,2927) - ELSE IF ( ISCALE.EQ.4 .OR. ISCALE.EQ.5 ) THEN - WRITE (NDSTAB,2928) - END IF -! - IF ( ISCALE.GE.3 ) FACF = 1. / FP - DO IK=1, NK - FACT = 1. / MAX ( 1.E-10 , E1(IK) ) - IF ( E1(IK) .GT. 1.E-10 ) THEN - WRITE (NDSTAB,2931) FACF*SIG(IK), E1(IK), & - FACT*SIN1(IK), FACT*SNL1(IK), & - FACT*SDS1(IK), FACT*SBT1(IK), & - FACT*SIS1(IK),FACT*STT1(IK) - ELSE - WRITE (NDSTAB,2931) FACF*SIG(IK), E1(IK) - END IF - END DO - WRITE (NDSTAB,2940) -! - ELSE IF ( OTYPE .EQ. 4 ) THEN -! - IF ( FLFORM ) THEN - WRITE (NDSTAB) PTNME(J), PTLOC(2,J), & - PTLOC(1,J), DPO(J), WAO(J), & - UDIR, CAO(J), CDIR - IF ( FLSRCE(1) ) WRITE (NDSTAB) & - ((E(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(2) ) WRITE (NDSTAB) & - ((SWN(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(3) ) WRITE (NDSTAB) & - ((SNL(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(4) ) WRITE (NDSTAB) & - ((SDS(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(5) ) WRITE (NDSTAB) & - ((SBT(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(6) ) WRITE (NDSTAB) & - ((SIS(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(7) ) WRITE (NDSTAB) & - ((STT(IK,ITH),IK=1,NK),ITH=1,NTH) - ELSE - IF ( FLAGLL ) THEN - WRITE (NDSTAB,901) PTNME(J), & - M2KM*PTLOC(2,J), M2KM*PTLOC(1,J), & - DPO(J), WAO(J), UDIR, CAO(J), CDIR - ELSE - WRITE (NDSTAB,701) PTNME(J), & - M2KM*PTLOC(2,J), M2KM*PTLOC(1,J), & - DPO(J), WAO(J), UDIR, CAO(J), CDIR - END IF - IF ( FLSRCE(1) ) WRITE (NDSTAB,902) & - ((E(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(2) ) WRITE (NDSTAB,902) & - ((SWN(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(3) ) WRITE (NDSTAB,902) & - ((SNL(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(4) ) WRITE (NDSTAB,902) & - ((SDS(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(5) ) WRITE (NDSTAB,902) & - ((SBT(IK,ITH),IK=1,NK),ITH=1,NTH) - IF ( FLSRCE(6) ) WRITE (NDSTAB,902) & - ((SIS(IK,ITH),IK=1,NK),ITH=1, NTH) - IF ( FLSRCE(7) ) WRITE (NDSTAB,902) & - ((STT(IK,ITH),IK=1,NK),ITH=1,NTH) - END IF -! - END IF -! -! 4.d Perform output type 4 ( Spectral partitions and bulletins ) -! - ELSE IF ( ITYPE .EQ. 4 ) THEN -! - IF ( OTYPE .EQ. 1 ) THEN -! - IF ( FLAGLL ) THEN - IF ( PTLOC(1,J) .LT. 0. ) & - PTLOC(1,J) = PTLOC(1,J) + 360. - WRITE (NDSTAB,940) TIME, M2KM*PTLOC(2,J), & - M2KM*PTLOC(1,J), PTNME(J), NPART, DEPTH, & - WAO(J), UDIR, CAO(J), CDIR - ELSE - WRITE (NDSTAB,943) TIME, M2KM*PTLOC(1,J), & - M2KM*PTLOC(2,J), PTNME(J), NPART, DEPTH, & - WAO(J), UDIR, CAO(J), CDIR - END IF -! WRITE (NDSTAB,941) - DO I=0, NPART - WRITE (NDSTAB,942) I, XPART(:,I) - END DO -! - ELSEIF ( OTYPE .GE. 2 ) THEN - CALL W3BULL (NPART, XPART, DIMXP, UABS, & - UDIR, J, IOUT, TIMEV ) -! - IF ( FLAGLL ) THEN - X = M2KM * PTLOC(1,J) - Y = M2KM * PTLOC(2,J) + END DO + WRITE (NDSTAB,2940) + ! + ELSE IF ( OTYPE .EQ. 3 ) THEN + ! + CALL STME21 ( TIME , DTME21 ) + IF ( FLAGLL ) THEN + WRITE (NDSTAB,2920) DTME21, PTNME(J), & + M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & + DPO(J), USTAR, WAO(J) + ELSE + WRITE (NDSTAB,2720) DTME21, PTNME(J), & + M2KM*PTLOC(1,J), M2KM*PTLOC(2,J), & + DPO(J), USTAR, WAO(J) + END IF + IF ( ISCALE.EQ.0 ) THEN + WRITE (NDSTAB,2925) + ELSE IF ( ISCALE.EQ.1 .OR. ISCALE.EQ.2 ) THEN + WRITE (NDSTAB,2926) + ELSE IF ( ISCALE.EQ.3 ) THEN + WRITE (NDSTAB,2927) + ELSE IF ( ISCALE.EQ.4 .OR. ISCALE.EQ.5 ) THEN + WRITE (NDSTAB,2928) + END IF + ! + IF ( ISCALE.GE.3 ) FACF = 1. / FP + DO IK=1, NK + FACT = 1. / MAX ( 1.E-10 , E1(IK) ) + IF ( E1(IK) .GT. 1.E-10 ) THEN + WRITE (NDSTAB,2931) FACF*SIG(IK), E1(IK), & + FACT*SIN1(IK), FACT*SNL1(IK), & + FACT*SDS1(IK), FACT*SBT1(IK), & + FACT*SIS1(IK),FACT*STT1(IK) + ELSE + WRITE (NDSTAB,2931) FACF*SIG(IK), E1(IK) + END IF + END DO + WRITE (NDSTAB,2940) + ! + ELSE IF ( OTYPE .EQ. 4 ) THEN + ! + IF ( FLFORM ) THEN + WRITE (NDSTAB) PTNME(J), PTLOC(2,J), & + PTLOC(1,J), DPO(J), WAO(J), & + UDIR, CAO(J), CDIR + IF ( FLSRCE(1) ) WRITE (NDSTAB) & + ((E(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(2) ) WRITE (NDSTAB) & + ((SWN(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(3) ) WRITE (NDSTAB) & + ((SNL(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(4) ) WRITE (NDSTAB) & + ((SDS(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(5) ) WRITE (NDSTAB) & + ((SBT(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(6) ) WRITE (NDSTAB) & + ((SIS(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(7) ) WRITE (NDSTAB) & + ((STT(IK,ITH),IK=1,NK),ITH=1,NTH) + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSTAB,901) PTNME(J), & + M2KM*PTLOC(2,J), M2KM*PTLOC(1,J), & + DPO(J), WAO(J), UDIR, CAO(J), CDIR + ELSE + WRITE (NDSTAB,701) PTNME(J), & + M2KM*PTLOC(2,J), M2KM*PTLOC(1,J), & + DPO(J), WAO(J), UDIR, CAO(J), CDIR + END IF + IF ( FLSRCE(1) ) WRITE (NDSTAB,902) & + ((E(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(2) ) WRITE (NDSTAB,902) & + ((SWN(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(3) ) WRITE (NDSTAB,902) & + ((SNL(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(4) ) WRITE (NDSTAB,902) & + ((SDS(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(5) ) WRITE (NDSTAB,902) & + ((SBT(IK,ITH),IK=1,NK),ITH=1,NTH) + IF ( FLSRCE(6) ) WRITE (NDSTAB,902) & + ((SIS(IK,ITH),IK=1,NK),ITH=1, NTH) + IF ( FLSRCE(7) ) WRITE (NDSTAB,902) & + ((STT(IK,ITH),IK=1,NK),ITH=1,NTH) + END IF + ! + END IF + ! + ! 4.d Perform output type 4 ( Spectral partitions and bulletins ) + ! + ELSE IF ( ITYPE .EQ. 4 ) THEN + ! + IF ( OTYPE .EQ. 1 ) THEN + ! + IF ( FLAGLL ) THEN + IF ( PTLOC(1,J) .LT. 0. ) & + PTLOC(1,J) = PTLOC(1,J) + 360. + WRITE (NDSTAB,940) TIME, M2KM*PTLOC(2,J), & + M2KM*PTLOC(1,J), PTNME(J), NPART, DEPTH, & + WAO(J), UDIR, CAO(J), CDIR + ELSE + WRITE (NDSTAB,943) TIME, M2KM*PTLOC(1,J), & + M2KM*PTLOC(2,J), PTNME(J), NPART, DEPTH, & + WAO(J), UDIR, CAO(J), CDIR + END IF + ! WRITE (NDSTAB,941) + DO I=0, NPART + WRITE (NDSTAB,942) I, XPART(:,I) + END DO + ! + ELSEIF ( OTYPE .GE. 2 ) THEN + CALL W3BULL (NPART, XPART, DIMXP, UABS, & + UDIR, J, IOUT, TIMEV ) + ! + IF ( FLAGLL ) THEN + X = M2KM * PTLOC(1,J) + Y = M2KM * PTLOC(2,J) - X = MOD ( X+720. , 360. ) - IF ( X .LE. 180. ) THEN - IDLON = 'E' - ELSE - X = 360. - X - IDLON = 'W' - ENDIF - !IF ( ABS(Y) .LE. 0.0049 ) THEN - !IDLAT = '-' - IF ( Y .GE. 0. ) THEN - IDLAT = 'N' - ELSE - IDLAT = 'S' - Y = -Y - ENDIF - ELSE - IDLAT = ' ' - IDLON = ' ' - ENDIF - IF ( OTYPE .EQ. 2 .OR. OTYPE .EQ. 4 ) THEN - NDSBUL=NDSTAB + (J - 1) + X = MOD ( X+720. , 360. ) + IF ( X .LE. 180. ) THEN + IDLON = 'E' + ELSE + X = 360. - X + IDLON = 'W' + ENDIF + !IF ( ABS(Y) .LE. 0.0049 ) THEN + !IDLAT = '-' + IF ( Y .GE. 0. ) THEN + IDLAT = 'N' + ELSE + IDLAT = 'S' + Y = -Y + ENDIF + ELSE + IDLAT = ' ' + IDLON = ' ' + ENDIF + IF ( OTYPE .EQ. 2 .OR. OTYPE .EQ. 4 ) THEN + NDSBUL=NDSTAB + (J - 1) #ifdef W3_NCO - NDSCBUL=NDSTAB + (J - 1) + NOPTS -#endif - IF (IOUT .EQ. 1) THEN - WRITE(HSTR,'(I2,1X,A)') TIMEV(2)/10000, & - HTYPE - WRITE (NDSBUL,970) PTNME(J), Y, IDLAT, X, & - IDLON, GNAME, TIMEV(1), & - HSTR - WRITE (NDSBUL,971) - WRITE (NDSBUL,972) - WRITE (NDSBUL,971) + NDSCBUL=NDSTAB + (J - 1) + NOPTS +#endif + IF (IOUT .EQ. 1) THEN + WRITE(HSTR,'(I2,1X,A)') TIMEV(2)/10000, & + HTYPE + WRITE (NDSBUL,970) PTNME(J), Y, IDLAT, X, & + IDLON, GNAME, TIMEV(1), & + HSTR + WRITE (NDSBUL,971) + WRITE (NDSBUL,972) + WRITE (NDSBUL,971) #ifdef W3_NCO - WRITE (NDSCBUL,960) PTNME(J), Y, IDLAT, & - X, IDLON, GNAME, TIMEV(1), HSTR - WRITE (NDSCBUL,961) + WRITE (NDSCBUL,960) PTNME(J), Y, IDLAT, & + X, IDLON, GNAME, TIMEV(1), HSTR + WRITE (NDSCBUL,961) #endif - ENDIF + ENDIF - WRITE (NDSBUL,973) ASCBLINE + WRITE (NDSBUL,973) ASCBLINE #ifdef W3_NCO - WRITE (NDSCBUL,963) CASCBLINE + WRITE (NDSCBUL,963) CASCBLINE #endif - ENDIF - IF ( OTYPE .EQ. 3 .OR. OTYPE .EQ. 4 ) THEN - ICSV = 0 - IF ( NDSBUL .GT. 0 ) ICSV = NDSBUL + ENDIF + IF ( OTYPE .EQ. 3 .OR. OTYPE .EQ. 4 ) THEN + ICSV = 0 + IF ( NDSBUL .GT. 0 ) ICSV = NDSBUL #ifdef W3_NCO - IF ( NDSCBUL .GT. 0 ) ICSV = NDSCBUL + IF ( NDSCBUL .GT. 0 ) ICSV = NDSCBUL #endif - NDSCSV = NDSTAB + (J - 1) + ICSV - WRITE (NDSCSV,'(A664)') CSVBLINE - ENDIF - END IF -! - END IF -! ... End of fields loop -! + NDSCSV = NDSTAB + (J - 1) + ICSV + WRITE (NDSCSV,'(A664)') CSVBLINE + ENDIF END IF - END DO -! - RETURN -! -! Formats -! - 900 FORMAT (I8.8,I7.6) - 901 FORMAT ('''',A10,'''',2F7.2,F10.1,2(F7.2,F6.1)) - 701 FORMAT ('''',A10,'''',2(F8.1,'E3'),F10.1,2(F7.2,F6.1)) - 902 FORMAT (7E11.3) - 905 FORMAT (9X,A) - 910 FORMAT (/15X,' Water depth :',F7.1,' (m)'/ & - 15X,' Wind speed :',F8.2,' (m/s)') - 911 FORMAT ( 15X,' Wind direction :',F7.1,' (degr)') - 912 FORMAT ( 15X,' Air-sea temp. dif.:',F7.1,' (degr)'/ & - 15X,' Current speed :',F8.2,' (m/s)') - 913 FORMAT ( 15X,' Current direction :',F7.1,' (degr)') - 914 FORMAT ( 15X,' Wave height :',F8.2,' (m)'/ & - 15X,' Mean wave length :',F6.0,' (m)'/ & - 15X,' Mean wave period :',F7.1,' (s)'/ & - 15X,' Mean wave direct. :',F7.1,' (degr)'/ & - 15X,' Direct. spread :',F7.1,' (degr)'/) - 920 FORMAT (' Time : ',A/ & - ' Location : ',A,' (',2F8.2,' )'/ & - ' depth : ',F7.1,' m'/ & - ' U* : ',F9.3,' m/s'/ & - ' U10 : ',F7.1,' m/s'/ & - ' Dir U10 : ',F7.1,' degr'// & - ' f f/fp F(f) theta spr alpha '/ & - ' (Hz) (-) (m2s) (deg) (deg) (-) '/ & - ' --------------------------------------------------') - 720 FORMAT (' Time : ',A/ & - ' Location : ',A,' (',2(F8.1,'E3'),' )'/ & - ' depth : ',F7.1,' m'/ & - ' U* : ',F9.3,' m/s'/ & - ' U10 : ',F7.1,' m/s'/ & - ' Dir U10 : ',F7.1,' degr'// & - ' f f/fp F(f) theta spr alpha '/ & - ' (Hz) (-) (m2s) (deg) (deg) (-) '/ & - ' --------------------------------------------------') - 921 FORMAT (1x,F8.5,F7.3,E11.3,2F8.1,F8.4) - 922 FORMAT (' '/' ') -! - 940 FORMAT (1X,I8.8,1X,I6.6,2F8.3,2X,'''',A10,'''', & - 1X,I3,F7.1,F5.1,f6.1,F5.2,F6.1) - 943 FORMAT (1X,I8.8,1X,I6.6,2(F8.1,'E3'),2X,'''',A10,'''', & - 1X,I3,F7.1,F5.1,f6.1,F5.2,F6.1) - 941 FORMAT (' hs tp lp theta sp wf') - 942 FORMAT (I3,3F8.2,2F9.2,10F7.2) -! -! + ! + END IF + ! ... End of fields loop + ! + END IF + END DO + ! + RETURN + ! + ! Formats + ! +900 FORMAT (I8.8,I7.6) +901 FORMAT ('''',A10,'''',2F7.2,F10.1,2(F7.2,F6.1)) +701 FORMAT ('''',A10,'''',2(F8.1,'E3'),F10.1,2(F7.2,F6.1)) +902 FORMAT (7E11.3) +905 FORMAT (9X,A) +910 FORMAT (/15X,' Water depth :',F7.1,' (m)'/ & + 15X,' Wind speed :',F8.2,' (m/s)') +911 FORMAT ( 15X,' Wind direction :',F7.1,' (degr)') +912 FORMAT ( 15X,' Air-sea temp. dif.:',F7.1,' (degr)'/ & + 15X,' Current speed :',F8.2,' (m/s)') +913 FORMAT ( 15X,' Current direction :',F7.1,' (degr)') +914 FORMAT ( 15X,' Wave height :',F8.2,' (m)'/ & + 15X,' Mean wave length :',F6.0,' (m)'/ & + 15X,' Mean wave period :',F7.1,' (s)'/ & + 15X,' Mean wave direct. :',F7.1,' (degr)'/ & + 15X,' Direct. spread :',F7.1,' (degr)'/) +920 FORMAT (' Time : ',A/ & + ' Location : ',A,' (',2F8.2,' )'/ & + ' depth : ',F7.1,' m'/ & + ' U* : ',F9.3,' m/s'/ & + ' U10 : ',F7.1,' m/s'/ & + ' Dir U10 : ',F7.1,' degr'// & + ' f f/fp F(f) theta spr alpha '/ & + ' (Hz) (-) (m2s) (deg) (deg) (-) '/ & + ' --------------------------------------------------') +720 FORMAT (' Time : ',A/ & + ' Location : ',A,' (',2(F8.1,'E3'),' )'/ & + ' depth : ',F7.1,' m'/ & + ' U* : ',F9.3,' m/s'/ & + ' U10 : ',F7.1,' m/s'/ & + ' Dir U10 : ',F7.1,' degr'// & + ' f f/fp F(f) theta spr alpha '/ & + ' (Hz) (-) (m2s) (deg) (deg) (-) '/ & + ' --------------------------------------------------') +921 FORMAT (1x,F8.5,F7.3,E11.3,2F8.1,F8.4) +922 FORMAT (' '/' ') + ! +940 FORMAT (1X,I8.8,1X,I6.6,2F8.3,2X,'''',A10,'''', & + 1X,I3,F7.1,F5.1,f6.1,F5.2,F6.1) +943 FORMAT (1X,I8.8,1X,I6.6,2(F8.1,'E3'),2X,'''',A10,'''', & + 1X,I3,F7.1,F5.1,f6.1,F5.2,F6.1) +941 FORMAT (' hs tp lp theta sp wf') +942 FORMAT (I3,3F8.2,2F9.2,10F7.2) + ! + ! #ifdef W3_NCO - 960 FORMAT ( 'Location : ',A,' (',F5.2,A,1X,F6.2,A,')'/ & - 'Model : ',A/ & - 'Cycle : ',I8,1X,A// & - 'DDHH HS SS PP DDD SS PP DDD SS PP DDD', & - ' SS PP DDD SS PP DDD SS PP DDD') - 961 FORMAT ('----------------------------------------', & - '---------------------------') - 963 FORMAT (A) -#endif -! - 970 FORMAT ( ' Location : ',A,' (',F5.2,A,1X,F6.2,A,')'/ & - ' Model : ',A/ & - ' Cycle : ',I8,1X,A) - 971 FORMAT (' +-------+-----------+-----------------+', & - '-----------------+-----------------+----', & - '-------------+-----------------+--------', & - '---------+') - 972 FORMAT (' | day & | Hst n x | Hs Tp dir |', & - ' Hs Tp dir |', & - ' Hs Tp dir |', & - ' Hs Tp dir |', & - ' Hs Tp dir |', & - ' Hs Tp dir |'/ & - ' | hour | (m) - - | (m) (s) (d) |', & - ' (m) (s) (d) |', & - ' (m) (s) (d) |', & - ' (m) (s) (d) |', & - ' (m) (s) (d) |', & - ' (m) (s) (d) |') - 973 FORMAT (1X,A) -! - 1901 FORMAT ( & - ' Date Time d Uc Dir. U10 Dir. '/ & - ' h m s (m) (m/s) (d.N) (m/s) (d.N) '/ & - ' ---------------------------------------------------------') - 1902 FORMAT ( & - ' Date Time Hs L Tr Dir. Spr. ', & - ' fp p_dir p_spr'/ & - ' h m s (m) (m) (s) (d.N) (deg)', & - ' (Hz) (d.N) (deg)'/ & - ' -------------------------------------------------------', & - '-----------------------') - 1903 FORMAT ( & - ' Date Time U* E* fp* Cd alpha'/& - ' h m s (m/s) (-) (-) *1000 *100'/ & - ' --------------------------------------------------------------') - 1904 FORMAT ( & - ' Date Time U10 E* fp* Cd alpha'/& - ' h m s (m/s) (-) (-) *1000 *100'/ & - ' --------------------------------------------------------------') - 1905 FORMAT ( & - ' Date Time U10 Dir. Hs H* cp/U ', & - ' cm/U Dt'/ & - ' (m/s) (d.N) (m) (-) (-) ', & - ' (-) (deg)'/ & - ' --------------------------------------------------', & - '---------------------') - 1906 FORMAT ( & - ' Time U10 Dir. Hs Tp '/ & - ' yr mth dy h (m/s) (d.N) (m) (s) '/ & - ' ----------------------------------') - 1910 FORMAT ( ' '/' ' ) - 1911 FORMAT (' Time : ',A// & - ' Long. Lat. d Uc Dir. U10 Dir. '/ & - ' (m) (m/s) (d.N) (m/s) (d.N) '/ & - ' --------------------------------------------------------') - 1912 FORMAT (' Time : ',A// & - ' Long. Lat. Hs L Tr Dir. Spr. ', & - ' fp p_dir p_spr'/ & - ' (m) (m) (s) (d.N) (deg)', & - ' (Hz) (d.N) (deg)'/ & - ' ------------------------------------------------------', & - '-----------------------') - 1711 FORMAT (' Time : ',A// & - ' X Y d Uc Dir. U10 Dir. '/ & - ' (m) (m) (m) (m/s) (d.N) (m/s) (d.N) '/ & - ' ----------------------------------------------------------') - 1712 FORMAT (' Time : ',A// & - ' X Y Hs L Tr Dir. Spr. ', & - ' fp p_dir p_spr'/ & - ' (m) (m)) (m) (m) (s) (d.N) (deg)', & - ' (Hz) (d.N) (deg)'/ & - ' ------------------------------------------------------', & - '-------------------------') - 1913 FORMAT (' Time : ',A// & - ' X* Y* U* E* fp* Cd alpha'/& - ' (-) (-) (m/s) (-) (-) *1000 *100'/ & - ' --------------------------------------------------------------') - 1914 FORMAT (' Time : ',A// & - ' X* Y* U10 E* fp* Cd alpha'/ & - ' (-) (-) (m/s) (-) (-) *1000 *100 '/ & - ' --------------------------------------------------------------') - 1915 FORMAT (' Time : ',A// & - ' Long. Lat. U10 Dir. Hs H* cp/U ', & - ' cm/U Dt'/ & - ' (m/s) (d.N) (m) (-) (-) ', & - ' (-) (deg)'/ & - ' -------------------------------------------------', & - '---------------------') - 1715 FORMAT (' Time : ',A// & - ' X Y U10 Dir. Hs H* cp/U ', & - ' cm/U Dt'/ & - ' (m) (m) (m/s) (d.N) (m) (-) (-) ', & - ' (-) (deg)'/ & - ' ---------------------------------------------------', & - '---------------------') - 1916 FORMAT (' Time : ',A// & - ' Long. Lat. U10 Dir. Hs Tp '/ & - ' (m/s) (d.N) (m) (s) '/ & - '-----------------------------------------------') - 1716 FORMAT (' Time : ',A// & - ' X Y U10 Dir. Hs Tp '/ & - ' (m) (m) (m/s) (d.N) (m) (s) '/ & - '---------------------------------------------------') - 1921 FORMAT ( 2X,I8.8,I3,2(1X,I2.2),F10.1,F6.2,F7.1,F6.2,F7.1) - 1922 FORMAT ( 2X,I8.8,I3,2(1X,I2.2),F9.3,F7.1,F7.2,F7.1,F7.2, & - F8.4,F7.1,F7.2) - 1923 FORMAT ( 2X,I8.8,I3,2(1X,I2.2),F8.4,2E11.3,2F7.3) - 1924 FORMAT ( 2X,I8.8,I3,2(1X,I2.2),F7.1,2E11.3,2F7.3) - 1925 FORMAT ( 2X,I8.8,I3,2(1X,I2.2),F7.2,F7.1,2F7.2,2F8.2,F7.1) - 1926 FORMAT ( 2X,I4,3(1X,I2),F6.2,1X,I3,2F6.2) - 1931 FORMAT ( 2X,2F8.3,F10.1,F6.2,F7.1,F6.2,F7.1) - 1932 FORMAT ( 2X,2F8.3,F9.3,F7.1,F7.2,F7.1,F7.2, & - F8.4,F7.1,F7.2) - 1731 FORMAT ( 2X,2(F7.1,'E3'),F10.1,F6.2,F7.1,F6.2,F7.1) - 1732 FORMAT ( 2X,2(F7.1,'E3'),F9.3,F7.1,F7.2,F7.1,F7.2, & - F8.4,F7.1,F7.2) - 1933 FORMAT ( 2X,2(F7.1,'E4'),F8.4,2E11.3,2F7.3) - 1934 FORMAT ( 2X,2F9.1,F7.1,2E11.3,2F7.3) - 1935 FORMAT ( 2X,2F8.3,F7.2,F7.1,2F7.2,2F8.2,F7.1) - 1735 FORMAT ( 2X,2(F7.1,'E3'),F7.2,F7.1,2F7.2,2F8.2,F7.1) - 1936 FORMAT ( 2X,2F8.3,F6.2,1X,I3,2F6.2) - 1736 FORMAT ( 2X,2(F8.2,'E3'),F6.2,1X,I3,2F6.2) -! - 2920 FORMAT (' Time : ',A/ & - ' Location : ',A,' (',2F8.2,' )'/ & - ' depth : ',F7.1,' m'/ & - ' U* : ',F9.3,' m/s'/ & - ' U10 : ',F7.1,' m/s'/) - 2720 FORMAT (' Time : ',A/ & - ' Location : ',A,' (',2(F8.1,'E3'),' )'/ & - ' depth : ',F7.1,' m'/ & - ' U* : ',F9.3,' m/s'/ & - ' U10 : ',F7.1,' m/s'/) - 2921 FORMAT (' f E ', & - ' Sin Snl Sds Sbt Sice Stot'/ & - ' (Hz) (m2s) ', & - ' (m2) (m2) (m2) (m2) (m2) (m2)'/ & - ' ------------------------------------------', & - '-------------------------------------------') - 2922 FORMAT (' f* E* ', & - ' Sin* Snl* Sds* Sbt* Sice* Stot*'/ & - ' (-) (-) ', & - ' (-) (-) (-) (-) (-) (-)'/ & - ' ------------------------------------------', & - '-------------------------------------------') - 2923 FORMAT (' f/fp E ', & - ' Sin Snl Sds Sbt Sice Stot'/ & - ' (-) (m2s) ', & - ' (m2) (m2) (m2) (m2) (m2) (m2)'/ & - ' ------------------------------------------', & - '-------------------------------------------') - 2924 FORMAT (' f/fp E* ', & - ' Sin* Snl* Sds* Sbt* Sice* Stot*'/ & - ' (-) (-) ', & - ' (-) (-) (-) (-) (-) (-)'/ & - ' ------------------------------------------', & - '-------------------------------------------') - 2925 FORMAT (' f E ', & - ' Tini Tnli Tdsi Tbti Ticei Ttoti'/ & - ' (Hz) (m2s) ', & - ' (1/s) (1/s) (1/s) (1/s) (1/s) (1/s)'/ & - ' ----------------------------------------', & - '-------------------------------------------') - 2926 FORMAT (' f* E* ', & - ' Tini* Tnli* Tdsi* Tbti* Ticei* Ttoti*'/ & - ' (-) (-) ', & - ' (-) (-) (-) (-) (-) (-)'/ & - ' ----------------------------------------', & - '-------------------------------------------') - 2927 FORMAT (' f/fp E ', & - ' Tini Tnli Tdsi Tbti Ticei Ttoti'/ & - ' (-) (m2s) ', & - ' (1/s) (1/s) (1/s) (1/s) (1/s) (1/s)'/ & - ' ----------------------------------------', & - '-------------------------------------------') - 2928 FORMAT (' f/fp E* ', & - ' Tini* Tnli* Tdsi* Tbti* Ticei* Ttoti*'/ & - ' (-) (-) ', & - ' (-) (-) (-) (-) (-) (-)'/ & - ' ----------------------------------------', & - '-------------------------------------------') - 2930 FORMAT (1X,F6.4,2X,7E11.3) - 2931 FORMAT (1X,F6.4,7E11.3) - 2940 FORMAT ( ' '/' ' ) -! +960 FORMAT ( 'Location : ',A,' (',F5.2,A,1X,F6.2,A,')'/ & + 'Model : ',A/ & + 'Cycle : ',I8,1X,A// & + 'DDHH HS SS PP DDD SS PP DDD SS PP DDD', & + ' SS PP DDD SS PP DDD SS PP DDD') +961 FORMAT ('----------------------------------------', & + '---------------------------') +963 FORMAT (A) +#endif + ! +970 FORMAT ( ' Location : ',A,' (',F5.2,A,1X,F6.2,A,')'/ & + ' Model : ',A/ & + ' Cycle : ',I8,1X,A) +971 FORMAT (' +-------+-----------+-----------------+', & + '-----------------+-----------------+----', & + '-------------+-----------------+--------', & + '---------+') +972 FORMAT (' | day & | Hst n x | Hs Tp dir |', & + ' Hs Tp dir |', & + ' Hs Tp dir |', & + ' Hs Tp dir |', & + ' Hs Tp dir |', & + ' Hs Tp dir |'/ & + ' | hour | (m) - - | (m) (s) (d) |', & + ' (m) (s) (d) |', & + ' (m) (s) (d) |', & + ' (m) (s) (d) |', & + ' (m) (s) (d) |', & + ' (m) (s) (d) |') +973 FORMAT (1X,A) + ! +1901 FORMAT ( & + ' Date Time d Uc Dir. U10 Dir. '/ & + ' h m s (m) (m/s) (d.N) (m/s) (d.N) '/ & + ' ---------------------------------------------------------') +1902 FORMAT ( & + ' Date Time Hs L Tr Dir. Spr. ', & + ' fp p_dir p_spr'/ & + ' h m s (m) (m) (s) (d.N) (deg)', & + ' (Hz) (d.N) (deg)'/ & + ' -------------------------------------------------------', & + '-----------------------') +1903 FORMAT ( & + ' Date Time U* E* fp* Cd alpha'/& + ' h m s (m/s) (-) (-) *1000 *100'/ & + ' --------------------------------------------------------------') +1904 FORMAT ( & + ' Date Time U10 E* fp* Cd alpha'/& + ' h m s (m/s) (-) (-) *1000 *100'/ & + ' --------------------------------------------------------------') +1905 FORMAT ( & + ' Date Time U10 Dir. Hs H* cp/U ', & + ' cm/U Dt'/ & + ' (m/s) (d.N) (m) (-) (-) ', & + ' (-) (deg)'/ & + ' --------------------------------------------------', & + '---------------------') +1906 FORMAT ( & + ' Time U10 Dir. Hs Tp '/ & + ' yr mth dy h (m/s) (d.N) (m) (s) '/ & + ' ----------------------------------') +1910 FORMAT ( ' '/' ' ) +1911 FORMAT (' Time : ',A// & + ' Long. Lat. d Uc Dir. U10 Dir. '/ & + ' (m) (m/s) (d.N) (m/s) (d.N) '/ & + ' --------------------------------------------------------') +1912 FORMAT (' Time : ',A// & + ' Long. Lat. Hs L Tr Dir. Spr. ', & + ' fp p_dir p_spr'/ & + ' (m) (m) (s) (d.N) (deg)', & + ' (Hz) (d.N) (deg)'/ & + ' ------------------------------------------------------', & + '-----------------------') +1711 FORMAT (' Time : ',A// & + ' X Y d Uc Dir. U10 Dir. '/ & + ' (m) (m) (m) (m/s) (d.N) (m/s) (d.N) '/ & + ' ----------------------------------------------------------') +1712 FORMAT (' Time : ',A// & + ' X Y Hs L Tr Dir. Spr. ', & + ' fp p_dir p_spr'/ & + ' (m) (m)) (m) (m) (s) (d.N) (deg)', & + ' (Hz) (d.N) (deg)'/ & + ' ------------------------------------------------------', & + '-------------------------') +1913 FORMAT (' Time : ',A// & + ' X* Y* U* E* fp* Cd alpha'/& + ' (-) (-) (m/s) (-) (-) *1000 *100'/ & + ' --------------------------------------------------------------') +1914 FORMAT (' Time : ',A// & + ' X* Y* U10 E* fp* Cd alpha'/ & + ' (-) (-) (m/s) (-) (-) *1000 *100 '/ & + ' --------------------------------------------------------------') +1915 FORMAT (' Time : ',A// & + ' Long. Lat. U10 Dir. Hs H* cp/U ', & + ' cm/U Dt'/ & + ' (m/s) (d.N) (m) (-) (-) ', & + ' (-) (deg)'/ & + ' -------------------------------------------------', & + '---------------------') +1715 FORMAT (' Time : ',A// & + ' X Y U10 Dir. Hs H* cp/U ', & + ' cm/U Dt'/ & + ' (m) (m) (m/s) (d.N) (m) (-) (-) ', & + ' (-) (deg)'/ & + ' ---------------------------------------------------', & + '---------------------') +1916 FORMAT (' Time : ',A// & + ' Long. Lat. U10 Dir. Hs Tp '/ & + ' (m/s) (d.N) (m) (s) '/ & + '-----------------------------------------------') +1716 FORMAT (' Time : ',A// & + ' X Y U10 Dir. Hs Tp '/ & + ' (m) (m) (m/s) (d.N) (m) (s) '/ & + '---------------------------------------------------') +1921 FORMAT ( 2X,I8.8,I3,2(1X,I2.2),F10.1,F6.2,F7.1,F6.2,F7.1) +1922 FORMAT ( 2X,I8.8,I3,2(1X,I2.2),F9.3,F7.1,F7.2,F7.1,F7.2, & + F8.4,F7.1,F7.2) +1923 FORMAT ( 2X,I8.8,I3,2(1X,I2.2),F8.4,2E11.3,2F7.3) +1924 FORMAT ( 2X,I8.8,I3,2(1X,I2.2),F7.1,2E11.3,2F7.3) +1925 FORMAT ( 2X,I8.8,I3,2(1X,I2.2),F7.2,F7.1,2F7.2,2F8.2,F7.1) +1926 FORMAT ( 2X,I4,3(1X,I2),F6.2,1X,I3,2F6.2) +1931 FORMAT ( 2X,2F8.3,F10.1,F6.2,F7.1,F6.2,F7.1) +1932 FORMAT ( 2X,2F8.3,F9.3,F7.1,F7.2,F7.1,F7.2, & + F8.4,F7.1,F7.2) +1731 FORMAT ( 2X,2(F7.1,'E3'),F10.1,F6.2,F7.1,F6.2,F7.1) +1732 FORMAT ( 2X,2(F7.1,'E3'),F9.3,F7.1,F7.2,F7.1,F7.2, & + F8.4,F7.1,F7.2) +1933 FORMAT ( 2X,2(F7.1,'E4'),F8.4,2E11.3,2F7.3) +1934 FORMAT ( 2X,2F9.1,F7.1,2E11.3,2F7.3) +1935 FORMAT ( 2X,2F8.3,F7.2,F7.1,2F7.2,2F8.2,F7.1) +1735 FORMAT ( 2X,2(F7.1,'E3'),F7.2,F7.1,2F7.2,2F8.2,F7.1) +1936 FORMAT ( 2X,2F8.3,F6.2,1X,I3,2F6.2) +1736 FORMAT ( 2X,2(F8.2,'E3'),F6.2,1X,I3,2F6.2) + ! +2920 FORMAT (' Time : ',A/ & + ' Location : ',A,' (',2F8.2,' )'/ & + ' depth : ',F7.1,' m'/ & + ' U* : ',F9.3,' m/s'/ & + ' U10 : ',F7.1,' m/s'/) +2720 FORMAT (' Time : ',A/ & + ' Location : ',A,' (',2(F8.1,'E3'),' )'/ & + ' depth : ',F7.1,' m'/ & + ' U* : ',F9.3,' m/s'/ & + ' U10 : ',F7.1,' m/s'/) +2921 FORMAT (' f E ', & + ' Sin Snl Sds Sbt Sice Stot'/ & + ' (Hz) (m2s) ', & + ' (m2) (m2) (m2) (m2) (m2) (m2)'/ & + ' ------------------------------------------', & + '-------------------------------------------') +2922 FORMAT (' f* E* ', & + ' Sin* Snl* Sds* Sbt* Sice* Stot*'/ & + ' (-) (-) ', & + ' (-) (-) (-) (-) (-) (-)'/ & + ' ------------------------------------------', & + '-------------------------------------------') +2923 FORMAT (' f/fp E ', & + ' Sin Snl Sds Sbt Sice Stot'/ & + ' (-) (m2s) ', & + ' (m2) (m2) (m2) (m2) (m2) (m2)'/ & + ' ------------------------------------------', & + '-------------------------------------------') +2924 FORMAT (' f/fp E* ', & + ' Sin* Snl* Sds* Sbt* Sice* Stot*'/ & + ' (-) (-) ', & + ' (-) (-) (-) (-) (-) (-)'/ & + ' ------------------------------------------', & + '-------------------------------------------') +2925 FORMAT (' f E ', & + ' Tini Tnli Tdsi Tbti Ticei Ttoti'/ & + ' (Hz) (m2s) ', & + ' (1/s) (1/s) (1/s) (1/s) (1/s) (1/s)'/ & + ' ----------------------------------------', & + '-------------------------------------------') +2926 FORMAT (' f* E* ', & + ' Tini* Tnli* Tdsi* Tbti* Ticei* Ttoti*'/ & + ' (-) (-) ', & + ' (-) (-) (-) (-) (-) (-)'/ & + ' ----------------------------------------', & + '-------------------------------------------') +2927 FORMAT (' f/fp E ', & + ' Tini Tnli Tdsi Tbti Ticei Ttoti'/ & + ' (-) (m2s) ', & + ' (1/s) (1/s) (1/s) (1/s) (1/s) (1/s)'/ & + ' ----------------------------------------', & + '-------------------------------------------') +2928 FORMAT (' f/fp E* ', & + ' Tini* Tnli* Tdsi* Tbti* Ticei* Ttoti*'/ & + ' (-) (-) ', & + ' (-) (-) (-) (-) (-) (-)'/ & + ' ----------------------------------------', & + '-------------------------------------------') +2930 FORMAT (1X,F6.4,2X,7E11.3) +2931 FORMAT (1X,F6.4,7E11.3) +2940 FORMAT ( ' '/' ' ) + ! #ifdef W3_T - 9000 FORMAT (' TEST W3EXPO : FLAGS :',40L2) - 9001 FORMAT (' TEST W3EXPO : ITPYE :',I4/ & - ' OTPYE :',I4/ & - ' NREQ :',I4/ & - ' SCALE1 :',E10.3/ & - ' SCALE2 :',E10.3/ & - ' FLSRCE :',7L2) - 9002 FORMAT (' TEST W3EXPO : OUTPUT POINT : ',A) - 9010 FORMAT (' TEST W3EXPO : DEPTH =',F7.1,' IK, T, K, CG :') - 9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) -#endif -!/ -!/ End of W3EXPO ----------------------------------------------------- / -!/ - END SUBROUTINE W3EXPO -!/ -!/ End of W3OUTP ----------------------------------------------------- / -!/ - END PROGRAM W3OUTP +9000 FORMAT (' TEST W3EXPO : FLAGS :',40L2) +9001 FORMAT (' TEST W3EXPO : ITPYE :',I4/ & + ' OTPYE :',I4/ & + ' NREQ :',I4/ & + ' SCALE1 :',E10.3/ & + ' SCALE2 :',E10.3/ & + ' FLSRCE :',7L2) +9002 FORMAT (' TEST W3EXPO : OUTPUT POINT : ',A) +9010 FORMAT (' TEST W3EXPO : DEPTH =',F7.1,' IK, T, K, CG :') +9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#endif + !/ + !/ End of W3EXPO ----------------------------------------------------- / + !/ + END SUBROUTINE W3EXPO + !/ + !/ End of W3OUTP ----------------------------------------------------- / + !/ +END PROGRAM W3OUTP diff --git a/model/src/ww3_prep.F90 b/model/src/ww3_prep.F90 index dad433a2f..7d41df3cf 100644 --- a/model/src/ww3_prep.F90 +++ b/model/src/ww3_prep.F90 @@ -14,1742 +14,1742 @@ !> !> @author H. L. Tolman @date 22-Mar-2021 ! - PROGRAM W3PREP -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | A. Chawla | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 18-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 11-Jan-2001 : Flat grid option added ( version 2.06 ) -!/ 17-Jul-2001 : Clean-up ( version 2.11 ) -!/ 24-Jan-2002 : Add data for data assimilation. ( version 2.17 ) -!/ 30-Apr-2002 : Fix 'AI' bug for 1-D fields. ( version 2.20 ) -!/ 24-Apr-2003 : Fix bug for NDAT = 0 in data. ( version 3.03 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 25-Sep-2007 : Switch header of file on or off, ( version 3.13 ) -!/ Times to file (!/O15) (A. Chawla) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 15-May-2010 : Add ISI (icebergs and sea ice). ( version 3.14.4 ) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 1-Apr-2011 : Fix bug GLOBX forcing with unst. ( version 3.14.4 ) -!/ 19-Sep-2011 : Fix bug prep forcing with unst. ( version 4.04 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.OF ) -!/ 3-Mar-2013 : Allows for longer input file name ( version 4.09 ) -!/ 11-Nov-2013 : Allows for input binary files to be of WAVEWATCH -!/ type (i.e. accounts for the header) ( version 4.13 ) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ 22-Mar-2021 : Add momentum and air density ( version 7.13 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Pre-processing of the input water level, current, wind, ice -! fields, momentum and air density, as well as assimilation data -! for the generic shell W3SHEL (ww3_shel.ftn). -! -! 2. Method : -! -! See documented input file. -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! NDSI Int. Input unit number ("ww3_prep.inp"). -! NDSLL Int. Unit number(s) of long-lat file(s) -! NDSF I.A. Unit number(s) of input file(s). -! NDSDAT Int. Unit number for output data file. -! IFLD Int. Integer input type. -! ITYPE Int. Integer input 'format' type. -! NFCOMP Int. Number of partial input to be processed. -! FLTIME Log. Time flag for input fields, if false, single -! field, time read from NDSI. -! IDLALL Int. Layout indicator used by INA2R. + -! IDFMLL Int. Id. FORMAT indicator. | -! FORMLL C*16 Id. FORMAT. | Long-lat -! FROMLL C*4 'UNIT' / 'NAME' indicator | file(s) -! NAMELL C*65 Name of long-lat file(s) + -! IDLAF I.A. + -! IDFMF I.A. | -! FORMF C.A. | Idem. fields file(s) -! FROMF C*4 | -! NAMEF C*65 + -! FORMT C.A. Format or time in field. -! XC R.A. Components of input vector field or first -! input scalar field -! YC R.A. Components of input vector field or second -! input scalar field -! FX,FY R.A. Output fields. -! ACC Real Required interpolation accuracy. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! STME21 Subr. W3TIMEMD Convert time to string. -! INAR2R Subr. W3ARRYMD Read in an REAL array. -! INAR2I Subr. Id. Read in an INTEGER array. -! PRTBLK Subr. Id. Print plot of array. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3FLDO Subr. W3FLDSMD Opening of WAVEWATCH III generic shell -! data file. -! W3FLDP Subr. Id. Prepare interp. from arbitrary grid. -! W3FLDG Subr. Id. Reading/writing shell input data. -! W3FLDD Subr. Id. Reading/writing shell assim. data. -! W3GSUC Func. W3GSRUMD Create grid-search-utility object -! W3GSUD Subr. W3GSRUMD Destroy grid-search-utility object -! W3GRMP Func. W3GSRUMD Compute interpolation weights -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! - Checks on files and reading from file. -! - Checks on validity of input parameters. -! -! 7. Remarks : -! -! - Input fields need to be continuous in longitude and latitude. -! - Longitude - latitude grid (Section 4.a) : program attempts to -! detect closure type (ICLO) using longitudes of the grid. Thus, -! it does not allow the user to specify the closure type, and so -! tripole closure is not supported. -! - Grid(s) from file (Section 4.a) : program reads logical variable -! CLO(J) from .inp file. Thus, it does not allow the user to -! specify more than two closure type (SMPL or NONE), and so -! tripole closure is not supported. +PROGRAM W3PREP + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | A. Chawla | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 18-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 11-Jan-2001 : Flat grid option added ( version 2.06 ) + !/ 17-Jul-2001 : Clean-up ( version 2.11 ) + !/ 24-Jan-2002 : Add data for data assimilation. ( version 2.17 ) + !/ 30-Apr-2002 : Fix 'AI' bug for 1-D fields. ( version 2.20 ) + !/ 24-Apr-2003 : Fix bug for NDAT = 0 in data. ( version 3.03 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 25-Sep-2007 : Switch header of file on or off, ( version 3.13 ) + !/ Times to file (!/O15) (A. Chawla) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 15-May-2010 : Add ISI (icebergs and sea ice). ( version 3.14.4 ) + !/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) + !/ (A. Roland and F. Ardhuin) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 1-Apr-2011 : Fix bug GLOBX forcing with unst. ( version 3.14.4 ) + !/ 19-Sep-2011 : Fix bug prep forcing with unst. ( version 4.04 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.OF ) + !/ 3-Mar-2013 : Allows for longer input file name ( version 4.09 ) + !/ 11-Nov-2013 : Allows for input binary files to be of WAVEWATCH + !/ type (i.e. accounts for the header) ( version 4.13 ) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ 22-Mar-2021 : Add momentum and air density ( version 7.13 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Pre-processing of the input water level, current, wind, ice + ! fields, momentum and air density, as well as assimilation data + ! for the generic shell W3SHEL (ww3_shel.ftn). + ! + ! 2. Method : + ! + ! See documented input file. + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! NDSI Int. Input unit number ("ww3_prep.inp"). + ! NDSLL Int. Unit number(s) of long-lat file(s) + ! NDSF I.A. Unit number(s) of input file(s). + ! NDSDAT Int. Unit number for output data file. + ! IFLD Int. Integer input type. + ! ITYPE Int. Integer input 'format' type. + ! NFCOMP Int. Number of partial input to be processed. + ! FLTIME Log. Time flag for input fields, if false, single + ! field, time read from NDSI. + ! IDLALL Int. Layout indicator used by INA2R. + + ! IDFMLL Int. Id. FORMAT indicator. | + ! FORMLL C*16 Id. FORMAT. | Long-lat + ! FROMLL C*4 'UNIT' / 'NAME' indicator | file(s) + ! NAMELL C*65 Name of long-lat file(s) + + ! IDLAF I.A. + + ! IDFMF I.A. | + ! FORMF C.A. | Idem. fields file(s) + ! FROMF C*4 | + ! NAMEF C*65 + + ! FORMT C.A. Format or time in field. + ! XC R.A. Components of input vector field or first + ! input scalar field + ! YC R.A. Components of input vector field or second + ! input scalar field + ! FX,FY R.A. Output fields. + ! ACC Real Required interpolation accuracy. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! W3SETO Subr. Id. Point to selected model for output. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! INAR2R Subr. W3ARRYMD Read in an REAL array. + ! INAR2I Subr. Id. Read in an INTEGER array. + ! PRTBLK Subr. Id. Print plot of array. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3FLDO Subr. W3FLDSMD Opening of WAVEWATCH III generic shell + ! data file. + ! W3FLDP Subr. Id. Prepare interp. from arbitrary grid. + ! W3FLDG Subr. Id. Reading/writing shell input data. + ! W3FLDD Subr. Id. Reading/writing shell assim. data. + ! W3GSUC Func. W3GSRUMD Create grid-search-utility object + ! W3GSUD Subr. W3GSRUMD Destroy grid-search-utility object + ! W3GRMP Func. W3GSRUMD Compute interpolation weights + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! - Checks on files and reading from file. + ! - Checks on validity of input parameters. + ! + ! 7. Remarks : + ! + ! - Input fields need to be continuous in longitude and latitude. + ! - Longitude - latitude grid (Section 4.a) : program attempts to + ! detect closure type (ICLO) using longitudes of the grid. Thus, + ! it does not allow the user to specify the closure type, and so + ! tripole closure is not supported. + ! - Grid(s) from file (Section 4.a) : program reads logical variable + ! CLO(J) from .inp file. Thus, it does not allow the user to + ! specify more than two closure type (SMPL or NONE), and so + ! tripole closure is not supported. -! 8. Structure : -! -! ---------------------------------------------------- -! 1.a Number of models. -! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) -! b I-O setup. -! c Print heading(s). -! 2. Read model definition file. ( W3IOGR ) -! 3.a Read major types from input file. -! b Check major types. -! c Additional input format types and time. -! 4. Prepare interpolation. -! a Longitude - latitude grid -! b Grid(s) from file. ( W3FLDP ) -! c Initialize fields. -! d Input location and format. -! 5 Prepare input and output files. -! a Open input file -! b Open and prepare output file ( W3FLDO ) -! 6 Until end of file -! a Read new time and fields -! b Interpolate fields -! c Write fields ( W3FLDG ) -! ---------------------------------------------------- -! -! 9. Switches : -! -! !/WNT0 = !/WNT1 -! !/WNT1 Correct wind speeds to (approximately) conserve the wind -! speed over the interpolation box. -! !/WNT2 Id. energy (USE ONLY ONE !) -! !/CRT1 Like !/WNT1 for currents. -! !/CRT2 Like !/WNT2 for currents. -! -! !/O3 Additional output in fields processing loop. -! !/O15 Generate file with the times of the processed fields. -! -! !/S Enable subroutine tracing. -! !/T Enable test output, -! !/T1 Full interpolation data. -! !/T1a Echo of lat-long data in type Fn -! !/T2 Full input data. -! !/T3 Print-plot of output data. -! -! !/NCO NCEP NCO modifications for operational implementation. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ -! USE W3GDATMD, ONLY: W3NMOD, W3SETG + ! 8. Structure : + ! + ! ---------------------------------------------------- + ! 1.a Number of models. + ! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) + ! b I-O setup. + ! c Print heading(s). + ! 2. Read model definition file. ( W3IOGR ) + ! 3.a Read major types from input file. + ! b Check major types. + ! c Additional input format types and time. + ! 4. Prepare interpolation. + ! a Longitude - latitude grid + ! b Grid(s) from file. ( W3FLDP ) + ! c Initialize fields. + ! d Input location and format. + ! 5 Prepare input and output files. + ! a Open input file + ! b Open and prepare output file ( W3FLDO ) + ! 6 Until end of file + ! a Read new time and fields + ! b Interpolate fields + ! c Write fields ( W3FLDG ) + ! ---------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/WNT0 = !/WNT1 + ! !/WNT1 Correct wind speeds to (approximately) conserve the wind + ! speed over the interpolation box. + ! !/WNT2 Id. energy (USE ONLY ONE !) + ! !/CRT1 Like !/WNT1 for currents. + ! !/CRT2 Like !/WNT2 for currents. + ! + ! !/O3 Additional output in fields processing loop. + ! !/O15 Generate file with the times of the processed fields. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output, + ! !/T1 Full interpolation data. + ! !/T1a Echo of lat-long data in type Fn + ! !/T2 Full input data. + ! !/T3 Print-plot of output data. + ! + ! !/NCO NCEP NCO modifications for operational implementation. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG #ifdef W3_NL1 - USE W3ADATMD,ONLY: W3NAUX, W3SETA + USE W3ADATMD,ONLY: W3NAUX, W3SETA #endif - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif - USE W3TIMEMD, ONLY : STME21 - USE W3ARRYMD, ONLY : INA2R, INA2I + USE W3TIMEMD, ONLY : STME21 + USE W3ARRYMD, ONLY : INA2R, INA2I #ifdef W3_T2 - USE W3ARRYMD, ONLY : PRTBLK + USE W3ARRYMD, ONLY : PRTBLK #endif #ifdef W3_T3 - USE W3ARRYMD, ONLY : PRTBLK + USE W3ARRYMD, ONLY : PRTBLK #endif - USE W3IOGRMD, ONLY: W3IOGR - USE W3FLDSMD, ONLY: W3FLDO, W3FLDP, W3FLDG, W3FLDD -!/ - USE W3GDATMD - USE W3GSRUMD - USE W3ODATMD, ONLY: NDSE, NDST, NDSO, FNMPRE -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NDSI, NDSM, NDSDAT, NDSTRC, NTRACE, & - IERR, IFLD, ITYPE, J, IX, IY, NFCOMP,& - TIME(2), NXI, NYI, NXJ(2), NYJ(2), & - NDSLL, IDLALL, IDFMLL, NDSF(2), & - IDLAF(2), IDFMF(2), TIME2(2), & - MXM, MYM, DATTYP, RECLDT, IDAT, & - NDAT, JJ, IS(4), JS(4) - INTEGER :: NXT, NYT - INTEGER :: ILAND = -999 + USE W3IOGRMD, ONLY: W3IOGR + USE W3FLDSMD, ONLY: W3FLDO, W3FLDP, W3FLDG, W3FLDD + !/ + USE W3GDATMD + USE W3GSRUMD + USE W3ODATMD, ONLY: NDSE, NDST, NDSO, FNMPRE + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NDSI, NDSM, NDSDAT, NDSTRC, NTRACE, & + IERR, IFLD, ITYPE, J, IX, IY, NFCOMP,& + TIME(2), NXI, NYI, NXJ(2), NYJ(2), & + NDSLL, IDLALL, IDFMLL, NDSF(2), & + IDLAF(2), IDFMF(2), TIME2(2), & + MXM, MYM, DATTYP, RECLDT, IDAT, & + NDAT, JJ, IS(4), JS(4) + INTEGER :: NXT, NYT + INTEGER :: ILAND = -999 #ifdef W3_O15 - INTEGER :: NDSTIME + INTEGER :: NDSTIME #endif - INTEGER, ALLOCATABLE :: IX21(:,:), IX22(:,:), & - IY21(:,:), IY22(:,:), & - JX21(:,:), JX22(:,:), & - JY21(:,:), JY22(:,:), MAPOVR(:,:) - INTEGER, ALLOCATABLE :: MASK(:,:) - TYPE(T_GSU) :: GSI + INTEGER, ALLOCATABLE :: IX21(:,:), IX22(:,:), & + IY21(:,:), IY22(:,:), & + JX21(:,:), JX22(:,:), & + JY21(:,:), JY22(:,:), MAPOVR(:,:) + INTEGER, ALLOCATABLE :: MASK(:,:) + TYPE(T_GSU) :: GSI #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T2 - INTEGER :: IXP0, IXPN, IXPWDT = 60 + INTEGER :: IXP0, IXPN, IXPWDT = 60 #endif #ifdef W3_T3 - INTEGER :: IX0, IXN, IXWDT = 60 - INTEGER, ALLOCATABLE :: MAPOUT(:,:) + INTEGER :: IX0, IXN, IXWDT = 60 + INTEGER, ALLOCATABLE :: MAPOUT(:,:) #endif - REAL :: X0I, XNI, Y0I, YNI, SXI, SYI, & - X, Y, FACTOR, EFAC, NODATA, RW(4) - REAL :: ACC = 0.05 - REAL, ALLOCATABLE :: RD11(:,:), RD21(:,:), & - RD12(:,:), RD22(:,:), & - XD11(:,:), XD21(:,:), & - XD12(:,:), XD22(:,:), & - FX(:,:), FY(:,:), FA(:,:), & - A1(:,:), A2(:,:), A3(:,:) - REAL, POINTER :: ALA(:,:), ALO(:,:) - REAL, ALLOCATABLE :: XC(:,:), YC(:,:), AC(:,:), DATA(:,:) - LOGICAL :: INGRID - LOGICAL :: FLSTAB, FLBERG, CLO(2), FLTIME, FLHDR - INTEGER :: ICLO + REAL :: X0I, XNI, Y0I, YNI, SXI, SYI, & + X, Y, FACTOR, EFAC, NODATA, RW(4) + REAL :: ACC = 0.05 + REAL, ALLOCATABLE :: RD11(:,:), RD21(:,:), & + RD12(:,:), RD22(:,:), & + XD11(:,:), XD21(:,:), & + XD12(:,:), XD22(:,:), & + FX(:,:), FY(:,:), FA(:,:), & + A1(:,:), A2(:,:), A3(:,:) + REAL, POINTER :: ALA(:,:), ALO(:,:) + REAL, ALLOCATABLE :: XC(:,:), YC(:,:), AC(:,:), DATA(:,:) + LOGICAL :: INGRID + LOGICAL :: FLSTAB, FLBERG, CLO(2), FLTIME, FLHDR + INTEGER :: ICLO #ifdef W3_T - LOGICAL :: FLMOD + LOGICAL :: FLMOD #endif - CHARACTER :: COMSTR*1, IDFLD*3, IDTYPE*2, & - IDTIME*23, FROMLL*4, FORMLL*16, & - NAMELL*65, FROMF*4, NAMEF*65 - CHARACTER(LEN=12) :: IDSTR1(-7:7) - CHARACTER(LEN=15) :: IDSTR3(3) - CHARACTER(LEN=32) :: FORMT(2), FORMF(2) - CHARACTER(LEN=20) :: IDSTR2(5) - CHARACTER(LEN=13) :: TSTR, IDSTR = 'WAVEWATCH III' - CHARACTER(LEN=3) :: TSFLD - INTEGER :: GTYPEDUM = 0 -! - EQUIVALENCE ( NXI , NXJ(1) ) , ( NYI , NYJ(1) ) -!/ -!/ ------------------------------------------------------------------- / -!/ -! notes: Is it possible to combine ice parameters into one group, -! similar to the way 1D spectra are in one group? - DATA IDSTR1 / 'ice param. 1' , 'ice param. 2' , & - 'ice param. 3' , 'ice param. 4' , & - 'ice param. 5' , 'mud density ' , & - 'mud thkness ' , 'mud viscos. ' , & - 'ice ' , 'water levels' , & - 'winds ' , 'currents ' , & - 'data ' , 'momentum ' , & - 'air density ' / - DATA IDSTR2 / 'pre-processed file ' , 'long.-lat. grid ' , & - 'grid from file (1) ' , 'grid from file (2) ' , & - 'data (assimilation) ' / - DATA IDSTR3 / 'mean parameters', '1D spectra ', & - '2D spectra ' / - NULLIFY ( ALA, ALO ) -! + CHARACTER :: COMSTR*1, IDFLD*3, IDTYPE*2, & + IDTIME*23, FROMLL*4, FORMLL*16, & + NAMELL*65, FROMF*4, NAMEF*65 + CHARACTER(LEN=12) :: IDSTR1(-7:7) + CHARACTER(LEN=15) :: IDSTR3(3) + CHARACTER(LEN=32) :: FORMT(2), FORMF(2) + CHARACTER(LEN=20) :: IDSTR2(5) + CHARACTER(LEN=13) :: TSTR, IDSTR = 'WAVEWATCH III' + CHARACTER(LEN=3) :: TSFLD + INTEGER :: GTYPEDUM = 0 + ! + EQUIVALENCE ( NXI , NXJ(1) ) , ( NYI , NYJ(1) ) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! notes: Is it possible to combine ice parameters into one group, + ! similar to the way 1D spectra are in one group? + DATA IDSTR1 / 'ice param. 1' , 'ice param. 2' , & + 'ice param. 3' , 'ice param. 4' , & + 'ice param. 5' , 'mud density ' , & + 'mud thkness ' , 'mud viscos. ' , & + 'ice ' , 'water levels' , & + 'winds ' , 'currents ' , & + 'data ' , 'momentum ' , & + 'air density ' / + DATA IDSTR2 / 'pre-processed file ' , 'long.-lat. grid ' , & + 'grid from file (1) ' , 'grid from file (2) ' , & + 'data (assimilation) ' / + DATA IDSTR3 / 'mean parameters', '1D spectra ', & + '2D spectra ' / + NULLIFY ( ALA, ALO ) + ! #ifdef W3_NCO -! CALL W3TAGB('WAVEPREP',1998,0007,0050,'NP21 ') + ! CALL W3TAGB('WAVEPREP',1998,0007,0050,'NP21 ') #endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1.a Set number of models -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1.a Set number of models + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) #ifdef W3_NL1 - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) #endif - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! -! 1.b IO set-up. -! - NDSI = 10 - NDSO = 6 - NDSE = 6 - NDST = 6 - NDSM = 11 - NDSDAT = 12 + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + ! 1.b IO set-up. + ! + NDSI = 10 + NDSO = 6 + NDSE = 6 + NDST = 6 + NDSM = 11 + NDSDAT = 12 #ifdef W3_O15 - NDSTIME = 13 + NDSTIME = 13 #endif -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_NCO -! -! Redo according to NCO -! - NDSI = 11 - NDSO = 6 - NDSE = NDSO - NDST = NDSO - NDSM = 12 - NDSDAT = 51 - NDSTRC = NDSO + ! + ! Redo according to NCO + ! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSDAT = 51 + NDSTRC = NDSO #endif -! -! 1.c Print header -! - WRITE (NDSO,900) + ! + ! 1.c Print header + ! + WRITE (NDSO,900) #ifdef W3_S - CALL STRACE (IENT, 'W3PREP') + CALL STRACE (IENT, 'W3PREP') #endif -! - J = LEN_TRIM(FNMPRE) - OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_prep.inp',STATUS='OLD', & - ERR=800,IOSTAT=IERR) - REWIND (NDSI) - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - WRITE (NDSO,902) GNAME - ALLOCATE ( IX21(NX,NY), IX22(NX,NY), IY21(NX,NY), IY22(NX,NY), & - JX21(NX,NY), JX22(NX,NY), JY21(NX,NY), JY22(NX,NY), & - MAPOVR(NX,NY) ) - ALLOCATE ( RD11(NX,NY), RD21(NX,NY), RD12(NX,NY), RD22(NX,NY), & - XD11(NX,NY), XD21(NX,NY), XD12(NX,NY), XD22(NX,NY), & - FX(NX,NY), FY(NX,NY), FA(NX,NY), & - A1(NX,NY), A2(NX,NY), A3(NX,NY) ) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3.a Read types from input file. -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDFLD, IDTYPE, FLTIME, & - FLHDR -! -! 3.b Check types. -! - FLSTAB = IDFLD .EQ. 'WNS' - FLBERG = IDFLD .EQ. 'ISI' - IF ( IDFLD.EQ.'IC1' ) THEN - IFLD = -7 - ELSE IF ( IDFLD.EQ.'IC2' ) THEN - IFLD = -6 - ELSE IF ( IDFLD.EQ.'IC3' ) THEN - IFLD = -5 - ELSE IF ( IDFLD.EQ.'IC4' ) THEN - IFLD = -4 - ELSE IF ( IDFLD.EQ.'IC5' ) THEN - IFLD = -3 - ELSE IF ( IDFLD.EQ.'MDN' ) THEN - IFLD = -2 - ELSE IF ( IDFLD.EQ.'MTH' ) THEN - IFLD = -1 - ELSE IF ( IDFLD.EQ.'MVS' ) THEN - IFLD = 0 - ELSE IF ( IDFLD.EQ.'ICE' .OR. FLBERG ) THEN - IFLD = 1 - ELSE IF ( IDFLD.EQ.'LEV' ) THEN - IFLD = 2 - ELSE IF ( IDFLD.EQ.'WND' .OR. FLSTAB ) THEN - IFLD = 3 - ELSE IF ( IDFLD.EQ.'CUR' ) THEN - IFLD = 4 - ELSE IF ( IDFLD.EQ.'DAT' ) THEN - IFLD = 5 - ELSE IF ( IDFLD.EQ.'TAU' ) THEN - IFLD = 6 - ELSE IF ( IDFLD.EQ.'RHO' ) THEN - IFLD = 7 - ELSE - WRITE (NDSE,1030) IDFLD - CALL EXTCDE ( 1 ) - END IF -! - NFCOMP = 1 - IF (IDFLD.EQ.'DAT') THEN - ITYPE = 5 - ELSE IF (IDTYPE.EQ.'AI') THEN - ITYPE = 1 - ELSE IF (IDTYPE.EQ.'LL') THEN - ITYPE = 2 - ELSE IF (IDTYPE.EQ.'F1') THEN - ITYPE = 3 - ELSE IF (IDTYPE.EQ.'F2') THEN - ITYPE = 4 - NFCOMP = 2 - ELSE - WRITE (NDSE,1031) IDTYPE - CALL EXTCDE ( 2 ) - END IF -! + ! + J = LEN_TRIM(FNMPRE) + OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_prep.inp',STATUS='OLD', & + ERR=800,IOSTAT=IERR) + REWIND (NDSI) + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + WRITE (NDSO,902) GNAME + ALLOCATE ( IX21(NX,NY), IX22(NX,NY), IY21(NX,NY), IY22(NX,NY), & + JX21(NX,NY), JX22(NX,NY), JY21(NX,NY), JY22(NX,NY), & + MAPOVR(NX,NY) ) + ALLOCATE ( RD11(NX,NY), RD21(NX,NY), RD12(NX,NY), RD22(NX,NY), & + XD11(NX,NY), XD21(NX,NY), XD12(NX,NY), XD22(NX,NY), & + FX(NX,NY), FY(NX,NY), FA(NX,NY), & + A1(NX,NY), A2(NX,NY), A3(NX,NY) ) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3.a Read types from input file. + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDFLD, IDTYPE, FLTIME, & + FLHDR + ! + ! 3.b Check types. + ! + FLSTAB = IDFLD .EQ. 'WNS' + FLBERG = IDFLD .EQ. 'ISI' + IF ( IDFLD.EQ.'IC1' ) THEN + IFLD = -7 + ELSE IF ( IDFLD.EQ.'IC2' ) THEN + IFLD = -6 + ELSE IF ( IDFLD.EQ.'IC3' ) THEN + IFLD = -5 + ELSE IF ( IDFLD.EQ.'IC4' ) THEN + IFLD = -4 + ELSE IF ( IDFLD.EQ.'IC5' ) THEN + IFLD = -3 + ELSE IF ( IDFLD.EQ.'MDN' ) THEN + IFLD = -2 + ELSE IF ( IDFLD.EQ.'MTH' ) THEN + IFLD = -1 + ELSE IF ( IDFLD.EQ.'MVS' ) THEN + IFLD = 0 + ELSE IF ( IDFLD.EQ.'ICE' .OR. FLBERG ) THEN + IFLD = 1 + ELSE IF ( IDFLD.EQ.'LEV' ) THEN + IFLD = 2 + ELSE IF ( IDFLD.EQ.'WND' .OR. FLSTAB ) THEN + IFLD = 3 + ELSE IF ( IDFLD.EQ.'CUR' ) THEN + IFLD = 4 + ELSE IF ( IDFLD.EQ.'DAT' ) THEN + IFLD = 5 + ELSE IF ( IDFLD.EQ.'TAU' ) THEN + IFLD = 6 + ELSE IF ( IDFLD.EQ.'RHO' ) THEN + IFLD = 7 + ELSE + WRITE (NDSE,1030) IDFLD + CALL EXTCDE ( 1 ) + END IF + ! + NFCOMP = 1 + IF (IDFLD.EQ.'DAT') THEN + ITYPE = 5 + ELSE IF (IDTYPE.EQ.'AI') THEN + ITYPE = 1 + ELSE IF (IDTYPE.EQ.'LL') THEN + ITYPE = 2 + ELSE IF (IDTYPE.EQ.'F1') THEN + ITYPE = 3 + ELSE IF (IDTYPE.EQ.'F2') THEN + ITYPE = 4 + NFCOMP = 2 + ELSE + WRITE (NDSE,1031) IDTYPE + CALL EXTCDE ( 2 ) + END IF + ! #ifdef W3_T - IF (ITYPE.NE.1 .AND. ITYPE.NE.5) WRITE (NDST,9000) ACC + IF (ITYPE.NE.1 .AND. ITYPE.NE.5) WRITE (NDST,9000) ACC #endif -! - WRITE (NDSO,930) IDSTR1(IFLD), IDSTR2(ITYPE) - IF ( ITYPE.NE.1 ) THEN + ! + WRITE (NDSO,930) IDSTR1(IFLD), IDSTR2(ITYPE) + IF ( ITYPE.NE.1 ) THEN #ifdef W3_WNT0 - IF (IFLD.EQ.3) WRITE (NDSO,1930) + IF (IFLD.EQ.3) WRITE (NDSO,1930) #endif #ifdef W3_WNT1 - IF (IFLD.EQ.3) WRITE (NDSO,1930) + IF (IFLD.EQ.3) WRITE (NDSO,1930) #endif #ifdef W3_WNT2 - IF (IFLD.EQ.3) WRITE (NDSO,2930) + IF (IFLD.EQ.3) WRITE (NDSO,2930) #endif #ifdef W3_CRT1 - IF (IFLD.EQ.4) WRITE (NDSO,1930) + IF (IFLD.EQ.4) WRITE (NDSO,1930) #endif #ifdef W3_CRT2 - IF (IFLD.EQ.4) WRITE (NDSO,2930) + IF (IFLD.EQ.4) WRITE (NDSO,2930) #endif #ifdef W3_WNT0 - IF (IFLD.EQ.6) WRITE (NDSO,1930) + IF (IFLD.EQ.6) WRITE (NDSO,1930) #endif #ifdef W3_WNT1 - IF (IFLD.EQ.6) WRITE (NDSO,1930) + IF (IFLD.EQ.6) WRITE (NDSO,1930) #endif #ifdef W3_WNT2 - IF (IFLD.EQ.6) WRITE (NDSO,2930) + IF (IFLD.EQ.6) WRITE (NDSO,2930) #endif - END IF - IF ( FLBERG ) WRITE (NDSO,938) - IF ( FLSTAB ) WRITE (NDSO,939) - IF (ITYPE.EQ.4 .AND. IFLD.GT.2) THEN - WRITE (NDSE,1032) - CALL EXTCDE ( 3 ) - END IF -! -! 3.c Additional input for format types and time -! ... time -! - IF (.NOT. FLTIME) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) TIME - IF (TIME(1).LT.10000000) THEN - WRITE (NDSE,1035) TIME - CALL EXTCDE ( 4 ) - END IF - CALL STME21 ( TIME , IDTIME ) - WRITE (NDSO,931) IDTIME - END IF -! - J = 1 - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF -! -! ... type 1 -! - IF (ITYPE.EQ.1) THEN -! - NXI = NX - NYI = NY - ALLOCATE ( MASK(NXI,NYI) ) - MASK = 1 - IF(GTYPE .EQ. UNGTYPE) THEN -! -! X0, Y0 are the coordinates of the lower-left point in mesh -! - RW(1) = FACTOR*X0 ; RW(2) = FACTOR*MAXX - RW(3) = FACTOR*Y0 ; RW(4) = FACTOR*MAXY - ELSE - RW(1) = FACTOR*XGRD(1,1) ; RW(2) = FACTOR*XGRD(NY,NX) - RW(3) = FACTOR*YGRD(1,1) ; RW(4) = FACTOR*YGRD(NY,NX) - END IF - WRITE (NDSO,932) NXI, NYI - IF ( FLAGLL ) THEN - WRITE (NDSO,933) RW(1),RW(2),RW(3),RW(4) - ELSE - WRITE (NDSO,733) RW(1),RW(2),RW(3),RW(4) - END IF -! -! ... type 2 -! - ELSE IF (ITYPE.EQ.2) THEN -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & - X0I, XNI, NXI, Y0I, YNI, NYI - IF (NXI.LT.2 .OR. NYI.LT.2) THEN - WRITE (NDSE,1036) NXI, NYI - CALL EXTCDE ( 5 ) - END IF - ALLOCATE ( MASK(NXI,NYI) ) - MASK = 1 - WRITE (NDSO,932) NXI, NYI + END IF + IF ( FLBERG ) WRITE (NDSO,938) + IF ( FLSTAB ) WRITE (NDSO,939) + IF (ITYPE.EQ.4 .AND. IFLD.GT.2) THEN + WRITE (NDSE,1032) + CALL EXTCDE ( 3 ) + END IF + ! + ! 3.c Additional input for format types and time + ! ... time + ! + IF (.NOT. FLTIME) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) TIME + IF (TIME(1).LT.10000000) THEN + WRITE (NDSE,1035) TIME + CALL EXTCDE ( 4 ) + END IF + CALL STME21 ( TIME , IDTIME ) + WRITE (NDSO,931) IDTIME + END IF + ! + J = 1 + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + ! + ! ... type 1 + ! + IF (ITYPE.EQ.1) THEN + ! + NXI = NX + NYI = NY + ALLOCATE ( MASK(NXI,NYI) ) + MASK = 1 + IF(GTYPE .EQ. UNGTYPE) THEN + ! + ! X0, Y0 are the coordinates of the lower-left point in mesh + ! + RW(1) = FACTOR*X0 ; RW(2) = FACTOR*MAXX + RW(3) = FACTOR*Y0 ; RW(4) = FACTOR*MAXY + ELSE + RW(1) = FACTOR*XGRD(1,1) ; RW(2) = FACTOR*XGRD(NY,NX) + RW(3) = FACTOR*YGRD(1,1) ; RW(4) = FACTOR*YGRD(NY,NX) + END IF + WRITE (NDSO,932) NXI, NYI + IF ( FLAGLL ) THEN + WRITE (NDSO,933) RW(1),RW(2),RW(3),RW(4) + ELSE + WRITE (NDSO,733) RW(1),RW(2),RW(3),RW(4) + END IF + ! + ! ... type 2 + ! + ELSE IF (ITYPE.EQ.2) THEN + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & + X0I, XNI, NXI, Y0I, YNI, NYI + IF (NXI.LT.2 .OR. NYI.LT.2) THEN + WRITE (NDSE,1036) NXI, NYI + CALL EXTCDE ( 5 ) + END IF + ALLOCATE ( MASK(NXI,NYI) ) + MASK = 1 + WRITE (NDSO,932) NXI, NYI - IF ( FLAGLL ) THEN - WRITE (NDSO,933) FACTOR*X0I, FACTOR*XNI, & - FACTOR*Y0I, FACTOR*YNI - ELSE - WRITE (NDSO,733) FACTOR*X0I, FACTOR*XNI, & - FACTOR*Y0I, FACTOR*YNI - END IF -! -! ... type 5 -! - ELSE IF (ITYPE.EQ.5) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & - DATTYP, RECLDT, NODATA - IF (DATTYP.LT.0 .OR. DATTYP.GT.2) THEN - WRITE (NDSE,1033) DATTYP - CALL EXTCDE ( 6 ) - END IF - IF (RECLDT.LE.0) THEN - WRITE (NDSE,1034) RECLDT - CALL EXTCDE ( 7 ) - END IF - WRITE (NDSO,934) IDSTR3(DATTYP+1), RECLDT, NODATA - WRITE (IDFLD,935) DATTYP - DEALLOCATE ( IX21, IX22, IY21, IY22, JX21, JX22, JY21, JY22, & - MAPOVR ) - DEALLOCATE ( RD11, RD21, RD12, RD22, XD11, XD21, XD12, XD22, & - FX, FY, FA, A1, A2, A3 ) -! -! ... types 3 and 4 ... in preprocessing loop .... -! - END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4 Prepare interpolation. -! - WRITE (NDSO,940) -! - IF (ITYPE.NE.1 .AND. ITYPE.NE.5) THEN -! -! 4.a Longitude - latitude grid -! - IF (ITYPE.EQ.2) THEN - WRITE (NDSO,941) -! -! ... setup coordinates -! - SXI = (XNI-X0I)/REAL(NXI-1) - SYI = (YNI-Y0I)/REAL(NYI-1) - ICLO = ICLOSE_NONE - IF ( FLAGLL ) THEN - IF ( ABS(ABS(REAL(NXI)*SXI)-360.) .LT. 0.1*ABS(SXI) ) & - ICLO = ICLOSE_SMPL - END IF - IF ( ASSOCIATED(ALA) ) THEN - DEALLOCATE ( ALA, ALO ) - NULLIFY ( ALA, ALO ) - END IF - ALLOCATE ( ALA(NXI,NYI), ALO(NXI,NYI) ) - DO IY=1, NYI - DO IX=1, NXI - ALO(IX,IY) = X0I + REAL(IX-1)*SXI - ALA(IX,IY) = Y0I + REAL(IY-1)*SYI - END DO - END DO -! -! ... create grid search utility -! - GSI = W3GSUC( .TRUE., FLAGLL, ICLO, ALO, ALA ) -! -! ... construct interpolation data -! + IF ( FLAGLL ) THEN + WRITE (NDSO,933) FACTOR*X0I, FACTOR*XNI, & + FACTOR*Y0I, FACTOR*YNI + ELSE + WRITE (NDSO,733) FACTOR*X0I, FACTOR*XNI, & + FACTOR*Y0I, FACTOR*YNI + END IF + ! + ! ... type 5 + ! + ELSE IF (ITYPE.EQ.5) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & + DATTYP, RECLDT, NODATA + IF (DATTYP.LT.0 .OR. DATTYP.GT.2) THEN + WRITE (NDSE,1033) DATTYP + CALL EXTCDE ( 6 ) + END IF + IF (RECLDT.LE.0) THEN + WRITE (NDSE,1034) RECLDT + CALL EXTCDE ( 7 ) + END IF + WRITE (NDSO,934) IDSTR3(DATTYP+1), RECLDT, NODATA + WRITE (IDFLD,935) DATTYP + DEALLOCATE ( IX21, IX22, IY21, IY22, JX21, JX22, JY21, JY22, & + MAPOVR ) + DEALLOCATE ( RD11, RD21, RD12, RD22, XD11, XD21, XD12, XD22, & + FX, FY, FA, A1, A2, A3 ) + ! + ! ... types 3 and 4 ... in preprocessing loop .... + ! + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4 Prepare interpolation. + ! + WRITE (NDSO,940) + ! + IF (ITYPE.NE.1 .AND. ITYPE.NE.5) THEN + ! + ! 4.a Longitude - latitude grid + ! + IF (ITYPE.EQ.2) THEN + WRITE (NDSO,941) + ! + ! ... setup coordinates + ! + SXI = (XNI-X0I)/REAL(NXI-1) + SYI = (YNI-Y0I)/REAL(NYI-1) + ICLO = ICLOSE_NONE + IF ( FLAGLL ) THEN + IF ( ABS(ABS(REAL(NXI)*SXI)-360.) .LT. 0.1*ABS(SXI) ) & + ICLO = ICLOSE_SMPL + END IF + IF ( ASSOCIATED(ALA) ) THEN + DEALLOCATE ( ALA, ALO ) + NULLIFY ( ALA, ALO ) + END IF + ALLOCATE ( ALA(NXI,NYI), ALO(NXI,NYI) ) + DO IY=1, NYI + DO IX=1, NXI + ALO(IX,IY) = X0I + REAL(IX-1)*SXI + ALA(IX,IY) = Y0I + REAL(IY-1)*SYI + END DO + END DO + ! + ! ... create grid search utility + ! + GSI = W3GSUC( .TRUE., FLAGLL, ICLO, ALO, ALA ) + ! + ! ... construct interpolation data + ! #ifdef W3_T1 - WRITE (NDST,9045) + WRITE (NDST,9045) #endif - IF (GTYPE .NE. UNGTYPE) THEN - DO IY=1,NY - DO IX=1,NX - INGRID = W3GRMP( GSI, REAL(XGRD(IY,IX)), REAL(YGRD(IY,IX)), & - IS, JS, RW ) + IF (GTYPE .NE. UNGTYPE) THEN + DO IY=1,NY + DO IX=1,NX + INGRID = W3GRMP( GSI, REAL(XGRD(IY,IX)), REAL(YGRD(IY,IX)), & + IS, JS, RW ) - IF ( .NOT.INGRID ) THEN + IF ( .NOT.INGRID ) THEN -! Notes: It would make sense to give this warning for only cases where -! the grid point is *not* masked. Obviously we don't care if -! a masked grid point is not given winds, etc. + ! Notes: It would make sense to give this warning for only cases where + ! the grid point is *not* masked. Obviously we don't care if + ! a masked grid point is not given winds, etc. - WRITE(NDSO,1042) IX, IY, XGRD(IY,IX), YGRD(IY,IX) + WRITE(NDSO,1042) IX, IY, XGRD(IY,IX), YGRD(IY,IX) -! Notes: We need to set these variables, even if we never intend to use them. -!...........Especially in the case of IX?? IY??, we cannot leave them unset, -!...........since they will be used as array indices later. + ! Notes: We need to set these variables, even if we never intend to use them. + !...........Especially in the case of IX?? IY??, we cannot leave them unset, + !...........since they will be used as array indices later. - IX21(IX,IY) = 1 - IX22(IX,IY) = 1 - IY21(IX,IY) = 1 - IY22(IX,IY) = 1 - RD11(IX,IY) = 0.0 - RD21(IX,IY) = 0.0 - RD12(IX,IY) = 0.0 - RD22(IX,IY) = 0.0 + IX21(IX,IY) = 1 + IX22(IX,IY) = 1 + IY21(IX,IY) = 1 + IY22(IX,IY) = 1 + RD11(IX,IY) = 0.0 + RD21(IX,IY) = 0.0 + RD12(IX,IY) = 0.0 + RD22(IX,IY) = 0.0 - CYCLE - END IF + CYCLE + END IF - IX21(IX,IY) = IS(1) - IX22(IX,IY) = IS(2) - IY21(IX,IY) = JS(1) - IY22(IX,IY) = JS(4) - RD11(IX,IY) = RW(1) - RD21(IX,IY) = RW(2) - RD12(IX,IY) = RW(4) - RD22(IX,IY) = RW(3) + IX21(IX,IY) = IS(1) + IX22(IX,IY) = IS(2) + IY21(IX,IY) = JS(1) + IY22(IX,IY) = JS(4) + RD11(IX,IY) = RW(1) + RD21(IX,IY) = RW(2) + RD12(IX,IY) = RW(4) + RD22(IX,IY) = RW(3) #ifdef W3_T1 - WRITE (NDST,9046) IX, IY, & - IX21(IX,IY),IX22(IX,IY),IY21(IX,IY),IY22(IX,IY), & - RD11(IX,IY),RD12(IX,IY),RD21(IX,IY),RD22(IX,IY) + WRITE (NDST,9046) IX, IY, & + IX21(IX,IY),IX22(IX,IY),IY21(IX,IY),IY22(IX,IY), & + RD11(IX,IY),RD12(IX,IY),RD21(IX,IY),RD22(IX,IY) #endif - END DO - END DO - ELSE - DO IX=1, NX - X = XGRD(1,IX) - Y = YGRD(1,IX) - - IX21(IX,1) = 1 + INT(MOD(360.+(X-X0I),360.)/SXI) -! -! Manages the simple closure of the grid -! - IF (ICLO.EQ.ICLOSE_NONE) THEN - IX21(IX,1) = MAX ( 1 , MIN(IX21(IX,1),NXI-1) ) - IX22(IX,1) = IX21(IX,1) + 1 - ELSE - IX21(IX,1) = MAX ( 1 , MIN(IX21(IX,1),NXI) ) - IX22(IX,1) = MOD(IX21(IX,1),NXI)+1 - END IF - IY21(IX,1) = 1 + INT((Y-Y0I)/SYI) - IY21(IX,1) = MAX ( 1 , MIN(IY21(IX,1),NYI-1) ) - IY22(IX,1) = IY21(IX,1) + 1 -! - RW(1) = MOD(360.+(X-X0I),360.)/SXI - REAL(IX21(IX,1)-1) - RW(2) = (Y-Y0I)/SYI - REAL(IY21(IX,1)-1) -! - IF (IY21(IX,1).EQ.1 .AND. RW(2).LT.ACC) THEN - IF (RW(2).LT.-ACC) THEN - WRITE (NDSO,1044) Y - ELSE IF (RW(2).LT.0.) THEN - RW(2) = 0. + END DO + END DO + ELSE + DO IX=1, NX + X = XGRD(1,IX) + Y = YGRD(1,IX) + + IX21(IX,1) = 1 + INT(MOD(360.+(X-X0I),360.)/SXI) + ! + ! Manages the simple closure of the grid + ! + IF (ICLO.EQ.ICLOSE_NONE) THEN + IX21(IX,1) = MAX ( 1 , MIN(IX21(IX,1),NXI-1) ) + IX22(IX,1) = IX21(IX,1) + 1 + ELSE + IX21(IX,1) = MAX ( 1 , MIN(IX21(IX,1),NXI) ) + IX22(IX,1) = MOD(IX21(IX,1),NXI)+1 + END IF + IY21(IX,1) = 1 + INT((Y-Y0I)/SYI) + IY21(IX,1) = MAX ( 1 , MIN(IY21(IX,1),NYI-1) ) + IY22(IX,1) = IY21(IX,1) + 1 + ! + RW(1) = MOD(360.+(X-X0I),360.)/SXI - REAL(IX21(IX,1)-1) + RW(2) = (Y-Y0I)/SYI - REAL(IY21(IX,1)-1) + ! + IF (IY21(IX,1).EQ.1 .AND. RW(2).LT.ACC) THEN + IF (RW(2).LT.-ACC) THEN + WRITE (NDSO,1044) Y + ELSE IF (RW(2).LT.0.) THEN + RW(2) = 0. #ifdef W3_T - FLMOD = .TRUE. + FLMOD = .TRUE. #endif - END IF - END IF -! - IF (IY21(IX,1).EQ.NYI .AND. RW(2).GT.1.-ACC) THEN - IF (RW(2).GT.1.+ACC) THEN - WRITE (NDSO,1044) Y - ELSE IF (RW(2).GT.1.) THEN - RW(2) = 1. + END IF + END IF + ! + IF (IY21(IX,1).EQ.NYI .AND. RW(2).GT.1.-ACC) THEN + IF (RW(2).GT.1.+ACC) THEN + WRITE (NDSO,1044) Y + ELSE IF (RW(2).GT.1.) THEN + RW(2) = 1. #ifdef W3_T - FLMOD = .TRUE. + FLMOD = .TRUE. #endif - END IF - END IF -! - EFAC = SQRT ( MAX(0.,ABS(RW(1)-0.5)-0.5)**2 + & - MAX(0.,ABS(RW(2)-0.5)-0.5)**2 ) - EFAC = 1. / ( 1. + 0.25*EFAC**2 ) - + END IF + END IF + ! + EFAC = SQRT ( MAX(0.,ABS(RW(1)-0.5)-0.5)**2 + & + MAX(0.,ABS(RW(2)-0.5)-0.5)**2 ) + EFAC = 1. / ( 1. + 0.25*EFAC**2 ) - RD11(IX,1) = EFAC * (1.-RW(1)) * (1.-RW(2)) - RD21(IX,1) = EFAC * RW(1) * (1.-RW(2)) - RD12(IX,1) = EFAC * (1.-RW(1)) * RW(2) - RD22(IX,1) = EFAC * RW(1) * RW(2) - END DO - END IF ! GTYPE .NE. UNGTYPE -! - CALL W3GSUD( GSI ) - DEALLOCATE ( ALA, ALO ) - NULLIFY ( ALA, ALO ) -! -! 4.b Grid(s) from file -! - ELSE - WRITE (NDSO,942) -! -! ... prepare overlay map -! - DO IY=1, NY - DO IX=1, NX - IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN - MAPOVR(IX,IY) = ILAND - ELSE - MAPOVR(IX,IY) = 0 - END IF - END DO - END DO -! -! ... loop over fields -! - DO J=1, NFCOMP -! - WRITE (NDSO,943) J -! -! ... file info lat-long file -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & - NXJ(J), NYJ(J), CLO(J) - IF (NXJ(J).LT.2 .OR. NYJ(J).LT.2) THEN - WRITE (NDSE,1036) NXJ(J), NYJ(J) - CALL EXTCDE ( 10 ) - END IF - IF ( ALLOCATED(MASK) ) DEALLOCATE (MASK) - ALLOCATE ( MASK(NXJ(J),NYJ(J)) ) - MASK = 1 - WRITE (NDSO,944) NXJ(J), NYJ(J), CLO(J) -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & - FROMLL, IDLALL, IDFMLL, FORMLL - IF (IDLALL.LT.1 .OR. IDLALL.GT.4) IDLALL = 1 - IF (IDFMLL.LT.1 .OR. IDFMLL.GT.3) IDFMLL = 1 - WRITE (NDSO,945) IDLALL, IDFMLL - IF (IDFMLL.EQ.2) WRITE (NDSO,946) FORMLL -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL -#ifdef W3_NCO - NDSLL = 20 + NFCOMP -#endif - WRITE (NDSO,947) NDSLL - IF (FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL - IF (NDSLL.EQ.NDSI) THEN - WRITE (NDSE,10381) - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - ELSE -! -! ... open lat-long file -! - IF ( IDFMLL .EQ. 3 ) THEN - IF (FROMLL.EQ.'NAME') THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & - form='UNFORMATTED', convert=file_endian,STATUS='OLD', & - ERR=845,IOSTAT=IERR) - ELSE - OPEN (NDSLL, form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=845,IOSTAT=IERR) - END IF - ELSE - IF (FROMLL.EQ.'NAME') THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & - STATUS='OLD',ERR=845,IOSTAT=IERR) - ELSE - OPEN (NDSLL, & - STATUS='OLD',ERR=845,IOSTAT=IERR) - END IF - END IF -! - END IF -! -! ... read lat-lon data -! - IF ( ASSOCIATED(ALA) ) THEN - DEALLOCATE ( ALA, ALO ) - NULLIFY ( ALA, ALO ) - END IF - ALLOCATE ( ALA(NXJ(J),NYJ(J)), ALO(NXJ(J),NYJ(J)) ) - CALL INA2R (ALA, NXJ(J), NYJ(J), 1, NXJ(J), 1, NYJ(J),& - NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1., 0.) - CALL INA2R (ALO, NXJ(J), NYJ(J), 1, NXJ(J), 1, NYJ(J),& - NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1., 0.) - IF ( NDSLL .NE. NDSI ) CLOSE (NDSLL) -! -! ... file info mask file -! - WRITE (NDSO,949) -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & - FROMLL, IDLALL, IDFMLL, FORMLL - IF (IDLALL.LT.1 .OR. IDLALL.GT.4) IDLALL = 1 - IF (IDFMLL.LT.1 .OR. IDFMLL.GT.3) IDFMLL = 1 - WRITE (NDSO,945) IDLALL, IDFMLL - IF (IDFMLL.EQ.2) WRITE (NDSO,946) FORMLL -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL + + RD11(IX,1) = EFAC * (1.-RW(1)) * (1.-RW(2)) + RD21(IX,1) = EFAC * RW(1) * (1.-RW(2)) + RD12(IX,1) = EFAC * (1.-RW(1)) * RW(2) + RD22(IX,1) = EFAC * RW(1) * RW(2) + END DO + END IF ! GTYPE .NE. UNGTYPE + ! + CALL W3GSUD( GSI ) + DEALLOCATE ( ALA, ALO ) + NULLIFY ( ALA, ALO ) + ! + ! 4.b Grid(s) from file + ! + ELSE + WRITE (NDSO,942) + ! + ! ... prepare overlay map + ! + DO IY=1, NY + DO IX=1, NX + IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN + MAPOVR(IX,IY) = ILAND + ELSE + MAPOVR(IX,IY) = 0 + END IF + END DO + END DO + ! + ! ... loop over fields + ! + DO J=1, NFCOMP + ! + WRITE (NDSO,943) J + ! + ! ... file info lat-long file + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & + NXJ(J), NYJ(J), CLO(J) + IF (NXJ(J).LT.2 .OR. NYJ(J).LT.2) THEN + WRITE (NDSE,1036) NXJ(J), NYJ(J) + CALL EXTCDE ( 10 ) + END IF + IF ( ALLOCATED(MASK) ) DEALLOCATE (MASK) + ALLOCATE ( MASK(NXJ(J),NYJ(J)) ) + MASK = 1 + WRITE (NDSO,944) NXJ(J), NYJ(J), CLO(J) + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & + FROMLL, IDLALL, IDFMLL, FORMLL + IF (IDLALL.LT.1 .OR. IDLALL.GT.4) IDLALL = 1 + IF (IDFMLL.LT.1 .OR. IDFMLL.GT.3) IDFMLL = 1 + WRITE (NDSO,945) IDLALL, IDFMLL + IF (IDFMLL.EQ.2) WRITE (NDSO,946) FORMLL + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL #ifdef W3_NCO - NDSLL = 22 + NFCOMP + NDSLL = 20 + NFCOMP #endif - WRITE (NDSO,947) NDSLL - IF (FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL - WRITE (NDSO,*) ' ' - IF (NDSLL.EQ.NDSI) THEN - WRITE (NDSE,10382) - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - ELSE -! -! ... open mask file -! - IF ( IDFMLL .EQ. 3 ) THEN - IF (FROMLL.EQ.'NAME') THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & - form='UNFORMATTED', convert=file_endian,STATUS='OLD', & - ERR=846,IOSTAT=IERR) - ELSE - OPEN (NDSLL,form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=846,IOSTAT=IERR) - END IF - ELSE - IF (FROMLL.EQ.'NAME') THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & - STATUS='OLD',ERR=846,IOSTAT=IERR) - ELSE - OPEN (NDSLL, & - STATUS='OLD',ERR=846,IOSTAT=IERR) - END IF - END IF -! - END IF -! -! ... read mask data -! - CALL INA2I (MASK, NXJ(J), NYJ(J), 1,NXJ(J), 1,NYJ(J), & - NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1, 0) - IF ( NDSLL .NE. NDSI ) CLOSE (NDSLL) -! -#ifdef W3_T1a - WRITE (NDST,9050) - DO IY=1, NYJ(J) - DO IX=1,NXJ(J) - WRITE (NDST,9051) IX, IY, ALA(IX,IY), & - ALO(IX,IY), MASK(IX,IY) - END DO - END DO -#endif -! -! ... generate interpolation data -! - IF ( J .EQ. 1 ) THEN - CALL W3FLDP ( NDSO, NDST, NDSE, IERR, FLAGLL, & - NX, NY, NX, NY, REAL(YGRD), REAL(XGRD), MAPOVR, ILAND, & - NXJ(J), NYJ(J), NXJ(J), NYJ(J), CLO(J), ALA, ALO, & - MASK, RD11, RD21, RD12, RD22, IX21, IX22, IY21, & - IY22 ) - ELSE - CALL W3FLDP ( NDSO, NDST, NDSE, IERR, FLAGLL, & - NX, NY, NX, NY, REAL(YGRD), REAL(XGRD), MAPOVR, ILAND, & - NXJ(J), NYJ(J), NXJ(J), NYJ(J), CLO(J), ALA, ALO, & - MASK, XD11, XD21, XD12, XD22, JX21, JX22, JY21, & - JY22 ) - END IF -! - END DO -! -! ... average two fields ! -! - IF ( NFCOMP .EQ. 2) THEN - DO IX=1, NX - DO IY=1, NY - IF ( MAPOVR(IX,IY) .GE. 2) THEN - FACTOR = 1. / REAL(MAPOVR(IX,IY)) - RD11(IX,IY) = FACTOR * RD11(IX,IY) - RD12(IX,IY) = FACTOR * RD12(IX,IY) - RD21(IX,IY) = FACTOR * RD21(IX,IY) - RD22(IX,IY) = FACTOR * RD22(IX,IY) - XD11(IX,IY) = FACTOR * XD11(IX,IY) - XD12(IX,IY) = FACTOR * XD12(IX,IY) - XD21(IX,IY) = FACTOR * XD21(IX,IY) - XD22(IX,IY) = FACTOR * XD22(IX,IY) - END IF - END DO - END DO - END IF -! + WRITE (NDSO,947) NDSLL + IF (FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL + IF (NDSLL.EQ.NDSI) THEN + WRITE (NDSE,10381) + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ELSE + ! + ! ... open lat-long file + ! + IF ( IDFMLL .EQ. 3 ) THEN + IF (FROMLL.EQ.'NAME') THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & + form='UNFORMATTED', convert=file_endian,STATUS='OLD', & + ERR=845,IOSTAT=IERR) + ELSE + OPEN (NDSLL, form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=845,IOSTAT=IERR) END IF - END IF -! -! 4.c Input location and format -! - DO J=1, NFCOMP -! - IF ( ITYPE .GE. 5 ) THEN - WRITE (NDSO,960) ELSE - IF (ITYPE.LE.3) THEN - WRITE (NDSO,961) NXJ(J), NYJ(J) - ELSE - WRITE (NDSO,962) J, NXJ(J), NYJ(J) - END IF + IF (FROMLL.EQ.'NAME') THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & + STATUS='OLD',ERR=845,IOSTAT=IERR) + ELSE + OPEN (NDSLL, & + STATUS='OLD',ERR=845,IOSTAT=IERR) + END IF END IF -! + ! + END IF + ! + ! ... read lat-lon data + ! + IF ( ASSOCIATED(ALA) ) THEN + DEALLOCATE ( ALA, ALO ) + NULLIFY ( ALA, ALO ) + END IF + ALLOCATE ( ALA(NXJ(J),NYJ(J)), ALO(NXJ(J),NYJ(J)) ) + CALL INA2R (ALA, NXJ(J), NYJ(J), 1, NXJ(J), 1, NYJ(J),& + NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1., 0.) + CALL INA2R (ALO, NXJ(J), NYJ(J), 1, NXJ(J), 1, NYJ(J),& + NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1., 0.) + IF ( NDSLL .NE. NDSI ) CLOSE (NDSLL) + ! + ! ... file info mask file + ! + WRITE (NDSO,949) + ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & - FROMF, IDLAF(J), IDFMF(J), FORMT(J), FORMF(J) - IF (IDLAF(J).LT.1 .OR. IDLAF(J).GT.4) IDLAF(J) = 1 - IF (IDFMF(J).LT.1 .OR. IDFMF(J).GT.3) IDFMF(J) = 1 - IF ( ITYPE .NE. 5 ) WRITE (NDSO,963) IDLAF(J) - WRITE (NDSO,964) IDFMF(J) - IF (IDFMF(J).EQ.2) WRITE (NDSO,965) FORMT(J), FORMF(J) -! + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & + FROMLL, IDLALL, IDFMLL, FORMLL + IF (IDLALL.LT.1 .OR. IDLALL.GT.4) IDLALL = 1 + IF (IDFMLL.LT.1 .OR. IDFMLL.GT.3) IDFMLL = 1 + WRITE (NDSO,945) IDLALL, IDFMLL + IF (IDFMLL.EQ.2) WRITE (NDSO,946) FORMLL + ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSF(J), NAMEF + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL #ifdef W3_NCO - NDSF(J) = 24 + NFCOMP + NDSLL = 22 + NFCOMP #endif - WRITE (NDSO,966) NDSF(J) - IF (FROMF.EQ.'NAME') WRITE (NDSO,967) NAMEF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5 Prepare files -! 5.a Open input file -! - WRITE (NDSO,970) -! - IF ( IDFMF(J) .EQ. 3 ) THEN - IF (NDSF(J).EQ.NDSI) THEN - WRITE (NDSE,1051) NDSI - CALL EXTCDE ( 20 ) - ELSE - IF (FROMF.EQ.'NAME') THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSF(J),FILE=FNMPRE(:JJ)//NAMEF, & - form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=850, & - IOSTAT=IERR) - ELSE - OPEN (NDSF(J),form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=850,IOSTAT=IERR) - END IF -! -! Adding a check to see if input file is a WAVEWATCH III file -! (This check has only been added for binary wind files) -! - READ (NDSF(J),END=888,IOSTAT=IERR) TSTR, & - TSFLD, NXT, NYT - IF (IERR .EQ. 0 .AND. TSTR .EQ. IDSTR) THEN - IF (TSFLD .NE. IDFLD .OR. NXT .NE. NXI & - .OR. NYT .NE. NYI ) THEN - WRITE (NDSE,1052) TSFLD, NXT, NYT, IDFLD, & - NXI, NYI - CALL EXTCDE ( 21 ) - END IF - ELSE - REWIND(NDSF(J)) - END IF - END IF + WRITE (NDSO,947) NDSLL + IF (FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL + WRITE (NDSO,*) ' ' + IF (NDSLL.EQ.NDSI) THEN + WRITE (NDSE,10382) + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ELSE + ! + ! ... open mask file + ! + IF ( IDFMLL .EQ. 3 ) THEN + IF (FROMLL.EQ.'NAME') THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & + form='UNFORMATTED', convert=file_endian,STATUS='OLD', & + ERR=846,IOSTAT=IERR) + ELSE + OPEN (NDSLL,form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=846,IOSTAT=IERR) + END IF ELSE - IF (NDSF(J).EQ.NDSI) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - ELSE - IF (FROMF.EQ.'NAME') THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSF(J),FILE=FNMPRE(:JJ)//NAMEF, & - STATUS='OLD',ERR=850,IOSTAT=IERR) - ELSE - OPEN (NDSF(J),STATUS='OLD',ERR=850,IOSTAT=IERR) - END IF - END IF + IF (FROMLL.EQ.'NAME') THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & + STATUS='OLD',ERR=846,IOSTAT=IERR) + ELSE + OPEN (NDSLL, & + STATUS='OLD',ERR=846,IOSTAT=IERR) + END IF END IF -! + ! + END IF + ! + ! ... read mask data + ! + CALL INA2I (MASK, NXJ(J), NYJ(J), 1,NXJ(J), 1,NYJ(J), & + NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1, 0) + IF ( NDSLL .NE. NDSI ) CLOSE (NDSLL) + ! +#ifdef W3_T1a + WRITE (NDST,9050) + DO IY=1, NYJ(J) + DO IX=1,NXJ(J) + WRITE (NDST,9051) IX, IY, ALA(IX,IY), & + ALO(IX,IY), MASK(IX,IY) + END DO END DO -! - IF ( NFCOMP .EQ. 1 ) THEN - NXJ (2) = NXJ (1) - NYJ (2) = NYJ (1) - NDSF (2) = NDSF (1) - IDLAF(2) = IDLAF(1) - IDFMF(2) = IDFMF(1) - FORMT(2) = FORMT(1) - FORMF(2) = FORMF(1) +#endif + ! + ! ... generate interpolation data + ! + IF ( J .EQ. 1 ) THEN + CALL W3FLDP ( NDSO, NDST, NDSE, IERR, FLAGLL, & + NX, NY, NX, NY, REAL(YGRD), REAL(XGRD), MAPOVR, ILAND, & + NXJ(J), NYJ(J), NXJ(J), NYJ(J), CLO(J), ALA, ALO, & + MASK, RD11, RD21, RD12, RD22, IX21, IX22, IY21, & + IY22 ) + ELSE + CALL W3FLDP ( NDSO, NDST, NDSE, IERR, FLAGLL, & + NX, NY, NX, NY, REAL(YGRD), REAL(XGRD), MAPOVR, ILAND, & + NXJ(J), NYJ(J), NXJ(J), NYJ(J), CLO(J), ALA, ALO, & + MASK, XD11, XD21, XD12, XD22, JX21, JX22, JY21, & + JY22 ) END IF -! -! 5.b Open and prepare output file -! - WRITE (NDSO,971) - J = LEN_TRIM(FNMPRE) - IF ( ITYPE .LE. 4 ) THEN - CALL W3FLDO ( 'WRITE', IDFLD, NDSDAT, NDST, NDSE, & - NX, NY, GTYPE, IERR, FPRE=FNMPRE(:J), & - FHDR=FLHDR ) + ! + END DO + ! + ! ... average two fields ! + ! + IF ( NFCOMP .EQ. 2) THEN + DO IX=1, NX + DO IY=1, NY + IF ( MAPOVR(IX,IY) .GE. 2) THEN + FACTOR = 1. / REAL(MAPOVR(IX,IY)) + RD11(IX,IY) = FACTOR * RD11(IX,IY) + RD12(IX,IY) = FACTOR * RD12(IX,IY) + RD21(IX,IY) = FACTOR * RD21(IX,IY) + RD22(IX,IY) = FACTOR * RD22(IX,IY) + XD11(IX,IY) = FACTOR * XD11(IX,IY) + XD12(IX,IY) = FACTOR * XD12(IX,IY) + XD21(IX,IY) = FACTOR * XD21(IX,IY) + XD22(IX,IY) = FACTOR * XD22(IX,IY) + END IF + END DO + END DO + END IF + ! + END IF + END IF + ! + ! 4.c Input location and format + ! + DO J=1, NFCOMP + ! + IF ( ITYPE .GE. 5 ) THEN + WRITE (NDSO,960) + ELSE + IF (ITYPE.LE.3) THEN + WRITE (NDSO,961) NXJ(J), NYJ(J) + ELSE + WRITE (NDSO,962) J, NXJ(J), NYJ(J) + END IF + END IF + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & + FROMF, IDLAF(J), IDFMF(J), FORMT(J), FORMF(J) + IF (IDLAF(J).LT.1 .OR. IDLAF(J).GT.4) IDLAF(J) = 1 + IF (IDFMF(J).LT.1 .OR. IDFMF(J).GT.3) IDFMF(J) = 1 + IF ( ITYPE .NE. 5 ) WRITE (NDSO,963) IDLAF(J) + WRITE (NDSO,964) IDFMF(J) + IF (IDFMF(J).EQ.2) WRITE (NDSO,965) FORMT(J), FORMF(J) + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSF(J), NAMEF +#ifdef W3_NCO + NDSF(J) = 24 + NFCOMP +#endif + WRITE (NDSO,966) NDSF(J) + IF (FROMF.EQ.'NAME') WRITE (NDSO,967) NAMEF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5 Prepare files + ! 5.a Open input file + ! + WRITE (NDSO,970) + ! + IF ( IDFMF(J) .EQ. 3 ) THEN + IF (NDSF(J).EQ.NDSI) THEN + WRITE (NDSE,1051) NDSI + CALL EXTCDE ( 20 ) + ELSE + IF (FROMF.EQ.'NAME') THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSF(J),FILE=FNMPRE(:JJ)//NAMEF, & + form='UNFORMATTED', convert=file_endian,STATUS='OLD',ERR=850, & + IOSTAT=IERR) ELSE - CALL W3FLDO ( 'WRITE', IDFLD, NDSDAT, NDST, NDSE, & - RECLDT, 0, GTYPEDUM, IERR, FPRE=FNMPRE(:J) ) + OPEN (NDSF(J),form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=850,IOSTAT=IERR) END IF -! -! 5.c Initialize fields -! - IF ( ITYPE .NE. 5 ) THEN - FX = 0. - FY = 0. - FA = 0. - MXM = MAX ( NXJ(1), NXJ(2) ) - MYM = MAX ( NYJ(1), NYJ(2) ) - ALLOCATE ( XC(MXM,MYM), YC(MXM,MYM), AC(MXM,MYM) ) - XC = 0. - YC = 0. - AC = 0. + ! + ! Adding a check to see if input file is a WAVEWATCH III file + ! (This check has only been added for binary wind files) + ! + READ (NDSF(J),END=888,IOSTAT=IERR) TSTR, & + TSFLD, NXT, NYT + IF (IERR .EQ. 0 .AND. TSTR .EQ. IDSTR) THEN + IF (TSFLD .NE. IDFLD .OR. NXT .NE. NXI & + .OR. NYT .NE. NYI ) THEN + WRITE (NDSE,1052) TSFLD, NXT, NYT, IDFLD, & + NXI, NYI + CALL EXTCDE ( 21 ) + END IF + ELSE + REWIND(NDSF(J)) END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6 Begin loop over input fields -! + END IF + ELSE + IF (NDSF(J).EQ.NDSI) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ELSE + IF (FROMF.EQ.'NAME') THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSF(J),FILE=FNMPRE(:JJ)//NAMEF, & + STATUS='OLD',ERR=850,IOSTAT=IERR) + ELSE + OPEN (NDSF(J),STATUS='OLD',ERR=850,IOSTAT=IERR) + END IF + END IF + END IF + ! + END DO + ! + IF ( NFCOMP .EQ. 1 ) THEN + NXJ (2) = NXJ (1) + NYJ (2) = NYJ (1) + NDSF (2) = NDSF (1) + IDLAF(2) = IDLAF(1) + IDFMF(2) = IDFMF(1) + FORMT(2) = FORMT(1) + FORMF(2) = FORMF(1) + END IF + ! + ! 5.b Open and prepare output file + ! + WRITE (NDSO,971) + J = LEN_TRIM(FNMPRE) + IF ( ITYPE .LE. 4 ) THEN + CALL W3FLDO ( 'WRITE', IDFLD, NDSDAT, NDST, NDSE, & + NX, NY, GTYPE, IERR, FPRE=FNMPRE(:J), & + FHDR=FLHDR ) + ELSE + CALL W3FLDO ( 'WRITE', IDFLD, NDSDAT, NDST, NDSE, & + RECLDT, 0, GTYPEDUM, IERR, FPRE=FNMPRE(:J) ) + END IF + ! + ! 5.c Initialize fields + ! + IF ( ITYPE .NE. 5 ) THEN + FX = 0. + FY = 0. + FA = 0. + MXM = MAX ( NXJ(1), NXJ(2) ) + MYM = MAX ( NYJ(1), NYJ(2) ) + ALLOCATE ( XC(MXM,MYM), YC(MXM,MYM), AC(MXM,MYM) ) + XC = 0. + YC = 0. + AC = 0. + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6 Begin loop over input fields + ! #ifdef W3_O15 - J = LEN_TRIM(FNMPRE) - OPEN (NDSTIME,FILE=FNMPRE(:J)//'times.'//IDFLD, & - ERR=870,IOSTAT=IERR ) + J = LEN_TRIM(FNMPRE) + OPEN (NDSTIME,FILE=FNMPRE(:J)//'times.'//IDFLD, & + ERR=870,IOSTAT=IERR ) #endif -! - WRITE (NDSO,972) - DO -! -! 6.a Read new time and fields -! - IF ( FLTIME ) THEN -! - J = 1 - IF (IDFMF(J).EQ.1) THEN - READ (NDSF(J), * ,END=888,ERR=860,IOSTAT=IERR) TIME - ELSE IF (IDFMF(J).EQ.2) THEN - READ (NDSF(J),FORMT(J),END=888,ERR=860,IOSTAT=IERR) TIME - ELSE - READ (NDSF(J), END=888,ERR=860,IOSTAT=IERR) TIME - END IF -! <--- + ! + WRITE (NDSO,972) + DO + ! + ! 6.a Read new time and fields + ! + IF ( FLTIME ) THEN + ! + J = 1 + IF (IDFMF(J).EQ.1) THEN + READ (NDSF(J), * ,END=888,ERR=860,IOSTAT=IERR) TIME + ELSE IF (IDFMF(J).EQ.2) THEN + READ (NDSF(J),FORMT(J),END=888,ERR=860,IOSTAT=IERR) TIME + ELSE + READ (NDSF(J), END=888,ERR=860,IOSTAT=IERR) TIME + END IF + ! <--- IF (NFCOMP.EQ.2) THEN - J = 2 - IF (IDFMF(J).EQ.1) THEN - READ (NDSF(J), * ,END=888,ERR=860,IOSTAT=IERR) TIME2 - ELSE IF (IDFMF(J).EQ.2) THEN - READ (NDSF(J),FORMT(J),END=888,ERR=860,IOSTAT=IERR) TIME2 - ELSE - READ (NDSF(J), END=888,ERR=860,IOSTAT=IERR) TIME2 - END IF - IF (TIME2(1).NE.TIME(1) .OR. TIME2(2).NE.TIME(2)) GOTO 861 + J = 2 + IF (IDFMF(J).EQ.1) THEN + READ (NDSF(J), * ,END=888,ERR=860,IOSTAT=IERR) TIME2 + ELSE IF (IDFMF(J).EQ.2) THEN + READ (NDSF(J),FORMT(J),END=888,ERR=860,IOSTAT=IERR) TIME2 + ELSE + READ (NDSF(J), END=888,ERR=860,IOSTAT=IERR) TIME2 END IF -! <--- - END IF -! - CALL STME21 ( TIME , IDTIME ) - WRITE (NDSO,973) IDTIME + IF (TIME2(1).NE.TIME(1) .OR. TIME2(2).NE.TIME(2)) GOTO 861 + END IF + ! <--- + END IF + ! + CALL STME21 ( TIME , IDTIME ) + WRITE (NDSO,973) IDTIME #ifdef W3_O15 - WRITE (NDSTIME, 979, ERR=871,IOSTAT=IERR) TIME + WRITE (NDSTIME, 979, ERR=871,IOSTAT=IERR) TIME #endif #ifdef W3_O3 - WRITE (NDSO,974) + WRITE (NDSO,974) #endif -! -! ... Input -! -! read in array from ww3_prep.inp - IF ( ITYPE .LE. 4 ) THEN - CALL INA2R (XC, MXM, MYM, 1, NXJ(1), 1, NYJ(1), & - NDSF(1), NDST, NDSE, IDFMF(1), FORMF(1), IDLAF(1), 1., 0.) -! + ! + ! ... Input + ! + ! read in array from ww3_prep.inp + IF ( ITYPE .LE. 4 ) THEN + CALL INA2R (XC, MXM, MYM, 1, NXJ(1), 1, NYJ(1), & + NDSF(1), NDST, NDSE, IDFMF(1), FORMF(1), IDLAF(1), 1., 0.) + ! #ifdef W3_T2 - WRITE (NDST,9060) 1 - IXP0 = 1 - IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(1) ) - DO - CALL PRTBLK ( NDST, NXJ(1), NYJ(1), MXM, XC, MASK, 0, 0.,& - IXP0, IXPN, 1, 1, NYJ(1), 1, 'Field 1', ' ') - IF (IXPN.NE.NXJ(1)) THEN - IXP0 = IXP0 + IXPWDT - IXPN = MIN ( IXPN+IXPWDT , NXJ(1) ) - ELSE - EXIT - END IF - END DO + WRITE (NDST,9060) 1 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(1) ) + DO + CALL PRTBLK ( NDST, NXJ(1), NYJ(1), MXM, XC, MASK, 0, 0.,& + IXP0, IXPN, 1, 1, NYJ(1), 1, 'Field 1', ' ') + IF (IXPN.NE.NXJ(1)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(1) ) + ELSE + EXIT + END IF + END DO #endif -! - IF (NFCOMP.EQ.2 .OR. IFLD.GE.3 .OR. FLBERG) THEN - CALL INA2R (YC, MXM, MYM, 1, NXJ(2), 1, NYJ(2), & - NDSF(2), NDST, NDSE, IDFMF(2), FORMF(2), & - IDLAF(2), 1., 0.) -! + ! + IF (NFCOMP.EQ.2 .OR. IFLD.GE.3 .OR. FLBERG) THEN + CALL INA2R (YC, MXM, MYM, 1, NXJ(2), 1, NYJ(2), & + NDSF(2), NDST, NDSE, IDFMF(2), FORMF(2), & + IDLAF(2), 1., 0.) + ! #ifdef W3_T2 - WRITE (NDST,9060) 2 - IXP0 = 1 - IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) - DO - CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, YC, MASK, 0, 0., & - IXP0, IXPN, 1, 1, NYJ(2), 1, 'Field 2', ' ') - IF (IXPN.NE.NXJ(2)) THEN - IXP0 = IXP0 + IXPWDT - IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) - ELSE - EXIT - END IF - END DO + WRITE (NDST,9060) 2 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) + DO + CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, YC, MASK, 0, 0., & + IXP0, IXPN, 1, 1, NYJ(2), 1, 'Field 2', ' ') + IF (IXPN.NE.NXJ(2)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) + ELSE + EXIT + END IF + END DO #endif -! - IF ( FLSTAB ) THEN - CALL INA2R (AC, MXM, MYM, 1, NXJ(2), 1, NYJ(2), & - NDSF(2), NDST, NDSE, IDFMF(2), FORMF(2), & - IDLAF(2), 1., 0. ) -! + ! + IF ( FLSTAB ) THEN + CALL INA2R (AC, MXM, MYM, 1, NXJ(2), 1, NYJ(2), & + NDSF(2), NDST, NDSE, IDFMF(2), FORMF(2), & + IDLAF(2), 1., 0. ) + ! #ifdef W3_T2 - WRITE (NDST,9060) 3 - IXP0 = 1 - IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) - DO - CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, AC, MASK, 0,& - 0., IXP0, IXPN, 1,1, NYJ(2), 1, 'Field 3', ' ') - IF (IXPN.NE.NXJ(2)) THEN - IXP0 = IXP0 + IXPWDT - IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) - ELSE - EXIT - END IF - END DO + WRITE (NDST,9060) 3 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) + DO + CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, AC, MASK, 0,& + 0., IXP0, IXPN, 1,1, NYJ(2), 1, 'Field 3', ' ') + IF (IXPN.NE.NXJ(2)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) + ELSE + EXIT + END IF + END DO #endif -! - END IF -! - END IF -! - ELSE -! - IF (IDFMF(1).EQ.3) THEN - READ (NDSF(1), END=862,ERR=862,IOSTAT=IERR) NDAT - ELSE - READ (NDSF(1),*,END=862,ERR=862,IOSTAT=IERR) NDAT - END IF + ! + END IF + ! + END IF + ! + ELSE + ! + IF (IDFMF(1).EQ.3) THEN + READ (NDSF(1), END=862,ERR=862,IOSTAT=IERR) NDAT + ELSE + READ (NDSF(1),*,END=862,ERR=862,IOSTAT=IERR) NDAT + END IF #ifdef W3_O3 - WRITE (NDSO,975) NDAT + WRITE (NDSO,975) NDAT #endif - IF ( NDAT.GT.0 ) THEN - ALLOCATE ( DATA(RECLDT,NDAT) ) - DO IDAT=1, NDAT - IF (IDFMF(1).EQ.1) THEN - READ (NDSF(1), * ,END=863,ERR=863, & - IOSTAT=IERR) DATA(:,IDAT) - ELSE IF (IDFMF(1).EQ.2) THEN - READ (NDSF(1),FORMT(1),END=863,ERR=863, & - IOSTAT=IERR) DATA(:,IDAT) - ELSE - READ (NDSF(1), END=863,ERR=863, & - IOSTAT=IERR) DATA(:,IDAT) - END IF - END DO - END IF -! + IF ( NDAT.GT.0 ) THEN + ALLOCATE ( DATA(RECLDT,NDAT) ) + DO IDAT=1, NDAT + IF (IDFMF(1).EQ.1) THEN + READ (NDSF(1), * ,END=863,ERR=863, & + IOSTAT=IERR) DATA(:,IDAT) + ELSE IF (IDFMF(1).EQ.2) THEN + READ (NDSF(1),FORMT(1),END=863,ERR=863, & + IOSTAT=IERR) DATA(:,IDAT) + ELSE + READ (NDSF(1), END=863,ERR=863, & + IOSTAT=IERR) DATA(:,IDAT) + END IF + END DO + END IF + ! #ifdef W3_T2 - WRITE (NDST,9061) - DO IDAT=1, NDAT - IX = MIN(6,RECLDT) - WRITE (NDST,9062) IDAT, DATA(1:IX,IDAT) - IF ( IX.LT.RECLDT ) WRITE (NDST,9063) DATA(IX+1:,:) - END DO + WRITE (NDST,9061) + DO IDAT=1, NDAT + IX = MIN(6,RECLDT) + WRITE (NDST,9062) IDAT, DATA(1:IX,IDAT) + IF ( IX.LT.RECLDT ) WRITE (NDST,9063) DATA(IX+1:,:) + END DO #endif -! - END IF -! -! 6.b Interpolate fields -! ... No interpolation, type AI (should not use array syntax !!!) -! - IF (ITYPE.EQ.1) THEN -! - IF (( IFLD.LE.2 ).AND.( .NOT. FLBERG )) THEN - DO IY=1, NY - DO IX=1, NX - FA(IX,IY) = XC(IX,IY) - END DO - END DO - ELSE - DO IY=1, NY - DO IX=1, NX - FX(IX,IY) = XC(IX,IY) - FY(IX,IY) = YC(IX,IY) - FA(IX,IY) = AC(IX,IY) - END DO - END DO - END IF -! - ELSE IF (ITYPE.NE.5) THEN -! -! ... One-component fields -! + ! + END IF + ! + ! 6.b Interpolate fields + ! ... No interpolation, type AI (should not use array syntax !!!) + ! + IF (ITYPE.EQ.1) THEN + ! + IF (( IFLD.LE.2 ).AND.( .NOT. FLBERG )) THEN + DO IY=1, NY + DO IX=1, NX + FA(IX,IY) = XC(IX,IY) + END DO + END DO + ELSE + DO IY=1, NY + DO IX=1, NX + FX(IX,IY) = XC(IX,IY) + FY(IX,IY) = YC(IX,IY) + FA(IX,IY) = AC(IX,IY) + END DO + END DO + END IF + ! + ELSE IF (ITYPE.NE.5) THEN + ! + ! ... One-component fields + ! #ifdef W3_O3 - WRITE (NDSO,976) ' ' + WRITE (NDSO,976) ' ' #endif - IF (( IFLD.LE.2 ).AND.( .NOT. FLBERG )) THEN -! - DO IY=1,NY - DO IX=1,NX - FA(IX,IY) & - = RD11(IX,IY) * XC(IX21(IX,IY),IY21(IX,IY)) & - + RD21(IX,IY) * XC(IX22(IX,IY),IY21(IX,IY)) & - + RD12(IX,IY) * XC(IX21(IX,IY),IY22(IX,IY)) & - + RD22(IX,IY) * XC(IX22(IX,IY),IY22(IX,IY)) - END DO - END DO -! - IF (NFCOMP.EQ.2) THEN + IF (( IFLD.LE.2 ).AND.( .NOT. FLBERG )) THEN + ! + DO IY=1,NY + DO IX=1,NX + FA(IX,IY) & + = RD11(IX,IY) * XC(IX21(IX,IY),IY21(IX,IY)) & + + RD21(IX,IY) * XC(IX22(IX,IY),IY21(IX,IY)) & + + RD12(IX,IY) * XC(IX21(IX,IY),IY22(IX,IY)) & + + RD22(IX,IY) * XC(IX22(IX,IY),IY22(IX,IY)) + END DO + END DO + ! + IF (NFCOMP.EQ.2) THEN #ifdef W3_O3 - WRITE (NDSO,976) ' (2) ' + WRITE (NDSO,976) ' (2) ' #endif - DO IY=1,NY - DO IX=1,NX - FA(IX,IY) = FA(IX,IY) & - + XD11(IX,IY) * YC(JX21(IX,IY),JY21(IX,IY)) & - + XD21(IX,IY) * YC(JX22(IX,IY),JY21(IX,IY)) & - + XD12(IX,IY) * YC(JX21(IX,IY),JY22(IX,IY)) & - + XD22(IX,IY) * YC(JX22(IX,IY),JY22(IX,IY)) - END DO - END DO - END IF -! -! ... Two-component fields -! - ELSE -! - DO IY=1,NY - DO IX=1,NX - IF (IY21(IX,IY).LT.1) THEN - IY21(IX,IY)=1 - IX21(IX,IY)=1 - IX22(IX,IY)=1 - ENDIF - IF (IY22(IX,IY).LT.1) IY22(IX,IY)=1 - IF (IY21(IX,IY).GT.MYM) IY21(IX,IY)=MYM - IF (IY22(IX,IY).GT.MYM) THEN - IY22(IX,IY)=MYM - IX21(IX,IY)=1 - IX22(IX,IY)=1 - END IF - FX(IX,IY) & - = RD11(IX,IY) * XC(IX21(IX,IY),IY21(IX,IY)) & - + RD21(IX,IY) * XC(IX22(IX,IY),IY21(IX,IY)) & - + RD12(IX,IY) * XC(IX21(IX,IY),IY22(IX,IY)) & - + RD22(IX,IY) * XC(IX22(IX,IY),IY22(IX,IY)) - FY(IX,IY) & - = RD11(IX,IY) * YC(IX21(IX,IY),IY21(IX,IY)) & - + RD21(IX,IY) * YC(IX22(IX,IY),IY21(IX,IY)) & - + RD12(IX,IY) * YC(IX21(IX,IY),IY22(IX,IY)) & - + RD22(IX,IY) * YC(IX22(IX,IY),IY22(IX,IY)) - FA(IX,IY) & - = RD11(IX,IY) * AC(IX21(IX,IY),IY21(IX,IY)) & - + RD21(IX,IY) * AC(IX22(IX,IY),IY21(IX,IY)) & - + RD12(IX,IY) * AC(IX21(IX,IY),IY22(IX,IY)) & - + RD22(IX,IY) * AC(IX22(IX,IY),IY22(IX,IY)) - A1(IX,IY) = MAX ( 1.E-10 , & - SQRT( FX(IX,IY)**2 + FY(IX,IY)**2 ) ) - A2(IX,IY) & + DO IY=1,NY + DO IX=1,NX + FA(IX,IY) = FA(IX,IY) & + + XD11(IX,IY) * YC(JX21(IX,IY),JY21(IX,IY)) & + + XD21(IX,IY) * YC(JX22(IX,IY),JY21(IX,IY)) & + + XD12(IX,IY) * YC(JX21(IX,IY),JY22(IX,IY)) & + + XD22(IX,IY) * YC(JX22(IX,IY),JY22(IX,IY)) + END DO + END DO + END IF + ! + ! ... Two-component fields + ! + ELSE + ! + DO IY=1,NY + DO IX=1,NX + IF (IY21(IX,IY).LT.1) THEN + IY21(IX,IY)=1 + IX21(IX,IY)=1 + IX22(IX,IY)=1 + ENDIF + IF (IY22(IX,IY).LT.1) IY22(IX,IY)=1 + IF (IY21(IX,IY).GT.MYM) IY21(IX,IY)=MYM + IF (IY22(IX,IY).GT.MYM) THEN + IY22(IX,IY)=MYM + IX21(IX,IY)=1 + IX22(IX,IY)=1 + END IF + FX(IX,IY) & + = RD11(IX,IY) * XC(IX21(IX,IY),IY21(IX,IY)) & + + RD21(IX,IY) * XC(IX22(IX,IY),IY21(IX,IY)) & + + RD12(IX,IY) * XC(IX21(IX,IY),IY22(IX,IY)) & + + RD22(IX,IY) * XC(IX22(IX,IY),IY22(IX,IY)) + FY(IX,IY) & + = RD11(IX,IY) * YC(IX21(IX,IY),IY21(IX,IY)) & + + RD21(IX,IY) * YC(IX22(IX,IY),IY21(IX,IY)) & + + RD12(IX,IY) * YC(IX21(IX,IY),IY22(IX,IY)) & + + RD22(IX,IY) * YC(IX22(IX,IY),IY22(IX,IY)) + FA(IX,IY) & + = RD11(IX,IY) * AC(IX21(IX,IY),IY21(IX,IY)) & + + RD21(IX,IY) * AC(IX22(IX,IY),IY21(IX,IY)) & + + RD12(IX,IY) * AC(IX21(IX,IY),IY22(IX,IY)) & + + RD22(IX,IY) * AC(IX22(IX,IY),IY22(IX,IY)) + A1(IX,IY) = MAX ( 1.E-10 , & + SQRT( FX(IX,IY)**2 + FY(IX,IY)**2 ) ) + A2(IX,IY) & = RD11(IX,IY) * SQRT(XC(IX21(IX,IY),IY21(IX,IY))**2 & - +YC(IX21(IX,IY),IY21(IX,IY))**2) & + +YC(IX21(IX,IY),IY21(IX,IY))**2) & + RD21(IX,IY) * SQRT(XC(IX22(IX,IY),IY21(IX,IY))**2 & - +YC(IX22(IX,IY),IY21(IX,IY))**2) & + +YC(IX22(IX,IY),IY21(IX,IY))**2) & + RD12(IX,IY) * SQRT(XC(IX21(IX,IY),IY22(IX,IY))**2 & - +YC(IX21(IX,IY),IY22(IX,IY))**2) & + +YC(IX21(IX,IY),IY22(IX,IY))**2) & + RD22(IX,IY) * SQRT(XC(IX22(IX,IY),IY22(IX,IY))**2 & - +YC(IX22(IX,IY),IY22(IX,IY))**2) - A3(IX,IY) = SQRT ( & - RD11(IX,IY) * ( XC(IX21(IX,IY),IY21(IX,IY))**2 & - + YC(IX21(IX,IY),IY21(IX,IY))**2 ) & - + RD21(IX,IY) * ( XC(IX22(IX,IY),IY21(IX,IY))**2 & - + YC(IX22(IX,IY),IY21(IX,IY))**2 ) & - + RD12(IX,IY) * ( XC(IX21(IX,IY),IY22(IX,IY))**2 & - + YC(IX21(IX,IY),IY22(IX,IY))**2 ) & - + RD22(IX,IY) * ( XC(IX22(IX,IY),IY22(IX,IY))**2 & - + YC(IX22(IX,IY),IY22(IX,IY))**2 ) ) - END DO - END DO -! -! ... Winds, correct for velocity or energy conservation -! + +YC(IX22(IX,IY),IY22(IX,IY))**2) + A3(IX,IY) = SQRT ( & + RD11(IX,IY) * ( XC(IX21(IX,IY),IY21(IX,IY))**2 & + + YC(IX21(IX,IY),IY21(IX,IY))**2 ) & + + RD21(IX,IY) * ( XC(IX22(IX,IY),IY21(IX,IY))**2 & + + YC(IX22(IX,IY),IY21(IX,IY))**2 ) & + + RD12(IX,IY) * ( XC(IX21(IX,IY),IY22(IX,IY))**2 & + + YC(IX21(IX,IY),IY22(IX,IY))**2 ) & + + RD22(IX,IY) * ( XC(IX22(IX,IY),IY22(IX,IY))**2 & + + YC(IX22(IX,IY),IY22(IX,IY))**2 ) ) + END DO + END DO + ! + ! ... Winds, correct for velocity or energy conservation + ! #ifdef W3_WNT1 - IF (IFLD.EQ.3) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF + IF (IFLD.EQ.3) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF #endif -! + ! #ifdef W3_WNT2 - IF (IFLD.EQ.3) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF + IF (IFLD.EQ.3) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF #endif -! -! ... Currents, correct for velocity or energy conservation -! + ! + ! ... Currents, correct for velocity or energy conservation + ! #ifdef W3_CRT1 - IF (IFLD.EQ.4) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF + IF (IFLD.EQ.4) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF #endif -! + ! #ifdef W3_CRT2 - IF (IFLD.EQ.4) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF + IF (IFLD.EQ.4) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF #endif -! -! ... Momentum, correct for velocity or energy conservation -! + ! + ! ... Momentum, correct for velocity or energy conservation + ! #ifdef W3_WNT1 - IF (IFLD.EQ.6) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF + IF (IFLD.EQ.6) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF #endif -! + ! #ifdef W3_WNT2 - IF (IFLD.EQ.6) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF -#endif - END IF -! - END IF -! -! ... Test output -! -#ifdef W3_T3 - IF ( .NOT. ALLOCATED(MAPOUT) ) ALLOCATE ( MAPOUT(NX,NY) ) - WRITE (NDST,9065) - DO IX=1, NX - DO IY=1, NY - MAPOUT(IX,IY) = MAPSTA(IY,IX) + IF (IFLD.EQ.6) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) END DO END DO - IX0 = 1 - IXN = MIN ( IX0+IXWDT-1 , NX ) - DO - IF (IFLD.EQ.-7) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'ice param 1', '(-)') - ELSE IF (IFLD.EQ.-6) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'ice param 2', '(-)') - ELSE IF (IFLD.EQ.-5) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'ice param 3', '(-)') - ELSE IF (IFLD.EQ.-4) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'ice param 4', '(-)') - ELSE IF (IFLD.EQ.-3) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'ice param 5', '(-)') - ELSE IF (IFLD.EQ.-2) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Mud Density', 'kg/m3') - ELSE IF (IFLD.EQ.-1) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Mud Thkness', '(-)') - ELSE IF (IFLD.EQ.0) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Mud Kin.Visc', 'm2/s') - ELSE IF (IFLD.EQ.1) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Fraction ice', '(-)') - IF ( FLBERG ) & - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Iceberg a', '0.1/km') - ELSE IF (IFLD.EQ.2) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Water level', 'm') - ELSE - CALL PRTBLK (NDSO, NX, NY, NX, FX, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Cart. X-comp', 'm/s') - CALL PRTBLK (NDSO, NX, NY, NX, FY, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Cart. Y-comp', 'm/s') - IF ( FLSTAB ) & - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Tair-Tsea', 'degr') - END IF - IF (IXN.NE.NX) THEN - IX0 = IX0 + IXWDT - IXN = MIN ( IXN+IXWDT , NX ) - ELSE - EXIT - END IF - END DO + END IF #endif -! -! 6.c Write fields -! - IF ( ITYPE .LE. 4 ) THEN + END IF + ! + END IF + ! + ! ... Test output + ! +#ifdef W3_T3 + IF ( .NOT. ALLOCATED(MAPOUT) ) ALLOCATE ( MAPOUT(NX,NY) ) + WRITE (NDST,9065) + DO IX=1, NX + DO IY=1, NY + MAPOUT(IX,IY) = MAPSTA(IY,IX) + END DO + END DO + IX0 = 1 + IXN = MIN ( IX0+IXWDT-1 , NX ) + DO + IF (IFLD.EQ.-7) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'ice param 1', '(-)') + ELSE IF (IFLD.EQ.-6) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'ice param 2', '(-)') + ELSE IF (IFLD.EQ.-5) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'ice param 3', '(-)') + ELSE IF (IFLD.EQ.-4) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'ice param 4', '(-)') + ELSE IF (IFLD.EQ.-3) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'ice param 5', '(-)') + ELSE IF (IFLD.EQ.-2) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Mud Density', 'kg/m3') + ELSE IF (IFLD.EQ.-1) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Mud Thkness', '(-)') + ELSE IF (IFLD.EQ.0) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Mud Kin.Visc', 'm2/s') + ELSE IF (IFLD.EQ.1) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Fraction ice', '(-)') + IF ( FLBERG ) & + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Iceberg a', '0.1/km') + ELSE IF (IFLD.EQ.2) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Water level', 'm') + ELSE + CALL PRTBLK (NDSO, NX, NY, NX, FX, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Cart. X-comp', 'm/s') + CALL PRTBLK (NDSO, NX, NY, NX, FY, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Cart. Y-comp', 'm/s') + IF ( FLSTAB ) & + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Tair-Tsea', 'degr') + END IF + IF (IXN.NE.NX) THEN + IX0 = IX0 + IXWDT + IXN = MIN ( IXN+IXWDT , NX ) + ELSE + EXIT + END IF + END DO +#endif + ! + ! 6.c Write fields + ! + IF ( ITYPE .LE. 4 ) THEN #ifdef W3_O3 - WRITE (NDSO,977) + WRITE (NDSO,977) #endif - CALL W3FLDG ('WRITE', IDFLD, NDSDAT, NDST, NDSE, NX, NY, & - NX, NY, TIME, TIME, TIME, FX, FY, FA, TIME, & - FX, FY, FA, IERR) - ELSE IF ( ITYPE .EQ. 5 ) THEN - IF ( NDAT .EQ. 0 ) THEN + CALL W3FLDG ('WRITE', IDFLD, NDSDAT, NDST, NDSE, NX, NY, & + NX, NY, TIME, TIME, TIME, FX, FY, FA, TIME, & + FX, FY, FA, IERR) + ELSE IF ( ITYPE .EQ. 5 ) THEN + IF ( NDAT .EQ. 0 ) THEN #ifdef W3_O3 - WRITE (NDSO,978) + WRITE (NDSO,978) #endif - ELSE + ELSE #ifdef W3_O3 - WRITE (NDSO,977) + WRITE (NDSO,977) #endif - CALL W3FLDD ('WRITE', IDFLD, NDSDAT, NDST, NDSE, TIME,& - TIME, RECLDT, NDAT, IDAT, DATA, IERR ) - DEALLOCATE ( DATA ) - END IF - END IF - IF (IERR.NE.0) CALL EXTCDE ( 30 ) -! - IF ( .NOT. FLTIME ) EXIT - END DO -! -! End loop over input fields -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! - GOTO 888 -! -! Error escape locations -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 40 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 41 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 42 ) -! - 845 CONTINUE - WRITE (NDSE,1045) IERR - CALL EXTCDE ( 47 ) -! - 846 CONTINUE - WRITE (NDSE,1046) IERR - CALL EXTCDE ( 48 ) -! - 850 CONTINUE - WRITE (NDSE,1050) IERR, NDSF(J), NAMEF - CALL EXTCDE ( 49 ) -! - 860 CONTINUE - WRITE (NDSE,1060) J, IERR - CALL EXTCDE ( 50 ) -! - 861 CONTINUE - WRITE (NDSE,1061) TIME, TIME2 - CALL EXTCDE ( 51 ) -! - 862 CONTINUE - WRITE (NDSE,1062) IERR - CALL EXTCDE ( 52 ) -! - 863 CONTINUE - WRITE (NDSE,1063) IDAT, IERR - CALL EXTCDE ( 53 ) -! + CALL W3FLDD ('WRITE', IDFLD, NDSDAT, NDST, NDSE, TIME,& + TIME, RECLDT, NDAT, IDAT, DATA, IERR ) + DEALLOCATE ( DATA ) + END IF + END IF + IF (IERR.NE.0) CALL EXTCDE ( 30 ) + ! + IF ( .NOT. FLTIME ) EXIT + END DO + ! + ! End loop over input fields + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! + GOTO 888 + ! + ! Error escape locations + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 40 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 41 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 42 ) + ! +845 CONTINUE + WRITE (NDSE,1045) IERR + CALL EXTCDE ( 47 ) + ! +846 CONTINUE + WRITE (NDSE,1046) IERR + CALL EXTCDE ( 48 ) + ! +850 CONTINUE + WRITE (NDSE,1050) IERR, NDSF(J), NAMEF + CALL EXTCDE ( 49 ) + ! +860 CONTINUE + WRITE (NDSE,1060) J, IERR + CALL EXTCDE ( 50 ) + ! +861 CONTINUE + WRITE (NDSE,1061) TIME, TIME2 + CALL EXTCDE ( 51 ) + ! +862 CONTINUE + WRITE (NDSE,1062) IERR + CALL EXTCDE ( 52 ) + ! +863 CONTINUE + WRITE (NDSE,1063) IDAT, IERR + CALL EXTCDE ( 53 ) + ! #ifdef W3_O15 - 870 CONTINUE - WRITE (NDSE,1070) IDFLD, IERR - CALL EXTCDE ( 54 ) +870 CONTINUE + WRITE (NDSE,1070) IDFLD, IERR + CALL EXTCDE ( 54 ) #endif -! + ! #ifdef W3_O15 - 871 CONTINUE - WRITE (NDSE,1071) IDTIME, IERR - CALL EXTCDE ( 54 ) +871 CONTINUE + WRITE (NDSE,1071) IDTIME, IERR + CALL EXTCDE ( 54 ) #endif -! - 888 CONTINUE - WRITE (NDSO,999) -! + ! +888 CONTINUE + WRITE (NDSO,999) + ! #ifdef W3_NCO -! CALL W3TAGE('WAVEPREP') + ! CALL W3TAGE('WAVEPREP') #endif -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Input pre-processing *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) - 902 FORMAT ( ' Grid name : ',A/) -! - 930 FORMAT (/' Description of inputs'/ & - ' --------------------------------------------------'/ & - ' Input type : ',A/ & - ' Format type : ',A) - 1930 FORMAT ( ' Field conserves velocity.') - 2930 FORMAT ( ' Field corrected for energy conservation.') - 931 FORMAT (/' Single field, time: ',A) - 932 FORMAT (/' Input grid dim. :',I5,3X,I5) - 933 FORMAT ( ' Longitude range :',2F8.2,' (deg)'/ & - ' Latitude range :',2F8.2,' (deg)') - 733 FORMAT ( ' X range :',2F8.2,' (km)'/ & - ' Y range :',2F8.2,' (km)') - 934 FORMAT (/' Data type : ',A/ & - ' Data record length:',I5/ & - ' Missing values :',F8.2) - 935 FORMAT ( 'DT',I1 ) - 938 FORMAT ( ' Icebergs included.') - 939 FORMAT ( ' Air-sea temperature differences included.') -! - 940 FORMAT (//' Preprocessing data'/ & - ' --------------------------------------------------') - 941 FORMAT ( ' Interpolation factors ..... '/ & - ' (longitude-latitude grid)') - 942 FORMAT ( ' Interpolation factors ..... '/ & - ' (grid from file)') - 943 FORMAT (/' Longitude-latitude file ',I1,' :'/ & - ' ---------------------------------------') - 944 FORMAT ( ' Input grid dim. :',I5,3X,I5/ & - ' Closed longitudes :',L5) - 945 FORMAT ( ' Layout indicator :',I5/ & - ' Format indicator :',I5) - 946 FORMAT ( ' Format : ',A) - 947 FORMAT ( ' Unit number :',I5) - 948 FORMAT ( ' File name : ',A) - 949 FORMAT (/' Corresponding map file '/ & - ' ---------------------------------------') -! - 960 FORMAT (/' Data file :'/ & - ' ---------------------------------------') - 961 FORMAT (/' Data file :'/ & - ' ---------------------------------------'/ & - ' Input grid dim. :',I5,3X,I5) - 962 FORMAT (/' Data file (',I1,') :'/ & - ' ---------------------------------------'/ & - ' Input grid dim. :',I5,3X,I5) - 963 FORMAT ( ' Layout indicator :',I5) - 964 FORMAT ( ' Format indicator :',I5) - 965 FORMAT ( ' Format for time : ',A/ & - ' Format for data : ',A) - 966 FORMAT ( ' Unit number :',I5) - 967 FORMAT ( ' File name : ',A) -! - 970 FORMAT (/' Opening input data file .....') - 971 FORMAT (/' Opening output data file .....') - 972 FORMAT (//' Processing data'/ & - ' --------------------------------------------------') - 973 FORMAT ( ' Time : ',A) + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Input pre-processing *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) +902 FORMAT ( ' Grid name : ',A/) + ! +930 FORMAT (/' Description of inputs'/ & + ' --------------------------------------------------'/ & + ' Input type : ',A/ & + ' Format type : ',A) +1930 FORMAT ( ' Field conserves velocity.') +2930 FORMAT ( ' Field corrected for energy conservation.') +931 FORMAT (/' Single field, time: ',A) +932 FORMAT (/' Input grid dim. :',I5,3X,I5) +933 FORMAT ( ' Longitude range :',2F8.2,' (deg)'/ & + ' Latitude range :',2F8.2,' (deg)') +733 FORMAT ( ' X range :',2F8.2,' (km)'/ & + ' Y range :',2F8.2,' (km)') +934 FORMAT (/' Data type : ',A/ & + ' Data record length:',I5/ & + ' Missing values :',F8.2) +935 FORMAT ( 'DT',I1 ) +938 FORMAT ( ' Icebergs included.') +939 FORMAT ( ' Air-sea temperature differences included.') + ! +940 FORMAT (//' Preprocessing data'/ & + ' --------------------------------------------------') +941 FORMAT ( ' Interpolation factors ..... '/ & + ' (longitude-latitude grid)') +942 FORMAT ( ' Interpolation factors ..... '/ & + ' (grid from file)') +943 FORMAT (/' Longitude-latitude file ',I1,' :'/ & + ' ---------------------------------------') +944 FORMAT ( ' Input grid dim. :',I5,3X,I5/ & + ' Closed longitudes :',L5) +945 FORMAT ( ' Layout indicator :',I5/ & + ' Format indicator :',I5) +946 FORMAT ( ' Format : ',A) +947 FORMAT ( ' Unit number :',I5) +948 FORMAT ( ' File name : ',A) +949 FORMAT (/' Corresponding map file '/ & + ' ---------------------------------------') + ! +960 FORMAT (/' Data file :'/ & + ' ---------------------------------------') +961 FORMAT (/' Data file :'/ & + ' ---------------------------------------'/ & + ' Input grid dim. :',I5,3X,I5) +962 FORMAT (/' Data file (',I1,') :'/ & + ' ---------------------------------------'/ & + ' Input grid dim. :',I5,3X,I5) +963 FORMAT ( ' Layout indicator :',I5) +964 FORMAT ( ' Format indicator :',I5) +965 FORMAT ( ' Format for time : ',A/ & + ' Format for data : ',A) +966 FORMAT ( ' Unit number :',I5) +967 FORMAT ( ' File name : ',A) + ! +970 FORMAT (/' Opening input data file .....') +971 FORMAT (/' Opening output data file .....') +972 FORMAT (//' Processing data'/ & + ' --------------------------------------------------') +973 FORMAT ( ' Time : ',A) #ifdef W3_O3 - 974 FORMAT ( ' reading ....') - 975 FORMAT ( ' number of data records :',I6) - 976 FORMAT ( ' interpolating',A,'....') - 977 FORMAT ( ' writing ....') - 978 FORMAT ( ' skipping ....') +974 FORMAT ( ' reading ....') +975 FORMAT ( ' number of data records :',I6) +976 FORMAT ( ' interpolating',A,'....') +977 FORMAT ( ' writing ....') +978 FORMAT ( ' skipping ....') #endif -! + ! #ifdef W3_O15 - 979 FORMAT (1X,I8.8,1X,I6.6) +979 FORMAT (1X,I8.8,1X,I6.6) #endif -! - 999 FORMAT(//' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Input preprocessing '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ILLEGAL FIELD ID -->',A,'<--'/) - 1031 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ILLEGAL FORMAT ID -->',A,'<--'/) - 1032 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' THIS FORMAT TYPE IS ALLOWED FOR ICE AND LEV ONLY'/) -! - 1033 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ILLEGAL DATA RECORD LENGTH : ',I6/) - 1034 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ILLEGAL DATA TYPE : ',I2/) -! - 1035 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ILLEGAL TIME : ',I8.8,I7.6/) - 1036 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ILLEGAL SIZE OF INPUT GRID : ',I5,1X,I5/) - 10381 FORMAT (/' *** WAVEWATCH III WARNING IN W3PREP : '/ & - ' LAT/LON DATA READ FROM INPUT FILE') - 10382 FORMAT (/' *** WAVEWATCH III WARNING IN W3PREP : '/ & - ' MASK DATA READ FROM INPUT FILE') -! - 1042 FORMAT (/' *** WAVEWATCH-III WARNING W3PREP : '/ & - ' GRID POINT ',2I6,2F7.2,/ & - ' NOT COVERED BY INPUT GRID.'/) - 1044 FORMAT (/' *** WAVEWATCH III WARNING W3PREP : '/ & - ' Y = ',F10.1,' NOT COVERED BY INPUT GRID.'/) -! + ! +999 FORMAT(//' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Input preprocessing '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ILLEGAL FIELD ID -->',A,'<--'/) +1031 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ILLEGAL FORMAT ID -->',A,'<--'/) +1032 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' THIS FORMAT TYPE IS ALLOWED FOR ICE AND LEV ONLY'/) + ! +1033 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ILLEGAL DATA RECORD LENGTH : ',I6/) +1034 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ILLEGAL DATA TYPE : ',I2/) + ! +1035 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ILLEGAL TIME : ',I8.8,I7.6/) +1036 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ILLEGAL SIZE OF INPUT GRID : ',I5,1X,I5/) +10381 FORMAT (/' *** WAVEWATCH III WARNING IN W3PREP : '/ & + ' LAT/LON DATA READ FROM INPUT FILE') +10382 FORMAT (/' *** WAVEWATCH III WARNING IN W3PREP : '/ & + ' MASK DATA READ FROM INPUT FILE') + ! +1042 FORMAT (/' *** WAVEWATCH-III WARNING W3PREP : '/ & + ' GRID POINT ',2I6,2F7.2,/ & + ' NOT COVERED BY INPUT GRID.'/) +1044 FORMAT (/' *** WAVEWATCH III WARNING W3PREP : '/ & + ' Y = ',F10.1,' NOT COVERED BY INPUT GRID.'/) + ! -! - 1045 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN OPENING LAT-LONG DATA FILE'/ & - ' IOSTAT =',I5/) -! - 1046 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN OPENING MASK FILE'/ & - ' IOSTAT =',I5/) -! - 1050 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN OPENING INPUT DATA FILE'/ & - ' IOSTAT =',I5/ & - ' NDSF =',I5/ & - ' NAMEF = ',A/) - 1051 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' CANNOT READ UNFORMATTED FROM UNIT',I3/) -! - 1052 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN READING FROM INPUT DATA FILE'/ & - ' IN FILE , VARIABLE ID = ',A/ & - ' ARRAY DIMENSION = ',2I5/ & - ' EXPECTING , VARIABLE ID = ',A/ & - ' ARRAY DIMENSION = ',2I5/) -! - 1060 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN READING TIME FROM FILE (',I1,')'/ & - ' IOSTAT =',I5/) - 1061 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' INCOMPATIBLE FIELD TIMES '/ & - ' FIELD #1 : ',I8.8,I7.6/ & - ' FIELD #2 : ',I8.8,I7.6/) - 1062 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN READING NDAT FROM FILE'/ & - ' IOSTAT =',I5/) - 1063 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN READING DATA RECORD',I6,' FROM FILE'/ & - ' IOSTAT =',I5/) + ! +1045 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN OPENING LAT-LONG DATA FILE'/ & + ' IOSTAT =',I5/) + ! +1046 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN OPENING MASK FILE'/ & + ' IOSTAT =',I5/) + ! +1050 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN OPENING INPUT DATA FILE'/ & + ' IOSTAT =',I5/ & + ' NDSF =',I5/ & + ' NAMEF = ',A/) +1051 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' CANNOT READ UNFORMATTED FROM UNIT',I3/) + ! +1052 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN READING FROM INPUT DATA FILE'/ & + ' IN FILE , VARIABLE ID = ',A/ & + ' ARRAY DIMENSION = ',2I5/ & + ' EXPECTING , VARIABLE ID = ',A/ & + ' ARRAY DIMENSION = ',2I5/) + ! +1060 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN READING TIME FROM FILE (',I1,')'/ & + ' IOSTAT =',I5/) +1061 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' INCOMPATIBLE FIELD TIMES '/ & + ' FIELD #1 : ',I8.8,I7.6/ & + ' FIELD #2 : ',I8.8,I7.6/) +1062 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN READING NDAT FROM FILE'/ & + ' IOSTAT =',I5/) +1063 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN READING DATA RECORD',I6,' FROM FILE'/ & + ' IOSTAT =',I5/) #ifdef W3_O15 - 1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN CREATING A TIMES FILE FOR ',A/ & - ' IOSTAT =',I5/) - 1071 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN WRITING TIME OUTPUT ',A/ & - ' IOSTAT =',I5/) +1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN CREATING A TIMES FILE FOR ',A/ & + ' IOSTAT =',I5/) +1071 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN WRITING TIME OUTPUT ',A/ & + ' IOSTAT =',I5/) #endif -! + ! #ifdef W3_T - 9000 FORMAT (' TEST W3PREP : ACC : ',F6.3) +9000 FORMAT (' TEST W3PREP : ACC : ',F6.3) #endif -! + ! #ifdef W3_T - 9040 FORMAT (' TEST W3PREP : INPUT GRID RANGES AND INCR. AFTER CORR.'/ & - ' LON / X : ',3F10.2, & - ' (GLOBAL=',L1,')'/ & - ' LAT / Y : ',3F10.2) - 9041 FORMAT (' TEST W3PREP : INTERPOLATION DATA FOR ',A) - 9042 FORMAT (' ',I4,F8.2,2I4,2F8.2,1X,F6.3,1X,A) - 9043 FORMAT (' TEST W3PREP : GRID SHIFTED BY ',F5.0,' DEGREES / M') +9040 FORMAT (' TEST W3PREP : INPUT GRID RANGES AND INCR. AFTER CORR.'/ & + ' LON / X : ',3F10.2, & + ' (GLOBAL=',L1,')'/ & + ' LAT / Y : ',3F10.2) +9041 FORMAT (' TEST W3PREP : INTERPOLATION DATA FOR ',A) +9042 FORMAT (' ',I4,F8.2,2I4,2F8.2,1X,F6.3,1X,A) +9043 FORMAT (' TEST W3PREP : GRID SHIFTED BY ',F5.0,' DEGREES / M') #endif #ifdef W3_T1 - 9045 FORMAT (' TEST W3PREP : IX, IY, IXI(2), IYI(2), RD(4)') - 9046 FORMAT (' ',2I4,2X,4I4,2X,4F6.2) +9045 FORMAT (' TEST W3PREP : IX, IY, IXI(2), IYI(2), RD(4)') +9046 FORMAT (' ',2I4,2X,4I4,2X,4F6.2) #endif -! + ! #ifdef W3_T1a - 9050 FORMAT (' TEST W3PREP : LAT-LONG OF INPUT FILE ') - 9051 FORMAT (' ',2I4,2F8.2,I4) +9050 FORMAT (' TEST W3PREP : LAT-LONG OF INPUT FILE ') +9051 FORMAT (' ',2I4,2F8.2,I4) #endif -! + ! #ifdef W3_T2 - 9060 FORMAT (' TEST W3PREP : INPUT FIELD (',I1,') :'/) - 9061 FORMAT (' TEST W3PREP : INPUT DATA RECORDS :') - 9062 FORMAT (' ',I6,' : ',6E11.3) - 9063 FORMAT (' ',6E11.3) +9060 FORMAT (' TEST W3PREP : INPUT FIELD (',I1,') :'/) +9061 FORMAT (' TEST W3PREP : INPUT DATA RECORDS :') +9062 FORMAT (' ',I6,' : ',6E11.3) +9063 FORMAT (' ',6E11.3) #endif #ifdef W3_T3 - 9065 FORMAT (' TEST W3PREP : OUTPUT FIELD(S) :'/) +9065 FORMAT (' TEST W3PREP : OUTPUT FIELD(S) :'/) #endif -!/ -!/ End of W3PREP ----------------------------------------------------- / -!/ - END PROGRAM W3PREP + !/ + !/ End of W3PREP ----------------------------------------------------- / + !/ +END PROGRAM W3PREP diff --git a/model/src/ww3_prnc.F90 b/model/src/ww3_prnc.F90 index 789128ff5..1d54c7432 100644 --- a/model/src/ww3_prnc.F90 +++ b/model/src/ww3_prnc.F90 @@ -1,6 +1,6 @@ !> @file !> @brief Contains program W3PRNC. -!> +!> !> @author M. Accensi !> @author F. Ardhuin !> @date 22-Mar-2021 @@ -19,2494 +19,2494 @@ !> @author F. Ardhuin !> @date 22-Mar-2021 !> - PROGRAM W3PRNC -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 01-Jan-2011 : Creation ( version 4.01 ) -!/ 17-Nov-2011 : Fix bug on latitudes ( version 4.04 ) -!/ 30-Sep-2012 : Implement tidal analysis ( version 4.08 ) -!/ 29-Oct-2012 : Parallelization of tidal analysis ( version 4.08 ) -!/ 4-Mar-2012 : allows any NetCDF dimensions names ( version 4.09 ) -!/ 13-Mar-2012 : Makes compatible with NC3 ( version 4.10 ) -!/ 18-Oct-2013 : Debug compile issue with TIDE switch( version 4.12 ) -!/ 18-Oct-2013 : Initialize interpolation weights ( version 4.12 ) -!/ 20-Dec-2013 : Allow scale factor and offset in ( version 4.16 ) -!/ NetCDF variables (S. Zieger) -!/ 24-Oct-2014 : Allows "As Is" curvilinear grids ( version 5.02 ) -!/ 14-Oct-2015 : Add a check for latitude reversed ( version 5.11 ) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ 04-Jan-2018 : Add namelist feature ( version 6.04 ) -!/ 21-Apr-2020 : Correction in MPI for tide ( version 7.13 ) -!/ 21-Apr-2020 : Correction in scale factor ( version 7.13 ) -!/ 22-Mar-2021 : Add momentum and air density ( version 7.13 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Pre-processing of the input water level, current, wind, ice -! fields, momentum and air density, as well as assimilation data -! ... from NetCDF input -! -! 2. Method : -! -! See documented input file. -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! NDSI Int. Input unit number ("ww3_prnc.inp"). -! NDSLL Int. Unit number(s) of long-lat file(s) -! NDSF I.A. Unit number(s) of input file(s). -! NDSDAT Int. Unit number for output data file. -! IFLD Int. Integer input type. -! ITYPE Int. Integer input 'format' type. -! NFCOMP Int. Number of partial input to be processed. -! FLTIME Log. Time flag for input fields, if false, single -! field, time read from NDSI. -! IDLALL Int. Layout indicator used by INA2R. + -! IDFMLL Int. Id. FORMAT indicator. | -! FORMLL C*16 Id. FORMAT. | Long-lat -! FROMLL C*4 'UNIT' / 'NAME' indicator | file(s) -! NAMELL C*20 Name of long-lat file(s) + -! IDLAF I.A. + -! IDFMF I.A. | -! FORMF C.A. | Idem. fields file(s) -! NAMEF C*20 + -! FORMT C.A. Format or time in field. -! XC R.A. Components of input vector field or first -! input scalar field -! XCFAC Real Scale factor for input scalar field -! XCOFF Real Offset for input scalar field -! YC R.A. Components of input vector field or second -! input scalar field -! YCFAC Real Scale factor for input scalar field -! YCOFF Real Offset for input scalar field -! FX,FY R.A. Output fields. -! ACC Real Required interpolation accuracy. -! XTEMP R.A. Temporal array -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! STME21 Subr. W3TIMEMD Convert time to string. -! INAR2R Subr. W3ARRYMD Read in an REAL array. -! INAR2I Subr. Id. Read in an INTEGER array. -! PRTBLK Subr. Id. Print plot of array. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3FLDO Subr. W3FLDSMD Opening of WAVEWATCH III generic shell -! data file. -! W3FLDP Subr. Id. Prepare interp. from arbitrary grid. -! W3FLDG Subr. Id. Reading/writing shell input data. -! W3FLDD Subr. Id. Reading/writing shell assim. data. -! W3GSUC Func. W3GSRUMD Create grid-search-utility object -! W3GSUD Subr. W3GSRUMD Destroy grid-search-utility object -! W3GRMP Func. W3GSRUMD Compute interpolation weights -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! - Checks on files and reading from file. -! - Checks on validity of input parameters. -! -! 7. Remarks : -! -! - Input fields need to be continuous in longitude and latitude. -! - Program attempts to detect closure type using longitudes of the -! grid. Thus, it does not allow the user to specify the closure -! type, and so tripole closure is not supported. -! -! 8. Structure : -! -! ---------------------------------------------------- -! 1.a Number of models. -! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) -! b I-O setup. -! c Print heading(s). -! 2. Read model definition file. ( W3IOGR ) -! 3.a Read major types from input file. -! b Check major types. -! c Additional input format types and time. -! 4. Prepare interpolation. -! a Longitude - latitude grid -! b Grid(s) from file. ( W3FLDP ) -! c Initialize fields. -! d Input location and format. -! 5 Prepare input and output files. -! a Open input file -! b Open and prepare output file ( W3FLDO ) -! 6 Until end of file -! a Read new time and fields -! b Interpolate fields -! c Write fields ( W3FLDG ) -! ---------------------------------------------------- -! -! 9. Switches : -! -! !/WNT0 = !/WNT1 -! !/WNT1 Correct wind speeds to (approximately) conserve the wind -! speed over the interpolation box. -! !/WNT2 Id. energy (USE ONLY ONE !) -! !/CRT1 Like !/WNT1 for currents. -! !/CRT2 Like !/WNT2 for currents. -! !/MPI Parallel processing is used for tidal analysis. -! -! !/O3 Additional output in fields processing loop. -! !/O15 Generate file with the times of the processed fields. -! -! !/S Enable subroutine tracing. -! !/T Enable test output, -! !/T1 Full interpolation data. -! !/T1a Echo of lat-long data in type Fn -! !/T2 Full input data. -! !/T3 Print-plot of output data. -! -! !/NCO NCEP NCO modifications for operational implementation. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ -! USE W3GDATMD, ONLY: W3NMOD, W3SETG +PROGRAM W3PRNC + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 01-Jan-2011 : Creation ( version 4.01 ) + !/ 17-Nov-2011 : Fix bug on latitudes ( version 4.04 ) + !/ 30-Sep-2012 : Implement tidal analysis ( version 4.08 ) + !/ 29-Oct-2012 : Parallelization of tidal analysis ( version 4.08 ) + !/ 4-Mar-2012 : allows any NetCDF dimensions names ( version 4.09 ) + !/ 13-Mar-2012 : Makes compatible with NC3 ( version 4.10 ) + !/ 18-Oct-2013 : Debug compile issue with TIDE switch( version 4.12 ) + !/ 18-Oct-2013 : Initialize interpolation weights ( version 4.12 ) + !/ 20-Dec-2013 : Allow scale factor and offset in ( version 4.16 ) + !/ NetCDF variables (S. Zieger) + !/ 24-Oct-2014 : Allows "As Is" curvilinear grids ( version 5.02 ) + !/ 14-Oct-2015 : Add a check for latitude reversed ( version 5.11 ) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ 04-Jan-2018 : Add namelist feature ( version 6.04 ) + !/ 21-Apr-2020 : Correction in MPI for tide ( version 7.13 ) + !/ 21-Apr-2020 : Correction in scale factor ( version 7.13 ) + !/ 22-Mar-2021 : Add momentum and air density ( version 7.13 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Pre-processing of the input water level, current, wind, ice + ! fields, momentum and air density, as well as assimilation data + ! ... from NetCDF input + ! + ! 2. Method : + ! + ! See documented input file. + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! NDSI Int. Input unit number ("ww3_prnc.inp"). + ! NDSLL Int. Unit number(s) of long-lat file(s) + ! NDSF I.A. Unit number(s) of input file(s). + ! NDSDAT Int. Unit number for output data file. + ! IFLD Int. Integer input type. + ! ITYPE Int. Integer input 'format' type. + ! NFCOMP Int. Number of partial input to be processed. + ! FLTIME Log. Time flag for input fields, if false, single + ! field, time read from NDSI. + ! IDLALL Int. Layout indicator used by INA2R. + + ! IDFMLL Int. Id. FORMAT indicator. | + ! FORMLL C*16 Id. FORMAT. | Long-lat + ! FROMLL C*4 'UNIT' / 'NAME' indicator | file(s) + ! NAMELL C*20 Name of long-lat file(s) + + ! IDLAF I.A. + + ! IDFMF I.A. | + ! FORMF C.A. | Idem. fields file(s) + ! NAMEF C*20 + + ! FORMT C.A. Format or time in field. + ! XC R.A. Components of input vector field or first + ! input scalar field + ! XCFAC Real Scale factor for input scalar field + ! XCOFF Real Offset for input scalar field + ! YC R.A. Components of input vector field or second + ! input scalar field + ! YCFAC Real Scale factor for input scalar field + ! YCOFF Real Offset for input scalar field + ! FX,FY R.A. Output fields. + ! ACC Real Required interpolation accuracy. + ! XTEMP R.A. Temporal array + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! W3SETO Subr. Id. Point to selected model for output. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! INAR2R Subr. W3ARRYMD Read in an REAL array. + ! INAR2I Subr. Id. Read in an INTEGER array. + ! PRTBLK Subr. Id. Print plot of array. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3FLDO Subr. W3FLDSMD Opening of WAVEWATCH III generic shell + ! data file. + ! W3FLDP Subr. Id. Prepare interp. from arbitrary grid. + ! W3FLDG Subr. Id. Reading/writing shell input data. + ! W3FLDD Subr. Id. Reading/writing shell assim. data. + ! W3GSUC Func. W3GSRUMD Create grid-search-utility object + ! W3GSUD Subr. W3GSRUMD Destroy grid-search-utility object + ! W3GRMP Func. W3GSRUMD Compute interpolation weights + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! - Checks on files and reading from file. + ! - Checks on validity of input parameters. + ! + ! 7. Remarks : + ! + ! - Input fields need to be continuous in longitude and latitude. + ! - Program attempts to detect closure type using longitudes of the + ! grid. Thus, it does not allow the user to specify the closure + ! type, and so tripole closure is not supported. + ! + ! 8. Structure : + ! + ! ---------------------------------------------------- + ! 1.a Number of models. + ! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) + ! b I-O setup. + ! c Print heading(s). + ! 2. Read model definition file. ( W3IOGR ) + ! 3.a Read major types from input file. + ! b Check major types. + ! c Additional input format types and time. + ! 4. Prepare interpolation. + ! a Longitude - latitude grid + ! b Grid(s) from file. ( W3FLDP ) + ! c Initialize fields. + ! d Input location and format. + ! 5 Prepare input and output files. + ! a Open input file + ! b Open and prepare output file ( W3FLDO ) + ! 6 Until end of file + ! a Read new time and fields + ! b Interpolate fields + ! c Write fields ( W3FLDG ) + ! ---------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/WNT0 = !/WNT1 + ! !/WNT1 Correct wind speeds to (approximately) conserve the wind + ! speed over the interpolation box. + ! !/WNT2 Id. energy (USE ONLY ONE !) + ! !/CRT1 Like !/WNT1 for currents. + ! !/CRT2 Like !/WNT2 for currents. + ! !/MPI Parallel processing is used for tidal analysis. + ! + ! !/O3 Additional output in fields processing loop. + ! !/O15 Generate file with the times of the processed fields. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output, + ! !/T1 Full interpolation data. + ! !/T1a Echo of lat-long data in type Fn + ! !/T2 Full input data. + ! !/T3 Print-plot of output data. + ! + ! !/NCO NCEP NCO modifications for operational implementation. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG #ifdef W3_NL1 - USE W3ADATMD,ONLY: W3NAUX, W3SETA + USE W3ADATMD,ONLY: W3NAUX, W3SETA #endif - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STRSPLIT + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STRSPLIT #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif - USE W3ARRYMD, ONLY : INA2R, INA2I + USE W3ARRYMD, ONLY : INA2R, INA2I #ifdef W3_T2 - USE W3ARRYMD, ONLY : PRTBLK + USE W3ARRYMD, ONLY : PRTBLK #endif #ifdef W3_T3 - USE W3ARRYMD, ONLY : PRTBLK -#endif - USE W3IOGRMD, ONLY: W3IOGR - USE W3FLDSMD, ONLY: W3FLDO, W3FLDP, W3FLDG, W3FLDD, & - W3FLDTIDE1, W3FLDTIDE2 -!/ - USE W3GDATMD - USE W3GSRUMD - USE W3ODATMD, ONLY: NDSE, NDST, NDSO, FNMPRE - - USE W3TIDEMD - USE W3TIMEMD - USE W3NMLPRNCMD - USE NETCDF -! - IMPLICIT NONE -! + USE W3ARRYMD, ONLY : PRTBLK +#endif + USE W3IOGRMD, ONLY: W3IOGR + USE W3FLDSMD, ONLY: W3FLDO, W3FLDP, W3FLDG, W3FLDD, & + W3FLDTIDE1, W3FLDTIDE2 + !/ + USE W3GDATMD + USE W3GSRUMD + USE W3ODATMD, ONLY: NDSE, NDST, NDSO, FNMPRE + + USE W3TIDEMD + USE W3TIMEMD + USE W3NMLPRNCMD + USE NETCDF + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(NML_FORCING_T) :: NML_FORCING - TYPE(NML_FILE_T) :: NML_FILE - TYPE(T_GSU) :: GSI -! - INTEGER :: NTI, NDSEN, NIDIMS, NFIELDS, ICLO, & - NDSI, NDSM, NDSDAT, NDSTRC, NTRACE, & - IERR, IFLD, ITYPE, J, NFCOMP, & - IX, IY, JX, NXI, NYI, NDAT, JJ, & - NDSLL, IDLALL, IDFMLL, NCID, IRET, & - MXM, MYM, DATTYP, RECLDT, IDAT, & - NDIMSGRID, NDIMSVAR, VARIDTMP, & - NUMDIMS, I, ITIME - INTEGER :: ILAND = -999 - INTEGER :: GTYPEDUM = 0 - -! - INTEGER :: TIME(2), TIMESTART(2), TIMESTOP(2), & - TIMESHIFT(2), NXJ(2), NYJ(2), & - NDSF(2), IDLAF(2), IDFMF(2), & - IS(4), JS(4), VARIDF(50), DIMSVAR(4),& - DIMLN(5), REFDATE(8),CURDATE(8), & - STARTDATE(8),STPDATE(8) + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(NML_FORCING_T) :: NML_FORCING + TYPE(NML_FILE_T) :: NML_FILE + TYPE(T_GSU) :: GSI + ! + INTEGER :: NTI, NDSEN, NIDIMS, NFIELDS, ICLO, & + NDSI, NDSM, NDSDAT, NDSTRC, NTRACE, & + IERR, IFLD, ITYPE, J, NFCOMP, & + IX, IY, JX, NXI, NYI, NDAT, JJ, & + NDSLL, IDLALL, IDFMLL, NCID, IRET, & + MXM, MYM, DATTYP, RECLDT, IDAT, & + NDIMSGRID, NDIMSVAR, VARIDTMP, & + NUMDIMS, I, ITIME + INTEGER :: ILAND = -999 + INTEGER :: GTYPEDUM = 0 + + ! + INTEGER :: TIME(2), TIMESTART(2), TIMESTOP(2), & + TIMESHIFT(2), NXJ(2), NYJ(2), & + NDSF(2), IDLAF(2), IDFMF(2), & + IS(4), JS(4), VARIDF(50), DIMSVAR(4),& + DIMLN(5), REFDATE(8),CURDATE(8), & + STARTDATE(8),STPDATE(8) #ifdef W3_MPI - INTEGER :: IERR_MPI, IND, REST, SLICE + INTEGER :: IERR_MPI, IND, REST, SLICE #endif #ifdef W3_O15 - INTEGER :: NDSTIME + INTEGER :: NDSTIME #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_T2 - INTEGER :: IXP0, IXPN, IXPWDT = 60 + INTEGER :: IXP0, IXPN, IXPWDT = 60 #endif #ifdef W3_T3 - INTEGER :: IX0, IXN, IXWDT = 60 -#endif -! - INTEGER, ALLOCATABLE :: IX21(:,:), IX22(:,:), & - IY21(:,:), IY22(:,:), & - JX21(:,:), JX22(:,:), & - JY21(:,:), JY22(:,:), & - MAPOVR(:,:), MASK(:,:), & - NELEM(:), CUMUL(:) + INTEGER :: IX0, IXN, IXWDT = 60 +#endif + ! + INTEGER, ALLOCATABLE :: IX21(:,:), IX22(:,:), & + IY21(:,:), IY22(:,:), & + JX21(:,:), JX22(:,:), & + JY21(:,:), JY22(:,:), & + MAPOVR(:,:), MASK(:,:), & + NELEM(:), CUMUL(:) #ifdef W3_T3 - INTEGER, ALLOCATABLE :: MAPOUT(:,:) -#endif -! - REAL :: X0I, XNI, Y0I, YNI, SXI, SYI, & - X, Y, FACTOR, EFAC, NODATA, & - XCFAC, XCOFF, YCFAC, YCOFF, & - FILLVALUE, TIMEDELAY - REAL :: ACC = 0.05 -! - REAL :: SCFAC(2), ADDOFF(2), RW(4) -! - REAL, ALLOCATABLE :: RD11(:,:), RD21(:,:), & - RD12(:,:), RD22(:,:), & - XD11(:,:), XD21(:,:), & - XD12(:,:), XD22(:,:), & - FX(:,:), FY(:,:), FA(:,:), & - A1(:,:), A2(:,:), A3(:,:) - REAL, ALLOCATABLE :: XC(:,:), YC(:,:), AC(:,:), & - DATA(:,:), XTEMP(:,:) -! - REAL, POINTER :: ALA(:,:), ALO(:,:) -! - DOUBLE PRECISION :: REFJULDAY, CURJULDAY, STARTJULDAY, STPJULDAY -! - CHARACTER*1024 :: STRFIELDSNAME - CHARACTER*100 :: FIELDSNAME(4) - CHARACTER*1024 :: STRDIMSNAME - CHARACTER*100 :: DIMSNAME(2) - CHARACTER :: COMSTR*1, IDFLD*3, IDTYPE*2, & - IDTIME*23, FROMLL*4, FORMLL*16, & - NAMELL*80, NAMEF*80, IDTIME2*23 - CHARACTER*14 :: IDSTR1(-7:7) - CHARACTER*15 :: IDSTR3(3) - CHARACTER*32 :: FORMT(2), FORMF(2) - CHARACTER*20 :: IDSTR2(6) - CHARACTER*20 :: DIMNAME(5) - CHARACTER*50 :: TIMEUNITS, CALENDAR -! - LOGICAL :: INGRID, FLGNML - LOGICAL :: FLSTAB, FLBERG, CLO(2), FLTIME, FLHDR + INTEGER, ALLOCATABLE :: MAPOUT(:,:) +#endif + ! + REAL :: X0I, XNI, Y0I, YNI, SXI, SYI, & + X, Y, FACTOR, EFAC, NODATA, & + XCFAC, XCOFF, YCFAC, YCOFF, & + FILLVALUE, TIMEDELAY + REAL :: ACC = 0.05 + ! + REAL :: SCFAC(2), ADDOFF(2), RW(4) + ! + REAL, ALLOCATABLE :: RD11(:,:), RD21(:,:), & + RD12(:,:), RD22(:,:), & + XD11(:,:), XD21(:,:), & + XD12(:,:), XD22(:,:), & + FX(:,:), FY(:,:), FA(:,:), & + A1(:,:), A2(:,:), A3(:,:) + REAL, ALLOCATABLE :: XC(:,:), YC(:,:), AC(:,:), & + DATA(:,:), XTEMP(:,:) + ! + REAL, POINTER :: ALA(:,:), ALO(:,:) + ! + DOUBLE PRECISION :: REFJULDAY, CURJULDAY, STARTJULDAY, STPJULDAY + ! + CHARACTER*1024 :: STRFIELDSNAME + CHARACTER*100 :: FIELDSNAME(4) + CHARACTER*1024 :: STRDIMSNAME + CHARACTER*100 :: DIMSNAME(2) + CHARACTER :: COMSTR*1, IDFLD*3, IDTYPE*2, & + IDTIME*23, FROMLL*4, FORMLL*16, & + NAMELL*80, NAMEF*80, IDTIME2*23 + CHARACTER*14 :: IDSTR1(-7:7) + CHARACTER*15 :: IDSTR3(3) + CHARACTER*32 :: FORMT(2), FORMF(2) + CHARACTER*20 :: IDSTR2(6) + CHARACTER*20 :: DIMNAME(5) + CHARACTER*50 :: TIMEUNITS, CALENDAR + ! + LOGICAL :: INGRID, FLGNML + LOGICAL :: FLSTAB, FLBERG, CLO(2), FLTIME, FLHDR #ifdef W3_T - LOGICAL :: FLMOD + LOGICAL :: FLMOD #endif -! -! Variables used in tidal analysis -! - INTEGER :: K, L, TIDEFLAG, & - TIDE_NDEF, TIDE_ITREND + ! + ! Variables used in tidal analysis + ! + INTEGER :: K, L, TIDEFLAG, & + TIDE_NDEF, TIDE_ITREND #ifdef W3_T - INTEGER, PARAMETER :: LRB = 4 - INTEGER(KIND=8) :: RPOS - INTEGER :: LRECL, NREC -#endif -! - INTEGER, ALLOCATABLE :: IMAX(:) -! - REAL :: TIDE_LAT -! - REAL, ALLOCATABLE :: TIDE_DATA_ALL(:,:,:), & - SSQ(:), RES(:) + INTEGER, PARAMETER :: LRB = 4 + INTEGER(KIND=8) :: RPOS + INTEGER :: LRECL, NREC +#endif + ! + INTEGER, ALLOCATABLE :: IMAX(:) + ! + REAL :: TIDE_LAT + ! + REAL, ALLOCATABLE :: TIDE_DATA_ALL(:,:,:), & + SSQ(:), RES(:) #ifdef W3_MPI - REAL, ALLOCATABLE :: TIDE1DL(:), TIDE1D(:) + REAL, ALLOCATABLE :: TIDE1DL(:), TIDE1D(:) #endif #ifdef W3_T - REAL(KIND=LRB), ALLOCATABLE :: NULLBUFF(:) -#endif -! - DOUBLE PRECISION, ALLOCATABLE :: ALLTIMES(:), & - SDEV0(:), SDEV(:), RMSR(:), & - RMSR0(:), RMSRP(:), RESMAX(:) -! - CHARACTER*256 :: TIDECONSTNAMES - CHARACTER*100 :: LIST(70) -! - LOGICAL, ALLOCATABLE :: TIDALCOMP(:,:) -! + REAL(KIND=LRB), ALLOCATABLE :: NULLBUFF(:) +#endif + ! + DOUBLE PRECISION, ALLOCATABLE :: ALLTIMES(:), & + SDEV0(:), SDEV(:), RMSR(:), & + RMSR0(:), RMSRP(:), RESMAX(:) + ! + CHARACTER*256 :: TIDECONSTNAMES + CHARACTER*100 :: LIST(70) + ! + LOGICAL, ALLOCATABLE :: TIDALCOMP(:,:) + ! #ifdef W3_T - CHARACTER*21 :: FNAMETXT -#endif -! - EQUIVALENCE ( NXI , NXJ(1) ) , ( NYI , NYJ(1) ) -!/ -!/ ------------------------------------------------------------------- / -!/ - DATA IDSTR1 / 'ice thickness ' , 'ice viscosity' , & - 'ice density ' , 'ice modulus ' , & - 'ice flow diam.' , 'mud density ' , & - 'mud thickness ' , 'mud viscosity ', & - 'ice conc. ' , 'water levels ' , & - 'winds ' , 'currents ' , & - 'data ' , 'momentum ' , & - 'air density ' / - DATA IDSTR2 / 'pre-processed file ' , 'long.-lat. grid ' , & - 'grid from file (1) ' , 'grid from file (2) ' , & - 'data (assimilation) ' , 'pre-pro. file + tide' / - DATA IDSTR3 / 'mean parameters', '1D spectra ', & - '2D spectra ' / -! + CHARACTER*21 :: FNAMETXT +#endif + ! + EQUIVALENCE ( NXI , NXJ(1) ) , ( NYI , NYJ(1) ) + !/ + !/ ------------------------------------------------------------------- / + !/ + DATA IDSTR1 / 'ice thickness ' , 'ice viscosity' , & + 'ice density ' , 'ice modulus ' , & + 'ice flow diam.' , 'mud density ' , & + 'mud thickness ' , 'mud viscosity ', & + 'ice conc. ' , 'water levels ' , & + 'winds ' , 'currents ' , & + 'data ' , 'momentum ' , & + 'air density ' / + DATA IDSTR2 / 'pre-processed file ' , 'long.-lat. grid ' , & + 'grid from file (1) ' , 'grid from file (2) ' , & + 'data (assimilation) ' , 'pre-pro. file + tide' / + DATA IDSTR3 / 'mean parameters', '1D spectra ', & + '2D spectra ' / + ! #ifdef W3_NCO -! CALL W3TAGB('WAVEPREP',1998,0007,0050,'NP21 ') -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1.a Set number of models -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) + ! CALL W3TAGB('WAVEPREP',1998,0007,0050,'NP21 ') +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1.a Set number of models + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) #ifdef W3_NL1 - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) -#endif - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! -! 1.b IO set-up. -! - NDSI = 10 - NDSO = 6 - NDSE = 6 - NDST = 6 - NDSM = 11 - NDSDAT = 12 + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + ! 1.b IO set-up. + ! + NDSI = 10 + NDSO = 6 + NDSE = 6 + NDST = 6 + NDSM = 11 + NDSDAT = 12 #ifdef W3_O15 - NDSTIME = 13 + NDSTIME = 13 #endif -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_NCO -! -! Redo according to NCO -! - NDSI = 11 - NDSO = 6 - NDSE = NDSO - NDST = NDSO - NDSM = 12 - NDSDAT = 51 - NDSTRC = NDSO -#endif -! + ! + ! Redo according to NCO + ! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSDAT = 51 + NDSTRC = NDSO +#endif + ! #ifdef W3_S - CALL STRACE (IENT, 'W3PRNC') + CALL STRACE (IENT, 'W3PRNC') #endif -! -! -! 1.c MPP initializations -! + ! + ! + ! 1.c MPP initializations + ! #ifdef W3_SHRD - NAPROC = 1 - IAPROC = 1 + NAPROC = 1 + IAPROC = 1 #endif -! + ! #ifdef W3_MPI - CALL MPI_INIT ( IERR_MPI ) - CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) - CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) - IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC -#endif -! - IF ( IAPROC .EQ. NAPERR ) THEN - NDSEN = NDSE - ELSE - NDSEN = -1 - END IF -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) -! - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file. -! - CALL W3IOGR ( 'READ', NDSM ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,902) GNAME - ALLOCATE ( IX21(NX,NY), IX22(NX,NY), IY21(NX,NY), IY22(NX,NY), & - JX21(NX,NY), JX22(NX,NY), JY21(NX,NY), JY22(NX,NY), & - MAPOVR(NX,NY) ) - ALLOCATE ( RD11(NX,NY), RD21(NX,NY), RD12(NX,NY), RD22(NX,NY), & - XD11(NX,NY), XD21(NX,NY), XD12(NX,NY), XD22(NX,NY), & - FX(NX,NY), FY(NX,NY), FA(NX,NY), & - A1(NX,NY), A2(NX,NY), A3(NX,NY) ) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read types and variables from input file. -! - - FLBERG = .FALSE. - FLSTAB = .FALSE. -! -! process ww3_prnc namelist -! - INQUIRE(FILE=TRIM(FNMPRE)//"ww3_prnc.nml", EXIST=FLGNML) - IF (FLGNML) THEN - ! Read namelist - CALL W3NMLPRNC (NDSI, TRIM(FNMPRE)//'ww3_prnc.nml', NML_FORCING, NML_FILE, IERR) - ! Check field - IF (NML_FORCING%FIELD%ICE_PARAM1) THEN - IDFLD = 'IC1' - IFLD = -7 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%ICE_PARAM2) THEN - IDFLD = 'IC2' - IFLD = -6 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%ICE_PARAM3) THEN - IDFLD = 'IC3' - IFLD = -5 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%ICE_PARAM4) THEN - IDFLD = 'IC4' - IFLD = -4 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%ICE_PARAM5) THEN - IDFLD = 'IC5' - IFLD = -3 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%MUD_DENSITY) THEN - IDFLD = 'MDN' - IFLD = -2 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%MUD_THICKNESS) THEN - IDFLD = 'MTH' - IFLD = -1 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%MUD_VISCOSITY) THEN - IDFLD = 'MVS' - IFLD = 0 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%ICE_CONC) THEN - IDFLD = 'ICE' - IFLD = 1 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%ICE_BERG) THEN - IDFLD = 'ISI' - IFLD = 1 - FLBERG = .TRUE. - NFIELDS = 2 - ELSE IF (NML_FORCING%FIELD%WATER_LEVELS) THEN - IDFLD = 'LEV' - IFLD = 2 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%WINDS) THEN - IDFLD = 'WND' - IFLD = 3 - NFIELDS = 2 - ELSE IF (NML_FORCING%FIELD%WINDS_AST) THEN - IDFLD = 'WNS' - IFLD = 3 - FLSTAB = .TRUE. - NFIELDS = 3 - ELSE IF (NML_FORCING%FIELD%CURRENTS) THEN - IDFLD = 'CUR' - IFLD = 4 - NFIELDS = 2 - ELSE IF (NML_FORCING%FIELD%DATA_ASSIM) THEN - IDFLD = 'DAT' - IFLD = 5 - ITYPE = 5 - NFIELDS = 1 - ELSE IF (NML_FORCING%FIELD%ATM_MOMENTUM) THEN - IDFLD = 'TAU' - IFLD = 6 - NFIELDS = 2 - ELSE IF (NML_FORCING%FIELD%AIR_DENSITY) THEN - IDFLD = 'RHO' - IFLD = 7 - NFIELDS = 1 - ELSE - GOTO 810 - END IF ! NML_FORCING - - ! Check grid asis/latlon - IF (NML_FORCING%GRID%ASIS) THEN - ITYPE = 1 - ELSE IF (NML_FORCING%GRID%LATLON) THEN - ITYPE = 2 - ELSE - GOTO 811 - END IF - - ! Check tidal component - TIDEFLAG = 0 - IF (TRIM(NML_FORCING%TIDAL).NE.'unset' .AND. & - TRIM(NML_FORCING%TIDAL).NE.'UNSET') THEN - TIDEFLAG = 1 - ITYPE = 6 - LIST(:)='' - CALL STRSPLIT(TRIM(NML_FORCING%TIDAL),LIST) - END IF - - ! Check file name, dimensions, variables - NFCOMP = 1 ! not anymore used 'F1' 'F2' ? - NAMEF=TRIM(NML_FILE%FILENAME) - DIMSNAME(1)=NML_FILE%LONGITUDE - DIMSNAME(2)=NML_FILE%LATITUDE - DO I=1,NFIELDS - FIELDSNAME(I)=NML_FILE%VAR(I) - END DO - ! Counts the number of dimensions - NIDIMS=0 - DO I=1,2 - IF (LEN_TRIM(DIMSNAME(I)).NE.0) NIDIMS=NIDIMS+1 - END DO - - - ! Check time start and stop - READ(NML_FORCING%TIMESTART,*) TIMESTART - CALL T2D(TIMESTART,STARTDATE,IERR) - CALL D2J(STARTDATE,STARTJULDAY,IERR) - READ(NML_FORCING%TIMESTOP,*) TIMESTOP - CALL T2D(TIMESTOP,STPDATE,IERR) - CALL D2J(STPDATE,STPJULDAY,IERR) - - ! Check time shift - FLHDR = .TRUE. - FLTIME = .TRUE. - READ(NML_FILE%TIMESHIFT,*) TIMESHIFT - IF(TIMESHIFT(1).NE.0 .OR. TIMESHIFT(2).NE.0) FLTIME = .FALSE. - - END IF ! FLGNML - -! -! process old ww3_prnc.inp format -! - IF (.NOT. FLGNML) THEN - OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_prnc.inp',STATUS='OLD',ERR=800,IOSTAT=IERR) - REWIND (NDSI) - - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDFLD, IDTYPE, FLTIME, FLHDR - - ! Check field - FLSTAB = IDFLD .EQ. 'WNS' - FLBERG = IDFLD .EQ. 'ISI' - IF ( IDFLD.EQ.'IC1' ) THEN - IFLD = -7 - ELSE IF ( IDFLD.EQ.'IC2' ) THEN - IFLD = -6 - ELSE IF ( IDFLD.EQ.'IC3' ) THEN - IFLD = -5 - ELSE IF ( IDFLD.EQ.'IC4' ) THEN - IFLD = -4 - ELSE IF ( IDFLD.EQ.'IC5' ) THEN - IFLD = -3 - ELSE IF ( IDFLD.EQ.'MDN' ) THEN - IFLD = -2 - ELSE IF ( IDFLD.EQ.'MTH' ) THEN - IFLD = -1 - ELSE IF ( IDFLD.EQ.'MVS' ) THEN - IFLD = 0 - ELSE IF ( IDFLD.EQ.'ICE' .OR. FLBERG ) THEN - IFLD = 1 - ELSE IF ( IDFLD.EQ.'LEV' ) THEN - IFLD = 2 - ELSE IF ( IDFLD.EQ.'WND' .OR. FLSTAB ) THEN - IFLD = 3 - ELSE IF ( IDFLD.EQ.'CUR' ) THEN - IFLD = 4 - ELSE IF ( IDFLD.EQ.'DAT' ) THEN - IFLD = 5 - ELSE IF ( IDFLD.EQ.'TAU' ) THEN - IFLD = 6 - ELSE IF ( IDFLD.EQ.'RHO' ) THEN - IFLD = 7 - ELSE - WRITE (NDSE,1030) IDFLD - CALL EXTCDE ( 30 ) - END IF - - ! Check grid and tidal component - NFCOMP = 1 - TIDEFLAG = 0 - IF (IDFLD.EQ.'DAT') THEN - ITYPE = 5 - ELSE IF (IDTYPE.EQ.'AI') THEN - ITYPE = 1 - ELSE IF (IDTYPE.EQ.'AT') THEN - ITYPE = 6 - TIDEFLAG= 1 - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,'(A)',END=801,ERR=803,IOSTAT=IERR) TIDECONSTNAMES - LIST(:)='' - CALL STRSPLIT(TIDECONSTNAMES,LIST) - ELSE IF (IDTYPE.EQ.'LL') THEN - ITYPE = 2 - ELSE IF (IDTYPE.EQ.'F1') THEN - ITYPE = 3 - ELSE IF (IDTYPE.EQ.'F2') THEN - ITYPE = 4 - NFCOMP = 2 - ELSE - WRITE (NDSE,1031) IDTYPE - CALL EXTCDE ( 31 ) - END IF -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) STRDIMSNAME -! - FIELDSNAME(:)='' - DIMSNAME(:)='' - CALL STRSPLIT(STRDIMSNAME,DIMSNAME) - ! Counts the number of dimensions - NIDIMS=0 - DO I=1,2 - IF (LEN_TRIM(DIMSNAME(I)).NE.0) NIDIMS=NIDIMS+1 - END DO -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) STRFIELDSNAME -! - FIELDSNAME(:)='' - CALL STRSPLIT(STRFIELDSNAME,FIELDSNAME) - ! Counts the number of variables - NFIELDS=0 - DO WHILE (LEN_TRIM(FIELDSNAME(NFIELDS+1)).NE.0) - NFIELDS=NFIELDS+1 - END DO - ! time flag and start date - IF (.NOT. FLTIME) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) TIMESHIFT - IF (TIMESHIFT(1).LT.10000000) THEN - WRITE (NDSE,1035) TIME - CALL EXTCDE ( 35 ) - END IF - END IF - ! Read netcdf filename - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NAMEF + CALL MPI_INIT ( IERR_MPI ) + CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC +#endif + ! + IF ( IAPROC .EQ. NAPERR ) THEN + NDSEN = NDSE + ELSE + NDSEN = -1 + END IF + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) + ! + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file. + ! + CALL W3IOGR ( 'READ', NDSM ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,902) GNAME + ALLOCATE ( IX21(NX,NY), IX22(NX,NY), IY21(NX,NY), IY22(NX,NY), & + JX21(NX,NY), JX22(NX,NY), JY21(NX,NY), JY22(NX,NY), & + MAPOVR(NX,NY) ) + ALLOCATE ( RD11(NX,NY), RD21(NX,NY), RD12(NX,NY), RD22(NX,NY), & + XD11(NX,NY), XD21(NX,NY), XD12(NX,NY), XD22(NX,NY), & + FX(NX,NY), FY(NX,NY), FA(NX,NY), & + A1(NX,NY), A2(NX,NY), A3(NX,NY) ) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read types and variables from input file. + ! + + FLBERG = .FALSE. + FLSTAB = .FALSE. + ! + ! process ww3_prnc namelist + ! + INQUIRE(FILE=TRIM(FNMPRE)//"ww3_prnc.nml", EXIST=FLGNML) + IF (FLGNML) THEN + ! Read namelist + CALL W3NMLPRNC (NDSI, TRIM(FNMPRE)//'ww3_prnc.nml', NML_FORCING, NML_FILE, IERR) + ! Check field + IF (NML_FORCING%FIELD%ICE_PARAM1) THEN + IDFLD = 'IC1' + IFLD = -7 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%ICE_PARAM2) THEN + IDFLD = 'IC2' + IFLD = -6 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%ICE_PARAM3) THEN + IDFLD = 'IC3' + IFLD = -5 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%ICE_PARAM4) THEN + IDFLD = 'IC4' + IFLD = -4 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%ICE_PARAM5) THEN + IDFLD = 'IC5' + IFLD = -3 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%MUD_DENSITY) THEN + IDFLD = 'MDN' + IFLD = -2 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%MUD_THICKNESS) THEN + IDFLD = 'MTH' + IFLD = -1 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%MUD_VISCOSITY) THEN + IDFLD = 'MVS' + IFLD = 0 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%ICE_CONC) THEN + IDFLD = 'ICE' + IFLD = 1 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%ICE_BERG) THEN + IDFLD = 'ISI' + IFLD = 1 + FLBERG = .TRUE. + NFIELDS = 2 + ELSE IF (NML_FORCING%FIELD%WATER_LEVELS) THEN + IDFLD = 'LEV' + IFLD = 2 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%WINDS) THEN + IDFLD = 'WND' + IFLD = 3 + NFIELDS = 2 + ELSE IF (NML_FORCING%FIELD%WINDS_AST) THEN + IDFLD = 'WNS' + IFLD = 3 + FLSTAB = .TRUE. + NFIELDS = 3 + ELSE IF (NML_FORCING%FIELD%CURRENTS) THEN + IDFLD = 'CUR' + IFLD = 4 + NFIELDS = 2 + ELSE IF (NML_FORCING%FIELD%DATA_ASSIM) THEN + IDFLD = 'DAT' + IFLD = 5 + ITYPE = 5 + NFIELDS = 1 + ELSE IF (NML_FORCING%FIELD%ATM_MOMENTUM) THEN + IDFLD = 'TAU' + IFLD = 6 + NFIELDS = 2 + ELSE IF (NML_FORCING%FIELD%AIR_DENSITY) THEN + IDFLD = 'RHO' + IFLD = 7 + NFIELDS = 1 + ELSE + GOTO 810 + END IF ! NML_FORCING + + ! Check grid asis/latlon + IF (NML_FORCING%GRID%ASIS) THEN + ITYPE = 1 + ELSE IF (NML_FORCING%GRID%LATLON) THEN + ITYPE = 2 + ELSE + GOTO 811 + END IF + + ! Check tidal component + TIDEFLAG = 0 + IF (TRIM(NML_FORCING%TIDAL).NE.'unset' .AND. & + TRIM(NML_FORCING%TIDAL).NE.'UNSET') THEN + TIDEFLAG = 1 + ITYPE = 6 + LIST(:)='' + CALL STRSPLIT(TRIM(NML_FORCING%TIDAL),LIST) + END IF + + ! Check file name, dimensions, variables + NFCOMP = 1 ! not anymore used 'F1' 'F2' ? + NAMEF=TRIM(NML_FILE%FILENAME) + DIMSNAME(1)=NML_FILE%LONGITUDE + DIMSNAME(2)=NML_FILE%LATITUDE + DO I=1,NFIELDS + FIELDSNAME(I)=NML_FILE%VAR(I) + END DO + ! Counts the number of dimensions + NIDIMS=0 + DO I=1,2 + IF (LEN_TRIM(DIMSNAME(I)).NE.0) NIDIMS=NIDIMS+1 + END DO + + + ! Check time start and stop + READ(NML_FORCING%TIMESTART,*) TIMESTART + CALL T2D(TIMESTART,STARTDATE,IERR) + CALL D2J(STARTDATE,STARTJULDAY,IERR) + READ(NML_FORCING%TIMESTOP,*) TIMESTOP + CALL T2D(TIMESTOP,STPDATE,IERR) + CALL D2J(STPDATE,STPJULDAY,IERR) + + ! Check time shift + FLHDR = .TRUE. + FLTIME = .TRUE. + READ(NML_FILE%TIMESHIFT,*) TIMESHIFT + IF(TIMESHIFT(1).NE.0 .OR. TIMESHIFT(2).NE.0) FLTIME = .FALSE. + + END IF ! FLGNML + + ! + ! process old ww3_prnc.inp format + ! + IF (.NOT. FLGNML) THEN + OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_prnc.inp',STATUS='OLD',ERR=800,IOSTAT=IERR) + REWIND (NDSI) + + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDFLD, IDTYPE, FLTIME, FLHDR + + ! Check field + FLSTAB = IDFLD .EQ. 'WNS' + FLBERG = IDFLD .EQ. 'ISI' + IF ( IDFLD.EQ.'IC1' ) THEN + IFLD = -7 + ELSE IF ( IDFLD.EQ.'IC2' ) THEN + IFLD = -6 + ELSE IF ( IDFLD.EQ.'IC3' ) THEN + IFLD = -5 + ELSE IF ( IDFLD.EQ.'IC4' ) THEN + IFLD = -4 + ELSE IF ( IDFLD.EQ.'IC5' ) THEN + IFLD = -3 + ELSE IF ( IDFLD.EQ.'MDN' ) THEN + IFLD = -2 + ELSE IF ( IDFLD.EQ.'MTH' ) THEN + IFLD = -1 + ELSE IF ( IDFLD.EQ.'MVS' ) THEN + IFLD = 0 + ELSE IF ( IDFLD.EQ.'ICE' .OR. FLBERG ) THEN + IFLD = 1 + ELSE IF ( IDFLD.EQ.'LEV' ) THEN + IFLD = 2 + ELSE IF ( IDFLD.EQ.'WND' .OR. FLSTAB ) THEN + IFLD = 3 + ELSE IF ( IDFLD.EQ.'CUR' ) THEN + IFLD = 4 + ELSE IF ( IDFLD.EQ.'DAT' ) THEN + IFLD = 5 + ELSE IF ( IDFLD.EQ.'TAU' ) THEN + IFLD = 6 + ELSE IF ( IDFLD.EQ.'RHO' ) THEN + IFLD = 7 + ELSE + WRITE (NDSE,1030) IDFLD + CALL EXTCDE ( 30 ) + END IF + + ! Check grid and tidal component + NFCOMP = 1 + TIDEFLAG = 0 + IF (IDFLD.EQ.'DAT') THEN + ITYPE = 5 + ELSE IF (IDTYPE.EQ.'AI') THEN + ITYPE = 1 + ELSE IF (IDTYPE.EQ.'AT') THEN + ITYPE = 6 + TIDEFLAG= 1 + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,'(A)',END=801,ERR=803,IOSTAT=IERR) TIDECONSTNAMES + LIST(:)='' + CALL STRSPLIT(TIDECONSTNAMES,LIST) + ELSE IF (IDTYPE.EQ.'LL') THEN + ITYPE = 2 + ELSE IF (IDTYPE.EQ.'F1') THEN + ITYPE = 3 + ELSE IF (IDTYPE.EQ.'F2') THEN + ITYPE = 4 + NFCOMP = 2 + ELSE + WRITE (NDSE,1031) IDTYPE + CALL EXTCDE ( 31 ) + END IF + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) STRDIMSNAME + ! + FIELDSNAME(:)='' + DIMSNAME(:)='' + CALL STRSPLIT(STRDIMSNAME,DIMSNAME) + ! Counts the number of dimensions + NIDIMS=0 + DO I=1,2 + IF (LEN_TRIM(DIMSNAME(I)).NE.0) NIDIMS=NIDIMS+1 + END DO + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) STRFIELDSNAME + ! + FIELDSNAME(:)='' + CALL STRSPLIT(STRFIELDSNAME,FIELDSNAME) + ! Counts the number of variables + NFIELDS=0 + DO WHILE (LEN_TRIM(FIELDSNAME(NFIELDS+1)).NE.0) + NFIELDS=NFIELDS+1 + END DO + ! time flag and start date + IF (.NOT. FLTIME) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) TIMESHIFT + IF (TIMESHIFT(1).LT.10000000) THEN + WRITE (NDSE,1035) TIME + CALL EXTCDE ( 35 ) + END IF + END IF + ! Read netcdf filename + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NAMEF - ! initialize timestart and timestop - STARTJULDAY=0 - STPJULDAY=100000000 + ! initialize timestart and timestop + STARTJULDAY=0 + STPJULDAY=100000000 - END IF ! .NOT. FLGNML + END IF ! .NOT. FLGNML -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Print logs -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,930) IDSTR1(IFLD), IDSTR2(ITYPE) - IF ( ITYPE.NE.1 .AND. ITYPE.NE.6 ) THEN + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Print logs + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,930) IDSTR1(IFLD), IDSTR2(ITYPE) + IF ( ITYPE.NE.1 .AND. ITYPE.NE.6 ) THEN #ifdef W3_WNT0 - IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,1930) + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,1930) #endif #ifdef W3_WNT1 - IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,1930) + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,1930) #endif #ifdef W3_WNT2 - IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,2930) + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,2930) #endif #ifdef W3_CRT1 - IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.4) WRITE (NDSO,1930) + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.4) WRITE (NDSO,1930) #endif #ifdef W3_CRT2 - IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.4) WRITE (NDSO,2930) + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.4) WRITE (NDSO,2930) #endif #ifdef W3_WNT0 - IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,1930) + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,1930) #endif #ifdef W3_WNT1 - IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,1930) + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,1930) #endif #ifdef W3_WNT2 - IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,2930) -#endif - END IF - IF (FLGNML) THEN - IF(TIMESTART(1).NE.19000101 .OR. TIMESTART(2).NE.0) THEN - CALL STME21 ( TIMESTART , IDTIME ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1931) IDTIME - END IF - IF(TIMESTOP(1).NE.29001231 .OR. TIMESTOP(2).NE.0) THEN - CALL STME21 ( TIMESTOP , IDTIME ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2931) IDTIME - END IF - END IF - IF (.NOT. FLTIME) THEN - CALL STME21 ( TIMESHIFT , IDTIME ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,3931) IDTIME - END IF - IF ( IAPROC .EQ. NAPOUT .AND.FLBERG ) WRITE (NDSO,938) - IF ( IAPROC .EQ. NAPOUT .AND.FLSTAB ) WRITE (NDSO,939) - - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,967) NAMEF - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,968) TRIM(DIMSNAME(1)), TRIM(DIMSNAME(2)) - DO I=1,NFIELDS - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,969) I, TRIM(FIELDSNAME(I)) - END DO - - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Read Input netcdf file -! - - ! open input file - IRET=NF90_OPEN(PATH=TRIM(FNMPRE)//NAMEF,MODE=NF90_NOWRITE,NCID=NCID) - CALL CHECK_ERR(IRET) - - ! instanciates time - REFDATE(:)=0. - IRET=NF90_INQ_VARID(NCID,"time",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"MT",VARIDTMP) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_ATT(NCID,VARIDTMP,"calendar",CALENDAR) - IF ( IRET/=NF90_NOERR ) THEN - WRITE(NDSE,1028) - ELSE IF ((INDEX(CALENDAR, "standard").EQ.0) .AND. & - (INDEX(CALENDAR, "gregorian").EQ.0)) THEN - WRITE(NDSE,1029) - END IF - IRET=NF90_GET_ATT(NCID,VARIDTMP,"units",TIMEUNITS) + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,2930) +#endif + END IF + IF (FLGNML) THEN + IF(TIMESTART(1).NE.19000101 .OR. TIMESTART(2).NE.0) THEN + CALL STME21 ( TIMESTART , IDTIME ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1931) IDTIME + END IF + IF(TIMESTOP(1).NE.29001231 .OR. TIMESTOP(2).NE.0) THEN + CALL STME21 ( TIMESTOP , IDTIME ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2931) IDTIME + END IF + END IF + IF (.NOT. FLTIME) THEN + CALL STME21 ( TIMESHIFT , IDTIME ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,3931) IDTIME + END IF + IF ( IAPROC .EQ. NAPOUT .AND.FLBERG ) WRITE (NDSO,938) + IF ( IAPROC .EQ. NAPOUT .AND.FLSTAB ) WRITE (NDSO,939) + + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,967) NAMEF + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,968) TRIM(DIMSNAME(1)), TRIM(DIMSNAME(2)) + DO I=1,NFIELDS + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,969) I, TRIM(FIELDSNAME(I)) + END DO + + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Read Input netcdf file + ! + + ! open input file + IRET=NF90_OPEN(PATH=TRIM(FNMPRE)//NAMEF,MODE=NF90_NOWRITE,NCID=NCID) + CALL CHECK_ERR(IRET) + + ! instanciates time + REFDATE(:)=0. + IRET=NF90_INQ_VARID(NCID,"time",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"MT",VARIDTMP) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_ATT(NCID,VARIDTMP,"calendar",CALENDAR) + IF ( IRET/=NF90_NOERR ) THEN + WRITE(NDSE,1028) + ELSE IF ((INDEX(CALENDAR, "standard").EQ.0) .AND. & + (INDEX(CALENDAR, "gregorian").EQ.0)) THEN + WRITE(NDSE,1029) + END IF + IRET=NF90_GET_ATT(NCID,VARIDTMP,"units",TIMEUNITS) + CALL CHECK_ERR(IRET) + CALL U2D(TIMEUNITS,REFDATE,IERR) + CALL D2J(REFDATE,REFJULDAY,IERR) + + ! gets variables ids, dimensions and fillvalue + DO I=1,NFIELDS + IRET = NF90_INQ_VARID(NCID,TRIM(FIELDSNAME(I)),VARIDF(I)) + CALL CHECK_ERR(IRET) + IRET = NF90_INQUIRE_VARIABLE(NCID, VARIDF(I), ndims=NDIMSVAR) + CALL CHECK_ERR(IRET) + IRET = NF90_INQUIRE_VARIABLE(NCID, VARIDF(I), dimids=DIMSVAR(:NDIMSVAR)) + CALL CHECK_ERR(IRET) + DO J=1,NDIMSVAR + IRET=NF90_INQUIRE_DIMENSION(NCID,DIMSVAR(J),name=DIMNAME(J), len=DIMLN(J)) CALL CHECK_ERR(IRET) - CALL U2D(TIMEUNITS,REFDATE,IERR) - CALL D2J(REFDATE,REFJULDAY,IERR) - - ! gets variables ids, dimensions and fillvalue - DO I=1,NFIELDS - IRET = NF90_INQ_VARID(NCID,TRIM(FIELDSNAME(I)),VARIDF(I)) - CALL CHECK_ERR(IRET) - IRET = NF90_INQUIRE_VARIABLE(NCID, VARIDF(I), ndims=NDIMSVAR) - CALL CHECK_ERR(IRET) - IRET = NF90_INQUIRE_VARIABLE(NCID, VARIDF(I), dimids=DIMSVAR(:NDIMSVAR)) - CALL CHECK_ERR(IRET) - DO J=1,NDIMSVAR - IRET=NF90_INQUIRE_DIMENSION(NCID,DIMSVAR(J),name=DIMNAME(J), len=DIMLN(J)) - CALL CHECK_ERR(IRET) - END DO - IRET=NF90_GET_ATT(NCID,VARIDF(I),"_FillValue", FILLVALUE) - IF ( IRET/=NF90_NOERR ) THEN - WRITE(NDSE,1027) TRIM(FIELDSNAME(I)) - CALL EXTCDE ( 27 ) - END IF + END DO + IRET=NF90_GET_ATT(NCID,VARIDF(I),"_FillValue", FILLVALUE) + IF ( IRET/=NF90_NOERR ) THEN + WRITE(NDSE,1027) TRIM(FIELDSNAME(I)) + CALL EXTCDE ( 27 ) + END IF + END DO + + ! instanciates generic variables dimensions + NXI=0 + NYI=0 + NDIMSGRID=2 + DO i=1,NDIMSVAR + IF (DIMNAME(i) .EQ. "time".OR.DIMNAME(i) .EQ."MT") NTI = DIMLN(i) + IF (DIMNAME(i) .EQ. DIMSNAME(1)) NXI = DIMLN(i) + IF (DIMNAME(i) .EQ. DIMSNAME(1).AND.NIDIMS.EQ.1) THEN + NDIMSGRID=1 + NYI = 1 + END IF + IF (NIDIMS.GE.2) THEN + IF (DIMNAME(i) .EQ. DIMSNAME(2)) NYI = DIMLN(i) + END IF + END DO + IF (NXI*NYI.EQ.0) GOTO 864 + + ! Set factor for deg/km + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + + ! Get longitude and latitude + IF (ITYPE.NE.1.AND.ITYPE.NE.6) THEN + ALLOCATE (ALA(NXI,NYI)) + ALLOCATE (ALO(NXI,NYI)) + ! get longitude + IRET=NF90_INQ_VARID(NCID,"longitude",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"lon",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"Longitude",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"x",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"X",VARIDTMP) + IRET = NF90_INQUIRE_VARIABLE(NCID, VARIDTMP, ndims = NUMDIMS) + call CHECK_ERR(IRET) + IF (NUMDIMS.EQ.1) THEN + IRET=NF90_GET_VAR(NCID,VARIDTMP,X0I,start=(/1/)) + call CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID,VARIDTMP,XNI,start=(/NXI/)) + call CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID,VARIDTMP,ALO(:,1)) + call CHECK_ERR(IRET) + DO i=1,NYI + ALO(:,i)=ALO(:,1) END DO - - ! instanciates generic variables dimensions - NXI=0 - NYI=0 - NDIMSGRID=2 - DO i=1,NDIMSVAR - IF (DIMNAME(i) .EQ. "time".OR.DIMNAME(i) .EQ."MT") NTI = DIMLN(i) - IF (DIMNAME(i) .EQ. DIMSNAME(1)) NXI = DIMLN(i) - IF (DIMNAME(i) .EQ. DIMSNAME(1).AND.NIDIMS.EQ.1) THEN - NDIMSGRID=1 - NYI = 1 - END IF - IF (NIDIMS.GE.2) THEN - IF (DIMNAME(i) .EQ. DIMSNAME(2)) NYI = DIMLN(i) - END IF + ELSE + IRET=NF90_GET_VAR(NCID,VARIDTMP,X0I,start=(/1,1/)) + call CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID,VARIDTMP,XNI,start=(/NXI,1/)) + call CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID,VARIDTMP,ALO(:,:)) + call CHECK_ERR(IRET) + END IF + ! get latitude + IRET=NF90_INQ_VARID(NCID,"latitude",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"lat",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"Latitude",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"y",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"Y",VARIDTMP) + IRET = NF90_INQUIRE_VARIABLE(NCID, VARIDTMP, ndims = NUMDIMS) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID,VARIDTMP,Y0I, start=(/1/)) + CALL CHECK_ERR(IRET) + IF (NUMDIMS.EQ.1) THEN + IRET=NF90_GET_VAR(NCID,VARIDTMP,ALA(1,:)) + CALL CHECK_ERR(IRET) + YNI=ALA(1,NYI) + DO i=1,NXI + ALA(i,:)=ALA(1,:) END DO - IF (NXI*NYI.EQ.0) GOTO 864 - - ! Set factor for deg/km + ELSE + IRET=NF90_GET_VAR(NCID,VARIDTMP,ALA(:,:)) + CALL CHECK_ERR(IRET) + YNI=ALA(1,NYI) + END IF + END IF + + + + ! + ! ... type 1 or 6 : "As Is" (AI) or "As Is with tide" (AT) + ! + IF (ITYPE.EQ.1.OR.ITYPE.EQ.6) THEN + ! + NXI = NX + NYI = NY + ALLOCATE ( MASK(NXI,NYI) ) + MASK = 1 + IF(GTYPE .EQ. UNGTYPE) THEN + ! + ! X0, Y0 are the coordinates of the lower-left point in mesh + ! + RW(1) = FACTOR*X0 ; RW(2) = FACTOR*MAXX + RW(3) = FACTOR*Y0 ; RW(4) = FACTOR*MAXY + ELSE + RW(1) = FACTOR*XGRD(1,1) ; RW(2) = FACTOR*XGRD(NY,NX) + RW(3) = FACTOR*YGRD(1,1) ; RW(4) = FACTOR*YGRD(NY,NX) + END IF + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,932) NXI, NYI + IF ( FLAGLL ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1933) RW(1),RW(2),RW(3),RW(4) + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2933) RW(1),RW(2),RW(3),RW(4) + END IF + ! + ! ... type 2 : "Lat/Lon" (LL) + ! + ELSE IF (ITYPE.EQ.2) THEN + ! + ! check latitude values order + IF ((GTYPE .EQ. RLGTYPE) .AND. (Y0I.GT.YNI)) THEN + WRITE (NDSE,1032) + CALL EXTCDE ( 32 ) + END IF + + IF (NXI.LT.2 .OR. NYI.LT.2) THEN + WRITE (NDSE,1036) NXI, NYI + CALL EXTCDE ( 36 ) + END IF + ALLOCATE ( MASK(NXI,NYI) ) + MASK = 1 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,932) NXI, NYI + + IF ( FLAGLL ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1933) FACTOR*X0I, FACTOR*XNI, & + FACTOR*Y0I, FACTOR*YNI + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2933) FACTOR*X0I, FACTOR*XNI, & + FACTOR*Y0I, FACTOR*YNI + END IF + ! + ! ... type 5 : "Data" (DAT) + ! + ELSE IF (ITYPE.EQ.5) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & + DATTYP, RECLDT, NODATA + IF (DATTYP.LT.0 .OR. DATTYP.GT.2) THEN + WRITE (NDSE,1033) DATTYP + CALL EXTCDE ( 33 ) + END IF + IF (RECLDT.LE.0) THEN + WRITE (NDSE,1034) RECLDT + CALL EXTCDE ( 34 ) + END IF + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,934) IDSTR3(DATTYP+1), RECLDT, NODATA + WRITE (IDFLD,935) DATTYP + DEALLOCATE ( IX21, IX22, IY21, IY22, JX21, JX22, JY21, JY22, & + MAPOVR ) + DEALLOCATE ( RD11, RD21, RD12, RD22, XD11, XD21, XD12, XD22, & + FX, FY, FA, A1, A2, A3 ) + ! + ! ... types 3 and 4 ... in preprocessing loop .... + ! + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6 Prepare interpolation. + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,940) + ! + IF (ITYPE.NE.1 .AND. ITYPE.NE.5 .AND. ITYPE.NE.6 ) THEN + ! + ! 6.a Longitude - latitude grid + ! + IF (ITYPE.EQ.2) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,941) + ! + ! ... setup coordinates + ! + SXI = (XNI-X0I)/REAL(NXI-1) + SYI = (YNI-Y0I)/REAL(NYI-1) + ICLO = ICLOSE_NONE IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF - - ! Get longitude and latitude - IF (ITYPE.NE.1.AND.ITYPE.NE.6) THEN - ALLOCATE (ALA(NXI,NYI)) - ALLOCATE (ALO(NXI,NYI)) - ! get longitude - IRET=NF90_INQ_VARID(NCID,"longitude",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"lon",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"Longitude",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"x",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"X",VARIDTMP) - IRET = NF90_INQUIRE_VARIABLE(NCID, VARIDTMP, ndims = NUMDIMS) - call CHECK_ERR(IRET) - IF (NUMDIMS.EQ.1) THEN - IRET=NF90_GET_VAR(NCID,VARIDTMP,X0I,start=(/1/)) - call CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID,VARIDTMP,XNI,start=(/NXI/)) - call CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID,VARIDTMP,ALO(:,1)) - call CHECK_ERR(IRET) - DO i=1,NYI - ALO(:,i)=ALO(:,1) - END DO - ELSE - IRET=NF90_GET_VAR(NCID,VARIDTMP,X0I,start=(/1,1/)) - call CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID,VARIDTMP,XNI,start=(/NXI,1/)) - call CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID,VARIDTMP,ALO(:,:)) - call CHECK_ERR(IRET) - END IF - ! get latitude - IRET=NF90_INQ_VARID(NCID,"latitude",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"lat",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"Latitude",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"y",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"Y",VARIDTMP) - IRET = NF90_INQUIRE_VARIABLE(NCID, VARIDTMP, ndims = NUMDIMS) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID,VARIDTMP,Y0I, start=(/1/)) - CALL CHECK_ERR(IRET) - IF (NUMDIMS.EQ.1) THEN - IRET=NF90_GET_VAR(NCID,VARIDTMP,ALA(1,:)) - CALL CHECK_ERR(IRET) - YNI=ALA(1,NYI) - DO i=1,NXI - ALA(i,:)=ALA(1,:) - END DO - ELSE - IRET=NF90_GET_VAR(NCID,VARIDTMP,ALA(:,:)) - CALL CHECK_ERR(IRET) - YNI=ALA(1,NYI) - END IF - END IF - - - -! -! ... type 1 or 6 : "As Is" (AI) or "As Is with tide" (AT) -! - IF (ITYPE.EQ.1.OR.ITYPE.EQ.6) THEN -! - NXI = NX - NYI = NY - ALLOCATE ( MASK(NXI,NYI) ) - MASK = 1 - IF(GTYPE .EQ. UNGTYPE) THEN -! -! X0, Y0 are the coordinates of the lower-left point in mesh -! - RW(1) = FACTOR*X0 ; RW(2) = FACTOR*MAXX - RW(3) = FACTOR*Y0 ; RW(4) = FACTOR*MAXY - ELSE - RW(1) = FACTOR*XGRD(1,1) ; RW(2) = FACTOR*XGRD(NY,NX) - RW(3) = FACTOR*YGRD(1,1) ; RW(4) = FACTOR*YGRD(NY,NX) - END IF - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,932) NXI, NYI - IF ( FLAGLL ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1933) RW(1),RW(2),RW(3),RW(4) - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2933) RW(1),RW(2),RW(3),RW(4) - END IF -! -! ... type 2 : "Lat/Lon" (LL) -! - ELSE IF (ITYPE.EQ.2) THEN -! - ! check latitude values order - IF ((GTYPE .EQ. RLGTYPE) .AND. (Y0I.GT.YNI)) THEN - WRITE (NDSE,1032) - CALL EXTCDE ( 32 ) - END IF - - IF (NXI.LT.2 .OR. NYI.LT.2) THEN - WRITE (NDSE,1036) NXI, NYI - CALL EXTCDE ( 36 ) + IF ( ABS(ABS(REAL(NXI)*SXI)-360.) .LT. 0.1*ABS(SXI) ) THEN + ICLO = ICLOSE_SMPL END IF - ALLOCATE ( MASK(NXI,NYI) ) - MASK = 1 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,932) NXI, NYI - - IF ( FLAGLL ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1933) FACTOR*X0I, FACTOR*XNI, & - FACTOR*Y0I, FACTOR*YNI - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2933) FACTOR*X0I, FACTOR*XNI, & - FACTOR*Y0I, FACTOR*YNI - END IF -! -! ... type 5 : "Data" (DAT) -! - ELSE IF (ITYPE.EQ.5) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & - DATTYP, RECLDT, NODATA - IF (DATTYP.LT.0 .OR. DATTYP.GT.2) THEN - WRITE (NDSE,1033) DATTYP - CALL EXTCDE ( 33 ) - END IF - IF (RECLDT.LE.0) THEN - WRITE (NDSE,1034) RECLDT - CALL EXTCDE ( 34 ) - END IF - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,934) IDSTR3(DATTYP+1), RECLDT, NODATA - WRITE (IDFLD,935) DATTYP - DEALLOCATE ( IX21, IX22, IY21, IY22, JX21, JX22, JY21, JY22, & - MAPOVR ) - DEALLOCATE ( RD11, RD21, RD12, RD22, XD11, XD21, XD12, XD22, & - FX, FY, FA, A1, A2, A3 ) -! -! ... types 3 and 4 ... in preprocessing loop .... -! END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6 Prepare interpolation. -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,940) -! - IF (ITYPE.NE.1 .AND. ITYPE.NE.5 .AND. ITYPE.NE.6 ) THEN -! -! 6.a Longitude - latitude grid -! - IF (ITYPE.EQ.2) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,941) -! -! ... setup coordinates -! - SXI = (XNI-X0I)/REAL(NXI-1) - SYI = (YNI-Y0I)/REAL(NYI-1) - ICLO = ICLOSE_NONE - IF ( FLAGLL ) THEN - IF ( ABS(ABS(REAL(NXI)*SXI)-360.) .LT. 0.1*ABS(SXI) ) THEN - ICLO = ICLOSE_SMPL - END IF - END IF -! -! ... create grid search utility -! - GSI = W3GSUC( .TRUE., FLAGLL, ICLO, ALO, ALA ) -! -! ... construct Interpolation data -! + ! + ! ... create grid search utility + ! + GSI = W3GSUC( .TRUE., FLAGLL, ICLO, ALO, ALA ) + ! + ! ... construct Interpolation data + ! #ifdef W3_T1 - WRITE (NDST,9045) -#endif - IF (GTYPE .NE. UNGTYPE) THEN - DO IY=1,NY - DO IX=1,NX - INGRID = W3GRMP( GSI, REAL(XGRD(IY,IX)), REAL(YGRD(IY,IX)), & - IS, JS, RW ) - IF ( .NOT.INGRID ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSO,1042) IX, IY, XGRD(IY,IX), YGRD(IY,IX) - IX21(IX,IY) = 1 - IX22(IX,IY) = 1 - IY21(IX,IY) = 1 - IY22(IX,IY) = 1 - RD11(IX,IY) = 0. - RD21(IX,IY) = 0. - RD12(IX,IY) = 0. - RD22(IX,IY) = 0. - - CYCLE - END IF - IX21(IX,IY) = IS(1) - IX22(IX,IY) = IS(2) - IY21(IX,IY) = JS(1) - IY22(IX,IY) = JS(4) - RD11(IX,IY) = RW(1) - RD21(IX,IY) = RW(2) - RD12(IX,IY) = RW(4) - RD22(IX,IY) = RW(3) + WRITE (NDST,9045) +#endif + IF (GTYPE .NE. UNGTYPE) THEN + DO IY=1,NY + DO IX=1,NX + INGRID = W3GRMP( GSI, REAL(XGRD(IY,IX)), REAL(YGRD(IY,IX)), & + IS, JS, RW ) + IF ( .NOT.INGRID ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSO,1042) IX, IY, XGRD(IY,IX), YGRD(IY,IX) + IX21(IX,IY) = 1 + IX22(IX,IY) = 1 + IY21(IX,IY) = 1 + IY22(IX,IY) = 1 + RD11(IX,IY) = 0. + RD21(IX,IY) = 0. + RD12(IX,IY) = 0. + RD22(IX,IY) = 0. + + CYCLE + END IF + IX21(IX,IY) = IS(1) + IX22(IX,IY) = IS(2) + IY21(IX,IY) = JS(1) + IY22(IX,IY) = JS(4) + RD11(IX,IY) = RW(1) + RD21(IX,IY) = RW(2) + RD12(IX,IY) = RW(4) + RD22(IX,IY) = RW(3) #ifdef W3_T1 - WRITE (NDST,9046) IX, IY, & - IX21(IX,IY),IX22(IX,IY),IY21(IX,IY),IY22(IX,IY), & - RD11(IX,IY),RD12(IX,IY),RD21(IX,IY),RD22(IX,IY) + WRITE (NDST,9046) IX, IY, & + IX21(IX,IY),IX22(IX,IY),IY21(IX,IY),IY22(IX,IY), & + RD11(IX,IY),RD12(IX,IY),RD21(IX,IY),RD22(IX,IY) #endif - END DO - END DO - ELSE ! GTYPE .NE. UNGTYPE - DO IX=1, NX - X = XGRD(1,IX) - Y = YGRD(1,IX) - IX21(IX,1) = 1 + INT(MOD(360.+(X-X0I),360.)/SXI) -! -! Manages the simple closure of the grid -! - IF (ICLO.EQ.ICLOSE_NONE) THEN - IF (IX21(IX,1).LT.1.OR.IX21(IX,1).GT.NXI-1) WRITE(NDSO,1042) IX, IY, X, Y - IX21(IX,1) = MAX ( 1 , MIN(IX21(IX,1),NXI-1) ) - IX22(IX,1) = IX21(IX,1) + 1 - ELSE - IX21(IX,1) = MAX ( 1 , MIN(IX21(IX,1),NXI) ) - IX22(IX,1) = MOD(IX21(IX,1),NXI)+1 - END IF - IY21(IX,1) = 1 + INT((Y-Y0I)/SYI) - IF (IY21(IX,1).LT.1.OR.IY21(IX,1).GT.NYI-1) WRITE(NDSO,1042) IX, IY, X, Y - IY21(IX,1) = MAX ( 1 , MIN(IY21(IX,1),NYI-1) ) - IY22(IX,1) = IY21(IX,1) + 1 -! - RW(1) = MOD(360.+(X-X0I),360.)/SXI - REAL(IX21(IX,1)-1) - RW(2) = (Y-Y0I)/SYI - REAL(IY21(IX,1)-1) -! - IF (IX21(IX,1).LE.1 .AND. RW(1).LT.ACC) THEN - IF (RW(1).LT.0.) THEN - RW(1) = 0. - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1043) X + END DO + END DO + ELSE ! GTYPE .NE. UNGTYPE + DO IX=1, NX + X = XGRD(1,IX) + Y = YGRD(1,IX) + IX21(IX,1) = 1 + INT(MOD(360.+(X-X0I),360.)/SXI) + ! + ! Manages the simple closure of the grid + ! + IF (ICLO.EQ.ICLOSE_NONE) THEN + IF (IX21(IX,1).LT.1.OR.IX21(IX,1).GT.NXI-1) WRITE(NDSO,1042) IX, IY, X, Y + IX21(IX,1) = MAX ( 1 , MIN(IX21(IX,1),NXI-1) ) + IX22(IX,1) = IX21(IX,1) + 1 + ELSE + IX21(IX,1) = MAX ( 1 , MIN(IX21(IX,1),NXI) ) + IX22(IX,1) = MOD(IX21(IX,1),NXI)+1 + END IF + IY21(IX,1) = 1 + INT((Y-Y0I)/SYI) + IF (IY21(IX,1).LT.1.OR.IY21(IX,1).GT.NYI-1) WRITE(NDSO,1042) IX, IY, X, Y + IY21(IX,1) = MAX ( 1 , MIN(IY21(IX,1),NYI-1) ) + IY22(IX,1) = IY21(IX,1) + 1 + ! + RW(1) = MOD(360.+(X-X0I),360.)/SXI - REAL(IX21(IX,1)-1) + RW(2) = (Y-Y0I)/SYI - REAL(IY21(IX,1)-1) + ! + IF (IX21(IX,1).LE.1 .AND. RW(1).LT.ACC) THEN + IF (RW(1).LT.0.) THEN + RW(1) = 0. + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1043) X #ifdef W3_T - FLMOD = .TRUE. -#endif - END IF - END IF -! - IF (IX21(IX,1).GE.(NXI-1) .AND. RW(1).GT.1.-ACC) THEN - IF (RW(1).GT.1.) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1043) X - RW(1) = 1. + FLMOD = .TRUE. +#endif + END IF + END IF + ! + IF (IX21(IX,1).GE.(NXI-1) .AND. RW(1).GT.1.-ACC) THEN + IF (RW(1).GT.1.) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1043) X + RW(1) = 1. #ifdef W3_T - FLMOD = .TRUE. -#endif - END IF - END IF -! - IF (IY21(IX,1).LE.1 .AND. RW(2).LT.ACC) THEN - IF (RW(2).LT.0.) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1044) Y - RW(2) = 0. + FLMOD = .TRUE. +#endif + END IF + END IF + ! + IF (IY21(IX,1).LE.1 .AND. RW(2).LT.ACC) THEN + IF (RW(2).LT.0.) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1044) Y + RW(2) = 0. #ifdef W3_T - FLMOD = .TRUE. -#endif - END IF - END IF -! - IF (IY21(IX,1).GE.NYI .AND. RW(2).GT.1.-ACC) THEN - IF (RW(2).GT.1) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1044) Y - RW(2) = 1. + FLMOD = .TRUE. +#endif + END IF + END IF + ! + IF (IY21(IX,1).GE.NYI .AND. RW(2).GT.1.-ACC) THEN + IF (RW(2).GT.1) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1044) Y + RW(2) = 1. #ifdef W3_T - FLMOD = .TRUE. -#endif - END IF - END IF -! - EFAC = SQRT ( MAX(0.,ABS(RW(1)-0.5)-0.5)**2 + & - MAX(0.,ABS(RW(2)-0.5)-0.5)**2 ) - EFAC = 1. / ( 1. + 0.25*EFAC**2 ) - - RD11(IX,1) = EFAC * (1.-RW(1)) * (1.-RW(2)) - RD21(IX,1) = EFAC * RW(1) * (1.-RW(2)) - RD12(IX,1) = EFAC * (1.-RW(1)) * RW(2) - RD22(IX,1) = EFAC * RW(1) * RW(2) - - END DO ! IX=1, NX - END IF ! GTYPE .NE. UNGTYPE -! - CALL W3GSUD( GSI ) - -! -! 6.b Grid(s) from file -! - ELSE ! ITYPE.EQ.2 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) -! -! ... prepare overlay map -! - DO IY=1, NY - DO IX=1, NX - IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN - MAPOVR(IX,IY) = ILAND - ELSE - MAPOVR(IX,IY) = 0 - END IF - END DO - END DO -! -! ... loop over fields -! - DO J=1, NFCOMP -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) J -! -! ... file info lat-long file -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & - NXJ(J), NYJ(J), CLO(J) - IF (NXJ(J).LT.2 .OR. NYJ(J).LT.2) THEN - WRITE (NDSE,1036) NXJ(J), NYJ(J) - CALL EXTCDE ( 36 ) - END IF - IF ( ALLOCATED(MASK) ) DEALLOCATE (MASK) - ALLOCATE ( MASK(NXJ(J),NYJ(J)) ) - MASK = 1 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,944) NXJ(J), NYJ(J), CLO(J) -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & - FROMLL, IDLALL, IDFMLL, FORMLL - IF (IDLALL.LT.1 .OR. IDLALL.GT.4) IDLALL = 1 - IF (IDFMLL.LT.1 .OR. IDFMLL.GT.3) IDFMLL = 1 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,945) IDLALL, IDFMLL - IF (IDFMLL.EQ.2) WRITE (NDSO,946) FORMLL -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL + FLMOD = .TRUE. +#endif + END IF + END IF + ! + EFAC = SQRT ( MAX(0.,ABS(RW(1)-0.5)-0.5)**2 + & + MAX(0.,ABS(RW(2)-0.5)-0.5)**2 ) + EFAC = 1. / ( 1. + 0.25*EFAC**2 ) + + RD11(IX,1) = EFAC * (1.-RW(1)) * (1.-RW(2)) + RD21(IX,1) = EFAC * RW(1) * (1.-RW(2)) + RD12(IX,1) = EFAC * (1.-RW(1)) * RW(2) + RD22(IX,1) = EFAC * RW(1) * RW(2) + + END DO ! IX=1, NX + END IF ! GTYPE .NE. UNGTYPE + ! + CALL W3GSUD( GSI ) + + ! + ! 6.b Grid(s) from file + ! + ELSE ! ITYPE.EQ.2 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) + ! + ! ... prepare overlay map + ! + DO IY=1, NY + DO IX=1, NX + IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN + MAPOVR(IX,IY) = ILAND + ELSE + MAPOVR(IX,IY) = 0 + END IF + END DO + END DO + ! + ! ... loop over fields + ! + DO J=1, NFCOMP + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) J + ! + ! ... file info lat-long file + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & + NXJ(J), NYJ(J), CLO(J) + IF (NXJ(J).LT.2 .OR. NYJ(J).LT.2) THEN + WRITE (NDSE,1036) NXJ(J), NYJ(J) + CALL EXTCDE ( 36 ) + END IF + IF ( ALLOCATED(MASK) ) DEALLOCATE (MASK) + ALLOCATE ( MASK(NXJ(J),NYJ(J)) ) + MASK = 1 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,944) NXJ(J), NYJ(J), CLO(J) + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & + FROMLL, IDLALL, IDFMLL, FORMLL + IF (IDLALL.LT.1 .OR. IDLALL.GT.4) IDLALL = 1 + IF (IDFMLL.LT.1 .OR. IDFMLL.GT.3) IDFMLL = 1 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,945) IDLALL, IDFMLL + IF (IDFMLL.EQ.2) WRITE (NDSO,946) FORMLL + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL #ifdef W3_NCO - NDSLL = 20 + NFCOMP + NDSLL = 20 + NFCOMP #endif - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,947) NDSLL - IF ( IAPROC .EQ. NAPOUT.AND.FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL - IF (NDSLL.EQ.NDSI) THEN - WRITE (NDSE,1038) - CALL NEXTLN ( COMSTR , NDSI , NDSE ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,947) NDSLL + IF ( IAPROC .EQ. NAPOUT.AND.FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL + IF (NDSLL.EQ.NDSI) THEN + WRITE (NDSE,1038) + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ELSE + ! + ! ... open lat-long file + ! + IF ( IDFMLL .EQ. 3 ) THEN + IF (FROMLL.EQ.'NAME') THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & + form='UNFORMATTED', convert=file_endian,STATUS='OLD', & + ERR=845,IOSTAT=IERR) ELSE -! -! ... open lat-long file -! - IF ( IDFMLL .EQ. 3 ) THEN - IF (FROMLL.EQ.'NAME') THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & - form='UNFORMATTED', convert=file_endian,STATUS='OLD', & - ERR=845,IOSTAT=IERR) - ELSE - OPEN (NDSLL, form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=845,IOSTAT=IERR) - END IF - ELSE - IF (FROMLL.EQ.'NAME') THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & - STATUS='OLD',ERR=845,IOSTAT=IERR) - ELSE - OPEN (NDSLL, & - STATUS='OLD',ERR=845,IOSTAT=IERR) - END IF - END IF -! + OPEN (NDSLL, form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=845,IOSTAT=IERR) END IF -! -! ... read lat-lon data -! - IF ( ASSOCIATED(ALA) ) THEN - DEALLOCATE ( ALA, ALO ) - NULLIFY ( ALA, ALO ) + ELSE + IF (FROMLL.EQ.'NAME') THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & + STATUS='OLD',ERR=845,IOSTAT=IERR) + ELSE + OPEN (NDSLL, & + STATUS='OLD',ERR=845,IOSTAT=IERR) END IF - ALLOCATE ( ALA(NXJ(J),NYJ(J)), ALO(NXJ(J),NYJ(J)) ) - CALL INA2R (ALA, NXJ(J), NYJ(J), 1, NXJ(J), 1, NYJ(J),& - NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1., 0.) - CALL INA2R (ALO, NXJ(J), NYJ(J), 1, NXJ(J), 1, NYJ(J),& - NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1., 0.) -! - IF ( NDSLL .NE. NDSI ) CLOSE (NDSLL) -! -! ... file info mask file -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,949) -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & - FROMLL, IDLALL, IDFMLL, FORMLL - IF (IDLALL.LT.1 .OR. IDLALL.GT.4) IDLALL = 1 - IF (IDFMLL.LT.1 .OR. IDFMLL.GT.3) IDFMLL = 1 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,945) IDLALL, IDFMLL - IF (IDFMLL.EQ.2) WRITE (NDSO,946) FORMLL -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL + END IF + ! + END IF + ! + ! ... read lat-lon data + ! + IF ( ASSOCIATED(ALA) ) THEN + DEALLOCATE ( ALA, ALO ) + NULLIFY ( ALA, ALO ) + END IF + ALLOCATE ( ALA(NXJ(J),NYJ(J)), ALO(NXJ(J),NYJ(J)) ) + CALL INA2R (ALA, NXJ(J), NYJ(J), 1, NXJ(J), 1, NYJ(J),& + NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1., 0.) + CALL INA2R (ALO, NXJ(J), NYJ(J), 1, NXJ(J), 1, NYJ(J),& + NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1., 0.) + ! + IF ( NDSLL .NE. NDSI ) CLOSE (NDSLL) + ! + ! ... file info mask file + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,949) + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) & + FROMLL, IDLALL, IDFMLL, FORMLL + IF (IDLALL.LT.1 .OR. IDLALL.GT.4) IDLALL = 1 + IF (IDFMLL.LT.1 .OR. IDFMLL.GT.3) IDFMLL = 1 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,945) IDLALL, IDFMLL + IF (IDFMLL.EQ.2) WRITE (NDSO,946) FORMLL + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL #ifdef W3_NCO - NDSLL = 22 + NFCOMP -#endif - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,947) NDSLL - IF (FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' - IF (NDSLL.EQ.NDSI) THEN - WRITE (NDSE,1038) - CALL NEXTLN ( COMSTR , NDSI , NDSE ) + NDSLL = 22 + NFCOMP +#endif + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,947) NDSLL + IF (FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' + IF (NDSLL.EQ.NDSI) THEN + WRITE (NDSE,1038) + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + ELSE + ! + ! ... open mask file + ! + IF ( IDFMLL .EQ. 3 ) THEN + IF (FROMLL.EQ.'NAME') THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & + form='UNFORMATTED', convert=file_endian,STATUS='OLD', & + ERR=846,IOSTAT=IERR) ELSE -! -! ... open mask file -! - IF ( IDFMLL .EQ. 3 ) THEN - IF (FROMLL.EQ.'NAME') THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & - form='UNFORMATTED', convert=file_endian,STATUS='OLD', & - ERR=846,IOSTAT=IERR) - ELSE - OPEN (NDSLL,form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=846,IOSTAT=IERR) - END IF - ELSE - IF (FROMLL.EQ.'NAME') THEN - JJ = LEN_TRIM(FNMPRE) - OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & - STATUS='OLD',ERR=846,IOSTAT=IERR) - ELSE - OPEN (NDSLL, & - STATUS='OLD',ERR=846,IOSTAT=IERR) - END IF - END IF -! + OPEN (NDSLL,form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=846,IOSTAT=IERR) END IF -! -! ... read mask data -! - CALL INA2I (MASK, NXJ(J), NYJ(J), 1,NXJ(J), 1,NYJ(J), & - NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1, 0) - IF ( NDSLL .NE. NDSI ) CLOSE (NDSLL) -! -#ifdef W3_T1a - WRITE (NDST,9050) - DO IY=1, NYJ(J) - DO IX=1,NXJ(J) - WRITE (NDST,9051) IX, IY, ALA(IX,IY), & - ALO(IX,IY), MASK(IX,IY) - END DO - END DO -#endif -! -! ... generate interpolation data -! - IF ( J .EQ. 1 ) THEN - CALL W3FLDP ( NDSO, NDST, NDSE, IERR, FLAGLL, & - NX, NY, NX, NY, REAL(YGRD), REAL(XGRD), MAPOVR, ILAND, & - NXJ(J), NYJ(J), NXJ(J), NYJ(J), CLO(J), ALA, ALO, & - MASK, RD11, RD21, RD12, RD22, IX21, IX22, IY21, & - IY22 ) - ELSE - CALL W3FLDP ( NDSO, NDST, NDSE, IERR, FLAGLL, & - NX, NY, NX, NY, REAL(YGRD), REAL(XGRD), MAPOVR, ILAND, & - NXJ(J), NYJ(J), NXJ(J), NYJ(J), CLO(J), ALA, ALO, & - MASK, XD11, XD21, XD12, XD22, JX21, JX22, JY21, & - JY22 ) - END IF ! J .EQ. 1 -! - END DO ! J=1, NFCOMP -! -! ... average two fields ! -! - IF ( NFCOMP .EQ. 2) THEN - DO IX=1, NX - DO IY=1, NY - IF ( MAPOVR(IX,IY) .GE. 2) THEN - FACTOR = 1. / REAL(MAPOVR(IX,IY)) - RD11(IX,IY) = FACTOR * RD11(IX,IY) - RD12(IX,IY) = FACTOR * RD12(IX,IY) - RD21(IX,IY) = FACTOR * RD21(IX,IY) - RD22(IX,IY) = FACTOR * RD22(IX,IY) - XD11(IX,IY) = FACTOR * XD11(IX,IY) - XD12(IX,IY) = FACTOR * XD12(IX,IY) - XD21(IX,IY) = FACTOR * XD21(IX,IY) - XD22(IX,IY) = FACTOR * XD22(IX,IY) - END IF - END DO - END DO - END IF ! NFCOMP .EQ. 2 -! - END IF ! ITYPE.EQ.2 - END IF ! ITYPE.NE.1 .AND. ITYPE.NE.5 -! -! 6.c Input location and format -! - DO J=1, NFCOMP -! - IF ( ITYPE .EQ. 5 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,960) - ELSE - IF (ITYPE.LE.3) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,961) NXJ(J), NYJ(J) ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,962) J, NXJ(J), NYJ(J) + IF (FROMLL.EQ.'NAME') THEN + JJ = LEN_TRIM(FNMPRE) + OPEN (NDSLL,FILE=FNMPRE(:JJ)//NAMELL, & + STATUS='OLD',ERR=846,IOSTAT=IERR) + ELSE + OPEN (NDSLL, & + STATUS='OLD',ERR=846,IOSTAT=IERR) + END IF END IF - END IF ! ITYPE .EQ. 5 -! - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 7 Prepare files -! - IF ( NFCOMP .EQ. 1 ) THEN - NXJ (2) = NXJ (1) - NYJ (2) = NYJ (1) - NDSF (2) = NDSF (1) - IDLAF(2) = IDLAF(1) - IDFMF(2) = IDFMF(1) - FORMT(2) = FORMT(1) - FORMF(2) = FORMF(1) - END IF - -! 7.b Open and prepare output file -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,971) - J = LEN_TRIM(FNMPRE) - - ! define tidal constituents for analysis - IF (ITYPE.EQ.6) THEN - CALL VUF_SET_PARAMETERS - TIDE_NDEF = NFIELDS - IF (TRIM(LIST(1)).EQ.'ALL') THEN - WRITE(NDSE,'(A)') 'Tidal constituent ALL not available anymore' - CALL EXTCDE(29) + ! END IF - CALL TIDE_FIND_INDICES_ANALYSIS(LIST) - END IF - - ! Create output binary file - IF ( ITYPE .LE. 4 .OR. ITYPE.EQ.6 ) THEN - IF ( IAPROC .EQ. NAPOUT ) & - CALL W3FLDO ( 'WRITE', IDFLD, NDSDAT, NDST, NDSE, & - NX, NY, GTYPE, IERR, FPRE=FNMPRE(:J), & - FHDR=FLHDR, TIDEFLAGIN=TIDEFLAG) + ! + ! ... read mask data + ! + CALL INA2I (MASK, NXJ(J), NYJ(J), 1,NXJ(J), 1,NYJ(J), & + NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1, 0) + IF ( NDSLL .NE. NDSI ) CLOSE (NDSLL) + ! +#ifdef W3_T1a + WRITE (NDST,9050) + DO IY=1, NYJ(J) + DO IX=1,NXJ(J) + WRITE (NDST,9051) IX, IY, ALA(IX,IY), & + ALO(IX,IY), MASK(IX,IY) + END DO + END DO +#endif + ! + ! ... generate interpolation data + ! + IF ( J .EQ. 1 ) THEN + CALL W3FLDP ( NDSO, NDST, NDSE, IERR, FLAGLL, & + NX, NY, NX, NY, REAL(YGRD), REAL(XGRD), MAPOVR, ILAND, & + NXJ(J), NYJ(J), NXJ(J), NYJ(J), CLO(J), ALA, ALO, & + MASK, RD11, RD21, RD12, RD22, IX21, IX22, IY21, & + IY22 ) ELSE - IF ( IAPROC .EQ. NAPOUT ) & - CALL W3FLDO ( 'WRITE', IDFLD, NDSDAT, NDST, NDSE, & - RECLDT, 0, GTYPEDUM, IERR, FPRE=FNMPRE(:J) ) - END IF + CALL W3FLDP ( NDSO, NDST, NDSE, IERR, FLAGLL, & + NX, NY, NX, NY, REAL(YGRD), REAL(XGRD), MAPOVR, ILAND, & + NXJ(J), NYJ(J), NXJ(J), NYJ(J), CLO(J), ALA, ALO, & + MASK, XD11, XD21, XD12, XD22, JX21, JX22, JY21, & + JY22 ) + END IF ! J .EQ. 1 + ! + END DO ! J=1, NFCOMP + ! + ! ... average two fields ! + ! + IF ( NFCOMP .EQ. 2) THEN + DO IX=1, NX + DO IY=1, NY + IF ( MAPOVR(IX,IY) .GE. 2) THEN + FACTOR = 1. / REAL(MAPOVR(IX,IY)) + RD11(IX,IY) = FACTOR * RD11(IX,IY) + RD12(IX,IY) = FACTOR * RD12(IX,IY) + RD21(IX,IY) = FACTOR * RD21(IX,IY) + RD22(IX,IY) = FACTOR * RD22(IX,IY) + XD11(IX,IY) = FACTOR * XD11(IX,IY) + XD12(IX,IY) = FACTOR * XD12(IX,IY) + XD21(IX,IY) = FACTOR * XD21(IX,IY) + XD22(IX,IY) = FACTOR * XD22(IX,IY) + END IF + END DO + END DO + END IF ! NFCOMP .EQ. 2 + ! + END IF ! ITYPE.EQ.2 + END IF ! ITYPE.NE.1 .AND. ITYPE.NE.5 + ! + ! 6.c Input location and format + ! + DO J=1, NFCOMP + ! + IF ( ITYPE .EQ. 5 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,960) + ELSE + IF (ITYPE.LE.3) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,961) NXJ(J), NYJ(J) + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,962) J, NXJ(J), NYJ(J) + END IF + END IF ! ITYPE .EQ. 5 + ! + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 7 Prepare files + ! + IF ( NFCOMP .EQ. 1 ) THEN + NXJ (2) = NXJ (1) + NYJ (2) = NYJ (1) + NDSF (2) = NDSF (1) + IDLAF(2) = IDLAF(1) + IDFMF(2) = IDFMF(1) + FORMT(2) = FORMT(1) + FORMF(2) = FORMF(1) + END IF + + ! 7.b Open and prepare output file + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,971) + J = LEN_TRIM(FNMPRE) + + ! define tidal constituents for analysis + IF (ITYPE.EQ.6) THEN + CALL VUF_SET_PARAMETERS + TIDE_NDEF = NFIELDS + IF (TRIM(LIST(1)).EQ.'ALL') THEN + WRITE(NDSE,'(A)') 'Tidal constituent ALL not available anymore' + CALL EXTCDE(29) + END IF + CALL TIDE_FIND_INDICES_ANALYSIS(LIST) + END IF + + ! Create output binary file + IF ( ITYPE .LE. 4 .OR. ITYPE.EQ.6 ) THEN + IF ( IAPROC .EQ. NAPOUT ) & + CALL W3FLDO ( 'WRITE', IDFLD, NDSDAT, NDST, NDSE, & + NX, NY, GTYPE, IERR, FPRE=FNMPRE(:J), & + FHDR=FLHDR, TIDEFLAGIN=TIDEFLAG) + ELSE + IF ( IAPROC .EQ. NAPOUT ) & + CALL W3FLDO ( 'WRITE', IDFLD, NDSDAT, NDST, NDSE, & + RECLDT, 0, GTYPEDUM, IERR, FPRE=FNMPRE(:J) ) + END IF #ifdef W3_T - IF (TIDEFLAG.GT.0) THEN - LRECL = TIDE_MF*LRB*NFIELDS*2 - NREC = LRECL / LRB - ALLOCATE(NULLBUFF(NREC)) - NULLBUFF(1:NREC) = 0. - OPEN (990,FILE='tidana.dat',form='UNFORMATTED', convert=file_endian, ACCESS='STREAM') - FNAMETXT = 'tidanaNNN.txt' - WRITE (FNAMETXT(7:9),'(I3.3)') IAPROC - OPEN (989,FILE=FNAMETXT,status='unknown') - ENDIF -#endif - -! -! 7.c Initialize fields -! - IF ( ITYPE .NE. 5 ) THEN - FX = 0. - FY = 0. - FA = 0. - MXM = MAX ( NXJ(1), NXJ(2) ) - MYM = MAX ( NYJ(1), NYJ(2) ) - IF (ITYPE.EQ.1.AND.GTYPE.EQ.UNGTYPE) THEN - ALLOCATE ( XC(MXM,1), YC(MXM,1), AC(MXM,1), XTEMP(MXM,1) ) - ELSE - ALLOCATE ( XC(MXM,MYM), YC(MXM,MYM), AC(MXM,MYM), XTEMP(MXM,MYM) ) - END IF - XC = 0. - YC = 0. - AC = 0. - XTEMP = 0. - END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! Dedicated section to ITYPE.EQ.6 -! -! points are read one by one for tidal analysis -! For other ITYPE, time steps are read one by one. -! - - IF (ITYPE.GE.6.AND.TIDEFLAG.GT.0) THEN -! -! Reads in the full time vector -! - IF (NX*NY.GT.4000) THEN + IF (TIDEFLAG.GT.0) THEN + LRECL = TIDE_MF*LRB*NFIELDS*2 + NREC = LRECL / LRB + ALLOCATE(NULLBUFF(NREC)) + NULLBUFF(1:NREC) = 0. + OPEN (990,FILE='tidana.dat',form='UNFORMATTED', convert=file_endian, ACCESS='STREAM') + FNAMETXT = 'tidanaNNN.txt' + WRITE (FNAMETXT(7:9),'(I3.3)') IAPROC + OPEN (989,FILE=FNAMETXT,status='unknown') + ENDIF +#endif + + ! + ! 7.c Initialize fields + ! + IF ( ITYPE .NE. 5 ) THEN + FX = 0. + FY = 0. + FA = 0. + MXM = MAX ( NXJ(1), NXJ(2) ) + MYM = MAX ( NYJ(1), NYJ(2) ) + IF (ITYPE.EQ.1.AND.GTYPE.EQ.UNGTYPE) THEN + ALLOCATE ( XC(MXM,1), YC(MXM,1), AC(MXM,1), XTEMP(MXM,1) ) + ELSE + ALLOCATE ( XC(MXM,MYM), YC(MXM,MYM), AC(MXM,MYM), XTEMP(MXM,MYM) ) + END IF + XC = 0. + YC = 0. + AC = 0. + XTEMP = 0. + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! + ! Dedicated section to ITYPE.EQ.6 + ! + ! points are read one by one for tidal analysis + ! For other ITYPE, time steps are read one by one. + ! + + IF (ITYPE.GE.6.AND.TIDEFLAG.GT.0) THEN + ! + ! Reads in the full time vector + ! + IF (NX*NY.GT.4000) THEN #ifdef W3_MPI - IF ((NX*NY)/NAPROC.LT.4000) THEN + IF ((NX*NY)/NAPROC.LT.4000) THEN IF (IAPROC.EQ.NAPOUT) WRITE(NDSE,*) 'Starting tidal analysis ... ' - ELSE - IF (IAPROC.EQ.NAPOUT) WRITE(NDSE,*) 'Starting tidal analysis for ',NX*NY, & - ' points. This can take hours ...' - ENDIF - IF (NX*NY.LT.4000) THEN -#endif - WRITE(NDSE,'(A,I8,A)') 'Starting tidal analysis for ',NX*NY, ' points.' - IF (NAPROC.EQ.1) WRITE(NDSE,'(A)') 'This can take hours ...Consider running this with MPI ' - END IF -#ifdef W3_MPI - END IF + ELSE + IF (IAPROC.EQ.NAPOUT) WRITE(NDSE,*) 'Starting tidal analysis for ',NX*NY, & + ' points. This can take hours ...' + ENDIF + IF (NX*NY.LT.4000) THEN #endif - IRET=NF90_INQ_VARID(NCID,"time",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"MT",VARIDTMP) - CALL CHECK_ERR(IRET) - ALLOCATE(ALLTIMES(NTI)) - IRET=NF90_GET_VAR(NCID,VARIDTMP,ALLTIMES,start=(/1/)) - CALL CHECK_ERR(IRET) - IF (INDEX(TIMEUNITS, "seconds").NE.0) ALLTIMES=ALLTIMES/86400. - IF (INDEX(TIMEUNITS, "minutes").NE.0) ALLTIMES=ALLTIMES/1440. - IF (INDEX(TIMEUNITS, "hours").NE.0) ALLTIMES=ALLTIMES/24. - ALLTIMES=REFJULDAY+ALLTIMES - -! -! Performs tidal analysis -! - TIDE_NTI = NTI - TIDE_NDEF = NFIELDS - ALLOCATE(SDEV0(TIDE_NDEF),SDEV(TIDE_NDEF), RMSR(TIDE_NDEF), & - RES(TIDE_NDEF), SSQ(TIDE_NDEF),RMSR0(TIDE_NDEF), & - RMSRP(TIDE_NDEF), IMAX(TIDE_NDEF), RESMAX(TIDE_NDEF)) - - ALLOCATE( TIDE_DATA(TIDE_NTI,TIDE_NDEF) ) - ALLOCATE( TIDE_DAYS(TIDE_NTI), TIDE_SECS(TIDE_NTI), TIDE_HOURS(TIDE_NTI) ) - ALLOCATE(V_ARG(170,TIDE_NTI),F_ARG(170,TIDE_NTI),U_ARG(170,TIDE_NTI)) - TIDE_NX=NX - TIDE_NY=NY - ALLOCATE(TIDAL_CONST(NX,NY,TIDE_MF,2,2)) - TIDAL_CONST(:,:,:,:,:)=0. - DO I=1,NFIELDS - IRET=NF90_INQ_VARID(NCID,FIELDSNAME(I),VARIDF(I)) - CALL CHECK_ERR(IRET) - END DO - IRET=NF90_GET_ATT(NCID,VARIDF(1),"_FillValue", FILLVALUE) - CALL CHECK_ERR(IRET) - IRET = NF90_GET_ATT(NCID,VARIDF(1),'scale_factor',SCFAC(1)) - IF (IRET .NE. 0) SCFAC(1) = 1.0 - IRET = NF90_GET_ATT(NCID,VARIDF(1),'add_offset',ADDOFF(1)) - IF (IRET .NE. 0) ADDOFF(1) = 0.0 - IF ( NFCOMP.EQ.2 .OR. (IFLD.GE.3 .AND. IFLD.NE.7) .OR. FLBERG ) THEN - IRET = NF90_GET_ATT(NCID,VARIDF(2),'scale_factor',SCFAC(2)) - IF (IRET .NE. 0) SCFAC(2) = 1.0 - IRET = NF90_GET_ATT(NCID,VARIDF(2),'add_offset',ADDOFF(2)) - IF (IRET .NE. 0) ADDOFF(2) = 0.0 - END IF - - -! -! Set arrays for MPI exchanges -! - IF (NX .LT. NAPROC) THEN - WRITE(NDSE,'(A)') 'NUMBER OF NX POINTS LESS THAN NUMBER OF PROC' - CALL EXTCDE (30) - END IF + WRITE(NDSE,'(A,I8,A)') 'Starting tidal analysis for ',NX*NY, ' points.' + IF (NAPROC.EQ.1) WRITE(NDSE,'(A)') 'This can take hours ...Consider running this with MPI ' + END IF +#ifdef W3_MPI + END IF +#endif + IRET=NF90_INQ_VARID(NCID,"time",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"MT",VARIDTMP) + CALL CHECK_ERR(IRET) + ALLOCATE(ALLTIMES(NTI)) + IRET=NF90_GET_VAR(NCID,VARIDTMP,ALLTIMES,start=(/1/)) + CALL CHECK_ERR(IRET) + IF (INDEX(TIMEUNITS, "seconds").NE.0) ALLTIMES=ALLTIMES/86400. + IF (INDEX(TIMEUNITS, "minutes").NE.0) ALLTIMES=ALLTIMES/1440. + IF (INDEX(TIMEUNITS, "hours").NE.0) ALLTIMES=ALLTIMES/24. + ALLTIMES=REFJULDAY+ALLTIMES + + ! + ! Performs tidal analysis + ! + TIDE_NTI = NTI + TIDE_NDEF = NFIELDS + ALLOCATE(SDEV0(TIDE_NDEF),SDEV(TIDE_NDEF), RMSR(TIDE_NDEF), & + RES(TIDE_NDEF), SSQ(TIDE_NDEF),RMSR0(TIDE_NDEF), & + RMSRP(TIDE_NDEF), IMAX(TIDE_NDEF), RESMAX(TIDE_NDEF)) + + ALLOCATE( TIDE_DATA(TIDE_NTI,TIDE_NDEF) ) + ALLOCATE( TIDE_DAYS(TIDE_NTI), TIDE_SECS(TIDE_NTI), TIDE_HOURS(TIDE_NTI) ) + ALLOCATE(V_ARG(170,TIDE_NTI),F_ARG(170,TIDE_NTI),U_ARG(170,TIDE_NTI)) + TIDE_NX=NX + TIDE_NY=NY + ALLOCATE(TIDAL_CONST(NX,NY,TIDE_MF,2,2)) + TIDAL_CONST(:,:,:,:,:)=0. + DO I=1,NFIELDS + IRET=NF90_INQ_VARID(NCID,FIELDSNAME(I),VARIDF(I)) + CALL CHECK_ERR(IRET) + END DO + IRET=NF90_GET_ATT(NCID,VARIDF(1),"_FillValue", FILLVALUE) + CALL CHECK_ERR(IRET) + IRET = NF90_GET_ATT(NCID,VARIDF(1),'scale_factor',SCFAC(1)) + IF (IRET .NE. 0) SCFAC(1) = 1.0 + IRET = NF90_GET_ATT(NCID,VARIDF(1),'add_offset',ADDOFF(1)) + IF (IRET .NE. 0) ADDOFF(1) = 0.0 + IF ( NFCOMP.EQ.2 .OR. (IFLD.GE.3 .AND. IFLD.NE.7) .OR. FLBERG ) THEN + IRET = NF90_GET_ATT(NCID,VARIDF(2),'scale_factor',SCFAC(2)) + IF (IRET .NE. 0) SCFAC(2) = 1.0 + IRET = NF90_GET_ATT(NCID,VARIDF(2),'add_offset',ADDOFF(2)) + IF (IRET .NE. 0) ADDOFF(2) = 0.0 + END IF + + + ! + ! Set arrays for MPI exchanges + ! + IF (NX .LT. NAPROC) THEN + WRITE(NDSE,'(A)') 'NUMBER OF NX POINTS LESS THAN NUMBER OF PROC' + CALL EXTCDE (30) + END IF #ifdef W3_MPI - SLICE=NX/NAPROC - REST=MOD(NX,NAPROC) - IF(REST.GE.IAPROC) SLICE=SLICE+1 + SLICE=NX/NAPROC + REST=MOD(NX,NAPROC) + IF(REST.GE.IAPROC) SLICE=SLICE+1 #endif #ifdef W3_MPI - ! set total 1D array (nx) - ALLOCATE (TIDE1D(NX * TIDE_MF * NFIELDS * 2)) - TIDE1D(:)=0. + ! set total 1D array (nx) + ALLOCATE (TIDE1D(NX * TIDE_MF * NFIELDS * 2)) + TIDE1D(:)=0. #endif #ifdef W3_MPI - ! set local 1D array (slice) - ALLOCATE(TIDE1DL(SLICE * TIDE_MF * NFIELDS * 2)) - TIDE1DL(:)=0. + ! set local 1D array (slice) + ALLOCATE(TIDE1DL(SLICE * TIDE_MF * NFIELDS * 2)) + TIDE1DL(:)=0. #endif - ! set arrays for number of elements per MPI proc - ALLOCATE(CUMUL(NAPROC)) - ALLOCATE(NELEM(NAPROC)) - CUMUL(1) = 0 - NELEM(1) = NX / NAPROC + ! set arrays for number of elements per MPI proc + ALLOCATE(CUMUL(NAPROC)) + ALLOCATE(NELEM(NAPROC)) + CUMUL(1) = 0 + NELEM(1) = NX / NAPROC #ifdef W3_MPI - IF (REST .GT. 0) NELEM(1) = NELEM(1) + 1 - DO I=2,NAPROC - CUMUL(I)=CUMUL(I-1)+NELEM(I-1) - NELEM(I) = NX / NAPROC - IF (REST .GT. I-1) NELEM(I) = NELEM(I) + 1 - END DO + IF (REST .GT. 0) NELEM(1) = NELEM(1) + 1 + DO I=2,NAPROC + CUMUL(I)=CUMUL(I-1)+NELEM(I-1) + NELEM(I) = NX / NAPROC + IF (REST .GT. I-1) NELEM(I) = NELEM(I) + 1 + END DO #endif - + #ifdef W3_MPIT - WRITE(100+IAPROC,*) "Number of points for this processor ", IAPROC, " : ", NELEM(IAPROC), ' / ', NX - WRITE(100+IAPROC,*) "Cumul of points for this processor ", IAPROC, " : ", CUMUL(IAPROC), ' / ', NX - WRITE(100+IAPROC,*) "Slice of values per processor ", SLICE + WRITE(100+IAPROC,*) "Number of points for this processor ", IAPROC, " : ", NELEM(IAPROC), ' / ', NX + WRITE(100+IAPROC,*) "Cumul of points for this processor ", IAPROC, " : ", CUMUL(IAPROC), ' / ', NX + WRITE(100+IAPROC,*) "Slice of values per processor ", SLICE #endif - ALLOCATE(TIDE_DATA_ALL(NELEM(IAPROC),NTI,NFIELDS)) + ALLOCATE(TIDE_DATA_ALL(NELEM(IAPROC),NTI,NFIELDS)) -! -! Loops on Y dimension -! - ALLOCATE(TIDALCOMP(NX,NY)) - TIDALCOMP=.TRUE. -! - DO IY=1,NY + ! + ! Loops on Y dimension + ! + ALLOCATE(TIDALCOMP(NX,NY)) + TIDALCOMP=.TRUE. + ! + DO IY=1,NY #ifdef W3_MPI - IND=0 -#endif -! - IF (NDIMSGRID.EQ.1) THEN - DO I=1,NFIELDS - IRET=NF90_GET_VAR(NCID,VARIDF(I),TIDE_DATA_ALL(:,:,I), & - start=(/CUMUL(IAPROC)+1,1/),count=(/NELEM(IAPROC),NTI/)) - CALL CHECK_ERR(IRET) - WHERE (TIDE_DATA_ALL(:,:,I).NE.FILLVALUE) TIDE_DATA_ALL(:,:,I)=TIDE_DATA_ALL(:,:,I)*SCFAC(I)+ADDOFF(I) - END DO - ELSE IF (NDIMSGRID.EQ.2) THEN - IF (NDIMSVAR.EQ.3) THEN - DO I=1,NFIELDS - IRET=NF90_GET_VAR(NCID,VARIDF(I),TIDE_DATA_ALL(:,:,I), & - start=(/CUMUL(IAPROC)+1,IY,1/),count=(/NELEM(IAPROC),1,NTI/)) - CALL CHECK_ERR(IRET) - WHERE (TIDE_DATA_ALL(:,:,I).NE.FILLVALUE) TIDE_DATA_ALL(:,:,I)=TIDE_DATA_ALL(:,:,I)*SCFAC(I)+ADDOFF(I) - END DO - ELSE IF (NDIMSVAR.EQ.4) THEN - DO I=1,NFIELDS - IRET=NF90_GET_VAR(NCID,VARIDF(I),TIDE_DATA_ALL(:,:,I), & - start=(/CUMUL(IAPROC)+1,IY,1,1/),count=(/NELEM(IAPROC),1,1,NTI/)) - CALL CHECK_ERR(IRET) - WHERE (TIDE_DATA_ALL(:,:,I).NE.FILLVALUE) TIDE_DATA_ALL(:,:,I)=TIDE_DATA_ALL(:,:,I)*SCFAC(I)+ADDOFF(I) - END DO - END IF ! NDIMSVAR - END IF ! NDIMSGRID + IND=0 +#endif + ! + IF (NDIMSGRID.EQ.1) THEN + DO I=1,NFIELDS + IRET=NF90_GET_VAR(NCID,VARIDF(I),TIDE_DATA_ALL(:,:,I), & + start=(/CUMUL(IAPROC)+1,1/),count=(/NELEM(IAPROC),NTI/)) + CALL CHECK_ERR(IRET) + WHERE (TIDE_DATA_ALL(:,:,I).NE.FILLVALUE) TIDE_DATA_ALL(:,:,I)=TIDE_DATA_ALL(:,:,I)*SCFAC(I)+ADDOFF(I) + END DO + ELSE IF (NDIMSGRID.EQ.2) THEN + IF (NDIMSVAR.EQ.3) THEN + DO I=1,NFIELDS + IRET=NF90_GET_VAR(NCID,VARIDF(I),TIDE_DATA_ALL(:,:,I), & + start=(/CUMUL(IAPROC)+1,IY,1/),count=(/NELEM(IAPROC),1,NTI/)) + CALL CHECK_ERR(IRET) + WHERE (TIDE_DATA_ALL(:,:,I).NE.FILLVALUE) TIDE_DATA_ALL(:,:,I)=TIDE_DATA_ALL(:,:,I)*SCFAC(I)+ADDOFF(I) + END DO + ELSE IF (NDIMSVAR.EQ.4) THEN + DO I=1,NFIELDS + IRET=NF90_GET_VAR(NCID,VARIDF(I),TIDE_DATA_ALL(:,:,I), & + start=(/CUMUL(IAPROC)+1,IY,1,1/),count=(/NELEM(IAPROC),1,1,NTI/)) + CALL CHECK_ERR(IRET) + WHERE (TIDE_DATA_ALL(:,:,I).NE.FILLVALUE) TIDE_DATA_ALL(:,:,I)=TIDE_DATA_ALL(:,:,I)*SCFAC(I)+ADDOFF(I) + END DO + END IF ! NDIMSVAR + END IF ! NDIMSGRID - -! - DO JX=1,NELEM(IAPROC) + + ! + DO JX=1,NELEM(IAPROC) #ifdef W3_MPI - IX=CUMUL(IAPROC)+JX + IX=CUMUL(IAPROC)+JX #endif #ifdef W3_SHRD - IX=JX -#endif - -! - TIDE_NTI=0 - DO I=1,NTI -! -! Defines usable timesteps ... criteria could be improved -! remove the times when the point IX,IY is dry ... -! and redefine TIDE_NTI based on wet times only -! - IF (TIDE_DATA_ALL(JX,I,1).NE.FILLVALUE & - .AND.TIDE_DATA_ALL(JX,I,NFIELDS).NE.FILLVALUE & - .AND.TIDE_DATA_ALL(JX,I,1).NE.0.0) THEN - TIDE_NTI=TIDE_NTI+1 - TIDE_DATA(TIDE_NTI,:)=TIDE_DATA_ALL(JX,I,:) - TIDE_DAYS(TIDE_NTI)=INT(ALLTIMES(I)) - TIDE_SECS(TIDE_NTI)=(ALLTIMES(I)-TIDE_DAYS(TIDE_NTI))*86400 - END IF - END DO ! NTI -! - TIDE_HOURS(1:TIDE_NTI)=24.d0*dfloat(TIDE_DAYS(1:TIDE_NTI)) & - +dfloat(TIDE_SECS(1:TIDE_NTI))/3600.d0 - -! -! Compute amplitude and phase -! - IF (TIDE_NTI.GT.(TIDE_MF*3)) THEN - TIDE_LAT= YGRD(IY,IX) - IF (ABS(TIDE_LAT).LT.5.) TIDE_LAT=SIGN(5.,TIDE_LAT) - DO I=1,TIDE_NTI - CALL SETVUF(TIDE_HOURS(I),TIDE_LAT,I) - END DO - TIDE_ITREND=0 - CALL flex_tidana_webpage(IX,IY,REAL(XGRD(IY,IX)),TIDE_LAT,TIDE_DAYS(1),TIDE_DAYS(TIDE_NTI), & - TIDE_NDEF, TIDE_ITREND, RES, SSQ, RMSR0, & - SDEV0, RMSR, RESMAX, IMAX, 0) + IX=JX +#endif + + ! + TIDE_NTI=0 + DO I=1,NTI + ! + ! Defines usable timesteps ... criteria could be improved + ! remove the times when the point IX,IY is dry ... + ! and redefine TIDE_NTI based on wet times only + ! + IF (TIDE_DATA_ALL(JX,I,1).NE.FILLVALUE & + .AND.TIDE_DATA_ALL(JX,I,NFIELDS).NE.FILLVALUE & + .AND.TIDE_DATA_ALL(JX,I,1).NE.0.0) THEN + TIDE_NTI=TIDE_NTI+1 + TIDE_DATA(TIDE_NTI,:)=TIDE_DATA_ALL(JX,I,:) + TIDE_DAYS(TIDE_NTI)=INT(ALLTIMES(I)) + TIDE_SECS(TIDE_NTI)=(ALLTIMES(I)-TIDE_DAYS(TIDE_NTI))*86400 + END IF + END DO ! NTI + ! + TIDE_HOURS(1:TIDE_NTI)=24.d0*dfloat(TIDE_DAYS(1:TIDE_NTI)) & + +dfloat(TIDE_SECS(1:TIDE_NTI))/3600.d0 + + ! + ! Compute amplitude and phase + ! + IF (TIDE_NTI.GT.(TIDE_MF*3)) THEN + TIDE_LAT= YGRD(IY,IX) + IF (ABS(TIDE_LAT).LT.5.) TIDE_LAT=SIGN(5.,TIDE_LAT) + DO I=1,TIDE_NTI + CALL SETVUF(TIDE_HOURS(I),TIDE_LAT,I) + END DO + TIDE_ITREND=0 + CALL flex_tidana_webpage(IX,IY,REAL(XGRD(IY,IX)),TIDE_LAT,TIDE_DAYS(1),TIDE_DAYS(TIDE_NTI), & + TIDE_NDEF, TIDE_ITREND, RES, SSQ, RMSR0, & + SDEV0, RMSR, RESMAX, IMAX, 0) #ifdef W3_T - WRITE (989,'(2I10,X,176F10.3)'),IX,TIDE_NTI,TIDE_AMPC(1:TIDE_MF,1:NFIELDS) - WRITE (989,'(2I10,X,176F10.3)'),IX,TIDE_NTI,TIDE_PHG(1:TIDE_MF,1:NFIELDS) - RPOS = 1_8 + LRECL*(IX-1_8) - WRITE (990,POS=RPOS),NULLBUFF(1:NREC) - WRITE (990,POS=RPOS),TIDE_AMPC(1:TIDE_MF,1:NFIELDS),TIDE_PHG(1:TIDE_MF,1:NFIELDS) + WRITE (989,'(2I10,X,176F10.3)'),IX,TIDE_NTI,TIDE_AMPC(1:TIDE_MF,1:NFIELDS) + WRITE (989,'(2I10,X,176F10.3)'),IX,TIDE_NTI,TIDE_PHG(1:TIDE_MF,1:NFIELDS) + RPOS = 1_8 + LRECL*(IX-1_8) + WRITE (990,POS=RPOS),NULLBUFF(1:NREC) + WRITE (990,POS=RPOS),TIDE_AMPC(1:TIDE_MF,1:NFIELDS),TIDE_PHG(1:TIDE_MF,1:NFIELDS) #endif - ELSE - TIDALCOMP(IX,IY)=.FALSE. - TIDE_AMPC(1:TIDE_MF,1:NFIELDS)=0. - TIDE_PHG(1:TIDE_MF,1:NFIELDS)=0. - END IF ! end of test on TIDE_NTI + ELSE + TIDALCOMP(IX,IY)=.FALSE. + TIDE_AMPC(1:TIDE_MF,1:NFIELDS)=0. + TIDE_PHG(1:TIDE_MF,1:NFIELDS)=0. + END IF ! end of test on TIDE_NTI -! -! Save tidal amplitude and phase -! + ! + ! Save tidal amplitude and phase + ! #ifdef W3_MPIT - IF (IAPROC.EQ.NAPOUT) WRITE(NDSO,'(A,I6,A,I6,A,I6)') 'IY, JX = ', & - IY,',',JX, ' out of ', NELEM(IAPROC) + IF (IAPROC.EQ.NAPOUT) WRITE(NDSO,'(A,I6,A,I6,A,I6)') 'IY, JX = ', & + IY,',',JX, ' out of ', NELEM(IAPROC) #endif #ifdef W3_MPI - DO J=1,TIDE_MF - DO K=1,NFIELDS - IND=IND+1 - TIDE1DL(IND)=TIDE_AMPC(J,K) - IND=IND+1 - TIDE1DL(IND)=TIDE_PHG(J,K) - END DO + DO J=1,TIDE_MF + DO K=1,NFIELDS + IND=IND+1 + TIDE1DL(IND)=TIDE_AMPC(J,K) + IND=IND+1 + TIDE1DL(IND)=TIDE_PHG(J,K) END DO + END DO #endif #ifdef W3_SHRD - TIDAL_CONST(IX,IY,1:TIDE_MF,1:NFIELDS,1)=TIDE_AMPC(1:TIDE_MF,1:NFIELDS) - TIDAL_CONST(IX,IY,1:TIDE_MF,1:NFIELDS,2)=TIDE_PHG(1:TIDE_MF,1:NFIELDS) + TIDAL_CONST(IX,IY,1:TIDE_MF,1:NFIELDS,1)=TIDE_AMPC(1:TIDE_MF,1:NFIELDS) + TIDAL_CONST(IX,IY,1:TIDE_MF,1:NFIELDS,2)=TIDE_PHG(1:TIDE_MF,1:NFIELDS) #endif - END DO ! JX=1,NELEM(IAPROC) + END DO ! JX=1,NELEM(IAPROC) -! -! Gather from other MPI tasks -! + ! + ! Gather from other MPI tasks + ! #ifdef W3_MPI - IF (NAPROC.GT.1) THEN - CALL MPI_GATHERV(TIDE1DL, SLICE * TIDE_MF * NFIELDS * 2, MPI_REAL, & - TIDE1D, NELEM * TIDE_MF * NFIELDS * 2, CUMUL * TIDE_MF * NFIELDS * 2, & - MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + IF (NAPROC.GT.1) THEN + CALL MPI_GATHERV(TIDE1DL, SLICE * TIDE_MF * NFIELDS * 2, MPI_REAL, & + TIDE1D, NELEM * TIDE_MF * NFIELDS * 2, CUMUL * TIDE_MF * NFIELDS * 2, & + MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) #endif #ifdef W3_MPI - IF (IAPROC.EQ.NAPOUT) THEN - CALL MPI_GATHERV(MPI_IN_PLACE,NELEM(IAPROC), & - MPI_LOGICAL, TIDALCOMP(:,IY), NELEM, CUMUL, MPI_LOGICAL, NAPOUT-1, & - MPI_COMM_WORLD, IERR_MPI) - ELSE - CALL MPI_GATHERV(TIDALCOMP(CUMUL(IAPROC)+1:CUMUL(IAPROC)+NELEM(IAPROC),IY),NELEM(IAPROC), & - MPI_LOGICAL, TIDALCOMP(:,IY), NELEM, CUMUL, MPI_LOGICAL, NAPOUT-1, & - MPI_COMM_WORLD, IERR_MPI) - END IF + IF (IAPROC.EQ.NAPOUT) THEN + CALL MPI_GATHERV(MPI_IN_PLACE,NELEM(IAPROC), & + MPI_LOGICAL, TIDALCOMP(:,IY), NELEM, CUMUL, MPI_LOGICAL, NAPOUT-1, & + MPI_COMM_WORLD, IERR_MPI) + ELSE + CALL MPI_GATHERV(TIDALCOMP(CUMUL(IAPROC)+1:CUMUL(IAPROC)+NELEM(IAPROC),IY),NELEM(IAPROC), & + MPI_LOGICAL, TIDALCOMP(:,IY), NELEM, CUMUL, MPI_LOGICAL, NAPOUT-1, & + MPI_COMM_WORLD, IERR_MPI) + END IF #endif #ifdef W3_MPI - ELSE - TIDE1D = TIDE1DL - END IF + ELSE + TIDE1D = TIDE1DL + END IF #endif -! -! Convert from 1D to 2D array -! + ! + ! Convert from 1D to 2D array + ! #ifdef W3_MPI - IF (IAPROC .EQ. NAPOUT) THEN - IND=0 - DO IX=1,NX - DO J=1,TIDE_MF - DO K=1,NFIELDS - DO L=1,2 - IND=IND+1 - TIDAL_CONST(IX,IY,J,K,L)=TIDE1D(IND) - END DO - END DO + IF (IAPROC .EQ. NAPOUT) THEN + IND=0 + DO IX=1,NX + DO J=1,TIDE_MF + DO K=1,NFIELDS + DO L=1,2 + IND=IND+1 + TIDAL_CONST(IX,IY,J,K,L)=TIDE1D(IND) END DO END DO - END IF + END DO + END DO + END IF #endif - - END DO ! IY=1,NY + + END DO ! IY=1,NY #ifdef W3_T CLOSE (990) CLOSE (989) - IF (IDFLD.EQ.'CUR') WRITE(986,'(F10.3,/)') TIDAL_CONST(:,1,15,1,1) - IF (IDFLD.EQ.'CUR') WRITE(986,'(F10.3,/)') TIDAL_CONST(:,1,15,2,1) + IF (IDFLD.EQ.'CUR') WRITE(986,'(F10.3,/)') TIDAL_CONST(:,1,15,1,1) + IF (IDFLD.EQ.'CUR') WRITE(986,'(F10.3,/)') TIDAL_CONST(:,1,15,2,1) #endif #ifdef W3_MPI - IF (IAPROC .NE. NAPOUT ) THEN - GOTO 888 + IF (IAPROC .NE. NAPOUT ) THEN + GOTO 888 #endif #ifdef W3_MPIT - ELSE - WRITE(NDSO,'(A)') "parallelization done" + ELSE + WRITE(NDSO,'(A)') "parallelization done" #endif #ifdef W3_MPI - END IF + END IF #endif -! -! Warn about not computed nodes for tidal constituents -! - IF ( IAPROC .EQ. NAPOUT) THEN - DO IX=1,NX - DO IY=1,NY - IF(TIDALCOMP(IX,IY).EQV..FALSE.) THEN - WRITE(NDSO,1047) IX, IY - END IF - END DO - END DO + ! + ! Warn about not computed nodes for tidal constituents + ! + IF ( IAPROC .EQ. NAPOUT) THEN + DO IX=1,NX + DO IY=1,NY + IF(TIDALCOMP(IX,IY).EQV..FALSE.) THEN + WRITE(NDSO,1047) IX, IY + END IF + END DO + END DO + END IF + + ! + ! After loop on points, write tidal constituents to file. + ! + IF ( IAPROC .EQ. NAPOUT.AND.TIDEFLAG.GE.1) & + CALL W3FLDTIDE1 ( 'WRITE', NDSDAT, NDST, NDSE, NX, NY, IDFLD, IERR ) + CALL W3FLDTIDE2 ( 'WRITE', NDSDAT, NDST, NDSE, NX, NY, IDFLD, 0, IERR ) + ! + GOTO 880 + + END IF ! end of test IF (ITYPE.GE.6.AND.TIDEFLAG.GT.0) + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 8 Begin loop over input fields + ! + ! Read scale factor and offset for input fields + XCFAC = 1.0 + YCFAC = 1.0 + XCOFF = 0.0 + YCOFF = 0.0 + ! + IF ( ITYPE .LE. 4 .OR. ITYPE.EQ.6 ) THEN + IRET = NF90_GET_ATT(NCID,VARIDF(1),'scale_factor',XCFAC) + IF (IRET.NE.0 ) XCFAC = 1.0 + IRET = NF90_GET_ATT(NCID,VARIDF(1),'add_offset',XCOFF) + IF (IRET.NE.0 ) XCOFF = 0.0 + IF ( NFCOMP.EQ.2 .OR. (IFLD.GE.3 .AND. IFLD.NE.7) .OR. FLBERG ) THEN + IRET = NF90_GET_ATT(NCID,VARIDF(2),'scale_factor',YCFAC) + IF (IRET.NE.0 ) YCFAC = 1.0 + IRET = NF90_GET_ATT(NCID,VARIDF(2),'add_offset',YCOFF) + IF (IRET.NE.0 ) YCOFF = 0.0 + END IF + END IF + ! +#ifdef W3_O15 + J = LEN_TRIM(FNMPRE) + OPEN (NDSTIME,FILE=FNMPRE(:J)//'times.'//IDFLD, & + ERR=870,IOSTAT=IERR ) +#endif + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,972) + TIMEDELAY = 0 + DO ITIME=1,NTI + ! + ! 8.a Read new time and fields + ! + IRET=NF90_INQ_VARID(NCID,"time",VARIDTMP) + IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"MT",VARIDTMP) + CALL CHECK_ERR(IRET) + IRET=NF90_GET_VAR(NCID,VARIDTMP,CURJULDAY,start=(/ITIME/)) + call CHECK_ERR(IRET) + IF (INDEX(TIMEUNITS, "seconds").NE.0) CURJULDAY=CURJULDAY/86400. + IF (INDEX(TIMEUNITS, "minutes").NE.0) CURJULDAY=CURJULDAY/1440. + IF (INDEX(TIMEUNITS, "hours").NE.0) CURJULDAY=CURJULDAY/24. + CURJULDAY=REFJULDAY+CURJULDAY + + ! cycle until reaching the start time + IF (STARTJULDAY.GT.CURJULDAY) CYCLE + + ! exit when reaching the stop time + IF (STPJULDAY.LT.CURJULDAY) EXIT + + ! convert julday to date and time + CALL J2D(CURJULDAY,CURDATE,IERR) + CALL D2T(CURDATE,TIME,IERR) + CALL STME21 (TIME,IDTIME) + + ! define time delay + IF (.NOT.FLTIME.AND.TIMEDELAY.EQ.0) THEN + TIMEDELAY = DSEC21 (TIME,TIMESHIFT) + END IF + + ! shift time + IF (TIMEDELAY.NE.0) THEN + CALL TICK21 (TIME,TIMEDELAY) + CALL STME21 (TIME,IDTIME2) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1973) IDTIME2, IDTIME + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2973) IDTIME + END IF +#ifdef W3_O15 + WRITE (NDSTIME, 979, ERR=871,IOSTAT=IERR) TIME +#endif +#ifdef W3_O3 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,974) +#endif + ! + ! ... Input + ! + IF ( ITYPE .LE. 4 .OR. ITYPE.EQ.6 ) THEN + IF (NDIMSGRID.EQ.1) THEN + IRET=NF90_GET_VAR(NCID,VARIDF(1),XC(:,1),start=(/1,ITIME/),count=(/MXM,1/)) + ELSE + IF (NDIMSVAR.EQ.3) THEN + IRET=NF90_GET_VAR(NCID,VARIDF(1),XC,start=(/1,1,ITIME/),count=(/MXM,MYM,1/)) + ELSE + IRET=NF90_GET_VAR(NCID,VARIDF(1),XC,start=(/1,1,1,ITIME/),count=(/MXM,MYM,1,1/)) END IF + END IF + CALL CHECK_ERR(IRET) + ! forces undefined values to FILLVALUE + WHERE(XC.NE.XC) XC = FILLVALUE + WHERE (XC.NE.FILLVALUE) XC=XC*XCFAC+XCOFF -! -! After loop on points, write tidal constituents to file. -! - IF ( IAPROC .EQ. NAPOUT.AND.TIDEFLAG.GE.1) & - CALL W3FLDTIDE1 ( 'WRITE', NDSDAT, NDST, NDSE, NX, NY, IDFLD, IERR ) - CALL W3FLDTIDE2 ( 'WRITE', NDSDAT, NDST, NDSE, NX, NY, IDFLD, 0, IERR ) -! - GOTO 880 - - END IF ! end of test IF (ITYPE.GE.6.AND.TIDEFLAG.GT.0) - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 8 Begin loop over input fields -! -! Read scale factor and offset for input fields - XCFAC = 1.0 - YCFAC = 1.0 - XCOFF = 0.0 - YCOFF = 0.0 -! - IF ( ITYPE .LE. 4 .OR. ITYPE.EQ.6 ) THEN - IRET = NF90_GET_ATT(NCID,VARIDF(1),'scale_factor',XCFAC) - IF (IRET.NE.0 ) XCFAC = 1.0 - IRET = NF90_GET_ATT(NCID,VARIDF(1),'add_offset',XCOFF) - IF (IRET.NE.0 ) XCOFF = 0.0 - IF ( NFCOMP.EQ.2 .OR. (IFLD.GE.3 .AND. IFLD.NE.7) .OR. FLBERG ) THEN - IRET = NF90_GET_ATT(NCID,VARIDF(2),'scale_factor',YCFAC) - IF (IRET.NE.0 ) YCFAC = 1.0 - IRET = NF90_GET_ATT(NCID,VARIDF(2),'add_offset',YCOFF) - IF (IRET.NE.0 ) YCOFF = 0.0 - END IF + ! +#ifdef W3_T2 + WRITE (NDST,9060) 1 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(1) ) + DO + CALL PRTBLK ( NDST, NXJ(1), NYJ(1), MXM, XC, MASK, 0, 0.,& + IXP0, IXPN, 1, 1, NYJ(1), 1, 'Field 1', ' ') + IF (IXPN.NE.NXJ(1)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(1) ) + ELSE + EXIT END IF -! -#ifdef W3_O15 - J = LEN_TRIM(FNMPRE) - OPEN (NDSTIME,FILE=FNMPRE(:J)//'times.'//IDFLD, & - ERR=870,IOSTAT=IERR ) -#endif -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,972) - TIMEDELAY = 0 - DO ITIME=1,NTI -! -! 8.a Read new time and fields -! - IRET=NF90_INQ_VARID(NCID,"time",VARIDTMP) - IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"MT",VARIDTMP) - CALL CHECK_ERR(IRET) - IRET=NF90_GET_VAR(NCID,VARIDTMP,CURJULDAY,start=(/ITIME/)) - call CHECK_ERR(IRET) - IF (INDEX(TIMEUNITS, "seconds").NE.0) CURJULDAY=CURJULDAY/86400. - IF (INDEX(TIMEUNITS, "minutes").NE.0) CURJULDAY=CURJULDAY/1440. - IF (INDEX(TIMEUNITS, "hours").NE.0) CURJULDAY=CURJULDAY/24. - CURJULDAY=REFJULDAY+CURJULDAY - - ! cycle until reaching the start time - IF (STARTJULDAY.GT.CURJULDAY) CYCLE - - ! exit when reaching the stop time - IF (STPJULDAY.LT.CURJULDAY) EXIT - - ! convert julday to date and time - CALL J2D(CURJULDAY,CURDATE,IERR) - CALL D2T(CURDATE,TIME,IERR) - CALL STME21 (TIME,IDTIME) - - ! define time delay - IF (.NOT.FLTIME.AND.TIMEDELAY.EQ.0) THEN - TIMEDELAY = DSEC21 (TIME,TIMESHIFT) - END IF + END DO +#endif + ! + IF (NFCOMP.EQ.2 .OR. (IFLD.GE.3 .AND. IFLD.NE.7) .OR. FLBERG) THEN - ! shift time - IF (TIMEDELAY.NE.0) THEN - CALL TICK21 (TIME,TIMEDELAY) - CALL STME21 (TIME,IDTIME2) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1973) IDTIME2, IDTIME + ! This is a quick fix that works if the lon,lat,level,time dimensions are in that order + ! otherwise, one should check the length of each dimension ... + IF (NDIMSGRID.EQ.1) THEN + IRET=NF90_GET_VAR(NCID,VARIDF(2),YC(:,1),start=(/1,ITIME/),count=(/MXM,1/)) + ELSE + IF (NDIMSVAR.EQ.3) THEN + IRET=NF90_GET_VAR(NCID,VARIDF(2),YC,start=(/1,1,ITIME/),count=(/MXM,MYM,1/)) ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2973) IDTIME + IRET=NF90_GET_VAR(NCID,VARIDF(2),YC,start=(/1,1,1,ITIME/),count=(/MXM,MYM,1,1/)) END IF -#ifdef W3_O15 - WRITE (NDSTIME, 979, ERR=871,IOSTAT=IERR) TIME + END IF + ! The following line forces to 0 values that are undefine + CALL CHECK_ERR(IRET) + WHERE(YC.NE.YC) YC = FILLVALUE + WHERE (YC.NE.FILLVALUE) YC=YC*YCFAC+YCOFF + ! +#ifdef W3_T2 + WRITE (NDST,9060) 2 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) + DO + CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, YC, MASK, 0, 0., & + IXP0, IXPN, 1, 1, NYJ(2), 1, 'Field 2', ' ') + IF (IXPN.NE.NXJ(2)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) + ELSE + EXIT + END IF + END DO #endif -#ifdef W3_O3 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,974) -#endif -! -! ... Input -! - IF ( ITYPE .LE. 4 .OR. ITYPE.EQ.6 ) THEN - IF (NDIMSGRID.EQ.1) THEN - IRET=NF90_GET_VAR(NCID,VARIDF(1),XC(:,1),start=(/1,ITIME/),count=(/MXM,1/)) + ! + IF (FLSTAB) THEN + ! This is a quick fix that works if the lon,lat,level,time dimensions are in that order + ! otherwise, one should check the length of each dimension ... + IF (NDIMSGRID.EQ.1) THEN + IRET=NF90_GET_VAR(NCID,VARIDF(3),AC(:,1),start=(/1,ITIME/),count=(/MXM,1/)) + ELSE + IF (NDIMSVAR.EQ.3) THEN + IRET=NF90_GET_VAR(NCID,VARIDF(3),AC,start=(/1,1,ITIME/),count=(/MXM,MYM,1/)) ELSE - IF (NDIMSVAR.EQ.3) THEN - IRET=NF90_GET_VAR(NCID,VARIDF(1),XC,start=(/1,1,ITIME/),count=(/MXM,MYM,1/)) - ELSE - IRET=NF90_GET_VAR(NCID,VARIDF(1),XC,start=(/1,1,1,ITIME/),count=(/MXM,MYM,1,1/)) - END IF + IRET=NF90_GET_VAR(NCID,VARIDF(3),AC,start=(/1,1,1,ITIME/),count=(/MXM,MYM,1,1/)) END IF - CALL CHECK_ERR(IRET) - ! forces undefined values to FILLVALUE - WHERE(XC.NE.XC) XC = FILLVALUE - WHERE (XC.NE.FILLVALUE) XC=XC*XCFAC+XCOFF - -! + END IF + CALL CHECK_ERR(IRET) + !AC(:,:)=AC(:,MYM:1:-1) + ! #ifdef W3_T2 - WRITE (NDST,9060) 1 - IXP0 = 1 - IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(1) ) - DO - CALL PRTBLK ( NDST, NXJ(1), NYJ(1), MXM, XC, MASK, 0, 0.,& - IXP0, IXPN, 1, 1, NYJ(1), 1, 'Field 1', ' ') - IF (IXPN.NE.NXJ(1)) THEN - IXP0 = IXP0 + IXPWDT - IXPN = MIN ( IXPN+IXPWDT , NXJ(1) ) - ELSE - EXIT - END IF - END DO + WRITE (NDST,9060) 3 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) + DO + CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, AC, MASK, 0,& + 0., IXP0, IXPN, 1,1, NYJ(2), 1, 'Field 3', ' ') + IF (IXPN.NE.NXJ(2)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) + ELSE + EXIT + END IF + END DO #endif -! - IF (NFCOMP.EQ.2 .OR. (IFLD.GE.3 .AND. IFLD.NE.7) .OR. FLBERG) THEN - -! This is a quick fix that works if the lon,lat,level,time dimensions are in that order -! otherwise, one should check the length of each dimension ... - IF (NDIMSGRID.EQ.1) THEN - IRET=NF90_GET_VAR(NCID,VARIDF(2),YC(:,1),start=(/1,ITIME/),count=(/MXM,1/)) - ELSE - IF (NDIMSVAR.EQ.3) THEN - IRET=NF90_GET_VAR(NCID,VARIDF(2),YC,start=(/1,1,ITIME/),count=(/MXM,MYM,1/)) - ELSE - IRET=NF90_GET_VAR(NCID,VARIDF(2),YC,start=(/1,1,1,ITIME/),count=(/MXM,MYM,1,1/)) - END IF - END IF -! The following line forces to 0 values that are undefine - CALL CHECK_ERR(IRET) - WHERE(YC.NE.YC) YC = FILLVALUE - WHERE (YC.NE.FILLVALUE) YC=YC*YCFAC+YCOFF -! -#ifdef W3_T2 - WRITE (NDST,9060) 2 - IXP0 = 1 - IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) - DO - CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, YC, MASK, 0, 0., & - IXP0, IXPN, 1, 1, NYJ(2), 1, 'Field 2', ' ') - IF (IXPN.NE.NXJ(2)) THEN - IXP0 = IXP0 + IXPWDT - IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) - ELSE - EXIT - END IF - END DO -#endif -! - IF (FLSTAB) THEN -! This is a quick fix that works if the lon,lat,level,time dimensions are in that order -! otherwise, one should check the length of each dimension ... - IF (NDIMSGRID.EQ.1) THEN - IRET=NF90_GET_VAR(NCID,VARIDF(3),AC(:,1),start=(/1,ITIME/),count=(/MXM,1/)) - ELSE - IF (NDIMSVAR.EQ.3) THEN - IRET=NF90_GET_VAR(NCID,VARIDF(3),AC,start=(/1,1,ITIME/),count=(/MXM,MYM,1/)) - ELSE - IRET=NF90_GET_VAR(NCID,VARIDF(3),AC,start=(/1,1,1,ITIME/),count=(/MXM,MYM,1,1/)) - END IF - END IF - CALL CHECK_ERR(IRET) - !AC(:,:)=AC(:,MYM:1:-1) -! -#ifdef W3_T2 - WRITE (NDST,9060) 3 - IXP0 = 1 - IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) - DO - CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, AC, MASK, 0,& - 0., IXP0, IXPN, 1,1, NYJ(2), 1, 'Field 3', ' ') - IF (IXPN.NE.NXJ(2)) THEN - IXP0 = IXP0 + IXPWDT - IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) - ELSE - EXIT - END IF - END DO -#endif -! - END IF -! - END IF - - ELSE ! ITYPE .NE. 5 -! - IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSO,*) "ITYPE5 TO DO" - IF (IDFMF(1).EQ.3) THEN - READ (NDSF(1), END=862,ERR=862,IOSTAT=IERR) NDAT - ELSE - READ (NDSF(1),*,END=862,ERR=862,IOSTAT=IERR) NDAT - END IF + ! + END IF + ! + END IF + + ELSE ! ITYPE .NE. 5 + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSO,*) "ITYPE5 TO DO" + IF (IDFMF(1).EQ.3) THEN + READ (NDSF(1), END=862,ERR=862,IOSTAT=IERR) NDAT + ELSE + READ (NDSF(1),*,END=862,ERR=862,IOSTAT=IERR) NDAT + END IF #ifdef W3_O3 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,975) NDAT -#endif - IF ( NDAT.GT.0 ) THEN - ALLOCATE ( DATA(RECLDT,NDAT) ) - DO IDAT=1, NDAT - IF (IDFMF(1).EQ.1) THEN - READ (NDSF(1), * ,END=863,ERR=863, & - IOSTAT=IERR) DATA(:,IDAT) - ELSE IF (IDFMF(1).EQ.2) THEN - READ (NDSF(1),FORMT(1),END=863,ERR=863, & - IOSTAT=IERR) DATA(:,IDAT) - ELSE - READ (NDSF(1), END=863,ERR=863, & - IOSTAT=IERR) DATA(:,IDAT) - END IF - END DO - END IF -! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,975) NDAT +#endif + IF ( NDAT.GT.0 ) THEN + ALLOCATE ( DATA(RECLDT,NDAT) ) + DO IDAT=1, NDAT + IF (IDFMF(1).EQ.1) THEN + READ (NDSF(1), * ,END=863,ERR=863, & + IOSTAT=IERR) DATA(:,IDAT) + ELSE IF (IDFMF(1).EQ.2) THEN + READ (NDSF(1),FORMT(1),END=863,ERR=863, & + IOSTAT=IERR) DATA(:,IDAT) + ELSE + READ (NDSF(1), END=863,ERR=863, & + IOSTAT=IERR) DATA(:,IDAT) + END IF + END DO + END IF + ! #ifdef W3_T2 - WRITE (NDST,9061) - DO IDAT=1, NDAT - IX = MIN(6,RECLDT) - WRITE (NDST,9062) IDAT, DATA(1:IX,IDAT) - IF ( IX.LT.RECLDT ) WRITE (NDST,9063) DATA(IX+1:,:) - END DO + WRITE (NDST,9061) + DO IDAT=1, NDAT + IX = MIN(6,RECLDT) + WRITE (NDST,9062) IDAT, DATA(1:IX,IDAT) + IF ( IX.LT.RECLDT ) WRITE (NDST,9063) DATA(IX+1:,:) + END DO #endif -! - END IF -! -! 8.b Interpolate fields -! ... No Interpolation, type AI (should not use array syntax !!!) -! - IF (ITYPE.EQ.1.OR.ITYPE.EQ.6) THEN -! - ! change fillvalue - DO IY=1,NY - DO IX=1,NX - IF (XC(IX,IY) .EQ. FILLVALUE) XC(IX,IY)=0 - IF (YC(IX,IY) .EQ. FILLVALUE) YC(IX,IY)=0 - END DO - END DO + ! + END IF + ! + ! 8.b Interpolate fields + ! ... No Interpolation, type AI (should not use array syntax !!!) + ! + IF (ITYPE.EQ.1.OR.ITYPE.EQ.6) THEN + ! + ! change fillvalue + DO IY=1,NY + DO IX=1,NX + IF (XC(IX,IY) .EQ. FILLVALUE) XC(IX,IY)=0 + IF (YC(IX,IY) .EQ. FILLVALUE) YC(IX,IY)=0 + END DO + END DO - IF (( IFLD.LE.2 .OR. IFLD.EQ.7 ).AND.( .NOT. FLBERG )) THEN - DO IY=1, NY - DO IX=1, NX - FA(IX,IY) = XC(IX,IY) - END DO - END DO - ELSE - DO IY=1, NY - DO IX=1, NX - FX(IX,IY) = XC(IX,IY) - FY(IX,IY) = YC(IX,IY) - FA(IX,IY) = AC(IX,IY) - END DO - END DO - END IF -! - ELSE IF (ITYPE.NE.5) THEN -! -! ... One-component fields -! + IF (( IFLD.LE.2 .OR. IFLD.EQ.7 ).AND.( .NOT. FLBERG )) THEN + DO IY=1, NY + DO IX=1, NX + FA(IX,IY) = XC(IX,IY) + END DO + END DO + ELSE + DO IY=1, NY + DO IX=1, NX + FX(IX,IY) = XC(IX,IY) + FY(IX,IY) = YC(IX,IY) + FA(IX,IY) = AC(IX,IY) + END DO + END DO + END IF + ! + ELSE IF (ITYPE.NE.5) THEN + ! + ! ... One-component fields + ! #ifdef W3_O3 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,976) ' ' -#endif - IF (( IFLD.LE.2 .OR. IFLD.EQ.7 ).AND.( .NOT. FLBERG )) THEN -! - CALL INTERP(MXM, MYM, XC, IX21, IX22, IY21, IY22, & - RD11, RD12, RD21, RD22, FILLVALUE, FA) -! - IF (NFCOMP.EQ.2) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,976) ' ' +#endif + IF (( IFLD.LE.2 .OR. IFLD.EQ.7 ).AND.( .NOT. FLBERG )) THEN + ! + CALL INTERP(MXM, MYM, XC, IX21, IX22, IY21, IY22, & + RD11, RD12, RD21, RD22, FILLVALUE, FA) + ! + IF (NFCOMP.EQ.2) THEN #ifdef W3_O3 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,976) ' (2) ' -#endif - CALL INTERP(MXM, MYM, YC, JX21, JX22, JY21, JY22, & - XD11, XD12, XD21, XD22, FILLVALUE, FA) - END IF -! -! ... Two-component fields -! - ELSE !so if IFLD.GT.2 -! - CALL INTERP(MXM, MYM, XC, IX21, IX22, IY21, IY22, & - RD11, RD12, RD21, RD22, FILLVALUE, FX) - - CALL INTERP(MXM, MYM, YC, IX21, IX22, IY21, IY22, & - RD11, RD12, RD21, RD22, FILLVALUE, FY) - - IF(FLSTAB) THEN - ! AC only populated if FLSTAB is true - CALL INTERP(MXM, MYM, AC, IX21, IX22, IY21, IY22, & - RD11, RD12, RD21, RD22, FILLVALUE, FA) - ENDIF - - WHERE ( XC.NE.FILLVALUE .AND. YC.NE.FILLVALUE) - XTEMP = XC*XC + YC*YC - ELSEWHERE - XTEMP = FILLVALUE - ENDWHERE - CALL INTERP(MXM, MYM, XTEMP, IX21, IX22, IY21, IY22, & - RD11, RD12, RD21, RD22, FILLVALUE, A3) - - WHERE ( XTEMP.NE.FILLVALUE ) - XTEMP = SQRT(XTEMP) - ENDWHERE - CALL INTERP(MXM, MYM, XTEMP, IX21, IX22, IY21, IY22, & - RD11, RD12, RD21, RD22, FILLVALUE, A2) - - DO IY=1,NY - DO IX=1,NX - A1(IX,IY) = MAX ( 1.E-10 , & - SQRT( FX(IX,IY)**2 + FY(IX,IY)**2 ) ) - - A3(IX,IY) = SQRT( A3(IX,IY) ) - END DO - END DO -! -! ... Winds, correct for velocity or energy conservation -! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,976) ' (2) ' +#endif + CALL INTERP(MXM, MYM, YC, JX21, JX22, JY21, JY22, & + XD11, XD12, XD21, XD22, FILLVALUE, FA) + END IF + ! + ! ... Two-component fields + ! + ELSE !so if IFLD.GT.2 + ! + CALL INTERP(MXM, MYM, XC, IX21, IX22, IY21, IY22, & + RD11, RD12, RD21, RD22, FILLVALUE, FX) + + CALL INTERP(MXM, MYM, YC, IX21, IX22, IY21, IY22, & + RD11, RD12, RD21, RD22, FILLVALUE, FY) + + IF(FLSTAB) THEN + ! AC only populated if FLSTAB is true + CALL INTERP(MXM, MYM, AC, IX21, IX22, IY21, IY22, & + RD11, RD12, RD21, RD22, FILLVALUE, FA) + ENDIF + + WHERE ( XC.NE.FILLVALUE .AND. YC.NE.FILLVALUE) + XTEMP = XC*XC + YC*YC + ELSEWHERE + XTEMP = FILLVALUE + ENDWHERE + CALL INTERP(MXM, MYM, XTEMP, IX21, IX22, IY21, IY22, & + RD11, RD12, RD21, RD22, FILLVALUE, A3) + + WHERE ( XTEMP.NE.FILLVALUE ) + XTEMP = SQRT(XTEMP) + ENDWHERE + CALL INTERP(MXM, MYM, XTEMP, IX21, IX22, IY21, IY22, & + RD11, RD12, RD21, RD22, FILLVALUE, A2) + + DO IY=1,NY + DO IX=1,NX + A1(IX,IY) = MAX ( 1.E-10 , & + SQRT( FX(IX,IY)**2 + FY(IX,IY)**2 ) ) + + A3(IX,IY) = SQRT( A3(IX,IY) ) + END DO + END DO + ! + ! ... Winds, correct for velocity or energy conservation + ! #ifdef W3_WNT1 - IF (IFLD.EQ.3) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF -#endif -! + IF (IFLD.EQ.3) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif + ! #ifdef W3_WNT2 - IF (IFLD.EQ.3) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF -#endif -! -! ... Currents, correct for velocity or energy conservation -! + IF (IFLD.EQ.3) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif + ! + ! ... Currents, correct for velocity or energy conservation + ! #ifdef W3_CRT1 - IF (IFLD.EQ.4) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF -#endif -! + IF (IFLD.EQ.4) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif + ! #ifdef W3_CRT2 - IF (IFLD.EQ.4) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF -#endif -! -! ... Momentum, correct for velocity or energy conservation -! + IF (IFLD.EQ.4) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif + ! + ! ... Momentum, correct for velocity or energy conservation + ! #ifdef W3_WNT1 - IF (IFLD.EQ.6) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF -#endif -! -#ifdef W3_WNT2 - IF (IFLD.EQ.6) THEN - DO IY=1,NY - DO IX=1,NX - FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) - FX(IX,IY) = FACTOR * FX(IX,IY) - FY(IX,IY) = FACTOR * FY(IX,IY) - END DO - END DO - END IF -#endif -! - END IF -! - END IF -! -! ... Test output -! -#ifdef W3_T3 - IF ( .NOT. ALLOCATED(MAPOUT) ) ALLOCATE ( MAPOUT(NX,NY) ) - WRITE (NDST,9065) - DO IX=1, NX - DO IY=1, NY - MAPOUT(IX,IY) = MAPSTA(IY,IX) + IF (IFLD.EQ.6) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) END DO END DO - IX0 = 1 - IXN = MIN ( IX0+IXWDT-1 , NX ) - DO - IF (IFLD.EQ.1) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Fraction ice', '(-)') - IF ( FLBERG ) & - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Iceberg a', '0.1/km') - ELSE IF (IFLD.EQ.2) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Water level', 'm') - ELSE IF (IFLD.EQ.7) THEN - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Air density', 'kg/m3') - ELSE - CALL PRTBLK (NDSO, NX, NY, NX, FX, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Cart. X-comp', 'm/s') - CALL PRTBLK (NDSO, NX, NY, NX, FY, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Cart. Y-comp', 'm/s') - IF ( FLSTAB ) & - CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & - IX0, IXN, 1, 1, NY, 1, 'Tair-Tsea', 'degr') - END IF - IF (IXN.NE.NX) THEN - IX0 = IX0 + IXWDT - IXN = MIN ( IXN+IXWDT , NX ) - ELSE - EXIT - END IF + END IF +#endif + ! +#ifdef W3_WNT2 + IF (IFLD.EQ.6) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO END DO + END IF +#endif + ! + END IF + ! + END IF + ! + ! ... Test output + ! +#ifdef W3_T3 + IF ( .NOT. ALLOCATED(MAPOUT) ) ALLOCATE ( MAPOUT(NX,NY) ) + WRITE (NDST,9065) + DO IX=1, NX + DO IY=1, NY + MAPOUT(IX,IY) = MAPSTA(IY,IX) + END DO + END DO + IX0 = 1 + IXN = MIN ( IX0+IXWDT-1 , NX ) + DO + IF (IFLD.EQ.1) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Fraction ice', '(-)') + IF ( FLBERG ) & + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Iceberg a', '0.1/km') + ELSE IF (IFLD.EQ.2) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Water level', 'm') + ELSE IF (IFLD.EQ.7) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Air density', 'kg/m3') + ELSE + CALL PRTBLK (NDSO, NX, NY, NX, FX, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Cart. X-comp', 'm/s') + CALL PRTBLK (NDSO, NX, NY, NX, FY, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Cart. Y-comp', 'm/s') + IF ( FLSTAB ) & + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Tair-Tsea', 'degr') + END IF + IF (IXN.NE.NX) THEN + IX0 = IX0 + IXWDT + IXN = MIN ( IXN+IXWDT , NX ) + ELSE + EXIT + END IF + END DO #endif -! -! 8.c Write fields -! - IF ( ITYPE .LE. 4 .OR. ITYPE.EQ.6 ) THEN + ! + ! 8.c Write fields + ! + IF ( ITYPE .LE. 4 .OR. ITYPE.EQ.6 ) THEN #ifdef W3_O3 IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,977) #endif - IF ( IAPROC .EQ. NAPOUT ) CALL W3FLDG ('WRITE', IDFLD, NDSDAT, NDST, NDSE, NX, NY, & - NX, NY, TIME, TIME, TIME, FX, FY, FA, TIME, & - FX, FY, FA, IERR) + IF ( IAPROC .EQ. NAPOUT ) CALL W3FLDG ('WRITE', IDFLD, NDSDAT, NDST, NDSE, NX, NY, & + NX, NY, TIME, TIME, TIME, FX, FY, FA, TIME, & + FX, FY, FA, IERR) - ELSE IF ( ITYPE .EQ. 5 ) THEN - IF ( NDAT .EQ. 0 ) THEN + ELSE IF ( ITYPE .EQ. 5 ) THEN + IF ( NDAT .EQ. 0 ) THEN #ifdef W3_O3 IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,978) #endif - ELSE + ELSE #ifdef W3_O3 IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,977) #endif - IF ( IAPROC .EQ. NAPOUT ) CALL W3FLDD ('WRITE', IDFLD, NDSDAT, NDST, NDSE, TIME,& - TIME, RECLDT, NDAT, IDAT, DATA, IERR ) - DEALLOCATE ( DATA ) - END IF - END IF - IF (IERR.NE.0) CALL EXTCDE ( 30 ) -! - END DO ! NTI -! - DEALLOCATE(XC,YC,AC,XTEMP) - IF (ASSOCIATED(ALA)) DEALLOCATE(ALA,ALO) -! -! End loop over input fields -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! - 880 CONTINUE - GOTO 888 -! -! Error escape locations -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 40 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 41 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 42 ) -! - 803 CONTINUE - WRITE (NDSE,1003) IERR - CALL EXTCDE ( 43 ) -! - 810 CONTINUE - WRITE (NDSE,1010) - CALL EXTCDE ( 1010 ) -! - 811 CONTINUE - WRITE (NDSE,1011) - CALL EXTCDE ( 1011 ) -! - 845 CONTINUE - WRITE (NDSE,1045) IERR - CALL EXTCDE ( 49 ) -! - 846 CONTINUE - WRITE (NDSE,1046) IERR - CALL EXTCDE ( 50 ) -! - 862 CONTINUE - WRITE (NDSE,1062) IERR - CALL EXTCDE ( 54 ) -! - 863 CONTINUE - WRITE (NDSE,1063) IDAT, IERR - CALL EXTCDE ( 55 ) - 864 CONTINUE - WRITE (NDSE,1064) TRIM(STRDIMSNAME) - CALL EXTCDE ( 56 ) -! + IF ( IAPROC .EQ. NAPOUT ) CALL W3FLDD ('WRITE', IDFLD, NDSDAT, NDST, NDSE, TIME,& + TIME, RECLDT, NDAT, IDAT, DATA, IERR ) + DEALLOCATE ( DATA ) + END IF + END IF + IF (IERR.NE.0) CALL EXTCDE ( 30 ) + ! + END DO ! NTI + ! + DEALLOCATE(XC,YC,AC,XTEMP) + IF (ASSOCIATED(ALA)) DEALLOCATE(ALA,ALO) + ! + ! End loop over input fields + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! +880 CONTINUE + GOTO 888 + ! + ! Error escape locations + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 40 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 41 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 42 ) + ! +803 CONTINUE + WRITE (NDSE,1003) IERR + CALL EXTCDE ( 43 ) + ! +810 CONTINUE + WRITE (NDSE,1010) + CALL EXTCDE ( 1010 ) + ! +811 CONTINUE + WRITE (NDSE,1011) + CALL EXTCDE ( 1011 ) + ! +845 CONTINUE + WRITE (NDSE,1045) IERR + CALL EXTCDE ( 49 ) + ! +846 CONTINUE + WRITE (NDSE,1046) IERR + CALL EXTCDE ( 50 ) + ! +862 CONTINUE + WRITE (NDSE,1062) IERR + CALL EXTCDE ( 54 ) + ! +863 CONTINUE + WRITE (NDSE,1063) IDAT, IERR + CALL EXTCDE ( 55 ) +864 CONTINUE + WRITE (NDSE,1064) TRIM(STRDIMSNAME) + CALL EXTCDE ( 56 ) + ! #ifdef W3_O15 - 870 CONTINUE - WRITE (NDSE,1070) IDFLD, IERR - CALL EXTCDE ( 57 ) +870 CONTINUE + WRITE (NDSE,1070) IDFLD, IERR + CALL EXTCDE ( 57 ) #endif -! + ! #ifdef W3_O15 - 871 CONTINUE - WRITE (NDSE,1071) IDTIME, IERR - CALL EXTCDE ( 58 ) +871 CONTINUE + WRITE (NDSE,1071) IDTIME, IERR + CALL EXTCDE ( 58 ) #endif -! - 888 CONTINUE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) + ! +888 CONTINUE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) #ifdef W3_MPI - CALL MPI_FINALIZE ( IERR_MPI ) + CALL MPI_FINALIZE ( IERR_MPI ) #endif -! + ! #ifdef W3_NCO -! CALL W3TAGE('WAVEPREP') -#endif - - -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Input pre-processing *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) - 902 FORMAT ( ' Grid name : ',A/) -! - 930 FORMAT (/' Description of inputs'/ & - ' --------------------------------------------------'/ & - ' Input type : ',A/ & - ' Format type : ',A) - 1930 FORMAT ( ' Field conserves velocity.') - 2930 FORMAT ( ' Field corrected for energy conservation.') - 1931 FORMAT ( ' Start time : ',A) - 2931 FORMAT ( ' Stop time : ',A) - 3931 FORMAT ( ' Shifted time : ',A) - 932 FORMAT (/' Input grid dim. :',I9,3X,I5) - 1933 FORMAT ( ' Longitude range :',2F8.2,' (deg)'/ & - ' Latitude range :',2F8.2,' (deg)') - 2933 FORMAT ( ' X range :',2F8.2,' (km)'/ & - ' Y range :',2F8.2,' (km)') - 934 FORMAT (/' Data type : ',A/ & - ' Data record length:',I5/ & - ' Missing values :',F8.2) - 935 FORMAT ( 'DT',I1 ) - 938 FORMAT ( ' Icebergs included.') - 939 FORMAT ( ' Air-sea temperature differences included.') -! - 940 FORMAT (//' Preprocessing data'/ & - ' --------------------------------------------------') - 941 FORMAT ( ' Interpolation factors ..... '/ & - ' (longitude-latitude grid)') - 942 FORMAT ( ' Interpolation factors ..... '/ & - ' (grid from file)') - 943 FORMAT (/' Longitude-latitude file ',I1,' :'/ & - ' ---------------------------------------') - 944 FORMAT ( ' Input grid dim. :',I9,3X,I5/ & - ' Closed longitudes :',L5) - 945 FORMAT ( ' Layout indicator :',I5/ & - ' Format indicator :',I5) - 946 FORMAT ( ' Format : ',A) - 947 FORMAT ( ' Unit number :',I5) - 948 FORMAT ( ' File name : ',A) - 949 FORMAT (/' Corresponding map file '/ & - ' ---------------------------------------') -! - 960 FORMAT (/' Data file :'/ & - ' ---------------------------------------') - 961 FORMAT (/' Data file :'/ & - ' ---------------------------------------'/ & - ' Input grid dim. :',I9,3X,I5) - 962 FORMAT (/' Data file (',I1,') :'/ & - ' ---------------------------------------'/ & - ' Input grid dim. :',I9,3X,I5) - 967 FORMAT (/' File name : ',A) - 968 FORMAT ( ' Dimension along x : ',A/ & - ' Dimension along y : ',A) - 969 FORMAT ( ' Field component ',I1,' : ',A) -! - 971 FORMAT (/' Opening output data file .....') - 972 FORMAT (//' Processing data'/ & - ' --------------------------------------------------') - 1973 FORMAT ( ' Shifted Time : ',A,' (File time : ',A,')') - 2973 FORMAT ( ' Time : ',A) + ! CALL W3TAGE('WAVEPREP') +#endif + + + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Input pre-processing *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) +902 FORMAT ( ' Grid name : ',A/) + ! +930 FORMAT (/' Description of inputs'/ & + ' --------------------------------------------------'/ & + ' Input type : ',A/ & + ' Format type : ',A) +1930 FORMAT ( ' Field conserves velocity.') +2930 FORMAT ( ' Field corrected for energy conservation.') +1931 FORMAT ( ' Start time : ',A) +2931 FORMAT ( ' Stop time : ',A) +3931 FORMAT ( ' Shifted time : ',A) +932 FORMAT (/' Input grid dim. :',I9,3X,I5) +1933 FORMAT ( ' Longitude range :',2F8.2,' (deg)'/ & + ' Latitude range :',2F8.2,' (deg)') +2933 FORMAT ( ' X range :',2F8.2,' (km)'/ & + ' Y range :',2F8.2,' (km)') +934 FORMAT (/' Data type : ',A/ & + ' Data record length:',I5/ & + ' Missing values :',F8.2) +935 FORMAT ( 'DT',I1 ) +938 FORMAT ( ' Icebergs included.') +939 FORMAT ( ' Air-sea temperature differences included.') + ! +940 FORMAT (//' Preprocessing data'/ & + ' --------------------------------------------------') +941 FORMAT ( ' Interpolation factors ..... '/ & + ' (longitude-latitude grid)') +942 FORMAT ( ' Interpolation factors ..... '/ & + ' (grid from file)') +943 FORMAT (/' Longitude-latitude file ',I1,' :'/ & + ' ---------------------------------------') +944 FORMAT ( ' Input grid dim. :',I9,3X,I5/ & + ' Closed longitudes :',L5) +945 FORMAT ( ' Layout indicator :',I5/ & + ' Format indicator :',I5) +946 FORMAT ( ' Format : ',A) +947 FORMAT ( ' Unit number :',I5) +948 FORMAT ( ' File name : ',A) +949 FORMAT (/' Corresponding map file '/ & + ' ---------------------------------------') + ! +960 FORMAT (/' Data file :'/ & + ' ---------------------------------------') +961 FORMAT (/' Data file :'/ & + ' ---------------------------------------'/ & + ' Input grid dim. :',I9,3X,I5) +962 FORMAT (/' Data file (',I1,') :'/ & + ' ---------------------------------------'/ & + ' Input grid dim. :',I9,3X,I5) +967 FORMAT (/' File name : ',A) +968 FORMAT ( ' Dimension along x : ',A/ & + ' Dimension along y : ',A) +969 FORMAT ( ' Field component ',I1,' : ',A) + ! +971 FORMAT (/' Opening output data file .....') +972 FORMAT (//' Processing data'/ & + ' --------------------------------------------------') +1973 FORMAT ( ' Shifted Time : ',A,' (File time : ',A,')') +2973 FORMAT ( ' Time : ',A) #ifdef W3_O3 - 974 FORMAT ( ' reading ....') - 975 FORMAT ( ' number of data records :',I6) - 976 FORMAT ( ' interpolating',A,'....') - 977 FORMAT ( ' writing ....') - 978 FORMAT ( ' skipping ....') +974 FORMAT ( ' reading ....') +975 FORMAT ( ' number of data records :',I6) +976 FORMAT ( ' interpolating',A,'....') +977 FORMAT ( ' writing ....') +978 FORMAT ( ' skipping ....') #endif -! + ! #ifdef W3_O15 - 979 FORMAT (1X,I8.8,1X,I6.6) -#endif -! - 999 FORMAT(//' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Input preprocessing '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' EXPECTING LIST OF TIDAL CONST. OR FAST OR VFAST'/& - ' IOSTAT =',I5/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' NO FIELD SELECTED'/) - 1011 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' NO GRID SELECTED'/) -! - 1027 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' _FillValue ATTRIBUTE NOT DEFINED FOR : ',A/) -! - 1028 FORMAT (/' *** WAVEWATCH III WARNING IN W3PRNC : '/ & - ' calendar ATTRIBUTE NOT DEFINED'/ & - ' IT MUST RESPECT STANDARD OR GREGORIAN CALENDAR') - 1029 FORMAT (/' *** WAVEWATCH III WARNING IN W3PRNC : '/ & - ' CALENDAR ATTRIBUTE NOT MATCH'/ & - ' IT MUST RESPECT STANDARD OR GREGORIAN CALENDAR') - 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ILLEGAL FIELD ID -->',A,'<--'/) - 1031 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ILLEGAL FORMAT ID -->',A,'<--'/) - 1032 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' LATITUDE VALUES MUST BE REVERSED'/ & - ' EXAMPLE: ncpdq -h -O -a -lat file.nc'/ ) -! - 1033 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ILLEGAL DATA RECORD LENGTH : ',I6/) - 1034 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ILLEGAL DATA TYPE : ',I2/) -! - 1035 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ILLEGAL TIME : ',I8.8,I7.6/) - 1036 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ILLEGAL SIZE OF INPUT GRID : ',I5,1X,I5/) - 1038 FORMAT (/' *** WAVEWATCH III WARNING IN W3PRNC : '/ & - ' DATA READ FROM INPUT FILE') - 1039 FORMAT (/' *** WAVEWATCH III WARNING IN W3PRNC : '/ & - ' NAN VALUES IN HARMONICS '/ & - ' REMOVE NON-LINEAR TIDAL COMPONENTS '/ & - ' 2MS2 2MN2 2NK2 MNS2 MSN2 2SM2 3MSN2 ' & - ' M4 MS4 MN4 M6 2MS6 2MN6'/) -! - 1042 FORMAT (/' *** WAVEWATCH-III WARNING W3PRNC : '/ & - ' GRID POINT ',2I6,2F7.2,/ & - ' NOT COVERED BY INPUT GRID.'/) - 1043 FORMAT (/' *** WAVEWATCH III WARNING W3PRNC : '/ & - ' X = ',F10.1,' NOT COVERED BY INPUT GRID.'/) - 1044 FORMAT (/' *** WAVEWATCH III WARNING W3PRNC : '/ & - ' Y = ',F10.1,' NOT COVERED BY INPUT GRID.'/) -! - -! - 1045 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ERROR IN OPENING LAT-LONG DATA FILE'/ & - ' IOSTAT =',I5/) -! - 1046 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ERROR IN OPENING MASK FILE'/ & - ' IOSTAT =',I5/) -! - 1047 FORMAT (/' *** WAVEWATCH III WARNING IN W3PRNC : '/ & - ' NO TIDAL COMPUTATION AT NODE [',I8,',',I8,']'/) -! - 1062 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & - ' ERROR IN READING NDAT FROM FILE'/ & - ' IOSTAT =',I5/) - 1063 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ERROR IN READING DATA RECORD',I6,' FROM FILE'/ & - ' IOSTAT =',I5/) - 1064 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' GRID DIMENSIONS ', A,' NOT FOUND... CHECK DIMENSION NAMES') -! +979 FORMAT (1X,I8.8,1X,I6.6) +#endif + ! +999 FORMAT(//' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Input preprocessing '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' EXPECTING LIST OF TIDAL CONST. OR FAST OR VFAST'/& + ' IOSTAT =',I5/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' NO FIELD SELECTED'/) +1011 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' NO GRID SELECTED'/) + ! +1027 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' _FillValue ATTRIBUTE NOT DEFINED FOR : ',A/) + ! +1028 FORMAT (/' *** WAVEWATCH III WARNING IN W3PRNC : '/ & + ' calendar ATTRIBUTE NOT DEFINED'/ & + ' IT MUST RESPECT STANDARD OR GREGORIAN CALENDAR') +1029 FORMAT (/' *** WAVEWATCH III WARNING IN W3PRNC : '/ & + ' CALENDAR ATTRIBUTE NOT MATCH'/ & + ' IT MUST RESPECT STANDARD OR GREGORIAN CALENDAR') +1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ILLEGAL FIELD ID -->',A,'<--'/) +1031 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ILLEGAL FORMAT ID -->',A,'<--'/) +1032 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' LATITUDE VALUES MUST BE REVERSED'/ & + ' EXAMPLE: ncpdq -h -O -a -lat file.nc'/ ) + ! +1033 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ILLEGAL DATA RECORD LENGTH : ',I6/) +1034 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ILLEGAL DATA TYPE : ',I2/) + ! +1035 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ILLEGAL TIME : ',I8.8,I7.6/) +1036 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ILLEGAL SIZE OF INPUT GRID : ',I5,1X,I5/) +1038 FORMAT (/' *** WAVEWATCH III WARNING IN W3PRNC : '/ & + ' DATA READ FROM INPUT FILE') +1039 FORMAT (/' *** WAVEWATCH III WARNING IN W3PRNC : '/ & + ' NAN VALUES IN HARMONICS '/ & + ' REMOVE NON-LINEAR TIDAL COMPONENTS '/ & + ' 2MS2 2MN2 2NK2 MNS2 MSN2 2SM2 3MSN2 ' & + ' M4 MS4 MN4 M6 2MS6 2MN6'/) + ! +1042 FORMAT (/' *** WAVEWATCH-III WARNING W3PRNC : '/ & + ' GRID POINT ',2I6,2F7.2,/ & + ' NOT COVERED BY INPUT GRID.'/) +1043 FORMAT (/' *** WAVEWATCH III WARNING W3PRNC : '/ & + ' X = ',F10.1,' NOT COVERED BY INPUT GRID.'/) +1044 FORMAT (/' *** WAVEWATCH III WARNING W3PRNC : '/ & + ' Y = ',F10.1,' NOT COVERED BY INPUT GRID.'/) + ! + + ! +1045 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ERROR IN OPENING LAT-LONG DATA FILE'/ & + ' IOSTAT =',I5/) + ! +1046 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ERROR IN OPENING MASK FILE'/ & + ' IOSTAT =',I5/) + ! +1047 FORMAT (/' *** WAVEWATCH III WARNING IN W3PRNC : '/ & + ' NO TIDAL COMPUTATION AT NODE [',I8,',',I8,']'/) + ! +1062 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN READING NDAT FROM FILE'/ & + ' IOSTAT =',I5/) +1063 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ERROR IN READING DATA RECORD',I6,' FROM FILE'/ & + ' IOSTAT =',I5/) +1064 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' GRID DIMENSIONS ', A,' NOT FOUND... CHECK DIMENSION NAMES') + ! #ifdef W3_O15 - 1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ERROR IN CREATING A TIMES FILE FOR ',A/ & - ' IOSTAT =',I5/) - 1071 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & - ' ERROR IN WRITING TIME OUTPUT ',A/ & - ' IOSTAT =',I5/) -#endif -! +1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ERROR IN CREATING A TIMES FILE FOR ',A/ & + ' IOSTAT =',I5/) +1071 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ERROR IN WRITING TIME OUTPUT ',A/ & + ' IOSTAT =',I5/) +#endif + ! #ifdef W3_T - 9040 FORMAT (' TEST W3PRNC : INPUT GRID RANGES AND INCR. AFTER CORR.'/ & - ' LON / X : ',3F10.2, & - ' (GLOBAL=',L1,')'/ & - ' LAT / Y : ',3F10.2) - 9041 FORMAT (' TEST W3PRNC : INTERPOLATION DATA FOR ',A) - 9042 FORMAT (' ',I4,F8.2,2I4,2F8.2,1X,F6.3,1X,A) - 9043 FORMAT (' TEST W3PRNC : GRID SHIFTED BY ',F5.0,' DEGREES / M') +9040 FORMAT (' TEST W3PRNC : INPUT GRID RANGES AND INCR. AFTER CORR.'/ & + ' LON / X : ',3F10.2, & + ' (GLOBAL=',L1,')'/ & + ' LAT / Y : ',3F10.2) +9041 FORMAT (' TEST W3PRNC : INTERPOLATION DATA FOR ',A) +9042 FORMAT (' ',I4,F8.2,2I4,2F8.2,1X,F6.3,1X,A) +9043 FORMAT (' TEST W3PRNC : GRID SHIFTED BY ',F5.0,' DEGREES / M') #endif #ifdef W3_T1 - 9045 FORMAT (' TEST W3PRNC : IX, IY, IXI(2), IYI(2), RD(4)') - 9046 FORMAT (' ',2I4,2X,4I4,2X,4F6.2) +9045 FORMAT (' TEST W3PRNC : IX, IY, IXI(2), IYI(2), RD(4)') +9046 FORMAT (' ',2I4,2X,4I4,2X,4F6.2) #endif -! + ! #ifdef W3_T1a - 9050 FORMAT (' TEST W3PRNC : LAT-LONG OF INPUT FILE ') - 9051 FORMAT (' ',2I4,2F8.2,I4) +9050 FORMAT (' TEST W3PRNC : LAT-LONG OF INPUT FILE ') +9051 FORMAT (' ',2I4,2F8.2,I4) #endif -! + ! #ifdef W3_T2 - 9060 FORMAT (' TEST W3PRNC : INPUT FIELD (',I1,') :'/) - 9061 FORMAT (' TEST W3PRNC : INPUT DATA RECORDS :') - 9062 FORMAT (' ',I6,' : ',6E11.3) - 9063 FORMAT (' ',6E11.3) +9060 FORMAT (' TEST W3PRNC : INPUT FIELD (',I1,') :'/) +9061 FORMAT (' TEST W3PRNC : INPUT DATA RECORDS :') +9062 FORMAT (' ',I6,' : ',6E11.3) +9063 FORMAT (' ',6E11.3) #endif #ifdef W3_T3 - 9065 FORMAT (' TEST W3PRNC : OUTPUT FIELD(S) :'/) +9065 FORMAT (' TEST W3PRNC : OUTPUT FIELD(S) :'/) #endif -!/ -!/ End of W3PRNC ----------------------------------------------------- / -!/ + !/ + !/ End of W3PRNC ----------------------------------------------------- / + !/ - END PROGRAM W3PRNC +END PROGRAM W3PRNC !============================================================================== !> @@ -2522,8 +2522,8 @@ END PROGRAM W3PRNC !> the interpolation coefficients are zero, and in this case we !> provide a sensible value - the value as read, not interpolated !> -!> @param[in] MXM Dimension X of XC variable -!> @param[in] MYM Dimension Y of XC variable +!> @param[in] MXM Dimension X of XC variable +!> @param[in] MYM Dimension Y of XC variable !> @param[in] XC Field to be interpolated, as read from the !> input netcdf !> @param[in] IX21 List of x-index to convert from the original @@ -2540,144 +2540,144 @@ END PROGRAM W3PRNC !> @param[in] RD22 Interpolation factor !> @param[in] FILLVALUE Fill value identifying non valid input !> @param[out] FA Result of the interpolation -!> +!> !> @author J. M. Castillo @date 23-Feb-2021 - SUBROUTINE INTERP(MXM, MYM, XC, IX21, IX22, IY21, IY22, & - RD11, RD12, RD21, RD22, FILLVALUE, FA) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | J. M. Castillo | -!/ | FORTRAN 90 | -!/ | Last update : 23-Feb-2021 | -!/ +-----------------------------------+ -!/ -!/ 23-Feb-2021 : First version ( version 7.12 ) -!/ -! 1. Purpose : -! -! Interpolate from a field read from file to the wave grid -! -! 2. Method : -! -! Invalid points are identified by the fill value read from the -! netcdf input, and interpolation does not take into account -! these points. The valid interpolation coefficients are scaled -! so that the sum is one, otherwise unphysical values can be -! generated. -! -! When one point is on the boundary but is not an ocean grid point, -! the interpolation coefficients are zero, and in this case we -! provide a sensible value - the value as read, not interpolated -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MxM I I Dimensions of the XC variable -! XC R.A. I Field to be interpolated, as read from the -! input netcdf -! IXxx I.A. I List of x-index to convert from the original -! field to the model grid -! IYxx I.A. I List of y-index to convert from the original -! field to the model grid -! RDxx R.A. I Interpolation factors -! FILLVALUE R I Fill value identifying non valid input -! FA F O Result of the interpolation -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_PRNC Prog. N/A Input data preprocessor. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NX, NY - - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MXM, MYM - REAL, DIMENSION(MXM,MYM), INTENT(IN) :: XC - INTEGER, DIMENSION(NX,NY), INTENT(IN) :: IX21, IX22, IY21, IY22 - REAL, DIMENSION(NX,NY), INTENT(IN) :: RD11, RD12, RD21, RD22 - REAL, INTENT(IN) :: FILLVALUE - REAL, DIMENSION(NX,NY), INTENT(OUT) :: FA -!/ -!/ ------------------------------------------------------------------- / -!/ Local variables -!/ - INTEGER :: IX, IY - REAL :: FACTOR -!/ ------------------------------------------------------------------- / - - DO IY=1,NY - DO IX=1,NX - FACTOR = 0.0 +SUBROUTINE INTERP(MXM, MYM, XC, IX21, IX22, IY21, IY22, & + RD11, RD12, RD21, RD22, FILLVALUE, FA) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | J. M. Castillo | + !/ | FORTRAN 90 | + !/ | Last update : 23-Feb-2021 | + !/ +-----------------------------------+ + !/ + !/ 23-Feb-2021 : First version ( version 7.12 ) + !/ + ! 1. Purpose : + ! + ! Interpolate from a field read from file to the wave grid + ! + ! 2. Method : + ! + ! Invalid points are identified by the fill value read from the + ! netcdf input, and interpolation does not take into account + ! these points. The valid interpolation coefficients are scaled + ! so that the sum is one, otherwise unphysical values can be + ! generated. + ! + ! When one point is on the boundary but is not an ocean grid point, + ! the interpolation coefficients are zero, and in this case we + ! provide a sensible value - the value as read, not interpolated + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MxM I I Dimensions of the XC variable + ! XC R.A. I Field to be interpolated, as read from the + ! input netcdf + ! IXxx I.A. I List of x-index to convert from the original + ! field to the model grid + ! IYxx I.A. I List of y-index to convert from the original + ! field to the model grid + ! RDxx R.A. I Interpolation factors + ! FILLVALUE R I Fill value identifying non valid input + ! FA F O Result of the interpolation + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_PRNC Prog. N/A Input data preprocessor. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NX, NY + + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MXM, MYM + REAL, DIMENSION(MXM,MYM), INTENT(IN) :: XC + INTEGER, DIMENSION(NX,NY), INTENT(IN) :: IX21, IX22, IY21, IY22 + REAL, DIMENSION(NX,NY), INTENT(IN) :: RD11, RD12, RD21, RD22 + REAL, INTENT(IN) :: FILLVALUE + REAL, DIMENSION(NX,NY), INTENT(OUT) :: FA + !/ + !/ ------------------------------------------------------------------- / + !/ Local variables + !/ + INTEGER :: IX, IY + REAL :: FACTOR + !/ ------------------------------------------------------------------- / + + DO IY=1,NY + DO IX=1,NX + FACTOR = 0.0 + FA(IX,IY) = 0.0 + + IF(XC(IX21(IX,IY),IY21(IX,IY)).NE.FILLVALUE) THEN + FACTOR = FACTOR + RD11(IX,IY) + FA(IX,IY) = RD11(IX,IY) * XC(IX21(IX,IY),IY21(IX,IY)) + ENDIF + IF(XC(IX22(IX,IY),IY21(IX,IY)).NE.FILLVALUE) THEN + FACTOR = FACTOR + RD21(IX,IY) + FA(IX,IY) = FA(IX,IY) + RD21(IX,IY) * XC(IX22(IX,IY),IY21(IX,IY)) + ENDIF + IF(XC(IX21(IX,IY),IY22(IX,IY)).NE.FILLVALUE) THEN + FACTOR = FACTOR + RD12(IX,IY) + FA(IX,IY) = FA(IX,IY) + RD12(IX,IY) * XC(IX21(IX,IY),IY22(IX,IY)) + ENDIF + IF(XC(IX22(IX,IY),IY22(IX,IY)).NE.FILLVALUE) THEN + FACTOR = FACTOR + RD22(IX,IY) + FA(IX,IY) = FA(IX,IY) + RD22(IX,IY) * XC(IX22(IX,IY),IY22(IX,IY)) + ENDIF + + IF(FACTOR.GT.0.0) THEN + FA(IX,IY) = FA(IX,IY) / FACTOR + ELSE + ! Interpolation coefficients sum to zero - could be on a boundary + ! (see note in "method" above). If any surrounding points have a + ! valid value then use one of them, otherwise set to zero. + IF( XC(IX21(IX,IY),IY21(IX,IY)) .NE. FILLVALUE) THEN + FA(IX,IY) = XC(IX21(IX,IY),IY21(IX,IY)) + ELSE IF( XC(IX22(IX,IY),IY21(IX,IY)) .NE. FILLVALUE) THEN + FA(IX,IY) = XC(IX22(IX,IY),IY21(IX,IY)) + ELSE IF( XC(IX21(IX,IY),IY22(IX,IY)) .NE. FILLVALUE) THEN + FA(IX,IY) = XC(IX21(IX,IY),IY22(IX,IY)) + ELSE IF( XC(IX22(IX,IY),IY22(IX,IY)) .NE. FILLVALUE) THEN + FA(IX,IY) = XC(IX22(IX,IY),IY22(IX,IY)) + ELSE + ! All surrounding points are FILLVALUE - set to zero. FA(IX,IY) = 0.0 + END IF + END IF + END DO + END DO - IF(XC(IX21(IX,IY),IY21(IX,IY)).NE.FILLVALUE) THEN - FACTOR = FACTOR + RD11(IX,IY) - FA(IX,IY) = RD11(IX,IY) * XC(IX21(IX,IY),IY21(IX,IY)) - ENDIF - IF(XC(IX22(IX,IY),IY21(IX,IY)).NE.FILLVALUE) THEN - FACTOR = FACTOR + RD21(IX,IY) - FA(IX,IY) = FA(IX,IY) + RD21(IX,IY) * XC(IX22(IX,IY),IY21(IX,IY)) - ENDIF - IF(XC(IX21(IX,IY),IY22(IX,IY)).NE.FILLVALUE) THEN - FACTOR = FACTOR + RD12(IX,IY) - FA(IX,IY) = FA(IX,IY) + RD12(IX,IY) * XC(IX21(IX,IY),IY22(IX,IY)) - ENDIF - IF(XC(IX22(IX,IY),IY22(IX,IY)).NE.FILLVALUE) THEN - FACTOR = FACTOR + RD22(IX,IY) - FA(IX,IY) = FA(IX,IY) + RD22(IX,IY) * XC(IX22(IX,IY),IY22(IX,IY)) - ENDIF - - IF(FACTOR.GT.0.0) THEN - FA(IX,IY) = FA(IX,IY) / FACTOR - ELSE - ! Interpolation coefficients sum to zero - could be on a boundary - ! (see note in "method" above). If any surrounding points have a - ! valid value then use one of them, otherwise set to zero. - IF( XC(IX21(IX,IY),IY21(IX,IY)) .NE. FILLVALUE) THEN - FA(IX,IY) = XC(IX21(IX,IY),IY21(IX,IY)) - ELSE IF( XC(IX22(IX,IY),IY21(IX,IY)) .NE. FILLVALUE) THEN - FA(IX,IY) = XC(IX22(IX,IY),IY21(IX,IY)) - ELSE IF( XC(IX21(IX,IY),IY22(IX,IY)) .NE. FILLVALUE) THEN - FA(IX,IY) = XC(IX21(IX,IY),IY22(IX,IY)) - ELSE IF( XC(IX22(IX,IY),IY22(IX,IY)) .NE. FILLVALUE) THEN - FA(IX,IY) = XC(IX22(IX,IY),IY22(IX,IY)) - ELSE - ! All surrounding points are FILLVALUE - set to zero. - FA(IX,IY) = 0.0 - END IF - END IF - END DO - END DO - - END SUBROUTINE INTERP +END SUBROUTINE INTERP !============================================================================== !> @brief Desc not available. @@ -2685,27 +2685,25 @@ END SUBROUTINE INTERP !> @param IRET !> @param ILINE !> @author NA @date NA - SUBROUTINE CHECK_ERROR(IRET, ILINE) +SUBROUTINE CHECK_ERROR(IRET, ILINE) - USE NETCDF - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE + USE NETCDF + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE - IMPLICIT NONE + IMPLICIT NONE - INTEGER IRET, ILINE + INTEGER IRET, ILINE - IF (IRET .NE. NF90_NOERR) THEN - WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN OUNF :' - WRITE(NDSE,*) ' LINE NUMBER ', ILINE - WRITE(NDSE,*) ' NETCDF ERROR MESSAGE: ' - WRITE(NDSE,*) NF90_STRERROR(IRET) - CALL EXTCDE ( 59 ) - END IF - RETURN + IF (IRET .NE. NF90_NOERR) THEN + WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN OUNF :' + WRITE(NDSE,*) ' LINE NUMBER ', ILINE + WRITE(NDSE,*) ' NETCDF ERROR MESSAGE: ' + WRITE(NDSE,*) NF90_STRERROR(IRET) + CALL EXTCDE ( 59 ) + END IF + RETURN - END SUBROUTINE CHECK_ERROR +END SUBROUTINE CHECK_ERROR !============================================================================== - - diff --git a/model/src/ww3_prtide.F90 b/model/src/ww3_prtide.F90 index 21b772e9a..1168cd1ab 100644 --- a/model/src/ww3_prtide.F90 +++ b/model/src/ww3_prtide.F90 @@ -5,885 +5,885 @@ ! #include "w3macros.h" !/ ------------------------------------------------------------------- / -!> @brief Predicts tides (current or water level) to be used during +!> @brief Predicts tides (current or water level) to be used during !> run by ww3_shel or ww3_multi (this takes much less memory). !> !> @author F. Ardhuin @date 21-Apr-2020 - PROGRAM W3PRTIDE -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 21-Apr-2020 | -!/ +-----------------------------------+ -!/ -!/ 29-Mar-2013 : Creation ( version 4.11 ) -!/ 17-Oct-2013 : Manages missing data for UNST grids ( version 4.12 ) -!/ 06-Jun-2018 : COMPUTE VNEIGH: calculate the number of connected -!/ triangles for a given point ( version 6.04 ) -!/ 21-Apr-2020 : MPI implementation ( version 7.13 ) -!/ 21-Apr-2020 : bug fix for rectilinear grid ( version 7.13 ) -!/ 1-Feb-2020 : Improve indexing, A.Roland ( version 7.14 ) - -!/ -!/ Copyright 2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Predicts tides (current or water level) to be used during -! run by ww3_shel or ww3_multi (this takes much less memory). -! -! 2. Method : -! -! See documented input file. -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! NDSI Int. Input unit number ("ww3_prtide.inp"). -! NDSLL Int. Unit number(s) of long-lat file(s) -! NDSF I.A. Unit number(s) of input file(s). -! NDSDAT Int. Unit number for output data file. -! FLTIME Log. Time flag for input fields, if false, single -! field, time read from NDSI. -! IDLALL Int. Layout indicator used by INA2R. + -! IDFMLL Int. Id. FORMAT indicator. | -! FORMLL C*16 Id. FORMAT. | Long-lat -! FROMLL C*4 'UNIT' / 'NAME' indicator | file(s) -! NAMELL C*40 Name of long-lat file(s) + -! IDLAF I.A. + -! IDFMF I.A. | -! FORMF C.A. | Idem. fields file(s) -! FROMF C*4 | -! NAMEF C*50 + -! FORMT C.A. Format or time in field. -! XC R.A. Components of input vector field or first -! input scalar field -! YC R.A. Components of input vector field or second -! input scalar field -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! STME21 Subr. W3TIMEMD Convert time to string. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3FLDO Subr. W3FLDSMD Opening of WAVEWATCH III generic shell -! data file. -! W3FLDG Subr. Id. Reading/writing shell input data. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! - Checks on files and reading from file. -! - Checks on validity of input parameters. -! -! 7. Remarks : -! -! - Input fields need to be continuous in longitude and latitude. -! -! 8. Structure : -! -! ---------------------------------------------------- -! To be updated ... -! ---------------------------------------------------- -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output, -! -! !/NCO NCEP NCO modifications for operational implementation. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ -! USE W3GDATMD, ONLY: W3NMOD, W3SETG +PROGRAM W3PRTIDE + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 21-Apr-2020 | + !/ +-----------------------------------+ + !/ + !/ 29-Mar-2013 : Creation ( version 4.11 ) + !/ 17-Oct-2013 : Manages missing data for UNST grids ( version 4.12 ) + !/ 06-Jun-2018 : COMPUTE VNEIGH: calculate the number of connected + !/ triangles for a given point ( version 6.04 ) + !/ 21-Apr-2020 : MPI implementation ( version 7.13 ) + !/ 21-Apr-2020 : bug fix for rectilinear grid ( version 7.13 ) + !/ 1-Feb-2020 : Improve indexing, A.Roland ( version 7.14 ) + + !/ + !/ Copyright 2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Predicts tides (current or water level) to be used during + ! run by ww3_shel or ww3_multi (this takes much less memory). + ! + ! 2. Method : + ! + ! See documented input file. + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! NDSI Int. Input unit number ("ww3_prtide.inp"). + ! NDSLL Int. Unit number(s) of long-lat file(s) + ! NDSF I.A. Unit number(s) of input file(s). + ! NDSDAT Int. Unit number for output data file. + ! FLTIME Log. Time flag for input fields, if false, single + ! field, time read from NDSI. + ! IDLALL Int. Layout indicator used by INA2R. + + ! IDFMLL Int. Id. FORMAT indicator. | + ! FORMLL C*16 Id. FORMAT. | Long-lat + ! FROMLL C*4 'UNIT' / 'NAME' indicator | file(s) + ! NAMELL C*40 Name of long-lat file(s) + + ! IDLAF I.A. + + ! IDFMF I.A. | + ! FORMF C.A. | Idem. fields file(s) + ! FROMF C*4 | + ! NAMEF C*50 + + ! FORMT C.A. Format or time in field. + ! XC R.A. Components of input vector field or first + ! input scalar field + ! YC R.A. Components of input vector field or second + ! input scalar field + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! W3SETO Subr. Id. Point to selected model for output. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! STME21 Subr. W3TIMEMD Convert time to string. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3FLDO Subr. W3FLDSMD Opening of WAVEWATCH III generic shell + ! data file. + ! W3FLDG Subr. Id. Reading/writing shell input data. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! - Checks on files and reading from file. + ! - Checks on validity of input parameters. + ! + ! 7. Remarks : + ! + ! - Input fields need to be continuous in longitude and latitude. + ! + ! 8. Structure : + ! + ! ---------------------------------------------------- + ! To be updated ... + ! ---------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output, + ! + ! !/NCO NCEP NCO modifications for operational implementation. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG #ifdef W3_NL1 - USE W3ADATMD,ONLY: W3NAUX, W3SETA + USE W3ADATMD,ONLY: W3NAUX, W3SETA #endif - USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STRSPLIT + USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STRSPLIT #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif - USE W3TIMEMD - USE W3ARRYMD, ONLY : INA2R, INA2I - USE W3IOGRMD, ONLY: W3IOGR - USE W3FLDSMD, ONLY: W3FLDO, W3FLDG, W3FLDD, W3FLDTIDE1, W3FLDTIDE2 -!/ - USE W3GDATMD - USE W3GSRUMD - USE W3ODATMD, ONLY: NDSE, NDST, NDSO, FNMPRE - USE W3TIDEMD - USE W3IDATMD -! - IMPLICIT NONE -! + USE W3TIMEMD + USE W3ARRYMD, ONLY : INA2R, INA2I + USE W3IOGRMD, ONLY: W3IOGR + USE W3FLDSMD, ONLY: W3FLDO, W3FLDG, W3FLDD, W3FLDTIDE1, W3FLDTIDE2 + !/ + USE W3GDATMD + USE W3GSRUMD + USE W3ODATMD, ONLY: NDSE, NDST, NDSO, FNMPRE + USE W3TIDEMD + USE W3IDATMD + ! + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NDSI, NDSF, NDSM, NDSDAT, NDSTRC, NTRACE - INTEGER :: IERR, IFLD, I, JJ, J, IX, IY - INTEGER :: DTTST, NDSEN, PRTIDE_DT - INTEGER :: TIDE_PRMF, FLAGTIDE, TINDEX - INTEGER :: TIDEOK, TIDE_MAX, TIDE_MAXI - INTEGER :: K, ICON, IX2, SUMOK, NBAD, ITER - INTEGER :: IE, IP, IP2, II, IFOUND, ALREADYFOUND - INTEGER :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NDSI, NDSF, NDSM, NDSDAT, NDSTRC, NTRACE + INTEGER :: IERR, IFLD, I, JJ, J, IX, IY + INTEGER :: DTTST, NDSEN, PRTIDE_DT + INTEGER :: TIDE_PRMF, FLAGTIDE, TINDEX + INTEGER :: TIDEOK, TIDE_MAX, TIDE_MAXI + INTEGER :: K, ICON, IX2, SUMOK, NBAD, ITER + INTEGER :: IE, IP, IP2, II, IFOUND, ALREADYFOUND + INTEGER :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" #ifdef W3_MPI - INTEGER :: IERR_MPI, IND, REST, SLICE + INTEGER :: IERR_MPI, IND, REST, SLICE #endif - INTEGER :: TIME(2), TIDE_START(2), TIDE_END(2) - INTEGER :: INDMAX(70), PR_INDS(70) -! - INTEGER, ALLOCATABLE :: BADPOINTS(:,:), VNEIGH(:,:), CONN(:) + INTEGER :: TIME(2), TIDE_START(2), TIDE_END(2) + INTEGER :: INDMAX(70), PR_INDS(70) + ! + INTEGER, ALLOCATABLE :: BADPOINTS(:,:), VNEIGH(:,:), CONN(:) #ifdef W3_MPI - INTEGER, ALLOCATABLE :: NELEM(:), CUMUL(:) + INTEGER, ALLOCATABLE :: NELEM(:), CUMUL(:) #endif -! - REAL :: WCURTIDEX, WCURTIDEY, TIDE_ARGX, TIDE_ARGY - REAL :: AMPCOS, AMPSIN -! - REAL :: TIDE_FX(44),UX(44),VX(44), MAXVALCON(70) -! - REAL, ALLOCATABLE :: FX(:,:), FY(:,:), FA(:,:) + ! + REAL :: WCURTIDEX, WCURTIDEY, TIDE_ARGX, TIDE_ARGY + REAL :: AMPCOS, AMPSIN + ! + REAL :: TIDE_FX(44),UX(44),VX(44), MAXVALCON(70) + ! + REAL, ALLOCATABLE :: FX(:,:), FY(:,:), FA(:,:) #ifdef W3_MPI - REAL, ALLOCATABLE :: FX1D(:), FY1D(:), FA1D(:) - REAL, ALLOCATABLE :: FX1DL(:), FY1DL(:), FA1DL(:) + REAL, ALLOCATABLE :: FX1D(:), FY1D(:), FA1D(:) + REAL, ALLOCATABLE :: FX1DL(:), FY1DL(:), FA1DL(:) #endif -! - DOUBLE PRECISION :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau -! - CHARACTER*256 :: FILENAMEXT - CHARACTER :: TIDECONSTNAMES*1024 - CHARACTER*23 :: IDTIME - CHARACTER :: COMSTR*1, IDFLD*3 -! - CHARACTER(LEN=100) :: TIDECON_PRNAMES(70), TIDECON_MAXNAMES(70) - CHARACTER(LEN=100) :: TIDECON_MAXVALS(70) -! - LOGICAL :: TIDEFILL -! -!/ -!/ ------------------------------------------------------------------- / -!/ - -!========================================================== -! -! Initialization -! -!========================================================== - -! -! 1.a Set number of models -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) + ! + DOUBLE PRECISION :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau + ! + CHARACTER*256 :: FILENAMEXT + CHARACTER :: TIDECONSTNAMES*1024 + CHARACTER*23 :: IDTIME + CHARACTER :: COMSTR*1, IDFLD*3 + ! + CHARACTER(LEN=100) :: TIDECON_PRNAMES(70), TIDECON_MAXNAMES(70) + CHARACTER(LEN=100) :: TIDECON_MAXVALS(70) + ! + LOGICAL :: TIDEFILL + ! + !/ + !/ ------------------------------------------------------------------- / + !/ + + !========================================================== + ! + ! Initialization + ! + !========================================================== + + ! + ! 1.a Set number of models + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) #ifdef W3_NL1 - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) #endif - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! -! 1.b IO set-up. -! - NDSI = 10 - NDSO = 6 - NDSE = 6 - NDST = 6 - NDSM = 11 - NDSDAT = 12 - NDSF = 13 -! - NDSTRC = 6 - NTRACE = 10 - TIDEFILL =.TRUE. - CALL ITRACE ( NDSTRC, NTRACE ) -! + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + ! 1.b IO set-up. + ! + NDSI = 10 + NDSO = 6 + NDSE = 6 + NDST = 6 + NDSM = 11 + NDSDAT = 12 + NDSF = 13 + ! + NDSTRC = 6 + NTRACE = 10 + TIDEFILL =.TRUE. + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_NCO -! -! Redo according to NCO -! - NDSI = 11 - NDSO = 6 - NDSE = NDSO - NDST = NDSO - NDSM = 12 - NDSDAT = 51 - NDSTRC = NDSO + ! + ! Redo according to NCO + ! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSDAT = 51 + NDSTRC = NDSO #endif #ifdef W3_S - CALL STRACE (IENT, 'W3PRTIDE') + CALL STRACE (IENT, 'W3PRTIDE') #endif -! -! 1.c MPP initializations -! + ! + ! 1.c MPP initializations + ! #ifdef W3_SHRD - NAPROC = 1 - IAPROC = 1 + NAPROC = 1 + IAPROC = 1 #endif -! + ! #ifdef W3_MPI - CALL MPI_INIT ( IERR_MPI ) - CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) - CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) - IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC + CALL MPI_INIT ( IERR_MPI ) + CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC #endif -! - IF ( IAPROC .EQ. NAPERR ) THEN - NDSEN = NDSE - ELSE - NDSEN = -1 - END IF -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) -! - OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_prtide.inp',STATUS='OLD', & - ERR=800,IOSTAT=IERR) - REWIND (NDSI) - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR - -!========================================================== -! -! Read model definition file. -! -!========================================================== - - CALL W3IOGR ( 'READ', NDSM ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,902) GNAME - ALLOCATE ( FX(NX,NY), FY(NX,NY), FA(NX,NY), BADPOINTS(NX,NY) ) - -!========================================================== -! -! Read types from input file. -! -!========================================================== - - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDFLD -! - IF ( IDFLD.EQ.'LEV' ) THEN - IFLD = 2 - ELSE IF ( IDFLD.EQ.'CUR' ) THEN - IFLD = 4 - ELSE - WRITE (NDSE,1030) IDFLD - CALL EXTCDE ( 1 ) - END IF -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) TIDECONSTNAMES - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - TIDECON_PRNAMES(:)='' - CALL STRSPLIT(TIDECONSTNAMES,TIDECON_PRNAMES) -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) TIDECONSTNAMES - TIDECON_MAXNAMES(:)='' - CALL STRSPLIT(TIDECONSTNAMES,TIDECON_MAXNAMES) -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - TIDECON_MAXVALS(:)='' - READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) TIDECONSTNAMES - CALL STRSPLIT(TIDECONSTNAMES,TIDECON_MAXVALS) -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) TIDE_START,PRTIDE_DT,TIDE_END - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) FILENAMEXT -! - CALL W3FLDO ('READ', IDFLD, NDSF, NDST, & - NDSE, NX, NY, GTYPE, & - IERR, FILENAMEXT, '', TIDEFLAGIN=FLAGTIDE ) -! - IF (FLAGTIDE.NE.1) GOTO 803 -! - CALL VUF_SET_PARAMETERS - -!========================================================== -! -! Read tidal amplitudes and phases -! -!========================================================== - - CALL W3FLDTIDE1 ( 'READ', NDSF, NDST, NDSE, NX, NY, IDFLD, IERR ) - CALL W3FLDTIDE2 ( 'READ', NDSF, NDST, NDSE, NX, NY, IDFLD, 0, IERR ) - CLOSE(NDSF) - -! - - IF (GTYPE.EQ.UNGTYPE) THEN - - COUNTRI = MAXVAL(CCON) - ALLOCATE(VNEIGH(NX,2*COUNTRI)) - ALLOCATE(CONN(NX)) - VNEIGH(:,:) = 0 - CONN(:) = 0 -! - J = 0 - DO IP = 1, NX - IFOUND = 0 - DO II = 1, CCON(IP) - J = J + 1 - IE = IE_CELL(J) - IF (IP == TRIGP(1,IE)) THEN - DO IP2=2,3 - ALREADYFOUND = 0 - DO I=1,IFOUND - IF (VNEIGH(IP,I).EQ.TRIGP(IP2,IE)) ALREADYFOUND=ALREADYFOUND+1 - END DO - IF (ALREADYFOUND.EQ.0) THEN - IFOUND=IFOUND+1 - VNEIGH(IP,IFOUND)=TRIGP(IP2,IE) - END IF - END DO - END IF - - IF (IP == TRIGP(2,IE)) THEN - DO IP2=3,4 - ALREADYFOUND = 0 - DO I=1,IFOUND - IF (VNEIGH(IP,I).EQ.TRIGP(MOD(IP2-1,3)+1,IE)) ALREADYFOUND=ALREADYFOUND+1 - END DO - IF (ALREADYFOUND.EQ.0) THEN - IFOUND=IFOUND+1 - VNEIGH(IP,IFOUND)=TRIGP(MOD(IP2-1,3)+1,IE) - END IF - END DO + ! + IF ( IAPROC .EQ. NAPERR ) THEN + NDSEN = NDSE + ELSE + NDSEN = -1 + END IF + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) + ! + OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_prtide.inp',STATUS='OLD', & + ERR=800,IOSTAT=IERR) + REWIND (NDSI) + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR + + !========================================================== + ! + ! Read model definition file. + ! + !========================================================== + + CALL W3IOGR ( 'READ', NDSM ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,902) GNAME + ALLOCATE ( FX(NX,NY), FY(NX,NY), FA(NX,NY), BADPOINTS(NX,NY) ) + + !========================================================== + ! + ! Read types from input file. + ! + !========================================================== + + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDFLD + ! + IF ( IDFLD.EQ.'LEV' ) THEN + IFLD = 2 + ELSE IF ( IDFLD.EQ.'CUR' ) THEN + IFLD = 4 + ELSE + WRITE (NDSE,1030) IDFLD + CALL EXTCDE ( 1 ) + END IF + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) TIDECONSTNAMES + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + TIDECON_PRNAMES(:)='' + CALL STRSPLIT(TIDECONSTNAMES,TIDECON_PRNAMES) + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) TIDECONSTNAMES + TIDECON_MAXNAMES(:)='' + CALL STRSPLIT(TIDECONSTNAMES,TIDECON_MAXNAMES) + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + TIDECON_MAXVALS(:)='' + READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) TIDECONSTNAMES + CALL STRSPLIT(TIDECONSTNAMES,TIDECON_MAXVALS) + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) TIDE_START,PRTIDE_DT,TIDE_END + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) FILENAMEXT + ! + CALL W3FLDO ('READ', IDFLD, NDSF, NDST, & + NDSE, NX, NY, GTYPE, & + IERR, FILENAMEXT, '', TIDEFLAGIN=FLAGTIDE ) + ! + IF (FLAGTIDE.NE.1) GOTO 803 + ! + CALL VUF_SET_PARAMETERS + + !========================================================== + ! + ! Read tidal amplitudes and phases + ! + !========================================================== + + CALL W3FLDTIDE1 ( 'READ', NDSF, NDST, NDSE, NX, NY, IDFLD, IERR ) + CALL W3FLDTIDE2 ( 'READ', NDSF, NDST, NDSE, NX, NY, IDFLD, 0, IERR ) + CLOSE(NDSF) + + ! + + IF (GTYPE.EQ.UNGTYPE) THEN + + COUNTRI = MAXVAL(CCON) + ALLOCATE(VNEIGH(NX,2*COUNTRI)) + ALLOCATE(CONN(NX)) + VNEIGH(:,:) = 0 + CONN(:) = 0 + ! + J = 0 + DO IP = 1, NX + IFOUND = 0 + DO II = 1, CCON(IP) + J = J + 1 + IE = IE_CELL(J) + IF (IP == TRIGP(1,IE)) THEN + DO IP2=2,3 + ALREADYFOUND = 0 + DO I=1,IFOUND + IF (VNEIGH(IP,I).EQ.TRIGP(IP2,IE)) ALREADYFOUND=ALREADYFOUND+1 + END DO + IF (ALREADYFOUND.EQ.0) THEN + IFOUND=IFOUND+1 + VNEIGH(IP,IFOUND)=TRIGP(IP2,IE) END IF + END DO + END IF - IF (IP == TRIGP(3,IE)) THEN - DO IP2=1,2 - ALREADYFOUND = 0 - DO I=1,IFOUND - IF (VNEIGH(IP,I).EQ.TRIGP(IP2,IE)) ALREADYFOUND=ALREADYFOUND+1 - END DO - IF (ALREADYFOUND.EQ.0) THEN - IFOUND=IFOUND+1 - VNEIGH(IP,IFOUND)=TRIGP(IP2,IE) - END IF - END DO + IF (IP == TRIGP(2,IE)) THEN + DO IP2=3,4 + ALREADYFOUND = 0 + DO I=1,IFOUND + IF (VNEIGH(IP,I).EQ.TRIGP(MOD(IP2-1,3)+1,IE)) ALREADYFOUND=ALREADYFOUND+1 + END DO + IF (ALREADYFOUND.EQ.0) THEN + IFOUND=IFOUND+1 + VNEIGH(IP,IFOUND)=TRIGP(MOD(IP2-1,3)+1,IE) END IF - END DO ! CCON -! CONN is a counter on connected points. In comparison with the number of connected triangle -! CCON, it will enable to spot whether a point belong to the contour -! - CONN(IP)=IFOUND - DO I=2,IFOUND - DO JJ=1,i-1 - IF (VNEIGH(IP,JJ).EQ. VNEIGH(IP,I)) THEN - COUNTCON(IP)=COUNTCON(IP)-1 - VNEIGH(IP,I:IFOUND)=VNEIGH(IP,I+1:IFOUND+1) ! removes the double point - END IF - END DO - END DO - END DO !NX - - END IF ! UNGTYPE + END DO + END IF -!========================================================== -! -! Apply the maximum threshold value to tidal constituents -! -!========================================================== - - CALL TIDE_FIND_INDICES_PREDICTION(TIDECON_PRNAMES,PR_INDS,TIDE_PRMF) - TIDE_MAX=0 - TIDE_MAXI=0 - DO WHILE (len_trim(TIDECON_MAXNAMES(TIDE_MAXI+1)).NE.0) - TIDE_MAXI=TIDE_MAXI+1 - DO J=1,TIDE_MF - IF (TRIM(TIDECON_NAME(J)).EQ.TRIM(TIDECON_MAXNAMES(TIDE_MAXI))) THEN - TIDE_MAX=TIDE_MAX+1 - INDMAX(TIDE_MAX)=J - READ(TIDECON_MAXVALS(TIDE_MAXI),*) MAXVALCON(TIDE_MAX) - IF (IAPROC.EQ.NAPOUT) THEN - WRITE(NDSO,'(A,I8,A,F10.2)') & - 'Maximum allowed value for amplitude:',& - J,TRIM(TIDECON_NAME(J)),MAXVALCON(TIDE_MAX) + IF (IP == TRIGP(3,IE)) THEN + DO IP2=1,2 + ALREADYFOUND = 0 + DO I=1,IFOUND + IF (VNEIGH(IP,I).EQ.TRIGP(IP2,IE)) ALREADYFOUND=ALREADYFOUND+1 + END DO + IF (ALREADYFOUND.EQ.0) THEN + IFOUND=IFOUND+1 + VNEIGH(IP,IFOUND)=TRIGP(IP2,IE) END IF + END DO + END IF + END DO ! CCON + ! CONN is a counter on connected points. In comparison with the number of connected triangle + ! CCON, it will enable to spot whether a point belong to the contour + ! + CONN(IP)=IFOUND + DO I=2,IFOUND + DO JJ=1,i-1 + IF (VNEIGH(IP,JJ).EQ. VNEIGH(IP,I)) THEN + COUNTCON(IP)=COUNTCON(IP)-1 + VNEIGH(IP,I:IFOUND)=VNEIGH(IP,I+1:IFOUND+1) ! removes the double point END IF END DO END DO - -!========================================================== -! -! Create the binary output file -! -!========================================================== - - FLAGTIDE = 0 - IF (IAPROC .EQ. NAPOUT) THEN - CALL W3FLDO ('WRITE', IDFLD, NDSDAT, NDST, NDSE, NX, NY, & - GTYPE, IERR, 'ww3', TIDEFLAGIN=FLAGTIDE) + END DO !NX + + END IF ! UNGTYPE + + !========================================================== + ! + ! Apply the maximum threshold value to tidal constituents + ! + !========================================================== + + CALL TIDE_FIND_INDICES_PREDICTION(TIDECON_PRNAMES,PR_INDS,TIDE_PRMF) + TIDE_MAX=0 + TIDE_MAXI=0 + DO WHILE (len_trim(TIDECON_MAXNAMES(TIDE_MAXI+1)).NE.0) + TIDE_MAXI=TIDE_MAXI+1 + DO J=1,TIDE_MF + IF (TRIM(TIDECON_NAME(J)).EQ.TRIM(TIDECON_MAXNAMES(TIDE_MAXI))) THEN + TIDE_MAX=TIDE_MAX+1 + INDMAX(TIDE_MAX)=J + READ(TIDECON_MAXVALS(TIDE_MAXI),*) MAXVALCON(TIDE_MAX) + IF (IAPROC.EQ.NAPOUT) THEN + WRITE(NDSO,'(A,I8,A,F10.2)') & + 'Maximum allowed value for amplitude:',& + J,TRIM(TIDECON_NAME(J)),MAXVALCON(TIDE_MAX) + END IF END IF - -!========================================================== -! -! Set arrays for MPI exchanges -! -!========================================================== + END DO + END DO + + !========================================================== + ! + ! Create the binary output file + ! + !========================================================== + + FLAGTIDE = 0 + IF (IAPROC .EQ. NAPOUT) THEN + CALL W3FLDO ('WRITE', IDFLD, NDSDAT, NDST, NDSE, NX, NY, & + GTYPE, IERR, 'ww3', TIDEFLAGIN=FLAGTIDE) + END IF + + !========================================================== + ! + ! Set arrays for MPI exchanges + ! + !========================================================== #ifdef W3_MPI - SLICE=NX/NAPROC - REST=MOD(NX,NAPROC) - IF(REST.GE.IAPROC) SLICE=SLICE+1 + SLICE=NX/NAPROC + REST=MOD(NX,NAPROC) + IF(REST.GE.IAPROC) SLICE=SLICE+1 #endif #ifdef W3_MPI - ! set total 1D array (nx) - ALLOCATE ( FX1D(NX), FY1D(NX), FA1D(NX)) - FX1D(:)=0. - FY1D(:)=0. - FA1D(:)=0. + ! set total 1D array (nx) + ALLOCATE ( FX1D(NX), FY1D(NX), FA1D(NX)) + FX1D(:)=0. + FY1D(:)=0. + FA1D(:)=0. #endif #ifdef W3_MPI - ! set local 1D array (slice) - ALLOCATE(FX1DL(SLICE)) - ALLOCATE(FY1DL(SLICE)) - ALLOCATE(FA1DL(SLICE)) - FX1DL(:)=0. - FY1DL(:)=0. - FA1DL(:)=0. + ! set local 1D array (slice) + ALLOCATE(FX1DL(SLICE)) + ALLOCATE(FY1DL(SLICE)) + ALLOCATE(FA1DL(SLICE)) + FX1DL(:)=0. + FY1DL(:)=0. + FA1DL(:)=0. #endif #ifdef W3_MPI - ! set arrays for number of elements per MPI proc - ALLOCATE(NELEM(NAPROC)) - ALLOCATE(CUMUL(NAPROC)) - NELEM(1) = NX / NAPROC - IF (REST .GT. 0) NELEM(1) = NELEM(1) + 1 - CUMUL(1) = 0 - DO I=2,NAPROC - CUMUL(I)=CUMUL(I-1)+NELEM(I-1) - NELEM(I) = NX / NAPROC - IF (REST .GT. I-1) NELEM(I) = NELEM(I) + 1 - END DO + ! set arrays for number of elements per MPI proc + ALLOCATE(NELEM(NAPROC)) + ALLOCATE(CUMUL(NAPROC)) + NELEM(1) = NX / NAPROC + IF (REST .GT. 0) NELEM(1) = NELEM(1) + 1 + CUMUL(1) = 0 + DO I=2,NAPROC + CUMUL(I)=CUMUL(I-1)+NELEM(I-1) + NELEM(I) = NX / NAPROC + IF (REST .GT. I-1) NELEM(I) = NELEM(I) + 1 + END DO #endif - + #ifdef W3_MPIT - WRITE(100+IAPROC,*) "Number of points for this processor ", IAPROC, " : ", NELEM(IAPROC), ' / ', NX - WRITE(100+IAPROC,*) "Cumul of points for this processor ", IAPROC, " : ", CUMUL(IAPROC), ' / ', NX + WRITE(100+IAPROC,*) "Number of points for this processor ", IAPROC, " : ", NELEM(IAPROC), ' / ', NX + WRITE(100+IAPROC,*) "Cumul of points for this processor ", IAPROC, " : ", CUMUL(IAPROC), ' / ', NX #endif -!========================================================== -! -! Loop on time steps -! -!========================================================== - - DTTST = DSEC21 ( TIDE_START , TIDE_END ) - IF ( DTTST .LE. 0. .OR. PRTIDE_DT .LT. 1 ) GOTO 888 - TIME = TIDE_START - TIDE_KD0= 2415020 -! - TINDEX = 1 -! - DO - DTTST = DSEC21 ( TIME, TIDE_END ) - IF ( DTTST .LT. 0. ) GOTO 888 -! - CALL STME21 ( TIME , IDTIME ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,973) IDTIME - - TIDE_HOUR = TIME2HOURS(TIME) -! -!* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED -! - d1=TIDE_HOUR/24.d0 - d1=d1-dfloat(TIDE_kd0)-0.5d0 - CALL ASTR(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) - INT24=24 - INTDYS=int((TIDE_HOUR+0.00001)/INT24) - HH=TIDE_HOUR-dfloat(INTDYS*INT24) - TAU=HH/24.D0+H-S - -!========================================================== -! -! Treatment of 'bad points' at first time step -! -!========================================================== - - BADPOINTS(:,:)=0 - NBAD =0 - - IF (TINDEX.EQ.1) THEN - DO IY = 1, NY - DO IX=1, NX - TIDEOK=1 - DO I=1,TIDE_MAX - IF (ABS(TIDAL_CONST(IX,IY,INDMAX(I),1,1)) .GT.MAXVALCON(I) .OR. & - ABS(TIDAL_CONST(IX,IY,INDMAX(I),2,1)) .GT.MAXVALCON(I)) THEN - TIDEOK = 0 - WRITE(NDSO,'(A,I8,F10.2,A,2F10.2)') & - '[BAD POINT] GREATER THAN THRESHOLD ', MAXVALCON(I), & - ' AT INDEX ', INDMAX(I), & - ' WITH X-Y COMPONENTS : ', ABS(TIDAL_CONST(IX,IY,INDMAX(I),1:2,1)) - END IF - BADPOINTS(IX,IY) = BADPOINTS(IX,IY) + (1-TIDEOK) - END DO - - IF (BADPOINTS(IX,IY).GT.0) THEN - NBAD = NBAD +1 - WRITE(NDSE,*) 'BAD POINT:',IX,IY,NBAD, & - TIDAL_CONST(IX,IY,:,1,1),'##',TIDAL_CONST(IX,IY,:,2,1) - END IF - END DO + !========================================================== + ! + ! Loop on time steps + ! + !========================================================== + + DTTST = DSEC21 ( TIDE_START , TIDE_END ) + IF ( DTTST .LE. 0. .OR. PRTIDE_DT .LT. 1 ) GOTO 888 + TIME = TIDE_START + TIDE_KD0= 2415020 + ! + TINDEX = 1 + ! + DO + DTTST = DSEC21 ( TIME, TIDE_END ) + IF ( DTTST .LT. 0. ) GOTO 888 + ! + CALL STME21 ( TIME , IDTIME ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,973) IDTIME + + TIDE_HOUR = TIME2HOURS(TIME) + ! + !* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED + ! + d1=TIDE_HOUR/24.d0 + d1=d1-dfloat(TIDE_kd0)-0.5d0 + CALL ASTR(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) + INT24=24 + INTDYS=int((TIDE_HOUR+0.00001)/INT24) + HH=TIDE_HOUR-dfloat(INTDYS*INT24) + TAU=HH/24.D0+H-S + + !========================================================== + ! + ! Treatment of 'bad points' at first time step + ! + !========================================================== + + BADPOINTS(:,:)=0 + NBAD =0 + + IF (TINDEX.EQ.1) THEN + DO IY = 1, NY + DO IX=1, NX + TIDEOK=1 + DO I=1,TIDE_MAX + IF (ABS(TIDAL_CONST(IX,IY,INDMAX(I),1,1)) .GT.MAXVALCON(I) .OR. & + ABS(TIDAL_CONST(IX,IY,INDMAX(I),2,1)) .GT.MAXVALCON(I)) THEN + TIDEOK = 0 + WRITE(NDSO,'(A,I8,F10.2,A,2F10.2)') & + '[BAD POINT] GREATER THAN THRESHOLD ', MAXVALCON(I), & + ' AT INDEX ', INDMAX(I), & + ' WITH X-Y COMPONENTS : ', ABS(TIDAL_CONST(IX,IY,INDMAX(I),1:2,1)) + END IF + BADPOINTS(IX,IY) = BADPOINTS(IX,IY) + (1-TIDEOK) END DO -! - DO ITER=1,2 - DO IY = 1, NY - DO IX= 1, NX - IF (BADPOINTS(IX,IY).GT.0) THEN - TIDAL_CONST(IX,IY,:,1,1)=0 - TIDAL_CONST(IX,IY,:,2,1)=0 - - IF (TIDEFILL.AND.(GTYPE.EQ.UNGTYPE)) THEN - -! -! Performs a vector sum of tidal constituents over neighbor nodes -! - DO J=1, TIDE_MF - DO K=1, 2 - AMPCOS = 0 - AMPSIN = 0 - SUMOK = 0 - DO ICON=1,COUNTCON(IX) - IX2=VNEIGH(IX,ICON) - IF (BADPOINTS(IX2,IY).EQ.0) THEN - SUMOK = SUMOK + 1 - AMPCOS = AMPCOS+TIDAL_CONST(IX2,IY,J,K,1)*COS(TIDAL_CONST(IX2,IY,J,K,2)*DERA) - AMPSIN = AMPSIN+TIDAL_CONST(IX2,IY,J,K,1)*SIN(TIDAL_CONST(IX2,IY,J,K,2)*DERA) - END IF - END DO - IF (SUMOK.GT.1) THEN -! -! Finalizes the amplitude and phase calculation from COS and SIN. Special case for mean value Z0. -! - IF (TIDECON_NAME(J).NE.'Z0 ') THEN - TIDAL_CONST(IX,IY,J,K,1) = SQRT(AMPCOS**2+AMPSIN**2)/SUMOK - TIDAL_CONST(IX,IY,J,K,2) = ATAN2(AMPSIN,AMPCOS)/DERA - ELSE - TIDAL_CONST(IX,IY,J,K,1) = AMPCOS/SUMOK - TIDAL_CONST(IX,IY,J,K,2) = 0. - END IF - IF(K.EQ.2.AND.J.EQ.TIDE_MF) THEN - NBAD=NBAD-1 - BADPOINTS(IX,IY) = 0 - END IF - ENDIF - END DO + IF (BADPOINTS(IX,IY).GT.0) THEN + NBAD = NBAD +1 + WRITE(NDSE,*) 'BAD POINT:',IX,IY,NBAD, & + TIDAL_CONST(IX,IY,:,1,1),'##',TIDAL_CONST(IX,IY,:,2,1) + END IF + END DO + END DO + ! + DO ITER=1,2 + DO IY = 1, NY + DO IX= 1, NX + IF (BADPOINTS(IX,IY).GT.0) THEN + TIDAL_CONST(IX,IY,:,1,1)=0 + TIDAL_CONST(IX,IY,:,2,1)=0 + + + IF (TIDEFILL.AND.(GTYPE.EQ.UNGTYPE)) THEN + + ! + ! Performs a vector sum of tidal constituents over neighbor nodes + ! + DO J=1, TIDE_MF + DO K=1, 2 + AMPCOS = 0 + AMPSIN = 0 + SUMOK = 0 + DO ICON=1,COUNTCON(IX) + IX2=VNEIGH(IX,ICON) + IF (BADPOINTS(IX2,IY).EQ.0) THEN + SUMOK = SUMOK + 1 + AMPCOS = AMPCOS+TIDAL_CONST(IX2,IY,J,K,1)*COS(TIDAL_CONST(IX2,IY,J,K,2)*DERA) + AMPSIN = AMPSIN+TIDAL_CONST(IX2,IY,J,K,1)*SIN(TIDAL_CONST(IX2,IY,J,K,2)*DERA) + END IF END DO - END IF - END IF - END DO - END DO + IF (SUMOK.GT.1) THEN + ! + ! Finalizes the amplitude and phase calculation from COS and SIN. Special case for mean value Z0. + ! + IF (TIDECON_NAME(J).NE.'Z0 ') THEN + TIDAL_CONST(IX,IY,J,K,1) = SQRT(AMPCOS**2+AMPSIN**2)/SUMOK + TIDAL_CONST(IX,IY,J,K,2) = ATAN2(AMPSIN,AMPCOS)/DERA + ELSE + TIDAL_CONST(IX,IY,J,K,1) = AMPCOS/SUMOK + TIDAL_CONST(IX,IY,J,K,2) = 0. + END IF + IF(K.EQ.2.AND.J.EQ.TIDE_MF) THEN + NBAD=NBAD-1 + BADPOINTS(IX,IY) = 0 + END IF + ENDIF + END DO + END DO + END IF + END IF END DO - IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSE,*) 'Number of remaining bad points:',NBAD - END IF + END DO + END DO + IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSE,*) 'Number of remaining bad points:',NBAD + END IF -!========================================================== -! -! For currents: 2 components -! -!========================================================== + !========================================================== + ! + ! For currents: 2 components + ! + !========================================================== - IF (IFLD.EQ.4) THEN - DO IY = 1, NY + IF (IFLD.EQ.4) THEN + DO IY = 1, NY #ifdef W3_MPI - IND=0 - DO IX=CUMUL(IAPROC)+1,CUMUL(IAPROC)+NELEM(IAPROC) + IND=0 + DO IX=CUMUL(IAPROC)+1,CUMUL(IAPROC)+NELEM(IAPROC) #endif #ifdef W3_SHRD - DO IX=1,NX + DO IX=1,NX #endif - CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,REAL(YGRD(IY,IX)),TIDE_FX,UX,VX) - WCURTIDEX = 0. - WCURTIDEY = 0. - DO I=1,TIDE_PRMF - J=PR_INDS(I) - IF (TRIM(TIDECON_NAME(J)).EQ.'Z0') THEN - WCURTIDEX = WCURTIDEX+TIDAL_CONST(IX,IY,J,1,1) - WCURTIDEY = WCURTIDEY+TIDAL_CONST(IX,IY,J,2,1) - ELSE - TIDE_ARGX=(VX(J)+UX(J))*twpi-TIDAL_CONST(IX,IY,J,1,2)*DERA - TIDE_ARGY=(VX(J)+UX(J))*twpi-TIDAL_CONST(IX,IY,J,2,2)*DERA - WCURTIDEX = WCURTIDEX+TIDE_FX(J)*TIDAL_CONST(IX,IY,J,1,1)*COS(TIDE_ARGX) - WCURTIDEY = WCURTIDEY+TIDE_FX(J)*TIDAL_CONST(IX,IY,J,2,1)*COS(TIDE_ARGY) - END IF - END DO - IF (ABS(WCURTIDEX).GT.10..OR.ABS(WCURTIDEY).GT.10.) THEN - WRITE(NDSE,*) & - 'WARNING: VERY STRONG CURRENT... BAD CONSTITUENTS?', & - IX, WCURTIDEX, WCURTIDEY , TIDAL_CONST(IX,IY,:,1,1),'##',TIDAL_CONST(IX,IY,:,2,1) - STOP + CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,REAL(YGRD(IY,IX)),TIDE_FX,UX,VX) + WCURTIDEX = 0. + WCURTIDEY = 0. + DO I=1,TIDE_PRMF + J=PR_INDS(I) + IF (TRIM(TIDECON_NAME(J)).EQ.'Z0') THEN + WCURTIDEX = WCURTIDEX+TIDAL_CONST(IX,IY,J,1,1) + WCURTIDEY = WCURTIDEY+TIDAL_CONST(IX,IY,J,2,1) + ELSE + TIDE_ARGX=(VX(J)+UX(J))*twpi-TIDAL_CONST(IX,IY,J,1,2)*DERA + TIDE_ARGY=(VX(J)+UX(J))*twpi-TIDAL_CONST(IX,IY,J,2,2)*DERA + WCURTIDEX = WCURTIDEX+TIDE_FX(J)*TIDAL_CONST(IX,IY,J,1,1)*COS(TIDE_ARGX) + WCURTIDEY = WCURTIDEY+TIDE_FX(J)*TIDAL_CONST(IX,IY,J,2,1)*COS(TIDE_ARGY) END IF + END DO + IF (ABS(WCURTIDEX).GT.10..OR.ABS(WCURTIDEY).GT.10.) THEN + WRITE(NDSE,*) & + 'WARNING: VERY STRONG CURRENT... BAD CONSTITUENTS?', & + IX, WCURTIDEX, WCURTIDEY , TIDAL_CONST(IX,IY,:,1,1),'##',TIDAL_CONST(IX,IY,:,2,1) + STOP + END IF #ifdef W3_MPI - IND=IND+1 - FX1DL(IND) = WCURTIDEX - FY1DL(IND) = WCURTIDEY - FA1DL(IND) = 0. - END DO ! NX + IND=IND+1 + FX1DL(IND) = WCURTIDEX + FY1DL(IND) = WCURTIDEY + FA1DL(IND) = 0. + END DO ! NX #endif #ifdef W3_SHRD - FX(IX,IY) = WCURTIDEX - FY(IX,IY) = WCURTIDEY - FA(IX,IY) = 0. - END DO ! NX + FX(IX,IY) = WCURTIDEX + FY(IX,IY) = WCURTIDEY + FA(IX,IY) = 0. + END DO ! NX #endif -! -! Gather from other MPI tasks -! + ! + ! Gather from other MPI tasks + ! #ifdef W3_MPI - IF (NAPROC.GT.1) THEN - CALL MPI_GATHERV(FX1DL, SLICE, MPI_REAL, FX1D, NELEM, & - CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) - CALL MPI_GATHERV(FY1DL, SLICE, MPI_REAL, FY1D, NELEM, & - CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) - CALL MPI_GATHERV(FA1DL, SLICE, MPI_REAL, FA1D, NELEM, & - CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) - ELSE - FX1D = FX1DL - FY1D = FY1DL - FA1D = FA1DL - END IF + IF (NAPROC.GT.1) THEN + CALL MPI_GATHERV(FX1DL, SLICE, MPI_REAL, FX1D, NELEM, & + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + CALL MPI_GATHERV(FY1DL, SLICE, MPI_REAL, FY1D, NELEM, & + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + CALL MPI_GATHERV(FA1DL, SLICE, MPI_REAL, FA1D, NELEM, & + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + ELSE + FX1D = FX1DL + FY1D = FY1DL + FA1D = FA1DL + END IF #endif -! -! Convert from 1D to 2D array -! + ! + ! Convert from 1D to 2D array + ! #ifdef W3_MPI - IF (IAPROC .EQ. NAPOUT) THEN - IND=0 - DO IX=1,NX - IND=IND+1 - FX(IX,IY)=FX1D(IND) - FY(IX,IY)=FY1D(IND) - FA(IX,IY)=FA1D(IND) - END DO - END IF + IF (IAPROC .EQ. NAPOUT) THEN + IND=0 + DO IX=1,NX + IND=IND+1 + FX(IX,IY)=FX1D(IND) + FY(IX,IY)=FY1D(IND) + FA(IX,IY)=FA1D(IND) + END DO + END IF #endif - END DO ! NY - END IF ! IFLD.EQ.4 + END DO ! NY + END IF ! IFLD.EQ.4 -!========================================================== -! -! For water levels: only 1 component -! -!========================================================== + !========================================================== + ! + ! For water levels: only 1 component + ! + !========================================================== - IF (IFLD.EQ.2) THEN - DO IY = 1, NY + IF (IFLD.EQ.2) THEN + DO IY = 1, NY #ifdef W3_MPI - IND=0 - DO IX=CUMUL(IAPROC)+1,CUMUL(IAPROC)+NELEM(IAPROC) + IND=0 + DO IX=CUMUL(IAPROC)+1,CUMUL(IAPROC)+NELEM(IAPROC) #endif #ifdef W3_SHRD - DO IX=1,NX + DO IX=1,NX #endif - CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,REAL(YGRD(IY,IX)),TIDE_FX,UX,VX) -! -! Removes unlikely values ... -! - IF (TINDEX.EQ.1) THEN - TIDEOK=1 - DO I=1,TIDE_MAX - IF (ABS(TIDAL_CONST(IX,IY,INDMAX(I),1,1)) .GT.MAXVALCON(I)) & - TIDEOK = 0 - END DO - IF (TIDEOK.EQ.0) THEN - WRITE(NDSE,*) 'BAD POINT:',IX,IY, TIDAL_CONST(IX,IY,:,1,1) - TIDAL_CONST(IX,IY,:,1,1)=0 - END IF - END IF - - WCURTIDEX = 0. - DO I=1,TIDE_PRMF - J=PR_INDS(I) - IF (TRIM(TIDECON_NAME(J)).EQ.'Z0') THEN - WCURTIDEX = WCURTIDEX+TIDAL_CONST(IX,IY,J,1,1) - ELSE - TIDE_ARGX=(VX(J)+UX(J))*twpi-TIDAL_CONST(IX,IY,J,1,2)*DERA - WCURTIDEX = WCURTIDEX+TIDE_FX(J)*TIDAL_CONST(IX,IY,J,1,1)*COS(TIDE_ARGX) - END IF + CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,REAL(YGRD(IY,IX)),TIDE_FX,UX,VX) + ! + ! Removes unlikely values ... + ! + IF (TINDEX.EQ.1) THEN + TIDEOK=1 + DO I=1,TIDE_MAX + IF (ABS(TIDAL_CONST(IX,IY,INDMAX(I),1,1)) .GT.MAXVALCON(I)) & + TIDEOK = 0 END DO + IF (TIDEOK.EQ.0) THEN + WRITE(NDSE,*) 'BAD POINT:',IX,IY, TIDAL_CONST(IX,IY,:,1,1) + TIDAL_CONST(IX,IY,:,1,1)=0 + END IF + END IF + + WCURTIDEX = 0. + DO I=1,TIDE_PRMF + J=PR_INDS(I) + IF (TRIM(TIDECON_NAME(J)).EQ.'Z0') THEN + WCURTIDEX = WCURTIDEX+TIDAL_CONST(IX,IY,J,1,1) + ELSE + TIDE_ARGX=(VX(J)+UX(J))*twpi-TIDAL_CONST(IX,IY,J,1,2)*DERA + WCURTIDEX = WCURTIDEX+TIDE_FX(J)*TIDAL_CONST(IX,IY,J,1,1)*COS(TIDE_ARGX) + END IF + END DO #ifdef W3_MPI - IND=IND+1 - FX1DL(IND) = 0. - FY1DL(IND) = 0. - FA1DL(IND) = WCURTIDEX - END DO ! NX + IND=IND+1 + FX1DL(IND) = 0. + FY1DL(IND) = 0. + FA1DL(IND) = WCURTIDEX + END DO ! NX #endif #ifdef W3_SHRD - FX(IX,IY) = 0. - FY(IX,IY) = 0. - FA(IX,IY) = WCURTIDEX - END DO ! NX + FX(IX,IY) = 0. + FY(IX,IY) = 0. + FA(IX,IY) = WCURTIDEX + END DO ! NX #endif -! -! Gather from other MPI tasks -! + ! + ! Gather from other MPI tasks + ! #ifdef W3_MPI - IF (NAPROC.GT.1) THEN - CALL MPI_GATHERV(FX1DL, SLICE, MPI_REAL, FX1D, NELEM,& - CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) - CALL MPI_GATHERV(FY1DL, SLICE, MPI_REAL, FY1D, NELEM,& - CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) - CALL MPI_GATHERV(FA1DL, SLICE, MPI_REAL, FA1D, NELEM,& - CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) - ELSE - FX1D = FX1DL - FY1D = FY1DL - FA1D = FA1DL - END IF + IF (NAPROC.GT.1) THEN + CALL MPI_GATHERV(FX1DL, SLICE, MPI_REAL, FX1D, NELEM,& + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + CALL MPI_GATHERV(FY1DL, SLICE, MPI_REAL, FY1D, NELEM,& + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + CALL MPI_GATHERV(FA1DL, SLICE, MPI_REAL, FA1D, NELEM,& + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + ELSE + FX1D = FX1DL + FY1D = FY1DL + FA1D = FA1DL + END IF #endif -! -! Convert from 1D to 2D array -! + ! + ! Convert from 1D to 2D array + ! #ifdef W3_MPI - IF (IAPROC .EQ. NAPOUT) THEN - IND=0 - DO IX=1,NX - IND=IND+1 - FX(IX,IY)=FX1D(IND) - FY(IX,IY)=FY1D(IND) - FA(IX,IY)=FA1D(IND) - END DO - END IF -#endif - - END DO ! NY - END IF ! IFLD.EQ.2 - - -!========================================================== -! -! Write into binary output file -! -!========================================================== - IF (IAPROC .EQ. NAPOUT) THEN - -! WHERE(FX.NE.FX) FX = 0. -! WHERE(FY.NE.FY) FY = 0. -! WHERE(FA.NE.FA) FA = 0. - - CALL W3FLDG ('WRITE', IDFLD, NDSDAT, NDST, NDSE, NX, NY, & - NX, NY, TIME, TIME, TIME, FX, FY, FA, TIME, & - FX, FY, FA, IERR) + IND=0 + DO IX=1,NX + IND=IND+1 + FX(IX,IY)=FX1D(IND) + FY(IX,IY)=FY1D(IND) + FA(IX,IY)=FA1D(IND) + END DO END IF +#endif -!========================================================== -! -! Increment the clock -! -!========================================================== - - CALL TICK21 ( TIME, FLOAT(PRTIDE_DT) ) - TINDEX = TINDEX +1 - - END DO -! - GOTO 888 -! -! Error escape locations -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 40 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 41 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 42 ) -! - 803 CONTINUE - WRITE (NDSE,1003) - CALL EXTCDE ( 43 ) -! - 888 CONTINUE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) + END DO ! NY + END IF ! IFLD.EQ.2 + + + !========================================================== + ! + ! Write into binary output file + ! + !========================================================== + + IF (IAPROC .EQ. NAPOUT) THEN + + ! WHERE(FX.NE.FX) FX = 0. + ! WHERE(FY.NE.FY) FY = 0. + ! WHERE(FA.NE.FA) FA = 0. + + CALL W3FLDG ('WRITE', IDFLD, NDSDAT, NDST, NDSE, NX, NY, & + NX, NY, TIME, TIME, TIME, FX, FY, FA, TIME, & + FX, FY, FA, IERR) + END IF + + !========================================================== + ! + ! Increment the clock + ! + !========================================================== + + CALL TICK21 ( TIME, FLOAT(PRTIDE_DT) ) + TINDEX = TINDEX +1 + + END DO + ! + GOTO 888 + ! + ! Error escape locations + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 40 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 41 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 42 ) + ! +803 CONTINUE + WRITE (NDSE,1003) + CALL EXTCDE ( 43 ) + ! +888 CONTINUE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) #ifdef W3_MPI - CALL MPI_FINALIZE ( IERR_MPI ) + CALL MPI_FINALIZE ( IERR_MPI ) #endif -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III tide prediction *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) - 902 FORMAT ( ' Grid name : ',A/) - 973 FORMAT ( ' Time : ',A) -! - 999 FORMAT(/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Input preprocessing '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRTIDE : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRTIDE : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRTIDE : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRTIDE : '/ & - ' THE INPUT FILE DOES NOT CONTAIN TIDAL DATA'/) -! - 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRTIDE : '/ & - ' ILLEGAL FIELD ID -->',A,'<--'/) -! -!/ -!/ End of W3PRTIDE ----------------------------------------------------- / -!/ - END PROGRAM W3PRTIDE + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III tide prediction *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) +902 FORMAT ( ' Grid name : ',A/) +973 FORMAT ( ' Time : ',A) + ! +999 FORMAT(/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Input preprocessing '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRTIDE : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRTIDE : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRTIDE : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRTIDE : '/ & + ' THE INPUT FILE DOES NOT CONTAIN TIDAL DATA'/) + ! +1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRTIDE : '/ & + ' ILLEGAL FIELD ID -->',A,'<--'/) + ! + !/ + !/ End of W3PRTIDE ----------------------------------------------------- / + !/ +END PROGRAM W3PRTIDE diff --git a/model/src/ww3_sbs1.F90 b/model/src/ww3_sbs1.F90 index b323a653e..94778b10d 100644 --- a/model/src/ww3_sbs1.F90 +++ b/model/src/ww3_sbs1.F90 @@ -10,14 +10,14 @@ !> !> @brief Program shell to run multi half-coupled. !> -!> @details Program shell or driver to run the multi-grid wave model in +!> @details Program shell or driver to run the multi-grid wave model in !> 'half-coupled' mode, that is running side-by-side with a weather !> model while waiting for wind field to become available. !> !> This version is set up for running at NCEP with a single input -!> wind file, and requires an additional input file. +!> wind file, and requires an additional input file. !> times.inp Input file with time stamps. Add to this input file -!> a time stamp after the field has been properly +!> a time stamp after the field has been properly !> added to the wind.ww3 or equavalent file. !> This file should have the time stamps of fields available in !> the first auxiliary wind input file (grid). @@ -33,627 +33,627 @@ !> @author A. Chawla !> @date 05-Dec-2012 !> - PROGRAM W3SBS1 -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | A. Chawla | -!/ | FORTRAN 90 | -!/ | Last update : 05-Dec-2012 | -!/ +-----------------------------------+ -!/ -!/ 04-May-2005 : Origination. ( version 3.07 ) -!/ 11-Aug-2010 : Upgrade for operations and inclusion in svn. -!/ ( version 3.14.4 ) -!/ 05-Dec-2012 : Making sleep a system call. ( version 4.11 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Program shell or driver to run the multi-grid wave model in -! 'half-coupled' mode, that is running side-by-side with a weather -! model while waiting for wind field to become available. -! -! This version is set up for running at NCEP with a single input -! wind file, and requires an additional input file. -! times.inp Input file with time stamps. Add to this input file -! a time stamp after the field has been properly -! added to the wind.ww3 or equavalent file. -! This file should have the time stamps of fields available in -! the first auxiliary wind input file (grid). -! -! Apart from management of the time stepping, this code is -! identical to ww3_multi.ftn, and reads the corresponding input -! file ww3_multi.inp -! -! Note hardwired options and system dependent parts as identified -! in Section 7. -! -! 2. Method : -! -! Calling WMWAVE in a loop as wind data become available, with -! test on wind file. -! -! In order for this to work properly, the user needs to increment -! then main wind input file (wind.XXXX) as data become avalable -! while this program is running. After a new field is added to -! wind file, the corresponding time stamp in YYYYMMDD YYMMSS -! format is concatenated to the times.inp file. As the code -! reads the new time stamp (1X,I8,1Z,I6 format), a test read of -! the wind file is performed until the file is readable, after -! which the wave model is run until the new time stamp and the -! process is repeated. The test reading of the wind file proved -! essential on the NCEP IBM systems to deal with file system -! latencies and buffer flushing. -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! SLEEP1 I.P. Sleep time for testing times file. -! SLEEP2 I.P. Sleep time for testing winds file. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WMINIT Subr. WMINITMD Multi-grid model initialization. -! WMWAVE Subr. WMWAVEMD Multi-grid model subroutine. -! WMFINL Subr. WMFINLMD Multi-grid model finalization. -! EXTCDE Subr. W3SERVMD Abort program as graceful as possible. -! W3SETG Subr. W3GDATMD Point to Grid data data structure. -! W3SETI Subr. W3IDATMD Point to input fields data structure. -! WMUGET Subr. WMUNITMD Automatic unit number assignement. -! WMUSET Subr. Automatic unit number assignement. -! -! MPI_INIT, MPI_COMM_SIZE, MPI_COMM_RANK, MPI_BARRIER, -! MPI_FINALIZE -! Subr. Standard MPI routines. -! -! RDTIME Subr. W3MLT Get next wind time. -! RDWIND Subr. W3MLT Test read next wind field. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Assumptions in this program: -! 1) WNS or WND option with 3 or two data fields is set in the -! decaration and initialization of the C*3 TYPE. -! 2) Single wind file to be tested, this is the first aux grid -! with wind defined. -! 3) Needs system SLEEP command, now behind SBS switch. -!/ 05-Dec-2012 : Making sleep a system call. ( version 4.11 ) +PROGRAM W3SBS1 + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | A. Chawla | + !/ | FORTRAN 90 | + !/ | Last update : 05-Dec-2012 | + !/ +-----------------------------------+ + !/ + !/ 04-May-2005 : Origination. ( version 3.07 ) + !/ 11-Aug-2010 : Upgrade for operations and inclusion in svn. + !/ ( version 3.14.4 ) + !/ 05-Dec-2012 : Making sleep a system call. ( version 4.11 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Program shell or driver to run the multi-grid wave model in + ! 'half-coupled' mode, that is running side-by-side with a weather + ! model while waiting for wind field to become available. + ! + ! This version is set up for running at NCEP with a single input + ! wind file, and requires an additional input file. + ! times.inp Input file with time stamps. Add to this input file + ! a time stamp after the field has been properly + ! added to the wind.ww3 or equavalent file. + ! This file should have the time stamps of fields available in + ! the first auxiliary wind input file (grid). + ! + ! Apart from management of the time stepping, this code is + ! identical to ww3_multi.ftn, and reads the corresponding input + ! file ww3_multi.inp + ! + ! Note hardwired options and system dependent parts as identified + ! in Section 7. + ! + ! 2. Method : + ! + ! Calling WMWAVE in a loop as wind data become available, with + ! test on wind file. + ! + ! In order for this to work properly, the user needs to increment + ! then main wind input file (wind.XXXX) as data become avalable + ! while this program is running. After a new field is added to + ! wind file, the corresponding time stamp in YYYYMMDD YYMMSS + ! format is concatenated to the times.inp file. As the code + ! reads the new time stamp (1X,I8,1Z,I6 format), a test read of + ! the wind file is performed until the file is readable, after + ! which the wave model is run until the new time stamp and the + ! process is repeated. The test reading of the wind file proved + ! essential on the NCEP IBM systems to deal with file system + ! latencies and buffer flushing. + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! SLEEP1 I.P. Sleep time for testing times file. + ! SLEEP2 I.P. Sleep time for testing winds file. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WMINIT Subr. WMINITMD Multi-grid model initialization. + ! WMWAVE Subr. WMWAVEMD Multi-grid model subroutine. + ! WMFINL Subr. WMFINLMD Multi-grid model finalization. + ! EXTCDE Subr. W3SERVMD Abort program as graceful as possible. + ! W3SETG Subr. W3GDATMD Point to Grid data data structure. + ! W3SETI Subr. W3IDATMD Point to input fields data structure. + ! WMUGET Subr. WMUNITMD Automatic unit number assignement. + ! WMUSET Subr. Automatic unit number assignement. + ! + ! MPI_INIT, MPI_COMM_SIZE, MPI_COMM_RANK, MPI_BARRIER, + ! MPI_FINALIZE + ! Subr. Standard MPI routines. + ! + ! RDTIME Subr. W3MLT Get next wind time. + ! RDWIND Subr. W3MLT Test read next wind field. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Assumptions in this program: + ! 1) WNS or WND option with 3 or two data fields is set in the + ! decaration and initialization of the C*3 TYPE. + ! 2) Single wind file to be tested, this is the first aux grid + ! with wind defined. + ! 3) Needs system SLEEP command, now behind SBS switch. + !/ 05-Dec-2012 : Making sleep a system call. ( version 4.11 ) -! -! 8. Structure : -! -! ---------------------------------------------------------------- -! 0. Initialization necessary for driver -! a General I/O: (implicit in wmmdatmd) -! b MPI environment -! c Identifying output to "screen" unit -! 1. Initialization of all wave models / grids ( WMINIT ) -! 2. Open and prepare test files. -! 3. Run the multi-grid models -! a Preparations -! b Catch up with starting time of model ( RDTIME ) -! c Catch up with test reading of file ( DWINDE ) -! d Run wave model ( WMWAVE ) -! 4. Finalization of wave model ( WMFINL ) -! 5. Finalization of driver -! ---------------------------------------------------------------- -! -! 9. Switches : -! -! !/MPI Including MPI routines / environment. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE WMINITMD, ONLY: WMINIT - USE WMWAVEMD, ONLY: WMWAVE - USE WMFINLMD, ONLY: WMFINL - USE W3SERVMD, ONLY: EXTCDE - USE W3GDATMD, ONLY: W3SETG - USE W3GDATMD, ONLY: NGRIDS, NAUXGR, NX, NY, GNAME, FILEXT - USE W3IDATMD, ONLY: W3SETI - USE W3IDATMD, ONLY: FLWIND - USE WMMDATMD, ONLY: MDSF - USE WMUNITMD, ONLY: WMUGET, WMUSET - USE W3TIMEMD -!/ - USE WMMDATMD, ONLY: MDSE, MDST, MDSS, NMPROC, IMPROC, NMPSCR, & - NRGRD, STIME, ETIME -!/ - IMPLICIT NONE -! + ! + ! 8. Structure : + ! + ! ---------------------------------------------------------------- + ! 0. Initialization necessary for driver + ! a General I/O: (implicit in wmmdatmd) + ! b MPI environment + ! c Identifying output to "screen" unit + ! 1. Initialization of all wave models / grids ( WMINIT ) + ! 2. Open and prepare test files. + ! 3. Run the multi-grid models + ! a Preparations + ! b Catch up with starting time of model ( RDTIME ) + ! c Catch up with test reading of file ( DWINDE ) + ! d Run wave model ( WMWAVE ) + ! 4. Finalization of wave model ( WMFINL ) + ! 5. Finalization of driver + ! ---------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/MPI Including MPI routines / environment. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE WMINITMD, ONLY: WMINIT + USE WMWAVEMD, ONLY: WMWAVE + USE WMFINLMD, ONLY: WMFINL + USE W3SERVMD, ONLY: EXTCDE + USE W3GDATMD, ONLY: W3SETG + USE W3GDATMD, ONLY: NGRIDS, NAUXGR, NX, NY, GNAME, FILEXT + USE W3IDATMD, ONLY: W3SETI + USE W3IDATMD, ONLY: FLWIND + USE WMMDATMD, ONLY: MDSF + USE WMUNITMD, ONLY: WMUGET, WMUSET + USE W3TIMEMD + !/ + USE WMMDATMD, ONLY: MDSE, MDST, MDSS, NMPROC, IMPROC, NMPSCR, & + NRGRD, STIME, ETIME + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: MPI_COMM = -99, IERR, NDST1, NDST2 = -1,& - NXW = -1, NYW = -1, TNEXT(2), TOLD(2), & - I + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: MPI_COMM = -99, IERR, NDST1, NDST2 = -1,& + NXW = -1, NYW = -1, TNEXT(2), TOLD(2), & + I #ifdef W3_MPI - INTEGER :: IERR_MPI + INTEGER :: IERR_MPI #endif - INTEGER, PARAMETER :: SLEEP1 = 10 , SLEEP2 = 10 - INTEGER, ALLOCATABLE :: TEND(:,:) - REAL :: DTTST -! CHARACTER(LEN=3) :: TSFLD, TYPE = 'WNS' - CHARACTER(LEN=3) :: TSFLD, TYPE = 'WND' - CHARACTER(LEN=13) :: TSSTR -!/ -!/ ------------------------------------------------------------------- / -! 0. Initialization necessary for driver -! 0.a General I/O: all can start with initialization in wmmdatmd -! -! 0.b MPI environment: Here, we use MPI_COMM_WORLD -! + INTEGER, PARAMETER :: SLEEP1 = 10 , SLEEP2 = 10 + INTEGER, ALLOCATABLE :: TEND(:,:) + REAL :: DTTST + ! CHARACTER(LEN=3) :: TSFLD, TYPE = 'WNS' + CHARACTER(LEN=3) :: TSFLD, TYPE = 'WND' + CHARACTER(LEN=13) :: TSSTR + !/ + !/ ------------------------------------------------------------------- / + ! 0. Initialization necessary for driver + ! 0.a General I/O: all can start with initialization in wmmdatmd + ! + ! 0.b MPI environment: Here, we use MPI_COMM_WORLD + ! #ifdef W3_MPI - CALL MPI_INIT ( IERR_MPI ) - MPI_COMM = MPI_COMM_WORLD - CALL MPI_COMM_SIZE ( MPI_COMM, NMPROC, IERR_MPI ) - CALL MPI_COMM_RANK ( MPI_COMM, IMPROC, IERR_MPI ) - IMPROC = IMPROC + 1 + CALL MPI_INIT ( IERR_MPI ) + MPI_COMM = MPI_COMM_WORLD + CALL MPI_COMM_SIZE ( MPI_COMM, NMPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 #endif -! -! 0.c Identifying output to "screen" unit -! - IF ( IMPROC .EQ. NMPSCR ) WRITE (*,900) -! -!/ ------------------------------------------------------------------- / -! 1. Initialization of all wave models / grids -! Use only one of the calls .... -! -! ... Log and screen output, no separate test output file -! -! CALL WMINIT ( 8, 9, 6, 6, 6, 'ww3_multi.inp', MPI_COMM ) -! -! ... Screen output disabled -! -! CALL WMINIT ( 8, 9, 9, 6, 6, 'ww3_multi.inp', MPI_COMM ) -! -! ... Separate test output file and file preamble defined -! -! CALL WMINIT ( 8, 9, 6, 10, 6, 'ww3_multi.inp', MPI_COMM, & -! './data/' ) -! -! ... Separate test output file -! - CALL WMINIT ( 8, 9, 6, 10, 6, 'ww3_multi.inp', MPI_COMM ) -! -!/ ------------------------------------------------------------------- / -! 2. Setting up test files -! - CALL WMUGET ( MDSE, MDST, NDST1, 'INP' ) - CALL WMUSET ( MDSE, MDST, NDST1, .TRUE., 'I/O', & - NAME='times.inp', & - DESC='times file for sbs driver' ) - OPEN (NDST1,FILE='times.inp',STATUS='OLD',ERR=820,IOSTAT=IERR) + ! + ! 0.c Identifying output to "screen" unit + ! + IF ( IMPROC .EQ. NMPSCR ) WRITE (*,900) + ! + !/ ------------------------------------------------------------------- / + ! 1. Initialization of all wave models / grids + ! Use only one of the calls .... + ! + ! ... Log and screen output, no separate test output file + ! + ! CALL WMINIT ( 8, 9, 6, 6, 6, 'ww3_multi.inp', MPI_COMM ) + ! + ! ... Screen output disabled + ! + ! CALL WMINIT ( 8, 9, 9, 6, 6, 'ww3_multi.inp', MPI_COMM ) + ! + ! ... Separate test output file and file preamble defined + ! + ! CALL WMINIT ( 8, 9, 6, 10, 6, 'ww3_multi.inp', MPI_COMM, & + ! './data/' ) + ! + ! ... Separate test output file + ! + CALL WMINIT ( 8, 9, 6, 10, 6, 'ww3_multi.inp', MPI_COMM ) + ! + !/ ------------------------------------------------------------------- / + ! 2. Setting up test files + ! + CALL WMUGET ( MDSE, MDST, NDST1, 'INP' ) + CALL WMUSET ( MDSE, MDST, NDST1, .TRUE., 'I/O', & + NAME='times.inp', & + DESC='times file for sbs driver' ) + OPEN (NDST1,FILE='times.inp',STATUS='OLD',ERR=820,IOSTAT=IERR) #ifdef W3_T - WRITE (MDST,9020) + WRITE (MDST,9020) #endif -! - DO I=-1, -NAUXGR, -1 - CALL W3SETG ( I, MDSE, MDST ) - CALL W3SETI ( I, MDSE, MDST ) - IF ( FLWIND ) THEN - IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,920) FILEXT - NXW = NX - NYW = NY - NDST2 = MDSF(I,3) - EXIT - END IF - END DO -! - IF ( NXW .EQ. -1 ) GOTO 825 - IF ( NDST2 .EQ. -1 ) GOTO 825 -! + ! + DO I=-1, -NAUXGR, -1 + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETI ( I, MDSE, MDST ) + IF ( FLWIND ) THEN + IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,920) FILEXT + NXW = NX + NYW = NY + NDST2 = MDSF(I,3) + EXIT + END IF + END DO + ! + IF ( NXW .EQ. -1 ) GOTO 825 + IF ( NDST2 .EQ. -1 ) GOTO 825 + ! #ifdef W3_T - WRITE (MDST,9021) - WRITE (MDST,9022) NXW, NYW, NDST2, I + WRITE (MDST,9021) + WRITE (MDST,9022) NXW, NYW, NDST2, I #endif -! -!/ ------------------------------------------------------------------- / -! 3. Run the wave model -! 3.a Prepping, initial time stamp -! - ALLOCATE ( TEND(2,NRGRD) ) -! - CALL RDTIME ( NDST1, TNEXT ) + ! + !/ ------------------------------------------------------------------- / + ! 3. Run the wave model + ! 3.a Prepping, initial time stamp + ! + ALLOCATE ( TEND(2,NRGRD) ) + ! + CALL RDTIME ( NDST1, TNEXT ) + IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,930) TNEXT + ! + ! 3.b Catch up with starting time as needed + ! + DO + TOLD = TNEXT + CALL RDTIME ( NDST1, TNEXT ) + DTTST = DSEC21 ( TNEXT , STIME ) + IF ( DTTST .GT. 0. ) THEN IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,930) TNEXT -! -! 3.b Catch up with starting time as needed -! - DO - TOLD = TNEXT - CALL RDTIME ( NDST1, TNEXT ) - DTTST = DSEC21 ( TNEXT , STIME ) - IF ( DTTST .GT. 0. ) THEN - IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,930) TNEXT - ELSE IF ( DTTST .EQ. 0. ) THEN - IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,930) TNEXT - EXIT - ELSE - BACKSPACE NDST1 - TNEXT = TOLD - EXIT - END IF - END DO -! -! 3.c Test readig of initial fields -! - CALL RDWIND ( NDST2, TNEXT, NXW, NYW, .FALSE. ) -! -! 3.d Loop to run the model -! - DO -! - CALL RDTIME ( NDST1, TNEXT ) - IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,930) TNEXT - CALL RDWIND ( NDST2, TNEXT, NXW, NYW, .TRUE. ) - IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,931) -! - DTTST = DSEC21 ( TNEXT , ETIME ) - IF ( DTTST .LT. 0. ) THEN - TNEXT = ETIME - DTTST = 0. - END IF -! - DO I=1, NRGRD - TEND(:,I) = TNEXT(:) - END DO -! + ELSE IF ( DTTST .EQ. 0. ) THEN + IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,930) TNEXT + EXIT + ELSE + BACKSPACE NDST1 + TNEXT = TOLD + EXIT + END IF + END DO + ! + ! 3.c Test readig of initial fields + ! + CALL RDWIND ( NDST2, TNEXT, NXW, NYW, .FALSE. ) + ! + ! 3.d Loop to run the model + ! + DO + ! + CALL RDTIME ( NDST1, TNEXT ) + IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,930) TNEXT + CALL RDWIND ( NDST2, TNEXT, NXW, NYW, .TRUE. ) + IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,931) + ! + DTTST = DSEC21 ( TNEXT , ETIME ) + IF ( DTTST .LT. 0. ) THEN + TNEXT = ETIME + DTTST = 0. + END IF + ! + DO I=1, NRGRD + TEND(:,I) = TNEXT(:) + END DO + ! #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) #endif - CALL WMWAVE ( TEND ) -! - DTTST = DSEC21 ( TNEXT , ETIME ) - IF ( DTTST .LE. 0 ) EXIT -! - END DO -! - DEALLOCATE ( TEND ) -! -!/ ------------------------------------------------------------------- / -! 4. Finalize the wave model -! - CALL WMFINL -! -!/ ------------------------------------------------------------------- / -! 5 Finalize the driver -! - IF ( IMPROC .EQ. NMPSCR ) WRITE (*,999) -! + CALL WMWAVE ( TEND ) + ! + DTTST = DSEC21 ( TNEXT , ETIME ) + IF ( DTTST .LE. 0 ) EXIT + ! + END DO + ! + DEALLOCATE ( TEND ) + ! + !/ ------------------------------------------------------------------- / + ! 4. Finalize the wave model + ! + CALL WMFINL + ! + !/ ------------------------------------------------------------------- / + ! 5 Finalize the driver + ! + IF ( IMPROC .EQ. NMPSCR ) WRITE (*,999) + ! #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) - CALL MPI_FINALIZE ( IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) + CALL MPI_FINALIZE ( IERR_MPI ) #endif -! - GO TO 888 -! - 820 CONTINUE - WRITE (MDSS,1020) IERR - CALL EXTCDE ( 20 ) -! - 825 CONTINUE - WRITE (MDSS,1025) NDST2 - CALL EXTCDE ( 25 ) -! - 888 CONTINUE -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Multi-grid shell *** '/ & - 15X,'================================================='/& - 15X,' side-by-side version'/) -! - 920 FORMAT ( ' WIND DATA FILE USED IS wind.',A) - 930 FORMAT (/' WIND DATA FOUND AT TIME : ',I8.8,1X,I6.6) - 931 FORMAT (' ') -! - 999 FORMAT (//' End of program '/ & - ' ========================================'/ & - ' WAVEWATCH III Multi-grid shell '/) -! - 1020 FORMAT (/' *** WAVEWATCH-III ERROR IN W3SBS1 : '/ & - ' ERROR IN OPENING TIMES FILE'/ & - ' IOSTAT =',I5/) -! - 1025 FORMAT (/' *** WAVEWATCH-III ERROR IN W3SBS1 : '/ & - ' WIND FILE NOT FOUND, NDST2 = ',I8/) -! + ! + GO TO 888 + ! +820 CONTINUE + WRITE (MDSS,1020) IERR + CALL EXTCDE ( 20 ) + ! +825 CONTINUE + WRITE (MDSS,1025) NDST2 + CALL EXTCDE ( 25 ) + ! +888 CONTINUE + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Multi-grid shell *** '/ & + 15X,'================================================='/& + 15X,' side-by-side version'/) + ! +920 FORMAT ( ' WIND DATA FILE USED IS wind.',A) +930 FORMAT (/' WIND DATA FOUND AT TIME : ',I8.8,1X,I6.6) +931 FORMAT (' ') + ! +999 FORMAT (//' End of program '/ & + ' ========================================'/ & + ' WAVEWATCH III Multi-grid shell '/) + ! +1020 FORMAT (/' *** WAVEWATCH-III ERROR IN W3SBS1 : '/ & + ' ERROR IN OPENING TIMES FILE'/ & + ' IOSTAT =',I5/) + ! +1025 FORMAT (/' *** WAVEWATCH-III ERROR IN W3SBS1 : '/ & + ' WIND FILE NOT FOUND, NDST2 = ',I8/) + ! #ifdef W3_T - 9020 FORMAT ( ' TEST W3SBS1: TIMES FILE SUCCESSFULLY OPENED') - 9021 FORMAT ( ' TEST W3SBS1: WINDS FILE SUCCESSFULLY OPENED') - 9022 FORMAT ( ' TEST DATA : ',2I8,2I4) +9020 FORMAT ( ' TEST W3SBS1: TIMES FILE SUCCESSFULLY OPENED') +9021 FORMAT ( ' TEST W3SBS1: WINDS FILE SUCCESSFULLY OPENED') +9022 FORMAT ( ' TEST DATA : ',2I8,2I4) #endif -!/ -!/ Internal subroutines RDTIME and RDWIND ---------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / -!> -!> @brief Internal subroutine to get next time in time file. -!> -!> @details Including wait until file is there. -!> -!> @param[in] NDS Unit number for times file. -!> @param[out] TIME Next time in times file. -!> -!> @author H. L. Tolman @date 05-Dec-2012 -!> - SUBROUTINE RDTIME ( NDS, TIME ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 05-Dec-2012 ! -!/ +-----------------------------------+ -!/ -!/ 10-Aug-2010 : Origination. ( version 3.14.4 ) -!/ 05-Dec-2012 : Making sleep a system call. ( version 4.11 ) -!/ -! 1. Purpose : -! -! Internal subroutine to get next time in time file, including -! waiting until the file is there. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Unit number for times file. -! TIME I.A. O Next time in times file. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS - INTEGER, INTENT(OUT) :: TIME(2) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ Internal subroutines RDTIME and RDWIND ---------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + !> + !> @brief Internal subroutine to get next time in time file. + !> + !> @details Including wait until file is there. + !> + !> @param[in] NDS Unit number for times file. + !> @param[out] TIME Next time in times file. + !> + !> @author H. L. Tolman @date 05-Dec-2012 + !> + SUBROUTINE RDTIME ( NDS, TIME ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 05-Dec-2012 ! + !/ +-----------------------------------+ + !/ + !/ 10-Aug-2010 : Origination. ( version 3.14.4 ) + !/ 05-Dec-2012 : Making sleep a system call. ( version 4.11 ) + !/ + ! 1. Purpose : + ! + ! Internal subroutine to get next time in time file, including + ! waiting until the file is there. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Unit number for times file. + ! TIME I.A. O Next time in times file. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS + INTEGER, INTENT(OUT) :: TIME(2) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_SBS - CHARACTER(LEN=10) :: COMMAND + CHARACTER(LEN=10) :: COMMAND #endif -!/ -! -------------------------------------------------------------------- / -! 1. Reading loop -! - DO -! - READ (NDS,910,END=110,ERR=810,IOSTAT=IERR) TIME - EXIT -! - 110 CONTINUE - IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS, 911 ) - BACKSPACE NDS -! + !/ + ! -------------------------------------------------------------------- / + ! 1. Reading loop + ! + DO + ! + READ (NDS,910,END=110,ERR=810,IOSTAT=IERR) TIME + EXIT + ! +110 CONTINUE + IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS, 911 ) + BACKSPACE NDS + ! #ifdef W3_SBS - WRITE (COMMAND,'(A5,1X,I4)') 'sleep ', SLEEP1 - CALL SYSTEM ( COMMAND ) + WRITE (COMMAND,'(A5,1X,I4)') 'sleep ', SLEEP1 + CALL SYSTEM ( COMMAND ) #endif -! - END DO -! - RETURN -! -! Escape locations read errors --------------------------------------- * -! - 810 CONTINUE - WRITE (MDSS,1010) IERR - CALL EXTCDE ( 10 ) -! -! Formats -! - 910 FORMAT (1X,I8,1X,I6) -! - 911 FORMAT (/' END OF TIMES FILE REACHED FOR WIND DATA '/ & - ' WAITING BEFORE CHECKING AGAIN') -! - 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3SBS1/RDTIME : '/ & - ' ERROR IN OPENING TIMES FILE'/ & - ' IOSTAT =',I5/) -!/ -!/ End of RDTIME ----------------------------------------------------- / -!/ - END SUBROUTINE RDTIME -!/ ------------------------------------------------------------------- / -!> -!> @brief Internal subroutine to test readnext wind fields from the data -!> file. -!> -!> @details Including testing to see if file was read properly. -!> -!> @param[in] NDS Unit number for times file. -!> @param[in] TIME Next time in times file. -!> @param[in] NX Grid size in X -!> @param[in] NY Grid size in Y -!> @param[in] REWIND Flag for wind file rewind -!> -!> @author H. L. Tolman @date 05-Dec-2012 -!> - SUBROUTINE RDWIND ( NDS, TIME, NX, NY, REWIND ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 05-Dec-2012 ! -!/ +-----------------------------------+ -!/ -!/ 10-Aug-2010 : Origination. ( version 3.14.4 ) -!/ 05-Dec-2012 : Making sleep a system call. ( version 4.11 ) -!/ -! 1. Purpose : -! -! Internal subroutine to test readnext wind fields from the data -! file, including testing to see if file was read properly. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Unit number for times file. -! TIME I.A. I Next time in times file. -! NX,NY Int. I Grid size. -! REWIND Log. I Flag for wind file rewind. -! ---------------------------------------------------------------- -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, TIME(2), NX, NY - LOGICAL, INTENT(IN) :: REWIND -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: TTIME(2), IX, IY - INTEGER, SAVE :: NREW = 0 - REAL :: DTTST, XXX(NX,NY) + ! + END DO + ! + RETURN + ! + ! Escape locations read errors --------------------------------------- * + ! +810 CONTINUE + WRITE (MDSS,1010) IERR + CALL EXTCDE ( 10 ) + ! + ! Formats + ! +910 FORMAT (1X,I8,1X,I6) + ! +911 FORMAT (/' END OF TIMES FILE REACHED FOR WIND DATA '/ & + ' WAITING BEFORE CHECKING AGAIN') + ! +1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3SBS1/RDTIME : '/ & + ' ERROR IN OPENING TIMES FILE'/ & + ' IOSTAT =',I5/) + !/ + !/ End of RDTIME ----------------------------------------------------- / + !/ + END SUBROUTINE RDTIME + !/ ------------------------------------------------------------------- / + !> + !> @brief Internal subroutine to test readnext wind fields from the data + !> file. + !> + !> @details Including testing to see if file was read properly. + !> + !> @param[in] NDS Unit number for times file. + !> @param[in] TIME Next time in times file. + !> @param[in] NX Grid size in X + !> @param[in] NY Grid size in Y + !> @param[in] REWIND Flag for wind file rewind + !> + !> @author H. L. Tolman @date 05-Dec-2012 + !> + SUBROUTINE RDWIND ( NDS, TIME, NX, NY, REWIND ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 05-Dec-2012 ! + !/ +-----------------------------------+ + !/ + !/ 10-Aug-2010 : Origination. ( version 3.14.4 ) + !/ 05-Dec-2012 : Making sleep a system call. ( version 4.11 ) + !/ + ! 1. Purpose : + ! + ! Internal subroutine to test readnext wind fields from the data + ! file, including testing to see if file was read properly. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Unit number for times file. + ! TIME I.A. I Next time in times file. + ! NX,NY Int. I Grid size. + ! REWIND Log. I Flag for wind file rewind. + ! ---------------------------------------------------------------- + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, TIME(2), NX, NY + LOGICAL, INTENT(IN) :: REWIND + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: TTIME(2), IX, IY + INTEGER, SAVE :: NREW = 0 + REAL :: DTTST, XXX(NX,NY) #ifdef W3_SBS - CHARACTER(LEN=10) :: COMMAND + CHARACTER(LEN=10) :: COMMAND #endif -! -! -------------------------------------------------------------------- / -! 1. Loops -! + ! + ! -------------------------------------------------------------------- / + ! 1. Loops + ! + DO + ! + ! ... Inner loop reading + ! DO -! -! ... Inner loop reading -! - DO -! - NREW = NREW + 1 - READ (NDS,END=140,ERR=140) TTIME + ! + NREW = NREW + 1 + READ (NDS,END=140,ERR=140) TTIME #ifdef W3_T - WRITE (MDST,9000) TTIME + WRITE (MDST,9000) TTIME #endif -! - NREW = NREW + 1 - READ (NDS,END=130,ERR=130) ((XXX(IX,IY),IX=1,NX),IY=1,NY) + ! + NREW = NREW + 1 + READ (NDS,END=130,ERR=130) ((XXX(IX,IY),IX=1,NX),IY=1,NY) #ifdef W3_T - WRITE (MDST,9001) 'U' + WRITE (MDST,9001) 'U' #endif -! - NREW = NREW + 1 - READ (NDS,END=120,ERR=120) ((XXX(IX,IY),IX=1,NX),IY=1,NY) + ! + NREW = NREW + 1 + READ (NDS,END=120,ERR=120) ((XXX(IX,IY),IX=1,NX),IY=1,NY) #ifdef W3_T - WRITE (MDST,9001) 'V' + WRITE (MDST,9001) 'V' #endif -! - IF ( TYPE .EQ. 'WNS' ) THEN - NREW = NREW + 1 - READ (NDS,END=110,ERR=110) ((XXX(IX,IY),IX=1,NX),IY=1,NY) + ! + IF ( TYPE .EQ. 'WNS' ) THEN + NREW = NREW + 1 + READ (NDS,END=110,ERR=110) ((XXX(IX,IY),IX=1,NX),IY=1,NY) #ifdef W3_T - WRITE (MDST,9001) 'DT' + WRITE (MDST,9001) 'DT' #endif - END IF -! - EXIT -! - 110 CONTINUE - BACKSPACE NDS - NREW = NREW - 1 - 120 CONTINUE - BACKSPACE NDS - NREW = NREW - 1 - 130 CONTINUE - BACKSPACE NDS - NREW = NREW - 1 - 140 CONTINUE - BACKSPACE NDS - NREW = NREW - 1 -! - IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,900) -! + END IF + ! + EXIT + ! +110 CONTINUE + BACKSPACE NDS + NREW = NREW - 1 +120 CONTINUE + BACKSPACE NDS + NREW = NREW - 1 +130 CONTINUE + BACKSPACE NDS + NREW = NREW - 1 +140 CONTINUE + BACKSPACE NDS + NREW = NREW - 1 + ! + IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,900) + ! #ifdef W3_SBS - WRITE (COMMAND,'(A5,1X,I4)') 'sleep ', SLEEP2 - CALL SYSTEM ( COMMAND ) + WRITE (COMMAND,'(A5,1X,I4)') 'sleep ', SLEEP2 + CALL SYSTEM ( COMMAND ) #endif -! - END DO -! -! ... Outer loop catching up -! - DTTST = DSEC21 ( TIME , TTIME ) -! - IF ( DTTST .LT. 0. ) THEN - IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,901) TTIME - ELSE IF ( DTTST .EQ. 0. ) THEN - EXIT - ELSE - GOTO 800 - END IF -! - END DO -! -! ... Rewind all -! - IF ( REWIND ) THEN -! - IF ( IMPROC.EQ.NMPSCR .AND. NREW.GT.4 ) WRITE (MDSS,902) NREW -! - DO I=1, NREW - BACKSPACE NDS - END DO -! - NREW = 0 -! - END IF -! - RETURN -! -! Escape locations read errors --------------------------------------- * -! - 800 CONTINUE - WRITE (MDSS,1010) - CALL EXTCDE ( 10 ) -! -! Formats -! - 900 FORMAT (' FILE NOT YET COMPLETE ... ') - 901 FORMAT (' SKIPPING FILE FOR ',I8.8,I7.6) - 902 FORMAT (' REWINDING FILE BY ',I4,' RECORDS') -! - 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3SBS1/RDWIND : '/ & - ' FILE READ PAST EXPECTED TIME '/) -! + ! + END DO + ! + ! ... Outer loop catching up + ! + DTTST = DSEC21 ( TIME , TTIME ) + ! + IF ( DTTST .LT. 0. ) THEN + IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,901) TTIME + ELSE IF ( DTTST .EQ. 0. ) THEN + EXIT + ELSE + GOTO 800 + END IF + ! + END DO + ! + ! ... Rewind all + ! + IF ( REWIND ) THEN + ! + IF ( IMPROC.EQ.NMPSCR .AND. NREW.GT.4 ) WRITE (MDSS,902) NREW + ! + DO I=1, NREW + BACKSPACE NDS + END DO + ! + NREW = 0 + ! + END IF + ! + RETURN + ! + ! Escape locations read errors --------------------------------------- * + ! +800 CONTINUE + WRITE (MDSS,1010) + CALL EXTCDE ( 10 ) + ! + ! Formats + ! +900 FORMAT (' FILE NOT YET COMPLETE ... ') +901 FORMAT (' SKIPPING FILE FOR ',I8.8,I7.6) +902 FORMAT (' REWINDING FILE BY ',I4,' RECORDS') + ! +1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3SBS1/RDWIND : '/ & + ' FILE READ PAST EXPECTED TIME '/) + ! #ifdef W3_T - 9000 FORMAT ( ' TEST RDWIND: TIME READ ',I8.8,1X,I6.6) - 9001 FORMAT ( ' FIELD READ ',A) +9000 FORMAT ( ' TEST RDWIND: TIME READ ',I8.8,1X,I6.6) +9001 FORMAT ( ' FIELD READ ',A) #endif -!/ -!/ End of RDWIND ----------------------------------------------------- / -!/ - END SUBROUTINE RDWIND -!/ -!/ End of W3SBS1 ----------------------------------------------------- / -!/ - END PROGRAM W3SBS1 + !/ + !/ End of RDWIND ----------------------------------------------------- / + !/ + END SUBROUTINE RDWIND + !/ + !/ End of W3SBS1 ----------------------------------------------------- / + !/ +END PROGRAM W3SBS1 diff --git a/model/src/ww3_shel.F90 b/model/src/ww3_shel.F90 index 89e029357..126db5329 100644 --- a/model/src/ww3_shel.F90 +++ b/model/src/ww3_shel.F90 @@ -13,1378 +13,1378 @@ !> !> @author H. L. Tolman @date 22-Mar-2021 ! - PROGRAM W3SHEL -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 19-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 19-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 08-Mar-2000 : Fix time managament bug. ( version 2.04 ) -!/ 09-Jan-2001 : Fix FOUT allocation bug. ( version 2.05 ) -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 25-Jan-2002 : Data assimilation set up. ( version 2.17 ) -!/ 08-May-2002 : Clean up for timers. ( version 2.21 ) -!/ 26-Aug-2002 : Generalizing timer. ( version 2.22 ) -!/ 26-Dec-2002 : Continuously moving grid. ( version 3.02 ) -!/ 01-Aug-2003 : Continuously moving grid, input. ( version 3.03 ) -!/ 07-Oct-2003 : Fixed NHMAX test. ( version 3.05 ) -!/ 05-Jan-2005 : Multiple grid version. ( version 3.06 ) -!/ 04-May-2005 : Change to MPI_COMM[_WAVE. ( version 3.07 ) -!/ 26-Jun-2006 : Add wiring for output type 6. ( version 3.07 ) -!/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 28-Oct-2006 : Adding partitioning options. ( version 3.10 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Fix format statement 2945. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 13-Sep-2009 : Add coupling option ( version 3.14_SHOM ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) -!/ (A. Roland and F. Ardhuin) -!/ 23-Nov-2011 : Comments clean up ( version 4.04 ) -!/ 06-Mar-2012 : Repairing test output. ( version 4.07 ) -!/ 03-Sep-2012 : Output initialization time. ( version 4.10 ) -!/ 27-Sep-2012 : Implement use of tidal constituents ( version 4.08 ) -!/ 04-Feb-2014 : Switched clock to DATE_AND_TIME ( version 4.18 ) -!/ (A. Chawla and Mark Szyszka) -!/ 23-Apr-2015 : Adding NCEP Coupler ( version 5.06 ) -!/ (A. Chawla and Dmitry Sheinin) -!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) -!/ (M. Accensi & F. Ardhuin, IFREMER) -!/ 11-May-2015 : Checks dates for output types ( version 5.08 ) -!/ 26-Mar-2018 : Sea-point only Wnd/Cur input. JGLi ( version 6.02 ) -!/ 15-May-2018 : Update namelist ( version 6.05 ) -!/ 06-Jun-2018 : Add PDLIB/MEMCHECK/NETCDF_QAD/DEBUGINIT ( version 6.04 ) -!/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) -!/ 04-Oct-2019 : Inline Output implementation ( version 6.07 ) -!/ (Roberto Padilla-Hernandez) -!/ 16-Jul-2020 : Variable coupling time step ( version 7.08 ) -!/ 25-Sep-2020 : Oasis coupling at T+0 ( version 7.10 ) -!/ 22-Mar-2021 : Add new coupling fields ( version 7.13 ) -!/ 07-Jun-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.13 ) -!/ 02-Feb-2022 : Scalability local ( version 7.14 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! A generic shell for WAVEWATCH III, using preformatted -! input fields. -! -! 2. Method : -! -! Driver for the actual wave model (W3WAVE). -! -! Files : ww3_shel.inp Input commands for shell. -! level.ww3 Water level fields (optional). -! current.ww3 Current fields (optional). -! wind.ww3 Wind fields (optional). -! muddens.ww3 Mud parameter (optional) -! mudthk.ww3 Mud parameter (optional) -! mudvisc.ww3 Mud parameter (optional) -! ice(n).ww3 Ice parameters (n=1 to 5) (optional) -! ice.ww3 ice concentration fields (optional). -! data0.ww3 Files with assimilation data (optional). -! data1.ww3 -! data2.ww3 -! -! The file names of the input files are set in W3FLDO -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! NHMAX I.P. Maximum number of homogeneous fields. -! -! NDSI Int. General input unit number (shell only). -! NDSS Int. Scratch file. -! NDSO Int. General output unit number (shell only). -! NDSE Int. Error output unit number (shell only). -! NDST Int. Test output unit number (shell only). -! NDSF I.A. Field files unit numbers (shell only). -! FLH L.A. Flags for homogeneous fields. -! FLAGSC L.A. Flags for coupling fields -! FLAGSCI Log. Flags for ice ic1 ic5 coupling -! NH I.A. Number of times for homogeneous fields. -! THO I.A. Times of homogeneous fields. -! TIME0 I.A. Starting time. -! TIMEN I.A. Ending time. -! ---------------------------------------------------------------- -! -! NDS, NTRACE, ..., see W3WAVE -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set nummber of data structures -! W3SETG Subr. Id. Point to data structure. -! W3NDAT Subr. W3WDATMD Set nummber of data structures -! W3SETW Subr. Id. Point to data structure. -! W3NMOD Subr. W3ADATMD Set nummber of data structures -! W3NAUX Subr. Id. Point to data structure. -! W3NOUT Subr. W3ODATMD Set nummber of data structures -! W3SETO Subr. Id. Point to data structure. -! W3NINP Subr. W3IDATMD Set nummber of data structures -! W3SETI Subr. Id. Point to data structure. -! -! NEXTLN Subr. W3SERVMD Skip to next input line. -! STME21 Subr. W3TIMEMD Print date and time readable. -! DSEC21 Func. Id. Difference between times. -! TICK21 Subr. Id. Increment time. -! -! W3FLDO Subr. W3FLDSMD Opens and checks input files. -! W3FLDG Subr. Id. Reads from input files. -! W3FLDD Subr. Id. Reads from data files. -! W3FLDH Subr. Id. Udates homogeneous fields. -! -! W3INIT Subr. W3INITMD Wave model initialization. -! W3READFLGRD Subr. W3IOGOMD Reading output fields flags. -! W3WAVE Subr. W3WAVEMD Wave model. -! W3WDAS Subr. W3WDASMD Data assimilation interface. -! -! MPI_INIT, MPI_COMM_SIZE, MPI_COMM_RANK, MPI_BARRIER, -! MPI_FINALIZE -! Subr. Standard MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! - Checks on I-O. -! - Check on time interval. -! -! 7. Remarks : -! -! - A rigourous input check is made in W3INIT. -! - See W3WDAS for documentation on the set-up of the data -! assimilation. -! - in "7.a.2 Check if update is needed" -! Field is updated when compute time is past old input time, and -! (in case of homogeneous input field), grabs field value at next -! input time, which may in fact be far in the future from current -! compute time. Example: user says -! field=1 on 19680101 000000 and -! field=100 on 20160101 000000 -! then on if 7.a.2 is reached on 19680101 010000, WW3 will set -! field to 100. -! -! 8. Structure : -! -! ---------------------------------------------------------------- -! 0. Set up data structures. ( W3NMOD, etc. ) -! 1. I-O setup. -! a For shell. -! b For WAVEWATCH III. -! c Local parameters. -! 2. Define input fields -! 3. Set time frame. -! 4. Define output -! a Loop over types, do -! +--------------------------------------------------------+ -! | b Process standard line | -! | c If type 1: fields of mean wave parameters | -! | d If type 2: point output | -! | e If type 3: track output | -! | f If type 4: restart files | -! | g If type 5: boundary output | -! | h If type 6: separated wave fields | -! | i If type 7: coupling fields | -! +--------------------------------------------------------+ -! 5. Initialzations -! a Wave model. ( W3INIT ) -! b Read homogeneous field data. -! c Prepare input files. ( W3FLDO ) -! d Set field times. -! 6. If no input fields required, run model in a single -! sweep and exit. ( W3WAVE ) -! 7. Run model with input -! Do until end time is reached -! +--------------------------------------------------------+ -! | a Determine next time interval and input fields. | -! | 1 Preparation | -! | Loop over input fields | -! | +------------------------------------------------------| -! | | 2 Check if update is needed | -! | | 3 Update time and fields ( W3FLDG ) | -! | | ( W3FLDH ) | -! | | 4 Update next ending time | -! | +------------------------------------------------------| -! | b Run wave model. ( W3WAVE ) | -! | c If requested, data assimilation. ( W3WDAS ) | -! | d Final output if needed. ( W3WAVE ) | -! | e Check time | -! +--------------------------------------------------------+ -! ---------------------------------------------------------------- -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/MGW Moving grid wind correction. -! !/MGP Moving grid propagation correction. -! -! !/T Enable test output. -! !/O7 Echo input homogeneous fields. -! -! !/NCO NCEP NCO modifications for operational implementation. -! -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / +PROGRAM W3SHEL + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 19-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 19-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 08-Mar-2000 : Fix time managament bug. ( version 2.04 ) + !/ 09-Jan-2001 : Fix FOUT allocation bug. ( version 2.05 ) + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 25-Jan-2002 : Data assimilation set up. ( version 2.17 ) + !/ 08-May-2002 : Clean up for timers. ( version 2.21 ) + !/ 26-Aug-2002 : Generalizing timer. ( version 2.22 ) + !/ 26-Dec-2002 : Continuously moving grid. ( version 3.02 ) + !/ 01-Aug-2003 : Continuously moving grid, input. ( version 3.03 ) + !/ 07-Oct-2003 : Fixed NHMAX test. ( version 3.05 ) + !/ 05-Jan-2005 : Multiple grid version. ( version 3.06 ) + !/ 04-May-2005 : Change to MPI_COMM[_WAVE. ( version 3.07 ) + !/ 26-Jun-2006 : Add wiring for output type 6. ( version 3.07 ) + !/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 28-Oct-2006 : Adding partitioning options. ( version 3.10 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Fix format statement 2945. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 13-Sep-2009 : Add coupling option ( version 3.14_SHOM ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) + !/ (A. Roland and F. Ardhuin) + !/ 23-Nov-2011 : Comments clean up ( version 4.04 ) + !/ 06-Mar-2012 : Repairing test output. ( version 4.07 ) + !/ 03-Sep-2012 : Output initialization time. ( version 4.10 ) + !/ 27-Sep-2012 : Implement use of tidal constituents ( version 4.08 ) + !/ 04-Feb-2014 : Switched clock to DATE_AND_TIME ( version 4.18 ) + !/ (A. Chawla and Mark Szyszka) + !/ 23-Apr-2015 : Adding NCEP Coupler ( version 5.06 ) + !/ (A. Chawla and Dmitry Sheinin) + !/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) + !/ (M. Accensi & F. Ardhuin, IFREMER) + !/ 11-May-2015 : Checks dates for output types ( version 5.08 ) + !/ 26-Mar-2018 : Sea-point only Wnd/Cur input. JGLi ( version 6.02 ) + !/ 15-May-2018 : Update namelist ( version 6.05 ) + !/ 06-Jun-2018 : Add PDLIB/MEMCHECK/NETCDF_QAD/DEBUGINIT ( version 6.04 ) + !/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) + !/ 04-Oct-2019 : Inline Output implementation ( version 6.07 ) + !/ (Roberto Padilla-Hernandez) + !/ 16-Jul-2020 : Variable coupling time step ( version 7.08 ) + !/ 25-Sep-2020 : Oasis coupling at T+0 ( version 7.10 ) + !/ 22-Mar-2021 : Add new coupling fields ( version 7.13 ) + !/ 07-Jun-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.13 ) + !/ 02-Feb-2022 : Scalability local ( version 7.14 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! A generic shell for WAVEWATCH III, using preformatted + ! input fields. + ! + ! 2. Method : + ! + ! Driver for the actual wave model (W3WAVE). + ! + ! Files : ww3_shel.inp Input commands for shell. + ! level.ww3 Water level fields (optional). + ! current.ww3 Current fields (optional). + ! wind.ww3 Wind fields (optional). + ! muddens.ww3 Mud parameter (optional) + ! mudthk.ww3 Mud parameter (optional) + ! mudvisc.ww3 Mud parameter (optional) + ! ice(n).ww3 Ice parameters (n=1 to 5) (optional) + ! ice.ww3 ice concentration fields (optional). + ! data0.ww3 Files with assimilation data (optional). + ! data1.ww3 + ! data2.ww3 + ! + ! The file names of the input files are set in W3FLDO + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! NHMAX I.P. Maximum number of homogeneous fields. + ! + ! NDSI Int. General input unit number (shell only). + ! NDSS Int. Scratch file. + ! NDSO Int. General output unit number (shell only). + ! NDSE Int. Error output unit number (shell only). + ! NDST Int. Test output unit number (shell only). + ! NDSF I.A. Field files unit numbers (shell only). + ! FLH L.A. Flags for homogeneous fields. + ! FLAGSC L.A. Flags for coupling fields + ! FLAGSCI Log. Flags for ice ic1 ic5 coupling + ! NH I.A. Number of times for homogeneous fields. + ! THO I.A. Times of homogeneous fields. + ! TIME0 I.A. Starting time. + ! TIMEN I.A. Ending time. + ! ---------------------------------------------------------------- + ! + ! NDS, NTRACE, ..., see W3WAVE + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set nummber of data structures + ! W3SETG Subr. Id. Point to data structure. + ! W3NDAT Subr. W3WDATMD Set nummber of data structures + ! W3SETW Subr. Id. Point to data structure. + ! W3NMOD Subr. W3ADATMD Set nummber of data structures + ! W3NAUX Subr. Id. Point to data structure. + ! W3NOUT Subr. W3ODATMD Set nummber of data structures + ! W3SETO Subr. Id. Point to data structure. + ! W3NINP Subr. W3IDATMD Set nummber of data structures + ! W3SETI Subr. Id. Point to data structure. + ! + ! NEXTLN Subr. W3SERVMD Skip to next input line. + ! STME21 Subr. W3TIMEMD Print date and time readable. + ! DSEC21 Func. Id. Difference between times. + ! TICK21 Subr. Id. Increment time. + ! + ! W3FLDO Subr. W3FLDSMD Opens and checks input files. + ! W3FLDG Subr. Id. Reads from input files. + ! W3FLDD Subr. Id. Reads from data files. + ! W3FLDH Subr. Id. Udates homogeneous fields. + ! + ! W3INIT Subr. W3INITMD Wave model initialization. + ! W3READFLGRD Subr. W3IOGOMD Reading output fields flags. + ! W3WAVE Subr. W3WAVEMD Wave model. + ! W3WDAS Subr. W3WDASMD Data assimilation interface. + ! + ! MPI_INIT, MPI_COMM_SIZE, MPI_COMM_RANK, MPI_BARRIER, + ! MPI_FINALIZE + ! Subr. Standard MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! - Checks on I-O. + ! - Check on time interval. + ! + ! 7. Remarks : + ! + ! - A rigourous input check is made in W3INIT. + ! - See W3WDAS for documentation on the set-up of the data + ! assimilation. + ! - in "7.a.2 Check if update is needed" + ! Field is updated when compute time is past old input time, and + ! (in case of homogeneous input field), grabs field value at next + ! input time, which may in fact be far in the future from current + ! compute time. Example: user says + ! field=1 on 19680101 000000 and + ! field=100 on 20160101 000000 + ! then on if 7.a.2 is reached on 19680101 010000, WW3 will set + ! field to 100. + ! + ! 8. Structure : + ! + ! ---------------------------------------------------------------- + ! 0. Set up data structures. ( W3NMOD, etc. ) + ! 1. I-O setup. + ! a For shell. + ! b For WAVEWATCH III. + ! c Local parameters. + ! 2. Define input fields + ! 3. Set time frame. + ! 4. Define output + ! a Loop over types, do + ! +--------------------------------------------------------+ + ! | b Process standard line | + ! | c If type 1: fields of mean wave parameters | + ! | d If type 2: point output | + ! | e If type 3: track output | + ! | f If type 4: restart files | + ! | g If type 5: boundary output | + ! | h If type 6: separated wave fields | + ! | i If type 7: coupling fields | + ! +--------------------------------------------------------+ + ! 5. Initialzations + ! a Wave model. ( W3INIT ) + ! b Read homogeneous field data. + ! c Prepare input files. ( W3FLDO ) + ! d Set field times. + ! 6. If no input fields required, run model in a single + ! sweep and exit. ( W3WAVE ) + ! 7. Run model with input + ! Do until end time is reached + ! +--------------------------------------------------------+ + ! | a Determine next time interval and input fields. | + ! | 1 Preparation | + ! | Loop over input fields | + ! | +------------------------------------------------------| + ! | | 2 Check if update is needed | + ! | | 3 Update time and fields ( W3FLDG ) | + ! | | ( W3FLDH ) | + ! | | 4 Update next ending time | + ! | +------------------------------------------------------| + ! | b Run wave model. ( W3WAVE ) | + ! | c If requested, data assimilation. ( W3WDAS ) | + ! | d Final output if needed. ( W3WAVE ) | + ! | e Check time | + ! +--------------------------------------------------------+ + ! ---------------------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! + ! !/MGW Moving grid wind correction. + ! !/MGP Moving grid propagation correction. + ! + ! !/T Enable test output. + ! !/O7 Echo input homogeneous fields. + ! + ! !/NCO NCEP NCO modifications for operational implementation. + ! + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_PDLIB - USE CONSTANTS, ONLY: LPDLIB + USE CONSTANTS, ONLY: LPDLIB #endif - USE W3GDATMD - USE W3WDATMD, ONLY: TIME, VA, W3NDAT, W3DIMW, W3SETW + USE W3GDATMD + USE W3WDATMD, ONLY: TIME, VA, W3NDAT, W3DIMW, W3SETW #ifdef W3_OASIS - USE W3WDATMD, ONLY: TIME00, TIMEEND + USE W3WDATMD, ONLY: TIME00, TIMEEND #endif #ifdef W3_NL5 - USE W3WDATMD, ONLY: QI5TBEG + USE W3WDATMD, ONLY: QI5TBEG #endif - USE W3ADATMD, ONLY: W3NAUX, W3DIMA, W3SETA + USE W3ADATMD, ONLY: W3NAUX, W3DIMA, W3SETA #ifdef W3_MEMCHECK - USE W3ADATMD, ONLY: MALLINFOS + USE W3ADATMD, ONLY: MALLINFOS #endif - USE W3IDATMD + USE W3IDATMD #ifdef W3_OASIS - USE W3ODATMD, ONLY: DTOUT, FLOUT -#endif - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3ODATMD, ONLY: NAPROC, IAPROC, NAPOUT, NAPERR, NOGRP, & - NGRPP, IDOUT, FNMPRE, IOSTYP, NOTYPE - USE W3ODATMD, ONLY: FLOGRR, FLOGR, OFILES -!/ - USE W3FLDSMD - USE W3INITMD - USE W3WAVEMD - USE W3WDASMD -!/ - USE W3IOGRMD, ONLY: W3IOGR - USE W3IOGOMD, ONLY: W3READFLGRD, FLDOUT, W3FLGRDFLAG - USE W3IORSMD, ONLY: OARST - USE W3IOPOMD - USE W3SERVMD, ONLY : NEXTLN, EXTCDE - USE W3TIMEMD + USE W3ODATMD, ONLY: DTOUT, FLOUT +#endif + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3ODATMD, ONLY: NAPROC, IAPROC, NAPOUT, NAPERR, NOGRP, & + NGRPP, IDOUT, FNMPRE, IOSTYP, NOTYPE + USE W3ODATMD, ONLY: FLOGRR, FLOGR, OFILES + !/ + USE W3FLDSMD + USE W3INITMD + USE W3WAVEMD + USE W3WDASMD + !/ + USE W3IOGRMD, ONLY: W3IOGR + USE W3IOGOMD, ONLY: W3READFLGRD, FLDOUT, W3FLGRDFLAG + USE W3IORSMD, ONLY: OARST + USE W3IOPOMD + USE W3SERVMD, ONLY : NEXTLN, EXTCDE + USE W3TIMEMD #ifdef W3_MEMCHECK - USE MallocInfo_m + USE MallocInfo_m #endif #ifdef W3_OASIS - USE W3OACPMD, ONLY: CPL_OASIS_INIT, CPL_OASIS_GRID, & - CPL_OASIS_DEFINE, CPL_OASIS_FINALIZE, & - ID_OASIS_TIME, CPLT0 + USE W3OACPMD, ONLY: CPL_OASIS_INIT, CPL_OASIS_GRID, & + CPL_OASIS_DEFINE, CPL_OASIS_FINALIZE, & + ID_OASIS_TIME, CPLT0 #endif #ifdef W3_OASOCM - USE W3OGCMMD, ONLY: SND_FIELDS_TO_OCEAN + USE W3OGCMMD, ONLY: SND_FIELDS_TO_OCEAN #endif #ifdef W3_OASACM - USE W3AGCMMD, ONLY: SND_FIELDS_TO_ATMOS + USE W3AGCMMD, ONLY: SND_FIELDS_TO_ATMOS #endif #ifdef W3_OASICM - USE W3IGCMMD, ONLY: SND_FIELDS_TO_ICE + USE W3IGCMMD, ONLY: SND_FIELDS_TO_ICE #endif #ifdef W3_TIDE - USE W3TIDEMD + USE W3TIDEMD #endif -! - USE W3NMLSHELMD - IMPLICIT NONE -! + ! + USE W3NMLSHELMD + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local PARAMETER statements -!/ - INTEGER, PARAMETER :: NHMAX = 200 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(NML_DOMAIN_T) :: NML_DOMAIN - TYPE(NML_INPUT_T) :: NML_INPUT - TYPE(NML_OUTPUT_TYPE_T) :: NML_OUTPUT_TYPE - TYPE(NML_OUTPUT_DATE_T) :: NML_OUTPUT_DATE - TYPE(NML_HOMOG_COUNT_T) :: NML_HOMOG_COUNT - TYPE(NML_HOMOG_INPUT_T), ALLOCATABLE :: NML_HOMOG_INPUT(:) -! - INTEGER :: NDSI, NDSI2, NDSS, NDSO, NDSE, NDST, NDSL,& - NDSEN, IERR, J, I, ILOOP, IPTS, NPTS, & - NDTNEW, MPI_COMM = -99, & - FLAGTIDE, COUPL_COMM, IH, N_TOT - INTEGER :: NDSF(-7:9), NDS(13), NTRACE(2), NDT(7:9), & - TIME0(2), TIMEN(2), TTIME(2), TTT(2), & - NH(-7:10), THO(2,-7:10,NHMAX), RCLD(7:9), & - NODATA(7:9), ODAT(40), IPRT(6) = 0, & - STARTDATE(8), STOPDATE(8), IHH(-7:10) -! + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Local PARAMETER statements + !/ + INTEGER, PARAMETER :: NHMAX = 200 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(NML_DOMAIN_T) :: NML_DOMAIN + TYPE(NML_INPUT_T) :: NML_INPUT + TYPE(NML_OUTPUT_TYPE_T) :: NML_OUTPUT_TYPE + TYPE(NML_OUTPUT_DATE_T) :: NML_OUTPUT_DATE + TYPE(NML_HOMOG_COUNT_T) :: NML_HOMOG_COUNT + TYPE(NML_HOMOG_INPUT_T), ALLOCATABLE :: NML_HOMOG_INPUT(:) + ! + INTEGER :: NDSI, NDSI2, NDSS, NDSO, NDSE, NDST, NDSL,& + NDSEN, IERR, J, I, ILOOP, IPTS, NPTS, & + NDTNEW, MPI_COMM = -99, & + FLAGTIDE, COUPL_COMM, IH, N_TOT + INTEGER :: NDSF(-7:9), NDS(13), NTRACE(2), NDT(7:9), & + TIME0(2), TIMEN(2), TTIME(2), TTT(2), & + NH(-7:10), THO(2,-7:10,NHMAX), RCLD(7:9), & + NODATA(7:9), ODAT(40), IPRT(6) = 0, & + STARTDATE(8), STOPDATE(8), IHH(-7:10) + ! #ifdef W3_OASIS - INTEGER :: OASISED + INTEGER :: OASISED #endif #ifdef W3_COU - INTEGER :: OFL + INTEGER :: OFL #endif - INTEGER :: CLKDT1(8), CLKDT2(8), CLKDT3(8) + INTEGER :: CLKDT1(8), CLKDT2(8), CLKDT3(8) #ifdef W3_MPI - INTEGER :: IERR_MPI -#endif -! - REAL :: FACTOR, DTTST, XX, YY, & - HA(NHMAX,-7:10), HD(NHMAX,-7:10), & - HS(NHMAX,-7:10) - REAL :: CLKFIN, CLKFEL - REAL, ALLOCATABLE :: X(:), Y(:), XXX(:,:), DATA0(:,:), & - DATA1(:,:), DATA2(:,:) -! - DOUBLE PRECISION :: STARTJULDAY, STOPJULDAY -! - CHARACTER(LEN=1) :: COMSTR, FLAGTFC(-7:10) - CHARACTER(LEN=3) :: IDSTR(-7:10), IDTST - CHARACTER(LEN=6) :: YESXNO - CHARACTER(LEN=40) :: PN - CHARACTER(LEN=40), & - ALLOCATABLE :: PNAMES(:) - CHARACTER(LEN=13) :: IDFLDS(-7:10) - CHARACTER(LEN=20) :: STRNG - CHARACTER(LEN=23) :: DTME21 - CHARACTER(LEN=30) :: IDOTYP(8) - CHARACTER(LEN=80) :: LINE - CHARACTER(LEN=256) :: TMPLINE, TEST - CHARACTER(LEN=1024) :: FLDIN - CHARACTER(LEN=1024) :: FLDRST='' - CHARACTER(LEN=80) :: LINEIN - CHARACTER(LEN=8) :: WORDS(7)='' + INTEGER :: IERR_MPI +#endif + ! + REAL :: FACTOR, DTTST, XX, YY, & + HA(NHMAX,-7:10), HD(NHMAX,-7:10), & + HS(NHMAX,-7:10) + REAL :: CLKFIN, CLKFEL + REAL, ALLOCATABLE :: X(:), Y(:), XXX(:,:), DATA0(:,:), & + DATA1(:,:), DATA2(:,:) + ! + DOUBLE PRECISION :: STARTJULDAY, STOPJULDAY + ! + CHARACTER(LEN=1) :: COMSTR, FLAGTFC(-7:10) + CHARACTER(LEN=3) :: IDSTR(-7:10), IDTST + CHARACTER(LEN=6) :: YESXNO + CHARACTER(LEN=40) :: PN + CHARACTER(LEN=40), & + ALLOCATABLE :: PNAMES(:) + CHARACTER(LEN=13) :: IDFLDS(-7:10) + CHARACTER(LEN=20) :: STRNG + CHARACTER(LEN=23) :: DTME21 + CHARACTER(LEN=30) :: IDOTYP(8) + CHARACTER(LEN=80) :: LINE + CHARACTER(LEN=256) :: TMPLINE, TEST + CHARACTER(LEN=1024) :: FLDIN + CHARACTER(LEN=1024) :: FLDRST='' + CHARACTER(LEN=80) :: LINEIN + CHARACTER(LEN=8) :: WORDS(7)='' #ifdef W3_COU - CHARACTER(LEN=30) :: OFILE -#endif -! - LOGICAL :: FLLSTL, FLLSTI, FLLSTR, FLFLG, FLHOM, & - TFLAGI, PRTFRM, FLAGSCI, FLGNML - LOGICAL :: FLGRD(NOGRP,NGRPP), FLGD(NOGRP), & - FLGR2(NOGRP,NGRPP), FLG2(NOGRP), & - FLAGSTIDE(4), FLH(-7:10), FLGDAS(3), & - FLLST_ALL(-7:10) + CHARACTER(LEN=30) :: OFILE +#endif + ! + LOGICAL :: FLLSTL, FLLSTI, FLLSTR, FLFLG, FLHOM, & + TFLAGI, PRTFRM, FLAGSCI, FLGNML + LOGICAL :: FLGRD(NOGRP,NGRPP), FLGD(NOGRP), & + FLGR2(NOGRP,NGRPP), FLG2(NOGRP), & + FLAGSTIDE(4), FLH(-7:10), FLGDAS(3), & + FLLST_ALL(-7:10) #ifdef W3_MPI - LOGICAL :: FLHYBR = .FALSE. + LOGICAL :: FLHYBR = .FALSE. #endif #ifdef W3_OMPH - INTEGER :: THRLEV + INTEGER :: THRLEV #endif #ifdef W3_OASIS - LOGICAL :: L_MASTER -#endif -! -!/ -!/ ------------------------------------------------------------------- / -!/ - DATA IDFLDS / 'ice param. 1 ' , 'ice param. 2 ' , & - 'ice param. 3 ' , 'ice param. 4 ' , & - 'ice param. 5 ' , & - 'mud density ' , 'mud thkness ' , & - 'mud viscos. ' , & - 'water levels ' , 'currents ' , & - 'winds ' , 'ice fields ' , & - 'momentum ' , 'air density ' , & - 'mean param. ' , '1D spectra ' , & - '2D spectra ' , 'moving grid ' / - DATA IDOTYP / 'Fields of mean wave parameters' , & - 'Point output ' , & - 'Track point output ' , & - 'Restart files ' , & - 'Nesting data ' , & - 'Partitioned wave field data ' , & - 'Fields for coupling ' , & - 'Restart files second request '/ - DATA IDSTR / 'IC1', 'IC2', 'IC3', 'IC4', 'IC5', 'MDN', 'MTH', & - 'MVS', 'LEV', 'CUR', 'WND', 'ICE', 'TAU', 'RHO', & - 'DT0', 'DT1', 'DT2', 'MOV' / -! - FLGR2 = .FALSE. - FLAGSTIDE(:) = .FALSE. - FLH(:) = .FALSE. -! + LOGICAL :: L_MASTER +#endif + ! + !/ + !/ ------------------------------------------------------------------- / + !/ + DATA IDFLDS / 'ice param. 1 ' , 'ice param. 2 ' , & + 'ice param. 3 ' , 'ice param. 4 ' , & + 'ice param. 5 ' , & + 'mud density ' , 'mud thkness ' , & + 'mud viscos. ' , & + 'water levels ' , 'currents ' , & + 'winds ' , 'ice fields ' , & + 'momentum ' , 'air density ' , & + 'mean param. ' , '1D spectra ' , & + '2D spectra ' , 'moving grid ' / + DATA IDOTYP / 'Fields of mean wave parameters' , & + 'Point output ' , & + 'Track point output ' , & + 'Restart files ' , & + 'Nesting data ' , & + 'Partitioned wave field data ' , & + 'Fields for coupling ' , & + 'Restart files second request '/ + DATA IDSTR / 'IC1', 'IC2', 'IC3', 'IC4', 'IC5', 'MDN', 'MTH', & + 'MVS', 'LEV', 'CUR', 'WND', 'ICE', 'TAU', 'RHO', & + 'DT0', 'DT1', 'DT2', 'MOV' / + ! + FLGR2 = .FALSE. + FLAGSTIDE(:) = .FALSE. + FLH(:) = .FALSE. + ! #ifdef W3_T - PRTFRM = .TRUE. -#endif -! - CALL DATE_AND_TIME ( VALUES=CLKDT1 ) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 0. Set up data structures -! + PRTFRM = .TRUE. +#endif + ! + CALL DATE_AND_TIME ( VALUES=CLKDT1 ) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 0. Set up data structures + ! #ifdef W3_OASIS - OASISED=1 + OASISED=1 #endif #ifdef W3_PDLIB - LPDLIB = .TRUE. -#endif -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3NAUX ( 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3NINP ( 6, 6 ) -! - CALL W3SETG ( 1, 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) - CALL W3SETI ( 1, 6, 6 ) + LPDLIB = .TRUE. +#endif + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3NINP ( 6, 6 ) + ! + CALL W3SETG ( 1, 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + CALL W3SETI ( 1, 6, 6 ) #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 1' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif -! + ! #ifdef W3_SHRD - NAPROC = 1 - IAPROC = 1 + NAPROC = 1 + IAPROC = 1 #endif -! + ! #ifdef W3_OMPH - FLHYBR = .TRUE. + FLHYBR = .TRUE. #endif #ifdef W3_OASIS - IF (OASISED.EQ.1) THEN - CALL CPL_OASIS_INIT(MPI_COMM) - ELSE + IF (OASISED.EQ.1) THEN + CALL CPL_OASIS_INIT(MPI_COMM) + ELSE #endif #ifdef W3_OMPH - ! For hybrid MPI-OpenMP specify required thread level. JGLi06Sep2019 - IF( FLHYBR ) THEN - CALL MPI_INIT_THREAD( MPI_THREAD_FUNNELED, THRLEV, IERR_MPI) - ELSE + ! For hybrid MPI-OpenMP specify required thread level. JGLi06Sep2019 + IF( FLHYBR ) THEN + CALL MPI_INIT_THREAD( MPI_THREAD_FUNNELED, THRLEV, IERR_MPI) + ELSE #endif #ifdef W3_MPI CALL MPI_INIT ( IERR_MPI ) #endif #ifdef W3_OMPH - ENDIF + ENDIF #endif #ifdef W3_MPI - MPI_COMM = MPI_COMM_WORLD + MPI_COMM = MPI_COMM_WORLD #endif #ifdef W3_OASIS - END IF + END IF #endif -! -! + ! + ! #ifdef W3_MPI - CALL MPI_COMM_SIZE ( MPI_COMM, NAPROC, IERR_MPI ) + CALL MPI_COMM_SIZE ( MPI_COMM, NAPROC, IERR_MPI ) #endif #ifdef W3_MPI - CALL MPI_COMM_RANK ( MPI_COMM, IAPROC, IERR_MPI ) - IAPROC = IAPROC + 1 + CALL MPI_COMM_RANK ( MPI_COMM, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 #endif -! + ! #ifdef W3_NCO -! IF ( IAPROC .EQ. 1 ) CALL W3TAGB & -! ('WAVEFCST',1998,0007,0050,'NP21 ') + ! IF ( IAPROC .EQ. 1 ) CALL W3TAGB & + ! ('WAVEFCST',1998,0007,0050,'NP21 ') #endif #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) -#endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. IO set-up -! 1.a For shell -! - NDSI = 10 - NDSS = 90 - NDSO = 6 - NDSE = 6 - NDST = 6 - NDSL = 50 + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 1. IO set-up + ! 1.a For shell + ! + NDSI = 10 + NDSS = 90 + NDSO = 6 + NDSE = 6 + NDST = 6 + NDSL = 50 #ifdef W3_COU - NDSO = 333 - NDSE = 333 - NDST = 333 -#endif - - - NDSF(-7) = 1008 - NDSF(-6) = 1009 - NDSF(-5) = 1010 - NDSF(-4) = 1011 - NDSF(-3) = 1012 - NDSF(-2) = 1013 - NDSF(-1) = 1014 - NDSF(0) = 1015 - - NDSF(1) = 11 - NDSF(2) = 12 - NDSF(3) = 13 - NDSF(4) = 14 - NDSF(5) = 15 - NDSF(6) = 16 - NDSF(7) = 17 - NDSF(8) = 18 - NDSF(9) = 19 -! + NDSO = 333 + NDSE = 333 + NDST = 333 +#endif + + + NDSF(-7) = 1008 + NDSF(-6) = 1009 + NDSF(-5) = 1010 + NDSF(-4) = 1011 + NDSF(-3) = 1012 + NDSF(-2) = 1013 + NDSF(-1) = 1014 + NDSF(0) = 1015 + + NDSF(1) = 11 + NDSF(2) = 12 + NDSF(3) = 13 + NDSF(4) = 14 + NDSF(5) = 15 + NDSF(6) = 16 + NDSF(7) = 17 + NDSF(8) = 18 + NDSF(9) = 19 + ! #ifdef W3_NCO -! -! Redo according to NCO -! - NDSI = 11 - NDSS = 90 - NDSO = 6 - NDSE = NDSO - NDST = NDSO - NDSF(1) = 12 - NDSF(2) = 13 - NDSF(3) = 14 - NDSF(4) = 15 - NDSF(5) = 16 - NDSF(6) = 17 - NDSF(7) = 18 - NDSF(8) = 19 - NDSF(9) = 20 -#endif -! - NAPOUT = 1 - NAPERR = 1 -! + ! + ! Redo according to NCO + ! + NDSI = 11 + NDSS = 90 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSF(1) = 12 + NDSF(2) = 13 + NDSF(3) = 14 + NDSF(4) = 15 + NDSF(5) = 16 + NDSF(6) = 17 + NDSF(7) = 18 + NDSF(8) = 19 + NDSF(9) = 20 +#endif + ! + NAPOUT = 1 + NAPERR = 1 + ! #ifdef W3_COU - OFILE = 'output.ww3' - OFL = LEN_TRIM(OFILE) - J = LEN_TRIM(FNMPRE) - IF ( IAPROC .EQ. NAPOUT ) & - OPEN (333,FILE=FNMPRE(:J)//OFILE(:OFL),ERR=2008,IOSTAT=IERR) -#endif - - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) -! - IF ( IAPROC .EQ. NAPERR ) THEN - NDSEN = NDSE - ELSE - NDSEN = -1 - END IF + OFILE = 'output.ww3' + OFL = LEN_TRIM(OFILE) + J = LEN_TRIM(FNMPRE) + IF ( IAPROC .EQ. NAPOUT ) & + OPEN (333,FILE=FNMPRE(:J)//OFILE(:OFL),ERR=2008,IOSTAT=IERR) +#endif + + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) + ! + IF ( IAPROC .EQ. NAPERR ) THEN + NDSEN = NDSE + ELSE + NDSEN = -1 + END IF #ifdef W3_OMPH - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,905) & - MPI_THREAD_FUNNELED, THRLEV -#endif -! - -! -! 1.b For WAVEWATCH III (See W3INIT) -! - NDS( 1) = 20 - NDS( 2) = 6 - NDS( 3) = 21 - NDS( 4) = 6 - NDS( 5) = 30 - NDS( 6) = 30 - NDS( 7) = 31 - NDS( 8) = 32 - NDS( 9) = 33 - NDS(10) = 35 - NDS(11) = 22 - NDS(12) = 23 - NDS(13) = 34 -! - NTRACE(1) = NDS(3) - NTRACE(2) = 10 -! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,905) & + MPI_THREAD_FUNNELED, THRLEV +#endif + ! + + ! + ! 1.b For WAVEWATCH III (See W3INIT) + ! + NDS( 1) = 20 + NDS( 2) = 6 + NDS( 3) = 21 + NDS( 4) = 6 + NDS( 5) = 30 + NDS( 6) = 30 + NDS( 7) = 31 + NDS( 8) = 32 + NDS( 9) = 33 + NDS(10) = 35 + NDS(11) = 22 + NDS(12) = 23 + NDS(13) = 34 + ! + NTRACE(1) = NDS(3) + NTRACE(2) = 10 + ! #ifdef W3_NCO -! -! Redo according to NCO -! - NDS( 1) = 51 - NDS( 2) = NDSO - NDS( 3) = NDSO - NDS( 4) = NDSO - NDS( 5) = 20 - NDS( 6) = 21 - NDS( 7) = 52 - NDS( 8) = 53 - NDS( 9) = 22 - NDS(10) = 71 - NDS(11) = 23 - NDS(12) = 54 - NDS(13) = 55 - NTRACE(1) = NDSO -#endif -! + ! + ! Redo according to NCO + ! + NDS( 1) = 51 + NDS( 2) = NDSO + NDS( 3) = NDSO + NDS( 4) = NDSO + NDS( 5) = 20 + NDS( 6) = 21 + NDS( 7) = 52 + NDS( 8) = 53 + NDS( 9) = 22 + NDS(10) = 71 + NDS(11) = 23 + NDS(12) = 54 + NDS(13) = 55 + NTRACE(1) = NDSO +#endif + ! #ifdef W3_T - WRITE (NDST,9000) (NDS(I),I=1,12) - WRITE (NDST,9001) (NTRACE(I),I=1,2) -#endif -! -! 1.c Local parameters -! -! Default COMSTR to "$" (for when using nml input files) - COMSTR = "$" -! -! inferred from context: these flags (FL) are to indicate that the last (LST) -! field has been read from a file. - FLLSTL = .FALSE. ! This is associated with J.EQ.1 (wlev) - FLLSTI = .FALSE. ! This is associated with J.EQ.4 (ice) - FLLSTR = .FALSE. ! This is associated with J.EQ.6 (rhoa) - FLLST_ALL = .FALSE. ! For all - -! If using experimental mud or ice physics, additional lines will -! be read in from ww3_shel.inp and applied, so JFIRST is changed from -! its initialization setting "JFIRST=1" to some lower value. + WRITE (NDST,9000) (NDS(I),I=1,12) + WRITE (NDST,9001) (NTRACE(I),I=1,2) +#endif + ! + ! 1.c Local parameters + ! + ! Default COMSTR to "$" (for when using nml input files) + COMSTR = "$" + ! + ! inferred from context: these flags (FL) are to indicate that the last (LST) + ! field has been read from a file. + FLLSTL = .FALSE. ! This is associated with J.EQ.1 (wlev) + FLLSTI = .FALSE. ! This is associated with J.EQ.4 (ice) + FLLSTR = .FALSE. ! This is associated with J.EQ.6 (rhoa) + FLLST_ALL = .FALSE. ! For all + + ! If using experimental mud or ice physics, additional lines will + ! be read in from ww3_shel.inp and applied, so JFIRST is changed from + ! its initialization setting "JFIRST=1" to some lower value. #ifdef W3_IC1 - JFIRST=-7 + JFIRST=-7 #endif #ifdef W3_IC2 - JFIRST=-7 + JFIRST=-7 #endif #ifdef W3_IS2 - JFIRST=-7 + JFIRST=-7 #endif #ifdef W3_IC3 - JFIRST=-7 + JFIRST=-7 #endif #ifdef W3_BT8 - JFIRST=-7 + JFIRST=-7 #endif #ifdef W3_BT9 - JFIRST=-7 + JFIRST=-7 #endif #ifdef W3_IC4 - JFIRST=-7 + JFIRST=-7 #endif #ifdef W3_IC5 - JFIRST=-7 + JFIRST=-7 #endif #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2a' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) -#endif - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Define input fields -! - -! -! process ww3_prnc namelist -! - INQUIRE(FILE=TRIM(FNMPRE)//"ww3_shel.nml", EXIST=FLGNML) - IF (FLGNML) THEN - ! Read namelist - CALL W3NMLSHEL (MPI_COMM, NDSI, TRIM(FNMPRE)//'ww3_shel.nml', & - NML_DOMAIN, NML_INPUT, NML_OUTPUT_TYPE, & - NML_OUTPUT_DATE, NML_HOMOG_COUNT, & - NML_HOMOG_INPUT, IERR) - -! 2.1 forcing flags - - FLH(-7:10)=.FALSE. - FLAGTFC(-7)=TRIM(NML_INPUT%FORCING%ICE_PARAM1) - FLAGTFC(-6)=TRIM(NML_INPUT%FORCING%ICE_PARAM2) - FLAGTFC(-5)=TRIM(NML_INPUT%FORCING%ICE_PARAM3) - FLAGTFC(-4)=TRIM(NML_INPUT%FORCING%ICE_PARAM4) - FLAGTFC(-3)=TRIM(NML_INPUT%FORCING%ICE_PARAM5) - FLAGTFC(-2)=TRIM(NML_INPUT%FORCING%MUD_DENSITY) - FLAGTFC(-1)=TRIM(NML_INPUT%FORCING%MUD_THICKNESS) - FLAGTFC(0)=TRIM(NML_INPUT%FORCING%MUD_VISCOSITY) - FLAGTFC(1)=TRIM(NML_INPUT%FORCING%WATER_LEVELS) - FLAGTFC(2)=TRIM(NML_INPUT%FORCING%CURRENTS) - FLAGTFC(3)=TRIM(NML_INPUT%FORCING%WINDS) - FLAGTFC(4)=TRIM(NML_INPUT%FORCING%ICE_CONC) - FLAGTFC(5)=TRIM(NML_INPUT%FORCING%ATM_MOMENTUM) - FLAGTFC(6)=TRIM(NML_INPUT%FORCING%AIR_DENSITY) - FLAGTFC(7)=TRIM(NML_INPUT%ASSIM%MEAN) - FLAGTFC(8)=TRIM(NML_INPUT%ASSIM%SPEC1D) - FLAGTFC(9)=TRIM(NML_INPUT%ASSIM%SPEC2D) - - IF (TRIM(NML_INPUT%FORCING%ICE_PARAM1) .EQ. 'H') THEN - FLAGTFC(-7)='T' - FLH(-7)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%ICE_PARAM2) .EQ. 'H') THEN - FLAGTFC(-6)='T' - FLH(-6)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%ICE_PARAM3) .EQ. 'H') THEN - FLAGTFC(-5)='T' - FLH(-5)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%ICE_PARAM4) .EQ. 'H') THEN - FLAGTFC(-4)='T' - FLH(-4)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%ICE_PARAM5) .EQ. 'H') THEN - FLAGTFC(-3)='T' - FLH(-3)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%MUD_DENSITY) .EQ. 'H') THEN - FLAGTFC(-2)='T' - FLH(-2)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%MUD_THICKNESS) .EQ. 'H') THEN - FLAGTFC(-1)='T' - FLH(-1)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%MUD_VISCOSITY) .EQ. 'H') THEN - FLAGTFC(0)='T' - FLH(0)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%WATER_LEVELS) .EQ. 'H') THEN - FLAGTFC(1)='T' - FLH(1)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%CURRENTS) .EQ. 'H') THEN - FLAGTFC(2)='T' - FLH(2)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%WINDS) .EQ. 'H') THEN - FLAGTFC(3)='T' - FLH(3)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%ICE_CONC) .EQ. 'H') THEN - FLAGTFC(4)='T' - FLH(4)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%ATM_MOMENTUM) .EQ. 'H') THEN - FLAGTFC(5)='T' - FLH(5)=.TRUE. - END IF - IF (TRIM(NML_INPUT%FORCING%AIR_DENSITY) .EQ. 'H') THEN - FLAGTFC(6)='T' - FLH(6)=.TRUE. - END IF - - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,920) - DO J=JFIRST, 9 - IF (FLAGTFC(J).EQ.'T') THEN - INFLAGS1(J)=.TRUE. - FLAGSC(J)=.FALSE. - END IF - IF (FLAGTFC(J).EQ.'F') THEN - INFLAGS1(J)=.FALSE. - FLAGSC(J)=.FALSE. - END IF - IF (FLAGTFC(J).EQ.'C') THEN - INFLAGS1(J)=.TRUE. - FLAGSC(J)=.TRUE. - END IF - IF ( J .LE. 6 ) THEN - FLH(J) = FLH(J) .AND. INFLAGS1(J) - END IF - IF ( INFLAGS1(J) ) THEN - YESXNO = 'YES/--' - ELSE - YESXNO = '---/NO' - END IF - IF ( FLH(J) ) THEN - STRNG = '(homogeneous field) ' - ELSE IF ( FLAGSC(J) ) THEN - STRNG = '(coupling field) ' - ELSE - STRNG = ' ' - END IF - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,921) IDFLDS(J), YESXNO, STRNG - END DO + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2a' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Define input fields + ! + + ! + ! process ww3_prnc namelist + ! + INQUIRE(FILE=TRIM(FNMPRE)//"ww3_shel.nml", EXIST=FLGNML) + IF (FLGNML) THEN + ! Read namelist + CALL W3NMLSHEL (MPI_COMM, NDSI, TRIM(FNMPRE)//'ww3_shel.nml', & + NML_DOMAIN, NML_INPUT, NML_OUTPUT_TYPE, & + NML_OUTPUT_DATE, NML_HOMOG_COUNT, & + NML_HOMOG_INPUT, IERR) + + ! 2.1 forcing flags + + FLH(-7:10)=.FALSE. + FLAGTFC(-7)=TRIM(NML_INPUT%FORCING%ICE_PARAM1) + FLAGTFC(-6)=TRIM(NML_INPUT%FORCING%ICE_PARAM2) + FLAGTFC(-5)=TRIM(NML_INPUT%FORCING%ICE_PARAM3) + FLAGTFC(-4)=TRIM(NML_INPUT%FORCING%ICE_PARAM4) + FLAGTFC(-3)=TRIM(NML_INPUT%FORCING%ICE_PARAM5) + FLAGTFC(-2)=TRIM(NML_INPUT%FORCING%MUD_DENSITY) + FLAGTFC(-1)=TRIM(NML_INPUT%FORCING%MUD_THICKNESS) + FLAGTFC(0)=TRIM(NML_INPUT%FORCING%MUD_VISCOSITY) + FLAGTFC(1)=TRIM(NML_INPUT%FORCING%WATER_LEVELS) + FLAGTFC(2)=TRIM(NML_INPUT%FORCING%CURRENTS) + FLAGTFC(3)=TRIM(NML_INPUT%FORCING%WINDS) + FLAGTFC(4)=TRIM(NML_INPUT%FORCING%ICE_CONC) + FLAGTFC(5)=TRIM(NML_INPUT%FORCING%ATM_MOMENTUM) + FLAGTFC(6)=TRIM(NML_INPUT%FORCING%AIR_DENSITY) + FLAGTFC(7)=TRIM(NML_INPUT%ASSIM%MEAN) + FLAGTFC(8)=TRIM(NML_INPUT%ASSIM%SPEC1D) + FLAGTFC(9)=TRIM(NML_INPUT%ASSIM%SPEC2D) + + IF (TRIM(NML_INPUT%FORCING%ICE_PARAM1) .EQ. 'H') THEN + FLAGTFC(-7)='T' + FLH(-7)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%ICE_PARAM2) .EQ. 'H') THEN + FLAGTFC(-6)='T' + FLH(-6)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%ICE_PARAM3) .EQ. 'H') THEN + FLAGTFC(-5)='T' + FLH(-5)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%ICE_PARAM4) .EQ. 'H') THEN + FLAGTFC(-4)='T' + FLH(-4)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%ICE_PARAM5) .EQ. 'H') THEN + FLAGTFC(-3)='T' + FLH(-3)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%MUD_DENSITY) .EQ. 'H') THEN + FLAGTFC(-2)='T' + FLH(-2)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%MUD_THICKNESS) .EQ. 'H') THEN + FLAGTFC(-1)='T' + FLH(-1)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%MUD_VISCOSITY) .EQ. 'H') THEN + FLAGTFC(0)='T' + FLH(0)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%WATER_LEVELS) .EQ. 'H') THEN + FLAGTFC(1)='T' + FLH(1)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%CURRENTS) .EQ. 'H') THEN + FLAGTFC(2)='T' + FLH(2)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%WINDS) .EQ. 'H') THEN + FLAGTFC(3)='T' + FLH(3)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%ICE_CONC) .EQ. 'H') THEN + FLAGTFC(4)='T' + FLH(4)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%ATM_MOMENTUM) .EQ. 'H') THEN + FLAGTFC(5)='T' + FLH(5)=.TRUE. + END IF + IF (TRIM(NML_INPUT%FORCING%AIR_DENSITY) .EQ. 'H') THEN + FLAGTFC(6)='T' + FLH(6)=.TRUE. + END IF + + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,920) + DO J=JFIRST, 9 + IF (FLAGTFC(J).EQ.'T') THEN + INFLAGS1(J)=.TRUE. + FLAGSC(J)=.FALSE. + END IF + IF (FLAGTFC(J).EQ.'F') THEN + INFLAGS1(J)=.FALSE. + FLAGSC(J)=.FALSE. + END IF + IF (FLAGTFC(J).EQ.'C') THEN + INFLAGS1(J)=.TRUE. + FLAGSC(J)=.TRUE. + END IF + IF ( J .LE. 6 ) THEN + FLH(J) = FLH(J) .AND. INFLAGS1(J) + END IF + IF ( INFLAGS1(J) ) THEN + YESXNO = 'YES/--' + ELSE + YESXNO = '---/NO' + END IF + IF ( FLH(J) ) THEN + STRNG = '(homogeneous field) ' + ELSE IF ( FLAGSC(J) ) THEN + STRNG = '(coupling field) ' + ELSE + STRNG = ' ' + END IF + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,921) IDFLDS(J), YESXNO, STRNG + END DO #ifdef W3_COU - IF (FLAGSC(1) .AND. INFLAGS1(2) .AND. .NOT. FLAGSC(2)) GOTO 2102 - IF (FLAGSC(2) .AND. INFLAGS1(1) .AND. .NOT. FLAGSC(1)) GOTO 2102 + IF (FLAGSC(1) .AND. INFLAGS1(2) .AND. .NOT. FLAGSC(2)) GOTO 2102 + IF (FLAGSC(2) .AND. INFLAGS1(1) .AND. .NOT. FLAGSC(1)) GOTO 2102 #endif - INFLAGS1(10) = .FALSE. + INFLAGS1(10) = .FALSE. #ifdef W3_MGW - INFLAGS1(10) = .TRUE. + INFLAGS1(10) = .TRUE. #endif #ifdef W3_MGP - INFLAGS1(10) = .TRUE. + INFLAGS1(10) = .TRUE. #endif #ifdef W3_MGW - FLH(10) = .TRUE. + FLH(10) = .TRUE. #endif #ifdef W3_MGP - FLH(10) = .TRUE. -#endif - IF ( INFLAGS1(10) .AND. IAPROC.EQ.NAPOUT ) & - WRITE (NDSO,921) IDFLDS(10), 'YES/--', ' ' -! - FLFLG = INFLAGS1(-7) .OR. INFLAGS1(-6) .OR. INFLAGS1(-5) .OR. INFLAGS1(-4) & - .OR. INFLAGS1(-3) .OR. INFLAGS1(-2) .OR. INFLAGS1(-1) & - .OR. INFLAGS1(0) .OR. INFLAGS1(1) .OR. INFLAGS1(2) & - .OR. INFLAGS1(3) .OR. INFLAGS1(4) .OR. INFLAGS1(5) & - .OR. INFLAGS1(6) .OR. INFLAGS1(7) .OR. INFLAGS1(8) & - .OR. INFLAGS1(9) - FLHOM = FLH(-7) .OR. FLH(-6) .OR. FLH(-5) .OR. FLH(-4) & - .OR. FLH(-3) .OR. FLH(-2) .OR. FLH(-1) .OR. FLH(0) & - .OR. FLH(1) .OR. FLH(2) .OR. FLH(3) .OR. FLH(4) & - .OR. FLH(5) .OR. FLH(6) .OR. FLH(10) -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,922) -! -! INFLAGS2 is just "initial value of INFLAGS1", i.e. does *not* get -! changed when model reads last record of ice.ww3 - INFLAGS2=INFLAGS1 + FLH(10) = .TRUE. +#endif + IF ( INFLAGS1(10) .AND. IAPROC.EQ.NAPOUT ) & + WRITE (NDSO,921) IDFLDS(10), 'YES/--', ' ' + ! + FLFLG = INFLAGS1(-7) .OR. INFLAGS1(-6) .OR. INFLAGS1(-5) .OR. INFLAGS1(-4) & + .OR. INFLAGS1(-3) .OR. INFLAGS1(-2) .OR. INFLAGS1(-1) & + .OR. INFLAGS1(0) .OR. INFLAGS1(1) .OR. INFLAGS1(2) & + .OR. INFLAGS1(3) .OR. INFLAGS1(4) .OR. INFLAGS1(5) & + .OR. INFLAGS1(6) .OR. INFLAGS1(7) .OR. INFLAGS1(8) & + .OR. INFLAGS1(9) + FLHOM = FLH(-7) .OR. FLH(-6) .OR. FLH(-5) .OR. FLH(-4) & + .OR. FLH(-3) .OR. FLH(-2) .OR. FLH(-1) .OR. FLH(0) & + .OR. FLH(1) .OR. FLH(2) .OR. FLH(3) .OR. FLH(4) & + .OR. FLH(5) .OR. FLH(6) .OR. FLH(10) + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,922) + ! + ! INFLAGS2 is just "initial value of INFLAGS1", i.e. does *not* get + ! changed when model reads last record of ice.ww3 + INFLAGS2=INFLAGS1 #ifdef W3_T - WRITE (NDST,9020) FLFLG, INFLAGS1, FLHOM, FLH + WRITE (NDST,9020) FLFLG, INFLAGS1, FLHOM, FLH #endif -! 2.2 Time setup + ! 2.2 Time setup - READ(NML_DOMAIN%START,*) TIME0 - CALL T2D(TIME0,STARTDATE,IERR) - CALL D2J(STARTDATE,STARTJULDAY,IERR) - READ(NML_DOMAIN%STOP,*) TIMEN - CALL T2D(TIMEN,STOPDATE,IERR) - CALL D2J(STOPDATE,STOPJULDAY,IERR) + READ(NML_DOMAIN%START,*) TIME0 + CALL T2D(TIME0,STARTDATE,IERR) + CALL D2J(STARTDATE,STARTJULDAY,IERR) + READ(NML_DOMAIN%STOP,*) TIMEN + CALL T2D(TIMEN,STOPDATE,IERR) + CALL D2J(STOPDATE,STOPJULDAY,IERR) -! 2.3 Domain setup + ! 2.3 Domain setup - IOSTYP = NML_DOMAIN%IOSTYP + IOSTYP = NML_DOMAIN%IOSTYP #ifdef W3_PDLIB - IF (IOSTYP .gt. 1) THEN - WRITE(*,*) 'IOSTYP not supported in domain decomposition mode' - CALL EXTCDE ( 6666 ) - ENDIF + IF (IOSTYP .gt. 1) THEN + WRITE(*,*) 'IOSTYP not supported in domain decomposition mode' + CALL EXTCDE ( 6666 ) + ENDIF +#endif + + CALL W3IOGR ( 'GRID', NDSF(7) ) + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + + ! 2.4 Output dates + + READ(NML_OUTPUT_DATE%FIELD%START, *) ODAT(1), ODAT(2) + READ(NML_OUTPUT_DATE%FIELD%STRIDE, *) ODAT(3) + READ(NML_OUTPUT_DATE%FIELD%STOP, *) ODAT(4), ODAT(5) + + READ(NML_OUTPUT_DATE%FIELD%OUTFFILE, *) OFILES(1) + ! OUTPTS(I)%OUTSTRIDE(1)=ODAT(3,I) + + READ(NML_OUTPUT_DATE%POINT%START, *) ODAT(6), ODAT(7) + READ(NML_OUTPUT_DATE%POINT%STRIDE, *) ODAT(8) + READ(NML_OUTPUT_DATE%POINT%STOP, *) ODAT(9), ODAT(10) + + READ(NML_OUTPUT_DATE%POINT%OUTFFILE, *) OFILES(2) + ! OUTPTS(I)%OUTSTRIDE(2)=ODAT(8,I) + + READ(NML_OUTPUT_DATE%TRACK%START, *) ODAT(11), ODAT(12) + READ(NML_OUTPUT_DATE%TRACK%STRIDE, *) ODAT(13) + READ(NML_OUTPUT_DATE%TRACK%STOP, *) ODAT(14), ODAT(15) + READ(NML_OUTPUT_DATE%RESTART%START, *) ODAT(16), ODAT(17) + READ(NML_OUTPUT_DATE%RESTART%STRIDE, *) ODAT(18) + READ(NML_OUTPUT_DATE%RESTART%STOP, *) ODAT(19), ODAT(20) + READ(NML_OUTPUT_DATE%RESTART2%START, *) ODAT(36), ODAT(37) + READ(NML_OUTPUT_DATE%RESTART2%STRIDE, *) ODAT(38) + READ(NML_OUTPUT_DATE%RESTART2%STOP, *) ODAT(39), ODAT(40) + READ(NML_OUTPUT_DATE%BOUNDARY%START, *) ODAT(21), ODAT(22) + READ(NML_OUTPUT_DATE%BOUNDARY%STRIDE, *) ODAT(23) + READ(NML_OUTPUT_DATE%BOUNDARY%STOP, *) ODAT(24), ODAT(25) + READ(NML_OUTPUT_DATE%PARTITION%START, *) ODAT(26), ODAT(27) + READ(NML_OUTPUT_DATE%PARTITION%STRIDE, *) ODAT(28) + READ(NML_OUTPUT_DATE%PARTITION%STOP, *) ODAT(29), ODAT(30) + READ(NML_OUTPUT_DATE%COUPLING%START, *) ODAT(31), ODAT(32) + READ(NML_OUTPUT_DATE%COUPLING%STRIDE, *) ODAT(33) + READ(NML_OUTPUT_DATE%COUPLING%STOP, *) ODAT(34), ODAT(35) + + ! set the time stride at 0 or more + ODAT(3) = MAX ( 0 , ODAT(3) ) + ODAT(8) = MAX ( 0 , ODAT(8) ) + ODAT(13) = MAX ( 0 , ODAT(13) ) + ODAT(18) = MAX ( 0 , ODAT(18) ) + ODAT(23) = MAX ( 0 , ODAT(23) ) + ODAT(28) = MAX ( 0 , ODAT(28) ) + ODAT(33) = MAX ( 0 , ODAT(33) ) + ODAT(38) = MAX ( 0 , ODAT(38) ) + ! +#ifdef W3_COU + ! Test the validity of the coupling time step + IF (ODAT(33) == 0) THEN + IF ( IAPROC .EQ. NAPOUT ) THEN + WRITE(NDSO,1010) ODAT(33), INT(DTMAX) + END IF + ODAT(33) = INT(DTMAX) + ELSE IF (MOD(ODAT(33),INT(DTMAX)) .NE. 0) THEN + GOTO 2009 + END IF #endif + ! + ! 2.5 Output types - CALL W3IOGR ( 'GRID', NDSF(7) ) - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF - -! 2.4 Output dates - - READ(NML_OUTPUT_DATE%FIELD%START, *) ODAT(1), ODAT(2) - READ(NML_OUTPUT_DATE%FIELD%STRIDE, *) ODAT(3) - READ(NML_OUTPUT_DATE%FIELD%STOP, *) ODAT(4), ODAT(5) - - READ(NML_OUTPUT_DATE%FIELD%OUTFFILE, *) OFILES(1) -! OUTPTS(I)%OUTSTRIDE(1)=ODAT(3,I) - - READ(NML_OUTPUT_DATE%POINT%START, *) ODAT(6), ODAT(7) - READ(NML_OUTPUT_DATE%POINT%STRIDE, *) ODAT(8) - READ(NML_OUTPUT_DATE%POINT%STOP, *) ODAT(9), ODAT(10) - - READ(NML_OUTPUT_DATE%POINT%OUTFFILE, *) OFILES(2) -! OUTPTS(I)%OUTSTRIDE(2)=ODAT(8,I) - - READ(NML_OUTPUT_DATE%TRACK%START, *) ODAT(11), ODAT(12) - READ(NML_OUTPUT_DATE%TRACK%STRIDE, *) ODAT(13) - READ(NML_OUTPUT_DATE%TRACK%STOP, *) ODAT(14), ODAT(15) - READ(NML_OUTPUT_DATE%RESTART%START, *) ODAT(16), ODAT(17) - READ(NML_OUTPUT_DATE%RESTART%STRIDE, *) ODAT(18) - READ(NML_OUTPUT_DATE%RESTART%STOP, *) ODAT(19), ODAT(20) - READ(NML_OUTPUT_DATE%RESTART2%START, *) ODAT(36), ODAT(37) - READ(NML_OUTPUT_DATE%RESTART2%STRIDE, *) ODAT(38) - READ(NML_OUTPUT_DATE%RESTART2%STOP, *) ODAT(39), ODAT(40) - READ(NML_OUTPUT_DATE%BOUNDARY%START, *) ODAT(21), ODAT(22) - READ(NML_OUTPUT_DATE%BOUNDARY%STRIDE, *) ODAT(23) - READ(NML_OUTPUT_DATE%BOUNDARY%STOP, *) ODAT(24), ODAT(25) - READ(NML_OUTPUT_DATE%PARTITION%START, *) ODAT(26), ODAT(27) - READ(NML_OUTPUT_DATE%PARTITION%STRIDE, *) ODAT(28) - READ(NML_OUTPUT_DATE%PARTITION%STOP, *) ODAT(29), ODAT(30) - READ(NML_OUTPUT_DATE%COUPLING%START, *) ODAT(31), ODAT(32) - READ(NML_OUTPUT_DATE%COUPLING%STRIDE, *) ODAT(33) - READ(NML_OUTPUT_DATE%COUPLING%STOP, *) ODAT(34), ODAT(35) - - ! set the time stride at 0 or more - ODAT(3) = MAX ( 0 , ODAT(3) ) - ODAT(8) = MAX ( 0 , ODAT(8) ) - ODAT(13) = MAX ( 0 , ODAT(13) ) - ODAT(18) = MAX ( 0 , ODAT(18) ) - ODAT(23) = MAX ( 0 , ODAT(23) ) - ODAT(28) = MAX ( 0 , ODAT(28) ) - ODAT(33) = MAX ( 0 , ODAT(33) ) - ODAT(38) = MAX ( 0 , ODAT(38) ) -! + NPTS = 0 + NOTYPE = 6 #ifdef W3_COU - ! Test the validity of the coupling time step - IF (ODAT(33) == 0) THEN - IF ( IAPROC .EQ. NAPOUT ) THEN - WRITE(NDSO,1010) ODAT(33), INT(DTMAX) - END IF - ODAT(33) = INT(DTMAX) - ELSE IF (MOD(ODAT(33),INT(DTMAX)) .NE. 0) THEN - GOTO 2009 - END IF + NOTYPE = 7 #endif -! -! 2.5 Output types + DO J = 1, NOTYPE + ! OUTPTS(I)%OFILES(J)=OFILES(J) + IF ( ODAT(5*(J-1)+3) .NE. 0 ) THEN - NPTS = 0 - NOTYPE = 6 -#ifdef W3_COU - NOTYPE = 7 -#endif - DO J = 1, NOTYPE -! OUTPTS(I)%OFILES(J)=OFILES(J) - IF ( ODAT(5*(J-1)+3) .NE. 0 ) THEN - -! Type 1: fields of mean wave parameters - IF ( J .EQ. 1 ) THEN - FLDOUT = NML_OUTPUT_TYPE%FIELD%LIST - CALL W3FLGRDFLAG ( NDSO, NDSO, NDSE, FLDOUT, FLGD, & - FLGRD, IAPROC, NAPOUT, IERR ) - IF ( IERR .NE. 0 ) GOTO 2222 - - -! Type 2: point output - ELSE IF ( J .EQ. 2 ) THEN - OPEN (NDSL, FILE=TRIM(FNMPRE)//TRIM(NML_OUTPUT_TYPE%POINT%FILE), & - FORM='FORMATTED', STATUS='OLD', ERR=2104, IOSTAT=IERR) - - ! first loop to count the number of points - ! second loop to allocate the array and store the points - IPTS = 0 - DO ILOOP=1,2 - REWIND (NDSL) -! - IF ( ILOOP.EQ.2) THEN - NPTS = IPTS - IF ( NPTS.GT.0 ) THEN - ALLOCATE ( X(NPTS), Y(NPTS), PNAMES(NPTS) ) - IPTS = 0 ! reset counter to be reused for next do loop - ELSE - ALLOCATE ( X(1), Y(1), PNAMES(1) ) - GOTO 2054 - END IF - END IF -! - DO - READ (NDSL,*,ERR=2004,IOSTAT=IERR) TMPLINE - ! if end of file or stopstring, then exit - IF ( IERR.NE.0 .OR. INDEX(TMPLINE,"STOPSTRING").NE.0 ) EXIT - ! leading blanks removed and placed on the right - TEST = ADJUSTL ( TMPLINE ) - IF ( TEST(1:1).EQ.COMSTR .OR. LEN_TRIM(TEST).EQ.0 ) THEN - ! if comment or blank line, then skip - CYCLE + ! Type 1: fields of mean wave parameters + IF ( J .EQ. 1 ) THEN + FLDOUT = NML_OUTPUT_TYPE%FIELD%LIST + CALL W3FLGRDFLAG ( NDSO, NDSO, NDSE, FLDOUT, FLGD, & + FLGRD, IAPROC, NAPOUT, IERR ) + IF ( IERR .NE. 0 ) GOTO 2222 + + + ! Type 2: point output + ELSE IF ( J .EQ. 2 ) THEN + OPEN (NDSL, FILE=TRIM(FNMPRE)//TRIM(NML_OUTPUT_TYPE%POINT%FILE), & + FORM='FORMATTED', STATUS='OLD', ERR=2104, IOSTAT=IERR) + + ! first loop to count the number of points + ! second loop to allocate the array and store the points + IPTS = 0 + DO ILOOP=1,2 + REWIND (NDSL) + ! + IF ( ILOOP.EQ.2) THEN + NPTS = IPTS + IF ( NPTS.GT.0 ) THEN + ALLOCATE ( X(NPTS), Y(NPTS), PNAMES(NPTS) ) + IPTS = 0 ! reset counter to be reused for next do loop + ELSE + ALLOCATE ( X(1), Y(1), PNAMES(1) ) + GOTO 2054 + END IF + END IF + ! + DO + READ (NDSL,*,ERR=2004,IOSTAT=IERR) TMPLINE + ! if end of file or stopstring, then exit + IF ( IERR.NE.0 .OR. INDEX(TMPLINE,"STOPSTRING").NE.0 ) EXIT + ! leading blanks removed and placed on the right + TEST = ADJUSTL ( TMPLINE ) + IF ( TEST(1:1).EQ.COMSTR .OR. LEN_TRIM(TEST).EQ.0 ) THEN + ! if comment or blank line, then skip + CYCLE + ELSE + ! otherwise, backup to beginning of line + BACKSPACE ( NDSL, ERR=2004, IOSTAT=IERR) + READ (NDSL,*,ERR=2004,IOSTAT=IERR) XX, YY, PN + END IF + IPTS = IPTS + 1 + IF ( ILOOP .EQ. 1 ) CYCLE + IF ( ILOOP .EQ. 2 ) THEN + X(IPTS) = XX + Y(IPTS) = YY + PNAMES(IPTS) = PN + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( FLAGLL ) THEN + IF ( IPTS .EQ. 1 ) THEN + WRITE (NDSO,2945) & + FACTOR*XX, FACTOR*YY, PN + ELSE + WRITE (NDSO,2946) IPTS, & + FACTOR*XX, FACTOR*YY, PN + END IF ELSE - ! otherwise, backup to beginning of line - BACKSPACE ( NDSL, ERR=2004, IOSTAT=IERR) - READ (NDSL,*,ERR=2004,IOSTAT=IERR) XX, YY, PN - END IF - IPTS = IPTS + 1 - IF ( ILOOP .EQ. 1 ) CYCLE - IF ( ILOOP .EQ. 2 ) THEN - X(IPTS) = XX - Y(IPTS) = YY - PNAMES(IPTS) = PN - IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( FLAGLL ) THEN - IF ( IPTS .EQ. 1 ) THEN - WRITE (NDSO,2945) & - FACTOR*XX, FACTOR*YY, PN - ELSE - WRITE (NDSO,2946) IPTS, & - FACTOR*XX, FACTOR*YY, PN - END IF - ELSE - IF ( IPTS .EQ. 1 ) THEN - WRITE (NDSO,2955) & - FACTOR*XX, FACTOR*YY, PN - ELSE - WRITE (NDSO,2956) IPTS, & - FACTOR*XX, FACTOR*YY, PN - END IF - END IF + IF ( IPTS .EQ. 1 ) THEN + WRITE (NDSO,2955) & + FACTOR*XX, FACTOR*YY, PN + ELSE + WRITE (NDSO,2956) IPTS, & + FACTOR*XX, FACTOR*YY, PN END IF - END IF ! ILOOP.EQ.2 - END DO ! end of file - END DO ! ILOOP - CLOSE(NDSL) - -! Type 3: track output - ELSE IF ( J .EQ. 3 ) THEN - TFLAGI = NML_OUTPUT_TYPE%TRACK%FORMAT - IF ( .NOT. TFLAGI ) NDS(11) = -NDS(11) - IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( .NOT. TFLAGI ) THEN - WRITE (NDSO,3945) 'input', 'UNFORMATTED' - ELSE - WRITE (NDSO,3945) 'input', 'FORMATTED' + END IF END IF - END IF + END IF ! ILOOP.EQ.2 + END DO ! end of file + END DO ! ILOOP + CLOSE(NDSL) + + ! Type 3: track output + ELSE IF ( J .EQ. 3 ) THEN + TFLAGI = NML_OUTPUT_TYPE%TRACK%FORMAT + IF ( .NOT. TFLAGI ) NDS(11) = -NDS(11) + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( .NOT. TFLAGI ) THEN + WRITE (NDSO,3945) 'input', 'UNFORMATTED' + ELSE + WRITE (NDSO,3945) 'input', 'FORMATTED' + END IF + END IF -! Type 6: partitioning - ELSE IF ( J .EQ. 6 ) THEN - IPRT(1) = NML_OUTPUT_TYPE%PARTITION%X0 - IPRT(2) = NML_OUTPUT_TYPE%PARTITION%XN - IPRT(3) = NML_OUTPUT_TYPE%PARTITION%NX - IPRT(4) = NML_OUTPUT_TYPE%PARTITION%Y0 - IPRT(5) = NML_OUTPUT_TYPE%PARTITION%YN - IPRT(6) = NML_OUTPUT_TYPE%PARTITION%NY - PRTFRM = NML_OUTPUT_TYPE%PARTITION%FORMAT -! - IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( PRTFRM ) THEN - YESXNO = 'YES/--' - ELSE - YESXNO = '---/NO' - END IF - WRITE (NDSO,6945) IPRT, YESXNO - END IF + ! Type 6: partitioning + ELSE IF ( J .EQ. 6 ) THEN + IPRT(1) = NML_OUTPUT_TYPE%PARTITION%X0 + IPRT(2) = NML_OUTPUT_TYPE%PARTITION%XN + IPRT(3) = NML_OUTPUT_TYPE%PARTITION%NX + IPRT(4) = NML_OUTPUT_TYPE%PARTITION%Y0 + IPRT(5) = NML_OUTPUT_TYPE%PARTITION%YN + IPRT(6) = NML_OUTPUT_TYPE%PARTITION%NY + PRTFRM = NML_OUTPUT_TYPE%PARTITION%FORMAT + ! + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( PRTFRM ) THEN + YESXNO = 'YES/--' + ELSE + YESXNO = '---/NO' + END IF + WRITE (NDSO,6945) IPRT, YESXNO + END IF #ifdef W3_COU - ! Type 7: coupling - ELSE IF ( J .EQ. 7 ) THEN - FLDOUT = NML_OUTPUT_TYPE%COUPLING%SENT - CALL W3FLGRDFLAG ( NDSO, NDSO, NDSE, FLDOUT, FLG2, & - FLGR2, IAPROC, NAPOUT, IERR ) - IF ( IERR .NE. 0 ) GOTO 2222 - FLDIN = NML_OUTPUT_TYPE%COUPLING%RECEIVED - CPLT0 = NML_OUTPUT_TYPE%COUPLING%COUPLET0 -#endif - - END IF ! J - END IF ! ODAT - END DO ! J - - ! Extra fields to be written in the restart - FLDRST = NML_OUTPUT_TYPE%RESTART%EXTRA - CALL W3FLGRDFLAG ( NDSO, NDSO, NDSE, FLDRST, FLOGR, & - FLOGRR, IAPROC, NAPOUT, IERR ) - IF ( IERR .NE. 0 ) GOTO 2222 - - ! force minimal allocation to avoid memory seg fault - IF ( .NOT.ALLOCATED(X) .AND. NPTS.EQ.0 ) ALLOCATE ( X(1), Y(1), PNAMES(1) ) - -! 2.6 Homogeneous field data - - IF ( FLHOM ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) & - 'Homogeneous field data (and moving grid) ...' - - NH(-7) = NML_HOMOG_COUNT%N_IC1 - NH(-6) = NML_HOMOG_COUNT%N_IC2 - NH(-5) = NML_HOMOG_COUNT%N_IC3 - NH(-4) = NML_HOMOG_COUNT%N_IC4 - NH(-3) = NML_HOMOG_COUNT%N_IC5 - NH(-2) = NML_HOMOG_COUNT%N_MDN - NH(-1) = NML_HOMOG_COUNT%N_MTH - NH(0) = NML_HOMOG_COUNT%N_MVS - NH(1) = NML_HOMOG_COUNT%N_LEV - NH(2) = NML_HOMOG_COUNT%N_CUR - NH(3) = NML_HOMOG_COUNT%N_WND - NH(4) = NML_HOMOG_COUNT%N_ICE - NH(5) = NML_HOMOG_COUNT%N_TAU - NH(6) = NML_HOMOG_COUNT%N_RHO - NH(10) = NML_HOMOG_COUNT%N_MOV -! - N_TOT = NML_HOMOG_COUNT%N_TOT -! - DO J=JFIRST,10 - IF ( NH(J) .GT. NHMAX ) GOTO 2006 - END DO + ! Type 7: coupling + ELSE IF ( J .EQ. 7 ) THEN + FLDOUT = NML_OUTPUT_TYPE%COUPLING%SENT + CALL W3FLGRDFLAG ( NDSO, NDSO, NDSE, FLDOUT, FLG2, & + FLGR2, IAPROC, NAPOUT, IERR ) + IF ( IERR .NE. 0 ) GOTO 2222 + FLDIN = NML_OUTPUT_TYPE%COUPLING%RECEIVED + CPLT0 = NML_OUTPUT_TYPE%COUPLING%COUPLET0 +#endif + + END IF ! J + END IF ! ODAT + END DO ! J + + ! Extra fields to be written in the restart + FLDRST = NML_OUTPUT_TYPE%RESTART%EXTRA + CALL W3FLGRDFLAG ( NDSO, NDSO, NDSE, FLDRST, FLOGR, & + FLOGRR, IAPROC, NAPOUT, IERR ) + IF ( IERR .NE. 0 ) GOTO 2222 + + ! force minimal allocation to avoid memory seg fault + IF ( .NOT.ALLOCATED(X) .AND. NPTS.EQ.0 ) ALLOCATE ( X(1), Y(1), PNAMES(1) ) + + ! 2.6 Homogeneous field data + + IF ( FLHOM ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) & + 'Homogeneous field data (and moving grid) ...' + + NH(-7) = NML_HOMOG_COUNT%N_IC1 + NH(-6) = NML_HOMOG_COUNT%N_IC2 + NH(-5) = NML_HOMOG_COUNT%N_IC3 + NH(-4) = NML_HOMOG_COUNT%N_IC4 + NH(-3) = NML_HOMOG_COUNT%N_IC5 + NH(-2) = NML_HOMOG_COUNT%N_MDN + NH(-1) = NML_HOMOG_COUNT%N_MTH + NH(0) = NML_HOMOG_COUNT%N_MVS + NH(1) = NML_HOMOG_COUNT%N_LEV + NH(2) = NML_HOMOG_COUNT%N_CUR + NH(3) = NML_HOMOG_COUNT%N_WND + NH(4) = NML_HOMOG_COUNT%N_ICE + NH(5) = NML_HOMOG_COUNT%N_TAU + NH(6) = NML_HOMOG_COUNT%N_RHO + NH(10) = NML_HOMOG_COUNT%N_MOV + ! + N_TOT = NML_HOMOG_COUNT%N_TOT + ! + DO J=JFIRST,10 + IF ( NH(J) .GT. NHMAX ) GOTO 2006 + END DO - ! Store homogeneous fields - IF ( N_TOT .GT. 0 ) THEN - IHH(:)=0 - DO IH=1,N_TOT - READ(NML_HOMOG_INPUT(IH)%NAME,*) IDTST - SELECT CASE (IDTST) - CASE ('IC1') - J=-7 - CASE ('IC2') - J=-6 - CASE ('IC3') - J=-5 - CASE ('IC4') - J=-4 - CASE ('IC5') - J=-3 - CASE ('MDN') - J=-2 - CASE ('MTH') - J=-1 - CASE ('MVS') - J=0 - CASE ('LEV') - J=1 - CASE ('CUR') - J=2 - CASE ('WND') - J=3 - CASE ('ICE') - J=4 - CASE ('TAU') - J=5 - CASE ('RHO') - J=6 - CASE ('MOV') - J=10 - CASE DEFAULT - GOTO 2062 - END SELECT - IHH(J)=IHH(J)+1 - READ(NML_HOMOG_INPUT(IH)%DATE,*) THO(:,J,IHH(J)) - HA(IHH(J),J) = NML_HOMOG_INPUT(IH)%VALUE1 - HD(IHH(J),J) = NML_HOMOG_INPUT(IH)%VALUE2 - HS(IHH(J),J) = NML_HOMOG_INPUT(IH)%VALUE3 - END DO - END IF + ! Store homogeneous fields + IF ( N_TOT .GT. 0 ) THEN + IHH(:)=0 + DO IH=1,N_TOT + READ(NML_HOMOG_INPUT(IH)%NAME,*) IDTST + SELECT CASE (IDTST) + CASE ('IC1') + J=-7 + CASE ('IC2') + J=-6 + CASE ('IC3') + J=-5 + CASE ('IC4') + J=-4 + CASE ('IC5') + J=-3 + CASE ('MDN') + J=-2 + CASE ('MTH') + J=-1 + CASE ('MVS') + J=0 + CASE ('LEV') + J=1 + CASE ('CUR') + J=2 + CASE ('WND') + J=3 + CASE ('ICE') + J=4 + CASE ('TAU') + J=5 + CASE ('RHO') + J=6 + CASE ('MOV') + J=10 + CASE DEFAULT + GOTO 2062 + END SELECT + IHH(J)=IHH(J)+1 + READ(NML_HOMOG_INPUT(IH)%DATE,*) THO(:,J,IHH(J)) + HA(IHH(J),J) = NML_HOMOG_INPUT(IH)%VALUE1 + HD(IHH(J),J) = NML_HOMOG_INPUT(IH)%VALUE2 + HS(IHH(J),J) = NML_HOMOG_INPUT(IH)%VALUE3 + END DO + END IF #ifdef W3_O7 - DO J=JFIRST, 10 - IF ( FLH(J) .AND. IAPROC.EQ.NAPOUT ) THEN - WRITE (NDSO,952) NH(J), IDFLDS(J) - DO I=1, NH(J) - IF ( ( J .LE. 1 ) .OR. ( J .EQ. 4 ) .OR. & - ( J .EQ. 6 ) ) THEN - WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & - HA(I,J) - ELSE IF ( ( J .EQ. 2 ) .OR. ( J .EQ. 5 ) .OR. & - ( J .EQ. 10 ) ) THEN - WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & - HA(I,J), HD(I,J) - ELSE IF ( J .EQ. 3 ) THEN - WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & - HA(I,J), HD(I,J), HS(I,J) - END IF - END DO + DO J=JFIRST, 10 + IF ( FLH(J) .AND. IAPROC.EQ.NAPOUT ) THEN + WRITE (NDSO,952) NH(J), IDFLDS(J) + DO I=1, NH(J) + IF ( ( J .LE. 1 ) .OR. ( J .EQ. 4 ) .OR. & + ( J .EQ. 6 ) ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J) + ELSE IF ( ( J .EQ. 2 ) .OR. ( J .EQ. 5 ) .OR. & + ( J .EQ. 10 ) ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J), HD(I,J) + ELSE IF ( J .EQ. 3 ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J), HD(I,J), HS(I,J) END IF END DO + END IF + END DO #endif -! - IF ( ( FLH(-7) .AND. (NH(-7).EQ.0) ) .OR. & - ( FLH(-6) .AND. (NH(-6).EQ.0) ) .OR. & - ( FLH(-5) .AND. (NH(-5).EQ.0) ) .OR. & - ( FLH(-4) .AND. (NH(-4).EQ.0) ) .OR. & - ( FLH(-3) .AND. (NH(-3).EQ.0) ) .OR. & - ( FLH(-2) .AND. (NH(-2).EQ.0) ) .OR. & - ( FLH(-1) .AND. (NH(-1).EQ.0) ) .OR. & - ( FLH(0) .AND. (NH(0).EQ.0) ) .OR. & - ( FLH(1) .AND. (NH(1).EQ.0) ) .OR. & - ( FLH(2) .AND. (NH(2).EQ.0) ) .OR. & - ( FLH(3) .AND. (NH(3).EQ.0) ) .OR. & - ( FLH(4) .AND. (NH(4).EQ.0) ) .OR. & - ( FLH(5) .AND. (NH(5).EQ.0) ) .OR. & - ( FLH(6) .AND. (NH(6).EQ.0) ) .OR. & - ( FLH(10) .AND. (NH(10).EQ.0) ) ) GOTO 2007 -! - END IF ! FLHOM - - - END IF ! FLGNML - - - -! -! process old ww3_shel.inp format -! - IF (.NOT. FLGNML) THEN - - OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_shel.inp',STATUS='OLD',IOSTAT=IERR) - REWIND (NDSI) -!AR: I changed the error handling for err=2002, see commit message ... - READ (NDSI,'(A)') COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR - -! 2.1 forcing flags - - FLH(-7:10) = .FALSE. - DO J=JFIRST, 9 - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - IF ( J .LE. 6 ) THEN - READ (NDSI,*) FLAGTFC(J), FLH(J) - ELSE - READ (NDSI,*) FLAGTFC(J) - END IF - END DO + ! + IF ( ( FLH(-7) .AND. (NH(-7).EQ.0) ) .OR. & + ( FLH(-6) .AND. (NH(-6).EQ.0) ) .OR. & + ( FLH(-5) .AND. (NH(-5).EQ.0) ) .OR. & + ( FLH(-4) .AND. (NH(-4).EQ.0) ) .OR. & + ( FLH(-3) .AND. (NH(-3).EQ.0) ) .OR. & + ( FLH(-2) .AND. (NH(-2).EQ.0) ) .OR. & + ( FLH(-1) .AND. (NH(-1).EQ.0) ) .OR. & + ( FLH(0) .AND. (NH(0).EQ.0) ) .OR. & + ( FLH(1) .AND. (NH(1).EQ.0) ) .OR. & + ( FLH(2) .AND. (NH(2).EQ.0) ) .OR. & + ( FLH(3) .AND. (NH(3).EQ.0) ) .OR. & + ( FLH(4) .AND. (NH(4).EQ.0) ) .OR. & + ( FLH(5) .AND. (NH(5).EQ.0) ) .OR. & + ( FLH(6) .AND. (NH(6).EQ.0) ) .OR. & + ( FLH(10) .AND. (NH(10).EQ.0) ) ) GOTO 2007 + ! + END IF ! FLHOM + + + END IF ! FLGNML + + + + ! + ! process old ww3_shel.inp format + ! + IF (.NOT. FLGNML) THEN + + OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_shel.inp',STATUS='OLD',IOSTAT=IERR) + REWIND (NDSI) + !AR: I changed the error handling for err=2002, see commit message ... + READ (NDSI,'(A)') COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR + + ! 2.1 forcing flags + + FLH(-7:10) = .FALSE. + DO J=JFIRST, 9 + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + IF ( J .LE. 6 ) THEN + READ (NDSI,*) FLAGTFC(J), FLH(J) + ELSE + READ (NDSI,*) FLAGTFC(J) + END IF + END DO - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,920) - DO J=JFIRST, 9 - IF (FLAGTFC(J).EQ.'T') THEN - INFLAGS1(J)=.TRUE. - FLAGSC(J)=.FALSE. - END IF - IF (FLAGTFC(J).EQ.'F') THEN - INFLAGS1(J)=.FALSE. - FLAGSC(J)=.FALSE. - END IF - IF (FLAGTFC(J).EQ.'C') THEN - INFLAGS1(J)=.TRUE. - FLAGSC(J)=.TRUE. - END IF - IF ( J .LE. 6 ) THEN - FLH(J) = FLH(J) .AND. INFLAGS1(J) - END IF - IF ( INFLAGS1(J) ) THEN - YESXNO = 'YES/--' - ELSE - YESXNO = '---/NO' - END IF - IF ( FLH(J) ) THEN - STRNG = '(homogeneous field) ' - ELSE IF ( FLAGSC(J) ) THEN - STRNG = '(coupling field) ' - ELSE - STRNG = ' ' - END IF - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,921) IDFLDS(J), YESXNO, STRNG - END DO + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,920) + DO J=JFIRST, 9 + IF (FLAGTFC(J).EQ.'T') THEN + INFLAGS1(J)=.TRUE. + FLAGSC(J)=.FALSE. + END IF + IF (FLAGTFC(J).EQ.'F') THEN + INFLAGS1(J)=.FALSE. + FLAGSC(J)=.FALSE. + END IF + IF (FLAGTFC(J).EQ.'C') THEN + INFLAGS1(J)=.TRUE. + FLAGSC(J)=.TRUE. + END IF + IF ( J .LE. 6 ) THEN + FLH(J) = FLH(J) .AND. INFLAGS1(J) + END IF + IF ( INFLAGS1(J) ) THEN + YESXNO = 'YES/--' + ELSE + YESXNO = '---/NO' + END IF + IF ( FLH(J) ) THEN + STRNG = '(homogeneous field) ' + ELSE IF ( FLAGSC(J) ) THEN + STRNG = '(coupling field) ' + ELSE + STRNG = ' ' + END IF + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,921) IDFLDS(J), YESXNO, STRNG + END DO #ifdef W3_COU - IF (FLAGSC(1) .AND. INFLAGS1(2) .AND. .NOT. FLAGSC(2)) GOTO 2102 - IF (FLAGSC(2) .AND. INFLAGS1(1) .AND. .NOT. FLAGSC(1)) GOTO 2102 + IF (FLAGSC(1) .AND. INFLAGS1(2) .AND. .NOT. FLAGSC(2)) GOTO 2102 + IF (FLAGSC(2) .AND. INFLAGS1(1) .AND. .NOT. FLAGSC(1)) GOTO 2102 #endif #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2b' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2b' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif -! - INFLAGS1(10) = .FALSE. + ! + INFLAGS1(10) = .FALSE. #ifdef W3_MGW - INFLAGS1(10) = .TRUE. + INFLAGS1(10) = .TRUE. #endif #ifdef W3_MGP - INFLAGS1(10) = .TRUE. + INFLAGS1(10) = .TRUE. #endif #ifdef W3_MGW - FLH(10) = .TRUE. + FLH(10) = .TRUE. #endif #ifdef W3_MGP - FLH(10) = .TRUE. -#endif - IF ( INFLAGS1(10) .AND. IAPROC.EQ.NAPOUT ) & - WRITE (NDSO,921) IDFLDS(10), 'YES/--', ' ' -! - FLFLG = INFLAGS1(-7) .OR. INFLAGS1(-6) .OR. INFLAGS1(-5) .OR. INFLAGS1(-4) & - .OR. INFLAGS1(-3) .OR. INFLAGS1(-2) .OR. INFLAGS1(-1) & - .OR. INFLAGS1(0) .OR. INFLAGS1(1) .OR. INFLAGS1(2) & - .OR. INFLAGS1(3) .OR. INFLAGS1(4) .OR. INFLAGS1(5) & - .OR. INFLAGS1(6) .OR. INFLAGS1(7) .OR. INFLAGS1(8) & - .OR. INFLAGS1(9) - FLHOM = FLH(-7) .OR. FLH(-6) .OR. FLH(-5) .OR. FLH(-4) & - .OR. FLH(-3) .OR. FLH(-2) .OR. FLH(-1) .OR. FLH(0) & - .OR. FLH(1) .OR. FLH(2) .OR. FLH(3) .OR. FLH(4) & - .OR. FLH(5) .OR. FLH(6) .OR. FLH(10) -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,922) -! -! INFLAGS2 is just "initial value of INFLAGS1", i.e. does *not* get -! changed when model reads last record of ice.ww3 - INFLAGS2=INFLAGS1 + FLH(10) = .TRUE. +#endif + IF ( INFLAGS1(10) .AND. IAPROC.EQ.NAPOUT ) & + WRITE (NDSO,921) IDFLDS(10), 'YES/--', ' ' + ! + FLFLG = INFLAGS1(-7) .OR. INFLAGS1(-6) .OR. INFLAGS1(-5) .OR. INFLAGS1(-4) & + .OR. INFLAGS1(-3) .OR. INFLAGS1(-2) .OR. INFLAGS1(-1) & + .OR. INFLAGS1(0) .OR. INFLAGS1(1) .OR. INFLAGS1(2) & + .OR. INFLAGS1(3) .OR. INFLAGS1(4) .OR. INFLAGS1(5) & + .OR. INFLAGS1(6) .OR. INFLAGS1(7) .OR. INFLAGS1(8) & + .OR. INFLAGS1(9) + FLHOM = FLH(-7) .OR. FLH(-6) .OR. FLH(-5) .OR. FLH(-4) & + .OR. FLH(-3) .OR. FLH(-2) .OR. FLH(-1) .OR. FLH(0) & + .OR. FLH(1) .OR. FLH(2) .OR. FLH(3) .OR. FLH(4) & + .OR. FLH(5) .OR. FLH(6) .OR. FLH(10) + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,922) + ! + ! INFLAGS2 is just "initial value of INFLAGS1", i.e. does *not* get + ! changed when model reads last record of ice.ww3 + INFLAGS2=INFLAGS1 #ifdef W3_T - WRITE (NDST,9020) FLFLG, INFLAGS1, FLHOM, FLH + WRITE (NDST,9020) FLFLG, INFLAGS1, FLHOM, FLH #endif -! 2.2 Time setup + ! 2.2 Time setup - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*) TIME0 + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*) TIME0 #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2c' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2c' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*) TIMEN -! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*) TIMEN + ! #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2d' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2d' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif -! 2.3 Domain setup + ! 2.3 Domain setup - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*) IOSTYP + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*) IOSTYP #ifdef W3_PDLIB - IF (IOSTYP .gt. 1) THEN - WRITE(*,*) 'IOSTYP not supported in domain decomposition mode' - CALL EXTCDE ( 6666 ) - ENDIF -#endif - CALL W3IOGR ( 'GRID', NDSF(7) ) - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF + IF (IOSTYP .gt. 1) THEN + WRITE(*,*) 'IOSTYP not supported in domain decomposition mode' + CALL EXTCDE ( 6666 ) + ENDIF +#endif + CALL W3IOGR ( 'GRID', NDSF(7) ) + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF -! 2.4 Output dates + ! 2.4 Output dates - NPTS = 0 - NOTYPE = 6 + NPTS = 0 + NOTYPE = 6 #ifdef W3_COU - NOTYPE = 7 -#endif - DO J = 1, NOTYPE + NOTYPE = 7 +#endif + DO J = 1, NOTYPE + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + ! + ! CHECKPOINT + IF(J .EQ. 4) THEN + ODAT(38)=0 + WORDS(1:7)='' + READ (NDSI,'(A)') LINEIN + READ(LINEIN,*,iostat=ierr) WORDS + READ(WORDS( 1 ), * ) ODAT(16) + READ(WORDS( 2 ), * ) ODAT(17) + READ(WORDS( 3 ), * ) ODAT(18) + READ(WORDS( 4 ), * ) ODAT(19) + READ(WORDS( 5 ), * ) ODAT(20) + IF (WORDS(6) .EQ. 'T') THEN CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -! -! CHECKPOINT - IF(J .EQ. 4) THEN - ODAT(38)=0 - WORDS(1:7)='' - READ (NDSI,'(A)') LINEIN - READ(LINEIN,*,iostat=ierr) WORDS - READ(WORDS( 1 ), * ) ODAT(16) - READ(WORDS( 2 ), * ) ODAT(17) - READ(WORDS( 3 ), * ) ODAT(18) - READ(WORDS( 4 ), * ) ODAT(19) - READ(WORDS( 5 ), * ) ODAT(20) - IF (WORDS(6) .EQ. 'T') THEN - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=2001,ERR=2002)(ODAT(I),I=5*(8-1)+1,5*8) - WRITE(*,*)(ODAT(I),I=5*(8-1)+1,5*8) - END IF - IF (WORDS(7) .EQ. 'T') THEN - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,'(A)',END=2001,ERR=2002) FLDRST - END IF - CALL W3FLGRDFLAG ( NDSO, NDSO, NDSE, FLDRST, FLOGR, & - FLOGRR, IAPROC, NAPOUT, IERR ) - IF ( IERR .NE. 0 ) GOTO 2222 - ELSE -! -!INLINE NEW VARIABLE TO READ IF PRESENT OFILES(J), IF NOT ==0 -! READ (NDSI,*) (ODAT(I),I=5*(J-1)+1,5*J) -! READ (NDSI,*,IOSTAT=IERR) (ODAT(I),I=5*(J-1)+1,5*J),OFILES(J) + READ (NDSI,*,END=2001,ERR=2002)(ODAT(I),I=5*(8-1)+1,5*8) + WRITE(*,*)(ODAT(I),I=5*(8-1)+1,5*8) + END IF + IF (WORDS(7) .EQ. 'T') THEN + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,'(A)',END=2001,ERR=2002) FLDRST + END IF + CALL W3FLGRDFLAG ( NDSO, NDSO, NDSE, FLDRST, FLOGR, & + FLOGRR, IAPROC, NAPOUT, IERR ) + IF ( IERR .NE. 0 ) GOTO 2222 + ELSE + ! + !INLINE NEW VARIABLE TO READ IF PRESENT OFILES(J), IF NOT ==0 + ! READ (NDSI,*) (ODAT(I),I=5*(J-1)+1,5*J) + ! READ (NDSI,*,IOSTAT=IERR) (ODAT(I),I=5*(J-1)+1,5*J),OFILES(J) IF(J .LE. 2) THEN WORDS(1:6)='' -! READ (NDSI,*,END=2001,ERR=2002)(ODAT(I),I=5*(J-1)+1,5*J),OFILES(J) + ! READ (NDSI,*,END=2001,ERR=2002)(ODAT(I),I=5*(J-1)+1,5*J),OFILES(J) READ (NDSI,'(A)') LINEIN READ(LINEIN,*,iostat=ierr) WORDS -! + ! IF(J .EQ. 1) THEN READ(WORDS( 1 ), * ) ODAT(1) READ(WORDS( 2 ), * ) ODAT(2) @@ -1411,13 +1411,13 @@ PROGRAM W3SHEL WORDS(1:6)='' READ (NDSI,'(A)') LINEIN READ(LINEIN,*,iostat=ierr) WORDS - + READ(WORDS( 1 ), * ) ODAT(31) READ(WORDS( 2 ), * ) ODAT(32) READ(WORDS( 3 ), * ) ODAT(33) READ(WORDS( 4 ), * ) ODAT(34) READ(WORDS( 5 ), * ) ODAT(35) - + IF (WORDS(6) .EQ. 'T') THEN CPLT0 = .TRUE. ELSE @@ -1428,1571 +1428,1571 @@ PROGRAM W3SHEL OFILES(J)=0 READ (NDSI,*,END=2001,ERR=2002)(ODAT(I),I=5*(J-1)+1,5*J) END IF -! WRITE(*,*) 'OFILES(J)= ', OFILES(J),J -! - ODAT(5*(J-1)+3) = MAX ( 0 , ODAT(5*(J-1)+3) ) -! + ! WRITE(*,*) 'OFILES(J)= ', OFILES(J),J + ! + ODAT(5*(J-1)+3) = MAX ( 0 , ODAT(5*(J-1)+3) ) + ! #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL NOTTYPE', J - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL NOTTYPE', J + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif -! + ! -! 2.5 Output types + ! 2.5 Output types - IF ( ODAT(5*(J-1)+3) .NE. 0 ) THEN + IF ( ODAT(5*(J-1)+3) .NE. 0 ) THEN -! Type 1: fields of mean wave parameters - IF ( J .EQ. 1 ) THEN - CALL W3READFLGRD ( NDSI, NDSO, 9, NDSEN, COMSTR, FLGD, & - FLGRD, IAPROC, NAPOUT, IERR ) - IF ( IERR .NE. 0 ) GOTO 2222 + ! Type 1: fields of mean wave parameters + IF ( J .EQ. 1 ) THEN + CALL W3READFLGRD ( NDSI, NDSO, 9, NDSEN, COMSTR, FLGD, & + FLGRD, IAPROC, NAPOUT, IERR ) + IF ( IERR .NE. 0 ) GOTO 2222 -! Type 2: point output - ELSE IF ( J .EQ. 2 ) THEN - DO ILOOP=1,2 - IF ( ILOOP .EQ. 1 ) THEN - NDSI2 = NDSI - IF ( IAPROC .EQ. 1 ) OPEN & - (NDSS,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') - ELSE - NDSI2 = NDSS + ! Type 2: point output + ELSE IF ( J .EQ. 2 ) THEN + DO ILOOP=1,2 + IF ( ILOOP .EQ. 1 ) THEN + NDSI2 = NDSI + IF ( IAPROC .EQ. 1 ) OPEN & + (NDSS,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') + ELSE + NDSI2 = NDSS #ifdef W3_MPI - CALL MPI_BARRIER (MPI_COMM,IERR_MPI) + CALL MPI_BARRIER (MPI_COMM,IERR_MPI) #endif - OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') - REWIND (NDSS) -! - IF ( .NOT.ALLOCATED(X) ) THEN - IF ( NPTS.GT.0 ) THEN - ALLOCATE ( X(NPTS), Y(NPTS), PNAMES(NPTS) ) - ELSE - ALLOCATE ( X(1), Y(1), PNAMES(1) ) - GOTO 2054 - END IF + OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') + REWIND (NDSS) + ! + IF ( .NOT.ALLOCATED(X) ) THEN + IF ( NPTS.GT.0 ) THEN + ALLOCATE ( X(NPTS), Y(NPTS), PNAMES(NPTS) ) + ELSE + ALLOCATE ( X(1), Y(1), PNAMES(1) ) + GOTO 2054 END IF END IF -! - NPTS = 0 - DO - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI2,*) XX, YY, PN - IF ( ILOOP.EQ.1 .AND. IAPROC.EQ.1 ) THEN - BACKSPACE (NDSI) - READ (NDSI,'(A)') LINE - WRITE (NDSS,'(A)') LINE - END IF - IF ( INDEX(PN,"STOPSTRING").NE.0 ) EXIT - NPTS = NPTS + 1 - IF ( ILOOP .EQ. 1 ) CYCLE - X(NPTS) = XX - Y(NPTS) = YY - PNAMES(NPTS) = PN - IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( FLAGLL ) THEN - IF ( NPTS .EQ. 1 ) THEN - WRITE (NDSO,2945) & - FACTOR*XX, FACTOR*YY, PN - ELSE - WRITE (NDSO,2946) NPTS, & - FACTOR*XX, FACTOR*YY, PN - END IF + END IF + ! + NPTS = 0 + DO + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI2,*) XX, YY, PN + IF ( ILOOP.EQ.1 .AND. IAPROC.EQ.1 ) THEN + BACKSPACE (NDSI) + READ (NDSI,'(A)') LINE + WRITE (NDSS,'(A)') LINE + END IF + IF ( INDEX(PN,"STOPSTRING").NE.0 ) EXIT + NPTS = NPTS + 1 + IF ( ILOOP .EQ. 1 ) CYCLE + X(NPTS) = XX + Y(NPTS) = YY + PNAMES(NPTS) = PN + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( FLAGLL ) THEN + IF ( NPTS .EQ. 1 ) THEN + WRITE (NDSO,2945) & + FACTOR*XX, FACTOR*YY, PN + ELSE + WRITE (NDSO,2946) NPTS, & + FACTOR*XX, FACTOR*YY, PN + END IF + ELSE + IF ( NPTS .EQ. 1 ) THEN + WRITE (NDSO,2955) & + FACTOR*XX, FACTOR*YY, PN ELSE - IF ( NPTS .EQ. 1 ) THEN - WRITE (NDSO,2955) & - FACTOR*XX, FACTOR*YY, PN - ELSE - WRITE (NDSO,2956) NPTS, & - FACTOR*XX, FACTOR*YY, PN - END IF + WRITE (NDSO,2956) NPTS, & + FACTOR*XX, FACTOR*YY, PN END IF END IF - END DO -! - IF ( IAPROC.EQ.1 .AND. ILOOP.EQ.1 ) CLOSE (NDSS) + END IF END DO -! - IF ( NPTS.EQ.0 .AND. IAPROC.EQ.NAPOUT ) & - WRITE (NDSO,2947) - IF ( IAPROC .EQ. 1 ) THEN + ! + IF ( IAPROC.EQ.1 .AND. ILOOP.EQ.1 ) CLOSE (NDSS) + END DO + ! + IF ( NPTS.EQ.0 .AND. IAPROC.EQ.NAPOUT ) & + WRITE (NDSO,2947) + IF ( IAPROC .EQ. 1 ) THEN #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) #endif - CLOSE (NDSS,STATUS='DELETE') - ELSE - CLOSE (NDSS) + CLOSE (NDSS,STATUS='DELETE') + ELSE + CLOSE (NDSS) #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) #endif - END IF -! + END IF + ! -! Type 3: track output - ELSE IF ( J .EQ. 3 ) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*) TFLAGI -! - IF ( .NOT. TFLAGI ) NDS(11) = -NDS(11) - IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( .NOT. TFLAGI ) THEN - WRITE (NDSO,3945) 'input', 'UNFORMATTED' - ELSE - WRITE (NDSO,3945) 'input', 'FORMATTED' - END IF + ! Type 3: track output + ELSE IF ( J .EQ. 3 ) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*) TFLAGI + ! + IF ( .NOT. TFLAGI ) NDS(11) = -NDS(11) + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( .NOT. TFLAGI ) THEN + WRITE (NDSO,3945) 'input', 'UNFORMATTED' + ELSE + WRITE (NDSO,3945) 'input', 'FORMATTED' END IF + END IF -! Type 6: partitioning - ELSE IF ( J .EQ. 6 ) THEN -! IPRT: IX0, IXN, IXS, IY0, IYN, IYS - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*) IPRT, PRTFRM -! - IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( PRTFRM ) THEN - YESXNO = 'YES/--' - ELSE - YESXNO = '---/NO' - END IF - WRITE (NDSO,6945) IPRT, YESXNO + ! Type 6: partitioning + ELSE IF ( J .EQ. 6 ) THEN + ! IPRT: IX0, IXN, IXS, IY0, IYN, IYS + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*) IPRT, PRTFRM + ! + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( PRTFRM ) THEN + YESXNO = 'YES/--' + ELSE + YESXNO = '---/NO' END IF + WRITE (NDSO,6945) IPRT, YESXNO + END IF #ifdef W3_COU - ! Type 7: coupling - ELSE IF ( J .EQ. 7 ) THEN - CALL W3READFLGRD ( NDSI, NDSO, NDSS, NDSEN, COMSTR, FLG2, & - FLGR2, IAPROC, NAPOUT, IERR ) - IF ( IERR .NE. 0 ) GOTO 2222 - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,'(A)',END=2001,ERR=2002,IOSTAT=IERR) FLDIN + ! Type 7: coupling + ELSE IF ( J .EQ. 7 ) THEN + CALL W3READFLGRD ( NDSI, NDSO, NDSS, NDSEN, COMSTR, FLG2, & + FLGR2, IAPROC, NAPOUT, IERR ) + IF ( IERR .NE. 0 ) GOTO 2222 + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,'(A)',END=2001,ERR=2002,IOSTAT=IERR) FLDIN #endif - END IF ! J - END IF ! ODAT - END IF ! IF J=4 - END DO ! J + END IF ! J + END IF ! ODAT + END IF ! IF J=4 + END DO ! J - ! force minimal allocation to avoid memory seg fault - IF ( .NOT.ALLOCATED(X) .AND. NPTS.EQ.0 ) ALLOCATE ( X(1), Y(1), PNAMES(1) ) + ! force minimal allocation to avoid memory seg fault + IF ( .NOT.ALLOCATED(X) .AND. NPTS.EQ.0 ) ALLOCATE ( X(1), Y(1), PNAMES(1) ) -! 2.6 Homogeneous field data + ! 2.6 Homogeneous field data - IF ( FLHOM ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) & - 'Homogeneous field data (and moving grid) ...' - NH = 0 -! - ! Start of loop - DO - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*) IDTST - - - ! Exit if illegal id - IF ( IDTST.NE.IDSTR(-7) .AND. IDTST.NE.IDSTR(-6) .AND. & - IDTST.NE.IDSTR(-5) .AND. IDTST.NE.IDSTR(-4) .AND. & - IDTST.NE.IDSTR(-3) .AND. IDTST.NE.IDSTR(-2) .AND. & - IDTST.NE.IDSTR(-1) .AND. IDTST.NE.IDSTR(0) .AND. & - IDTST.NE.IDSTR(1) .AND. IDTST.NE.IDSTR(2) .AND. & - IDTST.NE.IDSTR(3) .AND. IDTST.NE.IDSTR(4) .AND. & - IDTST.NE.IDSTR(5) .AND. IDTST.NE.IDSTR(6) .AND. & - IDTST.NE.IDSTR(10) .AND. IDTST.NE.'STP' ) GOTO 2005 - - ! Stop conditions - IF ( IDTST .EQ. 'STP' ) THEN - EXIT - ELSE - BACKSPACE ( NDSI ) - END IF + IF ( FLHOM ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) & + 'Homogeneous field data (and moving grid) ...' + NH = 0 + ! + ! Start of loop + DO + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*) IDTST + + + ! Exit if illegal id + IF ( IDTST.NE.IDSTR(-7) .AND. IDTST.NE.IDSTR(-6) .AND. & + IDTST.NE.IDSTR(-5) .AND. IDTST.NE.IDSTR(-4) .AND. & + IDTST.NE.IDSTR(-3) .AND. IDTST.NE.IDSTR(-2) .AND. & + IDTST.NE.IDSTR(-1) .AND. IDTST.NE.IDSTR(0) .AND. & + IDTST.NE.IDSTR(1) .AND. IDTST.NE.IDSTR(2) .AND. & + IDTST.NE.IDSTR(3) .AND. IDTST.NE.IDSTR(4) .AND. & + IDTST.NE.IDSTR(5) .AND. IDTST.NE.IDSTR(6) .AND. & + IDTST.NE.IDSTR(10) .AND. IDTST.NE.'STP' ) GOTO 2005 + + ! Stop conditions + IF ( IDTST .EQ. 'STP' ) THEN + EXIT + ELSE + BACKSPACE ( NDSI ) + END IF - ! Store data - DO J=LBOUND(IDSTR,1), 10 - IF ( IDTST .EQ. IDSTR(J) ) THEN - NH(J) = NH(J) + 1 - IF ( NH(J) .GT. NHMAX ) GOTO 2006 - IF ( J .LE. 1 ) THEN ! water levels, etc. : get HA - READ (NDSI,*) IDTST, & - THO(1,J,NH(J)), THO(2,J,NH(J)), & - HA(NH(J),J) - ELSE IF ( J .EQ. 2 ) THEN ! currents: get HA and HD - READ (NDSI,*) IDTST, & - THO(1,J,NH(J)), THO(2,J,NH(J)), & - HA(NH(J),J), HD(NH(J),J) - ELSE IF ( J .EQ. 3 ) THEN ! wind: get HA HD and HS - READ (NDSI,*) IDTST, & - THO(1,J,NH(J)), THO(2,J,NH(J)), & - HA(NH(J),J), HD(NH(J),J), HS(NH(J),J) - ELSE IF ( J .EQ. 4 ) THEN ! ice - READ (NDSI,*) IDTST, & - THO(1,J,NH(J)), THO(2,J,NH(J)), & - HA(NH(J),J) - ELSE IF ( J .EQ. 5 ) THEN ! atmospheric momentum - READ (NDSI,*) IDTST, & - THO(1,J,NH(J)), THO(2,J,NH(J)), & - HA(NH(J),J), HD(NH(J),j) - ELSE IF ( J .EQ. 6 ) THEN ! air density - READ (NDSI,*) IDTST, & - THO(1,J,NH(J)), THO(2,J,NH(J)), & - HA(NH(J),J) - ELSE IF ( J .EQ. 10 ) THEN ! mov: HA and HD - READ (NDSI,*) IDTST, & - THO(1,J,NH(J)), THO(2,J,NH(J)), & - HA(NH(J),J), HD(NH(J),J) - END IF - END IF - END DO - END DO + ! Store data + DO J=LBOUND(IDSTR,1), 10 + IF ( IDTST .EQ. IDSTR(J) ) THEN + NH(J) = NH(J) + 1 + IF ( NH(J) .GT. NHMAX ) GOTO 2006 + IF ( J .LE. 1 ) THEN ! water levels, etc. : get HA + READ (NDSI,*) IDTST, & + THO(1,J,NH(J)), THO(2,J,NH(J)), & + HA(NH(J),J) + ELSE IF ( J .EQ. 2 ) THEN ! currents: get HA and HD + READ (NDSI,*) IDTST, & + THO(1,J,NH(J)), THO(2,J,NH(J)), & + HA(NH(J),J), HD(NH(J),J) + ELSE IF ( J .EQ. 3 ) THEN ! wind: get HA HD and HS + READ (NDSI,*) IDTST, & + THO(1,J,NH(J)), THO(2,J,NH(J)), & + HA(NH(J),J), HD(NH(J),J), HS(NH(J),J) + ELSE IF ( J .EQ. 4 ) THEN ! ice + READ (NDSI,*) IDTST, & + THO(1,J,NH(J)), THO(2,J,NH(J)), & + HA(NH(J),J) + ELSE IF ( J .EQ. 5 ) THEN ! atmospheric momentum + READ (NDSI,*) IDTST, & + THO(1,J,NH(J)), THO(2,J,NH(J)), & + HA(NH(J),J), HD(NH(J),j) + ELSE IF ( J .EQ. 6 ) THEN ! air density + READ (NDSI,*) IDTST, & + THO(1,J,NH(J)), THO(2,J,NH(J)), & + HA(NH(J),J) + ELSE IF ( J .EQ. 10 ) THEN ! mov: HA and HD + READ (NDSI,*) IDTST, & + THO(1,J,NH(J)), THO(2,J,NH(J)), & + HA(NH(J),J), HD(NH(J),J) + END IF + END IF + END DO + END DO #ifdef W3_MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 3' call getMallocInfo(mallinfos) call printMallInfo(IAPROC,mallInfos) #endif -! + ! #ifdef W3_O7 - DO J=JFIRST, 10 - IF ( FLH(J) .AND. IAPROC.EQ.NAPOUT ) THEN - WRITE (NDSO,952) NH(J), IDFLDS(J) - DO I=1, NH(J) - IF ( ( J .LE. 1 ) .OR. ( J .EQ. 4 ) .OR. & - ( J .EQ. 6 ) ) THEN - WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & - HA(I,J) - ELSE IF ( ( J .EQ. 2 ) .OR. ( J .EQ. 5 ) .OR. & - ( J .EQ. 10 ) ) THEN - WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & - HA(I,J), HD(I,J) - ELSE IF ( J .EQ. 3 ) THEN - WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & - HA(I,J), HD(I,J), HS(I,J) - END IF - END DO + DO J=JFIRST, 10 + IF ( FLH(J) .AND. IAPROC.EQ.NAPOUT ) THEN + WRITE (NDSO,952) NH(J), IDFLDS(J) + DO I=1, NH(J) + IF ( ( J .LE. 1 ) .OR. ( J .EQ. 4 ) .OR. & + ( J .EQ. 6 ) ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J) + ELSE IF ( ( J .EQ. 2 ) .OR. ( J .EQ. 5 ) .OR. & + ( J .EQ. 10 ) ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J), HD(I,J) + ELSE IF ( J .EQ. 3 ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J), HD(I,J), HS(I,J) END IF END DO + END IF + END DO #endif -! -! - IF ( ( FLH(-7) .AND. (NH(-7).EQ.0) ) .OR. & - ( FLH(-6) .AND. (NH(-6).EQ.0) ) .OR. & - ( FLH(-5) .AND. (NH(-5).EQ.0) ) .OR. & - ( FLH(-4) .AND. (NH(-4).EQ.0) ) .OR. & - ( FLH(-3) .AND. (NH(-3).EQ.0) ) .OR. & - ( FLH(-2) .AND. (NH(-2).EQ.0) ) .OR. & - ( FLH(-1) .AND. (NH(-1).EQ.0) ) .OR. & - ( FLH(0) .AND. (NH(0).EQ.0) ) .OR. & - ( FLH(1) .AND. (NH(1).EQ.0) ) .OR. & - ( FLH(2) .AND. (NH(2).EQ.0) ) .OR. & - ( FLH(3) .AND. (NH(3).EQ.0) ) .OR. & - ( FLH(4) .AND. (NH(4).EQ.0) ) .OR. & - ( FLH(5) .AND. (NH(5).EQ.0) ) .OR. & - ( FLH(6) .AND. (NH(6).EQ.0) ) .OR. & - ( FLH(10) .AND. (NH(10).EQ.0) ) ) GOTO 2007 -! - END IF ! FLHOM + ! + ! + IF ( ( FLH(-7) .AND. (NH(-7).EQ.0) ) .OR. & + ( FLH(-6) .AND. (NH(-6).EQ.0) ) .OR. & + ( FLH(-5) .AND. (NH(-5).EQ.0) ) .OR. & + ( FLH(-4) .AND. (NH(-4).EQ.0) ) .OR. & + ( FLH(-3) .AND. (NH(-3).EQ.0) ) .OR. & + ( FLH(-2) .AND. (NH(-2).EQ.0) ) .OR. & + ( FLH(-1) .AND. (NH(-1).EQ.0) ) .OR. & + ( FLH(0) .AND. (NH(0).EQ.0) ) .OR. & + ( FLH(1) .AND. (NH(1).EQ.0) ) .OR. & + ( FLH(2) .AND. (NH(2).EQ.0) ) .OR. & + ( FLH(3) .AND. (NH(3).EQ.0) ) .OR. & + ( FLH(4) .AND. (NH(4).EQ.0) ) .OR. & + ( FLH(5) .AND. (NH(5).EQ.0) ) .OR. & + ( FLH(6) .AND. (NH(6).EQ.0) ) .OR. & + ( FLH(10) .AND. (NH(10).EQ.0) ) ) GOTO 2007 + ! + END IF ! FLHOM - END IF + END IF -! -! ---------------- -! + ! + ! ---------------- + ! -! 2.1 input fields + ! 2.1 input fields -! 2.1.a Opening field and data files + ! 2.1.a Opening field and data files - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,950) - IF ( FLFLG ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) & - 'Preparing input files ...' -! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,950) + IF ( FLFLG ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) & + 'Preparing input files ...' + ! - DO J=JFIRST, 6 - IF ( INFLAGS1(J) .AND. .NOT. FLAGSC(J)) THEN - IF ( FLH(J) ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,954) IDFLDS(J) - ELSE - FLAGTIDE = 0 - CALL W3FLDO ('READ', IDSTR(J), NDSF(J), NDST, & - NDSEN, NX, NY, GTYPE, & - IERR, FPRE=TRIM(FNMPRE), TIDEFLAGIN=FLAGTIDE ) - IF ( IERR .NE. 0 ) GOTO 2222 + DO J=JFIRST, 6 + IF ( INFLAGS1(J) .AND. .NOT. FLAGSC(J)) THEN + IF ( FLH(J) ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,954) IDFLDS(J) + ELSE + FLAGTIDE = 0 + CALL W3FLDO ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, NX, NY, GTYPE, & + IERR, FPRE=TRIM(FNMPRE), TIDEFLAGIN=FLAGTIDE ) + IF ( IERR .NE. 0 ) GOTO 2222 #ifdef W3_TIDE - IF (FLAGTIDE.GT.0.AND.J.EQ.1) FLAGSTIDE(1)=.TRUE. - IF (FLAGTIDE.GT.0.AND.J.EQ.2) FLAGSTIDE(2)=.TRUE. + IF (FLAGTIDE.GT.0.AND.J.EQ.1) FLAGSTIDE(1)=.TRUE. + IF (FLAGTIDE.GT.0.AND.J.EQ.2) FLAGSTIDE(2)=.TRUE. #endif - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,955) IDFLDS(J) - END IF - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,954) IDFLDS(J) - END IF - END DO -! - DO J=7, 9 - IF ( INFLAGS1(J) .AND. .NOT. FLAGSC(J)) THEN - CALL W3FLDO ('READ', IDSTR(J), NDSF(J), NDST, NDSEN, & - RCLD(J), NY, NODATA(J), & - IERR, FPRE=TRIM(FNMPRE) ) - IF ( IERR .NE. 0 ) GOTO 2222 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,956) IDFLDS(J),& - RCLD(J), NODATA(J) - ELSE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,954) IDFLDS(J) - END IF - END DO -! - END IF ! FLFLG + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,955) IDFLDS(J) + END IF + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,954) IDFLDS(J) + END IF + END DO + ! + DO J=7, 9 + IF ( INFLAGS1(J) .AND. .NOT. FLAGSC(J)) THEN + CALL W3FLDO ('READ', IDSTR(J), NDSF(J), NDST, NDSEN, & + RCLD(J), NY, NODATA(J), & + IERR, FPRE=TRIM(FNMPRE) ) + IF ( IERR .NE. 0 ) GOTO 2222 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,956) IDFLDS(J),& + RCLD(J), NODATA(J) + ELSE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,954) IDFLDS(J) + END IF + END DO + ! + END IF ! FLFLG #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 4' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif -! 2.2 Time setup + ! 2.2 Time setup - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,930) - CALL STME21 ( TIME0 , DTME21 ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,931) DTME21 - TIME = TIME0 - CALL STME21 ( TIMEN , DTME21 ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,932) DTME21 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,930) + CALL STME21 ( TIME0 , DTME21 ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,931) DTME21 + TIME = TIME0 + CALL STME21 ( TIMEN , DTME21 ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,932) DTME21 #ifdef W3_OASIS - TIME00 = TIME0 - TIMEEND = TIMEN + TIME00 = TIME0 + TIMEEND = TIMEN #endif #ifdef W3_NL5 - QI5TBEG = TIME0 + QI5TBEG = TIME0 #endif -! - DTTST = DSEC21 ( TIME0 , TIMEN ) - IF ( DTTST .LE. 0. ) GOTO 2003 + ! + DTTST = DSEC21 ( TIME0 , TIMEN ) + IF ( DTTST .LE. 0. ) GOTO 2003 -! 2.3 Domain setup + ! 2.3 Domain setup - IOSTYP = MAX ( 0 , MIN ( 3 , IOSTYP ) ) + IOSTYP = MAX ( 0 , MIN ( 3 , IOSTYP ) ) #ifdef W3_PDLIB - IF (IOSTYP .gt. 1) THEN - WRITE(*,*) 'IOSTYP not supported in domain decomposition mode' - CALL EXTCDE ( 6666 ) - ENDIF -#endif - - IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( IOSTYP .EQ. 0 ) THEN - WRITE (NDSO,940) 'No dedicated output process, ' // & - 'parallel file system required.' - ELSE IF ( IOSTYP .EQ. 1 ) THEN - WRITE (NDSO,940) 'No dedicated output process, ' // & - 'any file system.' - ELSE IF ( IOSTYP .EQ. 2 ) THEN - WRITE (NDSO,940) 'Single dedicated output process.' - ELSE IF ( IOSTYP .EQ. 3 ) THEN - WRITE (NDSO,940) 'Multiple dedicated output processes.' + IF (IOSTYP .gt. 1) THEN + WRITE(*,*) 'IOSTYP not supported in domain decomposition mode' + CALL EXTCDE ( 6666 ) + ENDIF +#endif + + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( IOSTYP .EQ. 0 ) THEN + WRITE (NDSO,940) 'No dedicated output process, ' // & + 'parallel file system required.' + ELSE IF ( IOSTYP .EQ. 1 ) THEN + WRITE (NDSO,940) 'No dedicated output process, ' // & + 'any file system.' + ELSE IF ( IOSTYP .EQ. 2 ) THEN + WRITE (NDSO,940) 'Single dedicated output process.' + ELSE IF ( IOSTYP .EQ. 3 ) THEN + WRITE (NDSO,940) 'Multiple dedicated output processes.' + ELSE + WRITE (NDSO,940) 'IOSTYP NOT RECOGNIZED' + END IF + END IF + + + ! 2.4 Output dates + + DO J = 1, NOTYPE + ! + IF ( ODAT(5*(J-1)+3) .NE. 0 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,941) J, IDOTYP(J) + TTIME(1) = ODAT(5*(J-1)+1) + TTIME(2) = ODAT(5*(J-1)+2) + CALL STME21 ( TTIME , DTME21 ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) DTME21 + TTIME(1) = ODAT(5*(J-1)+4) + TTIME(2) = ODAT(5*(J-1)+5) + CALL STME21 ( TTIME , DTME21 ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) DTME21 + TTIME(1) = 0 + TTIME(2) = 0 + DTTST = REAL ( ODAT(5*(J-1)+3) ) + CALL TICK21 ( TTIME , DTTST ) + CALL STME21 ( TTIME , DTME21 ) + IF ( ( ODAT(5*(J-1)+1) .NE. ODAT(5*(J-1)+4) .OR. & + ODAT(5*(J-1)+2) .NE. ODAT(5*(J-1)+5) ) .AND. & + IAPROC .EQ. NAPOUT ) THEN + IF ( DTME21(9:9) .NE. '0' ) THEN + WRITE (NDSO,1944) DTME21( 9:19) + ELSE IF ( DTME21(10:10) .NE. '0' ) THEN + WRITE (NDSO,2944) DTME21(10:19) ELSE - WRITE (NDSO,940) 'IOSTYP NOT RECOGNIZED' + WRITE (NDSO,3944) DTME21(12:19) END IF END IF - - -! 2.4 Output dates - - DO J = 1, NOTYPE -! - IF ( ODAT(5*(J-1)+3) .NE. 0 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,941) J, IDOTYP(J) - TTIME(1) = ODAT(5*(J-1)+1) - TTIME(2) = ODAT(5*(J-1)+2) - CALL STME21 ( TTIME , DTME21 ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) DTME21 - TTIME(1) = ODAT(5*(J-1)+4) - TTIME(2) = ODAT(5*(J-1)+5) - CALL STME21 ( TTIME , DTME21 ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) DTME21 - TTIME(1) = 0 - TTIME(2) = 0 - DTTST = REAL ( ODAT(5*(J-1)+3) ) - CALL TICK21 ( TTIME , DTTST ) - CALL STME21 ( TTIME , DTME21 ) - IF ( ( ODAT(5*(J-1)+1) .NE. ODAT(5*(J-1)+4) .OR. & - ODAT(5*(J-1)+2) .NE. ODAT(5*(J-1)+5) ) .AND. & - IAPROC .EQ. NAPOUT ) THEN - IF ( DTME21(9:9) .NE. '0' ) THEN - WRITE (NDSO,1944) DTME21( 9:19) - ELSE IF ( DTME21(10:10) .NE. '0' ) THEN - WRITE (NDSO,2944) DTME21(10:19) - ELSE - WRITE (NDSO,3944) DTME21(12:19) - END IF - END IF - END IF - END DO -! -! CHECKPOINT - J=8 - IF (ODAT(38) .NE. 0) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,941) J, IDOTYP(J) - TTIME(1) = ODAT(5*(J-1)+1) - TTIME(2) = ODAT(5*(J-1)+2) - CALL STME21 ( TTIME , DTME21 ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) DTME21 - TTIME(1) = ODAT(5*(J-1)+4) - TTIME(2) = ODAT(5*(J-1)+5) - CALL STME21 ( TTIME , DTME21 ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) DTME21 - TTIME(1) = 0 - TTIME(2) = 0 - DTTST = REAL ( ODAT(5*(J-1)+3) ) - CALL TICK21 ( TTIME , DTTST ) - CALL STME21 ( TTIME , DTME21 ) - IF ( ( ODAT(5*(J-1)+1) .NE. ODAT(5*(J-1)+4) .OR. & - ODAT(5*(J-1)+2) .NE. ODAT(5*(J-1)+5) ) .AND. & - IAPROC .EQ. NAPOUT ) THEN - IF ( DTME21(9:9) .NE. '0' ) THEN - WRITE (NDSO,1944) DTME21( 9:19) - ELSE IF ( DTME21(10:10) .NE. '0' ) THEN - WRITE (NDSO,2944) DTME21(10:19) - ELSE - WRITE (NDSO,3944) DTME21(12:19) - END IF - END IF + END IF + END DO + ! + ! CHECKPOINT + J=8 + IF (ODAT(38) .NE. 0) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,941) J, IDOTYP(J) + TTIME(1) = ODAT(5*(J-1)+1) + TTIME(2) = ODAT(5*(J-1)+2) + CALL STME21 ( TTIME , DTME21 ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) DTME21 + TTIME(1) = ODAT(5*(J-1)+4) + TTIME(2) = ODAT(5*(J-1)+5) + CALL STME21 ( TTIME , DTME21 ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,943) DTME21 + TTIME(1) = 0 + TTIME(2) = 0 + DTTST = REAL ( ODAT(5*(J-1)+3) ) + CALL TICK21 ( TTIME , DTTST ) + CALL STME21 ( TTIME , DTME21 ) + IF ( ( ODAT(5*(J-1)+1) .NE. ODAT(5*(J-1)+4) .OR. & + ODAT(5*(J-1)+2) .NE. ODAT(5*(J-1)+5) ) .AND. & + IAPROC .EQ. NAPOUT ) THEN + IF ( DTME21(9:9) .NE. '0' ) THEN + WRITE (NDSO,1944) DTME21( 9:19) + ELSE IF ( DTME21(10:10) .NE. '0' ) THEN + WRITE (NDSO,2944) DTME21(10:19) + ELSE + WRITE (NDSO,3944) DTME21(12:19) END IF -! -! 2.5 Output types + END IF + END IF + ! + ! 2.5 Output types #ifdef W3_T - WRITE (NDST,9040) ODAT - WRITE (NDST,9041) FLGRD - WRITE (NDST,9042) IPRT, PRTFRM -#endif - -! -! For outputs with non-zero time step, check dates : -! If output ends before run start OR output starts after run end, -! deactivate output cleanly with output time step = 0 -! This is usefull for IOSTYP=3 (Multiple dedicated output processes) -! to avoid the definition of dedicated proc. for unused output. -! - DO J = 1, NOTYPE - DTTST = DSEC21 ( TIME0 , ODAT(5*(J-1)+4:5*(J-1)+5) ) - IF ( DTTST .LT. 0 ) THEN - ODAT(5*(J-1)+3) = 0 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,8945) TRIM(IDOTYP(J)) - CONTINUE - END IF - DTTST = DSEC21 ( ODAT(5*(J-1)+1:5*(J-1)+2), TIMEN ) - IF ( DTTST .LT. 0 ) THEN - ODAT(5*(J-1)+3) = 0 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,8945) TRIM(IDOTYP(J)) - CONTINUE - END IF - END DO -! -! CHECKPOINT - J = 8 - DTTST = DSEC21 ( TIME0 , ODAT(5*(J-1)+4:5*(J-1)+5) ) - IF ( DTTST .LT. 0 ) THEN - ODAT(5*(J-1)+3) = 0 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,8945) TRIM(IDOTYP(J)) - CONTINUE - END IF - DTTST = DSEC21 ( ODAT(5*(J-1)+1:5*(J-1)+2), TIMEN ) - IF ( DTTST .LT. 0 ) THEN - ODAT(5*(J-1)+3) = 0 - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,8945) TRIM(IDOTYP(J)) - CONTINUE - END IF -! + WRITE (NDST,9040) ODAT + WRITE (NDST,9041) FLGRD + WRITE (NDST,9042) IPRT, PRTFRM +#endif + + ! + ! For outputs with non-zero time step, check dates : + ! If output ends before run start OR output starts after run end, + ! deactivate output cleanly with output time step = 0 + ! This is usefull for IOSTYP=3 (Multiple dedicated output processes) + ! to avoid the definition of dedicated proc. for unused output. + ! + DO J = 1, NOTYPE + DTTST = DSEC21 ( TIME0 , ODAT(5*(J-1)+4:5*(J-1)+5) ) + IF ( DTTST .LT. 0 ) THEN + ODAT(5*(J-1)+3) = 0 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,8945) TRIM(IDOTYP(J)) + CONTINUE + END IF + DTTST = DSEC21 ( ODAT(5*(J-1)+1:5*(J-1)+2), TIMEN ) + IF ( DTTST .LT. 0 ) THEN + ODAT(5*(J-1)+3) = 0 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,8945) TRIM(IDOTYP(J)) + CONTINUE + END IF + END DO + ! + ! CHECKPOINT + J = 8 + DTTST = DSEC21 ( TIME0 , ODAT(5*(J-1)+4:5*(J-1)+5) ) + IF ( DTTST .LT. 0 ) THEN + ODAT(5*(J-1)+3) = 0 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,8945) TRIM(IDOTYP(J)) + CONTINUE + END IF + DTTST = DSEC21 ( ODAT(5*(J-1)+1:5*(J-1)+2), TIMEN ) + IF ( DTTST .LT. 0 ) THEN + ODAT(5*(J-1)+3) = 0 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,8945) TRIM(IDOTYP(J)) + CONTINUE + END IF + ! #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 5' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Initializations -! + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Initializations + ! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) 'Wave model ...' -! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) 'Wave model ...' + ! #ifdef W3_TIDE - IF (FLAGSTIDE(1).OR.FLAGSTIDE(2)) THEN - CALL VUF_SET_PARAMETERS - IF (FLAGSTIDE(1)) CALL W3FLDTIDE1 ( 'READ', NDSF(1), NDST, NDSEN, NX, NY, IDSTR(1), IERR ) - IF (FLAGSTIDE(2)) CALL W3FLDTIDE1 ( 'READ', NDSF(2), NDST, NDSEN, NX, NY, IDSTR(2), IERR ) - END IF + IF (FLAGSTIDE(1).OR.FLAGSTIDE(2)) THEN + CALL VUF_SET_PARAMETERS + IF (FLAGSTIDE(1)) CALL W3FLDTIDE1 ( 'READ', NDSF(1), NDST, NDSEN, NX, NY, IDSTR(1), IERR ) + IF (FLAGSTIDE(2)) CALL W3FLDTIDE1 ( 'READ', NDSF(2), NDST, NDSEN, NX, NY, IDSTR(2), IERR ) + END IF #endif -! + ! #ifdef W3_COU - ! Sent coupled fields must be written in the restart when coupling at T+0 - IF (CPLT0) THEN - DO J=1, NOGRP - FLOGR(J) = FLOGR(J) .OR. FLG2(J) - DO I=1, NGRPP - FLOGRR(J,I) = FLOGRR(J,I) .OR. FLGR2(J,I) - END DO - END DO - ENDIF -#endif -! - OARST = ANY(FLOGR) -! - CALL W3INIT ( 1, .FALSE., 'ww3', NDS, NTRACE, ODAT, FLGRD, FLGR2, FLGD, & - FLG2, NPTS, X, Y, PNAMES, IPRT, PRTFRM, MPI_COMM, & - FLAGSTIDEIN=FLAGSTIDE ) -! -! IF (MINVAL(VA) .LT. 0.) THEN -! WRITE(740+IAPROC,*) 'NEGATIVE ACTION SHELL 5', MINVAL(VA) -! CALL FLUSH(740+IAPROC) -! CALL EXTCDE(665) -! ENDIF -! IF (SUM(VA) .NE. SUM(VA)) THEN -! WRITE(740+IAPROC,*) 'NAN in ACTION SHEL1', SUM(VA) -! CALL FLUSH(740+IAPROC) -! CALL EXTCDE(666) -! ENDIF + ! Sent coupled fields must be written in the restart when coupling at T+0 + IF (CPLT0) THEN + DO J=1, NOGRP + FLOGR(J) = FLOGR(J) .OR. FLG2(J) + DO I=1, NGRPP + FLOGRR(J,I) = FLOGRR(J,I) .OR. FLGR2(J,I) + END DO + END DO + ENDIF +#endif + ! + OARST = ANY(FLOGR) + ! + CALL W3INIT ( 1, .FALSE., 'ww3', NDS, NTRACE, ODAT, FLGRD, FLGR2, FLGD, & + FLG2, NPTS, X, Y, PNAMES, IPRT, PRTFRM, MPI_COMM, & + FLAGSTIDEIN=FLAGSTIDE ) + ! + ! IF (MINVAL(VA) .LT. 0.) THEN + ! WRITE(740+IAPROC,*) 'NEGATIVE ACTION SHELL 5', MINVAL(VA) + ! CALL FLUSH(740+IAPROC) + ! CALL EXTCDE(665) + ! ENDIF + ! IF (SUM(VA) .NE. SUM(VA)) THEN + ! WRITE(740+IAPROC,*) 'NAN in ACTION SHEL1', SUM(VA) + ! CALL FLUSH(740+IAPROC) + ! CALL EXTCDE(666) + ! ENDIF #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 5' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif -! + ! #ifdef W3_TIDE - IF (FLAGSTIDE(1)) CALL W3FLDTIDE2 ( 'READ', NDSF(1), NDST, NDSEN, NX, NY, IDSTR(1), 1, IERR ) - IF (FLAGSTIDE(2)) CALL W3FLDTIDE2 ( 'READ', NDSF(2), NDST, NDSEN, NX, NY, IDSTR(2), 1, IERR ) - ALLOCATE(V_ARG(170,1),F_ARG(170,1),U_ARG(170,1)) ! to be removed later ... + IF (FLAGSTIDE(1)) CALL W3FLDTIDE2 ( 'READ', NDSF(1), NDST, NDSEN, NX, NY, IDSTR(1), 1, IERR ) + IF (FLAGSTIDE(2)) CALL W3FLDTIDE2 ( 'READ', NDSF(2), NDST, NDSEN, NX, NY, IDSTR(2), 1, IERR ) + ALLOCATE(V_ARG(170,1),F_ARG(170,1),U_ARG(170,1)) ! to be removed later ... #endif -! - ALLOCATE ( XXX(NX,NY) ) -! + ! + ALLOCATE ( XXX(NX,NY) ) + ! -! + ! #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) -#endif -! - IF ( IAPROC .EQ. NAPOUT ) THEN - CALL DATE_AND_TIME ( VALUES=CLKDT2 ) - END IF -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#endif + ! + IF ( IAPROC .EQ. NAPOUT ) THEN + CALL DATE_AND_TIME ( VALUES=CLKDT2 ) + END IF + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! #ifdef W3_OASIS - ! Initialize L_MASTER, COUPL_COMM - IF ( IAPROC .EQ. 1) THEN - L_MASTER = .TRUE. - ELSE - L_MASTER = .FALSE. - ENDIF - ! Estimate the weights for the spatial interpolation - IF (DTOUT(7).NE.0) THEN - CALL CPL_OASIS_GRID(L_MASTER,MPI_COMM) - CALL CPL_OASIS_DEFINE(NDSO, FLDIN, FLDOUT) - END IF -#endif - - -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6. Model without input -! -! IF (MINVAL(VA) .LT. 0.) THEN -! WRITE(740+IAPROC,*) 'NEGATIVE ACTION SHELL 6', MINVAL(VA) -! CALL FLUSH(740+IAPROC) -! CALL EXTCDE(665) -! ENDIF -! IF (SUM(VA) .NE. SUM(VA)) THEN -! WRITE(740+IAPROC,*) 'NAN in ACTION SHEL2', SUM(VA) -! CALL FLUSH(740+IAPROC) -! CALL EXTCDE(666) -! ENDIF + ! Initialize L_MASTER, COUPL_COMM + IF ( IAPROC .EQ. 1) THEN + L_MASTER = .TRUE. + ELSE + L_MASTER = .FALSE. + ENDIF + ! Estimate the weights for the spatial interpolation + IF (DTOUT(7).NE.0) THEN + CALL CPL_OASIS_GRID(L_MASTER,MPI_COMM) + CALL CPL_OASIS_DEFINE(NDSO, FLDIN, FLDOUT) + END IF +#endif + + + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6. Model without input + ! + ! IF (MINVAL(VA) .LT. 0.) THEN + ! WRITE(740+IAPROC,*) 'NEGATIVE ACTION SHELL 6', MINVAL(VA) + ! CALL FLUSH(740+IAPROC) + ! CALL EXTCDE(665) + ! ENDIF + ! IF (SUM(VA) .NE. SUM(VA)) THEN + ! WRITE(740+IAPROC,*) 'NAN in ACTION SHEL2', SUM(VA) + ! CALL FLUSH(740+IAPROC) + ! CALL EXTCDE(666) + ! ENDIF #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 6' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif - IF ( .NOT. FLFLG ) THEN -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,960) - CALL W3WAVE ( 1, ODAT, TIMEN & + IF ( .NOT. FLFLG ) THEN + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,960) + CALL W3WAVE ( 1, ODAT, TIMEN & #ifdef W3_OASIS - , .TRUE., .FALSE., MPI_COMM, TIMEN & -#endif - ) -! - GOTO 2222 -! - END IF -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 7. Model with input -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,970) -! + , .TRUE., .FALSE., MPI_COMM, TIMEN & +#endif + ) + ! + GOTO 2222 + ! + END IF + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 7. Model with input + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,970) + ! #ifdef W3_OASIS - ! Send coupling fields at the initial time step - IF ( FLOUT(7) .AND. CPLT0 ) THEN + ! Send coupling fields at the initial time step + IF ( FLOUT(7) .AND. CPLT0 ) THEN #endif #ifdef W3_OASACM - CALL SND_FIELDS_TO_ATMOS() + CALL SND_FIELDS_TO_ATMOS() #endif #ifdef W3_OASOCM - CALL SND_FIELDS_TO_OCEAN() + CALL SND_FIELDS_TO_OCEAN() #endif #ifdef W3_OASICM - CALL SND_FIELDS_TO_ICE() + CALL SND_FIELDS_TO_ICE() #endif #ifdef W3_OASIS - END IF -#endif - - 700 CONTINUE -! -! -! 7.a Determine next time interval and input fields -! 7.a.1 Preparation -! - TTIME = TIMEN -! - CALL STME21 ( TIME0 , DTME21 ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,971) DTME21 -! + END IF +#endif + +700 CONTINUE + ! + ! + ! 7.a Determine next time interval and input fields + ! 7.a.1 Preparation + ! + TTIME = TIMEN + ! + CALL STME21 ( TIME0 , DTME21 ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,971) DTME21 + ! #ifdef W3_T - WRITE (NDST,9070) '0-N', TIME0, TTIME, & - IDSTR(-7), INFLAGS1(-7), TI1, & - IDSTR(-6), INFLAGS1(-6), TI2, & - IDSTR(-5), INFLAGS1(-5), TI3, & - IDSTR(-4), INFLAGS1(-4), TI4, & - IDSTR(-3), INFLAGS1(-3), TI5, & - IDSTR(-2), INFLAGS1(-2), TZN, & - IDSTR(-1), INFLAGS1(-1), TTN, & - IDSTR(0), INFLAGS1(0), TVN, & - IDSTR(1), INFLAGS1(1), TLN, & - IDSTR(2), INFLAGS1(2), TC0, TCN, & - IDSTR(3), INFLAGS1(3), TW0, TWN, & - IDSTR(4), INFLAGS1(4), TIN, & - IDSTR(5), INFLAGS1(5), TU0, TUN, & - IDSTR(6), INFLAGS1(6), TR0, TRN, & - IDSTR(7), INFLAGS1(7), T0N, & - IDSTR(8), INFLAGS1(8), T1N, & - IDSTR(9), INFLAGS1(9), T2N, & - IDSTR(10), INFLAGS1(10), TG0, TGN -#endif -! + WRITE (NDST,9070) '0-N', TIME0, TTIME, & + IDSTR(-7), INFLAGS1(-7), TI1, & + IDSTR(-6), INFLAGS1(-6), TI2, & + IDSTR(-5), INFLAGS1(-5), TI3, & + IDSTR(-4), INFLAGS1(-4), TI4, & + IDSTR(-3), INFLAGS1(-3), TI5, & + IDSTR(-2), INFLAGS1(-2), TZN, & + IDSTR(-1), INFLAGS1(-1), TTN, & + IDSTR(0), INFLAGS1(0), TVN, & + IDSTR(1), INFLAGS1(1), TLN, & + IDSTR(2), INFLAGS1(2), TC0, TCN, & + IDSTR(3), INFLAGS1(3), TW0, TWN, & + IDSTR(4), INFLAGS1(4), TIN, & + IDSTR(5), INFLAGS1(5), TU0, TUN, & + IDSTR(6), INFLAGS1(6), TR0, TRN, & + IDSTR(7), INFLAGS1(7), T0N, & + IDSTR(8), INFLAGS1(8), T1N, & + IDSTR(9), INFLAGS1(9), T2N, & + IDSTR(10), INFLAGS1(10), TG0, TGN +#endif + ! #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 7' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) #endif - DO J=JFIRST,10 -! + DO J=JFIRST,10 + ! #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL UPDATE', J - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) -#endif - - IF ( INFLAGS1(J) ) THEN -! -! 7.a.2 Check if update is needed -! - IF (.NOT.FLAGSC(J)) THEN - TTT(1) = TFN(1,J) - TTT(2) = TFN(2,J) - IF ( TTT(1) .EQ. -1 ) THEN - DTTST = 0. - ELSE - DTTST = DSEC21 ( TIME0 , TTT ) - END IF + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL UPDATE', J + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + IF ( INFLAGS1(J) ) THEN + ! + ! 7.a.2 Check if update is needed + ! + IF (.NOT.FLAGSC(J)) THEN + TTT(1) = TFN(1,J) + TTT(2) = TFN(2,J) + IF ( TTT(1) .EQ. -1 ) THEN + DTTST = 0. + ELSE + DTTST = DSEC21 ( TIME0 , TTT ) + END IF #ifdef W3_OASIS - ELSE - IF ( DTOUT(7).NE.0 ) THEN - ! TFN not initialized at TIME=TIME00, using TIME instead - IF(NINT(DSEC21(TIME00,TIME)) == 0) THEN - ID_OASIS_TIME = 0 - DTTST=0. - ELSE - ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TFN(:,J) )) - IF ( NINT(MOD(DSEC21(TIME00,TIME), DTOUT(7))) .EQ. 0 .AND. & - DSEC21 (TFN(:,J), TIMEEND) .GT. 0.0 ) DTTST=0. - ENDIF - ENDIF + ELSE + IF ( DTOUT(7).NE.0 ) THEN + ! TFN not initialized at TIME=TIME00, using TIME instead + IF(NINT(DSEC21(TIME00,TIME)) == 0) THEN + ID_OASIS_TIME = 0 + DTTST=0. + ELSE + ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TFN(:,J) )) + IF ( NINT(MOD(DSEC21(TIME00,TIME), DTOUT(7))) .EQ. 0 .AND. & + DSEC21 (TFN(:,J), TIMEEND) .GT. 0.0 ) DTTST=0. + ENDIF + ENDIF #endif - END IF -! + END IF + ! #ifdef W3_T - WRITE (NDST,9071) IDSTR(J), DTTST + WRITE (NDST,9071) IDSTR(J), DTTST #endif -! -! 7.a.3 Update time and fields / data -! - IF ( DTTST .LE. 0. ) THEN + ! + ! 7.a.3 Update time and fields / data + ! + IF ( DTTST .LE. 0. ) THEN #ifdef W3_TIDE - IF ((FLLEVTIDE .AND.(J.EQ.1)).OR.(FLCURTIDE.AND.(J.EQ.2))) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,974) IDFLDS(J) - ELSE + IF ((FLLEVTIDE .AND.(J.EQ.1)).OR.(FLCURTIDE.AND.(J.EQ.2))) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,974) IDFLDS(J) + ELSE #endif - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,972) IDFLDS(J) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,972) IDFLDS(J) #ifdef W3_TIDE - END IF + END IF #endif -! -! IC1 : (in context of IC3 & IC2, this is ice thickness) - IF ( J .EQ. -7 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TTT, XXX, XXX, XXX, TI1, XXX, XXX, ICEP1, IERR) - ELSE + ! + ! IC1 : (in context of IC3 & IC2, this is ice thickness) + IF ( J .EQ. -7 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TTT, XXX, XXX, XXX, TI1, XXX, XXX, ICEP1, IERR) + ELSE #ifdef W3_OASIS - COUPL_COMM = MPI_COMM + COUPL_COMM = MPI_COMM #endif #ifdef W3_OASICM - IF (FLAGSC(J)) FLAGSCI = .TRUE. - IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 + IF (FLAGSC(J)) FLAGSCI = .TRUE. + IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 #endif - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TTT, XXX, XXX, XXX, TI1, XXX, XXX, ICEP1, & - IERR, FLAGSC(J) & + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TTT, XXX, XXX, XXX, TI1, XXX, XXX, ICEP1, & + IERR, FLAGSC(J) & #ifdef W3_OASICM - , COUPL_COMM & + , COUPL_COMM & #endif - ) - END IF - IF ( IERR .LT. 0 ) FLLST_ALL(J) = .TRUE. - -! IC2 : (in context of IC3, this is ice viscosity) - ELSE IF ( J .EQ. -6 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TTT, XXX, XXX, XXX, TI2, XXX, XXX, ICEP2, IERR) - ELSE - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TTT, XXX, XXX, XXX, TI2, XXX, XXX, ICEP2, & - IERR, FLAGSC(J)) - END IF - IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. - -! IC3 : (in context of IC3, this is ice density) - ELSE IF ( J .EQ. -5 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TTT, XXX, XXX, XXX, TI3, XXX, XXX, ICEP3, IERR) - ELSE - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TTT, XXX, XXX, XXX, TI3, XXX, XXX, ICEP3, & - IERR, FLAGSC(J)) - END IF - IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. - -! IC4 : (in context of IC3, this is ice modulus) - ELSE IF ( J .EQ. -4 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TTT, XXX, XXX, XXX, TI4, XXX, XXX, ICEP4, IERR) - ELSE - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TTT, XXX, XXX, XXX, TI4, XXX, XXX, ICEP4, & - IERR, FLAGSC(J)) - END IF - IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. - -! IC5 : ice flow diam. - ELSE IF ( J .EQ. -3 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TTT, XXX, XXX, XXX, TI5, XXX, XXX, ICEP5, IERR) - ELSE + ) + END IF + IF ( IERR .LT. 0 ) FLLST_ALL(J) = .TRUE. + + ! IC2 : (in context of IC3, this is ice viscosity) + ELSE IF ( J .EQ. -6 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TTT, XXX, XXX, XXX, TI2, XXX, XXX, ICEP2, IERR) + ELSE + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TTT, XXX, XXX, XXX, TI2, XXX, XXX, ICEP2, & + IERR, FLAGSC(J)) + END IF + IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. + + ! IC3 : (in context of IC3, this is ice density) + ELSE IF ( J .EQ. -5 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TTT, XXX, XXX, XXX, TI3, XXX, XXX, ICEP3, IERR) + ELSE + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TTT, XXX, XXX, XXX, TI3, XXX, XXX, ICEP3, & + IERR, FLAGSC(J)) + END IF + IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. + + ! IC4 : (in context of IC3, this is ice modulus) + ELSE IF ( J .EQ. -4 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TTT, XXX, XXX, XXX, TI4, XXX, XXX, ICEP4, IERR) + ELSE + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TTT, XXX, XXX, XXX, TI4, XXX, XXX, ICEP4, & + IERR, FLAGSC(J)) + END IF + IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. + + ! IC5 : ice flow diam. + ELSE IF ( J .EQ. -3 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TTT, XXX, XXX, XXX, TI5, XXX, XXX, ICEP5, IERR) + ELSE #ifdef W3_OASIS - COUPL_COMM = MPI_COMM + COUPL_COMM = MPI_COMM #endif #ifdef W3_OASICM - IF (FLAGSC(J)) FLAGSCI = .TRUE. - IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 + IF (FLAGSC(J)) FLAGSCI = .TRUE. + IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 #endif - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TTT, XXX, XXX, XXX, TI5, XXX, XXX, ICEP5, & - IERR, FLAGSC(J) & + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TTT, XXX, XXX, XXX, TI5, XXX, XXX, ICEP5, & + IERR, FLAGSC(J) & #ifdef W3_OASICM - , COUPL_COMM & + , COUPL_COMM & #endif - ) - END IF - IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. - -! MUD1 : mud density - ELSE IF ( J .EQ. -2 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TTT, XXX, XXX, XXX, TZN, XXX, XXX, MUDD, IERR) - ELSE - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TTT, XXX, XXX, XXX, TZN, XXX, XXX, MUDD, & - IERR, FLAGSC(J)) - END IF - IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. - -! MUD2 : mud thickness - ELSE IF ( J .EQ. -1 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TTT, XXX, XXX, XXX, TTN, XXX, XXX, MUDT, IERR) - ELSE - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TTT, XXX, XXX, XXX, TTN, XXX, XXX, MUDT, & - IERR, FLAGSC(J)) - END IF - IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. - -! MUD3 : mud viscosity - ELSE IF ( J .EQ. 0 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TTT, XXX, XXX, XXX, TVN, XXX, XXX, MUDV, IERR) + ) + END IF + IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. + + ! MUD1 : mud density + ELSE IF ( J .EQ. -2 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TTT, XXX, XXX, XXX, TZN, XXX, XXX, MUDD, IERR) + ELSE + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TTT, XXX, XXX, XXX, TZN, XXX, XXX, MUDD, & + IERR, FLAGSC(J)) + END IF + IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. + + ! MUD2 : mud thickness + ELSE IF ( J .EQ. -1 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TTT, XXX, XXX, XXX, TTN, XXX, XXX, MUDT, IERR) + ELSE + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TTT, XXX, XXX, XXX, TTN, XXX, XXX, MUDT, & + IERR, FLAGSC(J)) + END IF + IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. + + ! MUD3 : mud viscosity + ELSE IF ( J .EQ. 0 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TTT, XXX, XXX, XXX, TVN, XXX, XXX, MUDV, IERR) + ELSE + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TTT, XXX, XXX, XXX, TVN, XXX, XXX, MUDV, & + IERR, FLAGSC(J)) + END IF + IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. + + ! LEV : water levels + ELSE IF ( J .EQ. 1 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TTT, XXX, XXX, XXX, TLN, XXX, XXX, WLEV, IERR) + ELSE +#ifdef W3_TIDE + IF ( FLLEVTIDE ) THEN + IERR=0 + IF ( TLN(1) .EQ. -1 ) THEN + TLN = TIME ELSE - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TTT, XXX, XXX, XXX, TVN, XXX, XXX, MUDV, & - IERR, FLAGSC(J)) + CALL TICK21 ( TLN, TIDE_DT ) END IF - IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. - -! LEV : water levels - ELSE IF ( J .EQ. 1 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TTT, XXX, XXX, XXX, TLN, XXX, XXX, WLEV, IERR) - ELSE -#ifdef W3_TIDE - IF ( FLLEVTIDE ) THEN - IERR=0 - IF ( TLN(1) .EQ. -1 ) THEN - TLN = TIME - ELSE - CALL TICK21 ( TLN, TIDE_DT ) - END IF - ELSE + ELSE #endif #ifdef W3_OASIS - COUPL_COMM = MPI_COMM + COUPL_COMM = MPI_COMM #endif #ifdef W3_OASOCM - IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 + IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 #endif - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TTT, XXX, XXX, XXX, TLN, XXX, XXX, WLEV, & - IERR, FLAGSC(J) & + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TTT, XXX, XXX, XXX, TLN, XXX, XXX, WLEV, & + IERR, FLAGSC(J) & #ifdef W3_OASOCM - , COUPL_COMM & + , COUPL_COMM & #endif - ) + ) #ifdef W3_TIDE - END IF + END IF #endif - END IF - IF ( IERR .LT. 0 ) FLLSTL = .TRUE. -!could be: IF ( IERR .LT. 0 ) FLLST_ALL(J) = .TRUE. - -! CUR : currents - ELSE IF ( J .EQ. 2 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TC0, CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) -! + END IF + IF ( IERR .LT. 0 ) FLLSTL = .TRUE. + !could be: IF ( IERR .LT. 0 ) FLLST_ALL(J) = .TRUE. + + ! CUR : currents + ELSE IF ( J .EQ. 2 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TC0, CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) + ! #ifdef W3_SMC - !!Li Reshape the CX0/N CY0/N space for sea-point only current. - !!Li JGLi26Jun2018. - ELSE IF( FSWND ) THEN - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & - NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TC0, & - CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) - !!Li + !!Li Reshape the CX0/N CY0/N space for sea-point only current. + !!Li JGLi26Jun2018. + ELSE IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TC0, & + CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) + !!Li #endif - ELSE + ELSE #ifdef W3_TIDE - IF ( FLCURTIDE ) THEN - IERR=0 - IF ( TCN(1) .EQ. -1 ) THEN - TCN = TIME - END IF - TC0(:) = TCN(:) - CALL TICK21 ( TCN, TIDE_DT ) - ELSE + IF ( FLCURTIDE ) THEN + IERR=0 + IF ( TCN(1) .EQ. -1 ) THEN + TCN = TIME + END IF + TC0(:) = TCN(:) + CALL TICK21 ( TCN, TIDE_DT ) + ELSE #endif #ifdef W3_OASIS - COUPL_COMM = MPI_COMM + COUPL_COMM = MPI_COMM #endif #ifdef W3_OASOCM - IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 + IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 #endif - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TC0, CX0, CY0, XXX, TCN, CXN, CYN, XXX, & - IERR, FLAGSC(J) & + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TC0, CX0, CY0, XXX, TCN, CXN, CYN, XXX, & + IERR, FLAGSC(J) & #ifdef W3_OASOCM - , COUPL_COMM & + , COUPL_COMM & #endif - ) + ) #ifdef W3_TIDE - END IF + END IF #endif - END IF + END IF -! WND : winds - ELSE IF ( J .EQ. 3 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TW0, WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) -! + ! WND : winds + ELSE IF ( J .EQ. 3 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TW0, WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) + ! #ifdef W3_SMC - !!Li Reshape the WX0/N WY0/N space for sea-point only wind. - !!Li JGLi26Jun2018. - ELSE IF( FSWND ) THEN - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & - NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TW0, & - WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) - !!Li + !!Li Reshape the WX0/N WY0/N space for sea-point only wind. + !!Li JGLi26Jun2018. + ELSE IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TW0, & + WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) + !!Li #endif - ELSE + ELSE #ifdef W3_OASIS - COUPL_COMM = MPI_COMM + COUPL_COMM = MPI_COMM #endif #ifdef W3_OASACM - IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 + IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 #endif - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TW0, WX0, WY0, DT0, TWN, WXN, WYN, DTN, & - IERR, FLAGSC(J) & + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TW0, WX0, WY0, DT0, TWN, WXN, WYN, DTN, & + IERR, FLAGSC(J) & #ifdef W3_OASACM - , COUPL_COMM & + , COUPL_COMM & #endif - ) - END IF + ) + END IF -! ICE : ice conc. - ELSE IF ( J .EQ. 4 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TTT, XXX, XXX, XXX, TIN, XXX, BERGI, ICEI, IERR) - ELSE + ! ICE : ice conc. + ELSE IF ( J .EQ. 4 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TTT, XXX, XXX, XXX, TIN, XXX, BERGI, ICEI, IERR) + ELSE #ifdef W3_OASIS - COUPL_COMM = MPI_COMM + COUPL_COMM = MPI_COMM #endif #ifdef W3_OASICM - IF (FLAGSC(J)) FLAGSCI = .TRUE. - IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 + IF (FLAGSC(J)) FLAGSCI = .TRUE. + IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 #endif - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TTT, XXX, XXX, XXX, TIN, XXX, BERGI, ICEI, & - IERR, FLAGSC(J) & + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TTT, XXX, XXX, XXX, TIN, XXX, BERGI, ICEI, & + IERR, FLAGSC(J) & #ifdef W3_OASICM - , COUPL_COMM & + , COUPL_COMM & #endif - ) - IF ( IERR .LT. 0 ) FLLSTI = .TRUE. -!could be: IF ( IERR .LT. 0 ) FLLST_ALL(J) = .TRUE. - END IF + ) + IF ( IERR .LT. 0 ) FLLSTI = .TRUE. + !could be: IF ( IERR .LT. 0 ) FLLST_ALL(J) = .TRUE. + END IF -! TAU : atmospheric momentum - ELSE IF ( J .EQ. 5 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TU0, UX0, UY0, XXX, TUN, UXN, UYN, XXX, IERR) -! + ! TAU : atmospheric momentum + ELSE IF ( J .EQ. 5 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TU0, UX0, UY0, XXX, TUN, UXN, UYN, XXX, IERR) + ! #ifdef W3_SMC - !!Li Reshape the UX0/N UY0/N space for sea-point only current. - !!Li JGLi26Jun2018. - ELSE IF( FSWND ) THEN - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & - NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TU0, & - UX0, UY0, XXX, TUN, UXN, UYN, XXX, IERR) - !!Li + !!Li Reshape the UX0/N UY0/N space for sea-point only current. + !!Li JGLi26Jun2018. + ELSE IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TU0, & + UX0, UY0, XXX, TUN, UXN, UYN, XXX, IERR) + !!Li #endif - ELSE + ELSE #ifdef W3_OASIS - COUPL_COMM = MPI_COMM + COUPL_COMM = MPI_COMM #endif #ifdef W3_OASACM - IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 + IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 #endif - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TU0, UX0, UY0, XXX, TUN, UXN, UYN, XXX, & - IERR, FLAGSC(J) & + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TU0, UX0, UY0, XXX, TUN, UXN, UYN, XXX, & + IERR, FLAGSC(J) & #ifdef W3_OASACM - , COUPL_COMM & + , COUPL_COMM & #endif - ) - END IF + ) + END IF -! RHO : air density - ELSE IF ( J .EQ. 6 ) THEN - IF ( FLH(J) ) THEN - CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & - TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& - TR0, XXX, XXX, RH0, TRN, XXX, XXX, RHN, IERR) + ! RHO : air density + ELSE IF ( J .EQ. 6 ) THEN + IF ( FLH(J) ) THEN + CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & + TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& + TR0, XXX, XXX, RH0, TRN, XXX, XXX, RHN, IERR) #ifdef W3_SMC - !!Li Reshape the RH0/N space for sea-point only current. - !!Li JGLi26Jun2018. - ELSE IF( FSWND ) THEN - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & - NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TR0, & - XXX, XXX, RH0, TRN, XXX, XXX, RHN, IERR) - !!Li + !!Li Reshape the RH0/N space for sea-point only current. + !!Li JGLi26Jun2018. + ELSE IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TR0, & + XXX, XXX, RH0, TRN, XXX, XXX, RHN, IERR) + !!Li #endif - ELSE + ELSE #ifdef W3_OASIS - COUPL_COMM = MPI_COMM + COUPL_COMM = MPI_COMM #endif #ifdef W3_OASACM - IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 + IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 #endif - CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & - NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & - TR0, XXX, XXX, RH0, TRN, XXX, XXX, RHN, & - IERR, FLAGSC(J) & + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & + NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & + TR0, XXX, XXX, RH0, TRN, XXX, XXX, RHN, & + IERR, FLAGSC(J) & #ifdef W3_OASACM - , COUPL_COMM & + , COUPL_COMM & #endif - ) - IF ( IERR .LT. 0 ) FLLSTR = .TRUE. - END IF - -! Assim data - ELSE IF ( J .EQ. 7 ) THEN - CALL W3FLDD ('SIZE', IDSTR(J), NDSF(J), NDST, & - NDSEN, TIME0, T0N, RCLD(J), NDT(J), & - NDTNEW, DATA0, IERR ) - IF ( IERR .LT. 0 ) THEN - INFLAGS1(J) = .FALSE. - IF ( ALLOCATED(DATA0) ) DEALLOCATE(DATA0) - ELSE - NDT(J) = NDTNEW - IF ( ALLOCATED(DATA0) ) DEALLOCATE(DATA0) - ALLOCATE ( DATA0(RCLD(J),NDT(J)) ) - CALL W3FLDD ('READ', IDSTR(J), NDSF(J), NDST, & - NDSEN, TIME0, T0N, RCLD(J), NDT(J), & - NDTNEW, DATA0, IERR ) - END IF - -! Assim data - ELSE IF ( J .EQ. 8 ) THEN - CALL W3FLDD ('SIZE', IDSTR(J), NDSF(J), NDST, & - NDSEN, TIME0, T1N, RCLD(J), NDT(J), & - NDTNEW, DATA1, IERR ) - IF ( IERR .LT. 0 ) THEN - INFLAGS1(J) = .FALSE. - IF ( ALLOCATED(DATA1) ) DEALLOCATE(DATA1) - ELSE - NDT(J) = NDTNEW - IF ( ALLOCATED(DATA1) ) DEALLOCATE(DATA1) - ALLOCATE ( DATA1(RCLD(J),NDT(J)) ) - CALL W3FLDD ('READ', IDSTR(J), NDSF(J), NDST, & - NDSEN, TIME0, T1N, RCLD(J), NDT(J), & - NDTNEW, DATA1, IERR ) - END IF - -! Assim data - ELSE IF ( J .EQ. 9 ) THEN - CALL W3FLDD ('SIZE', IDSTR(J), NDSF(J), NDST, & - NDSEN, TIME0, T2N, RCLD(J), NDT(J), & - NDTNEW, DATA2, IERR ) - IF ( IERR .LT. 0 ) THEN - INFLAGS1(J) = .FALSE. - IF ( ALLOCATED(DATA2) ) DEALLOCATE(DATA2) - ELSE - NDT(J) = NDTNEW - IF ( ALLOCATED(DATA2) ) DEALLOCATE(DATA2) - ALLOCATE ( DATA2(RCLD(J),NDT(J)) ) - CALL W3FLDD ('READ', IDSTR(J), NDSF(J), NDST, & - NDSEN, TIME0, T2N, RCLD(J), NDT(J), & - NDTNEW, DATA2, IERR ) - END IF + ) + IF ( IERR .LT. 0 ) FLLSTR = .TRUE. + END IF -! Track - ELSE IF ( J .EQ. 10 ) THEN - CALL W3FLDM (4, NDST, NDSEN, TIME0, TIMEN, NH(4), & - NHMAX, THO, HA, HD, TG0, GA0, GD0, & - TGN, GAN, GDN, IERR) - END IF -! - IF ( IERR.GT.0 ) GOTO 2222 - IF ( IERR.LT.0 .AND. IAPROC.EQ.NAPOUT ) WRITE (NDSO,973) IDFLDS(J) - + ! Assim data + ELSE IF ( J .EQ. 7 ) THEN + CALL W3FLDD ('SIZE', IDSTR(J), NDSF(J), NDST, & + NDSEN, TIME0, T0N, RCLD(J), NDT(J), & + NDTNEW, DATA0, IERR ) + IF ( IERR .LT. 0 ) THEN + INFLAGS1(J) = .FALSE. + IF ( ALLOCATED(DATA0) ) DEALLOCATE(DATA0) + ELSE + NDT(J) = NDTNEW + IF ( ALLOCATED(DATA0) ) DEALLOCATE(DATA0) + ALLOCATE ( DATA0(RCLD(J),NDT(J)) ) + CALL W3FLDD ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, TIME0, T0N, RCLD(J), NDT(J), & + NDTNEW, DATA0, IERR ) + END IF - END IF ! DTTST .LE. 0. -! -! 7.a.4 Update next ending time -! - IF ( INFLAGS1(J) ) THEN - TTT = TFN(:,J) - DTTST = DSEC21 ( TTT , TTIME ) - IF ( DTTST.GT.0. .AND. .NOT. & - ( (FLLSTL .AND. J.EQ.1) .OR. & - (FLLST_ALL(J) .AND. J.EQ.-7) .OR. & - (FLLST_ALL(J) .AND. J.EQ.-6) .OR. & - (FLLST_ALL(J) .AND. J.EQ.-5) .OR. & - (FLLST_ALL(J) .AND. J.EQ.-4) .OR. & - (FLLST_ALL(J) .AND. J.EQ.-3) .OR. & - (FLLST_ALL(J) .AND. J.EQ.-2) .OR. & - (FLLST_ALL(J) .AND. J.EQ.-1) .OR. & - (FLLST_ALL(J) .AND. J.EQ.0 ) .OR. & - (FLLSTI .AND. J.EQ.4) .OR. & - (FLLSTR .AND. J.EQ.6) ) ) THEN - TTIME = TTT -! notes: if model has run out beyond field input, then this line should not -! be reached. - END IF + ! Assim data + ELSE IF ( J .EQ. 8 ) THEN + CALL W3FLDD ('SIZE', IDSTR(J), NDSF(J), NDST, & + NDSEN, TIME0, T1N, RCLD(J), NDT(J), & + NDTNEW, DATA1, IERR ) + IF ( IERR .LT. 0 ) THEN + INFLAGS1(J) = .FALSE. + IF ( ALLOCATED(DATA1) ) DEALLOCATE(DATA1) + ELSE + NDT(J) = NDTNEW + IF ( ALLOCATED(DATA1) ) DEALLOCATE(DATA1) + ALLOCATE ( DATA1(RCLD(J),NDT(J)) ) + CALL W3FLDD ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, TIME0, T1N, RCLD(J), NDT(J), & + NDTNEW, DATA1, IERR ) END IF -! - END IF ! INFLAGSC1(J) -! - END DO ! J=JFIRST,10 -! -! update the next assimilation data time -! -#ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 8' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) -#endif + ! Assim data + ELSE IF ( J .EQ. 9 ) THEN + CALL W3FLDD ('SIZE', IDSTR(J), NDSF(J), NDST, & + NDSEN, TIME0, T2N, RCLD(J), NDT(J), & + NDTNEW, DATA2, IERR ) + IF ( IERR .LT. 0 ) THEN + INFLAGS1(J) = .FALSE. + IF ( ALLOCATED(DATA2) ) DEALLOCATE(DATA2) + ELSE + NDT(J) = NDTNEW + IF ( ALLOCATED(DATA2) ) DEALLOCATE(DATA2) + ALLOCATE ( DATA2(RCLD(J),NDT(J)) ) + CALL W3FLDD ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, TIME0, T2N, RCLD(J), NDT(J), & + NDTNEW, DATA2, IERR ) + END IF - TDN = TTIME - CALL TICK21 ( TDN, 1. ) - DO J=7, 9 - IF ( INFLAGS1(J) ) THEN - TTT = TFN(:,J) - DTTST = DSEC21 ( TTT , TDN ) - IF ( DTTST.GT.0. ) TDN = TTT + ! Track + ELSE IF ( J .EQ. 10 ) THEN + CALL W3FLDM (4, NDST, NDSEN, TIME0, TIMEN, NH(4), & + NHMAX, THO, HA, HD, TG0, GA0, GD0, & + TGN, GAN, GDN, IERR) END IF - END DO -! + ! + IF ( IERR.GT.0 ) GOTO 2222 + IF ( IERR.LT.0 .AND. IAPROC.EQ.NAPOUT ) WRITE (NDSO,973) IDFLDS(J) + + + END IF ! DTTST .LE. 0. + ! + ! 7.a.4 Update next ending time + ! + IF ( INFLAGS1(J) ) THEN + TTT = TFN(:,J) + DTTST = DSEC21 ( TTT , TTIME ) + IF ( DTTST.GT.0. .AND. .NOT. & + ( (FLLSTL .AND. J.EQ.1) .OR. & + (FLLST_ALL(J) .AND. J.EQ.-7) .OR. & + (FLLST_ALL(J) .AND. J.EQ.-6) .OR. & + (FLLST_ALL(J) .AND. J.EQ.-5) .OR. & + (FLLST_ALL(J) .AND. J.EQ.-4) .OR. & + (FLLST_ALL(J) .AND. J.EQ.-3) .OR. & + (FLLST_ALL(J) .AND. J.EQ.-2) .OR. & + (FLLST_ALL(J) .AND. J.EQ.-1) .OR. & + (FLLST_ALL(J) .AND. J.EQ.0 ) .OR. & + (FLLSTI .AND. J.EQ.4) .OR. & + (FLLSTR .AND. J.EQ.6) ) ) THEN + TTIME = TTT + ! notes: if model has run out beyond field input, then this line should not + ! be reached. + END IF + END IF + ! + END IF ! INFLAGSC1(J) + ! + END DO ! J=JFIRST,10 + ! + ! update the next assimilation data time + ! + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 8' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + TDN = TTIME + CALL TICK21 ( TDN, 1. ) + DO J=7, 9 + IF ( INFLAGS1(J) ) THEN + TTT = TFN(:,J) + DTTST = DSEC21 ( TTT , TDN ) + IF ( DTTST.GT.0. ) TDN = TTT + END IF + END DO + ! #ifdef W3_T - WRITE (NDST,9072) '0-N', TIME0, TTIME, & - IDSTR(-7), INFLAGS1(-7), TI1, & - IDSTR(-6), INFLAGS1(-6), TI2, & - IDSTR(-5), INFLAGS1(-5), TI3, & - IDSTR(-4), INFLAGS1(-4), TI4, & - IDSTR(-3), INFLAGS1(-3), TI5, & - IDSTR(-2), INFLAGS1(-2), TZN, & - IDSTR(-1), INFLAGS1(-1), TTN, & - IDSTR(0), INFLAGS1(0), TVN, & - IDSTR(1), INFLAGS1(1), TLN, & - IDSTR(2), INFLAGS1(2), TC0, TCN, & - IDSTR(3), INFLAGS1(3), TW0, TWN, & - IDSTR(4), INFLAGS1(4), TIN, & - IDSTR(5), INFLAGS1(5), TU0, TUN, & - IDSTR(6), INFLAGS1(6), TR0, TRN, & - IDSTR(7), INFLAGS1(7), T0N, & - IDSTR(8), INFLAGS1(8), T1N, & - IDSTR(9), INFLAGS1(9), T2N, TDN, & - IDSTR(10), INFLAGS1(10), TG0, TGN -#endif -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' -! -! 7.b Run the wave model for the given interval -! - TIME0 = TTIME -! - CALL W3WAVE ( 1, ODAT, TIME0 & + WRITE (NDST,9072) '0-N', TIME0, TTIME, & + IDSTR(-7), INFLAGS1(-7), TI1, & + IDSTR(-6), INFLAGS1(-6), TI2, & + IDSTR(-5), INFLAGS1(-5), TI3, & + IDSTR(-4), INFLAGS1(-4), TI4, & + IDSTR(-3), INFLAGS1(-3), TI5, & + IDSTR(-2), INFLAGS1(-2), TZN, & + IDSTR(-1), INFLAGS1(-1), TTN, & + IDSTR(0), INFLAGS1(0), TVN, & + IDSTR(1), INFLAGS1(1), TLN, & + IDSTR(2), INFLAGS1(2), TC0, TCN, & + IDSTR(3), INFLAGS1(3), TW0, TWN, & + IDSTR(4), INFLAGS1(4), TIN, & + IDSTR(5), INFLAGS1(5), TU0, TUN, & + IDSTR(6), INFLAGS1(6), TR0, TRN, & + IDSTR(7), INFLAGS1(7), T0N, & + IDSTR(8), INFLAGS1(8), T1N, & + IDSTR(9), INFLAGS1(9), T2N, TDN, & + IDSTR(10), INFLAGS1(10), TG0, TGN +#endif + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' + ! + ! 7.b Run the wave model for the given interval + ! + TIME0 = TTIME + ! + CALL W3WAVE ( 1, ODAT, TIME0 & #ifdef W3_OASIS - , .TRUE., .FALSE., MPI_COMM, TIMEN & + , .TRUE., .FALSE., MPI_COMM, TIMEN & #endif - ) + ) #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 9' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) -#endif -! - ! The following lines prevents us from trying to read past the end - ! of the files. This feature existed in v3.14. - ! "1" is for water levels - ! "4" is for ice concentration: - ! "6" is for air density: - IF ( FLLSTL ) INFLAGS1(1) = .FALSE. - IF ( FLLSTI ) INFLAGS1(4) = .FALSE. - IF ( FLLSTR ) INFLAGS1(6) = .FALSE. - - ! We include something like this for mud and ice parameters also: - DO J=-7,0 - IF (FLLST_ALL(J))THEN - INFLAGS1(J)=.FALSE. - END IF - END DO - -! -! 7.c Run data assimilation at ending time -! - DTTST = DSEC21 ( TIME , TDN ) - IF ( DTTST .EQ. 0 ) THEN - CALL STME21 ( TIME0 , DTME21 ) - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,975) DTME21 -! - FLGDAS(1) = DSEC21(TIME,T0N) .EQ. 0. - FLGDAS(2) = DSEC21(TIME,T1N) .EQ. 0. - FLGDAS(3) = DSEC21(TIME,T2N) .EQ. 0. -! - CALL W3WDAS ( FLGDAS, RCLD, NDT, DATA0, DATA1, DATA2 ) -! -! 7.d Call wave model again after data assimilation for output only -! - DTTST = DSEC21 ( TIME , TIMEN ) - - IF ( DTTST .EQ. 0. ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' - CALL W3WAVE ( 1, ODAT, TIME0 & + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 9' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + ! + ! The following lines prevents us from trying to read past the end + ! of the files. This feature existed in v3.14. + ! "1" is for water levels + ! "4" is for ice concentration: + ! "6" is for air density: + IF ( FLLSTL ) INFLAGS1(1) = .FALSE. + IF ( FLLSTI ) INFLAGS1(4) = .FALSE. + IF ( FLLSTR ) INFLAGS1(6) = .FALSE. + + ! We include something like this for mud and ice parameters also: + DO J=-7,0 + IF (FLLST_ALL(J))THEN + INFLAGS1(J)=.FALSE. + END IF + END DO + + ! + ! 7.c Run data assimilation at ending time + ! + DTTST = DSEC21 ( TIME , TDN ) + IF ( DTTST .EQ. 0 ) THEN + CALL STME21 ( TIME0 , DTME21 ) + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,975) DTME21 + ! + FLGDAS(1) = DSEC21(TIME,T0N) .EQ. 0. + FLGDAS(2) = DSEC21(TIME,T1N) .EQ. 0. + FLGDAS(3) = DSEC21(TIME,T2N) .EQ. 0. + ! + CALL W3WDAS ( FLGDAS, RCLD, NDT, DATA0, DATA1, DATA2 ) + ! + ! 7.d Call wave model again after data assimilation for output only + ! + DTTST = DSEC21 ( TIME , TIMEN ) + + IF ( DTTST .EQ. 0. ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' + CALL W3WAVE ( 1, ODAT, TIME0 & #ifdef W3_OASIS - , .TRUE., .FALSE., MPI_COMM, TIMEN & -#endif - ) - END IF - END IF -! -! 7.e Check times -! + , .TRUE., .FALSE., MPI_COMM, TIMEN & +#endif + ) + END IF + END IF + ! + ! 7.e Check times + ! #ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 10' - call getMallocInfo(mallinfos) -#endif - - - DTTST = DSEC21 ( TIME0 , TIMEN ) - IF ( DTTST .GT. 0. ) GOTO 700 -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! End of shel -! - GOTO 2222 -! -! Error escape locations -! - 2000 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) IERR - CALL EXTCDE ( 1000 ) -! - 2001 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) - CALL EXTCDE ( 1001 ) -! - 2002 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) IERR - CALL EXTCDE ( 1002 ) -! - 2102 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1102) - CALL EXTCDE ( 1102 ) -! - 2003 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) - CALL EXTCDE ( 1003 ) -! - 2104 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1104) IERR - CALL EXTCDE ( 1104 ) -! - 2004 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1004) IERR - CALL EXTCDE ( 1004 ) -! - 2005 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1005) IDTST - CALL EXTCDE ( 1005 ) -! - 2006 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006) IDTST, NH(J) - CALL EXTCDE ( 1006 ) -! - 2062 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1062) IDTST - CALL EXTCDE ( 1062 ) -! - 2007 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1007) - CALL EXTCDE ( 1007 ) -! - 2008 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1008) IERR - CALL EXTCDE ( 1008 ) -! + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 10' + call getMallocInfo(mallinfos) +#endif + + + DTTST = DSEC21 ( TIME0 , TIMEN ) + IF ( DTTST .GT. 0. ) GOTO 700 + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! End of shel + ! + GOTO 2222 + ! + ! Error escape locations + ! +2000 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) IERR + CALL EXTCDE ( 1000 ) + ! +2001 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) + CALL EXTCDE ( 1001 ) + ! +2002 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) IERR + CALL EXTCDE ( 1002 ) + ! +2102 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1102) + CALL EXTCDE ( 1102 ) + ! +2003 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) + CALL EXTCDE ( 1003 ) + ! +2104 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1104) IERR + CALL EXTCDE ( 1104 ) + ! +2004 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1004) IERR + CALL EXTCDE ( 1004 ) + ! +2005 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1005) IDTST + CALL EXTCDE ( 1005 ) + ! +2006 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006) IDTST, NH(J) + CALL EXTCDE ( 1006 ) + ! +2062 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1062) IDTST + CALL EXTCDE ( 1062 ) + ! +2007 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1007) + CALL EXTCDE ( 1007 ) + ! +2008 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1008) IERR + CALL EXTCDE ( 1008 ) + ! #ifdef W3_COU - 2009 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1009) ODAT(33), NINT(DTMAX) - CALL EXTCDE ( 1009 ) -#endif -! - 2054 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1054) - CALL EXTCDE ( 1054 ) - 2222 CONTINUE -! +2009 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1009) ODAT(33), NINT(DTMAX) + CALL EXTCDE ( 1009 ) +#endif + ! +2054 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1054) + CALL EXTCDE ( 1054 ) +2222 CONTINUE + ! #ifdef W3_MPI - CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) -#endif -! - IF ( IAPROC .EQ. NAPOUT ) THEN - CALL DATE_AND_TIME ( VALUES=CLKDT3 ) - CLKFIN = MAX(TDIFF ( CLKDT1,CLKDT2 ), 0.) - CLKFEL = MAX(TDIFF ( CLKDT1,CLKDT3 ), 0.) - WRITE (NDSO,997) CLKFIN - WRITE (NDSO,998) CLKFEL - IF ( NDSO .NE. NDS(1) ) THEN - WRITE (NDS(1),997) CLKFIN - WRITE (NDS(1),998) CLKFEL - END IF - WRITE (NDSO,999) - END IF -! + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#endif + ! + IF ( IAPROC .EQ. NAPOUT ) THEN + CALL DATE_AND_TIME ( VALUES=CLKDT3 ) + CLKFIN = MAX(TDIFF ( CLKDT1,CLKDT2 ), 0.) + CLKFEL = MAX(TDIFF ( CLKDT1,CLKDT3 ), 0.) + WRITE (NDSO,997) CLKFIN + WRITE (NDSO,998) CLKFEL + IF ( NDSO .NE. NDS(1) ) THEN + WRITE (NDS(1),997) CLKFIN + WRITE (NDS(1),998) CLKFEL + END IF + WRITE (NDSO,999) + END IF + ! #ifdef W3_NCO -! IF ( IAPROC .EQ. 1 ) CALL W3TAGE('WAVEFCST') + ! IF ( IAPROC .EQ. 1 ) CALL W3TAGE('WAVEFCST') #endif #ifdef W3_OASIS - IF (OASISED.EQ.1) THEN - CALL CPL_OASIS_FINALIZE - ELSE + IF (OASISED.EQ.1) THEN + CALL CPL_OASIS_FINALIZE + ELSE #endif #ifdef W3_MPI - CALL MPI_FINALIZE ( IERR_MPI ) + CALL MPI_FINALIZE ( IERR_MPI ) #endif #ifdef W3_OASIS - END IF -#endif -! -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Program shell *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) -! + END IF +#endif + ! + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Program shell *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) + ! #ifdef W3_OMPH - 905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & - ' Requested: ', I2/ & - ' Provided: ', I2/ ) -#endif - 920 FORMAT (/' Input fields : '/ & - ' --------------------------------------------------') - 921 FORMAT ( ' ',A,2X,A,2X,A) - 922 FORMAT ( ' ' ) -! - 930 FORMAT (/' Time interval : '/ & - ' --------------------------------------------------') - 931 FORMAT ( ' Starting time : ',A) - 932 FORMAT ( ' Ending time : ',A/) -! - 940 FORMAT (/' Output requests : '/ & - ' --------------------------------------------------'/ & - ' ',A) - 941 FORMAT (/' Type',I2,' : ',A/ & - ' -----------------------------------------') - 942 FORMAT ( ' From : ',A) - 943 FORMAT ( ' To : ',A) - 1944 FORMAT ( ' Interval : ', 8X,A11/) - 2944 FORMAT ( ' Interval : ', 9X,A10/) - 3944 FORMAT ( ' Interval : ',11X,A8/) - 2945 FORMAT ( ' Point 1 : ',2F8.2,2X,A) - 2955 FORMAT ( ' Point 1 : ',2(F8.1,'E3'),2X,A) - 2946 FORMAT ( ' ',I6,' : ',2F8.2,2X,A) - 2956 FORMAT ( ' ',I6,' : ',2(F8.1,'E3'),2X,A) - 2947 FORMAT ( ' No points defined') - 3945 FORMAT ( ' The file with ',A,' data is ',A,'.') - 6945 FORMAT ( ' IX first,last,inc :',3I5/ & - ' IY first,last,inc :',3I5/ & - ' Formatted file : ',A) - 8945 FORMAT ( ' output dates out of run dates : ', A, & - ' deactivated') -! - 950 FORMAT (/' Initializations :'/ & - ' --------------------------------------------------') - 951 FORMAT ( ' ',A) +905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & + ' Requested: ', I2/ & + ' Provided: ', I2/ ) +#endif +920 FORMAT (/' Input fields : '/ & + ' --------------------------------------------------') +921 FORMAT ( ' ',A,2X,A,2X,A) +922 FORMAT ( ' ' ) + ! +930 FORMAT (/' Time interval : '/ & + ' --------------------------------------------------') +931 FORMAT ( ' Starting time : ',A) +932 FORMAT ( ' Ending time : ',A/) + ! +940 FORMAT (/' Output requests : '/ & + ' --------------------------------------------------'/ & + ' ',A) +941 FORMAT (/' Type',I2,' : ',A/ & + ' -----------------------------------------') +942 FORMAT ( ' From : ',A) +943 FORMAT ( ' To : ',A) +1944 FORMAT ( ' Interval : ', 8X,A11/) +2944 FORMAT ( ' Interval : ', 9X,A10/) +3944 FORMAT ( ' Interval : ',11X,A8/) +2945 FORMAT ( ' Point 1 : ',2F8.2,2X,A) +2955 FORMAT ( ' Point 1 : ',2(F8.1,'E3'),2X,A) +2946 FORMAT ( ' ',I6,' : ',2F8.2,2X,A) +2956 FORMAT ( ' ',I6,' : ',2(F8.1,'E3'),2X,A) +2947 FORMAT ( ' No points defined') +3945 FORMAT ( ' The file with ',A,' data is ',A,'.') +6945 FORMAT ( ' IX first,last,inc :',3I5/ & + ' IY first,last,inc :',3I5/ & + ' Formatted file : ',A) +8945 FORMAT ( ' output dates out of run dates : ', A, & + ' deactivated') + ! +950 FORMAT (/' Initializations :'/ & + ' --------------------------------------------------') +951 FORMAT ( ' ',A) #ifdef W3_O7 - 952 FORMAT ( ' ',I6,2X,A) - 953 FORMAT ( ' ',I6,I11.8,I7.6,3E12.4) -#endif - 954 FORMAT ( ' ',A,': file not needed') - 955 FORMAT ( ' ',A,': file OK') - 956 FORMAT ( ' ',A,': file OK, recl =',I3, & - ' undef = ',E10.3) -! - 960 FORMAT (/' Running model without input fields'/ & - ' --------------------------------------------------'/) -! - 970 FORMAT (/' Running model with input fields'/ & - ' --------------------------------------------------') - 971 FORMAT (/' Updating input at ',A) - 972 FORMAT ( ' Updating ',A) - 973 FORMAT ( ' Past last ',A) +952 FORMAT ( ' ',I6,2X,A) +953 FORMAT ( ' ',I6,I11.8,I7.6,3E12.4) +#endif +954 FORMAT ( ' ',A,': file not needed') +955 FORMAT ( ' ',A,': file OK') +956 FORMAT ( ' ',A,': file OK, recl =',I3, & + ' undef = ',E10.3) + ! +960 FORMAT (/' Running model without input fields'/ & + ' --------------------------------------------------'/) + ! +970 FORMAT (/' Running model with input fields'/ & + ' --------------------------------------------------') +971 FORMAT (/' Updating input at ',A) +972 FORMAT ( ' Updating ',A) +973 FORMAT ( ' Past last ',A) #ifdef W3_TIDE - 974 FORMAT ( ' Updating ',A,'using tidal constituents') -#endif - 975 FORMAT (/' Data assimmilation at ',A) -! - 997 FORMAT (/' Initialization time :',F10.2,' s') - 998 FORMAT ( ' Elapsed time :',F10.2,' s') -! - 999 FORMAT(/' End of program '/ & - ' ===================================='/ & - ' WAVEWATCH III Program shell '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1102 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' LEVEL AND CURRENT ARE MIXING COUPLED AND FORCED'/& - ' IT MUST BE FULLY COUPLED OR DISABLED '/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ILLEGAL TIME INTERVAL'/) -! - 1104 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN OPENING POINT FILE'/ & - ' IOSTAT =',I5/) -! - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN READING FROM POINT FILE'/ & - ' IOSTAT =',I5/) -! - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ILLEGAL ID STRING HOMOGENEOUS FIELD : ',A/) -! - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' TOO MANY HOMOGENEOUS FIELDS : ',A,1X,I4/) -! - 1062 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : ***'/ & - ' HOMOGENEOUS NAME NOT RECOGNIZED : ', A/) -! - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' INSUFFICIENT DATA FOR HOMOGENEOUS FIELDS'/) -! - 1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN OPENING OUTPUT FILE'/ & - ' IOSTAT =',I5/) -! +974 FORMAT ( ' Updating ',A,'using tidal constituents') +#endif +975 FORMAT (/' Data assimmilation at ',A) + ! +997 FORMAT (/' Initialization time :',F10.2,' s') +998 FORMAT ( ' Elapsed time :',F10.2,' s') + ! +999 FORMAT(/' End of program '/ & + ' ===================================='/ & + ' WAVEWATCH III Program shell '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1102 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' LEVEL AND CURRENT ARE MIXING COUPLED AND FORCED'/& + ' IT MUST BE FULLY COUPLED OR DISABLED '/) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ILLEGAL TIME INTERVAL'/) + ! +1104 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ERROR IN OPENING POINT FILE'/ & + ' IOSTAT =',I5/) + ! +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ERROR IN READING FROM POINT FILE'/ & + ' IOSTAT =',I5/) + ! +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ILLEGAL ID STRING HOMOGENEOUS FIELD : ',A/) + ! +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' TOO MANY HOMOGENEOUS FIELDS : ',A,1X,I4/) + ! +1062 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : ***'/ & + ' HOMOGENEOUS NAME NOT RECOGNIZED : ', A/) + ! +1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' INSUFFICIENT DATA FOR HOMOGENEOUS FIELDS'/) + ! +1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ERROR IN OPENING OUTPUT FILE'/ & + ' IOSTAT =',I5/) + ! #ifdef W3_COU - 1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' COUPLING TIME STEP NOT MULTIPLE OF'/ & - ' MODEL TIME STEP: ',I6, I6/) +1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' COUPLING TIME STEP NOT MULTIPLE OF'/ & + ' MODEL TIME STEP: ',I6, I6/) #endif -! + ! #ifdef W3_COU - 1010 FORMAT (/' *** WAVEWATCH III WARNING IN W3SHEL : *** '/ & - ' COUPLING TIME STEP NOT DEFINED, '/ & - ' IT WILL BE OVERRIDEN TO DEFAULT VALUE'/ & - ' FROM ',I6, ' TO ',I6/) -#endif -! - 1054 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' POINT OUTPUT ACTIVATED BUT NO POINTS DEFINED'/) -! -! +1010 FORMAT (/' *** WAVEWATCH III WARNING IN W3SHEL : *** '/ & + ' COUPLING TIME STEP NOT DEFINED, '/ & + ' IT WILL BE OVERRIDEN TO DEFAULT VALUE'/ & + ' FROM ',I6, ' TO ',I6/) +#endif + ! +1054 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' POINT OUTPUT ACTIVATED BUT NO POINTS DEFINED'/) + ! + ! #ifdef W3_T - 9000 FORMAT ( ' TEST W3SHEL : UNIT NUMBERS :',12I4) - 9001 FORMAT ( ' TEST W3SHEL : SUBR. TRACING :',2I4) +9000 FORMAT ( ' TEST W3SHEL : UNIT NUMBERS :',12I4) +9001 FORMAT ( ' TEST W3SHEL : SUBR. TRACING :',2I4) #endif -! + ! #ifdef W3_T - 9020 FORMAT ( ' TEST W3SHEL : FLAGS DEF / HOM : ',9L2,2X,9L2) +9020 FORMAT ( ' TEST W3SHEL : FLAGS DEF / HOM : ',9L2,2X,9L2) #endif -! + ! #ifdef W3_T - 9040 FORMAT ( ' TEST W3SHEL : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & - 4(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) - 9041 FORMAT ( ' TEST W3SHEL : FLGRD : ',20L2) - 9042 FORMAT ( ' TEST W3SHEL : IPR, PRFRM : ',6I6,1X,L1) +9040 FORMAT ( ' TEST W3SHEL : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & + 4(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) +9041 FORMAT ( ' TEST W3SHEL : FLGRD : ',20L2) +9042 FORMAT ( ' TEST W3SHEL : IPR, PRFRM : ',6I6,1X,L1) #endif -! + ! #ifdef W3_T - 9070 FORMAT ( ' TEST W3SHEL : ',A,3X,2(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,2(I10.8,I7.6)/ & - ' ',A,L3,2(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,2(I10.8,I7.6)/ & - ' ',A,L3,2(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,2(I10.8,I7.6)) - 9071 FORMAT ( ' TEST W3SHEL : ',A,', DTTST = ',E10.3) - 9072 FORMAT ( ' TEST W3SHEL : ',A,3X,2(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,2(I10.8,I7.6)/ & - ' ',A,L3,2(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,2(I10.8,I7.6)/ & - ' ',A,L3,2(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,(I10.8,I7.6)/ & - ' ',A,L3,17X,2(I10.8,I7.6)/ & - ' ',A,L3,2(I10.8,I7.6)) -#endif -!/ -!/ End of W3SHEL ----------------------------------------------------- / -!/ - END PROGRAM W3SHEL +9070 FORMAT ( ' TEST W3SHEL : ',A,3X,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)) +9071 FORMAT ( ' TEST W3SHEL : ',A,', DTTST = ',E10.3) +9072 FORMAT ( ' TEST W3SHEL : ',A,3X,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,2(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)) +#endif + !/ + !/ End of W3SHEL ----------------------------------------------------- / + !/ +END PROGRAM W3SHEL diff --git a/model/src/ww3_strt.F90 b/model/src/ww3_strt.F90 index 631fcc0a9..b4bcad3ca 100644 --- a/model/src/ww3_strt.F90 +++ b/model/src/ww3_strt.F90 @@ -16,7 +16,7 @@ !> !> 1) Gaussian distribution in longitude, latitude and frequency, !> cos power in directions. Can default to single spectral bin. -!> +!> !> 2) Predefined JONSWAP spectrum, Gaussian height distribution !> in space. !> @@ -34,992 +34,992 @@ !> in W3IORS. !> !> @author H. L. Tolman @date 06-Jun-2018 - PROGRAM W3STRT -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 18-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 11-Jan-2001 : Flat grid version ( version 2.06 ) -!/ 11-Jun-2001 : Clean up. ( version 2.11 ) -!/ 30-Apr-2002 : Updated W3IORS. ( version 2.20 ) -!/ 13-Nov-2002 : Updated W3IORS. ( version 3.00 ) -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 31-Oct-2010 : Implement unstructured grid ( version 3.14 ) -!/ (A. Roland and F. Ardhuin) -!/ 05-Jul-2011 : Revert to X-Y gaussian shape ( version 4.01 ) -!/ 06-Mar-2012 : Hardening output. ( version 4.07 ) -!/ 06-Jun-2018 : Add DEBUGINIT/EXPORTWWM ( version 6.04 ) -!/ -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Generation of initial conditions for a "cold start" of -! WAVEWATCH III. -! -! 2. Method : -! -! General model information is obtained from the model definition -! file using W3IOGR. The type of the initial field is read -! from the input file WW3_strt.inp (NDSI). Three types of initial -! conditions are available. -! 1) Gaussian distribution in longitude, latitude and frequency, -! cos power in directions. Can default to single spectral -! bin. -! 2) Predefined JONSWAP spectrum, Gaussian height distribution -! in space. -! 3) Fetch-limited JONSWAP spectrum based on the actual wind -! speed. To avoid the need of reading a wind field, the -! restart file is a "dummy", and the actual initial field -! is constructed in the initialization routine W3INIT. -! 4) User defined spectrum throughout the model. -! 5) Starting from rest. -! The initial conditions are written to the restart.WW3 using the -! subroutine W3IORS. Note that the name of the restart file is set -! in W3IORS. -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! NDSI Int. Input unit number ("ww3_strt.inp"). -! ITYPE Int. Type of field (see section 2). -! FP,SIP Real Peak frequency (Hz) and spread. \ -! XM,SIX Real Id. X (degr.). | -! YM,SIY Real Id. Y (degr.). | ITYPE = 1 -! HMAX Real Maximum wave height. | -! NCOS Real Cosine power in dir. distr. | -! THM Real Mean direction (cart. degr.) / \ -! ALFA Real Energy level of PM spectrum. | -! FP Real Peak frequency (Hz). | ITYPE = 2 -! GAMMA Real Peak enhancement factor | -! SIGA/B Real Spread with GAMA. / -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W3DIMW Subr. Id. Set array dims for wave data. -! W3NAUX Subr. W3ADATMD Set number of model for aux data. -! W3SETA Subr. Id. Point to selected model for aux data. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input filw -! EXTCDE Subr. Id. Abort program as graceful as possible. -! EJ5P Func. Id. Five parameter JONSWAP spectrum. -! PRT1DS Subr. W3ARRYMD Print plot of 1-D spectrum. -! PRT2DS Subr. Id. Print plot of 2-D spectrum. -! PRTBLK Subr. Id. Print plot of array. -! WAVNU1 Subr. W3DISPMD Solve dispersion relation. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3IORS Subr. W3IORSMD Reading/writing restart files. -! W3DIST Subr. W3GSRUMD Compute distance between two points. -! MPI_xxx Subr. mpif.h Standard MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! - While reading the restart file W3IORS will recognize the -! need for checking the time, as the restart file contains -! information on the origine of the file ("cold" or "hot"). -! - User input for x-wise gaussian spread control, SIX, is -! now available again (option for SIX.NE.SIY available.) -! If user desires a distribution that is circular in real -! distances, user should input a negative number for SIX. -! -! 8. Structure : -! -! ---------------------------------------------------- -! 1.a Set up data structures. -! ( W3NMOD , W3NDAT , W3NOUT -! W3SETG , W3SETW , W3SETO ) -! b I-O setup. -! b Print heading(s). -! 2.a Read model defintion file with base model -! data. ( W3IOGR ) -! b MPP initializations. -! 3. Get field type from the input file. -! 4. ITYPE = 1, Gaussian, cosine. -! a Read parameters. -! b Set-up 1-D spectrum. -! c Set-up directional distribution. -! d Normalize spectrum with Hmax. -! e Distribute over grid. -! 5. ITYPE = 2, pre-defined JONSWAP. -! a Read parameters. -! b Set-up 1-D spectrum. -! c 2-D energy spectrum. -! d Distribute over grid. -! 6. ITYPE = 3, fetch limited JONSWAP. -! 7. ITYPE = 4, user-defined spectrum. -! a Read scale factor. -! b Read and rescale spectrum. -! c Distribute over grid. -! 8. ITYPE = 5, start from calm conditions. -! 9. Convert energy to action -! 10. Write restart file. ( W3IORS ) -! ---------------------------------------------------- -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! -! !/O4 Output normalized 1-D energy spectrum. -! !/O5 Output normalized 2-D energy spectrum. -! !/O6 Output normalized wave heights (not MPP adapted). -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ -! USE W3GDATMD, ONLY: W3NMOD, W3SETG -! USE W3WDATMD, ONLY: W3NDAT, W3SETW, W3DIMW +PROGRAM W3STRT + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 18-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 11-Jan-2001 : Flat grid version ( version 2.06 ) + !/ 11-Jun-2001 : Clean up. ( version 2.11 ) + !/ 30-Apr-2002 : Updated W3IORS. ( version 2.20 ) + !/ 13-Nov-2002 : Updated W3IORS. ( version 3.00 ) + !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 31-Oct-2010 : Implement unstructured grid ( version 3.14 ) + !/ (A. Roland and F. Ardhuin) + !/ 05-Jul-2011 : Revert to X-Y gaussian shape ( version 4.01 ) + !/ 06-Mar-2012 : Hardening output. ( version 4.07 ) + !/ 06-Jun-2018 : Add DEBUGINIT/EXPORTWWM ( version 6.04 ) + !/ + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Generation of initial conditions for a "cold start" of + ! WAVEWATCH III. + ! + ! 2. Method : + ! + ! General model information is obtained from the model definition + ! file using W3IOGR. The type of the initial field is read + ! from the input file WW3_strt.inp (NDSI). Three types of initial + ! conditions are available. + ! 1) Gaussian distribution in longitude, latitude and frequency, + ! cos power in directions. Can default to single spectral + ! bin. + ! 2) Predefined JONSWAP spectrum, Gaussian height distribution + ! in space. + ! 3) Fetch-limited JONSWAP spectrum based on the actual wind + ! speed. To avoid the need of reading a wind field, the + ! restart file is a "dummy", and the actual initial field + ! is constructed in the initialization routine W3INIT. + ! 4) User defined spectrum throughout the model. + ! 5) Starting from rest. + ! The initial conditions are written to the restart.WW3 using the + ! subroutine W3IORS. Note that the name of the restart file is set + ! in W3IORS. + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! NDSI Int. Input unit number ("ww3_strt.inp"). + ! ITYPE Int. Type of field (see section 2). + ! FP,SIP Real Peak frequency (Hz) and spread. \ + ! XM,SIX Real Id. X (degr.). | + ! YM,SIY Real Id. Y (degr.). | ITYPE = 1 + ! HMAX Real Maximum wave height. | + ! NCOS Real Cosine power in dir. distr. | + ! THM Real Mean direction (cart. degr.) / \ + ! ALFA Real Energy level of PM spectrum. | + ! FP Real Peak frequency (Hz). | ITYPE = 2 + ! GAMMA Real Peak enhancement factor | + ! SIGA/B Real Spread with GAMA. / + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W3DIMW Subr. Id. Set array dims for wave data. + ! W3NAUX Subr. W3ADATMD Set number of model for aux data. + ! W3SETA Subr. Id. Point to selected model for aux data. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! W3SETO Subr. Id. Point to selected model for output. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! NEXTLN Subr. Id. Get next line from input filw + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! EJ5P Func. Id. Five parameter JONSWAP spectrum. + ! PRT1DS Subr. W3ARRYMD Print plot of 1-D spectrum. + ! PRT2DS Subr. Id. Print plot of 2-D spectrum. + ! PRTBLK Subr. Id. Print plot of array. + ! WAVNU1 Subr. W3DISPMD Solve dispersion relation. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3IORS Subr. W3IORSMD Reading/writing restart files. + ! W3DIST Subr. W3GSRUMD Compute distance between two points. + ! MPI_xxx Subr. mpif.h Standard MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - While reading the restart file W3IORS will recognize the + ! need for checking the time, as the restart file contains + ! information on the origine of the file ("cold" or "hot"). + ! - User input for x-wise gaussian spread control, SIX, is + ! now available again (option for SIX.NE.SIY available.) + ! If user desires a distribution that is circular in real + ! distances, user should input a negative number for SIX. + ! + ! 8. Structure : + ! + ! ---------------------------------------------------- + ! 1.a Set up data structures. + ! ( W3NMOD , W3NDAT , W3NOUT + ! W3SETG , W3SETW , W3SETO ) + ! b I-O setup. + ! b Print heading(s). + ! 2.a Read model defintion file with base model + ! data. ( W3IOGR ) + ! b MPP initializations. + ! 3. Get field type from the input file. + ! 4. ITYPE = 1, Gaussian, cosine. + ! a Read parameters. + ! b Set-up 1-D spectrum. + ! c Set-up directional distribution. + ! d Normalize spectrum with Hmax. + ! e Distribute over grid. + ! 5. ITYPE = 2, pre-defined JONSWAP. + ! a Read parameters. + ! b Set-up 1-D spectrum. + ! c 2-D energy spectrum. + ! d Distribute over grid. + ! 6. ITYPE = 3, fetch limited JONSWAP. + ! 7. ITYPE = 4, user-defined spectrum. + ! a Read scale factor. + ! b Read and rescale spectrum. + ! c Distribute over grid. + ! 8. ITYPE = 5, start from calm conditions. + ! 9. Convert energy to action + ! 10. Write restart file. ( W3IORS ) + ! ---------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! + ! !/SHRD Switch for message passing method. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! + ! !/O4 Output normalized 1-D energy spectrum. + ! !/O5 Output normalized 2-D energy spectrum. + ! !/O6 Output normalized wave heights (not MPP adapted). + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + ! USE W3GDATMD, ONLY: W3NMOD, W3SETG + ! USE W3WDATMD, ONLY: W3NDAT, W3SETW, W3DIMW #ifdef W3_NL1 - USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ADATMD, ONLY: W3NAUX, W3SETA #endif - USE W3ODATMD, ONLY: W3NOUT, W3SETO, FLOGRR - USE W3SERVMD, ONLY: ITRACE, NEXTLN, EJ5P, EXTCDE + USE W3ODATMD, ONLY: W3NOUT, W3SETO, FLOGRR + USE W3SERVMD, ONLY: ITRACE, NEXTLN, EJ5P, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif #ifdef W3_O4 - USE W3ARRYMD, ONLY : PRT1DS + USE W3ARRYMD, ONLY : PRT1DS #endif #ifdef W3_O5 - USE W3ARRYMD, ONLY : PRT2DS + USE W3ARRYMD, ONLY : PRT2DS #endif #ifdef W3_O6 - USE W3ARRYMD, ONLY : PRTBLK + USE W3ARRYMD, ONLY : PRTBLK #endif - USE W3DISPMD, ONLY : WAVNU1 - USE W3IOGRMD, ONLY: W3IOGR - USE W3IORSMD, ONLY: W3IORS - USE W3GSRUMD, ONLY: W3DIST -!/ - USE W3GDATMD - USE W3WDATMD - USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NAPROC, IAPROC, & - NAPOUT, NAPERR, FNMPRE + USE W3DISPMD, ONLY : WAVNU1 + USE W3IOGRMD, ONLY: W3IOGR + USE W3IORSMD, ONLY: W3IORS + USE W3GSRUMD, ONLY: W3DIST + !/ + USE W3GDATMD + USE W3WDATMD + USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NAPROC, IAPROC, & + NAPOUT, NAPERR, FNMPRE #ifdef W3_WRST - USE W3IDATMD, ONLY: W3NINP + USE W3IDATMD, ONLY: W3NINP #endif -!/ - IMPLICIT NONE -! + !/ + IMPLICIT NONE + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NDSI, NDSM, NDSR, NDSTRC, NTRACE, & - NDSEN, IERR, ITYPE, NCOS, IKM, IK, & - ITHM, ITH, JSEA, ISEA, IX, IY, J + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NDSI, NDSM, NDSR, NDSTRC, NTRACE, & + NDSEN, IERR, ITYPE, NCOS, IKM, IK, & + ITHM, ITH, JSEA, ISEA, IX, IY, J #ifdef W3_MPI - INTEGER :: IERR_MPI + INTEGER :: IERR_MPI #endif #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_O6 - INTEGER :: NSX, NSY - INTEGER, ALLOCATABLE :: MAPO(:,:) + INTEGER :: NSX, NSY + INTEGER, ALLOCATABLE :: MAPO(:,:) #endif - REAL :: FP, SIP, THM, XM, SIX, YM, SIY, HMAX,& - CHSIP, FRREL, ETOT, E1I, FACTOR, X, & - Y, RDSQR, ALFA, GAMMA, SIGA, SIGB, & - YLN, FR, BETA, FRR, S, SUMD, ANG, & - ARG, FACS, DEPTH, WN, CG, HPQMAX - REAL, ALLOCATABLE :: E1(:), DD(:), E2(:,:), E21(:), FINP(:,:) + REAL :: FP, SIP, THM, XM, SIX, YM, SIY, HMAX,& + CHSIP, FRREL, ETOT, E1I, FACTOR, X, & + Y, RDSQR, ALFA, GAMMA, SIGA, SIGB, & + YLN, FR, BETA, FRR, S, SUMD, ANG, & + ARG, FACS, DEPTH, WN, CG, HPQMAX + REAL, ALLOCATABLE :: E1(:), DD(:), E2(:,:), E21(:), FINP(:,:) #ifdef W3_O5 - REAL, ALLOCATABLE :: E2OUT(:,:) + REAL, ALLOCATABLE :: E2OUT(:,:) #endif #ifdef W3_O6 - REAL, ALLOCATABLE :: HSIG(:,:) + REAL, ALLOCATABLE :: HSIG(:,:) #endif - CHARACTER :: COMSTR*1, INXOUT*4 + CHARACTER :: COMSTR*1, INXOUT*4 #ifdef W3_EXPORTWWM - INTEGER :: ISPEC + INTEGER :: ISPEC #endif - LOGICAL :: FLONE,NOSIX -!/ -!/ ------------------------------------------------------------------- / -! -! 1.a Initialize data structure -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) + LOGICAL :: FLONE,NOSIX + !/ + !/ ------------------------------------------------------------------- / + ! + ! 1.a Initialize data structure + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) #ifdef W3_NL1 - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) #endif - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) #ifdef W3_WRST - CALL W3NINP( 6, 6 ) + CALL W3NINP( 6, 6 ) #endif -! -! 1.b IO set-up. -! - NDSI = 10 - NDSM = 20 - NDSR = 20 -! - FLOGRR(:,:) = .FALSE. -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + ! + ! 1.b IO set-up. + ! + NDSI = 10 + NDSM = 20 + NDSR = 20 + ! + FLOGRR(:,:) = .FALSE. + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_S - CALL STRACE (IENT, 'W3STRT') + CALL STRACE (IENT, 'W3STRT') #endif -! -! 1.c MPP initializations -! + ! + ! 1.c MPP initializations + ! #ifdef W3_SHRD - NAPROC = 1 - IAPROC = 1 + NAPROC = 1 + IAPROC = 1 #endif -! + ! #ifdef W3_MPI - CALL MPI_INIT ( IERR_MPI ) - CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) - CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) - IAPROC = IAPROC + 1 + CALL MPI_INIT ( IERR_MPI ) + CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 #endif -! - IF ( IAPROC .EQ. NAPERR ) THEN - NDSEN = NDSE - ELSE - NDSEN = -1 - END IF -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) -! - J = LEN_TRIM(FNMPRE) - OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_strt.inp',STATUS='OLD', & - ERR=800,IOSTAT=IERR) - REWIND (NDSI) - READ (NDSI,'(A)',END=801,ERR=802) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read model definition file and mpp initializations. -! 2.a Reading file -! - CALL W3IOGR ( 'READ', NDSM ) -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,902) GNAME -! -! 2.b MPP initializations -! + ! + IF ( IAPROC .EQ. NAPERR ) THEN + NDSEN = NDSE + ELSE + NDSEN = -1 + END IF + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) + ! + J = LEN_TRIM(FNMPRE) + OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_strt.inp',STATUS='OLD', & + ERR=800,IOSTAT=IERR) + REWIND (NDSI) + READ (NDSI,'(A)',END=801,ERR=802) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read model definition file and mpp initializations. + ! 2.a Reading file + ! + CALL W3IOGR ( 'READ', NDSM ) + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,902) GNAME + ! + ! 2.b MPP initializations + ! #ifdef W3_SHRD - NSEAL = NSEA + NSEAL = NSEA #endif -! + ! #ifdef W3_DIST - NSEAL = 1 + (NSEA-IAPROC)/NAPROC - IF ( NSEA .LT. NAPROC ) GOTO 803 + NSEAL = 1 + (NSEA-IAPROC)/NAPROC + IF ( NSEA .LT. NAPROC ) GOTO 803 #endif -! - CALL W3DIMW ( 1, NDSE, NDST ) - ALLOCATE ( E1(NK), DD(NTH), E2(NTH,NK), E21(NSPEC), & - FINP(NK,NTH) ) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Read type from input file. -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=801,ERR=802) ITYPE - IF ( ITYPE.LT.1 .OR. ITYPE.GT.5 ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1010) ITYPE - CALL EXTCDE ( 1 ) - END IF - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,930) ITYPE -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. ITYPE = 1, Gaussian, cosine. -! - IF ( ITYPE .EQ. 1 ) THEN - INXOUT = 'COLD' -! -! 4.a Read parameters. -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=801,ERR=802) & - FP, SIP, THM, NCOS, XM, SIX, YM, SIY, HMAX - FP = MAX ( 0.5 * TPIINV * SIG(1) , FP ) - SIP = MAX ( 0. , SIP ) - DO - IF ( THM .LT. 0. ) THEN - THM = THM + 360. - ELSE - EXIT - END IF - END DO - THM = MOD ( THM , 360. ) - NCOS = MAX ( 0 , 2*(NCOS/2) ) + ! + CALL W3DIMW ( 1, NDSE, NDST ) + ALLOCATE ( E1(NK), DD(NTH), E2(NTH,NK), E21(NSPEC), & + FINP(NK,NTH) ) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Read type from input file. + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=801,ERR=802) ITYPE + IF ( ITYPE.LT.1 .OR. ITYPE.GT.5 ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1010) ITYPE + CALL EXTCDE ( 1 ) + END IF + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,930) ITYPE + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. ITYPE = 1, Gaussian, cosine. + ! + IF ( ITYPE .EQ. 1 ) THEN + INXOUT = 'COLD' + ! + ! 4.a Read parameters. + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=801,ERR=802) & + FP, SIP, THM, NCOS, XM, SIX, YM, SIY, HMAX + FP = MAX ( 0.5 * TPIINV * SIG(1) , FP ) + SIP = MAX ( 0. , SIP ) + DO + IF ( THM .LT. 0. ) THEN + THM = THM + 360. + ELSE + EXIT + END IF + END DO + THM = MOD ( THM , 360. ) + NCOS = MAX ( 0 , 2*(NCOS/2) ) - NOSIX=.FALSE. - IF(SIX.LT.0.0)THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,903) - NOSIX=.TRUE. - END IF + NOSIX=.FALSE. + IF(SIX.LT.0.0)THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,903) + NOSIX=.TRUE. + END IF - HPQMAX=-999.0 - DO JSEA=1, NSEAL + HPQMAX=-999.0 + DO JSEA=1, NSEAL #ifdef W3_DIST - ISEA = IAPROC + (JSEA-1)*NAPROC + ISEA = IAPROC + (JSEA-1)*NAPROC #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF(HPFAC(IY,IX).GT.HPQMAX)THEN - HPQMAX=HPFAC(IY,IX) - ENDIF - END DO - SIX = MAX(0.01*HPQMAX,SIX) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF(HPFAC(IY,IX).GT.HPQMAX)THEN + HPQMAX=HPFAC(IY,IX) + ENDIF + END DO + SIX = MAX(0.01*HPQMAX,SIX) - HPQMAX=-999.0 - DO JSEA=1, NSEAL + HPQMAX=-999.0 + DO JSEA=1, NSEAL #ifdef W3_DIST - ISEA = IAPROC + (JSEA-1)*NAPROC + ISEA = IAPROC + (JSEA-1)*NAPROC #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF(HQFAC(IY,IX).GT.HPQMAX)THEN - HPQMAX=HQFAC(IY,IX) - ENDIF - END DO - SIY = MAX(0.01*HPQMAX,SIY) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF(HQFAC(IY,IX).GT.HPQMAX)THEN + HPQMAX=HQFAC(IY,IX) + ENDIF + END DO + SIY = MAX(0.01*HPQMAX,SIY) - HMAX = MAX ( 0. , HMAX ) -! - IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( FLAGLL ) THEN - FACTOR = 1. - WRITE (NDSO,940) FP, SIP, THM, NCOS, & - FACTOR*XM, MIN(9999.99,FACTOR*SIX), FACTOR*YM, & - MIN(9999.99,FACTOR*SIY), HMAX - ELSE - FACTOR = 1.E-3 - WRITE (NDSO,941) FP, SIP, THM, NCOS, & - FACTOR*XM, MIN(9999.99,FACTOR*SIX), FACTOR*YM, & - MIN(9999.99,FACTOR*SIY), HMAX - END IF - END IF -! - FP = FP * TPI - SIP = SIP * TPI - THM = MOD ( 630. - THM , 360. ) * DERA -! -! 4.b Make 1-D spectrum. -! - CHSIP = 0.1 * DSIP(1) - FLONE = SIP .LT. CHSIP - IKM = NINT ( 1. + (LOG(FP)-LOG(FR1*TPI))/LOG(XFR) ) - IKM = MAX ( 1 , MIN ( NK , IKM ) ) -! - DO IK=1, NK - IF ( FLONE ) THEN - IF (IK.EQ.IKM) THEN - E1(IK) = 1. - ELSE - E1(IK) = 0. - END IF - ELSE - FRREL = (SIG(IK)-FP)/SIP - IF (ABS(FRREL).LT.10) THEN - E1(IK) = EXP ( -0.125 * FRREL**2 ) - ELSE - E1(IK) = 0. - END IF - END IF - END DO -! + HMAX = MAX ( 0. , HMAX ) + ! + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( FLAGLL ) THEN + FACTOR = 1. + WRITE (NDSO,940) FP, SIP, THM, NCOS, & + FACTOR*XM, MIN(9999.99,FACTOR*SIX), FACTOR*YM, & + MIN(9999.99,FACTOR*SIY), HMAX + ELSE + FACTOR = 1.E-3 + WRITE (NDSO,941) FP, SIP, THM, NCOS, & + FACTOR*XM, MIN(9999.99,FACTOR*SIX), FACTOR*YM, & + MIN(9999.99,FACTOR*SIY), HMAX + END IF + END IF + ! + FP = FP * TPI + SIP = SIP * TPI + THM = MOD ( 630. - THM , 360. ) * DERA + ! + ! 4.b Make 1-D spectrum. + ! + CHSIP = 0.1 * DSIP(1) + FLONE = SIP .LT. CHSIP + IKM = NINT ( 1. + (LOG(FP)-LOG(FR1*TPI))/LOG(XFR) ) + IKM = MAX ( 1 , MIN ( NK , IKM ) ) + ! + DO IK=1, NK + IF ( FLONE ) THEN + IF (IK.EQ.IKM) THEN + E1(IK) = 1. + ELSE + E1(IK) = 0. + END IF + ELSE + FRREL = (SIG(IK)-FP)/SIP + IF (ABS(FRREL).LT.10) THEN + E1(IK) = EXP ( -0.125 * FRREL**2 ) + ELSE + E1(IK) = 0. + END IF + END IF + END DO + ! #ifdef W3_O4 - IF ( IAPROC .EQ. NAPOUT ) CALL PRT1DS & - (NDSO, NK, E1, SIG(1:), ' ', 10, 0., & - 'Unscaled 1-D', ' ', 'TEST E(f)') + IF ( IAPROC .EQ. NAPOUT ) CALL PRT1DS & + (NDSO, NK, E1, SIG(1:), ' ', 10, 0., & + 'Unscaled 1-D', ' ', 'TEST E(f)') #endif -! -! 4.c Make directional distribution. -! - FLONE = NCOS .GT. 20 - ITHM = 1 + NINT ( THM / DTH ) - DO ITH=1, NTH - IF (FLONE) THEN - IF ( ITH .EQ. ITHM ) THEN - DD(ITH) = 1. - ELSE - DD(ITH) = 0. - END IF - ELSE - DD(ITH) = MAX ( COS(TH(ITH)-THM) , 0. )**NCOS - END IF - END DO -! -! 4.d 2-D energy spectrum. -! - ETOT = 0. - DO IK=1, NK - E1I = 0. - DO ITH=1, NTH - E2(ITH,IK) = E1(IK) * DD(ITH) - E1I = E1I + E2(ITH,IK) - END DO - ETOT = ETOT + E1I * DSIP(IK) - END DO - ETOT = ETOT * DTH - FACTOR = HMAX**2 / ( 16. * ETOT ) -! - E2 = FACTOR * E2 -! + ! + ! 4.c Make directional distribution. + ! + FLONE = NCOS .GT. 20 + ITHM = 1 + NINT ( THM / DTH ) + DO ITH=1, NTH + IF (FLONE) THEN + IF ( ITH .EQ. ITHM ) THEN + DD(ITH) = 1. + ELSE + DD(ITH) = 0. + END IF + ELSE + DD(ITH) = MAX ( COS(TH(ITH)-THM) , 0. )**NCOS + END IF + END DO + ! + ! 4.d 2-D energy spectrum. + ! + ETOT = 0. + DO IK=1, NK + E1I = 0. + DO ITH=1, NTH + E2(ITH,IK) = E1(IK) * DD(ITH) + E1I = E1I + E2(ITH,IK) + END DO + ETOT = ETOT + E1I * DSIP(IK) + END DO + ETOT = ETOT * DTH + FACTOR = HMAX**2 / ( 16. * ETOT ) + ! + E2 = FACTOR * E2 + ! #ifdef W3_O5 - ALLOCATE ( E2OUT(NK,NTH) ) - DO ITH=1, NTH - DO IK=1, NK - E2OUT(IK,ITH) = TPI * E2(ITH,IK) - END DO - END DO + ALLOCATE ( E2OUT(NK,NTH) ) + DO ITH=1, NTH + DO IK=1, NK + E2OUT(IK,ITH) = TPI * E2(ITH,IK) + END DO + END DO #endif -! + ! #ifdef W3_O5 - IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & - ( NDSO, NK, NK, NTH, E2OUT, SIG(1:), ' ', DERA*TPI, & - 0., 0.0001, 'Energy', 'm2s', 'TEST 2-D') - DEALLOCATE ( E2OUT ) + IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & + ( NDSO, NK, NK, NTH, E2OUT, SIG(1:), ' ', DERA*TPI, & + 0., 0.0001, 'Energy', 'm2s', 'TEST 2-D') + DEALLOCATE ( E2OUT ) #endif -! -! 4.e Distribute over grid. -! + ! + ! 4.e Distribute over grid. + ! - DO IK=1, NK - E21(1+(IK-1)*NTH:IK*NTH) = E2(:,IK) - END DO -! - DO JSEA=1, NSEAL -! + DO IK=1, NK + E21(1+(IK-1)*NTH:IK*NTH) = E2(:,IK) + END DO + ! + DO JSEA=1, NSEAL + ! #ifdef W3_DIST - ISEA = IAPROC + (JSEA-1)*NAPROC + ISEA = IAPROC + (JSEA-1)*NAPROC #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif - IF (GTYPE .EQ. UNGTYPE) THEN - IX = MAPSF(ISEA,1) - X = XGRD(1,IX) - Y = YGRD(1,IX) - ELSE - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - X = XGRD(IY,IX) - Y = YGRD(IY,IX) - ENDIF - IF(NOSIX)THEN - RDSQR =(W3DIST(FLAGLL,X,Y,XM,YM)/SIY)**2 - ELSE - RDSQR =((X-XM)/SIX)**2 + ((Y-YM)/SIY)**2 - ENDIF - IF ( RDSQR .GT. 40. ) THEN - FACTOR = 0. - ELSE - FACTOR = EXP ( -0.5 * RDSQR ) - END IF -! + IF (GTYPE .EQ. UNGTYPE) THEN + IX = MAPSF(ISEA,1) + X = XGRD(1,IX) + Y = YGRD(1,IX) + ELSE + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + X = XGRD(IY,IX) + Y = YGRD(IY,IX) + ENDIF + IF(NOSIX)THEN + RDSQR =(W3DIST(FLAGLL,X,Y,XM,YM)/SIY)**2 + ELSE + RDSQR =((X-XM)/SIX)**2 + ((Y-YM)/SIY)**2 + ENDIF + IF ( RDSQR .GT. 40. ) THEN + FACTOR = 0. + ELSE + FACTOR = EXP ( -0.5 * RDSQR ) + END IF + ! #ifdef W3_EXPORTWWM - FACTOR = 1. + FACTOR = 1. #endif - VA(:,JSEA) = FACTOR * E21 -! + VA(:,JSEA) = FACTOR * E21 + ! -! - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. ITYPE = 2, pre-defined JONSWAP. -! - ELSE IF ( ITYPE .EQ. 2 ) THEN - INXOUT = 'COLD' -! -! 5.a Read parameters. -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=801,ERR=802) & - ALFA, FP, THM, GAMMA, SIGA, SIGB, XM, SIX, YM, SIY -! - IF (ALFA.LE.0.) ALFA = 0.0081 - IF (FP .LE.0.) FP = 0.10 - IF (SIGA.LE.0.) SIGA = 0.07 - IF (SIGB.LE.0.) SIGB = 0.09 - FP = MAX ( 0.5 * TPIINV * SIG(1) , FP ) - FP = MIN ( TPIINV * SIG(NK) , FP ) + ! + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. ITYPE = 2, pre-defined JONSWAP. + ! + ELSE IF ( ITYPE .EQ. 2 ) THEN + INXOUT = 'COLD' + ! + ! 5.a Read parameters. + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=801,ERR=802) & + ALFA, FP, THM, GAMMA, SIGA, SIGB, XM, SIX, YM, SIY + ! + IF (ALFA.LE.0.) ALFA = 0.0081 + IF (FP .LE.0.) FP = 0.10 + IF (SIGA.LE.0.) SIGA = 0.07 + IF (SIGB.LE.0.) SIGB = 0.09 + FP = MAX ( 0.5 * TPIINV * SIG(1) , FP ) + FP = MIN ( TPIINV * SIG(NK) , FP ) - NOSIX=.FALSE. - IF(SIX.LT.0.0)THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,903) - NOSIX=.TRUE. - END IF + NOSIX=.FALSE. + IF(SIX.LT.0.0)THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,903) + NOSIX=.TRUE. + END IF - HPQMAX=-999.0 - DO JSEA=1, NSEAL + HPQMAX=-999.0 + DO JSEA=1, NSEAL #ifdef W3_DIST - ISEA = IAPROC + (JSEA-1)*NAPROC + ISEA = IAPROC + (JSEA-1)*NAPROC #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF(HPFAC(IY,IX).GT.HPQMAX)THEN - HPQMAX=HPFAC(IY,IX) - ENDIF - END DO - SIX = MAX(0.01*HPQMAX,SIX) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF(HPFAC(IY,IX).GT.HPQMAX)THEN + HPQMAX=HPFAC(IY,IX) + ENDIF + END DO + SIX = MAX(0.01*HPQMAX,SIX) - HPQMAX=-999.0 - DO JSEA=1, NSEAL + HPQMAX=-999.0 + DO JSEA=1, NSEAL #ifdef W3_DIST - ISEA = IAPROC + (JSEA-1)*NAPROC + ISEA = IAPROC + (JSEA-1)*NAPROC #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IF(HQFAC(IY,IX).GT.HPQMAX)THEN - HPQMAX=HQFAC(IY,IX) - ENDIF - END DO - SIY = MAX(0.01*HPQMAX,SIY) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF(HQFAC(IY,IX).GT.HPQMAX)THEN + HPQMAX=HQFAC(IY,IX) + ENDIF + END DO + SIY = MAX(0.01*HPQMAX,SIY) - DO - IF ( THM .LT. 0. ) THEN - THM = THM + 360. - ELSE - EXIT - END IF - END DO - THM = MOD ( THM , 360. ) - GAMMA = MAX (GAMMA,1.) - YLN = LOG(GAMMA) -! - IF ( IAPROC .EQ. NAPOUT ) THEN - IF ( FLAGLL ) THEN - FACTOR = 1. - WRITE (NDSO,950) ALFA, FP, THM, GAMMA, SIGA, SIGB, & - FACTOR*XM, FACTOR*SIX, FACTOR*YM, FACTOR*SIY - ELSE - FACTOR = 1.E-3 - WRITE (NDSO,951) ALFA, FP, THM, GAMMA, SIGA, SIGB, & - FACTOR*XM, FACTOR*SIX, FACTOR*YM, FACTOR*SIY - END IF - END IF - THM = MOD ( 630. - THM , 360. ) * DERA -! -! 5.b Make 1-D spectrum. -! - DO IK=1, NK - FR = SIG(IK) * TPIINV - E1(IK) = EJ5P (FR, ALFA, FP, YLN, SIGA, SIGB ) - END DO -! + DO + IF ( THM .LT. 0. ) THEN + THM = THM + 360. + ELSE + EXIT + END IF + END DO + THM = MOD ( THM , 360. ) + GAMMA = MAX (GAMMA,1.) + YLN = LOG(GAMMA) + ! + IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( FLAGLL ) THEN + FACTOR = 1. + WRITE (NDSO,950) ALFA, FP, THM, GAMMA, SIGA, SIGB, & + FACTOR*XM, FACTOR*SIX, FACTOR*YM, FACTOR*SIY + ELSE + FACTOR = 1.E-3 + WRITE (NDSO,951) ALFA, FP, THM, GAMMA, SIGA, SIGB, & + FACTOR*XM, FACTOR*SIX, FACTOR*YM, FACTOR*SIY + END IF + END IF + THM = MOD ( 630. - THM , 360. ) * DERA + ! + ! 5.b Make 1-D spectrum. + ! + DO IK=1, NK + FR = SIG(IK) * TPIINV + E1(IK) = EJ5P (FR, ALFA, FP, YLN, SIGA, SIGB ) + END DO + ! #ifdef W3_O4 - IF ( IAPROC .EQ. NAPOUT ) CALL PRT1DS & - (NDSO, NK, E1, SIG(1:), ' ', 18, 0., & - 'E(f)', ' ', 'TEST 1-D') + IF ( IAPROC .EQ. NAPOUT ) CALL PRT1DS & + (NDSO, NK, E1, SIG(1:), ' ', 18, 0., & + 'E(f)', ' ', 'TEST 1-D') #endif -! -! 5.c 2-D energy spectrum. -! Factor 2pi to go to E(sigma,theta) -! - DO IK = 1,NK - FR = SIG(IK) * TPIINV - IF (FR.LT.FP) THEN - BETA = 4.06 - ELSE - BETA = -2.34 - END IF - FRR = MIN ( 2.5 , FR/FP ) - S = 9.77 * FRR**BETA - SUMD = 0. - DO ITH = 1,NTH - ANG = COS( 0.5 * ( THM - TH(ITH) ) )**2 - DD(ITH) = 0. - IF(ANG.GT.1.E-20) THEN - ARG = S * LOG(ANG) - IF(ARG.GT.-170) DD(ITH) = EXP(ARG) - END IF - SUMD = SUMD + DD(ITH) - END DO - FACTOR = 1. / (TPI*SUMD*DTH) - DO ITH = 1,NTH - E2(ITH,IK) = FACTOR * E1(IK) * DD(ITH) - END DO - END DO -! + ! + ! 5.c 2-D energy spectrum. + ! Factor 2pi to go to E(sigma,theta) + ! + DO IK = 1,NK + FR = SIG(IK) * TPIINV + IF (FR.LT.FP) THEN + BETA = 4.06 + ELSE + BETA = -2.34 + END IF + FRR = MIN ( 2.5 , FR/FP ) + S = 9.77 * FRR**BETA + SUMD = 0. + DO ITH = 1,NTH + ANG = COS( 0.5 * ( THM - TH(ITH) ) )**2 + DD(ITH) = 0. + IF(ANG.GT.1.E-20) THEN + ARG = S * LOG(ANG) + IF(ARG.GT.-170) DD(ITH) = EXP(ARG) + END IF + SUMD = SUMD + DD(ITH) + END DO + FACTOR = 1. / (TPI*SUMD*DTH) + DO ITH = 1,NTH + E2(ITH,IK) = FACTOR * E1(IK) * DD(ITH) + END DO + END DO + ! #ifdef W3_O5 - ALLOCATE ( E2OUT(NK,NTH) ) - DO ITH=1, NTH - DO IK=1, NK - E2OUT(IK,ITH) = TPI * E2(ITH,IK) - END DO - END DO + ALLOCATE ( E2OUT(NK,NTH) ) + DO ITH=1, NTH + DO IK=1, NK + E2OUT(IK,ITH) = TPI * E2(ITH,IK) + END DO + END DO #endif -! + ! #ifdef W3_O5 - IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & - (NDSO, NK, NK, NTH, E2OUT, SIG(1:), ' ', 1., & - 0., 0.0001, 'E(f,theta)', 'm2s', 'TEST 2-D') - DEALLOCATE ( E2OUT ) + IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & + (NDSO, NK, NK, NTH, E2OUT, SIG(1:), ' ', 1., & + 0., 0.0001, 'E(f,theta)', 'm2s', 'TEST 2-D') + DEALLOCATE ( E2OUT ) #endif -! -! 5.d Distribute over grid. -! + ! + ! 5.d Distribute over grid. + ! - DO IK=1, NK - E21(1+(IK-1)*NTH:IK*NTH) = E2(:,IK) - END DO -! -! - DO JSEA=1, NSEAL -! + DO IK=1, NK + E21(1+(IK-1)*NTH:IK*NTH) = E2(:,IK) + END DO + ! + ! + DO JSEA=1, NSEAL + ! #ifdef W3_DIST - ISEA = IAPROC + (JSEA-1)*NAPROC + ISEA = IAPROC + (JSEA-1)*NAPROC #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif - IF (GTYPE .EQ. UNGTYPE) THEN - IX = MAPSF(ISEA,1) - X = XGRD(1,IX) - Y = YGRD(1,IX) - ELSE - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - X = XGRD(IY,IX) - Y = YGRD(IY,IX) - ENDIF - IF(NOSIX)THEN - RDSQR =(W3DIST(FLAGLL,X,Y,XM,YM)/SIY)**2 - ELSE - RDSQR =((X-XM)/SIX)**2 + ((Y-YM)/SIY)**2 - ENDIF - IF ( RDSQR .GT. 40. ) THEN - FACTOR = 0. - ELSE - FACTOR = EXP ( -0.5 * RDSQR ) - END IF -! - VA(:,JSEA) = FACTOR * E21 -! - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6. ITYPE = 3, fetch limited JONSWAP. -! - ELSE IF ( ITYPE .EQ. 3 ) THEN - INXOUT = 'WIND' - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,960) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 7. ITYPE = 4, User defined. -! - ELSE IF ( ITYPE .EQ. 4 ) THEN - INXOUT = 'COLD' -! -! 7.a Read parameters. -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=801,ERR=802) FACS - IF ( FACS .LE. 0. ) FACS = 1. - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,970) FACS -! -! 7.b Read and rescale spectrum. -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=801,ERR=802) & - ((FINP(IK,ITH),IK=1,NK),ITH=1,NTH) -! - FINP = FINP * FACS / TPI -! + IF (GTYPE .EQ. UNGTYPE) THEN + IX = MAPSF(ISEA,1) + X = XGRD(1,IX) + Y = YGRD(1,IX) + ELSE + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + X = XGRD(IY,IX) + Y = YGRD(IY,IX) + ENDIF + IF(NOSIX)THEN + RDSQR =(W3DIST(FLAGLL,X,Y,XM,YM)/SIY)**2 + ELSE + RDSQR =((X-XM)/SIX)**2 + ((Y-YM)/SIY)**2 + ENDIF + IF ( RDSQR .GT. 40. ) THEN + FACTOR = 0. + ELSE + FACTOR = EXP ( -0.5 * RDSQR ) + END IF + ! + VA(:,JSEA) = FACTOR * E21 + ! + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 6. ITYPE = 3, fetch limited JONSWAP. + ! + ELSE IF ( ITYPE .EQ. 3 ) THEN + INXOUT = 'WIND' + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,960) + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 7. ITYPE = 4, User defined. + ! + ELSE IF ( ITYPE .EQ. 4 ) THEN + INXOUT = 'COLD' + ! + ! 7.a Read parameters. + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=801,ERR=802) FACS + IF ( FACS .LE. 0. ) FACS = 1. + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,970) FACS + ! + ! 7.b Read and rescale spectrum. + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=801,ERR=802) & + ((FINP(IK,ITH),IK=1,NK),ITH=1,NTH) + ! + FINP = FINP * FACS / TPI + ! #ifdef W3_O5 - IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & - (NDSO, NK, NK, NTH, FINP, SIG(1:), ' ', TPI, & - 0., 0.0001, 'Energy', 'm2s', 'TEST 2-D') + IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & + (NDSO, NK, NK, NTH, FINP, SIG(1:), ' ', TPI, & + 0., 0.0001, 'Energy', 'm2s', 'TEST 2-D') #endif -! -! 7.c Distribute over grid. -! - DO JSEA=1, NSEAL -! + ! + ! 7.c Distribute over grid. + ! + DO JSEA=1, NSEAL + ! #ifdef W3_DIST - ISEA = IAPROC + (JSEA-1)*NAPROC + ISEA = IAPROC + (JSEA-1)*NAPROC #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif - DO IK=1, NK - DO ITH=1, NTH - VA(ITH+(IK-1)*NTH,JSEA) = FINP(IK,ITH) - END DO - END DO - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 8. ITYPE = 5, fetch limited JONSWAP. -! - ELSE - INXOUT = 'CALM' - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,980) -! - END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 9. Convert E(sigma) to N(k) -! - IF ( ITYPE.NE.3 .AND. ITYPE.NE.5 ) THEN - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,990) -! + DO IK=1, NK + DO ITH=1, NTH + VA(ITH+(IK-1)*NTH,JSEA) = FINP(IK,ITH) + END DO + END DO + END DO + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 8. ITYPE = 5, fetch limited JONSWAP. + ! + ELSE + INXOUT = 'CALM' + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,980) + ! + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 9. Convert E(sigma) to N(k) + ! + IF ( ITYPE.NE.3 .AND. ITYPE.NE.5 ) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,990) + ! #ifdef W3_O6 - ALLOCATE ( HSIG(NX,NY) ) - HSIG = 0. + ALLOCATE ( HSIG(NX,NY) ) + HSIG = 0. #endif -! - DO JSEA=1, NSEAL + ! + DO JSEA=1, NSEAL #ifdef W3_DIST - ISEA = IAPROC + (JSEA-1)*NAPROC + ISEA = IAPROC + (JSEA-1)*NAPROC #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif - DEPTH = MAX ( DMIN , -ZB(ISEA) ) + DEPTH = MAX ( DMIN , -ZB(ISEA) ) #ifdef W3_O6 - ETOT = 0. + ETOT = 0. #endif - DO IK=1, NK - CALL WAVNU1 ( SIG(IK), DEPTH, WN, CG ) + DO IK=1, NK + CALL WAVNU1 ( SIG(IK), DEPTH, WN, CG ) #ifdef W3_O6 - E1I = 0. + E1I = 0. #endif - DO ITH=1, NTH + DO ITH=1, NTH #ifdef W3_O6 - E1I = E1I + VA(ITH+(IK-1)*NTH,JSEA) + E1I = E1I + VA(ITH+(IK-1)*NTH,JSEA) #endif - VA(ITH+(IK-1)*NTH,JSEA) = VA(ITH+(IK-1)*NTH,JSEA) * & - CG / SIG(IK) - END DO + VA(ITH+(IK-1)*NTH,JSEA) = VA(ITH+(IK-1)*NTH,JSEA) * & + CG / SIG(IK) + END DO #ifdef W3_O6 - ETOT = ETOT + E1I*DSIP(IK) + ETOT = ETOT + E1I*DSIP(IK) #endif - END DO + END DO #ifdef W3_O6 - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - HSIG(IX,IY) = 4. * SQRT ( ETOT * DTH ) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + HSIG(IX,IY) = 4. * SQRT ( ETOT * DTH ) #endif #ifdef W3_EXPORTWWM - IF (JSEA .eq. 1) THEN - DO ITH=1,NTH - DO IK=1,NK - ISPEC = ITH + NTH * (IK-1) - WRITE(10003) ITH, IK, VA(ISPEC,JSEA) - END DO - END DO - WRITE(740+IAPROC,*) 'FINAL : sum(VA)=', sum(VA(:,JSEA)) - END IF -#endif + IF (JSEA .eq. 1) THEN + DO ITH=1,NTH + DO IK=1,NK + ISPEC = ITH + NTH * (IK-1) + WRITE(10003) ITH, IK, VA(ISPEC,JSEA) END DO -! + END DO + WRITE(740+IAPROC,*) 'FINAL : sum(VA)=', sum(VA(:,JSEA)) + END IF +#endif + END DO + ! #ifdef W3_O6 - ALLOCATE ( MAPO(NX,NY) ) - DO IX=1, NX - DO IY=1, NY - MAPO(IX,IY) = MAPSTA(IY,IX) - END DO - END DO + ALLOCATE ( MAPO(NX,NY) ) + DO IX=1, NX + DO IY=1, NY + MAPO(IX,IY) = MAPSTA(IY,IX) + END DO + END DO #endif -! + ! #ifdef W3_MPI - IF ( NAPROC .EQ. 1 ) THEN + IF ( NAPROC .EQ. 1 ) THEN #endif #ifdef W3_O6 - NSX = 1 + NX/35 - NSY = 1 + NY/35 - IF ( IAPROC .EQ. NAPOUT ) CALL PRTBLK & - (NDSO, NX, NY, NX, HSIG, MAPO, 0, 0., & - 1, NX, NSX, 1, NY, NSY, 'Hs', 'm') + NSX = 1 + NX/35 + NSY = 1 + NY/35 + IF ( IAPROC .EQ. NAPOUT ) CALL PRTBLK & + (NDSO, NX, NY, NX, HSIG, MAPO, 0, 0., & + 1, NX, NSX, 1, NY, NSY, 'Hs', 'm') #endif #ifdef W3_MPI - END IF + END IF #endif -! - END IF -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!10. Write restart file. -! - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,995) - CALL W3IORS ( INXOUT, NDSR, SIG(NK) ) -! - GOTO 888 -! -! Escape locations read errors : -! - 800 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) IERR - CALL EXTCDE ( 10 ) -! - 801 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) - CALL EXTCDE ( 11 ) -! - 802 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) IERR - CALL EXTCDE ( 12 ) -! + ! + END IF + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !10. Write restart file. + ! + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,995) + CALL W3IORS ( INXOUT, NDSR, SIG(NK) ) + ! + GOTO 888 + ! + ! Escape locations read errors : + ! +800 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) IERR + CALL EXTCDE ( 10 ) + ! +801 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) + CALL EXTCDE ( 11 ) + ! +802 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) IERR + CALL EXTCDE ( 12 ) + ! #ifdef W3_DIST - 803 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) NSEA, NAPROC - CALL EXTCDE ( 13 ) +803 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) NSEA, NAPROC + CALL EXTCDE ( 13 ) #endif -! - 888 CONTINUE - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) + ! +888 CONTINUE + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) #ifdef W3_MPI - CALL MPI_FINALIZE ( IERR_MPI ) + CALL MPI_FINALIZE ( IERR_MPI ) #endif -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Initial conditions *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) - 902 FORMAT ( ' Grid name : ',A/) - 903 FORMAT ( ' Negative SIX was provided by user. '/ & - ' WW3 will create a gaussian distribution '/ & - ' that is circular in real space. ') -! - 930 FORMAT (/' Initial field ITYPE =',I2/ & - ' --------------------------------------------------') -! - 940 FORMAT ( ' Gaussian / cosine power spectrum '// & - ' Peak frequency and spread (Hz) :',2X,2F8.4/ & - ' Mean direction (Naut., degr.) :',F7.1/ & - ' Cosine power of dir. distribution :',I5/ & - ' Mean longitude and spread (degr.) :',2F8.2/ & - ' Mean latitude and spread (degr.) :',2F8.2/ & - ' Maximum wave height :',F8.2/) -! - 950 FORMAT ( ' JONSWAP spectrum'// & - ' alfa (-) : ',F12.5/ & - ' Peak frequecy (Hz) : ',F11.4/ & - ' Mean direction (Naut.,deg.) : ',F 8.1/ & - ' gamma (-) : ',F 9.2/ & - ' sigma-A (-) : ',F11.4/ & - ' sigma-B (-) : ',F11.4/ & - ' Mean longitude and spread (degr.) : ',2F9.2/ & - ' Mean latitude and spread (degr.) : ',2F9.2) - 941 FORMAT ( ' Gaussian / cosine power spectrum '// & - ' Peak frequency and spread (Hz) :',2X,2F8.4/ & - ' Mean direction (Naut., degr.) :',F7.1/ & - ' Cosine power of dir. distribution :',I5/ & - ' Mean X and spread (km) :',2F8.2/ & - ' Mean Y and spread (km) :',2F8.2/ & - ' Maximum wave height :',F8.2/) -! - 951 FORMAT ( ' JONSWAP spectrum'// & - ' alfa (-) : ',F12.5/ & - ' Peak frequecy (Hz) : ',F11.4/ & - ' Mean direction (Naut.,deg.) : ',F 8.1/ & - ' gamma (-) : ',F 9.2/ & - ' sigma-A (-) : ',F11.4/ & - ' sigma-B (-) : ',F11.4/ & - ' Mean X and spread (km) : ',2F9.2/ & - ' Mean Y and spread (km) : ',2F9.2) -! - 960 FORMAT ( ' Fetch-limited JONSWAP spectra based on local '/ & - ' wind speed (fetch related to grid increment).') -! - 970 FORMAT ( ' User-defined energy spectrum F(f,theta).'// & - ' Scale factor (-) : ',E12.4/) -! - 980 FORMAT ( ' Starting from calm conditions (Hs = 0)') -! - 990 FORMAT (/' Converting energy to action ... ') - 995 FORMAT (/' Writing restart file ... '/) -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Initial conditions '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & - ' ILLEGAL TYPE, ITYPE =',I4/) -! + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Initial conditions *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) +902 FORMAT ( ' Grid name : ',A/) +903 FORMAT ( ' Negative SIX was provided by user. '/ & + ' WW3 will create a gaussian distribution '/ & + ' that is circular in real space. ') + ! +930 FORMAT (/' Initial field ITYPE =',I2/ & + ' --------------------------------------------------') + ! +940 FORMAT ( ' Gaussian / cosine power spectrum '// & + ' Peak frequency and spread (Hz) :',2X,2F8.4/ & + ' Mean direction (Naut., degr.) :',F7.1/ & + ' Cosine power of dir. distribution :',I5/ & + ' Mean longitude and spread (degr.) :',2F8.2/ & + ' Mean latitude and spread (degr.) :',2F8.2/ & + ' Maximum wave height :',F8.2/) + ! +950 FORMAT ( ' JONSWAP spectrum'// & + ' alfa (-) : ',F12.5/ & + ' Peak frequecy (Hz) : ',F11.4/ & + ' Mean direction (Naut.,deg.) : ',F 8.1/ & + ' gamma (-) : ',F 9.2/ & + ' sigma-A (-) : ',F11.4/ & + ' sigma-B (-) : ',F11.4/ & + ' Mean longitude and spread (degr.) : ',2F9.2/ & + ' Mean latitude and spread (degr.) : ',2F9.2) +941 FORMAT ( ' Gaussian / cosine power spectrum '// & + ' Peak frequency and spread (Hz) :',2X,2F8.4/ & + ' Mean direction (Naut., degr.) :',F7.1/ & + ' Cosine power of dir. distribution :',I5/ & + ' Mean X and spread (km) :',2F8.2/ & + ' Mean Y and spread (km) :',2F8.2/ & + ' Maximum wave height :',F8.2/) + ! +951 FORMAT ( ' JONSWAP spectrum'// & + ' alfa (-) : ',F12.5/ & + ' Peak frequecy (Hz) : ',F11.4/ & + ' Mean direction (Naut.,deg.) : ',F 8.1/ & + ' gamma (-) : ',F 9.2/ & + ' sigma-A (-) : ',F11.4/ & + ' sigma-B (-) : ',F11.4/ & + ' Mean X and spread (km) : ',2F9.2/ & + ' Mean Y and spread (km) : ',2F9.2) + ! +960 FORMAT ( ' Fetch-limited JONSWAP spectra based on local '/ & + ' wind speed (fetch related to grid increment).') + ! +970 FORMAT ( ' User-defined energy spectrum F(f,theta).'// & + ' Scale factor (-) : ',E12.4/) + ! +980 FORMAT ( ' Starting from calm conditions (Hs = 0)') + ! +990 FORMAT (/' Converting energy to action ... ') +995 FORMAT (/' Writing restart file ... '/) + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Initial conditions '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & + ' ILLEGAL TYPE, ITYPE =',I4/) + ! #ifdef W3_DIST - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & - ' NUMBER OF SEA POINTS LESS THAN NUMBER OF PROC.'/ & - ' NSEA, NAPROC =',2I8/) +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & + ' NUMBER OF SEA POINTS LESS THAN NUMBER OF PROC.'/ & + ' NSEA, NAPROC =',2I8/) #endif -!/ -!/ End of W3STRT ----------------------------------------------------- / -!/ - END PROGRAM W3STRT + !/ + !/ End of W3STRT ----------------------------------------------------- / + !/ +END PROGRAM W3STRT diff --git a/model/src/ww3_systrk.F90 b/model/src/ww3_systrk.F90 index dd02b10a9..ca13678d0 100644 --- a/model/src/ww3_systrk.F90 +++ b/model/src/ww3_systrk.F90 @@ -7,12 +7,12 @@ !> date 16-Jan-2017 ! !/ ------------------------------------------------------------------- / -!> @brief Perform spatial and temporal tracking of wave systems, based +!> @brief Perform spatial and temporal tracking of wave systems, based !> on spectral partition (bulletin) output. !> -!> @details This is a controller program. It reads the input parameter file -!> ww3_systrk.inp and calls subroutine waveTracking_NWS_V2 to -!> perform the actual tracking procedure. Write output (fields and +!> @details This is a controller program. It reads the input parameter file +!> ww3_systrk.inp and calls subroutine waveTracking_NWS_V2 to +!> perform the actual tracking procedure. Write output (fields and !> point output). !> !> @author A. J. van der Westhuysen @@ -20,712 +20,712 @@ !> @author Eve-Marie Devaliere !> date 16-Jan-2017 ! - PROGRAM WW3_SYSTRK -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | A. J. van der Westhuysen | -!/ | Jeff Hanson | -!/ | Eve-Marie Devaliere | -!/ | FORTRAN 95 | -!/ | Last update : 16-Jan-2017 | -!/ +-----------------------------------+ -!/ -!/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) -!/ by Jeff Hanson & Eve-Marie Devaliere -!/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) -!/ 29-Nov-2013 : Remove DOC control characters, -!/ update MPI! to MPI/! (H.L. Tolman). ( version 4.15 ) -!/ 11-Feb-2014 : Add NetCDF output option. Both NetCDF-3 and -!/ NetCDF-4 are available. (B. Li). ( version 4.18 ) -!/ 26-Sep-2016 : Optimization updates (A. van der Westhuysen) -!/ ( version 5.15 ) -!/ 20-Sep-2016 : Add support for unformatted partition file. -!/ (S.Zieger BoM, Australia) ( version 5.16 ) -!/ 20-Dec-2016 : Optimized search algorithms and -!/ set functions. (S.Zieger) ( version 5.16 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ - USE W3STRKMD - USE W3TIMEMD, ONLY: TDIFF - IMPLICIT NONE +PROGRAM WW3_SYSTRK + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | A. J. van der Westhuysen | + !/ | Jeff Hanson | + !/ | Eve-Marie Devaliere | + !/ | FORTRAN 95 | + !/ | Last update : 16-Jan-2017 | + !/ +-----------------------------------+ + !/ + !/ 03-Feb-2012 : Origination, based on Matlab code ( version 4.05 ) + !/ by Jeff Hanson & Eve-Marie Devaliere + !/ 04-Jan-2013 : Inclusion in trunk ( version 4.08 ) + !/ 29-Nov-2013 : Remove DOC control characters, + !/ update MPI! to MPI/! (H.L. Tolman). ( version 4.15 ) + !/ 11-Feb-2014 : Add NetCDF output option. Both NetCDF-3 and + !/ NetCDF-4 are available. (B. Li). ( version 4.18 ) + !/ 26-Sep-2016 : Optimization updates (A. van der Westhuysen) + !/ ( version 5.15 ) + !/ 20-Sep-2016 : Add support for unformatted partition file. + !/ (S.Zieger BoM, Australia) ( version 5.16 ) + !/ 20-Dec-2016 : Optimized search algorithms and + !/ set functions. (S.Zieger) ( version 5.16 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + USE W3STRKMD + USE W3TIMEMD, ONLY: TDIFF + IMPLICIT NONE #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -! -! 1. Purpose : -! -! Perform spatial and temporal tracking of wave systems, based -! on spectral partition (bulletin) output. -! -! 2. Method : -! -! This is a controller program. It reads the input parameter file -! ww3_systrk.inp and calls subroutine waveTracking_NWS_V2 to -! perform the actual tracking procedure. Write output (fields and -! point output). -! -! 3. Parameters : -! - LOGICAL :: testout - PARAMETER (testout = .FALSE.) - CHARACTER :: filename*80, paramFile*32 - REAL :: dirKnob, perKnob, hsKnob, wetPts, seedLat, & - seedLon, dirTimeKnob, tpTimeKnob, tint - REAL :: lonout(100), latout(100) !Increase dimension? - INTEGER :: maxGroup, ntint, noutp - INTEGER :: CLKDT0(8),CLKDT1(8) - REAL :: CLKFEL - TYPE(dat2d), POINTER :: wsdat(:) - TYPE(timsys), POINTER :: sysA(:) - INTEGER, POINTER :: maxSys(:) -! -! Local parameters. -! ---------------------------------------------------------------- -! intype Int input Type of input (0 = from memory; 1 = from file) -! tmax Int input Value of maxTs to apply (1 or 2, used for model coupling) -! tcur Int input Index of current time step (1 or 2, used for model coupling) -! ulimGroup Int input Upper limit of number of wave systems to output -! - LOGICAL :: file_exists - CHARACTER :: inpstr*72 - INTEGER :: intype, tmax, tcur, maxI, maxJ - INTEGER :: it, igrp, sysmatch, ind, ip - INTEGER :: i, j, leng, ulimGroup - REAL, ALLOCATABLE :: dum(:,:) + ! + ! 1. Purpose : + ! + ! Perform spatial and temporal tracking of wave systems, based + ! on spectral partition (bulletin) output. + ! + ! 2. Method : + ! + ! This is a controller program. It reads the input parameter file + ! ww3_systrk.inp and calls subroutine waveTracking_NWS_V2 to + ! perform the actual tracking procedure. Write output (fields and + ! point output). + ! + ! 3. Parameters : + ! + LOGICAL :: testout + PARAMETER (testout = .FALSE.) + CHARACTER :: filename*80, paramFile*32 + REAL :: dirKnob, perKnob, hsKnob, wetPts, seedLat, & + seedLon, dirTimeKnob, tpTimeKnob, tint + REAL :: lonout(100), latout(100) !Increase dimension? + INTEGER :: maxGroup, ntint, noutp + INTEGER :: CLKDT0(8),CLKDT1(8) + REAL :: CLKFEL + TYPE(dat2d), POINTER :: wsdat(:) + TYPE(timsys), POINTER :: sysA(:) + INTEGER, POINTER :: maxSys(:) + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! intype Int input Type of input (0 = from memory; 1 = from file) + ! tmax Int input Value of maxTs to apply (1 or 2, used for model coupling) + ! tcur Int input Index of current time step (1 or 2, used for model coupling) + ! ulimGroup Int input Upper limit of number of wave systems to output + ! + LOGICAL :: file_exists + CHARACTER :: inpstr*72 + INTEGER :: intype, tmax, tcur, maxI, maxJ + INTEGER :: it, igrp, sysmatch, ind, ip + INTEGER :: i, j, leng, ulimGroup + REAL, ALLOCATABLE :: dum(:,:) #ifdef W3_TRKNC - REAL, ALLOCATABLE :: dum2nc(:,:,:,:) - REAL, ALLOCATABLE :: hsprt_nc(:,:,:) - REAL, ALLOCATABLE :: tpprt_nc(:,:,:) - REAL, ALLOCATABLE :: dirprt_nc(:,:,:) - REAL, ALLOCATABLE :: longitude_nc(:),latitude_nc(:) - REAL, ALLOCATABLE :: lonprt_nc(:),latprt_nc(:) + REAL, ALLOCATABLE :: dum2nc(:,:,:,:) + REAL, ALLOCATABLE :: hsprt_nc(:,:,:) + REAL, ALLOCATABLE :: tpprt_nc(:,:,:) + REAL, ALLOCATABLE :: dirprt_nc(:,:,:) + REAL, ALLOCATABLE :: longitude_nc(:),latitude_nc(:) + REAL, ALLOCATABLE :: lonprt_nc(:),latprt_nc(:) #endif - INTEGER NTIME_NC - INTEGER :: outputType - LOGICAL :: outputCheck1 - DOUBLE PRECISION :: date1, date2, tstart, tend - REAL :: dlon, dlat, lonprt, latprt - REAL :: dt - REAL :: minlon, maxlon, minlat, maxlat - INTEGER :: mxcwt, mycwt + INTEGER NTIME_NC + INTEGER :: outputType + LOGICAL :: outputCheck1 + DOUBLE PRECISION :: date1, date2, tstart, tend + REAL :: dlon, dlat, lonprt, latprt + REAL :: dt + REAL :: minlon, maxlon, minlat, maxlat + INTEGER :: mxcwt, mycwt #ifdef W3_MPI - INTEGER :: rank, nproc, ierr - CHARACTER :: rankstr*4 + INTEGER :: rank, nproc, ierr + CHARACTER :: rankstr*4 #endif -! For point output (bilinear interpolation) - REAL :: hsprt(10),tpprt(10),dirprt(10) - REAL :: BL_hsprt(10),BR_hsprt(10),TR_hsprt(10),TL_hsprt(10), & - BL_tpprt(10),BR_tpprt(10),TR_tpprt(10),TL_tpprt(10), & - BL_dirprt(10),BR_dirprt(10),TR_dirprt(10),TL_dirprt(10) - REAL :: BL_dirx,BR_dirx,TR_dirx,TL_dirx, & - BL_diry,BR_diry,TR_diry,TL_diry - REAL :: BL_lonprt,BR_lonprt,TR_lonprt,TL_lonprt, & - BL_latprt,BR_latprt,TR_latprt,TL_latprt - REAL :: t, u, BL_W, BR_W, TR_W, TL_W - REAL :: PI - PARAMETER (PI = 3.1416) -! -! 4. Subroutines used : -! -! waveTracking_NWS_V2 -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! Calls subroutine waveTracking_NWS_V2 in trackmd.95 - see that -! file for structure. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/MPI Id. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! + ! For point output (bilinear interpolation) + REAL :: hsprt(10),tpprt(10),dirprt(10) + REAL :: BL_hsprt(10),BR_hsprt(10),TR_hsprt(10),TL_hsprt(10), & + BL_tpprt(10),BR_tpprt(10),TR_tpprt(10),TL_tpprt(10), & + BL_dirprt(10),BR_dirprt(10),TR_dirprt(10),TL_dirprt(10) + REAL :: BL_dirx,BR_dirx,TR_dirx,TL_dirx, & + BL_diry,BR_diry,TR_diry,TL_diry + REAL :: BL_lonprt,BR_lonprt,TR_lonprt,TL_lonprt, & + BL_latprt,BR_latprt,TR_latprt,TL_latprt + REAL :: t, u, BL_W, BR_W, TR_W, TL_W + REAL :: PI + PARAMETER (PI = 3.1416) + ! + ! 4. Subroutines used : + ! + ! waveTracking_NWS_V2 + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! Calls subroutine waveTracking_NWS_V2 in trackmd.95 - see that + ! file for structure. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/MPI Id. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! #ifdef W3_MPI -! Start of parallel region - CALL MPI_INIT(ierr) - - CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, ierr) + ! Start of parallel region + CALL MPI_INIT(ierr) + + CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, ierr) #endif -! Open log file + ! Open log file #ifdef W3_MPI - WRITE(rankstr,'(i4.4)') rank - OPEN(unit=20,file='sys_log'//rankstr//'.ww3',status='unknown') + WRITE(rankstr,'(i4.4)') rank + OPEN(unit=20,file='sys_log'//rankstr//'.ww3',status='unknown') #endif #ifdef W3_SHRD - OPEN(unit=20,file='sys_log.ww3',status='unknown') + OPEN(unit=20,file='sys_log.ww3',status='unknown') #endif -! Print code version + ! Print code version #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif - WRITE(6,900) + WRITE(6,900) #ifdef W3_MPI - END IF + END IF #endif - WRITE(20,900) - 900 FORMAT (/15X,' *** WAVEWATCH III Wave system tracking *** '/ & - 15X,'==============================================='/) - -! Since this program reads the raw partitioning input from file, -! we set intype=1 or 2, and tmax and tcur to dummy values (not used). - intype = 2 -! intype = 1 - IF (intype.EQ.1) WRITE(6,*) & - '*** WARNING: partRes format input used!' - tmax = 0 - tcur = 0 - -! Read input parameter file + WRITE(20,900) +900 FORMAT (/15X,' *** WAVEWATCH III Wave system tracking *** '/ & + 15X,'==============================================='/) + + ! Since this program reads the raw partitioning input from file, + ! we set intype=1 or 2, and tmax and tcur to dummy values (not used). + intype = 2 + ! intype = 1 + IF (intype.EQ.1) WRITE(6,*) & + '*** WARNING: partRes format input used!' + tmax = 0 + tcur = 0 + + ! Read input parameter file #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif - INQUIRE(FILE='ww3_systrk.inp', EXIST=file_exists) - IF (.NOT.file_exists) THEN - WRITE(20,2000) - WRITE(6,2000) - CALL ABORT - END IF - OPEN(unit=10,file='ww3_systrk.inp',status='old') - + INQUIRE(FILE='ww3_systrk.inp', EXIST=file_exists) + IF (.NOT.file_exists) THEN + WRITE(20,2000) + WRITE(6,2000) + CALL ABORT + END IF + OPEN(unit=10,file='ww3_systrk.inp',status='old') + + READ(10,'(A72)') inpstr + DO WHILE (inpstr(1:1).EQ.'$') READ(10,'(A72)') inpstr - DO WHILE (inpstr(1:1).EQ.'$') - READ(10,'(A72)') inpstr - END DO - BACKSPACE(10) - READ(10,*) filename + END DO + BACKSPACE(10) + READ(10,*) filename + READ(10,'(A72)') inpstr + DO WHILE (inpstr(1:1).EQ.'$') READ(10,'(A72)') inpstr - DO WHILE (inpstr(1:1).EQ.'$') - READ(10,'(A72)') inpstr - END DO - BACKSPACE(10) - READ(10,*) date1, date2, dt, ntint - tstart = date1 + date2/1000000 + END DO + BACKSPACE(10) + READ(10,*) date1, date2, dt, ntint + tstart = date1 + date2/1000000 + READ(10,'(A72)') inpstr + DO WHILE (inpstr(1:1).EQ.'$') READ(10,'(A72)') inpstr - DO WHILE (inpstr(1:1).EQ.'$') - READ(10,'(A72)') inpstr - END DO - BACKSPACE(10) - READ(10,*) outputType - - !Check for correct outputType option: - IF (outputType.EQ.1) THEN - !ASCII output - ELSEIF (outputType.EQ.3) THEN - !NetCDF 3 - requrires !/TRKNC switch - outputCheck1 = .TRUE. + END DO + BACKSPACE(10) + READ(10,*) outputType + + !Check for correct outputType option: + IF (outputType.EQ.1) THEN + !ASCII output + ELSEIF (outputType.EQ.3) THEN + !NetCDF 3 - requrires !/TRKNC switch + outputCheck1 = .TRUE. #ifdef W3_TRKNC - outputCheck1 = .FALSE. + outputCheck1 = .FALSE. #endif - IF(outputCheck1) THEN - WRITE(6,993) - STOP - END IF - ELSEIF (outputType.EQ.4) THEN - !NetCDF 4 - requrires !/TRKNC switch - outputCheck1 = .TRUE. + IF(outputCheck1) THEN + WRITE(6,993) + STOP + END IF + ELSEIF (outputType.EQ.4) THEN + !NetCDF 4 - requrires !/TRKNC switch + outputCheck1 = .TRUE. #ifdef W3_TRKNC - outputCheck1 = .FALSE. + outputCheck1 = .FALSE. #endif - IF(outputCheck1) THEN - WRITE(6,994) - STOP - END IF - ELSE - !Not a valid outputType - WRITE(6,995) outputType - STOP - ENDIF - + IF(outputCheck1) THEN + WRITE(6,994) + STOP + END IF + ELSE + !Not a valid outputType + WRITE(6,995) outputType + STOP + ENDIF + + READ(10,'(A72)') inpstr + DO WHILE (inpstr(1:1).EQ.'$') READ(10,'(A72)') inpstr - DO WHILE (inpstr(1:1).EQ.'$') - READ(10,'(A72)') inpstr - END DO - BACKSPACE(10) - READ(10,*) minlon, maxlon, mxcwt + END DO + BACKSPACE(10) + READ(10,*) minlon, maxlon, mxcwt + READ(10,'(A72)') inpstr + DO WHILE (inpstr(1:1).EQ.'$') READ(10,'(A72)') inpstr - DO WHILE (inpstr(1:1).EQ.'$') - READ(10,'(A72)') inpstr - END DO - BACKSPACE(10) - READ(10,*) minlat, maxlat, mycwt + END DO + BACKSPACE(10) + READ(10,*) minlat, maxlat, mycwt + READ(10,'(A72)') inpstr + DO WHILE (inpstr(1:1).EQ.'$') READ(10,'(A72)') inpstr - DO WHILE (inpstr(1:1).EQ.'$') - READ(10,'(A72)') inpstr - END DO - BACKSPACE(10) - READ(10,*) dirKnob, perKnob, hsKnob, wetPts, & - dirTimeKnob, tpTimeKnob + END DO + BACKSPACE(10) + READ(10,*) dirKnob, perKnob, hsKnob, wetPts, & + dirTimeKnob, tpTimeKnob + READ(10,'(A72)') inpstr + DO WHILE (inpstr(1:1).EQ.'$') READ(10,'(A72)') inpstr - DO WHILE (inpstr(1:1).EQ.'$') - READ(10,'(A72)') inpstr - END DO - BACKSPACE(10) - READ(10,*) seedLat, seedLon + END DO + BACKSPACE(10) + READ(10,*) seedLat, seedLon + READ(10,'(A72)') inpstr + DO WHILE (inpstr(1:1).EQ.'$') READ(10,'(A72)') inpstr - DO WHILE (inpstr(1:1).EQ.'$') - READ(10,'(A72)') inpstr - END DO - BACKSPACE(10) - noutp = 1 - lonout(:) = 9999. - latout(:) = 9999. - DO WHILE (.TRUE.) - READ(10,*) lonout(noutp),latout(noutp) - IF ((lonout(noutp).EQ.0.).AND.(latout(noutp).EQ.0.)) EXIT - noutp = noutp + 1 - END DO - noutp = noutp - 1 - - CLOSE(10) - - WRITE(20,*) 'Raw partition file = ',filename - WRITE(20,'(A,F15.6)') 'Start time = ',tstart - WRITE(20,*) 'dt = ',dt - WRITE(20,*) 'No. time levels = ',ntint - WRITE(20,'(A,2F7.2)') 'Domain limits: Longitude =',minlon, maxlon - WRITE(20,'(A,2F7.2)') ' Latitude =',minlat, maxlat - WRITE(20,*) 'No. increments: Long, Lat =',mxcwt, mycwt - WRITE(20,*) 'dirKnob, perKnob, hsKnob, wetPts, & - dirTimeKnob, tpTimeKnob, seedLat, seedLon =' - WRITE(20,'(8F6.2)') dirKnob, perKnob, hsKnob, wetPts, & - dirTimeKnob, tpTimeKnob, seedLat, seedLon - WRITE(20,*) 'No. output points =',noutp - DO i = 1,noutp - WRITE(20,*) lonout(i), latout(i) - END DO - - INQUIRE(FILE=filename, EXIST=file_exists) - IF (.NOT.file_exists) THEN - WRITE(20,2200) filename - WRITE(6,2200) filename - CALL EXIT(1) - END IF - - - CALL DATE_AND_TIME ( VALUES=CLKDT0 ) + END DO + BACKSPACE(10) + noutp = 1 + lonout(:) = 9999. + latout(:) = 9999. + DO WHILE (.TRUE.) + READ(10,*) lonout(noutp),latout(noutp) + IF ((lonout(noutp).EQ.0.).AND.(latout(noutp).EQ.0.)) EXIT + noutp = noutp + 1 + END DO + noutp = noutp - 1 + + CLOSE(10) + + WRITE(20,*) 'Raw partition file = ',filename + WRITE(20,'(A,F15.6)') 'Start time = ',tstart + WRITE(20,*) 'dt = ',dt + WRITE(20,*) 'No. time levels = ',ntint + WRITE(20,'(A,2F7.2)') 'Domain limits: Longitude =',minlon, maxlon + WRITE(20,'(A,2F7.2)') ' Latitude =',minlat, maxlat + WRITE(20,*) 'No. increments: Long, Lat =',mxcwt, mycwt + WRITE(20,*) 'dirKnob, perKnob, hsKnob, wetPts, & + dirTimeKnob, tpTimeKnob, seedLat, seedLon =' + WRITE(20,'(8F6.2)') dirKnob, perKnob, hsKnob, wetPts, & + dirTimeKnob, tpTimeKnob, seedLat, seedLon + WRITE(20,*) 'No. output points =',noutp + DO i = 1,noutp + WRITE(20,*) lonout(i), latout(i) + END DO + + INQUIRE(FILE=filename, EXIST=file_exists) + IF (.NOT.file_exists) THEN + WRITE(20,2200) filename + WRITE(6,2200) filename + CALL EXIT(1) + END IF + + + CALL DATE_AND_TIME ( VALUES=CLKDT0 ) #ifdef W3_MPI - END IF + END IF #endif #ifdef W3_MPI -! MPI communication block - CALL MPI_BCAST(filename,80,MPI_CHARACTER,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(tstart,1,MPI_DOUBLE_PRECISION,0, & - MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(tend,1,MPI_DOUBLE_PRECISION,0, & - MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(dt,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(ntint,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(minlon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(maxlon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(minlat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(maxlat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(mxcwt,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(mycwt,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(dirKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(perKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(hsKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(wetPts,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(dirTimeKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(tpTimeKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(seedLon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(seedLat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(noutp,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(lonout,100,MPI_REAL,0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(latout,100,MPI_REAL,0,MPI_COMM_WORLD,IERR) + ! MPI communication block + CALL MPI_BCAST(filename,80,MPI_CHARACTER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(tstart,1,MPI_DOUBLE_PRECISION,0, & + MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(tend,1,MPI_DOUBLE_PRECISION,0, & + MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(dt,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(ntint,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(minlon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(maxlon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(minlat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(maxlat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(mxcwt,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(mycwt,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(dirKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(perKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(hsKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(wetPts,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(dirTimeKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(tpTimeKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(seedLon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(seedLat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(noutp,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(lonout,100,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(latout,100,MPI_REAL,0,MPI_COMM_WORLD,IERR) #endif #ifdef W3_MPI - CALL MPI_Barrier(MPI_COMM_WORLD,IERR) + CALL MPI_Barrier(MPI_COMM_WORLD,IERR) #endif - CALL waveTracking_NWS_V2 (intype ,tmax , & - tcur ,filename , & - tstart ,tend , & - dt ,ntint , & - minlon ,maxlon , & - minlat ,maxlat , & - mxcwt ,mycwt , & - dirKnob , & - perKnob ,hsKnob , & - wetPts ,seedLat , & - seedLon ,dirTimeKnob, & - tpTimeKnob ,paramFile , & - sysA ,wsdat , & - maxSys ,maxGroup ) + CALL waveTracking_NWS_V2 (intype ,tmax , & + tcur ,filename , & + tstart ,tend , & + dt ,ntint , & + minlon ,maxlon , & + minlat ,maxlat , & + mxcwt ,mycwt , & + dirKnob , & + perKnob ,hsKnob , & + wetPts ,seedLat , & + seedLon ,dirTimeKnob, & + tpTimeKnob ,paramFile , & + sysA ,wsdat , & + maxSys ,maxGroup ) #ifdef W3_MPI - IF (rank.EQ.0) THEN + IF (rank.EQ.0) THEN #endif - CALL DATE_AND_TIME ( VALUES=CLKDT1 ) - CLKFEL = TDIFF ( CLKDT0,CLKDT1 ) - WRITE (6,998) CLKFEL - WRITE (6,*) 'Final system output...' + CALL DATE_AND_TIME ( VALUES=CLKDT1 ) + CLKFEL = TDIFF ( CLKDT0,CLKDT1 ) + WRITE (6,998) CLKFEL + WRITE (6,*) 'Final system output...' -! Set upper limit for wave systems to output (limited by AWIPS display) - ulimGroup = 9 + ! Set upper limit for wave systems to output (limited by AWIPS display) + ulimGroup = 9 -!-----Output systems as plain text---------------------------------------- + !-----Output systems as plain text---------------------------------------- - maxI = SIZE(wsdat(1)%lon,1) - maxJ = SIZE(wsdat(1)%lon,2) - dlon = wsdat(1)%lon(2,2)-wsdat(1)%lon(1,1) - dlat = wsdat(1)%lat(2,2)-wsdat(1)%lat(1,1) - WRITE(20,*) 'dlon, dlat =',dlon,dlat + maxI = SIZE(wsdat(1)%lon,1) + maxJ = SIZE(wsdat(1)%lon,2) + dlon = wsdat(1)%lon(2,2)-wsdat(1)%lon(1,1) + dlat = wsdat(1)%lat(2,2)-wsdat(1)%lat(1,1) + WRITE(20,*) 'dlon, dlat =',dlon,dlat -!-----Final SYSTEM output: Coordinates - OPEN(unit=21,file='sys_coord.ww3', status='unknown') + !-----Final SYSTEM output: Coordinates + OPEN(unit=21,file='sys_coord.ww3', status='unknown') - WRITE(21,'(I6,69X,A)') maxJ,'Number of rows' - WRITE(21,'(I6,69X,A)') maxI,'Number of cols' + WRITE(21,'(I6,69X,A)') maxJ,'Number of rows' + WRITE(21,'(I6,69X,A)') maxI,'Number of cols' #ifdef W3_TRKNC - ALLOCATE( longitude_nc(maxI) ) - ALLOCATE( latitude_nc(maxJ) ) + ALLOCATE( longitude_nc(maxI) ) + ALLOCATE( latitude_nc(maxJ) ) #endif - WRITE(21,*) 'Longitude =' - DO j = maxJ,1,-1 - DO i = 1,maxI - WRITE(21,'(F7.2)',ADVANCE='NO') wsdat(1)%lon(i,j) + WRITE(21,*) 'Longitude =' + DO j = maxJ,1,-1 + DO i = 1,maxI + WRITE(21,'(F7.2)',ADVANCE='NO') wsdat(1)%lon(i,j) #ifdef W3_TRKNC longitude_nc(i)=wsdat(1)%lon(i,1) #endif - END DO - WRITE(21,'(A)',ADVANCE='YES') '' END DO + WRITE(21,'(A)',ADVANCE='YES') '' + END DO - WRITE(21,*) 'Latitude = ' - DO j = maxJ,1,-1 - DO i = 1,maxI - WRITE(21,'(F7.2)',ADVANCE='NO') wsdat(1)%lat(i,j) + WRITE(21,*) 'Latitude = ' + DO j = maxJ,1,-1 + DO i = 1,maxI + WRITE(21,'(F7.2)',ADVANCE='NO') wsdat(1)%lat(i,j) #ifdef W3_TRKNC latitude_nc(j)=wsdat(1)%lat(1,j) #endif - END DO - WRITE(21,'(A)',ADVANCE='YES') '' END DO + WRITE(21,'(A)',ADVANCE='YES') '' + END DO - CLOSE(21) + CLOSE(21) -!-----Final SYSTEM output: hs - IF(outputType == 1) THEN + !-----Final SYSTEM output: hs + IF(outputType == 1) THEN OPEN(unit=22,file='sys_hs.ww3', status='unknown') WRITE(22,'(I6,69X,A)') maxJ,'Number of rows' WRITE(22,'(I6,69X,A)') maxI,'Number of cols' - ENDIF + ENDIF - NTIME_NC=SIZE(sysA) - ALLOCATE( dum(maxI,maxJ) ) + NTIME_NC=SIZE(sysA) + ALLOCATE( dum(maxI,maxJ) ) #ifdef W3_TRKNC - IF(outputType == 3 .OR. outputType == 4) THEN + IF(outputType == 3 .OR. outputType == 4) THEN ALLOCATE( dum2nc(maxI,maxJ,maxGroup,NTIME_NC) ) - ENDIF + ENDIF #endif - DO it = 1,SIZE(sysA) -! Loop through identified groups, limiting the output in file to ulimGroup - IF(outputType == 1) THEN - WRITE(22,'(F15.6,60x,A)') wsdat(it)%date,'Time' - WRITE(22,'(I6,69x,A)') MIN(ulimGroup,maxGroup), & - 'Tot number of systems' - ENDIF - DO igrp = 1,MIN(ulimGroup,maxGroup) - dum(1:maxI,1:maxJ) = 9999.00 -! Find system with this group tag - sysmatch = 1 - DO WHILE (sysmatch.LE.maxSys(it)) - IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT - sysmatch = sysmatch+1 - END DO - IF (sysmatch.LE.maxSys(it)) THEN -! Match found: fill the output matrix with this data - leng = sysA(it)%sys(sysmatch)%nPoints - DO ind = 1, leng - dum(sysA(it)%sys(sysmatch)%i(ind), & - sysA(it)%sys(sysmatch)%j(ind)) = & - sysA(it)%sys(sysmatch)%hs(ind) - END DO - ELSE - leng = 0 - END IF - + DO it = 1,SIZE(sysA) + ! Loop through identified groups, limiting the output in file to ulimGroup IF(outputType == 1) THEN - WRITE(22,'(I6,69x,A)') igrp,'System number' - WRITE(22,'(I6,69x,A)') leng,'Number of points in system' - - DO J = maxJ,1,-1 - DO i = 1,maxI - WRITE(22,'(F8.2)',ADVANCE='NO') dum(i,j) - END DO - WRITE(22,'(A)',ADVANCE='YES') '' + WRITE(22,'(F15.6,60x,A)') wsdat(it)%date,'Time' + WRITE(22,'(I6,69x,A)') MIN(ulimGroup,maxGroup), & + 'Tot number of systems' + ENDIF + DO igrp = 1,MIN(ulimGroup,maxGroup) + dum(1:maxI,1:maxJ) = 9999.00 + ! Find system with this group tag + sysmatch = 1 + DO WHILE (sysmatch.LE.maxSys(it)) + IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT + sysmatch = sysmatch+1 + END DO + IF (sysmatch.LE.maxSys(it)) THEN + ! Match found: fill the output matrix with this data + leng = sysA(it)%sys(sysmatch)%nPoints + DO ind = 1, leng + dum(sysA(it)%sys(sysmatch)%i(ind), & + sysA(it)%sys(sysmatch)%j(ind)) = & + sysA(it)%sys(sysmatch)%hs(ind) + END DO + ELSE + leng = 0 + END IF + + IF(outputType == 1) THEN + WRITE(22,'(I6,69x,A)') igrp,'System number' + WRITE(22,'(I6,69x,A)') leng,'Number of points in system' + + DO J = maxJ,1,-1 + DO i = 1,maxI + WRITE(22,'(F8.2)',ADVANCE='NO') dum(i,j) END DO - ELSE + WRITE(22,'(A)',ADVANCE='YES') '' + END DO + ELSE #ifdef W3_TRKNC - DO J = maxJ,1,-1 - DO i = 1,maxI - dum2nc(i,j,igrp,it)=dum(i,j) - END DO + DO J = maxJ,1,-1 + DO i = 1,maxI + dum2nc(i,j,igrp,it)=dum(i,j) END DO + END DO #endif - ENDIF + ENDIF - END DO END DO - + END DO + #ifdef W3_TRKNC - IF(outputType == 3 .OR. outputType == 4 ) THEN + IF(outputType == 3 .OR. outputType == 4 ) THEN call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& - maxGroup,date1,date2,dt,NTIME_NC,1,outputType) - ENDIF + maxGroup,date1,date2,dt,NTIME_NC,1,outputType) + ENDIF #endif - IF(outputType.EQ.1) CLOSE(22) + IF(outputType.EQ.1) CLOSE(22) -!-----Final SYSTEM output: tp - IF(outputType == 1) THEN + !-----Final SYSTEM output: tp + IF(outputType == 1) THEN OPEN(unit=23,file='sys_tp.ww3',status='unknown') WRITE(23,'(I6,69X,A)') maxJ,'Number of rows' WRITE(23,'(I6,69X,A)') maxI,'Number of cols' - ENDIF + ENDIF - DO it = 1,SIZE(sysA) -! Loop through identified groups, limiting the output in file to ulimGroup - IF(outputType == 1) THEN - WRITE(23,'(F15.6,60x,A)') wsdat(it)%date,'Time' - WRITE(23,'(I6,69X,A)') MIN(ulimGroup,maxGroup), & - 'Tot number of systems' - ENDIF - DO igrp = 1,MIN(ulimGroup,maxGroup) - dum(1:maxI,1:maxJ) = 9999.00 -! Find system with this group tag - sysmatch = 1 - DO WHILE (sysmatch.LE.maxSys(it)) - IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT - sysmatch = sysmatch+1 - END DO - IF (sysmatch.LE.maxSys(it)) THEN -! Match found: fill the output matrix with this data - leng = sysA(it)%sys(sysmatch)%nPoints - DO ind = 1, leng - dum(sysA(it)%sys(sysmatch)%i(ind), & - sysA(it)%sys(sysmatch)%j(ind)) = & - sysA(it)%sys(sysmatch)%tp(ind) - END DO - ELSE - leng = 0 - END IF - + DO it = 1,SIZE(sysA) + ! Loop through identified groups, limiting the output in file to ulimGroup IF(outputType == 1) THEN - WRITE(23,'(I6,69X,A)') igrp,'System number' - WRITE(23,'(I6,69X,A)') leng,'Number of points in system' - DO J = maxJ,1,-1 - DO i = 1,maxI - WRITE(23,'(F8.2)',ADVANCE='NO') dum(i,j) - END DO - WRITE(23,'(A)',ADVANCE='YES') '' + WRITE(23,'(F15.6,60x,A)') wsdat(it)%date,'Time' + WRITE(23,'(I6,69X,A)') MIN(ulimGroup,maxGroup), & + 'Tot number of systems' + ENDIF + DO igrp = 1,MIN(ulimGroup,maxGroup) + dum(1:maxI,1:maxJ) = 9999.00 + ! Find system with this group tag + sysmatch = 1 + DO WHILE (sysmatch.LE.maxSys(it)) + IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT + sysmatch = sysmatch+1 + END DO + IF (sysmatch.LE.maxSys(it)) THEN + ! Match found: fill the output matrix with this data + leng = sysA(it)%sys(sysmatch)%nPoints + DO ind = 1, leng + dum(sysA(it)%sys(sysmatch)%i(ind), & + sysA(it)%sys(sysmatch)%j(ind)) = & + sysA(it)%sys(sysmatch)%tp(ind) + END DO + ELSE + leng = 0 + END IF + + IF(outputType == 1) THEN + WRITE(23,'(I6,69X,A)') igrp,'System number' + WRITE(23,'(I6,69X,A)') leng,'Number of points in system' + DO J = maxJ,1,-1 + DO i = 1,maxI + WRITE(23,'(F8.2)',ADVANCE='NO') dum(i,j) END DO - ELSE + WRITE(23,'(A)',ADVANCE='YES') '' + END DO + ELSE #ifdef W3_TRKNC - DO J = maxJ,1,-1 - DO i = 1,maxI - dum2nc(i,j,igrp,it)=dum(i,j) - END DO + DO J = maxJ,1,-1 + DO i = 1,maxI + dum2nc(i,j,igrp,it)=dum(i,j) END DO + END DO #endif - ENDIF + ENDIF - END DO END DO + END DO #ifdef W3_TRKNC - IF(outputType.EQ.3 .OR. outputType.EQ. 4 ) THEN + IF(outputType.EQ.3 .OR. outputType.EQ. 4 ) THEN call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& - maxGroup,date1,date2,dt,NTIME_NC,2,outputType) - ENDIF + maxGroup,date1,date2,dt,NTIME_NC,2,outputType) + ENDIF #endif - IF(outputType.EQ.1) CLOSE(23) + IF(outputType.EQ.1) CLOSE(23) -!-----Final SYSTEM output: dir - IF(outputType == 1) THEN + !-----Final SYSTEM output: dir + IF(outputType == 1) THEN OPEN(unit=24,file='sys_dir.ww3',status='unknown') WRITE(24,'(I6,69X,A)') maxJ,'Number of rows' WRITE(24,'(I6,69X,A)') maxI,'Number of cols' - ENDIF + ENDIF - DO it = 1,SIZE(sysA) -! Loop through identified groups, limiting the output in file to -! ulimGroup - IF(outputType == 1) THEN - WRITE(24,'(F15.6,60x,A)') wsdat(it)%date,'Time' - WRITE(24,'(I6,69X,A)') MIN(ulimGroup,maxGroup), & - 'Tot number of systems' - ENDIF - DO igrp = 1,MIN(ulimGroup,maxGroup) - dum(1:maxI,1:maxJ) = 9999.00 -! Find system with this group tag - sysmatch = 1 - DO WHILE (sysmatch.LE.maxSys(it)) - IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT - sysmatch = sysmatch+1 - END DO - IF (sysmatch.LE.maxSys(it)) THEN -! Match found: fill the output matrix with this data - leng = sysA(it)%sys(sysmatch)%nPoints - DO ind = 1, leng - dum(sysA(it)%sys(sysmatch)%i(ind), & - sysA(it)%sys(sysmatch)%j(ind)) = & - sysA(it)%sys(sysmatch)%dir(ind) - END DO - ELSE - leng = 0 - END IF - + DO it = 1,SIZE(sysA) + ! Loop through identified groups, limiting the output in file to + ! ulimGroup IF(outputType == 1) THEN - WRITE(24,'(I6,69X,A)') igrp,'System number' - WRITE(24,'(I6,69X,A)') leng,'Number of points in system' - DO J = maxJ,1,-1 - DO i = 1,maxI - WRITE(24,'(F8.2)',ADVANCE='NO') dum(i,j) - END DO - WRITE(24,'(A)',ADVANCE='YES') '' + WRITE(24,'(F15.6,60x,A)') wsdat(it)%date,'Time' + WRITE(24,'(I6,69X,A)') MIN(ulimGroup,maxGroup), & + 'Tot number of systems' + ENDIF + DO igrp = 1,MIN(ulimGroup,maxGroup) + dum(1:maxI,1:maxJ) = 9999.00 + ! Find system with this group tag + sysmatch = 1 + DO WHILE (sysmatch.LE.maxSys(it)) + IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT + sysmatch = sysmatch+1 + END DO + IF (sysmatch.LE.maxSys(it)) THEN + ! Match found: fill the output matrix with this data + leng = sysA(it)%sys(sysmatch)%nPoints + DO ind = 1, leng + dum(sysA(it)%sys(sysmatch)%i(ind), & + sysA(it)%sys(sysmatch)%j(ind)) = & + sysA(it)%sys(sysmatch)%dir(ind) + END DO + ELSE + leng = 0 + END IF + + IF(outputType == 1) THEN + WRITE(24,'(I6,69X,A)') igrp,'System number' + WRITE(24,'(I6,69X,A)') leng,'Number of points in system' + DO J = maxJ,1,-1 + DO i = 1,maxI + WRITE(24,'(F8.2)',ADVANCE='NO') dum(i,j) END DO - ELSE + WRITE(24,'(A)',ADVANCE='YES') '' + END DO + ELSE #ifdef W3_TRKNC - DO J = maxJ,1,-1 - DO i = 1,maxI - dum2nc(i,j,igrp,it)=dum(i,j) - END DO + DO J = maxJ,1,-1 + DO i = 1,maxI + dum2nc(i,j,igrp,it)=dum(i,j) END DO + END DO #endif - END IF + END IF - END DO END DO + END DO #ifdef W3_TRKNC - IF(outputType.EQ.3 .OR. outputType.EQ.4 ) THEN + IF(outputType.EQ.3 .OR. outputType.EQ.4 ) THEN call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& - maxGroup,date1,date2,dt,NTIME_NC,3,outputType) - ENDIF + maxGroup,date1,date2,dt,NTIME_NC,3,outputType) + ENDIF #endif - IF(outputType.EQ.1) CLOSE(24) + IF(outputType.EQ.1) CLOSE(24) -!-----Final SYSTEM output: dspr - IF(outputType == 1) THEN + !-----Final SYSTEM output: dspr + IF(outputType == 1) THEN OPEN(unit=25,file='sys_dspr.ww3',status='unknown') WRITE(25,'(I6,69X,A)') maxJ,'Number of rows' WRITE(25,'(I6,69X,A)') maxI,'Number of cols' - ENDIF + ENDIF - DO it = 1,SIZE(sysA) -! Loop through identified groups, limiting the output in file to ulimGroup - IF(outputType == 1) THEN - WRITE(25,'(F15.6,60x,A)') wsdat(it)%date,'Time' - WRITE(25,'(I6,69X,A)') MIN(ulimGroup,maxGroup), & - 'Tot number of systems' - ENDIF - DO igrp = 1,MIN(ulimGroup,maxGroup) - dum(1:maxI,1:maxJ) = 9999.00 -! Find system with this group tag - sysmatch = 1 - DO WHILE (sysmatch.LE.maxSys(it)) - IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT - sysmatch = sysmatch+1 - END DO - IF (sysmatch.LE.maxSys(it)) THEN -! Match found: fill the output matrix with this data - leng = sysA(it)%sys(sysmatch)%nPoints - DO ind = 1, leng - dum(sysA(it)%sys(sysmatch)%i(ind), & - sysA(it)%sys(sysmatch)%j(ind)) = & - sysA(it)%sys(sysmatch)%dspr(ind) - END DO - ELSE - leng = 0 - END IF - + DO it = 1,SIZE(sysA) + ! Loop through identified groups, limiting the output in file to ulimGroup IF(outputType == 1) THEN - WRITE(25,'(I6,69X,A)') igrp,'System number' - WRITE(25,'(I6,69X,A)') leng,'Number of points in system' - DO J = maxJ,1,-1 - DO i = 1,maxI - WRITE(25,'(F8.2)',ADVANCE='NO') dum(i,j) - END DO - WRITE(25,'(A)',ADVANCE='YES') '' + WRITE(25,'(F15.6,60x,A)') wsdat(it)%date,'Time' + WRITE(25,'(I6,69X,A)') MIN(ulimGroup,maxGroup), & + 'Tot number of systems' + ENDIF + DO igrp = 1,MIN(ulimGroup,maxGroup) + dum(1:maxI,1:maxJ) = 9999.00 + ! Find system with this group tag + sysmatch = 1 + DO WHILE (sysmatch.LE.maxSys(it)) + IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT + sysmatch = sysmatch+1 + END DO + IF (sysmatch.LE.maxSys(it)) THEN + ! Match found: fill the output matrix with this data + leng = sysA(it)%sys(sysmatch)%nPoints + DO ind = 1, leng + dum(sysA(it)%sys(sysmatch)%i(ind), & + sysA(it)%sys(sysmatch)%j(ind)) = & + sysA(it)%sys(sysmatch)%dspr(ind) + END DO + ELSE + leng = 0 + END IF + + IF(outputType == 1) THEN + WRITE(25,'(I6,69X,A)') igrp,'System number' + WRITE(25,'(I6,69X,A)') leng,'Number of points in system' + DO J = maxJ,1,-1 + DO i = 1,maxI + WRITE(25,'(F8.2)',ADVANCE='NO') dum(i,j) END DO - ELSE + WRITE(25,'(A)',ADVANCE='YES') '' + END DO + ELSE #ifdef W3_TRKNC - DO J = maxJ,1,-1 - DO i = 1,maxI - dum2nc(i,j,igrp,it)=dum(i,j) - END DO + DO J = maxJ,1,-1 + DO i = 1,maxI + dum2nc(i,j,igrp,it)=dum(i,j) END DO + END DO #endif - ENDIF + ENDIF - END DO END DO + END DO #ifdef W3_TRKNC - IF(outputType.EQ.3 .OR. outputType.EQ.4 ) THEN + IF(outputType.EQ.3 .OR. outputType.EQ.4 ) THEN call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& - maxGroup,date1,date2,dt,NTIME_NC,4,outputType) - ENDIF + maxGroup,date1,date2,dt,NTIME_NC,4,outputType) + ENDIF #endif - IF(outputType.EQ.1) CLOSE(25) + IF(outputType.EQ.1) CLOSE(25) - IF (ALLOCATED(DUM)) DEALLOCATE(dum) + IF (ALLOCATED(DUM)) DEALLOCATE(dum) #ifdef W3_TRKNC - IF (ALLOCATED(dum2nc)) DEALLOCATE(dum2nc) + IF (ALLOCATED(dum2nc)) DEALLOCATE(dum2nc) #endif #ifdef W3_TRKNC - IF(outputType.EQ.3.OR.outputType.EQ.4) THEN + IF(outputType.EQ.3.OR.outputType.EQ.4) THEN ALLOCATE( hsprt_nc(10,noutp,NTIME_NC) ) ALLOCATE( tpprt_nc(10,noutp,NTIME_NC) ) ALLOCATE( dirprt_nc(10,noutp,NTIME_NC) ) ALLOCATE( lonprt_nc(noutp) ) ALLOCATE( latprt_nc(noutp) ) - ENDIF + ENDIF #endif -!-----Final SYSTEM output: point output - IF(outputType == 1) THEN + !-----Final SYSTEM output: point output + IF(outputType == 1) THEN OPEN(unit=26,file='sys_pnt.ww3',status='unknown') WRITE(26,'(A)') '%' WRITE(26,'(A)') '%' @@ -740,7 +740,7 @@ PROGRAM WW3_SYSTRK 'TpSY09 TpSY10 ', & 'DrSY01 DrSY02 DrSY03 DrSY04 ', & 'DrSY05 DrSY06 DrSY07 DrSY08 ', & - 'DrSY09 DrSY10' + 'DrSY09 DrSY10' WRITE(26,'(10A)') '% [degr] [degr] ', & '[m] [m] [m] [m] ', & '[m] [m] [m] [m] ', & @@ -752,195 +752,195 @@ PROGRAM WW3_SYSTRK '[degr] [degr] [degr] [degr] ', & '[degr] [degr]' WRITE(26,'(A)') '%' - ENDIF + ENDIF - DO it = 1,SIZE(sysA) + DO it = 1,SIZE(sysA) IF(outputType == 1) THEN - WRITE(26,'(A,F15.6)') 'Time : ',wsdat(it)%date - ENDIF - - DO ip = 1,noutp - hsprt(1:10) = 999.9999 - tpprt(1:10) = 999.9999 - dirprt(1:10) = 999.9999 - lonprt = 999.9999 - latprt = 999.9999 - BL_hsprt(1:10) = 999.9999 - BL_tpprt(1:10) = 999.9999 - BL_dirprt(1:10) = 999.9999 - BR_hsprt(1:10) = 999.9999 - BR_tpprt(1:10) = 999.9999 - BR_dirprt(1:10) = 999.9999 - TL_hsprt(1:10) = 999.9999 - TL_tpprt(1:10) = 999.9999 - TL_dirprt(1:10) = 999.9999 - TR_hsprt(1:10) = 999.9999 - TR_tpprt(1:10) = 999.9999 - TR_dirprt(1:10) = 999.9999 - BL_lonprt = 999.9999 - BL_latprt = 999.9999 - BR_lonprt = 999.9999 - BR_latprt = 999.9999 - TL_lonprt = 999.9999 - TL_latprt = 999.9999 - TR_lonprt = 999.9999 - TR_latprt = 999.9999 - BL_W = 999 - BR_W = 999 - TR_W = 999 - TL_W = 999 - - DO j = 1, (maxJ-1) - DO i = 1, (maxI-1) - IF ( ( ((lonout(ip).GE. & - wsdat(1)%lon(i,j)).AND. & - (lonout(ip).LT. & - wsdat(1)%lon(i+1,j))).OR. & - ((lonout(ip).GT. & - wsdat(1)%lon(i,j)).AND. & - (lonout(ip).LE. & - wsdat(1)%lon(i+1,j))) ).AND. & - ( ((latout(ip).GE. & - wsdat(1)%lat(i,j)).AND. & - (latout(ip).LT. & - wsdat(1)%lat(i,j+1))).OR. & - ((latout(ip).GT. & - wsdat(1)%lat(i,j)).AND. & - (latout(ip).LE. & - wsdat(1)%lat(i,j+1))) ) ) & - THEN - BL_lonprt = wsdat(1)%lon(i,j) - BL_latprt = wsdat(1)%lat(i,j) - BR_lonprt = wsdat(1)%lon(i+1,j) - BR_latprt = wsdat(1)%lat(i+1,j) - TL_lonprt = wsdat(1)%lon(i,j+1) - TL_latprt = wsdat(1)%lat(i,j+1) - TR_lonprt = wsdat(1)%lon(i+1,j+1) - TR_latprt = wsdat(1)%lat(i+1,j+1) -! Compute weights for this point - t = (lonout(ip)-BL_lonprt)/(BR_lonprt-BL_lonprt) - u = (latout(ip)-BL_latprt)/(TL_latprt-BL_latprt) - BL_W = (1-t)*(1-u) - BR_W = t*(1-u) - TR_W = t*u - TL_W = (1-t)*u -! Compute output values using weights - lonprt = BL_W*BL_lonprt + BR_W*BR_lonprt + & - TL_W*TL_lonprt + TR_W*TR_lonprt - latprt = BL_W*BL_latprt + BR_W*BR_latprt + & - TL_W*TL_latprt + TR_W*TR_latprt - END IF - END DO - END DO -! Loop through identified groups, limiting the output in file to 10 - DO igrp = 1,MIN(10,maxGroup) -! Find system with this group tag - sysmatch = 1 - DO WHILE (sysmatch.LE.maxSys(it)) - IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT - sysmatch = sysmatch+1 - END DO - IF (sysmatch.LE.maxSys(it)) THEN -! Match found: fill the output matrix with this data - leng = sysA(it)%sys(sysmatch)%nPoints - DO ind = 1, leng -! Write output point data with bilinear interpolation - IF ( (sysA(it)%sys(sysmatch)%lon(ind).EQ.& - BL_lonprt).AND.& - (sysA(it)%sys(sysmatch)%lat(ind).EQ.& - BL_latprt) ) THEN - BL_hsprt(igrp) = sysA(it)%sys(sysmatch)%hs(ind) - BL_tpprt(igrp) = sysA(it)%sys(sysmatch)%tp(ind) - BL_dirprt(igrp) = sysA(it)%sys(sysmatch)%dir(ind) - ELSE IF ( (sysA(it)%sys(sysmatch)%lon(ind).EQ.& - BR_lonprt).AND.& - (sysA(it)%sys(sysmatch)%lat(ind).EQ.& - BR_latprt)) THEN - BR_hsprt(igrp) = sysA(it)%sys(sysmatch)%hs(ind) - BR_tpprt(igrp) = sysA(it)%sys(sysmatch)%tp(ind) - BR_dirprt(igrp) = sysA(it)%sys(sysmatch)%dir(ind) - ELSE IF ( (sysA(it)%sys(sysmatch)%lon(ind).EQ.& - TL_lonprt).AND.& - (sysA(it)%sys(sysmatch)%lat(ind).EQ.& - TL_latprt)) THEN - TL_hsprt(igrp) = sysA(it)%sys(sysmatch)%hs(ind) - TL_tpprt(igrp) = sysA(it)%sys(sysmatch)%tp(ind) - TL_dirprt(igrp) = sysA(it)%sys(sysmatch)%dir(ind) - ELSE IF ( (sysA(it)%sys(sysmatch)%lon(ind).EQ.& - TR_lonprt).AND.& - (sysA(it)%sys(sysmatch)%lat(ind).EQ.& - TR_latprt)) THEN - TR_hsprt(igrp) = sysA(it)%sys(sysmatch)%hs(ind) - TR_tpprt(igrp) = sysA(it)%sys(sysmatch)%tp(ind) - TR_dirprt(igrp) = sysA(it)%sys(sysmatch)%dir(ind) - END IF - END DO -! Compute output value using weights -! (only if output point is surrounded by valid points) - IF ( (BL_hsprt(igrp).NE.999.9999).AND. & - (BR_hsprt(igrp).NE.999.9999).AND. & - (TL_hsprt(igrp).NE.999.9999).AND. & - (TR_hsprt(igrp).NE.999.9999) ) THEN - hsprt(igrp) = BL_W * BL_hsprt(igrp) + & - BR_W * BR_hsprt(igrp) + & - TL_W * TL_hsprt(igrp) + & - TR_W * TR_hsprt(igrp) - tpprt(igrp) = BL_W * BL_tpprt(igrp) + & - BR_W * BR_tpprt(igrp) + & - TL_W * TL_tpprt(igrp) + & - TR_W * TR_tpprt(igrp) - BL_dirx = COS((270-BL_dirprt(igrp))*PI/180.) - BR_dirx = COS((270-BR_dirprt(igrp))*PI/180.) - TR_dirx = COS((270-TR_dirprt(igrp))*PI/180.) - TL_dirx = COS((270-TL_dirprt(igrp))*PI/180.) - BL_diry = SIN((270-BL_dirprt(igrp))*PI/180.) - BR_diry = SIN((270-BR_dirprt(igrp))*PI/180.) - TR_diry = SIN((270-TR_dirprt(igrp))*PI/180.) - TL_diry = SIN((270-TL_dirprt(igrp))*PI/180.) - dirprt(igrp)=270 - 180./PI* & - ATAN2(BL_W*BL_diry+BR_W*BR_diry+ & - TL_W*TL_diry+TR_W*TR_diry, & - BL_W*BL_dirx+BR_W*BR_dirx+ & - TL_W*TL_dirx+TR_W*TR_dirx) - IF (dirprt(igrp).GT.360.) THEN - dirprt(igrp) = dirprt(igrp) - 360. - END IF - ELSE - hsprt(igrp) = 999.9999 - tpprt(igrp) = 999.9999 - dirprt(igrp) = 999.9999 - END IF - END IF + WRITE(26,'(A,F15.6)') 'Time : ',wsdat(it)%date + ENDIF + + DO ip = 1,noutp + hsprt(1:10) = 999.9999 + tpprt(1:10) = 999.9999 + dirprt(1:10) = 999.9999 + lonprt = 999.9999 + latprt = 999.9999 + BL_hsprt(1:10) = 999.9999 + BL_tpprt(1:10) = 999.9999 + BL_dirprt(1:10) = 999.9999 + BR_hsprt(1:10) = 999.9999 + BR_tpprt(1:10) = 999.9999 + BR_dirprt(1:10) = 999.9999 + TL_hsprt(1:10) = 999.9999 + TL_tpprt(1:10) = 999.9999 + TL_dirprt(1:10) = 999.9999 + TR_hsprt(1:10) = 999.9999 + TR_tpprt(1:10) = 999.9999 + TR_dirprt(1:10) = 999.9999 + BL_lonprt = 999.9999 + BL_latprt = 999.9999 + BR_lonprt = 999.9999 + BR_latprt = 999.9999 + TL_lonprt = 999.9999 + TL_latprt = 999.9999 + TR_lonprt = 999.9999 + TR_latprt = 999.9999 + BL_W = 999 + BR_W = 999 + TR_W = 999 + TL_W = 999 + + DO j = 1, (maxJ-1) + DO i = 1, (maxI-1) + IF ( ( ((lonout(ip).GE. & + wsdat(1)%lon(i,j)).AND. & + (lonout(ip).LT. & + wsdat(1)%lon(i+1,j))).OR. & + ((lonout(ip).GT. & + wsdat(1)%lon(i,j)).AND. & + (lonout(ip).LE. & + wsdat(1)%lon(i+1,j))) ).AND. & + ( ((latout(ip).GE. & + wsdat(1)%lat(i,j)).AND. & + (latout(ip).LT. & + wsdat(1)%lat(i,j+1))).OR. & + ((latout(ip).GT. & + wsdat(1)%lat(i,j)).AND. & + (latout(ip).LE. & + wsdat(1)%lat(i,j+1))) ) ) & + THEN + BL_lonprt = wsdat(1)%lon(i,j) + BL_latprt = wsdat(1)%lat(i,j) + BR_lonprt = wsdat(1)%lon(i+1,j) + BR_latprt = wsdat(1)%lat(i+1,j) + TL_lonprt = wsdat(1)%lon(i,j+1) + TL_latprt = wsdat(1)%lat(i,j+1) + TR_lonprt = wsdat(1)%lon(i+1,j+1) + TR_latprt = wsdat(1)%lat(i+1,j+1) + ! Compute weights for this point + t = (lonout(ip)-BL_lonprt)/(BR_lonprt-BL_lonprt) + u = (latout(ip)-BL_latprt)/(TL_latprt-BL_latprt) + BL_W = (1-t)*(1-u) + BR_W = t*(1-u) + TR_W = t*u + TL_W = (1-t)*u + ! Compute output values using weights + lonprt = BL_W*BL_lonprt + BR_W*BR_lonprt + & + TL_W*TL_lonprt + TR_W*TR_lonprt + latprt = BL_W*BL_latprt + BR_W*BR_latprt + & + TL_W*TL_latprt + TR_W*TR_latprt + END IF + END DO + END DO + ! Loop through identified groups, limiting the output in file to 10 + DO igrp = 1,MIN(10,maxGroup) + ! Find system with this group tag + sysmatch = 1 + DO WHILE (sysmatch.LE.maxSys(it)) + IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT + sysmatch = sysmatch+1 + END DO + IF (sysmatch.LE.maxSys(it)) THEN + ! Match found: fill the output matrix with this data + leng = sysA(it)%sys(sysmatch)%nPoints + DO ind = 1, leng + ! Write output point data with bilinear interpolation + IF ( (sysA(it)%sys(sysmatch)%lon(ind).EQ.& + BL_lonprt).AND.& + (sysA(it)%sys(sysmatch)%lat(ind).EQ.& + BL_latprt) ) THEN + BL_hsprt(igrp) = sysA(it)%sys(sysmatch)%hs(ind) + BL_tpprt(igrp) = sysA(it)%sys(sysmatch)%tp(ind) + BL_dirprt(igrp) = sysA(it)%sys(sysmatch)%dir(ind) + ELSE IF ( (sysA(it)%sys(sysmatch)%lon(ind).EQ.& + BR_lonprt).AND.& + (sysA(it)%sys(sysmatch)%lat(ind).EQ.& + BR_latprt)) THEN + BR_hsprt(igrp) = sysA(it)%sys(sysmatch)%hs(ind) + BR_tpprt(igrp) = sysA(it)%sys(sysmatch)%tp(ind) + BR_dirprt(igrp) = sysA(it)%sys(sysmatch)%dir(ind) + ELSE IF ( (sysA(it)%sys(sysmatch)%lon(ind).EQ.& + TL_lonprt).AND.& + (sysA(it)%sys(sysmatch)%lat(ind).EQ.& + TL_latprt)) THEN + TL_hsprt(igrp) = sysA(it)%sys(sysmatch)%hs(ind) + TL_tpprt(igrp) = sysA(it)%sys(sysmatch)%tp(ind) + TL_dirprt(igrp) = sysA(it)%sys(sysmatch)%dir(ind) + ELSE IF ( (sysA(it)%sys(sysmatch)%lon(ind).EQ.& + TR_lonprt).AND.& + (sysA(it)%sys(sysmatch)%lat(ind).EQ.& + TR_latprt)) THEN + TR_hsprt(igrp) = sysA(it)%sys(sysmatch)%hs(ind) + TR_tpprt(igrp) = sysA(it)%sys(sysmatch)%tp(ind) + TR_dirprt(igrp) = sysA(it)%sys(sysmatch)%dir(ind) + END IF END DO - IF(outputType == 1) THEN - WRITE(26,'(32F14.4)') lonprt,latprt, & - hsprt(1:10),tpprt(1:10),dirprt(1:10) + ! Compute output value using weights + ! (only if output point is surrounded by valid points) + IF ( (BL_hsprt(igrp).NE.999.9999).AND. & + (BR_hsprt(igrp).NE.999.9999).AND. & + (TL_hsprt(igrp).NE.999.9999).AND. & + (TR_hsprt(igrp).NE.999.9999) ) THEN + hsprt(igrp) = BL_W * BL_hsprt(igrp) + & + BR_W * BR_hsprt(igrp) + & + TL_W * TL_hsprt(igrp) + & + TR_W * TR_hsprt(igrp) + tpprt(igrp) = BL_W * BL_tpprt(igrp) + & + BR_W * BR_tpprt(igrp) + & + TL_W * TL_tpprt(igrp) + & + TR_W * TR_tpprt(igrp) + BL_dirx = COS((270-BL_dirprt(igrp))*PI/180.) + BR_dirx = COS((270-BR_dirprt(igrp))*PI/180.) + TR_dirx = COS((270-TR_dirprt(igrp))*PI/180.) + TL_dirx = COS((270-TL_dirprt(igrp))*PI/180.) + BL_diry = SIN((270-BL_dirprt(igrp))*PI/180.) + BR_diry = SIN((270-BR_dirprt(igrp))*PI/180.) + TR_diry = SIN((270-TR_dirprt(igrp))*PI/180.) + TL_diry = SIN((270-TL_dirprt(igrp))*PI/180.) + dirprt(igrp)=270 - 180./PI* & + ATAN2(BL_W*BL_diry+BR_W*BR_diry+ & + TL_W*TL_diry+TR_W*TR_diry, & + BL_W*BL_dirx+BR_W*BR_dirx+ & + TL_W*TL_dirx+TR_W*TR_dirx) + IF (dirprt(igrp).GT.360.) THEN + dirprt(igrp) = dirprt(igrp) - 360. + END IF + ELSE + hsprt(igrp) = 999.9999 + tpprt(igrp) = 999.9999 + dirprt(igrp) = 999.9999 + END IF + END IF + END DO + IF(outputType == 1) THEN + WRITE(26,'(32F14.4)') lonprt,latprt, & + hsprt(1:10),tpprt(1:10),dirprt(1:10) ENDIF #ifdef W3_TRKNC - IF(outputType.EQ.3.OR.outputType.EQ.4) THEN - lonprt_nc(ip)=lonprt - latprt_nc(ip)=latprt - do igrp=1,10 - hsprt_nc(igrp,ip,it)=hsprt(igrp) - tpprt_nc(igrp,ip,it)=tpprt(igrp) - dirprt_nc(igrp,ip,it)=dirprt(igrp) - enddo - ENDIF + IF(outputType.EQ.3.OR.outputType.EQ.4) THEN + lonprt_nc(ip)=lonprt + latprt_nc(ip)=latprt + do igrp=1,10 + hsprt_nc(igrp,ip,it)=hsprt(igrp) + tpprt_nc(igrp,ip,it)=tpprt(igrp) + dirprt_nc(igrp,ip,it)=dirprt(igrp) + enddo + ENDIF #endif - END DO END DO + END DO #ifdef W3_TRKNC - IF(outputType.EQ.3.OR.outputType.EQ.4) THEN + IF(outputType.EQ.3.OR.outputType.EQ.4) THEN call pt2netcdf(lonprt_nc,latprt_nc,hsprt_nc,tpprt_nc, & - dirprt_nc,noutp,date1,date2,dt,NTIME_NC,outputType) - ENDIF + dirprt_nc,noutp,date1,date2,dt,NTIME_NC,outputType) + ENDIF #endif - IF(outputType.EQ.1) CLOSE(26) + IF(outputType.EQ.1) CLOSE(26) -!-----Final SYSTEM output: point output (Nearest neighbor, as a double check) - IF (testout) THEN + !-----Final SYSTEM output: point output (Nearest neighbor, as a double check) + IF (testout) THEN OPEN(unit=28,file='sys_pnt_nn.ww3',status='unknown') WRITE(28,'(A)') '%' WRITE(28,'(A)') '%' @@ -955,7 +955,7 @@ PROGRAM WW3_SYSTRK 'TpSY09 TpSY10 ', & 'DrSY01 DrSY02 DrSY03 DrSY04 ', & 'DrSY05 DrSY06 DrSY07 DrSY08 ', & - 'DrSY09 DrSY10' + 'DrSY09 DrSY10' WRITE(28,'(10A)') '% [degr] [degr] ', & '[m] [m] [m] [m] ', & '[m] [m] [m] [m] ', & @@ -969,507 +969,506 @@ PROGRAM WW3_SYSTRK WRITE(28,'(A)') '%' DO it = 1,SIZE(sysA) - WRITE(28,'(A,F15.6)') 'Time : ',wsdat(it)%date - - DO ip = 1,noutp - hsprt(1:10) = 999.9999 - tpprt(1:10) = 999.9999 - dirprt(1:10) = 999.9999 - lonprt = 999.9999 - latprt = 999.9999 - - DO j = 1, maxJ - DO i = 1, maxI -! Write nearest nearbor output (no bilinear interpolation) - IF ( (lonout(ip).GE. & - (wsdat(1)%lon(i,j)-dlon/2)).AND. & - (lonout(ip).LT. & - (wsdat(1)%lon(i,j)+dlon/2)).AND. & - (latout(ip).GE. & - (wsdat(1)%lat(i,j)-dlat/2)).AND. & - (latout(ip).LT. & - (wsdat(1)%lat(i,j)+dlat/2)) ) & - THEN - lonprt = wsdat(1)%lon(i,j) - latprt = wsdat(1)%lat(i,j) - END IF - END DO + WRITE(28,'(A,F15.6)') 'Time : ',wsdat(it)%date + + DO ip = 1,noutp + hsprt(1:10) = 999.9999 + tpprt(1:10) = 999.9999 + dirprt(1:10) = 999.9999 + lonprt = 999.9999 + latprt = 999.9999 + + DO j = 1, maxJ + DO i = 1, maxI + ! Write nearest nearbor output (no bilinear interpolation) + IF ( (lonout(ip).GE. & + (wsdat(1)%lon(i,j)-dlon/2)).AND. & + (lonout(ip).LT. & + (wsdat(1)%lon(i,j)+dlon/2)).AND. & + (latout(ip).GE. & + (wsdat(1)%lat(i,j)-dlat/2)).AND. & + (latout(ip).LT. & + (wsdat(1)%lat(i,j)+dlat/2)) ) & + THEN + lonprt = wsdat(1)%lon(i,j) + latprt = wsdat(1)%lat(i,j) + END IF END DO -! Loop through identified groups, limiting the output in file to 10 - DO igrp = 1,MIN(10,maxGroup) -! Find system with this group tag - sysmatch = 1 - DO WHILE (sysmatch.LE.maxSys(it)) - IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT - sysmatch = sysmatch+1 - END DO - IF (sysmatch.LE.maxSys(it)) THEN -! Match found: fill the output matrix with this data - leng = sysA(it)%sys(sysmatch)%nPoints - DO ind = 1, leng -! Write nearest nearbor output (no bilinear interpolation) - IF ( (lonout(ip).GE. & - (sysA(it)%sys(sysmatch)%lon(ind)-dlon/2)).AND. & - (lonout(ip).LT. & - (sysA(it)%sys(sysmatch)%lon(ind)+dlon/2)).AND. & - (latout(ip).GE. & - (sysA(it)%sys(sysmatch)%lat(ind)-dlat/2)).AND. & - (latout(ip).LT. & - (sysA(it)%sys(sysmatch)%lat(ind)+dlat/2)) ) & - THEN - hsprt(igrp) = sysA(it)%sys(sysmatch)%hs(ind) - tpprt(igrp) = sysA(it)%sys(sysmatch)%tp(ind) - dirprt(igrp) = sysA(it)%sys(sysmatch)%dir(ind) - END IF - END DO - END IF + END DO + ! Loop through identified groups, limiting the output in file to 10 + DO igrp = 1,MIN(10,maxGroup) + ! Find system with this group tag + sysmatch = 1 + DO WHILE (sysmatch.LE.maxSys(it)) + IF (sysA(it)%sys(sysmatch)%grp.EQ.igrp) EXIT + sysmatch = sysmatch+1 END DO - WRITE(28,'(32F14.4)') lonprt,latprt, & - hsprt(1:10),tpprt(1:10),dirprt(1:10) - END DO + IF (sysmatch.LE.maxSys(it)) THEN + ! Match found: fill the output matrix with this data + leng = sysA(it)%sys(sysmatch)%nPoints + DO ind = 1, leng + ! Write nearest nearbor output (no bilinear interpolation) + IF ( (lonout(ip).GE. & + (sysA(it)%sys(sysmatch)%lon(ind)-dlon/2)).AND. & + (lonout(ip).LT. & + (sysA(it)%sys(sysmatch)%lon(ind)+dlon/2)).AND. & + (latout(ip).GE. & + (sysA(it)%sys(sysmatch)%lat(ind)-dlat/2)).AND. & + (latout(ip).LT. & + (sysA(it)%sys(sysmatch)%lat(ind)+dlat/2)) ) & + THEN + hsprt(igrp) = sysA(it)%sys(sysmatch)%hs(ind) + tpprt(igrp) = sysA(it)%sys(sysmatch)%tp(ind) + dirprt(igrp) = sysA(it)%sys(sysmatch)%dir(ind) + END IF + END DO + END IF + END DO + WRITE(28,'(32F14.4)') lonprt,latprt, & + hsprt(1:10),tpprt(1:10),dirprt(1:10) + END DO END DO CLOSE(28) - END IF - -!------------------------------------------------------------------------- - - WRITE(20,*) 'In ww3_systrk: Deallocating wsdat ...' - DO it=1,size(wsdat) - IF (ASSOCIATED(wsdat(it)%lat)) DEALLOCATE(wsdat(it)%lat) - IF (ASSOCIATED(wsdat(it)%lon)) DEALLOCATE(wsdat(it)%lon) - IF (ASSOCIATED(wsdat(it)%par)) DEALLOCATE(wsdat(it)%par) - IF (ASSOCIATED(wsdat(it)%wnd)) DEALLOCATE(wsdat(it)%wnd) + END IF + + !------------------------------------------------------------------------- + + WRITE(20,*) 'In ww3_systrk: Deallocating wsdat ...' + DO it=1,size(wsdat) + IF (ASSOCIATED(wsdat(it)%lat)) DEALLOCATE(wsdat(it)%lat) + IF (ASSOCIATED(wsdat(it)%lon)) DEALLOCATE(wsdat(it)%lon) + IF (ASSOCIATED(wsdat(it)%par)) DEALLOCATE(wsdat(it)%par) + IF (ASSOCIATED(wsdat(it)%wnd)) DEALLOCATE(wsdat(it)%wnd) + END DO + IF (ASSOCIATED(wsdat)) DEALLOCATE(wsdat) + WRITE(20,*) ' Deallocating sysA ...' + DO i=1,size(sysA) + DO j=1,size(sysA(i)%sys) + IF (ASSOCIATED(sysA(i)%sys(j)%i)) DEALLOCATE(sysA(i)%sys(j)%i) + IF (ASSOCIATED(sysA(i)%sys(j)%j)) DEALLOCATE(sysA(i)%sys(j)%j) + IF (ASSOCIATED(sysA(i)%sys(j)%lon)) & + DEALLOCATE(sysA(i)%sys(j)%lon) + IF (ASSOCIATED(sysA(i)%sys(j)%lat)) & + DEALLOCATE(sysA(i)%sys(j)%lat) + IF (ASSOCIATED(sysA(i)%sys(j)%hs)) & + DEALLOCATE(sysA(i)%sys(j)%hs) + IF (ASSOCIATED(sysA(i)%sys(j)%tp)) & + DEALLOCATE(sysA(i)%sys(j)%tp) + IF (ASSOCIATED(sysA(i)%sys(j)%dir)) & + DEALLOCATE(sysA(i)%sys(j)%dir) + IF (ASSOCIATED(sysA(i)%sys(j)%dspr)) & + DEALLOCATE(sysA(i)%sys(j)%dspr) END DO - IF (ASSOCIATED(wsdat)) DEALLOCATE(wsdat) - WRITE(20,*) ' Deallocating sysA ...' - DO i=1,size(sysA) - DO j=1,size(sysA(i)%sys) - IF (ASSOCIATED(sysA(i)%sys(j)%i)) DEALLOCATE(sysA(i)%sys(j)%i) - IF (ASSOCIATED(sysA(i)%sys(j)%j)) DEALLOCATE(sysA(i)%sys(j)%j) - IF (ASSOCIATED(sysA(i)%sys(j)%lon)) & - DEALLOCATE(sysA(i)%sys(j)%lon) - IF (ASSOCIATED(sysA(i)%sys(j)%lat)) & - DEALLOCATE(sysA(i)%sys(j)%lat) - IF (ASSOCIATED(sysA(i)%sys(j)%hs)) & - DEALLOCATE(sysA(i)%sys(j)%hs) - IF (ASSOCIATED(sysA(i)%sys(j)%tp)) & - DEALLOCATE(sysA(i)%sys(j)%tp) - IF (ASSOCIATED(sysA(i)%sys(j)%dir)) & - DEALLOCATE(sysA(i)%sys(j)%dir) - IF (ASSOCIATED(sysA(i)%sys(j)%dspr)) & - DEALLOCATE(sysA(i)%sys(j)%dspr) - END DO - END DO - IF (ASSOCIATED(sysA)) DEALLOCATE(sysA) - WRITE(20,*) ' Deallocating maxSys ...' - IF (ASSOCIATED(maxSys)) DEALLOCATE(maxSys) - CLOSE(20) + END DO + IF (ASSOCIATED(sysA)) DEALLOCATE(sysA) + WRITE(20,*) ' Deallocating maxSys ...' + IF (ASSOCIATED(maxSys)) DEALLOCATE(maxSys) + CLOSE(20) - WRITE(6,*) '... ww3_systrk completed successfully.' + WRITE(6,*) '... ww3_systrk completed successfully.' - WRITE(6,999) + WRITE(6,999) #ifdef W3_MPI - END IF !/IF (rank.EQ.0) + END IF !/IF (rank.EQ.0) #endif #ifdef W3_MPI - CALL MPI_FINALIZE(IERR) -! End of parallel region + CALL MPI_FINALIZE(IERR) + ! End of parallel region #endif - 998 FORMAT ( ' ... finished. Elapsed time : ',F10.2,' s') - 993 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK : '/ & - ' OutputType=3 needs TRKNC switch ') - 994 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK : '/ & - ' OutputType=4 needs TRKNC switch ') - 995 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK : '/ & - ' OutputType,',I3,'not valid. Options: 1,3,4') +998 FORMAT ( ' ... finished. Elapsed time : ',F10.2,' s') +993 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK : '/ & + ' OutputType=3 needs TRKNC switch ') +994 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK : '/ & + ' OutputType=4 needs TRKNC switch ') +995 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK : '/ & + ' OutputType,',I3,'not valid. Options: 1,3,4') - 999 FORMAT (/15X,'End of program '/ & - 15X,'==============================================='/ & - 15X,' *** WAVEWATCH III Wave system tracking *** ') +999 FORMAT (/15X,'End of program '/ & + 15X,'==============================================='/ & + 15X,' *** WAVEWATCH III Wave system tracking *** ') - 2000 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' ERROR IN OPENING INPUT FILE') - 2200 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & - ' ERROR IN OPENING PARTITION FILE : ',A) +2000 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' ERROR IN OPENING INPUT FILE') +2200 FORMAT (/' *** WAVEWATCH III ERROR IN W3SYSTRK : '/ & + ' ERROR IN OPENING PARTITION FILE : ',A) - END PROGRAM WW3_SYSTRK +END PROGRAM WW3_SYSTRK ! #ifdef W3_TRKNC - subroutine t2netcdf(lons,lats,data_in,nlons,nlats,nsys,date1,date2,& - dt,ntime,ivar, outputType) - USE W3TIMEMD - use netcdf - implicit none - character (len = 15) :: file_name - integer, parameter :: ndims = 4 - integer, parameter :: deflate = 1 - integer :: outputType, ncid, oldMode - integer :: nlons,nlats,nsys,rec,ntime,ivar - double precision :: date1,date2,timenc - real :: data_in(nlons, nlats, nsys,ntime) - real :: lats(nlats), lons(nlons),dt - double precision :: times(ntime) - integer :: iyc,imc,idc,ihc,iminc,isc,Jday,Jday0 - integer :: iret +subroutine t2netcdf(lons,lats,data_in,nlons,nlats,nsys,date1,date2,& + dt,ntime,ivar, outputType) + USE W3TIMEMD + use netcdf + implicit none + character (len = 15) :: file_name + integer, parameter :: ndims = 4 + integer, parameter :: deflate = 1 + integer :: outputType, ncid, oldMode + integer :: nlons,nlats,nsys,rec,ntime,ivar + double precision :: date1,date2,timenc + real :: data_in(nlons, nlats, nsys,ntime) + real :: lats(nlats), lons(nlons),dt + double precision :: times(ntime) + integer :: iyc,imc,idc,ihc,iminc,isc,Jday,Jday0 + integer :: iret #endif -! + ! #ifdef W3_TRKNC - integer :: lon_varid, lat_varid, rec_varid - character (len = *), parameter :: lsys_name = "system_index" - character (len = *), parameter :: lat_name = "latitude" - character (len = *), parameter :: lon_name = "longitude" - character (len = *), parameter :: time_name = "time" - integer :: sys_dimid, lon_dimid, lat_dimid, rec_dimid - integer :: start(ndims), count(ndims) + integer :: lon_varid, lat_varid, rec_varid + character (len = *), parameter :: lsys_name = "system_index" + character (len = *), parameter :: lat_name = "latitude" + character (len = *), parameter :: lon_name = "longitude" + character (len = *), parameter :: time_name = "time" + integer :: sys_dimid, lon_dimid, lat_dimid, rec_dimid + integer :: start(ndims), count(ndims) #endif -! + ! #ifdef W3_TRKNC - character (len = *), parameter :: var1_name="hs" - character (len = *), parameter :: var2_name="tp" - character (len = *), parameter :: var3_name="dir" - character (len = *), parameter :: var4_name="dspr" - integer :: var1_varid, var2_varid, var3_varid,var4_varid - integer :: dimids(ndims) + character (len = *), parameter :: var1_name="hs" + character (len = *), parameter :: var2_name="tp" + character (len = *), parameter :: var3_name="dir" + character (len = *), parameter :: var4_name="dspr" + integer :: var1_varid, var2_varid, var3_varid,var4_varid + integer :: dimids(ndims) #endif -! + ! #ifdef W3_TRKNC - character (len = *), parameter :: units = "units" - character (len = *), parameter :: var1_units = "m" - character (len = *), parameter :: var2_units = "s" - character (len = *), parameter :: var3_units = "degrees" - character (len = *), parameter :: var4_units = "degrees" - character (len = *), parameter :: lat_units = "degrees_north" - character (len = *), parameter :: lon_units = "degrees_east" - iyc=date1/10000 - imc=(date1-iyc*10000)/100 - idc=int(date1-DBLE(iyc*10000)-DBLE(imc*100)) - ihc=date2/10000 - iminc=(date2-ihc*10000)/100 - isc=date2-ihc*10000-100*iminc - timenc=DBLE(julday(idc,imc,iyc))+(DBLE(ihc)+(DBLE(iminc)+ & - (DBLE(isc)/60.0D0))/60.0D0)/24.0D0 - Jday0=julday(1,1,1990) - timenc=timenc-Jday0 - do rec=1,ntime - times(rec)=timenc+DBLE( (rec-1)*dt)/3600.0D0/24.0D0 - enddo - if( ivar == 1) then - file_name = "sys_hs.ww3.nc" - else if( ivar == 2) then - file_name = "sys_tp.ww3.nc" - else if( ivar == 3) then - file_name = "sys_dir.ww3.nc" - else - file_name = "sys_dspr.ww3.nc" - endif + character (len = *), parameter :: units = "units" + character (len = *), parameter :: var1_units = "m" + character (len = *), parameter :: var2_units = "s" + character (len = *), parameter :: var3_units = "degrees" + character (len = *), parameter :: var4_units = "degrees" + character (len = *), parameter :: lat_units = "degrees_north" + character (len = *), parameter :: lon_units = "degrees_east" + iyc=date1/10000 + imc=(date1-iyc*10000)/100 + idc=int(date1-DBLE(iyc*10000)-DBLE(imc*100)) + ihc=date2/10000 + iminc=(date2-ihc*10000)/100 + isc=date2-ihc*10000-100*iminc + timenc=DBLE(julday(idc,imc,iyc))+(DBLE(ihc)+(DBLE(iminc)+ & + (DBLE(isc)/60.0D0))/60.0D0)/24.0D0 + Jday0=julday(1,1,1990) + timenc=timenc-Jday0 + do rec=1,ntime + times(rec)=timenc+DBLE( (rec-1)*dt)/3600.0D0/24.0D0 + enddo + if( ivar == 1) then + file_name = "sys_hs.ww3.nc" + else if( ivar == 2) then + file_name = "sys_tp.ww3.nc" + else if( ivar == 3) then + file_name = "sys_dir.ww3.nc" + else + file_name = "sys_dspr.ww3.nc" + endif #endif -! + ! #ifdef W3_TRKNC -! create the netcdf file. - if (outputType.EQ.3) then - call check( nf90_create(file_name, NF90_CLOBBER, ncid) ) - endif - if(outputType.EQ.4) call check( nf90_create(file_name,NF90_NETCDF4,ncid)) - call check ( nf90_set_fill(ncid,nf90_nofill,oldMode) ) - call check( nf90_def_dim(ncid, lsys_name, nsys, sys_dimid) ) - call check( nf90_def_dim(ncid, lat_name, nlats, lat_dimid) ) - call check( nf90_def_dim(ncid, lon_name, nlons, lon_dimid) ) - call check( nf90_def_dim(ncid, time_name, ntime, rec_dimid) ) - call check( nf90_def_var(ncid, lat_name, NF90_REAL, lat_dimid,lat_varid)) - if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,lat_varid,1,1,deflate) ) - call check( nf90_def_var(ncid, lon_name, NF90_REAL, lon_dimid,lon_varid)) - if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,lon_varid,1,1,deflate) ) - call check( nf90_def_var(ncid,time_name,NF90_DOUBLE,rec_dimid,rec_varid)) - if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,rec_varid,1,1,deflate) ) + ! create the netcdf file. + if (outputType.EQ.3) then + call check( nf90_create(file_name, NF90_CLOBBER, ncid) ) + endif + if(outputType.EQ.4) call check( nf90_create(file_name,NF90_NETCDF4,ncid)) + call check ( nf90_set_fill(ncid,nf90_nofill,oldMode) ) + call check( nf90_def_dim(ncid, lsys_name, nsys, sys_dimid) ) + call check( nf90_def_dim(ncid, lat_name, nlats, lat_dimid) ) + call check( nf90_def_dim(ncid, lon_name, nlons, lon_dimid) ) + call check( nf90_def_dim(ncid, time_name, ntime, rec_dimid) ) + call check( nf90_def_var(ncid, lat_name, NF90_REAL, lat_dimid,lat_varid)) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,lat_varid,1,1,deflate) ) + call check( nf90_def_var(ncid, lon_name, NF90_REAL, lon_dimid,lon_varid)) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,lon_varid,1,1,deflate) ) + call check( nf90_def_var(ncid,time_name,NF90_DOUBLE,rec_dimid,rec_varid)) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,rec_varid,1,1,deflate) ) #endif -! + ! #ifdef W3_TRKNC - call check( nf90_put_att(ncid, lat_varid, units, lat_units) ) - call check( nf90_put_att(ncid, lat_varid, 'long_name', 'latitude') ) - call check( nf90_put_att(ncid, lat_varid, 'standard_name', 'latitude') ) - call check( nf90_put_att(ncid, lat_varid, 'axis','Y')) - call check( nf90_put_att(ncid, lon_varid, units, lon_units) ) - call check( nf90_put_att(ncid, lon_varid, 'long_name', 'longitude') ) - call check( nf90_put_att(ncid, lon_varid, 'standard_name', 'longitude') ) - call check( nf90_put_att(ncid, lon_varid, 'axis','X')) - call check(nf90_put_att(ncid,rec_varid,units,& - 'days since 1990-01-01 00:00:00')) - call check(nf90_put_att(ncid,rec_varid,'long_name','julian day (UT)')) - call check( nf90_put_att(ncid, rec_varid,'standard_name', 'time') ) - call check( nf90_put_att(ncid, rec_varid, 'conventions',& - 'relative julian day with decimal part (as part of the day)' ) ) - call check( nf90_put_att(ncid, rec_varid, 'axis','T')) + call check( nf90_put_att(ncid, lat_varid, units, lat_units) ) + call check( nf90_put_att(ncid, lat_varid, 'long_name', 'latitude') ) + call check( nf90_put_att(ncid, lat_varid, 'standard_name', 'latitude') ) + call check( nf90_put_att(ncid, lat_varid, 'axis','Y')) + call check( nf90_put_att(ncid, lon_varid, units, lon_units) ) + call check( nf90_put_att(ncid, lon_varid, 'long_name', 'longitude') ) + call check( nf90_put_att(ncid, lon_varid, 'standard_name', 'longitude') ) + call check( nf90_put_att(ncid, lon_varid, 'axis','X')) + call check(nf90_put_att(ncid,rec_varid,units,& + 'days since 1990-01-01 00:00:00')) + call check(nf90_put_att(ncid,rec_varid,'long_name','julian day (UT)')) + call check( nf90_put_att(ncid, rec_varid,'standard_name', 'time') ) + call check( nf90_put_att(ncid, rec_varid, 'conventions',& + 'relative julian day with decimal part (as part of the day)' ) ) + call check( nf90_put_att(ncid, rec_varid, 'axis','T')) #endif -! + ! #ifdef W3_TRKNC - dimids = (/ lon_dimid, lat_dimid, sys_dimid, rec_dimid /) - if( ivar == 1) then - call check( nf90_def_var(ncid, var1_name, NF90_REAL, dimids,var1_varid) ) - if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var1_varid,1,1,deflate) ) - call check( nf90_put_att(ncid, var1_varid, units, var1_units) ) - call check( nf90_put_att(ncid, var1_varid,'long_name','significant_wave_height') ) - call check( nf90_put_att(ncid, var1_varid,'missing_value','9999.00')) - else if( ivar == 2) then - call check( nf90_def_var(ncid, var2_name, NF90_REAL, dimids, var2_varid) ) - if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var2_varid,1,1,deflate) ) - call check( nf90_put_att(ncid, var2_varid, units, var2_units) ) - call check( nf90_put_att(ncid, var2_varid,'long_name','peak_period') ) - call check( nf90_put_att(ncid, var2_varid,'missing_value','9999.00') ) - else if ( ivar ==3 ) then - call check( nf90_def_var(ncid, var3_name, NF90_REAL, dimids, var3_varid) ) - if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var3_varid,1,1,deflate) ) - call check( nf90_put_att(ncid, var3_varid, units, var3_units) ) - call check( nf90_put_att(ncid, var3_varid,'long_name','peak_direction') ) - call check( nf90_put_att(ncid, var3_varid,'missing_value','9999.00') ) - else - call check( nf90_def_var(ncid, var4_name, NF90_REAL, dimids, var4_varid) ) - if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var4_varid,1,1,deflate) ) - call check( nf90_put_att(ncid, var4_varid, units, var4_units) ) - call check( nf90_put_att(ncid,var4_varid,'long_name','directional_spread') ) - call check( nf90_put_att(ncid, var4_varid,'missing_value','9999.00') ) - endif - call check( nf90_enddef(ncid) ) + dimids = (/ lon_dimid, lat_dimid, sys_dimid, rec_dimid /) + if( ivar == 1) then + call check( nf90_def_var(ncid, var1_name, NF90_REAL, dimids,var1_varid) ) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var1_varid,1,1,deflate) ) + call check( nf90_put_att(ncid, var1_varid, units, var1_units) ) + call check( nf90_put_att(ncid, var1_varid,'long_name','significant_wave_height') ) + call check( nf90_put_att(ncid, var1_varid,'missing_value','9999.00')) + else if( ivar == 2) then + call check( nf90_def_var(ncid, var2_name, NF90_REAL, dimids, var2_varid) ) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var2_varid,1,1,deflate) ) + call check( nf90_put_att(ncid, var2_varid, units, var2_units) ) + call check( nf90_put_att(ncid, var2_varid,'long_name','peak_period') ) + call check( nf90_put_att(ncid, var2_varid,'missing_value','9999.00') ) + else if ( ivar ==3 ) then + call check( nf90_def_var(ncid, var3_name, NF90_REAL, dimids, var3_varid) ) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var3_varid,1,1,deflate) ) + call check( nf90_put_att(ncid, var3_varid, units, var3_units) ) + call check( nf90_put_att(ncid, var3_varid,'long_name','peak_direction') ) + call check( nf90_put_att(ncid, var3_varid,'missing_value','9999.00') ) + else + call check( nf90_def_var(ncid, var4_name, NF90_REAL, dimids, var4_varid) ) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var4_varid,1,1,deflate) ) + call check( nf90_put_att(ncid, var4_varid, units, var4_units) ) + call check( nf90_put_att(ncid,var4_varid,'long_name','directional_spread') ) + call check( nf90_put_att(ncid, var4_varid,'missing_value','9999.00') ) + endif + call check( nf90_enddef(ncid) ) #endif -! + ! #ifdef W3_TRKNC - call check( nf90_put_var(ncid, lat_varid, lats) ) - call check( nf90_put_var(ncid, lon_varid, lons) ) - call check( nf90_put_var(ncid, rec_varid, times) ) + call check( nf90_put_var(ncid, lat_varid, lats) ) + call check( nf90_put_var(ncid, lon_varid, lons) ) + call check( nf90_put_var(ncid, rec_varid, times) ) #endif -! + ! #ifdef W3_TRKNC - count = (/ nlons, nlats, nsys, ntime /) - start = (/ 1, 1, 1, 1 /) - if( ivar == 1) then - call check( nf90_put_var(ncid, var1_varid, data_in, start = start, & - count = count) ) - else if( ivar == 2) then - call check( nf90_put_var(ncid, var2_varid, data_in, start = start, & - count = count) ) - else if( ivar == 3) then - call check( nf90_put_var(ncid, var3_varid, data_in, start = start, & - count = count) ) - else - call check( nf90_put_var(ncid, var4_varid, data_in, start = start, & - count = count) ) - endif - call check( nf90_close(ncid) ) - end subroutine t2netcdf + count = (/ nlons, nlats, nsys, ntime /) + start = (/ 1, 1, 1, 1 /) + if( ivar == 1) then + call check( nf90_put_var(ncid, var1_varid, data_in, start = start, & + count = count) ) + else if( ivar == 2) then + call check( nf90_put_var(ncid, var2_varid, data_in, start = start, & + count = count) ) + else if( ivar == 3) then + call check( nf90_put_var(ncid, var3_varid, data_in, start = start, & + count = count) ) + else + call check( nf90_put_var(ncid, var4_varid, data_in, start = start, & + count = count) ) + endif + call check( nf90_close(ncid) ) +end subroutine t2netcdf #endif ! #ifdef W3_TRKNC - subroutine check(status) - use netcdf - integer, intent ( in) :: status - if(status /= nf90_noerr) then - write(6,996) - 996 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK:'/ & - 'netCDF error:') - print *, trim(nf90_strerror(status)) - stop "Stopped in netcdf output part" - endif - end subroutine check +subroutine check(status) + use netcdf + integer, intent ( in) :: status + if(status /= nf90_noerr) then + write(6,996) +996 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK:'/ & + 'netCDF error:') + print *, trim(nf90_strerror(status)) + stop "Stopped in netcdf output part" + endif +end subroutine check #endif ! #ifdef W3_TRKNC - subroutine pt2netcdf(longitude,latitude,hs,tp,& - dir,npoints,date1,date2,dt,ntime,outputType) - USE W3TIMEMD - use netcdf - implicit none - integer :: ntime,npoints,outputType - integer, parameter :: deflate = 1 - integer :: iret, oldMode - integer :: ncid - integer :: system_index_dim - integer :: point_dim,rec_dim - integer :: nsys - integer :: start(3), count(3) - parameter (nsys = 10) - integer :: latitude_id - integer :: longitude_id - integer :: time_id - integer :: hs_id - integer :: tp_id - integer :: dir_id - integer :: time_rank - integer :: hs_rank - integer :: tp_rank - integer :: dir_rank - parameter (time_rank = 1) - parameter (hs_rank = 3) - parameter (tp_rank = 3) - parameter (dir_rank = 3) +subroutine pt2netcdf(longitude,latitude,hs,tp,& + dir,npoints,date1,date2,dt,ntime,outputType) + USE W3TIMEMD + use netcdf + implicit none + integer :: ntime,npoints,outputType + integer, parameter :: deflate = 1 + integer :: iret, oldMode + integer :: ncid + integer :: system_index_dim + integer :: point_dim,rec_dim + integer :: nsys + integer :: start(3), count(3) + parameter (nsys = 10) + integer :: latitude_id + integer :: longitude_id + integer :: time_id + integer :: hs_id + integer :: tp_id + integer :: dir_id + integer :: time_rank + integer :: hs_rank + integer :: tp_rank + integer :: dir_rank + parameter (time_rank = 1) + parameter (hs_rank = 3) + parameter (tp_rank = 3) + parameter (dir_rank = 3) #endif -! + ! #ifdef W3_TRKNC - integer :: hs_dims(hs_rank) - integer :: tp_dims(tp_rank) - integer :: dir_dims(dir_rank) - real :: latitude(npoints),dt - real :: longitude(npoints) - real :: hs(nsys, npoints, ntime) - real :: tp(nsys, npoints, ntime) - real :: dir(nsys, npoints, ntime) - integer :: iyc,imc,idc,ihc,iminc,isc,Jday,Jday0,rec - double precision date1,date2,timenc - double precision times(ntime) + integer :: hs_dims(hs_rank) + integer :: tp_dims(tp_rank) + integer :: dir_dims(dir_rank) + real :: latitude(npoints),dt + real :: longitude(npoints) + real :: hs(nsys, npoints, ntime) + real :: tp(nsys, npoints, ntime) + real :: dir(nsys, npoints, ntime) + integer :: iyc,imc,idc,ihc,iminc,isc,Jday,Jday0,rec + double precision date1,date2,timenc + double precision times(ntime) #endif -! + ! #ifdef W3_TRKNC - iyc=date1/10000 - imc=(date1-iyc*10000)/100 - idc=int(date1-DBLE(iyc*10000)-DBLE(imc*100)) - ihc=date2/10000 - iminc=(date2-ihc*10000)/100 - isc=date2-ihc*10000-100*iminc - timenc=DBLE(julday(idc,imc,iyc))+(DBLE(ihc)+(DBLE(iminc)+ & + iyc=date1/10000 + imc=(date1-iyc*10000)/100 + idc=int(date1-DBLE(iyc*10000)-DBLE(imc*100)) + ihc=date2/10000 + iminc=(date2-ihc*10000)/100 + isc=date2-ihc*10000-100*iminc + timenc=DBLE(julday(idc,imc,iyc))+(DBLE(ihc)+(DBLE(iminc)+ & (DBLE(isc)/60.0D0))/60.0D0)/24.0D0 - Jday0=julday(1,1,1990) - timenc=timenc-Jday0 - do rec=1,ntime - times(rec)=timenc+DBLE( (rec-1)*dt)/3600.0D0/24.0D0 - enddo + Jday0=julday(1,1,1990) + timenc=timenc-Jday0 + do rec=1,ntime + times(rec)=timenc+DBLE( (rec-1)*dt)/3600.0D0/24.0D0 + enddo #endif -! + ! #ifdef W3_TRKNC - if(outputType.EQ.3) then - iret = nf90_create('sys_pnt.ww3.nc', NF90_CLOBBER, ncid) - endif - if (outputType.EQ.4) iret = nf90_create('sys_pnt.ww3.nc',NF90_NETCDF4, ncid) - call check(iret) - iret = nf90_set_fill(ncid,nf90_nofill,oldMode) - call check(iret) -! define dimensions - iret = nf90_def_dim(ncid, 'system_index', nsys, system_index_dim) - call check(iret) - iret = nf90_def_dim(ncid, 'point', npoints, point_dim) - call check(iret) - iret = nf90_def_dim(ncid, 'time', ntime, rec_dim) - call check(iret) -! define variables - iret = nf90_def_var(ncid, 'latitude', NF90_REAL, point_dim, & - latitude_id) - call check(iret) - if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,latitude_id,1,1,deflate)) - iret = nf90_def_var(ncid, 'longitude', NF90_REAL, point_dim, & - longitude_id) - call check(iret) - if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,longitude_id,1,1,deflate)) - iret = nf90_def_var(ncid, 'time', NF90_DOUBLE, rec_dim, & - time_id) - call check(iret) - if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,time_id,1,1,deflate) ) - hs_dims(3) = rec_dim - hs_dims(2) = point_dim - hs_dims(1) = system_index_dim - iret = nf90_def_var(ncid, 'hs', NF90_REAL, & - hs_dims, hs_id) - call check(iret) - if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,hs_id,1,1,deflate)) - tp_dims(3) = rec_dim - tp_dims(2) = point_dim - tp_dims(1) = system_index_dim - iret = nf90_def_var(ncid, 'tp', NF90_REAL, & - tp_dims, tp_id) - call check(iret) - if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,tp_id,1,1,deflate)) - dir_dims(3) = rec_dim - dir_dims(2) = point_dim - dir_dims(1) = system_index_dim - iret = nf90_def_var(ncid, 'dir', NF90_REAL, & - dir_dims, dir_id) - call check(iret) - if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,dir_id,1,1,deflate)) -! assign attributes - iret = nf90_put_att(ncid, latitude_id, 'units', 'degrees_north') - call check(iret) - iret = nf90_put_att(ncid, latitude_id, 'long_name', 'latitude') - call check(iret) - iret = nf90_put_att(ncid, latitude_id, 'standard_name', 'latitude') - call check(iret) - iret = nf90_put_att(ncid, latitude_id, 'axis', 'Y') - call check(iret) - iret = nf90_put_att(ncid, longitude_id, 'units', 'degrees_east') - call check(iret) - iret = nf90_put_att(ncid, longitude_id,'long_name','longitude') - call check(iret) - iret = nf90_put_att(ncid, longitude_id,'standard_name','longitude') - call check(iret) - iret = nf90_put_att(ncid, longitude_id, 'axis', 'X') - call check(iret) - iret = nf90_put_att(ncid, time_id, 'units', & - 'days since 1990-01-01 00:00:00') - call check(iret) - iret = nf90_put_att(ncid, time_id, 'long_name','julian day(UT)') - call check(iret) - iret = nf90_put_att(ncid, time_id, 'standard_name','time') - call check(iret) - iret = nf90_put_att(ncid, time_id, 'conventions', & + if(outputType.EQ.3) then + iret = nf90_create('sys_pnt.ww3.nc', NF90_CLOBBER, ncid) + endif + if (outputType.EQ.4) iret = nf90_create('sys_pnt.ww3.nc',NF90_NETCDF4, ncid) + call check(iret) + iret = nf90_set_fill(ncid,nf90_nofill,oldMode) + call check(iret) + ! define dimensions + iret = nf90_def_dim(ncid, 'system_index', nsys, system_index_dim) + call check(iret) + iret = nf90_def_dim(ncid, 'point', npoints, point_dim) + call check(iret) + iret = nf90_def_dim(ncid, 'time', ntime, rec_dim) + call check(iret) + ! define variables + iret = nf90_def_var(ncid, 'latitude', NF90_REAL, point_dim, & + latitude_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,latitude_id,1,1,deflate)) + iret = nf90_def_var(ncid, 'longitude', NF90_REAL, point_dim, & + longitude_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,longitude_id,1,1,deflate)) + iret = nf90_def_var(ncid, 'time', NF90_DOUBLE, rec_dim, & + time_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,time_id,1,1,deflate) ) + hs_dims(3) = rec_dim + hs_dims(2) = point_dim + hs_dims(1) = system_index_dim + iret = nf90_def_var(ncid, 'hs', NF90_REAL, & + hs_dims, hs_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,hs_id,1,1,deflate)) + tp_dims(3) = rec_dim + tp_dims(2) = point_dim + tp_dims(1) = system_index_dim + iret = nf90_def_var(ncid, 'tp', NF90_REAL, & + tp_dims, tp_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,tp_id,1,1,deflate)) + dir_dims(3) = rec_dim + dir_dims(2) = point_dim + dir_dims(1) = system_index_dim + iret = nf90_def_var(ncid, 'dir', NF90_REAL, & + dir_dims, dir_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,dir_id,1,1,deflate)) + ! assign attributes + iret = nf90_put_att(ncid, latitude_id, 'units', 'degrees_north') + call check(iret) + iret = nf90_put_att(ncid, latitude_id, 'long_name', 'latitude') + call check(iret) + iret = nf90_put_att(ncid, latitude_id, 'standard_name', 'latitude') + call check(iret) + iret = nf90_put_att(ncid, latitude_id, 'axis', 'Y') + call check(iret) + iret = nf90_put_att(ncid, longitude_id, 'units', 'degrees_east') + call check(iret) + iret = nf90_put_att(ncid, longitude_id,'long_name','longitude') + call check(iret) + iret = nf90_put_att(ncid, longitude_id,'standard_name','longitude') + call check(iret) + iret = nf90_put_att(ncid, longitude_id, 'axis', 'X') + call check(iret) + iret = nf90_put_att(ncid, time_id, 'units', & + 'days since 1990-01-01 00:00:00') + call check(iret) + iret = nf90_put_att(ncid, time_id, 'long_name','julian day(UT)') + call check(iret) + iret = nf90_put_att(ncid, time_id, 'standard_name','time') + call check(iret) + iret = nf90_put_att(ncid, time_id, 'conventions', & 'relative julian day with decimal part (as part of the day)') - call check(iret) - iret = nf90_put_att(ncid, time_id, 'axis', 'T') - call check(iret) - iret = nf90_put_att(ncid, hs_id, 'units', 'm') - call check(iret) - iret = nf90_put_att(ncid, hs_id,'long_name','significant_wave_height') - call check(iret) - iret = nf90_put_att(ncid, hs_id, 'missing_value', & - '999.9999') - call check(iret) - iret = nf90_put_att(ncid, tp_id, 'units', 's') - call check(iret) - iret = nf90_put_att(ncid, tp_id,'long_name','peak_period') - call check(iret) - iret = nf90_put_att(ncid, tp_id, 'missing_value', & + call check(iret) + iret = nf90_put_att(ncid, time_id, 'axis', 'T') + call check(iret) + iret = nf90_put_att(ncid, hs_id, 'units', 'm') + call check(iret) + iret = nf90_put_att(ncid, hs_id,'long_name','significant_wave_height') + call check(iret) + iret = nf90_put_att(ncid, hs_id, 'missing_value', & + '999.9999') + call check(iret) + iret = nf90_put_att(ncid, tp_id, 'units', 's') + call check(iret) + iret = nf90_put_att(ncid, tp_id,'long_name','peak_period') + call check(iret) + iret = nf90_put_att(ncid, tp_id, 'missing_value', & '999.9999') - call check(iret) - iret = nf90_put_att(ncid, dir_id, 'units', 'degrees') - call check(iret) - iret = nf90_put_att(ncid, dir_id,'long_name','peak_direction') - call check(iret) - iret = nf90_put_att(ncid, dir_id, 'missing_value',& - '999.9999') - call check(iret) -! leave define mode - iret = nf90_enddef(ncid) - call check(iret) - iret = nf90_put_var(ncid, latitude_id, latitude) - call check(iret) + call check(iret) + iret = nf90_put_att(ncid, dir_id, 'units', 'degrees') + call check(iret) + iret = nf90_put_att(ncid, dir_id,'long_name','peak_direction') + call check(iret) + iret = nf90_put_att(ncid, dir_id, 'missing_value',& + '999.9999') + call check(iret) + ! leave define mode + iret = nf90_enddef(ncid) + call check(iret) + iret = nf90_put_var(ncid, latitude_id, latitude) + call check(iret) #endif -! + ! #ifdef W3_TRKNC - iret = nf90_put_var(ncid, longitude_id, longitude) - call check(iret) + iret = nf90_put_var(ncid, longitude_id, longitude) + call check(iret) #endif -! + ! #ifdef W3_TRKNC - iret = nf90_put_var(ncid, time_id, times) - call check(iret) + iret = nf90_put_var(ncid, time_id, times) + call check(iret) #endif -! + ! #ifdef W3_TRKNC - start = (/ 1, 1, 1 /) - count = (/ nsys,npoints,ntime /) + start = (/ 1, 1, 1 /) + count = (/ nsys,npoints,ntime /) #endif -! + ! #ifdef W3_TRKNC - iret = nf90_put_var(ncid, hs_id, hs,& + iret = nf90_put_var(ncid, hs_id, hs,& start = start, count = count ) - call check(iret) - iret = nf90_put_var(ncid, tp_id, tp, & + call check(iret) + iret = nf90_put_var(ncid, tp_id, tp, & start = start, count = count ) - call check(iret) - iret = nf90_put_var(ncid, dir_id, dir,& + call check(iret) + iret = nf90_put_var(ncid, dir_id, dir,& start = start, count = count ) - call check(iret) - iret = nf90_close(ncid) - call check(iret) - return - end subroutine pt2netcdf + call check(iret) + iret = nf90_close(ncid) + call check(iret) + return +end subroutine pt2netcdf #endif - diff --git a/model/src/ww3_trck.F90 b/model/src/ww3_trck.F90 index 33ef4b75a..ab125f840 100644 --- a/model/src/ww3_trck.F90 +++ b/model/src/ww3_trck.F90 @@ -12,467 +12,467 @@ !> @details Info read from track_o.ww3, written to track.ww3. !> !> @author H. L. Tolman @date 05-Mar-2014 - PROGRAM W3TRCK -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 05-Mar-2014 | -!/ +-----------------------------------+ -!/ -!/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 25-Jan-2001 : Flat grid version ( version 2.06 ) -!/ 20-Aug-2003 : Sequential file version ( version 3.04 ) -!/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 05-Mar-2014 : Now calls W3SETG for pointer def. ( version 4.18 ) -!/ -!/ Copyright 2009 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Convert direct access track output file to free-format -! readable sequential file. -! -! 2. Method : -! -! Info read from track_o.ww3, written to track.ww3. -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY : W3NMOD, W3SETG, FLAGLL, XFR - USE W3ODATMD, ONLY : W3NOUT, W3SETO, FNMPRE - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE +PROGRAM W3TRCK + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 05-Mar-2014 | + !/ +-----------------------------------+ + !/ + !/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 25-Jan-2001 : Flat grid version ( version 2.06 ) + !/ 20-Aug-2003 : Sequential file version ( version 3.04 ) + !/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 05-Mar-2014 : Now calls W3SETG for pointer def. ( version 4.18 ) + !/ + !/ Copyright 2009 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Convert direct access track output file to free-format + ! readable sequential file. + ! + ! 2. Method : + ! + ! Info read from track_o.ww3, written to track.ww3. + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY : W3NMOD, W3SETG, FLAGLL, XFR + USE W3ODATMD, ONLY : W3NOUT, W3SETO, FNMPRE + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif - USE W3TIMEMD, ONLY : STME21 -! - USE W3ODATMD, ONLY: NDSO, NDSE, NDST - use constants, only: file_endian -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER*34, PARAMETER :: & - IDTST = 'WAVEWATCH III TRACK OUTPUT SPECTRA' -! - INTEGER :: NDSI, NDSINP, & - NDSOUT, NDSTRC, NTRACE, NK, NTH, & - NSPEC, IERR, MK, MTH, & - NREC, ILOC, ISPEC, TIME(2), TTST(2), & - ILAST, NZERO, IK, ITH, IWZERO, ICH, & - IWDTH, J + USE W3TIMEMD, ONLY : STME21 + ! + USE W3ODATMD, ONLY: NDSO, NDSE, NDST + use constants, only: file_endian + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER*34, PARAMETER :: & + IDTST = 'WAVEWATCH III TRACK OUTPUT SPECTRA' + ! + INTEGER :: NDSI, NDSINP, & + NDSOUT, NDSTRC, NTRACE, NK, NTH, & + NSPEC, IERR, MK, MTH, & + NREC, ILOC, ISPEC, TIME(2), TTST(2), & + ILAST, NZERO, IK, ITH, IWZERO, ICH, & + IWDTH, J #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif - INTEGER :: LINELN = 81 - REAL :: TH1, DTH, X, Y, DW, CX, CY, WX, WY, & - UST, AS, VALUE - REAL :: SCALE = 0.001 - REAL :: FACTOR - REAL, ALLOCATABLE :: SIG(:), DSIP(:), SPEC(:,:) - CHARACTER :: COMSTR*1, IDSTR*34, TSTSTR*3, & - STIME*23, STRING*81, EMPTY*81, & - PART*9, ZEROS*9, TRCKID*32 -! - DATA EMPTY(01:40) / ' ' / - DATA EMPTY(41:81) / ' ' / -!/ -!/ ------------------------------------------------------------------- / -!/ -! -! 1.a Initialize data structure -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! -! 1.b IO set-up. -! - NDSI = 10 - NDSINP = 11 - NDSOUT = 51 -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + INTEGER :: LINELN = 81 + REAL :: TH1, DTH, X, Y, DW, CX, CY, WX, WY, & + UST, AS, VALUE + REAL :: SCALE = 0.001 + REAL :: FACTOR + REAL, ALLOCATABLE :: SIG(:), DSIP(:), SPEC(:,:) + CHARACTER :: COMSTR*1, IDSTR*34, TSTSTR*3, & + STIME*23, STRING*81, EMPTY*81, & + PART*9, ZEROS*9, TRCKID*32 + ! + DATA EMPTY(01:40) / ' ' / + DATA EMPTY(41:81) / ' ' / + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + ! 1.a Initialize data structure + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + ! 1.b IO set-up. + ! + NDSI = 10 + NDSINP = 11 + NDSOUT = 51 + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_S - CALL STRACE ( IENT, 'W3TRCK' ) + CALL STRACE ( IENT, 'W3TRCK' ) #endif -! - WRITE (NDSO,900) -! - J = LEN_TRIM(FNMPRE) - OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_trck.inp',STATUS='OLD', & - ERR=805,IOSTAT=IERR) - READ (NDSI,'(A)',END=806,ERR=807) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=806,ERR=807) NK, NTH - NSPEC = NK * NTH - WRITE (NDSO,902) NK, NTH -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Open and test input data file -! - WRITE (NDSO,920) -! - OPEN (NDSINP,FILE=FNMPRE(:J)//'track_o.ww3',form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=800,IOSTAT=IERR) - READ (NDSINP,ERR=801,IOSTAT=IERR) IDSTR, FLAGLL, MK, MTH, XFR -! - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF -! - IF ( IDSTR .NE. IDTST ) GOTO 810 - IF ( NK.NE.MK .OR. NTH.NE.MTH ) GOTO 811 + ! + WRITE (NDSO,900) + ! + J = LEN_TRIM(FNMPRE) + OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_trck.inp',STATUS='OLD', & + ERR=805,IOSTAT=IERR) + READ (NDSI,'(A)',END=806,ERR=807) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + ! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=806,ERR=807) NK, NTH + NSPEC = NK * NTH + WRITE (NDSO,902) NK, NTH + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Open and test input data file + ! + WRITE (NDSO,920) + ! + OPEN (NDSINP,FILE=FNMPRE(:J)//'track_o.ww3',form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=800,IOSTAT=IERR) + READ (NDSINP,ERR=801,IOSTAT=IERR) IDSTR, FLAGLL, MK, MTH, XFR + ! + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + ! + IF ( IDSTR .NE. IDTST ) GOTO 810 + IF ( NK.NE.MK .OR. NTH.NE.MTH ) GOTO 811 - ALLOCATE ( SIG(MK), DSIP(MK), SPEC(MK,MTH) ) -! - READ (NDSINP,ERR=801,IOSTAT=IERR) TH1, DTH, SIG, DSIP -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Open output file and prepare -! - WRITE (NDSO,930) -! - OPEN (NDSOUT,FILE=FNMPRE(:J)//'track.ww3', & - FORM='FORMATTED',ERR=802,IOSTAT=IERR) -! - WRITE (NDSOUT,980,ERR=803,IOSTAT=IERR) IDSTR - WRITE (NDSOUT,981,ERR=803,IOSTAT=IERR) MK, MTH, TH1, DTH - WRITE (NDSOUT,982,ERR=803,IOSTAT=IERR) SIG - WRITE (NDSOUT,983,ERR=803,IOSTAT=IERR) DSIP -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Process data -! - ILOC = 0 - ISPEC = 0 - READ (NDSINP,END=444, ERR=801,IOSTAT=IERR) TTST - BACKSPACE (NDSINP) - WRITE (NDSO,940) -! - 400 CONTINUE -! -! 4.a Read/write basic data -! - READ (NDSINP,END=444, ERR=801,IOSTAT=IERR) TIME, X, Y, TSTSTR, & - TRCKID - IF ( FLAGLL ) THEN - WRITE (NDSOUT,984,ERR=803,IOSTAT=IERR) & - TIME, FACTOR*X, FACTOR*Y, TSTSTR, TRCKID - ELSE - WRITE (NDSOUT,974,ERR=803,IOSTAT=IERR) & - TIME, FACTOR*X, FACTOR*Y, TSTSTR, TRCKID - END IF -! - IF ( TIME(1).EQ.TTST(1) .AND. TIME(2).EQ.TTST(2) ) THEN - ILOC = ILOC + 1 - IF ( TSTSTR .EQ. 'SEA' ) ISPEC = ISPEC + 1 - ENDIF - IF ( TIME(1).NE.TTST(1) .OR. TIME(2).NE.TTST(2) ) THEN - CALL STME21 ( TTST , STIME ) - WRITE (NDSO,941) STIME, ILOC, ISPEC - ILOC = 1 - ISPEC = 0 - IF ( TSTSTR .EQ. 'SEA' ) ISPEC = ISPEC + 1 - TTST(1) = TIME(1) - TTST(2) = TIME(2) - ENDIF -! -! 4.b Check if sea point -! - IF ( TSTSTR .NE. 'SEA' ) GOTO 400 -! -! 4.c Read all data -! - READ (NDSINP,ERR=801,IOSTAT=IERR) DW, CX, CY, WX, WY, UST, AS, & - SPEC - IF ( UST .LT. 0. ) UST = -1.0 -! -! 4.d Write the basic stuff -! - WRITE (NDSOUT,985,ERR=803,IOSTAT=IERR) & - DW, CX, CY, WX, WY, UST, AS, SCALE -! -! 4.e Start of integer packing -! - STRING = EMPTY - ILAST = 0 - NZERO = 0 -! -! 4.e.1 Loop over spectrum -! - DO IK=1, NK - DO ITH=1, NTH - VALUE = MAX ( 0.1 , 1.1*SPEC(IK,ITH)/SCALE ) - IWDTH = 2 + MAX( 0 , INT( ALOG10(VALUE) ) ) -! -! 4.e.2 Put value in string and test overflow -! - IF ( IWDTH .GT. 9 ) THEN - IWDTH = 9 - PART = ' 99999999' - ELSE - WRITE (PART,987) NINT(SPEC(IK,ITH)/SCALE) - IF ( PART(11-IWDTH:11-IWDTH) .EQ. ' ' ) & - IWDTH = IWDTH - 1 - ENDIF -! -! 4.e.3 It's a zero, wait with writing -! - IF ( PART(8:9) .EQ. ' 0' ) THEN - NZERO = NZERO + 1 - ELSE -! -! 4.e.4 It's not a zero, write unwritten zeros -! - IF ( NZERO .NE. 0 ) THEN - IF ( NZERO .EQ. 1 ) THEN - ZEROS = ' 0' - IWZERO = 2 - ELSE - WRITE (ZEROS,'(I7,A2)') NZERO, '*0' - IWZERO = 4 - DO - ICH = 10 - IWZERO - IF ( ZEROS(ICH:ICH) .NE. ' ' ) THEN - IWZERO = IWZERO + 1 - ELSE - EXIT - ENDIF - END DO - ENDIF - IF ( ILAST+IWZERO .GT. LINELN ) THEN - WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) & - STRING(2:ILAST) - STRING = EMPTY - ILAST = 0 - ENDIF - STRING(ILAST+1:ILAST+IWZERO) = & - ZEROS(10-IWZERO:9) - ILAST = ILAST + IWZERO - NZERO = 0 - ENDIF -! -! 4.e.5 It's not a zero, put in string -! - IF ( ILAST+IWDTH .GT. LINELN ) THEN - WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) & - STRING(2:ILAST) - STRING = EMPTY - ILAST = 0 - ENDIF -! - STRING(ILAST+1:ILAST+IWDTH) = PART(10-IWDTH:9) - ILAST = ILAST + IWDTH -! - ENDIF -! - END DO - END DO -! -! ..... End of loop over spectrum (4.e.1) -! -! 4.e.6 Write trailing zeros -! - IF ( NZERO .NE. 0 ) THEN + ALLOCATE ( SIG(MK), DSIP(MK), SPEC(MK,MTH) ) + ! + READ (NDSINP,ERR=801,IOSTAT=IERR) TH1, DTH, SIG, DSIP + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Open output file and prepare + ! + WRITE (NDSO,930) + ! + OPEN (NDSOUT,FILE=FNMPRE(:J)//'track.ww3', & + FORM='FORMATTED',ERR=802,IOSTAT=IERR) + ! + WRITE (NDSOUT,980,ERR=803,IOSTAT=IERR) IDSTR + WRITE (NDSOUT,981,ERR=803,IOSTAT=IERR) MK, MTH, TH1, DTH + WRITE (NDSOUT,982,ERR=803,IOSTAT=IERR) SIG + WRITE (NDSOUT,983,ERR=803,IOSTAT=IERR) DSIP + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Process data + ! + ILOC = 0 + ISPEC = 0 + READ (NDSINP,END=444, ERR=801,IOSTAT=IERR) TTST + BACKSPACE (NDSINP) + WRITE (NDSO,940) + ! +400 CONTINUE + ! + ! 4.a Read/write basic data + ! + READ (NDSINP,END=444, ERR=801,IOSTAT=IERR) TIME, X, Y, TSTSTR, & + TRCKID + IF ( FLAGLL ) THEN + WRITE (NDSOUT,984,ERR=803,IOSTAT=IERR) & + TIME, FACTOR*X, FACTOR*Y, TSTSTR, TRCKID + ELSE + WRITE (NDSOUT,974,ERR=803,IOSTAT=IERR) & + TIME, FACTOR*X, FACTOR*Y, TSTSTR, TRCKID + END IF + ! + IF ( TIME(1).EQ.TTST(1) .AND. TIME(2).EQ.TTST(2) ) THEN + ILOC = ILOC + 1 + IF ( TSTSTR .EQ. 'SEA' ) ISPEC = ISPEC + 1 + ENDIF + IF ( TIME(1).NE.TTST(1) .OR. TIME(2).NE.TTST(2) ) THEN + CALL STME21 ( TTST , STIME ) + WRITE (NDSO,941) STIME, ILOC, ISPEC + ILOC = 1 + ISPEC = 0 + IF ( TSTSTR .EQ. 'SEA' ) ISPEC = ISPEC + 1 + TTST(1) = TIME(1) + TTST(2) = TIME(2) + ENDIF + ! + ! 4.b Check if sea point + ! + IF ( TSTSTR .NE. 'SEA' ) GOTO 400 + ! + ! 4.c Read all data + ! + READ (NDSINP,ERR=801,IOSTAT=IERR) DW, CX, CY, WX, WY, UST, AS, & + SPEC + IF ( UST .LT. 0. ) UST = -1.0 + ! + ! 4.d Write the basic stuff + ! + WRITE (NDSOUT,985,ERR=803,IOSTAT=IERR) & + DW, CX, CY, WX, WY, UST, AS, SCALE + ! + ! 4.e Start of integer packing + ! + STRING = EMPTY + ILAST = 0 + NZERO = 0 + ! + ! 4.e.1 Loop over spectrum + ! + DO IK=1, NK + DO ITH=1, NTH + VALUE = MAX ( 0.1 , 1.1*SPEC(IK,ITH)/SCALE ) + IWDTH = 2 + MAX( 0 , INT( ALOG10(VALUE) ) ) + ! + ! 4.e.2 Put value in string and test overflow + ! + IF ( IWDTH .GT. 9 ) THEN + IWDTH = 9 + PART = ' 99999999' + ELSE + WRITE (PART,987) NINT(SPEC(IK,ITH)/SCALE) + IF ( PART(11-IWDTH:11-IWDTH) .EQ. ' ' ) & + IWDTH = IWDTH - 1 + ENDIF + ! + ! 4.e.3 It's a zero, wait with writing + ! + IF ( PART(8:9) .EQ. ' 0' ) THEN + NZERO = NZERO + 1 + ELSE + ! + ! 4.e.4 It's not a zero, write unwritten zeros + ! + IF ( NZERO .NE. 0 ) THEN IF ( NZERO .EQ. 1 ) THEN - ZEROS = ' 0' - IWZERO = 2 - ELSE - WRITE (ZEROS,'(I7,A2)') NZERO, '*0' - IWZERO = 4 - DO - ICH = 10 - IWZERO - IF ( ZEROS(ICH:ICH) .NE. ' ' ) THEN - IWZERO = IWZERO + 1 - ELSE - EXIT - ENDIF - END DO - ENDIF + ZEROS = ' 0' + IWZERO = 2 + ELSE + WRITE (ZEROS,'(I7,A2)') NZERO, '*0' + IWZERO = 4 + DO + ICH = 10 - IWZERO + IF ( ZEROS(ICH:ICH) .NE. ' ' ) THEN + IWZERO = IWZERO + 1 + ELSE + EXIT + ENDIF + END DO + ENDIF IF ( ILAST+IWZERO .GT. LINELN ) THEN - WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) & - STRING(2:ILAST) - STRING = EMPTY - ILAST = 0 - ENDIF - STRING(ILAST+1:ILAST+IWZERO) = ZEROS(10-IWZERO:9) + WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) & + STRING(2:ILAST) + STRING = EMPTY + ILAST = 0 + ENDIF + STRING(ILAST+1:ILAST+IWZERO) = & + ZEROS(10-IWZERO:9) ILAST = ILAST + IWZERO NZERO = 0 ENDIF -! -! 4.e.7 Write last line -! - IF ( ILAST .NE. 0 ) THEN - WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) STRING(2:ILAST) + ! + ! 4.e.5 It's not a zero, put in string + ! + IF ( ILAST+IWDTH .GT. LINELN ) THEN + WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) & + STRING(2:ILAST) + STRING = EMPTY + ILAST = 0 ENDIF -! -! ... Loop back to top -! - GOTO 400 -! -! 4.f All data done, write last batch info -! - 444 CONTINUE -! - CALL STME21 ( TTST , STIME ) - WRITE (NDSO,941) STIME, ILOC, ISPEC -! - GOTO 888 -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 1 ) -! - 801 CONTINUE - WRITE (NDSE,1001) IERR - CALL EXTCDE ( 2 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 3 ) -! - 803 CONTINUE - WRITE (NDSE,1003) IERR - CALL EXTCDE ( 4 ) -! - 805 CONTINUE - WRITE (NDSE,1004) IERR - CALL EXTCDE ( 5 ) -! - 806 CONTINUE - WRITE (NDSE,1005) IERR - CALL EXTCDE ( 6 ) -! - 807 CONTINUE - WRITE (NDSE,1006) IERR - CALL EXTCDE ( 7 ) -! - 810 CONTINUE - WRITE (NDSE,1010) IDSTR, IDTST - CALL EXTCDE ( 5 ) -! - 811 CONTINUE - WRITE (NDSE,1011) MK, MTH, NK, NTH - CALL EXTCDE ( 6 ) -! - 888 CONTINUE -! - WRITE (NDSO,999) -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Track output post.*** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) - 902 FORMAT ( ' Spectral grid size is ',I3,' by ',I3// & - ' Opening files : '/ & - ' -----------------------------------------------') - 920 FORMAT ( ' Input file ...') - 930 FORMAT ( ' Output file ...') - 940 FORMAT (/' Processing data : '/ & - ' -----------------------------------------------') - 941 FORMAT ( ' ',A,' :',I6,' points and',I6,' spectra.') -! - 980 FORMAT (A) - 981 FORMAT (2I6,2E13.5) - 982 FORMAT (7E11.4) - 983 FORMAT (7E11.4) - 984 FORMAT (I8.8,I7.6,2F9.3,2X,A3,2X,A32) - 974 FORMAT (I8.8,I7.6,2(F9.2,'E3'),2X,A3,2X,A32) - 985 FORMAT (F8.1,2F6.2,2F8.2,f9.5,f7.2,E12.5) - 986 FORMAT (A) - 987 FORMAT (I9) -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Track output '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & - ' ERROR IN OPENING INPUT DATA FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & - ' ERROR IN READING FROM INPUT DATA FILE'/ & - ' IOSTAT =',I5/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & - ' ERROR IN OPENING OUTPUT DATA FILE'/ & - ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & - ' ERROR IN WRITING TO OUTPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & - ' ERROR IN OPENING OUTPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & - ' UNEXPECTED ID STRING IN INPUT : ',A/ & - ' SHOULD BE : ',A/) -! - 1011 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & - ' UNEXPECTED SPECTRAL DIMENSIONS : ',2I4/ & - ' SHOULD BE : ',2I4/) -!/ -!/ End of W3TRCK ----------------------------------------------------- / -!/ - END PROGRAM W3TRCK + ! + STRING(ILAST+1:ILAST+IWDTH) = PART(10-IWDTH:9) + ILAST = ILAST + IWDTH + ! + ENDIF + ! + END DO + END DO + ! + ! ..... End of loop over spectrum (4.e.1) + ! + ! 4.e.6 Write trailing zeros + ! + IF ( NZERO .NE. 0 ) THEN + IF ( NZERO .EQ. 1 ) THEN + ZEROS = ' 0' + IWZERO = 2 + ELSE + WRITE (ZEROS,'(I7,A2)') NZERO, '*0' + IWZERO = 4 + DO + ICH = 10 - IWZERO + IF ( ZEROS(ICH:ICH) .NE. ' ' ) THEN + IWZERO = IWZERO + 1 + ELSE + EXIT + ENDIF + END DO + ENDIF + IF ( ILAST+IWZERO .GT. LINELN ) THEN + WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) & + STRING(2:ILAST) + STRING = EMPTY + ILAST = 0 + ENDIF + STRING(ILAST+1:ILAST+IWZERO) = ZEROS(10-IWZERO:9) + ILAST = ILAST + IWZERO + NZERO = 0 + ENDIF + ! + ! 4.e.7 Write last line + ! + IF ( ILAST .NE. 0 ) THEN + WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) STRING(2:ILAST) + ENDIF + ! + ! ... Loop back to top + ! + GOTO 400 + ! + ! 4.f All data done, write last batch info + ! +444 CONTINUE + ! + CALL STME21 ( TTST , STIME ) + WRITE (NDSO,941) STIME, ILOC, ISPEC + ! + GOTO 888 + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 1 ) + ! +801 CONTINUE + WRITE (NDSE,1001) IERR + CALL EXTCDE ( 2 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 3 ) + ! +803 CONTINUE + WRITE (NDSE,1003) IERR + CALL EXTCDE ( 4 ) + ! +805 CONTINUE + WRITE (NDSE,1004) IERR + CALL EXTCDE ( 5 ) + ! +806 CONTINUE + WRITE (NDSE,1005) IERR + CALL EXTCDE ( 6 ) + ! +807 CONTINUE + WRITE (NDSE,1006) IERR + CALL EXTCDE ( 7 ) + ! +810 CONTINUE + WRITE (NDSE,1010) IDSTR, IDTST + CALL EXTCDE ( 5 ) + ! +811 CONTINUE + WRITE (NDSE,1011) MK, MTH, NK, NTH + CALL EXTCDE ( 6 ) + ! +888 CONTINUE + ! + WRITE (NDSO,999) + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Track output post.*** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) +902 FORMAT ( ' Spectral grid size is ',I3,' by ',I3// & + ' Opening files : '/ & + ' -----------------------------------------------') +920 FORMAT ( ' Input file ...') +930 FORMAT ( ' Output file ...') +940 FORMAT (/' Processing data : '/ & + ' -----------------------------------------------') +941 FORMAT ( ' ',A,' :',I6,' points and',I6,' spectra.') + ! +980 FORMAT (A) +981 FORMAT (2I6,2E13.5) +982 FORMAT (7E11.4) +983 FORMAT (7E11.4) +984 FORMAT (I8.8,I7.6,2F9.3,2X,A3,2X,A32) +974 FORMAT (I8.8,I7.6,2(F9.2,'E3'),2X,A3,2X,A32) +985 FORMAT (F8.1,2F6.2,2F8.2,f9.5,f7.2,E12.5) +986 FORMAT (A) +987 FORMAT (I9) + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Track output '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & + ' ERROR IN OPENING INPUT DATA FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & + ' ERROR IN READING FROM INPUT DATA FILE'/ & + ' IOSTAT =',I5/) + ! +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & + ' ERROR IN OPENING OUTPUT DATA FILE'/ & + ' IOSTAT =',I5/) + ! +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & + ' ERROR IN WRITING TO OUTPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & + ' ERROR IN OPENING OUTPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & + ' UNEXPECTED ID STRING IN INPUT : ',A/ & + ' SHOULD BE : ',A/) + ! +1011 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & + ' UNEXPECTED SPECTRAL DIMENSIONS : ',2I4/ & + ' SHOULD BE : ',2I4/) + !/ + !/ End of W3TRCK ----------------------------------------------------- / + !/ +END PROGRAM W3TRCK diff --git a/model/src/ww3_trnc.F90 b/model/src/ww3_trnc.F90 index 3167c0b4b..b26d0d642 100644 --- a/model/src/ww3_trnc.F90 +++ b/model/src/ww3_trnc.F90 @@ -7,1128 +7,1124 @@ !/ ------------------------------------------------------------------- / !> !> @brief Convert direct access track output file to netCDF file. -!> +!> !> @details Info read from track_o.ww3, written to track.nc. -!> +!> !> @author M. Accensi @date 15-May-2018 !> - PROGRAM W3TRNC -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 15-May-2018 | -!/ +-----------------------------------+ -!/ -!/ 17-Feb-2016 : Creation ( version 5.11 ) -!/ 11-Apr-2016 : Adapted to use more options ( version 5.11 ) -!/ 15-May-2018 : Add namelist feature ( version 6.05 ) -!/ 18-Jun-2020 : Support for 360-day calendar. ( version 7.08 ) -!/ -!/ Copyright 2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Convert direct access track output file to netCDF file. -! -! 2. Method : -! -! Info read from track_o.ww3, written to track.nc -! -! 3. Parameters : -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3NOUT Subr. W3ODATMD Set number of model for output. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! None, stand-alone program. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - - USE W3GDATMD, ONLY : W3NMOD, W3SETG, FLAGLL, XFR - USE W3ODATMD, ONLY : W3NOUT, W3SETO, FNMPRE - USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE +PROGRAM W3TRNC + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 15-May-2018 | + !/ +-----------------------------------+ + !/ + !/ 17-Feb-2016 : Creation ( version 5.11 ) + !/ 11-Apr-2016 : Adapted to use more options ( version 5.11 ) + !/ 15-May-2018 : Add namelist feature ( version 6.05 ) + !/ 18-Jun-2020 : Support for 360-day calendar. ( version 7.08 ) + !/ + !/ Copyright 2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Convert direct access track output file to netCDF file. + ! + ! 2. Method : + ! + ! Info read from track_o.ww3, written to track.nc + ! + ! 3. Parameters : + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3NOUT Subr. W3ODATMD Set number of model for output. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! None, stand-alone program. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + + USE W3GDATMD, ONLY : W3NMOD, W3SETG, FLAGLL, XFR + USE W3ODATMD, ONLY : W3NOUT, W3SETO, FNMPRE + USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE #ifdef W3_S - USE W3SERVMD, ONLY : STRACE + USE W3SERVMD, ONLY : STRACE #endif - USE W3TIMEMD -! - USE W3ODATMD, ONLY: NDSO, NDSE -! - USE W3NMLTRNCMD - USE NETCDF -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(NML_TRACK_T) :: NML_TRACK - TYPE(NML_FILE_T) :: NML_FILE -! - INTEGER :: NDSI, NDSINP, & - NDSOUT, NDSTRC, NTRACE, & - NSPEC, IERR, MK, MTH, IT, & - ILOC, ISPEC, S3, IOUT, & - IRET, NCTYPE,NCID, ITH - - INTEGER :: TIME(2), TOUT(2), NOUT, TDUM(2), & - DIMID(4), VARID(18), DIMLN(4), & - STOPDATE(8) + USE W3TIMEMD + ! + USE W3ODATMD, ONLY: NDSO, NDSE + ! + USE W3NMLTRNCMD + USE NETCDF + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + TYPE(NML_TRACK_T) :: NML_TRACK + TYPE(NML_FILE_T) :: NML_FILE + ! + INTEGER :: NDSI, NDSINP, & + NDSOUT, NDSTRC, NTRACE, & + NSPEC, IERR, MK, MTH, IT, & + ILOC, ISPEC, S3, IOUT, & + IRET, NCTYPE,NCID, ITH + + INTEGER :: TIME(2), TOUT(2), NOUT, TDUM(2), & + DIMID(4), VARID(18), DIMLN(4), & + STOPDATE(8) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! - REAL :: TH1, DTH, X, Y, DW, CX, CY, CAO, CDO,& - WX, WY, WAO, WDO, UST, AS, DTEST, & - DTREQ, DTHD, RTH0, M2KM -! - REAL, ALLOCATABLE :: FREQ(:), FREQ1(:), FREQ2(:), DSIP(:),& - SPEC(:,:), E(:,:), THD(:), DIR(:) -! - CHARACTER*34, PARAMETER :: & - IDTST = 'WAVEWATCH III TRACK OUTPUT SPECTRA' - CHARACTER*30 :: FILEPREFIX, STRSTOPDATE - CHARACTER*20 :: FORMAT1 - CHARACTER :: IDTIME*23, IDDDAY*11, TRCKID*32, & - COMSTR*1, IDSTR*34, TSTSTR*3, STIME*23 -! - LOGICAL :: FLGNML - - -!/ -!/ ------------------------------------------------------------------- / -!/ -! -! 0. Initialize data structure -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! -! 1. IO set-up. -! - NDSI = 10 - NDSINP = 11 - NDSOUT = 51 -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! + ! + REAL :: TH1, DTH, X, Y, DW, CX, CY, CAO, CDO,& + WX, WY, WAO, WDO, UST, AS, DTEST, & + DTREQ, DTHD, RTH0, M2KM + ! + REAL, ALLOCATABLE :: FREQ(:), FREQ1(:), FREQ2(:), DSIP(:),& + SPEC(:,:), E(:,:), THD(:), DIR(:) + ! + CHARACTER*34, PARAMETER :: & + IDTST = 'WAVEWATCH III TRACK OUTPUT SPECTRA' + CHARACTER*30 :: FILEPREFIX, STRSTOPDATE + CHARACTER*20 :: FORMAT1 + CHARACTER :: IDTIME*23, IDDDAY*11, TRCKID*32, & + COMSTR*1, IDSTR*34, TSTSTR*3, STIME*23 + ! + LOGICAL :: FLGNML + + + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + ! 0. Initialize data structure + ! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) + ! + ! 1. IO set-up. + ! + NDSI = 10 + NDSINP = 11 + NDSOUT = 51 + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! #ifdef W3_S - CALL STRACE ( IENT, 'W3TRNC' ) + CALL STRACE ( IENT, 'W3TRNC' ) #endif -! - WRITE (NDSO,900) -! - - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. Read requests from input file. -! - -! -! process ww3_trnc namelist -! - INQUIRE(FILE=TRIM(FNMPRE)//"ww3_trnc.nml", EXIST=FLGNML) - IF (FLGNML) THEN - ! Read namelist - CALL W3NMLTRNC (NDSI, TRIM(FNMPRE)//'ww3_trnc.nml', NML_TRACK, NML_FILE, IERR) - -! 2.1 Time setup IDTIME, DTREQ, NOUT - READ(NML_TRACK%TIMESTRIDE, *) DTREQ - READ(NML_TRACK%TIMECOUNT, *) NOUT - READ(NML_TRACK%TIMESTART, *) TOUT(1), TOUT(2) - - -! 2.2 Output type - NCTYPE = NML_FILE%NETCDF - FILEPREFIX = NML_FILE%PREFIX - S3 = NML_TRACK%TIMESPLIT - - - END IF ! FLGNML - -! -! process old ww3_trnc.inp format -! - IF (.NOT. FLGNML) THEN - OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_trnc.inp',STATUS='OLD',ERR=805,IOSTAT=IERR) - REWIND (NDSI) - - READ (NDSI,'(A)',END=806,ERR=807,IOSTAT=IERR) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR - - -! 2.1 Time setup IDTIME, DTREQ, NOUT - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=806,ERR=807) TOUT, DTREQ, NOUT - - -! 2.2 Output type - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=806,ERR=807) NCTYPE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - FILEPREFIX= 'ww3.' - READ (NDSI,*,END=806,ERR=807) FILEPREFIX - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=806,ERR=807) S3 - - END IF ! .NOT. FLGNML - - - - -! 2.1 Time setup IDTIME, DTREQ, NOUT - DTREQ = MAX ( 0. , DTREQ ) - IF ( DTREQ.EQ.0. ) NOUT = 1 - NOUT = MAX ( 1 , NOUT ) - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,940) IDTIME - TDUM = 0 - CALL TICK21 ( TDUM , DTREQ ) - CALL STME21 ( TDUM , IDTIME ) - IF ( DTREQ .GE. 86400. ) THEN - WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) - ELSE - IDDDAY = ' ' - END IF - IDTIME(1:11) = IDDDAY - IDTIME(21:23) = ' ' - WRITE (NDSO,941) IDTIME, NOUT - - -! 2.2 Output type - IF ( NCTYPE.LT.3 .OR. NCTYPE.GT.4 ) THEN - WRITE (NDSE,1010) NCTYPE - CALL EXTCDE ( 1 ) + ! + WRITE (NDSO,900) + ! + + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Read requests from input file. + ! + + ! + ! process ww3_trnc namelist + ! + INQUIRE(FILE=TRIM(FNMPRE)//"ww3_trnc.nml", EXIST=FLGNML) + IF (FLGNML) THEN + ! Read namelist + CALL W3NMLTRNC (NDSI, TRIM(FNMPRE)//'ww3_trnc.nml', NML_TRACK, NML_FILE, IERR) + + ! 2.1 Time setup IDTIME, DTREQ, NOUT + READ(NML_TRACK%TIMESTRIDE, *) DTREQ + READ(NML_TRACK%TIMECOUNT, *) NOUT + READ(NML_TRACK%TIMESTART, *) TOUT(1), TOUT(2) + + + ! 2.2 Output type + NCTYPE = NML_FILE%NETCDF + FILEPREFIX = NML_FILE%PREFIX + S3 = NML_TRACK%TIMESPLIT + + + END IF ! FLGNML + + ! + ! process old ww3_trnc.inp format + ! + IF (.NOT. FLGNML) THEN + OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_trnc.inp',STATUS='OLD',ERR=805,IOSTAT=IERR) + REWIND (NDSI) + + READ (NDSI,'(A)',END=806,ERR=807,IOSTAT=IERR) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + + + ! 2.1 Time setup IDTIME, DTREQ, NOUT + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=806,ERR=807) TOUT, DTREQ, NOUT + + + ! 2.2 Output type + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=806,ERR=807) NCTYPE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + FILEPREFIX= 'ww3.' + READ (NDSI,*,END=806,ERR=807) FILEPREFIX + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=806,ERR=807) S3 + + END IF ! .NOT. FLGNML + + + + + ! 2.1 Time setup IDTIME, DTREQ, NOUT + DTREQ = MAX ( 0. , DTREQ ) + IF ( DTREQ.EQ.0. ) NOUT = 1 + NOUT = MAX ( 1 , NOUT ) + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,940) IDTIME + TDUM = 0 + CALL TICK21 ( TDUM , DTREQ ) + CALL STME21 ( TDUM , IDTIME ) + IF ( DTREQ .GE. 86400. ) THEN + WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) + ELSE + IDDDAY = ' ' + END IF + IDTIME(1:11) = IDDDAY + IDTIME(21:23) = ' ' + WRITE (NDSO,941) IDTIME, NOUT + + + ! 2.2 Output type + IF ( NCTYPE.LT.3 .OR. NCTYPE.GT.4 ) THEN + WRITE (NDSE,1010) NCTYPE + CALL EXTCDE ( 1 ) + END IF + ! S3 defines the number of characters in the date for the filename + ! S3=4-> YYYY, S3=6 -> YYYYMM, S3=10 -> YYYYMMDDTHHZ ... + + + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 3. Check consistency with input file and track_o.ww3 + ! + OPEN (NDSINP,FILE=TRIM(FNMPRE)//'track_o.ww3',form='UNFORMATTED', convert=file_endian, & + STATUS='OLD',ERR=800,IOSTAT=IERR) + READ (NDSINP,ERR=801,IOSTAT=IERR) IDSTR, FLAGLL, MK, MTH, XFR + ! + IF ( FLAGLL ) THEN + M2KM = 1. + ELSE + M2KM = 1.E-3 + END IF + ! + IF ( IDSTR .NE. IDTST ) GOTO 810 + + WRITE (NDSO,902) MK, MTH + NSPEC = MK * MTH + ALLOCATE ( FREQ(MK), FREQ1(MK), FREQ2(MK), DSIP(MK), & + SPEC(MK,MTH), E(MK,MTH), THD(MTH), DIR(MTH) ) + ! + READ (NDSINP,ERR=801,IOSTAT=IERR) TH1, DTH, FREQ, DSIP + + ! + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 4. Time management. + ! + IOUT = 0 + NCID = 0 + WRITE (NDSO,970) + READ (NDSINP,END=444, ERR=801,IOSTAT=IERR) TIME + BACKSPACE (NDSINP) + + + ! 4.1 Loops on track_o.ww3 to read the time and data + DO + DTEST = DSEC21 ( TIME , TOUT ) + + ! cycle to reach the start time of input file + IF ( DTEST .LT. 0. ) THEN + CALL TICK21 ( TOUT , DTREQ ) + CYCLE + END IF + + IF ( DTEST .GE. 0. ) THEN + TRCKID='' + READ (NDSINP,END=444, ERR=801,IOSTAT=IERR) TIME, X, Y, TSTSTR, TRCKID + IF ( TSTSTR .EQ. 'SEA' ) THEN + READ (NDSINP,ERR=801,IOSTAT=IERR) DW, CX, CY, WX, WY, UST, & + AS, SPEC END IF - ! S3 defines the number of characters in the date for the filename - ! S3=4-> YYYY, S3=6 -> YYYYMM, S3=10 -> YYYYMMDDTHHZ ... - - - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3. Check consistency with input file and track_o.ww3 -! - OPEN (NDSINP,FILE=TRIM(FNMPRE)//'track_o.ww3',form='UNFORMATTED', convert=file_endian, & - STATUS='OLD',ERR=800,IOSTAT=IERR) - READ (NDSINP,ERR=801,IOSTAT=IERR) IDSTR, FLAGLL, MK, MTH, XFR -! - IF ( FLAGLL ) THEN - M2KM = 1. - ELSE - M2KM = 1.E-3 - END IF -! - IF ( IDSTR .NE. IDTST ) GOTO 810 - - WRITE (NDSO,902) MK, MTH - NSPEC = MK * MTH - ALLOCATE ( FREQ(MK), FREQ1(MK), FREQ2(MK), DSIP(MK), & - SPEC(MK,MTH), E(MK,MTH), THD(MTH), DIR(MTH) ) -! - READ (NDSINP,ERR=801,IOSTAT=IERR) TH1, DTH, FREQ, DSIP - -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4. Time management. -! - IOUT = 0 - NCID = 0 - WRITE (NDSO,970) - READ (NDSINP,END=444, ERR=801,IOSTAT=IERR) TIME - BACKSPACE (NDSINP) - - -! 4.1 Loops on track_o.ww3 to read the time and data - DO - DTEST = DSEC21 ( TIME , TOUT ) - - ! cycle to reach the start time of input file - IF ( DTEST .LT. 0. ) THEN - CALL TICK21 ( TOUT , DTREQ ) - CYCLE - END IF - - IF ( DTEST .GE. 0. ) THEN - TRCKID='' - READ (NDSINP,END=444, ERR=801,IOSTAT=IERR) TIME, X, Y, TSTSTR, TRCKID - IF ( TSTSTR .EQ. 'SEA' ) THEN - READ (NDSINP,ERR=801,IOSTAT=IERR) DW, CX, CY, WX, WY, UST, & - AS, SPEC - END IF - IF ( IERR .EQ. -1 ) THEN - WRITE (NDSO,944) - EXIT - END IF - - - IF ( TIME(1).EQ.TOUT(1) .AND. TIME(2).EQ.TOUT(2) ) THEN - ILOC = ILOC + 1 - IF ( TSTSTR .EQ. 'SEA' ) ISPEC = ISPEC + 1 - ENDIF - IF ( TIME(1).GT.TOUT(1) .OR. TIME(2).GT.TOUT(2) ) THEN - CALL STME21 ( TIME , STIME ) - WRITE (NDSO,945) STIME, ILOC, ISPEC - ILOC = 1 - ISPEC = 0 - IF ( TSTSTR .EQ. 'SEA' ) ISPEC = ISPEC + 1 - TOUT(1) = TIME(1) - TOUT(2) = TIME(2) - ENDIF - END IF - - -! 4.1.1 Increments the global time counter IOUT - IOUT = IOUT + 1 - CALL STME21 ( TOUT , IDTIME ) - WRITE (NDSO,971) IDTIME - - -! 4.1.2 Processes the variable value for the time step IOUT - CALL W3EXNC ( FILEPREFIX, NCTYPE, NCID, S3, STRSTOPDATE, MK, MTH ) - - -! 4.1.3 Defines the stop date - CALL T2D(TOUT,STOPDATE,IERR) - WRITE(STRSTOPDATE,'(I4.4,A,4(I2.2,A),I2.2)') STOPDATE(1),'-',STOPDATE(2), & - '-',STOPDATE(3),' ',STOPDATE(5),':',STOPDATE(6),':',STOPDATE(7) - - IF ( IOUT .GE. NOUT ) EXIT - END DO - - - 444 CONTINUE - -! 4.2 Closes the netCDF file - IF (NCID.NE.0) THEN - IRET = NF90_REDEF(NCID) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'stop_date',STRSTOPDATE) - CALL CHECK_ERR(IRET) - IRET=NF90_CLOSE(NCID) - CALL CHECK_ERR(IRET) + IF ( IERR .EQ. -1 ) THEN + WRITE (NDSO,944) + EXIT END IF -! - GOTO 888 -! -! Escape locations read errors : -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 10 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 11 ) -! - 805 CONTINUE - WRITE (NDSE,1004) IERR - CALL EXTCDE ( 14 ) -! - 806 CONTINUE - WRITE (NDSE,1005) IERR - CALL EXTCDE ( 15 ) -! - 807 CONTINUE - WRITE (NDSE,1006) IERR - CALL EXTCDE ( 16 ) -! - - 810 CONTINUE - WRITE (NDSE,1010) IDSTR, IDTST - CALL EXTCDE ( 20 ) -! - 888 CONTINUE - WRITE (NDSO,999) -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Track output postp. *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) -! - 902 FORMAT ( ' Spectral grid size : ',I3,' by ',I3// & - ' Opening file : '/ & - ' -----------------------------------------------') - 940 FORMAT (/' Output time data : '/ & - ' --------------------------------------------------'/ & - ' First time : ',A) - 941 FORMAT ( ' Interval : ',A/ & - ' Number of requests : ',I10) -! - 944 FORMAT (/' End of file reached '/) -! - 945 FORMAT ( ' ',A,' :',I6,' points and',I6,' spectra.') -! - 970 FORMAT (//' Generating files '/ & - ' --------------------------------------------------') - 971 FORMAT ( ' Files for ',A) -! - 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III Track output '/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & - ' ERROR IN OPENING OUTPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & - ' ILLEGAL TYPE, NCTYPE =',I4/) -! -!/ -!/ Internal subroutine W3EXNC ---------------------------------------- / -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - -!> @brief Perform actual track output in NetCDF file. -!> -!> @param[in] FILEPREFIX -!> @param[in] NCTYPE -!> @param[inout] NCID -!> @param[inout] S3 -!> @param[in] STRSTOPDATE -!> @param[in] MK -!> @param[in] MTH -!> -!> @author M. Accensi @date 08-Apr-2016 -!> - SUBROUTINE W3EXNC ( FILEPREFIX, NCTYPE, NCID, S3, STRSTOPDATE, MK, MTH ) -!/ -!/ +-----------------------------------+ -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 8-Apr-2016 | -!/ +-----------------------------------+ -!/ -!/ 8-apr-2016 : Creation ( version 5.11 ) -!/ -! 1. Purpose : -! -! Perform actual track output in NetCDF file. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! Internal parameters -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. Id. Abort program as graceful as possible. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Main program in which it is contained. -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! None. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE NETCDF - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NCTYPE, MK, MTH - CHARACTER(30), INTENT(IN) :: FILEPREFIX, STRSTOPDATE - INTEGER, INTENT(INOUT) :: NCID, S3 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: S1, S2, S4, S5, NDSDAT, IRET - INTEGER :: STARTDATE(8), CURDATE(8), REFDATE(8) - INTEGER :: DEFLATE=1 + IF ( TIME(1).EQ.TOUT(1) .AND. TIME(2).EQ.TOUT(2) ) THEN + ILOC = ILOC + 1 + IF ( TSTSTR .EQ. 'SEA' ) ISPEC = ISPEC + 1 + ENDIF + IF ( TIME(1).GT.TOUT(1) .OR. TIME(2).GT.TOUT(2) ) THEN + CALL STME21 ( TIME , STIME ) + WRITE (NDSO,945) STIME, ILOC, ISPEC + ILOC = 1 + ISPEC = 0 + IF ( TSTSTR .EQ. 'SEA' ) ISPEC = ISPEC + 1 + TOUT(1) = TIME(1) + TOUT(2) = TIME(2) + ENDIF + END IF + + + ! 4.1.1 Increments the global time counter IOUT + IOUT = IOUT + 1 + CALL STME21 ( TOUT , IDTIME ) + WRITE (NDSO,971) IDTIME + + + ! 4.1.2 Processes the variable value for the time step IOUT + CALL W3EXNC ( FILEPREFIX, NCTYPE, NCID, S3, STRSTOPDATE, MK, MTH ) + + + ! 4.1.3 Defines the stop date + CALL T2D(TOUT,STOPDATE,IERR) + WRITE(STRSTOPDATE,'(I4.4,A,4(I2.2,A),I2.2)') STOPDATE(1),'-',STOPDATE(2), & + '-',STOPDATE(3),' ',STOPDATE(5),':',STOPDATE(6),':',STOPDATE(7) + + IF ( IOUT .GE. NOUT ) EXIT + END DO + + +444 CONTINUE + + ! 4.2 Closes the netCDF file + IF (NCID.NE.0) THEN + IRET = NF90_REDEF(NCID) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'stop_date',STRSTOPDATE) + CALL CHECK_ERR(IRET) + IRET=NF90_CLOSE(NCID) + CALL CHECK_ERR(IRET) + END IF + + ! + GOTO 888 + ! + ! Escape locations read errors : + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 10 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 11 ) + ! +805 CONTINUE + WRITE (NDSE,1004) IERR + CALL EXTCDE ( 14 ) + ! +806 CONTINUE + WRITE (NDSE,1005) IERR + CALL EXTCDE ( 15 ) + ! +807 CONTINUE + WRITE (NDSE,1006) IERR + CALL EXTCDE ( 16 ) + ! + +810 CONTINUE + WRITE (NDSE,1010) IDSTR, IDTST + CALL EXTCDE ( 20 ) + ! +888 CONTINUE + WRITE (NDSO,999) + ! + ! Formats + ! +900 FORMAT (/15X,' *** WAVEWATCH III Track output postp. *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) + ! +902 FORMAT ( ' Spectral grid size : ',I3,' by ',I3// & + ' Opening file : '/ & + ' -----------------------------------------------') +940 FORMAT (/' Output time data : '/ & + ' --------------------------------------------------'/ & + ' First time : ',A) +941 FORMAT ( ' Interval : ',A/ & + ' Number of requests : ',I10) + ! +944 FORMAT (/' End of file reached '/) + ! +945 FORMAT ( ' ',A,' :',I6,' points and',I6,' spectra.') + ! +970 FORMAT (//' Generating files '/ & + ' --------------------------------------------------') +971 FORMAT ( ' Files for ',A) + ! +999 FORMAT (/' End of program '/ & + ' ========================================='/ & + ' WAVEWATCH III Track output '/) + ! +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & + ' PREMATURE END OF INPUT FILE'/) + ! +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & + ' ERROR IN OPENING OUTPUT FILE'/ & + ' IOSTAT =',I5/) + ! +1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRNC : '/ & + ' ILLEGAL TYPE, NCTYPE =',I4/) + ! + !/ + !/ Internal subroutine W3EXNC ---------------------------------------- / + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + + !> @brief Perform actual track output in NetCDF file. + !> + !> @param[in] FILEPREFIX + !> @param[in] NCTYPE + !> @param[inout] NCID + !> @param[inout] S3 + !> @param[in] STRSTOPDATE + !> @param[in] MK + !> @param[in] MTH + !> + !> @author M. Accensi @date 08-Apr-2016 + !> + SUBROUTINE W3EXNC ( FILEPREFIX, NCTYPE, NCID, S3, STRSTOPDATE, MK, MTH ) + !/ + !/ +-----------------------------------+ + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 8-Apr-2016 | + !/ +-----------------------------------+ + !/ + !/ 8-apr-2016 : Creation ( version 5.11 ) + !/ + ! 1. Purpose : + ! + ! Perform actual track output in NetCDF file. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! Internal parameters + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Main program in which it is contained. + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! None. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE NETCDF + IMPLICIT NONE + + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NCTYPE, MK, MTH + CHARACTER(30), INTENT(IN) :: FILEPREFIX, STRSTOPDATE + INTEGER, INTENT(INOUT) :: NCID, S3 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: S1, S2, S4, S5, NDSDAT, IRET + INTEGER :: STARTDATE(8), CURDATE(8), REFDATE(8) + INTEGER :: DEFLATE=1 #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif -! - DOUBLE PRECISION :: OUTJULDAY -! - CHARACTER*30 :: STRSTARTDATE - CHARACTER :: FNAMENC*50, ENAME*6 - CHARACTER, SAVE :: OLDTIMEID*16 = '0000000000000000' - CHARACTER, SAVE :: TIMEID*16 = '0000000000000000' - -!/ -!/ ------------------------------------------------------------------- / -!/ -! + ! + DOUBLE PRECISION :: OUTJULDAY + ! + CHARACTER*30 :: STRSTARTDATE + CHARACTER :: FNAMENC*50, ENAME*6 + CHARACTER, SAVE :: OLDTIMEID*16 = '0000000000000000' + CHARACTER, SAVE :: TIMEID*16 = '0000000000000000' + + !/ + !/ ------------------------------------------------------------------- / + !/ + ! #ifdef W3_S - CALL STRACE (IENT, 'W3EXNC') + CALL STRACE (IENT, 'W3EXNC') #endif -! - CALL U2D('days since 1990-01-01 00:00:00',REFDATE,IERR) - -! 1.1 Sets the date as ISO8601 convention - ! S3 defines the number of characters in the date for the filename - ! S3=4-> YYYY, S3=6 -> YYYYMM, S3=10 -> YYYYMMDDHH - ! Setups min and max date format - IF (S3.LT.4) S3=4 - IF (S3.GT.10) S3=10 -! - ! Defines the format of FILETIME - S5=S3-8 - S4=S3 - OLDTIMEID=TIMEID - ! if S3=>YYYYMMDDHH then filetime='YYYYMMDDTHHMMSSZ' - IF (S3.EQ.10) THEN - S4=S4+2 ! add chars for ISO8601 : day T hours Z - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I8.8,A1,I',S5,'.',S5,',A1)' - WRITE (TIMEID,FORMAT1) TIME(1), 'T', & - FLOOR(REAL(TIME(2))/NINT(10.**(6-S5))), 'Z' + ! + CALL U2D('days since 1990-01-01 00:00:00',REFDATE,IERR) + + ! 1.1 Sets the date as ISO8601 convention + ! S3 defines the number of characters in the date for the filename + ! S3=4-> YYYY, S3=6 -> YYYYMM, S3=10 -> YYYYMMDDHH + ! Setups min and max date format + IF (S3.LT.4) S3=4 + IF (S3.GT.10) S3=10 + ! + ! Defines the format of FILETIME + S5=S3-8 + S4=S3 + OLDTIMEID=TIMEID + ! if S3=>YYYYMMDDHH then filetime='YYYYMMDDTHHMMSSZ' + IF (S3.EQ.10) THEN + S4=S4+2 ! add chars for ISO8601 : day T hours Z + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I8.8,A1,I',S5,'.',S5,',A1)' + WRITE (TIMEID,FORMAT1) TIME(1), 'T', & + FLOOR(REAL(TIME(2))/NINT(10.**(6-S5))), 'Z' ! if S3=>YYYYMMDD then filetime='YYYYMMDD' - ELSE IF (S3.EQ.8) THEN - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' - WRITE (TIMEID,FORMAT1) TIME(1) + ELSE IF (S3.EQ.8) THEN + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' + WRITE (TIMEID,FORMAT1) TIME(1) ! if S3=>YYYYMM then filetime='YYYYMM' ! or S3=>YYYY then filetime='YYYY' - ELSE - WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' - WRITE (TIMEID,FORMAT1) FLOOR(REAL(TIME(1))/NINT(10.**(8-S3))) - END IF - ! redefines filename with updated date format - S1=LEN_TRIM(FILEPREFIX) - FNAMENC='' - FNAMENC(1:S1)=FILEPREFIX(1:S1) - FNAMENC(S1+1:S1+S4) = TIMEID(1:S4) - - -! 1.2 Setups the output type 4 ( NetCDF file ) - - ENAME='.trck' - S2=LEN_TRIM(ENAME) - S1=LEN_TRIM(FILEPREFIX)+S4 - FNAMENC(S1+1:50)=' ' - FNAMENC(S1+1:S1+1) = '_' - - ! add variable name in file name - FNAMENC(S1+2:S1+S2) = ENAME(2:S2) - - ! Defines the netcdf extension - FNAMENC(S1+S2+1:S1+S2+3) = '.nc' - FNAMENC(S1+S2+4:S1+S2+6) = ' ' - - ! Defines the dimensions - DIMLN(1)=NF90_UNLIMITED ! time - DIMLN(2)=MK ! frequency - DIMLN(3)=MTH ! direction - DIMLN(4)=32 ! string track name length - - -! 1.3 Gets the netcdf id - - NDSDAT=30 - OPEN (NDSDAT,FILE=FNAMENC,status='new',IOSTAT=IRET) - IF (IRET.EQ.0) THEN - ! CLOSE old file - IF (INDEX('0000000000000000',OLDTIMEID).EQ.0 .AND. INDEX(TIMEID,OLDTIMEID).EQ.0) THEN - IRET = NF90_REDEF(NCID) - CALL CHECK_ERR(IRET) - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'stop_date',STRSTOPDATE) - CALL CHECK_ERR(IRET) - IRET=NF90_CLOSE(NCID) - CALL CHECK_ERR(IRET) - END IF - NCID=0 - ELSE - NCID=NCID - END IF - - -! 1.4 Creates the netcdf file - - IF (NCID.EQ.0) THEN - - ! Initializes the time iteration counter n - IT = 0 - ILOC = 0 - ISPEC = 0 - -! 1.4.1 Creates the NetCDF file - - CALL W3CRNC(NCTYPE,FNAMENC,NCID,DIMID,DIMLN,VARID) - - ! put start date in global attribute - CALL T2D(TIME,STARTDATE,IERR) - WRITE(STRSTARTDATE,'(I4.4,A,4(I2.2,A),I2.2)') STARTDATE(1),'-',STARTDATE(2),'-', & - STARTDATE(3),' ',STARTDATE(5),':',STARTDATE(6),':',STARTDATE(7) -! - IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'start_date',STRSTARTDATE) - CALL CHECK_ERR(IRET) - - ! End of define mode of NetCDF file - IRET = NF90_ENDDEF(NCID) - CALL CHECK_ERR(IRET) - - ! Process lower band and higher band frequencies - FREQ1(1:MK)=FREQ(1:MK)-0.5*(FREQ(1:MK)-(FREQ(1:MK)/XFR)) - FREQ2(1:MK)=FREQ(1:MK)+0.5*(-FREQ(1:MK)+(FREQ(1:MK)*XFR)) - FREQ1(1)=FREQ(1) - FREQ2(MK)=FREQ(MK) - - ! Converts direction unit in degree - DTHD=360./MTH - RTH0=TH1/DTH - DO ITH=1, MTH - THD(ITH)=DTHD*(RTH0+REAL(ITH-1)) - END DO - DIR(1:MTH)=MOD(360-THD(1:MTH),360.) - - -! 1.4.2 Adds general variables to NetCDF file - IRET=NF90_PUT_VAR(NCID,VARID(2),FREQ) - CALL CHECK_ERR(IRET) - - IRET=NF90_PUT_VAR(NCID,VARID(3),FREQ1) - CALL CHECK_ERR(IRET) - - IRET=NF90_PUT_VAR(NCID,VARID(4),FREQ2) + ELSE + WRITE(FORMAT1,'(A,I1,A,I1,A)') '(I',S3,'.',S3,')' + WRITE (TIMEID,FORMAT1) FLOOR(REAL(TIME(1))/NINT(10.**(8-S3))) + END IF + ! redefines filename with updated date format + S1=LEN_TRIM(FILEPREFIX) + FNAMENC='' + FNAMENC(1:S1)=FILEPREFIX(1:S1) + FNAMENC(S1+1:S1+S4) = TIMEID(1:S4) + + + ! 1.2 Setups the output type 4 ( NetCDF file ) + + ENAME='.trck' + S2=LEN_TRIM(ENAME) + S1=LEN_TRIM(FILEPREFIX)+S4 + FNAMENC(S1+1:50)=' ' + FNAMENC(S1+1:S1+1) = '_' + + ! add variable name in file name + FNAMENC(S1+2:S1+S2) = ENAME(2:S2) + + ! Defines the netcdf extension + FNAMENC(S1+S2+1:S1+S2+3) = '.nc' + FNAMENC(S1+S2+4:S1+S2+6) = ' ' + + ! Defines the dimensions + DIMLN(1)=NF90_UNLIMITED ! time + DIMLN(2)=MK ! frequency + DIMLN(3)=MTH ! direction + DIMLN(4)=32 ! string track name length + + + ! 1.3 Gets the netcdf id + + NDSDAT=30 + OPEN (NDSDAT,FILE=FNAMENC,status='new',IOSTAT=IRET) + IF (IRET.EQ.0) THEN + ! CLOSE old file + IF (INDEX('0000000000000000',OLDTIMEID).EQ.0 .AND. INDEX(TIMEID,OLDTIMEID).EQ.0) THEN + IRET = NF90_REDEF(NCID) CALL CHECK_ERR(IRET) - - IRET=NF90_PUT_VAR(NCID,VARID(5),DSIP) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'stop_date',STRSTOPDATE) CALL CHECK_ERR(IRET) - - IRET=NF90_PUT_VAR(NCID,VARID(6),DIR) + IRET=NF90_CLOSE(NCID) CALL CHECK_ERR(IRET) - - WRITE (NDSO,973) FNAMENC - - END IF ! IERR.EQ.0 - - -! 1.5 Defines the current time step and index - - CALL T2D(TIME,CURDATE,IERR) - OUTJULDAY=TSUB(REFDATE,CURDATE) - WRITE(NDSO,'(3A,I6,A,I4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2,2A)') & - 'Writing new record ', ENAME(2:) ,'number ',IT, & - ' for ',CURDATE(1),':',CURDATE(2),':',CURDATE(3),'T',CURDATE(5), & - ':',CURDATE(6),':',CURDATE(7),' in file ',TRIM(FNAMENC) - - -! -! 1.6 Exit from W3EXNC if not sea point -! - IF ( TSTSTR .NE. 'SEA' ) GOTO 888 - - -! -! 1.6.1 Process speed and direction components -! - WAO = SQRT ( WX**2 + WY**2 ) - IF ( WAO.GT.1.E-7 ) THEN - WDO = MOD(270.-ATAN2(WY,WX)*RADE,360.) - ELSE - WDO = 0. - END IF - - CAO = SQRT ( CX**2 + CY**2 ) - IF ( CAO.GT.1.E-7 ) THEN - CDO = MOD(270.-ATAN2(CY,CX)*RADE,360.) - ELSE - CDO = 0. END IF - -! -! 1.7.1 Puts dimensions variables in NetCDF file -! - IT=IT+1 - IF ( UST .LT. 0. ) UST = -1.0 - - ! time - IRET=NF90_PUT_VAR(NCID,VARID(1),OUTJULDAY,start=(/IT/)) - CALL CHECK_ERR(IRET) - ! longitude - IRET=NF90_PUT_VAR(NCID,VARID(7),M2KM*X,start=(/IT/)) - CALL CHECK_ERR(IRET) - ! latitude - IRET=NF90_PUT_VAR(NCID,VARID(8),M2KM*Y,start=(/IT/)) - CALL CHECK_ERR(IRET) - + NCID=0 + ELSE + NCID=NCID + END IF -! 1.7.2 Puts fields in NetCDF file + ! 1.4 Creates the netcdf file + IF (NCID.EQ.0) THEN -! 1.7.2.a Write spectrum + ! Initializes the time iteration counter n + IT = 0 + ILOC = 0 + ISPEC = 0 - IRET=NF90_PUT_VAR(NCID,VARID(9), & - TRANSPOSE(SPEC),start=(/1,1,IT/), count=(/MTH,MK,1/)) - CALL CHECK_ERR(IRET) + ! 1.4.1 Creates the NetCDF file -! 1.7.2.b Write the basic stuff + CALL W3CRNC(NCTYPE,FNAMENC,NCID,DIMID,DIMLN,VARID) - ! Write DW (depth) - IRET=NF90_PUT_VAR(NCID, VARID(10),DW ,start=(/IT/)) - CALL CHECK_ERR(IRET) - ! Write CAO (current - x direction) - IRET=NF90_PUT_VAR(NCID, VARID(11),CAO ,start=(/IT/)) - CALL CHECK_ERR(IRET) - ! Write CDO (current - y direction) - IRET=NF90_PUT_VAR(NCID,VARID(12),CDO ,start=(/IT/)) - CALL CHECK_ERR(IRET) - ! Write WAO (wind velocity - x direction) - IRET=NF90_PUT_VAR(NCID,VARID(13),WAO ,start=(/IT/)) - CALL CHECK_ERR(IRET) - ! Write WDO (wind velocity - y direction) - IRET=NF90_PUT_VAR(NCID,VARID(14),WDO ,start=(/IT/)) - CALL CHECK_ERR(IRET) - ! Write UST (friction velocity) - IRET=NF90_PUT_VAR(NCID,VARID(15),UST,start=(/IT/)) + ! put start date in global attribute + CALL T2D(TIME,STARTDATE,IERR) + WRITE(STRSTARTDATE,'(I4.4,A,4(I2.2,A),I2.2)') STARTDATE(1),'-',STARTDATE(2),'-', & + STARTDATE(3),' ',STARTDATE(5),':',STARTDATE(6),':',STARTDATE(7) + ! + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'start_date',STRSTARTDATE) CALL CHECK_ERR(IRET) - ! Write AS (air sea temperature difference) - IRET=NF90_PUT_VAR(NCID,VARID(16),AS ,start=(/IT/)) - CALL CHECK_ERR(IRET) - ! Track name - IRET=NF90_PUT_VAR(NCID,VARID(18),TRCKID,start=(/1,IT/),count=(/LEN_TRIM(TRCKID),1/)) - CALL CHECK_ERR(IRET) - - -! - 888 CONTINUE -! - RETURN - -! -! Formats -! - 973 FORMAT ( 'NEW NetCDF file was created ',A) - - -!/ End of W3EXNC ----------------------------------------------------- / -!/ - END SUBROUTINE W3EXNC + ! End of define mode of NetCDF file + IRET = NF90_ENDDEF(NCID) + CALL CHECK_ERR(IRET) + ! Process lower band and higher band frequencies + FREQ1(1:MK)=FREQ(1:MK)-0.5*(FREQ(1:MK)-(FREQ(1:MK)/XFR)) + FREQ2(1:MK)=FREQ(1:MK)+0.5*(-FREQ(1:MK)+(FREQ(1:MK)*XFR)) + FREQ1(1)=FREQ(1) + FREQ2(MK)=FREQ(MK) + + ! Converts direction unit in degree + DTHD=360./MTH + RTH0=TH1/DTH + DO ITH=1, MTH + THD(ITH)=DTHD*(RTH0+REAL(ITH-1)) + END DO + DIR(1:MTH)=MOD(360-THD(1:MTH),360.) -!-------------------------------------------------------------------------- -!> @brief Desc not available. -!> -!> @param[in] NCTYPE -!> @param[in] NCFILE -!> @param[out] NCID -!> @param[out] DIMID -!> @param[in] DIMLN -!> @param[out] VARID -!> -!> @author NA @date NA -!> - SUBROUTINE W3CRNC (NCTYPE,NCFILE,NCID,DIMID,DIMLN,VARID) - - USE NETCDF - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NCTYPE - CHARACTER*(*), INTENT(IN) :: NCFILE - INTEGER, INTENT(IN) :: DIMLN(:) - INTEGER, INTENT(OUT) :: DIMID(:), VARID(:), NCID - INTEGER :: IRET - INTEGER :: DEFLATE=1 - -! -! Creation in netCDF3 or netCDF4 -! - IF(NCTYPE.EQ.3) IRET = NF90_CREATE(TRIM(NCFILE), NF90_CLOBBER, NCID) - IF(NCTYPE.EQ.4) IRET = NF90_CREATE(TRIM(NCFILE), NF90_NETCDF4, NCID) + ! 1.4.2 Adds general variables to NetCDF file + IRET=NF90_PUT_VAR(NCID,VARID(2),FREQ) CALL CHECK_ERR(IRET) -! -! Define generals dimensions -! - IRET = NF90_DEF_DIM(NCID, 'time', DIMLN(1), DIMID(1)) - CALL CHECK_ERR(IRET) - IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(2), DIMID(2)) - CALL CHECK_ERR(IRET) - IRET = NF90_DEF_DIM(NCID, 'direction', DIMLN(3), DIMID(3)) + IRET=NF90_PUT_VAR(NCID,VARID(3),FREQ1) CALL CHECK_ERR(IRET) - IRET = NF90_DEF_DIM(NCID, 'string32', DIMLN(4), DIMID(4)) + + IRET=NF90_PUT_VAR(NCID,VARID(4),FREQ2) CALL CHECK_ERR(IRET) -! -! define generals variables -! - -! time - IRET=NF90_DEF_VAR(NCID, 'time', NF90_DOUBLE, (/DIMID(1)/), VARID(1)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(1), 1, 1, DEFLATE) - SELECT CASE (TRIM(CALTYPE)) - CASE ('360_day') - IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','time in 360 day calendar') - CASE ('365_day') - IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','time in 365 day calendar') - CASE ('standard') - IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','julian day (UT)') - END SELECT - IRET=NF90_PUT_ATT(NCID,VARID(1),'standard_name','time') - IRET=NF90_PUT_ATT(NCID,VARID(1),'units','days since 1990-01-01 00:00:00') - IRET=NF90_PUT_ATT(NCID,VARID(1),'conventions', & - 'Relative julian days with decimal part (as parts of the day)') - IRET=NF90_PUT_ATT(NCID,VARID(1),'axis','T') - IRET=NF90_PUT_ATT(NCID,VARID(1),'calendar',TRIM(CALTYPE)) - -! frequency - IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, (/DIMID(2)/),VARID(2)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(2), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','center frequencies for spectra') - IRET=NF90_PUT_ATT(NCID,VARID(2),'standard_name','frequency') - IRET=NF90_PUT_ATT(NCID,VARID(2),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(2),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(2),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(2),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(2),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(2),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(2),'axis','Y') - -!frequency1 - IRET=NF90_DEF_VAR(NCID, 'frequency1', NF90_FLOAT, (/DIMID(2)/), VARID(3)) + IRET=NF90_PUT_VAR(NCID,VARID(5),DSIP) CALL CHECK_ERR(IRET) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(3), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','frequency of lower band') - IRET=NF90_PUT_ATT(NCID,VARID(3),'standard_name','frequency_of_lower_band') - IRET=NF90_PUT_ATT(NCID,VARID(3),'globwave_name','frequency_lower_band') - IRET=NF90_PUT_ATT(NCID,VARID(3),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(3),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(3),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(3),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(3),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(3),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(3),'content','Y') - IRET=NF90_PUT_ATT(NCID,VARID(3),'associates','frequency') - -!frequency2 - IRET=NF90_DEF_VAR(NCID, 'frequency2', NF90_FLOAT, (/DIMID(2)/), VARID(4)) + + IRET=NF90_PUT_VAR(NCID,VARID(6),DIR) CALL CHECK_ERR(IRET) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(4), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(4),'long_name','frequency of upper band') - IRET=NF90_PUT_ATT(NCID,VARID(4),'standard_name','frequency_of_upper_band') - IRET=NF90_PUT_ATT(NCID,VARID(4),'globwave_name','frequency_upper_band') - IRET=NF90_PUT_ATT(NCID,VARID(4),'units','s-1') - IRET=NF90_PUT_ATT(NCID,VARID(4),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(4),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(4),'content','Y') - IRET=NF90_PUT_ATT(NCID,VARID(4),'associates','frequency') - -! frequency area - IRET=NF90_DEF_VAR(NCID, 'frequency_area', NF90_FLOAT,(/DIMID(2)/),VARID(5)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(5), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(5),'long_name','frequency spectral bin width') - IRET=NF90_PUT_ATT(NCID,VARID(5),'standard_name','frequency_area') - IRET=NF90_PUT_ATT(NCID,VARID(5),'units','s-2') - IRET=NF90_PUT_ATT(NCID,VARID(5),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(5),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(5),'content','Y') - IRET=NF90_PUT_ATT(NCID,VARID(5),'associates','frequency') - -! direction - IRET=NF90_DEF_VAR(NCID, 'direction', NF90_FLOAT, (/DIMID(3)/),VARID(6)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','sea surface wave to direction') - IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_to_direction') - IRET=NF90_PUT_ATT(NCID,VARID(6),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Z') - - IF (FLAGLL) THEN -! longitude - IRET=NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, (/DIMID(1)/),VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','longitude') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','longitude') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','degree_east') - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-180.0) - IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',360.) - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time') - - -! latitude - IRET=NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, (/DIMID(1)/),VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','latitude') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','latitude') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','degree_north') - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',-90.0) - IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',180.) - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time') - ELSE -! longitude - IRET=NF90_DEF_VAR(NCID, 'x', NF90_FLOAT, (/DIMID(1)/),VARID(7)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','x') - IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','x') - IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(7),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time') - -! latitude - IRET=NF90_DEF_VAR(NCID, 'y', NF90_FLOAT, (/DIMID(1)/),VARID(8)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','y') - IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','y') - IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(8),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time') - END IF + WRITE (NDSO,973) FNAMENC + + END IF ! IERR.EQ.0 + + + ! 1.5 Defines the current time step and index + + CALL T2D(TIME,CURDATE,IERR) + OUTJULDAY=TSUB(REFDATE,CURDATE) + WRITE(NDSO,'(3A,I6,A,I4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2,2A)') & + 'Writing new record ', ENAME(2:) ,'number ',IT, & + ' for ',CURDATE(1),':',CURDATE(2),':',CURDATE(3),'T',CURDATE(5), & + ':',CURDATE(6),':',CURDATE(7),' in file ',TRIM(FNAMENC) -! Efth - IRET=NF90_DEF_VAR(NCID,'efth',NF90_FLOAT,(/DIMID(3),DIMID(2),DIMID(1)/),VARID(9)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name', & + ! + ! 1.6 Exit from W3EXNC if not sea point + ! + IF ( TSTSTR .NE. 'SEA' ) GOTO 888 + + + ! + ! 1.6.1 Process speed and direction components + ! + WAO = SQRT ( WX**2 + WY**2 ) + IF ( WAO.GT.1.E-7 ) THEN + WDO = MOD(270.-ATAN2(WY,WX)*RADE,360.) + ELSE + WDO = 0. + END IF + + CAO = SQRT ( CX**2 + CY**2 ) + IF ( CAO.GT.1.E-7 ) THEN + CDO = MOD(270.-ATAN2(CY,CX)*RADE,360.) + ELSE + CDO = 0. + END IF + + ! + ! 1.7.1 Puts dimensions variables in NetCDF file + ! + IT=IT+1 + IF ( UST .LT. 0. ) UST = -1.0 + + ! time + IRET=NF90_PUT_VAR(NCID,VARID(1),OUTJULDAY,start=(/IT/)) + CALL CHECK_ERR(IRET) + ! longitude + IRET=NF90_PUT_VAR(NCID,VARID(7),M2KM*X,start=(/IT/)) + CALL CHECK_ERR(IRET) + ! latitude + IRET=NF90_PUT_VAR(NCID,VARID(8),M2KM*Y,start=(/IT/)) + CALL CHECK_ERR(IRET) + + + + ! 1.7.2 Puts fields in NetCDF file + + + ! 1.7.2.a Write spectrum + + IRET=NF90_PUT_VAR(NCID,VARID(9), & + TRANSPOSE(SPEC),start=(/1,1,IT/), count=(/MTH,MK,1/)) + CALL CHECK_ERR(IRET) + + ! 1.7.2.b Write the basic stuff + + ! Write DW (depth) + IRET=NF90_PUT_VAR(NCID, VARID(10),DW ,start=(/IT/)) + CALL CHECK_ERR(IRET) + ! Write CAO (current - x direction) + IRET=NF90_PUT_VAR(NCID, VARID(11),CAO ,start=(/IT/)) + CALL CHECK_ERR(IRET) + ! Write CDO (current - y direction) + IRET=NF90_PUT_VAR(NCID,VARID(12),CDO ,start=(/IT/)) + CALL CHECK_ERR(IRET) + ! Write WAO (wind velocity - x direction) + IRET=NF90_PUT_VAR(NCID,VARID(13),WAO ,start=(/IT/)) + CALL CHECK_ERR(IRET) + ! Write WDO (wind velocity - y direction) + IRET=NF90_PUT_VAR(NCID,VARID(14),WDO ,start=(/IT/)) + CALL CHECK_ERR(IRET) + ! Write UST (friction velocity) + IRET=NF90_PUT_VAR(NCID,VARID(15),UST,start=(/IT/)) + CALL CHECK_ERR(IRET) + ! Write AS (air sea temperature difference) + IRET=NF90_PUT_VAR(NCID,VARID(16),AS ,start=(/IT/)) + CALL CHECK_ERR(IRET) + ! Track name + IRET=NF90_PUT_VAR(NCID,VARID(18),TRCKID,start=(/1,IT/),count=(/LEN_TRIM(TRCKID),1/)) + CALL CHECK_ERR(IRET) + + + ! +888 CONTINUE + ! + RETURN + + ! + ! Formats + ! +973 FORMAT ( 'NEW NetCDF file was created ',A) + + + !/ End of W3EXNC ----------------------------------------------------- / + !/ + END SUBROUTINE W3EXNC + + + + + !-------------------------------------------------------------------------- + !> @brief Desc not available. + !> + !> @param[in] NCTYPE + !> @param[in] NCFILE + !> @param[out] NCID + !> @param[out] DIMID + !> @param[in] DIMLN + !> @param[out] VARID + !> + !> @author NA @date NA + !> + SUBROUTINE W3CRNC (NCTYPE,NCFILE,NCID,DIMID,DIMLN,VARID) + + USE NETCDF + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NCTYPE + CHARACTER*(*), INTENT(IN) :: NCFILE + INTEGER, INTENT(IN) :: DIMLN(:) + INTEGER, INTENT(OUT) :: DIMID(:), VARID(:), NCID + INTEGER :: IRET + INTEGER :: DEFLATE=1 + + ! + ! Creation in netCDF3 or netCDF4 + ! + IF(NCTYPE.EQ.3) IRET = NF90_CREATE(TRIM(NCFILE), NF90_CLOBBER, NCID) + IF(NCTYPE.EQ.4) IRET = NF90_CREATE(TRIM(NCFILE), NF90_NETCDF4, NCID) + CALL CHECK_ERR(IRET) + + ! + ! Define generals dimensions + ! + IRET = NF90_DEF_DIM(NCID, 'time', DIMLN(1), DIMID(1)) + CALL CHECK_ERR(IRET) + IRET = NF90_DEF_DIM(NCID, 'frequency', DIMLN(2), DIMID(2)) + CALL CHECK_ERR(IRET) + IRET = NF90_DEF_DIM(NCID, 'direction', DIMLN(3), DIMID(3)) + CALL CHECK_ERR(IRET) + IRET = NF90_DEF_DIM(NCID, 'string32', DIMLN(4), DIMID(4)) + CALL CHECK_ERR(IRET) + + ! + ! define generals variables + ! + + ! time + IRET=NF90_DEF_VAR(NCID, 'time', NF90_DOUBLE, (/DIMID(1)/), VARID(1)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(1), 1, 1, DEFLATE) + SELECT CASE (TRIM(CALTYPE)) + CASE ('360_day') + IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','time in 360 day calendar') + CASE ('365_day') + IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','time in 365 day calendar') + CASE ('standard') + IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','julian day (UT)') + END SELECT + IRET=NF90_PUT_ATT(NCID,VARID(1),'standard_name','time') + IRET=NF90_PUT_ATT(NCID,VARID(1),'units','days since 1990-01-01 00:00:00') + IRET=NF90_PUT_ATT(NCID,VARID(1),'conventions', & + 'Relative julian days with decimal part (as parts of the day)') + IRET=NF90_PUT_ATT(NCID,VARID(1),'axis','T') + IRET=NF90_PUT_ATT(NCID,VARID(1),'calendar',TRIM(CALTYPE)) + + ! frequency + IRET=NF90_DEF_VAR(NCID, 'frequency', NF90_FLOAT, (/DIMID(2)/),VARID(2)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(2), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','center frequencies for spectra') + IRET=NF90_PUT_ATT(NCID,VARID(2),'standard_name','frequency') + IRET=NF90_PUT_ATT(NCID,VARID(2),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(2),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(2),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(2),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(2),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(2),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(2),'axis','Y') + + !frequency1 + IRET=NF90_DEF_VAR(NCID, 'frequency1', NF90_FLOAT, (/DIMID(2)/), VARID(3)) + CALL CHECK_ERR(IRET) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(3), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(3),'long_name','frequency of lower band') + IRET=NF90_PUT_ATT(NCID,VARID(3),'standard_name','frequency_of_lower_band') + IRET=NF90_PUT_ATT(NCID,VARID(3),'globwave_name','frequency_lower_band') + IRET=NF90_PUT_ATT(NCID,VARID(3),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(3),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(3),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(3),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(3),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(3),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(3),'content','Y') + IRET=NF90_PUT_ATT(NCID,VARID(3),'associates','frequency') + + !frequency2 + IRET=NF90_DEF_VAR(NCID, 'frequency2', NF90_FLOAT, (/DIMID(2)/), VARID(4)) + CALL CHECK_ERR(IRET) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(4), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(4),'long_name','frequency of upper band') + IRET=NF90_PUT_ATT(NCID,VARID(4),'standard_name','frequency_of_upper_band') + IRET=NF90_PUT_ATT(NCID,VARID(4),'globwave_name','frequency_upper_band') + IRET=NF90_PUT_ATT(NCID,VARID(4),'units','s-1') + IRET=NF90_PUT_ATT(NCID,VARID(4),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(4),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(4),'content','Y') + IRET=NF90_PUT_ATT(NCID,VARID(4),'associates','frequency') + + ! frequency area + IRET=NF90_DEF_VAR(NCID, 'frequency_area', NF90_FLOAT,(/DIMID(2)/),VARID(5)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(5), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(5),'long_name','frequency spectral bin width') + IRET=NF90_PUT_ATT(NCID,VARID(5),'standard_name','frequency_area') + IRET=NF90_PUT_ATT(NCID,VARID(5),'units','s-2') + IRET=NF90_PUT_ATT(NCID,VARID(5),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(5),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(5),'content','Y') + IRET=NF90_PUT_ATT(NCID,VARID(5),'associates','frequency') + + ! direction + IRET=NF90_DEF_VAR(NCID, 'direction', NF90_FLOAT, (/DIMID(3)/),VARID(6)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(6), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(6),'long_name','sea surface wave to direction') + IRET=NF90_PUT_ATT(NCID,VARID(6),'standard_name','sea_surface_wave_to_direction') + IRET=NF90_PUT_ATT(NCID,VARID(6),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(6),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(6),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(6),'axis','Z') + + IF (FLAGLL) THEN + ! longitude + IRET=NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, (/DIMID(1)/),VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','longitude') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','longitude') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','degree_east') + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-180.0) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',360.) + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time') + + + ! latitude + IRET=NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, (/DIMID(1)/),VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','latitude') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','latitude') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','degree_north') + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',-90.0) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',180.) + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time') + ELSE + ! longitude + IRET=NF90_DEF_VAR(NCID, 'x', NF90_FLOAT, (/DIMID(1)/),VARID(7)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(7), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','x') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','x') + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(7),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time') + + ! latitude + IRET=NF90_DEF_VAR(NCID, 'y', NF90_FLOAT, (/DIMID(1)/),VARID(8)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(8), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','y') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','y') + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(8),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time') + + END IF + + + ! Efth + IRET=NF90_DEF_VAR(NCID,'efth',NF90_FLOAT,(/DIMID(3),DIMID(2),DIMID(1)/),VARID(9)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(9), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(9),'long_name', & 'sea surface wave directional variance spectral density') - IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name', & + IRET=NF90_PUT_ATT(NCID,VARID(9),'standard_name', & 'sea_surface_wave_directional_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name', & + IRET=NF90_PUT_ATT(NCID,VARID(9),'globwave_name', & 'directional_variance_spectral_density') - IRET=NF90_PUT_ATT(NCID,VARID(9),'units','m2 s rad-1') - IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',10.) - IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TYZ') - IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time frequency direction') - -! DW - depth - IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/DIMID(1)/),VARID(10)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','depth') - IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m') - IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(10),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time') - -! CAO - current speed (m/s) - IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT,(/DIMID(1)/), VARID(11)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','sea water speed') - IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','sea_water_speed') - IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','sea_water_speed') - IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(11),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time') - -! CDO - current direction (degree) - IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_FLOAT,(/DIMID(1)/), VARID(12)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','direction from of sea water velocity') - IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','direction_of_sea_water_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','direction_of_sea_water_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(12),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(12),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time') - -! WAO - wind speed (m/s) - IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT,(/DIMID(1)/), VARID(13)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','wind speed at 10m') - IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','wind_speed') - IRET=NF90_PUT_ATT(NCID,VARID(13),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(13),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time') - -! WDO - wind direction (degree) - IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT,(/DIMID(1)/), VARID(14)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','wind direction') - IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','wind_from_direction') - IRET=NF90_PUT_ATT(NCID,VARID(14),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(14),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time') - -! UST - friction velocity (m/s) - IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT,(/DIMID(1)/), VARID(15)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','friction velocity') - IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','friction_velocity') - IRET=NF90_PUT_ATT(NCID,VARID(15),'units','m s-1') - IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(15),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time') - -! AS - air-sea temperature difference (deg C) - IRET=NF90_DEF_VAR(NCID, 'ast',NF90_FLOAT,(/DIMID(1)/), VARID(16)) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(16), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','air sea temperature difference') - IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','air_sea_temperature_difference') - IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','air_sea_temperature_difference') - IRET=NF90_PUT_ATT(NCID,VARID(16),'units','degree') - IRET=NF90_PUT_ATT(NCID,VARID(16),'scale_factor',1.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'add_offset',0.) - IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue',NF90_FILL_FLOAT) - IRET=NF90_PUT_ATT(NCID,VARID(16),'content','T') - IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time') - -! string32 - IRET=NF90_DEF_VAR(NCID, 'string32', NF90_INT, (/DIMID(4)/), VARID(17)) - CALL CHECK_ERR(IRET) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(17), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(17),'long_name','track_name number of characters') - IRET=NF90_PUT_ATT(NCID,VARID(17),'_FillValue',NF90_FILL_INT) - IRET=NF90_PUT_ATT(NCID,VARID(17),'axis','W') - -! track_name - IRET=NF90_DEF_VAR(NCID, 'track_name', NF90_CHAR, (/DIMID(4),DIMID(1)/), VARID(18)) - CALL CHECK_ERR(IRET) - IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(18), 1, 1, DEFLATE) - IRET=NF90_PUT_ATT(NCID,VARID(18),'long_name','track name') - IRET=NF90_PUT_ATT(NCID,VARID(18),'content','TX') - IRET=NF90_PUT_ATT(NCID,VARID(18),'associates','time string16') - - RETURN - - END SUBROUTINE W3CRNC - -!============================================================================== -!> -!> @brief Desc not available. -!> -!> @param IRET -!> @author NA @date NA -!> - SUBROUTINE CHECK_ERR(IRET) - - USE NETCDF - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - - IMPLICIT NONE - - INTEGER IRET - - IF (IRET .NE. NF90_NOERR) THEN - WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN TRNC :' - WRITE(NDSE,*) ' NETCDF ERROR MESSAGE: ' - WRITE(NDSE,*) NF90_STRERROR(IRET) - CALL EXTCDE ( 59 ) - END IF - RETURN - - END SUBROUTINE CHECK_ERR - -!============================================================================== - - -!/ -!/ End of W3TRNC ----------------------------------------------------- / -!/ - END PROGRAM W3TRNC - - - - + IRET=NF90_PUT_ATT(NCID,VARID(9),'units','m2 s rad-1') + IRET=NF90_PUT_ATT(NCID,VARID(9),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_min',0.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',10.) + IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TYZ') + IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time frequency direction') + + ! DW - depth + IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/DIMID(1)/),VARID(10)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(10), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(10),'long_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(10),'standard_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(10),'globwave_name','depth') + IRET=NF90_PUT_ATT(NCID,VARID(10),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(10),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(10),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time') + + ! CAO - current speed (m/s) + IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT,(/DIMID(1)/), VARID(11)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','sea water speed') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','sea_water_speed') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','sea_water_speed') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time') + + ! CDO - current direction (degree) + IRET=NF90_DEF_VAR(NCID, 'curdir', NF90_FLOAT,(/DIMID(1)/), VARID(12)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(12), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(12),'long_name','direction from of sea water velocity') + IRET=NF90_PUT_ATT(NCID,VARID(12),'standard_name','direction_of_sea_water_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(12),'globwave_name','direction_of_sea_water_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(12),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(12),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(12),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time') + + ! WAO - wind speed (m/s) + IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT,(/DIMID(1)/), VARID(13)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(13), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(13),'long_name','wind speed at 10m') + IRET=NF90_PUT_ATT(NCID,VARID(13),'standard_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(13),'globwave_name','wind_speed') + IRET=NF90_PUT_ATT(NCID,VARID(13),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(13),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(13),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time') + + ! WDO - wind direction (degree) + IRET=NF90_DEF_VAR(NCID, 'wnddir', NF90_FLOAT,(/DIMID(1)/), VARID(14)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(14), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(14),'long_name','wind direction') + IRET=NF90_PUT_ATT(NCID,VARID(14),'standard_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(14),'globwave_name','wind_from_direction') + IRET=NF90_PUT_ATT(NCID,VARID(14),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(14),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(14),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time') + + ! UST - friction velocity (m/s) + IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT,(/DIMID(1)/), VARID(15)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(15), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(15),'long_name','friction velocity') + IRET=NF90_PUT_ATT(NCID,VARID(15),'standard_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(15),'globwave_name','friction_velocity') + IRET=NF90_PUT_ATT(NCID,VARID(15),'units','m s-1') + IRET=NF90_PUT_ATT(NCID,VARID(15),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(15),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time') + + ! AS - air-sea temperature difference (deg C) + IRET=NF90_DEF_VAR(NCID, 'ast',NF90_FLOAT,(/DIMID(1)/), VARID(16)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(16), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(16),'long_name','air sea temperature difference') + IRET=NF90_PUT_ATT(NCID,VARID(16),'standard_name','air_sea_temperature_difference') + IRET=NF90_PUT_ATT(NCID,VARID(16),'globwave_name','air_sea_temperature_difference') + IRET=NF90_PUT_ATT(NCID,VARID(16),'units','degree') + IRET=NF90_PUT_ATT(NCID,VARID(16),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(16),'content','T') + IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time') + + ! string32 + IRET=NF90_DEF_VAR(NCID, 'string32', NF90_INT, (/DIMID(4)/), VARID(17)) + CALL CHECK_ERR(IRET) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(17), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(17),'long_name','track_name number of characters') + IRET=NF90_PUT_ATT(NCID,VARID(17),'_FillValue',NF90_FILL_INT) + IRET=NF90_PUT_ATT(NCID,VARID(17),'axis','W') + + ! track_name + IRET=NF90_DEF_VAR(NCID, 'track_name', NF90_CHAR, (/DIMID(4),DIMID(1)/), VARID(18)) + CALL CHECK_ERR(IRET) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(18), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(18),'long_name','track name') + IRET=NF90_PUT_ATT(NCID,VARID(18),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(18),'associates','time string16') + + RETURN + + END SUBROUTINE W3CRNC + + !============================================================================== + !> + !> @brief Desc not available. + !> + !> @param IRET + !> @author NA @date NA + !> + SUBROUTINE CHECK_ERR(IRET) + + USE NETCDF + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + + IMPLICIT NONE + + INTEGER IRET + + IF (IRET .NE. NF90_NOERR) THEN + WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN TRNC :' + WRITE(NDSE,*) ' NETCDF ERROR MESSAGE: ' + WRITE(NDSE,*) NF90_STRERROR(IRET) + CALL EXTCDE ( 59 ) + END IF + RETURN + + END SUBROUTINE CHECK_ERR + + !============================================================================== + + + !/ + !/ End of W3TRNC ----------------------------------------------------- / + !/ +END PROGRAM W3TRNC diff --git a/model/src/ww3_uprstr.F90 b/model/src/ww3_uprstr.F90 index 28ddbd9ac..f885cf715 100644 --- a/model/src/ww3_uprstr.F90 +++ b/model/src/ww3_uprstr.F90 @@ -8,2218 +8,2218 @@ !> !> @brief Update restart files based on Hs from DA. !> -!> @details Update the WAVEWATCH III restart files based on the significant +!> @details Update the WAVEWATCH III restart files based on the significant !> wave height analysis from any data assimilation system. !> !> The W3UPRSTR is the intermediator between the background WW3 -!> and the analysis of the wave field, it modifies the original restart +!> and the analysis of the wave field, it modifies the original restart !> file according to the analysis. -!> For the wave modeling and DA, the ww3_uprstr program applies the +!> For the wave modeling and DA, the ww3_uprstr program applies the !> operator from the diagnostic to the prognostic variable. !> !> @author Stelios Flampouris @date 16-Feb-2017 !> - PROGRAM W3UPRSTR -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Stelios Flampouris | -!/ | FORTRAN 90 | -!/ | First version: 16-Feb-2017 | -!/ +-----------------------------------+ -!/ -!/ 16-Feb-2017 : Original Code ( version 6.03 ) -!/ 07-Jun-2017 : Change of the Core -!/ 07-Jul-2017 : Clean the code, add some flexibility, etc -!/ 04-Sep-2017 : Simplified the code, take out a significant part of the -!/ flexibility (The code is still available at SVN/UpRest) -!/ 15-Sep-2017 : Version 0.65 ( version 6.03 ) -!/ 01-Oct-2018 : Fixes to preserve spectral energy correctly -!/ (Andy Saulter) ( version 6.06 ) -!/ 17-Oct-2018 : Version 0.95 ( version 6.06 ) -!/ Simplified the code, remove some user unfriendly -!/ options, add reg test ta1, add logical checks, -!/ unified the operator, add/update the documentation. -!/ 05-Oct-2019 : Added UPD5 and UPD6 options, plus logic for running -!/ with SMC grids (Andy Saulter) ( version 6.07 ) -!/ 01-Nov-2019 : UPD5 and UPD6 use wind data either from anl.XXX file -!/ or from restart under WRST switch (Andy Saulter) -!/ 06-Oct-2020 : Added namelist input options ( version 7.11 ) -!/ 06-May-2021 : Use SMCTYPE and FSWND for SMC grid. ( version 7.13 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Update the WAVEWATCH III restart files based on the significant -! wave height analysis from any data assimilation system. -! -! 2. Method : -! -! 2.1. General: -! The W3UPRSTR is the intermediator between the background WW3 -! and the analysis of the wave field, it modifies the original restart -! file according to the analysis. -! For the wave modeling and DA, the ww3_uprstr program applies the -! operator from the diagnostic to the prognostic variable. -! -! See the chart below: -! -! +-------------------+ -! | WW3 Background Run| -! +-------------------+ -! +--------------+ | +-----+ -! | Restart File | <------------|-----------------> | Hs | -! +--------------+ +-----+ -! | | -! | | -! | +---------------+ +-----+ -! | |Hs Observations|-------> | D.A.| -! | +---------------+ +-----+ -! | | -! | +----------+ | -! +----------------> | W3UPRSTR |<-/Analysis/--+ -! +----------+ -! | -! +----------------------+ -! | Updated Restart File | -! +----------------------+ -! -! A. The WW3 Background Run has to provide two files: -! i. The field of Hs (for NCEP at grib2 format) and -! ii. the restart.ww3, at the WW3 format for restart files. -! Both of them, at the moment of the assimilation (Nevertheless, the WW3 -! restart reader will fail when the timestamps are not identical). -! -! B. The DA module produces the analysis and/or the difference (%) of -! the analysis from the first guess of Hs in the space of model and -! exports the results. -! -! C. The algorithm -! The Hs correction is redistributed to each frequency and direction. -! -! 1. The W3UPRSTR imports: i. the restart.ww3, -! ii. the analysis file and -! iii. the input file: ww3_uprstr.inp, details at 2.2.2.i. -! -! 2. The W3UPRSTR updates the restart file according to the option at -! ww3_uprstr UPD[N] -! Note: With the version 6.06 some options have been removed, but the naming -! is consistent with the original version. -! -! 3. W3UPRSTR exports the updated spectrum in the same format as the -! restart.ww3. The name of the output file is: restart001.ww3 and it has to -! be renamed "restart.ww3" for the initialization of the next prediction -! cycle. -! -! E. The user runs WW3 with the analysis restart file. -! -! 2.2. How to use ww3_uprstr -! The ww3_uperstr is one of the WW3 auxilary programs, therefore it works in -! a very similar way as the other auxilary programs. -! -! A. To compile: -! -! ww3_uprstr is included in the make_makefile.sh, to compile: -! $ ./w3_make ww3_uprstr -! or -! $ ./w3_make -! -! And the executable "ww3_uprstr" will appear at [...]/model/exe/ -! -! B. To run: -! At the computational path: -! > ${EXE}/ww3_uprstr -! And it should run if the input files are at ./ -! -! C. Input Files: -! -! i. ww3_uprstr.inp -! It includes some limited information for running the program: -! -! -------------------------------------------------------------------- $ -! WAVEWATCH III Update Restart input file $ -! -------------------------------------------------------------------- $ -! -! Time of Assimilation ----------------------------------------------- $ -! - Starting time in yyyymmdd hhmmss format. -! -! This is the assimilation starting time and has to be the same with -! the time at the restart.ww3. -! -! 19680607 120000 -! -! Choose algorithm to update restart file -! UPDN for the Nth approach -! The UPDN*, with N<2 the same correction factor is applied at all the grid points -! UPD0C:: ELIMINATED -! UPDOF:: Option 0F All the spectra are updated with a constant -! fac=HsAnl/HsBckg. -! Expected input: PRCNTG, as defined at fac -! UPD1 :: ELIMINATED -! UPDN, with N>1 each gridpoint has its own update factor. -! UPD2 :: Option 2 The fac(x,y,frq,theta), is calculated at each grid point -! according to the ratio of HsBckg and HsAnl (squared to preseve energy) -! Expected input: the Analysis field, grbtxt format -! UPD3 :: Option 3 The update factor is a surface with the shape of -! the background spectrum. -! Expected input: the Analysis field, grbtxt format -! UPD4 :: [NOT INCLUDED in this Version, Just keeping the spot] -! Option 4 The generalization of the UPD3. The update factor -! is the sum of surfaces which are applied on the background -! spectrum. -! The algorithm requires the mapping of each partition on the -! individual spectra; the map is used to determine the weighting -! surfaces. -! Expected input: the Analysis field, grbtxt format and the -! functions(frq,theta) of the update to be applied. -! UPD5 :: Option 5 Corrections are calculated as per UPD2 but are -! applied to wind-sea parts of the spectrum only when wind-sea -! is the dominant component, otherwise the whole spectrum is -! corrected -! Expected input: the Analysis Hs field plus background wind speed -! and direction -! UPD6 :: Option 6 Corrections are calculated as per UPD5 but wind-sea -! components are also shifted in frequency space using Toba (1973) -! Expected input: the Analysis Hs field plus background wind speed -! and direction -! -! PRCNTG is input for option UPD0F and is the correction factor -! applied to all the gridpoints (e.g. 1.) -! -! 0.475 -! -! PRCNTG_CAP is global input for option UPD2 and UPD3 and it is a cap on -! the maximum SWH correction factor applied to all the gridpoints, as -! both a multiple or divisor (e.g. cap at 5.0 means SWHANL/SWHBKG<=5.0 -! and SWHANL/SWHBKG>=0.2). The value given should not be less than 1.0 -! -! 5.0 -! -! Name of the file with the SWH analysis from the DA system $ -! suffix .grbtxt for text out of grib2 file. $ -! -! anl.grbtxt -! -! -------------------------------------------------------------------- $ -! WAVEWATCH III EoF ww3_uprstr.inp -! -------------------------------------------------------------------- $ -! -! ii. Data files anl.XXX -! -! FOR UPD2,3 and UPD5,6 with WRST switch -! USE THE grbtxt FORMAT, See Format E. -! -! Format E. -! Text file created by wgrib2. This format is tested more extensively -! and currently the only format supported for anl.grbtxt. -! -! NX NY -! VAL0001 -! VAL0002 -! ... -! VALNX*NY -! -! IMPORTANT : All the regtests are with the format E. strongly recommended. -! The order of the values in .grbtxt, is assumed the same by -! default as the order of spectral data in the restart file. -! -! NOTE: It is recommended to use UPD5,6 with the WRST switch enabled and -! using SWH analysis data only as per Format E. However, the code includes -! an option to run using a text file in which case: -! USE THE grbtxtws format below -! -! Text file with following lines: -! NX NY -! SWH0001 WSPD0001 WDIR0001 -! SWH0002 WSPD0002 WDIR0002 -! ... -! SWHNX*NY WSPDNX*NY WDIRNX*NY -! -! The order of the values in .grbtxt, is assumed the same by -! default as the order of spectral data in the restart file. -! Wind speeds and directions in the anl.XXX file are assumed to be -! in CARTESIAN (GRID U,V) CONVENTION -! -! NOTE About Format: if you prefer a different format; there are several -! I/O subroutines ready, not included in the current version of the code, -! contact the prgmr to get access to the source code. -! -! iii. restart.ww3 -! The restart file as came out of the background run, the name has to be -! restart.ww3, but the name of the output depends on the mod_def.ww3, the -! ww3_uprstr follows its content (be careful with ovewriting). -! -! 3. Example -! Use the regression tests ww3_ta1 -! -! 4. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! -! ---------------------------------------------------------------- -! -! 5. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3NDAT Subr. W3WDATMD Set number of model for wave data. -! W3SETW Subr. Id. Point to selected model for wave data. -! W3NINP Subr. W3IDATMD Set number of grids/models. -! W3SETI Subr. Id. Point to data structure. -! W3DIMI Subr. Id. Set array sizes in data structure. -! W2NAUX Subr. W3ADATMD Set number of model for aux data. -! W3SETA Subr. Id. Point to selected model for aux data. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! NEXTLN Subr. Id. Get next line from input file. -! EXTCDE Subr. Id. Abort program as graceful as possible. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! WAVNU1 Subr. W3DISPMD +PROGRAM W3UPRSTR + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Stelios Flampouris | + !/ | FORTRAN 90 | + !/ | First version: 16-Feb-2017 | + !/ +-----------------------------------+ + !/ + !/ 16-Feb-2017 : Original Code ( version 6.03 ) + !/ 07-Jun-2017 : Change of the Core + !/ 07-Jul-2017 : Clean the code, add some flexibility, etc + !/ 04-Sep-2017 : Simplified the code, take out a significant part of the + !/ flexibility (The code is still available at SVN/UpRest) + !/ 15-Sep-2017 : Version 0.65 ( version 6.03 ) + !/ 01-Oct-2018 : Fixes to preserve spectral energy correctly + !/ (Andy Saulter) ( version 6.06 ) + !/ 17-Oct-2018 : Version 0.95 ( version 6.06 ) + !/ Simplified the code, remove some user unfriendly + !/ options, add reg test ta1, add logical checks, + !/ unified the operator, add/update the documentation. + !/ 05-Oct-2019 : Added UPD5 and UPD6 options, plus logic for running + !/ with SMC grids (Andy Saulter) ( version 6.07 ) + !/ 01-Nov-2019 : UPD5 and UPD6 use wind data either from anl.XXX file + !/ or from restart under WRST switch (Andy Saulter) + !/ 06-Oct-2020 : Added namelist input options ( version 7.11 ) + !/ 06-May-2021 : Use SMCTYPE and FSWND for SMC grid. ( version 7.13 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Update the WAVEWATCH III restart files based on the significant + ! wave height analysis from any data assimilation system. + ! + ! 2. Method : + ! + ! 2.1. General: + ! The W3UPRSTR is the intermediator between the background WW3 + ! and the analysis of the wave field, it modifies the original restart + ! file according to the analysis. + ! For the wave modeling and DA, the ww3_uprstr program applies the + ! operator from the diagnostic to the prognostic variable. + ! + ! See the chart below: + ! + ! +-------------------+ + ! | WW3 Background Run| + ! +-------------------+ + ! +--------------+ | +-----+ + ! | Restart File | <------------|-----------------> | Hs | + ! +--------------+ +-----+ + ! | | + ! | | + ! | +---------------+ +-----+ + ! | |Hs Observations|-------> | D.A.| + ! | +---------------+ +-----+ + ! | | + ! | +----------+ | + ! +----------------> | W3UPRSTR |<-/Analysis/--+ + ! +----------+ + ! | + ! +----------------------+ + ! | Updated Restart File | + ! +----------------------+ + ! + ! A. The WW3 Background Run has to provide two files: + ! i. The field of Hs (for NCEP at grib2 format) and + ! ii. the restart.ww3, at the WW3 format for restart files. + ! Both of them, at the moment of the assimilation (Nevertheless, the WW3 + ! restart reader will fail when the timestamps are not identical). + ! + ! B. The DA module produces the analysis and/or the difference (%) of + ! the analysis from the first guess of Hs in the space of model and + ! exports the results. + ! + ! C. The algorithm + ! The Hs correction is redistributed to each frequency and direction. + ! + ! 1. The W3UPRSTR imports: i. the restart.ww3, + ! ii. the analysis file and + ! iii. the input file: ww3_uprstr.inp, details at 2.2.2.i. + ! + ! 2. The W3UPRSTR updates the restart file according to the option at + ! ww3_uprstr UPD[N] + ! Note: With the version 6.06 some options have been removed, but the naming + ! is consistent with the original version. + ! + ! 3. W3UPRSTR exports the updated spectrum in the same format as the + ! restart.ww3. The name of the output file is: restart001.ww3 and it has to + ! be renamed "restart.ww3" for the initialization of the next prediction + ! cycle. + ! + ! E. The user runs WW3 with the analysis restart file. + ! + ! 2.2. How to use ww3_uprstr + ! The ww3_uperstr is one of the WW3 auxilary programs, therefore it works in + ! a very similar way as the other auxilary programs. + ! + ! A. To compile: + ! + ! ww3_uprstr is included in the make_makefile.sh, to compile: + ! $ ./w3_make ww3_uprstr + ! or + ! $ ./w3_make + ! + ! And the executable "ww3_uprstr" will appear at [...]/model/exe/ + ! + ! B. To run: + ! At the computational path: + ! > ${EXE}/ww3_uprstr + ! And it should run if the input files are at ./ + ! + ! C. Input Files: + ! + ! i. ww3_uprstr.inp + ! It includes some limited information for running the program: + ! + ! -------------------------------------------------------------------- $ + ! WAVEWATCH III Update Restart input file $ + ! -------------------------------------------------------------------- $ + ! + ! Time of Assimilation ----------------------------------------------- $ + ! - Starting time in yyyymmdd hhmmss format. + ! + ! This is the assimilation starting time and has to be the same with + ! the time at the restart.ww3. + ! + ! 19680607 120000 + ! + ! Choose algorithm to update restart file + ! UPDN for the Nth approach + ! The UPDN*, with N<2 the same correction factor is applied at all the grid points + ! UPD0C:: ELIMINATED + ! UPDOF:: Option 0F All the spectra are updated with a constant + ! fac=HsAnl/HsBckg. + ! Expected input: PRCNTG, as defined at fac + ! UPD1 :: ELIMINATED + ! UPDN, with N>1 each gridpoint has its own update factor. + ! UPD2 :: Option 2 The fac(x,y,frq,theta), is calculated at each grid point + ! according to the ratio of HsBckg and HsAnl (squared to preseve energy) + ! Expected input: the Analysis field, grbtxt format + ! UPD3 :: Option 3 The update factor is a surface with the shape of + ! the background spectrum. + ! Expected input: the Analysis field, grbtxt format + ! UPD4 :: [NOT INCLUDED in this Version, Just keeping the spot] + ! Option 4 The generalization of the UPD3. The update factor + ! is the sum of surfaces which are applied on the background + ! spectrum. + ! The algorithm requires the mapping of each partition on the + ! individual spectra; the map is used to determine the weighting + ! surfaces. + ! Expected input: the Analysis field, grbtxt format and the + ! functions(frq,theta) of the update to be applied. + ! UPD5 :: Option 5 Corrections are calculated as per UPD2 but are + ! applied to wind-sea parts of the spectrum only when wind-sea + ! is the dominant component, otherwise the whole spectrum is + ! corrected + ! Expected input: the Analysis Hs field plus background wind speed + ! and direction + ! UPD6 :: Option 6 Corrections are calculated as per UPD5 but wind-sea + ! components are also shifted in frequency space using Toba (1973) + ! Expected input: the Analysis Hs field plus background wind speed + ! and direction + ! + ! PRCNTG is input for option UPD0F and is the correction factor + ! applied to all the gridpoints (e.g. 1.) + ! + ! 0.475 + ! + ! PRCNTG_CAP is global input for option UPD2 and UPD3 and it is a cap on + ! the maximum SWH correction factor applied to all the gridpoints, as + ! both a multiple or divisor (e.g. cap at 5.0 means SWHANL/SWHBKG<=5.0 + ! and SWHANL/SWHBKG>=0.2). The value given should not be less than 1.0 + ! + ! 5.0 + ! + ! Name of the file with the SWH analysis from the DA system $ + ! suffix .grbtxt for text out of grib2 file. $ + ! + ! anl.grbtxt + ! + ! -------------------------------------------------------------------- $ + ! WAVEWATCH III EoF ww3_uprstr.inp + ! -------------------------------------------------------------------- $ + ! + ! ii. Data files anl.XXX + ! + ! FOR UPD2,3 and UPD5,6 with WRST switch + ! USE THE grbtxt FORMAT, See Format E. + ! + ! Format E. + ! Text file created by wgrib2. This format is tested more extensively + ! and currently the only format supported for anl.grbtxt. + ! + ! NX NY + ! VAL0001 + ! VAL0002 + ! ... + ! VALNX*NY + ! + ! IMPORTANT : All the regtests are with the format E. strongly recommended. + ! The order of the values in .grbtxt, is assumed the same by + ! default as the order of spectral data in the restart file. + ! + ! NOTE: It is recommended to use UPD5,6 with the WRST switch enabled and + ! using SWH analysis data only as per Format E. However, the code includes + ! an option to run using a text file in which case: + ! USE THE grbtxtws format below + ! + ! Text file with following lines: + ! NX NY + ! SWH0001 WSPD0001 WDIR0001 + ! SWH0002 WSPD0002 WDIR0002 + ! ... + ! SWHNX*NY WSPDNX*NY WDIRNX*NY + ! + ! The order of the values in .grbtxt, is assumed the same by + ! default as the order of spectral data in the restart file. + ! Wind speeds and directions in the anl.XXX file are assumed to be + ! in CARTESIAN (GRID U,V) CONVENTION + ! + ! NOTE About Format: if you prefer a different format; there are several + ! I/O subroutines ready, not included in the current version of the code, + ! contact the prgmr to get access to the source code. + ! + ! iii. restart.ww3 + ! The restart file as came out of the background run, the name has to be + ! restart.ww3, but the name of the output depends on the mod_def.ww3, the + ! ww3_uprstr follows its content (be careful with ovewriting). + ! + ! 3. Example + ! Use the regression tests ww3_ta1 + ! + ! 4. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! ---------------------------------------------------------------- + ! + ! 5. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. W3GDATMD Set number of model. + ! W3SETG Subr. Id. Point to selected model. + ! W3NDAT Subr. W3WDATMD Set number of model for wave data. + ! W3SETW Subr. Id. Point to selected model for wave data. + ! W3NINP Subr. W3IDATMD Set number of grids/models. + ! W3SETI Subr. Id. Point to data structure. + ! W3DIMI Subr. Id. Set array sizes in data structure. + ! W2NAUX Subr. W3ADATMD Set number of model for aux data. + ! W3SETA Subr. Id. Point to selected model for aux data. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! NEXTLN Subr. Id. Get next line from input file. + ! EXTCDE Subr. Id. Abort program as graceful as possible. + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! WAVNU1 Subr. W3DISPMD -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! READ_GRBTXT -! WORKER -! SWH_RSRT_1p -! WRITEMATRIX -! -! 6. Called by : -! -! None, stand-alone program. -! -! 7. Error messages : -! -! 8. Remarks: -! -! 7.1 Use the grbtxt format for correction and analysis files. -! -! 7.2 There are some variables not used but declared, it's for future -! development. -! -! 9. Structure : -! -! ---------------------------------------------------- -! 1. Set up data structures. -! 2. Read model defintion file with base model ( W3IOGR ) -! 3. Import restart file ( W3IORS ) -! 4. Import correction percentage ( ) -! OR Import the analysis field ( ) -! 5. Apply correction to the restart file ( ) -! 6. Export the updated restart file ( W3IORS ) -! ---------------------------------------------------- -! -! 10. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/T -! !/S Enable subroutine tracing. -! -! 11. Known Bugs -! -! 1. Fix the format for the output (NSDO) of non strings, e.g. for -! TIME. -! -! 12. Source code : -! -!/ - USE W3GDATMD, ONLY: W3NMOD, W3SETG - USE W3WDATMD, ONLY: W3NDAT, W3SETW - USE W3ADATMD, ONLY: W3NAUX, W3SETA - USE W3ODATMD, ONLY: W3NOUT, W3SETO - USE W3IORSMD, ONLY: W3IORS - USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE - USE W3IOGRMD, ONLY: W3IOGR - USE W3DISPMD, ONLY: WAVNU1 -! - USE W3GDATMD, ONLY: GNAME, NX, NY, MAPSTA, SIG, NK, NTH, NSEA, & - NSEAL, MAPSF, DMIN, ZB, DSIP, DTH, RSTYPE, & - GTYPE, SMCTYPE + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! READ_GRBTXT + ! WORKER + ! SWH_RSRT_1p + ! WRITEMATRIX + ! + ! 6. Called by : + ! + ! None, stand-alone program. + ! + ! 7. Error messages : + ! + ! 8. Remarks: + ! + ! 7.1 Use the grbtxt format for correction and analysis files. + ! + ! 7.2 There are some variables not used but declared, it's for future + ! development. + ! + ! 9. Structure : + ! + ! ---------------------------------------------------- + ! 1. Set up data structures. + ! 2. Read model defintion file with base model ( W3IOGR ) + ! 3. Import restart file ( W3IORS ) + ! 4. Import correction percentage ( ) + ! OR Import the analysis field ( ) + ! 5. Apply correction to the restart file ( ) + ! 6. Export the updated restart file ( W3IORS ) + ! ---------------------------------------------------- + ! + ! 10. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/T + ! !/S Enable subroutine tracing. + ! + ! 11. Known Bugs + ! + ! 1. Fix the format for the output (NSDO) of non strings, e.g. for + ! TIME. + ! + ! 12. Source code : + ! + !/ + USE W3GDATMD, ONLY: W3NMOD, W3SETG + USE W3WDATMD, ONLY: W3NDAT, W3SETW + USE W3ADATMD, ONLY: W3NAUX, W3SETA + USE W3ODATMD, ONLY: W3NOUT, W3SETO + USE W3IORSMD, ONLY: W3IORS + USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE + USE W3IOGRMD, ONLY: W3IOGR + USE W3DISPMD, ONLY: WAVNU1 + ! + USE W3GDATMD, ONLY: GNAME, NX, NY, MAPSTA, SIG, NK, NTH, NSEA, & + NSEAL, MAPSF, DMIN, ZB, DSIP, DTH, RSTYPE, & + GTYPE, SMCTYPE #ifdef W3_SMC - USE W3GDATMD, ONLY: FSWND + USE W3GDATMD, ONLY: FSWND #endif - USE W3WDATMD, ONLY: VA, TIME - USE W3ADATMD, ONLY: NSEALM - USE W3ODATMD, ONLY: IAPROC, NAPERR, NAPLOG, NDS, NAPOUT - USE W3ODATMD, ONLY: NDSE, NDSO, NDST, IDOUT, FNMPRE + USE W3WDATMD, ONLY: VA, TIME + USE W3ADATMD, ONLY: NSEALM + USE W3ODATMD, ONLY: IAPROC, NAPERR, NAPLOG, NDS, NAPOUT + USE W3ODATMD, ONLY: NDSE, NDSO, NDST, IDOUT, FNMPRE #ifdef W3_WRST - USE W3IDATMD -#endif -! - USE W3NMLUPRSTRMD -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -! Local variables -!/ - INTEGER :: NDSI, NDSM, NDSTRC, NTRACE, IERR, I, J - CHARACTER :: COMSTR*1 -! - TYPE(NML_RESTART_T) :: NML_RESTART - TYPE(NML_UPDATE_T) :: NML_UPDATE -! -! REAL, ALLOCATABLE :: BETAW(:) -! LOGICAL, ALLOCATABLE :: MASK(:) - LOGICAL :: anl_exists, CORWSEA, FLGNML - INTEGER :: IMOD, NDSEN, IX, IY, IK, ITH, & - IXW, IYW - REAL, ALLOCATABLE :: UPDPRCNT(:,:),VATMP(:), HSIG(:,:), & - A(:), HS_ANAL(:,:), gues(:,:), & - HS_DIF(:,:),SWHANL(:,:), SWHBCKG(:,:), & - SWHUPRSTR(:,:),VATMP_NORM(:), & - WSBCKG(:,:),WDRBCKG(:,:) - INTEGER, ALLOCATABLE :: VAMAPWS(:) - REAL :: PRCNTG, PRCNTG_CAP, THRWSEA - INTEGER :: ROWS, COLS, ISEA - CHARACTER(128) :: FLNMCOR, FLNMANL - CHARACTER(16) :: UPDPROC -! for howv - REAL :: SWHTMP,SWHBCKG_1, SWHANL_1, & - DEPTH, WN, CG, ETOT, E1I, & - SWHTMP1,SUMVATMP, SWHBCKG_W, SWHBCKG_S - REAL :: K - CHARACTER(8), PARAMETER :: MYNAME='W3UPRSTR' - LOGICAL :: SMCGRD = .FALSE. - LOGICAL :: SMCWND = .FALSE. - LOGICAL :: WRSTON = .FALSE. -!/ -!/ ------------------------------------------------------------------- / -!/ -! 1. IO set-up. - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NDAT ( 6, 6 ) - CALL W3SETW ( 1, 6, 6 ) - CALL W3NAUX ( 6, 6 ) - CALL W3SETA ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) + USE W3IDATMD +#endif + ! + USE W3NMLUPRSTRMD + ! + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + ! Local variables + !/ + INTEGER :: NDSI, NDSM, NDSTRC, NTRACE, IERR, I, J + CHARACTER :: COMSTR*1 + ! + TYPE(NML_RESTART_T) :: NML_RESTART + TYPE(NML_UPDATE_T) :: NML_UPDATE + ! + ! REAL, ALLOCATABLE :: BETAW(:) + ! LOGICAL, ALLOCATABLE :: MASK(:) + LOGICAL :: anl_exists, CORWSEA, FLGNML + INTEGER :: IMOD, NDSEN, IX, IY, IK, ITH, & + IXW, IYW + REAL, ALLOCATABLE :: UPDPRCNT(:,:),VATMP(:), HSIG(:,:), & + A(:), HS_ANAL(:,:), gues(:,:), & + HS_DIF(:,:),SWHANL(:,:), SWHBCKG(:,:), & + SWHUPRSTR(:,:),VATMP_NORM(:), & + WSBCKG(:,:),WDRBCKG(:,:) + INTEGER, ALLOCATABLE :: VAMAPWS(:) + REAL :: PRCNTG, PRCNTG_CAP, THRWSEA + INTEGER :: ROWS, COLS, ISEA + CHARACTER(128) :: FLNMCOR, FLNMANL + CHARACTER(16) :: UPDPROC + ! for howv + REAL :: SWHTMP,SWHBCKG_1, SWHANL_1, & + DEPTH, WN, CG, ETOT, E1I, & + SWHTMP1,SUMVATMP, SWHBCKG_W, SWHBCKG_S + REAL :: K + CHARACTER(8), PARAMETER :: MYNAME='W3UPRSTR' + LOGICAL :: SMCGRD = .FALSE. + LOGICAL :: SMCWND = .FALSE. + LOGICAL :: WRSTON = .FALSE. + !/ + !/ ------------------------------------------------------------------- / + !/ + ! 1. IO set-up. + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NDAT ( 6, 6 ) + CALL W3SETW ( 1, 6, 6 ) + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) #ifdef W3_WRST - CALL W3NINP ( 6, 6 ) - CALL W3SETI ( 1, 6, 6 ) -#endif -! - NDSE = 6 - NDSI = 10 - NDSM = 20 -! - IAPROC = 1 - NAPOUT = 1 - NAPERR = 1 - IMOD = 1 - NAPLOG = 1 -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! - IF ( IAPROC .EQ. NAPERR ) THEN - NDSEN = NDSE - ELSE - NDSEN = -1 - END IF -! - WRITE (NDSO,900) -! + CALL W3NINP ( 6, 6 ) + CALL W3SETI ( 1, 6, 6 ) +#endif + ! + NDSE = 6 + NDSI = 10 + NDSM = 20 + ! + IAPROC = 1 + NAPOUT = 1 + NAPERR = 1 + IMOD = 1 + NAPLOG = 1 + ! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) + ! + IF ( IAPROC .EQ. NAPERR ) THEN + NDSEN = NDSE + ELSE + NDSEN = -1 + END IF + ! + WRITE (NDSO,900) + ! #ifdef W3_WRST - !Compiling with WRST will allow access to options UPD5/6 - WRSTON = .TRUE. - WRITE (NDSO,*) '*** UPRSTR will read wind from restart files' + !Compiling with WRST will allow access to options UPD5/6 + WRSTON = .TRUE. + WRITE (NDSO,*) '*** UPRSTR will read wind from restart files' +#endif + !/ + !/ ------------------------------------------------------------------- / + ! 2. Read the ww3_uprstr input data + ! + ! process ww3_uprstr namelist + ! + INQUIRE(FILE=TRIM(FNMPRE)//"ww3_uprstr.nml", EXIST=FLGNML) + IF (FLGNML) THEN + ! Read namelist + CALL W3NMLUPRSTR (NDSI, TRIM(FNMPRE)//'ww3_uprstr.nml', NML_RESTART, & + NML_UPDATE, IERR) + READ(NML_RESTART%RESTARTTIME, *) TIME + UPDPROC = NML_UPDATE%UPDPROC + PRCNTG = NML_UPDATE%PRCNTG + PRCNTG_CAP = NML_UPDATE%PRCNTGCAP + THRWSEA = NML_UPDATE%THRWSEA + FLNMANL = NML_UPDATE%FILE + END IF + !/ + ! otherwise read from the .inp file + IF (.NOT. FLGNML) THEN + J = LEN_TRIM(FNMPRE) + OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_uprstr.inp',STATUS='OLD', & + ERR=800,IOSTAT=IERR) + READ (NDSI,'(A)',END=801,ERR=802) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + ! + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=2001,ERR=2002) TIME + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=2001,ERR=2002) UPDPROC + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + IF (UPDPROC .EQ. 'UPD0F') THEN + READ (NDSI,*,END=2001,ERR=2002) PRCNTG + ELSE + IF ((UPDPROC .EQ. 'UPD2') .OR. (UPDPROC .EQ. 'UPD3')) THEN + ! CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=2001,ERR=2002) PRCNTG_CAP +#ifdef W3_F + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=2001,ERR=2002) FLNMCOR #endif -!/ -!/ ------------------------------------------------------------------- / -! 2. Read the ww3_uprstr input data -! -! process ww3_uprstr namelist -! - INQUIRE(FILE=TRIM(FNMPRE)//"ww3_uprstr.nml", EXIST=FLGNML) - IF (FLGNML) THEN - ! Read namelist - CALL W3NMLUPRSTR (NDSI, TRIM(FNMPRE)//'ww3_uprstr.nml', NML_RESTART, & - NML_UPDATE, IERR) - READ(NML_RESTART%RESTARTTIME, *) TIME - UPDPROC = NML_UPDATE%UPDPROC - PRCNTG = NML_UPDATE%PRCNTG - PRCNTG_CAP = NML_UPDATE%PRCNTGCAP - THRWSEA = NML_UPDATE%THRWSEA - FLNMANL = NML_UPDATE%FILE + ELSE + READ (NDSI,*,END=2001,ERR=2002) PRCNTG_CAP, THRWSEA END IF -!/ -! otherwise read from the .inp file - IF (.NOT. FLGNML) THEN - J = LEN_TRIM(FNMPRE) - OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_uprstr.inp',STATUS='OLD', & - ERR=800,IOSTAT=IERR) - READ (NDSI,'(A)',END=801,ERR=802) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR -! - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=2001,ERR=2002) TIME - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=2001,ERR=2002) UPDPROC - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - IF (UPDPROC .EQ. 'UPD0F') THEN - READ (NDSI,*,END=2001,ERR=2002) PRCNTG - ELSE - IF ((UPDPROC .EQ. 'UPD2') .OR. (UPDPROC .EQ. 'UPD3')) THEN -! CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=2001,ERR=2002) PRCNTG_CAP -#ifdef W3_F - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=2001,ERR=2002) FLNMCOR -#endif - ELSE - READ (NDSI,*,END=2001,ERR=2002) PRCNTG_CAP, THRWSEA - END IF - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*,END=2001,ERR=2002) FLNMANL - END IF - ENDIF + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=2001,ERR=2002) FLNMANL + END IF + ENDIF #ifdef W3_T - WRITE (NDSO,*)' TIME: ',TIME -#endif -!/ -!/ ------------------------------------------------------------------- / -! 3. Read model definition file. -!/ - CALL W3IOGR ( 'READ', NDSM ) - NSEAL = NSEA - WRITE (NDSO,920) GNAME -!/ + WRITE (NDSO,*)' TIME: ',TIME +#endif + !/ + !/ ------------------------------------------------------------------- / + ! 3. Read model definition file. + !/ + CALL W3IOGR ( 'READ', NDSM ) + NSEAL = NSEA + WRITE (NDSO,920) GNAME + !/ #ifdef W3_SMC - !! SMC grid option is activated if GTYPE .EQ. SMCTYPE. JGLi06May2021 - IF( GTYPE .EQ. SMCTYPE ) SMCGRD = .TRUE. - !! SMC sea-point wind option is activated if FSWND=.TRUE. JGLi06May2021 - IF( FSWND ) SMCWND = .TRUE. + !! SMC grid option is activated if GTYPE .EQ. SMCTYPE. JGLi06May2021 + IF( GTYPE .EQ. SMCTYPE ) SMCGRD = .TRUE. + !! SMC sea-point wind option is activated if FSWND=.TRUE. JGLi06May2021 + IF( FSWND ) SMCWND = .TRUE. #endif #ifdef W3_WRST - ! Override SMCWND - at present restarts only store wind on - ! a regular grid - SMCWND = .FALSE. + ! Override SMCWND - at present restarts only store wind on + ! a regular grid + SMCWND = .FALSE. #endif #ifdef W3_SMC - WRITE (NDSO,*) '*** UPRSTR set to work with SMC grid model' + WRITE (NDSO,*) '*** UPRSTR set to work with SMC grid model' #endif -!/ -!/ ------------------------------------------------------------------- / -! 4. Read restart file -!/ + !/ + !/ ------------------------------------------------------------------- / + ! 4. Read restart file + !/ #ifdef W3_WRST - ! Set the wind flag to true when reading restart wind - INFLAGS1(3) = .TRUE. - CALL W3DIMI ( 1, 6, 6 ) !Needs to be called after w3iogr to have correct dimensions? -#endif - CALL W3IORS ( 'READ', NDS(6), SIG(NK), IMOD )! - IF ( IAPROC .EQ. NAPLOG ) THEN - IF (RSTYPE.EQ.0.OR.RSTYPE.EQ.1.OR.RSTYPE.EQ.4) THEN - WRITE (NDSO,1004) 'Terminating ww3_uprstr: The restart ' // & - 'file is not read' - CALL EXTCDE ( 1 ) - ELSE - WRITE (NDSO,1004) ' Updating Restart File' - WRITE (NDSO,*) ' TIME: ',TIME - END IF - END IF + ! Set the wind flag to true when reading restart wind + INFLAGS1(3) = .TRUE. + CALL W3DIMI ( 1, 6, 6 ) !Needs to be called after w3iogr to have correct dimensions? +#endif + CALL W3IORS ( 'READ', NDS(6), SIG(NK), IMOD )! + IF ( IAPROC .EQ. NAPLOG ) THEN + IF (RSTYPE.EQ.0.OR.RSTYPE.EQ.1.OR.RSTYPE.EQ.4) THEN + WRITE (NDSO,1004) 'Terminating ww3_uprstr: The restart ' // & + 'file is not read' + CALL EXTCDE ( 1 ) + ELSE + WRITE (NDSO,1004) ' Updating Restart File' + WRITE (NDSO,*) ' TIME: ',TIME + END IF + END IF #ifdef W3_T - WRITE (NDST,*), MYNAME,' : Exporting VA as imported to VA01.txt' - CALL writeMatrix('VA01.txt', REAL(VA)) -#endif -!/ -!/ ------------------------------------------------------------------- / -! 5. Update restart spectra array according to the selected option -!/ - SELECT CASE (UPDPROC) -!/ -!/ ------------------------------------------------------------------- / -! UPD0F -!/ - CASE ('UPD0F') - WRITE (NDSO,902) 'UPD0F' - WRITE (NDSO,1005) ' PRCNTG = ',PRCNTG + WRITE (NDST,*), MYNAME,' : Exporting VA as imported to VA01.txt' + CALL writeMatrix('VA01.txt', REAL(VA)) +#endif + !/ + !/ ------------------------------------------------------------------- / + ! 5. Update restart spectra array according to the selected option + !/ + SELECT CASE (UPDPROC) + !/ + !/ ------------------------------------------------------------------- / + ! UPD0F + !/ + CASE ('UPD0F') + WRITE (NDSO,902) 'UPD0F' + WRITE (NDSO,1005) ' PRCNTG = ',PRCNTG #ifdef W3_T - ALLOCATE( VATMP (SIZE(VA ,1) )) - ALLOCATE( SWHANL (SIZE(MAPSTA,1), SIZE(MAPSTA,2))) - ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2))) + ALLOCATE( VATMP (SIZE(VA ,1) )) + ALLOCATE( SWHANL (SIZE(MAPSTA,1), SIZE(MAPSTA,2))) + ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2))) #endif - DO ISEA=1, NSEA, 1 + DO ISEA=1, NSEA, 1 #ifdef W3_T - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - VATMP = VA(:,ISEA) - CALL SWH_RSRT_1p (VATMP, ISEA, SWHBCKG_1) - SWHBCKG(IY,IX)=SWHBCKG_1 + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + VATMP = VA(:,ISEA) + CALL SWH_RSRT_1p (VATMP, ISEA, SWHBCKG_1) + SWHBCKG(IY,IX)=SWHBCKG_1 #endif - CALL UPDATE_VA(PRCNTG, VA(:,ISEA)) + CALL UPDATE_VA(PRCNTG, VA(:,ISEA)) #ifdef W3_T - VATMP = VA(:,ISEA) - CALL SWH_RSRT_1p (VATMP, ISEA, SWHANL_1) - SWHANL(IY,IX)=SWHANL_1 - WRITE (NDSO,*) ' =========== UPD0F Output ===========' - WRITE (NDSO,*)'ISEA = ', ISEA,' PRCNTG = ',PRCNTG, & - ' SWHBCKG = ',SWHBCKG(IY,IX), & - ' SWHANL= ', SWHANL(IY,IX) -#endif - END DO + VATMP = VA(:,ISEA) + CALL SWH_RSRT_1p (VATMP, ISEA, SWHANL_1) + SWHANL(IY,IX)=SWHANL_1 + WRITE (NDSO,*) ' =========== UPD0F Output ===========' + WRITE (NDSO,*)'ISEA = ', ISEA,' PRCNTG = ',PRCNTG, & + ' SWHBCKG = ',SWHBCKG(IY,IX), & + ' SWHANL= ', SWHANL(IY,IX) +#endif + END DO #ifdef W3_T - CALL writeMatrix('SWHBCKG_UPD0F.txt', REAL(SWHBCKG)) - CALL writeMatrix('SWHANL_UPD0F.txt' , REAL(SWHANL )) - CALL writeMatrix('SWHRSTR_UPD0F.txt', REAL(SWHANL )) + CALL writeMatrix('SWHBCKG_UPD0F.txt', REAL(SWHBCKG)) + CALL writeMatrix('SWHANL_UPD0F.txt' , REAL(SWHANL )) + CALL writeMatrix('SWHRSTR_UPD0F.txt', REAL(SWHANL )) - DEALLOCATE ( VATMP, SWHBCKG, SWHANL ) -#endif -!/ -!/ ------------------------------------------------------------------- / -! UPD2 -! Apply a bulk correction to the wave spectrum at each grid cell based -! on the ratio of HsBckg and HsAnl -!/ - CASE ('UPD2') - WRITE (NDSO,902) 'UPD2' - WRITE (NDSO,1005) ' PRCNTG_CAP = ',PRCNTG_CAP - WRITE (NDSO,1006) ' Reading updated SWH from: ',trim(FLNMANL) -! -! Array allocation - ALLOCATE ( VATMP(SIZE(VA,1))) - IF (.NOT. SMCGRD) THEN - ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) - ALLOCATE( SWHANL(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + DEALLOCATE ( VATMP, SWHBCKG, SWHANL ) +#endif + !/ + !/ ------------------------------------------------------------------- / + ! UPD2 + ! Apply a bulk correction to the wave spectrum at each grid cell based + ! on the ratio of HsBckg and HsAnl + !/ + CASE ('UPD2') + WRITE (NDSO,902) 'UPD2' + WRITE (NDSO,1005) ' PRCNTG_CAP = ',PRCNTG_CAP + WRITE (NDSO,1006) ' Reading updated SWH from: ',trim(FLNMANL) + ! + ! Array allocation + ALLOCATE ( VATMP(SIZE(VA,1))) + IF (.NOT. SMCGRD) THEN + ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ALLOCATE( SWHANL(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) #ifdef W3_SMC - ELSE - ALLOCATE( SWHBCKG(NSEA,1) ) - ALLOCATE( SWHANL(NSEA,1) ) + ELSE + ALLOCATE( SWHBCKG(NSEA,1) ) + ALLOCATE( SWHANL(NSEA,1) ) #endif - ENDIF + ENDIF #ifdef W3_T - IF (.NOT. SMCGRD) THEN - ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) - ELSE - ALLOCATE( SWHUPRSTR(NSEA,1) ) - ENDIF -#endif -! -! Read additional Input: Analysis Field - INQUIRE(FILE=FLNMANL, EXIST=anl_exists) - IF (anl_exists) THEN + IF (.NOT. SMCGRD) THEN + ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ELSE + ALLOCATE( SWHUPRSTR(NSEA,1) ) + ENDIF +#endif + ! + ! Read additional Input: Analysis Field + INQUIRE(FILE=FLNMANL, EXIST=anl_exists) + IF (anl_exists) THEN #ifdef W3_T - WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) + WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) #endif - CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) + CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) #ifdef W3_T - CALL writeMatrix('SWHANL_IN.txt',SWHANL) + CALL writeMatrix('SWHANL_IN.txt',SWHANL) #endif - ELSE - WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' - DEALLOCATE( SWHANL,VATMP,SWHBCKG ) + ELSE + WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' + DEALLOCATE( SWHANL,VATMP,SWHBCKG ) #ifdef W3_T - DEALLOCATE( SWHUPRSTR ) -#endif - STOP - END IF -! -! Calculation - DO ISEA=1, NSEA, 1 - IF (.NOT. SMCGRD) THEN - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + DEALLOCATE( SWHUPRSTR ) +#endif + STOP + END IF + ! + ! Calculation + DO ISEA=1, NSEA, 1 + IF (.NOT. SMCGRD) THEN + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) #ifdef W3_SMC - ELSE - IX = 1 - IY = ISEA + ELSE + IX = 1 + IY = ISEA #endif - ENDIF - VATMP = VA(:,ISEA) - CALL SWH_RSRT_1p (VATMP, ISEA, SWHBCKG_1) - SWHBCKG(IY,IX)=SWHBCKG_1 -! - IF ( SWHBCKG(IY,IX) > 0.01 .AND. SWHANL(IY,IX) > 0.01 ) THEN - PRCNTG=(SWHANL(IY,IX)/SWHBCKG_1) + ENDIF + VATMP = VA(:,ISEA) + CALL SWH_RSRT_1p (VATMP, ISEA, SWHBCKG_1) + SWHBCKG(IY,IX)=SWHBCKG_1 + ! + IF ( SWHBCKG(IY,IX) > 0.01 .AND. SWHANL(IY,IX) > 0.01 ) THEN + PRCNTG=(SWHANL(IY,IX)/SWHBCKG_1) #ifdef W3_T - WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & - ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & - ' SWHANL = ', SWHANL(IY,IX) + WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & + ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & + ' SWHANL = ', SWHANL(IY,IX) #endif - CALL CHECK_PRCNTG (PRCNTG,PRCNTG_CAP) - CALL UPDATE_VA(PRCNTG, VA(:,ISEA)) + CALL CHECK_PRCNTG (PRCNTG,PRCNTG_CAP) + CALL UPDATE_VA(PRCNTG, VA(:,ISEA)) #ifdef W3_T - CALL SWH_RSRT_1p (VA(:,ISEA), ISEA, SWHUPRSTR(IY,IX)) - WRITE (NDSO,*) ' =========== UPD2 Output ===========' - WRITE (NDSO,*)'ISEA = ',ISEA, & - 'SWH_BCKG = ', SWHBCKG(IY,IX), & - 'SWH_ANL = ', SWHANL(IY,IX), & - 'PRCNTG = ', PRCNTG, & - 'SWH_RSTR = ',SWHUPRSTR(IY,IX) -#endif - END IF - END DO + CALL SWH_RSRT_1p (VA(:,ISEA), ISEA, SWHUPRSTR(IY,IX)) + WRITE (NDSO,*) ' =========== UPD2 Output ===========' + WRITE (NDSO,*)'ISEA = ',ISEA, & + 'SWH_BCKG = ', SWHBCKG(IY,IX), & + 'SWH_ANL = ', SWHANL(IY,IX), & + 'PRCNTG = ', PRCNTG, & + 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#endif + END IF + END DO #ifdef W3_T - CALL writeMatrix('SWHBCKG_UPD2.txt', REAL(SWHBCKG )) - CALL writeMatrix('SWHANL_UPD2.txt' , REAL(SWHANL )) - CALL writeMatrix('SWHRSTR_UPD2.txt', REAL(SWHUPRSTR)) + CALL writeMatrix('SWHBCKG_UPD2.txt', REAL(SWHBCKG )) + CALL writeMatrix('SWHANL_UPD2.txt' , REAL(SWHANL )) + CALL writeMatrix('SWHRSTR_UPD2.txt', REAL(SWHUPRSTR)) #endif -! - DEALLOCATE( SWHANL,VATMP,SWHBCKG ) + ! + DEALLOCATE( SWHANL,VATMP,SWHBCKG ) #ifdef W3_T - DEALLOCATE( SWHUPRSTR ) -#endif -!/ -!/ ------------------------------------------------------------------- / -! UPD3 -! As per UPD2, but the update factor is a surface with the shape of the -! background spectrum -!/ - CASE ('UPD3') - WRITE (NDSO,902) 'UPD3' - WRITE (NDSO,1005) ' PRCNTG_CAP = ',PRCNTG_CAP - WRITE (NDSO,1006) ' Reading updated SWH from: ',trim(FLNMANL) -! -! Array allocation - ALLOCATE ( VATMP(SIZE(VA,1))) - ALLOCATE ( VATMP_NORM(SIZE(VA,1))) - ALLOCATE ( A(SIZE(VA,1))) - IF (.NOT. SMCGRD) THEN - ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) - ALLOCATE( SWHANL(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + DEALLOCATE( SWHUPRSTR ) +#endif + !/ + !/ ------------------------------------------------------------------- / + ! UPD3 + ! As per UPD2, but the update factor is a surface with the shape of the + ! background spectrum + !/ + CASE ('UPD3') + WRITE (NDSO,902) 'UPD3' + WRITE (NDSO,1005) ' PRCNTG_CAP = ',PRCNTG_CAP + WRITE (NDSO,1006) ' Reading updated SWH from: ',trim(FLNMANL) + ! + ! Array allocation + ALLOCATE ( VATMP(SIZE(VA,1))) + ALLOCATE ( VATMP_NORM(SIZE(VA,1))) + ALLOCATE ( A(SIZE(VA,1))) + IF (.NOT. SMCGRD) THEN + ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ALLOCATE( SWHANL(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) #ifdef W3_SMC - ELSE - ALLOCATE( SWHBCKG(NSEA,1) ) - ALLOCATE( SWHANL(NSEA,1) ) + ELSE + ALLOCATE( SWHBCKG(NSEA,1) ) + ALLOCATE( SWHANL(NSEA,1) ) #endif - ENDIF + ENDIF #ifdef W3_T - IF (.NOT. SMCGRD) THEN - ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) - ELSE - ALLOCATE( SWHUPRSTR(NSEA,1) ) - ENDIF -#endif -! -! Read additional Input: Analysis Field - INQUIRE(FILE=FLNMANL, EXIST=anl_exists) - IF (anl_exists) THEN + IF (.NOT. SMCGRD) THEN + ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ELSE + ALLOCATE( SWHUPRSTR(NSEA,1) ) + ENDIF +#endif + ! + ! Read additional Input: Analysis Field + INQUIRE(FILE=FLNMANL, EXIST=anl_exists) + IF (anl_exists) THEN #ifdef W3_T - WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) + WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) #endif - CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) + CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) #ifdef W3_T - CALL writeMatrix('SWHANL_IN.txt',SWHANL) + CALL writeMatrix('SWHANL_IN.txt',SWHANL) #endif - ELSE - WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' - DEALLOCATE( SWHANL,VATMP,SWHBCKG,VATMP_NORM,A ) + ELSE + WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' + DEALLOCATE( SWHANL,VATMP,SWHBCKG,VATMP_NORM,A ) #ifdef W3_T - DEALLOCATE( SWHUPRSTR ) -#endif - STOP - END IF -! -! Calculation - DO ISEA=1, NSEA, 1 - IF (.NOT. SMCGRD) THEN - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + DEALLOCATE( SWHUPRSTR ) +#endif + STOP + END IF + ! + ! Calculation + DO ISEA=1, NSEA, 1 + IF (.NOT. SMCGRD) THEN + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) #ifdef W3_SMC - ELSE - IX = 1 - IY = ISEA + ELSE + IX = 1 + IY = ISEA #endif - ENDIF - VATMP = VA(:,ISEA) - CALL SWH_RSRT_1p (VATMP, ISEA, SWHBCKG_1) - SWHBCKG(IY,IX)=SWHBCKG_1 -! - IF ( SWHBCKG(IY,IX) > 0.01 .AND. SWHANL(IY,IX) > 0.01 ) THEN - !Step 1. - PRCNTG=(SWHANL(IY,IX)/SWHBCKG_1) + ENDIF + VATMP = VA(:,ISEA) + CALL SWH_RSRT_1p (VATMP, ISEA, SWHBCKG_1) + SWHBCKG(IY,IX)=SWHBCKG_1 + ! + IF ( SWHBCKG(IY,IX) > 0.01 .AND. SWHANL(IY,IX) > 0.01 ) THEN + !Step 1. + PRCNTG=(SWHANL(IY,IX)/SWHBCKG_1) #ifdef W3_T - WRITE (NDSO,*) ' =========== Step 1. ===========' - WRITE (NDSO,*) ' ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & - ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & - ' SWHANL = ', SWHANL(IY,IX) + WRITE (NDSO,*) ' =========== Step 1. ===========' + WRITE (NDSO,*) ' ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & + ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & + ' SWHANL = ', SWHANL(IY,IX) #endif - CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) - VATMP_NORM=VATMP/SUM(VATMP) + CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) + VATMP_NORM=VATMP/SUM(VATMP) #ifdef W3_T - WRITE (NDSO,*)' ISEA =', ISEA,' IX = ',IX,' IY = ', IY, & - ' PRCNTG = ',PRCNTG, & - ' SWHBCKG = ',SWHBCKG(IY,IX), ' SWHANL = ', SWHANL(IY,IX) -#endif - IF (PRCNTG > 1.) THEN - A=PRCNTG**2*(1 + VATMP_NORM) - ELSE - A=PRCNTG**2*(1 - VATMP_NORM) - END IF - VATMP=A*VATMP - CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) - PRCNTG=(SWHANL(IY,IX)/SWHTMP) + WRITE (NDSO,*)' ISEA =', ISEA,' IX = ',IX,' IY = ', IY, & + ' PRCNTG = ',PRCNTG, & + ' SWHBCKG = ',SWHBCKG(IY,IX), ' SWHANL = ', SWHANL(IY,IX) +#endif + IF (PRCNTG > 1.) THEN + A=PRCNTG**2*(1 + VATMP_NORM) + ELSE + A=PRCNTG**2*(1 - VATMP_NORM) + END IF + VATMP=A*VATMP + CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) + PRCNTG=(SWHANL(IY,IX)/SWHTMP) #ifdef W3_T - SWHUPRSTR(IY,IX)=SWHTMP - WRITE (NDSO,*) ' =========== Step 2. ===========' - WRITE (NDSO,*)'ISEA = ', ISEA, ' PRCNTG = ',PRCNTG, & - ' SWHANL= ', SWHANL(IY,IX), & - ' SWHUPRSTR(IY,IX) = ', SWHUPRSTR(IY,IX) -#endif - CALL CHECK_PRCNTG (PRCNTG,PRCNTG_CAP) - CALL UPDATE_VA(PRCNTG, VATMP) - VA(:,ISEA)=VATMP + SWHUPRSTR(IY,IX)=SWHTMP + WRITE (NDSO,*) ' =========== Step 2. ===========' + WRITE (NDSO,*)'ISEA = ', ISEA, ' PRCNTG = ',PRCNTG, & + ' SWHANL= ', SWHANL(IY,IX), & + ' SWHUPRSTR(IY,IX) = ', SWHUPRSTR(IY,IX) +#endif + CALL CHECK_PRCNTG (PRCNTG,PRCNTG_CAP) + CALL UPDATE_VA(PRCNTG, VATMP) + VA(:,ISEA)=VATMP #ifdef W3_T - CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) - SWHUPRSTR(IY,IX)=SWHTMP - WRITE (NDSO,*) ' =========== UPD3 Output ===========' - WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & - 'SWH_ANL = ', SWHANL(IY,IX), & - 'SWH_RSTR = ',SWHUPRSTR(IY,IX) -#endif - END IF - END DO + CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) + SWHUPRSTR(IY,IX)=SWHTMP + WRITE (NDSO,*) ' =========== UPD3 Output ===========' + WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & + 'SWH_ANL = ', SWHANL(IY,IX), & + 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#endif + END IF + END DO #ifdef W3_T - CALL writeMatrix('SWHBCKG_UPD3.txt', REAL(SWHBCKG)) - CALL writeMatrix('SWHANL_UPD3.txt' , REAL(SWHANL )) - CALL writeMatrix('SWHRSTR_UPD3.txt', REAL(SWHUPRSTR)) + CALL writeMatrix('SWHBCKG_UPD3.txt', REAL(SWHBCKG)) + CALL writeMatrix('SWHANL_UPD3.txt' , REAL(SWHANL )) + CALL writeMatrix('SWHRSTR_UPD3.txt', REAL(SWHUPRSTR)) #endif -! - DEALLOCATE( SWHANL,VATMP,SWHBCKG,VATMP_NORM,A ) + ! + DEALLOCATE( SWHANL,VATMP,SWHBCKG,VATMP_NORM,A ) #ifdef W3_T - DEALLOCATE( SWHUPRSTR ) -#endif -!/ -!/ ------------------------------------------------------------------- / -! UPD5 -! Corrects wind-sea only in wind dominated conditions - bulk correction -! The fac(x,y,frq,theta), is calculated at each grid point according to -! HsBckg and HsAnl -!/ - CASE ('UPD5') - WRITE (NDSO,902) 'UPD5' - WRITE (NDSO,1005) ' PRCNTG_CAP = ',PRCNTG_CAP - WRITE (NDSO,1005) ' THRWSEA = ',THRWSEA - WRITE (NDSO,1006) ' Reading updated SWH from: ',trim(FLNMANL) - ! Presently set hardwired THRWSEA energy threshold here - ! not user defined in input file - ! THRWSEA = 0.7 -! -! Array allocation - ALLOCATE ( VATMP(SIZE(VA,1))) - ALLOCATE ( VAMAPWS(SIZE(VA,1))) - IF (.NOT. SMCGRD) THEN - ! SWH arrays allocated using Y,X convention as per wgrib write - ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) - ALLOCATE( SWHANL(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) - ! Wind arrays allocated using X,Y convention as in w3idatmd - ALLOCATE( WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) - ALLOCATE( WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) + DEALLOCATE( SWHUPRSTR ) +#endif + !/ + !/ ------------------------------------------------------------------- / + ! UPD5 + ! Corrects wind-sea only in wind dominated conditions - bulk correction + ! The fac(x,y,frq,theta), is calculated at each grid point according to + ! HsBckg and HsAnl + !/ + CASE ('UPD5') + WRITE (NDSO,902) 'UPD5' + WRITE (NDSO,1005) ' PRCNTG_CAP = ',PRCNTG_CAP + WRITE (NDSO,1005) ' THRWSEA = ',THRWSEA + WRITE (NDSO,1006) ' Reading updated SWH from: ',trim(FLNMANL) + ! Presently set hardwired THRWSEA energy threshold here + ! not user defined in input file + ! THRWSEA = 0.7 + ! + ! Array allocation + ALLOCATE ( VATMP(SIZE(VA,1))) + ALLOCATE ( VAMAPWS(SIZE(VA,1))) + IF (.NOT. SMCGRD) THEN + ! SWH arrays allocated using Y,X convention as per wgrib write + ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ALLOCATE( SWHANL(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ! Wind arrays allocated using X,Y convention as in w3idatmd + ALLOCATE( WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) + ALLOCATE( WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) #ifdef W3_SMC - ELSE - ALLOCATE( SWHBCKG(NSEA,1) ) - ALLOCATE( SWHANL(NSEA,1) ) - ! Use SMCWND to determine if reading a seapoint aray for wind - IF( SMCWND ) THEN - ALLOCATE( WSBCKG(NSEA,1) ) - ALLOCATE( WDRBCKG(NSEA,1) ) - ELSE - ALLOCATE(WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) - ALLOCATE(WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) - ENDIF + ELSE + ALLOCATE( SWHBCKG(NSEA,1) ) + ALLOCATE( SWHANL(NSEA,1) ) + ! Use SMCWND to determine if reading a seapoint aray for wind + IF( SMCWND ) THEN + ALLOCATE( WSBCKG(NSEA,1) ) + ALLOCATE( WDRBCKG(NSEA,1) ) + ELSE + ALLOCATE(WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) + ALLOCATE(WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) + ENDIF #endif - ENDIF + ENDIF #ifdef W3_T - IF (.NOT. SMCGRD) THEN - ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) - ELSE - ALLOCATE( SWHUPRSTR(NSEA,1) ) - ENDIF -#endif -! -! Read additional Input: Analysis Field - INQUIRE(FILE=FLNMANL, EXIST=anl_exists) - IF (anl_exists) THEN + IF (.NOT. SMCGRD) THEN + ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ELSE + ALLOCATE( SWHUPRSTR(NSEA,1) ) + ENDIF +#endif + ! + ! Read additional Input: Analysis Field + INQUIRE(FILE=FLNMANL, EXIST=anl_exists) + IF (anl_exists) THEN #ifdef W3_T - WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) + WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) #endif #ifdef W3_WRST - ! For WRST switch read only corrected SWH - ! Wind will have been read from the restart - IF (WRSTON) THEN - CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) - ELSE + ! For WRST switch read only corrected SWH + ! Wind will have been read from the restart + IF (WRSTON) THEN + CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) + ELSE #endif - CALL READ_GRBTXTWS(SWHANL,WSBCKG,WDRBCKG,FLNMANL,SMCGRD) + CALL READ_GRBTXTWS(SWHANL,WSBCKG,WDRBCKG,FLNMANL,SMCGRD) #ifdef W3_WRST - ENDIF + ENDIF #endif #ifdef W3_T - CALL writeMatrix('SWHANL_IN.txt',SWHANL) + CALL writeMatrix('SWHANL_IN.txt',SWHANL) #endif - ELSE - WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' - DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) + ELSE + WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' + DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) #ifdef W3_T - DEALLOCATE( SWHUPRSTR ) + DEALLOCATE( SWHUPRSTR ) #endif - STOP - END IF -! + STOP + END IF + ! #ifdef W3_WRST - !Calculate wind speed and direction values from u,v.. - !..using cartesian direction convention - !At present assume only needed for data read from restart - CALL UVTOCART(WXNwrst,WYNwrst,WSBCKG,WDRBCKG,SMCWND) -#endif -! -! Calculation - DO ISEA=1, NSEA, 1 - IF (.NOT. SMCGRD) THEN - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXW = IX - IYW = IY + !Calculate wind speed and direction values from u,v.. + !..using cartesian direction convention + !At present assume only needed for data read from restart + CALL UVTOCART(WXNwrst,WYNwrst,WSBCKG,WDRBCKG,SMCWND) +#endif + ! + ! Calculation + DO ISEA=1, NSEA, 1 + IF (.NOT. SMCGRD) THEN + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXW = IX + IYW = IY #ifdef W3_SMC - ELSE - IX = 1 - IY = ISEA - IF( SMCWND ) THEN - ! Wind arrays allocated using (X,Y) convention for regular grids - ! but overriding here for the SMC grid which are always defined - ! as (NSEA,1) by switching the IY and IX dimension values around - IXW = IY - IYW = IX - ELSE - IXW = MAPSF(ISEA,1) - IYW= MAPSF(ISEA,2) - ENDIF + ELSE + IX = 1 + IY = ISEA + IF( SMCWND ) THEN + ! Wind arrays allocated using (X,Y) convention for regular grids + ! but overriding here for the SMC grid which are always defined + ! as (NSEA,1) by switching the IY and IX dimension values around + IXW = IY + IYW = IX + ELSE + IXW = MAPSF(ISEA,1) + IYW= MAPSF(ISEA,2) + ENDIF #endif - ENDIF - VATMP = VA(:,ISEA) - CALL SWH_RSRT_1pw (VATMP, WSBCKG(IXW,IYW), WDRBCKG(IXW,IYW), ISEA, & - SWHBCKG_1, SWHBCKG_W, SWHBCKG_S, VAMAPWS) - SWHBCKG(IY,IX)=SWHBCKG_1 -! - IF ( SWHBCKG(IY,IX) > 0.01 .AND. SWHANL(IY,IX) > 0.01 ) THEN - ! If wind-sea is dominant energy component apply correction to - ! wind-sea part only - IF ( (SWHBCKG_W / SWHBCKG_1)**2.0 > THRWSEA ) THEN - ! Apply spectrum updates to wind-sea bins only - PRCNTG=SQRT((SWHANL(IY,IX)**2.0-SWHBCKG_S**2.0)/SWHBCKG_W**2.0) - CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) - CALL UPDTWSPEC(VATMP, PRCNTG, VAMAPWS) - ! else correct the whole spectrum as for UPD2 - ELSE - PRCNTG=(SWHANL(IY,IX)/SWHBCKG_1) - CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) - CALL UPDATE_VA(PRCNTG,VATMP) - END IF + ENDIF + VATMP = VA(:,ISEA) + CALL SWH_RSRT_1pw (VATMP, WSBCKG(IXW,IYW), WDRBCKG(IXW,IYW), ISEA, & + SWHBCKG_1, SWHBCKG_W, SWHBCKG_S, VAMAPWS) + SWHBCKG(IY,IX)=SWHBCKG_1 + ! + IF ( SWHBCKG(IY,IX) > 0.01 .AND. SWHANL(IY,IX) > 0.01 ) THEN + ! If wind-sea is dominant energy component apply correction to + ! wind-sea part only + IF ( (SWHBCKG_W / SWHBCKG_1)**2.0 > THRWSEA ) THEN + ! Apply spectrum updates to wind-sea bins only + PRCNTG=SQRT((SWHANL(IY,IX)**2.0-SWHBCKG_S**2.0)/SWHBCKG_W**2.0) + CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) + CALL UPDTWSPEC(VATMP, PRCNTG, VAMAPWS) + ! else correct the whole spectrum as for UPD2 + ELSE + PRCNTG=(SWHANL(IY,IX)/SWHBCKG_1) + CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) + CALL UPDATE_VA(PRCNTG,VATMP) + END IF #ifdef W3_T - WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & - ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & - ' SWHANL = ', SWHANL(IY,IX) + WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & + ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & + ' SWHANL = ', SWHANL(IY,IX) #endif - VA(:,ISEA)=VATMP + VA(:,ISEA)=VATMP #ifdef W3_T - CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) - SWHUPRSTR(IY,IX)=SWHTMP - WRITE (NDSO,*) ' =========== UPD5 Output ===========' - WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & - 'SWH_ANL = ', SWHANL(IY,IX), & - 'SWH_RSTR = ',SWHUPRSTR(IY,IX) -#endif - END IF - END DO + CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) + SWHUPRSTR(IY,IX)=SWHTMP + WRITE (NDSO,*) ' =========== UPD5 Output ===========' + WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & + 'SWH_ANL = ', SWHANL(IY,IX), & + 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#endif + END IF + END DO #ifdef W3_T - CALL writeMatrix('SWHBCKG_UPD5.txt', REAL(SWHBCKG )) - CALL writeMatrix('SWHANL_UPD5.txt' , REAL(SWHANL )) - CALL writeMatrix('SWHRSTR_UPD5.txt', REAL(SWHUPRSTR)) + CALL writeMatrix('SWHBCKG_UPD5.txt', REAL(SWHBCKG )) + CALL writeMatrix('SWHANL_UPD5.txt' , REAL(SWHANL )) + CALL writeMatrix('SWHRSTR_UPD5.txt', REAL(SWHUPRSTR)) #endif -! - DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) + ! + DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) #ifdef W3_T - DEALLOCATE( SWHUPRSTR ) -#endif -!/ -!/ ------------------------------------------------------------------- / -! UPD6 -! Hybrid of Lionello et al. and Kohno methods -! Corrects wind-sea only in wind dominated conditions - including fp shift -! The fac(x,y,frq,theta), is calculated at each grid point according to -! HsBckg and HsAnl -!/ - CASE ('UPD6') - WRITE (NDSO,902) 'UPD6' - WRITE (NDSO,1005) ' PRCNTG_CAP = ',PRCNTG_CAP - WRITE (NDSO,1005) ' THRWSEA = ',THRWSEA - WRITE (NDSO,1006) ' Reading updated SWH from: ',trim(FLNMANL) - ! Presently set hardwired CORWSEA logical and THRWSEA energy - ! thresholds here, not user defined in input file - CORWSEA = .FALSE. - !THRWSEA = 0.7 -! -! Array allocation - ALLOCATE ( VATMP(SIZE(VA,1))) - ALLOCATE ( VAMAPWS(SIZE(VA,1))) - IF (.NOT. SMCGRD) THEN - ! SWH arrays allocated using Y,X convention as per wgrib write - ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) - ALLOCATE( SWHANL(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) - ! Wind arrays allocated using X,Y convention as in w3idatmd - ALLOCATE( WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) - ALLOCATE( WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) + DEALLOCATE( SWHUPRSTR ) +#endif + !/ + !/ ------------------------------------------------------------------- / + ! UPD6 + ! Hybrid of Lionello et al. and Kohno methods + ! Corrects wind-sea only in wind dominated conditions - including fp shift + ! The fac(x,y,frq,theta), is calculated at each grid point according to + ! HsBckg and HsAnl + !/ + CASE ('UPD6') + WRITE (NDSO,902) 'UPD6' + WRITE (NDSO,1005) ' PRCNTG_CAP = ',PRCNTG_CAP + WRITE (NDSO,1005) ' THRWSEA = ',THRWSEA + WRITE (NDSO,1006) ' Reading updated SWH from: ',trim(FLNMANL) + ! Presently set hardwired CORWSEA logical and THRWSEA energy + ! thresholds here, not user defined in input file + CORWSEA = .FALSE. + !THRWSEA = 0.7 + ! + ! Array allocation + ALLOCATE ( VATMP(SIZE(VA,1))) + ALLOCATE ( VAMAPWS(SIZE(VA,1))) + IF (.NOT. SMCGRD) THEN + ! SWH arrays allocated using Y,X convention as per wgrib write + ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ALLOCATE( SWHANL(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ! Wind arrays allocated using X,Y convention as in w3idatmd + ALLOCATE( WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) + ALLOCATE( WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) #ifdef W3_SMC - ELSE - ALLOCATE( SWHBCKG(NSEA,1) ) - ALLOCATE( SWHANL(NSEA,1) ) - ! Use SMCWND to determine if reading a seapoint aray for wind - IF( SMCWND ) THEN - ALLOCATE( WSBCKG(NSEA,1) ) - ALLOCATE( WDRBCKG(NSEA,1) ) - ELSE - ALLOCATE(WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) - ALLOCATE(WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) - ENDIF + ELSE + ALLOCATE( SWHBCKG(NSEA,1) ) + ALLOCATE( SWHANL(NSEA,1) ) + ! Use SMCWND to determine if reading a seapoint aray for wind + IF( SMCWND ) THEN + ALLOCATE( WSBCKG(NSEA,1) ) + ALLOCATE( WDRBCKG(NSEA,1) ) + ELSE + ALLOCATE(WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) + ALLOCATE(WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) + ENDIF #endif - ENDIF + ENDIF #ifdef W3_T - IF (.NOT. SMCGRD) THEN - ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) - ELSE - ALLOCATE( SWHUPRSTR(NSEA,1) ) - ENDIF -#endif -! -! Read additional Input: Analysis Field - INQUIRE(FILE=FLNMANL, EXIST=anl_exists) - IF (anl_exists) THEN + IF (.NOT. SMCGRD) THEN + ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ELSE + ALLOCATE( SWHUPRSTR(NSEA,1) ) + ENDIF +#endif + ! + ! Read additional Input: Analysis Field + INQUIRE(FILE=FLNMANL, EXIST=anl_exists) + IF (anl_exists) THEN #ifdef W3_T - WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) + WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) #endif #ifdef W3_WRST - ! For WRST switch read only corrected SWH - ! Wind will have been read from the restart - IF (WRSTON) THEN - CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) - ELSE + ! For WRST switch read only corrected SWH + ! Wind will have been read from the restart + IF (WRSTON) THEN + CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) + ELSE #endif - CALL READ_GRBTXTWS(SWHANL,WSBCKG,WDRBCKG,FLNMANL,SMCGRD) + CALL READ_GRBTXTWS(SWHANL,WSBCKG,WDRBCKG,FLNMANL,SMCGRD) #ifdef W3_WRST - ENDIF + ENDIF #endif #ifdef W3_T - CALL writeMatrix('SWHANL_IN.txt',SWHANL) + CALL writeMatrix('SWHANL_IN.txt',SWHANL) #endif - ELSE - WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' - DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) + ELSE + WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' + DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) #ifdef W3_T - DEALLOCATE( SWHUPRSTR ) + DEALLOCATE( SWHUPRSTR ) #endif - STOP - END IF -! + STOP + END IF + ! #ifdef W3_WRST - !Calculate wind speed and direction values from u,v.. - !..using cartesian direction convention - !At present assume only needed for data read from restart - CALL UVTOCART(WXNwrst,WYNwrst,WSBCKG,WDRBCKG,SMCWND) -#endif -! -! Calculation - DO ISEA=1, NSEA, 1 - IF (.NOT. SMCGRD) THEN - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - IXW = IX - IYW = IY + !Calculate wind speed and direction values from u,v.. + !..using cartesian direction convention + !At present assume only needed for data read from restart + CALL UVTOCART(WXNwrst,WYNwrst,WSBCKG,WDRBCKG,SMCWND) +#endif + ! + ! Calculation + DO ISEA=1, NSEA, 1 + IF (.NOT. SMCGRD) THEN + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IXW = IX + IYW = IY #ifdef W3_SMC - ELSE - IX = 1 - IY = ISEA - IF( SMCWND ) THEN - ! Wind arrays allocated using (X,Y) convention for regular grids - ! but overriding here for the SMC grid which are always defined - ! as (NSEA,1) by switching the IY and IX dimension values around - IXW = IY - IYW = IX - ELSE - IXW = MAPSF(ISEA,1) - IYW = MAPSF(ISEA,2) - ENDIF + ELSE + IX = 1 + IY = ISEA + IF( SMCWND ) THEN + ! Wind arrays allocated using (X,Y) convention for regular grids + ! but overriding here for the SMC grid which are always defined + ! as (NSEA,1) by switching the IY and IX dimension values around + IXW = IY + IYW = IX + ELSE + IXW = MAPSF(ISEA,1) + IYW = MAPSF(ISEA,2) + ENDIF #endif - ENDIF - VATMP = VA(:,ISEA) - CALL SWH_RSRT_1pw (VATMP, WSBCKG(IXW,IYW), WDRBCKG(IXW,IYW), ISEA, & - SWHBCKG_1, SWHBCKG_W, SWHBCKG_S, VAMAPWS) - SWHBCKG(IY,IX)=SWHBCKG_1 -!/ - IF ( SWHBCKG(IY,IX) > 0.01 .AND. SWHANL(IY,IX) > 0.01 ) THEN - ! If wind-sea is dominant energy component apply correction to - ! wind-sea part only - IF ( (SWHBCKG_W / SWHBCKG_1)**2.0 > THRWSEA ) THEN - ! Apply spectrum updates to wind-sea bins only - PRCNTG=SQRT((SWHANL(IY,IX)**2.0-SWHBCKG_S**2.0)/SWHBCKG_W**2.0) - CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) - CALL UPDTWSPECF(VATMP, PRCNTG, VAMAPWS, ISEA, .FALSE.) - ! else correct the whole spectrum - ELSE - PRCNTG=(SWHANL(IY,IX)/SWHBCKG_1) - CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) - IF (CORWSEA) THEN - ! Include frequency shifts in wind-sea update - CALL UPDTWSPECF(VATMP, PRCNTG, VAMAPWS, ISEA, .TRUE.) - ELSE - ! bulk correction only, as per UPD2 - CALL UPDATE_VA(PRCNTG,VATMP) - END IF - END IF + ENDIF + VATMP = VA(:,ISEA) + CALL SWH_RSRT_1pw (VATMP, WSBCKG(IXW,IYW), WDRBCKG(IXW,IYW), ISEA, & + SWHBCKG_1, SWHBCKG_W, SWHBCKG_S, VAMAPWS) + SWHBCKG(IY,IX)=SWHBCKG_1 + !/ + IF ( SWHBCKG(IY,IX) > 0.01 .AND. SWHANL(IY,IX) > 0.01 ) THEN + ! If wind-sea is dominant energy component apply correction to + ! wind-sea part only + IF ( (SWHBCKG_W / SWHBCKG_1)**2.0 > THRWSEA ) THEN + ! Apply spectrum updates to wind-sea bins only + PRCNTG=SQRT((SWHANL(IY,IX)**2.0-SWHBCKG_S**2.0)/SWHBCKG_W**2.0) + CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) + CALL UPDTWSPECF(VATMP, PRCNTG, VAMAPWS, ISEA, .FALSE.) + ! else correct the whole spectrum + ELSE + PRCNTG=(SWHANL(IY,IX)/SWHBCKG_1) + CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) + IF (CORWSEA) THEN + ! Include frequency shifts in wind-sea update + CALL UPDTWSPECF(VATMP, PRCNTG, VAMAPWS, ISEA, .TRUE.) + ELSE + ! bulk correction only, as per UPD2 + CALL UPDATE_VA(PRCNTG,VATMP) + END IF + END IF #ifdef W3_T - WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & - ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & - ' SWHANL = ', SWHANL(IY,IX) + WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & + ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & + ' SWHANL = ', SWHANL(IY,IX) #endif - VA(:,ISEA)=VATMP + VA(:,ISEA)=VATMP #ifdef W3_T - CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) - SWHUPRSTR(IY,IX)=SWHTMP - WRITE (NDSO,*) ' =========== UPD6 Output ===========' - WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & - 'SWH_ANL = ', SWHANL(IY,IX), & - 'SWH_RSTR = ',SWHUPRSTR(IY,IX) -#endif - END IF - END DO -#ifdef W3_T - CALL writeMatrix('SWHBCKG_UPD6.txt', REAL(SWHBCKG )) - CALL writeMatrix('SWHANL_UPD6.txt' , REAL(SWHANL )) - CALL writeMatrix('SWHRSTR_UPD6.txt', REAL(SWHUPRSTR)) + CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) + SWHUPRSTR(IY,IX)=SWHTMP + WRITE (NDSO,*) ' =========== UPD6 Output ===========' + WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & + 'SWH_ANL = ', SWHANL(IY,IX), & + 'SWH_RSTR = ',SWHUPRSTR(IY,IX) #endif -! - DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) + END IF + END DO #ifdef W3_T - DEALLOCATE( SWHUPRSTR ) + CALL writeMatrix('SWHBCKG_UPD6.txt', REAL(SWHBCKG )) + CALL writeMatrix('SWHANL_UPD6.txt' , REAL(SWHANL )) + CALL writeMatrix('SWHRSTR_UPD6.txt', REAL(SWHUPRSTR)) #endif -!/ -!/ ------------------------------------------------------------------- / -! End of update options -!/ - END SELECT -!/ -!/ ------------------------------------------------------------------- / -! 6. Write updated restart file -!/ + ! + DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) +#ifdef W3_T + DEALLOCATE( SWHUPRSTR ) +#endif + !/ + !/ ------------------------------------------------------------------- / + ! End of update options + !/ + END SELECT + !/ + !/ ------------------------------------------------------------------- / + ! 6. Write updated restart file + !/ #ifdef W3_WRST - ! Copy read wind values from restart for write out - WXN = WXNwrst - WYN = WYNwrst + ! Copy read wind values from restart for write out + WXN = WXNwrst + WYN = WYNwrst #endif - WRITE (NDSO,903) - RSTYPE = 3 - CALL W3IORS ( 'HOT', NDS(6), SIG(NK), 1 ) + WRITE (NDSO,903) + RSTYPE = 3 + CALL W3IORS ( 'HOT', NDS(6), SIG(NK), 1 ) #ifdef W3_T - WRITE (NDST,*), MYNAME,' : Exporting VA at the end of the re-analysis' - CALL writeMatrix('VA02.txt', REAL(VA)) -#endif -! -!/ -!/ ------------------------------------------------------------------- / -! Escape locations read errors 08k: -!/ - GOTO 888 -! - 800 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 10 ) -! - 801 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 11 ) -! - 802 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 12 ) -! - 888 CONTINUE - WRITE (NDSO,999) -!/ -!/ ------------------------------------------------------------------- / -! Escape locations read errors 2k: -!/ - GOTO 2222 -! - 2001 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) - GOTO 2222 -! - 2002 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) IERR - GOTO 2222 -! - 2222 CONTINUE -!/ -!/ ------------------------------------------------------------------- / -! Formats -!/ + WRITE (NDST,*), MYNAME,' : Exporting VA at the end of the re-analysis' + CALL writeMatrix('VA02.txt', REAL(VA)) +#endif + ! + !/ + !/ ------------------------------------------------------------------- / + ! Escape locations read errors 08k: + !/ + GOTO 888 + ! +800 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 10 ) + ! +801 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 11 ) + ! +802 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 12 ) + ! +888 CONTINUE + WRITE (NDSO,999) + !/ + !/ ------------------------------------------------------------------- / + ! Escape locations read errors 2k: + !/ + GOTO 2222 + ! +2001 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) + GOTO 2222 + ! +2002 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) IERR + GOTO 2222 + ! +2222 CONTINUE + !/ + !/ ------------------------------------------------------------------- / + ! Formats + !/ 900 FORMAT (/15X,' *** WAVEWATCH III ww3_uprstr Initializing *** '/ & - 15X,' ==============================================='/) + 15X,' ==============================================='/) 901 FORMAT ( ' Comment character is ''',A,''''/) -! + ! 902 FORMAT ( ' The Option ''',A,''' is used.'/) -! + ! 903 FORMAT ( ' Exporting the Updated Restart file to "restart001.ww3"'/) -! + ! 920 FORMAT ( ' Grid name : ',A/) -! + ! 930 FORMAT (/' Time interval : '/ & - ' --------------------------------------------------') -! + ' --------------------------------------------------') + ! 931 FORMAT ( ' Starting time : ',A) -! + ! 932 FORMAT ( ' Ending time : ',A/) -! + ! 999 FORMAT (/' End of program '/ & - ' ========================================='/ & - ' WAVEWATCH III ww3_uprstr '/) -! + ' ========================================='/ & + ' WAVEWATCH III ww3_uprstr '/) + ! 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3UPRSTR : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) + ! 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3UPRSTR : '/ & - ' PREMATURE END OF INPUT FILE'/) + ' PREMATURE END OF INPUT FILE'/) 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3UPRSTR : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) 1004 FORMAT (/' '/,A/) 1005 FORMAT (' ',A, F6.3/) 1006 FORMAT (' ',A, A/) -! -!/ - CONTAINS -!/ -!/ ------------------------------------------------------------------- / -!> -!> @brief Apply correction to the spectrum. -!> -!> @details The factor is (swh_anal/swh_bkg)**2 as applying to wave energy. -!> -!> @param[in] PRCNTG -!> @param[inout] VATMP -!> @author Stelios Flampouris @date 16-Oct-2018 -!> - SUBROUTINE UPDATE_VA (PRCNTG, VATMP) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Stelios Flampouris | -!/ | FORTRAN 90 | -!/ | Created : 16-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ 16-Oct-2018 : Original Code ( version 6.06 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! Apply correction to the spectrum -! -! 2. Method : -! The factor is (swh_anal/swh_bkg)**2 as applying to wave energy -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/T -! -! 10. Source code : -! -!/ - REAL, INTENT(IN) :: PRCNTG - REAL, DIMENSION(:), INTENT(INOUT) :: VATMP -! - VATMP = (PRCNTG**2)*VATMP -! - END SUBROUTINE UPDATE_VA -!/ -!/ --------------------------------------------------------------------- -!/ -!> -!> @brief Last sanity check before the update of the spectrum. -!> -!> @details The percentage of change is compared against a user defined cap. -!> -!> @param[inout] PRCNTG -!> @param[inout] PRCNTG_CAP -!> @author Stelios Flampouris @date 16-Oct-2018 -!> - SUBROUTINE CHECK_PRCNTG (PRCNTG,PRCNTG_CAP) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Stelios Flampouris | -!/ | FORTRAN 90 | -!/ | Created : 16-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ 16-Oct-2018 : Original Code ( version 6.06 ) -!/ 24-Oct-2018 : Update by Andy Saulter ( version 7.14 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! Last sanity check before the update of the spectrum -! 2. Method : -! The percentage of change is compared against a user defined cap. -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/T -! -! 10. Source code : -! -!/ - REAL, INTENT(INOUT) :: PRCNTG - REAL, INTENT(IN ) :: PRCNTG_CAP -! local - CHARACTER(12), PARAMETER :: MYNAME='CHECK_PRCNTG' + ! + !/ +CONTAINS + !/ + !/ ------------------------------------------------------------------- / + !> + !> @brief Apply correction to the spectrum. + !> + !> @details The factor is (swh_anal/swh_bkg)**2 as applying to wave energy. + !> + !> @param[in] PRCNTG + !> @param[inout] VATMP + !> @author Stelios Flampouris @date 16-Oct-2018 + !> + SUBROUTINE UPDATE_VA (PRCNTG, VATMP) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Stelios Flampouris | + !/ | FORTRAN 90 | + !/ | Created : 16-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ 16-Oct-2018 : Original Code ( version 6.06 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! Apply correction to the spectrum + ! + ! 2. Method : + ! The factor is (swh_anal/swh_bkg)**2 as applying to wave energy + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/T + ! + ! 10. Source code : + ! + !/ + REAL, INTENT(IN) :: PRCNTG + REAL, DIMENSION(:), INTENT(INOUT) :: VATMP + ! + VATMP = (PRCNTG**2)*VATMP + ! + END SUBROUTINE UPDATE_VA + !/ + !/ --------------------------------------------------------------------- + !/ + !> + !> @brief Last sanity check before the update of the spectrum. + !> + !> @details The percentage of change is compared against a user defined cap. + !> + !> @param[inout] PRCNTG + !> @param[inout] PRCNTG_CAP + !> @author Stelios Flampouris @date 16-Oct-2018 + !> + SUBROUTINE CHECK_PRCNTG (PRCNTG,PRCNTG_CAP) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Stelios Flampouris | + !/ | FORTRAN 90 | + !/ | Created : 16-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ 16-Oct-2018 : Original Code ( version 6.06 ) + !/ 24-Oct-2018 : Update by Andy Saulter ( version 7.14 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! Last sanity check before the update of the spectrum + ! 2. Method : + ! The percentage of change is compared against a user defined cap. + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/T + ! + ! 10. Source code : + ! + !/ + REAL, INTENT(INOUT) :: PRCNTG + REAL, INTENT(IN ) :: PRCNTG_CAP + ! local + CHARACTER(12), PARAMETER :: MYNAME='CHECK_PRCNTG' #ifdef W3_T - WRITE (NDSO,*) trim(MYNAME)," The original correction is ",PRCNTG - WRITE (NDSO,*) trim(MYNAME)," The cap is ",PRCNTG_CAP + WRITE (NDSO,*) trim(MYNAME)," The original correction is ",PRCNTG + WRITE (NDSO,*) trim(MYNAME)," The cap is ",PRCNTG_CAP #endif - IF ( PRCNTG_CAP < 1. ) THEN - WRITE (NDSO,*) trim(MYNAME)," WARNING: PRCNTG_CAP set < 1." - WRITE (NDSO,*) trim(MYNAME)," This may introduce spurious corrections" - END IF + IF ( PRCNTG_CAP < 1. ) THEN + WRITE (NDSO,*) trim(MYNAME)," WARNING: PRCNTG_CAP set < 1." + WRITE (NDSO,*) trim(MYNAME)," This may introduce spurious corrections" + END IF #ifdef W3_T - WRITE (NDSO,*) trim(MYNAME)," The cap is ",PRCNTG_CAP + WRITE (NDSO,*) trim(MYNAME)," The cap is ",PRCNTG_CAP #endif - IF ( PRCNTG > 1. ) THEN + IF ( PRCNTG > 1. ) THEN #ifdef W3_T WRITE (NDSO,*) trim(MYNAME)," PRCNTG > 1." #endif - PRCNTG = MIN(PRCNTG, 1. * PRCNTG_CAP) - ELSE IF ( PRCNTG < 1. ) THEN + PRCNTG = MIN(PRCNTG, 1. * PRCNTG_CAP) + ELSE IF ( PRCNTG < 1. ) THEN #ifdef W3_T WRITE (NDSO,*) trim(MYNAME)," PRCNTG < 1." #endif - PRCNTG = MAX(PRCNTG, 1. / PRCNTG_CAP) + PRCNTG = MAX(PRCNTG, 1. / PRCNTG_CAP) #ifdef W3_T - + #endif - END IF + END IF #ifdef W3_T - WRITE (NDSO,*) trim(MYNAME)," The updated correction is ",PRCNTG -#endif -! - END SUBROUTINE CHECK_PRCNTG -!/ -!/ ------------------------------------------------------------------- / -!/ -!> @brief Read gribtxt files. -!> -!> @param[inout] UPDPRCNT -!> @param[inout] FLNMCOR -!> @param[inout] SMCGRD -!> @author Stelios Flampouris @date 16-Oct-2018 -!> - SUBROUTINE READ_GRBTXT(UPDPRCNT,FLNMCOR,SMCGRD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Stelios Flampouris | -!/ | FORTRAN 90 | -!/ | Created : 15-Mar-2017 | -!/ | Last Update : 16-Oct-2018 | -!/ +-----------------------------------+ -!/ -!/ 15-Mar-2017 : Original Code ( version 6.04 ) -!/ 16-Oct-2018 : Generalization of the reader ( version 6.06 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! Read gribtxt files -! 2. Method : -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/T -! -! 10. Source code : -! -!/ - REAL, DIMENSION(:,:), INTENT(OUT) :: UPDPRCNT - CHARACTER(*), INTENT(IN) :: FLNMCOR - LOGICAL, INTENT(IN) :: SMCGRD -! Local Variables - INTEGER :: I, J, IERR - INTEGER :: K, L, M, N - REAL :: A - INTEGER, PARAMETER :: IP_FID = 123 - CHARACTER(25), PARAMETER::myname='read_grbtxt' -! + WRITE (NDSO,*) trim(MYNAME)," The updated correction is ",PRCNTG +#endif + ! + END SUBROUTINE CHECK_PRCNTG + !/ + !/ ------------------------------------------------------------------- / + !/ + !> @brief Read gribtxt files. + !> + !> @param[inout] UPDPRCNT + !> @param[inout] FLNMCOR + !> @param[inout] SMCGRD + !> @author Stelios Flampouris @date 16-Oct-2018 + !> + SUBROUTINE READ_GRBTXT(UPDPRCNT,FLNMCOR,SMCGRD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Stelios Flampouris | + !/ | FORTRAN 90 | + !/ | Created : 15-Mar-2017 | + !/ | Last Update : 16-Oct-2018 | + !/ +-----------------------------------+ + !/ + !/ 15-Mar-2017 : Original Code ( version 6.04 ) + !/ 16-Oct-2018 : Generalization of the reader ( version 6.06 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! Read gribtxt files + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/T + ! + ! 10. Source code : + ! + !/ + REAL, DIMENSION(:,:), INTENT(OUT) :: UPDPRCNT + CHARACTER(*), INTENT(IN) :: FLNMCOR + LOGICAL, INTENT(IN) :: SMCGRD + ! Local Variables + INTEGER :: I, J, IERR + INTEGER :: K, L, M, N + REAL :: A + INTEGER, PARAMETER :: IP_FID = 123 + CHARACTER(25), PARAMETER::myname='read_grbtxt' + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' starts' -#endif - J = LEN_TRIM(FNMPRE) - OPEN (IP_FID,FILE=FNMPRE(:J)//TRIM(FLNMCOR),STATUS='OLD' & - ,ACTION='read',IOSTAT=IERR) -! - ! Read text header and check dimensions match expected values - IF (.NOT. SMCGRD) THEN - READ( IP_FID, *) M,N - IF (( SIZE(UPDPRCNT,1) /= N) .OR. ( SIZE(UPDPRCNT,2) /= M )) THEN - WRITE (NDSO,*) trim(myname),': These are not the grid ' // & - 'dimensions: M=',M,' N=',N - STOP - END IF + WRITE (NDSO,*) trim(myname), ' starts' +#endif + J = LEN_TRIM(FNMPRE) + OPEN (IP_FID,FILE=FNMPRE(:J)//TRIM(FLNMCOR),STATUS='OLD' & + ,ACTION='read',IOSTAT=IERR) + ! + ! Read text header and check dimensions match expected values + IF (.NOT. SMCGRD) THEN + READ( IP_FID, *) M,N + IF (( SIZE(UPDPRCNT,1) /= N) .OR. ( SIZE(UPDPRCNT,2) /= M )) THEN + WRITE (NDSO,*) trim(myname),': These are not the grid ' // & + 'dimensions: M=',M,' N=',N + STOP + END IF #ifdef W3_SMC - ELSE - READ( IP_FID, *) N - IF ( SIZE(UPDPRCNT,1) /= N ) THEN - WRITE (NDSO,*) trim(myname),': These are not the grid ' // & - 'dimensions: N=',N - STOP - END IF -#endif - END IF - UPDPRCNT=0 -! - ! Read the data into its allocated array - IF (.NOT. SMCGRD) THEN - DO L=1,N - DO K=1,M - A=0. - READ(IP_FID,*)A - UPDPRCNT(N+1-L,K)=A - END DO - END DO + ELSE + READ( IP_FID, *) N + IF ( SIZE(UPDPRCNT,1) /= N ) THEN + WRITE (NDSO,*) trim(myname),': These are not the grid ' // & + 'dimensions: N=',N + STOP + END IF +#endif + END IF + UPDPRCNT=0 + ! + ! Read the data into its allocated array + IF (.NOT. SMCGRD) THEN + DO L=1,N + DO K=1,M + A=0. + READ(IP_FID,*)A + UPDPRCNT(N+1-L,K)=A + END DO + END DO #ifdef W3_SMC - ELSE - DO L=1,N - A=0. - READ(IP_FID,*)A - UPDPRCNT(L,1)=A - END DO -#endif - END IF -! - CLOSE(IP_FID) -! + ELSE + DO L=1,N + A=0. + READ(IP_FID,*)A + UPDPRCNT(L,1)=A + END DO +#endif + END IF + ! + CLOSE(IP_FID) + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' ends' -#endif - END SUBROUTINE READ_GRBTXT -!/ -!/ ------------------------------------------------------------------- / -!/ -!> -!> @brief Read txt files that include wind data. -!> -!> @param[out] UPDPRCNT -!> @param[out] WSPD -!> @param[out] WDIR -!> @param[in] FLNMCOR -!> @param[in] SMCGRD -!> -!> @author Andy Saulter @date 24-Oct-2018 -!> - SUBROUTINE READ_GRBTXTWS(UPDPRCNT,WSPD,WDIR,FLNMCOR,SMCGRD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Andy Saulter | -!/ | FORTRAN 90 | -!/ | Original code : 24-Oct-2018 | -!/ | Last update : 05-Oct-2019 | -!/ +-----------------------------------+ -!/ -!/ 24-Oct-2018 : Original Code ( version 6.07 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! Read txt files that include wind data -! 2. Method : -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/T -! -! 10. Source code : -! -!/ - REAL, DIMENSION(:,:), INTENT(OUT) :: UPDPRCNT, WSPD, WDIR - CHARACTER(*), INTENT(IN) :: FLNMCOR - LOGICAL, INTENT(IN) :: SMCGRD -! Local Variables - INTEGER :: I, J, IERR - INTEGER :: K, L, M, N - REAL :: A, WS, WD - INTEGER, PARAMETER :: IP_FID = 123 - CHARACTER(25), PARAMETER::myname='read_grbtxt' -! + WRITE (NDSO,*) trim(myname), ' ends' +#endif + END SUBROUTINE READ_GRBTXT + !/ + !/ ------------------------------------------------------------------- / + !/ + !> + !> @brief Read txt files that include wind data. + !> + !> @param[out] UPDPRCNT + !> @param[out] WSPD + !> @param[out] WDIR + !> @param[in] FLNMCOR + !> @param[in] SMCGRD + !> + !> @author Andy Saulter @date 24-Oct-2018 + !> + SUBROUTINE READ_GRBTXTWS(UPDPRCNT,WSPD,WDIR,FLNMCOR,SMCGRD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Andy Saulter | + !/ | FORTRAN 90 | + !/ | Original code : 24-Oct-2018 | + !/ | Last update : 05-Oct-2019 | + !/ +-----------------------------------+ + !/ + !/ 24-Oct-2018 : Original Code ( version 6.07 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! Read txt files that include wind data + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/T + ! + ! 10. Source code : + ! + !/ + REAL, DIMENSION(:,:), INTENT(OUT) :: UPDPRCNT, WSPD, WDIR + CHARACTER(*), INTENT(IN) :: FLNMCOR + LOGICAL, INTENT(IN) :: SMCGRD + ! Local Variables + INTEGER :: I, J, IERR + INTEGER :: K, L, M, N + REAL :: A, WS, WD + INTEGER, PARAMETER :: IP_FID = 123 + CHARACTER(25), PARAMETER::myname='read_grbtxt' + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' starts' -#endif - J = LEN_TRIM(FNMPRE) - OPEN (IP_FID,FILE=FNMPRE(:J)//TRIM(FLNMCOR),STATUS='OLD' & - ,ACTION='read',IOSTAT=IERR) -! - ! Read text header and check dimensions match expected values - IF (.NOT. SMCGRD) THEN - READ( IP_FID, *) M,N - IF (( SIZE(UPDPRCNT,1) /= N) .OR. ( SIZE(UPDPRCNT,2) /= M )) THEN - WRITE (NDSO,*) trim(myname),': These are not the grid ' // & - 'dimensions: M=',M,' N=',N - STOP - END IF + WRITE (NDSO,*) trim(myname), ' starts' +#endif + J = LEN_TRIM(FNMPRE) + OPEN (IP_FID,FILE=FNMPRE(:J)//TRIM(FLNMCOR),STATUS='OLD' & + ,ACTION='read',IOSTAT=IERR) + ! + ! Read text header and check dimensions match expected values + IF (.NOT. SMCGRD) THEN + READ( IP_FID, *) M,N + IF (( SIZE(UPDPRCNT,1) /= N) .OR. ( SIZE(UPDPRCNT,2) /= M )) THEN + WRITE (NDSO,*) trim(myname),': These are not the grid ' // & + 'dimensions: M=',M,' N=',N + STOP + END IF #ifdef W3_SMC - ELSE - READ( IP_FID, *) N - IF ( SIZE(UPDPRCNT,1) /= N ) THEN - WRITE (NDSO,*) trim(myname),': These are not the grid ' // & - 'dimensions: N=',N - STOP - END IF -#endif - END IF - UPDPRCNT=0 - WSPD=0. - WDIR=0. -! - ! Read the data into allocated arrays - IF (.NOT. SMCGRD) THEN - DO L=1,N - DO K=1,M - A=0. - WS=0. - WD=0. - READ(IP_FID,*)A, WS, WD - !SWH data read onto Y,X grid - UPDPRCNT(N+1-L,K)=A - !Wind data read onto X,Y grid - WSPD(K,N+1-L)=WS - WDIR(K,N+1-L)=WD - END DO - END DO + ELSE + READ( IP_FID, *) N + IF ( SIZE(UPDPRCNT,1) /= N ) THEN + WRITE (NDSO,*) trim(myname),': These are not the grid ' // & + 'dimensions: N=',N + STOP + END IF +#endif + END IF + UPDPRCNT=0 + WSPD=0. + WDIR=0. + ! + ! Read the data into allocated arrays + IF (.NOT. SMCGRD) THEN + DO L=1,N + DO K=1,M + A=0. + WS=0. + WD=0. + READ(IP_FID,*)A, WS, WD + !SWH data read onto Y,X grid + UPDPRCNT(N+1-L,K)=A + !Wind data read onto X,Y grid + WSPD(K,N+1-L)=WS + WDIR(K,N+1-L)=WD + END DO + END DO #ifdef W3_SMC - ELSE - DO L=1,N - A=0. - READ(IP_FID,*)A, WS, WD - UPDPRCNT(L,1)=A - WSPD(L,1)=WS - WDIR(L,1)=WD - END DO -#endif - ENDIF -! - CLOSE(IP_FID) -! -! + ELSE + DO L=1,N + A=0. + READ(IP_FID,*)A, WS, WD + UPDPRCNT(L,1)=A + WSPD(L,1)=WS + WDIR(L,1)=WD + END DO +#endif + ENDIF + ! + CLOSE(IP_FID) + ! + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' ends' -#endif - END SUBROUTINE READ_GRBTXTWS -!/ -!/ ------------------------------------------------------------------- / -!/ -!> @brief Calculate the significant wave height from the restart file for 1 point. -!> -!> @param[in] VA1p -!> @param[in] ISEA1p -!> @param[out] HSIG1p -!> @author Stelios Flampouris @date 15-May-2017 -!> - SUBROUTINE SWH_RSRT_1p (VA1p, ISEA1p, HSIG1p ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Stelios Flampouris | -!/ | FORTRAN 90 | -!/ | Last update : 15-Mar-2017 | -!/ +-----------------------------------+ -!/ -!/ 15-Mar-2017 : Original Code ( version 6.04 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! Calculate the significant wave height from the restart file for 1 point -! 2. Method : -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/T -! -! 10. Source code : -! -!/ - REAL, INTENT(OUT) :: HSIG1p - INTEGER, INTENT(IN) :: ISEA1p - REAL, DIMENSION(:), INTENT(IN) :: VA1p - CHARACTER(25),PARAMETER :: myname='SWH_RSRT_1p' -! + WRITE (NDSO,*) trim(myname), ' ends' +#endif + END SUBROUTINE READ_GRBTXTWS + !/ + !/ ------------------------------------------------------------------- / + !/ + !> @brief Calculate the significant wave height from the restart file for 1 point. + !> + !> @param[in] VA1p + !> @param[in] ISEA1p + !> @param[out] HSIG1p + !> @author Stelios Flampouris @date 15-May-2017 + !> + SUBROUTINE SWH_RSRT_1p (VA1p, ISEA1p, HSIG1p ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Stelios Flampouris | + !/ | FORTRAN 90 | + !/ | Last update : 15-Mar-2017 | + !/ +-----------------------------------+ + !/ + !/ 15-Mar-2017 : Original Code ( version 6.04 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! Calculate the significant wave height from the restart file for 1 point + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/T + ! + ! 10. Source code : + ! + !/ + REAL, INTENT(OUT) :: HSIG1p + INTEGER, INTENT(IN) :: ISEA1p + REAL, DIMENSION(:), INTENT(IN) :: VA1p + CHARACTER(25),PARAMETER :: myname='SWH_RSRT_1p' + ! #ifdef W3_FT - WRITE (NDSO,*)' ' - WRITE (NDSO,*) trim(myname), ' starts' -#endif - HSIG1p = 0. - DEPTH = MAX ( DMIN , -ZB(ISEA1p) ) - ETOT = 0. -! - DO IK=1, NK - CALL WAVNU1 ( SIG(IK), DEPTH, WN, CG ) - E1I = 0. - DO ITH=1, NTH - E1I = E1I + VA1p(ITH+(IK-1)*NTH) * SIG(IK) / CG - END DO - ETOT = ETOT + E1I*DSIP(IK) - END DO -! - HSIG1p = 4. * SQRT ( ETOT * DTH ) -! + WRITE (NDSO,*)' ' + WRITE (NDSO,*) trim(myname), ' starts' +#endif + HSIG1p = 0. + DEPTH = MAX ( DMIN , -ZB(ISEA1p) ) + ETOT = 0. + ! + DO IK=1, NK + CALL WAVNU1 ( SIG(IK), DEPTH, WN, CG ) + E1I = 0. + DO ITH=1, NTH + E1I = E1I + VA1p(ITH+(IK-1)*NTH) * SIG(IK) / CG + END DO + ETOT = ETOT + E1I*DSIP(IK) + END DO + ! + HSIG1p = 4. * SQRT ( ETOT * DTH ) + ! #ifdef W3_FT - WRITE (NDSO,*) ' ', trim(myname), ' ends' - WRITE (NDSO,*)' ' -#endif - END SUBROUTINE SWH_RSRT_1p -!/ -!/ ------------------------------------------------------------------- / -!/ -!> @brief Calculate Hs from restart for 1 point. -!> -!> @details Calculate the significant wave height for total, wind sea and -!> swell components from the restart file for 1 point -!> -!> @param[in] VA1p -!> @param[in] WS -!> @param[in] WD -!> @param[in] ISEA1p -!> @param[out] HSIG1p -!> @param[out] HSIGwp -!> @param[out] HSIGsp -!> @param[out] VAMAPWS -!> -!> @author Andy Saulter @date 05-0ct-2019 -!> - SUBROUTINE SWH_RSRT_1pw (VA1p, WS, WD, ISEA1p, HSIG1p, HSIGwp, HSIGsp, VAMAPWS ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Andy Saulter | -!/ | FORTRAN 90 | -!/ | Original code : 24-Oct-2018 | -!/ | Last update : 05-Oct-2019 | -!/ +-----------------------------------+ -!/ -!/ 24-Oct-2018 : Original Code ( version 6.07 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! Calculate the significant wave height for total, wind sea and -! swell components from the restart file for 1 point -! 2. Method : -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/T -! -! 10. Source code : -! -!/ - USE W3GDATMD, ONLY: TH - USE W3ODATMD, ONLY: WSMULT !same wind sea cut-off factor for sea/swell outputs -! - REAL, INTENT(OUT) :: HSIG1p, HSIGwp, HSIGsp - INTEGER, INTENT(IN) :: ISEA1p - REAL, INTENT(IN) :: WS, WD - REAL, DIMENSION(:), INTENT(IN) :: VA1p - INTEGER, DIMENSION(:), INTENT(OUT) :: VAMAPWS ! Wind-sea id for spectral bins - REAL :: RELWS, ETOTw, ETOTs, EwI, EsI - CHARACTER(25),PARAMETER :: myname='SWH_RSRT_1pw' -! + WRITE (NDSO,*) ' ', trim(myname), ' ends' + WRITE (NDSO,*)' ' +#endif + END SUBROUTINE SWH_RSRT_1p + !/ + !/ ------------------------------------------------------------------- / + !/ + !> @brief Calculate Hs from restart for 1 point. + !> + !> @details Calculate the significant wave height for total, wind sea and + !> swell components from the restart file for 1 point + !> + !> @param[in] VA1p + !> @param[in] WS + !> @param[in] WD + !> @param[in] ISEA1p + !> @param[out] HSIG1p + !> @param[out] HSIGwp + !> @param[out] HSIGsp + !> @param[out] VAMAPWS + !> + !> @author Andy Saulter @date 05-0ct-2019 + !> + SUBROUTINE SWH_RSRT_1pw (VA1p, WS, WD, ISEA1p, HSIG1p, HSIGwp, HSIGsp, VAMAPWS ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Andy Saulter | + !/ | FORTRAN 90 | + !/ | Original code : 24-Oct-2018 | + !/ | Last update : 05-Oct-2019 | + !/ +-----------------------------------+ + !/ + !/ 24-Oct-2018 : Original Code ( version 6.07 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! Calculate the significant wave height for total, wind sea and + ! swell components from the restart file for 1 point + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/T + ! + ! 10. Source code : + ! + !/ + USE W3GDATMD, ONLY: TH + USE W3ODATMD, ONLY: WSMULT !same wind sea cut-off factor for sea/swell outputs + ! + REAL, INTENT(OUT) :: HSIG1p, HSIGwp, HSIGsp + INTEGER, INTENT(IN) :: ISEA1p + REAL, INTENT(IN) :: WS, WD + REAL, DIMENSION(:), INTENT(IN) :: VA1p + INTEGER, DIMENSION(:), INTENT(OUT) :: VAMAPWS ! Wind-sea id for spectral bins + REAL :: RELWS, ETOTw, ETOTs, EwI, EsI + CHARACTER(25),PARAMETER :: myname='SWH_RSRT_1pw' + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' starts' -#endif - HSIG1p = 0. - HSIGwp = 0. - HSIGsp = 0. - DEPTH = MAX ( DMIN , -ZB(ISEA1p) ) - ETOT = 0. - ETOTw = 0. - ETOTs = 0. -! - DO IK=1, NK - CALL WAVNU1 ( SIG(IK), DEPTH, WN, CG ) - E1I = 0. - EwI = 0. - EsI = 0. - DO ITH=1, NTH - ! Relative wind-sea calc assumes input with in direction toward - ! i.e. same as for the wave spectrum - RELWS = WSMULT * WS * MAX(0.0, COS(WD - TH(ITH))) - E1I = E1I + VA1p(ITH+(IK-1)*NTH) * SIG(IK) / CG - IF ( RELWS > (SIG(IK)/WN) ) THEN - EwI = EwI + VA1p(ITH+(IK-1)*NTH) * SIG(IK) / CG - VAMAPWS(ITH+(IK-1)*NTH) = 1 - ELSE - EsI = EsI + VA1p(ITH+(IK-1)*NTH) * SIG(IK) / CG - VAMAPWS(ITH+(IK-1)*NTH) = 0 - END IF - END DO - ETOT = ETOT + E1I*DSIP(IK) - ETOTw = ETOTw + EwI*DSIP(IK) - ETOTs = ETOTs + EsI*DSIP(IK) - END DO -! - HSIG1p = 4. * SQRT ( ETOT * DTH ) - HSIGwp = 4. * SQRT ( ETOTw * DTH ) - HSIGsp = 4. * SQRT ( ETOTs * DTH ) -! + WRITE (NDSO,*) trim(myname), ' starts' +#endif + HSIG1p = 0. + HSIGwp = 0. + HSIGsp = 0. + DEPTH = MAX ( DMIN , -ZB(ISEA1p) ) + ETOT = 0. + ETOTw = 0. + ETOTs = 0. + ! + DO IK=1, NK + CALL WAVNU1 ( SIG(IK), DEPTH, WN, CG ) + E1I = 0. + EwI = 0. + EsI = 0. + DO ITH=1, NTH + ! Relative wind-sea calc assumes input with in direction toward + ! i.e. same as for the wave spectrum + RELWS = WSMULT * WS * MAX(0.0, COS(WD - TH(ITH))) + E1I = E1I + VA1p(ITH+(IK-1)*NTH) * SIG(IK) / CG + IF ( RELWS > (SIG(IK)/WN) ) THEN + EwI = EwI + VA1p(ITH+(IK-1)*NTH) * SIG(IK) / CG + VAMAPWS(ITH+(IK-1)*NTH) = 1 + ELSE + EsI = EsI + VA1p(ITH+(IK-1)*NTH) * SIG(IK) / CG + VAMAPWS(ITH+(IK-1)*NTH) = 0 + END IF + END DO + ETOT = ETOT + E1I*DSIP(IK) + ETOTw = ETOTw + EwI*DSIP(IK) + ETOTs = ETOTs + EsI*DSIP(IK) + END DO + ! + HSIG1p = 4. * SQRT ( ETOT * DTH ) + HSIGwp = 4. * SQRT ( ETOTw * DTH ) + HSIGsp = 4. * SQRT ( ETOTs * DTH ) + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' ends' -#endif - END SUBROUTINE SWH_RSRT_1pw -!/ -!/ ------------------------------------------------------------------- / -!/ -!> @brief Calculate speed and cartesian convention directions from u,v -!> input vectors. -!> -!> @param[in] UVEC -!> @param[in] VVEC -!> @param[out] SPD -!> @param[out] DCART -!> @param[in] SMCGRD -!> -!> @author Andy Saulter @date 05-Oct-2019 -!> - SUBROUTINE UVTOCART (UVEC, VVEC, SPD, DCART, SMCGRD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Andy Saulter | -!/ | FORTRAN 90 | -!/ | Original code : 05-Oct-2019 | -!/ +-----------------------------------+ -!/ -!/ 05-Oct-2019 : Original Code ( version 6.07 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! Calculate speed and cartesian convention directions from u,v -! input vectors -! 2. Method : -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/T -! -! 10. Source code : -! -!/ - USE CONSTANTS, ONLY: TPI -! - REAL, DIMENSION(:,:), INTENT(OUT) :: SPD, DCART - REAL, DIMENSION(:,:), INTENT(IN) :: UVEC, VVEC - LOGICAL, INTENT(IN) :: SMCGRD -! + WRITE (NDSO,*) trim(myname), ' ends' +#endif + END SUBROUTINE SWH_RSRT_1pw + !/ + !/ ------------------------------------------------------------------- / + !/ + !> @brief Calculate speed and cartesian convention directions from u,v + !> input vectors. + !> + !> @param[in] UVEC + !> @param[in] VVEC + !> @param[out] SPD + !> @param[out] DCART + !> @param[in] SMCGRD + !> + !> @author Andy Saulter @date 05-Oct-2019 + !> + SUBROUTINE UVTOCART (UVEC, VVEC, SPD, DCART, SMCGRD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Andy Saulter | + !/ | FORTRAN 90 | + !/ | Original code : 05-Oct-2019 | + !/ +-----------------------------------+ + !/ + !/ 05-Oct-2019 : Original Code ( version 6.07 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! Calculate speed and cartesian convention directions from u,v + ! input vectors + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/T + ! + ! 10. Source code : + ! + !/ + USE CONSTANTS, ONLY: TPI + ! + REAL, DIMENSION(:,:), INTENT(OUT) :: SPD, DCART + REAL, DIMENSION(:,:), INTENT(IN) :: UVEC, VVEC + LOGICAL, INTENT(IN) :: SMCGRD + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' starts' + WRITE (NDSO,*) trim(myname), ' starts' #endif -! - DO ISEA=1, NSEA, 1 - IF (.NOT. SMCGRD) THEN - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + ! + DO ISEA=1, NSEA, 1 + IF (.NOT. SMCGRD) THEN + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) #ifdef W3_SMC - ELSE - IX = 1 - IY = ISEA + ELSE + IX = 1 + IY = ISEA #endif - ENDIF -! - SPD(IY,IX) = SQRT( UVEC(IY,IX)**2 + VVEC(IY,IX)**2 ) - IF( SPD(IY,IX) .GT. 1.E-7) THEN - DCART = MOD( TPI+ATAN2(UVEC(IY,IX),VVEC(IY,IX)) , TPI ) - ELSE - DCART = 0 - END IF - SPD(IY,IX) = MAX( SPD(IY,IX) , 0.001 ) - END DO -! + ENDIF + ! + SPD(IY,IX) = SQRT( UVEC(IY,IX)**2 + VVEC(IY,IX)**2 ) + IF( SPD(IY,IX) .GT. 1.E-7) THEN + DCART = MOD( TPI+ATAN2(UVEC(IY,IX),VVEC(IY,IX)) , TPI ) + ELSE + DCART = 0 + END IF + SPD(IY,IX) = MAX( SPD(IY,IX) , 0.001 ) + END DO + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' ends' -#endif - END SUBROUTINE UVTOCART -!/ -!/ ------------------------------------------------------------------- / -!/ -!> @brief Updates the wind-sea part of the wave spectrum only. -!> -!> @param[inout] VATMP -!> @param[in] PRCNTG -!> @param[in] VAMAPWS -!> -!> @author Andy Saulter @date 05-Oct-2019 -!> -!> - SUBROUTINE UPDTWSPEC(VATMP, PRCNTG, VAMAPWS) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Andy Saulter | -!/ | FORTRAN 90 | -!/ | Original code : 24-Oct-2018 | -!/ | Last update : 05-Oct-2019 | -!/ +-----------------------------------+ -!/ -!/ 24-Oct-2018 : Original Code ( version 6.07 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! Updates the wind-sea part of the wave spectrum only -! 2. Method : -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/T -! -! 10. Source code : -! -!/ - REAL, DIMENSION(:), INTENT(INOUT) :: VATMP - INTEGER, DIMENSION(:), INTENT(IN) :: VAMAPWS - REAL, INTENT(IN) :: PRCNTG - CHARACTER(25),PARAMETER :: myname='UPDTWSPEC' -! + WRITE (NDSO,*) trim(myname), ' ends' +#endif + END SUBROUTINE UVTOCART + !/ + !/ ------------------------------------------------------------------- / + !/ + !> @brief Updates the wind-sea part of the wave spectrum only. + !> + !> @param[inout] VATMP + !> @param[in] PRCNTG + !> @param[in] VAMAPWS + !> + !> @author Andy Saulter @date 05-Oct-2019 + !> + !> + SUBROUTINE UPDTWSPEC(VATMP, PRCNTG, VAMAPWS) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Andy Saulter | + !/ | FORTRAN 90 | + !/ | Original code : 24-Oct-2018 | + !/ | Last update : 05-Oct-2019 | + !/ +-----------------------------------+ + !/ + !/ 24-Oct-2018 : Original Code ( version 6.07 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! Updates the wind-sea part of the wave spectrum only + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/T + ! + ! 10. Source code : + ! + !/ + REAL, DIMENSION(:), INTENT(INOUT) :: VATMP + INTEGER, DIMENSION(:), INTENT(IN) :: VAMAPWS + REAL, INTENT(IN) :: PRCNTG + CHARACTER(25),PARAMETER :: myname='UPDTWSPEC' + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' starts' -#endif - DO IK=1, NK - DO ITH=1, NTH - IF ( VAMAPWS(ITH+(IK-1)*NTH) .EQ. 1 ) THEN - VATMP(ITH+(IK-1)*NTH) = VATMP(ITH+(IK-1)*NTH) * PRCNTG**2 - END IF - END DO - END DO -! + WRITE (NDSO,*) trim(myname), ' starts' +#endif + DO IK=1, NK + DO ITH=1, NTH + IF ( VAMAPWS(ITH+(IK-1)*NTH) .EQ. 1 ) THEN + VATMP(ITH+(IK-1)*NTH) = VATMP(ITH+(IK-1)*NTH) * PRCNTG**2 + END IF + END DO + END DO + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' ends' -#endif - END SUBROUTINE UPDTWSPEC -!/ -!/ ------------------------------------------------------------------- / -!/ -!> @brief Updates the wind-sea part of the wave spectrum and shifts -!> in frequency space. -!> -!> @param[inout] VATMP -!> @param[in] PRCNTG -!> @param[in] VAMAPWS -!> @param[in] ISEA1p -!> @param[in] ADJALL -!> -!> @author Andy Saulter @date 05-Oct-2019 -!> - SUBROUTINE UPDTWSPECF(VATMP, PRCNTG, VAMAPWS, ISEA1p, ADJALL) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Andy Saulter | -!/ | FORTRAN 90 | -!/ | Original code : 24-Oct-2018 | -!/ | Last update : 05-Oct-2019 | -!/ +-----------------------------------+ -!/ -!/ 24-Oct-2018 : Original Code ( version 6.07 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! Updates the wind-sea part of the wave spectrum and shifts in frequency -! space -! 2. Method : -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! 5. Called by : -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/T -! -! 10. Source code : -! -!/ - REAL, DIMENSION(:), INTENT(INOUT) :: VATMP - INTEGER, DIMENSION(:), INTENT(IN) :: VAMAPWS - REAL, INTENT(IN) :: PRCNTG - INTEGER, INTENT(IN) :: ISEA1p - LOGICAL, INTENT(IN) :: ADJALL - CHARACTER(25),PARAMETER :: myname='UPDTWSPECF' - REAL :: FFAC, SIGSHFT, FDM1, FDM2, WN1, CG1, WN2, CG2 - INTEGER :: LPF, M1, M2 - REAL, ALLOCATABLE :: VASHFT(:) -! + WRITE (NDSO,*) trim(myname), ' ends' +#endif + END SUBROUTINE UPDTWSPEC + !/ + !/ ------------------------------------------------------------------- / + !/ + !> @brief Updates the wind-sea part of the wave spectrum and shifts + !> in frequency space. + !> + !> @param[inout] VATMP + !> @param[in] PRCNTG + !> @param[in] VAMAPWS + !> @param[in] ISEA1p + !> @param[in] ADJALL + !> + !> @author Andy Saulter @date 05-Oct-2019 + !> + SUBROUTINE UPDTWSPECF(VATMP, PRCNTG, VAMAPWS, ISEA1p, ADJALL) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Andy Saulter | + !/ | FORTRAN 90 | + !/ | Original code : 24-Oct-2018 | + !/ | Last update : 05-Oct-2019 | + !/ +-----------------------------------+ + !/ + !/ 24-Oct-2018 : Original Code ( version 6.07 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! Updates the wind-sea part of the wave spectrum and shifts in frequency + ! space + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! 5. Called by : + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/T + ! + ! 10. Source code : + ! + !/ + REAL, DIMENSION(:), INTENT(INOUT) :: VATMP + INTEGER, DIMENSION(:), INTENT(IN) :: VAMAPWS + REAL, INTENT(IN) :: PRCNTG + INTEGER, INTENT(IN) :: ISEA1p + LOGICAL, INTENT(IN) :: ADJALL + CHARACTER(25),PARAMETER :: myname='UPDTWSPECF' + REAL :: FFAC, SIGSHFT, FDM1, FDM2, WN1, CG1, WN2, CG2 + INTEGER :: LPF, M1, M2 + REAL, ALLOCATABLE :: VASHFT(:) + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' starts' -#endif - DEPTH = MAX( DMIN , -ZB(ISEA1p)) - ALLOCATE(VASHFT(SIZE(VATMP))) - VASHFT(:) = 0.0 -! - ! 1st iteration shifts wind-sea energy in freq space - FFAC = (1. / PRCNTG**2)**(1.0/3.0) ! uses Toba's relationship - DO IK=1, NK - CALL WAVNU1(SIG(IK), DEPTH, WN, CG) - SIGSHFT = FFAC * SIG(IK) - DO ITH=1, NTH - IF ( VAMAPWS(ITH+(IK-1)*NTH) .EQ. 1 ) THEN - ! Interpolate frequency bin according to f-shift - LPF = 1 - DO WHILE (LPF < NK) - IF (SIG(LPF) >= SIGSHFT) THEN - IF (LPF .EQ. 1) THEN - CALL WAVNU1(SIG(LPF), DEPTH, WN1, CG1) - VASHFT(ITH+(LPF-1)*NTH) = VASHFT(ITH+(LPF-1)*NTH) + & - VATMP(ITH+(IK-1)*NTH) * & - (DSIP(IK)*SIG(IK)/CG) / & - (DSIP(LPF)*SIG(LPF)/CG1) - ELSE - M2 = LPF - M1 = LPF - 1 - FDM1 = SIGSHFT - SIG(M1) - FDM2 = SIG(M2) - SIG(M1) - CALL WAVNU1(SIG(M1), DEPTH, WN1, CG1) - CALL WAVNU1(SIG(M2), DEPTH, WN2, CG2) - VASHFT(ITH+(M1-1)*NTH) = VASHFT(ITH+(M1-1)*NTH) + & - (FDM1 / FDM2) * & - VATMP(ITH+(IK-1)*NTH) * & - (DSIP(IK)*SIG(IK)/CG) / & - (DSIP(M1)*SIG(M1)/CG1) - VASHFT(ITH+(M2-1)*NTH) = VASHFT(ITH+(M2-1)*NTH) + & - (1.0 - FDM1 / FDM2) * & - VATMP(ITH+(IK-1)*NTH) * & - (DSIP(IK)*SIG(IK)/CG) / & - (DSIP(M2)*SIG(M2)/CG2) - END IF - LPF = NK + 1 - ENDIF - LPF = LPF + 1 - END DO - IF (LPF .EQ. NK) THEN - CALL WAVNU1(SIG(LPF), DEPTH, WN1, CG1) - VASHFT(ITH+(LPF-1)*NTH) = VASHFT(ITH+(LPF-1)*NTH) + & - VATMP(ITH+(IK-1)*NTH) * & - (DSIP(IK)*SIG(IK)/CG) / & - (DSIP(LPF)*SIG(LPF)/CG1) - END IF - END IF - END DO - END DO - ! 2nd iteration scales wind-sea energy - DO IK=1, NK - DO ITH=1, NTH - IF ( VAMAPWS(ITH+(IK-1)*NTH) .EQ. 1 ) THEN - VASHFT(ITH+(IK-1)*NTH) = VASHFT(ITH+(IK-1)*NTH) * PRCNTG**2 - END IF - END DO - END DO - ! 3rd iteration combines wind-sea and swell energy - DO IK=1, NK - DO ITH=1, NTH - IF ( VAMAPWS(ITH+(IK-1)*NTH) .EQ. 1 ) THEN - VATMP(ITH+(IK-1)*NTH) = VASHFT(ITH+(IK-1)*NTH) - ELSE - IF ( ADJALL ) THEN - ! Swell components are also re-scaled - VATMP(ITH+(IK-1)*NTH) = VATMP(ITH+(IK-1)*NTH) * & - PRCNTG**2 + & - VASHFT(ITH+(IK-1)*NTH) - ELSE - ! Re-scaling wind-sea only - VATMP(ITH+(IK-1)*NTH) = VATMP(ITH+(IK-1)*NTH) + & - VASHFT(ITH+(IK-1)*NTH) - END IF - END IF - END DO - END DO -! - DEALLOCATE(VASHFT) -! + WRITE (NDSO,*) trim(myname), ' starts' +#endif + DEPTH = MAX( DMIN , -ZB(ISEA1p)) + ALLOCATE(VASHFT(SIZE(VATMP))) + VASHFT(:) = 0.0 + ! + ! 1st iteration shifts wind-sea energy in freq space + FFAC = (1. / PRCNTG**2)**(1.0/3.0) ! uses Toba's relationship + DO IK=1, NK + CALL WAVNU1(SIG(IK), DEPTH, WN, CG) + SIGSHFT = FFAC * SIG(IK) + DO ITH=1, NTH + IF ( VAMAPWS(ITH+(IK-1)*NTH) .EQ. 1 ) THEN + ! Interpolate frequency bin according to f-shift + LPF = 1 + DO WHILE (LPF < NK) + IF (SIG(LPF) >= SIGSHFT) THEN + IF (LPF .EQ. 1) THEN + CALL WAVNU1(SIG(LPF), DEPTH, WN1, CG1) + VASHFT(ITH+(LPF-1)*NTH) = VASHFT(ITH+(LPF-1)*NTH) + & + VATMP(ITH+(IK-1)*NTH) * & + (DSIP(IK)*SIG(IK)/CG) / & + (DSIP(LPF)*SIG(LPF)/CG1) + ELSE + M2 = LPF + M1 = LPF - 1 + FDM1 = SIGSHFT - SIG(M1) + FDM2 = SIG(M2) - SIG(M1) + CALL WAVNU1(SIG(M1), DEPTH, WN1, CG1) + CALL WAVNU1(SIG(M2), DEPTH, WN2, CG2) + VASHFT(ITH+(M1-1)*NTH) = VASHFT(ITH+(M1-1)*NTH) + & + (FDM1 / FDM2) * & + VATMP(ITH+(IK-1)*NTH) * & + (DSIP(IK)*SIG(IK)/CG) / & + (DSIP(M1)*SIG(M1)/CG1) + VASHFT(ITH+(M2-1)*NTH) = VASHFT(ITH+(M2-1)*NTH) + & + (1.0 - FDM1 / FDM2) * & + VATMP(ITH+(IK-1)*NTH) * & + (DSIP(IK)*SIG(IK)/CG) / & + (DSIP(M2)*SIG(M2)/CG2) + END IF + LPF = NK + 1 + ENDIF + LPF = LPF + 1 + END DO + IF (LPF .EQ. NK) THEN + CALL WAVNU1(SIG(LPF), DEPTH, WN1, CG1) + VASHFT(ITH+(LPF-1)*NTH) = VASHFT(ITH+(LPF-1)*NTH) + & + VATMP(ITH+(IK-1)*NTH) * & + (DSIP(IK)*SIG(IK)/CG) / & + (DSIP(LPF)*SIG(LPF)/CG1) + END IF + END IF + END DO + END DO + ! 2nd iteration scales wind-sea energy + DO IK=1, NK + DO ITH=1, NTH + IF ( VAMAPWS(ITH+(IK-1)*NTH) .EQ. 1 ) THEN + VASHFT(ITH+(IK-1)*NTH) = VASHFT(ITH+(IK-1)*NTH) * PRCNTG**2 + END IF + END DO + END DO + ! 3rd iteration combines wind-sea and swell energy + DO IK=1, NK + DO ITH=1, NTH + IF ( VAMAPWS(ITH+(IK-1)*NTH) .EQ. 1 ) THEN + VATMP(ITH+(IK-1)*NTH) = VASHFT(ITH+(IK-1)*NTH) + ELSE + IF ( ADJALL ) THEN + ! Swell components are also re-scaled + VATMP(ITH+(IK-1)*NTH) = VATMP(ITH+(IK-1)*NTH) * & + PRCNTG**2 + & + VASHFT(ITH+(IK-1)*NTH) + ELSE + ! Re-scaling wind-sea only + VATMP(ITH+(IK-1)*NTH) = VATMP(ITH+(IK-1)*NTH) + & + VASHFT(ITH+(IK-1)*NTH) + END IF + END IF + END DO + END DO + ! + DEALLOCATE(VASHFT) + ! #ifdef W3_T - WRITE (NDSO,*) trim(myname), ' ends' -#endif - END SUBROUTINE UPDTWSPECF -!/ -!/ ------------------------------------------------------------------- / -!/ -!> @brief Writes a 2D array to text file, column by column. -!> -!> @param[inout] FILENAME Path to the output file. -!> @param[inout] RDA_A 2D array to write. -!> -!> @author Stelios Flampouris @date 15-Mar-2017 -!> - SUBROUTINE WRITEMATRIX(FILENAME, RDA_A) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | Stelios Flampouris | -!/ | FORTRAN 90 | -!/ | Last update : 15-Mar-2017 | -!/ +-----------------------------------+ -!/ -!/ 15-Mar-2017 : Original Code ( version 6.04 ) -!/ -!/ Copyright 2010 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! Writes a 2D array to text file, column by column -! 2. Method : -! -! 3. Parameters : -! fileName path to the output file -! rda_A 2D array to write -! -! Local parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! ---------------------------------------------------------------- -! Internal Subroutines: -! -! 5. Called by : -! Any routine that has to write 2d arrays !?! -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/T -! -! 10. Source code : -! -!/ - REAL, DIMENSION(:, :), INTENT(IN) :: RDA_A - CHARACTER(*) , INTENT(IN) :: FILENAME - INTEGER IB_I, IB_J, IL_IOS - INTEGER, PARAMETER :: IP_FID = 123 -! - OPEN( UNIT = IP_FID, FILE = FILENAME, STATUS = 'REPLACE', & - FORM = 'FORMATTED', IOSTAT = IL_IOS) - IF (IL_IOS /= 0) PRINT*,'In writeMatrix : Error creating file'//FILENAME - DO IB_J = 1, SIZE(RDA_A,2) - DO IB_I = 1, SIZE(RDA_A,1) -! write(unit=ip_fid, fmt='(I, $)') rda_A(ib_i,ib_j) - WRITE(UNIT=IP_FID, FMT='(E18.8, $)') RDA_A(IB_I,IB_J) - END DO - WRITE(UNIT=IP_FID, FMT=*)'' - END DO - CLOSE(IP_FID) -! - END SUBROUTINE WRITEMATRIX -!/ -!/ ------------------------------------------------------------------- / -!/ - END PROGRAM W3UPRSTR + WRITE (NDSO,*) trim(myname), ' ends' +#endif + END SUBROUTINE UPDTWSPECF + !/ + !/ ------------------------------------------------------------------- / + !/ + !> @brief Writes a 2D array to text file, column by column. + !> + !> @param[inout] FILENAME Path to the output file. + !> @param[inout] RDA_A 2D array to write. + !> + !> @author Stelios Flampouris @date 15-Mar-2017 + !> + SUBROUTINE WRITEMATRIX(FILENAME, RDA_A) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | Stelios Flampouris | + !/ | FORTRAN 90 | + !/ | Last update : 15-Mar-2017 | + !/ +-----------------------------------+ + !/ + !/ 15-Mar-2017 : Original Code ( version 6.04 ) + !/ + !/ Copyright 2010 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! Writes a 2D array to text file, column by column + ! 2. Method : + ! + ! 3. Parameters : + ! fileName path to the output file + ! rda_A 2D array to write + ! + ! Local parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! ---------------------------------------------------------------- + ! Internal Subroutines: + ! + ! 5. Called by : + ! Any routine that has to write 2d arrays !?! + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/T + ! + ! 10. Source code : + ! + !/ + REAL, DIMENSION(:, :), INTENT(IN) :: RDA_A + CHARACTER(*) , INTENT(IN) :: FILENAME + INTEGER IB_I, IB_J, IL_IOS + INTEGER, PARAMETER :: IP_FID = 123 + ! + OPEN( UNIT = IP_FID, FILE = FILENAME, STATUS = 'REPLACE', & + FORM = 'FORMATTED', IOSTAT = IL_IOS) + IF (IL_IOS /= 0) PRINT*,'In writeMatrix : Error creating file'//FILENAME + DO IB_J = 1, SIZE(RDA_A,2) + DO IB_I = 1, SIZE(RDA_A,1) + ! write(unit=ip_fid, fmt='(I, $)') rda_A(ib_i,ib_j) + WRITE(UNIT=IP_FID, FMT='(E18.8, $)') RDA_A(IB_I,IB_J) + END DO + WRITE(UNIT=IP_FID, FMT=*)'' + END DO + CLOSE(IP_FID) + ! + END SUBROUTINE WRITEMATRIX + !/ + !/ ------------------------------------------------------------------- / + !/ +END PROGRAM W3UPRSTR